]> git.uio.no Git - u/mrichter/AliRoot.git/blame_incremental - PYTHIA6/pythia6.4.21/pythia-6.4.21.f
git://git.uio.no / u / mrichter / AliRoot.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
Protection against division by 0
[u/mrichter/AliRoot.git] / PYTHIA6 / pythia6.4.21 / pythia-6.4.21.f
... / ...
CommitLineData
1C*********************************************************************
2C*********************************************************************
3C* **
4C* Jul 2009 **
5C* **
6C* The Lund Monte Carlo **
7C* **
8C* PYTHIA version 6.4 **
9C* **
10C* Torbjorn Sjostrand **
11C* Department of Theoretical Physics **
12C* Lund University **
13C* Solvegatan 14A, S-223 62 Lund, Sweden **
14C* E-mail torbjorn@thep.lu.se **
15C* **
16C* SUSY and Technicolor parts by **
17C* Stephen Mrenna **
18C* Computing Division **
19C* Generators and Detector Simulation Group **
20C* Fermi National Accelerator Laboratory **
21C* MS 234, Batavia, IL 60510, USA **
22C* phone + 1 - 630 - 840 - 2556 **
23C* E-mail mrenna@fnal.gov **
24C* **
25C* New multiple interactions and more SUSY parts by **
26C* Peter Skands **
27C* Theoretical Physics Department **
28C* Fermi National Accelerator Laboratory **
29C* MS 106, Batavia, IL 60510, USA **
30C* and **
31C* CERN/PH, CH-1211 Geneva, Switzerland **
32C* phone +41 - 22 - 767 24 59 **
33C* E-mail skands@fnal.gov **
34C* **
35C* Several parts are written by Hans-Uno Bengtsson **
36C* PYSHOW is written together with Mats Bengtsson **
37C* PYMAEL is written by Emanuel Norrbin **
38C* advanced popcorn baryon production written by Patrik Eden **
39C* code for virtual photons mainly written by Christer Friberg **
40C* code for low-mass strings mainly written by Emanuel Norrbin **
41C* Bose-Einstein code mainly written by Leif Lonnblad **
42C* CTEQ parton distributions are by the CTEQ collaboration **
43C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
44C* SaS photon parton distributions together with Gerhard Schuler **
45C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
46C* MSSM Higgs mass calculation code by M. Carena, **
47C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
48C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
49C* PYGAUS adapted from CERN library (K.S. Kolbig) **
50C* NRQCD/colour octet production of onium by S. Wolf **
51C* **
52C* The latest program version and documentation is found on WWW **
53C* http://www.thep.lu.se/~torbjorn/Pythia.html **
54C* **
55C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2008 **
56C* **
57C*********************************************************************
58C*********************************************************************
59C *
60C List of subprograms in order of appearance, with main purpose *
61C (S = subroutine, F = function, B = block data) *
62C *
63C B PYDATA to contain all default values *
64C S PYCKBD to check that BLOCK DATA has been correctly loaded *
65C S PYTEST to test the proper functioning of the package *
66C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
67C *
68C S PYINIT to administer the initialization procedure *
69C S PYEVNT to administer the generation of an event *
70C S PYEVNW ditto, for new multiple interactions scenario *
71C S PYSTAT to print cross-section and other information *
72C S PYUPEV to administer the generation of an LHA hard process *
73C S PYUPIN to provide initialization needed for LHA input *
74C S PYLHEF to produce a Les Houches Event File from run *
75C S PYINRE to initialize treatment of resonances *
76C S PYINBM to read in beam, target and frame choices *
77C S PYINKI to initialize kinematics of incoming particles *
78C S PYINPR to set up the selection of included processes *
79C S PYXTOT to give total, elastic and diffractive cross-sect. *
80C S PYMAXI to find differential cross-section maxima *
81C S PYPILE to select multiplicity of pileup events *
82C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
83C S PYGAGA to handle lepton -> lepton + gamma branchings *
84C S PYRAND to select subprocess and kinematics for event *
85C S PYSCAT to set up kinematics and colour flow of event *
86C S PYEVOL handler for pT-ordered ISR and multiple interactions *
87C S PYSSPA to simulate initial state spacelike showers *
88C S PYPTIS to do pT-ordered initial state spacelike showers *
89C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
90C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
91C S PYPTMI to do pT-ordered multiple interactions *
92C F PYFCMP to give companion quark x*f distribution *
93C F PYPCMP to calculate momentum integral for companion quarks *
94C S PYUPRE to rearranges contents of the HEPEUP commonblock *
95C S PYADSH to administrate sequential final-state showers *
96C S PYVETO to allow the generation of an event to be aborted *
97C S PYRESD to perform resonance decays *
98C S PYMULT to generate multiple interactions - old scheme *
99C S PYREMN to add on target remnants - old scheme *
100C S PYMIGN to generate multiple interactions - new scheme *
101C S PYMIHK to connect colours in mult. int. - new scheme *
102C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
103C S PYMIHG to collapse two pairs of LHA1 colour tags. *
104C S PYMIRM to add on target remnants in mult. int.- new scheme *
105C S PYFSCR to perform final state colour reconnections - -"- *
106C S PYDIFF to set up kinematics for diffractive events *
107C S PYDISG to set up kinematics, remnant and showers for DIS *
108C S PYDOCU to compute cross-sections and handle documentation *
109C S PYFRAM to perform boosts between different frames *
110C S PYWIDT to calculate full and partial widths of resonances *
111C S PYOFSH to calculate partial width into off-shell channels *
112C S PYRECO to handle colour reconnection in W+W- events *
113C S PYKLIM to calculate borders of allowed kinematical region *
114C S PYKMAP to construct value of kinematical variable *
115C S PYSIGH to calculate differential cross-sections *
116C S PYSGQC auxiliary to PYSIGH for QCD processes *
117C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
118C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
119C S PYSGHG auxiliary to PYSIGH for Higgs processes *
120C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
121C S PYSGTC auxiliary to PYSIGH for technicolor processes *
122C S PYSGEX auxiliary to PYSIGH for various exotic processes *
123C S PYPDFU to evaluate parton distributions *
124C S PYPDFL to evaluate parton distributions at low x and Q^2 *
125C S PYPDEL to evaluate electron parton distributions *
126C S PYPDGA to evaluate photon parton distributions (generic) *
127C S PYGGAM to evaluate photon parton distributions (SaS sets) *
128C S PYGVMD to evaluate VMD part of photon parton distributions *
129C S PYGANO to evaluate anomalous part of photon PDFs *
130C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
131C S PYGDIR to evaluate direct contribution to photon PDFs *
132C S PYPDPI to evaluate pion parton distributions *
133C S PYPDPR to evaluate proton parton distributions *
134C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
135C S PYGRVL to evaluate the GRV 94L proton parton distributions *
136C S PYGRVM to evaluate the GRV 94M proton parton distributions *
137C S PYGRVD to evaluate the GRV 94D proton parton distributions *
138C F PYGRVV auxiliary to the PYGRV* routines *
139C F PYGRVW auxiliary to the PYGRV* routines *
140C F PYGRVS auxiliary to the PYGRV* routines *
141C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
142C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
143C S PYPDPO to evaluate old proton parton distributions *
144C F PYHFTH to evaluate threshold factor for heavy flavour *
145C S PYSPLI to find flavours left in hadron when one removed *
146C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
147C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
148C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
149C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
150C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
151C S PYSTBH to evaluate matrix element for t + b + H processes *
152C S PYTBHB auxiliary to PYSTBH *
153C S PYTBHG auxiliary to PYSTBH *
154C S PYTBHQ auxiliary to PYSTBH *
155C F PYTBHS auxiliary to PYSTBH *
156C *
157C S PYMSIN to initialize the supersymmetry simulation *
158C S PYSLHA to interface to SUSY spectrum and decay calculators *
159C S PYAPPS to determine MSSM parameters from SUGRA input *
160C S PYSUGI to determine MSSM parameters using ISASUSY *
161C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
162C F PYRNMQ to determine running squark masses *
163C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
164C S PYINOM to calculate neutralino/chargino mass eigenstates *
165C F PYRNM3 to determine running M3, gluino mass *
166C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
167C S PYHGGM to determine Higgs mass spectrum *
168C S PYSUBH to determine Higgs masses in the MSSM *
169C S PYPOLE to determine Higgs masses in the MSSM *
170C S PYRGHM auxiliary to PYPOLE *
171C S PYGFXX auxiliary to PYRGHM *
172C F PYFINT auxiliary to PYPOLE *
173C F PYFISB auxiliary to PYFINT *
174C S PYSFDC to calculate sfermion decay partial widths *
175C S PYGLUI to calculate gluino decay partial widths *
176C S PYTBBN to calculate 3-body decay of gluino to neutralino *
177C S PYTBBC to calculate 3-body decay of gluino to chargino *
178C S PYNJDC to calculate neutralino decay partial widths *
179C S PYCJDC to calculate chargino decay partial widths *
180C F PYXXZ6 auxiliary for ino 3-body decays *
181C F PYXXGA auxiliary for ino -> ino + gamma decay *
182C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
183C F PYX2XH auxiliary for ino -> ino + Higgs decay *
184C S PYHEXT to calculate non-SM Higgs decay partial widths *
185C F PYH2XX auxiliary for H -> ino + ino decay *
186C F PYGAUS to perform Gaussian integration *
187C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
188C F PYSIMP to perform Simpson integration *
189C F PYLAMF to evaluate the lambda kinematics function *
190C S PYTBDY to perform 3-body decay of gauginos *
191C S PYTECM to calculate techni_rho/omega masses *
192C S PYXDIN to initialize Universal Extra Dimensions *
193C S PYUEDC to compute UED mass radiative corrections *
194C S PYXUED to compute UED cross sections *
195C S PYGRAM to generate UED G* (excited graviton) mass spectrum *
196C F PYGRAW to compute UED partial widths to G* *
197C F PYWDKK to compute UED differential partial widths to G* *
198C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
199C S PYCMQR auxiliary to PYEICG *
200C S PYCMQ2 auxiliary to PYEICG *
201C S PYCDIV auxiliary to PYCMQR *
202C S PYCSRT auxiliary to PYCMQR *
203C S PYTHAG auxiliary to PYCMQR *
204C S PYCBAL auxiliary to PYEICG *
205C S PYCBA2 auxiliary to PYEICG *
206C S PYCRTH auxiliary to PYEICG *
207C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
208C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
209C S PYWIDX to calculate decay widths from within PYWIDT *
210C S PYRVSF to calculate R-violating sfermion decay widths *
211C S PYRVNE to calculate R-violating neutralino decay widths *
212C S PYRVCH to calculate R-violating chargino decay widths *
213C S PYRVGL to calculate R-violating gluino decay widths *
214C F PYRVSB auxiliary to PYRVSF *
215C S PYRVGW to calculate R-Violating 3-body widths *
216C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
217C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
218C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
219C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
220C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
221C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
222C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
223C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
224C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
225C *
226C S PY1ENT to fill one entry (= parton or particle) *
227C S PY2ENT to fill two entries *
228C S PY3ENT to fill three entries *
229C S PY4ENT to fill four entries *
230C S PY2FRM to interface to generic two-fermion generator *
231C S PY4FRM to interface to generic four-fermion generator *
232C S PY6FRM to interface to generic six-fermion generator *
233C S PY4JET to generate a shower from a given 4-parton config *
234C S PY4JTW to evaluate the weight od a shower history for above *
235C S PY4JTS to set up the parton configuration for above *
236C S PYJOIN to connect entries with colour flow information *
237C S PYGIVE to fill (or query) commonblock variables *
238C S PYONOF to allow easy control of particle decay modes *
239C S PYTUNE to select a predefined 'tune' for min-bias and UE *
240C S PYEXEC to administrate fragmentation and decay chain *
241C S PYPREP to rearrange showered partons along strings *
242C S PYSTRF to do string fragmentation of jet system *
243C S PYJURF to find boost to string junction rest frame *
244C S PYINDF to do independent fragmentation of one or many jets *
245C S PYDECY to do the decay of a particle *
246C S PYDCYK to select parton and hadron flavours in decays *
247C S PYKFDI to select parton and hadron flavours in fragm *
248C S PYNMES to select number of popcorn mesons *
249C S PYKFIN to calculate falvour prod. ratios from input params. *
250C S PYPTDI to select transverse momenta in fragm *
251C S PYZDIS to select longitudinal scaling variable in fragm *
252C S PYSHOW to do m-ordered timelike parton shower evolution *
253C S PYPTFS to do pT-ordered timelike parton shower evolution *
254C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
255C S PYBOEI to include Bose-Einstein effects (crudely) *
256C S PYBESQ auxiliary to PYBOEI *
257C F PYMASS to give the mass of a particle or parton *
258C F PYMRUN to give the running MSbar mass of a quark *
259C S PYNAME to give the name of a particle or parton *
260C F PYCHGE to give three times the electric charge *
261C F PYCOMP to compress standard KF flavour code to internal KC *
262C S PYERRM to write error messages and abort faulty run *
263C F PYALEM to give the alpha_electromagnetic value *
264C F PYALPS to give the alpha_strong value *
265C F PYANGL to give the angle from known x and y components *
266C F PYR to provide a random number generator *
267C S PYRGET to save the state of the random number generator *
268C S PYRSET to set the state of the random number generator *
269C S PYROBO to rotate and/or boost an event *
270C S PYEDIT to remove unwanted entries from record *
271C S PYLIST to list event record or particle data *
272C S PYLOGO to write a logo *
273C S PYUPDA to update particle data *
274C F PYK to provide integer-valued event information *
275C F PYP to provide real-valued event information *
276C S PYSPHE to perform sphericity analysis *
277C S PYTHRU to perform thrust analysis *
278C S PYCLUS to perform three-dimensional cluster analysis *
279C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
280C S PYJMAS to give high and low jet mass of event *
281C S PYFOWO to give Fox-Wolfram moments *
282C S PYTABU to analyze events, with tabular output *
283C *
284C S PYEEVT to administrate the generation of an e+e- event *
285C S PYXTEE to give the total cross-section at given CM energy *
286C S PYRADK to generate initial state photon radiation *
287C S PYXKFL to select flavour of primary qqbar pair *
288C S PYXJET to select (matrix element) jet multiplicity *
289C S PYX3JT to select kinematics of three-jet event *
290C S PYX4JT to select kinematics of four-jet event *
291C S PYXDIF to select angular orientation of event *
292C S PYONIA to perform generation of onium decay to gluons *
293C *
294C S PYBOOK to book a histogram *
295C S PYFILL to fill an entry in a histogram *
296C S PYFACT to multiply histogram contents by a factor *
297C S PYOPER to perform operations between histograms *
298C S PYHIST to print and reset all histograms *
299C S PYPLOT to print a single histogram *
300C S PYNULL to reset contents of a single histogram *
301C S PYDUMP to dump histogram contents onto a file *
302C *
303C S PYSTOP routine to handle Fortran STOP condition *
304C *
305C S PYKCUT dummy routine for user kinematical cuts *
306C S PYEVWT dummy routine for weighting events *
307C S UPINIT dummy routine to initialize user processes *
308C S UPEVNT dummy routine to generate a user process event *
309C S UPVETO dummy routine to abort event at parton level *
310C S PDFSET dummy routine to be removed when using PDFLIB *
311C S STRUCTM dummy routine to be removed when using PDFLIB *
312C S STRUCTP dummy routine to be removed when using PDFLIB *
313C S SUGRA dummy routine to be removed when linking with ISAJET *
314C F VISAJE dummy functn. to be removed when linking with ISAJET *
315C S SSMSSM dummy routine to be removed when linking with ISAJET *
316C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
317C S FHSETPARA dummy routine -"- FEYNHIGGS *
318C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
319C S PYTAUD dummy routine for interface to tau decay libraries *
320C S PYTIME dummy routine for giving date and time *
321C *
322C*********************************************************************
323
324C...PYDATA
325C...Default values for switches and parameters,
326C...and particle, decay and process data.
327
328 BLOCK DATA PYDATA
329
330C...Double precision and integer declarations.
331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
332 IMPLICIT INTEGER(I-N)
333 INTEGER PYK,PYCHGE,PYCOMP
334C...Commonblocks.
335 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
336 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
337 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
338 COMMON/PYDAT4/CHAF(500,2)
339 CHARACTER CHAF*16
340 COMMON/PYDATR/MRPY(6),RRPY(100)
341 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
343 COMMON/PYINT1/MINT(400),VINT(400)
344 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
345 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
346 COMMON/PYINT4/MWID(500),WIDS(500,5)
347 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
348 COMMON/PYINT6/PROC(0:500)
349 CHARACTER PROC*28
350 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
351 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
352 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
353 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
354 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
355 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
356 COMMON/PYPUED/IUED(0:99),RUED(0:99)
357 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
358 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
359 & AU(3,3),AD(3,3),AE(3,3)
360 COMMON/PYLH3C/CPRO(2),CVER(2)
361 CHARACTER CPRO*12,CVER*12
362 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
363 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
364 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
365 &/PYBINS/,/PYLH3P/,/PYLH3C/
366
367C...PYDAT1, containing status codes and most parameters.
368 DATA MSTU/
369 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
370 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
371 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
372 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
373 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
374 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
375 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
376 7 30*0,
377 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
378 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
379 & 80*0/
380 DATA (PARU(I),I=1,100)/
381 & 3.141592653589793D0, 6.283185307179586D0,
382 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
383 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
384 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
385 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
386 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
387 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
388 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
389 6 40*0D0/
390 DATA (PARU(I),I=101,200)/
391 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
392 & 0D0, 0D0, 0D0, 0D0, 0D0,
393 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
394 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
395 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
396 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
397 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
398 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
399 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
400 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
401 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
402 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
403 DATA MSTJ/
404 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
405 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
406 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
407 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
408 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
409 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
410 6 40*0,
411 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
412 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
413 2 80*0/
414 DATA PARJ/
415 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
416 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
417 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
418 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
419 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
420 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
421 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
422 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
423 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
424 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
425 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
426 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
427 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
428 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
429 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
430 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
431 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
432 4 10*0D0,
433 5 10*0D0,
434 6 10*0D0,
435 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
436 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
437 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
438 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
439 9 5*0D0/
440
441C...PYDAT2, with particle data and flavour treatment parameters.
442 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
443 &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,
444 &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,
445 &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0,
446 &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2,
447 &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0,
448 &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3,
449 &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1,
450 &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,
451 &7*0,3,
452C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
453 &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2,
454 &3*-3,0,-3,0,-3,0,-3,
455 &3*0,3,
456 &25*0/
457 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
458 &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
459 &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,
460 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
461 &83*0,12*1,9*0,2,3*0,25*0/
462 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
463 &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0,
464 &2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0,
465 &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,7*0,1,
466 &81*0,21*1,3*0,1,25*0/
467 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
468 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
469 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
470 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
471 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
472 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
473 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
474 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
475 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
476 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
477 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
478 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
479 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
480 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
481 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
482 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
483 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
484 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
485 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
486 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
487 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
488 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
489 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
490 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
491 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
492 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
493 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
494 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
495 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
496 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
497 &3000115,3000215,
498 &81*0,
499C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
500 &6100001,6100002,6100003,6100004,6100005,6100006,
501 &5100001,5100002,5100003,5100004,5100005,5100006,
502 &6100011,6100013,6100015,
503 &5100012,5100011,5100014,5100013,5100016,5100015,
504 &5100021,5100022,5100023,5100024,
505 &25*0/
506 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
507 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
508 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
509 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
510 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
511 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
512 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
513 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
514 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
515 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
516 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
517 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
518 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
519 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
520 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
521 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
522 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
523 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
524 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
525 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
526 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
527 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
528 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
529 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
530 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
531 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
532 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
533 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
534 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
535 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
536 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
537 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
538 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
539 &3*9.5D0,2*250D0,
540 &81*0,
541C...UED
542 &586.,588.,586.,588.,586.,586.,6*598.,
543 &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/
544 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
545 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
546 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
547 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
548 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
549 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
550 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
551 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
552 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
553 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
554 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
555 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
556 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
557 &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
558 &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
559 &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
560 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
561 &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
562 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
563 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
564 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
565 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
566 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
567 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
568 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
569 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
570 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
571 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
572 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
573 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
574 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
575 &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
576 &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
577 &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
578 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
579 &8.80013D0,13*0D0,2.54987D0,2.84456D0,
580 &81*0,
581C...UED
582 &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/
583 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
584 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
585 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
586 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
587 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
588 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
589 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
590 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
591
592 DATA PARF/
593 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
594 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
595 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
596 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
597 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
598 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
599 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
600 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
601 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
602 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
603 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
604 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
605 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
606 3 60*0D0,
607 4 0.2D0, 0.5D0, 8*0D0,
608 5 1800*0D0/
609 DATA ((VCKM(I,J),J=1,4),I=1,4)/
610 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
611 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
612 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
613 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
614
615C...PYDAT3, with particle decay parameters and data.
616 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
617 &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1,
618 &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,
619 &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,8*1,
620 &81*0,
621C...UED
622 &5*1,0,5*1,0,13*1,25*0/
623 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
624 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
625 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
626 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
627 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
628 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
629 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
630 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
631 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
632 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
633 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
634 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
635 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
636 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
637 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
638 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
639 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
640 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
641 &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
642 &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
643 DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
644 &4214,4215,4216,4296,4322,
645 &81*0,
646C...UED
647 %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
648 &5031,5032,5033,
649 &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
650 &25*0/
651 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
652 &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2,
653 &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,
654 &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,
655 &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,
656 &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,
657 &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24,
658 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
659 &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20,
660 &3*22,15,12,2*7,7*0,6*1,26,30,
661 &81*0,
662C...UED
663 &6*2,6*3,9*1,24,1,18,6,25*0/
664 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
665 &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
666 &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
667 &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,
668 &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1,
669 &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
670 &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1,
671 &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1,
672 &5*-1,3*1,-1,
673 &649*0,
674C...UED
675 &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
676 &1,24*1,2912*0/
677 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
678 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
679 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
680 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
681 &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,
682 &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0,
683 &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12,
684 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
685 &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0,
686 &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42,
687 &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
688 &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12,
689 &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32,
690 &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,
691 &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
692 &16*32,
693C...UED
694 &653*0,30*0,9*0,12*0,37*0,2912*0/
695 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
696 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
697 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
698 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
699 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
700 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
701 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
702 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
703 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
704 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
705 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
706 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
707 &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
708 &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
709 &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
710 &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
711 &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
712 &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
713 &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
714 &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
715 DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
716 &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
717 &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
718 &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
719 &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
720 &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
721 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
722 &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
723 &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
724 &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
725 &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
726 &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
727 &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
728 &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
729 &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
730 &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
731 &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
732 &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
733 &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
734 &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
735 DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
736 &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
737 &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
738 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
739 &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
740 &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
741 &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
742 &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
743 &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
744 &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
745 &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
746 &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
747 &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
748 &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
749 &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
750 &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
751 &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
752 &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
753 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
754 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
755 DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
756 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
757 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
758 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
759 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
760 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
761 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
762 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
763 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
764 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
765 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
766 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
767 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
768 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
769 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
770 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
771 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
772 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
773 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
774 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
775 DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
776 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
777 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
778 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
779 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
780 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
781 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
782 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
783 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
784 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
785 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
786 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
787 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
788 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
789 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
790 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
791 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
792 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
793 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
794 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
795 DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
796 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
797 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
798 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
799 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
800 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
801 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
802 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
803 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
804 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
805 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
806 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
807 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
808 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
809 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
810 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
811 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
812 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
813 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
814 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
815 DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
816 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
817 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
818 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
819 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
820 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
821 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
822 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
823 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
824 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
825 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
826 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
827 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
828 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
829 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
830 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
831 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
832 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
833 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
834 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
835 DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
836 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
837 &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
838 &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
839 &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
840 &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
841 &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
842 &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
843 &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
844 &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
845 &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
846 &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
847 &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
848 &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
849 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
850 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
851 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
852 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
853 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
854 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
855 DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
856 &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
857 &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
858 &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
859 &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
860 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
861 &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
862 &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
863 &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
864 &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
865 &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
866 &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
867 &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
868 &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
869 &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
870 &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
871 &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
872 &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
873 &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
874 &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
875 DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
876 &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
877 &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
878 &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
879 &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
880 &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
881 &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
882 &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
883 &2*0.011947D0,0.011946D0,0D0,
884 &649*0.D0,
885C....UED
886 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
887 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
888 &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,
889 &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0,
890 &9*1.D0,
891 &24*0.0416667,
892 &1.,
893 &3*0.D0,6*0.08333D0,
894 &3*0.D0,6*0.08333D0,
895 &6*0.166667D0,
896 &2912*0.D0/
897 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
898 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
899 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
900 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
901 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
902 &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
903 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
904 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
905 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
906 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
907 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
908 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
909 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
910 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
911 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
912 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
913 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
914 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
915 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
916 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
917 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
918 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
919 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
920 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
921 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
922 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
923 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
924 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
925 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
926 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
927 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
928 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
929 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
930 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
931 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
932 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
933 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
934 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
935 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
936 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
937 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
938 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
939 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
940 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
941 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
942 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
943 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
944 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
945 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
946 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
947 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
948 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
949 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
950 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
951 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
952 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
953 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
954 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
955 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
956 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
957 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
958 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
959 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
960 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
961 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
962 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
963 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
964 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
965 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
966 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
967 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
968 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
969 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
970 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
971 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
972 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
973 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
974 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
975 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
976 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
977 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
978 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
979 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
980 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
981 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
982 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
983 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
984 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
985 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
986 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
987 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
988 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
989 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
990 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
991 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
992 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
993 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
994 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
995 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
996 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
997 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
998 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
999 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
1000 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
1001 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
1002 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
1003 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1004 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
1005 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1006 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
1007 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1008 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
1009 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1010 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
1011 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1012 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
1013 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
1014 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
1015 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
1016 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
1017 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
1018 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1019 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
1020 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1021 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
1022 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
1023 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
1024 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
1025 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
1026 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
1027 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
1028 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
1029 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
1030 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
1031 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
1032 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
1033 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
1034 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
1035 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
1036 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
1037 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1038 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1039 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
1040 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
1041 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
1042 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
1043 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1044 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1045 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1046 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1047 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1048 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1049 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1050 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1051 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1052 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1053 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1054 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1055 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1056 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
1057 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1058 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1059 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1060 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1061 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1062 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1063 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1064 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1065 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1066 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1067 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1068 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1069 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1070 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1071 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1072 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1073 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1074 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1075 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1076 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1077 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1078 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1079 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1080 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1081 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1082 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1083 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1084 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1085 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1086 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1087 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1088 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1089 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1090 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1091 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1092 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1093 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1094 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1095 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1096 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1097 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1098 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1099 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1100 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1101 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1102 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1103 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1104 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1105 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1106 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1107 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1108 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1109 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1110 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1111 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1112 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1113 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1114 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1115 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1116 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1117 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1118 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1119 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1120 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1121 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1122 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1123 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1124 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1125 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1126 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1127 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1128 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1129 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1130 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1131 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1132 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1133 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1134 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1135 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1136 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1137 DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
1138 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1139 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1140 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1141 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1142 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1143 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1144 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1145 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1146 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1147 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1148 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1149 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1150 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1151 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1152 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1153 &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,
1154 &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1155 &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1156 &21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
1157 &9*15/
1158 DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11,
1159 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1160 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1161 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1162 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1163 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1164 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1165 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1166 &-11,-13,-15,-17,
1167 &649*0,
1168C...UED
1169 &5100023,5100022,5100023,5100022,5100023,5100022,
1170 &5100023,5100022,5100023,5100022,5100023,5100022,
1171 &5100023,-5100024,5100022,5100023,5100024,5100022,
1172 &5100023,-5100024,5100022,5100023,5100024,5100022,
1173 &5100023,-5100024,5100022,5100023,5100024,5100022,
1174 &9*5100022,
1175 &6100001,6100002,6100003,6100004,6100005,6100006,
1176 &5100001,5100002,5100003,5100004,5100005,5100006,
1177 &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1178 &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
1179 &39,
1180 &6100011,6100013,6100015,
1181 &5100011,5100013,5100015,
1182 %5100012,5100014,5100016,
1183 &-6100011,-6100013,-6100015,
1184 &-5100011,-5100013,-5100015,
1185 %-5100012,-5100014,-5100016,
1186 &-5100011,-5100013,-5100015,
1187 &5100012,5100014,5100016,
1188 &2912*0/
1189 DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
1190 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
1191 &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,
1192 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1193 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1194 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1195 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1196 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1197 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1198 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1199 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1200 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1201 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1202 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1203 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1204 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1205 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1206 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1207 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1208 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/
1209 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1210 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1211 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1212 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1213 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1214 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1215 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1216 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1217 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1218 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1219 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1220 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1221 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1222 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1223 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1224 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1225 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1226 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1227 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1228 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1229 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1230 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1231 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1232 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1233 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1234 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1235 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1236 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1237 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1238 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1239 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1240 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1241 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1242 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1243 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1244 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1245 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1246 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1247 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1248 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1249 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1250 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1251 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1252 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1253 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1254 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1255 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1256 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1257 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1258 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1259 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1260 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1261 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1262 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1263 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1264 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1265 &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11,
1266 &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4,
1267 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
1268 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/
1269 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1270 &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,
1271 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
1272 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
1273 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1274 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1275 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1276 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1277 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1278 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1279 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1280 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1281 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1282 &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,
1283 &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,
1284 &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1285 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3,
1286 &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,
1287 &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,
1288 &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/
1289 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1290 &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
1291 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1292 &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,
1293 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1294 &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
1295 &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,
1296 &5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,
1297 &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,
1298 &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,
1299 &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,
1300 &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,
1301 &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,
1302 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1303 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1304 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1305 &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1306 &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1307 &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1308 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/
1309 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1310 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1311 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1312 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1313 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1314 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1315 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1316 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1317 &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1318 &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1319 &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1320 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,
1321 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1322 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1323 &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
1324 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1325 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1326 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1327 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1328 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1329 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1330 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1331 &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,
1332 &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,
1333 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1334 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1335 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1336 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1337 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1338 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1339 &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,
1340 &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,
1341 &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,
1342 &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,
1343 &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,
1344 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1345 &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
1346 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1347 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1348 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1349 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1350 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1351 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1352 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1353 &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,
1354 &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,
1355 &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,
1356 &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,
1357 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1358 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1359 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1360 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1361 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1362 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1363 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1364 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1365 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1366 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1367 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1368 &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/
1369 DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1370 &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,
1371 &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,
1372 &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1373 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,
1374 &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,
1375 &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,
1376 &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
1377 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1378 &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,
1379 &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,
1380 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1381 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1382 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1383 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1384 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1385 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1386 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3,
1387 &3*-5,3*1,3*3,3*5,-11,11,-15,15,3*-1,3*-3,3*-5,3*1,3*3,3*5,-11,11,
1388 &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1389 DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1390 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1391 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1392 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1393 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1394 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1395 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1396 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1397 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1398 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1399 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1400 &649*0,
1401C...UED
1402 &1,1,2,2,3,3,4,4,5,5,6,6,
1403 &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1404 &11,13,15,12,11,14,13,16,15,
1405 &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1406 &1,2,3,4,5,6,1,2,3,4,5,6,
1407 &22,
1408 &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1409 &11,13,15,11,13,15,12,14,16,
1410 &12,14,16,-11,-13,-15,
1411 &2912*0/
1412 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1413 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1414 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1415 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1416 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1417 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1418 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1419 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1420 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1421 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1422 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1423 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1424 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1425 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1426 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1427 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1428 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1429 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1430 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1431 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1432 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1433 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1434 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1435 &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
1436 &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
1437 &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1438 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1439 &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1440 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1441 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1442 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1443 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1444 &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,
1445 &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1446 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1447 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1448 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,
1449 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1450 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1451 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1452 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1453 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1454 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1455 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,
1456 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1457 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1458 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1459 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1460 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1461 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1462 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1463 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1464 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1465 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2,
1466 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1467 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1468 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1469 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1470 &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1471 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/
1472 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1473 &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,
1474 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1475 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1476 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1477 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1478 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1479 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1480 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1481 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1482 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1483 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1484 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1485 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1486 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1487 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1488 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1489 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1490 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,
1491 &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1492 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1493 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,
1494 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1495 &4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
1496 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1497 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1498 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1499 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1500 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1501 &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1502 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,
1503 &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4,
1504 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1505 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1506 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1507 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1508 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1509 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1510 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1511 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1512 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1513 &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,
1514 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1515 &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,
1516 &162*81,31*0,-211,111,6516*0/
1517 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1518 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1519 &3*111,-211,111,7193*0/
1520
1521C...PYDAT4, with particle names (character strings).
1522 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1523 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1524 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1525 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1526 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1527 &'junction',' ','system','cluster','string','indep.','CMshower',
1528 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1529 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1530 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1531 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1532 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1533 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1534 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1535 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1536 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1537 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1538 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1539 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1540 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1541 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1542 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1543 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1544 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1545 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1546 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1547 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1548 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1549 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1550 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1551 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1552 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1553 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1554 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1555 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1556 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1557 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1558 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1559 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1560 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1561 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1562 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1563 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1564 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1565 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1566 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1567 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1568 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1569 &81*' ',
1570C...UED
1571 &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1572 &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1573 &'e*_S-','mu*_S-','tau*_S-',
1574 &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1575 &'g*','gamma*','Z*0','W*+',25*' '/
1576 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1577 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1578 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1579 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1580 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1581 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1582 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1583 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1584 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1585 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1586 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1587 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1588 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1589 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1590 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1591 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1592 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1593 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1594 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1595 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1596 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1597 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1598 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1599 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1600 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1601 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1602 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1603 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1604 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1605 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1606 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1607 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1608 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1609 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1610 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1611 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1612 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1613 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1614 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1615 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1616 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1617 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1618 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1619 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1620 &81*' ',
1621C...UED
1622 &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1623 &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1624 &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1625 &'nu*_eDbar','e*_Dbar+',
1626 &'nu*_muDbar','mu*_Dbar+',
1627 &'nu*_tauDbar','tau*_Dbar+',
1628 &'g*','gamma*','Z*0','W*-',25*' '/
1629
1630C...PYDATR, with initial values for the random number generator.
1631 DATA MRPY/19780503,0,0,97,33,0/
1632
1633C...Default values for allowed processes and kinematics constraints.
1634 DATA MSEL/1/
1635 DATA MSUB/500*0/
1636 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1637 &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,
1638 &6*1,4*0,4*1,16*0/
1639 DATA CKIN/
1640 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1641 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1642 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1643 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1644 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1645 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1646 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1647 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1648 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1649 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1650 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1651 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1652 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1653 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1654 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1655 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1656 8 120*0D0/
1657
1658C...Default values for main switches and parameters. Reset information.
1659 DATA (MSTP(I),I=1,100)/
1660 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1661 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1662 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1663 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1664 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1665 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1666 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1667 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1668 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1669 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1670 DATA (MSTP(I),I=101,200)/
1671 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1672 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1673 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1674 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1675 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1676 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1677 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1678 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1679 8 6, 421, 2009, 07, 13, 0, 0, 0, 0, 0,
1680 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1681 DATA (PARP(I),I=1,100)/
1682 & 0.25D0, 10D0, 8*0D0,
1683 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1684 2 10*0D0,
1685 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1686 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1687 5 10*0D0,
1688 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1689 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1690 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1691 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0,
1692 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1693 DATA (PARP(I),I=101,200)/
1694 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1695 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1696 2 1.0D0, 0.4D0, 8*0D0,
1697 3 0.01D0, 9*0D0,
1698 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1699 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1700 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1701 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1702 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1703 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1704 8 0.3D0, 0.64D0,
1705 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1706 DATA MSTI/200*0/
1707 DATA PARI/200*0D0/
1708 DATA MINT/400*0/
1709 DATA VINT/400*0D0/
1710
1711C...Constants for the generation of the various processes.
1712 DATA (ISET(I),I=1,100)/
1713 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1714 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1715 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1716 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1717 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1718 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1719 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1720 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1721 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1722 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1723 DATA (ISET(I),I=101,200)/
1724 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1725 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1726 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1727 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1728 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1729 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1730 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1731 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1732 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1733 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1734 DATA (ISET(I),I=201,300)/
1735 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1736 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1737 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1738 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1739 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1740 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1741 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1742 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1743 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1744 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1745 DATA (ISET(I),I=301,500)/
1746 & 2, 9*-2, 9*2, 21*-2,
1747 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1748 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1749 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1750 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1751 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1752 9 1, 1, 2, 2, 2, 5*-2,
1753 & 5, 5, 18*-2,
1754 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1755 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1756 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1757 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1758 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1759 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1760 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1761 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1762 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1763 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1764 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1765 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1766 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1767 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1768 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1769 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1770 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1771 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1772 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1773 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1774 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1775 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1776 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1777 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1778 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1779 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1780 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1781 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1782 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1783 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1784 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1785 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1786 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1787 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1788 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1789 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1790 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1791 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1792 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1793 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1794 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1795 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1796 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1797 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1798 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1799 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1800 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1801 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1802 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1803 & 1000011, 1000011, 2000011, 2000011, 1000011,
1804 & 2000011, 1000013, 1000013, 2000013, 2000013,
1805 & 1000013, 2000013, 1000015, 1000015, 2000015,
1806 & 2000015, 1000015, 2000015, 1000011, 1000012,
1807 1 1000015, 1000016, 2000015, 1000016, 1000012,
1808 1 1000012, 1000016, 1000016, 0, 0,
1809 1 1000022, 1000022, 1000023, 1000023, 1000025,
1810 1 1000025, 1000035, 1000035, 1000022, 1000023,
1811 2 1000022, 1000025, 1000022, 1000035, 1000023,
1812 2 1000025, 1000023, 1000035, 1000025, 1000035,
1813 2 1000024, 1000024, 1000037, 1000037, 1000024,
1814 2 1000037, 1000022, 1000024, 1000023, 1000024,
1815 3 1000025, 1000024, 1000035, 1000024, 1000022,
1816 3 1000037, 1000023, 1000037, 1000025, 1000037,
1817 3 1000035, 1000037, 1000021, 1000022, 1000021,
1818 3 1000023, 1000021, 1000025, 1000021, 1000035/
1819 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1820 4 1000021, 1000024, 1000021, 1000037, 1000021,
1821 4 1000021, 1000021, 1000021, 0, 0,
1822 4 1000002, 1000022, 2000002, 1000022, 1000002,
1823 4 1000023, 2000002, 1000023, 1000002, 1000025,
1824 5 2000002, 1000025, 1000002, 1000035, 2000002,
1825 5 1000035, 1000001, 1000024, 2000005, 1000024,
1826 5 1000001, 1000037, 2000005, 1000037, 1000002,
1827 5 1000021, 2000002, 1000021, 0, 0,
1828 6 1000006, 1000006, 2000006, 2000006, 1000006,
1829 6 2000006, 1000006, 1000006, 2000006, 2000006,
1830 6 0, 0, 0, 0, 0,
1831 6 0, 0, 0, 0, 0,
1832 7 1000002, 1000002, 2000002, 2000002, 1000002,
1833 7 2000002, 1000002, 1000002, 2000002, 2000002,
1834 7 1000002, 2000002, 1000002, 1000002, 2000002,
1835 7 2000002, 1000002, 1000002, 2000002, 2000002/
1836 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1837 8 1000005, 1000002, 2000005, 2000002, 1000005,
1838 8 2000002, 1000005, 1000002, 2000005, 2000002,
1839 8 1000005, 2000002, 1000005, 1000005, 2000005,
1840 8 2000005, 1000005, 1000005, 2000005, 2000005,
1841 9 1000005, 1000005, 2000005, 2000005, 1000005,
1842 9 2000005, 1000005, 1000021, 2000005, 1000021,
1843 9 1000005, 2000005, 37, 25, 37,
1844 9 35, 36, 25, 36, 35,
1845 & 37, 37, 18*0,
1846C...UED: 311-319
1847 & 5100021, 5100021,
1848 & 5100002, 5100021,
1849 & 5100002, 5100001,
1850 & 5100002, -5100002,
1851 & 5100002, -5100002,
1852 & 5100002, -6100001,
1853 & 5100002, -5100001,
1854 & 5100002, 6100001,
1855 & 5100001, -5100001,
1856 & 42*0,
1857 4 9900041, 0, 9900042, 0, 9900041,
1858 4 11, 9900042, 11, 9900041, 13,
1859 4 9900042, 13, 9900041, 15, 9900042,
1860 4 15, 9900041, 9900041, 9900042, 9900042/
1861 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1862 5 9900041, 0, 9900042, 0, 9900023,
1863 5 0, 9900024, 0, 0, 0,
1864 5 0, 0, 0, 0, 0,
1865 5 0, 0, 0, 0, 0,
1866 6 24, 24, 24, 3000211, 3000211,
1867 6 3000211, 22, 3000111, 22, 3000221,
1868 6 23, 3000111, 23, 3000221, 24,
1869 6 3000211, 0, 0, 24, 23,
1870 7 24, 3000111, 3000211, 23, 3000211,
1871 7 3000111, 22, 3000211, 23, 3000211,
1872 7 24, 3000111, 24, 3000221, 22,
1873 7 24, 22, 23, 23, 23,
1874 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1875 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1876 9 5000039, 0, 5000039, 0, 21,
1877 9 5000039, 0, 5000039, 21, 5000039,
1878 9 10*0/
1879 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1880 & 37, 6, 37, 6, 36*0,
1881 2 443, 21, 9900443, 21, 9900441,
1882 2 21, 9910441, 21, 0, 9900443,
1883 2 0, 9900441, 0, 9910441, 21,
1884 2 9900443, 21, 9900441, 21, 9910441,
1885 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1886 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1887 6 553, 21, 9900553, 21, 9900551,
1888 6 21, 9910551, 21, 0, 9900553,
1889 6 0, 9900551, 0, 9910551, 21,
1890 6 9900553, 21, 9900551, 21, 9910551,
1891 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1892 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1893 DATA COEF/10000*0D0/
1894 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1895 &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
1896 &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
1897 &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
1898 &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
1899 &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
1900 &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
1901 &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
1902 &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
1903 &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1904 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
1905
1906C...Treatment of resonances.
1907 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1908 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1909 &81*0,21*1,4*1,25*0/
1910
1911C...Character constants: name of processes.
1912 DATA PROC(0)/ 'All included subprocesses '/
1913 DATA (PROC(I),I=1,20)/
1914 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1915 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1916 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1917 &' ', 'W+ + W- -> h0 ',
1918 &' ', 'f + f'' -> f + f'' (QFD) ',
1919 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1920 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1921 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1922 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1923 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1924 DATA (PROC(I),I=21,40)/
1925 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1926 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1927 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1928 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1929 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1930 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1931 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1932 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1933 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1934 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1935 DATA (PROC(I),I=41,60)/
1936 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1937 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1938 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1939 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1940 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1941 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1942 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1943 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1944 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1945 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1946 DATA (PROC(I),I=61,80)/
1947 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1948 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1949 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1950 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1951 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1952 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1953 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1954 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1955 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1956 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1957 DATA (PROC(I),I=81,100)/
1958 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1959 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1960 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1961 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1962 8'g + g -> chi_2c + g ', ' ',
1963 9'Elastic scattering ', 'Single diffractive (XB) ',
1964 9'Single diffractive (AX) ', 'Double diffractive ',
1965 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1966 9' ', ' ',
1967 9'q + gamma* -> q ', ' '/
1968 DATA (PROC(I),I=101,120)/
1969 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1970 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1971 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1972 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1973 &' ', 'f + fbar -> gamma + h0 ',
1974 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1975 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1976 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1977 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1978 1' ', ' '/
1979 DATA (PROC(I),I=121,140)/
1980 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1981 2'f + f'' -> f + f'' + h0 ',
1982 2'f + f'' -> f" + f"'' + h0 ',
1983 2' ', ' ',
1984 2' ', ' ',
1985 2' ', ' ',
1986 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1987 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1988 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1989 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1990 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1991 DATA (PROC(I),I=141,160)/
1992 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1993 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1994 4'q + l -> LQ ', 'e + gamma -> e* ',
1995 4'd + g -> d* ', 'u + g -> u* ',
1996 4'g + g -> eta_tc ', ' ',
1997 5'f + fbar -> H0 ', 'g + g -> H0 ',
1998 5'gamma + gamma -> H0 ', ' ',
1999 5' ', 'f + fbar -> A0 ',
2000 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
2001 5' ', ' '/
2002 DATA (PROC(I),I=161,180)/
2003 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
2004 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
2005 6'f + fbar -> f'' + fbar'' (g/Z)',
2006 6'f +fbar'' -> f" + fbar"'' (W) ',
2007 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
2008 6'q + qbar -> e + e* ', ' ',
2009 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
2010 7'f + f'' -> f + f'' + H0 ',
2011 7'f + f'' -> f" + f"'' + H0 ',
2012 7' ', 'f + fbar -> Z0 + A0 ',
2013 7'f + fbar'' -> W+/- + A0 ',
2014 7'f + f'' -> f + f'' + A0 ',
2015 7'f + f'' -> f" + f"'' + A0 ',
2016 7' '/
2017 DATA (PROC(I),I=181,200)/
2018 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
2019 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
2020 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
2021 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
2022 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
2023 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
2024 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
2025 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
2026 9' ', ' ',
2027 9' ', ' '/
2028 DATA (PROC(I),I=201,220)/
2029 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
2030 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
2031 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
2032 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
2033 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
2034 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2035 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
2036 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
2037 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
2038 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
2039 DATA (PROC(I),I=221,240)/
2040 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2041 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2042 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2043 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2044 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2045 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2046 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2047 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2048 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
2049 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
2050 DATA (PROC(I),I=241,260)/
2051 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
2052 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
2053 4' ', 'qj + g -> ~qj_L + ~chi1 ',
2054 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
2055 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
2056 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
2057 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
2058 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
2059 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
2060 5'qj + g -> ~qj_R + ~g ', ' '/
2061 DATA (PROC(I),I=261,300)/
2062 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
2063 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
2064 6'g + g -> ~t_2 + ~t_2bar ', ' ',
2065 6' ', ' ',
2066 6' ', ' ',
2067 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
2068 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
2069 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
2070 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
2071 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
2072 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
2073 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
2074 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
2075 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
2076 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
2077 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
2078 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
2079 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
2080 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
2081 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
2082 DATA (PROC(I),I=301,340)/
2083 &'f + fbar -> H+ + H- ',
2084 &9*' ', 'g + g -> g* + g* ',
2085 &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
2086 &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
2087 &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
2088 &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
2089 &21*' '/
2090 DATA (PROC(I),I=341,380)/
2091 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
2092 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
2093 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
2094 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
2095 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
2096 5'f + f -> f'' + f'' + H_L++/-- ',
2097 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
2098 5'f + fbar'' -> W_R+/- ',5*' ',
2099 6' ', 'f + fbar -> W_L+ W_L- ',
2100 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
2101 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
2102 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
2103 6'f + fbar -> W+/- pi_T-/+ ', ' ',
2104 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
2105 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
2106 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
2107 7'f + fbar'' -> W+/- pi_T0 ',
2108 7'f + fbar'' -> W+/- pi_T0'' ',
2109 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2110 7'f + fbar -> Z0 Z0 (ETC) '/
2111 DATA (PROC(I),I=381,420)/
2112 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
2113 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
2114 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
2115 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
2116 8' ', ' ',
2117 9'f + fbar -> G* ', 'g + g -> G* ',
2118 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
2119 9'g + g -> g + G* ', ' ',
2120 9 4*' ',
2121 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
2122 & 18*' '/
2123 DATA (PROC(I),I=421,460)/
2124 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2125 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2126 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2127 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2128 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2129 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2130 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2131 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2132 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2133 3'q + q~ -> g + cc~[3P2(1)] ',
2134 3 21 *' '/
2135 DATA (PROC(I),I=461,500)/
2136 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2137 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2138 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2139 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2140 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2141 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2142 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2143 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2144 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2145 7'q + q~ -> g + bb~[3P2(1)] ',
2146 7 21 *' '/
2147
2148C...Cross sections and slope offsets.
2149 DATA SIGT/294*0D0/
2150
2151C...Supersymmetry switches and parameters.
2152 DATA IMSS/0,
2153 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2154 1 89*0/
2155 DATA RMSS/0D0,
2156 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2157 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2158 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2159 3 10*0D0,
2160 4 0D0,1D0,8*0D0,
2161 5 49*0D0/
2162C...Initial values for R-violating SUSY couplings.
2163C...Should not be changed here. See PYMSIN.
2164 DATA RVLAM/27*0D0/
2165 DATA RVLAMP/27*0D0/
2166 DATA RVLAMB/27*0D0/
2167
2168C...Technicolor switches and parameters
2169 DATA ITCM/0,
2170 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2171 1 89*0/
2172 DATA RTCM/0D0,
2173 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2174 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2175 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2176 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2177 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2178 4 200D0, 48*0D0/
2179
2180C...UED switches and parameters.
2181C... IUED(0) empty IUED vector element
2182C... IUED(1) UED ON(=1)/OFF(=0) switch
2183C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2184C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2185C... IUED(4) N the number of large extra dimensions
2186C... IUED(5) Selects whether the code takes Lambda (=0)
2187C... or Lambda*R (=1) as input.
2188C... IUED(6) With radiative corrections to the masses (=1)
2189C... or without (=0)
2190C...
2191C... RUED(0) empty RUED vector element
2192C... RUED(1) RINV (1/R) the curvature of the extra dimension
2193C... RUED(2) XMD the (4+N)-dimensional Planck scale
2194C... RUED(3) LAMUED (Lambda cutoff scale)
2195C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2196C...
2197 DATA IUED/0,0,0,5,6,0,1,93*0/
2198 DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
2199
2200C...Data for histogramming routines.
2201 DATA IHIST/1000,20000,55,1/
2202 DATA INDX/1000*0/
2203
2204C...Data for SUSY Les Houches Accord.
2205 DATA CPRO/'PYTHIA ','PYTHIA '/
2206 DATA CVER/'6.4 ','6.4 '/
2207 DATA MODSEL/200*0/
2208 DATA PARMIN/100*0D0/
2209 DATA RMSOFT/101*0D0/
2210 DATA AU/9*0D0/
2211 DATA AD/9*0D0/
2212 DATA AE/9*0D0/
2213
2214 END
2215
2216C*********************************************************************
2217
2218C...PYCKBD
2219C...Check that BLOCK DATA PYDATA has been loaded.
2220C...Should not be required, except that some compilers/linkers
2221C...are pretty buggy in this respect.
2222
2223 SUBROUTINE PYCKBD
2224
2225C...Double precision and integer declarations.
2226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2227 IMPLICIT INTEGER(I-N)
2228 INTEGER PYK,PYCHGE,PYCOMP
2229C...Commonblocks.
2230 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2231 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2232 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2233 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2234 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2235 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2236 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2237
2238C...Check a few variables to see they have been sensibly initialized.
2239 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2240 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2241 &MSTP(1).GT.5) THEN
2242C...If not, abort the run right away.
2243 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2244 WRITE(*,*) 'The program execution is stopped now!'
2245 CALL PYSTOP(8)
2246 ENDIF
2247
2248 RETURN
2249 END
2250
2251C*********************************************************************
2252
2253C...PYTEST
2254C...A simple program (disguised as subroutine) to run at installation
2255C...as a check that the program works as intended.
2256
2257 SUBROUTINE PYTEST(MTEST)
2258
2259C...Double precision and integer declarations.
2260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2261 IMPLICIT INTEGER(I-N)
2262 INTEGER PYK,PYCHGE,PYCOMP
2263C...Commonblocks.
2264 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2267 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2268 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2269 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2270 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2271C...Local arrays.
2272 DIMENSION PSUM(5),PINI(6),PFIN(6)
2273
2274C...Save defaults for values that are changed.
2275 MSTJ1=MSTJ(1)
2276 MSTJ3=MSTJ(3)
2277 MSTJ11=MSTJ(11)
2278 MSTJ42=MSTJ(42)
2279 MSTJ43=MSTJ(43)
2280 MSTJ44=MSTJ(44)
2281 PARJ17=PARJ(17)
2282 PARJ22=PARJ(22)
2283 PARJ43=PARJ(43)
2284 PARJ54=PARJ(54)
2285 MST101=MSTJ(101)
2286 MST104=MSTJ(104)
2287 MST105=MSTJ(105)
2288 MST107=MSTJ(107)
2289 MST116=MSTJ(116)
2290
2291C...First part: loop over simple events to be generated.
2292 IF(MTEST.GE.1) CALL PYTABU(20)
2293 NERR=0
2294 DO 180 IEV=1,500
2295
2296C...Reset parameter values. Switch on some nonstandard features.
2297 MSTJ(1)=1
2298 MSTJ(3)=0
2299 MSTJ(11)=1
2300 MSTJ(42)=2
2301 MSTJ(43)=4
2302 MSTJ(44)=2
2303 PARJ(17)=0.1D0
2304 PARJ(22)=1.5D0
2305 PARJ(43)=1D0
2306 PARJ(54)=-0.05D0
2307 MSTJ(101)=5
2308 MSTJ(104)=5
2309 MSTJ(105)=0
2310 MSTJ(107)=1
2311 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2312
2313C...Ten events each for some single jets configurations.
2314 IF(IEV.LE.50) THEN
2315 ITY=(IEV+9)/10
2316 MSTJ(3)=-1
2317 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2318 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2319 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2320 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2321 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2322 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2323
2324C...Ten events each for some simple jet systems; string fragmentation.
2325 ELSEIF(IEV.LE.130) THEN
2326 ITY=(IEV-41)/10
2327 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2328 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2329 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2330 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2331 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2332 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2333 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2334 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2335 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2336
2337C...Seventy events with independent fragmentation and momentum cons.
2338 ELSEIF(IEV.LE.200) THEN
2339 ITY=1+(IEV-131)/16
2340 MSTJ(2)=1+MOD(IEV-131,4)
2341 MSTJ(3)=1+MOD((IEV-131)/4,4)
2342 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2343 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2344 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2345 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2346 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2347 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2348
2349C...A hundred events with random jets (check invariant mass).
2350 ELSEIF(IEV.LE.300) THEN
2351 100 DO 110 J=1,5
2352 PSUM(J)=0D0
2353 110 CONTINUE
2354 NJET=2D0+6D0*PYR(0)
2355 DO 130 I=1,NJET
2356 KFL=21
2357 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2358 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2359 EJET=5D0+20D0*PYR(0)
2360 THETA=ACOS(2D0*PYR(0)-1D0)
2361 PHI=6.2832D0*PYR(0)
2362 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2363 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2364 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2365 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2366 DO 120 J=1,4
2367 PSUM(J)=PSUM(J)+P(I,J)
2368 120 CONTINUE
2369 130 CONTINUE
2370 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2371 & (PSUM(5)+PARJ(32))**2) GOTO 100
2372
2373C...Fifty e+e- continuum events with matrix elements.
2374 ELSEIF(IEV.LE.350) THEN
2375 MSTJ(101)=2
2376 CALL PYEEVT(0,40D0)
2377
2378C...Fifty e+e- continuum event with varying shower options.
2379 ELSEIF(IEV.LE.400) THEN
2380 MSTJ(42)=1+MOD(IEV,2)
2381 MSTJ(43)=1+MOD(IEV/2,4)
2382 MSTJ(44)=MOD(IEV/8,3)
2383 CALL PYEEVT(0,90D0)
2384
2385C...Fifty e+e- continuum events with coherent shower.
2386 ELSEIF(IEV.LE.450) THEN
2387 CALL PYEEVT(0,500D0)
2388
2389C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2390 ELSE
2391 CALL PYONIA(5,9.46D0)
2392 ENDIF
2393
2394C...Generate event. Find total momentum, energy and charge.
2395 DO 140 J=1,4
2396 PINI(J)=PYP(0,J)
2397 140 CONTINUE
2398 PINI(6)=PYP(0,6)
2399 CALL PYEXEC
2400 DO 150 J=1,4
2401 PFIN(J)=PYP(0,J)
2402 150 CONTINUE
2403 PFIN(6)=PYP(0,6)
2404
2405C...Check conservation of energy, momentum and charge;
2406C...usually exact, but only approximate for single jets.
2407 MERR=0
2408 IF(IEV.LE.50) THEN
2409 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2410 & MERR=MERR+1
2411 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2412 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2413 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2414 ELSE
2415 DO 160 J=1,4
2416 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2417 160 CONTINUE
2418 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2419 ENDIF
2420 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2421 & (PFIN(J),J=1,4),PFIN(6)
2422
2423C...Check that all KF codes are known ones, and that partons/particles
2424C...satisfy energy-momentum-mass relation. Store particle statistics.
2425 DO 170 I=1,N
2426 IF(K(I,1).GT.20) GOTO 170
2427 IF(PYCOMP(K(I,2)).EQ.0) THEN
2428 WRITE(MSTU(11),5100) I
2429 MERR=MERR+1
2430 ENDIF
2431 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2432 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2433 & THEN
2434 WRITE(MSTU(11),5200) I
2435 MERR=MERR+1
2436 ENDIF
2437 170 CONTINUE
2438 IF(MTEST.GE.1) CALL PYTABU(21)
2439
2440C...List all erroneous events and some normal ones.
2441 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2442 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2443 CALL PYLIST(2)
2444 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2445 CALL PYLIST(1)
2446 ENDIF
2447
2448C...Stop execution if too many errors.
2449 IF(MERR.NE.0) NERR=NERR+1
2450 IF(NERR.GE.10) THEN
2451 WRITE(MSTU(11),6300)
2452 CALL PYLIST(1)
2453 CALL PYSTOP(9)
2454 ENDIF
2455 180 CONTINUE
2456
2457C...Summarize result of run.
2458 IF(MTEST.GE.1) CALL PYTABU(22)
2459
2460C...Reset commonblock variables changed during run.
2461 MSTJ(1)=MSTJ1
2462 MSTJ(3)=MSTJ3
2463 MSTJ(11)=MSTJ11
2464 MSTJ(42)=MSTJ42
2465 MSTJ(43)=MSTJ43
2466 MSTJ(44)=MSTJ44
2467 PARJ(17)=PARJ17
2468 PARJ(22)=PARJ22
2469 PARJ(43)=PARJ43
2470 PARJ(54)=PARJ54
2471 MSTJ(101)=MST101
2472 MSTJ(104)=MST104
2473 MSTJ(105)=MST105
2474 MSTJ(107)=MST107
2475 MSTJ(116)=MST116
2476
2477C...Second part: complete events of various kinds.
2478C...Common initial values. Loop over initiating conditions.
2479 MSTP(122)=MAX(0,MIN(2,MTEST))
2480 MDCY(PYCOMP(111),1)=0
2481 DO 230 IPROC=1,8
2482
2483C...Reset process type, kinematics cuts, and the flags used.
2484 MSEL=0
2485 DO 190 ISUB=1,500
2486 MSUB(ISUB)=0
2487 190 CONTINUE
2488 CKIN(1)=2D0
2489 CKIN(3)=0D0
2490 MSTP(2)=1
2491 MSTP(11)=0
2492 MSTP(33)=0
2493 MSTP(81)=1
2494 MSTP(82)=1
2495 MSTP(111)=1
2496 MSTP(131)=0
2497 MSTP(133)=0
2498 PARP(131)=0.01D0
2499
2500C...Prompt photon production at fixed target.
2501 IF(IPROC.EQ.1) THEN
2502 PZSUM=300D0
2503 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2504 PQSUM=2D0
2505 MSEL=10
2506 CKIN(3)=5D0
2507 CALL PYINIT('FIXT','pi+','p',PZSUM)
2508
2509C...QCD processes at ISR energies.
2510 ELSEIF(IPROC.EQ.2) THEN
2511 PESUM=63D0
2512 PZSUM=0D0
2513 PQSUM=2D0
2514 MSEL=1
2515 CKIN(3)=5D0
2516 CALL PYINIT('CMS','p','p',PESUM)
2517
2518C...W production + multiple interactions at CERN Collider.
2519 ELSEIF(IPROC.EQ.3) THEN
2520 PESUM=630D0
2521 PZSUM=0D0
2522 PQSUM=0D0
2523 MSEL=12
2524 CKIN(1)=20D0
2525 MSTP(82)=4
2526 MSTP(2)=2
2527 MSTP(33)=3
2528 CALL PYINIT('CMS','p','pbar',PESUM)
2529
2530C...W/Z gauge boson pairs + pileup events at the Tevatron.
2531 ELSEIF(IPROC.EQ.4) THEN
2532 PESUM=1800D0
2533 PZSUM=0D0
2534 PQSUM=0D0
2535 MSUB(22)=1
2536 MSUB(23)=1
2537 MSUB(25)=1
2538 CKIN(1)=200D0
2539 MSTP(111)=0
2540 MSTP(131)=1
2541 MSTP(133)=2
2542 PARP(131)=0.04D0
2543 CALL PYINIT('CMS','p','pbar',PESUM)
2544
2545C...Higgs production at LHC.
2546 ELSEIF(IPROC.EQ.5) THEN
2547 PESUM=15400D0
2548 PZSUM=0D0
2549 PQSUM=2D0
2550 MSUB(3)=1
2551 MSUB(102)=1
2552 MSUB(123)=1
2553 MSUB(124)=1
2554 PMAS(25,1)=300D0
2555 CKIN(1)=200D0
2556 MSTP(81)=0
2557 MSTP(111)=0
2558 CALL PYINIT('CMS','p','p',PESUM)
2559
2560C...Z' production at SSC.
2561 ELSEIF(IPROC.EQ.6) THEN
2562 PESUM=40000D0
2563 PZSUM=0D0
2564 PQSUM=2D0
2565 MSEL=21
2566 PMAS(32,1)=600D0
2567 CKIN(1)=400D0
2568 MSTP(81)=0
2569 MSTP(111)=0
2570 CALL PYINIT('CMS','p','p',PESUM)
2571
2572C...W pair production at 1 TeV e+e- collider.
2573 ELSEIF(IPROC.EQ.7) THEN
2574 PESUM=1000D0
2575 PZSUM=0D0
2576 PQSUM=0D0
2577 MSUB(25)=1
2578 MSUB(69)=1
2579 MSTP(11)=1
2580 CALL PYINIT('CMS','e+','e-',PESUM)
2581
2582C...Deep inelastic scattering at a LEP+LHC ep collider.
2583 ELSEIF(IPROC.EQ.8) THEN
2584 P(1,1)=0D0
2585 P(1,2)=0D0
2586 P(1,3)=8000D0
2587 P(2,1)=0D0
2588 P(2,2)=0D0
2589 P(2,3)=-80D0
2590 PESUM=8080D0
2591 PZSUM=7920D0
2592 PQSUM=0D0
2593 MSUB(10)=1
2594 CKIN(3)=50D0
2595 MSTP(111)=0
2596 CALL PYINIT('3MOM','p','e-',PESUM)
2597 ENDIF
2598
2599C...Generate 20 events of each required type.
2600 DO 220 IEV=1,20
2601 CALL PYEVNT
2602 PESUMM=PESUM
2603 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2604
2605C...Check conservation of energy/momentum/flavour.
2606 PINI(1)=0D0
2607 PINI(2)=0D0
2608 PINI(3)=PZSUM
2609 PINI(4)=PESUMM
2610 PINI(6)=PQSUM
2611 DO 200 J=1,4
2612 PFIN(J)=PYP(0,J)
2613 200 CONTINUE
2614 PFIN(6)=PYP(0,6)
2615 MERR=0
2616 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2617 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2618 DEVQ=ABS(PFIN(6)-PINI(6))
2619 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2620 & DEVQ.GT.0.1D0) MERR=1
2621 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2622 & (PFIN(J),J=1,4),PFIN(6)
2623
2624C...Check that all KF codes are known ones, and that partons/particles
2625C...satisfy energy-momentum-mass relation.
2626 DO 210 I=1,N
2627 IF(K(I,1).GT.20) GOTO 210
2628 IF(PYCOMP(K(I,2)).EQ.0) THEN
2629 WRITE(MSTU(11),5100) I
2630 MERR=MERR+1
2631 ENDIF
2632 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2633 & SIGN(1D0,P(I,5))
2634 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2635 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2636 WRITE(MSTU(11),5200) I
2637 MERR=MERR+1
2638 ENDIF
2639 210 CONTINUE
2640
2641C...Listing of erroneous events, and first event of each type.
2642 IF(MERR.GE.1) NERR=NERR+1
2643 IF(NERR.GE.10) THEN
2644 WRITE(MSTU(11),6300)
2645 CALL PYLIST(1)
2646 CALL PYSTOP(9)
2647 ENDIF
2648 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2649 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2650 CALL PYLIST(1)
2651 ENDIF
2652 220 CONTINUE
2653
2654C...List statistics for each process type.
2655 IF(MTEST.GE.1) CALL PYSTAT(1)
2656 230 CONTINUE
2657
2658C...Summarize result of run.
2659 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2660 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2661
2662C...Format statements for output.
2663 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2664 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2665 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2666 &4(1X,F12.5),1X,F8.2)
2667 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2668 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2669 &'kinematics')
2670 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2671 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2672 6400 FORMAT(5X,'Faulty event follows:')
2673 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2674 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2675 &5X,'This should not have happened!')
2676
2677 RETURN
2678 END
2679
2680C*********************************************************************
2681
2682C...PYHEPC
2683C...Converts PYTHIA event record contents to or from
2684C...the standard event record commonblock.
2685
2686 SUBROUTINE PYHEPC(MCONV)
2687
2688C...Double precision and integer declarations.
2689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2690 IMPLICIT INTEGER(I-N)
2691 INTEGER PYK,PYCHGE,PYCOMP
2692C...Commonblocks.
2693 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2694 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2695 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2696 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2697C...HEPEVT commonblock.
2698 PARAMETER (NMXHEP=4000)
2699 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2700 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2701 DOUBLE PRECISION PHEP,VHEP
2702 SAVE /HEPEVT/
2703
2704C...Store HEPEVT commonblock size (for interfacing issues).
2705 MSTU(8)=NMXHEP
2706
2707C...Conversion from PYTHIA to standard, the easy part.
2708 IF(MCONV.EQ.1) THEN
2709 NEVHEP=0
2710 IF(N.GT.NMXHEP) CALL PYERRM(8,
2711 & '(PYHEPC:) no more space in /HEPEVT/')
2712 NHEP=MIN(N,NMXHEP)
2713 DO 150 I=1,NHEP
2714 ISTHEP(I)=0
2715 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2716 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2717 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2718 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2719 IDHEP(I)=K(I,2)
2720 JMOHEP(1,I)=K(I,3)
2721 JMOHEP(2,I)=0
2722 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2723 JDAHEP(1,I)=K(I,4)
2724 JDAHEP(2,I)=K(I,5)
2725 ELSE
2726 JDAHEP(1,I)=0
2727 JDAHEP(2,I)=0
2728 ENDIF
2729 DO 100 J=1,5
2730 PHEP(J,I)=P(I,J)
2731 100 CONTINUE
2732 DO 110 J=1,4
2733 VHEP(J,I)=V(I,J)
2734 110 CONTINUE
2735
2736C...Check if new event (from pileup).
2737 IF(I.EQ.1) THEN
2738 INEW=1
2739 ELSE
2740 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2741 ENDIF
2742
2743C...Fill in missing mother information.
2744 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2745 IMO1=I-2
2746 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2747 & THEN
2748 IMO1=IMO1-1
2749 GOTO 120
2750 ENDIF
2751 JMOHEP(1,I)=IMO1
2752 JMOHEP(2,I)=IMO1+1
2753 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2754 I1=K(I,3)-1
2755 130 I1=I1+1
2756 IF(I1.GE.I) CALL PYERRM(8,
2757 & '(PYHEPC:) translation of inconsistent event history')
2758 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2759 KC=PYCOMP(K(I1,2))
2760 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2761 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2762 JMOHEP(2,I)=I1
2763 ELSEIF(K(I,2).EQ.94) THEN
2764 NJET=2
2765 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2766 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2767 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2768 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2769 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2770 ENDIF
2771
2772C...Fill in missing daughter information.
2773 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2774 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2775 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2776 JDAHEP(1,I2)=I
2777 140 CONTINUE
2778 ENDIF
2779 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2780 I1=JMOHEP(1,I)
2781 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2782 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2783 IF(JDAHEP(1,I1).EQ.0) THEN
2784 JDAHEP(1,I1)=I
2785 ELSE
2786 JDAHEP(2,I1)=I
2787 ENDIF
2788 150 CONTINUE
2789 DO 160 I=1,NHEP
2790 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2791 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2792 160 CONTINUE
2793
2794C...Conversion from standard to PYTHIA, the easy part.
2795 ELSE
2796 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2797 & '(PYHEPC:) no more space in /PYJETS/')
2798 N=MIN(NHEP,MSTU(4))
2799 NKQ=0
2800 KQSUM=0
2801 DO 190 I=1,N
2802 K(I,1)=0
2803 IF(ISTHEP(I).EQ.1) K(I,1)=1
2804 IF(ISTHEP(I).EQ.2) K(I,1)=11
2805 IF(ISTHEP(I).EQ.3) K(I,1)=21
2806 K(I,2)=IDHEP(I)
2807 K(I,3)=JMOHEP(1,I)
2808 K(I,4)=JDAHEP(1,I)
2809 K(I,5)=JDAHEP(2,I)
2810 DO 170 J=1,5
2811 P(I,J)=PHEP(J,I)
2812 170 CONTINUE
2813 DO 180 J=1,4
2814 V(I,J)=VHEP(J,I)
2815 180 CONTINUE
2816 V(I,5)=0D0
2817 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2818 I1=JDAHEP(1,I)
2819 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2820 & PHEP(5,I)/PHEP(4,I)
2821 ENDIF
2822
2823C...Fill in missing information on colour connection in jet systems.
2824 IF(ISTHEP(I).EQ.1) THEN
2825 KC=PYCOMP(K(I,2))
2826 KQ=0
2827 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2828 IF(KQ.NE.0) NKQ=NKQ+1
2829 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2830 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2831 K(I,1)=2
2832 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2833 IF(K(I+1,2).EQ.21) K(I,1)=2
2834 ENDIF
2835 ENDIF
2836 190 CONTINUE
2837 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2838 & '(PYHEPC:) input parton configuration not colour singlet')
2839 ENDIF
2840
2841 END
2842
2843C*********************************************************************
2844
2845C...PYINIT
2846C...Initializes the generation procedure; finds maxima of the
2847C...differential cross-sections to be used for weighting.
2848
2849 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2850
2851C...Double precision and integer declarations.
2852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2853 IMPLICIT INTEGER(I-N)
2854 INTEGER PYK,PYCHGE,PYCOMP
2855C...Commonblocks.
2856 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2857 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2858 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2859 COMMON/PYDAT4/CHAF(500,2)
2860 CHARACTER CHAF*16
2861 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2862 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2863 COMMON/PYINT1/MINT(400),VINT(400)
2864 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2865 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2866 COMMON/PYPUED/IUED(0:99),RUED(0:99)
2867 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2868 &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/
2869C...Local arrays and character variables.
2870 DIMENSION ALAMIN(20),NFIN(20)
2871 CHARACTER*(*) FRAME,BEAM,TARGET
2872 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2873
2874C...Interface to PDFLIB.
2875 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
2876 COMMON/LW50512/QCDL4,QCDL5
2877 SAVE /W50511/,/LW50512/
2878 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2879 CHARACTER*20 PARM(20)
2880 DATA VALUE/20*0D0/,PARM/20*' '/
2881
2882C...Data:Lambda and n_f values for parton distributions..
2883 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2884 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2885 &NFIN/20*4/
2886 DATA CHLH/'lepton','hadron'/
2887
2888C...Check that BLOCK DATA PYDATA has been loaded.
2889 CALL PYCKBD
2890
2891C...Reset MINT and VINT arrays. Write headers.
2892 MSTI(53)=0
2893 DO 100 J=1,400
2894 MINT(J)=0
2895 VINT(J)=0D0
2896 100 CONTINUE
2897 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2898 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2899
2900C...Reset error counters.
2901 MSTU(23)=0
2902 MSTU(27)=0
2903 MSTU(30)=0
2904
2905C...Reset processes that should not be on.
2906 MSUB(96)=0
2907 MSUB(97)=0
2908
2909C...Select global FSR/ISR/UE parameter set = 'tune'
2910C...See routine PYTUNE for details
2911 IF (MSTP(5).NE.0) THEN
2912 MSTP5=MSTP(5)
2913 CALL PYTUNE(MSTP5)
2914 ENDIF
2915
2916C...Call user process initialization routine.
2917 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2918 MSEL=0
2919 CALL UPINIT
2920 MSEL=0
2921 ENDIF
2922
2923C...Maximum 4 generations; set maximum number of allowed flavours.
2924 MSTP(1)=MIN(4,MSTP(1))
2925 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2926 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2927
2928C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2929 DO 120 I=-20,20
2930 VINT(180+I)=0D0
2931 IA=IABS(I)
2932 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2933 DO 110 J=1,MSTP(1)
2934 IB=2*J-1+MOD(IA,2)
2935 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2936 IPM=(5-ISIGN(1,I))/2
2937 IDC=J+MDCY(IA,2)+2
2938 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2939 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2940 110 CONTINUE
2941 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2942 VINT(180+I)=1D0
2943 ENDIF
2944 120 CONTINUE
2945
2946C...Initialize parton distributions: PDFLIB.
2947 IF(MSTP(52).EQ.2) THEN
2948 PARM(1)='NPTYPE'
2949 VALUE(1)=1
2950 PARM(2)='NGROUP'
2951 VALUE(2)=MSTP(51)/1000
2952 PARM(3)='NSET'
2953 VALUE(3)=MOD(MSTP(51),1000)
2954 PARM(4)='TMAS'
2955 VALUE(4)=PMAS(6,1)
2956 CALL PDFSET_ALICE(PARM,VALUE)
2957 MINT(93)=1000000+MSTP(51)
2958 ENDIF
2959C...Choose Lambda value to use in alpha-strong.
2960 MSTU(111)=MSTP(2)
2961 IF(MSTP(3).GE.2) THEN
2962 ALAM=0.2D0
2963 NF=4
2964 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2965 ALAM=ALAMIN(MSTP(51))
2966 NF=NFIN(MSTP(51))
2967 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2968 ALAM=QCDL5
2969 NF=5
2970 ELSEIF(MSTP(52).EQ.2) THEN
2971 ALAM=QCDL4
2972 NF=4
2973 ENDIF
2974 PARP(1)=ALAM
2975 PARP(61)=ALAM
2976 PARP(72)=ALAM
2977 PARU(112)=ALAM
2978 MSTU(112)=NF
2979 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2980 ENDIF
2981C...Initialize the UED masses and widths
2982 IF (IUED(1).EQ.1) CALL PYXDIN
2983
2984C...Initialize the SUSY generation: couplings, masses,
2985C...decay modes, branching ratios, and so on.
2986 CALL PYMSIN
2987C...Initialize widths and partial widths for resonances.
2988 CALL PYINRE
2989C...Set Z0 mass and width for e+e- routines.
2990 PARJ(123)=PMAS(23,1)
2991 PARJ(124)=PMAS(23,2)
2992
2993C...Identify beam and target particles and frame of process.
2994 CHFRAM=FRAME//' '
2995 CHBEAM=BEAM//' '
2996 CHTARG=TARGET//' '
2997 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2998 IF(MINT(65).EQ.1) GOTO 170
2999
3000C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3001C...For e-gamma allow 2 alternatives.
3002 MINT(121)=1
3003 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3004 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3005 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3006 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
3007 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3008 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
3009 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3010 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3011 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3012 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
3013 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3014 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3015 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
3016 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
3017 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3018 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3019 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
3020 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
3021 ENDIF
3022 MINT(123)=MSTP(14)
3023 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
3024 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
3025 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
3026 IF(MSTP(14).EQ.11) MINT(123)=0
3027 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
3028 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
3029 IF(MSTP(14).EQ.15) MINT(123)=2
3030 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
3031 IF(MSTP(14).EQ.19) MINT(123)=3
3032 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
3033 IF(MSTP(14).EQ.21) MINT(123)=0
3034 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
3035 IF(MSTP(14).EQ.24) MINT(123)=1
3036 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
3037 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
3038 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
3039 ENDIF
3040
3041C...Set up kinematics of process.
3042 CALL PYINKI(0)
3043
3044C...Set up kinematics for photons inside leptons.
3045 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
3046
3047C...Precalculate flavour selection weights.
3048 CALL PYKFIN
3049
3050C...Loop over gamma-p or gamma-gamma alternatives.
3051 CKIN3=CKIN(3)
3052 MSAV48=0
3053 DO 160 IGA=1,MINT(121)
3054 CKIN(3)=CKIN3
3055 MINT(122)=IGA
3056
3057C...Select partonic subprocesses to be included in the simulation.
3058 CALL PYINPR
3059 MINT(101)=1
3060 MINT(102)=1
3061 MINT(103)=MINT(11)
3062 MINT(104)=MINT(12)
3063
3064C...Count number of subprocesses on.
3065 MINT(48)=0
3066 DO 130 ISUB=1,500
3067 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3068 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
3069 MSUB(ISUB)=0
3070 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3071 & MSUB(ISUB).EQ.1) THEN
3072 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
3073 CALL PYSTOP(1)
3074 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
3075 WRITE(MSTU(11),5300) ISUB
3076 CALL PYSTOP(1)
3077 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
3078 WRITE(MSTU(11),5400) ISUB
3079 CALL PYSTOP(1)
3080 ELSEIF(MSUB(ISUB).EQ.1) THEN
3081 MINT(48)=MINT(48)+1
3082 ENDIF
3083 130 CONTINUE
3084
3085C...Stop or raise warning flag if no subprocesses on.
3086 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
3087 IF(MSTP(127).NE.1) THEN
3088 WRITE(MSTU(11),5500)
3089 CALL PYSTOP(1)
3090 ELSE
3091 WRITE(MSTU(11),5700)
3092 MSTI(53)=1
3093 ENDIF
3094 ENDIF
3095 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
3096 MSAV48=MSAV48+MINT(48)
3097
3098C...Reset variables for cross-section calculation.
3099 DO 150 I=0,500
3100 DO 140 J=1,3
3101 NGEN(I,J)=0
3102 XSEC(I,J)=0D0
3103 140 CONTINUE
3104 150 CONTINUE
3105
3106C...Find parametrized total cross-sections.
3107 CALL PYXTOT
3108 VINT(318)=VINT(317)
3109
3110C...Maxima of differential cross-sections.
3111 IF(MSTP(121).LE.1) CALL PYMAXI
3112
3113C...Initialize possibility of pileup events.
3114 IF(MINT(121).GT.1) MSTP(131)=0
3115 IF(MSTP(131).NE.0) CALL PYPILE(1)
3116
3117C...Initialize multiple interactions with variable impact parameter.
3118 IF(MINT(50).EQ.1) THEN
3119 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3120 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
3121 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
3122 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
3123 MINT(35)=1
3124 CALL PYMULT(1)
3125 MINT(35)=3
3126 CALL PYMIGN(1)
3127 ENDIF
3128 ENDIF
3129
3130C...Save results for gamma-p and gamma-gamma alternatives.
3131 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
3132 160 CONTINUE
3133
3134C...Initialization finished.
3135 IF(MSAV48.EQ.0) THEN
3136 IF(MSTP(127).NE.1) THEN
3137 WRITE(MSTU(11),5500)
3138 CALL PYSTOP(1)
3139 ELSE
3140 WRITE(MSTU(11),5700)
3141 MSTI(53)=1
3142 ENDIF
3143 ENDIF
3144 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
3145
3146C...Formats for initialization information.
3147 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3148 &'routines',1X,17('*'))
3149 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3150 &'-',A6,' interactions.'/1X,'Execution stopped!')
3151 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3152 &1X,'Execution stopped!')
3153 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3154 &1X,'Execution stopped!')
3155 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3156 &1X,'Execution stopped.')
3157 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3158 &22('*'))
3159 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3160 &1X,'Execution will stop if you try to generate events.')
3161
3162 RETURN
3163 END
3164
3165C*********************************************************************
3166
3167C...PYEVNT
3168C...Administers the generation of a high-pT event via calls to
3169C...a number of subroutines.
3170
3171 SUBROUTINE PYEVNT
3172
3173C...Double precision and integer declarations.
3174 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3175 IMPLICIT INTEGER(I-N)
3176 INTEGER PYK,PYCHGE,PYCOMP
3177 PARAMETER (MAXNUR=1000)
3178C...Commonblocks.
3179 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3180 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3181 COMMON/PYCTAG/NCT,MCT(4000,2)
3182 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3183 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3184 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3185 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3186 COMMON/PYINT1/MINT(400),VINT(400)
3187 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3188 COMMON/PYINT4/MWID(500),WIDS(500,5)
3189 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3190 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3191 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3192C...Local array.
3193 DIMENSION VTX(4)
3194
3195C...Optionally let PYEVNW do the whole job.
3196 IF(MSTP(81).GE.20) THEN
3197 CALL PYEVNW
3198 RETURN
3199 ENDIF
3200
3201C...Stop if no subprocesses on.
3202 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3203 WRITE(MSTU(11),5100)
3204 CALL PYSTOP(1)
3205 ENDIF
3206
3207C...Initial values for some counters.
3208 MSTU(1)=0
3209 MSTU(2)=0
3210 N=0
3211 MINT(5)=MINT(5)+1
3212 MINT(7)=0
3213 MINT(8)=0
3214 MINT(30)=0
3215 MINT(83)=0
3216 MINT(84)=MSTP(126)
3217 MSTU(24)=0
3218 MSTU70=0
3219 MSTJ14=MSTJ(14)
3220C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3221 NCT=0
3222 MINT(33)=0
3223
3224C...Let called routines know call is from PYEVNT (not PYEVNW).
3225 MINT(35)=1
3226 IF (MSTP(81).GE.10) MINT(35)=2
3227
3228C...If variable energies: redo incoming kinematics and cross-section.
3229 MSTI(61)=0
3230 IF(MSTP(171).EQ.1) THEN
3231 CALL PYINKI(1)
3232 IF(MSTI(61).EQ.1) THEN
3233 MINT(5)=MINT(5)-1
3234 RETURN
3235 ENDIF
3236 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3237 CALL PYXTOT
3238 ENDIF
3239
3240C...Loop over number of pileup events; check space left.
3241 IF(MSTP(131).LE.0) THEN
3242 NPILE=1
3243 ELSE
3244 CALL PYPILE(2)
3245 NPILE=MINT(81)
3246 ENDIF
3247 DO 270 IPILE=1,NPILE
3248 IF(MINT(84)+100.GE.MSTU(4)) THEN
3249 CALL PYERRM(11,
3250 & '(PYEVNT:) no more space in PYJETS for pileup events')
3251 IF(MSTU(21).GE.1) GOTO 280
3252 ENDIF
3253 MINT(82)=IPILE
3254
3255C...Generate variables of hard scattering.
3256 MINT(51)=0
3257 MSTI(52)=0
3258 100 CONTINUE
3259 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3260 MINT(31)=0
3261 MINT(39)=0
3262 MINT(51)=0
3263 MINT(57)=0
3264 CALL PYRAND
3265 IF(MSTI(61).EQ.1) THEN
3266 MINT(5)=MINT(5)-1
3267 RETURN
3268 ENDIF
3269 IF(MINT(51).EQ.2) RETURN
3270 ISUB=MINT(1)
3271 IF(MSTP(111).EQ.-1) GOTO 260
3272
3273C...Loopback point if PYPREP fails, especially for junction topologies.
3274 NPREP=0
3275 MNT31S=MINT(31)
3276 110 NPREP=NPREP+1
3277 MINT(31)=MNT31S
3278
3279 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3280C...Hard scattering (including low-pT):
3281C...reconstruct kinematics and colour flow of hard scattering.
3282 MINT31=MINT(31)
3283 120 MINT(31)=MINT31
3284 MINT(51)=0
3285 CALL PYSCAT
3286 IF(MINT(51).EQ.1) GOTO 100
3287 IPU1=MINT(84)+1
3288 IPU2=MINT(84)+2
3289 IF(ISUB.EQ.95) GOTO 140
3290
3291C...Reset statistics on activity in event.
3292 DO 130 J=351,359
3293 MINT(J)=0
3294 VINT(J)=0D0
3295 130 CONTINUE
3296
3297C...Showering of initial state partons (optional).
3298 NFIN=N
3299 ALAMSV=PARJ(81)
3300 PARJ(81)=PARP(72)
3301 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3302 & CALL PYSSPA(IPU1,IPU2)
3303 PARJ(81)=ALAMSV
3304 IF(MINT(51).EQ.1) GOTO 100
3305
3306C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3307 IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
3308 PTMAX=0.5*SQRT(PARP(71))*VINT(55)
3309 CALL PYPTFS(3,PTMAX,0D0,PTGEN)
3310 ENDIF
3311
3312C...Showering of final state partons (optional).
3313 ALAMSV=PARJ(81)
3314 PARJ(81)=PARP(72)
3315 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3316 & THEN
3317 IPU3=MINT(84)+3
3318 IPU4=MINT(84)+4
3319 IF(ISET(ISUB).EQ.5) IPU4=-3
3320 QMAX=VINT(55)
3321 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3322 CALL PYSHOW(IPU3,IPU4,QMAX)
3323 ELSEIF(ISET(ISUB).EQ.11) THEN
3324 CALL PYADSH(NFIN)
3325 ENDIF
3326 PARJ(81)=ALAMSV
3327
3328C...Allow possibility for user to abort event generation.
3329 IVETO=0
3330 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3331 IF(IVETO.EQ.1) GOTO 100
3332
3333C...Decay of final state resonances.
3334 MINT(32)=0
3335 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3336 IF(MINT(51).EQ.1) GOTO 100
3337 MINT(52)=N
3338
3339
3340C...Multiple interactions - PYTHIA 6.3 intermediate style.
3341 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3342 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3343 CALL PYMIGN(6)
3344 IF(MINT(51).EQ.1) GOTO 100
3345 MINT(53)=N
3346
3347C...Beam remnant flavour and colour assignments - new scheme.
3348 CALL PYMIHK
3349 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3350 & GOTO 120
3351 IF(MINT(51).EQ.1) GOTO 100
3352
3353C...Primordial kT and beam remnant momentum sharing - new scheme.
3354 CALL PYMIRM
3355 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3356 & GOTO 120
3357 IF(MINT(51).EQ.1) GOTO 100
3358 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3359
3360C...Multiple interactions - PYTHIA 6.2 style.
3361 ELSEIF(MINT(111).NE.12) THEN
3362 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3363 CALL PYMULT(6)
3364 MINT(53)=N
3365 ENDIF
3366
3367C...Hadron remnants and primordial kT.
3368 CALL PYREMN(IPU1,IPU2)
3369 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3370 & 110
3371 IF(MINT(51).EQ.1) GOTO 100
3372 ENDIF
3373
3374 ELSEIF(ISUB.NE.99) THEN
3375C...Diffractive and elastic scattering.
3376 CALL PYDIFF
3377
3378 ELSE
3379C...DIS scattering (photon flux external).
3380 CALL PYDISG
3381 IF(MINT(51).EQ.1) GOTO 100
3382 ENDIF
3383
3384C...Check that no odd resonance left undecayed.
3385 MINT(54)=N
3386 IF(MSTP(111).GE.1) THEN
3387 NFIX=N
3388 DO 150 I=MINT(84)+1,NFIX
3389 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3390 & K(I,2).NE.22) THEN
3391 KCA=PYCOMP(K(I,2))
3392 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3393 CALL PYRESD(I)
3394 IF(MINT(51).EQ.1) GOTO 100
3395 ENDIF
3396 ENDIF
3397 150 CONTINUE
3398 ENDIF
3399
3400C...Boost hadronic subsystem to overall rest frame.
3401C..(Only relevant when photon inside lepton beam.)
3402 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3403
3404C...Recalculate energies from momenta and masses (if desired).
3405 IF(MSTP(113).GE.1) THEN
3406 DO 160 I=MINT(83)+1,N
3407 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3408 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3409 160 CONTINUE
3410 NRECAL=N
3411 ENDIF
3412
3413C...Colour reconnection before string formation
3414 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3415
3416C...Rearrange partons along strings, check invariant mass cuts.
3417 MSTU(28)=0
3418 IF(MSTP(111).LE.0) MSTJ(14)=-1
3419 CALL PYPREP(MINT(84)+1)
3420 MSTJ(14)=MSTJ14
3421 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3422 MSTU(24)=0
3423 GOTO 100
3424 ENDIF
3425 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3426 IF (MINT(51).EQ.1) GOTO 100
3427 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3428 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3429 DO 190 I=MINT(84)+1,N
3430 IF(K(I,2).EQ.94) THEN
3431 DO 180 I1=I+1,MIN(N,I+10)
3432 IF(K(I1,3).EQ.I) THEN
3433 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3434 IF(K(I1,3).EQ.0) THEN
3435 DO 170 II=MINT(84)+1,I-1
3436 IF(K(II,2).EQ.K(I1,2)) THEN
3437 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3438 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3439 ENDIF
3440 170 CONTINUE
3441 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3442 ENDIF
3443 ENDIF
3444 180 CONTINUE
3445 ENDIF
3446 190 CONTINUE
3447 CALL PYEDIT(12)
3448 CALL PYEDIT(14)
3449 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3450 IF(MSTP(125).EQ.0) MINT(4)=0
3451 DO 210 I=MINT(83)+1,N
3452 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3453 DO 200 I1=I+1,N
3454 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3455 IF(K(I1,3).EQ.I) K(I,5)=I1
3456 200 CONTINUE
3457 ENDIF
3458 210 CONTINUE
3459 ENDIF
3460
3461C...Introduce separators between sections in PYLIST event listing.
3462 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3463 MSTU70=1
3464 MSTU(71)=N
3465 ELSEIF(IPILE.EQ.1) THEN
3466 MSTU70=3
3467 MSTU(71)=2
3468 MSTU(72)=MINT(4)
3469 MSTU(73)=N
3470 ENDIF
3471
3472C...Go back to lab frame (needed for vertices, also in fragmentation).
3473 CALL PYFRAM(1)
3474
3475C...Set nonvanishing production vertex (optional).
3476 IF(MSTP(151).EQ.1) THEN
3477 DO 220 J=1,4
3478 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3479 & SIN(PARU(2)*PYR(0))
3480 220 CONTINUE
3481 DO 240 I=MINT(83)+1,N
3482 DO 230 J=1,4
3483 V(I,J)=V(I,J)+VTX(J)
3484 230 CONTINUE
3485 240 CONTINUE
3486 ENDIF
3487
3488C...Perform hadronization (if desired).
3489 IF(MSTP(111).GE.1) THEN
3490 CALL PYEXEC
3491 IF(MSTU(24).NE.0) GOTO 100
3492 ENDIF
3493 IF(MSTP(113).GE.1) THEN
3494 DO 250 I=NRECAL,N
3495 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3496 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3497 250 CONTINUE
3498 ENDIF
3499 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3500
3501C...Store event information and calculate Monte Carlo estimates of
3502C...subprocess cross-sections.
3503 260 IF(IPILE.EQ.1) CALL PYDOCU
3504
3505C...Set counters for current pileup event and loop to next one.
3506 MSTI(41)=IPILE
3507 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3508 IF(MSTU70.LT.10) THEN
3509 MSTU70=MSTU70+1
3510 MSTU(70+MSTU70)=N
3511 ENDIF
3512 MINT(83)=N
3513 MINT(84)=N+MSTP(126)
3514 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3515 270 CONTINUE
3516
3517C...Generic information on pileup events. Reconstruct missing history.
3518 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3519 PARI(91)=VINT(132)
3520 PARI(92)=VINT(133)
3521 PARI(93)=VINT(134)
3522 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3523 ENDIF
3524 CALL PYEDIT(16)
3525
3526C...Transform to the desired coordinate frame.
3527 280 CALL PYFRAM(MSTP(124))
3528 MSTU(70)=MSTU70
3529 PARU(21)=VINT(1)
3530
3531C...Error messages
3532 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3533 &1X,'Execution stopped.')
3534
3535 RETURN
3536 END
3537
3538C*********************************************************************
3539
3540C...PYEVNW
3541C...Administers the generation of a high-pT event via calls to
3542C...a number of subroutines for the new multiple interactions and
3543C...showering framework.
3544
3545 SUBROUTINE PYEVNW
3546
3547C...Double precision and integer declarations.
3548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3549 IMPLICIT INTEGER(I-N)
3550 INTEGER PYK,PYCHGE,PYCOMP
3551 PARAMETER (MAXNUR=1000)
3552C...Commonblocks.
3553 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3554C...Commonblocks.
3555 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3556 COMMON/PYCTAG/NCT,MCT(4000,2)
3557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3559 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3561 COMMON/PYINT1/MINT(400),VINT(400)
3562 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3563 COMMON/PYINT4/MWID(500),WIDS(500,5)
3564 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3565 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3566 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3567 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3568 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3569 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3570C...Local arrays.
3571 DIMENSION VTX(4)
3572
3573C...Stop if no subprocesses on.
3574 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3575 WRITE(MSTU(11),5100)
3576 CALL PYSTOP(1)
3577 ENDIF
3578
3579C...Initial values for some counters.
3580 MSTU(1)=0
3581 MSTU(2)=0
3582 N=0
3583 MINT(5)=MINT(5)+1
3584 MINT(7)=0
3585 MINT(8)=0
3586 MINT(30)=0
3587 MINT(83)=0
3588 MINT(84)=MSTP(126)
3589 MSTU(24)=0
3590 MSTU70=0
3591 MSTJ14=MSTJ(14)
3592C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3593 NCT=0
3594 MINT(33)=0
3595C...Zero counters for pT-ordered showers (failsafe)
3596 NPART=0
3597 NPARTD=0
3598
3599C...Let called routines know call is from PYEVNW (not PYEVNT).
3600 MINT(35)=3
3601
3602C...If variable energies: redo incoming kinematics and cross-section.
3603 MSTI(61)=0
3604 IF(MSTP(171).EQ.1) THEN
3605 CALL PYINKI(1)
3606 IF(MSTI(61).EQ.1) THEN
3607 MINT(5)=MINT(5)-1
3608 RETURN
3609 ENDIF
3610 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3611 CALL PYXTOT
3612 ENDIF
3613
3614C...Loop over number of pileup events; check space left.
3615 IF(MSTP(131).LE.0) THEN
3616 NPILE=1
3617 ELSE
3618 CALL PYPILE(2)
3619 NPILE=MINT(81)
3620 ENDIF
3621 DO 300 IPILE=1,NPILE
3622 IF(MINT(84)+100.GE.MSTU(4)) THEN
3623 CALL PYERRM(11,
3624 & '(PYEVNW:) no more space in PYJETS for pileup events')
3625 IF(MSTU(21).GE.1) GOTO 310
3626 ENDIF
3627 MINT(82)=IPILE
3628
3629C...Generate variables of hard scattering.
3630 MINT(51)=0
3631 MSTI(52)=0
3632 LOOPHS =0
3633 100 CONTINUE
3634 LOOPHS = LOOPHS + 1
3635 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3636 IF(LOOPHS.GE.10) THEN
3637 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3638 & //'multiple interactions. Returning.')
3639 MINT(51)=1
3640 RETURN
3641 ENDIF
3642 MINT(31)=0
3643 MINT(39)=0
3644 MINT(36)=0
3645 MINT(51)=0
3646 MINT(57)=0
3647 CALL PYRAND
3648 IF(MSTI(61).EQ.1) THEN
3649 MINT(5)=MINT(5)-1
3650 RETURN
3651 ENDIF
3652 IF(MINT(51).EQ.2) RETURN
3653 ISUB=MINT(1)
3654 IF(MSTP(111).EQ.-1) GOTO 290
3655
3656C...Loopback point if PYPREP fails, especially for junction topologies.
3657 NPREP=0
3658 MNT31S=MINT(31)
3659 110 NPREP=NPREP+1
3660 MINT(31)=MNT31S
3661
3662 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3663C...Hard scattering (including low-pT):
3664C...reconstruct kinematics and colour flow of hard scattering.
3665 MINT31=MINT(31)
3666 120 MINT(31)=MINT31
3667 MINT(51)=0
3668 CALL PYSCAT
3669 IF(MINT(51).EQ.1) GOTO 100
3670 NPARTD=N
3671 NFIN=N
3672
3673C...Intertwined initial state showers and multiple interactions.
3674C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3675C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3676 MSTP61=MSTP(61)
3677 IF (MINT(47).LT.2) MSTP(61)=0
3678 MSTP81=MSTP(81)
3679 IF (MINT(50).EQ.0) MSTP(81)=0
3680 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3681 & MINT(111).NE.12) THEN
3682C...Absolute max pT2 scale for evolution: phase space limit.
3683 PT2MXS=0.25D0*VINT(2)
3684C...Check if more constrained by ISR and MI max scales:
3685 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3686C...Loopback point in case of failure in evolution.
3687 LOOP=0
3688 130 LOOP=LOOP+1
3689 MINT(51)=0
3690 IF(LOOP.GT.100) THEN
3691 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3692 & //'multiple interactions. Trying new point.')
3693 MINT(51)=1
3694 RETURN
3695 ENDIF
3696
3697C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3698C...once per event. (E.g. compute constants and save variables to be
3699C...restored later in case of failure.)
3700 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3701
3702C...Initialize interleaved MI/ISR/JI evolution.
3703C...PT2MAX: absolute upper limit for evolution - Initialization may
3704C... return a PT2MAX which is lower than this.
3705C...PT2MIN: absolute lower limit for evolution - Initialization may
3706C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3707 PT2MAX=PT2MXS
3708 PT2MIN=0D0
3709 CALL PYEVOL(0,PT2MAX,PT2MIN)
3710C...If failed to initialize evolution, generate a new hard process
3711 IF (MINT(51).EQ.1) GOTO 100
3712
3713C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3714C...In principle factorized, so can be stopped and restarted.
3715C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3716C PT2MED=MAX(10D0**2,PT2MIN)
3717C CALL PYEVOL(1,PT2MAX,PT2MED)
3718C IF (MINT(51).EQ.1) GOTO 160
3719C PT2MAX=PT2MED
3720 CALL PYEVOL(1,PT2MAX,PT2MIN)
3721C...If fatal error (e.g., massive hard-process initiator, but no available
3722C...phase space for creation), generate a new hard process
3723 IF (MINT(51).EQ.2) GOTO 100
3724C...If smaller error, just try running evolution again
3725 IF (MINT(51).EQ.1) GOTO 130
3726
3727C...Finalize interleaved MI/ISR/JI evolution.
3728 CALL PYEVOL(2,PT2MAX,PT2MIN)
3729 IF (MINT(51).EQ.1) GOTO 130
3730
3731 ENDIF
3732 MSTP(61)=MSTP61
3733 MSTP(81)=MSTP81
3734 IF(MINT(51).EQ.1) GOTO 100
3735C...(MINT(52) is actually obsolete in this routine. Set anyway
3736C...to ensure PYDOCU stable.)
3737 MINT(52)=N
3738 MINT(53)=N
3739
3740C...Beam remnants - new scheme.
3741 140 IF(MINT(50).EQ.1) THEN
3742 IF (ISUB.EQ.95) MINT(31)=1
3743
3744C...Beam remnant flavour and colour assignments - new scheme.
3745 CALL PYMIHK
3746 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3747 & GOTO 120
3748 IF(MINT(51).EQ.1) GOTO 100
3749
3750C...Primordial kT and beam remnant momentum sharing - new scheme.
3751 CALL PYMIRM
3752 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3753 & GOTO 120
3754 IF(MINT(51).EQ.1) GOTO 100
3755 IF (ISUB.EQ.95) MINT(31)=0
3756 ELSEIF(MINT(111).NE.12) THEN
3757C...Hadron remnants and primordial kT - old model.
3758C...Happens e.g. for direct photon on one side.
3759 IPU1=IMI(1,1,1)
3760 IPU2=IMI(2,1,1)
3761 CALL PYREMN(IPU1,IPU2)
3762 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3763 & 110
3764 IF(MINT(51).EQ.1) GOTO 100
3765C...PYREMN does not set colour tags for BRs, so needs to be done now.
3766 DO 160 I=MINT(53)+1,N
3767 DO 150 KCS=4,5
3768 IDA=MOD(K(I,KCS),MSTU(5))
3769 IF (IDA.NE.0) THEN
3770 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3771 ELSE
3772 MCT(I,KCS-3)=0
3773 ENDIF
3774 150 CONTINUE
3775 160 CONTINUE
3776C...Instruct PYPREP to use colour tags
3777 MINT(33)=1
3778
3779 DO 360 MQGST=1,2
3780 DO 350 I=MINT(84)+1,N
3781
3782C...Look for coloured string endpoint, or (later) leftover gluon.
3783 IF (K(I,1).NE.3) GOTO 350
3784 KC=PYCOMP(K(I,2))
3785 IF(KC.EQ.0) GOTO 350
3786 KQ=KCHG(KC,2)
3787 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3788
3789C... Pick up loose string end with no previous tag.
3790 KCS=4
3791 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3792 IF(MCT(I,KCS-3).NE.0) GOTO 350
3793
3794 CALL PYCTTR(I,KCS,I)
3795 IF(MINT(51).NE.0) RETURN
3796
3797 350 CONTINUE
3798 360 CONTINUE
3799C...Now delete any colour processing information if set (since partons
3800C...otherwise not FS showered!)
3801 DO 170 I=MINT(84)+1,N
3802 IF (I.LE.N) THEN
3803 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3804 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3805 ENDIF
3806 170 CONTINUE
3807 ENDIF
3808
3809C...Showering of final state partons (optional).
3810 ALAMSV=PARJ(81)
3811 PARJ(81)=PARP(72)
3812 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3813 & THEN
3814 QMAX=VINT(55)
3815 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3816 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3817C...External processes: handle successive showers.
3818 ELSEIF(ISET(ISUB).EQ.11) THEN
3819 CALL PYADSH(NFIN)
3820 ENDIF
3821 PARJ(81)=ALAMSV
3822
3823C...Allow possibility for user to abort event generation.
3824 IVETO=0
3825 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3826 IF(IVETO.EQ.1) THEN
3827C...........No reason to count this as an error
3828 LOOPHS = LOOPHS-1
3829 GOTO 100
3830 ENDIF
3831
3832
3833C...Decay of final state resonances.
3834 MINT(32)=0
3835 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3836 CALL PYRESD(0)
3837 IF(MINT(51).NE.0) GOTO 100
3838 ENDIF
3839
3840 IF(MINT(51).EQ.1) GOTO 100
3841
3842 ELSEIF(ISUB.NE.99) THEN
3843C...Diffractive and elastic scattering.
3844 CALL PYDIFF
3845
3846 ELSE
3847C...DIS scattering (photon flux external).
3848 CALL PYDISG
3849 IF(MINT(51).EQ.1) GOTO 100
3850 ENDIF
3851
3852C...Check that no odd resonance left undecayed.
3853 MINT(54)=N
3854 IF(MSTP(111).GE.1) THEN
3855 NFIX=N
3856 DO 180 I=MINT(84)+1,NFIX
3857 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3858 & K(I,2).NE.22) THEN
3859 KCA=PYCOMP(K(I,2))
3860 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3861 CALL PYRESD(I)
3862 IF(MINT(51).EQ.1) GOTO 100
3863 ENDIF
3864 ENDIF
3865 180 CONTINUE
3866 ENDIF
3867
3868C...Boost hadronic subsystem to overall rest frame.
3869C..(Only relevant when photon inside lepton beam.)
3870 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3871
3872C...Recalculate energies from momenta and masses (if desired).
3873 IF(MSTP(113).GE.1) THEN
3874 DO 190 I=MINT(83)+1,N
3875 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3876 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3877 190 CONTINUE
3878 NRECAL=N
3879 ENDIF
3880
3881C...Colour reconnection before string formation
3882 CALL PYFSCR(MINT(84)+1)
3883
3884C...Rearrange partons along strings, check invariant mass cuts.
3885 MSTU(28)=0
3886 IF(MSTP(111).LE.0) MSTJ(14)=-1
3887 CALL PYPREP(MINT(84)+1)
3888 MSTJ(14)=MSTJ14
3889 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3890 MSTU(24)=0
3891 GOTO 100
3892 ENDIF
3893 IF(MINT(51).EQ.1) GOTO 110
3894 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3895 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3896 DO 220 I=MINT(84)+1,N
3897 IF(K(I,2).EQ.94) THEN
3898 DO 210 I1=I+1,MIN(N,I+10)
3899 IF(K(I1,3).EQ.I) THEN
3900 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3901 IF(K(I1,3).EQ.0) THEN
3902 DO 200 II=MINT(84)+1,I-1
3903 IF(K(II,2).EQ.K(I1,2)) THEN
3904 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3905 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3906 ENDIF
3907 200 CONTINUE
3908 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3909 ENDIF
3910 ENDIF
3911 210 CONTINUE
3912CC...Also collapse particles decaying to themselves (if same KS)
3913 ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3914 & .AND.K(I,4).LT.N) THEN
3915 IDA=K(I,4)
3916 IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3917 K(I,1)=0
3918 ENDIF
3919 ENDIF
3920 220 CONTINUE
3921 CALL PYEDIT(12)
3922 CALL PYEDIT(14)
3923 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3924 IF(MSTP(125).EQ.0) MINT(4)=0
3925 DO 240 I=MINT(83)+1,N
3926 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3927 DO 230 I1=I+1,N
3928 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3929 IF(K(I1,3).EQ.I) K(I,5)=I1
3930 230 CONTINUE
3931 ENDIF
3932 240 CONTINUE
3933 ENDIF
3934
3935C...Introduce separators between sections in PYLIST event listing.
3936 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3937 MSTU70=1
3938 MSTU(71)=N
3939 ELSEIF(IPILE.EQ.1) THEN
3940 MSTU70=3
3941 MSTU(71)=2
3942 MSTU(72)=MINT(4)
3943 MSTU(73)=N
3944 ENDIF
3945
3946C...Go back to lab frame (needed for vertices, also in fragmentation).
3947 CALL PYFRAM(1)
3948
3949C...Set nonvanishing production vertex (optional).
3950 IF(MSTP(151).EQ.1) THEN
3951 DO 250 J=1,4
3952 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3953 & SIN(PARU(2)*PYR(0))
3954 250 CONTINUE
3955 DO 270 I=MINT(83)+1,N
3956 DO 260 J=1,4
3957 V(I,J)=V(I,J)+VTX(J)
3958 260 CONTINUE
3959 270 CONTINUE
3960 ENDIF
3961
3962C...Perform hadronization (if desired).
3963 IF(MSTP(111).GE.1) THEN
3964 CALL PYEXEC
3965 IF(MSTU(24).NE.0) GOTO 100
3966 ENDIF
3967 IF(MSTP(113).GE.1) THEN
3968 DO 280 I=NRECAL,N
3969 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3970 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3971 280 CONTINUE
3972 ENDIF
3973 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3974
3975C...Store event information and calculate Monte Carlo estimates of
3976C...subprocess cross-sections.
3977 290 IF(IPILE.EQ.1) CALL PYDOCU
3978
3979C...Set counters for current pileup event and loop to next one.
3980 MSTI(41)=IPILE
3981 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3982 IF(MSTU70.LT.10) THEN
3983 MSTU70=MSTU70+1
3984 MSTU(70+MSTU70)=N
3985 ENDIF
3986 MINT(83)=N
3987 MINT(84)=N+MSTP(126)
3988 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3989 300 CONTINUE
3990
3991C...Generic information on pileup events. Reconstruct missing history.
3992 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3993 PARI(91)=VINT(132)
3994 PARI(92)=VINT(133)
3995 PARI(93)=VINT(134)
3996 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3997 ENDIF
3998 CALL PYEDIT(16)
3999
4000C...Transform to the desired coordinate frame.
4001 310 CALL PYFRAM(MSTP(124))
4002 MSTU(70)=MSTU70
4003 PARU(21)=VINT(1)
4004
4005C...Error messages
4006 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4007 &1X,'Execution stopped.')
4008
4009 RETURN
4010 END
4011
4012
4013C***********************************************************************
4014
4015C...PYSTAT
4016C...Prints out information about cross-sections, decay widths, branching
4017C...ratios, kinematical limits, status codes and parameter values.
4018
4019 SUBROUTINE PYSTAT(MSTAT)
4020
4021C...Double precision and integer declarations.
4022 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4023 IMPLICIT INTEGER(I-N)
4024 INTEGER PYK,PYCHGE,PYCOMP
4025C...Parameter statement to help give large particle numbers.
4026 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4027 &KEXCIT=4000000,KDIMEN=5000000)
4028 PARAMETER (EPS=1D-3)
4029C...Commonblocks.
4030 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4031 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4032 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4033 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4034 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4035 COMMON/PYINT1/MINT(400),VINT(400)
4036 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4037 COMMON/PYINT4/MWID(500),WIDS(500,5)
4038 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4039 COMMON/PYINT6/PROC(0:500)
4040 CHARACTER PROC*28, CHTMP*16
4041 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4042 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4043 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4044 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4045C...Local arrays, character variables and data.
4046 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4047 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4048 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4049 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4050 CHARACTER*24 CHD0, CHDC(10)
4051 CHARACTER*6 DNAME(3)
4052 DATA PROGA/
4053 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4054 &'VMD/hadron * anomalous ','direct * direct ',
4055 &'direct * anomalous ','anomalous * anomalous '/
4056 DATA DISGA/'e * VMD','e * anomalous'/
4057 DATA PROGG9/
4058 &'direct * direct ','direct * VMD ',
4059 &'direct * anomalous ','VMD * direct ',
4060 &'VMD * VMD ','VMD * anomalous ',
4061 &'anomalous * direct ','anomalous * VMD ',
4062 &'anomalous * anomalous ','DIS * VMD ',
4063 &'DIS * anomalous ','VMD * DIS ',
4064 &'anomalous * DIS '/
4065 DATA PROGG4/
4066 &'direct * direct ','direct * resolved ',
4067 &'resolved * direct ','resolved * resolved '/
4068 DATA PROGG2/
4069 &'direct * hadron ','resolved * hadron '/
4070 DATA PROGP4/
4071 &'VMD * hadron ','direct * hadron ',
4072 &'anomalous * hadron ','DIS * hadron '/
4073 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4074 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4075 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4076 &' y*_small ',' eta*_large ',' eta*_small ',
4077 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4078 &' x_2 ',' x_F ',' cos(theta_hard) ',
4079 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4080 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4081 &' tau'' '/
4082 DATA DNAME /'q ','lepton','nu '/
4083
4084C...Cross-sections.
4085 IF(MSTAT.LE.1) THEN
4086 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4087 WRITE(MSTU(11),5000)
4088 WRITE(MSTU(11),5100)
4089 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4090 DO 100 I=1,500
4091 IF(MSUB(I).NE.1) GOTO 100
4092 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4093 100 CONTINUE
4094 IF(MINT(121).GT.1) THEN
4095 WRITE(MSTU(11),5300)
4096 DO 110 IGA=1,MINT(121)
4097 CALL PYSAVE(3,IGA)
4098 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4099 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4100 & XSEC(0,3)
4101 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4102 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4103 & XSEC(0,3)
4104 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4105 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4106 & XSEC(0,3)
4107 ELSEIF(MINT(121).EQ.4) THEN
4108 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4109 & XSEC(0,3)
4110 ELSEIF(MINT(121).EQ.2) THEN
4111 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4112 & XSEC(0,3)
4113 ELSE
4114 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4115 & XSEC(0,3)
4116 ENDIF
4117 110 CONTINUE
4118 CALL PYSAVE(5,0)
4119 ENDIF
4120 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4121 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4122
4123C...Decay widths and branching ratios.
4124 ELSEIF(MSTAT.EQ.2) THEN
4125 WRITE(MSTU(11),5500)
4126 WRITE(MSTU(11),5600)
4127 DO 140 KC=1,500
4128 KF=KCHG(KC,4)
4129 CALL PYNAME(KF,CHKF)
4130 IOFF=0
4131 IF(KC.LE.22) THEN
4132 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4133 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4134 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4135 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4136 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4137 ELSE
4138 IF(MWID(KC).LE.0) GOTO 140
4139 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4140 & KF/KSUSY1.EQ.2)) GOTO 140
4141 ENDIF
4142C...Off-shell branchings.
4143 IF(IOFF.EQ.1) THEN
4144 NGP=0
4145 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4146 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4147 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4148 DO 120 J=1,MDCY(KC,3)
4149 IDC=J+MDCY(KC,2)-1
4150 NGP1=0
4151 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4152 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4153 NGP2=0
4154 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4155 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4156 CALL PYNAME(KFDP(IDC,1),CHD1)
4157 CALL PYNAME(KFDP(IDC,2),CHD2)
4158 IF(KFDP(IDC,3).EQ.0) THEN
4159 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4160 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4161 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4162 ELSE
4163 CALL PYNAME(KFDP(IDC,3),CHD3)
4164 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4165 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4166 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4167 ENDIF
4168 120 CONTINUE
4169C...On-shell decays.
4170 ELSE
4171 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4172 BRFIN=1D0
4173 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4174 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4175 & STATE(MDCY(KC,1)),BRFIN
4176 DO 130 J=1,MDCY(KC,3)
4177 IDC=J+MDCY(KC,2)-1
4178 NGP1=0
4179 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4180 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4181 NGP2=0
4182 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4183 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4184 BRPRI=0D0
4185 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4186 BRFIN=0D0
4187 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4188 CALL PYNAME(KFDP(IDC,1),CHD1)
4189 CALL PYNAME(KFDP(IDC,2),CHD2)
4190 IF(KFDP(IDC,3).EQ.0) THEN
4191 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4192 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4193 & CHD2(1:10),WDTP(J),BRPRI,
4194 & STATE(MDME(IDC,1)),BRFIN
4195 ELSE
4196 CALL PYNAME(KFDP(IDC,3),CHD3)
4197 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4198 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4199 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4200 & STATE(MDME(IDC,1)),BRFIN
4201 ENDIF
4202 130 CONTINUE
4203 ENDIF
4204 140 CONTINUE
4205 WRITE(MSTU(11),6000)
4206
4207C...Allowed incoming partons/particles at hard interaction.
4208 ELSEIF(MSTAT.EQ.3) THEN
4209 WRITE(MSTU(11),6100)
4210 CALL PYNAME(MINT(11),CHAU)
4211 CHIN(1)=CHAU(1:12)
4212 CALL PYNAME(MINT(12),CHAU)
4213 CHIN(2)=CHAU(1:12)
4214 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4215 DO 150 I=-20,22
4216 IF(I.EQ.0) GOTO 150
4217 IA=IABS(I)
4218 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4219 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4220 CALL PYNAME(I,CHAU)
4221 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4222 & STATE(KFIN(2,I))
4223 150 CONTINUE
4224 WRITE(MSTU(11),6400)
4225
4226C...User-defined limits on kinematical variables.
4227 ELSEIF(MSTAT.EQ.4) THEN
4228 WRITE(MSTU(11),6500)
4229 WRITE(MSTU(11),6600)
4230 SHRMAX=CKIN(2)
4231 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4232 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4233 PTHMIN=MAX(CKIN(3),CKIN(5))
4234 PTHMAX=CKIN(4)
4235 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4236 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4237 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4238 DO 160 I=4,14
4239 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4240 160 CONTINUE
4241 SPRMAX=CKIN(32)
4242 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4243 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4244 WRITE(MSTU(11),7000)
4245
4246C...Status codes and parameter values.
4247 ELSEIF(MSTAT.EQ.5) THEN
4248 WRITE(MSTU(11),7100)
4249 WRITE(MSTU(11),7200)
4250 DO 170 I=1,100
4251 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4252 & PARP(100+I)
4253 170 CONTINUE
4254
4255C...List of all processes implemented in the program.
4256 ELSEIF(MSTAT.EQ.6) THEN
4257 WRITE(MSTU(11),7400)
4258 WRITE(MSTU(11),7500)
4259 DO 180 I=1,500
4260 IF(ISET(I).LT.0) GOTO 180
4261 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4262 180 CONTINUE
4263 WRITE(MSTU(11),7700)
4264
4265 ELSEIF(MSTAT.EQ.7) THEN
4266 WRITE (MSTU(11),8000)
4267 NMODES(0)=0
4268 NMODES(10)=0
4269 NMODES(9)=0
4270 DO 290 ILR=1,2
4271 DO 280 KFSM=1,16
4272 KFSUSY=ILR*KSUSY1+KFSM
4273 NRVDC=0
4274C...SDOWN DECAYS
4275 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4276 NRVDC=3
4277 DO 190 I=1,NRVDC
4278 PBRAT(I)=0D0
4279 NMODES(I)=0
4280 190 CONTINUE
4281 CALL PYNAME(KFSUSY,CHTMP)
4282 CHD0=CHTMP//' '
4283 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4284 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4285 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4286 KC=PYCOMP(KFSUSY)
4287 DO 200 J=1,MDCY(KC,3)
4288 IDC=J+MDCY(KC,2)-1
4289 ID1=IABS(KFDP(IDC,1))
4290 ID2=IABS(KFDP(IDC,2))
4291 IF (KFDP(IDC,3).EQ.0) THEN
4292 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4293 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4294 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4295 NMODES(1)=NMODES(1)+1
4296 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4297 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4298 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4299 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4300 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4301 NMODES(2)=NMODES(2)+1
4302 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4303 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4304 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4305 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4306 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4307 NMODES(3)=NMODES(3)+1
4308 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4309 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4310 ENDIF
4311 ENDIF
4312 200 CONTINUE
4313 ENDIF
4314C...SUP DECAYS
4315 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4316 NRVDC=2
4317 DO 210 I=1,NRVDC
4318 NMODES(I)=0
4319 PBRAT(I)=0D0
4320 210 CONTINUE
4321 CALL PYNAME(KFSUSY,CHTMP)
4322 CHD0=CHTMP//' '
4323 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4324 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4325 KC=PYCOMP(KFSUSY)
4326 DO 220 J=1,MDCY(KC,3)
4327 IDC=J+MDCY(KC,2)-1
4328 ID1=IABS(KFDP(IDC,1))
4329 ID2=IABS(KFDP(IDC,2))
4330 IF (KFDP(IDC,3).EQ.0) THEN
4331 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4332 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4333 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4334 NMODES(1)=NMODES(1)+1
4335 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4336 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4337 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4338 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4339 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4340 NMODES(2)=NMODES(2)+1
4341 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4342 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4343 ENDIF
4344 ENDIF
4345 220 CONTINUE
4346 ENDIF
4347C...SLEPTON DECAYS
4348 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4349 NRVDC=2
4350 DO 230 I=1,NRVDC
4351 PBRAT(I)=0D0
4352 NMODES(I)=0
4353 230 CONTINUE
4354 CALL PYNAME(KFSUSY,CHTMP)
4355 CHD0=CHTMP//' '
4356 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4357 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4358 KC=PYCOMP(KFSUSY)
4359 DO 240 J=1,MDCY(KC,3)
4360 IDC=J+MDCY(KC,2)-1
4361 ID1=IABS(KFDP(IDC,1))
4362 ID2=IABS(KFDP(IDC,2))
4363 IF (KFDP(IDC,3).EQ.0) THEN
4364 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4365 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4366 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4367 NMODES(1)=NMODES(1)+1
4368 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4369 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4370 ENDIF
4371 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4372 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4373 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4374 NMODES(2)=NMODES(2)+1
4375 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4376 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4377 ENDIF
4378 ENDIF
4379 240 CONTINUE
4380 ENDIF
4381C...SNEUTRINO DECAYS
4382 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4383 & THEN
4384 NRVDC=2
4385 DO 250 I=1,NRVDC
4386 PBRAT(I)=0D0
4387 NMODES(I)=0
4388 250 CONTINUE
4389 CALL PYNAME(KFSUSY,CHTMP)
4390 CHD0=CHTMP//' '
4391 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4392 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4393 KC=PYCOMP(KFSUSY)
4394 DO 260 J=1,MDCY(KC,3)
4395 IDC=J+MDCY(KC,2)-1
4396 ID1=IABS(KFDP(IDC,1))
4397 ID2=IABS(KFDP(IDC,2))
4398 IF (KFDP(IDC,3).EQ.0) THEN
4399 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4400 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4401 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4402 NMODES(1)=NMODES(1)+1
4403 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4404 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4405 ENDIF
4406 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4407 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4408 NMODES(2)=NMODES(2)+1
4409 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4410 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4411 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4412 ENDIF
4413 ENDIF
4414 260 CONTINUE
4415 ENDIF
4416 IF (NRVDC.NE.0) THEN
4417 DO 270 I=1,NRVDC
4418 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4419 NMODES(0)=NMODES(0)+NMODES(I)
4420 270 CONTINUE
4421 ENDIF
4422 280 CONTINUE
4423 290 CONTINUE
4424 DO 370 KFSM=21,37
4425 KFSUSY=KSUSY1+KFSM
4426 NRVDC=0
4427C...NEUTRALINO DECAYS
4428 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4429 NRVDC=4
4430 DO 300 I=1,NRVDC
4431 PBRAT(I)=0D0
4432 NMODES(I)=0
4433 300 CONTINUE
4434 CALL PYNAME(KFSUSY,CHTMP)
4435 CHD0=CHTMP//' '
4436 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4437 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4438 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4439 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4440 KC=PYCOMP(KFSUSY)
4441 DO 310 J=1,MDCY(KC,3)
4442 IDC=J+MDCY(KC,2)-1
4443 ID1=IABS(KFDP(IDC,1))
4444 ID2=IABS(KFDP(IDC,2))
4445 ID3=IABS(KFDP(IDC,3))
4446 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4447 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4448 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4449 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4450 NMODES(1)=NMODES(1)+1
4451 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4452 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4453 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4454 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4455 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4456 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4457 NMODES(2)=NMODES(2)+1
4458 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4459 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4460 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4461 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4462 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4463 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4464 NMODES(3)=NMODES(3)+1
4465 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4466 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4467 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4468 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4469 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4470 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4471 NMODES(4)=NMODES(4)+1
4472 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4473 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4474 ENDIF
4475 310 CONTINUE
4476 ENDIF
4477C...CHARGINO DECAYS
4478 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4479 NRVDC=5
4480 DO 320 I=1,NRVDC
4481 PBRAT(I)=0D0
4482 NMODES(I)=0
4483 320 CONTINUE
4484 CALL PYNAME(KFSUSY,CHTMP)
4485 CHD0=CHTMP//' '
4486 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4487 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4488 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4489 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4490 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4491 KC=PYCOMP(KFSUSY)
4492 DO 330 J=1,MDCY(KC,3)
4493 IDC=J+MDCY(KC,2)-1
4494 ID1=IABS(KFDP(IDC,1))
4495 ID2=IABS(KFDP(IDC,2))
4496 ID3=IABS(KFDP(IDC,3))
4497 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4498 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4499 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4500 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4501 NMODES(1)=NMODES(1)+1
4502 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4503 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4504 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4505 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4506 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4507 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4508 NMODES(1)=NMODES(1)+1
4509 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4510 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4511 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4512 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4513 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4514 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4515 NMODES(2)=NMODES(2)+1
4516 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4517 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4518 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4519 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4520 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4521 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4522 NMODES(3)=NMODES(3)+1
4523 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4524 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4525 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4526 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4527 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4528 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4529 NMODES(3)=NMODES(3)+1
4530 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4531 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4532 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4533 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4534 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4535 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4536 NMODES(4)=NMODES(4)+1
4537 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4538 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4539 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4540 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4541 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4542 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4543 NMODES(4)=NMODES(4)+1
4544 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4545 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4546 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4547 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4548 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4549 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4550 NMODES(5)=NMODES(5)+1
4551 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4552 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4553 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4554 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4555 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4556 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4557 NMODES(5)=NMODES(5)+1
4558 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4559 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4560 ENDIF
4561 330 CONTINUE
4562 ENDIF
4563C...GLUINO DECAYS
4564 IF (KFSM.EQ.21) THEN
4565 NRVDC=3
4566 DO 340 I=1,NRVDC
4567 PBRAT(I)=0D0
4568 NMODES(I)=0
4569 340 CONTINUE
4570 CALL PYNAME(KFSUSY,CHTMP)
4571 CHD0=CHTMP//' '
4572 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4573 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4574 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4575 KC=PYCOMP(KFSUSY)
4576 DO 350 J=1,MDCY(KC,3)
4577 IDC=J+MDCY(KC,2)-1
4578 ID1=IABS(KFDP(IDC,1))
4579 ID2=IABS(KFDP(IDC,2))
4580 ID3=IABS(KFDP(IDC,3))
4581 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4582 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4583 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4584 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4585 NMODES(1)=NMODES(1)+1
4586 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4587 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4588 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4589 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4590 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4591 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4592 NMODES(2)=NMODES(2)+1
4593 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4594 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4595 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4596 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4597 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4598 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4599 NMODES(3)=NMODES(3)+1
4600 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4601 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4602 ENDIF
4603 350 CONTINUE
4604 ENDIF
4605
4606 IF (NRVDC.NE.0) THEN
4607 DO 360 I=1,NRVDC
4608 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4609 NMODES(0)=NMODES(0)+NMODES(I)
4610 360 CONTINUE
4611 ENDIF
4612 370 CONTINUE
4613 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4614
4615 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4616 WRITE (MSTU(11),8500)
4617 DO 400 IRV=1,3
4618 DO 390 JRV=1,3
4619 DO 380 KRV=1,3
4620 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4621 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4622 380 CONTINUE
4623 390 CONTINUE
4624 400 CONTINUE
4625 WRITE (MSTU(11),8600)
4626 ENDIF
4627 ENDIF
4628
4629C...Formats for printouts.
4630 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4631 &'Events and Cross-sections',1X,9('*'))
4632 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4633 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4634 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4635 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4636 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4637 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4638 &'I',12X,'I')
4639 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4640 &D10.3,1X,'I')
4641 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4642 &1X,'I',34X,'I',28X,'I',12X,'I')
4643 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4644 &1X,'********* Total number of errors, excluding junctions =',
4645 &1X,I8,' *************'/
4646 &1X,'********* Total number of errors, including junctions =',
4647 &1X,I8,' *************'/
4648 &1X,'********* Total number of warnings = ',
4649 &1X,I8,' *************'/
4650 &1X,'********* Fraction of events that fail fragmentation ',
4651 &'cuts =',1X,F8.5,' *********'/)
4652 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4653 &'Ratios',1X,27('*'))
4654 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4655 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4656 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4657 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4658 &1X,98('='))
4659 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4660 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4661 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4662 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4663 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4664 &1P,D10.3,0P,1X,'I')
4665 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4666 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4667 &1P,D10.3,0P,1X,'I')
4668 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4669 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4670 &'Particles at Hard Interaction',1X,7('*'))
4671 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4672 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4673 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4674 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4675 &78('=')/1X,'I',38X,'I',37X,'I')
4676 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4677 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4678 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4679 &'Kinematical Variables',1X,12('*'))
4680 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4681 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4682 &16X,'I')
4683 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4684 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4685 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4686 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4687 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4688 &'Parameter Values',1X,12('*'))
4689 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4690 &'PARP(I)'/)
4691 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4692 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4693 &1X,13('*'))
4694 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4695 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4696 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4697 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4698 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4699 8000 FORMAT(1X/ 1X/
4700 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4701 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4702 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4703 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4704 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4705 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4706 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4707 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4708 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4709 & /1X,70('='))
4710 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4711 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4712 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4713 8500 FORMAT(1X/ 1X/
4714 & 1X,'R-Violating couplings',1X/ 1X /
4715 & 1X,55('=')/
4716 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4717 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4718 & ,'I',15X,'I',15X,'I',15X,'I')
4719 8600 FORMAT(1X,55('='))
4720 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4721 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4722
4723 RETURN
4724 END
4725
4726C*********************************************************************
4727
4728C...PYUPEV
4729C...Administers the hard-process generation required for output to the
4730C...Les Houches event record.
4731
4732 SUBROUTINE PYUPEV
4733
4734C...Double precision and integer declarations.
4735 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4736 IMPLICIT INTEGER(I-N)
4737 INTEGER PYK,PYCHGE,PYCOMP
4738
4739C...Commonblocks.
4740 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4741 COMMON/PYCTAG/NCT,MCT(4000,2)
4742 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4743 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4744 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4745 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4746 COMMON/PYINT1/MINT(400),VINT(400)
4747 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4748 COMMON/PYINT4/MWID(500),WIDS(500,5)
4749 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4750 &/PYINT1/,/PYINT2/,/PYINT4/
4751
4752C...HEPEUP for output.
4753 INTEGER MAXNUP
4754 PARAMETER (MAXNUP=500)
4755 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4756 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4757 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4758 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4759 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4760 SAVE /HEPEUP/
4761
4762C...Stop if no subprocesses on.
4763 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4764 WRITE(MSTU(11),5100)
4765 STOP
4766 ENDIF
4767
4768C...Special flags for hard-process generation only.
4769 MSTP71=MSTP(71)
4770 MSTP(71)=0
4771 MST128=MSTP(128)
4772 MSTP(128)=1
4773
4774C...Initial values for some counters.
4775 N=0
4776 MINT(5)=MINT(5)+1
4777 MINT(7)=0
4778 MINT(8)=0
4779 MINT(30)=0
4780 MINT(83)=0
4781 MINT(84)=MSTP(126)
4782 MSTU(24)=0
4783 MSTU70=0
4784 MSTJ14=MSTJ(14)
4785C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4786 MINT(33)=0
4787
4788C...If variable energies: redo incoming kinematics and cross-section.
4789 MSTI(61)=0
4790 IF(MSTP(171).EQ.1) THEN
4791 CALL PYINKI(1)
4792 IF(MSTI(61).EQ.1) THEN
4793 MINT(5)=MINT(5)-1
4794 RETURN
4795 ENDIF
4796 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4797 CALL PYXTOT
4798 ENDIF
4799
4800C...Do not allow pileup events.
4801 MINT(82)=1
4802
4803C...Generate variables of hard scattering.
4804 MINT(51)=0
4805 MSTI(52)=0
4806 100 CONTINUE
4807 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4808 MINT(31)=0
4809 MINT(51)=0
4810 MINT(57)=0
4811 CALL PYRAND
4812 IF(MSTI(61).EQ.1) THEN
4813 MINT(5)=MINT(5)-1
4814 RETURN
4815 ENDIF
4816 IF(MINT(51).EQ.2) RETURN
4817 ISUB=MINT(1)
4818
4819 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4820C...Hard scattering (including low-pT):
4821C...reconstruct kinematics and colour flow of hard scattering.
4822 MINT31=MINT(31)
4823 110 MINT(31)=MINT31
4824 MINT(51)=0
4825 CALL PYSCAT
4826 IF(MINT(51).EQ.1) GOTO 100
4827 IPU1=MINT(84)+1
4828 IPU2=MINT(84)+2
4829
4830C...Decay of final state resonances.
4831 MINT(32)=0
4832 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4833 & CALL PYRESD(0)
4834 IF(MINT(51).EQ.1) GOTO 100
4835 MINT(52)=N
4836
4837C...Longitudinal boost of hard scattering.
4838 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4839 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4840
4841 ELSEIF(ISUB.NE.99) THEN
4842C...Diffractive and elastic scattering.
4843 CALL PYDIFF
4844
4845 ELSE
4846C...DIS scattering (photon flux external).
4847 CALL PYDISG
4848 IF(MINT(51).EQ.1) GOTO 100
4849 ENDIF
4850
4851C...Check that no odd resonance left undecayed.
4852 MINT(54)=N
4853 NFIX=N
4854 DO 120 I=MINT(84)+1,NFIX
4855 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4856 & K(I,2).NE.22) THEN
4857 KCA=PYCOMP(K(I,2))
4858 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4859 CALL PYRESD(I)
4860 IF(MINT(51).EQ.1) GOTO 100
4861 ENDIF
4862 ENDIF
4863 120 CONTINUE
4864
4865C...Boost hadronic subsystem to overall rest frame.
4866C..(Only relevant when photon inside lepton beam.)
4867 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4868
4869C...Store event information and calculate Monte Carlo estimates of
4870C...subprocess cross-sections.
4871 130 CALL PYDOCU
4872
4873C...Transform to the desired coordinate frame.
4874 140 CALL PYFRAM(MSTP(124))
4875 MSTU(70)=MSTU70
4876 PARU(21)=VINT(1)
4877
4878C...Restore special flags for hard-process generation only.
4879 MSTP(71)=MSTP71
4880 MSTP(128)=MST128
4881
4882C...Trace colour tags; convert to LHA style labels.
4883 NCT=100
4884 DO 150 I=MINT(84)+1,N
4885 MCT(I,1)=0
4886 MCT(I,2)=0
4887 150 CONTINUE
4888 DO 160 I=MINT(84)+1,N
4889 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4890 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4891 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4892 & THEN
4893 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4894 IDA=MOD(K(I,4),MSTU(5))
4895 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4896 & MCT(IMO,2).NE.0) THEN
4897 MCT(I,1)=MCT(IMO,2)
4898 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4899 & MCT(IMO,1).NE.0) THEN
4900 MCT(I,1)=MCT(IMO,1)
4901 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4902 & MCT(IDA,2).NE.0) THEN
4903 MCT(I,1)=MCT(IDA,2)
4904 ELSE
4905 NCT=NCT+1
4906 MCT(I,1)=NCT
4907 ENDIF
4908 ENDIF
4909 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4910 & THEN
4911 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4912 IDA=MOD(K(I,5),MSTU(5))
4913 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4914 & MCT(IMO,1).NE.0) THEN
4915 MCT(I,2)=MCT(IMO,1)
4916 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4917 & MCT(IMO,2).NE.0) THEN
4918 MCT(I,2)=MCT(IMO,2)
4919 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4920 & MCT(IDA,1).NE.0) THEN
4921 MCT(I,2)=MCT(IDA,1)
4922 ELSE
4923 NCT=NCT+1
4924 MCT(I,2)=NCT
4925 ENDIF
4926 ENDIF
4927 ENDIF
4928 160 CONTINUE
4929
4930C...Put event in HEPEUP commonblock.
4931 NUP=N-MINT(84)
4932 IDPRUP=MINT(1)
4933 XWGTUP=1D0
4934 SCALUP=VINT(53)
4935 AQEDUP=VINT(57)
4936 AQCDUP=VINT(58)
4937 DO 180 I=1,NUP
4938 IDUP(I)=K(I+MINT(84),2)
4939 IF(I.LE.2) THEN
4940 ISTUP(I)=-1
4941 MOTHUP(1,I)=0
4942 MOTHUP(2,I)=0
4943 ELSEIF(K(I+4,3).EQ.0) THEN
4944 ISTUP(I)=1
4945 MOTHUP(1,I)=1
4946 MOTHUP(2,I)=2
4947 ELSE
4948 ISTUP(I)=1
4949 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4950 MOTHUP(2,I)=0
4951 ENDIF
4952 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4953 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4954 ICOLUP(1,I)=MCT(I+MINT(84),1)
4955 ICOLUP(2,I)=MCT(I+MINT(84),2)
4956 DO 170 J=1,5
4957 PUP(J,I)=P(I+MINT(84),J)
4958 170 CONTINUE
4959 VTIMUP(I)=V(I,5)
4960 SPINUP(I)=9D0
4961 180 CONTINUE
4962
4963C...Optionally write out event to disk. Minimal size for time/spin fields.
4964 IF(MSTP(162).GT.0) THEN
4965 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4966 DO 190 I=1,NUP
4967 IF(VTIMUP(I).EQ.0D0) THEN
4968 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4969 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4970 & ' 0. 9.'
4971 ELSE
4972 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4973 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4974 & VTIMUP(I),' 9.'
4975 ENDIF
4976 190 CONTINUE
4977
4978C...Optional extra line with parton-density information.
4979 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4980 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4981 ENDIF
4982
4983C...Error messages and other print formats.
4984 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4985 &1X,'Execution stopped.')
4986 5200 FORMAT(1P,2I6,4E14.6)
4987 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4988 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4989 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4990
4991 RETURN
4992 END
4993
4994C*********************************************************************
4995
4996C...PYUPIN
4997C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4998C...processes, and optionally stores that information on file.
4999
5000 SUBROUTINE PYUPIN
5001
5002C...Double precision and integer declarations.
5003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5004 IMPLICIT INTEGER(I-N)
5005
5006C...Commonblocks.
5007 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5008 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5009 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5010 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5011 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5012
5013C...User process initialization commonblock.
5014 INTEGER MAXPUP
5015 PARAMETER (MAXPUP=100)
5016 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5017 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5018 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5019 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5020 &LPRUP(MAXPUP)
5021 SAVE /HEPRUP/
5022
5023C...Store info on incoming beams.
5024 IDBMUP(1)=K(1,2)
5025 IDBMUP(2)=K(2,2)
5026 EBMUP(1)=P(1,4)
5027 EBMUP(2)=P(2,4)
5028 PDFGUP(1)=0
5029 PDFGUP(2)=0
5030 PDFSUP(1)=MSTP(51)
5031 PDFSUP(2)=MSTP(51)
5032
5033C...Event weighting strategy.
5034 IDWTUP=3
5035
5036C...Info on individual processes.
5037 NPRUP=0
5038 DO 100 ISUB=1,500
5039 IF(MSUB(ISUB).EQ.1) THEN
5040 NPRUP=NPRUP+1
5041 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5042 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5043 XMAXUP(NPRUP)=1D0
5044 LPRUP(NPRUP)=ISUB
5045 ENDIF
5046 100 CONTINUE
5047
5048C...Write info to file.
5049 IF(MSTP(161).GT.0) THEN
5050 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5051 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5052 DO 110 IPR=1,NPRUP
5053 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5054 & LPRUP(IPR)
5055 110 CONTINUE
5056 ENDIF
5057
5058C...Formats for printout.
5059 5100 FORMAT(1P,2I8,2E14.6,6I6)
5060 5200 FORMAT(1P,3E14.6,I6)
5061
5062 RETURN
5063 END
5064
5065
5066C*********************************************************************
5067
5068C...Combine the two old-style Pythia initialization and event files
5069C...into a single Les Houches Event File.
5070
5071 SUBROUTINE PYLHEF
5072
5073C...Double precision and integer declarations.
5074 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5075 IMPLICIT INTEGER(I-N)
5076
5077C...PYTHIA commonblock: only used to provide read/write units and version.
5078 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5079 SAVE /PYPARS/
5080
5081C...User process initialization commonblock.
5082 INTEGER MAXPUP
5083 PARAMETER (MAXPUP=100)
5084 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5085 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5086 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5087 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5088 &LPRUP(MAXPUP)
5089 SAVE /HEPRUP/
5090
5091C...User process event common block.
5092 INTEGER MAXNUP
5093 PARAMETER (MAXNUP=500)
5094 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5095 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5096 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5097 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5098 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5099 SAVE /HEPEUP/
5100
5101C...Lines to read in assumed never longer than 200 characters.
5102 PARAMETER (MAXLEN=200)
5103 CHARACTER*(MAXLEN) STRING
5104
5105C...Format for reading lines.
5106 CHARACTER*6 STRFMT
5107 STRFMT='(A000)'
5108 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5109
5110C...Rewind initialization and event files.
5111 REWIND MSTP(161)
5112 REWIND MSTP(162)
5113
5114C...Write header info.
5115 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5116 WRITE(MSTP(163),'(A)') '<!--'
5117 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5118 &MSTP(181),'.',MSTP(182)
5119 WRITE(MSTP(163),'(A)') '-->'
5120
5121C...Read first line of initialization info and get number of processes.
5122 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5123 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5124 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5125
5126C...Copy initialization lines, omitting trailing blanks.
5127C...Embed in <init> ... </init> block.
5128 WRITE(MSTP(163),'(A)') '<init>'
5129 DO 140 IPR=0,NPRUP
5130 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5131 LEN=MAXLEN+1
5132 120 LEN=LEN-1
5133 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5134 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5135 140 CONTINUE
5136 WRITE(MSTP(163),'(A)') '</init>'
5137
5138C...Begin event loop. Read first line of event info or already done.
5139 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5140 200 CONTINUE
5141
5142C...Look at first line to know number of particles in event.
5143 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5144
5145C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5146 WRITE(MSTP(163),'(A)') '<event>'
5147 DO 240 I=0,NUP
5148 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5149 LEN=MAXLEN+1
5150 220 LEN=LEN-1
5151 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5152 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5153 240 CONTINUE
5154
5155C...Copy trailing comment lines - with a # in the first column - as is.
5156 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5157 IF(STRING(1:1).EQ.'#') THEN
5158 LEN=MAXLEN+1
5159 280 LEN=LEN-1
5160 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5161 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5162 GOTO 260
5163 ENDIF
5164
5165C..End the <event> block. Loop back to look for next event.
5166 WRITE(MSTP(163),'(A)') '</event>'
5167 GOTO 200
5168
5169C...Successfully reached end of event loop: write closing tag
5170C...and remove temporary intermediate files (unless asked not to).
5171 300 WRITE(MSTP(163),'(A)') '</event>'
5172 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5173 IF(MSTP(164).EQ.1) RETURN
5174 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5175 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5176 RETURN
5177
5178C...Error exit.
5179 400 WRITE(*,*) ' PYLHEF file joining failed!'
5180
5181 RETURN
5182 END
5183
5184C*********************************************************************
5185
5186C...PYINRE
5187C...Calculates full and effective widths of gauge bosons, stores
5188C...masses and widths, rescales coefficients to be used for
5189C...resonance production generation.
5190
5191 SUBROUTINE PYINRE
5192
5193C...Double precision and integer declarations.
5194 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5195 IMPLICIT INTEGER(I-N)
5196 INTEGER PYK,PYCHGE,PYCOMP
5197C...Parameter statement to help give large particle numbers.
5198 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5199 &KEXCIT=4000000,KDIMEN=5000000)
5200C...Commonblocks.
5201 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5202 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5203 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5204 COMMON/PYDAT4/CHAF(500,2)
5205 CHARACTER CHAF*16
5206 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5207 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5208 COMMON/PYINT1/MINT(400),VINT(400)
5209 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5210 COMMON/PYINT4/MWID(500),WIDS(500,5)
5211 COMMON/PYINT6/PROC(0:500)
5212 CHARACTER PROC*28
5213 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5214 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5215 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5216C...Local arrays and data.
5217 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5218 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5219
5220C...Born level couplings in MSSM Higgs doublet sector.
5221 XW=PARU(102)
5222 XWV=XW
5223 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5224 XW1=1D0-XW
5225 IF(MSTP(4).EQ.2) THEN
5226 TANBE=PARU(141)
5227 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5228 SQMZ=PMAS(23,1)**2
5229 SQMW=PMAS(24,1)**2
5230 SQMH=PMAS(25,1)**2
5231 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5232 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5233 SQMHC=SQMA+SQMW
5234 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5235 WRITE(MSTU(11),5000)
5236 CALL PYSTOP(101)
5237 ENDIF
5238 PMAS(35,1)=SQRT(SQMHP)
5239 PMAS(36,1)=SQRT(SQMA)
5240 PMAS(37,1)=SQRT(SQMHC)
5241 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5242 & (SQMA-SQMZ)))
5243 BESU=ATAN(TANBE)
5244 PARU(142)=1D0
5245 PARU(143)=1D0
5246 PARU(161)=-SIN(ALSU)/COS(BESU)
5247 PARU(162)=COS(ALSU)/SIN(BESU)
5248 PARU(163)=PARU(161)
5249 PARU(164)=SIN(BESU-ALSU)
5250 PARU(165)=PARU(164)
5251 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5252 PARU(171)=COS(ALSU)/COS(BESU)
5253 PARU(172)=SIN(ALSU)/SIN(BESU)
5254 PARU(173)=PARU(171)
5255 PARU(174)=COS(BESU-ALSU)
5256 PARU(175)=PARU(174)
5257 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5258 & SIN(BESU+ALSU)
5259 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5260 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5261 PARU(181)=TANBE
5262 PARU(182)=1D0/TANBE
5263 PARU(183)=PARU(181)
5264 PARU(184)=0D0
5265 PARU(185)=PARU(184)
5266 PARU(186)=COS(BESU-ALSU)
5267 PARU(187)=SIN(BESU-ALSU)
5268 PARU(188)=PARU(186)
5269 PARU(189)=PARU(187)
5270 PARU(190)=0D0
5271 PARU(195)=COS(BESU-ALSU)
5272 ENDIF
5273
5274C...Reset effective widths of gauge bosons.
5275 DO 110 I=1,500
5276 DO 100 J=1,5
5277 WIDS(I,J)=1D0
5278 100 CONTINUE
5279 110 CONTINUE
5280
5281C...Order resonances by increasing mass (except Z0 and W+/-).
5282 NRES=0
5283 DO 140 KC=1,500
5284 KF=KCHG(KC,4)
5285 IF(KF.EQ.0) GOTO 140
5286 IF(MWID(KC).EQ.0) GOTO 140
5287 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5288 IF(MSTP(1).LE.3) GOTO 140
5289 ENDIF
5290 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5291 IF(IMSS(1).LE.0) GOTO 140
5292 ENDIF
5293 NRES=NRES+1
5294 PMRES=PMAS(KC,1)
5295 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5296 DO 120 I1=NRES-1,1,-1
5297 IF(PMRES.GE.PMORD(I1)) GOTO 130
5298 KCORD(I1+1)=KCORD(I1)
5299 PMORD(I1+1)=PMORD(I1)
5300 120 CONTINUE
5301 130 KCORD(I1+1)=KC
5302 PMORD(I1+1)=PMRES
5303 140 CONTINUE
5304
5305C...Loop over possible resonances.
5306 DO 180 I=1,NRES
5307 KC=KCORD(I)
5308 KF=KCHG(KC,4)
5309
5310C...Check that no fourth generation channels on by mistake.
5311 IF(MSTP(1).LE.3) THEN
5312 DO 150 J=1,MDCY(KC,3)
5313 IDC=J+MDCY(KC,2)-1
5314 KFA1=IABS(KFDP(IDC,1))
5315 KFA2=IABS(KFDP(IDC,2))
5316 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5317 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5318 & MDME(IDC,1)=-1
5319 150 CONTINUE
5320 ENDIF
5321
5322C...Check that no supersymmetric channels on by mistake.
5323 IF(IMSS(1).LE.0) THEN
5324 DO 160 J=1,MDCY(KC,3)
5325 IDC=J+MDCY(KC,2)-1
5326 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5327 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5328 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5329 & MDME(IDC,1)=-1
5330 160 CONTINUE
5331 ENDIF
5332
5333C...Find mass and evaluate width.
5334 PMR=PMAS(KC,1)
5335 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5336 IF(MWID(KC).EQ.3) MINT(63)=1
5337 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5338 MINT(51)=0
5339
5340C...Evaluate suppression factors due to non-simulated channels.
5341 IF(KCHG(KC,3).EQ.0) THEN
5342 WDTP0I=0D0
5343 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5344 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5345 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5346 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5347 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5348 WIDS(KC,3)=0D0
5349 WIDS(KC,4)=0D0
5350 WIDS(KC,5)=0D0
5351 ELSE
5352 IF(MWID(KC).EQ.3) MINT(63)=1
5353 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5354 MINT(51)=0
5355 WDTP0I=0D0
5356 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5357 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5358 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5359 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5360 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5361 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5362 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5363 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5364 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5365 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5366 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5367 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5368 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5369 ENDIF
5370
5371C...Set resonance widths and branching ratios;
5372C...also on/off switch for decays.
5373 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5374 PMAS(KC,2)=WDTP(0)
5375 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5376 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5377 DO 170 J=1,MDCY(KC,3)
5378 IDC=J+MDCY(KC,2)-1
5379 BRAT(IDC)=0D0
5380 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5381 170 CONTINUE
5382 ENDIF
5383 180 CONTINUE
5384
5385C...Flavours of leptoquark: redefine charge and name.
5386 KFLQQ=KFDP(MDCY(42,2),1)
5387 KFLQL=KFDP(MDCY(42,2),2)
5388 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5389 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5390 LL=1
5391 IF(IABS(KFLQL).EQ.13) LL=2
5392 IF(IABS(KFLQL).EQ.15) LL=3
5393 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5394 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5395 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5396
5397C...Special cases in treatment of gamma*/Z0: redefine process name.
5398 IF(MSTP(43).EQ.1) THEN
5399 PROC(1)='f + fbar -> gamma*'
5400 PROC(15)='f + fbar -> g + gamma*'
5401 PROC(19)='f + fbar -> gamma + gamma*'
5402 PROC(30)='f + g -> f + gamma*'
5403 PROC(35)='f + gamma -> f + gamma*'
5404 ELSEIF(MSTP(43).EQ.2) THEN
5405 PROC(1)='f + fbar -> Z0'
5406 PROC(15)='f + fbar -> g + Z0'
5407 PROC(19)='f + fbar -> gamma + Z0'
5408 PROC(30)='f + g -> f + Z0'
5409 PROC(35)='f + gamma -> f + Z0'
5410 ELSEIF(MSTP(43).EQ.3) THEN
5411 PROC(1)='f + fbar -> gamma*/Z0'
5412 PROC(15)='f + fbar -> g + gamma*/Z0'
5413 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5414 PROC(30)='f + g -> f + gamma*/Z0'
5415 PROC(35)='f + gamma -> f + gamma*/Z0'
5416 ENDIF
5417
5418C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5419 IF(MSTP(44).EQ.1) THEN
5420 PROC(141)='f + fbar -> gamma*'
5421 ELSEIF(MSTP(44).EQ.2) THEN
5422 PROC(141)='f + fbar -> Z0'
5423 ELSEIF(MSTP(44).EQ.3) THEN
5424 PROC(141)='f + fbar -> Z''0'
5425 ELSEIF(MSTP(44).EQ.4) THEN
5426 PROC(141)='f + fbar -> gamma*/Z0'
5427 ELSEIF(MSTP(44).EQ.5) THEN
5428 PROC(141)='f + fbar -> gamma*/Z''0'
5429 ELSEIF(MSTP(44).EQ.6) THEN
5430 PROC(141)='f + fbar -> Z0/Z''0'
5431 ELSEIF(MSTP(44).EQ.7) THEN
5432 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5433 ENDIF
5434
5435C...Special cases in treatment of WW -> WW: redefine process name.
5436 IF(MSTP(45).EQ.1) THEN
5437 PROC(77)='W+ + W+ -> W+ + W+'
5438 ELSEIF(MSTP(45).EQ.2) THEN
5439 PROC(77)='W+ + W- -> W+ + W-'
5440 ELSEIF(MSTP(45).EQ.3) THEN
5441 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5442 ENDIF
5443
5444C...Format for error information.
5445 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5446 &'combination'/1X,'Execution stopped!')
5447
5448 RETURN
5449 END
5450
5451C*********************************************************************
5452
5453C...PYINBM
5454C...Identifies the two incoming particles and the choice of frame.
5455
5456 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5457
5458C...Double precision and integer declarations.
5459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5460 IMPLICIT INTEGER(I-N)
5461 INTEGER PYK,PYCHGE,PYCOMP
5462
5463C...User process initialization commonblock.
5464 INTEGER MAXPUP
5465 PARAMETER (MAXPUP=100)
5466 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5467 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5468 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5469 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5470 &LPRUP(MAXPUP)
5471 SAVE /HEPRUP/
5472
5473C...Commonblocks.
5474 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5475 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5476 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5477 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5478 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5479 COMMON/PYINT1/MINT(400),VINT(400)
5480 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5481
5482C...Local arrays, character variables and data.
5483 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5484 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5485 DIMENSION LEN(3),KCDE(39),PM(2)
5486 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5487 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5488 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5489 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5490 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5491 &'nu_taubar ','pi+ ','pi- ','n0 ',
5492 &'nbar0 ','p+ ','pbar- ','gamma ',
5493 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5494 &'xi- ','xi0 ','omega- ','pi0 ',
5495 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5496 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5497 &'k+ ','k- ','ks0 ','kl0 '/
5498 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5499 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5500 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5501
5502C...Store initial energy. Default frame.
5503 VINT(290)=WIN
5504 MINT(111)=0
5505
5506C...Special user process initialization; convert to normal input.
5507 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5508 MINT(111)=11
5509 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5510 CALL PYNAME(IDBMUP(1),CHNAME)
5511 CHBEAM=CHNAME(1:12)
5512 CALL PYNAME(IDBMUP(2),CHNAME)
5513 CHTARG=CHNAME(1:12)
5514 ENDIF
5515
5516C...Convert character variables to lowercase and find their length.
5517 CHCOM(1)=CHFRAM
5518 CHCOM(2)=CHBEAM
5519 CHCOM(3)=CHTARG
5520 DO 130 I=1,3
5521 LEN(I)=12
5522 DO 110 LL=12,1,-1
5523 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5524 DO 100 LA=1,26
5525 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5526 & CHALP(1)(LA:LA)
5527 100 CONTINUE
5528 110 CONTINUE
5529 CHIDNT(I)=CHCOM(I)
5530
5531C...Fix up bar, underscore and charge in particle name (if needed).
5532 DO 120 LL=1,10
5533 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5534 CHTEMP=CHIDNT(I)
5535 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5536 ENDIF
5537 120 CONTINUE
5538 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5539 CHTEMP=CHIDNT(I)
5540 CHIDNT(I)='nu_'//CHTEMP(3:7)
5541 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5542 CHIDNT(I)(1:3)='n0 '
5543 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5544 CHIDNT(I)(1:5)='nbar0'
5545 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5546 CHIDNT(I)(1:3)='p+ '
5547 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5548 & CHIDNT(I)(1:2).EQ.'p-') THEN
5549 CHIDNT(I)(1:5)='pbar-'
5550 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5551 CHIDNT(I)(7:7)='0'
5552 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5553 CHIDNT(I)(1:7)='reggeon'
5554 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5555 CHIDNT(I)(1:7)='pomeron'
5556 ENDIF
5557 130 CONTINUE
5558
5559C...Identify free initialization.
5560 IF(CHCOM(1)(1:2).EQ.'no') THEN
5561 MINT(65)=1
5562 RETURN
5563 ENDIF
5564
5565C...Identify incoming beam and target particles.
5566 DO 160 I=1,2
5567 DO 140 J=1,39
5568 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5569 140 CONTINUE
5570 PM(I)=PYMASS(MINT(10+I))
5571 VINT(2+I)=PM(I)
5572 MINT(140+I)=0
5573 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5574 CHTEMP=CHIDNT(I+1)(7:12)//' '
5575 DO 150 J=1,12
5576 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5577 150 CONTINUE
5578 PM(I)=PYMASS(MINT(140+I))
5579 VINT(302+I)=PM(I)
5580 ENDIF
5581 160 CONTINUE
5582 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5583 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5584 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5585
5586C...Identify choice of frame and input energies.
5587 CHINIT=' '
5588
5589C...Events defined in the CM frame.
5590 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5591 MINT(111)=1
5592 S=WIN**2
5593 IF(MSTP(122).GE.1) THEN
5594 IF(CHCOM(2)(1:1).NE.'e') THEN
5595 LOFFS=(31-(LEN(2)+LEN(3)))/2
5596 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5597 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5598 & ' collider'//' '
5599 ELSE
5600 LOFFS=(30-(LEN(2)+LEN(3)))/2
5601 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5602 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5603 & ' collider'//' '
5604 ENDIF
5605 WRITE(MSTU(11),5200) CHINIT
5606 WRITE(MSTU(11),5300) WIN
5607 ENDIF
5608
5609C...Events defined in fixed target frame.
5610 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5611 MINT(111)=2
5612 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5613 IF(MSTP(122).GE.1) THEN
5614 LOFFS=(29-(LEN(2)+LEN(3)))/2
5615 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5616 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5617 & ' fixed target'//' '
5618 WRITE(MSTU(11),5200) CHINIT
5619 WRITE(MSTU(11),5400) WIN
5620 WRITE(MSTU(11),5500) SQRT(S)
5621 ENDIF
5622
5623C...Frame defined by user three-vectors.
5624 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5625 MINT(111)=3
5626 P(1,5)=PM(1)
5627 P(2,5)=PM(2)
5628 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5629 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5630 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5631 & (P(1,3)+P(2,3))**2
5632 IF(MSTP(122).GE.1) THEN
5633 LOFFS=(22-(LEN(2)+LEN(3)))/2
5634 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5635 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5636 & ' user configuration'//' '
5637 WRITE(MSTU(11),5200) CHINIT
5638 WRITE(MSTU(11),5600)
5639 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5640 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5641 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5642 ENDIF
5643
5644C...Frame defined by user four-vectors.
5645 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5646 MINT(111)=4
5647 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5648 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5649 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5650 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5651 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5652 & (P(1,3)+P(2,3))**2
5653 IF(MSTP(122).GE.1) THEN
5654 LOFFS=(22-(LEN(2)+LEN(3)))/2
5655 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5656 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5657 & ' user configuration'//' '
5658 WRITE(MSTU(11),5200) CHINIT
5659 WRITE(MSTU(11),5600)
5660 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5661 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5662 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5663 ENDIF
5664
5665C...Frame defined by user five-vectors.
5666 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5667 MINT(111)=5
5668 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5669 & (P(1,3)+P(2,3))**2
5670 IF(MSTP(122).GE.1) THEN
5671 LOFFS=(22-(LEN(2)+LEN(3)))/2
5672 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5673 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5674 & ' user configuration'//' '
5675 WRITE(MSTU(11),5200) CHINIT
5676 WRITE(MSTU(11),5600)
5677 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5678 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5679 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5680 ENDIF
5681
5682C...Frame defined by HEPRUP common block.
5683 ELSEIF(MINT(111).GE.11) THEN
5684 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5685 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5686 IF(MSTP(122).GE.1) THEN
5687 LOFFS=(22-(LEN(2)+LEN(3)))/2
5688 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5689 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5690 & ' user configuration'//' '
5691 WRITE(MSTU(11),5200) CHINIT
5692 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5693 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5694 ENDIF
5695
5696C...Unknown frame. Error for too low CM energy.
5697 ELSE
5698 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5699 CALL PYSTOP(7)
5700 ENDIF
5701 IF(S.LT.PARP(2)**2) THEN
5702 WRITE(MSTU(11),5900) SQRT(S)
5703 CALL PYSTOP(7)
5704 ENDIF
5705
5706C...Formats for initialization and error information.
5707 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5708 &1X,'Execution stopped!')
5709 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5710 &1X,'Execution stopped!')
5711 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5712 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5713 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5714 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5715 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5716 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5717 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5718 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5719 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5720 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5721 &1X,'Execution stopped!')
5722 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5723 &'generation.'/1X,'Execution stopped!')
5724 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5725 &'GeV beam energies',13X,'I')
5726
5727 RETURN
5728 END
5729
5730C*********************************************************************
5731
5732C...PYINKI
5733C...Sets up kinematics, including rotations and boosts to/from CM frame.
5734
5735 SUBROUTINE PYINKI(MODKI)
5736
5737C...Double precision and integer declarations.
5738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5739 IMPLICIT INTEGER(I-N)
5740 INTEGER PYK,PYCHGE,PYCOMP
5741
5742C...User process initialization commonblock.
5743 INTEGER MAXPUP
5744 PARAMETER (MAXPUP=100)
5745 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5746 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5747 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5748 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5749 &LPRUP(MAXPUP)
5750 SAVE /HEPRUP/
5751
5752C...Commonblocks.
5753 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5755 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5756 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5757 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5758 COMMON/PYINT1/MINT(400),VINT(400)
5759 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5760
5761C...Set initial flavour state.
5762 N=2
5763 DO 100 I=1,2
5764 K(I,1)=1
5765 K(I,2)=MINT(10+I)
5766 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5767 100 CONTINUE
5768
5769C...Reset boost. Do kinematics for various cases.
5770 DO 110 J=6,10
5771 VINT(J)=0D0
5772 110 CONTINUE
5773
5774C...Set up kinematics for events defined in CM frame.
5775 IF(MINT(111).EQ.1) THEN
5776 WIN=VINT(290)
5777 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5778 S=WIN**2
5779 P(1,5)=VINT(3)
5780 P(2,5)=VINT(4)
5781 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5782 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5783 P(1,1)=0D0
5784 P(1,2)=0D0
5785 P(2,1)=0D0
5786 P(2,2)=0D0
5787 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5788 & (4D0*S))
5789 P(2,3)=-P(1,3)
5790 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5791 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5792
5793C...Set up kinematics for fixed target events.
5794 ELSEIF(MINT(111).EQ.2) THEN
5795 WIN=VINT(290)
5796 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5797 P(1,5)=VINT(3)
5798 P(2,5)=VINT(4)
5799 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5800 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5801 P(1,1)=0D0
5802 P(1,2)=0D0
5803 P(2,1)=0D0
5804 P(2,2)=0D0
5805 P(1,3)=WIN
5806 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5807 P(2,3)=0D0
5808 P(2,4)=P(2,5)
5809 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5810 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5811 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5812
5813C...Set up kinematics for events in user-defined frame.
5814 ELSEIF(MINT(111).EQ.3) THEN
5815 P(1,5)=VINT(3)
5816 P(2,5)=VINT(4)
5817 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5818 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5819 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5820 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5821 DO 120 J=1,3
5822 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5823 120 CONTINUE
5824 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5825 VINT(7)=PYANGL(P(1,1),P(1,2))
5826 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5827 VINT(6)=PYANGL(P(1,3),P(1,1))
5828 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5829 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5830
5831C...Set up kinematics for events with user-defined four-vectors.
5832 ELSEIF(MINT(111).EQ.4) THEN
5833 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5834 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5835 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5836 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5837 DO 130 J=1,3
5838 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5839 130 CONTINUE
5840 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5841 VINT(7)=PYANGL(P(1,1),P(1,2))
5842 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5843 VINT(6)=PYANGL(P(1,3),P(1,1))
5844 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5845 S=(P(1,4)+P(2,4))**2
5846
5847C...Set up kinematics for events with user-defined five-vectors.
5848 ELSEIF(MINT(111).EQ.5) THEN
5849 DO 140 J=1,3
5850 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5851 140 CONTINUE
5852 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5853 VINT(7)=PYANGL(P(1,1),P(1,2))
5854 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5855 VINT(6)=PYANGL(P(1,3),P(1,1))
5856 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5857 S=(P(1,4)+P(2,4))**2
5858
5859C...Set up kinematics for events with external user processes.
5860 ELSEIF(MINT(111).GE.11) THEN
5861 P(1,5)=VINT(3)
5862 P(2,5)=VINT(4)
5863 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5864 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5865 P(1,1)=0D0
5866 P(1,2)=0D0
5867 P(2,1)=0D0
5868 P(2,2)=0D0
5869 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5870 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5871 P(1,4)=EBMUP(1)
5872 P(2,4)=EBMUP(2)
5873 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5874 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5875 S=(P(1,4)+P(2,4))**2
5876 ENDIF
5877
5878C...Return or error for too low CM energy.
5879 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5880 IF(MSTP(172).LE.1) THEN
5881 CALL PYERRM(23,
5882 & '(PYINKI:) too low invariant mass in this event')
5883 ELSE
5884 MSTI(61)=1
5885 RETURN
5886 ENDIF
5887 ENDIF
5888
5889C...Save information on incoming particles.
5890 VINT(1)=SQRT(S)
5891 VINT(2)=S
5892 IF(MINT(111).GE.4) THEN
5893 IF(MINT(141).EQ.0) THEN
5894 VINT(3)=P(1,5)
5895 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5896 ELSE
5897 VINT(303)=P(1,5)
5898 ENDIF
5899 IF(MINT(142).EQ.0) THEN
5900 VINT(4)=P(2,5)
5901 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5902 ELSE
5903 VINT(304)=P(2,5)
5904 ENDIF
5905 ENDIF
5906 VINT(5)=P(1,3)
5907 IF(MODKI.EQ.0) VINT(289)=S
5908 DO 150 J=1,5
5909 V(1,J)=0D0
5910 V(2,J)=0D0
5911 VINT(290+J)=P(1,J)
5912 VINT(295+J)=P(2,J)
5913 150 CONTINUE
5914
5915C...Store pT cut-off and related constants to be used in generation.
5916 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5917 IF(MSTP(82).LE.1) THEN
5918 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5919 ELSE
5920 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5921 ENDIF
5922 VINT(149)=4D0*PTMN**2/S
5923 VINT(154)=PTMN
5924
5925 RETURN
5926 END
5927
5928C*********************************************************************
5929
5930C...PYINPR
5931C...Selects partonic subprocesses to be included in the simulation.
5932
5933 SUBROUTINE PYINPR
5934
5935C...Double precision and integer declarations.
5936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5937 IMPLICIT INTEGER(I-N)
5938 INTEGER PYK,PYCHGE,PYCOMP
5939
5940C...User process initialization commonblock.
5941 INTEGER MAXPUP
5942 PARAMETER (MAXPUP=100)
5943 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5944 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5945 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5946 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5947 &LPRUP(MAXPUP)
5948 SAVE /HEPRUP/
5949
5950C...Commonblocks and character variables.
5951 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5952 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5953 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5954 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5955 COMMON/PYINT1/MINT(400),VINT(400)
5956 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5957 COMMON/PYINT6/PROC(0:500)
5958 CHARACTER PROC*28
5959 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5960 &/PYINT6/
5961 CHARACTER CHIPR*10
5962
5963C...Reset processes to be included.
5964 IF(MSEL.NE.0) THEN
5965 DO 100 I=1,500
5966 MSUB(I)=0
5967 100 CONTINUE
5968 ENDIF
5969
5970C...Set running pTmin scale.
5971 IF(MSTP(82).LE.1) THEN
5972 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5973 ELSE
5974 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5975 ENDIF
5976
5977C...Begin by assuming incoming photon to enter subprocess.
5978 IF(MINT(11).EQ.22) MINT(15)=22
5979 IF(MINT(12).EQ.22) MINT(16)=22
5980
5981C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5982 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5983 MSUB(10)=1
5984 MINT(123)=MINT(122)+1
5985
5986C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5987C...allow mixture.
5988C...Here also set a few parameters otherwise normally not touched.
5989 ELSEIF(MINT(121).GT.1) THEN
5990
5991C...Parton distributions dampened at small Q2; go to low energies,
5992C...alpha_s <1; no minimum pT cut-off a priori.
5993 IF(MSTP(18).EQ.2) THEN
5994 MSTP(57)=3
5995 PARP(2)=2D0
5996 PARU(115)=1D0
5997 CKIN(5)=0.2D0
5998 CKIN(6)=0.2D0
5999 ENDIF
6000
6001C...Define pT cut-off parameters and whether run involves low-pT.
6002 PTMVMD=PTMRUN
6003 VINT(154)=PTMVMD
6004 PTMDIR=PTMVMD
6005 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6006 PTMANO=PTMVMD
6007 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6008 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6009 IPTL=1
6010 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6011 IF(MSEL.EQ.2) IPTL=1
6012
6013C...Set up for p/gamma * gamma; real or virtual photons.
6014 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6015 & MSTP(14).EQ.30)) THEN
6016
6017C...Set up for p/VMD * VMD.
6018 IF(MINT(122).EQ.1) THEN
6019 MINT(123)=2
6020 MSUB(11)=1
6021 MSUB(12)=1
6022 MSUB(13)=1
6023 MSUB(28)=1
6024 MSUB(53)=1
6025 MSUB(68)=1
6026 IF(IPTL.EQ.1) MSUB(95)=1
6027 IF(MSEL.EQ.2) THEN
6028 MSUB(91)=1
6029 MSUB(92)=1
6030 MSUB(93)=1
6031 MSUB(94)=1
6032 ENDIF
6033 IF(IPTL.EQ.1) CKIN(3)=0D0
6034
6035C...Set up for p/VMD * direct gamma.
6036 ELSEIF(MINT(122).EQ.2) THEN
6037 MINT(123)=0
6038 IF(MINT(121).EQ.6) MINT(123)=5
6039 MSUB(131)=1
6040 MSUB(132)=1
6041 MSUB(135)=1
6042 MSUB(136)=1
6043 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6044
6045C...Set up for p/VMD * anomalous gamma.
6046 ELSEIF(MINT(122).EQ.3) THEN
6047 MINT(123)=3
6048 IF(MINT(121).EQ.6) MINT(123)=7
6049 MSUB(11)=1
6050 MSUB(12)=1
6051 MSUB(13)=1
6052 MSUB(28)=1
6053 MSUB(53)=1
6054 MSUB(68)=1
6055 IF(IPTL.EQ.1) MSUB(95)=1
6056 IF(MSEL.EQ.2) THEN
6057 MSUB(91)=1
6058 MSUB(92)=1
6059 MSUB(93)=1
6060 MSUB(94)=1
6061 ENDIF
6062 IF(IPTL.EQ.1) CKIN(3)=0D0
6063
6064C...Set up for DIS * p.
6065 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6066 & IABS(MINT(12)).GT.100)) THEN
6067 MINT(123)=8
6068 IF(IPTL.EQ.1) MSUB(99)=1
6069
6070C...Set up for direct * direct gamma (switch off leptons).
6071 ELSEIF(MINT(122).EQ.4) THEN
6072 MINT(123)=0
6073 MSUB(137)=1
6074 MSUB(138)=1
6075 MSUB(139)=1
6076 MSUB(140)=1
6077 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6078 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6079 110 CONTINUE
6080 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6081
6082C...Set up for direct * anomalous gamma.
6083 ELSEIF(MINT(122).EQ.5) THEN
6084 MINT(123)=6
6085 MSUB(131)=1
6086 MSUB(132)=1
6087 MSUB(135)=1
6088 MSUB(136)=1
6089 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6090
6091C...Set up for anomalous * anomalous gamma.
6092 ELSEIF(MINT(122).EQ.6) THEN
6093 MINT(123)=3
6094 MSUB(11)=1
6095 MSUB(12)=1
6096 MSUB(13)=1
6097 MSUB(28)=1
6098 MSUB(53)=1
6099 MSUB(68)=1
6100 IF(IPTL.EQ.1) MSUB(95)=1
6101 IF(MSEL.EQ.2) THEN
6102 MSUB(91)=1
6103 MSUB(92)=1
6104 MSUB(93)=1
6105 MSUB(94)=1
6106 ENDIF
6107 IF(IPTL.EQ.1) CKIN(3)=0D0
6108 ENDIF
6109
6110C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6111 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6112
6113C...Set up for direct * direct gamma (switch off leptons).
6114 IF(MINT(122).EQ.1) THEN
6115 MINT(123)=0
6116 MSUB(137)=1
6117 MSUB(138)=1
6118 MSUB(139)=1
6119 MSUB(140)=1
6120 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6121 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6122 120 CONTINUE
6123 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6124
6125C...Set up for direct * VMD and VMD * direct gamma.
6126 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6127 MINT(123)=5
6128 MSUB(131)=1
6129 MSUB(132)=1
6130 MSUB(135)=1
6131 MSUB(136)=1
6132 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6133
6134C...Set up for direct * anomalous and anomalous * direct gamma.
6135 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6136 MINT(123)=6
6137 MSUB(131)=1
6138 MSUB(132)=1
6139 MSUB(135)=1
6140 MSUB(136)=1
6141 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6142
6143C...Set up for VMD*VMD.
6144 ELSEIF(MINT(122).EQ.5) THEN
6145 MINT(123)=2
6146 MSUB(11)=1
6147 MSUB(12)=1
6148 MSUB(13)=1
6149 MSUB(28)=1
6150 MSUB(53)=1
6151 MSUB(68)=1
6152 IF(IPTL.EQ.1) MSUB(95)=1
6153 IF(MSEL.EQ.2) THEN
6154 MSUB(91)=1
6155 MSUB(92)=1
6156 MSUB(93)=1
6157 MSUB(94)=1
6158 ENDIF
6159 IF(IPTL.EQ.1) CKIN(3)=0D0
6160
6161C...Set up for VMD * anomalous and anomalous * VMD gamma.
6162 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6163 MINT(123)=7
6164 MSUB(11)=1
6165 MSUB(12)=1
6166 MSUB(13)=1
6167 MSUB(28)=1
6168 MSUB(53)=1
6169 MSUB(68)=1
6170 IF(IPTL.EQ.1) MSUB(95)=1
6171 IF(MSEL.EQ.2) THEN
6172 MSUB(91)=1
6173 MSUB(92)=1
6174 MSUB(93)=1
6175 MSUB(94)=1
6176 ENDIF
6177 IF(IPTL.EQ.1) CKIN(3)=0D0
6178
6179C...Set up for anomalous * anomalous gamma.
6180 ELSEIF(MINT(122).EQ.9) THEN
6181 MINT(123)=3
6182 MSUB(11)=1
6183 MSUB(12)=1
6184 MSUB(13)=1
6185 MSUB(28)=1
6186 MSUB(53)=1
6187 MSUB(68)=1
6188 IF(IPTL.EQ.1) MSUB(95)=1
6189 IF(MSEL.EQ.2) THEN
6190 MSUB(91)=1
6191 MSUB(92)=1
6192 MSUB(93)=1
6193 MSUB(94)=1
6194 ENDIF
6195 IF(IPTL.EQ.1) CKIN(3)=0D0
6196
6197C...Set up for DIS * VMD and VMD * DIS gamma.
6198 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6199 MINT(123)=8
6200 IF(IPTL.EQ.1) MSUB(99)=1
6201
6202C...Set up for DIS * anomalous and anomalous * DIS gamma.
6203 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6204 MINT(123)=9
6205 IF(IPTL.EQ.1) MSUB(99)=1
6206 ENDIF
6207
6208C...Set up for gamma* * p; virtual photons = dir, res.
6209 ELSEIF(MINT(121).EQ.2) THEN
6210
6211C...Set up for direct * p.
6212 IF(MINT(122).EQ.1) THEN
6213 MINT(123)=0
6214 MSUB(131)=1
6215 MSUB(132)=1
6216 MSUB(135)=1
6217 MSUB(136)=1
6218 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6219
6220C...Set up for resolved * p.
6221 ELSEIF(MINT(122).EQ.2) THEN
6222 MINT(123)=1
6223 MSUB(11)=1
6224 MSUB(12)=1
6225 MSUB(13)=1
6226 MSUB(28)=1
6227 MSUB(53)=1
6228 MSUB(68)=1
6229 IF(IPTL.EQ.1) MSUB(95)=1
6230 IF(MSEL.EQ.2) THEN
6231 MSUB(91)=1
6232 MSUB(92)=1
6233 MSUB(93)=1
6234 MSUB(94)=1
6235 ENDIF
6236 IF(IPTL.EQ.1) CKIN(3)=0D0
6237 ENDIF
6238
6239C...Set up for gamma* * gamma*; virtual photons = dir, res.
6240 ELSEIF(MINT(121).EQ.4) THEN
6241
6242C...Set up for direct * direct gamma (switch off leptons).
6243 IF(MINT(122).EQ.1) THEN
6244 MINT(123)=0
6245 MSUB(137)=1
6246 MSUB(138)=1
6247 MSUB(139)=1
6248 MSUB(140)=1
6249 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6250 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6251 130 CONTINUE
6252 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6253
6254C...Set up for direct * resolved and resolved * direct gamma.
6255 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6256 MINT(123)=5
6257 MSUB(131)=1
6258 MSUB(132)=1
6259 MSUB(135)=1
6260 MSUB(136)=1
6261 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6262
6263C...Set up for resolved * resolved gamma.
6264 ELSEIF(MINT(122).EQ.4) THEN
6265 MINT(123)=2
6266 MSUB(11)=1
6267 MSUB(12)=1
6268 MSUB(13)=1
6269 MSUB(28)=1
6270 MSUB(53)=1
6271 MSUB(68)=1
6272 IF(IPTL.EQ.1) MSUB(95)=1
6273 IF(MSEL.EQ.2) THEN
6274 MSUB(91)=1
6275 MSUB(92)=1
6276 MSUB(93)=1
6277 MSUB(94)=1
6278 ENDIF
6279 IF(IPTL.EQ.1) CKIN(3)=0D0
6280 ENDIF
6281
6282C...End of special set up for gamma-p and gamma-gamma.
6283 ENDIF
6284 CKIN(1)=2D0*CKIN(3)
6285 ENDIF
6286
6287C...Flavour information for individual beams.
6288 DO 140 I=1,2
6289 MINT(40+I)=1
6290 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6291 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6292 MINT(44+I)=MINT(40+I)
6293 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6294 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6295 140 CONTINUE
6296
6297C...If two real gammas, whereof one direct, pick the first.
6298C...For two virtual photons, keep requested order.
6299 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6300 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6301 MINT(41)=1
6302 MINT(45)=1
6303 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6304 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6305 MINT(41)=1
6306 MINT(45)=1
6307 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6308 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6309 MINT(42)=1
6310 MINT(46)=1
6311 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6312 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6313 MINT(41)=1
6314 MINT(45)=1
6315 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6316 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6317 MINT(42)=1
6318 MINT(46)=1
6319 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6320 MINT(41)=1
6321 MINT(45)=1
6322 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6323 MINT(42)=1
6324 MINT(46)=1
6325 ENDIF
6326 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6327 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6328 IF(MINT(11).EQ.22) THEN
6329 MINT(41)=1
6330 MINT(45)=1
6331 ELSE
6332 MINT(42)=1
6333 MINT(46)=1
6334 ENDIF
6335 ENDIF
6336 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6337 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6338 ENDIF
6339
6340C...Flavour information on combination of incoming particles.
6341 MINT(43)=2*MINT(41)+MINT(42)-2
6342 MINT(44)=MINT(43)
6343 IF(MINT(123).LE.0) THEN
6344 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6345 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6346 ELSEIF(MINT(123).LE.3) THEN
6347 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6348 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6349 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6350 MINT(43)=4
6351 MINT(44)=1
6352 ENDIF
6353 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6354 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6355 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6356 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6357 MINT(50)=0
6358 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6359 MINT(107)=0
6360 MINT(108)=0
6361 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6362 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6363 & MINT(107)=2
6364 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6365 & MINT(107)=3
6366 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6367 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6368 & MINT(122).EQ.10) MINT(108)=2
6369 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6370 & MINT(122).EQ.11) MINT(108)=3
6371 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6372 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6373 IF(MINT(122).GE.3) MINT(107)=1
6374 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6375 ELSEIF(MINT(121).EQ.2) THEN
6376 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6377 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6378 ELSE
6379 IF(MINT(11).EQ.22) THEN
6380 MINT(107)=MINT(123)
6381 IF(MINT(123).GE.4) MINT(107)=0
6382 IF(MINT(123).EQ.7) MINT(107)=2
6383 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6384 IF(MSTP(14).EQ.28) MINT(107)=2
6385 IF(MSTP(14).EQ.29) MINT(107)=3
6386 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6387 & MINT(107)=4
6388 ENDIF
6389 IF(MINT(12).EQ.22) THEN
6390 MINT(108)=MINT(123)
6391 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6392 IF(MINT(123).EQ.7) MINT(108)=3
6393 IF(MSTP(14).EQ.26) MINT(108)=2
6394 IF(MSTP(14).EQ.27) MINT(108)=3
6395 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6396 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6397 & MINT(108)=4
6398 ENDIF
6399 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6400 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6401 MINTTP=MINT(107)
6402 MINT(107)=MINT(108)
6403 MINT(108)=MINTTP
6404 ENDIF
6405 ENDIF
6406 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6407 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6408
6409C...Select default processes according to incoming beams
6410C...(already done for gamma-p and gamma-gamma with
6411C...MSTP(14) = 10, 20, 25 or 30).
6412 IF(MINT(121).GT.1) THEN
6413 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6414
6415 IF(MINT(43).EQ.1) THEN
6416C...Lepton + lepton -> gamma/Z0 or W.
6417 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6418 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6419
6420 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6421 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6422C...Unresolved photon + lepton: Compton scattering.
6423 MSUB(133)=1
6424 MSUB(134)=1
6425
6426 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6427 & .OR.MINT(12).EQ.22)) THEN
6428C...DIS as pure gamma* + f -> f process.
6429 MSUB(99)=1
6430
6431 ELSEIF(MINT(43).LE.3) THEN
6432C...Lepton + hadron: deep inelastic scattering.
6433 MSUB(10)=1
6434
6435 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6436 & MINT(12).EQ.22) THEN
6437C...Two unresolved photons: fermion pair production,
6438C...exclude lepton pairs.
6439 DO 150 ISUB=137,140
6440 MSUB(ISUB)=1
6441 150 CONTINUE
6442 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6443 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6444 160 CONTINUE
6445 PTMDIR=PTMRUN
6446 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6447 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6448 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6449
6450 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6451 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6452 & MINT(12).EQ.22)) THEN
6453C...Unresolved photon + hadron: photon-parton scattering.
6454 DO 170 ISUB=131,136
6455 MSUB(ISUB)=1
6456 170 CONTINUE
6457
6458 ELSEIF(MSEL.EQ.1) THEN
6459C...High-pT QCD processes:
6460 MSUB(11)=1
6461 MSUB(12)=1
6462 MSUB(13)=1
6463 MSUB(28)=1
6464 MSUB(53)=1
6465 MSUB(68)=1
6466 PTMN=PTMRUN
6467 VINT(154)=PTMN
6468 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6469 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6470
6471 ELSE
6472C...All QCD processes:
6473 MSUB(11)=1
6474 MSUB(12)=1
6475 MSUB(13)=1
6476 MSUB(28)=1
6477 MSUB(53)=1
6478 MSUB(68)=1
6479 MSUB(91)=1
6480 MSUB(92)=1
6481 MSUB(93)=1
6482 MSUB(94)=1
6483 MSUB(95)=1
6484 ENDIF
6485
6486 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6487C...Heavy quark production.
6488 MSUB(81)=1
6489 MSUB(82)=1
6490 MSUB(84)=1
6491 DO 180 J=1,MIN(8,MDCY(21,3))
6492 MDME(MDCY(21,2)+J-1,1)=0
6493 180 CONTINUE
6494 MDME(MDCY(21,2)+MSEL-1,1)=1
6495 MSUB(85)=1
6496 DO 190 J=1,MIN(12,MDCY(22,3))
6497 MDME(MDCY(22,2)+J-1,1)=0
6498 190 CONTINUE
6499 MDME(MDCY(22,2)+MSEL-1,1)=1
6500
6501 ELSEIF(MSEL.EQ.10) THEN
6502C...Prompt photon production:
6503 MSUB(14)=1
6504 MSUB(18)=1
6505 MSUB(29)=1
6506
6507 ELSEIF(MSEL.EQ.11) THEN
6508C...Z0/gamma* production:
6509 MSUB(1)=1
6510
6511 ELSEIF(MSEL.EQ.12) THEN
6512C...W+/- production:
6513 MSUB(2)=1
6514
6515 ELSEIF(MSEL.EQ.13) THEN
6516C...Z0 + jet:
6517 MSUB(15)=1
6518 MSUB(30)=1
6519
6520 ELSEIF(MSEL.EQ.14) THEN
6521C...W+/- + jet:
6522 MSUB(16)=1
6523 MSUB(31)=1
6524
6525 ELSEIF(MSEL.EQ.15) THEN
6526C...Z0 & W+/- pair production:
6527 MSUB(19)=1
6528 MSUB(20)=1
6529 MSUB(22)=1
6530 MSUB(23)=1
6531 MSUB(25)=1
6532
6533 ELSEIF(MSEL.EQ.16) THEN
6534C...h0 production:
6535 MSUB(3)=1
6536 MSUB(102)=1
6537 MSUB(103)=1
6538 MSUB(123)=1
6539 MSUB(124)=1
6540
6541 ELSEIF(MSEL.EQ.17) THEN
6542C...h0 & Z0 or W+/- pair production:
6543 MSUB(24)=1
6544 MSUB(26)=1
6545
6546 ELSEIF(MSEL.EQ.18) THEN
6547C...h0 production; interesting processes in e+e-.
6548 MSUB(24)=1
6549 MSUB(103)=1
6550 MSUB(123)=1
6551 MSUB(124)=1
6552
6553 ELSEIF(MSEL.EQ.19) THEN
6554C...h0, H0 and A0 production; interesting processes in e+e-.
6555 MSUB(24)=1
6556 MSUB(103)=1
6557 MSUB(123)=1
6558 MSUB(124)=1
6559 MSUB(153)=1
6560 MSUB(171)=1
6561 MSUB(173)=1
6562 MSUB(174)=1
6563 MSUB(158)=1
6564 MSUB(176)=1
6565 MSUB(178)=1
6566 MSUB(179)=1
6567
6568 ELSEIF(MSEL.EQ.21) THEN
6569C...Z'0 production:
6570 MSUB(141)=1
6571
6572 ELSEIF(MSEL.EQ.22) THEN
6573C...W'+/- production:
6574 MSUB(142)=1
6575
6576 ELSEIF(MSEL.EQ.23) THEN
6577C...H+/- production:
6578 MSUB(143)=1
6579
6580 ELSEIF(MSEL.EQ.24) THEN
6581C...R production:
6582 MSUB(144)=1
6583
6584 ELSEIF(MSEL.EQ.25) THEN
6585C...LQ (leptoquark) production.
6586 MSUB(145)=1
6587 MSUB(162)=1
6588 MSUB(163)=1
6589 MSUB(164)=1
6590
6591 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6592C...Production of one heavy quark (W exchange):
6593 MSUB(83)=1
6594 DO 200 J=1,MIN(8,MDCY(21,3))
6595 MDME(MDCY(21,2)+J-1,1)=0
6596 200 CONTINUE
6597 MDME(MDCY(21,2)+MSEL-31,1)=1
6598
6599CMRENNA++Define SUSY alternatives.
6600 ELSEIF(MSEL.EQ.39) THEN
6601C...Turn on all SUSY processes.
6602 IF(MINT(43).EQ.4) THEN
6603C...Hadron-hadron processes.
6604 DO 210 I=201,301
6605 IF(ISET(I).GE.0) MSUB(I)=1
6606 210 CONTINUE
6607 ELSEIF(MINT(43).EQ.1) THEN
6608C...Lepton-lepton processes: QED production of squarks.
6609 DO 220 I=201,214
6610 MSUB(I)=1
6611 220 CONTINUE
6612 MSUB(210)=0
6613 MSUB(211)=0
6614 MSUB(212)=0
6615 DO 230 I=216,228
6616 MSUB(I)=1
6617 230 CONTINUE
6618 DO 240 I=261,263
6619 MSUB(I)=1
6620 240 CONTINUE
6621 MSUB(277)=1
6622 MSUB(278)=1
6623 ENDIF
6624
6625 ELSEIF(MSEL.EQ.40) THEN
6626C...Gluinos and squarks.
6627 IF(MINT(43).EQ.4) THEN
6628 MSUB(243)=1
6629 MSUB(244)=1
6630 MSUB(258)=1
6631 MSUB(259)=1
6632 MSUB(261)=1
6633 MSUB(262)=1
6634 MSUB(264)=1
6635 MSUB(265)=1
6636 DO 250 I=271,296
6637 MSUB(I)=1
6638 250 CONTINUE
6639 ELSEIF(MINT(43).EQ.1) THEN
6640 MSUB(277)=1
6641 MSUB(278)=1
6642 ENDIF
6643
6644 ELSEIF(MSEL.EQ.41) THEN
6645C...Stop production.
6646 MSUB(261)=1
6647 MSUB(262)=1
6648 MSUB(263)=1
6649 IF(MINT(43).EQ.4) THEN
6650 MSUB(264)=1
6651 MSUB(265)=1
6652 ENDIF
6653
6654 ELSEIF(MSEL.EQ.42) THEN
6655C...Slepton production.
6656 DO 260 I=201,214
6657 MSUB(I)=1
6658 260 CONTINUE
6659 IF(MINT(43).NE.4) THEN
6660 MSUB(210)=0
6661 MSUB(211)=0
6662 MSUB(212)=0
6663 ENDIF
6664
6665 ELSEIF(MSEL.EQ.43) THEN
6666C...Neutralino/Chargino + Gluino/Squark.
6667 IF(MINT(43).EQ.4) THEN
6668 DO 270 I=237,242
6669 MSUB(I)=1
6670 270 CONTINUE
6671 DO 280 I=246,254
6672 MSUB(I)=1
6673 280 CONTINUE
6674 MSUB(256)=1
6675 ENDIF
6676
6677 ELSEIF(MSEL.EQ.44) THEN
6678C...Neutralino/Chargino pair production.
6679 IF(MINT(43).EQ.4) THEN
6680 DO 290 I=216,236
6681 MSUB(I)=1
6682 290 CONTINUE
6683 ELSEIF(MINT(43).EQ.1) THEN
6684 DO 300 I=216,228
6685 MSUB(I)=1
6686 300 CONTINUE
6687 ENDIF
6688
6689 ELSEIF(MSEL.EQ.45) THEN
6690C...Sbottom production.
6691 MSUB(287)=1
6692 MSUB(288)=1
6693 IF(MINT(43).EQ.4) THEN
6694 DO 310 I=281,296
6695 MSUB(I)=1
6696 310 CONTINUE
6697 ENDIF
6698
6699 ELSEIF(MSEL.EQ.50) THEN
6700C...Pair production of technipions and gauge bosons.
6701 DO 320 I=361,368
6702 MSUB(I)=1
6703 320 CONTINUE
6704 IF(MINT(43).EQ.4) THEN
6705 DO 330 I=370,377
6706 MSUB(I)=1
6707 330 CONTINUE
6708 ENDIF
6709
6710 ELSEIF(MSEL.EQ.51) THEN
6711C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6712 DO 340 I=381,386
6713 MSUB(I)=1
6714 340 CONTINUE
6715
6716 ELSEIF(MSEL.EQ.61) THEN
6717C...Charmonium production in colour octet model, with recoiling parton.
6718 DO 342 I=421,439
6719 MSUB(I)=1
6720 342 CONTINUE
6721
6722 ELSEIF(MSEL.EQ.62) THEN
6723C...Bottomonium production in colour octet model, with recoiling parton.
6724 DO 344 I=461,479
6725 MSUB(I)=1
6726 344 CONTINUE
6727
6728 ELSEIF(MSEL.EQ.63) THEN
6729C...Charmonium and bottomonium production in colour octet model.
6730 DO 346 I=421,439
6731 MSUB(I)=1
6732 MSUB(I+40)=1
6733 346 CONTINUE
6734 ENDIF
6735
6736C...Find heaviest new quark flavour allowed in processes 81-84.
6737 KFLQM=1
6738 DO 350 I=1,MIN(8,MDCY(21,3))
6739 IDC=I+MDCY(21,2)-1
6740 IF(MDME(IDC,1).LE.0) GOTO 350
6741 KFLQM=I
6742 350 CONTINUE
6743 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6744 &KFLQM=MSTP(7)
6745 MINT(55)=KFLQM
6746 KFPR(81,1)=KFLQM
6747 KFPR(81,2)=KFLQM
6748 KFPR(82,1)=KFLQM
6749 KFPR(82,2)=KFLQM
6750 KFPR(83,1)=KFLQM
6751 KFPR(84,1)=KFLQM
6752 KFPR(84,2)=KFLQM
6753
6754C...Find heaviest new fermion flavour allowed in process 85.
6755 KFLFM=1
6756 DO 360 I=1,MIN(12,MDCY(22,3))
6757 IDC=I+MDCY(22,2)-1
6758 IF(MDME(IDC,1).LE.0) GOTO 360
6759 KFLFM=KFDP(IDC,1)
6760 360 CONTINUE
6761 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6762 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6763 MINT(56)=KFLFM
6764 KFPR(85,1)=KFLFM
6765 KFPR(85,2)=KFLFM
6766
6767C...Import relevant information on external user processes.
6768 IF(MINT(111).GE.11) THEN
6769 IPYPR=0
6770 DO 390 IUP=1,NPRUP
6771C...Find next empty PYTHIA process number slot and enable it.
6772 370 IPYPR=IPYPR+1
6773 IF(IPYPR.GT.500) CALL PYERRM(26,
6774 & '(PYINPR.) no more empty slots for user processes')
6775 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6776 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6777 ISET(IPYPR)=11
6778C...Overwrite KFPR with references back to process number and ID.
6779 KFPR(IPYPR,1)=IUP
6780 KFPR(IPYPR,2)=LPRUP(IUP)
6781C...Process title.
6782 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6783 ICHIN=1
6784 DO 380 ICH=1,9
6785 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6786 380 CONTINUE
6787 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6788C...Switch on process.
6789 MSUB(IPYPR)=1
6790 390 CONTINUE
6791 ENDIF
6792
6793 RETURN
6794 END
6795
6796C*********************************************************************
6797
6798C...PYXTOT
6799C...Parametrizes total, elastic and diffractive cross-sections
6800C...for different energies and beams. Donnachie-Landshoff for
6801C...total and Schuler-Sjostrand for elastic and diffractive.
6802C...Process code IPROC:
6803C...= 1 : p + p;
6804C...= 2 : pbar + p;
6805C...= 3 : pi+ + p;
6806C...= 4 : pi- + p;
6807C...= 5 : pi0 + p;
6808C...= 6 : phi + p;
6809C...= 7 : J/psi + p;
6810C...= 11 : rho + rho;
6811C...= 12 : rho + phi;
6812C...= 13 : rho + J/psi;
6813C...= 14 : phi + phi;
6814C...= 15 : phi + J/psi;
6815C...= 16 : J/psi + J/psi;
6816C...= 21 : gamma + p (DL);
6817C...= 22 : gamma + p (VDM).
6818C...= 23 : gamma + pi (DL);
6819C...= 24 : gamma + pi (VDM);
6820C...= 25 : gamma + gamma (DL);
6821C...= 26 : gamma + gamma (VDM).
6822
6823 SUBROUTINE PYXTOT
6824
6825C...Double precision and integer declarations.
6826 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6827 IMPLICIT INTEGER(I-N)
6828 INTEGER PYK,PYCHGE,PYCOMP
6829C...Commonblocks.
6830 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6831 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6832 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6833 COMMON/PYINT1/MINT(400),VINT(400)
6834 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6835 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6836 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6837C...Local arrays.
6838 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6839 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6840 &CEFFD(10,9),SIGTMP(6,0:5)
6841
6842C...Common constants.
6843 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6844 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6845 &FACDD/0.0084D0/
6846
6847C...Number of multiple processes to be evaluated (= 0 : undefined).
6848 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6849C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6850 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6851 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6852 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6853 DATA YPAR/
6854 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6855 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6856 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6857
6858C...Beam and target hadron class:
6859C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6860 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6861 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6862C...Characteristic class masses, slope parameters, beta = sqrt(X).
6863 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6864 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6865 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6866
6867C...Fitting constants used in parametrizations of diffractive results.
6868 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6869 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6870 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6871 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6872 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6873 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6874 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6875 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6876 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6877 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6878 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6879 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6880 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6881 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6882 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6883 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6884 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6885 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6886 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6887 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6888 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6889 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6890 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6891 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6892 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6893 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6894 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6895 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6896 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6897
6898C...Parameters. Combinations of the energy.
6899 AEM=PARU(101)
6900 PMTH=PARP(102)
6901 S=VINT(2)
6902 SRT=VINT(1)
6903 SEPS=S**EPS
6904 SETA=S**ETA
6905 SLOG=LOG(S)
6906
6907C...Ratio of gamma/pi (for rescaling in parton distributions).
6908 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6909 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6910 VINT(317)=1D0
6911 IF(MINT(50).NE.1) RETURN
6912
6913C...Order flavours of incoming particles: KF1 < KF2.
6914 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6915 KF1=IABS(MINT(11))
6916 KF2=IABS(MINT(12))
6917 IORD=1
6918 ELSE
6919 KF1=IABS(MINT(12))
6920 KF2=IABS(MINT(11))
6921 IORD=2
6922 ENDIF
6923 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6924
6925C...Find process number (for lookup tables).
6926 IF(KF1.GT.1000) THEN
6927 IPROC=1
6928 IF(ISGN12.LT.0) IPROC=2
6929 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6930 IPROC=3
6931 IF(ISGN12.LT.0) IPROC=4
6932 IF(KF1.EQ.111) IPROC=5
6933 ELSEIF(KF1.GT.100) THEN
6934 IPROC=11
6935 ELSEIF(KF2.GT.1000) THEN
6936 IPROC=21
6937 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6938 ELSEIF(KF2.GT.100) THEN
6939 IPROC=23
6940 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6941 ELSE
6942 IPROC=25
6943 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6944 ENDIF
6945
6946C... Number of multiple processes to be stored; beam/target side.
6947 NPR=NPROC(IPROC)
6948 MINT(101)=1
6949 MINT(102)=1
6950 IF(NPR.EQ.3) THEN
6951 MINT(100+IORD)=4
6952 ELSEIF(NPR.EQ.6) THEN
6953 MINT(101)=4
6954 MINT(102)=4
6955 ENDIF
6956 N1=0
6957 IF(MINT(101).EQ.4) N1=4
6958 N2=0
6959 IF(MINT(102).EQ.4) N2=4
6960
6961C...Do not do any more for user-set or undefined cross-sections.
6962 IF(MSTP(31).LE.0) RETURN
6963 IF(NPR.EQ.0) CALL PYERRM(26,
6964 &'(PYXTOT:) cross section for this process not yet implemented')
6965
6966C...Parameters. Combinations of the energy.
6967 AEM=PARU(101)
6968 PMTH=PARP(102)
6969 S=VINT(2)
6970 SRT=VINT(1)
6971 SEPS=S**EPS
6972 SETA=S**ETA
6973 SLOG=LOG(S)
6974
6975C...Loop over multiple processes (for VDM).
6976 DO 110 I=1,NPR
6977 IF(NPR.EQ.1) THEN
6978 IPR=IPROC
6979 ELSEIF(NPR.EQ.3) THEN
6980 IPR=I+4
6981 IF(KF2.LT.1000) IPR=I+10
6982 ELSEIF(NPR.EQ.6) THEN
6983 IPR=I+10
6984 ENDIF
6985
6986C...Evaluate hadron species, mass, slope contribution and fit number.
6987 IHA=IHADA(IPR)
6988 IHB=IHADB(IPR)
6989 PMA=PMHAD(IHA)
6990 PMB=PMHAD(IHB)
6991 BHA=BHAD(IHA)
6992 BHB=BHAD(IHB)
6993 ISD=IFITSD(IPR)
6994 IDD=IFITDD(IPR)
6995
6996C...Skip if energy too low relative to masses.
6997 DO 100 J=0,5
6998 SIGTMP(I,J)=0D0
6999 100 CONTINUE
7000 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7001
7002C...Total cross-section. Elastic slope parameter and cross-section.
7003 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7004 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7005 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7006
7007C...Diffractive scattering A + B -> X + B.
7008 BSD=2D0*BHB
7009 SQML=(PMA+PMTH)**2
7010 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7011 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7012 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7013 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7014 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7015 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7016 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7017
7018C...Diffractive scattering A + B -> A + X.
7019 BSD=2D0*BHA
7020 SQML=(PMB+PMTH)**2
7021 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7022 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7023 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7024 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7025 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7026 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7027 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7028
7029C...Order single diffractive correctly.
7030 IF(IORD.EQ.2) THEN
7031 SIGSAV=SIGTMP(I,2)
7032 SIGTMP(I,2)=SIGTMP(I,3)
7033 SIGTMP(I,3)=SIGSAV
7034 ENDIF
7035
7036C...Double diffractive scattering A + B -> X1 + X2.
7037 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7038 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7039 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7040 IF(YEFF.LE.0) SUM1=0D0
7041 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7042 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7043 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7044 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7045 & (2D0*ALP)
7046 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7047 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7048 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7049 & (2D0*ALP)
7050 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7051 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7052 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7053 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7054 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7055
7056C...Non-diffractive by unitarity.
7057 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7058 & SIGTMP(I,4)
7059 110 CONTINUE
7060
7061C...Put temporary results in output array: only one process.
7062 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7063 DO 120 J=0,5
7064 SIGT(0,0,J)=SIGTMP(1,J)
7065 120 CONTINUE
7066
7067C...Beam multiple processes.
7068 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7069 IF(MINT(107).EQ.2) THEN
7070 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7071 ELSE
7072 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7073 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7074 ENDIF
7075 IF(MSTP(20).GT.0) THEN
7076 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7077 ENDIF
7078 DO 140 I=1,4
7079 IF(MINT(107).EQ.2) THEN
7080 CONV=(AEM/PARP(160+I))*VINT(317)
7081 ELSEIF(VINT(154).GT.PARP(15)) THEN
7082 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7083 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7084 ELSE
7085 CONV=0D0
7086 ENDIF
7087 I1=MAX(1,I-1)
7088 DO 130 J=0,5
7089 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7090 130 CONTINUE
7091 140 CONTINUE
7092 DO 150 J=0,5
7093 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7094 150 CONTINUE
7095
7096C...Target multiple processes.
7097 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7098 IF(MINT(108).EQ.2) THEN
7099 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7100 ELSE
7101 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7102 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7103 ENDIF
7104 IF(MSTP(20).GT.0) THEN
7105 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7106 ENDIF
7107 DO 170 I=1,4
7108 IF(MINT(108).EQ.2) THEN
7109 CONV=(AEM/PARP(160+I))*VINT(317)
7110 ELSEIF(VINT(154).GT.PARP(15)) THEN
7111 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7112 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7113 ELSE
7114 CONV=0D0
7115 ENDIF
7116 IV=MAX(1,I-1)
7117 DO 160 J=0,5
7118 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7119 160 CONTINUE
7120 170 CONTINUE
7121 DO 180 J=0,5
7122 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7123 180 CONTINUE
7124
7125C...Both beam and target multiple processes.
7126 ELSE
7127 IF(MINT(107).EQ.2) THEN
7128 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7129 ELSE
7130 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7131 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7132 ENDIF
7133 IF(MINT(108).EQ.2) THEN
7134 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7135 ELSE
7136 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7137 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7138 ENDIF
7139 IF(MSTP(20).GT.0) THEN
7140 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7141 & VINT(308)))**MSTP(20)
7142 ENDIF
7143 DO 210 I1=1,4
7144 DO 200 I2=1,4
7145 IF(MINT(107).EQ.2) THEN
7146 CONV=(AEM/PARP(160+I1))*VINT(317)
7147 ELSEIF(VINT(154).GT.PARP(15)) THEN
7148 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7149 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7150 ELSE
7151 CONV=0D0
7152 ENDIF
7153 IF(MINT(108).EQ.2) THEN
7154 CONV=CONV*(AEM/PARP(160+I2))
7155 ELSEIF(VINT(154).GT.PARP(15)) THEN
7156 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7157 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7158 ELSE
7159 CONV=0D0
7160 ENDIF
7161 IF(I1.LE.2) THEN
7162 IV=MAX(1,I2-1)
7163 ELSEIF(I2.LE.2) THEN
7164 IV=MAX(1,I1-1)
7165 ELSEIF(I1.EQ.I2) THEN
7166 IV=2*I1-2
7167 ELSE
7168 IV=5
7169 ENDIF
7170 DO 190 J=0,5
7171 JV=J
7172 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7173 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7174 190 CONTINUE
7175 200 CONTINUE
7176 210 CONTINUE
7177 DO 230 J=0,5
7178 DO 220 I=1,4
7179 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7180 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7181 220 CONTINUE
7182 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7183 230 CONTINUE
7184 ENDIF
7185
7186C...Scale up uniformly for Donnachie-Landshoff parametrization.
7187 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7188 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7189 DO 260 I1=0,N1
7190 DO 250 I2=0,N2
7191 DO 240 J=0,5
7192 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7193 240 CONTINUE
7194 250 CONTINUE
7195 260 CONTINUE
7196 ENDIF
7197
7198 RETURN
7199 END
7200
7201C*********************************************************************
7202
7203C...PYMAXI
7204C...Finds optimal set of coefficients for kinematical variable selection
7205C...and the maximum of the part of the differential cross-section used
7206C...in the event weighting.
7207
7208 SUBROUTINE PYMAXI
7209
7210C...Double precision and integer declarations.
7211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7212 IMPLICIT INTEGER(I-N)
7213 INTEGER PYK,PYCHGE,PYCOMP
7214C...Parameter statement to help give large particle numbers.
7215 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7216 &KEXCIT=4000000,KDIMEN=5000000)
7217
7218C...User process initialization commonblock.
7219 INTEGER MAXPUP
7220 PARAMETER (MAXPUP=100)
7221 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7222 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7223 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7224 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7225 &LPRUP(MAXPUP)
7226 SAVE /HEPRUP/
7227
7228C...Commonblocks.
7229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7231 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7232 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7233 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7234 COMMON/PYINT1/MINT(400),VINT(400)
7235 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7236 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7237 COMMON/PYINT4/MWID(500),WIDS(500,5)
7238 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7239 COMMON/PYINT6/PROC(0:500)
7240 CHARACTER PROC*28
7241 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7242 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7243 COMMON/PYTCCO/COEFX(194:380,2)
7244 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7245 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7246 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7247 &/PYTCSM/,/TCPARA/
7248C...Local arrays, character variables and data.
7249 LOGICAL IOK
7250 CHARACTER CVAR(4)*4
7251 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7252 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7253 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7254 &IQ(9),IP(9)
7255 DATA CVAR/'tau ','tau''','y* ','cth '/
7256 DATA SIGSSM/3*0D0/
7257
7258C...Initial values and loop over subprocesses.
7259 NPOSI=0
7260 VINT(143)=1D0
7261 VINT(144)=1D0
7262 XSEC(0,1)=0D0
7263 ITECH=0
7264 DO 460 ISUB=1,500
7265 MINT(1)=ISUB
7266 MINT(51)=0
7267
7268C...Find maximum weight factors for photon flux.
7269 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7270 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7271 ENDIF
7272
7273C...Select subprocess to study: skip cases not applicable.
7274 IF(ISET(ISUB).EQ.11) THEN
7275 IF(MSUB(ISUB).NE.1) GOTO 460
7276C...User process intialization: cross section model dependent.
7277 IF(IABS(IDWTUP).EQ.1) THEN
7278 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7279 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7280 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7281 ELSE
7282 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7283 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7284 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7285 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7286 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7287 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7288 ENDIF
7289 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7290 & WTGAGA*XSEC(ISUB,1)
7291 NPOSI=NPOSI+1
7292 GOTO 450
7293 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7294 CALL PYSIGH(NCHN,SIGS)
7295 XSEC(ISUB,1)=SIGS
7296 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7297 & WTGAGA*XSEC(ISUB,1)
7298 IF(MSUB(ISUB).NE.1) GOTO 460
7299 NPOSI=NPOSI+1
7300 GOTO 450
7301 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7302 CALL PYSIGH(NCHN,SIGS)
7303 XSEC(ISUB,1)=SIGS
7304 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7305 & WTGAGA*XSEC(ISUB,1)
7306 IF(XSEC(ISUB,1).EQ.0D0) THEN
7307 MSUB(ISUB)=0
7308 ELSE
7309 NPOSI=NPOSI+1
7310 ENDIF
7311 GOTO 450
7312 ELSEIF(ISUB.EQ.96) THEN
7313 IF(MINT(50).EQ.0) GOTO 460
7314 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7315 & GOTO 460
7316 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7317 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7318 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7319 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7320 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7321 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7322 ELSE
7323 IF(MSUB(ISUB).NE.1) GOTO 460
7324 ENDIF
7325 ISTSB=ISET(ISUB)
7326 IF(ISUB.EQ.96) ISTSB=2
7327 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7328 MWTXS=0
7329 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7330 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7331
7332C...Find resonances (explicit or implicit in cross-section).
7333 MINT(72)=0
7334 KFR1=0
7335 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7336 KFR1=KFPR(ISUB,1)
7337 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7338 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7339 KFR1=23
7340 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7341 & .OR.ISUB.EQ.177) THEN
7342 KFR1=24
7343 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7344 KFR1=25
7345 IF(MSTP(46).EQ.5) THEN
7346 KFR1=89
7347 PMAS(89,1)=PARP(45)
7348 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7349 ENDIF
7350 ENDIF
7351 CKMX=CKIN(2)
7352 IF(CKMX.LE.0D0) CKMX=VINT(1)
7353 KCR1=PYCOMP(KFR1)
7354 IF(KFR1.NE.0) THEN
7355 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7356 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7357 ENDIF
7358 IF(KFR1.NE.0) THEN
7359 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7360 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7361 MINT(72)=1
7362 MINT(73)=KFR1
7363 VINT(73)=TAUR1
7364 VINT(74)=GAMR1
7365 ENDIF
7366 KFR2=0
7367 KFR3=0
7368 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7369 $ (ISUB.GE.361.AND.ISUB.LE.380))
7370 $ THEN
7371 KFR2=23
7372 IF(ISUB.EQ.141) THEN
7373 KCR2=PYCOMP(KFR2)
7374 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7375 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7376 KFR2=0
7377 ELSE
7378 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7379 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7380 MINT(72)=2
7381 MINT(74)=KFR2
7382 VINT(75)=TAUR2
7383 VINT(76)=GAMR2
7384 ENDIF
7385 ELSEIF(ITECH.EQ.0) THEN
7386 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7387 ITECH=1
7388 KFR1=KTECHN+113
7389 KCR1=PYCOMP(KFR1)
7390 KFR2=KTECHN+223
7391 KCR2=PYCOMP(KFR2)
7392 KFR3=KTECHN+115
7393 KCR3=PYCOMP(KFR3)
7394 IRES=0
7395C...Order the resonances
7396 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7397 KCT=KCR3
7398 KCR3=KCR2
7399 KCR2=KCT
7400 ENDIF
7401 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7402 KCT=KCR3
7403 KCR3=KCR1
7404 KCR1=KCT
7405 ENDIF
7406 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7407 KCT=KCR2
7408 KCR2=KCR1
7409 KCR1=KCT
7410 ENDIF
7411 DO 101 I=1,3
7412 IF(I.EQ.1) THEN
7413 SHN0=PMAS(KCR1,1)**2
7414 ELSEIF(I.EQ.2) THEN
7415 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7416 SHN0=PMAS(KCR2,1)**2
7417 ELSEIF(I.EQ.3) THEN
7418 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7419 SHN0=PMAS(KCR3,1)**2
7420 ENDIF
7421 AEM=PYALEM(SHN0)
7422 FAR=SQRT(AEM/ALPRHT)
7423 SHN=SHN0*(1D0-FAR)
7424 CALL PYTECM(SHN,S1,WIDO,1)
7425 RES=SHN-S1
7426 SHN=S1*.99D0
7427 SHSTEP=2D0
7428 102 SHN=SHN+SHSTEP
7429 CALL PYTECM(SHN,S1,WIDO,1)
7430 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7431 IOK=.FALSE.
7432 IF(IRES.GT.0) THEN
7433 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7434 ELSEIF(IRES.EQ.0) THEN
7435 IOK=.TRUE.
7436 ENDIF
7437 IF(IOK) THEN
7438 IRES=IRES+1
7439 XMAS(IRES)=SQRT(S1)
7440 XWID(IRES)=WIDO
7441 ENDIF
7442 ENDIF
7443 RES=SHN-S1
7444 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7445 101 CONTINUE
7446 JRES=0
7447 KFR1=KTECHN+213
7448 KCR1=PYCOMP(KFR1)
7449 KFR2=KTECHN+215
7450 KCR2=PYCOMP(KFR2)
7451 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7452 KCT=KCR2
7453 KCR2=KCR1
7454 KCR1=KCT
7455 ENDIF
7456 DO 103 I=1,2
7457 IF(I.EQ.1) THEN
7458 SHN0=PMAS(KCR1,1)**2
7459 ELSEIF(I.EQ.2) THEN
7460 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7461 SHN0=PMAS(KCR2,1)**2
7462 ENDIF
7463 AEM=PYALEM(SHN0)
7464 FAR=SQRT(AEM/ALPRHT)
7465 SHN=SHN0*(1D0-FAR)
7466 CALL PYTECM(SHN,S1,WIDO,2)
7467 RES=SHN-S1
7468 SHN=S1*.99D0
7469 SHSTEP=2D0
7470 104 SHN=SHN+SHSTEP
7471 CALL PYTECM(SHN,S1,WIDO,2)
7472 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7473 IOK=.FALSE.
7474 IF(JRES.GT.0) THEN
7475 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7476 ELSEIF(JRES.EQ.0) THEN
7477 IOK=.TRUE.
7478 ENDIF
7479 IF(IOK) THEN
7480 JRES=JRES+1
7481 YMAS(JRES)=SQRT(S1)
7482 YWID(JRES)=WIDO
7483 ENDIF
7484 ENDIF
7485 RES=SHN-S1
7486 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7487 103 CONTINUE
7488 ENDIF
7489 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7490 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7491 MINT(72)=IRES
7492 IF(IRES.GE.1) THEN
7493 VINT(73)=XMAS(1)**2/VINT(2)
7494 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7495 TAUR1=VINT(73)
7496 GAMR1=VINT(74)
7497 XM1=XMAS(1)
7498 XG1=XWID(1)
7499 KFR1=1
7500 ENDIF
7501 IF(IRES.GE.2) THEN
7502 VINT(75)=XMAS(2)**2/VINT(2)
7503 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7504 TAUR2=VINT(75)
7505 GAMR2=VINT(76)
7506 XM2=XMAS(2)
7507 XG2=XWID(2)
7508 KFR2=2
7509 ENDIF
7510 IF(IRES.EQ.3) THEN
7511 VINT(77)=XMAS(3)**2/VINT(2)
7512 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7513 TAUR3=VINT(77)
7514 GAMR3=VINT(78)
7515 XM3=XMAS(3)
7516 XG3=XWID(3)
7517 KFR3=3
7518 ENDIF
7519C...Charged current: rho+- and a+-
7520 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7521 MINT(72)=IRES
7522 IF(JRES.GE.1) THEN
7523 VINT(73)=YMAS(1)**2/VINT(2)
7524 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7525 KFR1=1
7526 TAUR1=VINT(73)
7527 GAMR1=VINT(74)
7528 XM1=YMAS(1)
7529 XG1=YWID(1)
7530 ENDIF
7531 IF(JRES.GE.2) THEN
7532 VINT(75)=YMAS(2)**2/VINT(2)
7533 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7534 KFR2=2
7535 TAUR2=VINT(73)
7536 GAMR2=VINT(74)
7537 XM2=YMAS(2)
7538 XG2=YWID(2)
7539 ENDIF
7540 KFR3=0
7541 ENDIF
7542 IF(ISUB.NE.141) THEN
7543 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7544 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7545 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7546 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7547 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7548 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7549 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7550
7551 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7552 MINT(72)=2
7553 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7554 MINT(72)=2
7555 MINT(74)=KFR3
7556 VINT(75)=TAUR3
7557 VINT(76)=GAMR3
7558 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7559 MINT(72)=2
7560 MINT(73)=KFR2
7561 VINT(73)=TAUR2
7562 VINT(74)=GAMR2
7563 MINT(74)=KFR3
7564 VINT(75)=TAUR3
7565 VINT(76)=GAMR3
7566 ELSEIF(KFR1.NE.0) THEN
7567 MINT(72)=1
7568 ELSEIF(KFR2.NE.0) THEN
7569 MINT(72)=1
7570 MINT(73)=KFR2
7571 VINT(73)=TAUR2
7572 VINT(74)=GAMR2
7573 ELSEIF(KFR3.NE.0) THEN
7574 MINT(72)=1
7575 MINT(73)=KFR3
7576 VINT(73)=TAUR3
7577 VINT(74)=GAMR3
7578 ELSE
7579 MINT(72)=0
7580 ENDIF
7581 ELSE
7582 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7583
7584 ELSEIF(KFR2.NE.0) THEN
7585 KFR1=KFR2
7586 TAUR1=TAUR2
7587 GAMR1=GAMR2
7588 MINT(72)=1
7589 MINT(73)=KFR1
7590 VINT(73)=TAUR1
7591 VINT(74)=GAMR1
7592 KFR2=0
7593 ELSE
7594 MINT(72)=0
7595 ENDIF
7596 ENDIF
7597 ENDIF
7598
7599C...Find product masses and minimum pT of process.
7600 SQM3=0D0
7601 SQM4=0D0
7602 MINT(71)=0
7603 VINT(71)=CKIN(3)
7604 VINT(80)=1D0
7605 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7606 NBW=0
7607 DO 110 I=1,2
7608 PMMN(I)=0D0
7609 IF(KFPR(ISUB,I).EQ.0) THEN
7610 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7611 & PARP(41)) THEN
7612 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7613 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7614 ELSE
7615 NBW=NBW+1
7616C...This prevents SUSY/t particles from becoming too light.
7617 KFLW=KFPR(ISUB,I)
7618 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7619 KCW=PYCOMP(KFLW)
7620 PMMN(I)=PMAS(KCW,1)
7621 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7622 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7623 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7624 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7625 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7626 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7627 PMMN(I)=MIN(PMMN(I),PMSUM)
7628 ENDIF
7629 100 CONTINUE
7630 ELSEIF(KFLW.EQ.6) THEN
7631 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7632 ENDIF
7633 ENDIF
7634 110 CONTINUE
7635 IF(NBW.GE.1) THEN
7636 CKIN41=CKIN(41)
7637 CKIN43=CKIN(43)
7638 CKIN(41)=MAX(PMMN(1),CKIN(41))
7639 CKIN(43)=MAX(PMMN(2),CKIN(43))
7640 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7641 CKIN(41)=CKIN41
7642 CKIN(43)=CKIN43
7643 IF(MINT(51).EQ.1) THEN
7644 WRITE(MSTU(11),5100) ISUB
7645 MSUB(ISUB)=0
7646 GOTO 460
7647 ENDIF
7648 SQM3=PQM3**2
7649 SQM4=PQM4**2
7650 ENDIF
7651 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7652 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7653 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7654 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7655 ELSEIF(ISUB.EQ.96) THEN
7656 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7657 ENDIF
7658 ENDIF
7659 VINT(63)=SQM3
7660 VINT(64)=SQM4
7661
7662C...Prepare for additional variable choices in 2 -> 3.
7663 IF(ISTSB.EQ.5) THEN
7664 VINT(201)=0D0
7665 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7666 VINT(206)=VINT(201)
7667 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7668 VINT(204)=PMAS(23,1)
7669 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7670 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7671 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7672 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7673 & VINT(204)=VINT(201)
7674 VINT(209)=VINT(204)
7675 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7676 ENDIF
7677
7678C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7679 IPEAK7=0
7680 NPTS(1)=2+2*MINT(72)
7681 IF(MINT(47).EQ.1) THEN
7682 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7683 ELSEIF(MINT(47).GE.5) THEN
7684 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7685 NPTS(1)=NPTS(1)+1
7686 IPEAK7=1
7687 ENDIF
7688 ENDIF
7689 NPTS(2)=1
7690 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7691 IF(MINT(47).GE.2) NPTS(2)=2
7692 IF(MINT(47).GE.5) NPTS(2)=3
7693 ENDIF
7694 NPTS(3)=1
7695 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7696 NPTS(3)=3
7697 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7698 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7699 ENDIF
7700 NPTS(4)=1
7701 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7702 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7703
7704C...Reset coefficients of cross-section weighting.
7705 DO 120 J=1,20
7706 COEF(ISUB,J)=0D0
7707 120 CONTINUE
7708 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7709 & .AND.ISUB.LE.380)) THEN
7710 DO 125 J=1,2
7711 COEFX(ISUB,J)=0D0
7712 125 CONTINUE
7713 ENDIF
7714 COEF(ISUB,1)=1D0
7715 COEF(ISUB,8)=0.5D0
7716 COEF(ISUB,9)=0.5D0
7717 COEF(ISUB,13)=1D0
7718 COEF(ISUB,18)=1D0
7719 MCTH=0
7720 MTAUP=0
7721 METAUP=0
7722 VINT(23)=0D0
7723 VINT(26)=0D0
7724 SIGSAM=0D0
7725
7726C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7727C...in grid of phase space points.
7728 CALL PYKLIM(1)
7729 METAU=MINT(51)
7730 NACC=0
7731 DO 150 ITRY=1,NTRY
7732 MINT(51)=0
7733 IF(METAU.EQ.1) GOTO 150
7734 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7735 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7736 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7737 MTAU=7
7738 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7739 MTAU=MTAU+1
7740 ENDIF
7741 RTAU=0.5D0
7742C...Special case when both resonances have same mass,
7743C...as is often the case in process 194.
7744c IF(MINT(72).GE.2) THEN
7745c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7746c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7747c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7748c RTAU=0.4D0
7749c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7750c RTAU=0.6D0
7751c ENDIF
7752c ENDIF
7753c ENDIF
7754 CALL PYKMAP(1,MTAU,RTAU)
7755 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7756 METAUP=MINT(51)
7757 ENDIF
7758 IF(METAUP.EQ.1) GOTO 150
7759 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7760 & .EQ.0) THEN
7761 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7762 CALL PYKMAP(4,MTAUP,0.5D0)
7763 ENDIF
7764 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7765 CALL PYKLIM(2)
7766 MEYST=MINT(51)
7767 ENDIF
7768 IF(MEYST.EQ.1) GOTO 150
7769 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7770 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7771 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7772 CALL PYKMAP(2,MYST,0.5D0)
7773 CALL PYKLIM(3)
7774 MECTH=MINT(51)
7775 ENDIF
7776 IF(MECTH.EQ.1) GOTO 150
7777 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7778 MCTH=1+MOD(ITRY-1,NPTS(4))
7779 CALL PYKMAP(3,MCTH,0.5D0)
7780 ENDIF
7781 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7782
7783C...Store position and limits.
7784 MINT(51)=0
7785 CALL PYKLIM(0)
7786 IF(MINT(51).EQ.1) GOTO 150
7787 NACC=NACC+1
7788 MVARPT(NACC,1)=MTAU
7789 MVARPT(NACC,2)=MTAUP
7790 MVARPT(NACC,3)=MYST
7791 MVARPT(NACC,4)=MCTH
7792 DO 130 J=1,30
7793 VINTPT(NACC,J)=VINT(10+J)
7794 130 CONTINUE
7795
7796C...Normal case: calculate cross-section.
7797 IF(ISTSB.NE.5) THEN
7798 CALL PYSIGH(NCHN,SIGS)
7799 IF(MWTXS.EQ.1) THEN
7800 CALL PYEVWT(WTXS)
7801 SIGS=WTXS*SIGS
7802 ENDIF
7803
7804C..2 -> 3: find highest value out of a number of tries.
7805 ELSE
7806 SIGS=0D0
7807 DO 140 IKIN3=1,MSTP(129)
7808 CALL PYKMAP(5,0,0D0)
7809 IF(MINT(51).EQ.1) GOTO 140
7810 CALL PYSIGH(NCHN,SIGTMP)
7811 IF(MWTXS.EQ.1) THEN
7812 CALL PYEVWT(WTXS)
7813 SIGTMP=WTXS*SIGTMP
7814 ENDIF
7815 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7816 140 CONTINUE
7817 ENDIF
7818
7819C...Store cross-section.
7820 SIGSPT(NACC)=SIGS
7821 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7822 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7823 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7824 150 CONTINUE
7825 IF(NACC.EQ.0) THEN
7826 WRITE(MSTU(11),5100) ISUB
7827 MSUB(ISUB)=0
7828 GOTO 460
7829 ELSEIF(SIGSAM.EQ.0D0) THEN
7830 WRITE(MSTU(11),5300) ISUB
7831 MSUB(ISUB)=0
7832 GOTO 460
7833 ENDIF
7834 IF(ISUB.NE.96) NPOSI=NPOSI+1
7835
7836C...Calculate integrals in tau over maximal phase space limits.
7837 TAUMIN=VINT(11)
7838 TAUMAX=VINT(31)
7839 ATAU1=LOG(TAUMAX/TAUMIN)
7840 IF(NPTS(1).GE.2) THEN
7841 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7842 ENDIF
7843 IF(NPTS(1).GE.4) THEN
7844 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7845 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7846 & GAMR1
7847 ENDIF
7848 IF(NPTS(1).GE.6) THEN
7849 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7850 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7851 & GAMR2
7852 ENDIF
7853 IF(NPTS(1).GE.8) THEN
7854 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7855 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7856 & GAMR3
7857 ENDIF
7858 IF(IPEAK7.EQ.1) THEN
7859 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7860 ENDIF
7861
7862C...Reset. Sum up cross-sections in points calculated.
7863 DO 320 IVAR=1,4
7864 IF(NPTS(IVAR).EQ.1) GOTO 320
7865 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7866 NBIN=NPTS(IVAR)
7867 DO 170 J1=1,NBIN
7868 NAREL(J1)=0
7869 WTREL(J1)=0D0
7870 COEFU(J1)=0D0
7871 DO 160 J2=1,NBIN
7872 WTMAT(J1,J2)=0D0
7873 160 CONTINUE
7874 170 CONTINUE
7875 DO 180 IACC=1,NACC
7876 IBIN=MVARPT(IACC,IVAR)
7877 IF(IVAR.EQ.1) THEN
7878 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7879 IBIN=IBIN-1
7880 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7881 IBIN=3+2*MINT(72)
7882 ENDIF
7883 ENDIF
7884 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7885 NAREL(IBIN)=NAREL(IBIN)+1
7886 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7887
7888C...Sum up tau cross-section pieces in points used.
7889 IF(IVAR.EQ.1) THEN
7890 TAU=VINTPT(IACC,11)
7891 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7892 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7893 IF(NBIN.GE.4) THEN
7894 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7895 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7896 & ((TAU-TAUR1)**2+GAMR1**2)
7897 ENDIF
7898 IF(NBIN.GE.6) THEN
7899 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7900 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7901 & ((TAU-TAUR2)**2+GAMR2**2)
7902 ENDIF
7903 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7904 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7905 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7906 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7907 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7908 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7909 ENDIF
7910 IF(MINT(72).EQ.3) THEN
7911 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7912 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7913 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7914 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7915 ENDIF
7916C...Sum up tau' cross-section pieces in points used.
7917 ELSEIF(IVAR.EQ.2) THEN
7918 TAU=VINTPT(IACC,11)
7919 TAUP=VINTPT(IACC,16)
7920 TAUPMN=VINTPT(IACC,6)
7921 TAUPMX=VINTPT(IACC,26)
7922 ATAUP1=LOG(TAUPMX/TAUPMN)
7923 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7924 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7925 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7926 & (1D0-TAU/TAUP)**3/TAUP
7927 IF(NBIN.GE.3) THEN
7928 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7929 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7930 & TAUP/MAX(2D-10,1D0-TAUP)
7931 ENDIF
7932
7933C...Sum up y* cross-section pieces in points used.
7934 ELSEIF(IVAR.EQ.3) THEN
7935 YST=VINTPT(IACC,12)
7936 YSTMIN=VINTPT(IACC,2)
7937 YSTMAX=VINTPT(IACC,22)
7938 AYST0=YSTMAX-YSTMIN
7939 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7940 AYST2=AYST1
7941 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7942 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7943 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7944 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7945 IF(MINT(45).EQ.3) THEN
7946 TAUE=VINTPT(IACC,11)
7947 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7948 YST0=-0.5D0*LOG(TAUE)
7949 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7950 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7951 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7952 & MAX(1D-10,1D0-EXP(YST-YST0))
7953 ENDIF
7954 IF(MINT(46).EQ.3) THEN
7955 TAUE=VINTPT(IACC,11)
7956 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7957 YST0=-0.5D0*LOG(TAUE)
7958 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7959 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7960 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7961 & MAX(1D-10,1D0-EXP(-YST-YST0))
7962 ENDIF
7963
7964C...Sum up cos(theta-hat) cross-section pieces in points used.
7965 ELSE
7966 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7967 RSQM=1D0+RM34
7968 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7969 CTHMIN=-CTHMAX
7970 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7971 & (TAUMAX*VINT(2)))
7972 ACTH1=CTHMAX-CTHMIN
7973 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7974 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7975 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7976 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7977 CTH=VINTPT(IACC,13)
7978 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7979 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7980 & MAX(RM34,RSQM-CTH)
7981 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7982 & MAX(RM34,RSQM+CTH)
7983 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7984 & MAX(RM34,RSQM-CTH)**2
7985 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7986 & MAX(RM34,RSQM+CTH)**2
7987 ENDIF
7988 180 CONTINUE
7989
7990C...Check that equation system solvable.
7991 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7992 MSOLV=1
7993 WTRELS=0D0
7994 DO 190 IBIN=1,NBIN
7995 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7996 & IRED=1,NBIN),WTREL(IBIN)
7997 IF(NAREL(IBIN).EQ.0) MSOLV=0
7998 WTRELS=WTRELS+WTREL(IBIN)
7999 190 CONTINUE
8000 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8001
8002C...Solve to find relative importance of cross-section pieces.
8003 IF(MSOLV.EQ.1) THEN
8004 DO 200 IBIN=1,NBIN
8005 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8006 WTRSAV(IBIN)=WTREL(IBIN)
8007 200 CONTINUE
8008C...Auxiliary vectors to record order of permutations
8009 DO I=1,NBIN
8010 IP(I) = I
8011 IQ(I) = I
8012 ENDDO
8013 DO 230 IRED=1,NBIN-1
8014 MROW=IRED
8015 RESMAX=ABS(WTREL(MROW))
8016C...Find row with largest residual
8017 DO JBIN=IRED+1,NBIN
8018 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8019 MROW=JBIN
8020 RESMAX=ABS(WTREL(MROW))
8021 ENDIF
8022 ENDDO
8023 IF(RESMAX.LT.1D-20) THEN
8024 MSOLV=0
8025 GOTO 260
8026 ENDIF
8027 MCOL = IRED
8028 AMAX = ABS(WTMAT(MROW,MCOL))
8029C...Find column with largest entry
8030 DO JBIN=IRED+1,NBIN
8031 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8032 MCOL = JBIN
8033 AMAX = ABS(WTMAT(MROW,MCOL))
8034 ENDIF
8035 ENDDO
8036C...Swap rows if necessary
8037 IF(MROW.NE.IRED) THEN
8038 DO JBIN=1,NBIN
8039 TMPE=WTMAT(IRED,JBIN)
8040 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8041 WTMAT(MROW,JBIN)=TMPE
8042 ENDDO
8043 TMPE=WTREL(IRED)
8044 WTREL(IRED)=WTREL(MROW)
8045 WTREL(MROW)=TMPE
8046 MTMP=IQ(IRED)
8047 IQ(IRED)=IQ(MROW)
8048 IQ(MROW)=MTMP
8049 ENDIF
8050C...Swap columns if necessary
8051 IF(MCOL.NE.IRED) THEN
8052 DO JBIN=1,NBIN
8053 TMPE=WTMAT(JBIN,IRED)
8054 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8055 WTMAT(JBIN,MCOL)=TMPE
8056 ENDDO
8057 MTMP=IP(IRED)
8058 IP(IRED)=IP(MCOL)
8059 IP(MCOL)=MTMP
8060 ENDIF
8061C...Begin eliminating equations
8062 DO 220 IBIN=IRED+1,NBIN
8063 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8064 MSOLV=0
8065 GOTO 260
8066 ENDIF
8067C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8068 RQTU=WTMAT(IBIN,IRED)
8069 RQTL=WTMAT(IRED,IRED)
8070C...Switch order of operations
8071 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8072 $ (WTREL(IRED)/RQTL)
8073 DO 210 ICOE=IRED,NBIN
8074 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8075 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8076 210 CONTINUE
8077 220 CONTINUE
8078 230 CONTINUE
8079 DO 250 IRED=NBIN,1,-1
8080 DO 240 ICOE=IRED+1,NBIN
8081 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8082 240 CONTINUE
8083 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8084 MSOLV=0
8085 GOTO 260
8086 ENDIF
8087 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8088 TEMPC(IRED)=COEFU(IRED)
8089 250 CONTINUE
8090C...Return to original order
8091 DO IBIN=1,NBIN
8092 MTMP=IP(IBIN)
8093 COEFU(MTMP)=TEMPC(IBIN)
8094 ENDDO
8095 ENDIF
8096
8097C...Share evenly if failure.
8098 260 IF(MSOLV.EQ.0) THEN
8099 DO 270 IBIN=1,NBIN
8100 COEFU(IBIN)=1D0
8101 WTRELN(IBIN)=0.1D0
8102 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8103 & WTRSAV(IBIN)/WTRELS)
8104 270 CONTINUE
8105 ENDIF
8106
8107C...Normalize coefficients, with piece shared democratically.
8108 COEFSU=0D0
8109 WTRELS=0D0
8110 DO 280 IBIN=1,NBIN
8111 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8112 COEFSU=COEFSU+COEFU(IBIN)
8113 WTRELS=WTRELS+WTRELN(IBIN)
8114 280 CONTINUE
8115 IF(COEFSU.GT.0D0) THEN
8116 DO 290 IBIN=1,NBIN
8117 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8118 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8119 290 CONTINUE
8120 ELSE
8121 DO 300 IBIN=1,NBIN
8122 COEFO(IBIN)=1D0/NBIN
8123 300 CONTINUE
8124 ENDIF
8125 IF(IVAR.EQ.1) IOFF=0
8126 IF(IVAR.EQ.2) IOFF=17
8127 IF(IVAR.EQ.3) IOFF=7
8128 IF(IVAR.EQ.4) IOFF=12
8129 DO 310 IBIN=1,NBIN
8130 ICOF=IOFF+IBIN
8131 IF(IVAR.EQ.1) THEN
8132 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8133 ICOF=7
8134 ENDIF
8135 ENDIF
8136 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8137 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8138 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8139 ELSE
8140 COEF(ISUB,ICOF)=COEFO(IBIN)
8141 ENDIF
8142 310 CONTINUE
8143
8144 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8145 & (COEFO(IBIN),IBIN=1,NBIN)
8146
8147 320 CONTINUE
8148
8149C...Find two most promising maxima among points previously determined.
8150 DO 330 J=1,4
8151 IACCMX(J)=0
8152 SIGSMX(J)=0D0
8153 330 CONTINUE
8154 NMAX=0
8155 DO 390 IACC=1,NACC
8156 DO 340 J=1,30
8157 VINT(10+J)=VINTPT(IACC,J)
8158 340 CONTINUE
8159 IF(ISTSB.NE.5) THEN
8160 CALL PYSIGH(NCHN,SIGS)
8161 IF(MWTXS.EQ.1) THEN
8162 CALL PYEVWT(WTXS)
8163 SIGS=WTXS*SIGS
8164 ENDIF
8165 ELSE
8166 SIGS=0D0
8167 DO 350 IKIN3=1,MSTP(129)
8168 CALL PYKMAP(5,0,0D0)
8169 IF(MINT(51).EQ.1) GOTO 350
8170 CALL PYSIGH(NCHN,SIGTMP)
8171 IF(MWTXS.EQ.1) THEN
8172 CALL PYEVWT(WTXS)
8173 SIGTMP=WTXS*SIGTMP
8174 ENDIF
8175 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8176 350 CONTINUE
8177 ENDIF
8178 IEQ=0
8179 DO 360 IMV=1,NMAX
8180 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8181 360 CONTINUE
8182 IF(IEQ.EQ.0) THEN
8183 DO 370 IMV=NMAX,1,-1
8184 IIN=IMV+1
8185 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8186 IACCMX(IMV+1)=IACCMX(IMV)
8187 SIGSMX(IMV+1)=SIGSMX(IMV)
8188 370 CONTINUE
8189 IIN=1
8190 380 IACCMX(IIN)=IACC
8191 SIGSMX(IIN)=SIGS
8192 IF(NMAX.LE.1) NMAX=NMAX+1
8193 ENDIF
8194 390 CONTINUE
8195
8196C...Read out starting position for search.
8197 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8198 SIGSAM=SIGSMX(1)
8199 DO 440 IMAX=1,NMAX
8200 IACC=IACCMX(IMAX)
8201 MTAU=MVARPT(IACC,1)
8202 MTAUP=MVARPT(IACC,2)
8203 MYST=MVARPT(IACC,3)
8204 MCTH=MVARPT(IACC,4)
8205 VTAU=0.5D0
8206 VYST=0.5D0
8207 VCTH=0.5D0
8208 VTAUP=0.5D0
8209
8210C...Starting point and step size in parameter space.
8211 DO 430 IRPT=1,2
8212 DO 420 IVAR=1,4
8213 IF(NPTS(IVAR).EQ.1) GOTO 420
8214 IF(IVAR.EQ.1) VVAR=VTAU
8215 IF(IVAR.EQ.2) VVAR=VTAUP
8216 IF(IVAR.EQ.3) VVAR=VYST
8217 IF(IVAR.EQ.4) VVAR=VCTH
8218 IF(IVAR.EQ.1) MVAR=MTAU
8219 IF(IVAR.EQ.2) MVAR=MTAUP
8220 IF(IVAR.EQ.3) MVAR=MYST
8221 IF(IVAR.EQ.4) MVAR=MCTH
8222 IF(IRPT.EQ.1) VDEL=0.1D0
8223 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8224 & 0.98D0-VVAR))
8225 IF(IRPT.EQ.1) VMAR=0.02D0
8226 IF(IRPT.EQ.2) VMAR=0.002D0
8227 IMOV0=1
8228 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8229 DO 410 IMOV=IMOV0,8
8230
8231C...Define new point in parameter space.
8232 IF(IMOV.EQ.0) THEN
8233 INEW=2
8234 VNEW=VVAR
8235 ELSEIF(IMOV.EQ.1) THEN
8236 INEW=3
8237 VNEW=VVAR+VDEL
8238 ELSEIF(IMOV.EQ.2) THEN
8239 INEW=1
8240 VNEW=VVAR-VDEL
8241 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8242 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8243 VVAR=VVAR+VDEL
8244 SIGSSM(1)=SIGSSM(2)
8245 SIGSSM(2)=SIGSSM(3)
8246 INEW=3
8247 VNEW=VVAR+VDEL
8248 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8249 & VVAR-2D0*VDEL.GT.VMAR) THEN
8250 VVAR=VVAR-VDEL
8251 SIGSSM(3)=SIGSSM(2)
8252 SIGSSM(2)=SIGSSM(1)
8253 INEW=1
8254 VNEW=VVAR-VDEL
8255 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8256 VDEL=0.5D0*VDEL
8257 VVAR=VVAR+VDEL
8258 SIGSSM(1)=SIGSSM(2)
8259 INEW=2
8260 VNEW=VVAR
8261 ELSE
8262 VDEL=0.5D0*VDEL
8263 VVAR=VVAR-VDEL
8264 SIGSSM(3)=SIGSSM(2)
8265 INEW=2
8266 VNEW=VVAR
8267 ENDIF
8268
8269C...Convert to relevant variables and find derived new limits.
8270 ILERR=0
8271 IF(IVAR.EQ.1) THEN
8272 VTAU=VNEW
8273 CALL PYKMAP(1,MTAU,VTAU)
8274 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8275 CALL PYKLIM(4)
8276 IF(MINT(51).EQ.1) ILERR=1
8277 ENDIF
8278 ENDIF
8279 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8280 & ILERR.EQ.0) THEN
8281 IF(IVAR.EQ.2) VTAUP=VNEW
8282 CALL PYKMAP(4,MTAUP,VTAUP)
8283 ENDIF
8284 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8285 CALL PYKLIM(2)
8286 IF(MINT(51).EQ.1) ILERR=1
8287 ENDIF
8288 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8289 IF(IVAR.EQ.3) VYST=VNEW
8290 CALL PYKMAP(2,MYST,VYST)
8291 CALL PYKLIM(3)
8292 IF(MINT(51).EQ.1) ILERR=1
8293 ENDIF
8294 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8295 & ILERR.EQ.0) THEN
8296 IF(IVAR.EQ.4) VCTH=VNEW
8297 CALL PYKMAP(3,MCTH,VCTH)
8298 ENDIF
8299 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8300
8301C...Evaluate cross-section. Save new maximum. Final maximum.
8302 IF(ILERR.NE.0) THEN
8303 SIGS=0.
8304 ELSEIF(ISTSB.NE.5) THEN
8305 CALL PYSIGH(NCHN,SIGS)
8306 IF(MWTXS.EQ.1) THEN
8307 CALL PYEVWT(WTXS)
8308 SIGS=WTXS*SIGS
8309 ENDIF
8310 ELSE
8311 SIGS=0D0
8312 DO 400 IKIN3=1,MSTP(129)
8313 CALL PYKMAP(5,0,0D0)
8314 IF(MINT(51).EQ.1) GOTO 400
8315 CALL PYSIGH(NCHN,SIGTMP)
8316 IF(MWTXS.EQ.1) THEN
8317 CALL PYEVWT(WTXS)
8318 SIGTMP=WTXS*SIGTMP
8319 ENDIF
8320 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8321 400 CONTINUE
8322 ENDIF
8323 SIGSSM(INEW)=SIGS
8324 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8325 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8326 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8327 410 CONTINUE
8328 420 CONTINUE
8329 430 CONTINUE
8330 440 CONTINUE
8331 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8332 XSEC(ISUB,1)=1.05D0*SIGSAM
8333C...Add extra headroom for UED
8334 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8335 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8336 & WTGAGA*XSEC(ISUB,1)
8337 450 CONTINUE
8338 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8339 & PARP(174)*XSEC(ISUB,1)
8340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8341 460 CONTINUE
8342 MINT(51)=0
8343
8344C...Print summary table.
8345 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8346 IF(MSTP(127).NE.1) THEN
8347 WRITE(MSTU(11),5900)
8348 CALL PYSTOP(1)
8349 ELSE
8350 WRITE(MSTU(11),6400)
8351 MSTI(53)=1
8352 ENDIF
8353 ENDIF
8354 IF(MSTP(122).GE.1) THEN
8355 WRITE(MSTU(11),6000)
8356 WRITE(MSTU(11),6100)
8357 DO 470 ISUB=1,500
8358 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8359 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8360 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8361 & GOTO 470
8362 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8363 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8364 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8365 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8366 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8367 470 CONTINUE
8368 WRITE(MSTU(11),6300)
8369 ENDIF
8370
8371C...Format statements for maximization results.
8372 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8373 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8374 &'cth',9X,'tau''',7X,'sigma')
8375 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8376 &'phase space.'/1X,'Process switched off!')
8377 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8378 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8379 &'cross-section.'/1X,'Process switched off!')
8380 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8381 5500 FORMAT(1X,1P,10D11.3)
8382 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8383 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8384 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8385 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8386 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8387 &'cross-section.'/1X,'Execution stopped!')
8388 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8389 &'cross-section maximum search',1X,8('*'))
8390 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8391 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8392 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8393 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8394 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8395 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8396 &'cross-section.'/
8397 &1X,'Execution will stop if you try to generate events.')
8398
8399 RETURN
8400 END
8401
8402C*********************************************************************
8403
8404C...PYPILE
8405C...Initializes multiplicity distribution and selects mutliplicity
8406C...of pileup events, i.e. several events occuring at the same
8407C...beam crossing.
8408
8409 SUBROUTINE PYPILE(MPILE)
8410
8411C...Double precision and integer declarations.
8412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8413 IMPLICIT INTEGER(I-N)
8414 INTEGER PYK,PYCHGE,PYCOMP
8415C...Commonblocks.
8416 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8417 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8418 COMMON/PYINT1/MINT(400),VINT(400)
8419 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8420 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8421C...Local arrays and saved variables.
8422 DIMENSION WTI(0:200)
8423 SAVE IMIN,IMAX,WTI,WTS
8424
8425C...Sum of allowed cross-sections for pileup events.
8426 IF(MPILE.EQ.1) THEN
8427 VINT(131)=SIGT(0,0,5)
8428 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8429 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8430 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8431 IF(MSTP(133).LE.0) RETURN
8432
8433C...Initialize multiplicity distribution at maximum.
8434 XNAVE=VINT(131)*PARP(131)
8435 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8436 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8437 WTI(INAVE)=1D0
8438 WTS=WTI(INAVE)
8439 WTN=WTI(INAVE)*INAVE
8440
8441C...Find shape of multiplicity distribution below maximum.
8442 IMIN=INAVE
8443 DO 100 I=INAVE-1,1,-1
8444 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8445 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8446 IF(WTI(I).LT.1D-6) GOTO 110
8447 WTS=WTS+WTI(I)
8448 WTN=WTN+WTI(I)*I
8449 IMIN=I
8450 100 CONTINUE
8451
8452C...Find shape of multiplicity distribution above maximum.
8453 110 IMAX=INAVE
8454 DO 120 I=INAVE+1,200
8455 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8456 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8457 IF(WTI(I).LT.1D-6) GOTO 130
8458 WTS=WTS+WTI(I)
8459 WTN=WTN+WTI(I)*I
8460 IMAX=I
8461 120 CONTINUE
8462 130 VINT(132)=XNAVE
8463 VINT(133)=WTN/WTS
8464 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8465 & WTS/(WTS+WTI(1)/XNAVE)
8466 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8467 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8468
8469C...Pick multiplicity of pileup events.
8470 ELSE
8471 IF(MSTP(133).LE.0) THEN
8472 MINT(81)=MAX(1,MSTP(134))
8473 ELSE
8474 WTR=WTS*PYR(0)
8475 DO 140 I=IMIN,IMAX
8476 MINT(81)=I
8477 WTR=WTR-WTI(I)
8478 IF(WTR.LE.0D0) GOTO 150
8479 140 CONTINUE
8480 150 CONTINUE
8481 ENDIF
8482 ENDIF
8483
8484C...Format statement for error message.
8485 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8486 &'crossing too large, ',1P,D12.4)
8487
8488 RETURN
8489 END
8490
8491C*********************************************************************
8492
8493C...PYSAVE
8494C...Saves and restores parameter and cross section values for the
8495C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8496C...Also makes random choice between alternatives.
8497
8498 SUBROUTINE PYSAVE(ISAVE,IGA)
8499
8500C...Double precision and integer declarations.
8501 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8502 IMPLICIT INTEGER(I-N)
8503 INTEGER PYK,PYCHGE,PYCOMP
8504C...Commonblocks.
8505 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8506 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8507 COMMON/PYINT1/MINT(400),VINT(400)
8508 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8509 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8510 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8511 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8512C...Local arrays and saved variables.
8513 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8514 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8515 &INTCP(15,20),RECP(15,20)
8516 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8517
8518C...Save list of subprocesses and cross-section information.
8519 IF(ISAVE.EQ.1) THEN
8520 ICP=0
8521 DO 120 I=1,500
8522 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8523 ICP=ICP+1
8524 NSUBCP(IGA,ICP)=I
8525 MSUBCP(IGA,ICP)=MSUB(I)
8526 DO 100 J=1,20
8527 COEFCP(IGA,ICP,J)=COEF(I,J)
8528 100 CONTINUE
8529 DO 110 J=1,3
8530 NGENCP(IGA,ICP,J)=NGEN(I,J)
8531 XSECCP(IGA,ICP,J)=XSEC(I,J)
8532 110 CONTINUE
8533 120 CONTINUE
8534 NCP(IGA)=ICP
8535 DO 130 J=1,3
8536 NGENCP(IGA,0,J)=NGEN(0,J)
8537 XSECCP(IGA,0,J)=XSEC(0,J)
8538 130 CONTINUE
8539 DO 160 I1=0,6
8540 DO 150 I2=0,6
8541 DO 140 J=0,5
8542 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8543 140 CONTINUE
8544 150 CONTINUE
8545 160 CONTINUE
8546
8547C...Save various common process variables.
8548 DO 170 J=1,10
8549 INTCP(IGA,J)=MINT(40+J)
8550 170 CONTINUE
8551 INTCP(IGA,11)=MINT(101)
8552 INTCP(IGA,12)=MINT(102)
8553 INTCP(IGA,13)=MINT(107)
8554 INTCP(IGA,14)=MINT(108)
8555 INTCP(IGA,15)=MINT(123)
8556 RECP(IGA,1)=CKIN(3)
8557 RECP(IGA,2)=VINT(318)
8558
8559C...Save cross-section information only.
8560 ELSEIF(ISAVE.EQ.2) THEN
8561 DO 190 ICP=1,NCP(IGA)
8562 I=NSUBCP(IGA,ICP)
8563 DO 180 J=1,3
8564 NGENCP(IGA,ICP,J)=NGEN(I,J)
8565 XSECCP(IGA,ICP,J)=XSEC(I,J)
8566 180 CONTINUE
8567 190 CONTINUE
8568 DO 200 J=1,3
8569 NGENCP(IGA,0,J)=NGEN(0,J)
8570 XSECCP(IGA,0,J)=XSEC(0,J)
8571 200 CONTINUE
8572
8573C...Choose between allowed alternatives.
8574 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8575 IF(ISAVE.EQ.4) THEN
8576 XSUMCP=0D0
8577 DO 210 IG=1,MINT(121)
8578 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8579 210 CONTINUE
8580 XSUMCP=XSUMCP*PYR(0)
8581 DO 220 IG=1,MINT(121)
8582 IGA=IG
8583 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8584 IF(XSUMCP.LE.0D0) GOTO 230
8585 220 CONTINUE
8586 230 CONTINUE
8587 ENDIF
8588
8589C...Restore cross-section information.
8590 DO 240 I=1,500
8591 MSUB(I)=0
8592 240 CONTINUE
8593 DO 270 ICP=1,NCP(IGA)
8594 I=NSUBCP(IGA,ICP)
8595 MSUB(I)=MSUBCP(IGA,ICP)
8596 DO 250 J=1,20
8597 COEF(I,J)=COEFCP(IGA,ICP,J)
8598 250 CONTINUE
8599 DO 260 J=1,3
8600 NGEN(I,J)=NGENCP(IGA,ICP,J)
8601 XSEC(I,J)=XSECCP(IGA,ICP,J)
8602 260 CONTINUE
8603 270 CONTINUE
8604 DO 280 J=1,3
8605 NGEN(0,J)=NGENCP(IGA,0,J)
8606 XSEC(0,J)=XSECCP(IGA,0,J)
8607 280 CONTINUE
8608 DO 310 I1=0,6
8609 DO 300 I2=0,6
8610 DO 290 J=0,5
8611 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8612 290 CONTINUE
8613 300 CONTINUE
8614 310 CONTINUE
8615
8616C...Restore various common process variables.
8617 DO 320 J=1,10
8618 MINT(40+J)=INTCP(IGA,J)
8619 320 CONTINUE
8620 MINT(101)=INTCP(IGA,11)
8621 MINT(102)=INTCP(IGA,12)
8622 MINT(107)=INTCP(IGA,13)
8623 MINT(108)=INTCP(IGA,14)
8624 MINT(123)=INTCP(IGA,15)
8625 CKIN(3)=RECP(IGA,1)
8626 CKIN(1)=2D0*CKIN(3)
8627 VINT(318)=RECP(IGA,2)
8628
8629C...Sum up cross-section info (for PYSTAT).
8630 ELSEIF(ISAVE.EQ.5) THEN
8631 DO 330 I=1,500
8632 MSUB(I)=0
8633 NGEN(I,1)=0
8634 NGEN(I,3)=0
8635 XSEC(I,3)=0D0
8636 330 CONTINUE
8637 NGEN(0,1)=0
8638 NGEN(0,2)=0
8639 NGEN(0,3)=0
8640 XSEC(0,3)=0
8641 DO 350 IG=1,MINT(121)
8642 DO 340 ICP=1,NCP(IG)
8643 I=NSUBCP(IG,ICP)
8644 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8645 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8646 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8647 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8648 340 CONTINUE
8649 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8650 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8651 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8652 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8653 350 CONTINUE
8654 ENDIF
8655
8656 RETURN
8657 END
8658
8659C*********************************************************************
8660
8661C...PYGAGA
8662C...For lepton beams it gives photon-hadron or photon-photon systems
8663C...to be treated with the ordinary machinery and combines this with a
8664C...description of the lepton -> lepton + photon branching.
8665
8666 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8667
8668C...Double precision and integer declarations.
8669 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8670 IMPLICIT INTEGER(I-N)
8671 INTEGER PYK,PYCHGE,PYCOMP
8672C...Commonblocks.
8673 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8676 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8677 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8678 COMMON/PYINT1/MINT(400),VINT(400)
8679 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8680 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8681 &/PYINT5/
8682C...Local variables and data statement.
8683 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8684 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8685 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8686 DATA EPS/1D-4/
8687
8688C...Initialize generation of photons inside leptons.
8689 IF(IGAGA.EQ.1) THEN
8690
8691C...Save quantities on incoming lepton system.
8692 VINT(301)=VINT(1)
8693 VINT(302)=VINT(2)
8694 PMS(1)=VINT(303)**2
8695 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8696 PMS(2)=VINT(304)**2
8697 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8698 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8699 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8700
8701C...Calculate range of x and Q2 values allowed in generation.
8702 DO 100 I=1,2
8703 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8704 IF(MINT(140+I).NE.0) THEN
8705 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8706 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8707 & PMC(I),1D0-EPS)
8708 YMIN=MAX(CKIN(71+2*I),EPS)
8709 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8710 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8711 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8712 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8713 THEMIN=MAX(CKIN(67+2*I),0D0)
8714 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8715 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8716 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8717 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8718 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8719 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8720 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8721 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8722 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8723C...W limits when lepton on one side only.
8724 IF(MINT(143-I).EQ.0) THEN
8725 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8726 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8727 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8728 ENDIF
8729 ENDIF
8730 100 CONTINUE
8731
8732C...W limits when lepton on both sides.
8733 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8734 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8735 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8736 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8737 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8738 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8739 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8740 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8741 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8742 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8743 ELSE
8744 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8745 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8746 ENDIF
8747 ENDIF
8748
8749C...Q2 and W values and photon flux weight factors for initialization.
8750 ELSEIF(IGAGA.EQ.2) THEN
8751 ISUB=MINT(1)
8752 MINT(15)=0
8753 MINT(16)=0
8754
8755C...W value for photon on one or both sides, and for processes
8756C...with gamma-gamma cross section peaked at small shat.
8757 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8758 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8759 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8760 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8761 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8762 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8763 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8764 ELSE
8765 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8766 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8767 ENDIF
8768 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8769
8770C...Upper estimate of photon flux weight factor.
8771C...Initialization Q2 scale. Flag incoming unresolved photon.
8772 WTGAGA=1D0
8773 DO 110 I=1,2
8774 IF(MINT(140+I).NE.0) THEN
8775 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8776 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8777 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8778 & THEN
8779 Q2INIT=5D0+Q2MIN(3-I)
8780 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8781 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8782 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8783 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8784 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8785 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8786 Q2INIT=VINT(2)/3D0
8787 ELSEIF(ISUB.EQ.140) THEN
8788 Q2INIT=VINT(2)/2D0
8789 ELSE
8790 Q2INIT=Q2MIN(I)
8791 ENDIF
8792 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8793 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8794 & MINT(14+I)=22
8795 VINT(306+I)=VINT(2+I)**2
8796 ENDIF
8797 110 CONTINUE
8798 VINT(320)=WTGAGA
8799
8800C...Update pTmin and cross section information.
8801 IF(MSTP(82).LE.1) THEN
8802 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8803 ELSE
8804 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8805 ENDIF
8806 VINT(149)=4D0*PTMN**2/VINT(2)
8807 VINT(154)=PTMN
8808 CALL PYXTOT
8809 VINT(318)=VINT(317)
8810
8811C...Generate photons inside leptons and
8812C...calculate photon flux weight factors.
8813 ELSEIF(IGAGA.EQ.3) THEN
8814 ISUB=MINT(1)
8815 MINT(15)=0
8816 MINT(16)=0
8817
8818C...Generate phase space point and check against cuts.
8819 LOOP=0
8820 120 LOOP=LOOP+1
8821 DO 130 I=1,2
8822 IF(MINT(140+I).NE.0) THEN
8823C...Pick x and Q2
8824 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8825 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8826C...Cuts on internal consistency in x and Q2.
8827 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8828 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8829 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8830C...Cuts on y and theta.
8831 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8832 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8833 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8834 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8835 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8836 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8837 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8838 & GOTO 120
8839
8840C...Phi angle isotropic. Reconstruct pT.
8841 PHI(I)=PARU(2)*PYR(0)
8842 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8843 & PMS(I))*SIN(THETA(I))
8844
8845C...Store info on variables selected, for documentation purposes.
8846 VINT(2+I)=-SQRT(Q2(I))
8847 VINT(304+I)=X(I)
8848 VINT(306+I)=Q2(I)
8849 VINT(308+I)=Y(I)
8850 VINT(310+I)=THETA(I)
8851 VINT(312+I)=PHI(I)
8852 ELSE
8853 VINT(304+I)=1D0
8854 VINT(306+I)=0D0
8855 VINT(308+I)=1D0
8856 VINT(310+I)=0D0
8857 VINT(312+I)=0D0
8858 ENDIF
8859 130 CONTINUE
8860
8861C...Cut on W combines info from two sides.
8862 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8863 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8864 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8865 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8866 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8867 IF(W2.LT.W2MIN) GOTO 120
8868 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8869 PMS1=-Q2(1)
8870 PMS2=-Q2(2)
8871 ELSEIF(MINT(141).NE.0) THEN
8872 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8873 PMS1=-Q2(1)
8874 PMS2=PMS(2)
8875 ELSEIF(MINT(142).NE.0) THEN
8876 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8877 PMS1=PMS(1)
8878 PMS2=-Q2(2)
8879 ENDIF
8880
8881C...Store kinematics info for photon(s) in subsystem cm frame.
8882 VINT(2)=W2
8883 VINT(1)=SQRT(W2)
8884 VINT(291)=0D0
8885 VINT(292)=0D0
8886 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8887 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8888 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8889 VINT(296)=0D0
8890 VINT(297)=0D0
8891 VINT(298)=-VINT(293)
8892 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8893 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8894
8895C...Assign weight for photon flux; different for transverse and
8896C...longitudinal photons. Flag incoming unresolved photon.
8897 WTGAGA=1D0
8898 DO 140 I=1,2
8899 IF(MINT(140+I).NE.0) THEN
8900 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8901 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8902 IF(MSTP(16).EQ.0) THEN
8903 XY=X(I)
8904 ELSE
8905 WTGAGA=WTGAGA*X(I)/Y(I)
8906 XY=Y(I)
8907 ENDIF
8908 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8909 WTGAGA=WTGAGA*(1D0-XY)
8910 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8911 WTGAGA=WTGAGA*(1D0-XY)
8912 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8913 WTGAGA=WTGAGA*(1D0-XY)
8914 ELSE
8915 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8916 & PMS(I)*XY**2/Q2(I))
8917 ENDIF
8918 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8919 ENDIF
8920 140 CONTINUE
8921 VINT(319)=WTGAGA
8922 MINT(143)=LOOP
8923
8924C...Update pTmin and cross section information.
8925 IF(MSTP(82).LE.1) THEN
8926 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8927 ELSE
8928 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8929 ENDIF
8930 VINT(149)=4D0*PTMN**2/VINT(2)
8931 VINT(154)=PTMN
8932 CALL PYXTOT
8933
8934C...Reconstruct kinematics of photons inside leptons.
8935 ELSEIF(IGAGA.EQ.4) THEN
8936
8937C...Make place for incoming particles and scattered leptons.
8938 MOVE=3
8939 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8940 MINT(4)=MINT(4)+MOVE
8941 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8942 IF(K(I,1).EQ.21) THEN
8943 DO 150 J=1,5
8944 K(I+MOVE,J)=K(I,J)
8945 P(I+MOVE,J)=P(I,J)
8946 V(I+MOVE,J)=V(I,J)
8947 150 CONTINUE
8948 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8949 & K(I+MOVE,3)=K(I,3)+MOVE
8950 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8951 & K(I+MOVE,4)=K(I,4)+MOVE
8952 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8953 & K(I+MOVE,5)=K(I,5)+MOVE
8954 ENDIF
8955 160 CONTINUE
8956 DO 170 I=MINT(84)+1,N
8957 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8958 & K(I,3)=K(I,3)+MOVE
8959 170 CONTINUE
8960
8961C...Fill in incoming particles.
8962 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8963 DO 180 J=1,5
8964 K(I,J)=0
8965 P(I,J)=0D0
8966 V(I,J)=0D0
8967 180 CONTINUE
8968 190 CONTINUE
8969 DO 200 I=1,2
8970 K(MINT(83)+I,1)=21
8971 IF(MINT(140+I).NE.0) THEN
8972 K(MINT(83)+I,2)=MINT(140+I)
8973 P(MINT(83)+I,5)=VINT(302+I)
8974 ELSE
8975 K(MINT(83)+I,2)=MINT(10+I)
8976 P(MINT(83)+I,5)=VINT(2+I)
8977 ENDIF
8978 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8979 & VINT(302))*(-1D0)**(I+1)
8980 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8981 200 CONTINUE
8982
8983C...New mother-daughter relations in documentation section.
8984 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8985 K(MINT(83)+1,4)=MINT(83)+3
8986 K(MINT(83)+1,5)=MINT(83)+5
8987 K(MINT(83)+2,4)=MINT(83)+4
8988 K(MINT(83)+2,5)=MINT(83)+6
8989 K(MINT(83)+3,3)=MINT(83)+1
8990 K(MINT(83)+5,3)=MINT(83)+1
8991 K(MINT(83)+4,3)=MINT(83)+2
8992 K(MINT(83)+6,3)=MINT(83)+2
8993 ELSEIF(MINT(141).NE.0) THEN
8994 K(MINT(83)+1,4)=MINT(83)+3
8995 K(MINT(83)+1,5)=MINT(83)+4
8996 K(MINT(83)+2,4)=MINT(83)+5
8997 K(MINT(83)+3,3)=MINT(83)+1
8998 K(MINT(83)+4,3)=MINT(83)+1
8999 K(MINT(83)+5,3)=MINT(83)+2
9000 ELSEIF(MINT(142).NE.0) THEN
9001 K(MINT(83)+1,4)=MINT(83)+4
9002 K(MINT(83)+2,4)=MINT(83)+3
9003 K(MINT(83)+2,5)=MINT(83)+5
9004 K(MINT(83)+3,3)=MINT(83)+2
9005 K(MINT(83)+4,3)=MINT(83)+1
9006 K(MINT(83)+5,3)=MINT(83)+2
9007 ENDIF
9008
9009C...Fill scattered lepton(s).
9010 DO 210 I=1,2
9011 IF(MINT(140+I).NE.0) THEN
9012 LSC=MINT(83)+MIN(I+2,MOVE)
9013 K(LSC,1)=21
9014 K(LSC,2)=MINT(140+I)
9015 P(LSC,1)=PT(I)*COS(PHI(I))
9016 P(LSC,2)=PT(I)*SIN(PHI(I))
9017 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9018 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9019 & (-1D0)**(I-1)
9020 P(LSC,5)=VINT(302+I)
9021 ENDIF
9022 210 CONTINUE
9023
9024C...Find incoming four-vectors to subprocess.
9025 K(N+1,1)=21
9026 IF(MINT(141).NE.0) THEN
9027 DO 220 J=1,4
9028 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9029 220 CONTINUE
9030 ELSE
9031 DO 230 J=1,4
9032 P(N+1,J)=P(MINT(83)+1,J)
9033 230 CONTINUE
9034 ENDIF
9035 K(N+2,1)=21
9036 IF(MINT(142).NE.0) THEN
9037 DO 240 J=1,4
9038 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9039 240 CONTINUE
9040 ELSE
9041 DO 250 J=1,4
9042 P(N+2,J)=P(MINT(83)+2,J)
9043 250 CONTINUE
9044 ENDIF
9045
9046C...Define boost and rotation between hadronic subsystem and
9047C...collision rest frame; boost hadronic subsystem to this frame.
9048 DO 260 J=1,3
9049 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9050 260 CONTINUE
9051 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9052 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9053 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9054 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9055 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9056 & BETA(3))
9057
9058C...Add on scattered leptons to final state.
9059 DO 280 I=1,2
9060 IF(MINT(140+I).NE.0) THEN
9061 LSC=MINT(83)+MIN(I+2,MOVE)
9062 N=N+1
9063 DO 270 J=1,5
9064 K(N,J)=K(LSC,J)
9065 P(N,J)=P(LSC,J)
9066 V(N,J)=V(LSC,J)
9067 270 CONTINUE
9068 K(N,1)=1
9069 K(N,3)=LSC
9070 ENDIF
9071 280 CONTINUE
9072 ENDIF
9073
9074 RETURN
9075 END
9076
9077C*********************************************************************
9078
9079C...PYRAND
9080C...Generates quantities characterizing the high-pT scattering at the
9081C...parton level according to the matrix elements. Chooses incoming,
9082C...reacting partons, their momentum fractions and one of the possible
9083C...subprocesses.
9084
9085 SUBROUTINE PYRAND
9086
9087C...Double precision and integer declarations.
9088 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9089 IMPLICIT INTEGER(I-N)
9090 INTEGER PYK,PYCHGE,PYCOMP
9091C...Parameter statement to help give large particle numbers.
9092 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9093 &KEXCIT=4000000,KDIMEN=5000000)
9094
9095C...User process initialization and event commonblocks.
9096 INTEGER MAXPUP
9097 PARAMETER (MAXPUP=100)
9098 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9099 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9100 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9101 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9102 &LPRUP(MAXPUP)
9103 INTEGER MAXNUP
9104 PARAMETER (MAXNUP=500)
9105 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9106 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9107 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9108 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9109 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9110 SAVE /HEPRUP/,/HEPEUP/
9111
9112C...Commonblocks.
9113 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9114 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9115 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9116 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9117 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9118 COMMON/PYINT1/MINT(400),VINT(400)
9119 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9120 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9121 COMMON/PYINT4/MWID(500),WIDS(500,5)
9122 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9123 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9124 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9125 COMMON/PYTCCO/COEFX(194:380,2)
9126 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9127 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9128 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9129 &/TCPARA/
9130C...Local arrays.
9131 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9132
9133C...Parameters and data used in elastic/diffractive treatment.
9134 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9135 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9136
9137C...Initial values, specifically for (first) semihard interaction.
9138 MINT(10)=0
9139 MINT(17)=0
9140 MINT(18)=0
9141 VINT(143)=1D0
9142 VINT(144)=1D0
9143 VINT(157)=0D0
9144 VINT(158)=0D0
9145 MFAIL=0
9146 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9147 ISUB=0
9148 ISTSB=0
9149 LOOP=0
9150 100 LOOP=LOOP+1
9151 MINT(51)=0
9152 MINT(143)=1
9153 VINT(97)=1D0
9154
9155C...Start by assuming incoming photon is entering subprocess.
9156 IF(MINT(11).EQ.22) THEN
9157 MINT(15)=22
9158 VINT(307)=VINT(3)**2
9159 ENDIF
9160 IF(MINT(12).EQ.22) THEN
9161 MINT(16)=22
9162 VINT(308)=VINT(4)**2
9163 ENDIF
9164 MINT(103)=MINT(11)
9165 MINT(104)=MINT(12)
9166
9167C...Choice of process type - first event of pileup.
9168 INMULT=0
9169 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9170 ELSEIF(MINT(82).EQ.1) THEN
9171
9172C...For gamma-p or gamma-gamma first pick between alternatives.
9173 IGA=0
9174 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9175 MINT(122)=IGA
9176
9177C...For real gamma + gamma with different nature, flip at random.
9178 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9179 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9180 MINTSV=MINT(41)
9181 MINT(41)=MINT(42)
9182 MINT(42)=MINTSV
9183 MINTSV=MINT(45)
9184 MINT(45)=MINT(46)
9185 MINT(46)=MINTSV
9186 MINTSV=MINT(107)
9187 MINT(107)=MINT(108)
9188 MINT(108)=MINTSV
9189 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9190 ENDIF
9191
9192C...Pick process type, possibly by user process machinery.
9193C...(If the latter, also event will be picked here.)
9194 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9195 CALL UPEVNT
9196 CALL PYUPRE
9197 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9198 CALL UPEVNT
9199 CALL PYUPRE
9200 ISUB=0
9201 110 ISUB=ISUB+1
9202 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9203 & ISUB.LT.500) GOTO 110
9204 ELSE
9205 RSUB=XSEC(0,1)*PYR(0)
9206 DO 120 I=1,500
9207 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9208 ISUB=I
9209 RSUB=RSUB-XSEC(I,1)
9210 IF(RSUB.LE.0D0) GOTO 130
9211 120 CONTINUE
9212 130 IF(ISUB.EQ.95) ISUB=96
9213 IF(ISUB.EQ.96) INMULT=1
9214 IF(ISET(ISUB).EQ.11) THEN
9215 IDPRUP=KFPR(ISUB,2)
9216 CALL UPEVNT
9217 CALL PYUPRE
9218 ENDIF
9219 ENDIF
9220
9221C...Choice of inclusive process type - pileup events.
9222 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9223 RSUB=VINT(131)*PYR(0)
9224 ISUB=96
9225 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9226 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9227 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9228 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9229 & ISUB=91
9230 IF(ISUB.EQ.96) INMULT=1
9231 ENDIF
9232
9233C...Choice of photon energy and flux factor inside lepton.
9234 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9235 CALL PYGAGA(3,WTGAGA)
9236 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9237 CKIN(3)=MAX(VINT(285),VINT(154))
9238 CKIN(1)=2D0*CKIN(3)
9239 ENDIF
9240C...When necessary set direct/resolved photon by hand.
9241 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9242 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9243 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9244 ENDIF
9245
9246C...Restrict direct*resolved processes to pTmin >= Q,
9247C...to avoid doublecounting with DIS.
9248 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9249 IF(MINT(15).EQ.22) THEN
9250 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9251 ELSE
9252 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9253 ENDIF
9254 CKIN(1)=2D0*CKIN(3)
9255 ENDIF
9256
9257C...Set up for multiple interactions (may include impact parameter).
9258 IF(INMULT.EQ.1) THEN
9259 IF(MINT(35).LE.1) CALL PYMULT(2)
9260 IF(MINT(35).GE.2) CALL PYMIGN(2)
9261 ENDIF
9262
9263C...Loopback point for minimum bias in photon physics.
9264 LOOP2=0
9265 140 LOOP2=LOOP2+1
9266 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9267 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9268 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9269 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9270 MINT(1)=ISUB
9271 ISTSB=ISET(ISUB)
9272
9273C...Random choice of flavour for some SUSY processes.
9274 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9275C...~e_L ~nu_e or ~mu_L ~nu_mu.
9276 IF(ISUB.EQ.210) THEN
9277 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9278 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9279C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9280 ELSEIF(ISUB.EQ.213) THEN
9281 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9282 KFPR(ISUB,2)=KFPR(ISUB,1)
9283C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9284 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9285 & ISUB.NE.257) THEN
9286 IF(ISUB.GE.258) THEN
9287 RKF=4D0
9288 ELSE
9289 RKF=5D0
9290 ENDIF
9291 IF(MOD(ISUB,2).EQ.0) THEN
9292 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9293 ELSE
9294 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9295 ENDIF
9296C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9297 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9298 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9299 KSU1=KSUSY1
9300 KSU2=KSUSY1
9301 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9302 KSU1=KSUSY2
9303 KSU2=KSUSY2
9304 ELSEIF(PYR(0).LT.0.5D0) THEN
9305 KSU1=KSUSY1
9306 KSU2=KSUSY2
9307 ELSE
9308 KSU1=KSUSY2
9309 KSU2=KSUSY1
9310 ENDIF
9311 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9312 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9313C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9314 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9315 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9316 KFPR(ISUB,2)=KFPR(ISUB,1)
9317 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9318 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9319 KFPR(ISUB,2)=KFPR(ISUB,1)
9320C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9321 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9322 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9323 KSU1=KSUSY1
9324 KSU2=KSUSY1
9325 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9326 KSU1=KSUSY2
9327 KSU2=KSUSY2
9328 ELSEIF(PYR(0).LT.0.5D0) THEN
9329 KSU1=KSUSY1
9330 KSU2=KSUSY2
9331 ELSE
9332 KSU1=KSUSY2
9333 KSU2=KSUSY1
9334 ENDIF
9335 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9336 RKF=5D0
9337 ELSE
9338 RKF=4D0
9339 ENDIF
9340 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9341 ENDIF
9342 ENDIF
9343
9344C...Random choice of flavours for some UED processes
9345c...The production processes can generate a doublet pair,
9346c...a singlet pair, or a doublet + singlet.
9347 IF(ISUB.EQ.313)THEN
9348C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9349 IF(PYR(0).LE.0.1)THEN
9350 KFPR(ISUB,1)=5100001
9351 ELSE
9352 KFPR(ISUB,1)=5100002
9353 ENDIF
9354 KFPR(ISUB,2)=KFPR(ISUB,1)
9355 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9356C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9357C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9358 IF(PYR(0).LE.0.1)THEN
9359 KFPR(ISUB,1)=5100001
9360 ELSE
9361 KFPR(ISUB,1)=5100002
9362 ENDIF
9363 KFPR(ISUB,2)=-KFPR(ISUB,1)
9364 ELSEIF(ISUB.EQ.316)THEN
9365C...qi + qbarj -> q*_Di + q*_Sbarj
9366 IF(PYR(0).LE.0.5)THEN
9367 KFPR(ISUB,1)=5100001
9368c Changed from private pythia6410_ued code
9369c KFPR(ISUB,2)=-5010001
9370 KFPR(ISUB,2)=-6100002
9371 ELSE
9372 KFPR(ISUB,1)=5100002
9373c Changed from private pythia6410_ued code
9374c KFPR(ISUB,2)=-5010002
9375 KFPR(ISUB,2)=-6100001
9376 ENDIF
9377 ELSEIF(ISUB.EQ.317)THEN
9378C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9379 IF(PYR(0).LE.0.5)THEN
9380 KFPR(ISUB,1)=5100001
9381 KFPR(ISUB,2)=-5100002
9382 ELSE
9383 KFPR(ISUB,1)=5100002
9384 KFPR(ISUB,2)=-5100001
9385 ENDIF
9386 ELSEIF(ISUB.EQ.318)THEN
9387C...qi + qj -> q*_Di + q*_Sj
9388 IF(PYR(0).LE.0.5)THEN
9389 KFPR(ISUB,1)=5100001
9390 KFPR(ISUB,2)=6100002
9391 ELSE
9392 KFPR(ISUB,1)=5100002
9393 KFPR(ISUB,2)=6100001
9394 ENDIF
9395 ENDIF
9396
9397C...Find resonances (explicit or implicit in cross-section).
9398 MINT(72)=0
9399 KFR1=0
9400 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9401 KFR1=KFPR(ISUB,1)
9402 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9403 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9404 KFR1=23
9405 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9406 & ISUB.EQ.177) THEN
9407 KFR1=24
9408 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9409 KFR1=25
9410 IF(MSTP(46).EQ.5) THEN
9411 KFR1=89
9412 PMAS(89,1)=PARP(45)
9413 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9414 ENDIF
9415 ENDIF
9416 CKMX=CKIN(2)
9417 IF(CKMX.LE.0D0) CKMX=VINT(1)
9418 KCR1=PYCOMP(KFR1)
9419 IF(KFR1.NE.0) THEN
9420 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9421 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9422 ENDIF
9423 IF(KFR1.NE.0) THEN
9424 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9425 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9426 MINT(72)=1
9427 MINT(73)=KFR1
9428 VINT(73)=TAUR1
9429 VINT(74)=GAMR1
9430 ENDIF
9431 KFR2=0
9432 KFR3=0
9433 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9434 $(ISUB.GE.361.AND.ISUB.LE.380))
9435 $THEN
9436 KFR2=23
9437 IF(ISUB.EQ.141) THEN
9438 KCR2=PYCOMP(KFR2)
9439 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9440 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9441 KFR2=0
9442 ELSE
9443 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9444 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9445 MINT(72)=2
9446 MINT(74)=KFR2
9447 VINT(75)=TAUR2
9448 VINT(76)=GAMR2
9449 ENDIF
9450C...3 resonances at work: rho, omega, a
9451 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9452 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9453 MINT(72)=IRES
9454 IF(IRES.GE.1) THEN
9455 VINT(73)=XMAS(1)**2/VINT(2)
9456 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9457 TAUR1=VINT(73)
9458 GAMR1=VINT(74)
9459 KFR1=1
9460 ENDIF
9461 IF(IRES.GE.2) THEN
9462 VINT(75)=XMAS(2)**2/VINT(2)
9463 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9464 TAUR2=VINT(75)
9465 GAMR2=VINT(76)
9466 KFR2=2
9467 ENDIF
9468 IF(IRES.EQ.3) THEN
9469 VINT(77)=XMAS(3)**2/VINT(2)
9470 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9471 TAUR3=VINT(77)
9472 GAMR3=VINT(78)
9473 KFR3=3
9474 ENDIF
9475C...Charged current: rho+- and a+-
9476 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9477 MINT(72)=IRES
9478 IF(JRES.GE.1) THEN
9479 VINT(73)=YMAS(1)**2/VINT(2)
9480 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9481 KFR1=1
9482 TAUR1=VINT(73)
9483 GAMR1=VINT(74)
9484 ENDIF
9485 IF(JRES.GE.2) THEN
9486 VINT(75)=YMAS(2)**2/VINT(2)
9487 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9488 KFR2=2
9489 TAUR2=VINT(73)
9490 GAMR2=VINT(74)
9491 ENDIF
9492 KFR3=0
9493 ENDIF
9494 IF(ISUB.NE.141) THEN
9495 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9496
9497 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9498 MINT(72)=2
9499 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9500 MINT(72)=2
9501 MINT(74)=KFR3
9502 VINT(75)=TAUR3
9503 VINT(76)=GAMR3
9504 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9505 MINT(72)=2
9506 MINT(73)=KFR2
9507 VINT(73)=TAUR2
9508 VINT(74)=GAMR2
9509 MINT(74)=KFR3
9510 VINT(75)=TAUR3
9511 VINT(76)=GAMR3
9512 ELSEIF(KFR1.NE.0) THEN
9513 MINT(72)=1
9514 ELSEIF(KFR2.NE.0) THEN
9515 MINT(72)=1
9516 MINT(73)=KFR2
9517 VINT(73)=TAUR2
9518 VINT(74)=GAMR2
9519 ELSEIF(KFR3.NE.0) THEN
9520 MINT(72)=1
9521 MINT(73)=KFR3
9522 VINT(73)=TAUR3
9523 VINT(74)=GAMR3
9524 ELSE
9525 MINT(72)=0
9526 ENDIF
9527 ELSE
9528 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9529
9530 ELSEIF(KFR2.NE.0) THEN
9531 KFR1=KFR2
9532 TAUR1=TAUR2
9533 GAMR1=GAMR2
9534 MINT(72)=1
9535 MINT(73)=KFR1
9536 VINT(73)=TAUR1
9537 VINT(74)=GAMR1
9538 KFR2=0
9539 ELSE
9540 MINT(72)=0
9541 ENDIF
9542 ENDIF
9543 ENDIF
9544
9545C...Find product masses and minimum pT of process,
9546C...optionally with broadening according to a truncated Breit-Wigner.
9547 VINT(63)=0D0
9548 VINT(64)=0D0
9549 MINT(71)=0
9550 VINT(71)=CKIN(3)
9551 IF(MINT(82).GE.2) VINT(71)=0D0
9552 VINT(80)=1D0
9553 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9554 NBW=0
9555 DO 160 I=1,2
9556 PMMN(I)=0D0
9557 IF(KFPR(ISUB,I).EQ.0) THEN
9558 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9559 & PARP(41)) THEN
9560 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9561 ELSE
9562 NBW=NBW+1
9563C...This prevents SUSY/t particles from becoming too light.
9564 KFLW=KFPR(ISUB,I)
9565 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9566 KCW=PYCOMP(KFLW)
9567 PMMN(I)=PMAS(KCW,1)
9568 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9569 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9570 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9571 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9572 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9573 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9574 PMMN(I)=MIN(PMMN(I),PMSUM)
9575 ENDIF
9576 150 CONTINUE
9577 ELSEIF(KFLW.EQ.6) THEN
9578 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9579 ENDIF
9580 ENDIF
9581 160 CONTINUE
9582 IF(NBW.GE.1) THEN
9583 CKIN41=CKIN(41)
9584 CKIN43=CKIN(43)
9585 CKIN(41)=MAX(PMMN(1),CKIN(41))
9586 CKIN(43)=MAX(PMMN(2),CKIN(43))
9587 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9588 CKIN(41)=CKIN41
9589 CKIN(43)=CKIN43
9590 IF(MINT(51).EQ.1) THEN
9591 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9592 IF(MFAIL.EQ.1) THEN
9593 MSTI(61)=1
9594 RETURN
9595 ENDIF
9596 GOTO 100
9597 ENDIF
9598 VINT(63)=PQM3**2
9599 VINT(64)=PQM4**2
9600 ENDIF
9601 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9602 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9603 ENDIF
9604
9605C...Prepare for additional variable choices in 2 -> 3.
9606 IF(ISTSB.EQ.5) THEN
9607 VINT(201)=0D0
9608 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9609 VINT(206)=VINT(201)
9610 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9611 VINT(204)=PMAS(23,1)
9612 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9613 & VINT(204)=PMAS(24,1)
9614 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9615 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9616 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9617 & VINT(204)=VINT(201)
9618 VINT(209)=VINT(204)
9619 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9620 ENDIF
9621
9622C...Select incoming VDM particle (rho/omega/phi/J/psi).
9623 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9624 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9625 VRN=PYR(0)*SIGT(0,0,5)
9626 IF(MINT(101).LE.1) THEN
9627 I1MN=0
9628 I1MX=0
9629 ELSE
9630 I1MN=1
9631 I1MX=MINT(101)
9632 ENDIF
9633 IF(MINT(102).LE.1) THEN
9634 I2MN=0
9635 I2MX=0
9636 ELSE
9637 I2MN=1
9638 I2MX=MINT(102)
9639 ENDIF
9640 DO 180 I1=I1MN,I1MX
9641 KFV1=110*I1+3
9642 DO 170 I2=I2MN,I2MX
9643 KFV2=110*I2+3
9644 VRN=VRN-SIGT(I1,I2,5)
9645 IF(VRN.LE.0D0) GOTO 190
9646 170 CONTINUE
9647 180 CONTINUE
9648 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9649 IF(MINT(102).GE.2) MINT(104)=KFV2
9650 ENDIF
9651
9652 IF(ISTSB.EQ.0) THEN
9653C...Elastic scattering or single or double diffractive scattering.
9654
9655C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9656 MINT(103)=MINT(11)
9657 MINT(104)=MINT(12)
9658 PMM(1)=VINT(3)
9659 PMM(2)=VINT(4)
9660 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9661 JJ=ISUB-90
9662 VRN=PYR(0)*SIGT(0,0,JJ)
9663 IF(MINT(101).LE.1) THEN
9664 I1MN=0
9665 I1MX=0
9666 ELSE
9667 I1MN=1
9668 I1MX=MINT(101)
9669 ENDIF
9670 IF(MINT(102).LE.1) THEN
9671 I2MN=0
9672 I2MX=0
9673 ELSE
9674 I2MN=1
9675 I2MX=MINT(102)
9676 ENDIF
9677 DO 210 I1=I1MN,I1MX
9678 KFV1=110*I1+3
9679 DO 200 I2=I2MN,I2MX
9680 KFV2=110*I2+3
9681 VRN=VRN-SIGT(I1,I2,JJ)
9682 IF(VRN.LE.0D0) GOTO 220
9683 200 CONTINUE
9684 210 CONTINUE
9685 220 IF(MINT(101).GE.2) THEN
9686 MINT(103)=KFV1
9687 PMM(1)=PYMASS(KFV1)
9688 ENDIF
9689 IF(MINT(102).GE.2) THEN
9690 MINT(104)=KFV2
9691 PMM(2)=PYMASS(KFV2)
9692 ENDIF
9693 ENDIF
9694 VINT(67)=PMM(1)
9695 VINT(68)=PMM(2)
9696
9697C...Select mass for GVMD states (rejecting previous assignment).
9698 Q0S=4D0*PARP(15)**2
9699 Q1S=4D0*VINT(154)**2
9700 LOOP3=0
9701 230 LOOP3=LOOP3+1
9702 DO 240 JT=1,2
9703 IF(MINT(106+JT).EQ.3) THEN
9704 PS=VINT(2+JT)**2
9705 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9706 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9707 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9708 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9709 ENDIF
9710 240 CONTINUE
9711 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9712 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9713 & GOTO 230
9714 GOTO 100
9715 ENDIF
9716
9717C...Side/sides of diffractive system.
9718 MINT(17)=0
9719 MINT(18)=0
9720 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9721 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9722
9723C...Find masses of particles and minimal masses of diffractive states.
9724 DO 250 JT=1,2
9725 PDIF(JT)=PMM(JT)
9726 VINT(68+JT)=PDIF(JT)
9727 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9728 250 CONTINUE
9729 SH=VINT(2)
9730 SQM1=PMM(1)**2
9731 SQM2=PMM(2)**2
9732 SQM3=PDIF(1)**2
9733 SQM4=PDIF(2)**2
9734 SMRES1=(PMM(1)+PMRC)**2
9735 SMRES2=(PMM(2)+PMRC)**2
9736
9737C...Find elastic slope and lower limit diffractive slope.
9738 IHA=MAX(2,IABS(MINT(103))/110)
9739 IF(IHA.GE.5) IHA=1
9740 IHB=MAX(2,IABS(MINT(104))/110)
9741 IF(IHB.GE.5) IHB=1
9742 IF(ISUB.EQ.91) THEN
9743 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9744 ELSEIF(ISUB.EQ.92) THEN
9745 BMN=MAX(2D0,2D0*BHAD(IHB))
9746 ELSEIF(ISUB.EQ.93) THEN
9747 BMN=MAX(2D0,2D0*BHAD(IHA))
9748 ELSEIF(ISUB.EQ.94) THEN
9749 BMN=2D0*ALP*4D0
9750 ENDIF
9751
9752C...Determine maximum possible t range and coefficient of generation.
9753 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9754 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9755 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9756 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9757 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9758 & (SQM1*SQM4-SQM2*SQM3)/SH
9759 THL=-0.5D0*(THA+THB)
9760 THU=THC/THL
9761 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9762
9763C...Select diffractive mass/masses according to dm^2/m^2.
9764 LOOP3=0
9765 260 LOOP3=LOOP3+1
9766 DO 270 JT=1,2
9767 IF(MINT(16+JT).EQ.0) THEN
9768 PDIF(2+JT)=PDIF(JT)
9769 ELSE
9770 PMMIN=PDIF(JT)
9771 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9772 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9773 ENDIF
9774 270 CONTINUE
9775 SQM3=PDIF(3)**2
9776 SQM4=PDIF(4)**2
9777
9778C..Additional mass factors, including resonance enhancement.
9779 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9780 IF(LOOP3.LT.100) GOTO 260
9781 GOTO 100
9782 ENDIF
9783 IF(ISUB.EQ.92) THEN
9784 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9785 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9786 ELSEIF(ISUB.EQ.93) THEN
9787 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9788 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9789 ELSEIF(ISUB.EQ.94) THEN
9790 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9791 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9792 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9793 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9794 ENDIF
9795
9796C...Select t according to exp(Bmn*t) and correct to right slope.
9797 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9798 IF(ISUB.GE.92) THEN
9799 IF(ISUB.EQ.92) THEN
9800 BADD=2D0*ALP*LOG(SH/SQM3)
9801 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9802 ELSEIF(ISUB.EQ.93) THEN
9803 BADD=2D0*ALP*LOG(SH/SQM4)
9804 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9805 ELSEIF(ISUB.EQ.94) THEN
9806 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9807 ENDIF
9808 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9809 ENDIF
9810
9811C...Check whether m^2 and t choices are consistent.
9812 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9813 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9814 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9815 IF(THB.LE.1D-8) GOTO 260
9816 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9817 & (SQM1*SQM4-SQM2*SQM3)/SH
9818 THLM=-0.5D0*(THA+THB)
9819 THUM=THC/THLM
9820 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9821
9822C...Information to output.
9823 VINT(21)=1D0
9824 VINT(22)=0D0
9825 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9826 VINT(45)=TH
9827 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9828 VINT(63)=PDIF(3)**2
9829 VINT(64)=PDIF(4)**2
9830 VINT(283)=PMM(1)**2/4D0
9831 VINT(284)=PMM(2)**2/4D0
9832
9833C...Note: in the following, by In is meant the integral over the
9834C...quantity multiplying coefficient cn.
9835C...Choose tau according to h1(tau)/tau, where
9836C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9837C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9838C...I1/I5*c5*1/(tau+tau_R') +
9839C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9840C...I1/I7*c7*tau/(1.-tau), and
9841C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9842 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9843 CALL PYKLIM(1)
9844 IF(MINT(51).NE.0) THEN
9845 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9846 IF(MFAIL.EQ.1) THEN
9847 MSTI(61)=1
9848 RETURN
9849 ENDIF
9850 GOTO 100
9851 ENDIF
9852 RTAU=PYR(0)
9853 MTAU=1
9854 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9855 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9856 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9857 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9858 & MTAU=5
9859 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9860 & COEF(ISUB,5)) MTAU=6
9861 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9862 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9863C...Additional check to handle techni-processes with extra resonance
9864C....Only modify tau treatment
9865 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9866 & THEN
9867 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9868 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9869 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9870 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9871 & +COEFX(ISUB,1)) MTAU=9
9872 ENDIF
9873 CALL PYKMAP(1,MTAU,PYR(0))
9874
9875C...2 -> 3, 4 processes:
9876C...Choose tau' according to h4(tau,tau')/tau', where
9877C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9878C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9879 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9880 CALL PYKLIM(4)
9881 IF(MINT(51).NE.0) THEN
9882 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9883 IF(MFAIL.EQ.1) THEN
9884 MSTI(61)=1
9885 RETURN
9886 ENDIF
9887 GOTO 100
9888 ENDIF
9889 RTAUP=PYR(0)
9890 MTAUP=1
9891 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9892 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9893 CALL PYKMAP(4,MTAUP,PYR(0))
9894 ENDIF
9895
9896C...Choose y* according to h2(y*), where
9897C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9898C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9899C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9900C...and c1 + c2 + c3 + c4 + c5 = 1.
9901 CALL PYKLIM(2)
9902 IF(MINT(51).NE.0) THEN
9903 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9904 IF(MFAIL.EQ.1) THEN
9905 MSTI(61)=1
9906 RETURN
9907 ENDIF
9908 GOTO 100
9909 ENDIF
9910 RYST=PYR(0)
9911 MYST=1
9912 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9913 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9914 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9915 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9916 & COEF(ISUB,11)) MYST=5
9917 CALL PYKMAP(2,MYST,PYR(0))
9918
9919C...2 -> 2 processes:
9920C...Choose cos(theta-hat) (cth) according to h3(cth), where
9921C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9922C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9923C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9924C...and c0 + c1 + c2 + c3 + c4 = 1.
9925 CALL PYKLIM(3)
9926 IF(MINT(51).NE.0) THEN
9927 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9928 IF(MFAIL.EQ.1) THEN
9929 MSTI(61)=1
9930 RETURN
9931 ENDIF
9932 GOTO 100
9933 ENDIF
9934 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9935 RCTH=PYR(0)
9936 MCTH=1
9937 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9938 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9939 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9940 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9941 & COEF(ISUB,16)) MCTH=5
9942 CALL PYKMAP(3,MCTH,PYR(0))
9943 ENDIF
9944
9945C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9946 IF(ISTSB.EQ.5) THEN
9947 CALL PYKMAP(5,0,0D0)
9948 IF(MINT(51).NE.0) THEN
9949 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9950 IF(MFAIL.EQ.1) THEN
9951 MSTI(61)=1
9952 RETURN
9953 ENDIF
9954 GOTO 100
9955 ENDIF
9956 ENDIF
9957
9958C...DIS as f + gamma* -> f process: set dummy values.
9959 ELSEIF(ISTSB.EQ.8) THEN
9960 VINT(21)=0.9D0
9961 VINT(22)=0D0
9962 VINT(23)=0D0
9963 VINT(47)=0D0
9964 VINT(48)=0D0
9965
9966C...Low-pT or multiple interactions (first semihard interaction).
9967 ELSEIF(ISTSB.EQ.9) THEN
9968 IF(MINT(35).LE.1) CALL PYMULT(3)
9969 IF(MINT(35).GE.2) CALL PYMIGN(3)
9970 ISUB=MINT(1)
9971
9972C...Study user-defined process: kinematics plus weight.
9973 ELSEIF(ISTSB.EQ.11) THEN
9974 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9975 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9976 MSTI(51)=0
9977 IF(NUP.LE.0) THEN
9978 MINT(51)=2
9979 MSTI(51)=1
9980 IF(MINT(82).EQ.1) THEN
9981 NGEN(0,1)=NGEN(0,1)-1
9982 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9983 ENDIF
9984 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9985 RETURN
9986 ENDIF
9987
9988C...Extract cross section event weight.
9989 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9990 SIGS=1D-9*XWGTUP
9991 ELSE
9992 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9993 ENDIF
9994 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9995 VINT(97)=SIGN(1D0,XWGTUP)
9996 ELSE
9997 VINT(97)=1D-9*XWGTUP
9998 ENDIF
9999
10000C...Construct 'trivial' kinematical variables needed.
10001 KFL1=IDUP(1)
10002 KFL2=IDUP(2)
10003 VINT(41)=PUP(4,1)/EBMUP(1)
10004 VINT(42)=PUP(4,2)/EBMUP(2)
10005 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10006 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10007 & '(listing follows):')
10008 CALL PYLIST(7)
10009 ENDIF
10010 VINT(21)=VINT(41)*VINT(42)
10011 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10012 VINT(44)=VINT(21)*VINT(2)
10013 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10014 VINT(55)=SCALUP
10015 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10016 VINT(56)=VINT(55)**2
10017 VINT(57)=AQEDUP
10018 VINT(58)=AQCDUP
10019
10020C...Construct other kinematical variables needed (approximately).
10021 VINT(23)=0D0
10022 VINT(26)=VINT(21)
10023 VINT(45)=-0.5D0*VINT(44)
10024 VINT(46)=-0.5D0*VINT(44)
10025 VINT(49)=VINT(43)
10026 VINT(50)=VINT(44)
10027 VINT(51)=VINT(55)
10028 VINT(52)=VINT(56)
10029 VINT(53)=VINT(55)
10030 VINT(54)=VINT(56)
10031 VINT(25)=0D0
10032 VINT(48)=0D0
10033 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10034 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10035 DO 280 IUP=3,NUP
10036 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10037 & '(PYRAND:) unacceptable ISTUP code for particles')
10038 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10039 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10040 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10041 & PUP(2,IUP)**2)
10042 280 CONTINUE
10043 VINT(47)=SQRT(VINT(48))
10044 ENDIF
10045
10046C...Choose azimuthal angle.
10047 VINT(24)=0D0
10048 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10049
10050C...Check against user cuts on kinematics at parton level.
10051 MINT(51)=0
10052 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10053 IF(MINT(51).NE.0) THEN
10054 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10055 IF(MFAIL.EQ.1) THEN
10056 MSTI(61)=1
10057 RETURN
10058 ENDIF
10059 GOTO 100
10060 ENDIF
10061 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10062 MCUT=0
10063 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10064 & CALL PYKCUT(MCUT)
10065 IF(MCUT.NE.0) THEN
10066 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10067 IF(MFAIL.EQ.1) THEN
10068 MSTI(61)=1
10069 RETURN
10070 ENDIF
10071 GOTO 100
10072 ENDIF
10073 ENDIF
10074
10075 IF(ISTSB.LE.10) THEN
10076C... If internal process, call PYSIGH
10077 CALL PYSIGH(NCHN,SIGS)
10078 ELSE
10079C... If external process, still have to set MI starting scale
10080 IF (MSTP(86).EQ.1) THEN
10081C... Limit phase space by xT2 of hard interaction
10082C... (gives undercounting of MI when ext proc != dijets)
10083 XT2GMX = VINT(25)
10084 ELSE
10085C... All accessible phase space allowed
10086C... (gives double counting of MI when ext proc = dijets)
10087 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10088 ENDIF
10089 VINT(62)=0.25D0*XT2GMX*VINT(2)
10090 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10091 ENDIF
10092
10093 SIGSOR=SIGS
10094 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10095
10096C...Multiply cross section by lepton -> photon flux factor.
10097 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10098 SIGS=WTGAGA*SIGS
10099 DO 290 ICHN=1,NCHN
10100 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10101 290 CONTINUE
10102 SIGLPT=WTGAGA*SIGLPT
10103 ENDIF
10104
10105C...Multiply cross-section by user-defined weights.
10106 IF(MSTP(173).EQ.1) THEN
10107 SIGS=PARP(173)*SIGS
10108 DO 300 ICHN=1,NCHN
10109 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10110 300 CONTINUE
10111 SIGLPT=PARP(173)*SIGLPT
10112 ENDIF
10113 WTXS=1D0
10114 SIGSWT=SIGS
10115 VINT(99)=1D0
10116 VINT(100)=1D0
10117 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10118 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10119 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10120 SIGSWT=WTXS*SIGS
10121 VINT(99)=WTXS
10122 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10123 ENDIF
10124
10125C...Calculations for Monte Carlo estimate of all cross-sections.
10126 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10127 IF(MSTP(142).LE.1) THEN
10128 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10129 ELSE
10130 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10131 ENDIF
10132 ELSEIF(MINT(82).EQ.1) THEN
10133 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10134 ENDIF
10135 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10136 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10137
10138C...Multiple interactions: store results of cross-section calculation.
10139 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10140 VINT(153)=SIGSOR
10141 IF(MINT(35).LE.1) CALL PYMULT(4)
10142 IF(MINT(35).GE.2) CALL PYMIGN(4)
10143 ENDIF
10144
10145C...Ratio of actual to maximum cross section.
10146 IF(ISTSB.NE.11) THEN
10147 VIOL=SIGSWT/XSEC(ISUB,1)
10148 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10149 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10150 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10151 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10152 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10153 ELSE
10154 VIOL=1D0
10155 ENDIF
10156
10157C...Check that weight not negative.
10158 IF(MSTP(123).LE.0) THEN
10159 IF(VIOL.LT.-1D-3) THEN
10160 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10161 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10162 & VINT(22),VINT(23),VINT(26)
10163 CALL PYSTOP(2)
10164 ENDIF
10165 ELSE
10166 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10167 VINT(109)=VIOL
10168 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10169 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10170 & VINT(22),VINT(23),VINT(26)
10171 ENDIF
10172 ENDIF
10173
10174C...Weighting using estimate of maximum of differential cross-section.
10175 RATND=1D0
10176 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10177 IF(VIOL.LT.PYR(0)) THEN
10178 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10179 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10180 GOTO 100
10181 ENDIF
10182 ELSEIF(MFAIL.EQ.0) THEN
10183 RATND=SIGLPT/XSEC(95,1)
10184 VIOL=VIOL/RATND
10185 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10186 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10187 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10188 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10189 ISUB=0
10190 GOTO 100
10191 ENDIF
10192 IF(VIOL.LT.PYR(0)) THEN
10193 GOTO 140
10194 ENDIF
10195 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10196 IF(VIOL.LT.PYR(0)) THEN
10197 MSTI(61)=1
10198 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10199 RETURN
10200 ENDIF
10201 ELSE
10202 RATND=SIGLPT/XSEC(95,1)
10203 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10204 MSTI(61)=1
10205 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10206 RETURN
10207 ENDIF
10208 VIOL=VIOL/RATND
10209 IF(VIOL.LT.PYR(0)) THEN
10210 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10211 GOTO 100
10212 ENDIF
10213 ENDIF
10214
10215C...Check for possible violation of estimated maximum of differential
10216C...cross-section used in weighting.
10217 IF(MSTP(123).LE.0) THEN
10218 IF(VIOL.GT.1D0) THEN
10219 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10220 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10221 & VINT(22),VINT(23),VINT(26)
10222 CALL PYSTOP(2)
10223 ENDIF
10224 ELSEIF(MSTP(123).EQ.1) THEN
10225 IF(VIOL.GT.VINT(108)) THEN
10226 VINT(108)=VIOL
10227 IF(VIOL.GT.1.0001D0) THEN
10228 MINT(10)=1
10229 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10230 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10231 & VINT(22),VINT(23),VINT(26)
10232 ENDIF
10233 ENDIF
10234 ELSEIF(VIOL.GT.VINT(108)) THEN
10235 VINT(108)=VIOL
10236 IF(VIOL.GT.1D0) THEN
10237 MINT(10)=1
10238 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10239 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10240 & THEN
10241 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10242 IF(KFPR(ISUB,1).LE.9) THEN
10243 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10244 & XMAXUP(KFPR(ISUB,1))
10245 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10246 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10247 & XMAXUP(KFPR(ISUB,1))
10248 ELSE
10249 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10250 & XMAXUP(KFPR(ISUB,1))
10251 ENDIF
10252 ENDIF
10253 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10254 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10255 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10256 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10257 & XSEC(0,1)=XSEC(0,1)+XDIF
10258 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10259 & VINT(22),VINT(23),VINT(26)
10260 IF(ISUB.LE.9) THEN
10261 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10262 ELSEIF(ISUB.LE.99) THEN
10263 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10264 ELSE
10265 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10266 ENDIF
10267 ENDIF
10268 VINT(108)=1D0
10269 ENDIF
10270 ENDIF
10271
10272C...Multiple interactions: choose impact parameter (if not already done).
10273 IF(MINT(39).EQ.0) VINT(148)=1D0
10274 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10275 &MSTP(82).GE.3) THEN
10276 IF(MINT(35).LE.1) CALL PYMULT(5)
10277 IF(MINT(35).GE.2) CALL PYMIGN(5)
10278 IF(VINT(150).LT.PYR(0)) THEN
10279 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10280 IF(MFAIL.EQ.1) THEN
10281 MSTI(61)=1
10282 RETURN
10283 ENDIF
10284 GOTO 100
10285 ENDIF
10286 ENDIF
10287 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10288 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10289 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10290 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10291 ENDIF
10292 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10293
10294C...Choose flavour of reacting partons (and subprocess).
10295 IF(ISTSB.GE.11) GOTO 320
10296 RSIGS=SIGS*PYR(0)
10297 QT2=VINT(48)
10298 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10299 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10300 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10301 &PYR(0).GT.RQQBAR)) THEN
10302 DO 310 ICHN=1,NCHN
10303 KFL1=ISIG(ICHN,1)
10304 KFL2=ISIG(ICHN,2)
10305 MINT(2)=ISIG(ICHN,3)
10306 RSIGS=RSIGS-SIGH(ICHN)
10307 IF(RSIGS.LE.0D0) GOTO 320
10308 310 CONTINUE
10309
10310C...Multiple interactions: choose qqbar preferentially at small pT.
10311 ELSEIF(ISUB.EQ.96) THEN
10312 MINT(105)=MINT(103)
10313 MINT(109)=MINT(107)
10314 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10315 MINT(105)=MINT(104)
10316 MINT(109)=MINT(108)
10317 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10318 MINT(1)=11
10319 MINT(2)=1
10320 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10321
10322C...Low-pT: choose string drawing configuration.
10323 ELSE
10324 KFL1=21
10325 KFL2=21
10326 RSIGS=6D0*PYR(0)
10327 MINT(2)=1
10328 IF(RSIGS.GT.1D0) MINT(2)=2
10329 IF(RSIGS.GT.2D0) MINT(2)=3
10330 ENDIF
10331
10332C...Reassign QCD process. Partons before initial state radiation.
10333 320 IF(MINT(2).GT.10) THEN
10334 MINT(1)=MINT(2)/10
10335 MINT(2)=MOD(MINT(2),10)
10336 ENDIF
10337 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10338 &NGEN(MINT(1),2)+1
10339 MINT(15)=KFL1
10340 MINT(16)=KFL2
10341 MINT(13)=MINT(15)
10342 MINT(14)=MINT(16)
10343 VINT(141)=VINT(41)
10344 VINT(142)=VINT(42)
10345 VINT(151)=0D0
10346 VINT(152)=0D0
10347
10348C...Calculate x value of photon for parton inside photon inside e.
10349 DO 350 JT=1,2
10350 MINT(18+JT)=0
10351 VINT(154+JT)=0D0
10352 MSPLI=0
10353 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10354 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10355 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10356 IF(MSPLI.EQ.2) THEN
10357 KFLH=MINT(14+JT)
10358 XHRD=VINT(140+JT)
10359 Q2HRD=VINT(54)
10360 MINT(105)=MINT(102+JT)
10361 MINT(109)=MINT(106+JT)
10362 VINT(120)=VINT(2+JT)
10363C.... ALICE
10364C.... Store side in MINT(124)
10365 MINT(124) = JT
10366C....
10367 IF(MSTP(57).LE.1) THEN
10368 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10369 ELSE
10370 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10371 ENDIF
10372 WTMX=4D0*XPQ(KFLH)
10373 IF(MSTP(13).EQ.2) THEN
10374 Q2PMS=Q2HRD/PMAS(11,1)**2
10375 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10376 ENDIF
10377 330 XE=XHRD**PYR(0)
10378 XG=MIN(1D0-1D-10,XHRD/XE)
10379 IF(MSTP(57).LE.1) THEN
10380 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10381 ELSE
10382 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10383 ENDIF
10384 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10385 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10386 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10387 MINT(18+JT)=1
10388 VINT(154+JT)=XE
10389 DO 340 KFLS=-25,25
10390 XSFX(JT,KFLS)=XPQ(KFLS)
10391 340 CONTINUE
10392 ENDIF
10393 350 CONTINUE
10394
10395C...Pick scale where photon is resolved.
10396 Q0S=PARP(15)**2
10397 Q1S=VINT(154)**2
10398 VINT(283)=0D0
10399 IF(MINT(107).EQ.3) THEN
10400 IF(MSTP(66).EQ.1) THEN
10401 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10402 ELSEIF(MSTP(66).EQ.2) THEN
10403 PS=VINT(3)**2
10404 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10405 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10406 Q2INT=SQRT(Q0S*Q2EFF)
10407 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10408 ELSEIF(MSTP(66).EQ.3) THEN
10409 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10410 ELSEIF(MSTP(66).GE.4) THEN
10411 PS=0.25D0*VINT(3)**2
10412 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10413 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10414 ENDIF
10415 ENDIF
10416 VINT(284)=0D0
10417 IF(MINT(108).EQ.3) THEN
10418 IF(MSTP(66).EQ.1) THEN
10419 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10420 ELSEIF(MSTP(66).EQ.2) THEN
10421 PS=VINT(4)**2
10422 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10423 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10424 Q2INT=SQRT(Q0S*Q2EFF)
10425 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10426 ELSEIF(MSTP(66).EQ.3) THEN
10427 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10428 ELSEIF(MSTP(66).GE.4) THEN
10429 PS=0.25D0*VINT(4)**2
10430 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10431 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10432 ENDIF
10433 ENDIF
10434 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10435
10436C...Format statements for differential cross-section maximum violations.
10437 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10438 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10439 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10440 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10441 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10442 &'in event',1X,I7)
10443 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10444 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10445 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10446 &'in event',1X,I7)
10447 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10448 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10449 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10450 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10451 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10452 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10453
10454 RETURN
10455 END
10456
10457C*********************************************************************
10458
10459C...PYSCAT
10460C...Finds outgoing flavours and event type; sets up the kinematics
10461C...and colour flow of the hard scattering
10462
10463 SUBROUTINE PYSCAT
10464
10465C...Double precision and integer declarations
10466 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10467 IMPLICIT INTEGER(I-N)
10468 INTEGER PYK,PYCHGE,PYCOMP
10469C...Parameter statement to help give large particle numbers.
10470 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10471 &KEXCIT=4000000,KDIMEN=5000000)
10472C...Parameter statement for maximum size of showers.
10473 PARAMETER (MAXNUR=1000)
10474
10475C...User process event common block.
10476 INTEGER MAXNUP
10477 PARAMETER (MAXNUP=500)
10478 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10479 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10480 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10481 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10482 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10483 SAVE /HEPEUP/
10484
10485C...Commonblocks.
10486 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10487 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10489 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10490 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10491 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10492 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10493 COMMON/PYINT1/MINT(400),VINT(400)
10494 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10495 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10496 COMMON/PYINT4/MWID(500),WIDS(500,5)
10497 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10498 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10499 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10500 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10501 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10502 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10503 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10504 &/PYTCSM/,/PYPUED/
10505C...Local arrays and saved variables
10506 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10507 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10508 INTEGER IOKFLA(6),IIFLAV
10509C...UED related declarations:
10510C...equivalences between ordered particles (451->475)
10511C...and UED particle code (5 000 000 + id)
10512 DIMENSION IUEDEQ(475),MUED(2)
10513 DATA (IUEDEQ(I),I=451,475)/
10514 & 6100001,6100002,6100003,6100004,6100005,6100006,
10515 & 5100001,5100002,5100003,5100004,5100005,5100006,
10516 & 6100011,6100013,6100015,
10517 & 5100012,5100011,5100014,5100013,5100016,5100015,
10518 & 5100021,5100022,5100023,5100024/
10519 SAVE VINTSV
10520
10521C...Read out process
10522 ISUB=MINT(1)
10523 ISUBSV=ISUB
10524
10525C...Restore information for low-pT processes
10526 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10527 DO 100 J=41,66
10528 100 VINT(J)=VINTSV(J)
10529 ENDIF
10530
10531C...Convert H' or A process into equivalent H one
10532 IHIGG=1
10533 KFHIGG=25
10534 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10535 &ISUB.LE.190)) THEN
10536 IHIGG=2
10537 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10538 KFHIGG=33+IHIGG
10539 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10540 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10541 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10542 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10543 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10544 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10545 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10546 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10547 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10548 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10549 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10550 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10551 ENDIF
10552
10553 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10554
10555C...Convert bottomonium process into equivalent charmonium ones.
10556 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10557
10558C...Choice of subprocess, number of documentation lines
10559 IDOC=6+ISET(ISUB)
10560 IF(ISUB.EQ.95) IDOC=8
10561 IF(ISET(ISUB).EQ.5) IDOC=9
10562 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10563 MINT(3)=IDOC-6
10564 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10565 MINT(4)=IDOC
10566 IPU1=MINT(84)+1
10567 IPU2=MINT(84)+2
10568 IPU3=MINT(84)+3
10569 IPU4=MINT(84)+4
10570 IPU5=MINT(84)+5
10571 IPU6=MINT(84)+6
10572
10573C...Reset K, P and V vectors. Store incoming particles
10574 DO 120 JT=1,MSTP(126)+100
10575 I=MINT(83)+JT
10576 IF(I.GT.MSTU(4)) GOTO 120
10577 DO 110 J=1,5
10578 K(I,J)=0
10579 P(I,J)=0D0
10580 V(I,J)=0D0
10581 110 CONTINUE
10582 120 CONTINUE
10583 DO 140 JT=1,2
10584 I=MINT(83)+JT
10585 K(I,1)=21
10586 K(I,2)=MINT(10+JT)
10587 DO 130 J=1,5
10588 P(I,J)=VINT(285+5*JT+J)
10589 130 CONTINUE
10590 140 CONTINUE
10591 MINT(6)=2
10592 KFRES=0
10593
10594C...Store incoming partons in their CM-frame. Save pdf value.
10595 SH=VINT(44)
10596 SHR=SQRT(SH)
10597 SHP=VINT(26)*VINT(2)
10598 SHPR=SQRT(SHP)
10599 SHUSER=SHR
10600 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10601 DO 150 JT=1,2
10602 I=MINT(84)+JT
10603 K(I,1)=14
10604 K(I,2)=MINT(14+JT)
10605 K(I,3)=MINT(83)+2+JT
10606 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10607 P(I,4)=0.5D0*SHUSER
10608 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10609 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10610 ELSE
10611 VINT(38+JT)=1D0
10612 ENDIF
10613 150 CONTINUE
10614
10615C...Copy incoming partons to documentation lines
10616 DO 170 JT=1,2
10617 I1=MINT(83)+4+JT
10618 I2=MINT(84)+JT
10619 K(I1,1)=21
10620 K(I1,2)=K(I2,2)
10621 K(I1,3)=I1-2
10622 DO 160 J=1,5
10623 P(I1,J)=P(I2,J)
10624 160 CONTINUE
10625 170 CONTINUE
10626
10627C...Choose new quark/lepton flavour for relevant annihilation graphs
10628 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10629 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10630 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10631 IGLGA=21
10632 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10633 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10634 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10635 DO 190 I=1,MDCY(IGLGA,3)
10636 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10637 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10638 IF(RKFL.LE.0D0) GOTO 200
10639 190 CONTINUE
10640 200 CONTINUE
10641 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10642 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10643 IF(KFLF.GE.4) GOTO 180
10644 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10645 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10646 KFLF=4
10647 MINT(2)=MINT(2)-2
10648 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10649 & OR.ISUB.EQ.316) THEN
10650 KFLF=5
10651 MINT(2)=MINT(2)-4
10652 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10653 & .AND.IABS(KFLF).GE.3) THEN
10654 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10655 & VINT(44)**2
10656 FACCIB=VINT(46)**2/RTCM(41)**4
10657 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10658 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10659 KFLF=5
10660 MINT(2)=1
10661 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10662 IF(KFLF.EQ.5) GOTO 180
10663 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10664 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10665 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10666 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10667 ENDIF
10668 ENDIF
10669
10670C...Final state flavours and colour flow: default values
10671 JS=1
10672 MINT(21)=MINT(15)
10673 MINT(22)=MINT(16)
10674 MINT(23)=0
10675 MINT(24)=0
10676 KCC=20
10677 KCS=ISIGN(1,MINT(15))
10678
10679 IF(ISET(ISUB).EQ.11) THEN
10680C...User-defined processes: find products
10681 MINT(3)=0
10682 DO 210 IUP=3,NUP
10683 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10684 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10685 MINT(21+IUP)=IDUP(IUP)
10686 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10687 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10688 ELSEIF(IDUP(IUP).EQ.0) THEN
10689 ELSE
10690 MINT(3)=MINT(3)+1
10691 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10692 ENDIF
10693 210 CONTINUE
10694
10695 ELSEIF(ISUB.LE.10) THEN
10696 IF(ISUB.EQ.1) THEN
10697C...f + fbar -> gamma*/Z0
10698 KFRES=23
10699
10700 ELSEIF(ISUB.EQ.2) THEN
10701C...f + fbar' -> W+/-
10702 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10703 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10704 KFRES=ISIGN(24,KCH1+KCH2)
10705
10706 ELSEIF(ISUB.EQ.3) THEN
10707C...f + fbar -> h0 (or H0, or A0)
10708 KFRES=KFHIGG
10709
10710 ELSEIF(ISUB.EQ.4) THEN
10711C...gamma + W+/- -> W+/-
10712
10713 ELSEIF(ISUB.EQ.5) THEN
10714C...Z0 + Z0 -> h0
10715 XH=SH/SHP
10716 MINT(21)=MINT(15)
10717 MINT(22)=MINT(16)
10718 PMQ(1)=PYMASS(MINT(21))
10719 PMQ(2)=PYMASS(MINT(22))
10720 220 JT=INT(1.5D0+PYR(0))
10721 ZMIN=2D0*PMQ(JT)/SHPR
10722 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10723 & (SHPR*(SHPR-PMQ(3-JT)))
10724 ZMAX=MIN(1D0-XH,ZMAX)
10725 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10726 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10727 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10728 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10729 IF(SQC1.LT.1D-8) GOTO 220
10730 C1=SQRT(SQC1)
10731 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10732 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10733 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10734 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10735 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10736 IF(SQC1.LT.1D-8) GOTO 220
10737 C1=SQRT(SQC1)
10738 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10739 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10740 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10741 PHIR=PARU(2)*PYR(0)
10742 CPHI=COS(PHIR)
10743 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10744 & SQRT(1D0-CTHE(2)**2)*CPHI
10745 Z1=2D0-Z(JT)
10746 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10747 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10748 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10749 & PMQ(3-JT)**2/SHP))
10750 ZMIN=2D0*PMQ(3-JT)/SHPR
10751 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10752 ZMAX=MIN(1D0-XH,ZMAX)
10753 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10754 KCC=22
10755 KFRES=25
10756
10757 ELSEIF(ISUB.EQ.6) THEN
10758C...Z0 + W+/- -> W+/-
10759
10760 ELSEIF(ISUB.EQ.7) THEN
10761C...W+ + W- -> Z0
10762
10763 ELSEIF(ISUB.EQ.8) THEN
10764C...W+ + W- -> h0
10765 XH=SH/SHP
10766 230 DO 260 JT=1,2
10767 I=MINT(14+JT)
10768 IA=IABS(I)
10769 IF(IA.LE.10) THEN
10770 RVCKM=VINT(180+I)*PYR(0)
10771 DO 240 J=1,MSTP(1)
10772 IB=2*J-1+MOD(IA,2)
10773 IPM=(5-ISIGN(1,I))/2
10774 IDC=J+MDCY(IA,2)+2
10775 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10776 MINT(20+JT)=ISIGN(IB,I)
10777 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10778 IF(RVCKM.LE.0D0) GOTO 250
10779 240 CONTINUE
10780 ELSE
10781 IB=2*((IA+1)/2)-1+MOD(IA,2)
10782 MINT(20+JT)=ISIGN(IB,I)
10783 ENDIF
10784 250 PMQ(JT)=PYMASS(MINT(20+JT))
10785 260 CONTINUE
10786 JT=INT(1.5D0+PYR(0))
10787 ZMIN=2D0*PMQ(JT)/SHPR
10788 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10789 & (SHPR*(SHPR-PMQ(3-JT)))
10790 ZMAX=MIN(1D0-XH,ZMAX)
10791 IF(ZMIN.GE.ZMAX) GOTO 230
10792 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10793 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10794 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10795 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10796 IF(SQC1.LT.1D-8) GOTO 230
10797 C1=SQRT(SQC1)
10798 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10799 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10800 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10801 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10802 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10803 IF(SQC1.LT.1D-8) GOTO 230
10804 C1=SQRT(SQC1)
10805 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10806 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10807 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10808 PHIR=PARU(2)*PYR(0)
10809 CPHI=COS(PHIR)
10810 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10811 & SQRT(1D0-CTHE(2)**2)*CPHI
10812 Z1=2D0-Z(JT)
10813 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10814 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10815 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10816 & PMQ(3-JT)**2/SHP))
10817 ZMIN=2D0*PMQ(3-JT)/SHPR
10818 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10819 ZMAX=MIN(1D0-XH,ZMAX)
10820 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10821 KCC=22
10822 KFRES=25
10823
10824 ELSEIF(ISUB.EQ.10) THEN
10825C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10826 IF(MINT(2).EQ.1) THEN
10827 KCC=22
10828 ELSE
10829C...W exchange: need to mix flavours according to CKM matrix
10830 DO 280 JT=1,2
10831 I=MINT(14+JT)
10832 IA=IABS(I)
10833 IF(IA.LE.10) THEN
10834 RVCKM=VINT(180+I)*PYR(0)
10835 DO 270 J=1,MSTP(1)
10836 IB=2*J-1+MOD(IA,2)
10837 IPM=(5-ISIGN(1,I))/2
10838 IDC=J+MDCY(IA,2)+2
10839 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10840 MINT(20+JT)=ISIGN(IB,I)
10841 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10842 IF(RVCKM.LE.0D0) GOTO 280
10843 270 CONTINUE
10844 ELSE
10845 IB=2*((IA+1)/2)-1+MOD(IA,2)
10846 MINT(20+JT)=ISIGN(IB,I)
10847 ENDIF
10848 280 CONTINUE
10849 KCC=22
10850 ENDIF
10851 ENDIF
10852
10853 ELSEIF(ISUB.LE.20) THEN
10854 IF(ISUB.EQ.11) THEN
10855C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10856 KCC=MINT(2)
10857 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10858
10859 ELSEIF(ISUB.EQ.12) THEN
10860C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10861 MINT(21)=ISIGN(KFLF,MINT(15))
10862 MINT(22)=-MINT(21)
10863 KCC=4
10864
10865 ELSEIF(ISUB.EQ.13) THEN
10866C...f + fbar -> g + g; th arbitrary
10867 MINT(21)=21
10868 MINT(22)=21
10869 KCC=MINT(2)+4
10870
10871 ELSEIF(ISUB.EQ.14) THEN
10872C...f + fbar -> g + gamma; th arbitrary
10873 IF(PYR(0).GT.0.5D0) JS=2
10874 MINT(20+JS)=21
10875 MINT(23-JS)=22
10876 KCC=17+JS
10877
10878 ELSEIF(ISUB.EQ.15) THEN
10879C...f + fbar -> g + Z0; th arbitrary
10880 IF(PYR(0).GT.0.5D0) JS=2
10881 MINT(20+JS)=21
10882 MINT(23-JS)=23
10883 KCC=17+JS
10884
10885 ELSEIF(ISUB.EQ.16) THEN
10886C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10887 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10888 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10889 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10890 MINT(20+JS)=21
10891 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10892 KCC=17+JS
10893
10894 ELSEIF(ISUB.EQ.17) THEN
10895C...f + fbar -> g + h0; th arbitrary
10896 IF(PYR(0).GT.0.5D0) JS=2
10897 MINT(20+JS)=21
10898 MINT(23-JS)=25
10899 KCC=17+JS
10900
10901 ELSEIF(ISUB.EQ.18) THEN
10902C...f + fbar -> gamma + gamma; th arbitrary
10903 MINT(21)=22
10904 MINT(22)=22
10905
10906 ELSEIF(ISUB.EQ.19) THEN
10907C...f + fbar -> gamma + Z0; th arbitrary
10908 IF(PYR(0).GT.0.5D0) JS=2
10909 MINT(20+JS)=22
10910 MINT(23-JS)=23
10911
10912 ELSEIF(ISUB.EQ.20) THEN
10913C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10914C...(p(fbar')-p(W+))**2
10915 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10916 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10917 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10918 MINT(20+JS)=22
10919 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10920 ENDIF
10921
10922 ELSEIF(ISUB.LE.30) THEN
10923 IF(ISUB.EQ.21) THEN
10924C...f + fbar -> gamma + h0; th arbitrary
10925 IF(PYR(0).GT.0.5D0) JS=2
10926 MINT(20+JS)=22
10927 MINT(23-JS)=25
10928
10929 ELSEIF(ISUB.EQ.22) THEN
10930C...f + fbar -> Z0 + Z0; th arbitrary
10931 MINT(21)=23
10932 MINT(22)=23
10933
10934 ELSEIF(ISUB.EQ.23) THEN
10935C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10936 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10937 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10938 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10939 MINT(20+JS)=23
10940 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10941
10942 ELSEIF(ISUB.EQ.24) THEN
10943C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10944 IF(PYR(0).GT.0.5D0) JS=2
10945 MINT(20+JS)=23
10946 MINT(23-JS)=KFHIGG
10947
10948 ELSEIF(ISUB.EQ.25) THEN
10949C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10950 MINT(21)=-ISIGN(24,MINT(15))
10951 MINT(22)=-MINT(21)
10952
10953 ELSEIF(ISUB.EQ.26) THEN
10954C...f + fbar' -> W+/- + h0 (or H0, or A0);
10955C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10957 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10958 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10959 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10960 MINT(23-JS)=KFHIGG
10961
10962 ELSEIF(ISUB.EQ.27) THEN
10963C...f + fbar -> h0 + h0
10964
10965 ELSEIF(ISUB.EQ.28) THEN
10966C...f + g -> f + g; th = (p(f)-p(f))**2
10967 IF(MINT(15).EQ.21) JS=2
10968 KCC=MINT(2)+6
10969 IF(MINT(15).EQ.21) KCC=KCC+2
10970 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10971 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10972
10973 ELSEIF(ISUB.EQ.29) THEN
10974C...f + g -> f + gamma; th = (p(f)-p(f))**2
10975 IF(MINT(15).EQ.21) JS=2
10976 MINT(23-JS)=22
10977 KCC=15+JS
10978 KCS=ISIGN(1,MINT(14+JS))
10979
10980 ELSEIF(ISUB.EQ.30) THEN
10981C...f + g -> f + Z0; th = (p(f)-p(f))**2
10982 IF(MINT(15).EQ.21) JS=2
10983 MINT(23-JS)=23
10984 KCC=15+JS
10985 KCS=ISIGN(1,MINT(14+JS))
10986 ENDIF
10987
10988 ELSEIF(ISUB.LE.40) THEN
10989 IF(ISUB.EQ.31) THEN
10990C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10991 IF(MINT(15).EQ.21) JS=2
10992 I=MINT(14+JS)
10993 IA=IABS(I)
10994 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10995 RVCKM=VINT(180+I)*PYR(0)
10996 DO 290 J=1,MSTP(1)
10997 IB=2*J-1+MOD(IA,2)
10998 IPM=(5-ISIGN(1,I))/2
10999 IDC=J+MDCY(IA,2)+2
11000 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11001 MINT(20+JS)=ISIGN(IB,I)
11002 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11003 IF(RVCKM.LE.0D0) GOTO 300
11004 290 CONTINUE
11005 300 KCC=15+JS
11006 KCS=ISIGN(1,MINT(14+JS))
11007
11008 ELSEIF(ISUB.EQ.32) THEN
11009C...f + g -> f + h0; th = (p(f)-p(f))**2
11010 IF(MINT(15).EQ.21) JS=2
11011 MINT(23-JS)=25
11012 KCC=15+JS
11013 KCS=ISIGN(1,MINT(14+JS))
11014
11015 ELSEIF(ISUB.EQ.33) THEN
11016C...f + gamma -> f + g; th=(p(f)-p(f))**2
11017 IF(MINT(15).EQ.22) JS=2
11018 MINT(23-JS)=21
11019 KCC=24+JS
11020 KCS=ISIGN(1,MINT(14+JS))
11021
11022 ELSEIF(ISUB.EQ.34) THEN
11023C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11024 IF(MINT(15).EQ.22) JS=2
11025 KCC=22
11026 KCS=ISIGN(1,MINT(14+JS))
11027
11028 ELSEIF(ISUB.EQ.35) THEN
11029C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11030 IF(MINT(15).EQ.22) JS=2
11031 MINT(23-JS)=23
11032 KCC=22
11033
11034 ELSEIF(ISUB.EQ.36) THEN
11035C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11036 IF(MINT(15).EQ.22) JS=2
11037 I=MINT(14+JS)
11038 IA=IABS(I)
11039 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11040 IF(IA.LE.10) THEN
11041 RVCKM=VINT(180+I)*PYR(0)
11042 DO 310 J=1,MSTP(1)
11043 IB=2*J-1+MOD(IA,2)
11044 IPM=(5-ISIGN(1,I))/2
11045 IDC=J+MDCY(IA,2)+2
11046 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11047 MINT(20+JS)=ISIGN(IB,I)
11048 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11049 IF(RVCKM.LE.0D0) GOTO 320
11050 310 CONTINUE
11051 ELSE
11052 IB=2*((IA+1)/2)-1+MOD(IA,2)
11053 MINT(20+JS)=ISIGN(IB,I)
11054 ENDIF
11055 320 KCC=22
11056
11057 ELSEIF(ISUB.EQ.37) THEN
11058C...f + gamma -> f + h0
11059
11060 ELSEIF(ISUB.EQ.38) THEN
11061C...f + Z0 -> f + g
11062
11063 ELSEIF(ISUB.EQ.39) THEN
11064C...f + Z0 -> f + gamma
11065
11066 ELSEIF(ISUB.EQ.40) THEN
11067C...f + Z0 -> f + Z0
11068 ENDIF
11069
11070 ELSEIF(ISUB.LE.50) THEN
11071 IF(ISUB.EQ.41) THEN
11072C...f + Z0 -> f' + W+/-
11073
11074 ELSEIF(ISUB.EQ.42) THEN
11075C...f + Z0 -> f + h0
11076
11077 ELSEIF(ISUB.EQ.43) THEN
11078C...f + W+/- -> f' + g
11079
11080 ELSEIF(ISUB.EQ.44) THEN
11081C...f + W+/- -> f' + gamma
11082
11083 ELSEIF(ISUB.EQ.45) THEN
11084C...f + W+/- -> f' + Z0
11085
11086 ELSEIF(ISUB.EQ.46) THEN
11087C...f + W+/- -> f' + W+/-
11088
11089 ELSEIF(ISUB.EQ.47) THEN
11090C...f + W+/- -> f' + h0
11091
11092 ELSEIF(ISUB.EQ.48) THEN
11093C...f + h0 -> f + g
11094
11095 ELSEIF(ISUB.EQ.49) THEN
11096C...f + h0 -> f + gamma
11097
11098 ELSEIF(ISUB.EQ.50) THEN
11099C...f + h0 -> f + Z0
11100 ENDIF
11101
11102 ELSEIF(ISUB.LE.60) THEN
11103 IF(ISUB.EQ.51) THEN
11104C...f + h0 -> f' + W+/-
11105
11106 ELSEIF(ISUB.EQ.52) THEN
11107C...f + h0 -> f + h0
11108
11109 ELSEIF(ISUB.EQ.53) THEN
11110C...g + g -> f + fbar; th arbitrary
11111 KCS=(-1)**INT(1.5D0+PYR(0))
11112 MINT(21)=ISIGN(KFLF,KCS)
11113 MINT(22)=-MINT(21)
11114 KCC=MINT(2)+10
11115
11116 ELSEIF(ISUB.EQ.54) THEN
11117C...g + gamma -> f + fbar; th arbitrary
11118 KCS=(-1)**INT(1.5D0+PYR(0))
11119 MINT(21)=ISIGN(KFLF,KCS)
11120 MINT(22)=-MINT(21)
11121 KCC=27
11122 IF(MINT(16).EQ.21) KCC=28
11123
11124 ELSEIF(ISUB.EQ.55) THEN
11125C...g + Z0 -> f + fbar
11126
11127 ELSEIF(ISUB.EQ.56) THEN
11128C...g + W+/- -> f + fbar'
11129
11130 ELSEIF(ISUB.EQ.57) THEN
11131C...g + h0 -> f + fbar
11132
11133 ELSEIF(ISUB.EQ.58) THEN
11134C...gamma + gamma -> f + fbar; th arbitrary
11135 KCS=(-1)**INT(1.5D0+PYR(0))
11136 MINT(21)=ISIGN(KFLF,KCS)
11137 MINT(22)=-MINT(21)
11138 KCC=21
11139
11140 ELSEIF(ISUB.EQ.59) THEN
11141C...gamma + Z0 -> f + fbar
11142
11143 ELSEIF(ISUB.EQ.60) THEN
11144C...gamma + W+/- -> f + fbar'
11145 ENDIF
11146
11147 ELSEIF(ISUB.LE.70) THEN
11148 IF(ISUB.EQ.61) THEN
11149C...gamma + h0 -> f + fbar
11150
11151 ELSEIF(ISUB.EQ.62) THEN
11152C...Z0 + Z0 -> f + fbar
11153
11154 ELSEIF(ISUB.EQ.63) THEN
11155C...Z0 + W+/- -> f + fbar'
11156
11157 ELSEIF(ISUB.EQ.64) THEN
11158C...Z0 + h0 -> f + fbar
11159
11160 ELSEIF(ISUB.EQ.65) THEN
11161C...W+ + W- -> f + fbar
11162
11163 ELSEIF(ISUB.EQ.66) THEN
11164C...W+/- + h0 -> f + fbar'
11165
11166 ELSEIF(ISUB.EQ.67) THEN
11167C...h0 + h0 -> f + fbar
11168
11169 ELSEIF(ISUB.EQ.68) THEN
11170C...g + g -> g + g; th arbitrary
11171 KCC=MINT(2)+12
11172 KCS=(-1)**INT(1.5D0+PYR(0))
11173
11174 ELSEIF(ISUB.EQ.69) THEN
11175C...gamma + gamma -> W+ + W-; th arbitrary
11176 MINT(21)=24
11177 MINT(22)=-24
11178 KCC=21
11179
11180 ELSEIF(ISUB.EQ.70) THEN
11181C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11182 IF(MINT(15).EQ.22) MINT(21)=23
11183 IF(MINT(16).EQ.22) MINT(22)=23
11184 KCC=21
11185 ENDIF
11186
11187 ELSEIF(ISUB.LE.80) THEN
11188 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11189C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11190 XH=SH/SHP
11191 MINT(21)=MINT(15)
11192 MINT(22)=MINT(16)
11193 PMQ(1)=PYMASS(MINT(21))
11194 PMQ(2)=PYMASS(MINT(22))
11195 330 JT=INT(1.5D0+PYR(0))
11196 ZMIN=2D0*PMQ(JT)/SHPR
11197 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11198 & (SHPR*(SHPR-PMQ(3-JT)))
11199 ZMAX=MIN(1D0-XH,ZMAX)
11200 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11201 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11202 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11203 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11204 IF(SQC1.LT.1D-8) GOTO 330
11205 C1=SQRT(SQC1)
11206 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11207 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11208 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11209 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11210 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11211 IF(SQC1.LT.1D-8) GOTO 330
11212 C1=SQRT(SQC1)
11213 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11214 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11215 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11216 PHIR=PARU(2)*PYR(0)
11217 CPHI=COS(PHIR)
11218 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11219 & SQRT(1D0-CTHE(2)**2)*CPHI
11220 Z1=2D0-Z(JT)
11221 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11222 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11223 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11224 & PMQ(3-JT)**2/SHP))
11225 ZMIN=2D0*PMQ(3-JT)/SHPR
11226 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11227 ZMAX=MIN(1D0-XH,ZMAX)
11228 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11229 KCC=22
11230
11231 ELSEIF(ISUB.EQ.73) THEN
11232C...Z0 + W+/- -> Z0 + W+/-
11233 JS=MINT(2)
11234 XH=SH/SHP
11235 340 JT=3-MINT(2)
11236 I=MINT(14+JT)
11237 IA=IABS(I)
11238 IF(IA.LE.10) THEN
11239 RVCKM=VINT(180+I)*PYR(0)
11240 DO 350 J=1,MSTP(1)
11241 IB=2*J-1+MOD(IA,2)
11242 IPM=(5-ISIGN(1,I))/2
11243 IDC=J+MDCY(IA,2)+2
11244 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11245 MINT(20+JT)=ISIGN(IB,I)
11246 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11247 IF(RVCKM.LE.0D0) GOTO 360
11248 350 CONTINUE
11249 ELSE
11250 IB=2*((IA+1)/2)-1+MOD(IA,2)
11251 MINT(20+JT)=ISIGN(IB,I)
11252 ENDIF
11253 360 PMQ(JT)=PYMASS(MINT(20+JT))
11254 MINT(23-JT)=MINT(17-JT)
11255 PMQ(3-JT)=PYMASS(MINT(23-JT))
11256 JT=INT(1.5D0+PYR(0))
11257 ZMIN=2D0*PMQ(JT)/SHPR
11258 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11259 & (SHPR*(SHPR-PMQ(3-JT)))
11260 ZMAX=MIN(1D0-XH,ZMAX)
11261 IF(ZMIN.GE.ZMAX) GOTO 340
11262 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11263 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11264 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11265 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11266 IF(SQC1.LT.1D-8) GOTO 340
11267 C1=SQRT(SQC1)
11268 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11269 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11270 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11271 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11272 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11273 IF(SQC1.LT.1D-8) GOTO 340
11274 C1=SQRT(SQC1)
11275 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11276 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11277 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11278 PHIR=PARU(2)*PYR(0)
11279 CPHI=COS(PHIR)
11280 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11281 & SQRT(1D0-CTHE(2)**2)*CPHI
11282 Z1=2D0-Z(JT)
11283 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11284 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11285 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11286 & PMQ(3-JT)**2/SHP))
11287 ZMIN=2D0*PMQ(3-JT)/SHPR
11288 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11289 ZMAX=MIN(1D0-XH,ZMAX)
11290 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11291 KCC=22
11292
11293 ELSEIF(ISUB.EQ.74) THEN
11294C...Z0 + h0 -> Z0 + h0
11295
11296 ELSEIF(ISUB.EQ.75) THEN
11297C...W+ + W- -> gamma + gamma
11298
11299 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11300C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11301 XH=SH/SHP
11302 370 DO 400 JT=1,2
11303 I=MINT(14+JT)
11304 IA=IABS(I)
11305 IF(IA.LE.10) THEN
11306 RVCKM=VINT(180+I)*PYR(0)
11307 DO 380 J=1,MSTP(1)
11308 IB=2*J-1+MOD(IA,2)
11309 IPM=(5-ISIGN(1,I))/2
11310 IDC=J+MDCY(IA,2)+2
11311 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11312 MINT(20+JT)=ISIGN(IB,I)
11313 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11314 IF(RVCKM.LE.0D0) GOTO 390
11315 380 CONTINUE
11316 ELSE
11317 IB=2*((IA+1)/2)-1+MOD(IA,2)
11318 MINT(20+JT)=ISIGN(IB,I)
11319 ENDIF
11320 390 PMQ(JT)=PYMASS(MINT(20+JT))
11321 400 CONTINUE
11322 JT=INT(1.5D0+PYR(0))
11323 ZMIN=2D0*PMQ(JT)/SHPR
11324 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11325 & (SHPR*(SHPR-PMQ(3-JT)))
11326 ZMAX=MIN(1D0-XH,ZMAX)
11327 IF(ZMIN.GE.ZMAX) GOTO 370
11328 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11329 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11330 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11331 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11332 IF(SQC1.LT.1D-8) GOTO 370
11333 C1=SQRT(SQC1)
11334 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11335 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11336 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11337 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11338 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11339 IF(SQC1.LT.1D-8) GOTO 370
11340 C1=SQRT(SQC1)
11341 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11342 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11343 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11344 PHIR=PARU(2)*PYR(0)
11345 CPHI=COS(PHIR)
11346 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11347 & SQRT(1D0-CTHE(2)**2)*CPHI
11348 Z1=2D0-Z(JT)
11349 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11350 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11351 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11352 & PMQ(3-JT)**2/SHP))
11353 ZMIN=2D0*PMQ(3-JT)/SHPR
11354 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11355 ZMAX=MIN(1D0-XH,ZMAX)
11356 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11357 KCC=22
11358
11359 ELSEIF(ISUB.EQ.78) THEN
11360C...W+/- + h0 -> W+/- + h0
11361
11362 ELSEIF(ISUB.EQ.79) THEN
11363C...h0 + h0 -> h0 + h0
11364
11365 ELSEIF(ISUB.EQ.80) THEN
11366C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11367 IF(MINT(15).EQ.22) JS=2
11368 I=MINT(14+JS)
11369 IA=IABS(I)
11370 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11371 IB=3-IA
11372 MINT(20+JS)=ISIGN(IB,I)
11373 KCC=22
11374 ENDIF
11375
11376 ELSEIF(ISUB.LE.90) THEN
11377 IF(ISUB.EQ.81) THEN
11378C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11379 MINT(21)=ISIGN(MINT(55),MINT(15))
11380 MINT(22)=-MINT(21)
11381 KCC=4
11382
11383 ELSEIF(ISUB.EQ.82) THEN
11384C...g + g -> Q + Qbar; th arbitrary
11385 KCS=(-1)**INT(1.5D0+PYR(0))
11386 MINT(21)=ISIGN(MINT(55),KCS)
11387 MINT(22)=-MINT(21)
11388 KCC=MINT(2)+10
11389
11390 ELSEIF(ISUB.EQ.83) THEN
11391C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11392 KFOLD=MINT(16)
11393 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11394 KFAOLD=IABS(KFOLD)
11395 IF(KFAOLD.GT.10) THEN
11396 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11397 ELSE
11398 RCKM=VINT(180+KFOLD)*PYR(0)
11399 IPM=(5-ISIGN(1,KFOLD))/2
11400 KFANEW=-MOD(KFAOLD+1,2)
11401 410 KFANEW=KFANEW+2
11402 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11403 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11404 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11405 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11406 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11407 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11408 ENDIF
11409 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11410 ENDIF
11411 IF(MINT(2).EQ.1) THEN
11412 MINT(21)=ISIGN(MINT(55),MINT(15))
11413 MINT(22)=ISIGN(KFANEW,MINT(16))
11414 ELSE
11415 MINT(21)=ISIGN(KFANEW,MINT(15))
11416 MINT(22)=ISIGN(MINT(55),MINT(16))
11417 JS=2
11418 ENDIF
11419 KCC=22
11420
11421 ELSEIF(ISUB.EQ.84) THEN
11422C...g + gamma -> Q + Qbar; th arbitary
11423 KCS=(-1)**INT(1.5D0+PYR(0))
11424 MINT(21)=ISIGN(MINT(55),KCS)
11425 MINT(22)=-MINT(21)
11426 KCC=27
11427 IF(MINT(16).EQ.21) KCC=28
11428
11429 ELSEIF(ISUB.EQ.85) THEN
11430C...gamma + gamma -> F + Fbar; th arbitary
11431 KCS=(-1)**INT(1.5D0+PYR(0))
11432 MINT(21)=ISIGN(MINT(56),KCS)
11433 MINT(22)=-MINT(21)
11434 KCC=21
11435
11436 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11437C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11438 MINT(21)=KFPR(ISUB,1)
11439 MINT(22)=KFPR(ISUB,2)
11440 KCC=24
11441 KCS=(-1)**INT(1.5D0+PYR(0))
11442 ENDIF
11443
11444 ELSEIF(ISUB.LE.100) THEN
11445 IF(ISUB.EQ.95) THEN
11446C...Low-pT ( = energyless g + g -> g + g)
11447 KCC=MINT(2)+12
11448 KCS=(-1)**INT(1.5D0+PYR(0))
11449
11450 ELSEIF(ISUB.EQ.96) THEN
11451C...Multiple interactions (should be reassigned to QCD process)
11452 ENDIF
11453
11454 ELSEIF(ISUB.LE.110) THEN
11455 IF(ISUB.EQ.101) THEN
11456C...g + g -> gamma*/Z0
11457 KCC=21
11458 KFRES=22
11459
11460 ELSEIF(ISUB.EQ.102) THEN
11461C...g + g -> h0 (or H0, or A0)
11462 KCC=21
11463 KFRES=KFHIGG
11464
11465 ELSEIF(ISUB.EQ.103) THEN
11466C...gamma + gamma -> h0 (or H0, or A0)
11467 KCC=21
11468 KFRES=KFHIGG
11469
11470 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11471C...g + g -> chi_0c or chi_2c.
11472 KCC=21
11473 KFRES=KFPR(ISUB,1)
11474
11475 ELSEIF(ISUB.EQ.106) THEN
11476C...g + g -> J/Psi + gamma
11477 MINT(21)=KFPR(ISUB,1)
11478 MINT(22)=KFPR(ISUB,2)
11479 KCC=21
11480
11481 ELSEIF(ISUB.EQ.107) THEN
11482C...g + gamma -> J/Psi + g
11483 MINT(21)=KFPR(ISUB,1)
11484 MINT(22)=KFPR(ISUB,2)
11485 KCC=22
11486 IF(MINT(16).EQ.22) KCC=33
11487
11488 ELSEIF(ISUB.EQ.108) THEN
11489C...gamma + gamma -> J/Psi + gamma
11490 MINT(21)=KFPR(ISUB,1)
11491 MINT(22)=KFPR(ISUB,2)
11492
11493 ELSEIF(ISUB.EQ.110) THEN
11494C...f + fbar -> gamma + h0; th arbitrary
11495 IF(PYR(0).GT.0.5D0) JS=2
11496 MINT(20+JS)=22
11497 MINT(23-JS)=KFHIGG
11498 ENDIF
11499
11500 ELSEIF(ISUB.LE.120) THEN
11501 IF(ISUB.EQ.111) THEN
11502C...f + fbar -> g + h0; th arbitrary
11503 IF(PYR(0).GT.0.5D0) JS=2
11504 MINT(20+JS)=21
11505 MINT(23-JS)=KFHIGG
11506 KCC=17+JS
11507
11508 ELSEIF(ISUB.EQ.112) THEN
11509C...f + g -> f + h0; th = (p(f) - p(f))**2
11510 IF(MINT(15).EQ.21) JS=2
11511 MINT(23-JS)=KFHIGG
11512 KCC=15+JS
11513 KCS=ISIGN(1,MINT(14+JS))
11514
11515 ELSEIF(ISUB.EQ.113) THEN
11516C...g + g -> g + h0; th arbitrary
11517 IF(PYR(0).GT.0.5D0) JS=2
11518 MINT(23-JS)=KFHIGG
11519 KCC=22+JS
11520 KCS=(-1)**INT(1.5D0+PYR(0))
11521
11522 ELSEIF(ISUB.EQ.114) THEN
11523C...g + g -> gamma + gamma; th arbitrary
11524 IF(PYR(0).GT.0.5D0) JS=2
11525 MINT(21)=22
11526 MINT(22)=22
11527 KCC=21
11528
11529 ELSEIF(ISUB.EQ.115) THEN
11530C...g + g -> g + gamma; th arbitrary
11531 IF(PYR(0).GT.0.5D0) JS=2
11532 MINT(23-JS)=22
11533 KCC=22+JS
11534 KCS=(-1)**INT(1.5D0+PYR(0))
11535
11536 ELSEIF(ISUB.EQ.116) THEN
11537C...g + g -> gamma + Z0
11538
11539 ELSEIF(ISUB.EQ.117) THEN
11540C...g + g -> Z0 + Z0
11541
11542 ELSEIF(ISUB.EQ.118) THEN
11543C...g + g -> W+ + W-
11544 ENDIF
11545
11546 ELSEIF(ISUB.LE.140) THEN
11547 IF(ISUB.EQ.121) THEN
11548C...g + g -> Q + Qbar + h0
11549 KCS=(-1)**INT(1.5D0+PYR(0))
11550 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11551 MINT(22)=-MINT(21)
11552 KCC=11+INT(0.5D0+PYR(0))
11553 KFRES=KFHIGG
11554
11555 ELSEIF(ISUB.EQ.122) THEN
11556C...q + qbar -> Q + Qbar + h0
11557 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11558 MINT(22)=-MINT(21)
11559 KCC=4
11560 KFRES=KFHIGG
11561
11562 ELSEIF(ISUB.EQ.123) THEN
11563C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11564C...inner process)
11565 KCC=22
11566 KFRES=KFHIGG
11567
11568 ELSEIF(ISUB.EQ.124) THEN
11569C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11570C...inner process)
11571 DO 430 JT=1,2
11572 I=MINT(14+JT)
11573 IA=IABS(I)
11574 IF(IA.LE.10) THEN
11575 RVCKM=VINT(180+I)*PYR(0)
11576 DO 420 J=1,MSTP(1)
11577 IB=2*J-1+MOD(IA,2)
11578 IPM=(5-ISIGN(1,I))/2
11579 IDC=J+MDCY(IA,2)+2
11580 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11581 MINT(20+JT)=ISIGN(IB,I)
11582 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11583 IF(RVCKM.LE.0D0) GOTO 430
11584 420 CONTINUE
11585 ELSE
11586 IB=2*((IA+1)/2)-1+MOD(IA,2)
11587 MINT(20+JT)=ISIGN(IB,I)
11588 ENDIF
11589 430 CONTINUE
11590 KCC=22
11591 KFRES=KFHIGG
11592
11593 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11594C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11595 IF(MINT(15).EQ.22) JS=2
11596 MINT(23-JS)=21
11597 KCC=24+JS
11598 KCS=ISIGN(1,MINT(14+JS))
11599
11600 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11601C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11602 IF(MINT(15).EQ.22) JS=2
11603 KCC=22
11604 KCS=ISIGN(1,MINT(14+JS))
11605
11606 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11607C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11608 KCS=(-1)**INT(1.5D0+PYR(0))
11609 MINT(21)=ISIGN(KFLF,KCS)
11610 MINT(22)=-MINT(21)
11611 KCC=27
11612 IF(MINT(16).EQ.21) KCC=28
11613
11614 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11615C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11616 KCS=(-1)**INT(1.5D0+PYR(0))
11617 MINT(21)=ISIGN(KFLF,KCS)
11618 MINT(22)=-MINT(21)
11619 KCC=21
11620
11621 ENDIF
11622
11623 ELSEIF(ISUB.LE.160) THEN
11624 IF(ISUB.EQ.141) THEN
11625C...f + fbar -> gamma*/Z0/Z'0
11626 KFRES=32
11627
11628 ELSEIF(ISUB.EQ.142) THEN
11629C...f + fbar' -> W'+/-
11630 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11631 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11632 KFRES=ISIGN(34,KCH1+KCH2)
11633
11634 ELSEIF(ISUB.EQ.143) THEN
11635C...f + fbar' -> H+/-
11636 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11637 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11638 KFRES=ISIGN(37,KCH1+KCH2)
11639
11640 ELSEIF(ISUB.EQ.144) THEN
11641C...f + fbar' -> R
11642 KFRES=ISIGN(41,MINT(15)+MINT(16))
11643
11644 ELSEIF(ISUB.EQ.145) THEN
11645C...q + l -> LQ (leptoquark)
11646 IF(IABS(MINT(16)).LE.8) JS=2
11647 KFRES=ISIGN(42,MINT(14+JS))
11648 KCC=28+JS
11649 KCS=ISIGN(1,MINT(14+JS))
11650
11651 ELSEIF(ISUB.EQ.146) THEN
11652C...e + gamma -> e* (excited lepton)
11653 IF(MINT(15).EQ.22) JS=2
11654 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11655 KCC=22
11656
11657 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11658C...q + g -> q* (excited quark)
11659 IF(MINT(15).EQ.21) JS=2
11660 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11661 KCC=30+JS
11662 KCS=ISIGN(1,MINT(14+JS))
11663
11664 ELSEIF(ISUB.EQ.149) THEN
11665C...g + g -> eta_tc
11666 KFRES=KTECHN+331
11667 KCC=23
11668 KCS=(-1)**INT(1.5D0+PYR(0))
11669 ENDIF
11670
11671 ELSEIF(ISUB.LE.200) THEN
11672 IF(ISUB.EQ.161) THEN
11673C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11674 IF(MINT(15).EQ.21) JS=2
11675 I=MINT(14+JS)
11676 IA=IABS(I)
11677 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11678 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11679 MINT(20+JS)=ISIGN(IB,I)
11680 KCC=15+JS
11681 KCS=ISIGN(1,MINT(14+JS))
11682
11683 ELSEIF(ISUB.EQ.162) THEN
11684C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11685 IF(MINT(15).EQ.21) JS=2
11686 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11687 KFLQL=KFDP(MDCY(42,2),2)
11688 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11689 KCC=15+JS
11690 KCS=ISIGN(1,MINT(14+JS))
11691
11692 ELSEIF(ISUB.EQ.163) THEN
11693C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11694 KCS=(-1)**INT(1.5D0+PYR(0))
11695 MINT(21)=ISIGN(42,KCS)
11696 MINT(22)=-MINT(21)
11697 KCC=MINT(2)+10
11698
11699 ELSEIF(ISUB.EQ.164) THEN
11700C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11701 MINT(21)=ISIGN(42,MINT(15))
11702 MINT(22)=-MINT(21)
11703 KCC=4
11704
11705 ELSEIF(ISUB.EQ.165) THEN
11706C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11707 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11708 MINT(22)=-MINT(21)
11709
11710 ELSEIF(ISUB.EQ.166) THEN
11711C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11712 IF(MOD(MINT(15),2).EQ.0) THEN
11713 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11714 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11715 ELSE
11716 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11717 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11718 ENDIF
11719
11720 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11721C...q + q' -> q" + q* (excited quark)
11722 KFQSTR=KFPR(ISUB,2)
11723 KFQEXC=MOD(KFQSTR,KEXCIT)
11724 JS=MINT(2)
11725 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11726 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11727 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11728 KCC=22
11729 JS=3-JS
11730
11731 ELSEIF(ISUB.EQ.169) THEN
11732C...q + qbar -> e + e* (excited lepton)
11733 KFQSTR=KFPR(ISUB,2)
11734 KFQEXC=MOD(KFQSTR,KEXCIT)
11735 JS=MINT(2)
11736 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11737 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11738 JS=3-JS
11739
11740 ELSEIF(ISUB.EQ.191) THEN
11741C...f + fbar -> rho_tc0.
11742 KFRES=KTECHN+113
11743
11744 ELSEIF(ISUB.EQ.192) THEN
11745C...f + fbar' -> rho_tc+/-
11746 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11747 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11748 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11749
11750 ELSEIF(ISUB.EQ.193) THEN
11751C...f + fbar -> omega_tc0.
11752 KFRES=KTECHN+223
11753
11754 ELSEIF(ISUB.EQ.194) THEN
11755C...f + fbar -> f' + fbar' via mixture of s-channel
11756C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11757 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11758 MINT(22)=-MINT(21)
11759
11760 ELSEIF(ISUB.EQ.195) THEN
11761C...f + fbar' -> f'' + fbar''' via s-channel
11762C...rho_tc+ th=(p(f)-p(f'))**2
11763C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11764 IF(MOD(MINT(15),2).EQ.0) THEN
11765 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11766 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11767 ELSE
11768 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11769 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11770 ENDIF
11771 ENDIF
11772
11773CMRENNA++
11774 ELSEIF(ISUB.LE.215) THEN
11775 IF(ISUB.EQ.201) THEN
11776C...f + fbar -> ~e_L + ~e_Lbar
11777 MINT(21)=ISIGN(KSUSY1+11,KCS)
11778 MINT(22)=-MINT(21)
11779
11780 ELSEIF(ISUB.EQ.202) THEN
11781C...f + fbar -> ~e_R + ~e_Rbar
11782 MINT(21)=ISIGN(KSUSY2+11,KCS)
11783 MINT(22)=-MINT(21)
11784
11785 ELSEIF(ISUB.EQ.203) THEN
11786C...f + fbar -> ~e_L + ~e_Rbar
11787 IF(MINT(15).LT.0) JS=2
11788 IF(MINT(2).EQ.1) THEN
11789 MINT(20+JS)=KFPR(ISUB,1)
11790 MINT(23-JS)=-KFPR(ISUB,2)
11791 ELSE
11792 MINT(20+JS)=-KFPR(ISUB,1)
11793 MINT(23-JS)=KFPR(ISUB,2)
11794 ENDIF
11795
11796 ELSEIF(ISUB.EQ.204) THEN
11797C...f + fbar -> ~mu_L + ~mu_Lbar
11798 MINT(21)=ISIGN(KSUSY1+13,KCS)
11799 MINT(22)=-MINT(21)
11800
11801 ELSEIF(ISUB.EQ.205) THEN
11802C...f + fbar -> ~mu_R + ~mu_Rbar
11803 MINT(21)=ISIGN(KSUSY2+13,KCS)
11804 MINT(22)=-MINT(21)
11805
11806 ELSEIF(ISUB.EQ.206) THEN
11807C...f + fbar -> ~mu_L + ~mu_Rbar
11808 IF(MINT(15).LT.0) JS=2
11809 IF(MINT(2).EQ.1) THEN
11810 MINT(20+JS)=KFPR(ISUB,1)
11811 MINT(23-JS)=-KFPR(ISUB,2)
11812 ELSE
11813 MINT(20+JS)=-KFPR(ISUB,1)
11814 MINT(23-JS)=KFPR(ISUB,2)
11815 ENDIF
11816
11817 ELSEIF(ISUB.EQ.207) THEN
11818C...f + fbar -> ~tau_1 + ~tau_1bar
11819 MINT(21)=ISIGN(KSUSY1+15,KCS)
11820 MINT(22)=-MINT(21)
11821
11822 ELSEIF(ISUB.EQ.208) THEN
11823C...f + fbar -> ~tau_2 + ~tau_2bar
11824 MINT(21)=ISIGN(KSUSY2+15,KCS)
11825 MINT(22)=-MINT(21)
11826
11827 ELSEIF(ISUB.EQ.209) THEN
11828C...f + fbar -> ~tau_1 + ~tau_2bar
11829 IF(MINT(15).LT.0) JS=2
11830 IF(MINT(2).EQ.1) THEN
11831 MINT(20+JS)=KFPR(ISUB,1)
11832 MINT(23-JS)=-KFPR(ISUB,2)
11833 ELSE
11834 MINT(20+JS)=-KFPR(ISUB,1)
11835 MINT(23-JS)=KFPR(ISUB,2)
11836 ENDIF
11837
11838 ELSEIF(ISUB.EQ.210) THEN
11839C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11840 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11841 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11842 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11843 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11844
11845 ELSEIF(ISUB.EQ.211) THEN
11846C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11847 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11848 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11849 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11850 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11851
11852 ELSEIF(ISUB.EQ.212) THEN
11853C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11854 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11855 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11856 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11857 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11858
11859 ELSEIF(ISUB.EQ.213) THEN
11860C...f + fbar -> ~nul + ~nulbar
11861 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11862 MINT(22)=-MINT(21)
11863
11864 ELSEIF(ISUB.EQ.214) THEN
11865C...f + fbar -> ~nutau + ~nutaubar
11866 MINT(21)=ISIGN(KSUSY1+16,KCS)
11867 MINT(22)=-MINT(21)
11868 ENDIF
11869
11870 ELSEIF(ISUB.LE.225) THEN
11871 IF(ISUB.EQ.216) THEN
11872C...f + fbar -> ~chi01 + ~chi01
11873 MINT(21)=KSUSY1+22
11874 MINT(22)=KSUSY1+22
11875
11876 ELSEIF(ISUB.EQ.217) THEN
11877C...f + fbar -> ~chi02 + ~chi02
11878 MINT(21)=KSUSY1+23
11879 MINT(22)=KSUSY1+23
11880
11881 ELSEIF(ISUB.EQ.218 ) THEN
11882C...f + fbar -> ~chi03 + ~chi03
11883 MINT(21)=KSUSY1+25
11884 MINT(22)=KSUSY1+25
11885
11886 ELSEIF(ISUB.EQ.219 ) THEN
11887C...f + fbar -> ~chi04 + ~chi04
11888 MINT(21)=KSUSY1+35
11889 MINT(22)=KSUSY1+35
11890
11891 ELSEIF(ISUB.EQ.220 ) THEN
11892C...f + fbar -> ~chi01 + ~chi02
11893 IF(MINT(15).LT.0) JS=2
11894C IF(PYR(0).GT.0.5D0) JS=2
11895 MINT(20+JS)=KSUSY1+22
11896 MINT(23-JS)=KSUSY1+23
11897
11898 ELSEIF(ISUB.EQ.221 ) THEN
11899C...f + fbar -> ~chi01 + ~chi03
11900 IF(MINT(15).LT.0) JS=2
11901C IF(PYR(0).GT.0.5D0) JS=2
11902 MINT(20+JS)=KSUSY1+22
11903 MINT(23-JS)=KSUSY1+25
11904
11905 ELSEIF(ISUB.EQ.222) THEN
11906C...f + fbar -> ~chi01 + ~chi04
11907 IF(MINT(15).LT.0) JS=2
11908C IF(PYR(0).GT.0.5D0) JS=2
11909 MINT(20+JS)=KSUSY1+22
11910 MINT(23-JS)=KSUSY1+35
11911
11912 ELSEIF(ISUB.EQ.223) THEN
11913C...f + fbar -> ~chi02 + ~chi03
11914 IF(MINT(15).LT.0) JS=2
11915C IF(PYR(0).GT.0.5D0) JS=2
11916 MINT(20+JS)=KSUSY1+23
11917 MINT(23-JS)=KSUSY1+25
11918
11919 ELSEIF(ISUB.EQ.224) THEN
11920C...f + fbar -> ~chi02 + ~chi04
11921 IF(MINT(15).LT.0) JS=2
11922C IF(PYR(0).GT.0.5D0) JS=2
11923 MINT(20+JS)=KSUSY1+23
11924 MINT(23-JS)=KSUSY1+35
11925
11926 ELSEIF(ISUB.EQ.225) THEN
11927C...f + fbar -> ~chi03 + ~chi04
11928 IF(MINT(15).LT.0) JS=2
11929C IF(PYR(0).GT.0.5D0) JS=2
11930 MINT(20+JS)=KSUSY1+25
11931 MINT(23-JS)=KSUSY1+35
11932 ENDIF
11933
11934 ELSEIF(ISUB.LE.236) THEN
11935 IF(ISUB.EQ.226) THEN
11936C...f + fbar -> ~chi+-1 + ~chi-+1
11937C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11938 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11939 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11940 MINT(22)=-MINT(21)
11941
11942 ELSEIF(ISUB.EQ.227) THEN
11943C...f + fbar -> ~chi+-2 + ~chi-+2
11944 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11945 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11946 MINT(22)=-MINT(21)
11947
11948 ELSEIF(ISUB.EQ.228) THEN
11949C...f + fbar -> ~chi+-1 + ~chi-+2
11950C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11951C...js=1 if pyr<.5, js=2 if pyr>.5
11952C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11953C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11954C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11955C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11957 KCH2=INT(1-KCH1)/2
11958 IF(MINT(2).EQ.1) THEN
11959 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11960 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11961c IF(KCH2.EQ.0) JS=2
11962 ELSE
11963 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11964 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11965 JS=2
11966c IF(KCH2.EQ.1) JS=2
11967 ENDIF
11968
11969 ELSEIF(ISUB.EQ.229) THEN
11970C...q + qbar' -> ~chi01 + ~chi+-1
11971C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11972 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11973 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11974C...CHECK THIS
11975 IF(MOD(MINT(15),2).EQ.0) JS=2
11976 MINT(20+JS)=KSUSY1+22
11977 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11978
11979 ELSEIF(ISUB.EQ.230) THEN
11980C...q + qbar' -> ~chi02 + ~chi+-1
11981 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11982 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11983 IF(MOD(MINT(15),2).EQ.0) JS=2
11984 MINT(20+JS)=KSUSY1+23
11985 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11986
11987 ELSEIF(ISUB.EQ.231) THEN
11988C...q + qbar' -> ~chi03 + ~chi+-1
11989 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11990 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11991 IF(MOD(MINT(15),2).EQ.0) JS=2
11992 MINT(20+JS)=KSUSY1+25
11993 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11994
11995 ELSEIF(ISUB.EQ.232) THEN
11996C...q + qbar' -> ~chi04 + ~chi+-1
11997 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11998 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11999 IF(MOD(MINT(15),2).EQ.0) JS=2
12000 MINT(20+JS)=KSUSY1+35
12001 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12002
12003 ELSEIF(ISUB.EQ.233) THEN
12004C...q + qbar' -> ~chi01 + ~chi+-2
12005 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12006 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12007 IF(MOD(MINT(15),2).EQ.0) JS=2
12008 MINT(20+JS)=KSUSY1+22
12009 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12010
12011 ELSEIF(ISUB.EQ.234) THEN
12012C...q + qbar' -> ~chi02 + ~chi+-2
12013 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12014 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12015 IF(MOD(MINT(15),2).EQ.0) JS=2
12016 MINT(20+JS)=KSUSY1+23
12017 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12018
12019 ELSEIF(ISUB.EQ.235) THEN
12020C...q + qbar' -> ~chi03 + ~chi+-2
12021 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12022 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12023 IF(MOD(MINT(15),2).EQ.0) JS=2
12024 MINT(20+JS)=KSUSY1+25
12025 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12026
12027 ELSEIF(ISUB.EQ.236) THEN
12028C...q + qbar' -> ~chi04 + ~chi+-2
12029 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12030 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12031 IF(MOD(MINT(15),2).EQ.0) JS=2
12032 MINT(20+JS)=KSUSY1+35
12033 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12034 ENDIF
12035
12036 ELSEIF(ISUB.LE.245) THEN
12037 IF(ISUB.EQ.237) THEN
12038C...q + qbar -> ~chi01 + ~g
12039C...th arbitrary
12040 IF(PYR(0).GT.0.5D0) JS=2
12041 MINT(20+JS)=KSUSY1+21
12042 MINT(23-JS)=KSUSY1+22
12043 KCC=17+JS
12044
12045 ELSEIF(ISUB.EQ.238) THEN
12046C...q + qbar -> ~chi02 + ~g
12047C...th arbitrary
12048 IF(PYR(0).GT.0.5D0) JS=2
12049 MINT(20+JS)=KSUSY1+21
12050 MINT(23-JS)=KSUSY1+23
12051 KCC=17+JS
12052
12053 ELSEIF(ISUB.EQ.239) THEN
12054C...q + qbar -> ~chi03 + ~g
12055C...th arbitrary
12056 IF(PYR(0).GT.0.5D0) JS=2
12057 MINT(20+JS)=KSUSY1+21
12058 MINT(23-JS)=KSUSY1+25
12059 KCC=17+JS
12060
12061 ELSEIF(ISUB.EQ.240) THEN
12062C...q + qbar -> ~chi04 + ~g
12063C...th arbitrary
12064 IF(PYR(0).GT.0.5D0) JS=2
12065 MINT(20+JS)=KSUSY1+21
12066 MINT(23-JS)=KSUSY1+35
12067 KCC=17+JS
12068
12069 ELSEIF(ISUB.EQ.241) THEN
12070C...q + qbar' -> ~chi+-1 + ~g
12071C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12072C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12073C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12074C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12075C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12076 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12077 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12078 JS=1
12079 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12080 MINT(20+JS)=KSUSY1+21
12081 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12082 KCC=17+JS
12083
12084 ELSEIF(ISUB.EQ.242) THEN
12085C...q + qbar' -> ~chi+-2 + ~g
12086C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12087C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12088C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12089C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12090C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12091 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12092 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12093 JS=1
12094 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12095 MINT(20+JS)=KSUSY1+21
12096 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12097 KCC=17+JS
12098
12099 ELSEIF(ISUB.EQ.243) THEN
12100C...q + qbar -> ~g + ~g ; th arbitrary
12101 MINT(21)=KSUSY1+21
12102 MINT(22)=KSUSY1+21
12103 KCC=MINT(2)+4
12104
12105 ELSEIF(ISUB.EQ.244) THEN
12106C...g + g -> ~g + ~g ; th arbitrary
12107 KCC=MINT(2)+12
12108 KCS=(-1)**INT(1.5D0+PYR(0))
12109 MINT(21)=KSUSY1+21
12110 MINT(22)=KSUSY1+21
12111 ENDIF
12112
12113 ELSEIF(ISUB.LE.260) THEN
12114 IF(ISUB.EQ.246) THEN
12115C...qj + g -> ~qj_L + ~chi01
12116 IF(MINT(15).EQ.21) JS=2
12117 I=MINT(14+JS)
12118 IA=IABS(I)
12119 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12120 MINT(23-JS)=KSUSY1+22
12121 KCC=15+JS
12122 KCS=ISIGN(1,MINT(14+JS))
12123
12124 ELSEIF(ISUB.EQ.247) THEN
12125C...qj + g -> ~qj_R + ~chi01
12126 IF(MINT(15).EQ.21) JS=2
12127 I=MINT(14+JS)
12128 IA=IABS(I)
12129 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12130 MINT(23-JS)=KSUSY1+22
12131 KCC=15+JS
12132 KCS=ISIGN(1,MINT(14+JS))
12133
12134 ELSEIF(ISUB.EQ.248) THEN
12135C...qj + g -> ~qj_L + ~chi02
12136 IF(MINT(15).EQ.21) JS=2
12137 I=MINT(14+JS)
12138 IA=IABS(I)
12139 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12140 MINT(23-JS)=KSUSY1+23
12141 KCC=15+JS
12142 KCS=ISIGN(1,MINT(14+JS))
12143
12144 ELSEIF(ISUB.EQ.249) THEN
12145C...qj + g -> ~qj_R + ~chi02
12146 IF(MINT(15).EQ.21) JS=2
12147 I=MINT(14+JS)
12148 IA=IABS(I)
12149 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12150 MINT(23-JS)=KSUSY1+23
12151 KCC=15+JS
12152 KCS=ISIGN(1,MINT(14+JS))
12153
12154 ELSEIF(ISUB.EQ.250) THEN
12155C...qj + g -> ~qj_L + ~chi03
12156 IF(MINT(15).EQ.21) JS=2
12157 I=MINT(14+JS)
12158 IA=IABS(I)
12159 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12160 MINT(23-JS)=KSUSY1+25
12161 KCC=15+JS
12162 KCS=ISIGN(1,MINT(14+JS))
12163
12164 ELSEIF(ISUB.EQ.251) THEN
12165C...qj + g -> ~qj_R + ~chi03
12166 IF(MINT(15).EQ.21) JS=2
12167 I=MINT(14+JS)
12168 IA=IABS(I)
12169 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12170 MINT(23-JS)=KSUSY1+25
12171 KCC=15+JS
12172 KCS=ISIGN(1,MINT(14+JS))
12173
12174 ELSEIF(ISUB.EQ.252) THEN
12175C...qj + g -> ~qj_L + ~chi04
12176 IF(MINT(15).EQ.21) JS=2
12177 I=MINT(14+JS)
12178 IA=IABS(I)
12179 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12180 MINT(23-JS)=KSUSY1+35
12181 KCC=15+JS
12182 KCS=ISIGN(1,MINT(14+JS))
12183
12184 ELSEIF(ISUB.EQ.253) THEN
12185C...qj + g -> ~qj_R + ~chi04
12186 IF(MINT(15).EQ.21) JS=2
12187 I=MINT(14+JS)
12188 IA=IABS(I)
12189 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12190 MINT(23-JS)=KSUSY1+35
12191 KCC=15+JS
12192 KCS=ISIGN(1,MINT(14+JS))
12193
12194 ELSEIF(ISUB.EQ.254) THEN
12195C...qj + g -> ~qk_L + ~chi+-1
12196 IF(MINT(15).EQ.21) JS=2
12197 I=MINT(14+JS)
12198 IA=IABS(I)
12199 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12200 IB=-IA+INT((IA+1)/2)*4-1
12201 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12202 KCC=15+JS
12203 KCS=ISIGN(1,MINT(14+JS))
12204
12205 ELSEIF(ISUB.EQ.255) THEN
12206C...qj + g -> ~qk_L + ~chi+-1
12207 IF(MINT(15).EQ.21) JS=2
12208 I=MINT(14+JS)
12209 IA=IABS(I)
12210 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12211 IB=-IA+INT((IA+1)/2)*4-1
12212 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12213 KCC=15+JS
12214 KCS=ISIGN(1,MINT(14+JS))
12215
12216 ELSEIF(ISUB.EQ.256) THEN
12217C...qj + g -> ~qk_L + ~chi+-2
12218 IF(MINT(15).EQ.21) JS=2
12219 I=MINT(14+JS)
12220 IA=IABS(I)
12221 IB=-IA+INT((IA+1)/2)*4-1
12222 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12223 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12224 KCC=15+JS
12225 KCS=ISIGN(1,MINT(14+JS))
12226
12227 ELSEIF(ISUB.EQ.257) THEN
12228C...qj + g -> ~qk_R + ~chi+-2
12229 IF(MINT(15).EQ.21) JS=2
12230 I=MINT(14+JS)
12231 IA=IABS(I)
12232 IB=-IA+INT((IA+1)/2)*4-1
12233 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12234 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12235 KCC=15+JS
12236 KCS=ISIGN(1,MINT(14+JS))
12237
12238 ELSEIF(ISUB.EQ.258) THEN
12239C...qj + g -> ~qj_L + ~g
12240 IF(MINT(15).EQ.21) JS=2
12241 I=MINT(14+JS)
12242 IA=IABS(I)
12243 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12244 MINT(23-JS)=KSUSY1+21
12245 KCC=MINT(2)+6
12246 IF(JS.EQ.2) KCC=KCC+2
12247 KCS=ISIGN(1,I)
12248
12249 ELSEIF(ISUB.EQ.259) THEN
12250C...qj + g -> ~qj_R + ~g
12251 IF(MINT(15).EQ.21) JS=2
12252 I=MINT(14+JS)
12253 IA=IABS(I)
12254 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12255 MINT(23-JS)=KSUSY1+21
12256 KCC=MINT(2)+6
12257 IF(JS.EQ.2) KCC=KCC+2
12258 KCS=ISIGN(1,I)
12259 ENDIF
12260
12261 ELSEIF(ISUB.LE.270) THEN
12262 IF(ISUB.EQ.261) THEN
12263C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12264 ISGN=1
12265 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12266 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12267 MINT(22)=-MINT(21)
12268C...Correct color combination
12269 IF(MINT(43).EQ.4) KCC=4
12270
12271 ELSEIF(ISUB.EQ.262) THEN
12272C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12273 ISGN=1
12274 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12275 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12276 MINT(22)=-MINT(21)
12277C...Correct color combination
12278 IF(MINT(43).EQ.4) KCC=4
12279
12280 ELSEIF(ISUB.EQ.263) THEN
12281C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12282 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12283 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12284 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12285 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12286 ELSE
12287 JS=2
12288 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12289 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12290 ENDIF
12291C...Correct color combination
12292 IF(MINT(43).EQ.4) KCC=4
12293
12294 ELSEIF(ISUB.EQ.264) THEN
12295C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12296 KCS=(-1)**INT(1.5D0+PYR(0))
12297 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12298 MINT(22)=-MINT(21)
12299 KCC=MINT(2)+10
12300
12301 ELSEIF(ISUB.EQ.265) THEN
12302C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12303 KCS=(-1)**INT(1.5D0+PYR(0))
12304 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12305 MINT(22)=-MINT(21)
12306 KCC=MINT(2)+10
12307 ENDIF
12308
12309 ELSEIF(ISUB.LE.296) THEN
12310 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12311C...qi + qj -> ~qi_L + ~qj_L
12312 KCC=MINT(2)
12313 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12314 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12315 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12316
12317 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12318C...qi + qj -> ~qi_R + ~qj_R
12319 KCC=MINT(2)
12320 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12321 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12322 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12323
12324 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12325C...qi + qj -> ~qi_L + ~qj_R
12326 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12327 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12328 KCC=MINT(2)
12329 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12330
12331 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12332C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12333 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12334 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12335 KCC=MINT(2)
12336 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12337
12338 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12339C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12340 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12341 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12342 KCC=MINT(2)
12343 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12344
12345 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12346C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12347 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12348 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12349 KCC=MINT(2)
12350 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12351
12352 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12353C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12354 ISGN=1
12355 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12356 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12357 MINT(22)=-MINT(21)
12358 IF(MINT(43).EQ.4) KCC=4
12359
12360 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12361C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12362 ISGN=1
12363 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12364 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12365 MINT(22)=-MINT(21)
12366 IF(MINT(43).EQ.4) KCC=4
12367
12368 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12369C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12370C...pure LL + RR
12371 KCS=(-1)**INT(1.5D0+PYR(0))
12372 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12373 MINT(22)=-MINT(21)
12374 KCC=MINT(2)+10
12375
12376 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12377C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12378 KCS=(-1)**INT(1.5D0+PYR(0))
12379 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12380 MINT(22)=-MINT(21)
12381 KCC=MINT(2)+10
12382
12383 ELSEIF(ISUB.EQ.294) THEN
12384C...qj + g -> ~qj_L + ~g
12385 IF(MINT(15).EQ.21) JS=2
12386 I=MINT(14+JS)
12387 IA=IABS(I)
12388 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12389 MINT(23-JS)=KSUSY1+21
12390 KCC=MINT(2)+6
12391 IF(JS.EQ.2) KCC=KCC+2
12392 KCS=ISIGN(1,I)
12393
12394 ELSEIF(ISUB.EQ.295) THEN
12395C...qj + g -> ~qj_R + ~g
12396 IF(MINT(15).EQ.21) JS=2
12397 I=MINT(14+JS)
12398 IA=IABS(I)
12399 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12400 MINT(23-JS)=KSUSY1+21
12401 KCC=MINT(2)+6
12402 IF(JS.EQ.2) KCC=KCC+2
12403 KCS=ISIGN(1,I)
12404 ENDIF
12405
12406 ELSEIF(ISUB.LE.330) THEN
12407 IF(ISUB.EQ.311)THEN
12408C...g + g -> g* + g* (UED)
12409 KCC=MINT(2)+12
12410 KCS=(-1)**INT(1.5D0+PYR(0))
12411 MUED(1)=472
12412 MUED(2)=472
12413 MINT(21)=IUEDEQ(472)
12414 MINT(22)=IUEDEQ(472)
12415 ELSEIF(ISUB.EQ.312)THEN
12416C...q + g -> q*_D + g*, q*_S + g*
12417C...The two channels have the same cross section
12418 KKFLMI=450
12419 IF(PYR(0).GT.0.5)KKFLMI=456
12420 IF(MINT(15).EQ.21) JS=2
12421 KCC=MINT(2)+6
12422 IF(MINT(15).EQ.21)KCC=KCC+2
12423 IF(MINT(15).NE.21)THEN
12424 KCS=ISIGN(1,MINT(15))
12425 MUED(2)=472
12426 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12427 MINT(22)=IUEDEQ(472)
12428 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12429 ENDIF
12430 IF(MINT(16).NE.21)THEN
12431 KCS=ISIGN(1,MINT(16))
12432 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12433 MUED(1)=472
12434 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12435 MINT(21)=IUEDEQ(472)
12436 ENDIF
12437 ELSEIF(ISUB.EQ.313)THEN
12438C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12439C...The two channels have the same cross section
12440 KKFLMI=450
12441 IF(PYR(0).GT.0.5)KKFLMI=456
12442 KCC=MINT(2)
12443 IF(MINT(15).EQ.MINT(16))THEN
12444 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12445 MUED(2)=MINT(21)
12446 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12447 MINT(22)=MINT(21)
12448 ELSE
12449 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12450 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12451 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12452 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12453 ENDIF
12454 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12455 ELSEIF(ISUB.EQ.314)THEN
12456C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12457C...The two channels have the same cross section
12458 KKFLMI=450
12459 IF(PYR(0).GT.0.5)KKFLMI=456
12460 KCS=(-1)**INT(1.5D0+PYR(0))
12461 XFLAOUT=PYR(0)
12462 IF(XFLAOUT.LE.0.2)THEN
12463 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12464 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12465 ELSEIF(XFLAOUT.LE.0.4)THEN
12466 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12467 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12468 ELSEIF(XFLAOUT.LE.0.6)THEN
12469 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12470 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12471 ELSEIF(XFLAOUT.LE.0.8)THEN
12472 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12473 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12474 ELSE
12475 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12476 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12477 ENDIF
12478 MINT(22)=-MINT(21)
12479 MUED(2)=-MUED(1)
12480 KCC=MINT(2)+10
12481 ELSEIF(ISUB.EQ.315)THEN
12482C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12483C...The two channels have the same cross section
12484 KKFLMI=450
12485 IF(PYR(0).GT.0.5)KKFLMI=456
12486 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12487 MUED(2)=-MINT(21)
12488 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12489 MINT(22)=-MINT(21)
12490 KCC=4
12491 ELSEIF(ISUB.EQ.316)THEN
12492C...q + qbar' -> q*_D + q*_S_bar'
12493 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12494 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12495 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12496 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12497 KCC=MINT(2)+2
12498 ELSEIF(ISUB.EQ.317)THEN
12499C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12500C...The two channels have the same cross section
12501 KKFLMI=450
12502 IF(PYR(0).GT.0.5)KKFLMI=456
12503 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12504 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12505 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12506 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12507 KCC=MINT(2)+2
12508 ELSEIF(ISUB.EQ.318)THEN
12509C...q + q' -> q*_D + q*_S'
12510 KCC=MINT(2)
12511 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12512 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12513 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12514 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12515 ELSEIF(ISUB.EQ.319)THEN
12516C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12517C...The two channels have the same cross section
12518 KKFLMI=450
12519 IF(PYR(0).GT.0.5)KKFLMI=456
12520 XFLAOUT=PYR(0)
12521 IIFLAV=0
12522C...N.B. NFLAVOURS=IUED(3)
12523C DO I=1,NFLAVOURS
12524 DO 433 I=1,IUED(3)
12525 IF(I.NE.IABS(MINT(15)))THEN
12526 IIFLAV=IIFLAV+1
12527 IOKFLA(IIFLAV)=I
12528 ENDIF
12529 433 CONTINUE
12530 FLASTEP=1./(IUED(3)-1)
12531 DO I=1,IUED(3)-1
12532 FLAVV=FLASTEP*I
12533 IF(XFLAOUT.LE.FLAVV)THEN
12534 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12535 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12536 GOTO 435
12537 ENDIF
12538 ENDDO
12539 435 CONTINUE
12540 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12541 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12542 CALL PYSTOP(5000000)
12543 ENDIF
12544 MINT(22)=-MINT(21)
12545 KCC=4
12546 ENDIF
12547
12548 ELSEIF(ISUB.LE.340) THEN
12549
12550 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12551C...q + qbar' -> H+ + H0
12552 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12553 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12554 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12555 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12556 MINT(23-JS)=KFPR(ISUB,2)
12557 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12558C...f + fbar -> A0 + H0; th arbitrary
12559 IF(PYR(0).GT.0.5D0) JS=2
12560 MINT(20+JS)=KFPR(ISUB,1)
12561 MINT(23-JS)=KFPR(ISUB,2)
12562 ELSEIF(ISUB.EQ.301) THEN
12563C...f + fbar -> H+ H-
12564 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12565 MINT(22)=-MINT(21)
12566 ENDIF
12567CMRENNA--
12568
12569 ELSEIF(ISUB.LE.360) THEN
12570
12571 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12572C...l + l -> H_L++/--, H_R++/--
12573 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12574 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12575 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12576
12577 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12578C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12579 IF(MINT(15).EQ.22) JS=2
12580 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12581 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12582 KCC=22
12583
12584 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12585C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12586 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12587 MINT(22)=-MINT(21)
12588
12589 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12590C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12591C...as inner process).
12592 DO 450 JT=1,2
12593 I=MINT(14+JT)
12594 IA=IABS(I)
12595 IF(IA.LE.10) THEN
12596 RVCKM=VINT(180+I)*PYR(0)
12597 DO 440 J=1,MSTP(1)
12598 IB=2*J-1+MOD(IA,2)
12599 IPM=(5-ISIGN(1,I))/2
12600 IDC=J+MDCY(IA,2)+2
12601 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12602 MINT(20+JT)=ISIGN(IB,I)
12603 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12604 IF(RVCKM.LE.0D0) GOTO 450
12605 440 CONTINUE
12606 ELSE
12607 IB=2*((IA+1)/2)-1+MOD(IA,2)
12608 MINT(20+JT)=ISIGN(IB,I)
12609 ENDIF
12610 450 CONTINUE
12611 KCC=22
12612 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12613 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12614
12615 ELSEIF(ISUB.EQ.353) THEN
12616C...f + fbar -> Z_R0
12617 KFRES=KFPR(ISUB,1)
12618
12619 ELSEIF(ISUB.EQ.354) THEN
12620C...f + fbar' -> W+/-
12621 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12622 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12623 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12624
12625 ENDIF
12626
12627 ELSEIF(ISUB.LE.380) THEN
12628
12629 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12630C...f + fbar -> charged+ charged- technicolor
12631 KSW=(-1)**INT(1.5D0+PYR(0))
12632 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12633 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12634
12635 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12636C...f + fbar -> neutral neutral technicolor
12637 MINT(21)=KFPR(ISUB,1)
12638 MINT(22)=KFPR(ISUB,2)
12639
12640 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12641C...f + fbar' -> neutral charged technicolor
12642 IN=1
12643 IC=2
12644 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12645 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12646 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12647 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12648 MINT(20+JS)=KFPR(ISUB,IN)
12649
12650 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12651C...f + fbar' -> charged neutral technicolor
12652 IN=2
12653 IC=1
12654 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12655 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12656 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12657 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12658 MINT(23-JS)=KFPR(ISUB,IN)
12659 ENDIF
12660
12661 ELSEIF(ISUB.LE.400) THEN
12662 IF(ISUB.EQ.381) THEN
12663C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12664 KCC=MINT(2)
12665 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12666
12667 ELSEIF(ISUB.EQ.382) THEN
12668C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12669 MINT(21)=ISIGN(KFLF,MINT(15))
12670 MINT(22)=-MINT(21)
12671 KCC=4
12672
12673 ELSEIF(ISUB.EQ.383) THEN
12674C...f + fbar -> g + g; th arbitrary, TC extensions
12675 MINT(21)=21
12676 MINT(22)=21
12677 KCC=MINT(2)+4
12678
12679 ELSEIF(ISUB.EQ.384) THEN
12680C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12681 IF(MINT(15).EQ.21) JS=2
12682 KCC=MINT(2)+6
12683 IF(MINT(15).EQ.21) KCC=KCC+2
12684 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12685 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12686
12687 ELSEIF(ISUB.EQ.385) THEN
12688C...g + g -> f + fbar; th arbitrary, TC extensions
12689 KCS=(-1)**INT(1.5D0+PYR(0))
12690 MINT(21)=ISIGN(KFLF,KCS)
12691 MINT(22)=-MINT(21)
12692 KCC=MINT(2)+10
12693
12694 ELSEIF(ISUB.EQ.386) THEN
12695C...g + g -> g + g; th arbitrary, TC extensions
12696 KCC=MINT(2)+12
12697 KCS=(-1)**INT(1.5D0+PYR(0))
12698
12699 ELSEIF(ISUB.EQ.387) THEN
12700C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12701 MINT(21)=ISIGN(MINT(55),MINT(15))
12702 MINT(22)=-MINT(21)
12703 KCC=4
12704
12705 ELSEIF(ISUB.EQ.388) THEN
12706C...g + g -> Q + Qbar; th arbitrary, TC extensions
12707 KCS=(-1)**INT(1.5D0+PYR(0))
12708 MINT(21)=ISIGN(MINT(55),KCS)
12709 MINT(22)=-MINT(21)
12710 KCC=MINT(2)+10
12711
12712 ELSEIF(ISUB.EQ.391) THEN
12713C...f + fbar -> G*.
12714 KFRES=KFPR(ISUB,1)
12715
12716 ELSEIF(ISUB.EQ.392) THEN
12717C...g + g -> G*.
12718 KCC=21
12719 KFRES=KFPR(ISUB,1)
12720
12721 ELSEIF(ISUB.EQ.393) THEN
12722C...q + qbar -> g + G*; th arbitrary.
12723 IF(PYR(0).GT.0.5D0) JS=2
12724 MINT(20+JS)=KFPR(ISUB,1)
12725 MINT(23-JS)=KFPR(ISUB,2)
12726 KCC=17+JS
12727
12728 ELSEIF(ISUB.EQ.394) THEN
12729C...q + g -> q + G*; th = (p(f) - p(f))**2
12730 IF(MINT(15).EQ.21) JS=2
12731 MINT(23-JS)=KFPR(ISUB,2)
12732 KCC=15+JS
12733 KCS=ISIGN(1,MINT(14+JS))
12734
12735 ELSEIF(ISUB.EQ.395) THEN
12736C...g + g -> G* + g; th arbitrary.
12737 IF(PYR(0).GT.0.5D0) JS=2
12738 MINT(23-JS)=KFPR(ISUB,2)
12739 KCC=22+JS
12740 ENDIF
12741
12742 ELSEIF(ISUB.LE.420) THEN
12743 IF(ISUB.EQ.401) THEN
12744C...g + g -> t + b + H+/-
12745 KCS=(-1)**INT(1.5D0+PYR(0))
12746 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12747 MINT(22)=ISIGN(5,-KCS)
12748 KCC=11+INT(0.5D0+PYR(0))
12749 KFRES=ISIGN(KFHIGG,-KCS)
12750
12751 ELSEIF(ISUB.EQ.402) THEN
12752C...q + qbar -> t + b + H+/-
12753 KFL=(-1)**INT(1.5D0+PYR(0))
12754 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12755 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12756 KCC=4
12757 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12758 ENDIF
12759
12760C...QUARKONIA+++
12761C...Additional code by Stefan Wolf
12762 ELSEIF(ISUB.LE.430) THEN
12763 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12764C...g + g -> QQ~[n] + g
12765C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12766C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12767C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12768C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12769C...or from ISUB.EQ.68 (for ISUB.NE.421)
12770C...[g + g -> g + g; th arbitrary]
12771 MINT(21)=KFPR(ISUBSV,1)
12772 MINT(22)=KFPR(ISUBSV,2)
12773 IF(ISUB.EQ.421) THEN
12774 KCC=24
12775 KCS=(-1)**INT(1.5D0+PYR(0))
12776 ELSE
12777 KCC=MINT(2)+12
12778 KCS=(-1)**INT(1.5D0+PYR(0))
12779 ENDIF
12780
12781 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12782C...q + g -> q + QQ~[n]
12783C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12784C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12785C...KCC copied from ISUB.EQ.28
12786C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12787 IF(MINT(15).EQ.21) JS=2
12788 MINT(23-JS)=KFPR(ISUBSV,2)
12789 KCC=MINT(2)+6
12790 IF(MINT(15).EQ.21) KCC=KCC+2
12791 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12792 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12793
12794 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12795C...q + q~ -> g + QQ~[n]
12796C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12797C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12798C...KCC copied from ISUB.EQ.13
12799C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12800 IF(PYR(0).GT.0.5) JS=2
12801 MINT(20+JS)=21
12802 MINT(23-JS)=KFPR(ISUBSV,2)
12803 KCC=MINT(2)+4
12804 ENDIF
12805
12806 ELSEIF(ISUB.LE.440) THEN
12807 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12808C...g + g -> QQ~[n] + g
12809C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12810C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12811C...KCC and KCS copied from ISUB.EQ.86-89
12812C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12813 MINT(21)=KFPR(ISUBSV,1)
12814 MINT(22)=KFPR(ISUBSV,2)
12815 KCC=24
12816 KCS=(-1)**INT(1.5D0+PYR(0))
12817
12818 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12819C...q + g -> q + QQ~[n]
12820C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12821C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12822C...KCC and KCS copied from ISUB.EQ.112
12823C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12824 IF(MINT(15).EQ.21) JS=2
12825 MINT(23-JS)=KFPR(ISUBSV,2)
12826 KCC=15+JS
12827 KCS=ISIGN(1,MINT(14+JS))
12828
12829 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12830C...q + q~ -> g + QQ~[n]
12831C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12832C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12833C...KCC copied from ISUB.EQ.111
12834C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12835 IF(PYR(0).GT.0.5) JS=2
12836 MINT(20+JS)=21
12837 MINT(23-JS)=KFPR(ISUBSV,2)
12838 KCC=17+JS
12839 ENDIF
12840C...QUARKONIA---
12841
12842 ENDIF
12843
12844 IF(ISET(ISUB).EQ.11) THEN
12845C...Store documentation for user-defined processes
12846 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12847 KUPPO(1)=MINT(83)+5
12848 KUPPO(2)=MINT(83)+6
12849 I=MINT(83)+6
12850 DO 470 IUP=3,NUP
12851 KUPPO(IUP)=0
12852 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12853 IDOC=IDOC-1
12854 MINT(4)=MINT(4)-1
12855 GOTO 470
12856 ENDIF
12857 I=I+1
12858 KUPPO(IUP)=I
12859 K(I,1)=21
12860 K(I,2)=IDUP(IUP)
12861 IF(IDUP(IUP).EQ.0) K(I,2)=90
12862 K(I,3)=0
12863 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12864 K(I,4)=0
12865 K(I,5)=0
12866 DO 460 J=1,5
12867 P(I,J)=PUP(J,IUP)
12868 460 CONTINUE
12869 V(I,5)=VTIMUP(IUP)
12870 470 CONTINUE
12871 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12872 & -BEZUP)
12873
12874C...Store final state partons for user-defined processes
12875 N=IPU2
12876 DO 490 IUP=3,NUP
12877 N=N+1
12878 K(N,1)=1
12879 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12880 K(N,2)=IDUP(IUP)
12881 IF(IDUP(IUP).EQ.0) K(N,2)=90
12882 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12883 K(N,3)=KUPPO(IUP)
12884 ELSE
12885 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12886 ENDIF
12887 K(N,4)=0
12888 K(N,5)=0
12889C...Search for daughters of intermediate colourless particles.
12890 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12891 DO 475 IUPDAU=IUP+1,NUP
12892 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12893 & N+IUPDAU-IUP
12894 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12895 475 CONTINUE
12896 ENDIF
12897 DO 480 J=1,5
12898 P(N,J)=PUP(J,IUP)
12899 480 CONTINUE
12900 V(N,5)=VTIMUP(IUP)
12901 490 CONTINUE
12902 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12903
12904C...Arrange colour flow for user-defined processes
12905 NLBL=0
12906 DO 540 IUP1=1,NUP
12907 I1=MINT(84)+IUP1
12908 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12909 IF(K(I1,1).EQ.1) K(I1,1)=3
12910 IF(K(I1,1).EQ.11) K(I1,1)=14
12911C...Find a not yet considered colour/anticolour line.
12912 DO 530 ISDE1=1,2
12913 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12914 NMAT=0
12915 DO 500 ILBL=1,NLBL
12916 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12917 500 CONTINUE
12918 IF(NMAT.EQ.0) THEN
12919 NLBL=NLBL+1
12920 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12921C...Find all others belonging to same line.
12922 I3=I1
12923 I4=0
12924 DO 520 IUP2=IUP1+1,NUP
12925 I2=MINT(84)+IUP2
12926 DO 510 ISDE2=1,2
12927 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12928 IF(ISDE2.EQ.ISDE1) THEN
12929 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12930 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12931 I3=I2
12932 ELSEIF(I4.NE.0) THEN
12933 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12934 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12935 I4=I2
12936 ELSEIF(IUP2.LE.2) THEN
12937 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12938 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12939 I4=I2
12940 ELSE
12941 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12942 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12943 I4=I2
12944 ENDIF
12945 ENDIF
12946 510 CONTINUE
12947 520 CONTINUE
12948 ENDIF
12949 530 CONTINUE
12950 540 CONTINUE
12951
12952 ELSEIF(IDOC.EQ.7) THEN
12953C...Resonance not decaying; store kinematics
12954 I=MINT(83)+7
12955 K(IPU3,1)=1
12956 K(IPU3,2)=KFRES
12957 K(IPU3,3)=I
12958 P(IPU3,4)=SHUSER
12959 P(IPU3,5)=SHUSER
12960 K(I,1)=21
12961 K(I,2)=KFRES
12962 P(I,4)=SHUSER
12963 P(I,5)=SHUSER
12964 N=IPU3
12965 MINT(21)=KFRES
12966 MINT(22)=0
12967
12968C...Special cases: colour flow in coloured resonances
12969 KCRES=PYCOMP(KFRES)
12970 IF(KCHG(KCRES,2).NE.0) THEN
12971 K(IPU3,1)=3
12972 DO 550 J=1,2
12973 JC=J
12974 IF(KCS.EQ.-1) JC=3-J
12975 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12976 & MINT(84)+ICOL(KCC,1,JC)
12977 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12978 & MINT(84)+ICOL(KCC,2,JC)
12979 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12980 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12981 550 CONTINUE
12982 ELSE
12983 K(IPU1,4)=IPU2
12984 K(IPU1,5)=IPU2
12985 K(IPU2,4)=IPU1
12986 K(IPU2,5)=IPU1
12987 ENDIF
12988
12989 ELSEIF(IDOC.EQ.8) THEN
12990C...2 -> 2 processes: store outgoing partons in their CM-frame
12991 DO 560 JT=1,2
12992 I=MINT(84)+2+JT
12993 KCA=PYCOMP(MINT(20+JT))
12994 K(I,1)=1
12995 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12996 K(I,2)=MINT(20+JT)
12997 K(I,3)=MINT(83)+IDOC+JT-2
12998 KFAA=IABS(K(I,2))
12999 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13000 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13001 ELSE
13002 P(I,5)=PYMASS(K(I,2))
13003 ENDIF
13004 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13005 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13006 560 CONTINUE
13007 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13008 KFA1=IABS(MINT(21))
13009 KFA2=IABS(MINT(22))
13010 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13011 & THEN
13012 MINT(51)=1
13013 RETURN
13014 ENDIF
13015 P(IPU3,5)=0D0
13016 P(IPU4,5)=0D0
13017 ENDIF
13018 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13019 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13020 P(IPU4,4)=SHR-P(IPU3,4)
13021 P(IPU4,3)=-P(IPU3,3)
13022 N=IPU4
13023 MINT(7)=MINT(83)+7
13024 MINT(8)=MINT(83)+8
13025
13026C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13027 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13028
13029 ELSEIF(IDOC.EQ.9) THEN
13030C...2 -> 3 processes: store outgoing partons in their CM frame
13031 DO 570 JT=1,2
13032 I=MINT(84)+2+JT
13033 KCA=PYCOMP(MINT(20+JT))
13034 K(I,1)=1
13035 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13036 K(I,2)=MINT(20+JT)
13037 K(I,3)=MINT(83)+IDOC+JT-3
13038 JTA=JT
13039C...t and b in opposide order in event list as compared to
13040C...matrix element?
13041 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13042 IF(IABS(K(I,2)).LE.22) THEN
13043 P(I,5)=PYMASS(K(I,2))
13044 ELSE
13045 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13046 ENDIF
13047 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13048 P(I,1)=PT*COS(VINT(198+5*JTA))
13049 P(I,2)=PT*SIN(VINT(198+5*JTA))
13050 570 CONTINUE
13051 K(IPU5,1)=1
13052 K(IPU5,2)=KFRES
13053 K(IPU5,3)=MINT(83)+IDOC
13054 P(IPU5,5)=SHR
13055 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13056 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13057 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13058 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13059 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13060 PMT3=SQRT(PMS3)
13061 P(IPU5,3)=PMT3*SINH(VINT(211))
13062 P(IPU5,4)=PMT3*COSH(VINT(211))
13063 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13064 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13065 IF(SQL12.LE.0D0) THEN
13066 MINT(51)=1
13067 RETURN
13068 ENDIF
13069 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13070 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13071 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13072 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13073C...t and b in opposide order in event list as compared to
13074C...matrix element
13075 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13076 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13077 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13078 END IF
13079 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13080 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13081 MINT(23)=KFRES
13082 N=IPU5
13083 MINT(7)=MINT(83)+7
13084 MINT(8)=MINT(83)+8
13085
13086 ELSEIF(IDOC.EQ.11) THEN
13087C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13088 PHI(1)=PARU(2)*PYR(0)
13089 PHI(2)=PHI(1)-PHIR
13090 DO 580 JT=1,2
13091 I=MINT(84)+2+JT
13092 K(I,1)=1
13093 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13094 K(I,2)=MINT(20+JT)
13095 K(I,3)=MINT(83)+IDOC+JT-2
13096 P(I,5)=PYMASS(K(I,2))
13097 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13098 MINT(51)=1
13099 RETURN
13100 ENDIF
13101 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13102 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13103 P(I,1)=PTABS*COS(PHI(JT))
13104 P(I,2)=PTABS*SIN(PHI(JT))
13105 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13106 P(I,4)=0.5D0*SHPR*Z(JT)
13107 IZW=MINT(83)+6+JT
13108 K(IZW,1)=21
13109 K(IZW,2)=23
13110 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13111 K(IZW,3)=IZW-2
13112 P(IZW,1)=-P(I,1)
13113 P(IZW,2)=-P(I,2)
13114 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13115 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13116 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13117 580 CONTINUE
13118 I=MINT(83)+9
13119 K(IPU5,1)=1
13120 K(IPU5,2)=KFRES
13121 K(IPU5,3)=I
13122 P(IPU5,5)=SHR
13123 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13124 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13125 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13126 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13127 K(I,1)=21
13128 K(I,2)=KFRES
13129 DO 590 J=1,5
13130 P(I,J)=P(IPU5,J)
13131 590 CONTINUE
13132 N=IPU5
13133 MINT(23)=KFRES
13134
13135 ELSEIF(IDOC.EQ.12) THEN
13136C...Z0 and W+/- scattering: store bosons and outgoing partons
13137 PHI(1)=PARU(2)*PYR(0)
13138 PHI(2)=PHI(1)-PHIR
13139 JTRAN=INT(1.5D0+PYR(0))
13140 DO 600 JT=1,2
13141 I=MINT(84)+2+JT
13142 K(I,1)=1
13143 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13144 K(I,2)=MINT(20+JT)
13145 K(I,3)=MINT(83)+IDOC+JT-2
13146 P(I,5)=PYMASS(K(I,2))
13147 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13148 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13149 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13150 P(I,1)=PTABS*COS(PHI(JT))
13151 P(I,2)=PTABS*SIN(PHI(JT))
13152 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13153 P(I,4)=0.5D0*SHPR*Z(JT)
13154 IZW=MINT(83)+6+JT
13155 K(IZW,1)=21
13156 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13157 K(IZW,2)=23
13158 ELSE
13159 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13160 ENDIF
13161 K(IZW,3)=IZW-2
13162 P(IZW,1)=-P(I,1)
13163 P(IZW,2)=-P(I,2)
13164 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13165 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13166 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13167 IPU=MINT(84)+4+JT
13168 K(IPU,1)=3
13169 K(IPU,2)=KFPR(ISUB,JT)
13170 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13171 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13172 K(IPU,3)=MINT(83)+8+JT
13173 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13174 P(IPU,5)=PYMASS(K(IPU,2))
13175 ELSE
13176 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13177 ENDIF
13178 MINT(22+JT)=K(IPU,2)
13179 600 CONTINUE
13180C...Find rotation and boost for hard scattering subsystem
13181 I1=MINT(83)+7
13182 I2=MINT(83)+8
13183 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13184 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13185 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13186 GAMCM=(P(I1,4)+P(I2,4))/SHR
13187 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13188 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13189 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13190 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13191 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13192 PHICM=PYANGL(PX,PY)
13193C...Store hard scattering subsystem. Rotate and boost it
13194 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13195 & P(IPU6,5)**2
13196 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13197 CTHWZ=VINT(23)
13198 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13199 PHIWZ=VINT(24)-PHICM
13200 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13201 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13202 P(IPU5,3)=PABS*CTHWZ
13203 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13204 P(IPU6,1)=-P(IPU5,1)
13205 P(IPU6,2)=-P(IPU5,2)
13206 P(IPU6,3)=-P(IPU5,3)
13207 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13208 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13209 DO 620 JT=1,2
13210 I1=MINT(83)+8+JT
13211 I2=MINT(84)+4+JT
13212 K(I1,1)=21
13213 K(I1,2)=K(I2,2)
13214 DO 610 J=1,5
13215 P(I1,J)=P(I2,J)
13216 610 CONTINUE
13217 620 CONTINUE
13218 N=IPU6
13219 MINT(7)=MINT(83)+9
13220 MINT(8)=MINT(83)+10
13221 ENDIF
13222
13223 IF(ISET(ISUB).EQ.11) THEN
13224 ELSEIF(IDOC.GE.8) THEN
13225C...Store colour connection indices
13226 DO 630 J=1,2
13227 JC=J
13228 IF(KCS.EQ.-1) JC=3-J
13229 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13230 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13231 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13232 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13233 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13234 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13235 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13236 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13237 630 CONTINUE
13238
13239C...Copy outgoing partons to documentation lines
13240 IMAX=2
13241 IF(IDOC.EQ.9) IMAX=3
13242 DO 650 I=1,IMAX
13243 I1=MINT(83)+IDOC-IMAX+I
13244 I2=MINT(84)+2+I
13245 K(I1,1)=21
13246 K(I1,2)=K(I2,2)
13247 IF(IDOC.LE.9) K(I1,3)=0
13248 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13249 DO 640 J=1,5
13250 P(I1,J)=P(I2,J)
13251 640 CONTINUE
13252 650 CONTINUE
13253
13254 ELSEIF(IDOC.EQ.9) THEN
13255C...Store colour connection indices
13256 DO 660 J=1,2
13257 JC=J
13258 IF(KCS.EQ.-1) JC=3-J
13259 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13260 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13261 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13262 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13263 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13264 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13265 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13266 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13267 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13268 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13269 660 CONTINUE
13270
13271C...Copy outgoing partons to documentation lines
13272 DO 680 I=1,3
13273 I1=MINT(83)+IDOC-3+I
13274 I2=MINT(84)+2+I
13275 K(I1,1)=21
13276 K(I1,2)=K(I2,2)
13277 K(I1,3)=0
13278 DO 670 J=1,5
13279 P(I1,J)=P(I2,J)
13280 670 CONTINUE
13281 680 CONTINUE
13282 ENDIF
13283
13284C...Copy outgoing partons to list of allowed radiators.
13285 NPART=0
13286 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13287 DO 690 I=MINT(84)+3,N
13288 NPART=NPART+1
13289 IPART(NPART)=I
13290 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13291 690 CONTINUE
13292 ENDIF
13293
13294C...Low-pT events: remove gluons used for string drawing purposes
13295 IF(ISUB.EQ.95) THEN
13296 IF(MINT(35).LE.1) THEN
13297 K(IPU3,1)=K(IPU3,1)+10
13298 K(IPU4,1)=K(IPU4,1)+10
13299 ENDIF
13300 DO 700 J=41,66
13301 VINTSV(J)=VINT(J)
13302 VINT(J)=0D0
13303 700 CONTINUE
13304 DO 720 I=MINT(83)+5,MINT(83)+8
13305 DO 710 J=1,5
13306 P(I,J)=0D0
13307 710 CONTINUE
13308 720 CONTINUE
13309 ENDIF
13310
13311 RETURN
13312 END
13313
13314C***********************************************************************
13315
13316C...PYEVOL
13317C...Handles intertwined pT-ordered spacelike initial-state parton
13318C...and multiple interactions.
13319
13320 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13321C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13322C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13323C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13324
13325C...Double precision and integer declarations.
13326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13327 IMPLICIT INTEGER(I-N)
13328 INTEGER PYK,PYCHGE,PYCOMP
13329C...External
13330 EXTERNAL PYALPS
13331 DOUBLE PRECISION PYALPS
13332C...Parameter statement for maximum size of showers.
13333 PARAMETER (MAXNUR=1000)
13334C...Commonblocks.
13335 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13336 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13338 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13339 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13340 COMMON/PYINT1/MINT(400),VINT(400)
13341 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13342 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13343 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13344 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13345 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13346 COMMON/PYCTAG/NCT,MCT(4000,2)
13347 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13348 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13349 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13350C...Local arrays and saved variables.
13351 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13352 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13353 & ,PSAV,KSAV,VSAV
13354
13355 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13356 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13357
13358C----------------------------------------------------------------------
13359C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13360C...done only once per event, while MODE=0 is repeated each time the
13361C...evolution needs to be restarted.
13362 IF (MODE.EQ.-1) THEN
13363 ISUBHD=MINT(1)
13364 NSAV=N
13365 NPARTS=NPART
13366C...Store hard scattering variables
13367 M15SV=MINT(15)
13368 M16SV=MINT(16)
13369 M21SV=MINT(21)
13370 M22SV=MINT(22)
13371 DO 100 J=11,80
13372 VINTSV(J)=VINT(J)
13373 100 CONTINUE
13374 DO 120 J=1,5
13375 DO 110 IS=1,4
13376 I=IS+MINT(84)
13377 PSAV(IS,J)=P(I,J)
13378 KSAV(IS,J)=K(I,J)
13379 VSAV(IS,J)=V(I,J)
13380 110 CONTINUE
13381 120 CONTINUE
13382
13383C...Set shat for hardest scattering
13384 SHAT(1)=VINT(44)
13385 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13386 & *VINT(2)
13387
13388C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13389 RMC=PMAS(4,1)
13390 RMB=PMAS(5,1)
13391 ALAM4=PARP(61)
13392 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13393 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13394 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13395
13396C----------------------------------------------------------------------
13397C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13398C...interaction initiators, with no previous evolution. Check the input
13399C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13400C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13401C...smaller than the CM energy / 2.)
13402 ELSEIF (MODE.EQ.0) THEN
13403C...Reset counters and switches
13404 N=NSAV
13405 NPART=NPARTS
13406 MINT(30)=0
13407 MINT(31)=1
13408 MINT(36)=1
13409C...Reset hard scattering variables
13410 MINT(1)=ISUBHD
13411 DO 130 J=11,80
13412 VINT(J)=VINTSV(J)
13413 130 CONTINUE
13414 DO 150 J=1,5
13415 DO 140 IS=1,4
13416 I=IS+MINT(84)
13417 P(I,J)=PSAV(IS,J)
13418 K(I,J)=KSAV(IS,J)
13419 V(I,J)=VSAV(IS,J)
13420 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13421 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13422 140 CONTINUE
13423 150 CONTINUE
13424C...Reset statistics on activity in event.
13425 DO 160 J=351,359
13426 MINT(J)=0
13427 VINT(J)=0D0
13428 160 CONTINUE
13429C...Reset extra companion reweighting factor
13430 VINT(140)=1D0
13431
13432C...We do not generate MI for soft process (ISUB=95), but the
13433C...initialization must be done regardless, for later purposes.
13434 MINT(36)=1
13435
13436C...Initialize multiple interactions.
13437 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13438 IF(MINT(51).NE.0) RETURN
13439
13440C...Decide whether quarks in hard scattering were valence or sea
13441 PT2HD=VINT(54)
13442 DO 170 JS=1,2
13443 MINT(30)=JS
13444 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13445 IF(MINT(51).NE.0) RETURN
13446 170 CONTINUE
13447
13448C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13449 VINT(18)=0D0
13450 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13451 IF (MSTP(70).EQ.2) THEN
13452C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13453 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13454 ELSEIF (MSTP(70).EQ.3) THEN
13455C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13456 ALPHA0 = MAX(1D-6,PARP(73))
13457 Q20 = ALAM3**2/PARP(64)
13458 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13459 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13460 ENDIF
13461C...Also store PT2MIN in VINT(17).
13462 180 VINT(17)=PT2MIN
13463
13464C...Set FS masses zero now.
13465 VINT(63)=0D0
13466 VINT(64)=0D0
13467
13468C...Initialize IS showers with VINT(56) as max scale.
13469 PT2ISR=VINT(56)
13470 PT20=PT2MIN
13471 IF (MSTP(70).EQ.0) THEN
13472 PT20=MAX(PT2MIN,PARP(62)**2)
13473 ELSEIF (MSTP(70).EQ.1) THEN
13474 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13475 ENDIF
13476 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13477 IF(MINT(51).NE.0) RETURN
13478
13479 RETURN
13480
13481C----------------------------------------------------------------------
13482C...MODE= 1: Evolve event from PTMAX to PTMIN.
13483 ELSEIF (MODE.EQ.1) THEN
13484
13485C...Skip if no phase space.
13486 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13487
13488C...Starting pT2 max scale (to be udpated successively).
13489 PT2CMX=PT2MAX
13490
13491C...Evolve two sides of the event to find which branches at highest pT.
13492 200 JSMX=-1
13493 MIMX=0
13494 PT2MX=0D0
13495
13496C...Loop over current shower initiators.
13497 IF (MSTP(61).GE.1) THEN
13498 DO 230 MI=1,MINT(31)
13499 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13500 ISUB=96
13501 IF (MI.EQ.1) ISUB=ISUBHD
13502 MINT(1)=ISUB
13503 MINT(36)=MI
13504C...Set up shat, initiator x values, and x remaining in BR.
13505 VINT(44)=SHAT(MI)
13506 VINT(141)=XMI(1,MI)
13507 VINT(142)=XMI(2,MI)
13508 VINT(143)=1D0
13509 VINT(144)=1D0
13510 DO 210 JI=1,MINT(31)
13511 IF (JI.EQ.MINT(36)) GOTO 210
13512 VINT(143)=VINT(143)-XMI(1,JI)
13513 VINT(144)=VINT(144)-XMI(2,JI)
13514 210 CONTINUE
13515C...Loop over sides.
13516C...Generate trial branchings for this interaction. The hardest
13517C...branching so far is automatically updated if necessary in /PYISMX/.
13518 DO 220 JS=1,2
13519 MINT(30)=JS
13520 PT20=PT2MIN
13521 IF (MSTP(70).EQ.0) THEN
13522 PT20=MAX(PT2MIN,PARP(62)**2)
13523 ELSEIF (MSTP(70).EQ.1) THEN
13524 PT20=MAX(PT2MIN,
13525 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13526 ENDIF
13527 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13528 IF (MINT(51).NE.0) RETURN
13529 220 CONTINUE
13530 230 CONTINUE
13531 ENDIF
13532
13533C...Generate trial additional interaction.
13534 MINT(36)=MINT(31)+1
13535 240 IF (MOD(MSTP(81),10).GE.1) THEN
13536 MINT(1)=96
13537C...Set up X remaining in BR.
13538 VINT(143)=1D0
13539 VINT(144)=1D0
13540 DO 250 JI=1,MINT(31)
13541 VINT(143)=VINT(143)-XMI(1,JI)
13542 VINT(144)=VINT(144)-XMI(2,JI)
13543 250 CONTINUE
13544C...Generate trial interaction
13545 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13546 IF (MINT(51).EQ.1) RETURN
13547 ENDIF
13548
13549C...And the winner is:
13550 IF (PT2MX.LT.PT2MIN) THEN
13551 GOTO 330
13552 ELSEIF (JSMX.EQ.0) THEN
13553C...Accept additional interaction (may still fail).
13554 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13555 IF(MINT(51).NE.0) RETURN
13556 IF (IFAIL.EQ.0) THEN
13557 SHAT(MINT(36))=VINT(44)
13558C...Decide on flavours (valence/sea/companion).
13559 DO 270 JS=1,2
13560 MINT(30)=JS
13561 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13562 IF(MINT(51).NE.0) RETURN
13563 270 CONTINUE
13564 ENDIF
13565 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13566C...Reconstruct kinematics of acceptable ISR branching.
13567C...Set up shat, initiator x values, and x remaining in BR.
13568 MINT(30)=JSMX
13569 MINT(36)=MIMX
13570 VINT(44)=SHAT(MINT(36))
13571 VINT(141)=XMI(1,MINT(36))
13572 VINT(142)=XMI(2,MINT(36))
13573 VINT(143)=1D0
13574 VINT(144)=1D0
13575 DO 280 JI=1,MINT(31)
13576 IF (JI.EQ.MINT(36)) GOTO 280
13577 VINT(143)=VINT(143)-XMI(1,JI)
13578 VINT(144)=VINT(144)-XMI(2,JI)
13579 280 CONTINUE
13580 PT2NEW=PT2MX
13581 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13582 IF (MINT(51).EQ.1) RETURN
13583 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13584C...Bookeep joining. Cannot (yet) be constructed kinematically.
13585 MINT(354)=MINT(354)+1
13586 VINT(354)=VINT(354)+SQRT(PT2MX)
13587 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13588 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13589 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13590 ENDIF
13591
13592C...Update PT2 iteration scale.
13593 PT2CMX=PT2MX
13594
13595C...Loop back to continue evolution.
13596 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13597 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13598 ELSE
13599 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13600 ENDIF
13601
13602C----------------------------------------------------------------------
13603C...MODE= 2: (Re-)store user information on hardest interaction etc.
13604 ELSEIF (MODE.EQ.2) THEN
13605
13606C...Revert to "ordinary" meanings of some parameters.
13607 290 DO 310 JS=1,2
13608 MINT(12+JS)=K(IMI(JS,1,1),2)
13609 VINT(140+JS)=XMI(JS,1)
13610 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13611 VINT(142+JS)=1D0
13612 DO 300 MI=1,MINT(31)
13613 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13614 300 CONTINUE
13615 310 CONTINUE
13616
13617C...Restore saved quantities for hardest interaction.
13618 MINT(1)=ISUBHD
13619 MINT(15)=M15SV
13620 MINT(16)=M16SV
13621 MINT(21)=M21SV
13622 MINT(22)=M22SV
13623 DO 320 J=11,80
13624 VINT(J)=VINTSV(J)
13625 320 CONTINUE
13626
13627 ENDIF
13628
13629 330 RETURN
13630 END
13631
13632C*********************************************************************
13633
13634C...PYSSPA
13635C...Generates spacelike parton showers.
13636
13637 SUBROUTINE PYSSPA(IPU1,IPU2)
13638
13639C...Double precision and integer declarations.
13640 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13641 IMPLICIT INTEGER(I-N)
13642 INTEGER PYK,PYCHGE,PYCOMP
13643 PARAMETER (MAXNUR=1000)
13644C...Commonblocks.
13645 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13646 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13649 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13650 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13651 COMMON/PYINT1/MINT(400),VINT(400)
13652 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13653 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13654 COMMON/PYCTAG/NCT,MCT(4000,2)
13655 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13656 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13657C...Local arrays and data.
13658 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13659 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13660 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13661 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13662 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13663 DATA IS/2*0/
13664
13665C...Read out basic information; set global Q^2 scale.
13666 IPUS1=IPU1
13667 IPUS2=IPU2
13668 ISUB=MINT(1)
13669 Q2MX=VINT(56)
13670 VINT2R=VINT(2)*VINT(143)*VINT(144)
13671 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13672 &MIN(VINT2R,PARP(67)*VINT(56))
13673 FCQ2MX=1D0
13674
13675C...Define which processes ME corrections have been implemented for.
13676 MECOR=0
13677 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13678 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13679 & ISUB.EQ.144) MECOR=1
13680 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13681 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13682 ENDIF
13683
13684C...Initialize QCD evolution and check phase space.
13685 Q2MNC=PARP(62)**2
13686 Q2MNCS(1)=Q2MNC
13687 Q2MNCS(2)=Q2MNC
13688 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13689 Q0S=PARP(15)**2
13690 PS=VINT(3)**2
13691 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13692 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13693 Q2INT=SQRT(Q0S*Q2EFF)
13694 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13695 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13696 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13697 ENDIF
13698 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13699 Q0S=PARP(15)**2
13700 PS=VINT(4)**2
13701 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13702 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13703 Q2INT=SQRT(Q0S*Q2EFF)
13704 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13705 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13706 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13707 ENDIF
13708 MCEV=0
13709 ALAMS=PARU(112)
13710 PARU(112)=PARP(61)
13711 FQ2C=1D0
13712 TCMX=0D0
13713 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13714 MCEV=1
13715 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13716 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13717 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13718 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13719 & MCEV=0
13720 ENDIF
13721
13722C...Initialize QED evolution and check phase space.
13723 MEEV=0
13724 XEE=1D-10
13725 SPME=PMAS(11,1)**2
13726 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13727 &SPME=PMAS(13,1)**2
13728 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13729 &SPME=PMAS(15,1)**2
13730 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13731 TEMX=0D0
13732 FWTE=10D0
13733 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13734 MEEV=1
13735 TEMX=LOG(Q2MX/SPME)
13736 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13737 ENDIF
13738 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13739 MEEV=2
13740 TEMX=TCMX
13741 FWTE=1D0
13742 ENDIF
13743 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13744
13745C...Loopback point in case of failure to reconstruct kinematics.
13746 NS=N
13747 NPARTS=NPART
13748 LOOP=0
13749 MNT352=MINT(352)
13750 MNT353=MINT(353)
13751 VNT352=VINT(352)
13752 VNT353=VINT(353)
13753 100 LOOP=LOOP+1
13754 IF(LOOP.GT.100) THEN
13755 MINT(51)=1
13756 RETURN
13757 ENDIF
13758 N=NS
13759 NPART=NPARTS
13760 MINT(352)=MNT352
13761 MINT(353)=MNT353
13762 VINT(352)=VNT352
13763 VINT(353)=VNT353
13764
13765C...Initial values: flavours, momenta, virtualities.
13766 DO 120 JT=1,2
13767 MORE(JT)=1
13768 KFBEAM(JT)=MINT(10+JT)
13769 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13770 KFLS(JT)=MINT(14+JT)
13771 KFLS(JT+2)=KFLS(JT)
13772 XS(JT)=VINT(40+JT)
13773 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13774 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13775 ZS(JT)=1D0
13776 Q2S(JT)=FCQ2MX*Q2MX
13777 DQ2(JT)=0D0
13778 TEVCSV(JT)=TCMX
13779 ALAM(JT)=PARP(61)
13780 THE2(JT)=1D0
13781 TEVESV(JT)=TEMX
13782 MCESV(JT)=0
13783C...Calculate initial parton distribution weights.
13784 MINT(105)=MINT(102+JT)
13785 MINT(109)=MINT(106+JT)
13786 VINT(120)=VINT(2+JT)
13787C.... ALICE
13788C.... Store side in MINT(124)
13789 MINT(124) = JT
13790C....
13791 IF(XS(JT).LT.1D0-XEE) THEN
13792 IF(MINT(31).GE.2) MINT(30)=JT
13793 IF(MSTP(57).LE.1) THEN
13794 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13795 ELSE
13796 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13797 ENDIF
13798 ENDIF
13799 DO 110 KFL=-25,25
13800 XFS(JT,KFL)=XFB(KFL)
13801 110 CONTINUE
13802C...Special kinematics check for c/b quarks (that g -> c cbar or
13803C...b bbar kinematically possible).
13804 KFLCB=IABS(KFLS(JT))
13805 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13806 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13807 MINT(51)=1
13808 RETURN
13809 ENDIF
13810 ENDIF
13811 120 CONTINUE
13812 DSH=VINT(44)
13813 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13814
13815C...Find if interference with final state partons.
13816 MFIS=0
13817 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13818 IF(MFIS.NE.0) THEN
13819 DO 140 I=1,2
13820 KCFI(I)=0
13821 KCA=PYCOMP(IABS(KFLS(I)))
13822 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13823 NFIS(I)=0
13824 IF(KCFI(I).NE.0) THEN
13825 IF(I.EQ.1) IPFS=IPUS1
13826 IF(I.EQ.2) IPFS=IPUS2
13827 DO 130 J=1,2
13828 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13829 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13830 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13831 NFIS(I)=NFIS(I)+1
13832 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13833 & P(ICSI,2)**2))
13834 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13835 ENDIF
13836 130 CONTINUE
13837 ENDIF
13838 140 CONTINUE
13839 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13840 ENDIF
13841
13842C...Pick up leg with highest virtuality.
13843 JTOLD=1
13844 150 N=N+1
13845 JT=1
13846 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13847 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13848 IF(MORE(JT).EQ.0) JT=3-JT
13849 JTOLD=JT
13850 KFLB=KFLS(JT)
13851 XB=XS(JT)
13852 DO 160 KFL=-25,25
13853 XFB(KFL)=XFS(JT,KFL)
13854 160 CONTINUE
13855 DSHR=2D0*SQRT(DSH)
13856 DSHZ=DSH/ZS(JT)
13857
13858C...Check if allowed to branch.
13859 MCEV=0
13860 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13861 MCEV=1
13862 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13863 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13864 ENDIF
13865 MEEV=0
13866 IF(MINT(44+JT).EQ.3) THEN
13867 MEEV=1
13868 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13869 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13870 & MEEV=0
13871C***Currently kill QED shower for resolved photoproduction.
13872 IF(MINT(18+JT).EQ.1) MEEV=0
13873C***Currently kill shower for W inside electron.
13874 IF(IABS(KFLB).EQ.24) THEN
13875 MCEV=0
13876 MEEV=0
13877 ENDIF
13878 ENDIF
13879 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13880 &MEEV=2
13881 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13882 Q2B=0D0
13883 GOTO 260
13884 ENDIF
13885
13886C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13887 Q2B=Q2S(JT)
13888 TEVCB=TEVCSV(JT)
13889 TEVEB=TEVESV(JT)
13890 IF(MSTP(62).LE.1) THEN
13891 IF(ZS(JT).GT.0.99999D0) THEN
13892 Q2B=Q2S(JT)
13893 ELSE
13894 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13895 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13896 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13897 ENDIF
13898 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13899 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13900 ENDIF
13901 IF(MCEV.EQ.1) THEN
13902 ALSDUM=PYALPS(FQ2C*Q2B)
13903 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13904 ALAM(JT)=PARU(117)
13905 B0=(33D0-2D0*MSTU(118))/6D0
13906 ENDIF
13907 IF(MEEV.EQ.2) TEVEB=TEVCB
13908 TEVCBS=TEVCB
13909 TEVEBS=TEVEB
13910
13911C...Select side for interference with final state partons.
13912 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13913 IFI=N-NS
13914 ISFI(IFI)=0
13915 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13916 ISFI(IFI)=1
13917 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13918 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13919 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13920 ISFI(IFI)=1
13921 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13922 ENDIF
13923 ENDIF
13924
13925C...Calculate preweighting factor for ME-corrected processes.
13926 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13927
13928C...Calculate Altarelli-Parisi weights.
13929 DO 170 KFL=-25,25
13930 WTAPC(KFL)=0D0
13931 WTAPE(KFL)=0D0
13932 WTSF(KFL)=0D0
13933 170 CONTINUE
13934C...q -> q (g or gamma emission), g -> q.
13935 IF(IABS(KFLB).LE.10) THEN
13936 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13937 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13938 EQ2=1D0/9D0
13939 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13940 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13941 & (XEC*(1D0-XEC)))
13942 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13943 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13944 WTAPC(21)=WTGF*WTAPC(21)
13945 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13946 ENDIF
13947C...f -> f, gamma -> f.
13948 ELSEIF(IABS(KFLB).LE.20) THEN
13949 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13950 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13951 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13952 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13953 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13954 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13955 WTAPE(22)=WTGF*WTAPE(22)
13956 ENDIF
13957C...f -> g, g -> g.
13958 ELSEIF(KFLB.EQ.21) THEN
13959 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13960 DO 180 KFL=1,MSTP(58)
13961 WTAPC(KFL)=WTAPQ
13962 WTAPC(-KFL)=WTAPQ
13963 180 CONTINUE
13964 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13965 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13966 DO 190 KFL=1,MSTP(58)
13967 WTAPC(KFL)=WTFG*WTAPC(KFL)
13968 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13969 190 CONTINUE
13970 WTAPC(21)=WTGG*WTAPC(21)
13971 ENDIF
13972C...f -> gamma, W+, W-.
13973 ELSEIF(KFLB.EQ.22) THEN
13974 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13975 WTAPE(11)=WTAPF
13976 WTAPE(-11)=WTAPF
13977 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13978 WTAPE(11)=WTFG*WTAPE(11)
13979 WTAPE(-11)=WTFG*WTAPE(-11)
13980 ENDIF
13981 ELSEIF(KFLB.EQ.24) THEN
13982 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13983 & (XEE*(XB+XEE)))/XB
13984 ELSEIF(KFLB.EQ.-24) THEN
13985 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13986 & (XEE*(XB+XEE)))/XB
13987 ENDIF
13988
13989C...Calculate parton distribution weights and sum.
13990 NTRY=0
13991 200 NTRY=NTRY+1
13992 IF(NTRY.GT.500) THEN
13993 MINT(51)=1
13994 RETURN
13995 ENDIF
13996 WTSUMC=0D0
13997 WTSUME=0D0
13998 XFBO=MAX(1D-10,XFB(KFLB))
13999 DO 210 KFL=-25,25
14000 WTSF(KFL)=XFB(KFL)/XFBO
14001 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14002 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14003 210 CONTINUE
14004 WTSUMC=MAX(0.0001D0,WTSUMC)
14005 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14006
14007C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14008 NTRY2=0
14009 220 NTRY2=NTRY2+1
14010 IF(NTRY2.GT.500) THEN
14011 MINT(51)=1
14012 RETURN
14013 ENDIF
14014 IF(MCEV.EQ.1) THEN
14015 IF(MSTP(64).LE.0) THEN
14016 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14017 ELSEIF(MSTP(64).EQ.1) THEN
14018 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14019 ELSE
14020 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14021 ENDIF
14022 ENDIF
14023 IF(MEEV.EQ.1) THEN
14024 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14025 & (PARU(101)*FWTE*WTSUME*TEMX)))
14026 ELSEIF(MEEV.EQ.2) THEN
14027 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14028 ENDIF
14029
14030C...Translate t into Q2 scale; choose between QCD and QED evolution.
14031 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14032 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14033 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14034C...Ensure that Q2 is above threshold for charm/bottom.
14035 KFLCB=IABS(KFLB)
14036 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14037 &MCEV.EQ.1) THEN
14038 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14039 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14040 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14041 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14042 ENDIF
14043 ENDIF
14044 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14045 &MEEV.EQ.2) THEN
14046 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14047 ENDIF
14048 MCE=0
14049 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14050 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14051 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14052 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14053 IF(Q2EB.GT.Q2MNE) MCE=2
14054 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14055 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14056 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14057 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14058 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14059 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14060 MCE=1
14061 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14062 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14063 ELSE
14064 MCE=2
14065 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14066 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14067 ENDIF
14068
14069C...Evolution possibly ended. Update t values.
14070 IF(MCE.EQ.0) THEN
14071 Q2B=0D0
14072 GOTO 260
14073 ELSEIF(MCE.EQ.1) THEN
14074 Q2B=Q2CB
14075 Q2REF=FQ2C*Q2B
14076 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14077 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14078 ELSE
14079 Q2B=Q2EB
14080 Q2REF=Q2B
14081 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14082 ENDIF
14083
14084C...Select flavour for branching parton.
14085 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14086 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14087 KFLA=-25
14088 240 KFLA=KFLA+1
14089 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14090 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14091 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14092 IF(KFLA.EQ.25) THEN
14093 Q2B=0D0
14094 GOTO 260
14095 ENDIF
14096
14097C...Choose z value and corrective weight.
14098 WTZ=0D0
14099C...q -> q + g or q -> q + gamma.
14100 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14101 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14102 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14103 WTZ=0.5D0*(1D0+Z**2)
14104C...q -> g + q.
14105 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14106 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14107 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14108C...f -> f + gamma.
14109 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14110 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14111 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14112 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14113 ELSE
14114 Z=XB+XB*(XEE/(1D0-XEE))*
14115 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14116 ENDIF
14117 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14118C...f -> gamma + f.
14119 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
14120 Z=XB+XB*(XEE/(1D0-XEE))*
14121 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14122 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
14123C...f -> W+- + f.
14124 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14125 Z=XB+XB*(XEE/(1D0-XEE))*
14126 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14127 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14128 & (Q2B/(Q2B+PMAS(24,1)**2))
14129C...g -> q + qbar.
14130 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14131 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14132 WTZ=1D0-2D0*Z*(1D0-Z)
14133C...g -> g + g.
14134 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14135 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14136 WTZ=(1D0-Z*(1D0-Z))**2
14137C...gamma -> f + fbar.
14138 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14139 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14140 WTZ=1D0-2D0*Z*(1D0-Z)
14141 ENDIF
14142 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14143
14144C...Option with resummation of soft gluon emission as effective z shift.
14145 IF(MCE.EQ.1) THEN
14146 IF(MSTP(65).GE.1) THEN
14147 RSOFT=6D0
14148 IF(KFLB.NE.21) RSOFT=8D0/3D0
14149 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14150 IF(Z.LE.XB) GOTO 220
14151 ENDIF
14152
14153C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14154 IF(MSTP(64).GE.2) THEN
14155 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14156 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14157 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14158 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14159 ENDIF
14160 ENDIF
14161
14162C...Remove kinematically impossible branchings.
14163 UHAT=Q2B-DSH*(1D0-Z)/Z
14164 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14165
14166C...Select phi angle of branching at random.
14167 PHIBR=PARU(2)*PYR(0)
14168
14169C...Matrix-element corrections for some processes.
14170 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14171 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14172 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14173 WTZ=WTZ*WTME/WTFF
14174 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14175 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14176 WTZ=WTZ*WTME/WTGF
14177 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14178 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14179 WTZ=WTZ*WTME/WTFG
14180 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14181 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14182 WTZ=WTZ*WTME/WTGG
14183 ENDIF
14184 ENDIF
14185
14186C...Impose angular constraint in first branching from interference
14187C...with final state partons.
14188 IF(MCE.EQ.1) THEN
14189 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14190 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14191 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14192 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14193 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14194 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14195 ENDIF
14196 ENDIF
14197
14198C...Option with angular ordering requirement.
14199 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14200 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14201 IF(THE2T.GT.THE2(JT)) GOTO 220
14202 ENDIF
14203 ENDIF
14204
14205C...Weighting with new parton distributions.
14206 MINT(105)=MINT(102+JT)
14207 MINT(109)=MINT(106+JT)
14208 VINT(120)=VINT(2+JT)
14209 IF(MINT(31).GE.2) MINT(30)=JT
14210C.... ALICE
14211C.... Store side in MINT(124)
14212 MINT(124) = JT
14213C....
14214 IF(MSTP(57).LE.1) THEN
14215 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14216 ELSE
14217 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14218 ENDIF
14219 XFBN=XFN(KFLB)
14220 IF(XFBN.LT.1D-20) THEN
14221 IF(KFLA.EQ.KFLB) THEN
14222 TEVCB=TEVCBS
14223 TEVEB=TEVEBS
14224 WTAPC(KFLB)=0D0
14225 WTAPE(KFLB)=0D0
14226 GOTO 200
14227 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14228 TEVCB=0.5D0*(TEVCBS+TEVCB)
14229 GOTO 230
14230 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14231 TEVEB=0.5D0*(TEVEBS+TEVEB)
14232 GOTO 230
14233 ELSE
14234 XFBN=1D-10
14235 XFN(KFLB)=XFBN
14236 ENDIF
14237 ENDIF
14238 DO 250 KFL=-25,25
14239 XFB(KFL)=XFN(KFL)
14240 250 CONTINUE
14241 XA=XB/Z
14242C.... ALICE
14243C.... Store side in MINT(124)
14244 MINT(124) = JT
14245C....
14246 IF(MINT(31).GE.2) MINT(30)=JT
14247 IF(MSTP(57).LE.1) THEN
14248 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14249 ELSE
14250 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14251 ENDIF
14252 XFAN=XFA(KFLA)
14253 IF(XFAN.LT.1D-20) GOTO 200
14254 WTSFA=WTSF(KFLA)
14255 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14256
14257C...Define two hard scatterers in their CM-frame.
14258 260 IF(N.EQ.NS+2) THEN
14259 DQ2(JT)=Q2B
14260 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14261 DO 280 JR=1,2
14262 I=NS+JR
14263 IF(JR.EQ.1) IPO=IPUS1
14264 IF(JR.EQ.2) IPO=IPUS2
14265 DO 270 J=1,5
14266 K(I,J)=0
14267 P(I,J)=0D0
14268 V(I,J)=0D0
14269 270 CONTINUE
14270 K(I,1)=14
14271 K(I,2)=KFLS(JR+2)
14272 K(I,4)=IPO
14273 K(I,5)=IPO
14274 P(I,3)=DPLCM*(-1)**(JR+1)
14275 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14276 P(I,5)=-SQRT(DQ2(JR))
14277 K(IPO,1)=14
14278 K(IPO,3)=I
14279 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14280 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14281 MCT(I,1)=MCT(IPO,1)
14282 MCT(I,2)=MCT(IPO,2)
14283 280 CONTINUE
14284
14285C...Find maximum allowed mass of timelike parton.
14286 ELSEIF(N.GT.NS+2) THEN
14287 JR=3-JT
14288 DQ2(3)=Q2B
14289 DPC(1)=P(IS(1),4)
14290 DPC(2)=P(IS(2),4)
14291 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14292 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14293 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14294 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14295 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14296 IKIN=0
14297 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14298 & 1D-10*DPD(1)) IKIN=1
14299 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14300 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14301 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14302 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14303
14304C...Generate timelike parton shower (if required).
14305 IT=N
14306 DO 290 J=1,5
14307 K(IT,J)=0
14308 P(IT,J)=0D0
14309 V(IT,J)=0D0
14310 290 CONTINUE
14311C...f -> f + g (gamma).
14312 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14313 K(IT,2)=21
14314 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14315C...f -> g (gamma, W+-) + f.
14316 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14317 K(IT,2)=KFLB
14318 IF(KFLS(JT+2).EQ.24) THEN
14319 K(IT,2)=-12
14320 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14321 K(IT,2)=12
14322 ENDIF
14323C...g (gamma) -> f + fbar, g + g.
14324 ELSE
14325 K(IT,2)=-KFLS(JT+2)
14326 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14327 ENDIF
14328 K(IT,1)=3
14329 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14330 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14331 P(IT,5)=PYMASS(K(IT,2))
14332 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14333 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14334 MSTJ48=MSTJ(48)
14335 PARJ85=PARJ(85)
14336 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14337 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14338 IF(MSTP(63).EQ.1) THEN
14339 Q2TIM=DMSMA
14340 ELSEIF(MSTP(63).EQ.2) THEN
14341 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14342 ELSE
14343 Q2TIM=DMSMA
14344 MSTJ(48)=1
14345 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14346 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14347 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14348 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14349 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14350 ENDIF
14351C...Only do timelike shower here if using PYSHOW
14352 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14353 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14354 ENDIF
14355 MSTJ(48)=MSTJ48
14356 PARJ(85)=PARJ85
14357 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14358 ENDIF
14359
14360C...Reconstruct kinematics of branching: timelike parton shower.
14361 DMS=P(IT,5)**2
14362 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14363 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14364 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14365 & (4D0*DSH*DPC(3)**2)
14366 IF(DPT2.LT.0D0) GOTO 100
14367 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14368 & DSHR)/DPC(3)-DPC(3)
14369 P(IT,1)=SQRT(DPT2)
14370 P(IT,3)=DPB(1)*(-1)**(JT+1)
14371 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14372 IF(N.GE.IT+1) THEN
14373 DPB(1)=SQRT(DPB(1)**2+DPT2)
14374 DPB(2)=SQRT(DPB(1)**2+DMS)
14375 DPB(3)=P(IT+1,3)
14376 DPB(4)=SQRT(DPB(3)**2+DMS)
14377 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14378 & DPB(1))
14379 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14380 THE=PYANGL(P(IT,3),P(IT,1))
14381 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14382 ENDIF
14383
14384C...Reconstruct kinematics of branching: spacelike parton.
14385 DO 300 J=1,5
14386 K(N+1,J)=0
14387 P(N+1,J)=0D0
14388 V(N+1,J)=0D0
14389 300 CONTINUE
14390 K(N+1,1)=14
14391 K(N+1,2)=KFLB
14392 P(N+1,1)=P(IT,1)
14393 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14394 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14395 P(N+1,5)=-SQRT(DQ2(3))
14396 MCT(N+1,1)=0
14397 MCT(N+1,2)=0
14398
14399C...Define colour flow of branching.
14400 K(IS(JT),3)=N+1
14401 K(IT,3)=N+1
14402 IM1=N+1
14403 IM2=N+1
14404C...f -> f + gamma (Z, W).
14405 IF(IABS(K(IT,2)).GE.22) THEN
14406 K(IT,1)=1
14407 ID1=IS(JT)
14408 ID2=IS(JT)
14409C...f -> gamma (Z, W) + f.
14410 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14411 ID1=IT
14412 ID2=IT
14413C...gamma -> q + qbar, g + g.
14414 ELSEIF(K(N+1,2).EQ.22) THEN
14415 ID1=IS(JT)
14416 ID2=IT
14417 IM1=ID2
14418 IM2=ID1
14419C...q -> q + g.
14420 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14421 ID1=IT
14422 ID2=IS(JT)
14423C...q -> g + q.
14424 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14425 ID1=IS(JT)
14426 ID2=IT
14427C...qbar -> qbar + g.
14428 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14429 ID1=IS(JT)
14430 ID2=IT
14431C...qbar -> g + qbar.
14432 ELSEIF(K(N+1,2).LT.0) THEN
14433 ID1=IT
14434 ID2=IS(JT)
14435C...g -> g + g; g -> q + qbar.
14436 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14437 ID1=IS(JT)
14438 ID2=IT
14439 ELSE
14440 ID1=IT
14441 ID2=IS(JT)
14442 ENDIF
14443 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14444 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14445 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14446 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14447 IF(ID1.NE.ID2) THEN
14448 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14449 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14450 ENDIF
14451 N=N+1
14452 IF(K(IT,1).EQ.1) THEN
14453 K(IT,4)=0
14454 K(IT,5)=0
14455 ENDIF
14456
14457C...Boost to new CM-frame.
14458 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14459 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14460 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14461 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14462 IR=N+(JT-1)*(IS(1)-N)
14463 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14464 & 0D0,0D0,0D0)
14465
14466C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14467 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14468 NPART=NPART+1
14469 IPART(NPART)=IT
14470 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14471 ENDIF
14472
14473C...Global statistics.
14474 MINT(352)=MINT(352)+1
14475 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14476 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14477
14478 ENDIF
14479
14480C...Update kinematics variables.
14481 IS(JT)=N
14482 DQ2(JT)=Q2B
14483 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14484 DSH=DSHZ
14485
14486C...Save quantities; loop back.
14487 Q2S(JT)=Q2B
14488 DPHI(JT)=PHIBR
14489 MCESV(JT)=MCE
14490 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14491 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14492 KFLS(JT+2)=KFLS(JT)
14493 KFLS(JT)=KFLA
14494 XS(JT)=XA
14495 ZS(JT)=Z
14496 DO 310 KFL=-25,25
14497 XFS(JT,KFL)=XFA(KFL)
14498 310 CONTINUE
14499 TEVCSV(JT)=TEVCB
14500 TEVESV(JT)=TEVEB
14501 ELSE
14502 MORE(JT)=0
14503 IF(JT.EQ.1) IPU1=N
14504 IF(JT.EQ.2) IPU2=N
14505 ENDIF
14506 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14507 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14508 IF(MSTU(21).GE.1) N=NS
14509 IF(MSTU(21).GE.1) RETURN
14510 ENDIF
14511 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14512
14513C...Boost hard scattering partons to frame of shower initiators.
14514 DO 320 J=1,3
14515 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14516 320 CONTINUE
14517 K(N+2,1)=1
14518 DO 330 J=1,5
14519 P(N+2,J)=P(NS+1,J)
14520 330 CONTINUE
14521 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14522 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14523 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14524 IMIN=MINT(83)+5
14525 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14526 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14527 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14528
14529C...Store user information. Reset Lambda value.
14530 IF(MINT(31).LE.1) THEN
14531 K(IPU1,3)=MINT(83)+3
14532 K(IPU2,3)=MINT(83)+4
14533 ELSE
14534 K(IPU1,3)=MINT(83)+1
14535 K(IPU2,3)=MINT(83)+2
14536 ENDIF
14537 DO 340 JT=1,2
14538 MINT(12+JT)=KFLS(JT)
14539 VINT(140+JT)=XS(JT)
14540 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14541 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14542 340 CONTINUE
14543 PARU(112)=ALAMS
14544
14545 RETURN
14546 END
14547
14548C*********************************************************************
14549
14550C...PYPTIS
14551C...Generates pT-ordered spacelike initial-state parton showers and
14552C...trial joinings.
14553C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14554C... interaction initiators at PT2NOW.
14555C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14556C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14557C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14558C... is below PT2CUT.
14559C... (Also generate test joinings if MSTP(96)=1.)
14560C...MODE= 1: Accept stored shower branching. Update event record etc.
14561C...PT2NOW : Starting (max) PT2 scale for evolution.
14562C...PT2CUT : Lower limit for evolution.
14563C...PT2 : Result of evolution. Generated PT2 for trial emission.
14564C...IFAIL : Status return code. IFAIL=0 when all is well.
14565
14566 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14567
14568C...Double precision and integer declarations.
14569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14570 IMPLICIT INTEGER(I-N)
14571 INTEGER PYK,PYCHGE,PYCOMP
14572C...Parameter statement for maximum size of showers.
14573 PARAMETER (MAXNUR=1000)
14574C...Commonblocks.
14575 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14576 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14577 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14578 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14579 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14580 COMMON/PYINT1/MINT(400),VINT(400)
14581 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14582 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14583 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14584 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14585 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14586 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14587 COMMON/PYCTAG/NCT,MCT(4000,2)
14588 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14589 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14590 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14591C...Local variables
14592 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14593 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14594 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14595 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14596 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14597 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14598C...For check on excessive weights.
14599 CHARACTER CHWT*12
14600
14601C...Only give errors for very large weights, otherwise just warnings
14602 DATA WTEMAX /1.5D0/
14603C...Only give errors for large pT, otherwise just warnings
14604 DATA PTEMAX /5D0/
14605
14606 IFAIL=-1
14607
14608C----------------------------------------------------------------------
14609C...MODE=-1: Initialize initial state showers from scratch, i.e.
14610C...starting from the hardest interaction initiators.
14611 IF (MODE.EQ.-1) THEN
14612C...Set hard scattering SHAT.
14613 SHTNOW(1)=VINT(44)
14614C...Mass thresholds and Lambda for QCD evolution.
14615 AEM2PI=PARU(101)/PARU(2)
14616 RMB=PMAS(5,1)
14617 RMC=PMAS(4,1)
14618 ALAM4=PARP(61)
14619 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14620 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14621 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14622 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14623C...Optionally use Lambda_MC = Lambda_CMW
14624 IF (MSTP(64).EQ.3) THEN
14625 ALAM5 = ALAM5 * 1.569
14626 ALAM4 = ALAM4 * 1.618
14627 ALAM3 = ALAM3 * 1.661
14628 ENDIF
14629 RMB2=RMB**2
14630 RMC2=RMC**2
14631C...Massive quark forced creation threshold (in M**2).
14632 TMIN=1.01D0
14633C...Set upper limit for X (ensures some X left for beam remnant).
14634 XMXC=1D0-2D0*PARP(111)/VINT(1)
14635
14636 IF (MSTP(61).GE.1) THEN
14637C...Initial values: flavours, momenta, virtualities.
14638 DO 100 JS=1,2
14639 NISGEN(JS,1)=0
14640
14641C...Special kinematics check for c/b quarks (that g -> c cbar or
14642C...b bbar kinematically possible).
14643 KFLB=K(IMI(JS,1,1),2)
14644 KFLCB=IABS(KFLB)
14645 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14646C...Check PT2MAX > mQ^2
14647 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14648 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14649 & 'No Q creation possible.')
14650 MINT(51)=1
14651 RETURN
14652 ELSE
14653C...Check for physical z values (m == MQ / sqrt(s))
14654C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14655 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14656 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14657 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14658 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14659 & 'Q creation.')
14660 MINT(51)=1
14661 RETURN
14662 ENDIF
14663 ENDIF
14664 ENDIF
14665 100 CONTINUE
14666 ENDIF
14667
14668 MINT(354)=0
14669C...Zero joining array
14670 DO 110 MJ=1,240
14671 MJOIND(1,MJ)=0
14672 MJOIND(2,MJ)=0
14673 110 CONTINUE
14674
14675C----------------------------------------------------------------------
14676C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14677C...MINT(30). Store if emission PT2 scale is largest so far.
14678C...Also generate test joinings if MSTP(96)=1.
14679 ELSEIF(MODE.EQ.0) THEN
14680 IFAIL=-1
14681 MECOR=0
14682 ISUB=MINT(1)
14683 JS=MINT(30)
14684C...No shower for structureless beam
14685 IF (MINT(44+JS).EQ.1) RETURN
14686 MI=MINT(36)
14687 SHAT=VINT(44)
14688C...Absolute shower max scale = VINT(56)
14689 PT2=MIN(PT2NOW,VINT(56))
14690 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14691C...Define for which processes ME corrections have been implemented.
14692 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14693 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14694 & .142.OR.ISUB.EQ.144) MECOR=1
14695 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14696 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14697C...Calculate preweighting factor for ME-corrected processes.
14698 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14699 ENDIF
14700C...Basic info on daughter for which to find mother.
14701 KFLB=K(IMI(JS,MI,1),2)
14702 KFLBA=IABS(KFLB)
14703C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14704C...second companion.
14705 KSVCB=MAX(-1,IMI(JS,MI,2))
14706C...Treat "first" companion of a pair like an ordinary sea quark
14707C...(except that creation diagram is not allowed)
14708 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14709C...X (rescaled to [0,1])
14710 XB=XMI(JS,MI)/VINT(142+JS)
14711C...Massive quarks (use physical masses.)
14712 RMQ2=0D0
14713 MQMASS=0
14714 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14715 RMQ2=RMC2
14716 IF (KFLBA.EQ.5) RMQ2=RMB2
14717C...Special threshold treatment for non-photon beams
14718 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14719 ENDIF
14720
14721C...Flags for parton distribution calls.
14722 MINT(105)=MINT(102+JS)
14723 MINT(109)=MINT(106+JS)
14724 VINT(120)=VINT(2+JS)
14725
14726C.... ALICE
14727C.... Store side in MINT(124)
14728 MINT(124) = JS
14729C....
14730C...Calculate initial parton distribution weights.
14731 IF(XB.GE.XMXC) THEN
14732 RETURN
14733 ELSEIF(MQMASS.EQ.0) THEN
14734 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14735 ELSE
14736C...Initialize massive quark PT2 dependent pdf underestimate.
14737 PT20=PT2
14738 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14739C.!.Tentative treatment of massive valence quarks.
14740 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14741 XG0=XFB(21)
14742 TPM0=LOG(PT20/RMQ2)
14743 WPDF0=TPM0*XG0/XQ0
14744 ENDIF
14745 IF (KFLBA.LE.6) THEN
14746C...For quarks, only include respective sea, val, or cmp part.
14747 IF (KSVCB.LE.0) THEN
14748 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14749 ELSE
14750C...Find companion's companion
14751 MISEA=0
14752 120 MISEA=MISEA+1
14753 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14754 XS=XMI(JS,MISEA)
14755 XREM=VINT(142+JS)
14756 YS=XS/(XREM+XS)
14757C...Momentum fraction of the companion quark.
14758C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14759 YB=XB*(1D0-YS)
14760 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14761 ENDIF
14762 ENDIF
14763
14764C...Determine overestimated z range: switch at c and b masses.
14765 130 IF (PT2.GT.TMIN*RMB2) THEN
14766 IZRG=3
14767 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14768 B0=23D0/6D0
14769 ALAM2=ALAM5**2
14770 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14771 IZRG=2
14772 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14773 B0=25D0/6D0
14774 ALAM2=ALAM4**2
14775 ELSE
14776 IZRG=1
14777 PT2MNE=PT2CUT
14778 B0=27D0/6D0
14779 ALAM2=ALAM3**2
14780 ENDIF
14781C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14782 ALAM2=ALAM2/PARP(64)
14783C...Overestimated ZMAX:
14784 IF (MQMASS.EQ.0) THEN
14785C...Massless
14786 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14787 & /PT2MNE)-1D0)
14788 ELSE
14789C...Massive (limit for bremsstrahlung diagram > creation)
14790 FMQ=SQRT(RMQ2/SHTNOW(MI))
14791 ZMAX=1D0/(1D0+FMQ)
14792 ENDIF
14793 ZMIN=XB/XMXC
14794
14795C...If kinematically impossible then do not evolve.
14796 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14797
14798C...Reset Altarelli-Parisi and PDF weights.
14799 DO 140 KFL=-5,5
14800 WTAP(KFL)=0D0
14801 WTPDF(KFL)=0D0
14802 140 CONTINUE
14803 WTAP(21)=0D0
14804 WTPDF(21)=0D0
14805C...Zero joining weights and compute X(partner) and X(mother) values.
14806 IF (MSTP(96).NE.0) THEN
14807 NJN=0
14808 DO 150 MJ=1,MINT(31)
14809 WTAPJ(MJ)=0D0
14810 WTPDFJ(MJ)=0D0
14811 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14812 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14813 & +XMI(JS,MI))
14814 150 CONTINUE
14815 ENDIF
14816
14817C...Approximate Altarelli-Parisi weights (integrated AP dz).
14818C...q -> q, g -> q or q -> q + gamma (already set which).
14819 IF(KFLBA.LE.5) THEN
14820C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14821 IF (KSVCB.LT.0) THEN
14822 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14823 ELSE
14824 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14825 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14826 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14827 ENDIF
14828 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14829 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14830 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14831 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14832 WTAP(KFLB)=WTFF*WTAP(KFLB)
14833 WTAP(21)=WTGF*WTAP(21)
14834 WTAPE=WTFF*WTAPE
14835 ENDIF
14836 IF (KSVCB.GE.1) THEN
14837C...Kill normal creation but add joining diagrams for cmp quark.
14838 WTAP(21)=0D0
14839 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14840 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14841 & " quark here. Not handled yet, giving up!")
14842 PT2=0D0
14843 MINT(51)=1
14844 RETURN
14845 ENDIF
14846C...Check for possible joinings
14847 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14848C...Find companion's companion.
14849 MJ=0
14850 160 MJ=MJ+1
14851 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14852 IF (MJOIND(JS,MJ).EQ.0) THEN
14853 Y(MI)=YB+YS
14854 Z=YB/Y(MI)
14855 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14856 IF (WTAPJ(MJ).GT.1D-6) THEN
14857 NJN=1
14858 ELSE
14859 WTAPJ(MJ)=0D0
14860 ENDIF
14861 ENDIF
14862C...Add trial gluon joinings.
14863 DO 170 MJ=1,MINT(31)
14864 KFLC=K(IMI(JS,MJ,1),2)
14865 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14866 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14867 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14868 IF (WTAPJ(MJ).GT.1D-6) THEN
14869 NJN=NJN+1
14870 ELSE
14871 WTAPJ(MJ)=0D0
14872 ENDIF
14873 170 CONTINUE
14874 ENDIF
14875 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14876C...Kill creation diagram for val quarks and sea quarks with companions.
14877 WTAP(21)=0D0
14878 ELSEIF (MQMASS.EQ.0) THEN
14879C...Extra safety factor for massless sea quark creation.
14880 WTAP(21)=WTAP(21)*1.25D0
14881 ENDIF
14882
14883C... q -> g, g -> g.
14884 ELSEIF(KFLB.EQ.21) THEN
14885C...Here we decide later whether a quark picked up is valence or
14886C...sea, so we maintain the extra factor sqrt(z) since we deal
14887C...with the *sum* of sea and valence in this context.
14888 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14889C...new: do not allow backwards evol to pick up heavy flavour.
14890 DO 180 KFL=1,MIN(3,MSTP(58))
14891 WTAP(KFL)=WTAPQ
14892 WTAP(-KFL)=WTAPQ
14893 180 CONTINUE
14894 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14895 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14896 WTAPQ=WTFG*WTAPQ
14897 WTAP(21)=WTGG*WTAP(21)
14898 ENDIF
14899C...Check for possible joinings (companions handled separately above)
14900 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14901 & THEN
14902 DO 190 MJ=1,MINT(31)
14903 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14904 KSVCC=IMI(JS,MJ,2)
14905 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14906 IF (KSVCC.GE.1) GOTO 190
14907 KFLC=K(IMI(JS,MJ,1),2)
14908C...Only try g -> g + g once.
14909 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14910 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14911 IF (KFLC.EQ.21) THEN
14912 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14913 ELSE
14914 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14915 ENDIF
14916 IF (WTAPJ(MJ).GT.1D-6) THEN
14917 NJN=NJN+1
14918 ELSE
14919 WTAPJ(MJ)=0D0
14920 ENDIF
14921 190 CONTINUE
14922 ENDIF
14923 ENDIF
14924
14925C...Initialize massive quark evolution
14926 IF (MQMASS.NE.0) THEN
14927 RML=(RMQ2+VINT(18))/ALAM2
14928 TML=LOG(RML)
14929 TPL=LOG((PT2+VINT(18))/ALAM2)
14930 TPM=LOG((PT2+VINT(18))/RMQ2)
14931 WN=WTAP(21)*WPDF0/B0
14932 ENDIF
14933
14934
14935C...Loopback point for iteration
14936 NTRY=0
14937 NTHRES=0
14938 200 NTRY=NTRY+1
14939 IF(NTRY.GT.500) THEN
14940 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14941 MINT(51)=1
14942 RETURN
14943 ENDIF
14944
14945C... Calculate PDF weights and sum for evolution rate.
14946 WTSUM=0D0
14947 XFBO=MAX(1D-10,XFB(KFLB))
14948 DO 210 KFL=-5,5
14949 WTPDF(KFL)=XFB(KFL)/XFBO
14950 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14951 210 CONTINUE
14952C...Only add gluon mother diagram for massless KFLB.
14953 IF(MQMASS.EQ.0) THEN
14954 WTPDF(21)=XFB(21)/XFBO
14955 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14956 ENDIF
14957 WTSUM=MAX(0.0001D0,WTSUM)
14958 WTSUMS=WTSUM
14959C...Add joining diagrams where applicable.
14960 WTJOIN=0D0
14961 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14962 DO 220 MJ=1,MINT(31)
14963 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14964 WTPDFJ(MJ)=1D0/XFBO
14965C...x and x*pdf (+ sea/val) for parton C.
14966 KFLC=K(IMI(JS,MJ,1),2)
14967 KFLCA=IABS(KFLC)
14968 KSVCC=MAX(-1,IMI(JS,MJ,2))
14969 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14970 MINT(30)=JS
14971 MINT(36)=MJ
14972C.... ALICE
14973C.... Store side in MINT(124)
14974 MINT(124) = JS
14975C....
14976 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14977 MINT(36)=MI
14978 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14979 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14980 ELSEIF (KSVCC.GE.1) THEN
14981 print*, 'error! parton C is companion!'
14982 ENDIF
14983 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14984C...x and x*pdf (+ sea/val) for parton A.
14985 KFLA=21
14986 KSVCA=0
14987 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14988 KFLA=KFLB
14989 KSVCA=KSVCB
14990 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14991 KFLA=KFLC
14992 KSVCA=KSVCC
14993 ENDIF
14994 MINT(30)=JS
14995C.... ALICE
14996C.... Store side in MINT(124)
14997 MINT(124) = JS
14998C....
14999 IF (KSVCA.LE.0) THEN
15000C...Consider C the "evolved" parton if B is gluon. Val/sea
15001C...counting will then be done correctly in PYPDFU.
15002 IF (KFLBA.EQ.21) MINT(36)=MJ
15003 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15004 MINT(36)=MI
15005 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15006 ELSE
15007C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15008 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15009 ENDIF
15010 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15011 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15012 220 CONTINUE
15013 ENDIF
15014
15015C...Pick normal pT2 (in overestimated z range).
15016 230 PT2OLD=PT2
15017 WTSUM=WTSUMS
15018 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15019 KFLC=21
15020
15021C...Evolve q -> q gamma separately, pick it if larger pT.
15022 IF(KFLBA.LE.5) THEN
15023 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15024 IF(PT2QED.GT.PT2) THEN
15025 PT2=PT2QED
15026 KFLC=22
15027 KFLA=KFLB
15028 ENDIF
15029 ENDIF
15030
15031C... Evolve massive quark creation separately.
15032 MCRQQ=0
15033 IF (MQMASS.NE.0) THEN
15034 if (WN .eq. 0.) THEN
15035 ARG = -1.
15036 ELSE
15037 ARG = TPM/(TPL*PYR(0)**(-TML/WN)-TPM)
15038 ENDIF
15039 PT2CR=(RMQ2+VINT(18))*(RML**ARG)-VINT(18)
15040C... Ensure mininimum PT2CR and force creation near threshold.
15041 IF (PT2CR.LT.TMIN*RMQ2) THEN
15042 NTHRES=NTHRES+1
15043 IF (NTHRES.GT.50) THEN
15044 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15045 & 'massive quark creation. Gave up trying.')
15046 MINT(51)=1
15047C...Special return code if failing before any evolution at all: bad event
15048 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15049 RETURN
15050 ENDIF
15051 PT2=0D0
15052 PT2CR=TMIN*RMQ2
15053 MCRQQ=2
15054 ENDIF
15055C... Select largest PT2 (brems or creation):
15056 IF (PT2CR.GT.PT2) THEN
15057 MCRQQ=MAX(MCRQQ,1)
15058 WTSUM=0D0
15059 PT2=PT2CR
15060 KFLA=21
15061 ELSE
15062 MCRQQ=0
15063 KFLA=KFLB
15064 ENDIF
15065C... Compute logarithms for this PT2
15066 TPL=LOG((PT2+VINT(18))/ALAM2)
15067 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15068 WTCRQQ=TPM/LOG(PT2/RMQ2)
15069 ENDIF
15070
15071C...Evolve joining separately
15072 MJOIN=0
15073 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15074 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15075 & -VINT(18)
15076 IF (PT2JN.GE.PT2) THEN
15077 MJOIN=1
15078 PT2=PT2JN
15079 ENDIF
15080 ENDIF
15081
15082C...Loopback if crossed c/b mass thresholds.
15083 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15084 PT2=RMB2
15085 GOTO 130
15086 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15087 PT2=RMC2
15088 GOTO 130
15089 ENDIF
15090
15091C...Speed up shower. Skip if higher-PT acceptable branching
15092C...already found somewhere else.
15093C...Also finish if below lower cutoff.
15094
15095 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
15096
15097C...Select parton A flavour (massive Q handled above.)
15098 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15099 WTRAN=PYR(0)*WTSUM
15100 KFLA=-6
15101 240 KFLA=KFLA+1
15102 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15103 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15104 IF(KFLA.EQ.6) KFLA=21
15105 ELSEIF (MJOIN.EQ.1) THEN
15106C...Tentative joining accept/reject.
15107 WTRAN=PYR(0)*WTJOIN
15108 MJ=0
15109 250 MJ=MJ+1
15110 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15111 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15112 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15113 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15114 & ' Rejected.')
15115 GOTO 230
15116 ENDIF
15117C...x*pdf (+ sea/val) at new pT2 for parton B.
15118 IF (KSVCB.LE.0) THEN
15119 MINT(30)=JS
15120C.... ALICE
15121C.... Store side in MINT(124)
15122 MINT(124) = JS
15123C....
15124 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15125 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15126 ELSE
15127C...Companion distributions do not evolve.
15128 XFB(KFLB)=XFBO
15129 ENDIF
15130 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15131 KFLC=K(IMI(JS,MJ,1),2)
15132 KFLCA=IABS(KFLC)
15133 KSVCC=MAX(-1,IMI(JS,MJ,2))
15134 IF (KSVCB.GE.1) KSVCC=-1
15135C...x*pdf (+ sea/val) at new pT2 for parton C.
15136 MINT(30)=JS
15137 MINT(36)=MJ
15138C.... ALICE
15139C.... Store side in MINT(124)
15140 MINT(124) = JS
15141C....
15142 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15143 MINT(36)=MI
15144 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15145 WTVETO=WTVETO/XFJ(KFLC)
15146C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15147 KFLA=21
15148 KSVCA=0
15149 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15150 KFLA=KFLB
15151 KSVCA=KSVCB
15152 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15153 KFLA=KFLC
15154 KSVCA=KSVCC
15155 ENDIF
15156 IF (KSVCA.LE.0) THEN
15157 MINT(30)=JS
15158C.... ALICE
15159C.... Store side in MINT(124)
15160 MINT(124) = JS
15161C....
15162 IF (KFLB.EQ.21) MINT(36)=MJ
15163 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15164 MINT(36)=MI
15165 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15166 ELSE
15167 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15168 ENDIF
15169 WTVETO=WTVETO*XFJ(KFLA)
15170C...Monte Carlo veto.
15171 IF (WTVETO.LT.PYR(0)) GOTO 200
15172C...If accept, save PT2 of this joining.
15173 IF (PT2.GT.PT2MX) THEN
15174 PT2MX=PT2
15175 JSMX=2+JS
15176 MJN1MX=MJ
15177 MJN2MX=MI
15178 WTAPJ(MJ)=0D0
15179 NJN=0
15180 ENDIF
15181C...Exit and continue evolution.
15182 GOTO 390
15183 ENDIF
15184 KFLAA=IABS(KFLA)
15185
15186C...Choose z value (still in overestimated range) and corrective weight.
15187C...Unphysical z will be rejected below when Q2 has is computed.
15188 WTZ=0D0
15189
15190C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15191C...q -> q + g or q -> q + gamma (already set which).
15192 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15193 IF (KSVCB.LT.0) THEN
15194 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15195 ELSE
15196 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15197 Z=((1-ZFAC)/(1+ZFAC))**2
15198 ENDIF
15199 WTZ=0.5D0*(1D0+Z**2)
15200C...Massive weight correction.
15201 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15202C...Valence quark weight correction (extra sqrt)
15203 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15204
15205C...q -> g + q.
15206C...NB: MQ>0 not yet implemented. Forced absent above.
15207 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15208 KFLC=KFLA
15209 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15210 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15211
15212C...g -> q + qbar.
15213 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15214 KFLC=-KFLB
15215 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15216 WTZ=Z**2+(1D0-Z)**2
15217C...Massive correction
15218 IF (MQMASS.NE.0) THEN
15219 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15220C...Extra safety margin for light sea quark creation
15221 ELSEIF (KSVCB.LT.0) THEN
15222 WTZ=WTZ/1.25D0
15223 ENDIF
15224
15225C...g -> g + g.
15226 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15227 KFLC=21
15228 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15229 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15230 WTZ=(1D0-Z*(1D0-Z))**2
15231 ENDIF
15232
15233C...Derive Q2 from pT2.
15234 Q2B=PT2/(1D0-Z)
15235 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15236
15237C...Loopback if outside allowed z range for given pT2.
15238 RM2C=PYMASS(KFLC)**2
15239 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15240 IF (PT2ADJ.LT.1D-6) GOTO 230
15241
15242C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15243C...No modification for very first emission if using ME correction
15244 MSTP67 = MSTP(67)
15245 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15246 MSTP67 = 0
15247 ENDIF
15248
15249C...For 1st branching, limit phase space by s-hat with color-partner
15250 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15251 MSIDE=1
15252 IDIP=IMI(JS,MI,1)
15253C...Use anticolor tag for antiquark, or for gluon half the time
15254 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15255 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15256C...Tag
15257 MCTAG=MCT(IDIP,MSIDE)
15258C...Default is to set up phase space using the opposite incoming parton
15259 JDIP=IMI(3-JS,MI,1)
15260 NDIP=0
15261C...Alternatively, look for final-state color partner (pick first if several)
15262 DO 260 IFS=1,NPART
15263 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15264 JDIP=IPART(IFS)
15265 NDIP=NDIP+1
15266 ENDIF
15267 260 CONTINUE
15268C...Compute mass of pair
15269 SDIP=(P(IDIP,4)+P(JDIP,4))**2-(P(IDIP,3)+P(JDIP,3))**2
15270 & -(P(IDIP,2)+P(JDIP,2))**2-(P(IDIP,1)+P(JDIP,1))**2
15271 IF (MSTP67.EQ.1) THEN
15272C...1 Option to completely kill radiation above s_dip * PARP(67)
15273 IF (4*PT2.GT.PARP(67)*SDIP) GOTO 230
15274 ELSE IF (MSTP67.EQ.2) THEN
15275C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15276C... (-> improved power showers?)
15277 IF (4*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15278 ENDIF
15279
15280C...For subsequent branchings, loopback if nonordered in angle/rapidity
15281 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15282 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15283 & GOTO 230
15284 ENDIF
15285
15286C...Select phi angle of branching at random.
15287 PHI=PARU(2)*PYR(0)
15288
15289C...Matrix-element corrections for some processes.
15290 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15291 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15292 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15293 WTZ=WTZ*WTME/WTFF
15294 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15295 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15296 WTZ=WTZ*WTME/WTGF
15297 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15298 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15299 WTZ=WTZ*WTME/WTFG
15300 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15301 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15302 WTZ=WTZ*WTME/WTGG
15303 ENDIF
15304 ENDIF
15305
15306C...Parton distributions at new pT2 but old x.
15307 MINT(30)=JS
15308C.... ALICE
15309C.... Store side in MINT(124)
15310 MINT(124) = JS
15311C....
15312 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15313C...Treat val and cmp separately
15314 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15315 IF (KSVCB.GE.1)
15316 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15317 XFBN=XFN(KFLB)
15318 IF(XFBN.LT.1D-20) THEN
15319 IF(KFLA.EQ.KFLB) THEN
15320 WTAP(KFLB)=0D0
15321 GOTO 200
15322 ELSE
15323 XFBN=1D-10
15324 XFN(KFLB)=XFBN
15325 ENDIF
15326 ENDIF
15327 DO 270 KFL=-5,5
15328 XFB(KFL)=XFN(KFL)
15329 270 CONTINUE
15330 XFB(21)=XFN(21)
15331
15332C...Parton distributions at new pT2 and new x.
15333 XA=XB/Z
15334 MINT(30)=JS
15335C.... ALICE
15336C.... Store side in MINT(124)
15337 MINT(124) = JS
15338C....
15339 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15340 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15341C...q -> q + g: only consider respective sea, val, or cmp content.
15342 IF (KSVCB.LE.0) THEN
15343 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15344 ELSE
15345 YA=XA*(1D0-YS)
15346 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15347 ENDIF
15348 ENDIF
15349 XFAN=XFA(KFLA)
15350 IF(XFAN.LT.1D-20) THEN
15351 GOTO 200
15352 ENDIF
15353
15354C...If weighting fails continue evolution.
15355 WTTOT=0D0
15356 IF (MCRQQ.EQ.0) THEN
15357 WTPDFA=1D0/WTPDF(KFLA)
15358 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15359 ELSEIF(MCRQQ.EQ.1) THEN
15360 WTPDFA=TPM/WPDF0
15361 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15362 XBEST=TPM/TPM0*XQ0
15363 ELSEIF(MCRQQ.EQ.2) THEN
15364C...Force massive quark creation.
15365 WTTOT=1D0
15366 ENDIF
15367
15368C...Loop back if trial emission fails.
15369 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15370 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15371 IF(WTTOT.LT.0D0) THEN
15372 WRITE(CHWT,'(1P,E12.4)') WTTOT
15373 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15374 ELSEIF(WTTOT.GT.WTACC) THEN
15375 WRITE(CHWT,'(1P,E12.4)') WTTOT
15376 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15377C...Too high weight: write out as error, but do not update error counter
15378 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15379 CALL PYERRM(19,
15380 & '(PYPTIS:) Weight '//CHWT//' above unity')
15381 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15382 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15383 ELSE
15384 CALL PYERRM(9,
15385 & '(PYPTIS:) Weight '//CHWT//' above unity')
15386 ENDIF
15387C...Useful for debugging but commented out for distribution:
15388C print*, 'JS, MI',JS, MI
15389C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15390C print*, 'A -> B C',KFLA, KFLB, KFLC
15391C XFAO=XFBO/WTPDFA
15392C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15393 ENDIF
15394
15395C...Save acceptable branching.
15396 IF(PT2.GT.PT2MX) THEN
15397 MIMX=MINT(36)
15398 JSMX=JS
15399 PT2MX=PT2
15400 KFLAMX=KFLA
15401 KFLCMX=KFLC
15402 RM2CMX=RM2C
15403 Q2BMX=Q2B
15404 ZMX=Z
15405 PT2AMX=PT2ADJ
15406 PHIMX=PHI
15407 ENDIF
15408
15409C----------------------------------------------------------------------
15410C...MODE= 1: Accept stored shower branching. Update event record etc.
15411 ELSEIF (MODE.EQ.1) THEN
15412 MI=MIMX
15413 JS=JSMX
15414 SHAT=SHTNOW(MI)
15415 SIDE=3D0-2D0*JS
15416C...Shift down rest of event record to make room for insertion.
15417 IT=IMISEP(MI)+1
15418 IM=IT+1
15419 IS=IMI(JS,MI,1)
15420 DO 290 I=N,IT,-1
15421 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15422 KT1=K(I,4)/MSTU(5)**2
15423 KT2=K(I,5)/MSTU(5)**2
15424 ID1=MOD(K(I,4),MSTU(5))
15425 ID2=MOD(K(I,5),MSTU(5))
15426 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15427 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15428 IF (ID1.GE.IT) ID1=ID1+2
15429 IF (ID2.GE.IT) ID2=ID2+2
15430 IF (IM1.GE.IT) IM1=IM1+2
15431 IF (IM2.GE.IT) IM2=IM2+2
15432 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15433 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15434 DO 280 IX=1,5
15435 K(I+2,IX)=K(I,IX)
15436 P(I+2,IX)=P(I,IX)
15437 V(I+2,IX)=V(I,IX)
15438 280 CONTINUE
15439 MCT(I+2,1)=MCT(I,1)
15440 MCT(I+2,2)=MCT(I,2)
15441 290 CONTINUE
15442 N=N+2
15443C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15444 DO 300 JI=1,MINT(31)
15445 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15446 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15447 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15448 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15449 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15450C...Also update companion pointers to the present mother.
15451 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15452 300 CONTINUE
15453 DO 310 IFS=1,NPART
15454 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15455 310 CONTINUE
15456C...Zero entries dedicated for new timelike and mother partons.
15457 DO 330 I=IT,IT+1
15458 DO 320 J=1,5
15459 K(I,J)=0
15460 P(I,J)=0D0
15461 V(I,J)=0D0
15462 320 CONTINUE
15463 MCT(I,1)=0
15464 MCT(I,2)=0
15465 330 CONTINUE
15466
15467C...Define timelike and new mother partons. History.
15468 K(IT,1)=3
15469 K(IT,2)=KFLCMX
15470 K(IM,1)=14
15471 K(IM,2)=KFLAMX
15472 K(IS,3)=IM
15473 K(IT,3)=IM
15474C...Set mother origin = side.
15475 K(IM,3)=MINT(83)+JS+2
15476 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15477
15478C...Define colour flow of branching.
15479 IM1=IM
15480 IM2=IM
15481C...q -> q + gamma.
15482 IF(K(IT,2).EQ.22) THEN
15483 K(IT,1)=1
15484 ID1=IS
15485 ID2=IS
15486C...q -> q + g.
15487 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15488 ID1=IT
15489 ID2=IS
15490C...q -> g + q.
15491 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15492 ID1=IS
15493 ID2=IT
15494C...qbar -> qbar + g.
15495 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15496 ID1=IS
15497 ID2=IT
15498C...qbar -> g + qbar.
15499 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15500 ID1=IT
15501 ID2=IS
15502C...g -> g + g; g -> q + qbar..
15503 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15504 ID1=IS
15505 ID2=IT
15506 ELSE
15507 ID1=IT
15508 ID2=IS
15509 ENDIF
15510 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15511 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15512 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15513 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15514 IF(ID1.NE.ID2) THEN
15515 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15516 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15517 ENDIF
15518 IF(K(IT,1).EQ.1) THEN
15519 K(IT,4)=0
15520 K(IT,5)=0
15521 ENDIF
15522C...Update IMI and colour tag arrays.
15523 IMI(JS,MI,1)=IM
15524 DO 340 MC=1,2
15525 MCT(IT,MC)=0
15526 MCT(IM,MC)=0
15527 340 CONTINUE
15528 DO 350 JCS=4,5
15529 KCS=JCS
15530C...If mother flag not yet set for spacelike parton, trace it.
15531 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15532 IF(MINT(51).NE.0) RETURN
15533 350 CONTINUE
15534 DO 360 JCS=4,5
15535 KCS=JCS
15536C...If mother flag not yet set for timelike parton, trace it.
15537 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15538 IF(MINT(51).NE.0) RETURN
15539 360 CONTINUE
15540
15541C...Boost recoiling parton to compensate for Q2 scale.
15542 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15543 & (1D0+(1D0+Q2BMX/SHAT)**2)
15544 IR=IMI(3-JS,MI,1)
15545 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15546
15547C...Define system to be rotated and boosted
15548C...(not including the 2 just added partons)
15549C...(but including the docu lines for first interaction)
15550 IMIN=IMISEP(MI-1)+1
15551 IF (MI.EQ.1) IMIN=MINT(83)+5
15552 IMAX=IMISEP(MI)-2
15553
15554C...Rotate back system in phi to compensate for subsequent rotation.
15555 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15556
15557C...Define kinematics of new partons in old frame.
15558 IMAX=IMISEP(MI)
15559 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15560 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15561 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15562 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15563 P(IT,1)=P(IM,1)
15564 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15565 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15566 P(IT,5)=SQRT(RM2CMX)
15567
15568C...Update internal line, now spacelike
15569 P(IS,1)=P(IM,1)-P(IT,1)
15570 P(IS,2)=P(IM,2)-P(IT,2)
15571 P(IS,3)=P(IM,3)-P(IT,3)
15572 P(IS,4)=P(IM,4)-P(IT,4)
15573 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15574C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15575 IF (P(IS,5).LT.0D0) THEN
15576 P(IS,5)=-SQRT(ABS(P(IS,5)))
15577 ELSE
15578 P(IS,5)=SQRT(P(IS,5))
15579 ENDIF
15580
15581C...Boost entire system and rotate to new frame.
15582C...(including docu lines)
15583 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15584 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15585 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15586 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15587 MINT(51)=1
15588 IFAIL=-1
15589 RETURN
15590 ENDIF
15591 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15592 I1=IMI(1,MI,1)
15593 THETA=PYANGL(P(I1,3),P(I1,1))
15594 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15595
15596C...Global statistics.
15597 MINT(352)=MINT(352)+1
15598 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15599 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15600
15601C...Add parton with relevant pT scale for timelike shower.
15602 IF (K(IT,2).NE.22) THEN
15603 NPART=NPART+1
15604 IPART(NPART)=IT
15605 PTPART(NPART)=SQRT(PT2AMX)
15606 ENDIF
15607
15608C...Update saved variables.
15609 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15610 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15611 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15612 PT2SAV(JSMX,MIMX)=PT2MX
15613 ZSAV(JS,MIMX)=ZMX
15614
15615 KSA=IABS(K(IS,2))
15616 KMA=IABS(K(IM,2))
15617 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15618C...Gluon reconstructs to quark.
15619C...Decide whether newly created quark is valence or sea:
15620 MINT(30)=JS
15621 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15622 IF(MINT(51).NE.0) RETURN
15623 ENDIF
15624 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15625C...Quark reconstructs to gluon.
15626C...Now some guy may have lost his companion. Check.
15627 ICMP=IMI(JS,MI,2)
15628 IF (ICMP.GT.0) THEN
15629 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15630 & //' away. Cannot handle that yet. Giving up.')
15631 MINT(51)=1
15632 RETURN
15633 ELSEIF(ICMP.LT.0) THEN
15634C...A sea quark with companion still in BR was reconstructed to a gluon.
15635C...Companion should now be removed from the beam remnant.
15636C...(Momentum integral is automatically updated in next call to PYPDFU.)
15637 ICMP=-ICMP
15638 IFL=-K(IS,2)
15639 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15640 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15641 DO 370 JI=1,MINT(31)
15642 KMI=-IMI(JS,JI,2)
15643 JFL=-K(IMI(JS,JI,1),2)
15644 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15645 & ,2)+1
15646 370 CONTINUE
15647 380 CONTINUE
15648 NVC(JS,IFL)=NVC(JS,IFL)-1
15649 ENDIF
15650C...Set gluon IMI(JS,MI,2) = 0.
15651 IMI(JS,MI,2)=0
15652 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15653C...Quark reconstructing to quark. If sea with companion still in BR
15654C...then update associated x value.
15655C...(Momentum integral is automatically updated in next call to PYPDFU.)
15656 IF (IMI(JS,MI,2).LT.0) THEN
15657 ICMP=-IMI(JS,MI,2)
15658 IFL=-K(IS,2)
15659 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15660 ENDIF
15661 ENDIF
15662
15663 ENDIF
15664
15665C...If reached this point, normal exit.
15666 390 IFAIL=0
15667
15668 RETURN
15669 END
15670
15671C*********************************************************************
15672
15673C...PYMEMX
15674C...Generates maximum ME weight in some initial-state showers.
15675C...Inparameter MECOR: kind of hard scattering process
15676C...Outparameter WTFF: maximum weight for fermion -> fermion
15677C... WTGF: maximum weight for gluon/photon -> fermion
15678C... WTFG: maximum weight for fermion -> gluon/photon
15679C... WTGG: maximum weight for gluon -> gluon
15680
15681 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15682
15683C...Double precision and integer declarations.
15684 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15685 IMPLICIT INTEGER(I-N)
15686 INTEGER PYK,PYCHGE,PYCOMP
15687C...Commonblocks.
15688 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15690 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15691 COMMON/PYINT1/MINT(400),VINT(400)
15692 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15693 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15694
15695C...Default maximum weight.
15696 WTFF=1D0
15697 WTGF=1D0
15698 WTFG=1D0
15699 WTGG=1D0
15700
15701C...Select maximum weight by process.
15702 IF(MECOR.EQ.1) THEN
15703 WTFF=1D0
15704 WTGF=3D0
15705 ELSEIF(MECOR.EQ.2) THEN
15706 WTFG=1D0
15707 WTGG=1D0
15708 ENDIF
15709
15710 RETURN
15711 END
15712
15713C*********************************************************************
15714
15715C...PYMEWT
15716C...Calculates actual ME weight in some initial-state showers.
15717C...Inparameter MECOR: kind of hard scattering process
15718C... IFLCB: flavour combination of branching,
15719C... 1 for fermion -> fermion,
15720C... 2 for gluon/photon -> fermion
15721C... 3 for fermion -> gluon/photon,
15722C... 4 for gluon -> gluon
15723C... Q2: Q2 value of shower branching
15724C... Z: Z value of branching
15725C...In+outparameter PHIBR: azimuthal angle of branching
15726C...Outparameter WTME: actual ME weight
15727
15728 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15729
15730C...Double precision and integer declarations.
15731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15732 IMPLICIT INTEGER(I-N)
15733 INTEGER PYK,PYCHGE,PYCOMP
15734C...Commonblocks.
15735 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15736 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15737 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15738 COMMON/PYINT1/MINT(400),VINT(400)
15739 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15740 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15741
15742C...Default output.
15743 WTME=1D0
15744
15745C...Define kinematics of shower branching in Mandelstam variables.
15746 SQM=VINT(44)
15747 SH=SQM/Z
15748 TH=-Q2
15749 UH=Q2-SQM*(1D0-Z)/Z
15750
15751C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15752 IF(MECOR.EQ.1) THEN
15753 IF(IFLCB.EQ.1) THEN
15754 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15755 ELSEIF(IFLCB.EQ.2) THEN
15756 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15757 ENDIF
15758
15759C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15760 ELSEIF(MECOR.EQ.2) THEN
15761 IF(IFLCB.EQ.3) THEN
15762 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15763 ELSEIF(IFLCB.EQ.4) THEN
15764 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15765 ENDIF
15766
15767C...Matrix-element corrections for q + qbar -> Higgs (h0)
15768 ELSEIF(MECOR.EQ.3) THEN
15769 IF(IFLCB.EQ.2) THEN
15770 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15771 1 (SH**2+2D0*SQM*(SQM-SH))
15772 ENDIF
15773 ENDIF
15774
15775 RETURN
15776 END
15777
15778C*********************************************************************
15779
15780C...PYPTMI
15781C...Handles the generation of additional interactions in the new
15782C...multiple interactions framework.
15783C...MODE=-1 : Initalize MI from scratch.
15784C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15785C... Sudakov for PT2, abort if below PT2CUT.
15786C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15787C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15788C...PT2NOW : Starting (max) PT2 scale for evolution.
15789C...PT2CUT : Lower limit for evolution.
15790C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15791C...IFAIL : Status return code.
15792C... = 0: All is well.
15793C... < 0: Phase space exhausted, generation to be terminated.
15794C... > 0: Additional interaction vetoed, but continue evolution.
15795
15796 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15797C...Double precision and integer declarations.
15798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15799 IMPLICIT INTEGER(I-N)
15800 INTEGER PYK,PYCHGE,PYCOMP
15801C...Parameter statement for maximum size of showers.
15802 PARAMETER (MAXNUR=1000)
15803C...Commonblocks.
15804 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15805 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15807 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15808 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15809 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15810 COMMON/PYINT1/MINT(400),VINT(400)
15811 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15812 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15813 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15814 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15815 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15816 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15817 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15818 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15819 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15820 COMMON/PYCTAG/NCT,MCT(4000,2)
15821C...Local arrays and saved variables.
15822 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15823
15824 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15825 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15826 & /PYISMX/,/PYCTAG/
15827 SAVE XT2FAC,SIGS
15828
15829 IFAIL=0
15830C...Set MI subprocess = QCD 2 -> 2.
15831 ISUB=96
15832
15833C----------------------------------------------------------------------
15834C...MODE=-1: Initialize from scratch
15835 IF (MODE.EQ.-1) THEN
15836C...Initialize PT2 array.
15837 PT2MI(1)=VINT(54)
15838C...Initialize list of incoming beams and partons from two sides.
15839 DO 110 JS=1,2
15840 DO 100 MI=1,240
15841 IMI(JS,MI,1)=0
15842 IMI(JS,MI,2)=0
15843 100 CONTINUE
15844 NMI(JS)=1
15845 IMI(JS,1,1)=MINT(84)+JS
15846 IMI(JS,1,2)=0
15847 XMI(JS,1)=VINT(40+JS)
15848C...Rescale x values to fractions of photon energy.
15849 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15850C...Hard reset: hard interaction initiators motherless by definition.
15851 K(MINT(84)+JS,3)=2+JS
15852 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15853 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15854 110 CONTINUE
15855 IMISEP(0)=MINT(84)
15856 IMISEP(1)=N
15857 IF (MOD(MSTP(81),10).GE.1) THEN
15858 IF(MSTP(82).LE.1) THEN
15859 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15860 & ,5))
15861 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15862 & VINT(317)/(VINT(318)*VINT(320))
15863 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15864 ELSE
15865 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15866 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15867 ENDIF
15868 ENDIF
15869C...Zero entries relating to scatterings beyond the first.
15870 DO 120 MI=2,240
15871 IMI(1,MI,1)=0
15872 IMI(2,MI,1)=0
15873 IMI(1,MI,2)=0
15874 IMI(2,MI,2)=0
15875 IMISEP(MI)=IMISEP(1)
15876 PT2MI(MI)=0D0
15877 XMI(1,MI)=0D0
15878 XMI(2,MI)=0D0
15879 120 CONTINUE
15880C...Initialize factors for PDF reshaping.
15881 DO 140 JS=1,2
15882 KFBEAM(JS)=MINT(10+JS)
15883 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15884 KFABM=IABS(KFBEAM(JS))
15885 KFSBM=ISIGN(1,KFBEAM(JS))
15886
15887C...Zero flavour content of incoming beam particle.
15888 KFIVAL(JS,1)=0
15889 KFIVAL(JS,2)=0
15890 KFIVAL(JS,3)=0
15891C... Flavour content of baryon.
15892 IF(KFABM.GT.1000) THEN
15893 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15894 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15895 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15896C... Flavour content of pi+-, K+-.
15897 ELSEIF(KFABM.EQ.211) THEN
15898 KFIVAL(JS,1)=KFSBM*2
15899 KFIVAL(JS,2)=-KFSBM
15900 ELSEIF(KFABM.EQ.321) THEN
15901 KFIVAL(JS,1)=-KFSBM*3
15902 KFIVAL(JS,2)=KFSBM*2
15903C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15904 ENDIF
15905
15906C...Zero initial valence and companion content.
15907 DO 130 IFL=-6,6
15908 NVC(JS,IFL)=0
15909 130 CONTINUE
15910 140 CONTINUE
15911C...Set up colour line tags starting from hard interaction initiators.
15912 NCT=0
15913C...Reset colour tag array and colour processing flags.
15914 DO 150 I=IMISEP(0)+1,N
15915 MCT(I,1)=0
15916 MCT(I,2)=0
15917 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15918 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15919 150 CONTINUE
15920C... Consider each side in turn.
15921 DO 170 JS=1,2
15922 I1=IMI(JS,1,1)
15923 I2=IMI(3-JS,1,1)
15924 DO 160 JCS=4,5
15925 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15926 & GOTO 160
15927 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15928 KCS=JCS
15929 CALL PYCTTR(I1,KCS,I2)
15930 IF(MINT(51).NE.0) RETURN
15931 160 CONTINUE
15932 170 CONTINUE
15933
15934C...Range checking for companion quark pdf large-x param.
15935 IF (MSTP(87).LT.0) THEN
15936 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15937 & ' MSTP(87)=0')
15938 MSTP(87)=0
15939 ELSEIF (MSTP(87).GT.4) THEN
15940 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15941 & ' MSTP(87)=4')
15942 MSTP(87)=4
15943 ENDIF
15944
15945C----------------------------------------------------------------------
15946C...MODE=0: Generate trial interaction. Return codes:
15947C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15948C...IFAIL = 0: Additional interaction generated at PT2.
15949C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15950 ELSEIF (MODE.EQ.0) THEN
15951C...Abolute MI max scale = VINT(62)
15952 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15953 180 IF(MSTP(82).LE.1) THEN
15954 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15955 IF(XT2.LT.VINT(149)) IFAIL=-2
15956 ELSE
15957 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15958 IFAIL=-3
15959 ELSE
15960 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15961 & LOG(PYR(0)))-VINT(149)
15962 ENDIF
15963 ENDIF
15964C...Also exit if below lower limit or if higher trial branching
15965C...already found.
15966 PT2=0.25D0*VINT(2)*XT2
15967 IF (PT2.LE.PT2CUT) IFAIL=-4
15968 IF (PT2.LE.PT2MX) IFAIL=-5
15969 IF (IFAIL.NE.0) THEN
15970 PT2=0D0
15971 RETURN
15972 ENDIF
15973 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15974 VINT(25)=4D0*PT2/VINT(2)
15975 XT2=VINT(25)
15976
15977C...Choose tau and y*. Calculate cos(theta-hat).
15978 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15979 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15980 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15981 ELSE
15982 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15983 ENDIF
15984 VINT(21)=TAU
15985C...New: require shat > 1.
15986 IF(TAU*VINT(2).LT.1D0) GOTO 180
15987 CALL PYKLIM(2)
15988 RYST=PYR(0)
15989 MYST=1
15990 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15991 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15992 CALL PYKMAP(2,MYST,PYR(0))
15993 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15994
15995C...Check that x not used up. Accept or reject kinematical variables.
15996 X1M=SQRT(TAU)*EXP(VINT(22))
15997 X2M=SQRT(TAU)*EXP(-VINT(22))
15998 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15999 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
16000 CALL PYSIGH(NCHN,SIGS)
16001 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16002 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16003 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16004
16005C...Save if highest PT so far.
16006 IF (PT2.GT.PT2MX) THEN
16007 JSMX=0
16008 MIMX=MINT(31)+1
16009 PT2MX=PT2
16010 ENDIF
16011
16012C----------------------------------------------------------------------
16013C...MODE=1: Generate and save accepted scattering.
16014 ELSEIF (MODE.EQ.1) THEN
16015 PT2=PT2NOW
16016C...Reset K, P, V, and MCT vectors.
16017 DO 200 I=N+1,N+4
16018 DO 190 J=1,5
16019 K(I,J)=0
16020 P(I,J)=0D0
16021 V(I,J)=0D0
16022 190 CONTINUE
16023 MCT(I,1)=0
16024 MCT(I,2)=0
16025 200 CONTINUE
16026
16027 NTRY=0
16028C...Choose flavour of reacting partons (and subprocess).
16029 210 NTRY=NTRY+1
16030 IF (NTRY.GT.50) THEN
16031 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16032 & //'interaction. Giving up!')
16033 MINT(51)=1
16034 RETURN
16035 ENDIF
16036 RSIGS=SIGS*PYR(0)
16037 DO 220 ICHN=1,NCHN
16038 KFL1=ISIG(ICHN,1)
16039 KFL2=ISIG(ICHN,2)
16040 ICONMI=ISIG(ICHN,3)
16041 RSIGS=RSIGS-SIGH(ICHN)
16042 IF(RSIGS.LE.0D0) GOTO 230
16043 220 CONTINUE
16044
16045C...Reassign to appropriate process codes.
16046 230 ISUBMI=ICONMI/10
16047 ICONMI=MOD(ICONMI,10)
16048
16049C...Choose new quark flavour for annihilation graphs
16050 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16051 SH=VINT(21)*VINT(2)
16052 CALL PYWIDT(21,SH,WDTP,WDTE)
16053 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16054 DO 250 I=1,MDCY(21,3)
16055 KFLF=KFDP(I+MDCY(21,2)-1,1)
16056 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16057 IF(RKFL.LE.0D0) GOTO 260
16058 250 CONTINUE
16059 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16060 IF(KFLF.GE.4) GOTO 240
16061 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16062 KFLF=4
16063 ICONMI=ICONMI-2
16064 ELSEIF(ISUBMI.EQ.53) THEN
16065 KFLF=5
16066 ICONMI=ICONMI-4
16067 ENDIF
16068 ENDIF
16069
16070C...Final state flavours and colour flow: default values
16071 JS=1
16072 KFL3=KFL1
16073 KFL4=KFL2
16074 KCC=20
16075 KCS=ISIGN(1,KFL1)
16076
16077 IF(ISUBMI.EQ.11) THEN
16078C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16079 KCC=ICONMI
16080 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16081
16082 ELSEIF(ISUBMI.EQ.12) THEN
16083C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16084 KFL3=ISIGN(KFLF,KFL1)
16085 KFL4=-KFL3
16086 KCC=4
16087
16088 ELSEIF(ISUBMI.EQ.13) THEN
16089C...f + fbar -> g + g; th arbitrary
16090 KFL3=21
16091 KFL4=21
16092 KCC=ICONMI+4
16093
16094 ELSEIF(ISUBMI.EQ.28) THEN
16095C...f + g -> f + g; th = (p(f)-p(f))**2
16096 IF(KFL1.EQ.21) JS=2
16097 KCC=ICONMI+6
16098 IF(KFL1.EQ.21) KCC=KCC+2
16099 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16100 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16101
16102 ELSEIF(ISUBMI.EQ.53) THEN
16103C...g + g -> f + fbar; th arbitrary
16104 KCS=(-1)**INT(1.5D0+PYR(0))
16105 KFL3=ISIGN(KFLF,KCS)
16106 KFL4=-KFL3
16107 KCC=ICONMI+10
16108
16109 ELSEIF(ISUBMI.EQ.68) THEN
16110C...g + g -> g + g; th arbitrary
16111 KCC=ICONMI+12
16112 KCS=(-1)**INT(1.5D0+PYR(0))
16113 ENDIF
16114
16115C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16116 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16117 & .OR.IABS(KFL4).EQ.5) THEN
16118 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16119 IF (PT2.LE.1.05*RMMAX2) THEN
16120 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16121 & //' too close to threshold (2nd try).')
16122 GOTO 210
16123 ENDIF
16124 ENDIF
16125
16126C...Store flavours of scattering.
16127 MINT(13)=KFL1
16128 MINT(14)=KFL2
16129 MINT(15)=KFL1
16130 MINT(16)=KFL2
16131 MINT(21)=KFL3
16132 MINT(22)=KFL4
16133
16134C...Set flavours and mothers of scattering partons.
16135 K(N+1,1)=14
16136 K(N+2,1)=14
16137 K(N+3,1)=3
16138 K(N+4,1)=3
16139 K(N+1,2)=KFL1
16140 K(N+2,2)=KFL2
16141 K(N+3,2)=KFL3
16142 K(N+4,2)=KFL4
16143 K(N+1,3)=MINT(83)+1
16144 K(N+2,3)=MINT(83)+2
16145 K(N+3,3)=N+1
16146 K(N+4,3)=N+2
16147
16148C...Store colour connection indices.
16149 DO 270 J=1,2
16150 JC=J
16151 IF(KCS.EQ.-1) JC=3-J
16152 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16153 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16154 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16155 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16156 270 CONTINUE
16157
16158C...Store incoming and outgoing partons in their CM-frame.
16159 SHR=SQRT(VINT(21))*VINT(1)
16160 P(N+1,3)=0.5D0*SHR
16161 P(N+1,4)=0.5D0*SHR
16162 P(N+2,3)=-0.5D0*SHR
16163 P(N+2,4)=0.5D0*SHR
16164 P(N+3,5)=PYMASS(K(N+3,2))
16165 P(N+4,5)=PYMASS(K(N+4,2))
16166 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16167 IFAIL=1
16168 RETURN
16169 ENDIF
16170 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16171 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16172 P(N+4,4)=SHR-P(N+3,4)
16173 P(N+4,3)=-P(N+3,3)
16174
16175C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16176 PHI=PARU(2)*PYR(0)
16177 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16178
16179C...Global statistics.
16180 MINT(351)=MINT(351)+1
16181 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16182 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16183
16184C...Keep track of loose colour ends and information on scattering.
16185 MINT(31)=MINT(31)+1
16186 MINT(36)=MINT(31)
16187 PT2MI(MINT(36))=PT2
16188 IMISEP(MINT(31))=N+4
16189 DO 280 JS=1,2
16190 IMI(JS,MINT(31),1)=N+JS
16191 IMI(JS,MINT(31),2)=0
16192 XMI(JS,MINT(31))=VINT(40+JS)
16193 NMI(JS)=NMI(JS)+1
16194C...Update cumulative counters
16195 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16196 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16197 280 CONTINUE
16198
16199C...Add to list of final state partons
16200 IPART(NPART+1)=N+3
16201 IPART(NPART+2)=N+4
16202 PTPART(NPART+1)=SQRT(PT2)
16203 PTPART(NPART+2)=SQRT(PT2)
16204 NPART=NPART+2
16205
16206C...Initialize ISR
16207 NISGEN(1,MINT(31))=0
16208 NISGEN(2,MINT(31))=0
16209
16210C...Update ER
16211 N=N+4
16212 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16213 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16214 MINT(51)=1
16215 RETURN
16216 ENDIF
16217
16218C...Finally, assign colour tags to new partons
16219 DO 300 JS=1,2
16220 I1=IMI(JS,MINT(31),1)
16221 I2=IMI(3-JS,MINT(31),1)
16222 DO 290 JCS=4,5
16223 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16224 & GOTO 290
16225 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16226 KCS=JCS
16227 CALL PYCTTR(I1,KCS,I2)
16228 IF(MINT(51).NE.0) RETURN
16229 290 CONTINUE
16230 300 CONTINUE
16231
16232C----------------------------------------------------------------------
16233C...MODE=2: Decide whether quarks in last scattering were valence,
16234C...companion, or sea.
16235 ELSEIF (MODE.EQ.2) THEN
16236 JS=MINT(30)
16237 MI=MINT(36)
16238 PT2=PT2NOW
16239 KFSBM=ISIGN(1,MINT(10+JS))
16240 IFL=K(IMI(JS,MI,1),2)
16241 IMI(JS,MI,2)=0
16242 IF (IABS(IFL).GE.6) THEN
16243 IF (IABS(IFL).EQ.6) THEN
16244 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16245 ENDIF
16246 RETURN
16247 ENDIF
16248C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16249C...(Do not include the parton itself in the X rescaling.)
16250 X=XMI(JS,MI)
16251 XRSC=X/(VINT(142+JS)+X)
16252C...Note: XPSVC = x*pdf.
16253 MINT(30)=JS
16254C.... ALICE
16255C.... Store side in MINT(124)
16256 MINT(124) = JS
16257C....
16258 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16259 SEA=XPSVC(IFL,-1)
16260 VAL=XPSVC(IFL,0)
16261C...Ensure that pdfs are positive definite
16262 IF (SEA.LT.0D0) THEN
16263 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16264 SEA=MAX(0D0,SEA)
16265 ELSEIF (VAL.LT.0D0) THEN
16266 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16267 VAL=MAX(0D0,VAL)
16268 ENDIF
16269 CMP=0D0
16270 DO 310 IVC=1,NVC(JS,IFL)
16271 CMP=CMP+XPSVC(IFL,IVC)
16272 310 CONTINUE
16273
16274 NTRY=0
16275C...Decide (Extra factor x cancels in the dvision).
16276 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16277 IVNOW=1
16278 NTRY=NTRY+1
16279 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16280C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16281 IVNOW=0
16282 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16283 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16284 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16285 IF(KFIVAL(JS,1).EQ.0) THEN
16286 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16287 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16288 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16289 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16290 ELSE
16291C...Count down valence remaining. Do not count current scattering.
16292 DO 340 I1=1,NMI(JS)
16293 IF (I1.EQ.MINT(36)) GOTO 340
16294 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16295 & IVNOW=IVNOW-1
16296 340 CONTINUE
16297 ENDIF
16298 IF(IVNOW.EQ.0) GOTO 330
16299C...Mark valence.
16300 IMI(JS,MI,2)=0
16301C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16302 IF(KFIVAL(JS,1).EQ.0) THEN
16303 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16304 KFIVAL(JS,1)=IFL
16305 KFIVAL(JS,2)=-IFL
16306 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16307 KFIVAL(JS,1)=IFL
16308 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16309 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16310 ENDIF
16311 ENDIF
16312
16313 ELSEIF (RVCS.LE.VAL+SEA) THEN
16314C...If sea, add opposite sign companion parton. Store X and I.
16315 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16316 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16317C...Set pointer to companion
16318 IMI(JS,MI,2)=-NVC(JS,-IFL)
16319
16320 ELSE
16321C...If companion, check whether we've got any in the books
16322 IF (NVC(JS,IFL).EQ.0) THEN
16323 CMP=0D0
16324C...Only report error first time for this event
16325 IF (NTRY.EQ.1)
16326 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16327C...Try a few times
16328 IF (NTRY.LE.10) THEN
16329 GOTO 320
16330C... But if it stil fails, abort this event
16331 ELSE
16332 MINT(51)=1
16333 RETURN
16334 ENDIF
16335 ENDIF
16336C...If several possibilities, decide which one
16337 CMPSUM=VAL+SEA
16338 ISEL=0
16339 350 ISEL=ISEL+1
16340 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16341 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16342C...Find original sea (anti-)quark. Do not consider current scattering.
16343 IASSOC=0
16344 DO 360 I1=1,NMI(JS)
16345 IF (I1.EQ.MINT(36)) GOTO 360
16346 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16347 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16348 IMI(JS,MI,2)=IMI(JS,I1,1)
16349 IMI(JS,I1,2)=IMI(JS,MI,1)
16350 ENDIF
16351 360 CONTINUE
16352C...Mark companion "out-kicked".
16353 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16354 ENDIF
16355
16356 ENDIF
16357 RETURN
16358 END
16359
16360C*********************************************************************
16361
16362C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16363C...Giving the x*f pdf of a companion quark, with its partner at XS,
16364C...using an approximate gluon density like (1-X)^NPOW/X. The value
16365C...corresponds to an unrescaled range between 0 and 1-X.
16366
16367 FUNCTION PYFCMP(XC,XS,NPOW)
16368 IMPLICIT NONE
16369 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16370 INTEGER NPOW
16371
16372 PYFCMP=0D0
16373C...Parent gluon momentum fraction
16374 Y=XC+XS
16375 IF (Y.GE.1D0) RETURN
16376C...Common factor (includes factor XC, since PYFCMP=x*f)
16377 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16378C...Store normalized companion x*f distribution.
16379 IF (NPOW.LE.0) THEN
16380 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16381 ELSEIF (NPOW.EQ.1) THEN
16382 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16383 ELSEIF (NPOW.EQ.2) THEN
16384 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16385 & +3D0*XS*(1D0+XS)*LOG(XS)))
16386 ELSEIF (NPOW.EQ.3) THEN
16387 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16388 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16389 ELSEIF (NPOW.GE.4) THEN
16390 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16391 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16392 ENDIF
16393 RETURN
16394 END
16395
16396C*********************************************************************
16397
16398C...PYPCMP: Auxiliary to PYPDFU.
16399C...Giving the momentum integral of a companion quark, with its
16400C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16401C...The value corresponds to an unrescaled range between 0 and 1-XS.
16402
16403 FUNCTION PYPCMP(XS,NPOW)
16404 IMPLICIT NONE
16405 DOUBLE PRECISION XS, PYPCMP
16406 INTEGER NPOW
16407 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16408 PYPCMP=0D0
16409 ELSEIF (NPOW.LE.0) THEN
16410 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16411 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16412 ELSEIF (NPOW.EQ.1) THEN
16413 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16414 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16415 ELSEIF (NPOW.EQ.2) THEN
16416 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16417 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16418 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16419 & -3D0*XS*LOG(XS)*(1+XS)))
16420 ELSEIF (NPOW.EQ.3) THEN
16421 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16422 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16423 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16424 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16425 ELSE
16426 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16427 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16428 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16429 & -6D0*XS*LOG(XS)*(1D0+XS)))
16430 ENDIF
16431 RETURN
16432 END
16433
16434C*********************************************************************
16435
16436C...PYUPRE
16437C...Rearranges contents of the HEPEUP commonblock so that
16438C...mothers precede daughters and daughters of a decay are
16439C...listed consecutively.
16440
16441 SUBROUTINE PYUPRE
16442
16443C...Double precision and integer declarations.
16444 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16445 IMPLICIT INTEGER(I-N)
16446
16447C...User process event common block.
16448 INTEGER MAXNUP
16449 PARAMETER (MAXNUP=500)
16450 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16451 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16452 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16453 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16454 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16455 SAVE /HEPEUP/
16456
16457C...Local arrays.
16458 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16459 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16460 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16461
16462C...Check whether a rearrangement is required.
16463 NEED=0
16464 DO 100 IUP=1,NUP
16465 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16466 100 CONTINUE
16467 DO 110 IUP=2,NUP
16468 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16469 110 CONTINUE
16470
16471 IF(NEED.NE.0) THEN
16472C...Find the new order that particles should have.
16473 NEWPOS(0)=0
16474 NNEW=0
16475 INEW=-1
16476 120 INEW=INEW+1
16477 DO 130 IUP=1,NUP
16478 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16479 NNEW=NNEW+1
16480 NEWPOS(NNEW)=IUP
16481 ENDIF
16482 130 CONTINUE
16483 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16484 IF(NNEW.NE.NUP) THEN
16485 CALL PYERRM(2,
16486 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16487 RETURN
16488 ENDIF
16489
16490C...Copy old info into temporary storage.
16491 DO 150 I=1,NUP
16492 IDUPT(I)=IDUP(I)
16493 ISTUPT(I)=ISTUP(I)
16494 MOTUPT(1,I)=MOTHUP(1,I)
16495 MOTUPT(2,I)=MOTHUP(2,I)
16496 ICOUPT(1,I)=ICOLUP(1,I)
16497 ICOUPT(2,I)=ICOLUP(2,I)
16498 DO 140 J=1,5
16499 PUPT(J,I)=PUP(J,I)
16500 140 CONTINUE
16501 VTIUPT(I)=VTIMUP(I)
16502 SPIUPT(I)=SPINUP(I)
16503 150 CONTINUE
16504
16505C...Copy info back into HEPEUP in right order.
16506 DO 180 I=1,NUP
16507 IOLD=NEWPOS(I)
16508 IDUP(I)=IDUPT(IOLD)
16509 ISTUP(I)=ISTUPT(IOLD)
16510 MOTHUP(1,I)=0
16511 MOTHUP(2,I)=0
16512 DO 160 IMOT=1,I-1
16513 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16514 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16515 160 CONTINUE
16516 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16517 MOTHSW=MOTHUP(1,I)
16518 MOTHUP(1,I)=MOTHUP(2,I)
16519 MOTHUP(2,I)=MOTHSW
16520 ENDIF
16521 ICOLUP(1,I)=ICOUPT(1,IOLD)
16522 ICOLUP(2,I)=ICOUPT(2,IOLD)
16523 DO 170 J=1,5
16524 PUP(J,I)=PUPT(J,IOLD)
16525 170 CONTINUE
16526 VTIMUP(I)=VTIUPT(IOLD)
16527 SPINUP(I)=SPIUPT(IOLD)
16528 180 CONTINUE
16529 ENDIF
16530
16531c...If incoming particles are massive recalculate to put them massless.
16532 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16533 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16534 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16535 PUP(4,1)=0.5D0*PPLUS
16536 PUP(3,1)=PUP(4,1)
16537 PUP(5,1)=0D0
16538 PUP(4,2)=0.5D0*PMINUS
16539 PUP(3,2)=-PUP(4,2)
16540 PUP(5,2)=0D0
16541 ENDIF
16542
16543 RETURN
16544 END
16545
16546C*********************************************************************
16547
16548C...PYADSH
16549C...Administers the generation of successive final-state showers
16550C...in external processes.
16551
16552 SUBROUTINE PYADSH(NFIN)
16553
16554C...Double precision and integer declarations.
16555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16556 IMPLICIT INTEGER(I-N)
16557 INTEGER PYK,PYCHGE,PYCOMP
16558C...Parameter statement for maximum size of showers.
16559 PARAMETER (MAXNUR=1000)
16560C...Commonblocks.
16561 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16562 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16563 COMMON/PYCTAG/NCT,MCT(4000,2)
16564 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16565 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16566 COMMON/PYINT1/MINT(400),VINT(400)
16567 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16568C...Local array.
16569 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16570
16571C...Set primary vertex.
16572 DO 100 J=1,5
16573 V(MINT(83)+5,J)=0D0
16574 V(MINT(83)+6,J)=0D0
16575 V(MINT(84)+1,J)=0D0
16576 V(MINT(84)+2,J)=0D0
16577 100 CONTINUE
16578
16579C...Isolate systems of particles with the same mother.
16580 NSYS=0
16581 IMS=-1
16582 DO 140 I=MINT(84)+3,NFIN
16583 IM=K(I,3)
16584 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16585 IF(IM.NE.IMS) THEN
16586 NSYS=NSYS+1
16587 IBEG(NSYS)=I
16588 IMS=IM
16589 ENDIF
16590
16591C...Set production vertices.
16592 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16593 & THEN
16594 DO 110 J=1,4
16595 V(I,J)=0D0
16596 110 CONTINUE
16597 ELSE
16598 DO 120 J=1,4
16599 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16600 120 CONTINUE
16601 ENDIF
16602 IF(MSTP(125).GE.1) THEN
16603 IDOC=I-MSTP(126)+4
16604 DO 130 J=1,5
16605 V(IDOC,J)=V(I,J)
16606 130 CONTINUE
16607 ENDIF
16608 140 CONTINUE
16609
16610C...End loop over systems. Return if no showers to be performed.
16611 IBEG(NSYS+1)=NFIN+1
16612 IF(MSTP(71).LE.0) RETURN
16613
16614C...Loop through systems of particles; check that sensible size.
16615 DO 270 ISYS=1,NSYS
16616 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16617 IF(MINT(35).LE.2) THEN
16618 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16619 GOTO 270
16620 ELSEIF(NSIZ.LE.1) THEN
16621 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16622 GOTO 270
16623 ELSEIF(NSIZ.GT.80) THEN
16624 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16625 GOTO 270
16626 ENDIF
16627 ENDIF
16628
16629C...Save status codes and daughters of showering particles; reset them.
16630 DO 150 J=1,4
16631 PSUM(J)=0D0
16632 150 CONTINUE
16633 DO 170 II=1,NSIZ
16634 I=IBEG(ISYS)-1+II
16635 KSAV(II,1)=K(I,1)
16636 IF(K(I,1).GT.10) THEN
16637 K(I,1)=1
16638 IF(KSAV(II,1).EQ.14) K(I,1)=3
16639 ENDIF
16640 IF(KSAV(II,1).LE.10) THEN
16641 ELSEIF(K(I,1).EQ.1) THEN
16642 KSAV(II,4)=K(I,4)
16643 KSAV(II,5)=K(I,5)
16644 K(I,4)=0
16645 K(I,5)=0
16646 ELSE
16647 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16648 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16649 K(I,4)=K(I,4)-KSAV(II,4)
16650 K(I,5)=K(I,5)-KSAV(II,5)
16651 ENDIF
16652 DO 160 J=1,4
16653 PSUM(J)=PSUM(J)+P(I,J)
16654 160 CONTINUE
16655 170 CONTINUE
16656
16657C...Perform shower.
16658 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16659 & PSUM(3)**2))
16660 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16661 NSAV=N
16662 IF(MINT(35).LE.2) THEN
16663 IF(NSIZ.EQ.2) THEN
16664 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16665 ELSE
16666 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16667 ENDIF
16668
16669C...For external processes, first call, also ISR partons radiate.
16670C...Can use existing PYPART list, removing partons that radiate later.
16671 ELSEIF(ISYS.EQ.1) THEN
16672 NPARTN=0
16673 DO 175 II=1,NPART
16674 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16675 NPARTN=NPARTN+1
16676 IPART(NPARTN)=IPART(II)
16677 PTPART(NPARTN)=PTPART(II)
16678 ENDIF
16679 175 CONTINUE
16680 NPART=NPARTN
16681 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16682 ELSE
16683C...For subsequent calls use the systems excluded above.
16684 NPART=NSIZ
16685 NPARTD=0
16686 DO 180 II=1,NSIZ
16687 I=IBEG(ISYS)-1+II
16688 IPART(II)=I
16689 PTPART(II)=0.5D0*QMAX
16690 180 CONTINUE
16691 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16692 ENDIF
16693
16694C...Look up showered copies of original showering particles.
16695 DO 260 II=1,NSIZ
16696 I=IBEG(ISYS)-1+II
16697 IMV=I
16698C...Particles without daughters need not be studied.
16699 IF(KSAV(II,1).LE.10) GOTO 260
16700 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16701 ELSEIF(K(I,1).EQ.11) THEN
16702 190 IMV=MOD(K(IMV,4),MSTU(5))
16703 IF(K(IMV,1).EQ.11) GOTO 190
16704 ELSE
16705 KDA1=MOD(K(I,4),MSTU(5))
16706 IF(KDA1.GT.0) THEN
16707 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16708 ENDIF
16709 KDA2=MOD(K(I,5),MSTU(5))
16710 IF(KDA2.GT.0) THEN
16711 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16712 ENDIF
16713 DO 200 I3=I+1,N
16714 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16715 & THEN
16716 IMV=I3
16717 KDA1=MOD(K(I3,4),MSTU(5))
16718 IF(KDA1.GT.0) THEN
16719 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16720 ENDIF
16721 KDA2=MOD(K(I3,5),MSTU(5))
16722 IF(KDA2.GT.0) THEN
16723 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16724 ENDIF
16725 ENDIF
16726 200 CONTINUE
16727 ENDIF
16728
16729C...Restore daughter info of original partons to showered copies.
16730 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16731 IF(KSAV(II,1).LE.10) THEN
16732 ELSEIF(K(I,1).EQ.1) THEN
16733 K(IMV,4)=KSAV(II,4)
16734 K(IMV,5)=KSAV(II,5)
16735 ELSE
16736 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16737 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16738 ENDIF
16739
16740C...Reset mother info of existing daughters to showered copies.
16741 DO 210 I3=IBEG(ISYS+1),NFIN
16742 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16743 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16744 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16745 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16746 ENDIF
16747 210 CONTINUE
16748
16749C...Boost all original daughters to new frame of showered copy.
16750C...Also update their colour tags.
16751 IF(IMV.NE.I) THEN
16752 DO 220 J=1,3
16753 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16754 220 CONTINUE
16755 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16756 DO 230 J=1,3
16757 BETA(J)=FAC*BETA(J)
16758 230 CONTINUE
16759 DO 250 I3=IBEG(ISYS+1),NFIN
16760 IMO=I3
16761 240 IMO=K(IMO,3)
16762 IF(MSTP(128).LE.0) THEN
16763 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16764 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16765 & THEN
16766 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16767 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16768 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16769 ENDIF
16770 ELSE
16771 IF(IMO.EQ.IMV) THEN
16772 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16773 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16774 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16775 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16776 GOTO 240
16777 ENDIF
16778 ENDIF
16779 250 CONTINUE
16780 ENDIF
16781 260 CONTINUE
16782
16783C...End of loop over showering systems
16784 270 CONTINUE
16785
16786 RETURN
16787 END
16788
16789C*********************************************************************
16790
16791C...PYVETO
16792C...Interface to UPVETO, which allows user to veto event generation
16793C...on the parton level, after parton showers but before multiple
16794C...interactions, beam remnants and hadronization is added.
16795
16796 SUBROUTINE PYVETO(IVETO)
16797
16798C...All real arithmetic in double precision.
16799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16800C...Three Pythia functions return integers, so need declaring.
16801 INTEGER PYK,PYCHGE,PYCOMP
16802
16803C...PYTHIA commonblocks.
16804 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16805 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16807 COMMON/PYINT1/MINT(400),VINT(400)
16808 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16809C...HEPEVT commonblock.
16810 PARAMETER (NMXHEP=4000)
16811 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16812 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16813 DOUBLE PRECISION PHEP,VHEP
16814 SAVE /HEPEVT/
16815C...Local array.
16816 DIMENSION IRESO(100)
16817
16818C...Define longitudinal boost from initiator rest frame to cm frame.
16819 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16820 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16821
16822C...Presentation is different if using pT-ordered shower
16823 IF(MINT(35).EQ.3) THEN
16824 GAMMA=1D0
16825 GABEZ=0D0
16826 ENDIF
16827
16828C... Reset counters.
16829 NEVHEP=0
16830 NHEP=0
16831 NRESO=0
16832
16833C...Oth pass: identify beam and incoming partons
16834 DO 140 I=MINT(83)+1,MINT(83)+6
16835 ISTORE=0
16836 IF(K(I,2).EQ.94) THEN
16837
16838 ELSE
16839 NRESO=NRESO+1
16840 IRESO(NRESO)=I
16841 IMOTH=K(I,3)
16842 ENDIF
16843 140 CONTINUE
16844
16845C...First pass: identify final locations of resonances
16846C...and of their daughters before showering.
16847 DO 150 I=MINT(84)+3,N
16848 ISTORE=0
16849 IMOTH=0
16850
16851C...Skip shower CM frame documentation lines.
16852 IF(K(I,2).EQ.94) THEN
16853
16854C... Store a new intermediate product, when mother in documentation.
16855 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16856 & K(I,3).LE.MINT(84)) THEN
16857 ISTORE=1
16858 NHEP=NHEP+1
16859 II=NHEP
16860 NRESO=NRESO+1
16861 IRESO(NRESO)=I
16862 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
16863
16864C... Store a new intermediate product, when mother in main section.
16865 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16866 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16867 ISTORE=1
16868 NHEP=NHEP+1
16869 II=NHEP
16870 NRESO=NRESO+1
16871 IRESO(NRESO)=I
16872 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
16873 ENDIF
16874
16875 IF(ISTORE.EQ.1) THEN
16876C...Copy parton info, boosting momenta along z axis to cm frame.
16877 ISTHEP(II)=2
16878 IDHEP(II)=K(I,2)
16879 PHEP(1,II)=P(I,1)
16880 PHEP(2,II)=P(I,2)
16881 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16882 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16883 PHEP(5,II)=P(I,5)
16884C...Store one mother. Rest of history and vertex info zeroed.
16885 JMOHEP(1,II)=IMOTH
16886 JMOHEP(2,II)=0
16887 JDAHEP(1,II)=0
16888 JDAHEP(2,II)=0
16889 VHEP(1,II)=0D0
16890 VHEP(2,II)=0D0
16891 VHEP(3,II)=0D0
16892 VHEP(4,II)=0D0
16893 ENDIF
16894 150 CONTINUE
16895
16896C...Second pass: identify current set of "final" partons.
16897 DO 200 I=MINT(84)+3,N
16898 ISTORE=0
16899 IMOTH=0
16900
16901C...Store a final parton.
16902 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16903 ISTORE=1
16904 NHEP=NHEP+1
16905 II=NHEP
16906C..Trace it back through shower, to check if from documented particle.
16907 IHIST=I
16908 ISAVE=IHIST
16909 160 CONTINUE
16910 IF(IHIST.GT.MINT(84)) THEN
16911 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16912 DO 170 IRI=1,NRESO
16913 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16914 170 CONTINUE
16915 ISAVE=IHIST
16916 IHIST=K(IHIST,3)
16917 IF(IMOTH.EQ.0) GOTO 160
16918 IMOTH=MAX(0,IMOTH-6)
16919 ELSEIF(IHIST.LE.4) THEN
16920 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16921 ISTORE=0
16922 NHEP=NHEP-1
16923 ELSE
16924 IMOTH=0
16925 ENDIF
16926 ENDIF
16927 ENDIF
16928
16929 IF(ISTORE.EQ.1) THEN
16930C...Copy parton info, boosting momenta along z axis to cm frame.
16931 ISTHEP(II)=1
16932 IDHEP(II)=K(I,2)
16933 PHEP(1,II)=P(I,1)
16934 PHEP(2,II)=P(I,2)
16935 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16936 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16937 PHEP(5,II)=P(I,5)
16938C...Store one mother. Rest of history and vertex info zeroed.
16939 JMOHEP(1,II)=IMOTH
16940 JMOHEP(2,II)=0
16941 JDAHEP(1,II)=0
16942 JDAHEP(2,II)=0
16943 VHEP(1,II)=0D0
16944 VHEP(2,II)=0D0
16945 VHEP(3,II)=0D0
16946 VHEP(4,II)=0D0
16947 ENDIF
16948 200 CONTINUE
16949C...Call user-written routine to decide whether to keep events.
16950 CALL UPVETO(IVETO)
16951 RETURN
16952 END
16953C*********************************************************************
16954
16955C...PYRESD
16956C...Allows resonances to decay (including parton showers for hadronic
16957C...channels).
16958
16959 SUBROUTINE PYRESD(IRES)
16960
16961C...Double precision and integer declarations.
16962 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16963 IMPLICIT INTEGER(I-N)
16964 INTEGER PYK,PYCHGE,PYCOMP
16965C...Parameter statement to help give large particle numbers.
16966 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16967 &KEXCIT=4000000,KDIMEN=5000000)
16968C...Parameter statement for maximum size of showers.
16969 PARAMETER (MAXNUR=1000)
16970C...Commonblocks.
16971 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16972 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16973 COMMON/PYCTAG/NCT,MCT(4000,2)
16974 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16975 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16976 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16977 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16978 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16979 COMMON/PYINT1/MINT(400),VINT(400)
16980 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16981 COMMON/PYINT4/MWID(500),WIDS(500,5)
16982 COMMON/PYPUED/IUED(0:99),RUED(0:99)
16983 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16984 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
16985C...Local arrays and complex and character variables.
16986 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16987 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16988 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16989 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16990 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16991 COMPLEX FGK,HA(6,6),HC(6,6)
16992 REAL TIR,UIR
16993 CHARACTER CODE*9,MASS*9
16994
16995C...The F, Xi and Xj functions of Gunion and Kunszt
16996C...(Phys. Rev. D33, 665, plus errata from the authors).
16997 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16998 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16999 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
17000 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
17001 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17002 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17003 &2D0*(D34/D56+D56/D34))
17004
17005C...Some general constants.
17006 XW=PARU(102)
17007 XWV=XW
17008 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17009 XW1=1D0-XW
17010 SQMZ=PMAS(23,1)**2
17011
17012 GMMZ=PMAS(23,1)*PMAS(23,2)
17013 SQMW=PMAS(24,1)**2
17014 GMMW=PMAS(24,1)*PMAS(24,2)
17015 SH=VINT(44)
17016
17017C...Boost and rotate to rest frame of incoming partons,
17018C...to get proper amount of smearing of decay angles.
17019 IBST=0
17020 IF(IRES.EQ.0) THEN
17021 IBST=1
17022 IIN1=MINT(84)+1
17023 IIN2=MINT(84)+2
17024C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17025C...(101,102) are off shell and can have inconsistent momenta, resulting
17026C...in boosts larger than unity. However, the corresponding docu partons
17027C...(5,6) are kept on shell, and have consistent momenta that can be used
17028C...to derive this boost instead. Ultimately, should change the way the new
17029C...shower stores intermediate partons, but just using partons (5,6) for now
17030C...does define the boost and furnishes a quick and much needed solution.
17031 IF (MINT(35).EQ.3) THEN
17032 IIN1=MINT(83)+5
17033 IIN2=MINT(83)+6
17034 ENDIF
17035 ETOTIN=P(IIN1,4)+P(IIN2,4)
17036 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17037 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17038 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17039 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17040 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17041 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17042 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17043 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17044 ENDIF
17045
17046C...Reset original resonance configuration.
17047 DO 100 JT=1,8
17048 IREF(1,JT)=0
17049 100 CONTINUE
17050
17051C...Define initial one, two or three objects for subprocess.
17052 IHDEC=0
17053 IF(IRES.EQ.0) THEN
17054 ISUB=MINT(1)
17055 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17056 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17057 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17058 JTMAX=1
17059 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17060 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17061 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17062 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17063 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17064 JTMAX=2
17065 ELSEIF(ISET(ISUB).EQ.5) THEN
17066 IREF(1,1)=MINT(84)+3
17067 IREF(1,2)=MINT(84)+4
17068 IREF(1,3)=MINT(84)+5
17069 IREF(1,4)=MINT(83)+7
17070 IREF(1,5)=MINT(83)+8
17071 IREF(1,6)=MINT(83)+9
17072 JTMAX=3
17073 ENDIF
17074
17075C...Define original resonance for odd cases.
17076 ELSE
17077 ISUB=0
17078 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17079 & IHDEC=1
17080 IF(IHDEC.EQ.1) ISUB=3
17081 IREF(1,1)=IRES
17082 IREF(1,4)=K(IRES,3)
17083 IRESTM=IRES
17084 IF(IREF(1,4).GT.MINT(84)) THEN
17085 110 ITMPMO=IREF(1,4)
17086 IF(K(ITMPMO,2).EQ.94) THEN
17087 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17088 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17089 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17090 IRESTM=ITMPMO
17091C...Explicitly check that reference particle exists, otherwise stop recursion
17092 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17093 IREF(1,4)=K(ITMPMO,3)
17094 GOTO 110
17095 ENDIF
17096 ENDIF
17097 ENDIF
17098 IF(IREF(1,4).GT.MINT(84)) THEN
17099 EMATCH=1D10
17100 IREF14=IREF(1,4)
17101 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17102 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17103 & EMATCH) THEN
17104 IREF(1,4)=II
17105 EMATCH=ABS(P(II,4)-P(IREF14,4))
17106 ENDIF
17107 120 CONTINUE
17108 ENDIF
17109 JTMAX=1
17110 ENDIF
17111
17112C...Check if initial resonance has been moved (in resonance + jet).
17113 DO 140 JT=1,3
17114 IF(IREF(1,JT).GT.0) THEN
17115 IF(K(IREF(1,JT),1).GT.10) THEN
17116 KFA=IABS(K(IREF(1,JT),2))
17117 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17118 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17119 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17120 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17121 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17122 ENDIF
17123 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17124 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17125 ENDIF
17126 DO 130 I=IREF(1,JT)+1,N
17127 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17128 & I.EQ.KDA2)) THEN
17129 IREF(1,JT)=I
17130 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17131 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17132 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17133 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17134 ENDIF
17135 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17136 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17137 ENDIF
17138 ENDIF
17139 130 CONTINUE
17140 ELSE
17141 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17142 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17143 ENDIF
17144 ENDIF
17145 ENDIF
17146 140 CONTINUE
17147
17148C...Set decay vertex for initial resonances
17149 DO 160 JT=1,JTMAX
17150 DO 150 I=1,4
17151 V(IREF(1,JT),I)=0D0
17152 150 CONTINUE
17153 160 CONTINUE
17154
17155C...Loop over decay history.
17156 NP=1
17157 IP=0
17158 170 IP=IP+1
17159 NINH=0
17160 JTMAX=2
17161 IF(IREF(IP,2).EQ.0) JTMAX=1
17162 IF(IREF(IP,3).NE.0) JTMAX=3
17163 IT4=0
17164 NSAV=N
17165
17166C...Check for Higgs which appears as decay product of user-process.
17167 IF(ISUB.EQ.0) THEN
17168 IHDEC=0
17169 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17170 & .EQ.36) IHDEC=1
17171 IF(IHDEC.EQ.1) ISUB=3
17172 ENDIF
17173
17174C...Start treatment of one, two or three resonances in parallel.
17175 180 N=NSAV
17176 DO 340 JT=1,JTMAX
17177 ID=IREF(IP,JT)
17178 KDCY(JT)=0
17179 KFL1(JT)=0
17180 KFL2(JT)=0
17181 KFL3(JT)=0
17182 KEQL(JT)=0
17183 NSD(JT)=ID
17184 ITJUNC(JT)=0
17185
17186C...Check whether particle can/is allowed to decay.
17187 IF(ID.EQ.0) GOTO 330
17188 KFA=IABS(K(ID,2))
17189 KCA=PYCOMP(KFA)
17190 IF(MWID(KCA).EQ.0) GOTO 330
17191 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17192 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17193 & KFA.EQ.18) IT4=IT4+1
17194 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17195 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17196
17197C...Choose lifetime and determine decay vertex.
17198 IF(K(ID,1).EQ.5) THEN
17199 V(ID,5)=0D0
17200 ELSEIF(K(ID,1).NE.4) THEN
17201 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17202 ENDIF
17203 DO 190 J=1,4
17204 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17205 190 CONTINUE
17206
17207C...Determine whether decay allowed or not.
17208 MOUT=0
17209 IF(MSTJ(22).EQ.2) THEN
17210 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17211 ELSEIF(MSTJ(22).EQ.3) THEN
17212 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17213 ELSEIF(MSTJ(22).EQ.4) THEN
17214 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17215 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17216 ENDIF
17217 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17218 K(ID,1)=4
17219 GOTO 330
17220 ENDIF
17221
17222C...Info for selection of decay channel: sign, pairings.
17223 IF(KCHG(KCA,3).EQ.0) THEN
17224 IPM=2
17225 ELSE
17226 IPM=(5-ISIGN(1,K(ID,2)))/2
17227 ENDIF
17228 KFB=0
17229 IF(JTMAX.EQ.2) THEN
17230 KFB=IABS(K(IREF(IP,3-JT),2))
17231 ELSEIF(JTMAX.EQ.3) THEN
17232 JT2=JT+1-3*(JT/3)
17233 KFB=IABS(K(IREF(IP,JT2),2))
17234 IF(KFB.NE.KFA) THEN
17235 JT2=JT+2-3*((JT+1)/3)
17236 KFB=IABS(K(IREF(IP,JT2),2))
17237 ENDIF
17238 ENDIF
17239
17240C...Select decay channel.
17241 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17242 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17243 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17244 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17245 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17246 IF(WDTE0S.LE.0D0) GOTO 330
17247 RKFL=WDTE0S*PYR(0)
17248 IDL=0
17249 200 IDL=IDL+1
17250 IDC=IDL+MDCY(KCA,2)-1
17251 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17252 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17253 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17254
17255C...Read out flavours and colour charges of decay channel chosen.
17256 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17257 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17258 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17259 KFC1A=PYCOMP(IABS(KFL1(JT)))
17260 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17261 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17262 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17263 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17264 KFC2A=PYCOMP(IABS(KFL2(JT)))
17265 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17266 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17267 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17268 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17269 KCQ3(JT)=0
17270 IF(KFL3(JT).NE.0) THEN
17271 KFC3A=PYCOMP(IABS(KFL3(JT)))
17272 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17273 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17274 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17275 ENDIF
17276
17277C...Set/save further info on channel.
17278 KDCY(JT)=1
17279 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17280 NSD(JT)=N
17281 HGZ(JT,1)=VINT(111)
17282 HGZ(JT,2)=VINT(112)
17283 HGZ(JT,3)=VINT(114)
17284 JTZ=JT
17285
17286C...Select masses; to begin with assume resonances narrow.
17287 DO 220 I=1,3
17288 P(N+I,5)=0D0
17289 PMMN(I)=0D0
17290 IF(I.EQ.1) THEN
17291 KFLW=IABS(KFL1(JT))
17292 KCW=KFC1A
17293 ELSEIF(I.EQ.2) THEN
17294 KFLW=IABS(KFL2(JT))
17295 KCW=KFC2A
17296 ELSEIF(I.EQ.3) THEN
17297 IF(KFL3(JT).EQ.0) GOTO 220
17298 KFLW=IABS(KFL3(JT))
17299 KCW=KFC3A
17300 ENDIF
17301 P(N+I,5)=PMAS(KCW,1)
17302CMRENNA++
17303C...This prevents SUSY/t particles from becoming too light.
17304 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17305 PMMN(I)=PMAS(KCW,1)
17306 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17307 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17308 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17309 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17310 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17311 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17312 PMMN(I)=MIN(PMMN(I),PMSUM)
17313 ENDIF
17314 210 CONTINUE
17315C MRENNA--
17316 ELSEIF(KFLW.EQ.6) THEN
17317 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17318 ENDIF
17319C...UED: select a graviton mass from continuous distribution
17320C...(stored in PMAS(39,1) so no value returned)
17321 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17322 & CALL PYGRAM(1)
17323 220 CONTINUE
17324
17325C...Check which two out of three are widest.
17326 IWID1=1
17327 IWID2=2
17328 PWID1=PMAS(KFC1A,2)
17329 PWID2=PMAS(KFC2A,2)
17330 KFLW1=IABS(KFL1(JT))
17331 KFLW2=IABS(KFL2(JT))
17332 IF(KFL3(JT).NE.0) THEN
17333 PWID3=PMAS(KFC3A,2)
17334 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17335 IWID1=3
17336 PWID1=PWID3
17337 KFLW1=IABS(KFL3(JT))
17338 ELSEIF(PWID3.GT.PWID2) THEN
17339 IWID2=3
17340 PWID2=PWID3
17341 KFLW2=IABS(KFL3(JT))
17342 ENDIF
17343 ENDIF
17344
17345C...If all narrow then only check that masses consistent.
17346 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17347 & PWID2.LT.PARP(41))) THEN
17348CMRENNA++
17349C....Handle near degeneracy cases.
17350 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17351 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17352 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17353 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17354 ENDIF
17355 ENDIF
17356CMRENNA--
17357 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17358 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17359 MINT(51)=1
17360 GOTO 720
17361 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
17362 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
17363 MINT(51)=1
17364 GOTO 720
17365 ENDIF
17366
17367C...For three wide resonances select narrower of three
17368C...according to BW decoupled from rest.
17369 ELSE
17370 PMTOT=P(ID,5)
17371 IF(KFL3(JT).NE.0) THEN
17372 IWID3=6-IWID1-IWID2
17373 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17374 & KFLW1-KFLW2
17375 LOOP=0
17376 230 LOOP=LOOP+1
17377 P(N+IWID3,5)=PYMASS(KFLW3)
17378 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17379 PMTOT=PMTOT-P(N+IWID3,5)
17380 ENDIF
17381C...Select other two correlated within remaining phase space.
17382 IF(IP.EQ.1) THEN
17383 CKIN45=CKIN(45)
17384 CKIN47=CKIN(47)
17385 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17386 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17387 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17388 & P(N+IWID2,5))
17389 CKIN(45)=CKIN45
17390 CKIN(47)=CKIN47
17391 ELSE
17392 CKIN(49)=PMMN(IWID1)
17393 CKIN(50)=PMMN(IWID2)
17394 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17395 & P(N+IWID2,5))
17396 CKIN(49)=0D0
17397 CKIN(50)=0D0
17398 ENDIF
17399 IF(MINT(51).EQ.1) GOTO 720
17400 ENDIF
17401
17402C...Begin fill decay products, with colour flow for coloured objects.
17403 MSTU10=MSTU(10)
17404 MSTU(10)=1
17405 MSTU(19)=1
17406
17407C...Three-body decays
17408 IF(KFL3(JT).NE.0) THEN
17409 DO 250 I=N+1,N+3
17410 DO 240 J=1,5
17411 K(I,J)=0
17412 V(I,J)=0D0
17413 240 CONTINUE
17414 MCT(I,1)=0
17415 MCT(I,2)=0
17416 250 CONTINUE
17417 K(N+1,1)=1
17418 K(N+1,2)=KFL1(JT)
17419 K(N+2,1)=1
17420 K(N+2,2)=KFL2(JT)
17421 K(N+3,1)=1
17422 K(N+3,2)=KFL3(JT)
17423 IDIN=ID
17424
17425C...Generate kinematics (default is flat)
17426 CALL PYTBDY(IDIN)
17427
17428C...Set generic colour flows whenever unambiguous,
17429C...(independently of the order of the decay products)
17430C...Sum up total colour content
17431 NANT=0
17432 NTRI=0
17433 NOCT=0
17434 KCQ(0)=KCQM(JT)
17435 KCQ(1)=KCQ1(JT)
17436 KCQ(2)=KCQ2(JT)
17437 KCQ(3)=KCQ3(JT)
17438 DO 255 J=0,3
17439 IF (KCQ(J).EQ.-1) THEN
17440 NANT=NANT+1
17441 IANT(NANT)=N+J
17442 ELSEIF (KCQ(J).EQ.1) THEN
17443 NTRI=NTRI+1
17444 ITRI(NTRI)=N+J
17445 ELSEIF (KCQ(J).EQ.2) THEN
17446 NOCT=NOCT+1
17447 IOCT(NOCT)=N+J
17448 ENDIF
17449 255 CONTINUE
17450
17451C...Set color flow for generic 1 -> N processes (N arbitrary)
17452 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17453C...All singlets: do nothing
17454
17455 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17456C...Two octets, zero triplets, n singlets:
17457 IF (KCQ(0).EQ.2) THEN
17458C...8 -> 8 + n(1)
17459 K(ID,4)=K(ID,4)+IOCT(2)
17460 K(ID,5)=K(ID,5)+IOCT(2)
17461 K(IOCT(2),1)=3
17462 K(IOCT(2),4)=MSTU(5)*ID
17463 K(IOCT(2),5)=MSTU(5)*ID
17464 MCT(IOCT(2),1)=MCT(ID,1)
17465 MCT(IOCT(2),2)=MCT(ID,2)
17466 ELSE
17467C...1 -> 8 + 8 + n(1)
17468 K(IOCT(1),1)=3
17469 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17470 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17471 K(IOCT(2),1)=3
17472 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17473 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17474 NCT=NCT+1
17475 MCT(IOCT(1),1)=NCT
17476 MCT(IOCT(2),2)=NCT
17477 NCT=NCT+1
17478 MCT(IOCT(2),1)=NCT
17479 MCT(IOCT(1),2)=NCT
17480 ENDIF
17481
17482 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17483C...Two triplets, zero octets, n singlets.
17484 IF (KCQ(0).EQ.1) THEN
17485C...3 -> 3 + n(1)
17486 K(ID,4)=K(ID,4)+ITRI(2)
17487 K(ITRI(2),1)=3
17488 K(ITRI(2),4)=MSTU(5)*ID
17489 MCT(ITRI(2),1)=MCT(ID,1)
17490 ELSEIF (KCQ(0).EQ.-1) THEN
17491C...3bar -> 3bar + n(1)
17492 K(ID,5)=K(ID,5)+IANT(2)
17493 K(IANT(2),1)=3
17494 K(IANT(2),5)=MSTU(5)*ID
17495 MCT(IANT(2),2)=MCT(ID,2)
17496 ELSE
17497C...1 -> 3 + 3bar + n(1)
17498 K(ITRI(1),1)=3
17499 K(ITRI(1),4)=MSTU(5)*IANT(1)
17500 K(IANT(1),1)=3
17501 K(IANT(1),5)=MSTU(5)*ITRI(1)
17502 NCT=NCT+1
17503 MCT(ITRI(1),1)=NCT
17504 MCT(IANT(1),2)=NCT
17505 ENDIF
17506
17507 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17508C...Two triplets, one octet, n singlets.
17509 IF (KCQ(0).EQ.2) THEN
17510C...8 -> 3 + 3bar + n(1)
17511 K(ID,4)=K(ID,4)+ITRI(1)
17512 K(ID,5)=K(ID,5)+IANT(1)
17513 K(ITRI(1),1)=3
17514 K(ITRI(1),4)=MSTU(5)*ID
17515 K(IANT(1),1)=3
17516 K(IANT(1),5)=MSTU(5)*ID
17517 MCT(ITRI(1),1)=MCT(ID,1)
17518 MCT(IANT(1),2)=MCT(ID,2)
17519 ELSEIF (KCQ(0).EQ.1) THEN
17520C...3 -> 8 + 3 + n(1)
17521 K(ID,4)=K(ID,4)+IOCT(1)
17522 K(IOCT(1),1)=3
17523 K(IOCT(1),4)=MSTU(5)*ID
17524 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17525 K(ITRI(2),1)=3
17526 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17527 MCT(IOCT(1),1)=MCT(ID,1)
17528 NCT=NCT+1
17529 MCT(IOCT(1),2)=NCT
17530 MCT(ITRI(2),1)=NCT
17531 ELSEIF (KCQ(0).EQ.-1) THEN
17532C...3bar -> 8 + 3bar + n(1)
17533 K(ID,5)=K(ID,5)+IOCT(1)
17534 K(IOCT(1),1)=3
17535 K(IOCT(1),5)=MSTU(5)*ID
17536 K(IOCT(1),4)=MSTU(5)*IANT(2)
17537 K(IANT(2),1)=3
17538 K(IANT(2),5)=MSTU(5)*IOCT(1)
17539 MCT(IOCT(1),2)=MCT(ID,2)
17540 NCT=NCT+1
17541 MCT(IOCT(1),1)=NCT
17542 MCT(IANT(2),2)=NCT
17543 ELSE
17544C...1 -> 3 + 3bar + 8 + n(1)
17545 K(ITRI(1),1)=3
17546 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17547 K(IOCT(1),1)=3
17548 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17549 K(IOCT(1),4)=MSTU(5)*IANT(1)
17550 K(IANT(1),1)=3
17551 K(IANT(1),5)=MSTU(5)*IOCT(1)
17552 NCT=NCT+1
17553 MCT(ITRI(1),1)=NCT
17554 MCT(IOCT(1),2)=NCT
17555 NCT=NCT+1
17556 MCT(IOCT(1),1)=NCT
17557 MCT(IANT(1),2)=NCT
17558 ENDIF
17559CPS-- End of generic cases
17560C...(could three octets also be handled?)
17561C...(could (some of) the RPV cases be made generic as well?)
17562
17563C...Special cases (= old treatment)
17564C...Set colour flow for t -> W + b + Z.
17565 ELSEIF(KFA.EQ.6) THEN
17566 K(N+2,1)=3
17567 ISID=4
17568 IF(KCQM(JT).EQ.-1) ISID=5
17569 IDAU=N+2
17570 K(ID,ISID)=K(ID,ISID)+IDAU
17571 K(IDAU,ISID)=MSTU(5)*ID
17572
17573C...Set colour flow in three-body decays - programmed as special cases.
17574
17575 ELSEIF(KFC2A.LE.6) THEN
17576 K(N+2,1)=3
17577 K(N+3,1)=3
17578 ISID=4
17579 IF(KFL2(JT).LT.0) ISID=5
17580 K(N+2,ISID)=MSTU(5)*(N+3)
17581 K(N+3,9-ISID)=MSTU(5)*(N+2)
17582C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17583 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
17584 & .AND.KFL3(JT).NE.0) THEN
17585 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
17586C...3-body decays of squarks to colour singlets plus one quark
17587 IF (KQSUMA.EQ.1) THEN
17588C...Find quark
17589 IQ=0
17590 IF (KCQ1(JT).NE.0) IQ=1
17591 IF (KCQ2(JT).NE.0) IQ=2
17592 IF (KCQ3(JT).NE.0) IQ=3
17593 ISID=4
17594 IF (K(N+IQ,2).LT.0) ISID=5
17595 K(N+IQ,1)=3
17596 K(ID,ISID)=K(ID,ISID)+(N+IQ)
17597 K(N+IQ,ISID)=MSTU(5)*ID
17598 ENDIF
17599C...PS--
17600 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
17601 K(N+1,1)=3
17602 K(N+2,1)=3
17603 K(N+3,1)=3
17604 ISID=4
17605 IF(KFL2(JT).LT.0) ISID=5
17606 K(N+1,ISID)=MSTU(5)*(N+2)
17607 K(N+1,9-ISID)=MSTU(5)*(N+3)
17608 K(N+2,ISID)=MSTU(5)*(N+1)
17609 K(N+3,9-ISID)=MSTU(5)*(N+1)
17610 ELSEIF(KFA.EQ.KSUSY1+21) THEN
17611 K(N+2,1)=3
17612 K(N+3,1)=3
17613 ISID=4
17614 IF(KFL2(JT).LT.0) ISID=5
17615 K(ID,ISID)=K(ID,ISID)+(N+2)
17616 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17617 K(N+2,ISID)=MSTU(5)*ID
17618 K(N+3,9-ISID)=MSTU(5)*ID
17619CMRENNA--
17620
17621 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17622 & IABS(KCQ2(JT)).EQ.1) THEN
17623 K(N+2,1)=3
17624 K(N+3,1)=3
17625 ISID=4
17626 IF(KFL2(JT).LT.0) ISID=5
17627 K(N+2,ISID)=MSTU(5)*(N+3)
17628 K(N+3,9-ISID)=MSTU(5)*(N+2)
17629 ENDIF
17630
17631 NSAV=N
17632
17633C...Set colour flow in three-body decays with baryon number violation.
17634C...Neutralino and chargino decays first.
17635 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17636 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17637 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17638 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17639C...Insert junction to keep track of colours.
17640 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17641 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17642 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17643C...Set special junction codes:
17644 K(N+4,1)=42
17645 K(N+4,2)=88
17646
17647C...Order decay products by invariant mass. (will be used in PYSTRF).
17648 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)-
17649 & P(N+1,3)*P(N+2,3)
17650 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)-
17651 & P(N+1,3)*P(N+3,3)
17652 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)-
17653 & P(N+2,3)*P(N+3,3)
17654 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17655 K(N+4,4)=N+3+K(N+4,4)
17656 K(N+4,5)=N+1+MSTU(5)*(N+2)
17657 ELSEIF(PM13.LT.PM23) THEN
17658 K(N+4,4)=N+2+K(N+4,4)
17659 K(N+4,5)=N+1+MSTU(5)*(N+3)
17660 ELSE
17661 K(N+4,4)=N+1+K(N+4,4)
17662 K(N+4,5)=N+2+MSTU(5)*(N+3)
17663 ENDIF
17664 DO 260 J=1,5
17665 P(N+4,J)=0D0
17666 V(N+4,J)=0D0
17667 260 CONTINUE
17668C...Connect daughters to junction.
17669 DO 270 II=N+1,N+3
17670 K(II,4)=0
17671 K(II,5)=0
17672 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17673 270 CONTINUE
17674C...Particle counter should be stepped up one extra for junction.
17675 N=N+1
17676
17677C...Gluino decays.
17678 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17679 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17680 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17681C...Insert junction to keep track of colours.
17682 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17683 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17684 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17685 K(N+4,1)=42
17686 K(N+4,2)=88
17687 DO 280 J=1,5
17688 P(N+4,J)=0D0
17689 V(N+4,J)=0D0
17690 280 CONTINUE
17691 CTMSUM=0D0
17692 DO 290 II=N+1,N+3
17693 K(II,4)=0
17694 K(II,5)=0
17695C...Start by connecting all daughters to junction.
17696 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17697C...Only consider colour topologies with off shell resonances.
17698 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17699 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17700 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17701 IF (RMGLU-RMQ1.LT.RMRES) THEN
17702C...Calculate propagators for each colour topology.
17703 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17704 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17705 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17706 ELSE
17707 CTM2(II-N)=0D0
17708 ENDIF
17709 CTMSUM=CTMSUM+CTM2(II-N)
17710 290 CONTINUE
17711 CTMSUM=PYR(0)*CTMSUM
17712C...Select colour topology J, with most off shell least likely.
17713 J=0
17714 300 J=J+1
17715 CTMSUM=CTMSUM-CTM2(J)
17716 IF (CTMSUM.GT.0D0) GOTO 300
17717C...The lucky winner gets its colour (anti-colour) directly from gluino.
17718 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17719 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17720C...The other gluino colour is connected to junction
17721 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17722 & MSTU(5)
17723 K(N+4,4)=K(N+4,4)+ID
17724C...Lastly, connect junction to remaining daughters.
17725 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17726C...Particle counter should be stepped up one extra for junction.
17727 N=N+1
17728 ENDIF
17729
17730C...Update particle counter.
17731 N=N+3
17732
17733C...2) Everything else two-body decay.
17734 ELSE
17735 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17736 MCT(N-1,1)=0
17737 MCT(N-1,2)=0
17738 MCT(N,1)=0
17739 MCT(N,2)=0
17740C...First set colour flow as if mother colour singlet.
17741 IF(KCQ1(JT).NE.0) THEN
17742 K(N-1,1)=3
17743 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17744 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17745 ENDIF
17746 IF(KCQ2(JT).NE.0) THEN
17747 K(N,1)=3
17748 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17749 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17750 ENDIF
17751C...Then redirect colour flow if mother (anti)triplet.
17752 IF(KCQM(JT).EQ.0) THEN
17753 ELSEIF(KCQM(JT).NE.2) THEN
17754 ISID=4
17755 IF(KCQM(JT).EQ.-1) ISID=5
17756 IDAU=N-1
17757 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17758 K(ID,ISID)=K(ID,ISID)+IDAU
17759 K(IDAU,ISID)=MSTU(5)*ID
17760C...Then redirect colour flow if mother octet.
17761 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17762 IDAU=N-1
17763 IF(KCQ1(JT).EQ.0) IDAU=N
17764 K(ID,4)=K(ID,4)+IDAU
17765 K(ID,5)=K(ID,5)+IDAU
17766 K(IDAU,4)=MSTU(5)*ID
17767 K(IDAU,5)=MSTU(5)*ID
17768 ELSE
17769 ISID=4
17770 IF(KCQ1(JT).EQ.-1) ISID=5
17771 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17772 K(ID,ISID)=K(ID,ISID)+(N-1)
17773 K(ID,9-ISID)=K(ID,9-ISID)+N
17774 K(N-1,ISID)=MSTU(5)*ID
17775 K(N,9-ISID)=MSTU(5)*ID
17776 ENDIF
17777
17778C...Insert junction
17779 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17780 N=N+1
17781C...~q* mother: type 3 junction. ~q mother: type 4.
17782 ITJUNC(JT)=(7+KCQM(JT))/2
17783C...Specify junction KF and set colour flow from junction
17784 K(N,1)=42
17785 K(N,2)=88
17786 K(N,3)=ID
17787C...Junction type encoded together with mother:
17788 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17789 K(N,5)=N-1+MSTU(5)*(N-2)
17790C...Zero P and V for junction (V filled later)
17791 DO 310 J=1,5
17792 P(N,J)=0D0
17793 V(N,J)=0D0
17794 310 CONTINUE
17795C...Set colour flow from mother to junction
17796 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17797C...Set colour flow from daughters to junction
17798 DO 320 II=N-2,N-1
17799 K(II,4) = 0
17800 K(II,5) = 0
17801C...(Anti-)colour mother is junction.
17802 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17803 320 CONTINUE
17804 ENDIF
17805 ENDIF
17806
17807C...End loop over resonances for daughter flavour and mass selection.
17808 MSTU(10)=MSTU10
17809 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17810 & NINH=NINH+1
17811 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17812 & KFL1(JT).EQ.0) THEN
17813 WRITE(CODE,'(I9)') K(ID,2)
17814 WRITE(MASS,'(F9.3)') P(ID,5)
17815 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17816 & CODE//' with mass'//MASS)
17817 MINT(51)=1
17818 GOTO 720
17819 ENDIF
17820 340 CONTINUE
17821
17822C...Check for allowed combinations. Skip if no decays.
17823 IF(JTMAX.EQ.1) THEN
17824 IF(KDCY(1).EQ.0) GOTO 710
17825 ELSEIF(JTMAX.EQ.2) THEN
17826 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17827 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17828 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17829 ELSEIF(JTMAX.EQ.3) THEN
17830 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17831 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17832 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17833 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17834 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17835 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17836 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17837 ENDIF
17838
17839C...Special case: matrix element option for Z0 decay to quarks.
17840 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17841 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17842
17843C...Check consistency of MSTJ options set.
17844 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17845 CALL PYERRM(6,
17846 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17847 MSTJ(110)=1
17848 ENDIF
17849 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17850 CALL PYERRM(6,
17851 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17852
17853 MSTJ(111)=0
17854 ENDIF
17855
17856C...Select alpha_strong behaviour.
17857 MST111=MSTU(111)
17858 PAR112=PARU(112)
17859 MSTU(111)=MSTJ(108)
17860 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17861 & MSTU(111)=1
17862 PARU(112)=PARJ(121)
17863 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17864
17865C...Find axial fraction in total cross section for scalar gluon model.
17866 PARJ(171)=0D0
17867 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17868 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17869 POLL=1D0-PARJ(131)*PARJ(132)
17870 SFF=1D0/(16D0*XW*XW1)
17871 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17872 & (PARJ(123)*PARJ(124))**2)
17873 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17874 VE=4D0*XW-1D0
17875 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17876 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17877 & (PARJ(132)-PARJ(131)))
17878 KFLC=IABS(KFL1(1))
17879 PMQ=PYMASS(KFLC)
17880 QF=KCHG(KFLC,1)/3D0
17881 VQ=1D0
17882 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17883 & 1D0-(2D0*PMQ/P(ID,5))**2))
17884 VF=SIGN(1D0,QF)-4D0*QF*XW
17885 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17886 & VF**2*HF1W)+VQ**3*HF1W
17887 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17888 ENDIF
17889
17890C...Choice of jet configuration.
17891 CALL PYXJET(P(ID,5),NJET,CUT)
17892 KFLC=IABS(KFL1(1))
17893 KFLN=21
17894 IF(NJET.EQ.4) THEN
17895 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17896 ELSEIF(NJET.EQ.3) THEN
17897 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17898 ELSE
17899 MSTJ(120)=1
17900 ENDIF
17901
17902C...Fill jet configuration; return if incorrect kinematics.
17903 NC=N-2
17904 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17905 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17906 ELSEIF(NJET.EQ.2) THEN
17907 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17908 ELSEIF(NJET.EQ.3) THEN
17909 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17910 ELSEIF(KFLN.EQ.21) THEN
17911 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17912 & X12,X14)
17913 ELSE
17914 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17915 & X12,X14)
17916 ENDIF
17917 IF(MSTU(24).NE.0) THEN
17918 MINT(51)=1
17919 MSTU(111)=MST111
17920 PARU(112)=PAR112
17921 GOTO 720
17922 ENDIF
17923
17924C...Angular orientation according to matrix element.
17925 IF(MSTJ(106).EQ.1) THEN
17926 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17927 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17928 CTHE(1)=COS(THEZ)
17929 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17930 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17931 ENDIF
17932
17933C...Boost partons to Z0 rest frame.
17934 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17935 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17936
17937C...Mark decayed resonance and add documentation lines,
17938 K(ID,1)=K(ID,1)+10
17939 IDOC=MINT(83)+MINT(4)
17940 DO 360 I=NC+1,N
17941 I1=MINT(83)+MINT(4)+1
17942 K(I,3)=I1
17943 IF(MSTP(128).GE.1) K(I,3)=ID
17944 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17945 MINT(4)=MINT(4)+1
17946 K(I1,1)=21
17947 K(I1,2)=K(I,2)
17948 K(I1,3)=IREF(IP,4)
17949 DO 350 J=1,5
17950 P(I1,J)=P(I,J)
17951 350 CONTINUE
17952 ENDIF
17953 360 CONTINUE
17954
17955C...Generate parton shower.
17956 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17957 CALL PYSHOW(N-1,N,P(ID,5))
17958 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17959 NPART=2
17960 IPART(1)=N-1
17961 IPART(2)=N
17962 PTPART(1)=0.5D0*P(ID,5)
17963 PTPART(2)=PTPART(1)
17964 NCT=NCT+1
17965 IF(K(N-1,2).GT.0) THEN
17966 MCT(N-1,1)=NCT
17967 MCT(N,2)=NCT
17968 ELSE
17969 MCT(N-1,2)=NCT
17970 MCT(N,1)=NCT
17971 ENDIF
17972 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17973 ENDIF
17974
17975C... End special case for Z0: skip ahead.
17976 MSTU(111)=MST111
17977 PARU(112)=PAR112
17978 GOTO 700
17979 ENDIF
17980
17981C...Order incoming partons and outgoing resonances.
17982 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17983 &NINH.EQ.0) THEN
17984 ILIN(1)=MINT(84)+1
17985 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17986 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17987 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17988 ILIN(2)=2*MINT(84)+3-ILIN(1)
17989 IMIN=1
17990 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17991 & .EQ.36) IMIN=3
17992 IMAX=2
17993 IORD=1
17994 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17995 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17996 IAKIPD=IABS(K(IREF(IP,IORD),2))
17997 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17998 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17999
18000C...Order decay products of resonances.
18001 DO 370 JT=IORD,3-IORD,3-2*IORD
18002 IF(KDCY(JT).EQ.0) THEN
18003 ILIN(IMAX+1)=NSD(JT)
18004 IMAX=IMAX+1
18005 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18006 ILIN(IMAX+1)=N+2*JT-1
18007 ILIN(IMAX+2)=N+2*JT
18008 IMAX=IMAX+2
18009 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18010 K(N+2*JT,2)=K(NSD(JT)+2,2)
18011 ELSE
18012 ILIN(IMAX+1)=N+2*JT
18013
18014 ILIN(IMAX+2)=N+2*JT-1
18015 IMAX=IMAX+2
18016 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18017 K(N+2*JT,2)=K(NSD(JT)+2,2)
18018 ENDIF
18019 370 CONTINUE
18020
18021C...Find charge, isospin, left- and righthanded couplings.
18022 DO 390 I=IMIN,IMAX
18023 DO 380 J=1,4
18024 COUP(I,J)=0D0
18025 380 CONTINUE
18026 KFA=IABS(K(ILIN(I),2))
18027 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18028 COUP(I,1)=KCHG(KFA,1)/3D0
18029 COUP(I,2)=(-1)**MOD(KFA,2)
18030 COUP(I,4)=-2D0*COUP(I,1)*XWV
18031 COUP(I,3)=COUP(I,2)+COUP(I,4)
18032 390 CONTINUE
18033
18034C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18035 IF(ISUB.EQ.22) THEN
18036 DO 420 I=3,5,2
18037 I1=IORD
18038 IF(I.EQ.5) I1=3-IORD
18039 DO 410 J1=1,2
18040 DO 400 J2=1,2
18041 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18042 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18043 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18044 & COUP(I,J2+2)**2
18045 400 CONTINUE
18046 410 CONTINUE
18047 420 CONTINUE
18048 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18049 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18050 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18051 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18052
18053 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18054 ENDIF
18055 ENDIF
18056
18057C...Select angular orientation type - Z'/W' only.
18058 MZPWP=0
18059 IF(ISUB.EQ.141) THEN
18060 IF(PYR(0).LT.PARU(130)) MZPWP=1
18061 IF(IP.EQ.2) THEN
18062 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18063 IAKIR=IABS(K(IREF(2,2),2))
18064 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18065 IF(IAKIR.LE.20) MZPWP=2
18066 ENDIF
18067 IF(IP.GE.3) MZPWP=2
18068 ELSEIF(ISUB.EQ.142) THEN
18069 IF(PYR(0).LT.PARU(136)) MZPWP=1
18070 IF(IP.EQ.2) THEN
18071 IAKIR=IABS(K(IREF(2,2),2))
18072 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18073 IF(IAKIR.LE.20) MZPWP=2
18074 ENDIF
18075 IF(IP.GE.3) MZPWP=2
18076 ENDIF
18077
18078C...Select random angles (begin of weighting procedure).
18079 430 DO 440 JT=1,JTMAX
18080 IF(KDCY(JT).EQ.0) GOTO 440
18081 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18082 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18083 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18084 PHI(JT)=VINT(24)
18085 ELSE
18086 CTHE(JT)=2D0*PYR(0)-1D0
18087 PHI(JT)=PARU(2)*PYR(0)
18088 ENDIF
18089 440 CONTINUE
18090
18091 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18092C...Construct massless four-vectors.
18093 DO 460 I=N+1,N+4
18094 K(I,1)=1
18095 DO 450 J=1,5
18096 P(I,J)=0D0
18097 V(I,J)=0D0
18098 450 CONTINUE
18099 460 CONTINUE
18100 DO 470 JT=1,JTMAX
18101 IF(KDCY(JT).EQ.0) GOTO 470
18102 ID=IREF(IP,JT)
18103 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18104 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18105 P(N+2*JT,3)=-0.5D0*P(ID,5)
18106 P(N+2*JT,4)=0.5D0*P(ID,5)
18107 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18108 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18109 470 CONTINUE
18110
18111C...Store incoming and outgoing momenta, with random rotation to
18112C...avoid accidental zeroes in HA expressions.
18113 IF(ISUB.NE.0) THEN
18114 DO 490 I=IMIN,IMAX
18115 K(N+4+I,1)=1
18116 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18117 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18118 P(N+4+I,5)=P(ILIN(I),5)
18119 DO 480 J=1,3
18120 P(N+4+I,J)=P(ILIN(I),J)
18121 480 CONTINUE
18122 490 CONTINUE
18123 500 THERR=ACOS(2D0*PYR(0)-1D0)
18124 PHIRR=PARU(2)*PYR(0)
18125 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18126 DO 520 I=IMIN,IMAX
18127 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18128 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18129 DO 510 J=1,4
18130 PK(I,J)=P(N+4+I,J)
18131 510 CONTINUE
18132 520 CONTINUE
18133 ENDIF
18134
18135C...Calculate internal products.
18136 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18137 & ISUB.EQ.142) THEN
18138 DO 540 I1=IMIN,IMAX-1
18139 DO 530 I2=I1+1,IMAX
18140 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18141 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18142 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18143 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18144 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18145 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18146 HC(I1,I2)=CONJG(HA(I1,I2))
18147 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18148 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18149 HA(I2,I1)=-HA(I1,I2)
18150 HC(I2,I1)=-HC(I1,I2)
18151 530 CONTINUE
18152 540 CONTINUE
18153 ENDIF
18154
18155C...Calculate four-products.
18156 IF(ISUB.NE.0) THEN
18157 DO 560 I=1,2
18158 DO 550 J=1,4
18159 PK(I,J)=-PK(I,J)
18160 550 CONTINUE
18161 560 CONTINUE
18162 DO 580 I1=IMIN,IMAX-1
18163 DO 570 I2=I1+1,IMAX
18164 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18165 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18166 PKK(I2,I1)=PKK(I1,I2)
18167 570 CONTINUE
18168 580 CONTINUE
18169 ENDIF
18170 ENDIF
18171
18172 KFAGM=IABS(IREF(IP,7))
18173 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18174C...Isotropic decay selected by user.
18175 WT=1D0
18176 WTMAX=1D0
18177
18178 ELSEIF(JTMAX.EQ.3) THEN
18179C...Isotropic decay when three mother particles.
18180 WT=1D0
18181 WTMAX=1D0
18182
18183 ELSEIF(IT4.GE.1) THEN
18184C... Isotropic decay t -> b + W etc for 4th generation q and l.
18185 WT=1D0
18186 WTMAX=1D0
18187
18188 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18189 & IREF(IP,7).EQ.36) THEN
18190C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18191C...CP-odd case added by Kari Ertresvag Myklevoll.
18192C...Now also with mixed Higgs CP-states
18193 ETA=PARP(25)
18194 IF(IP.EQ.1) WTMAX=SH**2
18195 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18196 KFA=IABS(K(IREF(IP,1),2))
18197 KFT=IABS(K(IREF(IP,2),2))
18198
18199 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18200 & MSTP(25).GE.3) THEN
18201C...For mixed CP states need epsilon product.
18202 P10=PK(3,4)
18203 P20=PK(4,4)
18204 P30=PK(5,4)
18205 P40=PK(6,4)
18206 P11=PK(3,1)
18207 P21=PK(4,1)
18208 P31=PK(5,1)
18209 P41=PK(6,1)
18210 P12=PK(3,2)
18211 P22=PK(4,2)
18212 P32=PK(5,2)
18213 P42=PK(6,2)
18214 P13=PK(3,3)
18215 P23=PK(4,3)
18216 P33=PK(5,3)
18217 P43=PK(6,3)
18218 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18219 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18220 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18221 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18222 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18223 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18224 & P22*P30*P41+P13*P22*P31*P40
18225C...For mixed CP states need gauge boson masses.
18226 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18227 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18228 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18229 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18230 XMV=PMAS(KFA,1)
18231 ENDIF
18232
18233C...Z decay
18234 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18235 KFLF1A=IABS(KFL1(1))
18236 EF1=KCHG(KFLF1A,1)/3D0
18237 AF1=SIGN(1D0,EF1+0.1D0)
18238 VF1=AF1-4D0*EF1*XWV
18239 KFLF2A=IABS(KFL1(2))
18240 EF2=KCHG(KFLF2A,1)/3D0
18241 AF2=SIGN(1D0,EF2+0.1D0)
18242 VF2=AF2-4D0*EF2*XWV
18243 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18244 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18245 & THEN
18246C...CP-even decay
18247 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18248 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18249 ELSEIF(MSTP(25).LE.2) THEN
18250C...CP-odd decay
18251 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18252 & -2*PKK(3,4)*PKK(5,6)
18253 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18254 & (PKK(3,4)*PKK(5,6))
18255 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18256 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18257 ELSE
18258C...Mixed CP states.
18259 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18260 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18261 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18262 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18263 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18264 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18265 & +PKK(3,4)*PKK(5,6)
18266 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18267 & +VA12AS*PKK(3,4)*PKK(5,6)
18268 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18269 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18270 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18271 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18272 ENDIF
18273
18274C...W decay
18275 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18276 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18277 & THEN
18278C...CP-even decay
18279 WT=16D0*PKK(3,5)*PKK(4,6)
18280 ELSEIF(MSTP(25).LE.2) THEN
18281C...CP-odd decay
18282 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18283 & -2*PKK(3,4)*PKK(5,6)
18284 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18285 & (PKK(3,4)*PKK(5,6))
18286 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18287 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18288 ELSE
18289C...Mixed CP states.
18290 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18291 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18292 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18293 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18294 & +PKK(3,4)*PKK(5,6)
18295 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18296 & +PKK(3,4)*PKK(5,6)
18297 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18298 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18299 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18300 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18301 ENDIF
18302
18303C...No angular correlations in other Higgs decays.
18304 ELSE
18305 WT=WTMAX
18306 ENDIF
18307
18308 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18309 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18310 & THEN
18311C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18312 I1=IREF(IP,8)
18313 IF(MOD(KFAGM,2).EQ.0) THEN
18314 I2=N+1
18315 I3=N+2
18316 ELSE
18317 I2=N+2
18318 I3=N+1
18319 ENDIF
18320 I4=IREF(IP,2)
18321 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18322 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18323 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18324 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18325
18326 ELSEIF(ISUB.EQ.1) THEN
18327C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18328 EI=KCHG(IABS(MINT(15)),1)/3D0
18329 AI=SIGN(1D0,EI+0.1D0)
18330 VI=AI-4D0*EI*XWV
18331 EF=KCHG(IABS(KFL1(1)),1)/3D0
18332 AF=SIGN(1D0,EF+0.1D0)
18333
18334 VF=AF-4D0*EF*XWV
18335 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18336 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18337 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18338 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18339 & (VI**2+AI**2)*VINT(114)*VF**2)
18340 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18341 & 4D0*VI*AI*VINT(114)*VF*AF)
18342 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18343 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18344 WTMAX=2D0*(WT1+ABS(WT3))
18345
18346 ELSEIF(ISUB.EQ.2) THEN
18347C...Angular weight for W+/- -> 2 quarks/leptons.
18348 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18349 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18350 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18351 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18352 WTMAX=4D0
18353
18354 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18355C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18356C...-> gluon/gamma + 2 quarks/leptons.
18357 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18358 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18359 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18360 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18361 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18362 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18363 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18364 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18365 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18366 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18367 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18368 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18369 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18370 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18371 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18372 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18373
18374 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18375C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18376C...-> gluon/gamma + 2 quarks/leptons.
18377 WT=PKK(1,3)**2+PKK(2,4)**2
18378 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18379
18380 ELSEIF(ISUB.EQ.22) THEN
18381C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18382 S34=P(IREF(IP,IORD),5)**2
18383 S56=P(IREF(IP,3-IORD),5)**2
18384 TI=PKK(1,3)+PKK(1,4)+S34
18385 UI=PKK(1,5)+PKK(1,6)+S56
18386 TIR=REAL(TI)
18387 UIR=REAL(UI)
18388 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18389 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18390 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18391 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18392 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18393 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18394 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18395 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18396
18397 WT=
18398 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18399 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18400 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18401 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18402 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18403 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18404 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18405 & 1D0/UI**2))
18406
18407 ELSEIF(ISUB.EQ.23) THEN
18408C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18409 D34=P(IREF(IP,IORD),5)**2
18410 D56=P(IREF(IP,3-IORD),5)**2
18411 DT=PKK(1,3)+PKK(1,4)+D34
18412 DU=PKK(1,5)+PKK(1,6)+D56
18413 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18414 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18415 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18416 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18417
18418 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18419 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18420 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18421 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18422 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18423 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18424
18425 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18426C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18427C...(or H0, or A0).
18428 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18429 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18430 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18431 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18432 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18433
18434 ELSEIF(ISUB.EQ.25) THEN
18435C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18436 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18437 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18438 D34=P(IREF(IP,IORD),5)**2
18439 D56=P(IREF(IP,3-IORD),5)**2
18440 DT=PKK(1,3)+PKK(1,4)+D34
18441 DU=PKK(1,5)+PKK(1,6)+D56
18442 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18443 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18444 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18445 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18446 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18447 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18448 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18449 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18450 IF(MSTP(50).LE.0) THEN
18451 WT=FGK135**2+(CCWW*FGK253)**2
18452 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18453 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18454 & DJGK(DT,DU)))
18455 ELSE
18456 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18457 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18458 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18459 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18460 ENDIF
18461
18462 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18463C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18464C...(or H0, or A0).
18465 WT=PKK(1,3)*PKK(2,4)
18466 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18467
18468 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18469C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18470C...-> f + 2 quarks/leptons.
18471 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18472 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18473 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18474 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18475 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18476 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18477 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18478 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18479 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18480 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18481 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18482 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18483 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18484 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18485 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18486 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18487 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18488 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18489
18490 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18491C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18492 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18493 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18494 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18495
18496 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18497 & ISUB.EQ.77) THEN
18498C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18499 WT=16D0*PKK(3,5)*PKK(4,6)
18500 WTMAX=SH**2
18501
18502 ELSEIF(ISUB.EQ.110) THEN
18503C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18504 WT=1D0
18505 WTMAX=1D0
18506
18507 ELSEIF(ISUB.EQ.141) THEN
18508C...Special case: if only branching ratios known then isotropic decay.
18509 IF(MWID(32).EQ.2) THEN
18510 WT=1D0
18511 WTMAX=1D0
18512 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18513C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18514C...Couplings of incoming flavour.
18515 KFAI=IABS(MINT(15))
18516 EI=KCHG(KFAI,1)/3D0
18517 AI=SIGN(1D0,EI+0.1D0)
18518 VI=AI-4D0*EI*XWV
18519 KFAIC=1
18520 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18521 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18522 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18523 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18524 VPI=PARU(119+2*KFAIC)
18525 API=PARU(120+2*KFAIC)
18526 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18527 VPI=PARJ(178+2*KFAIC)
18528 API=PARJ(179+2*KFAIC)
18529 ELSE
18530 VPI=PARJ(186+2*KFAIC)
18531 API=PARJ(187+2*KFAIC)
18532 ENDIF
18533C...Couplings of final flavour.
18534 KFAF=IABS(KFL1(1))
18535 EF=KCHG(KFAF,1)/3D0
18536 AF=SIGN(1D0,EF+0.1D0)
18537 VF=AF-4D0*EF*XWV
18538 KFAFC=1
18539 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18540 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18541 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18542 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18543 VPF=PARU(119+2*KFAFC)
18544 APF=PARU(120+2*KFAFC)
18545 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18546 VPF=PARJ(178+2*KFAFC)
18547 APF=PARJ(179+2*KFAFC)
18548 ELSE
18549 VPF=PARJ(186+2*KFAFC)
18550 APF=PARJ(187+2*KFAFC)
18551 ENDIF
18552C...Asymmetry and weight.
18553 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18554 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18555 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18556 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18557 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18558 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18559 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18560 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18561 WTMAX=2D0+ABS(ASYM)
18562 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
18563C...Angular weight for f + fbar -> Z' -> W+ + W-.
18564 RM1=P(NSD(1)+1,5)**2/SH
18565 RM2=P(NSD(1)+2,5)**2/SH
18566 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18567 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18568 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18569 & (RM2-RM1)**2)
18570 WT=CFLAT+CCOS2*CTHE(1)**2
18571 WTMAX=CFLAT+MAX(0D0,CCOS2)
18572 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
18573 & IABS(KFL1(1)).EQ.37)) THEN
18574C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18575 WT=1D0-CTHE(1)**2
18576 WTMAX=1D0
18577 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18578C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18579 RM1=P(NSD(1)+1,5)**2/SH
18580 RM2=P(NSD(1)+2,5)**2/SH
18581 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18582 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18583 WTMAX=1D0+FLAM2/(8D0*RM1)
18584 ELSEIF(MZPWP.EQ.0) THEN
18585C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18586C...(W:s like if intermediate Z).
18587 D34=P(IREF(IP,IORD),5)**2
18588 D56=P(IREF(IP,3-IORD),5)**2
18589 DT=PKK(1,3)+PKK(1,4)+D34
18590 DU=PKK(1,5)+PKK(1,6)+D56
18591 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18592 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18593 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
18594 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
18595 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18596 ELSEIF(MZPWP.EQ.1) THEN
18597C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18598C...(W:s approximately longitudinal, like if intermediate H).
18599 WT=16D0*PKK(3,5)*PKK(4,6)
18600 WTMAX=SH**2
18601 ELSE
18602C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18603C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18604 WT=1D0
18605 WTMAX=1D0
18606 ENDIF
18607
18608 ELSEIF(ISUB.EQ.142) THEN
18609C...Special case: if only branching ratios known then isotropic decay.
18610 IF(MWID(34).EQ.2) THEN
18611 WT=1D0
18612 WTMAX=1D0
18613 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18614C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18615 KFAI=IABS(MINT(15))
18616 KFAIC=1
18617 IF(KFAI.GT.10) KFAIC=2
18618 VI=PARU(129+2*KFAIC)
18619 AI=PARU(130+2*KFAIC)
18620 KFAF=IABS(KFL1(1))
18621 KFAFC=1
18622 IF(KFAF.GT.10) KFAFC=2
18623 VF=PARU(129+2*KFAFC)
18624 AF=PARU(130+2*KFAFC)
18625 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18626 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18627 WTMAX=2D0+ABS(ASYM)
18628 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18629C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18630 RM1=P(NSD(1)+1,5)**2/SH
18631 RM2=P(NSD(1)+2,5)**2/SH
18632 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18633 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18634 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18635 & (RM2-RM1)**2)
18636 WT=CFLAT+CCOS2*CTHE(1)**2
18637 WTMAX=CFLAT+MAX(0D0,CCOS2)
18638 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18639C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18640 RM1=P(NSD(1)+1,5)**2/SH
18641 RM2=P(NSD(1)+2,5)**2/SH
18642 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18643 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18644 WTMAX=1D0+FLAM2/(8D0*RM1)
18645 ELSEIF(MZPWP.EQ.0) THEN
18646C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18647C...(W/Z like if intermediate W).
18648 D34=P(IREF(IP,IORD),5)**2
18649 D56=P(IREF(IP,3-IORD),5)**2
18650 DT=PKK(1,3)+PKK(1,4)+D34
18651 DU=PKK(1,5)+PKK(1,6)+D56
18652 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18653 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18654 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18655 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18656 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18657 ELSEIF(MZPWP.EQ.1) THEN
18658C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18659C...(W/Z approximately longitudinal, like if intermediate H).
18660 WT=16D0*PKK(3,5)*PKK(4,6)
18661 WTMAX=SH**2
18662 ELSE
18663C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18664C...t + bbar -> t + W + bbar.
18665 WT=1D0
18666 WTMAX=1D0
18667 ENDIF
18668
18669 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18670 & THEN
18671C...Isotropic decay of leptoquarks (assumed spin 0).
18672 WT=1D0
18673 WTMAX=1D0
18674
18675 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18676C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18677 SIDE=1D0
18678 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18679 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18680 WT=1D0+SIDE*CTHE(1)
18681 WTMAX=2D0
18682 ELSEIF(IP.EQ.1) THEN
18683
18684 RM1=P(NSD(1)+1,5)**2/SH
18685 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18686 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18687 ELSE
18688C...W/Z decay assumed isotropic, since not known.
18689 WT=1D0
18690 WTMAX=1D0
18691 ENDIF
18692
18693 ELSEIF(ISUB.EQ.149) THEN
18694C...Isotropic decay of techni-eta.
18695 WT=1D0
18696 WTMAX=1D0
18697
18698 ELSEIF(ISUB.EQ.191) THEN
18699 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18700C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18701C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18702 WT=1D0-CTHE(1)**2
18703 WTMAX=1D0
18704 ELSEIF(IP.EQ.1) THEN
18705C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18706 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18707 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18708 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18709 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18710 KFAI=IABS(MINT(15))
18711 EI=KCHG(KFAI,1)/3D0
18712 AI=SIGN(1D0,EI+0.1D0)
18713 VI=AI-4D0*EI*XWV
18714 VALI=0.5D0*(VI+AI)
18715 VARI=0.5D0*(VI-AI)
18716 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18717 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18718 KFAF=IABS(KFL1(1))
18719 EF=KCHG(KFAF,1)/3D0
18720 AF=SIGN(1D0,EF+0.1D0)
18721 VF=AF-4D0*EF*XWV
18722 VALF=0.5D0*(VF+AF)
18723 VARF=0.5D0*(VF-AF)
18724 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18725 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18726 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18727 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18728 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18729 WTMAX=4D0*MAX(ASAME,AFLIP)
18730 ELSE
18731C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18732 WT=1D0
18733 WTMAX=1D0
18734 ENDIF
18735
18736 ELSEIF(ISUB.EQ.192) THEN
18737 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18738C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18739C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18740 WT=1D0-CTHE(1)**2
18741 WTMAX=1D0
18742 ELSEIF(IP.EQ.1) THEN
18743C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18744 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18745 WT=(1D0+CTHESG)**2
18746 WTMAX=4D0
18747 ELSE
18748C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18749 WT=1D0
18750 WTMAX=1D0
18751 ENDIF
18752
18753 ELSEIF(ISUB.EQ.193) THEN
18754 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18755C...Angular weight for f + fbar -> omega_tc0 ->
18756C...gamma pi_tc0 or Z0 pi_tc0.
18757 WT=1D0+CTHE(1)**2
18758 WTMAX=2D0
18759 ELSEIF(IP.EQ.1) THEN
18760C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18761 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18762 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18763 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18764 KFAI=IABS(MINT(15))
18765 EI=KCHG(KFAI,1)/3D0
18766 AI=SIGN(1D0,EI+0.1D0)
18767 VI=AI-4D0*EI*XWV
18768 VALI=0.5D0*(VI+AI)
18769 VARI=0.5D0*(VI-AI)
18770 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18771 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18772 KFAF=IABS(KFL1(1))
18773 EF=KCHG(KFAF,1)/3D0
18774 AF=SIGN(1D0,EF+0.1D0)
18775 VF=AF-4D0*EF*XWV
18776 VALF=0.5D0*(VF+AF)
18777 VARF=0.5D0*(VF-AF)
18778 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18779 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18780 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18781 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18782 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18783 WTMAX=4D0*MAX(BSAME,BFLIP)
18784 ELSE
18785C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18786 WT=1D0
18787 WTMAX=1D0
18788 ENDIF
18789
18790 ELSEIF(ISUB.EQ.353) THEN
18791C...Angular weight for Z_R0 -> 2 quarks/leptons.
18792 EI=KCHG(IABS(MINT(15)),1)/3D0
18793 AI=SIGN(1D0,EI+0.1D0)
18794 VI=AI-4D0*EI*XWV
18795 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18796 AF=SIGN(1D0,EF+0.1D0)
18797 VF=AF-4D0*EF*XWV
18798 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18799 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18800 WT2=RMF*(VI**2+AI**2)*VF**2
18801 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18802 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18803 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18804 WTMAX=2D0*(WT1+ABS(WT3))
18805
18806 ELSEIF(ISUB.EQ.354) THEN
18807C...Angular weight for W_R+/- -> 2 quarks/leptons.
18808 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18809 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18810 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18811 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18812 WTMAX=4D0
18813
18814 ELSEIF(ISUB.EQ.391) THEN
18815C...Angular weight for f + fbar -> G* -> f + fbar
18816 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18817 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18818 WTMAX=2D0
18819C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18820C...implemented by M.-C. Lemaire
18821 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18822 & IABS(KFL1(1)).EQ.22)) THEN
18823 WT=1D0-CTHE(1)**4
18824 WTMAX=1D0
18825C...Other G* decays not yet implemented angular distributions.
18826 ELSE
18827 WT=1D0
18828 WTMAX=1D0
18829 ENDIF
18830
18831 ELSEIF(ISUB.EQ.392) THEN
18832C...Angular weight for g + g -> G* -> f + fbar
18833 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18834 WT=1D0-CTHE(1)**4
18835 WTMAX=1D0
18836C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18837C...implemented by M.-C. Lemaire
18838 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18839 & IABS(KFL1(1)).EQ.22)) THEN
18840 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18841 WTMAX=8D0
18842C...Other G* decays not yet implemented angular distributions.
18843 ELSE
18844 WT=1D0
18845 WTMAX=1D0
18846 ENDIF
18847
18848C...Obtain correct angular distribution by rejection techniques.
18849 ELSE
18850 WT=1D0
18851 WTMAX=1D0
18852 ENDIF
18853 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18854
18855C...Construct massive four-vectors using angles chosen.
18856 590 DO 690 JT=1,JTMAX
18857 IF(KDCY(JT).EQ.0) GOTO 690
18858 ID=IREF(IP,JT)
18859 DO 600 J=1,5
18860 DPMO(J)=P(ID,J)
18861 600 CONTINUE
18862 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18863CMRENNA++
18864 IF(KFL3(JT).EQ.0) THEN
18865 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18866 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18867 N0=NSD(JT)+2
18868 ELSE
18869 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18870 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18871 N0=NSD(JT)+3
18872 ENDIF
18873
18874 DO 610 J=1,4
18875 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18876 610 CONTINUE
18877C...Fill in position of decay vertex.
18878 DO 630 I=NSD(JT)+1,N0
18879 DO 620 J=1,4
18880 V(I,J)=VDCY(J)
18881 620 CONTINUE
18882 V(I,5)=0D0
18883
18884 630 CONTINUE
18885CMRENNA--
18886
18887C...Mark decayed resonances; trace history.
18888 K(ID,1)=K(ID,1)+10
18889 KFA=IABS(K(ID,2))
18890 KCA=PYCOMP(KFA)
18891 IF(KCQM(JT).NE.0) THEN
18892C...Do not kill colour flow through coloured resonance!
18893 ELSE
18894 K(ID,4)=NSD(JT)+1
18895 K(ID,5)=NSD(JT)+2
18896C...If 3-body or 2-body with junction:
18897 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18898C...If 3-body with junction:
18899 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18900 ENDIF
18901
18902C...Add documentation lines.
18903 ISUBRG=MAX(1,MIN(500,MINT(1)))
18904 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18905 IDOC=MINT(83)+MINT(4)
18906CMRENNA+++
18907 IHI=NSD(JT)+2
18908 IF(KFL3(JT).NE.0) IHI=IHI+1
18909 DO 650 I=NSD(JT)+1,IHI
18910CMRENNA---
18911 I1=MINT(83)+MINT(4)+1
18912 K(I,3)=I1
18913 IF(MSTP(128).GE.1) K(I,3)=ID
18914 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18915 MINT(4)=MINT(4)+1
18916 K(I1,1)=21
18917 K(I1,2)=K(I,2)
18918 K(I1,3)=IREF(IP,JT+3)
18919 DO 640 J=1,5
18920 P(I1,J)=P(I,J)
18921 640 CONTINUE
18922 ENDIF
18923 650 CONTINUE
18924 ELSE
18925 K(NSD(JT)+1,3)=ID
18926 K(NSD(JT)+2,3)=ID
18927C...If 3-body or 2-body with junction:
18928 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18929C...If 3-body with junction:
18930 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18931 ENDIF
18932
18933C...Do showering of two or three objects.
18934 NSHBEF=N
18935 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18936 IF(KFL3(JT).EQ.0) THEN
18937 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18938 ELSE
18939 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18940 ENDIF
18941
18942c...For pT-ordered shower need set up first, especially colour tags.
18943C...(Need to set up colour tags even if MSTP(71) = 0)
18944 ELSEIF(MINT(35).GE.2) THEN
18945 NPART=2
18946 IF(KFL3(JT).NE.0) NPART=3
18947 IPART(1)=NSD(JT)+1
18948 IPART(2)=NSD(JT)+2
18949 IPART(3)=NSD(JT)+3
18950 PTPART(1)=0.5D0*P(ID,5)
18951 PTPART(2)=PTPART(1)
18952 PTPART(3)=PTPART(1)
18953 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18954 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18955 IF(MOTHER.LE.NSD(JT)) THEN
18956 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18957 ELSE
18958 NCT=NCT+1
18959 MCT(NSD(JT)+1,1)=NCT
18960 MCT(MOTHER,2)=NCT
18961 ENDIF
18962 ENDIF
18963 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18964 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18965 IF(MOTHER.LE.NSD(JT)) THEN
18966 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18967 ELSE
18968 NCT=NCT+1
18969 MCT(NSD(JT)+1,2)=NCT
18970 MCT(MOTHER,1)=NCT
18971 ENDIF
18972 ENDIF
18973 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18974 & KCQ2(JT).EQ.2)) THEN
18975 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18976 IF(MOTHER.LE.NSD(JT)) THEN
18977 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18978 ELSE
18979 NCT=NCT+1
18980 MCT(NSD(JT)+2,1)=NCT
18981 MCT(MOTHER,2)=NCT
18982 ENDIF
18983 ENDIF
18984 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18985 & KCQ2(JT).EQ.2)) THEN
18986 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18987 IF(MOTHER.LE.NSD(JT)) THEN
18988 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18989 ELSE
18990 NCT=NCT+1
18991 MCT(NSD(JT)+2,2)=NCT
18992 MCT(MOTHER,1)=NCT
18993 ENDIF
18994 ENDIF
18995 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18996 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18997 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18998 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18999 ENDIF
19000 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
19001 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19002 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19003 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19004 ENDIF
19005 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19006 ENDIF
19007 NSHAFT=N
19008 IF(JT.EQ.1) NAFT1=N
19009
19010C...Check if decay products moved by shower.
19011 NSD1=NSD(JT)+1
19012 NSD2=NSD(JT)+2
19013 NSD3=NSD(JT)+3
19014 IF(NSHAFT.GT.NSHBEF) THEN
19015 IF(K(NSD1,1).GT.10) THEN
19016 DO 660 I=NSHBEF+1,NSHAFT
19017 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19018 660 CONTINUE
19019 ENDIF
19020 IF(K(NSD2,1).GT.10) THEN
19021 DO 670 I=NSHBEF+1,NSHAFT
19022 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19023 & I.NE.NSD1) NSD2=I
19024 670 CONTINUE
19025 ENDIF
19026 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19027 DO 680 I=NSHBEF+1,NSHAFT
19028 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19029 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19030 680 CONTINUE
19031 ENDIF
19032 ENDIF
19033
19034C...Store decay products for further treatment.
19035 NP=NP+1
19036 IREF(NP,1)=NSD1
19037 IREF(NP,2)=NSD2
19038 IREF(NP,3)=0
19039 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19040 IREF(NP,4)=IDOC+1
19041 IREF(NP,5)=IDOC+2
19042 IREF(NP,6)=0
19043 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19044 IREF(NP,7)=K(IREF(IP,JT),2)
19045 IREF(NP,8)=IREF(IP,JT)
19046 690 CONTINUE
19047
19048
19049C...Fill information for 2 -> 1 -> 2.
19050 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19051 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19052 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19053 MINT(25)=KFL1(1)
19054 MINT(26)=KFL2(1)
19055 VINT(23)=CTHE(1)
19056 RM3=P(N-1,5)**2/SH
19057 RM4=P(N,5)**2/SH
19058 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19059 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19060 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19061 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19062 VINT(47)=SQRT(VINT(48))
19063 ENDIF
19064
19065C...Possibility of colour rearrangement in W+W- events.
19066 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19067 IAKF1=IABS(KFL1(1))
19068 IAKF2=IABS(KFL1(2))
19069 IAKF3=IABS(KFL2(1))
19070 IAKF4=IABS(KFL2(2))
19071 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19072 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19073 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19074 IF(MINT(51).NE.0) RETURN
19075 ENDIF
19076
19077C...Loop back if needed.
19078 710 IF(IP.LT.NP) GOTO 170
19079
19080C...Boost back to standard frame.
19081 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19082 &BEZIN)
19083
19084 RETURN
19085 END
19086
19087C*********************************************************************
19088
19089C...PYMULT
19090C...Initializes treatment of multiple interactions, selects kinematics
19091C...of hardest interaction if low-pT physics included in run, and
19092C...generates all non-hardest interactions.
19093
19094 SUBROUTINE PYMULT(MMUL)
19095
19096C...Double precision and integer declarations.
19097 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19098 IMPLICIT INTEGER(I-N)
19099 INTEGER PYK,PYCHGE,PYCOMP
19100C...Commonblocks.
19101 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19103 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19104 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19105 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19106 COMMON/PYINT1/MINT(400),VINT(400)
19107 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19108 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19109 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19110 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19111 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19112 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19113C...Local arrays and saved variables.
19114 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19115 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19116 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19117 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19118
19119C...Initialization of multiple interaction treatment.
19120 IF(MMUL.EQ.1) THEN
19121 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19122 ISUB=96
19123 MINT(1)=96
19124 VINT(63)=0D0
19125 VINT(64)=0D0
19126 VINT(143)=1D0
19127 VINT(144)=1D0
19128
19129C...Loop over phase space points: xT2 choice in 20 bins.
19130 100 SIGSUM=0D0
19131 DO 120 IXT2=1,20
19132 NMUL(IXT2)=MSTP(83)
19133 SIGM(IXT2)=0D0
19134 DO 110 ITRY=1,MSTP(83)
19135 RSCA=0.05D0*((21-IXT2)-PYR(0))
19136 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19137 XT2=MAX(0.01D0*VINT(149),XT2)
19138 VINT(25)=XT2
19139
19140C...Choose tau and y*. Calculate cos(theta-hat).
19141 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19142 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19143 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19144 ELSE
19145 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19146 ENDIF
19147 VINT(21)=TAU
19148 CALL PYKLIM(2)
19149 RYST=PYR(0)
19150 MYST=1
19151 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19152 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19153 CALL PYKMAP(2,MYST,PYR(0))
19154 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19155
19156C...Calculate differential cross-section.
19157 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19158 CALL PYSIGH(NCHN,SIGS)
19159 SIGM(IXT2)=SIGM(IXT2)+SIGS
19160 110 CONTINUE
19161 SIGSUM=SIGSUM+SIGM(IXT2)
19162 120 CONTINUE
19163 SIGSUM=SIGSUM/(20D0*MSTP(83))
19164
19165C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19166 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19167 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19168 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19169 PARP(82)=0.9D0*PARP(82)
19170 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19171 & VINT(2)
19172 GOTO 100
19173 ENDIF
19174 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19175 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19176
19177C...Start iteration to find k factor.
19178 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19179 P83A=(1D0-PARP(83))**2
19180 P83B=2D0*PARP(83)*(1D0-PARP(83))
19181 P83C=PARP(83)**2
19182 CQ2I=1D0/PARP(84)**2
19183 CQ2R=2D0/(1D0+PARP(84)**2)
19184 SO=0.5D0
19185 XI=0D0
19186 YI=0D0
19187 XF=0D0
19188 YF=0D0
19189 XK=0.5D0
19190 IIT=0
19191 130 IF(IIT.EQ.0) THEN
19192 XK=2D0*XK
19193 ELSEIF(IIT.EQ.1) THEN
19194 XK=0.5D0*XK
19195 ELSE
19196 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19197 ENDIF
19198
19199C...Evaluate overlap integrals. Find where to divide the b range.
19200 IF(MSTP(82).EQ.2) THEN
19201 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19202 SOP=SP/PARU(1)
19203 ELSE
19204 IF(MSTP(82).EQ.3) THEN
19205 DELTAB=0.02D0
19206 ELSEIF(MSTP(82).EQ.4) THEN
19207 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19208 ELSE
19209 POWIP=MAX(0.4D0,PARP(83))
19210 RPWIP=2D0/POWIP-1D0
19211 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19212 SO=0D0
19213 ENDIF
19214 SP=0D0
19215 SOP=0D0
19216 BSP=0D0
19217 SOHIGH=0D0
19218 IBDIV=0
19219 B=-0.5D0*DELTAB
19220 140 B=B+DELTAB
19221 IF(MSTP(82).EQ.3) THEN
19222 OV=EXP(-B**2)/PARU(2)
19223 ELSEIF(MSTP(82).EQ.4) THEN
19224 OV=(P83A*EXP(-MIN(50D0,B**2))+
19225 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19226 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19227 ELSE
19228 OV=EXP(-B**POWIP)/PARU(2)
19229 SO=SO+PARU(2)*B*DELTAB*OV
19230 ENDIF
19231 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19232 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19233 SP=SP+PARU(2)*B*DELTAB*PACC
19234 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19235 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19236 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19237 IBDIV=1
19238 BDIV=B+0.5D0*DELTAB
19239 ENDIF
19240 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19241 ENDIF
19242 YK=PARU(1)*XK*SO/SP
19243
19244C...Continue iteration until convergence.
19245 IF(YK.LT.YKE) THEN
19246 XI=XK
19247 YI=YK
19248 IF(IIT.EQ.1) IIT=2
19249 ELSE
19250 XF=XK
19251 YF=YK
19252 IF(IIT.EQ.0) IIT=1
19253 ENDIF
19254 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19255
19256C...Store some results for subsequent use.
19257 BAVG=BSP/SP
19258 VINT(145)=SIGSUM
19259 VINT(146)=SOP/SO
19260 VINT(147)=SOP/SP
19261 VNT145=VINT(145)
19262 VNT146=VINT(146)
19263 VNT147=VINT(147)
19264C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19265 PIK=(VNT146/VNT147)*YKE
19266
19267C...Find relative weight for low and high impact parameter.
19268 PLOWB=PARU(1)*BDIV**2
19269 IF(MSTP(82).EQ.3) THEN
19270 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19271 ELSEIF(MSTP(82).EQ.4) THEN
19272 S4A=P83A*EXP(-BDIV**2)
19273 S4B=P83B*EXP(-BDIV**2*CQ2R)
19274 S4C=P83C*EXP(-BDIV**2*CQ2I)
19275 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19276 ELSEIF(PARP(83).GE.1.999D0) THEN
19277 PHIGHB=PIK*SOHIGH
19278 B2RPDV=BDIV**POWIP
19279 ELSE
19280 PHIGHB=PIK*SOHIGH
19281 B2RPDV=BDIV**POWIP
19282 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19283 ENDIF
19284 PALLB=PLOWB+PHIGHB
19285
19286C...Initialize iteration in xT2 for hardest interaction.
19287 ELSEIF(MMUL.EQ.2) THEN
19288 VINT(145)=VNT145
19289 VINT(146)=VNT146
19290 VINT(147)=VNT147
19291 IF(MSTP(82).LE.0) THEN
19292 ELSEIF(MSTP(82).EQ.1) THEN
19293 XT2=1D0
19294 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19295 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19296 & VINT(317)/(VINT(318)*VINT(320))
19297 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19298 ELSEIF(MSTP(82).EQ.2) THEN
19299 XT2=1D0
19300 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19301 & VINT(149)*(1D0+VINT(149))
19302 ELSE
19303 XC2=4D0*CKIN(3)**2/VINT(2)
19304 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19305 ENDIF
19306
19307C...Select impact parameter for hardest interaction.
19308 IF(MSTP(82).LE.2) RETURN
19309 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19310C...Treatment in low b region.
19311 MINT(39)=1
19312 B=BDIV*SQRT(PYR(0))
19313 IF(MSTP(82).EQ.3) THEN
19314 OV=EXP(-B**2)/PARU(2)
19315 ELSEIF(MSTP(82).EQ.4) THEN
19316 OV=(P83A*EXP(-MIN(50D0,B**2))+
19317 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19318 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19319 ELSE
19320 OV=EXP(-B**POWIP)/PARU(2)
19321 ENDIF
19322 VINT(148)=OV/VNT147
19323 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19324 XT2=1D0
19325 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19326 & VINT(149)*(1D0+VINT(149))
19327 ELSE
19328C...Treatment in high b region.
19329 MINT(39)=2
19330 IF(MSTP(82).EQ.3) THEN
19331 B=SQRT(BDIV**2-LOG(PYR(0)))
19332 OV=EXP(-B**2)/PARU(2)
19333 ELSEIF(MSTP(82).EQ.4) THEN
19334 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19335 IF(S4RNDM.LT.S4A) THEN
19336 B=SQRT(BDIV**2-LOG(PYR(0)))
19337 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19338 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19339 ELSE
19340 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19341 ENDIF
19342 OV=(P83A*EXP(-MIN(50D0,B**2))+
19343 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19344 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19345 ELSEIF(PARP(83).GE.1.999D0) THEN
19346 144 B2RPW=B2RPDV-LOG(PYR(0))
19347 ACCIP=(B2RPW/B2RPDV)**RPWIP
19348 IF(ACCIP.LT.PYR(0)) GOTO 144
19349 OV=EXP(-B2RPW)/PARU(2)
19350 B=B2RPW**(1D0/POWIP)
19351 ELSE
19352 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19353 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19354 IF(ACCIP.LT.PYR(0)) GOTO 146
19355 OV=EXP(-B2RPW)/PARU(2)
19356 B=B2RPW**(1D0/POWIP)
19357 ENDIF
19358 VINT(148)=OV/VNT147
19359 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19360 ENDIF
19361 IF(PACC.LT.PYR(0)) GOTO 142
19362 VINT(139)=B/BAVG
19363
19364 ELSEIF(MMUL.EQ.3) THEN
19365C...Low-pT or multiple interactions (first semihard interaction):
19366C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19367C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19368 ISUB=MINT(1)
19369 VINT(145)=VNT145
19370 VINT(146)=VNT146
19371 VINT(147)=VNT147
19372 IF(MSTP(82).LE.0) THEN
19373 XT2=0D0
19374 ELSEIF(MSTP(82).EQ.1) THEN
19375 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19376C...Use with "Sudakov" for low b values when impact parameter dependence.
19377 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19378 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19379 & VINT(149)))).GT.PYR(0)) XT2=1D0
19380 IF(XT2.GE.1D0) THEN
19381 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19382 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19383 & VINT(149)
19384 ELSE
19385 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19386 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19387 & VINT(149)
19388 ENDIF
19389 XT2=MAX(0.01D0*VINT(149),XT2)
19390C...Use without "Sudakov" for high b values when impact parameter dep.
19391 ELSE
19392 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19393 & PYR(0)*(1D0-XC2))-VINT(149)
19394 XT2=MAX(0.01D0*VINT(149),XT2)
19395 ENDIF
19396 VINT(25)=XT2
19397
19398C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19399 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19400 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19401 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19402 ISUB=95
19403 MINT(1)=ISUB
19404 VINT(21)=0.01D0*VINT(149)
19405 VINT(22)=0D0
19406 VINT(23)=0D0
19407 VINT(25)=0.01D0*VINT(149)
19408
19409 ELSE
19410C...Multiple interactions (first semihard interaction).
19411C...Choose tau and y*. Calculate cos(theta-hat).
19412 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19413 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19414 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19415 ELSE
19416 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19417 ENDIF
19418 VINT(21)=TAU
19419 CALL PYKLIM(2)
19420 RYST=PYR(0)
19421 MYST=1
19422 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19423 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19424 CALL PYKMAP(2,MYST,PYR(0))
19425 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19426 ENDIF
19427 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19428
19429C...Store results of cross-section calculation.
19430 ELSEIF(MMUL.EQ.4) THEN
19431 ISUB=MINT(1)
19432 VINT(145)=VNT145
19433 VINT(146)=VNT146
19434 VINT(147)=VNT147
19435 XTS=VINT(25)
19436 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19437 IF(ISET(ISUB).EQ.2)
19438 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19439 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19440 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19441 & (XTS+VINT(149))))
19442 IRBIN=INT(1D0+20D0*RBIN)
19443 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19444 NMUL(IRBIN)=NMUL(IRBIN)+1
19445 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19446 ENDIF
19447
19448C...Choose impact parameter if not already done.
19449 ELSEIF(MMUL.EQ.5) THEN
19450 ISUB=MINT(1)
19451 VINT(145)=VNT145
19452 VINT(146)=VNT146
19453 VINT(147)=VNT147
19454 150 IF(MINT(39).GT.0) THEN
19455 ELSEIF(MSTP(82).EQ.3) THEN
19456 EXPB2=PYR(0)
19457 B2=-LOG(PYR(0))
19458 VINT(148)=EXPB2/(PARU(2)*VNT147)
19459 VINT(139)=SQRT(B2)/BAVG
19460 ELSEIF(MSTP(82).EQ.4) THEN
19461 RTYPE=PYR(0)
19462 IF(RTYPE.LT.P83A) THEN
19463 B2=-LOG(PYR(0))
19464 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19465 B2=-LOG(PYR(0))/CQ2R
19466 ELSE
19467 B2=-LOG(PYR(0))/CQ2I
19468 ENDIF
19469 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19470 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19471 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19472 VINT(139)=SQRT(B2)/BAVG
19473 ELSEIF(PARP(83).GE.1.999D0) THEN
19474 POWIP=MAX(2D0,PARP(83))
19475 RPWIP=2D0/POWIP-1D0
19476 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19477 160 IF(PYR(0).LT.PROB1) THEN
19478 B2RPW=PYR(0)**(0.5D0*POWIP)
19479 ACCIP=EXP(-B2RPW)
19480 ELSE
19481 B2RPW=1D0-LOG(PYR(0))
19482 ACCIP=B2RPW**RPWIP
19483 ENDIF
19484 IF(ACCIP.LT.PYR(0)) GOTO 160
19485 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19486 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19487 ELSE
19488 POWIP=MAX(0.4D0,PARP(83))
19489 RPWIP=2D0/POWIP-1D0
19490 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19491 170 IF(PYR(0).LT.PROB1) THEN
19492 B2RPW=2D0*RPWIP*PYR(0)
19493 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19494 ELSE
19495 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19496 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19497 ENDIF
19498 IF(ACCIP.LT .PYR(0)) GOTO 170
19499 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19500 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19501 ENDIF
19502
19503C...Multiple interactions (variable impact parameter) : reject with
19504C...probability exp(-overlap*cross-section above pT/normalization).
19505C...Does not apply to low-b region, where "Sudakov" already included.
19506 VINT(150)=1D0
19507 IF(MINT(39).NE.1) THEN
19508 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19509 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19510 DO 180 IBIN=IRBIN+1,20
19511 RNCOR=RNCOR+NMUL(IBIN)
19512 SIGCOR=SIGCOR+SIGM(IBIN)
19513 180 CONTINUE
19514 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19515 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19516 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19517 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19518 ENDIF
19519 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19520 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19521 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19522 IF(VINT(150).LT.PYR(0)) GOTO 150
19523 VINT(150)=1D0
19524 ENDIF
19525
19526C...Generate additional multiple semihard interactions.
19527 ELSEIF(MMUL.EQ.6) THEN
19528 ISUBSV=MINT(1)
19529 VINT(145)=VNT145
19530 VINT(146)=VNT146
19531 VINT(147)=VNT147
19532 DO 190 J=11,80
19533 VINTSV(J)=VINT(J)
19534 190 CONTINUE
19535 ISUB=96
19536 MINT(1)=96
19537 VINT(151)=0D0
19538 VINT(152)=0D0
19539
19540C...Reconstruct strings in hard scattering.
19541 NMAX=MINT(84)+4
19542 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
19543 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
19544 NSTR=0
19545 DO 210 I=MINT(84)+1,NMAX
19546 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
19547 IF(KCS.EQ.0) GOTO 210
19548 DO 200 J=1,4
19549 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
19550 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
19551 IF(J.LE.2) THEN
19552 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
19553 ELSE
19554 IST=MOD(K(I,J+1),MSTU(5))
19555 ENDIF
19556 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
19557 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
19558 NSTR=NSTR+1
19559 IF(J.EQ.1.OR.J.EQ.4) THEN
19560 KSTR(NSTR,1)=I
19561 KSTR(NSTR,2)=IST
19562 ELSE
19563 KSTR(NSTR,1)=IST
19564 KSTR(NSTR,2)=I
19565 ENDIF
19566 200 CONTINUE
19567 210 CONTINUE
19568
19569C...Set up starting values for iteration in xT2.
19570 XT2=4D0*VINT(62)/VINT(2)
19571 IF(MSTP(82).LE.1) THEN
19572 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19573 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19574 & VINT(317)/(VINT(318)*VINT(320))
19575 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19576 ELSE
19577 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19578 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19579 ENDIF
19580 VINT(63)=0D0
19581 VINT(64)=0D0
19582 VINT(143)=1D0-VINT(141)
19583 VINT(144)=1D0-VINT(142)
19584
19585C...Iterate downwards in xT2.
19586 220 IF(MSTP(82).LE.1) THEN
19587 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19588 IF(XT2.LT.VINT(149)) GOTO 270
19589 ELSE
19590 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
19591 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19592 & LOG(PYR(0)))-VINT(149)
19593 IF(XT2.LE.0D0) GOTO 270
19594 XT2=MAX(0.01D0*VINT(149),XT2)
19595 ENDIF
19596 VINT(25)=XT2
19597
19598C...Choose tau and y*. Calculate cos(theta-hat).
19599 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19600 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19601 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19602 ELSE
19603 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19604 ENDIF
19605 VINT(21)=TAU
19606 CALL PYKLIM(2)
19607 RYST=PYR(0)
19608 MYST=1
19609 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19610 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19611 CALL PYKMAP(2,MYST,PYR(0))
19612 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19613
19614C...Check that x not used up. Accept or reject kinematical variables.
19615 X1M=SQRT(TAU)*EXP(VINT(22))
19616 X2M=SQRT(TAU)*EXP(-VINT(22))
19617 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19618 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19619 CALL PYSIGH(NCHN,SIGS)
19620 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19621 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19622
19623C...Reset K, P and V vectors. Select some variables.
19624 DO 240 I=N+1,N+2
19625 DO 230 J=1,5
19626 K(I,J)=0
19627 P(I,J)=0D0
19628 V(I,J)=0D0
19629 230 CONTINUE
19630 240 CONTINUE
19631 RFLAV=PYR(0)
19632 PT=0.5D0*VINT(1)*SQRT(XT2)
19633 PHI=PARU(2)*PYR(0)
19634 CTH=VINT(23)
19635
19636C...Add first parton to event record.
19637 K(N+1,1)=3
19638 K(N+1,2)=21
19639 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19640 & 1+INT((2D0+PARJ(2))*PYR(0))
19641 P(N+1,1)=PT*COS(PHI)
19642 P(N+1,2)=PT*SIN(PHI)
19643 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19644 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19645 P(N+1,5)=0D0
19646
19647C...Add second parton to event record.
19648 K(N+2,1)=3
19649 K(N+2,2)=21
19650 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19651 P(N+2,1)=-P(N+1,1)
19652 P(N+2,2)=-P(N+1,2)
19653 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19654 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19655 P(N+2,5)=0D0
19656
19657 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19658C....Choose relevant string pieces to place gluons on.
19659 DO 260 I=N+1,N+2
19660 DMIN=1D8
19661 DO 250 ISTR=1,NSTR
19662 I1=KSTR(ISTR,1)
19663 I2=KSTR(ISTR,2)
19664 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19665 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19666 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19667 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19668 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19669 DMIN=DIST
19670 IST1=I1
19671 IST2=I2
19672 ISTM=ISTR
19673 ENDIF
19674 250 CONTINUE
19675
19676C....Colour flow adjustments, new string pieces.
19677 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19678 & MOD(K(IST1,4),MSTU(5))
19679 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19680 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19681 K(I,5)=MSTU(5)*IST1
19682 K(I,4)=MSTU(5)*IST2
19683 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19684 & MOD(K(IST2,5),MSTU(5))
19685 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19686 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19687 KSTR(ISTM,2)=I
19688 KSTR(NSTR+1,1)=I
19689 KSTR(NSTR+1,2)=IST2
19690 NSTR=NSTR+1
19691 260 CONTINUE
19692
19693C...String drawing and colour flow for gluon loop.
19694 ELSEIF(K(N+1,2).EQ.21) THEN
19695 K(N+1,4)=MSTU(5)*(N+2)
19696 K(N+1,5)=MSTU(5)*(N+2)
19697 K(N+2,4)=MSTU(5)*(N+1)
19698 K(N+2,5)=MSTU(5)*(N+1)
19699 KSTR(NSTR+1,1)=N+1
19700 KSTR(NSTR+1,2)=N+2
19701 KSTR(NSTR+2,1)=N+2
19702 KSTR(NSTR+2,2)=N+1
19703 NSTR=NSTR+2
19704
19705C...String drawing and colour flow for qqbar pair.
19706 ELSE
19707 K(N+1,4)=MSTU(5)*(N+2)
19708 K(N+2,5)=MSTU(5)*(N+1)
19709 KSTR(NSTR+1,1)=N+1
19710 KSTR(NSTR+1,2)=N+2
19711 NSTR=NSTR+1
19712 ENDIF
19713
19714C...Global statistics.
19715 MINT(351)=MINT(351)+1
19716 VINT(351)=VINT(351)+PT
19717 IF (MINT(351).EQ.1) VINT(356)=PT
19718
19719C...Update remaining energy; iterate.
19720 N=N+2
19721 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19722 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19723 MINT(51)=1
19724 RETURN
19725 ENDIF
19726 MINT(31)=MINT(31)+1
19727 VINT(151)=VINT(151)+VINT(41)
19728 VINT(152)=VINT(152)+VINT(42)
19729 VINT(143)=VINT(143)-VINT(41)
19730 VINT(144)=VINT(144)-VINT(42)
19731C...Allow FSR for UE (always handle with old showers)
19732 IF(MSTP(152).EQ.1) THEN
19733 M41SAV=MSTJ(41)
19734 IF (MSTJ(41).EQ.10) MSTJ(41)=2
19735 MSTJ(41)=MOD(MSTJ(41),10)
19736 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19737 MSTJ(41)=M41SAV
19738 ENDIF
19739 IF(MINT(31).LT.240) GOTO 220
19740 270 CONTINUE
19741 MINT(1)=ISUBSV
19742 DO 280 J=11,80
19743 VINT(J)=VINTSV(J)
19744 280 CONTINUE
19745 ENDIF
19746
19747C...Format statements for printout.
19748 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19749 &'actions for MSTP(82) =',I2,' ******')
19750 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19751 &D9.2,' mb: rejected')
19752 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19753 &D9.2,' mb: accepted')
19754
19755 RETURN
19756 END
19757
19758C*********************************************************************
19759
19760C...PYREMN
19761C...Adds on target remnants (one or two from each side) and
19762C...includes primordial kT for hadron beams.
19763
19764 SUBROUTINE PYREMN(IPU1,IPU2)
19765
19766C...Double precision and integer declarations.
19767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19768 IMPLICIT INTEGER(I-N)
19769 INTEGER PYK,PYCHGE,PYCOMP
19770C...Commonblocks.
19771 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19774 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19775 COMMON/PYINT1/MINT(400),VINT(400)
19776 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19777C...Local arrays.
19778 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19779 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19780
19781C...Find event type and remaining energy.
19782 ISUB=MINT(1)
19783 NS=N
19784 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19785 VINT(143)=1D0-VINT(141)
19786 VINT(144)=1D0-VINT(142)
19787 ENDIF
19788
19789C...Define initial partons.
19790 NTRY=0
19791 100 NTRY=NTRY+1
19792 DO 130 JT=1,2
19793 I=MINT(83)+JT+2
19794 IF(JT.EQ.1) IPU=IPU1
19795 IF(JT.EQ.2) IPU=IPU2
19796 K(I,1)=21
19797 K(I,2)=K(IPU,2)
19798 K(I,3)=I-2
19799 PMS(JT)=0D0
19800 VINT(156+JT)=0D0
19801 VINT(158+JT)=0D0
19802 IF(MINT(47).EQ.1) THEN
19803 DO 110 J=1,5
19804 P(I,J)=P(I-2,J)
19805 110 CONTINUE
19806 ELSEIF(ISUB.EQ.95) THEN
19807 K(I,2)=21
19808 ELSE
19809 P(I,5)=P(IPU,5)
19810
19811C...No primordial kT, or chosen according to truncated Gaussian or
19812C...exponential, or (for photon) predetermined or power law.
19813 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19814 IF(MSTP(91).LE.0) THEN
19815 PT=0D0
19816 ELSEIF(MSTP(91).EQ.1) THEN
19817 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19818 ELSE
19819 RPT1=PYR(0)
19820 RPT2=PYR(0)
19821 PT=-PARP(92)*LOG(RPT1*RPT2)
19822 ENDIF
19823 IF(PT.GT.PARP(93)) GOTO 120
19824 ELSEIF(MINT(106+JT).EQ.3) THEN
19825 PTA=SQRT(VINT(282+JT))
19826 PTB=0D0
19827 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19828 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19829 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19830 RPT1=PYR(0)
19831 RPT2=PYR(0)
19832 PTB=-PARP(99)*LOG(RPT1*RPT2)
19833 ENDIF
19834 IF(PTB.GT.PARP(100)) GOTO 120
19835 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19836 PT=PT*0.8D0**MINT(57)
19837 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19838 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19839 IF(MSTP(93).LE.0) THEN
19840 PT=0D0
19841 ELSEIF(MSTP(93).EQ.1) THEN
19842 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19843 ELSEIF(MSTP(93).EQ.2) THEN
19844 RPT1=PYR(0)
19845 RPT2=PYR(0)
19846 PT=-PARP(99)*LOG(RPT1*RPT2)
19847 ELSEIF(MSTP(93).EQ.3) THEN
19848 HA=PARP(99)**2
19849 HB=PARP(100)**2
19850 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19851 ELSE
19852 HA=PARP(99)**2
19853 HB=PARP(100)**2
19854 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19855 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19856 ENDIF
19857 IF(PT.GT.PARP(100)) GOTO 120
19858 ELSE
19859 PT=0D0
19860 ENDIF
19861 VINT(156+JT)=PT
19862 PHI=PARU(2)*PYR(0)
19863 P(I,1)=PT*COS(PHI)
19864 P(I,2)=PT*SIN(PHI)
19865 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19866 ENDIF
19867 130 CONTINUE
19868 IF(MINT(47).EQ.1) RETURN
19869
19870C...Kinematics construction for initial partons.
19871 I1=MINT(83)+3
19872 I2=MINT(83)+4
19873 IF(ISUB.EQ.95) THEN
19874 SHS=0D0
19875 SHR=0D0
19876 ELSE
19877 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19878 & (P(I1,2)+P(I2,2))**2
19879 SHR=SQRT(MAX(0D0,SHS))
19880 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19881 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19882 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19883 P(I2,4)=SHR-P(I1,4)
19884 P(I2,3)=-P(I1,3)
19885
19886C...Transform partons to overall CM-frame.
19887 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19888 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19889 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19890 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19891 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19892 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19893 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19894 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19895 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19896 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19897 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19898 ENDIF
19899
19900C...Optionally fix up x and Q2 definitions for leptoproduction.
19901 IDISXQ=0
19902 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19903 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19904 IF(IDISXQ.EQ.1) THEN
19905
19906C...Find where incoming and outgoing leptons/partons are sitting.
19907 LESD=1
19908 IF(MINT(42).EQ.1) LESD=2
19909 LPIN=MINT(83)+3-LESD
19910 LEIN=MINT(84)+LESD
19911 LQIN=MINT(84)+3-LESD
19912 LEOUT=MINT(84)+2+LESD
19913 LQOUT=MINT(84)+5-LESD
19914 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19915 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19916 LSCMS=0
19917 DO 140 I=MINT(84)+5,N
19918 IF(K(I,2).EQ.94) THEN
19919 LSCMS=I
19920 LEOUT=I+LESD
19921 LQOUT=I+3-LESD
19922 ENDIF
19923 140 CONTINUE
19924 LQBG=IPU1
19925 IF(LESD.EQ.1) LQBG=IPU2
19926
19927C...Calculate actual and wanted momentum transfer.
19928 XNOM=VINT(43-LESD)
19929 Q2NOM=-VINT(45)
19930 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19931 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19932 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19933 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19934 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19935 P(N+1,1)=FAC*P(LEOUT,1)
19936 P(N+1,2)=FAC*P(LEOUT,2)
19937 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19938 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19939 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19940 & P(N+1,3)**2)
19941 DO 150 J=1,4
19942 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19943 QNEW(J)=P(LEIN,J)-P(N+1,J)
19944 150 CONTINUE
19945
19946C...Boost outgoing electron and daughters.
19947 IF(LSCMS.EQ.0) THEN
19948 DO 160 J=1,4
19949 P(LEOUT,J)=P(N+1,J)
19950 160 CONTINUE
19951 ELSE
19952 DO 170 J=1,3
19953 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19954 170 CONTINUE
19955 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19956 DO 180 J=1,3
19957 DBE(J)=PINV*P(N+2,J)
19958 180 CONTINUE
19959 DO 200 I=LSCMS+1,N
19960 IORIG=I
19961 190 IORIG=K(IORIG,3)
19962 IF(IORIG.GT.LEOUT) GOTO 190
19963 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19964 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19965 200 CONTINUE
19966 ENDIF
19967
19968C...Copy shower initiator and all outgoing partons.
19969 NCOP=N+1
19970 K(NCOP,3)=LQBG
19971 DO 210 J=1,5
19972 P(NCOP,J)=P(LQBG,J)
19973 210 CONTINUE
19974 DO 240 I=MINT(84)+1,N
19975 ICOP=0
19976 IF(K(I,1).GT.10) GOTO 240
19977 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19978 ICOP=I
19979 ELSE
19980 IORIG=I
19981 220 IORIG=K(IORIG,3)
19982 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19983 ICOP=IORIG
19984 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19985 GOTO 220
19986 ENDIF
19987 ENDIF
19988 IF(ICOP.NE.0) THEN
19989 NCOP=NCOP+1
19990 K(NCOP,3)=I
19991 DO 230 J=1,5
19992 P(NCOP,J)=P(I,J)
19993 230 CONTINUE
19994 ENDIF
19995 240 CONTINUE
19996
19997C...Calculate relative rescaling factors.
19998 SLC=3-2*LESD
19999 PLCSUM=0D0
20000 DO 250 I=N+2,NCOP
20001 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20002 250 CONTINUE
20003 DO 260 I=N+2,NCOP
20004 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20005 260 CONTINUE
20006
20007C...Transfer extra three-momentum of current.
20008 DO 280 I=N+2,NCOP
20009 DO 270 J=1,3
20010 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20011 270 CONTINUE
20012 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20013 280 CONTINUE
20014
20015C...Iterate change of initiator momentum to get energy right.
20016 ITER=0
20017 290 ITER=ITER+1
20018 PEEX=-P(N+1,4)-QNEW(4)
20019 PEMV=-P(N+1,3)/P(N+1,4)
20020 DO 300 I=N+2,NCOP
20021 PEEX=PEEX+P(I,4)
20022 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20023 300 CONTINUE
20024 IF(ABS(PEMV).LT.1D-10) THEN
20025 MINT(51)=1
20026 MINT(57)=MINT(57)+1
20027 RETURN
20028 ENDIF
20029 PZCH=-PEEX/PEMV
20030 P(N+1,3)=P(N+1,3)+PZCH
20031 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)
20032 DO 310 I=N+2,NCOP
20033 P(I,3)=P(I,3)+V(I,1)*PZCH
20034 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20035 310 CONTINUE
20036 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20037
20038C...Modify momenta in event record.
20039 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20040 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20041 IF(ABS(HBE).GE.1D0) THEN
20042 MINT(51)=1
20043 MINT(57)=MINT(57)+1
20044 RETURN
20045 ENDIF
20046 I=MINT(83)+5-LESD
20047 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20048 DO 330 I=N+1,NCOP
20049 ICOP=K(I,3)
20050 DO 320 J=1,4
20051 P(ICOP,J)=P(I,J)
20052 320 CONTINUE
20053 330 CONTINUE
20054 ENDIF
20055
20056C...Check minimum invariant mass of remnant system(s).
20057 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20058 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20059 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20060 PMIN(0)=SQRT(PMS(0))
20061 DO 340 JT=1,2
20062 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20063 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20064 PMIN(JT)=0D0
20065 IF(MINT(44+JT).EQ.1) GOTO 340
20066 MINT(105)=MINT(102+JT)
20067 MINT(109)=MINT(106+JT)
20068 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20069 IF(MINT(51).NE.0) THEN
20070 MINT(57)=MINT(57)+1
20071 RETURN
20072 ENDIF
20073 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20074 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20075 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20076 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20077 & P(MINT(83)+JT+2,2)**2)
20078 340 CONTINUE
20079 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20080 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20081 &PSYS(2,4))) THEN
20082 MINT(51)=1
20083 MINT(57)=MINT(57)+1
20084 RETURN
20085 ENDIF
20086
20087C...Loop over two remnants; skip if none there.
20088 I=NS
20089 DO 410 JT=1,2
20090 ISN(JT)=0
20091 IF(MINT(44+JT).EQ.1) GOTO 410
20092 IF(JT.EQ.1) IPU=IPU1
20093 IF(JT.EQ.2) IPU=IPU2
20094
20095C...Store first remnant parton.
20096 I=I+1
20097 IS(JT)=I
20098 ISN(JT)=1
20099 DO 350 J=1,5
20100 K(I,J)=0
20101 P(I,J)=0D0
20102 V(I,J)=0D0
20103 350 CONTINUE
20104 K(I,1)=1
20105 K(I,2)=KFLSP(JT)
20106 K(I,3)=MINT(83)+JT
20107 P(I,5)=PYMASS(K(I,2))
20108
20109C...First parton colour connections and kinematics.
20110 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20111 IF(KCOL.EQ.2) THEN
20112 K(I,1)=3
20113 K(I,4)=MSTU(5)*IPU+IPU
20114 K(I,5)=MSTU(5)*IPU+IPU
20115 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20116 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20117 ELSEIF(KCOL.NE.0) THEN
20118 K(I,1)=3
20119 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20120 K(I,KFLS+3)=IPU
20121 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20122 ENDIF
20123 IF(KFLCH(JT).EQ.0) THEN
20124 P(I,1)=-P(MINT(83)+JT+2,1)
20125 P(I,2)=-P(MINT(83)+JT+2,2)
20126 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20127 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20128 P(I,3)=PSYS(JT,3)
20129 P(I,4)=PSYS(JT,4)
20130
20131C...When extra remnant parton or hadron: store extra remnant.
20132 ELSE
20133 I=I+1
20134 ISN(JT)=2
20135 DO 360 J=1,5
20136 K(I,J)=0
20137 P(I,J)=0D0
20138 V(I,J)=0D0
20139 360 CONTINUE
20140 K(I,1)=1
20141 K(I,2)=KFLCH(JT)
20142 K(I,3)=MINT(83)+JT
20143 P(I,5)=PYMASS(K(I,2))
20144
20145C...Find parton colour connections of extra remnant.
20146 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20147 IF(KCOL.EQ.2) THEN
20148 K(I,1)=3
20149 K(I,4)=MSTU(5)*IPU+IPU
20150 K(I,5)=MSTU(5)*IPU+IPU
20151 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20152 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20153 ELSEIF(KCOL.NE.0) THEN
20154 K(I,1)=3
20155 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20156 K(I,KFLS+3)=IPU
20157 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20158 ENDIF
20159
20160C...Relative transverse momentum when two remnants.
20161 LOOP=0
20162 370 LOOP=LOOP+1
20163 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20164 IF(IABS(MINT(10+JT)).LT.20) THEN
20165 P(I-1,1)=0D0
20166 P(I-1,2)=0D0
20167 ELSE
20168 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20169 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20170 ENDIF
20171 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20172 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20173 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20174 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20175
20176C...Meson or baryon; photon as meson. For splitup below.
20177 IMB=1
20178 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20179
20180C***Relative distribution for electron into two electrons. Temporary!
20181 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20182 & THEN
20183 CHI(JT)=PYR(0)
20184
20185C...Relative distribution of electron energy into electron plus parton.
20186 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20187 XHRD=VINT(140+JT)
20188 XE=VINT(154+JT)
20189 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20190
20191C...Relative distribution of energy for particle into two jets.
20192 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20193 CHIK=PARP(92+2*IMB)
20194 IF(MSTP(92).LE.1) THEN
20195 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20196 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20197 ELSEIF(MSTP(92).EQ.2) THEN
20198 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20199 ELSEIF(MSTP(92).EQ.3) THEN
20200 CUT=2D0*0.3D0/VINT(1)
20201 380 CHI(JT)=PYR(0)**2
20202 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20203 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20204 ELSEIF(MSTP(92).EQ.4) THEN
20205 CUT=2D0*0.3D0/VINT(1)
20206 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20207 390 CHIR=CUT*CUTR**PYR(0)
20208 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20209 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20210 ELSE
20211 CUT=2D0*0.3D0/VINT(1)
20212 CUTA=CUT**(1D0-PARP(98))
20213 CUTB=(1D0+CUT)**(1D0-PARP(98))
20214 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20215 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20216 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20217 ENDIF
20218
20219C...Relative distribution of energy for particle into jet plus particle.
20220 ELSE
20221 IF(MSTP(94).LE.1) THEN
20222 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20223 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20224 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20225 ELSEIF(MSTP(94).EQ.2) THEN
20226 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20227 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20228 ELSEIF(MSTP(94).EQ.3) THEN
20229 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20230 CHI(JT)=ZZ
20231 ELSE
20232 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20233 CHI(JT)=ZZ
20234 ENDIF
20235 ENDIF
20236
20237C...Construct total transverse mass; reject if too large.
20238 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20239 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20240 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20241 IF(LOOP.LT.100) THEN
20242 GOTO 370
20243 ELSE
20244 MINT(51)=1
20245 MINT(57)=MINT(57)+1
20246 RETURN
20247 ENDIF
20248 ENDIF
20249 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20250 VINT(158+JT)=CHI(JT)
20251
20252C...Subdivide longitudinal momentum according to value selected above.
20253 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20254 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20255 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20256 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20257 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20258 ENDIF
20259 410 CONTINUE
20260 N=I
20261
20262C...Check if longitudinal boosts needed - if so pick two systems.
20263 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20264 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20265 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20266 IF(ISN(1).EQ.0) THEN
20267 IR=0
20268 IL=2
20269 ELSEIF(ISN(2).EQ.0) THEN
20270 IR=1
20271 IL=0
20272 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20273 IR=1
20274 IL=2
20275 ELSEIF(VINT(143).GT.0.2D0) THEN
20276 IR=1
20277 IL=0
20278 ELSEIF(VINT(144).GT.0.2D0) THEN
20279 IR=0
20280 IL=2
20281 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20282 IR=1
20283 IL=0
20284 ELSE
20285 IR=0
20286 IL=2
20287 ENDIF
20288 IG=3-IR-IL
20289
20290C...E+-pL wanted for system to be modified.
20291 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20292 PPB=VINT(1)
20293 PNB=VINT(1)
20294 ELSE
20295 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20296 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20297 ENDIF
20298
20299C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20300 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20301 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20302 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20303 DO 420 J=1,4
20304 PSYS(0,J)=0D0
20305 420 CONTINUE
20306 DO 450 I=MINT(84)+1,NS
20307 IF(K(I,1).GT.10) GOTO 450
20308 INCL=0
20309 IORIG=I
20310 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20311 IORIG=K(IORIG,3)
20312 IF(IORIG.GT.LPIN) GOTO 430
20313 IF(INCL.EQ.0) GOTO 450
20314 DO 440 J=1,4
20315 PSYS(0,J)=PSYS(0,J)+P(I,J)
20316 440 CONTINUE
20317 450 CONTINUE
20318 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20319 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20320 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20321 ENDIF
20322
20323C...Construct longitudinal boosts.
20324 DPMTB=PPB*PNB
20325 DPMTR=PMS(IR)
20326 DPMTL=PMS(IL)
20327 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20328 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20329 MINT(51)=1
20330 MINT(57)=MINT(57)+1
20331 RETURN
20332 ENDIF
20333 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20334 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20335 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20336 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20337 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20338 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20339 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20340
20341C...Perform longitudinal boosts.
20342 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20343 P(IS(1),3)=0D0
20344 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20345 ELSEIF(IR.EQ.1) THEN
20346 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20347 ELSEIF(IDISXQ.EQ.1) THEN
20348 DO 470 I=I1,NS
20349 INCL=0
20350 IORIG=I
20351 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20352 IORIG=K(IORIG,3)
20353 IF(IORIG.GT.LPIN) GOTO 460
20354 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20355 470 CONTINUE
20356 ELSE
20357 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20358 ENDIF
20359 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20360 P(IS(2),3)=0D0
20361 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20362 ELSEIF(IL.EQ.2) THEN
20363 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20364 ELSEIF(IDISXQ.EQ.1) THEN
20365 DO 490 I=I1,NS
20366 INCL=0
20367 IORIG=I
20368 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20369 IORIG=K(IORIG,3)
20370 IF(IORIG.GT.LPIN) GOTO 480
20371 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20372 490 CONTINUE
20373 ELSE
20374 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20375 ENDIF
20376
20377C...Final check that energy-momentum conservation worked.
20378 PESUM=0D0
20379 PZSUM=0D0
20380 DO 500 I=MINT(84)+1,N
20381 IF(K(I,1).GT.10) GOTO 500
20382 PESUM=PESUM+P(I,4)
20383 PZSUM=PZSUM+P(I,3)
20384 500 CONTINUE
20385 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20386 IF(PDEV.GT.1D-4*VINT(1)) THEN
20387 MINT(51)=1
20388 MINT(57)=MINT(57)+1
20389 RETURN
20390 ENDIF
20391
20392C...Calculate rotation and boost from overall CM frame to
20393C...hadronic CM frame in leptoproduction.
20394 MINT(91)=0
20395 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20396 MINT(91)=1
20397 LESD=1
20398 IF(MINT(42).EQ.1) LESD=2
20399 LPIN=MINT(83)+3-LESD
20400
20401C...Sum upp momenta of everything not lepton or photon to define boost.
20402 DO 510 J=1,4
20403 PSUM(J)=0D0
20404 510 CONTINUE
20405 DO 530 I=1,N
20406 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20407 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20408 IF(K(I,2).EQ.22) GOTO 530
20409 DO 520 J=1,4
20410 PSUM(J)=PSUM(J)+P(I,J)
20411 520 CONTINUE
20412 530 CONTINUE
20413 VINT(223)=-PSUM(1)/PSUM(4)
20414 VINT(224)=-PSUM(2)/PSUM(4)
20415 VINT(225)=-PSUM(3)/PSUM(4)
20416
20417C...Boost incoming hadron to hadronic CM frame to determine rotations.
20418 K(N+1,1)=1
20419 DO 540 J=1,5
20420 P(N+1,J)=P(LPIN,J)
20421 V(N+1,J)=V(LPIN,J)
20422 540 CONTINUE
20423 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20424 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20425 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20426 IF(LESD.EQ.2) THEN
20427 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20428 ELSE
20429 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20430 ENDIF
20431 ENDIF
20432
20433 RETURN
20434 END
20435
20436C*********************************************************************
20437
20438C...PYMIGN
20439C...Initializes treatment of new multiple interactions scenario,
20440C...selects kinematics of hardest interaction if low-pT physics
20441C...included in run, and generates all non-hardest interactions.
20442
20443 SUBROUTINE PYMIGN(MMUL)
20444
20445C...Double precision and integer declarations.
20446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20447 IMPLICIT INTEGER(I-N)
20448 INTEGER PYK,PYCHGE,PYCOMP
20449 EXTERNAL PYALPS
20450 DOUBLE PRECISION PYALPS
20451C...Commonblocks.
20452 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20453 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20454 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20455 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20456 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20457 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20458 COMMON/PYINT1/MINT(400),VINT(400)
20459 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20460 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20461 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20462 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20463 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20464 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20465 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20466 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20467 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20468C...Local arrays and saved variables.
20469 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20470 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20471 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20472 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20473 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20474
20475C...Initialization of multiple interaction treatment.
20476 IF(MMUL.EQ.1) THEN
20477 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20478 ISUB=96
20479 MINT(1)=96
20480 VINT(63)=0D0
20481 VINT(64)=0D0
20482 VINT(143)=1D0
20483 VINT(144)=1D0
20484
20485C...Loop over phase space points: xT2 choice in 20 bins.
20486 100 SIGSUM=0D0
20487 DO 120 IXT2=1,20
20488 NMUL(IXT2)=MSTP(83)
20489 SIGM(IXT2)=0D0
20490 DO 110 ITRY=1,MSTP(83)
20491 RSCA=0.05D0*((21-IXT2)-PYR(0))
20492 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20493 XT2=MAX(0.01D0*VINT(149),XT2)
20494 VINT(25)=XT2
20495
20496C...Choose tau and y*. Calculate cos(theta-hat).
20497 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20498 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20499 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20500 ELSE
20501 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20502 ENDIF
20503 VINT(21)=TAU
20504 CALL PYKLIM(2)
20505 RYST=PYR(0)
20506 MYST=1
20507 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20508 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20509 CALL PYKMAP(2,MYST,PYR(0))
20510 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20511
20512C...Calculate differential cross-section.
20513 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20514 CALL PYSIGH(NCHN,SIGS)
20515 SIGM(IXT2)=SIGM(IXT2)+SIGS
20516 110 CONTINUE
20517 SIGSUM=SIGSUM+SIGM(IXT2)
20518 120 CONTINUE
20519 SIGSUM=SIGSUM/(20D0*MSTP(83))
20520
20521C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20522 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
20523 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
20524 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
20525 PARP(82)=0.9D0*PARP(82)
20526 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
20527 & VINT(2)
20528 GOTO 100
20529 ENDIF
20530 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
20531 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
20532
20533C...Start iteration to find k factor.
20534 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
20535 P83A=(1D0-PARP(83))**2
20536 P83B=2D0*PARP(83)*(1D0-PARP(83))
20537 P83C=PARP(83)**2
20538 CQ2I=1D0/PARP(84)**2
20539 CQ2R=2D0/(1D0+PARP(84)**2)
20540 SO=0.5D0
20541 XI=0D0
20542 YI=0D0
20543 XF=0D0
20544 YF=0D0
20545 XK=0.5D0
20546 IIT=0
20547 130 IF(IIT.EQ.0) THEN
20548 XK=2D0*XK
20549 ELSEIF(IIT.EQ.1) THEN
20550 XK=0.5D0*XK
20551 ELSE
20552 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
20553 ENDIF
20554
20555C...Evaluate overlap integrals. Find where to divide the b range.
20556 IF(MSTP(82).EQ.2) THEN
20557 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
20558 SOP=SP/PARU(1)
20559 ELSE
20560 IF(MSTP(82).EQ.3) THEN
20561 DELTAB=0.02D0
20562 ELSEIF(MSTP(82).EQ.4) THEN
20563 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
20564 ELSE
20565 POWIP=MAX(0.4D0,PARP(83))
20566 RPWIP=2D0/POWIP-1D0
20567 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
20568 SO=0D0
20569 ENDIF
20570 SP=0D0
20571 SOP=0D0
20572 BSP=0D0
20573 SOHIGH=0D0
20574 IBDIV=0
20575 B=-0.5D0*DELTAB
20576 140 B=B+DELTAB
20577 IF(MSTP(82).EQ.3) THEN
20578 OV=EXP(-B**2)/PARU(2)
20579 ELSEIF(MSTP(82).EQ.4) THEN
20580 OV=(P83A*EXP(-MIN(50D0,B**2))+
20581 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20582 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20583 ELSE
20584 OV=EXP(-B**POWIP)/PARU(2)
20585 SO=SO+PARU(2)*B*DELTAB*OV
20586 ENDIF
20587 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
20588 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
20589 SP=SP+PARU(2)*B*DELTAB*PACC
20590 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
20591 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
20592 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
20593 IBDIV=1
20594 BDIV=B+0.5D0*DELTAB
20595 ENDIF
20596 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
20597 ENDIF
20598 YK=PARU(1)*XK*SO/SP
20599
20600C...Continue iteration until convergence.
20601 IF(YK.LT.YKE) THEN
20602 XI=XK
20603 YI=YK
20604 IF(IIT.EQ.1) IIT=2
20605 ELSE
20606 XF=XK
20607 YF=YK
20608 IF(IIT.EQ.0) IIT=1
20609 ENDIF
20610 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
20611
20612C...Store some results for subsequent use.
20613 BAVG=BSP/SP
20614 VINT(145)=SIGSUM
20615 VINT(146)=SOP/SO
20616 VINT(147)=SOP/SP
20617 VNT145=VINT(145)
20618 VNT146=VINT(146)
20619 VNT147=VINT(147)
20620C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20621 PIK=(VNT146/VNT147)*YKE
20622
20623C...Find relative weight for low and high impact parameter..
20624 PLOWB=PARU(1)*BDIV**2
20625 IF(MSTP(82).EQ.3) THEN
20626 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20627 ELSEIF(MSTP(82).EQ.4) THEN
20628 S4A=P83A*EXP(-BDIV**2)
20629 S4B=P83B*EXP(-BDIV**2*CQ2R)
20630 S4C=P83C*EXP(-BDIV**2*CQ2I)
20631 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20632 ELSEIF(PARP(83).GE.1.999D0) THEN
20633 PHIGHB=PIK*SOHIGH
20634 B2RPDV=BDIV**POWIP
20635 ELSE
20636 PHIGHB=PIK*SOHIGH
20637 B2RPDV=BDIV**POWIP
20638 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20639 ENDIF
20640 PALLB=PLOWB+PHIGHB
20641
20642C...Initialize iteration in xT2 for hardest interaction.
20643 ELSEIF(MMUL.EQ.2) THEN
20644 VINT(145)=VNT145
20645 VINT(146)=VNT146
20646 VINT(147)=VNT147
20647 IF(MSTP(82).LE.0) THEN
20648 ELSEIF(MSTP(82).EQ.1) THEN
20649 XT2=1D0
20650 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20651 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20652 & VINT(317)/(VINT(318)*VINT(320))
20653 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20654 ELSEIF(MSTP(82).EQ.2) THEN
20655 XT2=1D0
20656 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20657 & VINT(149)*(1D0+VINT(149))
20658 ELSE
20659 XC2=4D0*CKIN(3)**2/VINT(2)
20660 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20661 ENDIF
20662
20663C...Select impact parameter for hardest interaction.
20664 IF(MSTP(82).LE.2) RETURN
20665 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20666C...Treatment in low b region.
20667 MINT(39)=1
20668 B=BDIV*SQRT(PYR(0))
20669 IF(MSTP(82).EQ.3) THEN
20670 OV=EXP(-B**2)/PARU(2)
20671 ELSEIF(MSTP(82).EQ.4) THEN
20672 OV=(P83A*EXP(-MIN(50D0,B**2))+
20673 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20674 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20675 ELSE
20676 OV=EXP(-B**POWIP)/PARU(2)
20677 ENDIF
20678 VINT(148)=OV/VNT147
20679 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20680 XT2=1D0
20681 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20682 & VINT(149)*(1D0+VINT(149))
20683 ELSE
20684C...Treatment in high b region.
20685 MINT(39)=2
20686 IF(MSTP(82).EQ.3) THEN
20687 B=SQRT(BDIV**2-LOG(PYR(0)))
20688 OV=EXP(-B**2)/PARU(2)
20689 ELSEIF(MSTP(82).EQ.4) THEN
20690 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20691 IF(S4RNDM.LT.S4A) THEN
20692 B=SQRT(BDIV**2-LOG(PYR(0)))
20693 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20694 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20695 ELSE
20696 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20697 ENDIF
20698 OV=(P83A*EXP(-MIN(50D0,B**2))+
20699 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20700 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20701 ELSEIF(PARP(83).GE.1.999D0) THEN
20702 144 B2RPW=B2RPDV-LOG(PYR(0))
20703 ACCIP=(B2RPW/B2RPDV)**RPWIP
20704 IF(ACCIP.LT.PYR(0)) GOTO 144
20705 OV=EXP(-B2RPW)/PARU(2)
20706 B=B2RPW**(1D0/POWIP)
20707 ELSE
20708 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20709 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20710 IF(ACCIP.LT.PYR(0)) GOTO 146
20711 OV=EXP(-B2RPW)/PARU(2)
20712 B=B2RPW**(1D0/POWIP)
20713 ENDIF
20714 VINT(148)=OV/VNT147
20715 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20716 ENDIF
20717 IF(PACC.LT.PYR(0)) GOTO 142
20718 VINT(139)=B/BAVG
20719
20720 ELSEIF(MMUL.EQ.3) THEN
20721C...Low-pT or multiple interactions (first semihard interaction):
20722C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20723C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20724 ISUB=MINT(1)
20725 VINT(145)=VNT145
20726 VINT(146)=VNT146
20727 VINT(147)=VNT147
20728 IF(MSTP(82).LE.0) THEN
20729 XT2=0D0
20730 ELSEIF(MSTP(82).EQ.1) THEN
20731 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20732C...Use with "Sudakov" for low b values when impact parameter dependence.
20733 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20734 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20735 & VINT(149)))).GT.PYR(0)) XT2=1D0
20736 IF(XT2.GE.1D0) THEN
20737 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20738 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20739 & VINT(149)
20740 ELSE
20741 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20742 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20743 & VINT(149)
20744 ENDIF
20745 XT2=MAX(0.01D0*VINT(149),XT2)
20746C...Use without "Sudakov" for high b values when impact parameter dep.
20747 ELSE
20748 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20749 & PYR(0)*(1D0-XC2))-VINT(149)
20750 XT2=MAX(0.01D0*VINT(149),XT2)
20751 ENDIF
20752 VINT(25)=XT2
20753
20754C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20755 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20756 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20757 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20758 ISUB=95
20759 MINT(1)=ISUB
20760 VINT(21)=1D-12*VINT(149)
20761 VINT(22)=0D0
20762 VINT(23)=0D0
20763 VINT(25)=1D-12*VINT(149)
20764
20765 ELSE
20766C...Multiple interactions (first semihard interaction).
20767C...Choose tau and y*. Calculate cos(theta-hat).
20768 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20769 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20770 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20771 ELSE
20772 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20773 ENDIF
20774 VINT(21)=TAU
20775 CALL PYKLIM(2)
20776 RYST=PYR(0)
20777 MYST=1
20778 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20779 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20780 CALL PYKMAP(2,MYST,PYR(0))
20781 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20782 ENDIF
20783 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20784
20785C...Store results of cross-section calculation.
20786 ELSEIF(MMUL.EQ.4) THEN
20787 ISUB=MINT(1)
20788 VINT(145)=VNT145
20789 VINT(146)=VNT146
20790 VINT(147)=VNT147
20791 XTS=VINT(25)
20792 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20793 IF(ISET(ISUB).EQ.2)
20794 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20795 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20796 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20797 & (XTS+VINT(149))))
20798 IRBIN=INT(1D0+20D0*RBIN)
20799 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20800 NMUL(IRBIN)=NMUL(IRBIN)+1
20801 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20802 ENDIF
20803
20804C...Choose impact parameter if not already done.
20805 ELSEIF(MMUL.EQ.5) THEN
20806 ISUB=MINT(1)
20807 VINT(145)=VNT145
20808 VINT(146)=VNT146
20809 VINT(147)=VNT147
20810 150 IF(MINT(39).GT.0) THEN
20811 ELSEIF(MSTP(82).EQ.3) THEN
20812 EXPB2=PYR(0)
20813 B2=-LOG(PYR(0))
20814 VINT(148)=EXPB2/(PARU(2)*VNT147)
20815 VINT(139)=SQRT(B2)/BAVG
20816 ELSEIF(MSTP(82).EQ.4) THEN
20817 RTYPE=PYR(0)
20818 IF(RTYPE.LT.P83A) THEN
20819 B2=-LOG(PYR(0))
20820 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20821 B2=-LOG(PYR(0))/CQ2R
20822 ELSE
20823 B2=-LOG(PYR(0))/CQ2I
20824 ENDIF
20825 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20826 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20827 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20828 VINT(139)=SQRT(B2)/BAVG
20829 ELSEIF(PARP(83).GE.1.999D0) THEN
20830 POWIP=MAX(2D0,PARP(83))
20831 RPWIP=2D0/POWIP-1D0
20832 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20833 160 IF(PYR(0).LT.PROB1) THEN
20834 B2RPW=PYR(0)**(0.5D0*POWIP)
20835 ACCIP=EXP(-B2RPW)
20836 ELSE
20837 B2RPW=1D0-LOG(PYR(0))
20838 ACCIP=B2RPW**RPWIP
20839 ENDIF
20840 IF(ACCIP.LT.PYR(0)) GOTO 160
20841 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20842 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20843 ELSE
20844 POWIP=MAX(0.4D0,PARP(83))
20845 RPWIP=2D0/POWIP-1D0
20846 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20847 170 IF(PYR(0).LT.PROB1) THEN
20848 B2RPW=2D0*RPWIP*PYR(0)
20849 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20850 ELSE
20851 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20852 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20853 ENDIF
20854 IF(ACCIP.LT .PYR(0)) GOTO 170
20855 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20856 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20857 ENDIF
20858
20859C...Multiple interactions (variable impact parameter) : reject with
20860C...probability exp(-overlap*cross-section above pT/normalization).
20861C...Does not apply to low-b region, where "Sudakov" already included.
20862 VINT(150)=1D0
20863 IF(MINT(39).NE.1) THEN
20864 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20865 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20866 DO 180 IBIN=IRBIN+1,20
20867 RNCOR=RNCOR+NMUL(IBIN)
20868 SIGCOR=SIGCOR+SIGM(IBIN)
20869 180 CONTINUE
20870 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20871 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20872 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20873 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20874 ENDIF
20875 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20876 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20877 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20878 IF(VINT(150).LT.PYR(0)) GOTO 150
20879 VINT(150)=1D0
20880 ENDIF
20881
20882C...Generate additional multiple semihard interactions.
20883 ELSEIF(MMUL.EQ.6) THEN
20884
20885C...Save data for hardest initeraction, to be restored.
20886 ISUBSV=MINT(1)
20887 VINT(145)=VNT145
20888 VINT(146)=VNT146
20889 VINT(147)=VNT147
20890 M13SV=MINT(13)
20891 M14SV=MINT(14)
20892 M15SV=MINT(15)
20893 M16SV=MINT(16)
20894 M21SV=MINT(21)
20895 M22SV=MINT(22)
20896 DO 190 J=11,80
20897 VINTSV(J)=VINT(J)
20898 190 CONTINUE
20899 V141SV=VINT(141)
20900 V142SV=VINT(142)
20901
20902C...Store data on hardest interaction.
20903 XMI(1,1)=VINT(141)
20904 XMI(2,1)=VINT(142)
20905 PT2MI(1)=VINT(54)
20906 IMISEP(0)=MINT(84)
20907 IMISEP(1)=N
20908
20909C...Change process to generate; sum of x values so far.
20910 ISUB=96
20911 MINT(1)=96
20912 VINT(143)=1D0-VINT(141)
20913 VINT(144)=1D0-VINT(142)
20914 VINT(151)=0D0
20915 VINT(152)=0D0
20916
20917C...Initialize factors for PDF reshaping.
20918 DO 230 JS=1,2
20919 KFBEAM=MINT(10+JS)
20920 KFABM=IABS(KFBEAM)
20921 KFSBM=ISIGN(1,KFBEAM)
20922
20923C...Zero flavour content of incoming beam particle.
20924 KFIVAL(JS,1)=0
20925 KFIVAL(JS,2)=0
20926 KFIVAL(JS,3)=0
20927C...Flavour content of baryon.
20928 IF(KFABM.GT.1000) THEN
20929 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20930 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20931 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20932C...Flavour content of pi+-, K+-.
20933 ELSEIF(KFABM.EQ.211) THEN
20934 KFIVAL(JS,1)=KFSBM*2
20935 KFIVAL(JS,2)=-KFSBM
20936 ELSEIF(KFABM.EQ.321) THEN
20937 KFIVAL(JS,1)=-KFSBM*3
20938 KFIVAL(JS,2)=KFSBM*2
20939C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20940 ENDIF
20941
20942C...Zero initial valence and companion content.
20943 DO 200 IFL=-6,6
20944 NVC(JS,IFL)=0
20945 200 CONTINUE
20946
20947C...Initiate listing of all incoming partons from two sides.
20948 NMI(JS)=0
20949 DO 210 I=MINT(84)+1,N
20950 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20951 IMI(JS,1,1)=I
20952 IMI(JS,1,2)=0
20953 ENDIF
20954 210 CONTINUE
20955
20956C...Decide whether quarks in hard scattering were valence or sea.
20957 IFL=K(IMI(JS,1,1),2)
20958 IF (IABS(IFL).GT.6) GOTO 230
20959
20960C...Get PDFs at X and Q2 of the parton shower initiator for the
20961C...hard scattering.
20962 X=VINT(140+JS)
20963 IF(MSTP(61).GE.1) THEN
20964 Q2=PARP(62)**2
20965 ELSE
20966 Q2=VINT(54)
20967 ENDIF
20968C...Note: XPSVC = x*pdf.
20969 MINT(30)=JS
20970C.... ALICE
20971C.... Store side in MINT(124)
20972 MINT(124) = JS
20973C....
20974 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20975 SEA=XPSVC(IFL,-1)
20976 VAL=XPSVC(IFL,0)
20977
20978C...Decide (Extra factor x cancels in the division).
20979 RVCS=PYR(0)*(SEA+VAL)
20980 IVNOW=1
20981 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20982C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20983 IVNOW=0
20984 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20985 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20986 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20987 IF(KFIVAL(JS,1).EQ.0) THEN
20988 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20989 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20990 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20991 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20992 ENDIF
20993 IF(IVNOW.EQ.0) GOTO 220
20994C...Mark valence.
20995 IMI(JS,1,2)=0
20996C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20997 IF(KFIVAL(JS,1).EQ.0) THEN
20998 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20999 KFIVAL(JS,1)=IFL
21000 KFIVAL(JS,2)=-IFL
21001 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21002 KFIVAL(JS,1)=IFL
21003 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21004 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21005 ENDIF
21006 ENDIF
21007
21008C...If sea, add opposite sign companion parton. Store X and I.
21009 ELSE
21010 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21011 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21012C...Set pointer to companion
21013 IMI(JS,1,2)=-NVC(JS,-IFL)
21014 ENDIF
21015 230 CONTINUE
21016
21017C...Update counter number of multiple interactions.
21018 NMI(1)=1
21019 NMI(2)=1
21020
21021C...Set up starting values for iteration in xT2.
21022 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21023 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21024 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21025 & ISUBSV.NE.96)) THEN
21026 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21027 ELSE
21028 XT2=VINT(25)
21029 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21030 IF(ISET(ISUBSV).EQ.2)
21031 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21032 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21033 ENDIF
21034 IF(MSTP(82).LE.1) THEN
21035 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21036 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21037 & VINT(317)/(VINT(318)*VINT(320))
21038 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21039 ELSE
21040 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21041 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21042 ENDIF
21043 VINT(63)=0D0
21044 VINT(64)=0D0
21045
21046C...Iterate downwards in xT2.
21047 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21048 XT2=0D0
21049 GOTO 440
21050 ELSEIF(MSTP(82).LE.1) THEN
21051 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21052 IF(XT2.LT.VINT(149)) GOTO 440
21053 ELSE
21054 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21055 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21056 & LOG(PYR(0)))-VINT(149)
21057 IF(XT2.LE.0D0) GOTO 440
21058 XT2=MAX(0.01D0*VINT(149),XT2)
21059 ENDIF
21060 VINT(25)=XT2
21061
21062C...Choose tau and y*. Calculate cos(theta-hat).
21063 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21064 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21065 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21066 ELSE
21067 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21068 ENDIF
21069 VINT(21)=TAU
21070C...New: require shat > 1.
21071 IF(TAU*VINT(2).LT.1D0) GOTO 240
21072 CALL PYKLIM(2)
21073 RYST=PYR(0)
21074 MYST=1
21075 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21076 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21077 CALL PYKMAP(2,MYST,PYR(0))
21078 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21079
21080C...Check that x not used up. Accept or reject kinematical variables.
21081 X1M=SQRT(TAU)*EXP(VINT(22))
21082 X2M=SQRT(TAU)*EXP(-VINT(22))
21083 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21084 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21085 CALL PYSIGH(NCHN,SIGS)
21086 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21087 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21088 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21089
21090C...Reset K, P and V vectors.
21091 DO 260 I=N+1,N+4
21092 DO 250 J=1,5
21093 K(I,J)=0
21094 P(I,J)=0D0
21095 V(I,J)=0D0
21096 250 CONTINUE
21097 260 CONTINUE
21098 PT=0.5D0*VINT(1)*SQRT(XT2)
21099
21100C...Choose flavour of reacting partons (and subprocess).
21101 RSIGS=SIGS*PYR(0)
21102 DO 270 ICHN=1,NCHN
21103 KFL1=ISIG(ICHN,1)
21104 KFL2=ISIG(ICHN,2)
21105 ICONMI=ISIG(ICHN,3)
21106 RSIGS=RSIGS-SIGH(ICHN)
21107 IF(RSIGS.LE.0D0) GOTO 280
21108 270 CONTINUE
21109
21110C...Reassign to appropriate process codes.
21111 280 ISUBMI=ICONMI/10
21112 ICONMI=MOD(ICONMI,10)
21113
21114C...Choose new quark flavour for annihilation graphs
21115 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21116 SH=TAU*VINT(2)
21117 CALL PYWIDT(21,SH,WDTP,WDTE)
21118 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21119 DO 300 I=1,MDCY(21,3)
21120 KFLF=KFDP(I+MDCY(21,2)-1,1)
21121 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21122 IF(RKFL.LE.0D0) GOTO 310
21123 300 CONTINUE
21124 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21125 IF(KFLF.GE.4) GOTO 290
21126 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21127 KFLF=4
21128 ICONMI=ICONMI-2
21129 ELSEIF(ISUBMI.EQ.53) THEN
21130 KFLF=5
21131 ICONMI=ICONMI-4
21132 ENDIF
21133 ENDIF
21134
21135C...Final state flavours and colour flow: default values
21136 JS=1
21137 KFL3=KFL1
21138 KFL4=KFL2
21139 KCC=20
21140 KCS=ISIGN(1,KFL1)
21141
21142 IF(ISUBMI.EQ.11) THEN
21143C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21144 KCC=ICONMI
21145 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21146
21147 ELSEIF(ISUBMI.EQ.12) THEN
21148C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21149 KFL3=ISIGN(KFLF,KFL1)
21150 KFL4=-KFL3
21151 KCC=4
21152
21153 ELSEIF(ISUBMI.EQ.13) THEN
21154C...f + fbar -> g + g; th arbitrary
21155 KFL3=21
21156 KFL4=21
21157 KCC=ICONMI+4
21158
21159 ELSEIF(ISUBMI.EQ.28) THEN
21160C...f + g -> f + g; th = (p(f)-p(f))**2
21161 IF(KFL1.EQ.21) JS=2
21162 KCC=ICONMI+6
21163 IF(KFL1.EQ.21) KCC=KCC+2
21164 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21165 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21166
21167 ELSEIF(ISUBMI.EQ.53) THEN
21168C...g + g -> f + fbar; th arbitrary
21169 KCS=(-1)**INT(1.5D0+PYR(0))
21170 KFL3=ISIGN(KFLF,KCS)
21171 KFL4=-KFL3
21172 KCC=ICONMI+10
21173
21174 ELSEIF(ISUBMI.EQ.68) THEN
21175C...g + g -> g + g; th arbitrary
21176 KCC=ICONMI+12
21177 KCS=(-1)**INT(1.5D0+PYR(0))
21178 ENDIF
21179
21180C...Store flavours of scattering.
21181 MINT(13)=KFL1
21182 MINT(14)=KFL2
21183 MINT(15)=KFL1
21184 MINT(16)=KFL2
21185 MINT(21)=KFL3
21186 MINT(22)=KFL4
21187
21188C...Set flavours and mothers of scattering partons.
21189 K(N+1,1)=14
21190 K(N+2,1)=14
21191 K(N+3,1)=3
21192 K(N+4,1)=3
21193 K(N+1,2)=KFL1
21194 K(N+2,2)=KFL2
21195 K(N+3,2)=KFL3
21196 K(N+4,2)=KFL4
21197 K(N+1,3)=MINT(83)+1
21198 K(N+2,3)=MINT(83)+2
21199 K(N+3,3)=N+1
21200 K(N+4,3)=N+2
21201
21202C...Store colour connection indices.
21203 DO 320 J=1,2
21204 JC=J
21205 IF(KCS.EQ.-1) JC=3-J
21206 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21207 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21208 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21209 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21210 320 CONTINUE
21211
21212C...Store incoming and outgoing partons in their CM-frame.
21213 SHR=SQRT(TAU)*VINT(1)
21214 P(N+1,3)=0.5D0*SHR
21215 P(N+1,4)=0.5D0*SHR
21216 P(N+2,3)=-0.5D0*SHR
21217 P(N+2,4)=0.5D0*SHR
21218 P(N+3,5)=PYMASS(K(N+3,2))
21219 P(N+4,5)=PYMASS(K(N+4,2))
21220 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21221 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21222 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21223 P(N+4,4)=SHR-P(N+3,4)
21224 P(N+4,3)=-P(N+3,3)
21225
21226C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21227 PHI=PARU(2)*PYR(0)
21228 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21229
21230C...Set up default values before showers.
21231 MINT(31)=MINT(31)+1
21232 IPU1=N+1
21233 IPU2=N+2
21234 IPU3=N+3
21235 IPU4=N+4
21236 VINT(141)=VINT(41)
21237 VINT(142)=VINT(42)
21238 N=N+4
21239
21240C...Showering of initial state partons (optional).
21241C...Note: no showering of final state partons here; it comes later.
21242 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21243 MINT(51)=0
21244 ALAMSV=PARJ(81)
21245 PARJ(81)=PARP(72)
21246 NSAV=N
21247 DO 340 I=1,4
21248 DO 330 J=1,5
21249 KSAV(I,J)=K(N-4+I,J)
21250 PSAV(I,J)=P(N-4+I,J)
21251 330 CONTINUE
21252 340 CONTINUE
21253 CALL PYSSPA(IPU1,IPU2)
21254 PARJ(81)=ALAMSV
21255C...If shower failed then restore to situation before shower.
21256 IF(MINT(51).GE.1) THEN
21257 N=NSAV
21258 DO 360 I=1,4
21259 DO 350 J=1,5
21260 K(N-4+I,J)=KSAV(I,J)
21261 P(N-4+I,J)=PSAV(I,J)
21262 350 CONTINUE
21263 360 CONTINUE
21264 IPU1=N-3
21265 IPU2=N-2
21266 VINT(141)=VINT(41)
21267 VINT(142)=VINT(42)
21268 ENDIF
21269 ENDIF
21270
21271C...Keep track of loose colour ends and information on scattering.
21272 370 IMI(1,MINT(31),1)=IPU1
21273 IMI(2,MINT(31),1)=IPU2
21274 IMI(1,MINT(31),2)=0
21275 IMI(2,MINT(31),2)=0
21276 XMI(1,MINT(31))=VINT(141)
21277 XMI(2,MINT(31))=VINT(142)
21278 PT2MI(MINT(31))=VINT(54)
21279 IMISEP(MINT(31))=N
21280
21281C...Decide whether quarks in last scattering were valence, companion or
21282C...sea.
21283 DO 430 JS=1,2
21284 KFBEAM=MINT(10+JS)
21285 KFSBM=ISIGN(1,MINT(10+JS))
21286 IFL=K(IMI(JS,MINT(31),1),2)
21287 IMI(JS,MINT(31),2)=0
21288 IF (IABS(IFL).GT.6) GOTO 430
21289
21290C...Get PDFs at X and Q2 of the parton shower initiator for the
21291C...last scattering. At this point VINT(143:144) do not yet
21292C...include the scattered x values VINT(141:142).
21293 X=VINT(140+JS)/VINT(142+JS)
21294 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21295 Q2=PARP(62)**2
21296 ELSE
21297 Q2=VINT(54)
21298 ENDIF
21299C...Note: XPSVC = x*pdf.
21300 MINT(30)=JS
21301C.... ALICE
21302C.... Store side in MINT(124)
21303 MINT(124) = JS
21304C....
21305 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21306 SEA=XPSVC(IFL,-1)
21307 VAL=XPSVC(IFL,0)
21308 CMP=0D0
21309 DO 380 IVC=1,NVC(JS,IFL)
21310 CMP=CMP+XPSVC(IFL,IVC)
21311 380 CONTINUE
21312
21313C...Decide (Extra factor x cancels in the dvision).
21314 RVCS=PYR(0)*(SEA+VAL+CMP)
21315 IVNOW=1
21316 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21317C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21318 IVNOW=0
21319 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21320 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21321 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21322 IF(KFIVAL(JS,1).EQ.0) THEN
21323 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21324 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21325 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21326 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21327 ELSE
21328 DO 400 I1=1,NMI(JS)
21329 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21330 & IVNOW=IVNOW-1
21331 400 CONTINUE
21332 ENDIF
21333 IF(IVNOW.EQ.0) GOTO 390
21334C...Mark valence.
21335 IMI(JS,MINT(31),2)=0
21336C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21337 IF(KFIVAL(JS,1).EQ.0) THEN
21338 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21339 KFIVAL(JS,1)=IFL
21340 KFIVAL(JS,2)=-IFL
21341 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21342 KFIVAL(JS,1)=IFL
21343 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21344 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21345 ENDIF
21346 ENDIF
21347
21348 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21349C...If sea, add opposite sign companion parton. Store X and I.
21350 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21351 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21352C...Set pointer to companion
21353 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21354 ELSE
21355C...If companion, decide which one.
21356 CMPSUM=VAL+SEA
21357 ISEL=0
21358 410 ISEL=ISEL+1
21359 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21360 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21361C...Find original sea (anti-)quark:
21362 IASSOC=0
21363 DO 420 I1=1,NMI(JS)
21364 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21365 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21366 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21367 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21368 ENDIF
21369 420 CONTINUE
21370C...Change X to what associated companion had, so that the correct
21371C...amount of momentum can be subtracted from the companion sum below.
21372 X=XASSOC(JS,IFL,ISEL)
21373C...Mark companion read.
21374 XASSOC(JS,IFL,ISEL)=0D0
21375 ENDIF
21376 430 CONTINUE
21377
21378C...Global statistics.
21379 MINT(351)=MINT(351)+1
21380 VINT(351)=VINT(351)+PT
21381 IF (MINT(351).EQ.1) VINT(356)=PT
21382
21383C...Update remaining energy and other counters.
21384 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21385 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21386 MINT(51)=1
21387 RETURN
21388 ENDIF
21389 NMI(1)=NMI(1)+1
21390 NMI(2)=NMI(2)+1
21391 VINT(151)=VINT(151)+VINT(41)
21392 VINT(152)=VINT(152)+VINT(42)
21393 VINT(143)=VINT(143)-VINT(141)
21394 VINT(144)=VINT(144)-VINT(142)
21395
21396C...Iterate, with more interactions allowed.
21397 IF(MINT(31).LT.240) GOTO 240
21398 440 CONTINUE
21399
21400C...Restore saved quantities for hardest interaction.
21401 MINT(1)=ISUBSV
21402 MINT(13)=M13SV
21403 MINT(14)=M14SV
21404 MINT(15)=M15SV
21405 MINT(16)=M16SV
21406 MINT(21)=M21SV
21407 MINT(22)=M22SV
21408 DO 450 J=11,80
21409 VINT(J)=VINTSV(J)
21410 450 CONTINUE
21411 VINT(141)=V141SV
21412 VINT(142)=V142SV
21413
21414 ENDIF
21415
21416C...Format statements for printout.
21417 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21418 &'actions for MSTP(82) =',I2,' ******')
21419 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21420 &D9.2,' mb: rejected')
21421 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21422 &D9.2,' mb: accepted')
21423
21424 RETURN
21425 END
21426
21427C*********************************************************************
21428
21429C...PYMIHK
21430C...Finds left-behind remnant flavour content and hooks up
21431C...the colour flow between the hard scattering and remnants
21432
21433 SUBROUTINE PYMIHK
21434
21435C...Double precision and integer declarations.
21436 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21437 IMPLICIT INTEGER(I-N)
21438 INTEGER PYK,PYCHGE,PYCOMP
21439C...The event record
21440 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21441C...Parameters
21442 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21443 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21444 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21445 COMMON/PYINT1/MINT(400),VINT(400)
21446C...The common block of dangling ends
21447 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21448 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21449 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21450 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21451C...Local variables
21452 PARAMETER (NERSIZ=4000)
21453 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21454 & ,MACCPT
21455 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21456 SAVE /PYCBLS/,/PYCTAG/
21457 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21458 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21459 DATA NERRPR/0/
21460 SAVE NERRPR
21461 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)
21462
21463C...Set up error checkers
21464 IBOOST=0
21465
21466C...Initialize colour arrays: MCO (Original) and MCT (New)
21467 DO 110 I=MINT(84)+1,NERSIZ
21468 DO 100 JC=1,2
21469 MCT(I,JC)=0
21470 MCO(I,JC)=0
21471 100 CONTINUE
21472C...Also zero colour tracing information, if existed.
21473 IF (I.LE.N) THEN
21474 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21475 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21476 ENDIF
21477 110 CONTINUE
21478
21479C...Initialize colour tag collapse arrays:
21480C...JCCO (Original) and JCCN (New).
21481 DO 130 MG=MINT(84)+1,NERSIZ
21482 DO 120 JC=1,2
21483 JCCO(MG,JC)=0
21484 JCCN(MG,JC)=0
21485 120 CONTINUE
21486 130 CONTINUE
21487
21488C...Zero gluon insertion array
21489 DO 150 IM=1,1000
21490 DO 140 J=1,3
21491 INSR(IM,J)=0
21492 140 CONTINUE
21493 150 CONTINUE
21494
21495C...Compute hard scattering system rapidities
21496 IF (MSTP(89).EQ.1) THEN
21497 DO 160 IM=1,240
21498 IF (IM.LE.MINT(31)) THEN
21499 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21500 ELSE
21501C...Set (unsigned) rapidity = 100 for beam remnant systems.
21502 YMI(IM)=100D0
21503 ENDIF
21504 160 CONTINUE
21505 ENDIF
21506
21507C...Treat each side separately
21508 DO 290 JS=1,2
21509
21510C...Initialize side.
21511 NG(JS)=0
21512 JV=0
21513 KFS=ISIGN(1,MINT(10+JS))
21514
21515C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21516 IF(KFIVAL(JS,1).EQ.0) THEN
21517 IF(MINT(10+JS).EQ.111) THEN
21518 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
21519 KFIVAL(JS,2)=-KFIVAL(JS,1)
21520 ELSEIF(MINT(10+JS).EQ.22) THEN
21521 PYRKF=PYR(0)
21522 KFIVAL(JS,1)=1
21523 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
21524 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
21525 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
21526 KFIVAL(JS,2)=-KFIVAL(JS,1)
21527 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
21528 IF(PYR(0).GT.0.5D0) THEN
21529 KFIVAL(JS,1)=1
21530 KFIVAL(JS,2)=-3
21531 ELSE
21532 KFIVAL(JS,1)=3
21533 KFIVAL(JS,2)=-1
21534 ENDIF
21535 ENDIF
21536 ENDIF
21537
21538C...Initialize beam remnant sea and valence content flavour by flavour.
21539 NVSUM(JS)=0
21540 NBRTOT(JS)=0
21541 DO 210 JFA=1,6
21542C...Count up original number of JFA valence quarks and antiquarks.
21543 NVALQ=0
21544 NVALQB=0
21545 NSEA=0
21546 DO 170 J=1,3
21547 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
21548 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
21549 170 CONTINUE
21550 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
21551C...Subtract kicked out valence and determine sea from flavour cons.
21552 DO 180 IM=1,NMI(JS)
21553 IFL = K(IMI(JS,IM,1),2)
21554 IFA = IABS(IFL)
21555 IFS = ISIGN(1,IFL)
21556 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21557C...Subtract K.O. valence quark from remainder.
21558 NVALQ=NVALQ-1
21559 JV=NVSUM(JS)-NVALQ-NVALQB
21560 IV(JS,JV)=IMI(JS,IM,1)
21561 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21562C...Subtract K.O. valence antiquark from remainder.
21563 NVALQB=NVALQB-1
21564 JV=NVSUM(JS)-NVALQ-NVALQB
21565 IV(JS,JV)=IMI(JS,IM,1)
21566 ELSEIF (IFA.EQ.JFA) THEN
21567C...Outside sea without companion: add opposite sea flavour inside.
21568 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
21569 ENDIF
21570 180 CONTINUE
21571C...Check if space left in PYJETS for additional BR flavours
21572 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
21573 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
21574 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
21575 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
21576 MINT(51)=1
21577 RETURN
21578 ENDIF
21579C...Add required val+sea content to beam remnant.
21580 IF (NFLSUM.GT.0) THEN
21581 DO 200 IA=1,NFLSUM
21582C...Insert beam remnant quark as p.t. symbolic parton in ER.
21583 N=N+1
21584 DO 190 IX=1,5
21585 K(N,IX)=0
21586 P(N,IX)=0D0
21587 V(N,IX)=0D0
21588 190 CONTINUE
21589 K(N,1)=3
21590 K(N,2)=ISIGN(JFA,NSEA)
21591 IF (IA.LE.NVALQ) K(N,2)=JFA
21592 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
21593 K(N,3)=MINT(83)+JS
21594C...Also update NMI, IMI, and IV arrays.
21595 NMI(JS)=NMI(JS)+1
21596 IMI(JS,NMI(JS),1)=N
21597 IMI(JS,NMI(JS),2)=-1
21598 IF (IA.LE.NVALQ+NVALQB) THEN
21599 IMI(JS,NMI(JS),2)=0
21600 JV=JV+1
21601 IV(JS,JV)=IMI(JS,NMI(JS),1)
21602 ENDIF
21603 200 CONTINUE
21604 ENDIF
21605 210 CONTINUE
21606
21607 IM=0
21608 220 IM=IM+1
21609 IF (IM.LE.NMI(JS)) THEN
21610 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
21611 NG(JS)=NG(JS)+1
21612C...Add fictitious parent gluons for companion pairs.
21613 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
21614C...Randomly assign companions to sea quarks which have none.
21615 IF (IMI(JS,IM,2).LT.0) THEN
21616 IMC=PYR(0)*NMI(JS)
21617 230 IMC=MOD(IMC,NMI(JS))+1
21618 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
21619 IF (IMI(JS,IMC,2).GE.0) GOTO 230
21620 IMI(JS, IM,2) = IMI(JS,IMC,1)
21621 IMI(JS,IMC,2) = IMI(JS, IM,1)
21622 ENDIF
21623C...Add fictitious parent gluon
21624 N=N+1
21625 DO 240 IX=1,5
21626 K(N,IX)=0
21627 P(N,IX)=0D0
21628 V(N,IX)=0D0
21629 240 CONTINUE
21630 K(N,1)=14
21631 K(N,2)=21
21632 K(N,3)=MINT(83)+JS
21633C...Set gluon (anti-)colour daughter pointers
21634 K(N,4)=IMI(JS, IM,1)
21635 K(N,5)=IMI(JS, IM,2)
21636C...Set quark (anti-)colour parent pointers
21637 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21638 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21639C...Add gluon to IMI
21640 NMI(JS)=NMI(JS)+1
21641 IMI(JS,NMI(JS),1)=N
21642 IMI(JS,NMI(JS),2)=0
21643 ENDIF
21644 GOTO 220
21645 ENDIF
21646
21647C...If incoming (anti-)baryon, insert inside (anti-)junction.
21648C...Set up initial v-v-j-v configuration. Otherwise set up
21649C...mesonic v-vbar configuration
21650 IF (IABS(MINT(10+JS)).GT.1000) THEN
21651C...Determine junction type (1: B=1 2: B=-1)
21652 ITJUNC(JS) = (3-KFS)/2
21653C...Insert junction.
21654 N=N+1
21655 DO 250 IX=1,5
21656 K(N,IX)=0
21657 P(N,IX)=0D0
21658 V(N,IX)=0D0
21659 250 CONTINUE
21660C...Set special junction codes:
21661 K(N,1)=42
21662 K(N,2)=88
21663C...Set parent to side.
21664 K(N,3)=MINT(83)+JS
21665 K(N,4)=ITJUNC(JS)*MSTU(5)
21666 K(N,5)=0
21667C...Connect valence quarks to junction.
21668 MOUT(JS)=0
21669 MANTI=ITJUNC(JS)-1
21670C...Set (anti)colour mother = junction.
21671 DO 260 JV=1,3
21672 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21673 & +MSTU(5)*N
21674C...Keep track of partons adjacent to junction:
21675 JST(JS,JV)=IV(JS,JV)
21676 260 CONTINUE
21677 ELSE
21678C...Mesons: set up initial q-qbar topology
21679 ITJUNC(JS)=0
21680 IF (K(IV(JS,1),2).GT.0) THEN
21681 IQ=IV(JS,1)
21682 IQBAR=IV(JS,2)
21683 ELSE
21684 IQ=IV(JS,2)
21685 IQBAR=IV(JS,1)
21686 ENDIF
21687 IV(JS,3)=0
21688 JST(JS,1)=IQ
21689 JST(JS,2)=IQBAR
21690 JST(JS,3)=0
21691 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21692 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21693C...Special for mesons. Insert gluon if BR empty.
21694 IF (NBRTOT(JS).EQ.0) THEN
21695 N=N+1
21696 DO 270 IX=1,5
21697 K(N,IX)=0
21698 P(N,IX)=0D0
21699 V(N,IX)=0D0
21700 270 CONTINUE
21701 K(N,1)=3
21702 K(N,2)=21
21703 K(N,3)=MINT(83)+JS
21704 K(N,4)=0
21705 K(N,5)=0
21706 NBRTOT(JS)=1
21707 NG(JS)=NG(JS)+1
21708C...Add gluon to IMI
21709 NMI(JS)=NMI(JS)+1
21710 IMI(JS,NMI(JS),1)=N
21711 IMI(JS,NMI(JS),2)=0
21712 ENDIF
21713 MOUT(JS)=0
21714 ENDIF
21715
21716C...Count up number of valence quarks outside BR.
21717 DO 280 JV=1,3
21718 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21719 & MOUT(JS)=MOUT(JS)+1
21720 280 CONTINUE
21721
21722 290 CONTINUE
21723
21724C...Now both sides have been prepared in an initial vvjv (baryonic) or
21725C...v(g)vbar (mesonic) configuration.
21726
21727C...Create colour line tags starting from initiators.
21728 NCT=0
21729 DO 320 IM=1,MINT(31)
21730C...Consider each side in turn.
21731 DO 310 JS=1,2
21732 I1=IMI(JS,IM,1)
21733 I2=IMI(3-JS,IM,1)
21734 DO 300 JCS=4,5
21735 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21736 & GOTO 300
21737 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21738
21739 KCS=JCS
21740 CALL PYCTTR(I1,KCS,I2)
21741 IF(MINT(51).NE.0) RETURN
21742
21743 300 CONTINUE
21744 310 CONTINUE
21745 320 CONTINUE
21746
21747 DO 340 JS=1,2
21748C...Create colour tags for beam remnant partons.
21749 DO 330 IM=MINT(31)+1,NMI(JS)
21750 IP=IMI(JS,IM,1)
21751 IF (K(IP,2).NE.21) THEN
21752 JC=(3-ISIGN(1,K(IP,2)))/2
21753 IF (MCT(IP,JC).EQ.0) THEN
21754 NCT=NCT+1
21755 MCT(IP,JC)=NCT
21756 ENDIF
21757 ELSE
21758C...Gluons
21759 ICD=K(IP,4)
21760 IAD=K(IP,5)
21761 IF (ICD.NE.0) THEN
21762C...Fictituous gluons just inherit from their quark daughters.
21763 ICC=MCT(ICD,1)
21764 IAC=MCT(IAD,2)
21765 ELSE
21766C...Real beam remnant gluons get their own colours
21767 ICC=NCT+1
21768 IAC=NCT+2
21769 NCT=NCT+2
21770 ENDIF
21771 MCT(IP,1)=ICC
21772 MCT(IP,2)=IAC
21773 ENDIF
21774 330 CONTINUE
21775 340 CONTINUE
21776
21777C...Create colour tags for colour lines which are detached from the
21778C...initial state.
21779
21780 DO 360 MQGST=1,2
21781 DO 350 I=MINT(84)+1,N
21782
21783C...Look for coloured string endpoint, or (later) leftover gluon.
21784 IF (K(I,1).NE.3) GOTO 350
21785 KC=PYCOMP(K(I,2))
21786 IF(KC.EQ.0) GOTO 350
21787 KQ=KCHG(KC,2)
21788 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21789
21790C...Pick up loose string end with no previous tag.
21791 KCS=4
21792 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21793 IF(MCT(I,KCS-3).NE.0) GOTO 350
21794
21795 CALL PYCTTR(I,KCS,I)
21796 IF(MINT(51).NE.0) RETURN
21797
21798 350 CONTINUE
21799 360 CONTINUE
21800
21801C...Store original colour tags
21802 DO 370 I=MINT(84)+1,N
21803 MCO(I,1)=MCT(I,1)
21804 MCO(I,2)=MCT(I,2)
21805 370 CONTINUE
21806
21807C...Iteratively add gluons to already existing string pieces, enforcing
21808C...various possible orderings, and rejecting insertions that would give
21809C...rise to singlet gluons.
21810C...<kappa tau> normalization.
21811 RM0=1.5D0
21812 MRETRY=0
21813 PARP80=PARP(80)
21814
21815C...Set up simplified kinematics.
21816C...Boost hard interaction systems.
21817 IBOOST=IBOOST+1
21818 DO 380 IM=1,MINT(31)
21819 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21820 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21821 380 CONTINUE
21822C...Assign preliminary beam remnant momenta.
21823 DO 390 I=MINT(53)+1,N
21824 JS=K(I,3)
21825 P(I,1)=0D0
21826 P(I,2)=0D0
21827 IF (K(I,2).NE.88) THEN
21828 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21829 P(I,3)=P(I,4)
21830 IF (JS.EQ.2) P(I,3)=-P(I,3)
21831 ELSE
21832C...Junctions are wildcards for the present.
21833 P(I,4)=0D0
21834 P(I,3)=0D0
21835 ENDIF
21836 390 CONTINUE
21837
21838C...Reset colour processing information.
21839 400 DO 410 I=MINT(84)+1,N
21840 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21841 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21842 410 CONTINUE
21843
21844 NCC=0
21845 DO 430 JS=1,2
21846C...If meson, without gluon in BR, collapse q-qbar colour tags:
21847 IF (ITJUNC(JS).EQ.0) THEN
21848 JC1=MCT(JST(JS,1),1)
21849 JC2=MCT(JST(JS,2),2)
21850 NCC=NCC+1
21851 JCCO(NCC,1)=MAX(JC1,JC2)
21852 JCCO(NCC,2)=MIN(JC1,JC2)
21853C...Collapse colour tags in event record
21854 DO 420 I=MINT(84)+1,N
21855 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21856 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21857 420 CONTINUE
21858 ENDIF
21859 430 CONTINUE
21860
21861 440 JS=1
21862 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21863 IF (NG(JS).GT.0) THEN
21864 NOPT=0
21865 RLOPT=1D9
21866C...Start at random gluon (optimizes speed for random attachments)
21867 NMGL=0
21868 IMGL=PYR(0)*NMI(JS)+1
21869 450 IMGL=MOD(IMGL,NMI(JS))+1
21870 NMGL=NMGL+1
21871C...Only loop through NMI once (with upper limit to save time)
21872 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21873 IGL = IMI(JS,IMGL,1)
21874C...If not gluon or if already connected, try next.
21875 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21876 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21877C...Now loop through all possible insertions of this gluon.
21878 NMP1=0
21879 IMP1=PYR(0)*NMI(JS)+1
21880 460 IMP1=MOD(IMP1,NMI(JS))+1
21881 NMP1=NMP1+1
21882 IF (IMP1.EQ.IMGL) GOTO 460
21883C...Only loop through NMI once (with upper limit to save time).
21884 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21885 IP1 = IMI(JS,IMP1,1)
21886C...Try both colour mother and colour anti-mother.
21887C...Randomly select which one to try first.
21888 NANTI=0
21889 MANTI=PYR(0)*2
21890 470 MANTI=MOD(MANTI+1,2)
21891 NANTI=NANTI+1
21892 IF (NANTI.LE.2) THEN
21893 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21894C...Reject if no appropriate mother (or if mother is fictitious
21895C...parent gluon.)
21896 IF (IP2.LE.0) GOTO 470
21897 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21898C...Also reject if this link has already been tried.
21899 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21900 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21901C...Set flag to indicate that this link has now been tried for this
21902C...gluon. IP2 may be junction, which has several mothers.
21903 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21904 IF (K(IP2,2).NE.88) THEN
21905 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21906 ENDIF
21907
21908C...JCG1: Original colour tag of gluon on IP1 side
21909C...JCG2: Original colour tag of gluon on IP2 side
21910C...JCP1: Original colour tag of IP1 on gluon side
21911C...JCP2: Original colour tag of IP2 on gluon side.
21912 JCG1=MCO(IGL,2-MANTI)
21913 JCG2=MCO(IGL,1+MANTI)
21914 JCP1=MCO(IP1,1+MANTI)
21915 JCP2=MCO(IP2,2-MANTI)
21916
21917 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21918C...Reject gluon attachments that give rise to singlet gluons.
21919 IF (MACCPT.EQ.0) GOTO 470
21920
21921C...Update colours
21922 JCG1=MCT(IGL,2-MANTI)
21923 JCG2=MCT(IGL,1+MANTI)
21924 JCP1=MCT(IP1,1+MANTI)
21925 JCP2=MCT(IP2,2-MANTI)
21926
21927C...Select whether to accept this insertion
21928 IF (MSTP(89).EQ.0) THEN
21929C...Random insertions: no measure.
21930 RL=1D0
21931C...For random ordering, we want to suppress beam remnant breakups
21932C...already at this point.
21933 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21934 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21935 NMP1=0
21936 NMGL=0
21937 GOTO 470
21938 ENDIF
21939 ELSEIF (MSTP(89).EQ.1) THEN
21940C...Rapidity ordering:
21941C...YGL = Rapidity of gluon.
21942 YGL=YMI(IMGL)
21943C...If fictitious gluon
21944 IF (YGL.EQ.100D0) THEN
21945 YGL=(3-2*JS)*100D0
21946 IDA1=MOD(K(IGL,4),MSTU(5))
21947 IDA2=MOD(K(IGL,5),MSTU(5))
21948 DO 480 IMT=1,NMI(JS)
21949C...Select (arbitrarily) the most central daughter.
21950 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21951 & THEN
21952 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21953 ENDIF
21954 480 CONTINUE
21955 ENDIF
21956C...YP1 = Rapidity IP1
21957 YP1=YMI(IMP1)
21958C...If fictitious gluon
21959 IF (YP1.EQ.100D0) THEN
21960 YP1=(3-2*JS)*YP1
21961 IDA1=MOD(K(IP1,4),MSTU(5))
21962 IDA2=MOD(K(IP1,5),MSTU(5))
21963 DO 490 IMT=1,NMI(JS)
21964C...Select (arbitrarily) the most central daughter.
21965 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21966 & THEN
21967 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21968 ENDIF
21969 490 CONTINUE
21970 ENDIF
21971C...YP2 = Rapidity of mother system
21972 IF (K(IP2,2).NE.88) THEN
21973 DO 500 IMT=1,NMI(JS)
21974 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21975 500 CONTINUE
21976C...If fictitious gluon
21977 IF (YP2.EQ.100D0) THEN
21978 YP2=(3-2*JS)*YP2
21979 IDA1=MOD(K(IP2,4),MSTU(5))
21980 IDA2=MOD(K(IP2,5),MSTU(5))
21981 DO 510 IMT=1,NMI(JS)
21982C...Select (arbitrarily) the most central daughter.
21983 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21984 & ) THEN
21985 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21986 ENDIF
21987 510 CONTINUE
21988 ENDIF
21989C...Assign (arbitrarily) 100D0 to junction also
21990 ELSE
21991 YP2=(3-2*JS)*100D0
21992 ENDIF
21993 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21994 ELSEIF (MSTP(89).EQ.2) THEN
21995C...Lambda ordering:
21996C...Compute lambda measure for this insertion.
21997 RL=1D0
21998 DO 520 IST=1,6
21999 ISTR(IST)=0
22000 520 CONTINUE
22001C...If IP2 is junction, not caught below.
22002 IF (JCP2.EQ.0) THEN
22003 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22004C...Anti-junction is colour endpoint et vv., always on JCG2.
22005 ISTR(5-ITJU)=IP2
22006 ENDIF
22007 DO 530 I=MINT(84)+1,N
22008 IF (K(I,1).LT.10) THEN
22009C...The new string pieces
22010 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22011 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22012 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22013 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22014 ENDIF
22015 530 CONTINUE
22016C...Also identify junctions as string endpoints.
22017 DO 540 I=MINT(84)+1,N
22018 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22019 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22020C...Find partons adjacent to junctions.
22021 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22022 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22023 & .EQ.0) ISTR(2) = ICMO
22024 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22025 & .EQ.0) ISTR(4) = ICMO
22026 ENDIF
22027 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22028 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22029 & .EQ.0) ISTR(1) = IAMO
22030 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22031 & .EQ.0) ISTR(3) = IAMO
22032 ENDIF
22033 540 CONTINUE
22034C...The old string piece
22035 ISTR(5)=ISTR(1+2*MANTI)
22036 ISTR(6)=ISTR(4-2*MANTI)
22037 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22038 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22039C...If one or more of the colour tags for this connection is/are still
22040C...dangling, skip this attempt for the time being.
22041 RL=1D6
22042 ELSE
22043 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22044 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22045 RL=LOG(RL)
22046 ENDIF
22047 ENDIF
22048C...Allow some breadth to speed things up.
22049 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22050 NOPT=NOPT+1
22051 ELSEIF (RL.GT.RLOPT) THEN
22052 GOTO 470
22053 ELSE
22054 NOPT=1
22055 RLOPT=RL
22056 ENDIF
22057C...INSR(NOPT,1)=Gluon colour mother
22058C...INSR(NOPT,2)=Gluon
22059C...INSR(NOPT,3)=Gluon anticolour mother
22060 IF (NOPT.GT.1000) GOTO 470
22061 INSR(NOPT,1+2*MANTI)=IP2
22062 INSR(NOPT,2)=IGL
22063 INSR(NOPT,3-2*MANTI)=IP1
22064 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22065 ENDIF
22066 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22067 ENDIF
22068C...Reset link test information.
22069 DO 550 I=MINT(84)+1,N
22070 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22071 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22072 550 CONTINUE
22073 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22074 ENDIF
22075C...Now we have a list of best gluon insertions, none of which cause
22076C...singlets to arise. If list is empty, try again a few times. Note:
22077C...this should never happen if we have a meson with a gluon inserted
22078C...in the beam remnant, since that breaks up the colour line.
22079 IF (NOPT.EQ.0) THEN
22080C...Abandon BR-g-BR suppression for retries. This is not serious, it
22081C...just means we happened to start with trying a bad sequence.
22082 PARP80=1D0
22083 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22084 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22085 MRETRY=MRETRY+1
22086 DO 590 JS=1,2
22087 IF (ITJUNC(JS).NE.0) THEN
22088 JST(JS,1)=IV(JS,1)
22089 JST(JS,2)=IV(JS,2)
22090 JST(JS,3)=IV(JS,3)
22091C...Reset valence quark parent pointers
22092 DO 560 I=MINT(53)+1,N
22093 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22094 560 CONTINUE
22095 MANTI=ITJUNC(JS)-1
22096C...Set (anti)colour mother = junction.
22097 DO 570 JV=1,3
22098 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22099 & +MSTU(5)*IJU
22100 570 CONTINUE
22101 ELSE
22102C...Same for mesons. JST unchanged, so needn't be restored.
22103 IQ=JST(JS,1)
22104 IQBAR=JST(JS,2)
22105 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22106 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22107 ENDIF
22108C...Also reset gluon parent pointers.
22109 NG(JS)=0
22110 DO 580 IM=1,NMI(JS)
22111 I=IMI(JS,IM,1)
22112 IF (K(I,2).EQ.21) THEN
22113 K(I,4)=MOD(K(I,4),MSTU(5))
22114 K(I,5)=MOD(K(I,5),MSTU(5))
22115 NG(JS)=NG(JS)+1
22116 ENDIF
22117 580 CONTINUE
22118 590 CONTINUE
22119C...Reset colour tags
22120 DO 600 I=MINT(84)+1,N
22121 MCT(I,1)=MCO(I,1)
22122 MCT(I,2)=MCO(I,2)
22123 600 CONTINUE
22124 GOTO 400
22125 ELSE
22126 IF(NERRPR.LT.5) THEN
22127 NERRPR=NERRPR+1
22128 CALL PYLIST(4)
22129 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22130 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22131 ENDIF
22132C...Kill event and start another.
22133 MINT(51)=1
22134 RETURN
22135 ENDIF
22136 ELSE
22137C...Select between insertions, suppressing insertions wholly in the BR.
22138 IIN=PYR(0)*NOPT+1
22139 610 IIN=MOD(IIN,NOPT)+1
22140 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22141 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22142 ENDIF
22143
22144C...Now we know which gluon to insert where. Colour tags in JCCO and
22145C...colour connection information should be updated, NG(JS) should be
22146C...counted down, and a new loop performed if there are still gluons
22147C...left on any side.
22148 ICM=INSR(IIN,1)
22149 IACM=INSR(IIN,3)
22150 IGL=INSR(IIN,2)
22151C...JCG : Original gluon colour tag
22152C...JCAG: Original gluon anticolour tag.
22153C...JCM : Original anticolour tag of gluon colour mother
22154C...JACM: Original colour tag of gluon anticolour mother
22155 JCG=MCO(IGL,1)
22156 JCM=MCO(ICM,2)
22157 JACG=MCO(IGL,2)
22158 JACM=MCO(IACM,1)
22159
22160 CALL PYMIHG(JACM,JACG,JCM,JCG)
22161 IF (MACCPT.EQ.0) THEN
22162 IF(NERRPR.LT.5) THEN
22163 NERRPR=NERRPR+1
22164 CALL PYLIST(4)
22165 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22166 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22167 ENDIF
22168C...Kill event and start another.
22169 MINT(51)=1
22170 RETURN
22171 ELSE
22172C...If everything went fine, store new JCCN in JCCO.
22173 NCC=NCC+1
22174 DO 620 ICC=1,NCC
22175 JCCO(ICC,1)=JCCN(ICC,1)
22176 JCCO(ICC,2)=JCCN(ICC,2)
22177 620 CONTINUE
22178 ENDIF
22179
22180C...One gluon attached is counted as equivalent to one end outside.
22181 MOUT(JS)=1
22182C...Set IGL colour mother = ICM.
22183 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22184C...Set ICM anticolour mother = IGL colour.
22185 IF (K(ICM,2).NE.88) THEN
22186 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22187 ELSE
22188C...If ICM is junction, just update JST array for now.
22189 DO 630 MSJ=1,3
22190 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22191 630 CONTINUE
22192 ENDIF
22193C...Set IGL anticolour mother = IACM.
22194 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22195C...Set IACM anticolour mother = IGL anticolour.
22196 IF (K(IACM,2).NE.88) THEN
22197 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22198 ELSE
22199C...If IACM is junction, just update JST array for now.
22200 DO 640 MSJ=1,3
22201 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22202 640 CONTINUE
22203 ENDIF
22204C...Count down # unconnected gluons.
22205 NG(JS)=NG(JS)-1
22206 ENDIF
22207 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22208
22209 DO 840 JS=1,2
22210C...Collapse fictitious gluons.
22211 DO 670 IGL=MINT(53)+1,N
22212 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22213 & K(IGL,1).EQ.14) THEN
22214 ICM=K(IGL,4)/MSTU(5)
22215 IAM=K(IGL,5)/MSTU(5)
22216 ICD=MOD(K(IGL,4),MSTU(5))
22217 IAD=MOD(K(IGL,5),MSTU(5))
22218C...Set gluon daughters pointing to gluon mothers
22219 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22220 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22221C...Set gluon mothers pointing to gluon daughters.
22222 IF (K(ICM,2).NE.88) THEN
22223 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22224 ELSE
22225C...Special case: mother=junction. Just update JST array for now.
22226 DO 650 MSJ=1,3
22227 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22228 650 CONTINUE
22229 ENDIF
22230 IF (K(IAM,2).NE.88) THEN
22231 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22232 ELSE
22233 DO 660 MSJ=1,3
22234 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22235 660 CONTINUE
22236 ENDIF
22237 ENDIF
22238 670 CONTINUE
22239
22240C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22241 IM=NMI(JS)+1
22242 680 IM=IM-1
22243 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22244 IF (IM.GT.MINT(31)) THEN
22245 NMI(JS)=NMI(JS)-1
22246 DO 690 IMR=IM,NMI(JS)
22247 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22248 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22249 690 CONTINUE
22250 GOTO 680
22251 ENDIF
22252
22253C...Finally, connect junction.
22254 IF (ITJUNC(JS).NE.0) THEN
22255 DO 700 I=MINT(53)+1,N
22256 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22257 700 CONTINUE
22258C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22259 NBRJQ =0
22260 NBRVQ =0
22261 DO 720 MSJ=1,3
22262 IDQ(MSJ)=0
22263C...Find jq with no glue inbetween inside beam remnant.
22264 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22265 & THEN
22266 NBRJQ=NBRJQ+1
22267C...Set IDQ = -I if q non-valence and = +I if q valence.
22268 IDQ(NBRJQ)=-JST(JS,MSJ)
22269 DO 710 JV=1,3
22270 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22271 IDQ(NBRJQ)=JST(JS,MSJ)
22272 NBRVQ=NBRVQ+1
22273 ENDIF
22274 710 CONTINUE
22275 ENDIF
22276 I12=MOD(MSJ+1,2)
22277 I45=5
22278 IF (MSJ.EQ.3) I45=4
22279 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22280 720 CONTINUE
22281
22282C...Check if diquark can be formed.
22283 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22284 & .GE.1)) THEN
22285C...If there is less than 2 valence quarks connected to junction
22286C...and MSTP(88)>1, use random non-valence quarks to fill up.
22287 IF (NBRVQ.LE.1) THEN
22288 NDIQ=NBRVQ
22289 730 JFLIP=NBRJQ*PYR(0)+1
22290 IF (IDQ(JFLIP).LT.0) THEN
22291 IDQ(JFLIP)=-IDQ(JFLIP)
22292 NDIQ=NDIQ+1
22293 ENDIF
22294 IF (NDIQ.LE.1) GOTO 730
22295 ENDIF
22296C...Place selected quarks first in IDQ, ordered in flavour.
22297 DO 740 JDQ=1,3
22298 IF (IDQ(JDQ).LE.0) THEN
22299 ITEMP1 = IDQ(JDQ)
22300 IDQ(JDQ)= IDQ(3)
22301 IDQ(3) = -ITEMP1
22302 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22303 ITEMP1 = IDQ(1)
22304 IDQ(1) = IDQ(2)
22305 IDQ(2) = ITEMP1
22306 ENDIF
22307 ENDIF
22308 740 CONTINUE
22309C...Choose diquark spin.
22310 IF (NBRVQ.EQ.2) THEN
22311C...If the selected quarks are both valence, we may use SU(6) rules
22312C...to figure out which spin the diquark has, by a subdivision of the
22313C...original beam hadron into the selected diquark system plus a kicked
22314C...out quark, IKO.
22315 JKO=6
22316 DO 760 JDQ=1,2
22317 DO 750 JV=1,3
22318 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22319 750 CONTINUE
22320 760 CONTINUE
22321 IKO=IV(JS,JKO)
22322 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22323 ELSE
22324C...If one or more of the selected quarks are not valence, we cannot use
22325C...SU(6) subdivisions of the original beam hadron. Instead, with the
22326C...flavours of the diquark already selected, we assume for now
22327C...50:50 spin-1:spin-0 (where spin-0 possible).
22328 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22329 IS=3
22330 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22331 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22332 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22333 ENDIF
22334
22335C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22336C...Note: third quark can per definition not also be valence,
22337C...therefore we can only do this if we are allowed to use sea quarks.
22338 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22339 NTRY=0
22340 780 NTRY=NTRY+1
22341 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22342 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22343 GOTO 780
22344 ELSEIF(NTRY.GT.100) THEN
22345C...If no baryon can be found, give up and form diquark.
22346 IDQ(3)=0
22347 GOTO 770
22348 ELSE
22349C...Replace junction by baryon.
22350 K(IJU,1)=1
22351 K(IJU,2)=KFBAR
22352 K(IJU,3)=MINT(83)+JS
22353 K(IJU,4)=0
22354 K(IJU,5)=0
22355 P(IJU,5)=PYMASS(KFBAR)
22356 DO 790 MSJ=1,3
22357C...Prepare removal of participating quarks from ER.
22358 K(JST(JS,MSJ),1)=-1
22359 790 CONTINUE
22360 ENDIF
22361 ELSE
22362C...If collapse to baryon not possible or not allowed, replace junction
22363C...by diquark. This way, collapsed gluons that were pointing at the
22364C...junction will now point (correctly) at diquark.
22365 MANTI=ITJUNC(JS)-1
22366 K(IJU,1)=3
22367 K(IJU,2)=KFDQ
22368 K(IJU,3)=MINT(83)+JS
22369 K(IJU,4)=0
22370 K(IJU,5)=0
22371 DO 800 MSJ=1,3
22372 IP=JST(JS,MSJ)
22373 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22374 K(IJU,4+MANTI)=0
22375 K(IJU,5-MANTI)=IP*MSTU(5)
22376 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22377 & MSTU(5)*IJU
22378 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22379 ELSE
22380C...Prepare removal of participating quarks from ER.
22381 K(IP,1)=-1
22382 ENDIF
22383 800 CONTINUE
22384 ENDIF
22385
22386C...Update so ER pointers to collapsed quarks
22387C...now go to collapsed object.
22388 DO 820 I=MINT(84)+1,N
22389 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22390 & .K(I,1).GT.0) THEN
22391 DO 810 ISID=4,5
22392 IMO=K(I,ISID)/MSTU(5)
22393 IDA=MOD(K(I,ISID),MSTU(5))
22394 IF (IMO.GT.0) THEN
22395 IF (K(IMO,1).EQ.-1) IMO=IJU
22396 ENDIF
22397 IF (IDA.GT.0) THEN
22398 IF (K(IDA,1).EQ.-1) IDA=IJU
22399 ENDIF
22400 K(I,ISID)=IDA+MSTU(5)*IMO
22401 810 CONTINUE
22402 ENDIF
22403 820 CONTINUE
22404 ENDIF
22405 ENDIF
22406
22407C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22408C...(this only happens for baryons, where we want to force the gluon
22409C...to sit next to the junction. Mesons handled above.)
22410 IF (NBRTOT(JS).EQ.0) THEN
22411 N=N+1
22412 DO 830 IX=1,5
22413 K(N,IX)=0
22414 P(N,IX)=0D0
22415 V(N,IX)=0D0
22416 830 CONTINUE
22417 IGL=N
22418 K(IGL,1)=3
22419 K(IGL,2)=21
22420 K(IGL,3)=MINT(83)+JS
22421 IF (ITJUNC(JS).NE.0) THEN
22422C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22423 JLEG=PYR(0)*NVSUM(JS)+1
22424 I1=JST(JS,JLEG)
22425 JST(JS,JLEG)=IGL
22426 JCT=MCT(I1,ITJUNC(JS))
22427 MCT(IGL,3-ITJUNC(JS))=JCT
22428 NCT=NCT+1
22429 MCT(IGL,ITJUNC(JS))=NCT
22430 MANTI=ITJUNC(JS)-1
22431 ELSE
22432C...Meson. Should not happen.
22433 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22434 IF(NERRPR.LT.5) THEN
22435 WRITE(MSTU(11),*) 'This should not have been possible!'
22436 CALL PYLIST(4)
22437 NERRPR=NERRPR+1
22438 ENDIF
22439 MINT(51)=1
22440 RETURN
22441 ENDIF
22442 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22443 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22444 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22445 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22446 IF (K(I2,2).NE.88) THEN
22447 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22448 ELSE
22449 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22450 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22451 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22452 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22453 ELSE
22454 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22455 ENDIF
22456 ENDIF
22457 ENDIF
22458 840 CONTINUE
22459
22460C...Remove collapsed quarks and junctions from ER and update IMI.
22461 CALL PYEDIT(11)
22462
22463C...Also update beam remnant part of IMI.
22464 NMI(1)=MINT(31)
22465 NMI(2)=MINT(31)
22466 DO 850 I=MINT(53)+1,N
22467 IF (K(I,1).LE.0) GOTO 850
22468C...Restore BR quark/diquark/baryon pointers in IMI.
22469 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22470 JS=K(I,3)-MINT(83)
22471 NMI(JS)=NMI(JS)+1
22472 IMI(JS,NMI(JS),1)=I
22473 IMI(JS,NMI(JS),2)=0
22474 ENDIF
22475 850 CONTINUE
22476
22477C...Restore companion information from collapsed gluons.
22478 DO 870 I=MINT(53)+1,N
22479 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22480 JS=K(I,3)-MINT(83)
22481 JCD=MOD(K(I,4),MSTU(5))
22482 JAD=MOD(K(I,5),MSTU(5))
22483 DO 860 IM=1,NMI(JS)
22484 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22485 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22486 860 CONTINUE
22487 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22488 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22489 ENDIF
22490 870 CONTINUE
22491
22492C...Renumber colour lines (since some have disappeared)
22493 JCT=0
22494 JCD=0
22495 880 JCT=JCT+1
22496 MFOUND=0
22497 I=MINT(84)
22498 890 I=I+1
22499 IF (I.EQ.N+1) THEN
22500 IF (MFOUND.EQ.0) JCD=JCD+1
22501 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22502 MCT(I,1)=JCT-JCD
22503 MFOUND=1
22504 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22505 MCT(I,2)=JCT-JCD
22506 MFOUND=1
22507 ENDIF
22508 IF (I.LE.N) GOTO 890
22509 IF (JCT.LT.NCT) GOTO 880
22510 NCT=JCT-JCD
22511
22512C...Reset hard interaction subsystems to their CM frames.
22513 IF (IBOOST.EQ.1) THEN
22514 DO 900 IM=1,MINT(31)
22515 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22516 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22517 900 CONTINUE
22518C...Zero beam remnant longitudinal momenta and energies
22519 DO 910 I=MINT(53)+1,N
22520 P(I,3)=0D0
22521 P(I,4)=0D0
22522 910 CONTINUE
22523 ELSE
22524 CALL PYERRM(9
22525 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22526C...Kill event and start another.
22527 MINT(51)=1
22528 RETURN
22529 ENDIF
22530
22531 9999 RETURN
22532 END
22533C*********************************************************************
22534
22535C...PYCTTR
22536C...Adapted from PYPREP.
22537C...Assigns LHA1 colour tags to coloured partons based on
22538C...K(I,4) and K(I,5) colour connection record.
22539C...KCS negative signifies that a previous tracing should be continued.
22540C...(in case the tag to be continued is empty, the routine exits)
22541C...Starts at I and ends at I or IEND.
22542C...Special considerations for systems with junctions.
22543C...Special: if IEND=-1, means trace this parton to its color partner,
22544C... then exit. If no partner found, exit with 0.
22545
22546 SUBROUTINE PYCTTR(I,KCS,IEND)
22547C...Double precision and integer declarations.
22548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22549 INTEGER PYK,PYCHGE,PYCOMP
22550C...Commonblocks.
22551 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22552 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22553 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22554 COMMON/PYINT1/MINT(400),VINT(400)
22555C...The common block of colour tags.
22556 COMMON/PYCTAG/NCT,MCT(4000,2)
22557 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
22558 DATA NERRPR/0/
22559 SAVE NERRPR
22560
22561C...Skip if parton not existing or does not have KCS
22562 IF (K(I,1).LE.0) GOTO 120
22563 KC=PYCOMP(K(I,2))
22564 IF (KC.EQ.0) GOTO 120
22565 KQ=KCHG(KC,2)
22566 IF (KQ.EQ.0) GOTO 120
22567 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
22568 & GOTO 120
22569
22570 IF (KCS.GT.0) THEN
22571 NCT=NCT+1
22572C...Set colour tag of first parton.
22573 MCT(I,KCS-3)=NCT
22574 NCS=NCT
22575 ELSE
22576 KCS=-KCS
22577 NCS=MCT(I,KCS-3)
22578 IF (NCS.EQ.0) GOTO 120
22579 ENDIF
22580
22581 IA=I
22582 NSTP=0
22583 100 NSTP=NSTP+1
22584 IF(NSTP.GT.4*N) THEN
22585 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
22586 GOTO 120
22587 ENDIF
22588
22589C...Finished if reached final-state triplet.
22590 IF(K(IA,1).EQ.3) THEN
22591 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
22592 ENDIF
22593
22594C...Also finished if reached junction.
22595 IF(K(IA,1).EQ.42) THEN
22596 GOTO 120
22597 ENDIF
22598
22599C...GOTO next parton in colour space.
22600 110 IB=IA
22601C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22602 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
22603 & .NE.0) THEN
22604 IA=MOD(K(IB,KCS),MSTU(5))
22605 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
22606 MREV=0
22607 ELSE
22608C...If KCS mother traced or KCS mother nonexistent, switch colour.
22609 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
22610 & MSTU(5)).EQ.0) THEN
22611 KCS=9-KCS
22612 NCT=NCT+1
22613 NCS=NCT
22614C...Assign new colour tag on other side of old parton.
22615 MCT(IB,KCS-3)=NCT
22616 ENDIF
22617C...Goto (new) KCS mother, set mother traced tag
22618 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
22619 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
22620 MREV=1
22621 ENDIF
22622 IF(IA.LE.0.OR.IA.GT.N) THEN
22623 IF (IEND.EQ.-1) THEN
22624 IEND=0
22625 GOTO 120
22626 ENDIF
22627 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
22628 IF(NERRPR.LT.5) THEN
22629 write(*,*) 'began at ',I
22630 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
22631 & ' NCS=',NCS,' MREV=',MREV
22632 CALL PYLIST(4)
22633 NERRPR=NERRPR+1
22634 ENDIF
22635 MINT(51)=1
22636 RETURN
22637 ENDIF
22638 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
22639 & MSTU(5)).EQ.IB) THEN
22640 IF(MREV.EQ.1) KCS=9-KCS
22641 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
22642C...Set KSC mother traced tag for IA
22643 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
22644 ELSE
22645 IF(MREV.EQ.0) KCS=9-KCS
22646 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22647C...Set KCS daughter traced tag for IA
22648 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22649 ENDIF
22650C...Assign new colour tag
22651 MCT(IA,KCS-3)=NCS
22652C...Finish if IEND=-1 and found final-state color partner
22653 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
22654 IEND=IA
22655 GOTO 120
22656 ENDIF
22657 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
22658
22659 120 RETURN
22660 END
22661
22662*********************************************************************
22663
22664C...PYMIHG
22665C...Collapse JCP1 and connecting tags to JCG1.
22666C...Collapse JCP2 and connecting tags to JCG2.
22667
22668 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22669C...Double precision and integer declarations.
22670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22671 IMPLICIT INTEGER(I-N)
22672 INTEGER PYK,PYCHGE,PYCOMP
22673C...The event record
22674 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22675C...Parameters
22676 COMMON/PYINT1/MINT(400),VINT(400)
22677 SAVE /PYJETS/,/PYINT1/
22678C...Local variables
22679 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22680 COMMON /PYCTAG/NCT,MCT(4000,2)
22681 SAVE /PYCBLS/,/PYCTAG/
22682
22683C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22684C...in temporary tag collapse array JCCN. Only break up one connection.
22685 MACCPT=1
22686 MCLPS=0
22687 DO 100 ICC=1,NCC
22688 JCCN(ICC,1)=JCCO(ICC,1)
22689 JCCN(ICC,2)=JCCO(ICC,2)
22690C...If there was a mother, it was previously connected to JCP1.
22691C...Should be changed to JCP2.
22692 IF (MCLPS.EQ.0) THEN
22693 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22694 & ,JCP2)) THEN
22695 JCCN(ICC,1)=MAX(JCG2,JCP2)
22696 JCCN(ICC,2)=MIN(JCG2,JCP2)
22697 MCLPS=1
22698 ENDIF
22699 ENDIF
22700 100 CONTINUE
22701C...Also collapse colours on JCP1 side of JCG1
22702 IF (JCP1.NE.0) THEN
22703 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22704 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22705 ELSE
22706 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22707 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22708 ENDIF
22709
22710C...Initialize event record colour tag array MCT array to MCO.
22711 DO 110 I=MINT(84)+1,N
22712 MCT(I,1)=MCO(I,1)
22713 MCT(I,2)=MCO(I,2)
22714 110 CONTINUE
22715
22716C...Collapse tags:
22717C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22718C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22719C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22720C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22721 DO 160 IS=1,4
22722C...Skip if junction.
22723 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22724C...Define starting point in tag space.
22725C...JCA = previous tag
22726C...JCO = present tag
22727C...JCN = new tag
22728 IF (MOD(IS,2).EQ.1) THEN
22729 JCO=JCP1
22730 JCN=JCG1
22731 JCALL=JCG1
22732 ELSEIF (MOD(IS,2).EQ.0) THEN
22733 JCO=JCP2
22734 JCN=JCG2
22735 JCALL=JCG2
22736 ENDIF
22737 ITRACE=0
22738 120 ITRACE=ITRACE+1
22739 IF (ITRACE.GT.1000) THEN
22740C...NB: Proper error message should be defined here.
22741 CALL PYERRM(14
22742 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22743 MINT(57)=MINT(57)+1
22744 MINT(51)=1
22745 RETURN
22746 ENDIF
22747C...Collapse all JCN tags to JCALL
22748 DO 130 I=MINT(84)+1,N
22749 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22750 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22751 130 CONTINUE
22752C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22753 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22754 JCA=JCN
22755 JCN=JCO
22756 ELSE
22757 JCA=JCO
22758 JCO=JCN
22759 ENDIF
22760C...If possible, step from JCO to new tag JCN not equal to JCA.
22761 DO 140 ICC=1,NCC+1
22762 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22763 & JCCN(ICC,2)
22764 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22765 & JCCN(ICC,1)
22766 140 CONTINUE
22767C...Iterate if new colour was arrived at, but don't go in circles.
22768 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22769C...Change all JCN tags in MCO to JCALL in MCT.
22770 DO 150 I=MINT(84)+1,N
22771 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22772 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22773C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22774 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22775 & .NE.0) MACCPT=0
22776 150 CONTINUE
22777 160 CONTINUE
22778
22779 DO 200 JCL=NCT,1,-1
22780 JCA=0
22781 JCN=JCL
22782 170 JCO=JCN
22783 DO 180 ICC=1,NCC+1
22784 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22785 & =JCCN(ICC,2)
22786 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22787 & =JCCN(ICC,1)
22788 180 CONTINUE
22789C...Overpaint all JCN with JCL
22790 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22791 DO 190 I=MINT(84)+1,N
22792 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22793 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22794C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22795 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22796 & .NE.0) MACCPT=0
22797 190 CONTINUE
22798 JCA=JCO
22799 GOTO 170
22800 ENDIF
22801 200 CONTINUE
22802
22803 RETURN
22804 END
22805
22806C*********************************************************************
22807
22808C...PYMIRM
22809C...Picks primordial kT and shares longitudinal momentum among
22810C...beam remnants.
22811
22812 SUBROUTINE PYMIRM
22813
22814C...Double precision and integer declarations.
22815 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22816 IMPLICIT INTEGER(I-N)
22817 INTEGER PYK,PYCHGE,PYCOMP
22818C...The event record
22819 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22820C...Parameters
22821 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22822 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22823 COMMON/PYINT1/MINT(400),VINT(400)
22824C...The common block of colour tags.
22825 COMMON/PYCTAG/NCT,MCT(4000,2)
22826C...The common block of dangling ends
22827 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22828 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22829 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22830 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22831C...Local variables
22832 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22833C...W(I,J)| J=0 | 1 | 2 |
22834C... I=0 | Wrem**2 | W+ | W- |
22835C... 1 | W1**2 | W1+ | W1- |
22836C... 2 | W2**2 | W2+ | W2- |
22837C...4-product
22838 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)
22839C...Tentative parametrization of <kT> as a function of Q.
22840 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22841C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22842C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22843 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22844C...Lambda kinematic function.
22845 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22846
22847C...Beginning and end of beam remnant partons
22848 NOUT=MINT(53)
22849 ISUB=MINT(1)
22850
22851C...Loopback point if kinematic choices gives impossible configuration.
22852 NTRY=0
22853 100 NTRY=NTRY+1
22854
22855C...Assign kT values on each side separately.
22856 DO 180 JS=1,2
22857
22858C...First zero all kT on this side. Skip if no kT to generate.
22859 DO 110 IM=1,NMI(JS)
22860 P(IMI(JS,IM,1),1)=0D0
22861 P(IMI(JS,IM,1),2)=0D0
22862 110 CONTINUE
22863 IF(MSTP(91).LE.0) GOTO 180
22864
22865C...Now assign kT to each (non-collapsed) parton in IMI.
22866 DO 170 IM=1,NMI(JS)
22867 I=IMI(JS,IM,1)
22868C...Select kT according to truncated gaussian or 1/kt6 tails.
22869C...For first interaction, either use rms width = PARP(91) or fitted.
22870 IF (IM.EQ.1) THEN
22871 SIGMA=PARP(91)
22872 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22873 Q=SQRT(PT2MI(IM))
22874 SIGMA=SIGPT(Q)
22875 ENDIF
22876 ELSE
22877C...For subsequent interactions and BR partons use fragmentation width.
22878 SIGMA=PARJ(21)
22879 ENDIF
22880 PHI=PARU(2)*PYR(0)
22881 PT=0D0
22882 IF(NTRY.LE.100) THEN
22883 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22884 PT=GETPT(Q,SIGMA)
22885 PTX=PT*COS(PHI)
22886 PTY=PT*SIN(PHI)
22887 ELSEIF (MSTP(91).EQ.2) THEN
22888 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22889 & 'available, using MSTP(91)=1.')
22890 CALL PYGIVE('MSTP(91)=1')
22891 GOTO 111
22892 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22893C...Use distribution with kt**6 tails, rms width = PARP(91).
22894 EPS=SQRT(3D0/2D0)*SIGMA
22895C...Generate PTX and PTY separately, each propto 1/KT**6
22896 DO 119 IXY=1,2
22897C...Decide which interval to try
22898 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22899 IF (PYR(0).LT.P12) THEN
22900C...Use flat approx with accept/reject up to EPS.
22901 PT=PYR(0)*EPS
22902 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22903 IF (PYR(0).GT.WT) GOTO 112
22904 ELSE
22905C...Above EPS, use 1/kt**6 approx with accept/reject.
22906 PT=EPS/(PYR(0)**(1D0/5D0))
22907 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22908 IF (PYR(0).GT.WT) GOTO 112
22909 ENDIF
22910 MSIGN=1
22911 IF (PYR(0).GT.0.5D0) MSIGN=-1
22912 IF (IXY.EQ.1) PTX=MSIGN*PT
22913 IF (IXY.EQ.2) PTY=MSIGN*PT
22914 119 CONTINUE
22915 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22916 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22917 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22918 ENDIF
22919C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22920 PT=SQRT(PTX**2+PTY**2)
22921 WT=1D0
22922 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22923 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22924 PTX=PTX*WT
22925 PTY=PTY*WT
22926 PT=SQRT(PTX**2+PTY**2)
22927 ENDIF
22928
22929 P(I,1)=P(I,1)+PTX
22930 P(I,2)=P(I,2)+PTY
22931
22932C...Compensation kicks, with varying degree of local anticorrelations.
22933 MCORR=MSTP(90)
22934 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22935 PTCX=-PTX/(NMI(JS)-1)
22936 PTCY=-PTY/(NMI(JS)-1)
22937 IF(ISUB.EQ.95) THEN
22938 PTCX=-PTX/(NMI(JS)-2)
22939 PTCY=-PTY/(NMI(JS)-2)
22940 ENDIF
22941 DO 120 IMC=1,NMI(JS)
22942 IF (IMC.EQ.IM) GOTO 120
22943 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22944 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22945 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22946 120 CONTINUE
22947 ELSEIF (MCORR.GE.1) THEN
22948 DO 140 MSID=4,5
22949 NNXT(MSID-3)=0
22950C...Count up # of neighbours on either side
22951 IMO=I
22952 130 IMO=K(IMO,MSID)/MSTU(5)
22953 IF (IMO.EQ.0) GOTO 140
22954 NNXT(MSID-3)=NNXT(MSID-3)+1
22955C...Stop at quarks and junctions
22956 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22957 140 CONTINUE
22958C...How should compensation be shared when unequal numbers on the
22959C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22960 NSUM=NNXT(1)+NNXT(2)
22961 T1=0
22962 DO 160 MSID=4,5
22963C...Total momentum to be compensated on this side
22964 IF (NNXT(MSID-3).EQ.0) GOTO 160
22965 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22966 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22967C...RS: compensation supression factor as we go out from parton I.
22968C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22969C...since (for now) MSTP(90) provides enough variability.
22970 RS=0.5D0
22971 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22972 IMO=I
22973 150 IDA=IMO
22974 IMO=K(IMO,MSID)/MSTU(5)
22975 IF (IMO.EQ.0) GOTO 160
22976 FAC=FAC*RS
22977 IF (K(IMO,2).NE.88) THEN
22978 P(IMO,1)=P(IMO,1)+FAC*PTCX
22979 P(IMO,2)=P(IMO,2)+FAC*PTCY
22980 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22981C...If we reach junction, divide out the kT that would have been
22982C...assigned to the junction on each of its other legs.
22983 ELSE
22984 L1=MOD(K(IMO,4),MSTU(5))
22985 L2=K(IMO,5)/MSTU(5)
22986 L3=MOD(K(IMO,5),MSTU(5))
22987 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22988 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22989 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22990 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22991 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22992 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22993 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22994 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22995 ENDIF
22996
22997 160 CONTINUE
22998 ENDIF
22999 170 CONTINUE
23000C...End assignment of kT values to initiators and remnants.
23001 180 CONTINUE
23002
23003C...Check kinematics constraints for non-BR partons.
23004 DO 190 IM=1,MINT(31)
23005 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23006 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23007 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23008 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23009 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23010 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23011 IF(NTRY.GE.100) THEN
23012C...Kill this event and start another.
23013 CALL PYERRM(1,
23014 & '(PYMIRM:) No consistent (x,kT) sets found')
23015 MINT(51)=1
23016 RETURN
23017 ENDIF
23018 GOTO 100
23019 ENDIF
23020 190 CONTINUE
23021
23022C...Calculate W+ and W- available for combined remnant system.
23023 W(0,1)=VINT(1)
23024 W(0,2)=VINT(1)
23025 DO 200 IM=1,MINT(31)
23026 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23027 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23028 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23029 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23030 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23031 200 CONTINUE
23032C...Also store Wrem**2 = W+ * W-
23033 W(0,0)=W(0,1)*W(0,2)
23034
23035 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23036 IF(NTRY.GE.100) THEN
23037C...Kill this event and start another.
23038 CALL PYERRM(1,
23039 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23040 MINT(51)=1
23041 RETURN
23042 ENDIF
23043 GOTO 100
23044 ENDIF
23045
23046C...Assign unscaled x values to partons/hadrons in each of the
23047C...beam remnants and calculate unscaled W+ and W- from them.
23048 NTRYX=0
23049 210 NTRYX=NTRYX+1
23050 DO 280 JS=1,2
23051 W(JS,1)=0D0
23052 W(JS,2)=0D0
23053 DO 270 IM=MINT(31)+1,NMI(JS)
23054 I=IMI(JS,IM,1)
23055 KF=K(I,2)
23056 KFA=IABS(KF)
23057 ICOMP=IMI(JS,IM,2)
23058
23059C...Skip collapsed gluons and junctions. Reset.
23060 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23061 IF (KFA.EQ.88) GOTO 270
23062 X=0D0
23063 IVALQ(1)=0
23064 IVALQ(2)=0
23065 ICOMQ(1)=0
23066 ICOMQ(2)=0
23067
23068C...If gluon then only beam remnant, so takes all.
23069 IF(KFA.EQ.21) THEN
23070 X=1D0
23071C...If valence quark then use parametrized valence distribution.
23072 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23073 IVALQ(1)=KF
23074C...If companion quark then derive from companion x.
23075 ELSEIF(KFA.LE.6) THEN
23076 ICOMQ(1)=ICOMP
23077C...If valence diquark then use two parametrized valence distributions.
23078 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23079 & ICOMP.EQ.0) THEN
23080 IVALQ(1)=ISIGN(KFA/1000,KF)
23081 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23082C...If valence+sea diquark then combine valence + companion choices.
23083 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23084 & ICOMP.LT.MSTU(5)) THEN
23085 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23086 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23087 ELSE
23088 IVALQ(1)=ISIGN(KFA/1000,KF)
23089 ENDIF
23090 ICOMQ(1)=ICOMP
23091C...Extra code: workaround for diquark made out of two sea
23092C...quarks, but where not (yet) ICOMP > MSTU(5).
23093 DO 220 IM1=1,MINT(31)
23094 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23095 ICOMQ(2)=IMI(JS,IM1,1)
23096 IVALQ(1)=0
23097 ENDIF
23098 220 CONTINUE
23099C...If sea diquark then sum of two derived from companion x.
23100 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23101 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23102 ICOMQ(2)=ICOMP/MSTU(5)
23103C...If meson or baryon then use fragmentation function.
23104C...Somewhat arbitrary split into old and new flavour, but OK normally.
23105 ELSE
23106 KFL3=MOD(KFA/10,10)
23107 IF(MOD(KFA/1000,10).EQ.0) THEN
23108 KFL1=MOD(KFA/100,10)
23109 ELSE
23110 KFL1=MOD(KFA,10000)-10*KFL3-1
23111 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23112 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23113 ENDIF
23114 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23115 CALL PYZDIS(KFL1,KFL3,PR,X)
23116 ENDIF
23117
23118 DO 260 IQ=1,2
23119C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23120C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23121C...In other baryons combine u and d from proton appropriately.
23122 IF(IVALQ(IQ).NE.0) THEN
23123 NVAL=0
23124 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23125 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23126 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23127C...Meson.
23128 IF(KFIVAL(JS,3).EQ.0) THEN
23129 MDU=0
23130C...Baryon with three identical quarks: mix u and d forms.
23131 ELSEIF(NVAL.EQ.3) THEN
23132 MDU=INT(PYR(0)+5D0/3D0)
23133C...Baryon, one of two identical quarks: u form.
23134 ELSEIF(NVAL.EQ.2) THEN
23135 MDU=2
23136C...Baryon with two identical quarks, but not the one picked: d form.
23137 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23138 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23139 MDU=1
23140C...Baryon with three nonidentical quarks: mix u and d forms.
23141 ELSE
23142 MDU=INT(PYR(0)+5D0/3D0)
23143 ENDIF
23144 XPOW=0.8D0
23145 IF(MDU.EQ.1) XPOW=3.5D0
23146 IF(MDU.EQ.2) XPOW=2D0
23147 230 XX=PYR(0)**2
23148 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23149 X=X+XX
23150 ENDIF
23151
23152C...Calculation of x of companion quark.
23153 IF(ICOMQ(IQ).NE.0) THEN
23154 XCOMP=1D-4
23155 DO 240 IM1=1,MINT(31)
23156 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23157 240 CONTINUE
23158 NPOW=MAX(0,MIN(4,MSTP(87)))
23159 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23160 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23161 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23162 IF(CORR.LT.PYR(0)) GOTO 250
23163 X=X+XX
23164 ENDIF
23165 260 CONTINUE
23166
23167C...Optionally enchance x of composite systems (e.g. diquarks)
23168 IF (KFA.GT.100) X=PARP(79)*X
23169
23170C...Store x. Also calculate light cone energies of each system.
23171 XMI(JS,IM)=X
23172 W(JS,JS)=W(JS,JS)+X
23173 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23174 270 CONTINUE
23175 W(JS,JS)=W(JS,JS)*W(0,JS)
23176 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23177 W(JS,0)=W(JS,1)*W(JS,2)
23178 280 CONTINUE
23179
23180C...Check W1 W2 < Wrem (can be done before rescaling, since W
23181C...insensitive to global rescalings of the BR x values).
23182 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23183 & THEN
23184 GOTO 210
23185 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23186 GOTO 100
23187 ELSEIF (NTRYX.GT.100) THEN
23188 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23189 MINT(57)=MINT(57)+1
23190 MINT(51)=1
23191 RETURN
23192 ENDIF
23193
23194C...Compute x rescaling factors
23195 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23196 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23197 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23198
23199 IF (R1.LT.0.OR.R2.LT.0) THEN
23200 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23201 MINT(57)=MINT(57)+1
23202 MINT(51)=1
23203 ENDIF
23204
23205C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23206 W(1,1)=W(1,1)*R1
23207 W(1,2)=W(1,2)/R1
23208 W(2,1)=W(2,1)/R2
23209 W(2,2)=W(2,2)*R2
23210
23211C...Rescale BR x values.
23212 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23213 XMI(1,IM)=XMI(1,IM)*R1
23214 XMI(2,IM)=XMI(2,IM)*R2
23215 290 CONTINUE
23216
23217C...Now we have a consistent set of x and kT values.
23218C...First set up the initiators and their daughters correctly.
23219 DO 300 IM=1,MINT(31)
23220 I1=IMI(1,IM,1)
23221 I2=IMI(2,IM,1)
23222 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23223 & (P(I1,2)+P(I2,2))**2
23224 PT12=P(I1,1)**2+P(I1,2)**2
23225 PT22=P(I2,1)**2+P(I2,2)**2
23226C...p_z
23227 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23228 P(I2,3)=-P(I1,3)
23229C...Energies (masses should be zero at this stage)
23230 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23231 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23232
23233C...Transverse 12 system initiator velocity:
23234 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23235 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23236C...Boost to overall initiator system rest frame
23237 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23238 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23239
23240C...Compute phi,theta coordinates of I1 and rotate z axis.
23241 PHI=PYANGL(P(I1,1),P(I1,2))
23242 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23243 IMIN=IMISEP(IM-1)+1
23244C...(include documentation lines if MI = 1)
23245 IF (IM.EQ.1) IMIN=MINT(83)+5
23246 IMAX=IMISEP(IM)
23247C...Rotate entire system in phi
23248 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23249C...Only rotate 12 system in theta
23250 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23251 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23252
23253C...Now boost entire system back to LAB
23254 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23255 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23256 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23257
23258 300 CONTINUE
23259
23260
23261C...For the beam remnant partons/hadrons, we only need to set pz and E.
23262 DO 320 JS=1,2
23263 DO 310 IM=MINT(31)+1,NMI(JS)
23264 I=IMI(JS,IM,1)
23265C...Skip collapsed gluons and junctions.
23266 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23267 IF (KFA.EQ.88) GOTO 310
23268 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23269 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23270 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23271 IF (JS.EQ.2) P(I,3)=-P(I,3)
23272 310 CONTINUE
23273 320 CONTINUE
23274
23275
23276C...Documentation lines
23277 DO 340 JS=1,2
23278 IN=MINT(83)+JS+2
23279 IO=IMI(JS,1,1)
23280 K(IN,1)=21
23281 K(IN,2)=K(IO,2)
23282 K(IN,3)=MINT(83)+JS
23283 K(IN,4)=0
23284 K(IN,5)=0
23285 DO 330 J=1,5
23286 P(IN,J)=P(IO,J)
23287 V(IN,J)=V(IO,J)
23288 330 CONTINUE
23289 MCT(IN,1)=MCT(IO,1)
23290 MCT(IN,2)=MCT(IO,2)
23291 340 CONTINUE
23292
23293C...Final state colour reconnections.
23294 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23295
23296C...Number of colour tags for which a recoupling will be tried.
23297 NTOT=NCT
23298C...Number of recouplings to try
23299 MINT(34)=0
23300 NRECP=0
23301 NITER=0
23302 350 NRECP=MINT(34)
23303 NITER=NITER+1
23304 IITER=0
23305 360 IITER=IITER+1
23306 IF (IITER.LE.PARP(78)*NTOT) THEN
23307C...Select two colour tags at random
23308C...NB: jj strings do not have colour tags assigned to them,
23309C...thus they are as yet not affected by anything done here.
23310 JCT=PYR(0)*NCT+1
23311 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23312 IJ1=0
23313 IJ2=0
23314 IK1=0
23315 IK2=0
23316C...Find final state partons with this (anti)colour
23317 DO 370 I=MINT(84)+1,N
23318 IF (K(I,1).EQ.3) THEN
23319 IF (MCT(I,1).EQ.JCT) IJ1=I
23320 IF (MCT(I,2).EQ.JCT) IJ2=I
23321 IF (MCT(I,1).EQ.KCT) IK1=I
23322 IF (MCT(I,2).EQ.KCT) IK2=I
23323 ENDIF
23324 370 CONTINUE
23325C...Only consider recouplings not involving junctions for now.
23326 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23327
23328 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23329 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23330 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23331 MCT(IJ2,2)=KCT
23332 MCT(IK2,2)=JCT
23333C...Count up number of reconnections
23334 MINT(34)=MINT(34)+1
23335 ENDIF
23336 IF (MINT(34).LE.1000) THEN
23337 GOTO 360
23338 ELSE
23339 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23340 GOTO 380
23341 ENDIF
23342 ENDIF
23343 IF (NRECP.LT.MINT(34)) GOTO 350
23344
23345C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23346 380 MINT(33)=1
23347
23348 RETURN
23349 END
23350
23351C*********************************************************************
23352
23353C...PYFSCR
23354C...Performs colour annealing.
23355C...MSTP(95) : CR Type
23356C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23357C... = 2 : Type I(no gg loops); hadron-hadron only
23358C... = 3 : Type I(no gg loops); all beams
23359C... = 4 : Type II(gg loops) ; hadron-hadron only
23360C... = 5 : Type II(gg loops) ; all beams
23361C... = 6 : Type S ; hadron-hadron only
23362C... = 7 : Type S ; all beams
23363C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23364C...Type S is driven by starting only from free triplets, not octets.
23365C...A string piece remains unchanged with probability
23366C... PKEEP = (1-PARP(78))**N
23367C...This scaling corresponds to each string piece having to go through
23368C...N other ones, each with probability PARP(78) for reconnection, where
23369C...N is here chosen simply as the number of multiple interactions,
23370C...for a rough scaling with the general level of activity.
23371
23372 SUBROUTINE PYFSCR(IP)
23373C...Double precision and integer declarations.
23374 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23375 INTEGER PYK,PYCHGE,PYCOMP
23376C...Commonblocks.
23377 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23378 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23379 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23380 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23381 COMMON/PYINT1/MINT(400),VINT(400)
23382C...The common block of colour tags.
23383 COMMON/PYCTAG/NCT,MCT(4000,2)
23384 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23385 &/PYPARS/
23386C...MCN: Temporary storage of new colour tags
23387 INTEGER MCN(4000,2)
23388C...Arrays for storing color string lengths
23389 INTEGER ICR(4000),MSCR(4000)
23390 INTEGER IOPT(4000)
23391 DOUBLE PRECISION RLOPTC(4000)
23392
23393C...Function to give four-product.
23394 FOUR(I,J)=P(I,4)*P(J,4)
23395 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23396
23397C...Check valid range of MSTP(95), local copy
23398 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23399 MSTP95=MOD(MSTP(95),10)
23400C...Set whether CR allowed inside resonance systems or not
23401C...(not implemented yet)
23402C MRESCR=1
23403C IF (MSTP(95).GE.10) MRESCR=0
23404
23405C...Check whether colour tags already defined
23406 IF (MINT(33).EQ.0) THEN
23407C...Erase any existing colour tags for this event
23408 DO 100 I=1,N
23409 MCT(I,1)=0
23410 MCT(I,2)=0
23411 100 CONTINUE
23412C...Create colour tags for this event
23413 DO 120 I=1,N
23414 IF (K(I,1).EQ.3) THEN
23415 DO 110 KCS=4,5
23416 KCSIN=KCS
23417 IF (MCT(I,KCSIN-3).EQ.0) THEN
23418 CALL PYCTTR(I,KCSIN,I)
23419 ENDIF
23420 110 CONTINUE
23421 ENDIF
23422 120 CONTINUE
23423C...Instruct PYPREP to use colour tags
23424 MINT(33)=1
23425 ENDIF
23426
23427C...For MSTP(95) even, only apply to hadron-hadron
23428 KA1=IABS(MINT(11))
23429 KA2=IABS(MINT(12))
23430 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23431
23432C...Initialize new tag array (but do not delete old yet)
23433 LCT=NCT
23434 DO 130 I=MAX(1,IP),N
23435 MCN(I,1)=0
23436 MCN(I,2)=0
23437 130 CONTINUE
23438
23439C...For each final-state dipole, check whether string should be
23440C...preserved.
23441 NCR=0
23442 IA=0
23443 IC=0
23444
23445 DO 150 ICT=1,NCT
23446 IA=0
23447 IC=0
23448 DO 140 I=MAX(1,IP),N
23449 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23450 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23451 140 CONTINUE
23452 IF (IC.NE.0.AND.IA.NE.0) THEN
23453 CRMODF=1D0
23454C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23455C...(so far ignores the possibility that the whole "muck" may be moving.)
23456 IF (PARP(77).GT.0D0) THEN
23457 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
23458C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23459 IF (KA1.LT.100.AND.KA2.LT.100) THEN
23460 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
23461 ELSE
23462 P2STR = 3D0/2D0 * PT2STR
23463 ENDIF
23464 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
23465 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
23466C...Estimate number of particles ~ log(M2), cut off at 1.
23467 RLOGM2=MAX(1D0,LOG(RM2STR))
23468 P2AVG=P2STR/RLOGM2
23469C...Supress reconnection probability by 1/(1+P77*P2AVG)
23470 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
23471 ENDIF
23472 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
23473 IF (PYR(0).LE.PKEEP) THEN
23474 LCT=LCT+1
23475 MCN(IC,1)=LCT
23476 MCN(IA,2)=LCT
23477 ELSE
23478C...Add coloured parton
23479 NCR=NCR+1
23480 ICR(NCR)=IC
23481 MSCR(NCR)=1
23482 IOPT(NCR)=0
23483 RLOPTC(NCR)=1D19
23484C...Add anti-coloured parton
23485 NCR=NCR+1
23486 ICR(NCR)=IA
23487 MSCR(NCR)=2
23488 IOPT(NCR)=0
23489 RLOPTC(NCR)=1D19
23490 ENDIF
23491 ENDIF
23492 150 CONTINUE
23493
23494C...Skip if there is only one possibility
23495 IF (NCR.LE.2) THEN
23496 GOTO 9999
23497 ENDIF
23498
23499C...Reorder, so ordered in I (in order to correspond to old algorithm)
23500 NLOOP=0
23501 151 NLOOP=NLOOP+1
23502 MORD=1
23503 DO 155 IC1=1,NCR-1
23504 I1=ICR(IC1)
23505 I2=ICR(IC1+1)
23506 IF (I1.GT.I2) THEN
23507 IT=I1
23508 MST=MSCR(IC1)
23509 ICR(IC1)=I2
23510 MSCR(IC1)=MSCR(IC1+1)
23511 ICR(IC1+1)=IT
23512 MSCR(IC1+1)=MST
23513 MORD=0
23514 ENDIF
23515 155 CONTINUE
23516C...Max do 1000 reordering loops
23517 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
23518
23519C...Loop over CR partons
23520C...(Ignore junctions for now.)
23521 NLOOP=0
23522 160 NLOOP=NLOOP+1
23523 RLMAX=0D0
23524 ICRMAX=0
23525C...Loop over coloured partons
23526 DO 230 IC1=1,NCR
23527C...Retrieve parton Event Record index and Colour Side
23528 I=ICR(IC1)
23529 MSI=MSCR(IC1)
23530C...Skip already connected partons
23531 IF (MCN(I,MSI).NE.0) GOTO 230
23532C...Shorthand for colour charge
23533 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23534C...For Seattle algorithm, only start from partons with one dangling
23535C...colour tag
23536 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
23537 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
23538 ENDIF
23539C...Retrieve saved optimal partner
23540 IO=IOPT(IC1)
23541 IF (IO.NE.0) THEN
23542C...Reject saved optimal partner if latter is now connected
23543C...(Also reject if using model S1, since saved partner may
23544C...now give rise to gg loop.)
23545 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
23546 IOPT(IC1)=0
23547 RLOPTC(IC1)=1D19
23548 ENDIF
23549 ENDIF
23550 RLOPT=RLOPTC(IC1)
23551C...Search for new optimal partner if necessary
23552 IF (IOPT(IC1).EQ.0) THEN
23553 MBROPT=0
23554 MGGOPT=0
23555 RLOPT=1D19
23556C...Loop over partons you can connect to
23557 DO 210 IC2=1,NCR
23558 J=ICR(IC2)
23559 MSJ=MSCR(IC2)
23560C...Skip if already connected
23561 IF (MCN(J,MSJ).NE.0) GOTO 210
23562C...Skip if this not colour-anticolour pair
23563 IF (MSI.EQ.MSJ) GOTO 210
23564C...And do not let gluons connect to themselves
23565 IF (I.EQ.J) GOTO 210
23566C...Suppress direct connections between partons in same Beam Remnant
23567 MBRSTR=0
23568 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
23569 & MBRSTR=1
23570C...Shorthand for colour charge
23571 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
23572C...Check for gluon loops
23573 MGGSTR=0
23574 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
23575 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
23576 & MCN(I,2).NE.0) MGGSTR=1
23577 ENDIF
23578C...Save connection with smallest lambda measure
23579 RL=FOUR(I,J)
23580C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23581 IF (MSTP(95).GE.7.AND.MSTP(95).LE.8) THEN
23582 IF (K(I,2).EQ.21) RL=0.5D0*RL
23583 IF (K(J,2).EQ.21) RL=0.5D0*RL
23584 ENDIF
23585C...If best so far was a BR string and this is not, also save.
23586C...If best so far was a gg string and this is not, also save.
23587C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23588C...string with a small Lambda measure as the last step, this connection
23589C...will be saved regardless of whether other possibilities existed.
23590C...I.e., there should really be a check whether another possibility has
23591C...already been found, but since these models are now actively in use
23592C...and uncertainties are anyway large, the algorithm is left as it is.
23593C...(correction --> Pythia 8 ?)
23594 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
23595 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
23596 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
23597 RLOPT=RL
23598 RLOPTC(IC1)=RLOPT
23599 IOPT(IC1)=J
23600 MBROPT=MBRSTR
23601 MGGOPT=MGGSTR
23602 ENDIF
23603 210 CONTINUE
23604 ENDIF
23605 IF (IOPT(IC1).NE.0) THEN
23606C...Save pair with largest RLOPT so far
23607 IF (RLOPT.GE.RLMAX) THEN
23608 ICRMAX=IC1
23609 RLMAX=RLOPT
23610 ENDIF
23611 ENDIF
23612 230 CONTINUE
23613C...Save and iterate
23614 IF (ICRMAX.GT.0) THEN
23615 LCT=LCT+1
23616 ILMAX=ICR(ICRMAX)
23617 JLMAX=IOPT(ICRMAX)
23618 ICMAX=MSCR(ICRMAX)
23619 JCMAX=3-ICMAX
23620 MCN(ILMAX,ICMAX)=LCT
23621 MCN(JLMAX,JCMAX)=LCT
23622 IF (NLOOP.LE.2*(N-IP)) THEN
23623 GOTO 160
23624 ELSE
23625 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
23626 CALL PYSTOP(11)
23627 ENDIF
23628 ELSE
23629C...Save and exit. First check for leftover gluon(s)
23630 DO 260 I=MAX(1,IP),N
23631C...Check colour charge
23632 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23633 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
23634 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
23635C...Decide where to put left-over gluon (minimal insertion)
23636 ILMAX=0
23637 RLMAX=1D19
23638 DO 250 KCT=NCT+1,LCT
23639 DO 240 IT=MAX(1,IP),N
23640 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
23641 IF (MCN(IT,1).EQ.KCT) IC=IT
23642 IF (MCN(IT,2).EQ.KCT) IA=IT
23643 240 CONTINUE
23644 RL=FOUR(IC,I)*FOUR(IA,I)
23645 IF (RL.LT.RLMAX) THEN
23646 RLMAX=RL
23647 ICMAX=IC
23648 IAMAX=IA
23649 ENDIF
23650 250 CONTINUE
23651 LCT=LCT+1
23652 MCN(I,1)=MCN(ICMAX,1)
23653 MCN(I,2)=LCT
23654 MCN(ICMAX,1)=LCT
23655 ENDIF
23656 260 CONTINUE
23657C...Here we need to loop over entire event.
23658 DO 270 IZ=MAX(1,IP),N
23659C...Do not erase parton shower colour history
23660 IF (K(IZ,1).NE.3) GOTO 270
23661C...Check colour charge
23662 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
23663 IF (MCI.EQ.0) GOTO 270
23664 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
23665 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
23666 270 CONTINUE
23667 ENDIF
23668
23669 9999 RETURN
23670 END
23671
23672C*********************************************************************
23673
23674C...PYDIFF
23675C...Handles diffractive and elastic scattering.
23676
23677 SUBROUTINE PYDIFF
23678
23679C...Double precision and integer declarations.
23680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23681 IMPLICIT INTEGER(I-N)
23682 INTEGER PYK,PYCHGE,PYCOMP
23683C...Commonblocks.
23684 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23685 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23686 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23687 COMMON/PYINT1/MINT(400),VINT(400)
23688 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
23689
23690C...Reset K, P and V vectors. Store incoming particles.
23691 DO 110 JT=1,MSTP(126)+10
23692 I=MINT(83)+JT
23693 DO 100 J=1,5
23694 K(I,J)=0
23695 P(I,J)=0D0
23696 V(I,J)=0D0
23697 100 CONTINUE
23698 110 CONTINUE
23699 N=MINT(84)
23700 MINT(3)=0
23701 MINT(21)=0
23702 MINT(22)=0
23703 MINT(23)=0
23704 MINT(24)=0
23705 MINT(4)=4
23706 DO 130 JT=1,2
23707 I=MINT(83)+JT
23708 K(I,1)=21
23709 K(I,2)=MINT(10+JT)
23710 DO 120 J=1,5
23711 P(I,J)=VINT(285+5*JT+J)
23712 120 CONTINUE
23713 130 CONTINUE
23714 MINT(6)=2
23715
23716C...Subprocess; kinematics.
23717 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23718 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23719 DO 200 JT=1,2
23720 I=MINT(83)+JT
23721 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23722 KFH=MINT(102+JT)
23723
23724C...Elastically scattered particle. (Except elastic GVMD states.)
23725 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23726 & MINT(106+JT).NE.3)) THEN
23727 N=N+1
23728 K(N,1)=1
23729 K(N,2)=KFH
23730 K(N,3)=I+2
23731 P(N,3)=PZ*(-1)**(JT+1)
23732 P(N,4)=PE
23733 P(N,5)=SQRT(VINT(62+JT))
23734
23735C...Decay rho from elastic scattering of gamma with sin**2(theta)
23736C...distribution of decay products (in rho rest frame).
23737 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23738 NSAV=N
23739 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23740 P(N,3)=0D0
23741 P(N,4)=P(N,5)
23742 CALL PYDECY(NSAV)
23743 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23744 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23745 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23746 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23747 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23748 140 CTHE=2D0*PYR(0)-1D0
23749 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23750 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23751 ENDIF
23752 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23753 ENDIF
23754
23755C...Diffracted particle: low-mass system to two particles.
23756 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23757 N=N+2
23758 K(N-1,1)=1
23759 K(N,1)=1
23760 K(N-1,3)=I+2
23761 K(N,3)=I+2
23762 PMMAS=SQRT(VINT(62+JT))
23763 NTRY=0
23764 150 NTRY=NTRY+1
23765 IF(NTRY.LT.20) THEN
23766 MINT(105)=MINT(102+JT)
23767 MINT(109)=MINT(106+JT)
23768 CALL PYSPLI(KFH,21,KFL1,KFL2)
23769 CALL PYKFDI(KFL1,0,KFL3,KF1)
23770 IF(KF1.EQ.0) GOTO 150
23771 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23772 IF(KF2.EQ.0) GOTO 150
23773 ELSE
23774 KF1=KFH
23775 KF2=111
23776 ENDIF
23777 PM1=PYMASS(KF1)
23778 PM2=PYMASS(KF2)
23779 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23780 K(N-1,2)=KF1
23781 K(N,2)=KF2
23782 P(N-1,5)=PM1
23783 P(N,5)=PM2
23784 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23785 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23786 P(N-1,3)=PZP
23787 P(N,3)=-PZP
23788 P(N-1,4)=SQRT(PM1**2+PZP**2)
23789 P(N,4)=SQRT(PM2**2+PZP**2)
23790 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23791 & 0D0,0D0,0D0)
23792 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23793 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23794
23795C...Diffracted particle: valence quark kicked out.
23796 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23797 & PARP(101))) THEN
23798 N=N+2
23799 K(N-1,1)=2
23800 K(N,1)=1
23801 K(N-1,3)=I+2
23802 K(N,3)=I+2
23803 MINT(105)=MINT(102+JT)
23804 MINT(109)=MINT(106+JT)
23805 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23806 P(N-1,5)=PYMASS(K(N-1,2))
23807 P(N,5)=PYMASS(K(N,2))
23808 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23809 & 4D0*P(N-1,5)**2*P(N,5)**2
23810 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23811 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23812 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23813 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23814 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23815
23816C...Diffracted particle: gluon kicked out.
23817 ELSE
23818 N=N+3
23819 K(N-2,1)=2
23820 K(N-1,1)=2
23821 K(N,1)=1
23822 K(N-2,3)=I+2
23823 K(N-1,3)=I+2
23824 K(N,3)=I+2
23825 MINT(105)=MINT(102+JT)
23826 MINT(109)=MINT(106+JT)
23827 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23828 K(N-1,2)=21
23829 P(N-2,5)=PYMASS(K(N-2,2))
23830 P(N-1,5)=0D0
23831 P(N,5)=PYMASS(K(N,2))
23832C...Energy distribution for particle into two jets.
23833 160 IMB=1
23834 IF(MOD(KFH/1000,10).NE.0) IMB=2
23835 CHIK=PARP(92+2*IMB)
23836 IF(MSTP(92).LE.1) THEN
23837 IF(IMB.EQ.1) CHI=PYR(0)
23838 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23839 ELSEIF(MSTP(92).EQ.2) THEN
23840 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23841 ELSEIF(MSTP(92).EQ.3) THEN
23842 CUT=2D0*0.3D0/VINT(1)
23843 170 CHI=PYR(0)**2
23844 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23845 & PYR(0)) GOTO 170
23846 ELSEIF(MSTP(92).EQ.4) THEN
23847 CUT=2D0*0.3D0/VINT(1)
23848 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23849 180 CHIR=CUT*CUTR**PYR(0)
23850 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23851 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23852 ELSE
23853 CUT=2D0*0.3D0/VINT(1)
23854 CUTA=CUT**(1D0-PARP(98))
23855 CUTB=(1D0+CUT)**(1D0-PARP(98))
23856 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23857 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23858 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23859 ENDIF
23860 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23861 & VINT(62+JT)) GOTO 160
23862 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23863 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23864 & (2D0*VINT(62+JT))
23865 PEI=SQRT(PZI**2+SQM)
23866 PQQP=(1D0-CHI)*(PEI+PZI)
23867 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23868 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23869 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23870 P(N-1,3)=P(N-1,4)*(-1)**JT
23871 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23872 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23873 ENDIF
23874
23875C...Documentation lines.
23876 K(I+2,1)=21
23877 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23878 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23879 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23880 K(I+2,3)=I
23881 P(I+2,3)=PZ*(-1)**(JT+1)
23882 P(I+2,4)=PE
23883 P(I+2,5)=SQRT(VINT(62+JT))
23884 200 CONTINUE
23885
23886C...Rotate outgoing partons/particles using cos(theta).
23887 IF(VINT(23).LT.0.9D0) THEN
23888 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23889 ELSE
23890 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23891 ENDIF
23892
23893 RETURN
23894 END
23895
23896C*********************************************************************
23897
23898C...PYDISG
23899C...Set up a DIS process as gamma* + f -> f, with beam remnant
23900C...and showering added consecutively. Photon flux by the PYGAGA
23901C...routine (if at all).
23902
23903 SUBROUTINE PYDISG
23904
23905C...Double precision and integer declarations.
23906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23907 IMPLICIT INTEGER(I-N)
23908 INTEGER PYK,PYCHGE,PYCOMP
23909C...Parameter statement to help give large particle numbers.
23910 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23911 &KEXCIT=4000000,KDIMEN=5000000)
23912C...Commonblocks.
23913 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23914 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23915 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23916 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23917 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23918 COMMON/PYINT1/MINT(400),VINT(400)
23919 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23920C...Local arrays.
23921 DIMENSION PMS(4)
23922
23923C...Choice of subprocess, number of documentation lines
23924 IDOC=7
23925 MINT(3)=IDOC-6
23926 MINT(4)=IDOC
23927 IPU1=MINT(84)+1
23928 IPU2=MINT(84)+2
23929 IPU3=MINT(84)+3
23930 ISIDE=1
23931 IF(MINT(107).EQ.4) ISIDE=2
23932
23933C...Reset K, P and V vectors. Store incoming particles
23934 DO 110 JT=1,MSTP(126)+20
23935 I=MINT(83)+JT
23936 DO 100 J=1,5
23937 K(I,J)=0
23938 P(I,J)=0D0
23939 V(I,J)=0D0
23940 100 CONTINUE
23941 110 CONTINUE
23942 DO 130 JT=1,2
23943 I=MINT(83)+JT
23944 K(I,1)=21
23945 K(I,2)=MINT(10+JT)
23946 DO 120 J=1,5
23947 P(I,J)=VINT(285+5*JT+J)
23948 120 CONTINUE
23949 130 CONTINUE
23950 MINT(6)=2
23951
23952C...Store incoming partons in hadronic CM-frame
23953 DO 140 JT=1,2
23954 I=MINT(84)+JT
23955 K(I,1)=14
23956 K(I,2)=MINT(14+JT)
23957 K(I,3)=MINT(83)+2+JT
23958 140 CONTINUE
23959 IF(MINT(15).EQ.22) THEN
23960 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23961 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23962 P(MINT(84)+1,5)=-SQRT(VINT(307))
23963 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23964 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23965 KFRES=MINT(16)
23966 ISIDE=2
23967 ELSE
23968 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23969 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23970 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23971 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23972 P(MINT(84)+1,5)=-SQRT(VINT(308))
23973 KFRES=MINT(15)
23974 ISIDE=1
23975 ENDIF
23976 SIDESG=(-1D0)**(ISIDE-1)
23977
23978C...Copy incoming partons to documentation lines.
23979 DO 170 JT=1,2
23980 I1=MINT(83)+4+JT
23981 I2=MINT(84)+JT
23982 K(I1,1)=21
23983 K(I1,2)=K(I2,2)
23984 K(I1,3)=I1-2
23985 DO 150 J=1,5
23986 P(I1,J)=P(I2,J)
23987 150 CONTINUE
23988
23989C...Second copy for partons before ISR shower, since no such.
23990 I1=MINT(83)+2+JT
23991 K(I1,1)=21
23992 K(I1,2)=K(I2,2)
23993 K(I1,3)=I1-2
23994 DO 160 J=1,5
23995 P(I1,J)=P(I2,J)
23996 160 CONTINUE
23997 170 CONTINUE
23998
23999C...Define initial partons.
24000 NTRY=0
24001 180 NTRY=NTRY+1
24002 IF(NTRY.GT.100) THEN
24003 MINT(51)=1
24004 RETURN
24005 ENDIF
24006
24007C...Scattered quark in hadronic CM frame.
24008 I=MINT(83)+7
24009 K(IPU3,1)=3
24010 K(IPU3,2)=KFRES
24011 K(IPU3,3)=I
24012 P(IPU3,5)=PYMASS(KFRES)
24013 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24014 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24015 P(IPU3,5)=0D0
24016 K(I,1)=21
24017 K(I,2)=KFRES
24018 K(I,3)=MINT(83)+4+ISIDE
24019 P(I,3)=P(IPU3,3)
24020 P(I,4)=P(IPU3,4)
24021 P(I,5)=P(IPU3,5)
24022 N=IPU3
24023 MINT(21)=KFRES
24024 MINT(22)=0
24025
24026C...No primordial kT, or chosen according to truncated Gaussian or
24027C...exponential, or (for photon) predetermined or power law.
24028 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24029 IF(MSTP(91).LE.0) THEN
24030 PT=0D0
24031 ELSEIF(MSTP(91).EQ.1) THEN
24032 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24033 ELSE
24034 RPT1=PYR(0)
24035 RPT2=PYR(0)
24036 PT=-PARP(92)*LOG(RPT1*RPT2)
24037 ENDIF
24038 IF(PT.GT.PARP(93)) GOTO 190
24039 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24040 PTA=SQRT(VINT(282+ISIDE))
24041 PTB=0D0
24042 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24043 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24044 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24045 RPT1=PYR(0)
24046 RPT2=PYR(0)
24047 PTB=-PARP(99)*LOG(RPT1*RPT2)
24048 ENDIF
24049 IF(PTB.GT.PARP(100)) GOTO 190
24050 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24051 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24052 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24053 IF(MSTP(93).LE.0) THEN
24054 PT=0D0
24055 ELSEIF(MSTP(93).EQ.1) THEN
24056 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24057 ELSEIF(MSTP(93).EQ.2) THEN
24058 RPT1=PYR(0)
24059 RPT2=PYR(0)
24060 PT=-PARP(99)*LOG(RPT1*RPT2)
24061 ELSEIF(MSTP(93).EQ.3) THEN
24062 HA=PARP(99)**2
24063 HB=PARP(100)**2
24064 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24065 ELSE
24066 HA=PARP(99)**2
24067 HB=PARP(100)**2
24068 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24069 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24070 ENDIF
24071 IF(PT.GT.PARP(100)) GOTO 190
24072 ELSE
24073 PT=0D0
24074 ENDIF
24075 VINT(156+ISIDE)=PT
24076 PHI=PARU(2)*PYR(0)
24077 P(IPU3,1)=PT*COS(PHI)
24078 P(IPU3,2)=PT*SIN(PHI)
24079 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24080 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24081 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24082
24083C...Find one or two beam remnants.
24084 MINT(105)=MINT(102+ISIDE)
24085 MINT(109)=MINT(106+ISIDE)
24086 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24087 IF(MINT(51).NE.0) THEN
24088 MINT(51)=0
24089 GOTO 180
24090 ENDIF
24091
24092C...Store first remnant parton, with colour info and kinematics.
24093 I=N+1
24094 K(I,1)=1
24095 K(I,2)=KFLSP
24096 K(I,3)=MINT(83)+ISIDE
24097 P(I,5)=PYMASS(K(I,2))
24098 KCOL=KCHG(PYCOMP(KFLSP),2)
24099 IF(KCOL.NE.0) THEN
24100 K(I,1)=3
24101 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24102 K(I,KFLS+3)=MSTU(5)*IPU3
24103 K(IPU3,6-KFLS)=MSTU(5)*I
24104 ICOLR=I
24105 ENDIF
24106 IF(KFLCH.EQ.0) THEN
24107 P(I,1)=-P(IPU3,1)
24108 P(I,2)=-P(IPU3,2)
24109 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24110 P(I,3)=-P(IPU3,3)
24111 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24112 PRP=P(I,4)+ABS(P(I,3))
24113
24114C...When extra remnant parton or hadron: store extra remnant.
24115 ELSE
24116 I=I+1
24117 K(I,1)=1
24118 K(I,2)=KFLCH
24119 K(I,3)=MINT(83)+ISIDE
24120 P(I,5)=PYMASS(K(I,2))
24121 KCOL=KCHG(PYCOMP(KFLCH),2)
24122 IF(KCOL.NE.0) THEN
24123 K(I,1)=3
24124 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24125 K(I,KFLS+3)=MSTU(5)*IPU3
24126 K(IPU3,6-KFLS)=MSTU(5)*I
24127 ICOLR=I
24128 ENDIF
24129
24130C...Relative transverse momentum when two remnants.
24131 LOOP=0
24132 200 LOOP=LOOP+1
24133 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24134 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24135 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24136 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24137 P(I,1)=-P(IPU3,1)-P(I-1,1)
24138 P(I,2)=-P(IPU3,2)-P(I-1,2)
24139 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24140
24141C...Relative distribution of energy for particle into jet plus particle.
24142 IMB=1
24143 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24144 IF(MSTP(94).LE.1) THEN
24145 IF(IMB.EQ.1) CHI=PYR(0)
24146 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24147 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24148 ELSEIF(MSTP(94).EQ.2) THEN
24149 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24150 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24151 ELSEIF(MSTP(94).EQ.3) THEN
24152 CALL PYZDIS(1,0,PMS(4),ZZ)
24153 CHI=ZZ
24154 ELSE
24155 CALL PYZDIS(1000,0,PMS(4),ZZ)
24156 CHI=ZZ
24157 ENDIF
24158
24159C...Construct total transverse mass; reject if too large.
24160 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24161 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24162 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24163 IF(LOOP.LT.10) GOTO 200
24164 GOTO 180
24165 ENDIF
24166 VINT(158+ISIDE)=CHI
24167
24168C...Subdivide longitudinal momentum according to value selected above.
24169 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24170 PW1=(1D0-CHI)*PRP
24171 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24172 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24173 PW2=CHI*PRP
24174 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24175 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24176 ENDIF
24177 N=I
24178
24179C...Boost current and remnant systems to correct frame.
24180 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24181 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24182 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24183 &(2D0*VINT(1)*PCP)
24184 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24185 &(2D0*VINT(1)*PRP)
24186 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24187 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24188 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24189 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24190
24191C...Let current quark shower; recoil but no showering by colour partner.
24192 QMAX=2D0*SQRT(VINT(309-ISIDE))
24193 MSTJ48=MSTJ(48)
24194 MSTJ(48)=1
24195 PARJ86=PARJ(86)
24196 PARJ(86)=0D0
24197 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24198 MSTJ(48)=MSTJ48
24199 PARJ(86)=PARJ86
24200
24201 RETURN
24202 END
24203
24204C*********************************************************************
24205
24206C...PYDOCU
24207C...Handles the documentation of the process in MSTI and PARI,
24208C...and also computes cross-sections based on accumulated statistics.
24209
24210 SUBROUTINE PYDOCU
24211
24212C...Double precision and integer declarations.
24213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24214 IMPLICIT INTEGER(I-N)
24215 INTEGER PYK,PYCHGE,PYCOMP
24216C...Commonblocks.
24217 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24218 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24219 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24220 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24221 COMMON/PYINT1/MINT(400),VINT(400)
24222 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24223 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24224 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24225 &/PYINT5/
24226
24227C...Calculate Monte Carlo estimates of cross-sections.
24228 ISUB=MINT(1)
24229 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24230 NGEN(0,3)=NGEN(0,3)+1
24231 XSEC(0,3)=0D0
24232 DO 100 I=1,500
24233 IF(I.EQ.96.OR.I.EQ.97) THEN
24234 XSEC(I,3)=0D0
24235 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24236 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24237 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24238 & DBLE(NGEN(96,2)))
24239 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24240 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24241 & DBLE(NGEN(96,2)))
24242 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24243 XSEC(I,3)=0D0
24244 ELSEIF(NGEN(I,2).EQ.0) THEN
24245 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24246 & DBLE(NGEN(0,2)))
24247 ELSE
24248 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24249 & DBLE(NGEN(I,2)))
24250 ENDIF
24251 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24252 100 CONTINUE
24253
24254C...Rescale to known low-pT cross-section for standard QCD processes.
24255 IF(MSUB(95).EQ.1) THEN
24256 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24257 & XSEC(68,3)+XSEC(95,3)
24258 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24259 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24260 FAC=XSECW/XSECH
24261 XSEC(11,3)=FAC*XSEC(11,3)
24262 XSEC(12,3)=FAC*XSEC(12,3)
24263 XSEC(13,3)=FAC*XSEC(13,3)
24264 XSEC(28,3)=FAC*XSEC(28,3)
24265 XSEC(53,3)=FAC*XSEC(53,3)
24266 XSEC(68,3)=FAC*XSEC(68,3)
24267 XSEC(95,3)=FAC*XSEC(95,3)
24268 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24269 ENDIF
24270 ENDIF
24271
24272C...Save information for gamma-p and gamma-gamma.
24273 IF(MINT(121).GT.1) THEN
24274 IGA=MINT(122)
24275 CALL PYSAVE(2,IGA)
24276 CALL PYSAVE(5,0)
24277 ENDIF
24278
24279C...Reset information on hard interaction.
24280 DO 110 J=1,200
24281 MSTI(J)=0
24282 PARI(J)=0D0
24283 110 CONTINUE
24284
24285C...Copy integer valued information from MINT into MSTI.
24286 DO 120 J=1,32
24287 MSTI(J)=MINT(J)
24288 120 CONTINUE
24289 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24290
24291C...Store cross-section variables in PARI.
24292 PARI(1)=XSEC(0,3)
24293 PARI(2)=XSEC(0,3)/MINT(5)
24294 PARI(7)=VINT(97)
24295 PARI(9)=VINT(99)
24296 PARI(10)=VINT(100)
24297 VINT(98)=VINT(98)+VINT(100)
24298 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24299
24300C...Store kinematics variables in PARI.
24301 PARI(11)=VINT(1)
24302 PARI(12)=VINT(2)
24303 IF(ISUB.NE.95) THEN
24304 DO 130 J=13,26
24305 PARI(J)=VINT(30+J)
24306 130 CONTINUE
24307 PARI(29)=VINT(39)
24308 PARI(30)=VINT(40)
24309 PARI(31)=VINT(141)
24310 PARI(32)=VINT(142)
24311 PARI(33)=VINT(41)
24312 PARI(34)=VINT(42)
24313 PARI(35)=PARI(33)-PARI(34)
24314 PARI(36)=VINT(21)
24315 PARI(37)=VINT(22)
24316 PARI(38)=VINT(26)
24317 PARI(39)=VINT(157)
24318 PARI(40)=VINT(158)
24319 PARI(41)=VINT(23)
24320 PARI(42)=2D0*VINT(47)/VINT(1)
24321 ENDIF
24322
24323C...Store information on scattered partons in PARI.
24324 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24325 DO 140 IS=7,8
24326 I=MINT(IS)
24327 PARI(36+IS)=P(I,3)/VINT(1)
24328 PARI(38+IS)=P(I,4)/VINT(1)
24329 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24330 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24331 & SQRT(PR),1D20)),P(I,3))
24332 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24333 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24334 & SQRT(PR),1D20)),P(I,3))
24335 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24336 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24337 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24338 140 CONTINUE
24339 ENDIF
24340
24341C...Store sum up transverse and longitudinal momenta.
24342 PARI(65)=2D0*PARI(17)
24343 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24344 DO 150 I=MSTP(126)+1,N
24345 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24346 PT=SQRT(P(I,1)**2+P(I,2)**2)
24347 PARI(69)=PARI(69)+PT
24348 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24349 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24350 150 CONTINUE
24351 PARI(67)=PARI(68)
24352 PARI(71)=VINT(151)
24353 PARI(72)=VINT(152)
24354 PARI(73)=VINT(151)
24355 PARI(74)=VINT(152)
24356 ELSE
24357 PARI(66)=PARI(65)
24358 PARI(69)=PARI(65)
24359 ENDIF
24360
24361C...Store various other pieces of information into PARI.
24362 PARI(61)=VINT(148)
24363 PARI(75)=VINT(155)
24364 PARI(76)=VINT(156)
24365 PARI(77)=VINT(159)
24366 PARI(78)=VINT(160)
24367 PARI(81)=VINT(138)
24368
24369C...Store information on lepton -> lepton + gamma in PYGAGA.
24370 MSTI(71)=MINT(141)
24371 MSTI(72)=MINT(142)
24372 PARI(101)=VINT(301)
24373 PARI(102)=VINT(302)
24374 DO 160 I=103,114
24375 PARI(I)=VINT(I+202)
24376 160 CONTINUE
24377
24378C...Set information for PYTABU.
24379 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
24380 MSTU(161)=MINT(21)
24381 MSTU(162)=0
24382 ELSEIF(ISET(ISUB).EQ.5) THEN
24383 MSTU(161)=MINT(23)
24384 MSTU(162)=0
24385 ELSE
24386 MSTU(161)=MINT(21)
24387 MSTU(162)=MINT(22)
24388 ENDIF
24389
24390 RETURN
24391 END
24392
24393C*********************************************************************
24394
24395C...PYFRAM
24396C...Performs transformations between different coordinate frames.
24397
24398 SUBROUTINE PYFRAM(IFRAME)
24399
24400C...Double precision and integer declarations.
24401 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24402 IMPLICIT INTEGER(I-N)
24403 INTEGER PYK,PYCHGE,PYCOMP
24404C...Commonblocks.
24405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24406 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24407 COMMON/PYINT1/MINT(400),VINT(400)
24408 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
24409
24410C...Check that transformation can and should be done.
24411 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
24412 &MINT(91).EQ.1)) THEN
24413 IF(IFRAME.EQ.MINT(6)) RETURN
24414 ELSE
24415 WRITE(MSTU(11),5000) IFRAME,MINT(6)
24416 RETURN
24417 ENDIF
24418
24419 IF(MINT(6).EQ.1) THEN
24420C...Transform from fixed target or user specified frame to
24421C...overall CM frame.
24422 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
24423 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
24424 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
24425 ELSEIF(MINT(6).EQ.3) THEN
24426C...Transform from hadronic CM frame in DIS to overall CM frame.
24427 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
24428 & -VINT(225))
24429 ENDIF
24430
24431 IF(IFRAME.EQ.1) THEN
24432C...Transform from overall CM frame to fixed target or user specified
24433C...frame.
24434 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
24435 ELSEIF(IFRAME.EQ.3) THEN
24436C...Transform from overall CM frame to hadronic CM frame in DIS.
24437 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
24438 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
24439 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
24440 ENDIF
24441
24442C...Set information about new frame.
24443 MINT(6)=IFRAME
24444 MSTI(6)=IFRAME
24445
24446 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
24447 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
24448 &1X,I5)
24449
24450 RETURN
24451 END
24452
24453C*********************************************************************
24454
24455C...PYWIDT
24456C...Calculates full and partial widths of resonances.
24457
24458 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
24459
24460C...Double precision and integer declarations.
24461 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24462 IMPLICIT INTEGER(I-N)
24463 INTEGER PYK,PYCHGE,PYCOMP
24464C...Parameter statement to help give large particle numbers.
24465 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24466 &KEXCIT=4000000,KDIMEN=5000000)
24467C...Commonblocks.
24468 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24469 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24470 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
24471 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24472 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24473 COMMON/PYINT1/MINT(400),VINT(400)
24474 COMMON/PYINT4/MWID(500),WIDS(500,5)
24475 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24476 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24477 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24478 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
24479 COMMON/PYPUED/IUED(0:99),RUED(0:99)
24480 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
24481 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
24482C...Local arrays and saved variables.
24483 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24484 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
24485 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
24486C...UED: equivalences between ordered particles (451->475)
24487C...and UED particle code (5 000 000 + id)
24488 PARAMETER(KKFLMI=451,KKFLMA=475)
24489 DIMENSION CHIDEL(3), IUEDPR(25)
24490 DIMENSION IUEDEQ(KKFLMA),MUED(2)
24491 COMMON/SW1/SW21,CW21
24492 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
24493 & 6100001,6100002,6100003,6100004,6100005,6100006,
24494 & 5100001,5100002,5100003,5100004,5100005,5100006,
24495 & 6100011,6100013,6100015,
24496 & 5100012,5100011,5100014,5100013,5100016,5100015,
24497 & 5100021,5100022,5100023,5100024/
24498C...Save local variables
24499 SAVE MOFSV,WIDWSV,WID2SV
24500C...Initial values
24501 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
24502 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
24503 DATA IUEDPR/25*0/
24504C...UED: inline functions used in kk width calculus
24505 FKAC1(X,Y)=1.-X**2/Y**2
24506 FKAC2(X,Y)=2.+X**2/Y**2
24507
24508C...Compressed code and sign; mass.
24509 KFLA=IABS(KFLR)
24510 KFLS=ISIGN(1,KFLR)
24511 KC=PYCOMP(KFLA)
24512 SHR=SQRT(SH)
24513 PMR=PMAS(KC,1)
24514
24515C...Reset width information.
24516 DO 110 I=0,MDCY(KC,3)
24517 WDTP(I)=0D0
24518 DO 100 J=0,5
24519 WDTE(I,J)=0D0
24520 100 CONTINUE
24521 110 CONTINUE
24522
24523C...Allow for fudge factor to rescale resonance width.
24524 FUDGE=1D0
24525 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
24526 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
24527 IF(MSTP(110).EQ.KFLA) THEN
24528 FUDGE=PARP(110)
24529 ELSEIF(MSTP(110).EQ.-1) THEN
24530 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
24531 ELSEIF(MSTP(110).EQ.-2) THEN
24532 FUDGE=PARP(110)
24533 ENDIF
24534 ENDIF
24535
24536C...Not to be treated as a resonance: return.
24537 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
24538 &KFLA.NE.22) THEN
24539 WDTP(0)=1D0
24540 WDTE(0,0)=1D0
24541 MINT(61)=0
24542 MINT(62)=0
24543 MINT(63)=0
24544 RETURN
24545
24546C...Treatment as a resonance based on tabulated branching ratios.
24547 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
24548C...Loop over possible decay channels; skip irrelevant ones.
24549 DO 120 I=1,MDCY(KC,3)
24550 IDC=I+MDCY(KC,2)-1
24551 IF(MDME(IDC,1).LT.0) GOTO 120
24552
24553C...Read out decay products and nominal masses.
24554 KFD1=KFDP(IDC,1)
24555 KFC1=PYCOMP(KFD1)
24556C...Skip dummy modes or unrecognized particles
24557 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
24558 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
24559 PM1=PMAS(KFC1,1)
24560 KFD2=KFDP(IDC,2)
24561 KFC2=PYCOMP(KFD2)
24562 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
24563 PM2=PMAS(KFC2,1)
24564 KFD3=KFDP(IDC,3)
24565 PM3=0D0
24566 IF(KFD3.NE.0) THEN
24567 KFC3=PYCOMP(KFD3)
24568 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
24569 PM3=PMAS(KFC3,1)
24570 ENDIF
24571
24572C...Naive partial width and alternative threshold factors.
24573 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
24574 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
24575 & PM1+PM2+PM3.GE.SHR) THEN
24576 WDTP(I)=0D0
24577 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
24578 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
24579 & 4D0*PM1**2*PM2**2))/SH
24580 ELSEIF(MDME(IDC,2).EQ.52) THEN
24581 PMA=MAX(PM1,PM2,PM3)
24582 PMC=MIN(PM1,PM2,PM3)
24583 PMB=PM1+PM2+PM3-PMA-PMC
24584 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
24585 PMAN=PMA**2/SH
24586 PMBN=PMB**2/SH
24587 PMCN=PMC**2/SH
24588 PMBCN=PMBC**2/SH
24589 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
24590 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24591 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24592 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24593 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24594 & ((1D0-PMBCN)*PMBCN*SH)
24595 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
24596 WDTP(I)=WDTP(I)*SQRT(
24597 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
24598 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
24599 ELSEIF(MDME(IDC,2).EQ.53) THEN
24600 PMA=MAX(PM1,PM2,PM3)
24601 PMC=MIN(PM1,PM2,PM3)
24602 PMB=PM1+PM2+PM3-PMA-PMC
24603 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
24604 PMAN=PMA**2/SH
24605 PMBN=PMB**2/SH
24606 PMCN=PMC**2/SH
24607 PMBCN=PMBC**2/SH
24608 FACACT=SQRT(MAX(0D0,
24609 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24610 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24611 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24612 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24613 & ((1D0-PMBCN)*PMBCN*SH)
24614 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
24615 PMAN=PMA**2/PMR**2
24616 PMBN=PMB**2/PMR**2
24617 PMCN=PMC**2/PMR**2
24618 PMBCN=PMBC**2/PMR**2
24619 FACNOM=SQRT(MAX(0D0,
24620 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24621 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24622 & ((PMR-PMA)**2-(PMB+PMC)**2)*
24623 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
24624 & ((1D0-PMBCN)*PMBCN*PMR**2)
24625 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
24626 ENDIF
24627 WDTP(I)=FUDGE*WDTP(I)
24628 WDTP(0)=WDTP(0)+WDTP(I)
24629
24630C...Calculate secondary width (at most two identical/opposite).
24631 WID2=1D0
24632 IF(MDME(IDC,1).GT.0) THEN
24633 IF(KFD2.EQ.KFD1) THEN
24634 IF(KCHG(KFC1,3).EQ.0) THEN
24635 WID2=WIDS(KFC1,1)
24636 ELSEIF(KFD1.GT.0) THEN
24637 WID2=WIDS(KFC1,4)
24638 ELSE
24639 WID2=WIDS(KFC1,5)
24640 ENDIF
24641 IF(KFD3.GT.0) THEN
24642 WID2=WID2*WIDS(KFC3,2)
24643 ELSEIF(KFD3.LT.0) THEN
24644 WID2=WID2*WIDS(KFC3,3)
24645 ENDIF
24646 ELSEIF(KFD2.EQ.-KFD1) THEN
24647 WID2=WIDS(KFC1,1)
24648 IF(KFD3.GT.0) THEN
24649 WID2=WID2*WIDS(KFC3,2)
24650 ELSEIF(KFD3.LT.0) THEN
24651 WID2=WID2*WIDS(KFC3,3)
24652 ENDIF
24653 ELSEIF(KFD3.EQ.KFD1) THEN
24654 IF(KCHG(KFC1,3).EQ.0) THEN
24655 WID2=WIDS(KFC1,1)
24656 ELSEIF(KFD1.GT.0) THEN
24657 WID2=WIDS(KFC1,4)
24658 ELSE
24659 WID2=WIDS(KFC1,5)
24660 ENDIF
24661 IF(KFD2.GT.0) THEN
24662 WID2=WID2*WIDS(KFC2,2)
24663 ELSEIF(KFD2.LT.0) THEN
24664 WID2=WID2*WIDS(KFC2,3)
24665 ENDIF
24666 ELSEIF(KFD3.EQ.-KFD1) THEN
24667 WID2=WIDS(KFC1,1)
24668 IF(KFD2.GT.0) THEN
24669 WID2=WID2*WIDS(KFC2,2)
24670 ELSEIF(KFD2.LT.0) THEN
24671 WID2=WID2*WIDS(KFC2,3)
24672 ENDIF
24673 ELSEIF(KFD3.EQ.KFD2) THEN
24674 IF(KCHG(KFC2,3).EQ.0) THEN
24675 WID2=WIDS(KFC2,1)
24676 ELSEIF(KFD2.GT.0) THEN
24677 WID2=WIDS(KFC2,4)
24678 ELSE
24679 WID2=WIDS(KFC2,5)
24680 ENDIF
24681 IF(KFD1.GT.0) THEN
24682 WID2=WID2*WIDS(KFC1,2)
24683 ELSEIF(KFD1.LT.0) THEN
24684 WID2=WID2*WIDS(KFC1,3)
24685 ENDIF
24686 ELSEIF(KFD3.EQ.-KFD2) THEN
24687 WID2=WIDS(KFC2,1)
24688 IF(KFD1.GT.0) THEN
24689 WID2=WID2*WIDS(KFC1,2)
24690 ELSEIF(KFD1.LT.0) THEN
24691 WID2=WID2*WIDS(KFC1,3)
24692 ENDIF
24693 ELSE
24694 IF(KFD1.GT.0) THEN
24695 WID2=WIDS(KFC1,2)
24696 ELSE
24697 WID2=WIDS(KFC1,3)
24698 ENDIF
24699 IF(KFD2.GT.0) THEN
24700 WID2=WID2*WIDS(KFC2,2)
24701 ELSE
24702 WID2=WID2*WIDS(KFC2,3)
24703 ENDIF
24704 IF(KFD3.GT.0) THEN
24705 WID2=WID2*WIDS(KFC3,2)
24706 ELSEIF(KFD3.LT.0) THEN
24707 WID2=WID2*WIDS(KFC3,3)
24708 ENDIF
24709 ENDIF
24710
24711C...Store effective widths according to case.
24712 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24713 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24714 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24715 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24716 ENDIF
24717 120 CONTINUE
24718C...Return.
24719 MINT(61)=0
24720 MINT(62)=0
24721 MINT(63)=0
24722 RETURN
24723 ENDIF
24724
24725C...Here begins detailed dynamical calculation of resonance widths.
24726C...Shared treatment of Higgs states.
24727 KFHIGG=25
24728 IHIGG=1
24729 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24730 KFHIGG=KFLA
24731 IHIGG=KFLA-33
24732 ENDIF
24733
24734C...Common electroweak and strong constants.
24735 XW=PARU(102)
24736 XWV=XW
24737 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24738 XW1=1D0-XW
24739 AEM=PYALEM(SH)
24740 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24741 AS=PYALPS(SH)
24742 RADC=1D0+AS/PARU(1)
24743
24744 IF(KFLA.EQ.6) THEN
24745C...t quark.
24746 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24747 RADCT=1D0-2.5D0*AS/PARU(1)
24748 DO 140 I=1,MDCY(KC,3)
24749 IDC=I+MDCY(KC,2)-1
24750 IF(MDME(IDC,1).LT.0) GOTO 140
24751 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24752 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24753 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24754 WID2=1D0
24755 IF(I.GE.4.AND.I.LE.7) THEN
24756C...t -> W + q; including approximate QCD correction factor.
24757 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24758 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24759 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24760 IF(KFLR.GT.0) THEN
24761 WID2=WIDS(24,2)
24762 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24763 ELSE
24764 WID2=WIDS(24,3)
24765 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24766 ENDIF
24767 ELSEIF(I.EQ.9) THEN
24768C...t -> H + b.
24769 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24770 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24771 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24772 & 4D0*SQRT(RM2R*RM2))
24773 WID2=WIDS(37,2)
24774 IF(KFLR.LT.0) WID2=WIDS(37,3)
24775CMRENNA++
24776 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24777C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24778 BETA=ATAN(RMSS(5))
24779 SINB=SIN(BETA)
24780 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24781 ET=KCHG(6,1)/3D0
24782 T3L=SIGN(0.5D0,ET)
24783 KFC1=PYCOMP(KFDP(IDC,1))
24784 KFC2=PYCOMP(KFDP(IDC,2))
24785 PMNCHI=PMAS(KFC1,1)
24786 PMSTOP=PMAS(KFC2,1)
24787 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24788 IZ=I-9
24789 DO 130 IK=1,4
24790 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24791 130 CONTINUE
24792 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24793 AR=-ET*ZMIXC(IZ,1)*TANW
24794 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24795 BR=AL
24796 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24797 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24798 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24799 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24800 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24801 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24802 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24803 IF(KFLR.GT.0) THEN
24804 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24805 ELSE
24806 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24807 ENDIF
24808 ENDIF
24809 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24810C...t -> ~g + ~t
24811 KFC1=PYCOMP(KFDP(IDC,1))
24812 KFC2=PYCOMP(KFDP(IDC,2))
24813 PMNCHI=PMAS(KFC1,1)
24814 PMSTOP=PMAS(KFC2,1)
24815 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24816 RL=SFMIX(6,1)
24817 RR=-SFMIX(6,2)
24818 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24819 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24820 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24821 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24822 IF(KFLR.GT.0) THEN
24823 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24824 ELSE
24825 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24826 ENDIF
24827 ENDIF
24828 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24829C...t -> ~gravitino + ~t
24830 XMP2=RMSS(29)**2
24831 KFC1=PYCOMP(KFDP(IDC,1))
24832 XMGR2=PMAS(KFC1,1)**2
24833 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24834 KFC2=PYCOMP(KFDP(IDC,2))
24835 WID2=WIDS(KFC2,2)
24836 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24837CMRENNA--
24838 ENDIF
24839 WDTP(I)=FUDGE*WDTP(I)
24840 WDTP(0)=WDTP(0)+WDTP(I)
24841 IF(MDME(IDC,1).GT.0) THEN
24842 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24843 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24844 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24845 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24846 ENDIF
24847 140 CONTINUE
24848
24849 ELSEIF(KFLA.EQ.7) THEN
24850C...b' quark.
24851 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24852 DO 150 I=1,MDCY(KC,3)
24853 IDC=I+MDCY(KC,2)-1
24854 IF(MDME(IDC,1).LT.0) GOTO 150
24855 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24856 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24857 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24858 WID2=1D0
24859 IF(I.GE.4.AND.I.LE.7) THEN
24860C...b' -> W + q.
24861 WDTP(I)=FAC*VCKM(I-3,4)*
24862 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24863 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24864 IF(KFLR.GT.0) THEN
24865 WID2=WIDS(24,3)
24866 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24867 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24868 ELSE
24869 WID2=WIDS(24,2)
24870 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24871 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24872 ENDIF
24873 WID2=WIDS(24,3)
24874 IF(KFLR.LT.0) WID2=WIDS(24,2)
24875 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24876C...b' -> H + q.
24877 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24878 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24879 IF(KFLR.GT.0) THEN
24880 WID2=WIDS(37,3)
24881 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24882 ELSE
24883 WID2=WIDS(37,2)
24884 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24885 ENDIF
24886 ENDIF
24887 WDTP(I)=FUDGE*WDTP(I)
24888 WDTP(0)=WDTP(0)+WDTP(I)
24889 IF(MDME(IDC,1).GT.0) THEN
24890 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24891 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24892 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24893 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24894 ENDIF
24895 150 CONTINUE
24896
24897 ELSEIF(KFLA.EQ.8) THEN
24898C...t' quark.
24899 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24900 DO 160 I=1,MDCY(KC,3)
24901 IDC=I+MDCY(KC,2)-1
24902 IF(MDME(IDC,1).LT.0) GOTO 160
24903 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24904 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24905 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24906 WID2=1D0
24907 IF(I.GE.4.AND.I.LE.7) THEN
24908C...t' -> W + q.
24909 WDTP(I)=FAC*VCKM(4,I-3)*
24910 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24911 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24912 IF(KFLR.GT.0) THEN
24913 WID2=WIDS(24,2)
24914 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24915 ELSE
24916 WID2=WIDS(24,3)
24917 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24918 ENDIF
24919 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24920C...t' -> H + q.
24921 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24922 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24923 IF(KFLR.GT.0) THEN
24924 WID2=WIDS(37,2)
24925 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24926 ELSE
24927 WID2=WIDS(37,3)
24928 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24929 ENDIF
24930 ENDIF
24931 WDTP(I)=FUDGE*WDTP(I)
24932 WDTP(0)=WDTP(0)+WDTP(I)
24933 IF(MDME(IDC,1).GT.0) THEN
24934 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24935 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24936 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24937 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24938 ENDIF
24939 160 CONTINUE
24940
24941 ELSEIF(KFLA.EQ.17) THEN
24942C...tau' lepton.
24943 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24944 DO 170 I=1,MDCY(KC,3)
24945 IDC=I+MDCY(KC,2)-1
24946 IF(MDME(IDC,1).LT.0) GOTO 170
24947 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24948 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24949 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24950 WID2=1D0
24951 IF(I.EQ.3) THEN
24952C...tau' -> W + nu'_tau.
24953 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24954 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24955 IF(KFLR.GT.0) THEN
24956 WID2=WIDS(24,3)
24957 WID2=WID2*WIDS(18,2)
24958 ELSE
24959 WID2=WIDS(24,2)
24960 WID2=WID2*WIDS(18,3)
24961 ENDIF
24962 ELSEIF(I.EQ.5) THEN
24963C...tau' -> H + nu'_tau.
24964 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24965 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24966 IF(KFLR.GT.0) THEN
24967 WID2=WIDS(37,3)
24968 WID2=WID2*WIDS(18,2)
24969 ELSE
24970 WID2=WIDS(37,2)
24971 WID2=WID2*WIDS(18,3)
24972 ENDIF
24973 ENDIF
24974 WDTP(I)=FUDGE*WDTP(I)
24975 WDTP(0)=WDTP(0)+WDTP(I)
24976 IF(MDME(IDC,1).GT.0) THEN
24977 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24978 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24979 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24980 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24981 ENDIF
24982 170 CONTINUE
24983
24984 ELSEIF(KFLA.EQ.18) THEN
24985C...nu'_tau neutrino.
24986 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24987 DO 180 I=1,MDCY(KC,3)
24988 IDC=I+MDCY(KC,2)-1
24989 IF(MDME(IDC,1).LT.0) GOTO 180
24990 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24991 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24992 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24993 WID2=1D0
24994 IF(I.EQ.2) THEN
24995C...nu'_tau -> W + tau'.
24996 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24997 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24998 IF(KFLR.GT.0) THEN
24999 WID2=WIDS(24,2)
25000 WID2=WID2*WIDS(17,2)
25001 ELSE
25002 WID2=WIDS(24,3)
25003 WID2=WID2*WIDS(17,3)
25004 ENDIF
25005 ELSEIF(I.EQ.3) THEN
25006C...nu'_tau -> H + tau'.
25007 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25008 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25009 IF(KFLR.GT.0) THEN
25010 WID2=WIDS(37,2)
25011 WID2=WID2*WIDS(17,2)
25012 ELSE
25013 WID2=WIDS(37,3)
25014 WID2=WID2*WIDS(17,3)
25015 ENDIF
25016 ENDIF
25017 WDTP(I)=FUDGE*WDTP(I)
25018 WDTP(0)=WDTP(0)+WDTP(I)
25019 IF(MDME(IDC,1).GT.0) THEN
25020 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25021 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25022 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25023 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25024 ENDIF
25025 180 CONTINUE
25026
25027 ELSEIF(KFLA.EQ.21) THEN
25028C...QCD:
25029C***Note that widths are not given in dimensional quantities here.
25030 DO 190 I=1,MDCY(KC,3)
25031 IDC=I+MDCY(KC,2)-1
25032 IF(MDME(IDC,1).LT.0) GOTO 190
25033 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25034 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25035 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25036 WID2=1D0
25037 IF(I.LE.8) THEN
25038C...QCD -> q + qbar
25039 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25040 IF(I.EQ.6) WID2=WIDS(6,1)
25041 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25042 ENDIF
25043 WDTP(I)=FUDGE*WDTP(I)
25044 WDTP(0)=WDTP(0)+WDTP(I)
25045 IF(MDME(IDC,1).GT.0) THEN
25046 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25047 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25048 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25049 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25050 ENDIF
25051 190 CONTINUE
25052
25053 ELSEIF(KFLA.EQ.22) THEN
25054C...QED photon.
25055C***Note that widths are not given in dimensional quantities here.
25056 DO 200 I=1,MDCY(KC,3)
25057 IDC=I+MDCY(KC,2)-1
25058 IF(MDME(IDC,1).LT.0) GOTO 200
25059 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25060 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25061 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25062 WID2=1D0
25063 IF(I.LE.8) THEN
25064C...QED -> q + qbar.
25065 EF=KCHG(I,1)/3D0
25066 FCOF=3D0*RADC
25067 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25068 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25069 IF(I.EQ.6) WID2=WIDS(6,1)
25070 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25071 ELSEIF(I.LE.12) THEN
25072C...QED -> l+ + l-.
25073 EF=KCHG(9+2*(I-8),1)/3D0
25074 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25075 IF(I.EQ.12) WID2=WIDS(17,1)
25076 ENDIF
25077 WDTP(I)=FUDGE*WDTP(I)
25078 WDTP(0)=WDTP(0)+WDTP(I)
25079 IF(MDME(IDC,1).GT.0) THEN
25080 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25081 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25082 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25083 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25084 ENDIF
25085 200 CONTINUE
25086
25087 ELSEIF(KFLA.EQ.23) THEN
25088C...Z0:
25089 ICASE=1
25090 XWC=1D0/(16D0*XW*XW1)
25091 FAC=(AEM*XWC/3D0)*SHR
25092 210 CONTINUE
25093 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25094 VINT(111)=0D0
25095 VINT(112)=0D0
25096 VINT(114)=0D0
25097 ENDIF
25098 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25099 KFI=IABS(MINT(15))
25100 IF(KFI.GT.20) KFI=IABS(MINT(16))
25101 EI=KCHG(KFI,1)/3D0
25102 AI=SIGN(1D0,EI)
25103 VI=AI-4D0*EI*XWV
25104 SQMZ=PMAS(23,1)**2
25105 HZ=SHR*WDTP(0)
25106 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25107 IF(MSTP(43).EQ.3) VINT(112)=
25108 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25109 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25110 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25111 ENDIF
25112 DO 220 I=1,MDCY(KC,3)
25113 IDC=I+MDCY(KC,2)-1
25114 IF(MDME(IDC,1).LT.0) GOTO 220
25115 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25116 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25117 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25118 WID2=1D0
25119 IF(I.LE.8) THEN
25120C...Z0 -> q + qbar
25121 EF=KCHG(I,1)/3D0
25122 AF=SIGN(1D0,EF+0.1D0)
25123 VF=AF-4D0*EF*XWV
25124 FCOF=3D0*RADC
25125 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25126 IF(I.EQ.6) WID2=WIDS(6,1)
25127 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25128 ELSEIF(I.LE.16) THEN
25129C...Z0 -> l+ + l-, nu + nubar
25130 EF=KCHG(I+2,1)/3D0
25131 AF=SIGN(1D0,EF+0.1D0)
25132 VF=AF-4D0*EF*XWV
25133 FCOF=1D0
25134 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25135 ENDIF
25136 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25137 IF(ICASE.EQ.1) THEN
25138 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25139 & BE34
25140 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25141 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25142 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25143 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25144 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25145 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25146 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25147 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25148 ENDIF
25149 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25150 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25151 IF(MDME(IDC,1).GT.0) THEN
25152 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25153 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25154 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25155 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25156 & WDTE(I,MDME(IDC,1))
25157 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25158 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25159 ENDIF
25160 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25161 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25162 & VINT(111)+FGGF*WID2
25163 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25164 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25165 & VINT(114)+FZZF*WID2
25166 ENDIF
25167 ENDIF
25168 220 CONTINUE
25169 IF(MINT(61).GE.1) ICASE=3-ICASE
25170 IF(ICASE.EQ.2) GOTO 210
25171
25172 ELSEIF(KFLA.EQ.24) THEN
25173C...W+/-:
25174 FAC=(AEM/(24D0*XW))*SHR
25175 DO 230 I=1,MDCY(KC,3)
25176 IDC=I+MDCY(KC,2)-1
25177 IF(MDME(IDC,1).LT.0) GOTO 230
25178 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25179 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25180 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25181 WID2=1D0
25182 IF(I.LE.16) THEN
25183C...W+/- -> q + qbar'
25184 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25185 IF(KFLR.GT.0) THEN
25186 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25187 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25188 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25189 ELSE
25190 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25191 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25192 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25193 ENDIF
25194 ELSEIF(I.LE.20) THEN
25195C...W+/- -> l+/- + nu
25196 FCOF=1D0
25197 IF(KFLR.GT.0) THEN
25198 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25199 ELSE
25200 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25201 ENDIF
25202 ENDIF
25203 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25204 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25205 WDTP(I)=FUDGE*WDTP(I)
25206 WDTP(0)=WDTP(0)+WDTP(I)
25207 IF(MDME(IDC,1).GT.0) THEN
25208 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25209 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25210 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25211 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25212 ENDIF
25213 230 CONTINUE
25214
25215 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25216C...h0 (or H0, or A0):
25217 SHFS=SH
25218 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25219 DO 270 I=1,MDCY(KFHIGG,3)
25220 IDC=I+MDCY(KFHIGG,2)-1
25221 IF(MDME(IDC,1).LT.0) GOTO 270
25222 KFC1=PYCOMP(KFDP(IDC,1))
25223 KFC2=PYCOMP(KFDP(IDC,2))
25224 RM1=PMAS(KFC1,1)**2/SH
25225 RM2=PMAS(KFC2,1)**2/SH
25226 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25227 & GOTO 270
25228 WID2=1D0
25229
25230 IF(I.LE.8) THEN
25231C...h0 -> q + qbar
25232 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25233 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25234C...A0 behaves like beta, ho and H0 like beta**3.
25235 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25236 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25237 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25238 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25239 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25240 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25241 IF(IHIGG.NE.3) THEN
25242 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25243 & PARU(151+10*IHIGG))**2
25244 ENDIF
25245 ENDIF
25246 ENDIF
25247 IF(I.EQ.6) WID2=WIDS(6,1)
25248 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25249 ELSEIF(I.LE.12) THEN
25250C...h0 -> l+ + l-
25251 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25252C...A0 behaves like beta, ho and H0 like beta**3.
25253 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25254 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25255 & PARU(153+10*IHIGG)**2
25256 IF(I.EQ.12) WID2=WIDS(17,1)
25257
25258 ELSEIF(I.EQ.13) THEN
25259C...h0 -> g + g; quark loop contribution only
25260 ETARE=0D0
25261 ETAIM=0D0
25262 DO 240 J=1,2*MSTP(1)
25263 EPS=(2D0*PMAS(J,1))**2/SH
25264C...Loop integral; function of eps=4m^2/shat; different for A0.
25265 IF(EPS.LE.1D0) THEN
25266 IF(EPS.GT.1D-4) THEN
25267 ROOT=SQRT(1D0-EPS)
25268 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25269 ELSE
25270 RLN=LOG(4D0/EPS-2D0)
25271 ENDIF
25272 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25273 PHIIM=0.5D0*PARU(1)*RLN
25274 ELSE
25275 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25276 PHIIM=0D0
25277 ENDIF
25278 IF(IHIGG.LE.2) THEN
25279 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25280 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25281 ELSE
25282 ETAREJ=-0.5D0*EPS*PHIRE
25283 ETAIMJ=-0.5D0*EPS*PHIIM
25284 ENDIF
25285C...Couplings (=1 for standard model Higgs).
25286 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25287 IF(MOD(J,2).EQ.1) THEN
25288 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25289 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25290 ELSE
25291 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25292 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25293 ENDIF
25294 ENDIF
25295 ETARE=ETARE+ETAREJ
25296 ETAIM=ETAIM+ETAIMJ
25297 240 CONTINUE
25298 ETA2=ETARE**2+ETAIM**2
25299 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25300
25301 ELSEIF(I.EQ.14) THEN
25302C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25303 ETARE=0D0
25304 ETAIM=0D0
25305 JMAX=3*MSTP(1)+1
25306 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25307 DO 250 J=1,JMAX
25308 IF(J.LE.2*MSTP(1)) THEN
25309 EJ=KCHG(J,1)/3D0
25310 EPS=(2D0*PMAS(J,1))**2/SH
25311 ELSEIF(J.LE.3*MSTP(1)) THEN
25312 JL=2*(J-2*MSTP(1))-1
25313 EJ=KCHG(10+JL,1)/3D0
25314 EPS=(2D0*PMAS(10+JL,1))**2/SH
25315 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25316 EPS=(2D0*PMAS(24,1))**2/SH
25317 ELSE
25318 EPS=(2D0*PMAS(37,1))**2/SH
25319 ENDIF
25320C...Loop integral; function of eps=4m^2/shat.
25321 IF(EPS.LE.1D0) THEN
25322 IF(EPS.GT.1D-4) THEN
25323 ROOT=SQRT(1D0-EPS)
25324 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25325 ELSE
25326 RLN=LOG(4D0/EPS-2D0)
25327 ENDIF
25328 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25329 PHIIM=0.5D0*PARU(1)*RLN
25330 ELSE
25331 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25332 PHIIM=0D0
25333 ENDIF
25334 IF(J.LE.3*MSTP(1)) THEN
25335C...Fermion loops: loop integral different for A0; charges.
25336 IF(IHIGG.LE.2) THEN
25337 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25338 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25339 ELSE
25340 PHIPRE=-0.5D0*EPS*PHIRE
25341 PHIPIM=-0.5D0*EPS*PHIIM
25342 ENDIF
25343 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25344 EJC=3D0*EJ**2
25345 EJH=PARU(151+10*IHIGG)
25346 ELSEIF(J.LE.2*MSTP(1)) THEN
25347 EJC=3D0*EJ**2
25348 EJH=PARU(152+10*IHIGG)
25349 ELSE
25350 EJC=EJ**2
25351 EJH=PARU(153+10*IHIGG)
25352 ENDIF
25353 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25354 ETAREJ=EJC*EJH*PHIPRE
25355 ETAIMJ=EJC*EJH*PHIPIM
25356 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25357C...W loops: loop integral and charges.
25358 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
25359 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
25360 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25361 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25362 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25363 ENDIF
25364 ELSE
25365C...Charged H loops: loop integral and charges.
25366 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
25367 & PARU(158+10*IHIGG+2*(IHIGG/3))
25368 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
25369 ETAIMJ=-EPS**2*PHIIM*FACHHH
25370 ENDIF
25371 ETARE=ETARE+ETAREJ
25372 ETAIM=ETAIM+ETAIMJ
25373 250 CONTINUE
25374 ETA2=ETARE**2+ETAIM**2
25375 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
25376
25377 ELSEIF(I.EQ.15) THEN
25378C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25379 ETARE=0D0
25380 ETAIM=0D0
25381 JMAX=3*MSTP(1)+1
25382 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25383 DO 260 J=1,JMAX
25384 IF(J.LE.2*MSTP(1)) THEN
25385 EJ=KCHG(J,1)/3D0
25386 AJ=SIGN(1D0,EJ+0.1D0)
25387 VJ=AJ-4D0*EJ*XWV
25388 EPS=(2D0*PMAS(J,1))**2/SH
25389 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
25390 ELSEIF(J.LE.3*MSTP(1)) THEN
25391 JL=2*(J-2*MSTP(1))-1
25392 EJ=KCHG(10+JL,1)/3D0
25393 AJ=SIGN(1D0,EJ+0.1D0)
25394 VJ=AJ-4D0*EJ*XWV
25395 EPS=(2D0*PMAS(10+JL,1))**2/SH
25396 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
25397 ELSE
25398 EPS=(2D0*PMAS(24,1))**2/SH
25399 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
25400 ENDIF
25401C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25402 IF(EPS.LE.1D0) THEN
25403 ROOT=SQRT(1D0-EPS)
25404 IF(EPS.GT.1D-4) THEN
25405 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25406 ELSE
25407 RLN=LOG(4D0/EPS-2D0)
25408 ENDIF
25409 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25410 PHIIM=0.5D0*PARU(1)*RLN
25411 PSIRE=0.5D0*ROOT*RLN
25412 PSIIM=-0.5D0*ROOT*PARU(1)
25413 ELSE
25414 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25415 PHIIM=0D0
25416 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
25417 PSIIM=0D0
25418 ENDIF
25419 IF(EPSP.LE.1D0) THEN
25420 ROOT=SQRT(1D0-EPSP)
25421 IF(EPSP.GT.1D-4) THEN
25422 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25423 ELSE
25424 RLN=LOG(4D0/EPSP-2D0)
25425 ENDIF
25426 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
25427 PHIIMP=0.5D0*PARU(1)*RLN
25428 PSIREP=0.5D0*ROOT*RLN
25429 PSIIMP=-0.5D0*ROOT*PARU(1)
25430 ELSE
25431 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
25432 PHIIMP=0D0
25433 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
25434 PSIIMP=0D0
25435 ENDIF
25436 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
25437 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
25438 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
25439 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
25440 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
25441 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
25442 IF(J.LE.3*MSTP(1)) THEN
25443C...Fermion loops: loop integral different for A0; charges.
25444 IF(IHIGG.EQ.3) FXYRE=0D0
25445 IF(IHIGG.EQ.3) FXYIM=0D0
25446 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25447 EJC=-3D0*EJ*VJ
25448 EJH=PARU(151+10*IHIGG)
25449 ELSEIF(J.LE.2*MSTP(1)) THEN
25450 EJC=-3D0*EJ*VJ
25451 EJH=PARU(152+10*IHIGG)
25452 ELSE
25453 EJC=-EJ*VJ
25454 EJH=PARU(153+10*IHIGG)
25455 ENDIF
25456 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25457 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
25458 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
25459 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25460C...W loops: loop integral and charges.
25461 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
25462 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
25463 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
25464 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25465 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25466 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25467 ENDIF
25468 ELSE
25469C...Charged H loops: loop integral and charges.
25470 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
25471 & PARU(158+10*IHIGG+2*(IHIGG/3))
25472 ETAREJ=FACHHH*FXYRE
25473 ETAIMJ=FACHHH*FXYIM
25474 ENDIF
25475 ETARE=ETARE+ETAREJ
25476 ETAIM=ETAIM+ETAIMJ
25477 260 CONTINUE
25478 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
25479 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
25480 WID2=WIDS(23,2)
25481
25482 ELSEIF(I.LE.17) THEN
25483C...h0 -> Z0 + Z0, W+ + W-
25484 PM1=PMAS(IABS(KFDP(IDC,1)),1)
25485 PG1=PMAS(IABS(KFDP(IDC,1)),2)
25486 IF(MINT(62).GE.1) THEN
25487 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
25488 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
25489 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
25490 MOFSV(IHIGG,I-15)=0
25491 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25492 & 1D0-4D0*RM1))
25493 WID2=1D0
25494 ELSE
25495 MOFSV(IHIGG,I-15)=1
25496 RMAS=SQRT(MAX(0D0,SH))
25497 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
25498 & WID2)
25499 WIDWSV(IHIGG,I-15)=WIDW
25500 WID2SV(IHIGG,I-15)=WID2
25501 ENDIF
25502 ELSE
25503 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
25504 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25505 & 1D0-4D0*RM1))
25506 WID2=1D0
25507 ELSE
25508 WIDW=WIDWSV(IHIGG,I-15)
25509 WID2=WID2SV(IHIGG,I-15)
25510 ENDIF
25511 ENDIF
25512 WDTP(I)=FAC*WIDW/(2D0*(18-I))
25513 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
25514 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25515 & PARU(138+I+10*IHIGG)**2
25516 WID2=WID2*WIDS(7+I,1)
25517
25518 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
25519C...H0 -> Z0 + h0, A0-> Z0 + h0
25520 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25521 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25522 IF(IHIGG.EQ.2) THEN
25523 WDTP(I)=WDTP(I)*PARU(179)**2
25524 ELSEIF(IHIGG.EQ.3) THEN
25525 WDTP(I)=WDTP(I)*PARU(186)**2
25526 ENDIF
25527 WID2=WIDS(23,2)*WIDS(25,2)
25528
25529 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
25530C...H0 -> h0 + h0, A0-> h0 + h0
25531 WDTP(I)=FAC*0.25D0*
25532 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25533 IF(IHIGG.EQ.2) THEN
25534 WDTP(I)=WDTP(I)*PARU(176)**2
25535 ELSEIF(IHIGG.EQ.3) THEN
25536 WDTP(I)=WDTP(I)*PARU(169)**2
25537 ENDIF
25538 WID2=WIDS(25,1)
25539 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
25540C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25541 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25542 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25543 & *PARU(195+IHIGG)**2
25544 IF(I.EQ.20) THEN
25545 WID2=WIDS(24,2)*WIDS(37,3)
25546 ELSEIF(I.EQ.21) THEN
25547 WID2=WIDS(24,3)*WIDS(37,2)
25548 ENDIF
25549
25550 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
25551C...H0 -> Z0 + A0.
25552 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
25553 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25554 WID2=WIDS(36,2)*WIDS(23,2)
25555
25556 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
25557C...H0 -> h0 + A0.
25558 WDTP(I)=FAC*0.5D0*PARU(180)**2*
25559 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25560 WID2=WIDS(25,2)*WIDS(36,2)
25561
25562 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
25563C...H0 -> A0 + A0
25564 WDTP(I)=FAC*0.25D0*PARU(177)**2*
25565 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25566 WID2=WIDS(36,1)
25567
25568CMRENNA++
25569 ELSE
25570C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25571 RM10=RM1*SH/PMR**2
25572 RM20=RM2*SH/PMR**2
25573 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25574 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25575 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25576 WFAC=0D0
25577 ELSE
25578 WFAC=WFAC/WFAC0
25579 ENDIF
25580 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25581CMRENNA--
25582 IF(KFC2.EQ.KFC1) THEN
25583 WID2=WIDS(KFC1,1)
25584 ELSE
25585 KSGN1=2
25586 IF(KFDP(IDC,1).LT.0) KSGN1=3
25587 KSGN2=2
25588 IF(KFDP(IDC,2).LT.0) KSGN2=3
25589 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25590 ENDIF
25591 ENDIF
25592 WDTP(I)=FUDGE*WDTP(I)
25593 WDTP(0)=WDTP(0)+WDTP(I)
25594 IF(MDME(IDC,1).GT.0) THEN
25595 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25596 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25597 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25598 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25599 ENDIF
25600 270 CONTINUE
25601
25602 ELSEIF(KFLA.EQ.32) THEN
25603C...Z'0:
25604 ICASE=1
25605 XWC=1D0/(16D0*XW*XW1)
25606 FAC=(AEM*XWC/3D0)*SHR
25607 VINT(117)=0D0
25608 280 CONTINUE
25609 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25610 VINT(111)=0D0
25611 VINT(112)=0D0
25612 VINT(113)=0D0
25613 VINT(114)=0D0
25614 VINT(115)=0D0
25615 VINT(116)=0D0
25616 ENDIF
25617 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25618 KFAI=IABS(MINT(15))
25619 EI=KCHG(KFAI,1)/3D0
25620 AI=SIGN(1D0,EI+0.1D0)
25621 VI=AI-4D0*EI*XWV
25622 KFAIC=1
25623 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
25624 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
25625 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
25626 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
25627 VPI=PARU(119+2*KFAIC)
25628 API=PARU(120+2*KFAIC)
25629 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
25630 VPI=PARJ(178+2*KFAIC)
25631 API=PARJ(179+2*KFAIC)
25632 ELSE
25633 VPI=PARJ(186+2*KFAIC)
25634 API=PARJ(187+2*KFAIC)
25635 ENDIF
25636 SQMZ=PMAS(23,1)**2
25637 HZ=SHR*VINT(117)
25638 SQMZP=PMAS(32,1)**2
25639 HZP=SHR*WDTP(0)
25640 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25641 & MSTP(44).EQ.7) VINT(111)=1D0
25642 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
25643 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25644 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
25645 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
25646 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25647 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25648 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
25649 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
25650 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
25651 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25652 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
25653 ENDIF
25654 DO 290 I=1,MDCY(KC,3)
25655 IDC=I+MDCY(KC,2)-1
25656 IF(MDME(IDC,1).LT.0) GOTO 290
25657 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25658 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25659 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
25660 WID2=1D0
25661 IF(I.LE.16) THEN
25662 IF(I.LE.8) THEN
25663C...Z'0 -> q + qbar
25664 EF=KCHG(I,1)/3D0
25665 AF=SIGN(1D0,EF+0.1D0)
25666 VF=AF-4D0*EF*XWV
25667 IF(I.LE.2) THEN
25668 VPF=PARU(123-2*MOD(I,2))
25669 APF=PARU(124-2*MOD(I,2))
25670 ELSEIF(I.LE.4) THEN
25671 VPF=PARJ(182-2*MOD(I,2))
25672 APF=PARJ(183-2*MOD(I,2))
25673 ELSE
25674 VPF=PARJ(190-2*MOD(I,2))
25675 APF=PARJ(191-2*MOD(I,2))
25676 ENDIF
25677 FCOF=3D0*RADC
25678 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25679 & PYHFTH(SH,SH*RM1,1D0)
25680 IF(I.EQ.6) WID2=WIDS(6,1)
25681 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25682 ELSEIF(I.LE.16) THEN
25683C...Z'0 -> l+ + l-, nu + nubar
25684 EF=KCHG(I+2,1)/3D0
25685 AF=SIGN(1D0,EF+0.1D0)
25686 VF=AF-4D0*EF*XWV
25687 IF(I.LE.10) THEN
25688 VPF=PARU(127-2*MOD(I,2))
25689 APF=PARU(128-2*MOD(I,2))
25690 ELSEIF(I.LE.12) THEN
25691 VPF=PARJ(186-2*MOD(I,2))
25692 APF=PARJ(187-2*MOD(I,2))
25693 ELSE
25694 VPF=PARJ(194-2*MOD(I,2))
25695 APF=PARJ(195-2*MOD(I,2))
25696 ENDIF
25697 FCOF=1D0
25698 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25699 ENDIF
25700 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25701 IF(ICASE.EQ.1) THEN
25702 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25703 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
25704 & APF**2*(1D0-4D0*RM1))*BE34
25705 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25706 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25707 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
25708 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
25709 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
25710 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
25711 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
25712 ELSEIF(MINT(61).EQ.2) THEN
25713 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25714 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25715 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
25716 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25717 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
25718 & BE34
25719 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
25720 & BE34
25721 ENDIF
25722 ELSEIF(I.EQ.17) THEN
25723C...Z'0 -> W+ + W-
25724 WDTPZP=PARU(129)**2*XW1**2*
25725 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25726 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25727 IF(ICASE.EQ.1) THEN
25728 WDTPZ=0D0
25729 WDTP(I)=FAC*WDTPZP
25730 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25731 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25732 ELSEIF(MINT(61).EQ.2) THEN
25733 FGGF=0D0
25734 FGZF=0D0
25735 FGZPF=0D0
25736 FZZF=0D0
25737 FZZPF=0D0
25738 FZPZPF=WDTPZP
25739 ENDIF
25740 WID2=WIDS(24,1)
25741 ELSEIF(I.EQ.18) THEN
25742C...Z'0 -> H+ + H-
25743 CZC=2D0*(1D0-2D0*XW)
25744 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25745 IF(ICASE.EQ.1) THEN
25746 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25747 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25748 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25749 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25750 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25751 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25752 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25753 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25754 ELSEIF(MINT(61).EQ.2) THEN
25755 FGGF=0.25D0*BE34C
25756 FGZF=0.25D0*PARU(142)*CZC*BE34C
25757 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25758 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25759 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25760 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25761 ENDIF
25762 WID2=WIDS(37,1)
25763 ELSEIF(I.EQ.19) THEN
25764C...Z'0 -> Z0 + gamma.
25765 ELSEIF(I.EQ.20) THEN
25766C...Z'0 -> Z0 + h0
25767 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25768 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25769 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25770 IF(ICASE.EQ.1) THEN
25771 WDTPZ=0D0
25772 WDTP(I)=FAC*WDTPZP
25773 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25774 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25775 ELSEIF(MINT(61).EQ.2) THEN
25776 FGGF=0D0
25777 FGZF=0D0
25778 FGZPF=0D0
25779 FZZF=0D0
25780 FZZPF=0D0
25781 FZPZPF=WDTPZP
25782 ENDIF
25783 WID2=WIDS(23,2)*WIDS(25,2)
25784 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25785C...Z' -> h0 + A0 or H0 + A0.
25786 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25787 IF(I.EQ.21) THEN
25788 CZAH=PARU(186)
25789 CZPAH=PARU(188)
25790 ELSE
25791 CZAH=PARU(187)
25792 CZPAH=PARU(189)
25793 ENDIF
25794 IF(ICASE.EQ.1) THEN
25795 WDTPZ=CZAH**2*BE34C
25796 WDTP(I)=FAC*CZPAH**2*BE34C
25797 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25798 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25799 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25800 & VINT(116))*BE34C
25801 ELSEIF(MINT(61).EQ.2) THEN
25802 FGGF=0D0
25803 FGZF=0D0
25804 FGZPF=0D0
25805 FZZF=CZAH**2*BE34C
25806 FZZPF=CZAH*CZPAH*BE34C
25807 FZPZPF=CZPAH**2*BE34C
25808 ENDIF
25809 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25810 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25811 ENDIF
25812 IF(ICASE.EQ.1) THEN
25813 VINT(117)=VINT(117)+FAC*WDTPZ
25814 WDTP(I)=FUDGE*WDTP(I)
25815 WDTP(0)=WDTP(0)+WDTP(I)
25816 ENDIF
25817 IF(MDME(IDC,1).GT.0) THEN
25818 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25819 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25820 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25821 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25822 & WDTE(I,MDME(IDC,1))
25823 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25824 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25825 ENDIF
25826 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25827 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25828 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25829 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25830 & FGZF*WID2
25831 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25832 & FGZPF*WID2
25833 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25834 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25835 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25836 & FZZPF*WID2
25837 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25838 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25839 ENDIF
25840 ENDIF
25841 290 CONTINUE
25842 IF(MINT(61).GE.1) ICASE=3-ICASE
25843 IF(ICASE.EQ.2) GOTO 280
25844
25845 ELSEIF(KFLA.EQ.34) THEN
25846C...W'+/-:
25847 FAC=(AEM/(24D0*XW))*SHR
25848 DO 300 I=1,MDCY(KC,3)
25849 IDC=I+MDCY(KC,2)-1
25850 IF(MDME(IDC,1).LT.0) GOTO 300
25851 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25852 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25853 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25854 WID2=1D0
25855 IF(I.LE.20) THEN
25856 IF(I.LE.16) THEN
25857C...W'+/- -> q + qbar'
25858 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25859 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25860 IF(KFLR.GT.0) THEN
25861 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25862 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25863 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25864 ELSE
25865 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25866 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25867 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25868 ENDIF
25869 ELSEIF(I.LE.20) THEN
25870C...W'+/- -> l+/- + nu
25871 FCOF=PARU(133)**2+PARU(134)**2
25872 IF(KFLR.GT.0) THEN
25873 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25874 ELSE
25875 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25876 ENDIF
25877 ENDIF
25878 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25879 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25880 ELSEIF(I.EQ.21) THEN
25881C...W'+/- -> W+/- + Z0
25882 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25883 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25884 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25885 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25886 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25887 ELSEIF(I.EQ.23) THEN
25888C...W'+/- -> W+/- + h0
25889 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25890 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25891 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25892 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25893 ENDIF
25894 WDTP(I)=FUDGE*WDTP(I)
25895 WDTP(0)=WDTP(0)+WDTP(I)
25896 IF(MDME(IDC,1).GT.0) THEN
25897 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25898 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25899 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25900 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25901 ENDIF
25902 300 CONTINUE
25903
25904 ELSEIF(KFLA.EQ.37) THEN
25905C...H+/-:
25906C IF(MSTP(49).EQ.0) THEN
25907 SHFS=SH
25908C ELSE
25909C SHFS=PMAS(37,1)**2
25910C ENDIF
25911 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25912 DO 310 I=1,MDCY(KC,3)
25913 IDC=I+MDCY(KC,2)-1
25914 IF(MDME(IDC,1).LT.0) GOTO 310
25915 KFC1=PYCOMP(KFDP(IDC,1))
25916 KFC2=PYCOMP(KFDP(IDC,2))
25917 RM1=PMAS(KFC1,1)**2/SH
25918 RM2=PMAS(KFC2,1)**2/SH
25919 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25920 WID2=1D0
25921 IF(I.LE.4) THEN
25922C...H+/- -> q + qbar'
25923 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25924 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25925 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25926 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25927 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25928 IF(KFLR.GT.0) THEN
25929 IF(I.EQ.3) WID2=WIDS(6,2)
25930 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25931 ELSE
25932 IF(I.EQ.3) WID2=WIDS(6,3)
25933 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25934 ENDIF
25935 ELSEIF(I.LE.8) THEN
25936C...H+/- -> l+/- + nu
25937 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25938 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25939 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25940 IF(KFLR.GT.0) THEN
25941 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25942 ELSE
25943 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25944 ENDIF
25945 ELSEIF(I.EQ.9) THEN
25946C...H+/- -> W+/- + h0.
25947 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25948 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25949 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25950 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25951
25952CMRENNA++
25953 ELSE
25954C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25955 RM10=RM1*SH/PMR**2
25956 RM20=RM2*SH/PMR**2
25957 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25958 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25959 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25960 WFAC=0D0
25961 ELSE
25962 WFAC=WFAC/WFAC0
25963 ENDIF
25964 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25965CMRENNA--
25966 KSGN1=2
25967 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25968 KSGN2=2
25969 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25970 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25971 ENDIF
25972 WDTP(I)=FUDGE*WDTP(I)
25973 WDTP(0)=WDTP(0)+WDTP(I)
25974 IF(MDME(IDC,1).GT.0) THEN
25975 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25976 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25977 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25978 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25979 ENDIF
25980 310 CONTINUE
25981
25982 ELSEIF(KFLA.EQ.41) THEN
25983C...R:
25984 FAC=(AEM/(12D0*XW))*SHR
25985 DO 320 I=1,MDCY(KC,3)
25986 IDC=I+MDCY(KC,2)-1
25987 IF(MDME(IDC,1).LT.0) GOTO 320
25988 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25989 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25990 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25991 WID2=1D0
25992 IF(I.LE.6) THEN
25993C...R -> q + qbar'
25994 FCOF=3D0*RADC
25995 ELSEIF(I.LE.9) THEN
25996C...R -> l+ + l'-
25997 FCOF=1D0
25998 ENDIF
25999 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26000 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26001 IF(KFLR.GT.0) THEN
26002 IF(I.EQ.4) WID2=WIDS(6,3)
26003 IF(I.EQ.5) WID2=WIDS(7,3)
26004 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26005 IF(I.EQ.9) WID2=WIDS(17,3)
26006 ELSE
26007 IF(I.EQ.4) WID2=WIDS(6,2)
26008 IF(I.EQ.5) WID2=WIDS(7,2)
26009 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26010 IF(I.EQ.9) WID2=WIDS(17,2)
26011 ENDIF
26012 WDTP(I)=FUDGE*WDTP(I)
26013 WDTP(0)=WDTP(0)+WDTP(I)
26014 IF(MDME(IDC,1).GT.0) THEN
26015 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26016 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26017 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26018 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26019 ENDIF
26020 320 CONTINUE
26021
26022 ELSEIF(KFLA.EQ.42) THEN
26023C...LQ (leptoquark).
26024 FAC=(AEM/4D0)*PARU(151)*SHR
26025 DO 330 I=1,MDCY(KC,3)
26026 IDC=I+MDCY(KC,2)-1
26027 IF(MDME(IDC,1).LT.0) GOTO 330
26028 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26029 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26030 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26031 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26032 WID2=1D0
26033 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26034 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26035 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26036 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26037 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26038 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26039 WDTP(I)=FUDGE*WDTP(I)
26040 WDTP(0)=WDTP(0)+WDTP(I)
26041 IF(MDME(IDC,1).GT.0) THEN
26042 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26043 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26044 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26045 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26046 ENDIF
26047 330 CONTINUE
26048
26049C...UED: kk state width decays : flav: 451 476
26050 ELSEIF(IUED(1).EQ.1.AND.
26051 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26052 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26053 KCLA=PYCOMP(KFLA)
26054C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26055 RMFLAS=PMAS(KCLA,1)
26056 FACSH=SH/PMAS(KCLA,1)**2
26057 ALPHEM=PYALEM(RMFLAS**2)
26058 ALPHS=PYALPS(RMFLAS**2)
26059
26060C...uedcor parameters (alpha_s is calculated at mkk scale)
26061C...alpha_em is calculated at z pole !
26062 ALPHEM=PARU(101)
26063 FACSH=1.
26064
26065 DO 1070 I=1,MDCY(KCLA,3)
26066 IDC=I+MDCY(KCLA,2)-1
26067
26068 IF(MDME(IDC,1).LT.0) GOTO 1070
26069 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26070 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26071 RM1=PMAS(KFC1,1)**2/SH
26072 RM2=PMAS(KFC2,1)**2/SH
26073 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26074 & GOTO 1070
26075 WID2=1D0
26076
26077C...N.B. RINV=RUED(1)
26078 RMKK=RUED(1)
26079 RMWKK=PMAS(475,1)
26080 RMZKK=PMAS(474,1)
26081 SW2=PARU(102)
26082 CW2=1.-SW2
26083 KKCLA=KCLA-KKFLMI+1
26084 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26085 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26086 IF(KKCLA.LE.6) THEN
26087C...q*_S -> q + gamma* (in first time sw21=0)
26088 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26089C...Eventually change the following by enabling a choice of open or closed.
26090C...Only the gamma_kk channel is open.
26091 IF(MOD(I,2).EQ.0)
26092 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26093 WDTP(I)=FACSH*WDTP(I)
26094 WID2=WIDS(473,2)
26095 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26096C...q*_D -> q + Z*/W*
26097 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26098 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26099 IF(I.EQ.1)THEN
26100C...q*_D -> q + Z*
26101 WDTP(I)=0.5*GAMMAW
26102 WID2=WIDS(474,2)
26103 ELSEIF(I.EQ.2)THEN
26104C...q*_D -> q + W*
26105 WDTP(I)=GAMMAW
26106 WID2=WIDS(475,2)
26107 ENDIF
26108 WDTP(I)=FACSH*WDTP(I)
26109C...q*_D -> q + gamma* is closed
26110 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26111C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26112 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26113 RMGAKK=PMAS(473,1)
26114 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26115 + FKAC1(RMGAKK,RMFLAS)**2
26116 WDTP(I)=FACSH*WDTP(I)
26117 WID2=WIDS(473,2)
26118 ELSEIF(KKCLA.EQ.22)THEN
26119 RMQST=PMAS(KKPART,1)
26120 WID2=WIDS(KKPART,2)
26121C...g* -> q*_S/q*_D + q
26122 FAC=10.*ALPHS/12.*RMFLAS
26123 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26124 WDTP(I)=FACSH*WDTP(I)
26125 ELSEIF(KKCLA.EQ.23)THEN
26126C...gamma* decays to graviton + gamma : initial value is used
26127 ICHI=IUED(4)/2
26128 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26129 & *CHIDEL(ICHI)
26130 ELSEIF(KKCLA.EQ.24)THEN
26131C...Z* -> l*_S + l is closed
26132C... Z* -> l*_D + l
26133 IF(I.LE.3)GOTO 1070
26134c... After closing the channels for a Z* decaying into positively charged
26135C... KK lepton singlets, close the channels for a Z* decaying into negatively
26136C... charged KK lepton singlets + positively charged SM particles
26137 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26138 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26139 RMLST=PMAS(KKPART,1)
26140 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26141 WDTP(I)=FACSH*WDTP(I)
26142 WID2=WIDS(KKPART,2)
26143 ELSEIF(KKCLA.EQ.25)THEN
26144C...W* -> l*_D lbar
26145 FAC=3.*ALPHEM/12./SW2*RMWKK
26146 RMLST=PMAS(KKPART,1)
26147 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26148 WDTP(I)=FACSH*WDTP(I)
26149 WID2=WIDS(KKPART,2)
26150 ENDIF
26151 WDTP(0)=WDTP(0)+WDTP(I)
26152 IF(MDME(IDC,1).GT.0) THEN
26153 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26154 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26155 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26156 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26157 ENDIF
26158 1070 CONTINUE
26159 IUEDPR(KKCLA)=1
26160
26161 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26162C...Techni-pi0 and techni-pi0':
26163 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26164 DO 340 I=1,MDCY(KC,3)
26165 IDC=I+MDCY(KC,2)-1
26166 IF(MDME(IDC,1).LT.0) GOTO 340
26167 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26168 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26169 RM1=PM1**2/SH
26170 RM2=PM2**2/SH
26171 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26172 WID2=1D0
26173C...pi_tc -> g + g
26174 IF(I.EQ.8) THEN
26175 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26176 & /(8D0*PARU(1))*SH*SHR
26177 IF(KFLA.EQ.KTECHN+111) THEN
26178 FACP=FACP*RTCM(9)
26179 ELSE
26180 FACP=FACP*RTCM(10)
26181 ENDIF
26182 WDTP(I)=FACP
26183 ELSE
26184C...pi_tc -> f + fbar.
26185 FCOF=1D0
26186 IKA=IABS(KFDP(IDC,1))
26187 IF(IKA.LT.10) FCOF=3D0*RADC
26188 HM1=PM1
26189 HM2=PM2
26190 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26191 FCOF=FCOF*RTCM(1+IKA)**2
26192 HM1=PYMRUN(KFDP(IDC,1),SH)
26193 HM2=PYMRUN(KFDP(IDC,2),SH)
26194 ELSEIF(IKA.EQ.15) THEN
26195 FCOF=FCOF*RTCM(8)**2
26196 ENDIF
26197 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26198 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26199 ENDIF
26200 WDTP(I)=FUDGE*WDTP(I)
26201 WDTP(0)=WDTP(0)+WDTP(I)
26202 IF(MDME(IDC,1).GT.0) THEN
26203 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26204 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26205 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26206 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26207 ENDIF
26208 340 CONTINUE
26209
26210 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26211C...pi+_tc
26212 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26213 DO 350 I=1,MDCY(KC,3)
26214 IDC=I+MDCY(KC,2)-1
26215 IF(MDME(IDC,1).LT.0) GOTO 350
26216 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26217 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26218 PM3=0D0
26219 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26220 RM1=PM1**2/SH
26221 RM2=PM2**2/SH
26222 RM3=PM3**2/SH
26223 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26224 WID2=1D0
26225C...pi_tc -> f + f'.
26226 FCOF=1D0
26227 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26228C...pi_tc+ -> W b b~
26229 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26230 FCOF=3D0*RADC
26231 XMT2=PMAS(6,1)**2/SH
26232 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26233 KFC3=PYCOMP(KFDP(IDC,3))
26234 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26235 CHECK = SQRT(RM1)
26236 T0 = (1D0-CHECK**2)*
26237 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26238 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26239 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26240 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26241 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26242 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26243 & +T3*LOG(CHECK))
26244 IF(KFLR.GT.0) THEN
26245 WID2=WIDS(24,2)
26246 ELSE
26247 WID2=WIDS(24,3)
26248 ENDIF
26249 ELSE
26250 FCOF=1D0
26251 IKA=IABS(KFDP(IDC,1))
26252 IF(IKA.LT.10) FCOF=3D0*RADC
26253 HM1=PM1
26254 HM2=PM2
26255 IF(I.GE.1.AND.I.LE.5) THEN
26256 IF(I.LE.2) THEN
26257 FCOF=FCOF*RTCM(5)**2
26258 ELSEIF(I.LE.4) THEN
26259 FCOF=FCOF*RTCM(6)**2
26260 ELSEIF(I.EQ.5) THEN
26261 FCOF=FCOF*RTCM(7)**2
26262 ENDIF
26263 HM1=PYMRUN(KFDP(IDC,1),SH)
26264 HM2=PYMRUN(KFDP(IDC,2),SH)
26265 ELSEIF(I.EQ.8) THEN
26266 FCOF=FCOF*RTCM(8)**2
26267 ENDIF
26268 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26269 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26270 ENDIF
26271 WDTP(I)=FUDGE*WDTP(I)
26272 WDTP(0)=WDTP(0)+WDTP(I)
26273 IF(MDME(IDC,1).GT.0) THEN
26274 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26275 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26276 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26277 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26278 ENDIF
26279 350 CONTINUE
26280
26281 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26282C...Techni-eta.
26283 FAC=(SH/PARP(46)**2)*SHR
26284 DO 360 I=1,MDCY(KC,3)
26285 IDC=I+MDCY(KC,2)-1
26286 IF(MDME(IDC,1).LT.0) GOTO 360
26287 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26288 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26289 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26290 WID2=1D0
26291 IF(I.LE.2) THEN
26292 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26293 IF(I.EQ.2) WID2=WIDS(6,1)
26294 ELSE
26295 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26296 ENDIF
26297 WDTP(I)=FUDGE*WDTP(I)
26298 WDTP(0)=WDTP(0)+WDTP(I)
26299 IF(MDME(IDC,1).GT.0) THEN
26300 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26301 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26302 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26303 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26304 ENDIF
26305 360 CONTINUE
26306
26307 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26308C...Techni-rho0:
26309 ALPRHT=2.16D0*(3D0/ITCM(1))
26310 FAC=(ALPRHT/12D0)*SHR
26311 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26312 SQMZ=PMAS(23,1)**2
26313 SQMW=PMAS(24,1)**2
26314 SHP=SH
26315 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26316 GMMZ=SHR*WDTPP(0)
26317 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26318 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26319 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26320 DO 370 I=1,MDCY(KC,3)
26321 IDC=I+MDCY(KC,2)-1
26322 IF(MDME(IDC,1).LT.0) GOTO 370
26323 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26324 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26325 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26326 WID2=1D0
26327 IF(I.EQ.1) THEN
26328C...rho_tc0 -> W+ + W-.
26329C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26330 WDTP(I)=FAC*RTCM(3)**4*
26331 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26332 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26333 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26334 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26335 WID2=WIDS(24,1)
26336 ELSEIF(I.EQ.2) THEN
26337C...rho_tc0 -> W+ + pi_tc-.
26338C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26339 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26340 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26341 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26342 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26343 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26344 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26345 ELSEIF(I.EQ.3) THEN
26346C...rho_tc0 -> pi_tc+ + W-.
26347 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26348 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26349 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26350 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
26351 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26352 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
26353 ELSEIF(I.EQ.4) THEN
26354C...rho_tc0 -> pi_tc+ + pi_tc-.
26355 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26356 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26357 WID2=WIDS(PYCOMP(KTECHN+211),1)
26358 ELSEIF(I.EQ.5) THEN
26359C...rho_tc0 -> gamma + pi_tc0
26360 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26361 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26362 & SHR**3
26363 WID2=WIDS(PYCOMP(KTECHN+111),2)
26364 ELSEIF(I.EQ.6) THEN
26365C...rho_tc0 -> gamma + pi_tc0'
26366 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26367 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
26368 WID2=WIDS(PYCOMP(KTECHN+221),2)
26369 ELSEIF(I.EQ.7) THEN
26370C...rho_tc0 -> Z0 + pi_tc0
26371 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26372 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26373 & XW/XW1*SHR**3
26374 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26375 ELSEIF(I.EQ.8) THEN
26376C...rho_tc0 -> Z0 + pi_tc0'
26377 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26378 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26379 & XW/XW1*SHR**3
26380 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26381 ELSEIF(I.EQ.9) THEN
26382C...rho_tc0 -> gamma + Z0
26383 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26384 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26385 WID2=WIDS(23,2)
26386 ELSEIF(I.EQ.10) THEN
26387C...rho_tc0 -> Z0 + Z0
26388 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26389 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
26390 & SHR**3
26391 WID2=WIDS(23,1)
26392 ELSE
26393C...rho_tc0 -> f + fbar.
26394 WID2=1D0
26395 IF(I.LE.18) THEN
26396 IA=I-10
26397 FCOF=3D0*RADC
26398 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26399 ELSE
26400 IA=I-6
26401 FCOF=1D0
26402 IF(IA.GE.17) WID2=WIDS(IA,1)
26403 ENDIF
26404 EI=KCHG(IA,1)/3D0
26405 AI=SIGN(1D0,EI+0.1D0)
26406 VI=AI-4D0*EI*XWV
26407 VALI=0.5D0*(VI+AI)
26408 VARI=0.5D0*(VI-AI)
26409 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26410 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26411 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26412 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26413 ENDIF
26414 WDTP(I)=FUDGE*WDTP(I)
26415 WDTP(0)=WDTP(0)+WDTP(I)
26416 IF(MDME(IDC,1).GT.0) THEN
26417 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26418 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26419 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26420 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26421 ENDIF
26422 370 CONTINUE
26423
26424 ELSEIF(KFLA.EQ.KTECHN+213) THEN
26425C...Techni-rho+/-:
26426 ALPRHT=2.16D0*(3D0/ITCM(1))
26427 FAC=(ALPRHT/12D0)*SHR
26428 SQMZ=PMAS(23,1)**2
26429 SQMW=PMAS(24,1)**2
26430 SHP=SH
26431 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26432 GMMW=SHR*WDTPP(0)
26433 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26434 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26435 DO 380 I=1,MDCY(KC,3)
26436 IDC=I+MDCY(KC,2)-1
26437 IF(MDME(IDC,1).LT.0) GOTO 380
26438 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26439 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26440 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
26441 WID2=1D0
26442 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26443c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26444c & /3D0*SHR**3
26445 IF(I.EQ.1) THEN
26446C...rho_tc+ -> W+ + Z0.
26447C......Goldstone
26448 WDTP(I)=FAC*RTCM(3)**4*
26449 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26450 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
26451 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
26452C......W_L Z_T
26453 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
26454 & /3D0*SHR**3
26455 VA2=0D0
26456 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
26457C......W_T Z_L
26458 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26459 & /3D0*SHR**3
26460 IF(KFLR.GT.0) THEN
26461 WID2=WIDS(24,2)*WIDS(23,2)
26462 ELSE
26463 WID2=WIDS(24,3)*WIDS(23,2)
26464 ENDIF
26465 ELSEIF(I.EQ.2) THEN
26466C...rho_tc+ -> W+ + pi_tc0.
26467 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26468 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26469 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26470 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26471 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26472 IF(KFLR.GT.0) THEN
26473 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
26474 ELSE
26475 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
26476 ENDIF
26477 ELSEIF(I.EQ.3) THEN
26478C...rho_tc+ -> pi_tc+ + Z0.
26479 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26480 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26481 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26482 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
26483 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
26484 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26485 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26486 & SHR**3*XW/XW1
26487 IF(KFLR.GT.0) THEN
26488 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
26489 ELSE
26490 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
26491 ENDIF
26492 ELSEIF(I.EQ.4) THEN
26493C...rho_tc+ -> pi_tc+ + pi_tc0.
26494 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26495 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26496 IF(KFLR.GT.0) THEN
26497 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
26498 ELSE
26499 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
26500 ENDIF
26501 ELSEIF(I.EQ.5) THEN
26502C...rho_tc+ -> pi_tc+ + gamma
26503 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26504 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26505 & SHR**3
26506 IF(KFLR.GT.0) THEN
26507 WID2=WIDS(PYCOMP(KTECHN+211),2)
26508 ELSE
26509 WID2=WIDS(PYCOMP(KTECHN+211),3)
26510 ENDIF
26511 ELSEIF(I.EQ.6) THEN
26512C...rho_tc+ -> W+ + pi_tc0'
26513 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26514 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
26515 IF(KFLR.GT.0) THEN
26516 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
26517 ELSE
26518 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
26519 ENDIF
26520 ELSEIF(I.EQ.7) THEN
26521C...rho_tc+ -> W+ + gamma
26522 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26523 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26524 IF(KFLR.GT.0) THEN
26525 WID2=WIDS(24,2)
26526 ELSE
26527 WID2=WIDS(24,3)
26528 ENDIF
26529 ELSE
26530C...rho_tc+ -> f + fbar'.
26531 IA=I-7
26532 WID2=1D0
26533 IF(IA.LE.16) THEN
26534 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26535 IF(KFLR.GT.0) THEN
26536 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26537 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26538 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26539 ELSE
26540 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26541 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26542 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26543 ENDIF
26544 ELSE
26545 FCOF=1D0
26546 IF(KFLR.GT.0) THEN
26547 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26548 ELSE
26549 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26550 ENDIF
26551 ENDIF
26552 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26553 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26554 ENDIF
26555 WDTP(I)=FUDGE*WDTP(I)
26556 WDTP(0)=WDTP(0)+WDTP(I)
26557 IF(MDME(IDC,1).GT.0) THEN
26558 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26559 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26560 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26561 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26562 ENDIF
26563 380 CONTINUE
26564
26565 ELSEIF(KFLA.EQ.KTECHN+223) THEN
26566C...Techni-omega:
26567 ALPRHT=2.16D0*(3D0/ITCM(1))
26568 FAC=(ALPRHT/12D0)*SHR
26569 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
26570 SQMZ=PMAS(23,1)**2
26571 SHP=SH
26572 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26573 GMMZ=SHR*WDTPP(0)
26574 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26575 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26576 DO 390 I=1,MDCY(KC,3)
26577 IDC=I+MDCY(KC,2)-1
26578 IF(MDME(IDC,1).LT.0) GOTO 390
26579 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26580 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26581 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
26582 WID2=1D0
26583 IF(I.EQ.1) THEN
26584C...omega_tc0 -> gamma + pi_tc0.
26585 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
26586 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
26587 WID2=WIDS(PYCOMP(KTECHN+111),2)
26588 ELSEIF(I.EQ.2) THEN
26589C...omega_tc0 -> Z0 + pi_tc0
26590 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26591 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26592 & XW/XW1*SHR**3
26593 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26594 ELSEIF(I.EQ.3) THEN
26595C...omega_tc0 -> gamma + pi_tc0'
26596 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26597 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26598 & SHR**3
26599 WID2=WIDS(PYCOMP(KTECHN+221),2)
26600 ELSEIF(I.EQ.4) THEN
26601C...omega_tc0 -> Z0 + pi_tc0'
26602 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26603 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26604 & XW/XW1*SHR**3
26605 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26606 ELSEIF(I.EQ.5) THEN
26607C...omega_tc0 -> W+ + pi_tc-
26608 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26609 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26610 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26611 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26612 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26613 ELSEIF(I.EQ.6) THEN
26614C...omega_tc0 -> pi_tc+ + W-
26615 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26616 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26617 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26618 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26619 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26620 ELSEIF(I.EQ.7) THEN
26621C...omega_tc0 -> W+ + W-.
26622C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26623 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
26624 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26625 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26626 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
26627 WID2=WIDS(24,1)
26628 ELSEIF(I.EQ.8) THEN
26629C...omega_tc0 -> pi_tc+ + pi_tc-.
26630 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
26631 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26632 WID2=WIDS(PYCOMP(KTECHN+211),1)
26633C...omega_tc0 -> gamma + Z0
26634 ELSEIF(I.EQ.9) THEN
26635 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26636 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26637 WID2=WIDS(23,2)
26638C...omega_tc0 -> Z0 + Z0
26639 ELSEIF(I.EQ.10) THEN
26640 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26641 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
26642 & /24D0/RTCM(12)**2*SHR**3
26643 WID2=WIDS(23,1)
26644 ELSE
26645C...omega_tc0 -> f + fbar.
26646 WID2=1D0
26647 IF(I.LE.18) THEN
26648 IA=I-10
26649 FCOF=3D0*RADC
26650 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26651 ELSE
26652 IA=I-8
26653 FCOF=1D0
26654 IF(IA.GE.17) WID2=WIDS(IA,1)
26655 ENDIF
26656 EI=KCHG(IA,1)/3D0
26657 AI=SIGN(1D0,EI+0.1D0)
26658 VI=AI-4D0*EI*XWV
26659 VALI=-0.5D0*(VI+AI)
26660 VARI=-0.5D0*(VI-AI)
26661 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26662 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26663 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26664 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26665 ENDIF
26666 WDTP(I)=FUDGE*WDTP(I)
26667 WDTP(0)=WDTP(0)+WDTP(I)
26668 IF(MDME(IDC,1).GT.0) THEN
26669 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26670 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26671 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26672 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26673 ENDIF
26674 390 CONTINUE
26675
26676C.....V8 -> quark anti-quark
26677 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
26678 FAC=AS/6D0*SHR
26679 TANT3=RTCM(21)
26680 IF(ITCM(2).EQ.0) THEN
26681 IMDL=1
26682 ELSEIF(ITCM(2).EQ.1) THEN
26683 IMDL=2
26684 ENDIF
26685 DO 400 I=1,MDCY(KC,3)
26686 IDC=I+MDCY(KC,2)-1
26687 IF(MDME(IDC,1).LT.0) GOTO 400
26688 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26689 RM1=PM1**2/SH
26690 IF(RM1.GT.0.25D0) GOTO 400
26691 WID2=1D0
26692 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26693 FMIX=1D0/TANT3**2
26694 ELSE
26695 FMIX=TANT3**2
26696 ENDIF
26697 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
26698 IF(I.EQ.6) WID2=WIDS(6,1)
26699 WDTP(I)=FUDGE*WDTP(I)
26700 WDTP(0)=WDTP(0)+WDTP(I)
26701 IF(MDME(IDC,1).GT.0) THEN
26702 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26703 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26704 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26705 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26706 ENDIF
26707 400 CONTINUE
26708
26709 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
26710 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
26711 CLEBF=0D0
26712 DO 410 I=1,MDCY(KC,3)
26713 IDC=I+MDCY(KC,2)-1
26714 IF(MDME(IDC,1).LT.0) GOTO 410
26715 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26716 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26717 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
26718 WID2=1D0
26719C...pi_tc -> g + g
26720 IF(I.EQ.7) THEN
26721 IF(KFLA.EQ.KTECHN+100111) THEN
26722 CLEBG=4D0/3D0
26723 ELSE
26724 CLEBG=5D0/3D0
26725 ENDIF
26726 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
26727 & /(2D0*PARU(1))*SH*SHR*CLEBG
26728 WDTP(I)=FACP
26729 ELSE
26730C...pi_tc -> f + fbar.
26731 IF(I.EQ.6) WID2=WIDS(6,1)
26732 FCOF=1D0
26733 IKA=IABS(KFDP(IDC,1))
26734 IF(IKA.LT.10) FCOF=3D0*RADC
26735 HM1=PYMRUN(KFDP(IDC,1),SH)
26736 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
26737 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26738 ENDIF
26739 WDTP(I)=FUDGE*WDTP(I)
26740 WDTP(0)=WDTP(0)+WDTP(I)
26741 IF(MDME(IDC,1).GT.0) THEN
26742 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26743 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26744 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26745 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26746 ENDIF
26747 410 CONTINUE
26748
26749 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
26750 FAC=AS/6D0*SHR
26751 ALPRHT=2.16D0*(3D0/ITCM(1))
26752 TANT3=RTCM(21)
26753 SIN2T=2D0*TANT3/(TANT3**2+1D0)
26754 SINT3=TANT3/SQRT(TANT3**2+1D0)
26755 CSXPP=RTCM(22)
26756 RM82=RTCM(27)**2
26757 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
26758 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
26759 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
26760 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
26761 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
26762 & SINT3**2)*2D0
26763 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
26764 & SINT3**2)*2D0
26765 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
26766
26767 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
26768 GMV8=SHR*WDTPP(0)
26769 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
26770 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
26771 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
26772 IF(ITCM(2).EQ.0) THEN
26773 IMDL=1
26774 ELSE
26775 IMDL=2
26776 ENDIF
26777 DO 420 I=1,MDCY(KC,3)
26778 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
26779 & KFLA.EQ.KTECHN+300113)) GOTO 420
26780 IDC=I+MDCY(KC,2)-1
26781 IF(MDME(IDC,1).LT.0) GOTO 420
26782 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26783 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26784 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
26785 WID2=1D0
26786 IF(I.LE.6) THEN
26787 IF(I.EQ.6) WID2=WIDS(6,1)
26788 XIG=1D0
26789 IF(KFLA.EQ.KTECHN+200113) THEN
26790 XIG=0D0
26791 XIJ=X12
26792 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
26793 XIG=0D0
26794 XIJ=X21
26795 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
26796 XIJ=X11
26797 ELSE
26798 XIJ=X22
26799 ENDIF
26800 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26801 FMIX=1D0/TANT3/SIN2T
26802 ELSE
26803 FMIX=-TANT3/SIN2T
26804 ENDIF
26805 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
26806 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
26807 ELSEIF(I.EQ.7) THEN
26808 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
26809 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
26810 PSH=SHR*(1D0-RM1)/2D0
26811 WDTP(I)=AS/9D0*PSH**3/RM82
26812 IF(I.EQ.8) THEN
26813 WDTP(I)=2D0*WDTP(I)*CSXPP**2
26814 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26815 ELSE
26816 WDTP(I)=5D0*WDTP(I)
26817 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26818 ENDIF
26819 ENDIF
26820 WDTP(I)=FUDGE*WDTP(I)
26821 WDTP(0)=WDTP(0)+WDTP(I)
26822 IF(MDME(IDC,1).GT.0) THEN
26823 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26824 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26825 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26826 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26827 ENDIF
26828 420 CONTINUE
26829
26830 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
26831C...d* excited quark.
26832 FAC=(SH/RTCM(41)**2)*SHR
26833 DO 430 I=1,MDCY(KC,3)
26834 IDC=I+MDCY(KC,2)-1
26835 IF(MDME(IDC,1).LT.0) GOTO 430
26836 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26837 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26838 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
26839 WID2=1D0
26840 IF(I.EQ.1) THEN
26841C...d* -> g + d.
26842 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26843 WID2=1D0
26844 ELSEIF(I.EQ.2) THEN
26845C...d* -> gamma + d.
26846 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26847 WDTP(I)=FAC*AEM*QF**2/4D0
26848 WID2=1D0
26849 ELSEIF(I.EQ.3) THEN
26850C...d* -> Z0 + d.
26851 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26852 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26853 & (1D0-RM1)**2*(2D0+RM1)
26854 WID2=WIDS(23,2)
26855 ELSEIF(I.EQ.4) THEN
26856C...d* -> W- + u.
26857 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26858 & (1D0-RM1)**2*(2D0+RM1)
26859 IF(KFLR.GT.0) WID2=WIDS(24,3)
26860 IF(KFLR.LT.0) WID2=WIDS(24,2)
26861 ENDIF
26862 WDTP(I)=FUDGE*WDTP(I)
26863 WDTP(0)=WDTP(0)+WDTP(I)
26864 IF(MDME(IDC,1).GT.0) THEN
26865 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26866 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26867 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26868 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26869 ENDIF
26870 430 CONTINUE
26871
26872 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26873C...u* excited quark.
26874 FAC=(SH/RTCM(41)**2)*SHR
26875 DO 440 I=1,MDCY(KC,3)
26876 IDC=I+MDCY(KC,2)-1
26877 IF(MDME(IDC,1).LT.0) GOTO 440
26878 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26879 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26880 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26881 WID2=1D0
26882 IF(I.EQ.1) THEN
26883C...u* -> g + u.
26884 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26885 WID2=1D0
26886 ELSEIF(I.EQ.2) THEN
26887C...u* -> gamma + u.
26888 QF=RTCM(43)/2D0+RTCM(44)/6D0
26889 WDTP(I)=FAC*AEM*QF**2/4D0
26890 WID2=1D0
26891 ELSEIF(I.EQ.3) THEN
26892C...u* -> Z0 + u.
26893 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26894 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26895 & (1D0-RM1)**2*(2D0+RM1)
26896 WID2=WIDS(23,2)
26897 ELSEIF(I.EQ.4) THEN
26898C...u* -> W+ + d.
26899 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26900 & (1D0-RM1)**2*(2D0+RM1)
26901 IF(KFLR.GT.0) WID2=WIDS(24,2)
26902 IF(KFLR.LT.0) WID2=WIDS(24,3)
26903 ENDIF
26904 WDTP(I)=FUDGE*WDTP(I)
26905 WDTP(0)=WDTP(0)+WDTP(I)
26906 IF(MDME(IDC,1).GT.0) THEN
26907 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26908 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26909 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26910 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26911 ENDIF
26912 440 CONTINUE
26913
26914 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26915C...e* excited lepton.
26916 FAC=(SH/RTCM(41)**2)*SHR
26917 DO 450 I=1,MDCY(KC,3)
26918 IDC=I+MDCY(KC,2)-1
26919 IF(MDME(IDC,1).LT.0) GOTO 450
26920 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26921 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26922 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26923 WID2=1D0
26924 IF(I.EQ.1) THEN
26925C...e* -> gamma + e.
26926 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26927 WDTP(I)=FAC*AEM*QF**2/4D0
26928 WID2=1D0
26929 ELSEIF(I.EQ.2) THEN
26930C...e* -> Z0 + e.
26931 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26932 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26933 & (1D0-RM1)**2*(2D0+RM1)
26934 WID2=WIDS(23,2)
26935 ELSEIF(I.EQ.3) THEN
26936C...e* -> W- + nu.
26937 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26938 & (1D0-RM1)**2*(2D0+RM1)
26939 IF(KFLR.GT.0) WID2=WIDS(24,3)
26940 IF(KFLR.LT.0) WID2=WIDS(24,2)
26941 ENDIF
26942 WDTP(I)=FUDGE*WDTP(I)
26943 WDTP(0)=WDTP(0)+WDTP(I)
26944 IF(MDME(IDC,1).GT.0) THEN
26945 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26946 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26947 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26948 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26949 ENDIF
26950 450 CONTINUE
26951
26952 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26953C...nu*_e excited neutrino.
26954 FAC=(SH/RTCM(41)**2)*SHR
26955 DO 460 I=1,MDCY(KC,3)
26956 IDC=I+MDCY(KC,2)-1
26957 IF(MDME(IDC,1).LT.0) GOTO 460
26958 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26959 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26960 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26961 WID2=1D0
26962 IF(I.EQ.1) THEN
26963C...nu*_e -> Z0 + nu*_e.
26964 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26965 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26966 & (1D0-RM1)**2*(2D0+RM1)
26967 WID2=WIDS(23,2)
26968 ELSEIF(I.EQ.2) THEN
26969C...nu*_e -> W+ + e.
26970 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26971 & (1D0-RM1)**2*(2D0+RM1)
26972 IF(KFLR.GT.0) WID2=WIDS(24,2)
26973 IF(KFLR.LT.0) WID2=WIDS(24,3)
26974 ENDIF
26975 WDTP(I)=FUDGE*WDTP(I)
26976 WDTP(0)=WDTP(0)+WDTP(I)
26977 IF(MDME(IDC,1).GT.0) THEN
26978 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26979 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26980 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26981 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26982 ENDIF
26983 460 CONTINUE
26984
26985 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26986C...G* (graviton resonance):
26987 FAC=(PARP(50)**2/PARU(1))*SHR
26988 DO 470 I=1,MDCY(KC,3)
26989 IDC=I+MDCY(KC,2)-1
26990 IF(MDME(IDC,1).LT.0) GOTO 470
26991 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26992 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26993 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26994 WID2=1D0
26995 IF(I.LE.8) THEN
26996C...G* -> q + qbar
26997 FCOF=3D0*RADC
26998 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26999 & PYHFTH(SH,SH*RM1,1D0)
27000 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27001 & (1D0+8D0*RM1/3D0)/320D0
27002 IF(I.EQ.6) WID2=WIDS(6,1)
27003 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27004 ELSEIF(I.LE.16) THEN
27005C...G* -> l+ + l-, nu + nubar
27006 FCOF=1D0
27007 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27008 & (1D0+8D0*RM1/3D0)/320D0
27009 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27010 ELSEIF(I.EQ.17) THEN
27011C...G* -> g + g.
27012 WDTP(I)=FAC/20D0
27013 ELSEIF(I.EQ.18) THEN
27014C...G* -> gamma + gamma.
27015 WDTP(I)=FAC/160D0
27016 ELSEIF(I.EQ.19) THEN
27017C...G* -> Z0 + Z0.
27018 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27019 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27020 WID2=WIDS(23,1)
27021 ELSEIF(I.EQ.20) THEN
27022C...G* -> W+ + W-.
27023 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27024 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27025 WID2=WIDS(24,1)
27026 ENDIF
27027 WDTP(I)=FUDGE*WDTP(I)
27028 WDTP(0)=WDTP(0)+WDTP(I)
27029 IF(MDME(IDC,1).GT.0) THEN
27030 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27031 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27032 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27033 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27034 ENDIF
27035 470 CONTINUE
27036
27037 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27038C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27039 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27040 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27041 DO 480 I=1,MDCY(KC,3)
27042 IDC=I+MDCY(KC,2)-1
27043 IF(MDME(IDC,1).LT.0) GOTO 480
27044 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27045 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27046 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27047 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27048 WID2=1D0
27049 IF(I.LE.9) THEN
27050C...nu_lR -> l- qbar q'
27051 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27052 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27053 ELSEIF(I.LE.18) THEN
27054C...nu_lR -> l+ q qbar'
27055 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27056 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27057 ELSE
27058C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27059 FCOF=1D0
27060 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27061 ENDIF
27062 X=(PM1+PM2+PM3)/SHR
27063 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27064 Y=(SHR/PMWR)**2
27065 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27066 WDTP(I)=FAC*FCOF*FX*FY
27067 WDTP(I)=FUDGE*WDTP(I)
27068 WDTP(0)=WDTP(0)+WDTP(I)
27069 IF(MDME(IDC,1).GT.0) THEN
27070 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27071 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27072 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27073 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27074 ENDIF
27075 480 CONTINUE
27076
27077 ELSEIF(KFLA.EQ.9900023) THEN
27078C...Z_R0:
27079 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27080 DO 490 I=1,MDCY(KC,3)
27081 IDC=I+MDCY(KC,2)-1
27082 IF(MDME(IDC,1).LT.0) GOTO 490
27083 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27084 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27085 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27086 WID2=1D0
27087 SYMMET=1D0
27088 IF(I.LE.6) THEN
27089C...Z_R0 -> q + qbar
27090 EF=KCHG(I,1)/3D0
27091 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27092 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27093 FCOF=3D0*RADC
27094 IF(I.EQ.6) WID2=WIDS(6,1)
27095 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27096C...Z_R0 -> l+ + l-
27097 AF=-(1D0-2D0*XW)
27098 VF=-1D0+4D0*XW
27099 FCOF=1D0
27100 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27101C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27102 AF=-2D0*XW
27103 VF=0D0
27104 FCOF=1D0
27105 SYMMET=0.5D0
27106 ELSEIF(I.LE.15) THEN
27107C...Z0 -> nu_R + nu_R, assumed Majorana.
27108 AF=2D0*XW1
27109 VF=0D0
27110 FCOF=1D0
27111 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27112 SYMMET=0.5D0
27113 ENDIF
27114 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27115 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27116 WDTP(I)=FUDGE*WDTP(I)
27117 WDTP(0)=WDTP(0)+WDTP(I)
27118 IF(MDME(IDC,1).GT.0) THEN
27119 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27120 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27121 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27122 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27123 ENDIF
27124 490 CONTINUE
27125
27126 ELSEIF(KFLA.EQ.9900024) THEN
27127C...W_R+/-:
27128 FAC=(AEM/(24D0*XW))*SHR
27129 DO 500 I=1,MDCY(KC,3)
27130 IDC=I+MDCY(KC,2)-1
27131 IF(MDME(IDC,1).LT.0) GOTO 500
27132 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27133 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27134 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27135 WID2=1D0
27136 IF(I.LE.9) THEN
27137C...W_R+/- -> q + qbar'
27138 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27139 IF(KFLR.GT.0) THEN
27140 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27141 ELSE
27142 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27143 ENDIF
27144 ELSEIF(I.LE.12) THEN
27145C...W_R+/- -> l+/- + nu_R
27146 FCOF=1D0
27147 ENDIF
27148 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27149 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27150 WDTP(I)=FUDGE*WDTP(I)
27151 WDTP(0)=WDTP(0)+WDTP(I)
27152 IF(MDME(IDC,1).GT.0) THEN
27153 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27154 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27155 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27156 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27157 ENDIF
27158 500 CONTINUE
27159
27160 ELSEIF(KFLA.EQ.9900041) THEN
27161C...H_L++/--:
27162 FAC=(1D0/(8D0*PARU(1)))*SHR
27163 DO 510 I=1,MDCY(KC,3)
27164 IDC=I+MDCY(KC,2)-1
27165 IF(MDME(IDC,1).LT.0) GOTO 510
27166 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27167 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27168 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27169 WID2=1D0
27170 IF(I.LE.6) THEN
27171C...H_L++/-- -> l+/- + l'+/-
27172 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27173 & (IABS(KFDP(IDC,2))-9)/2)**2
27174 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27175 ELSEIF(I.EQ.7) THEN
27176C...H_L++/-- -> W_L+/- + W_L+/-
27177 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27178 & (3D0*RM1+0.25D0/RM1-1D0)
27179 WID2=WIDS(24,4+(1-KFLS)/2)
27180 ENDIF
27181 WDTP(I)=FAC*FCOF*
27182 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27183 WDTP(I)=FUDGE*WDTP(I)
27184 WDTP(0)=WDTP(0)+WDTP(I)
27185 IF(MDME(IDC,1).GT.0) THEN
27186 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27187 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27188 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27189 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27190 ENDIF
27191 510 CONTINUE
27192
27193 ELSEIF(KFLA.EQ.9900042) THEN
27194C...H_R++/--:
27195 FAC=(1D0/(8D0*PARU(1)))*SHR
27196 DO 520 I=1,MDCY(KC,3)
27197 IDC=I+MDCY(KC,2)-1
27198 IF(MDME(IDC,1).LT.0) GOTO 520
27199 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27200 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27201 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27202 WID2=1D0
27203 IF(I.LE.6) THEN
27204C...H_R++/-- -> l+/- + l'+/-
27205 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27206 & (IABS(KFDP(IDC,2))-9)/2)**2
27207 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27208 ELSEIF(I.EQ.7) THEN
27209C...H_R++/-- -> W_R+/- + W_R+/-
27210 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27211 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27212 ENDIF
27213 WDTP(I)=FAC*FCOF*
27214 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27215 WDTP(I)=FUDGE*WDTP(I)
27216 WDTP(0)=WDTP(0)+WDTP(I)
27217 IF(MDME(IDC,1).GT.0) THEN
27218 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27219 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27220 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27221 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27222 ENDIF
27223 520 CONTINUE
27224
27225 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27226C...Techni-a2:
27227C...Need to update to alpha_rho
27228 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27229 FAC=(ALPRHT/12D0)*SHR
27230 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27231 SQMZ=PMAS(23,1)**2
27232 SQMW=PMAS(24,1)**2
27233 SHP=SH
27234 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27235 GMMZ=SHR*WDTPP(0)
27236 XWRHT=1D0/(4D0*XW*(1D0-XW))
27237 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27238 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27239 DO 530 I=1,MDCY(KC,3)
27240 IDC=I+MDCY(KC,2)-1
27241 IF(MDME(IDC,1).LT.0) GOTO 530
27242 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27243 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27244 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27245 WID2=1D0
27246 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27247 IF(I.LE.4) THEN
27248 FACPV=PCM**2
27249 FACPA=PCM**2+1.5D0*RM1
27250 VA2=0D0
27251 AA2=0D0
27252C...a2_tc0 -> W+ + W-
27253 IF(I.EQ.1) THEN
27254 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27255C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27256 WID2=WIDS(24,1)
27257C...a2_tc0 -> W+ + pi_tc- + c.c.
27258 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27259 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27260 IF(I.EQ.6) THEN
27261 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27262 ELSE
27263 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27264 ENDIF
27265 ELSEIF(I.EQ.4) THEN
27266C...a2_tc0 -> Z0 + pi_tc0'
27267 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27268 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27269 ENDIF
27270 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27271 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27272 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27273 FACPA=PCM**2*(1D0+RM1+RM2)
27274 VA2=0D0
27275 AA2=0D0
27276 IF(I.EQ.5) THEN
27277C...a_T^0 -> gamma rho_T^0
27278 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27279 WID2=WIDS(PYCOMP(KTECHN+113),2)
27280 ELSEIF(I.EQ.6) THEN
27281C...a_T^0 -> gamma omega_T
27282 VA2=1D0/RTCM(50)**4
27283 WID2=WIDS(PYCOMP(KTECHN+223),2)
27284 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27285C...a_T^0 -> W^+- rho_T^-+
27286 AA2=.25D0/XW/RTCM(51)**4
27287 IF(I.EQ.7) THEN
27288 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27289 ELSE
27290 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27291 ENDIF
27292 ELSEIF(I.EQ.9) THEN
27293C...a_T^0 -> Z^0 rho_T^0
27294 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27295 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27296 ELSEIF(I.EQ.10) THEN
27297C...a_T^0 -> Z^0 omega_T
27298 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27299 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27300 ENDIF
27301 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27302 ELSE
27303C...a2_tc0 -> f + fbar.
27304 WID2=1D0
27305 IF(I.LE.18) THEN
27306 IA=I-10
27307 FCOF=3D0*RADC
27308 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27309 ELSE
27310 IA=I-8
27311 FCOF=1D0
27312 IF(IA.GE.17) WID2=WIDS(IA,1)
27313 ENDIF
27314 EI=KCHG(IA,1)/3D0
27315 AI=SIGN(1D0,EI+0.1D0)
27316 VI=AI-4D0*EI*XWV
27317 VALI=0.5D0*(VI+AI)
27318 VARI=0.5D0*(VI-AI)
27319 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27320 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27321 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27322 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27323 ENDIF
27324 WDTP(I)=FUDGE*WDTP(I)
27325 WDTP(0)=WDTP(0)+WDTP(I)
27326 IF(MDME(IDC,1).GT.0) THEN
27327 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27328 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27329 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27330 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27331 ENDIF
27332 530 CONTINUE
27333
27334 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27335C...Techni-a2+/-:
27336 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27337 FAC=(ALPRHT/12D0)*SHR
27338 SQMZ=PMAS(23,1)**2
27339 SQMW=PMAS(24,1)**2
27340 SHP=SH
27341 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27342 GMMW=SHR*WDTPP(0)
27343 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27344 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27345 DO 540 I=1,MDCY(KC,3)
27346 IDC=I+MDCY(KC,2)-1
27347 IF(MDME(IDC,1).LT.0) GOTO 540
27348 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27349 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27350 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
27351 WID2=1D0
27352 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27353 IF(KFLR.GT.0) THEN
27354 ICHANN=2
27355 ELSE
27356 ICHANN=3
27357 ENDIF
27358 IF(I.LE.7) THEN
27359 AA2=0
27360 VA2=0
27361C...a2_tc+ -> gamma + W+.
27362 IF(I.EQ.1) THEN
27363 AA2=RTCM(3)**2/RTCM(49)**2
27364 WID2=WIDS(24,ICHANN)
27365C...a2_tc+ -> gamma + pi_tc+.
27366 ELSEIF(I.EQ.2) THEN
27367 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
27368 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
27369C...a2_tc+ -> W+ + Z
27370 ELSEIF(I.EQ.3) THEN
27371 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
27372 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
27373 WID2=WIDS(24,ICHANN)*WIDS(23,2)
27374C...a2_tc+ -> W+ + pi_tc0.
27375 ELSEIF(I.EQ.4) THEN
27376 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27377 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
27378C...a2_tc+ -> W+ + pi_tc'0.
27379 ELSEIF(I.EQ.5) THEN
27380 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
27381 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
27382C...a2_tc+ -> Z0 + pi_tc+.
27383 ELSEIF(I.EQ.6) THEN
27384 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
27385 & RTCM(49)**2
27386 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
27387 ENDIF
27388 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27389 & /3D0*SHR**3
27390 ELSEIF(I.LE.10) THEN
27391 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27392 FACPA=PCM**2*(1D0+RM1+RM2)
27393 VA2=0D0
27394 AA2=0D0
27395C...a2_tc+ -> gamma + rho_tc+
27396 IF(I.EQ.7) THEN
27397 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27398 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
27399C...a2_tc+ -> W+ + rho_T^0
27400 ELSEIF(I.EQ.8) THEN
27401 AA2=1D0/(4D0*XW)/RTCM(51)**4
27402 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
27403C...a2_tc+ -> W+ + omega_T
27404 ELSEIF(I.EQ.9) THEN
27405 VA2=.25D0/XW/RTCM(50)**4
27406 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
27407C...a2_tc+ -> Z^0 + rho_T^+
27408 ELSEIF(I.EQ.10) THEN
27409 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27410 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
27411 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
27412 ENDIF
27413 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27414 ELSE
27415C...a2_tc+ -> f + fbar'.
27416 IA=I-10
27417 WID2=1D0
27418 IF(IA.LE.16) THEN
27419 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27420 IF(KFLR.GT.0) THEN
27421 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27422 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27423 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27424 ELSE
27425 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27426 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27427 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27428 ENDIF
27429 ELSE
27430 FCOF=1D0
27431 IF(KFLR.GT.0) THEN
27432 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27433 ELSE
27434 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27435 ENDIF
27436 ENDIF
27437 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27438 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27439 ENDIF
27440 WDTP(I)=FUDGE*WDTP(I)
27441 WDTP(0)=WDTP(0)+WDTP(I)
27442 IF(MDME(IDC,1).GT.0) THEN
27443 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27444 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27445 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27446 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27447 ENDIF
27448 540 CONTINUE
27449
27450 ENDIF
27451 MINT(61)=0
27452 MINT(62)=0
27453 MINT(63)=0
27454 RETURN
27455 END
27456
27457C***********************************************************************
27458
27459C...PYOFSH
27460C...Calculates partial width and differential cross-section maxima
27461C...of channels/processes not allowed on mass-shell, and selects
27462C...masses in such channels/processes.
27463
27464 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27465
27466C...Double precision and integer declarations.
27467 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27468 IMPLICIT INTEGER(I-N)
27469 INTEGER PYK,PYCHGE,PYCOMP
27470C...Commonblocks.
27471 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27472 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27473 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27474 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27475 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27476 COMMON/PYINT1/MINT(400),VINT(400)
27477 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27478 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27479 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
27480 &/PYINT2/,/PYINT5/
27481C...Local arrays.
27482 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
27483 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
27484 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
27485 &WDTE(0:400,0:5)
27486
27487C...Find if particles equal, maximum mass, matrix elements, etc.
27488 MINT(51)=0
27489 ISUB=MINT(1)
27490 KFD(1)=IABS(KFD1)
27491 KFD(2)=IABS(KFD2)
27492 MEQL=0
27493 IF(KFD(1).EQ.KFD(2)) MEQL=1
27494 MLM=0
27495 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
27496 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
27497 NOFF=44
27498 PMMX=PMMO
27499 ELSE
27500 NOFF=40
27501 PMMX=VINT(1)
27502 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
27503 ENDIF
27504 MMED=0
27505 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
27506 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
27507 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
27508 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
27509 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
27510 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
27511 LOOP=1
27512
27513C...Find where Breit-Wigners are required, else select discrete masses.
27514 100 DO 110 I=1,2
27515 KFCA=PYCOMP(KFD(I))
27516 IF(KFCA.GT.0) THEN
27517 PMD(I)=PMAS(KFCA,1)
27518 PGD(I)=PMAS(KFCA,2)
27519 ELSE
27520 PMD(I)=0D0
27521 PGD(I)=0D0
27522 ENDIF
27523 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
27524 MBW(I)=0
27525 PMG(I)=PMD(I)
27526 RMG(I)=(PMG(I)/PMMX)**2
27527 ELSE
27528 MBW(I)=1
27529 ENDIF
27530 110 CONTINUE
27531
27532C...Find allowed mass range and Breit-Wigner parameters.
27533 DO 120 I=1,2
27534 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
27535 PML(I)=PARP(42)
27536 PMU(I)=PMMX-PARP(42)
27537 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27538 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27539 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
27540 ILM=I
27541 IF(MLM.EQ.2) ILM=3-I
27542 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
27543 IF(MBW(3-I).EQ.0) THEN
27544 PMU(I)=PMMX-PMD(3-I)
27545 ELSE
27546 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
27547 ENDIF
27548 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
27549 & MIN(PMU(I),CKIN(NOFF+2*ILM))
27550 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27551 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27552 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27553 IF(MBW(I).EQ.1) THEN
27554 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27555 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27556 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27557 & PGD(I)))
27558 ENDIF
27559 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
27560 ILM=I
27561 IF(MLM.EQ.2) ILM=3-I
27562 PML(I)=MAX(CKIN(48+I),PARP(42))
27563 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
27564 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27565 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27566 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27567 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27568 IF(MBW(I).EQ.1) THEN
27569 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27570 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27571 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27572 & PGD(I)))
27573 ENDIF
27574 ENDIF
27575 120 CONTINUE
27576 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
27577 &THEN
27578 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
27579 MINT(51)=1
27580 RETURN
27581 ENDIF
27582
27583C...Calculation of partial width of resonance.
27584 IF(MOFSH.EQ.1) THEN
27585
27586C..If only one integration, pick that to be the inner.
27587 IF(MBW(1).EQ.0) THEN
27588 PM2=PMD(1)
27589 PMD(1)=PMD(2)
27590 PGD(1)=PGD(2)
27591 PML(1)=PML(2)
27592 PMU(1)=PMU(2)
27593 ELSEIF(MBW(2).EQ.0) THEN
27594 PM2=PMD(2)
27595 ENDIF
27596
27597C...Start outer loop of integration.
27598 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27599 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27600 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27601 NPT2=1
27602 XPT2(1)=1D0
27603 INX2(1)=0
27604 FMAX2=0D0
27605 ENDIF
27606 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27607 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
27608 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
27609 ENDIF
27610 RM2=(PM2/PMMX)**2
27611
27612C...Start inner loop of integration.
27613 PML1=PML(1)
27614 PMU1=MIN(PMU(1),PMMX-PM2)
27615 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
27616 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27617 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27618 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
27619 FUNC2=0D0
27620 GOTO 180
27621 ENDIF
27622 NPT1=1
27623 XPT1(1)=1D0
27624 INX1(1)=0
27625 FMAX1=0D0
27626 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
27627 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
27628 RM1=(PM1/PMMX)**2
27629
27630C...Evaluate function value - inner loop.
27631 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27632 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
27633 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
27634 & RM2**2+10D0*RM1*RM2)
27635 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
27636 FPT1(NPT1)=FUNC1
27637
27638C...Go to next position in inner loop.
27639 IF(NPT1.EQ.1) THEN
27640 NPT1=NPT1+1
27641 XPT1(NPT1)=0D0
27642 INX1(NPT1)=1
27643 GOTO 140
27644 ELSEIF(NPT1.LE.8) THEN
27645 NPT1=NPT1+1
27646 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
27647 ISH1=ISH1+1
27648 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27649 INX1(NPT1)=INX1(ISH1)
27650 INX1(ISH1)=NPT1
27651 GOTO 140
27652 ELSEIF(NPT1.LT.100) THEN
27653 ISN1=ISH1
27654 150 ISH1=ISH1+1
27655 IF(ISH1.GT.NPT1) ISH1=2
27656 IF(ISH1.EQ.ISN1) GOTO 160
27657 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
27658 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
27659 NPT1=NPT1+1
27660 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27661 INX1(NPT1)=INX1(ISH1)
27662 INX1(ISH1)=NPT1
27663 GOTO 140
27664 ENDIF
27665
27666C...Calculate integral over inner loop.
27667 160 FSUM1=0D0
27668 DO 170 IPT1=2,NPT1
27669 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
27670 & (XPT1(INX1(IPT1))-XPT1(IPT1))
27671 170 CONTINUE
27672 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
27673 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27674 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
27675 FPT2(NPT2)=FUNC2
27676
27677C...Go to next position in outer loop.
27678 IF(NPT2.EQ.1) THEN
27679 NPT2=NPT2+1
27680 XPT2(NPT2)=0D0
27681 INX2(NPT2)=1
27682 GOTO 130
27683 ELSEIF(NPT2.LE.8) THEN
27684 NPT2=NPT2+1
27685 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
27686 ISH2=ISH2+1
27687 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27688 INX2(NPT2)=INX2(ISH2)
27689 INX2(ISH2)=NPT2
27690 GOTO 130
27691 ELSEIF(NPT2.LT.100) THEN
27692 ISN2=ISH2
27693 190 ISH2=ISH2+1
27694 IF(ISH2.GT.NPT2) ISH2=2
27695 IF(ISH2.EQ.ISN2) GOTO 200
27696 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
27697 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
27698 NPT2=NPT2+1
27699 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27700 INX2(NPT2)=INX2(ISH2)
27701 INX2(ISH2)=NPT2
27702 GOTO 130
27703 ENDIF
27704
27705C...Calculate integral over outer loop.
27706 200 FSUM2=0D0
27707 DO 210 IPT2=2,NPT2
27708 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
27709 & (XPT2(INX2(IPT2))-XPT2(IPT2))
27710 210 CONTINUE
27711 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
27712 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
27713 ELSE
27714 FSUM2=FUNC2
27715 ENDIF
27716
27717C...Save result; second integration for user-selected mass range.
27718 IF(LOOP.EQ.1) WIDW=FSUM2
27719 WID2=FSUM2
27720 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
27721 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
27722 LOOP=2
27723 GOTO 100
27724 ENDIF
27725 RET1=WIDW
27726 RET2=WID2/WIDW
27727
27728C...Select two decay product masses of a resonance.
27729 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
27730 220 DO 230 I=1,2
27731 IF(MBW(I).EQ.0) GOTO 230
27732 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
27733 & (ATU(I)-ATL(I)))
27734 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
27735 RMG(I)=(PMG(I)/PMMX)**2
27736 230 CONTINUE
27737 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27738 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
27739
27740C...Weight with matrix element (if none known, use beta factor).
27741 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
27742 IF(MMED.EQ.1) THEN
27743 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
27744 ELSEIF(MMED.EQ.2) THEN
27745 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
27746 & RMG(2)**2+10D0*RMG(1)*RMG(2))
27747 ELSEIF(MMED.EQ.3) THEN
27748 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
27749 ELSE
27750 WTBE=FLAM
27751 ENDIF
27752 IF(WTBE.LT.PYR(0)) GOTO 220
27753 RET1=PMG(1)
27754 RET2=PMG(2)
27755
27756C...Find suitable set of masses for initialization of 2 -> 2 processes.
27757 ELSEIF(MOFSH.EQ.3) THEN
27758 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
27759 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
27760 PMG(2)=PMD(2)
27761 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
27762 PMG(1)=PMD(1)
27763 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
27764 ELSE
27765 IDIV=-1
27766 240 IDIV=IDIV+1
27767 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
27768 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
27769 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
27770 ENDIF
27771 RET1=PMG(1)
27772 RET2=PMG(2)
27773
27774C...Evaluate importance of excluded tails of Breit-Wigners.
27775 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27776 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27777 IF(MEQL.LE.1) THEN
27778 VINT(80)=1D0
27779 DO 250 I=1,2
27780 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
27781 & PARU(1)
27782 250 CONTINUE
27783 ELSE
27784 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
27785 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
27786 ENDIF
27787 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
27788 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
27789 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
27790 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27791
27792C...Pick one particle to be the lighter (if improves efficiency).
27793 ELSEIF(MOFSH.EQ.4) THEN
27794 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27795 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27796 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
27797
27798C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27799 DO 270 I=1,2
27800 IF(MBW(I).EQ.0) GOTO 270
27801 PMV=PMU(I)
27802 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27803 ATV=ATU(I)
27804 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27805 RBR=PYR(0)
27806 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27807 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
27808 IF(RBR.LT.0.8D0) THEN
27809 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
27810 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
27811 ELSEIF(RBR.LT.0.9D0) THEN
27812 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
27813 ELSEIF(RBR.LT.1.5D0) THEN
27814 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
27815 ELSE
27816 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
27817 & (PMV**2-PML(I)**2))))
27818 ENDIF
27819 270 CONTINUE
27820 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27821 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
27822 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
27823 NGEN(0,1)=NGEN(0,1)+1
27824 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
27825 GOTO 260
27826 ELSE
27827 MINT(51)=1
27828 RETURN
27829 ENDIF
27830 ENDIF
27831 RET1=PMG(1)
27832 RET2=PMG(2)
27833
27834C...Give weight for selected mass distribution.
27835 VINT(80)=1D0
27836 DO 280 I=1,2
27837 IF(MBW(I).EQ.0) GOTO 280
27838 PMV=PMU(I)
27839 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27840 ATV=ATU(I)
27841 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27842 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
27843 & (PMD(I)*PGD(I))**2)/PARU(1)
27844 F1=1D0
27845 F2=1D0/PMG(I)**2
27846 F3=1D0/PMG(I)**4
27847 FI0=(ATV-ATL(I))/PARU(1)
27848 FI1=PMV**2-PML(I)**2
27849 FI2=2D0*LOG(PMV/PML(I))
27850 FI3=1D0/PML(I)**2-1D0/PMV**2
27851 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27852 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27853 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27854 & 5D0*F3/FI3))
27855 ELSE
27856 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27857 ENDIF
27858 VINT(80)=VINT(80)*FI0
27859 280 CONTINUE
27860 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27861 ENDIF
27862
27863 RETURN
27864 END
27865
27866C***********************************************************************
27867
27868C...PYRECO
27869C...Handles the possibility of colour reconnection in W+W- events,
27870C...Based on the main scenarios of the Sjostrand and Khoze study:
27871C...I, II, II', intermediate and instantaneous; plus one model
27872C...along the lines of the Gustafson and Hakkinen: GH.
27873C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27874C...is as if first resonance is W+ and second W-.
27875
27876 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27877
27878C...Double precision and integer declarations.
27879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27880 IMPLICIT INTEGER(I-N)
27881 INTEGER PYK,PYCHGE,PYCOMP
27882C...Parameter value; number of points in MC integration.
27883 PARAMETER (NPT=100)
27884C...Commonblocks.
27885 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27886 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27887 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27888 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27889 COMMON/PYINT1/MINT(400),VINT(400)
27890 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27891C...Local arrays.
27892 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27893 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27894 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27895 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27896 &TMC(20),IJOIN(100)
27897
27898C...Functions to give four-product and to do determinants.
27899 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)
27900 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27901 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27902 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27903
27904C...Only allow fraction of recoupling for GH, intermediate and
27905C...instantaneous.
27906 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27907 IF(PYR(0).GT.PARP(120)) RETURN
27908 ENDIF
27909 ISUB=MINT(1)
27910
27911C...Common part for scenarios I, II, II', and GH.
27912 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27913 &MSTP(115).EQ.5) THEN
27914
27915C...Read out frequently-used parameters.
27916 PI=PARU(1)
27917 HBAR=PARU(3)
27918 PMW=PMAS(24,1)
27919 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27920 PGW=PMAS(24,2)
27921 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27922 TFRAG=PARP(115)
27923 RHAD=PARP(116)
27924 FACT=PARP(117)
27925 BLOWR=PARP(118)
27926 BLOWT=PARP(119)
27927
27928C...Find range of decay products of the W's.
27929C...Background: the W's are stored in IW1 and IW2.
27930C...Their direct decay products in NSD1+1 through NSD1+4.
27931C...Products after shower (if any) in NSD1+5 through NAFT1
27932C...for first W and in NAFT1+1 through N for the second.
27933 IF(NAFT1.GT.NSD1+4) THEN
27934 NBEG(1)=NSD1+5
27935 NEND(1)=NAFT1
27936 ELSE
27937 NBEG(1)=NSD1+1
27938 NEND(1)=NSD1+2
27939 ENDIF
27940 IF(N.GT.NAFT1) THEN
27941 NBEG(2)=NAFT1+1
27942 NEND(2)=N
27943 ELSE
27944 NBEG(2)=NSD1+3
27945 NEND(2)=NSD1+4
27946 ENDIF
27947
27948C...Rearrange parton shower products along strings.
27949 NOLD=N
27950 CALL PYPREP(NSD1+1)
27951 IF(MINT(51).NE.0) RETURN
27952
27953C...Find partons pointing back to W+ and W-; store them with quark
27954C...end of string first.
27955 NNP=0
27956 NNM=0
27957 ISGP=0
27958 ISGM=0
27959 DO 120 I=NOLD+1,N
27960 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27961 IF(IABS(K(I,2)).GE.22) GOTO 120
27962 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27963 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27964 NNP=NNP+1
27965 IF(ISGP.EQ.1) THEN
27966 INP(NNP)=I
27967 ELSE
27968 DO 100 I1=NNP,2,-1
27969 INP(I1)=INP(I1-1)
27970 100 CONTINUE
27971 INP(1)=I
27972 ENDIF
27973 IF(K(I,1).EQ.1) ISGP=0
27974 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27975 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27976 NNM=NNM+1
27977 IF(ISGM.EQ.1) THEN
27978 INM(NNM)=I
27979 ELSE
27980 DO 110 I1=NNM,2,-1
27981 INM(I1)=INM(I1-1)
27982 110 CONTINUE
27983 INM(1)=I
27984 ENDIF
27985 IF(K(I,1).EQ.1) ISGM=0
27986 ENDIF
27987 120 CONTINUE
27988
27989C...Boost to W+W- rest frame (not strictly needed).
27990 DO 130 J=1,3
27991 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27992 130 CONTINUE
27993 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27994 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27995 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27996
27997C...Select decay vertices of W+ and W-.
27998 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27999 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
28000 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
28001 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28002 GTMAX=MAX(TP,TM)
28003 DO 140 J=1,3
28004 XP(J)=TP*P(IW1,J)/P(IW1,4)
28005 XM(J)=TM*P(IW2,J)/P(IW2,4)
28006 140 CONTINUE
28007
28008C...Begin scenario I specifics.
28009 IF(MSTP(115).EQ.1) THEN
28010
28011C...Reconstruct velocity and direction of W+ string pieces.
28012 DO 170 IIP=1,NNP-1
28013 IF(K(INP(IIP),2).LT.0) GOTO 170
28014 I1=INP(IIP)
28015 I2=INP(IIP+1)
28016 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28017 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28018 DO 150 J=1,3
28019 V1(J)=P(I1,J)/P1A
28020 V2(J)=P(I2,J)/P2A
28021 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28022 DIRP(IIP,J)=V1(J)-V2(J)
28023 150 CONTINUE
28024 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28025 & BETP(IIP,3)**2)
28026 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28027 DO 160 J=1,3
28028 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28029 160 CONTINUE
28030 170 CONTINUE
28031
28032C...Reconstruct velocity and direction of W- string pieces.
28033 DO 200 IIM=1,NNM-1
28034 IF(K(INM(IIM),2).LT.0) GOTO 200
28035 I1=INM(IIM)
28036 I2=INM(IIM+1)
28037 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28038 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28039 DO 180 J=1,3
28040 V1(J)=P(I1,J)/P1A
28041 V2(J)=P(I2,J)/P2A
28042 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28043 DIRM(IIM,J)=V1(J)-V2(J)
28044 180 CONTINUE
28045 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28046 & BETM(IIM,3)**2)
28047 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28048 DO 190 J=1,3
28049 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28050 190 CONTINUE
28051 200 CONTINUE
28052
28053C...Loop over number of space-time points.
28054 NACC=0
28055 SUM=0D0
28056 DO 250 IPT=1,NPT
28057
28058C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28059 R=SQRT(-LOG(PYR(0)))
28060 PHI=2D0*PI*PYR(0)
28061 X=BLOWR*RHAD*R*COS(PHI)
28062 Y=BLOWR*RHAD*R*SIN(PHI)
28063 R=SQRT(-LOG(PYR(0)))
28064 PHI=2D0*PI*PYR(0)
28065 Z=BLOWR*RHAD*R*COS(PHI)
28066 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28067
28068C...Reject impossible points. Weight for sample distribution.
28069 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28070 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28071 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28072
28073C...Loop over W+ string pieces and find one with largest weight.
28074 IMAXP=0
28075 WTMAXP=1D-10
28076 XD(1)=X-XP(1)
28077 XD(2)=Y-XP(2)
28078 XD(3)=Z-XP(3)
28079 XD(4)=T-TP
28080 DO 220 IIP=1,NNP-1
28081 IF(K(INP(IIP),2).LT.0) GOTO 220
28082 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28083 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28084 DO 210 J=1,3
28085 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28086 210 CONTINUE
28087 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28088 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28089 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28090 & DIRP(IIP,3)*XB(3))**2
28091 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28092 & TFRAG**2)
28093 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28094 IF(WTP.GT.WTMAXP) THEN
28095 IMAXP=IIP
28096 WTMAXP=WTP
28097 ENDIF
28098 220 CONTINUE
28099
28100C...Loop over W- string pieces and find one with largest weight.
28101 IMAXM=0
28102 WTMAXM=1D-10
28103 XD(1)=X-XM(1)
28104 XD(2)=Y-XM(2)
28105 XD(3)=Z-XM(3)
28106 XD(4)=T-TM
28107 DO 240 IIM=1,NNM-1
28108 IF(K(INM(IIM),2).LT.0) GOTO 240
28109 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28110 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28111 DO 230 J=1,3
28112 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28113 230 CONTINUE
28114 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28115 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28116 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28117 & DIRM(IIM,3)*XB(3))**2
28118 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28119 & TFRAG**2)
28120 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28121 IF(WTM.GT.WTMAXM) THEN
28122 IMAXM=IIM
28123 WTMAXM=WTM
28124 ENDIF
28125 240 CONTINUE
28126
28127C...Result of integration.
28128 WT=0D0
28129 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28130 WT=WTMAXP*WTMAXM/WTSMP
28131 SUM=SUM+WT
28132 NACC=NACC+1
28133 IAP(NACC)=IMAXP
28134 IAM(NACC)=IMAXM
28135 WTA(NACC)=WT
28136 ENDIF
28137 250 CONTINUE
28138 RES=BLOWR**3*BLOWT*SUM/NPT
28139
28140C...Decide whether to reconnect and, if so, where.
28141 IACC=0
28142 PREC=1D0-EXP(-FACT*RES)
28143 IF(PREC.GT.PYR(0)) THEN
28144 RSUM=PYR(0)*SUM
28145 DO 260 IA=1,NACC
28146 IACC=IA
28147 RSUM=RSUM-WTA(IA)
28148 IF(RSUM.LE.0D0) GOTO 270
28149 260 CONTINUE
28150 270 IIP=IAP(IACC)
28151 IIM=IAM(IACC)
28152 ENDIF
28153
28154C...Begin scenario II and II' specifics.
28155 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28156
28157C...Loop through all string pieces, one from W+ and one from W-.
28158 NCROSS=0
28159 TC(0)=0D0
28160 DO 340 IIP=1,NNP-1
28161 IF(K(INP(IIP),2).LT.0) GOTO 340
28162 I1P=INP(IIP)
28163 I2P=INP(IIP+1)
28164 DO 330 IIM=1,NNM-1
28165 IF(K(INM(IIM),2).LT.0) GOTO 330
28166 I1M=INM(IIM)
28167 I2M=INM(IIM+1)
28168
28169C...Find endpoint velocity vectors.
28170 DO 280 J=1,3
28171 V1P(J)=P(I1P,J)/P(I1P,4)
28172 V2P(J)=P(I2P,J)/P(I2P,4)
28173 V1M(J)=P(I1M,J)/P(I1M,4)
28174 V2M(J)=P(I2M,J)/P(I2M,4)
28175 280 CONTINUE
28176
28177C...Define q matrix and find t.
28178 DO 290 J=1,3
28179 Q(1,J)=V2P(J)-V1P(J)
28180 Q(2,J)=-(V2M(J)-V1M(J))
28181 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28182 Q(4,J)=V1P(J)-V1M(J)
28183 290 CONTINUE
28184 T=-DETER(1,2,3)/DETER(1,2,4)
28185
28186C...Find alpha and beta; i.e. coordinates of crossing point.
28187 S11=Q(1,1)*(T-TP)
28188 S12=Q(2,1)*(T-TM)
28189 S13=Q(3,1)+Q(4,1)*T
28190 S21=Q(1,2)*(T-TP)
28191 S22=Q(2,2)*(T-TM)
28192 S23=Q(3,2)+Q(4,2)*T
28193 DEN=S11*S22-S12*S21
28194 ALP=(S12*S23-S22*S13)/DEN
28195 BET=(S21*S13-S11*S23)/DEN
28196
28197C...Check if solution acceptable.
28198 IANSW=1
28199 IF(T.LT.GTMAX) IANSW=0
28200 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28201 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28202
28203C...Find point of crossing and check that not inconsistent.
28204 DO 300 J=1,3
28205 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28206 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28207 300 CONTINUE
28208 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28209 & (XPP(3)-XMM(3))**2
28210 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28211 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28212 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28213
28214C...Find string eigentimes at crossing.
28215 IF(IANSW.EQ.1) THEN
28216 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28217 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28218 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28219 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28220 ELSE
28221 TAUP=0D0
28222 TAUM=0D0
28223 ENDIF
28224
28225C...Order crossings by time. End loop over crossings.
28226 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28227 NCROSS=NCROSS+1
28228 DO 310 I1=NCROSS,1,-1
28229 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28230 IPC(I1)=IIP
28231 IMC(I1)=IIM
28232 TC(I1)=T
28233 TPC(I1)=TAUP
28234 TMC(I1)=TAUM
28235 GOTO 320
28236 ELSE
28237 IPC(I1)=IPC(I1-1)
28238 IMC(I1)=IMC(I1-1)
28239 TC(I1)=TC(I1-1)
28240 TPC(I1)=TPC(I1-1)
28241 TMC(I1)=TMC(I1-1)
28242 ENDIF
28243 310 CONTINUE
28244 320 CONTINUE
28245 ENDIF
28246 330 CONTINUE
28247 340 CONTINUE
28248
28249C...Loop over crossings; find first (if any) acceptable one.
28250 IACC=0
28251 IF(NCROSS.GE.1) THEN
28252 DO 350 IC=1,NCROSS
28253 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28254 IF(PNFRAG.GT.PYR(0)) THEN
28255C...Scenario II: only compare with fragmentation time.
28256 IF(MSTP(115).EQ.2) THEN
28257 IACC=IC
28258 IIP=IPC(IACC)
28259 IIM=IMC(IACC)
28260 GOTO 360
28261C...Scenario II': also require that string length decreases.
28262 ELSE
28263 IIP=IPC(IC)
28264 IIM=IMC(IC)
28265 I1P=INP(IIP)
28266 I2P=INP(IIP+1)
28267 I1M=INM(IIM)
28268 I2M=INM(IIM+1)
28269 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28270 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28271 IF(ELNEW.LT.ELOLD) THEN
28272 IACC=IC
28273 IIP=IPC(IACC)
28274 IIM=IMC(IACC)
28275 GOTO 360
28276 ENDIF
28277 ENDIF
28278 ENDIF
28279 350 CONTINUE
28280 360 CONTINUE
28281 ENDIF
28282
28283C...Begin scenario GH specifics.
28284 ELSEIF(MSTP(115).EQ.5) THEN
28285
28286C...Loop through all string pieces, one from W+ and one from W-.
28287 IACC=0
28288 ELMIN=1D0
28289 DO 380 IIP=1,NNP-1
28290 IF(K(INP(IIP),2).LT.0) GOTO 380
28291 I1P=INP(IIP)
28292 I2P=INP(IIP+1)
28293 DO 370 IIM=1,NNM-1
28294 IF(K(INM(IIM),2).LT.0) GOTO 370
28295 I1M=INM(IIM)
28296 I2M=INM(IIM+1)
28297
28298C...Look for largest decrease of (exponent of) Lambda measure.
28299 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28300 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28301 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28302 IF(ELDIF.LT.ELMIN) THEN
28303 IACC=IIP+IIM
28304 ELMIN=ELDIF
28305 IPC(1)=IIP
28306 IMC(1)=IIM
28307 ENDIF
28308 370 CONTINUE
28309 380 CONTINUE
28310 IIP=IPC(1)
28311 IIM=IMC(1)
28312 ENDIF
28313
28314C...Common for scenarios I, II, II' and GH: reconnect strings.
28315 IF(IACC.NE.0) THEN
28316 MINT(32)=1
28317 NJOIN=0
28318 DO 390 IS=1,NNP+NNM
28319 NJOIN=NJOIN+1
28320 IF(IS.LE.IIP) THEN
28321 I=INP(IS)
28322 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28323 I=INM(IS-IIP+IIM)
28324 ELSEIF(IS.LE.IIP+NNM) THEN
28325 I=INM(IS-IIP-NNM+IIM)
28326 ELSE
28327 I=INP(IS-NNM)
28328 ENDIF
28329 IJOIN(NJOIN)=I
28330 IF(K(I,2).LT.0) THEN
28331 CALL PYJOIN(NJOIN,IJOIN)
28332 NJOIN=0
28333 ENDIF
28334 390 CONTINUE
28335
28336C...Restore original event record if no reconnection.
28337 ELSE
28338 DO 400 I=NSD1+1,NOLD
28339 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28340 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28341 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28342 ENDIF
28343 400 CONTINUE
28344 DO 410 I=NOLD+1,N
28345 K(K(I,3),1)=3
28346 410 CONTINUE
28347 N=NOLD
28348 ENDIF
28349
28350C...Boost back system.
28351 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28352 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28353 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
28354 & BEWW(1),BEWW(2),BEWW(3))
28355
28356C...Common part for intermediate and instantaneous scenarios.
28357 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28358 MINT(32)=1
28359
28360C...Remove old shower products and reset showering ones.
28361 N=NSD1+4
28362 DO 420 I=NSD1+1,NSD1+4
28363 K(I,1)=3
28364 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28365 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28366 420 CONTINUE
28367
28368C...Identify quark-antiquark pairs.
28369 IQ1=NSD1+1
28370 IQ2=NSD1+2
28371 IQ3=NSD1+3
28372 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
28373 IQ4=2*NSD1+7-IQ3
28374
28375C...Reconnect strings.
28376 IJOIN(1)=IQ1
28377 IJOIN(2)=IQ4
28378 CALL PYJOIN(2,IJOIN)
28379 IJOIN(1)=IQ3
28380 IJOIN(2)=IQ2
28381 CALL PYJOIN(2,IJOIN)
28382
28383C...Do new parton showers in intermediate scenario.
28384 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
28385 MSTJ50=MSTJ(50)
28386 MSTJ(50)=0
28387 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
28388 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
28389 MSTJ(50)=MSTJ50
28390
28391C...Do new parton showers in instantaneous scenario.
28392 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
28393 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
28394 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
28395 PPM=SQRT(MAX(0D0,PPM2))
28396 CALL PYSHOW(IQ1,IQ4,PPM)
28397 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
28398 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
28399 PPM=SQRT(MAX(0D0,PPM2))
28400 CALL PYSHOW(IQ3,IQ2,PPM)
28401 ENDIF
28402 ENDIF
28403
28404 RETURN
28405 END
28406
28407C***********************************************************************
28408
28409C...PYKLIM
28410C...Checks generated variables against pre-set kinematical limits;
28411C...also calculates limits on variables used in generation.
28412
28413 SUBROUTINE PYKLIM(ILIM)
28414
28415C...Double precision and integer declarations.
28416 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28417 IMPLICIT INTEGER(I-N)
28418 INTEGER PYK,PYCHGE,PYCOMP
28419C...Commonblocks.
28420 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28421 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28422 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28423 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28424 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28425 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28426 COMMON/PYINT1/MINT(400),VINT(400)
28427 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28428 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28429 &/PYINT1/,/PYINT2/
28430
28431C...Common kinematical expressions.
28432 MINT(51)=0
28433 ISUB=MINT(1)
28434 ISTSB=ISET(ISUB)
28435 IF(ISUB.EQ.96) GOTO 100
28436 SQM3=VINT(63)
28437 SQM4=VINT(64)
28438 IF(ILIM.NE.0) THEN
28439 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
28440 CKIN09=MAX(CKIN(9),CKIN(13))
28441 CKIN10=MIN(CKIN(10),CKIN(14))
28442 CKIN11=MAX(CKIN(11),CKIN(15))
28443 CKIN12=MIN(CKIN(12),CKIN(16))
28444 ELSE
28445 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
28446 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
28447 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
28448 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
28449 ENDIF
28450 ENDIF
28451 IF(ILIM.NE.1) THEN
28452 TAU=VINT(21)
28453 RM3=SQM3/(TAU*VINT(2))
28454 RM4=SQM4/(TAU*VINT(2))
28455 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28456 ENDIF
28457 PTHMIN=CKIN(3)
28458 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
28459 &PTHMIN=MAX(CKIN(3),CKIN(5))
28460
28461 IF(ILIM.EQ.0) THEN
28462C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28463C...pre-set kinematical limits.
28464 YST=VINT(22)
28465 CTH=VINT(23)
28466 TAUP=VINT(26)
28467 TAUE=TAU
28468 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28469 X1=SQRT(TAUE)*EXP(YST)
28470 X2=SQRT(TAUE)*EXP(-YST)
28471 XF=X1-X2
28472 IF(MINT(47).NE.1) THEN
28473 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
28474 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
28475 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
28476 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
28477 ENDIF
28478 IF(MINT(45).NE.1) THEN
28479 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
28480 ENDIF
28481 IF(MINT(46).NE.1) THEN
28482 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
28483 ENDIF
28484 IF(MINT(45).EQ.2) THEN
28485 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28486 ENDIF
28487 IF(MINT(46).EQ.2) THEN
28488 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28489 ENDIF
28490 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28491 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
28492 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
28493 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
28494 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
28495 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
28496 Y3=YST+0.5D0*LOG(EXPY3)
28497 Y4=YST+0.5D0*LOG(EXPY4)
28498 YLARGE=MAX(Y3,Y4)
28499 YSMALL=MIN(Y3,Y4)
28500 ETALAR=20D0
28501 ETASMA=-20D0
28502 STH=SQRT(MAX(0D0,1D0-CTH**2))
28503 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
28504 & CTH)**2-4D0*RM3))
28505 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
28506 & CTH)**2-4D0*RM4))
28507 IF(STH.GE.1D-10) THEN
28508 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
28509 & (BE34*STH)
28510 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
28511 & (BE34*STH)
28512 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
28513 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
28514 ETALAR=MAX(ETA3,ETA4)
28515 ETASMA=MIN(ETA3,ETA4)
28516 ENDIF
28517 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
28518 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
28519 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
28520 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
28521 SH=TAU*VINT(2)
28522 RPTS=4D0*VINT(71)**2/SH
28523 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28524 RM34=MAX(1D-20,2D0*RM3*RM4)
28525 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28526 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28527 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28528 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
28529 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28530 IF(PTH.LT.PTHMIN) MINT(51)=1
28531 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
28532 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
28533 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
28534 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
28535 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
28536 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
28537 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
28538 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
28539 IF(THA.LT.CKIN(35)) MINT(51)=1
28540 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
28541 IF(UHA.LT.CKIN(37)) MINT(51)=1
28542 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
28543 ENDIF
28544 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28545 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
28546 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
28547 ENDIF
28548
28549C...Additional cuts on W2 (approximately) in DIS.
28550 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
28551 XBJ=X2
28552 IF(IABS(MINT(12)).LT.20) XBJ=X1
28553 Q2BJ=THA
28554 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
28555 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
28556 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
28557 ENDIF
28558
28559 ELSEIF(ILIM.EQ.1) THEN
28560C...Calculate limits on tau
28561C...0) due to definition
28562 TAUMN0=0D0
28563 TAUMX0=1D0
28564C...1) due to limits on subsystem mass
28565 TAUMN1=CKIN(1)**2/VINT(2)
28566 TAUMX1=1D0
28567 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
28568C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28569 TM3=SQRT(SQM3+PTHMIN**2)
28570 TM4=SQRT(SQM4+PTHMIN**2)
28571 YDCOSH=1D0
28572 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
28573 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
28574 TAUMX2=1D0
28575C...3) due to limits on pT-hat and cos(theta-hat)
28576 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
28577 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
28578 TAUMN3=0D0
28579 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
28580 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
28581 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
28582 TAUMX3=1D0
28583 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
28584 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
28585 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
28586C...4) due to limits on x1 and x2
28587 TAUMN4=CKIN(21)*CKIN(23)
28588 TAUMX4=CKIN(22)*CKIN(24)
28589C...5) due to limits on xF
28590 TAUMN5=0D0
28591 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
28592C...6) due to limits on that and uhat
28593 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
28594 TAUMX6=1D0
28595 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
28596 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
28597
28598C...Net effect of all separate limits.
28599 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
28600 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
28601 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28602 VINT(11)=1D0-1D-9
28603 VINT(31)=1D0+1D-9
28604 ELSEIF(MINT(47).EQ.5) THEN
28605 VINT(31)=MIN(VINT(31),1D0-2D-10)
28606 ELSEIF(MINT(47).GE.6) THEN
28607 VINT(31)=MIN(VINT(31),1D0-1D-10)
28608 ENDIF
28609 IF(VINT(31).LE.VINT(11)) MINT(51)=1
28610
28611 ELSEIF(ILIM.EQ.2) THEN
28612C...Calculate limits on y*
28613 TAUE=TAU
28614 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28615 TAURT=SQRT(TAUE)
28616C...0) due to kinematics
28617 YSTMN0=LOG(TAURT)
28618 YSTMX0=-YSTMN0
28619C...1) due to explicit limits
28620 YSTMN1=CKIN(7)
28621 YSTMX1=CKIN(8)
28622C...2) due to limits on x1
28623 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
28624 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
28625C...3) due to limits on x2
28626 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
28627 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
28628C...4) due to limits on xF
28629 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
28630 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
28631 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
28632 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
28633C...5) due to simultaneous limits on y-large and y-small
28634 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
28635 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
28636 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
28637 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
28638 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
28639 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
28640C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28641C... y-small
28642 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
28643 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
28644 RZMX=BE34*MIN(CKIN(28),CTHLIM)
28645 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
28646 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
28647 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
28648 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
28649 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
28650 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
28651
28652C...Net effect of all separate limits.
28653 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
28654 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
28655 IF(MINT(47).EQ.1) THEN
28656 VINT(12)=-1D-9
28657 VINT(32)=1D-9
28658 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28659 VINT(12)=(1D0-1D-9)*YSTMX0
28660 VINT(32)=(1D0+1D-9)*YSTMX0
28661 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28662 VINT(12)=-(1D0+1D-9)*YSTMX0
28663 VINT(32)=-(1D0-1D-9)*YSTMX0
28664 ELSEIF(MINT(47).EQ.5) THEN
28665 YSTEE=LOG((1D0-1D-10)/TAURT)
28666 VINT(12)=MAX(VINT(12),-YSTEE)
28667 VINT(32)=MIN(VINT(32),YSTEE)
28668 ENDIF
28669 IF(VINT(32).LE.VINT(12)) MINT(51)=1
28670
28671 ELSEIF(ILIM.EQ.3) THEN
28672C...Calculate limits on cos(theta-hat)
28673 YST=VINT(22)
28674C...0) due to definition
28675 CTNMN0=-1D0
28676 CTNMX0=0D0
28677 CTPMN0=0D0
28678 CTPMX0=1D0
28679C...1) due to explicit limits
28680 CTNMN1=MIN(0D0,CKIN(27))
28681 CTNMX1=MIN(0D0,CKIN(28))
28682 CTPMN1=MAX(0D0,CKIN(27))
28683 CTPMX1=MAX(0D0,CKIN(28))
28684C...2) due to limits on pT-hat
28685 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
28686 CTPMX2=-CTNMN2
28687 CTNMX2=0D0
28688 CTPMN2=0D0
28689 IF(CKIN(4).GE.0D0) THEN
28690 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
28691 & (BE34**2*TAU*VINT(2))))
28692 CTPMN2=-CTNMX2
28693 ENDIF
28694C...3) due to limits on y-large and y-small
28695 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
28696 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
28697 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
28698 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
28699 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
28700 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
28701 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
28702 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
28703C...4) due to limits on that
28704 CTNMN4=-1D0
28705 CTNMX4=0D0
28706 CTPMN4=0D0
28707 CTPMX4=1D0
28708 SH=TAU*VINT(2)
28709 IF(CKIN(35).GT.0D0) THEN
28710 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
28711 IF(CTLIM.GT.0D0) THEN
28712 CTPMX4=CTLIM
28713 ELSE
28714 CTPMX4=0D0
28715 CTNMX4=CTLIM
28716 ENDIF
28717 ENDIF
28718 IF(CKIN(36).GT.0D0) THEN
28719 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
28720 IF(CTLIM.LT.0D0) THEN
28721 CTNMN4=CTLIM
28722 ELSE
28723 CTNMN4=0D0
28724 CTPMN4=CTLIM
28725 ENDIF
28726 ENDIF
28727C...5) due to limits on uhat
28728 CTNMN5=-1D0
28729 CTNMX5=0D0
28730 CTPMN5=0D0
28731 CTPMX5=1D0
28732 IF(CKIN(37).GT.0D0) THEN
28733 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
28734 IF(CTLIM.LT.0D0) THEN
28735 CTNMN5=CTLIM
28736 ELSE
28737 CTNMN5=0D0
28738 CTPMN5=CTLIM
28739 ENDIF
28740 ENDIF
28741 IF(CKIN(38).GT.0D0) THEN
28742 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
28743 IF(CTLIM.GT.0D0) THEN
28744 CTPMX5=CTLIM
28745 ELSE
28746 CTPMX5=0D0
28747 CTNMX5=CTLIM
28748 ENDIF
28749 ENDIF
28750
28751C...Net effect of all separate limits.
28752 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
28753 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
28754 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
28755 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
28756 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
28757
28758 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
28759 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
28760
28761 ELSEIF(ILIM.EQ.4) THEN
28762C...Calculate limits on tau'
28763C...0) due to kinematics
28764 TAPMN0=TAU
28765 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
28766 PQRAT=(VINT(201)+VINT(206))/VINT(1)
28767 TAPMN0=(SQRT(TAU)+PQRAT)**2
28768 ENDIF
28769 TAPMX0=1D0
28770C...1) due to explicit limits
28771 TAPMN1=CKIN(31)**2/VINT(2)
28772 TAPMX1=1D0
28773 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
28774
28775C...Net effect of all separate limits.
28776 VINT(16)=MAX(TAPMN0,TAPMN1)
28777 VINT(36)=MIN(TAPMX0,TAPMX1)
28778 IF(MINT(47).EQ.1) THEN
28779 VINT(16)=1D0-1D-9
28780 VINT(36)=1D0+1D-9
28781 ELSEIF(MINT(47).EQ.5) THEN
28782 VINT(36)=MIN(VINT(36),1D0-2D-10)
28783 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
28784 VINT(36)=MIN(VINT(36),1D0-1D-10)
28785 ENDIF
28786 IF(VINT(36).LE.VINT(16)) MINT(51)=1
28787
28788 ENDIF
28789 RETURN
28790
28791C...Special case for low-pT and multiple interactions:
28792C...effective kinematical limits for tau, y*, cos(theta-hat).
28793 100 IF(ILIM.EQ.0) THEN
28794 ELSEIF(ILIM.EQ.1) THEN
28795 IF(MSTP(82).LE.1) THEN
28796 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28797 & VINT(2)
28798 ELSE
28799 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
28800 ENDIF
28801 VINT(31)=1D0
28802 ELSEIF(ILIM.EQ.2) THEN
28803 VINT(12)=0.5D0*LOG(VINT(21))
28804 VINT(32)=-VINT(12)
28805 ELSEIF(ILIM.EQ.3) THEN
28806 IF(MSTP(82).LE.1) THEN
28807 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28808 & (VINT(21)*VINT(2))
28809 ELSE
28810 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
28811 & (VINT(21)*VINT(2))
28812 ENDIF
28813 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
28814 VINT(33)=0D0
28815 VINT(14)=0D0
28816 VINT(34)=-VINT(13)
28817 ENDIF
28818
28819 RETURN
28820 END
28821
28822C*********************************************************************
28823
28824C...PYKMAP
28825C...Maps a uniform distribution into a distribution of a kinematical
28826C...variable according to one of the possibilities allowed. It is
28827C...assumed that kinematical limits have been set by a PYKLIM call.
28828
28829 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
28830
28831C...Double precision and integer declarations.
28832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28833 IMPLICIT INTEGER(I-N)
28834 INTEGER PYK,PYCHGE,PYCOMP
28835C...Commonblocks.
28836 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28837 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28838 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28839 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28840 COMMON/PYINT1/MINT(400),VINT(400)
28841 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28842 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28843
28844C...Convert VVAR to tau variable.
28845 ISUB=MINT(1)
28846 ISTSB=ISET(ISUB)
28847 IF(IVAR.EQ.1) THEN
28848 TAUMIN=VINT(11)
28849 TAUMAX=VINT(31)
28850 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28851 TAURE=VINT(73)
28852 GAMRE=VINT(74)
28853 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28854 TAURE=VINT(75)
28855 GAMRE=VINT(76)
28856 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28857 TAURE=VINT(77)
28858 GAMRE=VINT(78)
28859 ENDIF
28860 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28861 TAU=1D0
28862 ELSEIF(MVAR.EQ.1) THEN
28863 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28864 ELSEIF(MVAR.EQ.2) THEN
28865 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28866 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28867 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28868 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28869 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28870 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28871 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28872 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28873 ELSEIF(MINT(47).EQ.5) THEN
28874 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28875 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28876 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28877 ELSE
28878 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28879 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28880 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28881 ENDIF
28882 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28883
28884C...Convert VVAR to y* variable.
28885 ELSEIF(IVAR.EQ.2) THEN
28886 YSTMIN=VINT(12)
28887 YSTMAX=VINT(32)
28888 TAUE=VINT(21)
28889 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28890 IF(MINT(47).EQ.1) THEN
28891 YST=0D0
28892 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28893 YST=-0.5D0*LOG(TAUE)
28894 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28895 YST=0.5D0*LOG(TAUE)
28896 ELSEIF(MVAR.EQ.1) THEN
28897 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28898 ELSEIF(MVAR.EQ.2) THEN
28899 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28900 ELSEIF(MVAR.EQ.3) THEN
28901 AUPP=ATAN(EXP(YSTMAX))
28902 ALOW=ATAN(EXP(YSTMIN))
28903 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28904 ELSEIF(MVAR.EQ.4) THEN
28905 YST0=-0.5D0*LOG(TAUE)
28906 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28907 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28908 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28909 ELSE
28910 YST0=-0.5D0*LOG(TAUE)
28911 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28912 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28913 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28914 ENDIF
28915 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28916
28917C...Convert VVAR to cos(theta-hat) variable.
28918 ELSEIF(IVAR.EQ.3) THEN
28919 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28920 RSQM=1D0+RM34
28921 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28922 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28923 CTNMIN=VINT(13)
28924 CTNMAX=VINT(33)
28925 CTPMIN=VINT(14)
28926 CTPMAX=VINT(34)
28927 IF(MVAR.EQ.1) THEN
28928 ANEG=CTNMAX-CTNMIN
28929 APOS=CTPMAX-CTPMIN
28930 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28931 VCTN=VVAR*(ANEG+APOS)/ANEG
28932 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28933 ELSE
28934 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28935 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28936 ENDIF
28937 ELSEIF(MVAR.EQ.2) THEN
28938 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28939 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28940 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28941 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28942 ANEG=LOG(RMNMIN/RMNMAX)
28943 APOS=LOG(RMPMIN/RMPMAX)
28944 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28945 VCTN=VVAR*(ANEG+APOS)/ANEG
28946 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28947 ELSE
28948 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28949 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28950 ENDIF
28951 ELSEIF(MVAR.EQ.3) THEN
28952 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28953 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28954 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28955 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28956 ANEG=LOG(RMNMAX/RMNMIN)
28957 APOS=LOG(RMPMAX/RMPMIN)
28958 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28959 VCTN=VVAR*(ANEG+APOS)/ANEG
28960 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28961 ELSE
28962 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28963 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28964 ENDIF
28965 ELSEIF(MVAR.EQ.4) THEN
28966 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28967 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28968 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28969 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28970 ANEG=1D0/RMNMAX-1D0/RMNMIN
28971 APOS=1D0/RMPMAX-1D0/RMPMIN
28972 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28973 VCTN=VVAR*(ANEG+APOS)/ANEG
28974 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28975 ELSE
28976 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28977 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28978 ENDIF
28979 ELSEIF(MVAR.EQ.5) THEN
28980 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28981 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28982 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28983 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28984 ANEG=1D0/RMNMIN-1D0/RMNMAX
28985 APOS=1D0/RMPMIN-1D0/RMPMAX
28986 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28987 VCTN=VVAR*(ANEG+APOS)/ANEG
28988 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28989 ELSE
28990 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28991 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28992 ENDIF
28993 ENDIF
28994 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28995 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28996 VINT(23)=CTH
28997
28998C...Convert VVAR to tau' variable.
28999 ELSEIF(IVAR.EQ.4) THEN
29000 TAU=VINT(21)
29001 TAUPMN=VINT(16)
29002 TAUPMX=VINT(36)
29003 IF(MINT(47).EQ.1) THEN
29004 TAUP=1D0
29005 ELSEIF(MVAR.EQ.1) THEN
29006 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29007 ELSEIF(MVAR.EQ.2) THEN
29008 AUPP=(1D0-TAU/TAUPMX)**4
29009 ALOW=(1D0-TAU/TAUPMN)**4
29010 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29011 ELSEIF(MINT(47).EQ.5) THEN
29012 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29013 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29014 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29015 ELSE
29016 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29017 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29018 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29019 ENDIF
29020 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29021
29022C...Selection of extra variables needed in 2 -> 3 process:
29023C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29024C...Since no options are available, the functions of PYKLIM
29025C...and PYKMAP are joint for these choices.
29026 ELSEIF(IVAR.EQ.5) THEN
29027
29028C...Read out total energy and particle masses.
29029 MINT(51)=0
29030 MPTPK=1
29031 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29032 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29033 & MPTPK=2
29034 SHP=VINT(26)*VINT(2)
29035 SHPR=SQRT(SHP)
29036 PM1=VINT(201)
29037 PM2=VINT(206)
29038 PM3=SQRT(VINT(21))*VINT(1)
29039 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29040 MINT(51)=1
29041 RETURN
29042 ENDIF
29043 PMRS1=VINT(204)**2
29044 PMRS2=VINT(209)**2
29045
29046C...Specify coefficients of pT choice; upper and lower limits.
29047 IF(MPTPK.EQ.1) THEN
29048 HWT1=0.4D0
29049 HWT2=0.4D0
29050 ELSE
29051 HWT1=0.05D0
29052 HWT2=0.05D0
29053 ENDIF
29054 HWT3=1D0-HWT1-HWT2
29055 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29056 & (4D0*SHP)
29057 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29058 PTSMN1=CKIN(51)**2
29059 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29060 & (4D0*SHP)
29061 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29062 PTSMN2=CKIN(53)**2
29063
29064C...Select transverse momenta according to
29065C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29066 HMX=PMRS1+PTSMX1
29067 HMN=PMRS1+PTSMN1
29068 IF(HMX.LT.1.0001D0*HMN) THEN
29069 MINT(51)=1
29070 RETURN
29071 ENDIF
29072 HDE=PTSMX1-PTSMN1
29073 RPT=PYR(0)
29074 IF(RPT.LT.HWT1) THEN
29075 PTS1=PTSMN1+PYR(0)*HDE
29076 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29077 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29078 ELSE
29079 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29080 ENDIF
29081 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29082 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29083 HMX=PMRS2+PTSMX2
29084 HMN=PMRS2+PTSMN2
29085 IF(HMX.LT.1.0001D0*HMN) THEN
29086 MINT(51)=1
29087 RETURN
29088 ENDIF
29089 HDE=PTSMX2-PTSMN2
29090 RPT=PYR(0)
29091 IF(RPT.LT.HWT1) THEN
29092 PTS2=PTSMN2+PYR(0)*HDE
29093 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29094 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29095 ELSE
29096 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29097 ENDIF
29098 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29099 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29100
29101C...Select azimuthal angles and check pT choice.
29102 PHI1=PARU(2)*PYR(0)
29103 PHI2=PARU(2)*PYR(0)
29104 PHIR=PHI2-PHI1
29105 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29106 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29107 & CKIN(56)**2)) THEN
29108 MINT(51)=1
29109 RETURN
29110 ENDIF
29111
29112C...Calculate transverse masses and check phase space not closed.
29113 PMS1=PM1**2+PTS1
29114 PMS2=PM2**2+PTS2
29115 PMS3=PM3**2+PTS3
29116 PMT1=SQRT(PMS1)
29117 PMT2=SQRT(PMS2)
29118 PMT3=SQRT(PMS3)
29119 PM12=(PMT1+PMT2)**2
29120 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29121 MINT(51)=1
29122 RETURN
29123 ENDIF
29124
29125C...Select rapidity for particle 3 and check phase space not closed.
29126 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29127 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29128 IF(Y3MAX.LT.1D-6) THEN
29129 MINT(51)=1
29130 RETURN
29131 ENDIF
29132 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29133 PZ3=PMT3*SINH(Y3)
29134 PE3=PMT3*COSH(Y3)
29135
29136C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29137 PZ12=-PZ3
29138 PE12=SHPR-PE3
29139 PMS12=PE12**2-PZ12**2
29140 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29141 IF(SQL12.LT.1D-6*SHP) THEN
29142 MINT(51)=1
29143 RETURN
29144 ENDIF
29145 PMM1=PMS12+PMS1-PMS2
29146 PMM2=PMS12+PMS2-PMS1
29147 TFAC=-SHPR/(2D0*PMS12)
29148 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29149 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29150 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29151 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29152
29153C...Construct relative mirror weights and make choice.
29154 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29155 WTPU=1D0
29156 WTNU=1D0
29157 ELSE
29158 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29159 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29160 ENDIF
29161 WTP=WTPU/(WTPU+WTNU)
29162 WTN=WTNU/(WTPU+WTNU)
29163 EPS=1D0
29164 IF(WTN.GT.PYR(0)) EPS=-1D0
29165
29166C...Store result of variable choice and associated weights.
29167 VINT(202)=PTS1
29168 VINT(207)=PTS2
29169 VINT(203)=PHI1
29170 VINT(208)=PHI2
29171 VINT(205)=WTPTS1
29172 VINT(210)=WTPTS2
29173 VINT(211)=Y3
29174 VINT(212)=Y3MAX
29175 VINT(213)=EPS
29176 IF(EPS.GT.0D0) THEN
29177 VINT(214)=1D0/WTP
29178 VINT(215)=T1P
29179 VINT(216)=T2P
29180 ELSE
29181 VINT(214)=1D0/WTN
29182 VINT(215)=T1N
29183 VINT(216)=T2N
29184 ENDIF
29185 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29186 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29187 VINT(219)=0.5D0*(PMS12-PTS3)
29188 VINT(220)=SQL12
29189 ENDIF
29190
29191 RETURN
29192 END
29193
29194C***********************************************************************
29195
29196C...PYSIGH
29197C...Differential matrix elements for all included subprocesses
29198C...Note that what is coded is (disregarding the COMFAC factor)
29199C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29200C...when d(sigma-hat) is given in the zero-width limit, the delta
29201C...function in tau is replaced by a (modified) Breit-Wigner:
29202C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29203C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29204C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29205C...i.e., dimensionless quantities
29206C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29207C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29208C...(2pi)^4 delta^4(P - sum p_i)
29209C...COMFAC contains the factor pi/s (or equivalent) and
29210C...the conversion factor from GeV^-2 to mb
29211
29212 SUBROUTINE PYSIGH(NCHN,SIGS)
29213
29214C...Double precision and integer declarations
29215 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29216 IMPLICIT INTEGER(I-N)
29217 INTEGER PYK,PYCHGE,PYCOMP
29218C...Parameter statement to help give large particle numbers.
29219 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29220 &KEXCIT=4000000,KDIMEN=5000000)
29221C...Commonblocks
29222 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29223 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29224 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29225 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29226 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29227 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29228 COMMON/PYINT1/MINT(400),VINT(400)
29229 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29230 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29231 COMMON/PYINT4/MWID(500),WIDS(500,5)
29232 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29233 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29234 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29235 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29236 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29237 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29238 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29239 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29240 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29241 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29242 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29243 COMMON/PYTCCO/COEFX(194:380,2)
29244 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29245 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29246 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29247C...Local arrays and complex variables
29248 DIMENSION XPQ(-25:25)
29249
29250C...Map of processes onto which routine to call
29251C...in order to evaluate cross section:
29252C...0 = not implemented;
29253C...1 = standard QCD (including photons);
29254C...2 = heavy flavours;
29255C...3 = W/Z;
29256C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29257C...5 = SUSY;
29258C...6 = Technicolor;
29259C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29260C...8 = Universal Extra Dimensions
29261 DIMENSION MAPPR(500)
29262 DATA (MAPPR(I),I=1,180)/
29263 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29264 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29265 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29266 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29267 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29268 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29269 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29270 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29271 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29272 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29273 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29274 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29275 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29276 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29277 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29278 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29279 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29280 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29281 DATA (MAPPR(I),I=181,500)/
29282 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29283 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29284 & 100*5,
29285 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29286 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29287 1 20*0,
29288 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29289 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29290 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29291 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29292 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29293 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29294 & 4, 4, 18*0,
29295 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29296 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29297 4 20*0,
29298 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29299 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29300 8 20*0/
29301
29302C...Reset number of channels and cross-section
29303 NCHN=0
29304 SIGS=0D0
29305
29306C...Read process to consider.
29307 ISUB=MINT(1)
29308 ISUBSV=ISUB
29309 MAP=MAPPR(ISUB)
29310
29311C...Read kinematical variables and limits
29312 ISTSB=ISET(ISUBSV)
29313 TAUMIN=VINT(11)
29314 YSTMIN=VINT(12)
29315 CTNMIN=VINT(13)
29316 CTPMIN=VINT(14)
29317 TAUPMN=VINT(16)
29318 TAU=VINT(21)
29319 YST=VINT(22)
29320 CTH=VINT(23)
29321 XT2=VINT(25)
29322 TAUP=VINT(26)
29323 TAUMAX=VINT(31)
29324 YSTMAX=VINT(32)
29325 CTNMAX=VINT(33)
29326 CTPMAX=VINT(34)
29327 TAUPMX=VINT(36)
29328
29329C...Derive kinematical quantities
29330 TAUE=TAU
29331 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29332 X(1)=SQRT(TAUE)*EXP(YST)
29333 X(2)=SQRT(TAUE)*EXP(-YST)
29334 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29335 IF(X(1).GT.1D0-1D-7) RETURN
29336 ELSEIF(MINT(45).EQ.3) THEN
29337 X(1)=MIN(1D0-1.1D-10,X(1))
29338 ENDIF
29339 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29340 IF(X(2).GT.1D0-1D-7) RETURN
29341 ELSEIF(MINT(46).EQ.3) THEN
29342 X(2)=MIN(1D0-1.1D-10,X(2))
29343 ENDIF
29344 SH=MAX(1D0,TAU*VINT(2))
29345 SQM3=VINT(63)
29346 SQM4=VINT(64)
29347 RM3=SQM3/SH
29348 RM4=SQM4/SH
29349 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29350 RPTS=4D0*VINT(71)**2/SH
29351 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29352 RM34=MAX(1D-20,2D0*RM3*RM4)
29353 RSQM=1D0+RM34
29354 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
29355 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
29356 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29357 IF(ISTSB.EQ.0) THEN
29358 TH=VINT(45)
29359 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29360 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
29361 ELSE
29362C...Kinematics with incoming masses tricky: now depends on how
29363C...subprocess has been set up w.r.t. order of incoming partons.
29364 RM1=0D0
29365 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
29366 RM2=0D0
29367 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
29368 IF(ISUB.EQ.35) THEN
29369 RM2=MIN(RM1,RM2)
29370 RM1=0D0
29371 ENDIF
29372 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
29373 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
29374 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
29375 & BE12*BE34*CTH)
29376 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
29377 & BE12*BE34*CTH)
29378 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
29379 ENDIF
29380 SHR=SQRT(SH)
29381 SH2=SH**2
29382 TH2=TH**2
29383 UH2=UH**2
29384
29385C...Choice of Q2 scale for hard process (e.g. alpha_s).
29386 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
29387 Q2=SH
29388 ELSEIF(ISTSB.EQ.8) THEN
29389 IF(MINT(107).EQ.4) Q2=VINT(307)
29390 IF(MINT(108).EQ.4) Q2=VINT(308)
29391 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
29392 Q2IN1=0D0
29393 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
29394 Q2IN2=0D0
29395 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
29396 IF(MSTP(32).EQ.1) THEN
29397 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
29398 ELSEIF(MSTP(32).EQ.2) THEN
29399 Q2=SQPTH+0.5D0*(SQM3+SQM4)
29400 ELSEIF(MSTP(32).EQ.3) THEN
29401 Q2=MIN(-TH,-UH)
29402 ELSEIF(MSTP(32).EQ.4) THEN
29403 Q2=SH
29404 ELSEIF(MSTP(32).EQ.5) THEN
29405 Q2=-TH
29406 ELSEIF(MSTP(32).EQ.6) THEN
29407 XSF1=X(1)
29408 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
29409 XSF2=X(2)
29410 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
29411 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
29412 & (SQPTH+0.5D0*(SQM3+SQM4))
29413 ELSEIF(MSTP(32).EQ.7) THEN
29414 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
29415 ELSEIF(MSTP(32).EQ.8) THEN
29416 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
29417 ELSEIF(MSTP(32).EQ.9) THEN
29418 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
29419 ELSEIF(MSTP(32).EQ.10) THEN
29420 Q2=VINT(2)
29421C..Begin JA 040914
29422 ELSEIF(MSTP(32).EQ.11) THEN
29423 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
29424 ELSEIF(MSTP(32).EQ.12) THEN
29425 Q2=PARP(193)
29426C..End JA
29427 ELSEIF(MSTP(32).EQ.13) THEN
29428 Q2=SQPTH
29429 ENDIF
29430 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
29431 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
29432 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
29433 ENDIF
29434
29435C...Choice of Q2 scale for parton densities.
29436 Q2SF=Q2
29437C..Begin JA 040914
29438 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
29439 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
29440 & Q2=PARP(194)
29441C..End JA
29442 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29443 Q2SF=PMAS(23,1)**2
29444 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
29445 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
29446 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
29447 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
29448 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
29449 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
29450 IF(MSTP(39).EQ.2) Q2SF=
29451 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
29452 IF(MSTP(39).EQ.3) Q2SF=SH
29453 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
29454 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
29455C..Begin JA 040914
29456 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
29457 IF(MSTP(39).EQ.7) Q2SF=
29458 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
29459 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
29460C..End JA
29461 ENDIF
29462 ENDIF
29463 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
29464
29465 Q2PS=Q2SF
29466 Q2SF=Q2SF*PARP(34)
29467 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
29468 IF(MSTP(69).GE.2) Q2SF=VINT(2)
29469
29470C...Identify to which class(es) subprocess belongs
29471 ISMECR=0
29472 ISQCD=0
29473 ISJETS=0
29474 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
29475 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
29476 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
29477 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
29478 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
29479 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
29480 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
29481 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
29482 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
29483 IF (ISTSB.EQ.9) ISQCD=1
29484 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
29485 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
29486 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
29487 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
29488 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
29489 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
29490 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
29491 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
29492C...WBF is special case of ISJETS
29493 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
29494 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
29495 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
29496 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
29497 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
29498 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
29499 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
29500 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
29501 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
29502C...Some processes with photons also belong here.
29503 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
29504 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
29505 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
29506 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
29507 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
29508 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
29509
29510C...Choice of Q2 scale for parton-shower activity.
29511 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
29512 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
29513 XBJ=X(2)
29514 IF(MINT(43).EQ.3) XBJ=X(1)
29515 IF(MSTP(22).EQ.1) THEN
29516 Q2PS=-TH
29517 ELSEIF(MSTP(22).EQ.2) THEN
29518 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
29519 ELSEIF(MSTP(22).EQ.3) THEN
29520 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
29521 ELSE
29522 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
29523 ENDIF
29524 ENDIF
29525C...For multiple interactions, start from scale defined above
29526C...For all other QCD or "+jets"-type events, start shower from pThard.
29527 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
29528 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
29529C...Max shower scale = s for ME corrected processes.
29530C...(pT-ordering: max pT2 is s/4)
29531 Q2PS=VINT(2)
29532 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29533 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
29534C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29535C...(pT-ordering: max pT2 is s/4)
29536 Q2PS=VINT(2)
29537 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29538 ENDIF
29539 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
29540
29541C...Elastic and diffractive events not associated with scales so set 0.
29542 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
29543 Q2SF=0D0
29544 Q2PS=0D0
29545 ENDIF
29546
29547C...Store derived kinematical quantities
29548 VINT(41)=X(1)
29549 VINT(42)=X(2)
29550 VINT(44)=SH
29551 VINT(43)=SQRT(SH)
29552 VINT(45)=TH
29553 VINT(46)=UH
29554 IF(ISTSB.NE.8) VINT(48)=SQPTH
29555 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
29556 VINT(50)=TAUP*VINT(2)
29557 VINT(49)=SQRT(MAX(0D0,VINT(50)))
29558 VINT(52)=Q2
29559 VINT(51)=SQRT(Q2)
29560 VINT(54)=Q2SF
29561 VINT(53)=SQRT(Q2SF)
29562 VINT(56)=Q2PS
29563 VINT(55)=SQRT(Q2PS)
29564
29565C...Set starting scale for multiple interactions
29566 IF (ISUBSV.EQ.95) THEN
29567 XT2GMX=0D0
29568 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
29569 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
29570 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
29571 & ISUBSV.NE.96)) THEN
29572C...All accessible phase space allowed.
29573 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
29574 ELSE
29575C...Scale of hard process sets limit.
29576C...2 -> 1. Limit is tau = x1*x2.
29577C...2 -> 2. Limit is XT2 for hard process + FS masses.
29578C...2 -> n > 2. Limit is tau' = tau of outer process.
29579 XT2GMX=VINT(25)
29580 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
29581 IF(ISTSB.EQ.2)
29582 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
29583 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
29584 ENDIF
29585 VINT(62)=0.25D0*XT2GMX*VINT(2)
29586 VINT(61)=SQRT(MAX(0D0,VINT(62)))
29587
29588C...Calculate parton distributions
29589 IF(ISTSB.LE.0) GOTO 160
29590 IF(MINT(47).GE.2) THEN
29591 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
29592 XSF=X(I)
29593 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
29594 IF(ISUB.EQ.99) THEN
29595 IF(MINT(140+I).EQ.0) THEN
29596 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
29597 ELSE
29598 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
29599 ENDIF
29600 VINT(40+I)=XSF
29601 Q2SF=VINT(309-I)
29602 ENDIF
29603 MINT(105)=MINT(102+I)
29604 MINT(109)=MINT(106+I)
29605 VINT(120)=VINT(2+I)
29606C.... ALICE
29607C.... Store side in MINT(124)
29608 MINT(124) = I
29609C....
29610 IF(MSTP(57).LE.1) THEN
29611 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
29612 ELSE
29613 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
29614 ENDIF
29615C...Safety margin against heavy flavour very close to threshold,
29616C...e.g. caused by mismatch in c and b masses.
29617 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
29618 XPQ(4)=0D0
29619 XPQ(-4)=0D0
29620 ENDIF
29621 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
29622 XPQ(5)=0D0
29623 XPQ(-5)=0D0
29624 ENDIF
29625 DO 100 KFL=-25,25
29626 XSFX(I,KFL)=XPQ(KFL)
29627 100 CONTINUE
29628 110 CONTINUE
29629 ENDIF
29630
29631C...Calculate alpha_em, alpha_strong and K-factor
29632 XW=PARU(102)
29633 XWV=XW
29634 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
29635 &1D0-(PMAS(24,1)/PMAS(23,1))**2
29636 XW1=1D0-XW
29637 XWC=1D0/(16D0*XW*XW1)
29638 AEM=PYALEM(Q2)
29639 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
29640 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
29641 FACK=1D0
29642 FACA=1D0
29643 IF(MSTP(33).EQ.1) THEN
29644 FACK=PARP(31)
29645 ELSEIF(MSTP(33).EQ.2) THEN
29646 FACK=PARP(31)
29647 FACA=PARP(32)/PARP(31)
29648 ELSEIF(MSTP(33).EQ.3) THEN
29649 Q2AS=PARP(33)*Q2
29650 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
29651 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
29652 AS=PYALPS(Q2AS)
29653 ENDIF
29654 VINT(138)=1D0
29655 VINT(57)=AEM
29656 VINT(58)=AS
29657
29658C...Set flags for allowed reacting partons/leptons
29659 DO 140 I=1,2
29660 DO 120 J=-25,25
29661 KFAC(I,J)=0
29662 120 CONTINUE
29663 IF(MINT(44+I).EQ.1) THEN
29664 KFAC(I,MINT(10+I))=1
29665 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
29666 KFAC(I,MINT(10+I))=1
29667 KFAC(I,22)=1
29668 KFAC(I,24)=1
29669 KFAC(I,-24)=1
29670 ELSE
29671 DO 130 J=-25,25
29672 KFAC(I,J)=KFIN(I,J)
29673 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
29674 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
29675 130 CONTINUE
29676 ENDIF
29677 140 CONTINUE
29678
29679C...Lower and upper limit for fermion flavour loops
29680 MMIN1=0
29681 MMAX1=0
29682 MMIN2=0
29683 MMAX2=0
29684 DO 150 J=-20,20
29685 IF(KFAC(1,-J).EQ.1) MMIN1=-J
29686 IF(KFAC(1,J).EQ.1) MMAX1=J
29687 IF(KFAC(2,-J).EQ.1) MMIN2=-J
29688 IF(KFAC(2,J).EQ.1) MMAX2=J
29689 150 CONTINUE
29690 MMINA=MIN(MMIN1,MMIN2)
29691 MMAXA=MAX(MMAX1,MMAX2)
29692
29693C...Common resonance mass and width combinations
29694 SQMZ=PMAS(23,1)**2
29695 SQMW=PMAS(24,1)**2
29696 GMMZ=PMAS(23,1)*PMAS(23,2)
29697 GMMW=PMAS(24,1)*PMAS(24,2)
29698
29699C...Polarization factors...implemented so far for W+W-(25)
29700 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
29701 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
29702 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
29703 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
29704
29705C...Phase space integral in tau
29706 COMFAC=PARU(1)*PARU(5)/VINT(2)
29707 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
29708 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
29709 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
29710 ATAU1=LOG(TAUMAX/TAUMIN)
29711 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
29712 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
29713 IF(MINT(72).GE.1) THEN
29714 TAUR1=VINT(73)
29715 GAMR1=VINT(74)
29716 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
29717 ATAU3=ATAUD/TAUR1
29718 IF(ATAUD.GT.1D-10) H1=H1+
29719 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
29720 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
29721 ATAU4=ATAUD/GAMR1
29722 IF(ATAUD.GT.1D-10) H1=H1+
29723 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
29724 ENDIF
29725 IF(MINT(72).GE.2) THEN
29726 TAUR2=VINT(75)
29727 GAMR2=VINT(76)
29728 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
29729 ATAU5=ATAUD/TAUR2
29730 IF(ATAUD.GT.1D-10) H1=H1+
29731 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
29732 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
29733 ATAU6=ATAUD/GAMR2
29734 IF(ATAUD.GT.1D-10) H1=H1+
29735 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
29736 ENDIF
29737 IF(MINT(72).EQ.3) THEN
29738 TAUR3=VINT(77)
29739 GAMR3=VINT(78)
29740 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
29741 ATAU50=ATAUD/TAUR3
29742 IF(ATAUD.GT.1D-10) H1=H1+
29743 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
29744 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
29745 ATAU60=ATAUD/GAMR3
29746 IF(ATAUD.GT.1D-10) H1=H1+
29747 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
29748 ENDIF
29749 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29750 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
29751 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29752 & MAX(2D-10,1D0-TAU)
29753 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29754 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
29755 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29756 & MAX(1D-10,1D0-TAU)
29757 ENDIF
29758 COMFAC=COMFAC*ATAU1/(TAU*H1)
29759 ENDIF
29760
29761C...Phase space integral in y*
29762 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
29763 &THEN
29764 AYST0=YSTMAX-YSTMIN
29765 IF(AYST0.LT.1D-10) THEN
29766 COMFAC=0D0
29767 ELSE
29768 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29769 AYST2=AYST1
29770 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29771 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29772 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29773 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29774 IF(MINT(45).EQ.3) THEN
29775 YST0=-0.5D0*LOG(TAUE)
29776 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
29777 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29778 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
29779 & MAX(1D-10,1D0-EXP(YST-YST0))
29780 ENDIF
29781 IF(MINT(46).EQ.3) THEN
29782 YST0=-0.5D0*LOG(TAUE)
29783 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
29784 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29785 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
29786 & MAX(1D-10,1D0-EXP(-YST-YST0))
29787 ENDIF
29788 COMFAC=COMFAC*AYST0/H2
29789 ENDIF
29790 ENDIF
29791
29792C...2 -> 1 processes: reduction in angular part of phase space integral
29793C...for case of decaying resonance
29794 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
29795 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
29796 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
29797 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
29798 & KFPR(ISUB,1).EQ.39) THEN
29799 COMFAC=COMFAC*0.5D0*ACTH0
29800 ELSE
29801 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
29802 & CTPMAX**3-CTPMIN**3)
29803 ENDIF
29804 ENDIF
29805
29806C...2 -> 2 processes: angular part of phase space integral
29807 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29808 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
29809 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
29810 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
29811 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
29812 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
29813 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
29814 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
29815 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
29816 H3=COEF(ISUBSV,13)+
29817 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
29818 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
29819 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
29820 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
29821 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
29822
29823C...2 -> 2 processes: take into account final state Breit-Wigners
29824 COMFAC=COMFAC*VINT(80)
29825 ENDIF
29826
29827C...2 -> 3, 4 processes: phace space integral in tau'
29828 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29829 ATAUP1=LOG(TAUPMX/TAUPMN)
29830 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
29831 H4=COEF(ISUBSV,18)+
29832 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
29833 IF(MINT(47).EQ.5) THEN
29834 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
29835 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
29836 ELSEIF(MINT(47).GE.6) THEN
29837 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
29838 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
29839 ENDIF
29840 COMFAC=COMFAC*ATAUP1/H4
29841 ENDIF
29842
29843C...2 -> 3, 4 processes: effective W/Z parton distributions
29844 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
29845 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29846 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29847 ELSE
29848 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29849 ENDIF
29850 COMFAC=COMFAC*FZW
29851 ENDIF
29852
29853C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29854 IF(ISTSB.EQ.5) THEN
29855 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29856 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29857 ENDIF
29858
29859C...Phase space integral for low-pT and multiple interactions
29860 IF(ISTSB.EQ.9) THEN
29861 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29862 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29863 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29864 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29865 COMFAC=COMFAC*ATAU1/H1
29866 AYST0=YSTMAX-YSTMIN
29867 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29868 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29869 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29870 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29871 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29872 COMFAC=COMFAC*AYST0/H2
29873 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29874C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29875C...introduced to make cross-section finite for xT2 -> 0
29876 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29877 & (1D0+VINT(149)))
29878 ENDIF
29879
29880C...Real gamma + gamma: include factor 2 when different nature
29881 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29882 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29883
29884C...Extra factors to include the effects of
29885C...longitudinal resolved photons (but not direct or DIS ones).
29886 DO 170 ISDE=1,2
29887 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29888 & MINT(106+ISDE).LE.3) THEN
29889 VINT(314+ISDE)=1D0
29890 XY=PARP(166+ISDE)
29891 IF(MSTP(16).EQ.0) THEN
29892 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29893 & XY=VINT(304+ISDE)
29894 ELSE
29895 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29896 & XY=VINT(308+ISDE)
29897 ENDIF
29898 Q2GA=VINT(306+ISDE)
29899 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29900 & Q2GA.GT.0D0) THEN
29901 REDUCE=0D0
29902 IF(MSTP(17).EQ.1) THEN
29903 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29904 ELSEIF(MSTP(17).EQ.2) THEN
29905 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29906 ELSEIF(MSTP(17).EQ.3) THEN
29907 PMVIRT=PMAS(PYCOMP(113),1)
29908 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29909 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29910 PMVIRT=PMAS(PYCOMP(113),1)
29911 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29912 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29913 PMVIRT=PMAS(PYCOMP(113),1)
29914 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29915 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29916 PMVSMN=4D0*PARP(15)**2
29917 PMVSMX=4D0*VINT(154)**2
29918 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29919 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29920 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29921 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29922 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29923 PMVIRT=PMAS(PYCOMP(113),1)
29924 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29925 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29926 PMVIRT=PMAS(PYCOMP(113),1)
29927 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29928 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29929 PMVSMN=4D0*PARP(15)**2
29930 PMVSMX=4D0*VINT(154)**2
29931 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29932 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29933 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29934 ENDIF
29935 BEAMAS=PYMASS(11)
29936 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29937 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29938 & (1D0-2D0*BEAMAS**2/Q2GA))
29939 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29940 ENDIF
29941 ELSE
29942 VINT(314+ISDE)=1D0
29943 ENDIF
29944 COMFAC=COMFAC*VINT(314+ISDE)
29945 170 CONTINUE
29946
29947C...Evaluate cross sections - done in separate routines by kind
29948C...of physics, to keep PYSIGH of sensible size.
29949 IF(MAP.EQ.1) THEN
29950C...Standard QCD (including photons).
29951 CALL PYSGQC(NCHN,SIGS)
29952 ELSEIF(MAP.EQ.2) THEN
29953C...Heavy flavours.
29954 CALL PYSGHF(NCHN,SIGS)
29955 ELSEIF(MAP.EQ.3) THEN
29956C...W/Z.
29957 CALL PYSGWZ(NCHN,SIGS)
29958 ELSEIF(MAP.EQ.4) THEN
29959C...Higgs (2 doublets; including longitudinal W/Z scattering).
29960 CALL PYSGHG(NCHN,SIGS)
29961 ELSEIF(MAP.EQ.5) THEN
29962C...SUSY.
29963 CALL PYSGSU(NCHN,SIGS)
29964 ELSEIF(MAP.EQ.6) THEN
29965C...Technicolor.
29966 CALL PYSGTC(NCHN,SIGS)
29967 ELSEIF(MAP.EQ.7) THEN
29968C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29969 CALL PYSGEX(NCHN,SIGS)
29970 ELSEIF(MAP.EQ.8) THEN
29971C... Universal Extra Dimensions
29972 CALL PYXUED(NCHN,SIGS)
29973 ENDIF
29974
29975C...Multiply with parton distributions
29976 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29977 DO 180 ICHN=1,NCHN
29978 IF(MINT(45).GE.2) THEN
29979 KFL1=ISIG(ICHN,1)
29980 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29981 ENDIF
29982 IF(MINT(46).GE.2) THEN
29983 KFL2=ISIG(ICHN,2)
29984 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29985 ENDIF
29986 SIGS=SIGS+SIGH(ICHN)
29987 180 CONTINUE
29988 ENDIF
29989
29990 RETURN
29991 END
29992
29993C*********************************************************************
29994
29995C...PYSGQC
29996C...Subprocess cross sections for QCD processes,
29997C...including photons.
29998C...Auxiliary to PYSIGH.
29999
30000 SUBROUTINE PYSGQC(NCHN,SIGS)
30001
30002C...Double precision and integer declarations
30003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30004 IMPLICIT INTEGER(I-N)
30005 INTEGER PYK,PYCHGE,PYCOMP
30006C...Parameter statement to help give large particle numbers.
30007 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30008 &KEXCIT=4000000,KDIMEN=5000000)
30009C...Commonblocks
30010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30011 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30012 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30013 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30014 COMMON/PYINT1/MINT(400),VINT(400)
30015 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30016 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30017 COMMON/PYINT4/MWID(500),WIDS(500,5)
30018 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30019 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30020 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30021 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30022 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30023 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30024 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30025C...Local arrays
30026 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30027
30028C...Differential cross section expressions.
30029
30030 IF(ISUB.LE.20) THEN
30031 IF(ISUB.EQ.10) THEN
30032C...f + f' -> f + f' (gamma/Z/W exchange)
30033 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30034 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30035 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30036 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30037 DO 110 I=MMIN1,MMAX1
30038 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30039 IA=IABS(I)
30040 DO 100 J=MMIN2,MMAX2
30041 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30042 JA=IABS(J)
30043C...Electroweak couplings
30044 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30045 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30046 VI=AI-4D0*EI*XWV
30047 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30048 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30049 VJ=AJ-4D0*EJ*XWV
30050 EPSIJ=ISIGN(1,I*J)
30051C...gamma/Z exchange, only gamma exchange, or only Z exchange
30052 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30053 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30054 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30055 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30056 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30057 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30058 ELSEIF(MSTP(21).EQ.2) THEN
30059 FACNCF=FACGGF*EI**2*EJ**2
30060 ELSE
30061 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30062 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30063 ENDIF
30064C...Extrafactor 2 for only one incoming neutrino spin state.
30065 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30066 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30067 NCHN=NCHN+1
30068 ISIG(NCHN,1)=I
30069 ISIG(NCHN,2)=J
30070 ISIG(NCHN,3)=1
30071 SIGH(NCHN)=FACNCF
30072 ENDIF
30073C...W exchange
30074 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30075 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30076 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30077 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30078 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30079 NCHN=NCHN+1
30080 ISIG(NCHN,1)=I
30081 ISIG(NCHN,2)=J
30082 ISIG(NCHN,3)=2
30083 SIGH(NCHN)=FACCCF
30084 ENDIF
30085 100 CONTINUE
30086 110 CONTINUE
30087
30088 ELSEIF(ISUB.EQ.11) THEN
30089C...f + f' -> f + f' (g exchange)
30090 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30091 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30092 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30093 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30094 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30095 DO 130 I=MMIN1,MMAX1
30096 IA=IABS(I)
30097 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30098 DO 120 J=MMIN2,MMAX2
30099 JA=IABS(J)
30100 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30101 NCHN=NCHN+1
30102 ISIG(NCHN,1)=I
30103 ISIG(NCHN,2)=J
30104 ISIG(NCHN,3)=1
30105 SIGH(NCHN)=FACQQ1
30106 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30107 IF(I.EQ.J) THEN
30108 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30109 NCHN=NCHN+1
30110 ISIG(NCHN,1)=I
30111 ISIG(NCHN,2)=J
30112 ISIG(NCHN,3)=2
30113 SIGH(NCHN)=0.5D0*FACQQ2
30114 ENDIF
30115 120 CONTINUE
30116 130 CONTINUE
30117
30118 ELSEIF(ISUB.EQ.12) THEN
30119C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30120 CALL PYWIDT(21,SH,WDTP,WDTE)
30121 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30122 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30123 DO 140 I=MMINA,MMAXA
30124 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30125 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30126 NCHN=NCHN+1
30127 ISIG(NCHN,1)=I
30128 ISIG(NCHN,2)=-I
30129 ISIG(NCHN,3)=1
30130 SIGH(NCHN)=FACQQB
30131 140 CONTINUE
30132
30133 ELSEIF(ISUB.EQ.13) THEN
30134C...f + fbar -> g + g (q + qbar -> g + g only)
30135 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30136 & UH2/SH2)
30137 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30138 & TH2/SH2)
30139 DO 150 I=MMINA,MMAXA
30140 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30141 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30142 NCHN=NCHN+1
30143 ISIG(NCHN,1)=I
30144 ISIG(NCHN,2)=-I
30145 ISIG(NCHN,3)=1
30146 SIGH(NCHN)=0.5D0*FACGG1
30147 NCHN=NCHN+1
30148 ISIG(NCHN,1)=I
30149 ISIG(NCHN,2)=-I
30150 ISIG(NCHN,3)=2
30151 SIGH(NCHN)=0.5D0*FACGG2
30152 150 CONTINUE
30153
30154 ELSEIF(ISUB.EQ.14) THEN
30155C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30156 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30157 DO 160 I=MMINA,MMAXA
30158 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30159 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30160 EI=KCHG(IABS(I),1)/3D0
30161 NCHN=NCHN+1
30162 ISIG(NCHN,1)=I
30163 ISIG(NCHN,2)=-I
30164 ISIG(NCHN,3)=1
30165 SIGH(NCHN)=FACGG*EI**2
30166 160 CONTINUE
30167
30168 ELSEIF(ISUB.EQ.18) THEN
30169C...f + fbar -> gamma + gamma
30170 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30171 DO 170 I=MMINA,MMAXA
30172 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30173 EI=KCHG(IABS(I),1)/3D0
30174 FCOI=1D0
30175 IF(IABS(I).LE.10) FCOI=FACA/3D0
30176 NCHN=NCHN+1
30177 ISIG(NCHN,1)=I
30178 ISIG(NCHN,2)=-I
30179 ISIG(NCHN,3)=1
30180 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30181 170 CONTINUE
30182 ENDIF
30183
30184 ELSEIF(ISUB.LE.40) THEN
30185 IF(ISUB.EQ.28) THEN
30186C...f + g -> f + g (q + g -> q + g only)
30187 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30188 & UH/SH)*FACA
30189 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30190 & SH/UH)
30191 DO 190 I=MMINA,MMAXA
30192 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30193 DO 180 ISDE=1,2
30194 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30195 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30196 NCHN=NCHN+1
30197 ISIG(NCHN,ISDE)=I
30198 ISIG(NCHN,3-ISDE)=21
30199 ISIG(NCHN,3)=1
30200 SIGH(NCHN)=FACQG1
30201 NCHN=NCHN+1
30202 ISIG(NCHN,ISDE)=I
30203 ISIG(NCHN,3-ISDE)=21
30204 ISIG(NCHN,3)=2
30205 SIGH(NCHN)=FACQG2
30206 180 CONTINUE
30207 190 CONTINUE
30208
30209 ELSEIF(ISUB.EQ.29) THEN
30210C...f + g -> f + gamma (q + g -> q + gamma only)
30211 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30212 DO 210 I=MMINA,MMAXA
30213 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30214 EI=KCHG(IABS(I),1)/3D0
30215 FACGQ=FGQ*EI**2
30216 DO 200 ISDE=1,2
30217 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30218 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30219 NCHN=NCHN+1
30220 ISIG(NCHN,ISDE)=I
30221 ISIG(NCHN,3-ISDE)=21
30222 ISIG(NCHN,3)=1
30223 SIGH(NCHN)=FACGQ
30224 200 CONTINUE
30225 210 CONTINUE
30226
30227 ELSEIF(ISUB.EQ.33) THEN
30228C...f + gamma -> f + g (q + gamma -> q + g only)
30229 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30230 DO 230 I=MMINA,MMAXA
30231 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30232 EI=KCHG(IABS(I),1)/3D0
30233 FACGQ=FGQ*EI**2
30234 DO 220 ISDE=1,2
30235 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30236 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30237 NCHN=NCHN+1
30238 ISIG(NCHN,ISDE)=I
30239 ISIG(NCHN,3-ISDE)=22
30240 ISIG(NCHN,3)=1
30241 SIGH(NCHN)=FACGQ
30242 220 CONTINUE
30243 230 CONTINUE
30244
30245 ELSEIF(ISUB.EQ.34) THEN
30246C...f + gamma -> f + gamma
30247 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30248 DO 250 I=MMINA,MMAXA
30249 IF(I.EQ.0) GOTO 250
30250 EI=KCHG(IABS(I),1)/3D0
30251 FACGQ=FGQ*EI**4
30252 DO 240 ISDE=1,2
30253 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30254 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30255 NCHN=NCHN+1
30256 ISIG(NCHN,ISDE)=I
30257 ISIG(NCHN,3-ISDE)=22
30258 ISIG(NCHN,3)=1
30259 SIGH(NCHN)=FACGQ
30260 240 CONTINUE
30261 250 CONTINUE
30262 ENDIF
30263
30264 ELSEIF(ISUB.LE.80) THEN
30265 IF(ISUB.EQ.53) THEN
30266C...g + g -> f + fbar (g + g -> q + qbar only)
30267 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30268 IDC0=MDCY(21,2)-1
30269C...Begin by d, u, s flavours.
30270 FLAVWT=0D0
30271 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30272 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30273 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30274 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30275 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30276 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30277 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30278 & UH2/SH2)*FLAVWT*FACA
30279 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30280 & TH2/SH2)*FLAVWT*FACA
30281 NCHN=NCHN+1
30282 ISIG(NCHN,1)=21
30283 ISIG(NCHN,2)=21
30284 ISIG(NCHN,3)=1
30285 SIGH(NCHN)=FACQQ1
30286 NCHN=NCHN+1
30287 ISIG(NCHN,1)=21
30288 ISIG(NCHN,2)=21
30289 ISIG(NCHN,3)=2
30290 SIGH(NCHN)=FACQQ2
30291C...Next c and b flavours: modified that and uhat for fixed
30292C...cos(theta-hat).
30293 DO 260 IFL=4,5
30294 SQMAVG=PMAS(IFL,1)**2
30295 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30296 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30297 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30298 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30299 THUHQ=THQ*UHQ-SQMAVG*SH
30300 IF(MSTP(34).EQ.0) THEN
30301 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30302 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30303 ELSE
30304 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30305 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30306 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30307 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30308 ENDIF
30309 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30310 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30311 NCHN=NCHN+1
30312 ISIG(NCHN,1)=21
30313 ISIG(NCHN,2)=21
30314 ISIG(NCHN,3)=1+2*(IFL-3)
30315 SIGH(NCHN)=FACQQ1
30316 NCHN=NCHN+1
30317 ISIG(NCHN,1)=21
30318 ISIG(NCHN,2)=21
30319 ISIG(NCHN,3)=2+2*(IFL-3)
30320 SIGH(NCHN)=FACQQ2
30321 ENDIF
30322 260 CONTINUE
30323 270 CONTINUE
30324
30325 ELSEIF(ISUB.EQ.54) THEN
30326C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30327 CALL PYWIDT(21,SH,WDTP,WDTE)
30328 WDTESU=0D0
30329 DO 280 I=1,MIN(8,MDCY(21,3))
30330 EF=KCHG(I,1)/3D0
30331 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30332 & WDTE(I,4))
30333 280 CONTINUE
30334 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
30335 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30336 NCHN=NCHN+1
30337 ISIG(NCHN,1)=21
30338 ISIG(NCHN,2)=22
30339 ISIG(NCHN,3)=1
30340 SIGH(NCHN)=FACQQ
30341 ENDIF
30342 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30343 NCHN=NCHN+1
30344 ISIG(NCHN,1)=22
30345 ISIG(NCHN,2)=21
30346 ISIG(NCHN,3)=1
30347 SIGH(NCHN)=FACQQ
30348 ENDIF
30349
30350 ELSEIF(ISUB.EQ.58) THEN
30351C...gamma + gamma -> f + fbar
30352 CALL PYWIDT(22,SH,WDTP,WDTE)
30353 WDTESU=0D0
30354 DO 290 I=1,MIN(12,MDCY(22,3))
30355 IF(I.LE.8) EF= KCHG(I,1)/3D0
30356 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30357 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30358 & WDTE(I,4))
30359 290 CONTINUE
30360 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
30361 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30362 NCHN=NCHN+1
30363 ISIG(NCHN,1)=22
30364 ISIG(NCHN,2)=22
30365 ISIG(NCHN,3)=1
30366 SIGH(NCHN)=FACFF
30367 ENDIF
30368
30369 ELSEIF(ISUB.EQ.68) THEN
30370C...g + g -> g + g
30371 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
30372 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
30373 & TH2/SH2)*FACA
30374 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
30375 & SH2/UH2)*FACA
30376 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
30377 & UH2/TH2)
30378 NCHN=NCHN+1
30379 ISIG(NCHN,1)=21
30380 ISIG(NCHN,2)=21
30381 ISIG(NCHN,3)=1
30382 SIGH(NCHN)=0.5D0*FACGG1
30383 NCHN=NCHN+1
30384 ISIG(NCHN,1)=21
30385 ISIG(NCHN,2)=21
30386 ISIG(NCHN,3)=2
30387 SIGH(NCHN)=0.5D0*FACGG2
30388 NCHN=NCHN+1
30389 ISIG(NCHN,1)=21
30390 ISIG(NCHN,2)=21
30391 ISIG(NCHN,3)=3
30392 SIGH(NCHN)=0.5D0*FACGG3
30393 300 CONTINUE
30394
30395 ELSEIF(ISUB.EQ.80) THEN
30396C...q + gamma -> q' + pi+/-
30397 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
30398 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
30399 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
30400 DELSH=UH*SQRT(ASSH*Q2FPSH)
30401 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
30402 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
30403 DELUH=SH*SQRT(ASUH*Q2FPUH)
30404 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
30405 IF(I.EQ.0) GOTO 320
30406 EI=KCHG(IABS(I),1)/3D0
30407 EJ=SIGN(1D0-ABS(EI),EI)
30408 DO 310 ISDE=1,2
30409 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
30410 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
30411 NCHN=NCHN+1
30412 ISIG(NCHN,ISDE)=I
30413 ISIG(NCHN,3-ISDE)=22
30414 ISIG(NCHN,3)=1
30415 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
30416 310 CONTINUE
30417 320 CONTINUE
30418 ENDIF
30419
30420 ELSEIF(ISUB.LE.100) THEN
30421 IF(ISUB.EQ.91) THEN
30422C...Elastic scattering
30423 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
30424
30425 ELSEIF(ISUB.EQ.92) THEN
30426C...Single diffractive scattering (first side, i.e. XB)
30427 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
30428
30429 ELSEIF(ISUB.EQ.93) THEN
30430C...Single diffractive scattering (second side, i.e. AX)
30431 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
30432
30433 ELSEIF(ISUB.EQ.94) THEN
30434C...Double diffractive scattering
30435 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
30436
30437 ELSEIF(ISUB.EQ.95) THEN
30438C...Low-pT scattering
30439 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
30440
30441 ELSEIF(ISUB.EQ.96) THEN
30442C...Multiple interactions: sum of QCD processes
30443 CALL PYWIDT(21,SH,WDTP,WDTE)
30444
30445C...q + q' -> q + q'
30446 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30447 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30448 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30449 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
30450 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
30451 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
30452 DO 340 I=-5,5
30453 IF(I.EQ.0) GOTO 340
30454 DO 330 J=-5,5
30455 IF(J.EQ.0) GOTO 330
30456 NCHN=NCHN+1
30457 ISIG(NCHN,1)=I
30458 ISIG(NCHN,2)=J
30459 ISIG(NCHN,3)=111
30460 SIGH(NCHN)=FACQQ1
30461 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30462 IF(I.EQ.J) THEN
30463 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
30464 NCHN=NCHN+1
30465 ISIG(NCHN,1)=I
30466 ISIG(NCHN,2)=J
30467 ISIG(NCHN,3)=112
30468 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
30469 ENDIF
30470 330 CONTINUE
30471 340 CONTINUE
30472
30473C...q + qbar -> q' + qbar' or g + g
30474 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30475 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
30476 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30477 & UH2/SH2)
30478 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30479 & TH2/SH2)
30480 DO 350 I=-5,5
30481 IF(I.EQ.0) GOTO 350
30482 NCHN=NCHN+1
30483 ISIG(NCHN,1)=I
30484 ISIG(NCHN,2)=-I
30485 ISIG(NCHN,3)=121
30486 SIGH(NCHN)=FACQQB
30487 NCHN=NCHN+1
30488 ISIG(NCHN,1)=I
30489 ISIG(NCHN,2)=-I
30490 ISIG(NCHN,3)=131
30491 SIGH(NCHN)=0.5D0*FACGG1
30492 NCHN=NCHN+1
30493 ISIG(NCHN,1)=I
30494 ISIG(NCHN,2)=-I
30495 ISIG(NCHN,3)=132
30496 SIGH(NCHN)=0.5D0*FACGG2
30497 350 CONTINUE
30498
30499C...q + g -> q + g
30500 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30501 & UH/SH)*FACA
30502 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30503 & SH/UH)
30504 DO 370 I=-5,5
30505 IF(I.EQ.0) GOTO 370
30506 DO 360 ISDE=1,2
30507 NCHN=NCHN+1
30508 ISIG(NCHN,ISDE)=I
30509 ISIG(NCHN,3-ISDE)=21
30510 ISIG(NCHN,3)=281
30511 SIGH(NCHN)=FACQG1
30512 NCHN=NCHN+1
30513 ISIG(NCHN,ISDE)=I
30514 ISIG(NCHN,3-ISDE)=21
30515 ISIG(NCHN,3)=282
30516 SIGH(NCHN)=FACQG2
30517 360 CONTINUE
30518 370 CONTINUE
30519
30520C...g + g -> q + qbar (only d, u, s)
30521 IDC0=MDCY(21,2)-1
30522 FLAVWT=0D0
30523 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30524 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30525 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30526 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30527 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30528 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30529 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30530 & UH2/SH2)*FLAVWT*FACA
30531 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30532 & TH2/SH2)*FLAVWT*FACA
30533 NCHN=NCHN+1
30534 ISIG(NCHN,1)=21
30535 ISIG(NCHN,2)=21
30536 ISIG(NCHN,3)=531
30537 SIGH(NCHN)=FACQQ1
30538 NCHN=NCHN+1
30539 ISIG(NCHN,1)=21
30540 ISIG(NCHN,2)=21
30541 ISIG(NCHN,3)=532
30542 SIGH(NCHN)=FACQQ2
30543
30544C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30545C...cos(theta-hat)
30546 DO 380 IFL=4,5
30547 SQMAVG=PMAS(IFL,1)**2
30548 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30549 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30550 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30551 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30552 THUHQ=THQ*UHQ-SQMAVG*SH
30553 IF(MSTP(34).EQ.0) THEN
30554 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30555 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30556 ELSE
30557 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30558 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30559 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30560 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30561 ENDIF
30562 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30563 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30564 NCHN=NCHN+1
30565 ISIG(NCHN,1)=21
30566 ISIG(NCHN,2)=21
30567 ISIG(NCHN,3)=531+2*(IFL-3)
30568 SIGH(NCHN)=FACQQ1
30569 NCHN=NCHN+1
30570 ISIG(NCHN,1)=21
30571 ISIG(NCHN,2)=21
30572 ISIG(NCHN,3)=532+2*(IFL-3)
30573 SIGH(NCHN)=FACQQ2
30574 ENDIF
30575 380 CONTINUE
30576
30577C...g + g -> g + g
30578 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
30579 & 2D0*TH/SH+TH2/SH2)*FACA
30580 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
30581 & 2D0*SH/UH+SH2/UH2)*FACA
30582 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
30583 & 2D0*UH/TH+UH2/TH2)
30584 NCHN=NCHN+1
30585 ISIG(NCHN,1)=21
30586 ISIG(NCHN,2)=21
30587 ISIG(NCHN,3)=681
30588 SIGH(NCHN)=0.5D0*FACGG1
30589 NCHN=NCHN+1
30590 ISIG(NCHN,1)=21
30591 ISIG(NCHN,2)=21
30592 ISIG(NCHN,3)=682
30593 SIGH(NCHN)=0.5D0*FACGG2
30594 NCHN=NCHN+1
30595 ISIG(NCHN,1)=21
30596 ISIG(NCHN,2)=21
30597 ISIG(NCHN,3)=683
30598 SIGH(NCHN)=0.5D0*FACGG3
30599
30600 ELSEIF(ISUB.EQ.99) THEN
30601C...f + gamma* -> f.
30602 IF(MINT(107).EQ.4) THEN
30603 Q2GA=VINT(307)
30604 P2GA=VINT(308)
30605 ISDE=2
30606 ELSE
30607 Q2GA=VINT(308)
30608 P2GA=VINT(307)
30609 ISDE=1
30610 ENDIF
30611 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
30612 PM2RHO=PMAS(PYCOMP(113),1)**2
30613 IF(MSTP(19).EQ.0) THEN
30614 COMFAC=COMFAC/Q2GA
30615 ELSEIF(MSTP(19).EQ.1) THEN
30616 COMFAC=COMFAC/(Q2GA+PM2RHO)
30617 ELSEIF(MSTP(19).EQ.2) THEN
30618 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30619 ELSE
30620 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30621 W2GA=VINT(2)
30622 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
30623 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
30624 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
30625 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
30626 ELSE
30627 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
30628 & Q2GA**0.57D0)
30629 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
30630 ENDIF
30631 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
30632 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
30633 ENDIF
30634 DO 390 I=MMINA,MMAXA
30635 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
30636 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
30637 EI=KCHG(IABS(I),1)/3D0
30638 NCHN=NCHN+1
30639 ISIG(NCHN,ISDE)=I
30640 ISIG(NCHN,3-ISDE)=22
30641 ISIG(NCHN,3)=1
30642 SIGH(NCHN)=COMFAC*EI**2
30643 390 CONTINUE
30644 ENDIF
30645
30646 ELSE
30647 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
30648C...g + g -> gamma + gamma or g + g -> g + gamma
30649 A0STUR=0D0
30650 A0STUI=0D0
30651 A0TSUR=0D0
30652 A0TSUI=0D0
30653 A0UTSR=0D0
30654 A0UTSI=0D0
30655 A1STUR=0D0
30656 A1STUI=0D0
30657 A2STUR=0D0
30658 A2STUI=0D0
30659 ALST=LOG(-SH/TH)
30660 ALSU=LOG(-SH/UH)
30661 ALTU=LOG(TH/UH)
30662 IMAX=2*MSTP(1)
30663 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
30664 DO 400 I=1,IMAX
30665 EI=KCHG(IABS(I),1)/3D0
30666 EIWT=EI**2
30667 IF(ISUB.EQ.115) EIWT=EI
30668 SQMQ=PMAS(I,1)**2
30669 EPSS=4D0*SQMQ/SH
30670 EPST=4D0*SQMQ/TH
30671 EPSU=4D0*SQMQ/UH
30672 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
30673 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
30674 & PARU(1)**2)
30675 B0STUI=0D0
30676 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
30677 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
30678 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
30679 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
30680 B1STUR=-1D0
30681 B1STUI=0D0
30682 B2STUR=-1D0
30683 B2STUI=0D0
30684 ELSE
30685 CALL PYWAUX(1,EPSS,W1SR,W1SI)
30686 CALL PYWAUX(1,EPST,W1TR,W1TI)
30687 CALL PYWAUX(1,EPSU,W1UR,W1UI)
30688 CALL PYWAUX(2,EPSS,W2SR,W2SI)
30689 CALL PYWAUX(2,EPST,W2TR,W2TI)
30690 CALL PYWAUX(2,EPSU,W2UR,W2UI)
30691 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
30692 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
30693 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
30694 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
30695 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
30696 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
30697 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
30698 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
30699 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
30700 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
30701 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30702 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30703 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
30704 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
30705 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
30706 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
30707 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30708 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30709 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
30710 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
30711 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
30712 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
30713 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30714 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
30715 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
30716 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
30717 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
30718 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
30719 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30720 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
30721 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
30722 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
30723 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
30724 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
30725 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30726 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
30727 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
30728 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
30729 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
30730 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
30731 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30732 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
30733 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
30734 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
30735 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
30736 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30737 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
30738 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
30739 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
30740 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30741 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
30742 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
30743 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
30744 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
30745 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
30746 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
30747 ENDIF
30748 A0STUR=A0STUR+EIWT*B0STUR
30749 A0STUI=A0STUI+EIWT*B0STUI
30750 A0TSUR=A0TSUR+EIWT*B0TSUR
30751 A0TSUI=A0TSUI+EIWT*B0TSUI
30752 A0UTSR=A0UTSR+EIWT*B0UTSR
30753 A0UTSI=A0UTSI+EIWT*B0UTSI
30754 A1STUR=A1STUR+EIWT*B1STUR
30755 A1STUI=A1STUI+EIWT*B1STUI
30756 A2STUR=A2STUR+EIWT*B2STUR
30757 A2STUI=A2STUI+EIWT*B2STUI
30758 400 CONTINUE
30759 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
30760 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
30761 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
30762 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
30763 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
30764 NCHN=NCHN+1
30765 ISIG(NCHN,1)=21
30766 ISIG(NCHN,2)=21
30767 ISIG(NCHN,3)=1
30768 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
30769 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
30770 410 CONTINUE
30771
30772 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
30773C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30774 PH=0D0
30775 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30776 & PH=VINT(3)**2
30777 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30778 & PH=VINT(4)**2
30779 IF(ISUB.EQ.131) THEN
30780 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
30781 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30782 ELSE
30783 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30784 ENDIF
30785 DO 430 I=MMINA,MMAXA
30786 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
30787 EI=KCHG(IABS(I),1)/3D0
30788 FACGQ=FGQ*EI**2
30789 DO 420 ISDE=1,2
30790 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
30791 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
30792 NCHN=NCHN+1
30793 ISIG(NCHN,ISDE)=I
30794 ISIG(NCHN,3-ISDE)=22
30795 ISIG(NCHN,3)=1
30796 SIGH(NCHN)=FACGQ
30797 420 CONTINUE
30798 430 CONTINUE
30799
30800 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
30801C...f + gamma*_(T,L) -> f + gamma
30802 PH=0D0
30803 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30804 & PH=VINT(3)**2
30805 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30806 & PH=VINT(4)**2
30807 IF(ISUB.EQ.133) THEN
30808 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
30809 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30810 ELSE
30811 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30812 ENDIF
30813 DO 450 I=MMINA,MMAXA
30814 IF(I.EQ.0) GOTO 450
30815 EI=KCHG(IABS(I),1)/3D0
30816 FACGQ=FGQ*EI**4
30817 DO 440 ISDE=1,2
30818 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
30819 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
30820 NCHN=NCHN+1
30821 ISIG(NCHN,ISDE)=I
30822 ISIG(NCHN,3-ISDE)=22
30823 ISIG(NCHN,3)=1
30824 SIGH(NCHN)=FACGQ
30825 440 CONTINUE
30826 450 CONTINUE
30827
30828 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
30829C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30830 PH=0D0
30831 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30832 & PH=VINT(3)**2
30833 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30834 & PH=VINT(4)**2
30835 CALL PYWIDT(21,SH,WDTP,WDTE)
30836 WDTESU=0D0
30837 DO 460 I=1,MIN(8,MDCY(21,3))
30838 EF=KCHG(I,1)/3D0
30839 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30840 & WDTE(I,4))
30841 460 CONTINUE
30842 IF(ISUB.EQ.135) THEN
30843 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
30844 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
30845 ELSE
30846 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
30847 ENDIF
30848 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30849 NCHN=NCHN+1
30850 ISIG(NCHN,1)=21
30851 ISIG(NCHN,2)=22
30852 ISIG(NCHN,3)=1
30853 SIGH(NCHN)=FACQQ
30854 ENDIF
30855 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30856 NCHN=NCHN+1
30857 ISIG(NCHN,1)=22
30858 ISIG(NCHN,2)=21
30859 ISIG(NCHN,3)=1
30860 SIGH(NCHN)=FACQQ
30861 ENDIF
30862
30863 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30864C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30865 PH1=0D0
30866 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30867 PH2=0D0
30868 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30869 CALL PYWIDT(22,SH,WDTP,WDTE)
30870 WDTESU=0D0
30871 DO 470 I=1,MIN(12,MDCY(22,3))
30872 IF(I.LE.8) EF= KCHG(I,1)/3D0
30873 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30874 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30875 & WDTE(I,4))
30876 470 CONTINUE
30877 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30878 IF(ISUB.EQ.137) THEN
30879 FPARAM=-SH*(TH+UH)/DLAMB2
30880 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30881 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30882 & 2D0*PH1*PH2*FPARAM**2)
30883 ELSEIF(ISUB.EQ.138) THEN
30884 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30885 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30886 & 2D0*PH1**2*(TH-UH)**2)
30887 ELSEIF(ISUB.EQ.139) THEN
30888 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30889 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30890 & 2D0*PH2**2*(TH-UH)**2)
30891 ELSE
30892 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30893 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30894 ENDIF
30895 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30896 NCHN=NCHN+1
30897 ISIG(NCHN,1)=22
30898 ISIG(NCHN,2)=22
30899 ISIG(NCHN,3)=1
30900 SIGH(NCHN)=FACFF
30901 ENDIF
30902
30903 ENDIF
30904 ENDIF
30905
30906 RETURN
30907 END
30908
30909C*********************************************************************
30910
30911C...PYSGHF
30912C...Subprocess cross sections for heavy flavour production,
30913C...open and closed.
30914C...Auxiliary to PYSIGH.
30915
30916 SUBROUTINE PYSGHF(NCHN,SIGS)
30917
30918C...Double precision and integer declarations
30919 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30920 IMPLICIT INTEGER(I-N)
30921 INTEGER PYK,PYCHGE,PYCOMP
30922C...Parameter statement to help give large particle numbers.
30923 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30924 &KEXCIT=4000000,KDIMEN=5000000)
30925C...Commonblocks
30926 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30927 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30928 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30929 COMMON/PYINT1/MINT(400),VINT(400)
30930 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30931 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30932 COMMON/PYINT4/MWID(500),WIDS(500,5)
30933 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30934 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30935 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30936 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30937 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30938 &/PYINT4/,/PYSGCM/
30939C...Local arrays
30940 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30941
30942C...Determine where are charmonium/bottomonium wave function parameters.
30943 IONIUM=140
30944 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30945
30946C...Convert bottomonium process into equivalent charmonium ones.
30947 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30948
30949C...Differential cross section expressions.
30950
30951 IF(ISUB.LE.100) THEN
30952 IF(ISUB.EQ.81) THEN
30953C...q + qbar -> Q + Qbar
30954 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30955 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30956 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30957 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30958 & 2D0*SQMAVG/SH)
30959 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30960 WID2=1D0
30961 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30962 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30963 FACQQB=FACQQB*WID2
30964 DO 100 I=MMINA,MMAXA
30965 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30966 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30967 NCHN=NCHN+1
30968 ISIG(NCHN,1)=I
30969 ISIG(NCHN,2)=-I
30970 ISIG(NCHN,3)=1
30971 SIGH(NCHN)=FACQQB
30972 100 CONTINUE
30973
30974 ELSEIF(ISUB.EQ.82) THEN
30975C...g + g -> Q + Qbar
30976 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30977 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30978 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30979 THUHQ=THQ*UHQ-SQMAVG*SH
30980 IF(MSTP(34).EQ.0) THEN
30981 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30982 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30983 ELSE
30984 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30985 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30986 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30987 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30988 ENDIF
30989 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30990 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30991 IF(MSTP(35).GE.1) THEN
30992 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30993 FACQQ1=FACQQ1*FATRE
30994 FACQQ2=FACQQ2*FATRE
30995 ENDIF
30996 WID2=1D0
30997 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30998 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30999 FACQQ1=FACQQ1*WID2
31000 FACQQ2=FACQQ2*WID2
31001 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31002 NCHN=NCHN+1
31003 ISIG(NCHN,1)=21
31004 ISIG(NCHN,2)=21
31005 ISIG(NCHN,3)=1
31006 SIGH(NCHN)=FACQQ1
31007 NCHN=NCHN+1
31008 ISIG(NCHN,1)=21
31009 ISIG(NCHN,2)=21
31010 ISIG(NCHN,3)=2
31011 SIGH(NCHN)=FACQQ2
31012 110 CONTINUE
31013
31014 ELSEIF(ISUB.EQ.83) THEN
31015C...f + q -> f' + Q
31016 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31017 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31018 DO 130 I=MMIN1,MMAX1
31019 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31020 DO 120 J=MMIN2,MMAX2
31021 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31022 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31023 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31024 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31025 & THEN
31026 NCHN=NCHN+1
31027 ISIG(NCHN,1)=I
31028 ISIG(NCHN,2)=J
31029 ISIG(NCHN,3)=1
31030 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31031 & (IABS(I)+1)/2)*VINT(180+J)
31032 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31033 & (MINT(55)+1)/2)*VINT(180+J)
31034 WID2=1D0
31035 IF(I.GT.0) THEN
31036 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31037 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31038 & WIDS(MINT(55),2)
31039 ELSE
31040 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31041 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31042 & WIDS(MINT(55),3)
31043 ENDIF
31044 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31045 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31046 ENDIF
31047 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31048 & THEN
31049 NCHN=NCHN+1
31050 ISIG(NCHN,1)=I
31051 ISIG(NCHN,2)=J
31052 ISIG(NCHN,3)=2
31053 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31054 & (IABS(J)+1)/2)*VINT(180+I)
31055 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31056 & (MINT(55)+1)/2)*VINT(180+I)
31057 WID2=1D0
31058 IF(J.GT.0) THEN
31059 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31060 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31061 & WIDS(MINT(55),2)
31062 ELSE
31063 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31064 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31065 & WIDS(MINT(55),3)
31066 ENDIF
31067 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31068 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31069 ENDIF
31070 120 CONTINUE
31071 130 CONTINUE
31072
31073 ELSEIF(ISUB.EQ.84) THEN
31074C...g + gamma -> Q + Qbar
31075 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31076 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31077 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31078 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31079 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31080 & (THQ*UHQ)
31081 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31082 WID2=1D0
31083 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31084 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31085 FACQQ=FACQQ*WID2
31086 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31087 NCHN=NCHN+1
31088 ISIG(NCHN,1)=21
31089 ISIG(NCHN,2)=22
31090 ISIG(NCHN,3)=1
31091 SIGH(NCHN)=FACQQ
31092 ENDIF
31093 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31094 NCHN=NCHN+1
31095 ISIG(NCHN,1)=22
31096 ISIG(NCHN,2)=21
31097 ISIG(NCHN,3)=1
31098 SIGH(NCHN)=FACQQ
31099 ENDIF
31100
31101 ELSEIF(ISUB.EQ.85) THEN
31102C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31103 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31104 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31105 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31106 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31107 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31108 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31109 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31110 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31111 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31112 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31113 WID2=1D0
31114 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31115 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31116 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31117 FACFF=FACFF*WID2
31118 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31119 NCHN=NCHN+1
31120 ISIG(NCHN,1)=22
31121 ISIG(NCHN,2)=22
31122 ISIG(NCHN,3)=1
31123 SIGH(NCHN)=FACFF
31124 ENDIF
31125
31126 ELSEIF(ISUB.EQ.86) THEN
31127C...g + g -> J/Psi + g
31128 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31129 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31130 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31131 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31132 NCHN=NCHN+1
31133 ISIG(NCHN,1)=21
31134 ISIG(NCHN,2)=21
31135 ISIG(NCHN,3)=1
31136 SIGH(NCHN)=FACQQG
31137 ENDIF
31138
31139 ELSEIF(ISUB.EQ.87) THEN
31140C...g + g -> chi_0c + g
31141 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31142 QGTW=(SH*TH*UH)/SH**3
31143 RGTW=SQM3/SH
31144 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31145 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31146 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31147 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31148 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31149 & (QGTW*(QGTW-RGTW*PGTW)**4)
31150 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31151 NCHN=NCHN+1
31152 ISIG(NCHN,1)=21
31153 ISIG(NCHN,2)=21
31154 ISIG(NCHN,3)=1
31155 SIGH(NCHN)=FACQQG
31156 ENDIF
31157
31158 ELSEIF(ISUB.EQ.88) THEN
31159C...g + g -> chi_1c + g
31160 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31161 QGTW=(SH*TH*UH)/SH**3
31162 RGTW=SQM3/SH
31163 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31164 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31165 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31166 & (QGTW-RGTW*PGTW)**4
31167 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31168 NCHN=NCHN+1
31169 ISIG(NCHN,1)=21
31170 ISIG(NCHN,2)=21
31171 ISIG(NCHN,3)=1
31172 SIGH(NCHN)=FACQQG
31173 ENDIF
31174
31175 ELSEIF(ISUB.EQ.89) THEN
31176C...g + g -> chi_2c + g
31177 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31178 QGTW=(SH*TH*UH)/SH**3
31179 RGTW=SQM3/SH
31180 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31181 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31182 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31183 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31184 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31185 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31186 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31187 NCHN=NCHN+1
31188 ISIG(NCHN,1)=21
31189 ISIG(NCHN,2)=21
31190 ISIG(NCHN,3)=1
31191 SIGH(NCHN)=FACQQG
31192 ENDIF
31193 ENDIF
31194
31195 ELSEIF(ISUB.LE.200) THEN
31196 IF(ISUB.EQ.104) THEN
31197C...g + g -> chi_c0.
31198 KC=PYCOMP(10441)
31199 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31200 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31201 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31202 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31203 NCHN=NCHN+1
31204 ISIG(NCHN,1)=21
31205 ISIG(NCHN,2)=21
31206 ISIG(NCHN,3)=1
31207 SIGH(NCHN)=FACBW
31208 ENDIF
31209
31210 ELSEIF(ISUB.EQ.105) THEN
31211C...g + g -> chi_c2.
31212 KC=PYCOMP(445)
31213 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31214 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31215 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31216 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31217 NCHN=NCHN+1
31218 ISIG(NCHN,1)=21
31219 ISIG(NCHN,2)=21
31220 ISIG(NCHN,3)=1
31221 SIGH(NCHN)=FACBW
31222 ENDIF
31223
31224 ELSEIF(ISUB.EQ.106) THEN
31225C...g + g -> J/Psi + gamma.
31226 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31227 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31228 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31229 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31230 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31231 NCHN=NCHN+1
31232 ISIG(NCHN,1)=21
31233 ISIG(NCHN,2)=21
31234 ISIG(NCHN,3)=1
31235 SIGH(NCHN)=FACQQG
31236 ENDIF
31237
31238 ELSEIF(ISUB.EQ.107) THEN
31239C...g + gamma -> J/Psi + g.
31240 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31241 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31242 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31243 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31244 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31245 NCHN=NCHN+1
31246 ISIG(NCHN,1)=21
31247 ISIG(NCHN,2)=22
31248 ISIG(NCHN,3)=1
31249 SIGH(NCHN)=FACQQG
31250 ENDIF
31251 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31252 NCHN=NCHN+1
31253 ISIG(NCHN,1)=22
31254 ISIG(NCHN,2)=21
31255 ISIG(NCHN,3)=1
31256 SIGH(NCHN)=FACQQG
31257 ENDIF
31258
31259 ELSEIF(ISUB.EQ.108) THEN
31260C...gamma + gamma -> J/Psi + gamma.
31261 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31262 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31263 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31264 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31265 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31266 NCHN=NCHN+1
31267 ISIG(NCHN,1)=22
31268 ISIG(NCHN,2)=22
31269 ISIG(NCHN,3)=1
31270 SIGH(NCHN)=FACQQG
31271 ENDIF
31272 ENDIF
31273
31274C...QUARKONIA+++
31275C...Additional code by Stefan Wolf
31276 ELSE
31277
31278C...Common code for quarkonium production.
31279 SHTH=SH+TH
31280 THUH=TH+UH
31281 UHSH=UH+SH
31282 SHTH2=SHTH**2
31283 THUH2=THUH**2
31284 UHSH2=UHSH**2
31285 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31286 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31287 SQMQQ=SQM3
31288 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31289 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31290 SQMQQ=SQM4
31291 ENDIF
31292 SQMQQR=SQRT(SQMQQ)
31293 IF(MSTP(145).EQ.1) THEN
31294 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31295 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31296 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31297 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31298 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31299 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31300 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31301 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31302 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31303 & ISUB.GE.437) THEN
31304 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31305 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31306 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31307 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31308 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31309 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31310 ENDIF
31311 AQ2=AQ**2
31312 BQ2=BQ**2
31313 SMQQ2=SQMQQ*VINT(2)
31314C...Polarisation frames
31315 IF(MSTP(146).EQ.1) THEN
31316C...Recoil frame
31317 POLH1=SQRT(AQ2-SMQQ2)
31318 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31319 AZ=-SQMQQR/POLH1
31320 BZ=0D0
31321 AX=AQ*BQ/(POLH1*POLH2)
31322 BX=-POLH1/POLH2
31323 ELSEIF(MSTP(146).EQ.2) THEN
31324C...Gottfried Jackson frame
31325 POLH1=AQ+BQ
31326 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31327 AZ=SQMQQR/POLH1
31328 BZ=AZ
31329 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
31330 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
31331 ELSEIF(MSTP(146).EQ.3) THEN
31332C...Target frame
31333 POLH1=AQ-BQ
31334 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31335 AZ=-SQMQQR/POLH1
31336 BZ=-AZ
31337 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
31338 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
31339 ELSEIF(MSTP(146).EQ.4) THEN
31340C...Collins Soper frame
31341 POLH1=AQ2-BQ2
31342 POLH2=SQRT(VINT(2)*POLH1)
31343 AZ=-BQ/POLH2
31344 BZ=AQ/POLH2
31345 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
31346 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
31347 ENDIF
31348C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31349 EL1K10=AZ*ATILK1+BZ*BTILK1
31350 EL1K20=AZ*ATILK2+BZ*BTILK2
31351 EL2K10=EL1K10
31352 EL2K20=EL1K20
31353 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
31354 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
31355 EL2K11=EL1K11
31356 EL2K21=EL1K21
31357 ENDIF
31358
31359 IF(ISUB.EQ.421) THEN
31360C...g + g -> QQ~[3S11] + g
31361 IF(MSTP(145).EQ.0) THEN
31362* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31363* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
31364 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31365 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
31366* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31367* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31368 ELSE
31369 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
31370 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31371 BB=2D0*(SH2+TH2)
31372 CC=2D0*(SH2+UH2)
31373 DD=2D0*SH2
31374 IF(MSTP(147).EQ.0) THEN
31375 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31376 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31377 ELSEIF(MSTP(147).EQ.1) THEN
31378 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31379 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31380 ELSEIF(MSTP(147).EQ.3) THEN
31381 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31382 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31383 ELSEIF(MSTP(147).EQ.4) THEN
31384 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31385 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31386 ELSEIF(MSTP(147).EQ.5) THEN
31387 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31388 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31389 ELSEIF(MSTP(147).EQ.6) THEN
31390 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31391 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31392 ENDIF
31393 FACQQG=COMFAC*FF*FACQQG
31394 ENDIF
31395 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31396 NCHN=NCHN+1
31397 ISIG(NCHN,1)=21
31398 ISIG(NCHN,2)=21
31399 ISIG(NCHN,3)=1
31400 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
31401 ENDIF
31402
31403 ELSEIF(ISUB.EQ.422) THEN
31404C...g + g -> QQ~[3S18] + g
31405 IF(MSTP(145).EQ.0) THEN
31406 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
31407 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31408 & (SQMQQ*SQMQQR)*
31409 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
31410 ELSE
31411 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31412 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
31413 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31414 BB=2D0*(SH2+TH2)
31415 CC=2D0*(SH2+UH2)
31416 DD=2D0*SH2
31417 IF(MSTP(147).EQ.0) THEN
31418 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31419 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31420 ELSEIF(MSTP(147).EQ.1) THEN
31421 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31422 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31423 ELSEIF(MSTP(147).EQ.3) THEN
31424 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31425 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31426 ELSEIF(MSTP(147).EQ.4) THEN
31427 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31428 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31429 ELSEIF(MSTP(147).EQ.5) THEN
31430 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31431 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31432 ELSEIF(MSTP(147).EQ.6) THEN
31433 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31434 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31435 ENDIF
31436 FACQQG=COMFAC*FF*FACQQG
31437 ENDIF
31438C...Split total contribution into different colour flows just like
31439C...in g g -> g g (recalculate kinematics for massless partons).
31440 THP=-0.5D0*SH*(1D0-CTH)
31441 UHP=-0.5D0*SH*(1D0+CTH)
31442 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31443 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31444 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31445 FACGGS=FACGG1+FACGG2+FACGG3
31446 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31447 NCHN=NCHN+1
31448 ISIG(NCHN,1)=21
31449 ISIG(NCHN,2)=21
31450 ISIG(NCHN,3)=1
31451 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31452 NCHN=NCHN+1
31453 ISIG(NCHN,1)=21
31454 ISIG(NCHN,2)=21
31455 ISIG(NCHN,3)=2
31456 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31457 NCHN=NCHN+1
31458 ISIG(NCHN,1)=21
31459 ISIG(NCHN,2)=21
31460 ISIG(NCHN,3)=3
31461 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
31462 ENDIF
31463
31464 ELSEIF(ISUB.EQ.423) THEN
31465C...g + g -> QQ~[1S08] + g
31466 IF(MSTP(145).EQ.0) THEN
31467* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31468* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31469* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31470* & (SHTH2*THUH2*UHSH2)
31471 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
31472 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31473 & TH2/(SHTH2*THUH2))*
31474 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31475 ELSE
31476 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
31477 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31478 & TH2/(SHTH2*THUH2))*
31479 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31480 IF(MSTP(147).EQ.0) THEN
31481 FACQQG=COMFAC*FA
31482 ELSEIF(MSTP(147).EQ.1) THEN
31483 FACQQG=COMFAC*2D0*FA
31484 ELSEIF(MSTP(147).EQ.3) THEN
31485 FACQQG=COMFAC*FA
31486 ELSEIF(MSTP(147).EQ.4) THEN
31487 FACQQG=COMFAC*FA
31488 ELSEIF(MSTP(147).EQ.5) THEN
31489 FACQQG=0D0
31490 ELSEIF(MSTP(147).EQ.6) THEN
31491 FACQQG=0D0
31492 ENDIF
31493 ENDIF
31494C...Split total contribution into different colour flows just like
31495C...in g g -> g g (recalculate kinematics for massless partons).
31496 THP=-0.5D0*SH*(1D0-CTH)
31497 UHP=-0.5D0*SH*(1D0+CTH)
31498 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31499 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31500 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31501 FACGGS=FACGG1+FACGG2+FACGG3
31502 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31503 NCHN=NCHN+1
31504 ISIG(NCHN,1)=21
31505 ISIG(NCHN,2)=21
31506 ISIG(NCHN,3)=1
31507 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31508 NCHN=NCHN+1
31509 ISIG(NCHN,1)=21
31510 ISIG(NCHN,2)=21
31511 ISIG(NCHN,3)=2
31512 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31513 NCHN=NCHN+1
31514 ISIG(NCHN,1)=21
31515 ISIG(NCHN,2)=21
31516 ISIG(NCHN,3)=3
31517 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
31518 ENDIF
31519
31520 ELSEIF(ISUB.EQ.424) THEN
31521C...g + g -> QQ~[3PJ8] + g
31522 POLY=SH2+SH*TH+TH2
31523 IF(MSTP(145).EQ.0) THEN
31524 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
31525 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
31526 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
31527 & +7D0*TH**6)
31528 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
31529 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
31530 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
31531 & +35D0*TH**8)
31532 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
31533 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
31534 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
31535 & +84D0*TH**8)
31536 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
31537 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
31538 & +451D0*SH*TH**5+126D0*TH**6)
31539 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
31540 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
31541 & +171D0*SH*TH**5+42D0*TH**6)
31542 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
31543 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
31544 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
31545 & +99D0*SH*TH**3+35D0*TH**4)
31546 & +7D0*SQMQQ**8*SHTH*POLY)/
31547 & (SH*TH*UH*SQMQQR*SQMQQ*
31548 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31549 ELSE
31550 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
31551 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31552 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
31553 & -SQMQQ*SHTH2*POLY**2*
31554 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
31555 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
31556 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
31557 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
31558 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
31559 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
31560 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
31561 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
31562 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
31563 & +145D0*SH*TH**5+34D0*TH**6)
31564 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
31565 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
31566 & +44D0*TH**6)
31567 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
31568 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
31569 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
31570 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
31571 & +3D0*SQMQQ**8*SHTH*POLY)
31572 BB=4D0*SHTH2*POLY**3
31573 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
31574 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
31575 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
31576 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
31577 & +84D0*SH*TH**9+20D0*TH**10)
31578 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
31579 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
31580 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
31581 & +40D0*TH**8)
31582 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
31583 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
31584 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
31585 & +40D0*TH**8)
31586 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
31587 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
31588 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
31589 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
31590 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
31591 & +4D0*TH**6)
31592 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
31593 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
31594 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
31595 CC=4D0*TH2*POLY**3
31596 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
31597 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
31598 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
31599 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
31600 & +28D0*TH**9)
31601 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
31602 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
31603 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
31604 & +394D0*SH*TH**9+84D0*TH**10)
31605 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
31606 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
31607 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
31608 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
31609 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
31610 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
31611 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
31612 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
31613 & +266D0*SH*TH**6+84D0*TH**7)
31614 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
31615 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
31616 & +28D0*TH**6)
31617 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
31618 & +7D0*SH*TH**3+4*TH**4)
31619 & +SQMQQ**8*SH*(SH-TH)**2*TH
31620 DD=2D0*TH2*SHTH2*POLY**3
31621 & *(-SH2+2*SH*TH+2*TH2)
31622 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
31623 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
31624 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
31625 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
31626 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
31627 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
31628 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
31629 & -210D0*SH*TH**8-60D0*TH**9)
31630 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
31631 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
31632 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
31633 & -80D0*TH**8)
31634 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
31635 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
31636 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
31637 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
31638 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
31639 & -30D0*SH*TH**6-24D0*TH**7)
31640 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
31641 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
31642 & -4D0*TH**6)
31643 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
31644 IF(MSTP(147).EQ.0) THEN
31645 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31646 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31647 ELSEIF(MSTP(147).EQ.1) THEN
31648 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31649 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31650 ELSEIF(MSTP(147).EQ.3) THEN
31651 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31652 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31653 ELSEIF(MSTP(147).EQ.4) THEN
31654 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31655 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31656 ELSEIF(MSTP(147).EQ.5) THEN
31657 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31658 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31659 ELSEIF(MSTP(147).EQ.6) THEN
31660 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31661 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31662 ENDIF
31663 FACQQG=COMFAC*FF*FACQQG
31664 ENDIF
31665C...Split total contribution into different colour flows just like
31666C...in g g -> g g (recalculate kinematics for massless partons).
31667 THP=-0.5D0*SH*(1D0-CTH)
31668 UHP=-0.5D0*SH*(1D0+CTH)
31669 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31670 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31671 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31672 FACGGS=FACGG1+FACGG2+FACGG3
31673 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31674 NCHN=NCHN+1
31675 ISIG(NCHN,1)=21
31676 ISIG(NCHN,2)=21
31677 ISIG(NCHN,3)=1
31678 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31679 NCHN=NCHN+1
31680 ISIG(NCHN,1)=21
31681 ISIG(NCHN,2)=21
31682 ISIG(NCHN,3)=2
31683 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31684 NCHN=NCHN+1
31685 ISIG(NCHN,1)=21
31686 ISIG(NCHN,2)=21
31687 ISIG(NCHN,3)=3
31688 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
31689 ENDIF
31690
31691 ELSEIF(ISUB.EQ.425) THEN
31692C...q + g -> q + QQ~[3S18]
31693 IF(MSTP(145).EQ.0) THEN
31694 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
31695 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
31696 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
31697 ELSE
31698 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
31699 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
31700 AA=SHTH2+THUH2
31701 BB=4D0
31702 CC=8D0
31703 DD=4D0
31704 IF(MSTP(147).EQ.0) THEN
31705 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31706 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31707 ELSEIF(MSTP(147).EQ.1) THEN
31708 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31709 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31710 ELSEIF(MSTP(147).EQ.3) THEN
31711 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31712 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31713 ELSEIF(MSTP(147).EQ.4) THEN
31714 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31715 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31716 ELSEIF(MSTP(147).EQ.5) THEN
31717 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31718 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31719 ELSEIF(MSTP(147).EQ.6) THEN
31720 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31721 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31722 ENDIF
31723 FACQQG=COMFAC*FF*FACQQG
31724 ENDIF
31725C...Split total contribution into different colour flows just like
31726C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31727C...(recalculate kinematics for massless partons).
31728 THP=-0.5D0*SH*(1D0-CTH)
31729 UHP=-0.5D0*SH*(1D0+CTH)
31730 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31731 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31732 FACQGS=FACQG1+FACQG2
31733 DO 2442 I=MMINA,MMAXA
31734 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
31735 DO 2441 ISDE=1,2
31736 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
31737 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
31738 NCHN=NCHN+1
31739 ISIG(NCHN,ISDE)=I
31740 ISIG(NCHN,3-ISDE)=21
31741 ISIG(NCHN,3)=1
31742 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
31743 NCHN=NCHN+1
31744 ISIG(NCHN,ISDE)=I
31745 ISIG(NCHN,3-ISDE)=21
31746 ISIG(NCHN,3)=2
31747 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
31748 2441 CONTINUE
31749 2442 CONTINUE
31750
31751 ELSEIF(ISUB.EQ.426) THEN
31752C...q + g -> q + QQ~[1S08]
31753 IF(MSTP(145).EQ.0) THEN
31754 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
31755 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
31756 ELSE
31757 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
31758 IF(MSTP(147).EQ.0) THEN
31759 FACQQG=COMFAC*FA
31760 ELSEIF(MSTP(147).EQ.1) THEN
31761 FACQQG=COMFAC*2D0*FA
31762 ELSEIF(MSTP(147).EQ.3) THEN
31763 FACQQG=COMFAC*FA
31764 ELSEIF(MSTP(147).EQ.4) THEN
31765 FACQQG=COMFAC*FA
31766 ELSEIF(MSTP(147).EQ.5) THEN
31767 FACQQG=0D0
31768 ELSEIF(MSTP(147).EQ.6) THEN
31769 FACQQG=0D0
31770 ENDIF
31771 ENDIF
31772C...Split total contribution into different colour flows just like
31773C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31774C...(recalculate kinematics for massless partons).
31775 THP=-0.5D0*SH*(1D0-CTH)
31776 UHP=-0.5D0*SH*(1D0+CTH)
31777 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31778 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31779 FACQGS=FACQG1+FACQG2
31780 DO 2444 I=MMINA,MMAXA
31781 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
31782 DO 2443 ISDE=1,2
31783 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
31784 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
31785 NCHN=NCHN+1
31786 ISIG(NCHN,ISDE)=I
31787 ISIG(NCHN,3-ISDE)=21
31788 ISIG(NCHN,3)=1
31789 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
31790 NCHN=NCHN+1
31791 ISIG(NCHN,ISDE)=I
31792 ISIG(NCHN,3-ISDE)=21
31793 ISIG(NCHN,3)=2
31794 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
31795 2443 CONTINUE
31796 2444 CONTINUE
31797
31798 ELSEIF(ISUB.EQ.427) THEN
31799C...q + g -> q + QQ~[3PJ8]
31800 IF(MSTP(145).EQ.0) THEN
31801 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
31802 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
31803 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
31804 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
31805 ELSE
31806 FF=10D0*PARU(1)*AS**3/
31807 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
31808 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
31809 BB=8D0*(SHTH2+TH*UH)
31810 CC=8D0*UHSH*(SHTH+THUH)
31811 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
31812 IF(MSTP(147).EQ.0) THEN
31813 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31814 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31815 ELSEIF(MSTP(147).EQ.1) THEN
31816 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31817 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31818 ELSEIF(MSTP(147).EQ.3) THEN
31819 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31820 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31821 ELSEIF(MSTP(147).EQ.4) THEN
31822 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31823 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31824 ELSEIF(MSTP(147).EQ.5) THEN
31825 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31826 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31827 ELSEIF(MSTP(147).EQ.6) THEN
31828 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31829 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31830 ENDIF
31831 FACQQG=COMFAC*FF*FACQQG
31832 ENDIF
31833C...Split total contribution into different colour flows just like
31834C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31835C...(recalculate kinematics for massless partons).
31836 THP=-0.5D0*SH*(1D0-CTH)
31837 UHP=-0.5D0*SH*(1D0+CTH)
31838 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31839 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31840 FACQGS=FACQG1+FACQG2
31841 DO 2446 I=MMINA,MMAXA
31842 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
31843 DO 2445 ISDE=1,2
31844 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
31845 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
31846 NCHN=NCHN+1
31847 ISIG(NCHN,ISDE)=I
31848 ISIG(NCHN,3-ISDE)=21
31849 ISIG(NCHN,3)=1
31850 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31851 NCHN=NCHN+1
31852 ISIG(NCHN,ISDE)=I
31853 ISIG(NCHN,3-ISDE)=21
31854 ISIG(NCHN,3)=2
31855 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31856 2445 CONTINUE
31857 2446 CONTINUE
31858
31859 ELSEIF(ISUB.EQ.428) THEN
31860C...q + q~ -> g + QQ~[3S18]
31861 IF(MSTP(145).EQ.0) THEN
31862 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31863 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31864 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31865 ELSE
31866 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31867 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31868 AA=SHTH2+UHSH2
31869 BB=4D0
31870 CC=4D0
31871 DD=0D0
31872 IF(MSTP(147).EQ.0) THEN
31873 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31874 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31875 ELSEIF(MSTP(147).EQ.1) THEN
31876 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31877 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31878 ELSEIF(MSTP(147).EQ.3) THEN
31879 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31880 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31881 ELSEIF(MSTP(147).EQ.4) THEN
31882 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31883 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31884 ELSEIF(MSTP(147).EQ.5) THEN
31885 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31886 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31887 ELSEIF(MSTP(147).EQ.6) THEN
31888 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31889 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31890 ENDIF
31891 FACQQG=COMFAC*FF*FACQQG
31892 ENDIF
31893C...Split total contribution into different colour flows just like
31894C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31895C...(recalculate kinematics for massless partons).
31896 THP=-0.5D0*SH*(1D0-CTH)
31897 UHP=-0.5D0*SH*(1D0+CTH)
31898 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31899 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31900 FACGGS=FACGG1+FACGG2
31901 DO 2447 I=MMINA,MMAXA
31902 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31903 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31904 NCHN=NCHN+1
31905 ISIG(NCHN,1)=I
31906 ISIG(NCHN,2)=-I
31907 ISIG(NCHN,3)=1
31908 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31909 NCHN=NCHN+1
31910 ISIG(NCHN,1)=I
31911 ISIG(NCHN,2)=-I
31912 ISIG(NCHN,3)=2
31913 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31914 2447 CONTINUE
31915
31916 ELSEIF(ISUB.EQ.429) THEN
31917C...q + q~ -> g + QQ~[1S08]
31918 IF(MSTP(145).EQ.0) THEN
31919 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31920 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31921 ELSE
31922 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31923 IF(MSTP(147).EQ.0) THEN
31924 FACQQG=COMFAC*FA
31925 ELSEIF(MSTP(147).EQ.1) THEN
31926 FACQQG=COMFAC*2D0*FA
31927 ELSEIF(MSTP(147).EQ.3) THEN
31928 FACQQG=COMFAC*FA
31929 ELSEIF(MSTP(147).EQ.4) THEN
31930 FACQQG=COMFAC*FA
31931 ELSEIF(MSTP(147).EQ.5) THEN
31932 FACQQG=0D0
31933 ELSEIF(MSTP(147).EQ.6) THEN
31934 FACQQG=0D0
31935 ENDIF
31936 ENDIF
31937C...Split total contribution into different colour flows just like
31938C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31939C...(recalculate kinematics for massless partons).
31940 THP=-0.5D0*SH*(1D0-CTH)
31941 UHP=-0.5D0*SH*(1D0+CTH)
31942 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31943 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31944 FACGGS=FACGG1+FACGG2
31945 DO 2448 I=MMINA,MMAXA
31946 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31947 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31948 NCHN=NCHN+1
31949 ISIG(NCHN,1)=I
31950 ISIG(NCHN,2)=-I
31951 ISIG(NCHN,3)=1
31952 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31953 NCHN=NCHN+1
31954 ISIG(NCHN,1)=I
31955 ISIG(NCHN,2)=-I
31956 ISIG(NCHN,3)=2
31957 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31958 2448 CONTINUE
31959
31960 ELSEIF(ISUB.EQ.430) THEN
31961C...q + q~ -> g + QQ~[3PJ8]
31962 IF(MSTP(145).EQ.0) THEN
31963 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31964 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31965 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31966 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31967 ELSE
31968 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31969 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31970 BB=8D0*(UHSH2+SH*TH)
31971 CC=8D0*(SHTH2+SH*UH)
31972 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31973 IF(MSTP(147).EQ.0) THEN
31974 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31975 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31976 ELSEIF(MSTP(147).EQ.1) THEN
31977 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31978 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31979 ELSEIF(MSTP(147).EQ.3) THEN
31980 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31981 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31982 ELSEIF(MSTP(147).EQ.4) THEN
31983 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31984 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31985 ELSEIF(MSTP(147).EQ.5) THEN
31986 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31987 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31988 ELSEIF(MSTP(147).EQ.6) THEN
31989 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31990 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31991 ENDIF
31992 FACQQG=COMFAC*FF*FACQQG
31993 ENDIF
31994C...Split total contribution into different colour flows just like
31995C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31996C...(recalculate kinematics for massless partons).
31997 THP=-0.5D0*SH*(1D0-CTH)
31998 UHP=-0.5D0*SH*(1D0+CTH)
31999 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32000 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32001 FACGGS=FACGG1+FACGG2
32002 DO 2449 I=MMINA,MMAXA
32003 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32004 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32005 NCHN=NCHN+1
32006 ISIG(NCHN,1)=I
32007 ISIG(NCHN,2)=-I
32008 ISIG(NCHN,3)=1
32009 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32010 NCHN=NCHN+1
32011 ISIG(NCHN,1)=I
32012 ISIG(NCHN,2)=-I
32013 ISIG(NCHN,3)=2
32014 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32015 2449 CONTINUE
32016
32017 ELSEIF(ISUB.EQ.431) THEN
32018C...g + g -> QQ~[3P01] + g
32019 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32020 QGTW=(SH*TH*UH)/SH**3
32021 RGTW=SQMQQ/SH
32022 IF(MSTP(145).EQ.0) THEN
32023 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32024 & (9D0*RGTW**2*PGTW**4*
32025 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32026 & -6D0*RGTW*PGTW**3*QGTW*
32027 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32028 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32029 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32030 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32031 ELSE
32032 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32033 & (9D0*RGTW**2*PGTW**4*
32034 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32035 & -6D0*RGTW*PGTW**3*QGTW*
32036 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32037 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32038 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32039 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32040 IF(MSTP(147).EQ.0) THEN
32041 FACQQG=COMFAC*FC1
32042 ELSEIF(MSTP(147).EQ.1) THEN
32043 FACQQG=COMFAC*2D0*FC1
32044 ELSEIF(MSTP(147).EQ.3) THEN
32045 FACQQG=COMFAC*FC1
32046 ELSEIF(MSTP(147).EQ.4) THEN
32047 FACQQG=COMFAC*FC1
32048 ELSEIF(MSTP(147).EQ.5) THEN
32049 FACQQG=0D0
32050 ELSEIF(MSTP(147).EQ.6) THEN
32051 FACQQG=0D0
32052 ENDIF
32053 ENDIF
32054 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32055 NCHN=NCHN+1
32056 ISIG(NCHN,1)=21
32057 ISIG(NCHN,2)=21
32058 ISIG(NCHN,3)=1
32059 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32060 ENDIF
32061
32062 ELSEIF(ISUB.EQ.432) THEN
32063C...g + g -> QQ~[3P11] + g
32064 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32065 QGTW=(SH*TH*UH)/SH**3
32066 RGTW=SQMQQ/SH
32067 IF(MSTP(145).EQ.0) THEN
32068 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32069 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32070 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32071 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32072 ELSE
32073 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32074 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32075 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32076 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32077 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32078 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32079 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32080 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32081 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32082 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32083 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32084 C4=-4D0*THUH*(TH-UH)**2*
32085 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32086 & -SH2*TH*UH*(TH2+UH2))
32087 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32088 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32089 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32090 IF(MSTP(147).EQ.0) THEN
32091 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32092 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32093 ELSEIF(MSTP(147).EQ.1) THEN
32094 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32095 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32096 ELSEIF(MSTP(147).EQ.3) THEN
32097 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32098 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32099 ELSEIF(MSTP(147).EQ.4) THEN
32100 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32101 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32102 ELSEIF(MSTP(147).EQ.5) THEN
32103 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32104 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32105 ELSEIF(MSTP(147).EQ.6) THEN
32106 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32107 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32108 ENDIF
32109 FACQQG=COMFAC*FF*FACQQG
32110 ENDIF
32111 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32112 NCHN=NCHN+1
32113 ISIG(NCHN,1)=21
32114 ISIG(NCHN,2)=21
32115 ISIG(NCHN,3)=1
32116 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32117 ENDIF
32118
32119 ELSEIF(ISUB.EQ.433) THEN
32120C...g + g -> QQ~[3P21] + g
32121 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32122 QGTW=(SH*TH*UH)/SH**3
32123 RGTW=SQMQQ/SH
32124 IF(MSTP(145).EQ.0) THEN
32125 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32126 & (12D0*RGTW**2*PGTW**4*
32127 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32128 & -3D0*RGTW*PGTW**3*QGTW*
32129 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32130 & +2D0*PGTW**2*QGTW**2*
32131 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32132 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32133 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32134 ELSE
32135 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32136 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32137 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32138 & *SH*SH2**7
32139 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32140 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32141 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32142 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32143 & +10D0*(SH2**2+TH2**2))
32144 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32145 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32146 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32147 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32148 & +4D0*SH*TH*UH2**4*SHTH2)
32149 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32150 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32151 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32152 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32153 & +10D0*(SH2**2+UH2**2))
32154 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32155 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32156 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32157 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32158 & +4D0*SH*UH*TH2**4*UHSH2)
32159 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32160 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32161 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32162 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32163 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32164 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32165 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32166 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32167 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32168 & +3D0*(TH2**3+UH2**3)))
32169 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32170 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32171 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32172 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32173 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32174 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32175 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32176 & 82D0*TH**3)
32177 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32178 & +45D0*TH**3)
32179 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32180 & 8D0*TH**3)
32181 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32182 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32183 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32184 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32185 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32186 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32187 & 82D0*UH**3)
32188 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32189 & +45D0*UH**3)
32190 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32191 & 8D0*UH**3)
32192 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32193 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32194 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32195 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32196 & +4D0*SH*TH2**2*UH2**2*THUH2
32197 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32198 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32199 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32200 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32201 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32202 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32203 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32204 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32205 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32206 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32207 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32208 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32209 & +2D0*(TH2**3+UH2**3))
32210 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32211 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32212 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32213 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32214 IF(MSTP(147).EQ.0) THEN
32215 FACQQG=1D0/3D0*(C1*3D0
32216 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32217 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32218 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32219 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32220 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32221 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32222 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32223 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32224 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32225 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32226 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32227 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32228 ELSEIF(MSTP(147).EQ.1) THEN
32229 FACQQG=C1*2D0
32230 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32231 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32232 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32233 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32234 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32235 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32236 & +EL1K10*EL2K20*EL1K11*EL2K11)
32237 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32238 & +EL1K10*EL2K20*EL1K21*EL2K21)
32239 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32240 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32241 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32242 & +EL1K20*EL2K20*EL1K11*EL2K11)
32243 ELSEIF(MSTP(147).EQ.2) THEN
32244 FACQQG=2D0*(C1
32245 & -C2*EL1K11*EL2K11
32246 & -C3*EL1K21*EL2K21
32247 & -C4*EL1K11*EL2K21
32248 & +C5*(EL1K11*EL2K11)**2
32249 & +C6*(EL1K21*EL2K21)**2
32250 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32251 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32252 & +(C9+C0)*(EL1K11*EL2K21)**2)
32253 ENDIF
32254 FACQQG=COMFAC*FF*FACQQG
32255 ENDIF
32256 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32257 NCHN=NCHN+1
32258 ISIG(NCHN,1)=21
32259 ISIG(NCHN,2)=21
32260 ISIG(NCHN,3)=1
32261 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32262 ENDIF
32263
32264 ELSEIF(ISUB.EQ.434) THEN
32265C...q + g -> q + QQ~[3P01]
32266 IF(MSTP(145).EQ.0) THEN
32267 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32268 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32269 ELSE
32270 FA=-PARU(1)*AS**3*(16D0/243D0)*
32271 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32272 IF(MSTP(147).EQ.0) THEN
32273 FACQQG=COMFAC*FA
32274 ELSEIF(MSTP(147).EQ.1) THEN
32275 FACQQG=COMFAC*2D0*FA
32276 ELSEIF(MSTP(147).EQ.3) THEN
32277 FACQQG=COMFAC*FA
32278 ELSEIF(MSTP(147).EQ.4) THEN
32279 FACQQG=COMFAC*FA
32280 ELSEIF(MSTP(147).EQ.5) THEN
32281 FACQQG=0D0
32282 ELSEIF(MSTP(147).EQ.6) THEN
32283 FACQQG=0D0
32284 ENDIF
32285 ENDIF
32286 DO 2452 I=MMINA,MMAXA
32287 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32288 DO 2451 ISDE=1,2
32289 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32290 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32291 NCHN=NCHN+1
32292 ISIG(NCHN,ISDE)=I
32293 ISIG(NCHN,3-ISDE)=21
32294 ISIG(NCHN,3)=1
32295 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32296 2451 CONTINUE
32297 2452 CONTINUE
32298
32299 ELSEIF(ISUB.EQ.435) THEN
32300C...q + g -> q + QQ~[3P11]
32301 IF(MSTP(145).EQ.0) THEN
32302 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32303 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32304 ELSE
32305 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32306 C1=SH*UH
32307 C2=2D0*SH
32308 C3=0D0
32309 C4=2D0*(SH-UH)
32310 IF(MSTP(147).EQ.0) THEN
32311 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32312 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32313 ELSEIF(MSTP(147).EQ.1) THEN
32314 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32315 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32316 ELSEIF(MSTP(147).EQ.3) THEN
32317 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32318 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32319 ELSEIF(MSTP(147).EQ.4) THEN
32320 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32321 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32322 ELSEIF(MSTP(147).EQ.5) THEN
32323 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32324 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32325 ELSEIF(MSTP(147).EQ.6) THEN
32326 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32327 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32328 ENDIF
32329 FACQQG=COMFAC*FF*FACQQG
32330 ENDIF
32331 DO 2454 I=MMINA,MMAXA
32332 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
32333 DO 2453 ISDE=1,2
32334 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
32335 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
32336 NCHN=NCHN+1
32337 ISIG(NCHN,ISDE)=I
32338 ISIG(NCHN,3-ISDE)=21
32339 ISIG(NCHN,3)=1
32340 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32341 2453 CONTINUE
32342 2454 CONTINUE
32343
32344 ELSEIF(ISUB.EQ.436) THEN
32345C...q + g -> q + QQ~[3P21]
32346 IF(MSTP(145).EQ.0) THEN
32347 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
32348 & ((6D0*SQMQQ**2+TH2)*UHSH2
32349 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
32350 & (SQMQQR*TH*UHSH2**2)
32351 ELSE
32352 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
32353 C1=TH*UHSH2
32354 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
32355 C3=4D0*UHSH2
32356 C4=8D0*SH*UHSH
32357 C5=8D0*TH
32358 C6=0D0
32359 C7=16D0*TH
32360 C8=0D0
32361 C9=-16D0*UHSH
32362 C0=16D0*SQMQQ
32363 IF(MSTP(147).EQ.0) THEN
32364 FACQQG=1D0/3D0*(C1*3D0
32365 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32366 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32367 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32368 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32369 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32370 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32371 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32372 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32373 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32374 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32375 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32376 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32377 ELSEIF(MSTP(147).EQ.1) THEN
32378 FACQQG=C1*2D0
32379 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32380 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32381 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32382 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32383 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32384 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32385 & +EL1K10*EL2K20*EL1K11*EL2K11)
32386 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32387 & +EL1K10*EL2K20*EL1K21*EL2K21)
32388 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32389 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32390 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32391 & +EL1K20*EL2K20*EL1K11*EL2K11)
32392 ELSEIF(MSTP(147).EQ.2) THEN
32393 FACQQG=2D0*(C1
32394 & -C2*EL1K11*EL2K11
32395 & -C3*EL1K21*EL2K21
32396 & -C4*EL1K11*EL2K21
32397 & +C5*(EL1K11*EL2K11)**2
32398 & +C6*(EL1K21*EL2K21)**2
32399 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32400 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32401 & +(C9+C0)*(EL1K11*EL2K21)**2)
32402 ENDIF
32403 FACQQG=COMFAC*FF*FACQQG
32404 ENDIF
32405 DO 2456 I=MMINA,MMAXA
32406 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
32407 DO 2455 ISDE=1,2
32408 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
32409 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
32410 NCHN=NCHN+1
32411 ISIG(NCHN,ISDE)=I
32412 ISIG(NCHN,3-ISDE)=21
32413 ISIG(NCHN,3)=1
32414 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32415 2455 CONTINUE
32416 2456 CONTINUE
32417
32418 ELSEIF(ISUB.EQ.437) THEN
32419C...q + q~ -> g + QQ~[3P01]
32420 IF(MSTP(145).EQ.0) THEN
32421 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
32422 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32423 ELSE
32424 FA=PARU(1)*AS**3*(128D0/729D0)*
32425 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32426 IF(MSTP(147).EQ.0) THEN
32427 FACQQG=COMFAC*FA
32428 ELSEIF(MSTP(147).EQ.1) THEN
32429 FACQQG=COMFAC*2D0*FA
32430 ELSEIF(MSTP(147).EQ.3) THEN
32431 FACQQG=COMFAC*FA
32432 ELSEIF(MSTP(147).EQ.4) THEN
32433 FACQQG=COMFAC*FA
32434 ELSEIF(MSTP(147).EQ.5) THEN
32435 FACQQG=0D0
32436 ELSEIF(MSTP(147).EQ.6) THEN
32437 FACQQG=0D0
32438 ENDIF
32439 ENDIF
32440 DO 2457 I=MMINA,MMAXA
32441 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32442 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
32443 NCHN=NCHN+1
32444 ISIG(NCHN,1)=I
32445 ISIG(NCHN,2)=-I
32446 ISIG(NCHN,3)=1
32447 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32448 2457 CONTINUE
32449
32450 ELSEIF(ISUB.EQ.438) THEN
32451C...q + q~ -> g + QQ~[3P11]
32452 IF(MSTP(145).EQ.0) THEN
32453 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
32454 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
32455 ELSE
32456 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
32457 C1=TH*UH
32458 C2=2D0*UH
32459 C3=2D0*TH
32460 C4=2D0*THUH
32461 IF(MSTP(147).EQ.0) THEN
32462 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32463 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32464 ELSEIF(MSTP(147).EQ.1) THEN
32465 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32466 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32467 ELSEIF(MSTP(147).EQ.3) THEN
32468 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32469 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32470 ELSEIF(MSTP(147).EQ.4) THEN
32471 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32472 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32473 ELSEIF(MSTP(147).EQ.5) THEN
32474 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32475 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32476 ELSEIF(MSTP(147).EQ.6) THEN
32477 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32478 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32479 ENDIF
32480 FACQQG=COMFAC*FF*FACQQG
32481 ENDIF
32482 DO 2458 I=MMINA,MMAXA
32483 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32484 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
32485 NCHN=NCHN+1
32486 ISIG(NCHN,1)=I
32487 ISIG(NCHN,2)=-I
32488 ISIG(NCHN,3)=1
32489 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32490 2458 CONTINUE
32491
32492 ELSEIF(ISUB.EQ.439) THEN
32493C...q + q~ -> g + QQ~[3P21]
32494 IF(MSTP(145).EQ.0) THEN
32495 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
32496 & ((6D0*SQMQQ**2+SH2)*THUH2
32497 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
32498 & (SQMQQR*SH*THUH2**2)
32499 ELSE
32500 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
32501 C1=SH*THUH2
32502 C2=4D0*(SH2+UH2+2D0*SH*THUH)
32503 C3=4D0*(SH2+TH2+2D0*SH*THUH)
32504 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
32505 C5=8D0*SH
32506 C6=C5
32507 C7=16D0*SH
32508 C8=C7
32509 C9=-16D0*THUH
32510 C0=16D0*SQMQQ
32511 IF(MSTP(147).EQ.0) THEN
32512 FACQQG=1D0/3D0*(C1*3D0
32513 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32514 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32515 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32516 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32517 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32518 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32519 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32520 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32521 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32522 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32523 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32524 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32525 ELSEIF(MSTP(147).EQ.1) THEN
32526 FACQQG=C1*2D0
32527 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32528 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32529 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32530 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32531 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32532 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32533 & +EL1K10*EL2K20*EL1K11*EL2K11)
32534 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32535 & +EL1K10*EL2K20*EL1K21*EL2K21)
32536 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32537 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32538 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32539 & +EL1K20*EL2K20*EL1K11*EL2K11)
32540 ELSEIF(MSTP(147).EQ.2) THEN
32541 FACQQG=2D0*(C1
32542 & -C2*EL1K11*EL2K11
32543 & -C3*EL1K21*EL2K21
32544 & -C4*EL1K11*EL2K21
32545 & +C5*(EL1K11*EL2K11)**2
32546 & +C6*(EL1K21*EL2K21)**2
32547 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32548 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32549 & +(C9+C0)*(EL1K11*EL2K21)**2)
32550 ENDIF
32551 FACQQG=COMFAC*FF*FACQQG
32552 ENDIF
32553 DO 2459 I=MMINA,MMAXA
32554 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32555 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
32556 NCHN=NCHN+1
32557 ISIG(NCHN,1)=I
32558 ISIG(NCHN,2)=-I
32559 ISIG(NCHN,3)=1
32560 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32561 2459 CONTINUE
32562 ENDIF
32563C...QUARKONIA---
32564
32565 ENDIF
32566
32567 RETURN
32568 END
32569
32570C*********************************************************************
32571
32572C...PYSGWZ
32573C...Subprocess cross sections for W/Z processes,
32574C...except that longitudinal WW scattering is in Higgs sector.
32575C...Auxiliary to PYSIGH.
32576
32577 SUBROUTINE PYSGWZ(NCHN,SIGS)
32578
32579C...Double precision and integer declarations
32580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32581 IMPLICIT INTEGER(I-N)
32582 INTEGER PYK,PYCHGE,PYCOMP
32583C...Parameter statement to help give large particle numbers.
32584 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32585 &KEXCIT=4000000,KDIMEN=5000000)
32586C...Commonblocks
32587 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32588 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32589 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32590 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32591 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32592 COMMON/PYINT1/MINT(400),VINT(400)
32593 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32594 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32595 COMMON/PYINT4/MWID(500),WIDS(500,5)
32596 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
32597 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32598 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32599 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32600 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32601 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
32602 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
32603C...Local arrays and complex numbers
32604 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
32605 &HL4(3),HR4(3)
32606 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32607
32608C...Differential cross section expressions.
32609
32610 IF(ISUB.LE.20) THEN
32611 IF(ISUB.EQ.1) THEN
32612C...f + fbar -> gamma*/Z0
32613 MINT(61)=2
32614 CALL PYWIDT(23,SH,WDTP,WDTE)
32615 HS=SHR*WDTP(0)
32616 FACZ=4D0*COMFAC*3D0
32617 HP0=AEM/3D0*SH
32618 HP1=AEM/3D0*XWC*SH
32619 DO 100 I=MMINA,MMAXA
32620 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32621 EI=KCHG(IABS(I),1)/3D0
32622 AI=SIGN(1D0,EI)
32623 VI=AI-4D0*EI*XWV
32624 HI0=HP0
32625 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
32626 HI1=HP1
32627 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
32628 NCHN=NCHN+1
32629 ISIG(NCHN,1)=I
32630 ISIG(NCHN,2)=-I
32631 ISIG(NCHN,3)=1
32632 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
32633 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
32634 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
32635 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
32636 100 CONTINUE
32637
32638 ELSEIF(ISUB.EQ.2) THEN
32639C...f + fbar' -> W+/-
32640 CALL PYWIDT(24,SH,WDTP,WDTE)
32641 HS=SHR*WDTP(0)
32642 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
32643 HP=AEM/(24D0*XW)*SH
32644 DO 120 I=MMIN1,MMAX1
32645 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32646 IA=IABS(I)
32647 DO 110 J=MMIN2,MMAX2
32648 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32649 JA=IABS(J)
32650 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
32651 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32652 & GOTO 110
32653 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32654 HI=HP*2D0
32655 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
32656 NCHN=NCHN+1
32657 ISIG(NCHN,1)=I
32658 ISIG(NCHN,2)=J
32659 ISIG(NCHN,3)=1
32660 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
32661 SIGH(NCHN)=HI*FACBW*HF
32662 110 CONTINUE
32663 120 CONTINUE
32664
32665 ELSEIF(ISUB.EQ.15) THEN
32666C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32667 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32668C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32669 HFGG=0D0
32670 HFGZ=0D0
32671 HFZZ=0D0
32672 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32673 DO 130 I=1,MIN(16,MDCY(23,3))
32674 IDC=I+MDCY(23,2)-1
32675 IF(MDME(IDC,1).LT.0) GOTO 130
32676 IMDM=0
32677 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32678 & IMDM=1
32679 IF(I.LE.8) THEN
32680 EF=KCHG(I,1)/3D0
32681 AF=SIGN(1D0,EF+0.1D0)
32682 VF=AF-4D0*EF*XWV
32683 ELSEIF(I.LE.16) THEN
32684 EF=KCHG(I+2,1)/3D0
32685 AF=SIGN(1D0,EF+0.1D0)
32686 VF=AF-4D0*EF*XWV
32687 ENDIF
32688 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32689 IF(4D0*RM1.LT.1D0) THEN
32690 FCOF=1D0
32691 IF(I.LE.8) FCOF=3D0*RADC4
32692 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32693 IF(IMDM.EQ.1) THEN
32694 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32695 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32696 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32697 & AF**2*(1D0-4D0*RM1))*BE34
32698 ENDIF
32699 ENDIF
32700 130 CONTINUE
32701C...Propagators: as simulated in PYOFSH and as desired
32702 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32703 MINT15=MINT(15)
32704 MINT(15)=1
32705 MINT(61)=1
32706 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32707 MINT(15)=MINT15
32708 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32709 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32710 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32711 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32712C...Loop over flavours; consider full gamma/Z structure
32713 DO 140 I=MMINA,MMAXA
32714 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32715 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
32716 EI=KCHG(IABS(I),1)/3D0
32717 AI=SIGN(1D0,EI)
32718 VI=AI-4D0*EI*XWV
32719 NCHN=NCHN+1
32720 ISIG(NCHN,1)=I
32721 ISIG(NCHN,2)=-I
32722 ISIG(NCHN,3)=1
32723 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
32724 & (VI**2+AI**2)*HFZZ)/HBW4
32725 140 CONTINUE
32726
32727 ELSEIF(ISUB.EQ.16) THEN
32728C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32729 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32730C...Propagators: as simulated in PYOFSH and as desired
32731 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32732 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32733 GMMWC=SQRT(SQM4)*WDTP(0)
32734 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32735 FACWG=FACWG*HBW4C/HBW4
32736 DO 160 I=MMIN1,MMAX1
32737 IA=IABS(I)
32738 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
32739 DO 150 J=MMIN2,MMAX2
32740 JA=IABS(J)
32741 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
32742 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
32743 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32744 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32745 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32746 NCHN=NCHN+1
32747 ISIG(NCHN,1)=I
32748 ISIG(NCHN,2)=J
32749 ISIG(NCHN,3)=1
32750 SIGH(NCHN)=FACWG*FCKM*WIDSC
32751 150 CONTINUE
32752 160 CONTINUE
32753
32754 ELSEIF(ISUB.EQ.19) THEN
32755C...f + fbar -> gamma + (gamma*/Z0)
32756 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32757C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32758 HFGG=0D0
32759 HFGZ=0D0
32760 HFZZ=0D0
32761 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32762 DO 170 I=1,MIN(16,MDCY(23,3))
32763 IDC=I+MDCY(23,2)-1
32764 IF(MDME(IDC,1).LT.0) GOTO 170
32765 IMDM=0
32766 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32767 & IMDM=1
32768 IF(I.LE.8) THEN
32769 EF=KCHG(I,1)/3D0
32770 AF=SIGN(1D0,EF+0.1D0)
32771 VF=AF-4D0*EF*XWV
32772 ELSEIF(I.LE.16) THEN
32773 EF=KCHG(I+2,1)/3D0
32774 AF=SIGN(1D0,EF+0.1D0)
32775 VF=AF-4D0*EF*XWV
32776 ENDIF
32777 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32778 IF(4D0*RM1.LT.1D0) THEN
32779 FCOF=1D0
32780 IF(I.LE.8) FCOF=3D0*RADC4
32781 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32782 IF(IMDM.EQ.1) THEN
32783 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32784 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32785 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32786 & AF**2*(1D0-4D0*RM1))*BE34
32787 ENDIF
32788 ENDIF
32789 170 CONTINUE
32790C...Propagators: as simulated in PYOFSH and as desired
32791 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32792 MINT15=MINT(15)
32793 MINT(15)=1
32794 MINT(61)=1
32795 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32796 MINT(15)=MINT15
32797 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32798 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32799 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32800 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32801C...Loop over flavours; consider full gamma/Z structure
32802 DO 180 I=MMINA,MMAXA
32803 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
32804 EI=KCHG(IABS(I),1)/3D0
32805 AI=SIGN(1D0,EI)
32806 VI=AI-4D0*EI*XWV
32807 FCOI=1D0
32808 IF(IABS(I).LE.10) FCOI=FACA/3D0
32809 NCHN=NCHN+1
32810 ISIG(NCHN,1)=I
32811 ISIG(NCHN,2)=-I
32812 ISIG(NCHN,3)=1
32813 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32814 & (VI**2+AI**2)*HFZZ)/HBW4
32815 180 CONTINUE
32816
32817 ELSEIF(ISUB.EQ.20) THEN
32818C...f + fbar' -> gamma + W+/-
32819 FACGW=COMFAC*0.5D0*AEM**2/XW
32820C...Propagators: as simulated in PYOFSH and as desired
32821 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32822 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32823 GMMWC=SQRT(SQM4)*WDTP(0)
32824 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32825 FACGW=FACGW*HBW4C/HBW4
32826C...Anomalous couplings
32827 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32828 TERM2=0D0
32829 TERM3=0D0
32830 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
32831 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
32832 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
32833 & (4D0*SQMW))/(TH+UH)**2
32834 ENDIF
32835 DO 200 I=MMIN1,MMAX1
32836 IA=IABS(I)
32837 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
32838 DO 190 J=MMIN2,MMAX2
32839 JA=IABS(J)
32840 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
32841 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
32842 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32843 & GOTO 190
32844 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32845 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32846 IF(IA.LE.10) THEN
32847 FACWR=UH/(TH+UH)-1D0/3D0
32848 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32849 FCOI=FACA/3D0
32850 ELSE
32851 FACWR=-TH/(TH+UH)
32852 FCKM=1D0
32853 FCOI=1D0
32854 ENDIF
32855 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32856 NCHN=NCHN+1
32857 ISIG(NCHN,1)=I
32858 ISIG(NCHN,2)=J
32859 ISIG(NCHN,3)=1
32860 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32861 190 CONTINUE
32862 200 CONTINUE
32863 ENDIF
32864
32865 ELSEIF(ISUB.LE.40) THEN
32866 IF(ISUB.EQ.22) THEN
32867C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32868C...Kinematics dependence
32869 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32870 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32871C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32872 DO 220 I=1,6
32873 DO 210 J=1,3
32874 HGZ(I,J)=0D0
32875 210 CONTINUE
32876 220 CONTINUE
32877 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32878 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32879 DO 230 I=1,MIN(16,MDCY(23,3))
32880 IDC=I+MDCY(23,2)-1
32881 IF(MDME(IDC,1).LT.0) GOTO 230
32882 IMDM=0
32883 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32884 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32885 IF(I.LE.8) THEN
32886 EF=KCHG(I,1)/3D0
32887 AF=SIGN(1D0,EF+0.1D0)
32888 VF=AF-4D0*EF*XWV
32889 ELSEIF(I.LE.16) THEN
32890 EF=KCHG(I+2,1)/3D0
32891 AF=SIGN(1D0,EF+0.1D0)
32892 VF=AF-4D0*EF*XWV
32893 ENDIF
32894 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32895 IF(4D0*RM1.LT.1D0) THEN
32896 FCOF=1D0
32897 IF(I.LE.8) FCOF=3D0*RADC3
32898 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32899 IF(IMDM.GE.1) THEN
32900 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32901 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32902 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32903 & AF**2*(1D0-4D0*RM1))*BE34
32904 ENDIF
32905 ENDIF
32906 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32907 IF(4D0*RM1.LT.1D0) THEN
32908 FCOF=1D0
32909 IF(I.LE.8) FCOF=3D0*RADC4
32910 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32911 IF(IMDM.GE.1) THEN
32912 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32913 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32914 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32915 & AF**2*(1D0-4D0*RM1))*BE34
32916 ENDIF
32917 ENDIF
32918 230 CONTINUE
32919C...Propagators: as simulated in PYOFSH and as desired
32920 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32921 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32922 MINT15=MINT(15)
32923 MINT(15)=1
32924 MINT(61)=1
32925 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32926 MINT(15)=MINT15
32927 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32928 DO 240 J=1,3
32929 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32930 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32931 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32932 240 CONTINUE
32933 MINT15=MINT(15)
32934 MINT(15)=1
32935 MINT(61)=1
32936 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32937 MINT(15)=MINT15
32938 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32939 DO 250 J=1,3
32940 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32941 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32942 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32943 250 CONTINUE
32944C...Loop over flavours; separate left- and right-handed couplings
32945 DO 270 I=MMINA,MMAXA
32946 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32947 EI=KCHG(IABS(I),1)/3D0
32948 AI=SIGN(1D0,EI)
32949 VI=AI-4D0*EI*XWV
32950 VALI=VI-AI
32951 VARI=VI+AI
32952 FCOI=1D0
32953 IF(IABS(I).LE.10) FCOI=FACA/3D0
32954 DO 260 J=1,3
32955 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32956 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32957 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32958 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32959 260 CONTINUE
32960 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32961 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32962 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32963 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32964 NCHN=NCHN+1
32965 ISIG(NCHN,1)=I
32966 ISIG(NCHN,2)=-I
32967 ISIG(NCHN,3)=1
32968 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32969 270 CONTINUE
32970
32971 ELSEIF(ISUB.EQ.23) THEN
32972C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32973 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32974 FACZW=FACZW*WIDS(23,2)
32975 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32976 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32977 DO 290 I=MMIN1,MMAX1
32978 IA=IABS(I)
32979 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32980 DO 280 J=MMIN2,MMAX2
32981 JA=IABS(J)
32982 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32983 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32984 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32985 & GOTO 280
32986 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32987 EI=KCHG(IA,1)/3D0
32988 AI=SIGN(1D0,EI+0.1D0)
32989 VI=AI-4D0*EI*XWV
32990 EJ=KCHG(JA,1)/3D0
32991 AJ=SIGN(1D0,EJ+0.1D0)
32992 VJ=AJ-4D0*EJ*XWV
32993 IF(VI+AI.GT.0) THEN
32994 VISAV=VI
32995 AISAV=AI
32996 VI=VJ
32997 AI=AJ
32998 VJ=VISAV
32999 AJ=AISAV
33000 ENDIF
33001 FCKM=1D0
33002 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33003 FCOI=1D0
33004 IF(IA.LE.10) FCOI=FACA/3D0
33005 NCHN=NCHN+1
33006 ISIG(NCHN,1)=I
33007 ISIG(NCHN,2)=J
33008 ISIG(NCHN,3)=1
33009 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33010 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33011 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33012 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33013 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33014 & WIDS(24,(5-KCHW)/2)
33015C***Protect against slightly negative cross sections. (Reason yet to be
33016C***sorted out. One possibility: addition of width to the W propagator.)
33017 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33018 280 CONTINUE
33019 290 CONTINUE
33020
33021 ELSEIF(ISUB.EQ.25) THEN
33022C...f + fbar -> W+ + W-
33023C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33024 GMMZC=GMMZ
33025 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33026 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33027 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33028 GMMW3=SQRT(SQM3)*WDTP(0)
33029 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33030 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33031 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33032 GMMW4=SQRT(SQM4)*WDTP(0)
33033 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33034C...Kinematical functions
33035 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33036 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33037 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33038 GT=THUH34+4D0*THUH/TH2
33039 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33040 GU=THUH34+4D0*THUH/UH2
33041 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33042C...Common factors and couplings
33043 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33044 FACWW=FACWW*WIDS(24,1)
33045 CGG=AEM**2/2D0
33046 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33047 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33048 CNG=AEM**2/(4D0*XW)
33049 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33050 CNN=AEM**2/(16D0*XW**2)
33051C...Coulomb factor for W+W- pair
33052 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33053 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33054 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33055 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33056 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33057 & PMAS(24,2)**2)-COULE))
33058 ELSE
33059 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33060 ENDIF
33061 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33062 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33063 & PMAS(24,2)**2)+COULE))
33064 ELSE
33065 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33066 & ABS(COULE)))
33067 ENDIF
33068 IF(MSTP(40).EQ.1) THEN
33069 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33070 & MAX(1D-10,2D0*COULP*COULP1))
33071 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33072 ELSEIF(MSTP(40).EQ.2) THEN
33073 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33074 COULCP=DCMPLX(0D0,DBLE(COULP))
33075 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33076 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33077 & (4D0*COULCP)*LOG(COULCD)
33078 COULCS=DCMPLX(0D0,0D0)
33079 NSTP=100
33080 DO 300 ISTP=1,NSTP
33081 COULXX=(ISTP-0.5)/NSTP
33082 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33083 & (1D0+COULXX/COULCD))
33084 300 CONTINUE
33085 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33086 & (COULCS/NSTP)
33087 FACCOU=ABS(COULCR)**2
33088 ELSEIF(MSTP(40).EQ.3) THEN
33089 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33090 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33091 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33092 ENDIF
33093 ELSEIF(MSTP(40).EQ.4) THEN
33094 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33095 ELSE
33096 FACCOU=1D0
33097 ENDIF
33098 VINT(95)=FACCOU
33099 FACWW=FACWW*FACCOU
33100C...Loop over allowed flavours
33101 DO 310 I=MMINA,MMAXA
33102 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33103 EI=KCHG(IABS(I),1)/3D0
33104 AI=SIGN(1D0,EI+0.1D0)
33105 VI=AI-4D0*EI*XWV
33106 FCOI=1D0
33107 IF(IABS(I).LE.10) FCOI=FACA/3D0
33108 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33109 IF(AI.LT.0D0) THEN
33110 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33111 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33112 ELSE
33113 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33114 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33115 ENDIF
33116 ELSE
33117 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33118 BET=SQRT(1D0-4D0*XMW02/SH)
33119 GAT=1D0/SQRT(1D0-BET**2)
33120 STHE2=1D0-CTH**2
33121 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33122 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33123 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33124 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33125 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33126 & (1D0-2D0*BET*CTH+BET**2))
33127 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33128 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33129 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33130 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33131 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33132 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33133 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33134 DSIGWW=ATOT
33135 ENDIF
33136 NCHN=NCHN+1
33137 ISIG(NCHN,1)=I
33138 ISIG(NCHN,2)=-I
33139 ISIG(NCHN,3)=1
33140 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33141 310 CONTINUE
33142
33143 ELSEIF(ISUB.EQ.30) THEN
33144C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33145 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33146 & (-SH*UH)
33147C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33148 HFGG=0D0
33149 HFGZ=0D0
33150 HFZZ=0D0
33151 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33152 DO 320 I=1,MIN(16,MDCY(23,3))
33153 IDC=I+MDCY(23,2)-1
33154 IF(MDME(IDC,1).LT.0) GOTO 320
33155 IMDM=0
33156 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33157 & IMDM=1
33158 IF(I.LE.8) THEN
33159 EF=KCHG(I,1)/3D0
33160 AF=SIGN(1D0,EF+0.1D0)
33161 VF=AF-4D0*EF*XWV
33162 ELSEIF(I.LE.16) THEN
33163 EF=KCHG(I+2,1)/3D0
33164 AF=SIGN(1D0,EF+0.1D0)
33165 VF=AF-4D0*EF*XWV
33166 ENDIF
33167 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33168 IF(4D0*RM1.LT.1D0) THEN
33169 FCOF=1D0
33170 IF(I.LE.8) FCOF=3D0*RADC4
33171 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33172 IF(IMDM.EQ.1) THEN
33173 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33174 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33175 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33176 & AF**2*(1D0-4D0*RM1))*BE34
33177 ENDIF
33178 ENDIF
33179 320 CONTINUE
33180C...Propagators: as simulated in PYOFSH and as desired
33181 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33182 MINT15=MINT(15)
33183 MINT(15)=1
33184 MINT(61)=1
33185 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33186 MINT(15)=MINT15
33187 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33188 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33189 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33190 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33191C...Loop over flavours; consider full gamma/Z structure
33192 DO 340 I=MMINA,MMAXA
33193 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33194 EI=KCHG(IABS(I),1)/3D0
33195 AI=SIGN(1D0,EI)
33196 VI=AI-4D0*EI*XWV
33197 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33198 & (VI**2+AI**2)*HFZZ)/HBW4
33199 DO 330 ISDE=1,2
33200 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33201 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33202 NCHN=NCHN+1
33203 ISIG(NCHN,ISDE)=I
33204 ISIG(NCHN,3-ISDE)=21
33205 ISIG(NCHN,3)=1
33206 SIGH(NCHN)=FACZQ
33207 330 CONTINUE
33208 340 CONTINUE
33209
33210 ELSEIF(ISUB.EQ.31) THEN
33211C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33212 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33213 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33214C...Propagators: as simulated in PYOFSH and as desired
33215 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33216 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33217 GMMWC=SQRT(SQM4)*WDTP(0)
33218 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33219 FACWQ=FACWQ*HBW4C/HBW4
33220 DO 360 I=MMINA,MMAXA
33221 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33222 IA=IABS(I)
33223 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33224 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33225 DO 350 ISDE=1,2
33226 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33227 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33228 NCHN=NCHN+1
33229 ISIG(NCHN,ISDE)=I
33230 ISIG(NCHN,3-ISDE)=21
33231 ISIG(NCHN,3)=1
33232 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33233 350 CONTINUE
33234 360 CONTINUE
33235
33236 ELSEIF(ISUB.EQ.35) THEN
33237C...f + gamma -> f + (gamma*/Z0)
33238 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33239 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33240 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33241 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33242 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33243 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33244 ELSE
33245 FZQN=SH2+UH2+2D0*SQM4*TH
33246 FZQDTM=-SH*UH
33247 ENDIF
33248 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33249C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33250 HFGG=0D0
33251 HFGZ=0D0
33252 HFZZ=0D0
33253 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33254 DO 370 I=1,MIN(16,MDCY(23,3))
33255 IDC=I+MDCY(23,2)-1
33256 IF(MDME(IDC,1).LT.0) GOTO 370
33257 IMDM=0
33258 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33259 & IMDM=1
33260 IF(I.LE.8) THEN
33261 EF=KCHG(I,1)/3D0
33262 AF=SIGN(1D0,EF+0.1D0)
33263 VF=AF-4D0*EF*XWV
33264 ELSEIF(I.LE.16) THEN
33265 EF=KCHG(I+2,1)/3D0
33266 AF=SIGN(1D0,EF+0.1D0)
33267 VF=AF-4D0*EF*XWV
33268 ENDIF
33269 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33270 IF(4D0*RM1.LT.1D0) THEN
33271 FCOF=1D0
33272 IF(I.LE.8) FCOF=3D0*RADC4
33273 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33274 IF(IMDM.EQ.1) THEN
33275 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33276 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33277 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33278 & AF**2*(1D0-4D0*RM1))*BE34
33279 ENDIF
33280 ENDIF
33281 370 CONTINUE
33282C...Propagators: as simulated in PYOFSH and as desired
33283 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33284 MINT15=MINT(15)
33285 MINT(15)=1
33286 MINT(61)=1
33287 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33288 MINT(15)=MINT15
33289 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33290 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33291 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33292 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33293C...Loop over flavours; consider full gamma/Z structure
33294 DO 390 I=MMINA,MMAXA
33295 IF(I.EQ.0) GOTO 390
33296 EI=KCHG(IABS(I),1)/3D0
33297 AI=SIGN(1D0,EI)
33298 VI=AI-4D0*EI*XWV
33299 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33300 & (VI**2+AI**2)*HFZZ)/HBW4
33301 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33302 DO 380 ISDE=1,2
33303 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33304 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33305 NCHN=NCHN+1
33306 ISIG(NCHN,ISDE)=I
33307 ISIG(NCHN,3-ISDE)=22
33308 ISIG(NCHN,3)=1
33309 SIGH(NCHN)=FACZQ*FZQN/FZQD
33310 380 CONTINUE
33311 390 CONTINUE
33312
33313 ELSEIF(ISUB.EQ.36) THEN
33314C...f + gamma -> f' + W+/-
33315 FWQ=COMFAC*AEM**2/(2D0*XW)*
33316 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33317C...Propagators: as simulated in PYOFSH and as desired
33318 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33319 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33320 GMMWC=SQRT(SQM4)*WDTP(0)
33321 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33322 FWQ=FWQ*HBW4C/HBW4
33323 DO 410 I=MMINA,MMAXA
33324 IF(I.EQ.0) GOTO 410
33325 IA=IABS(I)
33326 EIA=ABS(KCHG(IABS(I),1)/3D0)
33327 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33328 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33329 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33330 DO 400 ISDE=1,2
33331 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
33332 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
33333 NCHN=NCHN+1
33334 ISIG(NCHN,ISDE)=I
33335 ISIG(NCHN,3-ISDE)=22
33336 ISIG(NCHN,3)=1
33337 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33338 400 CONTINUE
33339 410 CONTINUE
33340 ENDIF
33341
33342 ELSEIF(ISUB.LE.100) THEN
33343 IF(ISUB.EQ.69) THEN
33344C...gamma + gamma -> W+ + W-
33345 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33346 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
33347 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
33348 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
33349 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
33350 NCHN=NCHN+1
33351 ISIG(NCHN,1)=22
33352 ISIG(NCHN,2)=22
33353 ISIG(NCHN,3)=1
33354 SIGH(NCHN)=FACWW
33355 420 CONTINUE
33356
33357 ELSEIF(ISUB.EQ.70) THEN
33358C...gamma + W+/- -> Z0 + W+/-
33359 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33360 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
33361 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
33362 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
33363 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
33364 DO 440 KCHW=1,-1,-2
33365 DO 430 ISDE=1,2
33366 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
33367 NCHN=NCHN+1
33368 ISIG(NCHN,ISDE)=22
33369 ISIG(NCHN,3-ISDE)=24*KCHW
33370 ISIG(NCHN,3)=1
33371 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
33372 430 CONTINUE
33373 440 CONTINUE
33374 ENDIF
33375 ENDIF
33376
33377 RETURN
33378 END
33379
33380C*********************************************************************
33381
33382C...PYSGHG
33383C...Subprocess cross sections for Higgs processes,
33384C...except Higgs pairs in PYSGSU, but including WW scattering.
33385C...Auxiliary to PYSIGH.
33386
33387 SUBROUTINE PYSGHG(NCHN,SIGS)
33388
33389C...Double precision and integer declarations
33390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33391 IMPLICIT INTEGER(I-N)
33392 INTEGER PYK,PYCHGE,PYCOMP
33393C...Parameter statement to help give large particle numbers.
33394 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33395 &KEXCIT=4000000,KDIMEN=5000000)
33396C...Commonblocks
33397 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33398 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33399 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33400 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33401 COMMON/PYINT1/MINT(400),VINT(400)
33402 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33403 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33404 COMMON/PYINT4/MWID(500),WIDS(500,5)
33405 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33406 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33407 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33408 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33409 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33410 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33411 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
33412 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
33413C...Local arrays and complex variables
33414 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33415 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33416 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33417
33418C...Convert H or A process into equivalent h one
33419 IHIGG=1
33420 KFHIGG=25
33421 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
33422 KFHIGG=KFPR(ISUB,1)
33423 END IF
33424 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
33425 &ISUB.LE.190)) THEN
33426 IHIGG=2
33427 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
33428 KFHIGG=33+IHIGG
33429 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
33430 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
33431 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
33432 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
33433 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
33434 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
33435 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
33436 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
33437 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
33438 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
33439 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
33440 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
33441 ENDIF
33442 SQMH=PMAS(KFHIGG,1)**2
33443 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
33444
33445C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33446 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
33447 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
33448C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33449 IF(MSTP(46).LE.4) THEN
33450 HDTLH=LOG(PMAS(25,1)/PARP(44))
33451 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
33452 HDTNR=-1D0/18D0+HDTLH/6D0
33453 ELSE
33454 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
33455 HDTLQ=LOG(PARP(45)/PARP(44))
33456 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
33457 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
33458 ENDIF
33459
33460C...Calculate lowest and next-to-lowest order partial wave amplitudes
33461 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
33462 A00L=DBLE(HDTV*SH)
33463 A20L=-0.5D0*A00L
33464 A11L=A00L/6D0
33465 HDTLS=LOG(SH/PARP(44)**2)
33466 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33467 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
33468 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
33469 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33470 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
33471 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
33472 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
33473 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
33474
33475C...Unitarize partial wave amplitudes with Pade or K-matrix method
33476 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
33477 A00U=A00L/(1D0-A004/A00L)
33478 A20U=A20L/(1D0-A204/A20L)
33479 A11U=A11L/(1D0-A114/A11L)
33480 ELSE
33481 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
33482 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
33483 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
33484 ENDIF
33485 ENDIF
33486
33487C...Differential cross section expressions.
33488
33489 IF(ISUB.LE.60) THEN
33490 IF(ISUB.EQ.3) THEN
33491C...f + fbar -> h0 (or H0, or A0)
33492 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33493 HS=SHR*WDTP(0)
33494 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33495 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33496 & FACBW=0D0
33497 HP=AEM/(8D0*XW)*SH/SQMW*SH
33498 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33499 DO 100 I=MMINA,MMAXA
33500 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33501 IA=IABS(I)
33502 RMQ=PYMRUN(IA,SH)**2/SH
33503 HI=HP*RMQ
33504 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
33505 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33506 IKFI=1
33507 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33508 IF(IA.GT.10) IKFI=3
33509 HI=HI*PARU(150+10*IHIGG+IKFI)**2
33510 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33511 HI=HI/(1D0+RMSS(41))**2
33512 IF(IHIGG.NE.3) THEN
33513 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33514 & PARU(151+10*IHIGG))**2
33515 ENDIF
33516 ENDIF
33517 ENDIF
33518 NCHN=NCHN+1
33519 ISIG(NCHN,1)=I
33520 ISIG(NCHN,2)=-I
33521 ISIG(NCHN,3)=1
33522 SIGH(NCHN)=HI*FACBW*HF
33523 100 CONTINUE
33524
33525 ELSEIF(ISUB.EQ.5) THEN
33526C...Z0 + Z0 -> h0
33527 CALL PYWIDT(25,SH,WDTP,WDTE)
33528 HS=SHR*WDTP(0)
33529 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33530 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33531 HP=AEM/(8D0*XW)*SH/SQMW*SH
33532 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33533 HI=HP/4D0
33534 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
33535 DO 120 I=MMIN1,MMAX1
33536 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33537 DO 110 J=MMIN2,MMAX2
33538 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33539 EI=KCHG(IABS(I),1)/3D0
33540 AI=SIGN(1D0,EI)
33541 VI=AI-4D0*EI*XWV
33542 EJ=KCHG(IABS(J),1)/3D0
33543 AJ=SIGN(1D0,EJ)
33544 VJ=AJ-4D0*EJ*XWV
33545 NCHN=NCHN+1
33546 ISIG(NCHN,1)=I
33547 ISIG(NCHN,2)=J
33548 ISIG(NCHN,3)=1
33549 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
33550 110 CONTINUE
33551 120 CONTINUE
33552
33553 ELSEIF(ISUB.EQ.8) THEN
33554C...W+ + W- -> h0
33555 CALL PYWIDT(25,SH,WDTP,WDTE)
33556 HS=SHR*WDTP(0)
33557 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33558 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33559 HP=AEM/(8D0*XW)*SH/SQMW*SH
33560 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33561 HI=HP/2D0
33562 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
33563 DO 140 I=MMIN1,MMAX1
33564 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
33565 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33566 DO 130 J=MMIN2,MMAX2
33567 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
33568 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33569 IF(EI*EJ.GT.0D0) GOTO 130
33570 NCHN=NCHN+1
33571 ISIG(NCHN,1)=I
33572 ISIG(NCHN,2)=J
33573 ISIG(NCHN,3)=1
33574 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
33575 130 CONTINUE
33576 140 CONTINUE
33577
33578 ELSEIF(ISUB.EQ.24) THEN
33579C...f + fbar -> Z0 + h0 (or H0, or A0)
33580C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33581 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33582 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33583 GMMZ3=SQRT(SQM3)*WDTP(0)
33584 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
33585 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33586 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33587 GMMH4=SQRT(SQM4)*WDTP(0)
33588 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33589 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33590 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
33591 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
33592 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
33593 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
33594 & PARU(154+10*IHIGG)**2
33595 DO 150 I=MMINA,MMAXA
33596 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
33597 EI=KCHG(IABS(I),1)/3D0
33598 AI=SIGN(1D0,EI)
33599 VI=AI-4D0*EI*XWV
33600 FCOI=1D0
33601 IF(IABS(I).LE.10) FCOI=FACA/3D0
33602 NCHN=NCHN+1
33603 ISIG(NCHN,1)=I
33604 ISIG(NCHN,2)=-I
33605 ISIG(NCHN,3)=1
33606 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
33607 150 CONTINUE
33608
33609 ELSEIF(ISUB.EQ.26) THEN
33610C...f + fbar' -> W+/- + h0 (or H0, or A0)
33611C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33612 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33613 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33614 GMMW3=SQRT(SQM3)*WDTP(0)
33615 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33616 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33617 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33618 GMMH4=SQRT(SQM4)*WDTP(0)
33619 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33620 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33621 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
33622 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
33623 FACHW=FACHW*WIDS(KFHIGG,2)
33624 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
33625 & PARU(155+10*IHIGG)**2
33626 DO 170 I=MMIN1,MMAX1
33627 IA=IABS(I)
33628 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
33629 DO 160 J=MMIN2,MMAX2
33630 JA=IABS(J)
33631 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
33632 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
33633 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33634 & GOTO 160
33635 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33636 FCKM=1D0
33637 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33638 FCOI=1D0
33639 IF(IA.LE.10) FCOI=FACA/3D0
33640 NCHN=NCHN+1
33641 ISIG(NCHN,1)=I
33642 ISIG(NCHN,2)=J
33643 ISIG(NCHN,3)=1
33644 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
33645 160 CONTINUE
33646 170 CONTINUE
33647
33648 ELSEIF(ISUB.EQ.32) THEN
33649C...f + g -> f + h0 (q + g -> q + h0 only)
33650 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
33651C...H propagator: as simulated in PYOFSH and as desired
33652 SQMHC=PMAS(25,1)**2
33653 GMMHC=PMAS(25,1)*PMAS(25,2)
33654 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33655 CALL PYWIDT(25,SQM4,WDTP,WDTE)
33656 GMMHCC=SQRT(SQM4)*WDTP(0)
33657 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33658 FHCQ=FHCQ*HBW4C/HBW4
33659 DO 190 I=MMINA,MMAXA
33660 IA=IABS(I)
33661 IF(IA.NE.5) GOTO 190
33662 SQML=PYMRUN(IA,SH)**2
33663 SQMQ=PMAS(IA,1)**2
33664 FACHCQ=FHCQ*SQML/SQMW*
33665 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33666 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
33667 & (SQM4-SQMQ-SH)/SH)
33668 DO 180 ISDE=1,2
33669 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
33670 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
33671 NCHN=NCHN+1
33672 ISIG(NCHN,ISDE)=I
33673 ISIG(NCHN,3-ISDE)=21
33674 ISIG(NCHN,3)=1
33675 SIGH(NCHN)=FACHCQ*WIDS(25,2)
33676 180 CONTINUE
33677 190 CONTINUE
33678 ENDIF
33679
33680 ELSEIF(ISUB.LE.80) THEN
33681 IF(ISUB.EQ.71) THEN
33682C...Z0 + Z0 -> Z0 + Z0
33683 IF(SH.LE.4.01D0*SQMZ) GOTO 220
33684
33685 IF(MSTP(46).LE.2) THEN
33686C...Exact scattering ME:s for on-mass-shell gauge bosons
33687 BE2=1D0-4D0*SQMZ/SH
33688 TH=-0.5D0*SH*BE2*(1D0-CTH)
33689 UH=-0.5D0*SH*BE2*(1D0+CTH)
33690 IF(MAX(TH,UH).GT.-1D0) GOTO 220
33691 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
33692 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33693 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33694 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
33695 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33696 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33697 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
33698 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33699 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33700 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33701 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33702 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33703 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
33704 & (ASHIM+ATHIM+AUHIM)**2)
33705 IF(MSTP(46).EQ.2) FACZZ=0D0
33706
33707 ELSE
33708C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33709 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33710 & ABS(A00U+2D0*A20U)**2
33711 ENDIF
33712 FACZZ=FACZZ*WIDS(23,1)
33713
33714 DO 210 I=MMIN1,MMAX1
33715 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
33716 EI=KCHG(IABS(I),1)/3D0
33717 AI=SIGN(1D0,EI)
33718 VI=AI-4D0*EI*XWV
33719 AVI=AI**2+VI**2
33720 DO 200 J=MMIN2,MMAX2
33721 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
33722 EJ=KCHG(IABS(J),1)/3D0
33723 AJ=SIGN(1D0,EJ)
33724 VJ=AJ-4D0*EJ*XWV
33725 AVJ=AJ**2+VJ**2
33726 NCHN=NCHN+1
33727 ISIG(NCHN,1)=I
33728 ISIG(NCHN,2)=J
33729 ISIG(NCHN,3)=1
33730 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
33731 200 CONTINUE
33732 210 CONTINUE
33733 220 CONTINUE
33734
33735 ELSEIF(ISUB.EQ.72) THEN
33736C...Z0 + Z0 -> W+ + W-
33737 IF(SH.LE.4.01D0*SQMZ) GOTO 250
33738
33739 IF(MSTP(46).LE.2) THEN
33740C...Exact scattering ME:s for on-mass-shell gauge bosons
33741 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33742 CTH2=CTH**2
33743 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33744 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33745 IF(MAX(TH,UH).GT.-1D0) GOTO 250
33746 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33747 & (1D0-2D0*SQMZ/SH)
33748 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33749 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33750 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33751 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33752 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33753 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33754 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33755 ATWIM=0D0
33756 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33757 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33758 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33759 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33760 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33761 AUWIM=0D0
33762 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33763 A4IM=0D0
33764 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33765 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33766 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
33767 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33768 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33769 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
33770 & (ATWIM+AUWIM+A4IM)**2)
33771
33772 ELSE
33773C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33774 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33775 & ABS(A00U-A20U)**2
33776 ENDIF
33777 FACWW=FACWW*WIDS(24,1)
33778
33779 DO 240 I=MMIN1,MMAX1
33780 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
33781 EI=KCHG(IABS(I),1)/3D0
33782 AI=SIGN(1D0,EI)
33783 VI=AI-4D0*EI*XWV
33784 AVI=AI**2+VI**2
33785 DO 230 J=MMIN2,MMAX2
33786 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
33787 EJ=KCHG(IABS(J),1)/3D0
33788 AJ=SIGN(1D0,EJ)
33789 VJ=AJ-4D0*EJ*XWV
33790 AVJ=AJ**2+VJ**2
33791 NCHN=NCHN+1
33792 ISIG(NCHN,1)=I
33793 ISIG(NCHN,2)=J
33794 ISIG(NCHN,3)=1
33795 SIGH(NCHN)=FACWW*AVI*AVJ
33796 230 CONTINUE
33797 240 CONTINUE
33798 250 CONTINUE
33799
33800 ELSEIF(ISUB.EQ.73) THEN
33801C...Z0 + W+/- -> Z0 + W+/-
33802 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
33803
33804 IF(MSTP(46).LE.2) THEN
33805C...Exact scattering ME:s for on-mass-shell gauge bosons
33806 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
33807 EP1=1D0-(SQMZ-SQMW)/SH
33808 EP2=1D0+(SQMZ-SQMW)/SH
33809 TH=-0.5D0*SH*BE2*(1D0-CTH)
33810 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
33811 IF(MAX(TH,UH).GT.-1D0) GOTO 280
33812 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
33813 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33814 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33815 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
33816 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
33817 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
33818 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
33819 ASWIM=0D0
33820 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
33821 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
33822 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
33823 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
33824 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
33825 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
33826 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
33827 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
33828 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
33829 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
33830 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
33831 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
33832 AUWIM=0D0
33833 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
33834 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
33835 A4IM=0D0
33836 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
33837 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
33838 IF(MSTP(46).LE.0) FACZW=0D0
33839 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
33840 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
33841 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
33842 & (ASWIM+AUWIM+A4IM)**2)
33843
33844 ELSE
33845C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33846 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
33847 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
33848 ENDIF
33849 FACZW=FACZW*WIDS(23,2)
33850
33851 DO 270 I=MMIN1,MMAX1
33852 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33853 EI=KCHG(IABS(I),1)/3D0
33854 AI=SIGN(1D0,EI)
33855 VI=AI-4D0*EI*XWV
33856 AVI=AI**2+VI**2
33857 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33858 DO 260 J=MMIN2,MMAX2
33859 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33860 EJ=KCHG(IABS(J),1)/3D0
33861 AJ=SIGN(1D0,EJ)
33862 VJ=AI-4D0*EJ*XWV
33863 AVJ=AJ**2+VJ**2
33864 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33865 NCHN=NCHN+1
33866 ISIG(NCHN,1)=I
33867 ISIG(NCHN,2)=J
33868 ISIG(NCHN,3)=1
33869 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33870 NCHN=NCHN+1
33871 ISIG(NCHN,1)=I
33872 ISIG(NCHN,2)=J
33873 ISIG(NCHN,3)=2
33874 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33875 260 CONTINUE
33876 270 CONTINUE
33877 280 CONTINUE
33878
33879 ELSEIF(ISUB.EQ.75) THEN
33880C...W+ + W- -> gamma + gamma
33881
33882 ELSEIF(ISUB.EQ.76) THEN
33883C...W+ + W- -> Z0 + Z0
33884 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33885
33886 IF(MSTP(46).LE.2) THEN
33887C...Exact scattering ME:s for on-mass-shell gauge bosons
33888 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33889 CTH2=CTH**2
33890 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33891 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33892 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33893 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33894 & (1D0-2D0*SQMZ/SH)
33895 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33896 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33897 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33898 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33899 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33900 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33901 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33902 ATWIM=0D0
33903 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33904 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33905 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33906 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33907 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33908 AUWIM=0D0
33909 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33910 A4IM=0D0
33911 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33912 & (SH/SQMW)**2*SH2
33913 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33914 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33915 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33916 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33917 & (ATWIM+AUWIM+A4IM)**2)
33918
33919 ELSE
33920C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33921 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33922 & ABS(A00U-A20U)**2
33923 ENDIF
33924 FACZZ=FACZZ*WIDS(23,1)
33925
33926 DO 300 I=MMIN1,MMAX1
33927 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33928 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33929 DO 290 J=MMIN2,MMAX2
33930 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33931 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33932 IF(EI*EJ.GT.0D0) GOTO 290
33933 NCHN=NCHN+1
33934 ISIG(NCHN,1)=I
33935 ISIG(NCHN,2)=J
33936 ISIG(NCHN,3)=1
33937 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33938 290 CONTINUE
33939 300 CONTINUE
33940 310 CONTINUE
33941
33942 ELSEIF(ISUB.EQ.77) THEN
33943C...W+/- + W+/- -> W+/- + W+/-
33944 IF(SH.LE.4.01D0*SQMW) GOTO 340
33945
33946 IF(MSTP(46).LE.2) THEN
33947C...Exact scattering ME:s for on-mass-shell gauge bosons
33948 BE2=1D0-4D0*SQMW/SH
33949 BE4=BE2**2
33950 CTH2=CTH**2
33951 CTH3=CTH**3
33952 TH=-0.5D0*SH*BE2*(1D0-CTH)
33953 UH=-0.5D0*SH*BE2*(1D0+CTH)
33954 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33955 SHANG=(1D0+BE2)**2
33956 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33957 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33958 THANG=(BE2-CTH)**2
33959 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33960 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33961 UHANG=(BE2+CTH)**2
33962 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33963 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33964 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33965 ASGRE=XW*SGZANG
33966 ASGIM=0D0
33967 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33968 ASZIM=0D0
33969 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33970 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33971 ATGRE=0.5D0*XW*SH/TH*TGZANG
33972 ATGIM=0D0
33973 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33974 ATZIM=0D0
33975 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33976 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33977 AUGRE=0.5D0*XW*SH/UH*UGZANG
33978 AUGIM=0D0
33979 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33980 AUZIM=0D0
33981 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33982 A4AIM=0D0
33983 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33984 A4SIM=0D0
33985 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33986 & (SH/SQMW)**2*SH2
33987 IF(MSTP(46).LE.0) THEN
33988 AWWARE=ASHRE
33989 AWWAIM=ASHIM
33990 AWWSRE=0D0
33991 AWWSIM=0D0
33992 ELSEIF(MSTP(46).EQ.1) THEN
33993 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33994 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33995 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33996 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33997 ELSE
33998 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33999 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34000 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34001 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34002 ENDIF
34003 AWWA2=AWWARE**2+AWWAIM**2
34004 AWWS2=AWWSRE**2+AWWSIM**2
34005
34006 ELSE
34007C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34008 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34009 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34010 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34011 ENDIF
34012
34013 DO 330 I=MMIN1,MMAX1
34014 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34015 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34016 DO 320 J=MMIN2,MMAX2
34017 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34018 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34019 IF(EI*EJ.LT.0D0) THEN
34020C...W+W-
34021 IF(MSTP(45).EQ.1) GOTO 320
34022 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34023 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34024 ELSE
34025C...W+W+/W-W-
34026 IF(MSTP(45).EQ.2) GOTO 320
34027 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34028 IF(MSTP(46).GE.3) FACWW=FWWS
34029 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34030 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34031 ENDIF
34032 NCHN=NCHN+1
34033 ISIG(NCHN,1)=I
34034 ISIG(NCHN,2)=J
34035 ISIG(NCHN,3)=1
34036 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34037 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34038 320 CONTINUE
34039 330 CONTINUE
34040 340 CONTINUE
34041 ENDIF
34042
34043 ELSEIF(ISUB.LE.120) THEN
34044 IF(ISUB.EQ.102) THEN
34045C...g + g -> h0 (or H0, or A0)
34046 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34047 HS=SHR*WDTP(0)
34048 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34049 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34050 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34051 & FACBW=0D0
34052C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34053 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34054 WDTP13=0D0
34055 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34056 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34057 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34058 345 CONTINUE
34059 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34060 & '(PYSGHG:) did not find Higgs -> g g channel')
34061 HI=SHR*WDTP13/32D0
34062 ELSE
34063 HI=SHR*WDTP(13)/32D0
34064 ENDIF
34065 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34066 NCHN=NCHN+1
34067 ISIG(NCHN,1)=21
34068 ISIG(NCHN,2)=21
34069 ISIG(NCHN,3)=1
34070 SIGH(NCHN)=HI*FACBW*HF
34071 350 CONTINUE
34072
34073 ELSEIF(ISUB.EQ.103) THEN
34074C...gamma + gamma -> h0 (or H0, or A0)
34075 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34076 HS=SHR*WDTP(0)
34077 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34078 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34079 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34080 & FACBW=0D0
34081C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34082 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34083 WDTP14=0D0
34084 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34085 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34086 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34087 355 CONTINUE
34088 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34089 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34090 HI=SHR*WDTP14*2D0
34091 ELSE
34092 HI=SHR*WDTP(14)*2D0
34093 ENDIF
34094 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34095 NCHN=NCHN+1
34096 ISIG(NCHN,1)=22
34097 ISIG(NCHN,2)=22
34098 ISIG(NCHN,3)=1
34099 SIGH(NCHN)=HI*FACBW*HF
34100 360 CONTINUE
34101
34102 ELSEIF(ISUB.EQ.110) THEN
34103C...f + fbar -> gamma + h0
34104 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34105 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34106 FACHG=FACHG*WIDS(KFHIGG,2)
34107C...Calculate loop contributions for intermediate gamma* and Z0
34108 CIGTOT=DCMPLX(0D0,0D0)
34109 CIZTOT=DCMPLX(0D0,0D0)
34110 JMAX=3*MSTP(1)+1
34111 DO 370 J=1,JMAX
34112 IF(J.LE.2*MSTP(1)) THEN
34113 FNC=1D0
34114 EJ=KCHG(J,1)/3D0
34115 AJ=SIGN(1D0,EJ+0.1D0)
34116 VJ=AJ-4D0*EJ*XWV
34117 BALP=SQM4/(2D0*PMAS(J,1))**2
34118 BBET=SH/(2D0*PMAS(J,1))**2
34119 ELSEIF(J.LE.3*MSTP(1)) THEN
34120 FNC=3D0
34121 JL=2*(J-2*MSTP(1))-1
34122 EJ=KCHG(10+JL,1)/3D0
34123 AJ=SIGN(1D0,EJ+0.1D0)
34124 VJ=AJ-4D0*EJ*XWV
34125 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34126 BBET=SH/(2D0*PMAS(10+JL,1))**2
34127 ELSE
34128 BALP=SQM4/(2D0*PMAS(24,1))**2
34129 BBET=SH/(2D0*PMAS(24,1))**2
34130 ENDIF
34131 BABI=1D0/(BALP-BBET)
34132 IF(BALP.LT.1D0) THEN
34133 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34134 F1ALP=F0ALP**2
34135 ELSE
34136 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34137 & -DBLE(0.5D0*PARU(1)))
34138 F1ALP=-F0ALP**2
34139 ENDIF
34140 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34141 IF(BBET.LT.1D0) THEN
34142 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34143 F1BET=F0BET**2
34144 ELSE
34145 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34146 & -DBLE(0.5D0*PARU(1)))
34147 F1BET=-F0BET**2
34148 ENDIF
34149 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34150 IF(J.LE.3*MSTP(1)) THEN
34151 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34152 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34153 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34154 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34155 ELSE
34156 TXW=XW/XW1
34157 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34158 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34159 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34160 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34161 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34162 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34163 & (F1BET-F1ALP))
34164 ENDIF
34165 370 CONTINUE
34166 CIGTOT=CIGTOT/DBLE(SH)
34167 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34168C...Loop over initial flavours
34169 DO 380 I=MMINA,MMAXA
34170 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34171 EI=KCHG(IABS(I),1)/3D0
34172 AI=SIGN(1D0,EI)
34173 VI=AI-4D0*EI*XWV
34174 FCOI=1D0
34175 IF(IABS(I).LE.10) FCOI=FACA/3D0
34176 NCHN=NCHN+1
34177 ISIG(NCHN,1)=I
34178 ISIG(NCHN,2)=-I
34179 ISIG(NCHN,3)=1
34180 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34181 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34182 380 CONTINUE
34183
34184 ELSEIF(ISUB.EQ.111) THEN
34185C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34186 IF(MSTP(38).NE.0) THEN
34187C...Simple case: only do gg <-> h exactly.
34188 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34189C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34190 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34191 WDTP13=0D0
34192 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34193 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34194 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34195 385 CONTINUE
34196 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34197 & '(PYSGHG:) did not find Higgs -> g g channel')
34198 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34199 & (TH**2+UH**2)/(SH*SQM4)
34200 ELSE
34201 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34202 & (TH**2+UH**2)/(SH*SQM4)
34203 ENDIF
34204C...Propagators: as simulated in PYOFSH and as desired
34205 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34206 GMMHC=SQRT(SQM4)*WDTP(0)
34207 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34208 & ((SQM4-SQMH)**2+GMMHC**2)
34209 FACGH=FACGH*HBW4C/HBW4
34210 ELSE
34211C...Messy case: do full loop integrals
34212 A5STUR=0D0
34213 A5STUI=0D0
34214 DO 390 I=1,2*MSTP(1)
34215 SQMQ=PMAS(I,1)**2
34216 EPSS=4D0*SQMQ/SH
34217 EPSH=4D0*SQMQ/SQMH
34218 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34219 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34220 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34221 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34222 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34223 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34224 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34225 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34226 390 CONTINUE
34227 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34228 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34229 FACGH=FACGH*WIDS(25,2)
34230 ENDIF
34231 DO 400 I=MMINA,MMAXA
34232 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34233 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34234 NCHN=NCHN+1
34235 ISIG(NCHN,1)=I
34236 ISIG(NCHN,2)=-I
34237 ISIG(NCHN,3)=1
34238 SIGH(NCHN)=FACGH
34239 400 CONTINUE
34240
34241 ELSEIF(ISUB.EQ.112) THEN
34242C...f + g -> f + h0 (q + g -> q + h0 only)
34243 IF(MSTP(38).NE.0) THEN
34244C...Simple case: only do gg <-> h exactly.
34245 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34246C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34247 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34248 WDTP13=0D0
34249 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34250 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34251 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34252 405 CONTINUE
34253 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34254 & '(PYSGHG:) did not find Higgs -> g g channel')
34255 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34256 & (SH**2+UH**2)/(-TH*SQM4)
34257 ELSE
34258 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34259 & (SH**2+UH**2)/(-TH*SQM4)
34260 ENDIF
34261C...Propagators: as simulated in PYOFSH and as desired
34262 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34263 GMMHC=SQRT(SQM4)*WDTP(0)
34264 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34265 & ((SQM4-SQMH)**2+GMMHC**2)
34266 FACQH=FACQH*HBW4C/HBW4
34267 ELSE
34268C...Messy case: do full loop integrals
34269 A5TSUR=0D0
34270 A5TSUI=0D0
34271 DO 410 I=1,2*MSTP(1)
34272 SQMQ=PMAS(I,1)**2
34273 EPST=4D0*SQMQ/TH
34274 EPSH=4D0*SQMQ/SQMH
34275 CALL PYWAUX(1,EPST,W1TR,W1TI)
34276 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34277 CALL PYWAUX(2,EPST,W2TR,W2TI)
34278 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34279 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34280 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34281 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34282 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34283 410 CONTINUE
34284 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34285 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34286 FACQH=FACQH*WIDS(25,2)
34287 ENDIF
34288 DO 430 I=MMINA,MMAXA
34289 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34290 DO 420 ISDE=1,2
34291 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34292 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34293 NCHN=NCHN+1
34294 ISIG(NCHN,ISDE)=I
34295 ISIG(NCHN,3-ISDE)=21
34296 ISIG(NCHN,3)=1
34297 SIGH(NCHN)=FACQH
34298 420 CONTINUE
34299 430 CONTINUE
34300
34301 ELSEIF(ISUB.EQ.113) THEN
34302C...g + g -> g + h0
34303 IF(MSTP(38).NE.0) THEN
34304C...Simple case: only do gg <-> h exactly.
34305 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34306C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34307 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34308 WDTP13=0D0
34309 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34310 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34311 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34312 435 CONTINUE
34313 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34314 & '(PYSGHG:) did not find Higgs -> g g channel')
34315 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34316 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34317 ELSE
34318 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34319 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34320 ENDIF
34321C...Propagators: as simulated in PYOFSH and as desired
34322 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34323 GMMHC=SQRT(SQM4)*WDTP(0)
34324 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34325 & ((SQM4-SQMH)**2+GMMHC**2)
34326 FACGH=FACGH*HBW4C/HBW4
34327 ELSE
34328C...Messy case: do full loop integrals
34329 A2STUR=0D0
34330 A2STUI=0D0
34331 A2USTR=0D0
34332 A2USTI=0D0
34333 A2TUSR=0D0
34334 A2TUSI=0D0
34335 A4STUR=0D0
34336 A4STUI=0D0
34337 DO 440 I=1,2*MSTP(1)
34338 SQMQ=PMAS(I,1)**2
34339 EPSS=4D0*SQMQ/SH
34340 EPST=4D0*SQMQ/TH
34341 EPSU=4D0*SQMQ/UH
34342 EPSH=4D0*SQMQ/SQMH
34343 IF(EPSH.LT.1D-6) GOTO 440
34344 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34345 CALL PYWAUX(1,EPST,W1TR,W1TI)
34346 CALL PYWAUX(1,EPSU,W1UR,W1UI)
34347 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34348 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34349 CALL PYWAUX(2,EPST,W2TR,W2TI)
34350 CALL PYWAUX(2,EPSU,W2UR,W2UI)
34351 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34352 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
34353 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
34354 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
34355 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
34356 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
34357 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
34358 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
34359 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
34360 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
34361 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
34362 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
34363 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
34364 W3STUR=YHSTUR-Y3STUR-Y3UTSR
34365 W3STUI=YHSTUI-Y3STUI-Y3UTSI
34366 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
34367 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
34368 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
34369 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
34370 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
34371 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
34372 W3USTR=YHUSTR-Y3USTR-Y3TSUR
34373 W3USTI=YHUSTI-Y3USTI-Y3TSUI
34374 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
34375 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
34376 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
34377 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
34378 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
34379 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
34380 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
34381 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
34382 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
34383 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
34384 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
34385 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
34386 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
34387 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
34388 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
34389 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
34390 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
34391 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
34392 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
34393 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
34394 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
34395 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
34396 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
34397 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
34398 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
34399 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
34400 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
34401 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
34402 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
34403 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
34404 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
34405 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
34406 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
34407 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
34408 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
34409 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
34410 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
34411 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
34412 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
34413 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
34414 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
34415 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
34416 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
34417 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
34418 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
34419 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
34420 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
34421 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
34422 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
34423 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
34424 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
34425 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
34426 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
34427 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
34428 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
34429 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
34430 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
34431 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
34432 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
34433 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
34434 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
34435 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
34436 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34437 & (W2SR-W2HR+W3STUR))
34438 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
34439 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34440 & (W2TR-W2HR+W3TUSR))
34441 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
34442 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34443 & (W2UR-W2HR+W3USTR))
34444 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
34445 A2STUR=A2STUR+B2STUR+B2SUTR
34446 A2STUI=A2STUI+B2STUI+B2SUTI
34447 A2USTR=A2USTR+B2USTR+B2UTSR
34448 A2USTI=A2USTI+B2USTI+B2UTSI
34449 A2TUSR=A2TUSR+B2TUSR+B2TSUR
34450 A2TUSI=A2TUSI+B2TUSI+B2TSUI
34451 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
34452 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
34453 440 CONTINUE
34454 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
34455 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
34456 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
34457 FACGH=FACGH*WIDS(25,2)
34458 ENDIF
34459 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
34460 NCHN=NCHN+1
34461 ISIG(NCHN,1)=21
34462 ISIG(NCHN,2)=21
34463 ISIG(NCHN,3)=1
34464 SIGH(NCHN)=FACGH
34465 450 CONTINUE
34466 ENDIF
34467
34468 ELSEIF(ISUB.LE.170) THEN
34469 IF(ISUB.EQ.121) THEN
34470C...g + g -> Q + Qbar + h0
34471 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
34472 IA=KFPR(ISUBSV,2)
34473 PMF=PYMRUN(IA,SH)
34474 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34475 & (0.5D0*PMF/PMAS(24,1))**2
34476 WID2=1D0
34477 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34478 FACQQH=FACQQH*WID2
34479 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34480 IKFI=1
34481 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34482 IF(IA.GT.10) IKFI=3
34483 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34484 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34485 FACQQH=FACQQH/(1D0+RMSS(41))**2
34486 IF(IHIGG.NE.3) THEN
34487 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34488 & PARU(151+10*IHIGG))**2
34489 ENDIF
34490 ENDIF
34491 ENDIF
34492 CALL PYQQBH(WTQQBH)
34493 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34494 HS=SHR*WDTP(0)
34495 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34496 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34497 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34498 & FACBW=0D0
34499 NCHN=NCHN+1
34500 ISIG(NCHN,1)=21
34501 ISIG(NCHN,2)=21
34502 ISIG(NCHN,3)=1
34503 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34504 460 CONTINUE
34505
34506 ELSEIF(ISUB.EQ.122) THEN
34507C...q + qbar -> Q + Qbar + h0
34508 IA=KFPR(ISUBSV,2)
34509 PMF=PYMRUN(IA,SH)
34510 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34511 & (0.5D0*PMF/PMAS(24,1))**2
34512 WID2=1D0
34513 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34514 FACQQH=FACQQH*WID2
34515 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34516 IKFI=1
34517 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34518 IF(IA.GT.10) IKFI=3
34519 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34520 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34521 FACQQH=FACQQH/(1D0+RMSS(41))**2
34522 IF(IHIGG.NE.3) THEN
34523 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34524 & PARU(151+10*IHIGG))**2
34525 ENDIF
34526 ENDIF
34527 ENDIF
34528 CALL PYQQBH(WTQQBH)
34529 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34530 HS=SHR*WDTP(0)
34531 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34532 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34533 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34534 & FACBW=0D0
34535 DO 470 I=MMINA,MMAXA
34536 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34537 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
34538 NCHN=NCHN+1
34539 ISIG(NCHN,1)=I
34540 ISIG(NCHN,2)=-I
34541 ISIG(NCHN,3)=1
34542 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34543 470 CONTINUE
34544
34545 ELSEIF(ISUB.EQ.123) THEN
34546C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34547C...inner process)
34548 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
34549 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34550 & PARU(154+10*IHIGG)**2
34551 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34552 & (VINT(216)-VINT(209)**2))**2
34553 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34554 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
34555 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34556 HS=SHR*WDTP(0)
34557 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34558 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34559 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34560 & FACBW=0D0
34561 DO 490 I=MMIN1,MMAX1
34562 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
34563 IA=IABS(I)
34564 DO 480 J=MMIN2,MMAX2
34565 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
34566 JA=IABS(J)
34567 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
34568 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
34569 VI=AI-4D0*EI*XWV
34570 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
34571 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
34572 VJ=AJ-4D0*EJ*XWV
34573 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
34574 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
34575 NCHN=NCHN+1
34576 ISIG(NCHN,1)=I
34577 ISIG(NCHN,2)=J
34578 ISIG(NCHN,3)=1
34579 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
34580 480 CONTINUE
34581 490 CONTINUE
34582
34583 ELSEIF(ISUB.EQ.124) THEN
34584C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34585C...inner process)
34586 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
34587 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34588 & PARU(155+10*IHIGG)**2
34589 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34590 & (VINT(216)-VINT(209)**2))**2
34591 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34592 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34593 HS=SHR*WDTP(0)
34594 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34595 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34596 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34597 & FACBW=0D0
34598 DO 510 I=MMIN1,MMAX1
34599 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
34600 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34601 DO 500 J=MMIN2,MMAX2
34602 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
34603 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34604 IF(EI*EJ.GT.0D0) GOTO 500
34605 FACLR=VINT(180+I)*VINT(180+J)
34606 NCHN=NCHN+1
34607 ISIG(NCHN,1)=I
34608 ISIG(NCHN,2)=J
34609 ISIG(NCHN,3)=1
34610 SIGH(NCHN)=FACLR*FACWW*FACBW
34611 500 CONTINUE
34612 510 CONTINUE
34613
34614 ELSEIF(ISUB.EQ.143) THEN
34615C...f + fbar' -> H+/-
34616 SQMHC=PMAS(37,1)**2
34617 CALL PYWIDT(37,SH,WDTP,WDTE)
34618 HS=SHR*WDTP(0)
34619 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
34620 HP=AEM/(8D0*XW)*SH/SQMW*SH
34621 DO 530 I=MMIN1,MMAX1
34622 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
34623 IA=IABS(I)
34624 IM=(MOD(IA,10)+1)/2
34625 DO 520 J=MMIN2,MMAX2
34626 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
34627 JA=IABS(J)
34628 JM=(MOD(JA,10)+1)/2
34629 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
34630 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34631 & GOTO 520
34632 IF(MOD(IA,2).EQ.0) THEN
34633 IU=IA
34634 IL=JA
34635 ELSE
34636 IU=JA
34637 IL=IA
34638 ENDIF
34639 RML=PYMRUN(IL,SH)**2/SH
34640 RMU=PYMRUN(IU,SH)**2/SH
34641 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
34642 IF(IA.LE.10) HI=HI*FACA/3D0
34643 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34644 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
34645 NCHN=NCHN+1
34646 ISIG(NCHN,1)=I
34647 ISIG(NCHN,2)=J
34648 ISIG(NCHN,3)=1
34649 SIGH(NCHN)=HI*FACBW*HF
34650 520 CONTINUE
34651 530 CONTINUE
34652
34653 ELSEIF(ISUB.EQ.161) THEN
34654C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34655C...(choice of only b and t to avoid kinematics problems)
34656 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
34657C...H propagator: as simulated in PYOFSH and as desired
34658 SQMHC=PMAS(37,1)**2
34659 GMMHC=PMAS(37,1)*PMAS(37,2)
34660 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34661 CALL PYWIDT(37,SQM4,WDTP,WDTE)
34662 GMMHCC=SQRT(SQM4)*WDTP(0)
34663 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34664 FHCQ=FHCQ*HBW4C/HBW4
34665 Q2RM=SH
34666 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
34667 DO 550 I=MMINA,MMAXA
34668 IA=IABS(I)
34669 IF(IA.NE.5) GOTO 550
34670 SQML=PYMRUN(IA,Q2RM)**2
34671 IUA=IA+MOD(IA,2)
34672 SQMQ=PYMRUN(IUA,Q2RM)**2
34673 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
34674 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34675 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
34676 & (SQMHC-SQMQ-SH)/SH)
34677 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34678 DO 540 ISDE=1,2
34679 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
34680 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
34681 NCHN=NCHN+1
34682 ISIG(NCHN,ISDE)=I
34683 ISIG(NCHN,3-ISDE)=21
34684 ISIG(NCHN,3)=1
34685 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
34686 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
34687 540 CONTINUE
34688 550 CONTINUE
34689 ENDIF
34690
34691 ELSEIF(ISUB.LE.402) THEN
34692 IF(ISUB.EQ.401) THEN
34693C... g + g -> t + bbar + H-
34694 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
34695 IA=KFPR(ISUBSV,2)
34696 CALL PYSTBH(WTTBH)
34697 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34698 HS=SHR*WDTP(0)
34699 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34700 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34701 & FACBW=0D0
34702 NCHN=NCHN+1
34703 ISIG(NCHN,1)=21
34704 ISIG(NCHN,2)=21
34705 ISIG(NCHN,3)=1
34706 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34707c Since we don't know yet if H+ or H-, assume H+
34708c when calculating suppression due to closed channels.
34709 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34710 IF(ABS(WIDS(37,2)-WIDS(37,3))
34711 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
34712 & ABS(WIDS(6,2)-WIDS(6,3))
34713 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
34714 WRITE(*,*)'Error: Process 401 cannot handle different'
34715 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34716 WRITE(*,*)'Execution stopped.'
34717 CALL PYSTOP(108)
34718 END IF
34719 560 CONTINUE
34720
34721 ELSEIF(ISUB.EQ.402) THEN
34722C... q + qbar -> t + bbar + H-
34723 IA=KFPR(ISUBSV,2)
34724 CALL PYSTBH(WTTBH)
34725 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34726 HS=SHR*WDTP(0)
34727 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34728 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34729 & FACBW=0D0
34730 DO 570 I=MMINA,MMAXA
34731 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34732 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
34733 NCHN=NCHN+1
34734 ISIG(NCHN,1)=I
34735 ISIG(NCHN,2)=-I
34736 ISIG(NCHN,3)=1
34737 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34738c Since we don't know yet if H+ or H-, assume H+
34739c when calculating suppression due to closed channels.
34740 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34741 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
34742 & .GE.1D-6.OR.
34743 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
34744 & .GE.1D-6) THEN
34745 WRITE(*,*)'Error: Process 402 cannot handle different'
34746 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34747 WRITE(*,*)'Execution stopped.'
34748 CALL PYSTOP(108)
34749 END IF
34750 570 CONTINUE
34751 ENDIF
34752 ENDIF
34753
34754 RETURN
34755 END
34756
34757C*********************************************************************
34758
34759C...PYSGSU
34760C...Subprocess cross sections for SUSY processes,
34761C...including Higgs pair production.
34762C...Auxiliary to PYSIGH.
34763
34764 SUBROUTINE PYSGSU(NCHN,SIGS)
34765
34766C...Double precision and integer declarations
34767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34768 IMPLICIT INTEGER(I-N)
34769 INTEGER PYK,PYCHGE,PYCOMP
34770C...Parameter statement to help give large particle numbers.
34771 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34772 &KEXCIT=4000000,KDIMEN=5000000)
34773C...Commonblocks
34774 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34775 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34776 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34777 COMMON/PYINT1/MINT(400),VINT(400)
34778 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34779 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34780 COMMON/PYINT4/MWID(500),WIDS(500,5)
34781 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34782 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34783 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34784 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34785 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34786 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34787 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34788 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
34789 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
34790C...Local arrays and complex variables
34791 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34792 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34793 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34794 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34795
34796CMRENNA++
34797C...Z and W width, combinations of weak mixing angle
34798 ZWID=PMAS(23,2)
34799 WWID=PMAS(24,2)
34800 TANW=SQRT(XW/XW1)
34801 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34802
34803C...Convert almost equivalent SUSY processes into each other
34804C...Extract differences in flavours and couplings
34805
34806C...Sleptons and sneutrinos
34807 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
34808 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34809 ISUB=201
34810 ILR=0
34811 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
34812 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34813 ISUB=201
34814 ILR=1
34815 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
34816 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34817 ISUB=203
34818 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
34819 IF(ISUB.EQ.210) THEN
34820 RKF=2.0D0
34821 ELSEIF(ISUB.EQ.211) THEN
34822 RKF=SFMIX(15,1)**2
34823 ELSEIF(ISUB.EQ.212) THEN
34824 RKF=SFMIX(15,2)**2
34825 ENDIF
34826 ISUB=210
34827 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
34828 IF(ISUB.EQ.213) THEN
34829 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34830 RKF=2.0D0
34831 ELSEIF(ISUB.EQ.214) THEN
34832 KFID=16
34833 RKF=1.0D0
34834 ENDIF
34835 ISUB=213
34836
34837C...Neutralinos
34838 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
34839 IF(ISUB.EQ.216) THEN
34840 IZID1=1
34841 IZID2=1
34842 ELSEIF(ISUB.EQ.217) THEN
34843 IZID1=2
34844 IZID2=2
34845 ELSEIF(ISUB.EQ.218) THEN
34846 IZID1=3
34847 IZID2=3
34848 ELSEIF(ISUB.EQ.219) THEN
34849 IZID1=4
34850 IZID2=4
34851 ELSEIF(ISUB.EQ.220) THEN
34852 IZID1=1
34853 IZID2=2
34854 ELSEIF(ISUB.EQ.221) THEN
34855 IZID1=1
34856 IZID2=3
34857 ELSEIF(ISUB.EQ.222) THEN
34858 IZID1=1
34859 IZID2=4
34860 ELSEIF(ISUB.EQ.223) THEN
34861 IZID1=2
34862 IZID2=3
34863 ELSEIF(ISUB.EQ.224) THEN
34864 IZID1=2
34865 IZID2=4
34866 ELSEIF(ISUB.EQ.225) THEN
34867 IZID1=3
34868 IZID2=4
34869 ENDIF
34870 ISUB=216
34871
34872C...Charginos
34873 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
34874 IF(ISUB.EQ.226) THEN
34875 IZID1=1
34876 IZID2=1
34877 ELSEIF(ISUB.EQ.227) THEN
34878 IZID1=2
34879 IZID2=2
34880 ELSEIF(ISUB.EQ.228) THEN
34881 IZID1=1
34882 IZID2=2
34883 ENDIF
34884 ISUB=226
34885
34886C...Neutralino + chargino
34887 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34888 IF(ISUB.EQ.229) THEN
34889 IZID1=1
34890 IZID2=1
34891 ELSEIF(ISUB.EQ.230) THEN
34892 IZID1=1
34893 IZID2=2
34894 ELSEIF(ISUB.EQ.231) THEN
34895 IZID1=1
34896 IZID2=3
34897 ELSEIF(ISUB.EQ.232) THEN
34898 IZID1=1
34899 IZID2=4
34900 ELSEIF(ISUB.EQ.233) THEN
34901 IZID1=2
34902 IZID2=1
34903 ELSEIF(ISUB.EQ.234) THEN
34904 IZID1=2
34905 IZID2=2
34906 ELSEIF(ISUB.EQ.235) THEN
34907 IZID1=2
34908 IZID2=3
34909 ELSEIF(ISUB.EQ.236) THEN
34910 IZID1=2
34911 IZID2=4
34912 ENDIF
34913 ISUB=229
34914
34915C...Gluino + neutralino
34916 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34917 IF(ISUB.EQ.237) THEN
34918 IZID=1
34919 ELSEIF(ISUB.EQ.238) THEN
34920 IZID=2
34921 ELSEIF(ISUB.EQ.239) THEN
34922 IZID=3
34923 ELSEIF(ISUB.EQ.240) THEN
34924 IZID=4
34925 ENDIF
34926 ISUB=237
34927
34928C...Gluino + chargino
34929 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34930 IF(ISUB.EQ.241) THEN
34931 IZID=1
34932 ELSEIF(ISUB.EQ.242) THEN
34933 IZID=2
34934 ENDIF
34935 ISUB=241
34936
34937C...Squark + neutralino
34938 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34939 ILR=0
34940 IF(MOD(ISUB,2).NE.0) ILR=1
34941 IF(ISUB.LE.247) THEN
34942 IZID=1
34943 ELSEIF(ISUB.LE.249) THEN
34944 IZID=2
34945 ELSEIF(ISUB.LE.251) THEN
34946 IZID=3
34947 ELSEIF(ISUB.LE.253) THEN
34948 IZID=4
34949 ENDIF
34950 ISUB=246
34951 RKF=5D0
34952
34953C...Squark + chargino
34954 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34955 IF(ISUB.LE.255) THEN
34956 IZID=1
34957 ELSEIF(ISUB.LE.257) THEN
34958 IZID=2
34959 ENDIF
34960 IF(MOD(ISUB,2).EQ.0) THEN
34961 ILR=0
34962 ELSE
34963 ILR=1
34964 ENDIF
34965 ISUB=254
34966 RKF=5D0
34967
34968C...Squark + gluino
34969 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34970 ISUB=258
34971 RKF=4D0
34972
34973C...Stops
34974 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34975 ILR=0
34976 IF(ISUB.EQ.262) ILR=1
34977 ISUB=261
34978 ELSEIF(ISUB.EQ.265) THEN
34979 ISUB=264
34980
34981C...Squarks
34982 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34983 ILR=0
34984 IF(ISUB.LE.273) THEN
34985 IF(ISUB.EQ.273) ILR=1
34986 ISUB=271
34987 RKF=16D0
34988 ELSEIF(ISUB.LE.276) THEN
34989 IF(ISUB.EQ.276) ILR=1
34990 ISUB=274
34991 RKF=16D0
34992 ELSEIF(ISUB.LE.278) THEN
34993 IF(ISUB.EQ.278) ILR=1
34994 ISUB=277
34995 RKF=4D0
34996 ELSE
34997 IF(ISUB.EQ.280) ILR=1
34998 ISUB=279
34999 RKF=4D0
35000 ENDIF
35001C...Sbottoms
35002 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35003 ILR=0
35004 IF(ISUB.LE.283) THEN
35005 IF(ISUB.EQ.283) ILR=1
35006 ISUB=271
35007 RKF=4D0
35008 ELSEIF(ISUB.LE.286) THEN
35009 IF(ISUB.EQ.286) ILR=1
35010 ISUB=274
35011 RKF=4D0
35012 ELSEIF(ISUB.LE.288) THEN
35013 IF(ISUB.EQ.288) ILR=1
35014 ISUB=277
35015 RKF=1D0
35016 ELSEIF(ISUB.LE.290) THEN
35017 IF(ISUB.EQ.290) ILR=1
35018 ISUB=279
35019 RKF=1D0
35020 ELSEIF(ISUB.LE.293) THEN
35021 IF(ISUB.EQ.293) ILR=1
35022 ISUB=271
35023 RKF=1D0
35024 ELSEIF(ISUB.EQ.296) THEN
35025 ILR=1
35026 ISUB=274
35027 RKF=1D0
35028C...Squark + gluino
35029 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35030 ISUB=258
35031 RKF=1D0
35032 ENDIF
35033C...H+/- + H0
35034 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35035 IF(ISUB.EQ.297) THEN
35036 RKF=.5D0*PARU(195)**2
35037 ELSEIF(ISUB.EQ.298) THEN
35038 RKF=.5D0*(1D0-PARU(195)**2)
35039 ENDIF
35040 ISUB=210
35041C...A0 + H0
35042 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35043 IF(ISUB.EQ.299) THEN
35044 RKF=PARU(186)**2
35045 KFID=25
35046 ELSEIF(ISUB.EQ.300) THEN
35047 RKF=PARU(187)**2
35048 KFID=35
35049 ENDIF
35050 ISUB=213
35051C...H+ + H-
35052 ELSEIF(ISUB.EQ.301) THEN
35053 KFID=37
35054 RKF=1D0
35055 ISUB=201
35056 ENDIF
35057
35058C...Supersymmetric processes - all of type 2 -> 2 :
35059C...correct final-state Breit-Wigners from fixed to running width.
35060 IF(MSTP(42).GT.0) THEN
35061 DO 100 I=1,2
35062 KFLW=KFPR(ISUBSV,I)
35063 KCW=PYCOMP(KFLW)
35064 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35065 IF(I.EQ.1) SQMI=SQM3
35066 IF(I.EQ.2) SQMI=SQM4
35067 SQMS=PMAS(KCW,1)**2
35068 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35069 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35070 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35071 GMMI=SQRT(SQMI)*WDTP(0)
35072 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35073 COMFAC=COMFAC*(HBWI/HBWS)
35074 100 CONTINUE
35075 ENDIF
35076
35077C...Differential cross section expressions.
35078
35079 IF(ISUB.LE.210) THEN
35080 IF(ISUB.EQ.201) THEN
35081C...f + fbar -> e_L + e_Lbar
35082 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35083 DO 130 I=MMIN1,MMAX1
35084 IA=IABS(I)
35085 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35086 EI=KCHG(IA,1)/3D0
35087 TT3I=SIGN(1D0,EI+1D-6)/2D0
35088 EJ=-1D0
35089 TT3J=-1D0/2D0
35090 FCOL=1D0
35091C...Color factor for e+ e-
35092 IF(IA.GE.11) FCOL=3D0
35093 IF(ISUBSV.EQ.301) THEN
35094 A1=1D0
35095 A2=0D0
35096 ELSEIF(ILR.EQ.1) THEN
35097 A1=SFMIX(KFID,3)**2
35098 A2=SFMIX(KFID,4)**2
35099 ELSEIF(ILR.EQ.0) THEN
35100 A1=SFMIX(KFID,1)**2
35101 A2=SFMIX(KFID,2)**2
35102 ENDIF
35103 XLQ=(TT3J-EJ*XW)*A1
35104 XRQ=(-EJ*XW)*A2
35105 XLF=(TT3I-EI*XW)
35106 XRF=(-EI*XW)
35107 TAA=(EI*EJ)**2*(POLL+POLR)
35108 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35109 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35110 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35111 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35112 TNN=0.0D0
35113 TAN=0.0D0
35114 TZN=0.0D0
35115 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35116 FAC2=SQRT(2D0)
35117 TNN1=0D0
35118 TNN2=0D0
35119 TNN3=0D0
35120 DO 120 II=1,4
35121 DK=1D0/(TH-SMZ(II)**2)
35122 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35123 & ZMIX(II,1))
35124 FREK=FAC2*TANW*EI*ZMIX(II,1)
35125 TNN1=TNN1+FLEK**2*DK
35126 TNN2=TNN2+FREK**2*DK
35127 DO 110 JJ=1,4
35128 DL=1D0/(TH-SMZ(JJ)**2)
35129 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35130 & ZMIX(JJ,1))
35131 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35132 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35133 110 CONTINUE
35134 120 CONTINUE
35135 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35136 & A2**2*TNN2**2*POLR)
35137 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35138 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35139 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35140 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35141 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35142 & (1D0-SQMZ/SH)/SH
35143 TZN=TZN/XW**2/XW1
35144 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35145 & A2*TNN2*POLR)/XW
35146 ENDIF
35147 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35148 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35149 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35150 NCHN=NCHN+1
35151 ISIG(NCHN,1)=I
35152 ISIG(NCHN,2)=-I
35153 ISIG(NCHN,3)=1
35154 SIGH(NCHN)=FACQQ1+FACQQ2
35155 130 CONTINUE
35156
35157 ELSEIF(ISUB.EQ.203) THEN
35158C...f + fbar -> e_L + e_Rbar
35159 DO 160 I=MMIN1,MMAX1
35160 IA=IABS(I)
35161 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35162 EI=KCHG(IABS(I),1)/3D0
35163 TT3I=SIGN(1D0,EI)/2D0
35164 EJ=-1
35165 TT3J=-1D0/2D0
35166 FCOL=1D0
35167C...Color factor for e+ e-
35168 IF(IA.GE.11) FCOL=3D0
35169 A1=SFMIX(KFID,1)**2
35170 A2=SFMIX(KFID,2)**2
35171 XLQ=(TT3J-EJ*XW)
35172 XRQ=(-EJ*XW)
35173 XLF=(TT3I-EI*XW)
35174 XRF=(-EI*XW)
35175 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35176 & /XW**2/XW1**2*A1*A2
35177 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35178 TNN=0.0D0
35179 TZN=0.0D0
35180 TNNA=0D0
35181 TNNB=0D0
35182 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35183 FAC2=SQRT(2D0)
35184 TNN1=0D0
35185 TNN2=0D0
35186 TNN3=0D0
35187 DO 150 II=1,4
35188 DK=1D0/(TH-SMZ(II)**2)
35189 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35190 & ZMIX(II,1))
35191 FREK=FAC2*TANW*EI*ZMIX(II,1)
35192 TNN1=TNN1+FLEK**2*DK
35193 TNN2=TNN2+FREK**2*DK
35194 DO 140 JJ=1,4
35195 DL=1D0/(TH-SMZ(JJ)**2)
35196 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35197 & ZMIX(JJ,1))
35198 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35199 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35200 140 CONTINUE
35201 150 CONTINUE
35202 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35203 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35204 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35205 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35206 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35207 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35208 & (1D0-SQMZ/SH)/SH
35209 ENDIF
35210 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35211 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35212 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35213C%%%%%%%%%%%
35214 NCHN=NCHN+1
35215 ISIG(NCHN,1)=I
35216 ISIG(NCHN,2)=-I
35217 ISIG(NCHN,3)=1
35218 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35219 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35220 NCHN=NCHN+1
35221 ISIG(NCHN,1)=I
35222 ISIG(NCHN,2)=-I
35223 ISIG(NCHN,3)=2
35224 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35225 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35226 160 CONTINUE
35227
35228 ELSEIF(ISUB.EQ.210) THEN
35229C...q + qbar' -> W*- > ~l_L + ~nu_L
35230 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35231 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35232 DO 180 I=MMIN1,MMAX1
35233 IA=IABS(I)
35234 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35235 DO 170 J=MMIN2,MMAX2
35236 JA=IABS(J)
35237 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35238 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35239 FCKM=3D0
35240 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35241 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35242 KCHW=2
35243 IF(KCHSUM.LT.0) KCHW=3
35244 NCHN=NCHN+1
35245 ISIG(NCHN,1)=I
35246 ISIG(NCHN,2)=J
35247 ISIG(NCHN,3)=1
35248 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35249 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35250 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35251 ELSE
35252 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35253 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35254 ENDIF
35255 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35256 170 CONTINUE
35257 180 CONTINUE
35258 ENDIF
35259
35260 ELSEIF(ISUB.LE.220) THEN
35261 IF(ISUB.EQ.213) THEN
35262C...f + fbar -> ~nu_L + ~nu_Lbar
35263 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35264 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35265 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35266 ELSE
35267 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35268 ENDIF
35269 COMFAC=COMFAC*FACR
35270 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35271 XLL=0.5D0
35272 XLR=0.0D0
35273 DO 190 I=MMIN1,MMAX1
35274 IA=IABS(I)
35275 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35276 EI=KCHG(IA,1)/3D0
35277 FCOL=1D0
35278C...Color factor for e+ e-
35279 IF(IA.GE.11) FCOL=3D0
35280 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35281 XRQ=-EI*XW
35282 TZC=0.0D0
35283 TCC=0.0D0
35284 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35285 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35286 & (TH-SMW(2)**2)
35287 TCC=TZC**2
35288 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35289 ENDIF
35290 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35291 FACQQ2=TZC+TCC/4D0
35292 NCHN=NCHN+1
35293 ISIG(NCHN,1)=I
35294 ISIG(NCHN,2)=-I
35295 ISIG(NCHN,3)=1
35296 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35297 & *AEM**2*FCOL/3D0/XW**2
35298 190 CONTINUE
35299
35300 ELSEIF(ISUB.EQ.216) THEN
35301C...q + qbar -> ~chi0_1 + ~chi0_1
35302 IF(IZID1.EQ.IZID2) THEN
35303 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35304 ELSE
35305 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35306 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35307 ENDIF
35308 FACXX=COMFAC*AEM**2/3D0/XW**2
35309 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35310 ZM12=SQM3
35311 ZM22=SQM4
35312 WU2 = (UH-ZM12)*(UH-ZM22)
35313 WT2 = (TH-ZM12)*(TH-ZM22)
35314 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35315 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35316 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35317 DO 200 I=1,4
35318 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35319 IF(IZID2.NE.IZID1) THEN
35320 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35321 ENDIF
35322 200 CONTINUE
35323 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35324 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35325 ORPP=DCONJG(OLPP)
35326 DO 210 I=MMINA,MMAXA
35327 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35328 EI=KCHG(IABS(I),1)/3D0
35329 T3I=SIGN(1D0,EI+1D-6)/2D0
35330 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
35331 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
35332 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
35333 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
35334 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
35335 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
35336 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
35337 & /DCMPLX(TH-XML2)
35338 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
35339 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
35340 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
35341 FCOL=1D0
35342 IF(IABS(I).GE.11) FCOL=3D0
35343 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35344 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35345 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35346 & QRL*DCONJG(QRR)*POLR)*WS2
35347 NCHN=NCHN+1
35348 ISIG(NCHN,1)=I
35349 ISIG(NCHN,2)=-I
35350 ISIG(NCHN,3)=1
35351 SIGH(NCHN)=FACXX*FACGG1*FCOL
35352 210 CONTINUE
35353 ENDIF
35354
35355 ELSEIF(ISUB.LE.230) THEN
35356 IF(ISUB.EQ.226) THEN
35357C...f + fbar -> ~chi+_1 + ~chi-_1
35358 FACXX=COMFAC*AEM**2/3D0
35359 ZM12=SQM3
35360 ZM22=SQM4
35361 WU2 = (UH-ZM12)*(UH-ZM22)
35362 WT2 = (TH-ZM12)*(TH-ZM22)
35363 WS2 = SMW(IZID1)*SMW(IZID2)*SH
35364 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35365 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35366 DIFF=0D0
35367 IF(IZID1.EQ.IZID2) DIFF=1D0
35368 DO 220 I=1,2
35369 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35370 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35371 IF(IZID2.NE.IZID1) THEN
35372 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
35373 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
35374 ENDIF
35375 220 CONTINUE
35376 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
35377 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
35378 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
35379 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
35380 DO 230 I=MMINA,MMAXA
35381 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
35382 EI=KCHG(IABS(I),1)/3D0
35383 T3I=SIGN(1D0,EI+1D-6)/2D0
35384 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
35385 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
35386 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
35387 IF(MOD(I,2).EQ.0) THEN
35388 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
35389 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35390 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
35391 & DCMPLX(T3I/XW/(TH-XML2))
35392 ELSE
35393 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
35394 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35395 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
35396 & DCMPLX(T3I/XW/(TH-XML2))
35397 ENDIF
35398 FCOL=1D0
35399 IF(IABS(I).GE.11) FCOL=3D0
35400 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35401 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35402 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35403 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
35404 NCHN=NCHN+1
35405 ISIG(NCHN,1)=I
35406 ISIG(NCHN,2)=-I
35407 ISIG(NCHN,3)=1
35408 IF(IZID1.EQ.IZID2) THEN
35409 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35410 ELSE
35411 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35412 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35413 NCHN=NCHN+1
35414 ISIG(NCHN,1)=I
35415 ISIG(NCHN,2)=-I
35416 ISIG(NCHN,3)=2
35417 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35418 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35419 ENDIF
35420 230 CONTINUE
35421
35422 ELSEIF(ISUB.EQ.229) THEN
35423C...q + qbar' -> ~chi0_1 + ~chi+-_1
35424 FACXX=COMFAC*AEM**2/6D0/XW**2
35425 ZM12=SQM3
35426 ZM22=SQM4
35427 WU2 = (UH-ZM12)*(UH-ZM22)
35428 WT2 = (TH-ZM12)*(TH-ZM22)
35429 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
35430 RT2I = 1D0/SQRT(2D0)
35431 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
35432 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
35433 DO 240 I=1,2
35434 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35435 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35436 240 CONTINUE
35437 DO 250 I=1,4
35438 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35439 250 CONTINUE
35440 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
35441 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
35442 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
35443 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
35444
35445 DO 270 I=MMIN1,MMAX1
35446 IA=IABS(I)
35447 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
35448 EI=KCHG(IA,1)/3D0
35449 T3I=SIGN(1D0,EI+1D-6)/2D0
35450 DO 260 J=MMIN2,MMAX2
35451 JA=IABS(J)
35452 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
35453 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
35454 EJ=KCHG(JA,1)/3D0
35455 T3J=SIGN(1D0,EJ+1D-6)/2D0
35456 FCKM=3D0
35457 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35458 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35459 KCHW=2
35460 IF(KCHSUM.LT.0) KCHW=3
35461 IF(MOD(IA,2).EQ.0) THEN
35462 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35463 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35464 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
35465 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
35466 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35467 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
35468 & /DCMPLX(TH-ZMJ2)
35469 ELSE
35470 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35471 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35472 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
35473 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
35474 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35475 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
35476 & /DCMPLX(TH-ZMI2)
35477 ENDIF
35478 ZINTR=DBLE(QLR*DCONJG(QLL))
35479 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
35480 & 2D0*ZINTR*WS2)
35481 NCHN=NCHN+1
35482 ISIG(NCHN,1)=I
35483 ISIG(NCHN,2)=J
35484 ISIG(NCHN,3)=1
35485 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35486 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35487 260 CONTINUE
35488 270 CONTINUE
35489 ENDIF
35490
35491 ELSEIF(ISUB.LE.240) THEN
35492 IF(ISUB.EQ.237) THEN
35493C...q + qbar -> gluino + ~chi0_1
35494 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35495 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35496 ASYUK=RMSS(42)*AS
35497 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
35498 GM2=SQM3
35499 ZM2=SQM4
35500 DO 280 I=MMINA,MMAXA
35501 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
35502 EI=KCHG(IABS(I),1)/3D0
35503 IA=IABS(I)
35504 XLQC = -TANW*EI*ZMIX(IZID,1)
35505 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35506 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35507 XLQ2=XLQC**2
35508 XRQ2=XRQC**2
35509 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
35510 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
35511 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
35512 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
35513 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
35514 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35515 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
35516 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
35517 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
35518 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35519 NCHN=NCHN+1
35520 ISIG(NCHN,1)=I
35521 ISIG(NCHN,2)=-I
35522 ISIG(NCHN,3)=1
35523 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
35524 280 CONTINUE
35525 ENDIF
35526
35527 ELSEIF(ISUB.LE.250) THEN
35528 IF(ISUB.EQ.241) THEN
35529C...q + qbar' -> ~chi+-_1 + gluino
35530 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
35531 GM2=SQM3
35532 ZM2=SQM4
35533 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
35534 FAC0=UMIX(IZID,1)**2
35535 FAC1=VMIX(IZID,1)**2
35536 DO 300 I=MMIN1,MMAX1
35537 IA=IABS(I)
35538 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
35539 DO 290 J=MMIN2,MMAX2
35540 JA=IABS(J)
35541 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
35542 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
35543 FCKM=1D0
35544 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35545 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35546 KCHW=2
35547 IF(KCHSUM.LT.0) KCHW=3
35548 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
35549 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
35550 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
35551 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
35552 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
35553 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
35554 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
35555 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
35556 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
35557 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
35558 & SH/(TH-XMU2)/(UH-XMD2))/2D0
35559 NCHN=NCHN+1
35560 ISIG(NCHN,1)=I
35561 ISIG(NCHN,2)=J
35562 ISIG(NCHN,3)=1
35563 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
35564 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35565 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35566 290 CONTINUE
35567 300 CONTINUE
35568
35569 ELSEIF(ISUB.EQ.243) THEN
35570C...q + qbar -> gluino + gluino
35571 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35572 XMT=SQM3-TH
35573 XMU=SQM3-UH
35574 DO 310 I=MMINA,MMAXA
35575 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35576 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
35577 NCHN=NCHN+1
35578 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
35579 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
35580 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35581 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35582 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35583 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35584 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
35585 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
35586 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35587 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35588 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35589 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35590 ISIG(NCHN,1)=I
35591 ISIG(NCHN,2)=-I
35592 ISIG(NCHN,3)=1
35593C...1/2 for identical particles
35594 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
35595 310 CONTINUE
35596
35597 ELSEIF(ISUB.EQ.244) THEN
35598C...g + g -> gluino + gluino
35599 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35600 XMT=SQM3-TH
35601 XMU=SQM3-UH
35602 FACQQ1=COMFAC*AS**2*9D0/4D0*(
35603 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
35604 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
35605 FACQQ2=COMFAC*AS**2*9D0/4D0*(
35606 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
35607 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
35608 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
35609 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
35610 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
35611 NCHN=NCHN+1
35612 ISIG(NCHN,1)=21
35613 ISIG(NCHN,2)=21
35614 ISIG(NCHN,3)=1
35615 SIGH(NCHN)=FACQQ1/2D0
35616 NCHN=NCHN+1
35617 ISIG(NCHN,1)=21
35618 ISIG(NCHN,2)=21
35619 ISIG(NCHN,3)=2
35620 SIGH(NCHN)=FACQQ2/2D0
35621 NCHN=NCHN+1
35622 ISIG(NCHN,1)=21
35623 ISIG(NCHN,2)=21
35624 ISIG(NCHN,3)=3
35625 SIGH(NCHN)=FACQQ3/2D0
35626 320 CONTINUE
35627
35628 ELSEIF(ISUB.EQ.246) THEN
35629C...g + q_j -> ~chi0_1 + ~q_j
35630 FAC0=COMFAC*AS*AEM/6D0/XW
35631 ZM2=SQM4
35632 QM2=SQM3
35633 FACZQ0=FAC0*( (ZM2-TH)/SH +
35634 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35635 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35636 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35637 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
35638 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
35639 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
35640 EI=KCHG(IABS(I),1)/3D0
35641 IA=IABS(I)
35642 XRQZ = -TANW*EI*ZMIX(IZID,1)
35643 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35644 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35645 IF(ILR.EQ.0) THEN
35646 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
35647 ELSE
35648 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
35649 ENDIF
35650 FACZQ=FACZQ0*BS
35651 KCHQ=2
35652 IF(I.LT.0) KCHQ=3
35653 DO 330 ISDE=1,2
35654 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
35655 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
35656 NCHN=NCHN+1
35657 ISIG(NCHN,ISDE)=I
35658 ISIG(NCHN,3-ISDE)=21
35659 ISIG(NCHN,3)=1
35660 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35661 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35662 330 CONTINUE
35663 340 CONTINUE
35664 ENDIF
35665
35666 ELSEIF(ISUB.LE.260) THEN
35667 IF(ISUB.EQ.254) THEN
35668C...g + q_j -> ~chi1_1 + ~q_i
35669 FAC0=COMFAC*AS*AEM/12D0/XW
35670 ZM2=SQM4
35671 QM2=SQM3
35672 AU=UMIX(IZID,1)**2
35673 AD=VMIX(IZID,1)**2
35674 FACZQ0=FAC0*( (ZM2-TH)/SH +
35675 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35676 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35677 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
35678 IF(MOD(KFNSQ1,2).EQ.0) THEN
35679 KFNSQ=KFNSQ1-1
35680 KCHW=2
35681 ELSE
35682 KFNSQ=KFNSQ1+1
35683 KCHW=3
35684 ENDIF
35685 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
35686 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
35687 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
35688 IA=IABS(I)
35689 IF(MOD(IA,2).EQ.0) THEN
35690 FACZQ=FACZQ0*AU
35691 ELSE
35692 FACZQ=FACZQ0*AD
35693 ENDIF
35694 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
35695 KCHQ=2
35696 IF(I.LT.0) KCHQ=3
35697 KCHWQ=KCHW
35698 IF(I.LT.0) KCHWQ=5-KCHW
35699 DO 350 ISDE=1,2
35700 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
35701 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
35702 NCHN=NCHN+1
35703 ISIG(NCHN,ISDE)=I
35704 ISIG(NCHN,3-ISDE)=21
35705 ISIG(NCHN,3)=1
35706 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35707 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
35708 350 CONTINUE
35709 360 CONTINUE
35710
35711 ELSEIF(ISUB.EQ.258) THEN
35712C...g + q_j -> gluino + ~q_i
35713 XG2=SQM4
35714 XQ2=SQM3
35715 XMT=XG2-TH
35716 XMU=XG2-UH
35717 XST=XQ2-TH
35718 XSU=XQ2-UH
35719 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
35720 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
35721 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
35722 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
35723 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
35724 & (SH*(UH+XG2)
35725 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
35726 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
35727 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
35728 ASYUK=RMSS(42)*AS
35729 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
35730 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
35731 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35732 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
35733 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
35734 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
35735 KCHQ=2
35736 IF(I.LT.0) KCHQ=3
35737 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35738 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35739 DO 370 ISDE=1,2
35740 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
35741 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
35742 NCHN=NCHN+1
35743 ISIG(NCHN,ISDE)=I
35744 ISIG(NCHN,3-ISDE)=21
35745 ISIG(NCHN,3)=1
35746 SIGH(NCHN)=FACQG1*FACSEL
35747 NCHN=NCHN+1
35748 ISIG(NCHN,ISDE)=I
35749 ISIG(NCHN,3-ISDE)=21
35750 ISIG(NCHN,3)=2
35751 SIGH(NCHN)=FACQG2*FACSEL
35752 370 CONTINUE
35753 380 CONTINUE
35754 ENDIF
35755
35756 ELSEIF(ISUB.LE.270) THEN
35757 IF(ISUB.EQ.261) THEN
35758C...q_i + q_ibar -> ~t_1 + ~t_1bar
35759 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
35760 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35761 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35762 FAC0=AS**2*4D0/9D0
35763 DO 390 I=MMIN1,MMAX1
35764 IA=IABS(I)
35765 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
35766 IF(IA.GE.11.AND.IA.LE.18) THEN
35767 EI=KCHG(IA,1)/3D0
35768 EJ=KCHG(KFNSQ,1)/3D0
35769 T3I=SIGN(1D0,EI)/2D0
35770 T3J=SIGN(1D0,EJ)/2D0
35771 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
35772 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
35773 XLF=2D0*(T3I-EI*XW)
35774 XRF=2D0*(-EI*XW)
35775 TAA=0.5D0*(EI*EJ)**2
35776 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35777 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35778 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35779 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35780 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35781 ENDIF
35782 NCHN=NCHN+1
35783 ISIG(NCHN,1)=I
35784 ISIG(NCHN,2)=-I
35785 ISIG(NCHN,3)=1
35786 SIGH(NCHN)=FACQQ1*FAC0
35787 390 CONTINUE
35788
35789 ELSEIF(ISUB.EQ.263) THEN
35790C...f + fbar -> ~t1 + ~t2bar
35791 DO 400 I=MMIN1,MMAX1
35792 IA=IABS(I)
35793 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
35794 EI=KCHG(IABS(I),1)/3D0
35795 TT3I=SIGN(1D0,EI)/2D0
35796 EJ=2D0/3D0
35797 TT3J=1D0/2D0
35798 FCOL=1D0
35799C...Color factor for e+ e-
35800 IF(IA.GE.11) FCOL=3D0
35801 XLQ=2D0*(TT3J-EJ*XW)
35802 XRQ=2D0*(-EJ*XW)
35803 XLF=2D0*(TT3I-EI*XW)
35804 XRF=2D0*(-EI*XW)
35805 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
35806 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
35807 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35808C...Factor of 2 for t1 t2bar + t2 t1bar
35809 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
35810 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
35811 NCHN=NCHN+1
35812 ISIG(NCHN,1)=I
35813 ISIG(NCHN,2)=-I
35814 ISIG(NCHN,3)=1
35815 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35816 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35817 NCHN=NCHN+1
35818 ISIG(NCHN,1)=I
35819 ISIG(NCHN,2)=-I
35820 ISIG(NCHN,3)=2
35821 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35822 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35823 400 CONTINUE
35824
35825 ELSEIF(ISUB.EQ.264) THEN
35826C...g + g -> ~t_1 + ~t_1bar
35827 XSU=SQM3-UH
35828 XST=SQM3-TH
35829 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
35830 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35831 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35832 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35833 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
35834 NCHN=NCHN+1
35835 ISIG(NCHN,1)=21
35836 ISIG(NCHN,2)=21
35837 ISIG(NCHN,3)=1
35838 SIGH(NCHN)=FACQQ1
35839 NCHN=NCHN+1
35840 ISIG(NCHN,1)=21
35841 ISIG(NCHN,2)=21
35842 ISIG(NCHN,3)=2
35843 SIGH(NCHN)=FACQQ2
35844 410 CONTINUE
35845 ENDIF
35846
35847 ELSEIF(ISUB.LE.280) THEN
35848 IF(ISUB.EQ.271) THEN
35849C...q + q' -> ~q + ~q' (~g exchange)
35850 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35851 XMT=XMG2-TH
35852 XMU=XMG2-UH
35853 XSU1=SQM3-UH
35854 XSU2=SQM4-UH
35855 XST1=SQM3-TH
35856 XST2=SQM4-TH
35857 ASYUK=RMSS(42)*AS
35858 IF(ILR.EQ.1) THEN
35859 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
35860 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
35861 FACQQB=0.0D0
35862 ELSE
35863 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
35864 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
35865 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
35866 & XMT/XMU )
35867 ENDIF
35868 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35869 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35870 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
35871 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
35872 IA=IABS(I)
35873 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35874 KCHQ=2
35875 IF(I.LT.0) KCHQ=3
35876 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35877 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35878 JA=IABS(J)
35879 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35880 IF(I*J.LT.0) GOTO 420
35881 NCHN=NCHN+1
35882 ISIG(NCHN,1)=I
35883 ISIG(NCHN,2)=J
35884 ISIG(NCHN,3)=1
35885 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35886 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35887 IF(I.EQ.J) THEN
35888 IF(ILR.EQ.0) THEN
35889 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35890 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35891 ELSE
35892 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35893 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35894 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35895 ENDIF
35896 NCHN=NCHN+1
35897 ISIG(NCHN,1)=I
35898 ISIG(NCHN,2)=J
35899 ISIG(NCHN,3)=2
35900 IF(ILR.EQ.0) THEN
35901 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35902 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35903 ELSE
35904 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35905 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35906 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35907 ENDIF
35908 ENDIF
35909 420 CONTINUE
35910 430 CONTINUE
35911
35912 ELSEIF(ISUB.EQ.274) THEN
35913C...q + qbar' -> ~q + ~qbar'
35914 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35915 XMT=XMG2-TH
35916 XMU=XMG2-UH
35917 IF(ILR.EQ.0) THEN
35918C...Mrenna...Normalization.and.1/XMT
35919 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35920 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35921 FACQQB=COMFAC*AS**2*4D0/9D0*(
35922 & (UH*TH-SQM3*SQM4)/SH2 )
35923 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35924 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35925 FACQQB=FACQQB+FACQQ1+FACQQI
35926 ELSE
35927 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35928 FACQQB=FACQQ1
35929 ENDIF
35930 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35931 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35932 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35933 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35934 IA=IABS(I)
35935 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35936 KCHQ=2
35937 IF(I.LT.0) KCHQ=3
35938 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35939 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35940 JA=IABS(J)
35941 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35942 IF(I*J.GT.0) GOTO 440
35943 NCHN=NCHN+1
35944 ISIG(NCHN,1)=I
35945 ISIG(NCHN,2)=J
35946 ISIG(NCHN,3)=1
35947 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35948 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35949 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35950 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35951 440 CONTINUE
35952 450 CONTINUE
35953
35954 ELSEIF(ISUB.EQ.277) THEN
35955C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35956C...if i .eq. j covered in 274
35957 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35958 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35959 FAC0=0D0
35960 DO 460 I=MMIN1,MMAX1
35961 IA=IABS(I)
35962 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35963 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35964 IF(IA.EQ.KFNSQ) GOTO 460
35965 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35966 EI=KCHG(IA,1)/3D0
35967 EJ=KCHG(KFNSQ,1)/3D0
35968 T3J=SIGN(0.5D0,EJ)
35969 T3I=SIGN(1D0,EI)/2D0
35970 IF(ILR.EQ.0) THEN
35971 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35972 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35973 ELSE
35974 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35975 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35976 ENDIF
35977 XLF=2D0*(T3I-EI*XW)
35978 XRF=2D0*(-EI*XW)
35979 IF(ILR.EQ.0) THEN
35980 XRQ=0D0
35981 ELSE
35982 XLQ=0D0
35983 ENDIF
35984 TAA=0.5D0*(EI*EJ)**2
35985 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35986 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35987 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35988 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35989 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35990 ELSEIF(IA.LE.6) THEN
35991 FAC0=AS**2*8D0/9D0/2D0
35992 ENDIF
35993 NCHN=NCHN+1
35994 ISIG(NCHN,1)=I
35995 ISIG(NCHN,2)=-I
35996 ISIG(NCHN,3)=1
35997 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35998 460 CONTINUE
35999
36000 ELSEIF(ISUB.EQ.279) THEN
36001C...g + g -> ~q_j + ~q_jbar
36002 XSU=SQM3-UH
36003 XST=SQM3-TH
36004C...5=RKF because ~t ~tbar treated separately
36005 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36006 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36007 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36008 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36009 NCHN=NCHN+1
36010 ISIG(NCHN,1)=21
36011 ISIG(NCHN,2)=21
36012 ISIG(NCHN,3)=1
36013 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36014 NCHN=NCHN+1
36015 ISIG(NCHN,1)=21
36016 ISIG(NCHN,2)=21
36017 ISIG(NCHN,3)=2
36018 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36019 470 CONTINUE
36020
36021 ENDIF
36022 ENDIF
36023CMRENNA--
36024
36025 RETURN
36026 END
36027
36028C*********************************************************************
36029
36030C...PYSGTC
36031C...Subprocess cross sections for Technicolor processes.
36032C...Auxiliary to PYSIGH.
36033
36034 SUBROUTINE PYSGTC(NCHN,SIGS)
36035
36036C...Double precision and integer declarations
36037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36038 IMPLICIT INTEGER(I-N)
36039 INTEGER PYK,PYCHGE,PYCOMP
36040C...Parameter statement to help give large particle numbers.
36041 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36042 &KEXCIT=4000000,KDIMEN=5000000)
36043C...Commonblocks
36044 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36045 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36046 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36047 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36048 COMMON/PYINT1/MINT(400),VINT(400)
36049 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36050 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36051 COMMON/PYINT4/MWID(500),WIDS(500,5)
36052 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36053 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36054 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36055 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36056 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36057 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36058 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36059C...Local arrays and complex variables
36060 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36061 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36062 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36063 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36064 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36065 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36066 COMPLEX*16 DVVS,DVVT,DVVU
36067 INTEGER INDX(6)
36068
36069C...Combinations of weak mixing angle.
36070 TANW=SQRT(XW/XW1)
36071 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36072
36073C...Convert almost equivalent technicolor processes into
36074C...a few basic processes, and set distinguishing parameters.
36075 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36076 SQTV=RTCM(12)**2
36077 SQTA=RTCM(13)**2
36078 SN2W=2D0*SQRT(XW*XW1)
36079 CS2W=1D0-2D0*XW
36080 CT2W=CS2W/SN2W
36081 CSXI=COS(ASIN(RTCM(3)))
36082 CSXIP=COS(ASIN(RTCM(4)))
36083 QUPD=2D0*RTCM(2)-1D0
36084 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36085 CAB2=0D0
36086 VOGP=0D0
36087 VRGP=0D0
36088 AOGP=0D0
36089 ARGP=0D0
36090 VXGP=0D0
36091 AXGP=0D0
36092 VAGP=0D0
36093 VZGP=0D0
36094 VWGP=0D0
36095C... rho_tc0, etc. -> W_L W_L, W_L W_T
36096 IF(ISUB.EQ.361) THEN
36097 KFA=24
36098 KFB=24
36099 CAB2=RTCM(3)**4
36100 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36101 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36102 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36103C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36104 AXGP = SQRT(2D0)*AXGP
36105 ARGP = SQRT(2D0)*ARGP
36106 VOGP = SQRT(2D0)*VOGP
36107C... rho_tc0 -> W_L pi_tc-
36108 ELSEIF(ISUB.EQ.362) THEN
36109 KFA=24
36110 KFB=KTECHN+211
36111 ISUB=361
36112 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36113C... pi_tc pi_tc
36114 ELSEIF(ISUB.EQ.363) THEN
36115 KFA=KTECHN+211
36116 KFB=KTECHN+211
36117 ISUB=361
36118 CAB2=(1D0-RTCM(3)**2)**2
36119C... rho_tc0/omega_tc -> gamma pi_tc
36120 ELSEIF(ISUB.EQ.364) THEN
36121 KFA=22
36122 KFB=KTECHN+111
36123 ISUB=361
36124 VOGP=CSXI/RTCM(12)
36125 VRGP=VOGP*QUPD
36126 VAGP=2D0*QUPD*CSXI
36127 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36128C... gamma pi_tc'
36129 ELSEIF(ISUB.EQ.365) THEN
36130 KFA=22
36131 KFB=KTECHN+221
36132 ISUB=361
36133 VRGP=CSXIP/RTCM(12)
36134 VOGP=VRGP*QUPD
36135 VAGP=2D0*Q2UD*CSXIP
36136 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36137C... Z pi_tc
36138 ELSEIF(ISUB.EQ.366) THEN
36139 KFA=23
36140 KFB=KTECHN+111
36141 ISUB=361
36142 VOGP=CSXI*CT2W/RTCM(12)
36143 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36144 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36145 VZGP=-QUPD*CSXI*CS2W/XW1
36146C... Z pi_tc'
36147 ELSEIF(ISUB.EQ.367) THEN
36148 KFA=23
36149 KFB=KTECHN+221
36150 ISUB=361
36151C...RTCM(48) is the M_V for the techni-a
36152 VXGP=-CSXIP/SN2W/RTCM(48)
36153 VRGP=CSXIP*CT2W/RTCM(12)
36154 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36155 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36156 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36157C... W_T pi_tc
36158 ELSEIF(ISUB.EQ.368) THEN
36159 KFA=24
36160 KFB=KTECHN+211
36161 ISUB=361
36162C...RTCM(49) is the M_A for the techni-a
36163 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36164 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36165 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36166 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36167 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36168C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36169 ELSEIF(ISUB.EQ.370) THEN
36170 KFA=24
36171 KFB=23
36172 CAB2=RTCM(3)**4
36173 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36174 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36175C... W_L pi_tc0
36176 ELSEIF(ISUB.EQ.371) THEN
36177 KFA=24
36178 KFB=KTECHN+111
36179 ISUB=370
36180 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36181C... Z_L pi_tc+
36182 ELSEIF(ISUB.EQ.372) THEN
36183 KFA=KTECHN+211
36184 KFB=23
36185 ISUB=370
36186 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36187C... pi_tc+ pi_tc0
36188 ELSEIF(ISUB.EQ.373) THEN
36189 KFA=KTECHN+211
36190 KFB=KTECHN+111
36191 ISUB=370
36192 CAB2=(1D0-RTCM(3)**2)**2
36193C... gamma pi_tc+
36194 ELSEIF(ISUB.EQ.374) THEN
36195 KFA=KTECHN+211
36196 KFB=22
36197 ISUB=370
36198 VRGP=QUPD*CSXI/RTCM(12)
36199 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36200 AXGP=-CSXI/RTCM(49)
36201C... Z_T pi_tc+
36202 ELSEIF(ISUB.EQ.375) THEN
36203 KFA=KTECHN+211
36204 KFB=23
36205 ISUB=370
36206 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36207 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36208 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36209 AXGP=-CSXI*CT2W/RTCM(49)
36210C... W_T pi_tc0
36211 ELSEIF(ISUB.EQ.376) THEN
36212 KFA=24
36213 KFB=KTECHN+111
36214 ISUB=370
36215 VRGP=0D0
36216 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36217 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36218C... W_T pi_tc0'
36219 ELSEIF(ISUB.EQ.377) THEN
36220 KFA=24
36221 KFB=KTECHN+221
36222 ISUB=370
36223 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36224 VWGP=CSXIP/(2D0*XW)
36225 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36226C... gamma W+
36227 ELSEIF(ISUB.EQ.378) THEN
36228 KFA=24
36229 KFB=22
36230 ISUB=370
36231 VRGP=QUPD*RTCM(3)/RTCM(12)
36232 AXGP=-RTCM(3)/RTCM(49)
36233C... gamma Z
36234 ELSEIF(ISUB.EQ.379) THEN
36235 KFA=23
36236 KFB=22
36237 ISUB=361
36238 VOGP=RTCM(3)/RTCM(12)
36239 VRGP=QUPD*RTCM(3)/RTCM(12)
36240 ELSEIF(ISUB.EQ.380) THEN
36241 KFA=23
36242 KFB=23
36243 ISUB=361
36244 VOGP=RTCM(3)*CT2W/RTCM(12)
36245 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36246 ENDIF
36247 ENDIF
36248
36249C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36250 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36251 IF(ITCM(5).LE.4) THEN
36252 SQDQQS=1D0/SH2
36253 SQDQQT=1D0/TH2
36254 SQDQQU=1D0/UH2
36255 SQDGGS=SQDQQS
36256 SQDGGT=SQDQQT
36257 SQDGGU=SQDQQU
36258 REDGGS=1D0/SH
36259 REDGGT=1D0/TH
36260 REDGGU=1D0/UH
36261 REDGTU=1D0/UH/TH
36262 REDGSU=1D0/SH/UH
36263 REDGST=1D0/SH/TH
36264 REDQST=1D0/SH/TH
36265 REDQTU=1D0/UH/TH
36266 SQDLGS=0D0
36267 SQDLGT=0D0
36268 SQDQTS=SQDQQS
36269 ELSEIF(ITCM(5).EQ.5) THEN
36270 TANT3=RTCM(21)
36271 IF(ITCM(2).EQ.0) THEN
36272 IMDL=1
36273 ELSE
36274 IMDL=2
36275 ENDIF
36276 ALPRHT=2.16D0*(3D0/ITCM(1))
36277 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36278 SINT3=TANT3/SQRT(TANT3**2+1D0)
36279 XIG=SQRT(PYALPS(SH)/ALPRHT)
36280 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36281 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36282 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36283 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36284 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36285 & SINT3**2)*2D0/SIN2T
36286 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36287 & SINT3**2)*2D0/SIN2T
36288
36289 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36290 SM1112=X12*RTCM(28)**2*SIN2T
36291 SM1121=-X21*RTCM(28)**2*SIN2T
36292 SM2212=-SM1112
36293 SM2221=-SM1121
36294 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36295 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36296
36297C.........SH LOOP
36298 ZTC(1,1)=DCMPLX(SH,0D0)
36299 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36300 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36301 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36302 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36303 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36304 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36305 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36306 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36307 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36308 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36309 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36310 ZTC(1,2)=(0D0,0D0)
36311 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36312 ZTC(1,4)=ZTC(1,3)
36313 ZTC(1,5)=ZTC(1,2)
36314 ZTC(1,6)=ZTC(1,2)
36315 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36316 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36317 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36318 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36319 ZTC(3,4)=-SM1122
36320 ZTC(3,5)=-SM1112
36321 ZTC(3,6)=-SM1121
36322 ZTC(4,5)=-SM2212
36323 ZTC(4,6)=-SM2221
36324 ZTC(5,6)=-SM1221
36325
36326 DO 110 I=1,5
36327 DO 100 J=I+1,6
36328 ZTC(J,I)=ZTC(I,J)
36329 100 CONTINUE
36330 110 CONTINUE
36331 CALL PYLDCM(ZTC,6,6,INDX,D)
36332 DO 130 I=1,6
36333 DO 120 J=1,6
36334 YTC(I,J)=(0D0,0D0)
36335 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36336 120 CONTINUE
36337 130 CONTINUE
36338
36339 DO 140 I=1,6
36340 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36341 140 CONTINUE
36342 DGGS=YTC(1,1)
36343 DVVS=YTC(2,2)
36344 DGVS=YTC(1,2)
36345
36346 XIG=SQRT(PYALPS(-TH)/ALPRHT)
36347C.........TH LOOP
36348 ZTC(1,1)=DCMPLX(TH)
36349 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
36350 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
36351 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
36352 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
36353 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
36354 ZTC(1,2)=(0D0,0D0)
36355 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
36356 ZTC(1,4)=ZTC(1,3)
36357 ZTC(1,5)=ZTC(1,2)
36358 ZTC(1,6)=ZTC(1,2)
36359 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
36360 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
36361 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
36362 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
36363 ZTC(3,4)=-SM1122
36364 ZTC(3,5)=-SM1112
36365 ZTC(3,6)=-SM1121
36366 ZTC(4,5)=-SM2212
36367 ZTC(4,6)=-SM2221
36368 ZTC(5,6)=-SM1221
36369 DO 160 I=1,5
36370 DO 150 J=I+1,6
36371 ZTC(J,I)=ZTC(I,J)
36372 150 CONTINUE
36373 160 CONTINUE
36374 CALL PYLDCM(ZTC,6,6,INDX,D)
36375 DO 180 I=1,6
36376 DO 170 J=1,6
36377 YTC(I,J)=(0D0,0D0)
36378 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36379 170 CONTINUE
36380 180 CONTINUE
36381 DO 190 I=1,6
36382 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36383 190 CONTINUE
36384 DGGT=YTC(1,1)
36385 DVVT=YTC(2,2)
36386 DGVT=YTC(1,2)
36387
36388 XIG=SQRT(PYALPS(-UH)/ALPRHT)
36389C.........UH LOOP
36390 ZTC(1,1)=DCMPLX(UH,0D0)
36391 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
36392 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
36393 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
36394 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
36395 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
36396 ZTC(1,2)=(0D0,0D0)
36397 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
36398 ZTC(1,4)=ZTC(1,3)
36399 ZTC(1,5)=ZTC(1,2)
36400 ZTC(1,6)=ZTC(1,2)
36401 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
36402 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
36403 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
36404 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
36405 ZTC(3,4)=-SM1122
36406 ZTC(3,5)=-SM1112
36407 ZTC(3,6)=-SM1121
36408 ZTC(4,5)=-SM2212
36409 ZTC(4,6)=-SM2221
36410 ZTC(5,6)=-SM1221
36411 DO 210 I=1,5
36412 DO 200 J=I+1,6
36413 ZTC(J,I)=ZTC(I,J)
36414 200 CONTINUE
36415 210 CONTINUE
36416 CALL PYLDCM(ZTC,6,6,INDX,D)
36417 DO 230 I=1,6
36418 DO 220 J=1,6
36419 YTC(I,J)=(0D0,0D0)
36420 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36421 220 CONTINUE
36422 230 CONTINUE
36423 DO 240 I=1,6
36424 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36425 240 CONTINUE
36426 DGGU=YTC(1,1)
36427 DVVU=YTC(2,2)
36428 DGVU=YTC(1,2)
36429
36430 IF(IMDL.EQ.1) THEN
36431 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
36432 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
36433 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
36434 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
36435 DQGS=DGGS-DGVS*DCMPLX(TANT3)
36436 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36437 ELSE
36438 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36439 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
36440 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
36441 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36442 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36443 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36444 ENDIF
36445
36446 SQDQTS=ABS(DQTS)**2
36447 SQDQQS=ABS(DQQS)**2
36448 SQDQQT=ABS(DQQT)**2
36449 SQDQQU=ABS(DQQU)**2
36450 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
36451 REDLGS=DBLE(DQGS)
36452 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
36453 REDHGS=DBLE(DTGS)
36454 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
36455
36456 SQDGGS=ABS(DGGS)**2
36457 SQDGGT=ABS(DGGT)**2
36458 SQDGGU=ABS(DGGU)**2
36459 REDGGS=DBLE(DGGS)
36460 REDGGT=DBLE(DGGT)
36461 REDGGU=DBLE(DGGU)
36462 REDGTU=DBLE(DGGU*DCONJG(DGGT))
36463 REDGSU=DBLE(DGGU*DCONJG(DGGS))
36464 REDGST=DBLE(DGGS*DCONJG(DGGT))
36465 REDQST=DBLE(DQQS*DCONJG(DQQT))
36466 REDQTU=DBLE(DQQT*DCONJG(DQQU))
36467 ENDIF
36468 ENDIF
36469
36470
36471C...Differential cross section expressions.
36472
36473 IF(ISUB.LE.190) THEN
36474 IF(ISUB.EQ.149) THEN
36475C...g + g -> eta_tc
36476 KCTC=PYCOMP(KTECHN+331)
36477 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
36478 HS=SHR*WDTP(0)
36479 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
36480 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36481 HP=SH
36482 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
36483 HI=HP*WDTP(3)
36484 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36485 NCHN=NCHN+1
36486 ISIG(NCHN,1)=21
36487 ISIG(NCHN,2)=21
36488 ISIG(NCHN,3)=1
36489 SIGH(NCHN)=HI*FACBW*HF
36490 250 CONTINUE
36491
36492 ELSEIF(ISUB.EQ.165) THEN
36493C...q + qbar -> l+ + l- (including contact term for compositeness)
36494 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36495 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36496 KFF=IABS(KFPR(ISUB,1))
36497 EF=KCHG(KFF,1)/3D0
36498 AF=SIGN(1D0,EF+0.1D0)
36499 VF=AF-4D0*EF*XWV
36500 VALF=VF+AF
36501 VARF=VF-AF
36502 FCOF=1D0
36503 IF(KFF.LE.10) FCOF=3D0
36504 WID2=1D0
36505 IF(KFF.EQ.6) WID2=WIDS(6,1)
36506 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
36507 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36508 DO 260 I=MMINA,MMAXA
36509 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
36510 EI=KCHG(IABS(I),1)/3D0
36511 AI=SIGN(1D0,EI+0.1D0)
36512 VI=AI-4D0*EI*XWV
36513 VALI=VI+AI
36514 VARI=VI-AI
36515 FCOI=1D0
36516 IF(IABS(I).LE.10) FCOI=FACA/3D0
36517 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
36518 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
36519 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
36520 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36521 ELSE
36522 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
36523 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36524 ENDIF
36525 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
36526 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
36527 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
36528 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
36529 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
36530 NCHN=NCHN+1
36531 ISIG(NCHN,1)=I
36532 ISIG(NCHN,2)=-I
36533 ISIG(NCHN,3)=1
36534 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
36535 260 CONTINUE
36536
36537 ELSEIF(ISUB.EQ.166) THEN
36538C...q + q'bar -> l + nu_l (including contact term for compositeness)
36539 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
36540 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
36541 KFF=IABS(KFPR(ISUB,1))
36542 FCOF=1D0
36543 IF(KFF.LE.10) FCOF=3D0
36544 DO 280 I=MMIN1,MMAX1
36545 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
36546 IA=IABS(I)
36547 DO 270 J=MMIN2,MMAX2
36548 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
36549 JA=IABS(J)
36550 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
36551 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36552 & GOTO 270
36553 FCOI=1D0
36554 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36555 WID2=1D0
36556 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
36557 & MOD(J,2).EQ.0)) THEN
36558 IF(KFF.EQ.5) WID2=WIDS(6,2)
36559 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
36560 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
36561 ELSE
36562 IF(KFF.EQ.5) WID2=WIDS(6,3)
36563 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
36564 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
36565 ENDIF
36566 NCHN=NCHN+1
36567 ISIG(NCHN,1)=I
36568 ISIG(NCHN,2)=J
36569 ISIG(NCHN,3)=1
36570 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
36571 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
36572 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
36573 270 CONTINUE
36574 280 CONTINUE
36575 ENDIF
36576
36577 ELSEIF(ISUB.LE.200) THEN
36578 IF(ISUB.EQ.191) THEN
36579C...q + qbar -> rho_tc0.
36580 KCTC=PYCOMP(KTECHN+113)
36581 SQMRHT=PMAS(KCTC,1)**2
36582 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36583 HS=SHR*WDTP(0)
36584 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36585 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36586 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36587 ALPRHT=2.16D0*(3D0/ITCM(1))
36588 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
36589 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
36590 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36591 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36592 DO 290 I=MMINA,MMAXA
36593 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
36594 IA=IABS(I)
36595 EI=KCHG(IABS(I),1)/3D0
36596 AI=SIGN(1D0,EI+0.1D0)
36597 VI=AI-4D0*EI*XWV
36598 VALI=0.5D0*(VI+AI)
36599 VARI=0.5D0*(VI-AI)
36600 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
36601 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
36602 IF(IA.LE.10) HI=HI*FACA/3D0
36603 NCHN=NCHN+1
36604 ISIG(NCHN,1)=I
36605 ISIG(NCHN,2)=-I
36606 ISIG(NCHN,3)=1
36607 SIGH(NCHN)=HI*FACBW*HF
36608 290 CONTINUE
36609
36610 ELSEIF(ISUB.EQ.192) THEN
36611C...q + qbar' -> rho_tc+/-.
36612 KCTC=PYCOMP(KTECHN+213)
36613 SQMRHT=PMAS(KCTC,1)**2
36614 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36615 HS=SHR*WDTP(0)
36616 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36617 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36618 ALPRHT=2.16D0*(3D0/ITCM(1))
36619 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
36620 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
36621 DO 310 I=MMIN1,MMAX1
36622 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
36623 IA=IABS(I)
36624 DO 300 J=MMIN2,MMAX2
36625 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
36626 JA=IABS(J)
36627 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
36628 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36629 & GOTO 300
36630 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36631 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
36632 HI=HP
36633 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36634 NCHN=NCHN+1
36635 ISIG(NCHN,1)=I
36636 ISIG(NCHN,2)=J
36637 ISIG(NCHN,3)=1
36638 SIGH(NCHN)=HI*FACBW*HF
36639 300 CONTINUE
36640 310 CONTINUE
36641
36642 ELSEIF(ISUB.EQ.193) THEN
36643C...q + qbar -> omega_tc0.
36644 KCTC=PYCOMP(KTECHN+223)
36645 SQMOMT=PMAS(KCTC,1)**2
36646 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36647 HS=SHR*WDTP(0)
36648 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
36649 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36650 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36651 ALPRHT=2.16D0*(3D0/ITCM(1))
36652 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
36653 & (2D0*RTCM(2)-1D0)**2
36654 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36655 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36656 DO 320 I=MMINA,MMAXA
36657 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36658 IA=IABS(I)
36659 EI=KCHG(IABS(I),1)/3D0
36660 AI=SIGN(1D0,EI+0.1D0)
36661 VI=AI-4D0*EI*XWV
36662 VALI=0.5D0*(VI+AI)
36663 VARI=0.5D0*(VI-AI)
36664 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
36665 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
36666 IF(IA.LE.10) HI=HI*FACA/3D0
36667 NCHN=NCHN+1
36668 ISIG(NCHN,1)=I
36669 ISIG(NCHN,2)=-I
36670 ISIG(NCHN,3)=1
36671 SIGH(NCHN)=HI*FACBW*HF
36672 320 CONTINUE
36673
36674 ELSEIF(ISUB.EQ.194) THEN
36675C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36676C...Default final state is e+e-
36677 KFA=KFPR(ISUBSV,1)
36678 ALPRHT=2.16D0*(3D0/ITCM(1))
36679 HP=AEM**2*COMFAC
36680
36681 SN2W=2D0*SQRT(XW*XW1)
36682C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36683C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36684
36685 QUPD=2D0*RTCM(2)-1D0
36686 FAR=SQRT(AEM/ALPRHT)
36687 FAO=FAR*QUPD
36688 FZR=FAR*CT2W
36689 FZO=-FAO*TANW
36690C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36691 FZX=-FAR/SN2W*RTCM(47)
36692 SFAR=FAR**2
36693 SFAO=FAO**2
36694 SFZR=FZR**2
36695 SFZO=FZO**2
36696 SFZX=FZX**2
36697 CALL PYWIDT(23,SH,WDTP,WDTE)
36698 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36699 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36700 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36701 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36702 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36703 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36704 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36705C...Propagator including a_T^0
36706 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36707 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36708C...Add in techni-a contribution
36709 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36710 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36711 $ SFZX*SSMR*SSMO)/DETD/SH
36712 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36713 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36714
36715 XWRHT=1D0/(4D0*XW*(1D0-XW))
36716 KFF=IABS(KFPR(ISUB,1))
36717 EF=KCHG(KFF,1)/3D0
36718 AF=SIGN(1D0,EF+0.1D0)
36719 VF=AF-4D0*EF*XWV
36720 VALF=0.5D0*(VF+AF)
36721 VARF=0.5D0*(VF-AF)
36722 FCOF=1D0
36723 IF(KFF.LE.10) FCOF=3D0
36724
36725 WID2=1D0
36726 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
36727 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36728 DZZ=DZZ*DCMPLX(XWRHT,0D0)
36729 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
36730
36731 DO 330 I=MMINA,MMAXA
36732 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
36733 EI=KCHG(IABS(I),1)/3D0
36734 AI=SIGN(1D0,EI+0.1D0)
36735 VI=AI-4D0*EI*XWV
36736 VALI=0.5D0*(VI+AI)
36737 VARI=0.5D0*(VI-AI)
36738 FCOI=FCOF
36739 IF(IABS(I).LE.10) FCOI=FCOI/3D0
36740 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
36741 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
36742 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
36743 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
36744 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
36745 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
36746 NCHN=NCHN+1
36747 ISIG(NCHN,1)=I
36748 ISIG(NCHN,2)=-I
36749 ISIG(NCHN,3)=1
36750 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
36751 330 CONTINUE
36752
36753 ELSEIF(ISUB.EQ.195) THEN
36754C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36755 KFA=KFPR(ISUBSV,1)
36756 KFB=KFA+1
36757 ALPRHT=2.16D0*(3D0/ITCM(1))
36758 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
36759
36760 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36761C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36762C
36763C...Propagator including a_T^+
36764 FWX=-FWR*RTCM(47)
36765 CALL PYWIDT(24,SH,WDTP,WDTE)
36766 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36767 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36768 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36769 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36770 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36771 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36772 & DCMPLX(FWX**2,0D0)*SSMR
36773 DWW=SSMR*SSMX/DETD/SH
36774 FCOF=1D0
36775 IF(KFA.LE.8) FCOF=3D0
36776 HP=FACTC*ABS(DWW)**2*FCOF
36777
36778 DO 350 I=MMIN1,MMAX1
36779 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
36780 IA=IABS(I)
36781 DO 340 J=MMIN2,MMAX2
36782 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
36783 JA=IABS(J)
36784 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
36785 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36786 & GOTO 340
36787 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36788 HI=HP
36789 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36790 NCHN=NCHN+1
36791 ISIG(NCHN,1)=I
36792 ISIG(NCHN,2)=J
36793 ISIG(NCHN,3)=1
36794 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
36795 340 CONTINUE
36796 350 CONTINUE
36797 ENDIF
36798
36799 ELSEIF(ISUB.LE.380) THEN
36800 ALPRHT=2.16D0*(3D0/ITCM(1))
36801 IF(ISUB.EQ.361) THEN
36802 FAR=SQRT(AEM/ALPRHT)
36803 FAO=FAR*QUPD
36804 FZR=FAR*CT2W
36805 FZO=-FAO*TANW
36806C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36807 FZX=-FAR/SN2W*RTCM(47)
36808 SFAR=FAR**2
36809 SFAO=FAO**2
36810 SFZR=FZR**2
36811 SFZO=FZO**2
36812 SFZX=FZX**2
36813 CALL PYWIDT(23,SH,WDTP,WDTE)
36814 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36815 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36816 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36817 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36818 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36819 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36820 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36821 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36822 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36823C...Add in techni-a contribution
36824 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36825 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
36826 $ SFZX*FAR*SSMO)/DETD/SH
36827 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
36828 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
36829 $ SFZX*FAO*SSMR)/DETD/SH
36830 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
36831 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
36832 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
36833 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36834 $ SFZX*SSMR*SSMO)/DETD/SH
36835 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36836 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36837
36838C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36839C...W+W-, W pi_tc, pi_T pi_T, etc.
36840 FACA=(SH**2*BE34**2-(TH-UH)**2)
36841 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36842 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36843 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36844 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
36845 DO 370 I=MMINA,MMAXA
36846 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
36847 IA=IABS(I)
36848 EI=KCHG(IABS(I),1)/3D0
36849 AI=SIGN(1D0,EI+0.1D0)
36850 VI=AI-4D0*EI*XWV
36851 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
36852 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
36853C...........Eqs. (5) and (6) in LSTC-rates.pdf
36854 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
36855 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
36856 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
36857 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
36858 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
36859 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
36860 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
36861 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
36862 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
36863 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
36864 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
36865C...........Eqs. (5) and (7) in LSTC-rates.pdf
36866 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
36867 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
36868 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
36869 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
36870 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
36871 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
36872 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
36873C
36874C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36875C
36876c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36877c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36878c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36879c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36880 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36881 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36882 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36883 HI=HI+HJ+HK
36884 IF(IA.LE.10) HI=HI/3D0
36885 NCHN=NCHN+1
36886 ISIG(NCHN,1)=I
36887 ISIG(NCHN,2)=-I
36888 ISIG(NCHN,3)=1
36889 IF(KFA.EQ.KFB) THEN
36890 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36891 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36892 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36893 NCHN=NCHN+1
36894 ISIG(NCHN,1)=I
36895 ISIG(NCHN,2)=-I
36896 ISIG(NCHN,3)=2
36897 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36898 ELSE
36899 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36900 ENDIF
36901 370 CONTINUE
36902
36903 ELSEIF(ISUB.EQ.370) THEN
36904C...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
36905C...f + fbar' -> gamma pi_tc, etc.
36906 FACA=(SH**2*BE34**2-(TH-UH)**2)
36907 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36908 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36909 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36910 ALPRHT=2.16D0*(3D0/ITCM(1))
36911 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36912 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36913C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36914 FWX=-FWR*RTCM(47)
36915 CALL PYWIDT(24,SH,WDTP,WDTE)
36916 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36917 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36918 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36919 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36920 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36921 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36922 & DCMPLX(FWX**2,0D0)*SSMR
36923 DWW=SSMR*SSMX/DETD/SH
36924 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36925 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36926 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36927 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36928C
36929C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36930C
36931c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36932 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36933C...Add in W_L Z_T axial and vector contributions.
36934 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36935 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36936 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36937 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36938 DO 410 I=MMIN1,MMAX1
36939 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36940 IA=IABS(I)
36941 DO 400 J=MMIN2,MMAX2
36942 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36943 JA=IABS(J)
36944 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36945 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36946 & GOTO 400
36947 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36948 HI=HP
36949 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36950 NCHN=NCHN+1
36951 ISIG(NCHN,1)=I
36952 ISIG(NCHN,2)=J
36953 ISIG(NCHN,3)=1
36954 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36955 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36956 ELSE
36957 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36958 & WIDS(PYCOMP(KFB),2)
36959 ENDIF
36960 400 CONTINUE
36961 410 CONTINUE
36962 ENDIF
36963
36964 ELSEIF(ISUB.LE.390) THEN
36965 IF(ISUB.EQ.381) THEN
36966C...f + f' -> f + f' (g exchange)
36967 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36968 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36969 & MSTP(34)*2D0/3D0*UH2*REDQST)
36970 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36971 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36972 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36973 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36974C...Modifications from contact interactions (compositeness)
36975 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36976 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36977 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36978 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36979 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36980 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36981 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36982 ELSEIF(ITCM(5).EQ.5) THEN
36983 FACCI1=FACQQ1
36984 FACCIB=FACQQB
36985 FACCI2=FACQQ2
36986 FACCI3=FACQQ1
36987CSM.......Check this change from
36988CSM RATCII=1D0
36989 RATCII=RATQQI
36990 ENDIF
36991 DO 430 I=MMIN1,MMAX1
36992 IA=IABS(I)
36993 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36994 DO 420 J=MMIN2,MMAX2
36995 JA=IABS(J)
36996 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36997 NCHN=NCHN+1
36998 ISIG(NCHN,1)=I
36999 ISIG(NCHN,2)=J
37000 ISIG(NCHN,3)=1
37001 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37002 & JA.GE.3))) THEN
37003 SIGH(NCHN)=FACQQ1
37004 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37005 ELSE
37006 SIGH(NCHN)=FACCI1
37007 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37008 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37009 ENDIF
37010 IF(I.EQ.J) THEN
37011 NCHN=NCHN+1
37012 ISIG(NCHN,1)=I
37013 ISIG(NCHN,2)=J
37014 ISIG(NCHN,3)=2
37015 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37016 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37017 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37018 ELSE
37019 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37020 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37021 ENDIF
37022 ENDIF
37023 420 CONTINUE
37024 430 CONTINUE
37025
37026 ELSEIF(ISUB.EQ.382) THEN
37027C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37028 CALL PYWIDT(21,SH,WDTP,WDTE)
37029 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37030 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37031 IF(ITCM(5).EQ.1) THEN
37032C...Modifications from contact interactions (compositeness)
37033 FACCIB=FACQQB
37034 DO 440 I=1,2
37035 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37036 & WDTE(I,2)+WDTE(I,4))
37037 440 CONTINUE
37038 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37039 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37040 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37041 ELSEIF(ITCM(5).EQ.5) THEN
37042 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37043 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37044 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37045 ENDIF
37046 DO 450 I=MMINA,MMAXA
37047 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37048 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37049 NCHN=NCHN+1
37050 ISIG(NCHN,1)=I
37051 ISIG(NCHN,2)=-I
37052 ISIG(NCHN,3)=1
37053 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37054 SIGH(NCHN)=FACQQB
37055 ELSEIF(ITCM(5).EQ.5) THEN
37056 SIGH(NCHN)=FACQQB
37057 NCHN=NCHN+1
37058 ISIG(NCHN,1)=I
37059 ISIG(NCHN,2)=-I
37060 ISIG(NCHN,3)=2
37061 SIGH(NCHN)=FACCIB
37062 ELSE
37063 SIGH(NCHN)=FACCIB
37064 ENDIF
37065 450 CONTINUE
37066
37067 ELSEIF(ISUB.EQ.383) THEN
37068C...f + fbar -> g + g (q + qbar -> g + g only)
37069 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37070 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37071 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37072 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37073 IF(ITCM(5).EQ.5) THEN
37074 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37075 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37076 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37077 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37078 ENDIF
37079 DO 460 I=MMINA,MMAXA
37080 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37081 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37082 NCHN=NCHN+1
37083 ISIG(NCHN,1)=I
37084 ISIG(NCHN,2)=-I
37085 ISIG(NCHN,3)=1
37086 SIGH(NCHN)=0.5D0*FACGG1
37087 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37088 NCHN=NCHN+1
37089 ISIG(NCHN,1)=I
37090 ISIG(NCHN,2)=-I
37091 ISIG(NCHN,3)=2
37092 SIGH(NCHN)=0.5D0*FACGG2
37093 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37094 460 CONTINUE
37095
37096 ELSEIF(ISUB.EQ.384) THEN
37097C...f + g -> f + g (q + g -> q + g only)
37098 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37099 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37100 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37101 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37102 DO 480 I=MMINA,MMAXA
37103 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37104 DO 470 ISDE=1,2
37105 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37106 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37107 NCHN=NCHN+1
37108 ISIG(NCHN,ISDE)=I
37109 ISIG(NCHN,3-ISDE)=21
37110 ISIG(NCHN,3)=1
37111 SIGH(NCHN)=FACQG1
37112 NCHN=NCHN+1
37113 ISIG(NCHN,ISDE)=I
37114 ISIG(NCHN,3-ISDE)=21
37115 ISIG(NCHN,3)=2
37116 SIGH(NCHN)=FACQG2
37117 470 CONTINUE
37118 480 CONTINUE
37119
37120 ELSEIF(ISUB.EQ.385) THEN
37121C...g + g -> f + fbar (g + g -> q + qbar only)
37122 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37123 IDC0=MDCY(21,2)-1
37124C...Begin by d, u, s flavours.
37125 FLAVWT=0D0
37126 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37127 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37128 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37129 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37130 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37131 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37132 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37133 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37134 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37135 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37136 NCHN=NCHN+1
37137 ISIG(NCHN,1)=21
37138 ISIG(NCHN,2)=21
37139 ISIG(NCHN,3)=1
37140 SIGH(NCHN)=FACQQ1
37141 NCHN=NCHN+1
37142 ISIG(NCHN,1)=21
37143 ISIG(NCHN,2)=21
37144 ISIG(NCHN,3)=2
37145 SIGH(NCHN)=FACQQ2
37146C...Next c and b flavours: modified that and uhat for fixed
37147C...cos(theta-hat).
37148 DO 490 IFL=4,5
37149 SQMAVG=PMAS(IFL,1)**2
37150 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37151 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37152 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37153 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37154 THUHQ=THQ*UHQ-SQMAVG*SH
37155 IF(MSTP(34).EQ.0) THEN
37156 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37157 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37158 ELSE
37159 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37160 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37161 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37162 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37163 ENDIF
37164 IF(ITCM(5).GE.5) THEN
37165 IF(IFL.EQ.4) THEN
37166 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37167 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37168 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37169 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37170 ELSE
37171 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37172 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37173 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37174 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37175 ENDIF
37176 ENDIF
37177 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37178 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37179 NCHN=NCHN+1
37180 ISIG(NCHN,1)=21
37181 ISIG(NCHN,2)=21
37182 ISIG(NCHN,3)=1+2*(IFL-3)
37183 SIGH(NCHN)=FACQQ1
37184 NCHN=NCHN+1
37185 ISIG(NCHN,1)=21
37186 ISIG(NCHN,2)=21
37187 ISIG(NCHN,3)=2+2*(IFL-3)
37188 SIGH(NCHN)=FACQQ2
37189 ENDIF
37190 490 CONTINUE
37191 500 CONTINUE
37192
37193 ELSEIF(ISUB.EQ.386) THEN
37194C...g + g -> g + g
37195 IF(ITCM(5).LE.4) THEN
37196 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37197 & 2D0*TH/SH+TH2/SH2)*FACA
37198 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37199 & 2D0*SH/UH+SH2/UH2)*FACA
37200 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37201 & 2D0*UH/TH+UH2/TH2)
37202 ELSE
37203 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37204 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37205 & 4D0*REDGST*(SH + 2D0*TH)*
37206 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37207 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37208 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37209 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37210 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37211 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37212 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37213 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37214 & 4D0*REDGSU*(SH + 2D0*UH)*
37215 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37216 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37217 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37218 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37219 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37220 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37221 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37222 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37223 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37224 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37225 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37226 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37227 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37228 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37229 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37230 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37231 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37232 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37233 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37234 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37235 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37236 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37237 ENDIF
37238 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37239 NCHN=NCHN+1
37240 ISIG(NCHN,1)=21
37241 ISIG(NCHN,2)=21
37242 ISIG(NCHN,3)=1
37243 SIGH(NCHN)=0.5D0*FACGG1
37244 NCHN=NCHN+1
37245 ISIG(NCHN,1)=21
37246 ISIG(NCHN,2)=21
37247 ISIG(NCHN,3)=2
37248 SIGH(NCHN)=0.5D0*FACGG2
37249 NCHN=NCHN+1
37250 ISIG(NCHN,1)=21
37251 ISIG(NCHN,2)=21
37252 ISIG(NCHN,3)=3
37253 SIGH(NCHN)=0.5D0*FACGG3
37254 510 CONTINUE
37255
37256 ELSEIF(ISUB.EQ.387) THEN
37257C...q + qbar -> Q + Qbar
37258 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37259 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37260 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37261 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37262 & 2D0*SQMAVG/SH)
37263 IF(ITCM(5).GE.5) THEN
37264 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37265 FACQQB=FACQQB*SH2*SQDQTS
37266 ELSE
37267 FACQQB=FACQQB*SH2*SQDQQS
37268 ENDIF
37269 ENDIF
37270 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37271 WID2=1D0
37272 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37273 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37274 FACQQB=FACQQB*WID2
37275 DO 520 I=MMINA,MMAXA
37276 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37277 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37278 NCHN=NCHN+1
37279 ISIG(NCHN,1)=I
37280 ISIG(NCHN,2)=-I
37281 ISIG(NCHN,3)=1
37282 SIGH(NCHN)=FACQQB
37283 520 CONTINUE
37284
37285 ELSEIF(ISUB.EQ.388) THEN
37286C...g + g -> Q + Qbar
37287 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37288 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37289 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37290 THUHQ=THQ*UHQ-SQMAVG*SH
37291 IF(MSTP(34).EQ.0) THEN
37292 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37293 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37294 ELSE
37295 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37296 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37297 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37298 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37299 ENDIF
37300 IF(ITCM(5).GE.5) THEN
37301 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37302 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37303 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37304 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37305 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37306 ELSE
37307 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37308 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37309 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37310 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37311 ENDIF
37312 ENDIF
37313 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37314 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37315 IF(MSTP(35).GE.1) THEN
37316 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37317 FACQQ1=FACQQ1*FATRE
37318 FACQQ2=FACQQ2*FATRE
37319 ENDIF
37320 WID2=1D0
37321 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37322 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37323 FACQQ1=FACQQ1*WID2
37324 FACQQ2=FACQQ2*WID2
37325 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37326 NCHN=NCHN+1
37327 ISIG(NCHN,1)=21
37328 ISIG(NCHN,2)=21
37329 ISIG(NCHN,3)=1
37330 SIGH(NCHN)=FACQQ1
37331 NCHN=NCHN+1
37332 ISIG(NCHN,1)=21
37333 ISIG(NCHN,2)=21
37334 ISIG(NCHN,3)=2
37335 SIGH(NCHN)=FACQQ2
37336 530 CONTINUE
37337 ENDIF
37338 ENDIF
37339
37340CMRENNA--
37341
37342 RETURN
37343 END
37344
37345C*********************************************************************
37346
37347C...PYSGEX
37348C...Subprocess cross sections for assorted exotic processes,
37349C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37350C...Auxiliary to PYSIGH.
37351
37352 SUBROUTINE PYSGEX(NCHN,SIGS)
37353
37354C...Double precision and integer declarations
37355 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37356 IMPLICIT INTEGER(I-N)
37357 INTEGER PYK,PYCHGE,PYCOMP
37358C...Parameter statement to help give large particle numbers.
37359 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37360 &KEXCIT=4000000,KDIMEN=5000000)
37361C...Commonblocks
37362 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37363 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37364 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
37365 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37366 COMMON/PYINT1/MINT(400),VINT(400)
37367 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
37368 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
37369 COMMON/PYINT4/MWID(500),WIDS(500,5)
37370 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
37371 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
37372 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
37373 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
37374 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
37375 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
37376 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
37377C...Local arrays
37378 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
37379
37380C...Differential cross section expressions.
37381
37382 IF(ISUB.LE.160) THEN
37383 IF(ISUB.EQ.141) THEN
37384C...f + fbar -> gamma*/Z0/Z'0
37385 SQMZP=PMAS(32,1)**2
37386 MINT(61)=2
37387 CALL PYWIDT(32,SH,WDTP,WDTE)
37388 HP0=AEM/3D0*SH
37389 HP1=AEM/3D0*XWC*SH
37390 HP2=HP1
37391 HS=SHR*VINT(117)
37392 HSP=SHR*WDTP(0)
37393 FACZP=4D0*COMFAC*3D0
37394 DO 100 I=MMINA,MMAXA
37395 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
37396 EI=KCHG(IABS(I),1)/3D0
37397 AI=SIGN(1D0,EI)
37398 VI=AI-4D0*EI*XWV
37399 IA=IABS(I)
37400 IF(IA.LT.10) THEN
37401 IF(IA.LE.2) THEN
37402 VPI=PARU(123-2*MOD(IABS(I),2))
37403 API=PARU(124-2*MOD(IABS(I),2))
37404 ELSEIF(IA.LE.4) THEN
37405 VPI=PARJ(182-2*MOD(IABS(I),2))
37406 API=PARJ(183-2*MOD(IABS(I),2))
37407 ELSE
37408 VPI=PARJ(190-2*MOD(IABS(I),2))
37409 API=PARJ(191-2*MOD(IABS(I),2))
37410 ENDIF
37411 ELSE
37412 IF(IA.LE.12) THEN
37413 VPI=PARU(127-2*MOD(IABS(I),2))
37414 API=PARU(128-2*MOD(IABS(I),2))
37415 ELSEIF(IA.LE.14) THEN
37416 VPI=PARJ(186-2*MOD(IABS(I),2))
37417 API=PARJ(187-2*MOD(IABS(I),2))
37418 ELSE
37419 VPI=PARJ(194-2*MOD(IABS(I),2))
37420 API=PARJ(195-2*MOD(IABS(I),2))
37421 ENDIF
37422 ENDIF
37423 HI0=HP0
37424 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
37425 HI1=HP1
37426 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
37427 HI2=HP2
37428 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
37429 NCHN=NCHN+1
37430 ISIG(NCHN,1)=I
37431 ISIG(NCHN,2)=-I
37432 ISIG(NCHN,3)=1
37433C...Special case: if only branching ratios known then use them.
37434 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
37435 HI=0D0
37436 IF(IA.LT.10) THEN
37437 HI=SHR*WDTP(IA)*FACA/9D0
37438 ELSEIF(IA.LT.20) THEN
37439 HI=SHR*WDTP(IA-2)
37440 ENDIF
37441 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37442 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
37443 ELSE
37444C...Normal cross section.
37445 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
37446 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
37447 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
37448 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
37449 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
37450 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
37451 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
37452 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
37453 ENDIF
37454 100 CONTINUE
37455
37456 ELSEIF(ISUB.EQ.142) THEN
37457C...f + fbar' -> W'+/-
37458 SQMWP=PMAS(34,1)**2
37459 CALL PYWIDT(34,SH,WDTP,WDTE)
37460 HS=SHR*WDTP(0)
37461 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
37462 HP=AEM/(24D0*XW)*SH
37463 DO 120 I=MMIN1,MMAX1
37464 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
37465 IA=IABS(I)
37466 DO 110 J=MMIN2,MMAX2
37467 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
37468 JA=IABS(J)
37469 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
37470 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37471 & GOTO 110
37472 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37473C...Special case: if only branching ratios known then use them.
37474 IF(MWID(34).EQ.2) THEN
37475 HI=0D0
37476 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
37477 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
37478 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
37479 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
37480 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
37481 105 CONTINUE
37482 IF(IA.LT.10) HI=HI*FACA/9D0
37483 ELSE
37484C...Normal cross section.
37485 HI=HP*(PARU(133)**2+PARU(134)**2)
37486 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
37487 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37488 ENDIF
37489 NCHN=NCHN+1
37490 ISIG(NCHN,1)=I
37491 ISIG(NCHN,2)=J
37492 ISIG(NCHN,3)=1
37493 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37494 SIGH(NCHN)=HI*FACBW*HF
37495 110 CONTINUE
37496 120 CONTINUE
37497
37498 ELSEIF(ISUB.EQ.144) THEN
37499C...f + fbar' -> R
37500 SQMR=PMAS(41,1)**2
37501 CALL PYWIDT(41,SH,WDTP,WDTE)
37502 HS=SHR*WDTP(0)
37503 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
37504 HP=AEM/(12D0*XW)*SH
37505 DO 140 I=MMIN1,MMAX1
37506 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
37507 IA=IABS(I)
37508 DO 130 J=MMIN2,MMAX2
37509 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
37510 JA=IABS(J)
37511 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
37512 HI=HP
37513 IF(IA.LE.10) HI=HI*FACA/3D0
37514 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
37515 NCHN=NCHN+1
37516 ISIG(NCHN,1)=I
37517 ISIG(NCHN,2)=J
37518 ISIG(NCHN,3)=1
37519 SIGH(NCHN)=HI*FACBW*HF
37520 130 CONTINUE
37521 140 CONTINUE
37522
37523 ELSEIF(ISUB.EQ.145) THEN
37524C...q + l -> LQ (leptoquark)
37525 SQMLQ=PMAS(42,1)**2
37526 CALL PYWIDT(42,SH,WDTP,WDTE)
37527 HS=SHR*WDTP(0)
37528 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
37529 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
37530 HP=AEM/4D0*SH
37531 KFLQQ=KFDP(MDCY(42,2),1)
37532 KFLQL=KFDP(MDCY(42,2),2)
37533 DO 160 I=MMIN1,MMAX1
37534 IF(KFAC(1,I).EQ.0) GOTO 160
37535 IA=IABS(I)
37536 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
37537 DO 150 J=MMIN2,MMAX2
37538 IF(KFAC(2,J).EQ.0) GOTO 150
37539 JA=IABS(J)
37540 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
37541 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
37542 IF(JA.EQ.IA) GOTO 150
37543 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
37544 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
37545 HI=HP*PARU(151)
37546 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
37547 NCHN=NCHN+1
37548 ISIG(NCHN,1)=I
37549 ISIG(NCHN,2)=J
37550 ISIG(NCHN,3)=1
37551 SIGH(NCHN)=HI*FACBW*HF
37552 150 CONTINUE
37553 160 CONTINUE
37554
37555 ELSEIF(ISUB.EQ.146) THEN
37556C...e + gamma* -> e* (excited lepton)
37557 KFQSTR=KFPR(ISUB,1)
37558 KCQSTR=PYCOMP(KFQSTR)
37559 KFQEXC=MOD(KFQSTR,KEXCIT)
37560 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37561 HS=SHR*WDTP(0)
37562 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37563 QF=-RTCM(43)/2D0-RTCM(44)/2D0
37564 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
37565 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37566 & FACBW=0D0
37567 HP=SH
37568 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
37569 DO 170 ISDE=1,2
37570 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
37571 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
37572 HI=HP
37573 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37574 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37575 NCHN=NCHN+1
37576 ISIG(NCHN,ISDE)=I
37577 ISIG(NCHN,3-ISDE)=22
37578 ISIG(NCHN,3)=1
37579 SIGH(NCHN)=HI*FACBW*HF
37580 170 CONTINUE
37581 180 CONTINUE
37582
37583 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
37584C...d + g -> d* and u + g -> u* (excited quarks)
37585 KFQSTR=KFPR(ISUB,1)
37586 KCQSTR=PYCOMP(KFQSTR)
37587 KFQEXC=MOD(KFQSTR,KEXCIT)
37588 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37589 HS=SHR*WDTP(0)
37590 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37591 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
37592 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37593 & FACBW=0D0
37594 HP=SH
37595 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
37596 DO 190 ISDE=1,2
37597 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
37598 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
37599 HI=HP
37600 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37601 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37602 NCHN=NCHN+1
37603 ISIG(NCHN,ISDE)=I
37604 ISIG(NCHN,3-ISDE)=21
37605 ISIG(NCHN,3)=1
37606 SIGH(NCHN)=HI*FACBW*HF
37607 190 CONTINUE
37608 200 CONTINUE
37609 ENDIF
37610
37611 ELSEIF(ISUB.LE.190) THEN
37612 IF(ISUB.EQ.162) THEN
37613C...q + g -> LQ + lbar; LQ=leptoquark
37614 SQMLQ=PMAS(42,1)**2
37615 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
37616 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
37617 KFLQQ=KFDP(MDCY(42,2),1)
37618 DO 220 I=MMINA,MMAXA
37619 IF(IABS(I).NE.KFLQQ) GOTO 220
37620 KCHLQ=ISIGN(1,I)
37621 DO 210 ISDE=1,2
37622 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
37623 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
37624 NCHN=NCHN+1
37625 ISIG(NCHN,ISDE)=I
37626 ISIG(NCHN,3-ISDE)=21
37627 ISIG(NCHN,3)=1
37628 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
37629 210 CONTINUE
37630 220 CONTINUE
37631
37632 ELSEIF(ISUB.EQ.163) THEN
37633C...g + g -> LQ + LQbar; LQ=leptoquark
37634 SQMLQ=PMAS(42,1)**2
37635 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
37636 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
37637 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
37638 & ((TH-SQMLQ)*(UH-SQMLQ)))
37639 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
37640 NCHN=NCHN+1
37641 ISIG(NCHN,1)=21
37642 ISIG(NCHN,2)=21
37643C...Since don't know proper colour flow, randomize between alternatives
37644 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
37645 SIGH(NCHN)=FACLQ
37646 230 CONTINUE
37647
37648 ELSEIF(ISUB.EQ.164) THEN
37649C...q + qbar -> LQ + LQbar; LQ=leptoquark
37650 DELTA=0.25D0*(SQM3-SQM4)**2/SH
37651 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
37652 TH=TH-DELTA
37653 UH=UH-DELTA
37654C SQMLQ=PMAS(42,1)**2
37655 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
37656 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
37657 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
37658 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
37659 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
37660 KFLQQ=KFDP(MDCY(42,2),1)
37661 DO 240 I=MMINA,MMAXA
37662 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37663 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
37664 NCHN=NCHN+1
37665 ISIG(NCHN,1)=I
37666 ISIG(NCHN,2)=-I
37667 ISIG(NCHN,3)=1
37668 SIGH(NCHN)=FACLQA
37669 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
37670 240 CONTINUE
37671
37672 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
37673C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37674 KFQSTR=KFPR(ISUB,2)
37675 KCQSTR=PYCOMP(KFQSTR)
37676 KFQEXC=MOD(KFQSTR,KEXCIT)
37677 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
37678 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37679 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37680C...Propagators: as simulated in PYOFSH and as desired
37681 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37682 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37683 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37684 GMMQC=SQRT(SQM4)*WDTP(0)
37685 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37686 FACQSA=FACQSA*HBW4C/HBW4
37687 FACQSB=FACQSB*HBW4C/HBW4
37688C...Branching ratios.
37689 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37690 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37691 DO 260 I=MMIN1,MMAX1
37692 IA=IABS(I)
37693 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
37694 DO 250 J=MMIN2,MMAX2
37695 JA=IABS(J)
37696 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
37697 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
37698 NCHN=NCHN+1
37699 ISIG(NCHN,1)=I
37700 ISIG(NCHN,2)=J
37701 ISIG(NCHN,3)=1
37702 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37703 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37704 NCHN=NCHN+1
37705 ISIG(NCHN,1)=I
37706 ISIG(NCHN,2)=J
37707 ISIG(NCHN,3)=2
37708 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37709 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37710 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
37711 NCHN=NCHN+1
37712 ISIG(NCHN,1)=I
37713 ISIG(NCHN,2)=J
37714 ISIG(NCHN,3)=1
37715 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37716 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
37717 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
37718 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
37719 NCHN=NCHN+1
37720 ISIG(NCHN,1)=I
37721 ISIG(NCHN,2)=J
37722 ISIG(NCHN,3)=1
37723 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37724 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37725 NCHN=NCHN+1
37726 ISIG(NCHN,1)=I
37727 ISIG(NCHN,2)=J
37728 ISIG(NCHN,3)=2
37729 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37730 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37731 ELSEIF(I.EQ.-J) THEN
37732 NCHN=NCHN+1
37733 ISIG(NCHN,1)=I
37734 ISIG(NCHN,2)=J
37735 ISIG(NCHN,3)=1
37736 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37737 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37738 NCHN=NCHN+1
37739 ISIG(NCHN,1)=I
37740 ISIG(NCHN,2)=J
37741 ISIG(NCHN,3)=2
37742 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37743 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37744 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
37745 NCHN=NCHN+1
37746 ISIG(NCHN,1)=I
37747 ISIG(NCHN,2)=J
37748 ISIG(NCHN,3)=1
37749 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37750 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
37751 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
37752 ENDIF
37753 250 CONTINUE
37754 260 CONTINUE
37755
37756 ELSEIF(ISUB.EQ.169) THEN
37757C...q + qbar -> e + e* (excited lepton)
37758 KFQSTR=KFPR(ISUB,2)
37759 KCQSTR=PYCOMP(KFQSTR)
37760 KFQEXC=MOD(KFQSTR,KEXCIT)
37761 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37762 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37763C...Propagators: as simulated in PYOFSH and as desired
37764 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37765 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37766 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37767 GMMQC=SQRT(SQM4)*WDTP(0)
37768 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37769 FACQSB=FACQSB*HBW4C/HBW4
37770C...Branching ratios.
37771 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37772 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37773 DO 270 I=MMIN1,MMAX1
37774 IA=IABS(I)
37775 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
37776 J=-I
37777 JA=IABS(J)
37778 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
37779 NCHN=NCHN+1
37780 ISIG(NCHN,1)=I
37781 ISIG(NCHN,2)=J
37782 ISIG(NCHN,3)=1
37783 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37784 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37785 NCHN=NCHN+1
37786 ISIG(NCHN,1)=I
37787 ISIG(NCHN,2)=J
37788 ISIG(NCHN,3)=2
37789 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37790 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37791 270 CONTINUE
37792 ENDIF
37793
37794 ELSEIF(ISUB.LE.360) THEN
37795 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
37796C...l + l -> H_L++/-- or H_R++/--.
37797 KFRES=KFPR(ISUB,1)
37798 KFREC=PYCOMP(KFRES)
37799 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37800 HS=SHR*WDTP(0)
37801 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
37802 DO 290 I=MMIN1,MMAX1
37803 IA=IABS(I)
37804 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
37805 & GOTO 290
37806 DO 280 J=MMIN2,MMAX2
37807 JA=IABS(J)
37808 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
37809 & GOTO 280
37810 IF(I*J.LT.0) GOTO 280
37811 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37812 NCHN=NCHN+1
37813 ISIG(NCHN,1)=I
37814 ISIG(NCHN,2)=J
37815 ISIG(NCHN,3)=1
37816 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
37817 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37818 SIGH(NCHN)=HI*FACBW*HF
37819 280 CONTINUE
37820 290 CONTINUE
37821
37822 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
37823C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37824 KFRES=KFPR(ISUB,1)
37825 KFREC=PYCOMP(KFRES)
37826C...Propagators: as simulated in PYOFSH and as desired
37827 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
37828 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
37829 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37830 GMMC=SQRT(SQM3)*WDTP(0)
37831 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
37832 FHCC=COMFAC*AEM*HBW3C/HBW3
37833 DO 310 I=MMINA,MMAXA
37834 IA=IABS(I)
37835 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
37836 SQML=PMAS(IA,1)**2
37837 J=ISIGN(KFPR(ISUB,2),-I)
37838 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
37839 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
37840 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
37841 & (UH-SQM3)**2
37842 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
37843 & (TH-SQM4)*SH)/(TH-SQM4)**2
37844 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
37845 & SH)/(SH-SQML)**2
37846 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
37847 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
37848 & ((UH-SQM3)*(TH-SQM4))
37849 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
37850 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
37851 & ((UH-SQM3)*(SH-SQML))
37852 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
37853 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
37854 & ((SH-SQML)*(TH-SQM4))
37855 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
37856 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
37857 DO 300 ISDE=1,2
37858 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
37859 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
37860 NCHN=NCHN+1
37861 ISIG(NCHN,ISDE)=I
37862 ISIG(NCHN,3-ISDE)=22
37863 ISIG(NCHN,3)=0
37864 SIGH(NCHN)=FHCC*SMM*WIDSC
37865 300 CONTINUE
37866 310 CONTINUE
37867
37868 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
37869C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37870 KFRES=KFPR(ISUB,1)
37871 KFREC=PYCOMP(KFRES)
37872 SQMH=PMAS(KFREC,1)**2
37873 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
37874C...Propagators: H++/-- as simulated in PYOFSH and as desired
37875 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
37876 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37877 GMMH3=SQRT(SQM3)*WDTP(0)
37878 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
37879 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
37880 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
37881 GMMH4=SQRT(SQM4)*WDTP(0)
37882 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
37883C...Kinematical and coupling functions
37884 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
37885 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
37886C...Loop over allowed flavours
37887 DO 320 I=MMINA,MMAXA
37888 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37889 EI=KCHG(IABS(I),1)/3D0
37890 AI=SIGN(1D0,EI+0.1D0)
37891 VI=AI-4D0*EI*XWV
37892 FCOI=1D0
37893 IF(IABS(I).LE.10) FCOI=FACA/3D0
37894 IF(ISUB.EQ.349) THEN
37895 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
37896 IF(IABS(I).LT.10) THEN
37897 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37898 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37899 & (VI**2+AI**2)*XWHH**2*HBWZ)
37900 ELSE
37901 IAOFF=181+3*((IABS(I)-11)/2)
37902 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37903 & (4D0*PARU(1))
37904 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37905 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37906 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37907 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37908 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37909 & 4D0*HSUM**2/TH2
37910 ENDIF
37911 ELSE
37912 IF(IABS(I).LT.10) THEN
37913 DSIGHH=8D0*AEM**2*EI**2/SH2
37914 ELSE
37915 IAOFF=181+3*((IABS(I)-11)/2)
37916 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37917 & (4D0*PARU(1))
37918 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37919 & 4D0*HSUM**2/TH2
37920 ENDIF
37921 ENDIF
37922 NCHN=NCHN+1
37923 ISIG(NCHN,1)=I
37924 ISIG(NCHN,2)=-I
37925 ISIG(NCHN,3)=1
37926 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37927 320 CONTINUE
37928
37929 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37930C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37931 KFRES=KFPR(ISUB,1)
37932 KFREC=PYCOMP(KFRES)
37933 SQMH=PMAS(KFREC,1)**2
37934 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37935 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37936 & PMAS(PYCOMP(9900024),1)**2
37937 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37938 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37939 & (VINT(209)**2-VINT(216)))
37940 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37941 & (VINT(209)**2+2D0*VINT(218)))
37942 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37943 HS=SHR*WDTP(0)
37944 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37945 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37946 & FACBW=0D0
37947 DO 340 I=MMIN1,MMAX1
37948 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37949 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37950 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37951 DO 330 J=MMIN2,MMAX2
37952 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37953 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37954 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37955 KCHH=KCHWI+KCHWJ
37956 IF(IABS(KCHH).NE.2) GOTO 330
37957 FACLR=VINT(180+I)*VINT(180+J)
37958 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37959 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37960 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37961 ELSE
37962 FACPRP=FACPRT**2
37963 ENDIF
37964 NCHN=NCHN+1
37965 ISIG(NCHN,1)=I
37966 ISIG(NCHN,2)=J
37967 ISIG(NCHN,3)=1
37968 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37969 330 CONTINUE
37970 340 CONTINUE
37971
37972 ELSEIF(ISUB.EQ.353) THEN
37973C...f + fbar -> Z_R0
37974 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37975 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37976 HS=SHR*WDTP(0)
37977 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37978 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37979 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37980 DO 350 I=MMINA,MMAXA
37981 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37982 IF(IABS(I).LE.8) THEN
37983 EI=KCHG(IABS(I),1)/3D0
37984 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37985 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37986 ELSE
37987 AI=-(1D0-2D0*XW)
37988 VI=-1D0+4D0*XW
37989 ENDIF
37990 HI=HP*(VI**2+AI**2)
37991 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37992 NCHN=NCHN+1
37993 ISIG(NCHN,1)=I
37994 ISIG(NCHN,2)=-I
37995 ISIG(NCHN,3)=1
37996 SIGH(NCHN)=HI*FACBW*HF
37997 350 CONTINUE
37998
37999 ELSEIF(ISUB.EQ.354) THEN
38000C...f + fbar' -> W_R+/-
38001 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38002 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38003 HS=SHR*WDTP(0)
38004 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38005 HP=AEM/(24D0*XW)*SH
38006 DO 370 I=MMIN1,MMAX1
38007 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38008 IA=IABS(I)
38009 DO 360 J=MMIN2,MMAX2
38010 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38011 JA=IABS(J)
38012 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38013 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38014 & GOTO 360
38015 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38016 HI=HP*2D0
38017 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38018 NCHN=NCHN+1
38019 ISIG(NCHN,1)=I
38020 ISIG(NCHN,2)=J
38021 ISIG(NCHN,3)=1
38022 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38023 SIGH(NCHN)=HI*FACBW*HF
38024 360 CONTINUE
38025 370 CONTINUE
38026 ENDIF
38027
38028 ELSEIF(ISUB.LE.400) THEN
38029 IF(ISUB.EQ.391) THEN
38030C...f + fbar -> G*.
38031 KFGSTR=KFPR(ISUB,1)
38032 KCGSTR=PYCOMP(KFGSTR)
38033 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38034 HS=SHR*WDTP(0)
38035 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38036 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38037 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38038C...Modify cross section in wings of peak.
38039 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38040 DO 380 I=MMINA,MMAXA
38041 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38042 HI=1D0
38043 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38044 NCHN=NCHN+1
38045 ISIG(NCHN,1)=I
38046 ISIG(NCHN,2)=-I
38047 ISIG(NCHN,3)=1
38048 SIGH(NCHN)=FACG*HI
38049 380 CONTINUE
38050
38051 ELSEIF(ISUB.EQ.392) THEN
38052C...g + g -> G*.
38053 KFGSTR=KFPR(ISUB,1)
38054 KCGSTR=PYCOMP(KFGSTR)
38055 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38056 HS=SHR*WDTP(0)
38057 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38058 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38059 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38060C...Modify cross section in wings of peak.
38061 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38062 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38063 NCHN=NCHN+1
38064 ISIG(NCHN,1)=21
38065 ISIG(NCHN,2)=21
38066 ISIG(NCHN,3)=1
38067 SIGH(NCHN)=FACG
38068 390 CONTINUE
38069
38070 ELSEIF(ISUB.EQ.393) THEN
38071C...q + qbar -> g + G*.
38072 KFGSTR=KFPR(ISUB,2)
38073 KCGSTR=PYCOMP(KFGSTR)
38074 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38075 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38076 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38077 & 2D0*SH2/(TH*UH))
38078C...Propagators: as simulated in PYOFSH and as desired
38079 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38080 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38081 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38082 HS=SQRT(SQM4)*WDTP(0)
38083 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38084 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38085 FACG=FACG*HBW4C/HBW4
38086 DO 400 I=MMINA,MMAXA
38087 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38088 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38089 NCHN=NCHN+1
38090 ISIG(NCHN,1)=I
38091 ISIG(NCHN,2)=-I
38092 ISIG(NCHN,3)=1
38093 SIGH(NCHN)=FACG
38094 400 CONTINUE
38095
38096 ELSEIF(ISUB.EQ.394) THEN
38097C...q + g -> q + G*.
38098 KFGSTR=KFPR(ISUB,2)
38099 KCGSTR=PYCOMP(KFGSTR)
38100 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38101 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38102 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38103 & 2D0*TH2*TH/(UH*SH2))
38104C...Propagators: as simulated in PYOFSH and as desired
38105 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38106 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38107 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38108 HS=SQRT(SQM4)*WDTP(0)
38109 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38110 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38111 FACG=FACG*HBW4C/HBW4
38112 DO 420 I=MMINA,MMAXA
38113 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38114 DO 410 ISDE=1,2
38115 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38116 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38117 NCHN=NCHN+1
38118 ISIG(NCHN,ISDE)=I
38119 ISIG(NCHN,3-ISDE)=21
38120 ISIG(NCHN,3)=1
38121 SIGH(NCHN)=FACG
38122 410 CONTINUE
38123 420 CONTINUE
38124
38125 ELSEIF(ISUB.EQ.395) THEN
38126C...g + g -> g + G*.
38127 KFGSTR=KFPR(ISUB,2)
38128 KCGSTR=PYCOMP(KFGSTR)
38129 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38130 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38131 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38132C...Propagators: as simulated in PYOFSH and as desired
38133 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38134 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38135 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38136 HS=SQRT(SQM4)*WDTP(0)
38137 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38138 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38139 FACG=FACG*HBW4C/HBW4
38140 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38141 NCHN=NCHN+1
38142 ISIG(NCHN,1)=21
38143 ISIG(NCHN,2)=21
38144 ISIG(NCHN,3)=1
38145 SIGH(NCHN)=FACG
38146 ENDIF
38147 ENDIF
38148 ENDIF
38149
38150 RETURN
38151 END
38152
38153C*********************************************************************
38154
38155C...PYPDFU
38156C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38157C...parton distributions according to a few different parametrizations.
38158C...Note that what is coded is x times the probability distribution,
38159C...i.e. xq(x,Q2) etc.
38160
38161 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38162
38163C...Double precision and integer declarations.
38164 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38165 IMPLICIT INTEGER(I-N)
38166 INTEGER PYK,PYCHGE,PYCOMP
38167C...Commonblocks.
38168 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38169 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38170 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38171 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38172 COMMON/PYINT1/MINT(400),VINT(400)
38173 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38174 &XPDIR(-6:6)
38175 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38176 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38177 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38178 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38179 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38180 &/PYINT9/,/PYINTM/
38181C...Local arrays.
38182 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38183 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38184 SAVE PPAR
38185
38186C...Interface to PDFLIB.
38187 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38188 SAVE /W50513/
38189 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38190 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38191 CHARACTER*20 PARM(20)
38192 DATA VALUE/20*0D0/,PARM/20*' '/
38193
38194C...Data related to Schuler-Sjostrand photon distributions.
38195 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38196
38197C...Valence PDF momentum integral parametrizations PER PARTON!
38198 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38199 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38200 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38201 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38202
38203C...Reset parton distributions.
38204 MINT(92)=0
38205 DO 100 KFL=-25,25
38206 XPQ(KFL)=0D0
38207 100 CONTINUE
38208 DO 110 KFL=-6,6
38209 XPVAL(KFL)=0D0
38210 110 CONTINUE
38211
38212C...Check x and particle species.
38213 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38214 WRITE(MSTU(11),5000) X
38215 GOTO 9999
38216 ENDIF
38217 KFA=IABS(KF)
38218 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38219 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38220 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38221 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38222 &KFA.NE.310.AND.KFA.NE.130) THEN
38223 WRITE(MSTU(11),5100) KF
38224 GOTO 9999
38225 ENDIF
38226
38227C...Electron (or muon or tau) parton distribution call.
38228 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38229 CALL PYPDEL(KFA,X,Q2,XPEL)
38230 DO 120 KFL=-25,25
38231 XPQ(KFL)=XPEL(KFL)
38232 120 CONTINUE
38233
38234C...Photon parton distribution call (VDM+anomalous).
38235 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38236 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38237 CALL PYPDGA(X,Q2,XPGA)
38238 DO 130 KFL=-6,6
38239 XPQ(KFL)=XPGA(KFL)
38240 130 CONTINUE
38241 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38242 XPVAL(1)=XPVU/4D0
38243 XPVAL(2)=XPVU
38244 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38245 XPVAL(4)=MIN(XPQ(4),XPVU)
38246 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38247 XPVAL(-1)=XPVAL(1)
38248 XPVAL(-2)=XPVAL(2)
38249 XPVAL(-3)=XPVAL(3)
38250 XPVAL(-4)=XPVAL(4)
38251 XPVAL(-5)=XPVAL(5)
38252 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38253 Q2MX=Q2
38254 P2MX=0.36D0
38255 IF(MSTP(55).GE.7) P2MX=4.0D0
38256 IF(MSTP(57).EQ.0) Q2MX=P2MX
38257 P2=0D0
38258 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38259 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38260 DO 140 KFL=-6,6
38261 XPQ(KFL)=XPGA(KFL)
38262 XPVAL(KFL)=VXPDGM(KFL)
38263 140 CONTINUE
38264 VINT(231)=P2MX
38265 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38266 Q2MX=Q2
38267 P2MX=0.36D0
38268 IF(MSTP(55).GE.11) P2MX=4.0D0
38269 IF(MSTP(57).EQ.0) Q2MX=P2MX
38270 P2=0D0
38271 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38272 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38273 DO 150 KFL=-6,6
38274 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38275 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38276 150 CONTINUE
38277 VINT(231)=P2MX
38278 ELSEIF(MSTP(56).EQ.2) THEN
38279C...Call PDFLIB parton distributions.
38280 PARM(1)='NPTYPE'
38281 VALUE(1)=3
38282 PARM(2)='NGROUP'
38283 VALUE(2)=MSTP(55)/1000
38284 PARM(3)='NSET'
38285 VALUE(3)=MOD(MSTP(55),1000)
38286 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38287 CALL PDFSET_ALICE(PARM,VALUE)
38288 MINT(93)=3000000+MSTP(55)
38289 ENDIF
38290 XX=X
38291 QQ2=MAX(0D0,Q2MIN,Q2)
38292 IF(MSTP(57).EQ.0) QQ2=Q2MIN
38293 P2=0D0
38294 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38295 IP2=MSTP(60)
38296 IF(MSTP(55).EQ.5004) THEN
38297 IF(5D0*P2.LT.QQ2.AND.
38298 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
38299 & P2.GE.0D0.AND.P2.LT.10D0.AND.
38300 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
38301 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38302 & BOT,TOP,GLU)
38303 ELSE
38304 UPV=0D0
38305 DNV=0D0
38306 USEA=0D0
38307 DSEA=0D0
38308 STR=0D0
38309 CHM=0D0
38310 BOT=0D0
38311 TOP=0D0
38312 GLU=0D0
38313 ENDIF
38314 ELSE
38315 IF(P2.LT.QQ2) THEN
38316 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38317 & BOT,TOP,GLU)
38318 ELSE
38319 UPV=0D0
38320 DNV=0D0
38321 USEA=0D0
38322 DSEA=0D0
38323 STR=0D0
38324 CHM=0D0
38325 BOT=0D0
38326 TOP=0D0
38327 GLU=0D0
38328 ENDIF
38329 ENDIF
38330 VINT(231)=Q2MIN
38331 XPQ(0)=GLU
38332 XPQ(1)=DNV
38333 XPQ(-1)=DNV
38334 XPQ(2)=UPV
38335 XPQ(-2)=UPV
38336 XPQ(3)=STR
38337 XPQ(-3)=STR
38338 XPQ(4)=CHM
38339 XPQ(-4)=CHM
38340 XPQ(5)=BOT
38341 XPQ(-5)=BOT
38342 XPQ(6)=TOP
38343 XPQ(-6)=TOP
38344 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38345 XPVAL(1)=XPVU/4D0
38346 XPVAL(2)=XPVU
38347 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38348 XPVAL(4)=MIN(XPQ(4),XPVU)
38349 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38350 XPVAL(-1)=XPVAL(1)
38351 XPVAL(-2)=XPVAL(2)
38352 XPVAL(-3)=XPVAL(3)
38353 XPVAL(-4)=XPVAL(4)
38354 XPVAL(-5)=XPVAL(5)
38355 ELSE
38356 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
38357 ENDIF
38358
38359C...Pion/gammaVDM parton distribution call.
38360 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
38361 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38362 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
38363 & MSTP(55).LE.12) THEN
38364 ISET=1+MOD(MSTP(55)-1,4)
38365 Q2MX=Q2
38366 P2MX=0.36D0
38367 IF(ISET.GE.3) P2MX=4.0D0
38368 IF(MSTP(57).EQ.0) Q2MX=P2MX
38369 P2=0D0
38370 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38371 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38372 DO 160 KFL=-6,6
38373 XPQ(KFL)=XPVMD(KFL)
38374 XPVAL(KFL)=VXPVMD(KFL)
38375 160 CONTINUE
38376 VINT(231)=P2MX
38377 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
38378 CALL PYPDPI(X,Q2,XPPI)
38379 DO 170 KFL=-6,6
38380 XPQ(KFL)=XPPI(KFL)
38381 170 CONTINUE
38382 XPVAL(2)=XPQ(2)-XPQ(-2)
38383 XPVAL(-1)=XPQ(-1)-XPQ(1)
38384 ELSEIF(MSTP(54).EQ.2) THEN
38385C...Call PDFLIB parton distributions.
38386 PARM(1)='NPTYPE'
38387 VALUE(1)=2
38388 PARM(2)='NGROUP'
38389 VALUE(2)=MSTP(53)/1000
38390 PARM(3)='NSET'
38391 VALUE(3)=MOD(MSTP(53),1000)
38392 IF(MINT(93).NE.2000000+MSTP(53)) THEN
38393 CALL PDFSET_ALICE(PARM,VALUE)
38394 MINT(93)=2000000+MSTP(53)
38395 ENDIF
38396 XX=X
38397 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38398 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38399 CALL STRUCTM_ALICE
38400 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38401 VINT(231)=Q2MIN
38402 XPQ(0)=GLU
38403 XPQ(1)=DSEA
38404 XPQ(-1)=UPV+DSEA
38405 XPQ(2)=UPV+USEA
38406 XPQ(-2)=USEA
38407 XPQ(3)=STR
38408 XPQ(-3)=STR
38409 XPQ(4)=CHM
38410 XPQ(-4)=CHM
38411 XPQ(5)=BOT
38412 XPQ(-5)=BOT
38413 XPQ(6)=TOP
38414 XPQ(-6)=TOP
38415 XPVAL(2)=UPV
38416 XPVAL(-1)=UPV
38417 ELSE
38418 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
38419 ENDIF
38420
38421C...Anomalous photon parton distribution call.
38422 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
38423 Q2MX=Q2
38424 P2MX=PARP(15)**2
38425 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
38426 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
38427 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
38428 IF(MSTP(57).EQ.0) Q2MX=P2MX
38429 P2=0D0
38430 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38431 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38432 DO 180 KFL=-6,6
38433 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
38434 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
38435 180 CONTINUE
38436 VINT(231)=P2MX
38437 ELSEIF(MSTP(56).EQ.1) THEN
38438 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
38439 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
38440 IF(MSTP(57).EQ.0) Q2MX=P2MX
38441 P2=0D0
38442 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38443 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38444 DO 190 KFL=-6,6
38445 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38446 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38447 190 CONTINUE
38448 VINT(231)=P2MX
38449 ELSEIF(MSTP(56).EQ.2) THEN
38450 IF(MSTP(57).EQ.0) Q2MX=P2MX
38451 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
38452 DO 200 KFL=-6,6
38453 XPQ(KFL)=XPGA(KFL)
38454 XPVAL(KFL)=VXPGA(KFL)
38455 200 CONTINUE
38456 VINT(231)=P2MX
38457 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
38458 IF(MSTP(57).EQ.0) Q2MX=P2MX
38459 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38460 DO 210 KFL=-6,6
38461 XPQ(KFL)=XPGA(KFL)
38462 XPVAL(KFL)=VXPGA(KFL)
38463 210 CONTINUE
38464 VINT(231)=P2MX
38465 ELSE
38466 220 RKF=11D0*PYR(0)
38467 KFR=1
38468 IF(RKF.GT.1D0) KFR=2
38469 IF(RKF.GT.5D0) KFR=3
38470 IF(RKF.GT.6D0) KFR=4
38471 IF(RKF.GT.10D0) KFR=5
38472 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
38473 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
38474 IF(MSTP(57).EQ.0) Q2MX=P2MX
38475 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38476 DO 230 KFL=-6,6
38477 XPQ(KFL)=XPGA(KFL)
38478 XPVAL(KFL)=VXPGA(KFL)
38479 230 CONTINUE
38480 VINT(231)=P2MX
38481 ENDIF
38482
38483C...Proton parton distribution call.
38484 ELSE
38485 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
38486 CALL PYPDPR(X,Q2,XPPR)
38487 DO 240 KFL=-6,6
38488 XPQ(KFL)=XPPR(KFL)
38489 240 CONTINUE
38490C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38491 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
38492 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
38493 ELSEIF(MSTP(52).EQ.2) THEN
38494C...Call PDFLIB parton distributions.
38495 PARM(1)='NPTYPE'
38496 VALUE(1)=1
38497 PARM(2)='NGROUP'
38498 VALUE(2)=MSTP(51)/1000
38499 PARM(3)='NSET'
38500 VALUE(3)=MOD(MSTP(51),1000)
38501 IF(MINT(93).NE.1000000+MSTP(51)) THEN
38502 CALL PDFSET_ALICE(PARM,VALUE)
38503 MINT(93)=1000000+MSTP(51)
38504 ENDIF
38505 XX=X
38506 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38507 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38508 CALL STRUCTM_ALICE(
38509 & XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38510 VINT(231)=Q2MIN
38511 XPQ(0)=GLU
38512 XPQ(1)=DNV+DSEA
38513 XPQ(-1)=DSEA
38514 XPQ(2)=UPV+USEA
38515 XPQ(-2)=USEA
38516 XPQ(3)=STR
38517 XPQ(-3)=STR
38518 XPQ(4)=CHM
38519 XPQ(-4)=CHM
38520 XPQ(5)=BOT
38521 XPQ(-5)=BOT
38522 XPQ(6)=TOP
38523 XPQ(-6)=TOP
38524 XPVAL(1)=DNV
38525 XPVAL(2)=UPV
38526 ELSE
38527 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
38528 ENDIF
38529 ENDIF
38530
38531C...Isospin average for pi0/gammaVDM.
38532 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38533 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
38534 XPV=XPQ(2)-XPQ(1)
38535 XPQ(2)=XPQ(1)
38536 XPQ(-2)=XPQ(-1)
38537 ELSE
38538 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38539 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38540 XPQ(2)=XPS
38541 XPQ(-1)=XPS
38542 ENDIF
38543 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
38544 & XPVAL(3)+XPVAL(4)+XPVAL(5)
38545 DO 250 KFL=-6,6
38546 XPVAL(KFL)=0D0
38547 250 CONTINUE
38548 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
38549 XPQ(1)=XPQ(1)+0.2D0*XPV
38550 XPQ(2)=XPQ(2)+0.8D0*XPV
38551 XPVAL(1)=0.2D0*XPVL
38552 XPVAL(2)=0.8D0*XPVL
38553 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
38554 XPQ(3)=XPQ(3)+XPV
38555 XPVAL(3)=XPVL
38556 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
38557 XPQ(4)=XPQ(4)+XPV
38558 XPVAL(4)=XPVL
38559 IF(MSTP(55).GE.9) THEN
38560 DO 260 KFL=-6,6
38561 XPQ(KFL)=0D0
38562 260 CONTINUE
38563 ENDIF
38564 ELSE
38565 XPQ(1)=XPQ(1)+0.5D0*XPV
38566 XPQ(2)=XPQ(2)+0.5D0*XPV
38567 XPVAL(1)=0.5D0*XPVL
38568 XPVAL(2)=0.5D0*XPVL
38569 ENDIF
38570 DO 270 KFL=1,6
38571 XPQ(-KFL)=XPQ(KFL)
38572 XPVAL(-KFL)=XPVAL(KFL)
38573 270 CONTINUE
38574
38575C...Rescale for gammaVDM by effective gamma -> rho coupling.
38576C+++Do not rescale?
38577 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
38578 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
38579 DO 280 KFL=-6,6
38580 XPQ(KFL)=VINT(281)*XPQ(KFL)
38581 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
38582 280 CONTINUE
38583 VINT(232)=VINT(281)*XPV
38584 ENDIF
38585
38586C...Simple recipes for kaons.
38587 ELSEIF(KFA.EQ.321) THEN
38588 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
38589 XPQ(-1)=XPQ(1)
38590 XPVAL(-3)=XPVAL(-1)
38591 XPVAL(-1)=0D0
38592 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
38593 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38594 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38595 XPQ(2)=XPS
38596 XPQ(-1)=XPS
38597 XPQ(1)=XPQ(1)+0.5D0*XPV
38598 XPQ(-1)=XPQ(-1)+0.5D0*XPV
38599 XPQ(3)=XPQ(3)+0.5D0*XPV
38600 XPQ(-3)=XPQ(-3)+0.5D0*XPV
38601 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
38602 XPVAL(2)=0D0
38603 XPVAL(-1)=0D0
38604 XPVAL(1)=0.5D0*XPV
38605 XPVAL(-1)=0.5D0*XPV
38606 XPVAL(3)=0.5D0*XPV
38607 XPVAL(-3)=0.5D0*XPV
38608
38609C...Isospin conjugation for neutron.
38610 ELSEIF(KFA.EQ.2112) THEN
38611 XPSV=XPQ(1)
38612 XPQ(1)=XPQ(2)
38613 XPQ(2)=XPSV
38614 XPSV=XPQ(-1)
38615 XPQ(-1)=XPQ(-2)
38616 XPQ(-2)=XPSV
38617 XPSV=XPVAL(1)
38618 XPVAL(1)=XPVAL(2)
38619 XPVAL(2)=XPSV
38620
38621C...Simple recipes for hyperon (average valence parton distribution).
38622 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
38623 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
38624 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
38625 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
38626 XPQ(1)=XPS
38627 XPQ(2)=XPS
38628 XPQ(-1)=XPS
38629 XPQ(-2)=XPS
38630 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
38631 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
38632 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
38633 XPV=(XPVAL(1)+XPVAL(2))/3D0
38634 XPVAL(1)=0D0
38635 XPVAL(2)=0D0
38636 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
38637 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
38638 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
38639 ENDIF
38640
38641C...Charge conjugation for antiparticle.
38642 IF(KF.LT.0) THEN
38643 DO 290 KFL=1,25
38644 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
38645 XPSV=XPQ(KFL)
38646 XPQ(KFL)=XPQ(-KFL)
38647 XPQ(-KFL)=XPSV
38648 290 CONTINUE
38649 DO 300 KFL=1,6
38650 XPSV=XPVAL(KFL)
38651 XPVAL(KFL)=XPVAL(-KFL)
38652 XPVAL(-KFL)=XPSV
38653 300 CONTINUE
38654 ENDIF
38655
38656C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38657C...Set side.
38658 JS=MINT(30)
38659C...Only reshape PDFs for the non-first interactions;
38660C...But need valence/sea separation already from first interaction.
38661 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
38662 KFVSEL=KFIVAL(JS,1)
38663C...If valence quark kicked out of pi0 or gamma then that decides
38664C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38665 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
38666 XPVL=0D0
38667 DO 310 KFL=1,6
38668 XPVL=XPVL+XPVAL(KFL)
38669 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
38670 XPVAL(KFL)=0D0
38671 310 CONTINUE
38672 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
38673 XPVAL(IABS(KFVSEL))=XPVL
38674 DO 320 KFL=1,6
38675 XPQ(-KFL)=XPQ(KFL)
38676 XPVAL(-KFL)=XPVAL(KFL)
38677 320 CONTINUE
38678
38679C...If valence quark kicked out of K0S or K0S then that decides whether
38680C...we should consider state as d sbar or s dbar.
38681 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
38682 KFS=1
38683 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
38684 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38685 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38686 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38687 XPVAL(-KFS)=0D0
38688 KFS=-3*KFS
38689 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38690 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38691 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38692 XPVAL(-KFS)=0D0
38693 ENDIF
38694
38695C...XPQ distributions are nominal for a (signed) beam particle
38696C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38697 CMPFAC=1D0
38698 NRESC=0
38699 345 NRESC=NRESC+1
38700 PVCTOT(JS,-1)=0D0
38701 PVCTOT(JS, 0)=0D0
38702 PVCTOT(JS, 1)=0D0
38703 DO 350 IFL=-6,6
38704 IF(IFL.EQ.0) GOTO 350
38705
38706C...Count up number of original IFL valence quarks.
38707 IVORG=0
38708 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
38709 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
38710 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
38711C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38712C...bookkeep as if d dbar (for total momentum sum in valence sector).
38713 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
38714C...Count down number of remaining IFL valence quarks. Skip current
38715C...interaction initiator.
38716 IVREM=IVORG
38717 DO 330 I1=1,NMI(JS)
38718 IF (I1.EQ.MINT(36)) GOTO 330
38719 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
38720 & IVREM=IVREM-1
38721 330 CONTINUE
38722
38723C...Separate out original VALENCE and SEA content.
38724 VAL=XPVAL(IFL)
38725 SEA=MAX(0D0,XPQ(IFL)-VAL)
38726 XPSVC(IFL,0)=VAL
38727 XPSVC(IFL,-1)=SEA
38728
38729C...Rescale valence content if changed.
38730 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
38731 & (VAL*IVREM)/IVORG
38732
38733C...Momentum integrals of original and removed valence quarks.
38734 IF(IVORG.NE.0) THEN
38735C...For p/n/pbar/nbar beams can split into d_val and u_val.
38736C...Isospin conjugation for neutrons
38737 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
38738 IAFLP=IABS(IFL)
38739 IF (KFA.EQ.2112) IAFLP=3-IAFLP
38740 VPAVG=PAVG(IAFLP,Q2)
38741C...For other baryons average d_val and u_val, like for PDFs.
38742 ELSEIF(KFA.GT.1000) THEN
38743 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
38744C...For mesons and photon average d_val and u_val and scale by 3/2.
38745C...Very crude, especially for photon.
38746 ELSE
38747 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
38748 ENDIF
38749 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
38750 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
38751 ENDIF
38752
38753C...Now add companions (at X with partner having been at Z=XASSOC).
38754C...NOTE: due to the assumed simple x scaling, the partner was at what
38755C...corresponds to a higher Z than XASSOC, if there were intermediate
38756C...scatterings. Nothing done about that for the moment.
38757 DO 340 IVC=1,NVC(JS,IFL)
38758C...Skip companions that have been kicked out
38759 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
38760 XPSVC(IFL,IVC)=0D0
38761 GOTO 340
38762 ELSE
38763C...Momentum fraction of the partner quark.
38764C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38765 XS=XASSOC(JS,IFL,IVC)
38766 XREM=VINT(142+JS)
38767 YS=XS/(XREM+XS)
38768C...Momentum fraction of the companion quark.
38769C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38770 Y=X*(1D0-YS)
38771 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
38772C...Add to momentum sum, with rescaling compensation factor.
38773 XCFAC=(XREM+XS)/XREM*CMPFAC
38774 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
38775 ENDIF
38776 340 CONTINUE
38777 350 CONTINUE
38778
38779C...Wait until all flavours treated, then rescale seas and gluon.
38780 XPSVC(0,-1)=XPQ(0)
38781 XPSVC(0,0)=0D0
38782 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
38783 IF (RSFAC.LE.0D0) THEN
38784C...First calculate factor needed to exactly restore pz cons.
38785 IF (NRESC.EQ.1) CMPFAC =
38786 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
38787C...Add a bit of headroom
38788 CMPFAC=0.99*CMPFAC
38789C...Try a few times if more headroom is needed, then print error message.
38790 IF (NRESC.LE.10) GOTO 345
38791 CALL PYERRM(15,
38792 & '(PYPDFU:) Negative reshaping factor persists!')
38793 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
38794 RSFAC=0D0
38795 ENDIF
38796 DO 370 IFL=-6,6
38797 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
38798C...Also store resulting distributions in XPQ
38799 XPQ(IFL)=0D0
38800 DO 360 ISVC=-1,NVC(JS,IFL)
38801 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
38802 360 CONTINUE
38803 370 CONTINUE
38804C...Save companion reweighting factor for PYPTIS.
38805 VINT(140)=CMPFAC
38806 ENDIF
38807
38808
38809C...Allow gluon also in position 21.
38810 XPQ(21)=XPQ(0)
38811
38812C...Check positivity and reset above maximum allowed flavour.
38813 DO 380 KFL=-25,25
38814 XPQ(KFL)=MAX(0D0,XPQ(KFL))
38815 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
38816 380 CONTINUE
38817
38818C...Formats for error printouts.
38819 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38820 5100 FORMAT(' Error: illegal particle code for parton distribution;',
38821 &' KF =',I5)
38822 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38823 &3I5)
38824 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
38825 & ' Removed valence momentum fraction : ',F6.3/
38826 & ' Added companion momentum fraction : ',F6.3/
38827 & ' Resulting rescale factor : ',F6.3)
38828
38829C...Reset side pointer and return
38830 9999 MINT(30)=0
38831
38832 RETURN
38833 END
38834
38835C*********************************************************************
38836
38837C...PYPDFL
38838C...Gives proton parton distribution at small x and/or Q^2 according to
38839C...correct limiting behaviour.
38840
38841 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
38842
38843C...Double precision and integer declarations.
38844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38845 IMPLICIT INTEGER(I-N)
38846 INTEGER PYK,PYCHGE,PYCOMP
38847C...Commonblocks.
38848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38850 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38851 COMMON/PYINT1/MINT(400),VINT(400)
38852 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38853C...Local arrays.
38854 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
38855 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
38856
38857C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38858 MINT(92)=0
38859 KFA=IABS(KF)
38860 IACC=0
38861 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
38862 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
38863 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
38864 IF(IACC.EQ.0) THEN
38865 CALL PYPDFU(KF,X,Q2,XPQ)
38866 RETURN
38867 ENDIF
38868
38869C...Reset. Check x.
38870 DO 100 KFL=-25,25
38871 XPQ(KFL)=0D0
38872 100 CONTINUE
38873 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38874 WRITE(MSTU(11),5000) X
38875 RETURN
38876 ENDIF
38877
38878C...Define valence content.
38879 KFC=KF
38880 NV1=2
38881 NV2=1
38882 IF(KF.EQ.2212) THEN
38883 KFV1=2
38884 KFV2=1
38885 ELSEIF(KF.EQ.-2212) THEN
38886 KFV1=-2
38887 KFV2=-1
38888 ELSEIF(KF.EQ.2112) THEN
38889 KFV1=1
38890 KFV2=2
38891 ELSEIF(KF.EQ.-2112) THEN
38892 KFV1=-1
38893 KFV2=-2
38894 ELSEIF(KF.EQ.211) THEN
38895 NV1=1
38896 KFV1=2
38897 KFV2=-1
38898 ELSEIF(KF.EQ.-211) THEN
38899 NV1=1
38900 KFV1=-2
38901 KFV2=1
38902 ELSEIF(MINT(105).LE.223) THEN
38903 KFV1=1
38904 WTV1=0.2D0
38905 KFV2=2
38906 WTV2=0.8D0
38907 ELSEIF(MINT(105).EQ.333) THEN
38908 KFV1=3
38909 WTV1=1.0D0
38910 KFV2=1
38911 WTV2=0.0D0
38912 ELSEIF(MINT(105).EQ.443) THEN
38913 KFV1=4
38914 WTV1=1.0D0
38915 KFV2=1
38916 WTV2=0.0D0
38917 ENDIF
38918
38919C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38920 MINT30=MINT(30)
38921 CALL PYPDFU(KFC,X,Q2,XPA)
38922 Q2MN=MAX(3D0,VINT(231))
38923 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38924 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38925
38926C...Large Q2 and large x: naive call is enough.
38927 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38928 DO 110 KFL=-25,25
38929 XPQ(KFL)=XPA(KFL)
38930 110 CONTINUE
38931 MINT(92)=1
38932
38933C...Small Q2 and large x: dampen boundary value.
38934 ELSEIF(X.GT.XMN) THEN
38935
38936C...Evaluate at boundary and define dampening factors.
38937 MINT(30)=MINT30
38938 CALL PYPDFU(KFC,X,Q2MN,XPA)
38939 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38940 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38941
38942C...Separate valence and sea parts of parton distribution.
38943 IF(KFA.NE.22) THEN
38944 XFV1=XPA(KFV1)-XPA(-KFV1)
38945 XPA(KFV1)=XPA(-KFV1)
38946 XFV2=XPA(KFV2)-XPA(-KFV2)
38947 XPA(KFV2)=XPA(-KFV2)
38948 ELSE
38949 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38950 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38951 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38952 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38953 ENDIF
38954
38955C...Dampen valence and sea separately. Put back together.
38956 DO 120 KFL=-25,25
38957 XPQ(KFL)=FS*XPA(KFL)
38958 120 CONTINUE
38959 IF(KFA.NE.22) THEN
38960 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38961 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38962 ELSE
38963 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38964 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38965 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38966 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38967 ENDIF
38968 MINT(92)=2
38969
38970C...Large Q2 and small x: interpolate behaviour.
38971 ELSEIF(Q2.GT.Q2MN) THEN
38972
38973C...Evaluate at extremes and define coefficients for interpolation.
38974 MINT(30)=MINT30
38975 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38976 VI232A=VINT(232)
38977 MINT(30)=MINT30
38978 CALL PYPDFU(KFC,X,Q2B,XPB)
38979 VI232B=VINT(232)
38980 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38981 FVA=(X/XMN)**0.45D0*FLA
38982 FSA=(X/XMN)**(-0.08D0)*FLA
38983 FB=1D0-FLA
38984
38985C...Separate valence and sea parts of parton distribution.
38986 IF(KFA.NE.22) THEN
38987 XFVA1=XPA(KFV1)-XPA(-KFV1)
38988 XPA(KFV1)=XPA(-KFV1)
38989 XFVA2=XPA(KFV2)-XPA(-KFV2)
38990 XPA(KFV2)=XPA(-KFV2)
38991 XFVB1=XPB(KFV1)-XPB(-KFV1)
38992 XPB(KFV1)=XPB(-KFV1)
38993 XFVB2=XPB(KFV2)-XPB(-KFV2)
38994 XPB(KFV2)=XPB(-KFV2)
38995 ELSE
38996 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38997 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38998 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38999 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
39000 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
39001 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39002 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39003 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39004 ENDIF
39005
39006C...Interpolate for valence and sea. Put back together.
39007 DO 130 KFL=-25,25
39008 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39009 130 CONTINUE
39010 IF(KFA.NE.22) THEN
39011 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39012 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39013 ELSE
39014 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39015 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39016 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39017 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39018 ENDIF
39019 MINT(92)=3
39020
39021C...Small Q2 and small x: dampen boundary value and add term.
39022 ELSE
39023
39024C...Evaluate at boundary and define dampening factors.
39025 MINT(30)=MINT30
39026 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39027 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39028 FA=1D0-FB
39029 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39030 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39031 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39032 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39033 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39034 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39035
39036C...Separate valence and sea parts of parton distribution.
39037 IF(KFA.NE.22) THEN
39038 XFV1=XPA(KFV1)-XPA(-KFV1)
39039 XPA(KFV1)=XPA(-KFV1)
39040 XFV2=XPA(KFV2)-XPA(-KFV2)
39041 XPA(KFV2)=XPA(-KFV2)
39042 ELSE
39043 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39044 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39045 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39046 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39047 ENDIF
39048
39049C...Dampen valence and sea separately. Add constant terms.
39050C...Put back together.
39051 DO 140 KFL=-25,25
39052 XPQ(KFL)=FSA*XPA(KFL)
39053 140 CONTINUE
39054 IF(KFA.NE.22) THEN
39055 DO 150 KFL=-3,3
39056 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39057 150 CONTINUE
39058 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39059 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39060 ELSE
39061 DO 160 KFL=-3,3
39062 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39063 160 CONTINUE
39064 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39065 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39066 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39067 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39068 ENDIF
39069 XPQ(21)=XPQ(0)
39070 MINT(92)=4
39071 ENDIF
39072
39073C...Format for error printout.
39074 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39075
39076 RETURN
39077 END
39078
39079C*********************************************************************
39080
39081C...PYPDEL
39082C...Gives electron (or muon, or tau) parton distribution.
39083
39084 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39085
39086C...Double precision and integer declarations.
39087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39088 IMPLICIT INTEGER(I-N)
39089 INTEGER PYK,PYCHGE,PYCOMP
39090C...Commonblocks.
39091 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39092 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39093 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39094 COMMON/PYINT1/MINT(400),VINT(400)
39095 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39096C...Local arrays.
39097 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39098
39099C...Interface to PDFLIB.
39100 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39101 SAVE /W50513/
39102 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39103 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39104 CHARACTER*20 PARM(20)
39105 DATA VALUE/20*0D0/,PARM/20*' '/
39106
39107C...Some common constants.
39108 DO 100 KFL=-25,25
39109 XPEL(KFL)=0D0
39110 100 CONTINUE
39111 AEM=PARU(101)
39112 PME=PMAS(11,1)
39113 IF(KFA.EQ.13) PME=PMAS(13,1)
39114 IF(KFA.EQ.15) PME=PMAS(15,1)
39115 XL=LOG(MAX(1D-10,X))
39116 X1L=LOG(MAX(1D-10,1D0-X))
39117 HLE=LOG(MAX(3D0,Q2/PME**2))
39118 HBE2=(AEM/PARU(1))*(HLE-1D0)
39119
39120C...Electron inside electron, see R. Kleiss et al., in Z physics at
39121C...LEP 1, CERN 89-08, p. 34
39122 IF(MSTP(59).LE.1) THEN
39123 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39124 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39125 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39126 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39127 & 4D0*XL/(1D0-X)-5D0-X)
39128 ELSE
39129 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39130 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39131 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39132 ENDIF
39133C...Zero distribution for very large x and rescale it for intermediate.
39134 IF(X.GT.1D0-1D-10) THEN
39135 HEE=0D0
39136 ELSEIF(X.GT.1D0-1D-7) THEN
39137 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39138 ENDIF
39139 XPEL(KFA)=X*HEE
39140
39141C...Photon and (transverse) W- inside electron.
39142 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39143 IF(MSTP(13).LE.1) THEN
39144 HLG=HLE
39145 ELSE
39146 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39147 ENDIF
39148 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39149 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39150 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39151
39152C...Electron or positron inside photon inside electron.
39153 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39154 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39155 & 2D0*X*(1D0+X)*XL)
39156 XPEL(11)=XPEL(11)+XFSEA
39157 XPEL(-11)=XFSEA
39158
39159C...Initialize PDFLIB photon parton distributions.
39160 IF(MSTP(56).EQ.2) THEN
39161 PARM(1)='NPTYPE'
39162 VALUE(1)=3
39163 PARM(2)='NGROUP'
39164 VALUE(2)=MSTP(55)/1000
39165 PARM(3)='NSET'
39166 VALUE(3)=MOD(MSTP(55),1000)
39167 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39168 CALL PDFSET_ALICE(PARM,VALUE)
39169 MINT(93)=3000000+MSTP(55)
39170 ENDIF
39171 ENDIF
39172
39173C...Quarks and gluons inside photon inside electron:
39174C...numerical convolution required.
39175 DO 110 KFL=0,6
39176 SXP(KFL)=0D0
39177 110 CONTINUE
39178 SUMXPP=0D0
39179 ITER=-1
39180 120 ITER=ITER+1
39181 SUMXP=SUMXPP
39182 NSTP=2**(ITER-1)
39183 IF(ITER.EQ.0) NSTP=2
39184 DO 130 KFL=0,6
39185 SXP(KFL)=0.5D0*SXP(KFL)
39186 130 CONTINUE
39187 WTSTP=0.5D0/NSTP
39188 IF(ITER.EQ.0) WTSTP=0.5D0
39189C...Pick grid of x_{gamma} values logarithmically even.
39190 DO 150 ISTP=1,NSTP
39191 IF(ITER.EQ.0) THEN
39192 XLE=XL*(ISTP-1)
39193 ELSE
39194 XLE=XL*(ISTP-0.5D0)/NSTP
39195 ENDIF
39196 XE=MIN(1D0-1D-10,EXP(XLE))
39197 XG=MIN(1D0-1D-10,X/XE)
39198C...Evaluate photon inside electron parton distribution for convolution.
39199 XPGP=1D0+(1D0-XE)**2
39200 IF(MSTP(13).LE.1) THEN
39201 XPGP=XPGP*HLE
39202 ELSE
39203 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39204 ENDIF
39205C...Evaluate photon parton distributions for convolution.
39206 IF(MSTP(56).EQ.1) THEN
39207 IF(MSTP(55).EQ.1) THEN
39208 CALL PYPDGA(XG,Q2,XPGA)
39209 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39210 Q2MX=Q2
39211 P2MX=0.36D0
39212 IF(MSTP(55).GE.7) P2MX=4.0D0
39213 IF(MSTP(57).EQ.0) Q2MX=P2MX
39214 P2=0D0
39215 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39216 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39217 VINT(231)=P2MX
39218 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39219 Q2MX=Q2
39220 P2MX=0.36D0
39221 IF(MSTP(55).GE.11) P2MX=4.0D0
39222 IF(MSTP(57).EQ.0) Q2MX=P2MX
39223 P2=0D0
39224 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39225 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39226 VINT(231)=P2MX
39227 ENDIF
39228 DO 140 KFL=0,5
39229 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39230 140 CONTINUE
39231 ELSEIF(MSTP(56).EQ.2) THEN
39232C...Call PDFLIB parton distributions.
39233 XX=XG
39234 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39235 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39236 CALL STRUCTM_ALICE
39237 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39238 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39239 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39240 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39241 SXP(3)=SXP(3)+WTSTP*XPGP*STR
39242 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
39243 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
39244 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
39245 ENDIF
39246 150 CONTINUE
39247 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
39248 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
39249 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
39250
39251C...Put convolution into output arrays.
39252 FCONV=AEMP*(-XL)
39253 XPEL(0)=FCONV*SXP(0)
39254 DO 160 KFL=1,6
39255 XPEL(KFL)=FCONV*SXP(KFL)
39256 XPEL(-KFL)=XPEL(KFL)
39257 160 CONTINUE
39258 ENDIF
39259
39260 RETURN
39261 END
39262
39263C*********************************************************************
39264
39265C...PYPDGA
39266C...Gives photon parton distribution.
39267
39268 SUBROUTINE PYPDGA(X,Q2,XPGA)
39269
39270C...Double precision and integer declarations.
39271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39272 IMPLICIT INTEGER(I-N)
39273 INTEGER PYK,PYCHGE,PYCOMP
39274C...Commonblocks.
39275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39276 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39277 COMMON/PYINT1/MINT(400),VINT(400)
39278 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39279C...Local arrays.
39280 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
39281 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
39282 &DGCS(4,3),DGDS(4,3),DGES(4,3)
39283
39284C...The following data lines are coefficients needed in the
39285C...Drees and Grassie photon parton distribution parametrization.
39286 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
39287 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
39288 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
39289 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
39290 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
39291 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
39292 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
39293 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
39294 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
39295 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
39296 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
39297 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
39298 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
39299 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
39300 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
39301 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
39302 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
39303 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
39304 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
39305 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
39306 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
39307 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
39308 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
39309 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
39310 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
39311 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
39312
39313C...Photon parton distribution from Drees and Grassie.
39314C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39315 DO 100 KFL=-6,6
39316 XPGA(KFL)=0D0
39317 100 CONTINUE
39318 VINT(231)=1D0
39319 IF(MSTP(57).LE.0) THEN
39320 T=LOG(1D0/0.16D0)
39321 ELSE
39322 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
39323 ENDIF
39324 X1=1D0-X
39325 NF=3
39326 IF(Q2.GT.25D0) NF=4
39327 IF(Q2.GT.300D0) NF=5
39328 NFE=NF-2
39329 AEM=PARU(101)
39330
39331C...Evaluate gluon content.
39332 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
39333 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
39334 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
39335 XPGL=DGA*X**DGB*X1**DGC
39336
39337C...Evaluate up- and down-type quark content.
39338 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
39339 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
39340 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
39341 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
39342 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
39343 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39344 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
39345 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
39346 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
39347 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
39348 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
39349 DGF=9D0
39350 IF(NF.EQ.4) DGF=10D0
39351 IF(NF.EQ.5) DGF=55D0/6D0
39352 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39353 IF(NF.LE.3) THEN
39354 XPQU=(XPQS+9D0*XPQN)/6D0
39355 XPQD=(XPQS-4.5D0*XPQN)/6D0
39356 ELSEIF(NF.EQ.4) THEN
39357 XPQU=(XPQS+6D0*XPQN)/8D0
39358 XPQD=(XPQS-6D0*XPQN)/8D0
39359 ELSE
39360 XPQU=(XPQS+7.5D0*XPQN)/10D0
39361 XPQD=(XPQS-5D0*XPQN)/10D0
39362 ENDIF
39363
39364C...Put into output arrays.
39365 XPGA(0)=AEM*XPGL
39366 XPGA(1)=AEM*XPQD
39367 XPGA(2)=AEM*XPQU
39368 XPGA(3)=AEM*XPQD
39369 IF(NF.GE.4) XPGA(4)=AEM*XPQU
39370 IF(NF.GE.5) XPGA(5)=AEM*XPQD
39371 DO 110 KFL=1,6
39372 XPGA(-KFL)=XPGA(KFL)
39373 110 CONTINUE
39374
39375 RETURN
39376 END
39377
39378C*********************************************************************
39379
39380C...PYGGAM
39381C...Constructs the F2 and parton distributions of the photon
39382C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39383C...For F2, c and b are included by the Bethe-Heitler formula;
39384C...in the 'MSbar' scheme additionally a Cgamma term is added.
39385C...Contains the SaS sets 1D, 1M, 2D and 2M.
39386C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39387
39388 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39389
39390C...Double precision and integer declarations.
39391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39392 IMPLICIT INTEGER(I-N)
39393 INTEGER PYK,PYCHGE,PYCOMP
39394C...Commonblocks.
39395 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
39396 &XPDIR(-6:6)
39397 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
39398 SAVE /PYINT8/,/PYINT9/
39399C...Local arrays.
39400 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
39401C...Charm and bottom masses (low to compensate for J/psi etc.).
39402 DATA PMC/1.3D0/, PMB/4.6D0/
39403C...alpha_em and alpha_em/(2*pi).
39404 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
39405C...Lambda value for 4 flavours.
39406 DATA ALAM/0.20D0/
39407C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39408 DATA FRACU/0.8D0/
39409C...VMD couplings f_V**2/(4*pi).
39410 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
39411C...Masses for rho (=omega) and phi.
39412 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
39413C...Number of points in integration for IP2=1.
39414 DATA NSTEP/100/
39415
39416C...Reset output.
39417 F2GM=0D0
39418 DO 100 KFL=-6,6
39419 XPDFGM(KFL)=0D0
39420 XPVMD(KFL)=0D0
39421 XPANL(KFL)=0D0
39422 XPANH(KFL)=0D0
39423 XPBEH(KFL)=0D0
39424 XPDIR(KFL)=0D0
39425 VXPVMD(KFL)=0D0
39426 VXPANL(KFL)=0D0
39427 VXPANH(KFL)=0D0
39428 VXPDGM(KFL)=0D0
39429 100 CONTINUE
39430
39431C...Set Q0 cut-off parameter as function of set used.
39432 IF(ISET.LE.2) THEN
39433 Q0=0.6D0
39434 ELSE
39435 Q0=2D0
39436 ENDIF
39437 Q02=Q0**2
39438
39439C...Scale choice for off-shell photon; common factors.
39440 Q2A=Q2
39441 FACNOR=1D0
39442 IF(IP2.EQ.1) THEN
39443 P2MX=P2+Q02
39444 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39445 FACNOR=LOG(Q2/Q02)/NSTEP
39446 ELSEIF(IP2.EQ.2) THEN
39447 P2MX=MAX(P2,Q02)
39448 ELSEIF(IP2.EQ.3) THEN
39449 P2MX=P2+Q02
39450 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39451 ELSEIF(IP2.EQ.4) THEN
39452 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39453 & ((Q2+P2)*(Q02+P2)))
39454 ELSEIF(IP2.EQ.5) THEN
39455 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39456 & ((Q2+P2)*(Q02+P2)))
39457 P2MX=Q0*SQRT(P2MXA)
39458 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
39459 ELSEIF(IP2.EQ.6) THEN
39460 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39461 & ((Q2+P2)*(Q02+P2)))
39462 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39463 ELSE
39464 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39465 & ((Q2+P2)*(Q02+P2)))
39466 P2MX=Q0*SQRT(P2MXA)
39467 P2MXB=P2MX
39468 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39469 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
39470 IF(ABS(Q2-Q02).GT.1D-6) THEN
39471 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
39472 ELSEIF(P2.LT.Q02) THEN
39473 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
39474 ELSE
39475 FACNOR=1D0
39476 ENDIF
39477 ENDIF
39478
39479C...Call VMD parametrization for d quark and use to give rho, omega,
39480C...phi. Note dipole dampening for off-shell photon.
39481 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39482 XFVAL=VXPGA(1)
39483 XPGA(1)=XPGA(2)
39484 XPGA(-1)=XPGA(-2)
39485 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
39486 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
39487 DO 110 KFL=-5,5
39488 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
39489 110 CONTINUE
39490 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
39491 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
39492 XPVMD(3)=XPVMD(3)+FACS*XFVAL
39493 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
39494 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
39495 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
39496 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
39497 VXPVMD(2)=FRACU*FACUD*XFVAL
39498 VXPVMD(3)=FACS*XFVAL
39499 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
39500 VXPVMD(-2)=FRACU*FACUD*XFVAL
39501 VXPVMD(-3)=FACS*XFVAL
39502
39503 IF(IP2.NE.1) THEN
39504C...Anomalous parametrizations for different strategies
39505C...for off-shell photons; except full integration.
39506
39507C...Call anomalous parametrization for d + u + s.
39508 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39509 DO 120 KFL=-5,5
39510 XPANL(KFL)=FACNOR*XPGA(KFL)
39511 VXPANL(KFL)=FACNOR*VXPGA(KFL)
39512 120 CONTINUE
39513
39514C...Call anomalous parametrization for c and b.
39515 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39516 DO 130 KFL=-5,5
39517 XPANH(KFL)=FACNOR*XPGA(KFL)
39518 VXPANH(KFL)=FACNOR*VXPGA(KFL)
39519 130 CONTINUE
39520 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39521 DO 140 KFL=-5,5
39522 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
39523 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
39524 140 CONTINUE
39525
39526 ELSE
39527C...Special option: loop over flavours and integrate over k2.
39528 DO 170 KF=1,5
39529 DO 160 ISTEP=1,NSTEP
39530 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
39531 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
39532 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
39533 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
39534 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
39535 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
39536 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
39537 DO 150 KFL=-5,5
39538 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
39539 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
39540 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
39541 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
39542 150 CONTINUE
39543 160 CONTINUE
39544 170 CONTINUE
39545 ENDIF
39546
39547C...Call Bethe-Heitler term expression for charm and bottom.
39548 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
39549 XPBEH(4)=XPBH
39550 XPBEH(-4)=XPBH
39551 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
39552 XPBEH(5)=XPBH
39553 XPBEH(-5)=XPBH
39554
39555C...For MSbar subtraction call C^gamma term expression for d, u, s.
39556 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
39557 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
39558 DO 180 KFL=-5,5
39559 XPDIR(KFL)=XPGA(KFL)
39560 180 CONTINUE
39561 ENDIF
39562
39563C...Store result in output array.
39564 DO 190 KFL=-5,5
39565 CHSQ=1D0/9D0
39566 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
39567 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39568 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
39569 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
39570 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
39571 190 CONTINUE
39572
39573 RETURN
39574 END
39575
39576C*********************************************************************
39577
39578C...PYGVMD
39579C...Evaluates the VMD parton distributions of a photon,
39580C...evolved homogeneously from an initial scale P2 to Q2.
39581C...Does not include dipole suppression factor.
39582C...ISET is parton distribution set, see above;
39583C...additionally ISET=0 is used for the evolution of an anomalous photon
39584C...which branched at a scale P2 and then evolved homogeneously to Q2.
39585C...ALAM is the 4-flavour Lambda, which is automatically converted
39586C...to 3- and 5-flavour equivalents as needed.
39587C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39588
39589 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39590
39591C...Double precision and integer declarations.
39592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39593 IMPLICIT INTEGER(I-N)
39594 INTEGER PYK,PYCHGE,PYCOMP
39595C...Local arrays and data.
39596 DIMENSION XPGA(-6:6), VXPGA(-6:6)
39597 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39598
39599C...Reset output.
39600 DO 100 KFL=-6,6
39601 XPGA(KFL)=0D0
39602 VXPGA(KFL)=0D0
39603 100 CONTINUE
39604 KFA=IABS(KF)
39605
39606C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39607 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
39608 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
39609 P2EFF=MAX(P2,1.2D0*ALAM3**2)
39610 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39611 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39612 Q2EFF=MAX(Q2,P2EFF)
39613
39614C...Find number of flavours at lower and upper scale.
39615 NFP=4
39616 IF(P2EFF.LT.PMC**2) NFP=3
39617 IF(P2EFF.GT.PMB**2) NFP=5
39618 NFQ=4
39619 IF(Q2EFF.LT.PMC**2) NFQ=3
39620 IF(Q2EFF.GT.PMB**2) NFQ=5
39621
39622C...Find s as sum of 3-, 4- and 5-flavour parts.
39623 S=0D0
39624 IF(NFP.EQ.3) THEN
39625 Q2DIV=PMC**2
39626 IF(NFQ.EQ.3) Q2DIV=Q2EFF
39627 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
39628 ENDIF
39629 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
39630 P2DIV=P2EFF
39631 IF(NFP.EQ.3) P2DIV=PMC**2
39632 Q2DIV=Q2EFF
39633 IF(NFQ.EQ.5) Q2DIV=PMB**2
39634 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
39635 ENDIF
39636 IF(NFQ.EQ.5) THEN
39637 P2DIV=PMB**2
39638 IF(NFP.EQ.5) P2DIV=P2EFF
39639 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
39640 ENDIF
39641
39642C...Calculate frequent combinations of x and s.
39643 X1=1D0-X
39644 XL=-LOG(X)
39645 S2=S**2
39646 S3=S**3
39647 S4=S**4
39648
39649C...Evaluate homogeneous anomalous parton distributions below or
39650C...above threshold.
39651 IF(ISET.EQ.0) THEN
39652 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39653 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39654 XVAL = X * 1.5D0 * (X**2+X1**2)
39655 XGLU = 0D0
39656 XSEA = 0D0
39657 ELSE
39658 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
39659 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
39660 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
39661 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
39662 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
39663 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
39664 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
39665 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
39666 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
39667 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
39668 & (2D0*X-1D0)*X*XL**2)
39669 ENDIF
39670
39671C...Evaluate set 1D parton distributions below or above threshold.
39672 ELSEIF(ISET.EQ.1) THEN
39673 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39674 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39675 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
39676 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
39677 XSEA = 0.100D0 * X1**3.76D0
39678 ELSE
39679 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
39680 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
39681 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
39682 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
39683 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
39684 & X**0.40D0 * X1**(1.76D0+3D0*S)
39685 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
39686 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
39687 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
39688 XSEA0 = 0.100D0 * X1**3.76D0
39689 ENDIF
39690
39691C...Evaluate set 1M parton distributions below or above threshold.
39692 ELSEIF(ISET.EQ.2) THEN
39693 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39694 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39695 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
39696 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
39697 XSEA = 0D0
39698 ELSE
39699 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
39700 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
39701 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
39702 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
39703 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
39704 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
39705 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
39706 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
39707 & XL**(2.8D0*S)
39708 XSEA0 = 0D0
39709 ENDIF
39710
39711C...Evaluate set 2D parton distributions below or above threshold.
39712 ELSEIF(ISET.EQ.3) THEN
39713 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39714 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39715 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
39716 XGLU = 1.925D0 * X1**2
39717 XSEA = 0.242D0 * X1**4
39718 ELSE
39719 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
39720 & X**(0.46D0+0.25D0*S) *
39721 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
39722 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
39723 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
39724 & EXP(-18.67D0*S) *
39725 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
39726 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
39727 & XL**(9.3D0*S/(1D0+1.7D0*S))
39728 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
39729 & (1D0-0.607D0*S+21.95D0*S2) *
39730 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
39731 XSEA0 = 0.242D0 * X1**4
39732 ENDIF
39733
39734C...Evaluate set 2M parton distributions below or above threshold.
39735 ELSEIF(ISET.EQ.4) THEN
39736 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39737 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39738 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
39739 XGLU = 1.808D0 * X1**2
39740 XSEA = 0.209D0 * X1**4
39741 ELSE
39742 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
39743 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
39744 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
39745 & XL**(5.15D0*S/(1D0+2D0*S)) +
39746 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
39747 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
39748 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
39749 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
39750 & XL**(10.9D0*S/(1D0+2.5D0*S))
39751 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
39752 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
39753 & X1**(4D0+S) * XL**(0.45D0*S)
39754 XSEA0 = 0.209D0 * X1**4
39755 ENDIF
39756 ENDIF
39757
39758C...Threshold factors for c and b sea.
39759 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39760 XCHM=0D0
39761 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39762 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39763 IF(ISET.EQ.0) THEN
39764 XCHM=XSEA*(1D0-(SCH/SLL)**2)
39765 ELSE
39766 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
39767 ENDIF
39768 ENDIF
39769 XBOT=0D0
39770 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39771 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39772 IF(ISET.EQ.0) THEN
39773 XBOT=XSEA*(1D0-(SBT/SLL)**2)
39774 ELSE
39775 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
39776 ENDIF
39777 ENDIF
39778
39779C...Fill parton distributions.
39780 XPGA(0)=XGLU
39781 XPGA(1)=XSEA
39782 XPGA(2)=XSEA
39783 XPGA(3)=XSEA
39784 XPGA(4)=XCHM
39785 XPGA(5)=XBOT
39786 XPGA(KFA)=XPGA(KFA)+XVAL
39787 DO 110 KFL=1,5
39788 XPGA(-KFL)=XPGA(KFL)
39789 110 CONTINUE
39790 VXPGA(KFA)=XVAL
39791 VXPGA(-KFA)=XVAL
39792
39793 RETURN
39794 END
39795
39796C*********************************************************************
39797
39798C...PYGANO
39799C...Evaluates the parton distributions of the anomalous photon,
39800C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39801C...KF=0 gives the sum over (up to) 5 flavours,
39802C...KF<0 limits to flavours up to abs(KF),
39803C...KF>0 is for flavour KF only.
39804C...ALAM is the 4-flavour Lambda, which is automatically converted
39805C...to 3- and 5-flavour equivalents as needed.
39806C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39807
39808 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39809
39810C...Double precision and integer declarations.
39811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39812 IMPLICIT INTEGER(I-N)
39813 INTEGER PYK,PYCHGE,PYCOMP
39814C...Local arrays and data.
39815 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
39816 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39817
39818C...Reset output.
39819 DO 100 KFL=-6,6
39820 XPGA(KFL)=0D0
39821 VXPGA(KFL)=0D0
39822 100 CONTINUE
39823 IF(Q2.LE.P2) RETURN
39824 KFA=IABS(KF)
39825
39826C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39827 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
39828 ALAMSQ(4)=ALAM**2
39829 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
39830 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
39831 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39832 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39833 Q2EFF=MAX(Q2,P2EFF)
39834 XL=-LOG(X)
39835
39836C...Find number of flavours at lower and upper scale.
39837 NFP=4
39838 IF(P2EFF.LT.PMC**2) NFP=3
39839 IF(P2EFF.GT.PMB**2) NFP=5
39840 NFQ=4
39841 IF(Q2EFF.LT.PMC**2) NFQ=3
39842 IF(Q2EFF.GT.PMB**2) NFQ=5
39843
39844C...Define range of flavour loop.
39845 IF(KF.EQ.0) THEN
39846 KFLMN=1
39847 KFLMX=5
39848 ELSEIF(KF.LT.0) THEN
39849 KFLMN=1
39850 KFLMX=KFA
39851 ELSE
39852 KFLMN=KFA
39853 KFLMX=KFA
39854 ENDIF
39855
39856C...Loop over flavours the photon can branch into.
39857 DO 110 KFL=KFLMN,KFLMX
39858
39859C...Light flavours: calculate t range and (approximate) s range.
39860 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
39861 TDIFF=LOG(Q2EFF/P2EFF)
39862 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39863 & LOG(P2EFF/ALAMSQ(NFQ)))
39864 IF(NFQ.GT.NFP) THEN
39865 Q2DIV=PMB**2
39866 IF(NFQ.EQ.4) Q2DIV=PMC**2
39867 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39868 & LOG(P2EFF/ALAMSQ(NFQ)))
39869 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39870 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39871 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39872 ENDIF
39873 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
39874 Q2DIV=PMC**2
39875 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
39876 & LOG(P2EFF/ALAMSQ(4)))
39877 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
39878 & LOG(P2EFF/ALAMSQ(3)))
39879 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
39880 ENDIF
39881
39882C...u and s quark do not need a separate treatment when d has been done.
39883 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
39884
39885C...Charm: as above, but only include range above c threshold.
39886 ELSEIF(KFL.EQ.4) THEN
39887 IF(Q2.LE.PMC**2) GOTO 110
39888 P2EFF=MAX(P2EFF,PMC**2)
39889 Q2EFF=MAX(Q2EFF,P2EFF)
39890 TDIFF=LOG(Q2EFF/P2EFF)
39891 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39892 & LOG(P2EFF/ALAMSQ(NFQ)))
39893 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
39894 Q2DIV=PMB**2
39895 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39896 & LOG(P2EFF/ALAMSQ(NFQ)))
39897 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39898 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39899 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39900 ENDIF
39901
39902C...Bottom: as above, but only include range above b threshold.
39903 ELSEIF(KFL.EQ.5) THEN
39904 IF(Q2.LE.PMB**2) GOTO 110
39905 P2EFF=MAX(P2EFF,PMB**2)
39906 Q2EFF=MAX(Q2,P2EFF)
39907 TDIFF=LOG(Q2EFF/P2EFF)
39908 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39909 & LOG(P2EFF/ALAMSQ(NFQ)))
39910 ENDIF
39911
39912C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39913 CHSQ=1D0/9D0
39914 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39915 FAC=AEM2PI*2D0*CHSQ*TDIFF
39916
39917C...Evaluate parton distributions (normalized to unit momentum sum).
39918 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39919 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39920 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39921 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39922 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39923 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39924 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39925 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39926 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39927 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39928 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39929 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39930
39931C...Threshold factors for c and b sea.
39932 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39933 XCHM=0D0
39934 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39935 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39936 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39937 ENDIF
39938 XBOT=0D0
39939 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39940 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39941 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39942 ENDIF
39943 ENDIF
39944
39945C...Add contribution of each valence flavour.
39946 XPGA(0)=XPGA(0)+FAC*XGLU
39947 XPGA(1)=XPGA(1)+FAC*XSEA
39948 XPGA(2)=XPGA(2)+FAC*XSEA
39949 XPGA(3)=XPGA(3)+FAC*XSEA
39950 XPGA(4)=XPGA(4)+FAC*XCHM
39951 XPGA(5)=XPGA(5)+FAC*XBOT
39952 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39953 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39954 110 CONTINUE
39955 DO 120 KFL=1,5
39956 XPGA(-KFL)=XPGA(KFL)
39957 VXPGA(-KFL)=VXPGA(KFL)
39958 120 CONTINUE
39959
39960 RETURN
39961 END
39962
39963
39964C*********************************************************************
39965
39966C...PYGBEH
39967C...Evaluates the Bethe-Heitler cross section for heavy flavour
39968C...production.
39969C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39970
39971 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39972
39973C...Double precision and integer declarations.
39974 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39975 IMPLICIT INTEGER(I-N)
39976 INTEGER PYK,PYCHGE,PYCOMP
39977
39978C...Local data.
39979 DATA AEM2PI/0.0011614D0/
39980
39981C...Reset output.
39982 XPBH=0D0
39983 SIGBH=0D0
39984
39985C...Check kinematics limits.
39986 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39987 W2=Q2*(1D0-X)/X-P2
39988 BETA2=1D0-4D0*PM2/W2
39989 IF(BETA2.LT.1D-10) RETURN
39990 BETA=SQRT(BETA2)
39991 RMQ=4D0*PM2/Q2
39992
39993C...Simple case: P2 = 0.
39994 IF(P2.LT.1D-4) THEN
39995 IF(BETA.LT.0.99D0) THEN
39996 XBL=LOG((1D0+BETA)/(1D0-BETA))
39997 ELSE
39998 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39999 ENDIF
40000 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
40001 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40002
40003C...Complicated case: P2 > 0, based on approximation of
40004C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40005 ELSE
40006 RPQ=1D0-4D0*X**2*P2/Q2
40007 IF(RPQ.GT.1D-10) THEN
40008 RPBE=SQRT(RPQ*BETA2)
40009 IF(RPBE.LT.0.99D0) THEN
40010 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40011 XBI=2D0*RPBE/(1D0-RPBE**2)
40012 ELSE
40013 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40014 XBL=LOG((1D0+RPBE)**2/RPBESN)
40015 XBI=2D0*RPBE/RPBESN
40016 ENDIF
40017 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40018 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40019 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40020 ENDIF
40021 ENDIF
40022
40023C...Multiply by charge-squared etc. to get parton distribution.
40024 CHSQ=1D0/9D0
40025 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40026 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40027
40028 RETURN
40029 END
40030
40031C*********************************************************************
40032
40033C...PYGDIR
40034C...Evaluates the direct contribution, i.e. the C^gamma term,
40035C...as needed in MSbar parametrizations.
40036C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40037
40038 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40039
40040C...Double precision and integer declarations.
40041 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40042 IMPLICIT INTEGER(I-N)
40043 INTEGER PYK,PYCHGE,PYCOMP
40044C...Local array and data.
40045 DIMENSION XPGA(-6:6)
40046 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40047
40048C...Reset output.
40049 DO 100 KFL=-6,6
40050 XPGA(KFL)=0D0
40051 100 CONTINUE
40052
40053C...Evaluate common x-dependent expression.
40054 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40055 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40056
40057C...d, u, s part by simple charge factor.
40058 XPGA(1)=(1D0/9D0)*CGAM
40059 XPGA(2)=(4D0/9D0)*CGAM
40060 XPGA(3)=(1D0/9D0)*CGAM
40061
40062C...Also fill for antiquarks.
40063 DO 110 KF=1,5
40064 XPGA(-KF)=XPGA(KF)
40065 110 CONTINUE
40066
40067 RETURN
40068 END
40069
40070C*********************************************************************
40071
40072C...PYPDPI
40073C...Gives pi+ parton distribution according to two different
40074C...parametrizations.
40075
40076 SUBROUTINE PYPDPI(X,Q2,XPPI)
40077
40078C...Double precision and integer declarations.
40079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40080 IMPLICIT INTEGER(I-N)
40081 INTEGER PYK,PYCHGE,PYCOMP
40082C...Commonblocks.
40083 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40084 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40085 COMMON/PYINT1/MINT(400),VINT(400)
40086 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40087C...Local arrays.
40088 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40089
40090C...The following data lines are coefficients needed in the
40091C...Owens pion parton distribution parametrizations, see below.
40092C...Expansion coefficients for up and down valence quark distributions.
40093 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40094 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40095 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40096 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40097 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40098 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40099 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40100 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40101C...Expansion coefficients for gluon distribution.
40102 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40103 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40104 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40105 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40106 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40107 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40108 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40109 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40110C...Expansion coefficients for (up+down+strange) quark sea distribution.
40111 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40112 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40113 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40114 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40115 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40116 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40117 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40118 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40119C...Expansion coefficients for charm quark sea distribution.
40120 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40121 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40122 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40123 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40124 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40125 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40126 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40127 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40128
40129C...Euler's beta function, requires ordinary Gamma function
40130 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40131
40132C...Reset output array.
40133 DO 100 KFL=-6,6
40134 XPPI(KFL)=0D0
40135 100 CONTINUE
40136
40137 IF(MSTP(53).LE.2) THEN
40138C...Pion parton distributions from Owens.
40139C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40140
40141C...Determine set, Lambda and s expansion variable.
40142 NSET=MSTP(53)
40143 IF(NSET.EQ.1) ALAM=0.2D0
40144 IF(NSET.EQ.2) ALAM=0.4D0
40145 VINT(231)=4D0
40146 IF(MSTP(57).LE.0) THEN
40147 SD=0D0
40148 ELSE
40149 Q2IN=MIN(2D3,MAX(4D0,Q2))
40150 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40151 ENDIF
40152
40153C...Calculate parton distributions.
40154 DO 120 KFL=1,4
40155 DO 110 IS=1,5
40156 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40157 & COW(3,IS,KFL,NSET)*SD**2
40158 110 CONTINUE
40159 IF(KFL.EQ.1) THEN
40160 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40161 ELSE
40162 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40163 & TS(5)*X**2)
40164 ENDIF
40165 120 CONTINUE
40166
40167C...Put into output array.
40168 XPPI(0)=XQ(2)
40169 XPPI(1)=XQ(3)/6D0
40170 XPPI(2)=XQ(1)+XQ(3)/6D0
40171 XPPI(3)=XQ(3)/6D0
40172 XPPI(4)=XQ(4)
40173 XPPI(-1)=XQ(1)+XQ(3)/6D0
40174 XPPI(-2)=XQ(3)/6D0
40175 XPPI(-3)=XQ(3)/6D0
40176 XPPI(-4)=XQ(4)
40177
40178C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40179C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40180C...10^-5 < x < 1.
40181 ELSE
40182
40183C...Determine s expansion variable and some x expressions.
40184 VINT(231)=0.25D0
40185 IF(MSTP(57).LE.0) THEN
40186 SD=0D0
40187 ELSE
40188 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40189 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40190 ENDIF
40191 SD2=SD**2
40192 XL=-LOG(X)
40193 XS=SQRT(X)
40194
40195C...Evaluate valence, gluon and sea distributions.
40196 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40197 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40198 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40199 & SD-0.175D0*SD2)+
40200 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40201 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40202 & XL)))*
40203 & (1D0-X)**(0.390D0+1.053D0*SD)
40204 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40205 & X)**3.359D0*
40206 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40207 & XL))/
40208 & XL**(2.538D0-0.763D0*SD)
40209 IF(SD.LE.0.888D0) THEN
40210 XFCHM=0D0
40211 ELSE
40212 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40213 & 0.771D0*SD)*
40214 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40215 & XL))
40216 ENDIF
40217 IF(SD.LE.1.351D0) THEN
40218 XFBOT=0D0
40219 ELSE
40220 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40221 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40222 & XL))
40223 ENDIF
40224
40225C...Put into output array.
40226 XPPI(0)=XFGLU
40227 XPPI(1)=XFSEA
40228 XPPI(2)=XFSEA
40229 XPPI(3)=XFSEA
40230 XPPI(4)=XFCHM
40231 XPPI(5)=XFBOT
40232 DO 130 KFL=1,5
40233 XPPI(-KFL)=XPPI(KFL)
40234 130 CONTINUE
40235 XPPI(2)=XPPI(2)+XFVAL
40236 XPPI(-1)=XPPI(-1)+XFVAL
40237 ENDIF
40238
40239 RETURN
40240 END
40241
40242C*********************************************************************
40243
40244C...PYPDPR
40245C...Gives proton parton distributions according to a few different
40246C...parametrizations.
40247
40248 SUBROUTINE PYPDPR(X,Q2,XPPR)
40249
40250C...Double precision and integer declarations.
40251 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40252 IMPLICIT INTEGER(I-N)
40253 INTEGER PYK,PYCHGE,PYCOMP
40254C...Commonblocks.
40255 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40256 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40257 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40258 COMMON/PYINT1/MINT(400),VINT(400)
40259 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40260C...Arrays and data.
40261 DIMENSION XPPR(-6:6),Q2MIN(16)
40262 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
40263 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
40264
40265C...Reset output array.
40266 DO 100 KFL=-6,6
40267 XPPR(KFL)=0D0
40268 100 CONTINUE
40269
40270C...Common preliminaries.
40271 NSET=MAX(1,MIN(16,MSTP(51)))
40272 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
40273 VINT(231)=Q2MIN(NSET)
40274 IF(MSTP(57).EQ.0) THEN
40275 Q2L=Q2MIN(NSET)
40276 ELSE
40277 Q2L=MAX(Q2MIN(NSET),Q2)
40278 ENDIF
40279
40280 IF(NSET.GE.1.AND.NSET.LE.3) THEN
40281C...Interface to the CTEQ 3 parton distributions.
40282 QRT=SQRT(MAX(1D0,Q2L))
40283
40284C...Loop over flavours.
40285 DO 110 I=-6,6
40286 IF(I.LE.0) THEN
40287 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
40288 ELSEIF(I.LE.2) THEN
40289 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
40290 ELSE
40291 XPPR(I)=XPPR(-I)
40292 ENDIF
40293 110 CONTINUE
40294
40295 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
40296C...Interface to the GRV 94 distributions.
40297 IF(NSET.EQ.4) THEN
40298 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40299 ELSEIF(NSET.EQ.5) THEN
40300 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40301 ELSE
40302 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40303 ENDIF
40304
40305C...Put into output array.
40306 XPPR(0)=GL
40307 XPPR(-1)=0.5D0*(UDB+DEL)
40308 XPPR(-2)=0.5D0*(UDB-DEL)
40309 XPPR(-3)=SB
40310 XPPR(-4)=CHM
40311 XPPR(-5)=BOT
40312 XPPR(1)=DV+XPPR(-1)
40313 XPPR(2)=UV+XPPR(-2)
40314 XPPR(3)=SB
40315 XPPR(4)=CHM
40316 XPPR(5)=BOT
40317
40318 ELSEIF(NSET.EQ.7) THEN
40319C...Interface to the CTEQ 5L parton distributions.
40320C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40321C...freezing x*f(x,Q2) at borders.
40322 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40323 XIN=MAX(1D-6,MIN(1D0,X))
40324
40325C...Loop over flavours (with u <-> d notation mismatch).
40326 SUMUDB=PYCT5L(-1,XIN,QRT)
40327 RATUDB=PYCT5L(-2,XIN,QRT)
40328 DO 120 I=-5,2
40329 IF(I.EQ.1) THEN
40330 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
40331 ELSEIF(I.EQ.2) THEN
40332 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
40333 ELSEIF(I.EQ.-1) THEN
40334 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40335 ELSEIF(I.EQ.-2) THEN
40336 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40337 ELSE
40338 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
40339 IF(I.LT.0) XPPR(-I)=XPPR(I)
40340 ENDIF
40341 120 CONTINUE
40342
40343 ELSEIF(NSET.EQ.8) THEN
40344C...Interface to the CTEQ 5M1 parton distributions.
40345 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40346 XIN=MAX(1D-6,MIN(1D0,X))
40347
40348C...Loop over flavours (with u <-> d notation mismatch).
40349 SUMUDB=PYCT5M(-1,XIN,QRT)
40350 RATUDB=PYCT5M(-2,XIN,QRT)
40351 DO 130 I=-5,2
40352 IF(I.EQ.1) THEN
40353 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
40354 ELSEIF(I.EQ.2) THEN
40355 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
40356 ELSEIF(I.EQ.-1) THEN
40357 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40358 ELSEIF(I.EQ.-2) THEN
40359 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40360 ELSE
40361 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
40362 IF(I.LT.0) XPPR(-I)=XPPR(I)
40363 ENDIF
40364 130 CONTINUE
40365
40366 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
40367C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40368C...obsolete but offers backwards compatibility.
40369 CALL PYPDPO(X,Q2L,XPPR)
40370
40371C...Symmetric choice for debugging only
40372 ELSEIF(NSET.EQ.16) THEN
40373 XPPR(0)=.5D0/X
40374 XPPR(1)=.05D0/X
40375 XPPR(2)=.05D0/X
40376 XPPR(3)=.05D0/X
40377 XPPR(4)=.05D0/X
40378 XPPR(5)=.05D0/X
40379 XPPR(-1)=.05D0/X
40380 XPPR(-2)=.05D0/X
40381 XPPR(-3)=.05D0/X
40382 XPPR(-4)=.05D0/X
40383 XPPR(-5)=.05D0/X
40384
40385 ENDIF
40386
40387 RETURN
40388 END
40389
40390C*********************************************************************
40391
40392C...PYCTEQ
40393C...Gives the CTEQ 3 parton distribution function sets in
40394C...parametrized form, of October 24, 1994.
40395C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40396C...J. Qiu, W.K. Tung and H. Weerts.
40397
40398 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
40399
40400C...Double precision declaration.
40401 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40402 IMPLICIT INTEGER(I-N)
40403
40404C...Data on Lambda values of fits, minimum Q and quark masses.
40405 DIMENSION ALM(3), QMS(4:6)
40406 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
40407 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
40408
40409C....Check flavour thresholds. Set up QI for SB.
40410 IP = IABS(IPRT)
40411 IF(IP .GE. 4) THEN
40412 IF(Q .LE. QMS(IP)) THEN
40413 PYCTEQ = 0D0
40414 RETURN
40415 ENDIF
40416 QI = QMS(IP)
40417 ELSE
40418 QI = QMN
40419 ENDIF
40420
40421C...Use "standard lambda" of parametrization program for expansion.
40422 ALAM = ALM (ISET)
40423 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
40424 SB = LOG (SBL)
40425 SB2 = SB*SB
40426 SB3 = SB2*SB
40427
40428C...Expansion for CTEQ3L.
40429 IF(ISET .EQ. 1) THEN
40430 IF(IPRT .EQ. 2) THEN
40431 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
40432 & 0.3171D+00*SB3)
40433 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
40434 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
40435 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
40436 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
40437 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
40438 ELSEIF(IPRT .EQ. 1) THEN
40439 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
40440 & 0.7728D+00*SB3)
40441 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
40442 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
40443 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
40444 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
40445 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
40446 ELSEIF(IPRT .EQ. 0) THEN
40447 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
40448 & 0.5343D+00*SB3)
40449 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
40450 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
40451 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
40452 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
40453 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
40454 ELSEIF(IPRT .EQ. -1) THEN
40455 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
40456 & 0.2031D+01*SB3)
40457 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
40458 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
40459 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
40460 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
40461 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
40462 ELSEIF(IPRT .EQ. -2) THEN
40463 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
40464 & 0.9872D-01*SB3)
40465 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
40466 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
40467 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
40468 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
40469 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
40470 ELSEIF(IPRT .EQ. -3) THEN
40471 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
40472 & 0.8390D+00*SB3)
40473 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
40474 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
40475 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
40476 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
40477 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
40478 ELSEIF(IPRT .EQ. -4) THEN
40479 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
40480 & 0.1651D-01*SB2)
40481 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
40482 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
40483 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
40484 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
40485 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
40486 ELSEIF(IPRT .EQ. -5) THEN
40487 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
40488 & 0.3702D+01*SB2)
40489 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
40490 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
40491 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
40492 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
40493 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
40494 ELSEIF(IPRT .EQ. -6) THEN
40495 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
40496 & 0.6943D+00*SB2)
40497 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
40498 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
40499 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
40500 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
40501 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
40502 ENDIF
40503
40504C...Expansion for CTEQ3M.
40505 ELSEIF(ISET .EQ. 2) THEN
40506 IF(IPRT .EQ. 2) THEN
40507 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
40508 & 0.2935D+00*SB3)
40509 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
40510 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
40511 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
40512 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
40513 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
40514 ELSEIF(IPRT .EQ. 1) THEN
40515 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
40516 & 0.4305D-01*SB3)
40517 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
40518 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
40519 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
40520 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
40521 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
40522 ELSEIF(IPRT .EQ. 0) THEN
40523 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
40524 & 0.1037D-01*SB3)
40525 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
40526 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
40527 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
40528 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
40529 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
40530 ELSEIF(IPRT .EQ. -1) THEN
40531 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
40532 & 0.1602D+01*SB3)
40533 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
40534 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
40535 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
40536 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
40537 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
40538 ELSEIF(IPRT .EQ. -2) THEN
40539 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
40540 & 0.2496D+00*SB3)
40541 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
40542 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
40543 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
40544 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
40545 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
40546 ELSEIF(IPRT .EQ. -3) THEN
40547 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
40548 & 0.1936D+01*SB3)
40549 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
40550 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
40551 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
40552 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
40553 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
40554 ELSEIF(IPRT .EQ. -4) THEN
40555 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
40556 & 0.5348D+00*SB2)
40557 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
40558 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
40559 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
40560 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
40561 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
40562 ELSEIF(IPRT .EQ. -5) THEN
40563 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
40564 & 0.1569D+01*SB2)
40565 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
40566 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
40567 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
40568 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
40569 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
40570 ELSEIF(IPRT .EQ. -6) THEN
40571 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
40572 & 0.8838D+01*SB2)
40573 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
40574 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
40575 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
40576 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
40577 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
40578 ENDIF
40579
40580C...Expansion for CTEQ3D.
40581 ELSEIF(ISET .EQ. 3) THEN
40582 IF(IPRT .EQ. 2) THEN
40583 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
40584 & 0.2902D+00*SB3)
40585 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
40586 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
40587 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
40588 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
40589 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
40590 ELSEIF(IPRT .EQ. 1) THEN
40591 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
40592 & 0.7257D+00*SB3)
40593 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
40594 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
40595 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
40596 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
40597 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
40598 ELSEIF(IPRT .EQ. 0) THEN
40599 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
40600 & 0.2734D-04*SB3)
40601 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
40602 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
40603 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
40604 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
40605 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
40606 ELSEIF(IPRT .EQ. -1) THEN
40607 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
40608 & 0.1671D+01*SB3)
40609 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
40610 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
40611 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
40612 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
40613 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
40614 ELSEIF(IPRT .EQ. -2) THEN
40615 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
40616 & 0.2223D+00*SB3)
40617 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
40618 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
40619 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
40620 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
40621 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
40622 ELSEIF(IPRT .EQ. -3) THEN
40623 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
40624 & 0.1937D+01*SB3)
40625 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
40626 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
40627 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
40628 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
40629 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
40630 ELSEIF(IPRT .EQ. -4) THEN
40631 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
40632 & 0.5137D+00*SB2)
40633 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
40634 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
40635 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
40636 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
40637 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
40638 ELSEIF(IPRT .EQ. -5) THEN
40639 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
40640 & 0.2143D+01*SB2)
40641 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
40642 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
40643 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
40644 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
40645 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
40646 ELSEIF(IPRT .EQ. -6) THEN
40647 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
40648 & 0.9998D+01*SB2)
40649 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
40650 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
40651 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
40652 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
40653 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
40654 ENDIF
40655 ENDIF
40656
40657C...Calculation of x * f(x, Q).
40658 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
40659 & *(LOG(1D0+1D0/X))**A5 )
40660
40661 RETURN
40662 END
40663
40664C*********************************************************************
40665
40666C...PYGRVL
40667C...Gives the GRV 94 L (leading order) parton distribution function set
40668C...in parametrized form.
40669C...Authors: M. Glueck, E. Reya and A. Vogt.
40670
40671 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40672
40673C...Double precision declaration.
40674 IMPLICIT DOUBLE PRECISION (A - Z)
40675
40676C...Common expressions.
40677 MU2 = 0.23D0
40678 LAM2 = 0.2322D0 * 0.2322D0
40679 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40680 DS = SQRT (S)
40681 S2 = S * S
40682 S3 = S2 * S
40683
40684C...uv :
40685 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
40686 AKU = 0.590D0 - 0.024D0 * S
40687 BKU = 0.131D0 + 0.063D0 * S
40688 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
40689 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
40690 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
40691 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
40692 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40693
40694C...dv :
40695 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
40696 AKD = 0.376D0
40697 BKD = 0.486D0 + 0.062D0 * S
40698 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
40699 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
40700 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
40701 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
40702 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40703
40704C...del :
40705 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
40706 AKE = 0.409D0 - 0.005D0 * S
40707 BKE = 0.799D0 + 0.071D0 * S
40708 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
40709 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
40710 CE = 0.0D0
40711 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
40712 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40713
40714C...udb :
40715 ALX = 1.451D0
40716 BEX = 0.271D0
40717 AKX = 0.410D0 - 0.232D0 * S
40718 BKX = 0.534D0 - 0.457D0 * S
40719 AGX = 0.890D0 - 0.140D0 * S
40720 BGX = -0.981D0
40721 CX = 0.320D0 + 0.683D0 * S
40722 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
40723 EX = 4.119D0 + 1.713D0 * S
40724 ESX = 0.682D0 + 2.978D0 * S
40725 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40726 & DX, EX, ESX)
40727
40728C...sb :
40729 STS = 0D0
40730 ALS = 0.914D0
40731 BES = 0.577D0
40732 AKS = 1.798D0 - 0.596D0 * S
40733 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
40734 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
40735 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
40736 EST = 3.981D0 + 1.638D0 * S
40737 ESS = 6.402D0
40738 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40739
40740C...cb :
40741 STC = 0.888D0
40742 ALC = 1.01D0
40743 BEC = 0.37D0
40744 AKC = 0D0
40745 AC = 0D0
40746 BC = 4.24D0 - 0.804D0 * S
40747 DCT = 3.46D0 - 1.076D0 * S
40748 ECT = 4.61D0 + 1.49D0 * S
40749 ESC = 2.555D0 + 1.961D0 * S
40750 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40751
40752C...bb :
40753 STB = 1.351D0
40754 ALB = 1.00D0
40755 BEB = 0.51D0
40756 AKB = 0D0
40757 AB = 0D0
40758 BB = 1.848D0
40759 DBT = 2.929D0 + 1.396D0 * S
40760 EBT = 4.71D0 + 1.514D0 * S
40761 ESB = 4.02D0 + 1.239D0 * S
40762 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40763
40764C...gl :
40765 ALG = 0.524D0
40766 BEG = 1.088D0
40767 AKG = 1.742D0 - 0.930D0 * S
40768 BKG = - 0.399D0 * S2
40769 AG = 7.486D0 - 2.185D0 * S
40770 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
40771 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
40772 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
40773 EG = 0.807D0 + 2.005D0 * S
40774 ESG = 3.841D0 + 0.316D0 * S
40775 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
40776 & DG, EG, ESG)
40777
40778 RETURN
40779 END
40780
40781C*********************************************************************
40782
40783C...PYGRVM
40784C...Gives the GRV 94 M (MSbar) parton distribution function set
40785C...in parametrized form.
40786C...Authors: M. Glueck, E. Reya and A. Vogt.
40787
40788 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40789
40790C...Double precision declaration.
40791 IMPLICIT DOUBLE PRECISION (A - Z)
40792
40793C...Common expressions.
40794 MU2 = 0.34D0
40795 LAM2 = 0.248D0 * 0.248D0
40796 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40797 DS = SQRT (S)
40798 S2 = S * S
40799 S3 = S2 * S
40800
40801C...uv :
40802 NU = 1.304D0 + 0.863D0 * S
40803 AKU = 0.558D0 - 0.020D0 * S
40804 BKU = 0.183D0 * S
40805 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
40806 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
40807 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
40808 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
40809 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40810
40811C...dv :
40812 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
40813 AKD = 0.270D0 - 0.019D0 * S
40814 BKD = 0.260D0
40815 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
40816 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
40817 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
40818 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
40819 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40820
40821C...del :
40822 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
40823 AKE = 0.409D0 - 0.007D0 * S
40824 BKE = 0.782D0 + 0.082D0 * S
40825 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
40826 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
40827 CE = 0.0D0
40828 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
40829 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40830
40831C...udb :
40832 ALX = 0.877D0
40833 BEX = 0.561D0
40834 AKX = 0.275D0
40835 BKX = 0.0D0
40836 AGX = 0.997D0
40837 BGX = 3.210D0 - 1.866D0 * S
40838 CX = 7.300D0
40839 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
40840 EX = 3.077D0 + 1.446D0 * S
40841 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
40842 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40843 & DX, EX, ESX)
40844
40845C...sb :
40846 STS = 0D0
40847 ALS = 0.756D0
40848 BES = 0.216D0
40849 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
40850 AS = -4.329D0 + 1.131D0 * S
40851 BS = 9.568D0 - 1.744D0 * S
40852 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
40853 EST = 3.031D0 + 1.639D0 * S
40854 ESS = 5.837D0 + 0.815D0 * S
40855 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40856
40857C...cb :
40858 STC = 0.820D0
40859 ALC = 0.98D0
40860 BEC = 0D0
40861 AKC = -0.625D0 - 0.523D0 * S
40862 AC = 0D0
40863 BC = 1.896D0 + 1.616D0 * S
40864 DCT = 4.12D0 + 0.683D0 * S
40865 ECT = 4.36D0 + 1.328D0 * S
40866 ESC = 0.677D0 + 0.679D0 * S
40867 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40868
40869C...bb :
40870 STB = 1.297D0
40871 ALB = 0.99D0
40872 BEB = 0D0
40873 AKB = - 0.193D0 * S
40874 AB = 0D0
40875 BB = 0D0
40876 DBT = 3.447D0 + 0.927D0 * S
40877 EBT = 4.68D0 + 1.259D0 * S
40878 ESB = 1.892D0 + 2.199D0 * S
40879 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40880
40881C...gl :
40882 ALG = 1.014D0
40883 BEG = 1.738D0
40884 AKG = 1.724D0 + 0.157D0 * S
40885 BKG = 0.800D0 + 1.016D0 * S
40886 AG = 7.517D0 - 2.547D0 * S
40887 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
40888 CG = 4.039D0 + 1.491D0 * S
40889 DG = 3.404D0 + 0.830D0 * S
40890 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
40891 ESG = 3.256D0 - 0.436D0 * S
40892 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40893
40894 RETURN
40895 END
40896
40897C*********************************************************************
40898
40899C...PYGRVD
40900C...Gives the GRV 94 D (DIS) parton distribution function set
40901C...in parametrized form.
40902C...Authors: M. Glueck, E. Reya and A. Vogt.
40903
40904 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40905
40906C...Double precision declaration.
40907 IMPLICIT DOUBLE PRECISION (A - Z)
40908
40909C...Common expressions.
40910 MU2 = 0.34D0
40911 LAM2 = 0.248D0 * 0.248D0
40912 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40913 DS = SQRT (S)
40914 S2 = S * S
40915 S3 = S2 * S
40916
40917C...uv :
40918 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40919 AKU = 0.563D0 - 0.025D0 * S
40920 BKU = 0.054D0 + 0.154D0 * S
40921 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40922 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40923 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40924 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40925 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40926
40927C...dv :
40928 ND = 0.156D0 - 0.017D0 * S
40929 AKD = 0.299D0 - 0.022D0 * S
40930 BKD = 0.259D0 - 0.015D0 * S
40931 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40932 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40933 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40934 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40935 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40936
40937C...del :
40938 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40939 AKE = 0.419D0 - 0.013D0 * S
40940 BKE = 1.064D0 - 0.038D0 * S
40941 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40942 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40943 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40944 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40945 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40946
40947C...udb :
40948 ALX = 1.215D0
40949 BEX = 0.466D0
40950 AKX = 0.326D0 + 0.150D0 * S
40951 BKX = 0.956D0 + 0.405D0 * S
40952 AGX = 0.272D0
40953 BGX = 3.794D0 - 2.359D0 * DS
40954 CX = 2.014D0
40955 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40956 EX = 3.049D0 + 1.597D0 * S
40957 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40958 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40959 & DX, EX, ESX)
40960
40961C...sb :
40962 STS = 0D0
40963 ALS = 0.175D0
40964 BES = 0.344D0
40965 AKS = 1.415D0 - 0.641D0 * DS
40966 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40967 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40968 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40969 EST = 4.546D0 + 0.372D0 * S2
40970 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40971 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40972
40973C...cb :
40974 STC = 0.820D0
40975 ALC = 0.98D0
40976 BEC = 0D0
40977 AKC = -0.625D0 - 0.523D0 * S
40978 AC = 0D0
40979 BC = 1.896D0 + 1.616D0 * S
40980 DCT = 4.12D0 + 0.683D0 * S
40981 ECT = 4.36D0 + 1.328D0 * S
40982 ESC = 0.677D0 + 0.679D0 * S
40983 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40984
40985C...bb :
40986 STB = 1.297D0
40987 ALB = 0.99D0
40988 BEB = 0D0
40989 AKB = - 0.193D0 * S
40990 AB = 0D0
40991 BB = 0D0
40992 DBT = 3.447D0 + 0.927D0 * S
40993 EBT = 4.68D0 + 1.259D0 * S
40994 ESB = 1.892D0 + 2.199D0 * S
40995 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40996
40997C...gl :
40998 ALG = 1.258D0
40999 BEG = 1.846D0
41000 AKG = 2.423D0
41001 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
41002 AG = 25.09D0 - 7.935D0 * S
41003 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41004 CG = 590.3D0 - 173.8D0 * S
41005 DG = 5.196D0 + 1.857D0 * S
41006 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41007 ESG = 3.232D0 - 0.542D0 * S
41008 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41009
41010 RETURN
41011 END
41012
41013C*********************************************************************
41014
41015C...PYGRVV
41016C...Auxiliary for the GRV 94 parton distribution functions
41017C...for u and d valence and d-u sea.
41018C...Authors: M. Glueck, E. Reya and A. Vogt.
41019
41020 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41021
41022C...Double precision declaration.
41023 IMPLICIT DOUBLE PRECISION (A - Z)
41024
41025C...Evaluation.
41026 DX = SQRT (X)
41027 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41028 & (1D0- X)**D
41029
41030 RETURN
41031 END
41032
41033C*********************************************************************
41034
41035C...PYGRVW
41036C...Auxiliary for the GRV 94 parton distribution functions
41037C...for d+u sea and gluon.
41038C...Authors: M. Glueck, E. Reya and A. Vogt.
41039
41040 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41041
41042C...Double precision declaration.
41043 IMPLICIT DOUBLE PRECISION (A - Z)
41044
41045C...Evaluation.
41046 LX = LOG (1D0/X)
41047 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41048 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41049
41050 RETURN
41051 END
41052
41053C*********************************************************************
41054
41055C...PYGRVS
41056C...Auxiliary for the GRV 94 parton distribution functions
41057C...for s, c and b sea.
41058C...Authors: M. Glueck, E. Reya and A. Vogt.
41059
41060 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41061
41062C...Double precision declaration.
41063 IMPLICIT DOUBLE PRECISION (A - Z)
41064
41065C...Evaluation.
41066 IF(S.LE.STH) THEN
41067 PYGRVS = 0D0
41068 ELSE
41069 DX = SQRT (X)
41070 LX = LOG (1D0/X)
41071 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41072 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41073 ENDIF
41074
41075 RETURN
41076 END
41077
41078C*********************************************************************
41079
41080C...PYCT5L
41081C...Auxiliary function for parametrization of CTEQ5L.
41082C...Author: J. Pumplin 9/99.
41083
41084C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41085C...in Parametrized Form
41086C... September 15, 1999
41087C
41088C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41089C... CTEQ5 PPARTON DISTRIBUTIONS"
41090C...hep-ph/9903282
41091
41092C...The CTEQ5M1 set given here is an updated version of the original
41093C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41094C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41095C...almost all applications.
41096C...The improvement is in the QCD evolution which is now more
41097C...accurate, and which agrees completely with the benchmark work
41098C...of the HERA 96/97 Workshop.
41099C...The differences between the parametrized and the corresponding
41100C...table versions (on which it is based) are of similar order as
41101C...between the two version.
41102
41103C...!! Because accurate parametrizations over a wide range of (x,Q)
41104C...is hard to obtain, only the most widely used sets CTEQ5M and
41105C...CTEQ5L are available in parametrized form for now.
41106
41107C...These parametrizations were obtained by Jon Pumplin.
41108
41109C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41110C -------------------------------------------------------------------
41111C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41112C 3 CTEQ5L Leading Order 0.127 192 146
41113C -------------------------------------------------------------------
41114C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41115C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41116C...calibration.
41117
41118C...The two Iset value are adopted to agree with the standard table
41119C...versions.
41120
41121C...Range of validity:
41122C...The range of (x, Q) covered by this parametrization of the QCD
41123C...evolved parton distributions is 1E-6 < x < 1 ;
41124C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41125C...data only in a subset of that region; and the assumed DGLAP
41126C...evolution is unlikely to be valid for all of it either.
41127
41128C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41129C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41130C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41131C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41132
41133 FUNCTION PYCT5L(IFL,X,Q)
41134
41135C...Double precision declaration.
41136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41137 IMPLICIT INTEGER(I-N)
41138
41139 PARAMETER (NEX=8, NLF=2)
41140 DIMENSION AM(0:NEX,0:NLF,-5:2)
41141 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41142 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41143 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41144 DIMENSION AF(0:NEX)
41145
41146 DATA MEXVEC( 2) / 8 /
41147 DATA MLFVEC( 2) / 2 /
41148 DATA UT1VEC( 2) / 0.4971265E+01 /
41149 DATA UT2VEC( 2) / -0.1105128E+01 /
41150 DATA ALFVEC( 2) / 0.2987216E+00 /
41151 DATA QMAVEC( 2) / 0.0000000E+00 /
41152 DATA (AM( 0,K, 2),K=0, 2)
41153 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41154 DATA (AM( 1,K, 2),K=0, 2)
41155 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41156 DATA (AM( 2,K, 2),K=0, 2)
41157 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41158 DATA (AM( 3,K, 2),K=0, 2)
41159 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41160 DATA (AM( 4,K, 2),K=0, 2)
41161 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41162 DATA (AM( 5,K, 2),K=0, 2)
41163 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41164 DATA (AM( 6,K, 2),K=0, 2)
41165 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41166 DATA (AM( 7,K, 2),K=0, 2)
41167 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41168 DATA (AM( 8,K, 2),K=0, 2)
41169 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41170
41171 DATA MEXVEC( 1) / 8 /
41172 DATA MLFVEC( 1) / 2 /
41173 DATA UT1VEC( 1) / 0.2612618E+01 /
41174 DATA UT2VEC( 1) / -0.1258304E+06 /
41175 DATA ALFVEC( 1) / 0.3407552E+00 /
41176 DATA QMAVEC( 1) / 0.0000000E+00 /
41177 DATA (AM( 0,K, 1),K=0, 2)
41178 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41179 DATA (AM( 1,K, 1),K=0, 2)
41180 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41181 DATA (AM( 2,K, 1),K=0, 2)
41182 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41183 DATA (AM( 3,K, 1),K=0, 2)
41184 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41185 DATA (AM( 4,K, 1),K=0, 2)
41186 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41187 DATA (AM( 5,K, 1),K=0, 2)
41188 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41189 DATA (AM( 6,K, 1),K=0, 2)
41190 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41191 DATA (AM( 7,K, 1),K=0, 2)
41192 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41193 DATA (AM( 8,K, 1),K=0, 2)
41194 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41195
41196 DATA MEXVEC( 0) / 8 /
41197 DATA MLFVEC( 0) / 2 /
41198 DATA UT1VEC( 0) / -0.4656819E+00 /
41199 DATA UT2VEC( 0) / -0.2742390E+03 /
41200 DATA ALFVEC( 0) / 0.4491863E+00 /
41201 DATA QMAVEC( 0) / 0.0000000E+00 /
41202 DATA (AM( 0,K, 0),K=0, 2)
41203 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41204 DATA (AM( 1,K, 0),K=0, 2)
41205 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41206 DATA (AM( 2,K, 0),K=0, 2)
41207 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41208 DATA (AM( 3,K, 0),K=0, 2)
41209 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41210 DATA (AM( 4,K, 0),K=0, 2)
41211 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41212 DATA (AM( 5,K, 0),K=0, 2)
41213 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41214 DATA (AM( 6,K, 0),K=0, 2)
41215 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41216 DATA (AM( 7,K, 0),K=0, 2)
41217 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41218 DATA (AM( 8,K, 0),K=0, 2)
41219 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41220
41221 DATA MEXVEC(-1) / 8 /
41222 DATA MLFVEC(-1) / 2 /
41223 DATA UT1VEC(-1) / 0.3862583E+01 /
41224 DATA UT2VEC(-1) / -0.1265969E+01 /
41225 DATA ALFVEC(-1) / 0.2457668E+00 /
41226 DATA QMAVEC(-1) / 0.0000000E+00 /
41227 DATA (AM( 0,K,-1),K=0, 2)
41228 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41229 DATA (AM( 1,K,-1),K=0, 2)
41230 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41231 DATA (AM( 2,K,-1),K=0, 2)
41232 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41233 DATA (AM( 3,K,-1),K=0, 2)
41234 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41235 DATA (AM( 4,K,-1),K=0, 2)
41236 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41237 DATA (AM( 5,K,-1),K=0, 2)
41238 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41239 DATA (AM( 6,K,-1),K=0, 2)
41240 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41241 DATA (AM( 7,K,-1),K=0, 2)
41242 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
41243 DATA (AM( 8,K,-1),K=0, 2)
41244 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
41245
41246 DATA MEXVEC(-2) / 7 /
41247 DATA MLFVEC(-2) / 2 /
41248 DATA UT1VEC(-2) / 0.1895615E+00 /
41249 DATA UT2VEC(-2) / -0.3069097E+01 /
41250 DATA ALFVEC(-2) / 0.5293999E+00 /
41251 DATA QMAVEC(-2) / 0.0000000E+00 /
41252 DATA (AM( 0,K,-2),K=0, 2)
41253 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
41254 DATA (AM( 1,K,-2),K=0, 2)
41255 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
41256 DATA (AM( 2,K,-2),K=0, 2)
41257 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
41258 DATA (AM( 3,K,-2),K=0, 2)
41259 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
41260 DATA (AM( 4,K,-2),K=0, 2)
41261 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
41262 DATA (AM( 5,K,-2),K=0, 2)
41263 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
41264 DATA (AM( 6,K,-2),K=0, 2)
41265 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
41266 DATA (AM( 7,K,-2),K=0, 2)
41267 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
41268
41269 DATA MEXVEC(-3) / 7 /
41270 DATA MLFVEC(-3) / 2 /
41271 DATA UT1VEC(-3) / 0.3753257E+01 /
41272 DATA UT2VEC(-3) / -0.1113085E+01 /
41273 DATA ALFVEC(-3) / 0.3713141E+00 /
41274 DATA QMAVEC(-3) / 0.0000000E+00 /
41275 DATA (AM( 0,K,-3),K=0, 2)
41276 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
41277 DATA (AM( 1,K,-3),K=0, 2)
41278 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
41279 DATA (AM( 2,K,-3),K=0, 2)
41280 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
41281 DATA (AM( 3,K,-3),K=0, 2)
41282 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
41283 DATA (AM( 4,K,-3),K=0, 2)
41284 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
41285 DATA (AM( 5,K,-3),K=0, 2)
41286 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
41287 DATA (AM( 6,K,-3),K=0, 2)
41288 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
41289 DATA (AM( 7,K,-3),K=0, 2)
41290 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
41291
41292 DATA MEXVEC(-4) / 7 /
41293 DATA MLFVEC(-4) / 2 /
41294 DATA UT1VEC(-4) / 0.4400772E+01 /
41295 DATA UT2VEC(-4) / -0.1356116E+01 /
41296 DATA ALFVEC(-4) / 0.3712017E-01 /
41297 DATA QMAVEC(-4) / 0.1300000E+01 /
41298 DATA (AM( 0,K,-4),K=0, 2)
41299 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
41300 DATA (AM( 1,K,-4),K=0, 2)
41301 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
41302 DATA (AM( 2,K,-4),K=0, 2)
41303 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
41304 DATA (AM( 3,K,-4),K=0, 2)
41305 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
41306 DATA (AM( 4,K,-4),K=0, 2)
41307 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
41308 DATA (AM( 5,K,-4),K=0, 2)
41309 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
41310 DATA (AM( 6,K,-4),K=0, 2)
41311 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
41312 DATA (AM( 7,K,-4),K=0, 2)
41313 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
41314
41315 DATA MEXVEC(-5) / 6 /
41316 DATA MLFVEC(-5) / 2 /
41317 DATA UT1VEC(-5) / 0.5562568E+01 /
41318 DATA UT2VEC(-5) / -0.1801317E+01 /
41319 DATA ALFVEC(-5) / 0.4952010E-02 /
41320 DATA QMAVEC(-5) / 0.4500000E+01 /
41321 DATA (AM( 0,K,-5),K=0, 2)
41322 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
41323 DATA (AM( 1,K,-5),K=0, 2)
41324 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
41325 DATA (AM( 2,K,-5),K=0, 2)
41326 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
41327 DATA (AM( 3,K,-5),K=0, 2)
41328 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
41329 DATA (AM( 4,K,-5),K=0, 2)
41330 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
41331 DATA (AM( 5,K,-5),K=0, 2)
41332 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
41333 DATA (AM( 6,K,-5),K=0, 2)
41334 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
41335
41336 IF(Q .LE. QMAVEC(IFL)) THEN
41337 PYCT5L = 0.D0
41338 RETURN
41339 ENDIF
41340
41341 IF(X .GE. 1.D0) THEN
41342 PYCT5L = 0.D0
41343 RETURN
41344 ENDIF
41345
41346 TMP = LOG(Q/ALFVEC(IFL))
41347 IF(TMP .LE. 0.D0) THEN
41348 PYCT5L = 0.D0
41349 RETURN
41350 ENDIF
41351
41352 SB = LOG(TMP)
41353 SB1 = SB - 1.2D0
41354 SB2 = SB1*SB1
41355
41356 DO 110 I = 0, NEX
41357 AF(I) = 0.D0
41358 SBX = 1.D0
41359 DO 100 K = 0, MLFVEC(IFL)
41360 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41361 SBX = SB1*SBX
41362 100 CONTINUE
41363 110 CONTINUE
41364
41365 Y = -LOG(X)
41366 U = LOG(X/0.00001D0)
41367
41368 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41369 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41370 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41371 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41372 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41373
41374 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41375
41376C...Include threshold factor.
41377 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
41378
41379 RETURN
41380 END
41381
41382C*********************************************************************
41383
41384C...PYCT5M
41385C...Auxiliary function for parametrization of CTEQ5M1.
41386C...Author: J. Pumplin 9/99.
41387
41388 FUNCTION PYCT5M(IFL,X,Q)
41389
41390C...Double precision declaration.
41391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41392 IMPLICIT INTEGER(I-N)
41393
41394 PARAMETER (NEX=8, NLF=2)
41395 DIMENSION AM(0:NEX,0:NLF,-5:2)
41396 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41397 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41398 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41399 DIMENSION AF(0:NEX)
41400
41401 DATA MEXVEC( 2) / 8 /
41402 DATA MLFVEC( 2) / 2 /
41403 DATA UT1VEC( 2) / 0.5141718E+01 /
41404 DATA UT2VEC( 2) / -0.1346944E+01 /
41405 DATA ALFVEC( 2) / 0.5260555E+00 /
41406 DATA QMAVEC( 2) / 0.0000000E+00 /
41407 DATA (AM( 0,K, 2),K=0, 2)
41408 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
41409 DATA (AM( 1,K, 2),K=0, 2)
41410 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
41411 DATA (AM( 2,K, 2),K=0, 2)
41412 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
41413 DATA (AM( 3,K, 2),K=0, 2)
41414 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
41415 DATA (AM( 4,K, 2),K=0, 2)
41416 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
41417 DATA (AM( 5,K, 2),K=0, 2)
41418 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
41419 DATA (AM( 6,K, 2),K=0, 2)
41420 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
41421 DATA (AM( 7,K, 2),K=0, 2)
41422 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
41423 DATA (AM( 8,K, 2),K=0, 2)
41424 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
41425
41426 DATA MEXVEC( 1) / 8 /
41427 DATA MLFVEC( 1) / 2 /
41428 DATA UT1VEC( 1) / 0.4138426E+01 /
41429 DATA UT2VEC( 1) / -0.3221374E+01 /
41430 DATA ALFVEC( 1) / 0.4960962E+00 /
41431 DATA QMAVEC( 1) / 0.0000000E+00 /
41432 DATA (AM( 0,K, 1),K=0, 2)
41433 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
41434 DATA (AM( 1,K, 1),K=0, 2)
41435 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
41436 DATA (AM( 2,K, 1),K=0, 2)
41437 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
41438 DATA (AM( 3,K, 1),K=0, 2)
41439 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
41440 DATA (AM( 4,K, 1),K=0, 2)
41441 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
41442 DATA (AM( 5,K, 1),K=0, 2)
41443 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
41444 DATA (AM( 6,K, 1),K=0, 2)
41445 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
41446 DATA (AM( 7,K, 1),K=0, 2)
41447 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
41448 DATA (AM( 8,K, 1),K=0, 2)
41449 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
41450
41451 DATA MEXVEC( 0) / 8 /
41452 DATA MLFVEC( 0) / 2 /
41453 DATA UT1VEC( 0) / -0.1026789E+01 /
41454 DATA UT2VEC( 0) / -0.9051707E+01 /
41455 DATA ALFVEC( 0) / 0.9462977E+00 /
41456 DATA QMAVEC( 0) / 0.0000000E+00 /
41457 DATA (AM( 0,K, 0),K=0, 2)
41458 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
41459 DATA (AM( 1,K, 0),K=0, 2)
41460 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
41461 DATA (AM( 2,K, 0),K=0, 2)
41462 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
41463 DATA (AM( 3,K, 0),K=0, 2)
41464 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
41465 DATA (AM( 4,K, 0),K=0, 2)
41466 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
41467 DATA (AM( 5,K, 0),K=0, 2)
41468 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
41469 DATA (AM( 6,K, 0),K=0, 2)
41470 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
41471 DATA (AM( 7,K, 0),K=0, 2)
41472 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
41473 DATA (AM( 8,K, 0),K=0, 2)
41474 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
41475
41476 DATA MEXVEC(-1) / 8 /
41477 DATA MLFVEC(-1) / 2 /
41478 DATA UT1VEC(-1) / 0.5243571E+01 /
41479 DATA UT2VEC(-1) / -0.2870513E+01 /
41480 DATA ALFVEC(-1) / 0.6701448E+00 /
41481 DATA QMAVEC(-1) / 0.0000000E+00 /
41482 DATA (AM( 0,K,-1),K=0, 2)
41483 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
41484 DATA (AM( 1,K,-1),K=0, 2)
41485 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
41486 DATA (AM( 2,K,-1),K=0, 2)
41487 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
41488 DATA (AM( 3,K,-1),K=0, 2)
41489 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
41490 DATA (AM( 4,K,-1),K=0, 2)
41491 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
41492 DATA (AM( 5,K,-1),K=0, 2)
41493 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
41494 DATA (AM( 6,K,-1),K=0, 2)
41495 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
41496 DATA (AM( 7,K,-1),K=0, 2)
41497 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
41498 DATA (AM( 8,K,-1),K=0, 2)
41499 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
41500
41501 DATA MEXVEC(-2) / 7 /
41502 DATA MLFVEC(-2) / 2 /
41503 DATA UT1VEC(-2) / 0.4782210E+01 /
41504 DATA UT2VEC(-2) / -0.1976856E+02 /
41505 DATA ALFVEC(-2) / 0.7558374E+00 /
41506 DATA QMAVEC(-2) / 0.0000000E+00 /
41507 DATA (AM( 0,K,-2),K=0, 2)
41508 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
41509 DATA (AM( 1,K,-2),K=0, 2)
41510 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
41511 DATA (AM( 2,K,-2),K=0, 2)
41512 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
41513 DATA (AM( 3,K,-2),K=0, 2)
41514 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
41515 DATA (AM( 4,K,-2),K=0, 2)
41516 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
41517 DATA (AM( 5,K,-2),K=0, 2)
41518 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
41519 DATA (AM( 6,K,-2),K=0, 2)
41520 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
41521 DATA (AM( 7,K,-2),K=0, 2)
41522 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
41523
41524 DATA MEXVEC(-3) / 7 /
41525 DATA MLFVEC(-3) / 2 /
41526 DATA UT1VEC(-3) / 0.4518239E+01 /
41527 DATA UT2VEC(-3) / -0.2690590E+01 /
41528 DATA ALFVEC(-3) / 0.6124079E+00 /
41529 DATA QMAVEC(-3) / 0.0000000E+00 /
41530 DATA (AM( 0,K,-3),K=0, 2)
41531 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
41532 DATA (AM( 1,K,-3),K=0, 2)
41533 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
41534 DATA (AM( 2,K,-3),K=0, 2)
41535 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
41536 DATA (AM( 3,K,-3),K=0, 2)
41537 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
41538 DATA (AM( 4,K,-3),K=0, 2)
41539 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
41540 DATA (AM( 5,K,-3),K=0, 2)
41541 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
41542 DATA (AM( 6,K,-3),K=0, 2)
41543 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
41544 DATA (AM( 7,K,-3),K=0, 2)
41545 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
41546
41547 DATA MEXVEC(-4) / 7 /
41548 DATA MLFVEC(-4) / 2 /
41549 DATA UT1VEC(-4) / 0.2783230E+01 /
41550 DATA UT2VEC(-4) / -0.1746328E+01 /
41551 DATA ALFVEC(-4) / 0.1115653E+01 /
41552 DATA QMAVEC(-4) / 0.1300000E+01 /
41553 DATA (AM( 0,K,-4),K=0, 2)
41554 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
41555 DATA (AM( 1,K,-4),K=0, 2)
41556 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
41557 DATA (AM( 2,K,-4),K=0, 2)
41558 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
41559 DATA (AM( 3,K,-4),K=0, 2)
41560 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
41561 DATA (AM( 4,K,-4),K=0, 2)
41562 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
41563 DATA (AM( 5,K,-4),K=0, 2)
41564 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
41565 DATA (AM( 6,K,-4),K=0, 2)
41566 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
41567 DATA (AM( 7,K,-4),K=0, 2)
41568 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
41569
41570 DATA MEXVEC(-5) / 6 /
41571 DATA MLFVEC(-5) / 2 /
41572 DATA UT1VEC(-5) / 0.1619654E+02 /
41573 DATA UT2VEC(-5) / -0.3367346E+01 /
41574 DATA ALFVEC(-5) / 0.5109891E-02 /
41575 DATA QMAVEC(-5) / 0.4500000E+01 /
41576 DATA (AM( 0,K,-5),K=0, 2)
41577 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
41578 DATA (AM( 1,K,-5),K=0, 2)
41579 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
41580 DATA (AM( 2,K,-5),K=0, 2)
41581 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
41582 DATA (AM( 3,K,-5),K=0, 2)
41583 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
41584 DATA (AM( 4,K,-5),K=0, 2)
41585 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
41586 DATA (AM( 5,K,-5),K=0, 2)
41587 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
41588 DATA (AM( 6,K,-5),K=0, 2)
41589 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
41590
41591 IF(Q .LE. QMAVEC(IFL)) THEN
41592 PYCT5M = 0.D0
41593 RETURN
41594 ENDIF
41595
41596 IF(X .GE. 1.D0) THEN
41597 PYCT5M = 0.D0
41598 RETURN
41599 ENDIF
41600
41601 TMP = LOG(Q/ALFVEC(IFL))
41602 IF(TMP .LE. 0.D0) THEN
41603 PYCT5M = 0.D0
41604 RETURN
41605 ENDIF
41606
41607 SB = LOG(TMP)
41608 SB1 = SB - 1.2D0
41609 SB2 = SB1*SB1
41610
41611 DO 110 I = 0, NEX
41612 AF(I) = 0.D0
41613 SBX = 1.D0
41614 DO 100 K = 0, MLFVEC(IFL)
41615 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41616 SBX = SB1*SBX
41617 100 CONTINUE
41618 110 CONTINUE
41619
41620 Y = -LOG(X)
41621 U = LOG(X/0.00001D0)
41622
41623 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41624 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41625 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41626 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41627 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41628
41629 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41630
41631C...Include threshold factor.
41632 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
41633
41634 RETURN
41635 END
41636
41637C*********************************************************************
41638
41639C...PYPDPO
41640C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41641C...a few older parametrizations, now obsolete but convenient for
41642C...backwards checks.
41643
41644 SUBROUTINE PYPDPO(X,Q2,XPPR)
41645
41646C...Double precision and integer declarations.
41647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41648 IMPLICIT INTEGER(I-N)
41649 INTEGER PYK,PYCHGE,PYCOMP
41650C...Commonblocks.
41651 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41652 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41653 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41654 COMMON/PYINT1/MINT(400),VINT(400)
41655 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41656 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
41657 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
41658
41659
41660C...The following data lines are coefficients needed in the
41661C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41662C...parametrizations, see below.
41663C...Powers of 1-x in different cases.
41664 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41665C...Expansion coefficients for up valence quark distribution.
41666 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
41667 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
41668 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
41669 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
41670 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
41671 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
41672 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
41673 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
41674 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
41675 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
41676 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
41677 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
41678 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
41679 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
41680 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
41681 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
41682 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
41683 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
41684 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
41685 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
41686 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
41687 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
41688 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
41689 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
41690 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
41691 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
41692C...Expansion coefficients for down valence quark distribution.
41693 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
41694 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
41695 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
41696 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
41697 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
41698 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
41699 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
41700 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
41701 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
41702 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
41703 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
41704 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
41705 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
41706 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
41707 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
41708 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
41709 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
41710 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
41711 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
41712 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
41713 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
41714 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
41715 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
41716 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
41717 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
41718 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
41719C...Expansion coefficients for up and down sea quark distributions.
41720 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
41721 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
41722 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
41723 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
41724 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
41725 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
41726 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
41727 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
41728 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
41729 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
41730 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
41731 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
41732 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
41733 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
41734 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
41735 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
41736 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
41737 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
41738 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
41739 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
41740 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
41741 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
41742 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
41743 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
41744 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
41745 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
41746C...Expansion coefficients for gluon distribution.
41747 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
41748 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
41749 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
41750 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
41751 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
41752 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
41753 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
41754 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
41755 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
41756 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
41757 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
41758 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
41759 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
41760 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
41761 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
41762 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
41763 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
41764 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
41765 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
41766 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
41767 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
41768 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
41769 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
41770 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
41771 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
41772 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
41773C...Expansion coefficients for strange sea quark distribution.
41774 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
41775 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
41776 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
41777 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
41778 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
41779 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
41780 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
41781 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
41782 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
41783 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
41784 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
41785 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
41786 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
41787 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
41788 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
41789 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
41790 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
41791 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
41792 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
41793 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
41794 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
41795 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
41796 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
41797 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
41798 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
41799 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
41800C...Expansion coefficients for charm sea quark distribution.
41801 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
41802 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
41803 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
41804 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
41805 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
41806 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
41807 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
41808 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
41809 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
41810 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
41811 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
41812 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
41813 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
41814 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
41815 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
41816 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
41817 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
41818 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
41819 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
41820 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
41821 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
41822 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
41823 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
41824 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
41825 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
41826 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
41827C...Expansion coefficients for bottom sea quark distribution.
41828 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
41829 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
41830 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
41831 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
41832 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
41833 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
41834 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
41835 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
41836 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
41837 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
41838 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
41839 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
41840 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
41841 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
41842 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
41843 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
41844 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
41845 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
41846 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
41847 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
41848 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
41849 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
41850 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
41851 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
41852 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
41853 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
41854C...Expansion coefficients for top sea quark distribution.
41855 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
41856 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
41857 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
41858 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
41859 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41860 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
41861 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41862 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
41863 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
41864 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
41865 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
41866 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
41867 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
41868 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
41869 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
41870 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
41871 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
41872 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41873 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
41874 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41875 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
41876 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
41877 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
41878 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
41879 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
41880 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
41881
41882C...The following data lines are coefficients needed in the
41883C...Duke, Owens proton structure function parametrizations, see below.
41884C...Expansion coefficients for (up+down) valence quark distribution.
41885 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
41886 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41887 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41888 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41889 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
41890 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41891 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41892 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41893C...Expansion coefficients for down valence quark distribution.
41894 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
41895 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41896 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41897 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41898 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
41899 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41900 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41901 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41902C...Expansion coefficients for (up+down+strange) sea quark distribution.
41903 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
41904 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41905 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
41906 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41907 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41908 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41909 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41910 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41911C...Expansion coefficients for charm sea quark distribution.
41912 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41913 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41914 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41915 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41916 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41917 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41918 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41919 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41920C...Expansion coefficients for gluon distribution.
41921 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41922 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41923 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41924 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41925 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41926 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41927 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41928 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41929
41930C...Euler's beta function, requires ordinary Gamma function
41931 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41932
41933C...Leading order proton parton distributions from Glueck, Reya and
41934C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41935C...10^-5 < x < 1.
41936 IF(MSTP(51).EQ.11) THEN
41937
41938C...Determine s expansion variable and some x expressions.
41939 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41940 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41941 SD2=SD**2
41942 XL=-LOG(X)
41943 XS=SQRT(X)
41944
41945C...Evaluate valence, gluon and sea distributions.
41946 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41947 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41948 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41949 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41950 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41951 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41952 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41953 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41954 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41955 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41956 & SQRT(4.066D0*SD**1.218D0*XL)))*
41957 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41958 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41959 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41960 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41961 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41962 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41963 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41964 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41965 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41966 IF(SD.LE.0.888D0) THEN
41967 XFCHM=0D0
41968 ELSE
41969 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41970 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41971 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41972 ENDIF
41973 IF(SD.LE.1.351D0) THEN
41974 XFBOT=0D0
41975 ELSE
41976 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41977 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41978 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41979 ENDIF
41980
41981C...Put into output array.
41982 XPPR(0)=XFGLU
41983 XPPR(1)=XFVDD+XFSEA
41984 XPPR(2)=XFVUD-XFVDD+XFSEA
41985 XPPR(3)=XFSTR
41986 XPPR(4)=XFCHM
41987 XPPR(5)=XFBOT
41988 XPPR(-1)=XFSEA
41989 XPPR(-2)=XFSEA
41990 XPPR(-3)=XFSTR
41991 XPPR(-4)=XFCHM
41992 XPPR(-5)=XFBOT
41993
41994C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41995C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41996 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41997
41998C...Determine set, Lambda and x and t expansion variables.
41999 NSET=MSTP(51)-11
42000 IF(NSET.EQ.1) ALAM=0.2D0
42001 IF(NSET.EQ.2) ALAM=0.29D0
42002 TMIN=LOG(5D0/ALAM**2)
42003 TMAX=LOG(1D8/ALAM**2)
42004 T=LOG(MAX(1D0,Q2/ALAM**2))
42005 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42006 NX=1
42007 IF(X.LE.0.1D0) NX=2
42008 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42009 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42010
42011C...Chebyshev polynomials for x and t expansion.
42012 TX(1)=1D0
42013 TX(2)=VX
42014 TX(3)=2D0*VX**2-1D0
42015 TX(4)=4D0*VX**3-3D0*VX
42016 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42017 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42018 TT(1)=1D0
42019 TT(2)=VT
42020 TT(3)=2D0*VT**2-1D0
42021 TT(4)=4D0*VT**3-3D0*VT
42022 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42023 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42024
42025C...Calculate structure functions.
42026 DO 120 KFL=1,6
42027 XQSUM=0D0
42028 DO 110 IT=1,6
42029 DO 100 IX=1,6
42030 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42031 100 CONTINUE
42032 110 CONTINUE
42033 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42034 120 CONTINUE
42035
42036C...Put into output array.
42037 XPPR(0)=XQ(4)
42038 XPPR(1)=XQ(2)+XQ(3)
42039 XPPR(2)=XQ(1)+XQ(3)
42040 XPPR(3)=XQ(5)
42041 XPPR(4)=XQ(6)
42042 XPPR(-1)=XQ(3)
42043 XPPR(-2)=XQ(3)
42044 XPPR(-3)=XQ(5)
42045 XPPR(-4)=XQ(6)
42046
42047C...Special expansion for bottom (threshold effects).
42048 IF(MSTP(58).GE.5) THEN
42049 IF(NSET.EQ.1) TMIN=8.1905D0
42050 IF(NSET.EQ.2) TMIN=7.4474D0
42051 IF(T.GT.TMIN) THEN
42052 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42053 TT(1)=1D0
42054 TT(2)=VT
42055 TT(3)=2D0*VT**2-1D0
42056 TT(4)=4D0*VT**3-3D0*VT
42057 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42058 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42059 XQSUM=0D0
42060 DO 140 IT=1,6
42061 DO 130 IX=1,6
42062 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42063 130 CONTINUE
42064 140 CONTINUE
42065 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42066 XPPR(-5)=XPPR(5)
42067 ENDIF
42068 ENDIF
42069
42070C...Special expansion for top (threshold effects).
42071 IF(MSTP(58).GE.6) THEN
42072 IF(NSET.EQ.1) TMIN=11.5528D0
42073 IF(NSET.EQ.2) TMIN=10.8097D0
42074 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42075 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42076 IF(T.GT.TMIN) THEN
42077 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42078 TT(1)=1D0
42079 TT(2)=VT
42080 TT(3)=2D0*VT**2-1D0
42081 TT(4)=4D0*VT**3-3D0*VT
42082 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42083 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42084 XQSUM=0D0
42085 DO 160 IT=1,6
42086 DO 150 IX=1,6
42087 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42088 150 CONTINUE
42089 160 CONTINUE
42090 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42091 XPPR(-6)=XPPR(6)
42092 ENDIF
42093 ENDIF
42094
42095C...Proton parton distributions from Duke, Owens.
42096C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42097 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42098
42099C...Determine set, Lambda and s expansion parameter.
42100 NSET=MSTP(51)-13
42101 IF(NSET.EQ.1) ALAM=0.2D0
42102 IF(NSET.EQ.2) ALAM=0.4D0
42103 Q2IN=MIN(1D6,MAX(4D0,Q2))
42104 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42105
42106C...Calculate structure functions.
42107 DO 180 KFL=1,5
42108 DO 170 IS=1,6
42109 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42110 & CDO(3,IS,KFL,NSET)*SD**2
42111 170 CONTINUE
42112 IF(KFL.LE.2) THEN
42113 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42114 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42115 ELSE
42116 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42117 & TS(5)*X**2+TS(6)*X**3)
42118 ENDIF
42119 180 CONTINUE
42120
42121C...Put into output arrays.
42122 XPPR(0)=XQ(5)
42123 XPPR(1)=XQ(2)+XQ(3)/6D0
42124 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42125 XPPR(3)=XQ(3)/6D0
42126 XPPR(4)=XQ(4)
42127 XPPR(-1)=XQ(3)/6D0
42128 XPPR(-2)=XQ(3)/6D0
42129 XPPR(-3)=XQ(3)/6D0
42130 XPPR(-4)=XQ(4)
42131
42132 ENDIF
42133
42134 RETURN
42135 END
42136
42137C*********************************************************************
42138
42139C...PYHFTH
42140C...Gives threshold attractive/repulsive factor for heavy flavour
42141C...production.
42142
42143 FUNCTION PYHFTH(SH,SQM,FRATT)
42144
42145C...Double precision and integer declarations.
42146 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42147 IMPLICIT INTEGER(I-N)
42148 INTEGER PYK,PYCHGE,PYCOMP
42149C...Commonblocks.
42150 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42151 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42152 COMMON/PYINT1/MINT(400),VINT(400)
42153 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42154
42155C...Value for alpha_strong.
42156 IF(MSTP(35).LE.1) THEN
42157 ALSSG=PARP(35)
42158 ELSE
42159 MST115=MSTU(115)
42160 MSTU(115)=MSTP(36)
42161 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42162 & PARP(36)**2)))
42163 ALSSG=PYALPS(Q2BN)
42164 MSTU(115)=MST115
42165 ENDIF
42166
42167C...Evaluate attractive and repulsive factors.
42168 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42169 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42170 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42171 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42172 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42173 VINT(138)=PYHFTH
42174
42175 RETURN
42176 END
42177
42178C*********************************************************************
42179
42180C...PYSPLI
42181C...Splits a hadron remnant into two (partons or hadron + parton)
42182C...in case it is more complicated than just a quark or a diquark.
42183
42184 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42185
42186C...Double precision and integer declarations.
42187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42188 IMPLICIT INTEGER(I-N)
42189 INTEGER PYK,PYCHGE,PYCOMP
42190C...Commonblocks. PYDAT1 temporary
42191 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42192 COMMON/PYINT1/MINT(400),VINT(400)
42193 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42194 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42195C...Local array.
42196 DIMENSION KFL(3)
42197
42198C...Preliminaries. Parton composition.
42199 KFA=IABS(KF)
42200 KFS=ISIGN(1,KF)
42201 KFL(1)=MOD(KFA/1000,10)
42202 KFL(2)=MOD(KFA/100,10)
42203 KFL(3)=MOD(KFA/10,10)
42204 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42205 KFL(2)=INT(1.5D0+PYR(0))
42206 IF(MINT(105).EQ.333) KFL(2)=3
42207 IF(MINT(105).EQ.443) KFL(2)=4
42208 KFL(3)=KFL(2)
42209 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42210 KFL(2)=2
42211 KFL(3)=2
42212 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42213 KFL(2)=1
42214 KFL(3)=1
42215 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42216 KFL(2)=MOD(KFA/10,10)
42217 KFL(3)=MOD(KFA/100,10)
42218 ENDIF
42219 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42220 KFLR=KFLIN*KFS
42221 ELSE
42222 KFLR=KFLIN
42223 ENDIF
42224 KFLCH=0
42225
42226C...Subdivide lepton.
42227 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42228 IF(KFLR.EQ.KFA) THEN
42229 KFLSP=KFS*22
42230 ELSEIF(KFLR.EQ.22) THEN
42231 KFLSP=KFA
42232 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42233 KFLSP=KFA+1
42234 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42235 KFLSP=KFA-1
42236 ELSEIF(KFLR.EQ.21) THEN
42237 KFLSP=KFA
42238 KFLCH=KFS*21
42239 ELSE
42240 KFLSP=KFA
42241 KFLCH=-KFLR
42242 ENDIF
42243
42244C...Subdivide photon.
42245 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
42246 IF(KFLR.NE.21) THEN
42247 KFLSP=-KFLR
42248 ELSE
42249 RAGR=0.75D0*PYR(0)
42250 KFLSP=1
42251 IF(RAGR.GT.0.125D0) KFLSP=2
42252 IF(RAGR.GT.0.625D0) KFLSP=3
42253 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
42254 KFLCH=-KFLSP
42255 ENDIF
42256
42257C...Subdivide Reggeon or Pomeron.
42258 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
42259 IF(KFLIN.EQ.21) THEN
42260 KFLSP=KFS*21
42261 ELSE
42262 KFLSP=-KFLIN
42263 ENDIF
42264
42265C...Subdivide meson.
42266 ELSEIF(KFL(1).EQ.0) THEN
42267 KFL(2)=KFL(2)*(-1)**KFL(2)
42268 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
42269 IF(KFLR.EQ.KFL(2)) THEN
42270 KFLSP=KFL(3)
42271 ELSEIF(KFLR.EQ.KFL(3)) THEN
42272 KFLSP=KFL(2)
42273 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
42274 KFLSP=KFL(2)
42275 KFLCH=KFL(3)
42276 ELSEIF(KFLR.EQ.21) THEN
42277 KFLSP=KFL(3)
42278 KFLCH=KFL(2)
42279 ELSEIF(KFLR*KFL(2).GT.0) THEN
42280 NTRY=0
42281 100 NTRY=NTRY+1
42282 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
42283 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42284 GOTO 100
42285 ELSEIF(KFLCH.EQ.0) THEN
42286 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42287 MINT(51)=1
42288 RETURN
42289 ENDIF
42290 KFLSP=KFL(3)
42291 ELSE
42292 NTRY=0
42293 110 NTRY=NTRY+1
42294 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
42295 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42296 GOTO 110
42297 ELSEIF(KFLCH.EQ.0) THEN
42298 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42299 MINT(51)=1
42300 RETURN
42301 ENDIF
42302 KFLSP=KFL(2)
42303 ENDIF
42304
42305C...Special case for extracting photon from baryon without splitting
42306C...the latter. (Currently only used by external programs.)
42307 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
42308 KFLSP=KFA
42309 KFLCH=0
42310
42311C...Subdivide baryon.
42312 ELSE
42313 NAGR=0
42314 DO 120 J=1,3
42315 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
42316 120 CONTINUE
42317 IF(NAGR.GE.1) THEN
42318 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
42319 IAGR=0
42320 DO 130 J=1,3
42321 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
42322 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
42323 130 CONTINUE
42324 ELSE
42325 IAGR=1.00001D0+2.99998D0*PYR(0)
42326 ENDIF
42327 ID1=1
42328 IF(IAGR.EQ.1) ID1=2
42329 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
42330 ID2=6-IAGR-ID1
42331 KSP=3
42332 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
42333 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
42334 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
42335 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
42336 ELSEIF(MOD(KFA,10).EQ.2) THEN
42337 IF(IAGR.EQ.1) KSP=1
42338 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
42339 ENDIF
42340 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
42341 IF(KFLR.EQ.21) THEN
42342 KFLCH=KFL(IAGR)
42343 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
42344 NTRY=0
42345 140 NTRY=NTRY+1
42346 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
42347 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42348 GOTO 140
42349 ELSEIF(KFLCH.EQ.0) THEN
42350 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42351 MINT(51)=1
42352 RETURN
42353 ENDIF
42354 ELSEIF(NAGR.EQ.0) THEN
42355 NTRY=0
42356 150 NTRY=NTRY+1
42357 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
42358 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42359 GOTO 150
42360 ELSEIF(KFLCH.EQ.0) THEN
42361 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42362 MINT(51)=1
42363 RETURN
42364 ENDIF
42365 KFLSP=KFL(IAGR)
42366 ENDIF
42367 ENDIF
42368
42369C...Add on correct sign for result.
42370 KFLCH=KFLCH*KFS
42371 KFLSP=KFLSP*KFS
42372
42373 RETURN
42374 END
42375
42376C*********************************************************************
42377
42378C...PYGAMM
42379C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42380C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42381C...(Dover, 1965) 6.1.36.
42382
42383 FUNCTION PYGAMM(X)
42384
42385C...Double precision and integer declarations.
42386 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42387 IMPLICIT INTEGER(I-N)
42388 INTEGER PYK,PYCHGE,PYCOMP
42389C...Local array and data.
42390 DIMENSION B(8)
42391 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
42392 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
42393
42394 NX=INT(X)
42395 DX=X-NX
42396
42397 PYGAMM=1D0
42398 DXP=1D0
42399 DO 100 I=1,8
42400 DXP=DXP*DX
42401 PYGAMM=PYGAMM+B(I)*DXP
42402 100 CONTINUE
42403 IF(X.LT.1D0) THEN
42404 PYGAMM=PYGAMM/X
42405 ELSE
42406 DO 110 IX=1,NX-1
42407 PYGAMM=(X-IX)*PYGAMM
42408 110 CONTINUE
42409 ENDIF
42410
42411 RETURN
42412 END
42413
42414C***********************************************************************
42415
42416C...PYWAUX
42417C...Calculates real and imaginary parts of the auxiliary functions W1
42418C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42419C...der Bij, Nucl. Phys. B297 (1988) 221.
42420
42421 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
42422
42423C...Double precision and integer declarations.
42424 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42425 IMPLICIT INTEGER(I-N)
42426 INTEGER PYK,PYCHGE,PYCOMP
42427C...Commonblocks.
42428 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42429 SAVE /PYDAT1/
42430
42431 ASINH(X)=LOG(X+SQRT(X**2+1D0))
42432 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
42433
42434 IF(EPS.LT.0D0) THEN
42435 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
42436 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
42437 WIM=0D0
42438 ELSEIF(EPS.LT.1D0) THEN
42439 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
42440 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
42441 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
42442 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
42443 ELSE
42444 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
42445 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
42446 WIM=0D0
42447 ENDIF
42448
42449 RETURN
42450 END
42451
42452C***********************************************************************
42453
42454C...PYI3AU
42455C...Calculates real and imaginary parts of the auxiliary function I3;
42456C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42457C...Nucl. Phys. B297 (1988) 221.
42458
42459 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
42460
42461C...Double precision and integer declarations.
42462 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42463 IMPLICIT INTEGER(I-N)
42464 INTEGER PYK,PYCHGE,PYCOMP
42465C...Commonblocks.
42466 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42467 SAVE /PYDAT1/
42468
42469 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
42470 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
42471
42472 IF(EPS.LT.0D0) THEN
42473 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42474 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42475 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42476 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
42477 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
42478 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
42479 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
42480 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
42481 & EPS))
42482 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42483 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42484 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42485 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
42486 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
42487 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
42488 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
42489 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
42490 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42491 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42492 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42493 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
42494 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
42495 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
42496 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
42497 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
42498 ELSE
42499 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42500 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
42501 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
42502 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
42503 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
42504 ENDIF
42505 F3IM=0D0
42506 ELSEIF(EPS.LT.1D0) THEN
42507 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42508 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42509 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42510 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
42511 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
42512 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42513 & (0.25D0*(RAT+1D0)*EPS))
42514 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42515 & (0.25D0*(RAT+1D0)*EPS))
42516 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42517 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42518 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42519 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
42520 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
42521 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
42522 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42523 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42524 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42525 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42526 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42527 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
42528 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
42529 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
42530 & (1D0+0.25D0*RAT*EPS-GA))
42531 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
42532 & (1D0+0.25D0*RAT*EPS-GA))
42533 ELSE
42534 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42535 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
42536 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
42537 & LOG((GA+BE-1D0)/(BE-GA))
42538 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
42539 ENDIF
42540 ELSE
42541 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
42542 RCTHE=RSQ*(1D0-2D0*BE/EPS)
42543 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
42544 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
42545 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
42546 R=SQRT(RSQ)
42547 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
42548 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
42549 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
42550 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
42551 & (PHI-THE)*(PHI+THE-PARU(1))
42552 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
42553 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
42554 ENDIF
42555
42556 Y3RE=2D0/(2D0*BE-1D0)*F3RE
42557 Y3IM=2D0/(2D0*BE-1D0)*F3IM
42558
42559 RETURN
42560 END
42561
42562C***********************************************************************
42563
42564C...PYSPEN
42565C...Calculates real and imaginary part of Spence function; see
42566C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42567
42568 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
42569
42570C...Double precision and integer declarations.
42571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42572 IMPLICIT INTEGER(I-N)
42573 INTEGER PYK,PYCHGE,PYCOMP
42574C...Commonblocks.
42575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42576 SAVE /PYDAT1/
42577C...Local array and data.
42578 DIMENSION B(0:14)
42579 DATA B/
42580 &1.000000D+00, -5.000000D-01, 1.666667D-01,
42581 &0.000000D+00, -3.333333D-02, 0.000000D+00,
42582 &2.380952D-02, 0.000000D+00, -3.333333D-02,
42583 &0.000000D+00, 7.575757D-02, 0.000000D+00,
42584 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
42585
42586 XRE=XREIN
42587 XIM=XIMIN
42588 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
42589 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
42590 IF(IREIM.EQ.2) PYSPEN=0D0
42591 RETURN
42592 ENDIF
42593
42594 XMOD=SQRT(XRE**2+XIM**2)
42595 IF(XMOD.LT.1D-6) THEN
42596 IF(IREIM.EQ.1) PYSPEN=0D0
42597 IF(IREIM.EQ.2) PYSPEN=0D0
42598 RETURN
42599 ENDIF
42600
42601 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42602 SP0RE=0D0
42603 SP0IM=0D0
42604 SGN=1D0
42605 IF(XMOD.GT.1D0) THEN
42606 ALGXRE=LOG(XMOD)
42607 ALGXIM=XARG-SIGN(PARU(1),XARG)
42608 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
42609 SP0IM=-ALGXRE*ALGXIM
42610 SGN=-1D0
42611 XMOD=1D0/XMOD
42612 XARG=-XARG
42613 XRE=XMOD*COS(XARG)
42614 XIM=XMOD*SIN(XARG)
42615 ENDIF
42616 IF(XRE.GT.0.5D0) THEN
42617 ALGXRE=LOG(XMOD)
42618 ALGXIM=XARG
42619 XRE=1D0-XRE
42620 XIM=-XIM
42621 XMOD=SQRT(XRE**2+XIM**2)
42622 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42623 ALGYRE=LOG(XMOD)
42624 ALGYIM=XARG
42625 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
42626 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
42627 SGN=-SGN
42628 ENDIF
42629
42630 XRE=1D0-XRE
42631 XIM=-XIM
42632 XMOD=SQRT(XRE**2+XIM**2)
42633 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42634 ZRE=-LOG(XMOD)
42635 ZIM=-XARG
42636
42637 SPRE=0D0
42638 SPIM=0D0
42639 SAVERE=1D0
42640 SAVEIM=0D0
42641 DO 100 I=0,14
42642 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
42643 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
42644 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
42645 SAVERE=TERMRE
42646 SAVEIM=TERMIM
42647 SPRE=SPRE+B(I)*TERMRE
42648 SPIM=SPIM+B(I)*TERMIM
42649 100 CONTINUE
42650
42651 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
42652 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
42653
42654 RETURN
42655 END
42656
42657C***********************************************************************
42658
42659C...PYQQBH
42660C...Calculates the matrix element for the processes
42661C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42662C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42663C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42664
42665 SUBROUTINE PYQQBH(WTQQBH)
42666
42667C...Double precision and integer declarations.
42668 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42669 IMPLICIT INTEGER(I-N)
42670 INTEGER PYK,PYCHGE,PYCOMP
42671C...Commonblocks.
42672 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42673 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42674 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42675 COMMON/PYINT1/MINT(400),VINT(400)
42676 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42677 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
42678C...Local arrays and function.
42679 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
42680 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
42681 &PP(I,3)*PP(J,3)
42682
42683C...Mass parameters.
42684 WTQQBH=0D0
42685 ISUB=MINT(1)
42686 SHPR=SQRT(VINT(26))*VINT(1)
42687 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
42688 PH=SQRT(VINT(21))*VINT(1)
42689 SPQ=PQ**2
42690 SPH=PH**2
42691
42692C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42693 DO 100 I=1,2
42694 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42695 PP(I,1)=PT*COS(VINT(198+5*I))
42696 PP(I,2)=PT*SIN(VINT(198+5*I))
42697 100 CONTINUE
42698 PP(3,1)=-PP(1,1)-PP(2,1)
42699 PP(3,2)=-PP(1,2)-PP(2,2)
42700 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
42701 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
42702 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
42703 PMT3=SQRT(PMS3)
42704 PP(3,3)=PMT3*SINH(VINT(211))
42705 PP(3,4)=PMT3*COSH(VINT(211))
42706 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
42707 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42708 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
42709 PP(2,3)=-PP(1,3)-PP(3,3)
42710 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
42711 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
42712
42713C...Set up incoming kinematics and derived momentum combinations.
42714 DO 110 I=4,5
42715 PP(I,1)=0D0
42716 PP(I,2)=0D0
42717 PP(I,3)=-0.5D0*SHPR*(-1)**I
42718 PP(I,4)=-0.5D0*SHPR
42719 110 CONTINUE
42720 DO 120 J=1,4
42721 PP(6,J)=PP(1,J)+PP(2,J)
42722 PP(7,J)=PP(1,J)+PP(3,J)
42723 PP(8,J)=PP(1,J)+PP(4,J)
42724 PP(9,J)=PP(1,J)+PP(5,J)
42725 PP(10,J)=-PP(2,J)-PP(3,J)
42726 PP(11,J)=-PP(2,J)-PP(4,J)
42727 PP(12,J)=-PP(2,J)-PP(5,J)
42728 PP(13,J)=-PP(4,J)-PP(5,J)
42729 120 CONTINUE
42730
42731C...Derived kinematics invariants.
42732 X1=DOT(1,2)
42733 X2=DOT(1,3)
42734 X3=DOT(1,4)
42735 X4=DOT(1,5)
42736 X5=DOT(2,3)
42737 X6=DOT(2,4)
42738 X7=DOT(2,5)
42739 X8=DOT(3,4)
42740 X9=DOT(3,5)
42741 X10=DOT(4,5)
42742
42743C...Propagators.
42744 SS1=DOT(7,7)-SPQ
42745 SS2=DOT(8,8)-SPQ
42746 SS3=DOT(9,9)-SPQ
42747 SS4=DOT(10,10)-SPQ
42748 SS5=DOT(11,11)-SPQ
42749 SS6=DOT(12,12)-SPQ
42750 SS7=DOT(13,13)
42751 DX(1)=SS1*SS6
42752 DX(2)=SS2*SS6
42753 DX(3)=SS2*SS4
42754 DX(4)=SS1*SS5
42755 DX(5)=SS3*SS5
42756 DX(6)=SS3*SS4
42757 DX(7)=SS7*SS1
42758 DX(8)=SS7*SS4
42759
42760C...Define colour coefficients for g + g -> Q + Qbar + H.
42761 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
42762 DO 140 I=1,3
42763 DO 130 J=1,3
42764 CLR(I,J)=16D0/3D0
42765 CLR(I+3,J+3)=16D0/3D0
42766 CLR(I,J+3)=-2D0/3D0
42767 CLR(I+3,J)=-2D0/3D0
42768 130 CONTINUE
42769 140 CONTINUE
42770 DO 160 L=1,2
42771 DO 150 I=1,3
42772 CLR(I,6+L)=-6D0
42773 CLR(I+3,6+L)=6D0
42774 CLR(6+L,I)=-6D0
42775 CLR(6+L,I+3)=6D0
42776 150 CONTINUE
42777 160 CONTINUE
42778 DO 180 K1=1,2
42779 DO 170 K2=1,2
42780 CLR(6+K1,6+K2)=12D0
42781 170 CONTINUE
42782 180 CONTINUE
42783
42784C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42785 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
42786 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
42787 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
42788 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
42789 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
42790 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
42791 & X10)
42792 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
42793 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
42794 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42795 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
42796 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
42797 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
42798 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
42799 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
42800 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
42801 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
42802 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
42803 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
42804 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42805 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
42806 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
42807 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
42808 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
42809 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
42810 & X4*X6*X5)
42811 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
42812 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
42813 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
42814 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
42815 & +X4*X9*X5+X4*X5**2)
42816 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
42817 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
42818 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
42819 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
42820 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
42821 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
42822 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
42823 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
42824 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
42825 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
42826 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
42827 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
42828 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
42829 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
42830 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
42831 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
42832 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
42833 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
42834 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
42835 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
42836 & X6)
42837 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
42838 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42839 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
42840 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
42841 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
42842 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
42843 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
42844 & X5+X4*X6*X5)
42845 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
42846 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
42847 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
42848 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
42849 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
42850 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
42851 & X6**2)
42852 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
42853 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
42854 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
42855 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
42856 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
42857 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
42858 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
42859 & X4*X6*X5)
42860 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42861 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42862 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
42863 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
42864 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
42865 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42866 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
42867 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
42868 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
42869 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
42870 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
42871 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42872 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42873 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
42874 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
42875 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
42876 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42877 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
42878 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
42879 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
42880 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
42881 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
42882 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
42883 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
42884 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
42885 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
42886 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
42887 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
42888 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
42889 & +X3*X8*X5+X3*X5**2)
42890 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
42891 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
42892 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
42893 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
42894 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
42895 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
42896 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
42897 & X5+X4*X6*X5)
42898 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
42899 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
42900 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
42901 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
42902 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
42903 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
42904 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
42905 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
42906 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42907 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42908 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42909 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42910 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42911 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42912 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42913 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42914 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42915 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42916 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42917 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42918 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42919 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42920 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42921 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42922 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42923 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42924 & X10)
42925 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42926 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42927 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42928 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42929 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42930 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42931 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42932 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42933 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42934 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42935 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42936 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42937 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42938 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42939 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42940 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42941 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42942 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42943 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42944 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42945 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42946 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42947 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42948 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42949 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42950 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42951 & X7)
42952 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42953 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42954 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42955 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42956 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42957 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42958 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42959 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42960 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42961 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42962 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42963 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42964 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42965 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42966 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42967 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42968 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42969 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42970 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42971 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42972 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42973 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42974 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42975 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42976 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42977 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42978 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42979 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42980 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42981 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42982 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42983 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42984 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42985 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42986 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42987 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42988 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42989 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42990 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42991 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42992 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42993 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42994 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42995 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42996 & *X6)
42997 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42998 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42999 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
43000 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
43001 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43002 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43003 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43004 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43005 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43006 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43007 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43008 & X8)
43009 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43010 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43011 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43012 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43013 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43014 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43015 & X9*X5)
43016 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43017 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43018 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43019 & X8*X5)
43020 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43021 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43022 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43023 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43024
43025C...Repackage matrix elements.
43026 DO 200 I=1,8
43027 DO 190 J=I,8
43028 RM(I,J)=FM(I,J)
43029 190 CONTINUE
43030 200 CONTINUE
43031 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43032 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43033 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43034
43035C...Produce final result: matrix elements * colours * propagators.
43036 DO 220 I=1,8
43037 DO 210 J=I,8
43038 FAC=8D0
43039 IF(I.EQ.J)FAC=4D0
43040 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43041 210 CONTINUE
43042 220 CONTINUE
43043 WTQQBH=-WTQQBH/256D0
43044
43045 ELSE
43046C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43047 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43048 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43049 & *X6+X8*X7)
43050 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43051 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43052 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43053 & X5)
43054 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43055 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43056 & *X9+X4*X8)
43057
43058C...Produce final result: matrix elements * propagators.
43059 A11=A11/DX(7)**2
43060 A12=A12/(DX(7)*DX(8))
43061 A22=A22/DX(8)**2
43062 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43063 ENDIF
43064
43065 RETURN
43066 END
43067
43068C*********************************************************************
43069
43070C...PYSTBH (and auxiliaries)
43071C.. Evaluates the matrix elements for t + b + H production.
43072
43073 SUBROUTINE PYSTBH(WTTBH)
43074
43075C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43077 IMPLICIT INTEGER(I-N)
43078 INTEGER PYK,PYCHGE,PYCOMP
43079
43080C...COMMONBLOCKS
43081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43082 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43083 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43084 COMMON/PYINT1/MINT(400),VINT(400)
43085 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43086 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43087 COMMON/PYINT4/MWID(500),WIDS(500,5)
43088 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43089 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43090 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43091 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43092 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43093 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43094 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43095 DOUBLE PRECISION MW2
43096 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43097 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43098
43099C...LOCAL ARRAYS AND COMPLEX VARIABLES
43100 DIMENSION QQ(4,2),PP(4,3)
43101 DATA QQ/8*0D0/
43102
43103 WTTBH=0D0
43104
43105C...KINEMATIC PARAMETERS.
43106 SHPR=SQRT(VINT(26))*VINT(1)
43107 PH=SQRT(VINT(21))*VINT(1)
43108 SPH=PH**2
43109
43110C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43111 DO 100 I=1,2
43112 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43113 PP(1,I)=PT*COS(VINT(198+5*I))
43114 PP(2,I)=PT*SIN(VINT(198+5*I))
43115 100 CONTINUE
43116 PP(1,3)=-PP(1,1)-PP(1,2)
43117 PP(2,3)=-PP(2,1)-PP(2,2)
43118 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43119 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43120 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43121 PMT3=SQRT(PMS3)
43122 PP(3,3)=PMT3*SINH(VINT(211))
43123 PP(4,3)=PMT3*COSH(VINT(211))
43124 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43125 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43126 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43127 PP(3,2)=-PP(3,1)-PP(3,3)
43128 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43129 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43130
43131C...CM SYSTEM, INGOING QUARKS/GLUONS
43132 QQ(3,1) = SHPR/2.D0
43133 QQ(4,1) = QQ(3,1)
43134 QQ(3,2) = -QQ(3,1)
43135 QQ(4,2) = QQ(4,1)
43136
43137C...PARAMETERS FOR AMPLITUDE METHOD
43138 ALPHA = AEM
43139 ALPHAS = AS
43140 SW2 = PARU(102)
43141 MW2 = PMAS(24,1)**2
43142 TANB = PARU(141)
43143 VTB = VCKM(3,3)
43144 RMB=PYMRUN(5,VINT(52))
43145
43146 ISUB=MINT(1)
43147
43148 IF (ISUB.EQ.401) THEN
43149 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43150 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43151 ELSE IF (ISUB.EQ.402) THEN
43152 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43153 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43154 END IF
43155
43156 RETURN
43157 END
43158C------------------------------------------------------------------
43159 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43160C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43161 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43162 IMPLICIT INTEGER(I-N)
43163 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43164 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43165 SAVE /PYCTBH/
43166
43167C TOP WIDTH CALCULATION
43168C VTB = 0.99
43169 MW=DSQRT(MW2)
43170 XB=(MB/MT)**2
43171 XW=(MW/MT)**2
43172 XH =(MHP/MT)**2
43173 GAMTBH = 0D0
43174 IF (MT .LT. (MHP+MB)) THEN
43175C T ->B W ONLY
43176 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43177 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43178 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43179 GAMT = GAMTBW
43180 ELSE
43181C T ->BW +T ->B H^+
43182 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43183 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43184 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43185C
43186 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43187 & -4.D0*(MHP*MB/MT**2)**2 )
43188 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43189 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43190 GAMT = GAMTBW+GAMTBH
43191 ENDIF
43192C THUS BR IS
43193 BR=GAMTBH/GAMT
43194 RETURN
43195 END
43196
43197C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43198C GG->TBH^+, QQBAR->TBH^+
43199C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43200C (FOR INSTANCE WITH PYTHIA)
43201C------------------------------------------------------------
43202C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43203C PHYS REV. D 60 (1999) 115011
43204C (THESE FILES PREPARED BY J.-L. KNEUR)
43205C------------------------------------------------------------
43206C 1) GG->TBH^+
43207 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43208C
43209C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43210C
43211C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43212C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43213C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43214C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43215C "PHYSICAL PARAMETERS" INPUT:
43216C MT,MB TOP AND BOTTOM MASSES;
43217C MHP CHARGED HIGGS MASS
43218C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43219C
43220C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43221C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43222C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43223C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43224C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43225C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43226C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43227C
43228 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43229 IMPLICIT INTEGER(I-N)
43230 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43231 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43232 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43233 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43234 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43235
43236 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43237 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43238C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43239C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43240C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43241C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43242C (TAN BETA) VALUES
43243C
43244C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43245C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43246
43247 PI = 4*DATAN(1.D0)
43248 MW = DSQRT(MW2)
43249C
43250C COLLECTING THE RELEVANT OVERALL FACTORS:
43251C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43252 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
43253C COUPLING CONSTANT (OVERALL NORMALIZATION)
43254 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43255C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43256C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43257C ALPHAS IS ALPHA_STRONG;
43258C SW2 IS SIN(THETA_W)**2.
43259C
43260C VTB=.998D0
43261C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43262C
43263 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43264 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43265C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43266C
43267C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43268C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43269 DO 100 KK=1,4
43270 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43271 100 CONTINUE
43272C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43273 S = 2*PYTBHS(Q1,Q2)
43274 P1Q1=PYTBHS(Q1,P1)
43275 P1Q2=PYTBHS(P1,Q2)
43276 P2Q1=PYTBHS(P2,Q1)
43277 P2Q2=PYTBHS(P2,Q2)
43278 P1P2=PYTBHS(P1,P2)
43279C
43280C TOP WIDTH CALCULATION
43281 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43282C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43283C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43284 A1INV= S -2*P1Q1 -2*P1Q2
43285 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43286C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43287C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43288C THE TOP WIDTH
43289 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43290 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43291C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43292C NOW COMES THE AMP**2:
43293C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43294C THE EXPRESSIONS BELOW
43295 V18=0.D0
43296 A18=0.D0
43297 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
43298 &512*A1*A2*MB*MT/3-
43299 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43300 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
43301 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
43302 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43303 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
43304 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
43305 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
43306 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
43307 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43308 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43309 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
43310 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
43311 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43312 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43313 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
43314 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
43315 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
43316 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
43317 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43318 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
43319 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
43320 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43321 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43322 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43323 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
43324 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43325 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43326 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43327 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43328 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43329 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
43330 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43331 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43332 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
43333 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
43334 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43335 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
43336 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43337 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43338 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
43339 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
43340 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43341 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
43342 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43343 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43344 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43345 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43346 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
43347 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
43348 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43349 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
43350 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43351 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43352 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43353 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43354 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43355 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
43356 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
43357 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
43358 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43359 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43360 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43361 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43362 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43363 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
43364 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43365 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43366 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43367 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
43368 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43369 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
43370 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43371 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43372 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
43373 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43374 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43375 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43376 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
43377 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43378 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43379 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43380 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43381 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43382 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43383 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
43384 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43385 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43386 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
43387 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43388 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43389 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43390 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43391 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43392 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43393 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
43394 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43395 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43396 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43397 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
43398 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43399 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43400 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43401 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43402 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43403 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
43404 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43405 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
43406 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43407 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
43408 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
43409 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43410 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43411 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43412 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43413 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
43414 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43415 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43416 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43417 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43418 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43419 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
43420 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43421 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43422 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43423 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43424 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43425 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
43426 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
43427 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43428 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43429 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43430 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
43431 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43432 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43433 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43434 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43435 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43436 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
43437 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43438 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
43439 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43440 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43441 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
43442 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43443 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43444 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43445 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43446 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43447 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
43448 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43449 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43450 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43451 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43452 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43453 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43454 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43455 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
43456 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43457 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43458 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43459 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43460 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43461 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
43462 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43463 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43464 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43465 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43466 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43467 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43468 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
43469 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43470 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
43471 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43472 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43473 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43474 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43475 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43476 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43477 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43478 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43479 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
43480 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43481 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43482 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
43483 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43484 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43485 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43486 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43487 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43488 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
43489 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43490 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43491 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43492 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
43493 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43494 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43495 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
43496 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43497 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43498 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43499 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43500 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43501 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43502 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43503 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43504 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43505 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43506 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43507 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43508 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43509 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43510 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43511 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43512 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43513 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43514 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43515 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
43516 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43517 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43518 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43519 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43520 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43521 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43522 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43523 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43524 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
43525 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43526 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43527 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43528 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43529 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43530 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43531 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43532 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43533 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
43534 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43535 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43536 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43537 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43538 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43539 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
43540 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43541 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43542 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43543 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43544 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43545 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43546 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43547 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43548 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
43549 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43550 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43551 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43552 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43553 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43554 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43555 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43556 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43557 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43558 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43559 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43560 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43561 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43562 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43563 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43564 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43565 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
43566 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43567 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43568 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43569 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
43570 &384*A12*MB*MT*P1Q1**2/S**2+
43571 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43572 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
43573 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43574 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43575 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43576 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43577 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
43578 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43579 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43580 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43581 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43582 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43583 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43584 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43585 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43586 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
43587 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43588 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
43589 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
43590 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
43591 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
43592 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
43593 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43594 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
43595 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
43596 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
43597 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
43598 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
43599 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
43600 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43601 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
43602 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43603 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
43604 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
43605 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43606 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43607 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
43608 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
43609 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
43610 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
43611 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43612 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43613 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43614 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43615 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
43616 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43617 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
43618 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
43619 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
43620 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
43621 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
43622 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43623 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
43624 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43625 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43626 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43627 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43628 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43629 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43630 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43631 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43632 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43633 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43634 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
43635 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
43636 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
43637 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
43638 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
43639 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
43640 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43641 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43642 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43643 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
43644 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43645 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
43646 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43647 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43648 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43649 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43650 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43651 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43652 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
43653 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43654 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
43655 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43656 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
43657 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43658 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43659 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
43660 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
43661 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43662 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43663 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43664 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43665 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
43666 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43667 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
43668 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43669 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43670 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43671 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
43672 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43673 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
43674 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43675 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
43676 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
43677 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
43678 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43679 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
43680 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
43681 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43682 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43683 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43684 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43685 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43686 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43687 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43688 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43689 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43690 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
43691 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43692 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43693 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43694 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43695 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43696 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43697 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43698 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43699 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43700 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
43701 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43702 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
43703 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43704 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43705 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43706 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43707 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
43708 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
43709 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43710 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
43711 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
43712 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43713 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43714 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
43715 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43716 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43717 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
43718 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43719 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43720 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43721 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
43722 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
43723 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43724 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
43725 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
43726 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43727 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43728 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43729 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43730 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43731 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43732 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
43733 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
43734 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
43735 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43736 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43737 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43738 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43739 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43740 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
43741 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
43742 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43743 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43744 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43745 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
43746 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
43747
43748 V18BIS=
43749 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43750 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43751 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43752 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43753 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43754 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43755 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43756 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43757 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43758 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43759 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
43760 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43761 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43762 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
43763 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43764 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
43765 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
43766 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
43767 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43768 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43769 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43770 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43771 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43772 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43773 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
43774 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
43775 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43776 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43777 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
43778 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
43779 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43780 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
43781 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
43782 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
43783 &272*A1*A2*P1Q1*S/(3*P1Q2)+
43784 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
43785 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43786 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
43787 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43788 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43789 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43790 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43791 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43792 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
43793 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43794 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43795 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
43796 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43797 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
43798 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
43799 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43800 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43801 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
43802 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
43803 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
43804 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43805 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
43806 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43807 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
43808 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43809 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43810 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
43811 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43812 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43813 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
43814 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43815 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
43816 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
43817 &32*A12*P2Q1*S/(3*P1Q1)-
43818 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43819 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
43820 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
43821 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43822 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43823 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43824 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43825 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43826 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
43827 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43828 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43829 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
43830 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43831 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43832 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
43833 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
43834 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
43835 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43836 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
43837 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43838 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43839 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
43840 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43841 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
43842 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43843 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
43844 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43845 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43846 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43847 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43848 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43849 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
43850 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
43851 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
43852 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43853 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
43854 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
43855 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
43856 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43857 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43858 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43859 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43860 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43861 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43862 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43863 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43864 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43865 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43866 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
43867 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
43868 &272*A1*A2*P2Q1*S/(3*P2Q2)-
43869 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
43870 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43871 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
43872 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43873 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43874 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43875 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43876 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43877 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43878 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43879 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
43880 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43881 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43882 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43883 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
43884 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
43885 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43886 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43887 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
43888 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
43889 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43890 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43891 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43892C
43893
43894 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
43895 &512*A1*A2*MB*MT/3+
43896 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43897 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
43898 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
43899 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43900 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
43901 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
43902 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
43903 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
43904 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43905 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43906 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43907 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43908 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43909 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43910 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43911 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43912 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43913 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43914 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43915 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43916 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43917 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43918 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43919 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43920 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43921 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43922 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43923 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43924 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43925 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43926 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43927 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43928 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43929 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43930 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43931 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43932 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43933 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43934 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43935 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43936 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43937 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43938 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43939 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43940 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43941 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43942 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43943 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43944 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43945 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43946 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43947 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43948 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43949 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43950 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43951 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43952 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43953 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43954 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43955 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43956 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43957 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43958 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43959 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43960 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43961 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43962 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43963 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43964 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43965 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43966 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43967 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43968 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43969 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43970 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43971 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43972 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43973 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43974 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43975 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43976 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43977 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43978 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43979 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43980 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43981 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43982 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43983 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43984 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43985 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43986 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43987 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43988 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43989 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43990 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43991 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43992 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43993 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43994 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43995 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43996 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43997 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43998 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43999 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44000 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
44001 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44002 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44003 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44004 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44005 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44006 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44007 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44008 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44009 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44010 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44011 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44012 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44013 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44014 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44015 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44016 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44017 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44018 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44019 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44020 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44021 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44022 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44023 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44024 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44025 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44026 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44027 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44028 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44029 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44030 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44031 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44032 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44033 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44034 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44035 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44036 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44037 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44038 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44039 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44040 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44041 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44042 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44043 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44044 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44045 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44046 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44047 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44048 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44049 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44050 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44051 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44052 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44053 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44054 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44055 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44056 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44057 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44058 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44059 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44060 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44061 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44062 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44063 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44064 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44065 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44066 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44067 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44068 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44069 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44070 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44071 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44072 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44073 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44074 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44075 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44076 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44077 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44078 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44079 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44080 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44081 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44082 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44083 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44084 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44085 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44086 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44087 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44088 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44089 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44090 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44091 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44092 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44093 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44094 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44095 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44096 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44097 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44098 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44099 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44100 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44101 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44102 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44103 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44104 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44105 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44106 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44107 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44108 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44109 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44110 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44111 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44112 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44113 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44114 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44115 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44116 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44117 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44118 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44119 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44120 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44121 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44122 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44123 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44124 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44125 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44126 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44127 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44128 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44129 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44130 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44131 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44132 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44133 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44134 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44135 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44136 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44137 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44138 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44139 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44140 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44141 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44142 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44143 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44144 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44145 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44146 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44147 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44148 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44149 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44150 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44151 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44152 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44153 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44154 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44155 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44156 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44157 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44158 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44159 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44160 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44161 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44162 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44163 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44164 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44165 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44166 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44167 &384*A12*MB*MT*P1Q1**2/S**2+
44168 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44169 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44170 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44171 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44172 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44173 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44174 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44175 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44176 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44177 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44178 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44179 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44180 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44181 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44182 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44183 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44184 &384*A2**2*MB*MT*P2Q2**2/S**2+
44185 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44186 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44187 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44188 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44189 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44190 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44191 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44192 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44193 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44194 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44195 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44196 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44197 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44198 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44199 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44200 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44201 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44202 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44203 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44204 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44205 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44206 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44207 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44208 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44209 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44210 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44211 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44212 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44213 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44214 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44215 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44216 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44217 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44218 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44219 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44220 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44221 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44222 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44223 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44224 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44225 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44226 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44227 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44228 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44229 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44230 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44231 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44232 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44233 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44234 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44235 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44236 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44237 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44238 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44239 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44240 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44241 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
44242 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44243 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44244 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44245 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44246 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44247 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44248 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
44249 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44250 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
44251 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44252 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
44253 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44254 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44255 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
44256 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
44257 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44258 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44259 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44260 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44261 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
44262 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44263 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
44264 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44265 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
44266 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44267 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
44268 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44269 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
44270 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44271 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
44272 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
44273 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
44274 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44275 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
44276 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
44277 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44278 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44279 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44280 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44281 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
44282 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44283 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44284 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
44285 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
44286 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
44287 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44288 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44289 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44290 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44291 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44292 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44293 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44294 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44295 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44296 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
44297 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44298 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
44299 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44300 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44301 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
44302 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
44303 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44304 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
44305 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44306 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
44307 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
44308 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44309 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44310 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
44311 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44312 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44313 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
44314 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44315 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44316 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44317 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
44318 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
44319 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44320 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
44321 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44322 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44323 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44324 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44325 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44326 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44327 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
44328 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
44329 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
44330 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44331 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44332 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44333 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
44334 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44335 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
44336 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
44337 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44338 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44339 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44340 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44341 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44342 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44343 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44344 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44345 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44346 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44347 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44348 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
44349 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44350 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44351 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44352 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
44353 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44354 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44355 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
44356 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44357 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
44358 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
44359 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44360 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44361 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44362 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44363 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44364 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44365 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
44366 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
44367 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44368 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44369 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
44370 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
44371 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44372 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
44373 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
44374 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
44375 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
44376 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44377 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
44378
44379 A18BIS=
44380 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44381 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44382 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44383 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44384 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44385 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
44386 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44387 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44388 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
44389 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44390 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
44391 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
44392 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44393 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44394 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
44395 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
44396 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
44397 &12*S/(P1Q2*P2Q1)+
44398 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44399 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
44400 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44401 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
44402 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44403 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44404 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44405 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44406 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44407 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
44408 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44409 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
44410 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
44411 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44412 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
44413 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
44414 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
44415 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44416 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44417 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44418 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44419 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44420 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
44421 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44422 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44423 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
44424 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44425 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44426 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
44427 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
44428 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44429 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
44430 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44431 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44432 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
44433 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44434 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
44435 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44436 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
44437 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44438 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44439 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44440 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44441 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44442 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
44443 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
44444 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44445 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
44446 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
44447 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44448 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44449 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44450 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44451 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44452 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44453 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44454 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44455 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44456 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44457 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44458 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44459 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
44460 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
44461 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
44462 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44463 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
44464 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44465 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44466 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44467 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44468 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44469 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44470 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44471 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
44472 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44473 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44474 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44475 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
44476 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
44477 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44478 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44479 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
44480 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
44481 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44482 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44483 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44484C
44485 V18=V18+V18BIS
44486 A18=A18+A18BIS
44487 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
44488 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
44489 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44490 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44491 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44492 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
44493 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44494 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44495 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44496 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44497 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44498 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44499 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
44500 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
44501 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
44502 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
44503 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
44504 V910=V910+96*A1*A2*P1P2*P2Q1/S-
44505 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44506 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
44507 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
44508 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44509 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44510C
44511 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
44512 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
44513 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44514 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44515 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44516 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
44517 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44518 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44519 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
44520 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44521 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44522 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44523 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
44524 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
44525 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
44526 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
44527 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
44528 A910=A910+96*A1*A2*P1P2*P2Q1/S-
44529 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44530 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
44531 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
44532 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44533 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44534C
44535C FINAL RESULT;
44536C
44537 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
44538
44539 END
44540C---------------------------------------------------------
44541C 2) Q QBAR ->TBH^+
44542 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44543C
44544C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44545C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44546 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44547 IMPLICIT INTEGER(I-N)
44548 DOUBLE PRECISION MW2,MT,MB,MHP,MW
44549 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
44550 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44551 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44552 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44553 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
44554 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
44555C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44556C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44557C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44558C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44559C
44560C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44561C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44562C
44563 DIMENSION YY(2,2)
44564
44565 PI = 4*DATAN(1.D0)
44566 MW = DSQRT(MW2)
44567
44568C COLLECTING THE RELEVANT OVERALL FACTORS:
44569C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44570 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
44571C COUPLING CONSTANT (OVERALL NORMALIZATION)
44572 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44573C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44574C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44575C ALPHAS IS ALPHA_STRONG;
44576C SW2 IS SIN(THETA_W)**2.
44577C
44578C VTB=.998D0
44579C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44580C
44581 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44582 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44583C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44584C
44585C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44586C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44587 DO 100 KK=1,4
44588 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44589 100 CONTINUE
44590C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44591 S = 2*PYTBHS(Q1,Q2)
44592 P1Q1=PYTBHS(Q1,P1)
44593 P1Q2=PYTBHS(P1,Q2)
44594 P2Q1=PYTBHS(P2,Q1)
44595 P2Q2=PYTBHS(P2,Q2)
44596 P1P2=PYTBHS(P1,P2)
44597C
44598C TOP WIDTH CALCULATION
44599 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44600C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44601C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44602 A1INV= S -2*P1Q1 -2*P1Q2
44603 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44604C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44605C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44606 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44607 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44608C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44609C NOW COMES THE AMP**2:
44610C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44611C THE EXPRESSIONS BELOW
44612 YY(1, 1) = -16*A**2*A2**2*MB*MT+
44613 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
44614 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
44615 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
44616 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44617 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44618 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
44619 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
44620 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
44621 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
44622 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
44623 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
44624 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
44625 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
44626 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44627 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44628 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
44629 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
44630 &32*A2**2*MB**2*P1P2*V**2/S+
44631 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
44632 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
44633 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
44634 YY(1, 1)=2*YY(1, 1)
44635
44636 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
44637 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
44638 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44639 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44640 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
44641 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
44642 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
44643 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44644 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
44645 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44646 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
44647 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44648 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
44649 &64*A**2*A1*A2*MB*MT*P1P2/S+
44650 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
44651 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
44652 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
44653 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
44654 &64*A**2*A1*A2*P1Q1*P2Q1/S-
44655 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
44656 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
44657 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
44658 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
44659 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
44660 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
44661 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
44662 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
44663 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
44664 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
44665 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
44666 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44667 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44668 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
44669 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
44670 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
44671 &32*A1*A2*P1P2*P1Q1*V**2/S+
44672 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
44673 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
44674 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
44675 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
44676
44677
44678 YY(2, 2) =-16*A**2*A12*MB*MT+
44679 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
44680 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
44681 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
44682 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
44683 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
44684 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
44685 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
44686 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
44687 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
44688 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
44689 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
44690 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
44691 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
44692 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
44693 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
44694 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
44695 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
44696 &32*A12*MT**2*P2Q2*V**2/S-
44697 &32*A12*P1Q2*P2Q2*V**2/S
44698 YY(2, 2)=2*YY(2, 2)
44699
44700 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
44701 AMP2= FACT*PS*VTB**2*RES
44702
44703 END
44704C=====================================================================
44705C ************* FUNCTION SCALAR PRODUCTS *************************
44706 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
44707 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44708 IMPLICIT INTEGER(I-N)
44709 DIMENSION A(4),B(4)
44710 DUM=A(4)*B(4)
44711 DO 100 ID=1,3
44712 DUM=DUM-A(ID)*B(ID)
44713 100 CONTINUE
44714 PYTBHS=DUM
44715 RETURN
44716 END
44717
44718C*********************************************************************
44719
44720C...PYMSIN
44721C...Initializes supersymmetry: finds sparticle masses and
44722C...branching ratios and stores this information.
44723C...AUTHOR: STEPHEN MRENNA
44724C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44725
44726 SUBROUTINE PYMSIN
44727
44728C...Double precision and integer declarations.
44729 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44730 IMPLICIT INTEGER(I-N)
44731 INTEGER PYK,PYCHGE,PYCOMP
44732C...Parameter statement to help give large particle numbers.
44733 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44734 &KEXCIT=4000000,KDIMEN=5000000)
44735C...Commonblocks.
44736 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44737 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44738 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44739 COMMON/PYDAT4/CHAF(500,2)
44740 CHARACTER CHAF*16
44741 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44742 COMMON/PYINT4/MWID(500),WIDS(500,5)
44743 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44744 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44745 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44746 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44747 COMMON/PYHTRI/HHH(7)
44748 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44749 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
44750 &/PYMSSM/,/PYMSRV/,/PYSSMT/
44751
44752C...Local variables.
44753 DOUBLE PRECISION ALFA,BETA
44754 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44755 INTEGER I,J,J1,I1,K1
44756 INTEGER KC,LKNT,IDLAM(400,3)
44757 DOUBLE PRECISION XLAM(0:400)
44758 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44759 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44760 DOUBLE PRECISION DELM,XMDIF
44761 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44762 DOUBLE PRECISION ARG,SGNMU,R
44763 INTEGER IMSSM
44764 INTEGER IRPRTY
44765 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44766 SAVE MWIDSU,MDCYSU
44767 DATA KFSUSY/
44768 &1000001,2000001,1000002,2000002,1000003,2000003,
44769 &1000004,2000004,1000005,2000005,1000006,2000006,
44770 &1000011,2000011,1000012,2000012,1000013,2000013,
44771 &1000014,2000014,1000015,2000015,1000016,2000016,
44772 &1000021,1000022,1000023,1000025,1000035,1000024,
44773 &1000037,1000039, 25, 35, 36, 37,
44774 & 6, 24, 45, 46,1000045, 9*0/
44775 DATA INIT/0/
44776
44777C...Automatically read QNUMBERS, MASS, and DECAY tables
44778 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
44779 NQNUM=0
44780 CALL PYSLHA(0,0,IFAIL)
44781 CALL PYSLHA(5,0,IFAIL)
44782 ENDIF
44783 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
44784
44785C...Do nothing further if SUSY not requested
44786 IMSSM=IMSS(1)
44787 IF(IMSSM.EQ.0) RETURN
44788
44789C...Save copy of MWID(KC) and MDCY(KC,1) values before
44790C...they are set to zero for the LSP.
44791 IF(INIT.EQ.0) THEN
44792 INIT=1
44793 DO 100 I=1,36
44794 KF=KFSUSY(I)
44795 KC=PYCOMP(KF)
44796 MWIDSU(I)=MWID(KC)
44797 MDCYSU(I)=MDCY(KC,1)
44798 100 CONTINUE
44799 ENDIF
44800
44801C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44802 DO 110 I=1,36
44803 KF=KFSUSY(I)
44804 KC=PYCOMP(KF)
44805 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
44806 MWID(KC)=MWIDSU(I)
44807 MDCY(KC,1)=MDCYSU(I)
44808 ENDIF
44809 110 CONTINUE
44810
44811C...First part of routine: set masses and couplings.
44812
44813C...Reset mixing values in sfermion sector to pure left/right.
44814 DO 120 I=1,16
44815 SFMIX(I,1)=1D0
44816 SFMIX(I,4)=1D0
44817 SFMIX(I,2)=0D0
44818 SFMIX(I,3)=0D0
44819 120 CONTINUE
44820
44821C...Add NMSSM states if NMSSM switched on, and change old names.
44822 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
44823C... Switch on NMSSM
44824 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
44825
44826 KFN=25
44827 KCN=KFN
44828 CHAF(KCN,1)='h_10'
44829 CHAF(KCN,2)=' '
44830
44831 KFN=35
44832 KCN=KFN
44833 CHAF(KCN,1)='h_20'
44834 CHAF(KCN,2)=' '
44835
44836 KFN=45
44837 KCN=KFN
44838 CHAF(KCN,1)='h_30'
44839 CHAF(KCN,2)=' '
44840
44841 KFN=36
44842 KCN=KFN
44843 CHAF(KCN,1)='A_10'
44844 CHAF(KCN,2)=' '
44845
44846 KFN=46
44847 KCN=KFN
44848 CHAF(KCN,1)='A_20'
44849 CHAF(KCN,2)=' '
44850
44851 KFN=1000045
44852 KCN=PYCOMP(KFN)
44853 IF (KCN.EQ.0) THEN
44854 DO 123 KCT=100,MSTU(6)
44855 IF(KCHG(KCT,4).GT.100) KCN=KCT
44856 123 CONTINUE
44857 KCN=KCN+1
44858 KCHG(KCN,4)=KFN
44859 MSTU(20)=0
44860 ENDIF
44861C... Set stable for now
44862 PMAS(KCN,2)=1D-6
44863 MWID(KCN)=0
44864 MDCY(KCN,1)=0
44865 MDCY(KCN,2)=0
44866 MDCY(KCN,3)=0
44867 CHAF(KCN,1)='~chi_50'
44868 CHAF(KCN,2)=' '
44869 ENDIF
44870
44871C...Read spectrum from SLHA file.
44872 IF (IMSSM.EQ.11) THEN
44873 CALL PYSLHA(1,0,IFAIL)
44874 ENDIF
44875
44876C...Common couplings.
44877 TANB=RMSS(5)
44878 BETA=ATAN(TANB)
44879 COSB=COS(BETA)
44880 SINB=TANB*COSB
44881 COS2B=COS(2D0*BETA)
44882 ALFA=RMSS(18)
44883 XMW2=PMAS(24,1)**2
44884 XMZ2=PMAS(23,1)**2
44885 XW=PARU(102)
44886
44887C...Define sparticle masses for a general MSSM simulation.
44888 IF(IMSSM.EQ.1) THEN
44889 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
44890 DO 130 I=1,5,2
44891 KC=PYCOMP(KSUSY1+I)
44892 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
44893 KC=PYCOMP(KSUSY2+I)
44894 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
44895 KC=PYCOMP(KSUSY1+I+1)
44896 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
44897 KC=PYCOMP(KSUSY2+I+1)
44898 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
44899 130 CONTINUE
44900 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
44901 IF(XARG.LT.0D0) THEN
44902 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44903 & ' FROM THE SUM RULE. '
44904 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44905 RETURN
44906 ELSE
44907 XARG=SQRT(XARG)
44908 ENDIF
44909 DO 140 I=11,15,2
44910 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44911 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44912 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44913 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44914 140 CONTINUE
44915 IF(IMSS(8).EQ.1) THEN
44916 RMSS(13)=RMSS(6)
44917 RMSS(14)=RMSS(7)
44918 ENDIF
44919
44920C...Alternatively derive masses from SUGRA relations.
44921 ELSEIF(IMSSM.EQ.2) THEN
44922 RMSS(36)=RMSS(16)
44923 CALL PYAPPS
44924C...Or use ISASUSY
44925 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44926 RMSS(36)=RMSS(16)
44927 CALL PYSUGI
44928 ALFA=RMSS(18)
44929 GOTO 170
44930 ELSE
44931 GOTO 170
44932 ENDIF
44933
44934C...Add in extra D-term contributions.
44935 IF(IMSS(7).EQ.1) THEN
44936 R=0.43D0
44937 DX=RMSS(23)
44938 DY=RMSS(24)
44939 DS=RMSS(25)
44940 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44941 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44942 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44943 WRITE(MSTU(11),*) 'C DX = ',DX
44944 WRITE(MSTU(11),*) 'C DY = ',DY
44945 WRITE(MSTU(11),*) 'C DS = ',DS
44946 WRITE(MSTU(11),*) 'C '
44947 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44948 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44949 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44950 DQ2=DY/6D0-DX/3D0-DS/3D0
44951 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44952 DD2=DY/3D0+DX-2D0*DS/3D0
44953 DL2=-DY/2D0+DX-2D0*DS/3D0
44954 DE2=DY-DX/3D0-DS/3D0
44955 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44956 DHD2=-DY/2D0-2D0*DX/3D0+DS
44957 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44958 & /ABS(COS2B)
44959 DMA2 = 2D0*DMU2+DHU2+DHD2
44960 DO 150 I=1,5,2
44961 KC=PYCOMP(KSUSY1+I)
44962 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44963 KC=PYCOMP(KSUSY2+I)
44964 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44965 KC=PYCOMP(KSUSY1+I+1)
44966 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44967 KC=PYCOMP(KSUSY2+I+1)
44968 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44969 150 CONTINUE
44970 DO 160 I=11,15,2
44971 KC=PYCOMP(KSUSY1+I)
44972 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44973 KC=PYCOMP(KSUSY2+I)
44974 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44975 KC=PYCOMP(KSUSY1+I+1)
44976 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44977 160 CONTINUE
44978 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44979 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44980 CALL PYSTOP(104)
44981 ENDIF
44982 SGNMU=SIGN(1D0,RMSS(4))
44983 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44984 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44985 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44986 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44987 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44988 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44989 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44990 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44991 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44992 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44993 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44994 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44995 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44996 CALL PYSTOP(104)
44997 ENDIF
44998 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44999 RMSS(6)=SQRT(RMSS(6)**2+DL2)
45000 RMSS(7)=SQRT(RMSS(7)**2+DE2)
45001 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45002 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45003 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45004 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45005 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45006 ENDIF
45007
45008C...Fix the third generation sfermions.
45009 CALL PYTHRG
45010
45011C...Fix the neutralino--chargino--gluino sector.
45012 CALL PYINOM
45013
45014C...Fix the Higgs sector.
45015 CALL PYHGGM(ALFA)
45016
45017C...Choose the Gunion-Haber convention.
45018 ALFA=-ALFA
45019 RMSS(18)=ALFA
45020
45021C...Print information on mass parameters.
45022 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45023 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45024 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45025 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45026 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45027 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45028 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45029 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45030 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45031 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45032 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45033 ENDIF
45034 IF(IMSS(20).EQ.1) THEN
45035 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45036 WRITE(MSTU(11),*) ' DEBUG MODE '
45037 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45038 & UMIX(2,1),UMIX(2,2)
45039 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45040 & UMIXI(2,1),UMIXI(2,2)
45041 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45042 & VMIX(2,1),VMIX(2,2)
45043 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45044 & VMIXI(2,1),VMIXI(2,2)
45045 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45046 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45047 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45048 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45049 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45050 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45051 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45052 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45053 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45054 WRITE(MSTU(11),*) ' BETA = ',BETA
45055 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45056 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45057 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45058 ENDIF
45059
45060C...Set up the Higgs couplings - needed here since initialization
45061C...in PYINRE did not yet occur when PYWIDT is called below.
45062 170 AL=ALFA
45063 BE=BETA
45064 SINA=SIN(AL)
45065 COSA=COS(AL)
45066 COSB=COS(BE)
45067 SINB=TANB*COSB
45068 SBMA=SIN(BE-AL)
45069 SAPB=SIN(AL+BE)
45070 CAPB=COS(AL+BE)
45071 CBMA=COS(BE-AL)
45072 C2A=COS(2D0*AL)
45073 C2B=COSB**2-SINB**2
45074C...tanb (used for H+)
45075 PARU(141)=TANB
45076
45077C...Firstly: h
45078C...Coupling to d-type quarks
45079 PARU(161)=SINA/COSB
45080C...Coupling to u-type quarks
45081 PARU(162)=-COSA/SINB
45082C...Coupling to leptons
45083 PARU(163)=PARU(161)
45084C...Coupling to Z
45085 PARU(164)=SBMA
45086C...Coupling to W
45087 PARU(165)=PARU(164)
45088
45089C...Secondly: H
45090C...Coupling to d-type quarks
45091 PARU(171)=-COSA/COSB
45092C...Coupling to u-type quarks
45093 PARU(172)=-SINA/SINB
45094C...Coupling to leptons
45095 PARU(173)=PARU(171)
45096C...Coupling to Z
45097 PARU(174)=CBMA
45098C...Coupling to W
45099 PARU(175)=PARU(174)
45100C...Coupling to h
45101 IF(IMSS(4).GE.2) THEN
45102 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45103 ELSE
45104 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45105 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45106 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45107 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45108 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45109 ENDIF
45110C...Coupling to H+
45111C...Define later
45112 IF(IMSS(4).GE.2) THEN
45113 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45114 ELSE
45115 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45116 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45117 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45118 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45119 ENDIF
45120C...Coupling to A
45121 IF(IMSS(4).GE.2) THEN
45122 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45123 ELSE
45124 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45125 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45126 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45127 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45128 ENDIF
45129C...Coupling to H+
45130 IF(IMSS(4).GE.2) THEN
45131 PARU(178)=PARU(177)
45132 ELSE
45133 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45134 ENDIF
45135C...Thirdly, A
45136C...Coupling to d-type quarks
45137 PARU(181)=TANB
45138C...Coupling to u-type quarks
45139 PARU(182)=1D0/PARU(181)
45140C...Coupling to leptons
45141 PARU(183)=PARU(181)
45142 PARU(184)=0D0
45143 PARU(185)=0D0
45144C...Coupling to Z h
45145 PARU(186)=COS(BE-AL)
45146C...Coupling to Z H
45147 PARU(187)=SIN(BE-AL)
45148 PARU(188)=0D0
45149 PARU(189)=0D0
45150 PARU(190)=0D0
45151
45152C...Finally: H+
45153C...Coupling to W h
45154 PARU(195)=COS(BE-AL)
45155
45156C...Tell that all Higgs couplings have been set.
45157 MSTP(4)=1
45158
45159C...Set R-Violating couplings.
45160C...Set lambda couplings to common value or "natural values".
45161 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45162 VIR3=1D0/(126D0)**3
45163 DO 200 IRK=1,3
45164 DO 190 IRI=1,3
45165 DO 180 IRJ=1,3
45166 IF (IRI.NE.IRJ) THEN
45167 IF (IRI.LT.IRJ) THEN
45168 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45169 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45170 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45171 & PMAS(9+2*IRK,1)*VIR3)
45172 ELSE
45173 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45174 ENDIF
45175 ELSE
45176 RVLAM(IRI,IRJ,IRK)=0D0
45177 ENDIF
45178 180 CONTINUE
45179 190 CONTINUE
45180 200 CONTINUE
45181 ENDIF
45182C...Set lambda' couplings to common value or "natural values".
45183 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45184 VIR3=1D0/(126D0)**3
45185 DO 230 IRI=1,3
45186 DO 220 IRJ=1,3
45187 DO 210 IRK=1,3
45188 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45189 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45190 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45191 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45192 210 CONTINUE
45193 220 CONTINUE
45194 230 CONTINUE
45195 ENDIF
45196C...Set lambda'' couplings to common value or "natural values".
45197 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45198 VIR3=1D0/(126D0)**3
45199 DO 260 IRI=1,3
45200 DO 250 IRJ=1,3
45201 DO 240 IRK=1,3
45202 IF (IRJ.NE.IRK) THEN
45203 IF (IRJ.LT.IRK) THEN
45204 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45205 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45206 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45207 & PMAS(2*IRK-1,1)*VIR3)
45208 ELSE
45209 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45210 ENDIF
45211 ELSE
45212 RVLAMB(IRI,IRJ,IRK) = 0D0
45213 ENDIF
45214 240 CONTINUE
45215 250 CONTINUE
45216 260 CONTINUE
45217 ENDIF
45218
45219C...Antisymmetrize couplings set by user
45220 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45221 DO 290 IRI=1,3
45222 DO 280 IRJ=1,3
45223 DO 270 IRK=1,3
45224 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45225 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45226 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45227 ENDIF
45228 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45229 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45230 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45231 ENDIF
45232 270 CONTINUE
45233 280 CONTINUE
45234 290 CONTINUE
45235 ENDIF
45236
45237C...Write spectrum to SLHA file
45238 IF (IMSS(23).NE.0) THEN
45239 IFAIL=0
45240 CALL PYSLHA(3,0,IFAIL)
45241 ENDIF
45242
45243C...Second part of routine: set decay modes and branching ratios.
45244
45245C...Allow chi10 -> gravitino + gamma or not.
45246 KC=PYCOMP(KSUSY1+39)
45247 IF( IMSS(11) .NE. 0 ) THEN
45248 PMAS(KC,1)=RMSS(21)/1D9
45249 PMAS(KC,2)=0D0
45250 IRPRTY=0
45251 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45252 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
45253 IRPRTY=0
45254 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
45255 & ' ALLOWING SUSY LLE DECAYS'
45256 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
45257 & ' ALLOWING SUSY LQD DECAYS'
45258 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
45259 & ' ALLOWING SUSY UDD DECAYS'
45260 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
45261 & ' --- Warning: R-Violating couplings possibly',
45262 & ' incompatible with proton decay'
45263 ELSE
45264 PMAS(KC,1)=9999D0
45265 IRPRTY=1
45266 ENDIF
45267
45268C...Loop over sparticle and Higgs species.
45269 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
45270C...Find the LSP or NLSP for a gravitino LSP
45271 ILSP=0
45272 PMLSP=1D20
45273 DO 300 I=1,36
45274 KF=KFSUSY(I)
45275 IF(KF.EQ.1000039) GOTO 300
45276 KC=PYCOMP(KF)
45277 IF(PMAS(KC,1).LT.PMLSP) THEN
45278 ILSP=I
45279 PMLSP=PMAS(KC,1)
45280 ENDIF
45281 300 CONTINUE
45282 DO 370 I=1,50
45283 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
45284 KF=KFSUSY(I)
45285 IF (KF.EQ.0) GOTO 370
45286 KC=PYCOMP(KF)
45287 LKNT=0
45288
45289C...Check if there are any decays listed for this sparticle
45290C...in a file
45291 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
45292 IFAIL=0
45293 CALL PYSLHA(2,KF,IFAIL)
45294 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
45295 ELSEIF (I.GE.37) THEN
45296 GOTO 370
45297 ENDIF
45298
45299C...Sfermion decays.
45300 IF(I.LE.24) THEN
45301C...First check to see if sneutrino is lighter than chi10.
45302 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
45303 & PMAS(KC,1).LT.PMCHI1) THEN
45304 ELSE
45305 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
45306 ENDIF
45307
45308C...Gluino decays.
45309 ELSEIF(I.EQ.25) THEN
45310 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
45311 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
45312
45313C...Neutralino decays.
45314 ELSEIF(I.GE.26.AND.I.LE.29) THEN
45315 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
45316C...chi10 stable or chi10 -> gravitino + gamma.
45317 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
45318 PMAS(KC,2)=1D-6
45319 MDCY(KC,1)=0
45320 MWID(KC)=0
45321 ENDIF
45322
45323C...Chargino decays.
45324 ELSEIF(I.GE.30.AND.I.LE.31) THEN
45325 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
45326
45327C...Gravitino is stable.
45328 ELSEIF(I.EQ.32) THEN
45329 MDCY(KC,1)=0
45330 MWID(KC)=0
45331
45332C...Higgs decays.
45333 ELSEIF(I.GE.33.AND.I.LE.36) THEN
45334C...Calculate decays to non-SUSY particles.
45335 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
45336 LKNT=0
45337 DO 310 I1=0,100
45338 XLAM(I1)=0D0
45339 310 CONTINUE
45340 DO 330 I1=1,MDCY(KC,3)
45341 K1=MDCY(KC,2)+I1-1
45342 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
45343 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
45344 XLAM(I1)=WDTP(I1)
45345 XLAM(0)=XLAM(0)+XLAM(I1)
45346 DO 320 J1=1,3
45347 IDLAM(I1,J1)=KFDP(K1,J1)
45348 320 CONTINUE
45349 LKNT=LKNT+1
45350 330 CONTINUE
45351C...Add the decays to SUSY particles.
45352 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
45353 ENDIF
45354C...Zero the branching ratios for use in loop mode
45355C...thanks to K. Matchev (FNAL)
45356 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45357 BRAT(IDC)=0D0
45358 340 CONTINUE
45359
45360C...Set stable particles.
45361 IF(LKNT.EQ.0) THEN
45362 MDCY(KC,1)=0
45363 MWID(KC)=0
45364 PMAS(KC,2)=1D-6
45365 PMAS(KC,3)=1D-5
45366 PMAS(KC,4)=0D0
45367
45368C...Store branching ratios in the standard tables.
45369 ELSE
45370 IDC=MDCY(KC,2)+MDCY(KC,3)-1
45371 DELM=1D6
45372 DO 360 IL=1,LKNT
45373 IDCSV=IDC
45374 350 IDC=IDC+1
45375 BRAT(IDC)=0D0
45376 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
45377 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
45378 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
45379 BRAT(IDC)=XLAM(IL)/XLAM(0)
45380 XMDIF=PMAS(KC,1)
45381 IF(MDME(IDC,1).GE.1) THEN
45382 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
45383 & PMAS(PYCOMP(KFDP(IDC,2)),1)
45384 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
45385 & PMAS(PYCOMP(KFDP(IDC,3)),1)
45386 ENDIF
45387 IF(I.LE.32) THEN
45388 IF(XMDIF.GE.0D0) THEN
45389 DELM=MIN(DELM,XMDIF)
45390 ELSE
45391 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
45392 WRITE(MSTU(11),*) ' KF = ',KF
45393 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
45394 ENDIF
45395 ENDIF
45396 GOTO 360
45397 ELSEIF(IDC.EQ.IDCSV) THEN
45398 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
45399 & 'channel not recognized:'
45400 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
45401 GOTO 360
45402 ELSE
45403 GOTO 350
45404 ENDIF
45405 360 CONTINUE
45406
45407C...Store width, cutoff and lifetime.
45408 PMAS(KC,2)=XLAM(0)
45409 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
45410 PMAS(KC,3)=PMAS(KC,2)*10D0
45411 ELSE
45412 PMAS(KC,3)=0.95D0*DELM
45413 ENDIF
45414 IF(PMAS(KC,2).NE.0D0) THEN
45415 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
45416 ENDIF
45417C...Write decays to SLHA file
45418 IF (IMSS(24).NE.0) THEN
45419 IFAIL=0
45420 CALL PYSLHA(4,KF,IFAIL)
45421 ENDIF
45422
45423 ENDIF
45424 370 CONTINUE
45425
45426 RETURN
45427 END
45428C*********************************************************************
45429
45430C...PYSLHA
45431C...Read/write spectrum or decay data from SLHA standard file(s).
45432C...P. Skands
45433
45434C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45435C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45436C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45437C... (KFORIG=0 : read all decay tables)
45438C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45439C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45440C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45441C... (KFORIG=0 : read all MASS entries)
45442
45443 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
45444
45445C...Double precision and integer declarations.
45446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45447 IMPLICIT INTEGER(I-N)
45448 INTEGER PYK,PYCHGE,PYCOMP
45449 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45450 &KEXCIT=4000000,KDIMEN=5000000)
45451C...Commonblocks.
45452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45453 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45454 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45455 COMMON/PYDAT4/CHAF(500,2)
45456 CHARACTER CHAF*16
45457 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45458 CHARACTER*40 ISAVER,VISAJE
45459 COMMON/PYINT4/MWID(500),WIDS(500,5)
45460 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
45461C...SUSY blocks
45462 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45463 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45464 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45465 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45466 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
45467
45468C...Local arrays, character variables and data.
45469 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45470 & AU(3,3),AD(3,3),AE(3,3)
45471 COMMON/PYLH3C/CPRO(2),CVER(2)
45472C...The common block of new states (QNUMBERS / PARTICLE)
45473 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45474C...- NQNUM : Number of QNUMBERS blocks that have been read in
45475C...- KQNUM(I,0) : KF of new state
45476C...- KQNUM(I,1) : 3 times electric charge
45477C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45478C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45479C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45480C...- KQNUM(I,5:9) : space available for further quantum numbers
45481 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
45482 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
45483C...MMOD: flags to set for each block read in.
45484C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45485C...MSPC: Flags to set for each block read in.
45486C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45487C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45488C...11: AD 12: AE 13: YU 14: YD 15: YE
45489C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45490 CHARACTER CPRO*12,CVER*12,CHNLIN*6
45491 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45492 CHARACTER CHINL*120,CHKF*9,CHTMP*16
45493 INTEGER VERBOS
45494 SAVE VERBOS
45495C...Date of last Change
45496 PARAMETER (DOC='13 Jul 2009')
45497C...Local arrays and initial values
45498 DIMENSION IDC(5),KFSUSY(50)
45499 SAVE KFSUSY
45500 DATA NQNUM /0/
45501 DATA NDECAY /0/
45502 DATA VERBOS /1/
45503 DATA NHELLO /0/
45504 DATA MLHEF /0/
45505 DATA MLHEFD /0/
45506 DATA KFSUSY/
45507 &1000001,1000002,1000003,1000004,1000005,1000006,
45508 &2000001,2000002,2000003,2000004,2000005,2000006,
45509 &1000011,1000012,1000013,1000014,1000015,1000016,
45510 &2000011,2000012,2000013,2000014,2000015,2000016,
45511 &1000021,1000022,1000023,1000025,1000035,1000024,
45512 &1000037,1000039, 25, 35, 36, 37,
45513 & 6, 24, 45, 46,1000045, 9*0/
45514 DATA KFDEC/100*0/
45515 RMFUN(IP)=PMAS(PYCOMP(IP),1)
45516
45517C...Shorthand for spectrum and decay table unit numbers
45518 IMSS21=IMSS(21)
45519 IMSS22=IMSS(22)
45520
45521C...Default for LHEF input: read header information
45522 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
45523 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
45524 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
45525 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
45526
45527C...Hello World
45528 IF (NHELLO.EQ.0) THEN
45529 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
45530 WRITE(MSTU(11),5000) DOC
45531 NHELLO=1
45532 ENDIF
45533 ENDIF
45534
45535C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45536C...+MUPDA).
45537 LFN=IMSS21
45538 IF (MUPDA.EQ.2) LFN=IMSS22
45539 IF (MUPDA.EQ.3) LFN=IMSS(23)
45540 IF (MUPDA.EQ.4) LFN=IMSS(24)
45541C...Flag that we have not yet found whatever we were asked to find.
45542 IRETRN=1
45543C...Flag that we are skipping until <slha> tag found (if LHEF)
45544 ISKIP=0
45545 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
45546
45547C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45548 IF (LFN.EQ.0) THEN
45549 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45550 GOTO 9999
45551 ENDIF
45552
45553C...If reading LHEF header, start by rewinding file
45554 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
45555
45556C...If told to read spectrum, first zero all previous information.
45557 IF (MUPDA.EQ.1) THEN
45558C...Zero all block read flags
45559 DO 100 M=1,100
45560 MMOD(M)=0
45561 MSPC(M)=0
45562 100 CONTINUE
45563C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45564 DO 110 ISUSY=1,36
45565 KC=PYCOMP(KFSUSY(ISUSY))
45566 PMAS(KC,1)=0D0
45567 110 CONTINUE
45568C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45569 DO 130 J=1,4
45570 SFMIX(5,J) =0D0
45571 SFMIX(6,J) =0D0
45572 SFMIX(15,J)=0D0
45573 DO 120 L=1,4
45574 ZMIX(L,J) =0D0
45575 ZMIXI(L,J)=0D0
45576 IF (J.LE.2.AND.L.LE.2) THEN
45577 UMIX(L,J) =0D0
45578 UMIXI(L,J)=0D0
45579 VMIX(L,J) =0D0
45580 VMIXI(L,J)=0D0
45581 ENDIF
45582 120 CONTINUE
45583C...Zero signed masses.
45584 SMZ(J)=0D0
45585 IF (J.LE.2) SMW(J)=0D0
45586 130 CONTINUE
45587
45588C...If reading decays, reset PYTHIA decay counters.
45589 ELSEIF (MUPDA.EQ.2) THEN
45590C...Check if DECAY for this KF already read
45591 IF (KFORIG.NE.0) THEN
45592 DO 140 IDEC=1,NDECAY
45593 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
45594 IRETRN=0
45595 RETURN
45596 ENDIF
45597 140 CONTINUE
45598 ENDIF
45599 KCC=100
45600 NDC=0
45601 BRSUM=0D0
45602 DO 150 KC=1,MSTU(6)
45603 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
45604 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
45605 150 CONTINUE
45606 ELSEIF (MUPDA.EQ.5) THEN
45607C...Zero block read flags
45608 DO 160 M=1,100
45609 MSPC(M)=0
45610 160 CONTINUE
45611 ENDIF
45612
45613C............READ
45614C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45615 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
45616C...Initialize program and version strings
45617 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
45618 CPRO(MUPDA)=' '
45619 CVER(MUPDA)=' '
45620 ENDIF
45621
45622C...Initialize read loop
45623 MERR=0
45624 NLINE=0
45625 CHBLCK=' '
45626C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45627 170 CHINL=' '
45628 READ(LFN,'(A120)',END=400) CHINL
45629C...Count which line number we're at.
45630 NLINE=NLINE+1
45631 WRITE(CHNLIN,'(I6)') NLINE
45632
45633C...Skip comment and empty lines without processing.
45634 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
45635
45636C...We assume all upper case below. Rewrite CHINL to all upper case.
45637 INL=0
45638 IGOOD=0
45639 180 INL=INL+1
45640 IF (CHINL(INL:INL).NE.'#') THEN
45641 DO 190 ICH=97,122
45642 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
45643 190 CONTINUE
45644C...Extra safety. Chek for sensible input on line
45645 IF (IGOOD.EQ.0) THEN
45646 DO 200 ICH=48,90
45647 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
45648 200 CONTINUE
45649 ENDIF
45650 IF (INL.LT.120) GOTO 180
45651 ENDIF
45652 IF (IGOOD.EQ.0) GOTO 170
45653
45654C...If reading from LHEF file, skip until <slha> begin tag found
45655 IF (ISKIP.NE.0) THEN
45656 DO 205 I1=1,10
45657 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
45658 205 CONTINUE
45659 IF (ISKIP.NE.0) GOTO 170
45660 ENDIF
45661
45662C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45663 DO 210 I1=1,10
45664 IF (CHINL(I1:I1+5).EQ.'</SLHA'
45665 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
45666 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
45667 REWIND(LFN)
45668 GOTO 400
45669 ENDIF
45670 210 CONTINUE
45671
45672C...Check for BLOCK begin statement (spectrum).
45673 IF (CHINL(1:5).EQ.'BLOCK') THEN
45674 MERR=0
45675 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
45676C...Check if another of this type of block was already read.
45677C...(logarithmic interpolation not yet implemented, so duplicates always
45678C...give errors)
45679 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
45680 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
45681 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
45682 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
45683 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
45684 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
45685 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
45686 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
45687 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
45688 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
45689 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
45690 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
45691 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
45692 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
45693 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
45694 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
45695 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
45696C...Check for new particles
45697 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45698 & THEN
45699 MSPC(19)=MSPC(19)+1
45700C...Read PDG code
45701 READ(CHBLCK(9:60),*) KFQ
45702
45703 DO 220 MQ=1,NQNUM
45704 IF (KQNUM(MQ,0).EQ.KFQ) THEN
45705 MERR=17
45706 GOTO 380
45707 ENDIF
45708 220 CONTINUE
45709 IF (NHELLO.EQ.0) THEN
45710 WRITE(MSTU(11),5000) DOC
45711 NHELLO=1
45712 ENDIF
45713 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45714 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
45715 & ' for KF =',KFQ
45716 NQNUM=NQNUM+1
45717 KQNUM(NQNUM,0)=KFQ
45718 MSPC(19)=MSPC(19)+1
45719 KCQ=PYCOMP(KFQ)
45720C...Only read in new codes (also OK to overwrite if KF > 3000000)
45721 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
45722 IF (KCQ.EQ.0) THEN
45723 DO 230 KCT=100,MSTU(6)
45724 IF(KCHG(KCT,4).GT.100) KCQ=KCT
45725 230 CONTINUE
45726 KCQ=KCQ+1
45727 ENDIF
45728 KCC=KCQ
45729 KCHG(KCQ,4)=KFQ
45730C...First write PDG code as name
45731 WRITE(CHTMP,*) KFQ
45732 WRITE(CHTMP,'(A)') CHTMP(2:10)
45733C...Then look for real name
45734 IBEG=9
45735 240 IBEG=IBEG+1
45736 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
45737 250 IBEG=IBEG+1
45738 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
45739 IEND=IBEG-1
45740 260 IEND=IEND+1
45741 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
45742 IF (IEND.LT.59) THEN
45743 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
45744 IF (CHDUM.NE.' ') CHTMP=CHDUM
45745 ENDIF
45746 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
45747 MSTU(20)=0
45748C...Set stable for now
45749 PMAS(KCQ,2)=1D-6
45750 MWID(KCQ)=0
45751 MDCY(KCQ,1)=0
45752 MDCY(KCQ,2)=0
45753 MDCY(KCQ,3)=0
45754 ELSE
45755 WRITE(MSTU(11),*)
45756 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
45757 & CHAF(KCQ,1), '. Entry ignored.'
45758 MERR=7
45759 ENDIF
45760 ENDIF
45761C...Finalize this line and read next.
45762 GOTO 380
45763C...Check for DECAY begin statement (decays).
45764 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
45765 MERR=0
45766 BRSUM=0D0
45767 CHBLCK='DECAY'
45768C...Read KF code and WIDTH
45769 MPSIGN=1
45770 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
45771 IF (KF.LE.0) THEN
45772 KF=-KF
45773 MPSIGN=-1
45774 ENDIF
45775C...If this is not the KF we're looking for...
45776 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
45777C...Set block skip flag and read next line.
45778 MERR=16
45779 GOTO 380
45780 ELSE
45781C...Check whether decay table for this particle already read in
45782 DO 280 IDECAY=1,NDECAY
45783 IF (KFDEC(IDECAY).EQ.KF) THEN
45784 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
45785 & ' * (PYSLHA:) Ignoring DECAY table ',
45786 & 'for KF =',KF,' on line ',CHNLIN,
45787 & ' (duplicate)'
45788 MERR=16
45789 GOTO 380
45790 ENDIF
45791 280 CONTINUE
45792 ENDIF
45793
45794C...Determine PYTHIA KC code of particle
45795 KCREP=0
45796 IF(KF.LE.100) THEN
45797 KCREP=KF
45798 ELSE
45799 DO 290 KCR=101,KCC
45800 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
45801 290 CONTINUE
45802 ENDIF
45803 KC=KCREP
45804 IF (KCREP.NE.0) THEN
45805C...Particle is already known. Do not overwrite low-mass SM particles,
45806C...since this could give problems at hadronization / hadron decay stage.
45807 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
45808C...Set block skip flag and read next line
45809 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45810 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45811 & KF, ' (SLHA read-in not allowed)'
45812 MERR=16
45813 GOTO 380
45814 ENDIF
45815 ELSE
45816C... Add new particle. Actually, this should not happen.
45817C... New particles should be added already when reading the spectrum
45818C... information, so go under previously stable category.
45819 KCC=KCC+1
45820 KC=KCC
45821 ENDIF
45822
45823 IF (WIDTH.LE.0D0) THEN
45824C...Stable (i.e. LSP)
45825 WRITE(MSTU(11),'(A,I9,A,A)')
45826 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
45827 & KF,', ',CHAF(KCREP,1)(1:16)
45828 IF (WIDTH.LT.0D0) THEN
45829 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
45830 & ' zero !')
45831 WIDTH=0D0
45832 ENDIF
45833 PMAS(KC,2)=1D-6
45834 MWID(KC)=0
45835 MDCY(KC,1)=0
45836C...Ignore any decay lines that may be present for this KF
45837 MERR=16
45838 MDCY(KC,2)=0
45839 MDCY(KC,3)=0
45840C...Return ok
45841 IRETRN=0
45842 ENDIF
45843C...Finalize and start reading in decay modes.
45844 GOTO 380
45845 ELSEIF (MOD(MERR,10).GE.6) THEN
45846C...If ignore block flag set, skip directly to next line.
45847 GOTO 170
45848 ENDIF
45849
45850C...READ SPECTRUM
45851 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
45852 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45853 & THEN
45854 READ(CHINL,*) INDX, IVAL
45855 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
45856 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
45857 IF (INDX.EQ.3) KCHG(KCQ,2)=0
45858 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
45859 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
45860 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
45861 IF (INDX.EQ.4) THEN
45862 KCHG(KCQ,3)=IVAL
45863 IF (IVAL.EQ.1) THEN
45864 CHTMP=CHAF(KCQ,1)
45865 IF (CHTMP.EQ.' ') THEN
45866 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
45867 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
45868 ELSE
45869 ILAST=17
45870 300 ILAST=ILAST-1
45871 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
45872 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
45873 CHTMP(ILAST:ILAST)='-'
45874 ELSE
45875 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
45876 ENDIF
45877 CHAF(KCQ,2)=CHTMP
45878 ENDIF
45879 ENDIF
45880 ENDIF
45881 ELSE
45882 MERR=8
45883 ENDIF
45884 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
45885C...MASS: Mass spectrum
45886 IF (CHBLCK(1:4).EQ.'MASS') THEN
45887 READ(CHINL,*) KF, VAL
45888 MERR=1
45889 KC=0
45890 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
45891C...Read in masses for almost anything
45892 MERR=0
45893 KC=PYCOMP(KF)
45894 IF (KC.NE.0) THEN
45895C...Don't read in masses for special code particles
45896 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
45897 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45898 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45899 & KF, ' (KF reserved by PYTHIA)'
45900 GOTO 170
45901 ENDIF
45902C...Be careful with light SM particles / hadrons
45903 IF (PMAS(KC,1).LE.20D0) THEN
45904 IF (IABS(KF).LE.22) THEN
45905 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45906 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45907 & KF, ' (SLHA read-in not allowed)'
45908
45909 GOTO 170
45910 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
45911 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45912 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45913 & KF, ' (SLHA read-in not allowed)'
45914 GOTO 170
45915 ENDIF
45916 ENDIF
45917 MSPC(1)=MSPC(1)+1
45918 PMAS(KC,1) = ABS(VAL)
45919 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
45920 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45921 & ' * (PYSLHA:) Reading MASS entry for KF =',
45922 & KF, ', pole mass =', VAL
45923 IRETRN=0
45924 ENDIF
45925C...Check Z, W and top masses
45926 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
45927 & THEN
45928 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45929 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
45930 & //CHTMP)
45931 ENDIF
45932 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
45933 & THEN
45934 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45935 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
45936 & //CHTMP)
45937 ENDIF
45938 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
45939 & THEN
45940 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45941 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
45942 & //CHTMP//'GeV')
45943 ENDIF
45944C... Signed masses
45945 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
45946 IF (KF.EQ.1000022) SMZ(1)=VAL
45947 IF (KF.EQ.1000023) SMZ(2)=VAL
45948 IF (KF.EQ.1000025) SMZ(3)=VAL
45949 IF (KF.EQ.1000035) SMZ(4)=VAL
45950 IF (KF.EQ.1000024) SMW(1)=VAL
45951 IF (KF.EQ.1000037) SMW(2)=VAL
45952 ENDIF
45953 ELSEIF (MUPDA.EQ.5) THEN
45954 MERR=0
45955 ENDIF
45956C... MODSEL: Model selection and global switches
45957 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
45958 READ(CHINL,*) INDX, IVAL
45959 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45960 IF (IMSS(1).EQ.0) IMSS(1)=11
45961 MODSEL(INDX)=IVAL
45962 MMOD(1)=MMOD(1)+1
45963 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45964C... Switch on NMSSM
45965 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45966 IMSS(13)=MAX(1,IMSS(13))
45967C... Add NMSSM states if not already done
45968
45969 KFN=25
45970 KCN=KFN
45971 CHAF(KCN,1)='h_10'
45972 CHAF(KCN,2)=' '
45973
45974 KFN=35
45975 KCN=KFN
45976 CHAF(KCN,1)='h_20'
45977 CHAF(KCN,2)=' '
45978
45979 KFN=45
45980 KCN=KFN
45981 CHAF(KCN,1)='h_30'
45982 CHAF(KCN,2)=' '
45983
45984 KFN=36
45985 KCN=KFN
45986 CHAF(KCN,1)='A_10'
45987 CHAF(KCN,2)=' '
45988
45989 KFN=46
45990 KCN=KFN
45991 CHAF(KCN,1)='A_20'
45992 CHAF(KCN,2)=' '
45993
45994 KFN=1000045
45995 KCN=PYCOMP(KFN)
45996 IF (KCN.EQ.0) THEN
45997 DO 310 KCT=100,MSTU(6)
45998 IF(KCHG(KCT,4).GT.100) KCN=KCT
45999 310 CONTINUE
46000 KCN=KCN+1
46001 KCHG(KCN,4)=KFN
46002 MSTU(20)=0
46003 ENDIF
46004C... Set stable for now
46005 PMAS(KCN,2)=1D-6
46006 MWID(KCN)=0
46007 MDCY(KCN,1)=0
46008 MDCY(KCN,2)=0
46009 MDCY(KCN,3)=0
46010 CHAF(KCN,1)='~chi_50'
46011 CHAF(KCN,2)=' '
46012 ENDIF
46013 ELSE
46014 MERR=1
46015 ENDIF
46016 ELSEIF (MUPDA.EQ.5) THEN
46017C...If MUPDA = 5, skip all except MASS, return if MODSEL
46018 MERR=8
46019 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46020 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46021C...Don't print a warning for QNUMBERS when reading spectrum
46022 MERR=8
46023C...MINPAR: Minimal model parameters
46024 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46025 READ(CHINL,*) INDX, VAL
46026 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46027 PARMIN(INDX)=VAL
46028 MMOD(2)=MMOD(2)+1
46029 ELSE
46030 MERR=1
46031 ENDIF
46032 IF (MMOD(3).NE.0) THEN
46033 WRITE(MSTU(11),*)
46034 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46035 MERR=1
46036 ENDIF
46037C...tan(beta)
46038 IF (INDX.EQ.3) RMSS(5)=VAL
46039C...EXTPAR: non-minimal model parameters.
46040 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46041 IF (MMOD(1).NE.0) THEN
46042 READ(CHINL,*) INDX, VAL
46043 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46044 PAREXT(INDX)=VAL
46045 MMOD(3)=MMOD(3)+1
46046 ELSE
46047 MERR=1
46048 ENDIF
46049 ELSE
46050 WRITE(MSTU(11),*)
46051 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46052 MERR=1
46053 ENDIF
46054C...tan(beta)
46055 IF (INDX.EQ.25) RMSS(5)=VAL
46056 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46057 READ(CHINL,*) INDX, VAL
46058 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46059 MERR=1
46060 ELSEIF (INDX.EQ.4) THEN
46061 PMAS(PYCOMP(23),1)=VAL
46062 ELSEIF (INDX.EQ.6) THEN
46063 PMAS(PYCOMP(6),1)=VAL
46064 ENDIF
46065 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46066 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46067 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46068 $ THEN
46069C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46070 IM=0
46071 IF (CHBLCK(5:6).EQ.'IM') IM=1
46072 320 READ(CHINL,*) INDX1, INDX2, VAL
46073 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46074 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46075 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46076 MSPC(2)=MSPC(2)+1
46077 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46078 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46079 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46080 MSPC(3)=MSPC(3)+1
46081 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46082 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46083 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46084 MSPC(4)=MSPC(4)+1
46085 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46086 $ .CHBLCK(1:4).EQ.'STAU') THEN
46087 IF (CHBLCK(1:4).EQ.'STOP') THEN
46088 KFSM=6
46089 ISPC=6
46090 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46091 KFSM=5
46092 ISPC=5
46093 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46094 KFSM=15
46095 ISPC=7
46096 ENDIF
46097C...Set SFMIX element
46098 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46099 MSPC(ISPC)=MSPC(ISPC)+1
46100 ENDIF
46101C...Running parameters
46102 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46103 READ(CHBLCK(8:25),*,ERR=620) Q
46104 READ(CHINL,*) INDX, VAL
46105 MSPC(8)=MSPC(8)+1
46106 IF (INDX.EQ.1) THEN
46107 RMSS(4) = VAL
46108 ELSE
46109 MERR=1
46110 MSPC(8)=MSPC(8)-1
46111 ENDIF
46112 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46113 READ(CHINL,*,ERR=630) VAL
46114 RMSS(18)= VAL
46115 MSPC(17)=MSPC(17)+1
46116C...Higgs parameters set manually or with FeynHiggs.
46117 IMSS(4)=MAX(2,IMSS(4))
46118 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46119 & .CHBLCK(1:2).EQ.'AE') THEN
46120 READ(CHBLCK(9:26),*,ERR=620) Q
46121 READ(CHINL,*) INDX1, INDX2, VAL
46122 IF (CHBLCK(2:2).EQ.'U') THEN
46123 AU(INDX1,INDX2)=VAL
46124 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46125 MSPC(11)=MSPC(11)+1
46126 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46127 AD(INDX1,INDX2)=VAL
46128 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46129 MSPC(10)=MSPC(10)+1
46130 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46131 AE(INDX1,INDX2)=VAL
46132 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46133 MSPC(12)=MSPC(12)+1
46134 ELSE
46135 MERR=1
46136 ENDIF
46137 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46138 IF (MSPC(18).EQ.0) THEN
46139 READ(CHBLCK(9:25),*,ERR=620) Q
46140 RMSOFT(0)=Q
46141 ENDIF
46142 READ(CHINL,*) INDX, VAL
46143 RMSOFT(INDX)=VAL
46144 MSPC(18)=MSPC(18)+1
46145 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46146 MERR=8
46147 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46148 & .CHBLCK(1:2).EQ.'YE') THEN
46149 MERR=8
46150 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46151 READ(CHINL(1:6),*) INDX
46152 IT=0
46153 MIRD=0
46154 330 IT=IT+1
46155 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46156C...Don't read index
46157 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46158 MIRD=1
46159 GOTO 330
46160 ENDIF
46161 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46162 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46163 ELSE
46164C... Set unrecognized block flag.
46165 MERR=6
46166 ENDIF
46167
46168C...DECAY TABLES
46169C...Read in decay information
46170 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46171C...Read new decay chanel
46172 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46173 NDC=NDC+1
46174C...Read in branching ratio and number of daughters for this mode.
46175 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46176 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46177 IF (NDA.LE.5) THEN
46178 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46179 & '(PYSLHA:) Decay data arrays full by KF = '
46180 $ //CHAF(KC,1))
46181C...If first decay channel, set decays start point in decay table
46182 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46183 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46184 & '* (PYSLHA:) Reading DECAY table for '//
46185 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46186C...Set particle parameters (mass set when reading BLOCK MASS above)
46187 PMAS(KC,2)=WIDTH
46188 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46189 WRITE(MSTU(11),'(1x,A)')
46190 & '* Note: the Pythia gg->h/H/A cross section'//
46191 & ' is proportional to the h/H/A->gg width'
46192 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46193 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46194 WRITE(MSTU(11),'(1x,A,A16)')
46195 & '* Warning: will use DECAY table (fixed-width,'//
46196 & ' flat PS) for ',CHAF(KC,1)(1:16)
46197 ENDIF
46198 PMAS(KC,3)=0D0
46199 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46200 MWID(KC)=2
46201 MDCY(KC,1)=1
46202 MDCY(KC,2)=NDC
46203 MDCY(KC,3)=0
46204C...Add to list of DECAY blocks currently read
46205 NDECAY=NDECAY+1
46206 KFDEC(NDECAY)=KF
46207C...Return ok
46208 IRETRN=0
46209 ENDIF
46210C... Count up number of decay modes for this particle
46211 MDCY(KC,3)=MDCY(KC,3)+1
46212C... Read in decay daughters.
46213 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46214C... Flip sign if reading antiparticle decays (if antipartner exists)
46215 DO 340 IDA=1,NDA
46216 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46217 & IDC(IDA)=MPSIGN*IDC(IDA)
46218 340 CONTINUE
46219C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46220 MDME(NDC,1)=1
46221 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46222 BRSUM=BRSUM+ABS(BRAT(NDC))
46223 BRAT(NDC)=ABS(BRAT(NDC))
46224 350 IFLIP=0
46225 DO 360 IDA=1,NDA-1
46226 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46227 ITMP=IDC(IDA)
46228 IDC(IDA)=IDC(IDA+1)
46229 IDC(IDA+1)=ITMP
46230 IFLIP=IFLIP+1
46231 ENDIF
46232 360 CONTINUE
46233 IF (IFLIP.GT.0) GOTO 350
46234C...Treat as ordinary decay, no fancy stuff.
46235 MDME(NDC,2)=0
46236 DO 370 IDA=1,5
46237 IF (IDA.LE.NDA) THEN
46238 KFDP(NDC,IDA)=IDC(IDA)
46239 ELSE
46240 KFDP(NDC,IDA)=0
46241 ENDIF
46242 370 CONTINUE
46243C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46244C & (KFDP(NDC,J),J=1,NDA)
46245 ELSE
46246 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
46247 & CHNLIN)
46248 MERR=11
46249 NDC=NDC-1
46250 ENDIF
46251 ELSEIF(CHINL(1:1).EQ.'+') THEN
46252 MERR=11
46253 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
46254 MERR=16
46255 ELSE
46256 MERR=16
46257 ENDIF
46258 ENDIF
46259C... Error check.
46260 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
46261 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
46262 & //CHINL(1:40)
46263 MERR=0
46264 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
46265 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46266 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
46267 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
46268 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46269 & //CHBLCK(1:INL)//'... on line'//CHNLIN
46270 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
46271 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
46272 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
46273 & //'... on line'//CHNLIN
46274 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
46275 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46276 & /CHBLCK(1:INL)//'... on line'//CHNLIN
46277 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
46278 WRITE (CHTMP,*) KF
46279 WRITE(MSTU(11),*)
46280 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46281 & CHTMP(1:9)//' on line'//CHNLIN
46282 ENDIF
46283C...Iterate read loop
46284 GOTO 170
46285C...Error catching
46286 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
46287 & ', ignoring subsequent lines.'
46288 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
46289 CHBLCK=' '
46290 GOTO 170
46291C...End of read loop
46292 400 CONTINUE
46293C...Set flag that KC codes have been rearranged.
46294 MSTU(20)=0
46295 VERBOS=0
46296
46297C...Perform possible tests that new information is consistent.
46298 IF (MUPDA.EQ.1) THEN
46299 MSTU23=MSTU(23)
46300 MSTU27=MSTU(27)
46301C...Check masses
46302 DO 410 ISUSY=1,37
46303 KF=KFSUSY(ISUSY)
46304C...Don't complain about right-handed neutrinos
46305 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
46306 & +16) GOTO 410
46307C...Only check gravitino in GMSB scenarios
46308 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
46309 KC=PYCOMP(KF)
46310 IF (PMAS(KC,1).EQ.0D0) THEN
46311 WRITE(CHTMP,*) KF
46312 CALL PYERRM(9
46313 & ,'(PYSLHA:) No mass information found for KF ='
46314 & //CHTMP)
46315 ENDIF
46316 410 CONTINUE
46317C...Check mixing matrices (MSSM only)
46318 IF (IMSS(13).EQ.0) THEN
46319 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
46320 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46321 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
46322 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46323 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
46324 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46325 IF (MSPC(5).NE.4) CALL PYERRM(9
46326 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46327 IF (MSPC(6).NE.4) CALL PYERRM(9
46328 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46329 IF (MSPC(7).NE.4) CALL PYERRM(9
46330 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46331 IF (MSPC(8).LT.1) CALL PYERRM(9
46332 & ,'(PYSLHA:) Too few elements in HMIX')
46333 IF (MSPC(10).EQ.0) CALL PYERRM(9
46334 & ,'(PYSLHA:) Missing A_b trilinear coupling')
46335 IF (MSPC(11).EQ.0) CALL PYERRM(9
46336 & ,'(PYSLHA:) Missing A_t trilinear coupling')
46337 IF (MSPC(12).EQ.0) CALL PYERRM(9
46338 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46339 IF (MSPC(17).LT.1) CALL PYERRM(9
46340 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46341 ENDIF
46342C...Check wavefunction normalizations.
46343C...Sfermions
46344 DO 420 ISPC=5,7
46345 IF (MSPC(ISPC).EQ.4) THEN
46346 KFSM=ISPC
46347 IF (ISPC.EQ.7) KFSM=15
46348 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
46349 & *SFMIX(KFSM,3))
46350 IF (ABS(1D0-CHECK).GT.1D-3) THEN
46351 KCSM=PYCOMP(KFSM)
46352 CALL PYERRM(17
46353 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46354 & //CHAF(KCSM,1))
46355 ENDIF
46356C...Bug fix 30/09 2008: PS
46357C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46358 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
46359 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
46360 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
46361 ENDIF
46362 ENDIF
46363 420 CONTINUE
46364C...Neutralinos + charginos
46365 DO 440 J=1,4
46366 CN1=0D0
46367 CN2=0D0
46368 CU1=0D0
46369 CU2=0D0
46370 CV1=0D0
46371 CV2=0D0
46372 DO 430 L=1,4
46373 CN1=CN1+ZMIX(J,L)**2
46374 CN2=CN2+ZMIX(L,J)**2
46375 IF (J.LE.2.AND.L.LE.2) THEN
46376 CU1=CU1+UMIX(J,L)**2
46377 CU2=CU2+UMIX(L,J)**2
46378 CV1=CV1+VMIX(J,L)**2
46379 CV2=CV2+VMIX(L,J)**2
46380 ENDIF
46381 430 CONTINUE
46382C...NMIX normalization
46383 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
46384 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
46385 CALL PYERRM(19,
46386 & '(PYSLHA:) NMIX: Inconsistent normalization.')
46387 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
46388 ENDIF
46389C...UMIX, VMIX normalizations
46390 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
46391 IF (J.LE.2) THEN
46392 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
46393 CALL PYERRM(19
46394 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46395 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
46396 & CU2
46397 ENDIF
46398 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
46399 CALL PYERRM(19,
46400 & '(PYSLHA:) VMIX: Inconsistent normalization.')
46401 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
46402 & CV2
46403 ENDIF
46404 ENDIF
46405 ENDIF
46406 440 CONTINUE
46407 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
46408 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
46409 & '* (PYSLHA:) No spectrum inconsistencies were found.'
46410 ELSE
46411 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46412 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46413 & ,' Warning: one or more (serious)'//
46414 & ' inconsistencies were found in the spectrum !'
46415 & ,' Read the error messages above and check your'//
46416 & ' input file.'
46417 ENDIF
46418C...Increase precision in Higgs sector using FeynHiggs
46419 IF (IMSS(4).EQ.3) THEN
46420C...FeynHiggs needs MSOFT.
46421 IERR=0
46422 IF (MSPC(18).EQ.0) THEN
46423 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
46424 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46425 & ' Cannot call FeynHiggs.'
46426 IERR=-1
46427 ELSE
46428 WRITE(MSTU(11),'(1x,/1x,A/)')
46429 & '* (PYSLHA:) Now calling FeynHiggs.'
46430 CALL PYFEYN(IERR)
46431 IF (IERR.NE.0) IMSS(4)=2
46432 ENDIF
46433 ENDIF
46434 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
46435 IBEG=1
46436 IF (KFORIG.NE.0) IBEG=NDECAY
46437 DO 490 IDECAY=IBEG,NDECAY
46438 KF = KFDEC(IDECAY)
46439 KC = PYCOMP(KF)
46440 WRITE(CHKF,8300) KF
46441 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
46442 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
46443 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
46444 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46445 $ //CHKF)
46446 BRSUM=0D0
46447 BROPN=0D0
46448 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46449 IF(MDME(IDA,2).GT.80) GOTO 460
46450 KQ=KCHG(KC,1)
46451 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
46452 MERR=0
46453 DO 450 J=1,5
46454 KP=KFDP(IDA,J)
46455 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
46456 IF(KP.EQ.81) KQ=0
46457 ELSEIF(PYCOMP(KP).EQ.0) THEN
46458 MERR=3
46459 ELSE
46460 KQ=KQ-PYCHGE(KP)
46461 KPC=PYCOMP(KP)
46462 PMS=PMS-PMAS(KPC,1)
46463 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
46464 & PMAS(KPC,3))
46465 ENDIF
46466 450 CONTINUE
46467 IF(KQ.NE.0) MERR=MAX(2,MERR)
46468 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
46469 & MERR=MAX(1,MERR)
46470 IF(MERR.EQ.3) CALL PYERRM(17,
46471 & '(PYSLHA:) Unknown particle code in decay of KF ='
46472 $ //CHKF)
46473 IF(MERR.EQ.2) CALL PYERRM(17,
46474 & '(PYSLHA:) Charge not conserved in decay of KF ='
46475 $ //CHKF)
46476 IF(MERR.EQ.1) CALL PYERRM(7,
46477 & '(PYSLHA:) Kinematically unallowed decay of KF ='
46478 $ //CHKF)
46479 BRSUM=BRSUM+BRAT(IDA)
46480 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
46481 460 CONTINUE
46482C...Check branching ratio sum.
46483 IF (BROPN.LE.0D0) THEN
46484C...If zero, set stable.
46485 WRITE(CHTMP,8500) BROPN
46486 CALL PYERRM(7
46487 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
46488 & CHTMP(9:16)//'. Changed to stable.')
46489 PMAS(KC,2)=1D-6
46490 MWID(KC)=0
46491C...If BR's > 1, rescale.
46492 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
46493 WRITE(CHTMP,8500) BRSUM
46494 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
46495 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
46496 & ' ; sum was'//CHTMP(9:16)//'.')
46497 FAC=1D0/BRSUM
46498 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46499 IF(MDME(IDA,2).GT.80) GOTO 470
46500 BRAT(IDA)=FAC*BRAT(IDA)
46501 470 CONTINUE
46502 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
46503C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46504 WRITE(CHTMP,8500) BRSUM
46505 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
46506 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
46507 & CHTMP(9:16)//'. Dummy mode will be inserted.')
46508C...Move table and insert dummy mode
46509 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46510 NDC=NDC+1
46511 BRAT(NDC)=BRAT(IDA)
46512 KFDP(NDC,1)=KFDP(IDA,1)
46513 KFDP(NDC,2)=KFDP(IDA,2)
46514 KFDP(NDC,3)=KFDP(IDA,3)
46515 KFDP(NDC,4)=KFDP(IDA,4)
46516 KFDP(NDC,5)=KFDP(IDA,5)
46517 MDME(NDC,1)=MDME(IDA,1)
46518 480 CONTINUE
46519 NDC=NDC+1
46520 BRAT(NDC)=1D0-BRSUM
46521 KFDP(NDC,1)=0
46522 KFDP(NDC,2)=0
46523 KFDP(NDC,3)=0
46524 KFDP(NDC,4)=0
46525 KFDP(NDC,5)=0
46526 MDME(NDC,1)=0
46527 BRSUM=1D0
46528C...Update MDCY
46529 MDCY(KC,3)=MDCY(KC,3)+1
46530 MDCY(KC,2)=NDC-MDCY(KC,3)+1
46531 ENDIF
46532 490 CONTINUE
46533 ENDIF
46534
46535
46536C...WRITE SPECTRUM ON SLHA FILE
46537 ELSEIF(MUPDA.EQ.3) THEN
46538C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46539 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
46540 MODSEL(1)=1
46541 PARMIN(1)=RMSS(8)
46542 PARMIN(2)=RMSS(1)
46543 PARMIN(3)=RMSS(5)
46544 PARMIN(4)=SIGN(1D0,RMSS(4))
46545 PARMIN(5)=RMSS(36)
46546 ENDIF
46547C...Write spectrum
46548 WRITE(LFN,7000) 'SLHA MSSM spectrum'
46549 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46550 & // ' P. Skands.'
46551 WRITE(LFN,7010) 'MODSEL', 'Model selection'
46552 WRITE(LFN,7110) 1, MODSEL(1)
46553 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
46554 IF (MODSEL(1).EQ.1) THEN
46555 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
46556 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
46557 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46558 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46559 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
46560 ELSEIF(MODSEL(2).EQ.2) THEN
46561 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
46562 WRITE(LFN,7210) 2, PARMIN(2), 'M'
46563 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46564 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46565 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
46566 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
46567 ENDIF
46568 WRITE(LFN,7000) ' '
46569 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
46570 DO 500 I=1,36
46571 KF=KFSUSY(I)
46572 KC=PYCOMP(KF)
46573 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
46574 KFSM=KF-KSUSY1
46575 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
46576 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
46577 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
46578 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
46579 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
46580 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
46581 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
46582 ELSE
46583 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
46584 ENDIF
46585 500 CONTINUE
46586C...SUSY scale
46587 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
46588 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
46589 WRITE(LFN,7210) 1, RMSS(4),'mu'
46590 WRITE(LFN,7010) 'ALPHA',' '
46591 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
46592 WRITE(LFN,7020) 'AU',RMSUSY
46593 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
46594 WRITE(LFN,7020) 'AD',RMSUSY
46595 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
46596 WRITE(LFN,7020) 'AE',RMSUSY
46597 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
46598 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
46599 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
46600 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
46601 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
46602 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
46603 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
46604 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
46605 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
46606 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
46607 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
46608 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
46609 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
46610 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
46611 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
46612 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
46613 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
46614 DO 520 I1=1,4
46615 DO 510 I2=1,4
46616 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
46617 510 CONTINUE
46618 520 CONTINUE
46619 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
46620 DO 540 I1=1,2
46621 DO 530 I2=1,2
46622 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
46623 530 CONTINUE
46624 540 CONTINUE
46625 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
46626 DO 560 I1=1,2
46627 DO 550 I2=1,2
46628 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
46629 550 CONTINUE
46630 560 CONTINUE
46631 WRITE(LFN,7010) 'SPINFO'
46632 IF (IMSS(1).EQ.2) THEN
46633 CPRO(1)='PYTHIA'
46634 CVER(1)='6.4'
46635 ELSEIF (IMSS(1).EQ.12) THEN
46636 ISAVER=VISAJE()
46637 CPRO(1)='ISASUSY'
46638 CVER(1)=ISAVER(1:12)
46639 ENDIF
46640 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
46641 WRITE(LFN,7310) 2, CVER(1), 'Version number'
46642 ENDIF
46643
46644C...Print user information about spectrum
46645 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
46646 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
46647 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
46648 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
46649 IF (MUPDA.EQ.1) THEN
46650 WRITE(MSTU(11),5020) LFN
46651 ELSE
46652 WRITE(MSTU(11),5010) LFN
46653 ENDIF
46654
46655 WRITE(MSTU(11),5400)
46656 WRITE(MSTU(11),5500) 'Pole masses'
46657 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
46658 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
46659 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
46660 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
46661 IF (IMSS(13).EQ.0) THEN
46662 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
46663 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
46664 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
46665 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
46666 & CHAF(37,1), ' ', ' ',' ',' ',
46667 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
46668 ELSEIF (IMSS(13).EQ.1) THEN
46669 KF1=KSUSY1+21
46670 KF2=KSUSY1+22
46671 KF3=KSUSY1+23
46672 KF4=KSUSY1+25
46673 KF5=KSUSY1+35
46674 KF6=KSUSY1+45
46675 KF7=KSUSY1+24
46676 KF8=KSUSY1+37
46677 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
46678 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
46679 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
46680 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
46681 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
46682 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
46683 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
46684 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
46685 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
46686 & RMFUN(37)
46687 ENDIF
46688 WRITE(MSTU(11),5400)
46689 WRITE(MSTU(11),5500) 'Mixing structure'
46690 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46691 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46692 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46693 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46694 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46695 & ),(SFMIX(15,J),J=3,4)
46696 WRITE(MSTU(11),5400)
46697 WRITE(MSTU(11),5500) 'Couplings'
46698 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
46699 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
46700 WRITE(MSTU(11),5400)
46701 WRITE(MSTU(11),6500)
46702
46703 ENDIF
46704
46705C...Only rewind when reading
46706 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
46707
46708 9999 RETURN
46709
46710C...Serious error catching
46711 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
46712 write(*,*) CHINL(1:80)
46713 CALL PYSTOP(106)
46714 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
46715 WRITE(*,*) CHINL(1:72)
46716 CALL PYSTOP(106)
46717 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
46718 WRITE(*,*) CHINL(1:80)
46719 CALL PYSTOP(106)
46720 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
46721 WRITE(*,*) CHINL(1:80)
46722 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
46723 CALL PYSTOP(106)
46724 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
46725 WRITE(*,*) CHINL(1:80)
46726 CALL PYSTOP(106)
46727
46728 8300 FORMAT(I9)
46729 8500 FORMAT(F16.5)
46730
46731C...Formats for user information printout.
46732 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.13: SUSY/BSM SPECTRUM '
46733 & ,'INTERFACE',1x,17('*')/1x,'*',1x
46734 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
46735 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
46736 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
46737 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
46738 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46739 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46740 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46741 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46742 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46743 & ,'----------------')
46744 5400 FORMAT(1x,'*',1x,A)
46745 5500 FORMAT(1x,'*',1x,A,':')
46746 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46747 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46748 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46749 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46750 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46751 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46752 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46753 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46754 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46755 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46756 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46757 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
46758 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46759 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46760 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46761 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46762 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46763 & ,1x,F6.3,1x),'|')
46764 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46765 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46766 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46767 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46768 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46769 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46770 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46771 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46772 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46773 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46774 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46775 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46776 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
46777 & ,'A_tau = ',F8.2)
46778 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
46779 & ,' mu = ',F8.2)
46780 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46781
46782C...Format to use for comments
46783 7000 FORMAT('# ',A)
46784C...Format to use for block statements
46785 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
46786 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
46787C...Indexed Int
46788 7110 FORMAT(1x,I4,1x,I4,3x,'#')
46789C...Non-Indexed Double
46790 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
46791C...Indexed Double
46792 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
46793C...Long Indexed Double (PDG + double)
46794 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
46795C...Indexed Char(12)
46796 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
46797C...Single matrix
46798 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
46799C...Double Matrix
46800 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
46801C...Write Decay Table
46802 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
46803 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
46804 & 3x,'#',1x,A)
46805
46806 END
46807
46808
46809C*********************************************************************
46810
46811C...PYAPPS
46812C...Uses approximate analytical formulae to determine the full set of
46813C...MSSM parameters from SUGRA input.
46814C...See M. Drees and S.P. Martin, hep-ph/9504124
46815
46816 SUBROUTINE PYAPPS
46817
46818C...Double precision and integer declarations.
46819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46820 IMPLICIT INTEGER(I-N)
46821 INTEGER PYK,PYCHGE,PYCOMP
46822C...Parameter statement to help give large particle numbers.
46823 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46824 &KEXCIT=4000000,KDIMEN=5000000)
46825C...Commonblocks.
46826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46827 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46828 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46829 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
46830
46831 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46832 &' not intended for serious physics studies'
46833 IMSS(5)=0
46834 IMSS(8)=0
46835 XMT=PMAS(6,1)
46836 XMZ2=PMAS(23,1)**2
46837 XMW2=PMAS(24,1)**2
46838 TANB=RMSS(5)
46839 BETA=ATAN(TANB)
46840 XW=PARU(102)
46841 XMG=RMSS(1)
46842 XMG2=XMG*XMG
46843 XM0=RMSS(8)
46844 XM02=XM0*XM0
46845C...Temporary sign change for AT. Others unchanged.
46846 AT=-RMSS(16)
46847 RMSS(15)=RMSS(16)
46848 RMSS(17)=RMSS(16)
46849 SINB=TANB/SQRT(TANB**2+1D0)
46850 COSB=SINB/TANB
46851
46852 DTERM=XMZ2*COS(2D0*BETA)
46853 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
46854 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
46855 RMSS(6)=XMEL
46856 RMSS(7)=XMER
46857 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
46858 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
46859 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
46860 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
46861 DO 100 I=1,5,2
46862 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
46863 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
46864 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
46865 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
46866 100 CONTINUE
46867 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
46868 IF(XARG.LT.0D0) THEN
46869 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46870 & ' FROM THE SUM RULE. '
46871 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46872 RETURN
46873 ELSE
46874 XARG=SQRT(XARG)
46875 ENDIF
46876 DO 110 I=11,15,2
46877 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
46878 PMAS(PYCOMP(KSUSY2+I),1)=XMER
46879 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
46880 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
46881 110 CONTINUE
46882 RMT=PYMRUN(6,PMAS(6,1)**2)
46883 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
46884 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
46885 RMB=PYMRUN(5,PMAS(6,1)**2)
46886 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
46887 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
46888 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
46889 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
46890 &SINB)**2)
46891 RMSS(16)=-ATP
46892 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
46893 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
46894 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
46895 XMU=SIGN(SQRT(XMU2),RMSS(4))
46896 RMSS(4)=XMU
46897 IF(XMA2.GT.0D0) THEN
46898 RMSS(19)=SQRT(XMA2)
46899 ELSE
46900 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46901 CALL PYSTOP(102)
46902 ENDIF
46903 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
46904 IF(ARG.GT.0D0) THEN
46905 RMSS(14)=SQRT(ARG)
46906 ELSE
46907 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46908 CALL PYSTOP(102)
46909 ENDIF
46910 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
46911 IF(ARG.GT.0D0) THEN
46912 RMSS(13)=SQRT(ARG)
46913 ELSE
46914 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46915 CALL PYSTOP(102)
46916 ENDIF
46917 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
46918 IF(ARG.GT.0D0) THEN
46919 RMSS(10)=SQRT(ARG)
46920 ELSE
46921 RMSS(10)=-SQRT(-ARG)
46922 ENDIF
46923 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
46924 IF(ARG.GT.0D0) THEN
46925 RMSS(12)=SQRT(ARG)
46926 ELSE
46927 RMSS(12)=-SQRT(-ARG)
46928 ENDIF
46929 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
46930 IF(ARG.GT.0D0) THEN
46931 RMSS(11)=SQRT(ARG)
46932 ELSE
46933 RMSS(11)=-SQRT(-ARG)
46934 ENDIF
46935
46936 RETURN
46937 END
46938
46939C*********************************************************************
46940
46941C...PYSUGI
46942C...Interface to ISASUSY version 7.71.
46943C...Warning: this interface should not be used with earlier versions
46944C...of ISASUSY, since common block incompatibilities may then arise.
46945C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46946C...Then converts to Gunion-Haber conventions.
46947
46948 SUBROUTINE PYSUGI
46949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46950
46951 INTEGER PYK,PYCHGE,PYCOMP
46952 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46953 &KEXCIT=4000000,KDIMEN=5000000)
46954
46955C...Date of Change
46956 CHARACTER DOC*11
46957 PARAMETER (DOC='01 May 2006')
46958
46959C...ISASUGRA Input:
46960 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46961C...XISAIN contains the MSSMi inputs in natural order.
46962 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
46963 $XAMIN(7)
46964 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46965 SAVE /SUGXIN/
46966C...ISASUGRA Output
46967 CHARACTER*40 ISAVER,VISAJE
46968 REAL SUPER
46969 COMMON /SSPAR/ SUPER(72)
46970 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46971 $FBGUT,FTAGUT,FNGUT
46972 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46973 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46974 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46975 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46976 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46977 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46978 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46979 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46980 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46981 INTEGER IALLOW
46982 SAVE /SUGMG/,/SSPAR/
46983C SUPER: Filled by ISASUGRA.
46984C SUPER(1) = mass of ~g
46985C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46986C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46987C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46988C ,~tau_2
46989C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46990C SUPER(29) = Higgsino mass = - mu
46991C SUPER(30) = ratio v2/v1 of vev's
46992C SUPER(31:34) = Signed neutralino masses
46993C SUPER(35:50) = Neutralino mixing matrix
46994C SUPER(51:52) = Signed chargino masses
46995C SUPER(53:54) = Chargino left, right mixing angles
46996C SUPER(55:58) = mass of h0, H0, A0, H+
46997C SUPER(59) = Higgs mixing angle alpha
46998C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46999C SUPER(66) = Gravitino mass
47000C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
47001C SUPER(70) = b-Yukawa at mA scale (not used)
47002C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47003C GSS: Filled by ISASUGRA
47004C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47005C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47006C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47007C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47008C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47009C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47010C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47011C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47012C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47013C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47014C GSS(31) = log(vuq)
47015C MSS: Filled by ISASUGRA
47016C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47017C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47018C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47019C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47020C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47021C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47022C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47023C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47024C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47025C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47026C MSS(31) = ha0 MSS(32) = h+
47027C Unification, filled by ISASUGRA if applicable.
47028C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47029
47030C...SPYTHIA Input/Output
47031 INTEGER IMSS
47032 DOUBLE PRECISION RMSS
47033 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47034 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47035 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47036C...SLHA Input/Output
47037 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47038 & AU(3,3),AD(3,3),AE(3,3)
47039C...PYTHIA common blocks
47040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47041 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47042 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47043
47044 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47045CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47046 INTEGER IMODEL
47047 REAL M0,MHF,A0,MT
47048 CHARACTER*20 CHMOD(5)
47049 CHARACTER*32 FNAME
47050
47051 COMMON /SUGNU/ XNUSUG(18)
47052 REAL XNUSUG
47053 SAVE /SUGNU/
47054
47055 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47056 & 'truly unified SUGRA', 'non-minimal GMSB'/
47057
47058C...Start by checking for incompatibilities/inconsistencies:
47059 DO 100 ICHK=2,9
47060 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47061 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47062 & ,' option not used by PYSUGI'
47063 ENDIF
47064 100 CONTINUE
47065C...ISAJET works with REAL numbers.
47066 MZERO=REAL(RMSS(8))
47067 MHLF=REAL(RMSS(1))
47068 AZERO=REAL(RMSS(16))
47069 TANB=REAL(RMSS(5))
47070 SGNMU=REAL(RMSS(4))
47071 MTOP=REAL(PMAS(6,1))
47072 IMODEL=0
47073 IF (IMSS(1).EQ.12) THEN
47074 IMODEL=1
47075 GOTO 130
47076 ELSEIF(IMSS(1).EQ.13) THEN
47077C...Read from isajet par file in IMSS(20)
47078 LFN=IMSS(20)
47079C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47080 IF (LFN.EQ.0) THEN
47081 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47082 GOTO 9999
47083 ENDIF
47084 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47085CMrenna change to allow any susy model
47086 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47087 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47088 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47089 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47090 & ' gauge couplings:'
47091 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47092 READ(LFN,*) IMODEL
47093 IF (IMODEL.EQ.4) THEN
47094 IAL3UN=1
47095 IMODEL=1
47096 ENDIF
47097 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47098 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47099 & //' sgn(mu), M_t:'
47100 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47101 IF (IMODEL.EQ.3) THEN
47102 IMODEL=1
47103 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47104 & //' 0 to continue:'
47105 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47106 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47107 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47108 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47109 & //' generation masses'
47110 WRITE(MSTU(11),*)
47111 & ' NUSUG5 = GUT scale 3rd generation masses'
47112 READ(LFN,*) INUSUG
47113 IF (INUSUG.EQ.0) THEN
47114 GOTO 120
47115 ELSEIF (INUSUG.EQ.1) THEN
47116 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47117 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47118 IF (XNUSUG(3).LE.0.) THEN
47119 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47120 CALL PYSTOP(109)
47121 END IF
47122 ELSEIF (INUSUG.EQ.2) THEN
47123 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47124 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47125 ELSEIF (INUSUG.EQ.3) THEN
47126 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47127 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47128 ELSEIF (INUSUG.EQ.4) THEN
47129 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47130 & //' M(ur), M(el), M(er):'
47131 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47132 & XNUSUG(10),XNUSUG(9)
47133 ELSEIF (INUSUG.EQ.5) THEN
47134 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47135 & //' M(Ll), M(Lr):'
47136 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47137 & XNUSUG(15),XNUSUG(14)
47138 ENDIF
47139 GOTO 110
47140 ENDIF
47141 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47142 IMSS(11)=1
47143 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47144 & ,' sgn(mu), M_t, C_gv:'
47145 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47146 XGMIN(7)=XCMGV
47147 XGMIN(8)=1.
47148C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47149 AMPL=2.4D18
47150 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47151 IF (IMODEL.EQ.5) THEN
47152 IMODEL=2
47153 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47154 & ,' masses at M_mes'
47155 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47156 & ,' shifts at M_mes'
47157 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47158 & ' Y at M_mes'
47159 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47160 & ,'SU(2),SU(3)'
47161 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47162 & ,' n5_2, n5_3'
47163 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47164 $ XGMIN(13),XGMIN(14)
47165 ENDIF
47166 ELSE
47167 WRITE(MSTU(11),*) 'Invalid model choice.'
47168 GOTO 9999
47169 ENDIF
47170 ENDIF
47171
47172 120 MZERO=M0
47173 MHLF=MHF
47174 AZERO=A0
47175C TANB=REAL(RMSS(5))
47176C SGNMU=REAL(RMSS(4))
47177 MTOP=MT
47178
47179C...Initialize MSSM parameter array
47180 130 DO 140 IPAR=1,72
47181 SUPER(IPAR)=0.0
47182 140 CONTINUE
47183C...Call ISASUGRA
47184 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47185C...Check whether ISASUSY thought the model was OK.
47186 IF (NOGOOD.NE.0) THEN
47187 IF (NOGOOD.EQ.1) CALL PYERRM(26
47188 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47189 IF (NOGOOD.EQ.2) CALL PYERRM(26
47190 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47191 IF (NOGOOD.EQ.3) CALL PYERRM(26
47192 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47193 IF (NOGOOD.EQ.4) CALL PYERRM(26
47194 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47195 IF (NOGOOD.EQ.7) CALL PYERRM(26
47196 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47197 IF (NOGOOD.EQ.8) CALL PYERRM(26
47198 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47199C...Give warning, but don't stop, if LSP not ~chi_10.
47200 IF (NOGOOD.EQ.5) CALL PYERRM(16
47201 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47202 ENDIF
47203C...Warn about possible GUT scale tachyons.
47204 IF (ITACHY.NE.0) CALL PYERRM(16,
47205 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47206C...Finalize spectrum (last iteration)
47207C...(Thanks to A. Raklev for pointing this out.)
47208C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47209 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
47210 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
47211 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
47212 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
47213 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
47214 $ MTOP,IALLOW,1)
47215
47216C...M1, M2, M3.
47217 RMSS(1)=dble(GSS(7))
47218 RMSS(2)=dble(GSS(8))
47219 RMSS(3)=dble(GSS(9))
47220 RMSOFT(1)=dble(GSS(7))
47221 RMSOFT(2)=dble(GSS(8))
47222 RMSOFT(3)=dble(GSS(9))
47223C...Mu = - Higgsino mass.
47224 RMSS(4)=-SUPER(29)
47225 RMSS(5)=TANB
47226C...Slepton and squark masses. 2 first generations.
47227 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
47228 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
47229 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
47230 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
47231C...Third generation.
47232 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
47233 RMSS(11)=SUPER(11)
47234 RMSS(12)=SUPER(15)
47235 RMSS(13)=SUPER(22)
47236 RMSS(14)=SUPER(23)
47237C...SLHA: store exact soft spectrum in RMSOFT
47238 RMSOFT(31)=SUPER(18)
47239 RMSOFT(32)=SUPER(20)
47240 RMSOFT(33)=SUPER(22)
47241 RMSOFT(34)=SUPER(19)
47242 RMSOFT(35)=SUPER(21)
47243 RMSOFT(36)=SUPER(23)
47244 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
47245 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
47246 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
47247 RMSOFT(44)=SUPER(3)
47248 RMSOFT(45)=SUPER(9)
47249 RMSOFT(46)=SUPER(15)
47250 RMSOFT(47)=SUPER(5)
47251 RMSOFT(48)=SUPER(7)
47252 RMSOFT(49)=SUPER(11)
47253
47254C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47255 RMSS(15)=SUPER(62)
47256 RMSS(16)=SUPER(60)
47257 RMSS(17)=SUPER(64)
47258 RMSS(26)=SUPER(63)
47259 RMSS(27)=SUPER(61)
47260 RMSS(28)=SUPER(65)
47261C...SLHA trilinears
47262 DO 142 K1=1,3
47263 DO 141 K2=1,3
47264 AE(K1,K2)=0D0
47265 AU(K1,K2)=0D0
47266 AD(K1,K2)=0D0
47267 141 CONTINUE
47268 142 CONTINUE
47269 AE(3,3)=SUPER(64)
47270 AU(3,3)=SUPER(60)
47271 AD(3,3)=SUPER(62)
47272C...Higgs mixing angle alpha (Gunion-Haber convention).
47273 RMSS(18)=-SUPER(59)
47274C...A0 mass.
47275 RMSS(19)=SUPER(57)
47276C...GUT scale coupling
47277 RMSS(20)=AGUTSS
47278C...Gravitino mass (for future compatibility)
47279 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
47280
47281C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47282C...Higgs sector.
47283 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
47284 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
47285 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
47286 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
47287C...Gluino.
47288 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
47289C...Squarks and Sleptons.
47290 DO 150 ILR=1,2
47291 ILRM=ILR-1
47292 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
47293 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
47294 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
47295 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
47296 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
47297 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
47298 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
47299 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
47300 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
47301 150 CONTINUE
47302 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
47303 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
47304 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
47305C...Neutralinos.
47306 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
47307 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
47308 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
47309 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
47310C...Signed masses (extra minus from going to G-H convention).
47311 SMZ(1)=-SUPER(31)
47312 SMZ(2)=-SUPER(32)
47313 SMZ(3)=-SUPER(33)
47314 SMZ(4)=-SUPER(34)
47315C...Charginos
47316 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
47317 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
47318C...Signed masses (extra minus from going to G-H convention).
47319 SMW(1)=-SUPER(51)
47320 SMW(2)=-SUPER(52)
47321
47322C... Neutralino Mixing.
47323 DO 160 IN=1,4
47324 ZMIX(IN,1)= SUPER(38+4*(IN-1))
47325 ZMIX(IN,2)= SUPER(37+4*(IN-1))
47326 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
47327 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
47328 160 CONTINUE
47329C...Chargino Mixing (PYTHIA same angle as HERWIG).
47330 THX=1D0
47331 THY=1D0
47332 IF (SUPER(53).GT.0) THX=-1D0
47333 IF (SUPER(54).GT.0) THY=-1D0
47334 UMIX(1,1) = -SIN(SUPER(53))
47335 UMIX(1,2) = -COS(SUPER(53))
47336 UMIX(2,1) = -THX*COS(SUPER(53))
47337 UMIX(2,2) = THX*SIN(SUPER(53))
47338 VMIX(1,1) = -SIN(SUPER(54))
47339 VMIX(1,2) = -COS(SUPER(54))
47340 VMIX(2,1) = -THY*COS(SUPER(54))
47341 VMIX(2,2) = THY*SIN(SUPER(54))
47342C...Sfermion mixing (PYTHIA same angle as ISAJET)
47343 SFMIX(5,1)=COS(SUPER(63))
47344 SFMIX(5,2)=SIN(SUPER(63))
47345 SFMIX(5,3)=-SIN(SUPER(63))
47346 SFMIX(5,4)=COS(SUPER(63))
47347 SFMIX(6,1)=COS(SUPER(61))
47348 SFMIX(6,2)=SIN(SUPER(61))
47349 SFMIX(6,3)=-SIN(SUPER(61))
47350 SFMIX(6,4)=COS(SUPER(61))
47351 SFMIX(15,1)=COS(SUPER(65))
47352 SFMIX(15,2)=SIN(SUPER(65))
47353 SFMIX(15,3)=-SIN(SUPER(65))
47354 SFMIX(15,4)=COS(SUPER(65))
47355
47356 IF (MSTP(122).NE.0) THEN
47357C...Print a few lines to make the user know what's happening
47358 ISAVER=VISAJE()
47359 WRITE(MSTU(11),5000) DOC, ISAVER
47360 WRITE(MSTU(11),5100)
47361 IF (IMODEL.EQ.1) THEN
47362 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
47363 & MTOP
47364 WRITE(MSTU(11),5300)
47365 ENDIF
47366 WRITE(MSTU(11),5500) 'Pole masses'
47367 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
47368 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
47369 & ,(SUPER(IP),IP=19,25,2)
47370 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
47371 & ,IP=1,2)
47372 WRITE(MSTU(11),5400)
47373 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
47374 WRITE(MSTU(11),5400)
47375 WRITE(MSTU(11),5500) 'EW scale mixing structure'
47376 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47377 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47378 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47379 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47380 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47381 & ),(SFMIX(15,J),J=3,4)
47382 WRITE(MSTU(11),5400)
47383 WRITE(MSTU(11),6450) RMSS(18)
47384 WRITE(MSTU(11),5400)
47385 WRITE(MSTU(11),5500) 'Couplings'
47386 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
47387 WRITE(MSTU(11),5400)
47388 ENDIF
47389
47390C...Call FeynHiggs to improve Higgs sector if requested
47391 IF (IMSS(4).EQ.3) THEN
47392 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
47393 & ' (PYSUGI:) Now calling FeynHiggs.'
47394 CALL PYFEYN(IERR)
47395 IF (IERR.EQ.0) THEN
47396 IMSS(4)=2
47397 IF (MSTP(122).NE.0) THEN
47398 WRITE(MSTU(11),5400)
47399 WRITE(MSTU(11),5500)
47400 & 'Corrected Higgs masses and mixing'
47401 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
47402 & PMAS(37,1)
47403 WRITE(MSTU(11),6450) RMSS(18)
47404 WRITE(MSTU(11),5400)
47405 ENDIF
47406 ENDIF
47407 ENDIF
47408
47409 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
47410
47411C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47412C...output by ISASUSY.
47413 IMSS(4)=MAX(2,IMSS(4))
47414
47415 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47416 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
47417 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
47418 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47419 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47420 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47421 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47422 & ,'----------------')
47423 5400 FORMAT(1x,'*',1x,A)
47424 5500 FORMAT(1x,'*',1x,A,':')
47425 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47426 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47427 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47428 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47429 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
47430 & ,1x))
47431 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47432 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47433 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
47434 & .2,1x))
47435 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47436 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47437 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47438 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47439 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
47440 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47441 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
47442 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47443 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47444 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47445 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47446 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47447 & ,1x,F6.3,1x),'|')
47448 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47449 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47450 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47451 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47452 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47453 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47454 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47455 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47456 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47457 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47458 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47459 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47460 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
47461 & ,4x,'Alpha_GUT = ',F8.2)
47462 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
47463 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47464
47465 9999 RETURN
47466 END
47467
47468C*********************************************************************
47469
47470C...PYFEYN
47471C...Interface to FeynHiggs for MSSM Higgs sector.
47472C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47473C...P. Skands
47474
47475 SUBROUTINE PYFEYN(IERR)
47476
47477C...Double precision and integer declarations.
47478 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47479 IMPLICIT INTEGER(I-N)
47480 INTEGER PYK,PYCHGE,PYCOMP
47481C...Commonblocks.
47482 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47483 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47484C...SUSY blocks
47485 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47486C...FeynHiggs variables
47487 DOUBLE PRECISION RMHIGG(4)
47488 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47489 DOUBLE COMPLEX DMU,
47490 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47491 & DM1, DM2, DM3
47492C...SLHA Common Block
47493 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47494 & AU(3,3),AD(3,3),AE(3,3)
47495 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
47496
47497 IERR=0
47498 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
47499 IF (IERR.NE.0) THEN
47500 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47501 & //'Will not use FeynHiggs for this run.')
47502 RETURN
47503 ENDIF
47504 Q=RMSOFT(0)
47505 DMB=PMAS(5,1)
47506 DMT=PMAS(6,1)
47507 DMZ=PMAS(23,1)
47508 DMW=PMAS(24,1)
47509 DMA=PMAS(36,1)
47510 DM1=RMSOFT(1)
47511 DM2=RMSOFT(2)
47512 DM3=RMSOFT(3)
47513 DTANB=RMSS(5)
47514 DMU=RMSS(4)
47515 DM3SL=RMSOFT(33)
47516 DM3SE=RMSOFT(36)
47517 DM3SQ=RMSOFT(43)
47518 DM3SU=RMSOFT(46)
47519 DM3SD=RMSOFT(49)
47520 DM2SL=RMSOFT(32)
47521 DM2SE=RMSOFT(35)
47522 DM2SQ=RMSOFT(42)
47523 DM2SU=RMSOFT(45)
47524 DM2SD=RMSOFT(48)
47525 DM1SL=RMSOFT(31)
47526 DM1SE=RMSOFT(34)
47527 DM1SQ=RMSOFT(41)
47528 DM1SU=RMSOFT(44)
47529 DM1SD=RMSOFT(47)
47530 AE33=AE(3,3)
47531 AE22=AE(2,2)
47532 AE11=AE(1,1)
47533 AU33=AU(3,3)
47534 AU22=AU(2,2)
47535 AU11=AU(1,1)
47536 AD33=AD(3,3)
47537 AD22=AD(2,2)
47538 AD11=AD(1,1)
47539 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
47540 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
47541 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
47542 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
47543 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47544 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
47545 IF (IERR.NE.0) THEN
47546 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
47547 & //' Will not use FeynHiggs for this run.')
47548 RETURN
47549 ENDIF
47550C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47551 SAEFF=0D0
47552 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
47553 IF (IERR.NE.0) THEN
47554 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
47555 & 'GSCORR. Will not use FeynHiggs for this run.')
47556 RETURN
47557 ENDIF
47558 ALPHA = ASIN(DBLE(SAEFF))
47559 R=RMSS(18)/ALPHA
47560 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
47561 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47562 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
47563 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
47564 ENDIF
47565 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
47566 & 1.15D0*PMAS(25,1)) THEN
47567 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47568 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
47569 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
47570 ENDIF
47571 RMSS(18)=ALPHA
47572 PMAS(25,1)=RMHIGG(1)
47573 PMAS(35,1)=RMHIGG(2)
47574 PMAS(36,1)=RMHIGG(3)
47575 PMAS(37,1)=RMHIGG(4)
47576
47577 RETURN
47578 END
47579
47580C*********************************************************************
47581
47582C...PYRNMQ
47583C...Determines the running mass of Squarks.
47584
47585 FUNCTION PYRNMQ(ID,DTERM)
47586
47587C...Double precision and integer declarations.
47588 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47589 IMPLICIT INTEGER(I-N)
47590 INTEGER PYK,PYCHGE,PYCOMP
47591C...Commonblock.
47592 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47593 SAVE /PYMSSM/
47594
47595C...Local variables.
47596 DOUBLE PRECISION PI,R
47597 DOUBLE PRECISION TOL
47598 DOUBLE PRECISION CI(3)
47599 EXTERNAL PYALPS
47600 DOUBLE PRECISION PYALPS
47601 DATA TOL/0.001D0/
47602 DATA PI,R/3.141592654D0,.61803399D0/
47603 DATA CI/0.47D0,0.07D0,0.02D0/
47604
47605 C=1D0-R
47606 CA=CI(ID)
47607 AG=(0.71D0)**2/4D0/PI
47608 AG=RMSS(20)
47609 XM0=RMSS(8)
47610 XMG=RMSS(1)
47611 XM02=XM0*XM0
47612 XMG2=XMG*XMG
47613
47614 AS=PYALPS(XM02+6D0*XMG2)
47615 CG=8D0/9D0*((AS/AG)**2-1D0)
47616 BX=XM02+(CA+CG)*XMG2+DTERM
47617 AX=MIN(50D0**2,0.5D0*BX)
47618 CX=MAX(2000D0**2,2D0*BX)
47619
47620 X0=AX
47621 X3=CX
47622 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47623 X1=BX
47624 X2=BX+C*(CX-BX)
47625 ELSE
47626 X2=BX
47627 X1=BX-C*(BX-AX)
47628 ENDIF
47629 AS1=PYALPS(X1)
47630 CG=8D0/9D0*((AS1/AG)**2-1D0)
47631 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47632 AS2=PYALPS(X2)
47633 CG=8D0/9D0*((AS2/AG)**2-1D0)
47634 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47635 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47636 IF(F2.LT.F1) THEN
47637 X0=X1
47638 X1=X2
47639 X2=R*X1+C*X3
47640 F1=F2
47641 AS2=PYALPS(X2)
47642 CG=8D0/9D0*((AS2/AG)**2-1D0)
47643 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47644 ELSE
47645 X3=X2
47646 X2=X1
47647 X1=R*X2+C*X0
47648 F2=F1
47649 AS1=PYALPS(X1)
47650 CG=8D0/9D0*((AS1/AG)**2-1D0)
47651 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47652 ENDIF
47653 GOTO 100
47654 ENDIF
47655 IF(F1.LT.F2) THEN
47656 PYRNMQ=X1
47657 XMIN=X1
47658 ELSE
47659 PYRNMQ=X2
47660 XMIN=X2
47661 ENDIF
47662
47663 RETURN
47664 END
47665
47666C*********************************************************************
47667
47668C...PYTHRG
47669C...Calculates the mass eigenstates of the third generation sfermions.
47670C...Created: 5-31-96
47671
47672 SUBROUTINE PYTHRG
47673
47674C...Double precision and integer declarations.
47675 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47676 IMPLICIT INTEGER(I-N)
47677 INTEGER PYK,PYCHGE,PYCOMP
47678C...Parameter statement to help give large particle numbers.
47679 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47680 &KEXCIT=4000000,KDIMEN=5000000)
47681C...Commonblocks.
47682 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47683 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47684 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47685 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47686 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47687 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47688
47689C...Local variables.
47690 DOUBLE PRECISION BETA
47691 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47692 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47693 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47694 DOUBLE PRECISION ATR,AMQR,AMQL
47695 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47696 INTEGER IF,I,J,II,JJ,IT,L
47697 LOGICAL DTERM
47698 DATA SMALL/1D-3/
47699 DATA ID1/10,10,13/
47700 DATA ID2/5,6,15/
47701 DATA ID3/15,16,17/
47702 DATA ID4/11,12,14/
47703 DATA DTERM/.TRUE./
47704
47705 XMZ2=PMAS(23,1)**2
47706 XMW2=PMAS(24,1)**2
47707 TANB=RMSS(5)
47708 XMU=-RMSS(4)
47709 BETA=ATAN(TANB)
47710 COS2B=COS(2D0*BETA)
47711
47712C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47713
47714 IOPT=IMSS(5)
47715 IF(IOPT.EQ.1) THEN
47716 CTT=DCOS(RMSS(27))
47717 CTT2=CTT**2
47718 STT=DSIN(RMSS(27))
47719 STT2=STT**2
47720 XM12=RMSS(10)**2
47721 XM22=RMSS(12)**2
47722 XMQL2=CTT2*XM12+STT2*XM22
47723 XMQR2=STT2*XM12+CTT2*XM22
47724 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
47725 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47726 RMSS(16)=ATOP
47727C......SUBTRACT OUT D-TERM AND FERMION MASS
47728 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
47729 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
47730 IF(XMQL2.GE.0D0) THEN
47731 RMSS(10)=SQRT(XMQL2)
47732 ELSE
47733 RMSS(10)=-SQRT(-XMQL2)
47734 ENDIF
47735 IF(XMQR2.GE.0D0) THEN
47736 RMSS(12)=SQRT(XMQR2)
47737 ELSE
47738 RMSS(12)=-SQRT(-XMQR2)
47739 ENDIF
47740
47741C SAME FOR BOTTOM SQUARK
47742 CTT=DCOS(RMSS(26))
47743 CTT2=CTT**2
47744 STT=DSIN(RMSS(26))
47745 STT2=STT**2
47746 XM22=RMSS(11)**2
47747 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
47748 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
47749 IF(ABS(CTT).GE..9999D0) THEN
47750 ABOT=-XMU*TANB
47751 XMQR2=RMSS(11)**2
47752 ELSEIF(ABS(CTT).LE.1D-4) THEN
47753 ABOT=-XMU*TANB
47754 XMQR2=RMSS(11)**2
47755 ELSE
47756 XM12=(XMQL2-STT2*XM22)/CTT2
47757 XMQR2=STT2*XM12+CTT2*XM22
47758 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47759 ENDIF
47760 RMSS(15)=ABOT
47761C......SUBTRACT OUT D-TERM AND FERMION MASS
47762 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
47763 IF(XMQR2.GE.0D0) THEN
47764 RMSS(11)=SQRT(XMQR2)
47765 ELSE
47766 RMSS(11)=-SQRT(-XMQR2)
47767 ENDIF
47768C SAME FOR TAU SLEPTON
47769 CTT=DCOS(RMSS(28))
47770 CTT2=CTT**2
47771 STT=DSIN(RMSS(28))
47772 STT2=STT**2
47773 XM12=RMSS(13)**2
47774 XM22=RMSS(14)**2
47775 XMQL2=CTT2*XM12+STT2*XM22
47776 XMQR2=STT2*XM12+CTT2*XM22
47777 XMFR=PMAS(15,1)
47778 XMF2=XMFR**2
47779 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47780 RMSS(17)=ATAU
47781C......SUBTRACT OUT D-TERM AND FERMION MASS
47782 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
47783 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
47784 IF(XMQL2.GE.0D0) THEN
47785 RMSS(13)=SQRT(XMQL2)
47786 ELSE
47787 RMSS(13)=-SQRT(-XMQL2)
47788 ENDIF
47789 IF(XMQR2.GE.0D0) THEN
47790 RMSS(14)=SQRT(XMQR2)
47791 ELSE
47792 RMSS(14)=-SQRT(-XMQR2)
47793 ENDIF
47794 ENDIF
47795 DO 170 L=1,3
47796 AMQL=RMSS(ID1(L))
47797 IF(AMQL.LT.0D0) THEN
47798 XMQL2=-AMQL**2
47799 ELSE
47800 XMQL2=AMQL**2
47801 ENDIF
47802 ATR=RMSS(ID3(L))
47803 AMQR=RMSS(ID4(L))
47804 IF(AMQR.LT.0D0) THEN
47805 XMQR2=-AMQR**2
47806 ELSE
47807 XMQR2=AMQR**2
47808 ENDIF
47809 IF=ID2(L)
47810 XMF=PYMRUN(IF,PMAS(6,1)**2)
47811 XMF2=XMF**2
47812 AM2(1,1)=XMQL2+XMF2
47813 AM2(2,2)=XMQR2+XMF2
47814 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
47815 IF(DTERM) THEN
47816 IF(L.EQ.1) THEN
47817 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
47818 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
47819 AM2(1,2)=XMF*(ATR+XMU*TANB)
47820 ELSEIF(L.EQ.2) THEN
47821 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
47822 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
47823 AM2(1,2)=XMF*(ATR+XMU/TANB)
47824 ELSEIF(L.EQ.3) THEN
47825 IF(IMSS(8).EQ.1) THEN
47826 AM2(1,1)=RMSS(6)**2
47827 AM2(2,2)=RMSS(7)**2
47828 AM2(1,2)=0D0
47829 RMSS(13)=RMSS(6)
47830 RMSS(14)=RMSS(7)
47831 ELSE
47832 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
47833 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
47834 AM2(1,2)=XMF*(ATR+XMU*TANB)
47835 ENDIF
47836 ENDIF
47837 ENDIF
47838 AM2(2,1)=AM2(1,2)
47839 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
47840 IF(DETM.LT.0D0) THEN
47841 WRITE(MSTU(11),*) ID2(L),DETM,AM2
47842 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47843 ENDIF
47844 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
47845 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
47846 XMF12=SAME-DIFF
47847 XMF22=SAME+DIFF
47848 IT=0
47849 IF(XMF22-XMF12.GT.0D0) THEN
47850 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
47851 RT(2,2) = RT(1,1)
47852 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
47853 & AM2(1,2)/(XMF22-XMF12))
47854 RT(2,1) = -RT(1,2)
47855 ELSE
47856 RT(1,1) = 1D0
47857 RT(2,2) = RT(1,1)
47858 RT(1,2) = 0D0
47859 RT(2,1) = -RT(1,2)
47860 ENDIF
47861 100 CONTINUE
47862 IT=IT+1
47863
47864 DO 140 I=1,2
47865 DO 130 JJ=1,2
47866 DI(I,JJ)=0D0
47867 DO 120 II=1,2
47868 DO 110 J=1,2
47869 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
47870 110 CONTINUE
47871 120 CONTINUE
47872 130 CONTINUE
47873 140 CONTINUE
47874
47875 IF(DI(1,1).GT.DI(2,2)) THEN
47876 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
47877 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
47878 WRITE(MSTU(11),*) AM2
47879 WRITE(MSTU(11),*) DI
47880 WRITE(MSTU(11),*) RT
47881 DI(1,1)=-RT(2,1)
47882 DI(2,2)=RT(1,2)
47883 DI(1,2)=-RT(2,2)
47884 DI(2,1)=RT(1,1)
47885 DO 160 I=1,2
47886 DO 150 J=1,2
47887 RT(I,J)=DI(I,J)
47888 150 CONTINUE
47889 160 CONTINUE
47890 GOTO 100
47891 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
47892 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47893 & ' OFF DIAGONAL ELEMENTS '
47894 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
47895 WRITE(MSTU(11),*) DI
47896 WRITE(MSTU(11),*) ' ROTATION = ',RT
47897C...STOP
47898 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
47899 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47900 & ' NEGATIVE MASSES '
47901 CALL PYSTOP(111)
47902 ENDIF
47903 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
47904 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
47905 SFMIX(IF,1)=RT(1,1)
47906 SFMIX(IF,2)=RT(1,2)
47907 SFMIX(IF,3)=RT(2,1)
47908 SFMIX(IF,4)=RT(2,2)
47909 170 CONTINUE
47910
47911C.....TAU SNEUTRINO MASS...L=3
47912
47913 XARG=AM2(1,1)+XMW2*COS2B
47914 IF(XARG.LT.0D0) THEN
47915 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47916 & ' FROM THE SUM RULE. '
47917 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47918 RETURN
47919 ELSE
47920 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
47921 ENDIF
47922
47923 RETURN
47924 END
47925C*********************************************************************
47926
47927C...PYINOM
47928C...Finds the mass eigenstates and mixing matrices for neutralinos
47929C...and charginos.
47930
47931 SUBROUTINE PYINOM
47932
47933C...Double precision and integer declarations.
47934 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47935 IMPLICIT INTEGER(I-N)
47936 INTEGER PYCOMP
47937C...Parameter statement to help give large particle numbers.
47938 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47939 &KEXCIT=4000000,KDIMEN=5000000)
47940C...Commonblocks.
47941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47942 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47943 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47944 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47945 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47946 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47947
47948C...Local variables.
47949 DOUBLE PRECISION XMW,XMZ,XM(4)
47950 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47951 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47952 DOUBLE PRECISION COSW,SINW
47953 DOUBLE PRECISION XMU
47954 DOUBLE PRECISION TANB,COSB,SINB
47955 DOUBLE PRECISION XM1,XM2,XM3,BETA
47956 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47957 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47958 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47959 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47960 DOUBLE PRECISION PYALPS,PYALEM
47961 DOUBLE PRECISION PYRNM3
47962 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47963 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47964 DATA KFNCHI/1000022,1000023,1000025,1000035/
47965
47966 IOPT=IMSS(2)
47967 IF(IMSS(1).EQ.2) THEN
47968 IOPT=1
47969 ENDIF
47970C...M1, M2, AND M3 ARE INDEPENDENT
47971 IF(IOPT.EQ.0) THEN
47972 XM1=RMSS(1)
47973 XM2=RMSS(2)
47974 XM3=RMSS(3)
47975 ELSEIF(IOPT.GE.1) THEN
47976 Q2=PMAS(23,1)**2
47977 AEM=PYALEM(Q2)
47978 A2=AEM/PARU(102)
47979 A1=AEM/(1D0-PARU(102))
47980 XM1=RMSS(1)
47981 XM2=RMSS(2)
47982 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47983 IF(IOPT.EQ.1) THEN
47984 XM2=XM1*A2/A1*3D0/5D0
47985 RMSS(2)=XM2
47986 ELSEIF(IOPT.EQ.3) THEN
47987 XM1=XM2*5D0/3D0*A1/A2
47988 RMSS(1)=XM1
47989 ENDIF
47990 XM3=PYRNM3(XM2/A2)
47991 RMSS(3)=XM3
47992 IF(XM3.LE.0D0) THEN
47993 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47994 CALL PYSTOP(105)
47995 ENDIF
47996 ENDIF
47997
47998C...GLUINO MASS
47999 IF(IMSS(3).EQ.1) THEN
48000 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48001 ELSE
48002 AQ=0D0
48003 DO 110 I=1,4
48004 DO 100 ILR=1,2
48005 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48006 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48007 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48008 100 CONTINUE
48009 110 CONTINUE
48010
48011 DO 130 I=5,6
48012 DO 120 ILR=1,2
48013 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48014 RM2=PMAS(I,1)**2/XM3**2
48015 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48016 IF(ARG.GE.0D0) THEN
48017 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48018 AX0=ABS(X0)
48019 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48020 AX1=ABS(X1)
48021 IF(X0.EQ.1D0) THEN
48022 AT=-1D0
48023 BT=0.25D0
48024 ELSEIF(X0.EQ.0D0) THEN
48025 AT=0D0
48026 BT=-0.25D0
48027 ELSE
48028 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48029 & 0.5D0*X0**2*LOG(AX0)
48030 BT=(-1D0-2D0*X0)/4D0
48031 ENDIF
48032 IF(X1.EQ.1D0) THEN
48033 AT=-1D0+AT
48034 BT=0.25D0+BT
48035 ELSEIF(X1.EQ.0D0) THEN
48036 AT=0D0+AT
48037 BT=-0.25D0+BT
48038 ELSE
48039 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48040 & X1**2*LOG(AX1)+AT
48041 BT=(-1D0-2D0*X1)/4D0+BT
48042 ENDIF
48043 AQ=AQ+AT+BT
48044 ELSE
48045 X0=0.5D0*(1D0+RM2-RM1)
48046 Y0=-0.5D0*SQRT(-ARG)
48047 AMGX0=SQRT(X0**2+Y0**2)
48048 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48049 ARGX0=ATAN2(-X0,-Y0)
48050 AR1X0=ATAN2(1D0-X0,Y0)
48051 X1=X0
48052 Y1=-Y0
48053 AMGX1=AMGX0
48054 AM1X1=AM1X0
48055 ARGX1=ATAN2(-X1,-Y1)
48056 AR1X1=ATAN2(1D0-X1,Y1)
48057 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48058 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48059 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48060 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48061 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48062 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48063 AQ=AQ+AT+BT
48064 ENDIF
48065 120 CONTINUE
48066 130 CONTINUE
48067 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48068 & /(2D0*PARU(2))*(15D0+AQ))
48069 ENDIF
48070
48071C...NEUTRALINO MASSES
48072 DO 150 I=1,4
48073 DO 140 J=1,4
48074 AI(I,J)=0D0
48075 140 CONTINUE
48076 150 CONTINUE
48077 XMZ=PMAS(23,1)/100D0
48078 XMW=PMAS(24,1)/100D0
48079 XMU=RMSS(4)/100D0
48080 SINW=SQRT(PARU(102))
48081 COSW=SQRT(1D0-PARU(102))
48082 TANB=RMSS(5)
48083 BETA=ATAN(TANB)
48084 COSB=COS(BETA)
48085 SINB=TANB*COSB
48086
48087 XM2=XM2/100D0
48088 XM1=XM1/100D0
48089
48090
48091C... Definitions:
48092C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48093C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48094 AR(1,1) = XM1*COS(RMSS(30))
48095 AI(1,1) = XM1*SIN(RMSS(30))
48096 AR(2,2) = XM2*COS(RMSS(31))
48097 AI(2,2) = XM2*SIN(RMSS(31))
48098 AR(3,3) = 0D0
48099 AR(4,4) = 0D0
48100 AR(1,2) = 0D0
48101 AR(2,1) = 0D0
48102 AR(1,3) = -XMZ*SINW*COSB
48103 AR(3,1) = AR(1,3)
48104 AR(1,4) = XMZ*SINW*SINB
48105 AR(4,1) = AR(1,4)
48106 AR(2,3) = XMZ*COSW*COSB
48107 AR(3,2) = AR(2,3)
48108 AR(2,4) = -XMZ*COSW*SINB
48109 AR(4,2) = AR(2,4)
48110 AR(3,4) = -XMU*COS(RMSS(33))
48111 AI(3,4) = -XMU*SIN(RMSS(33))
48112 AR(4,3) = -XMU*COS(RMSS(33))
48113 AI(4,3) = -XMU*SIN(RMSS(33))
48114C CALL PYEIG4(AR,WR,ZR)
48115 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48116 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48117 & 'PROBLEM WITH PYEICG IN PYINOM ')
48118 DO 160 I=1,4
48119 INDEX(I)=I
48120 XM(I)=ABS(WR(I))
48121 160 CONTINUE
48122 DO 180 I=2,4
48123 K=I
48124 DO 170 J=I-1,1,-1
48125 IF(XM(K).LT.XM(J)) THEN
48126 ITMP=INDEX(J)
48127 XTMP=XM(J)
48128 INDEX(J)=INDEX(K)
48129 XM(J)=XM(K)
48130 INDEX(K)=ITMP
48131 XM(K)=XTMP
48132 K=K-1
48133 ELSE
48134 GOTO 180
48135 ENDIF
48136 170 CONTINUE
48137 180 CONTINUE
48138
48139
48140 DO 210 I=1,4
48141 K=INDEX(I)
48142 SMZ(I)=WR(K)*100D0
48143 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48144 S=0D0
48145 DO 190 J=1,4
48146 S=S+ZR(J,K)**2+ZI(J,K)**2
48147 190 CONTINUE
48148 DO 200 J=1,4
48149 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48150 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48151 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48152 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48153 200 CONTINUE
48154 210 CONTINUE
48155
48156C...CHARGINO MASSES
48157C.....Find eigenvectors of X X^*
48158 DO I=1,4
48159 DO J=1,4
48160 AR(I,J)=0D0
48161 AI(I,J)=0D0
48162 ENDDO
48163 ENDDO
48164 AI(1,1) = 0D0
48165 AI(2,2) = 0D0
48166 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48167 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48168 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48169 &XMU*COS(RMSS(33))*SINB)
48170 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48171 &XMU*SIN(RMSS(33))*SINB)
48172 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48173 &XMU*COS(RMSS(33))*SINB)
48174 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48175 &XMU*SIN(RMSS(33))*SINB)
48176 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48177 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48178 & 'PROBLEM WITH PYEICG IN PYINOM ')
48179 INDEX(1)=1
48180 INDEX(2)=2
48181 IF(WR(2).LT.WR(1)) THEN
48182 INDEX(1)=2
48183 INDEX(2)=1
48184 ENDIF
48185
48186
48187 DO 240 I=1,2
48188 K=INDEX(I)
48189 SMW(I)=SQRT(WR(K))*100D0
48190 S=0D0
48191 DO 220 J=1,2
48192 S=S+ZR(J,K)**2+ZI(J,K)**2
48193 220 CONTINUE
48194 DO 230 J=1,2
48195 UMIX(I,J)=ZR(J,K)/SQRT(S)
48196 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
48197 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
48198 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
48199 230 CONTINUE
48200 240 CONTINUE
48201C...Force chargino mass > neutralino mass
48202 IFRC=0
48203 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
48204 CALL PYERRM(8,'(PYINOM:) '//
48205 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48206 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
48207 IFRC=1
48208 ENDIF
48209 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
48210 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
48211
48212C.....Find eigenvectors of X^* X
48213 DO I=1,4
48214 DO J=1,4
48215 AR(I,J)=0D0
48216 AI(I,J)=0D0
48217 ZR(I,J)=0D0
48218 ZI(I,J)=0D0
48219 ENDDO
48220 ENDDO
48221 AI(1,1) = 0D0
48222 AI(2,2) = 0D0
48223 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
48224 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
48225 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48226 &XMU*COS(RMSS(33))*COSB)
48227 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
48228 &XMU*SIN(RMSS(33))*COSB)
48229 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48230 &XMU*COS(RMSS(33))*COSB)
48231 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
48232 &XMU*SIN(RMSS(33))*COSB)
48233 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48234 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48235 & 'PROBLEM WITH PYEICG IN PYINOM ')
48236 INDEX(1)=1
48237 INDEX(2)=2
48238 IF(WR(2).LT.WR(1)) THEN
48239 INDEX(1)=2
48240 INDEX(2)=1
48241 ENDIF
48242
48243 SIMAG=0D0
48244 DO 270 I=1,2
48245 K=INDEX(I)
48246 S=0D0
48247 DO 250 J=1,2
48248 S=S+ZR(J,K)**2+ZI(J,K)**2
48249 SIMAG=SIMAG+ZI(J,K)**2
48250 250 CONTINUE
48251 DO 260 J=1,2
48252 VMIX(I,J)=ZR(J,K)/SQRT(S)
48253 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
48254 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
48255 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
48256 260 CONTINUE
48257 270 CONTINUE
48258
48259C.....Simplify if no phases
48260 IF(SIMAG.LT.1D-6) THEN
48261 AR(1,1) = XM2*COS(RMSS(31))
48262 AR(2,2) = XMU*COS(RMSS(33))
48263 AR(1,2) = SQRT(2D0)*XMW*SINB
48264 AR(2,1) = SQRT(2D0)*XMW*COSB
48265 IKNT=0
48266 300 CONTINUE
48267 DO I=1,2
48268 DO J=1,2
48269 ZR(I,J)=0D0
48270 ENDDO
48271 ENDDO
48272
48273 DO I=1,2
48274 DO J=1,2
48275 DO K=1,2
48276 DO L=1,2
48277 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
48278 ENDDO
48279 ENDDO
48280 ENDDO
48281 ENDDO
48282 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
48283 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
48284 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
48285 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
48286 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48287 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48288 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
48289 IKNT=IKNT+1
48290 GOTO 300
48291 ENDIF
48292C.....Must deal with phases
48293 ELSE
48294 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
48295 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
48296 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
48297 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
48298
48299 IKNT=0
48300 310 CONTINUE
48301 DO I=1,2
48302 DO J=1,2
48303 CAI(I,J)=CMPLX(0D0,0D0)
48304 ENDDO
48305 ENDDO
48306
48307 DO I=1,2
48308 DO J=1,2
48309 DO K=1,2
48310 DO L=1,2
48311 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
48312 & CMPLX(VMIX(J,L),VMIXI(J,L))
48313 ENDDO
48314 ENDDO
48315 ENDDO
48316 ENDDO
48317
48318 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
48319 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
48320 TEMPR=VMIX(1,1)
48321 TEMPI=VMIXI(1,1)
48322 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48323 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48324 TEMPR=VMIX(1,2)
48325 TEMPI=VMIXI(1,2)
48326 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48327 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48328 TEMPR=VMIX(2,1)
48329 TEMPI=VMIXI(2,1)
48330 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48331 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48332 TEMPR=VMIX(2,2)
48333 TEMPI=VMIXI(2,2)
48334 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48335 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48336 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48337 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48338 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
48339 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
48340 IKNT=IKNT+1
48341 GOTO 310
48342 ENDIF
48343 ENDIF
48344 RETURN
48345 END
48346
48347C*********************************************************************
48348
48349C...PYRNM3
48350C...Calculates the running of M3, the SU(3) gluino mass parameter.
48351
48352 FUNCTION PYRNM3(RGUT)
48353
48354C...Double precision and integer declarations.
48355 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48356 IMPLICIT INTEGER(I-N)
48357 INTEGER PYK,PYCHGE,PYCOMP
48358
48359C...Local variables.
48360 DOUBLE PRECISION R
48361 DOUBLE PRECISION TOL
48362 EXTERNAL PYALPS
48363 DOUBLE PRECISION PYALPS
48364 DATA TOL/0.001D0/
48365 DATA R/0.61803399D0/
48366
48367 C=1D0-R
48368
48369 BX=RGUT*PYALPS(RGUT**2)
48370 AX=MIN(50D0,BX*0.5D0)
48371 CX=MAX(2000D0,2D0*BX)
48372
48373 X0=AX
48374 X3=CX
48375 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48376 X1=BX
48377 X2=BX+C*(CX-BX)
48378 ELSE
48379 X2=BX
48380 X1=BX-C*(BX-AX)
48381 ENDIF
48382 AS1=PYALPS(X1**2)
48383 F1=ABS(X1-RGUT*AS1)
48384 AS2=PYALPS(X2**2)
48385 F2=ABS(X2-RGUT*AS2)
48386 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48387 IF(F2.LT.F1) THEN
48388 X0=X1
48389 X1=X2
48390 X2=R*X1+C*X3
48391 F1=F2
48392 AS2=PYALPS(X2**2)
48393 F2=ABS(X2-RGUT*AS2)
48394 ELSE
48395 X3=X2
48396 X2=X1
48397 X1=R*X2+C*X0
48398 F2=F1
48399 AS1=PYALPS(X1**2)
48400 F1=ABS(X1-RGUT*AS1)
48401 ENDIF
48402 GOTO 100
48403 ENDIF
48404 IF(F1.LT.F2) THEN
48405 PYRNM3=X1
48406 XMIN=X1
48407 ELSE
48408 PYRNM3=X2
48409 XMIN=X2
48410 ENDIF
48411
48412 RETURN
48413 END
48414
48415C*********************************************************************
48416
48417C...PYEIG4
48418C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48419C...Specific application: mixing in neutralino sector.
48420
48421 SUBROUTINE PYEIG4(A,W,Z)
48422
48423C...Double precision and integer declarations.
48424 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48425 IMPLICIT INTEGER(I-N)
48426 INTEGER PYK,PYCHGE,PYCOMP
48427
48428C...Arrays: in call and local.
48429 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
48430
48431C...Coefficients of fourth-degree equation from matrix.
48432C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48433 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
48434 B2=0D0
48435 DO 110 I=1,3
48436 DO 100 J=I+1,4
48437 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
48438 100 CONTINUE
48439 110 CONTINUE
48440 B1=0D0
48441 B0=0D0
48442 DO 120 I=1,4
48443 I1=MOD(I,4)+1
48444 I2=MOD(I+1,4)+1
48445 I3=MOD(I+2,4)+1
48446 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
48447 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
48448 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
48449 B0=B0+(-1D0)**(I+1)*A(1,I)*(
48450 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
48451 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
48452 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
48453 120 CONTINUE
48454
48455C...Coefficients of third-degree equation needed for
48456C...separation into two second-degree equations.
48457C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48458 C2=-B2
48459 C1=B1*B3-4D0*B0
48460 C0=-B1**2-B0*B3**2+4D0*B0*B2
48461 CQ=C1/3D0-C2**2/9D0
48462 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
48463 CQR=CQ**3+CR**2
48464
48465C...Cases with one or three real roots.
48466 IF(CQR.GE.0D0) THEN
48467 S1=(CR+SQRT(CQR))**(1D0/3D0)
48468 S2=(CR-SQRT(CQR))**(1D0/3D0)
48469 U=S1+S2-C2/3D0
48470 ELSE
48471 SABS=SQRT(-CQ)
48472 THE=ACOS(CR/SABS**3)/3D0
48473 SRE=SABS*COS(THE)
48474 U=2D0*SRE-C2/3D0
48475 ENDIF
48476
48477C...Find and solve two second-degree equations.
48478 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
48479 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
48480 Q1=U/2D0+SQRT(U**2/4D0-B0)
48481 Q2=U/2D0-SQRT(U**2/4D0-B0)
48482 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
48483 QSAV=Q1
48484 Q1=Q2
48485 Q2=QSAV
48486 ENDIF
48487 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
48488 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
48489 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
48490 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
48491
48492C...Order eigenvalues in asceding mass.
48493 W(1)=X(1)
48494 DO 150 I1=2,4
48495 DO 130 I2=I1-1,1,-1
48496 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
48497 W(I2+1)=W(I2)
48498 130 CONTINUE
48499 140 W(I2+1)=X(I1)
48500 150 CONTINUE
48501
48502C...Find equation system for eigenvectors.
48503 DO 250 I=1,4
48504 DO 170 J1=1,4
48505 D(J1,J1)=A(J1,J1)-W(I)
48506 DO 160 J2=J1+1,4
48507 D(J1,J2)=A(J1,J2)
48508 D(J2,J1)=A(J2,J1)
48509 160 CONTINUE
48510 170 CONTINUE
48511
48512C...Find largest element in matrix.
48513 DAMAX=0D0
48514 DO 190 J1=1,4
48515 DO 180 J2=1,4
48516 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
48517 JA=J1
48518 JB=J2
48519 DAMAX=ABS(D(J1,J2))
48520 180 CONTINUE
48521 190 CONTINUE
48522
48523C...Subtract others by multiple of row selected above.
48524 DAMAX=0D0
48525 DO 210 J3=JA+1,JA+3
48526 J1=J3-4*((J3-1)/4)
48527 RL=D(J1,JB)/D(JA,JB)
48528 DO 200 J2=1,4
48529 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
48530 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
48531 JC=J1
48532 JD=J2
48533 DAMAX=ABS(D(J1,J2))
48534 200 CONTINUE
48535 210 CONTINUE
48536
48537C...Do one more subtraction of a row.
48538 DAMAX=0D0
48539 DO 230 J3=JC+1,JC+3
48540 J1=J3-4*((J3-1)/4)
48541 IF(J1.EQ.JA) GOTO 230
48542 RL=D(J1,JD)/D(JC,JD)
48543 DO 220 J2=1,4
48544 IF(J2.EQ.JB) GOTO 220
48545 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
48546 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
48547 JE=J1
48548 DAMAX=ABS(D(J1,J2))
48549 220 CONTINUE
48550 230 CONTINUE
48551
48552C...Construct unnormalized eigenvector.
48553 JF1=JD+1-4*(JD/4)
48554 JF2=JD+2-4*((JD+1)/4)
48555 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
48556 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
48557 E(JF1)=-D(JE,JF2)
48558 E(JF2)=D(JE,JF1)
48559 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
48560 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
48561 & D(JA,JB)
48562
48563C...Normalize and fill in final array.
48564 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
48565 SGN=(-1D0)**INT(PYR(0)+0.5D0)
48566 DO 240 J=1,4
48567 Z(I,J)=SGN*E(J)/EA
48568 240 CONTINUE
48569 250 CONTINUE
48570
48571 RETURN
48572 END
48573
48574C*********************************************************************
48575
48576C...PYHGGM
48577C...Determines the Higgs boson mass spectrum using several inputs.
48578
48579 SUBROUTINE PYHGGM(ALPHA)
48580
48581C...Double precision and integer declarations.
48582 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48583 IMPLICIT INTEGER(I-N)
48584 INTEGER PYK,PYCHGE,PYCOMP
48585C...Parameter statement to help give large particle numbers.
48586 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48587 &KEXCIT=4000000,KDIMEN=5000000)
48588C...Commonblocks.
48589 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48590 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48591 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
48592 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48593 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
48594
48595C...Local variables.
48596 DOUBLE PRECISION AT,AB,XMU,TANB
48597 DOUBLE PRECISION ALPHA
48598 INTEGER IHOPT
48599 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48600 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48601 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48602 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48603
48604 IHOPT=IMSS(4)
48605 IF(IHOPT.EQ.2) THEN
48606 ALPHA=RMSS(18)
48607 RETURN
48608 ENDIF
48609 AT=RMSS(16)
48610 AB=RMSS(15)
48611 DMGL=RMSS(3)
48612 XMU=RMSS(4)
48613 TANB=RMSS(5)
48614
48615 DMA=RMSS(19)
48616 DTANB=TANB
48617 DMQ=RMSS(10)
48618 DMUR=RMSS(12)
48619 DMDR=RMSS(11)
48620 DMTOP=PMAS(6,1)
48621 DMC=PMAS(PYCOMP(KSUSY1+37),1)
48622 DAU=AT
48623 DAD=AB
48624 DMU=XMU
48625 RMSS(40)=0D0
48626 RMSS(41)=0D0
48627
48628 IF(IHOPT.EQ.0) THEN
48629 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48630 & DMHCH,DSA,DCA,DTANBA)
48631 ELSEIF(IHOPT.EQ.1) THEN
48632 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48633 & DMHCH,DSA,DCA,DTANBA)
48634 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
48635 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
48636 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
48637 RMSS(40)=DDT
48638 RMSS(41)=DDB
48639 DMH=DMHP
48640 DHM=DHMP
48641 DMA=DAMP
48642 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
48643 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48644 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
48645 & PMAS(PYCOMP(1000006),1),DSTOP2
48646 ENDIF
48647 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
48648 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48649 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
48650 & PMAS(PYCOMP(2000006),1),DSTOP1
48651 ENDIF
48652 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
48653 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48654 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
48655 & PMAS(PYCOMP(1000005),1),DSBOT2
48656 ENDIF
48657 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
48658 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48659 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
48660 & PMAS(PYCOMP(2000005),1),DSBOT1
48661 ENDIF
48662
48663 ELSEIF (IHOPT.EQ.3) THEN
48664c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48665C...Currently only available for SLHA spectrum read-in.
48666 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
48667 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48668 & //' spectrum, change IMSS(1) or IMSS(4) option.')
48669 ENDIF
48670 ALPHA=RMSS(18)
48671 RETURN
48672 ENDIF
48673
48674 ALPHA=ACOS(DCA)
48675
48676 PMAS(25,1)=DMH
48677 PMAS(35,1)=DHM
48678 PMAS(36,1)=DMA
48679 PMAS(37,1)=DMHCH
48680
48681 RETURN
48682 END
48683
48684C*********************************************************************
48685
48686C...PYSUBH
48687C...This routine computes the renormalization group improved
48688C...values of Higgs masses and couplings in the MSSM.
48689
48690C...Program based on the work by M. Carena, J.R. Espinosa,
48691c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48692
48693C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48694C...All masses in GeV units. MA is the CP-odd Higgs mass,
48695C...MTOP is the physical top mass, MQ and MUR are the soft
48696C...supersymmetry breaking mass parameters of left handed
48697C...and right handed stops respectively, AU and AD are the
48698C...stop and sbottom trilinear soft breaking terms,
48699C...respectively, and MU is the supersymmetric
48700C...Higgs mass parameter. We use the conventions from
48701C...the physics report of Haber and Kane: left right
48702C...stop mixing term proportional to (AU - MU/TANB)
48703C...We use as input TANB defined at the scale MTOP
48704
48705C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48706C...where MH and HM are the lightest and heaviest CP-even
48707C...Higgs masses, MHCH is the charged Higgs mass and
48708C...ALPHA is the Higgs mixing angle
48709C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48710
48711C...Range of validity:
48712C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48713C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48714C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48715C...are the sbottom mass eigenvalues, respectively. This
48716C...range automatically excludes the existence of tachyons.
48717C...For the charged Higgs mass computation, the method is
48718C...valid if
48719C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48720C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48721C...where M_SUSY**2 is the average of the squared stop mass
48722C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48723C...masses have been assumed to be of order of the stop ones
48724C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48725
48726 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48727 &XMHCH,SA,CA,TANBA)
48728
48729C...Double precision and integer declarations.
48730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48731 IMPLICIT INTEGER(I-N)
48732 INTEGER PYK,PYCHGE,PYCOMP
48733C...Parameter statement to help give large particle numbers.
48734 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48735 &KEXCIT=4000000,KDIMEN=5000000)
48736C...Commonblocks.
48737 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48738 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48739 COMMON/PYHTRI/HHH(7)
48740 SAVE /PYDAT1/,/PYDAT2/
48741
48742C...Local variables.
48743 DOUBLE PRECISION PYALEM,PYALPS
48744 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48745 DOUBLE PRECISION XMHCH,SA,CA
48746 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48747 DOUBLE PRECISION Q02
48748 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48749 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48750 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48751 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48752 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48753 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48754 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48755 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48756
48757 XMZ = PMAS(23,1)
48758 Q02=XMZ**2
48759 AEM=PYALEM(Q02)
48760 ALP1=AEM/(1D0-PARU(102))
48761 ALP2=AEM/PARU(102)
48762 ALPH3Z=PYALPS(Q02)
48763
48764 ALP1 = 0.0101D0
48765 ALP2 = 0.0337D0
48766 ALPH3Z = 0.12D0
48767
48768 V = 174.1D0
48769 PI = PARU(1)
48770 TANBA = TANB
48771 TANBT = TANB
48772
48773C...MBOTTOM(MTOP) = 3. GEV
48774 XMB = PYMRUN(5,XMTOP**2)
48775 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
48776 &LOG(XMTOP**2/XMZ**2))
48777
48778C...RMTOP= RUNNING TOP QUARK MASS
48779 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
48780 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
48781 T = LOG(XMS**2/XMTOP**2)
48782 SINB = TANB/((1D0 + TANB**2)**0.5D0)
48783 COSB = SINB/TANB
48784C...IF(MA.LE.XMTOP) TANBA = TANBT
48785 IF(XMA.GT.XMTOP)
48786 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
48787 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
48788 &LOG(XMA**2/XMTOP**2))
48789
48790 SINBT = TANBT/SQRT(1D0 + TANBT**2)
48791 COSBT = 1D0/SQRT(1D0 + TANBT**2)
48792C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48793 G1 = SQRT(ALP1*4D0*PI)
48794 G2 = SQRT(ALP2*4D0*PI)
48795 G3 = SQRT(ALP3*4D0*PI)
48796 HU = RMTOP/V/SINBT
48797 HD = XMB/V/COSBT
48798 HU2=HU*HU
48799 HD2=HD*HD
48800 HU4=HU2*HU2
48801 HD4=HD2*HD2
48802 AU2=AU**2
48803 AD2=AD**2
48804 XMS2=XMS**2
48805 XMS3=XMS**3
48806 XMS4=XMS2*XMS2
48807 XMU2=XMU*XMU
48808 PI2=PI*PI
48809
48810 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
48811 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
48812 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
48813 &+ 3D0*(AU + AD)**2/XMS2)/6D0
48814 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
48815 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
48816 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
48817 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
48818 &- 16D0*G3**2) *T/16D0/PI2)
48819 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
48820 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
48821 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
48822 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
48823 &- 16D0*G3**2) *T/16D0/PI2)
48824 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48825 &(HU2 + HD2)*T/16D0/PI2)
48826 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48827 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48828 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48829 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
48830 &- 16D0*G3**2) *T/16D0/PI2)
48831 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48832 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
48833 &- 16D0*G3**2) *T/16D0/PI2)
48834 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
48835 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48836 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48837 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48838 &XMS4)*
48839 &(1+ (6D0*HU2 -2D0* HD2
48840 &- 16D0*G3**2) *T/16D0/PI2)
48841 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48842 &XMS4)*
48843 &(1+ (6D0*HD2 -2D0* HU2/2D0
48844 &- 16D0*G3**2) *T/16D0/PI2)
48845 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
48846 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
48847 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
48848 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
48849 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
48850 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48851 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
48852 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48853 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
48854 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48855 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
48856 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48857 HHH(1)=XLAM1
48858 HHH(2)=XLAM2
48859 HHH(3)=XLAM3
48860 HHH(4)=XLAM4
48861 HHH(5)=XLAM5
48862 HHH(6)=XLAM6
48863 HHH(7)=XLAM7
48864 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
48865 &2D0* XLAM6*SINBT*COSBT
48866 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
48867 &+ XLAM5*COSBT**2)
48868 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
48869 &XLAM6*COSBT**2
48870 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
48871 &2D0* XLAM6* COSBT*SINBT
48872 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48873 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
48874 &((XLAM1* COSBT**2 +2D0*
48875 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
48876 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
48877 &*SINBT**2
48878 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
48879 &+ XLAM4) + XLAM6*COSBT**2
48880 &+ XLAM7* SINBT**2))
48881
48882 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
48883 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
48884 XHM = SQRT(XHM2)
48885 XMH = SQRT(XMH2)
48886 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
48887 XMHCH = SQRT(XMHCH2)
48888
48889 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48890 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48891 &XLAM6* COSBT*SINBT
48892 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48893 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48894 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
48895 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
48896
48897 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
48898 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
48899 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
48900 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
48901 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48902 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48903 &XLAM6* COSBT*SINBT
48904 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48905 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48906 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
48907
48908 SA = -SINALP
48909 CA = -COSALP
48910
48911 100 CONTINUE
48912
48913 RETURN
48914 END
48915
48916C*********************************************************************
48917
48918C...PYPOLE
48919C...This subroutine computes the CP-even higgs and CP-odd pole
48920c...Higgs masses and mixing angles.
48921
48922C...Program based on the work by M. Carena, M. Quiros
48923C...and C.E.M. Wagner, "Effective potential methods and
48924C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48925
48926C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48927C...AT,AB,MU
48928C...where MCHI is the largest chargino mass, MA is the running
48929C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48930C...expectaion values at the scale MTOP, MQ is the third generation
48931C...left handed squark mass parameter, MUR is the third generation
48932C...right handed stop mass parameter, MDR is the third generation
48933C...right handed sbottom mass parameter, MTOP is the pole top quark
48934C...mass; AT,AB are the soft supersymmetry breaking trilinear
48935C...couplings of the stop and sbottoms, respectively, and MU is the
48936C...supersymmetric mass parameter
48937
48938C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48939C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48940C...masses are given, what makes the running of the program
48941c...much faster and it is quite generally a good approximation
48942c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48943C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48944c...and if IHIGGS=3, then h,H,A polarizations are computed
48945
48946C...Output: MH and MHP which are the lightest CP-even Higgs running
48947C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48948C...Higgs running and pole masses, repectively; SA and CA are the
48949C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48950C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48951C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48952C...the value of TANB at the CP-odd Higgs mass scale
48953
48954C...This subroutine makes use of CERN library subroutine
48955C...integration package, which makes the computation of the
48956C...pole Higgs masses somewhat faster. We thank P. Janot for this
48957C...improvement. Those who are not able to call the CERN
48958C...libraries, please use the subroutine SUBHPOLE2.F, which
48959C...although somewhat slower, gives identical results
48960
48961 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48962 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48963
48964C...Double precision and integer declarations.
48965 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48966 IMPLICIT INTEGER(I-N)
48967
48968C...Parameters.
48969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48970 SAVE /PYDAT1/
48971 INTEGER PYK,PYCHGE,PYCOMP
48972
48973C...Local variables.
48974 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48975 &SSBOT2(2),B(2,2),COUPB(2,2),
48976 &HCOUPT(2,2),HCOUPB(2,2),
48977 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48978
48979 DELTA(1,1) = 1D0
48980 DELTA(2,2) = 1D0
48981 DELTA(1,2) = 0D0
48982 DELTA(2,1) = 0D0
48983 V = 174.1D0
48984 XMZ=91.18D0
48985 PI=PARU(1)
48986 RXMT=PYMRUN(6,XMT**2)
48987 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48988 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48989
48990 SINB = TANB/(TANB**2+1D0)**0.5D0
48991 COSB = 1D0/(TANB**2+1D0)**0.5D0
48992 COS2B = SINB**2 - COSB**2
48993 SINBPA = SINB*CA + COSB*SA
48994 COSBPA = COSB*CA - SINB*SA
48995 RMBOT = PYMRUN(5,XMT**2)
48996 XMQ2 = XMQ**2
48997 XMUR2 = XMUR**2
48998 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48999 XMDR2 = XMDR**2
49000 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
49001 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49002 IF(XMST11.LT.0D0) GOTO 500
49003 IF(XMST22.LT.0D0) GOTO 500
49004 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49005 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49006 IF(XMSB11.LT.0D0) GOTO 500
49007 IF(XMSB22.LT.0D0) GOTO 500
49008C WMST11 = RXMT**2 + XMQ2
49009C WMST22 = RXMT**2 + XMUR2
49010 XMST12 = RXMT*(AT - XMU/TANB)
49011 XMSB12 = RMBOT*(AB - XMU*TANB)
49012
49013CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49014C...STOP EIGENVALUES CALCULATION
49015CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49016
49017 STOP12 = 0.5D0*(XMST11+XMST22) +
49018 &0.5D0*((XMST11+XMST22)**2 -
49019 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49020 STOP22 = 0.5D0*(XMST11+XMST22) -
49021 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49022 &XMST12**2))**0.5D0
49023
49024 IF(STOP22.LT.0D0) GOTO 500
49025 SSTOP2(1) = STOP12
49026 SSTOP2(2) = STOP22
49027 STOP1 = STOP12**0.5D0
49028 STOP2 = STOP22**0.5D0
49029C STOP1W = STOP1
49030C STOP2W = STOP2
49031
49032 IF(XMST12.EQ.0D0) XST11 = 1D0
49033 IF(XMST12.EQ.0D0) XST12 = 0D0
49034 IF(XMST12.EQ.0D0) XST21 = 0D0
49035 IF(XMST12.EQ.0D0) XST22 = 1D0
49036
49037 IF(XMST12.EQ.0D0) GOTO 110
49038
49039 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49040 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49041 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49042 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49043
49044 110 T(1,1) = XST11
49045 T(2,2) = XST22
49046 T(1,2) = XST12
49047 T(2,1) = XST21
49048
49049 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49050 &0.5D0*((XMSB11+XMSB22)**2 -
49051 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49052 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49053 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49054 &XMSB12**2))**0.5D0
49055 IF(SBOT22.LT.0D0) GOTO 500
49056 SBOT1 = SBOT12**0.5D0
49057 SBOT2 = SBOT22**0.5D0
49058
49059 SSBOT2(1) = SBOT12
49060 SSBOT2(2) = SBOT22
49061
49062 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49063 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49064 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49065 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49066
49067 IF(XMSB12.EQ.0D0) GOTO 130
49068
49069 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49070 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49071 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49072 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49073
49074 130 B(1,1) = XSB11
49075 B(2,2) = XSB22
49076 B(1,2) = XSB12
49077 B(2,1) = XSB21
49078
49079
49080 SINT = 0.2320D0
49081 SQR = DSQRT(2D0)
49082 VP = 174.1D0*SQR
49083
49084CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49085C...STARTING OF LIGHT HIGGS
49086CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49087
49088 IF(IHIGGS.EQ.0) GOTO 490
49089
49090 DO 150 I = 1,2
49091 DO 140 J = 1,2
49092 COUPT(I,J) =
49093 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49094 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49095 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49096 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49097 & T(1,J)*T(2,I))
49098 140 CONTINUE
49099 150 CONTINUE
49100
49101
49102 DO 170 I = 1,2
49103 DO 160 J = 1,2
49104 COUPB(I,J) =
49105 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49106 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49107 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49108 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49109 & B(1,J)*B(2,I))
49110 160 CONTINUE
49111 170 CONTINUE
49112
49113 PRUN = XMH
49114 EPS = 1D-4*PRUN
49115 ITER = 0
49116 180 ITER = ITER + 1
49117 DO 230 I3 = 1,3
49118
49119 PR(I3)=PRUN+(I3-2)*EPS/2
49120 P2=PR(I3)**2
49121 POLT = 0D0
49122 DO 200 I = 1,2
49123 DO 190 J = 1,2
49124 POLT = POLT + COUPT(I,J)**2*3D0*
49125 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49126 190 CONTINUE
49127 200 CONTINUE
49128
49129 POLB = 0D0
49130 DO 220 I = 1,2
49131 DO 210 J = 1,2
49132 POLB = POLB + COUPB(I,J)**2*3D0*
49133 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49134 210 CONTINUE
49135 220 CONTINUE
49136C RXMT2 = RXMT**2
49137 XMT2=XMT**2
49138
49139 POLTT =
49140 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49141 & CA**2/SINB**2 *
49142 & (-2D0*XMT**2+0.5D0*P2)*
49143 & PYFINT(P2,XMT2,XMT2)
49144
49145 POL = POLT + POLB + POLTT
49146 POLAR(I3) = P2 - XMH**2 - POL
49147 230 CONTINUE
49148 DERIV = (POLAR(3)-POLAR(1))/EPS
49149 DRUN = - POLAR(2)/DERIV
49150 PRUN = PRUN + DRUN
49151 P2 = PRUN**2
49152 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49153 GOTO 180
49154 240 CONTINUE
49155
49156 XMHP = DSQRT(P2)
49157
49158CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49159C...END OF LIGHT HIGGS
49160CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49161
49162 250 IF(IHIGGS.EQ.1) GOTO 490
49163
49164CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49165C... STARTING OF HEAVY HIGGS
49166CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49167
49168 DO 270 I = 1,2
49169 DO 260 J = 1,2
49170 HCOUPT(I,J) =
49171 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49172 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49173 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49174 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49175 & T(1,J)*T(2,I))
49176 260 CONTINUE
49177 270 CONTINUE
49178
49179 DO 290 I = 1,2
49180 DO 280 J = 1,2
49181 HCOUPB(I,J) =
49182 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49183 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49184 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49185 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
49186 & B(1,J)*B(2,I))
49187 HCOUPB(I,J)=0D0
49188 280 CONTINUE
49189 290 CONTINUE
49190
49191 PRUN = HM
49192 EPS = 1D-4*PRUN
49193 ITER = 0
49194 300 ITER = ITER + 1
49195 DO 350 I3 = 1,3
49196 PR(I3)=PRUN+(I3-2)*EPS/2
49197 HP2=PR(I3)**2
49198
49199 HPOLT = 0D0
49200 DO 320 I = 1,2
49201 DO 310 J = 1,2
49202 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
49203 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49204 310 CONTINUE
49205 320 CONTINUE
49206
49207 HPOLB = 0D0
49208 DO 340 I = 1,2
49209 DO 330 J = 1,2
49210 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
49211 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49212 330 CONTINUE
49213 340 CONTINUE
49214
49215C RXMT2 = RXMT**2
49216 XMT2 = XMT**2
49217
49218 HPOLTT =
49219 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49220 & SA**2/SINB**2 *
49221 & (-2D0*XMT**2+0.5D0*HP2)*
49222 & PYFINT(HP2,XMT2,XMT2)
49223
49224 HPOL = HPOLT + HPOLB + HPOLTT
49225 POLAR(I3) =HP2-HM**2-HPOL
49226 350 CONTINUE
49227 DERIV = (POLAR(3)-POLAR(1))/EPS
49228 DRUN = - POLAR(2)/DERIV
49229 PRUN = PRUN + DRUN
49230 HP2 = PRUN**2
49231 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
49232 GOTO 300
49233 360 CONTINUE
49234
49235
49236 370 CONTINUE
49237 HMP = HP2**0.5D0
49238
49239CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49240C... END OF HEAVY HIGGS
49241CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49242
49243 IF(IHIGGS.EQ.2) GOTO 490
49244
49245CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49246C...BEGINNING OF PSEUDOSCALAR HIGGS
49247CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49248
49249 DO 390 I = 1,2
49250 DO 380 J = 1,2
49251 ACOUPT(I,J) =
49252 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
49253 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
49254 380 CONTINUE
49255 390 CONTINUE
49256 DO 410 I = 1,2
49257 DO 400 J = 1,2
49258 ACOUPB(I,J) =
49259 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
49260 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
49261 400 CONTINUE
49262 410 CONTINUE
49263
49264 PRUN = XMA
49265 EPS = 1D-4*PRUN
49266 ITER = 0
49267 420 ITER = ITER + 1
49268 DO 470 I3 = 1,3
49269 PR(I3)=PRUN+(I3-2)*EPS/2
49270 AP2=PR(I3)**2
49271 APOLT = 0D0
49272 DO 440 I = 1,2
49273 DO 430 J = 1,2
49274 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
49275 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49276 430 CONTINUE
49277 440 CONTINUE
49278 APOLB = 0D0
49279 DO 460 I = 1,2
49280 DO 450 J = 1,2
49281 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
49282 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49283 450 CONTINUE
49284 460 CONTINUE
49285C RXMT2 = RXMT**2
49286 XMT2=XMT**2
49287 APOLTT =
49288 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49289 & COSB**2/SINB**2 *
49290 & (-0.5D0*AP2)*
49291 & PYFINT(AP2,XMT2,XMT2)
49292 APOL = APOLT + APOLB + APOLTT
49293 POLAR(I3) = AP2 - XMA**2 -APOL
49294 470 CONTINUE
49295 DERIV = (POLAR(3)-POLAR(1))/EPS
49296 DRUN = - POLAR(2)/DERIV
49297 PRUN = PRUN + DRUN
49298 AP2 = PRUN**2
49299 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
49300 GOTO 420
49301 480 CONTINUE
49302
49303 AMP = DSQRT(AP2)
49304
49305CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49306C...END OF PSEUDOSCALAR HIGGS
49307CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49308
49309 IF(IHIGGS.EQ.3) GOTO 490
49310
49311 490 CONTINUE
49312 RETURN
49313 500 CONTINUE
49314 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
49315 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
49316 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
49317 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
49318 CALL PYSTOP(107)
49319 END
49320
49321C*********************************************************************
49322
49323C...PYRGHM
49324C...Auxiliary to PYPOLE.
49325
49326 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49327 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49328 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
49329 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
49330C...Parameters.
49331 INTEGER MSTU,MSTJ
49332 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49333 SAVE /PYDAT1/
49334
49335 MZ = 91.18D0
49336 PI = PARU(1)
49337 V = 174.1D0
49338 ALPHA1 = 0.0101D0
49339 ALPHA2 = 0.0337D0
49340 ALPHA3Z = 0.12D0
49341 TANBA = TANB
49342 TANBT = TANB
49343C MBOTTOM(MTOP) = 3. GEV
49344 MB = PYMRUN(5,MTOP**2)
49345 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
49346 *LOG(MTOP**2/MZ**2))
49347C RMTOP= RUNNING TOP QUARK MASS
49348 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49349 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
49350 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
49351 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
49352CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49353C
49354C NEW DEFINITION, TGLU.
49355C
49356CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49357 TGLU = LOG(MGLU**2/MTOP**2)
49358 SINB = TANB/DSQRT(1D0 + TANB**2)
49359 COSB = SINB/TANB
49360 IF(MA.GT.MTOP)
49361 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
49362 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
49363 *LOG(MA**2/MTOP**2))
49364 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
49365 SINB = TANBT/SQRT(1D0 + TANBT**2)
49366 COSB = 1D0/DSQRT(1D0 + TANBT**2)
49367 G1 = SQRT(ALPHA1*4D0*PI)
49368 G2 = SQRT(ALPHA2*4D0*PI)
49369 G3 = SQRT(ALPHA3*4D0*PI)
49370 HU = RMTOP/V/SINB
49371 HD = MB/V/COSB
49372 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
49373 *SBOT1,SBOT2,DELTAMT,DELTAMB)
49374 IF(MQ.GT.MUR) TP = TQ - TU
49375 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
49376 IF(MQ.GT.MUR) TDP = TU
49377 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
49378 IF(MQ.GT.MD) TPD = TQ - TD
49379 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
49380 IF(MQ.GT.MD) TDPD = TD
49381 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
49382
49383 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
49384 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
49385 * HD**2*(G1**2/3D0+G2**2)*TPD
49386
49387 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
49388 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
49389 * HU**2*(-G1**2/3D0+G2**2)*TP
49390
49391CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49392C
49393C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49394C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49395C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49396C TWO STOPS.
49397C
49398C
49399CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49400
49401 DLAMBDAP2 = 0D0
49402 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
49403 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
49404 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
49405 ENDIF
49406
49407 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
49408 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49409 ENDIF
49410
49411 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
49412 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49413 ENDIF
49414
49415 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
49416 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
49417 ENDIF
49418
49419 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
49420 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49421 ENDIF
49422
49423 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
49424 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49425 ENDIF
49426 ENDIF
49427 DLAMBDA3 = 0D0
49428 DLAMBDA4 = 0D0
49429 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
49430 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
49431 *(G2**2-G1**2/3D0)*TPD
49432 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
49433 *1D0/16D0/PI**2*G1**2*HU**2*TP
49434 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
49435 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
49436 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
49437 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
49438 *HD**2*TPD
49439 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
49440 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
49441 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
49442 *+ (3D0*HD**2/2D0 + HU**2/2D0
49443 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
49444 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
49445 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
49446 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
49447 *(TP + TDP)/8D0/PI**2)
49448 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
49449 *+ (3D0*HU**2/2D0 + HD**2/2D0
49450 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
49451 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
49452 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
49453 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49454 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
49455 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
49456 LAMBDA4 = (- G2**2/2D0)*(1D0
49457 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
49458 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
49459
49460 LAMBDA5 = 0D0
49461 LAMBDA6 = 0D0
49462 LAMBDA7 = 0D0
49463
49464 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
49465 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
49466
49467 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
49468 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
49469 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
49470 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
49471
49472 M2(2,1) = M2(1,2)
49473CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49474CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49475CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49476
49477 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
49478
49479 IF(MCHI.GT.MSSUSY) GOTO 100
49480 IF(MCHI.LT.MTOP) MCHI=MTOP
49481
49482 TCHAR=LOG(MSSUSY**2/MCHI**2)
49483
49484 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
49485 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
49486 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
49487
49488 DELTAM112=2D0*DELTAL12*V**2*COSB**2
49489 DELTAM222=2D0*DELTAL12*V**2*SINB**2
49490 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
49491
49492 M2(1,1)=M2(1,1)+DELTAM112
49493 M2(2,2)=M2(2,2)+DELTAM222
49494 M2(1,2)=M2(1,2)+DELTAM122
49495 M2(2,1)=M2(2,1)+DELTAM122
49496
49497 100 CONTINUE
49498
49499CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49500CCC END OF CHARGINOS/NEUTRALINOS
49501CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49502
49503 DO 120 I = 1,2
49504 DO 110 J = 1,2
49505 M2P(I,J) = M2(I,J) + VH(I,J)
49506 110 CONTINUE
49507 120 CONTINUE
49508 TRM2P = M2P(1,1) + M2P(2,2)
49509 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
49510 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49511 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49512 HMP = DSQRT(HM2P)
49513 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
49514 MCH=DSQRT(MCH2)
49515 IF(MH2P.LT.0.) GOTO 130
49516 MHP = SQRT(MH2P)
49517 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
49518 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
49519 IF(COS2ALPHA.GE.0.) THEN
49520 ALPHA = ASIN(SIN2ALPHA)/2D0
49521 ELSE
49522 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
49523 ENDIF
49524 SA = SIN(ALPHA)
49525 CA = COS(ALPHA)
49526CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49527C
49528C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49529C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49530C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49531C
49532C
49533CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49534 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
49535 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
49536 130 CONTINUE
49537 RETURN
49538 END
49539
49540C*********************************************************************
49541
49542C...PYGFXX
49543C...Auxiliary to PYRGHM.
49544
49545 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49546 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49547 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
49548 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
49549C...Commonblocks.
49550 INTEGER MSTU,MSTJ,KCHG
49551 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49552 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49553 SAVE /PYDAT1/,/PYDAT2/
49554
49555 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
49556
49557 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
49558 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
49559
49560 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
49561 MQ2 = MQ**2
49562 MUR2 = MUR**2
49563 MD2 = MD**2
49564 TANBA = TANB
49565 SINBA = TANBA/DSQRT(TANBA**2+1D0)
49566 COSBA = SINBA/TANBA
49567
49568 SINB = TANB/DSQRT(TANB**2+1D0)
49569 COSB = SINB/TANB
49570
49571 PI = PARU(1)
49572 MZ = PMAS(23,1)
49573 MW = PMAS(24,1)
49574 SW = 1D0-MW**2/MZ**2
49575 V = 174.1D0
49576
49577 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
49578 G2 = DSQRT(0.0336D0*4D0*PI)
49579 G1 = DSQRT(0.0101D0*4D0*PI)
49580
49581 IF(MQ.GT.MUR) MST = MQ
49582 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
49583
49584 MSUSYT = DSQRT(MST**2 + MTOP**2)
49585
49586 IF(MQ.GT.MD) MSB = MQ
49587 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
49588
49589 MB = PYMRUN(5,MSB**2)
49590 MSUSYB = DSQRT(MSB**2 + MB**2)
49591 TT = LOG(MSUSYT**2/MTOP**2)
49592 TB = LOG(MSUSYB**2/MTOP**2)
49593
49594 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49595 HT = RMTOP/(V*SINB)
49596 HTST = RMTOP/V
49597 HB = MB/V/COSB
49598 G32 = ALPHA3*4D0*PI
49599 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
49600 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
49601 AL2 = 3D0/8D0/PI**2*HT**2
49602C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49603C ALST = 3./8./PI**2*HTST**2
49604 AL1 = 3D0/8D0/PI**2*HB**2
49605
49606 AL(1,1) = AL1
49607 AL(1,2) = (AL2+AL1)/2D0
49608 AL(2,1) = (AL2+AL1)/2D0
49609 AL(2,2) = AL2
49610
49611 IF(MA.GT.MTOP) THEN
49612 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
49613 * LOG(MTOP**2/MA**2))
49614 H1I = VI* COSBA
49615 H2I = VI*SINBA
49616 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
49617 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
49618 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
49619 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
49620 ELSE
49621 VI = V
49622 H1I = VI*COSB
49623 H2I = VI*SINB
49624 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49625 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49626 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49627 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49628 ENDIF
49629
49630 TANBST = H2T/H1T
49631 SINBT = TANBST/DSQRT(1D0+TANBST**2)
49632
49633 TANBSB = H2B/H1B
49634 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
49635 COSBB = SINBB/TANBSB
49636
49637 DELTAMT = 0D0
49638 DELTAMB = 0D0
49639
49640 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49641 MTOP2 = DSQRT(MTOP4)
49642 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49643 * /(1D0+DELTAMB)**4
49644 MBOT2 = DSQRT(MBOT4)
49645
49646 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49647 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49648 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49649 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49650 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49651 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49652 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49653 * MQ2 - MUR2)**2*0.25D0
49654 * + MTOP2*(AT-XMU/TANBST)**2)
49655 IF(STOP22.LT.0.) GOTO 120
49656 SBOT12 = (MQ2 + MD2)*.5D0
49657 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49658 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49659 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49660 SBOT22 = (MQ2 + MD2)*.5D0
49661 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49662 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49663 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49664 IF(SBOT22.LT.0.) SBOT22 = 10000D0
49665
49666 STOP1 = DSQRT(STOP12)
49667 STOP2 = DSQRT(STOP22)
49668 SBOT1 = DSQRT(SBOT12)
49669 SBOT2 = DSQRT(SBOT22)
49670
49671CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49672C
49673C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49674C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49675C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49676C INDUCED CORRECTIONS.
49677C
49678CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49679
49680 X=SBOT1
49681 Y=SBOT2
49682 Z=XMGL
49683 IF(X.EQ.Y) X = X - 0.00001D0
49684 IF(X.EQ.Z) X = X - 0.00002D0
49685 IF(Y.EQ.Z) Y = Y - 0.00003D0
49686
49687 T1=T(X,Y,Z)
49688 X=STOP1
49689 Y=STOP2
49690 Z=XMU
49691 IF(X.EQ.Y) X = X - 0.00001D0
49692 IF(X.EQ.Z) X = X - 0.00002D0
49693 IF(Y.EQ.Z) Y = Y - 0.00003D0
49694 T2=T(X,Y,Z)
49695 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
49696 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
49697 X=STOP1
49698 Y=STOP2
49699 Z=XMGL
49700 IF(X.EQ.Y) X = X - 0.00001D0
49701 IF(X.EQ.Z) X = X - 0.00002D0
49702 IF(Y.EQ.Z) Y = Y - 0.00003D0
49703 T3=T(X,Y,Z)
49704 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
49705
49706CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49707C
49708C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49709C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49710C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49711C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49712C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49713C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49714C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49715C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49716C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49717C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49718C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49719C
49720C
49721CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49722
49723 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49724 MTOP2 = DSQRT(MTOP4)
49725 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49726 * /(1D0+DELTAMB)**4
49727 MBOT2 = DSQRT(MBOT4)
49728
49729 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49730 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49731 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49732 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49733 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49734 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49735 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49736 * MQ2 - MUR2)**2*0.25D0
49737 * + MTOP2*(AT-XMU/TANBST)**2)
49738
49739 IF(STOP22.LT.0.) GOTO 120
49740 SBOT12 = (MQ2 + MD2)*.5D0
49741 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49742 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49743 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49744 SBOT22 = (MQ2 + MD2)*.5D0
49745 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49746 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49747 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49748 IF(SBOT22.LT.0.) GOTO 120
49749
49750
49751 STOP1 = DSQRT(STOP12)
49752 STOP2 = DSQRT(STOP22)
49753 SBOT1 = DSQRT(SBOT12)
49754 SBOT2 = DSQRT(SBOT22)
49755
49756CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49757CCC D-TERMS
49758CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49759 STW=SW
49760
49761 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
49762 * LOG(STOP1/STOP2)
49763 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
49764 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
49765
49766 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
49767 * LOG(SBOT1/SBOT2)
49768 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
49769 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
49770
49771 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
49772 * (-.5D0*LOG(STOP12/STOP22)
49773 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
49774 * G(STOP12,STOP22))
49775
49776 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
49777 * (.5D0*LOG(SBOT12/SBOT22)
49778 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
49779 * G(SBOT12,SBOT22))
49780
49781 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
49782 * (MQ2+MBOT2)/(MD2+MBOT2))
49783 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
49784 * LOG(SBOT1**2/SBOT2**2)) +
49785 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
49786 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
49787
49788 VH3T(1,1) =
49789 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
49790 * -STOP2**2))**2*G(STOP12,STOP22)
49791
49792 VH3B(1,1)=VH3B(1,1)+
49793 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
49794
49795 VH3T(1,1) = VH3T(1,1) +
49796 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
49797
49798 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
49799 * (MQ2+MTOP2)/(MUR2+MTOP2))
49800 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
49801 * LOG(STOP1**2/STOP2**2)) +
49802 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
49803 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
49804
49805 VH3B(2,2) =
49806 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
49807 * -SBOT2**2))**2*G(SBOT12,SBOT22)
49808
49809 VH3T(2,2)=VH3T(2,2)+
49810 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
49811 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
49812 VH3T(1,2) = -
49813 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
49814 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
49815 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
49816
49817 VH3B(1,2) =
49818 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
49819 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
49820 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
49821
49822
49823 VH3T(1,2)=VH3T(1,2) +
49824 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
49825
49826 VH3B(1,2)=VH3B(1,2) +
49827 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
49828
49829 VH3T(2,1) = VH3T(1,2)
49830 VH3B(2,1) = VH3B(1,2)
49831
49832C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49833C TU = LOG((MUR2+MTOP2)/MTOP2)
49834C TQD = LOG((MQ2 + MB**2)/MB**2)
49835C TD = LOG((MD2+MB**2)/MB**2)
49836
49837 DO 110 I = 1,2
49838 DO 100 J = 1,2
49839 VH(I,J) =
49840 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
49841 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
49842 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
49843 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
49844 100 CONTINUE
49845 110 CONTINUE
49846
49847 GOTO 150
49848 120 DO 140 I =1,2
49849 DO 130 J = 1,2
49850 VH(I,J) = -1D15
49851 130 CONTINUE
49852 140 CONTINUE
49853
49854
49855 150 RETURN
49856 END
49857
49858
49859
49860
49861
49862C*********************************************************************
49863
49864C...PYFINT
49865C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49866
49867 FUNCTION PYFINT(A,B,C)
49868
49869C...Double precision and integer declarations.
49870 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49871 IMPLICIT INTEGER(I-N)
49872 INTEGER PYK,PYCHGE,PYCOMP
49873C...Commonblock.
49874 COMMON/PYINTS/XXM(20)
49875 SAVE/PYINTS/
49876
49877C...Local variables.
49878 EXTERNAL PYFISB
49879 DOUBLE PRECISION PYFISB
49880
49881 XXM(1)=A
49882 XXM(2)=B
49883 XXM(3)=C
49884 XLO=0D0
49885 XHI=1D0
49886 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
49887
49888 RETURN
49889 END
49890
49891C*********************************************************************
49892
49893C...PYFISB
49894C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49895
49896 FUNCTION PYFISB(X)
49897
49898C...Double precision and integer declarations.
49899 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49900 IMPLICIT INTEGER(I-N)
49901 INTEGER PYK,PYCHGE,PYCOMP
49902C...Commonblock.
49903 COMMON/PYINTS/XXM(20)
49904 SAVE/PYINTS/
49905
49906 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
49907 &(X*(XXM(2)-XXM(3))+XXM(3)))
49908
49909 RETURN
49910 END
49911
49912C*********************************************************************
49913
49914C...PYSFDC
49915C...Calculates decays of sfermions.
49916
49917 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
49918
49919C...Double precision and integer declarations.
49920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49921 IMPLICIT INTEGER(I-N)
49922 INTEGER PYK,PYCHGE,PYCOMP
49923C...Parameter statement to help give large particle numbers.
49924 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49925 &KEXCIT=4000000,KDIMEN=5000000)
49926C...Commonblocks.
49927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49928 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49929 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49930 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49931 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49932 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49933
49934C...Local variables.
49935 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49936 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49937 INTEGER KFIN,KCIN
49938 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49939 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49940 DOUBLE PRECISION PYLAMF,XL
49941 DOUBLE PRECISION TANW,XW,AEM,C1,AS
49942 DOUBLE PRECISION AL,AR,BL,BR
49943 DOUBLE PRECISION CH1,CH2,CH3,CH4
49944 DOUBLE PRECISION XMBOT,XMTOP
49945 DOUBLE PRECISION XLAM(0:400)
49946 INTEGER IDLAM(400,3)
49947 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49948 DOUBLE PRECISION SR2
49949 DOUBLE PRECISION CBETA,SBETA
49950 DOUBLE PRECISION CW
49951 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49952 DOUBLE PRECISION COSA,SINA,TANB
49953 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49954 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49955 INTEGER IG,KF1,KF2
49956 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49957 DATA IGG/23,25,35,36/
49958 DATA PI/3.141592654D0/
49959 DATA SR2/1.4142136D0/
49960 DATA KFNCHI/1000022,1000023,1000025,1000035/
49961 DATA KFCCHI/1000024,1000037/
49962
49963C...COUNT THE NUMBER OF DECAY MODES
49964 LKNT=0
49965
49966C...NO NU_R DECAYS
49967 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49968 &KFIN.EQ.KSUSY2+16) RETURN
49969
49970 XMW=PMAS(24,1)
49971 XMW2=XMW**2
49972 XMZ=PMAS(23,1)
49973 XW=PARU(102)
49974 TANW = SQRT(XW/(1D0-XW))
49975 CW=SQRT(1D0-XW)
49976
49977 DO 110 I=1,4
49978 DO 100 J=1,4
49979 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49980 100 CONTINUE
49981 110 CONTINUE
49982 DO 130 I=1,2
49983 DO 120 J=1,2
49984 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49985 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49986 120 CONTINUE
49987 130 CONTINUE
49988
49989C...KCIN
49990 KCIN=PYCOMP(KFIN)
49991C...ILR is 1 for left and 2 for right.
49992 ILR=KFIN/KSUSY1
49993C...IFL is matching non-SUSY flavour.
49994 IFL=MOD(KFIN,KSUSY1)
49995C...IDU is weak isospin, 1 for down and 2 for up.
49996 IDU=2-MOD(IFL,2)
49997
49998 XMI=PMAS(KCIN,1)
49999 XMI2=XMI**2
50000 AEM=PYALEM(XMI2)
50001 AS =PYALPS(XMI2)
50002 C1=AEM/XW
50003 XMI3=XMI**3
50004 EI=KCHG(IFL,1)/3D0
50005
50006 XMBOT=PYMRUN(5,XMI2)
50007 XMTOP=PYMRUN(6,XMI2)
50008
50009 TANB=RMSS(5)
50010 BETA=ATAN(TANB)
50011 ALFA=RMSS(18)
50012 CBETA=COS(BETA)
50013 SBETA=TANB*CBETA
50014 SINA=SIN(ALFA)
50015 COSA=COS(ALFA)
50016 XMU=-RMSS(4)
50017 ATRIT=RMSS(16)
50018 ATRIB=RMSS(15)
50019 ATRIL=RMSS(17)
50020
50021C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50022
50023 IF(IMSS(11).EQ.1) THEN
50024 XMP=RMSS(29)
50025 IDG=39+KSUSY1
50026 XMGR=PMAS(PYCOMP(IDG),1)
50027 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50028 IF(IFL.EQ.5) THEN
50029 XMF=XMBOT
50030 ELSEIF(IFL.EQ.6) THEN
50031 XMF=XMTOP
50032 ELSE
50033 XMF=PMAS(IFL,1)
50034 ENDIF
50035 IF(XMI.GT.XMGR+XMF) THEN
50036 LKNT=LKNT+1
50037 IDLAM(LKNT,1)=IDG
50038 IDLAM(LKNT,2)=IFL
50039 IDLAM(LKNT,3)=0
50040 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50041 ENDIF
50042 ENDIF
50043
50044C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50045
50046C...CHARGED DECAYS:
50047 DO 140 IX=1,2
50048C...DI -> U CHI1-,CHI2-
50049 IF(IDU.EQ.1) THEN
50050 XMFP=PMAS(IFL+1,1)
50051 XMF =PMAS(IFL,1)
50052C...UI -> D CHI1+,CHI2+
50053 ELSE
50054 XMFP=PMAS(IFL-1,1)
50055 XMF =PMAS(IFL,1)
50056 ENDIF
50057 XMJ=SMW(IX)
50058 AXMJ=ABS(XMJ)
50059 IF(XMI.GE.AXMJ+XMFP) THEN
50060 XMA2=XMJ**2
50061 XMB2=XMFP**2
50062 IF(IDU.EQ.2) THEN
50063 IF(IFL.EQ.6) THEN
50064 XMFP=XMBOT
50065 XMF =XMTOP
50066 ELSEIF(IFL.LT.6) THEN
50067 XMF=0D0
50068 XMFP=0D0
50069 ENDIF
50070 CBL=VMIXC(IX,1)
50071 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50072 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50073 CAR=0D0
50074 ELSE
50075 IF(IFL.EQ.5) THEN
50076 XMF =XMBOT
50077 XMFP=XMTOP
50078 ELSEIF(IFL.LT.5) THEN
50079 XMF=0D0
50080 XMFP=0D0
50081 ENDIF
50082 CBL=UMIXC(IX,1)
50083 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50084 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50085 CAR=0D0
50086 ENDIF
50087
50088 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50089 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50090 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50091 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50092 CAL=CALP
50093 CBL=CBLP
50094 CAR=CARP
50095 CBR=CBRP
50096
50097C...F1 -> F` CHI
50098 IF(ILR.EQ.1) THEN
50099 CA=CAL
50100 CB=CBL
50101C...F2 -> F` CHI
50102 ELSE
50103 CA=CAR
50104 CB=CBR
50105 ENDIF
50106 LKNT=LKNT+1
50107 XL=PYLAMF(XMI2,XMA2,XMB2)
50108C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50109 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50110 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50111 IDLAM(LKNT,3)=0
50112 IF(IDU.EQ.1) THEN
50113 IDLAM(LKNT,1)=-KFCCHI(IX)
50114 IDLAM(LKNT,2)=IFL+1
50115 ELSE
50116 IDLAM(LKNT,1)=KFCCHI(IX)
50117 IDLAM(LKNT,2)=IFL-1
50118 ENDIF
50119 ENDIF
50120 140 CONTINUE
50121
50122C...NEUTRAL DECAYS
50123 DO 150 IX=1,4
50124C...DI -> D CHI10
50125 XMF=PMAS(IFL,1)
50126 XMJ=SMZ(IX)
50127 AXMJ=ABS(XMJ)
50128 IF(XMI.GE.AXMJ+XMF) THEN
50129 XMA2=XMJ**2
50130 XMB2=XMF**2
50131 IF(IDU.EQ.1) THEN
50132 IF(IFL.EQ.5) THEN
50133 XMF=XMBOT
50134 ELSEIF(IFL.LT.5) THEN
50135 XMF=0D0
50136 ENDIF
50137 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50138 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50139 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50140 CBR=CAL
50141 ELSE
50142 IF(IFL.EQ.6) THEN
50143 XMF=XMTOP
50144 ELSEIF(IFL.LT.5) THEN
50145 XMF=0D0
50146 ENDIF
50147 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50148 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50149 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50150 CBR=CAL
50151 ENDIF
50152
50153 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50154 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50155 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50156 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50157 CAL=CALP
50158 CBL=CBLP
50159 CAR=CARP
50160 CBR=CBRP
50161
50162C...F1 -> F CHI
50163 IF(ILR.EQ.1) THEN
50164 CA=CAL
50165 CB=CBL
50166C...F2 -> F CHI
50167 ELSE
50168 CA=CAR
50169 CB=CBR
50170 ENDIF
50171 LKNT=LKNT+1
50172 XL=PYLAMF(XMI2,XMA2,XMB2)
50173C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50174 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50175 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50176 IDLAM(LKNT,1)=KFNCHI(IX)
50177 IDLAM(LKNT,2)=IFL
50178 IDLAM(LKNT,3)=0
50179 ENDIF
50180 150 CONTINUE
50181
50182C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50183C...IG=23,25,35,36
50184 DO 160 II=1,4
50185 IG=IGG(II)
50186 IF(ILR.EQ.1) GOTO 160
50187 XMB=PMAS(IG,1)
50188 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50189 IF(XMI.LT.XMSF1+XMB) GOTO 160
50190 IF(IG.EQ.23) THEN
50191 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
50192 BR=EI*XW/CW
50193 BLR=0D0
50194 ELSEIF(IG.EQ.25) THEN
50195 IF(IFL.EQ.5) THEN
50196 XMF=XMBOT
50197 ELSEIF(IFL.EQ.6) THEN
50198 XMF=XMTOP
50199 ELSEIF(IFL.LT.5) THEN
50200 XMF=0D0
50201 ELSE
50202 XMF=PMAS(IFL,1)
50203 ENDIF
50204 IF(IDU.EQ.2) THEN
50205 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50206 & XMF**2/XMW*COSA/SBETA
50207 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50208 & XMF**2/XMW*COSA/SBETA
50209 ELSE
50210 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50211 & XMF**2/XMW*(-SINA)/CBETA
50212 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50213 & XMF**2/XMW*(-SINA)/CBETA
50214 ENDIF
50215 IF(IFL.EQ.5) THEN
50216 AT=ATRIB
50217 ELSEIF(IFL.EQ.6) THEN
50218 AT=ATRIT
50219 ELSEIF(IFL.EQ.15) THEN
50220 AT=ATRIL
50221 ELSE
50222 AT=0D0
50223 ENDIF
50224C.........need to complexify
50225 IF(IDU.EQ.2) THEN
50226 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
50227 & AT*COSA)
50228 ELSE
50229 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
50230 & AT*SINA)
50231 ENDIF
50232 BL=GHLL
50233 BR=GHRR
50234 BLR=-GHLR
50235 ELSEIF(IG.EQ.35) THEN
50236 IF(IFL.EQ.5) THEN
50237 XMF=XMBOT
50238 ELSEIF(IFL.EQ.6) THEN
50239 XMF=XMTOP
50240 ELSEIF(IFL.LT.5) THEN
50241 XMF=0D0
50242 ELSE
50243 XMF=PMAS(IFL,1)
50244 ENDIF
50245 IF(IDU.EQ.2) THEN
50246 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50247 & XMF**2/XMW*SINA/SBETA
50248 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50249 & XMF**2/XMW*SINA/SBETA
50250 ELSE
50251 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50252 & XMF**2/XMW*COSA/CBETA
50253 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50254 & XMF**2/XMW*COSA/CBETA
50255 ENDIF
50256 IF(IFL.EQ.5) THEN
50257 AT=ATRIB
50258 ELSEIF(IFL.EQ.6) THEN
50259 AT=ATRIT
50260 ELSEIF(IFL.EQ.15) THEN
50261 AT=ATRIL
50262 ELSE
50263 AT=0D0
50264 ENDIF
50265C.........Need to complexify
50266 IF(IDU.EQ.2) THEN
50267 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
50268 & AT*SINA)
50269 ELSE
50270 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
50271 & AT*COSA)
50272 ENDIF
50273 BL=GHLL
50274 BR=GHRR
50275 BLR=GHLR
50276 ELSEIF(IG.EQ.36) THEN
50277 GHLL=0D0
50278 GHRR=0D0
50279 IF(IFL.EQ.5) THEN
50280 XMF=XMBOT
50281 ELSEIF(IFL.EQ.6) THEN
50282 XMF=XMTOP
50283 ELSEIF(IFL.LT.5) THEN
50284 XMF=0D0
50285 ELSE
50286 XMF=PMAS(IFL,1)
50287 ENDIF
50288 IF(IFL.EQ.5) THEN
50289 AT=ATRIB
50290 ELSEIF(IFL.EQ.6) THEN
50291 AT=ATRIT
50292 ELSEIF(IFL.EQ.15) THEN
50293 AT=ATRIL
50294 ELSE
50295 AT=0D0
50296 ENDIF
50297C.........Need to complexify
50298 IF(IDU.EQ.2) THEN
50299 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
50300 ELSE
50301 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
50302 ENDIF
50303 BL=GHLL
50304 BR=GHRR
50305 BLR=GHLR
50306 ENDIF
50307 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
50308 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
50309 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
50310 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50311 LKNT=LKNT+1
50312 IF(IG.EQ.23) THEN
50313 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50314 ELSE
50315 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
50316 ENDIF
50317 IDLAM(LKNT,3)=0
50318 IDLAM(LKNT,1)=KFIN-KSUSY1
50319 IDLAM(LKNT,2)=IG
50320 160 CONTINUE
50321
50322C...SF -> SF' + W
50323 XMB=PMAS(24,1)
50324 IF(MOD(IFL,2).EQ.0) THEN
50325 KF1=KSUSY1+IFL-1
50326 ELSE
50327 KF1=KSUSY1+IFL+1
50328 ENDIF
50329 KF2=KF1+KSUSY1
50330 XMSF1=PMAS(PYCOMP(KF1),1)
50331 XMSF2=PMAS(PYCOMP(KF2),1)
50332 IF(XMI.GT.XMB+XMSF1) THEN
50333 IF(MOD(IFL,2).EQ.0) THEN
50334 IF(ILR.EQ.1) THEN
50335 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
50336 ELSE
50337 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
50338 ENDIF
50339 ELSE
50340 IF(ILR.EQ.1) THEN
50341 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
50342 ELSE
50343 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
50344 ENDIF
50345 ENDIF
50346 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50347 LKNT=LKNT+1
50348 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50349 IDLAM(LKNT,3)=0
50350 IDLAM(LKNT,1)=KF1
50351 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50352 ENDIF
50353 IF(XMI.GT.XMB+XMSF2) THEN
50354 IF(MOD(IFL,2).EQ.0) THEN
50355 IF(ILR.EQ.1) THEN
50356 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
50357 ELSE
50358 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
50359 ENDIF
50360 ELSE
50361 IF(ILR.EQ.1) THEN
50362 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
50363 ELSE
50364 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
50365 ENDIF
50366 ENDIF
50367 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
50368 LKNT=LKNT+1
50369 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50370 IDLAM(LKNT,3)=0
50371 IDLAM(LKNT,1)=KF2
50372 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50373 ENDIF
50374
50375C...SF -> SF' + HC
50376 XMB=PMAS(37,1)
50377 IF(MOD(IFL,2).EQ.0) THEN
50378 KF1=KSUSY1+IFL-1
50379 ELSE
50380 KF1=KSUSY1+IFL+1
50381 ENDIF
50382 KF2=KF1+KSUSY1
50383 XMSF1=PMAS(PYCOMP(KF1),1)
50384 XMSF2=PMAS(PYCOMP(KF2),1)
50385 IF(XMI.GT.XMB+XMSF1) THEN
50386 XMF=0D0
50387 XMFP=0D0
50388 AT=0D0
50389 AB=0D0
50390 IF(MOD(IFL,2).EQ.0) THEN
50391C...T1-> B1 HC
50392 IF(ILR.EQ.1) THEN
50393 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
50394 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
50395 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
50396 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
50397C...T2-> B1 HC
50398 ELSE
50399 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
50400 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
50401 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
50402 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
50403 ENDIF
50404 IF(IFL.EQ.6) THEN
50405 XMF=XMTOP
50406 XMFP=XMBOT
50407 AT=ATRIT
50408 AB=ATRIB
50409 ENDIF
50410 ELSE
50411C...B1 -> T1 HC
50412 IF(ILR.EQ.1) THEN
50413 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
50414 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
50415 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
50416 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
50417C...B2-> T1 HC
50418 ELSE
50419 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
50420 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
50421 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
50422 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
50423 ENDIF
50424 IF(IFL.EQ.5) THEN
50425 XMF=XMTOP
50426 XMFP=XMBOT
50427 AT=ATRIT
50428 AB=ATRIB
50429 ENDIF
50430 ENDIF
50431 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50432 LKNT=LKNT+1
50433C.......Need to complexify
50434 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50435 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50436 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50437 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50438 IDLAM(LKNT,3)=0
50439 IDLAM(LKNT,1)=KF1
50440 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50441 ENDIF
50442 IF(XMI.GT.XMB+XMSF2) THEN
50443 XMF=0D0
50444 XMFP=0D0
50445 AT=0D0
50446 AB=0D0
50447 IF(MOD(IFL,2).EQ.0) THEN
50448C...T1-> B2 HC
50449 IF(ILR.EQ.1) THEN
50450 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
50451 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
50452 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
50453 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
50454C...T2-> B2 HC
50455 ELSE
50456 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
50457 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
50458 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
50459 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
50460 ENDIF
50461 IF(IFL.EQ.6) THEN
50462 XMF=XMTOP
50463 XMFP=XMBOT
50464 AT=ATRIT
50465 AB=ATRIB
50466 ENDIF
50467 ELSE
50468C...B1 -> T2 HC
50469 IF(ILR.EQ.1) THEN
50470 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
50471 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
50472 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
50473 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
50474C...B2-> T2 HC
50475 ELSE
50476 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
50477 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
50478 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
50479 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
50480 ENDIF
50481 IF(IFL.EQ.5) THEN
50482 XMF=XMTOP
50483 XMFP=XMBOT
50484 AT=ATRIT
50485 AB=ATRIB
50486 ENDIF
50487 ENDIF
50488 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50489 LKNT=LKNT+1
50490C.......Need to complexify
50491 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50492 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50493 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50494 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50495 IDLAM(LKNT,3)=0
50496 IDLAM(LKNT,1)=KF2
50497 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50498 ENDIF
50499
50500C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50501
50502 IF(IFL.LE.6) THEN
50503 XMFP=0D0
50504 XMF=0D0
50505 IF(IFL.EQ.6) XMF=PMAS(6,1)
50506 IF(IFL.EQ.5) XMF=PMAS(5,1)
50507 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50508 AXMJ=ABS(XMJ)
50509 IF(XMI.GE.AXMJ+XMF) THEN
50510 AL=-SFMIX(IFL,3)
50511 BL=SFMIX(IFL,1)
50512 AR=-SFMIX(IFL,4)
50513 BR=SFMIX(IFL,2)
50514C...F1 -> F CHI
50515 IF(ILR.EQ.1) THEN
50516 XCA=AL
50517 XCB=BL
50518C...F2 -> F CHI
50519 ELSE
50520 XCA=AR
50521 XCB=BR
50522 ENDIF
50523 LKNT=LKNT+1
50524 XMA2=XMJ**2
50525 XMB2=XMF**2
50526 XL=PYLAMF(XMI2,XMA2,XMB2)
50527 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50528 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
50529 IDLAM(LKNT,1)=KSUSY1+21
50530 IDLAM(LKNT,2)=IFL
50531 IDLAM(LKNT,3)=0
50532 ENDIF
50533 ENDIF
50534
50535C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50536 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
50537 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
50538C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50539C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50540C...M*M = C1**2 * G**2/(16PI**2)
50541C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50542 LKNT=LKNT+1
50543 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
50544 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
50545 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
50546 IDLAM(LKNT,1)=KSUSY1+22
50547 IDLAM(LKNT,2)=4
50548 IDLAM(LKNT,3)=0
50549 ENDIF
50550
50551C...R-violating sfermion decays (SKANDS).
50552 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
50553
50554 IKNT=LKNT
50555 XLAM(0)=0D0
50556 DO 170 I=1,IKNT
50557 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50558 XLAM(0)=XLAM(0)+XLAM(I)
50559 170 CONTINUE
50560 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
50561
50562 RETURN
50563 END
50564
50565C*********************************************************************
50566
50567C...PYGLUI
50568C...Calculates gluino decay modes.
50569
50570 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
50571
50572C...Double precision and integer declarations.
50573 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50574 IMPLICIT INTEGER(I-N)
50575 INTEGER PYK,PYCHGE,PYCOMP
50576C...Parameter statement to help give large particle numbers.
50577 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50578 &KEXCIT=4000000,KDIMEN=5000000)
50579C...Commonblocks.
50580 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50581 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50582 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50583 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50584 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50585CC &SFMIX(16,4),
50586C COMMON/PYINTS/XXM(20)
50587 COMPLEX*16 CXC
50588 COMMON/PYINTC/XXC(10),CXC(8)
50589 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50590
50591C...Local variables
50592 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50593 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50594 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50595 DOUBLE PRECISION PYLAMF,XL
50596 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50597 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50598 DOUBLE PRECISION XLAM(0:400)
50599 INTEGER IDLAM(400,3)
50600 INTEGER LKNT,IX,ILR,I,IKNT,IFL
50601 DOUBLE PRECISION SR2
50602 DOUBLE PRECISION GAM
50603 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50604 EXTERNAL PYGAUS,PYXXZ6
50605 DOUBLE PRECISION PYGAUS,PYXXZ6
50606 DOUBLE PRECISION PREC
50607 INTEGER KFNCHI(4),KFCCHI(2)
50608 DATA PI/3.141592654D0/
50609 DATA SR2/1.4142136D0/
50610 DATA PREC/1D-2/
50611 DATA KFNCHI/1000022,1000023,1000025,1000035/
50612 DATA KFCCHI/1000024,1000037/
50613
50614C...COUNT THE NUMBER OF DECAY MODES
50615 LKNT=0
50616 IF(KFIN.NE.KSUSY1+21) RETURN
50617 KCIN=PYCOMP(KFIN)
50618
50619 XW=PARU(102)
50620 TANW = SQRT(XW/(1D0-XW))
50621
50622 XMI=PMAS(KCIN,1)
50623 AXMI=ABS(XMI)
50624 XMI2=XMI**2
50625 AEM=PYALEM(XMI2)
50626 AS =PYALPS(XMI2)
50627 C1=AEM/XW
50628 XMI3=AXMI**3
50629
50630 XMI=SIGN(XMI,RMSS(3))
50631
50632C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50633
50634 IF(IMSS(11).EQ.1) THEN
50635 XMP=RMSS(29)
50636 IDG=39+KSUSY1
50637 XMGR=PMAS(PYCOMP(IDG),1)
50638 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50639 IF(AXMI.GT.XMGR) THEN
50640 LKNT=LKNT+1
50641 IDLAM(LKNT,1)=IDG
50642 IDLAM(LKNT,2)=21
50643 IDLAM(LKNT,3)=0
50644 XLAM(LKNT)=XFAC
50645 ENDIF
50646 ENDIF
50647
50648C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50649
50650 DO 110 IFL=1,6
50651 DO 100 ILR=1,2
50652 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
50653 AXMJ=ABS(XMJ)
50654 XMF=PMAS(IFL,1)
50655 IF(AXMI.GE.AXMJ+XMF) THEN
50656C...Minus sign difference from gluino-quark-squark feynman rules
50657 AL=SFMIX(IFL,1)
50658 BL=-SFMIX(IFL,3)
50659 AR=SFMIX(IFL,2)
50660 BR=-SFMIX(IFL,4)
50661C...F1 -> F CHI
50662 IF(ILR.EQ.1) THEN
50663 CA=AL
50664 CB=BL
50665C...F2 -> F CHI
50666 ELSE
50667 CA=AR
50668 CB=BR
50669 ENDIF
50670 LKNT=LKNT+1
50671 XMA2=XMJ**2
50672 XMB2=XMF**2
50673 XL=PYLAMF(XMI2,XMA2,XMB2)
50674 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
50675 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
50676 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
50677 IDLAM(LKNT,2)=-IFL
50678 IDLAM(LKNT,3)=0
50679 LKNT=LKNT+1
50680 XLAM(LKNT)=XLAM(LKNT-1)
50681 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50682 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50683 IDLAM(LKNT,3)=0
50684 ENDIF
50685 100 CONTINUE
50686 110 CONTINUE
50687
50688C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50689C...GLUINO -> NI Q QBAR
50690 DO 170 IX=1,4
50691 XMJ=SMZ(IX)
50692 AXMJ=ABS(XMJ)
50693 IF(AXMI.GE.AXMJ) THEN
50694 DO 120 I=1,4
50695 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
50696 120 CONTINUE
50697 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
50698 ORPP=DCONJG(OLPP)
50699 XXC(1)=0D0
50700 XXC(2)=XMJ
50701 XXC(3)=0D0
50702 XXC(4)=XMI
50703 IA=1
50704 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50705 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50706 XXC(7)=XXC(5)
50707 XXC(8)=XXC(6)
50708 XXC(9)=1D6
50709 XXC(10)=0D0
50710 EI=KCHG(IA,1)/3D0
50711 T3I=SIGN(1D0,EI+1D-6)/2D0
50712 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50713 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50714 CXC(1)=0D0
50715 CXC(2)=-GLIJ
50716 CXC(3)=0D0
50717 CXC(4)=DCONJG(GLIJ)
50718 CXC(5)=0D0
50719 CXC(6)=GRIJ
50720 CXC(7)=0D0
50721 CXC(8)=-DCONJG(GRIJ)
50722 S12MIN=0D0
50723 S12MAX=(AXMI-AXMJ)**2
50724 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
50725 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50726 LKNT=LKNT+1
50727 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50728 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50729 IDLAM(LKNT,1)=KFNCHI(IX)
50730 IDLAM(LKNT,2)=1
50731 IDLAM(LKNT,3)=-1
50732 ENDIF
50733 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50734 LKNT=LKNT+1
50735 XLAM(LKNT)=XLAM(LKNT-1)
50736 IDLAM(LKNT,1)=KFNCHI(IX)
50737 IDLAM(LKNT,2)=3
50738 IDLAM(LKNT,3)=-3
50739 ENDIF
50740 130 CONTINUE
50741 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50742 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
50743 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
50744 GOTO 140
50745 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
50746 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
50747 ENDIF
50748 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
50749 LKNT=LKNT+1
50750 XLAM(LKNT)=GAM
50751 IDLAM(LKNT,1)=KFNCHI(IX)
50752 IDLAM(LKNT,2)=5
50753 IDLAM(LKNT,3)=-5
50754 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
50755 ENDIF
50756C...U-TYPE QUARKS
50757 140 CONTINUE
50758 IA=2
50759 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50760 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50761C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50762 XXC(7)=XXC(5)
50763 XXC(8)=XXC(6)
50764 EI=KCHG(IA,1)/3D0
50765 T3I=SIGN(1D0,EI+1D-6)/2D0
50766 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50767 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50768 CXC(2)=-GLIJ
50769 CXC(4)=DCONJG(GLIJ)
50770 CXC(6)=GRIJ
50771 CXC(8)=-DCONJG(GRIJ)
50772 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
50773 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50774 LKNT=LKNT+1
50775 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50776 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50777 IDLAM(LKNT,1)=KFNCHI(IX)
50778 IDLAM(LKNT,2)=2
50779 IDLAM(LKNT,3)=-2
50780 ENDIF
50781 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50782 LKNT=LKNT+1
50783 XLAM(LKNT)=XLAM(LKNT-1)
50784 IDLAM(LKNT,1)=KFNCHI(IX)
50785 IDLAM(LKNT,2)=4
50786 IDLAM(LKNT,3)=-4
50787 ENDIF
50788 150 CONTINUE
50789C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50790C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50791 XMF=PMAS(6,1)
50792 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
50793 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
50794 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
50795 GOTO 160
50796 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
50797 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
50798 ENDIF
50799 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
50800 LKNT=LKNT+1
50801 XLAM(LKNT)=GAM
50802 IDLAM(LKNT,1)=KFNCHI(IX)
50803 IDLAM(LKNT,2)=6
50804 IDLAM(LKNT,3)=-6
50805 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
50806 ENDIF
50807 160 CONTINUE
50808 ENDIF
50809 170 CONTINUE
50810
50811C...GLUINO -> CI Q QBAR'
50812 DO 210 IX=1,2
50813 XMJ=SMW(IX)
50814 AXMJ=ABS(XMJ)
50815 IF(AXMI.GE.AXMJ) THEN
50816 DO 180 I=1,2
50817 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
50818 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
50819 180 CONTINUE
50820 S12MIN=0D0
50821 S12MAX=(AXMI-AXMJ)**2
50822 XXC(1)=0D0
50823 XXC(2)=XMJ
50824 XXC(3)=0D0
50825 XXC(4)=XMI
50826 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50827 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50828 XXC(9)=1D6
50829 XXC(10)=0D0
50830 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50831 ORPP=DCONJG(OLPP)
50832 CXC(1)=DCMPLX(0D0,0D0)
50833 CXC(3)=DCMPLX(0D0,0D0)
50834 CXC(5)=DCMPLX(0D0,0D0)
50835 CXC(7)=DCMPLX(0D0,0D0)
50836 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50837 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50838 CXC(6)=DCMPLX(0D0,0D0)
50839 CXC(8)=DCMPLX(0D0,0D0)
50840 IF(XXC(5).LT.AXMI) THEN
50841 XXC(5)=1D6
50842 ELSEIF(XXC(6).LT.AXMI) THEN
50843 XXC(6)=1D6
50844 ENDIF
50845 XXC(7)=XXC(6)
50846 XXC(8)=XXC(5)
50847 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
50848 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50849 LKNT=LKNT+1
50850 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50851 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50852 IDLAM(LKNT,1)=KFCCHI(IX)
50853 IDLAM(LKNT,2)=1
50854 IDLAM(LKNT,3)=-2
50855 LKNT=LKNT+1
50856 XLAM(LKNT)=XLAM(LKNT-1)
50857 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50858 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50859 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50860 ENDIF
50861 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50862 LKNT=LKNT+1
50863 XLAM(LKNT)=XLAM(LKNT-1)
50864 IDLAM(LKNT,1)=KFCCHI(IX)
50865 IDLAM(LKNT,2)=3
50866 IDLAM(LKNT,3)=-4
50867 LKNT=LKNT+1
50868 XLAM(LKNT)=XLAM(LKNT-1)
50869 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50870 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50871 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50872 ENDIF
50873 190 CONTINUE
50874
50875 XMF=PMAS(6,1)
50876 XMFP=PMAS(5,1)
50877 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
50878 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
50879 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
50880 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
50881 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
50882 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
50883 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
50884 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
50885 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
50886 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
50887 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
50888 CALL PYTBBC(IX,100,XMI,GAM)
50889 LKNT=LKNT+1
50890 XLAM(LKNT)=GAM
50891 IDLAM(LKNT,1)=KFCCHI(IX)
50892 IDLAM(LKNT,2)=5
50893 IDLAM(LKNT,3)=-6
50894 LKNT=LKNT+1
50895 XLAM(LKNT)=XLAM(LKNT-1)
50896 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50897 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50898 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50899 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
50900 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
50901 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
50902 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
50903 ENDIF
50904 200 CONTINUE
50905 ENDIF
50906 210 CONTINUE
50907
50908C...R-parity violating (3-body) decays.
50909 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
50910
50911 IKNT=LKNT
50912 XLAM(0)=0D0
50913 DO 220 I=1,IKNT
50914 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50915 XLAM(0)=XLAM(0)+XLAM(I)
50916 220 CONTINUE
50917 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50918
50919 RETURN
50920 END
50921
50922
50923C*********************************************************************
50924
50925C...PYTBBN
50926C...Calculates the three-body decay of gluinos into
50927C...neutralinos and third generation fermions.
50928
50929 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
50930
50931C...Double precision and integer declarations.
50932 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50933 IMPLICIT INTEGER(I-N)
50934 INTEGER PYK,PYCHGE,PYCOMP
50935C...Parameter statement to help give large particle numbers.
50936 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50937 &KEXCIT=4000000,KDIMEN=5000000)
50938C...Commonblocks.
50939 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50940 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50941 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50942 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50943 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50944 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50945
50946C...Local variables.
50947 EXTERNAL PYSIMP,PYLAMF
50948 DOUBLE PRECISION PYSIMP,PYLAMF
50949 INTEGER LIN,NN
50950 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50951 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50952 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50953 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50954 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50955 DOUBLE PRECISION XLN1,XLN2,B1,B2
50956 DOUBLE PRECISION E,XMGLU,GAM
50957 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50958 SAVE HRB,HLB,FLB,FRB
50959 DOUBLE PRECISION ALPHAW,ALPHAS
50960 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50961 SAVE HLT,HRT,FLT,FRT
50962 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50963 SAVE AMN,AN,ZN
50964 DOUBLE PRECISION AMBOT,SINC,COSC
50965 DOUBLE PRECISION AMTOP,SINA,COSA
50966 DOUBLE PRECISION SINW,COSW,TANW
50967 DOUBLE PRECISION ROT1(4,4)
50968 LOGICAL IFIRST
50969 SAVE IFIRST
50970 DATA IFIRST/.TRUE./
50971
50972 TANB=RMSS(5)
50973 SINB=TANB/SQRT(1D0+TANB**2)
50974 COSB=SINB/TANB
50975 XW=PARU(102)
50976 SINW=SQRT(XW)
50977 COSW=SQRT(1D0-XW)
50978 TANW=SINW/COSW
50979 AMW=PMAS(24,1)
50980 COSC=SFMIX(5,1)
50981 SINC=SFMIX(5,3)
50982 COSA=SFMIX(6,1)
50983 SINA=SFMIX(6,3)
50984 AMBOT=PYMRUN(5,XMGLU**2)
50985 AMTOP=PYMRUN(6,XMGLU**2)
50986 W2=SQRT(2D0)
50987 FAKT1=AMBOT/W2/AMW/COSB
50988 FAKT2=AMTOP/W2/AMW/SINB
50989 IF(IFIRST) THEN
50990 DO 110 II=1,4
50991 AMN(II)=SMZ(II)
50992 DO 100 J=1,4
50993 ROT1(II,J)=0D0
50994 AN(II,J)=0D0
50995 100 CONTINUE
50996 110 CONTINUE
50997 ROT1(1,1)=COSW
50998 ROT1(1,2)=-SINW
50999 ROT1(2,1)=-ROT1(1,2)
51000 ROT1(2,2)=ROT1(1,1)
51001 ROT1(3,3)=COSB
51002 ROT1(3,4)=SINB
51003 ROT1(4,3)=-ROT1(3,4)
51004 ROT1(4,4)=ROT1(3,3)
51005 DO 140 II=1,4
51006 DO 130 J=1,4
51007 DO 120 JJ=1,4
51008 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51009 120 CONTINUE
51010 130 CONTINUE
51011 140 CONTINUE
51012 DO 150 J=1,4
51013 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51014 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51015 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51016 & XW)*AN(J,2)/COSW
51017 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51018 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51019 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51020 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51021C FLU(J)=ZN(3)
51022C FRU(J)=ZN(2)
51023 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51024 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51025 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51026 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51027 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51028 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51029 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51030C FLD(J)=ZN(3)
51031C FRD(J)=ZN(2)
51032 150 CONTINUE
51033C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51034C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51035C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51036C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51037 IFIRST=.FALSE.
51038 ENDIF
51039
51040 IF(NINT(3D0*E).EQ.2) THEN
51041 HL=HLT(I)
51042 HR=HRT(I)
51043 FL=FLT(I)
51044 FR=FRT(I)
51045 COSD=SFMIX(6,1)
51046 SIND=SFMIX(6,3)
51047 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51048 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51049 XM=PMAS(6,1)
51050 ELSE
51051 HL=HLB(I)
51052 HR=HRB(I)
51053 FL=FLB(I)
51054 FR=FRB(I)
51055 COSD=SFMIX(5,1)
51056 SIND=SFMIX(5,3)
51057 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51058 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51059 XM=PMAS(5,1)
51060 ENDIF
51061 COSD2=COSD*COSD
51062 SIND2=SIND*SIND
51063 COS2D=COSD2-SIND2
51064 SIN2D=SIND*COSD*2D0
51065 HL2=HL*HL
51066 HR2=HR*HR
51067 FL2=FL*FL
51068 FR2=FR*FR
51069 FF=FL*FR
51070 HH=HL*HR
51071 HFL=HL*FL
51072 HFR=HR*FR
51073 HRFL=HR*FL
51074 HLFR=HL*FR
51075 XM2=XM*XM
51076 XMG=XMGLU
51077 XMG2=XMG*XMG
51078 ALPHAW=PYALEM(XMG2)
51079 ALPHAS=PYALPS(XMG2)
51080 XMR=AMN(I)
51081 XMR2=XMR*XMR
51082 XMQ4=XMG*XM2*XMR
51083 XM24=(XMG2+XM2)*(XM2+XMR2)
51084 SMIN=4D0*XM2
51085 SMAX=(XMG-ABS(XMR))**2
51086 XMQA=XMG2+2D0*XM2+XMR2
51087 DO 170 LIN=1,NN-1
51088 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51089 GRS=SBAR-XMQA
51090 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51091 W=DSQRT(W)
51092 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51093 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51094 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51095 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51096 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51097 & +2D0*(FF*SIND2-HH*COSD2))*W
51098 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51099 & +4D0*HFL*XM*XMR)*XLN1
51100 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51101 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51102 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51103 & +8D0*HFL*XMQ4*SIN2D)*B1
51104 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51105 & +4D0*HFR*XMR*XM)*XLN2
51106 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51107 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51108 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51109 & -8D0*HFR*XMQ4*SIN2D)*B2
51110 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51111 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51112 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51113 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51114 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51115 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51116 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51117 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51118 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51119 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51120 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51121 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51122 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51123 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51124 & +COS2D*XM*(SBAR+XMG2-XMR2))
51125 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51126 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51127 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51128 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51129 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51130 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51131 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51132 SUMME(LIN)=0D0
51133 DO 160 J=0,6
51134 SUMME(LIN)=SUMME(LIN)+G(J)
51135 160 CONTINUE
51136 170 CONTINUE
51137 SUMME(0)=0D0
51138 SUMME(NN)=0D0
51139 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51140 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51141
51142 RETURN
51143 END
51144
51145C*********************************************************************
51146
51147C...PYTBBC
51148C...Calculates the three-body decay of gluinos into
51149C...charginos and third generation fermions.
51150
51151 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51152
51153C...Double precision and integer declarations.
51154 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51155 IMPLICIT INTEGER(I-N)
51156 INTEGER PYK,PYCHGE,PYCOMP
51157C...Parameter statement to help give large particle numbers.
51158 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51159 &KEXCIT=4000000,KDIMEN=5000000)
51160C...Commonblocks.
51161 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51162 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51163 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51164 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51165 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51166 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51167
51168C...Local variables.
51169 EXTERNAL PYSIMP,PYLAMF
51170 DOUBLE PRECISION PYSIMP,PYLAMF
51171 INTEGER I,NN,LIN
51172 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51173 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51174 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51175 DOUBLE PRECISION SUMME(0:100),A(4,8)
51176 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51177 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51178 DOUBLE PRECISION XMGLU,GAM
51179 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51180 &DDD(2),EEE(2),FFF(2)
51181 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51182 DOUBLE PRECISION ALPHAW,ALPHAS
51183 DOUBLE PRECISION AMC(2)
51184 SAVE AMC
51185 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51186 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51187 SAVE AMSB,AMST
51188 LOGICAL IFIRST
51189 SAVE IFIRST
51190 DATA IFIRST/.TRUE./
51191
51192 TANB=RMSS(5)
51193 SINB=TANB/SQRT(1D0+TANB**2)
51194 COSB=SINB/TANB
51195 XW=PARU(102)
51196 AMW=PMAS(24,1)
51197 COSC=SFMIX(5,1)
51198 SINC=SFMIX(5,3)
51199 COSA=SFMIX(6,1)
51200 SINA=SFMIX(6,3)
51201 AMBOT=PYMRUN(5,XMGLU**2)
51202 AMTOP=PYMRUN(6,XMGLU**2)
51203 W2=SQRT(2D0)
51204 AMW=PMAS(24,1)
51205 FAKT1=AMBOT/W2/AMW/COSB
51206 FAKT2=AMTOP/W2/AMW/SINB
51207 IF(IFIRST) THEN
51208 AMC(1)=SMW(1)
51209 AMC(2)=SMW(2)
51210 DO 100 JJ=1,2
51211 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
51212 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
51213 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
51214 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
51215 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
51216 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
51217 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
51218 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
51219 100 CONTINUE
51220 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51221 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51222 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51223 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51224 IFIRST=.FALSE.
51225 ENDIF
51226
51227 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
51228 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
51229 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
51230 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
51231
51232 COS2A=COSA**2-SINA**2
51233 SIN2A=SINA*COSA*2D0
51234 COS2C=COSC**2-SINC**2
51235 SIN2C=SINC*COSC*2D0
51236
51237 XMG=XMGLU
51238 XMT=PMAS(6,1)
51239 XMB=PMAS(5,1)
51240 XMR=AMC(I)
51241 XMG2=XMG*XMG
51242 ALPHAW=PYALEM(XMG2)
51243 ALPHAS=PYALPS(XMG2)
51244 XMT2=XMT*XMT
51245 XMB2=XMB*XMB
51246 XMR2=XMR*XMR
51247 XMQ2=XMG2+XMT2+XMB2+XMR2
51248 XMQ4=XMG*XMT*XMB*XMR
51249 XMQ3=XMG2*XMR2+XMT2*XMB2
51250 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
51251 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
51252
51253 XMST(1)=AMST(1)*AMST(1)
51254 XMST(2)=AMST(1)*AMST(1)
51255 XMST(3)=AMST(2)*AMST(2)
51256 XMST(4)=AMST(2)*AMST(2)
51257 XMSB(1)=AMSB(1)*AMSB(1)
51258 XMSB(2)=AMSB(2)*AMSB(2)
51259 XMSB(3)=AMSB(1)*AMSB(1)
51260 XMSB(4)=AMSB(2)*AMSB(2)
51261
51262 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
51263 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
51264 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
51265 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
51266 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
51267 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
51268 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
51269 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
51270
51271 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
51272 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
51273 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
51274 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
51275 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
51276 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
51277 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
51278 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
51279
51280 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
51281 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
51282 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
51283 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
51284 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
51285 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
51286 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
51287 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
51288
51289 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
51290 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
51291 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
51292 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
51293 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
51294 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
51295 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
51296 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
51297
51298 SMAX=(XMG-ABS(XMR))**2
51299 SMIN=(XMB+XMT)**2+0.1D0
51300
51301 DO 120 LIN=0,NN-1
51302 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51303 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
51304 GRS=SBAR-XMQ2
51305 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
51306 W=DSQRT(W)/2D0/SBAR
51307 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
51308 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
51309 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
51310 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
51311 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
51312 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
51313 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
51314 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
51315 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
51316 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
51317 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
51318 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
51319 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
51320 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
51321 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
51322 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
51323 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
51324 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
51325 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
51326 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
51327 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
51328 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
51329 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
51330 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
51331 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
51332 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
51333 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
51334 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
51335 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
51336 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
51337 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
51338 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
51339 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
51340 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
51341 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
51342 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
51343 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
51344 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
51345 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
51346 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
51347 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
51348 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
51349 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
51350 DO 110 J=1,4
51351 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
51352 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
51353 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
51354 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
51355 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
51356 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
51357 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
51358 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
51359 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
51360 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
51361 & -A(J,6)*(XMG2+XMR2-SBAR)
51362 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
51363 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
51364 & /(GRS+XMSB(J)+XMST(J))
51365 110 CONTINUE
51366 120 CONTINUE
51367 SUMME(NN)=0D0
51368 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51369 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51370
51371 RETURN
51372 END
51373
51374C*********************************************************************
51375
51376C...PYNJDC
51377C...Calculates decay widths for the neutralinos (admixtures of
51378C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51379
51380C...Input: KCIN = KF code for particle
51381C...Output: XLAM = widths
51382C... IDLAM = KF codes for decay particles
51383C... IKNT = number of decay channels defined
51384C...AUTHOR: STEPHEN MRENNA
51385C...Last change:
51386C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51387C...when CHIGAMMA .NE. 0
51388C...10 FEB 96: Calculate this decay for small tan(beta)
51389
51390 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
51391
51392C...Double precision and integer declarations.
51393 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51394 IMPLICIT INTEGER(I-N)
51395 INTEGER PYK,PYCHGE,PYCOMP
51396C...Parameter statement to help give large particle numbers.
51397 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51398 &KEXCIT=4000000,KDIMEN=5000000)
51399C...Commonblocks.
51400 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51401 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51402 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51403c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51404c &SFMIX(16,4)
51405 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51406 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51407C COMMON/PYINTS/XXM(20)
51408 COMPLEX*16 CXC
51409 COMMON/PYINTC/XXC(10),CXC(8)
51410 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51411
51412C...Local variables.
51413 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51414 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51415 INTEGER KFIN
51416 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51417 &XMZ,XMZ2,AXMJ,AXMI
51418 DOUBLE PRECISION S12MIN,S12MAX
51419 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51420 DOUBLE PRECISION PYLAMF,XL
51421 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51422 DOUBLE PRECISION PYX2XH,PYX2XG
51423 DOUBLE PRECISION XLAM(0:400)
51424 INTEGER IDLAM(400,3)
51425 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51426 INTEGER ITH(3),KF1,KF2
51427 INTEGER ITHC
51428 DOUBLE PRECISION DH(3),EH(3)
51429 DOUBLE PRECISION SR2
51430 DOUBLE PRECISION CBETA,SBETA
51431 DOUBLE PRECISION GAMCON,XMT1,XMT2
51432 DOUBLE PRECISION PYALEM,PI,PYALPS
51433 DOUBLE PRECISION RAT1,RAT2
51434 DOUBLE PRECISION T3T,FCOL
51435 DOUBLE PRECISION ALFA,BETA,TANB
51436 DOUBLE PRECISION PYXXGA
51437 EXTERNAL PYGAUS,PYXXZ6
51438 DOUBLE PRECISION PYGAUS,PYXXZ6
51439 DOUBLE PRECISION PREC
51440 INTEGER KFNCHI(4),KFCCHI(2)
51441 DATA ITH/25,35,36/
51442 DATA ITHC/37/
51443 DATA PREC/1D-2/
51444 DATA PI/3.141592654D0/
51445 DATA SR2/1.4142136D0/
51446 DATA KFNCHI/1000022,1000023,1000025,1000035/
51447 DATA KFCCHI/1000024,1000037/
51448
51449C...COUNT THE NUMBER OF DECAY MODES
51450 LKNT=0
51451
51452 XMW=PMAS(24,1)
51453 XMW2=XMW**2
51454 XMZ=PMAS(23,1)
51455 XMZ2=XMZ**2
51456 XW=1D0-XMW2/XMZ2
51457 XW1=1D0-XW
51458 TANW = SQRT(XW/XW1)
51459
51460C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51461 IX=1
51462 IF(KFIN.EQ.KFNCHI(2)) IX=2
51463 IF(KFIN.EQ.KFNCHI(3)) IX=3
51464 IF(KFIN.EQ.KFNCHI(4)) IX=4
51465
51466 XMI=SMZ(IX)
51467 XMI2=XMI**2
51468 AXMI=ABS(XMI)
51469 AEM=PYALEM(XMI2)
51470 AS =PYALPS(XMI2)
51471 C1=AEM/XW
51472 XMI3=ABS(XMI**3)
51473
51474 TANB=RMSS(5)
51475 BETA=ATAN(TANB)
51476 ALFA=RMSS(18)
51477 CBETA=COS(BETA)
51478 SBETA=TANB*CBETA
51479 CALFA=COS(ALFA)
51480 SALFA=SIN(ALFA)
51481
51482 DO 110 I=1,4
51483 DO 100 J=1,4
51484 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51485 100 CONTINUE
51486 110 CONTINUE
51487 DO 130 I=1,2
51488 DO 120 J=1,2
51489 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51490 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51491 120 CONTINUE
51492 130 CONTINUE
51493
51494C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51495 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
51496
51497C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51498 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
51499 XMJ=SMZ(1)
51500 AXMJ=ABS(XMJ)
51501 LKNT=LKNT+1
51502 GAMCON=AEM**3/8D0/PI/XMW2/XW
51503 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51504 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51505 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51506 IDLAM(LKNT,1)=KSUSY1+22
51507 IDLAM(LKNT,2)=22
51508 IDLAM(LKNT,3)=0
51509 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
51510 GOTO 340
51511 ENDIF
51512
51513C...GRAVITINO DECAY MODES
51514
51515 IF(IMSS(11).EQ.1) THEN
51516 XMP=RMSS(29)
51517 IDG=39+KSUSY1
51518 XMGR=PMAS(PYCOMP(IDG),1)
51519 SINW=SQRT(XW)
51520 COSW=SQRT(1D0-XW)
51521 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51522 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
51523 LKNT=LKNT+1
51524 IDLAM(LKNT,1)=IDG
51525 IDLAM(LKNT,2)=22
51526 IDLAM(LKNT,3)=0
51527 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
51528 ENDIF
51529 IF(AXMI.GT.XMGR+XMZ) THEN
51530 LKNT=LKNT+1
51531 IDLAM(LKNT,1)=IDG
51532 IDLAM(LKNT,2)=23
51533 IDLAM(LKNT,3)=0
51534 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
51535 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
51536 & (1D0-XMZ2/XMI2)**4
51537 ENDIF
51538 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
51539 LKNT=LKNT+1
51540 IDLAM(LKNT,1)=IDG
51541 IDLAM(LKNT,2)=25
51542 IDLAM(LKNT,3)=0
51543 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
51544 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
51545 ENDIF
51546 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
51547 LKNT=LKNT+1
51548 IDLAM(LKNT,1)=IDG
51549 IDLAM(LKNT,2)=35
51550 IDLAM(LKNT,3)=0
51551 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
51552 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
51553 ENDIF
51554 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
51555 LKNT=LKNT+1
51556 IDLAM(LKNT,1)=IDG
51557 IDLAM(LKNT,2)=36
51558 IDLAM(LKNT,3)=0
51559 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
51560 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
51561 ENDIF
51562 IF(IX.EQ.1) GOTO 300
51563 ENDIF
51564
51565 DO 220 IJ=1,IX-1
51566 XMJ=SMZ(IJ)
51567 AXMJ=ABS(XMJ)
51568 XMJ2=XMJ**2
51569
51570C...CHI0_I -> CHI0_J + GAMMA
51571 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
51572 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
51573 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
51574 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
51575 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
51576 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
51577 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
51578 LKNT=LKNT+1
51579 IDLAM(LKNT,1)=KFNCHI(IJ)
51580 IDLAM(LKNT,2)=22
51581 IDLAM(LKNT,3)=0
51582 GAMCON=AEM**3/8D0/PI/XMW2/XW
51583 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51584 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51585 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51586 ENDIF
51587 ENDIF
51588
51589C...CHI0_I -> CHI0_J + Z0
51590 IF(AXMI.GE.AXMJ+XMZ) THEN
51591 LKNT=LKNT+1
51592 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51593 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51594 ORPP=-DCONJG(OLPP)
51595 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51596 GLR=DBLE(OLPP*DCONJG(ORPP))
51597 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51598 IDLAM(LKNT,1)=KFNCHI(IJ)
51599 IDLAM(LKNT,2)=23
51600 IDLAM(LKNT,3)=0
51601 ELSEIF(AXMI.GE.AXMJ) THEN
51602 XXC(1)=0D0
51603 XXC(2)=XMJ
51604 XXC(3)=0D0
51605 XXC(4)=XMI
51606 XXC(9)=XMZ
51607 XXC(10)=PMAS(23,2)
51608 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51609 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51610 ORPP=DCONJG(OLPP)
51611C...CHARGED LEPTONS
51612 FID=11
51613 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51614 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51615 EI=KCHG(FID,1)/3D0
51616 T3I=SIGN(1D0,EI+1D-6)/2D0
51617 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51618 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51619 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51620 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51621 CXC(2)=-GLIJ
51622 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51623 CXC(4)=DCONJG(GLIJ)
51624 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51625 CXC(6)=GRIJ
51626 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51627 CXC(8)=-DCONJG(GRIJ)
51628 S12MIN=0D0
51629 S12MAX=(AXMI-AXMJ)**2
51630 IF( XXC(5).LT.AXMI ) THEN
51631 XXC(5)=1D6
51632 ENDIF
51633 IF(XXC(6).LT.AXMI ) THEN
51634 XXC(6)=1D6
51635 ENDIF
51636 XXC(7)=XXC(5)
51637 XXC(8)=XXC(6)
51638
51639 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51640 LKNT=LKNT+1
51641 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51642 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51643 IDLAM(LKNT,1)=KFNCHI(IJ)
51644 IDLAM(LKNT,2)=FID
51645 IDLAM(LKNT,3)=-FID
51646 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51647 LKNT=LKNT+1
51648 XLAM(LKNT)=XLAM(LKNT-1)
51649 IDLAM(LKNT,1)=KFNCHI(IJ)
51650 IDLAM(LKNT,2)=13
51651 IDLAM(LKNT,3)=-13
51652 ENDIF
51653 ENDIF
51654 140 CONTINUE
51655 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51656 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51657 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51658 ELSE
51659 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51660 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51661 ENDIF
51662 IF( XXC(5).LT.AXMI ) THEN
51663 XXC(5)=1D6
51664 ENDIF
51665 IF(XXC(6).LT.AXMI ) THEN
51666 XXC(6)=1D6
51667 ENDIF
51668 XXC(7)=XXC(5)
51669 XXC(8)=XXC(6)
51670
51671 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51672 LKNT=LKNT+1
51673 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51674 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51675 IDLAM(LKNT,1)=KFNCHI(IJ)
51676 IDLAM(LKNT,2)=15
51677 IDLAM(LKNT,3)=-15
51678 ENDIF
51679
51680C...NEUTRINOS
51681 150 CONTINUE
51682 FID=12
51683 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51684 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51685 EI=KCHG(FID,1)/3D0
51686 T3I=SIGN(1D0,EI+1D-6)/2D0
51687 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51688 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51689 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51690 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51691 CXC(2)=-GLIJ
51692 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51693 CXC(4)=DCONJG(GLIJ)
51694 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51695 CXC(6)=GRIJ
51696 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51697 CXC(8)=-DCONJG(GRIJ)
51698 S12MIN=0D0
51699 S12MAX=(AXMI-AXMJ)**2
51700 IF( XXC(5).LT.AXMI ) THEN
51701 XXC(5)=1D6
51702 ENDIF
51703 IF( XXC(6).LT.AXMI ) THEN
51704 XXC(6)=1D6
51705 ENDIF
51706 XXC(7)=XXC(5)
51707 XXC(8)=XXC(6)
51708
51709 LKNT=LKNT+1
51710 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51711 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51712 IDLAM(LKNT,1)=KFNCHI(IJ)
51713 IDLAM(LKNT,2)=12
51714 IDLAM(LKNT,3)=-12
51715 LKNT=LKNT+1
51716 XLAM(LKNT)=XLAM(LKNT-1)
51717 IDLAM(LKNT,1)=KFNCHI(IJ)
51718 IDLAM(LKNT,2)=14
51719 IDLAM(LKNT,3)=-14
51720 160 CONTINUE
51721
51722 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
51723 & THEN
51724 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51725 IF( XXC(5).LT.AXMI ) THEN
51726 XXC(5)=1D6
51727 ENDIF
51728 XXC(7)=XXC(5)
51729 LKNT=LKNT+1
51730 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51731 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51732 ELSE
51733 LKNT=LKNT+1
51734 XLAM(LKNT)=XLAM(LKNT-1)
51735 ENDIF
51736 IDLAM(LKNT,1)=KFNCHI(IJ)
51737 IDLAM(LKNT,2)=16
51738 IDLAM(LKNT,3)=-16
51739C...D-TYPE QUARKS
51740 170 CONTINUE
51741 FID=1
51742 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51743 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51744 EI=KCHG(FID,1)/3D0
51745 T3I=SIGN(1D0,EI+1D-6)/2D0
51746 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51747 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51748 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51749 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51750 CXC(2)=-GLIJ
51751 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51752 CXC(4)=DCONJG(GLIJ)
51753 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51754 CXC(6)=GRIJ
51755 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51756 CXC(8)=-DCONJG(GRIJ)
51757 S12MIN=0D0
51758 S12MAX=(AXMI-AXMJ)**2
51759 IF( XXC(5).LT.AXMI ) THEN
51760 XXC(5)=1D6
51761 ENDIF
51762 IF( XXC(6).LT.AXMI ) THEN
51763 XXC(6)=1D6
51764 ENDIF
51765 XXC(7)=XXC(5)
51766 XXC(8)=XXC(6)
51767
51768 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51769 LKNT=LKNT+1
51770 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51771 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51772 IDLAM(LKNT,1)=KFNCHI(IJ)
51773 IDLAM(LKNT,2)=1
51774 IDLAM(LKNT,3)=-1
51775 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51776 LKNT=LKNT+1
51777 XLAM(LKNT)=XLAM(LKNT-1)
51778 IDLAM(LKNT,1)=KFNCHI(IJ)
51779 IDLAM(LKNT,2)=3
51780 IDLAM(LKNT,3)=-3
51781 ENDIF
51782 ENDIF
51783 180 CONTINUE
51784 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51785 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51786 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51787 ELSE
51788 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51789 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51790 ENDIF
51791 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51792 IF(XXC(5).LT.AXMI) THEN
51793 XXC(5)=1D6
51794 ELSEIF(XXC(6).LT.AXMI) THEN
51795 XXC(6)=1D6
51796 ENDIF
51797 XXC(7)=XXC(5)
51798 XXC(8)=XXC(6)
51799 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51800 LKNT=LKNT+1
51801 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51802 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51803 IDLAM(LKNT,1)=KFNCHI(IJ)
51804 IDLAM(LKNT,2)=5
51805 IDLAM(LKNT,3)=-5
51806 ENDIF
51807
51808C...U-TYPE QUARKS
51809 190 CONTINUE
51810 FID=2
51811 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51812 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51813 EI=KCHG(FID,1)/3D0
51814 T3I=SIGN(1D0,EI+1D-6)/2D0
51815 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51816 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51817 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51818 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51819 CXC(2)=-GLIJ
51820 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51821 CXC(4)=DCONJG(GLIJ)
51822 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51823 CXC(6)=GRIJ
51824 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51825 CXC(8)=-DCONJG(GRIJ)
51826
51827 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
51828 IF(XXC(5).LT.AXMI) THEN
51829 XXC(5)=1D6
51830 ELSEIF(XXC(6).LT.AXMI) THEN
51831 XXC(6)=1D6
51832 ENDIF
51833 XXC(7)=XXC(5)
51834 XXC(8)=XXC(6)
51835
51836 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51837 LKNT=LKNT+1
51838 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51839 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51840 IDLAM(LKNT,1)=KFNCHI(IJ)
51841 IDLAM(LKNT,2)=2
51842 IDLAM(LKNT,3)=-2
51843 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51844 LKNT=LKNT+1
51845 XLAM(LKNT)=XLAM(LKNT-1)
51846 IDLAM(LKNT,1)=KFNCHI(IJ)
51847 IDLAM(LKNT,2)=4
51848 IDLAM(LKNT,3)=-4
51849 ENDIF
51850 ENDIF
51851 200 CONTINUE
51852 ENDIF
51853
51854C...CHI0_I -> CHI0_J + H0_K
51855 EH(1)=SIN(ALFA)
51856 EH(2)=COS(ALFA)
51857 EH(3)=-SIN(BETA)
51858 DH(1)=COS(ALFA)
51859 DH(2)=-SIN(ALFA)
51860 DH(3)=COS(BETA)
51861 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
51862 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
51863 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
51864 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
51865 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
51866 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
51867 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
51868 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
51869 DO 210 IH=1,3
51870 XMH=PMAS(ITH(IH),1)
51871 XMH2=XMH**2
51872 IF(AXMI.GE.AXMJ+XMH) THEN
51873 LKNT=LKNT+1
51874 XL=PYLAMF(XMI2,XMJ2,XMH2)
51875 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
51876 F12K=F21K
51877C...SIGN OF MASSES I,J
51878 XMK=XMJ
51879 IF(IH.EQ.3) XMK=-XMK
51880 GX2=ABS(F21K)**2+ABS(F12K)**2
51881 GLR=DBLE(F21K*DCONJG(F12K))
51882 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51883 IDLAM(LKNT,1)=KFNCHI(IJ)
51884 IDLAM(LKNT,2)=ITH(IH)
51885 IDLAM(LKNT,3)=0
51886 ENDIF
51887 210 CONTINUE
51888 220 CONTINUE
51889
51890C...CHI0_I -> CHI+_J + W-
51891 DO 260 IJ=1,2
51892 XMJ=SMW(IJ)
51893 AXMJ=ABS(XMJ)
51894 XMJ2=XMJ**2
51895 IF(AXMI.GE.AXMJ+XMW) THEN
51896 LKNT=LKNT+1
51897 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51898 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
51899 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51900 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
51901 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51902 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51903 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51904 IDLAM(LKNT,1)=KFCCHI(IJ)
51905 IDLAM(LKNT,2)=-24
51906 IDLAM(LKNT,3)=0
51907 LKNT=LKNT+1
51908 XLAM(LKNT)=XLAM(LKNT-1)
51909 IDLAM(LKNT,1)=-KFCCHI(IJ)
51910 IDLAM(LKNT,2)=24
51911 IDLAM(LKNT,3)=0
51912 ELSEIF(AXMI.GE.AXMJ) THEN
51913 S12MIN=0D0
51914 S12MAX=(AXMI-AXMJ)**2
51915 RT2I = 1D0/SQRT(2D0)
51916 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51917 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
51918 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51919 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
51920 CXC(5)=DCMPLX(0D0,0D0)
51921 CXC(7)=DCMPLX(0D0,0D0)
51922 IA=11
51923 JA=12
51924 EI=KCHG(IA,1)/3D0
51925 T3I=SIGN(1D0,EI+1D-6)/2D0
51926 EJ=KCHG(JA,1)/3D0
51927 T3J=SIGN(1D0,EJ+1D-6)/2D0
51928 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51929 & TANW+ZMIXC(IX,2)*T3J)*RT2I
51930 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51931 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
51932 CXC(6)=DCMPLX(0D0,0D0)
51933 CXC(8)=DCMPLX(0D0,0D0)
51934 XXC(1)=0D0
51935 XXC(2)=XMJ
51936 XXC(3)=0D0
51937 XXC(4)=XMI
51938 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51939 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51940 XXC(9)=PMAS(24,1)
51941 XXC(10)=PMAS(24,2)
51942 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
51943 IF(XXC(5).LT.AXMI) THEN
51944 XXC(5)=1D6
51945 ELSEIF(XXC(6).LT.AXMI) THEN
51946 XXC(6)=1D6
51947 ENDIF
51948 XXC(7)=XXC(6)
51949 XXC(8)=XXC(5)
51950 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51951 LKNT=LKNT+1
51952 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51953 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51954 IDLAM(LKNT,1)=KFCCHI(IJ)
51955 IDLAM(LKNT,2)=11
51956 IDLAM(LKNT,3)=-12
51957 LKNT=LKNT+1
51958 XLAM(LKNT)=XLAM(LKNT-1)
51959 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51960 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51961 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51962 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51963 LKNT=LKNT+1
51964 XLAM(LKNT)=XLAM(LKNT-1)
51965 IDLAM(LKNT,1)=KFCCHI(IJ)
51966 IDLAM(LKNT,2)=13
51967 IDLAM(LKNT,3)=-14
51968 LKNT=LKNT+1
51969 XLAM(LKNT)=XLAM(LKNT-1)
51970 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51971 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51972 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51973 ENDIF
51974 ENDIF
51975 230 CONTINUE
51976 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51977 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51978 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51979 ELSE
51980 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51981 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51982 ENDIF
51983 IF(XXC(5).LT.AXMI) THEN
51984 XXC(5)=1D6
51985 ENDIF
51986 IF(XXC(6).LT.AXMI) THEN
51987 XXC(6)=1D6
51988 ENDIF
51989 XXC(7)=XXC(6)
51990 XXC(8)=XXC(5)
51991 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51992 LKNT=LKNT+1
51993 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51994 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51995 XLAM(LKNT)=XLAM(LKNT-1)
51996 IDLAM(LKNT,1)=KFCCHI(IJ)
51997 IDLAM(LKNT,2)=15
51998 IDLAM(LKNT,3)=-16
51999 LKNT=LKNT+1
52000 XLAM(LKNT)=XLAM(LKNT-1)
52001 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52002 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52003 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52004 ENDIF
52005
52006C...NOW, DO THE QUARKS
52007 240 CONTINUE
52008 IA=1
52009 JA=2
52010 EI=KCHG(IA,1)/3D0
52011 T3I=SIGN(1D0,EI+1D-6)/2D0
52012 EJ=KCHG(JA,1)/3D0
52013 T3J=SIGN(1D0,EJ+1D-6)/2D0
52014 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52015 & TANW+ZMIXC(IX,2)*T3J)
52016 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52017 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52018 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52019 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52020 IF(XXC(5).LT.AXMI) THEN
52021 XXC(5)=1D6
52022 ENDIF
52023 IF(XXC(6).LT.AXMI) THEN
52024 XXC(6)=1D6
52025 ENDIF
52026 XXC(7)=XXC(6)
52027 XXC(8)=XXC(5)
52028 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52029 LKNT=LKNT+1
52030 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52031 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52032 IDLAM(LKNT,1)=KFCCHI(IJ)
52033 IDLAM(LKNT,2)=1
52034 IDLAM(LKNT,3)=-2
52035 LKNT=LKNT+1
52036 XLAM(LKNT)=XLAM(LKNT-1)
52037 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52038 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52039 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52040 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52041 LKNT=LKNT+1
52042 XLAM(LKNT)=XLAM(LKNT-1)
52043 IDLAM(LKNT,1)=KFCCHI(IJ)
52044 IDLAM(LKNT,2)=3
52045 IDLAM(LKNT,3)=-4
52046 LKNT=LKNT+1
52047 XLAM(LKNT)=XLAM(LKNT-1)
52048 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52049 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52050 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52051 ENDIF
52052 ENDIF
52053 250 CONTINUE
52054 ENDIF
52055 260 CONTINUE
52056 270 CONTINUE
52057
52058C...CHI0_I -> CHI+_I + H-
52059 DO 280 IJ=1,2
52060 XMJ=SMW(IJ)
52061 AXMJ=ABS(XMJ)
52062 XMJ2=XMJ**2
52063 XMHP=PMAS(ITHC,1)
52064 IF(AXMI.GE.AXMJ+XMHP) THEN
52065 LKNT=LKNT+1
52066 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52067 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52068 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52069 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52070 & UMIXC(IJ,2)/SR2)
52071 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52072 GLR=DBLE(OLPP*DCONJG(ORPP))
52073 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52074 IDLAM(LKNT,1)=KFCCHI(IJ)
52075 IDLAM(LKNT,2)=-ITHC
52076 IDLAM(LKNT,3)=0
52077 LKNT=LKNT+1
52078 XLAM(LKNT)=XLAM(LKNT-1)
52079 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52080 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52081 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52082 ELSE
52083
52084 ENDIF
52085 280 CONTINUE
52086
52087C...2-BODY DECAYS TO FERMION SFERMION
52088 DO 290 J=1,16
52089 IF(J.GE.7.AND.J.LE.10) GOTO 290
52090 KF1=KSUSY1+J
52091 KF2=KSUSY2+J
52092 XMSF1=PMAS(PYCOMP(KF1),1)
52093 XMSF2=PMAS(PYCOMP(KF2),1)
52094 XMF=PMAS(J,1)
52095 IF(J.LE.6) THEN
52096 FCOL=3D0
52097 ELSE
52098 FCOL=1D0
52099 ENDIF
52100
52101 EI=KCHG(J,1)/3D0
52102 T3T=SIGN(1D0,EI)
52103 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52104 IF(MOD(J,2).EQ.0) THEN
52105 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52106 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52107 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52108 CBR=CAL
52109 ELSE
52110 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52111 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52112 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52113 CBR=CAL
52114 ENDIF
52115
52116C...D~ D_L
52117 IF(AXMI.GE.XMF+XMSF1) THEN
52118 LKNT=LKNT+1
52119 XMA2=XMSF1**2
52120 XMB2=XMF**2
52121 XL=PYLAMF(XMI2,XMA2,XMB2)
52122 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52123 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52124 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52125 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52126 IDLAM(LKNT,1)=KF1
52127 IDLAM(LKNT,2)=-J
52128 IDLAM(LKNT,3)=0
52129 LKNT=LKNT+1
52130 XLAM(LKNT)=XLAM(LKNT-1)
52131 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52132 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52133 IDLAM(LKNT,3)=0
52134 ENDIF
52135
52136C...D~ D_R
52137 IF(AXMI.GE.XMF+XMSF2) THEN
52138 LKNT=LKNT+1
52139 XMA2=XMSF2**2
52140 XMB2=XMF**2
52141 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52142 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52143 XL=PYLAMF(XMI2,XMA2,XMB2)
52144 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52145 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52146 IDLAM(LKNT,1)=KF2
52147 IDLAM(LKNT,2)=-J
52148 IDLAM(LKNT,3)=0
52149 LKNT=LKNT+1
52150 XLAM(LKNT)=XLAM(LKNT-1)
52151 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52152 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52153 IDLAM(LKNT,3)=0
52154 ENDIF
52155 290 CONTINUE
52156 300 CONTINUE
52157C...3-BODY DECAY TO Q Q~ GLUINO
52158 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52159 IF(AXMI.GE.XMJ) THEN
52160 RT2I = 1D0/SQRT(2D0)
52161 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52162 ORPP=DCONJG(OLPP)
52163 AXMJ=ABS(XMJ)
52164 XXC(1)=0D0
52165 XXC(2)=XMJ
52166 XXC(3)=0D0
52167 XXC(4)=XMI
52168 FID=1
52169 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52170 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52171 XXC(7)=XXC(5)
52172 XXC(8)=XXC(6)
52173 XXC(9)=1D6
52174 XXC(10)=0D0
52175 EI=KCHG(FID,1)/3D0
52176 T3I=SIGN(1D0,EI+1D-6)/2D0
52177 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52178 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52179 CXC(1)=0D0
52180 CXC(2)=-GLIJ
52181 CXC(3)=0D0
52182 CXC(4)=DCONJG(GLIJ)
52183 CXC(5)=0D0
52184 CXC(6)=GRIJ
52185 CXC(7)=0D0
52186 CXC(8)=-DCONJG(GRIJ)
52187 S12MIN=0D0
52188 S12MAX=(AXMI-AXMJ)**2
52189CMRENNA.This statement must be here to define S12MAX
52190 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
52191C...ALL QUARKS BUT T
52192 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52193 LKNT=LKNT+1
52194 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52195 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52196 IDLAM(LKNT,1)=KSUSY1+21
52197 IDLAM(LKNT,2)=1
52198 IDLAM(LKNT,3)=-1
52199 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52200 LKNT=LKNT+1
52201 XLAM(LKNT)=XLAM(LKNT-1)
52202 IDLAM(LKNT,1)=KSUSY1+21
52203 IDLAM(LKNT,2)=3
52204 IDLAM(LKNT,3)=-3
52205 ENDIF
52206 ENDIF
52207 310 CONTINUE
52208 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52209 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52210 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52211 ELSE
52212 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52213 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52214 ENDIF
52215 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
52216 XXC(7)=XXC(5)
52217 XXC(8)=XXC(6)
52218 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52219 LKNT=LKNT+1
52220 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52221 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52222 IDLAM(LKNT,1)=KSUSY1+21
52223 IDLAM(LKNT,2)=5
52224 IDLAM(LKNT,3)=-5
52225 ENDIF
52226C...U-TYPE QUARKS
52227 320 CONTINUE
52228 FID=2
52229 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52230 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52231 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
52232 XXC(7)=XXC(5)
52233 XXC(8)=XXC(6)
52234 EI=KCHG(FID,1)/3D0
52235 T3I=SIGN(1D0,EI+1D-6)/2D0
52236 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52237 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52238 CXC(2)=-GLIJ
52239 CXC(4)=DCONJG(GLIJ)
52240 CXC(6)=GRIJ
52241 CXC(8)=-DCONJG(GRIJ)
52242 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52243 LKNT=LKNT+1
52244 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52245 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52246 IDLAM(LKNT,1)=KSUSY1+21
52247 IDLAM(LKNT,2)=2
52248 IDLAM(LKNT,3)=-2
52249 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52250 LKNT=LKNT+1
52251 XLAM(LKNT)=XLAM(LKNT-1)
52252 IDLAM(LKNT,1)=KSUSY1+21
52253 IDLAM(LKNT,2)=4
52254 IDLAM(LKNT,3)=-4
52255 ENDIF
52256 ENDIF
52257 330 CONTINUE
52258 ENDIF
52259
52260C...R-violating decay modes (SKANDS).
52261 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
52262
52263 340 IKNT=LKNT
52264 XLAM(0)=0D0
52265 DO 350 I=1,IKNT
52266 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
52267 XLAM(0)=XLAM(0)+XLAM(I)
52268 350 CONTINUE
52269 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52270
52271 RETURN
52272 END
52273
52274C*********************************************************************
52275
52276C...PYCJDC
52277C...Calculate decay widths for the charginos (admixtures of
52278C...charged Wino and charged Higgsino.
52279
52280C...Input: KCIN = KF code for particle
52281C...Output: XLAM = widths
52282C... IDLAM = KF codes for decay particles
52283C... IKNT = number of decay channels defined
52284C...AUTHOR: STEPHEN MRENNA
52285C...Last change:
52286C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52287C...when CHIENU .NE. 0
52288
52289 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
52290
52291C...Double precision and integer declarations.
52292 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52293 IMPLICIT INTEGER(I-N)
52294 INTEGER PYK,PYCHGE,PYCOMP
52295C...Parameter statement to help give large particle numbers.
52296 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52297 &KEXCIT=4000000,KDIMEN=5000000)
52298C...Commonblocks.
52299 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52300 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52301 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52302 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52303 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52304CC &SFMIX(16,4),
52305C COMMON/PYINTS/XXM(20)
52306 COMPLEX*16 CXC
52307 COMMON/PYINTC/XXC(10),CXC(8)
52308 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52309
52310C...Local variables
52311 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52312 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52313 INTEGER KFIN,KCIN
52314 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52315 &XMZ,XMZ2,AXMJ,AXMI
52316 DOUBLE PRECISION S12MIN,S12MAX
52317 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52318 DOUBLE PRECISION PYLAMF,XL
52319 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52320 DOUBLE PRECISION PYX2XH,PYX2XG
52321 DOUBLE PRECISION XLAM(0:400)
52322 INTEGER IDLAM(400,3)
52323 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52324 INTEGER ITH(3)
52325 INTEGER ITHC
52326 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52327 DOUBLE PRECISION SR2
52328 DOUBLE PRECISION CBETA,SBETA,TANB
52329
52330 DOUBLE PRECISION PYALEM,PI,PYALPS
52331 DOUBLE PRECISION FCOL
52332 INTEGER KF1,KF2,ISF
52333 INTEGER KFNCHI(4),KFCCHI(2)
52334
52335 DOUBLE PRECISION TEMP
52336 EXTERNAL PYGAUS,PYXXZ6
52337 DOUBLE PRECISION PYGAUS,PYXXZ6
52338 DOUBLE PRECISION PREC
52339 DATA ITH/25,35,36/
52340 DATA ITHC/37/
52341 DATA ETAH/1D0,1D0,-1D0/
52342 DATA SR2/1.4142136D0/
52343 DATA PI/3.141592654D0/
52344 DATA PREC/1D-2/
52345 DATA KFNCHI/1000022,1000023,1000025,1000035/
52346 DATA KFCCHI/1000024,1000037/
52347
52348C...COUNT THE NUMBER OF DECAY MODES
52349 LKNT=0
52350 XMW=PMAS(24,1)
52351 XMW2=XMW**2
52352 XMZ=PMAS(23,1)
52353 XMZ2=XMZ**2
52354 XW=1D0-XMW2/XMZ2
52355 XW1=1D0-XW
52356 TANW = SQRT(XW/XW1)
52357
52358C...1 OR 2 DEPENDING ON CHARGINO TYPE
52359 IX=1
52360 IF(KFIN.EQ.KFCCHI(2)) IX=2
52361 KCIN=PYCOMP(KFIN)
52362
52363 XMI=SMW(IX)
52364 XMI2=XMI**2
52365 AXMI=ABS(XMI)
52366 AEM=PYALEM(XMI2)
52367 AS =PYALPS(XMI2)
52368 C1=AEM/XW
52369 XMI3=ABS(XMI**3)
52370 TANB=RMSS(5)
52371 BETA=ATAN(TANB)
52372 CBETA=COS(BETA)
52373 SBETA=TANB*CBETA
52374 ALFA=RMSS(18)
52375
52376 DO 110 I=1,2
52377 DO 100 J=1,2
52378 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52379 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52380 100 CONTINUE
52381 110 CONTINUE
52382
52383C...GRAVITINO DECAY MODES
52384
52385 IF(IMSS(11).EQ.1) THEN
52386 XMP=RMSS(29)
52387 IDG=39+KSUSY1
52388 XMGR=PMAS(PYCOMP(IDG),1)
52389C SINW=SQRT(XW)
52390C COSW=SQRT(1D0-XW)
52391 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52392 IF(AXMI.GT.XMGR+XMW) THEN
52393 LKNT=LKNT+1
52394 IDLAM(LKNT,1)=IDG
52395 IDLAM(LKNT,2)=24
52396 IDLAM(LKNT,3)=0
52397 XLAM(LKNT)=XFAC*(
52398 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
52399 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
52400 & (1D0-XMW2/XMI2)**4
52401 ENDIF
52402 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
52403 LKNT=LKNT+1
52404 IDLAM(LKNT,1)=IDG
52405 IDLAM(LKNT,2)=37
52406 IDLAM(LKNT,3)=0
52407 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
52408 & (ABS(UMIXC(IX,2))*SBETA)**2))
52409 & *(1D0-PMAS(37,1)**2/XMI2)**4
52410 ENDIF
52411 ENDIF
52412
52413C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52414 IF(IX.EQ.1) GOTO 170
52415 XMJ=SMW(1)
52416 AXMJ=ABS(XMJ)
52417 XMJ2=XMJ**2
52418
52419C...CHI_2+ -> CHI_1+ + Z0
52420 IF(AXMI.GE.AXMJ+XMZ) THEN
52421 LKNT=LKNT+1
52422 IJ=1
52423 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52424 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52425 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52426 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52427 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52428 GLR=DBLE(OLPP*DCONJG(ORPP))
52429 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52430 IDLAM(LKNT,1)=KFCCHI(1)
52431 IDLAM(LKNT,2)=23
52432 IDLAM(LKNT,3)=0
52433
52434C...CHARGED LEPTONS
52435 ELSEIF(AXMI.GE.AXMJ) THEN
52436 S12MIN=0D0
52437 S12MAX=(AXMI-AXMJ)**2
52438 IA=11
52439 JA=12
52440 EI=KCHG(IABS(IA),1)/3D0
52441 T3I=SIGN(1D0,EI+1D-6)/2D0
52442 XXC(1)=0D0
52443 XXC(2)=XMJ
52444 XXC(3)=0D0
52445 XXC(4)=XMI
52446 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52447 XXC(6)=1D6
52448 XXC(9)=PMAS(23,1)
52449 XXC(10)=PMAS(23,2)
52450 IJ=1
52451 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52452 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52453 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52454 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52455 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52456 CXC(2)=DCMPLX(0D0,0D0)
52457 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52458 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52459 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52460 CXC(6)=DCMPLX(0D0,0D0)
52461 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52462 CXC(8)=DCMPLX(0D0,0D0)
52463 IF( XXC(5).LT.AXMI ) THEN
52464 XXC(5)=1D6
52465 ENDIF
52466 XXC(7)=XXC(5)
52467 XXC(8)=XXC(6)
52468 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52469 LKNT=LKNT+1
52470 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52471 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52472 IDLAM(LKNT,1)=KFCCHI(1)
52473 IDLAM(LKNT,2)=11
52474 IDLAM(LKNT,3)=-11
52475 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52476 LKNT=LKNT+1
52477 XLAM(LKNT)=XLAM(LKNT-1)
52478 IDLAM(LKNT,1)=KFCCHI(1)
52479 IDLAM(LKNT,2)=13
52480 IDLAM(LKNT,3)=-13
52481 ENDIF
52482 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52483 LKNT=LKNT+1
52484 XLAM(LKNT)=XLAM(LKNT-1)
52485 IDLAM(LKNT,1)=KFCCHI(1)
52486 IDLAM(LKNT,2)=15
52487 IDLAM(LKNT,3)=-15
52488 ENDIF
52489 ENDIF
52490
52491C...NEUTRINOS
52492 120 CONTINUE
52493 IA=12
52494 JA=11
52495 EI=KCHG(IABS(IA),1)/3D0
52496 T3I=SIGN(1D0,EI+1D-6)/2D0
52497 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52498 XXC(6)=1D6
52499 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52500 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52501 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52502 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52503 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52504 IF( XXC(5).LT.AXMI ) THEN
52505 XXC(5)=1D6
52506 ENDIF
52507 XXC(7)=XXC(5)
52508 XXC(8)=XXC(6)
52509 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
52510 LKNT=LKNT+1
52511 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52512 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52513 IDLAM(LKNT,1)=KFCCHI(1)
52514 IDLAM(LKNT,2)=12
52515 IDLAM(LKNT,3)=-12
52516 LKNT=LKNT+1
52517 XLAM(LKNT)=XLAM(LKNT-1)
52518 IDLAM(LKNT,1)=KFCCHI(1)
52519 IDLAM(LKNT,2)=14
52520 IDLAM(LKNT,3)=-14
52521 ENDIF
52522 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
52523 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52524 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52525 ELSE
52526 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52527 ENDIF
52528 IF( XXC(5).LT.AXMI ) THEN
52529 XXC(5)=1D6
52530 ENDIF
52531 XXC(7)=XXC(5)
52532 LKNT=LKNT+1
52533 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52534 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52535 IDLAM(LKNT,1)=KFCCHI(1)
52536 IDLAM(LKNT,2)=16
52537 IDLAM(LKNT,3)=-16
52538 ENDIF
52539
52540C...D-TYPE QUARKS
52541 130 CONTINUE
52542 IA=1
52543 JA=2
52544 EI=KCHG(IABS(IA),1)/3D0
52545 T3I=SIGN(1D0,EI+1D-6)/2D0
52546 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52547 XXC(6)=1D6
52548 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52549 CXC(2)=DCMPLX(0D0,0D0)
52550 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52551 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52552 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52553 CXC(6)=DCMPLX(0D0,0D0)
52554 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52555 CXC(8)=DCMPLX(0D0,0D0)
52556 IF( XXC(5).LT.AXMI ) THEN
52557 XXC(5)=1D6
52558 ENDIF
52559 XXC(7)=XXC(5)
52560 XXC(8)=XXC(6)
52561 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52562 LKNT=LKNT+1
52563 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52564 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52565 IDLAM(LKNT,1)=KFCCHI(1)
52566 IDLAM(LKNT,2)=1
52567 IDLAM(LKNT,3)=-1
52568 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52569 LKNT=LKNT+1
52570 XLAM(LKNT)=XLAM(LKNT-1)
52571 IDLAM(LKNT,1)=KFCCHI(1)
52572 IDLAM(LKNT,2)=3
52573 IDLAM(LKNT,3)=-3
52574 ENDIF
52575 ENDIF
52576 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52577 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52578 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52579 ELSE
52580 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52581 ENDIF
52582 IF( XXC(5).LT.AXMI ) THEN
52583 XXC(5)=1D6
52584 ENDIF
52585 XXC(7)=XXC(5)
52586 LKNT=LKNT+1
52587 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52588 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52589 IDLAM(LKNT,1)=KFCCHI(1)
52590 IDLAM(LKNT,2)=5
52591 IDLAM(LKNT,3)=-5
52592 ENDIF
52593
52594C...U-TYPE QUARKS
52595 140 CONTINUE
52596 IA=2
52597 JA=1
52598 EI=KCHG(IABS(IA),1)/3D0
52599 T3I=SIGN(1D0,EI+1D-6)/2D0
52600 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52601 XXC(6)=1D6
52602 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52603 CXC(2)=DCMPLX(0D0,0D0)
52604 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52605 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52606 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52607 CXC(6)=DCMPLX(0D0,0D0)
52608 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52609 CXC(8)=DCMPLX(0D0,0D0)
52610 IF( XXC(5).LT.AXMI ) THEN
52611 XXC(5)=1D6
52612 ENDIF
52613 XXC(7)=XXC(5)
52614 XXC(8)=XXC(6)
52615 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52616 LKNT=LKNT+1
52617 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52618 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52619 IDLAM(LKNT,1)=KFCCHI(1)
52620 IDLAM(LKNT,2)=2
52621 IDLAM(LKNT,3)=-2
52622 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52623 LKNT=LKNT+1
52624 XLAM(LKNT)=XLAM(LKNT-1)
52625 IDLAM(LKNT,1)=KFCCHI(1)
52626 IDLAM(LKNT,2)=4
52627 IDLAM(LKNT,3)=-4
52628 ENDIF
52629 ENDIF
52630 150 CONTINUE
52631 ENDIF
52632
52633C...CHI_2+ -> CHI_1+ + H0_K
52634 EH(2)=COS(ALFA)
52635 EH(1)=SIN(ALFA)
52636 EH(3)=-SBETA
52637 DH(2)=-SIN(ALFA)
52638 DH(1)=COS(ALFA)
52639 DH(3)=COS(BETA)
52640 DO 160 IH=1,3
52641 XMH=PMAS(ITH(IH),1)
52642 XMH2=XMH**2
52643C...NO 3-BODY OPTION
52644 IF(AXMI.GE.AXMJ+XMH) THEN
52645 LKNT=LKNT+1
52646 XL=PYLAMF(XMI2,XMJ2,XMH2)
52647 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
52648 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
52649 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
52650 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
52651 XMK=XMJ*ETAH(IH)
52652 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52653 GLR=DBLE(OLPP*DCONJG(ORPP))
52654 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52655 IDLAM(LKNT,1)=KFCCHI(1)
52656 IDLAM(LKNT,2)=ITH(IH)
52657 IDLAM(LKNT,3)=0
52658 ENDIF
52659 160 CONTINUE
52660
52661C...CHI1 JUMPS TO HERE
52662 170 CONTINUE
52663
52664C...CHI+_I -> CHI0_J + W+
52665 DO 220 IJ=1,4
52666 XMJ=SMZ(IJ)
52667 AXMJ=ABS(XMJ)
52668 XMJ2=XMJ**2
52669 IF(AXMI.GE.AXMJ+XMW) THEN
52670 LKNT=LKNT+1
52671 DO 180 I=1,4
52672 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52673 180 CONTINUE
52674 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52675 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
52676 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52677 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
52678 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52679 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52680 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52681 IDLAM(LKNT,1)=KFNCHI(IJ)
52682 IDLAM(LKNT,2)=24
52683 IDLAM(LKNT,3)=0
52684C...LEPTONS
52685 ELSEIF(AXMI.GE.AXMJ) THEN
52686 S12MIN=0D0
52687 S12MAX=(AXMI-AXMJ)**2
52688 DO 190 I=1,4
52689 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52690 190 CONTINUE
52691 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52692 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
52693 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52694 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
52695 CXC(5)=DCMPLX(0D0,0D0)
52696 CXC(7)=DCMPLX(0D0,0D0)
52697 IA=11
52698 JA=12
52699 EI=KCHG(IA,1)/3D0
52700 T3I=SIGN(1D0,EI+1D-6)/2D0
52701 EJ=KCHG(JA,1)/3D0
52702 T3J=SIGN(1D0,EJ+1D-6)/2D0
52703 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52704 & TANW+ZMIXC(IJ,2)*T3J)/SR2
52705 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52706 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
52707 CXC(6)=DCMPLX(0D0,0D0)
52708 CXC(8)=DCMPLX(0D0,0D0)
52709 XXC(1)=0D0
52710 XXC(2)=XMJ
52711 XXC(3)=0D0
52712 XXC(4)=XMI
52713 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52714 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52715 XXC(9)=PMAS(24,1)
52716 XXC(10)=PMAS(24,2)
52717CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52718 IF(XXC(5).LT.AXMI) THEN
52719 XXC(5)=1D6
52720 ELSEIF(XXC(6).LT.AXMI) THEN
52721 XXC(6)=1D6
52722 ENDIF
52723 XXC(7)=XXC(6)
52724 XXC(8)=XXC(5)
52725C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52726C...--> 1/(16PI)/M**3*(AEM/XW)**2
52727 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52728 LKNT=LKNT+1
52729 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52730 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52731 IDLAM(LKNT,1)=KFNCHI(IJ)
52732 IDLAM(LKNT,2)=-11
52733 IDLAM(LKNT,3)=12
52734C...ONLY DECAY CHI+1 -> E+ NU_E
52735 IF( IMSS(12).NE. 0 ) GOTO 260
52736 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52737 LKNT=LKNT+1
52738 XLAM(LKNT)=XLAM(LKNT-1)
52739 IDLAM(LKNT,1)=KFNCHI(IJ)
52740 IDLAM(LKNT,2)=-13
52741 IDLAM(LKNT,3)=14
52742 ENDIF
52743 ENDIF
52744 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52745 LKNT=LKNT+1
52746 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52747 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52748 ELSE
52749 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52750 ENDIF
52751 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
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 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52760 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52761 IDLAM(LKNT,1)=KFNCHI(IJ)
52762 IDLAM(LKNT,2)=-15
52763 IDLAM(LKNT,3)=16
52764 ENDIF
52765
52766C...NOW, DO THE QUARKS
52767 200 CONTINUE
52768 IA=1
52769 JA=2
52770 EI=KCHG(IA,1)/3D0
52771 T3I=SIGN(1D0,EI+1D-6)/2D0
52772 EJ=KCHG(JA,1)/3D0
52773 T3J=SIGN(1D0,EJ+1D-6)/2D0
52774 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52775 & TANW+ZMIXC(IJ,2)*T3J)
52776 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52777 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
52778 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52779 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52780 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
52781 IF(XXC(5).LT.AXMI) THEN
52782 XXC(5)=1D6
52783 ENDIF
52784 IF(XXC(6).LT.AXMI) THEN
52785 XXC(6)=1D6
52786 ENDIF
52787 XXC(7)=XXC(6)
52788 XXC(8)=XXC(5)
52789 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52790 LKNT=LKNT+1
52791 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52792 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52793 IDLAM(LKNT,1)=KFNCHI(IJ)
52794 IDLAM(LKNT,2)=-1
52795 IDLAM(LKNT,3)=2
52796 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52797 LKNT=LKNT+1
52798 XLAM(LKNT)=XLAM(LKNT-1)
52799 IDLAM(LKNT,1)=KFNCHI(IJ)
52800 IDLAM(LKNT,2)=-3
52801 IDLAM(LKNT,3)=4
52802 ENDIF
52803 ENDIF
52804 210 CONTINUE
52805 ENDIF
52806 220 CONTINUE
52807
52808C...CHI+_I -> CHI0_J + H+
52809 DO 230 IJ=1,4
52810 XMJ=SMZ(IJ)
52811 AXMJ=ABS(XMJ)
52812 XMJ2=XMJ**2
52813 XMHP=PMAS(ITHC,1)
52814 IF(AXMI.GE.AXMJ+XMHP) THEN
52815 LKNT=LKNT+1
52816 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
52817 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
52818 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
52819 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
52820 & UMIXC(IX,2)/SR2)
52821 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52822 GLR=DBLE(OLPP*DCONJG(ORPP))
52823 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52824 IDLAM(LKNT,1)=KFNCHI(IJ)
52825 IDLAM(LKNT,2)=ITHC
52826 IDLAM(LKNT,3)=0
52827 ELSE
52828
52829 ENDIF
52830 230 CONTINUE
52831
52832C...2-BODY DECAYS TO FERMION SFERMION
52833 DO 240 J=1,16
52834 IF(J.GE.7.AND.J.LE.10) GOTO 240
52835 IF(MOD(J,2).EQ.0) THEN
52836 KF1=KSUSY1+J-1
52837 ELSE
52838 KF1=KSUSY1+J+1
52839 ENDIF
52840 KF2=KF1+KSUSY1
52841 XMSF1=PMAS(PYCOMP(KF1),1)
52842 XMSF2=PMAS(PYCOMP(KF2),1)
52843 XMF=PMAS(J,1)
52844 IF(J.LE.6) THEN
52845 FCOL=3D0
52846 ELSE
52847 FCOL=1D0
52848 ENDIF
52849
52850C...U~ D_L
52851 IF(MOD(J,2).EQ.0) THEN
52852 XMFP=PMAS(J-1,1)
52853 CAL=UMIXC(IX,1)
52854 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
52855 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
52856 CBR=0D0
52857 ISF=J-1
52858 ELSE
52859 XMFP=PMAS(J+1,1)
52860 CAL=VMIXC(IX,1)
52861 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
52862 CBR=0D0
52863 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
52864 ISF=J+1
52865 ENDIF
52866
52867C...~U_L D
52868 IF(AXMI.GE.XMF+XMSF1) THEN
52869 LKNT=LKNT+1
52870 XMA2=XMSF1**2
52871 XMB2=XMF**2
52872 XL=PYLAMF(XMI2,XMA2,XMB2)
52873 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
52874 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
52875 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52876 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52877 IDLAM(LKNT,3)=0
52878 IF(MOD(J,2).EQ.0) THEN
52879 IDLAM(LKNT,1)=-KF1
52880 IDLAM(LKNT,2)=J
52881 ELSE
52882 IDLAM(LKNT,1)=KF1
52883 IDLAM(LKNT,2)=-J
52884 ENDIF
52885 ENDIF
52886
52887C...U~ D_R
52888 IF(AXMI.GE.XMF+XMSF2) THEN
52889 LKNT=LKNT+1
52890 XMA2=XMSF2**2
52891 XMB2=XMF**2
52892 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
52893 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
52894 XL=PYLAMF(XMI2,XMA2,XMB2)
52895 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52896 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52897 IDLAM(LKNT,3)=0
52898 IF(MOD(J,2).EQ.0) THEN
52899 IDLAM(LKNT,1)=-KF2
52900 IDLAM(LKNT,2)=J
52901 ELSE
52902 IDLAM(LKNT,1)=KF2
52903 IDLAM(LKNT,2)=-J
52904 ENDIF
52905 ENDIF
52906 240 CONTINUE
52907
52908C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52909C...A 2-BODY -- 2-BODY CHAIN
52910 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52911 IF(AXMI.GE.XMJ) THEN
52912 AXMJ=ABS(XMJ)
52913 S12MIN=0D0
52914 S12MAX=(AXMI-AXMJ)**2
52915 XXC(1)=0D0
52916 XXC(2)=XMJ
52917 XXC(3)=0D0
52918 XXC(4)=XMI
52919 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
52920 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
52921 XXC(9)=1D6
52922 XXC(10)=0D0
52923 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
52924 ORPP=DCONJG(OLPP)
52925 CXC(1)=DCMPLX(0D0,0D0)
52926 CXC(3)=DCMPLX(0D0,0D0)
52927 CXC(5)=DCMPLX(0D0,0D0)
52928 CXC(7)=DCMPLX(0D0,0D0)
52929 CXC(2)=UMIXC(IX,1)*OLPP/SR2
52930 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
52931 CXC(6)=DCMPLX(0D0,0D0)
52932 CXC(8)=DCMPLX(0D0,0D0)
52933 IF(XXC(5).LT.AXMI) THEN
52934 XXC(5)=1D6
52935 ELSEIF(XXC(6).LT.AXMI) THEN
52936 XXC(6)=1D6
52937 ENDIF
52938 XXC(7)=XXC(6)
52939 XXC(8)=XXC(5)
52940 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
52941 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52942 LKNT=LKNT+1
52943 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52944 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52945 IDLAM(LKNT,1)=KSUSY1+21
52946 IDLAM(LKNT,2)=-1
52947 IDLAM(LKNT,3)=2
52948 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52949 LKNT=LKNT+1
52950 XLAM(LKNT)=XLAM(LKNT-1)
52951 IDLAM(LKNT,1)=KSUSY1+21
52952 IDLAM(LKNT,2)=-3
52953 IDLAM(LKNT,3)=4
52954 ENDIF
52955 ENDIF
52956 250 CONTINUE
52957 ENDIF
52958
52959C...R-violating decay modes (SKANDS).
52960 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
52961
52962 260 IKNT=LKNT
52963 XLAM(0)=0D0
52964 DO 270 I=1,IKNT
52965 XLAM(0)=XLAM(0)+XLAM(I)
52966 IF(XLAM(I).LT.0D0) THEN
52967 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52968 & (IDLAM(I,J),J=1,3)
52969 XLAM(I)=0D0
52970 ENDIF
52971 270 CONTINUE
52972 IF(XLAM(0).EQ.0D0) THEN
52973 XLAM(0)=1D-6
52974 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52975 WRITE(MSTU(11),*) LKNT
52976 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52977 ENDIF
52978
52979 RETURN
52980 END
52981
52982C*********************************************************************
52983
52984C...PYXXZ6
52985C...Used in the calculation of inoi -> inoj + f + ~f.
52986
52987 FUNCTION PYXXZ6(X)
52988
52989C...Double precision and integer declarations.
52990 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52991 IMPLICIT INTEGER(I-N)
52992 INTEGER PYK,PYCHGE,PYCOMP
52993C...Parameter statement to help give large particle numbers.
52994 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52995 &KEXCIT=4000000,KDIMEN=5000000)
52996C...Commonblocks.
52997 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52998C COMMON/PYINTS/XXM(20)
52999 COMPLEX*16 CXC
53000 COMMON/PYINTC/XXC(10),CXC(8)
53001 SAVE /PYDAT1/,/PYINTC/
53002
53003C...Local variables.
53004 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53005 DOUBLE PRECISION PYXXZ6,X
53006 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53007 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53008 DOUBLE PRECISION SIJ
53009 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53010 DOUBLE PRECISION OL2
53011 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53012 INTEGER I
53013
53014C...Statement functions.
53015C...Integral from x to y of (t-a)(b-t) dt.
53016 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53017C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53018 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53019 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53020C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53021 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53022 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53023C...Integral from x to y of (t-a)/(b-t) dt.
53024 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53025C...Integral from x to y of 1/(t-a) dt.
53026 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53027
53028 XM12=XXC(1)**2
53029 XM22=XXC(2)**2
53030 XM32=XXC(3)**2
53031 S=XXC(4)**2
53032 S13=X
53033
53034 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53035 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53036 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53037
53038 S23MIN=(S23AVE-S23DEL)
53039 S23MAX=(S23AVE+S23DEL)
53040
53041 XMSD1=XXC(5)**2
53042 XMSD2=XXC(7)**2
53043 XMSU1=XXC(6)**2
53044 XMSU2=XXC(8)**2
53045
53046 XMV=XXC(9)
53047 XMG=XXC(10)
53048 QLLS=CXC(1)
53049 QLLU=CXC(2)
53050 QLRS=CXC(3)
53051 QLRT=CXC(4)
53052 QRLS=CXC(5)
53053 QRLT=CXC(6)
53054 QRRS=CXC(7)
53055 QRRU=CXC(8)
53056 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53057 SIJ=2D0*XXC(2)*XXC(4)*S13
53058 IF(XMV.LE.1000D0) THEN
53059 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53060 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53061 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53062 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53063 IF(XXC(5).LE.10000D0) THEN
53064 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53065 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53066 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53067 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53068 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53069 & *(S13-XMV**2)/WPROP2
53070 ELSE
53071 WFL1=0D0
53072 ENDIF
53073
53074 IF(XXC(6).LE.10000D0) THEN
53075 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53076 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53077 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53078 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53079 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53080 & *(S13-XMV**2)/WPROP2
53081 ELSE
53082 WFL2=0D0
53083 ENDIF
53084 ELSE
53085 WW=0D0
53086 WFL1=0D0
53087 WFL2=0D0
53088 ENDIF
53089 IF(XXC(5).LE.10000D0) THEN
53090 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53091 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53092 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53093 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53094 ELSE
53095 WF1=0D0
53096 ENDIF
53097 IF(XXC(6).LE.10000D0) THEN
53098 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53099 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53100 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53101 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53102 ELSE
53103 WF2=0D0
53104 ENDIF
53105
53106 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53107
53108 IF(PYXXZ6.LT.0D0) THEN
53109 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53110 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53111 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53112 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53113 WRITE(MSTU(11),*) S23MIN,S23MAX
53114 PYXXZ6=0D0
53115 ENDIF
53116
53117 RETURN
53118 END
53119
53120
53121C*********************************************************************
53122
53123C...PYXXGA
53124C...Calculates chi0_i -> chi0_j + gamma.
53125
53126 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53127
53128C...Double precision and integer declarations.
53129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53130 IMPLICIT INTEGER(I-N)
53131 INTEGER PYK,PYCHGE,PYCOMP
53132
53133C...Local variables.
53134 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53135 DOUBLE PRECISION F1,F2
53136
53137 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53138 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53139 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53140 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53141
53142 RETURN
53143 END
53144
53145C*********************************************************************
53146
53147C...PYX2XG
53148C...Calculates the decay rate for ino -> ino + gauge boson.
53149
53150 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53151
53152C...Double precision and integer declarations.
53153 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53154 IMPLICIT INTEGER(I-N)
53155 INTEGER PYK,PYCHGE,PYCOMP
53156
53157C...Local variables.
53158 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53159 DOUBLE PRECISION XL,PYLAMF,C1
53160 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53161
53162 XMI2=XM1**2
53163 XMI3=ABS(XM1**3)
53164 XMJ2=XM2**2
53165 XMV2=XM3**2
53166 XL=PYLAMF(XMI2,XMJ2,XMV2)
53167 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53168 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53169 &12D0*GLR*XM1*XM2*XMV2)
53170
53171 RETURN
53172 END
53173
53174C*********************************************************************
53175
53176C...PYX2XH
53177C...Calculates the decay rate for ino -> ino + H.
53178
53179 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53180
53181C...Double precision and integer declarations.
53182 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53183 IMPLICIT INTEGER(I-N)
53184 INTEGER PYK,PYCHGE,PYCOMP
53185
53186C...Local variables.
53187 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53188 DOUBLE PRECISION XL,PYLAMF,C1
53189 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53190
53191 XMI2=XM1**2
53192 XMI3=ABS(XM1**3)
53193 XMJ2=XM2**2
53194 XMV2=XM3**2
53195 XL=PYLAMF(XMI2,XMJ2,XMV2)
53196 PYX2XH=C1/8D0/XMI3*SQRT(XL)
53197 &*(GX2*(XMI2+XMJ2-XMV2)+
53198 &4D0*GLR*XM1*XM2)
53199
53200 RETURN
53201 END
53202
53203C*********************************************************************
53204
53205C...PYHEXT
53206C...Calculates the non-standard decay modes of the Higgs boson.
53207C...
53208C...Author: Stephen Mrenna
53209C...Last Update: April 2001
53210C......Allow complex values for Z,U, and V
53211
53212 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
53213
53214C...Double precision and integer declarations.
53215 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53216 IMPLICIT INTEGER(I-N)
53217 INTEGER PYK,PYCHGE,PYCOMP
53218C...Parameter statement to help give large particle numbers.
53219 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53220 &KEXCIT=4000000,KDIMEN=5000000)
53221C...Commonblocks.
53222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53224 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53225 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53226 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53227 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53228 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
53229
53230C...Local variables.
53231 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53232 COMPLEX*16 QIJ,RIJ,F21K,F12K
53233 INTEGER KFIN
53234 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53235 DOUBLE PRECISION XMI2,XMI3,XMJ2
53236 DOUBLE PRECISION PYLAMF,XL,CF,EI
53237 INTEGER IDU,IFL
53238 DOUBLE PRECISION TANW,XW,AEM,C1,AS
53239 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53240 DOUBLE PRECISION XLAM(0:400)
53241 INTEGER IDLAM(400,3)
53242 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53243 INTEGER ITH(4)
53244 INTEGER KFNCHI(4),KFCCHI(2)
53245 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53246 DOUBLE PRECISION SR2
53247 DOUBLE PRECISION BETA,ALFA
53248 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53249 DOUBLE PRECISION PYALEM
53250 DOUBLE PRECISION AL,AR,ALR
53251 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53252 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53253 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53254 DATA ITH/25,35,36,37/
53255 DATA ETAH/1D0,1D0,-1D0/
53256 DATA SR2/1.4142136D0/
53257 DATA KFNCHI/1000022,1000023,1000025,1000035/
53258 DATA KFCCHI/1000024,1000037/
53259
53260C...COUNT THE NUMBER OF DECAY MODES
53261 LKNT=IKNT
53262
53263 XMW=PMAS(24,1)
53264 XMW2=XMW**2
53265 XMZ=PMAS(23,1)
53266 XW=PARU(102)
53267 TANW = SQRT(XW/(1D0-XW))
53268 CW=SQRT(1D0-XW)
53269
53270C...1 - 4 DEPENDING ON Higgs species.
53271 IH=1
53272 IF(KFIN.EQ.ITH(2)) IH=2
53273 IF(KFIN.EQ.ITH(3)) IH=3
53274 IF(KFIN.EQ.ITH(4)) IH=4
53275
53276 XMI=PMAS(KFIN,1)
53277 XMI2=XMI**2
53278 AXMI=ABS(XMI)
53279 AEM=PYALEM(XMI2)
53280 C1=AEM/XW
53281 XMI3=ABS(XMI**3)
53282
53283 TANB=RMSS(5)
53284 BETA=ATAN(TANB)
53285 CBETA=COS(BETA)
53286 SBETA=TANB*CBETA
53287 ALFA=RMSS(18)
53288 COSA=COS(ALFA)
53289 SINA=SIN(ALFA)
53290 ATRIT=RMSS(16)
53291 ATRIB=RMSS(15)
53292 ATRIL=RMSS(17)
53293 XMUZ=-RMSS(4)
53294
53295 DO 110 I=1,4
53296 DO 100 J=1,4
53297 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
53298 100 CONTINUE
53299 110 CONTINUE
53300 DO 130 I=1,2
53301 DO 120 J=1,2
53302 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53303 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53304 120 CONTINUE
53305 130 CONTINUE
53306
53307
53308 IF(IH.EQ.4) GOTO 220
53309
53310C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53311C...H0_K -> CHI0_I + CHI0_J
53312 EH(2)=SINA
53313 EH(1)=COSA
53314 EH(3)=CBETA
53315 DH(2)=COSA
53316 DH(1)=-SINA
53317 DH(3)=SBETA
53318 DO 150 IJ=1,4
53319 XMJ=SMZ(IJ)
53320 AXMJ=ABS(XMJ)
53321 DO 140 IK=1,IJ
53322 XMK=SMZ(IK)
53323 AXMK=ABS(XMK)
53324 IF(AXMI.GE.AXMJ+AXMK) THEN
53325 LKNT=LKNT+1
53326 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
53327 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
53328 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
53329 & ZMIXC(IJ,3)*ZMIXC(IK,1))
53330 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
53331 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
53332 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
53333 & ZMIXC(IJ,4)*ZMIXC(IK,1))
53334 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
53335 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
53336C...SIGN OF MASSES I,J
53337 XML=XMK*ETAH(IH)
53338 GX2=ABS(F12K)**2+ABS(F21K)**2
53339 GLR=DBLE(F12K*DCONJG(F21K))
53340 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53341 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
53342 IDLAM(LKNT,1)=KFNCHI(IJ)
53343 IDLAM(LKNT,2)=KFNCHI(IK)
53344 IDLAM(LKNT,3)=0
53345 ENDIF
53346 140 CONTINUE
53347 150 CONTINUE
53348
53349C...H0_K -> CHI+_I CHI-_J
53350 DO 170 IJ=1,2
53351 XMJ=SMW(IJ)
53352 AXMJ=ABS(XMJ)
53353 DO 160 IK=1,2
53354 XMK=SMW(IK)
53355 AXMK=ABS(XMK)
53356 IF(AXMI.GE.AXMJ+AXMK) THEN
53357 LKNT=LKNT+1
53358 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
53359 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
53360 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
53361 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
53362 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53363 GLR=DBLE(OLPP*DCONJG(ORPP))
53364 XML=XMK*ETAH(IH)
53365 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53366 IDLAM(LKNT,1)=KFCCHI(IJ)
53367 IDLAM(LKNT,2)=-KFCCHI(IK)
53368 IDLAM(LKNT,3)=0
53369 ENDIF
53370 160 CONTINUE
53371 170 CONTINUE
53372
53373C...HIGGS TO SFERMION SFERMION
53374 DO 200 IFL=1,16
53375 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
53376 IJ=KSUSY1+IFL
53377 XMJL=PMAS(PYCOMP(IJ),1)
53378 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
53379 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
53380 XMJ=XMJL
53381 XMJ2=XMJ**2
53382 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53383 XMF=PMAS(IFL,1)
53384 EI=KCHG(IFL,1)/3D0
53385 IDU=2-MOD(IFL,2)
53386
53387 IF(IH.EQ.1) THEN
53388 IF(IDU.EQ.1) THEN
53389 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
53390 & XMF**2/XMW*SINA/CBETA
53391 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
53392 & XMF**2/XMW*SINA/CBETA
53393 IF(IFL.EQ.5) THEN
53394 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53395 & ATRIB*SINA)
53396 ELSEIF(IFL.EQ.15) THEN
53397 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53398 & ATRIL*SINA)
53399 ELSE
53400 GHLR=0D0
53401 ENDIF
53402 ELSE
53403 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
53404 & XMF**2/XMW*COSA/SBETA
53405 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
53406 & XMF**2/XMW*COSA/SBETA
53407 IF(IFL.EQ.6) THEN
53408 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
53409 & ATRIT*COSA)
53410 ELSE
53411 GHLR=0D0
53412 ENDIF
53413 ENDIF
53414
53415 ELSEIF(IH.EQ.2) THEN
53416 IF(IDU.EQ.1) THEN
53417 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
53418 & XMF**2/XMW*COSA/CBETA
53419 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53420 & XMF**2/XMW*COSA/CBETA
53421 IF(IFL.EQ.5) THEN
53422 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53423 & ATRIB*COSA)
53424 ELSEIF(IFL.EQ.15) THEN
53425 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53426 & ATRIL*COSA)
53427 ELSE
53428 GHLR=0D0
53429 ENDIF
53430 ELSE
53431 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
53432 & XMF**2/XMW*SINA/SBETA
53433 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53434 & XMF**2/XMW*SINA/SBETA
53435 IF(IFL.EQ.6) THEN
53436 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
53437 & ATRIT*SINA)
53438 ELSE
53439 GHLR=0D0
53440 ENDIF
53441 ENDIF
53442
53443 ELSEIF(IH.EQ.3) THEN
53444 GHLL=0D0
53445 GHRR=0D0
53446 GHLR=0D0
53447 IF(IDU.EQ.1) THEN
53448 IF(IFL.EQ.5) THEN
53449 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
53450 ELSEIF(IFL.EQ.15) THEN
53451 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
53452 ENDIF
53453 ELSE
53454 IF(IFL.EQ.6) THEN
53455 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
53456 ENDIF
53457 ENDIF
53458 ENDIF
53459 IF(IH.EQ.3) GOTO 180
53460
53461 AL=SFMIX(IFL,1)**2
53462 AR=SFMIX(IFL,2)**2
53463 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
53464 IF(IFL.LE.6) THEN
53465 CF=3D0
53466 ELSE
53467 CF=1D0
53468 ENDIF
53469
53470 IF(AXMI.GE.2D0*XMJ) THEN
53471 LKNT=LKNT+1
53472 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53473 & (GHLL*AL+GHRR*AR
53474 & +2D0*GHLR*ALR)**2
53475 IDLAM(LKNT,1)=IJ
53476 IDLAM(LKNT,2)=-IJ
53477 IDLAM(LKNT,3)=0
53478 ENDIF
53479
53480 IF(AXMI.GE.2D0*XMJR) THEN
53481 LKNT=LKNT+1
53482 AL=SFMIX(IFL,3)**2
53483 AR=SFMIX(IFL,4)**2
53484 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
53485 XMJ=XMJR
53486 XMJ2=XMJ**2
53487 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53488 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53489 & (GHLL*AL+GHRR*AR
53490 & +2D0*GHLR*ALR)**2
53491 IDLAM(LKNT,1)=IJ+KSUSY1
53492 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53493 IDLAM(LKNT,3)=0
53494 ENDIF
53495 180 CONTINUE
53496
53497 IF(AXMI.GE.XMJL+XMJR) THEN
53498 LKNT=LKNT+1
53499 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
53500 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
53501 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
53502 XMJ=XMJR
53503 XMJ2=XMJ**2
53504 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
53505 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53506 & (GHLL*AL+GHRR*AR)**2
53507 IDLAM(LKNT,1)=IJ
53508 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53509 IDLAM(LKNT,3)=0
53510 LKNT=LKNT+1
53511 IDLAM(LKNT,1)=-IJ
53512 IDLAM(LKNT,2)=IJ+KSUSY1
53513 IDLAM(LKNT,3)=0
53514 XLAM(LKNT)=XLAM(LKNT-1)
53515 ENDIF
53516 ENDIF
53517 190 CONTINUE
53518 200 CONTINUE
53519 210 CONTINUE
53520
53521 GOTO 270
53522 220 CONTINUE
53523
53524C...H+ -> CHI+_I + CHI0_J
53525 DO 240 IJ=1,4
53526 XMJ=SMZ(IJ)
53527 AXMJ=ABS(XMJ)
53528 XMJ2=XMJ**2
53529 DO 230 IK=1,2
53530 XMK=SMW(IK)
53531 AXMK=ABS(XMK)
53532 IF(AXMI.GE.AXMJ+AXMK) THEN
53533 LKNT=LKNT+1
53534 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
53535 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
53536 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
53537 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
53538 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53539 GLR=DBLE(OLPP*DCONJG(ORPP))
53540 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
53541 IDLAM(LKNT,1)=KFNCHI(IJ)
53542 IDLAM(LKNT,2)=KFCCHI(IK)
53543 IDLAM(LKNT,3)=0
53544 ENDIF
53545 230 CONTINUE
53546 240 CONTINUE
53547
53548 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
53549 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
53550 AL=0D0
53551 AR=0D0
53552 CF=3D0
53553
53554C...H+ -> T_1 B_1~
53555 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53556 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53557 IF(XMI.GE.XM1+XM2) THEN
53558 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53559 LKNT=LKNT+1
53560 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53561 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
53562 IDLAM(LKNT,1)=KSUSY1+6
53563 IDLAM(LKNT,2)=-(KSUSY1+5)
53564 IDLAM(LKNT,3)=0
53565 ENDIF
53566
53567C...H+ -> T_2 B_1~
53568 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53569 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53570 IF(XMI.GE.XM1+XM2) THEN
53571 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53572 LKNT=LKNT+1
53573 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53574 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
53575 IDLAM(LKNT,1)=KSUSY2+6
53576 IDLAM(LKNT,2)=-(KSUSY1+5)
53577 IDLAM(LKNT,3)=0
53578 ENDIF
53579
53580C...H+ -> T_1 B_2~
53581 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53582 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53583 IF(XMI.GE.XM1+XM2) THEN
53584 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53585 LKNT=LKNT+1
53586 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53587 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
53588 IDLAM(LKNT,1)=KSUSY1+6
53589 IDLAM(LKNT,2)=-(KSUSY2+5)
53590 IDLAM(LKNT,3)=0
53591 ENDIF
53592
53593C...H+ -> T_2 B_2~
53594 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53595 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53596 IF(XMI.GE.XM1+XM2) THEN
53597 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53598 LKNT=LKNT+1
53599 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53600 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
53601 IDLAM(LKNT,1)=KSUSY2+6
53602 IDLAM(LKNT,2)=-(KSUSY2+5)
53603 IDLAM(LKNT,3)=0
53604 ENDIF
53605
53606C...H+ -> UL DL~
53607 GL=-XMW/SR2*SIN(2D0*BETA)
53608 DO 250 IJ=1,3,2
53609 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53610 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53611 IF(XMI.GE.XM1+XM2) THEN
53612 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53613 LKNT=LKNT+1
53614 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53615 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53616 IDLAM(LKNT,2)=KSUSY1+IJ+1
53617 IDLAM(LKNT,3)=0
53618 ENDIF
53619 250 CONTINUE
53620
53621C...H+ -> EL~ NUL
53622 CF=1D0
53623 DO 260 IJ=11,13,2
53624 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53625 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53626 IF(XMI.GE.XM1+XM2) THEN
53627 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53628 LKNT=LKNT+1
53629 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53630 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53631 IDLAM(LKNT,2)=KSUSY1+IJ+1
53632 IDLAM(LKNT,3)=0
53633 ENDIF
53634 260 CONTINUE
53635
53636C...H+ -> TAU1 NUTAUL
53637 XM1=PMAS(PYCOMP(KSUSY1+15),1)
53638 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53639 IF(XMI.GE.XM1+XM2) THEN
53640 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53641 LKNT=LKNT+1
53642 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
53643 IDLAM(LKNT,1)=-(KSUSY1+15)
53644 IDLAM(LKNT,2)= KSUSY1+16
53645 IDLAM(LKNT,3)=0
53646 ENDIF
53647
53648C...H+ -> TAU2 NUTAUL
53649 XM1=PMAS(PYCOMP(KSUSY2+15),1)
53650 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53651 IF(XMI.GE.XM1+XM2) THEN
53652 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53653 LKNT=LKNT+1
53654 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
53655 IDLAM(LKNT,1)=-(KSUSY2+15)
53656 IDLAM(LKNT,2)= KSUSY1+16
53657 IDLAM(LKNT,3)=0
53658 ENDIF
53659
53660 270 CONTINUE
53661 IKNT=LKNT
53662 XLAM(0)=0D0
53663 DO 280 I=1,IKNT
53664 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
53665 XLAM(0)=XLAM(0)+XLAM(I)
53666 280 CONTINUE
53667 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53668
53669 RETURN
53670 END
53671
53672C*********************************************************************
53673
53674C...PYH2XX
53675C...Calculates the decay rate for a Higgs to an ino pair.
53676
53677 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
53678
53679C...Double precision and integer declarations.
53680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53681 IMPLICIT INTEGER(I-N)
53682 INTEGER PYK,PYCHGE,PYCOMP
53683C...Commonblocks.
53684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53685 SAVE /PYDAT1/
53686
53687C...Local variables.
53688 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53689 DOUBLE PRECISION XL,PYLAMF,C1
53690 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53691
53692 XMI2=XM1**2
53693 XMI3=ABS(XM1**3)
53694 XMJ2=XM2**2
53695 XMK2=XM3**2
53696 XL=PYLAMF(XMI2,XMJ2,XMK2)
53697 PYH2XX=C1/4D0/XMI3*SQRT(XL)
53698 &*(GX2*(XMI2-XMJ2-XMK2)-
53699 &4D0*GLR*XM3*XM2)
53700 IF(PYH2XX.LT.0D0) PYH2XX=0D0
53701
53702 RETURN
53703 END
53704
53705C*********************************************************************
53706
53707C...PYGAUS
53708C...Integration by adaptive Gaussian quadrature.
53709C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53710
53711 FUNCTION PYGAUS(F, A, B, EPS)
53712
53713C...Double precision and integer declarations.
53714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53715 IMPLICIT INTEGER(I-N)
53716 INTEGER PYK,PYCHGE,PYCOMP
53717
53718C...Local declarations.
53719 EXTERNAL F
53720 DOUBLE PRECISION F,W(12), X(12)
53721 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53722 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53723 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53724 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53725 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53726 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53727 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53728 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53729 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53730 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53731 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53732 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53733
53734C...The Gaussian quadrature algorithm.
53735 H = 0D0
53736 IF(B .EQ. A) GOTO 140
53737 CONST = 5D-3 / ABS(B-A)
53738 BB = A
53739 100 CONTINUE
53740 AA = BB
53741 BB = B
53742 110 CONTINUE
53743 C1 = 0.5D0*(BB+AA)
53744 C2 = 0.5D0*(BB-AA)
53745 S8 = 0D0
53746 DO 120 I = 1, 4
53747 U = C2*X(I)
53748 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53749 120 CONTINUE
53750 S16 = 0D0
53751 DO 130 I = 5, 12
53752 U = C2*X(I)
53753 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53754 130 CONTINUE
53755 S16 = C2*S16
53756 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53757 H = H + S16
53758 IF(BB .NE. B) GOTO 100
53759 ELSE
53760 BB = C1
53761 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53762 H = 0D0
53763 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
53764 GOTO 140
53765 ENDIF
53766 140 CONTINUE
53767 PYGAUS = H
53768
53769 RETURN
53770 END
53771
53772C*********************************************************************
53773
53774C...PYGAU2
53775C...Integration by adaptive Gaussian quadrature.
53776C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53777C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53778
53779 FUNCTION PYGAU2(F, A, B, EPS)
53780
53781C...Double precision and integer declarations.
53782 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53783 IMPLICIT INTEGER(I-N)
53784 INTEGER PYK,PYCHGE,PYCOMP
53785
53786C...Local declarations.
53787 EXTERNAL F
53788 DOUBLE PRECISION F,W(12), X(12)
53789 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53790 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53791 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53792 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53793 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53794 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53795 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53796 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53797 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53798 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53799 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53800 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53801
53802C...The Gaussian quadrature algorithm.
53803 H = 0D0
53804 IF(B .EQ. A) GOTO 140
53805 CONST = 5D-3 / ABS(B-A)
53806 BB = A
53807 100 CONTINUE
53808 AA = BB
53809 BB = B
53810 110 CONTINUE
53811 C1 = 0.5D0*(BB+AA)
53812 C2 = 0.5D0*(BB-AA)
53813 S8 = 0D0
53814 DO 120 I = 1, 4
53815 U = C2*X(I)
53816 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53817 120 CONTINUE
53818 S16 = 0D0
53819 DO 130 I = 5, 12
53820 U = C2*X(I)
53821 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53822 130 CONTINUE
53823 S16 = C2*S16
53824 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53825 H = H + S16
53826 IF(BB .NE. B) GOTO 100
53827 ELSE
53828 BB = C1
53829 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53830 H = 0D0
53831 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
53832 GOTO 140
53833 ENDIF
53834 140 CONTINUE
53835 PYGAU2 = H
53836
53837 RETURN
53838 END
53839
53840C*********************************************************************
53841
53842C...PYSIMP
53843C...Simpson formula for an integral.
53844
53845 FUNCTION PYSIMP(Y,X0,X1,N)
53846
53847C...Double precision and integer declarations.
53848 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53849 IMPLICIT INTEGER(I-N)
53850 INTEGER PYK,PYCHGE,PYCOMP
53851
53852C...Local variables.
53853 DOUBLE PRECISION Y,X0,X1,H,S
53854 DIMENSION Y(0:N)
53855
53856 S=0D0
53857 H=(X1-X0)/N
53858 DO 100 I=0,N-2,2
53859 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
53860 100 CONTINUE
53861 PYSIMP=S*H/3D0
53862
53863 RETURN
53864 END
53865
53866C*********************************************************************
53867
53868C...PYLAMF
53869C...The standard lambda function.
53870
53871 FUNCTION PYLAMF(X,Y,Z)
53872
53873C...Double precision and integer declarations.
53874 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53875 IMPLICIT INTEGER(I-N)
53876 INTEGER PYK,PYCHGE,PYCOMP
53877
53878C...Local variables.
53879 DOUBLE PRECISION PYLAMF,X,Y,Z
53880
53881 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
53882 IF(PYLAMF.LT.0D0) PYLAMF=0D0
53883
53884 RETURN
53885 END
53886
53887C*********************************************************************
53888
53889C...PYTBDY
53890C...Generates 3-body decays of gauginos.
53891
53892 SUBROUTINE PYTBDY(IDIN)
53893
53894C...Double precision and integer declarations.
53895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53896 IMPLICIT INTEGER(I-N)
53897 INTEGER PYK,PYCHGE,PYCOMP
53898C...Parameter statement to help give large particle numbers.
53899 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53900 &KEXCIT=4000000,KDIMEN=5000000)
53901C...Commonblocks.
53902 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53903 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53904 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53905C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53906C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53907 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53908 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53909C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53910 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
53911
53912C...Local variables.
53913 DOUBLE PRECISION XM(5)
53914 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53915 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53916 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53917 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53918 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53919 DOUBLE PRECISION CPHI1,SPHI1
53920 DOUBLE PRECISION S23DEL,EPS
53921 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53922 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
53923 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53924 INTEGER INOID(4)
53925 DATA INOID/22,23,25,35/
53926 DATA EPS/1D-6/
53927
53928 ID=IDIN
53929 ISKIP=1
53930 XM(1)=P(N+1,5)
53931 XM(2)=P(N+2,5)
53932 XM(3)=P(N+3,5)
53933 XM(5)=P(ID,5)
53934
53935C...GENERATE S12
53936 S12MIN=(XM(1)+XM(2))**2
53937 S12MAX=(XM(5)-XM(3))**2
53938 YJACO1=S12MAX-S12MIN
53939
53940C...Initialize some parameters
53941 XW=PARU(102)
53942 XW1=1D0-XW
53943 TANW=SQRT(XW/XW1)
53944 IZID1=0
53945 IWID1=0
53946 IZID2=0
53947 IWID2=0
53948
53949 IA=K(N+2,2)
53950 JA=K(N+3,2)
53951
53952C...Mrenna: check that we are indeed decaying a SUSY particle
53953 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
53954
53955 ELSE
53956 DO 100 I1=1,4
53957 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
53958 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
53959 100 CONTINUE
53960 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
53961 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
53962 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
53963 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
53964 ZM12=XM(5)**2
53965 ZM22=XM(1)**2
53966 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53967 T3I=SIGN(1D0,EI+1D-6)/2D0
53968 ENDIF
53969
53970 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53971 ISKIP=0
53972 ELSEIF(IZID1*IZID2.NE.0) THEN
53973 SQMZ=PMAS(23,1)**2
53974 GMMZ=PMAS(23,1)*PMAS(23,2)
53975 DO 110 I=1,4
53976 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53977 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53978 110 CONTINUE
53979 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53980 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53981 ORPP=DCONJG(OLPP)
53982 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53983 XLR2=XLL2
53984 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53985 XRL2=XRR2
53986 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53987 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53988 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53989 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53990 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53991 QLLU=-GLIJ
53992 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53993 QLRT=DCONJG(GLIJ)
53994 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53995 QRLT=GRIJ
53996 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53997 QRRU=-DCONJG(GRIJ)
53998 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53999 IF(IZID1.NE.0) THEN
54000 XM1M2=SMZ(IZID1)*SMW(IWID2)
54001 IZID1=IWID2
54002 IZID2=IZID1
54003 ELSE
54004 XM1M2=SMZ(IZID2)*SMW(IWID1)
54005 IZID1=IWID1
54006 ENDIF
54007 RT2I = 1D0/SQRT(2D0)
54008 SQMZ=PMAS(24,1)**2
54009 GMMZ=PMAS(24,1)*PMAS(24,2)
54010 DO 120 I=1,2
54011 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54012 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54013 120 CONTINUE
54014 DO 130 I=1,4
54015 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54016 130 CONTINUE
54017 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54018 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54019 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54020 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54021 EJ=KCHG(IABS(JA),1)/3D0
54022 T3J=SIGN(1D0,EJ+1D-6)/2D0
54023 QRLS=DCMPLX(0D0,0D0)
54024 QRLT=QRLS
54025 QRRS=QRLS
54026 QRRU=QRLS
54027 XRR2=1D6**2
54028 XRL2=XRR2
54029 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54030 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54031 IF(MOD(IA,2).EQ.0) THEN
54032 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54033 & TANW+ZMIXC(IZID2,2)*T3I)
54034 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54035 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54036 ELSE
54037 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54038 & TANW+ZMIXC(IZID2,2)*T3J)
54039 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54040 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54041 ENDIF
54042 ELSEIF(IWID1*IWID2.NE.0) THEN
54043 IZID1=IWID1
54044 IZID2=IWID2
54045 XM1M2=SMW(IWID1)*SMW(IWID2)
54046 SQMZ=PMAS(23,1)**2
54047 GMMZ=PMAS(23,1)*PMAS(23,2)
54048 DO 140 I=1,2
54049 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54050 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54051 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54052 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54053 140 CONTINUE
54054 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54055 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54056 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54057 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54058 QRLS=-DCMPLX(EI/XW1)*ORPP
54059 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54060 QRRS=-DCMPLX(EI/XW1)*OLPP
54061 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54062 IF(MOD(IA,2).EQ.0) THEN
54063 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54064 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54065 ELSE
54066 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54067 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54068 ENDIF
54069 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54070 &THEN
54071 ISKIP=0
54072 ELSE
54073 ISKIP=0
54074 ENDIF
54075
54076 IF(ISKIP.NE.0) THEN
54077 WTMAX=0D0
54078 DO 160 KT=1,100
54079 S12=S12MIN+YJACO1*(KT-1)/99
54080 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54081 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54082 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54083 & -(2D0*XM(1)*XM(2))**2
54084 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54085 & -(2D0*XM(3)*XM(5))**2
54086 S23DF1=S23DF1*EPS
54087 S23DF2=S23DF2*EPS
54088 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54089 S23DEL=S23DEL/EPS
54090 S23MIN=S23AVE-S23DEL
54091 S23MAX=S23AVE+S23DEL
54092 YJACO2=S23MAX-S23MIN
54093 TH=S12
54094 DO 150 KS=1,100
54095 S23=S23MIN+YJACO2*(KS-1)/99
54096 SH=S23
54097 UH=ZM12+ZM22-SH-TH
54098 WU2 = (UH-ZM12)*(UH-ZM22)
54099 WT2 = (TH-ZM12)*(TH-ZM22)
54100 WS2 = XM1M2*SH
54101 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54102 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54103 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54104 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54105 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54106 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54107 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54108 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54109 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54110 IF(WT0.GT.WTMAX) WTMAX=WT0
54111 150 CONTINUE
54112 160 CONTINUE
54113
54114 WTMAX=WTMAX*1.05D0
54115 ENDIF
54116
54117C...FIND S12*
54118 AX=S12MIN
54119 CX=S12MAX
54120 BX=S12MIN+0.5D0*YJACO1
54121 X0=AX
54122 X3=CX
54123 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54124 X1=BX
54125 X2=BX+C*(CX-BX)
54126 ELSE
54127 X2=BX
54128 X1=BX-C*(BX-AX)
54129 ENDIF
54130
54131C...SOLVE FOR F1 AND F2
54132 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54133 &-(2D0*XM(1)*XM(2))**2
54134 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54135 &-(2D0*XM(3)*XM(5))**2
54136 S23DF1=S23DF1*EPS
54137 S23DF2=S23DF2*EPS
54138 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54139 F1=-2D0*S23DEL/EPS
54140 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54141 &-(2D0*XM(1)*XM(2))**2
54142 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54143 &-(2D0*XM(3)*XM(5))**2
54144 S23DF1=S23DF1*EPS
54145 S23DF2=S23DF2*EPS
54146 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54147 F2=-2D0*S23DEL/EPS
54148
54149 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54150C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54151 IF(F2.LE.F1)THEN
54152 X0=X1
54153 X1=X2
54154 X2=R*X1+C*X3
54155 F1=F2
54156 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54157 & -(2D0*XM(1)*XM(2))**2
54158 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54159 & -(2D0*XM(3)*XM(5))**2
54160 S23DF1=S23DF1*EPS
54161 S23DF2=S23DF2*EPS
54162 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54163 F2=-2D0*S23DEL/EPS
54164 ELSE
54165 X3=X2
54166 X2=X1
54167 X1=R*X2+C*X0
54168 F2=F1
54169 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54170 & -(2D0*XM(1)*XM(2))**2
54171 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54172 & -(2D0*XM(3)*XM(5))**2
54173 S23DF1=S23DF1*EPS
54174 S23DF2=S23DF2*EPS
54175 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54176 F1=-2D0*S23DEL/EPS
54177 ENDIF
54178 GOTO 170
54179 ENDIF
54180C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54181 IF(F1.LT.F2)THEN
54182 GOLDEN=-F1
54183 XMIN=X1
54184 ELSE
54185 GOLDEN=-F2
54186 XMIN=X2
54187 ENDIF
54188
54189 IKNT=0
54190 180 S12=S12MIN+PYR(0)*YJACO1
54191 IKNT=IKNT+1
54192C...GENERATE S23
54193 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54194 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54195 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54196 &-(2D0*XM(1)*XM(2))**2
54197 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54198 &-(2D0*XM(3)*XM(5))**2
54199 S23DF1=S23DF1*EPS
54200 S23DF2=S23DF2*EPS
54201 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54202 S23DEL=S23DEL/EPS
54203 S23MIN=S23AVE-S23DEL
54204 S23MAX=S23AVE+S23DEL
54205 YJACO2=S23MAX-S23MIN
54206 S23=S23MIN+PYR(0)*YJACO2
54207
54208C...CHECK THE SAMPLING
54209 IF(IKNT.GT.100) THEN
54210 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
54211 GOTO 190
54212 ENDIF
54213 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
54214
54215 IF(ISKIP.EQ.0) GOTO 190
54216
54217 SH=S23
54218 TH=S12
54219 UH=ZM12+ZM22-SH-TH
54220
54221 WU2 = (UH-ZM12)*(UH-ZM22)
54222 WT2 = (TH-ZM12)*(TH-ZM22)
54223 WS2 = XM1M2*SH
54224 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54225 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54226
54227 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54228 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54229 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54230 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54231c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54232c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54233c &/DCMPLX(TH-XML2)
54234c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54235c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54236c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54237 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54238 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
54239 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54240
54241 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
54242 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
54243
54244 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
54245 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
54246 D2=XM(5)-D1-D3
54247 P1=SQRT(D1*D1-XM(1)**2)
54248 P2=SQRT(D2*D2-XM(2)**2)
54249 P3=SQRT(D3*D3-XM(3)**2)
54250 CTHE1=2D0*PYR(0)-1D0
54251 ANG1=2D0*PYR(0)*PARU(1)
54252 CPHI1=COS(ANG1)
54253 SPHI1=SIN(ANG1)
54254 ARG=1D0-CTHE1**2
54255 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54256 STHE1=SQRT(ARG)
54257 P(N+1,1)=P1*STHE1*CPHI1
54258 P(N+1,2)=P1*STHE1*SPHI1
54259 P(N+1,3)=P1*CTHE1
54260 P(N+1,4)=D1
54261
54262C...GET CPHI3
54263 ANG3=2D0*PYR(0)*PARU(1)
54264 CPHI3=COS(ANG3)
54265 SPHI3=SIN(ANG3)
54266 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
54267 ARG=1D0-CTHE3**2
54268 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54269 STHE3=SQRT(ARG)
54270 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
54271 &+P3*STHE3*SPHI3*SPHI1
54272 &+P3*CTHE3*STHE1*CPHI1
54273 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
54274 &-P3*STHE3*SPHI3*CPHI1
54275 &+P3*CTHE3*STHE1*SPHI1
54276 P(N+3,3)=P3*STHE3*CPHI3*STHE1
54277 &+P3*CTHE3*CTHE1
54278 P(N+3,4)=D3
54279
54280 DO 200 I=1,3
54281 P(N+2,I)=-P(N+1,I)-P(N+3,I)
54282 200 CONTINUE
54283 P(N+2,4)=D2
54284
54285 RETURN
54286 END
54287
54288
54289C*********************************************************************
54290
54291C...PYTECM
54292C...Finds the s-hat dependent eigenvalues of the inverse propagator
54293C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54294C...phase space generation. Extended to include techni-a meson, and
54295C...to return the width.
54296
54297 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
54298
54299C...Double precision and integer declarations.
54300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54301 IMPLICIT INTEGER(I-N)
54302 INTEGER PYK,PYCHGE,PYCOMP
54303C...Parameter statement to help give large particle numbers.
54304 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54305 &KEXCIT=4000000,KDIMEN=5000000)
54306C...Commonblocks.
54307 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54308 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54309 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54310 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54311 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
54312
54313C...Local variables.
54314 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54315 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
54316 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
54317 INTEGER i,j,ierr
54318
54319 SH=SMIN
54320 SHR=SQRT(SH)
54321 AEM=PYALEM(SH)
54322
54323 SINW=MIN(SQRT(PARU(102)),1D0)
54324 COSW=SQRT(1D0-SINW**2)
54325 TANW=SINW/COSW
54326 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
54327 QUPD=2D0*RTCM(2)-1D0
54328
54329 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
54330 FAR=SQRT(AEM/ALPRHT)
54331 FAO=FAR*QUPD
54332 FZR=FAR*CT2W
54333 FZO=-FAO*TANW
54334 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
54335 FWR=FAR/(2D0*SINW)
54336 FWX=-FWR/RTCM(47)
54337
54338 DO 110 I=1,5
54339 DO 100 J=1,5
54340 AT(I,J)=0D0
54341 100 CONTINUE
54342 110 CONTINUE
54343
54344C...NC
54345 IF(IOPT.EQ.1) THEN
54346 AR(1,1) = SH
54347 AR(2,2) = SH-PMAS(23,1)**2
54348 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
54349 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
54350 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
54351 AR(1,2) = 0D0
54352 AR(2,1) = 0D0
54353 AR(1,3) = SH*FAR
54354 AR(3,1) = AR(1,3)
54355 AR(1,4) = SH*FAO
54356 AR(4,1) = AR(1,4)
54357 AR(2,3) = SH*FZR
54358 AR(3,2) = AR(2,3)
54359 AR(2,4) = SH*FZO
54360 AR(4,2) = AR(2,4)
54361 AR(3,4) = 0D0
54362 AR(4,3) = 0D0
54363 AR(2,5) = SH*FZX
54364 AR(5,2) = AR(2,5)
54365 AR(1,5) = 0D0
54366 AR(5,1) = AR(1,5)
54367 AR(3,5) = 0D0
54368 AR(5,3) = AR(3,5)
54369 AR(4,5) = 0D0
54370 AR(5,4) = AR(4,5)
54371 CALL PYWIDT(23,SH,WDTP,WDTE)
54372 AT(2,2) = WDTP(0)*SHR
54373 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
54374 AT(3,3) = WDTP(0)*SHR
54375 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
54376 AT(4,4) = WDTP(0)*SHR
54377 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
54378 AT(5,5) = WDTP(0)*SHR
54379 IDIM=5
54380C...CC
54381 ELSE
54382 AR(1,1) = SH-PMAS(24,1)**2
54383 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
54384 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
54385 AR(1,2) = SH*FWR
54386 AR(2,1) = AR(1,2)
54387 AR(1,3) = SH*FWX
54388 AR(3,1) = AR(1,3)
54389 AR(2,3) = 0D0
54390 AR(3,2) = 0D0
54391 CALL PYWIDT(24,SH,WDTP,WDTE)
54392 AT(1,1) = WDTP(0)*SHR
54393 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
54394 AT(2,2) = WDTP(0)*SHR
54395 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
54396 AT(3,3) = WDTP(0)*SHR
54397 IDIM=3
54398 ENDIF
54399 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
54400
54401 IMIN=1
54402 SXMN=1D20
54403 DO 120 I=1,IDIM
54404 WX(I)=SQRT(ABS(SH-WR(I)))
54405 WR(I)=ABS(WR(I))
54406 IF(WR(I).LT.SXMN) THEN
54407 SXMN=WR(I)
54408 IMIN=I
54409 ENDIF
54410 120 CONTINUE
54411 SMOU=WX(IMIN)**2
54412 WIDO=WI(IMIN)/SHR
54413
54414 RETURN
54415 END
54416C*********************************************************************
54417
54418C...PYXDIN
54419C...Universal Extra Dimensions Model (UED)
54420C...Initialize the xd masses and widths
54421C...M. ELKACIMI 4/03/2006
54422C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54423
54424 SUBROUTINE PYXDIN
54425
54426C...Double precision and integer declarations.
54427 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54428 IMPLICIT INTEGER(I-N)
54429 INTEGER PYK,PYCHGE,PYCOMP
54430C...Commonblocks.
54431 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54432 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54433 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54434C...UED Pythia common
54435 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54436
54437C...SAVE statements
54438 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
54439
54440C...Print out some info about the UED model
54441 WRITE(MSTU(11),7000)
54442 & ' ',
54443 & '********** PYXDIN: initialization of UED ******************',
54444 & ' ',
54445 & 'Universal Extra Dimensions (UED) switched on ',
54446 & ' ',
54447 & 'This implementation is courtesy of',
54448 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54449 & ' see [hep-ph/0602198] (Les Houches 2005) ',
54450 & ' ',
54451 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54452 & 'Dobrescu), with gravity-mediated decay widths calculated in',
54453 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54454 & 'radiative corrections to the KK masses from [hep/ph0204342]',
54455 & '(Cheng, Matchev, Schmaltz).'
54456 WRITE(MSTU(11),7000)
54457 & ' ',
54458 & 'SM particles can propagate into one small extra dimension ',
54459 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54460 & 'graviton is further allowed to propagate into N = IUED(4)',
54461 & 'large (eV^-1) extra dimensions.'
54462 WRITE(MSTU(11),7000)
54463 & ' ',
54464 & 'The switches and parameters for UED are:',
54465 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54466 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54467 & ' IUED(3): (D=5) number of quark flavours',
54468 & ' IUED(4): (D=6) number of large extra dimensions into',
54469 & ' which the graviton propagates',
54470 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54471 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54472 & ' ',
54473 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54474 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54475 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54476 & ' when IUED(5)=0',
54477 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54478 WRITE(MSTU(11),7000)
54479 & ' ',
54480 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54481 & 'model, but is set through pmas(25,1).',
54482 & ' '
54483
54484C...Hardcoded switch, required by current implementation
54485 CALL PYGIVE('MSTP(42)=0')
54486
54487C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54488 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
54489
54490C...Calculated the radiative corrections to the KK particle masses
54491 CALL PYUEDC
54492
54493C...Initialize the graviton mass
54494C...only if the KK particles decays gravitationally
54495 IF(IUED(2).EQ.1) CALL PYGRAM(0)
54496
54497 WRITE(MSTU(11),7000)
54498 & '********** PYXDIN: UED initialization completed ***********'
54499
54500C...Format to use for comments
54501 7000 FORMAT(' * ',A)
54502
54503 RETURN
54504 END
54505C*********************************************************************
54506
54507C...PYUEDC
54508C...Auxiliary to PYXDIN
54509C...Mass kk states radiative corrections
54510C...Radiative corrections are included (hep/ph0204342)
54511
54512 SUBROUTINE PYUEDC
54513
54514C...Double precision and integer declarations.
54515 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54516 IMPLICIT INTEGER(I-N)
54517 INTEGER PYK,PYCHGE,PYCOMP
54518
54519 PARAMETER(KKPART=25,KKFLA=450)
54520
54521C...UED Pythia common
54522 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54523C...Pythia common: particles properties
54524 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54525C...Parameters.
54526 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54527C...Decay information.
54528 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54529C...Resonance width and secondary decay treatment.
54530 COMMON/PYINT4/MWID(500),WIDS(500,5)
54531 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54532
54533C...Local variables
54534 DOUBLE PRECISION PI,QUP,QDW
54535 DOUBLE PRECISION WDTP,WDTE
54536 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54537 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54538 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54539 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54540 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54541 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54542 DOUBLE PRECISION SWW1,CWW1
54543 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54544 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54545 DOUBLE PRECISION SW21,CW21,SW021,CW021
54546 COMMON/SW1/SW021,CW021
54547C...UED related declarations:
54548C...equivalences between ordered particles (451->475)
54549C...and UED particle code (5 000 000 + id)
54550 DIMENSION IUEDEQ(475)
54551 DATA (IUEDEQ(I),I=451,475)/
54552C...Singlet quarks
54553 & 6100001,6100002,6100003,6100004,6100005,6100006,
54554C...Doublet quarks
54555 & 5100001,5100002,5100003,5100004,5100005,5100006,
54556C...Singlet leptons
54557 & 6100011,6100013,6100015,
54558C...Doublet leptons
54559 & 5100012,5100011,5100014,5100013,5100016,5100015,
54560C...Gauge boson KK excitations
54561 & 5100021,5100022,5100023,5100024/
54562
54563C...N.B. rinv=rued(1)
54564 IF(RUED(1).LE.0.)THEN
54565 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
54566 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54567 RETURN
54568 ENDIF
54569
54570 PI=DACOS(-1.D0)
54571 RMZ = PMAS(23,1)
54572 RMZ2 = RMZ**2
54573 RMW = PMAS(24,1)
54574 RMW2 = RMW**2
54575 ALPHEM = PARU(101)
54576 QUP = 2./3.
54577 QDW = -1./3.
54578
54579c...qt is q-tilde, qs is q-star
54580c...strong coupling value
54581 Q2 = RUED(1)**2
54582 ALPHS=PYALPS(Q2)
54583
54584c...weak mixing angle
54585 SW2=PARU(102)
54586 CW2=1D0-PARU(102)
54587
54588c...for the mass corrections
54589 RMKK = RUED(1)
54590 RMKK2 = RMKK**2
54591 ZETA3= 1.2
54592
54593C... Either fix the cutoff scale LAMUED
54594 IF(IUED(5).EQ.0)THEN
54595 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
54596C... or the ratio LAMUED/RINV (=product Lambda*R)
54597 ELSEIF(IUED(5).EQ.1)THEN
54598 LOGLAM = DLOG(RUED(4)**2)
54599 ELSE
54600 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54601 CALL PYSTOP(6000)
54602 ENDIF
54603
54604C...Calculate the radiative corrections for the UED KK masses
54605 IF(IUED(6).EQ.1)THEN
54606 RFACT=1.D0
54607C...or induce a minute mass difference
54608C...keeping the UED KK mass values nearly equal to 1/R
54609 ELSEIF(IUED(6).EQ.0)THEN
54610 RFACT=0.01D0
54611 ELSE
54612 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54613 CALL PYSTOP(6001)
54614 ENDIF
54615
54616c...Take into account only the strong interactions:
54617
54618c...The space bulk corrections :
54619 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
54620c...The boundary terms:
54621 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
54622
54623c...Mass corrections for fermions are extracted from
54624c...Phys. Rev. D66 036005(2002)9
54625 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
54626 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
54627 DBMQU=RMKK*(3.*(ALPHS/4./PI)
54628 . +(ALPHEM/4./PI/CW2))*LOGLAM
54629 DBMQD=RMKK*(3.*(ALPHS/4./PI)
54630 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
54631
54632 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
54633 . (ALPHEM/4./PI/CW2))*LOGLAM
54634 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
54635
54636c...Vector boson masss matrix diagonalization
54637 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
54638 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
54639 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
54640 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
54641
54642c...Elements of the mass matrix
54643 A = RMZ2*SW2 + DBMB2 + DSMB2
54644 B = RMZ2*CW2 + DBMA2 + DSMA2
54645 C = RMZ2*DSQRT(SW2*CW2)
54646 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
54647
54648c...Eigenvalues: corrections to X1 and Z1 masses
54649 DMB2 = (A+B-SQRDEL)/2.
54650 DMA2 = (A+B+SQRDEL)/2.
54651
54652c...Rotation angles
54653 SWW1 = 2*C
54654 CWW1 = A-B-SQRDEL
54655C...Weinberg angle
54656 SW21= SWW1**2/(SWW1**2 + CWW1**2)
54657 CW21= 1. - SW21
54658
54659 SW021=SW21
54660 CW021=CW21
54661
54662c...Masses:
54663 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
54664
54665 RMDQST=RMKK+RFACT*DBMQDO
54666 RMSQUS=RMKK+RFACT*DBMQU
54667 RMSQDS=RMKK+RFACT*DBMQD
54668
54669C...Note: MZ mass is included in ma2
54670 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
54671 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
54672 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
54673
54674 RMLSLD=RMKK+RFACT*DBMLDO
54675 RMLSLE=RMKK+RFACT*DBMLE
54676
54677 DO 100 IPART=1,5,2
54678 PMAS(KKFLA+IPART,1)=RMSQDS
54679 100 CONTINUE
54680 DO 110 IPART=2,6,2
54681 PMAS(KKFLA+IPART,1)=RMSQUS
54682 110 CONTINUE
54683 DO 120 IPART=7,12
54684 PMAS(KKFLA+IPART,1)=RMDQST
54685 120 CONTINUE
54686 DO 130 IPART=13,15
54687 PMAS(KKFLA+IPART,1)=RMLSLE
54688 130 CONTINUE
54689 DO 140 IPART=16,21
54690 PMAS(KKFLA+IPART,1)=RMLSLD
54691 140 CONTINUE
54692 PMAS(KKFLA+22,1)=RMGST
54693 PMAS(KKFLA+23,1)=RMPHST
54694 PMAS(KKFLA+24,1)=RMZST
54695 PMAS(KKFLA+25,1)=RMWST
54696
54697 WRITE(MSTU(11),7000) ' PYUEDC: ',
54698 & 'UED Mass Spectrum (GeV) :'
54699 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
54700 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
54701 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
54702 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
54703 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
54704 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
54705 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
54706 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
54707 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
54708 WRITE(MSTU(11),7000) ' '
54709
54710C...Initialize widths, branching ratios and life time
54711 DO 199 IPART=1,25
54712 KC=KKFLA+IPART
54713 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
54714 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
54715 IF(WDTP(0).LE.0)THEN
54716 WRITE(MSTU(11),*)
54717 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
54718 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
54719 GOTO 199
54720 ELSE
54721 DO 180 IDC=1,MDCY(KC,3)
54722 IC=IDC+MDCY(KC,2)-1
54723 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
54724C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54725 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
54726 BRAT(IC)=WDTP(IDC)/WDTP(0)
54727 ENDIF
54728 180 CONTINUE
54729 ENDIF
54730 ENDIF
54731 199 CONTINUE
54732
54733C...Format to use for comments
54734 7000 FORMAT(' * ',A)
54735 7100 FORMAT(' * ',A,F12.3)
54736
54737 END
54738C********************************************************************
54739C...PYXUED
54740C... Last change:
54741C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54742C... Original version:
54743C... M. El Kacimi
54744C... 05/07/2005
54745C Universal Extra Dimensions Subprocess cross sections
54746C The expressions used are from atl-com-phys-2005-003
54747C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54748C For each UED subprocess, the color flow used is the same
54749C as the equivalent QCD subprocess. Different configuration
54750C color flows are considered to have the same probability.
54751C
54752C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54753C by G.Azuelos and P.H.Beauchemin.
54754C
54755C This routine is called from pysigh.
54756
54757 SUBROUTINE PYXUED(NCHN,SIGS)
54758
54759C...Double precision and integer declarations
54760 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54761 IMPLICIT INTEGER(I-N)
54762C...
54763 INTEGER NGRDEC
54764 COMMON/DECMOD/NGRDEC
54765C...
54766 PARAMETER(KKPART=25,KKFLA=450)
54767C...Commonblocks
54768 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54769 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54770 COMMON/PYINT1/MINT(400),VINT(400)
54771 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
54772 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
54773 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
54774 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
54775 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
54776 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
54777C...UED Pythia common
54778 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54779C...Local arrays and complex variables
54780 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54781 + ,FAC1,XMNKK,XMUED,SIGS
54782 INTEGER NCHN
54783
54784C...Return if UED not switched on
54785 IF (IUED(1).LE.0) THEN
54786 RETURN
54787 ENDIF
54788
54789C...Energy scale of the parton processus
54790C...taken equal to the mass of the final state kk
54791c Q2=XMNKK**2
54792
54793C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54794 XMNKK=PMAS(KKFLA+23,1)
54795
54796C...To compare the cross section with phys-pub-2005-03
54797C...(no radiative corrections),
54798C...take xmnkk=rinv and q2=rinv**2
54799c++lnk
54800C...n.b. (rinv=rued(1))
54801c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54802 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
54803c--lnk
54804
54805 SHAT=VINT(44)
54806 SP=SHAT
54807 THAT=VINT(45)
54808 TP=THAT-XMNKK**2
54809 UHAT=VINT(46)
54810 UP=UHAT-XMNKK**2
54811 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
54812 PI=DACOS(-1.D0)
54813c++lnk
54814c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54815 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
54816
54817c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54818 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
54819c--lnk
54820
54821C...Strong coupling value
54822 ALPHAS=PYALPS(Q2)
54823
54824 IF(ISUB.EQ.311)THEN
54825C...gg --> g* g*
54826 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
54827 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
54828 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
54829 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
54830 & 12.*TP**2*UP**3+6*TP*UP**4)
54831 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
54832 & 15.*TP**3*UP**3+13*TP**2*UP**4+
54833 & 6.*TP*UP**5+2.*UP**6)
54834 NCHN=NCHN+1
54835 ISIG(NCHN,1)=21
54836 ISIG(NCHN,2)=21
54837C...Three color flow configurations (qcd g+g->g+g)
54838 XCOL=PYR(0)
54839 IF(XCOL.LE.1./3.)THEN
54840 ISIG(NCHN,3)=1
54841 ELSEIF(XCOL.LE.2./3.)THEN
54842 ISIG(NCHN,3)=2
54843 ELSE
54844 ISIG(NCHN,3)=3
54845 ENDIF
54846 SIGH(NCHN)=COMFAC*XMUED
54847 ELSEIF(ISUB.EQ.312)THEN
54848C...q + g -> q*_D + g*, q*_S + g*
54849C...(the two channels have the same cross section)
54850 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
54851 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
54852 & 5.*SP**4*UP**2+12.*SP**5*UP)
54853 XMUED=COMFAC*2.*XMUED
54854
54855 DO 190 I=MMINA,MMAXA
54856 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
54857 DO 180 ISDE=1,2
54858
54859 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
54860 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
54861 NCHN=NCHN+1
54862 ISIG(NCHN,ISDE)=I
54863 ISIG(NCHN,3-ISDE)=21
54864 ISIG(NCHN,3)=1
54865 SIGH(NCHN)=XMUED
54866 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54867 180 CONTINUE
54868 190 CONTINUE
54869
54870 ELSEIF(ISUB.EQ.313)THEN
54871C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54872C...(the two channels have the same cross section)
54873C...qi and qj have the same charge sign
54874 DO 100 I=MMIN1,MMAX1
54875 IA=IABS(I)
54876 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
54877 DO 101 J=MMIN2,MMAX2
54878 JA=IABS(J)
54879 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
54880 & EQ.0) GOTO 101
54881 IF(J*I.LE.0)GOTO 101
54882 NCHN=NCHN+1
54883 ISIG(NCHN,1)=I
54884 ISIG(NCHN,2)=J
54885 IF(J.EQ.I)THEN
54886 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
54887 XMUED=FAC1*
54888 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
54889 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
54890 & 20.*TP**2*UP**2+56./3.*
54891 & TP*UP**3+8.*UP**4)
54892 SIGH(NCHN)=COMFAC*2.*XMUED
54893 ISIG(NCHN,3)=1
54894 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54895 ELSE
54896 FAC1=2./9.*ALPHAS**2/TP**2
54897 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54898 SIGH(NCHN)=COMFAC*2.*XMUED
54899 ISIG(NCHN,3)=1
54900 ENDIF
54901 101 CONTINUE
54902 100 CONTINUE
54903 ELSEIF(ISUB.EQ.314)THEN
54904C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54905C...(the two channels have the same cross section)
54906 NCHN=NCHN+1
54907 ISIG(NCHN,1)=21
54908 ISIG(NCHN,2)=21
54909 ISIG(NCHN,3)=INT(1.5+PYR(0))
54910
54911 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
54912 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
54913 + +4.*UP**4+4*TP**4)
54914 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
54915 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
54916 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
54917
54918 SIGH(NCHN)=COMFAC*XMUED
54919C...has been multiplied by 5: all possible quark flavors in final state
54920
54921 ELSEIF(ISUB.EQ.315)THEN
54922C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54923C...(the two channels have the same cross section)
54924 DO 141 I=MMIN1,MMAX1
54925 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
54926 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
54927 DO 142 J=MMIN2,MMAX2
54928 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
54929 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
54930 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
54931 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
54932 & 2./3.*SP**3*TP+SP**4)
54933 NCHN=NCHN+1
54934 ISIG(NCHN,1)=I
54935 ISIG(NCHN,2)=-I
54936 ISIG(NCHN,3)=1
54937 SIGH(NCHN)=COMFAC*2.*XMUED
54938 142 CONTINUE
54939 141 CONTINUE
54940 ELSEIF(ISUB.EQ.316)THEN
54941C...q + qbar' -> q*_D + q*_Sbar'
54942 FAC1=2./9.*ALPHAS**2
54943 DO 300 I=MMIN1,MMAX1
54944 IA=IABS(I)
54945 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
54946 DO 301 J=MMIN2,MMAX2
54947 JA=IABS(J)
54948 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
54949 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
54950 NCHN=NCHN+1
54951 ISIG(NCHN,1)=I
54952 ISIG(NCHN,2)=J
54953 ISIG(NCHN,3)=1
54954 FAC1=2./9.*ALPHAS**2/TP**2
54955 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54956 SIGH(NCHN)=COMFAC*XMUED
54957 301 CONTINUE
54958 300 CONTINUE
54959
54960 ELSEIF(ISUB.EQ.317)THEN
54961C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54962C...(the two channels have the same cross section)
54963 DO 400 I=MMIN1,MMAX1
54964 IA=IABS(I)
54965 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
54966 DO 401 J=MMIN1,MMAX1
54967 JA=IABS(J)
54968 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
54969 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
54970 NCHN=NCHN+1
54971 ISIG(NCHN,1)=I
54972 ISIG(NCHN,2)=J
54973 ISIG(NCHN,3)=1
54974 FAC1=1./18.*ALPHAS**2/TP**2
54975 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
54976 SIGH(NCHN)=COMFAC*2.*XMUED
54977 401 CONTINUE
54978 400 CONTINUE
54979 ELSEIF(ISUB.EQ.318)THEN
54980C...q + q' -> q*_D + q*_S'
54981 DO 500 I=MMIN1,MMAX1
54982 IA=IABS(I)
54983 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
54984 DO 501 J=MMIN2,MMAX2
54985 JA=IABS(J)
54986 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
54987 IF(J*I.LE.0)GOTO 501
54988 IF(IA.EQ.JA)THEN
54989 NCHN=NCHN+1
54990 ISIG(NCHN,1)=I
54991 ISIG(NCHN,2)=J
54992 ISIG(NCHN,3)=INT(1.5+PYR(0))
54993 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
54994 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
54995 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
54996 SIGH(NCHN)=COMFAC*XMUED
54997 ELSE
54998 NCHN=NCHN+1
54999 ISIG(NCHN,1)=I
55000 ISIG(NCHN,2)=J
55001 ISIG(NCHN,3)=1
55002 FAC1=1./18.*ALPHAS**2/TP**2
55003 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55004 SIGH(NCHN)=COMFAC*2.*XMUED
55005 ENDIF
55006 501 CONTINUE
55007 500 CONTINUE
55008 ELSEIF(ISUB.EQ.319)THEN
55009C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55010C...(the two channels have the same cross section)
55011 DO 741 I=MMIN1,MMAX1
55012 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55013 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55014 DO 742 J=MMIN2,MMAX2
55015 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55016 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55017 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55018 NCHN=NCHN+1
55019 ISIG(NCHN,1)=I
55020 ISIG(NCHN,2)=-I
55021 ISIG(NCHN,3)=1
55022 SIGH(NCHN)=COMFAC*2.*XMUED
55023 742 CONTINUE
55024 741 CONTINUE
55025
55026 ENDIF
55027
55028 RETURN
55029 END
55030C*********************************************************************
55031
55032C...PYGRAM
55033C...Universal Extra Dimensions Model (UED)
55034C...Computation of the Graviton mass.
55035
55036 SUBROUTINE PYGRAM(IN)
55037
55038C...Double precision and integer declarations
55039 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55040 IMPLICIT INTEGER(I-N)
55041
55042C...Pythia commonblocks
55043 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55044 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55045C...UED Pythia common
55046 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55047
55048C...Local variables
55049 INTEGER KCFLA,NMAX
55050 PARAMETER(KCFLA=450,NMAX=5000)
55051 DIMENSION YVEC(5000),RESVEC(5000)
55052 COMMON/INTSAV/YSAV,YMAX,RESMAX
55053 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55054 COMMON/KAPPA/XKAPPA
55055
55056C...External function (used in call to PYGAUS)
55057 EXTERNAL PYGRAW
55058
55059C...SAVE statements
55060 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55061
55062C...Initialization
55063 NDIM=IUED(4)
55064 RINV=RUED(1)
55065 XMD=RUED(2)
55066 PI=PARU(1)
55067
55068C...Initialize for numerical integration
55069 XMPLNK=2.4D+18
55070 XKAPPA=DSQRT(2.D0)/XMPLNK
55071
55072C...For NDIM=2, compute graviton mass distribution numerically
55073 IF(NDIM.EQ.2)THEN
55074
55075C... For first event: tabulate distribution of stepwise integrals:
55076C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55077 IF(IN.EQ.0)THEN
55078 RESMAX = 0D0
55079 YMAX = 0D0
55080 DO 100 I=1,NMAX
55081 YSAV = (I-0.5)/DBLE(NMAX)
55082 TOL = 1D-6
55083C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55084 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55085 YVEC(I) = YSAV
55086 RESVEC(I) = RESINT
55087C... Save max of distribution (for accept/reject below)
55088 IF(RESINT.GT.RESMAX)THEN
55089 RESMAX = RESINT
55090 YMAX = YVEC(I)
55091 ENDIF
55092 100 CONTINUE
55093 ENDIF
55094
55095C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55096 PCUJET=1D0
55097 KCGAKK=KCFLA+23
55098 XMGAMK=PMAS(KCGAKK,1)
55099
55100C... Pick random graviton mass, accept according to stored integrals
55101 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55102 110 RMG=AMMAX*PYR(0)
55103 X=RMG/XMGAMK
55104
55105C... Bin enumeration starts at 1, but make sure always in range
55106 IBIN=INT(NMAX*X)+1
55107 IBIN=MIN(IBIN,NMAX)
55108 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55109
55110C... For NDIM=4 and 6, the analytical expression for the
55111C... graviton mass distribution integral is used.
55112 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55113
55114C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55115 PCUJET=1D0
55116
55117C... KK photon (?) compressed code and mass
55118 KCGAKK=KCFLA+23
55119 XMGAMK=PMAS(KCGAKK,1)
55120
55121C... Find maximum of (dGamma/dMg)
55122 IF(IN.EQ.0)THEN
55123 RESMAX=0D0
55124 YMAX=0D0
55125 DO 120 I=1,NMAX-1
55126 Y=I/DBLE(NMAX)
55127 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55128 IF(RESINT.GE.RESMAX)THEN
55129 RESMAX=RESINT
55130 YMAX=Y
55131 ENDIF
55132 120 CONTINUE
55133 ENDIF
55134
55135C... Pick random graviton mass, accept/reject
55136 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55137 130 RMG=AMMAX*PYR(0)
55138 X=RMG/XMGAMK
55139 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55140 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55141
55142C... If the user has not chosen N=2,4 or 6, STOP
55143 ELSE
55144 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55145 & ' (MUST BE 2, 4, OR 6) '
55146 CALL PYSTOP(6002)
55147 ENDIF
55148
55149C... Now store the sampled Mg
55150 PMAS(39,1)=RMG
55151
55152 RETURN
55153 END
55154
55155C*********************************************************************
55156
55157C...PYGRAW
55158C...Universal Extra Dimensions Model (UED)
55159C...
55160C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55161C...
55162C...Integrand for the KK boson -> SM boson + graviton
55163C...graviton mass distribution (and gravity mediated total width),
55164C...which contains (see 0201300 and below for the full product)
55165C...the gravity mediated partial decay width Gamma(xx, yy)
55166C... i.e. GRADEN(YY)*PYWDKK(XXA)
55167C... where xx is exclusive to gravity
55168C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55169C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55170
55171 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55172
55173C...Double precision and integer declarations
55174 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55175 IMPLICIT INTEGER (I-N)
55176
55177C...Pythia commonblocks
55178 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55179
55180C...Local UED commonblocks and variables
55181 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55182 COMMON/INTSAV/YSAV,YMAX,RESMAX
55183
55184C...SAVE statements
55185 SAVE /PYDAT1/,/INTSAV/
55186
55187C...External: Pythia's Gamma function
55188 EXTERNAL PYGAMM
55189
55190C...Pi
55191 PI=PARU(1)
55192 PI2=PI*PI
55193
55194 YMIN=1.D-9/RINV
55195 YY=YSAV
55196 XX=DSQRT(1.-YY**2)*YIN
55197 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
55198 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
55199 XND=(NDIM-1.)/2.
55200 GAMMN=PYGAMM(XND)
55201 FAC=FAC/GAMMN
55202 XXA=DSQRT(XX**2+YY**2)
55203 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
55204
55205 PYGRAW=DJAC*
55206 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
55207
55208 RETURN
55209 END
55210C*********************************************************************
55211
55212C...PYWDKK
55213C...Universal Extra Dimensions Model (UED)
55214C...
55215C...Multiplied by the square modulus of a form factor
55216C...(see GRADEN in function PYGRAW)
55217C...PYWDKK is the KK boson -> SM boson + graviton
55218C...gravity mediated partial decay width Gamma(xx, yy)
55219C... where xx is exclusive to gravity
55220C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55221C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55222C...
55223C...N.B. The Feynman rules for the couplings of the graviton fields
55224C...to the UED fields are related to the corresponding couplings of
55225C...the graviton fields to the SM fields by the form factor.
55226
55227 DOUBLE PRECISION FUNCTION PYWDKK(X)
55228
55229C...Double precision and integer declarations
55230 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55231 IMPLICIT INTEGER (I-N)
55232
55233C...Pythia commonblocks
55234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55235 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55236
55237C...Local UED commonblocks and variables
55238 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55239 COMMON/KAPPA/XKAPPA
55240
55241C...SAVE statements
55242 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
55243
55244 PI=PARU(1)
55245
55246C...gamma* mass 473
55247 KCQKK=473
55248 XMNKK=PMAS(KCQKK,1)
55249
55250C...Bosons partial width Macesanu hep-ph/0201300
55251 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
55252 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
55253
55254 RETURN
55255 END
55256
55257C*********************************************************************
55258
55259C...PYEIGC
55260C...Finds eigenvalues of a general complex matrix
55261C
55262C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55263C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55264C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55265C OF A COMPLEX GENERAL MATRIX.
55266C
55267C ON INPUT
55268C
55269C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55270C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55271C DIMENSION STATEMENT.
55272C
55273C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55274C
55275C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55276C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55277C
55278C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55279C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55280C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55281C
55282C ON OUTPUT
55283C
55284C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55285C RESPECTIVELY, OF THE EIGENVALUES.
55286C
55287C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55288C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55289C
55290C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55291C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55292C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55293C
55294C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55295C
55296C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55297C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55298C
55299C THIS VERSION DATED AUGUST 1983.
55300C
55301
55302 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55303
55304 INTEGER N,NM,IS1,IS2,IERR,MATZ
55305 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55306 X FV1(5),FV2(5),FV3(5)
55307 IF (N .LE. NM) GOTO 100
55308 IERR = 10 * N
55309 GOTO 120
55310C
55311 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
55312 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
55313 IF (MATZ .NE. 0) GOTO 110
55314C .......... FIND EIGENVALUES ONLY ..........
55315 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
55316 GOTO 120
55317C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55318 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
55319 IF (IERR .NE. 0) GOTO 120
55320 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
55321 120 RETURN
55322 END
55323
55324C*********************************************************************
55325
55326C...PYCMQR
55327C...Auxiliary to PYEICG.
55328C
55329C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55330C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55331C AND WILKINSON.
55332C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55333C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55334C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55335C
55336C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55337C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55338C
55339C ON INPUT
55340C
55341C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55342C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55343C DIMENSION STATEMENT.
55344C
55345C N IS THE ORDER OF THE MATRIX.
55346C
55347C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55348C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55349C SET LOW=1, IGH=N.
55350C
55351C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55352C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55353C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55354C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55355C THE REDUCTION BY CORTH, IF PERFORMED.
55356C
55357C ON OUTPUT
55358C
55359C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55360C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55361C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55362C EIGENVECTORS IS TO BE PERFORMED.
55363C
55364C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55365C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55366C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55367C FOR INDICES IERR+1,...,N.
55368C
55369C IERR IS SET TO
55370C ZERO FOR NORMAL RETURN,
55371C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55372C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55373C
55374C CALLS PYCDIV FOR COMPLEX DIVISION.
55375C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55376C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55377C
55378C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55379C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55380C
55381C THIS VERSION DATED AUGUST 1983.
55382C
55383
55384 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55385
55386 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55387 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55388 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55389 X PYTHAG
55390
55391 IERR = 0
55392 IF (LOW .EQ. IGH) GOTO 130
55393C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55394 L = LOW + 1
55395C
55396 DO 120 I = L, IGH
55397 LL = MIN0(I+1,IGH)
55398 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
55399 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55400 YR = HR(I,I-1) / NORM
55401 YI = HI(I,I-1) / NORM
55402 HR(I,I-1) = NORM
55403 HI(I,I-1) = 0.0D0
55404C
55405 DO 100 J = I, IGH
55406 SI = YR * HI(I,J) - YI * HR(I,J)
55407 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55408 HI(I,J) = SI
55409 100 CONTINUE
55410C
55411 DO 110 J = LOW, LL
55412 SI = YR * HI(J,I) + YI * HR(J,I)
55413 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55414 HI(J,I) = SI
55415 110 CONTINUE
55416C
55417 120 CONTINUE
55418C .......... STORE ROOTS ISOLATED BY CBAL ..........
55419 130 DO 140 I = 1, N
55420 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
55421 WR(I) = HR(I,I)
55422 WI(I) = HI(I,I)
55423 140 CONTINUE
55424C
55425 EN = IGH
55426 TR = 0.0D0
55427 TI = 0.0D0
55428 ITN = 30*N
55429C .......... SEARCH FOR NEXT EIGENVALUE ..........
55430 150 IF (EN .LT. LOW) GOTO 320
55431 ITS = 0
55432 ENM1 = EN - 1
55433C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55434C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55435 160 DO 170 LL = LOW, EN
55436 L = EN + LOW - LL
55437 IF (L .EQ. LOW) GOTO 180
55438 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55439 X + DABS(HR(L,L)) + DABS(HI(L,L))
55440 TST2 = TST1 + DABS(HR(L,L-1))
55441 IF (TST2 .EQ. TST1) GOTO 180
55442 170 CONTINUE
55443C .......... FORM SHIFT ..........
55444 180 IF (L .EQ. EN) GOTO 300
55445 IF (ITN .EQ. 0) GOTO 310
55446 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
55447 SR = HR(EN,EN)
55448 SI = HI(EN,EN)
55449 XR = HR(ENM1,EN) * HR(EN,ENM1)
55450 XI = HI(ENM1,EN) * HR(EN,ENM1)
55451 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
55452 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55453 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55454 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55455 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
55456 ZZR = -ZZR
55457 ZZI = -ZZI
55458 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55459 SR = SR - XR
55460 SI = SI - XI
55461 GOTO 210
55462C .......... FORM EXCEPTIONAL SHIFT ..........
55463 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55464 SI = 0.0D0
55465C
55466 210 DO 220 I = LOW, EN
55467 HR(I,I) = HR(I,I) - SR
55468 HI(I,I) = HI(I,I) - SI
55469 220 CONTINUE
55470C
55471 TR = TR + SR
55472 TI = TI + SI
55473 ITS = ITS + 1
55474 ITN = ITN - 1
55475C .......... REDUCE TO TRIANGLE (ROWS) ..........
55476 LP1 = L + 1
55477C
55478 DO 240 I = LP1, EN
55479 SR = HR(I,I-1)
55480 HR(I,I-1) = 0.0D0
55481 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55482 XR = HR(I-1,I-1) / NORM
55483 WR(I-1) = XR
55484 XI = HI(I-1,I-1) / NORM
55485 WI(I-1) = XI
55486 HR(I-1,I-1) = NORM
55487 HI(I-1,I-1) = 0.0D0
55488 HI(I,I-1) = SR / NORM
55489C
55490 DO 230 J = I, EN
55491 YR = HR(I-1,J)
55492 YI = HI(I-1,J)
55493 ZZR = HR(I,J)
55494 ZZI = HI(I,J)
55495 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55496 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55497 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55498 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55499 230 CONTINUE
55500C
55501 240 CONTINUE
55502C
55503 SI = HI(EN,EN)
55504 IF (SI .EQ. 0.0D0) GOTO 250
55505 NORM = PYTHAG(HR(EN,EN),SI)
55506 SR = HR(EN,EN) / NORM
55507 SI = SI / NORM
55508 HR(EN,EN) = NORM
55509 HI(EN,EN) = 0.0D0
55510C .......... INVERSE OPERATION (COLUMNS) ..........
55511 250 DO 280 J = LP1, EN
55512 XR = WR(J-1)
55513 XI = WI(J-1)
55514C
55515 DO 270 I = L, J
55516 YR = HR(I,J-1)
55517 YI = 0.0D0
55518 ZZR = HR(I,J)
55519 ZZI = HI(I,J)
55520 IF (I .EQ. J) GOTO 260
55521 YI = HI(I,J-1)
55522 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55523 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55524 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55525 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55526 270 CONTINUE
55527C
55528 280 CONTINUE
55529C
55530 IF (SI .EQ. 0.0D0) GOTO 160
55531C
55532 DO 290 I = L, EN
55533 YR = HR(I,EN)
55534 YI = HI(I,EN)
55535 HR(I,EN) = SR * YR - SI * YI
55536 HI(I,EN) = SR * YI + SI * YR
55537 290 CONTINUE
55538C
55539 GOTO 160
55540C .......... A ROOT FOUND ..........
55541 300 WR(EN) = HR(EN,EN) + TR
55542 WI(EN) = HI(EN,EN) + TI
55543 EN = ENM1
55544 GOTO 150
55545C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55546C CONVERGED AFTER 30*N ITERATIONS ..........
55547 310 IERR = EN
55548 320 RETURN
55549 END
55550
55551C*********************************************************************
55552
55553C...PYCMQ2
55554C...Auxiliary to PYEICG.
55555C
55556C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55557C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55558C AND WILKINSON.
55559C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55560C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55561C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55562C
55563C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55564C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55565C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55566C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55567C THIS GENERAL MATRIX TO HESSENBERG FORM.
55568C
55569C ON INPUT
55570C
55571C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55572C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55573C DIMENSION STATEMENT.
55574C
55575C N IS THE ORDER OF THE MATRIX.
55576C
55577C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55578C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55579C SET LOW=1, IGH=N.
55580C
55581C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55582C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55583C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55584C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55585C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55586C
55587C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55588C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55589C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55590C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55591C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55592C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55593C ARBITRARY.
55594C
55595C ON OUTPUT
55596C
55597C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55598C HAVE BEEN DESTROYED.
55599C
55600C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55601C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55602C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55603C FOR INDICES IERR+1,...,N.
55604C
55605C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55606C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55607C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55608C THE EIGENVECTORS HAS BEEN FOUND.
55609C
55610C IERR IS SET TO
55611C ZERO FOR NORMAL RETURN,
55612C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55613C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55614C
55615C CALLS PYCDIV FOR COMPLEX DIVISION.
55616C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55617C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55618C
55619C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55620C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55621C
55622C THIS VERSION DATED OCTOBER 1989.
55623C
55624C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55625C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55626C
55627
55628 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55629
55630 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55631 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55632 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55633 X ORTR(5),ORTI(5)
55634 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55635 X PYTHAG
55636
55637 IERR = 0
55638C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55639 DO 110 J = 1, N
55640C
55641 DO 100 I = 1, N
55642 ZR(I,J) = 0.0D0
55643 ZI(I,J) = 0.0D0
55644 100 CONTINUE
55645 ZR(J,J) = 1.0D0
55646 110 CONTINUE
55647C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55648C FROM THE INFORMATION LEFT BY CORTH ..........
55649 IEND = IGH - LOW - 1
55650 IF (IEND.LT.0) GOTO 220
55651 IF (IEND.EQ.0) GOTO 170
55652C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55653 DO 160 II = 1, IEND
55654 I = IGH - II
55655 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
55656 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
55657C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55658 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
55659 IP1 = I + 1
55660C
55661 DO 120 K = IP1, IGH
55662 ORTR(K) = HR(K,I-1)
55663 ORTI(K) = HI(K,I-1)
55664 120 CONTINUE
55665C
55666 DO 150 J = I, IGH
55667 SR = 0.0D0
55668 SI = 0.0D0
55669C
55670 DO 130 K = I, IGH
55671 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
55672 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
55673 130 CONTINUE
55674C
55675 SR = SR / NORM
55676 SI = SI / NORM
55677C
55678 DO 140 K = I, IGH
55679 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
55680 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
55681 140 CONTINUE
55682C
55683 150 CONTINUE
55684C
55685 160 CONTINUE
55686C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55687 170 L = LOW + 1
55688C
55689 DO 210 I = L, IGH
55690 LL = MIN0(I+1,IGH)
55691 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
55692 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55693 YR = HR(I,I-1) / NORM
55694 YI = HI(I,I-1) / NORM
55695 HR(I,I-1) = NORM
55696 HI(I,I-1) = 0.0D0
55697C
55698 DO 180 J = I, N
55699 SI = YR * HI(I,J) - YI * HR(I,J)
55700 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55701 HI(I,J) = SI
55702 180 CONTINUE
55703C
55704 DO 190 J = 1, LL
55705 SI = YR * HI(J,I) + YI * HR(J,I)
55706 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55707 HI(J,I) = SI
55708 190 CONTINUE
55709C
55710 DO 200 J = LOW, IGH
55711 SI = YR * ZI(J,I) + YI * ZR(J,I)
55712 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
55713 ZI(J,I) = SI
55714 200 CONTINUE
55715C
55716 210 CONTINUE
55717C .......... STORE ROOTS ISOLATED BY CBAL ..........
55718 220 DO 230 I = 1, N
55719 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
55720 WR(I) = HR(I,I)
55721 WI(I) = HI(I,I)
55722 230 CONTINUE
55723C
55724 EN = IGH
55725 TR = 0.0D0
55726 TI = 0.0D0
55727 ITN = 30*N
55728C .......... SEARCH FOR NEXT EIGENVALUE ..........
55729 240 IF (EN .LT. LOW) GOTO 430
55730 ITS = 0
55731 ENM1 = EN - 1
55732C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55733C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55734 250 DO 260 LL = LOW, EN
55735 L = EN + LOW - LL
55736 IF (L .EQ. LOW) GOTO 270
55737 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55738 X + DABS(HR(L,L)) + DABS(HI(L,L))
55739 TST2 = TST1 + DABS(HR(L,L-1))
55740 IF (TST2 .EQ. TST1) GOTO 270
55741 260 CONTINUE
55742C .......... FORM SHIFT ..........
55743 270 IF (L .EQ. EN) GOTO 420
55744 IF (ITN .EQ. 0) GOTO 550
55745 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
55746 SR = HR(EN,EN)
55747 SI = HI(EN,EN)
55748 XR = HR(ENM1,EN) * HR(EN,ENM1)
55749 XI = HI(ENM1,EN) * HR(EN,ENM1)
55750 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
55751 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55752 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55753 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55754 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
55755 ZZR = -ZZR
55756 ZZI = -ZZI
55757 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55758 SR = SR - XR
55759 SI = SI - XI
55760 GOTO 300
55761C .......... FORM EXCEPTIONAL SHIFT ..........
55762 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55763 SI = 0.0D0
55764C
55765 300 DO 310 I = LOW, EN
55766 HR(I,I) = HR(I,I) - SR
55767 HI(I,I) = HI(I,I) - SI
55768 310 CONTINUE
55769C
55770 TR = TR + SR
55771 TI = TI + SI
55772 ITS = ITS + 1
55773 ITN = ITN - 1
55774C .......... REDUCE TO TRIANGLE (ROWS) ..........
55775 LP1 = L + 1
55776C
55777 DO 330 I = LP1, EN
55778 SR = HR(I,I-1)
55779 HR(I,I-1) = 0.0D0
55780 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55781 XR = HR(I-1,I-1) / NORM
55782 WR(I-1) = XR
55783 XI = HI(I-1,I-1) / NORM
55784 WI(I-1) = XI
55785 HR(I-1,I-1) = NORM
55786 HI(I-1,I-1) = 0.0D0
55787 HI(I,I-1) = SR / NORM
55788C
55789 DO 320 J = I, N
55790 YR = HR(I-1,J)
55791 YI = HI(I-1,J)
55792 ZZR = HR(I,J)
55793 ZZI = HI(I,J)
55794 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55795 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55796 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55797 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55798 320 CONTINUE
55799C
55800 330 CONTINUE
55801C
55802 SI = HI(EN,EN)
55803 IF (SI .EQ. 0.0D0) GOTO 350
55804 NORM = PYTHAG(HR(EN,EN),SI)
55805 SR = HR(EN,EN) / NORM
55806 SI = SI / NORM
55807 HR(EN,EN) = NORM
55808 HI(EN,EN) = 0.0D0
55809 IF (EN .EQ. N) GOTO 350
55810 IP1 = EN + 1
55811C
55812 DO 340 J = IP1, N
55813 YR = HR(EN,J)
55814 YI = HI(EN,J)
55815 HR(EN,J) = SR * YR + SI * YI
55816 HI(EN,J) = SR * YI - SI * YR
55817 340 CONTINUE
55818C .......... INVERSE OPERATION (COLUMNS) ..........
55819 350 DO 390 J = LP1, EN
55820 XR = WR(J-1)
55821 XI = WI(J-1)
55822C
55823 DO 370 I = 1, J
55824 YR = HR(I,J-1)
55825 YI = 0.0D0
55826 ZZR = HR(I,J)
55827 ZZI = HI(I,J)
55828 IF (I .EQ. J) GOTO 360
55829 YI = HI(I,J-1)
55830 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55831 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55832 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55833 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55834 370 CONTINUE
55835C
55836 DO 380 I = LOW, IGH
55837 YR = ZR(I,J-1)
55838 YI = ZI(I,J-1)
55839 ZZR = ZR(I,J)
55840 ZZI = ZI(I,J)
55841 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55842 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55843 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55844 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55845 380 CONTINUE
55846C
55847 390 CONTINUE
55848C
55849 IF (SI .EQ. 0.0D0) GOTO 250
55850C
55851 DO 400 I = 1, EN
55852 YR = HR(I,EN)
55853 YI = HI(I,EN)
55854 HR(I,EN) = SR * YR - SI * YI
55855 HI(I,EN) = SR * YI + SI * YR
55856 400 CONTINUE
55857C
55858 DO 410 I = LOW, IGH
55859 YR = ZR(I,EN)
55860 YI = ZI(I,EN)
55861 ZR(I,EN) = SR * YR - SI * YI
55862 ZI(I,EN) = SR * YI + SI * YR
55863 410 CONTINUE
55864C
55865 GOTO 250
55866C .......... A ROOT FOUND ..........
55867 420 HR(EN,EN) = HR(EN,EN) + TR
55868 WR(EN) = HR(EN,EN)
55869 HI(EN,EN) = HI(EN,EN) + TI
55870 WI(EN) = HI(EN,EN)
55871 EN = ENM1
55872 GOTO 240
55873C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55874C VECTORS OF UPPER TRIANGULAR FORM ..........
55875 430 NORM = 0.0D0
55876C
55877 DO 440 I = 1, N
55878C
55879 DO 440 J = I, N
55880 TR = DABS(HR(I,J)) + DABS(HI(I,J))
55881 IF (TR .GT. NORM) NORM = TR
55882 440 CONTINUE
55883C
55884 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
55885C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55886 DO 500 NN = 2, N
55887 EN = N + 2 - NN
55888 XR = WR(EN)
55889 XI = WI(EN)
55890 HR(EN,EN) = 1.0D0
55891 HI(EN,EN) = 0.0D0
55892 ENM1 = EN - 1
55893C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55894 DO 490 II = 1, ENM1
55895 I = EN - II
55896 ZZR = 0.0D0
55897 ZZI = 0.0D0
55898 IP1 = I + 1
55899C
55900 DO 450 J = IP1, EN
55901 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
55902 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
55903 450 CONTINUE
55904C
55905 YR = XR - WR(I)
55906 YI = XI - WI(I)
55907 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
55908 TST1 = NORM
55909 YR = TST1
55910 460 YR = 0.01D0 * YR
55911 TST2 = NORM + YR
55912 IF (TST2 .GT. TST1) GOTO 460
55913 470 CONTINUE
55914 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
55915C .......... OVERFLOW CONTROL ..........
55916 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
55917 IF (TR .EQ. 0.0D0) GOTO 490
55918 TST1 = TR
55919 TST2 = TST1 + 1.0D0/TST1
55920 IF (TST2 .GT. TST1) GOTO 490
55921 DO 480 J = I, EN
55922 HR(J,EN) = HR(J,EN)/TR
55923 HI(J,EN) = HI(J,EN)/TR
55924 480 CONTINUE
55925C
55926 490 CONTINUE
55927C
55928 500 CONTINUE
55929C .......... END BACKSUBSTITUTION ..........
55930C .......... VECTORS OF ISOLATED ROOTS ..........
55931 DO 520 I = 1, N
55932 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
55933C
55934 DO 510 J = I, N
55935 ZR(I,J) = HR(I,J)
55936 ZI(I,J) = HI(I,J)
55937 510 CONTINUE
55938C
55939 520 CONTINUE
55940C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55941C VECTORS OF ORIGINAL FULL MATRIX.
55942C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55943 DO 540 JJ = LOW, N
55944 J = N + LOW - JJ
55945 M = MIN0(J,IGH)
55946C
55947 DO 540 I = LOW, IGH
55948 ZZR = 0.0D0
55949 ZZI = 0.0D0
55950C
55951 DO 530 K = LOW, M
55952 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
55953 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
55954 530 CONTINUE
55955C
55956 ZR(I,J) = ZZR
55957 ZI(I,J) = ZZI
55958 540 CONTINUE
55959C
55960 GOTO 560
55961C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55962C CONVERGED AFTER 30*N ITERATIONS ..........
55963 550 IERR = EN
55964 560 RETURN
55965 END
55966
55967C*********************************************************************
55968
55969C...PYCDIV
55970C...Auxiliary to PYCMQR
55971C
55972C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55973C
55974
55975 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
55976
55977 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55978 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55979
55980 S = DABS(BR) + DABS(BI)
55981 ARS = AR/S
55982 AIS = AI/S
55983 BRS = BR/S
55984 BIS = BI/S
55985 S = BRS**2 + BIS**2
55986 CR = (ARS*BRS + AIS*BIS)/S
55987 CI = (AIS*BRS - ARS*BIS)/S
55988 RETURN
55989 END
55990
55991C*********************************************************************
55992
55993C...PYCSRT
55994C...Auxiliary to PYCMQR
55995C
55996C (YR,YI) = COMPLEX DSQRT(XR,XI)
55997C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
55998C
55999
56000 SUBROUTINE PYCSRT(XR,XI,YR,YI)
56001
56002 DOUBLE PRECISION XR,XI,YR,YI
56003 DOUBLE PRECISION S,TR,TI,PYTHAG
56004
56005 TR = XR
56006 TI = XI
56007 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56008 IF (TR .GE. 0.0D0) YR = S
56009 IF (TI .LT. 0.0D0) S = -S
56010 IF (TR .LE. 0.0D0) YI = S
56011 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56012 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56013 RETURN
56014 END
56015
56016 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56017 DOUBLE PRECISION A,B
56018C
56019C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56020C
56021 DOUBLE PRECISION P,R,S,T,U
56022 P = DMAX1(DABS(A),DABS(B))
56023 IF (P .EQ. 0.0D0) GOTO 110
56024 R = (DMIN1(DABS(A),DABS(B))/P)**2
56025 100 CONTINUE
56026 T = 4.0D0 + R
56027 IF (T .EQ. 4.0D0) GOTO 110
56028 S = R/T
56029 U = 1.0D0 + 2.0D0*S
56030 P = U*P
56031 R = (S/U)**2 * R
56032 GOTO 100
56033 110 PYTHAG = P
56034 RETURN
56035 END
56036
56037C*********************************************************************
56038
56039C...PYCBAL
56040C...Auxiliary to PYEICG
56041C
56042C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56043C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56044C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56045C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56046C
56047C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56048C EIGENVALUES WHENEVER POSSIBLE.
56049C
56050C ON INPUT
56051C
56052C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56053C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56054C DIMENSION STATEMENT.
56055C
56056C N IS THE ORDER OF THE MATRIX.
56057C
56058C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56059C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56060C
56061C ON OUTPUT
56062C
56063C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56064C RESPECTIVELY, OF THE BALANCED MATRIX.
56065C
56066C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56067C ARE EQUAL TO ZERO IF
56068C (1) I IS GREATER THAN J AND
56069C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56070C
56071C SCALE CONTAINS INFORMATION DETERMINING THE
56072C PERMUTATIONS AND SCALING FACTORS USED.
56073C
56074C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56075C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56076C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56077C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56078C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56079C = D(J,J) J = LOW,...,IGH
56080C = P(J) J = IGH+1,...,N.
56081C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56082C THEN 1 TO LOW-1.
56083C
56084C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56085C
56086C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56087C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56088C K,L HAVE BEEN REVERSED.)
56089C
56090C ARITHMETIC IS REAL THROUGHOUT.
56091C
56092C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56093C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56094C
56095C THIS VERSION DATED AUGUST 1983.
56096C
56097
56098 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56099
56100 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56101 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56102 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56103 LOGICAL NOCONV
56104
56105 RADIX = 16.0D0
56106C
56107 B2 = RADIX * RADIX
56108 K = 1
56109 L = N
56110 GOTO 150
56111C .......... IN-LINE PROCEDURE FOR ROW AND
56112C COLUMN EXCHANGE ..........
56113 100 SCALE(M) = J
56114 IF (J .EQ. M) GOTO 130
56115C
56116 DO 110 I = 1, L
56117 F = AR(I,J)
56118 AR(I,J) = AR(I,M)
56119 AR(I,M) = F
56120 F = AI(I,J)
56121 AI(I,J) = AI(I,M)
56122 AI(I,M) = F
56123 110 CONTINUE
56124C
56125 DO 120 I = K, N
56126 F = AR(J,I)
56127 AR(J,I) = AR(M,I)
56128 AR(M,I) = F
56129 F = AI(J,I)
56130 AI(J,I) = AI(M,I)
56131 AI(M,I) = F
56132 120 CONTINUE
56133C
56134 130 IF(IEXC.EQ.1) GOTO 140
56135 IF(IEXC.EQ.2) GOTO 180
56136C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56137C AND PUSH THEM DOWN ..........
56138 140 IF (L .EQ. 1) GOTO 320
56139 L = L - 1
56140C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56141 150 DO 170 JJ = 1, L
56142 J = L + 1 - JJ
56143C
56144 DO 160 I = 1, L
56145 IF (I .EQ. J) GOTO 160
56146 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56147 160 CONTINUE
56148C
56149 M = L
56150 IEXC = 1
56151 GOTO 100
56152 170 CONTINUE
56153C
56154 GOTO 190
56155C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56156C AND PUSH THEM LEFT ..........
56157 180 K = K + 1
56158C
56159 190 DO 210 J = K, L
56160C
56161 DO 200 I = K, L
56162 IF (I .EQ. J) GOTO 200
56163 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56164 200 CONTINUE
56165C
56166 M = K
56167 IEXC = 2
56168 GOTO 100
56169 210 CONTINUE
56170C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56171 DO 220 I = K, L
56172 220 SCALE(I) = 1.0D0
56173C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56174 230 NOCONV = .FALSE.
56175C
56176 DO 310 I = K, L
56177 C = 0.0D0
56178 R = 0.0D0
56179C
56180 DO 240 J = K, L
56181 IF (J .EQ. I) GOTO 240
56182 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56183 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56184 240 CONTINUE
56185C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56186 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
56187 G = R / RADIX
56188 F = 1.0D0
56189 S = C + R
56190 250 IF (C .GE. G) GOTO 260
56191 F = F * RADIX
56192 C = C * B2
56193 GOTO 250
56194 260 G = R * RADIX
56195 270 IF (C .LT. G) GOTO 280
56196 F = F / RADIX
56197 C = C / B2
56198 GOTO 270
56199C .......... NOW BALANCE ..........
56200 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
56201 G = 1.0D0 / F
56202 SCALE(I) = SCALE(I) * F
56203 NOCONV = .TRUE.
56204C
56205 DO 290 J = K, N
56206 AR(I,J) = AR(I,J) * G
56207 AI(I,J) = AI(I,J) * G
56208 290 CONTINUE
56209C
56210 DO 300 J = 1, L
56211 AR(J,I) = AR(J,I) * F
56212 AI(J,I) = AI(J,I) * F
56213 300 CONTINUE
56214C
56215 310 CONTINUE
56216C
56217 IF (NOCONV) GOTO 230
56218C
56219 320 LOW = K
56220 IGH = L
56221 RETURN
56222 END
56223
56224C*********************************************************************
56225
56226C...PYCBA2
56227C...Auxiliary to PYEICG.
56228C
56229C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56230C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56231C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56232C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56233C
56234C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56235C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56236C BALANCED MATRIX DETERMINED BY CBAL.
56237C
56238C ON INPUT
56239C
56240C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56241C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56242C DIMENSION STATEMENT.
56243C
56244C N IS THE ORDER OF THE MATRIX.
56245C
56246C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56247C
56248C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56249C AND SCALING FACTORS USED BY CBAL.
56250C
56251C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56252C
56253C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56254C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56255C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56256C
56257C ON OUTPUT
56258C
56259C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56260C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56261C IN THEIR FIRST M COLUMNS.
56262C
56263C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56264C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56265C
56266C THIS VERSION DATED AUGUST 1983.
56267C
56268
56269 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56270
56271 INTEGER I,J,K,M,N,II,NM,IGH,LOW
56272 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56273 DOUBLE PRECISION S
56274
56275 IF (M .EQ. 0) GOTO 150
56276 IF (IGH .EQ. LOW) GOTO 120
56277C
56278 DO 110 I = LOW, IGH
56279 S = SCALE(I)
56280C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56281C IF THE FOREGOING STATEMENT IS REPLACED BY
56282C S=1.0D0/SCALE(I). ..........
56283 DO 100 J = 1, M
56284 ZR(I,J) = ZR(I,J) * S
56285 ZI(I,J) = ZI(I,J) * S
56286 100 CONTINUE
56287C
56288 110 CONTINUE
56289C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56290C IGH+1 STEP 1 UNTIL N DO -- ..........
56291 120 DO 140 II = 1, N
56292 I = II
56293 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56294 IF (I .LT. LOW) I = LOW - II
56295 K = SCALE(I)
56296 IF (K .EQ. I) GOTO 140
56297C
56298 DO 130 J = 1, M
56299 S = ZR(I,J)
56300 ZR(I,J) = ZR(K,J)
56301 ZR(K,J) = S
56302 S = ZI(I,J)
56303 ZI(I,J) = ZI(K,J)
56304 ZI(K,J) = S
56305 130 CONTINUE
56306C
56307 140 CONTINUE
56308C
56309 150 RETURN
56310 END
56311
56312C*********************************************************************
56313
56314C...PYCRTH
56315C...Auxiliary to PYEICG.
56316C
56317C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56318C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56319C BY MARTIN AND WILKINSON.
56320C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56321C
56322C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56323C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56324C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56325C UNITARY SIMILARITY TRANSFORMATIONS.
56326C
56327C ON INPUT
56328C
56329C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56330C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56331C DIMENSION STATEMENT.
56332C
56333C N IS THE ORDER OF THE MATRIX.
56334C
56335C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56336C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56337C SET LOW=1, IGH=N.
56338C
56339C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56340C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56341C
56342C ON OUTPUT
56343C
56344C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56345C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56346C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56347C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56348C HESSENBERG MATRIX.
56349C
56350C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56351C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56352C
56353C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56354C
56355C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56356C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56357C
56358C THIS VERSION DATED AUGUST 1983.
56359C
56360
56361 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56362
56363 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56364 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56365 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56366
56367 LA = IGH - 1
56368 KP1 = LOW + 1
56369 IF (LA .LT. KP1) GOTO 210
56370C
56371 DO 200 M = KP1, LA
56372 H = 0.0D0
56373 ORTR(M) = 0.0D0
56374 ORTI(M) = 0.0D0
56375 SCALE = 0.0D0
56376C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56377 DO 100 I = M, IGH
56378 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
56379C
56380 IF (SCALE .EQ. 0.0D0) GOTO 200
56381 MP = M + IGH
56382C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56383 DO 110 II = M, IGH
56384 I = MP - II
56385 ORTR(I) = AR(I,M-1) / SCALE
56386 ORTI(I) = AI(I,M-1) / SCALE
56387 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
56388 110 CONTINUE
56389C
56390 G = DSQRT(H)
56391 F = PYTHAG(ORTR(M),ORTI(M))
56392 IF (F .EQ. 0.0D0) GOTO 120
56393 H = H + F * G
56394 G = G / F
56395 ORTR(M) = (1.0D0 + G) * ORTR(M)
56396 ORTI(M) = (1.0D0 + G) * ORTI(M)
56397 GOTO 130
56398C
56399 120 ORTR(M) = G
56400 AR(M,M-1) = SCALE
56401C .......... FORM (I-(U*UT)/H) * A ..........
56402 130 DO 160 J = M, N
56403 FR = 0.0D0
56404 FI = 0.0D0
56405C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56406 DO 140 II = M, IGH
56407 I = MP - II
56408 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
56409 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
56410 140 CONTINUE
56411C
56412 FR = FR / H
56413 FI = FI / H
56414C
56415 DO 150 I = M, IGH
56416 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
56417 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
56418 150 CONTINUE
56419C
56420 160 CONTINUE
56421C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56422 DO 190 I = 1, IGH
56423 FR = 0.0D0
56424 FI = 0.0D0
56425C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56426 DO 170 JJ = M, IGH
56427 J = MP - JJ
56428 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
56429 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
56430 170 CONTINUE
56431C
56432 FR = FR / H
56433 FI = FI / H
56434C
56435 DO 180 J = M, IGH
56436 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
56437 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
56438 180 CONTINUE
56439C
56440 190 CONTINUE
56441C
56442 ORTR(M) = SCALE * ORTR(M)
56443 ORTI(M) = SCALE * ORTI(M)
56444 AR(M,M-1) = -G * AR(M,M-1)
56445 AI(M,M-1) = -G * AI(M,M-1)
56446 200 CONTINUE
56447C
56448 210 RETURN
56449 END
56450
56451C*********************************************************************
56452
56453C...PYLDCM
56454C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56455C...processes.
56456
56457 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
56458 IMPLICIT NONE
56459 INTEGER N,NP,INDX(N)
56460 REAL*8 D,TINY
56461 COMPLEX*16 A(NP,NP)
56462 PARAMETER (TINY=1.0D-20)
56463 INTEGER I,IMAX,J,K
56464 REAL*8 AAMAX,VV(6),DUM
56465 COMPLEX*16 SUM,DUMC
56466
56467 D=1D0
56468 DO 110 I=1,N
56469 AAMAX=0D0
56470 DO 100 J=1,N
56471 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
56472 100 CONTINUE
56473 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
56474 VV(I)=1D0/AAMAX
56475 110 CONTINUE
56476 DO 180 J=1,N
56477 DO 130 I=1,J-1
56478 SUM=A(I,J)
56479 DO 120 K=1,I-1
56480 SUM=SUM-A(I,K)*A(K,J)
56481 120 CONTINUE
56482 A(I,J)=SUM
56483 130 CONTINUE
56484 AAMAX=0D0
56485 DO 150 I=J,N
56486 SUM=A(I,J)
56487 DO 140 K=1,J-1
56488 SUM=SUM-A(I,K)*A(K,J)
56489 140 CONTINUE
56490 A(I,J)=SUM
56491 DUM=VV(I)*ABS(SUM)
56492 IF (DUM.GE.AAMAX) THEN
56493 IMAX=I
56494 AAMAX=DUM
56495 ENDIF
56496 150 CONTINUE
56497 IF (J.NE.IMAX)THEN
56498 DO 160 K=1,N
56499 DUMC=A(IMAX,K)
56500 A(IMAX,K)=A(J,K)
56501 A(J,K)=DUMC
56502 160 CONTINUE
56503 D=-D
56504 VV(IMAX)=VV(J)
56505 ENDIF
56506 INDX(J)=IMAX
56507 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
56508 IF(J.NE.N)THEN
56509 DO 170 I=J+1,N
56510 A(I,J)=A(I,J)/A(J,J)
56511 170 CONTINUE
56512 ENDIF
56513 180 CONTINUE
56514
56515 RETURN
56516 END
56517
56518C*********************************************************************
56519
56520C...PYBKSB
56521C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56522C...processes.
56523
56524 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
56525 IMPLICIT NONE
56526 INTEGER N,NP,INDX(N)
56527 COMPLEX*16 A(NP,NP),B(N)
56528 INTEGER I,II,J,LL
56529 COMPLEX*16 SUM
56530
56531 II=0
56532 DO 110 I=1,N
56533 LL=INDX(I)
56534 SUM=B(LL)
56535 B(LL)=B(I)
56536 IF (II.NE.0)THEN
56537 DO 100 J=II,I-1
56538 SUM=SUM-A(I,J)*B(J)
56539 100 CONTINUE
56540 ELSE IF (ABS(SUM).NE.0D0) THEN
56541 II=I
56542 ENDIF
56543 B(I)=SUM
56544 110 CONTINUE
56545 DO 130 I=N,1,-1
56546 SUM=B(I)
56547 DO 120 J=I+1,N
56548 SUM=SUM-A(I,J)*B(J)
56549 120 CONTINUE
56550 B(I)=SUM/A(I,I)
56551 130 CONTINUE
56552 RETURN
56553 END
56554
56555C***********************************************************************
56556
56557C...PYWIDX
56558C...Calculates full and partial widths of resonances.
56559C....copy of PYWIDT, used for techniparticle widths
56560
56561 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
56562
56563C...Double precision and integer declarations.
56564 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56565 IMPLICIT INTEGER(I-N)
56566 INTEGER PYK,PYCHGE,PYCOMP
56567C...Parameter statement to help give large particle numbers.
56568 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56569 &KEXCIT=4000000,KDIMEN=5000000)
56570C...Commonblocks.
56571 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56572 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56573 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56574 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
56575 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56576 COMMON/PYINT1/MINT(400),VINT(400)
56577 COMMON/PYINT4/MWID(500),WIDS(500,5)
56578 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56579 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
56580 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
56581 &/PYINT4/,/PYMSSM/,/PYTCSM/
56582C...Local arrays and saved variables.
56583 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
56584 &WID2SV(3,2)
56585 SAVE MOFSV,WIDWSV,WID2SV
56586 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
56587
56588C...Compressed code and sign; mass.
56589 KFLA=IABS(KFLR)
56590 KFLS=ISIGN(1,KFLR)
56591 KC=PYCOMP(KFLA)
56592 SHR=SQRT(SH)
56593 PMR=PMAS(KC,1)
56594
56595C...Reset width information.
56596 DO I=0,400
56597 WDTP(I)=0D0
56598 ENDDO
56599
56600C...Common electroweak and strong constants.
56601 XW=PARU(102)
56602 XWV=XW
56603 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
56604 XW1=1D0-XW
56605 AEM=PYALEM(SH)
56606 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
56607 AS=PYALPS(SH)
56608 RADC=1D0+AS/PARU(1)
56609
56610 IF(KFLA.EQ.23) THEN
56611C...Z0:
56612 XWC=1D0/(16D0*XW*XW1)
56613 FAC=(AEM*XWC/3D0)*SHR
56614 120 CONTINUE
56615 DO 130 I=1,MDCY(KC,3)
56616 IDC=I+MDCY(KC,2)-1
56617 IF(MDME(IDC,1).LT.0) GOTO 130
56618 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56619 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56620 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
56621 IF(I.LE.8) THEN
56622C...Z0 -> q + qbar
56623 EF=KCHG(I,1)/3D0
56624 AF=SIGN(1D0,EF+0.1D0)
56625 VF=AF-4D0*EF*XWV
56626 FCOF=3D0*RADC
56627 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
56628 ELSEIF(I.LE.16) THEN
56629C...Z0 -> l+ + l-, nu + nubar
56630 EF=KCHG(I+2,1)/3D0
56631 AF=SIGN(1D0,EF+0.1D0)
56632 VF=AF-4D0*EF*XWV
56633 FCOF=1D0
56634 ENDIF
56635 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
56636 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
56637 & BE34
56638 WDTP(0)=WDTP(0)+WDTP(I)
56639 130 CONTINUE
56640
56641
56642 ELSEIF(KFLA.EQ.24) THEN
56643C...W+/-:
56644 FAC=(AEM/(24D0*XW))*SHR
56645 DO 140 I=1,MDCY(KC,3)
56646 IDC=I+MDCY(KC,2)-1
56647 IF(MDME(IDC,1).LT.0) GOTO 140
56648 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56649 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56650 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
56651 WID2=1D0
56652 IF(I.LE.16) THEN
56653C...W+/- -> q + qbar'
56654 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
56655 ELSEIF(I.LE.20) THEN
56656C...W+/- -> l+/- + nu
56657 FCOF=1D0
56658 ENDIF
56659 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
56660 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
56661 WDTP(0)=WDTP(0)+WDTP(I)
56662 140 CONTINUE
56663
56664C.....V8 -> quark anti-quark
56665 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
56666 FAC=AS/6D0*SHR
56667 TANT3=RTCM(21)
56668 IF(ITCM(2).EQ.0) THEN
56669 IMDL=1
56670 ELSEIF(ITCM(2).EQ.1) THEN
56671 IMDL=2
56672 ENDIF
56673 DO 150 I=1,MDCY(KC,3)
56674 IDC=I+MDCY(KC,2)-1
56675 IF(MDME(IDC,1).LT.0) GOTO 150
56676 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
56677 RM1=PM1**2/SH
56678 IF(RM1.GT.0.25D0) GOTO 150
56679 WID2=1D0
56680 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
56681 FMIX=1D0/TANT3**2
56682 ELSE
56683 FMIX=TANT3**2
56684 ENDIF
56685 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
56686 IF(I.EQ.6) WID2=WIDS(6,1)
56687 WDTP(0)=WDTP(0)+WDTP(I)
56688 150 CONTINUE
56689 ENDIF
56690
56691 RETURN
56692 END
56693
56694C*********************************************************************
56695
56696C...PYRVSF
56697C...Calculates R-violating decays of sfermions.
56698C...P. Z. Skands
56699
56700 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
56701
56702C...Double precision and integer declarations.
56703 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56704 IMPLICIT INTEGER(I-N)
56705C...Parameter statement to help give large particle numbers.
56706 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56707 &KEXCIT=4000000,KDIMEN=5000000)
56708C...Commonblocks.
56709 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56710 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56711 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56712 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56713 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
56714C...Local variables.
56715 DOUBLE PRECISION XLAM(0:400)
56716 INTEGER IDLAM(400,3), PYCOMP
56717 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
56718
56719C...IS R-VIOLATION ON ?
56720 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
56721C...Mass eigenstate counter
56722 ICNT=INT(KFIN/KSUSY1)
56723C...SM KF code of SUSY particle
56724 KFSM=KFIN-ICNT*KSUSY1
56725C...Squared Sparticle Mass
56726 SM=PMAS(PYCOMP(KFIN),1)**2
56727C... Squared mass of top quark
56728 SMT=PMAS(PYCOMP(6),1)**2
56729C...IS L-VIOLATION ON ?
56730 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
56731C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56732 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
56733 & THEN
56734 K=INT((KFSM-9)/2)
56735 DO 110 I=1,3
56736 DO 100 J=1,3
56737 IF(I.NE.J) THEN
56738C...~e,~mu,~tau -> nu_I + lepton-_J
56739 LKNT = LKNT+1
56740 IDLAM(LKNT,1)= 12 +2*(I-1)
56741 IDLAM(LKNT,2)= 11 +2*(J-1)
56742 IDLAM(LKNT,3)= 0
56743 XLAM(LKNT)=0D0
56744 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56745 IF (IMSS(51).NE.0) XLAM(LKNT) =
56746 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56747C...KINEMATICS CHECK
56748 IF (XLAM(LKNT).EQ.0D0) THEN
56749 LKNT=LKNT-1
56750 ENDIF
56751 ENDIF
56752 100 CONTINUE
56753 110 CONTINUE
56754C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56755 J=INT((KFSM-9)/2)
56756 DO 130 I=1,3
56757 IF(I.NE.J) THEN
56758 DO 120 K=1,3
56759 LKNT = LKNT+1
56760 IDLAM(LKNT,1)=-12 -2*(I-1)
56761 IDLAM(LKNT,2)= 11 +2*(K-1)
56762 IDLAM(LKNT,3)= 0
56763 XLAM(LKNT)=0D0
56764 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56765 IF (IMSS(51).NE.0) XLAM(LKNT) =
56766 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56767C...KINEMATICS CHECK
56768 IF (XLAM(LKNT).EQ.0D0) THEN
56769 LKNT=LKNT-1
56770 ENDIF
56771 120 CONTINUE
56772 ENDIF
56773 130 CONTINUE
56774C...~e,~mu,~tau -> u_Jbar + d_K
56775 I=INT((KFSM-9)/2)
56776 DO 150 J=1,3
56777 DO 140 K=1,3
56778 LKNT = LKNT+1
56779 IDLAM(LKNT,1)=-2 -2*(J-1)
56780 IDLAM(LKNT,2)= 1 +2*(K-1)
56781 IDLAM(LKNT,3)= 0
56782 XLAM(LKNT)=0
56783 IF (IMSS(52).NE.0) THEN
56784C...Use massive top quark
56785 IF (IDLAM(LKNT,1).EQ.-6) THEN
56786 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
56787 & * (SM-SMT)
56788 XLAM(LKNT) =
56789 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56790C...If no top quark, all decay products massless
56791 ELSE
56792 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56793 XLAM(LKNT) =
56794 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56795 ENDIF
56796C...KINEMATICS CHECK
56797 IF (XLAM(LKNT).EQ.0D0) THEN
56798 LKNT=LKNT-1
56799 ENDIF
56800 ENDIF
56801 140 CONTINUE
56802 150 CONTINUE
56803 ENDIF
56804C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56805C...No right-handed neutrinos
56806 IF(ICNT.EQ.1) THEN
56807 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
56808 J=INT((KFSM-10)/2)
56809 DO 170 I=1,3
56810 DO 160 K=1,3
56811 IF (I.NE.J) THEN
56812C...~nu_J -> lepton+_I + lepton-_K
56813 LKNT = LKNT+1
56814 IDLAM(LKNT,1)=-11 -2*(I-1)
56815 IDLAM(LKNT,2)= 11 +2*(K-1)
56816 IDLAM(LKNT,3)= 0
56817 XLAM(LKNT)=0D0
56818 RM2=RVLAM(I,J,K)**2 * SM
56819 IF (IMSS(51).NE.0) XLAM(LKNT) =
56820 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56821C...KINEMATICS CHECK
56822 IF (XLAM(LKNT).EQ.0D0) THEN
56823 LKNT=LKNT-1
56824 ENDIF
56825 ENDIF
56826 160 CONTINUE
56827 170 CONTINUE
56828C...~nu_I -> dbar_J + d_K
56829 I=INT((KFSM-10)/2)
56830 DO 190 J=1,3
56831 DO 180 K=1,3
56832 LKNT = LKNT+1
56833 IDLAM(LKNT,1)=-1 -2*(J-1)
56834 IDLAM(LKNT,2)= 1 +2*(K-1)
56835 IDLAM(LKNT,3)= 0
56836 XLAM(LKNT)=0D0
56837 RM2=3*RVLAMP(I,J,K)**2 * SM
56838 IF (IMSS(52).NE.0) XLAM(LKNT) =
56839 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56840C...KINEMATICS CHECK
56841 IF (XLAM(LKNT).EQ.0D0) THEN
56842 LKNT=LKNT-1
56843 ENDIF
56844 180 CONTINUE
56845 190 CONTINUE
56846 ENDIF
56847 ENDIF
56848C * SDOWN -> NU(BAR) + D and LEPTON- + U
56849 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56850 J=INT((KFSM+1)/2)
56851 DO 210 I=1,3
56852 DO 200 K=1,3
56853C...~d_J -> nu_Ibar + d_K
56854 LKNT = LKNT+1
56855 IDLAM(LKNT,1)=-12 -2*(I-1)
56856 IDLAM(LKNT,2)= 1 +2*(K-1)
56857 IDLAM(LKNT,3)= 0
56858 XLAM(LKNT)=0D0
56859 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56860 IF (IMSS(52).NE.0) XLAM(LKNT) =
56861 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56862C...KINEMATICS CHECK
56863 IF (XLAM(LKNT).EQ.0D0) THEN
56864 LKNT=LKNT-1
56865 ENDIF
56866 200 CONTINUE
56867 210 CONTINUE
56868 K=INT((KFSM+1)/2)
56869 DO 240 I=1,3
56870 DO 230 J=1,3
56871C...~d_K -> nu_I + d_J
56872 LKNT = LKNT+1
56873 IDLAM(LKNT,1)= 12 +2*(I-1)
56874 IDLAM(LKNT,2)= 1 +2*(J-1)
56875 IDLAM(LKNT,3)= 0
56876 XLAM(LKNT)=0D0
56877 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56878 IF (IMSS(52).NE.0) XLAM(LKNT) =
56879 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56880C...KINEMATICS CHECK
56881 IF (XLAM(LKNT).EQ.0D0) THEN
56882 LKNT=LKNT-1
56883 ENDIF
56884C...~d_K -> lepton_I- + u_J
56885 220 LKNT = LKNT+1
56886 IDLAM(LKNT,1)= 11 +2*(I-1)
56887 IDLAM(LKNT,2)= 2 +2*(J-1)
56888 IDLAM(LKNT,3)= 0
56889 XLAM(LKNT)=0D0
56890 IF (IMSS(52).NE.0) THEN
56891C...Use massive top quark
56892 IF (IDLAM(LKNT,2).EQ.6) THEN
56893 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
56894 XLAM(LKNT) =
56895 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
56896C...If no top quark, all decay products massless
56897 ELSE
56898 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56899 XLAM(LKNT) =
56900 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56901 ENDIF
56902C...KINEMATICS CHECK
56903 IF (XLAM(LKNT).EQ.0D0) THEN
56904 LKNT=LKNT-1
56905 ENDIF
56906 ENDIF
56907 230 CONTINUE
56908 240 CONTINUE
56909 ENDIF
56910C * SUP -> LEPTON+ + D
56911 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56912 J=NINT(KFSM/2.)
56913 DO 260 I=1,3
56914 DO 250 K=1,3
56915C...~u_J -> lepton_I+ + d_K
56916 LKNT = LKNT+1
56917 IDLAM(LKNT,1)=-11 -2*(I-1)
56918 IDLAM(LKNT,2)= 1 +2*(K-1)
56919 IDLAM(LKNT,3)= 0
56920 XLAM(LKNT)=0D0
56921 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56922 IF (IMSS(52).NE.0) XLAM(LKNT) =
56923 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56924C...KINEMATICS CHECK
56925 IF (XLAM(LKNT).EQ.0D0) THEN
56926 LKNT=LKNT-1
56927 ENDIF
56928 250 CONTINUE
56929 260 CONTINUE
56930 ENDIF
56931 ENDIF
56932C...BARYON NUMBER VIOLATING DECAYS
56933 IF (IMSS(53).GE.1) THEN
56934C * SUP -> DBAR + DBAR
56935 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56936 I = KFSM/2
56937 DO 280 J=1,3
56938 DO 270 K=1,3
56939C...~u_I -> dbar_J + dbar_K
56940 IF (J.LT.K) THEN
56941C...(anti-) symmetry J <-> K.
56942 LKNT = LKNT + 1
56943 IDLAM(LKNT,1) = -1 -2*(J-1)
56944 IDLAM(LKNT,2) = -1 -2*(K-1)
56945 IDLAM(LKNT,3) = 0
56946 XLAM(LKNT) = 0D0
56947 RM2 = 2.*(RVLAMB(I,J,K)**2)
56948 & * SFMIX(KFSM,2*ICNT)**2 * SM
56949 XLAM(LKNT) =
56950 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56951C...KINEMATICS CHECK
56952 IF (XLAM(LKNT).EQ.0D0) THEN
56953 LKNT = LKNT-1
56954 ENDIF
56955 ENDIF
56956 270 CONTINUE
56957 280 CONTINUE
56958 ENDIF
56959C * SDOWN -> UBAR + DBAR
56960 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56961 K=(KFSM+1)/2
56962 DO 300 I=1,3
56963 DO 290 J=1,3
56964C...LAMB coupling antisymmetric in J and K.
56965 IF (J.NE.K) THEN
56966C...~d_K -> ubar_I + dbar_K
56967 LKNT = LKNT + 1
56968 IDLAM(LKNT,1)= -2 -2*(I-1)
56969 IDLAM(LKNT,2)= -1 -2*(J-1)
56970 IDLAM(LKNT,3)= 0
56971 XLAM(LKNT)=0D0
56972C...Use massive top quark
56973 IF (IDLAM(LKNT,1).EQ.-6) THEN
56974 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
56975 & )
56976 XLAM(LKNT) =
56977 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56978C...If no top quark, all decay products massless
56979 ELSE
56980 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56981 XLAM(LKNT) =
56982 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56983 ENDIF
56984C...KINEMATICS CHECK
56985 IF (XLAM(LKNT).EQ.0D0) THEN
56986 LKNT=LKNT-1
56987 ENDIF
56988 ENDIF
56989 290 CONTINUE
56990 300 CONTINUE
56991 ENDIF
56992 ENDIF
56993 ENDIF
56994
56995 RETURN
56996 END
56997
56998C*********************************************************************
56999
57000C...PYRVNE
57001C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57002C...P. Z. Skands
57003
57004 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57005
57006C...Double precision and integer declarations.
57007 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57008 IMPLICIT INTEGER(I-N)
57009C...Parameter statement to help give large particle numbers.
57010 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57011 &KEXCIT=4000000,KDIMEN=5000000)
57012C...Commonblocks.
57013 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57014 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57015 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57016 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57017 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57018 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57019C...Local variables.
57020 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57021 & ,DCMASS,KFR(3)
57022 DOUBLE PRECISION XLAM(0:400)
57023 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57024 INTEGER IDLAM(400,3), PYCOMP
57025 LOGICAL DCMASS
57026 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57027
57028C...R-VIOLATING DECAYS
57029 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57030 KFSM=KFIN-KSUSY1
57031 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57032C...WHICH NEUTRALINO ?
57033 NCHI=1
57034 IF (KFSM.EQ.23) NCHI=2
57035 IF (KFSM.EQ.25) NCHI=3
57036 IF (KFSM.EQ.35) NCHI=4
57037C...SIGN OF MASS (Opposite convention as HERWIG)
57038 ISM = 1
57039 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57040
57041C...Useful parameters for the calculation of the A and B constants.
57042 WMASS = PMAS(PYCOMP(24),1)
57043 ECHG = 2*SQRT(PARU(103)*PARU(1))
57044 COSB=1/(SQRT(1+RMSS(5)**2))
57045 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57046 COSW=SQRT(1-PARU(102))
57047 SINW=SQRT(PARU(102))
57048 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57049C...Run quark masses to neutralino mass squared (for Higgs-type
57050C...couplings)
57051 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57052 DO 100 I=1,6
57053 RMQ(I)=PYMRUN(I,SQMCHI)
57054 100 CONTINUE
57055C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57056 DO 110 NCHJ=1,4
57057 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57058 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57059 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57060 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57061 110 CONTINUE
57062 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57063 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57064 C2=ECHG*ZPMIX(NCHI,1)
57065 C3=GW*ZPMIX(NCHI,2)/COSW
57066 EU=2D0/3D0
57067 ED=-1D0/3D0
57068C... AB(x,y,z):
57069C x=1-2 : Select A or B constant (1:A ; 2:B)
57070C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57071C 11-16:e,nu_e,mu,...)
57072C z=1-2 : Mass eigenstate number
57073C...CALCULATE COUPLINGS
57074 DO 120 I = 11,15,2
57075 CMS=PMAS(PYCOMP(I),1)
57076C...Intermediate sleptons
57077 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57078 & *(C2-C3*SINW**2))
57079 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57080 & *(C2-C3*SINW**2))
57081 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57082 & **2))
57083 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57084 & **2))
57085C...Inermediate sneutrinos
57086 AB(1,I+1,1)=0D0
57087 AB(2,I+1,1)=5D-1*C3
57088 AB(1,I+1,2)=0D0
57089 AB(2,I+1,2)=0D0
57090C...Inermediate sdown
57091 J=I-10
57092 CMS=RMQ(J)
57093 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57094 & *ED*(C2-C3*SINW**2))
57095 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57096 & *ED*(C2-C3*SINW**2))
57097 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57098 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57099 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57100 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57101C...Inermediate sup
57102 J=J+1
57103 CMS=RMQ(J)
57104 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57105 & *EU*(C2-C3*SINW**2))
57106 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57107 & *EU*(C2-C3*SINW**2))
57108 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57109 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57110 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57111 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57112 120 CONTINUE
57113
57114 IF (IMSS(51).GE.1) THEN
57115C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57116C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57117C...STEP IN I,J,K USING SINGLE COUNTER
57118 DO 130 ISC=0,26
57119C...LAMBDA COUPLING ASYM IN I,J
57120 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57121 LKNT = LKNT+1
57122 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57123 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57124 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57125 XLAM(LKNT) = 0D0
57126C...Set coupling, and decay product masses on/off
57127 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57128 & ,MOD(ISC,3)+1)**2
57129 DCMASS=.FALSE.
57130 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57131 & DCMASS = .TRUE.
57132C...Resonance KF codes (1=I,2=J,3=K)
57133 KFR(1)=-IDLAM(LKNT,1)
57134 KFR(2)=-IDLAM(LKNT,2)
57135 KFR(3)=-IDLAM(LKNT,3)
57136C...Calculate width.
57137 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57138 & IDLAM(LKNT,3),XLAM(LKNT))
57139 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57140C...Charge conjugate mode.
57141 LKNT=LKNT+1
57142 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57143 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57144 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57145 XLAM(LKNT)=XLAM(LKNT-1)
57146C...KINEMATICS CHECK
57147 IF (XLAM(LKNT).EQ.0D0) THEN
57148 LKNT=LKNT-2
57149 ENDIF
57150 ENDIF
57151 130 CONTINUE
57152 ENDIF
57153
57154 IF (IMSS(52).GE.1) THEN
57155C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57156C * CHI0 -> NUBAR_I + DBAR_J + D_K
57157 DO 140 ISC=0,26
57158 LKNT = LKNT+1
57159 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57160 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57161 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57162 XLAM(LKNT) = 0D0
57163C...Set coupling, and decay product masses on/off
57164 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57165 & ,MOD(ISC,3)+1)**2
57166 DCMASS=.FALSE.
57167 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57168 & DCMASS = .TRUE.
57169C...Resonance KF codes (1=I,2=J,3=K)
57170 KFR(1)=-IDLAM(LKNT,1)
57171 KFR(2)=-IDLAM(LKNT,2)
57172 KFR(3)=-IDLAM(LKNT,3)
57173C...Calculate width.
57174 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57175 & ,XLAM(LKNT))
57176 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57177C...Charge conjugate mode.
57178 LKNT=LKNT+1
57179 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57180 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57181 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57182 XLAM(LKNT)=XLAM(LKNT-1)
57183C...KINEMATICS CHECK
57184 IF (XLAM(LKNT).EQ.0D0) THEN
57185 LKNT=LKNT-2
57186 ENDIF
57187
57188C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57189 LKNT = LKNT+1
57190 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57191 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57192 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57193 XLAM(LKNT) = 0D0
57194C...Set coupling, and decay product masses on/off
57195 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57196 & ,MOD(ISC,3)+1)**2
57197 DCMASS=.FALSE.
57198 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57199 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57200C...Resonance KF codes (1=I,2=J,3=K)
57201 KFR(1)=-IDLAM(LKNT,1)
57202 KFR(2)=-IDLAM(LKNT,2)
57203 KFR(3)=-IDLAM(LKNT,3)
57204C...Calculate width.
57205 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57206 & ,XLAM(LKNT))
57207 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57208C...Charge conjugate mode.
57209 LKNT=LKNT+1
57210 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57211 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57212 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57213 XLAM(LKNT)=XLAM(LKNT-1)
57214C...KINEMATICS CHECK
57215 IF (XLAM(LKNT).EQ.0D0) THEN
57216 LKNT=LKNT-2
57217 ENDIF
57218 140 CONTINUE
57219 ENDIF
57220
57221 IF (IMSS(53).GE.1) THEN
57222C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57223C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57224 DO 150 ISC=0,26
57225C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57226 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57227 LKNT = LKNT+1
57228 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57229 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57230 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57231 XLAM(LKNT) = 0D0
57232C...Set coupling, and decay product masses on/off
57233 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
57234 & +1,MOD(ISC,3)+1)**2
57235 DCMASS=.FALSE.
57236 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57237 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57238C...Resonance KF codes (1=I,2=J,3=K)
57239 KFR(1) = IDLAM(LKNT,1)
57240 KFR(2) = IDLAM(LKNT,2)
57241 KFR(3) = IDLAM(LKNT,3)
57242C...Calculate width.
57243 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57244 & IDLAM(LKNT,3),XLAM(LKNT))
57245 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57246C...Charge conjugate mode.
57247 LKNT=LKNT+1
57248 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57249 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57250 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57251 XLAM(LKNT)=XLAM(LKNT-1)
57252C...KINEMATICS CHECK
57253 IF (XLAM(LKNT).EQ.0D0) THEN
57254 LKNT=LKNT-2
57255 ENDIF
57256 ENDIF
57257 150 CONTINUE
57258 ENDIF
57259 ENDIF
57260 ENDIF
57261
57262 RETURN
57263 END
57264
57265C*********************************************************************
57266
57267C...PYRVCH
57268C...Calculates R-violating chargino decay widths.
57269C...P. Z. Skands
57270
57271 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
57272
57273C...Double precision and integer declarations.
57274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57275 IMPLICIT INTEGER(I-N)
57276C...Parameter statement to help give large particle numbers.
57277 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57278 &KEXCIT=4000000,KDIMEN=5000000)
57279C...Commonblocks.
57280 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57281 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57282 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57283 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57284 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57285 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57286C...Local variables.
57287 DOUBLE PRECISION XLAM(0:400)
57288 INTEGER IDLAM(400,3), PYCOMP
57289C...Information from main routine to PYRVGW
57290 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57291 & ,DCMASS,KFR(3)
57292C...Auxiliary variables needed for BV (RV Gauge STOre)
57293 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57294 & ,RVLJKI,RVLJIK
57295C...Running quark masses
57296 DOUBLE PRECISION RMQ(6)
57297C...Decay product masses on/off
57298 LOGICAL DCMASS
57299 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57300 & /RVGSTO/
57301
57302
57303C...IF R-VIOLATION ON.
57304 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57305 KFSM=KFIN-KSUSY1
57306 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
57307C...WHICH CHARGINO ?
57308 NCHI = 1
57309 IF (KFSM.EQ.37) NCHI = 2
57310
57311C...Useful parameters for calculating the A and B constants.
57312C...SIGN OF MASS (Opposite convention as HERWIG)
57313 ISM = 1
57314 IF (SMW(NCHI).LT.0D0) ISM = -1
57315 WMASS = PMAS(PYCOMP(24),1)
57316 COSB = 1/(SQRT(1+RMSS(5)**2))
57317 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
57318 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
57319 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
57320 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
57321 C2 = UMIX(NCHI,1)
57322 C3 = VMIX(NCHI,1)
57323C...Running masses at Q^2=MCHI^2.
57324 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
57325 DO 100 I=1,6
57326 RMQ(I)=PYMRUN(I,SQMCHI)
57327 100 CONTINUE
57328
57329C... AB(x,y,z) coefficients:
57330C x=1-2 : A or B coefficient (1:A ; 2:B)
57331C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57332C 11-16:e,nu_e,mu,...)
57333C z=1-2 : Mass eigenstate number
57334 DO 110 I = 11,15,2
57335C...Intermediate sleptons
57336 AB(1,I,1) = 0D0
57337 AB(1,I,2) = 0D0
57338 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
57339 & SFMIX(I,1)*C2
57340 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
57341 & SFMIX(I,3)*C2
57342C...Intermediate sneutrinos
57343 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
57344 AB(1,I+1,2) = 0D0
57345 AB(2,I+1,1) = ISM*C3
57346 AB(2,I+1,2) = 0D0
57347C...Intermediate sdown
57348 J=I-10
57349 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
57350 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
57351 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
57352 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
57353C...Intermediate sup
57354 J=J+1
57355 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
57356 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
57357 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
57358 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
57359 110 CONTINUE
57360
57361C...LLE TYPE R-VIOLATION
57362 IF (IMSS(51).GE.1) THEN
57363C...LOOP OVER DECAY MODES
57364 DO 140 ISC=0,26
57365
57366C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57367 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57368 LKNT = LKNT+1
57369 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
57370 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
57371 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
57372 XLAM(LKNT) = 0D0
57373C...Set coupling, and decay product masses on/off
57374 RVLAMC = GW2 * 5D-1 *
57375 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57376 & **2
57377 DCMASS=.FALSE.
57378 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
57379C...Resonance KF codes (1=I,2=J,3=K).
57380 KFR(1) = 0
57381 KFR(2) = 0
57382 KFR(3) = -IDLAM(LKNT,3)+1
57383C...Calculate width.
57384 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57385 & IDLAM(LKNT,3),XLAM(LKNT))
57386 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57387C...KINEMATICS CHECK
57388 IF (XLAM(LKNT).EQ.0D0) THEN
57389 LKNT=LKNT-1
57390 ENDIF
57391
57392C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57393 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
57394 LKNT = LKNT+1
57395 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57396 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
57397 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
57398 XLAM(LKNT) = 0D0
57399C...Set coupling, and decay product masses on/off
57400 RVLAMC = GW2 * 5D-1 *
57401 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57402C...I,J SYMMETRY => FACTOR 2
57403 RVLAMC=2*RVLAMC
57404 DCMASS=.FALSE.
57405 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
57406C...Resonance KF codes (1=I,2=J,3=K)
57407 KFR(1)=IDLAM(LKNT,1)-1
57408 KFR(2)=IDLAM(LKNT,2)-1
57409 KFR(3)=0
57410C...Calculate width.
57411 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57412 & IDLAM(LKNT,3),XLAM(LKNT))
57413 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57414C...KINEMATICS CHECK
57415 IF (XLAM(LKNT).EQ.0D0) THEN
57416 LKNT=LKNT-1
57417 ENDIF
57418 130 ENDIF
57419
57420C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57421 LKNT = LKNT+1
57422 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57423 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57424 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57425 XLAM(LKNT) = 0D0
57426C...Set coupling, and decay product masses on/off
57427 RVLAMC = GW2 * 5D-1 *
57428 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57429C...I,J SYMMETRY => FACTOR 2
57430 RVLAMC=2*RVLAMC
57431 DCMASS=.FALSE.
57432 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
57433 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
57434C...Resonance KF codes (1=I,2=J,3=K)
57435 KFR(1) =-IDLAM(LKNT,1)+1
57436 KFR(2) =-IDLAM(LKNT,2)+1
57437 KFR(3) = 0
57438C...Calculate width.
57439 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57440 & IDLAM(LKNT,3),XLAM(LKNT))
57441 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57442C...KINEMATICS CHECK
57443 IF (XLAM(LKNT).EQ.0D0) THEN
57444 LKNT=LKNT-1
57445 ENDIF
57446 ENDIF
57447 140 CONTINUE
57448 ENDIF
57449
57450C...LQD TYPE R-VIOLATION
57451 IF (IMSS(52).GE.1) THEN
57452C...LOOP OVER DECAY MODES
57453 DO 180 ISC=0,26
57454
57455C...CHI+ -> NUBAR_I + DBAR_J + U_K
57456 LKNT = LKNT+1
57457 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57458 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57459 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57460 XLAM(LKNT) = 0D0
57461C...Set coupling, and decay product masses on/off
57462 RVLAMC = 3. * GW2 * 5D-1 *
57463 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57464 DCMASS=.FALSE.
57465 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
57466 & DCMASS = .TRUE.
57467C...Resonance KF codes (1=I,2=J,3=K)
57468 KFR(1)=0
57469 KFR(2)=0
57470 KFR(3)=-IDLAM(LKNT,3)+1
57471C...Calculate width.
57472 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57473 & ,XLAM(LKNT))
57474 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57475C...KINEMATICS CHECK
57476 IF (XLAM(LKNT).EQ.0D0) THEN
57477 LKNT=LKNT-1
57478 ENDIF
57479
57480C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57481 150 LKNT = LKNT+1
57482 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57483 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57484 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57485 XLAM(LKNT) = 0D0
57486C...Set coupling, and decay product masses on/off
57487 RVLAMC = 3. * GW2 * 5D-1 *
57488 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57489 DCMASS=.FALSE.
57490 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
57491 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
57492C...Resonance KF codes (1=I,2=J,3=K)
57493 KFR(1)=0
57494 KFR(2)=0
57495 KFR(3)=-IDLAM(LKNT,3)+1
57496C...Calculate width.
57497 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57498 & ,XLAM(LKNT))
57499 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57500C...KINEMATICS CHECK
57501 IF (XLAM(LKNT).EQ.0D0) THEN
57502 LKNT=LKNT-1
57503 ENDIF
57504
57505C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57506 160 LKNT = LKNT+1
57507 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57508 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57509 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57510 XLAM(LKNT) = 0D0
57511C...Set coupling, and decay product masses on/off
57512 RVLAMC = 3. * GW2 * 5D-1 *
57513 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57514 DCMASS = .FALSE.
57515 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
57516 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57517C...Resonance KF codes (1=I,2=J,3=K)
57518 KFR(1)=-IDLAM(LKNT,1)+1
57519 KFR(2)=-IDLAM(LKNT,2)+1
57520 KFR(3)=0
57521C...Calculate width.
57522 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57523 & ,XLAM(LKNT))
57524 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57525C...KINEMATICS CHECK
57526 IF (XLAM(LKNT).EQ.0D0) THEN
57527 LKNT=LKNT-1
57528 ENDIF
57529
57530C * CHI+ -> NU_I + U_J + DBAR_K.
57531 170 LKNT = LKNT+1
57532 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57533 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57534 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57535 XLAM(LKNT) = 0D0
57536C...Set coupling, and decay product masses on/off
57537 DCMASS = .FALSE.
57538 RVLAMC = 3. * GW2 * 5D-1 *
57539 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57540 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
57541 & DCMASS = .TRUE.
57542C...Resonance KF codes (1=I,2=J,3=K)
57543 KFR(1)=IDLAM(LKNT,1)-1
57544 KFR(2)=IDLAM(LKNT,2)-1
57545 KFR(3)=0
57546C...Calculate width.
57547 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57548 & ,XLAM(LKNT))
57549 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57550C...KINEMATICS CHECK
57551 IF (XLAM(LKNT).EQ.0D0) THEN
57552 LKNT=LKNT-1
57553 ENDIF
57554
57555 180 CONTINUE
57556 ENDIF
57557
57558C...UDD TYPE R-VIOLATION
57559C...These decays need special treatment since more than one BV coupling
57560C...contributes (with interference). Consider e.g. (symbolically)
57561C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57562C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57563C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57564C...The problem is that a single call to PYRVGW would evaluate all
57565C...these terms and sum them, but without the different couplings. The
57566C...way out is to call PYRVGW three times, once for the first line, once
57567C...for the second line, and then once for all the lines (it is
57568C...impossible to get just the last line out) without multiplying by
57569C...couplings. The last line is then obtained as the result of the third
57570C...call minus the results of the two first calls. Each term is then
57571C...multiplied by its respective coupling before the whole thing is
57572C...summed up in XLAM.
57573C...Note that with three interfering resonances, this procedure becomes
57574C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57575
57576 IF (IMSS(53).GE.1) THEN
57577C...LOOP OVER DECAY MODES
57578 DO 190 ISC=1,25
57579
57580C...CHI+ -> U_I + U_J + D_K
57581C...Decay mode I<->J symmetric.
57582 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
57583 LKNT = LKNT+1
57584 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
57585 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57586 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57587 XLAM(LKNT) = 0D0
57588C...Set coupling, and decay product masses on/off
57589 RVLAMC= 6. * GW2 * 5D-1
57590 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
57591 & +1)
57592 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57593 & +1)
57594 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
57595 & * RVLAMC
57596 DCMASS=.FALSE.
57597 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
57598 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
57599C...Resonance KF codes (1=I,2=J,3=K)
57600 KFR(1) = -IDLAM(LKNT,1)+1
57601 KFR(2) = 0
57602 KFR(3) = 0
57603C...Calculate width.
57604 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57605 & IDLAM(LKNT,3),XRESI)
57606C...Resonance KF codes (1=I,2=J,3=K)
57607 KFR(1) = 0
57608 KFR(2) = -IDLAM(LKNT,2)+1
57609 KFR(3) = 0
57610C...Calculate width.
57611 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57612 & IDLAM(LKNT,3),XRESJ)
57613C...Resonance KF codes (1=I,2=J,3=K)
57614 KFR(1) = -IDLAM(LKNT,1)+1
57615 KFR(2) = -IDLAM(LKNT,2)+1
57616 KFR(3) = 0
57617C...Calculate width.
57618 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57619 & IDLAM(LKNT,3),XRESIJ)
57620 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57621 XRESIJ = XRESIJ-XRESI-XRESJ
57622 ELSE
57623 XRESIJ = 0D0
57624 ENDIF
57625C...CALCULATE TOTAL WIDTH
57626 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
57627 & + RVLJIK*RVLIJK * XRESIJ
57628 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57629C...KINEMATICS CHECK
57630 IF (XLAM(LKNT).EQ.0D0) THEN
57631 LKNT=LKNT-1
57632 ENDIF
57633 ENDIF
57634C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57635C...Symmetry I<->J<->K.
57636 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
57637 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
57638 LKNT = LKNT+1
57639 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
57640 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57641 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57642 XLAM(LKNT) = 0D0
57643C...Set coupling, and decay product masses on/off
57644 RVLAMC = 6. * GW2 * 5D-1
57645 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57646 & +1)
57647 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
57648 & +1)
57649 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
57650 & +1)
57651 DCMASS = .FALSE.
57652 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
57653 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
57654C...Collect symmetry factors
57655 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
57656 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
57657 & RVLAMC = 5D-1 * RVLAMC
57658C...Resonance KF codes (1=I,2=J,3=K)
57659 KFR(1) = IDLAM(LKNT,1)-1
57660 KFR(2) = 0
57661 KFR(3) = 0
57662C...Calculate width.
57663 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57664 & IDLAM(LKNT,3),XRESI)
57665C...Resonance KF codes (1=I,2=J,3=K)
57666 KFR(1) = 0
57667 KFR(2) = IDLAM(LKNT,2)-1
57668 KFR(3) = 0
57669C...Calculate width.
57670 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57671 & IDLAM(LKNT,3),XRESJ)
57672C...Resonance KF codes (1=I,2=J,3=K)
57673 KFR(1) = 0
57674 KFR(2) = 0
57675 KFR(3) = IDLAM(LKNT,3)-1
57676C...Calculate width.
57677 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57678 & IDLAM(LKNT,3),XRESK)
57679C...Resonance KF codes (1=I,2=J,3=K)
57680 KFR(1) = IDLAM(LKNT,1)-1
57681 KFR(2) = IDLAM(LKNT,2)-1
57682 KFR(3) = 0
57683C...Calculate width.
57684 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57685 & IDLAM(LKNT,3),XRESIJ)
57686 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
57687 XRESIJ = XRESI+XRESJ-XRESIJ
57688 ELSE
57689 XRESIJ = 0D0
57690 ENDIF
57691C...Resonance KF codes (1=I,2=J,3=K)
57692 KFR(1) = 0
57693 KFR(2) = IDLAM(LKNT,2)-1
57694 KFR(3) = IDLAM(LKNT,3)-1
57695C...Calculate width.
57696 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57697 & IDLAM(LKNT,3),XRESJK)
57698 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
57699 XRESJK = XRESJ+XRESK-XRESJK
57700 ELSE
57701 XRESJK = 0D0
57702 ENDIF
57703C...Resonance KF codes (1=I,2=J,3=K)
57704 KFR(1) = IDLAM(LKNT,1)-1
57705 KFR(2) = 0
57706 KFR(3) = IDLAM(LKNT,3)-1
57707C...Calculate width.
57708 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57709 & IDLAM(LKNT,3),XRESIK)
57710 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
57711 XRESIK = XRESI+XRESK-XRESIK
57712 ELSE
57713 XRESIK = 0D0
57714 ENDIF
57715C...CALCULATE TOTAL WIDTH
57716 XLAM(LKNT) =
57717 & RVLIJK**2 * XRESI
57718 & + RVLJKI**2 * XRESJ
57719 & + RVLKIJ**2 * XRESK
57720 & + RVLIJK*RVLJKI * XRESIJ
57721 & + RVLIJK*RVLKIJ * XRESIK
57722 & + RVLJKI*RVLKIJ * XRESJK
57723 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
57724C...KINEMATICS CHECK
57725 IF (XLAM(LKNT).EQ.0D0) THEN
57726 LKNT=LKNT-1
57727 ENDIF
57728 ENDIF
57729 190 CONTINUE
57730 ENDIF
57731 ENDIF
57732 ENDIF
57733
57734 RETURN
57735 END
57736
57737C*********************************************************************
57738
57739C...PYRVGL
57740C...Calculates R-violating gluino decay widths.
57741C...See BV part of PYRVCH for comments about the way the BV decay width
57742C...is calculated. Same comments apply here.
57743C...P. Z. Skands
57744
57745 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
57746
57747C...Double precision and integer declarations.
57748 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57749 IMPLICIT INTEGER(I-N)
57750C...Parameter statement to help give large particle numbers.
57751 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57752 &KEXCIT=4000000,KDIMEN=5000000)
57753C...Commonblocks.
57754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57755 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57756 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57757 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57758 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57759 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57760C...Local variables.
57761 DOUBLE PRECISION XLAM(0:400)
57762 INTEGER IDLAM(400,3), PYCOMP
57763C...Information from main routine to PYRVGW
57764 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57765 & ,DCMASS,KFR(3)
57766C...Auxiliary variables needed for BV (RV Gauge STOre)
57767 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57768 & ,RVLJKI,RVLJIK
57769C...Running quark masses
57770 DOUBLE PRECISION RMQ(6)
57771C...Decay product masses on/off
57772 LOGICAL DCMASS
57773 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57774 & /RVGSTO/
57775
57776C...IF LQD OR UDD TYPE R-VIOLATION ON.
57777 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
57778 KFSM=KFIN-KSUSY1
57779
57780C... AB(x,y,z):
57781C x=1-2 : Select A or B coupling (1:A ; 2:B)
57782C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57783C 11-16:e,nu_e,mu,... not used here)
57784C z=1-2 : Mass eigenstate number
57785 DO 100 I = 1,6
57786C...A Couplings
57787 AB(1,I,1) = SFMIX(I,2)
57788 AB(1,I,2) = SFMIX(I,4)
57789C...B Couplings
57790 AB(2,I,1) = -SFMIX(I,1)
57791 AB(2,I,2) = -SFMIX(I,3)
57792 100 CONTINUE
57793 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
57794C...LQD DECAYS.
57795 IF (IMSS(52).GE.1) THEN
57796C...STEP IN I,J,K USING SINGLE COUNTER
57797 DO 120 ISC=0,26
57798C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57799 LKNT = LKNT+1
57800 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57801 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57802 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57803 XLAM(LKNT)=0D0
57804C...Set coupling, and decay product masses on/off
57805 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57806 & * 5D-1 * GSTR2
57807 DCMASS = .FALSE.
57808 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57809C...Resonance KF codes (1=I,2=J,3=K)
57810 KFR(1) = 0
57811 KFR(2) = -IDLAM(LKNT,2)
57812 KFR(3) = -IDLAM(LKNT,3)
57813C...Calculate width.
57814 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57815 & ,XLAM(LKNT))
57816C...Normalize
57817 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57818C...Charge conjugate mode.
57819 110 LKNT = LKNT+1
57820 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57821 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57822 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57823 XLAM(LKNT) = XLAM(LKNT-1)
57824C...KINEMATICS CHECK
57825 IF (XLAM(LKNT).EQ.0D0) THEN
57826 LKNT=LKNT-2
57827 ENDIF
57828
57829C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57830 LKNT = LKNT+1
57831 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57832 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57833 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57834 XLAM(LKNT)=0D0
57835C...Set coupling, and decay product masses on/off
57836 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57837 & **2* 5D-1 * GSTR2
57838 DCMASS = .FALSE.
57839 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57840 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57841C...Resonance KF codes (1=I,2=J,3=K)
57842 KFR(1) = 0
57843 KFR(2) = -IDLAM(LKNT,2)
57844 KFR(3) = -IDLAM(LKNT,3)
57845C...Calculate width.
57846 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57847 & ,XLAM(LKNT))
57848 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57849C...Charge conjugate mode.
57850 LKNT=LKNT+1
57851 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
57852 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
57853 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
57854 XLAM(LKNT) = XLAM(LKNT-1)
57855C...KINEMATICS CHECK
57856 IF (XLAM(LKNT).EQ.0D0) THEN
57857 LKNT=LKNT-2
57858 ENDIF
57859
57860 120 CONTINUE
57861 ENDIF
57862
57863C...UDD DECAYS.
57864 IF (IMSS(53).GE.1) THEN
57865C...STEP IN I,J,K USING SINGLE COUNTER
57866 DO 130 ISC=0,26
57867C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57868 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57869 LKNT = LKNT+1
57870 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57871 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57872 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57873 XLAM(LKNT)=0D0
57874C...Set coupling, and decay product masses on/off. A factor of 2 for
57875C...(N_C-1) has been used to cancel a factor 0.5.
57876 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57877 & **2 * GSTR2
57878 DCMASS = .FALSE.
57879 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57880 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57881C...Resonance KF codes (1=I,2=J,3=K)
57882 KFR(1) = IDLAM(LKNT,1)
57883 KFR(2) = 0
57884 KFR(3) = 0
57885C...Calculate width.
57886 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57887 & ,XRESI)
57888C...Resonance KF codes (1=I,2=J,3=K)
57889 KFR(1) = 0
57890 KFR(2) = IDLAM(LKNT,2)
57891 KFR(3) = 0
57892C...Calculate width.
57893 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57894 & ,XRESJ)
57895C...Resonance KF codes (1=I,2=J,3=K)
57896 KFR(1) = 0
57897 KFR(2) = 0
57898 KFR(3) = IDLAM(LKNT,3)
57899C...Calculate width.
57900 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57901 & ,XRESK)
57902C...Resonance KF codes (1=I,2=J,3=K)
57903 KFR(1) = IDLAM(LKNT,1)
57904 KFR(2) = IDLAM(LKNT,2)
57905 KFR(3) = 0
57906C...Calculate width.
57907 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57908 & ,XRESIJ)
57909C...Calculate interference function. (Factor -1/2 to make up for factor
57910C...-2 in PYRVGW.
57911 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57912 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
57913 ELSE
57914 XRESIJ = 0D0
57915 ENDIF
57916C...Resonance KF codes (1=I,2=J,3=K)
57917 KFR(1) = 0
57918 KFR(2) = IDLAM(LKNT,2)
57919 KFR(3) = IDLAM(LKNT,3)
57920C...Calculate width.
57921 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57922 & ,XRESJK)
57923 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
57924 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
57925 ELSE
57926 XRESJK = 0D0
57927 ENDIF
57928C...Resonance KF codes (1=I,2=J,3=K)
57929 KFR(1) = IDLAM(LKNT,1)
57930 KFR(2) = 0
57931 KFR(3) = IDLAM(LKNT,3)
57932C...Calculate width.
57933 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57934 & ,XRESIK)
57935 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
57936 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
57937 ELSE
57938 XRESIK = 0D0
57939 ENDIF
57940C...Calculate total width (factor 1/2 from 1/(N_C-1))
57941 XLAM(LKNT) = XRESI + XRESJ + XRESK
57942 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
57943C...Normalize
57944 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57945C...Charge conjugate mode.
57946 LKNT = LKNT+1
57947 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57948 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57949 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57950 XLAM(LKNT) = XLAM(LKNT-1)
57951C...KINEMATICS CHECK
57952 IF (XLAM(LKNT).EQ.0D0) THEN
57953 LKNT=LKNT-2
57954 ENDIF
57955 ENDIF
57956 130 CONTINUE
57957 ENDIF
57958 ENDIF
57959 RETURN
57960 END
57961
57962C*********************************************************************
57963
57964C...PYRVSB
57965C...Auxiliary function to PYRVSF for calculating R-Violating
57966C...sfermion widths. Though the decay products are most often treated
57967C...as massless in the calculation, the kinematical boundary of phase
57968C...space is tested using the true masses.
57969C...MODE = 1: All decay products massive
57970C...MODE = 2: Decay product 1 massless
57971C...MODE = 3: Decay product 2 massless
57972C...MODE = 4: All decay products massless
57973
57974 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
57975
57976 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
57977 IMPLICIT INTEGER (I-N)
57978 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57979 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57980 SAVE /PYDAT1/,/PYDAT2/
57981 DOUBLE PRECISION SM(3)
57982 INTEGER PYCOMP, KC(3)
57983 KC(1)=PYCOMP(KFIN)
57984 KC(2)=PYCOMP(ID1)
57985 KC(3)=PYCOMP(ID2)
57986 SM(1)=PMAS(KC(1),1)**2
57987 SM(2)=PMAS(KC(2),1)**2
57988 SM(3)=PMAS(KC(3),1)**2
57989C...Kinematics check
57990 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
57991 PYRVSB=0D0
57992 RETURN
57993 ENDIF
57994C...CM momenta squared
57995 IF (MODE.EQ.1) THEN
57996 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
57997 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
57998 ELSE IF (MODE.EQ.2) THEN
57999 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
58000 ELSE IF (MODE.EQ.3) THEN
58001 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58002 ELSE
58003 P2CM=SM(1)/4.
58004 ENDIF
58005C...Calculate Width
58006 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58007 RETURN
58008 END
58009
58010C*********************************************************************
58011
58012C...PYRVGW
58013C...Generalized Matrix Element for R-Violating 3-body widths.
58014C...P. Z. Skands
58015 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58016
58017 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58018 IMPLICIT INTEGER (I-N)
58019 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58020 &KEXCIT=4000000,KDIMEN=5000000)
58021 PARAMETER (EPS=1D-4)
58022 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58023 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58024 & ,DCMASS,KFR(3)
58025 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58026 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58027 DOUBLE PRECISION XLIM(3,3)
58028 INTEGER KC(0:3), PYCOMP
58029 LOGICAL DCMASS, DCHECK(6)
58030 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58031
58032 XLAM = 0D0
58033
58034 KC(0) = PYCOMP(KFIN)
58035 KC(1) = PYCOMP(ID1)
58036 KC(2) = PYCOMP(ID2)
58037 KC(3) = PYCOMP(ID3)
58038 RMS(0) = PMAS(KC(0),1)
58039 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58040 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58041 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58042C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58043 XLIM(1,1)=(RMS(1)+RMS(2))**2
58044 XLIM(1,2)=(RMS(0)-RMS(3))**2
58045 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58046 XLIM(2,1)=(RMS(2)+RMS(3))**2
58047 XLIM(2,2)=(RMS(0)-RMS(1))**2
58048 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58049 XLIM(3,1)=(RMS(1)+RMS(3))**2
58050 XLIM(3,2)=(RMS(0)-RMS(2))**2
58051 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58052C...Check Phase Space
58053 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58054 RETURN
58055 ENDIF
58056
58057C...INITIALIZE RESONANCE INFORMATION
58058 DO 110 JRES = 1,3
58059 DO 100 IMASS = 1,2
58060 IRES = 2*(JRES-1)+IMASS
58061 INTRES(IRES,1) = 0
58062 DCHECK(IRES) =.FALSE.
58063C...NO RIGHT-HANDED NEUTRINOS
58064 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58065 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58066 & .KFR(JRES).EQ.0) GOTO 100
58067 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58068 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58069 INTRES(IRES,1) = IABS(KFR(JRES))
58070 INTRES(IRES,2) = IMASS
58071 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58072 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58073 100 CONTINUE
58074 110 CONTINUE
58075
58076C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58077
58078C...RESONANCE CONTRIBUTIONS
58079C...(Only sum contributions where the resonance is off shell).
58080C...Store whether diagram on/off in DCHECK.
58081C...LOOP OVER MASS STATES
58082 DO 120 J=1,2
58083 IDR=J
58084 IF(INTRES(IDR,1).NE.0) THEN
58085
58086 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58087 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58088 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58089 DCHECK(IDR) =.TRUE.
58090 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58091 ENDIF
58092 ENDIF
58093
58094 IDR=J+2
58095 IF(INTRES(IDR,1).NE.0) THEN
58096 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58097 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58098 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58099 DCHECK(IDR) =.TRUE.
58100 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58101 ENDIF
58102 ENDIF
58103
58104 IDR=J+4
58105 IF(INTRES(IDR,1).NE.0) THEN
58106 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58107 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58108 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58109 DCHECK(IDR) =.TRUE.
58110 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58111 ENDIF
58112 ENDIF
58113 120 CONTINUE
58114C... L-R INTERFERENCES
58115C... (Only add contributions where both contributing diagrams
58116C... are non-resonant).
58117 IDR=1
58118 IF (DCHECK(1).AND.DCHECK(2)) THEN
58119C...Bug corrected 11/12 2001. Skands.
58120 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58121 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58122 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58123 ENDIF
58124
58125 IDR=3
58126 IF (DCHECK(3).AND.DCHECK(4)) THEN
58127 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58128 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58129 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58130 ENDIF
58131
58132 IDR=5
58133 IF (DCHECK(5).AND.DCHECK(6)) THEN
58134 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58135 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58136 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58137 ENDIF
58138C... TRUE INTERFERENCES
58139C... (Only add contributions where both contributing diagrams
58140C... are non-resonant).
58141 PREF=-2D0
58142 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58143 DO 140 IKR1 = 1,2
58144 DO 130 IKR2 = 1,2
58145 IDR = IKR1+2
58146 IDR2 = IKR2
58147 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58148 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58149 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58150 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58151 ENDIF
58152
58153 IDR = IKR1+4
58154 IDR2 = IKR2
58155 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58156 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58157 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58158 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58159 ENDIF
58160
58161 IDR = IKR1+4
58162 IDR2 = IKR2+2
58163 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58164 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58165 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58166 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58167 ENDIF
58168 130 CONTINUE
58169 140 CONTINUE
58170
58171 RETURN
58172 END
58173
58174C*********************************************************************
58175
58176C...PYRVI1
58177C...Function to integrate resonance contributions
58178
58179 FUNCTION PYRVI1(ID1,ID2,ID3)
58180
58181 IMPLICIT NONE
58182 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58183 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58184 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58185 LOGICAL MFLAG,DCMASS
58186 EXTERNAL PYRVG1,PYGAUS
58187 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58188 & ,DCMASS,KFR(3)
58189 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58190 SAVE/PYRVNV/,/PYRVPM/
58191C...Initialize mass and width information
58192 PYRVI1 = 0D0
58193 RM(0) = RMS(0)
58194 RM(1) = RMS(ID1)
58195 RM(2) = RMS(ID2)
58196 RM(3) = RMS(ID3)
58197 RESM(1)= RES(IDR,1)
58198 RESW(1)= RES(IDR,2)
58199C...A->B and B->A for antisparticles
58200 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58201 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58202C...Integration boundaries and mass flag
58203 LO = (RM(1)+RM(2))**2
58204 HI = (RM(0)-RM(3))**2
58205 MFLAG = DCMASS
58206 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
58207 RETURN
58208 END
58209
58210C*********************************************************************
58211
58212C...PYRVI2
58213C...Function to integrate L-R interference contributions
58214
58215 FUNCTION PYRVI2(ID1,ID2,ID3)
58216
58217 IMPLICIT NONE
58218 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58219 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58220 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58221 LOGICAL MFLAG,DCMASS
58222 EXTERNAL PYRVG2,PYGAUS
58223 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58224 & ,DCMASS,KFR(3)
58225 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58226 SAVE/PYRVNV/,/PYRVPM/
58227C...Initialize mass and width information
58228 PYRVI2 = 0D0
58229 RM(0) = RMS(0)
58230 RM(1) = RMS(ID1)
58231 RM(2) = RMS(ID2)
58232 RM(3) = RMS(ID3)
58233 RESM(1)= RES(IDR,1)
58234 RESW(1)= RES(IDR,2)
58235 RESM(2)= RES(IDR+1,1)
58236 RESW(2)= RES(IDR+1,2)
58237C...A->B and B->A for antisparticles
58238 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58239 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58240 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58241 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58242C...Boundaries and mass flag
58243 LO = (RM(1)+RM(2))**2
58244 HI = (RM(0)-RM(3))**2
58245 MFLAG = DCMASS
58246 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
58247 RETURN
58248 END
58249
58250C*********************************************************************
58251
58252C...PYRVI3
58253C...Function to integrate true interference contributions
58254
58255 FUNCTION PYRVI3(ID1,ID2,ID3)
58256
58257 IMPLICIT NONE
58258 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58259 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58260 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58261 LOGICAL MFLAG,DCMASS
58262 EXTERNAL PYRVG3,PYGAUS
58263 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58264 & ,DCMASS,KFR(3)
58265 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58266 SAVE/PYRVNV/,/PYRVPM/
58267C...Initialize mass and width information
58268 PYRVI3 = 0D0
58269 RM(0) = RMS(0)
58270 RM(1) = RMS(ID1)
58271 RM(2) = RMS(ID2)
58272 RM(3) = RMS(ID3)
58273 RESM(1)= RES(IDR,1)
58274 RESW(1)= RES(IDR,2)
58275 RESM(2)= RES(IDR2,1)
58276 RESW(2)= RES(IDR2,2)
58277C...A -> B and B -> A for antisparticles
58278 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58279 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58280 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58281 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58282C...Boundaries and mass flag
58283 LO = (RM(1)+RM(2))**2
58284 HI = (RM(0)-RM(3))**2
58285 MFLAG = DCMASS
58286 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
58287 RETURN
58288 END
58289
58290C*********************************************************************
58291
58292C...PYRVG1
58293C...Integrand for resonance contributions
58294
58295 FUNCTION PYRVG1(X)
58296
58297 IMPLICIT NONE
58298 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58299 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58300 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58301 LOGICAL MFLAG
58302 SAVE/PYRVPM/
58303 RVR = PYRVR(X,RESM(1),RESW(1))
58304 C1 = 2D0*SQRT(MAX(0D0,X))
58305 IF (.NOT.MFLAG) THEN
58306 E2 = X/C1
58307 E3 = (RM(0)**2-X)/C1
58308 DELTAY = 4D0*E2*E3
58309 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
58310 ELSE
58311 E2 = (X-RM(1)**2+RM(2)**2)/C1
58312 E3 = (RM(0)**2-X-RM(3)**2)/C1
58313 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58314 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58315 DELTAY = 4D0*SR1*SR2
58316 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
58317 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
58318 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
58319 ENDIF
58320 RETURN
58321 END
58322
58323C*********************************************************************
58324
58325C...PYRVG2
58326C...Integrand for L-R interference contributions
58327
58328 FUNCTION PYRVG2(X)
58329
58330 IMPLICIT NONE
58331 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58332 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58333 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58334 LOGICAL MFLAG
58335 SAVE/PYRVPM/
58336 C1 = 2D0*SQRT(MAX(0D0,X))
58337 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
58338 IF (.NOT.MFLAG) THEN
58339 E2 = X/C1
58340 E3 = (RM(0)**2-X)/C1
58341 DELTAY = 4D0*E2*E3
58342 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
58343 ELSE
58344 E2 = (X-RM(1)**2+RM(2)**2)/C1
58345 E3 = (RM(0)**2-X-RM(3)**2)/C1
58346 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58347 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58348 DELTAY = 4D0*SR1*SR2
58349 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
58350 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
58351 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
58352 ENDIF
58353 RETURN
58354 END
58355
58356C*********************************************************************
58357
58358C...PYRVG3
58359C...Function to do Y integration over true interference contributions
58360
58361 FUNCTION PYRVG3(X)
58362
58363 IMPLICIT NONE
58364 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58365C...Second Dalitz variable for PYRVG4
58366 COMMON/PYG2DX/X1
58367 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58368 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58369 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58370 LOGICAL MFLAG
58371 EXTERNAL PYGAU2,PYRVG4
58372 SAVE/PYRVPM/,/PYG2DX/
58373 PYRVG3=0D0
58374 C1=2D0*SQRT(MAX(1D-9,X))
58375 X1=X
58376 IF (.NOT.MFLAG) THEN
58377 E2 = X/C1
58378 E3 = (RM(0)**2-X)/C1
58379 YMIN = 0D0
58380 YMAX = 4D0*E2*E3
58381 ELSE
58382 E2 = (X-RM(1)**2+RM(2)**2)/C1
58383 E3 = (RM(0)**2-X-RM(3)**2)/C1
58384 SQ1 = (E2+E3)**2
58385 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58386 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58387 YMIN = SQ1-(SR1+SR2)**2
58388 YMAX = SQ1-(SR1-SR2)**2
58389 ENDIF
58390 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
58391 RETURN
58392 END
58393
58394C*********************************************************************
58395
58396C...PYRVG4
58397C...Integrand for true intereference contributions
58398
58399 FUNCTION PYRVG4(Y)
58400
58401 IMPLICIT NONE
58402 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58403 COMMON/PYG2DX/X
58404 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58405 LOGICAL MFLAG
58406 SAVE /PYRVPM/,/PYG2DX/
58407 PYRVG4=0D0
58408 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
58409 IF (.NOT.MFLAG) THEN
58410 PYRVG4 = RVS*B(1)*B(2)*X*Y
58411 ELSE
58412 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
58413 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
58414 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
58415 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
58416 ENDIF
58417 RETURN
58418 END
58419
58420C*********************************************************************
58421
58422C...PYRVR
58423C...Breit-Wigner for resonance contributions
58424
58425 FUNCTION PYRVR(Mab2,RM,RW)
58426
58427 IMPLICIT NONE
58428 DOUBLE PRECISION Mab2,RM,RW,PYRVR
58429 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
58430 RETURN
58431 END
58432
58433C*********************************************************************
58434
58435C...PYRVS
58436C...Interference function
58437
58438 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
58439
58440 IMPLICIT NONE
58441 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58442 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
58443 & +W1*W2*M1*M2)
58444 RETURN
58445 END
58446
58447C*********************************************************************
58448
58449C...PY1ENT
58450C...Stores one parton/particle in commonblock PYJETS.
58451
58452 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
58453
58454C...Double precision and integer declarations.
58455 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58456 IMPLICIT INTEGER(I-N)
58457 INTEGER PYK,PYCHGE,PYCOMP
58458C...Commonblocks.
58459 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58460 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58461 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58463
58464C...Standard checks.
58465 MSTU(28)=0
58466 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58467 IPA=MAX(1,IABS(IP))
58468 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
58469 &'(PY1ENT:) writing outside PYJETS memory')
58470 KC=PYCOMP(KF)
58471 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
58472
58473C...Find mass. Reset K, P and V vectors.
58474 PM=0D0
58475 IF(MSTU(10).EQ.1) PM=P(IPA,5)
58476 IF(MSTU(10).GE.2) PM=PYMASS(KF)
58477 DO 100 J=1,5
58478 K(IPA,J)=0
58479 P(IPA,J)=0D0
58480 V(IPA,J)=0D0
58481 100 CONTINUE
58482
58483C...Store parton/particle in K and P vectors.
58484 K(IPA,1)=1
58485 IF(IP.LT.0) K(IPA,1)=2
58486 K(IPA,2)=KF
58487 P(IPA,5)=PM
58488 P(IPA,4)=MAX(PE,PM)
58489 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
58490 P(IPA,1)=PA*SIN(THE)*COS(PHI)
58491 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
58492 P(IPA,3)=PA*COS(THE)
58493
58494C...Set N. Optionally fragment/decay.
58495 N=IPA
58496 IF(IP.EQ.0) CALL PYEXEC
58497
58498 RETURN
58499 END
58500
58501C*********************************************************************
58502
58503C...PY2ENT
58504C...Stores two partons/particles in their CM frame,
58505C...with the first along the +z axis.
58506
58507 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
58508
58509C...Double precision and integer declarations.
58510 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58511 IMPLICIT INTEGER(I-N)
58512 INTEGER PYK,PYCHGE,PYCOMP
58513C...Commonblocks.
58514 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58515 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58516 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58517 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58518
58519C...Standard checks.
58520 MSTU(28)=0
58521 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58522 IPA=MAX(1,IABS(IP))
58523 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
58524 &'(PY2ENT:) writing outside PYJETS memory')
58525 KC1=PYCOMP(KF1)
58526 KC2=PYCOMP(KF2)
58527 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
58528 &'(PY2ENT:) unknown flavour code')
58529
58530C...Find masses. Reset K, P and V vectors.
58531 PM1=0D0
58532 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58533 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58534 PM2=0D0
58535 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58536 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58537 DO 110 I=IPA,IPA+1
58538 DO 100 J=1,5
58539 K(I,J)=0
58540 P(I,J)=0D0
58541 V(I,J)=0D0
58542 100 CONTINUE
58543 110 CONTINUE
58544
58545C...Check flavours.
58546 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58547 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58548 IF(MSTU(19).EQ.1) THEN
58549 MSTU(19)=0
58550 ELSE
58551 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
58552 & '(PY2ENT:) unphysical flavour combination')
58553 ENDIF
58554 K(IPA,2)=KF1
58555 K(IPA+1,2)=KF2
58556
58557C...Store partons/particles in K vectors for normal case.
58558 IF(IP.GE.0) THEN
58559 K(IPA,1)=1
58560 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
58561 K(IPA+1,1)=1
58562
58563C...Store partons in K vectors for parton shower evolution.
58564 ELSE
58565 K(IPA,1)=3
58566 K(IPA+1,1)=3
58567 K(IPA,4)=MSTU(5)*(IPA+1)
58568 K(IPA,5)=K(IPA,4)
58569 K(IPA+1,4)=MSTU(5)*IPA
58570 K(IPA+1,5)=K(IPA+1,4)
58571 ENDIF
58572
58573C...Check kinematics and store partons/particles in P vectors.
58574 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
58575 &'(PY2ENT:) energy smaller than sum of masses')
58576 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
58577 &(2D0*PECM)
58578 P(IPA,3)=PA
58579 P(IPA,4)=SQRT(PM1**2+PA**2)
58580 P(IPA,5)=PM1
58581 P(IPA+1,3)=-PA
58582 P(IPA+1,4)=SQRT(PM2**2+PA**2)
58583 P(IPA+1,5)=PM2
58584
58585C...Set N. Optionally fragment/decay.
58586 N=IPA+1
58587 IF(IP.EQ.0) CALL PYEXEC
58588
58589 RETURN
58590 END
58591
58592C*********************************************************************
58593
58594C...PY3ENT
58595C...Stores three partons or particles in their CM frame,
58596C...with the first along the +z axis and the third in the (x,z)
58597C...plane with x > 0.
58598
58599 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
58600
58601C...Double precision and integer declarations.
58602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58603 IMPLICIT INTEGER(I-N)
58604 INTEGER PYK,PYCHGE,PYCOMP
58605C...Commonblocks.
58606 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58607 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58608 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58609 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58610
58611C...Standard checks.
58612 MSTU(28)=0
58613 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58614 IPA=MAX(1,IABS(IP))
58615 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
58616 &'(PY3ENT:) writing outside PYJETS memory')
58617 KC1=PYCOMP(KF1)
58618 KC2=PYCOMP(KF2)
58619 KC3=PYCOMP(KF3)
58620 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
58621 &'(PY3ENT:) unknown flavour code')
58622
58623C...Find masses. Reset K, P and V vectors.
58624 PM1=0D0
58625 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58626 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58627 PM2=0D0
58628 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58629 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58630 PM3=0D0
58631 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58632 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58633 DO 110 I=IPA,IPA+2
58634 DO 100 J=1,5
58635 K(I,J)=0
58636 P(I,J)=0D0
58637 V(I,J)=0D0
58638 100 CONTINUE
58639 110 CONTINUE
58640
58641C...Check flavours.
58642 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58643 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58644 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58645 IF(MSTU(19).EQ.1) THEN
58646 MSTU(19)=0
58647 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
58648 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
58649 & KQ1+KQ3.EQ.4)) THEN
58650 ELSE
58651 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
58652 ENDIF
58653 K(IPA,2)=KF1
58654 K(IPA+1,2)=KF2
58655 K(IPA+2,2)=KF3
58656
58657C...Store partons/particles in K vectors for normal case.
58658 IF(IP.GE.0) THEN
58659 K(IPA,1)=1
58660 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
58661 K(IPA+1,1)=1
58662 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
58663 K(IPA+2,1)=1
58664
58665C...Store partons in K vectors for parton shower evolution.
58666 ELSE
58667 K(IPA,1)=3
58668 K(IPA+1,1)=3
58669 K(IPA+2,1)=3
58670 KCS=4
58671 IF(KQ1.EQ.-1) KCS=5
58672 K(IPA,KCS)=MSTU(5)*(IPA+1)
58673 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
58674 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58675 K(IPA+1,9-KCS)=MSTU(5)*IPA
58676 K(IPA+2,KCS)=MSTU(5)*IPA
58677 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58678 ENDIF
58679
58680C...Check kinematics.
58681 MKERR=0
58682 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
58683 &0.5D0*X3*PECM.LE.PM3) MKERR=1
58684 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58685 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
58686 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
58687 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
58688 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
58689 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
58690 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
58691 IF(MKERR.NE.0) CALL PYERRM(13,
58692 &'(PY3ENT:) unphysical kinematical variable setup')
58693
58694C...Store partons/particles in P vectors.
58695 P(IPA,3)=PA1
58696 P(IPA,4)=SQRT(PA1**2+PM1**2)
58697 P(IPA,5)=PM1
58698 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
58699 P(IPA+2,3)=PA3*CTHE3
58700 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
58701 P(IPA+2,5)=PM3
58702 P(IPA+1,1)=-P(IPA+2,1)
58703 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
58704 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
58705 P(IPA+1,5)=PM2
58706
58707C...Set N. Optionally fragment/decay.
58708 N=IPA+2
58709 IF(IP.EQ.0) CALL PYEXEC
58710
58711 RETURN
58712 END
58713
58714C*********************************************************************
58715
58716C...PY4ENT
58717C...Stores four partons or particles in their CM frame, with
58718C...the first along the +z axis, the last in the xz plane with x > 0
58719C...and the second having y < 0 and y > 0 with equal probability.
58720
58721 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58722
58723C...Double precision and integer declarations.
58724 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58725 IMPLICIT INTEGER(I-N)
58726 INTEGER PYK,PYCHGE,PYCOMP
58727C...Commonblocks.
58728 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58729 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58730 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58731 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58732
58733C...Standard checks.
58734 MSTU(28)=0
58735 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58736 IPA=MAX(1,IABS(IP))
58737 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
58738 &'(PY4ENT:) writing outside PYJETS momory')
58739 KC1=PYCOMP(KF1)
58740 KC2=PYCOMP(KF2)
58741 KC3=PYCOMP(KF3)
58742 KC4=PYCOMP(KF4)
58743 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
58744 &'(PY4ENT:) unknown flavour code')
58745
58746C...Find masses. Reset K, P and V vectors.
58747 PM1=0D0
58748 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58749 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58750 PM2=0D0
58751 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58752 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58753 PM3=0D0
58754 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58755 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58756 PM4=0D0
58757 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
58758 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
58759 DO 110 I=IPA,IPA+3
58760 DO 100 J=1,5
58761 K(I,J)=0
58762 P(I,J)=0D0
58763 V(I,J)=0D0
58764 100 CONTINUE
58765 110 CONTINUE
58766
58767C...Check flavours.
58768 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58769 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58770 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58771 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
58772 IF(MSTU(19).EQ.1) THEN
58773 MSTU(19)=0
58774 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
58775 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
58776 & KQ1+KQ4.EQ.4)) THEN
58777 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
58778 & THEN
58779 ELSE
58780 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
58781 ENDIF
58782 K(IPA,2)=KF1
58783 K(IPA+1,2)=KF2
58784 K(IPA+2,2)=KF3
58785 K(IPA+3,2)=KF4
58786
58787C...Store partons/particles in K vectors for normal case.
58788 IF(IP.GE.0) THEN
58789 K(IPA,1)=1
58790 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
58791 K(IPA+1,1)=1
58792 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
58793 & K(IPA+1,1)=2
58794 K(IPA+2,1)=1
58795 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
58796 K(IPA+3,1)=1
58797
58798C...Store partons for parton shower evolution from q-g-g-qbar or
58799C...g-g-g-g event.
58800 ELSEIF(KQ1+KQ2.NE.0) THEN
58801 K(IPA,1)=3
58802 K(IPA+1,1)=3
58803 K(IPA+2,1)=3
58804 K(IPA+3,1)=3
58805 KCS=4
58806 IF(KQ1.EQ.-1) KCS=5
58807 K(IPA,KCS)=MSTU(5)*(IPA+1)
58808 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
58809 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58810 K(IPA+1,9-KCS)=MSTU(5)*IPA
58811 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
58812 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58813 K(IPA+3,KCS)=MSTU(5)*IPA
58814 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
58815
58816C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58817 ELSE
58818 K(IPA,1)=3
58819 K(IPA+1,1)=3
58820 K(IPA+2,1)=3
58821 K(IPA+3,1)=3
58822 K(IPA,4)=MSTU(5)*(IPA+1)
58823 K(IPA,5)=K(IPA,4)
58824 K(IPA+1,4)=MSTU(5)*IPA
58825 K(IPA+1,5)=K(IPA+1,4)
58826 K(IPA+2,4)=MSTU(5)*(IPA+3)
58827 K(IPA+2,5)=K(IPA+2,4)
58828 K(IPA+3,4)=MSTU(5)*(IPA+2)
58829 K(IPA+3,5)=K(IPA+3,4)
58830 ENDIF
58831
58832C...Check kinematics.
58833 MKERR=0
58834 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
58835 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
58836 &MKERR=1
58837 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58838 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
58839 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
58840 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
58841 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
58842 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
58843 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
58844 STHE4=SQRT(1D0-CTHE4**2)
58845 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
58846 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
58847 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
58848 STHE2=SQRT(1D0-CTHE2**2)
58849 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
58850 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
58851 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
58852 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
58853 IF(MKERR.EQ.1) CALL PYERRM(13,
58854 &'(PY4ENT:) unphysical kinematical variable setup')
58855
58856C...Store partons/particles in P vectors.
58857 P(IPA,3)=PA1
58858 P(IPA,4)=SQRT(PA1**2+PM1**2)
58859 P(IPA,5)=PM1
58860 P(IPA+3,1)=PA4*STHE4
58861 P(IPA+3,3)=PA4*CTHE4
58862 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
58863 P(IPA+3,5)=PM4
58864 P(IPA+1,1)=PA2*STHE2*CPHI2
58865 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
58866 P(IPA+1,3)=PA2*CTHE2
58867 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
58868 P(IPA+1,5)=PM2
58869 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
58870 P(IPA+2,2)=-P(IPA+1,2)
58871 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
58872 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
58873 P(IPA+2,5)=PM3
58874
58875C...Set N. Optionally fragment/decay.
58876 N=IPA+3
58877 IF(IP.EQ.0) CALL PYEXEC
58878
58879 RETURN
58880 END
58881
58882C*********************************************************************
58883
58884C...PY2FRM
58885C...An interface from a two-fermion generator to include
58886C...parton showers and hadronization.
58887
58888 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
58889
58890C...Double precision and integer declarations.
58891 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58892 IMPLICIT INTEGER(I-N)
58893 INTEGER PYK,PYCHGE,PYCOMP
58894C...Commonblocks.
58895 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58896 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58897 SAVE /PYJETS/,/PYDAT1/
58898C...Local arrays.
58899 DIMENSION IJOIN(2),INTAU(2)
58900
58901C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58902 IF(ICOM.EQ.0) THEN
58903 MSTU(28)=0
58904 CALL PYHEPC(2)
58905 ENDIF
58906
58907C...Loop through entries and pick up all final fermions/antifermions.
58908 I1=0
58909 I2=0
58910 DO 100 I=1,N
58911 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
58912 KFA=IABS(K(I,2))
58913 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
58914 IF(K(I,2).GT.0) THEN
58915 IF(I1.EQ.0) THEN
58916 I1=I
58917 ELSE
58918 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
58919 ENDIF
58920 ELSE
58921 IF(I2.EQ.0) THEN
58922 I2=I
58923 ELSE
58924 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
58925 ENDIF
58926 ENDIF
58927 ENDIF
58928 100 CONTINUE
58929
58930C...Check that event is arranged according to conventions.
58931 IF(I1.EQ.0.OR.I2.EQ.0) THEN
58932 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
58933 ENDIF
58934 IF(I2.LT.I1) THEN
58935 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
58936 ENDIF
58937
58938C...Check whether fermion pair is quarks or leptons.
58939 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
58940 IQL12=1
58941 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
58942 IQL12=2
58943 ELSE
58944 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
58945 ENDIF
58946
58947C...Decide whether to allow or not photon radiation in showers.
58948 MSTJ(41)=2
58949 IF(IRAD.EQ.0) MSTJ(41)=1
58950
58951C...Do colour joining and parton showers.
58952 IP1=I1
58953 IP2=I2
58954 IF(IQL12.EQ.1) THEN
58955 IJOIN(1)=IP1
58956 IJOIN(2)=IP2
58957 CALL PYJOIN(2,IJOIN)
58958 ENDIF
58959 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
58960 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
58961 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
58962 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
58963 ENDIF
58964
58965C...Do fragmentation and decays. Possibly except tau decay.
58966 IF(ITAU.EQ.0) THEN
58967 NTAU=0
58968 DO 110 I=1,N
58969 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
58970 NTAU=NTAU+1
58971 INTAU(NTAU)=I
58972 K(I,1)=11
58973 ENDIF
58974 110 CONTINUE
58975 ENDIF
58976 CALL PYEXEC
58977 IF(ITAU.EQ.0) THEN
58978 DO 120 I=1,NTAU
58979 K(INTAU(I),1)=1
58980 120 CONTINUE
58981 ENDIF
58982
58983C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58984 IF(ICOM.EQ.0) THEN
58985 MSTU(28)=0
58986 CALL PYHEPC(1)
58987 ENDIF
58988
58989 END
58990
58991C*********************************************************************
58992
58993C...PY4FRM
58994C...An interface from a four-fermion generator to include
58995C...parton showers and hadronization.
58996
58997 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
58998
58999C...Double precision and integer declarations.
59000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59001 IMPLICIT INTEGER(I-N)
59002 INTEGER PYK,PYCHGE,PYCOMP
59003C...Commonblocks.
59004 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59005 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59006 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59007 COMMON/PYINT1/MINT(400),VINT(400)
59008 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59009C...Local arrays.
59010 DIMENSION IJOIN(2),INTAU(4)
59011
59012C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59013 IF(ICOM.EQ.0) THEN
59014 MSTU(28)=0
59015 CALL PYHEPC(2)
59016 ENDIF
59017
59018C...Loop through entries and pick up all final fermions/antifermions.
59019 I1=0
59020 I2=0
59021 I3=0
59022 I4=0
59023 DO 100 I=1,N
59024 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59025 KFA=IABS(K(I,2))
59026 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59027 IF(K(I,2).GT.0) THEN
59028 IF(I1.EQ.0) THEN
59029 I1=I
59030 ELSEIF(I3.EQ.0) THEN
59031 I3=I
59032 ELSE
59033 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59034 ENDIF
59035 ELSE
59036 IF(I2.EQ.0) THEN
59037 I2=I
59038 ELSEIF(I4.EQ.0) THEN
59039 I4=I
59040 ELSE
59041 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59042 ENDIF
59043 ENDIF
59044 ENDIF
59045 100 CONTINUE
59046
59047C...Check that event is arranged according to conventions.
59048 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59049 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59050 ENDIF
59051 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59052 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59053 ENDIF
59054
59055C...Check which fermion pairs are quarks and which leptons.
59056 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59057 IQL12=1
59058 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59059 IQL12=2
59060 ELSE
59061 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59062 ENDIF
59063 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59064 IQL34=1
59065 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59066 IQL34=2
59067 ELSE
59068 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59069 ENDIF
59070
59071C...Decide whether to allow or not photon radiation in showers.
59072 MSTJ(41)=2
59073 IF(IRAD.EQ.0) MSTJ(41)=1
59074
59075C...Decide on dipole pairing.
59076 IP1=I1
59077 IP2=I2
59078 IP3=I3
59079 IP4=I4
59080 IF(IQL12.EQ.IQL34) THEN
59081 R1SQ=A1SQ
59082 R2SQ=A2SQ
59083 DELTA=ATOTSQ-A1SQ-A2SQ
59084 IF(ISTRAT.EQ.1) THEN
59085 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59086 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59087 ELSEIF(ISTRAT.EQ.2) THEN
59088 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59089 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59090 ENDIF
59091 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59092 IP2=I4
59093 IP4=I2
59094 ENDIF
59095 ENDIF
59096
59097C...If colour reconnection then bookkeep W+W- or Z0Z0
59098C...and copy q qbar q qbar consecutively.
59099 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59100 K(N+1,1)=11
59101 K(N+1,3)=IP1
59102 K(N+1,4)=N+3
59103 K(N+1,5)=N+4
59104 K(N+2,1)=11
59105 K(N+2,3)=IP3
59106 K(N+2,4)=N+5
59107 K(N+2,5)=N+6
59108 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59109 K(N+1,2)=23
59110 K(N+2,2)=23
59111 MINT(1)=22
59112 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59113 K(N+1,2)=24
59114 K(N+2,2)=-24
59115 MINT(1)=25
59116 ELSE
59117 K(N+1,2)=-24
59118 K(N+2,2)=24
59119 MINT(1)=25
59120 ENDIF
59121 DO 110 J=1,5
59122 K(N+3,J)=K(IP1,J)
59123 K(N+4,J)=K(IP2,J)
59124 K(N+5,J)=K(IP3,J)
59125 K(N+6,J)=K(IP4,J)
59126 P(N+1,J)=P(IP1,J)+P(IP2,J)
59127 P(N+2,J)=P(IP3,J)+P(IP4,J)
59128 P(N+3,J)=P(IP1,J)
59129 P(N+4,J)=P(IP2,J)
59130 P(N+5,J)=P(IP3,J)
59131 P(N+6,J)=P(IP4,J)
59132 V(N+1,J)=V(IP1,J)
59133 V(N+2,J)=V(IP3,J)
59134 V(N+3,J)=V(IP1,J)
59135 V(N+4,J)=V(IP2,J)
59136 V(N+5,J)=V(IP3,J)
59137 V(N+6,J)=V(IP4,J)
59138 110 CONTINUE
59139 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59140 & P(N+1,3)**2))
59141 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59142 & P(N+2,3)**2))
59143 K(N+3,3)=N+1
59144 K(N+4,3)=N+1
59145 K(N+5,3)=N+2
59146 K(N+6,3)=N+2
59147C...Remove original q qbar q qbar and update counters.
59148 K(IP1,1)=K(IP1,1)+10
59149 K(IP2,1)=K(IP2,1)+10
59150 K(IP3,1)=K(IP3,1)+10
59151 K(IP4,1)=K(IP4,1)+10
59152 IW1=N+1
59153 IW2=N+2
59154 NSD1=N+2
59155 IP1=N+3
59156 IP2=N+4
59157 IP3=N+5
59158 IP4=N+6
59159 N=N+6
59160 ENDIF
59161
59162C...Do colour joinings and parton showers.
59163 IF(IQL12.EQ.1) THEN
59164 IJOIN(1)=IP1
59165 IJOIN(2)=IP2
59166 CALL PYJOIN(2,IJOIN)
59167 ENDIF
59168 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59169 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59170 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59171 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59172 ENDIF
59173 NAFT1=N
59174 IF(IQL34.EQ.1) THEN
59175 IJOIN(1)=IP3
59176 IJOIN(2)=IP4
59177 CALL PYJOIN(2,IJOIN)
59178 ENDIF
59179 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59180 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59181 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59182 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59183 ENDIF
59184
59185C...Optionally do colour reconnection.
59186 MINT(32)=0
59187 MSTI(32)=0
59188 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59189 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
59190 MSTI(32)=MINT(32)
59191 ENDIF
59192
59193C...Do fragmentation and decays. Possibly except tau decay.
59194 IF(ITAU.EQ.0) THEN
59195 NTAU=0
59196 DO 120 I=1,N
59197 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59198 NTAU=NTAU+1
59199 INTAU(NTAU)=I
59200 K(I,1)=11
59201 ENDIF
59202 120 CONTINUE
59203 ENDIF
59204 CALL PYEXEC
59205 IF(ITAU.EQ.0) THEN
59206 DO 130 I=1,NTAU
59207 K(INTAU(I),1)=1
59208 130 CONTINUE
59209 ENDIF
59210
59211C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59212 IF(ICOM.EQ.0) THEN
59213 MSTU(28)=0
59214 CALL PYHEPC(1)
59215 ENDIF
59216
59217 END
59218
59219C*********************************************************************
59220
59221C...PY6FRM
59222C...An interface from a six-fermion generator to include
59223C...parton showers and hadronization.
59224
59225 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59226
59227C...Double precision and integer declarations.
59228 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59229 IMPLICIT INTEGER(I-N)
59230 INTEGER PYK,PYCHGE,PYCOMP
59231C...Commonblocks.
59232 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59233 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59234 SAVE /PYJETS/,/PYDAT1/
59235C...Local arrays.
59236 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
59237
59238C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59239 IF(ICOM.EQ.0) THEN
59240 MSTU(28)=0
59241 CALL PYHEPC(2)
59242 ENDIF
59243
59244C...Loop through entries and pick up all final fermions/antifermions.
59245 I1=0
59246 I2=0
59247 I3=0
59248 I4=0
59249 I5=0
59250 I6=0
59251 DO 100 I=1,N
59252 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59253 KFA=IABS(K(I,2))
59254 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59255 IF(K(I,2).GT.0) THEN
59256 IF(I1.EQ.0) THEN
59257 I1=I
59258 ELSEIF(I3.EQ.0) THEN
59259 I3=I
59260 ELSEIF(I5.EQ.0) THEN
59261 I5=I
59262 ELSE
59263 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
59264 ENDIF
59265 ELSE
59266 IF(I2.EQ.0) THEN
59267 I2=I
59268 ELSEIF(I4.EQ.0) THEN
59269 I4=I
59270 ELSEIF(I6.EQ.0) THEN
59271 I6=I
59272 ELSE
59273 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
59274 ENDIF
59275 ENDIF
59276 ENDIF
59277 100 CONTINUE
59278
59279C...Check that event is arranged according to conventions.
59280 IF(I5.EQ.0.OR.I6.EQ.0) THEN
59281 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
59282 ENDIF
59283 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
59284 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
59285 ENDIF
59286
59287C...Check which fermion pairs are quarks and which leptons.
59288 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59289 IQL12=1
59290 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59291 IQL12=2
59292 ELSE
59293 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
59294 ENDIF
59295 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59296 IQL34=1
59297 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59298 IQL34=2
59299 ELSE
59300 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
59301 ENDIF
59302 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
59303 IQL56=1
59304 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
59305 IQL56=2
59306 ELSE
59307 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
59308 ENDIF
59309
59310C...Decide whether to allow or not photon radiation in showers.
59311 MSTJ(41)=2
59312 IF(IRAD.EQ.0) MSTJ(41)=1
59313
59314C...Allow dipole pairings only among leptons and quarks separately.
59315 P12D=P12
59316 P13D=0D0
59317 IF(IQL34.EQ.IQL56) P13D=P13
59318 P21D=0D0
59319 IF(IQL12.EQ.IQL34) P21D=P21
59320 P23D=0D0
59321 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
59322 P31D=0D0
59323 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
59324 P32D=0D0
59325 IF(IQL12.EQ.IQL56) P32D=P32
59326
59327C...Decide whether t+tbar.
59328 ITOP=0
59329 IF(PYR(0).LT.PTOP) THEN
59330 ITOP=1
59331
59332C...If t+tbar: reconstruct t's.
59333 IT=N+1
59334 ITB=N+2
59335 DO 110 J=1,5
59336 K(IT,J)=0
59337 K(ITB,J)=0
59338 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
59339 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
59340 V(IT,J)=0D0
59341 V(ITB,J)=0D0
59342 110 CONTINUE
59343 K(IT,1)=1
59344 K(ITB,1)=1
59345 K(IT,2)=6
59346 K(ITB,2)=-6
59347 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
59348 & P(IT,3)**2))
59349 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
59350 & P(ITB,3)**2))
59351 N=N+2
59352
59353C...If t+tbar: colour join t's and let them shower.
59354 IJOIN(1)=IT
59355 IJOIN(2)=ITB
59356 CALL PYJOIN(2,IJOIN)
59357 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
59358 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
59359 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
59360
59361C...If t+tbar: pick up the t's after shower.
59362 ITNEW=IT
59363 ITBNEW=ITB
59364 DO 120 I=ITB+1,N
59365 IF(K(I,2).EQ.6) ITNEW=I
59366 IF(K(I,2).EQ.-6) ITBNEW=I
59367 120 CONTINUE
59368
59369C...If t+tbar: loop over two top systems.
59370 DO 200 IT1=1,2
59371 IF(IT1.EQ.1) THEN
59372 ITO=IT
59373 ITN=ITNEW
59374 IBO=I1
59375 IW1=I3
59376 IW2=I4
59377 ELSE
59378 ITO=ITB
59379 ITN=ITBNEW
59380 IBO=I2
59381 IW1=I5
59382 IW2=I6
59383 ENDIF
59384 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
59385 & '(PY6FRM:) not b in t decay')
59386
59387C...If t+tbar: find boost from original to new top frame.
59388 DO 130 J=1,3
59389 BETAO(J)=P(ITO,J)/P(ITO,4)
59390 BETAN(J)=P(ITN,J)/P(ITN,4)
59391 130 CONTINUE
59392
59393C...If t+tbar: boost copy of b by t shower and connect it in colour.
59394 N=N+1
59395 IB=N
59396 K(IB,1)=3
59397 K(IB,2)=K(IBO,2)
59398 K(IB,3)=ITN
59399 DO 140 J=1,5
59400 P(IB,J)=P(IBO,J)
59401 V(IB,J)=0D0
59402 140 CONTINUE
59403 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59404 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59405 K(IB,4)=MSTU(5)*ITN
59406 K(IB,5)=MSTU(5)*ITN
59407 K(ITN,4)=K(ITN,4)+IB
59408 K(ITN,5)=K(ITN,5)+IB
59409 K(ITN,1)=K(ITN,1)+10
59410 K(IBO,1)=K(IBO,1)+10
59411
59412C...If t+tbar: construct W recoiling against b.
59413 N=N+1
59414 IW=N
59415 DO 150 J=1,5
59416 K(IW,J)=0
59417 V(IW,J)=0D0
59418 150 CONTINUE
59419 K(IW,1)=1
59420 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
59421 IF(IABS(KCHW).EQ.3) THEN
59422 K(IW,2)=ISIGN(24,KCHW)
59423 ELSE
59424 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
59425 ENDIF
59426 K(IW,3)=IW1
59427
59428C...If t+tbar: construct W momentum, including boost by t shower.
59429 DO 160 J=1,4
59430 P(IW,J)=P(IW1,J)+P(IW2,J)
59431 160 CONTINUE
59432 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
59433 & P(IW,3)**2))
59434 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59435 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59436
59437C...If t+tbar: boost b and W to top rest frame.
59438 DO 170 J=1,3
59439 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
59440 170 CONTINUE
59441 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59442 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59443
59444C...If t+tbar: let b shower and pick up modified W.
59445 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
59446 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
59447 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
59448 DO 180 I=IW,N
59449 IF(IABS(K(I,2)).EQ.24) IWM=I
59450 180 CONTINUE
59451
59452C...If t+tbar: take copy of W decay products.
59453 DO 190 J=1,5
59454 K(N+1,J)=K(IW1,J)
59455 P(N+1,J)=P(IW1,J)
59456 V(N+1,J)=V(IW1,J)
59457 K(N+2,J)=K(IW2,J)
59458 P(N+2,J)=P(IW2,J)
59459 V(N+2,J)=V(IW2,J)
59460 190 CONTINUE
59461 K(IW1,1)=K(IW1,1)+10
59462 K(IW2,1)=K(IW2,1)+10
59463 K(IWM,1)=K(IWM,1)+10
59464 K(IWM,4)=N+1
59465 K(IWM,5)=N+2
59466 K(N+1,3)=IWM
59467 K(N+2,3)=IWM
59468 IF(IT1.EQ.1) THEN
59469 I3=N+1
59470 I4=N+2
59471 ELSE
59472 I5=N+1
59473 I6=N+2
59474 ENDIF
59475 N=N+2
59476
59477C...If t+tbar: boost W decay products, first by effects of t shower,
59478C...then by those of b shower. b and its shower simple boost back.
59479 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59480 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59481 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59482 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
59483 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
59484 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
59485 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
59486 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
59487 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
59488 200 CONTINUE
59489 ENDIF
59490
59491C...Decide on dipole pairing.
59492 IP1=I1
59493 IP3=I3
59494 IP5=I5
59495 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
59496 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
59497 IP2=I2
59498 IP4=I4
59499 IP6=I6
59500 ELSEIF(PRN.LT.P12D+P13D) THEN
59501 IP2=I2
59502 IP4=I6
59503 IP6=I4
59504 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
59505 IP2=I4
59506 IP4=I2
59507 IP6=I6
59508 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
59509 IP2=I4
59510 IP4=I6
59511 IP6=I2
59512 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
59513 IP2=I6
59514 IP4=I2
59515 IP6=I4
59516 ELSE
59517 IP2=I6
59518 IP4=I4
59519 IP6=I2
59520 ENDIF
59521
59522C...Do colour joinings and parton showers
59523C...(except ones already made for t+tbar).
59524 IF(ITOP.EQ.0) THEN
59525 IF(IQL12.EQ.1) THEN
59526 IJOIN(1)=IP1
59527 IJOIN(2)=IP2
59528 CALL PYJOIN(2,IJOIN)
59529 ENDIF
59530 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59531 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59532 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59533 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59534 ENDIF
59535 ENDIF
59536 IF(IQL34.EQ.1) THEN
59537 IJOIN(1)=IP3
59538 IJOIN(2)=IP4
59539 CALL PYJOIN(2,IJOIN)
59540 ENDIF
59541 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59542 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59543 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59544 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59545 ENDIF
59546 IF(IQL56.EQ.1) THEN
59547 IJOIN(1)=IP5
59548 IJOIN(2)=IP6
59549 CALL PYJOIN(2,IJOIN)
59550 ENDIF
59551 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
59552 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
59553 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
59554 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
59555 ENDIF
59556
59557C...Do fragmentation and decays. Possibly except tau decay.
59558 IF(ITAU.EQ.0) THEN
59559 NTAU=0
59560 DO 210 I=1,N
59561 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59562 NTAU=NTAU+1
59563 INTAU(NTAU)=I
59564 K(I,1)=11
59565 ENDIF
59566 210 CONTINUE
59567 ENDIF
59568 CALL PYEXEC
59569 IF(ITAU.EQ.0) THEN
59570 DO 220 I=1,NTAU
59571 K(INTAU(I),1)=1
59572 220 CONTINUE
59573 ENDIF
59574
59575C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59576 IF(ICOM.EQ.0) THEN
59577 MSTU(28)=0
59578 CALL PYHEPC(1)
59579 ENDIF
59580
59581 END
59582
59583C*********************************************************************
59584
59585C...PY4JET
59586C...An interface from a four-parton generator to include
59587C...parton showers and hadronization.
59588
59589 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
59590
59591C...Double precision and integer declarations.
59592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59593 IMPLICIT INTEGER(I-N)
59594 INTEGER PYK,PYCHGE,PYCOMP
59595C...Commonblocks.
59596 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59597 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59598 SAVE /PYJETS/,/PYDAT1/
59599C...Local arrays.
59600 DIMENSION IJOIN(2),PTOT(4),BETA(3)
59601
59602C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59603 IF(ICOM.EQ.0) THEN
59604 MSTU(28)=0
59605 CALL PYHEPC(2)
59606 ENDIF
59607
59608C...Loop through entries and pick up all final partons.
59609 I1=0
59610 I2=0
59611 I3=0
59612 I4=0
59613 DO 100 I=1,N
59614 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59615 KFA=IABS(K(I,2))
59616 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
59617 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
59618 IF(I1.EQ.0) THEN
59619 I1=I
59620 ELSEIF(I3.EQ.0) THEN
59621 I3=I
59622 ELSE
59623 CALL PYERRM(16,'(PY4JET:) more than two quarks')
59624 ENDIF
59625 ELSEIF(K(I,2).LT.0) THEN
59626 IF(I2.EQ.0) THEN
59627 I2=I
59628 ELSEIF(I4.EQ.0) THEN
59629 I4=I
59630 ELSE
59631 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
59632 ENDIF
59633 ELSE
59634 IF(I3.EQ.0) THEN
59635 I3=I
59636 ELSEIF(I4.EQ.0) THEN
59637 I4=I
59638 ELSE
59639 CALL PYERRM(16,'(PY4JET:) more than two gluons')
59640 ENDIF
59641 ENDIF
59642 ENDIF
59643 100 CONTINUE
59644
59645C...Check that event is arranged according to conventions.
59646 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
59647 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
59648 ENDIF
59649 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59650 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
59651 ENDIF
59652
59653C...Check whether second pair are quarks or gluons.
59654 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59655 IQG34=1
59656 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
59657 IQG34=2
59658 ELSE
59659 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
59660 ENDIF
59661
59662C...Boost partons to their cm frame.
59663 DO 110 J=1,4
59664 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
59665 110 CONTINUE
59666 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
59667 DO 120 J=1,3
59668 BETA(J)=PTOT(J)/PTOT(4)
59669 120 CONTINUE
59670 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59671 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59672 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59673 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59674 NSAV=N
59675
59676C...Decide and set up shower history for q qbar q' qbar' events.
59677 IF(IQG34.EQ.1) THEN
59678 W1=PY4JTW(0,I1,I3,I4)
59679 W2=PY4JTW(0,I2,I3,I4)
59680 IF(W1.GT.PYR(0)*(W1+W2)) THEN
59681 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59682 ELSE
59683 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59684 ENDIF
59685
59686C...Decide and set up shower history for q qbar g g events.
59687 ELSE
59688 W1=PY4JTW(I1,I3,I2,I4)
59689 W2=PY4JTW(I1,I4,I2,I3)
59690 W3=PY4JTW(0,I3,I1,I4)
59691 W4=PY4JTW(0,I4,I1,I3)
59692 W5=PY4JTW(0,I3,I2,I4)
59693 W6=PY4JTW(0,I4,I2,I3)
59694 W7=PY4JTW(0,I1,I3,I4)
59695 W8=PY4JTW(0,I2,I3,I4)
59696 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
59697 IF(W1.GT.WR) THEN
59698 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
59699 ELSEIF(W1+W2.GT.WR) THEN
59700 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
59701 ELSEIF(W1+W2+W3.GT.WR) THEN
59702 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
59703 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
59704 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
59705 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
59706 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
59707 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
59708 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
59709 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
59710 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59711 ELSE
59712 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59713 ENDIF
59714 ENDIF
59715
59716C...Boost back original partons and mark them as deleted.
59717 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
59718 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
59719 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
59720 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
59721 K(I1,1)=K(I1,1)+10
59722 K(I2,1)=K(I2,1)+10
59723 K(I3,1)=K(I3,1)+10
59724 K(I4,1)=K(I4,1)+10
59725
59726C...Rotate shower initiating partons to be along z axis.
59727 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
59728 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
59729 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
59730 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
59731
59732C...Set up copy of shower initiating partons as on mass shell.
59733 DO 140 I=N+1,N+2
59734 DO 130 J=1,5
59735 K(I,J)=0
59736 P(I,J)=0D0
59737 V(I,J)=V(I1,J)
59738 130 CONTINUE
59739 K(I,1)=1
59740 K(I,2)=K(I-6,2)
59741 140 CONTINUE
59742 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
59743 K(N+1,3)=I1
59744 P(N+1,5)=P(I1,5)
59745 K(N+2,3)=I2
59746 P(N+2,5)=P(I2,5)
59747 ELSE
59748 K(N+1,3)=I2
59749 P(N+1,5)=P(I2,5)
59750 K(N+2,3)=I1
59751 P(N+2,5)=P(I1,5)
59752 ENDIF
59753 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
59754 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
59755 P(N+1,3)=PABS
59756 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
59757 P(N+2,3)=-PABS
59758 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
59759 N=N+2
59760
59761C...Decide whether to allow or not photon radiation in showers.
59762C...Connect up colours.
59763 MSTJ(41)=2
59764 IF(IRAD.EQ.0) MSTJ(41)=1
59765 IJOIN(1)=N-1
59766 IJOIN(2)=N
59767 CALL PYJOIN(2,IJOIN)
59768
59769C...Decide on maximum virtuality and do parton shower.
59770 IF(PMAX.LT.PARJ(82)) THEN
59771 PQMAX=QMAX
59772 ELSE
59773 PQMAX=PMAX
59774 ENDIF
59775 CALL PYSHOW(NSAV+1,-100,PQMAX)
59776
59777C...Rotate and boost back system.
59778 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
59779
59780C...Do fragmentation and decays.
59781 CALL PYEXEC
59782
59783C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59784 IF(ICOM.EQ.0) THEN
59785 MSTU(28)=0
59786 CALL PYHEPC(1)
59787 ENDIF
59788
59789 RETURN
59790 END
59791
59792C*********************************************************************
59793
59794C...PY4JTW
59795C...Auxiliary to PY4JET, to evaluate weight of configuration.
59796
59797 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
59798
59799C...Double precision and integer declarations.
59800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59801 IMPLICIT INTEGER(I-N)
59802 INTEGER PYK,PYCHGE,PYCOMP
59803C...Commonblocks.
59804 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59805 SAVE /PYJETS/
59806
59807C...First case: when both original partons radiate.
59808C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59809 IF(IA1.NE.0) THEN
59810 DO 100 J=1,4
59811 P(N+1,J)=P(IA1,J)+P(IA2,J)
59812 P(N+2,J)=P(IA3,J)+P(IA4,J)
59813 100 CONTINUE
59814 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59815 & P(N+1,3)**2))
59816 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59817 & P(N+2,3)**2))
59818 Z1=P(IA1,4)/P(N+1,4)
59819 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
59820 Z2=P(IA3,4)/P(N+2,4)
59821 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
59822
59823C...Second case: when one original parton radiates to three.
59824C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59825 ELSE
59826 DO 110 J=1,4
59827 P(N+2,J)=P(IA3,J)+P(IA4,J)
59828 P(N+1,J)=P(N+2,J)+P(IA2,J)
59829 110 CONTINUE
59830 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59831 & P(N+1,3)**2))
59832 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59833 & P(N+2,3)**2))
59834 IF(K(IA2,2).EQ.21) THEN
59835 Z1=P(N+2,4)/P(N+1,4)
59836 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59837 & P(IA3,5)**2)
59838 ELSE
59839 Z1=P(IA2,4)/P(N+1,4)
59840 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59841 & P(IA2,5)**2)
59842 ENDIF
59843 Z2=P(IA3,4)/P(N+2,4)
59844 IF(K(IA2,2).EQ.21) THEN
59845 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
59846 & P(IA3,5)**2)
59847 ELSEIF(K(IA3,2).EQ.21) THEN
59848 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
59849 ELSE
59850 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
59851 ENDIF
59852 ENDIF
59853
59854C...Total weight.
59855 PY4JTW=WT1*WT2
59856
59857 RETURN
59858 END
59859
59860C*********************************************************************
59861
59862C...PY4JTS
59863C...Auxiliary to PY4JET, to set up chosen configuration.
59864
59865 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
59866
59867C...Double precision and integer declarations.
59868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59869 IMPLICIT INTEGER(I-N)
59870 INTEGER PYK,PYCHGE,PYCOMP
59871C...Commonblocks.
59872 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59873 SAVE /PYJETS/
59874
59875C...Reset info.
59876 DO 110 I=N+1,N+6
59877 DO 100 J=1,5
59878 K(I,J)=0
59879 V(I,J)=V(IA2,J)
59880 100 CONTINUE
59881 K(I,1)=16
59882 110 CONTINUE
59883
59884C...First case: when both original partons radiate.
59885C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59886 IF(IA1.NE.0) THEN
59887
59888C...Set up flavour and history pointers for new partons.
59889 K(N+1,2)=K(IA1,2)
59890 K(N+2,2)=K(IA3,2)
59891 K(N+3,2)=K(IA1,2)
59892 K(N+4,2)=K(IA2,2)
59893 K(N+5,2)=K(IA3,2)
59894 K(N+6,2)=K(IA4,2)
59895 K(N+1,3)=IA1
59896 K(N+1,4)=N+3
59897 K(N+1,5)=N+4
59898 K(N+2,3)=IA3
59899 K(N+2,4)=N+5
59900 K(N+2,5)=N+6
59901 K(N+3,3)=N+1
59902 K(N+4,3)=N+1
59903 K(N+5,3)=N+2
59904 K(N+6,3)=N+2
59905
59906C...Set up momenta for new partons.
59907 DO 120 J=1,5
59908 P(N+1,J)=P(IA1,J)+P(IA2,J)
59909 P(N+2,J)=P(IA3,J)+P(IA4,J)
59910 P(N+3,J)=P(IA1,J)
59911 P(N+4,J)=P(IA2,J)
59912 P(N+5,J)=P(IA3,J)
59913 P(N+6,J)=P(IA4,J)
59914 120 CONTINUE
59915 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59916 & P(N+1,3)**2))
59917 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59918 & P(N+2,3)**2))
59919 QMAX=MIN(P(N+1,5),P(N+2,5))
59920
59921C...Second case: q radiates twice.
59922C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59923C...IA5=N+2 does not radiate.
59924 ELSEIF(K(IA2,2).EQ.21) THEN
59925
59926C...Set up flavour and history pointers for new partons.
59927 K(N+1,2)=K(IA3,2)
59928 K(N+2,2)=K(IA5,2)
59929 K(N+3,2)=K(IA3,2)
59930 K(N+4,2)=K(IA2,2)
59931 K(N+5,2)=K(IA3,2)
59932 K(N+6,2)=K(IA4,2)
59933 K(N+1,3)=IA3
59934 K(N+1,4)=N+3
59935 K(N+1,5)=N+4
59936 K(N+2,3)=IA5
59937 K(N+3,3)=N+1
59938 K(N+3,4)=N+5
59939 K(N+3,5)=N+6
59940 K(N+4,3)=N+1
59941 K(N+5,3)=N+3
59942 K(N+6,3)=N+3
59943
59944C...Set up momenta for new partons.
59945 DO 130 J=1,5
59946 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59947 P(N+2,J)=P(IA5,J)
59948 P(N+3,J)=P(IA3,J)+P(IA4,J)
59949 P(N+4,J)=P(IA2,J)
59950 P(N+5,J)=P(IA3,J)
59951 P(N+6,J)=P(IA4,J)
59952 130 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+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
59956 & P(N+3,3)**2))
59957 QMAX=P(N+3,5)
59958
59959C...Third case: q radiates g, g branches.
59960C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59961C...IA5=N+2 does not radiate.
59962 ELSE
59963
59964C...Set up flavour and history pointers for new partons.
59965 K(N+1,2)=K(IA2,2)
59966 K(N+2,2)=K(IA5,2)
59967 K(N+3,2)=K(IA2,2)
59968 K(N+4,2)=21
59969 K(N+5,2)=K(IA3,2)
59970 K(N+6,2)=K(IA4,2)
59971 K(N+1,3)=IA2
59972 K(N+1,4)=N+3
59973 K(N+1,5)=N+4
59974 K(N+2,3)=IA5
59975 K(N+3,3)=N+1
59976 K(N+4,3)=N+1
59977 K(N+4,4)=N+5
59978 K(N+4,5)=N+6
59979 K(N+5,3)=N+4
59980 K(N+6,3)=N+4
59981
59982C...Set up momenta for new partons.
59983 DO 140 J=1,5
59984 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59985 P(N+2,J)=P(IA5,J)
59986 P(N+3,J)=P(IA2,J)
59987 P(N+4,J)=P(IA3,J)+P(IA4,J)
59988 P(N+5,J)=P(IA3,J)
59989 P(N+6,J)=P(IA4,J)
59990 140 CONTINUE
59991 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59992 & P(N+1,3)**2))
59993 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
59994 & P(N+4,3)**2))
59995 QMAX=P(N+4,5)
59996
59997 ENDIF
59998 N=N+6
59999
60000 RETURN
60001 END
60002
60003C*********************************************************************
60004
60005C...PYJOIN
60006C...Connects a sequence of partons with colour flow indices,
60007C...as required for subsequent shower evolution (or other operations).
60008
60009 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60010
60011C...Double precision and integer declarations.
60012 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60013 IMPLICIT INTEGER(I-N)
60014 INTEGER PYK,PYCHGE,PYCOMP
60015C...Commonblocks.
60016 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60017 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60018 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60019 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60020C...Local array.
60021 DIMENSION IJOIN(*)
60022
60023C...Check that partons are of right types to be connected.
60024 IF(NJOIN.LT.2) GOTO 120
60025 KQSUM=0
60026 DO 100 IJN=1,NJOIN
60027 I=IJOIN(IJN)
60028 IF(I.LE.0.OR.I.GT.N) GOTO 120
60029 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60030 KC=PYCOMP(K(I,2))
60031 IF(KC.EQ.0) GOTO 120
60032 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60033 IF(KQ.EQ.0) GOTO 120
60034 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60035 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60036 IF(IJN.EQ.1) KQS=KQ
60037 100 CONTINUE
60038 IF(KQSUM.NE.0) GOTO 120
60039
60040C...Connect the partons sequentially (closing for gluon loop).
60041 KCS=(9-KQS)/2
60042 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60043 DO 110 IJN=1,NJOIN
60044 I=IJOIN(IJN)
60045 K(I,1)=3
60046 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60047 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60048 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60049 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60050 K(I,KCS)=MSTU(5)*IN
60051 K(I,9-KCS)=MSTU(5)*IP
60052 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60053 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60054 110 CONTINUE
60055
60056C...Error exit: no action taken.
60057 RETURN
60058 120 CALL PYERRM(12,
60059 &'(PYJOIN:) given entries can not be joined by one string')
60060
60061 RETURN
60062 END
60063
60064C*********************************************************************
60065
60066C...PYGIVE
60067C...Sets values of commonblock variables.
60068
60069 SUBROUTINE PYGIVE(CHIN)
60070
60071C...Double precision and integer declarations.
60072 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60073 IMPLICIT INTEGER(I-N)
60074 INTEGER PYK,PYCHGE,PYCOMP
60075C...Commonblocks.
60076 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60079 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60080 COMMON/PYDAT4/CHAF(500,2)
60081 CHARACTER CHAF*16
60082 COMMON/PYDATR/MRPY(6),RRPY(100)
60083 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60084 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60085 COMMON/PYINT1/MINT(400),VINT(400)
60086 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60087 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60088 COMMON/PYINT4/MWID(500),WIDS(500,5)
60089 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60090 COMMON/PYINT6/PROC(0:500)
60091 CHARACTER PROC*28
60092 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60093 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60094 &XPDIR(-6:6)
60095 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60096 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60097 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60098 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60099 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60100 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60101 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60102C...Local arrays and character variables.
60103 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60104 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60105 &CHINR*16,CHDIG*10
60106 DIMENSION MSVAR(56,8)
60107
60108C...For each variable to be translated give: name,
60109C...integer/real/character, no. of indices, lower&upper index bounds.
60110 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60111 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60112 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60113 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60114 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60115 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60116 &'ITCM','RTCM','IUED','RUED'/
60117 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60118 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60119 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60120 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60121 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60122 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60123 &1,1,1,6,4*0, 2,1,1,100,4*0,
60124 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60125 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60126 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60127 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60128 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60129 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60130 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60131 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60132 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60133 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60134 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60135 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60136 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60137
60138C...Length of character variable. Subdivide it into instructions.
60139 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60140 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60141 CHBIT=CHIN//' '
60142 LBIT=101
60143 100 LBIT=LBIT-1
60144 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60145 LTOT=0
60146 DO 110 LCOM=1,LBIT
60147 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60148 LTOT=LTOT+1
60149 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60150 110 CONTINUE
60151 LLOW=0
60152 120 LHIG=LLOW+1
60153 130 LHIG=LHIG+1
60154 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60155 LBIT=LHIG-LLOW-1
60156 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60157
60158C...Send off decay-mode on/off commands to PYONOF.
60159 IONOF=0
60160 DO 135 LDIG=1,10
60161 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60162 135 CONTINUE
60163 IF(IONOF.EQ.1) THEN
60164 CALL PYONOF(CHIN)
60165 RETURN
60166 ENDIF
60167
60168C...Peel off any text following exclamation mark.
60169 LHIG2=LBIT
60170 DO 140 LLOW2=LHIG2,1,-1
60171 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60172 140 CONTINUE
60173 IF(LBIT.EQ.0) RETURN
60174
60175C...Identify commonblock variable.
60176 LNAM=1
60177 150 LNAM=LNAM+1
60178 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60179 &LNAM.LE.6) GOTO 150
60180 CHNAM=CHBIT(1:LNAM-1)//' '
60181 DO 170 LCOM=1,LNAM-1
60182 DO 160 LALP=1,26
60183 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60184 & CHALP(2)(LALP:LALP)
60185 160 CONTINUE
60186 170 CONTINUE
60187 IVAR=0
60188 DO 180 IV=1,56
60189 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
60190 180 CONTINUE
60191 IF(IVAR.EQ.0) THEN
60192 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
60193 LLOW=LHIG
60194 IF(LLOW.LT.LTOT) GOTO 120
60195 RETURN
60196 ENDIF
60197
60198C...Identify any indices.
60199 I1=0
60200 I2=0
60201 I3=0
60202 NINDX=0
60203 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
60204 LIND=LNAM
60205 190 LIND=LIND+1
60206 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
60207 CHIND=' '
60208 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
60209 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
60210 & IVAR.EQ.37)) THEN
60211 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
60212 READ(CHIND,'(I8)') KF
60213 I1=PYCOMP(KF)
60214 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
60215 & 'c') THEN
60216 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
60217 & CHNAM)
60218 LLOW=LHIG
60219 IF(LLOW.LT.LTOT) GOTO 120
60220 RETURN
60221 ELSE
60222 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60223 READ(CHIND,'(I8)') I1
60224 ENDIF
60225 LNAM=LIND
60226 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60227 NINDX=1
60228 ENDIF
60229 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60230 LIND=LNAM
60231 200 LIND=LIND+1
60232 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
60233 CHIND=' '
60234 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60235 READ(CHIND,'(I8)') I2
60236 LNAM=LIND
60237 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60238 NINDX=2
60239 ENDIF
60240 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60241 LIND=LNAM
60242 210 LIND=LIND+1
60243 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
60244 CHIND=' '
60245 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60246 READ(CHIND,'(I8)') I3
60247 LNAM=LIND+1
60248 NINDX=3
60249 ENDIF
60250
60251C...Check that indices allowed.
60252 IERR=0
60253 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
60254 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
60255 &IERR=2
60256 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
60257 &IERR=3
60258 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
60259 &IERR=4
60260 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
60261 IF(IERR.GE.1) THEN
60262 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
60263 & CHBIT(1:LNAM-1))
60264 LLOW=LHIG
60265 IF(LLOW.LT.LTOT) GOTO 120
60266 RETURN
60267 ENDIF
60268
60269C...Save old value of variable.
60270 IF(IVAR.EQ.1) THEN
60271 IOLD=N
60272 ELSEIF(IVAR.EQ.2) THEN
60273 IOLD=K(I1,I2)
60274 ELSEIF(IVAR.EQ.3) THEN
60275 ROLD=P(I1,I2)
60276 ELSEIF(IVAR.EQ.4) THEN
60277 ROLD=V(I1,I2)
60278 ELSEIF(IVAR.EQ.5) THEN
60279 IOLD=MSTU(I1)
60280 ELSEIF(IVAR.EQ.6) THEN
60281 ROLD=PARU(I1)
60282 ELSEIF(IVAR.EQ.7) THEN
60283 IOLD=MSTJ(I1)
60284 ELSEIF(IVAR.EQ.8) THEN
60285 ROLD=PARJ(I1)
60286 ELSEIF(IVAR.EQ.9) THEN
60287 IOLD=KCHG(I1,I2)
60288 ELSEIF(IVAR.EQ.10) THEN
60289 ROLD=PMAS(I1,I2)
60290 ELSEIF(IVAR.EQ.11) THEN
60291 ROLD=PARF(I1)
60292 ELSEIF(IVAR.EQ.12) THEN
60293 ROLD=VCKM(I1,I2)
60294 ELSEIF(IVAR.EQ.13) THEN
60295 IOLD=MDCY(I1,I2)
60296 ELSEIF(IVAR.EQ.14) THEN
60297 IOLD=MDME(I1,I2)
60298 ELSEIF(IVAR.EQ.15) THEN
60299 ROLD=BRAT(I1)
60300 ELSEIF(IVAR.EQ.16) THEN
60301 IOLD=KFDP(I1,I2)
60302 ELSEIF(IVAR.EQ.17) THEN
60303 CHOLD=CHAF(I1,I2)(1:8)
60304 ELSEIF(IVAR.EQ.18) THEN
60305 IOLD=MRPY(I1)
60306 ELSEIF(IVAR.EQ.19) THEN
60307 ROLD=RRPY(I1)
60308 ELSEIF(IVAR.EQ.20) THEN
60309 IOLD=MSEL
60310 ELSEIF(IVAR.EQ.21) THEN
60311 IOLD=MSUB(I1)
60312 ELSEIF(IVAR.EQ.22) THEN
60313 IOLD=KFIN(I1,I2)
60314 ELSEIF(IVAR.EQ.23) THEN
60315 ROLD=CKIN(I1)
60316 ELSEIF(IVAR.EQ.24) THEN
60317 IOLD=MSTP(I1)
60318 ELSEIF(IVAR.EQ.25) THEN
60319 ROLD=PARP(I1)
60320 ELSEIF(IVAR.EQ.26) THEN
60321 IOLD=MSTI(I1)
60322 ELSEIF(IVAR.EQ.27) THEN
60323 ROLD=PARI(I1)
60324 ELSEIF(IVAR.EQ.28) THEN
60325 IOLD=MINT(I1)
60326 ELSEIF(IVAR.EQ.29) THEN
60327 ROLD=VINT(I1)
60328 ELSEIF(IVAR.EQ.30) THEN
60329 IOLD=ISET(I1)
60330 ELSEIF(IVAR.EQ.31) THEN
60331 IOLD=KFPR(I1,I2)
60332 ELSEIF(IVAR.EQ.32) THEN
60333 ROLD=COEF(I1,I2)
60334 ELSEIF(IVAR.EQ.33) THEN
60335 IOLD=ICOL(I1,I2,I3)
60336 ELSEIF(IVAR.EQ.34) THEN
60337 ROLD=XSFX(I1,I2)
60338 ELSEIF(IVAR.EQ.35) THEN
60339 IOLD=ISIG(I1,I2)
60340 ELSEIF(IVAR.EQ.36) THEN
60341 ROLD=SIGH(I1)
60342 ELSEIF(IVAR.EQ.37) THEN
60343 IOLD=MWID(I1)
60344 ELSEIF(IVAR.EQ.38) THEN
60345 ROLD=WIDS(I1,I2)
60346 ELSEIF(IVAR.EQ.39) THEN
60347 IOLD=NGEN(I1,I2)
60348 ELSEIF(IVAR.EQ.40) THEN
60349 ROLD=XSEC(I1,I2)
60350 ELSEIF(IVAR.EQ.41) THEN
60351 CHOLD2=PROC(I1)
60352 ELSEIF(IVAR.EQ.42) THEN
60353 ROLD=SIGT(I1,I2,I3)
60354 ELSEIF(IVAR.EQ.43) THEN
60355 ROLD=XPVMD(I1)
60356 ELSEIF(IVAR.EQ.44) THEN
60357 ROLD=XPANL(I1)
60358 ELSEIF(IVAR.EQ.45) THEN
60359 ROLD=XPANH(I1)
60360 ELSEIF(IVAR.EQ.46) THEN
60361 ROLD=XPBEH(I1)
60362 ELSEIF(IVAR.EQ.47) THEN
60363 ROLD=XPDIR(I1)
60364 ELSEIF(IVAR.EQ.48) THEN
60365 IOLD=IMSS(I1)
60366 ELSEIF(IVAR.EQ.49) THEN
60367 ROLD=RMSS(I1)
60368 ELSEIF(IVAR.EQ.50) THEN
60369 ROLD=RVLAM(I1,I2,I3)
60370 ELSEIF(IVAR.EQ.51) THEN
60371 ROLD=RVLAMP(I1,I2,I3)
60372 ELSEIF(IVAR.EQ.52) THEN
60373 ROLD=RVLAMB(I1,I2,I3)
60374 ELSEIF(IVAR.EQ.53) THEN
60375 IOLD=ITCM(I1)
60376 ELSEIF(IVAR.EQ.54) THEN
60377 ROLD=RTCM(I1)
60378 ELSEIF(IVAR.EQ.55) THEN
60379 IOLD=IUED(I1)
60380 ELSEIF(IVAR.EQ.56) THEN
60381 ROLD=RUED(I1)
60382 ENDIF
60383
60384C...Print current value of variable. Loop back.
60385 IF(LNAM.GE.LBIT) THEN
60386 CHBIT(LNAM:14)=' '
60387 CHBIT(15:60)=' has the value '
60388 IF(MSVAR(IVAR,1).EQ.1) THEN
60389 WRITE(CHBIT(51:60),'(I10)') IOLD
60390 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60391 WRITE(CHBIT(47:60),'(F14.5)') ROLD
60392 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60393 CHBIT(53:60)=CHOLD
60394 ELSE
60395 CHBIT(33:60)=CHOLD
60396 ENDIF
60397 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60398 LLOW=LHIG
60399 IF(LLOW.LT.LTOT) GOTO 120
60400 RETURN
60401 ENDIF
60402
60403C...Read in new variable value.
60404 IF(MSVAR(IVAR,1).EQ.1) THEN
60405 CHINI=' '
60406 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
60407 READ(CHINI,'(I10)') INEW
60408 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60409 CHINR=' '
60410 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
60411 READ(CHINR,*) RNEW
60412 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60413 CHNEW=CHBIT(LNAM+1:LBIT)//' '
60414 ELSE
60415 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
60416 ENDIF
60417
60418C...Store new variable value.
60419 IF(IVAR.EQ.1) THEN
60420 N=INEW
60421 ELSEIF(IVAR.EQ.2) THEN
60422 K(I1,I2)=INEW
60423 ELSEIF(IVAR.EQ.3) THEN
60424 P(I1,I2)=RNEW
60425 ELSEIF(IVAR.EQ.4) THEN
60426 V(I1,I2)=RNEW
60427 ELSEIF(IVAR.EQ.5) THEN
60428 MSTU(I1)=INEW
60429 ELSEIF(IVAR.EQ.6) THEN
60430 PARU(I1)=RNEW
60431 ELSEIF(IVAR.EQ.7) THEN
60432 MSTJ(I1)=INEW
60433 ELSEIF(IVAR.EQ.8) THEN
60434 PARJ(I1)=RNEW
60435 ELSEIF(IVAR.EQ.9) THEN
60436 KCHG(I1,I2)=INEW
60437 ELSEIF(IVAR.EQ.10) THEN
60438 PMAS(I1,I2)=RNEW
60439 ELSEIF(IVAR.EQ.11) THEN
60440 PARF(I1)=RNEW
60441 ELSEIF(IVAR.EQ.12) THEN
60442 VCKM(I1,I2)=RNEW
60443 ELSEIF(IVAR.EQ.13) THEN
60444 MDCY(I1,I2)=INEW
60445 ELSEIF(IVAR.EQ.14) THEN
60446 MDME(I1,I2)=INEW
60447 ELSEIF(IVAR.EQ.15) THEN
60448 BRAT(I1)=RNEW
60449 ELSEIF(IVAR.EQ.16) THEN
60450 KFDP(I1,I2)=INEW
60451 ELSEIF(IVAR.EQ.17) THEN
60452 CHAF(I1,I2)=CHNEW
60453 ELSEIF(IVAR.EQ.18) THEN
60454 MRPY(I1)=INEW
60455 ELSEIF(IVAR.EQ.19) THEN
60456 RRPY(I1)=RNEW
60457 ELSEIF(IVAR.EQ.20) THEN
60458 MSEL=INEW
60459 ELSEIF(IVAR.EQ.21) THEN
60460 MSUB(I1)=INEW
60461 ELSEIF(IVAR.EQ.22) THEN
60462 KFIN(I1,I2)=INEW
60463 ELSEIF(IVAR.EQ.23) THEN
60464 CKIN(I1)=RNEW
60465 ELSEIF(IVAR.EQ.24) THEN
60466 MSTP(I1)=INEW
60467 ELSEIF(IVAR.EQ.25) THEN
60468 PARP(I1)=RNEW
60469 ELSEIF(IVAR.EQ.26) THEN
60470 MSTI(I1)=INEW
60471 ELSEIF(IVAR.EQ.27) THEN
60472 PARI(I1)=RNEW
60473 ELSEIF(IVAR.EQ.28) THEN
60474 MINT(I1)=INEW
60475 ELSEIF(IVAR.EQ.29) THEN
60476 VINT(I1)=RNEW
60477 ELSEIF(IVAR.EQ.30) THEN
60478 ISET(I1)=INEW
60479 ELSEIF(IVAR.EQ.31) THEN
60480 KFPR(I1,I2)=INEW
60481 ELSEIF(IVAR.EQ.32) THEN
60482 COEF(I1,I2)=RNEW
60483 ELSEIF(IVAR.EQ.33) THEN
60484 ICOL(I1,I2,I3)=INEW
60485 ELSEIF(IVAR.EQ.34) THEN
60486 XSFX(I1,I2)=RNEW
60487 ELSEIF(IVAR.EQ.35) THEN
60488 ISIG(I1,I2)=INEW
60489 ELSEIF(IVAR.EQ.36) THEN
60490 SIGH(I1)=RNEW
60491 ELSEIF(IVAR.EQ.37) THEN
60492 MWID(I1)=INEW
60493 ELSEIF(IVAR.EQ.38) THEN
60494 WIDS(I1,I2)=RNEW
60495 ELSEIF(IVAR.EQ.39) THEN
60496 NGEN(I1,I2)=INEW
60497 ELSEIF(IVAR.EQ.40) THEN
60498 XSEC(I1,I2)=RNEW
60499 ELSEIF(IVAR.EQ.41) THEN
60500 PROC(I1)=CHNEW2
60501 ELSEIF(IVAR.EQ.42) THEN
60502 SIGT(I1,I2,I3)=RNEW
60503 ELSEIF(IVAR.EQ.43) THEN
60504 XPVMD(I1)=RNEW
60505 ELSEIF(IVAR.EQ.44) THEN
60506 XPANL(I1)=RNEW
60507 ELSEIF(IVAR.EQ.45) THEN
60508 XPANH(I1)=RNEW
60509 ELSEIF(IVAR.EQ.46) THEN
60510 XPBEH(I1)=RNEW
60511 ELSEIF(IVAR.EQ.47) THEN
60512 XPDIR(I1)=RNEW
60513 ELSEIF(IVAR.EQ.48) THEN
60514 IMSS(I1)=INEW
60515 ELSEIF(IVAR.EQ.49) THEN
60516 RMSS(I1)=RNEW
60517 ELSEIF(IVAR.EQ.50) THEN
60518 RVLAM(I1,I2,I3)=RNEW
60519 ELSEIF(IVAR.EQ.51) THEN
60520 RVLAMP(I1,I2,I3)=RNEW
60521 ELSEIF(IVAR.EQ.52) THEN
60522 RVLAMB(I1,I2,I3)=RNEW
60523 ELSEIF(IVAR.EQ.53) THEN
60524 ITCM(I1)=INEW
60525 ELSEIF(IVAR.EQ.54) THEN
60526 RTCM(I1)=RNEW
60527 ELSEIF(IVAR.EQ.55) THEN
60528 IUED(I1)=INEW
60529 ELSEIF(IVAR.EQ.56) THEN
60530 RUED(I1)=RNEW
60531 ENDIF
60532
60533C...Write old and new value. Loop back.
60534 CHBIT(LNAM:14)=' '
60535 CHBIT(15:60)=' changed from to '
60536 IF(MSVAR(IVAR,1).EQ.1) THEN
60537 WRITE(CHBIT(33:42),'(I10)') IOLD
60538 WRITE(CHBIT(51:60),'(I10)') INEW
60539 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60540 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60541 WRITE(CHBIT(29:42),'(F14.5)') ROLD
60542 WRITE(CHBIT(47:60),'(F14.5)') RNEW
60543 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60544 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60545 CHBIT(35:42)=CHOLD
60546 CHBIT(53:60)=CHNEW
60547 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60548 ELSE
60549 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
60550 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
60551 ENDIF
60552 LLOW=LHIG
60553 IF(LLOW.LT.LTOT) GOTO 120
60554
60555C...Format statement for output on unit MSTU(11) (by default 6).
60556 5000 FORMAT(5X,A60)
60557 5100 FORMAT(5X,A88)
60558
60559 RETURN
60560 END
60561
60562C*********************************************************************
60563
60564C...PYONOF
60565C...Switches on and off decay channel by search for match.
60566
60567 SUBROUTINE PYONOF(CHIN)
60568
60569C...Double precision and integer declarations.
60570 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60571 IMPLICIT INTEGER(I-N)
60572 INTEGER PYK,PYCHGE,PYCOMP
60573C...Commonblocks.
60574 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60575 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60576 SAVE /PYDAT1/,/PYDAT3/
60577C...Local arrays and character variables.
60578 INTEGER KFCMP(10),KFTMP(10)
60579 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60580 &CHALP(2)*26
60581 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60582 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60583
60584C...Determine length of character variable.
60585 CHTMP=CHIN//' '
60586 LBEG=0
60587 100 LBEG=LBEG+1
60588 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
60589 LEND=LBEG-1
60590 105 LEND=LEND+1
60591 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
60592 110 LEND=LEND-1
60593 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
60594 LEN=1+LEND-LBEG
60595 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
60596
60597C...Find colon separator and particle code.
60598 LCOLON=0
60599 120 LCOLON=LCOLON+1
60600 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
60601 CHCODE=' '
60602 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
60603 READ(CHCODE,'(I8)',ERR=300) KF
60604 KC=PYCOMP(KF)
60605
60606C...Done if unknown code or no decay channels.
60607 IF(KC.EQ.0) THEN
60608 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
60609 RETURN
60610 ENDIF
60611 IDCBEG=MDCY(KC,2)
60612 IDCLEN=MDCY(KC,3)
60613 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
60614 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
60615 RETURN
60616 ENDIF
60617
60618C...Find command name up to blank or equal sign.
60619 LSEP=LCOLON
60620 130 LSEP=LSEP+1
60621 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
60622 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
60623 CHMODE=' '
60624 LMODE=LSEP-LCOLON-1
60625 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
60626
60627C...Convert to uppercase.
60628 DO 150 LCOM=1,LMODE
60629 DO 140 LALP=1,26
60630 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
60631 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
60632 140 CONTINUE
60633 150 CONTINUE
60634
60635C...Identify command. Failed if not identified.
60636 MODE=0
60637 IF(CHMODE.EQ.'ALLOFF') MODE=1
60638 IF(CHMODE.EQ.'ALLON') MODE=2
60639 IF(CHMODE.EQ.'OFFIFANY') MODE=3
60640 IF(CHMODE.EQ.'ONIFANY') MODE=4
60641 IF(CHMODE.EQ.'OFFIFALL') MODE=5
60642 IF(CHMODE.EQ.'ONIFALL') MODE=6
60643 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
60644 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
60645 IF(MODE.EQ.0) THEN
60646 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
60647 RETURN
60648 ENDIF
60649
60650C...Simple cases when all on or all off.
60651 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
60652 WRITE(MSTU(11),1000) KF,CHMODE
60653 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
60654 IF(MDME(IDC,1).LT.0) GOTO 160
60655 MDME(IDC,1)=MODE-1
60656 160 CONTINUE
60657 RETURN
60658 ENDIF
60659
60660C...Identify matching list.
60661 NCMP=0
60662 LBEG=LSEP
60663 170 LBEG=LBEG+1
60664 IF(LBEG.GT.LEN) GOTO 190
60665 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
60666 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
60667 LEND=LBEG-1
60668 180 LEND=LEND+1
60669 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
60670 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
60671 IF(LEND.LT.LEN) LEND=LEND-1
60672 CHCODE=' '
60673 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
60674 READ(CHCODE,'(I8)',ERR=300) KFREAD
60675 NCMP=NCMP+1
60676 KFCMP(NCMP)=IABS(KFREAD)
60677 LBEG=LEND
60678 IF(NCMP.LT.10) GOTO 170
60679 190 CONTINUE
60680 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
60681
60682C...Only one matching required.
60683 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
60684 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
60685 IF(MDME(IDC,1).LT.0) GOTO 220
60686 DO 210 IKF=1,5
60687 KFNOW=IABS(KFDP(IDC,IKF))
60688 IF(KFNOW.EQ.0) GOTO 210
60689 DO 200 ICMP=1,NCMP
60690 IF(KFCMP(ICMP).EQ.KFNOW) THEN
60691 MDME(IDC,1)=MODE-3
60692 GOTO 220
60693 ENDIF
60694 200 CONTINUE
60695 210 CONTINUE
60696 220 CONTINUE
60697 RETURN
60698 ENDIF
60699
60700C...Multiple matchings required.
60701 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
60702 IF(MDME(IDC,1).LT.0) GOTO 260
60703 NTMP=NCMP
60704 DO 230 ITMP=1,NTMP
60705 KFTMP(ITMP)=KFCMP(ITMP)
60706 230 CONTINUE
60707 NFIN=0
60708 DO 250 IKF=1,5
60709 KFNOW=IABS(KFDP(IDC,IKF))
60710 IF(KFNOW.EQ.0) GOTO 250
60711 NFIN=NFIN+1
60712 DO 240 ITMP=1,NTMP
60713 IF(KFTMP(ITMP).EQ.KFNOW) THEN
60714 KFTMP(ITMP)=KFTMP(NTMP)
60715 NTMP=NTMP-1
60716 GOTO 250
60717 ENDIF
60718 240 CONTINUE
60719 250 CONTINUE
60720 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
60721 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
60722 & MDME(IDC,1)=MODE-7
60723 260 CONTINUE
60724 RETURN
60725
60726C...Error exit for impossible read of particle code.
60727 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
60728 &//CHCODE)
60729
60730C...Formats for output.
60731 1000 FORMAT(' Decays for',I8,' set ',A10)
60732 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
60733
60734 RETURN
60735 END
60736C*********************************************************************
60737
60738C...PYTUNE
60739C...Presets for a few specific underlying-event and min-bias tunes
60740C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60741C...others require particular versions of pythia (e.g. the SCI and GAL
60742C...models). See below for details.
60743 SUBROUTINE PYTUNE(ITUNE)
60744C
60745C ITUNE NAME (detailed descriptions below)
60746C 0 Default : No settings changed => defaults.
60747C
60748C ====== Old UE, Q2-ordered showers ====================================
60749C 100 A : Rick Field's CDF Tune A (Oct 2002)
60750C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60751C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60752C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60753C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60754C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60755C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60756C 107 ACR : Tune A modified with new CR model (Mar 2007)
60757C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60758C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60759C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60760C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60761C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60762C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60763C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60764C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60765C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60766C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60767C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60768C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60769C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60770C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60771C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60772C
60773C ====== Intermediate and Hybrid Models ================================
60774C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60775C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60776C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60777C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60778C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60779C
60780C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60781C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60782C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60783C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60784C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60785C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60786C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60787C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60788C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60789C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60790C 311 S1-Pro : S1 -"- (Oct 2008)
60791C 312 S2-Pro : S2 -"- (Oct 2008)
60792C 313 S0A-Pro : S0A -"- (Oct 2008)
60793C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60794C 315 Old-Pro : Old -"- (Oct 2008)
60795C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60796C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60797C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60798C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60799C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60800C balance & different scaling to LHC & RHIC (Feb 2009)
60801C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60802C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60803C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60804C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60805C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60806C
60807C ======= The Uppsala models ===========================================
60808C ( NB! must be run with special modified Pythia 6.215 version )
60809C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60810C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60811C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60812C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60813C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60814C
60815C More details;
60816C
60817C Quick Dictionary:
60818C BE : Bose-Einstein
60819C BR : Beam Remnants
60820C CR : Colour Reconnections
60821C HAD: Hadronization
60822C ISR/FSR: Initial-State Radiation / Final-State Radiation
60823C FSI: Final-State Interactions (=CR+BE)
60824C MB : Minimum-bias
60825C MI : Multiple Interactions
60826C UE : Underlying Event
60827C
60828C=======================================================================
60829C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60830C=======================================================================
60831C
60832C A (100) and AW (101). CTEQ5L parton distributions
60833C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60834C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60835C...Key feature: extensively compared to CDF data (R.D. Field).
60836C...* Large starting scale for ISR (PARP(67)=4)
60837C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60838C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60839C
60840C BW (102). CTEQ5L parton distributions
60841C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60842C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60843C...Key feature: extensively compared to CDF data (R.D. Field).
60844C...NB: Can also be run with Pythia 6.2 or 6.312+
60845C...* Small starting scale for ISR (PARP(67)=1)
60846C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60847C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60848C
60849C DW (103) and DWT (104). CTEQ5L parton distributions
60850C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60851C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60852C...Key feature: extensively compared to CDF data (R.D. Field).
60853C...NB: Can also be run with Pythia 6.2 or 6.312+
60854C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60855C...* DWT has a different reference energy, the same as the "S" models
60856C... below, leading to more UE activity at the LHC, but less at RHIC.
60857C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60858C
60859C QW (105). CTEQ61 parton distributions
60860C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60861C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60862C...Key feature: uses CTEQ61 (external pdf library must be linked)
60863C
60864C ATLAS-DC2 (106). CTEQ5L parton distributions
60865C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60866C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60867C...Key feature: tune used by the ATLAS collaboration.
60868C
60869C ACR (107). CTEQ5L parton distributions
60870C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60871C...Key feature: Tune A modified to use annealing CR.
60872C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60873C
60874C D6 (108) and D6T (109). CTEQ6L parton distributions
60875C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60876C
60877C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60878C Old UE model, Q2-ordered showers.
60879C...Key feature: Rick Field's family of tunes revamped with the
60880C...Professor Q2-ordered final-state shower and fragmentation tunes
60881C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60882C...Key feature: improved descriptions of LEP data.
60883C
60884C Pro-Q20 (129). CTEQ5L parton distributions
60885C Old UE model, Q2-ordered showers.
60886C...Key feature: Complete retune of old model by Professor, including
60887C...large amounts of both LEP and Tevatron data.
60888C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60889C...extreme in this tune, corresponding to using mu_R = pT/3 .
60890C
60891C=======================================================================
60892C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60893C=======================================================================
60894C
60895C IM1 (200). Intermediate model, Q2-ordered showers,
60896C CTEQ5L parton distributions
60897C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60898C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60899C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60900C
60901C APT (201). Old UE model, pT-ordered final-state showers,
60902C CTEQ5L parton distributions
60903C...Key feature: Rick Field's Tune A, but with new final-state showers
60904C
60905C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60906C CTEQ5L parton distributions
60907C...Key feature: APT revamped with the Professor pT-ordered final-state
60908C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60909C...Perugia MPI workshop in October 2008.
60910C
60911C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60912C CTEQ5L parton distributions
60913C...Key feature: APT-Pro with final-state showers off the MPI,
60914C...lower ISR renormalization scale to improve agreement with the
60915C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60916C...to min-bias at 630 GeV.
60917C
60918C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60919C CTEQ6L1 parton distributions.
60920C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60921C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60922C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60923C
60924C=======================================================================
60925C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60926C=======================================================================
60927C
60928C S0 (300) and S0A (303). CTEQ5L parton distributions
60929C...Key feature: large amount of multiple interactions
60930C...* Somewhat faster than the other colour annealing scenarios.
60931C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60932C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60933C...* Small amount of radiation.
60934C...* Large amount of low-pT MI
60935C...* Low degree of proton lumpiness (broad matter dist.)
60936C...* CR Type S (driven by free triplets), of medium strength.
60937C...* See: Pythia6402 update notes or later.
60938C
60939C S1 (301). CTEQ5L parton distributions
60940C...Key feature: large amount of radiation.
60941C...* Large amount of low-pT perturbative ISR
60942C...* Large amount of FSR off ISR partons
60943C...* Small amount of low-pT multiple interactions
60944C...* Moderate degree of proton lumpiness
60945C...* Least aggressive CR type (S+S Type I), but with large strength
60946C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60947C
60948C S2 (302). CTEQ5L parton distributions
60949C...Key feature: very lumpy proton + gg string cluster formation allowed
60950C...* Small amount of radiation
60951C...* Moderate amount of low-pT MI
60952C...* High degree of proton lumpiness (more spiky matter distribution)
60953C...* Most aggressive CR type (S+S Type II), but with small strength
60954C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60955C
60956C NOCR (304). CTEQ5L parton distributions
60957C...Key feature: no colour reconnections (NB: "Best fit" only).
60958C...* NB: <pT>(Nch) problematic in this tune.
60959C...* Small amount of radiation
60960C...* Small amount of low-pT MI
60961C...* Low degree of proton lumpiness
60962C...* Large BR composite x enhancement factor
60963C...* Most clever colour flow without CR ("Lambda ordering")
60964C
60965C ATLAS-CSC (306). CTEQ6L parton distributions
60966C...Key feature: 11-parameter ATLAS tune of the new framework.
60967C...* Old (pre-annealing) colour reconnections a la 305.
60968C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60969C
60970C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60971C...Key feature: the S0 family of tunes revamped with the Professor
60972C...pT-ordered final-state shower and fragmentation tunes presented by
60973C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60974C...Key feature: improved descriptions of LEP data.
60975C
60976C Perugia-0 (320). CTEQ5L parton distributions.
60977C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60978C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60979C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60980C...beam-remnant breakup (more baryon number transport), and suppression
60981C...of CR in high-pT string pieces.
60982C
60983C Perugia-HARD (321). CTEQ5L parton distributions.
60984C...Key feature: More ISR, More FSR, Less MPI, Less BR
60985C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60986C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60987C...baryon number transport), and more fragmentation pT.
60988C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60989C...DY pT spectrum is HARD.
60990C
60991C Perugia-SOFT (322). CTEQ5L parton distributions.
60992C...Key feature: Less ISR, Less FSR, More MPI, More BR
60993C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60994C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
60995C...number transport), and less fragmentation pT.
60996C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
60997C...DY pT spectrum is SOFT
60998C
60999C Perugia-3 (323). CTEQ5L parton distributions.
61000C...Key feature: variant of Perugia-0 with more extreme energy scaling
61001C...properties while still agreeing with Tevatron data from 630 to 1960.
61002C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61003C...allows FSR off the active end of dipoles stretched to the remnant.
61004C
61005C Perugia-NOCR (324). CTEQ5L parton distributions.
61006C...Key feature: Retune of NOCR-Pro with better scaling properties to
61007C...lower energies and somewhat better agreement with Tevatron data
61008C...at 1800/1960.
61009C
61010C Perugia-* (325). MRST LO* parton distributions for generators
61011C...Key feature: first attempt at using the LO* distributions
61012C...(external pdf library must be linked).
61013C
61014C Perugia-6 (326). CTEQ6L1 parton distributions
61015C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61016C
61017C Pro-pT0 (329). CTEQ5L parton distributions
61018C...Key feature: Complete retune of new model by Professor, including
61019C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61020C
61021C=======================================================================
61022C OTHER TUNES
61023C=======================================================================
61024C
61025C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61026C...with an unmodified Pythia distribution.
61027C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61028C
61029C ::: + Future improvements?
61030C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61031C (problem: K-factor affects everything so only works as
61032C intended for min-bias, not for UE ... probably need a
61033C better long-term solution to handle UE as well. Anyway,
61034C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61035
61036C...Global statements
61037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61038 INTEGER PYK,PYCHGE,PYCOMP
61039
61040C...Commonblocks.
61041 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61042 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61043
61044C...SCI and GAL Commonblocks
61045 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61046
61047C...SAVE statements
61048 SAVE /PYDAT1/,/PYPARS/
61049 SAVE /SCIPAR/
61050
61051C...Internal parameters
61052 PARAMETER(MXTUNS=500)
61053 CHARACTER*8 CHVERS, CHDOC
61054 PARAMETER (CHVERS='1.015 ',CHDOC='Jan 2009')
61055 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61056 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
61057 & CHPARJ(1:100), CH40
61058 CHARACTER*60 CH60
61059 CHARACTER*70 CH70
61060 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61061 DATA (CHNAMS(I),I=100,119)/
61062 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61063 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61064 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61065 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61066 1 'Tune D6-Pro','Tune D6T-Pro'/
61067 DATA (CHNAMS(I),I=120,129)/
61068 & 9*' ','Pro-Q20'/
61069 DATA (CHNAMS(I),I=300,309)/
61070 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61071 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61072 DATA (CHNAMS(I),I=310,315)/
61073 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61074 & 'NOCR-Pro','Old-Pro'/
61075 DATA (CHNAMS(I),I=320,329)/
61076 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61077 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61078 & 'Perugia 6',2*' ','Pro-pT0'/
61079 DATA (CHNAMS(I),I=200,229)/
61080 & 'IM Tune 1','Tune APT',8*' ',
61081 & ' ','Tune APT-Pro',8*' ',
61082 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61083 DATA (CHNAMS(I),I=400,409)/
61084 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61085 DATA (CHMSTJ(I),I=11,20)/
61086 & 'HAD choice of fragmentation function(s)',4*' ',
61087 & 'HAD treatment of small-mass systems',4*' '/
61088 DATA (CHMSTJ(I),I=41,50)/
61089 & 'FSR type (Q2 or pT) for old framework',9*' '/
61090 DATA (CHMSTP(I),I=51,100)/
61091 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
61092 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
61093 6 'ISR coherence option for 1st emission',
61094 6 'ISR phase space choice & ME corrections',' ',
61095 7 'ISR IR regularization scheme',' ',
61096 7 'ISR scheme for FSR off ISR',8*' ',
61097 8 'UE model',
61098 8 'UE hadron transverse mass distribution',5*' ',
61099 8 'BR composite scheme','BR colour scheme',
61100 9 'BR primordial kT compensation',
61101 9 'BR primordial kT distribution',
61102 9 'BR energy partitioning scheme',2*' ',
61103 9 'FSI colour (re-)connection model',5*' '/
61104 DATA (CHPARP(I),I=61,100)/
61105 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
61106 6 2*' ','ISR Q2max factor',3*' ',
61107 7 'FSR Q2max factor for non-s-channel procs',5*' ',
61108 7 'FSI colour reco high-pT dampening strength',
61109 7 'FSI colour reconnection strength',
61110 7 'BR composite x enhancement','BR breakup suppression',
61111 8 2*'UE IR cutoff at reference ecm',
61112 8 2*'UE mass distribution parameter',
61113 8 'UE gg colour correlated fraction','UE total gg fraction',
61114 8 2*' ',
61115 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61116 9 'BR primordial kT width <|kT|>',' ',
61117 9 'BR primordial kT UV cutoff',7*' '/
61118 DATA (CHPARJ(I),I=1,30)/
61119 & 'HAD diquark suppression','HAD strangeness suppression',
61120 & 'HAD strange diquark suppression',
61121 & 'HAD vector diquark suppression',6*' ',
61122 1 'HAD P(vector meson), u and d only',
61123 1 'HAD P(vector meson), contains s',
61124 1 'HAD P(vector meson), heavy quarks',7*' ',
61125 2 'HAD fragmentation pT',' ',' ',' ',
61126 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61127 DATA (CHPARJ(I),I=41,90)/
61128 4 'HAD string parameter a','HAD string parameter b',3*' ',
61129 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61130 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61131 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61132 6 10*' ',10*' ',
61133 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61134
61135C...1) Shorthand notation
61136 M13=MSTU(13)
61137 M11=MSTU(11)
61138 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
61139 CHNAME=CHNAMS(ITUNE)
61140 IF (ITUNE.EQ.0) GOTO 9999
61141 ELSE
61142 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
61143 GOTO 9999
61144 ENDIF
61145
61146C...2) Hello World
61147 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
61148
61149C...3) Tune parameters
61150
61151C=======================================================================
61152C...S0, S1, S2, S0A, NOCR, Rap,
61153C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61154C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61155C...Pro-pT0
61156 IF ((ITUNE.GE.300.AND.ITUNE.LE.305)
61157 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
61158 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.326).OR.ITUNE.EQ.329) THEN
61159 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61160 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61161 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61162 & ' with tune.')
61163 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326.AND.ITUNE.NE.324.AND.
61164 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
61165 & THEN
61166 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61167 & ' with tune.')
61168 ENDIF
61169
61170C...Use Professor's LEP pars if ITUNE >= 310
61171C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61172 IF (ITUNE.LT.310) THEN
61173C...# Old defaults
61174 MSTJ(11) = 4
61175C...# Old default flavour parameters
61176 PARJ(21) = 0.36
61177 PARJ(41) = 0.30
61178 PARJ(42) = 0.58
61179 PARJ(46) = 1.0
61180 PARJ(82) = 1.0
61181
61182 ELSEIF (ITUNE.GE.310) THEN
61183C...# Tuned flavour parameters:
61184 PARJ(1) = 0.073
61185 PARJ(2) = 0.2
61186 PARJ(3) = 0.94
61187 PARJ(4) = 0.032
61188 PARJ(11) = 0.31
61189 PARJ(12) = 0.4
61190 PARJ(13) = 0.54
61191 PARJ(25) = 0.63
61192 PARJ(26) = 0.12
61193C...# Always use pT-ordered shower:
61194 MSTJ(41) = 12
61195C...# Switch on Bowler:
61196 MSTJ(11) = 5
61197C...# Fragmentation
61198 PARJ(21) = 0.313
61199 PARJ(41) = 0.49
61200 PARJ(42) = 1.2
61201 PARJ(47) = 1.0
61202 PARJ(81) = 0.257
61203 PARJ(82) = 0.8
61204 ENDIF
61205
61206C...Remove middle digit now for Professor variants, since identical pars
61207 ITUNEB=ITUNE
61208 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
61209 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61210 ENDIF
61211
61212C...PDFs: all use CTEQ5L as starting point
61213 MSTP(52)=1
61214 MSTP(51)=7
61215 IF (ITUNE.EQ.325) THEN
61216C...MRST LO* for 325
61217 MSTP(52)=2
61218 MSTP(51)=20650
61219 ELSEIF (ITUNE.EQ.326) THEN
61220C...CTEQ6L1 for 326
61221 MSTP(52)=2
61222 MSTP(51)=10042
61223 ENDIF
61224
61225C...ISR: use Lambda_MSbar with default scale for S0(A)
61226 MSTP(64)=2
61227 PARP(64)=1D0
61228 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.
61229 & ITUNE.EQ.326) THEN
61230C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61231 MSTP(64)=3
61232 PARP(64)=1D0
61233 ELSEIF (ITUNE.EQ.321) THEN
61234C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61235 MSTP(64)=3
61236 PARP(64)=0.25D0
61237 ELSEIF (ITUNE.EQ.322) THEN
61238C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61239 MSTP(64)=2
61240 PARP(64)=2D0
61241 ELSEIF (ITUNE.EQ.325) THEN
61242C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61243 MSTP(64)=3
61244 PARP(64)=2D0
61245 ELSEIF (ITUNE.EQ.329) THEN
61246C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61247 MSTP(64)=2
61248 PARP(64)=1.3D0
61249 ENDIF
61250
61251C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61252 MSTP(67)=2
61253 PARP(67)=4D0
61254C...Perugia tunes have stronger suppression, except HARD
61255 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61256 PARP(67)=1D0
61257 IF (ITUNE.EQ.321) PARP(67)=4D0
61258 IF (ITUNE.EQ.322) PARP(67)=0.5D0
61259 ENDIF
61260
61261C...ISR IR cutoff type and FSR off ISR setting:
61262C...Smooth ISR, low FSR-off-ISR
61263 MSTP(70)=2
61264 MSTP(72)=0
61265 IF (ITUNEB.EQ.301) THEN
61266C...S1, S1-Pro: sharp ISR, high FSR
61267 MSTP(70)=0
61268 MSTP(72)=1
61269 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
61270 & .OR.ITUNE.EQ.325) THEN
61271C...Perugia default is smooth ISR, high FSR-off-ISR
61272 MSTP(70)=2
61273 MSTP(72)=1
61274 ELSEIF (ITUNE.EQ.321) THEN
61275C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61276 MSTP(70)=0
61277 PARP(62)=1.25D0
61278 MSTP(72)=1
61279 ELSEIF (ITUNE.EQ.322) THEN
61280C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61281 MSTP(70)=1
61282 PARP(81)=1.5D0
61283 MSTP(72)=0
61284 ELSEIF (ITUNE.EQ.323) THEN
61285C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61286 MSTP(70)=0
61287 PARP(62)=1.25D0
61288 MSTP(72)=2
61289 ENDIF
61290
61291C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61292C...by Professor tunes (with HARD and SOFT variations)
61293 PARP(71)=4D0
61294 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61295 PARP(71)=2D0
61296 IF (ITUNE.EQ.321) PARP(71)=4D0
61297 IF (ITUNE.EQ.322) PARP(71)=1D0
61298 ENDIF
61299 IF (ITUNE.EQ.329) PARP(71)=2D0
61300
61301C...FSR: Lambda_FSR scale (only if not using professor)
61302 IF (ITUNE.LT.310) PARJ(81)=0.23D0
61303 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
61304 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
61305
61306C...UE on, new model
61307 MSTP(81)=21
61308
61309C...UE: hadron-hadron overlap profile (expOfPow for all)
61310 MSTP(82)=5
61311C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61312 PARP(83)=1.6D0
61313 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
61314 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
61315C...NOCR variants have very smooth distributions
61316 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
61317 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
61318 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61319C...Perugia variants have slightly smoother profiles by default
61320C...(to compensate for more tail by added radiation)
61321C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61322 PARP(83)=1.7D0
61323 IF (ITUNE.EQ.322) PARP(83)=1.5D0
61324 IF (ITUNE.EQ.324) PARP(83)=1.8D0
61325 ENDIF
61326C...Professor-pT0 also has very smooth distribution
61327 IF (ITUNE.EQ.329) PARP(83)=1.8
61328
61329C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61330 PARP(82)=1.85D0
61331 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
61332 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
61333 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
61334 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
61335 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61336C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61337C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61338C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61339C...slightly higher, due to increased activity.
61340 PARP(82)=2.0D0
61341 IF (ITUNE.EQ.321) PARP(82)=2.3D0
61342 IF (ITUNE.EQ.322) PARP(82)=1.9D0
61343 IF (ITUNE.EQ.323) PARP(82)=2.2D0
61344 IF (ITUNE.EQ.324) PARP(82)=1.95D0
61345 IF (ITUNE.EQ.325) PARP(82)=2.2D0
61346 IF (ITUNE.EQ.326) PARP(82)=1.95D0
61347 ENDIF
61348C...Professor-pT0 maintains low pT0 vaue
61349 IF (ITUNE.EQ.329) PARP(82)=1.85D0
61350
61351C...UE: IR cutoff reference energy and default energy scaling pace
61352 PARP(89)=1800D0
61353 PARP(90)=0.16D0
61354C...S0A, S0A-Pro have tune A energy scaling
61355 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
61356 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61357C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61358 PARP(90)=0.26
61359 IF (ITUNE.EQ.321) PARP(90)=0.30D0
61360 IF (ITUNE.EQ.322) PARP(90)=0.24D0
61361 IF (ITUNE.EQ.323) PARP(90)=0.32D0
61362 IF (ITUNE.EQ.324) PARP(90)=0.24D0
61363C...LO* and CTEQ6L1 tunes have slower energy scaling
61364 IF (ITUNE.EQ.325) PARP(90)=0.23D0
61365 IF (ITUNE.EQ.326) PARP(90)=0.22D0
61366 ENDIF
61367C...Professor-pT0 has intermediate scaling
61368 IF (ITUNE.EQ.329) PARP(90)=0.22D0
61369
61370C...BR: MPI initiator color connections rap-ordered by default
61371C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61372 MSTP(89)=1
61373 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
61374 IF (ITUNE.EQ.322) MSTP(89)=0
61375
61376C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61377 PARP(80)=0.01D0
61378 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61379C...Perugia tunes have more beam blowup by default
61380 PARP(80)=0.05D0
61381 IF (ITUNE.EQ.321) PARP(80)=0.01
61382 IF (ITUNE.EQ.323) PARP(80)=0.03
61383 IF (ITUNE.EQ.324) PARP(80)=0.01
61384 ENDIF
61385
61386C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61387 MSTP(88)=0
61388 PARP(79)=2D0
61389 IF (ITUNEB.EQ.304) PARP(79)=3D0
61390 IF (ITUNE.EQ.329) PARP(79)=1.18
61391
61392C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61393 MSTP(91)=1
61394 PARP(91)=2D0
61395 PARP(93)=10D0
61396C...Perugia-HARD only uses 1.0 GeV
61397 IF (ITUNE.EQ.321) PARP(91)=1.0D0
61398C...Perugia-3 only uses 1.5 GeV
61399 IF (ITUNE.EQ.323) PARP(91)=1.5D0
61400C...Professor-pT0 uses 7-GeV cutoff
61401 IF (ITUNE.EQ.329) PARP(93)=7.0
61402
61403C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61404 MSTP(95)=6
61405C...S1, S1-Pro: use S1
61406 IF (ITUNEB.EQ.301) MSTP(95)=2
61407C...S2, S2-Pro: use S2
61408 IF (ITUNEB.EQ.302) MSTP(95)=4
61409C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61410 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324) MSTP(95)=0
61411C..."Old" and "Old"-Pro: use old CR
61412 IF (ITUNEB.EQ.305) MSTP(95)=1
61413
61414C...FSI: CR strength and high-pT dampening, default is S0
61415 IF (ITUNE.LT.320.OR.ITUNE.EQ.329) THEN
61416 PARP(78)=0.2D0
61417 PARP(77)=0D0
61418 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
61419 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
61420 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
61421 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
61422 IF (ITUNE.EQ.329) PARP(78)=0.17D0
61423 ELSE
61424C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61425 PARP(78)=0.33
61426 PARP(77)=0.9D0
61427 IF (ITUNE.EQ.321) THEN
61428C...HARD has HIGH amount of CR
61429 PARP(78)=0.37D0
61430 PARP(77)=0.4D0
61431 ELSEIF (ITUNE.EQ.322) THEN
61432C...SOFT has LOW amount of CR
61433 PARP(78)=0.15D0
61434 PARP(77)=0.5D0
61435 ELSEIF (ITUNE.EQ.323) THEN
61436C...Scaling variant appears to need slightly more than default
61437 PARP(78)=0.35D0
61438 PARP(77)=0.6D0
61439 ELSEIF (ITUNE.EQ.324) THEN
61440C...NOCR has no CR
61441 PARP(78)=0D0
61442 PARP(77)=0D0
61443 ENDIF
61444 ENDIF
61445
61446C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61447 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
61448 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
61449
61450C...Switch off trial joinings
61451 MSTP(96)=0
61452
61453C...S0 (300), S0A (303)
61454 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
61455 IF (M13.GE.1) THEN
61456 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61457 WRITE(M11,5030) CH60
61458 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61459 WRITE(M11,5030) CH60
61460 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61461 WRITE(M11,5030) CH60
61462 IF (ITUNE.GE.310) THEN
61463 CH60='LEP parameters tuned by Professor'
61464 WRITE(M11,5030) CH60
61465 ENDIF
61466 ENDIF
61467
61468C...S1 (301)
61469 ELSEIF(ITUNEB.EQ.301) THEN
61470 IF (M13.GE.1) THEN
61471 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61472 WRITE(M11,5030) CH60
61473 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61474 WRITE(M11,5030) CH60
61475 IF (ITUNE.GE.310) THEN
61476 CH60='LEP parameters tuned with Professor'
61477 WRITE(M11,5030) CH60
61478 ENDIF
61479 ENDIF
61480
61481C...S2 (302)
61482 ELSEIF(ITUNEB.EQ.302) THEN
61483 IF (M13.GE.1) THEN
61484 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61485 WRITE(M11,5030) CH60
61486 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61487 WRITE(M11,5030) CH60
61488 IF (ITUNE.GE.310) THEN
61489 CH60='LEP parameters tuned by Professor'
61490 WRITE(M11,5030) CH60
61491 ENDIF
61492 ENDIF
61493
61494C...NOCR (304)
61495 ELSEIF(ITUNEB.EQ.304) THEN
61496 IF (M13.GE.1) THEN
61497 CH60='"best try" without colour reconnections'
61498 WRITE(M11,5030) CH60
61499 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61500 WRITE(M11,5030) CH60
61501 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61502 WRITE(M11,5030) CH60
61503 IF (ITUNE.GE.310) THEN
61504 CH60='LEP parameters tuned by Professor'
61505 WRITE(M11,5030) CH60
61506 ENDIF
61507 ENDIF
61508
61509C..."Lo FSR" retune (305)
61510 ELSEIF(ITUNEB.EQ.305) THEN
61511 IF (M13.GE.1) THEN
61512 CH60='"Lo FSR retune" with primitive colour reconnections'
61513 WRITE(M11,5030) CH60
61514 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61515 WRITE(M11,5030) CH60
61516 IF (ITUNE.GE.310) THEN
61517 CH60='LEP parameters tuned by Professor'
61518 WRITE(M11,5030) CH60
61519 ENDIF
61520 ENDIF
61521
61522C...Perugia Tunes (320-326)
61523 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61524 IF (M13.GE.1) THEN
61525 CH60='P. Skands, Perugia MPI workshop October 2008'
61526 WRITE(M11,5030) CH60
61527 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61528 WRITE(M11,5030) CH60
61529 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61530 WRITE(M11,5030) CH60
61531 CH60='LEP parameters tuned by Professor'
61532 WRITE(M11,5030) CH60
61533 IF (ITUNE.EQ.325) THEN
61534 CH70='NB! This tune requires MRST LO* pdfs to be '//
61535 & 'externally linked'
61536 WRITE(M11,5035) CH70
61537 ELSEIF (ITUNE.EQ.326) THEN
61538 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
61539 & 'externally linked'
61540 WRITE(M11,5035) CH70
61541 ELSEIF (ITUNE.EQ.321) THEN
61542 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61543 WRITE(M11,5030) CH60
61544 ELSEIF (ITUNE.EQ.322) THEN
61545 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61546 WRITE(M11,5030) CH60
61547 ENDIF
61548 ENDIF
61549
61550C...Professor-pT0 (329)
61551 ELSEIF(ITUNE.EQ.329) THEN
61552 IF (M13.GE.1) THEN
61553 CH60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61554 WRITE(M11,5030) CH60
61555 CH60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61556 WRITE(M11,5030) CH60
61557 CH60='LEP/Tevatron parameters tuned by Professor'
61558 WRITE(M11,5030) CH60
61559 ENDIF
61560
61561 ENDIF
61562
61563C...Output
61564 IF (M13.GE.1) THEN
61565 WRITE(M11,5030) ' '
61566 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61567 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61568 IF (MSTP(70).EQ.0) THEN
61569 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
61570 ELSEIF (MSTP(70).EQ.1) THEN
61571 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
61572 CH60='(Note: PARP(81) replaces PARP(62).)'
61573 WRITE(M11,5030) CH60
61574 ENDIF
61575 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
61576 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61577 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
61578 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
61579 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61580 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61581 WRITE(M11,5030) CH60
61582 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61583 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61584 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61585 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61586 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
61587 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61588 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61589 IF (MSTP(70).EQ.2) THEN
61590 CH60='(Note: PARP(82) replaces PARP(62).)'
61591 WRITE(M11,5030) CH60
61592 ENDIF
61593 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61594 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61595 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61596 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61597 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61598 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61599 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61600 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61601 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
61602 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
61603 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61604 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61605 IF (MSTP(95).GE.1) THEN
61606 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61607 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
61608 ENDIF
61609 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61610 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61611 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61612 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61613 IF (MSTJ(11).LE.3) THEN
61614 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61615 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61616 ELSE
61617 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61618 ENDIF
61619 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61620 ENDIF
61621
61622C=======================================================================
61623C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61624 ELSEIF (ITUNE.EQ.306) THEN
61625 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61626 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61627 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61628 & ' with tune.')
61629 ENDIF
61630
61631C...PDFs
61632 MSTP(52)=2
61633 MSTP(54)=2
61634 MSTP(51)=10042
61635 MSTP(53)=10042
61636C...ISR
61637C PARP(64)=1D0
61638C...UE on, new model.
61639 MSTP(81)=21
61640C...Energy scaling
61641 PARP(89)=1800D0
61642 PARP(90)=0.22D0
61643C...Switch off trial joinings
61644 MSTP(96)=0
61645C...Primordial kT cutoff
61646
61647 IF (M13.GE.1) THEN
61648 CH60='see presentations by A. Moraes (ATLAS),'
61649 WRITE(M11,5030) CH60
61650 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61651 WRITE(M11,5030) CH60
61652 WRITE(M11,5030) ' '
61653 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61654 & 'externally linked'
61655 WRITE(M11,5035) CH70
61656 ENDIF
61657C...Smooth ISR, low FSR
61658 MSTP(70)=2
61659 MSTP(72)=0
61660C...pT0
61661 PARP(82)=1.9D0
61662C...Transverse density profile.
61663 MSTP(82)=4
61664 PARP(83)=0.3D0
61665 PARP(84)=0.5D0
61666C...ISR & FSR in interactions after the first (default)
61667 MSTP(84)=1
61668 MSTP(85)=1
61669C...No double-counting (default)
61670 MSTP(86)=2
61671C...Companion quark parent gluon (1-x) power
61672 MSTP(87)=4
61673C...Primordial kT compensation along chaings (default = 0 : uniform)
61674 MSTP(90)=1
61675C...Colour Reconnections
61676 MSTP(95)=1
61677 PARP(78)=0.2D0
61678C...Lambda_FSR scale.
61679 PARJ(81)=0.23D0
61680C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61681 MSTP(89)=1
61682 MSTP(88)=0
61683C PARP(79)=2D0
61684 PARP(80)=0.01D0
61685C...Peterson charm frag, and c and b hadr parameters
61686 MSTJ(11)=3
61687 PARJ(54)=-0.07
61688 PARJ(55)=-0.006
61689C... Output
61690 IF (M13.GE.1) THEN
61691 WRITE(M11,5030) ' '
61692 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61693 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61694 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61695 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61696 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61697 WRITE(M11,5030) CH60
61698 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61699 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61700 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61701 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61702 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
61703 WRITE(M11,5030) CH60
61704 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61705 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61706 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61707 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61708 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61709 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61710 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
61711 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61712 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61713 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
61714 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61715 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61716 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61717 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61718 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61719 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61720 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61721 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61722 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61723 IF (MSTJ(11).LE.3) THEN
61724 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61725 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61726 ELSE
61727 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61728 ENDIF
61729 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61730 ENDIF
61731
61732C=======================================================================
61733C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61734C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61735C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61736 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
61737 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
61738 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
61739 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
61740 WRITE(M11,5010) ITUNE, CHNAME
61741 CH60='see R.D. Field, in hep-ph/0610012'
61742 WRITE(M11,5030) CH60
61743 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61744 WRITE(M11,5030) CH60
61745 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61746 CH60='LEP parameters tuned by Professor'
61747 WRITE(M11,5030) CH60
61748 ENDIF
61749 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
61750 WRITE(M11,5010) ITUNE, CHNAME
61751 CH60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61752 WRITE(M11,5030) CH60
61753 CH60='LEP/Tevatron parameters tuned by Professor'
61754 WRITE(M11,5030) CH60
61755 ENDIF
61756
61757C...Make sure we start from old default fragmentation parameters
61758 PARJ(81) = 0.29
61759 PARJ(82) = 1.0
61760
61761C...Use Professor's LEP pars if ITUNE >= 110
61762C...(i.e., for A-Pro, DW-Pro etc)
61763 IF (ITUNE.LT.110) THEN
61764C...# Old defaults
61765 MSTJ(11) = 4
61766C...# Old default flavour parameters
61767 PARJ(21) = 0.36
61768 PARJ(41) = 0.30
61769 PARJ(42) = 0.58
61770 PARJ(46) = 1.0
61771 PARJ(82) = 1.0
61772 ELSE
61773C...# Tuned flavour parameters:
61774 PARJ(1) = 0.073
61775 PARJ(2) = 0.2
61776 PARJ(3) = 0.94
61777 PARJ(4) = 0.032
61778 PARJ(11) = 0.31
61779 PARJ(12) = 0.4
61780 PARJ(13) = 0.54
61781 PARJ(25) = 0.63
61782 PARJ(26) = 0.12
61783C...# Switch on Bowler:
61784 MSTJ(11) = 5
61785C...# Fragmentation
61786 PARJ(21) = 0.325
61787 PARJ(41) = 0.5
61788 PARJ(42) = 0.6
61789 PARJ(47) = 0.67
61790 PARJ(81) = 0.29
61791 PARJ(82) = 1.65
61792 ENDIF
61793
61794C...Remove middle digit now for Professor variants, since identical pars
61795 ITUNEB=ITUNE
61796 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61797 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61798 ENDIF
61799
61800C...Multiple interactions on, old framework
61801 MSTP(81)=1
61802C...Fast IR cutoff energy scaling by default
61803 PARP(89)=1800D0
61804 PARP(90)=0.25D0
61805C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61806 MSTP(51)=7
61807 MSTP(52)=1
61808 IF (ITUNEB.EQ.105) THEN
61809 MSTP(51)=10150
61810 MSTP(52)=2
61811 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61812 MSTP(52)=2
61813 MSTP(54)=2
61814 MSTP(51)=10042
61815 MSTP(53)=10042
61816 ENDIF
61817C...Double Gaussian matter distribution.
61818 MSTP(82)=4
61819 PARP(83)=0.5D0
61820 PARP(84)=0.4D0
61821C...FSR activity.
61822 PARP(71)=4D0
61823C...Fragmentation functions and c and b parameters
61824C...(only if not using Professor)
61825 IF (ITUNE.LE.109) THEN
61826 MSTJ(11)=4
61827 PARJ(54)=-0.05
61828 PARJ(55)=-0.005
61829 ENDIF
61830
61831C...Tune A and AW
61832 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
61833C...pT0.
61834 PARP(82)=2.0D0
61835c...String drawing almost completely minimizes string length.
61836 PARP(85)=0.9D0
61837 PARP(86)=0.95D0
61838C...ISR cutoff, muR scale factor, and phase space size
61839 PARP(62)=1D0
61840 PARP(64)=1D0
61841 PARP(67)=4D0
61842C...Intrinsic kT, size, and max
61843 MSTP(91)=1
61844 PARP(91)=1D0
61845 PARP(93)=5D0
61846C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61847 IF (ITUNEB.EQ.101) THEN
61848 PARP(62)=1.25D0
61849 PARP(64)=0.2D0
61850 PARP(91)=2.1D0
61851 PARP(92)=15.0D0
61852 ENDIF
61853
61854C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61855 ELSEIF (ITUNEB.EQ.102) THEN
61856C...pT0.
61857 PARP(82)=1.9D0
61858c...String drawing completely minimizes string length.
61859 PARP(85)=1.0D0
61860 PARP(86)=1.0D0
61861C...ISR cutoff, muR scale factor, and phase space size
61862 PARP(62)=1.25D0
61863 PARP(64)=0.2D0
61864 PARP(67)=1D0
61865C...Intrinsic kT, size, and max
61866 MSTP(91)=1
61867 PARP(91)=2.1D0
61868 PARP(93)=15D0
61869
61870C...Tune DW
61871 ELSEIF (ITUNEB.EQ.103) THEN
61872C...pT0.
61873 PARP(82)=1.9D0
61874c...String drawing completely minimizes string length.
61875 PARP(85)=1.0D0
61876 PARP(86)=1.0D0
61877C...ISR cutoff, muR scale factor, and phase space size
61878 PARP(62)=1.25D0
61879 PARP(64)=0.2D0
61880 PARP(67)=2.5D0
61881C...Intrinsic kT, size, and max
61882 MSTP(91)=1
61883 PARP(91)=2.1D0
61884 PARP(93)=15D0
61885
61886C...Tune DWT
61887 ELSEIF (ITUNEB.EQ.104) THEN
61888C...pT0.
61889 PARP(82)=1.9409D0
61890C...Run II ref scale and slow scaling
61891 PARP(89)=1960D0
61892 PARP(90)=0.16D0
61893c...String drawing completely minimizes string length.
61894 PARP(85)=1.0D0
61895 PARP(86)=1.0D0
61896C...ISR cutoff, muR scale factor, and phase space size
61897 PARP(62)=1.25D0
61898 PARP(64)=0.2D0
61899 PARP(67)=2.5D0
61900C...Intrinsic kT, size, and max
61901 MSTP(91)=1
61902 PARP(91)=2.1D0
61903 PARP(93)=15D0
61904
61905C...Tune QW
61906 ELSEIF(ITUNEB.EQ.105) THEN
61907 IF (M13.GE.1) THEN
61908 WRITE(M11,5030) ' '
61909 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61910 & 'externally linked'
61911 WRITE(M11,5035) CH70
61912 ENDIF
61913C...pT0.
61914 PARP(82)=1.1D0
61915c...String drawing completely minimizes string length.
61916 PARP(85)=1.0D0
61917 PARP(86)=1.0D0
61918C...ISR cutoff, muR scale factor, and phase space size
61919 PARP(62)=1.25D0
61920 PARP(64)=0.2D0
61921 PARP(67)=2.5D0
61922C...Intrinsic kT, size, and max
61923 MSTP(91)=1
61924 PARP(91)=2.1D0
61925 PARP(93)=15D0
61926
61927C...Tune D6 and D6T
61928 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61929 IF (M13.GE.1) THEN
61930 WRITE(M11,5030) ' '
61931 CH70='NB! This tune requires CTEQ6L pdfs to be '//
61932 & 'externally linked'
61933 WRITE(M11,5035) CH70
61934 ENDIF
61935C...The "Rick" proton, double gauss with 0.5/0.4
61936 MSTP(82)=4
61937 PARP(83)=0.5D0
61938 PARP(84)=0.4D0
61939c...String drawing completely minimizes string length.
61940 PARP(85)=1.0D0
61941 PARP(86)=1.0D0
61942 IF (ITUNEB.EQ.108) THEN
61943C...D6: pT0, Run I ref scale, and fast energy scaling
61944 PARP(82)=1.8D0
61945 PARP(89)=1800D0
61946 PARP(90)=0.25D0
61947 ELSE
61948C...D6T: pT0, Run II ref scale, and slow energy scaling
61949 PARP(82)=1.8387D0
61950 PARP(89)=1960D0
61951 PARP(90)=0.16D0
61952 ENDIF
61953C...ISR cutoff, muR scale factor, and phase space size
61954 PARP(62)=1.25D0
61955 PARP(64)=0.2D0
61956 PARP(67)=2.5D0
61957C...Intrinsic kT, size, and max
61958 MSTP(91)=1
61959 PARP(91)=2.1D0
61960 PARP(93)=15D0
61961
61962C...Old ATLAS-DC2 5-parameter tune
61963 ELSEIF(ITUNEB.EQ.106) THEN
61964 IF (M13.GE.1) THEN
61965 WRITE(M11,5010) ITUNE, CHNAME
61966 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
61967 WRITE(M11,5030) CH60
61968 CH60=' R. Field in hep-ph/0610012,'
61969 WRITE(M11,5030) CH60
61970 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61971 WRITE(M11,5030) CH60
61972 ENDIF
61973C... pT0.
61974 PARP(82)=1.8D0
61975C... Different ref and rescaling pacee
61976 PARP(89)=1000D0
61977 PARP(90)=0.16D0
61978C... Parameters of mass distribution
61979 PARP(83)=0.5D0
61980 PARP(84)=0.5D0
61981C... Old default string drawing
61982 PARP(85)=0.33D0
61983 PARP(86)=0.66D0
61984C... ISR, phase space equivalent to Tune B
61985 PARP(62)=1D0
61986 PARP(64)=1D0
61987 PARP(67)=1D0
61988C... FSR
61989 PARP(71)=4D0
61990C... Intrinsic kT
61991 MSTP(91)=1
61992 PARP(91)=1D0
61993 PARP(93)=5D0
61994
61995C...Professor's Pro-Q20 Tune
61996 ELSEIF(ITUNE.EQ.129) THEN
61997 IF (M13.GE.1) THEN
61998 CH60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
61999 WRITE(M11,5030) CH60
62000 ENDIF
62001 PARP(62)=2.9
62002 PARP(64)=0.14
62003 PARP(67)=2.65
62004 PARP(82)=1.9
62005 PARP(83)=0.83
62006 PARP(84)=0.6
62007 PARP(85)=0.86
62008 PARP(86)=0.93
62009 PARP(89)=1800D0
62010 PARP(90)=0.22
62011 MSTP(91)=1
62012 PARP(91)=2.1
62013 PARP(93)=5.0
62014
62015 ENDIF
62016
62017C... Output
62018 IF (M13.GE.1) THEN
62019 WRITE(M11,5030) ' '
62020 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62021 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62022 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62023 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62024 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62025 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62026 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62027 WRITE(M11,5030) CH60
62028 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62029 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62030 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62031 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62032 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62033 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62034 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62035 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62036 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62037 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62038 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62039 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62040 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62041 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62042 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62043 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62044 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62045 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62046 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62047 IF (MSTJ(11).LE.3) THEN
62048 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62049 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62050 ELSE
62051 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62052 ENDIF
62053 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62054 ENDIF
62055
62056C=======================================================================
62057C... ACR, tune A with new CR (107)
62058 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
62059 IF (M13.GE.1) THEN
62060 WRITE(M11,5010) ITUNE, CHNAME
62061 CH60='Tune A modified with new colour reconnections'
62062 WRITE(M11,5030) CH60
62063 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
62064 WRITE(M11,5030) CH60
62065 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
62066 WRITE(M11,5030) CH60
62067 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
62068 WRITE(M11,5030) CH60
62069 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62070 WRITE(M11,5030) CH60
62071 IF (ITUNE.EQ.117) THEN
62072 CH60='LEP parameters tuned by Professor'
62073 WRITE(M11,5030) CH60
62074 ENDIF
62075 ENDIF
62076 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
62077 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62078 & ' with tune. Using defaults.')
62079 GOTO 100
62080 ENDIF
62081
62082C...Make sure we start from old default fragmentation parameters
62083 PARJ(81) = 0.29
62084 PARJ(82) = 1.0
62085
62086C...Use Professor's LEP pars if ITUNE >= 110
62087C...(i.e., for A-Pro, DW-Pro etc)
62088 IF (ITUNE.LT.110) THEN
62089C...# Old defaults
62090 MSTJ(11) = 4
62091C...# Old default flavour parameters
62092 PARJ(21) = 0.36
62093 PARJ(41) = 0.30
62094 PARJ(42) = 0.58
62095 PARJ(46) = 1.0
62096 PARJ(82) = 1.0
62097 ELSE
62098C...# Tuned flavour parameters:
62099 PARJ(1) = 0.073
62100 PARJ(2) = 0.2
62101 PARJ(3) = 0.94
62102 PARJ(4) = 0.032
62103 PARJ(11) = 0.31
62104 PARJ(12) = 0.4
62105 PARJ(13) = 0.54
62106 PARJ(25) = 0.63
62107 PARJ(26) = 0.12
62108C...# Switch on Bowler:
62109 MSTJ(11) = 5
62110C...# Fragmentation
62111 PARJ(21) = 0.325
62112 PARJ(41) = 0.5
62113 PARJ(42) = 0.6
62114 PARJ(47) = 0.67
62115 PARJ(81) = 0.29
62116 PARJ(82) = 1.65
62117 ENDIF
62118
62119 MSTP(81)=1
62120 PARP(89)=1800D0
62121 PARP(90)=0.25D0
62122 MSTP(82)=4
62123 PARP(83)=0.5D0
62124 PARP(84)=0.4D0
62125 MSTP(51)=7
62126 MSTP(52)=1
62127 PARP(71)=4D0
62128 PARP(82)=2.0D0
62129 PARP(85)=0.0D0
62130 PARP(86)=0.66D0
62131 PARP(62)=1D0
62132 PARP(64)=1D0
62133 PARP(67)=4D0
62134 MSTP(91)=1
62135 PARP(91)=1D0
62136 PARP(93)=5D0
62137 MSTP(95)=6
62138C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62139 PARP(78)=0.09D0
62140C...Frag functions (only if not using Professor)
62141 IF (ITUNE.LE.109) THEN
62142 MSTJ(11)=4
62143 PARJ(54)=-0.05
62144 PARJ(55)=-0.005
62145 ENDIF
62146
62147C...Output
62148 IF (M13.GE.1) THEN
62149 WRITE(M11,5030) ' '
62150 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62151 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62152 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62153 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62154 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62155 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62156 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62157 WRITE(M11,5030) CH60
62158 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62159 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62160 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62161 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62162 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62163 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62164 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62165 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62166 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62167 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62168 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62169 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62170 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62171 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62172 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62173 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62174 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62175 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62176 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62177 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62178 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62179 IF (MSTJ(11).LE.3) THEN
62180 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62181 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62182 ELSE
62183 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62184 ENDIF
62185 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62186 ENDIF
62187
62188C=======================================================================
62189C...Intermediate model. Rap tune
62190C...(retuned to post-6.406 IR factorization)
62191 ELSEIF(ITUNE.EQ.200) THEN
62192 IF (M13.GE.1) THEN
62193 WRITE(M11,5010) ITUNE, CHNAME
62194 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62195 WRITE(M11,5030) CH60
62196 ENDIF
62197 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62198 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62199 & ' with tune.')
62200 ENDIF
62201C...PDF
62202 MSTP(51)=7
62203 MSTP(52)=1
62204C...ISR
62205 PARP(62)=1D0
62206 PARP(64)=1D0
62207 PARP(67)=4D0
62208C...FSR
62209 PARP(71)=4D0
62210 PARJ(81)=0.29D0
62211C...UE
62212 MSTP(81)=11
62213 PARP(82)=2.25D0
62214 PARP(89)=1800D0
62215 PARP(90)=0.25D0
62216C... ExpOfPow(1.8) overlap profile
62217 MSTP(82)=5
62218 PARP(83)=1.8D0
62219C... Valence qq
62220 MSTP(88)=0
62221C... Rap Tune
62222 MSTP(89)=1
62223C... Default diquark, BR-g-BR supp
62224 PARP(79)=2D0
62225 PARP(80)=0.01D0
62226C... Final state reconnect.
62227 MSTP(95)=1
62228 PARP(78)=0.55D0
62229C...Fragmentation functions and c and b parameters
62230 MSTJ(11)=4
62231 PARJ(54)=-0.05
62232 PARJ(55)=-0.005
62233C... Output
62234 IF (M13.GE.1) THEN
62235 WRITE(M11,5030) ' '
62236 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62237 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62238 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62239 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62240 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62241 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62242 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62243 WRITE(M11,5030) CH60
62244 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62245 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62246 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62247 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62248 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62249 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62250 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62251 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62252 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62253 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62254 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62255 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62256 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62257 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62258 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62259 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62260 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62261 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62262 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62263 IF (MSTJ(11).LE.3) THEN
62264 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62265 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62266 ELSE
62267 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62268 ENDIF
62269 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62270 ENDIF
62271
62272C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62273C...Old model for ISR and UE, new pT-ordered model for FSR
62274 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
62275 & .ITUNE.EQ.226) THEN
62276 IF (M13.GE.1) THEN
62277 WRITE(M11,5010) ITUNE, CHNAME
62278 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62279 WRITE(M11,5030) CH60
62280 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62281 WRITE(M11,5030) CH60
62282 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62283 WRITE(M11,5030) CH60
62284 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62285 WRITE(M11,5030) CH60
62286 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
62287 CH60='LEP parameters tuned by Professor'
62288 WRITE(M11,5030) CH60
62289 ENDIF
62290 ENDIF
62291 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
62292 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62293 & ' with tune.')
62294 ENDIF
62295C...First set as if Pythia tune A
62296C...Multiple interactions on, old framework
62297 MSTP(81)=1
62298C...Fast IR cutoff energy scaling by default
62299 PARP(89)=1800D0
62300 PARP(90)=0.25D0
62301C...Default CTEQ5L (internal)
62302 MSTP(51)=7
62303 MSTP(52)=1
62304C...Double Gaussian matter distribution.
62305 MSTP(82)=4
62306 PARP(83)=0.5D0
62307 PARP(84)=0.4D0
62308C...FSR activity.
62309 PARP(71)=4D0
62310c...String drawing almost completely minimizes string length.
62311 PARP(85)=0.9D0
62312 PARP(86)=0.95D0
62313C...ISR cutoff, muR scale factor, and phase space size
62314 PARP(62)=1D0
62315 PARP(64)=1D0
62316 PARP(67)=4D0
62317C...Intrinsic kT, size, and max
62318 MSTP(91)=1
62319 PARP(91)=1D0
62320 PARP(93)=5D0
62321C...Use 2 GeV of primordial kT for "Perugia" version
62322 IF (ITUNE.EQ.221) THEN
62323 PARP(91)=2D0
62324 PARP(93)=10D0
62325 ENDIF
62326C...Use pT-ordered FSR
62327 MSTJ(41)=12
62328C...Lambda_FSR scale for pT-ordering
62329 PARJ(81)=0.23D0
62330C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62331 PARP(82)=2.05D0
62332C...Fragmentation functions and c and b parameters
62333C...(overwritten for 211, i.e., if using Professor pars)
62334 PARJ(54)=-0.05
62335 PARJ(55)=-0.005
62336
62337C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62338 IF (ITUNE.LT.210) THEN
62339C...# Old defaults
62340 MSTJ(11) = 4
62341C...# Old default flavour parameters
62342 PARJ(21) = 0.36
62343 PARJ(41) = 0.30
62344 PARJ(42) = 0.58
62345 PARJ(46) = 1.0
62346 PARJ(82) = 1.0
62347 ELSE
62348C...# Tuned flavour parameters:
62349 PARJ(1) = 0.073
62350 PARJ(2) = 0.2
62351 PARJ(3) = 0.94
62352 PARJ(4) = 0.032
62353 PARJ(11) = 0.31
62354 PARJ(12) = 0.4
62355 PARJ(13) = 0.54
62356 PARJ(25) = 0.63
62357 PARJ(26) = 0.12
62358C...# Always use pT-ordered shower:
62359 MSTJ(41) = 12
62360C...# Switch on Bowler:
62361 MSTJ(11) = 5
62362C...# Fragmentation
62363 PARJ(21) = 3.1327e-01
62364 PARJ(41) = 4.8989e-01
62365 PARJ(42) = 1.2018e+00
62366 PARJ(47) = 1.0000e+00
62367 PARJ(81) = 2.5696e-01
62368 PARJ(82) = 8.0000e-01
62369 ENDIF
62370
62371C...221, 226 : Perugia-APT and Perugia-APT6
62372 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
62373
62374 PARP(64)=0.5D0
62375 PARP(82)=2.05D0
62376 PARP(90)=0.26D0
62377 PARP(91)=2.0D0
62378C...The Perugia variants use Steve's showers off the old MPI
62379 MSTP(152)=1
62380C...And use a lower PARP(71) as suggested by Professor tunings
62381C...(although not certain that applies to Q2-pT2 hybrid)
62382 PARP(71)=2.5D0
62383
62384C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62385 IF (ITUNE.EQ.226) THEN
62386 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
62387 & 'externally linked'
62388 WRITE(M11,5035) CH70
62389 MSTP(52)=2
62390 MSTP(51)=10042
62391 PARP(82)=1.95D0
62392 ENDIF
62393
62394 ENDIF
62395
62396C... Output
62397 IF (M13.GE.1) THEN
62398 WRITE(M11,5030) ' '
62399 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62400 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62401 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62402 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62403 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62404 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62405 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62406 WRITE(M11,5030) CH60
62407 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
62408 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62409 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62410 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62411 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62412 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62413 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62414 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62415 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62416 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62417 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62418 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62419 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62420 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62421 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62422 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62423 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62424 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62425 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62426 IF (MSTJ(11).LE.3) THEN
62427 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62428 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62429 ELSE
62430 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62431 ENDIF
62432 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62433 ENDIF
62434
62435C======================================================================
62436C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62437 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
62438 IF (M13.GE.1) THEN
62439 WRITE(M11,5010) ITUNE, CHNAME
62440 CH60='see J. Rathsman, PLB452(1999)364'
62441 WRITE(M11,5030) CH60
62442C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62443C ? WRITE(M11,5030)
62444 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62445 WRITE(M11,5030) CH60
62446 WRITE(M11,5030) ' '
62447 CH70='NB! The GAL model must be run with modified '//
62448 & 'Pythia v6.215:'
62449 WRITE(M11,5035) CH70
62450 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62451 WRITE(M11,5035) CH70
62452 WRITE(M11,5030) ' '
62453 ENDIF
62454C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62455 MSWI(2) = 3
62456 PARSCI(2) = 0.10
62457 MSWI(1) = 2
62458 PARSCI(1) = 0.44
62459 MSTJ(16) = 0
62460 PARJ(42) = 0.45
62461 PARJ(82) = 2.0
62462 PARP(62) = 2.0
62463 MSTP(81) = 1
62464 MSTP(82) = 1
62465 PARP(81) = 1.9
62466 MSTP(92) = 1
62467 IF(CHNAME.EQ.'GAL Tune 1') THEN
62468C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62469 MSTP(82)=4
62470 PARP(83)=0.25D0
62471 PARP(84)=0.5D0
62472 PARP(82) = 1.75
62473 IF (M13.GE.1) THEN
62474 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62475 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62476 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62477 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62478 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62479 ENDIF
62480 ELSE
62481 IF (M13.GE.1) THEN
62482 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62483 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62484 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62485 ENDIF
62486 ENDIF
62487C...Output
62488 IF (M13.GE.1) THEN
62489 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62490 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62491 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62492 CH40='FSI SCI/GAL selection'
62493 WRITE(M11,6040) 1, MSWI(1), CH40
62494 CH40='FSI SCI/GAL sea quark treatment'
62495 WRITE(M11,6040) 2, MSWI(2), CH40
62496 CH40='FSI SCI/GAL sea quark treatment parm'
62497 WRITE(M11,6050) 1, PARSCI(1), CH40
62498 CH40='FSI SCI/GAL string reco probability R_0'
62499 WRITE(M11,6050) 2, PARSCI(2), CH40
62500 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62501 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62502 ENDIF
62503 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
62504 IF (M13.GE.1) THEN
62505 WRITE(M11,5010) ITUNE, CHNAME
62506 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62507 WRITE(M11,5030) CH60
62508 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62509 WRITE(M11,5030) CH60
62510 WRITE(M11,5030) ' '
62511 CH70='NB! The SCI model must be run with modified '//
62512 & 'Pythia v6.215:'
62513 WRITE(M11,5035) CH70
62514 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62515 WRITE(M11,5035) CH70
62516 WRITE(M11,5030) ' '
62517 ENDIF
62518C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62519 MSTP(81)=1
62520 MSTP(82)=1
62521 PARP(81)=2.2
62522 MSTP(92)=1
62523 MSWI(2)=2
62524 PARSCI(2)=0.50
62525 MSWI(1)=2
62526 PARSCI(1)=0.44
62527 MSTJ(16)=0
62528 IF (CHNAME.EQ.'SCI Tune 1') THEN
62529C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62530 MSTP(81) = 1
62531 MSTP(82) = 3
62532 PARP(82) = 2.4
62533 PARP(83) = 0.5D0
62534 PARP(62) = 1.5
62535 PARP(84)=0.25D0
62536 IF (M13.GE.1) THEN
62537 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62538 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62539 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62540 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62541 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62542 ENDIF
62543 ELSE
62544 IF (M13.GE.1) THEN
62545 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62546 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62547 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62548 ENDIF
62549 ENDIF
62550C...Output
62551 IF (M13.GE.1) THEN
62552 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62553 CH40='FSI SCI/GAL selection'
62554 WRITE(M11,6040) 1, MSWI(1), CH40
62555 CH40='FSI SCI/GAL sea quark treatment'
62556 WRITE(M11,6040) 2, MSWI(2), CH40
62557 CH40='FSI SCI/GAL sea quark treatment parm'
62558 WRITE(M11,6050) 1, PARSCI(1), CH40
62559 CH40='FSI SCI/GAL string reco probability R_0'
62560 WRITE(M11,6050) 2, PARSCI(2), CH40
62561 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62562 ENDIF
62563
62564 ELSE
62565 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
62566
62567 ENDIF
62568
62569 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
62570
62571 9999 RETURN
62572
62573 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
62574 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62575 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
62576 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
62577 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
62578 5030 FORMAT(' *',3x,10x,A60,3x,'*')
62579 5035 FORMAT(' *',3x,A70,3x,'*')
62580 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
62581 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
62582 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
62583 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
62584 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
62585 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
62586 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62587 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
62588 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
62589
62590 END
62591
62592C*********************************************************************
62593
62594C...PYEXEC
62595C...Administrates the fragmentation and decay chain.
62596
62597 SUBROUTINE PYEXEC
62598
62599C...Double precision and integer declarations.
62600 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62601 IMPLICIT INTEGER(I-N)
62602 INTEGER PYK,PYCHGE,PYCOMP
62603C...Commonblocks.
62604 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62605 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62606 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62607 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62608 COMMON/PYINT1/MINT(400),VINT(400)
62609 COMMON/PYINT4/MWID(500),WIDS(500,5)
62610 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
62611C...Local array.
62612 DIMENSION PS(2,6),IJOIN(100)
62613
62614C...Initialize and reset.
62615 MSTU(24)=0
62616 IF(MSTU(12).NE.12345) CALL PYLIST(0)
62617 MSTU(29)=0
62618 MSTU(31)=MSTU(31)+1
62619 MSTU(1)=0
62620 MSTU(2)=0
62621 MSTU(3)=0
62622 IF(MSTU(17).LE.0) MSTU(90)=0
62623 MCONS=1
62624
62625C...Sum up momentum, energy and charge for starting entries.
62626 NSAV=N
62627 DO 110 I=1,2
62628 DO 100 J=1,6
62629 PS(I,J)=0D0
62630 100 CONTINUE
62631 110 CONTINUE
62632 DO 130 I=1,N
62633 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
62634 DO 120 J=1,4
62635 PS(1,J)=PS(1,J)+P(I,J)
62636 120 CONTINUE
62637 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
62638 130 CONTINUE
62639 PARU(21)=PS(1,4)
62640
62641C...Start by all decays of coloured resonances involved in shower.
62642 NORIG=N
62643 DO 140 I=1,NORIG
62644 IF(K(I,1).EQ.3) THEN
62645 KC=PYCOMP(K(I,2))
62646 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
62647 ENDIF
62648 140 CONTINUE
62649
62650C...Prepare system for subsequent fragmentation/decay.
62651 CALL PYPREP(0)
62652 IF(MINT(51).NE.0) RETURN
62653
62654C...Loop through jet fragmentation and particle decays.
62655 MBE=0
62656 150 MBE=MBE+1
62657 IP=0
62658 160 IP=IP+1
62659 KC=0
62660 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
62661 IF(KC.EQ.0) THEN
62662
62663C...Deal with any remaining undecayed resonance
62664C...(normally the task of PYEVNT, so seldom used).
62665 ELSEIF(MWID(KC).NE.0) THEN
62666 IBEG=IP
62667 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
62668 IBEG=IP+1
62669 170 IBEG=IBEG-1
62670 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
62671 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
62672 IEND=IP-1
62673 180 IEND=IEND+1
62674 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
62675 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
62676 NJOIN=0
62677 DO 190 I=IBEG,IEND
62678 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
62679 NJOIN=NJOIN+1
62680 IJOIN(NJOIN)=I
62681 ENDIF
62682 190 CONTINUE
62683 ENDIF
62684 CALL PYRESD(IP)
62685 CALL PYPREP(IBEG)
62686 IF(MINT(51).NE.0) RETURN
62687
62688C...Particle decay if unstable and allowed. Save long-lived particle
62689C...decays until second pass after Bose-Einstein effects.
62690 ELSEIF(KCHG(KC,2).EQ.0) THEN
62691 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
62692 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
62693 & CALL PYDECY(IP)
62694
62695C...Decay products may develop a shower.
62696 IF(MSTJ(92).GT.0) THEN
62697 IP1=MSTJ(92)
62698 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
62699 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
62700 MINT(33)=0
62701 CALL PYSHOW(IP1,IP1+1,QMAX)
62702 CALL PYPREP(IP1)
62703 IF(MINT(51).NE.0) RETURN
62704 MSTJ(92)=0
62705 ELSEIF(MSTJ(92).LT.0) THEN
62706 IP1=-MSTJ(92)
62707 MINT(33)=0
62708 CALL PYSHOW(IP1,-3,P(IP,5))
62709 CALL PYPREP(IP1)
62710 IF(MINT(51).NE.0) RETURN
62711 MSTJ(92)=0
62712 ENDIF
62713
62714C...Jet fragmentation: string or independent fragmentation.
62715 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
62716 MFRAG=MSTJ(1)
62717 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
62718 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
62719 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
62720 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
62721 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
62722 ENDIF
62723 ENDIF
62724 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
62725 IF(MFRAG.EQ.2) CALL PYINDF(IP)
62726 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
62727 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
62728 ENDIF
62729
62730C...Loop back if enough space left in PYJETS and no error abort.
62731 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
62732 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
62733 GOTO 160
62734 ELSEIF(IP.LT.N) THEN
62735 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
62736 ENDIF
62737
62738C...Include simple Bose-Einstein effect parametrization if desired.
62739 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
62740 CALL PYBOEI(NSAV)
62741 GOTO 150
62742 ENDIF
62743
62744C...Check that momentum, energy and charge were conserved.
62745 DO 210 I=1,N
62746 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
62747 DO 200 J=1,4
62748 PS(2,J)=PS(2,J)+P(I,J)
62749 200 CONTINUE
62750 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
62751 210 CONTINUE
62752 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
62753 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
62754 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
62755 &'(PYEXEC:) four-momentum was not conserved')
62756 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
62757 &'(PYEXEC:) charge was not conserved')
62758
62759 RETURN
62760 END
62761
62762C*********************************************************************
62763
62764C...PYPREP
62765C...Rearranges partons along strings.
62766C...Special considerations for systems with junctions, with
62767C...possibility of junction-antijunction annihilation.
62768C...Allows small systems to collapse into one or two particles.
62769C...Checks flavours and colour singlet invariant masses.
62770
62771 SUBROUTINE PYPREP(IP)
62772
62773C...Double precision and integer declarations.
62774 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62775 INTEGER PYK,PYCHGE,PYCOMP
62776C...Commonblocks.
62777 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62778 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62779 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
62780 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62781 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62782 COMMON/PYINT1/MINT(400),VINT(400)
62783C...The common block of colour tags.
62784 COMMON/PYCTAG/NCT,MCT(4000,2)
62785 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
62786 &/PYPARS/
62787 DATA NERRPR/0/
62788 SAVE NERRPR
62789C...Local arrays.
62790 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
62791 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
62792 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
62793 &IJCP(0:6),TJUOLD(5)
62794 CHARACTER CHTMP*6
62795
62796C...Function to give four-product.
62797 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)
62798
62799C...Rearrange parton shower product listing along strings: begin loop.
62800 MSTU(24)=0
62801 NOLD=N
62802 I1=N
62803 NJUNC=0
62804 NPIECE=0
62805 NJJSTR=0
62806 MSTU32=MSTU(32)+1
62807 DO 100 I=MAX(1,IP),N
62808C...First store junction positions.
62809 IF(K(I,1).EQ.42) THEN
62810 NJUNC=NJUNC+1
62811 IJUNC(NJUNC,0)=I
62812 IJUNC(NJUNC,4)=0
62813 ENDIF
62814 100 CONTINUE
62815
62816 DO 250 MQGST=1,3
62817 DO 240 I=MAX(1,IP),N
62818C...Special treatment for junctions
62819 IF (K(I,1).LE.0) GOTO 240
62820 IF(K(I,1).EQ.42) THEN
62821C...MQGST=2: Look for junction-junction strings (not detected in the
62822C...main search below).
62823 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
62824 IF (NJJSTR.EQ.0) THEN
62825 NJJSTR = (3*NJUNC-NPIECE)/2
62826 ENDIF
62827C...Check how many already identified strings end on this junction
62828 ILC=0
62829 DO 110 J=1,NPIECE
62830 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
62831 110 CONTINUE
62832C...If less than 3, remaining must be to another junction
62833 IF (ILC.LT.3) THEN
62834 IF (ILC.NE.2) THEN
62835C...Multiple j-j connections not handled yet.
62836 CALL PYERRM(2,
62837 & '(PYPREP:) Too many junction-junction strings.')
62838 MINT(51)=1
62839 RETURN
62840 ENDIF
62841C...The colour information in the junction is unreadable for the
62842C...colour space search further down in this routine, so we must
62843C...start on the colour mother of this junction and then "artificially"
62844C...prevent the colour mother from connecting here again.
62845 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
62846 KCS=4
62847 IF (MOD(ITJUNC,2).EQ.0) KCS=5
62848C...Switch colour if the junction-junction leg is presumably a
62849C...junction mother leg rather than a junction daughter leg.
62850 IF (ITJUNC.GE.3) KCS=9-KCS
62851 IF (MINT(33).EQ.0) THEN
62852C...Find the unconnected leg and reorder junction daughter pointers so
62853C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62854C...piece.
62855 IA=MOD(K(I,4),MSTU(5))
62856 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
62857 ITMP=MOD(K(I,5),MSTU(5))
62858 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
62859 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
62860 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
62861 ELSE
62862 K(I,5)=K(I,5)+(IA-ITMP)
62863 ENDIF
62864 K(I,4)=K(I,4)+(ITMP-IA)
62865 IA=ITMP
62866 ENDIF
62867 IF (ITJUNC.LE.2) THEN
62868C...Beam baryon junction
62869 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
62870 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
62871C...Else 1 -> 2 decay junction
62872 ELSE
62873 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
62874 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
62875 ENDIF
62876 I1BEG = I1
62877 NSTP = 0
62878 GOTO 170
62879C...Alternatively use colour tag information.
62880 ELSE
62881C...Find a final state parton with appropriate dangling colour tag.
62882 JCT=0
62883 IA=0
62884 IJUMO=K(I,3)
62885 DO 140 J1=MAX(1,IP),N
62886 IF (K(J1,1).NE.3) GOTO 140
62887C...Check for matching final-state colour tag
62888 IMATCH=0
62889 DO 120 J2=MAX(1,IP),N
62890 IF (K(J2,1).NE.3) GOTO 120
62891 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
62892 120 CONTINUE
62893 IF (IMATCH.EQ.1) GOTO 140
62894C...Check whether this colour tag belongs to the present junction
62895C...by seeing whether any parton with this colour tag has the same
62896C...mother as the junction.
62897 JCT=MCT(J1,KCS-3)
62898 IMATCH=0
62899 DO 130 J2=MINT(84)+1,N
62900 IMO2=K(J2,3)
62901C...First scattering partons have IMO1 = 3 and 4.
62902 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
62903 & IMO2=IMO2-2
62904 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
62905 & IMATCH=1
62906 130 CONTINUE
62907 IF (IMATCH.EQ.0) GOTO 140
62908 IA=J1
62909 140 CONTINUE
62910C...Check for junction-junction strings without intermediate final state
62911C...glue (not detected above).
62912 IF (IA.EQ.0) THEN
62913 DO 160 MJU=1,NJUNC
62914 IJU2=IJUNC(MJU,0)
62915 IF (IJU2.EQ.I) GOTO 160
62916 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
62917C...Only opposite types of junctions can connect to each other.
62918 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
62919 IS=0
62920 DO 150 J=1,NPIECE
62921 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
62922 150 CONTINUE
62923 IF (IS.EQ.3) GOTO 160
62924 IB=I
62925 IA=IJU2
62926 160 CONTINUE
62927 ENDIF
62928C...Switch to other side of adjacent parton and step from there.
62929 KCS=9-KCS
62930 I1BEG = I1
62931 NSTP = 0
62932 GOTO 170
62933 ENDIF
62934 ELSE IF (ILC.NE.3) THEN
62935 ENDIF
62936 ENDIF
62937 ENDIF
62938
62939C...Look for coloured string endpoint, or (later) leftover gluon.
62940 IF(K(I,1).NE.3) GOTO 240
62941 KC=PYCOMP(K(I,2))
62942 IF(KC.EQ.0) GOTO 240
62943 KQ=KCHG(KC,2)
62944 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
62945
62946C...Pick up loose string end.
62947 KCS=4
62948 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
62949 IA=I
62950 IB=I
62951 I1BEG=I1
62952 NSTP=0
62953 170 NSTP=NSTP+1
62954 IF(NSTP.GT.4*N) THEN
62955 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
62956 MINT(51)=1
62957 RETURN
62958 ENDIF
62959
62960C...Copy undecayed parton. Finished if reached string endpoint.
62961 IF(K(IA,1).EQ.3) THEN
62962 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
62963 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62964 MINT(51)=1
62965 MSTU(24)=1
62966 RETURN
62967 ENDIF
62968 I1=I1+1
62969 K(I1,1)=2
62970 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
62971 K(I1,2)=K(IA,2)
62972 K(I1,3)=IA
62973 K(I1,4)=0
62974 K(I1,5)=0
62975 DO 180 J=1,5
62976 P(I1,J)=P(IA,J)
62977 V(I1,J)=V(IA,J)
62978 180 CONTINUE
62979 K(IA,1)=K(IA,1)+10
62980 IF(K(I1,1).EQ.1) GOTO 240
62981 ENDIF
62982
62983C...Also finished (for now) if reached junction; then copy to end.
62984 IF(K(IA,1).EQ.42) THEN
62985 NCOPY=I1-I1BEG
62986 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
62987 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62988 MINT(51)=1
62989 MSTU(24)=1
62990 RETURN
62991 ENDIF
62992 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
62993 DO 200 ICOPY=1,NCOPY
62994 DO 190 J=1,5
62995 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
62996 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
62997 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
62998 190 CONTINUE
62999 200 CONTINUE
63000 ENDIF
63001C...For junction-junction strings, find end leg and reorder junction
63002C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
63003C...junction-junction string piece.
63004 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
63005 ITMP=MOD(K(IA,4),MSTU(5))
63006 IF (ITMP.NE.IB) THEN
63007 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
63008 K(IA,5)=K(IA,5)+(ITMP-IB)
63009 ELSE
63010 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
63011 ENDIF
63012 K(IA,4)=K(IA,4)+(IB-ITMP)
63013 ENDIF
63014 ENDIF
63015 NPIECE=NPIECE+1
63016C...IPIECE:
63017C...0: endpoint in original ER
63018C...1:
63019C...2:
63020C...3: Parton immediately next to junction
63021C...4: Junction
63022 IPIECE(NPIECE,0)=I
63023 IPIECE(NPIECE,1)=MSTU32+1
63024 IPIECE(NPIECE,2)=MSTU32+NCOPY
63025 IPIECE(NPIECE,3)=IB
63026 IPIECE(NPIECE,4)=IA
63027 MSTU32=MSTU32+NCOPY
63028 I1=I1BEG
63029 GOTO 240
63030 ENDIF
63031
63032C...GOTO next parton in colour space.
63033 IB=IA
63034 IF (MINT(33).EQ.0) THEN
63035 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
63036 & )).NE.0) THEN
63037 IA=MOD(K(IB,KCS),MSTU(5))
63038 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
63039 MREV=0
63040 ELSE
63041 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
63042 & MSTU(5)).EQ.0) KCS=9-KCS
63043 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
63044 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
63045 MREV=1
63046 ENDIF
63047 IF(IA.LE.0.OR.IA.GT.N) THEN
63048 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
63049 IF(NERRPR.LT.5) THEN
63050 NERRPR=NERRPR+1
63051 WRITE(MSTU(11),*) 'started at:', I
63052 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
63053 WRITE(MSTU(11),*) 'MQGST =',MQGST
63054 CALL PYLIST(4)
63055 ENDIF
63056 MINT(51)=1
63057 RETURN
63058 ENDIF
63059 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
63060 & ,MSTU(5)).EQ.IB) THEN
63061 IF(MREV.EQ.1) KCS=9-KCS
63062 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
63063 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
63064 ELSE
63065 IF(MREV.EQ.0) KCS=9-KCS
63066 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
63067 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
63068 ENDIF
63069 IF(IA.NE.I) GOTO 170
63070C...Use colour tag information
63071 ELSE
63072C...First create colour tags starting on IB if none already present.
63073 IF (MCT(IB,KCS-3).EQ.0) THEN
63074 CALL PYCTTR(IB,KCS,IB)
63075 IF(MINT(51).NE.0) RETURN
63076 ENDIF
63077 JCT=MCT(IB,KCS-3)
63078 IFOUND=0
63079C...Find final state tag partner
63080 DO 210 IT=MAX(1,IP),N
63081 IF (IT.EQ.IB) GOTO 210
63082 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
63083 & .0) THEN
63084 IFOUND=IFOUND+1
63085 IA=IT
63086 ENDIF
63087 210 CONTINUE
63088C...Just copy and goto next if exactly one partner found.
63089 IF (IFOUND.EQ.1) THEN
63090 GOTO 170
63091C...When no match found, match is presumably junction.
63092 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
63093C...Check whether this colour tag matches a junction
63094C...by seeing whether any parton with this colour tag has the same
63095C...mother as a junction.
63096C...NB: Only type 1 and 2 junctions handled presently.
63097 DO 230 IJU=1,NJUNC
63098 IJUMO=K(IJUNC(IJU,0),3)
63099 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
63100C...Colours only connect to junctions, anti-colours to antijunctions:
63101 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
63102 IMATCH=0
63103 DO 220 J1=MAX(1,IP),N
63104 IF (K(J1,1).LE.0) GOTO 220
63105C...First scattering partons have IMO1 = 3 and 4.
63106 IMO=K(J1,3)
63107 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
63108 & IMO=IMO-2
63109 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
63110 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
63111 & IMATCH=1
63112C...Attempt at handling type > 3 junctions also. Not tested.
63113 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
63114 & .IJUMO) IMATCH=1
63115 220 CONTINUE
63116 IF (IMATCH.EQ.0) GOTO 230
63117 IA=IJUNC(IJU,0)
63118 IFOUND=IFOUND+1
63119 230 CONTINUE
63120
63121 IF (IFOUND.EQ.1) THEN
63122 GOTO 170
63123 ELSEIF (IFOUND.EQ.0) THEN
63124 WRITE(CHTMP,*) JCT
63125 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
63126 & //CHTMP)
63127 IF(NERRPR.LT.5) THEN
63128 NERRPR=NERRPR+1
63129 CALL PYLIST(4)
63130 ENDIF
63131 MINT(51)=1
63132 RETURN
63133 ENDIF
63134 ELSEIF (IFOUND.GE.2) THEN
63135 WRITE(CHTMP,*) JCT
63136 CALL PYERRM(12
63137 & ,'(PYPREP:) too many occurences of colour line: '//
63138 & CHTMP)
63139 IF(NERRPR.LT.5) THEN
63140 NERRPR=NERRPR+1
63141 CALL PYLIST(4)
63142 ENDIF
63143 MINT(51)=1
63144 RETURN
63145 ENDIF
63146 ENDIF
63147 K(I1,1)=1
63148 240 CONTINUE
63149 250 CONTINUE
63150
63151C...Junction systems remain.
63152 IJU=0
63153 IJUS=0
63154 IJUCNT=0
63155 MREV=0
63156 IJJSTR=0
63157 260 IJUCNT=IJUCNT+1
63158 IF (IJUCNT.LE.NJUNC) THEN
63159C...If we are not processing a j-j string, treat this junction as new.
63160 IF (IJJSTR.EQ.0) THEN
63161 IJU=IJUNC(IJUCNT,0)
63162 MREV=0
63163C...If junction has already been read, ignore it.
63164 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
63165C...If we are on a j-j string, goto second j-j junction.
63166 ELSE
63167 IJUCNT=IJUCNT-1
63168 IJU=IJUS
63169 ENDIF
63170C...Mark selected junction read.
63171 DO 270 J=1,NJUNC
63172 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
63173 270 CONTINUE
63174C...Determine junction type
63175 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
63176C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63177C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63178C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63179 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
63180 IHK=0
63181 280 IHK=IHK+1
63182C...Find which quarks belong to given junction.
63183 IHF=0
63184 DO 290 IPC=1,NPIECE
63185 IF (IPIECE(IPC,4).EQ.IJU) THEN
63186 IHF=IHF+1
63187 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
63188 ENDIF
63189 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
63190 290 CONTINUE
63191C...IHK = 3 is special. Either normal string piece, or j-j string.
63192 IF(IHK.EQ.3) THEN
63193 IF (MREV.NE.1) THEN
63194 DO 300 IPC=1,NPIECE
63195C...If there is a j-j string starting on the present junction which has
63196C...zero length, insert next junction immediately.
63197 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
63198 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
63199 IJJSTR = 1
63200 GOTO 340
63201 ENDIF
63202 300 CONTINUE
63203 MREV = 1
63204C...If MREV is 1 and IHK is 3 we are finished with this system.
63205 ELSE
63206 MREV=0
63207 GOTO 260
63208 ENDIF
63209 ENDIF
63210
63211C...If we've gotten this far, then either IHK < 3, or
63212C...an interjunction string exists, or just a third normal string.
63213 IJUNC(IJUCNT,IHK)=0
63214 IJJSTR = 0
63215C..Order pieces belonging to this junction. Also look for j-j.
63216 DO 310 IPC=1,NPIECE
63217 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
63218 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
63219 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
63220 IJUNC(IJUCNT,IHK)=IPC
63221 IJJSTR = 1
63222 MREV = 0
63223 ENDIF
63224 310 CONTINUE
63225C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63226 IPC=IJUNC(IJUCNT,IHK)
63227C...Temporary solution to cover for bug.
63228 IF(IPC.LE.0) THEN
63229 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
63230 MINT(51)=1
63231 RETURN
63232 ENDIF
63233 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
63234 I1=I1+1
63235 DO 320 J=1,5
63236 K(I1,J)=K(MSTU(4)-ICP,J)
63237 P(I1,J)=P(MSTU(4)-ICP,J)
63238 V(I1,J)=V(MSTU(4)-ICP,J)
63239 320 CONTINUE
63240 330 CONTINUE
63241 K(I1,1)=2
63242C...Mark last quark.
63243 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
63244C...Do not insert junctions at wrong places.
63245 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
63246C...Insert junction.
63247 340 IJUS = IJU
63248 IF (IHK.EQ.3) THEN
63249C...Shift to end junction if a j-j string has been processed.
63250 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
63251 MREV= 1
63252 ENDIF
63253 I1=I1+1
63254 DO 350 J=1,5
63255 K(I1,J)=0
63256 P(I1,J)=0.
63257 V(I1,J)=0.
63258 350 CONTINUE
63259 K(I1,1)=41
63260 K(IJUS,1)=K(IJUS,1)+10
63261 K(I1,2)=K(IJUS,2)
63262 K(I1,3)=IJUS
63263 360 IF (IHK.LT.3) GOTO 280
63264 ELSE
63265 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
63266 MINT(51)=1
63267 RETURN
63268 ENDIF
63269 IF (IJUCNT.NE.NJUNC) GOTO 260
63270 ENDIF
63271 N=I1
63272
63273C...Rearrange three strings from junction, e.g. in case one has been
63274C...shortened by shower, so the last is the largest-energy one.
63275 IF(NJUNC.GE.1) THEN
63276C...Find systems with exactly one junction.
63277 MJUN1=0
63278 NBEG=NOLD+1
63279 DO 470 I=NOLD+1,N
63280 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
63281 ELSEIF(K(I,1).EQ.41) THEN
63282 MJUN1=MJUN1+1
63283 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
63284 MJUN1=0
63285 NBEG=I+1
63286 ELSE
63287 NEND=I
63288C...Sum up energy-momentum in each junction string.
63289 DO 370 J=1,5
63290 PJU(1,J)=0D0
63291 PJU(2,J)=0D0
63292 PJU(3,J)=0D0
63293 370 CONTINUE
63294 NJU=0
63295 DO 390 I1=NBEG,NEND
63296 IF(K(I1,2).NE.21) THEN
63297 NJU=NJU+1
63298 IJUR(NJU)=I1
63299 ENDIF
63300 DO 380 J=1,5
63301 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
63302 380 CONTINUE
63303 390 CONTINUE
63304C...Find which of them has highest energy (minus mass) in rest frame.
63305 DO 400 J=1,5
63306 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63307 400 CONTINUE
63308 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
63309 & PJU(4,3)**2))
63310 DO 410 I2=1,3
63311 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
63312 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
63313 410 CONTINUE
63314 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
63315C...Decide how to rearrange so that new last has highest energy.
63316 IF(PJU(1,6).LT.PJU(2,6)) THEN
63317 IRNG(1,1)=IJUR(1)
63318 IRNG(1,2)=IJUR(2)-1
63319 IRNG(2,1)=IJUR(4)
63320 IRNG(2,2)=IJUR(3)+1
63321 IRNG(4,1)=IJUR(3)-1
63322 IRNG(4,2)=IJUR(2)
63323 ELSE
63324 IRNG(1,1)=IJUR(4)
63325 IRNG(1,2)=IJUR(3)+1
63326 IRNG(2,1)=IJUR(2)
63327 IRNG(2,2)=IJUR(3)-1
63328 IRNG(4,1)=IJUR(2)-1
63329 IRNG(4,2)=IJUR(1)
63330 ENDIF
63331 IRNG(3,1)=IJUR(3)
63332 IRNG(3,2)=IJUR(3)
63333C...Copy in correct order below bottom of current event record.
63334 I2=N
63335 DO 440 II=1,4
63336 DO 430 I1=IRNG(II,1),IRNG(II,2),
63337 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
63338 I2=I2+1
63339 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
63340 CALL PYERRM(11,
63341 & '(PYPREP:) no more memory left in PYJETS')
63342 MINT(51)=1
63343 MSTU(24)=1
63344 RETURN
63345 ENDIF
63346 DO 420 J=1,5
63347 K(I2,J)=K(I1,J)
63348 P(I2,J)=P(I1,J)
63349 V(I2,J)=V(I1,J)
63350 420 CONTINUE
63351 IF(K(I2,1).EQ.1) K(I2,1)=2
63352 430 CONTINUE
63353 440 CONTINUE
63354 K(I2,1)=1
63355C...Copy back up, overwriting but now in correct order.
63356 DO 460 I1=NBEG,NEND
63357 I2=I1-NBEG+N+1
63358 DO 450 J=1,5
63359 K(I1,J)=K(I2,J)
63360 P(I1,J)=P(I2,J)
63361 V(I1,J)=V(I2,J)
63362 450 CONTINUE
63363 460 CONTINUE
63364 ENDIF
63365 MJUN1=0
63366 NBEG=I+1
63367 ENDIF
63368 470 CONTINUE
63369
63370C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63371C...to two q-qbar systems.
63372C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63373 IF (MSTJ(19).NE.1) THEN
63374 MJUN1 = 0
63375 JJGLUE = 0
63376 NBEG = NOLD+1
63377C...Force collapse when MSTJ(19)=2.
63378 IF (MSTJ(19).EQ.2) THEN
63379 DELMJJ = 1D9
63380 DELMQQ = 0D0
63381 ENDIF
63382C...Find systems with exactly two junctions.
63383 DO 700 I=NOLD+1,N
63384C...Count junctions
63385 IF (K(I,1).EQ.41) THEN
63386 MJUN1 = MJUN1+1
63387C...Check for interjunction gluons
63388 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
63389 JJGLUE = 1
63390 ENDIF
63391 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
63392C...If end of system reached with either zero or one junction, restart
63393C...with next system.
63394 MJUN1 = 0
63395 JJGLUE = 0
63396 NBEG = I+1
63397 ELSEIF(K(I,1).EQ.1) THEN
63398C...If end of system reached with exactly two junctions, compute string
63399C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63400C...length measure for the (q-qbar)(q-qbar) topology.
63401 NEND=I
63402C...Loop down through chain.
63403 ISID=0
63404 DO 480 I1=NBEG,NEND
63405C...Store string piece division locations in event record
63406 IF (K(I1,2).NE.21) THEN
63407 ISID = ISID+1
63408 IJCP(ISID) = I1
63409 ENDIF
63410 480 CONTINUE
63411C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63412 ISW=0
63413 IF (PYR(0).LT.0.5D0) ISW=1
63414C...Randomly choose which qqbar string gets the jj gluons.
63415 IGS=1
63416 IF (PYR(0).GT.0.5D0) IGS=2
63417C...Only compute string lengths when no topology forced.
63418 IF (MSTJ(19).EQ.0) THEN
63419C...Repeat following for each junction
63420 DO 570 IJU=1,2
63421C...Initialize iterative procedure for finding JRF
63422 IJRFIT=0
63423 DO 490 IX=1,3
63424 TJUOLD(IX)=0D0
63425 490 CONTINUE
63426 TJUOLD(4)=1D0
63427C...Start iteration. Sum up momenta in string pieces
63428 500 DO 540 IJS=1,3
63429C...JD=-1 for first junction, +1 for second junction.
63430C...Find out where piece starts and ends and which direction to go.
63431 JD=2*IJU-3
63432 IF (IJS.LE.2) THEN
63433 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
63434 IB = IJCP((IJU-1)*7 - JD*IJS)
63435 ELSEIF (IJS.EQ.3) THEN
63436 JD =-JD
63437 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
63438 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
63439 ENDIF
63440C...Initialize junction pull 4-vector.
63441 DO 510 J=1,5
63442 PUL(IJS,J)=0D0
63443 510 CONTINUE
63444C...Initialize weight
63445 PWT = 0D0
63446 PWTOLD = 0D0
63447C...Sum up (weighted) momenta along each string piece
63448 DO 530 ISP=IA,IB,JD
63449C...If present parton not last in chain
63450 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
63451C...If last parton was a junction, store present weight
63452 IF (K(ISP-JD,2).EQ.88) THEN
63453 PWTOLD = PWT
63454C...If last parton was a quark, reset to stored weight.
63455 ELSEIF (K(ISP-JD,2).NE.21) THEN
63456 PWT = PWTOLD
63457 ENDIF
63458 ENDIF
63459C...Skip next parton if weight already large
63460 IF (PWT.GT.10D0) GOTO 530
63461C...Compute momentum in TJUOLD frame:
63462 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
63463 & )*P(ISP,3)
63464 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
63465 DO 520 J=1,3
63466 TMP=P(ISP,J)+TJUOLD(J)*BFC
63467 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
63468 520 CONTINUE
63469C...Boosted energy
63470 TMP=TJUOLD(4)*P(ISP,4)+TDP
63471 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
63472C...Update weight
63473 PWT=PWT+TMP/PARJ(48)
63474C...Put |p| rather than m in 5th slot
63475 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
63476 & +PUL(IJS,3)**2)
63477 530 CONTINUE
63478 540 CONTINUE
63479C...Compute boost
63480 IJRFIT=IJRFIT+1
63481 CALL PYJURF(PUL,T)
63482C...Combine new boost (T) with old boost (TJUOLD)
63483 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
63484 DO 550 IX=1,3
63485 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
63486 & ))
63487 550 CONTINUE
63488 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
63489 & **2)
63490C...If last boost small, accept JRF, else iterate.
63491C...Also prevent possibility of infinite loop.
63492 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
63493 & IJRFIT.LT.MSTJ(18))THEN
63494 GOTO 500
63495 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
63496 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
63497 ENDIF
63498C...Store final boost, with change of sign since TJJ motion vector.
63499 DO 560 IX=1,3
63500 TJJ(IJU,IX)=-TJUOLD(IX)
63501 560 CONTINUE
63502 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
63503 & +TJJ(IJU,3)**2)
63504 570 CONTINUE
63505C...String length measure for (q-qbar)(q-qbar) topology.
63506C...Note only momenta of nearest partons used (since rest of system
63507C...identical).
63508 IF (JJGLUE.EQ.0) THEN
63509 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
63510 & -1,IJCP(5-ISW)+1)
63511 ELSE
63512C...Put jj gluons on selected string (IGS selected randomly above).
63513 IF (IGS.EQ.1) THEN
63514 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63515 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
63516 ELSE
63517 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
63518 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63519 & ,IJCP(5-ISW)+1)
63520 ENDIF
63521 ENDIF
63522C...String length measure for q-q-j-j-q-q topology.
63523 T1G1=0D0
63524 T2G2=0D0
63525 T1T2=0D0
63526 T1P1=0D0
63527 T1P2=0D0
63528 T2P3=0D0
63529 T2P4=0D0
63530 ISGN=-1
63531C...Note only momenta of nearest partons used (since rest of system
63532C...identical).
63533 DO 580 IX=1,4
63534 IF (IX.EQ.4) ISGN=1
63535 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
63536 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
63537 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
63538 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
63539 IF (JJGLUE.EQ.0) THEN
63540C...Junction motion vector dot product gives length when inter-junction
63541C...gluons absent.
63542 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
63543 ELSE
63544C...Junction motion vector dot products with gluon momenta give length
63545C...when inter-junction gluons present.
63546 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
63547 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
63548 ENDIF
63549 580 CONTINUE
63550 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
63551 IF (JJGLUE.EQ.0) THEN
63552 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
63553 ELSE
63554 DELMJJ=DELMJJ*4D0*T1G1*T2G2
63555 ENDIF
63556 ENDIF
63557C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63558C...(Always the case for MSTJ(19)=2 due to initialization above)
63559 IF (DELMJJ.GT.DELMQQ) THEN
63560C...Put new system at end of event record
63561 NCOP=N
63562 DO 650 IST=1,2
63563 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
63564 NCOP=NCOP+1
63565 DO 590 IX=1,5
63566 P(NCOP,IX)=P(ICOP,IX)
63567 K(NCOP,IX)=K(ICOP,IX)
63568 590 CONTINUE
63569 600 CONTINUE
63570 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
63571C...Insert inter-junction gluon string piece (reversed)
63572 NJJGL=0
63573 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
63574 NJJGL=NJJGL+1
63575 NCOP=NCOP+1
63576 DO 610 IX=1,5
63577 P(NCOP,IX)=P(ICOP,IX)
63578 K(NCOP,IX)=K(ICOP,IX)
63579 610 CONTINUE
63580 620 CONTINUE
63581 ENDIF
63582 IFC=-2*IST+3
63583 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
63584 NCOP=NCOP+1
63585 DO 630 IX=1,5
63586 P(NCOP,IX)=P(ICOP,IX)
63587 K(NCOP,IX)=K(ICOP,IX)
63588 630 CONTINUE
63589 640 CONTINUE
63590 K(NCOP,1)=1
63591 650 CONTINUE
63592C...Copy system back in right order
63593 DO 670 ICOP=NBEG,NEND-2
63594 DO 660 IX=1,5
63595 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
63596 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
63597 660 CONTINUE
63598 670 CONTINUE
63599C...Shift down rest of event record
63600 DO 690 ICOP=NEND+1,N
63601 DO 680 IX=1,5
63602 P(ICOP-2,IX)=P(ICOP,IX)
63603 K(ICOP-2,IX)=K(ICOP,IX)
63604 680 CONTINUE
63605 690 CONTINUE
63606C...Update length of event record.
63607 N=N-2
63608 ENDIF
63609 MJUN1=0
63610 NBEG=I+1
63611 ENDIF
63612 700 CONTINUE
63613 ENDIF
63614 ENDIF
63615
63616C...Done if no checks on small-mass systems.
63617 IF(MSTJ(14).LT.0) RETURN
63618 IF(MSTJ(14).EQ.0) GOTO 1140
63619
63620C...Find lowest-mass colour singlet jet system.
63621 NS=N
63622 710 NSIN=N-NS
63623 PDMIN=1D0+PARJ(32)
63624 IC=0
63625 DO 770 I=MAX(1,IP),N
63626 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
63627 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
63628 NSIN=NSIN+1
63629 IC=I
63630 DO 720 J=1,4
63631 DPS(J)=P(I,J)
63632 720 CONTINUE
63633 MSTJ(93)=1
63634 DPS(5)=PYMASS(K(I,2))
63635 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
63636 DO 730 J=1,4
63637 DPS(J)=DPS(J)+P(I,J)
63638 730 CONTINUE
63639 MSTJ(93)=1
63640 DPS(5)=DPS(5)+PYMASS(K(I,2))
63641 ELSEIF(K(I,1).EQ.2) THEN
63642 DO 740 J=1,4
63643 DPS(J)=DPS(J)+P(I,J)
63644 740 CONTINUE
63645 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63646 DO 750 J=1,4
63647 DPS(J)=DPS(J)+P(I,J)
63648 750 CONTINUE
63649 MSTJ(93)=1
63650 DPS(5)=DPS(5)+PYMASS(K(I,2))
63651 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
63652 & DPS(5)
63653 IF(PD.LT.PDMIN) THEN
63654 PDMIN=PD
63655 DO 760 J=1,5
63656 DPC(J)=DPS(J)
63657 760 CONTINUE
63658 IC1=IC
63659 IC2=I
63660 ENDIF
63661 IC=0
63662 ELSE
63663 NSIN=NSIN+1
63664 ENDIF
63665 770 CONTINUE
63666
63667C...Done if lowest-mass system above threshold for string frag.
63668 IF(PDMIN.GE.PARJ(32)) GOTO 1140
63669
63670C...Fill small-mass system as cluster.
63671 NSAV=N
63672 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
63673 K(N+1,1)=11
63674 K(N+1,2)=91
63675 K(N+1,3)=IC1
63676 P(N+1,1)=DPC(1)
63677 P(N+1,2)=DPC(2)
63678 P(N+1,3)=DPC(3)
63679 P(N+1,4)=DPC(4)
63680 P(N+1,5)=PECM
63681
63682C...Set up history, assuming cluster -> 2 hadrons.
63683 NBODY=2
63684 K(N+1,4)=N+2
63685 K(N+1,5)=N+3
63686 K(N+2,1)=1
63687 K(N+3,1)=1
63688 IF(MSTU(16).NE.2) THEN
63689 K(N+2,3)=N+1
63690 K(N+3,3)=N+1
63691 ELSE
63692 K(N+2,3)=IC1
63693 K(N+3,3)=IC2
63694 ENDIF
63695 K(N+2,4)=0
63696 K(N+3,4)=0
63697 K(N+2,5)=0
63698 K(N+3,5)=0
63699 V(N+1,5)=0D0
63700 V(N+2,5)=0D0
63701 V(N+3,5)=0D0
63702
63703C...Find total flavour content - complicated by presence of junctions.
63704 NQ=0
63705 NDIQ=0
63706 DO 780 I=IC1,IC2
63707 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
63708 NQ=NQ+1
63709 KFQ(NQ)=K(I,2)
63710 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
63711 ENDIF
63712 780 CONTINUE
63713
63714C...If several diquarks, split up one to give even number of flavours.
63715 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
63716 I1=3
63717 IF(IABS(KFQ(3)).LT.1000) I1=1
63718 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
63719 KFQ(I1)=KFQ(I1)/1000
63720 NQ=4
63721 NDIQ=NDIQ-1
63722 ENDIF
63723
63724C...If four quark ends, join two to diquark.
63725 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
63726 I1=1
63727 I2=2
63728 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
63729 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
63730 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63731 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63732 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63733 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63734 KFQ(I2)=KFQ(4)
63735 NQ=3
63736 NDIQ=1
63737 ENDIF
63738
63739C...If two quark ends, plus quark or diquark, join quarks to diquark.
63740 IF(NQ.EQ.3) THEN
63741 I1=1
63742 I2=2
63743 IF(IABS(KFQ(I1)).GT.1000) I1=3
63744 IF(IABS(KFQ(I2)).GT.1000) I2=3
63745 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63746 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63747 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63748 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63749 KFQ(I2)=KFQ(3)
63750 NQ=2
63751 NDIQ=NDIQ+1
63752 ENDIF
63753
63754C...Form two particles from flavours of lowest-mass system, if feasible.
63755 NTRY = 0
63756 790 NTRY = NTRY + 1
63757
63758C...Open string with two specified endpoint flavours.
63759 IF(NQ.EQ.2) THEN
63760 KC1=PYCOMP(KFQ(1))
63761 KC2=PYCOMP(KFQ(2))
63762 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
63763 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63764 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63765 IF(KQ1+KQ2.NE.0) GOTO 1140
63766C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63767 800 K1=KFQ(1)
63768 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
63769 MSTU(125)=0
63770 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
63771 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
63772 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
63773
63774C...Open string with four specified flavours.
63775 ELSEIF(NQ.EQ.4) THEN
63776 KC1=PYCOMP(KFQ(1))
63777 KC2=PYCOMP(KFQ(2))
63778 KC3=PYCOMP(KFQ(3))
63779 KC4=PYCOMP(KFQ(4))
63780 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
63781 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63782 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63783 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
63784 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
63785 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
63786C...Combine flavours pairwise to form two hadrons.
63787 810 I1=1
63788 I2=2
63789 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63790 & IABS(KFQ(2)).GT.1000)) I2=3
63791 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63792 & IABS(KFQ(3)).GT.1000))) I2=4
63793 I3=3
63794 IF(I2.EQ.3) I3=2
63795 I4=10-I1-I2-I3
63796 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
63797 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
63798 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
63799
63800C...Closed string.
63801 ELSE
63802 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
63803C...No room for popcorn mesons in closed string -> 2 hadrons.
63804 MSTU(125)=0
63805 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
63806 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
63807 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
63808 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
63809 ENDIF
63810 P(N+2,5)=PYMASS(K(N+2,2))
63811 P(N+3,5)=PYMASS(K(N+3,2))
63812
63813C...If it does not work: try again (a number of times), give up (if no
63814C...place to shuffle momentum or too many flavours), or form one hadron.
63815 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
63816 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
63817 GOTO 790
63818 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
63819 GOTO 1140
63820 ELSE
63821 GOTO 890
63822 END IF
63823 END IF
63824
63825C...Perform two-particle decay of jet system.
63826C...First step: find reference axis in decaying system rest frame.
63827C...(Borrow slot N+2 for temporary direction.)
63828 DO 830 J=1,4
63829 P(N+2,J)=P(IC1,J)
63830 830 CONTINUE
63831 DO 850 I=IC1+1,IC2-1
63832 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
63833 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63834 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
63835 DO 840 J=1,4
63836 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
63837 840 CONTINUE
63838 ENDIF
63839 850 CONTINUE
63840 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
63841 &-DPC(3)/DPC(4))
63842 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
63843 PHI1=PYANGL(P(N+2,1),P(N+2,2))
63844
63845C...Second step: generate isotropic/anisotropic decay.
63846 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
63847 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
63848 860 UE(3)=PYR(0)
63849 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
63850 PT2=(1D0-UE(3)**2)*PA**2
63851 IF(MSTJ(16).LE.0) THEN
63852 PREV=0.5D0
63853 ELSE
63854 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
63855 PR1=P(N+2,5)**2+PT2
63856 PR2=P(N+3,5)**2+PT2
63857 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
63858 PREVCF=PARJ(42)
63859 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63860 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
63861 ENDIF
63862 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
63863 PHI=PARU(2)*PYR(0)
63864 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
63865 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
63866 DO 870 J=1,3
63867 P(N+2,J)=PA*UE(J)
63868 P(N+3,J)=-PA*UE(J)
63869 870 CONTINUE
63870 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
63871 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
63872
63873C...Third step: move back to event frame and set production vertex.
63874 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
63875 &DPC(3)/DPC(4))
63876 DO 880 J=1,4
63877 V(N+1,J)=V(IC1,J)
63878 V(N+2,J)=V(IC1,J)
63879 V(N+3,J)=V(IC2,J)
63880 880 CONTINUE
63881 N=N+3
63882 GOTO 1120
63883
63884C...Else form one particle, if possible.
63885 890 NBODY=1
63886 K(N+1,5)=N+2
63887 DO 900 J=1,4
63888 V(N+1,J)=V(IC1,J)
63889 V(N+2,J)=V(IC1,J)
63890 900 CONTINUE
63891
63892C...Select hadron flavour from available quark flavours.
63893 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
63894 GOTO 1140
63895 ELSEIF(NQ.EQ.2) THEN
63896 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
63897 ELSE
63898 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
63899 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
63900 ENDIF
63901 IF(K(N+2,2).EQ.0) GOTO 910
63902 P(N+2,5)=PYMASS(K(N+2,2))
63903
63904C...Use old algorithm for E/p conservation? (EN)
63905 IF (MSTJ(16).LE.0) GOTO 1080
63906
63907C...Find the string piece closest to the cluster by a loop
63908C...over the undecayed partons not in present cluster. (EN)
63909 DGLOMI=1D30
63910 IBEG=0
63911 I0=0
63912 NJUNC=0
63913 DO 940 I1=MAX(1,IP),N-1
63914 IF(K(I1,1).EQ.1) NJUNC=0
63915 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
63916 IF(K(I1,1).EQ.41) GOTO 940
63917 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
63918 I0=0
63919 ELSEIF(K(I1,1).EQ.2) THEN
63920 IF(I0.EQ.0) I0=I1
63921 I2=I1
63922 920 I2=I2+1
63923 IF(K(I2,1).EQ.41) GOTO 940
63924 IF(K(I2,1).GT.10) GOTO 920
63925 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
63926 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
63927 & NJUNC.EQ.0) GOTO 940
63928 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
63929 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
63930 & K(I2,1).NE.1)) GOTO 940
63931
63932C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63933 DO 930 J=1,3
63934 E1(J)=P(I1,J)/P(I1,4)
63935 E2(J)=P(I2,J)/P(I2,4)
63936 ECL(J)=P(N+1,J)/P(N+1,4)
63937 E3(J)=E2(J)-E1(J)
63938 E4(J)=ECL(J)-E1(J)
63939 930 CONTINUE
63940
63941C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63942 E3S=E3(1)**2+E3(2)**2+E3(3)**2
63943 E4S=E4(1)**2+E4(2)**2+E4(3)**2
63944 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
63945 IF(E34.LE.0D0) THEN
63946 DDMIN=E4S
63947 ELSEIF(E34.LT.E3S) THEN
63948 DDMIN=E4S-E34**2/E3S
63949 ELSE
63950 DDMIN=E4S-2D0*E34+E3S
63951 ENDIF
63952
63953C...Is this the smallest so far?
63954 IF(DDMIN.LT.DGLOMI) THEN
63955 DGLOMI=DDMIN
63956 IBEG=I0
63957 IPCS=I1
63958 ENDIF
63959 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
63960 I0=0
63961 ENDIF
63962 940 CONTINUE
63963
63964C... Check if there are any strings to connect to the new gluon. (EN)
63965 IF (IBEG.EQ.0) GOTO 1080
63966
63967C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63968 IF (P(N+1,5).GE.P(N+2,5)) THEN
63969
63970C...Construct 'gluon' that is needed to put hadron on the mass shell.
63971 FRAC=P(N+2,5)/P(N+1,5)
63972 DO 950 J=1,5
63973 P(N+2,J)=FRAC*P(N+1,J)
63974 PG(J)=(1D0-FRAC)*P(N+1,J)
63975 950 CONTINUE
63976
63977C... Copy string with new gluon put in.
63978 N=N+2
63979 I=IBEG-1
63980 960 I=I+1
63981 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
63982 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
63983 N=N+1
63984 DO 970 J=1,5
63985 K(N,J)=K(I,J)
63986 P(N,J)=P(I,J)
63987 V(N,J)=V(I,J)
63988 970 CONTINUE
63989 K(I,1)=K(I,1)+10
63990 K(I,4)=N
63991 K(I,5)=N
63992 K(N,3)=I
63993 IF(I.EQ.IPCS) THEN
63994 N=N+1
63995 DO 980 J=1,5
63996 K(N,J)=K(N-1,J)
63997 P(N,J)=PG(J)
63998 V(N,J)=V(N-1,J)
63999 980 CONTINUE
64000 K(N,2)=21
64001 K(N,3)=NSAV+1
64002 ENDIF
64003 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
64004 GOTO 1120
64005
64006C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
64007C...from string piece endpoints.
64008 ELSE
64009
64010C...Begin by copying string that should give energy to cluster.
64011 N=N+2
64012 I=IBEG-1
64013 990 I=I+1
64014 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
64015 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
64016 N=N+1
64017 DO 1000 J=1,5
64018 K(N,J)=K(I,J)
64019 P(N,J)=P(I,J)
64020 V(N,J)=V(I,J)
64021 1000 CONTINUE
64022 K(I,1)=K(I,1)+10
64023 K(I,4)=N
64024 K(I,5)=N
64025 K(N,3)=I
64026 IF(I.EQ.IPCS) I1=N
64027 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
64028 I2=I1+1
64029
64030C...Set initial Phad.
64031 DO 1010 J=1,4
64032 P(NSAV+2,J)=P(NSAV+1,J)
64033 1010 CONTINUE
64034
64035C...Calculate Pg, a part of which will be added to Phad later. (EN)
64036 1020 IF(MSTJ(16).EQ.1) THEN
64037 ALPHA=1D0
64038 BETA=1D0
64039 ELSE
64040 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
64041 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
64042 ENDIF
64043 DO 1030 J=1,4
64044 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
64045 1030 CONTINUE
64046 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
64047
64048C..Solve 2nd order equation, use the best (smallest) solution. (EN)
64049 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
64050 & P(NSAV+2,3)**2
64051 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
64052 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
64053 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
64054
64055C...If all gluon energy eaten, zero it and take a step back.
64056 ITER=0
64057 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
64058 ITER=1
64059 DO 1040 J=1,4
64060 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
64061 P(I1,J)=0D0
64062 1040 CONTINUE
64063 P(I1,5)=0D0
64064 K(I1,1)=K(I1,1)+10
64065 I1=I1-1
64066 IF(K(I1,1).EQ.41) ITER=-1
64067 ENDIF
64068 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
64069 ITER=1
64070 DO 1050 J=1,4
64071 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
64072 P(I2,J)=0D0
64073 1050 CONTINUE
64074 P(I2,5)=0D0
64075 K(I2,1)=K(I2,1)+10
64076 I2=I2+1
64077 IF(K(I2,1).EQ.41) ITER=-1
64078 ENDIF
64079 IF(ITER.EQ.1) GOTO 1020
64080
64081C...If also all endpoint energy eaten, revert to old procedure.
64082 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
64083 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
64084 DO 1060 I=NSAV+3,N
64085 IM=K(I,3)
64086 K(IM,1)=K(IM,1)-10
64087 K(IM,4)=0
64088 K(IM,5)=0
64089 1060 CONTINUE
64090 N=NSAV
64091 GOTO 1080
64092 ENDIF
64093
64094C... Construct the collapsed hadron and modified string partons.
64095 DO 1070 J=1,4
64096 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
64097 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
64098 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
64099 1070 CONTINUE
64100 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
64101 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
64102
64103C...Finished with string collapse in new scheme.
64104 GOTO 1120
64105 ENDIF
64106
64107C... Use old algorithm; by choice or when in trouble.
64108 1080 CONTINUE
64109C...Find parton/particle which combines to largest extra mass.
64110 IR=0
64111 HA=0D0
64112 HSM=0D0
64113 DO 1100 MCOMB=1,3
64114 IF(IR.NE.0) GOTO 1100
64115 DO 1090 I=MAX(1,IP),N
64116 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
64117 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
64118 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
64119 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
64120 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
64121 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
64122 & GOTO 1090
64123 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
64124 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
64125 IF(HSR.GT.HSM) THEN
64126 IR=I
64127 HA=HCR
64128 HSM=HSR
64129 ENDIF
64130 1090 CONTINUE
64131 1100 CONTINUE
64132
64133C...Shuffle energy and momentum to put new particle on mass shell.
64134 IF(IR.NE.0) THEN
64135 HB=PECM**2+HA
64136 HC=P(N+2,5)**2+HA
64137 HD=P(IR,5)**2+HA
64138 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
64139 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
64140 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
64141 DO 1110 J=1,4
64142 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
64143 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
64144 1110 CONTINUE
64145 N=N+2
64146 ELSE
64147 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
64148 RETURN
64149 ENDIF
64150
64151C...Mark collapsed system and store daughter pointers. Iterate.
64152 1120 DO 1130 I=IC1,IC2
64153 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
64154 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
64155 K(I,1)=K(I,1)+10
64156 IF(MSTU(16).NE.2) THEN
64157 K(I,4)=NSAV+1
64158 K(I,5)=NSAV+1
64159 ELSE
64160 K(I,4)=NSAV+2
64161 K(I,5)=NSAV+1+NBODY
64162 ENDIF
64163 ENDIF
64164 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
64165 1130 CONTINUE
64166 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
64167
64168C...Check flavours and invariant masses in parton systems.
64169 1140 NP=0
64170 KFN=0
64171 KQS=0
64172 NJU=0
64173 DO 1150 J=1,5
64174 DPS(J)=0D0
64175 1150 CONTINUE
64176 DO 1180 I=MAX(1,IP),N
64177 IF(K(I,1).EQ.41) NJU=NJU+1
64178 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
64179 KC=PYCOMP(K(I,2))
64180 IF(KC.EQ.0) GOTO 1180
64181 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64182 IF(KQ.EQ.0) GOTO 1180
64183 NP=NP+1
64184 IF(KQ.NE.2) THEN
64185 KFN=KFN+1
64186 KQS=KQS+KQ
64187 MSTJ(93)=1
64188 DPS(5)=DPS(5)+PYMASS(K(I,2))
64189 ENDIF
64190 DO 1160 J=1,4
64191 DPS(J)=DPS(J)+P(I,J)
64192 1160 CONTINUE
64193 IF(K(I,1).EQ.1) THEN
64194 NFERR=0
64195 IF(NJU.EQ.0.AND.NP.NE.1) THEN
64196 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
64197 ELSEIF(NJU.EQ.1) THEN
64198 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
64199 ELSEIF(NJU.EQ.2) THEN
64200 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
64201 ELSEIF(NJU.GE.3) THEN
64202 NFERR=1
64203 ENDIF
64204 IF(NFERR.EQ.1) THEN
64205 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
64206 MINT(51)=1
64207 RETURN
64208 ENDIF
64209 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
64210 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
64211 & '(PYPREP:) too small mass in jet system')
64212 NP=0
64213 KFN=0
64214 KQS=0
64215 NJU=0
64216 DO 1170 J=1,5
64217 DPS(J)=0D0
64218 1170 CONTINUE
64219 ENDIF
64220 1180 CONTINUE
64221
64222 RETURN
64223 END
64224
64225C*********************************************************************
64226
64227C...PYSTRF
64228C...Handles the fragmentation of an arbitrary colour singlet
64229C...jet system according to the Lund string fragmentation model.
64230
64231 SUBROUTINE PYSTRF(IP)
64232
64233C...Double precision and integer declarations.
64234 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64235 IMPLICIT INTEGER(I-N)
64236 INTEGER PYK,PYCHGE,PYCOMP
64237C...Commonblocks.
64238 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64239 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64240 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64241 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
64242C...Local arrays. All MOPS variables ends with MO
64243 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
64244 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
64245 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
64246 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
64247 &PBST(3,5),TJUOLD(5)
64248
64249C...Function: four-product of two vectors.
64250 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)
64251 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
64252 &DP(I,3)*DP(J,3)
64253
64254C...Reset counters.
64255 MSTJ(91)=0
64256 NSAV=N
64257 MSTU90=MSTU(90)
64258 NP=0
64259 KQSUM=0
64260 DO 100 J=1,5
64261 DPS(J)=0D0
64262 100 CONTINUE
64263 MJU(1)=0
64264 MJU(2)=0
64265 NTRYFN=0
64266 IJUORI(1)=0
64267 IJUORI(2)=0
64268
64269C...Identify parton system.
64270 I=IP-1
64271 110 I=I+1
64272 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
64273 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
64274 IF(MSTU(21).GE.1) RETURN
64275 ENDIF
64276 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
64277 KC=PYCOMP(K(I,2))
64278 IF(KC.EQ.0) GOTO 110
64279 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64280 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
64281 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
64282 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64283 IF(MSTU(21).GE.1) RETURN
64284 ENDIF
64285
64286C...Take copy of partons to be considered. Check flavour sum.
64287 NP=NP+1
64288 DO 120 J=1,5
64289 K(N+NP,J)=K(I,J)
64290 P(N+NP,J)=P(I,J)
64291 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
64292 120 CONTINUE
64293 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
64294 K(N+NP,3)=I
64295 IF(KQ.NE.2) KQSUM=KQSUM+KQ
64296 IF(K(I,1).EQ.41) THEN
64297 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
64298 MJU(1)=N+NP
64299 IJUORI(1)=I
64300 ELSE
64301 MJU(2)=N+NP
64302 IJUORI(2)=I
64303 ENDIF
64304 ENDIF
64305 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
64306 IF(MOD(KQSUM,3).NE.0) THEN
64307 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
64308 IF(MSTU(21).GE.1) RETURN
64309 ENDIF
64310 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
64311
64312C...Boost copied system to CM frame (for better numerical precision).
64313 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
64314 MBST=0
64315 MSTU(33)=1
64316 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
64317 & -DPS(3)/DPS(4))
64318 ELSE
64319 MBST=1
64320 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
64321 DO 130 I=N+1,N+NP
64322 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
64323 IF(P(I,3).GT.0D0) THEN
64324 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
64325 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
64326 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64327 ELSE
64328 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
64329 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
64330 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64331 ENDIF
64332 130 CONTINUE
64333 ENDIF
64334
64335C...Search for very nearby partons that may be recombined.
64336 NTRYR=0
64337 NTRYWR=0
64338 PARU12=PARU(12)
64339 PARU13=PARU(13)
64340 MJU(3)=MJU(1)
64341 MJU(4)=MJU(2)
64342 NR=NP
64343 NRMIN=2
64344 IF(MJU(1).GT.0) NRMIN=NRMIN+2
64345 IF(MJU(2).GT.0) NRMIN=NRMIN+2
64346 140 IF(NR.GT.NRMIN) THEN
64347 PDRMIN=2D0*PARU12
64348 DO 150 I=N+1,N+NR
64349 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
64350 I1=I+1
64351 IF(I.EQ.N+NR) I1=N+1
64352 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
64353 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
64354 & GOTO 150
64355 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
64356 & GOTO 150
64357 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
64358 & P(I1,2)**2+P(I1,3)**2))
64359 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
64360 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
64361 IF(PDR.LT.PDRMIN) THEN
64362 IR=I
64363 PDRMIN=PDR
64364 ENDIF
64365 150 CONTINUE
64366
64367C...Recombine very nearby partons to avoid machine precision problems.
64368 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
64369 DO 160 J=1,4
64370 P(N+1,J)=P(N+1,J)+P(N+NR,J)
64371 160 CONTINUE
64372 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
64373 & P(N+1,3)**2))
64374 NR=NR-1
64375 GOTO 140
64376 ELSEIF(PDRMIN.LT.PARU12) THEN
64377 DO 170 J=1,4
64378 P(IR,J)=P(IR,J)+P(IR+1,J)
64379 170 CONTINUE
64380 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
64381 & P(IR,3)**2))
64382 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
64383 DO 190 I=IR+1,N+NR-1
64384 K(I,1)=K(I+1,1)
64385 K(I,2)=K(I+1,2)
64386 DO 180 J=1,5
64387 P(I,J)=P(I+1,J)
64388 180 CONTINUE
64389 190 CONTINUE
64390 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
64391 NR=NR-1
64392 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
64393 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
64394 GOTO 140
64395 ENDIF
64396 ENDIF
64397 NTRYR=NTRYR+1
64398
64399C...Reset particle counter. Skip ahead if no junctions are present;
64400C...this is usually the case!
64401 NRS=MAX(5*NR+11,NP)
64402 NTRY=0
64403 200 NTRY=NTRY+1
64404 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64405 PARU12=4D0*PARU12
64406 PARU13=2D0*PARU13
64407 GOTO 140
64408 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
64409 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64410 IF(MSTU(21).GE.1) RETURN
64411 ENDIF
64412 I=N+NRS
64413 MSTU(90)=MSTU90
64414 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
64415 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
64416 & ' junction strings not handled by MSTJ(12)>3 options')
64417 DO 640 JT=1,2
64418 NJS(JT)=0
64419 IF(MJU(JT).EQ.0) GOTO 640
64420 JS=3-2*JT
64421
64422C++SKANDS
64423C...Find and sum up momentum on three sides of junction.
64424C...Begin with previous boost = zero.
64425 IJRFIT=0
64426 DO 210 IX=1,3
64427 TJUOLD(IX)=0D0
64428 210 CONTINUE
64429C...Prevent IJU (specifically IJU(5)) from containing junk below
64430 DO 215 IU=1,6
64431 IJU(IU)=0
64432 215 CONTINUE
64433 TJUOLD(4)=1D0
64434 220 IU=0
64435C...Beginning and end of string system in event record.
64436 I1BEG=N+1+(JT-1)*(NR-1)
64437 I1END=N+NR+(JT-1)*(1-NR)
64438C...Look for junction string piece end points
64439 DO 230 I1=I1BEG,I1END,JS
64440 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
64441C...Store junction string piece end points.
64442C 1-junction systems 2-junction systems
64443C IU : 1 2 3 4 1 2 3 4 5 6
64444C 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
64445 IU=IU+1
64446 IJU(IU)=I1
64447 ENDIF
64448C...Sum over momenta, from junction outwards.
64449 230 CONTINUE
64450 DO 280 IU=1,3
64451 PWT=0D0
64452C...Initialize junction drag and string piece 4-vectors.
64453 DO 240 J=1,5
64454 PBST(IU,J)=0D0
64455 PJU(IU,J)=0D0
64456 240 CONTINUE
64457C...First two branches. Inwards out means opposite direction to JS.
64458C...(JS is 1 for JT=1, -1 for JT=2)
64459 IF (IU.LT.3) THEN
64460 I1A=IJU(IU+1)-JS
64461 I1B=IJU(IU)
64462 IDIR=-JS
64463C...Last branch (gq or gjgqgq). Direction now reversed.
64464 ELSE
64465 I1A=IJU(IU)+JS
64466 I1B=I1END
64467 IDIR=JS
64468 ENDIF
64469 DO 270 I1=I1A,I1B,IDIR
64470C...Sum up momentum directions with exponential suppression
64471C...for use in finding junction rest frame below.
64472 IF (K(I1,2).EQ.88) THEN
64473C...gjgqgq type system encountered. Use current PWT as start
64474C...for both strings.
64475 PWTOLD=PWT
64476 ELSE
64477 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
64478C...Sum up string piece (boosted) 4-momenta.
64479 DO 250 J=1,4
64480 PJU(IU,J)=PJU(IU,J)+P(I1,J)
64481 250 CONTINUE
64482C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64483C...boost is zero, see above). Skip parton if suppression factor large.
64484 IF (PWT.GT.10D0) GOTO 270
64485C...Compute momentum in current frame:
64486 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
64487 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
64488 DO 260 J=1,3
64489 PTMP=P(I1,J)+TJUOLD(J)*BFC
64490 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
64491 260 CONTINUE
64492C...Boosted energy
64493 PTMP=TJUOLD(4)*P(I1,4)+TDP
64494 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
64495 PWT=PWT+PTMP/PARJ(48)
64496 ENDIF
64497 270 CONTINUE
64498C...Put |p| rather than m in 5th slot.
64499 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
64500 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
64501 280 CONTINUE
64502
64503C...Calculate boost from present frame to next JRF candidate.
64504 IJRFIT=IJRFIT+1
64505 CALL PYJURF(PBST,TJU)
64506
64507C...After some iterations do not take full step in new direction.
64508 IF(IJRFIT.GT.5) THEN
64509 REDUCE=0.8D0**(IJRFIT-5)
64510 TJU(1)=REDUCE*TJU(1)
64511 TJU(2)=REDUCE*TJU(2)
64512 TJU(3)=REDUCE*TJU(3)
64513 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64514 ENDIF
64515
64516C...Combine new boost (TJU) with old boost (TJUOLD)
64517 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
64518 DO 290 IX=1,3
64519 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
64520 290 CONTINUE
64521 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
64522
64523C...If last boost small, accept JRF, else iterate.
64524C...Also prevent possibility of infinite loop.
64525 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
64526 & IJRFIT.LT.MSTJ(18)) THEN
64527 GOTO 220
64528 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
64529 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
64530 ENDIF
64531
64532C...Now store total boost in TJU and change perception.
64533C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64534C...TJU = junction motion vector in string CM, so the sign changes.
64535 DO 300 J=1,3
64536 TJU(J)=-TJUOLD(J)
64537 300 CONTINUE
64538 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64539
64540C--SKANDS
64541
64542C...Calculate string piece energies in junction rest frame.
64543 DO 310 IU=1,3
64544 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
64545 & TJU(3)*PJU(IU,3)
64546 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
64547 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
64548 310 CONTINUE
64549
64550C...Start preparing for fragmentation of two strings from junction.
64551 ISTA=I
64552 NTRYER=0
64553 320 NTRYER=NTRYER+1
64554 I=ISTA
64555 DO 620 IU=1,2
64556 NS=IABS(IJU(IU+1)-IJU(IU))
64557
64558C...Junction strings: find longitudinal string directions.
64559 DO 350 IS=1,NS
64560 IS1=IJU(IU)+JS*(IS-1)
64561 IS2=IJU(IU)+JS*IS
64562 DO 330 J=1,5
64563 DP(1,J)=0.5D0*P(IS1,J)
64564 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
64565 DP(2,J)=0.5D0*P(IS2,J)
64566 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
64567 & (PJU(IU,5)/PBST(IU,5))
64568 330 CONTINUE
64569 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
64570 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
64571 DP(3,5)=DFOUR(1,1)
64572 DP(4,5)=DFOUR(2,2)
64573 DHKC=DFOUR(1,2)
64574 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
64575 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64576 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64577 DP(3,5)=0D0
64578 DP(4,5)=0D0
64579 DHKC=DFOUR(1,2)
64580 ENDIF
64581 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64582 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64583 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64584 IN1=N+NR+4*IS-3
64585 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64586 DO 340 J=1,4
64587 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64588 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64589 340 CONTINUE
64590 350 CONTINUE
64591
64592C...Junction strings: initialize flavour, momentum and starting pos.
64593 ISAV=I
64594 MSTU91=MSTU(90)
64595 360 NTRY=NTRY+1
64596 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64597 PARU12=4D0*PARU12
64598 PARU13=2D0*PARU13
64599 GOTO 140
64600 ELSEIF(NTRY.GT.100) THEN
64601 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64602 IF(MSTU(21).GE.1) RETURN
64603 ENDIF
64604 I=ISAV
64605 MSTU(90)=MSTU91
64606 IRANKJ=0
64607 IE(1)=K(N+1+(JT/2)*(NP-1),3)
64608 IF (MOD(JT+IU,2).NE.0) THEN
64609 IE(1)=K(IJU(IU),3)
64610 IF (NP-NR.NE.0) THEN
64611C...If gluons have disappeared. Original IJU must be used.
64612 IT=IP
64613 NE=1
64614 370 IT=IT+1
64615 IF (K(IT,2).NE.21) THEN
64616 NE=NE+1
64617 ENDIF
64618 IF (NE.EQ.IU+4*(JT-1)) THEN
64619 IE(1)=IT
64620 ELSEIF (IT.LE.IP+NP) THEN
64621 GOTO 370
64622 ELSE
64623 CALL PYERRM(14,'(PYSTRF:) '//
64624 & 'Original IJU could not be reconstructed!')
64625 ENDIF
64626 ENDIF
64627 ENDIF
64628 IN(4)=N+NR+1
64629 IN(5)=IN(4)+1
64630 IN(6)=N+NR+4*NS+1
64631 DO 390 JQ=1,2
64632 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
64633 P(IN1,1)=2-JQ
64634 P(IN1,2)=JQ-1
64635 P(IN1,3)=1D0
64636 380 CONTINUE
64637 390 CONTINUE
64638 KFL(1)=K(IJU(IU),2)
64639 PX(1)=0D0
64640 PY(1)=0D0
64641 GAM(1)=0D0
64642 DO 400 J=1,5
64643 PJU(IU+3,J)=0D0
64644 400 CONTINUE
64645
64646C...Junction strings: find initial transverse directions.
64647 DO 410 J=1,4
64648 DP(1,J)=P(IN(4),J)
64649 DP(2,J)=P(IN(4)+1,J)
64650 DP(3,J)=0D0
64651 DP(4,J)=0D0
64652 410 CONTINUE
64653 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64654 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64655 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64656 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64657 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64658 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64659 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64660 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64661 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64662 DHC12=DFOUR(1,2)
64663 DHCX1=DFOUR(3,1)/DHC12
64664 DHCX2=DFOUR(3,2)/DHC12
64665 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64666 DHCY1=DFOUR(4,1)/DHC12
64667 DHCY2=DFOUR(4,2)/DHC12
64668 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64669 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64670 DO 420 J=1,4
64671 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64672 P(IN(6),J)=DP(3,J)
64673 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64674 & DHCYX*DP(3,J))
64675 420 CONTINUE
64676
64677C...Junction strings: produce new particle, origin.
64678 430 I=I+1
64679 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
64680 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64681 IF(MSTU(21).GE.1) RETURN
64682 ENDIF
64683 IRANKJ=IRANKJ+1
64684 K(I,1)=1
64685 K(I,3)=IE(1)
64686 K(I,4)=0
64687 K(I,5)=0
64688
64689C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64690 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
64691 IF(K(I,2).EQ.0) GOTO 360
64692 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
64693 & IABS(KFL(3)).GT.10) THEN
64694 IF(PYR(0).GT.PARJ(19)) GOTO 440
64695 ENDIF
64696 P(I,5)=PYMASS(K(I,2))
64697 CALL PYPTDI(KFL(1),PX(3),PY(3))
64698 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
64699 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
64700 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
64701 & MSTU(90).LT.8) THEN
64702 MSTU(90)=MSTU(90)+1
64703 MSTU(90+MSTU(90))=I
64704 PARU(90+MSTU(90))=Z
64705 ENDIF
64706 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
64707 DO 450 J=1,3
64708 IN(J)=IN(3+J)
64709 450 CONTINUE
64710
64711C...Junction strings: stepping within 'low' string region.
64712 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
64713 & P(IN(1),5)**2.GE.PR(1)) THEN
64714 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
64715 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
64716 DO 460 J=1,4
64717 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
64718 460 CONTINUE
64719 GOTO 560
64720C...Has used up energy of junction string, i.e. no more hadrons in it.
64721 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
64722 DO 470 J=1,5
64723 P(I,J)=0D0
64724 470 CONTINUE
64725 GOTO 600
64726C...Stepping from 'low' string region
64727 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
64728 P(IN(2)+2,4)=P(IN(2)+2,3)
64729 P(IN(2)+2,1)=1D0
64730 IN(2)=IN(2)+4
64731 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64732 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64733 P(IN(1)+2,4)=P(IN(1)+2,3)
64734 P(IN(1)+2,1)=0D0
64735 IN(1)=IN(1)+4
64736 ENDIF
64737 ENDIF
64738
64739C...Junction strings: find new transverse directions.
64740 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
64741 & IN(1).GT.IN(2)) GOTO 360
64742 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
64743 DO 490 J=1,4
64744 DP(1,J)=P(IN(1),J)
64745 DP(2,J)=P(IN(2),J)
64746 DP(3,J)=0D0
64747 DP(4,J)=0D0
64748 490 CONTINUE
64749 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64750 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64751 DHC12=DFOUR(1,2)
64752 IF(DHC12.LE.1D-2) THEN
64753 P(IN(1)+2,4)=P(IN(1)+2,3)
64754 P(IN(1)+2,1)=0D0
64755 IN(1)=IN(1)+4
64756 GOTO 480
64757 ENDIF
64758 IN(3)=N+NR+4*NS+5
64759 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64760 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64761 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64762 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64763 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64764 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64765 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64766 DHCX1=DFOUR(3,1)/DHC12
64767 DHCX2=DFOUR(3,2)/DHC12
64768 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64769 DHCY1=DFOUR(4,1)/DHC12
64770 DHCY2=DFOUR(4,2)/DHC12
64771 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64772 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64773 DO 500 J=1,4
64774 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64775 P(IN(3),J)=DP(3,J)
64776 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64777 & DHCYX*DP(3,J))
64778 500 CONTINUE
64779C...Express pT with respect to new axes, if sensible.
64780 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
64781 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
64782 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
64783 PX(3)=PXP
64784 PY(3)=PYP
64785 ENDIF
64786 ENDIF
64787
64788C...Junction strings: sum up known four-momentum, coefficients for m2.
64789 DO 530 J=1,4
64790 DHG(J)=0D0
64791 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
64792 & PY(3)*P(IN(3)+1,J)
64793 DO 510 IN1=IN(4),IN(1)-4,4
64794 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
64795 510 CONTINUE
64796 DO 520 IN2=IN(5),IN(2)-4,4
64797 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
64798 520 CONTINUE
64799 530 CONTINUE
64800 DHM(1)=FOUR(I,I)
64801 DHM(2)=2D0*FOUR(I,IN(1))
64802 DHM(3)=2D0*FOUR(I,IN(2))
64803 DHM(4)=2D0*FOUR(IN(1),IN(2))
64804
64805C...Junction strings: find coefficients for Gamma expression.
64806 DO 550 IN2=IN(1)+1,IN(2),4
64807 DO 540 IN1=IN(1),IN2-1,4
64808 DHC=2D0*FOUR(IN1,IN2)
64809 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
64810 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
64811 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
64812 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
64813 540 CONTINUE
64814 550 CONTINUE
64815
64816C...Junction strings: solve (m2, Gamma) equation system for energies.
64817 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
64818 IF(ABS(DHS1).LT.1D-4) GOTO 360
64819 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
64820 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
64821 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
64822 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
64823 & ABS(DHS1)-DHS2/DHS1)
64824 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
64825 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
64826 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
64827
64828C...Junction strings: step to new region if necessary.
64829 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
64830 P(IN(2)+2,4)=P(IN(2)+2,3)
64831 P(IN(2)+2,1)=1D0
64832 IN(2)=IN(2)+4
64833 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64834 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64835 P(IN(1)+2,4)=P(IN(1)+2,3)
64836 P(IN(1)+2,1)=0D0
64837 IN(1)=IN(1)+4
64838 ENDIF
64839 GOTO 480
64840 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
64841 P(IN(1)+2,4)=P(IN(1)+2,3)
64842 P(IN(1)+2,1)=0D0
64843 IN(1)=IN(1)+4
64844 GOTO 480
64845 ENDIF
64846
64847C...Junction strings: particle four-momentum, remainder, loop back.
64848 560 DO 570 J=1,4
64849 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
64850 & P(IN(2)+2,4)*P(IN(2),J)
64851 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
64852 570 CONTINUE
64853 IF(P(I,4).LT.P(I,5)) GOTO 360
64854 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64855 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64856 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
64857 KFL(1)=-KFL(3)
64858 PX(1)=-PX(3)
64859 PY(1)=-PY(3)
64860 GAM(1)=GAM(3)
64861 IF(IN(3).NE.IN(6)) THEN
64862 DO 580 J=1,4
64863 P(IN(6),J)=P(IN(3),J)
64864 P(IN(6)+1,J)=P(IN(3)+1,J)
64865 580 CONTINUE
64866 ENDIF
64867 DO 590 JQ=1,2
64868 IN(3+JQ)=IN(JQ)
64869 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
64870 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
64871 590 CONTINUE
64872 GOTO 430
64873 ENDIF
64874
64875C...Junction strings: save quantities left after each string.
64876 IF(IABS(KFL(1)).GT.10) GOTO 360
64877 600 I=I-1
64878 KFJH(IU)=KFL(1)
64879 DO 610 J=1,4
64880 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
64881 610 CONTINUE
64882
64883C...Junction strings: loopback if much unused energy in both strings.
64884 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64885 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64886 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
64887 620 CONTINUE
64888 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
64889 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
64890 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
64891 & .AND.NTRYER.LT.10) GOTO 320
64892
64893C...Junction strings: put together to new effective string endpoint.
64894 NJS(JT)=I-ISTA
64895 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
64896 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
64897 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
64898 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
64899 DO 630 J=1,4
64900 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
64901 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
64902 630 CONTINUE
64903 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
64904 & PJS(JT,3)**2))
64905 PJS(JT+2,5)=0D0
64906 640 CONTINUE
64907
64908C...Open versus closed strings. Choose breakup region for latter.
64909 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
64910 NS=MJU(2)-MJU(1)
64911 NB=MJU(1)-N
64912 ELSEIF(MJU(1).NE.0) THEN
64913 NS=N+NR-MJU(1)
64914 NB=MJU(1)-N
64915 ELSEIF(MJU(2).NE.0) THEN
64916 NS=MJU(2)-N
64917 NB=1
64918 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
64919 NS=NR-1
64920 NB=1
64921 ELSE
64922 NS=NR+1
64923 W2SUM=0D0
64924 DO 660 IS=1,NR
64925 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
64926 W2SUM=W2SUM+P(N+NR+IS,1)
64927 660 CONTINUE
64928 W2RAN=PYR(0)*W2SUM
64929 NB=0
64930 670 NB=NB+1
64931 W2SUM=W2SUM-P(N+NR+NB,1)
64932 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
64933 ENDIF
64934
64935C...Find longitudinal string directions (i.e. lightlike four-vectors).
64936 DO 700 IS=1,NS
64937 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
64938 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
64939 DO 680 J=1,5
64940 DP(1,J)=P(IS1,J)
64941 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
64942 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
64943 DP(2,J)=P(IS2,J)
64944 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
64945 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
64946 680 CONTINUE
64947 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
64948 & DP(1,2)**2-DP(1,3)**2))
64949 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
64950 & DP(2,2)**2-DP(2,3)**2))
64951 DP(3,5)=DFOUR(1,1)
64952 DP(4,5)=DFOUR(2,2)
64953 DHKC=DFOUR(1,2)
64954 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
64955 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64956 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64957 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64958 IN1=N+NR+4*IS-3
64959 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64960 DO 690 J=1,4
64961 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64962 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64963 690 CONTINUE
64964 700 CONTINUE
64965
64966C...Begin initialization: sum up energy, set starting position.
64967 ISAV=I
64968 MSTU91=MSTU(90)
64969 710 NTRY=NTRY+1
64970 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64971 PARU12=4D0*PARU12
64972 PARU13=2D0*PARU13
64973 GOTO 140
64974 ELSEIF(NTRY.GT.100) THEN
64975 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64976 IF(MSTU(21).GE.1) RETURN
64977 ENDIF
64978 I=ISAV
64979 MSTU(90)=MSTU91
64980 DO 730 J=1,4
64981 P(N+NRS,J)=0D0
64982 DO 720 IS=1,NR
64983 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
64984 720 CONTINUE
64985 730 CONTINUE
64986 DO 750 JT=1,2
64987 IRANK(JT)=0
64988 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
64989 IF(NS.GT.NR) IRANK(JT)=1
64990 IBARRK(JT)=0
64991 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
64992 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
64993 IN(3*JT+2)=IN(3*JT+1)+1
64994 IN(3*JT+3)=N+NR+4*NS+2*JT-1
64995 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
64996 P(IN1,1)=2-JT
64997 P(IN1,2)=JT-1
64998 P(IN1,3)=1D0
64999 740 CONTINUE
65000 750 CONTINUE
65001
65002C.. MOPS variables and switches
65003 NRVMO=0
65004 XBMO=1D0
65005 MSTU(121)=0
65006 MSTU(122)=0
65007
65008C...Initialize flavour and pT variables for open string.
65009 IF(NS.LT.NR) THEN
65010 PX(1)=0D0
65011 PY(1)=0D0
65012 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
65013 PX(2)=-PX(1)
65014 PY(2)=-PY(1)
65015 DO 760 JT=1,2
65016 KFL(JT)=K(IE(JT),2)
65017 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
65018 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
65019 MSTJ(93)=1
65020 PMQ(JT)=PYMASS(KFL(JT))
65021 GAM(JT)=0D0
65022 760 CONTINUE
65023
65024C...Closed string: random initial breakup flavour, pT and vertex.
65025 ELSE
65026 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65027 IBMO=0
65028 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
65029C.. Closed string: first vertex diq attempt => enforced second
65030C.. vertex diq
65031 IF(IABS(KFL(1)).GT.10)THEN
65032 IBMO=1
65033 MSTU(121)=0
65034 GOTO 770
65035 ENDIF
65036 IF(IBMO.EQ.1) MSTU(121)=-1
65037 KFL(2)=-KFL(1)
65038 CALL PYPTDI(KFL(1),PX(1),PY(1))
65039 PX(2)=-PX(1)
65040 PY(2)=-PY(1)
65041 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
65042 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
65043 ZR=PR3/(Z*P(N+NR+1,5)**2)
65044 IF(ZR.GE.1D0) GOTO 780
65045 DO 790 JT=1,2
65046 MSTJ(93)=1
65047 PMQ(JT)=PYMASS(KFL(JT))
65048 GAM(JT)=PR3*(1D0-Z)/Z
65049 IN1=N+NR+3+4*(JT/2)*(NS-1)
65050 P(IN1,JT)=1D0-Z
65051 P(IN1,3-JT)=JT-1
65052 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
65053 P(IN1+1,JT)=ZR
65054 P(IN1+1,3-JT)=2-JT
65055 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
65056 790 CONTINUE
65057 ENDIF
65058C.. MOPS variables
65059 DO 800 JT=1,2
65060 XTMO(JT)=1D0
65061 PM2QMO(JT)=PMQ(JT)**2
65062 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
65063 800 CONTINUE
65064
65065C...Find initial transverse directions (i.e. spacelike four-vectors).
65066 DO 840 JT=1,2
65067 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
65068 IN1=IN(3*JT+1)
65069 IN3=IN(3*JT+3)
65070 DO 810 J=1,4
65071 DP(1,J)=P(IN1,J)
65072 DP(2,J)=P(IN1+1,J)
65073 DP(3,J)=0D0
65074 DP(4,J)=0D0
65075 810 CONTINUE
65076 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65077 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65078 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65079 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65080 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65081 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65082 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65083 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65084 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65085 DHC12=DFOUR(1,2)
65086 DHCX1=DFOUR(3,1)/DHC12
65087 DHCX2=DFOUR(3,2)/DHC12
65088 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65089 DHCY1=DFOUR(4,1)/DHC12
65090 DHCY2=DFOUR(4,2)/DHC12
65091 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65092 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65093 DO 820 J=1,4
65094 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65095 P(IN3,J)=DP(3,J)
65096 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65097 & DHCYX*DP(3,J))
65098 820 CONTINUE
65099 ELSE
65100 DO 830 J=1,4
65101 P(IN3+2,J)=P(IN3,J)
65102 P(IN3+3,J)=P(IN3+1,J)
65103 830 CONTINUE
65104 ENDIF
65105 840 CONTINUE
65106
65107C...Remove energy used up in junction string fragmentation.
65108 IF(MJU(1)+MJU(2).GT.0) THEN
65109 DO 860 JT=1,2
65110 IF(NJS(JT).EQ.0) GOTO 860
65111 DO 850 J=1,4
65112 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
65113 850 CONTINUE
65114 860 CONTINUE
65115 PARJST=PARJ(33)
65116 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65117 WMIN=PARJST+PMQ(1)+PMQ(2)
65118 WREM2=FOUR(N+NRS,N+NRS)
65119 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
65120 NTRYWR=NTRYWR+1
65121 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
65122 GOTO 140
65123 ENDIF
65124 ENDIF
65125
65126C...Produce new particle: side, origin.
65127 870 I=I+1
65128 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
65129 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65130 IF(MSTU(21).GE.1) RETURN
65131 ENDIF
65132C.. New side priority for popcorn systems
65133 IF(MSTU(121).LE.0)THEN
65134 JT=1.5D0+PYR(0)
65135 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
65136 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
65137 ENDIF
65138 JR=3-JT
65139 JS=3-2*JT
65140 IRANK(JT)=IRANK(JT)+1
65141 K(I,1)=1
65142 K(I,4)=0
65143 K(I,5)=0
65144
65145C...Generate flavour, hadron and pT.
65146 880 K(I,3)=IE(JT)
65147 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
65148 IF(K(I,2).EQ.0) GOTO 710
65149 MU90MO=MSTU(90)
65150 IF(MSTU(121).EQ.-1) GOTO 910
65151 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
65152 &IABS(KFL(3)).GT.10) THEN
65153 IF(PYR(0).GT.PARJ(19)) GOTO 880
65154 ENDIF
65155 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65156 &K(I,3)=IJUORI(JT)
65157 P(I,5)=PYMASS(K(I,2))
65158 CALL PYPTDI(KFL(JT),PX(3),PY(3))
65159 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
65160
65161C...Final hadrons for small invariant mass.
65162 MSTJ(93)=1
65163 PMQ(3)=PYMASS(KFL(3))
65164 PARJST=PARJ(33)
65165 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65166 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
65167 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
65168 &WMIN-0.5D0*PARJ(36)*PMQ(3)
65169 WREM2=FOUR(N+NRS,N+NRS)
65170 IF(WREM2.LT.0.10D0) GOTO 710
65171 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
65172 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
65173
65174C...Choose z, which gives Gamma. Shift z for heavy flavours.
65175 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
65176 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
65177 &MSTU(90).LT.8) THEN
65178 MSTU(90)=MSTU(90)+1
65179 MSTU(90+MSTU(90))=I
65180 PARU(90+MSTU(90))=Z
65181 ENDIF
65182 KFL1A=IABS(KFL(1))
65183 KFL2A=IABS(KFL(2))
65184 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65185 &MOD(KFL2A/1000,10)).GE.4) THEN
65186 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65187 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
65188 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
65189 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65190 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
65191 ENDIF
65192 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
65193
65194C.. MOPS baryon model modification
65195 XTMO3=(1D0-Z)*XTMO(JT)
65196 IF(IABS(KFL(3)).LE.10) NRVMO=0
65197 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
65198 GTSTMO=1D0
65199 PTSTMO=1D0
65200 RTSTMO=PYR(0)
65201 IF(IABS(KFL(JT)).LE.10)THEN
65202 XBMO=MIN(XTMO3,1D0-(2D-10))
65203 GBMO=GAM(3)
65204 PMMO=0D0
65205 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
65206 GTSTMO=1D0-PARF(192)**PGMO
65207 ELSE
65208 IF(IRANK(JT).EQ.1) THEN
65209 GBMO=GAM(JT)
65210 PMMO=0D0
65211 XBMO=1D0
65212 ENDIF
65213 IF(XBMO.LT.1D0-(1D-10))THEN
65214 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
65215 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
65216 PGMO=PGNMO
65217 ENDIF
65218 IF(MSTJ(12).GE.5)THEN
65219 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
65220 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
65221 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
65222 PMMO=PMNMO
65223 ENDIF
65224 ENDIF
65225
65226C.. MOPS Accepting popcorn system hadron.
65227 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
65228 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
65229 NRVMO=I-N-NR
65230 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
65231 CALL PYERRM(11,
65232 & '(PYSTRF:) no more memory left in PYJETS')
65233 IF(MSTU(21).GE.1) RETURN
65234 ENDIF
65235 IMO=I
65236 KFLMO=KFL(JT)
65237 PMQMO=PMQ(JT)
65238 PXMO=PX(JT)
65239 PYMO=PY(JT)
65240 GAMMO=GAM(JT)
65241 IRMO=IRANK(JT)
65242 XMO=XTMO(JT)
65243 DO 900 J=1,9
65244 IF(J.LE.5) THEN
65245 DO 890 LINE=1,I-N-NR
65246 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
65247 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
65248 890 CONTINUE
65249 ENDIF
65250 INMO(J)=IN(J)
65251 900 CONTINUE
65252 ENDIF
65253 ELSE
65254C..Reject popcorn system, flag=-1 if enforcing new one
65255 MSTU(121)=-1
65256 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
65257 ENDIF
65258 ENDIF
65259
65260
65261C..Lift restoring string outside MOPS block
65262 910 IF(MSTU(121).LT.0) THEN
65263 IF(MSTU(121).EQ.-2) MSTU(121)=0
65264 MSTU(90)=MU90MO
65265 NRVMO=0
65266 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
65267 I=IMO
65268 KFL(JT)=KFLMO
65269 PMQ(JT)=PMQMO
65270 PX(JT)=PXMO
65271 PY(JT)=PYMO
65272 GAM(JT)=GAMMO
65273 IRANK(JT)=IRMO
65274 XTMO(JT)=XMO
65275 DO 930 J=1,9
65276 IF(J.LE.5) THEN
65277 DO 920 LINE=1,I-N-NR
65278 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
65279 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
65280 920 CONTINUE
65281 ENDIF
65282 IN(J)=INMO(J)
65283 930 CONTINUE
65284 GOTO 880
65285 ENDIF
65286 XTMO(JT)=XTMO3
65287C.. MOPS end of modification
65288
65289 DO 940 J=1,3
65290 IN(J)=IN(3*JT+J)
65291 940 CONTINUE
65292
65293C...Stepping within or from 'low' string region easy.
65294 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
65295 &P(IN(1),5)**2.GE.PR(JT)) THEN
65296 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
65297 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
65298 DO 950 J=1,4
65299 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
65300 950 CONTINUE
65301 GOTO 1040
65302 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
65303 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65304 P(IN(JR)+2,JT)=1D0
65305 IN(JR)=IN(JR)+4*JS
65306 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65307 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65308 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65309 P(IN(JT)+2,JT)=0D0
65310 IN(JT)=IN(JT)+4*JS
65311 ENDIF
65312 ENDIF
65313
65314C...Find new transverse directions (i.e. spacelike string vectors).
65315 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
65316 &IN(1).GT.IN(2)) GOTO 710
65317 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
65318 DO 970 J=1,4
65319 DP(1,J)=P(IN(1),J)
65320 DP(2,J)=P(IN(2),J)
65321 DP(3,J)=0D0
65322 DP(4,J)=0D0
65323 970 CONTINUE
65324 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65325 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65326 DHC12=DFOUR(1,2)
65327 IF(DHC12.LE.1D-2) THEN
65328 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65329 P(IN(JT)+2,JT)=0D0
65330 IN(JT)=IN(JT)+4*JS
65331 GOTO 960
65332 ENDIF
65333 IN(3)=N+NR+4*NS+5
65334 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65335 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65336 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65337 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65338 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65339 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65340 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65341 DHCX1=DFOUR(3,1)/DHC12
65342 DHCX2=DFOUR(3,2)/DHC12
65343 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65344 DHCY1=DFOUR(4,1)/DHC12
65345 DHCY2=DFOUR(4,2)/DHC12
65346 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65347 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65348 DO 980 J=1,4
65349 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65350 P(IN(3),J)=DP(3,J)
65351 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65352 & DHCYX*DP(3,J))
65353 980 CONTINUE
65354C...Express pT with respect to new axes, if sensible.
65355 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
65356 & FOUR(IN(3*JT+3)+1,IN(3)))
65357 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
65358 & FOUR(IN(3*JT+3)+1,IN(3)+1))
65359 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
65360 PX(3)=PXP
65361 PY(3)=PYP
65362 ENDIF
65363 ENDIF
65364
65365C...Sum up known four-momentum. Gives coefficients for m2 expression.
65366 DO 1010 J=1,4
65367 DHG(J)=0D0
65368 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
65369 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
65370 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
65371 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
65372 990 CONTINUE
65373 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
65374 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
65375 1000 CONTINUE
65376 1010 CONTINUE
65377 DHM(1)=FOUR(I,I)
65378 DHM(2)=2D0*FOUR(I,IN(1))
65379 DHM(3)=2D0*FOUR(I,IN(2))
65380 DHM(4)=2D0*FOUR(IN(1),IN(2))
65381
65382C...Find coefficients for Gamma expression.
65383 DO 1030 IN2=IN(1)+1,IN(2),4
65384 DO 1020 IN1=IN(1),IN2-1,4
65385 DHC=2D0*FOUR(IN1,IN2)
65386 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
65387 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
65388 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
65389 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
65390 1020 CONTINUE
65391 1030 CONTINUE
65392
65393C...Solve (m2, Gamma) equation system for energies taken.
65394 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
65395 IF(ABS(DHS1).LT.1D-4) GOTO 710
65396 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
65397 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
65398 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
65399 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
65400 &ABS(DHS1)-DHS2/DHS1)
65401 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
65402 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
65403 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
65404
65405C...Step to new region if necessary.
65406 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
65407 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65408 P(IN(JR)+2,JT)=1D0
65409 IN(JR)=IN(JR)+4*JS
65410 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65411 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65412 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65413 P(IN(JT)+2,JT)=0D0
65414 IN(JT)=IN(JT)+4*JS
65415 ENDIF
65416 GOTO 960
65417 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
65418 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65419 P(IN(JT)+2,JT)=0D0
65420 IN(JT)=IN(JT)+4*JS
65421 GOTO 960
65422 ENDIF
65423
65424C...Four-momentum of particle. Remaining quantities. Loop back.
65425 1040 DO 1050 J=1,4
65426 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
65427 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
65428 1050 CONTINUE
65429 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
65430 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
65431 &GOTO 200
65432 IF(P(I,4).LT.P(I,5)) GOTO 710
65433 KFL(JT)=-KFL(3)
65434 PMQ(JT)=PMQ(3)
65435 PX(JT)=-PX(3)
65436 PY(JT)=-PY(3)
65437 GAM(JT)=GAM(3)
65438 IF(IN(3).NE.IN(3*JT+3)) THEN
65439 DO 1060 J=1,4
65440 P(IN(3*JT+3),J)=P(IN(3),J)
65441 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
65442 1060 CONTINUE
65443 ENDIF
65444 DO 1070 JQ=1,2
65445 IN(3*JT+JQ)=IN(JQ)
65446 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
65447 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
65448 1070 CONTINUE
65449 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65450 &IBARRK(JT)=0
65451 GOTO 870
65452
65453C...Final hadron: side, flavour, hadron, mass.
65454 1080 I=I+1
65455 K(I,1)=1
65456 K(I,3)=IE(JR)
65457 K(I,4)=0
65458 K(I,5)=0
65459 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
65460 IF(K(I,2).EQ.0) GOTO 710
65461 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
65462 &IBARRK(JT)=0
65463 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65464 &K(I,3)=IJUORI(JT)
65465 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65466 &K(I,3)=IJUORI(JR)
65467 P(I,5)=PYMASS(K(I,2))
65468 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65469
65470C...Final two hadrons: find common setup of four-vectors.
65471 JQ=1
65472 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
65473 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
65474 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
65475 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
65476 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
65477 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
65478 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
65479 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
65480 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
65481 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
65482 ENDIF
65483
65484C...Solve kinematics for final two hadrons, if possible.
65485 WREM2=2D0*DHR1*DHR2*DHC12
65486 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
65487 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
65488 IF(FD.GE.1D0) GOTO 710
65489 FA=WREM2+PR(JT)-PR(JR)
65490 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
65491 PREVCF=PARJ(42)
65492 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65493 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
65494 FB=SIGN(FB,JS*(PYR(0)-PREV))
65495 KFL1A=IABS(KFL(1))
65496 KFL2A=IABS(KFL(2))
65497 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65498 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
65499 &4D0*WREM2*PR(JT))),DBLE(JS))
65500 DO 1090 J=1,4
65501 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
65502 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
65503 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
65504 P(I,J)=P(N+NRS,J)-P(I-1,J)
65505 1090 CONTINUE
65506 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
65507 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
65508 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
65509 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
65510 NTRYFN=NTRYFN+1
65511 IF(NTRYFN.LT.100) GOTO 140
65512 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
65513 ENDIF
65514
65515C...Mark jets as fragmented and give daughter pointers.
65516 N=I-NRS+1
65517 DO 1100 I=NSAV+1,NSAV+NP
65518 IM=K(I,3)
65519 K(IM,1)=K(IM,1)+10
65520 IF(MSTU(16).NE.2) THEN
65521 K(IM,4)=NSAV+1
65522 K(IM,5)=NSAV+1
65523 ELSE
65524 K(IM,4)=NSAV+2
65525 K(IM,5)=N
65526 ENDIF
65527 1100 CONTINUE
65528
65529C...Document string system. Move up particles.
65530 NSAV=NSAV+1
65531 K(NSAV,1)=11
65532 K(NSAV,2)=92
65533 K(NSAV,3)=IP
65534 K(NSAV,4)=NSAV+1
65535 K(NSAV,5)=N
65536 DO 1110 J=1,4
65537 P(NSAV,J)=DPS(J)
65538 V(NSAV,J)=V(IP,J)
65539 1110 CONTINUE
65540 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
65541 V(NSAV,5)=0D0
65542 DO 1130 I=NSAV+1,N
65543 DO 1120 J=1,5
65544 K(I,J)=K(I+NRS-1,J)
65545 P(I,J)=P(I+NRS-1,J)
65546 V(I,J)=0D0
65547 1120 CONTINUE
65548 1130 CONTINUE
65549 MSTU91=MSTU(90)
65550 DO 1140 IZ=MSTU90+1,MSTU91
65551 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
65552 PARU9T(IZ)=PARU(90+IZ)
65553 1140 CONTINUE
65554 MSTU(90)=MSTU90
65555
65556C...Order particles in rank along the chain. Update mother pointer.
65557 DO 1160 I=NSAV+1,N
65558 DO 1150 J=1,5
65559 K(I-NSAV+N,J)=K(I,J)
65560 P(I-NSAV+N,J)=P(I,J)
65561 1150 CONTINUE
65562 1160 CONTINUE
65563 I1=NSAV
65564 DO 1190 I=N+1,2*N-NSAV
65565 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
65566 I1=I1+1
65567 DO 1170 J=1,5
65568 K(I1,J)=K(I,J)
65569 P(I1,J)=P(I,J)
65570 1170 CONTINUE
65571 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65572 DO 1180 IZ=MSTU90+1,MSTU91
65573 IF(MSTU9T(IZ).EQ.I) THEN
65574 MSTU(90)=MSTU(90)+1
65575 MSTU(90+MSTU(90))=I1
65576 PARU(90+MSTU(90))=PARU9T(IZ)
65577 ENDIF
65578 1180 CONTINUE
65579 1190 CONTINUE
65580 DO 1220 I=2*N-NSAV,N+1,-1
65581 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
65582 I1=I1+1
65583 DO 1200 J=1,5
65584 K(I1,J)=K(I,J)
65585 P(I1,J)=P(I,J)
65586 1200 CONTINUE
65587 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65588 DO 1210 IZ=MSTU90+1,MSTU91
65589 IF(MSTU9T(IZ).EQ.I) THEN
65590 MSTU(90)=MSTU(90)+1
65591 MSTU(90+MSTU(90))=I1
65592 PARU(90+MSTU(90))=PARU9T(IZ)
65593 ENDIF
65594 1210 CONTINUE
65595 1220 CONTINUE
65596
65597C...Boost back particle system. Set production vertices.
65598 IF(MBST.EQ.0) THEN
65599 MSTU(33)=1
65600 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
65601 & DPS(3)/DPS(4))
65602 ELSE
65603 DO 1230 I=NSAV+1,N
65604 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65605 IF(P(I,3).GT.0D0) THEN
65606 HHPEZ=(P(I,4)+P(I,3))*HHBZ
65607 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65608 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65609 ELSE
65610 HHPEZ=(P(I,4)-P(I,3))/HHBZ
65611 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65612 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65613 ENDIF
65614 1230 CONTINUE
65615 ENDIF
65616 DO 1250 I=NSAV+1,N
65617 DO 1240 J=1,4
65618 V(I,J)=V(IP,J)
65619 1240 CONTINUE
65620 1250 CONTINUE
65621
65622 RETURN
65623 END
65624
65625C*********************************************************************
65626
65627C...PYJURF
65628C...From three given input vectors in PJU the boost VJU from
65629C...the "lab frame" to the junction rest frame is constructed.
65630
65631 SUBROUTINE PYJURF(PJU,VJU)
65632
65633C...Double precision and integer declarations.
65634 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65635 IMPLICIT INTEGER(I-N)
65636
65637C...Input, output and local arrays.
65638 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
65639 DATA TWOPI/6.283186D0/
65640
65641C...Calculate masses and other invariants.
65642 DO 100 J=1,4
65643 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
65644 100 CONTINUE
65645 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
65646 PSUM(5)=SQRT(PSUM2)
65647 DO 120 I=1,3
65648 DO 110 J=1,3
65649 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
65650 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
65651 110 CONTINUE
65652 120 CONTINUE
65653
65654C...Pick I to be most massive parton and J to be the one closest to I.
65655 ITRY=0
65656 I=1
65657 IF(A(2,2).GT.A(1,1)) I=2
65658 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
65659 130 ITRY=ITRY+1
65660 J=1+MOD(I,3)
65661 K=1+MOD(J,3)
65662 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
65663 K=1+MOD(I,3)
65664 J=1+MOD(K,3)
65665 ENDIF
65666 PMI2=A(I,I)
65667 PMJ2=A(J,J)
65668 PMK2=A(K,K)
65669 AIJ=A(I,J)
65670 AIK=A(I,K)
65671 AJK=A(J,K)
65672
65673C...Trivial find new parton energies if all three partons are massless.
65674 IF(PMI2.LT.1D-4) THEN
65675 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
65676 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
65677 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
65678
65679C...Else find momentum range for parton I and values at extremes.
65680 ELSE
65681 PAIMIN=0D0
65682 PEIMIN=SQRT(PMI2)
65683 PEJMIN=AIJ/PEIMIN
65684 PEKMIN=AIK/PEIMIN
65685 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
65686 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
65687 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
65688 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
65689 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
65690 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
65691 HI=PEIMAX**2-0.25D0*PAIMAX**2
65692 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
65693 & 0.5D0*PAIMAX*AIJ)/HI
65694 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
65695 & 0.5D0*PAIMAX*AIK)/HI
65696 PEJMAX=SQRT(PAJMAX**2+PMJ2)
65697 PEKMAX=SQRT(PAKMAX**2+PMK2)
65698 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
65699
65700C...If unexpected values at upper endpoint then pick another parton.
65701 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
65702 I1=1+MOD(I,3)
65703 IF(A(I1,I1).GE.1D-4) THEN
65704 I=I1
65705 GOTO 130
65706 ENDIF
65707 ITRY=ITRY+1
65708 I1=1+MOD(I,3)
65709 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
65710 I=I1
65711 GOTO 130
65712 ENDIF
65713 ENDIF
65714
65715C..Start binary + linear search to find solution inside range.
65716 ITER=0
65717 ITMIN=0
65718 ITMAX=0
65719 PAI=0.5D0*(PAIMIN+PAIMAX)
65720 140 ITER=ITER+1
65721
65722C...Derive momentum of other two partons and distance to root.
65723 PEI=SQRT(PAI**2+PMI2)
65724 HI=PEI**2-0.25D0*PAI**2
65725 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
65726 PEJ=SQRT(PAJ**2+PMJ2)
65727 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
65728 PEK=SQRT(PAK**2+PMK2)
65729 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
65730
65731C...Pick next I momentum to explore, hopefully closer to root.
65732 IF(FNOW.GT.0D0) THEN
65733 PAIMIN=PAI
65734 FMIN=FNOW
65735 ITMIN=ITMIN+1
65736 ELSE
65737 PAIMAX=PAI
65738 FMAX=FNOW
65739 ITMAX=ITMAX+1
65740 ENDIF
65741 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
65742 & THEN
65743 PAI=0.5D0*(PAIMIN+PAIMAX)
65744 GOTO 140
65745 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
65746 & ABS(FNOW).GT.1D-12*PSUM2) THEN
65747 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
65748 GOTO 140
65749 ENDIF
65750 ENDIF
65751
65752C...Now know energies in junction rest frame.
65753 PENEW(I)=PEI
65754 PENEW(J)=PEJ
65755 PENEW(K)=PEK
65756
65757C...Boost (copy of) partons to their rest frame.
65758 VXCM=-PSUM(1)/PSUM(5)
65759 VYCM=-PSUM(2)/PSUM(5)
65760 VZCM=-PSUM(3)/PSUM(5)
65761 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
65762 DO 150 I=1,3
65763 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
65764 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
65765 PCM(I,1)=PJU(I,1)+FAC2*VXCM
65766 PCM(I,2)=PJU(I,2)+FAC2*VYCM
65767 PCM(I,3)=PJU(I,3)+FAC2*VZCM
65768 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
65769 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65770 150 CONTINUE
65771
65772C...Construct difference vectors and boost to junction rest frame.
65773 DO 160 J=1,3
65774 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
65775 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
65776 160 CONTINUE
65777 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
65778 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
65779 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
65780 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
65781 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
65782 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
65783 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
65784 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
65785 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
65786 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
65787 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
65788
65789C...Add two boosts, giving final result.
65790 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
65791 VJU(1)=VXJU+FCM*VXCM
65792 VJU(2)=VYJU+FCM*VYCM
65793 VJU(3)=VZJU+FCM*VZCM
65794 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
65795 VJU(5)=1D0
65796
65797C...In case of error in reconstruction: revert to CM frame of system.
65798 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65799 &(PCM(1,5)*PCM(2,5))
65800 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65801 &(PCM(1,5)*PCM(3,5))
65802 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65803 &(PCM(2,5)*PCM(3,5))
65804 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65805 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65806 DO 170 I=1,3
65807 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
65808 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
65809 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
65810 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
65811 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
65812 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
65813 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65814 170 CONTINUE
65815 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65816 &(PCM(1,5)*PCM(2,5))
65817 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65818 &(PCM(1,5)*PCM(3,5))
65819 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65820 &(PCM(2,5)*PCM(3,5))
65821 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65822 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65823 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
65824 VJU(1)=VXCM
65825 VJU(2)=VYCM
65826 VJU(3)=VZCM
65827 VJU(4)=GAMCM
65828 ENDIF
65829
65830 RETURN
65831 END
65832
65833C*********************************************************************
65834
65835C...PYINDF
65836C...Handles the fragmentation of a jet system (or a single
65837C...jet) according to independent fragmentation models.
65838
65839 SUBROUTINE PYINDF(IP)
65840
65841C...Double precision and integer declarations.
65842 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65843 IMPLICIT INTEGER(I-N)
65844 INTEGER PYK,PYCHGE,PYCOMP
65845C...Commonblocks.
65846 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65847 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65848 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65849 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65850C...Local arrays.
65851 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
65852 &KFLO(2),PXO(2),PYO(2),WO(2)
65853
65854C.. MOPS error message
65855 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
65856 &' are not treated as expected in independent fragmentation')
65857
65858C...Reset counters. Identify parton system and take copy. Check flavour.
65859 NSAV=N
65860 MSTU90=MSTU(90)
65861 NJET=0
65862 KQSUM=0
65863 DO 100 J=1,5
65864 DPS(J)=0D0
65865 100 CONTINUE
65866 I=IP-1
65867 110 I=I+1
65868 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65869 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
65870 IF(MSTU(21).GE.1) RETURN
65871 ENDIF
65872 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
65873 KC=PYCOMP(K(I,2))
65874 IF(KC.EQ.0) GOTO 110
65875 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65876 IF(KQ.EQ.0) GOTO 110
65877 NJET=NJET+1
65878 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65879 DO 120 J=1,5
65880 K(NSAV+NJET,J)=K(I,J)
65881 P(NSAV+NJET,J)=P(I,J)
65882 DPS(J)=DPS(J)+P(I,J)
65883 120 CONTINUE
65884 K(NSAV+NJET,3)=I
65885 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
65886 &K(I+1,1).EQ.2)) GOTO 110
65887 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
65888 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
65889 IF(MSTU(21).GE.1) RETURN
65890 ENDIF
65891
65892C...Boost copied system to CM frame. Find CM energy and sum flavours.
65893 IF(NJET.NE.1) THEN
65894 MSTU(33)=1
65895 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
65896 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
65897 ENDIF
65898 PECM=0D0
65899 DO 130 J=1,3
65900 NFI(J)=0
65901 130 CONTINUE
65902 DO 140 I=NSAV+1,NSAV+NJET
65903 PECM=PECM+P(I,4)
65904 KFA=IABS(K(I,2))
65905 IF(KFA.LE.3) THEN
65906 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
65907 ELSEIF(KFA.GT.1000) THEN
65908 KFLA=MOD(KFA/1000,10)
65909 KFLB=MOD(KFA/100,10)
65910 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
65911 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
65912 ENDIF
65913 140 CONTINUE
65914
65915C...Loop over attempts made. Reset counters.
65916 NTRY=0
65917 150 NTRY=NTRY+1
65918 IF(NTRY.GT.200) THEN
65919 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
65920 IF(MSTU(21).GE.1) RETURN
65921 ENDIF
65922 N=NSAV+NJET
65923 MSTU(90)=MSTU90
65924 DO 160 J=1,3
65925 NFL(J)=NFI(J)
65926 IFET(J)=0
65927 KFLF(J)=0
65928 160 CONTINUE
65929
65930C...Loop over jets to be fragmented.
65931 DO 230 IP1=NSAV+1,NSAV+NJET
65932 MSTJ(91)=0
65933 NSAV1=N
65934 MSTU91=MSTU(90)
65935
65936C...Initial flavour and momentum values. Jet along +z axis.
65937 KFLH=IABS(K(IP1,2))
65938 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
65939 KFLO(2)=0
65940 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
65941
65942C...Initial values for quark or diquark jet.
65943 170 IF(IABS(K(IP1,2)).NE.21) THEN
65944 NSTR=1
65945 KFLO(1)=K(IP1,2)
65946 CALL PYPTDI(0,PXO(1),PYO(1))
65947 WO(1)=WF
65948
65949C...Initial values for gluon treated like random quark jet.
65950 ELSEIF(MSTJ(2).LE.2) THEN
65951 NSTR=1
65952 IF(MSTJ(2).EQ.2) MSTJ(91)=1
65953 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65954 CALL PYPTDI(0,PXO(1),PYO(1))
65955 WO(1)=WF
65956
65957C...Initial values for gluon treated like quark-antiquark jet pair,
65958C...sharing energy according to Altarelli-Parisi splitting function.
65959 ELSE
65960 NSTR=2
65961 IF(MSTJ(2).EQ.4) MSTJ(91)=1
65962 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65963 KFLO(2)=-KFLO(1)
65964 CALL PYPTDI(0,PXO(1),PYO(1))
65965 PXO(2)=-PXO(1)
65966 PYO(2)=-PYO(1)
65967 WO(1)=WF*PYR(0)**(1D0/3D0)
65968 WO(2)=WF-WO(1)
65969 ENDIF
65970
65971C...Initial values for rank, flavour, pT and W+.
65972 DO 220 ISTR=1,NSTR
65973 180 I=N
65974 MSTU(90)=MSTU91
65975 IRANK=0
65976 KFL1=KFLO(ISTR)
65977 PX1=PXO(ISTR)
65978 PY1=PYO(ISTR)
65979 W=WO(ISTR)
65980
65981C...New hadron. Generate flavour and hadron species.
65982 190 I=I+1
65983 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
65984 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
65985 IF(MSTU(21).GE.1) RETURN
65986 ENDIF
65987 IRANK=IRANK+1
65988 K(I,1)=1
65989 K(I,3)=IP1
65990 K(I,4)=0
65991 K(I,5)=0
65992 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
65993 IF(K(I,2).EQ.0) GOTO 180
65994 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
65995 IF(PYR(0).GT.PARJ(19)) GOTO 200
65996 ENDIF
65997
65998C...Find hadron mass. Generate four-momentum.
65999 P(I,5)=PYMASS(K(I,2))
66000 CALL PYPTDI(KFL1,PX2,PY2)
66001 P(I,1)=PX1+PX2
66002 P(I,2)=PY1+PY2
66003 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
66004 CALL PYZDIS(KFL1,KFL2,PR,Z)
66005 MZSAV=0
66006 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
66007 MZSAV=1
66008 MSTU(90)=MSTU(90)+1
66009 MSTU(90+MSTU(90))=I
66010 PARU(90+MSTU(90))=Z
66011 ENDIF
66012 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
66013 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
66014 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
66015 & P(I,3).LE.0.001D0) THEN
66016 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
66017 P(I,3)=0.0001D0
66018 P(I,4)=SQRT(PR)
66019 Z=P(I,4)/W
66020 ENDIF
66021
66022C...Remaining flavour and momentum.
66023 KFL1=-KFL2
66024 PX1=-PX2
66025 PY1=-PY2
66026 W=(1D0-Z)*W
66027 DO 210 J=1,5
66028 V(I,J)=0D0
66029 210 CONTINUE
66030
66031C...Check if pL acceptable. Go back for new hadron if enough energy.
66032 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
66033 I=I-1
66034 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
66035 ENDIF
66036 IF(W.GT.PARJ(31)) GOTO 190
66037 N=I
66038 220 CONTINUE
66039 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
66040 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
66041
66042C...Rotate jet to new direction.
66043 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
66044 PHI=PYANGL(P(IP1,1),P(IP1,2))
66045 MSTU(33)=1
66046 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
66047 K(K(IP1,3),4)=NSAV1+1
66048 K(K(IP1,3),5)=N
66049
66050C...End of jet generation loop. Skip conservation in some cases.
66051 230 CONTINUE
66052 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
66053 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
66054
66055C...Subtract off produced hadron flavours, finished if zero.
66056 DO 240 I=NSAV+NJET+1,N
66057 KFA=IABS(K(I,2))
66058 KFLA=MOD(KFA/1000,10)
66059 KFLB=MOD(KFA/100,10)
66060 KFLC=MOD(KFA/10,10)
66061 IF(KFLA.EQ.0) THEN
66062 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
66063 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
66064 ELSE
66065 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
66066 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
66067 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
66068 ENDIF
66069 240 CONTINUE
66070 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66071 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66072 IF(NREQ.EQ.0) GOTO 320
66073
66074C...Take away flavour of low-momentum particles until enough freedom.
66075 NREM=0
66076 250 IREM=0
66077 P2MIN=PECM**2
66078 DO 260 I=NSAV+NJET+1,N
66079 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
66080 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
66081 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
66082 260 CONTINUE
66083 IF(IREM.EQ.0) GOTO 150
66084 K(IREM,1)=7
66085 KFA=IABS(K(IREM,2))
66086 KFLA=MOD(KFA/1000,10)
66087 KFLB=MOD(KFA/100,10)
66088 KFLC=MOD(KFA/10,10)
66089 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
66090 IF(K(IREM,1).EQ.8) GOTO 250
66091 IF(KFLA.EQ.0) THEN
66092 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
66093 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
66094 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
66095 ELSE
66096 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
66097 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
66098 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
66099 ENDIF
66100 NREM=NREM+1
66101 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66102 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66103 IF(NREQ.GT.NREM) GOTO 250
66104 DO 270 I=NSAV+NJET+1,N
66105 IF(K(I,1).EQ.8) K(I,1)=1
66106 270 CONTINUE
66107
66108C...Find combination of existing and new flavours for hadron.
66109 280 NFET=2
66110 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
66111 IF(NREQ.LT.NREM) NFET=1
66112 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
66113 DO 290 J=1,NFET
66114 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
66115 KFLF(J)=ISIGN(1,NFL(1))
66116 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
66117 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
66118 290 CONTINUE
66119 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
66120 &GOTO 280
66121 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
66122 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
66123 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
66124 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
66125 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
66126 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
66127 IF(NFET.LE.2) KFLF(3)=0
66128 IF(KFLF(3).NE.0) THEN
66129 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
66130 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
66131 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
66132 & KFLFC=KFLFC+ISIGN(2,KFLFC)
66133 ELSE
66134 KFLFC=KFLF(1)
66135 ENDIF
66136 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
66137 IF(KF.EQ.0) GOTO 280
66138 DO 300 J=1,MAX(2,NFET)
66139 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
66140 300 CONTINUE
66141
66142C...Store hadron at random among free positions.
66143 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
66144 DO 310 I=NSAV+NJET+1,N
66145 IF(K(I,1).EQ.7) NPOS=NPOS-1
66146 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
66147 K(I,1)=1
66148 K(I,2)=KF
66149 P(I,5)=PYMASS(K(I,2))
66150 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66151 310 CONTINUE
66152 NREM=NREM-1
66153 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66154 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66155 IF(NREM.GT.0) GOTO 280
66156
66157C...Compensate for missing momentum in global scheme (3 options).
66158 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
66159 DO 340 J=1,3
66160 PSI(J)=0D0
66161 DO 330 I=NSAV+NJET+1,N
66162 PSI(J)=PSI(J)+P(I,J)
66163 330 CONTINUE
66164 340 CONTINUE
66165 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
66166 PWS=0D0
66167 DO 350 I=NSAV+NJET+1,N
66168 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
66169 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66170 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66171 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
66172 350 CONTINUE
66173 DO 370 I=NSAV+NJET+1,N
66174 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
66175 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66176 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66177 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
66178 DO 360 J=1,3
66179 P(I,J)=P(I,J)-PSI(J)*PW/PWS
66180 360 CONTINUE
66181 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66182 370 CONTINUE
66183
66184C...Compensate for missing momentum withing each jet separately.
66185 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
66186 DO 390 I=N+1,N+NJET
66187 K(I,1)=0
66188 DO 380 J=1,5
66189 P(I,J)=0D0
66190 380 CONTINUE
66191 390 CONTINUE
66192 DO 410 I=NSAV+NJET+1,N
66193 IR1=K(I,3)
66194 IR2=N+IR1-NSAV
66195 K(IR2,1)=K(IR2,1)+1
66196 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66197 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66198 DO 400 J=1,3
66199 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
66200 400 CONTINUE
66201 P(IR2,4)=P(IR2,4)+P(I,4)
66202 P(IR2,5)=P(IR2,5)+PLS
66203 410 CONTINUE
66204 PSS=0D0
66205 DO 420 I=N+1,N+NJET
66206 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
66207 420 CONTINUE
66208 DO 440 I=NSAV+NJET+1,N
66209 IR1=K(I,3)
66210 IR2=N+IR1-NSAV
66211 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66212 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66213 DO 430 J=1,3
66214 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
66215 & PLS*P(IR1,J)
66216 430 CONTINUE
66217 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66218 440 CONTINUE
66219 ENDIF
66220
66221C...Scale momenta for energy conservation.
66222 IF(MOD(MSTJ(3),5).NE.0) THEN
66223 PMS=0D0
66224 PES=0D0
66225 PQS=0D0
66226 DO 450 I=NSAV+NJET+1,N
66227 PMS=PMS+P(I,5)
66228 PES=PES+P(I,4)
66229 PQS=PQS+P(I,5)**2/P(I,4)
66230 450 CONTINUE
66231 IF(PMS.GE.PECM) GOTO 150
66232 NECO=0
66233 460 NECO=NECO+1
66234 PFAC=(PECM-PQS)/(PES-PQS)
66235 PES=0D0
66236 PQS=0D0
66237 DO 480 I=NSAV+NJET+1,N
66238 DO 470 J=1,3
66239 P(I,J)=PFAC*P(I,J)
66240 470 CONTINUE
66241 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66242 PES=PES+P(I,4)
66243 PQS=PQS+P(I,5)**2/P(I,4)
66244 480 CONTINUE
66245 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
66246 ENDIF
66247
66248C...Origin of produced particles and parton daughter pointers.
66249 490 DO 500 I=NSAV+NJET+1,N
66250 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
66251 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
66252 500 CONTINUE
66253 DO 510 I=NSAV+1,NSAV+NJET
66254 I1=K(I,3)
66255 K(I1,1)=K(I1,1)+10
66256 IF(MSTU(16).NE.2) THEN
66257 K(I1,4)=NSAV+1
66258 K(I1,5)=NSAV+1
66259 ELSE
66260 K(I1,4)=K(I1,4)-NJET+1
66261 K(I1,5)=K(I1,5)-NJET+1
66262 IF(K(I1,5).LT.K(I1,4)) THEN
66263 K(I1,4)=0
66264 K(I1,5)=0
66265 ENDIF
66266 ENDIF
66267 510 CONTINUE
66268
66269C...Document independent fragmentation system. Remove copy of jets.
66270 NSAV=NSAV+1
66271 K(NSAV,1)=11
66272 K(NSAV,2)=93
66273 K(NSAV,3)=IP
66274 K(NSAV,4)=NSAV+1
66275 K(NSAV,5)=N-NJET+1
66276 DO 520 J=1,4
66277 P(NSAV,J)=DPS(J)
66278 V(NSAV,J)=V(IP,J)
66279 520 CONTINUE
66280 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
66281 V(NSAV,5)=0D0
66282 DO 540 I=NSAV+NJET,N
66283 DO 530 J=1,5
66284 K(I-NJET+1,J)=K(I,J)
66285 P(I-NJET+1,J)=P(I,J)
66286 V(I-NJET+1,J)=V(I,J)
66287 530 CONTINUE
66288 540 CONTINUE
66289 N=N-NJET+1
66290 DO 550 IZ=MSTU90+1,MSTU(90)
66291 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
66292 550 CONTINUE
66293
66294C...Boost back particle system. Set production vertices.
66295 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
66296 &DPS(2)/DPS(4),DPS(3)/DPS(4))
66297 DO 570 I=NSAV+1,N
66298 DO 560 J=1,4
66299 V(I,J)=V(IP,J)
66300 560 CONTINUE
66301 570 CONTINUE
66302
66303 RETURN
66304 END
66305
66306C*********************************************************************
66307
66308C...PYDECY
66309C...Handles the decay of unstable particles.
66310
66311 SUBROUTINE PYDECY(IP)
66312
66313C...Double precision and integer declarations.
66314 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
66315 IMPLICIT INTEGER(I-N)
66316 INTEGER PYK,PYCHGE,PYCOMP
66317C...Commonblocks.
66318 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
66319 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
66320 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
66321 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
66322 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
66323C...Local arrays.
66324 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
66325 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
66326 CHARACTER CIDC*4
66327 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66328
66329C...Functions: momentum in two-particle decays and four-product.
66330 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
66331 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)
66332
66333C...Initial values.
66334 NTRY=0
66335 NSAV=N
66336 KFA=IABS(K(IP,2))
66337 KFS=ISIGN(1,K(IP,2))
66338 KC=PYCOMP(KFA)
66339 MSTJ(92)=0
66340
66341C...Choose lifetime and determine decay vertex.
66342 IF(K(IP,1).EQ.5) THEN
66343 V(IP,5)=0D0
66344 ELSEIF(K(IP,1).NE.4) THEN
66345 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
66346 ENDIF
66347 DO 100 J=1,4
66348 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
66349 100 CONTINUE
66350
66351C...Determine whether decay allowed or not.
66352 MOUT=0
66353 IF(MSTJ(22).EQ.2) THEN
66354 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
66355 ELSEIF(MSTJ(22).EQ.3) THEN
66356 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
66357 ELSEIF(MSTJ(22).EQ.4) THEN
66358 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
66359 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
66360 ENDIF
66361 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
66362 K(IP,1)=4
66363 RETURN
66364 ENDIF
66365
66366C...Interface to external tau decay library (for tau polarization).
66367 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
66368
66369C...Starting values for pointers and momenta.
66370 ITAU=IP
66371 DO 110 J=1,4
66372 PTAU(J)=P(ITAU,J)
66373 PCMTAU(J)=P(ITAU,J)
66374 110 CONTINUE
66375
66376C...Iterate to find position and code of mother of tau.
66377 IMTAU=ITAU
66378 120 IMTAU=K(IMTAU,3)
66379
66380 IF(IMTAU.EQ.0) THEN
66381C...If no known origin then impossible to do anything further.
66382 KFORIG=0
66383 IORIG=0
66384
66385 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
66386C...If tau -> tau + gamma then add gamma energy and loop.
66387 IF(K(K(IMTAU,4),2).EQ.22) THEN
66388 DO 130 J=1,4
66389 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
66390 130 CONTINUE
66391 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
66392 DO 140 J=1,4
66393 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
66394 140 CONTINUE
66395 ENDIF
66396 GOTO 120
66397
66398 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
66399C...If coming from weak decay of hadron then W is not stored in record,
66400C...but can be reconstructed by adding neutrino momentum.
66401 KFORIG=-ISIGN(24,K(ITAU,2))
66402 IORIG=0
66403 DO 160 II=K(IMTAU,4),K(IMTAU,5)
66404 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
66405 DO 150 J=1,4
66406 PCMTAU(J)=PCMTAU(J)+P(II,J)
66407 150 CONTINUE
66408 ENDIF
66409 160 CONTINUE
66410
66411 ELSE
66412C...If coming from resonance decay then find latest copy of this
66413C...resonance (may not completely agree).
66414 KFORIG=K(IMTAU,2)
66415 IORIG=IMTAU
66416 DO 170 II=IMTAU+1,IP-1
66417 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
66418 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
66419 170 CONTINUE
66420 DO 180 J=1,4
66421 PCMTAU(J)=P(IORIG,J)
66422 180 CONTINUE
66423 ENDIF
66424
66425C...Boost tau to rest frame of production process (where known)
66426C...and rotate it to sit along +z axis.
66427 DO 190 J=1,3
66428 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
66429 190 CONTINUE
66430 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
66431 & -DBETAU(2),-DBETAU(3))
66432 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
66433 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
66434 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
66435 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
66436
66437C...Call tau decay routine (if meaningful) and fill extra info.
66438 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66439 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
66440 DO 200 II=NSAV+1,NSAV+NDECAY
66441 K(II,1)=1
66442 K(II,3)=IP
66443 K(II,4)=0
66444 K(II,5)=0
66445 200 CONTINUE
66446 N=NSAV+NDECAY
66447 ENDIF
66448
66449C...Boost back decay tau and decay products.
66450 DO 210 J=1,4
66451 P(ITAU,J)=PTAU(J)
66452 210 CONTINUE
66453 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66454 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
66455 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
66456 & DBETAU(2),DBETAU(3))
66457
66458C...Skip past ordinary tau decay treatment.
66459 MMAT=0
66460 MBST=0
66461 ND=0
66462 GOTO 630
66463 ENDIF
66464 ENDIF
66465
66466C...B-Bbar mixing: flip sign of meson appropriately.
66467 MMIX=0
66468 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
66469 XBBMIX=PARJ(76)
66470 IF(KFA.EQ.531) XBBMIX=PARJ(77)
66471 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
66472 IF(MMIX.EQ.1) KFS=-KFS
66473 ENDIF
66474
66475C...Check existence of decay channels. Particle/antiparticle rules.
66476 KCA=KC
66477 IF(MDCY(KC,2).GT.0) THEN
66478 MDMDCY=MDME(MDCY(KC,2),2)
66479 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
66480 ENDIF
66481 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
66482 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
66483 RETURN
66484 ENDIF
66485 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
66486 IF(KCHG(KC,3).EQ.0) THEN
66487 KFSP=1
66488 KFSN=0
66489 IF(PYR(0).GT.0.5D0) KFS=-KFS
66490 ELSEIF(KFS.GT.0) THEN
66491 KFSP=1
66492 KFSN=0
66493 ELSE
66494 KFSP=0
66495 KFSN=1
66496 ENDIF
66497
66498C...Sum branching ratios of allowed decay channels.
66499 220 NOPE=0
66500 BRSU=0D0
66501 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
66502 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66503 & KFSN*MDME(IDL,1).NE.3) GOTO 230
66504 IF(MDME(IDL,2).GT.100) GOTO 230
66505 NOPE=NOPE+1
66506 BRSU=BRSU+BRAT(IDL)
66507 230 CONTINUE
66508 IF(NOPE.EQ.0) THEN
66509 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
66510 RETURN
66511 ENDIF
66512
66513C...Select decay channel among allowed ones.
66514 240 RBR=BRSU*PYR(0)
66515 IDL=MDCY(KCA,2)-1
66516 250 IDL=IDL+1
66517 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66518 &KFSN*MDME(IDL,1).NE.3) THEN
66519 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66520 ELSEIF(MDME(IDL,2).GT.100) THEN
66521 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66522 ELSE
66523 IDC=IDL
66524 RBR=RBR-BRAT(IDL)
66525 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
66526 ENDIF
66527
66528C...Start readout of decay channel: matrix element, reset counters.
66529 MMAT=MDME(IDC,2)
66530 260 NTRY=NTRY+1
66531 IF(MOD(NTRY,200).EQ.0) THEN
66532 WRITE(CIDC,'(I4)') IDC
66533C...Do not print warning for some well-known special cases.
66534 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
66535 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
66536 & CIDC)
66537 GOTO 240
66538 ENDIF
66539 IF(NTRY.GT.1000) THEN
66540 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66541 IF(MSTU(21).GE.1) RETURN
66542 ENDIF
66543 I=N
66544 NP=0
66545 NQ=0
66546 MBST=0
66547 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
66548 DO 270 J=1,4
66549 PV(1,J)=0D0
66550 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
66551 270 CONTINUE
66552 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
66553 PV(1,5)=P(IP,5)
66554 PS=0D0
66555 PSQ=0D0
66556 MREM=0
66557 MHADDY=0
66558 IF(KFA.GT.80) MHADDY=1
66559C.. Random flavour and popcorn system memory.
66560 IRNDMO=0
66561 JTMO=0
66562 MSTU(121)=0
66563 MSTU(125)=10
66564
66565C...Read out decay products. Convert to standard flavour code.
66566 JTMAX=5
66567 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
66568 DO 280 JT=1,JTMAX
66569 IF(JT.LE.5) KP=KFDP(IDC,JT)
66570 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
66571 IF(KP.EQ.0) GOTO 280
66572 KPA=IABS(KP)
66573 KCP=PYCOMP(KPA)
66574 IF(KPA.GT.80) MHADDY=1
66575 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
66576 KFP=KP
66577 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
66578 KFP=KFS*KP
66579 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
66580 KFP=-KFS*MOD(KFA/10,10)
66581 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
66582 KFP=KFS*(100*MOD(KFA/10,100)+3)
66583 ELSEIF(KPA.EQ.81) THEN
66584 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
66585 ELSEIF(KP.EQ.82) THEN
66586 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
66587 IF(KFP.EQ.0) GOTO 260
66588 KFP=-KFP
66589 IRNDMO=1
66590 MSTJ(93)=1
66591 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
66592 ELSEIF(KP.EQ.-82) THEN
66593 KFP=MSTU(124)
66594 ENDIF
66595 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
66596
66597C...Add decay product to event record or to quark flavour list.
66598 KFPA=IABS(KFP)
66599 KQP=KCHG(KCP,2)
66600 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
66601 NQ=NQ+1
66602 KFLO(NQ)=KFP
66603C...set rndmflav popcorn system pointer
66604 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
66605 MSTJ(93)=2
66606 PSQ=PSQ+PYMASS(KFLO(NQ))
66607 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
66608 & MOD(NQ,2).EQ.1) THEN
66609 NQ=NQ-1
66610 PS=PS-P(I,5)
66611 K(I,1)=1
66612 KFI=K(I,2)
66613 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
66614 IF(K(I,2).EQ.0) GOTO 260
66615 MSTJ(93)=1
66616 P(I,5)=PYMASS(K(I,2))
66617 PS=PS+P(I,5)
66618 ELSE
66619 I=I+1
66620 NP=NP+1
66621 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
66622 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
66623 K(I,1)=1+MOD(NQ,2)
66624 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
66625 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
66626 K(I,2)=KFP
66627 K(I,3)=IP
66628 K(I,4)=0
66629 K(I,5)=0
66630 P(I,5)=PYMASS(KFP)
66631 PS=PS+P(I,5)
66632 ENDIF
66633 280 CONTINUE
66634
66635C...Check masses for resonance decays.
66636 IF(MHADDY.EQ.0) THEN
66637 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
66638 ENDIF
66639
66640C...Choose decay multiplicity in phase space model.
66641 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
66642 PSP=PS
66643 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
66644 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
66645 300 NTRY=NTRY+1
66646C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66647 IF(IRNDMO.EQ.0) THEN
66648 MSTU(121)=0
66649 JTMO=0
66650 ELSEIF(IRNDMO.EQ.1) THEN
66651 IRNDMO=2
66652 ELSE
66653 GOTO 260
66654 ENDIF
66655 IF(NTRY.GT.1000) THEN
66656 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66657 IF(MSTU(21).GE.1) RETURN
66658 ENDIF
66659 IF(MMAT.LE.20) THEN
66660 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
66661 & SIN(PARU(2)*PYR(0))
66662 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
66663 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
66664 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
66665 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
66666 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
66667 ELSE
66668 ND=MMAT-20
66669 ENDIF
66670C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66671 MSTU(125)=ND-NQ/2
66672 IF(MSTU(121).GT.MSTU(125)) GOTO 300
66673
66674C...Form hadrons from flavour content.
66675 DO 310 JT=1,NQ
66676 KFL1(JT)=KFLO(JT)
66677 310 CONTINUE
66678 IF(ND.EQ.NP+NQ/2) GOTO 330
66679 DO 320 I=N+NP+1,N+ND-NQ/2
66680C.. Stick to started popcorn system, else pick side at random
66681 JT=JTMO
66682 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
66683 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
66684 IF(K(I,2).EQ.0) GOTO 300
66685 MSTU(125)=MSTU(125)-1
66686 JTMO=0
66687 IF(MSTU(121).GT.0) JTMO=JT
66688 KFL1(JT)=-KFL2
66689 320 CONTINUE
66690 330 JT=2
66691 JT2=3
66692 JT3=4
66693 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
66694 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
66695 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
66696 IF(JT.EQ.3) JT2=2
66697 IF(JT.EQ.4) JT3=2
66698 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
66699 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
66700 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
66701 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
66702
66703C...Check that sum of decay product masses not too large.
66704 PS=PSP
66705 DO 340 I=N+NP+1,N+ND
66706 K(I,1)=1
66707 K(I,3)=IP
66708 K(I,4)=0
66709 K(I,5)=0
66710 P(I,5)=PYMASS(K(I,2))
66711 PS=PS+P(I,5)
66712 340 CONTINUE
66713 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
66714
66715C...Rescale energy to subtract off spectator quark mass.
66716 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
66717 & .AND.NP.GE.3) THEN
66718 PS=PS-P(N+NP,5)
66719 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
66720 DO 350 J=1,5
66721 P(N+NP,J)=PQT*PV(1,J)
66722 PV(1,J)=(1D0-PQT)*PV(1,J)
66723 350 CONTINUE
66724 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
66725 ND=NP-1
66726 MREM=1
66727
66728C...Fully specified final state: check mass broadening effects.
66729 ELSE
66730 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
66731 ND=NP
66732 ENDIF
66733
66734C...Determine position of grandmother, number of sisters.
66735 NM=0
66736 KFAS=0
66737 MSGN=0
66738 IF(MMAT.EQ.3) THEN
66739 IM=K(IP,3)
66740 IF(IM.LT.0.OR.IM.GE.IP) IM=0
66741 IF(IM.NE.0) KFAM=IABS(K(IM,2))
66742 IF(IM.NE.0) THEN
66743 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
66744 IF(K(IL,3).EQ.IM) NM=NM+1
66745 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
66746 360 CONTINUE
66747 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
66748 & MOD(KFAM/1000,10).NE.0) NM=0
66749 IF(NM.EQ.2) THEN
66750 KFAS=IABS(K(ISIS,2))
66751 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
66752 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
66753 ENDIF
66754 ENDIF
66755 ENDIF
66756
66757C...Kinematics of one-particle decays.
66758 IF(ND.EQ.1) THEN
66759 DO 370 J=1,4
66760 P(N+1,J)=P(IP,J)
66761 370 CONTINUE
66762 GOTO 630
66763 ENDIF
66764
66765C...Calculate maximum weight ND-particle decay.
66766 PV(ND,5)=P(N+ND,5)
66767 IF(ND.GE.3) THEN
66768 WTMAX=1D0/WTCOR(ND-2)
66769 PMAX=PV(1,5)-PS+P(N+ND,5)
66770 PMIN=0D0
66771 DO 380 IL=ND-1,1,-1
66772 PMAX=PMAX+P(N+IL,5)
66773 PMIN=PMIN+P(N+IL+1,5)
66774 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
66775 380 CONTINUE
66776 ENDIF
66777
66778C...Find virtual gamma mass in Dalitz decay.
66779 390 IF(ND.EQ.2) THEN
66780 ELSEIF(MMAT.EQ.2) THEN
66781 PMES=4D0*PMAS(11,1)**2
66782 PMRHO2=PMAS(131,1)**2
66783 PGRHO2=PMAS(131,2)**2
66784 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
66785 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
66786 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
66787 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
66788 IF(WT.LT.PYR(0)) GOTO 400
66789 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
66790
66791C...M-generator gives weight. If rejected, try again.
66792 ELSE
66793 410 RORD(1)=1D0
66794 DO 440 IL1=2,ND-1
66795 RSAV=PYR(0)
66796 DO 420 IL2=IL1-1,1,-1
66797 IF(RSAV.LE.RORD(IL2)) GOTO 430
66798 RORD(IL2+1)=RORD(IL2)
66799 420 CONTINUE
66800 430 RORD(IL2+1)=RSAV
66801 440 CONTINUE
66802 RORD(ND)=0D0
66803 WT=1D0
66804 DO 450 IL=ND-1,1,-1
66805 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
66806 & (PV(1,5)-PS)
66807 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66808 450 CONTINUE
66809 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
66810 ENDIF
66811
66812C...Perform two-particle decays in respective CM frame.
66813 460 DO 480 IL=1,ND-1
66814 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66815 UE(3)=2D0*PYR(0)-1D0
66816 PHI=PARU(2)*PYR(0)
66817 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
66818 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
66819 DO 470 J=1,3
66820 P(N+IL,J)=PA*UE(J)
66821 PV(IL+1,J)=-PA*UE(J)
66822 470 CONTINUE
66823 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
66824 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
66825 480 CONTINUE
66826
66827C...Lorentz transform decay products to lab frame.
66828 DO 490 J=1,4
66829 P(N+ND,J)=PV(ND,J)
66830 490 CONTINUE
66831 DO 530 IL=ND-1,1,-1
66832 DO 500 J=1,3
66833 BE(J)=PV(IL,J)/PV(IL,4)
66834 500 CONTINUE
66835 GA=PV(IL,4)/PV(IL,5)
66836 DO 520 I=N+IL,N+ND
66837 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
66838 DO 510 J=1,3
66839 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
66840 510 CONTINUE
66841 P(I,4)=GA*(P(I,4)+BEP)
66842 520 CONTINUE
66843 530 CONTINUE
66844
66845C...Check that no infinite loop in matrix element weight.
66846 NTRY=NTRY+1
66847 IF(NTRY.GT.800) GOTO 560
66848
66849C...Matrix elements for omega and phi decays.
66850 IF(MMAT.EQ.1) THEN
66851 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
66852 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
66853 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
66854 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
66855
66856C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66857 ELSEIF(MMAT.EQ.2) THEN
66858 FOUR12=FOUR(N+1,N+2)
66859 FOUR13=FOUR(N+1,N+3)
66860 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
66861 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
66862 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
66863
66864C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66865C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66866C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66867 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
66868 FOUR10=FOUR(IP,IM)
66869 FOUR12=FOUR(IP,N+1)
66870 FOUR02=FOUR(IM,N+1)
66871 PMS1=P(IP,5)**2
66872 PMS0=P(IM,5)**2
66873 PMS2=P(N+1,5)**2
66874 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
66875 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
66876 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
66877 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
66878 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
66879 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
66880
66881C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66882 ELSEIF(MMAT.EQ.4) THEN
66883 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66884 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
66885 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
66886 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
66887 & ((1D0-HX3)/(HX1*HX2))**2
66888 IF(WT.LT.2D0*PYR(0)) GOTO 390
66889 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
66890 & GOTO 390
66891
66892C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66893 ELSEIF(MMAT.EQ.41) THEN
66894 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66895 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
66896 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
66897 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
66898
66899C...Matrix elements for weak decays (only semileptonic for c and b)
66900 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66901 & .AND.ND.EQ.3) THEN
66902 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
66903 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
66904 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66905 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
66906 DO 550 J=1,4
66907 P(N+NP+1,J)=0D0
66908 DO 540 IS=N+3,N+NP
66909 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
66910 540 CONTINUE
66911 550 CONTINUE
66912 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
66913 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
66914 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66915 ENDIF
66916
66917C...Scale back energy and reattach spectator.
66918 560 IF(MREM.EQ.1) THEN
66919 DO 570 J=1,5
66920 PV(1,J)=PV(1,J)/(1D0-PQT)
66921 570 CONTINUE
66922 ND=ND+1
66923 MREM=0
66924 ENDIF
66925
66926C...Low invariant mass for system with spectator quark gives particle,
66927C...not two jets. Readjust momenta accordingly.
66928 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
66929 MSTJ(93)=1
66930 PM2=PYMASS(K(N+2,2))
66931 MSTJ(93)=1
66932 PM3=PYMASS(K(N+3,2))
66933 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
66934 & (PARJ(32)+PM2+PM3)**2) GOTO 630
66935 K(N+2,1)=1
66936 KFTEMP=K(N+2,2)
66937 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
66938 IF(K(N+2,2).EQ.0) GOTO 260
66939 P(N+2,5)=PYMASS(K(N+2,2))
66940 PS=P(N+1,5)+P(N+2,5)
66941 PV(2,5)=P(N+2,5)
66942 MMAT=0
66943 ND=2
66944 GOTO 460
66945 ELSEIF(MMAT.EQ.44) THEN
66946 MSTJ(93)=1
66947 PM3=PYMASS(K(N+3,2))
66948 MSTJ(93)=1
66949 PM4=PYMASS(K(N+4,2))
66950 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
66951 & (PARJ(32)+PM3+PM4)**2) GOTO 600
66952 K(N+3,1)=1
66953 KFTEMP=K(N+3,2)
66954 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
66955 IF(K(N+3,2).EQ.0) GOTO 260
66956 P(N+3,5)=PYMASS(K(N+3,2))
66957 DO 580 J=1,3
66958 P(N+3,J)=P(N+3,J)+P(N+4,J)
66959 580 CONTINUE
66960 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)
66961 HA=P(N+1,4)**2-P(N+2,4)**2
66962 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
66963 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
66964 & (P(N+1,3)-P(N+2,3))**2
66965 HD=(PV(1,4)-P(N+3,4))**2
66966 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
66967 HF=HD*HC-HB**2
66968 HG=HD*HC-HA*HB
66969 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
66970 DO 590 J=1,3
66971 PCOR=HH*(P(N+1,J)-P(N+2,J))
66972 P(N+1,J)=P(N+1,J)+PCOR
66973 P(N+2,J)=P(N+2,J)-PCOR
66974 590 CONTINUE
66975 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)
66976 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)
66977 ND=ND-1
66978 ENDIF
66979
66980C...Check invariant mass of W jets. May give one particle or start over.
66981 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66982 &.AND.IABS(K(N+1,2)).LT.10) THEN
66983 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
66984 MSTJ(93)=1
66985 PM1=PYMASS(K(N+1,2))
66986 MSTJ(93)=1
66987 PM2=PYMASS(K(N+2,2))
66988 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
66989 KFLDUM=INT(1.5D0+PYR(0))
66990 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
66991 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
66992 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
66993 PSM=PYMASS(KF1)+PYMASS(KF2)
66994 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
66995 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
66996 IF(MMAT.EQ.48) GOTO 390
66997 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
66998 K(N+1,1)=1
66999 KFTEMP=K(N+1,2)
67000 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
67001 IF(K(N+1,2).EQ.0) GOTO 260
67002 P(N+1,5)=PYMASS(K(N+1,2))
67003 K(N+2,2)=K(N+3,2)
67004 P(N+2,5)=P(N+3,5)
67005 PS=P(N+1,5)+P(N+2,5)
67006 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
67007 PV(2,5)=P(N+3,5)
67008 MMAT=0
67009 ND=2
67010 GOTO 460
67011 ENDIF
67012
67013C...Phase space decay of partons from W decay.
67014 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
67015 KFLO(1)=K(N+1,2)
67016 KFLO(2)=K(N+2,2)
67017 K(N+1,1)=K(N+3,1)
67018 K(N+1,2)=K(N+3,2)
67019 DO 620 J=1,5
67020 PV(1,J)=P(N+1,J)+P(N+2,J)
67021 P(N+1,J)=P(N+3,J)
67022 620 CONTINUE
67023 PV(1,5)=PMR
67024 N=N+1
67025 NP=0
67026 NQ=2
67027 PS=0D0
67028 MSTJ(93)=2
67029 PSQ=PYMASS(KFLO(1))
67030 MSTJ(93)=2
67031 PSQ=PSQ+PYMASS(KFLO(2))
67032 MMAT=11
67033 GOTO 290
67034 ENDIF
67035
67036C...Boost back for rapidly moving particle.
67037 630 N=N+ND
67038 IF(MBST.EQ.1) THEN
67039 DO 640 J=1,3
67040 BE(J)=P(IP,J)/P(IP,4)
67041 640 CONTINUE
67042 GA=P(IP,4)/P(IP,5)
67043 DO 660 I=NSAV+1,N
67044 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
67045 DO 650 J=1,3
67046 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
67047 650 CONTINUE
67048 P(I,4)=GA*(P(I,4)+BEP)
67049 660 CONTINUE
67050 ENDIF
67051
67052C...Fill in position of decay vertex.
67053 DO 680 I=NSAV+1,N
67054 DO 670 J=1,4
67055 V(I,J)=VDCY(J)
67056 670 CONTINUE
67057 V(I,5)=0D0
67058 680 CONTINUE
67059
67060C...Set up for parton shower evolution from jets.
67061 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
67062 K(NSAV+1,1)=3
67063 K(NSAV+2,1)=3
67064 K(NSAV+3,1)=3
67065 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67066 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67067 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67068 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67069 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67070 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67071 MSTJ(92)=-(NSAV+1)
67072 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
67073 K(NSAV+2,1)=3
67074 K(NSAV+3,1)=3
67075 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67076 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
67077 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
67078 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67079 MSTJ(92)=NSAV+2
67080 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67081 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
67082 K(NSAV+1,1)=3
67083 K(NSAV+2,1)=3
67084 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67085 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
67086 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
67087 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67088 MSTJ(92)=NSAV+1
67089 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67090 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
67091 MSTJ(92)=NSAV+1
67092 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
67093 & THEN
67094 K(NSAV+1,1)=3
67095 K(NSAV+2,1)=3
67096 K(NSAV+3,1)=3
67097 KCP=PYCOMP(K(NSAV+1,2))
67098 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
67099 JCON=4
67100 IF(KQP.LT.0) JCON=5
67101 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
67102 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
67103 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
67104 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
67105 MSTJ(92)=NSAV+1
67106 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
67107 K(NSAV+1,1)=3
67108 K(NSAV+3,1)=3
67109 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
67110 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67111 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67112 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
67113 MSTJ(92)=NSAV+1
67114 ENDIF
67115
67116C...Mark decayed particle; special option for B-Bbar mixing.
67117 IF(K(IP,1).EQ.5) K(IP,1)=15
67118 IF(K(IP,1).LE.10) K(IP,1)=11
67119 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
67120 K(IP,4)=NSAV+1
67121 K(IP,5)=N
67122
67123 RETURN
67124 END
67125
67126
67127C*********************************************************************
67128
67129C...PYDCYK
67130C...Handles flavour production in the decay of unstable particles
67131C...and small string clusters.
67132
67133 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
67134
67135C...Double precision and integer declarations.
67136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67137 IMPLICIT INTEGER(I-N)
67138 INTEGER PYK,PYCHGE,PYCOMP
67139C...Commonblocks.
67140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67142 SAVE /PYDAT1/,/PYDAT2/
67143
67144
67145C.. Call PYKFDI directly if no popcorn option is on
67146 IF(MSTJ(12).LT.2) THEN
67147 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67148 MSTU(124)=KFL3
67149 RETURN
67150 ENDIF
67151
67152 KFL3=0
67153 KF=0
67154 IF(KFL1.EQ.0) RETURN
67155 KF1A=IABS(KFL1)
67156 KF2A=IABS(KFL2)
67157
67158 NSTO=130
67159 NMAX=MIN(MSTU(125),10)
67160
67161C.. Identify rank 0 cluster qq
67162 IRANK=1
67163 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
67164
67165 IF(KF2A.GT.0)THEN
67166C.. Join jets: Fails if store not empty
67167 IF(MSTU(121).GT.0) THEN
67168 MSTU(121)=0
67169 RETURN
67170 ENDIF
67171 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67172 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
67173C.. Pick popcorn meson from store, return same qq, decrease store
67174 KF=MSTU(NSTO+MSTU(121))
67175 KFL3=-KFL1
67176 MSTU(121)=MSTU(121)-1
67177 ELSE
67178C.. Generate new flavour. Then done if no diquark is generated
67179 100 CALL PYKFDI(KFL1,0,KFL3,KF)
67180 IF(MSTU(121).EQ.-1) GOTO 100
67181 MSTU(124)=KFL3
67182 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
67183
67184C.. Simple case if no dynamical popcorn suppressions are considered
67185 IF(MSTJ(12).LT.4) THEN
67186 IF(MSTU(121).EQ.0) RETURN
67187 NMES=1
67188 KFPREV=-KFL3
67189 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67190C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67191 IF(IABS(KFL3).LE.10)THEN
67192 KFL3=-KFPREV
67193 RETURN
67194 ENDIF
67195 GOTO 120
67196 ENDIF
67197
67198C test output qq against fake Gamma, then return if no popcorn.
67199 GB=2D0
67200 IF(IRANK.NE.0)THEN
67201 CALL PYZDIS(1,2103,5D0,Z)
67202 GB=5D0*(1D0-Z)/Z
67203 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
67204 MSTU(121)=0
67205 GOTO 100
67206 ENDIF
67207 ENDIF
67208 IF(MSTU(121).EQ.0) RETURN
67209
67210C..Set store size memory. Pick fake dynamical variables of qq.
67211 NMES=MSTU(121)
67212 CALL PYPTDI(1,PX3,PY3)
67213 X=1D0
67214 POPM=0D0
67215 G=GB
67216 POPG=GB
67217
67218C.. Pick next popcorn meson, test with fake dynamical variables
67219 110 KFPREV=-KFL3
67220 PX1=-PX3
67221 PY1=-PY3
67222 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67223 IF(MSTU(121).EQ.-1) GOTO 100
67224 CALL PYPTDI(KFL3,PX3,PY3)
67225 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
67226 CALL PYZDIS(KFPREV,KFL3,PM,Z)
67227 G=(1D0-Z)*(G+PM/Z)
67228 X=(1D0-Z)*X
67229
67230 PTST=1D0
67231 GTST=1D0
67232 RTST=PYR(0)
67233 IF(MSTJ(12).GT.4)THEN
67234 POPMN=SQRT((1D0-X)*(G/X-GB))
67235 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
67236 PTST=EXP((POPM-POPMN)*PARF(193))
67237 POPM=POPMN
67238 ENDIF
67239 IF(IRANK.NE.0)THEN
67240 POPGN=X*GB
67241 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
67242 POPG=POPGN
67243 ENDIF
67244 IF(RTST.GT.PTST*GTST)THEN
67245 MSTU(121)=0
67246 IF(RTST.GT.PTST) MSTU(121)=-1
67247 GOTO 100
67248 ENDIF
67249
67250C.. Store meson
67251 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
67252 IF(MSTU(121).GT.0) GOTO 110
67253
67254C.. Test accepted system size. If OK set global popcorn size variable.
67255 IF(NMES.GT.NMAX)THEN
67256 KF=0
67257 KFL3=0
67258 RETURN
67259 ENDIF
67260 MSTU(121)=NMES
67261 ENDIF
67262
67263 RETURN
67264 END
67265
67266C********************************************************************
67267
67268C...PYKFDI
67269C...Generates a new flavour pair and combines off a hadron
67270
67271 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
67272
67273C...Double precision and integer declarations.
67274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67275 IMPLICIT INTEGER(I-N)
67276 INTEGER PYK,PYCHGE,PYCOMP
67277C...Commonblocks.
67278 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67279 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67280 SAVE /PYDAT1/,/PYDAT2/
67281C...Local arrays.
67282 DIMENSION PD(7)
67283
67284 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
67285
67286C...Default flavour values. Input consistency checks.
67287 KF1A=IABS(KFL1)
67288 KF2A=IABS(KFL2)
67289 KFL3=0
67290 KF=0
67291 IF(KF1A.EQ.0) RETURN
67292 IF(KF2A.NE.0)THEN
67293 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
67294 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
67295 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
67296 ENDIF
67297
67298C...Check if tabulated flavour probabilities are to be used.
67299 IF(MSTJ(15).EQ.1) THEN
67300 IF(MSTJ(12).GE.5) CALL PYERRM(29,
67301 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67302 & ' together with MSTJ(12)>=5 modification')
67303 KTAB1=-1
67304 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
67305 KFL1A=MOD(KF1A/1000,10)
67306 KFL1B=MOD(KF1A/100,10)
67307 KFL1S=MOD(KF1A,10)
67308 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
67309 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
67310 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
67311 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
67312 KTAB2=0
67313 IF(KF2A.NE.0) THEN
67314 KTAB2=-1
67315 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
67316 KFL2A=MOD(KF2A/1000,10)
67317 KFL2B=MOD(KF2A/100,10)
67318 KFL2S=MOD(KF2A,10)
67319 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
67320 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
67321 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
67322 ENDIF
67323 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
67324 ENDIF
67325
67326C.. Recognize rank 0 diquark case
67327 100 IRANK=1
67328 KFDIQ=MAX(KF1A,KF2A)
67329 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
67330
67331C.. Join two flavours to meson or baryon. Test for popcorn.
67332 IF(KF2A.GT.0)THEN
67333 MBARY=0
67334 IF(KFDIQ.GT.10) THEN
67335 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
67336 & CALL PYNMES(KFDIQ)
67337 IF(MSTU(121).NE.0) THEN
67338 MSTU(121)=0
67339 RETURN
67340 ENDIF
67341 MBARY=2
67342 ENDIF
67343 KFQOLD=KF1A
67344 KFQVER=KF2A
67345 GOTO 130
67346 ENDIF
67347
67348C.. Separate incoming flavours, curtain flavour consistency check
67349 KFIN=KFL1
67350 KFQOLD=KF1A
67351 KFQPOP=KF1A/10000
67352 IF(KF1A.GT.10)THEN
67353 KFIN=-KFL1
67354 KFL1A=MOD(KF1A/1000,10)
67355 KFL1B=MOD(KF1A/100,10)
67356 IF(IRANK.EQ.0)THEN
67357 QAWT=1D0
67358 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
67359 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
67360 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
67361 ENDIF
67362 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
67363 MSTU(121)=0
67364 RETURN
67365 ENDIF
67366 KFQOLD=KFL1A+KFL1B-KFQPOP
67367 ENDIF
67368
67369C...Meson/baryon choice. Set number of mesons if starting a popcorn
67370C...system.
67371 110 MBARY=0
67372 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
67373 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
67374 MBARY=1
67375 CALL PYNMES(0)
67376 ENDIF
67377 ELSEIF(KF1A.GT.10)THEN
67378 MBARY=2
67379 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
67380 IF(MSTU(121).GT.0) MBARY=-1
67381 ENDIF
67382
67383C..x->H+q: Choose single vertex quark. Jump to form hadron.
67384 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
67385 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
67386 KFL3=ISIGN(KFQVER,-KFIN)
67387 GOTO 130
67388 ENDIF
67389
67390C..x->H+qq: (IDW=proper PARF position for diquark weights)
67391 IDW=160
67392 IF(MBARY.EQ.1)THEN
67393 IF(MSTU(121).EQ.0) IDW=150
67394 SQWT=PARF(IDW+1)
67395 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
67396 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
67397C.. Shift to s-curtain parameters if needed
67398 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
67399 PARF(194)=PARF(138)*PARF(139)
67400 PARF(193)=PARJ(8)+PARJ(9)
67401 ENDIF
67402 ENDIF
67403
67404C.. x->H+qq: Get vertex quark
67405 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67406 IDW=MSTU(122)
67407 MSTU(121)=MSTU(121)-1
67408 IF(IDW.EQ.170) THEN
67409 IF(MSTU(121).EQ.0)THEN
67410 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
67411 ELSE
67412 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
67413 ENDIF
67414 ELSE
67415 IF(MSTU(121).EQ.0)THEN
67416 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
67417 ELSE
67418 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
67419 ENDIF
67420 ENDIF
67421 IPOS=200+30*IPOS+1
67422
67423 IMES=-1
67424 RMES=PYR(0)*PARF(194)
67425 120 IMES=IMES+1
67426 RMES=RMES-PARF(IPOS+IMES)
67427 IF(IMES.EQ.30) THEN
67428 MSTU(121)=-1
67429 KF=-111
67430 RETURN
67431 ENDIF
67432 IF(RMES.GT.0D0) GOTO 120
67433 KMUL=IMES/5
67434 KFJ=2*KMUL+1
67435 IF(KMUL.EQ.2) KFJ=10003
67436 IF(KMUL.EQ.3) KFJ=10001
67437 IF(KMUL.EQ.4) KFJ=20003
67438 IF(KMUL.EQ.5) KFJ=5
67439 IDIAG=0
67440 KFQVER=MOD(IMES,5)+1
67441 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
67442 IF(KFQVER.GT.3)THEN
67443 IDIAG=KFQVER-3
67444 KFQVER=KFQOLD
67445 ENDIF
67446 ELSE
67447 IF(MBARY.EQ.-1) IDW=170
67448 SQWT=PARF(IDW+2)
67449 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
67450 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
67451 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
67452 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
67453 KFQVER=KFQPOP
67454 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
67455 ENDIF
67456 ENDIF
67457
67458C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67459 KFLDS=3
67460 IF(KFQPOP.NE.KFQVER)THEN
67461 SWT=PARF(IDW+7)
67462 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
67463 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
67464 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
67465 ENDIF
67466 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
67467 & +10000*KFQPOP
67468 KFL3=ISIGN(KFDIQ,KFIN)
67469
67470C..x->M+y: flavour for meson.
67471 130 IF(MBARY.LE.0)THEN
67472 KFLA=MAX(KFQOLD,KFQVER)
67473 KFLB=MIN(KFQOLD,KFQVER)
67474 KFS=ISIGN(1,KFL1)
67475 IF(KFLA.NE.KFQOLD) KFS=-KFS
67476C... Form meson, with spin and flavour mixing for diagonal states.
67477 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67478 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
67479 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
67480 RETURN
67481 ENDIF
67482 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
67483 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
67484 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
67485 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
67486 IF(PYR(0).LT.PARJ(14)) KMUL=2
67487 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
67488 RMUL=PYR(0)
67489 IF(RMUL.LT.PARJ(15)) KMUL=3
67490 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
67491 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
67492 ENDIF
67493 KFLS=3
67494 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
67495 IF(KMUL.EQ.5) KFLS=5
67496 IF(KFLA.NE.KFLB)THEN
67497 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
67498 ELSE
67499 RMIX=PYR(0)
67500 IMIX=2*KFLA+10*KMUL
67501 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
67502 & INT(RMIX+PARF(IMIX)))+KFLS
67503 IF(KFLA.GE.4) KF=110*KFLA+KFLS
67504 ENDIF
67505 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
67506 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
67507
67508C..Optional extra suppression of eta and eta'.
67509C..Allow shift to qq->B+q in old version (set IRANK to 0)
67510 IF(KF.EQ.221.OR.KF.EQ.331)THEN
67511 IF(PYR(0).GT.PARJ(25+KF/300))THEN
67512 IF(KF2A.GT.0) GOTO 130
67513 IF(MSTJ(12).LT.4) IRANK=0
67514 GOTO 110
67515 ENDIF
67516 ENDIF
67517 MSTU(121)=0
67518
67519C.. x->B+y: Flavour for baryon
67520 ELSE
67521 KFLA=KFQVER
67522 IF(KF1A.LE.10) KFLA=KFQOLD
67523 KFLB=MOD(KFDIQ/1000,10)
67524 KFLC=MOD(KFDIQ/100,10)
67525 KFLDS=MOD(KFDIQ,10)
67526 KFLD=MAX(KFLA,KFLB,KFLC)
67527 KFLF=MIN(KFLA,KFLB,KFLC)
67528 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67529
67530C... SU(6) factors for formation of baryon.
67531 KBARY=3
67532 KDMAX=5
67533 KFLG=KFLB
67534 IF(KFLB.NE.KFLC)THEN
67535 KBARY=2*KFLDS-1
67536 KDMAX=1+KFLDS/2
67537 IF(KFLB.GT.2) KDMAX=KDMAX+2
67538 ENDIF
67539 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
67540 KBARY=KBARY+1
67541 KFLG=KFLA
67542 ENDIF
67543
67544 SU6MAX=PARF(140+KDMAX)
67545 SU6DEC=PARJ(18)
67546 SU6S =PARF(146)
67547 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
67548 SU6MAX=1D0
67549 SU6DEC=1D0
67550 SU6S =1D0
67551 ENDIF
67552 SU6OCT=PARF(60+KBARY)
67553 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
67554 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
67555 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
67556 ELSE
67557 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
67558 ENDIF
67559 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
67560
67561C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67562 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
67563 MSTU(121)=0
67564 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
67565 GOTO 110
67566 ENDIF
67567
67568C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67569 KSIG=1
67570 KFLS=2
67571 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
67572 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
67573 KSIG=KFLDS/3
67574 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
67575 ENDIF
67576 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
67577 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
67578 ENDIF
67579 RETURN
67580
67581C...Use tabulated probabilities to select new flavour and hadron.
67582 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
67583 KT3L=1
67584 KT3U=6
67585 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
67586 KT3L=1
67587 KT3U=6
67588 ELSEIF(KTAB2.EQ.0) THEN
67589 KT3L=1
67590 KT3U=22
67591 ELSE
67592 KT3L=KTAB2
67593 KT3U=KTAB2
67594 ENDIF
67595 RFL=0D0
67596 DO 160 KTS=0,2
67597 DO 150 KT3=KT3L,KT3U
67598 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
67599 150 CONTINUE
67600 160 CONTINUE
67601 RFL=PYR(0)*RFL
67602 DO 180 KTS=0,2
67603 KTABS=KTS
67604 DO 170 KT3=KT3L,KT3U
67605 KTAB3=KT3
67606 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
67607 IF(RFL.LE.0D0) GOTO 190
67608 170 CONTINUE
67609 180 CONTINUE
67610 190 CONTINUE
67611
67612C...Reconstruct flavour of produced quark/diquark.
67613 IF(KTAB3.LE.6) THEN
67614 KFL3A=KTAB3
67615 KFL3B=0
67616 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
67617 ELSE
67618 KFL3A=1
67619 IF(KTAB3.GE.8) KFL3A=2
67620 IF(KTAB3.GE.11) KFL3A=3
67621 IF(KTAB3.GE.16) KFL3A=4
67622 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
67623 KFL3=1000*KFL3A+100*KFL3B+1
67624 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
67625 & KFL3+2
67626 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
67627 ENDIF
67628
67629C...Reconstruct meson code.
67630 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
67631 &KFL3B.NE.0)) THEN
67632 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67633 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
67634 KF=110+2*KTABS+1
67635 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
67636 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67637 & 25*KTABS)) KF=330+2*KTABS+1
67638 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
67639 KFLA=MAX(KTAB1,KTAB3)
67640 KFLB=MIN(KTAB1,KTAB3)
67641 KFS=ISIGN(1,KFL1)
67642 IF(KFLA.NE.KF1A) KFS=-KFS
67643 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67644 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
67645 KFS=ISIGN(1,KFL1)
67646 IF(KFL1A.EQ.KFL3A) THEN
67647 KFLA=MAX(KFL1B,KFL3B)
67648 KFLB=MIN(KFL1B,KFL3B)
67649 IF(KFLA.NE.KFL1B) KFS=-KFS
67650 ELSEIF(KFL1A.EQ.KFL3B) THEN
67651 KFLA=KFL3A
67652 KFLB=KFL1B
67653 KFS=-KFS
67654 ELSEIF(KFL1B.EQ.KFL3A) THEN
67655 KFLA=KFL1A
67656 KFLB=KFL3B
67657 ELSEIF(KFL1B.EQ.KFL3B) THEN
67658 KFLA=MAX(KFL1A,KFL3A)
67659 KFLB=MIN(KFL1A,KFL3A)
67660 IF(KFLA.NE.KFL1A) KFS=-KFS
67661 ELSE
67662 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
67663 GOTO 100
67664 ENDIF
67665 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67666
67667C...Reconstruct baryon code.
67668 ELSE
67669 IF(KTAB1.GE.7) THEN
67670 KFLA=KFL3A
67671 KFLB=KFL1A
67672 KFLC=KFL1B
67673 ELSE
67674 KFLA=KFL1A
67675 KFLB=KFL3A
67676 KFLC=KFL3B
67677 ENDIF
67678 KFLD=MAX(KFLA,KFLB,KFLC)
67679 KFLF=MIN(KFLA,KFLB,KFLC)
67680 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67681 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
67682 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
67683 ENDIF
67684
67685C...Check that constructed flavour code is an allowed one.
67686 IF(KFL2.NE.0) KFL3=0
67687 KC=PYCOMP(KF)
67688 IF(KC.EQ.0) THEN
67689 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
67690 & 'failed')
67691 GOTO 100
67692 ENDIF
67693
67694 RETURN
67695 END
67696
67697C*********************************************************************
67698
67699C...PYNMES
67700C...Generates number of popcorn mesons and stores some relevant
67701C...parameters.
67702
67703 SUBROUTINE PYNMES(KFDIQ)
67704
67705C...Double precision and integer declarations.
67706 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67707 IMPLICIT INTEGER(I-N)
67708 INTEGER PYK,PYCHGE,PYCOMP
67709C...Commonblocks.
67710 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67711 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67712 SAVE /PYDAT1/,/PYDAT2/
67713
67714 MSTU(121)=0
67715 IF(MSTJ(12).LT.2) RETURN
67716
67717C..Old version: Get 1 or 0 popcorn mesons
67718 IF(MSTJ(12).LT.5)THEN
67719 POPWT=PARF(131)
67720 IF(KFDIQ.NE.0) THEN
67721 KFDIQA=IABS(KFDIQ)
67722 KFA=MOD(KFDIQA/1000,10)
67723 KFB=MOD(KFDIQA/100,10)
67724 KFS=MOD(KFDIQA,10)
67725 POPWT=PARF(132)
67726 IF(KFA.EQ.3) POPWT=PARF(133)
67727 IF(KFB.EQ.3) POPWT=PARF(134)
67728 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
67729 ENDIF
67730 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
67731 RETURN
67732 ENDIF
67733
67734C..New version: Store popcorn- or rank 0 diquark parameters
67735 MSTU(122)=170
67736 PARF(193)=PARJ(8)
67737 PARF(194)=PARF(139)
67738 IF(KFDIQ.NE.0) THEN
67739 MSTU(122)=180
67740 PARF(193)=PARJ(10)
67741 PARF(194)=PARF(140)
67742 ENDIF
67743 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
67744 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
67745 & '(PYNMES:) Neglecting too large popcorn possibility')
67746 RETURN
67747 ENDIF
67748
67749C..New version: Get number of popcorn mesons
67750 100 RTST=PYR(0)
67751 MSTU(121)=-1
67752 110 MSTU(121)=MSTU(121)+1
67753 RTST=RTST/PARF(194)
67754 IF(RTST.LT.1D0) GOTO 110
67755 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
67756 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
67757 RETURN
67758 END
67759
67760C***************************************************************
67761
67762C...PYKFIN
67763C...Precalculates a set of diquark and popcorn weights.
67764
67765 SUBROUTINE PYKFIN
67766
67767C...Double precision and integer declarations.
67768 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67769 IMPLICIT INTEGER(I-N)
67770 INTEGER PYK,PYCHGE,PYCOMP
67771C...Commonblocks.
67772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67774 SAVE /PYDAT1/,/PYDAT2/
67775
67776 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
67777
67778
67779 MSTU(123)=1
67780C..Diquark indices for dimensional variables
67781 IUD1=1
67782 IUU1=2
67783 IUS0=3
67784 ISU0=4
67785 IUS1=5
67786 ISU1=6
67787 ISS1=7
67788
67789C.. *** SU(6) factors **
67790C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67791 PARF(146)=1D0
67792 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
67793 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
67794 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67795 DO 100 I=1,6
67796 SU6(I)=PARF(60+I)
67797 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
67798 100 CONTINUE
67799 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
67800 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
67801 DO 110 I=1,6
67802 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
67803 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
67804 110 CONTINUE
67805
67806C..SU(6)max q q' s,c,b
67807 SU6MUD =MAX(SU6(1) , SU6(8) )
67808 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
67809 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
67810 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
67811 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
67812 SU6M(IUS0)=SU6M(ISU0)
67813 SU6M(ISS1)=SU6M(IUU1)
67814 SU6M(IUS1)=SU6M(ISU1)
67815
67816C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67817 PARF(141)=SU6MUD
67818 PARF(142)=SU6M(IUD1)
67819 PARF(143)=SU6M(ISU0)
67820 PARF(144)=SU6M(ISU1)
67821 PARF(145)=SU6M(ISS1)
67822
67823C..diquark SU(6) survival =
67824C..sum over quark (quark tunnel weight)*(SU(6)).
67825 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
67826 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
67827 DMB(IUS0)=DMB(ISU0)
67828 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
67829 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
67830 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
67831 DMB(IUS1)=DMB(ISU1)
67832 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
67833
67834C.. *** Tunneling factors for Diquark production***
67835C.. T: half a curtain pair = sqrt(curtain pair factor)
67836 IF(MSTJ(12).GE.5) THEN
67837 PMUD0=PYMASS(2101)
67838 PMUD1=PYMASS(2103)-PMUD0
67839 PMUS0=PYMASS(3201)-PMUD0
67840 PMUS1=PYMASS(3203)-PMUS0-PMUD0
67841 PMSS1=PYMASS(3303)-PMUS0-PMUD0
67842 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
67843 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
67844 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
67845 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
67846 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
67847 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
67848 QBB(IUD1)=QBB(IUU1)
67849 ELSE
67850 PAR2M=SQRT(PARJ(2))
67851 PAR3M=SQRT(PARJ(3))
67852 PAR4M=SQRT(PARJ(4))
67853 QBB(ISU0)=PAR2M*PAR3M
67854 QBB(IUS0)=PAR3M
67855 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
67856 QBB(IUU1)=PAR4M
67857 QBB(ISU1)=PAR4M*QBB(ISU0)
67858 QBB(IUS1)=PAR4M*QBB(IUS0)
67859 QBB(IUD1)=PAR4M
67860 ENDIF
67861
67862C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67863 QBM(ISU0)=QBB(ISU0)
67864 QBM(IUS0)=PARJ(2)*QBB(IUS0)
67865 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
67866 QBM(IUU1)=6D0*QBB(IUU1)
67867 QBM(ISU1)=3D0*QBB(ISU1)
67868 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
67869 QBM(IUD1)=3D0*QBB(IUD1)
67870
67871C.. Combine T and tau to diquark weight for q-> B+B+..
67872 DO 120 I=1,7
67873 QBB(I)=QBB(I)*QBM(I)
67874 120 CONTINUE
67875
67876 IF(MSTJ(12).GE.5)THEN
67877C..New version: tau for rank 0 diquark.
67878 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
67879 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
67880 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
67881 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
67882 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
67883 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
67884 DMB(7+IUD1)=DMB(7+IUU1)/2D0
67885
67886C..New version: curtain flavour ratios.
67887C.. s/u for q->B+M+...
67888C.. s/u for rank 0 diquark: su -> ...M+B+...
67889C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67890 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67891 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67892 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
67893 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
67894 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
67895 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
67896 ELSE
67897C..Old version: reset unused rank 0 diquark weights and
67898C.. unused diquark SU(6) survival weights
67899 DO 130 I=1,7
67900 IF(MSTJ(12).LT.3) DMB(I)=1D0
67901 DMB(7+I)=1D0
67902 130 CONTINUE
67903
67904C..Old version: Shuffle PARJ(7) into tau
67905 QBM(IUS0)=QBM(IUS0)*PARJ(7)
67906 QBM(ISS1)=QBM(ISS1)*PARJ(7)
67907 QBM(IUS1)=QBM(IUS1)*PARJ(7)
67908
67909C..Old version: curtain flavour ratios.
67910C.. s/u for q->B+M+...
67911C.. s/u for rank 0 diquark: su -> ...M+B+...
67912C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67913 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67914 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67915 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
67916 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
67917 ENDIF
67918
67919C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67920C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67921 DO 140 I=1,7
67922 DMB(7+I)=DMB(7+I)*DMB(I)
67923 DMB(I)=DMB(I)*QBM(I)
67924 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
67925 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
67926 140 CONTINUE
67927
67928C.. *** Popcorn factors ***
67929
67930 IF(MSTJ(12).LT.5)THEN
67931C.. Old version: Resulting popcorn weights.
67932 PARF(138)=PARJ(6)
67933 WS=PARF(135)*PARF(138)
67934 WQ=WU*PARJ(5)/3D0
67935 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
67936 PARF(133)=WQ*
67937 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
67938 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
67939 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
67940 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
67941 & (1D0+QBB(IUD1)+QBB(IUU1)+
67942 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
67943 ELSE
67944C..New version: Store weights for popcorn mesons,
67945C..get prel. popcorn weights.
67946 DO 150 IPOS=201,1400
67947 PARF(IPOS)=0D0
67948 150 CONTINUE
67949 DO 160 I=138,140
67950 PARF(I)=0D0
67951 160 CONTINUE
67952 IPOS=200
67953 PARF(193)=PARJ(8)
67954 DO 240 MR=0,7,7
67955 IF(MR.EQ.7) PARF(193)=PARJ(10)
67956 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
67957 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67958 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67959 DO 230 NMES=0,1
67960 IF(NMES.EQ.1) SQWT=PARJ(2)
67961 DO 220 KFQPOP=1,4
67962 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
67963 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
67964 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
67965 QQWT=0.5D0
67966 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
67967 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
67968 ENDIF
67969 DO 210 KFQOLD =1,5
67970 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
67971 IF(NMES.EQ.1) THEN
67972 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
67973 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
67974 ENDIF
67975 WTTOT=0D0
67976 WTFAIL=0D0
67977 DO 190 KMUL=0,5
67978 PJWT=PARJ(12+KMUL)
67979 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
67980 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
67981 IF(PJWT.LE.0D0) GOTO 190
67982 IF(PJWT.GT.1D0) PJWT=1D0
67983 IMES=5*KMUL
67984 IMIX=2*KFQOLD+10*KMUL
67985 KFJ=2*KMUL+1
67986 IF(KMUL.EQ.2) KFJ=10003
67987 IF(KMUL.EQ.3) KFJ=10001
67988 IF(KMUL.EQ.4) KFJ=20003
67989 IF(KMUL.EQ.5) KFJ=5
67990 DO 180 KFQVER =1,3
67991 KFLA=MAX(KFQOLD,KFQVER)
67992 KFLB=MIN(KFQOLD,KFQVER)
67993 SWT=PARJ(11+KFLA/3+KFLA/4)
67994 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
67995 SWT=SWT*PJWT
67996 QWT=SQWT/(2D0+SQWT)
67997 IF(KFQVER.LT.3)THEN
67998 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
67999 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
68000 ENDIF
68001 IF(KFQVER.NE.KFQOLD)THEN
68002 IMES=IMES+1
68003 KFM=100*KFLA+10*KFLB+KFJ
68004 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68005 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
68006 WTTOT=WTTOT+PARF(IPOS+IMES)
68007 ELSE
68008 DO 170 ID=3,5
68009 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
68010 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
68011 IF(ID.EQ.5) DWT=PARF(IMIX)
68012 KFM=110*(ID-2)+KFJ
68013 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68014 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
68015 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
68016 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
68017 PARF(IPOS+5*KMUL+ID)=
68018 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
68019 ENDIF
68020 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
68021 170 CONTINUE
68022 ENDIF
68023 180 CONTINUE
68024 190 CONTINUE
68025 DO 200 IMES=1,30
68026 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
68027 200 CONTINUE
68028 IF(MR.EQ.7) PARF(140)=
68029 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
68030 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
68031 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
68032 IPOS=IPOS+30
68033 210 CONTINUE
68034 220 CONTINUE
68035 230 CONTINUE
68036 240 CONTINUE
68037 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
68038 MSTU(121)=0
68039
68040 ENDIF
68041
68042C..Recombine diquark weights to flavour and spin ratios
68043 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
68044 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
68045 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
68046 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
68047 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
68048 PARF(155)=QBB(ISU1)/QBB(ISU0)
68049 PARF(156)=QBB(IUS1)/QBB(IUS0)
68050 PARF(157)=QBB(IUD1)
68051
68052 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
68053 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
68054 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
68055 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
68056 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
68057 PARF(165)=QBM(ISU1)/QBM(ISU0)
68058 PARF(166)=QBM(IUS1)/QBM(IUS0)
68059 PARF(167)=QBM(IUD1)
68060
68061 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
68062 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
68063 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
68064 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
68065 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
68066 PARF(175)=DMB(ISU1)/DMB(ISU0)
68067 PARF(176)=DMB(IUS1)/DMB(IUS0)
68068 PARF(177)=DMB(IUD1)
68069
68070 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
68071 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
68072 PARF(187)=DMB(7+IUD1)
68073
68074 RETURN
68075 END
68076
68077
68078C*********************************************************************
68079
68080C...PYPTDI
68081C...Generates transverse momentum according to a Gaussian.
68082
68083 SUBROUTINE PYPTDI(KFL,PX,PY)
68084
68085C...Double precision and integer declarations.
68086 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68087 IMPLICIT INTEGER(I-N)
68088 INTEGER PYK,PYCHGE,PYCOMP
68089C...Commonblocks.
68090 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68091 SAVE /PYDAT1/
68092
68093C...Generate p_T and azimuthal angle, gives p_x and p_y.
68094 KFLA=IABS(KFL)
68095 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
68096 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
68097 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
68098 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
68099 PHI=PARU(2)*PYR(0)
68100 PX=PT*COS(PHI)
68101 PY=PT*SIN(PHI)
68102
68103 RETURN
68104 END
68105
68106C*********************************************************************
68107
68108C...PYZDIS
68109C...Generates the longitudinal splitting variable z.
68110
68111 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
68112
68113C...Double precision and integer declarations.
68114 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68115 IMPLICIT INTEGER(I-N)
68116 INTEGER PYK,PYCHGE,PYCOMP
68117C...Commonblocks.
68118 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68119 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68120 SAVE /PYDAT1/,/PYDAT2/
68121
68122C...Check if heavy flavour fragmentation.
68123 KFLA=IABS(KFL1)
68124 KFLB=IABS(KFL2)
68125 KFLH=KFLA
68126 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
68127
68128C...Lund symmetric scaling function: determine parameters of shape.
68129 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
68130 &MSTJ(11).GE.4) THEN
68131 FA=PARJ(41)
68132 IF(MSTJ(91).EQ.1) FA=PARJ(43)
68133 IF(KFLB.GE.10) FA=FA+PARJ(45)
68134 FBB=PARJ(42)
68135 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
68136 FB=FBB*PR
68137 FC=1D0
68138 IF(KFLA.GE.10) FC=FC-PARJ(45)
68139 IF(KFLB.GE.10) FC=FC+PARJ(45)
68140 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
68141 FRED=PARJ(46)
68142 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
68143 FC=FC+FRED*FBB*PARF(100+KFLH)**2
68144 ENDIF
68145 MC=1
68146 IF(ABS(FC-1D0).GT.0.01D0) MC=2
68147
68148C...Determine position of maximum. Special cases for a = 0 or a = c.
68149 IF(FA.LT.0.02D0) THEN
68150 MA=1
68151 ZMAX=1D0
68152 IF(FC.GT.FB) ZMAX=FB/FC
68153 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
68154 MA=2
68155 ZMAX=FB/(FB+FC)
68156 ELSE
68157 MA=3
68158 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
68159 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
68160 ENDIF
68161
68162C...Subdivide z range if distribution very peaked near endpoint.
68163 MMAX=2
68164 IF(ZMAX.LT.0.1D0) THEN
68165 MMAX=1
68166 ZDIV=2.75D0*ZMAX
68167 IF(MC.EQ.1) THEN
68168 FINT=1D0-LOG(ZDIV)
68169 ELSE
68170 ZDIVC=ZDIV**(1D0-FC)
68171 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
68172 ENDIF
68173 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
68174 MMAX=3
68175 FSCB=SQRT(4D0+(FC/FB)**2)
68176 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
68177 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
68178 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
68179 FINT=1D0+FB*(1D0-ZDIV)
68180 ENDIF
68181
68182C...Choice of z, preweighted for peaks at low or high z.
68183 100 Z=PYR(0)
68184 FPRE=1D0
68185 IF(MMAX.EQ.1) THEN
68186 IF(FINT*PYR(0).LE.1D0) THEN
68187 Z=ZDIV*Z
68188 ELSEIF(MC.EQ.1) THEN
68189 Z=ZDIV**Z
68190 FPRE=ZDIV/Z
68191 ELSE
68192 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
68193 FPRE=(ZDIV/Z)**FC
68194 ENDIF
68195 ELSEIF(MMAX.EQ.3) THEN
68196 IF(FINT*PYR(0).LE.1D0) THEN
68197 Z=ZDIV+LOG(Z)/FB
68198 FPRE=EXP(FB*(Z-ZDIV))
68199 ELSE
68200 Z=ZDIV+Z*(1D0-ZDIV)
68201 ENDIF
68202 ENDIF
68203
68204C...Weighting according to correct formula.
68205 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
68206 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
68207 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
68208 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
68209 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
68210
68211C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68212 ELSE
68213 FC=PARJ(50+MAX(1,KFLH))
68214 IF(MSTJ(91).EQ.1) FC=PARJ(59)
68215 110 Z=PYR(0)
68216 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
68217 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
68218 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
68219 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
68220 & GOTO 110
68221 ELSE
68222 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
68223 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
68224 ENDIF
68225 ENDIF
68226
68227 RETURN
68228 END
68229
68230C*********************************************************************
68231
68232C...PYSHOW
68233C...Generates timelike parton showers from given partons.
68234
68235 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
68236
68237C...Double precision and integer declarations.
68238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68239 IMPLICIT INTEGER(I-N)
68240 INTEGER PYK,PYCHGE,PYCOMP
68241C...Parameter statement to help give large particle numbers.
68242 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68243 &KEXCIT=4000000,KDIMEN=5000000)
68244 PARAMETER (MAXNUR=1000)
68245C...Commonblocks.
68246 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
68247 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68248 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68249 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68250 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68251 COMMON/PYINT1/MINT(400),VINT(400)
68252 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
68253C...Local arrays.
68254 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
68255 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
68256 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
68257 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
68258 &IREF(1000)
68259
68260C...Check that QMAX not too low.
68261 IF(MSTJ(41).LE.0) THEN
68262 RETURN
68263 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
68264 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
68265 ELSE
68266 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
68267 & RETURN
68268 ENDIF
68269
68270C...Store positions of shower initiating partons.
68271 MPSPD=0
68272 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
68273 NPA=1
68274 IPA(1)=IP1
68275 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
68276 & MSTU(32))) THEN
68277 NPA=2
68278 IPA(1)=IP1
68279 IPA(2)=IP2
68280 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
68281 & .AND.IP2.GE.-80) THEN
68282 NPA=IABS(IP2)
68283 DO 100 I=1,NPA
68284 IPA(I)=IP1+I-1
68285 100 CONTINUE
68286 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
68287 &IP2.EQ.-100) THEN
68288 MPSPD=1
68289 NPA=2
68290 IPA(1)=IP1+6
68291 IPA(2)=IP1+7
68292 ELSE
68293 CALL PYERRM(12,
68294 & '(PYSHOW:) failed to reconstruct showering system')
68295 IF(MSTU(21).GE.1) RETURN
68296 ENDIF
68297
68298C...Send off to PYPTFS for pT-ordered evolution if requested,
68299C...if at least 2 partons, and without predefined shower branchings.
68300 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
68301 &MPSPD.EQ.0) THEN
68302 NPART=NPA
68303 DO 110 II=1,NPART
68304 IPART(II)=IPA(II)
68305 PTPART(II)=0.5D0*QMAX
68306 110 CONTINUE
68307 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
68308 RETURN
68309 ENDIF
68310
68311C...Initialization of cutoff masses etc.
68312 DO 120 IFL=0,40
68313 ISCOL(IFL)=0
68314 ISCHG(IFL)=0
68315 KSH(IFL)=0
68316 120 CONTINUE
68317 ISCOL(21)=1
68318 KSH(21)=1
68319 PMTH(1,21)=PYMASS(21)
68320 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
68321 PMTH(3,21)=2D0*PMTH(2,21)
68322 PMTH(4,21)=PMTH(3,21)
68323 PMTH(5,21)=PMTH(3,21)
68324 PMTH(1,22)=PYMASS(22)
68325 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
68326 PMTH(3,22)=2D0*PMTH(2,22)
68327 PMTH(4,22)=PMTH(3,22)
68328 PMTH(5,22)=PMTH(3,22)
68329 PMQTH1=PARJ(82)
68330 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
68331 PMQT1E=MIN(PMQTH1,PARJ(90))
68332 PMQTH2=PMTH(2,21)
68333 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
68334 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
68335 DO 130 IFL=1,5
68336 ISCOL(IFL)=1
68337 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
68338 KSH(IFL)=1
68339 PMTH(1,IFL)=PYMASS(IFL)
68340 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
68341 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
68342 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68343 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68344 130 CONTINUE
68345 DO 140 IFL=11,15,2
68346 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
68347 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
68348 PMTH(1,IFL)=PYMASS(IFL)
68349 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
68350 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
68351 PMTH(4,IFL)=PMTH(3,IFL)
68352 PMTH(5,IFL)=PMTH(3,IFL)
68353 140 CONTINUE
68354 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
68355 ALAMS=PARJ(81)**2
68356 ALFM=LOG(PT2MIN/ALAMS)
68357
68358C...Check on phase space available for emission.
68359 IREJ=0
68360 DO 150 J=1,5
68361 PS(J)=0D0
68362 150 CONTINUE
68363 PM=0D0
68364 KFLA(2)=0
68365 DO 170 I=1,NPA
68366 KFLA(I)=IABS(K(IPA(I),2))
68367 PMA(I)=P(IPA(I),5)
68368C...Special cutoff masses for initial partons (may be a heavy quark,
68369C...squark, ..., and need not be on the mass shell).
68370 IR=30+I
68371 IF(NPA.LE.1) IREF(I)=IR
68372 IF(NPA.GE.2) IREF(I+1)=IR
68373 ISCOL(IR)=0
68374 ISCHG(IR)=0
68375 KSH(IR)=0
68376 IF(KFLA(I).LE.8) THEN
68377 ISCOL(IR)=1
68378 IF(MSTJ(41).GE.2) ISCHG(IR)=1
68379 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
68380 & KFLA(I).EQ.17) THEN
68381 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
68382 ELSEIF(KFLA(I).EQ.21) THEN
68383 ISCOL(IR)=1
68384 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
68385 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
68386 ISCOL(IR)=1
68387 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
68388 ISCOL(IR)=1
68389C...QUARKONIA+++
68390C...same for QQ~[3S18]
68391 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
68392 & KFLA(I).EQ.9900553)) THEN
68393 ISCOL(IR)=1
68394C...QUARKONIA---
68395 ENDIF
68396
68397C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68398C...(only intended for studying the effects of switching such rad on/off)
68399 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
68400 ISCOL(IR)=0
68401 ISCHG(IR)=0
68402 ENDIF
68403
68404 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
68405 PMTH(1,IR)=PMA(I)
68406 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
68407 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
68408 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
68409 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68410 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68411 ELSEIF(ISCOL(IR).EQ.1) THEN
68412 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
68413 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
68414 PMTH(4,IR)=PMTH(3,IR)
68415 PMTH(5,IR)=PMTH(3,IR)
68416 ELSEIF(ISCHG(IR).EQ.1) THEN
68417 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
68418 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
68419 PMTH(4,IR)=PMTH(3,IR)
68420 PMTH(5,IR)=PMTH(3,IR)
68421 ENDIF
68422 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
68423 PM=PM+PMA(I)
68424 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
68425 DO 160 J=1,4
68426 PS(J)=PS(J)+P(IPA(I),J)
68427 160 CONTINUE
68428 170 CONTINUE
68429 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
68430 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
68431 IF(NPA.EQ.1) PS(5)=PS(4)
68432 IF(PS(5).LE.PM+PMQT1E) RETURN
68433
68434C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68435 KFSRCE=0
68436 IF(IP2.LE.0) THEN
68437 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
68438 KFSRCE=IABS(K(K(IP1,3),2))
68439 ELSE
68440 IPAR1=MAX(1,K(IP1,3))
68441 IPAR2=MAX(1,K(IP2,3))
68442 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
68443 & KFSRCE=IABS(K(K(IPAR1,3),2))
68444 ENDIF
68445 ITYPES=0
68446 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
68447 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
68448 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
68449 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
68450 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
68451 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
68452 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
68453 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
68454
68455C...Identify two primary showerers.
68456 ITYPE1=0
68457 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
68458 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
68459 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
68460 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
68461 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
68462 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
68463 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
68464 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
68465 ITYPE2=0
68466 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
68467 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
68468 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
68469 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
68470 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
68471 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
68472 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
68473 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
68474
68475C...Order of showerers. Presence of gluino.
68476 ITYPMN=MIN(ITYPE1,ITYPE2)
68477 ITYPMX=MAX(ITYPE1,ITYPE2)
68478 IORD=1
68479 IF(ITYPE1.GT.ITYPE2) IORD=2
68480 IGLUI=0
68481 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
68482
68483C...Check if 3-jet matrix elements to be used.
68484 M3JC=0
68485 ALPHA=0.5D0
68486 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
68487 IF(MSTJ(38).NE.0) THEN
68488 M3JC=MSTJ(38)
68489 ALPHA=PARJ(80)
68490 MSTJ(38)=0
68491 ELSEIF(MSTJ(47).GE.6) THEN
68492 M3JC=MSTJ(47)
68493 ELSE
68494 ICLASS=1
68495 ICOMBI=4
68496
68497C...Vector/axial vector -> q + qbar; q -> q + V.
68498 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
68499 & ITYPES.EQ.3)) THEN
68500 ICLASS=2
68501 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
68502 ICOMBI=1
68503 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
68504 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
68505C...gamma*/Z0: assume e+e- initial state if unknown.
68506 EI=-1D0
68507 IF(KFSRCE.EQ.23) THEN
68508 IANNFL=K(K(IP1,3),3)
68509 IF(IANNFL.NE.0) THEN
68510 KANNFL=IABS(K(IANNFL,2))
68511 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
68512 ENDIF
68513 ENDIF
68514 AI=SIGN(1D0,EI+0.1D0)
68515 VI=AI-4D0*EI*PARU(102)
68516 EF=KCHG(KFLA(1),1)/3D0
68517 AF=SIGN(1D0,EF+0.1D0)
68518 VF=AF-4D0*EF*PARU(102)
68519 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
68520 SH=PS(5)**2
68521 SQMZ=PMAS(23,1)**2
68522 SQWZ=PS(5)*PMAS(23,2)
68523 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
68524 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
68525 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
68526 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
68527 ICOMBI=3
68528 ALPHA=VECT/(VECT+AXIV)
68529 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
68530 ICOMBI=4
68531 ENDIF
68532C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68533 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
68534 ICLASS=2
68535 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68536 & ITYPES.EQ.1)) THEN
68537 ICLASS=3
68538
68539C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68540 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
68541 ICLASS=4
68542 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
68543 ICOMBI=1
68544 ELSEIF(KFSRCE.EQ.36) THEN
68545 ICOMBI=2
68546 ENDIF
68547 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68548 & ITYPES.EQ.1)) THEN
68549 ICLASS=5
68550
68551C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68552 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68553 & ITYPES.EQ.3)) THEN
68554 ICLASS=6
68555 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68556 & ITYPES.EQ.2)) THEN
68557 ICLASS=7
68558 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
68559 ICLASS=8
68560 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68561 & ITYPES.EQ.2)) THEN
68562 ICLASS=9
68563
68564C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68565 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68566 & ITYPES.EQ.5)) THEN
68567 ICLASS=10
68568 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68569 & ITYPES.EQ.2)) THEN
68570 ICLASS=11
68571 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68572 & ITYPES.EQ.1)) THEN
68573 ICLASS=12
68574
68575C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68576 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
68577 ICLASS=13
68578 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68579 & ITYPES.EQ.2)) THEN
68580 ICLASS=14
68581 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68582 & ITYPES.EQ.1)) THEN
68583 ICLASS=15
68584
68585C...g -> ~g + ~g (eikonal approximation).
68586 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
68587 ICLASS=16
68588 ENDIF
68589 M3JC=5*ICLASS+ICOMBI
68590 ENDIF
68591 ENDIF
68592
68593C...Find if interference with initial state partons.
68594 MIIS=0
68595 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
68596 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
68597 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
68598 &MIIS=MSTJ(50)-3
68599 IF(MIIS.NE.0) THEN
68600 DO 190 I=1,2
68601 KCII(I)=0
68602 KCA=PYCOMP(KFLA(I))
68603 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
68604 NIIS(I)=0
68605 IF(KCII(I).NE.0) THEN
68606 DO 180 J=1,2
68607 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
68608 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
68609 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
68610 NIIS(I)=NIIS(I)+1
68611 IIIS(I,NIIS(I))=ICSI
68612 ENDIF
68613 180 CONTINUE
68614 ENDIF
68615 190 CONTINUE
68616 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
68617 ENDIF
68618
68619C...Boost interfering initial partons to rest frame
68620C...and reconstruct their polar and azimuthal angles.
68621 IF(MIIS.NE.0) THEN
68622 DO 210 I=1,2
68623 DO 200 J=1,5
68624 K(N+I,J)=K(IPA(I),J)
68625 P(N+I,J)=P(IPA(I),J)
68626 V(N+I,J)=0D0
68627 200 CONTINUE
68628 210 CONTINUE
68629 DO 230 I=3,2+NIIS(1)
68630 DO 220 J=1,5
68631 K(N+I,J)=K(IIIS(1,I-2),J)
68632 P(N+I,J)=P(IIIS(1,I-2),J)
68633 V(N+I,J)=0D0
68634 220 CONTINUE
68635 230 CONTINUE
68636 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68637 DO 240 J=1,5
68638 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
68639 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
68640 V(N+I,J)=0D0
68641 240 CONTINUE
68642 250 CONTINUE
68643 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
68644 & -PS(2)/PS(4),-PS(3)/PS(4))
68645 PHI=PYANGL(P(N+1,1),P(N+1,2))
68646 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
68647 THE=PYANGL(P(N+1,3),P(N+1,1))
68648 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
68649 DO 260 I=3,2+NIIS(1)
68650 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
68651 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
68652 260 CONTINUE
68653 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68654 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
68655 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
68656 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
68657 270 CONTINUE
68658 ENDIF
68659
68660C...Boost 3 or more partons to their rest frame.
68661 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
68662 &-PS(2)/PS(4),-PS(3)/PS(4))
68663
68664C...Define imagined single initiator of shower for parton system.
68665 NS=N
68666 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
68667 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68668 IF(MSTU(21).GE.1) RETURN
68669 ENDIF
68670 280 N=NS
68671 IF(NPA.GE.2) THEN
68672 K(N+1,1)=11
68673 K(N+1,2)=21
68674 K(N+1,3)=0
68675 K(N+1,4)=0
68676 K(N+1,5)=0
68677 P(N+1,1)=0D0
68678 P(N+1,2)=0D0
68679 P(N+1,3)=0D0
68680 P(N+1,4)=PS(5)
68681 P(N+1,5)=PS(5)
68682 V(N+1,5)=PS(5)**2
68683 N=N+1
68684 IREF(1)=21
68685 ENDIF
68686
68687C...Loop over partons that may branch.
68688 NEP=NPA
68689 IM=NS
68690 IF(NPA.EQ.1) IM=NS-1
68691 290 IM=IM+1
68692 IF(N.GT.NS) THEN
68693 IF(IM.GT.N) GOTO 600
68694 KFLM=IABS(K(IM,2))
68695 IR=IREF(IM-NS)
68696 IF(KSH(IR).EQ.0) GOTO 290
68697 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
68698 IGM=K(IM,3)
68699 ELSE
68700 IGM=-1
68701 ENDIF
68702 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
68703 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68704 IF(MSTU(21).GE.1) RETURN
68705 ENDIF
68706
68707C...Position of aunt (sister to branching parton).
68708C...Origin and flavour of daughters.
68709 IAU=0
68710 IF(IGM.GT.0) THEN
68711 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
68712 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
68713 ENDIF
68714 IF(IGM.GE.0) THEN
68715 K(IM,4)=N+1
68716 DO 300 I=1,NEP
68717 K(N+I,3)=IM
68718 300 CONTINUE
68719 ELSE
68720 K(N+1,3)=IPA(1)
68721 ENDIF
68722 IF(IGM.LE.0) THEN
68723 DO 310 I=1,NEP
68724 K(N+I,2)=K(IPA(I),2)
68725 310 CONTINUE
68726 ELSEIF(KFLM.NE.21) THEN
68727 K(N+1,2)=K(IM,2)
68728 K(N+2,2)=K(IM,5)
68729 IREF(N+1-NS)=IREF(IM-NS)
68730 IREF(N+2-NS)=IABS(K(N+2,2))
68731 ELSEIF(K(IM,5).EQ.21) THEN
68732 K(N+1,2)=21
68733 K(N+2,2)=21
68734 IREF(N+1-NS)=21
68735 IREF(N+2-NS)=21
68736 ELSE
68737 K(N+1,2)=K(IM,5)
68738 K(N+2,2)=-K(IM,5)
68739 IREF(N+1-NS)=IABS(K(N+1,2))
68740 IREF(N+2-NS)=IABS(K(N+2,2))
68741 ENDIF
68742
68743C...Reset flags on daughters and tries made.
68744 DO 320 IP=1,NEP
68745 K(N+IP,1)=3
68746 K(N+IP,4)=0
68747 K(N+IP,5)=0
68748 KFLD(IP)=IABS(K(N+IP,2))
68749 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
68750 ITRY(IP)=0
68751 ISL(IP)=0
68752 ISI(IP)=0
68753 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
68754 320 CONTINUE
68755 ISLM=0
68756
68757C...Maximum virtuality of daughters.
68758 IF(IGM.LE.0) THEN
68759 DO 330 I=1,NPA
68760 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
68761 P(N+I,5)=MIN(QMAX,PS(5))
68762 IR=IREF(N+I-NS)
68763 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
68764 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
68765 330 CONTINUE
68766 ELSE
68767 IF(MSTJ(43).LE.2) PEM=V(IM,2)
68768 IF(MSTJ(43).GE.3) PEM=P(IM,4)
68769 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
68770 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
68771 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
68772 ENDIF
68773 DO 340 I=1,NEP
68774 PMSD(I)=P(N+I,5)
68775 IF(ISI(I).EQ.1) THEN
68776 IR=IREF(N+I-NS)
68777 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
68778 ENDIF
68779 V(N+I,5)=P(N+I,5)**2
68780 340 CONTINUE
68781
68782C...Choose one of the daughters for evolution.
68783 350 INUM=0
68784 IF(NEP.EQ.1) INUM=1
68785 DO 360 I=1,NEP
68786 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
68787 360 CONTINUE
68788 DO 370 I=1,NEP
68789 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
68790 IR=IREF(N+I-NS)
68791 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
68792 ENDIF
68793 370 CONTINUE
68794 IF(INUM.EQ.0) THEN
68795 RMAX=0D0
68796 DO 380 I=1,NEP
68797 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
68798 RPM=P(N+I,5)/PMSD(I)
68799 IR=IREF(N+I-NS)
68800 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
68801 RMAX=RPM
68802 INUM=I
68803 ENDIF
68804 ENDIF
68805 380 CONTINUE
68806 ENDIF
68807
68808C...Cancel choice of predetermined daughter already treated.
68809 INUM=MAX(1,INUM)
68810 INUMT=INUM
68811 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
68812 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
68813 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
68814 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
68815 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
68816 ENDIF
68817
68818C...Store information on choice of evolving daughter.
68819 IEP(1)=N+INUM
68820 DO 390 I=2,NEP
68821 IEP(I)=IEP(I-1)+1
68822 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
68823 390 CONTINUE
68824 DO 400 I=1,NEP
68825 KFL(I)=IABS(K(IEP(I),2))
68826 400 CONTINUE
68827 ITRY(INUM)=ITRY(INUM)+1
68828 IF(ITRY(INUM).GT.200) THEN
68829 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
68830 IF(MSTU(21).GE.1) RETURN
68831 ENDIF
68832 Z=0.5D0
68833 IR=IREF(IEP(1)-NS)
68834 IF(KSH(IR).EQ.0) GOTO 450
68835 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
68836
68837C...Check if evolution already predetermined for daughter.
68838 IPSPD=0
68839 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
68840 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
68841 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
68842 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
68843 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
68844 ENDIF
68845 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
68846 ISSET(INUM)=0
68847 IF(IPSPD.NE.0) ISSET(INUM)=1
68848 ENDIF
68849
68850C...Select side for interference with initial state partons.
68851 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
68852 III=IEP(1)-NS-1
68853 ISII(III)=0
68854 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
68855 ISII(III)=1
68856 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
68857 IF(PYR(0).GT.0.5D0) ISII(III)=1
68858 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
68859 ISII(III)=1
68860 IF(PYR(0).GT.0.5D0) ISII(III)=2
68861 ENDIF
68862 ENDIF
68863
68864C...Calculate allowed z range.
68865 IF(NEP.EQ.1) THEN
68866 PMED=PS(4)
68867 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
68868 PMED=P(IM,5)
68869 ELSE
68870 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
68871 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
68872 ENDIF
68873 IF(MOD(MSTJ(43),2).EQ.1) THEN
68874 ZC=PMTH(2,21)/PMED
68875 ZCE=PMTH(2,22)/PMED
68876 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
68877 ELSE
68878 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
68879 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
68880 PMTMPE=PMTH(2,22)
68881 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
68882 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
68883 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
68884 ENDIF
68885 ZC=MIN(ZC,0.491D0)
68886 ZCE=MIN(ZCE,0.49991D0)
68887 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
68888 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
68889 P(IEP(1),5)=PMTH(1,IR)
68890 V(IEP(1),5)=P(IEP(1),5)**2
68891 GOTO 450
68892 ENDIF
68893
68894C...Integral of Altarelli-Parisi z kernel for QCD.
68895C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68896 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
68897 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
68898C...QUARKONIA+++
68899C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68900 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
68901 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
68902 FBR=6D0*LOG((1D0-ZC)/ZC)
68903C...QUARKONIA---
68904 ELSEIF(MSTJ(49).EQ.0) THEN
68905 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
68906 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
68907
68908C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68909 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
68910 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
68911 ELSEIF(MSTJ(49).EQ.1) THEN
68912 FBR=(1D0-2D0*ZC)/3D0
68913 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
68914
68915C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68916 ELSEIF(KFL(1).EQ.21) THEN
68917 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
68918 ELSE
68919 FBR=2D0*LOG((1D0-ZC)/ZC)
68920 ENDIF
68921
68922C...Reset QCD probability for colourless.
68923 IF(ISCOL(IR).EQ.0) FBR=0D0
68924
68925C...Integral of Altarelli-Parisi kernel for photon emission.
68926 FBRE=0D0
68927 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
68928 IF(KFL(1).LE.18) THEN
68929 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
68930 ENDIF
68931 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
68932 ENDIF
68933
68934C...Inner veto algorithm starts. Find maximum mass for evolution.
68935 410 PMS=V(IEP(1),5)
68936 IF(IGM.GE.0) THEN
68937 PM2=0D0
68938 DO 420 I=2,NEP
68939 PM=P(IEP(I),5)
68940 IRI=IREF(IEP(I)-NS)
68941 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
68942 PM2=PM2+PM
68943 420 CONTINUE
68944 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
68945 ENDIF
68946
68947C...Select mass for daughter in QCD evolution.
68948 B0=27D0/6D0
68949 DO 430 IFF=4,MSTJ(45)
68950 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
68951 430 CONTINUE
68952C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68953 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
68954C...Already predetermined choice.
68955 IF(IPSPD.NE.0) THEN
68956 PMSQCD=P(IPSPD,5)**2
68957 ELSEIF(FBR.LT.1D-3) THEN
68958 PMSQCD=0D0
68959 ELSEIF(MSTJ(44).LE.0) THEN
68960 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
68961 ELSEIF(MSTJ(44).EQ.1) THEN
68962 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
68963 ELSE
68964 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
68965 ENDIF
68966C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68967 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
68968 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
68969 V(IEP(1),5)=PMSQCD
68970 MCE=1
68971
68972C...Select mass for daughter in QED evolution.
68973 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
68974C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68975 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
68976 IF(FBRE.LT.1D-3) THEN
68977 PMSQED=0D0
68978 ELSE
68979 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
68980 & (PARU(101)*FBRE)))
68981 ENDIF
68982C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68983 PMSQED=PMSQED+PMTH(1,IR)**2
68984 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
68985 & PMTH(2,IR)**2
68986 IF(PMSQED.GT.PMSQCD) THEN
68987 V(IEP(1),5)=PMSQED
68988 MCE=2
68989 ENDIF
68990 ENDIF
68991
68992C...Check whether daughter mass below cutoff.
68993 P(IEP(1),5)=SQRT(V(IEP(1),5))
68994 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
68995 P(IEP(1),5)=PMTH(1,IR)
68996 V(IEP(1),5)=P(IEP(1),5)**2
68997 GOTO 450
68998 ENDIF
68999
69000C...Already predetermined choice of z, and flavour in g -> qqbar.
69001 IF(IPSPD.NE.0) THEN
69002 IPSGD1=K(IPSPD,4)
69003 IPSGD2=K(IPSPD,5)
69004 PMSGD1=P(IPSGD1,5)**2
69005 PMSGD2=P(IPSGD2,5)**2
69006 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
69007 & 4D0*PMSGD1*PMSGD2))
69008 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
69009 & PMSGD1+PMSGD2)/ALAMPS
69010 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
69011 IF(KFL(1).NE.21) THEN
69012 K(IEP(1),5)=21
69013 ELSE
69014 K(IEP(1),5)=IABS(K(IPSGD1,2))
69015 ENDIF
69016
69017C...Select z value of branching: q -> qgamma.
69018 ELSEIF(MCE.EQ.2) THEN
69019 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
69020 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69021 K(IEP(1),5)=22
69022
69023C...QUARKONIA+++
69024C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
69025 ELSEIF(MSTJ(49).EQ.0.AND.
69026 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
69027 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69028C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
69029 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
69030 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69031 K(IEP(1),5)=21
69032C...QUARKONIA---
69033
69034C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
69035 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
69036 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69037C...Only do z weighting when no ME correction afterwards.
69038 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69039 K(IEP(1),5)=21
69040 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
69041 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69042 IF(PYR(0).GT.0.5D0) Z=1D0-Z
69043 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69044 K(IEP(1),5)=21
69045 ELSEIF(MSTJ(49).NE.1) THEN
69046 Z=PYR(0)
69047 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
69048 KFLB=1+INT(MSTJ(45)*PYR(0))
69049 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69050 IF(PMQ.GE.1D0) GOTO 410
69051 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
69052 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
69053 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
69054 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
69055 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
69056 ELSE
69057 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
69058 ENDIF
69059 K(IEP(1),5)=KFLB
69060
69061C...Ditto for scalar gluon model.
69062 ELSEIF(KFL(1).NE.21) THEN
69063 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
69064 K(IEP(1),5)=21
69065 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
69066 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69067 K(IEP(1),5)=21
69068 ELSE
69069 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69070 KFLB=1+INT(MSTJ(45)*PYR(0))
69071 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69072 IF(PMQ.GE.1D0) GOTO 410
69073 K(IEP(1),5)=KFLB
69074 ENDIF
69075
69076C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
69077 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
69078 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69079 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69080 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
69081 ELSE
69082 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
69083 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
69084 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
69085 IF(PT2APP.LT.PT2MIN) GOTO 410
69086 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
69087 ENDIF
69088 ENDIF
69089
69090C...Check if z consistent with chosen m.
69091 IF(KFL(1).EQ.21) THEN
69092 IRGD1=IABS(K(IEP(1),5))
69093 IRGD2=IRGD1
69094 ELSE
69095 IRGD1=IR
69096 IRGD2=IABS(K(IEP(1),5))
69097 ENDIF
69098 IF(NEP.EQ.1) THEN
69099 PED=PS(4)
69100 ELSEIF(NEP.GE.3) THEN
69101 PED=P(IEP(1),4)
69102 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69103 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
69104 ELSE
69105 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
69106 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
69107 ENDIF
69108 IF(MOD(MSTJ(43),2).EQ.1) THEN
69109 PMQTH3=0.5D0*PARJ(82)
69110 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69111 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
69112 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
69113 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
69114 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69115 & 4D0*PMQ1*PMQ2)))
69116 ZH=1D0+PMQ1-PMQ2
69117 ELSE
69118 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
69119 ZH=1D0
69120 ENDIF
69121 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69122 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69123 ELSEIF(IPSPD.NE.0) THEN
69124 ELSE
69125 ZL=0.5D0*(ZH-ZD)
69126 ZU=0.5D0*(ZH+ZD)
69127 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
69128 ENDIF
69129 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
69130 &(1D0-ZU)))
69131 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69132
69133C...Width suppression for q -> q + g.
69134 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
69135 IF(IGM.EQ.0) THEN
69136 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
69137 ELSE
69138 EGLU=PMED*(1D0-Z)
69139 ENDIF
69140 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
69141 IF(MSTJ(40).EQ.1) THEN
69142 IF(CHI.LT.PYR(0)) GOTO 410
69143 ELSEIF(MSTJ(40).EQ.2) THEN
69144 IF(1D0-CHI.LT.PYR(0)) GOTO 410
69145 ENDIF
69146 ENDIF
69147
69148C...Three-jet matrix element correction.
69149 IF(M3JC.GE.1) THEN
69150 WME=1D0
69151 WSHOW=1D0
69152
69153C...QED matrix elements: only for massless case so far.
69154 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
69155 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69156 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69157 X3=(1D0-X1)+(1D0-X2)
69158 KI1=K(IPA(INUM),2)
69159 KI2=K(IPA(3-INUM),2)
69160 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
69161 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
69162 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
69163 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
69164 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
69165 ELSEIF(MCE.EQ.2) THEN
69166
69167C...QCD matrix elements, including mass effects.
69168 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
69169 PS1ME=V(IEP(1),5)
69170 PM1ME=PMTH(1,IR)
69171 M3JCC=M3JC
69172 IF(IR.GE.31.AND.IGM.EQ.0) THEN
69173C...QCD ME: original parton, first branching.
69174 PM2ME=PMTH(1,63-IR)
69175 ECMME=PS(5)
69176 ELSEIF(IR.GE.31) THEN
69177C...QCD ME: original parton, subsequent branchings.
69178 PM2ME=PMTH(1,63-IR)
69179 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69180 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69181 ELSEIF(K(IM,2).EQ.21) THEN
69182C...QCD ME: secondary partons, first branching.
69183 PM2ME=PM1ME
69184 ZMME=V(IM,1)
69185 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
69186 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
69187 & 4D0*PS1ME*PM2ME**2))
69188 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
69189 & V(IM,5)
69190 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69191 M3JCC=66
69192 ELSE
69193C...QCD ME: secondary partons, subsequent branchings.
69194 PM2ME=PM1ME
69195 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69196 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69197 M3JCC=66
69198 ENDIF
69199C...Construct ME variables.
69200 R1ME=PM1ME/ECMME
69201 R2ME=PM2ME/ECMME
69202 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
69203 X2=1D0+R2ME**2-PS1ME/ECMME**2
69204C...Call ME, with right order important for two inequivalent showerers.
69205 IF(IR.EQ.IORD+30) THEN
69206 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
69207 ELSE
69208 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
69209 ENDIF
69210C...Split up total ME when two radiating partons.
69211 ISPRAD=1
69212 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
69213 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
69214 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
69215 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
69216 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
69217 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
69218 & MAX(1D-10,2D0-X1-X2)
69219C...Evaluate shower rate to be compared with.
69220 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
69221 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
69222 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
69223 ELSEIF(MSTJ(49).NE.1) THEN
69224
69225C...Toy model scalar theory matrix elements; no mass effects.
69226 ELSE
69227 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69228 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69229 X3=(1D0-X1)+(1D0-X2)
69230 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
69231 WME=X3**2
69232 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
69233 & PARJ(171)
69234 ENDIF
69235
69236 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
69237 ENDIF
69238
69239C...Impose angular ordering by rejection of nonordered emission.
69240 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
69241 PEMAO=V(IM,1)*P(IM,4)
69242 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
69243 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
69244 MAOD=0
69245 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
69246 & .OR.MSTJ(42).EQ.7)) THEN
69247 MAOD=0
69248 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
69249 & .OR.MSTJ(42).EQ.6)) THEN
69250 MAOD=1
69251 PMDAO=PMTH(2,K(IEP(1),5))
69252 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
69253 ELSE
69254 MAOD=1
69255 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
69256 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
69257 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
69258 ENDIF
69259 MAOM=1
69260 IAOM=IM
69261 440 IF(K(IAOM,5).EQ.22) THEN
69262 IAOM=K(IAOM,3)
69263 IF(K(IAOM,3).LE.NS) MAOM=0
69264 IF(MAOM.EQ.1) GOTO 440
69265 ENDIF
69266 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
69267 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
69268 IF(THE2ID.LT.THE2IM) GOTO 410
69269 ENDIF
69270 ENDIF
69271
69272C...Impose user-defined maximum angle at first branching.
69273 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
69274 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
69275 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
69276 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69277 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
69278 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69279 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69280 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
69281 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69282 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
69283 ENDIF
69284 ENDIF
69285
69286C...Impose angular constraint in first branching from interference
69287C...with initial state partons.
69288 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
69289 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
69290 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
69291 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
69292 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
69293 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
69294 ENDIF
69295 ENDIF
69296
69297C...End of inner veto algorithm. Check if only one leg evolved so far.
69298 450 V(IEP(1),1)=Z
69299 ISL(1)=0
69300 ISL(2)=0
69301 IF(NEP.EQ.1) GOTO 490
69302 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
69303 DO 460 I=1,NEP
69304 IR=IREF(N+I-NS)
69305 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
69306 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
69307 ENDIF
69308 460 CONTINUE
69309
69310C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69311 IF(NEP.GE.3) THEN
69312 PMSUM=0D0
69313 DO 470 I=1,NEP
69314 PMSUM=PMSUM+P(N+I,5)
69315 470 CONTINUE
69316 IF(PMSUM.GE.PS(5)) GOTO 350
69317 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
69318 DO 480 I1=N+1,N+2
69319 IRDA=IREF(I1-NS)
69320 IF(KSH(IRDA).EQ.0) GOTO 480
69321 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
69322 IF(IRDA.EQ.21) THEN
69323 IRGD1=IABS(K(I1,5))
69324 IRGD2=IRGD1
69325 ELSE
69326 IRGD1=IRDA
69327 IRGD2=IABS(K(I1,5))
69328 ENDIF
69329 I2=2*N+3-I1
69330 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69331 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
69332 ELSE
69333 IF(I1.EQ.N+1) ZM=V(IM,1)
69334 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
69335 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
69336 & 4D0*V(N+1,5)*V(N+2,5))
69337 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
69338 & V(IM,5)
69339 ENDIF
69340 IF(MOD(MSTJ(43),2).EQ.1) THEN
69341 PMQTH3=0.5D0*PARJ(82)
69342 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69343 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
69344 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
69345 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
69346 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69347 & 4D0*PMQ1*PMQ2)))
69348 ZH=1D0+PMQ1-PMQ2
69349 ELSE
69350 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
69351 ZH=1D0
69352 ENDIF
69353 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
69354 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69355 ELSE
69356 ZL=0.5D0*(ZH-ZD)
69357 ZU=0.5D0*(ZH+ZD)
69358 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69359 & ISSET(1).EQ.0) THEN
69360 ISL(1)=1
69361 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69362 & ISSET(2).EQ.0) THEN
69363 ISL(2)=1
69364 ENDIF
69365 ENDIF
69366 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
69367 & ZL*(1D0-ZU)))
69368 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69369 480 CONTINUE
69370 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
69371 ISL(3-ISLM)=0
69372 ISLM=3-ISLM
69373 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
69374 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
69375 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
69376 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
69377 IF(ISL(1).EQ.1) ISL(2)=0
69378 IF(ISL(1).EQ.0) ISLM=1
69379 IF(ISL(2).EQ.0) ISLM=2
69380 ENDIF
69381 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
69382 ENDIF
69383 IRD1=IREF(N+1-NS)
69384 IRD2=IREF(N+2-NS)
69385 IF(IGM.GT.0) THEN
69386 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
69387 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
69388 PMQ1=V(N+1,5)/V(IM,5)
69389 PMQ2=V(N+2,5)/V(IM,5)
69390 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
69391 & 4D0*PMQ1*PMQ2)))
69392 ZH=1D0+PMQ1-PMQ2
69393 ZL=0.5D0*(ZH-ZD)
69394 ZU=0.5D0*(ZH+ZD)
69395 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
69396 ENDIF
69397 ENDIF
69398
69399C...Accepted branch. Construct four-momentum for initial partons.
69400 490 MAZIP=0
69401 MAZIC=0
69402 IF(NEP.EQ.1) THEN
69403 P(N+1,1)=0D0
69404 P(N+1,2)=0D0
69405 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
69406 & P(N+1,5))))
69407 P(N+1,4)=P(IPA(1),4)
69408 V(N+1,2)=P(N+1,4)
69409 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
69410 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
69411 P(N+1,1)=0D0
69412 P(N+1,2)=0D0
69413 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
69414 P(N+1,4)=PED1
69415 P(N+2,1)=0D0
69416 P(N+2,2)=0D0
69417 P(N+2,3)=-P(N+1,3)
69418 P(N+2,4)=P(IM,5)-PED1
69419 V(N+1,2)=P(N+1,4)
69420 V(N+2,2)=P(N+2,4)
69421 ELSEIF(NEP.GE.3) THEN
69422C...Rescale all momenta for energy conservation.
69423 LOOP=0
69424 PES=0D0
69425 PQS=0D0
69426 DO 510 I=1,NEP
69427 DO 500 J=1,4
69428 P(N+I,J)=P(IPA(I),J)
69429 500 CONTINUE
69430 PES=PES+P(N+I,4)
69431 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69432 510 CONTINUE
69433 520 LOOP=LOOP+1
69434 FAC=(PS(5)-PQS)/(PES-PQS)
69435 PES=0D0
69436 PQS=0D0
69437 DO 540 I=1,NEP
69438 DO 530 J=1,3
69439 P(N+I,J)=FAC*P(N+I,J)
69440 530 CONTINUE
69441 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)
69442 V(N+I,2)=P(N+I,4)
69443 PES=PES+P(N+I,4)
69444 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69445 540 CONTINUE
69446 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
69447
69448C...Construct transverse momentum for ordinary branching in shower.
69449 ELSE
69450 ZM=V(IM,1)
69451 LOOPPT=0
69452 550 LOOPPT=LOOPPT+1
69453 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
69454 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
69455 IF(PZM.LE.0D0) THEN
69456 PTS=0D0
69457 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69458 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69459 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
69460 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69461 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
69462 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
69463 ELSE
69464 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
69465 ENDIF
69466 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
69467 ZM=0.05D0+0.9D0*ZM
69468 GOTO 550
69469 ELSEIF(PTS.LT.0D0) THEN
69470 GOTO 280
69471 ENDIF
69472 PT=SQRT(MAX(0D0,PTS))
69473
69474C...Global statistics.
69475 MINT(353)=MINT(353)+1
69476 VINT(353)=VINT(353)+PT
69477 IF (MINT(353).EQ.1) VINT(358)=PT
69478
69479C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69480 HAZIP=0D0
69481 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
69482 & .AND.IAU.NE.0) THEN
69483 IF(K(IGM,3).NE.0) MAZIP=1
69484 ZAU=V(IGM,1)
69485 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
69486 IF(MAZIP.EQ.0) ZAU=0D0
69487 IF(K(IGM,2).NE.21) THEN
69488 HAZIP=2D0*ZAU/(1D0+ZAU**2)
69489 ELSE
69490 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
69491 ENDIF
69492 IF(K(N+1,2).NE.21) THEN
69493 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
69494 ELSE
69495 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
69496 ENDIF
69497 ENDIF
69498
69499C...Find coefficient of azimuthal asymmetry due to soft gluon
69500C...interference.
69501 HAZIC=0D0
69502 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
69503 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
69504 IF(K(IGM,3).NE.0) MAZIC=N+1
69505 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
69506 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69507 & ZM.GT.0.5D0) MAZIC=N+2
69508 IF(K(IAU,2).EQ.22) MAZIC=0
69509 ZS=ZM
69510 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
69511 ZGM=V(IGM,1)
69512 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
69513 IF(MAZIC.EQ.0) ZGM=1D0
69514 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
69515 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
69516 HAZIC=MIN(0.95D0,HAZIC)
69517 ENDIF
69518 ENDIF
69519
69520C...Construct energies for ordinary branching in shower.
69521 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
69522 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69523 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69524 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69525 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69526 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69527 P(N+1,4)=PEM*V(IM,1)
69528 ELSE
69529 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
69530 & SQRT(PMLS)*ZM)/V(IM,5)
69531 ENDIF
69532
69533C...Already predetermined choice of phi angle or not
69534 PHI=PARU(2)*PYR(0)
69535 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
69536 IPSPD=IP1+IM-NS-2
69537 IF(K(IPSPD,4).GT.0) THEN
69538 IPSGD1=K(IPSPD,4)
69539 IF(IM.EQ.NS+2) THEN
69540 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69541 ELSE
69542 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
69543 ENDIF
69544 ENDIF
69545 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
69546 IPSPD=IP1+IM-NS-2
69547 IF(K(IPSPD,4).GT.0) THEN
69548 IPSGD1=K(IPSPD,4)
69549 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
69550 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
69551 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
69552 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
69553 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69554 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
69555 ENDIF
69556 ENDIF
69557
69558C...Construct momenta for ordinary branching in shower.
69559 P(N+1,1)=PT*COS(PHI)
69560 P(N+1,2)=PT*SIN(PHI)
69561 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69562 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69563 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69564 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69565 ELSEIF(PZM.GT.0D0) THEN
69566 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
69567 & 2D0*PEM*P(N+1,4))/PZM
69568 ELSE
69569 P(N+1,3)=0D0
69570 ENDIF
69571 P(N+2,1)=-P(N+1,1)
69572 P(N+2,2)=-P(N+1,2)
69573 P(N+2,3)=PZM-P(N+1,3)
69574 P(N+2,4)=PEM-P(N+1,4)
69575 IF(MSTJ(43).LE.2) THEN
69576 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
69577 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
69578 ENDIF
69579 ENDIF
69580
69581C...Rotate and boost daughters.
69582 IF(IGM.GT.0) THEN
69583 IF(MSTJ(43).LE.2) THEN
69584 BEX=P(IGM,1)/P(IGM,4)
69585 BEY=P(IGM,2)/P(IGM,4)
69586 BEZ=P(IGM,3)/P(IGM,4)
69587 GA=P(IGM,4)/P(IGM,5)
69588 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
69589 & P(IM,4))
69590 ELSE
69591 BEX=0D0
69592 BEY=0D0
69593 BEZ=0D0
69594 GA=1D0
69595 GABEP=0D0
69596 ENDIF
69597 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
69598 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
69599 IF(PTIMB.GT.1D-4) THEN
69600 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
69601 ELSE
69602 PHI=0D0
69603 ENDIF
69604 DO 570 I=N+1,N+2
69605 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
69606 & SIN(THE)*COS(PHI)*P(I,3)
69607 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
69608 & SIN(THE)*SIN(PHI)*P(I,3)
69609 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
69610 DP(4)=P(I,4)
69611 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
69612 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
69613 P(I,1)=DP(1)+DGABP*BEX
69614 P(I,2)=DP(2)+DGABP*BEY
69615 P(I,3)=DP(3)+DGABP*BEZ
69616 P(I,4)=GA*(DP(4)+DBP)
69617 570 CONTINUE
69618 ENDIF
69619
69620C...Weight with azimuthal distribution, if required.
69621 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
69622 DO 580 J=1,3
69623 DPT(1,J)=P(IM,J)
69624 DPT(2,J)=P(IAU,J)
69625 DPT(3,J)=P(N+1,J)
69626 580 CONTINUE
69627 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
69628 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
69629 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
69630 DO 590 J=1,3
69631 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
69632 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
69633 590 CONTINUE
69634 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
69635 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
69636 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
69637 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
69638 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
69639 IF(MAZIP.NE.0) THEN
69640 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
69641 & GOTO 560
69642 ENDIF
69643 IF(MAZIC.NE.0) THEN
69644 IF(MAZIC.EQ.N+2) CAD=-CAD
69645 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
69646 & .LT.PYR(0)) GOTO 560
69647 ENDIF
69648 ENDIF
69649 ENDIF
69650
69651C...Azimuthal anisotropy due to interference with initial state partons.
69652 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
69653 &K(N+2,2).EQ.21)) THEN
69654 III=IM-NS-1
69655 IF(ISII(III).GE.1) THEN
69656 IAZIID=N+1
69657 IF(K(N+1,2).NE.21) IAZIID=N+2
69658 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69659 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
69660 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
69661 IF(III.EQ.2) THEIID=PARU(1)-THEIID
69662 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
69663 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
69664 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
69665 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
69666 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
69667 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
69668 & .LT.PYR(0)) GOTO 560
69669 ENDIF
69670 ENDIF
69671
69672C...Continue loop over partons that may branch, until none left.
69673 IF(IGM.GE.0) K(IM,1)=14
69674 N=N+NEP
69675 NEP=2
69676 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
69677 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
69678 IF(MSTU(21).GE.1) N=NS
69679 IF(MSTU(21).GE.1) RETURN
69680 ENDIF
69681 GOTO 290
69682
69683C...Set information on imagined shower initiator.
69684 600 IF(NPA.GE.2) THEN
69685 K(NS+1,1)=11
69686 K(NS+1,2)=94
69687 K(NS+1,3)=IP1
69688 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
69689 K(NS+1,4)=NS+2
69690 K(NS+1,5)=NS+1+NPA
69691 IIM=1
69692 ELSE
69693 IIM=0
69694 ENDIF
69695
69696C...Reconstruct string drawing information.
69697 DO 610 I=NS+1+IIM,N
69698 KQ=KCHG(PYCOMP(K(I,2)),2)
69699 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
69700 K(I,1)=1
69701 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
69702 & IABS(K(I,2)).LE.18) THEN
69703 K(I,1)=1
69704 ELSEIF(K(I,1).LE.10) THEN
69705 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
69706 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
69707 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
69708 ID1=MOD(K(I,4),MSTU(5))
69709 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
69710 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
69711 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
69712 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
69713 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69714 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
69715 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69716 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
69717 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
69718 K(ID2,5)=K(ID2,5)+MSTU(5)*I
69719 ELSE
69720 ID1=MOD(K(I,4),MSTU(5))
69721 ID2=ID1+1
69722 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69723 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
69724 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
69725 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69726 K(ID1,5)=K(ID1,5)+MSTU(5)*I
69727 ELSE
69728 K(ID1,4)=0
69729 K(ID1,5)=0
69730 ENDIF
69731 K(ID2,4)=0
69732 K(ID2,5)=0
69733 ENDIF
69734 610 CONTINUE
69735
69736C...Transformation from CM frame.
69737 IF(NPA.EQ.1) THEN
69738 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
69739 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
69740 MSTU(33)=1
69741 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
69742 ELSEIF(NPA.EQ.2) THEN
69743 BEX=PS(1)/PS(4)
69744 BEY=PS(2)/PS(4)
69745 BEZ=PS(3)/PS(4)
69746 GA=PS(4)/PS(5)
69747 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
69748 & /(1D0+GA)-P(IPA(1),4))
69749 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
69750 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
69751 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
69752 MSTU(33)=1
69753 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
69754 ELSE
69755 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
69756 & PS(3)/PS(4))
69757 MSTU(33)=1
69758 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
69759 ENDIF
69760
69761C...Decay vertex of shower.
69762 DO 630 I=NS+1,N
69763 DO 620 J=1,5
69764 V(I,J)=V(IP1,J)
69765 620 CONTINUE
69766 630 CONTINUE
69767
69768C...Delete trivial shower, else connect initiators.
69769 IF(N.LE.NS+NPA+IIM) THEN
69770 N=NS
69771 ELSE
69772 DO 640 IP=1,NPA
69773 K(IPA(IP),1)=14
69774 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
69775 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
69776 K(NS+IIM+IP,3)=IPA(IP)
69777 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
69778 IF(K(NS+IIM+IP,1).NE.1) THEN
69779 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
69780 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
69781 ENDIF
69782 640 CONTINUE
69783 ENDIF
69784
69785 RETURN
69786 END
69787
69788C*********************************************************************
69789
69790C...PYPTFS
69791C...Generates pT-ordered timelike final-state parton showers.
69792
69793C...MODE defines how to find radiators and recoilers.
69794C... = 0 : based on colour flow between undecayed partons.
69795C... = 1 : for IPART <= NPARTD only consider primary partons,
69796C... whether decayed or not; else as above.
69797C... = 2 : based on common history, whether decayed or not.
69798C... = 3 : use (or create) MCT color information to shower partons
69799
69800 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
69801
69802C...Double precision and integer declarations.
69803 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69804 IMPLICIT INTEGER(I-N)
69805 INTEGER PYK,PYCHGE,PYCOMP
69806C...Parameter statement to help give large particle numbers.
69807 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69808 &KEXCIT=4000000,KDIMEN=5000000)
69809C...Parameter statement for maximum size of showers.
69810 PARAMETER (MAXNUR=1000)
69811C...Commonblocks.
69812 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69813 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69814 COMMON/PYCTAG/NCT,MCT(4000,2)
69815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69816 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69817 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69818 COMMON/PYINT1/MINT(400),VINT(400)
69819 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
69820 &/PYINT1/
69821C...Local arrays.
69822 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
69823 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
69824 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
69825 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
69826C...Statement functions.
69827 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
69828 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
69829
69830C...Initial values. Check that valid system.
69831 PTGEN=0D0
69832 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
69833 &MSTJ(41).NE.12) RETURN
69834 IF(NPART.LE.0) THEN
69835 CALL PYERRM(2,'(PYPTFS:) showering system too small')
69836 RETURN
69837 ENDIF
69838 PT2CMX=PTMAX**2
69839 IORD=1
69840
69841C...Mass thresholds and Lambda for QCD evolution.
69842 PMB=PMAS(5,1)
69843 PMC=PMAS(4,1)
69844 ALAM5=PARJ(81)
69845 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
69846 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
69847 PMBS=PMB**2
69848 PMCS=PMC**2
69849 ALAM5S=ALAM5**2
69850 ALAM4S=ALAM4**2
69851 ALAM3S=ALAM3**2
69852
69853C...Cutoff scale for QCD evolution. Starting pT2.
69854 NFLAV=MAX(0,MIN(5,MSTJ(45)))
69855 PT0C=0.5D0*PARJ(82)
69856 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
69857
69858C...Parameters for QED evolution.
69859 AEM2PI=PARU(101)/PARU(2)
69860 PT0EQ=0.5D0*PARJ(83)
69861 PT0EL=0.5D0*PARJ(90)
69862
69863C...Reset. Remove irrelevant colour tags.
69864 NEVOL=0
69865 DO 100 J=1,4
69866 PSUM(J)=0D0
69867 100 CONTINUE
69868 DO 110 I=MINT(84)+1,N
69869 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
69870 K(I,5)=0
69871 MCT(I,2)=0
69872 ENDIF
69873 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
69874 K(I,4)=0
69875 MCT(I,1)=0
69876 ENDIF
69877 110 CONTINUE
69878 NPARTS=NPART
69879
69880C...Begin loop to set up showering partons. Sum four-momenta.
69881 DO 230 IP=1,NPART
69882 I=IPART(IP)
69883 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
69884 IF(K(I,1).GT.10) GOTO 230
69885 ELSEIF(K(I,3).GT.MINT(84)) THEN
69886 IF(K(I,3).GT.MINT(84)+2) GOTO 230
69887 ELSE
69888 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
69889 ENDIF
69890 DO 120 J=1,4
69891 PSUM(J)=PSUM(J)+P(I,J)
69892 120 CONTINUE
69893
69894C...Find colour and charge, but skip diquarks.
69895 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
69896 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
69897 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
69898
69899C...QUARKONIA++
69900 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
69901 IF (MSTP(148).GE.1) THEN
69902C...Temporary: force no radiation from quarkonia since not yet treated
69903 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
69904 & //' PYPTFS, switched off')
69905 CALL PYGIVE('MSTP(148)=0')
69906 ENDIF
69907 IF (MSTP(148).EQ.0) THEN
69908C...Skip quarkonia if radiation switched off
69909 GOTO 230
69910 ENDIF
69911 ENDIF
69912C...QUARKONIA--
69913
69914C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69915C...(only intended for studying the effects of switching such rad on/off)
69916 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
69917 GOTO 230
69918 ENDIF
69919
69920C...Either colour or anticolour charge radiates; for gluon both.
69921 DO 180 JSGCOL=1,-1,-2
69922 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
69923 JCOL=4+(1-JSGCOL)/2
69924 JCOLR=9-JCOL
69925
69926C...Basic info about radiating parton.
69927 NEVOL=NEVOL+1
69928 IPOS(NEVOL)=I
69929 IFLG(NEVOL)=0
69930 ISCOL(NEVOL)=JSGCOL
69931 ISCHG(NEVOL)=0
69932 PTSCA(NEVOL)=PTPART(IP)
69933
69934C...Begin search for colour recoiler when MODE = 0 or 1.
69935 IF(MODE.LE.1) THEN
69936C...Find sister with matching anticolour to the radiating parton.
69937 IROLD=I
69938 IRNEW=K(IROLD,JCOL)/MSTU(5)
69939 MOVE=1
69940
69941C...Skip radiation off loose colour ends.
69942 130 IF(IRNEW.EQ.0) THEN
69943 NEVOL=NEVOL-1
69944 GOTO 180
69945
69946C...Optionally skip radiation on dipole to beam remnant.
69947 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
69948 NEVOL=NEVOL-1
69949 GOTO 180
69950
69951C...For now always skip radiation on dipole to junction.
69952 ELSEIF(K(IRNEW,2).EQ.88) THEN
69953 NEVOL=NEVOL-1
69954 GOTO 180
69955
69956C...For MODE=1: if reached primary then done.
69957 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
69958 & IRNEW.LE.NPARTD) THEN
69959
69960C...If sister stable and points back then done.
69961 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69962 & THEN
69963 IF(K(IRNEW,1).LT.10) THEN
69964
69965C...If sister unstable then go to her daughter.
69966 ELSE
69967 IROLD=IRNEW
69968 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69969 MOVE=2
69970 GOTO 130
69971 ENDIF
69972
69973C...If found mother then look for aunt.
69974 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69975 & IROLD) THEN
69976 IROLD=IRNEW
69977 IRNEW=K(IROLD,JCOL)/MSTU(5)
69978 GOTO 130
69979
69980C...If daughter stable then done.
69981 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69982 & THEN
69983 IF(K(IRNEW,1).LT.10) THEN
69984
69985C...If daughter unstable then go to granddaughter.
69986 ELSE
69987 IROLD=IRNEW
69988 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69989 MOVE=2
69990 GOTO 130
69991 ENDIF
69992
69993C...If daughter points to another daughter then done or move up.
69994 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69995 & IROLD) THEN
69996 IF(K(IRNEW,1).LT.10) THEN
69997 ELSE
69998 IROLD=IRNEW
69999 IRNEW=K(IRNEW,JCOL)/MSTU(5)
70000 MOVE=1
70001 GOTO 130
70002 ENDIF
70003 ENDIF
70004
70005C...Begin search for colour recoiler when MODE = 2.
70006 ELSEIF (MODE.EQ.2) THEN
70007 IROLD=I
70008 IRNEW=K(IROLD,JCOL)/MSTU(5)
70009 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
70010C...If no color partner found, pick at random among other primaries
70011C...(e.g., when the color line is traced all the way to the beam)
70012 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70013 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70014 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
70015C...Step up to mother if radiating parton already branched.
70016 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
70017 IROLD=IRNEW
70018 IRNEW=K(IROLD,JCOL)/MSTU(5)
70019 GOTO 140
70020C...Pick sister by history if no anticolour available.
70021 ELSE
70022 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70023 IRNEW=IROLD-1
70024 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
70025 & THEN
70026 IRNEW=IROLD+1
70027C...Last resort: pick at random among other primaries.
70028 ELSE
70029 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70030 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70031 ENDIF
70032 ENDIF
70033 ENDIF
70034C...Trace down if sister branched.
70035 150 IF(K(IRNEW,1).GT.10) THEN
70036 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70037C...If no correct color-daughter found, swap.
70038 IF (IRTMP.EQ.0) THEN
70039 JCOL=9-JCOL
70040 JCOLR=9-JCOLR
70041 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70042 ENDIF
70043 IRNEW=IRTMP
70044 GOTO 150
70045 ENDIF
70046 ELSEIF (MODE.EQ.3) THEN
70047C...The following will add MCT colour tracing for unprepped events
70048C...If not done, trace Les Houches colour tags for this dipole
70049 JCOLSV=JCOL
70050 IF (MCT(I,JCOL-3).EQ.0) THEN
70051C...Special end code -1 : trace to color partner or 0, return in IEND
70052 IEND=-1
70053 CALL PYCTTR(I,JCOL,IEND)
70054C...Clean up mother/daughter 'read' tags set by PYCTTR
70055 JCOL=JCOLSV
70056 DO 160 IR=1,N
70057 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
70058 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
70059 MCT(IR,1)=0
70060 MCT(IR,2)=0
70061 160 CONTINUE
70062 ELSE
70063 IEND=0
70064 DO 170 IR=1,N
70065 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
70066 & IEND=IR
70067 170 CONTINUE
70068 ENDIF
70069C...If no color partner, then we hit beam
70070 IF (IEND.LE.0) THEN
70071C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
70072 IF (MSTP(72).LE.1) THEN
70073 NEVOL=NEVOL-1
70074 GOTO 180
70075 ELSE
70076C...Else try a random partner
70077 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70078 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70079 ENDIF
70080 ELSE
70081C...Else save recoiling colour partner
70082 IRNEW=IEND
70083 ENDIF
70084
70085 ENDIF
70086
70087C...Now found other end of colour dipole.
70088 IREC(NEVOL)=IRNEW
70089 ENDIF
70090 180 CONTINUE
70091
70092C...Also electrical charge may radiate; so far only quarks and leptons.
70093 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
70094 & IABS(K(I,2)).LE.18) THEN
70095
70096C...Basic info about radiating parton.
70097 NEVOL=NEVOL+1
70098 IPOS(NEVOL)=I
70099 IFLG(NEVOL)=0
70100 ISCOL(NEVOL)=0
70101 ISCHG(NEVOL)=KCHA
70102 PTSCA(NEVOL)=PTPART(IP)
70103
70104C...Pick nearest (= smallest invariant mass) charged particle
70105C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
70106 IF(MODE.LE.1) THEN
70107 IRNEW=0
70108 PM2MIN=VINT(2)
70109 DO 190 IP2=1,NPART+N-MINT(53)
70110 IF(IP2.EQ.IP) GOTO 190
70111 IF(IP2.LE.NPART) THEN
70112 I2=IPART(IP2)
70113 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
70114 IF(K(I2,1).GT.10) GOTO 190
70115 ELSEIF(K(I2,3).GT.MINT(84)) THEN
70116 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
70117 ELSE
70118 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
70119 ENDIF
70120 ELSE
70121 I2=MINT(53)+IP2-NPART
70122 ENDIF
70123 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
70124 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
70125 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
70126 IF(PM2INV.LT.PM2MIN) THEN
70127 IRNEW=I2
70128 PM2MIN=PM2INV
70129 ENDIF
70130 190 CONTINUE
70131 IF(IRNEW.EQ.0) THEN
70132 NEVOL=NEVOL-1
70133 GOTO 230
70134 ENDIF
70135
70136C...Begin search for charge recoiler when MODE = 2.
70137 ELSE
70138 IROLD=I
70139C...Pick sister by history; step up if parton already branched.
70140 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
70141 IROLD=K(IROLD,3)
70142 GOTO 200
70143 ENDIF
70144 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70145 IRNEW=IROLD-1
70146 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
70147 IRNEW=IROLD+1
70148C...Last resort: pick at random among other primaries.
70149 ELSE
70150 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70151 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70152 ENDIF
70153C...Trace down if sister branched.
70154 210 IF(K(IRNEW,1).GT.10) THEN
70155 DO 220 IR=IRNEW+1,N
70156 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
70157 IRNEW=IR
70158 GOTO 210
70159 ENDIF
70160 220 CONTINUE
70161 ENDIF
70162 ENDIF
70163 IREC(NEVOL)=IRNEW
70164 ENDIF
70165
70166C...End loop to set up showering partons. System invariant mass.
70167 230 CONTINUE
70168 IF(NEVOL.LE.0) RETURN
70169 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
70170 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70171
70172C...Check if 3-jet matrix elements to be used.
70173 M3JC=0
70174 ALPHA=0.5D0
70175 NMESYS=0
70176 IF(MSTJ(47).GE.1) THEN
70177
70178C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70179 KFSRCE=0
70180 IPART1=K(IPART(1),3)
70181 IPART2=K(IPART(2),3)
70182 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
70183 KFSRCE=IABS(K(IPART1,2))
70184 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
70185 IPART1=K(IPART1,3)
70186 GOTO 240
70187 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
70188 IPART2=K(IPART2,3)
70189 GOTO 240
70190 ENDIF
70191 ITYPES=0
70192 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70193 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70194 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70195 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70196 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70197 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70198 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70199 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70200
70201C...Identify two primary showerers.
70202 KFLA1=IABS(K(IPART(1),2))
70203 ITYPE1=0
70204 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
70205 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
70206 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
70207 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
70208 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
70209 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
70210 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
70211 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
70212 KFLA2=IABS(K(IPART(2),2))
70213 ITYPE2=0
70214 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
70215 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
70216 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
70217 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
70218 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
70219 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
70220 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
70221 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
70222
70223C...Order of showerers. Presence of gluino.
70224 ITYPMN=MIN(ITYPE1,ITYPE2)
70225 ITYPMX=MAX(ITYPE1,ITYPE2)
70226 IORD=1
70227 IF(ITYPE1.GT.ITYPE2) IORD=2
70228 IGLUI=0
70229 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70230
70231C...Require exactly two primary showerers for ME corrections.
70232 NPRIM=0
70233 IF(IPART1.GT.0) THEN
70234 DO 250 I=1,N
70235 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
70236 250 CONTINUE
70237 ENDIF
70238 IF(NPRIM.NE.2) THEN
70239
70240C...Predetermined and default matrix element kinds.
70241 ELSEIF(MSTJ(38).NE.0) THEN
70242 M3JC=MSTJ(38)
70243 ALPHA=PARJ(80)
70244 MSTJ(38)=0
70245 ELSEIF(MSTJ(47).GE.6) THEN
70246 M3JC=MSTJ(47)
70247 ELSE
70248 ICLASS=1
70249 ICOMBI=4
70250
70251C...Vector/axial vector -> q + qbar; q -> q + V.
70252 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70253 & ITYPES.EQ.3)) THEN
70254 ICLASS=2
70255 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70256 ICOMBI=1
70257 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70258 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
70259C...gamma*/Z0: assume e+e- initial state if unknown.
70260 EI=-1D0
70261 IF(KFSRCE.EQ.23) THEN
70262 IANNFL=IPART1
70263 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70264 IF(IANNFL.GT.0) THEN
70265 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70266 ENDIF
70267 IF(IANNFL.NE.0) THEN
70268 KANNFL=IABS(K(IANNFL,2))
70269 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70270 ENDIF
70271 ENDIF
70272 AI=SIGN(1D0,EI+0.1D0)
70273 VI=AI-4D0*EI*PARU(102)
70274 EF=KCHG(KFLA1,1)/3D0
70275 AF=SIGN(1D0,EF+0.1D0)
70276 VF=AF-4D0*EF*PARU(102)
70277 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70278 SH=PSUM(5)**2
70279 SQMZ=PMAS(23,1)**2
70280 SQWZ=PSUM(5)*PMAS(23,2)
70281 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70282 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70283 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70284 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70285 ICOMBI=3
70286 ALPHA=VECT/(VECT+AXIV)
70287 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70288 ICOMBI=4
70289 ENDIF
70290C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70291 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70292 ICLASS=2
70293 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70294 & ITYPES.EQ.1)) THEN
70295 ICLASS=3
70296
70297C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70298 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70299 ICLASS=4
70300 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70301 ICOMBI=1
70302 ELSEIF(KFSRCE.EQ.36) THEN
70303 ICOMBI=2
70304 ENDIF
70305 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70306 & ITYPES.EQ.1)) THEN
70307 ICLASS=5
70308
70309C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70310 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70311 & ITYPES.EQ.3)) THEN
70312 ICLASS=6
70313 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70314 & ITYPES.EQ.2)) THEN
70315 ICLASS=7
70316 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70317 ICLASS=8
70318 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70319 & ITYPES.EQ.2)) THEN
70320 ICLASS=9
70321
70322C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70323 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70324 & ITYPES.EQ.5)) THEN
70325 ICLASS=10
70326 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70327 & ITYPES.EQ.2)) THEN
70328 ICLASS=11
70329 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70330 & ITYPES.EQ.1)) THEN
70331 ICLASS=12
70332
70333C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70334 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70335 ICLASS=13
70336 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70337 & ITYPES.EQ.2)) THEN
70338 ICLASS=14
70339 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70340 & ITYPES.EQ.1)) THEN
70341 ICLASS=15
70342
70343C...g -> ~g + ~g (eikonal approximation).
70344 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70345 ICLASS=16
70346 ENDIF
70347 M3JC=5*ICLASS+ICOMBI
70348 ENDIF
70349
70350C...Store pair that together define matrix element treatment.
70351 IF(M3JC.NE.0) THEN
70352 NMESYS=1
70353 MESYS(NMESYS,0)=M3JC
70354 MESYS(NMESYS,1)=IPART(1)
70355 MESYS(NMESYS,2)=IPART(2)
70356 ENDIF
70357
70358C...Store qqbar or l+l- pairs for QED radiation.
70359 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
70360 NMESYS=NMESYS+1
70361 MESYS(NMESYS,0)=101
70362 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
70363 MESYS(NMESYS,1)=IPART(1)
70364 MESYS(NMESYS,2)=IPART(2)
70365 ENDIF
70366
70367C...Store other qqbar/l+l- pairs from g/gamma branchings.
70368 DO 290 I1=1,N
70369 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
70370 I1M=K(I1,3)
70371 260 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
70372 I1M=K(I1M,3)
70373 GOTO 260
70374 ENDIF
70375C...Move up this check to avoid out-of-bounds.
70376 IF(I1M.EQ.0) GOTO 290
70377 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
70378 DO 280 I2=I1+1,N
70379 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
70380 I2M=K(I2,3)
70381 270 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
70382 I2M=K(I2M,3)
70383 GOTO 270
70384 ENDIF
70385 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
70386 NMESYS=NMESYS+1
70387 MESYS(NMESYS,0)=66
70388 MESYS(NMESYS,1)=I1
70389 MESYS(NMESYS,2)=I2
70390 NMESYS=NMESYS+1
70391 MESYS(NMESYS,0)=102
70392 MESYS(NMESYS,1)=I1
70393 MESYS(NMESYS,2)=I2
70394 ENDIF
70395 280 CONTINUE
70396 290 CONTINUE
70397 ENDIF
70398
70399C..Loopback point for counting number of emissions.
70400 NGEN=0
70401 300 NGEN=NGEN+1
70402
70403C...Begin loop to evolve all existing partons, if required.
70404 310 IMX=0
70405 PT2MX=0D0
70406 DO 380 IEVOL=1,NEVOL
70407 IF(IFLG(IEVOL).EQ.0) THEN
70408
70409C...Basic info on radiator and recoil.
70410 I=IPOS(IEVOL)
70411 IR=IREC(IEVOL)
70412 SHT=SHAT(I,IR)
70413 PM2I=P(I,5)**2
70414 PM2R=P(IR,5)**2
70415
70416C...Invariant mass of "dipole".Starting value for pT evolution.
70417 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
70418 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
70419
70420C...Case of evolution by QCD branching.
70421 IF(ISCOL(IEVOL).NE.0) THEN
70422
70423C...Parton-by-parton maximum scale from initial conditions.
70424 IF(MSTP(72).EQ.0) THEN
70425 DO 320 IPRT=1,NPARTS
70426 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
70427 320 CONTINUE
70428 ENDIF
70429
70430C...If kinematically impossible then do not evolve.
70431 IF(PT2.LT.PT2CMN) THEN
70432 IFLG(IEVOL)=-1
70433 GOTO 380
70434 ENDIF
70435
70436C...Check if part of system for which ME corrections should be applied.
70437 IMESYS=0
70438 DO 330 IME=1,NMESYS
70439 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70440 & MESYS(IME,0).LT.100) IMESYS=IME
70441 330 CONTINUE
70442
70443C...Special flag for colour octet states.
70444C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70445 MOCT=0
70446 IF(K(I,2).EQ.21) MOCT=1
70447C...SUSY gluino
70448 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70449C...UED KK gluon
70450 IF(K(I,2).EQ.5100021) MOCT=2
70451C...QUARKONIA++
70452 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
70453 & IABS(K(I,2)).LE.9910555) MOCT=2
70454C...QUARKONIA--
70455
70456
70457C...Upper estimate for matrix element weighting and colour factor.
70458C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70459 WTPSGL=2D0
70460 COLFAC=4D0/3D0
70461 IF(MOCT.GE.1) COLFAC=3D0/2D0
70462 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
70463 WTPSQQ=0.5D0*0.5D0*NFLAV
70464
70465C...Determine overestimated z range: switch at c and b masses.
70466 340 IZRG=1
70467 PT2MNE=PT2CMN
70468 B0=27D0/6D0
70469 ALAMS=ALAM3S
70470 IF(PT2.GT.1.01D0*PMCS) THEN
70471 IZRG=2
70472 PT2MNE=PMCS
70473 B0=25D0/6D0
70474 ALAMS=ALAM4S
70475 ENDIF
70476 IF(PT2.GT.1.01D0*PMBS) THEN
70477 IZRG=3
70478 PT2MNE=PMBS
70479 B0=23D0/6D0
70480 ALAMS=ALAM5S
70481 ENDIF
70482 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
70483 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
70484
70485C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70486 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
70487 EVCOEF=EVEMGL
70488 IF(MOCT.EQ.1) THEN
70489 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
70490 EVCOEF=EVCOEF+EVEMQQ
70491 ENDIF
70492
70493C...Pick pT2 (in overestimated z range).
70494 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
70495
70496C...Loopback if crossed c/b mass thresholds.
70497 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
70498 PT2=PMBS
70499 GOTO 340
70500 ENDIF
70501 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
70502 PT2=PMCS
70503 GOTO 340
70504 ENDIF
70505
70506C...Finish if below lower cutoff.
70507 IF(PT2.LT.PT2CMN) THEN
70508 IFLG(IEVOL)=-1
70509 GOTO 380
70510 ENDIF
70511
70512C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70513C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70514 IFLAG=1
70515 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
70516
70517C...Pick z: dz/(1-z) or dz.
70518 IF(IFLAG.EQ.1) THEN
70519 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70520 ELSE
70521 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
70522 ENDIF
70523
70524C...Loopback if outside allowed range for given pT2.
70525 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70526 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70527 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
70528 PM2=PM2I+PT2/(Z*(1D0-Z))
70529 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
70530
70531C...No weighting for primary partons; to be done later on.
70532 IF(IMESYS.GT.0) THEN
70533
70534C...Weighting of q->qg/X->Xg branching.
70535 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
70536 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
70537
70538C...Weighting of g->gg branching.
70539 ELSEIF(IFLAG.EQ.1) THEN
70540 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
70541
70542C...Flavour choice and weighting of g->qqbar branching.
70543 ELSE
70544 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
70545 PMQ=PMAS(KFQ,1)
70546 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70547 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
70548 IF(WTME.LT.PYR(0)) GOTO 350
70549 IFLAG=10+KFQ
70550 ENDIF
70551
70552C...Case of evolution by QED branching.
70553 ELSEIF(ISCHG(IEVOL).NE.0) THEN
70554
70555C...If kinematically impossible then do not evolve.
70556 PT2EMN=PT0EQ**2
70557 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
70558 IF(PT2.LT.PT2EMN) THEN
70559 IFLG(IEVOL)=-1
70560 GOTO 380
70561 ENDIF
70562
70563C...Check if part of system for which ME corrections should be applied.
70564 IMESYS=0
70565 DO 360 IME=1,NMESYS
70566 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70567 & MESYS(IME,0).GT.100) IMESYS=IME
70568 360 CONTINUE
70569
70570C...Charge. Matrix element weighting factor.
70571 CHG=ISCHG(IEVOL)/3D0
70572 WTPSGA=2D0
70573
70574C...Determine overestimated z range. Find evolution coefficient.
70575 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
70576 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
70577 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
70578
70579C...Pick pT2 (in overestimated z range).
70580 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
70581
70582C...Finish if below lower cutoff.
70583 IF(PT2.LT.PT2EMN) THEN
70584 IFLG(IEVOL)=-1
70585 GOTO 380
70586 ENDIF
70587
70588C...Pick z: dz/(1-z).
70589 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70590
70591C...Loopback if outside allowed range for given pT2.
70592 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70593 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70594 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
70595 PM2=PM2I+PT2/(Z*(1D0-Z))
70596 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
70597
70598C...Weighting by branching kernel, except if ME weighting later.
70599 IF(IMESYS.EQ.0) THEN
70600 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
70601 ENDIF
70602 IFLAG=3
70603 ENDIF
70604
70605C...Save acceptable branching.
70606 IFLG(IEVOL)=IFLAG
70607 IMESAV(IEVOL)=IMESYS
70608 PT2SAV(IEVOL)=PT2
70609 ZSAV(IEVOL)=Z
70610 SHTSAV(IEVOL)=SHT
70611 ENDIF
70612
70613C...Check if branching has highest pT.
70614 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
70615 IMX=IEVOL
70616 PT2MX=PT2SAV(IEVOL)
70617 ENDIF
70618 380 CONTINUE
70619
70620C...Finished if no more branchings to be done.
70621 IF(IMX.EQ.0) GOTO 500
70622
70623C...Restore info on hardest branching to be processed.
70624 I=IPOS(IMX)
70625 IR=IREC(IMX)
70626 KCOL=ISCOL(IMX)
70627 KCHA=ISCHG(IMX)
70628 IMESYS=IMESAV(IMX)
70629 PT2=PT2SAV(IMX)
70630 Z=ZSAV(IMX)
70631 SHT=SHTSAV(IMX)
70632 PM2I=P(I,5)**2
70633 PM2R=P(IR,5)**2
70634 PM2=PM2I+PT2/(Z*(1D0-Z))
70635
70636C...Special flag for colour octet states.
70637 MOCT=0
70638 IF(K(I,2).EQ.21) MOCT=1
70639 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70640 IF(K(I,2).EQ.5100021) MOCT=2
70641C...QUARKONIA++
70642 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
70643 & IABS(K(I,2)).LE.9910555) MOCT=2
70644C...QUARKONIA--
70645
70646C...Restore further info for g->qqbar branching.
70647 KFQ=0
70648 IF(IFLG(IMX).GT.10) THEN
70649 KFQ=IFLG(IMX)-10
70650 PMQ=PMAS(KFQ,1)
70651 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70652 ENDIF
70653
70654C...For branching g include azimuthal asymmetries from polarization.
70655 ASYPOL=0D0
70656 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
70657C...Trace grandmother via intermediate recoil copies.
70658 KFGM=0
70659 IM=I
70660 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
70661 & K(IM,3).GT.0) THEN
70662 IM=K(IM,3)
70663 IF(IM.GT.MINT(84)) GOTO 390
70664 ENDIF
70665 IGM=K(IM,3)
70666 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
70667 & KFGM=IABS(K(IGM,2))
70668C...Define approximate energy sharing by identifying aunt.
70669 IAU=IM+1
70670 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
70671 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
70672 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
70673C...Coefficient from gluon production.
70674 IF(KFGM.LE.6) THEN
70675 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
70676 ELSE
70677 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
70678 ENDIF
70679C...Coefficient from gluon decay.
70680 IF(KFQ.EQ.0) THEN
70681 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
70682 ELSE
70683 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
70684 ENDIF
70685 ENDIF
70686 ENDIF
70687
70688C...Create new slots for branching products and recoil.
70689 INEW=N+1
70690 IGNEW=N+2
70691 IRNEW=N+3
70692 N=N+3
70693
70694C...Set status, flavour and mother of new ones.
70695 K(INEW,1)=K(I,1)
70696 K(IGNEW,1)=3
70697 IF(KCHA.NE.0) K(IGNEW,1)=1
70698 K(IRNEW,1)=K(IR,1)
70699 IF(KFQ.EQ.0) THEN
70700 K(INEW,2)=K(I,2)
70701 K(IGNEW,2)=21
70702 IF(KCHA.NE.0) K(IGNEW,2)=22
70703 ELSE
70704 K(INEW,2)=-ISIGN(KFQ,KCOL)
70705 K(IGNEW,2)=-K(INEW,2)
70706 ENDIF
70707 K(IRNEW,2)=K(IR,2)
70708 K(INEW,3)=I
70709 K(IGNEW,3)=I
70710 K(IRNEW,3)=IR
70711
70712C...Find rest frame and angles of branching+recoil.
70713 DO 400 J=1,5
70714 P(INEW,J)=P(I,J)
70715 P(IGNEW,J)=0D0
70716 P(IRNEW,J)=P(IR,J)
70717 400 CONTINUE
70718 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
70719 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
70720 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
70721 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
70722 PHI=PYANGL(P(INEW,1),P(INEW,2))
70723 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
70724
70725C...Derive kinematics of branching: generics (like g->gg).
70726 DO 410 J=1,4
70727 P(INEW,J)=0D0
70728 P(IRNEW,J)=0D0
70729 410 CONTINUE
70730 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
70731 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
70732 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
70733 PTCOR=SQRT(MAX(0D0,PT2COR))
70734 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
70735 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
70736C...Specific kinematics reduction for q->qg with m_q > 0.
70737 IF(MOCT.NE.1) THEN
70738 PTCOR=(1D0-PM2I/PM2)*PTCOR
70739 PZN=PZN+PM2I*PZG/PM2
70740 PZG=(1D0-PM2I/PM2)*PZG
70741C...Specific kinematics reduction for g->qqbar with m_q > 0.
70742 ELSEIF(KFQ.NE.0) THEN
70743 P(INEW,5)=PMQ
70744 P(IGNEW,5)=PMQ
70745 PTCOR=ROOTQQ*PTCOR
70746 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
70747 PZG=PZM-PZN
70748 ENDIF
70749
70750C...Pick phi and construct kinematics of branching.
70751 420 PHIROT=PARU(2)*PYR(0)
70752 P(INEW,1)=PTCOR*COS(PHIROT)
70753 P(INEW,2)=PTCOR*SIN(PHIROT)
70754 P(INEW,3)=PZN
70755 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
70756 P(IGNEW,1)=-P(INEW,1)
70757 P(IGNEW,2)=-P(INEW,2)
70758 P(IGNEW,3)=PZG
70759 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
70760 P(IRNEW,1)=0D0
70761 P(IRNEW,2)=0D0
70762 P(IRNEW,3)=-PZM
70763 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
70764
70765C...Boost branching system to lab frame.
70766 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
70767
70768C...Renew choice of phi angle according to polarization asymmetry.
70769 IF(ABS(ASYPOL).GT.1D-3) THEN
70770 DO 430 J=1,3
70771 DPT(1,J)=P(I,J)
70772 DPT(2,J)=P(IAU,J)
70773 DPT(3,J)=P(INEW,J)
70774 430 CONTINUE
70775 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
70776 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
70777 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
70778 DO 440 J=1,3
70779 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
70780 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
70781 440 CONTINUE
70782 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
70783 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
70784 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
70785 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
70786 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
70787 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
70788 & GOTO 420
70789 ENDIF
70790 ENDIF
70791
70792C...Matrix element corrections for primary partons when requested.
70793 IF(IMESYS.GT.0) THEN
70794 M3JC=MESYS(IMESYS,0)
70795
70796C...Identify recoiling partner and set up three-body kinematics.
70797 IRP=MESYS(IMESYS,1)
70798 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
70799 IF(IRP.EQ.IR) IRP=IRNEW
70800 DO 450 J=1,4
70801 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
70802 450 CONTINUE
70803 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
70804 & PSUM(3)**2))
70805 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
70806 & PSUM(3)*P(INEW,3))/PSUM(5)**2
70807 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
70808 & PSUM(3)*P(IRP,3))/PSUM(5)**2
70809 X3=2D0-X1-X2
70810 R1ME=P(INEW,5)/PSUM(5)
70811 R2ME=P(IRP,5)/PSUM(5)
70812
70813C...Matrix elements for gluon emission.
70814 IF(M3JC.LT.100) THEN
70815
70816C...Call ME, with right order important for two inequivalent showerers.
70817 IF(MESYS(IMESYS,IORD).EQ.I) THEN
70818 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
70819 ELSE
70820 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
70821 ENDIF
70822
70823C...Split up total ME when two radiating partons.
70824 ISPRAD=1
70825 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
70826 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
70827 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
70828 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70829 & MAX(1D-10,2D0-X1-X2)
70830
70831C...Evaluate shower rate.
70832 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70833 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70834 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
70835
70836C...Matrix elements for photon emission: still rather primitive.
70837 ELSE
70838
70839C...For generic charge combination currently only massless expression.
70840 IF(M3JC.EQ.101) THEN
70841 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
70842 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
70843 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70844 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
70845
70846C...For flavour neutral system assume vector source and include masses.
70847 ELSE
70848 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
70849 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
70850 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70851 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70852 ENDIF
70853 ENDIF
70854
70855C...Perform weighting with W_ME/W_PS.
70856 IF(WME.LT.PYR(0)*WPS) THEN
70857 N=N-3
70858 IFLG(IMX)=0
70859 PT2CMX=PT2
70860 GOTO 310
70861 ENDIF
70862 ENDIF
70863
70864C...Now for sure accepted branching. Save highest pT.
70865 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
70866
70867C...Update status for obsolete ones. Bookkkep the moved original parton
70868C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70869C...Do not bookkeep radiated photon, since it cannot radiate further.
70870 K(I,1)=K(I,1)+10
70871 K(IR,1)=K(IR,1)+10
70872 DO 460 IP=1,NPART
70873 IF(IPART(IP).EQ.I) IPART(IP)=INEW
70874 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
70875 460 CONTINUE
70876 IF(KCHA.EQ.0) THEN
70877 NPART=NPART+1
70878 IPART(NPART)=IGNEW
70879 ENDIF
70880
70881C...Initialize colour flow of branching.
70882C...Use both old and new style colour tags for flexibility.
70883 K(INEW,4)=0
70884 K(IGNEW,4)=0
70885 K(INEW,5)=0
70886 K(IGNEW,5)=0
70887 JCOLP=4+(1-KCOL)/2
70888 JCOLN=9-JCOLP
70889 MCT(INEW,1)=0
70890 MCT(INEW,2)=0
70891 MCT(IGNEW,1)=0
70892 MCT(IGNEW,2)=0
70893 MCT(IRNEW,1)=0
70894 MCT(IRNEW,2)=0
70895
70896C...Trivial colour flow for l->lgamma and q->qgamma.
70897 IF(IABS(KCHA).EQ.3) THEN
70898 K(I,4)=INEW
70899 K(I,5)=IGNEW
70900 ELSEIF(KCHA.NE.0) THEN
70901 IF(K(I,4).NE.0) THEN
70902 K(I,4)=K(I,4)+INEW
70903 K(INEW,4)=MSTU(5)*I
70904 MCT(INEW,1)=MCT(I,1)
70905 ENDIF
70906 IF(K(I,5).NE.0) THEN
70907 K(I,5)=K(I,5)+INEW
70908 K(INEW,5)=MSTU(5)*I
70909 MCT(INEW,2)=MCT(I,2)
70910 ENDIF
70911
70912C...Set colour flow for q->qg and g->gg.
70913 ELSEIF(KFQ.EQ.0) THEN
70914 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70915 K(IGNEW,JCOLP)=MSTU(5)*I
70916 K(INEW,JCOLP)=MSTU(5)*IGNEW
70917 K(IGNEW,JCOLN)=MSTU(5)*INEW
70918 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70919 NCT=NCT+1
70920 MCT(INEW,JCOLP-3)=NCT
70921 MCT(IGNEW,JCOLN-3)=NCT
70922 IF(MOCT.GE.1) THEN
70923 K(I,JCOLN)=K(I,JCOLN)+INEW
70924 K(INEW,JCOLN)=MSTU(5)*I
70925 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70926 ENDIF
70927
70928C...Set colour flow for g->qqbar.
70929 ELSE
70930 K(I,JCOLN)=K(I,JCOLN)+INEW
70931 K(INEW,JCOLN)=MSTU(5)*I
70932 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70933 K(IGNEW,JCOLP)=MSTU(5)*I
70934 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70935 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70936 ENDIF
70937
70938C...Daughter info for colourless recoiling parton.
70939 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
70940 K(IR,4)=IRNEW
70941 K(IR,5)=IRNEW
70942 K(IRNEW,4)=0
70943 K(IRNEW,5)=0
70944
70945C...Colour of recoiling parton sails through unchanged.
70946 ELSE
70947 IF(K(IR,4).NE.0) THEN
70948 K(IR,4)=K(IR,4)+IRNEW
70949 K(IRNEW,4)=MSTU(5)*IR
70950 MCT(IRNEW,1)=MCT(IR,1)
70951 ENDIF
70952 IF(K(IR,5).NE.0) THEN
70953 K(IR,5)=K(IR,5)+IRNEW
70954 K(IRNEW,5)=MSTU(5)*IR
70955 MCT(IRNEW,2)=MCT(IR,2)
70956 ENDIF
70957 ENDIF
70958
70959C...Vertex information trivial.
70960 DO 470 J=1,5
70961 V(INEW,J)=V(I,J)
70962 V(IGNEW,J)=V(I,J)
70963 V(IRNEW,J)=V(IR,J)
70964 470 CONTINUE
70965
70966C...Update list of old radiators.
70967 DO 480 IEVOL=1,NEVOL
70968 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
70969 IPOS(IEVOL)=INEW
70970 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
70971 IREC(IEVOL)=IRNEW
70972 IFLG(IEVOL)=0
70973 ELSEIF(IPOS(IEVOL).EQ.I) THEN
70974 IPOS(IEVOL)=INEW
70975 IFLG(IEVOL)=0
70976 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
70977 IPOS(IEVOL)=IRNEW
70978 IREC(IEVOL)=INEW
70979 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
70980 IFLG(IEVOL)=0
70981 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
70982 IPOS(IEVOL)=IRNEW
70983 IFLG(IEVOL)=0
70984 ENDIF
70985C...Update links of old connected partons.
70986 IF(IREC(IEVOL).EQ.I) THEN
70987 IREC(IEVOL)=INEW
70988 IFLG(IEVOL)=0
70989 ELSEIF(IREC(IEVOL).EQ.IR) THEN
70990 IREC(IEVOL)=IRNEW
70991 IFLG(IEVOL)=0
70992 ENDIF
70993 480 CONTINUE
70994
70995C...q->qg or g->gg: create new gluon radiators.
70996 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
70997 NEVOL=NEVOL+1
70998 IPOS(NEVOL)=INEW
70999 IREC(NEVOL)=IGNEW
71000 IFLG(NEVOL)=0
71001 ISCOL(NEVOL)=KCOL
71002 ISCHG(NEVOL)=0
71003 PTSCA(NEVOL)=SQRT(PT2)
71004 NEVOL=NEVOL+1
71005 IPOS(NEVOL)=IGNEW
71006 IREC(NEVOL)=INEW
71007 IFLG(NEVOL)=0
71008 ISCOL(NEVOL)=-KCOL
71009 ISCHG(NEVOL)=0
71010 PTSCA(NEVOL)=PTSCA(NEVOL-1)
71011 ENDIF
71012
71013C...Update matrix elements parton list and add new for g/gamma->qqbar.
71014 DO 490 IME=1,NMESYS
71015 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
71016 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
71017 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
71018 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
71019 490 CONTINUE
71020 IF(KFQ.NE.0) THEN
71021 NMESYS=NMESYS+1
71022 MESYS(NMESYS,0)=66
71023 MESYS(NMESYS,1)=INEW
71024 MESYS(NMESYS,2)=IGNEW
71025 NMESYS=NMESYS+1
71026 MESYS(NMESYS,0)=102
71027 MESYS(NMESYS,1)=INEW
71028 MESYS(NMESYS,2)=IGNEW
71029 ENDIF
71030
71031C...Global statistics.
71032 MINT(353)=MINT(353)+1
71033 VINT(353)=VINT(353)+PTCOR
71034 IF (MINT(353).EQ.1) VINT(358)=PTCOR
71035
71036C...Loopback for more emissions if enough space.
71037 PT2CMX=PT2
71038 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
71039 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
71040 GOTO 300
71041 ELSE
71042 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
71043 ENDIF
71044
71045C...Done.
71046 500 CONTINUE
71047
71048 RETURN
71049 END
71050
71051C*********************************************************************
71052
71053C...PYMAEL
71054C...Auxiliary to PYSHOW and PYPTFS.
71055C...Matrix elements for gluon (or photon) emission from
71056C...a two-body state; to be used by the parton shower routine.
71057C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
71058C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
71059C... = (alpha-strong/2 pi) * CF * PYMAEL,
71060C...i.e. normalization is such that one recovers the familiar
71061C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
71062C...Coupling structure:
71063C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
71064C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
71065C... = 16-19 : q -> q V
71066C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
71067C... = 26-29 : q -> q S
71068C... = 31-34 : V -> ~q ~qbar (~q = squark)
71069C... = 36-39 : ~q -> ~q V
71070C... = 41-44 : S -> ~q ~qbar
71071C... = 46-49 : ~q -> ~q S
71072C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
71073C... = 56-59 : ~q -> q chi
71074C... = 61-64 : q -> ~q chi
71075C... = 66-69 : ~g -> q ~qbar
71076C... = 71-74 : ~q -> q ~g
71077C... = 76-79 : q -> ~q ~g
71078C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
71079C...Note that the order of the decay products is important.
71080C...In each set of four, the variants are ordered as:
71081C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
71082C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
71083C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
71084C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
71085
71086 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
71087
71088C...Double precision and integer declarations.
71089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71090 IMPLICIT INTEGER(I-N)
71091
71092C...Check input values. Return zero outside allowed phase space.
71093 PYMAEL=0D0
71094 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
71095 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
71096 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
71097 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
71098 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
71099 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
71100
71101C...Initial values and flags.
71102 ICLASS=NI/5
71103 ICOMBI=NI-5*ICLASS
71104 ISSET1=0
71105 ISSET2=0
71106 ISSET4=0
71107
71108C... Phase space.
71109 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
71110
71111C...Eikonal expression; also acts as default.
71112 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
71113 RLO=PS
71114 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71115 ANUM=0D0
71116 ELSEIF(ICOMBI.EQ.2) THEN
71117 ANUM=(2D0-X1-X2)**2
71118 ELSEIF(ICOMBI.EQ.3) THEN
71119 ANUM=ALPCOR*(2D0-X1-X2)**2
71120 ELSE
71121 ANUM=0.5D0*(2D0-X1-X2)**2
71122 ENDIF
71123 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71124 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71125 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71126 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71127 ICOMBI=0
71128
71129C...V -> q qbar (V = gamma*/Z0/W+-/...).
71130 ELSEIF(ICLASS.EQ.2) THEN
71131 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71132 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71133 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
71134 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
71135 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
71136 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
71137 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71138 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
71139 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
71140 & (-1+R1**2-R2**2+X2)**2
71141 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71142 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71143 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
71144 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71145 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
71146 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71147 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71148 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
71149 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
71150 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
71151 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
71152 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
71153 RFO1=RFO1/2.D0
71154 ISSET1=1
71155 ENDIF
71156 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71157 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71158 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
71159 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
71160 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
71161 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
71162 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
71163 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
71164 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
71165 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71166 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71167 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
71168 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71169 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
71170 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71171 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71172 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
71173 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
71174 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
71175 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71176 & +X2)/(-1-R1**2+R2**2+X1)**2
71177 RFO2=RFO2/2.D0
71178 ISSET2=1
71179 ENDIF
71180 IF(ICOMBI.EQ.4) THEN
71181 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
71182 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
71183 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
71184 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
71185 & (-1-R1**2+R2**2+X1)**2
71186 RFO4=RFO4
71187 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
71188 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
71189 & -R1**2*X2**2+X1*X2**2)/
71190 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71191 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
71192 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
71193 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
71194 & (-1+R1**2-R2**2+X2)**2
71195 RFO4=RFO4/2.D0
71196 ISSET4=1
71197 ENDIF
71198
71199C...q -> q V.
71200 ELSEIF(ICLASS.EQ.3) THEN
71201 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71202 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
71203 & +R1**2*R2**2-2D0*R2**4)
71204 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
71205 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
71206 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
71207 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
71208 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
71209 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
71210 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71211 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
71212 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71213 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
71214 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71215 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71216 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
71217 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
71218 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71219 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
71220 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71221 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
71222 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
71223 ISSET1=1
71224 ENDIF
71225 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71226 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
71227 & +R1**2*R2**2-2D0*R2**4)
71228 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
71229 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
71230 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
71231 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
71232 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
71233 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
71234 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71235 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
71236 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71237 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
71238 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71239 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71240 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71241 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
71242 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71243 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
71244 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71245 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71246 & +X1*X2**2)/(-2+X1+X2)**2
71247 ISSET2=1
71248 ENDIF
71249 IF(ICOMBI.EQ.4) THEN
71250 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
71251 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
71252 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
71253 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
71254 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
71255 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71256 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
71257 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
71258 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71259 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71260 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71261 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
71262 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
71263 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71264 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71265 & +X1*X2**2)/(2-X1-X2)**2
71266 ISSET4=1
71267 ENDIF
71268
71269C...S -> q qbar (S = h0/H0/A0/H+-/...).
71270 ELSEIF(ICLASS.EQ.4) THEN
71271 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71272 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
71273 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71274 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71275 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71276 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
71277 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
71278 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71279 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71280 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71281 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71282 ISSET1=1
71283 ENDIF
71284 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71285 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
71286 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71287 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71288 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71289 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71290 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71291 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71292 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
71293 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
71294 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71295 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71296 ISSET2=1
71297 ENDIF
71298 IF(ICOMBI.EQ.4) THEN
71299 RLO4=PS*(1D0-R1**2-R2**2)
71300 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71301 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71302 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71303 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71304 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71305 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
71306 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71307 ISSET4=1
71308 ENDIF
71309
71310C...q -> q S.
71311 ELSEIF(ICLASS.EQ.5) THEN
71312 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71313 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71314 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71315 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71316 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
71317 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71318 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71319 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71320 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71321 & (-1+R1**2-R2**2+X2)**2
71322 ISSET1=1
71323 ENDIF
71324 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71325 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71326 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71327 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71328 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
71329 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71330 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71331 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71332 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71333 & (-1+R1**2-R2**2+X2)**2
71334 ISSET2=1
71335 ENDIF
71336 IF(ICOMBI.EQ.4) THEN
71337 RLO4=PS*(1D0+R1**2-R2**2)
71338 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
71339 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71340 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
71341 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71342 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71343 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71344 ISSET4=1
71345 ENDIF
71346
71347C...V -> ~q ~qbar (~q = squark).
71348 ELSEIF(ICLASS.EQ.6) THEN
71349 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71350 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
71351 & (-1-R1**2+R2**2+X1)**2
71352 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
71353 & (-1-R1**2+R2**2+X1)
71354 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
71355 & /(-1+R1**2-R2**2+X2)**2
71356 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
71357 & (-1+R1**2-R2**2+X2)
71358 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
71359 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
71360 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
71361 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71362 ISSET1=1
71363
71364C...~q -> ~q V.
71365 ELSEIF(ICLASS.EQ.7) THEN
71366 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71367 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
71368 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
71369 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
71370 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71371 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
71372 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
71373 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
71374 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
71375 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
71376 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
71377 & (3*(-2+X1+X2))
71378 RFO1=3D0*RFO1/8D0
71379 ISSET1=1
71380
71381C...S -> ~q ~qbar.
71382 ELSEIF(ICLASS.EQ.8) THEN
71383 RLO1=PS
71384 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71385 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
71386 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
71387 & -R1**2*X2**2+X1*X2**2)/
71388 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
71389 RFO1=2D0*RFO1
71390 ISSET1=1
71391
71392C...~q -> ~q S.
71393 ELSEIF(ICLASS.EQ.9) THEN
71394 RLO1=PS
71395 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71396 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71397 & -(X1+X2)/(-2+X1+X2)**2
71398 ISSET1=1
71399
71400C...chi -> q ~qbar (chi = neutralino/chargino).
71401 ELSEIF(ICLASS.EQ.10) THEN
71402 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71403 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71404 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71405 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
71406 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71407 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71408 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71409 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71410 & (-1+R1**2-R2**2+X2)**2
71411 ISSET1=1
71412 ENDIF
71413 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71414 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
71415 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
71416 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
71417 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
71418 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71419 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71420 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71421 & (-1+R1**2-R2**2+X2)**2
71422 ISSET2=1
71423 ENDIF
71424 IF(ICOMBI.EQ.4) THEN
71425 RLO4=PS*(1+R1**2-R2**2)
71426 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71427 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
71428 & +X2+R1**2*X2-X1*X2/2)/
71429 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71430 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71431 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71432 ISSET4=1
71433 ENDIF
71434
71435C...~q -> q chi.
71436 ELSEIF(ICLASS.EQ.11) THEN
71437 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71438 RLO1=PS*(1D0-(R1+R2)**2)
71439 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71440 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71441 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71442 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71443 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71444 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71445 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71446 ISSET1=1
71447 ENDIF
71448 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71449 RLO2=PS*(1D0-(R1-R2)**2)
71450 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
71451 & (-2+X1+X2)**2
71452 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71453 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71454 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71455 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
71456 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71457 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71458 ISSET2=1
71459 ENDIF
71460 IF(ICOMBI.EQ.4) THEN
71461 RLO4=PS*(1D0-R1**2-R2**2)
71462 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71463 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
71464 & +3*R1**2*X2-R2**2*X2-X1*X2)/
71465 & (-1+R1**2-R2**2+X2)**2
71466 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71467 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71468 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71469 ISSET4=1
71470 ENDIF
71471
71472C...q -> ~q chi.
71473 ELSEIF(ICLASS.EQ.12) THEN
71474 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71475 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71476 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71477 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
71478 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
71479 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
71480 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71481 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71482 ISSET1=1
71483 END IF
71484 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71485 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71486 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
71487 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
71488 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71489 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71490 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71491 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71492 ISSET2=1
71493 END IF
71494 IF(ICOMBI.EQ.4) THEN
71495 RLO4=PS*(1D0-R1**2+R2**2)
71496 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71497 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
71498 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
71499 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
71500 & +R1**2*X2-X1*X2/2-X2**2/2)/
71501 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71502 ISSET4=1
71503 END IF
71504
71505C...~g -> q ~qbar.
71506 ELSEIF(ICLASS.EQ.13) THEN
71507 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71508 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71509 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
71510 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
71511 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
71512 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
71513 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71514 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
71515 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
71516 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
71517 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
71518 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
71519 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
71520 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71521 & (3*(-1+R1**2-R2**2+X2)**2)
71522 RFO1=3D0*RFO1/4D0
71523 ISSET1=1
71524 ENDIF
71525 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71526 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71527 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
71528 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
71529 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71530 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
71531 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
71532 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
71533 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
71534 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
71535 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
71536 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71537 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
71538 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
71539 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71540 & (3*(-1+R1**2-R2**2+X2)**2)
71541 RFO2=3D0*RFO2/4D0
71542 ISSET2=1
71543 ENDIF
71544 IF(ICOMBI.EQ.4) THEN
71545 RLO4=PS*(1D0+R1**2-R2**2)
71546 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
71547 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
71548 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
71549 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
71550 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
71551 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71552 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
71553 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71554 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
71555 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71556 & (3*(-1+R1**2-R2**2+X2)**2)
71557 RFO4=3D0*RFO4/8D0
71558 ISSET4=1
71559 ENDIF
71560
71561C...~q -> q ~g.
71562 ELSEIF(ICLASS.EQ.14) THEN
71563 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71564 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
71565 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71566 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71567 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71568 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
71569 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
71570 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
71571 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71572 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71573 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71574 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71575 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
71576 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
71577 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71578 RFO1=RFO1
71579 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71580 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71581 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71582 RFO1=9D0*RFO1/64D0
71583 ISSET1=1
71584 ENDIF
71585 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71586 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
71587 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71588 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71589 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71590 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
71591 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
71592 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
71593 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
71594 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
71595 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71596 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71597 RFO2=RFO2
71598 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
71599 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
71600 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71601 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
71602 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
71603 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71604 RFO2=9D0*RFO2/64D0
71605 ISSET2=1
71606 ENDIF
71607 IF(ICOMBI.EQ.4) THEN
71608 RLO4=PS*(1-R1**2-R2**2)
71609 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
71610 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71611 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71612 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71613 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71614 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
71615 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
71616 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71617 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
71618 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
71619 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
71620 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71621 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71622 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
71623 RFO4=9D0*RFO4/128D0
71624 ISSET4=1
71625 ENDIF
71626
71627C...q -> ~q ~g.
71628 ELSEIF(ICLASS.EQ.15) THEN
71629 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71630 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71631 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71632 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
71633 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
71634 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
71635 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
71636 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71637 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
71638 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
71639 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71640 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
71641 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
71642 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
71643 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71644 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71645 RFO1=9D0*RFO1/32D0
71646 ISSET1=1
71647 END IF
71648 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71649 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71650 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
71651 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
71652 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
71653 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
71654 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
71655 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71656 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
71657 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
71658 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71659 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
71660 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71661 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71662 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71663 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71664 RFO2=9D0*RFO2/32D0
71665 ISSET2=1
71666 END IF
71667 IF(ICOMBI.EQ.4) THEN
71668 RLO4=PS*(1D0-R1**2+R2**2)
71669 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71670 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
71671 & -R2**2*X2/2-X1*X2/2)/
71672 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
71673 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
71674 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71675 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
71676 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71677 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
71678 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
71679 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71680 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71681 RFO4=9D0*RFO4/64D0
71682 ISSET4=1
71683 END IF
71684
71685C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71686 ELSEIF(ICLASS.EQ.16) THEN
71687 RLO=PS
71688 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71689 ANUM=0D0
71690 ELSEIF(ICOMBI.EQ.2) THEN
71691 ANUM=(2D0-X1-X2)**2
71692 ELSEIF(ICOMBI.EQ.3) THEN
71693 ANUM=ALPCOR*(2D0-X1-X2)**2
71694 ELSE
71695 ANUM=0.5D0*(2D0-X1-X2)**2
71696 ENDIF
71697 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71698 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71699 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71700 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71701 RFO=9D0*RFO/4D0
71702 ICOMBI=0
71703 ENDIF
71704
71705C...Find relevant LO and FO expression.
71706 IF(ICOMBI.EQ.0) THEN
71707 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
71708 RLO=RLO1
71709 RFO=RFO1
71710 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
71711 RLO=RLO2
71712 RFO=RFO2
71713 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71714 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
71715 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
71716 ELSEIF(ISSET4.EQ.1) THEN
71717 RLO=RLO4
71718 RFO=RFO4
71719 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71720 RLO=0.5D0*(RLO1+RLO2)
71721 RFO=0.5D0*(RFO1+RFO2)
71722 ELSEIF(ISSET1.EQ.1) THEN
71723 RLO=RLO1
71724 RFO=RFO1
71725 ELSE
71726 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
71727 RLO=1D0
71728 RFO=0D0
71729 ENDIF
71730
71731C...Output.
71732 PYMAEL=RFO/RLO
71733
71734 RETURN
71735 END
71736
71737C*********************************************************************
71738
71739C...PYBOEI
71740C...Modifies an event so as to approximately take into account
71741C...Bose-Einstein effects according to a simple phenomenological
71742C...parametrization.
71743
71744 SUBROUTINE PYBOEI(NSAV)
71745
71746C...Double precision and integer declarations.
71747 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71748 IMPLICIT INTEGER(I-N)
71749 INTEGER PYK,PYCHGE,PYCOMP
71750C...Parameter statement to help give large particle numbers.
71751 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71752 &KEXCIT=4000000,KDIMEN=5000000)
71753C...Commonblocks.
71754 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71755 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71756 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71757 COMMON/PYINT1/MINT(400),VINT(400)
71758 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
71759C...Local arrays and data.
71760 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
71761 &BEIW(100),BEI3W(100)
71762 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
71763C...Statement function: squared invariant mass.
71764 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
71765 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
71766
71767C...Boost event to overall CM frame. Calculate CM energy.
71768 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
71769 DO 100 J=1,4
71770 DPS(J)=0D0
71771 100 CONTINUE
71772 DO 120 I=1,N
71773 KFA=IABS(K(I,2))
71774 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
71775 & .AND.K(I,3).GT.0) THEN
71776 KFMA=IABS(K(K(I,3),2))
71777 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
71778 ENDIF
71779 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
71780 DO 110 J=1,4
71781 DPS(J)=DPS(J)+P(I,J)
71782 110 CONTINUE
71783 120 CONTINUE
71784 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
71785 &-DPS(3)/DPS(4))
71786 PECM=0D0
71787 DO 130 I=1,N
71788 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
71789 130 CONTINUE
71790
71791C...Check if we have separated strings
71792
71793C...Reserve copy of particles by species at end of record.
71794 IWP=0
71795 IWN=0
71796 NBE(0)=N+MSTU(3)
71797 NMAX=NBE(0)
71798 SMMIN=PECM
71799 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
71800 NBE(IBE)=NBE(IBE-1)
71801 DO 180 I=NSAV+1,N
71802 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
71803 DO 140 IIBE=1,IBE-1
71804 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
71805 140 CONTINUE
71806 ELSE
71807 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
71808 ENDIF
71809 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
71810 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
71811 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
71812 RETURN
71813 ENDIF
71814 NBE(IBE)=NBE(IBE)+1
71815 NMAX=NBE(IBE)
71816 K(NBE(IBE),1)=I
71817 K(NBE(IBE),2)=0
71818 K(NBE(IBE),3)=0
71819 K(NBE(IBE),4)=0
71820 K(NBE(IBE),5)=0
71821 P(NBE(IBE),1)=0.0D0
71822 P(NBE(IBE),2)=0.0D0
71823 P(NBE(IBE),3)=0.0D0
71824 P(NBE(IBE),4)=0.0D0
71825 P(NBE(IBE),5)=0.0D0
71826 SMMIN=MIN(SMMIN,P(I,5))
71827C...Check if particles comes from different W's or Z's
71828 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
71829 IM=I
71830 150 IF(K(IM,3).GT.0) THEN
71831 IM=K(IM,3)
71832 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
71833 K(NBE(IBE),5)=IM
71834 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
71835 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
71836 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
71837 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
71838 ENDIF
71839 ENDIF
71840C...Check if particles comes from different strings.
71841 IF(PARJ(94).GT.0.0D0) THEN
71842 IM=I
71843 160 IF(K(IM,3).GT.0) THEN
71844 IM=K(IM,3)
71845 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
71846 K(NBE(IBE),5)=IM
71847 ENDIF
71848 ENDIF
71849 DO 170 J=1,3
71850 P(NBE(IBE),J)=0D0
71851 V(NBE(IBE),J)=0D0
71852 170 CONTINUE
71853 P(NBE(IBE),5)=-1.0D0
71854 180 CONTINUE
71855 190 CONTINUE
71856 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
71857
71858C...Calculate separation between W+ and W- or between two Z0's.
71859C...No separation if there has been re-connections.
71860 SIGW=PARJ(93)
71861 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
71862 IF(K(IWP,2).EQ.23) THEN
71863 DMW=PMAS(23,1)
71864 DGW=PMAS(23,2)
71865 ELSE
71866 DMW=PMAS(24,1)
71867 DGW=PMAS(24,2)
71868 ENDIF
71869 DMP=P(IWP,5)
71870 DMN=P(IWN,5)
71871 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
71872 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
71873 TAUP=-TAUPD*LOG(PYR(IDUM))
71874 TAUN=-TAUND*LOG(PYR(IDUM))
71875 DXP=TAUP*PYP(IWP,8)/DMP
71876 DXN=TAUN*PYP(IWN,8)/DMN
71877 DX=DXP+DXN
71878 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
71879 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
71880 ENDIF
71881
71882C...Add separation between strings.
71883 IF(PARJ(94).GT.0.0D0) THEN
71884 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
71885 IWP=-1
71886 IWN=-1
71887 ENDIF
71888
71889 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
71890 DO 220 IBE=1,MIN(9,MSTJ(52))
71891 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
71892 Q2MIN=PECM**2
71893 I1=K(I1M,1)
71894 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
71895 IF(I2M.EQ.I1M) GOTO 200
71896 I2=K(I2M,1)
71897 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
71898 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
71899 & (P(I1,5)+P(I2,5))**2
71900 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
71901 Q2MIN=Q2
71902 ENDIF
71903 200 CONTINUE
71904 P(I1M,5)=Q2MIN
71905 210 CONTINUE
71906 220 CONTINUE
71907 ENDIF
71908
71909C...Tabulate integral for subsequent momentum shift.
71910 DO 400 IBE=1,MIN(9,MSTJ(52))
71911 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
71912 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
71913 & .LE.1) GOTO 270
71914 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
71915 & NBE(7)-NBE(6)).LE.1) GOTO 270
71916 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
71917 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
71918 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
71919 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
71920 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
71921 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
71922 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
71923 QDELW=0.1D0*MIN(PMHQ,SIGW)
71924 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
71925 IF(MSTJ(51).EQ.1) THEN
71926 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
71927 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
71928 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
71929 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
71930 BEEX=EXP(0.5D0*QDEL/PARJ(93))
71931 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
71932 BEEXW=EXP(0.5D0*QDELW/SIGW)
71933 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
71934 BERT=EXP(-QDEL/PARJ(93))
71935 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
71936 BERTW=EXP(-QDELW/SIGW)
71937 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
71938 ELSE
71939 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
71940 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
71941 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
71942 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
71943 ENDIF
71944 DO 230 IBIN=1,NBIN
71945 QBIN=QDEL*(IBIN-0.5D0)
71946 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71947 IF(MSTJ(51).EQ.1) THEN
71948 BEEX=BEEX*BERT
71949 BEI(IBIN)=BEI(IBIN)*BEEX
71950 ELSE
71951 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
71952 ENDIF
71953 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
71954 230 CONTINUE
71955 DO 240 IBIN=1,NBIN3
71956 QBIN=QDEL3*(IBIN-0.5D0)
71957 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71958 IF(MSTJ(51).EQ.1) THEN
71959 BEEX3=BEEX3*BERT3
71960 BEI3(IBIN)=BEI3(IBIN)*BEEX3
71961 ELSE
71962 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
71963 ENDIF
71964 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
71965 240 CONTINUE
71966 DO 250 IBIN=1,NBINW
71967 QBIN=QDELW*(IBIN-0.5D0)
71968 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71969 IF(MSTJ(51).EQ.1) THEN
71970 BEEXW=BEEXW*BERTW
71971 BEIW(IBIN)=BEIW(IBIN)*BEEXW
71972 ELSE
71973 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
71974 ENDIF
71975 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
71976 250 CONTINUE
71977 DO 260 IBIN=1,NBIN3W
71978 QBIN=QDEL3W*(IBIN-0.5D0)
71979 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
71980 & SQRT(QBIN**2+PMHQ**2)
71981 IF(MSTJ(51).EQ.1) THEN
71982 BEEX3W=BEEX3W*BERT3W
71983 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
71984 ELSE
71985 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
71986 ENDIF
71987 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
71988 260 CONTINUE
71989
71990C...Loop through particle pairs and find old relative momentum.
71991 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
71992 I1=K(I1M,1)
71993 DO 380 I2M=I1M+1,NBE(IBE)
71994 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
71995 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
71996 I2=K(I2M,1)
71997 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
71998 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
71999 IF(Q2OLD.LE.0.0D0) GOTO 380
72000 QOLD=SQRT(Q2OLD)
72001
72002C...Calculate new relative momentum.
72003 QMOV=0.0D0
72004 QMOV3=0.0D0
72005 QMOVW=0.0D0
72006 QMOV3W=0.0D0
72007 IF(QOLD.LT.1D-3*QDEL) THEN
72008 GOTO 280
72009 ELSEIF(QOLD.LE.QDEL) THEN
72010 QMOV=QOLD/3D0
72011 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
72012 RBIN=QOLD/QDEL
72013 IBIN=RBIN
72014 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
72015 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
72016 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72017 ELSE
72018 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72019 ENDIF
72020 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
72021 IF(QOLD.LT.1D-3*QDEL3) THEN
72022 GOTO 290
72023 ELSEIF(QOLD.LE.QDEL3) THEN
72024 QMOV3=QOLD/3D0
72025 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
72026 RBIN3=QOLD/QDEL3
72027 IBIN3=RBIN3
72028 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
72029 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
72030 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72031 ELSE
72032 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72033 ENDIF
72034 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
72035 RSCALE=1.0D0
72036 IF(MSTJ(54).EQ.2)
72037 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
72038 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
72039 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
72040
72041 IF(QOLD.LT.1D-3*QDELW) THEN
72042 GOTO 300
72043 ELSEIF(QOLD.LE.QDELW) THEN
72044 QMOVW=QOLD/3D0
72045 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
72046 RBINW=QOLD/QDELW
72047 IBINW=RBINW
72048 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
72049 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
72050 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72051 ELSE
72052 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72053 ENDIF
72054 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
72055 IF(QOLD.LT.1D-3*QDEL3W) THEN
72056 GOTO 310
72057 ELSEIF(QOLD.LE.QDEL3W) THEN
72058 QMOV3W=QOLD/3D0
72059 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
72060 RBIN3W=QOLD/QDEL3W
72061 IBIN3W=RBIN3W
72062 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
72063 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
72064 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72065 ELSE
72066 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72067 ENDIF
72068 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
72069 IF(MSTJ(54).EQ.2)
72070 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
72071
72072 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
72073 DO 330 J=1,3
72074 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
72075 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
72076 330 CONTINUE
72077 IF(MSTJ(54).GE.1) THEN
72078 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
72079 DO 340 J=1,3
72080 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
72081 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
72082 340 CONTINUE
72083 ELSEIF(MSTJ(54).LE.-1) THEN
72084 EDEL=P(I1,4)+P(I2,4)-
72085 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
72086 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72087 & (P(I1,3)-P(I2,3))**2
72088 WMAX=-1.0D20
72089 MI3=0
72090 MI4=0
72091 S12=SDIP(I1,I2)
72092 SM1=(P(I1,5)+SMMIN)**2
72093 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72094 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
72095 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
72096 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72097 & K(I3M,5).NE.K(I1M,5)) GOTO 360
72098 I3=K(I3M,1)
72099 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
72100 S13=SDIP(I1,I3)
72101 S23=SDIP(I2,I3)
72102 SM3=(P(I3,5)+SMMIN)**2
72103 IF(MSTJ(54).EQ.-2) THEN
72104 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
72105 & S23*MIN(SM1,SM3))*SM1)
72106 ELSE
72107 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
72108 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
72109 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
72110 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
72111 ENDIF
72112 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
72113 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
72114 & GOTO 360
72115 ELSE
72116 IF(WMAX*WI.GE.1.0) GOTO 360
72117 ENDIF
72118 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
72119 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
72120 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
72121 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72122 & K(I4M,5).NE.K(I1M,5)) GOTO 350
72123 I4=K(I4M,1)
72124 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
72125 & GOTO 350
72126 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
72127 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72128 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
72129 & GOTO 350
72130 IF(MSTJ(54).EQ.-2) THEN
72131 S14=SDIP(I1,I4)
72132 S24=SDIP(I2,I4)
72133 S34=SDIP(I3,I4)
72134 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
72135 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
72136 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
72137 W=MIN(W,MIN(S23,S24)*S13*S14)
72138 W=1.0D0/W
72139 ELSE
72140C...weight=1-cos(theta)/mtot2
72141 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
72142 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
72143 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
72144 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
72145 W=1.0D0/S1234
72146 IF(W.LE.WMAX) GOTO 350
72147 ENDIF
72148 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
72149 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
72150 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
72151 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
72152 IF(W.LE.WMAX) GOTO 350
72153 MI3=I3M
72154 MI4=I4M
72155 WMAX=W
72156 350 CONTINUE
72157 360 CONTINUE
72158 IF(MI4.EQ.0) GOTO 380
72159 I3=K(MI3,1)
72160 I4=K(MI4,1)
72161 EOLD=P(I3,4)+P(I4,4)
72162 ENEW=EOLD+EDEL
72163 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72164 & (P(I3,3)+P(I4,3))**2
72165 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
72166 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
72167 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
72168 DO 370 J=1,3
72169 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
72170 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
72171 370 CONTINUE
72172 ENDIF
72173 380 CONTINUE
72174 390 CONTINUE
72175 400 CONTINUE
72176
72177C...Shift momenta and recalculate energies.
72178 ESUMP=0.0D0
72179 ESUM=0.0D0
72180 PROD=0.0D0
72181 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72182 I=K(IM,1)
72183 ESUMP=ESUMP+P(I,4)
72184 DO 410 J=1,3
72185 P(I,J)=P(I,J)+P(IM,J)
72186 410 CONTINUE
72187 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72188 ESUM=ESUM+P(I,4)
72189 DO 420 J=1,3
72190 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72191 420 CONTINUE
72192 430 CONTINUE
72193
72194 PARJ(96)=0.0D0
72195 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
72196 440 ALPHA=(ESUMP-ESUM)/PROD
72197 PARJ(96)=PARJ(96)+ALPHA
72198 PROD=0.0D0
72199 ESUM=0.0D0
72200 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72201 I=K(IM,1)
72202 DO 450 J=1,3
72203 P(I,J)=P(I,J)+ALPHA*V(IM,J)
72204 450 CONTINUE
72205 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72206 ESUM=ESUM+P(I,4)
72207 DO 460 J=1,3
72208 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72209 460 CONTINUE
72210 470 CONTINUE
72211 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
72212 & GOTO 440
72213 ENDIF
72214
72215C...Rescale all momenta for energy conservation.
72216 PES=0D0
72217 PQS=0D0
72218 DO 480 I=1,N
72219 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
72220 PES=PES+P(I,4)
72221 PQS=PQS+P(I,5)**2/P(I,4)
72222 480 CONTINUE
72223 PARJ(95)=PES-PECM
72224 FAC=(PECM-PQS)/(PES-PQS)
72225 DO 500 I=1,N
72226 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
72227 DO 490 J=1,3
72228 P(I,J)=FAC*P(I,J)
72229 490 CONTINUE
72230 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72231 500 CONTINUE
72232
72233C...Boost back to correct reference frame.
72234 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
72235 DO 520 I=1,N
72236 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
72237 520 CONTINUE
72238
72239 RETURN
72240 END
72241
72242C*********************************************************************
72243
72244C...PYBESQ
72245C...Calculates the momentum shift in a system of two particles assuming
72246C...the relative momentum squared should be shifted to Q2NEW. NI is the
72247C...last position occupied in /PYJETS/.
72248
72249 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
72250
72251C...Double precision and integer declarations.
72252 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72253 IMPLICIT INTEGER(I-N)
72254 INTEGER PYK,PYCHGE,PYCOMP
72255C...Parameter statement to help give large particle numbers.
72256 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72257 &KEXCIT=4000000,KDIMEN=5000000)
72258C...Commonblocks.
72259 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72260 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72261 SAVE /PYJETS/,/PYDAT1/
72262C...Local arrays and data.
72263 DIMENSION DP(5)
72264 SAVE HC1
72265
72266 IF(MSTJ(55).EQ.0) THEN
72267 DQ2=Q2NEW-Q2OLD
72268 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72269 & (P(I1,3)-P(I2,3))**2
72270 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
72271 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
72272 SE=P(I1,4)+P(I2,4)
72273 DE=P(I1,4)-P(I2,4)
72274 DQ2SE=DQ2+SE**2
72275 DA=SE*DE*DP12-DP2*DQ2SE
72276 DB=DP2*DQ2SE-DP12**2
72277 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
72278 DO 100 J=1,3
72279 PD=HA*(P(I1,J)-P(I2,J))
72280 P(NI+1,J)=PD
72281 P(NI+2,J)=-PD
72282 100 CONTINUE
72283 RETURN
72284 ENDIF
72285
72286 K(NI+1,1)=1
72287 K(NI+2,1)=1
72288 DO 110 J=1,5
72289 P(NI+1,J)=P(I1,J)
72290 P(NI+2,J)=P(I2,J)
72291 DP(J)=P(I1,J)+P(I2,J)
72292 110 CONTINUE
72293
72294C...Boost to cms and rotate first particle to z-axis
72295 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
72296 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
72297 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
72298 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
72299 S=Q2NEW+(P(I1,5)+P(I2,5))**2
72300 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
72301 P(NI+1,1)=0.0D0
72302 P(NI+1,2)=0.0D0
72303 P(NI+1,3)=PZ
72304 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
72305 P(NI+2,1)=0.0D0
72306 P(NI+2,2)=0.0D0
72307 P(NI+2,3)=-PZ
72308 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
72309 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
72310 CALL PYROBO(NI+1,NI+2,THE,PHI,
72311 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
72312
72313 DO 120 J=1,3
72314 P(NI+1,J)=P(NI+1,J)-P(I1,J)
72315 P(NI+2,J)=P(NI+2,J)-P(I2,J)
72316 120 CONTINUE
72317
72318 RETURN
72319 END
72320
72321C*********************************************************************
72322
72323C...PYMASS
72324C...Gives the mass of a particle/parton.
72325
72326 FUNCTION PYMASS(KF)
72327
72328C...Double precision and integer declarations.
72329 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72330 IMPLICIT INTEGER(I-N)
72331 INTEGER PYK,PYCHGE,PYCOMP
72332C...Commonblocks.
72333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72335 SAVE /PYDAT1/,/PYDAT2/
72336
72337C...Reset variables. Compressed code. Special case for popcorn diquarks.
72338 PYMASS=0D0
72339 KFA=IABS(KF)
72340 KC=PYCOMP(KF)
72341 IF(KC.EQ.0) THEN
72342 MSTJ(93)=0
72343 RETURN
72344 ENDIF
72345
72346C...Guarantee use of constituent masses for internal checks.
72347 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
72348 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
72349 IF(KFA.LE.5) THEN
72350 PYMASS=PARF(100+KFA)
72351 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
72352 ELSEIF(KFA.LE.10) THEN
72353 PYMASS=PMAS(KFA,1)
72354 ELSEIF(MSTJ(93).EQ.1) THEN
72355 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
72356 ELSE
72357 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
72358 ENDIF
72359
72360C...Other masses can be read directly off table.
72361 ELSE
72362 PYMASS=PMAS(KC,1)
72363 ENDIF
72364
72365C...Optional mass broadening according to truncated Breit-Wigner
72366C...(either in m or in m^2).
72367 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
72368 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
72369 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
72370 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
72371 ELSE
72372 PM0=PYMASS
72373 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
72374 & (PM0*PMAS(KC,2)))
72375 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
72376 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
72377 & (PMUPP-PMLOW)*PYR(0))))
72378 ENDIF
72379 ENDIF
72380 MSTJ(93)=0
72381
72382 RETURN
72383 END
72384
72385C*********************************************************************
72386
72387C...PYMRUN
72388C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72389C...for Higgs couplings. Everything else sent on to PYMASS.
72390
72391 FUNCTION PYMRUN(KF,Q2)
72392
72393C...Double precision and integer declarations.
72394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72395 IMPLICIT INTEGER(I-N)
72396 INTEGER PYK,PYCHGE,PYCOMP
72397C...Commonblocks.
72398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72399 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72400 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
72401 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
72402
72403C...Most masses not handled here.
72404 KFA=IABS(KF)
72405 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
72406 PYMRUN=PYMASS(KF)
72407
72408C...Current-algebra masses, but no Q2 dependence.
72409 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
72410 PYMRUN=PARF(90+KFA)
72411
72412C...Running current-algebra masses.
72413 ELSE
72414 AS=PYALPS(Q2)
72415 PYMRUN=PARF(90+KFA)*
72416 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
72417 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
72418 ENDIF
72419
72420 RETURN
72421 END
72422
72423C*********************************************************************
72424
72425C...PYNAME
72426C...Gives the particle/parton name as a character string.
72427
72428 SUBROUTINE PYNAME(KF,CHAU)
72429
72430C...Double precision and integer declarations.
72431 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72432 IMPLICIT INTEGER(I-N)
72433 INTEGER PYK,PYCHGE,PYCOMP
72434C...Commonblocks.
72435 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72437 COMMON/PYDAT4/CHAF(500,2)
72438 CHARACTER CHAF*16
72439 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
72440C...Local character variable.
72441 CHARACTER CHAU*16
72442
72443C...Read out code with distinction particle/antiparticle.
72444 CHAU=' '
72445 KC=PYCOMP(KF)
72446 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
72447
72448
72449 RETURN
72450 END
72451
72452C*********************************************************************
72453
72454C...PYCHGE
72455C...Gives three times the charge for a particle/parton.
72456
72457 FUNCTION PYCHGE(KF)
72458
72459C...Double precision and integer declarations.
72460 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72461 IMPLICIT INTEGER(I-N)
72462 INTEGER PYK,PYCHGE,PYCOMP
72463C...Commonblocks.
72464 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72465 SAVE /PYDAT2/
72466
72467C...Read out charge and change sign for antiparticle.
72468 PYCHGE=0
72469 KC=PYCOMP(KF)
72470 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
72471
72472 RETURN
72473 END
72474
72475C*********************************************************************
72476
72477C...PYCOMP
72478C...Compress the standard KF codes for use in mass and decay arrays;
72479C...also checks whether a given code actually is defined.
72480
72481 FUNCTION PYCOMP(KF)
72482
72483C...Double precision and integer declarations.
72484 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72485 IMPLICIT INTEGER(I-N)
72486 INTEGER PYK,PYCHGE,PYCOMP
72487C...Commonblocks.
72488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72489 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72490 SAVE /PYDAT1/,/PYDAT2/
72491C...Local arrays and saved data.
72492 DIMENSION KFORD(100:500),KCORD(101:500)
72493 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
72494
72495C...Whenever necessary reorder codes for faster search.
72496 IF(MSTU(20).EQ.0) THEN
72497 NFORD=100
72498 KFORD(100)=0
72499 DO 120 I=101,500
72500 KFA=KCHG(I,4)
72501 IF(KFA.LE.100) GOTO 120
72502 NFORD=NFORD+1
72503 DO 100 I1=NFORD-1,0,-1
72504 IF(KFA.GE.KFORD(I1)) GOTO 110
72505 KFORD(I1+1)=KFORD(I1)
72506 KCORD(I1+1)=KCORD(I1)
72507 100 CONTINUE
72508 110 KFORD(I1+1)=KFA
72509 KCORD(I1+1)=I
72510 120 CONTINUE
72511 MSTU(20)=1
72512 KFLAST=0
72513 KCLAST=0
72514 ENDIF
72515
72516C...Fast action if same code as in latest call.
72517 IF(KF.EQ.KFLAST) THEN
72518 PYCOMP=KCLAST
72519 RETURN
72520 ENDIF
72521
72522C...Starting values. Remove internal diquark flags.
72523 PYCOMP=0
72524 KFA=IABS(KF)
72525 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
72526 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
72527
72528C...Simple cases: direct translation.
72529 IF(KFA.GT.KFORD(NFORD)) THEN
72530 ELSEIF(KFA.LE.100) THEN
72531 PYCOMP=KFA
72532
72533C...Else binary search.
72534 ELSE
72535 IMIN=100
72536 IMAX=NFORD+1
72537 130 IAVG=(IMIN+IMAX)/2
72538 IF(KFORD(IAVG).GT.KFA) THEN
72539 IMAX=IAVG
72540 IF(IMAX.GT.IMIN+1) GOTO 130
72541 ELSEIF(KFORD(IAVG).LT.KFA) THEN
72542 IMIN=IAVG
72543 IF(IMAX.GT.IMIN+1) GOTO 130
72544 ELSE
72545 PYCOMP=KCORD(IAVG)
72546 ENDIF
72547 ENDIF
72548
72549C...Check if antiparticle allowed.
72550 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
72551 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
72552 ENDIF
72553
72554C...Save codes for possible future fast action.
72555 KFLAST=KF
72556 KCLAST=PYCOMP
72557
72558 RETURN
72559 END
72560
72561C*********************************************************************
72562
72563C...PYERRM
72564C...Informs user of errors in program execution.
72565
72566 SUBROUTINE PYERRM(MERR,CHMESS)
72567
72568C...Double precision and integer declarations.
72569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72570 IMPLICIT INTEGER(I-N)
72571 INTEGER PYK,PYCHGE,PYCOMP
72572C...Commonblocks.
72573 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72574 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72575 SAVE /PYJETS/,/PYDAT1/
72576C...Local character variable.
72577 CHARACTER CHMESS*(*)
72578
72579C...Write first few warnings, then be silent.
72580 IF(MERR.LE.10) THEN
72581 MSTU(27)=MSTU(27)+1
72582 MSTU(28)=MERR
72583 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
72584 & MERR,MSTU(31),CHMESS
72585
72586C...Write first few errors, then be silent or stop program.
72587 ELSEIF(MERR.LE.20) THEN
72588 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
72589 MSTU(30)=MSTU(30)+1
72590 MSTU(24)=MERR-10
72591 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
72592 & MERR-10,MSTU(31),CHMESS
72593 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
72594 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
72595 WRITE(MSTU(11),5200)
72596 IF(MERR.NE.17) CALL PYLIST(2)
72597 CALL PYSTOP(3)
72598 ENDIF
72599
72600C...Stop program in case of irreparable error.
72601 ELSE
72602 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
72603 CALL PYSTOP(3)
72604 ENDIF
72605
72606C...Formats for output.
72607 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
72608 &' PYEXEC calls:'/5X,A)
72609 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
72610 &' PYEXEC calls:'/5X,A)
72611 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
72612 &'event!')
72613 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
72614 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
72615
72616 RETURN
72617 END
72618
72619C*********************************************************************
72620
72621C...PYALEM
72622C...Calculates the running alpha_electromagnetic.
72623
72624 FUNCTION PYALEM(Q2)
72625
72626C...Double precision and integer declarations.
72627 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72628 IMPLICIT INTEGER(I-N)
72629 INTEGER PYK,PYCHGE,PYCOMP
72630C...Commonblocks.
72631 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72632 SAVE /PYDAT1/
72633
72634C...Calculate real part of photon vacuum polarization.
72635C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72636C...For hadrons use parametrization of H. Burkhardt et al.
72637C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72638 AEMPI=PARU(101)/(3D0*PARU(1))
72639 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
72640 RPIGG=0D0
72641 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
72642 RPIGG=0D0
72643 ELSEIF(MSTU(101).EQ.2) THEN
72644 RPIGG=1D0-PARU(101)/PARU(103)
72645 ELSEIF(Q2.LT.0.09D0) THEN
72646 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
72647 ELSEIF(Q2.LT.9D0) THEN
72648 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
72649 & 0.00238D0*LOG(1D0+3.927D0*Q2)
72650 ELSEIF(Q2.LT.1D4) THEN
72651 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
72652 & 0.00299D0*LOG(1D0+Q2)
72653 ELSE
72654 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
72655 & 0.00293D0*LOG(1D0+Q2)
72656 ENDIF
72657
72658C...Calculate running alpha_em.
72659 PYALEM=PARU(101)/(1D0-RPIGG)
72660 PARU(108)=PYALEM
72661
72662 RETURN
72663 END
72664
72665C*********************************************************************
72666
72667C...PYALPS
72668C...Gives the value of alpha_strong.
72669
72670 FUNCTION PYALPS(Q2)
72671
72672C...Double precision and integer declarations.
72673 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72674 IMPLICIT INTEGER(I-N)
72675 INTEGER PYK,PYCHGE,PYCOMP
72676C...Commonblocks.
72677 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72678 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72679 SAVE /PYDAT1/,/PYDAT2/
72680C...Coefficients for second-order threshold matching.
72681C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72682 DIMENSION STEPDN(6),STEPUP(6)
72683c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72684c &(2D0*321D0/3703D0),0D0/
72685c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72686c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72687 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
72688 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
72689
72690C...Constant alpha_strong trivial. Pick artificial Lambda.
72691 IF(MSTU(111).LE.0) THEN
72692 PYALPS=PARU(111)
72693 MSTU(118)=MSTU(112)
72694 PARU(117)=0.2D0
72695 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
72696 & ((33D0-2D0*MSTU(112))*PARU(111)))
72697 PARU(118)=PARU(111)
72698 RETURN
72699 ENDIF
72700
72701C...Find effective Q2, number of flavours and Lambda.
72702 Q2EFF=Q2
72703 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
72704 NF=MSTU(112)
72705 ALAM2=PARU(112)**2
72706 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
72707 Q2THR=PARU(113)*PMAS(NF,1)**2
72708 IF(Q2EFF.LT.Q2THR) THEN
72709 NF=NF-1
72710 Q2RAT=Q2THR/ALAM2
72711 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
72712 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
72713 GOTO 100
72714 ENDIF
72715 ENDIF
72716 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
72717 Q2THR=PARU(113)*PMAS(NF+1,1)**2
72718 IF(Q2EFF.GT.Q2THR) THEN
72719 NF=NF+1
72720 Q2RAT=Q2THR/ALAM2
72721 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
72722 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
72723 GOTO 110
72724 ENDIF
72725 ENDIF
72726 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
72727 PARU(117)=SQRT(ALAM2)
72728
72729C...Evaluate first or second order alpha_strong.
72730 B0=(33D0-2D0*NF)/6D0
72731 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
72732 IF(MSTU(111).EQ.1) THEN
72733 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
72734 ELSE
72735 B1=(153D0-19D0*NF)/6D0
72736 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
72737 & (B0**2*ALGQ)))
72738 ENDIF
72739 MSTU(118)=NF
72740 PARU(118)=PYALPS
72741
72742 RETURN
72743 END
72744
72745C*********************************************************************
72746
72747C...PYANGL
72748C...Reconstructs an angle from given x and y coordinates.
72749
72750 FUNCTION PYANGL(X,Y)
72751
72752C...Double precision and integer declarations.
72753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72754 IMPLICIT INTEGER(I-N)
72755 INTEGER PYK,PYCHGE,PYCOMP
72756C...Commonblocks.
72757 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72758 SAVE /PYDAT1/
72759
72760 PYANGL=0D0
72761 R=SQRT(X**2+Y**2)
72762 IF(R.LT.1D-20) RETURN
72763 IF(ABS(X)/R.LT.0.8D0) THEN
72764 PYANGL=SIGN(ACOS(X/R),Y)
72765 ELSE
72766 PYANGL=ASIN(Y/R)
72767 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
72768 PYANGL=PARU(1)-PYANGL
72769 ELSEIF(X.LT.0D0) THEN
72770 PYANGL=-PARU(1)-PYANGL
72771 ENDIF
72772 ENDIF
72773
72774 RETURN
72775 END
72776
72777C*********************************************************************
72778
72779C...PYROBO
72780C...Performs rotations and boosts.
72781
72782 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72783
72784C...Double precision and integer declarations.
72785 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72786 IMPLICIT INTEGER(I-N)
72787 INTEGER PYK,PYCHGE,PYCOMP
72788C...Commonblocks.
72789 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72790 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72791 SAVE /PYJETS/,/PYDAT1/
72792C...Local arrays.
72793 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
72794
72795C...Find and check range of rotation/boost.
72796 IMIN=IMI
72797 IF(IMIN.LE.0) IMIN=1
72798 IF(MSTU(1).GT.0) IMIN=MSTU(1)
72799 IMAX=IMA
72800 IF(IMAX.LE.0) IMAX=N
72801 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72802 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
72803 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
72804 RETURN
72805 ENDIF
72806
72807C...Optional resetting of V (when not set before.)
72808 IF(MSTU(33).NE.0) THEN
72809 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
72810 DO 100 J=1,5
72811 V(I,J)=0D0
72812 100 CONTINUE
72813 110 CONTINUE
72814 MSTU(33)=0
72815 ENDIF
72816
72817C...Rotate, typically from z axis to direction (theta,phi).
72818 IF(THE**2+PHI**2.GT.1D-20) THEN
72819 ROT(1,1)=COS(THE)*COS(PHI)
72820 ROT(1,2)=-SIN(PHI)
72821 ROT(1,3)=SIN(THE)*COS(PHI)
72822 ROT(2,1)=COS(THE)*SIN(PHI)
72823 ROT(2,2)=COS(PHI)
72824 ROT(2,3)=SIN(THE)*SIN(PHI)
72825 ROT(3,1)=-SIN(THE)
72826 ROT(3,2)=0D0
72827 ROT(3,3)=COS(THE)
72828 DO 140 I=IMIN,IMAX
72829 IF(K(I,1).LE.0) GOTO 140
72830 DO 120 J=1,3
72831 PR(J)=P(I,J)
72832 VR(J)=V(I,J)
72833 120 CONTINUE
72834 DO 130 J=1,3
72835 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
72836 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
72837 130 CONTINUE
72838 140 CONTINUE
72839 ENDIF
72840
72841C...Boost, typically from rest to momentum/energy=beta.
72842 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
72843 DBX=BEX
72844 DBY=BEY
72845 DBZ=BEZ
72846 DB=SQRT(DBX**2+DBY**2+DBZ**2)
72847 EPS1=1D0-1D-12
72848 IF(DB.GT.EPS1) THEN
72849C...Rescale boost vector if too close to unity.
72850 CALL PYERRM(3,'(PYROBO:) boost vector too large')
72851 DBX=DBX*(EPS1/DB)
72852 DBY=DBY*(EPS1/DB)
72853 DBZ=DBZ*(EPS1/DB)
72854 DB=EPS1
72855 ENDIF
72856 DGA=1D0/SQRT(1D0-DB**2)
72857 DO 160 I=IMIN,IMAX
72858 IF(K(I,1).LE.0) GOTO 160
72859 DO 150 J=1,4
72860 DP(J)=P(I,J)
72861 DV(J)=V(I,J)
72862 150 CONTINUE
72863 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
72864 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
72865 P(I,1)=DP(1)+DGABP*DBX
72866 P(I,2)=DP(2)+DGABP*DBY
72867 P(I,3)=DP(3)+DGABP*DBZ
72868 P(I,4)=DGA*(DP(4)+DBP)
72869 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
72870 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
72871 V(I,1)=DV(1)+DGABV*DBX
72872 V(I,2)=DV(2)+DGABV*DBY
72873 V(I,3)=DV(3)+DGABV*DBZ
72874 V(I,4)=DGA*(DV(4)+DBV)
72875 160 CONTINUE
72876 ENDIF
72877
72878 RETURN
72879 END
72880
72881C*********************************************************************
72882
72883C...PYEDIT
72884C...Performs global manipulations on the event record, in particular
72885C...to exclude unstable or undetectable partons/particles.
72886
72887 SUBROUTINE PYEDIT(MEDIT)
72888
72889C...Double precision and integer declarations.
72890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72891 IMPLICIT INTEGER(I-N)
72892 INTEGER PYK,PYCHGE,PYCOMP
72893C...Parameter statement to help give large particle numbers.
72894 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72895 &KEXCIT=4000000,KDIMEN=5000000)
72896C...Commonblocks.
72897 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72898 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72899 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72900 COMMON/PYCTAG/NCT,MCT(4000,2)
72901 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
72902C...Local arrays.
72903 DIMENSION NS(2),PTS(2),PLS(2)
72904
72905C...Remove unwanted partons/particles.
72906 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
72907 IMAX=N
72908 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72909 I1=MAX(1,MSTU(1))-1
72910 DO 110 I=MAX(1,MSTU(1)),IMAX
72911 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
72912 IF(MEDIT.EQ.1) THEN
72913 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72914 ELSEIF(MEDIT.EQ.2) THEN
72915 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72916 KC=PYCOMP(K(I,2))
72917 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72918 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72919 & K(I,2).EQ.KSUSY1+39) GOTO 110
72920 ELSEIF(MEDIT.EQ.3) THEN
72921 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72922 KC=PYCOMP(K(I,2))
72923 IF(KC.EQ.0) GOTO 110
72924 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
72925 ELSEIF(MEDIT.EQ.5) THEN
72926 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
72927 KC=PYCOMP(K(I,2))
72928 IF(KC.EQ.0) GOTO 110
72929 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
72930 & KCHG(KC,2).EQ.0) GOTO 110
72931 ENDIF
72932
72933C...Pack remaining partons/particles. Origin no longer known.
72934 I1=I1+1
72935 DO 100 J=1,5
72936 K(I1,J)=K(I,J)
72937 P(I1,J)=P(I,J)
72938 V(I1,J)=V(I,J)
72939 100 CONTINUE
72940 K(I1,3)=0
72941 110 CONTINUE
72942 IF(I1.LT.N) MSTU(3)=0
72943 IF(I1.LT.N) MSTU(70)=0
72944 N=I1
72945
72946C...Selective removal of class of entries. New position of retained.
72947 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
72948 I1=0
72949 DO 120 I=1,N
72950 K(I,3)=MOD(K(I,3),MSTU(5))
72951 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
72952 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
72953 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
72954 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
72955 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
72956 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
72957 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
72958 I1=I1+1
72959 K(I,3)=K(I,3)+MSTU(5)*I1
72960 120 CONTINUE
72961
72962C...Find new event history information and replace old.
72963 DO 140 I=1,N
72964 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
72965 & K(I,3)/MSTU(5).EQ.0) GOTO 140
72966 ID=I
72967 130 IM=MOD(K(ID,3),MSTU(5))
72968 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
72969 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
72970 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
72971 ID=IM
72972 GOTO 130
72973 ENDIF
72974 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
72975 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
72976 & K(IM,2).EQ.94) THEN
72977 ID=IM
72978 GOTO 130
72979 ENDIF
72980 ENDIF
72981 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
72982 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
72983 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
72984 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
72985 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
72986 & K(K(I,4),3)/MSTU(5)
72987 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
72988 & K(K(I,5),3)/MSTU(5)
72989 ELSE
72990 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
72991 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
72992 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
72993 KCD=MOD(K(I,4),MSTU(5))
72994 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
72995 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
72996 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
72997 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
72998 KCD=MOD(K(I,5),MSTU(5))
72999 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
73000 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
73001 ENDIF
73002 140 CONTINUE
73003
73004C...Pack remaining entries.
73005 I1=0
73006 MSTU90=MSTU(90)
73007 MSTU(90)=0
73008 DO 170 I=1,N
73009 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
73010 I1=I1+1
73011 DO 150 J=1,5
73012 K(I1,J)=K(I,J)
73013 P(I1,J)=P(I,J)
73014 V(I1,J)=V(I,J)
73015 150 CONTINUE
73016C...Also update LHA1 colour tags
73017 MCT(I1,1)=MCT(I,1)
73018 MCT(I1,2)=MCT(I,2)
73019 K(I1,3)=MOD(K(I1,3),MSTU(5))
73020 DO 160 IZ=1,MSTU90
73021 IF(I.EQ.MSTU(90+IZ)) THEN
73022 MSTU(90)=MSTU(90)+1
73023 MSTU(90+MSTU(90))=I1
73024 PARU(90+MSTU(90))=PARU(90+IZ)
73025 ENDIF
73026 160 CONTINUE
73027 170 CONTINUE
73028 IF(I1.LT.N) MSTU(3)=0
73029 IF(I1.LT.N) MSTU(70)=0
73030 N=I1
73031
73032C...Fill in some missing daughter pointers (lost in colour flow).
73033 ELSEIF(MEDIT.EQ.16) THEN
73034 DO 220 I=1,N
73035 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
73036 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
73037C...Find daughters who point to mother.
73038 DO 180 I1=I+1,N
73039 IF(K(I1,3).NE.I) THEN
73040 ELSEIF(K(I,4).EQ.0) THEN
73041 K(I,4)=I1
73042 ELSE
73043 K(I,5)=I1
73044 ENDIF
73045 180 CONTINUE
73046 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73047 IF(K(I,4).NE.0) GOTO 220
73048C...Find daughters who point to documentation version of mother.
73049 IM=K(I,3)
73050 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
73051 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
73052 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
73053 DO 190 I1=I+1,N
73054 IF(K(I1,3).NE.IM) THEN
73055 ELSEIF(K(I,4).EQ.0) THEN
73056 K(I,4)=I1
73057 ELSE
73058 K(I,5)=I1
73059 ENDIF
73060 190 CONTINUE
73061 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73062 IF(K(I,4).NE.0) GOTO 220
73063C...Find daughters who point to documentation daughters who,
73064C...in their turn, point to documentation mother.
73065 ID1=IM
73066 ID2=IM
73067 DO 200 I1=IM+1,I-1
73068 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
73069 ID2=I1
73070 IF(ID1.EQ.IM) ID1=I1
73071 ENDIF
73072 200 CONTINUE
73073 DO 210 I1=I+1,N
73074 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
73075 ELSEIF(K(I,4).EQ.0) THEN
73076 K(I,4)=I1
73077 ELSE
73078 K(I,5)=I1
73079 ENDIF
73080 210 CONTINUE
73081 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73082 220 CONTINUE
73083
73084C...Save top entries at bottom of PYJETS commonblock.
73085 ELSEIF(MEDIT.EQ.21) THEN
73086 IF(2*N.GE.MSTU(4)) THEN
73087 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
73088 RETURN
73089 ENDIF
73090 DO 240 I=1,N
73091 DO 230 J=1,5
73092 K(MSTU(4)-I,J)=K(I,J)
73093 P(MSTU(4)-I,J)=P(I,J)
73094 V(MSTU(4)-I,J)=V(I,J)
73095 230 CONTINUE
73096 240 CONTINUE
73097 MSTU(32)=N
73098
73099C...Restore bottom entries of commonblock PYJETS to top.
73100 ELSEIF(MEDIT.EQ.22) THEN
73101 DO 260 I=1,MSTU(32)
73102 DO 250 J=1,5
73103 K(I,J)=K(MSTU(4)-I,J)
73104 P(I,J)=P(MSTU(4)-I,J)
73105 V(I,J)=V(MSTU(4)-I,J)
73106 250 CONTINUE
73107 260 CONTINUE
73108 N=MSTU(32)
73109
73110C...Mark primary entries at top of commonblock PYJETS as untreated.
73111 ELSEIF(MEDIT.EQ.23) THEN
73112 I1=0
73113 DO 270 I=1,N
73114 KH=K(I,3)
73115 IF(KH.GE.1) THEN
73116 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
73117 ENDIF
73118 IF(KH.NE.0) GOTO 280
73119 I1=I1+1
73120 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
73121 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
73122 270 CONTINUE
73123 280 N=I1
73124
73125C...Place largest axis along z axis and second largest in xy plane.
73126 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
73127 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
73128 & P(MSTU(61),2)),0D0,0D0,0D0)
73129 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
73130 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
73131 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
73132 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
73133 IF(MEDIT.EQ.31) RETURN
73134
73135C...Rotate to put slim jet along +z axis.
73136 DO 290 IS=1,2
73137 NS(IS)=0
73138 PTS(IS)=0D0
73139 PLS(IS)=0D0
73140 290 CONTINUE
73141 DO 300 I=1,N
73142 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
73143 IF(MSTU(41).GE.2) THEN
73144 KC=PYCOMP(K(I,2))
73145 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73146 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73147 & K(I,2).EQ.KSUSY1+39) GOTO 300
73148 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73149 & .EQ.0) GOTO 300
73150 ENDIF
73151 IS=2D0-SIGN(0.5D0,P(I,3))
73152 NS(IS)=NS(IS)+1
73153 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
73154 300 CONTINUE
73155 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
73156 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
73157
73158C...Rotate to put second largest jet into -z,+x quadrant.
73159 DO 310 I=1,N
73160 IF(P(I,3).GE.0D0) GOTO 310
73161 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
73162 IF(MSTU(41).GE.2) THEN
73163 KC=PYCOMP(K(I,2))
73164 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73165 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73166 & K(I,2).EQ.KSUSY1+39) GOTO 310
73167 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73168 & .EQ.0) GOTO 310
73169 ENDIF
73170 IS=2D0-SIGN(0.5D0,P(I,1))
73171 PLS(IS)=PLS(IS)-P(I,3)
73172 310 CONTINUE
73173 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
73174 & 0D0,0D0,0D0)
73175 ENDIF
73176
73177 RETURN
73178 END
73179
73180C*********************************************************************
73181
73182C...PYLIST
73183C...Gives program heading, or lists an event, or particle
73184C...data, or current parameter values.
73185
73186 SUBROUTINE PYLIST(MLIST)
73187
73188C...Double precision and integer declarations.
73189 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73190 IMPLICIT INTEGER(I-N)
73191 INTEGER PYK,PYCHGE,PYCOMP
73192C...Parameter statement to help give large particle numbers.
73193 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73194 &KEXCIT=4000000,KDIMEN=5000000)
73195
73196C...HEPEVT commonblock.
73197 PARAMETER (NMXHEP=4000)
73198 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
73199 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
73200 DOUBLE PRECISION PHEP,VHEP
73201 SAVE /HEPEVT/
73202
73203C...User process event common block.
73204 INTEGER MAXNUP
73205 PARAMETER (MAXNUP=500)
73206 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73207 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73208 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
73209 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
73210 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
73211 SAVE /HEPEUP/
73212
73213C...Commonblocks.
73214 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73215 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73216 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73217 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73218 COMMON/PYCTAG/NCT,MCT(4000,2)
73219 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
73220C...Local arrays, character variables and data.
73221 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73222 DIMENSION PS(6)
73223 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
73224
73225C...Initialization printout: version number and date of last change.
73226 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
73227 CALL PYLOGO
73228 MSTU(12)=12345
73229 IF(MLIST.EQ.0) RETURN
73230 ENDIF
73231
73232C...List event data, including additional lines after N.
73233 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
73234 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
73235 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
73236 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
73237 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
73238 LMX=12
73239 IF(MLIST.GE.2) LMX=16
73240 ISTR=0
73241 IMAX=N
73242 IF(MSTU(2).GT.0) IMAX=MSTU(2)
73243 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
73244 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
73245 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
73246 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
73247
73248C...Get particle name, pad it and check it is not too long.
73249 CALL PYNAME(K(I,2),CHAP)
73250 LEN=0
73251 DO 100 LEM=1,16
73252 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
73253 100 CONTINUE
73254 MDL=(K(I,1)+19)/10
73255 LDL=0
73256 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
73257 CHAC=CHAP
73258 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
73259 ELSE
73260 LDL=1
73261 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
73262 IF(LEN.EQ.0) THEN
73263 CHAC=CHDL(MDL)(1:2*LDL)//' '
73264 ELSE
73265 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
73266 & CHDL(MDL)(LDL+1:2*LDL)//' '
73267 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
73268 ENDIF
73269 ENDIF
73270
73271C...Add information on string connection.
73272 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
73273 & THEN
73274 KC=PYCOMP(K(I,2))
73275 KCC=0
73276 IF(KC.NE.0) KCC=KCHG(KC,2)
73277 IF(IABS(K(I,2)).EQ.39) THEN
73278 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
73279 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
73280 ISTR=1
73281 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
73282 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
73283 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
73284 ELSEIF(KCC.NE.0) THEN
73285 ISTR=0
73286 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
73287 ENDIF
73288 ENDIF
73289 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
73290 & CHAC(LMX-1:LMX-1)='I'
73291
73292C...Write data for particle/jet.
73293 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
73294 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
73295 & (P(I,J2),J2=1,5)
73296 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
73297 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
73298 & (P(I,J2),J2=1,5)
73299 ELSEIF(MLIST.EQ.1) THEN
73300 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
73301 & (P(I,J2),J2=1,5)
73302 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
73303 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
73304 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
73305 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73306 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
73307 & (P(I,J2),J2=1,5)
73308 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
73309 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73310 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
73311 & ,10000),MCT(I,1),MCT(I,2)
73312 ELSE
73313 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
73314 & (P(I,J2),J2=1,5)
73315 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
73316 & ,MCT(I,1),MCT(I,2)
73317 ENDIF
73318 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
73319
73320C...Insert extra separator lines specified by user.
73321 IF(MSTU(70).GE.1) THEN
73322 ISEP=0
73323 DO 110 J=1,MIN(10,MSTU(70))
73324 IF(I.EQ.MSTU(70+J)) ISEP=1
73325 110 CONTINUE
73326 IF(ISEP.EQ.1) THEN
73327 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
73328 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
73329 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
73330 ENDIF
73331 ENDIF
73332 120 CONTINUE
73333
73334C...Sum of charges and momenta.
73335 DO 130 J=1,6
73336 PS(J)=PYP(0,J)
73337 130 CONTINUE
73338 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
73339 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
73340 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
73341 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
73342 ELSEIF(MLIST.EQ.1) THEN
73343 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
73344 ELSEIF(MLIST.LE.3) THEN
73345 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
73346 ELSE
73347 WRITE(MSTU(11),7000) PS(6)
73348 ENDIF
73349
73350C...Simple listing of HEPEVT entries (mainly for test purposes).
73351 ELSEIF(MLIST.EQ.5) THEN
73352 WRITE(MSTU(11),7100)
73353 DO 140 I=1,NHEP
73354 IF(ISTHEP(I).EQ.0) GOTO 140
73355 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
73356 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
73357 140 CONTINUE
73358
73359
73360C...Simple listing of user-process entries (mainly for test purposes).
73361 ELSEIF(MLIST.EQ.7) THEN
73362 WRITE(MSTU(11),7300)
73363 DO 150 I=1,NUP
73364 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
73365 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
73366 150 CONTINUE
73367
73368C...Give simple list of KF codes defined in program.
73369 ELSEIF(MLIST.EQ.11) THEN
73370 WRITE(MSTU(11),7500)
73371 DO 160 KF=1,80
73372 CALL PYNAME(KF,CHAP)
73373 CALL PYNAME(-KF,CHAN)
73374 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73375 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73376 160 CONTINUE
73377 DO 190 KFLS=1,3,2
73378 DO 180 KFLA=1,5
73379 DO 170 KFLB=1,KFLA-(3-KFLS)/2
73380 KF=1000*KFLA+100*KFLB+KFLS
73381 CALL PYNAME(KF,CHAP)
73382 CALL PYNAME(-KF,CHAN)
73383 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73384 170 CONTINUE
73385 180 CONTINUE
73386 190 CONTINUE
73387 DO 220 KMUL=0,5
73388 KFLS=3
73389 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
73390 IF(KMUL.EQ.5) KFLS=5
73391 KFLR=0
73392 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
73393 IF(KMUL.EQ.4) KFLR=2
73394 DO 210 KFLB=1,5
73395 DO 200 KFLC=1,KFLB-1
73396 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
73397 CALL PYNAME(KF,CHAP)
73398 CALL PYNAME(-KF,CHAN)
73399 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73400 IF(KF.EQ.311) THEN
73401 KFK=130
73402 CALL PYNAME(KFK,CHAP)
73403 WRITE(MSTU(11),7600) KFK,CHAP
73404 KFK=310
73405 CALL PYNAME(KFK,CHAP)
73406 WRITE(MSTU(11),7600) KFK,CHAP
73407 ENDIF
73408 200 CONTINUE
73409 KF=10000*KFLR+110*KFLB+KFLS
73410 CALL PYNAME(KF,CHAP)
73411 WRITE(MSTU(11),7600) KF,CHAP
73412 210 CONTINUE
73413 220 CONTINUE
73414 KF=100443
73415 CALL PYNAME(KF,CHAP)
73416 WRITE(MSTU(11),7600) KF,CHAP
73417 KF=100553
73418 CALL PYNAME(KF,CHAP)
73419 WRITE(MSTU(11),7600) KF,CHAP
73420 DO 260 KFLSP=1,3
73421 KFLS=2+2*(KFLSP/3)
73422 DO 250 KFLA=1,5
73423 DO 240 KFLB=1,KFLA
73424 DO 230 KFLC=1,KFLB
73425 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
73426 & GOTO 230
73427 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
73428 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
73429 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
73430 CALL PYNAME(KF,CHAP)
73431 CALL PYNAME(-KF,CHAN)
73432 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73433 230 CONTINUE
73434 240 CONTINUE
73435 250 CONTINUE
73436 260 CONTINUE
73437 DO 270 KC=1,500
73438 KF=KCHG(KC,4)
73439 IF(KF.LT.1000000) GOTO 270
73440 CALL PYNAME(KF,CHAP)
73441 CALL PYNAME(-KF,CHAN)
73442 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73443 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73444 270 CONTINUE
73445
73446C...List parton/particle data table. Check whether to be listed.
73447 ELSEIF(MLIST.EQ.12) THEN
73448 WRITE(MSTU(11),7700)
73449 DO 300 KC=1,MSTU(6)
73450 KF=KCHG(KC,4)
73451 IF(KF.EQ.0) GOTO 300
73452 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
73453 & GOTO 300
73454
73455C...Find particle name and mass. Print information.
73456 CALL PYNAME(KF,CHAP)
73457 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
73458 CALL PYNAME(-KF,CHAN)
73459 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
73460 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
73461
73462C...Particle decay: channel number, branching ratios, matrix element,
73463C...decay products.
73464 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73465 DO 280 J=1,5
73466 CALL PYNAME(KFDP(IDC,J),CHAD(J))
73467 280 CONTINUE
73468 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73469 & (CHAD(J),J=1,5)
73470 290 CONTINUE
73471 300 CONTINUE
73472
73473C...List parameter value table.
73474 ELSEIF(MLIST.EQ.13) THEN
73475 WRITE(MSTU(11),8000)
73476 DO 310 I=1,200
73477 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
73478 310 CONTINUE
73479 ENDIF
73480
73481C...Format statements for output on unit MSTU(11) (by default 6).
73482 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
73483 &5X,'KF orig p_x p_y p_z E m'/)
73484 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
73485 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73486 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73487 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
73488 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73489 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
73490 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73491 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
73492 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
73493 & ,' C tag AC tag'/)
73494 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
73495 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
73496 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
73497 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
73498 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
73499 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
73500 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
73501 6200 FORMAT(66X,5(1X,F12.3))
73502 6300 FORMAT(1X,78('='))
73503 6400 FORMAT(1X,130('='))
73504 6500 FORMAT(1X,65('='))
73505 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
73506 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
73507 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
73508 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
73509 &5F13.5)
73510 7000 FORMAT(19X,'sum charge:',F6.2)
73511 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
73512 &//' I IST ID Mothers Daughters p_x p_y p_z',
73513 &' E m')
73514 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
73515 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
73516 &//' I IST ID Mothers Colours p_x p_y p_z',
73517 &' E m')
73518 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
73519 7500 FORMAT(///20X,'List of KF codes in program'/)
73520 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
73521 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
73522 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
73523 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
73524 &1X,'ME',3X,'Br.rat.',4X,'decay products')
73525 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
73526 &1X,1P,E13.5,3X,I2)
73527 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
73528 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
73529 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
73530 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
73531
73532 RETURN
73533 END
73534
73535C*********************************************************************
73536
73537C...PYLOGO
73538C...Writes a logo for the program.
73539
73540 SUBROUTINE PYLOGO
73541
73542C...Double precision and integer declarations.
73543 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73544 IMPLICIT INTEGER(I-N)
73545 INTEGER PYK,PYCHGE,PYCOMP
73546C...Parameter for length of information block.
73547 PARAMETER (IREFER=21)
73548C...Commonblocks.
73549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73550 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
73551 SAVE /PYDAT1/,/PYPARS/
73552C...Local arrays and character variables.
73553 INTEGER IDATI(6)
73554 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73555 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
73556
73557C...Data on months, logo, titles, and references.
73558 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73559 &'Oct','Nov','Dec'/
73560 DATA (LOGO(J),J=1,19)/
73561 &' *......* ',
73562 &' *:::!!:::::::::::* ',
73563 &' *::::::!!::::::::::::::* ',
73564 &' *::::::::!!::::::::::::::::* ',
73565 &' *:::::::::!!:::::::::::::::::* ',
73566 &' *:::::::::!!:::::::::::::::::* ',
73567 &' *::::::::!!::::::::::::::::*! ',
73568 &' *::::::!!::::::::::::::* !! ',
73569 &' !! *:::!!:::::::::::* !! ',
73570 &' !! !* -><- * !! ',
73571 &' !! !! !! ',
73572 &' !! !! !! ',
73573 &' !! !! ',
73574 &' !! lh !! ',
73575 &' !! !! ',
73576 &' !! hh !! ',
73577 &' !! ll !! ',
73578 &' !! !! ',
73579 &' !! '/
73580 DATA (LOGO(J),J=20,38)/
73581 &'Welcome to the Lund Monte Carlo!',
73582 &' ',
73583 &'PPP Y Y TTTTT H H III A ',
73584 &'P P Y Y T H H I A A ',
73585 &'PPP Y T HHHHH I AAAAA',
73586 &'P Y T H H I A A',
73587 &'P Y T H H III A A',
73588 &' ',
73589 &'This is PYTHIA version x.xxx ',
73590 &'Last date of change: xx xxx 200x',
73591 &' ',
73592 &'Now is xx xxx 200x at xx:xx:xx ',
73593 &' ',
73594 &'Disclaimer: this program comes ',
73595 &'without any guarantees. Beware ',
73596 &'of errors and use common sense ',
73597 &'when interpreting results. ',
73598 &' ',
73599 &'Copyright T. Sjostrand (2008) '/
73600 DATA (REFER(J),J=1,14)/
73601 &'An archive of program versions and d',
73602 &'ocumentation is found on the web: ',
73603 &'http://www.thep.lu.se/~torbjorn/Pyth',
73604 &'ia.html ',
73605 &' ',
73606 &' ',
73607 &'When you cite this program, the offi',
73608 &'cial reference is to the 6.4 manual:',
73609 &'T. Sjostrand, S. Mrenna and P. Skand',
73610 &'s, JHEP05 (2006) 026 ',
73611 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73612 &'-T) [hep-ph/0603175]. ',
73613 &' ',
73614 &' '/
73615 DATA (REFER(J),J=15,32)/
73616 &'Also remember that the program, to a',
73617 &' large extent, represents original ',
73618 &'physics research. Other publications',
73619 &' of special relevance to your ',
73620 &'studies may therefore deserve separa',
73621 &'te mention. ',
73622 &' ',
73623 &' ',
73624 &'Main author: Torbjorn Sjostrand; Dep',
73625 &'artment of Theoretical Physics, ',
73626 &' Lund University, Solvegatan 14A, S',
73627 &'-223 62 Lund, Sweden; ',
73628 &' phone: + 46 - 46 - 222 48 16; e-ma',
73629 &'il: torbjorn@thep.lu.se ',
73630 &'Author: Stephen Mrenna; Computing Di',
73631 &'vision, GDS Group, ',
73632 &' Fermi National Accelerator Laborat',
73633 &'ory, MS 234, Batavia, IL 60510, USA;'/
73634 DATA (REFER(J),J=33,2*IREFER)/
73635 &' phone: + 1 - 630 - 840 - 2556; e-m',
73636 &'ail: mrenna@fnal.gov ',
73637 &'Author: Peter Skands; Theoretical Ph',
73638 &'ysics Department, ',
73639 &' Fermi National Accelerator Laborat',
73640 &'ory, MS 106, Batavia, IL 60510, USA;',
73641 &' and CERN/PH, CH-1211 Geneva, Switz',
73642 &'erland; ',
73643 &' phone: + 41 - 22 - 767 24 59; e-ma',
73644 &'il: skands@fnal.gov '/
73645
73646C...Check that PYDATA linked.
73647 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
73648 WRITE(*,'(1X,A)')
73649 & 'Error: PYDATA has not been linked.'
73650 WRITE(*,'(1X,A)') 'Execution stopped!'
73651 CALL PYSTOP(8)
73652
73653C...Write current version number and current date+time.
73654 ELSE
73655 WRITE(VERS,'(I1)') MSTP(181)
73656 LOGO(28)(24:24)=VERS
73657 WRITE(SUBV,'(I3)') MSTP(182)
73658 LOGO(28)(26:28)=SUBV
73659 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
73660 WRITE(DATE,'(I2)') MSTP(185)
73661 LOGO(29)(22:23)=DATE
73662 LOGO(29)(25:27)=MONTH(MSTP(184))
73663 WRITE(YEAR,'(I4)') MSTP(183)
73664 LOGO(29)(29:32)=YEAR
73665 CALL PYTIME(IDATI)
73666 IF(IDATI(1).LE.0) THEN
73667 LOGO(31)=' '
73668 ELSE
73669 WRITE(DATE,'(I2)') IDATI(3)
73670 LOGO(31)(8:9)=DATE
73671 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
73672 WRITE(YEAR,'(I4)') IDATI(1)
73673 LOGO(31)(15:18)=YEAR
73674 WRITE(HOUR,'(I2)') IDATI(4)
73675 LOGO(31)(23:24)=HOUR
73676 WRITE(MINU,'(I2)') IDATI(5)
73677 LOGO(31)(26:27)=MINU
73678 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
73679 WRITE(SECO,'(I2)') IDATI(6)
73680 LOGO(31)(29:30)=SECO
73681 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
73682 ENDIF
73683 ENDIF
73684
73685C...Loop over lines in header. Define page feed and side borders.
73686 DO 100 ILIN=1,29+IREFER
73687 LINE=' '
73688 IF(ILIN.EQ.1) THEN
73689 LINE(1:1)='1'
73690 ELSE
73691 LINE(2:3)='**'
73692 LINE(78:79)='**'
73693 ENDIF
73694
73695C...Separator lines and logos.
73696 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
73697 LINE(4:77)='***********************************************'//
73698 & '***************************'
73699 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
73700 LINE(6:37)=LOGO(ILIN-5)
73701 LINE(44:75)=LOGO(ILIN+14)
73702 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
73703 LINE(5:40)=REFER(2*ILIN-51)
73704 LINE(41:76)=REFER(2*ILIN-50)
73705 ENDIF
73706
73707C...Write lines to appropriate unit.
73708 WRITE(MSTU(11),'(A79)') LINE
73709 100 CONTINUE
73710
73711 RETURN
73712 END
73713
73714C*********************************************************************
73715
73716C...PYUPDA
73717C...Facilitates the updating of particle and decay data
73718C...by allowing it to be done in an external file.
73719
73720 SUBROUTINE PYUPDA(MUPDA,LFN)
73721
73722C...Double precision and integer declarations.
73723 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73724 IMPLICIT INTEGER(I-N)
73725 INTEGER PYK,PYCHGE,PYCOMP
73726C...Commonblocks.
73727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73728 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73729 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73730 COMMON/PYDAT4/CHAF(500,2)
73731 CHARACTER CHAF*16
73732 COMMON/PYINT4/MWID(500),WIDS(500,5)
73733 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
73734C...Local arrays, character variables and data.
73735 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73736 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
73737 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73738 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73739 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73740 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73741 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73742
73743C...Write header if not yet done.
73744 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73745
73746C...Write information on file for editing.
73747 IF(MUPDA.EQ.1) THEN
73748 DO 110 KC=1,500
73749 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73750 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73751 & MWID(KC),MDCY(KC,1)
73752 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73753 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73754 & (KFDP(IDC,J),J=1,5)
73755 100 CONTINUE
73756 110 CONTINUE
73757
73758C...Read complete set of information from edited file or
73759C...read partial set of new or updated information from edited file.
73760 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
73761
73762C...Reset counters.
73763 KCC=100
73764 NDC=0
73765 CHKF=' '
73766 IF(MUPDA.EQ.2) THEN
73767 DO 120 I=1,MSTU(6)
73768 KCHG(I,4)=0
73769 120 CONTINUE
73770 ELSE
73771 DO 130 KC=1,MSTU(6)
73772 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
73773 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
73774 130 CONTINUE
73775 ENDIF
73776
73777C...Begin of loop: read new line; unknown whether particle or
73778C...decay data.
73779 140 READ(LFN,5200,END=190) CHINL
73780
73781C...Identify particle code and whether already defined (for MUPDA=3).
73782 IF(CHINL(2:10).NE.' ') THEN
73783 CHKF=CHINL(2:10)
73784 READ(CHKF,5300) KF
73785 IF(MUPDA.EQ.2) THEN
73786 IF(KF.LE.100) THEN
73787 KC=KF
73788 ELSE
73789 KCC=KCC+1
73790 KC=KCC
73791 ENDIF
73792 ELSE
73793 KCREP=0
73794 IF(KF.LE.100) THEN
73795 KCREP=KF
73796 ELSE
73797 DO 150 KCR=101,KCC
73798 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
73799 150 CONTINUE
73800 ENDIF
73801C...Remove duplicate old decay data.
73802 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
73803 IDCREP=MDCY(KCREP,2)
73804 NDCREP=MDCY(KCREP,3)
73805 DO 160 I=1,KCC
73806 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
73807 160 CONTINUE
73808 DO 180 I=IDCREP,NDC-NDCREP
73809 MDME(I,1)=MDME(I+NDCREP,1)
73810 MDME(I,2)=MDME(I+NDCREP,2)
73811 BRAT(I)=BRAT(I+NDCREP)
73812 DO 170 J=1,5
73813 KFDP(I,J)=KFDP(I+NDCREP,J)
73814 170 CONTINUE
73815 180 CONTINUE
73816 NDC=NDC-NDCREP
73817 KC=KCREP
73818 ELSEIF(KCREP.NE.0) THEN
73819 KC=KCREP
73820 ELSE
73821 KCC=KCC+1
73822 KC=KCC
73823 ENDIF
73824 ENDIF
73825
73826C...Study line with particle data.
73827 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
73828 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
73829 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73830 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73831 & MWID(KC),MDCY(KC,1)
73832 MDCY(KC,2)=0
73833 MDCY(KC,3)=0
73834
73835C...Study line with decay data.
73836 ELSE
73837 NDC=NDC+1
73838 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
73839 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
73840 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
73841 MDCY(KC,3)=MDCY(KC,3)+1
73842 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
73843 & (KFDP(NDC,J),J=1,5)
73844 ENDIF
73845
73846C...End of loop; ensure that PYCOMP tables are updated.
73847 GOTO 140
73848 190 CONTINUE
73849 MSTU(20)=0
73850
73851C...Perform possible tests that new information is consistent.
73852 DO 220 KC=1,MSTU(6)
73853 KF=KCHG(KC,4)
73854 IF(KF.EQ.0) GOTO 220
73855 WRITE(CHKF,5300) KF
73856 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
73857 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
73858 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
73859 BRSUM=0D0
73860 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73861 IF(MDME(IDC,2).GT.80) GOTO 210
73862 KQ=KCHG(KC,1)
73863 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
73864 MERR=0
73865 DO 200 J=1,5
73866 KP=KFDP(IDC,J)
73867 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
73868 IF(KP.EQ.81) KQ=0
73869 ELSEIF(PYCOMP(KP).EQ.0) THEN
73870 MERR=3
73871 ELSE
73872 KQ=KQ-PYCHGE(KP)
73873 KPC=PYCOMP(KP)
73874 PMS=PMS-PMAS(KPC,1)
73875 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
73876 & PMAS(KPC,3))
73877 ENDIF
73878 200 CONTINUE
73879 IF(KQ.NE.0) MERR=MAX(2,MERR)
73880 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
73881 & MERR=MAX(1,MERR)
73882 IF(MERR.EQ.3) CALL PYERRM(17,
73883 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
73884 IF(MERR.EQ.2) CALL PYERRM(17,
73885 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
73886 IF(MERR.EQ.1) CALL PYERRM(7,
73887 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
73888 BRSUM=BRSUM+BRAT(IDC)
73889 210 CONTINUE
73890 WRITE(CHTMP,5500) BRSUM
73891 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
73892 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
73893 & CHTMP(9:16)//' for KF ='//CHKF)
73894 220 CONTINUE
73895
73896C...Write DATA statements for inclusion in program.
73897 ELSEIF(MUPDA.EQ.4) THEN
73898
73899C...Find out how many codes and decay channels are actually used.
73900 KCC=0
73901 NDC=0
73902 DO 230 I=1,MSTU(6)
73903 IF(KCHG(I,4).NE.0) THEN
73904 KCC=I
73905 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
73906 ENDIF
73907 230 CONTINUE
73908
73909C...Initialize writing of DATA statements for inclusion in program.
73910 DO 300 IVAR=1,22
73911 NDIM=MSTU(6)
73912 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
73913 NLIN=1
73914 CHLIN=' '
73915 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
73916 LLIN=35
73917 CHOLD='START'
73918
73919C...Loop through variables for conversion to characters.
73920 DO 280 IDIM=1,NDIM
73921 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
73922 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
73923 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
73924 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
73925 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
73926 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
73927 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
73928 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
73929 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
73930 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
73931 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
73932 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
73933 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
73934 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
73935 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
73936 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
73937 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
73938 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
73939 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
73940 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
73941 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
73942 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
73943
73944C...Replace variables beyond what is properly defined.
73945 IF(IVAR.LE.4) THEN
73946 IF(IDIM.GT.KCC) CHTMP=' 0'
73947 ELSEIF(IVAR.LE.8) THEN
73948 IF(IDIM.GT.KCC) CHTMP=' 0.0'
73949 ELSEIF(IVAR.LE.11) THEN
73950 IF(IDIM.GT.KCC) CHTMP=' 0'
73951 ELSEIF(IVAR.LE.13) THEN
73952 IF(IDIM.GT.NDC) CHTMP=' 0'
73953 ELSEIF(IVAR.LE.14) THEN
73954 IF(IDIM.GT.NDC) CHTMP=' 0.0'
73955 ELSEIF(IVAR.LE.19) THEN
73956 IF(IDIM.GT.NDC) CHTMP=' 0'
73957 ELSEIF(IVAR.LE.21) THEN
73958 IF(IDIM.GT.KCC) CHTMP=' '
73959 ELSE
73960 IF(IDIM.GT.KCC) CHTMP=' 0'
73961 ENDIF
73962
73963C...Length of variable, trailing decimal zeros, quotation marks.
73964 LLOW=1
73965 LHIG=1
73966 DO 240 LL=1,16
73967 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
73968 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
73969 240 CONTINUE
73970 CHNEW=CHTMP(LLOW:LHIG)//' '
73971 LNEW=1+LHIG-LLOW
73972 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
73973 LNEW=LNEW+1
73974 250 LNEW=LNEW-1
73975 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
73976 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
73977 IF(LNEW.EQ.0) THEN
73978 CHNEW(1:3)='0D0'
73979 LNEW=3
73980 ELSE
73981 CHNEW(LNEW+1:LNEW+2)='D0'
73982 LNEW=LNEW+2
73983 ENDIF
73984 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
73985 DO 260 LL=LNEW,1,-1
73986 IF(CHNEW(LL:LL).EQ.'''') THEN
73987 CHTMP=CHNEW
73988 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
73989 LNEW=LNEW+1
73990 ENDIF
73991 260 CONTINUE
73992 LNEW=MIN(14,LNEW)
73993 CHTMP=CHNEW
73994 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
73995 LNEW=LNEW+2
73996 ENDIF
73997
73998C...Form composite character string, often including repetition counter.
73999 IF(CHNEW.NE.CHOLD) THEN
74000 NRPT=1
74001 CHOLD=CHNEW
74002 CHCOM=CHNEW
74003 LCOM=LNEW
74004 ELSE
74005 LRPT=LNEW+1
74006 IF(NRPT.GE.2) LRPT=LNEW+3
74007 IF(NRPT.GE.10) LRPT=LNEW+4
74008 IF(NRPT.GE.100) LRPT=LNEW+5
74009 IF(NRPT.GE.1000) LRPT=LNEW+6
74010 LLIN=LLIN-LRPT
74011 NRPT=NRPT+1
74012 WRITE(CHTMP,5400) NRPT
74013 LRPT=1
74014 IF(NRPT.GE.10) LRPT=2
74015 IF(NRPT.GE.100) LRPT=3
74016 IF(NRPT.GE.1000) LRPT=4
74017 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
74018 LCOM=LRPT+1+LNEW
74019 ENDIF
74020
74021C...Add characters to end of line, to new line (after storing old line),
74022C...or to new block of lines (after writing old block).
74023 IF(LLIN+LCOM.LE.70) THEN
74024 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
74025 LLIN=LLIN+LCOM+1
74026 ELSEIF(NLIN.LE.19) THEN
74027 CHLIN(LLIN+1:72)=' '
74028 CHBLK(NLIN)=CHLIN
74029 NLIN=NLIN+1
74030 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
74031 LLIN=6+LCOM+1
74032 ELSE
74033 CHLIN(LLIN:72)='/'//' '
74034 CHBLK(NLIN)=CHLIN
74035 WRITE(CHTMP,5400) IDIM-NRPT
74036 CHBLK(1)(30:33)=CHTMP(13:16)
74037 DO 270 ILIN=1,NLIN
74038 WRITE(LFN,5700) CHBLK(ILIN)
74039 270 CONTINUE
74040 NLIN=1
74041 CHLIN=' '
74042 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
74043 & ',I= , )/'//CHCOM(1:LCOM)//','
74044 WRITE(CHTMP,5400) IDIM-NRPT+1
74045 CHLIN(25:28)=CHTMP(13:16)
74046 LLIN=35+LCOM+1
74047 ENDIF
74048 280 CONTINUE
74049
74050C...Write final block of lines.
74051 CHLIN(LLIN:72)='/'//' '
74052 CHBLK(NLIN)=CHLIN
74053 WRITE(CHTMP,5400) NDIM
74054 CHBLK(1)(30:33)=CHTMP(13:16)
74055 DO 290 ILIN=1,NLIN
74056 WRITE(LFN,5700) CHBLK(ILIN)
74057 290 CONTINUE
74058 300 CONTINUE
74059 ENDIF
74060
74061C...Formats for reading and writing particle data.
74062 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
74063 5100 FORMAT(10X,2I5,F12.6,5I10)
74064 5200 FORMAT(A120)
74065 5300 FORMAT(I9)
74066 5400 FORMAT(I16)
74067 5500 FORMAT(F16.5)
74068 5600 FORMAT(F16.6)
74069 5700 FORMAT(A72)
74070
74071 RETURN
74072 END
74073
74074C*********************************************************************
74075
74076C...PYK
74077C...Provides various integer-valued event related data.
74078
74079 FUNCTION PYK(I,J)
74080
74081C...Double precision and integer declarations.
74082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74083 IMPLICIT INTEGER(I-N)
74084 INTEGER PYK,PYCHGE,PYCOMP
74085C...Commonblocks.
74086 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74087 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74088 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74089 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74090
74091C...Default value. For I=0 number of entries, number of stable entries
74092C...or 3 times total charge.
74093 PYK=0
74094 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74095 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
74096 PYK=N
74097 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
74098 DO 100 I1=1,N
74099 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
74100 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
74101 & PYCHGE(K(I1,2))
74102 100 CONTINUE
74103 ELSEIF(I.EQ.0) THEN
74104
74105C...For I > 0 direct readout of K matrix or charge.
74106 ELSEIF(J.LE.5) THEN
74107 PYK=K(I,J)
74108 ELSEIF(J.EQ.6) THEN
74109 PYK=PYCHGE(K(I,2))
74110
74111C...Status (existing/fragmented/decayed), parton/hadron separation.
74112 ELSEIF(J.LE.8) THEN
74113 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
74114 IF(J.EQ.8) PYK=PYK*K(I,2)
74115 ELSEIF(J.LE.12) THEN
74116 KFA=IABS(K(I,2))
74117 KC=PYCOMP(KFA)
74118 KQ=0
74119 IF(KC.NE.0) KQ=KCHG(KC,2)
74120 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
74121 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
74122 IF(J.EQ.11) PYK=KC
74123 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
74124
74125C...Heaviest flavour in hadron/diquark.
74126 ELSEIF(J.EQ.13) THEN
74127 KFA=IABS(K(I,2))
74128 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
74129 IF(KFA.LT.10) PYK=KFA
74130 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
74131 PYK=PYK*ISIGN(1,K(I,2))
74132
74133C...Particle history: generation, ancestor, rank.
74134 ELSEIF(J.LE.15) THEN
74135 I2=I
74136 I1=I
74137 110 PYK=PYK+1
74138 I2=I1
74139 I1=K(I1,3)
74140 IF(I1.GT.0) THEN
74141 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
74142 ENDIF
74143 IF(J.EQ.15) PYK=I2
74144 ELSEIF(J.EQ.16) THEN
74145 KFA=IABS(K(I,2))
74146 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
74147 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
74148 I1=I
74149 120 I2=I1
74150 I1=K(I1,3)
74151 IF(I1.GT.0) THEN
74152 KFAM=IABS(K(I1,2))
74153 ILP=1
74154 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
74155 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
74156 & ILP=0
74157 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
74158 IF(ILP.EQ.1) GOTO 120
74159 ENDIF
74160 IF(K(I1,1).EQ.12) THEN
74161 DO 130 I3=I1+1,I2
74162 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
74163 & .AND.K(I3,2).NE.93) PYK=PYK+1
74164 130 CONTINUE
74165 ELSE
74166 I3=I2
74167 140 PYK=PYK+1
74168 I3=I3+1
74169 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
74170 ENDIF
74171 ENDIF
74172
74173C...Particle coming from collapsing jet system or not.
74174 ELSEIF(J.EQ.17) THEN
74175 I1=I
74176 150 PYK=PYK+1
74177 I3=I1
74178 I1=K(I1,3)
74179 I0=MAX(1,I1)
74180 KC=PYCOMP(K(I0,2))
74181 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
74182 IF(PYK.EQ.1) PYK=-1
74183 IF(PYK.GT.1) PYK=0
74184 RETURN
74185 ENDIF
74186 IF(KCHG(KC,2).EQ.0) GOTO 150
74187 IF(K(I1,1).NE.12) PYK=0
74188 IF(K(I1,1).NE.12) RETURN
74189 I2=I1
74190 160 I2=I2+1
74191 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
74192 K3M=K(I3-1,3)
74193 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
74194 K3P=K(I3+1,3)
74195 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
74196
74197C...Number of decay products. Colour flow.
74198 ELSEIF(J.EQ.18) THEN
74199 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
74200 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
74201 ELSEIF(J.LE.22) THEN
74202 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
74203 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
74204 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
74205 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
74206 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
74207 ELSE
74208 ENDIF
74209
74210 RETURN
74211 END
74212
74213C*********************************************************************
74214
74215C...PYP
74216C...Provides various real-valued event related data.
74217
74218 FUNCTION PYP(I,J)
74219
74220C...Double precision and integer declarations.
74221 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74222 IMPLICIT INTEGER(I-N)
74223 INTEGER PYK,PYCHGE,PYCOMP
74224C...Commonblocks.
74225 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74226 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74227 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74228 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74229C...Local array.
74230 DIMENSION PSUM(4)
74231
74232C...Set default value. For I = 0 sum of momenta or charges,
74233C...or invariant mass of system.
74234 PYP=0D0
74235 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74236 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
74237 DO 100 I1=1,N
74238 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
74239 100 CONTINUE
74240 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
74241 DO 120 J1=1,4
74242 PSUM(J1)=0D0
74243 DO 110 I1=1,N
74244 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
74245 & P(I1,J1)
74246 110 CONTINUE
74247 120 CONTINUE
74248 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
74249 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
74250 DO 130 I1=1,N
74251 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
74252 130 CONTINUE
74253 ELSEIF(I.EQ.0) THEN
74254
74255C...Direct readout of P matrix.
74256 ELSEIF(J.LE.5) THEN
74257 PYP=P(I,J)
74258
74259C...Charge, total momentum, transverse momentum, transverse mass.
74260 ELSEIF(J.LE.12) THEN
74261 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
74262 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
74263 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
74264 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
74265 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
74266
74267C...Theta and phi angle in radians or degrees.
74268 ELSEIF(J.LE.16) THEN
74269 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
74270 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
74271 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
74272
74273C...True rapidity, rapidity with pion mass, pseudorapidity.
74274 ELSEIF(J.LE.19) THEN
74275 PMR=0D0
74276 IF(J.EQ.17) PMR=P(I,5)
74277 IF(J.EQ.18) PMR=PYMASS(211)
74278 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
74279 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
74280 & 1D20)),P(I,3))
74281
74282C...Energy and momentum fractions (only to be used in CM frame).
74283 ELSEIF(J.LE.25) THEN
74284 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
74285 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
74286 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
74287 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
74288 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
74289 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
74290 ENDIF
74291
74292 RETURN
74293 END
74294
74295C*********************************************************************
74296
74297C...PYSPHE
74298C...Performs sphericity tensor analysis to give sphericity,
74299C...aplanarity and the related event axes.
74300
74301 SUBROUTINE PYSPHE(SPH,APL)
74302
74303C...Double precision and integer declarations.
74304 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74305 IMPLICIT INTEGER(I-N)
74306 INTEGER PYK,PYCHGE,PYCOMP
74307C...Parameter statement to help give large particle numbers.
74308 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74309 &KEXCIT=4000000,KDIMEN=5000000)
74310C...Commonblocks.
74311 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74312 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74313 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74314 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74315C...Local arrays.
74316 DIMENSION SM(3,3),SV(3,3)
74317
74318C...Calculate matrix to be diagonalized.
74319 NP=0
74320 DO 110 J1=1,3
74321 DO 100 J2=J1,3
74322 SM(J1,J2)=0D0
74323 100 CONTINUE
74324 110 CONTINUE
74325 PS=0D0
74326 DO 140 I=1,N
74327 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74328 IF(MSTU(41).GE.2) THEN
74329 KC=PYCOMP(K(I,2))
74330 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74331 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74332 & K(I,2).EQ.KSUSY1+39) GOTO 140
74333 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74334 & GOTO 140
74335 ENDIF
74336 NP=NP+1
74337 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74338 PWT=1D0
74339 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
74340 & MAX(1D-10,PA)**(PARU(41)-2D0)
74341 DO 130 J1=1,3
74342 DO 120 J2=J1,3
74343 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
74344 120 CONTINUE
74345 130 CONTINUE
74346 PS=PS+PWT*PA**2
74347 140 CONTINUE
74348
74349C...Very low multiplicities (0 or 1) not considered.
74350 IF(NP.LE.1) THEN
74351 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
74352 SPH=-1D0
74353 APL=-1D0
74354 RETURN
74355 ENDIF
74356 DO 160 J1=1,3
74357 DO 150 J2=J1,3
74358 SM(J1,J2)=SM(J1,J2)/PS
74359 150 CONTINUE
74360 160 CONTINUE
74361
74362C...Find eigenvalues to matrix (third degree equation).
74363 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
74364 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
74365 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
74366 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
74367 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
74368 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
74369 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
74370 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
74371 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
74372 IF(P(N+2,4).LT.1D-5) THEN
74373 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
74374 SPH=-1D0
74375 APL=-1D0
74376 RETURN
74377 ENDIF
74378
74379C...Find first and last eigenvector by solving equation system.
74380 DO 240 I=1,3,2
74381 DO 180 J1=1,3
74382 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
74383 DO 170 J2=J1+1,3
74384 SV(J1,J2)=SM(J1,J2)
74385 SV(J2,J1)=SM(J1,J2)
74386 170 CONTINUE
74387 180 CONTINUE
74388 SMAX=0D0
74389 DO 200 J1=1,3
74390 DO 190 J2=1,3
74391 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
74392 JA=J1
74393 JB=J2
74394 SMAX=ABS(SV(J1,J2))
74395 190 CONTINUE
74396 200 CONTINUE
74397 SMAX=0D0
74398 DO 220 J3=JA+1,JA+2
74399 J1=J3-3*((J3-1)/3)
74400 RL=SV(J1,JB)/SV(JA,JB)
74401 DO 210 J2=1,3
74402 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
74403 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
74404 JC=J1
74405 SMAX=ABS(SV(J1,J2))
74406 210 CONTINUE
74407 220 CONTINUE
74408 JB1=JB+1-3*(JB/3)
74409 JB2=JB+2-3*((JB+1)/3)
74410 P(N+I,JB1)=-SV(JC,JB2)
74411 P(N+I,JB2)=SV(JC,JB1)
74412 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
74413 & SV(JA,JB)
74414 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
74415 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74416 DO 230 J=1,3
74417 P(N+I,J)=SGN*P(N+I,J)/PA
74418 230 CONTINUE
74419 240 CONTINUE
74420
74421C...Middle axis orthogonal to other two. Fill other codes.
74422 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74423 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
74424 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
74425 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
74426 DO 260 I=1,3
74427 K(N+I,1)=31
74428 K(N+I,2)=95
74429 K(N+I,3)=I
74430 K(N+I,4)=0
74431 K(N+I,5)=0
74432 P(N+I,5)=0D0
74433 DO 250 J=1,5
74434 V(I,J)=0D0
74435 250 CONTINUE
74436 260 CONTINUE
74437
74438C...Calculate sphericity and aplanarity. Select storing option.
74439 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
74440 APL=1.5D0*P(N+3,4)
74441 MSTU(61)=N+1
74442 MSTU(62)=NP
74443 IF(MSTU(43).LE.1) MSTU(3)=3
74444 IF(MSTU(43).GE.2) N=N+3
74445
74446 RETURN
74447 END
74448
74449C*********************************************************************
74450
74451C...PYTHRU
74452C...Performs thrust analysis to give thrust, oblateness
74453C...and the related event axes.
74454
74455 SUBROUTINE PYTHRU(THR,OBL)
74456
74457C...Double precision and integer declarations.
74458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74459 IMPLICIT INTEGER(I-N)
74460 INTEGER PYK,PYCHGE,PYCOMP
74461C...Parameter statement to help give large particle numbers.
74462 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74463 &KEXCIT=4000000,KDIMEN=5000000)
74464C...Commonblocks.
74465 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74466 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74467 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74468 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74469C...Local arrays.
74470 DIMENSION TDI(3),TPR(3)
74471
74472C...Take copy of particles that are to be considered in thrust analysis.
74473 NP=0
74474 PS=0D0
74475 DO 100 I=1,N
74476 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
74477 IF(MSTU(41).GE.2) THEN
74478 KC=PYCOMP(K(I,2))
74479 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74480 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74481 & K(I,2).EQ.KSUSY1+39) GOTO 100
74482 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74483 & GOTO 100
74484 ENDIF
74485 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
74486 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
74487 THR=-2D0
74488 OBL=-2D0
74489 RETURN
74490 ENDIF
74491 NP=NP+1
74492 K(N+NP,1)=23
74493 P(N+NP,1)=P(I,1)
74494 P(N+NP,2)=P(I,2)
74495 P(N+NP,3)=P(I,3)
74496 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74497 P(N+NP,5)=1D0
74498 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
74499 & P(N+NP,4)**(PARU(42)-1D0)
74500 PS=PS+P(N+NP,4)*P(N+NP,5)
74501 100 CONTINUE
74502
74503C...Very low multiplicities (0 or 1) not considered.
74504 IF(NP.LE.1) THEN
74505 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
74506 THR=-1D0
74507 OBL=-1D0
74508 RETURN
74509 ENDIF
74510
74511C...Loop over thrust and major. T axis along z direction in latter case.
74512 DO 320 ILD=1,2
74513 IF(ILD.EQ.2) THEN
74514 K(N+NP+1,1)=31
74515 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
74516 MSTU(33)=1
74517 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
74518 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
74519 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
74520 ENDIF
74521
74522C...Find and order particles with highest p (pT for major).
74523 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
74524 P(ILF,4)=0D0
74525 110 CONTINUE
74526 DO 160 I=N+1,N+NP
74527 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
74528 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
74529 IF(P(I,4).LE.P(ILF,4)) GOTO 140
74530 DO 120 J=1,5
74531 P(ILF+1,J)=P(ILF,J)
74532 120 CONTINUE
74533 130 CONTINUE
74534 ILF=N+NP+3
74535 140 DO 150 J=1,5
74536 P(ILF+1,J)=P(I,J)
74537 150 CONTINUE
74538 160 CONTINUE
74539
74540C...Find and order initial axes with highest thrust (major).
74541 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
74542 P(ILG,4)=0D0
74543 170 CONTINUE
74544 NC=2**(MIN(MSTU(44),NP)-1)
74545 DO 250 ILC=1,NC
74546 DO 180 J=1,3
74547 TDI(J)=0D0
74548 180 CONTINUE
74549 DO 200 ILF=1,MIN(MSTU(44),NP)
74550 SGN=P(N+NP+ILF+3,5)
74551 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
74552 DO 190 J=1,4-ILD
74553 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
74554 190 CONTINUE
74555 200 CONTINUE
74556 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
74557 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
74558 IF(TDS.LE.P(ILG,4)) GOTO 230
74559 DO 210 J=1,4
74560 P(ILG+1,J)=P(ILG,J)
74561 210 CONTINUE
74562 220 CONTINUE
74563 ILG=N+NP+MSTU(44)+4
74564 230 DO 240 J=1,3
74565 P(ILG+1,J)=TDI(J)
74566 240 CONTINUE
74567 P(ILG+1,4)=TDS
74568 250 CONTINUE
74569
74570C...Iterate direction of axis until stable maximum.
74571 P(N+NP+ILD,4)=0D0
74572 ILG=0
74573 260 ILG=ILG+1
74574 THP=0D0
74575 270 THPS=THP
74576 DO 280 J=1,3
74577 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
74578 IF(THP.GT.1D-10) TDI(J)=TPR(J)
74579 TPR(J)=0D0
74580 280 CONTINUE
74581 DO 300 I=N+1,N+NP
74582 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
74583 DO 290 J=1,4-ILD
74584 TPR(J)=TPR(J)+SGN*P(I,J)
74585 290 CONTINUE
74586 300 CONTINUE
74587 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
74588 IF(THP.GE.THPS+PARU(48)) GOTO 270
74589
74590C...Save good axis. Try new initial axis until a number of tries agree.
74591 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
74592 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
74593 IAGR=0
74594 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74595 DO 310 J=1,3
74596 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
74597 310 CONTINUE
74598 P(N+NP+ILD,4)=THP
74599 P(N+NP+ILD,5)=0D0
74600 ENDIF
74601 IAGR=IAGR+1
74602 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
74603 320 CONTINUE
74604
74605C...Find minor axis and value by orthogonality.
74606 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74607 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
74608 P(N+NP+3,2)=SGN*P(N+NP+2,1)
74609 P(N+NP+3,3)=0D0
74610 THP=0D0
74611 DO 330 I=N+1,N+NP
74612 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
74613 330 CONTINUE
74614 P(N+NP+3,4)=THP/PS
74615 P(N+NP+3,5)=0D0
74616
74617C...Fill axis information. Rotate back to original coordinate system.
74618 DO 350 ILD=1,3
74619 K(N+ILD,1)=31
74620 K(N+ILD,2)=96
74621 K(N+ILD,3)=ILD
74622 K(N+ILD,4)=0
74623 K(N+ILD,5)=0
74624 DO 340 J=1,5
74625 P(N+ILD,J)=P(N+NP+ILD,J)
74626 V(N+ILD,J)=0D0
74627 340 CONTINUE
74628 350 CONTINUE
74629 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
74630
74631C...Calculate thrust and oblateness. Select storing option.
74632 THR=P(N+1,4)
74633 OBL=P(N+2,4)-P(N+3,4)
74634 MSTU(61)=N+1
74635 MSTU(62)=NP
74636 IF(MSTU(43).LE.1) MSTU(3)=3
74637 IF(MSTU(43).GE.2) N=N+3
74638
74639 RETURN
74640 END
74641
74642C*********************************************************************
74643
74644C...PYCLUS
74645C...Subdivides the particle content of an event into jets/clusters.
74646
74647 SUBROUTINE PYCLUS(NJET)
74648
74649C...Double precision and integer declarations.
74650 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74651 IMPLICIT INTEGER(I-N)
74652 INTEGER PYK,PYCHGE,PYCOMP
74653C...Parameter statement to help give large particle numbers.
74654 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74655 &KEXCIT=4000000,KDIMEN=5000000)
74656C...Commonblocks.
74657 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74658 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74659 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74660 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74661C...Local arrays and saved variables.
74662 DIMENSION PS(5)
74663 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
74664
74665C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74666 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
74667 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
74668 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
74669 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74670 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
74671 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74672
74673C...If first time, reset. If reentering, skip preliminaries.
74674 IF(MSTU(48).LE.0) THEN
74675 NP=0
74676 DO 100 J=1,5
74677 PS(J)=0D0
74678 100 CONTINUE
74679 PSS=0D0
74680 PIMASS=PMAS(PYCOMP(211),1)
74681 ELSE
74682 NJET=NSAV
74683 IF(MSTU(43).GE.2) N=N-NJET
74684 DO 110 I=N+1,N+NJET
74685 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74686 110 CONTINUE
74687 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74688 R2ACC=PARU(44)**2
74689 ELSE
74690 R2ACC=PARU(45)*PS(5)**2
74691 ENDIF
74692 NLOOP=0
74693 GOTO 300
74694 ENDIF
74695
74696C...Find which particles are to be considered in cluster search.
74697 DO 140 I=1,N
74698 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74699 IF(MSTU(41).GE.2) THEN
74700 KC=PYCOMP(K(I,2))
74701 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74702 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74703 & K(I,2).EQ.KSUSY1+39) GOTO 140
74704 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74705 & GOTO 140
74706 ENDIF
74707 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
74708 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
74709 NJET=-1
74710 RETURN
74711 ENDIF
74712
74713C...Take copy of these particles, with space left for jets later on.
74714 NP=NP+1
74715 K(N+NP,3)=I
74716 DO 120 J=1,5
74717 P(N+NP,J)=P(I,J)
74718 120 CONTINUE
74719 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
74720 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
74721 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74722 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74723 DO 130 J=1,4
74724 PS(J)=PS(J)+P(N+NP,J)
74725 130 CONTINUE
74726 PSS=PSS+P(N+NP,5)
74727 140 CONTINUE
74728 DO 160 I=N+1,N+NP
74729 K(I+NP,3)=K(I,3)
74730 DO 150 J=1,5
74731 P(I+NP,J)=P(I,J)
74732 150 CONTINUE
74733 160 CONTINUE
74734 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
74735
74736C...Very low multiplicities not considered.
74737 IF(NP.LT.MSTU(47)) THEN
74738 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
74739 NJET=-1
74740 RETURN
74741 ENDIF
74742
74743C...Find precluster configuration. If too few jets, make harder cuts.
74744 NLOOP=0
74745 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74746 R2ACC=PARU(44)**2
74747 ELSE
74748 R2ACC=PARU(45)*PS(5)**2
74749 ENDIF
74750 RINIT=1.25D0*PARU(43)
74751 IF(NP.LE.MSTU(47)+2) RINIT=0D0
74752 170 RINIT=0.8D0*RINIT
74753 NPRE=0
74754 NREM=NP
74755 DO 180 I=N+NP+1,N+2*NP
74756 K(I,4)=0
74757 180 CONTINUE
74758
74759C...Sum up small momentum region. Jet if enough absolute momentum.
74760 IF(MSTU(46).LE.2) THEN
74761 DO 190 J=1,4
74762 P(N+1,J)=0D0
74763 190 CONTINUE
74764 DO 210 I=N+NP+1,N+2*NP
74765 IF(P(I,5).GT.2D0*RINIT) GOTO 210
74766 NREM=NREM-1
74767 K(I,4)=1
74768 DO 200 J=1,4
74769 P(N+1,J)=P(N+1,J)+P(I,J)
74770 200 CONTINUE
74771 210 CONTINUE
74772 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
74773 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
74774 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74775 IF(NREM.EQ.0) GOTO 170
74776 ENDIF
74777
74778C...Find fastest remaining particle.
74779 220 NPRE=NPRE+1
74780 PMAX=0D0
74781 DO 230 I=N+NP+1,N+2*NP
74782 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
74783 IMAX=I
74784 PMAX=P(I,5)
74785 230 CONTINUE
74786 DO 240 J=1,5
74787 P(N+NPRE,J)=P(IMAX,J)
74788 240 CONTINUE
74789 NREM=NREM-1
74790 K(IMAX,4)=NPRE
74791
74792C...Sum up precluster around it according to pT separation.
74793 IF(MSTU(46).LE.2) THEN
74794 DO 260 I=N+NP+1,N+2*NP
74795 IF(K(I,4).NE.0) GOTO 260
74796 R2=R2T(I,IMAX)
74797 IF(R2.GT.RINIT**2) GOTO 260
74798 NREM=NREM-1
74799 K(I,4)=NPRE
74800 DO 250 J=1,4
74801 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
74802 250 CONTINUE
74803 260 CONTINUE
74804 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74805
74806C...Sum up precluster around it according to mass or
74807C...Durham pT separation.
74808 ELSE
74809 270 IMIN=0
74810 R2MIN=RINIT**2
74811 DO 280 I=N+NP+1,N+2*NP
74812 IF(K(I,4).NE.0) GOTO 280
74813 IF(MSTU(46).LE.4) THEN
74814 R2=R2M(I,N+NPRE)
74815 ELSE
74816 R2=R2D(I,N+NPRE)
74817 ENDIF
74818 IF(R2.GE.R2MIN) GOTO 280
74819 IMIN=I
74820 R2MIN=R2
74821 280 CONTINUE
74822 IF(IMIN.NE.0) THEN
74823 DO 290 J=1,4
74824 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
74825 290 CONTINUE
74826 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74827 NREM=NREM-1
74828 K(IMIN,4)=NPRE
74829 GOTO 270
74830 ENDIF
74831 ENDIF
74832
74833C...Check if more preclusters to be found. Start over if too few.
74834 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74835 IF(NREM.GT.0) GOTO 220
74836 NJET=NPRE
74837
74838C...Reassign all particles to nearest jet. Sum up new jet momenta.
74839 300 TSAV=0D0
74840 PSJT=0D0
74841 310 IF(MSTU(46).LE.1) THEN
74842 DO 330 I=N+1,N+NJET
74843 DO 320 J=1,4
74844 V(I,J)=0D0
74845 320 CONTINUE
74846 330 CONTINUE
74847 DO 360 I=N+NP+1,N+2*NP
74848 R2MIN=PSS**2
74849 DO 340 IJET=N+1,N+NJET
74850 IF(P(IJET,5).LT.RINIT) GOTO 340
74851 R2=R2T(I,IJET)
74852 IF(R2.GE.R2MIN) GOTO 340
74853 IMIN=IJET
74854 R2MIN=R2
74855 340 CONTINUE
74856 K(I,4)=IMIN-N
74857 DO 350 J=1,4
74858 V(IMIN,J)=V(IMIN,J)+P(I,J)
74859 350 CONTINUE
74860 360 CONTINUE
74861 PSJT=0D0
74862 DO 380 I=N+1,N+NJET
74863 DO 370 J=1,4
74864 P(I,J)=V(I,J)
74865 370 CONTINUE
74866 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74867 PSJT=PSJT+P(I,5)
74868 380 CONTINUE
74869 ENDIF
74870
74871C...Find two closest jets.
74872 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
74873 DO 400 ITRY1=N+1,N+NJET-1
74874 DO 390 ITRY2=ITRY1+1,N+NJET
74875 IF(MSTU(46).LE.2) THEN
74876 R2=R2T(ITRY1,ITRY2)
74877 ELSEIF(MSTU(46).LE.4) THEN
74878 R2=R2M(ITRY1,ITRY2)
74879 ELSE
74880 R2=R2D(ITRY1,ITRY2)
74881 ENDIF
74882 IF(R2.GE.R2MIN) GOTO 390
74883 IMIN1=ITRY1
74884 IMIN2=ITRY2
74885 R2MIN=R2
74886 390 CONTINUE
74887 400 CONTINUE
74888
74889C...If allowed, join two closest jets and start over.
74890 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
74891 IREC=MIN(IMIN1,IMIN2)
74892 IDEL=MAX(IMIN1,IMIN2)
74893 DO 410 J=1,4
74894 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
74895 410 CONTINUE
74896 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
74897 DO 430 I=IDEL+1,N+NJET
74898 DO 420 J=1,5
74899 P(I-1,J)=P(I,J)
74900 420 CONTINUE
74901 430 CONTINUE
74902 IF(MSTU(46).GE.2) THEN
74903 DO 440 I=N+NP+1,N+2*NP
74904 IORI=N+K(I,4)
74905 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
74906 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
74907 440 CONTINUE
74908 ENDIF
74909 NJET=NJET-1
74910 GOTO 300
74911
74912C...Divide up broad jet if empty cluster in list of final ones.
74913 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
74914 DO 450 I=N+1,N+NJET
74915 K(I,5)=0
74916 450 CONTINUE
74917 DO 460 I=N+NP+1,N+2*NP
74918 K(N+K(I,4),5)=K(N+K(I,4),5)+1
74919 460 CONTINUE
74920 IEMP=0
74921 DO 470 I=N+1,N+NJET
74922 IF(K(I,5).EQ.0) IEMP=I
74923 470 CONTINUE
74924 IF(IEMP.NE.0) THEN
74925 NLOOP=NLOOP+1
74926 ISPL=0
74927 R2MAX=0D0
74928 DO 480 I=N+NP+1,N+2*NP
74929 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
74930 IJET=N+K(I,4)
74931 R2=R2T(I,IJET)
74932 IF(R2.LE.R2MAX) GOTO 480
74933 ISPL=I
74934 R2MAX=R2
74935 480 CONTINUE
74936 IF(ISPL.NE.0) THEN
74937 IJET=N+K(ISPL,4)
74938 DO 490 J=1,4
74939 P(IEMP,J)=P(ISPL,J)
74940 P(IJET,J)=P(IJET,J)-P(ISPL,J)
74941 490 CONTINUE
74942 P(IEMP,5)=P(ISPL,5)
74943 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
74944 IF(NLOOP.LE.2) GOTO 300
74945 ENDIF
74946 ENDIF
74947 ENDIF
74948
74949C...If generalized thrust has not yet converged, continue iteration.
74950 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
74951 &THEN
74952 TSAV=PSJT/PSS
74953 GOTO 310
74954 ENDIF
74955
74956C...Reorder jets according to energy.
74957 DO 510 I=N+1,N+NJET
74958 DO 500 J=1,5
74959 V(I,J)=P(I,J)
74960 500 CONTINUE
74961 510 CONTINUE
74962 DO 540 INEW=N+1,N+NJET
74963 PEMAX=0D0
74964 DO 520 ITRY=N+1,N+NJET
74965 IF(V(ITRY,4).LE.PEMAX) GOTO 520
74966 IMAX=ITRY
74967 PEMAX=V(ITRY,4)
74968 520 CONTINUE
74969 K(INEW,1)=31
74970 K(INEW,2)=97
74971 K(INEW,3)=INEW-N
74972 K(INEW,4)=0
74973 DO 530 J=1,5
74974 P(INEW,J)=V(IMAX,J)
74975 530 CONTINUE
74976 V(IMAX,4)=-1D0
74977 K(IMAX,5)=INEW
74978 540 CONTINUE
74979
74980C...Clean up particle-jet assignments and jet information.
74981 DO 550 I=N+NP+1,N+2*NP
74982 IORI=K(N+K(I,4),5)
74983 K(I,4)=IORI-N
74984 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
74985 K(IORI,4)=K(IORI,4)+1
74986 550 CONTINUE
74987 IEMP=0
74988 PSJT=0D0
74989 DO 570 I=N+1,N+NJET
74990 K(I,5)=0
74991 PSJT=PSJT+P(I,5)
74992 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
74993 DO 560 J=1,5
74994 V(I,J)=0D0
74995 560 CONTINUE
74996 IF(K(I,4).EQ.0) IEMP=I
74997 570 CONTINUE
74998
74999C...Select storing option. Output variables. Check for failure.
75000 MSTU(61)=N+1
75001 MSTU(62)=NP
75002 MSTU(63)=NPRE
75003 PARU(61)=PS(5)
75004 PARU(62)=PSJT/PSS
75005 PARU(63)=SQRT(R2MIN)
75006 IF(NJET.LE.1) PARU(63)=0D0
75007 IF(IEMP.NE.0) THEN
75008 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
75009 NJET=-1
75010 RETURN
75011 ENDIF
75012 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75013 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75014 NSAV=NJET
75015
75016 RETURN
75017 END
75018
75019C*********************************************************************
75020
75021C...PYCELL
75022C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75023C...as used for calorimeters at hadron colliders.
75024
75025 SUBROUTINE PYCELL(NJET)
75026
75027C...Double precision and integer declarations.
75028 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75029 IMPLICIT INTEGER(I-N)
75030 INTEGER PYK,PYCHGE,PYCOMP
75031C...Parameter statement to help give large particle numbers.
75032 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75033 &KEXCIT=4000000,KDIMEN=5000000)
75034C...Commonblocks.
75035 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75036 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75037 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75038 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75039
75040C...Loop over all particles. Find cell that was hit by given particle.
75041 PTLRAT=1D0/SINH(PARU(51))**2
75042 NP=0
75043 NC=N
75044 DO 110 I=1,N
75045 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75046 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
75047 IF(MSTU(41).GE.2) THEN
75048 KC=PYCOMP(K(I,2))
75049 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75050 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75051 & K(I,2).EQ.KSUSY1+39) GOTO 110
75052 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75053 & GOTO 110
75054 ENDIF
75055 NP=NP+1
75056 PT=SQRT(P(I,1)**2+P(I,2)**2)
75057 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
75058 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
75059 & (ETA/PARU(51)+1D0))))
75060 PHI=PYANGL(P(I,1),P(I,2))
75061 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
75062 & (PHI/PARU(1)+1D0))))
75063 IETPH=MSTU(52)*IETA+IPHI
75064
75065C...Add to cell already hit, or book new cell.
75066 DO 100 IC=N+1,NC
75067 IF(IETPH.EQ.K(IC,3)) THEN
75068 K(IC,4)=K(IC,4)+1
75069 P(IC,5)=P(IC,5)+PT
75070 GOTO 110
75071 ENDIF
75072 100 CONTINUE
75073 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
75074 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75075 NJET=-2
75076 RETURN
75077 ENDIF
75078 NC=NC+1
75079 K(NC,3)=IETPH
75080 K(NC,4)=1
75081 K(NC,5)=2
75082 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
75083 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
75084 P(NC,5)=PT
75085 110 CONTINUE
75086
75087C...Smear true bin content by calorimeter resolution.
75088 IF(MSTU(53).GE.1) THEN
75089 DO 130 IC=N+1,NC
75090 PEI=P(IC,5)
75091 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
75092 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
75093 & COS(PARU(2)*PYR(0))
75094 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
75095 P(IC,5)=PEF
75096 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
75097 130 CONTINUE
75098 ENDIF
75099
75100C...Remove cells below threshold.
75101 IF(PARU(58).GT.0D0) THEN
75102 NCC=NC
75103 NC=N
75104 DO 140 IC=N+1,NCC
75105 IF(P(IC,5).GT.PARU(58)) THEN
75106 NC=NC+1
75107 K(NC,3)=K(IC,3)
75108 K(NC,4)=K(IC,4)
75109 K(NC,5)=K(IC,5)
75110 P(NC,1)=P(IC,1)
75111 P(NC,2)=P(IC,2)
75112 P(NC,5)=P(IC,5)
75113 ENDIF
75114 140 CONTINUE
75115 ENDIF
75116
75117C...Find initiator cell: the one with highest pT of not yet used ones.
75118 NJ=NC
75119 150 ETMAX=0D0
75120 DO 160 IC=N+1,NC
75121 IF(K(IC,5).NE.2) GOTO 160
75122 IF(P(IC,5).LE.ETMAX) GOTO 160
75123 ICMAX=IC
75124 ETA=P(IC,1)
75125 PHI=P(IC,2)
75126 ETMAX=P(IC,5)
75127 160 CONTINUE
75128 IF(ETMAX.LT.PARU(52)) GOTO 220
75129 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
75130 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75131 NJET=-2
75132 RETURN
75133 ENDIF
75134 K(ICMAX,5)=1
75135 NJ=NJ+1
75136 K(NJ,4)=0
75137 K(NJ,5)=1
75138 P(NJ,1)=ETA
75139 P(NJ,2)=PHI
75140 P(NJ,3)=0D0
75141 P(NJ,4)=0D0
75142 P(NJ,5)=0D0
75143
75144C...Sum up unused cells within required distance of initiator.
75145 DO 170 IC=N+1,NC
75146 IF(K(IC,5).EQ.0) GOTO 170
75147 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
75148 DPHIA=ABS(P(IC,2)-PHI)
75149 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
75150 PHIC=P(IC,2)
75151 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
75152 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
75153 K(IC,5)=-K(IC,5)
75154 K(NJ,4)=K(NJ,4)+K(IC,4)
75155 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
75156 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
75157 P(NJ,5)=P(NJ,5)+P(IC,5)
75158 170 CONTINUE
75159
75160C...Reject cluster below minimum ET, else accept.
75161 IF(P(NJ,5).LT.PARU(53)) THEN
75162 NJ=NJ-1
75163 DO 180 IC=N+1,NC
75164 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
75165 180 CONTINUE
75166 ELSEIF(MSTU(54).LE.2) THEN
75167 P(NJ,3)=P(NJ,3)/P(NJ,5)
75168 P(NJ,4)=P(NJ,4)/P(NJ,5)
75169 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
75170 & P(NJ,4))
75171 DO 190 IC=N+1,NC
75172 IF(K(IC,5).LT.0) K(IC,5)=0
75173 190 CONTINUE
75174 ELSE
75175 DO 200 J=1,4
75176 P(NJ,J)=0D0
75177 200 CONTINUE
75178 DO 210 IC=N+1,NC
75179 IF(K(IC,5).GE.0) GOTO 210
75180 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
75181 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
75182 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
75183 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
75184 K(IC,5)=0
75185 210 CONTINUE
75186 ENDIF
75187 GOTO 150
75188
75189C...Arrange clusters in falling ET sequence.
75190 220 DO 250 I=1,NJ-NC
75191 ETMAX=0D0
75192 DO 230 IJ=NC+1,NJ
75193 IF(K(IJ,5).EQ.0) GOTO 230
75194 IF(P(IJ,5).LT.ETMAX) GOTO 230
75195 IJMAX=IJ
75196 ETMAX=P(IJ,5)
75197 230 CONTINUE
75198 K(IJMAX,5)=0
75199 K(N+I,1)=31
75200 K(N+I,2)=98
75201 K(N+I,3)=I
75202 K(N+I,4)=K(IJMAX,4)
75203 K(N+I,5)=0
75204 DO 240 J=1,5
75205 P(N+I,J)=P(IJMAX,J)
75206 V(N+I,J)=0D0
75207 240 CONTINUE
75208 250 CONTINUE
75209 NJET=NJ-NC
75210
75211C...Convert to massless or massive four-vectors.
75212 IF(MSTU(54).EQ.2) THEN
75213 DO 260 I=N+1,N+NJET
75214 ETA=P(I,3)
75215 P(I,1)=P(I,5)*COS(P(I,4))
75216 P(I,2)=P(I,5)*SIN(P(I,4))
75217 P(I,3)=P(I,5)*SINH(ETA)
75218 P(I,4)=P(I,5)*COSH(ETA)
75219 P(I,5)=0D0
75220 260 CONTINUE
75221 ELSEIF(MSTU(54).GE.3) THEN
75222 DO 270 I=N+1,N+NJET
75223 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
75224 270 CONTINUE
75225 ENDIF
75226
75227C...Information about storage.
75228 MSTU(61)=N+1
75229 MSTU(62)=NP
75230 MSTU(63)=NC-N
75231 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75232 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75233
75234 RETURN
75235 END
75236
75237C*********************************************************************
75238
75239C...PYJMAS
75240C...Determines, approximately, the two jet masses that minimize
75241C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75242
75243 SUBROUTINE PYJMAS(PMH,PML)
75244
75245C...Double precision and integer declarations.
75246 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75247 IMPLICIT INTEGER(I-N)
75248 INTEGER PYK,PYCHGE,PYCOMP
75249C...Parameter statement to help give large particle numbers.
75250 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75251 &KEXCIT=4000000,KDIMEN=5000000)
75252C...Commonblocks.
75253 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75254 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75255 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75256 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75257C...Local arrays.
75258 DIMENSION SM(3,3),SAX(3),PS(3,5)
75259
75260C...Reset.
75261 NP=0
75262 DO 120 J1=1,3
75263 DO 100 J2=J1,3
75264 SM(J1,J2)=0D0
75265 100 CONTINUE
75266 DO 110 J2=1,4
75267 PS(J1,J2)=0D0
75268 110 CONTINUE
75269 120 CONTINUE
75270 PSS=0D0
75271 PIMASS=PMAS(PYCOMP(211),1)
75272
75273C...Take copy of particles that are to be considered in mass analysis.
75274 DO 170 I=1,N
75275 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
75276 IF(MSTU(41).GE.2) THEN
75277 KC=PYCOMP(K(I,2))
75278 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75279 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75280 & K(I,2).EQ.KSUSY1+39) GOTO 170
75281 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75282 & GOTO 170
75283 ENDIF
75284 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
75285 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
75286 PMH=-2D0
75287 PML=-2D0
75288 RETURN
75289 ENDIF
75290 NP=NP+1
75291 DO 130 J=1,5
75292 P(N+NP,J)=P(I,J)
75293 130 CONTINUE
75294 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
75295 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
75296 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
75297
75298C...Fill information in sphericity tensor and total momentum vector.
75299 DO 150 J1=1,3
75300 DO 140 J2=J1,3
75301 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
75302 140 CONTINUE
75303 150 CONTINUE
75304 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75305 DO 160 J=1,4
75306 PS(3,J)=PS(3,J)+P(N+NP,J)
75307 160 CONTINUE
75308 170 CONTINUE
75309
75310C...Very low multiplicities (0 or 1) not considered.
75311 IF(NP.LE.1) THEN
75312 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
75313 PMH=-1D0
75314 PML=-1D0
75315 RETURN
75316 ENDIF
75317 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
75318 &PS(3,3)**2))
75319
75320C...Find largest eigenvalue to matrix (third degree equation).
75321 DO 190 J1=1,3
75322 DO 180 J2=J1,3
75323 SM(J1,J2)=SM(J1,J2)/PSS
75324 180 CONTINUE
75325 190 CONTINUE
75326 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
75327 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
75328 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
75329 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
75330 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
75331 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
75332 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
75333
75334C...Find largest eigenvector by solving equation system.
75335 DO 210 J1=1,3
75336 SM(J1,J1)=SM(J1,J1)-SMA
75337 DO 200 J2=J1+1,3
75338 SM(J2,J1)=SM(J1,J2)
75339 200 CONTINUE
75340 210 CONTINUE
75341 SMAX=0D0
75342 DO 230 J1=1,3
75343 DO 220 J2=1,3
75344 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
75345 JA=J1
75346 JB=J2
75347 SMAX=ABS(SM(J1,J2))
75348 220 CONTINUE
75349 230 CONTINUE
75350 SMAX=0D0
75351 DO 250 J3=JA+1,JA+2
75352 J1=J3-3*((J3-1)/3)
75353 RL=SM(J1,JB)/SM(JA,JB)
75354 DO 240 J2=1,3
75355 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
75356 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
75357 JC=J1
75358 SMAX=ABS(SM(J1,J2))
75359 240 CONTINUE
75360 250 CONTINUE
75361 JB1=JB+1-3*(JB/3)
75362 JB2=JB+2-3*((JB+1)/3)
75363 SAX(JB1)=-SM(JC,JB2)
75364 SAX(JB2)=SM(JC,JB1)
75365 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
75366
75367C...Divide particles into two initial clusters by hemisphere.
75368 DO 270 I=N+1,N+NP
75369 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
75370 IS=1
75371 IF(PSAX.LT.0D0) IS=2
75372 K(I,3)=IS
75373 DO 260 J=1,4
75374 PS(IS,J)=PS(IS,J)+P(I,J)
75375 260 CONTINUE
75376 270 CONTINUE
75377 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
75378 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
75379
75380C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75381 280 PMD=0D0
75382 IM=0
75383 DO 290 J=1,4
75384 PS(3,J)=PS(1,J)-PS(2,J)
75385 290 CONTINUE
75386 DO 300 I=N+1,N+NP
75387 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)
75388 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
75389 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
75390 IF(PMDI.LT.PMD) THEN
75391 PMD=PMDI
75392 IM=I
75393 ENDIF
75394 300 CONTINUE
75395
75396C...Loop back if significant reduction in sum of m^2.
75397 IF(PMD.LT.-PARU(48)*PMS) THEN
75398 PMS=PMS+PMD
75399 IS=K(IM,3)
75400 DO 310 J=1,4
75401 PS(IS,J)=PS(IS,J)-P(IM,J)
75402 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
75403 310 CONTINUE
75404 K(IM,3)=3-IS
75405 GOTO 280
75406 ENDIF
75407
75408C...Final masses and output.
75409 MSTU(61)=N+1
75410 MSTU(62)=NP
75411 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
75412 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
75413 PMH=MAX(PS(1,5),PS(2,5))
75414 PML=MIN(PS(1,5),PS(2,5))
75415
75416 RETURN
75417 END
75418
75419C*********************************************************************
75420
75421C...PYFOWO
75422C...Calculates the first few Fox-Wolfram moments.
75423
75424 SUBROUTINE PYFOWO(H10,H20,H30,H40)
75425
75426C...Double precision and integer declarations.
75427 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75428 IMPLICIT INTEGER(I-N)
75429 INTEGER PYK,PYCHGE,PYCOMP
75430C...Parameter statement to help give large particle numbers.
75431 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75432 &KEXCIT=4000000,KDIMEN=5000000)
75433C...Commonblocks.
75434 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75435 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75437 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75438
75439C...Copy momenta for particles and calculate H0.
75440 NP=0
75441 H0=0D0
75442 HD=0D0
75443 DO 110 I=1,N
75444 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75445 IF(MSTU(41).GE.2) THEN
75446 KC=PYCOMP(K(I,2))
75447 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75448 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75449 & K(I,2).EQ.KSUSY1+39) GOTO 110
75450 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75451 & GOTO 110
75452 ENDIF
75453 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
75454 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
75455 H10=-1D0
75456 H20=-1D0
75457 H30=-1D0
75458 H40=-1D0
75459 RETURN
75460 ENDIF
75461 NP=NP+1
75462 DO 100 J=1,3
75463 P(N+NP,J)=P(I,J)
75464 100 CONTINUE
75465 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75466 H0=H0+P(N+NP,4)
75467 HD=HD+P(N+NP,4)**2
75468 110 CONTINUE
75469 H0=H0**2
75470
75471C...Very low multiplicities (0 or 1) not considered.
75472 IF(NP.LE.1) THEN
75473 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
75474 H10=-1D0
75475 H20=-1D0
75476 H30=-1D0
75477 H40=-1D0
75478 RETURN
75479 ENDIF
75480
75481C...Calculate H1 - H4.
75482 H10=0D0
75483 H20=0D0
75484 H30=0D0
75485 H40=0D0
75486 DO 130 I1=N+1,N+NP
75487 DO 120 I2=I1+1,N+NP
75488 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
75489 & (P(I1,4)*P(I2,4))
75490 H10=H10+P(I1,4)*P(I2,4)*CTHE
75491 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
75492 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
75493 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
75494 & 0.375D0)
75495 120 CONTINUE
75496 130 CONTINUE
75497
75498C...Calculate H1/H0 - H4/H0. Output.
75499 MSTU(61)=N+1
75500 MSTU(62)=NP
75501 H10=(HD+2D0*H10)/H0
75502 H20=(HD+2D0*H20)/H0
75503 H30=(HD+2D0*H30)/H0
75504 H40=(HD+2D0*H40)/H0
75505
75506 RETURN
75507 END
75508
75509C*********************************************************************
75510
75511C...PYTABU
75512C...Evaluates various properties of an event, with statistics
75513C...accumulated during the course of the run and
75514C...printed at the end.
75515
75516 SUBROUTINE PYTABU(MTABU)
75517
75518C...Double precision and integer declarations.
75519 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75520 IMPLICIT INTEGER(I-N)
75521 INTEGER PYK,PYCHGE,PYCOMP
75522C...Parameter statement to help give large particle numbers.
75523 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75524 &KEXCIT=4000000,KDIMEN=5000000)
75525C...Commonblocks.
75526 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75527 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75528 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75529 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75530 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
75531C...Local arrays, character variables, saved variables and data.
75532 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
75533 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
75534 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
75535 &KFDM(8),KFDC(200,0:8),NPDC(200)
75536 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
75537 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
75538 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
75539 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75540 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
75541 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
75542 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
75543 &NEVDC/0/,NKFDC/0/,NREDC/0/
75544
75545C...Reset statistics on initial parton state.
75546 IF(MTABU.EQ.10) THEN
75547 NEVIS=0
75548 NKFIS=0
75549
75550C...Identify and order flavour content of initial state.
75551 ELSEIF(MTABU.EQ.11) THEN
75552 NEVIS=NEVIS+1
75553 KFM1=2*IABS(MSTU(161))
75554 IF(MSTU(161).GT.0) KFM1=KFM1-1
75555 KFM2=2*IABS(MSTU(162))
75556 IF(MSTU(162).GT.0) KFM2=KFM2-1
75557 KFMN=MIN(KFM1,KFM2)
75558 KFMX=MAX(KFM1,KFM2)
75559 DO 100 I=1,NKFIS
75560 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
75561 IKFIS=-I
75562 GOTO 110
75563 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
75564 & KFMX.LT.KFIS(I,2))) THEN
75565 IKFIS=I
75566 GOTO 110
75567 ENDIF
75568 100 CONTINUE
75569 IKFIS=NKFIS+1
75570 110 IF(IKFIS.LT.0) THEN
75571 IKFIS=-IKFIS
75572 ELSE
75573 IF(NKFIS.GE.100) RETURN
75574 DO 130 I=NKFIS,IKFIS,-1
75575 KFIS(I+1,1)=KFIS(I,1)
75576 KFIS(I+1,2)=KFIS(I,2)
75577 DO 120 J=0,10
75578 NPIS(I+1,J)=NPIS(I,J)
75579 120 CONTINUE
75580 130 CONTINUE
75581 NKFIS=NKFIS+1
75582 KFIS(IKFIS,1)=KFMN
75583 KFIS(IKFIS,2)=KFMX
75584 DO 140 J=0,10
75585 NPIS(IKFIS,J)=0
75586 140 CONTINUE
75587 ENDIF
75588 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
75589
75590C...Count number of partons in initial state.
75591 NP=0
75592 DO 160 I=1,N
75593 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
75594 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
75595 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
75596 & THEN
75597 ELSE
75598 IM=I
75599 150 IM=K(IM,3)
75600 IF(IM.LE.0.OR.IM.GT.N) THEN
75601 NP=NP+1
75602 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75603 NP=NP+1
75604 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
75605 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
75606 & .NE.0) THEN
75607 ELSE
75608 GOTO 150
75609 ENDIF
75610 ENDIF
75611 160 CONTINUE
75612 NPCO=MAX(NP,1)
75613 IF(NP.GE.6) NPCO=6
75614 IF(NP.GE.8) NPCO=7
75615 IF(NP.GE.11) NPCO=8
75616 IF(NP.GE.16) NPCO=9
75617 IF(NP.GE.26) NPCO=10
75618 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
75619 MSTU(62)=NP
75620
75621C...Write statistics on initial parton state.
75622 ELSEIF(MTABU.EQ.12) THEN
75623 FAC=1D0/MAX(1,NEVIS)
75624 WRITE(MSTU(11),5000) NEVIS
75625 DO 170 I=1,NKFIS
75626 KFMN=KFIS(I,1)
75627 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75628 KFM1=(KFMN+1)/2
75629 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75630 CALL PYNAME(KFM1,CHAU)
75631 CHIS(1)=CHAU(1:12)
75632 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
75633 KFMX=KFIS(I,2)
75634 IF(KFIS(I,1).EQ.0) KFMX=0
75635 KFM2=(KFMX+1)/2
75636 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75637 CALL PYNAME(KFM2,CHAU)
75638 CHIS(2)=CHAU(1:12)
75639 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
75640 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
75641 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
75642 170 CONTINUE
75643
75644C...Copy statistics on initial parton state into /PYJETS/.
75645 ELSEIF(MTABU.EQ.13) THEN
75646 FAC=1D0/MAX(1,NEVIS)
75647 DO 190 I=1,NKFIS
75648 KFMN=KFIS(I,1)
75649 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75650 KFM1=(KFMN+1)/2
75651 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75652 KFMX=KFIS(I,2)
75653 IF(KFIS(I,1).EQ.0) KFMX=0
75654 KFM2=(KFMX+1)/2
75655 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75656 K(I,1)=32
75657 K(I,2)=99
75658 K(I,3)=KFM1
75659 K(I,4)=KFM2
75660 K(I,5)=NPIS(I,0)
75661 DO 180 J=1,5
75662 P(I,J)=FAC*NPIS(I,J)
75663 V(I,J)=FAC*NPIS(I,J+5)
75664 180 CONTINUE
75665 190 CONTINUE
75666 N=NKFIS
75667 DO 200 J=1,5
75668 K(N+1,J)=0
75669 P(N+1,J)=0D0
75670 V(N+1,J)=0D0
75671 200 CONTINUE
75672 K(N+1,1)=32
75673 K(N+1,2)=99
75674 K(N+1,5)=NEVIS
75675 MSTU(3)=1
75676
75677C...Reset statistics on number of particles/partons.
75678 ELSEIF(MTABU.EQ.20) THEN
75679 NEVFS=0
75680 NPRFS=0
75681 NFIFS=0
75682 NCHFS=0
75683 NKFFS=0
75684
75685C...Identify whether particle/parton is primary or not.
75686 ELSEIF(MTABU.EQ.21) THEN
75687 NEVFS=NEVFS+1
75688 MSTU(62)=0
75689 DO 260 I=1,N
75690 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
75691 MSTU(62)=MSTU(62)+1
75692 KC=PYCOMP(K(I,2))
75693 MPRI=0
75694 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
75695 MPRI=1
75696 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
75697 MPRI=1
75698 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
75699 MPRI=1
75700 ELSEIF(KC.EQ.0) THEN
75701 ELSEIF(K(K(I,3),1).EQ.13) THEN
75702 IM=K(K(I,3),3)
75703 IF(IM.LE.0.OR.IM.GT.N) THEN
75704 MPRI=1
75705 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75706 MPRI=1
75707 ENDIF
75708 ELSEIF(KCHG(KC,2).EQ.0) THEN
75709 KCM=PYCOMP(K(K(I,3),2))
75710 IF(KCM.NE.0) THEN
75711 IF(KCHG(KCM,2).NE.0) MPRI=1
75712 ENDIF
75713 ENDIF
75714 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
75715 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
75716 ENDIF
75717 IF(K(I,1).LE.10) THEN
75718 NFIFS=NFIFS+1
75719 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
75720 ENDIF
75721
75722C...Fill statistics on number of particles/partons in event.
75723 KFA=IABS(K(I,2))
75724 KFS=3-ISIGN(1,K(I,2))-MPRI
75725 DO 210 IP=1,NKFFS
75726 IF(KFA.EQ.KFFS(IP)) THEN
75727 IKFFS=-IP
75728 GOTO 220
75729 ELSEIF(KFA.LT.KFFS(IP)) THEN
75730 IKFFS=IP
75731 GOTO 220
75732 ENDIF
75733 210 CONTINUE
75734 IKFFS=NKFFS+1
75735 220 IF(IKFFS.LT.0) THEN
75736 IKFFS=-IKFFS
75737 ELSE
75738 IF(NKFFS.GE.400) RETURN
75739 DO 240 IP=NKFFS,IKFFS,-1
75740 KFFS(IP+1)=KFFS(IP)
75741 DO 230 J=1,4
75742 NPFS(IP+1,J)=NPFS(IP,J)
75743 230 CONTINUE
75744 240 CONTINUE
75745 NKFFS=NKFFS+1
75746 KFFS(IKFFS)=KFA
75747 DO 250 J=1,4
75748 NPFS(IKFFS,J)=0
75749 250 CONTINUE
75750 ENDIF
75751 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
75752 260 CONTINUE
75753
75754C...Write statistics on particle/parton composition of events.
75755 ELSEIF(MTABU.EQ.22) THEN
75756 FAC=1D0/MAX(1,NEVFS)
75757 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
75758 DO 270 I=1,NKFFS
75759 CALL PYNAME(KFFS(I),CHAU)
75760 KC=PYCOMP(KFFS(I))
75761 MDCYF=0
75762 IF(KC.NE.0) MDCYF=MDCY(KC,1)
75763 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
75764 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
75765 270 CONTINUE
75766
75767C...Copy particle/parton composition information into /PYJETS/.
75768 ELSEIF(MTABU.EQ.23) THEN
75769 FAC=1D0/MAX(1,NEVFS)
75770 DO 290 I=1,NKFFS
75771 K(I,1)=32
75772 K(I,2)=99
75773 K(I,3)=KFFS(I)
75774 K(I,4)=0
75775 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
75776 DO 280 J=1,4
75777 P(I,J)=FAC*NPFS(I,J)
75778 V(I,J)=0D0
75779 280 CONTINUE
75780 P(I,5)=FAC*K(I,5)
75781 V(I,5)=0D0
75782 290 CONTINUE
75783 N=NKFFS
75784 DO 300 J=1,5
75785 K(N+1,J)=0
75786 P(N+1,J)=0D0
75787 V(N+1,J)=0D0
75788 300 CONTINUE
75789 K(N+1,1)=32
75790 K(N+1,2)=99
75791 K(N+1,5)=NEVFS
75792 P(N+1,1)=FAC*NPRFS
75793 P(N+1,2)=FAC*NFIFS
75794 P(N+1,3)=FAC*NCHFS
75795 MSTU(3)=1
75796
75797C...Reset factorial moments statistics.
75798 ELSEIF(MTABU.EQ.30) THEN
75799 NEVFM=0
75800 NMUFM=0
75801 DO 330 IM=1,3
75802 DO 320 IB=1,10
75803 DO 310 IP=1,4
75804 FM1FM(IM,IB,IP)=0D0
75805 FM2FM(IM,IB,IP)=0D0
75806 310 CONTINUE
75807 320 CONTINUE
75808 330 CONTINUE
75809
75810C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75811 ELSEIF(MTABU.EQ.31) THEN
75812 NEVFM=NEVFM+1
75813 NLOW=N+MSTU(3)
75814 NUPP=NLOW
75815 DO 410 I=1,N
75816 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
75817 IF(MSTU(41).GE.2) THEN
75818 KC=PYCOMP(K(I,2))
75819 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75820 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75821 & K(I,2).EQ.KSUSY1+39) GOTO 410
75822 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
75823 & PYCHGE(K(I,2)).EQ.0) GOTO 410
75824 ENDIF
75825 PMR=0D0
75826 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
75827 IF(MSTU(42).GE.2) PMR=P(I,5)
75828 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
75829 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
75830 & 1D20)),P(I,3))
75831 IF(ABS(YETA).GT.PARU(57)) GOTO 410
75832 PHI=PYANGL(P(I,1),P(I,2))
75833 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
75834 IYETA=MAX(0,MIN(511,IYETA))
75835 IPHI=512D0*(PHI+PARU(1))/PARU(2)
75836 IPHI=MAX(0,MIN(511,IPHI))
75837 IYEP=0
75838 DO 340 IB=0,9
75839 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
75840 340 CONTINUE
75841
75842C...Order particles in (pseudo)rapidity and/or azimuth.
75843 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
75844 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
75845 RETURN
75846 ENDIF
75847 NUPP=NUPP+1
75848 IF(NUPP.EQ.NLOW+1) THEN
75849 K(NUPP,1)=IYETA
75850 K(NUPP,2)=IPHI
75851 K(NUPP,3)=IYEP
75852 ELSE
75853 DO 350 I1=NUPP-1,NLOW+1,-1
75854 IF(IYETA.GE.K(I1,1)) GOTO 360
75855 K(I1+1,1)=K(I1,1)
75856 350 CONTINUE
75857 360 K(I1+1,1)=IYETA
75858 DO 370 I1=NUPP-1,NLOW+1,-1
75859 IF(IPHI.GE.K(I1,2)) GOTO 380
75860 K(I1+1,2)=K(I1,2)
75861 370 CONTINUE
75862 380 K(I1+1,2)=IPHI
75863 DO 390 I1=NUPP-1,NLOW+1,-1
75864 IF(IYEP.GE.K(I1,3)) GOTO 400
75865 K(I1+1,3)=K(I1,3)
75866 390 CONTINUE
75867 400 K(I1+1,3)=IYEP
75868 ENDIF
75869 410 CONTINUE
75870 K(NUPP+1,1)=2**10
75871 K(NUPP+1,2)=2**10
75872 K(NUPP+1,3)=4**10
75873
75874C...Calculate sum of factorial moments in event.
75875 DO 480 IM=1,3
75876 DO 430 IB=1,10
75877 DO 420 IP=1,4
75878 FEVFM(IB,IP)=0D0
75879 420 CONTINUE
75880 430 CONTINUE
75881 DO 450 IB=1,10
75882 IF(IM.LE.2) IBIN=2**(10-IB)
75883 IF(IM.EQ.3) IBIN=4**(10-IB)
75884 IAGR=K(NLOW+1,IM)/IBIN
75885 NAGR=1
75886 DO 440 I=NLOW+2,NUPP+1
75887 ICUT=K(I,IM)/IBIN
75888 IF(ICUT.EQ.IAGR) THEN
75889 NAGR=NAGR+1
75890 ELSE
75891 IF(NAGR.EQ.1) THEN
75892 ELSEIF(NAGR.EQ.2) THEN
75893 FEVFM(IB,1)=FEVFM(IB,1)+2D0
75894 ELSEIF(NAGR.EQ.3) THEN
75895 FEVFM(IB,1)=FEVFM(IB,1)+6D0
75896 FEVFM(IB,2)=FEVFM(IB,2)+6D0
75897 ELSEIF(NAGR.EQ.4) THEN
75898 FEVFM(IB,1)=FEVFM(IB,1)+12D0
75899 FEVFM(IB,2)=FEVFM(IB,2)+24D0
75900 FEVFM(IB,3)=FEVFM(IB,3)+24D0
75901 ELSE
75902 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
75903 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
75904 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75905 & (NAGR-3D0)
75906 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75907 & (NAGR-3D0)*(NAGR-4D0)
75908 ENDIF
75909 IAGR=ICUT
75910 NAGR=1
75911 ENDIF
75912 440 CONTINUE
75913 450 CONTINUE
75914
75915C...Add results to total statistics.
75916 DO 470 IB=10,1,-1
75917 DO 460 IP=1,4
75918 IF(FEVFM(1,IP).LT.0.5D0) THEN
75919 FEVFM(IB,IP)=0D0
75920 ELSEIF(IM.LE.2) THEN
75921 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75922 ELSE
75923 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75924 ENDIF
75925 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
75926 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
75927 460 CONTINUE
75928 470 CONTINUE
75929 480 CONTINUE
75930 NMUFM=NMUFM+(NUPP-NLOW)
75931 MSTU(62)=NUPP-NLOW
75932
75933C...Write accumulated statistics on factorial moments.
75934 ELSEIF(MTABU.EQ.32) THEN
75935 FAC=1D0/MAX(1,NEVFM)
75936 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
75937 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
75938 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
75939 DO 510 IM=1,3
75940 WRITE(MSTU(11),5500)
75941 DO 500 IB=1,10
75942 BYETA=2D0*PARU(57)
75943 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
75944 BPHI=PARU(2)
75945 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
75946 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
75947 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
75948 DO 490 IP=1,4
75949 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
75950 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75951 & FMOMA(IP)**2)))
75952 490 CONTINUE
75953 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
75954 & IP=1,4)
75955 500 CONTINUE
75956 510 CONTINUE
75957
75958C...Copy statistics on factorial moments into /PYJETS/.
75959 ELSEIF(MTABU.EQ.33) THEN
75960 FAC=1D0/MAX(1,NEVFM)
75961 DO 540 IM=1,3
75962 DO 530 IB=1,10
75963 I=10*(IM-1)+IB
75964 K(I,1)=32
75965 K(I,2)=99
75966 K(I,3)=1
75967 IF(IM.NE.2) K(I,3)=2**(IB-1)
75968 K(I,4)=1
75969 IF(IM.NE.1) K(I,4)=2**(IB-1)
75970 K(I,5)=0
75971 P(I,1)=2D0*PARU(57)/K(I,3)
75972 V(I,1)=PARU(2)/K(I,4)
75973 DO 520 IP=1,4
75974 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
75975 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75976 & P(I,IP+1)**2)))
75977 520 CONTINUE
75978 530 CONTINUE
75979 540 CONTINUE
75980 N=30
75981 DO 550 J=1,5
75982 K(N+1,J)=0
75983 P(N+1,J)=0D0
75984 V(N+1,J)=0D0
75985 550 CONTINUE
75986 K(N+1,1)=32
75987 K(N+1,2)=99
75988 K(N+1,5)=NEVFM
75989 MSTU(3)=1
75990
75991C...Reset statistics on Energy-Energy Correlation.
75992 ELSEIF(MTABU.EQ.40) THEN
75993 NEVEE=0
75994 DO 560 J=1,25
75995 FE1EC(J)=0D0
75996 FE2EC(J)=0D0
75997 FE1EC(51-J)=0D0
75998 FE2EC(51-J)=0D0
75999 FE1EA(J)=0D0
76000 FE2EA(J)=0D0
76001 560 CONTINUE
76002
76003C...Find particles to include, with proper assumed mass.
76004 ELSEIF(MTABU.EQ.41) THEN
76005 NEVEE=NEVEE+1
76006 NLOW=N+MSTU(3)
76007 NUPP=NLOW
76008 ECM=0D0
76009 DO 570 I=1,N
76010 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
76011 IF(MSTU(41).GE.2) THEN
76012 KC=PYCOMP(K(I,2))
76013 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76014 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76015 & K(I,2).EQ.KSUSY1+39) GOTO 570
76016 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
76017 & PYCHGE(K(I,2)).EQ.0) GOTO 570
76018 ENDIF
76019 PMR=0D0
76020 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
76021 IF(MSTU(42).GE.2) PMR=P(I,5)
76022 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
76023 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
76024 RETURN
76025 ENDIF
76026 NUPP=NUPP+1
76027 P(NUPP,1)=P(I,1)
76028 P(NUPP,2)=P(I,2)
76029 P(NUPP,3)=P(I,3)
76030 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76031 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
76032 ECM=ECM+P(NUPP,4)
76033 570 CONTINUE
76034 IF(NUPP.EQ.NLOW) RETURN
76035
76036C...Analyze Energy-Energy Correlation in event.
76037 FAC=(2D0/ECM**2)*50D0/PARU(1)
76038 DO 580 J=1,50
76039 FEVEE(J)=0D0
76040 580 CONTINUE
76041 DO 600 I1=NLOW+2,NUPP
76042 DO 590 I2=NLOW+1,I1-1
76043 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
76044 & (P(I1,5)*P(I2,5))
76045 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
76046 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
76047 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
76048 590 CONTINUE
76049 600 CONTINUE
76050 DO 610 J=1,25
76051 FE1EC(J)=FE1EC(J)+FEVEE(J)
76052 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
76053 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
76054 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
76055 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
76056 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
76057 610 CONTINUE
76058 MSTU(62)=NUPP-NLOW
76059
76060C...Write statistics on Energy-Energy Correlation.
76061 ELSEIF(MTABU.EQ.42) THEN
76062 FAC=1D0/MAX(1,NEVEE)
76063 WRITE(MSTU(11),5700) NEVEE
76064 DO 620 J=1,25
76065 FEEC1=FAC*FE1EC(J)
76066 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
76067 FEEC2=FAC*FE1EC(51-J)
76068 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
76069 FEECA=FAC*FE1EA(J)
76070 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
76071 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
76072 & FEEC2,FEES2,FEECA,FEESA
76073 620 CONTINUE
76074
76075C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76076 ELSEIF(MTABU.EQ.43) THEN
76077 FAC=1D0/MAX(1,NEVEE)
76078 DO 630 I=1,25
76079 K(I,1)=32
76080 K(I,2)=99
76081 K(I,3)=0
76082 K(I,4)=0
76083 K(I,5)=0
76084 P(I,1)=FAC*FE1EC(I)
76085 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
76086 P(I,2)=FAC*FE1EC(51-I)
76087 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
76088 P(I,3)=FAC*FE1EA(I)
76089 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
76090 P(I,4)=PARU(1)*(I-1)/50D0
76091 P(I,5)=PARU(1)*I/50D0
76092 V(I,4)=3.6D0*(I-1)
76093 V(I,5)=3.6D0*I
76094 630 CONTINUE
76095 N=25
76096 DO 640 J=1,5
76097 K(N+1,J)=0
76098 P(N+1,J)=0D0
76099 V(N+1,J)=0D0
76100 640 CONTINUE
76101 K(N+1,1)=32
76102 K(N+1,2)=99
76103 K(N+1,5)=NEVEE
76104 MSTU(3)=1
76105
76106C...Reset statistics on decay channels.
76107 ELSEIF(MTABU.EQ.50) THEN
76108 NEVDC=0
76109 NKFDC=0
76110 NREDC=0
76111
76112C...Identify and order flavour content of final state.
76113 ELSEIF(MTABU.EQ.51) THEN
76114 NEVDC=NEVDC+1
76115 NDS=0
76116 DO 670 I=1,N
76117 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
76118 NDS=NDS+1
76119 IF(NDS.GT.8) THEN
76120 NREDC=NREDC+1
76121 RETURN
76122 ENDIF
76123 KFM=2*IABS(K(I,2))
76124 IF(K(I,2).LT.0) KFM=KFM-1
76125 DO 650 IDS=NDS-1,1,-1
76126 IIN=IDS+1
76127 IF(KFM.LT.KFDM(IDS)) GOTO 660
76128 KFDM(IDS+1)=KFDM(IDS)
76129 650 CONTINUE
76130 IIN=1
76131 660 KFDM(IIN)=KFM
76132 670 CONTINUE
76133
76134C...Find whether old or new final state.
76135 DO 690 IDC=1,NKFDC
76136 IF(NDS.LT.KFDC(IDC,0)) THEN
76137 IKFDC=IDC
76138 GOTO 700
76139 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
76140 DO 680 I=1,NDS
76141 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
76142 IKFDC=IDC
76143 GOTO 700
76144 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
76145 GOTO 690
76146 ENDIF
76147 680 CONTINUE
76148 IKFDC=-IDC
76149 GOTO 700
76150 ENDIF
76151 690 CONTINUE
76152 IKFDC=NKFDC+1
76153 700 IF(IKFDC.LT.0) THEN
76154 IKFDC=-IKFDC
76155 ELSEIF(NKFDC.GE.200) THEN
76156 NREDC=NREDC+1
76157 RETURN
76158 ELSE
76159 DO 720 IDC=NKFDC,IKFDC,-1
76160 NPDC(IDC+1)=NPDC(IDC)
76161 DO 710 I=0,8
76162 KFDC(IDC+1,I)=KFDC(IDC,I)
76163 710 CONTINUE
76164 720 CONTINUE
76165 NKFDC=NKFDC+1
76166 KFDC(IKFDC,0)=NDS
76167 DO 730 I=1,NDS
76168 KFDC(IKFDC,I)=KFDM(I)
76169 730 CONTINUE
76170 NPDC(IKFDC)=0
76171 ENDIF
76172 NPDC(IKFDC)=NPDC(IKFDC)+1
76173
76174C...Write statistics on decay channels.
76175 ELSEIF(MTABU.EQ.52) THEN
76176 FAC=1D0/MAX(1,NEVDC)
76177 WRITE(MSTU(11),5900) NEVDC
76178 DO 750 IDC=1,NKFDC
76179 DO 740 I=1,KFDC(IDC,0)
76180 KFM=KFDC(IDC,I)
76181 KF=(KFM+1)/2
76182 IF(2*KF.NE.KFM) KF=-KF
76183 CALL PYNAME(KF,CHAU)
76184 CHDC(I)=CHAU(1:12)
76185 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
76186 740 CONTINUE
76187 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
76188 750 CONTINUE
76189 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
76190
76191C...Copy statistics on decay channels into /PYJETS/.
76192 ELSEIF(MTABU.EQ.53) THEN
76193 FAC=1D0/MAX(1,NEVDC)
76194 DO 780 IDC=1,NKFDC
76195 K(IDC,1)=32
76196 K(IDC,2)=99
76197 K(IDC,3)=0
76198 K(IDC,4)=0
76199 K(IDC,5)=KFDC(IDC,0)
76200 DO 760 J=1,5
76201 P(IDC,J)=0D0
76202 V(IDC,J)=0D0
76203 760 CONTINUE
76204 DO 770 I=1,KFDC(IDC,0)
76205 KFM=KFDC(IDC,I)
76206 KF=(KFM+1)/2
76207 IF(2*KF.NE.KFM) KF=-KF
76208 IF(I.LE.5) P(IDC,I)=KF
76209 IF(I.GE.6) V(IDC,I-5)=KF
76210 770 CONTINUE
76211 V(IDC,5)=FAC*NPDC(IDC)
76212 780 CONTINUE
76213 N=NKFDC
76214 DO 790 J=1,5
76215 K(N+1,J)=0
76216 P(N+1,J)=0D0
76217 V(N+1,J)=0D0
76218 790 CONTINUE
76219 K(N+1,1)=32
76220 K(N+1,2)=99
76221 K(N+1,5)=NEVDC
76222 V(N+1,5)=FAC*NREDC
76223 MSTU(3)=1
76224 ENDIF
76225
76226C...Format statements for output on unit MSTU(11) (default 6).
76227 5000 FORMAT(///20X,'Event statistics - initial state'/
76228 &20X,'based on an analysis of ',I6,' events'//
76229 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
76230 &'according to fragmenting system multiplicity'/
76231 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
76232 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
76233 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
76234 5200 FORMAT(///20X,'Event statistics - final state'/
76235 &20X,'based on an analysis of ',I7,' events'//
76236 &5X,'Mean primary multiplicity =',F10.4/
76237 &5X,'Mean final multiplicity =',F10.4/
76238 &5X,'Mean charged multiplicity =',F10.4//
76239 &5X,'Number of particles produced per event (directly and via ',
76240 &'decays/branchings)'/
76241 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
76242 &8X,'Total'/35X,'prim seco prim seco'/)
76243 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
76244 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
76245 &20X,'based on an analysis of ',I6,' events'//
76246 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
76247 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
76248 5500 FORMAT(10X)
76249 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
76250 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
76251 &20X,'based on an analysis of ',I6,' events'//
76252 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
76253 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
76254 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
76255 5900 FORMAT(///20X,'Decay channel analysis - final state'/
76256 &20X,'based on an analysis of ',I6,' events'//
76257 &2X,'Probability',10X,'Complete final state'/)
76258 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
76259 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
76260 &'or table overflow)')
76261
76262 RETURN
76263 END
76264
76265C*********************************************************************
76266
76267C...PYEEVT
76268C...Handles the generation of an e+e- annihilation jet event.
76269
76270 SUBROUTINE PYEEVT(KFL,ECM)
76271
76272C...Double precision and integer declarations.
76273 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76274 IMPLICIT INTEGER(I-N)
76275 INTEGER PYK,PYCHGE,PYCOMP
76276C...Commonblocks.
76277 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76278 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76279 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76280 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76281
76282C...Check input parameters.
76283 IF(MSTU(12).NE.12345) CALL PYLIST(0)
76284 IF(KFL.LT.0.OR.KFL.GT.8) THEN
76285 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
76286 IF(MSTU(21).GE.1) RETURN
76287 ENDIF
76288 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
76289 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
76290 IF(ECM.LT.ECMMIN) THEN
76291 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
76292 IF(MSTU(21).GE.1) RETURN
76293 ENDIF
76294
76295C...Check consistency of MSTJ options set.
76296 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
76297 CALL PYERRM(6,
76298 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76299 MSTJ(110)=1
76300 ENDIF
76301 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
76302 CALL PYERRM(6,
76303 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76304 MSTJ(111)=0
76305 ENDIF
76306
76307C...Initialize alpha_strong and total cross-section.
76308 MSTU(111)=MSTJ(108)
76309 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
76310 &MSTU(111)=1
76311 PARU(112)=PARJ(121)
76312 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
76313 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
76314 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
76315 &XTOT)
76316 IF(MSTJ(116).GE.3) MSTJ(116)=1
76317 PARJ(171)=0D0
76318
76319C...Add initial e+e- to event record (documentation only).
76320 NTRY=0
76321 100 NTRY=NTRY+1
76322 IF(NTRY.GT.100) THEN
76323 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
76324 RETURN
76325 ENDIF
76326 MSTU(24)=0
76327 NC=0
76328 IF(MSTJ(115).GE.2) THEN
76329 NC=NC+2
76330 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
76331 K(NC-1,1)=21
76332 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
76333 K(NC,1)=21
76334 ENDIF
76335
76336C...Radiative photon (in initial state).
76337 MK=0
76338 ECMC=ECM
76339 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
76340 &THEK,PHIK,ALPK)
76341 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
76342 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
76343 NC=NC+1
76344 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
76345 K(NC,3)=MIN(MSTJ(115)/2,1)
76346 ENDIF
76347
76348C...Virtual exchange boson (gamma or Z0).
76349 IF(MSTJ(115).GE.3) THEN
76350 NC=NC+1
76351 KF=22
76352 IF(MSTJ(102).EQ.2) KF=23
76353 MSTU10=MSTU(10)
76354 MSTU(10)=1
76355 P(NC,5)=ECMC
76356 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
76357 K(NC,1)=21
76358 K(NC,3)=1
76359 MSTU(10)=MSTU10
76360 ENDIF
76361
76362C...Choice of flavour and jet configuration.
76363 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
76364 IF(KFLC.EQ.0) GOTO 100
76365 CALL PYXJET(ECMC,NJET,CUT)
76366 KFLN=21
76367 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
76368 &X12,X14)
76369 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
76370 IF(NJET.EQ.2) MSTJ(120)=1
76371
76372C...Fill jet configuration and origin.
76373 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
76374 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
76375 &ECMC)
76376 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
76377 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
76378 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76379 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
76380 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76381 IF(MSTU(24).NE.0) GOTO 100
76382 DO 110 IP=NC+1,N
76383 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
76384 110 CONTINUE
76385
76386C...Angular orientation according to matrix element.
76387 IF(MSTJ(106).EQ.1) THEN
76388 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
76389 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
76390 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
76391 ENDIF
76392
76393C...Rotation and boost from radiative photon.
76394 IF(MK.EQ.1) THEN
76395 DBEK=-PAK/(ECM-PAK)
76396 NMIN=NC+1-MSTJ(115)/3
76397 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
76398 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
76399 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
76400 ENDIF
76401
76402C...Generate parton shower. Rearrange along strings and check.
76403 IF(MSTJ(101).EQ.5) THEN
76404 CALL PYSHOW(N-1,N,ECMC)
76405 MSTJ14=MSTJ(14)
76406 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
76407 IF(MSTJ(105).GE.0) MSTU(28)=0
76408 CALL PYPREP(0)
76409 MSTJ(14)=MSTJ14
76410 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
76411 ENDIF
76412
76413C...Fragmentation/decay generation. Information for PYTABU.
76414 IF(MSTJ(105).EQ.1) CALL PYEXEC
76415 MSTU(161)=KFLC
76416 MSTU(162)=-KFLC
76417
76418 RETURN
76419 END
76420
76421C*********************************************************************
76422
76423C...PYXTEE
76424C...Calculates total cross-section, including initial state
76425C...radiation effects.
76426
76427 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
76428
76429C...Double precision and integer declarations.
76430 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76431 IMPLICIT INTEGER(I-N)
76432 INTEGER PYK,PYCHGE,PYCOMP
76433C...Commonblocks.
76434 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76435 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76436 SAVE /PYDAT1/,/PYDAT2/
76437
76438C...Status, (optimized) Q^2 scale, alpha_strong.
76439 PARJ(151)=ECM
76440 MSTJ(119)=10*MSTJ(102)+KFL
76441 IF(MSTJ(111).EQ.0) THEN
76442 Q2R=ECM**2
76443 ELSEIF(MSTU(111).EQ.0) THEN
76444 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76445 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76446 Q2R=PARJ(168)*ECM**2
76447 ELSE
76448 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76449 & (2D0*PARU(112)/ECM)**2))
76450 Q2R=PARJ(168)*ECM**2
76451 ENDIF
76452 ALSPI=PYALPS(Q2R)/PARU(1)
76453
76454C...QCD corrections factor in R.
76455 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
76456 RQCD=1D0
76457 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
76458 RQCD=1D0+ALSPI
76459 ELSEIF(MSTJ(109).EQ.0) THEN
76460 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76461 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
76462 & LOG(PARJ(168))*ALSPI**2)
76463 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
76464 RQCD=1D0+(3D0/4D0)*ALSPI
76465 ELSE
76466 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
76467 ENDIF
76468
76469C...Calculate Z0 width if default value not acceptable.
76470 IF(MSTJ(102).GE.3) THEN
76471 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
76472 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
76473 DO 100 KFLC=5,6
76474 VQ=1D0
76475 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
76476 & (2D0*PYMASS(KFLC)/ ECM)**2))
76477 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
76478 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
76479 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
76480 100 CONTINUE
76481 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
76482 & (1D0-PARU(102)))
76483 ENDIF
76484
76485C...Calculate propagator and related constants for QFD case.
76486 POLL=1D0-PARJ(131)*PARJ(132)
76487 IF(MSTJ(102).GE.2) THEN
76488 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76489 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76490 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
76491 VE=4D0*PARU(102)-1D0
76492 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
76493 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76494 HF1I=SFI*SF1I
76495 HF1W=SFW*SF1W
76496 ENDIF
76497
76498C...Loop over different flavours: charge, velocity.
76499 RTOT=0D0
76500 RQQ=0D0
76501 RQV=0D0
76502 RVA=0D0
76503 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
76504 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
76505 MSTJ(93)=1
76506 PMQ=PYMASS(KFLC)
76507 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
76508 QF=KCHG(KFLC,1)/3D0
76509 VQ=1D0
76510 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
76511
76512C...Calculate R and sum of charges for QED or QFD case.
76513 RQQ=RQQ+3D0*QF**2*POLL
76514 IF(MSTJ(102).LE.1) THEN
76515 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
76516 ELSE
76517 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76518 RQV=RQV-6D0*QF*VF*SF1I
76519 RVA=RVA+3D0*(VF**2+1D0)*SF1W
76520 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
76521 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
76522 ENDIF
76523 110 CONTINUE
76524 RSUM=RQQ
76525 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
76526
76527C...Calculate cross-section, including QCD corrections.
76528 PARJ(141)=RQQ
76529 PARJ(142)=RTOT
76530 PARJ(143)=RTOT*RQCD
76531 PARJ(144)=PARJ(143)
76532 PARJ(145)=PARJ(141)*86.8D0/ECM**2
76533 PARJ(146)=PARJ(142)*86.8D0/ECM**2
76534 PARJ(147)=PARJ(143)*86.8D0/ECM**2
76535 PARJ(148)=PARJ(147)
76536 PARJ(157)=RSUM*RQCD
76537 PARJ(158)=0D0
76538 PARJ(159)=0D0
76539 XTOT=PARJ(147)
76540 IF(MSTJ(107).LE.0) RETURN
76541
76542C...Virtual cross-section.
76543 XKL=PARJ(135)
76544 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76545 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
76546 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
76547 &1.526D0*LOG(ECM**2/0.932D0)
76548
76549C...Soft and hard radiative cross-section in QED case.
76550 IF(MSTJ(102).LE.1) THEN
76551 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
76552 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
76553 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
76554
76555C...Soft and hard radiative cross-section in QFD case.
76556 ELSE
76557 SZM=1D0-(PARJ(123)/ECM)**2
76558 SZW=PARJ(123)*PARJ(124)/ECM**2
76559 PARJ(161)=-RQQ/RSUM
76560 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
76561 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
76562 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
76563 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
76564 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
76565 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
76566 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
76567 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
76568 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
76569 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
76570 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
76571 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
76572 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
76573 ENDIF
76574
76575C...Total cross-section and fraction of hard photon events.
76576 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
76577 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
76578 PARJ(144)=PARJ(157)
76579 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76580 XTOT=PARJ(148)
76581
76582 RETURN
76583 END
76584
76585C*********************************************************************
76586
76587C...PYRADK
76588C...Generates initial state photon radiation.
76589
76590 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
76591
76592C...Double precision and integer declarations.
76593 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76594 IMPLICIT INTEGER(I-N)
76595 INTEGER PYK,PYCHGE,PYCOMP
76596C...Commonblocks.
76597 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76598 SAVE /PYDAT1/
76599
76600C...Function: cumulative hard photon spectrum in QFD case.
76601 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
76602 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
76603
76604C...Determine whether radiative photon or not.
76605 MK=0
76606 PAK=0D0
76607 IF(PARJ(160).LT.PYR(0)) RETURN
76608 MK=1
76609
76610C...Photon energy range. Find photon momentum in QED case.
76611 XKL=PARJ(135)
76612 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76613 IF(MSTJ(102).LE.1) THEN
76614 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
76615 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
76616
76617C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76618 ELSE
76619 SZM=1D0-(PARJ(123)/ECM)**2
76620 SZW=PARJ(123)*PARJ(124)/ECM**2
76621 FXKL=FXK(XKL)
76622 FXKU=FXK(XKU)
76623 FXKD=1D-4*(FXKU-FXKL)
76624 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
76625 NXK=0
76626 110 NXK=NXK+1
76627 XK=0.5D0*(XKL+XKU)
76628 FXKV=FXK(XK)
76629 IF(FXKV.GT.FXKR) THEN
76630 XKU=XK
76631 FXKU=FXKV
76632 ELSE
76633 XKL=XK
76634 FXKL=FXKV
76635 ENDIF
76636 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
76637 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
76638 ENDIF
76639 PAK=0.5D0*ECM*XK
76640
76641C...Photon polar and azimuthal angle.
76642 PME=2D0*(PYMASS(11)/ECM)**2
76643 120 CTHM=PME*(2D0/PME)**PYR(0)
76644 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
76645 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
76646 CTHE=1D0-CTHM
76647 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
76648 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
76649 THEK=PYANGL(CTHE,STHE)
76650 PHIK=PARU(2)*PYR(0)
76651
76652C...Rotation angle for hadronic system.
76653 SGN=1D0
76654 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
76655 &PYR(0)) SGN=-1D0
76656 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
76657 &(2D0-XK*(1D0-SGN*CTHE)))
76658
76659 RETURN
76660 END
76661
76662C*********************************************************************
76663
76664C...PYXKFL
76665C...Selects flavour for produced qqbar pair.
76666
76667 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
76668
76669C...Double precision and integer declarations.
76670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76671 IMPLICIT INTEGER(I-N)
76672 INTEGER PYK,PYCHGE,PYCOMP
76673C...Commonblocks.
76674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76676 SAVE /PYDAT1/,/PYDAT2/
76677
76678C...Calculate maximum weight in QED or QFD case.
76679 IF(MSTJ(102).LE.1) THEN
76680 RFMAX=4D0/9D0
76681 ELSE
76682 POLL=1D0-PARJ(131)*PARJ(132)
76683 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76684 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76685 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
76686 VE=4D0*PARU(102)-1D0
76687 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
76688 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76689 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
76690 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
76691 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
76692 & 1D0)*HF1W)
76693 ENDIF
76694
76695C...Choose flavour. Gives charge and velocity.
76696 NTRY=0
76697 100 NTRY=NTRY+1
76698 IF(NTRY.GT.100) THEN
76699 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
76700 KFLC=0
76701 RETURN
76702 ENDIF
76703 KFLC=KFL
76704 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
76705 MSTJ(93)=1
76706 PMQ=PYMASS(KFLC)
76707 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
76708 QF=KCHG(KFLC,1)/3D0
76709 VQ=1D0
76710 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
76711
76712C...Calculate weight in QED or QFD case.
76713 IF(MSTJ(102).LE.1) THEN
76714 RF=QF**2
76715 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
76716 ELSE
76717 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76718 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
76719 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
76720 & VQ**3*HF1W
76721 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
76722 ENDIF
76723
76724C...Weighting or new event (radiative photon). Cross-section update.
76725 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
76726 PARJ(158)=PARJ(158)+1D0
76727 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
76728 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
76729 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
76730 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
76731 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76732
76733 RETURN
76734 END
76735
76736C*********************************************************************
76737
76738C...PYXJET
76739C...Selects number of jets in matrix element approach.
76740
76741 SUBROUTINE PYXJET(ECM,NJET,CUT)
76742
76743C...Double precision and integer declarations.
76744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76745 IMPLICIT INTEGER(I-N)
76746 INTEGER PYK,PYCHGE,PYCOMP
76747C...Commonblocks.
76748 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76749 SAVE /PYDAT1/
76750C...Local array and data.
76751 DIMENSION ZHUT(5)
76752 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
76753
76754C...Trivial result for two-jets only, including parton shower.
76755 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76756 CUT=0D0
76757
76758C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76759 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
76760 CF=4D0/3D0
76761 IF(MSTJ(109).EQ.2) CF=1D0
76762 IF(MSTJ(111).EQ.0) THEN
76763 Q2=ECM**2
76764 Q2R=ECM**2
76765 ELSEIF(MSTU(111).EQ.0) THEN
76766 PARJ(169)=MIN(1D0,PARJ(129))
76767 Q2=PARJ(169)*ECM**2
76768 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76769 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76770 Q2R=PARJ(168)*ECM**2
76771 ELSE
76772 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
76773 Q2=PARJ(169)*ECM**2
76774 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76775 & (2D0*PARU(112)/ECM)**2))
76776 Q2R=PARJ(168)*ECM**2
76777 ENDIF
76778
76779C...alpha_strong for R and R itself.
76780 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
76781 IF(IABS(MSTJ(101)).EQ.1) THEN
76782 RQCD=1D0+ALSPI
76783 ELSEIF(MSTJ(109).EQ.0) THEN
76784 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76785 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
76786 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
76787 ELSE
76788 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
76789 ENDIF
76790
76791C...alpha_strong for jet rate. Initial value for y cut.
76792 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76793 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
76794 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
76795 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
76796 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76797
76798C...Parametrization of first order three-jet cross-section.
76799 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
76800 PARJ(152)=0D0
76801 ELSE
76802 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
76803 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
76804 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
76805 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
76806 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
76807 & PARJ(152)=0D0
76808 ENDIF
76809
76810C...Parametrization of second order three-jet cross-section.
76811 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
76812 & CUT.GE.0.25D0) THEN
76813 PARJ(153)=0D0
76814 ELSEIF(MSTJ(110).LE.1) THEN
76815 CT=LOG(1D0/CUT-2D0)
76816 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
76817 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
76818
76819C...Interpolation in second/first order ratio for Zhu parametrization.
76820 ELSEIF(MSTJ(110).EQ.2) THEN
76821 IZA=0
76822 DO 110 IY=1,5
76823 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
76824 110 CONTINUE
76825 IF(IZA.NE.0) THEN
76826 ZHURAT=ZHUT(IZA)
76827 ELSE
76828 IZ=100D0*CUT
76829 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
76830 ENDIF
76831 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
76832 ENDIF
76833
76834C...Shift in second order three-jet cross-section with optimized Q^2.
76835 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
76836 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
76837 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
76838
76839C...Parametrization of second order four-jet cross-section.
76840 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
76841 PARJ(154)=0D0
76842 ELSE
76843 CT=LOG(1D0/CUT-5D0)
76844 IF(CUT.LE.0.018D0) THEN
76845 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
76846 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
76847 & 0.4059D0*CT**2)
76848 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
76849 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76850 ELSE
76851 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
76852 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
76853 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
76854 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
76855 & 0.002093D0*CT**3)
76856 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76857 ENDIF
76858 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
76859 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
76860 ENDIF
76861
76862C...If negative three-jet rate, change y' optimization parameter.
76863 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
76864 & PARJ(169).LT.0.99D0) THEN
76865 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76866 Q2=PARJ(169)*ECM**2
76867 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76868 GOTO 100
76869 ENDIF
76870
76871C...If too high cross-section, use harder cuts, or fail.
76872 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
76873 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
76874 & PARJ(169).LT.0.99D0) THEN
76875 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76876 Q2=PARJ(169)*ECM**2
76877 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76878 GOTO 100
76879 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
76880 CALL PYERRM(26,
76881 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76882 ENDIF
76883 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
76884 & PARJ(154))**(-1D0/3D0)
76885 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76886 GOTO 100
76887 ENDIF
76888
76889C...Scalar gluon (first order only).
76890 ELSE
76891 ALSPI=PYALPS(ECM**2)/PARU(1)
76892 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
76893 PARJ(152)=0D0
76894 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
76895 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
76896 PARJ(153)=0D0
76897 PARJ(154)=0D0
76898 ENDIF
76899
76900C...Select number of jets.
76901 PARJ(150)=CUT
76902 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76903 NJET=2
76904 ELSEIF(MSTJ(101).LE.0) THEN
76905 NJET=MIN(4,2-MSTJ(101))
76906 ELSE
76907 RNJ=PYR(0)
76908 NJET=2
76909 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
76910 IF(PARJ(154).GT.RNJ) NJET=4
76911 ENDIF
76912
76913 RETURN
76914 END
76915
76916C*********************************************************************
76917
76918C...PYX3JT
76919C...Selects the kinematical variables of three-jet events.
76920
76921 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
76922
76923C...Double precision and integer declarations.
76924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76925 IMPLICIT INTEGER(I-N)
76926 INTEGER PYK,PYCHGE,PYCOMP
76927C...Commonblocks.
76928 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76929 SAVE /PYDAT1/
76930C...Local array.
76931 DIMENSION ZHUP(5,12)
76932
76933C...Coefficients of Zhu second order parametrization.
76934 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
76935 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
76936 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
76937 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
76938 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
76939 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
76940 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
76941 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
76942 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
76943 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
76944 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
76945
76946C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76947 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
76948 &X**7/49D0
76949
76950C...Event type. Mass effect factors and other common constants.
76951 MSTJ(120)=2
76952 MSTJ(121)=0
76953 PMQ=PYMASS(KFL)
76954 QME=(2D0*PMQ/ECM)**2
76955 IF(MSTJ(109).NE.1) THEN
76956 CUTL=LOG(CUT)
76957 CUTD=LOG(1D0/CUT-2D0)
76958 IF(MSTJ(109).EQ.0) THEN
76959 CF=4D0/3D0
76960 CN=3D0
76961 TR=2D0
76962 WTMX=MIN(20D0,37D0-6D0*CUTD)
76963 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
76964 ELSE
76965 CF=1D0
76966 CN=0D0
76967 TR=12D0
76968 WTMX=0D0
76969 ENDIF
76970
76971C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
76972 ALS2PI=PARU(118)/PARU(2)
76973 WTOPT=0D0
76974 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
76975 & LOG(PARJ(169))*ALS2PI
76976 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
76977
76978C...Choose three-jet events in allowed region.
76979 100 NJET=3
76980 110 Y13L=CUTL+CUTD*PYR(0)
76981 Y23L=CUTL+CUTD*PYR(0)
76982 Y13=EXP(Y13L)
76983 Y23=EXP(Y23L)
76984 Y12=1D0-Y13-Y23
76985 IF(Y12.LE.CUT) GOTO 110
76986 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
76987
76988C...Second order corrections.
76989 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
76990 Y12L=LOG(Y12)
76991 Y13M=LOG(1D0-Y13)
76992 Y23M=LOG(1D0-Y23)
76993 Y12M=LOG(1D0-Y12)
76994 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
76995 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
76996 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
76997 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
76998 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
76999 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
77000 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
77001 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
77002 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
77003 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
77004 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
77005 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
77006 & TR*(2D0*CUTL/3D0-10D0/9D0)+
77007 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
77008 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
77009 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
77010 & Y13*Y23)/(Y12+Y13)**2)/WT1+
77011 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
77012 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
77013 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
77014 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
77015 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
77016 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
77017 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
77018 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77019 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77020 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
77021
77022 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
77023C...Second order corrections; Zhu parametrization of ERT.
77024 ZX=(Y23-Y13)**2
77025 ZY=1D0-Y12
77026 IZA=0
77027 DO 120 IY=1,5
77028 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
77029 120 CONTINUE
77030 IF(IZA.NE.0) THEN
77031 IZ=IZA
77032 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77033 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77034 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77035 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77036 ELSE
77037 IZ=100D0*CUT
77038 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77039 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77040 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77041 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77042 IZ=IZ+1
77043 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77044 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77045 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77046 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77047 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
77048 ENDIF
77049 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77050 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77051 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
77052 ENDIF
77053
77054C...Impose mass cuts (gives two jets). For fixed jet number new try.
77055 X1=1D0-Y23
77056 X2=1D0-Y13
77057 X3=1D0-Y12
77058 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
77059 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
77060 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
77061 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
77062 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
77063
77064C...Scalar gluon model (first order only, no mass effects).
77065 ELSE
77066 130 NJET=3
77067 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
77068 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
77069 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
77070 X1=1D0-0.5D0*(X3+YD)
77071 X2=1D0-0.5D0*(X3-YD)
77072 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
77073 IF(MSTJ(102).GE.2) THEN
77074 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
77075 & X3**2*PYR(0)) NJET=2
77076 ENDIF
77077 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
77078 ENDIF
77079
77080 RETURN
77081 END
77082
77083C*********************************************************************
77084
77085C...PYX4JT
77086C...Selects the kinematical variables of four-jet events.
77087
77088 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77089
77090C...Double precision and integer declarations.
77091 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77092 IMPLICIT INTEGER(I-N)
77093 INTEGER PYK,PYCHGE,PYCOMP
77094C...Commonblocks.
77095 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77096 SAVE /PYDAT1/
77097C...Local arrays.
77098 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
77099
77100C...Common constants. Colour factors for QCD and Abelian gluon theory.
77101 PMQ=PYMASS(KFL)
77102 QME=(2D0*PMQ/ECM)**2
77103 CT=LOG(1D0/CUT-5D0)
77104 IF(MSTJ(109).EQ.0) THEN
77105 CF=4D0/3D0
77106 CN=3D0
77107 TR=2.5D0
77108 ELSE
77109 CF=1D0
77110 CN=0D0
77111 TR=15D0
77112 ENDIF
77113
77114C...Choice of process (qqbargg or qqbarqqbar).
77115 100 NJET=4
77116 IT=1
77117 IF(PARJ(155).GT.PYR(0)) IT=2
77118 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
77119 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
77120 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
77121 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
77122 ID=1
77123
77124C...Sample the five kinematical variables (for qqgg preweighted in y34).
77125 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77126 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77127 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
77128 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
77129 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
77130 VT=PYR(0)
77131 CP=COS(PARU(1)*PYR(0))
77132 Y14=(Y134-Y34)*VT
77133 Y13=Y134-Y14-Y34
77134 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
77135 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
77136 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
77137 Y23=Y234-Y34-Y24
77138 Y12=1D0-Y134-Y23-Y24
77139 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
77140 Y123=Y12+Y13+Y23
77141 Y124=Y12+Y14+Y24
77142
77143C...Calculate matrix elements for qqgg or qqqq process.
77144 IC=0
77145 WTTOT=0D0
77146 120 IC=IC+1
77147 IF(IT.EQ.1) THEN
77148 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
77149 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
77150 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
77151 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
77152 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
77153 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
77154 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
77155 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
77156 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
77157 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
77158 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
77159 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
77160 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
77161 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
77162 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
77163 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
77164 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
77165 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
77166 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
77167 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
77168 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
77169 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
77170 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
77171 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
77172 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
77173 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
77174 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
77175 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
77176 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
77177 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
77178 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
77179 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
77180 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
77181 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
77182 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
77183 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
77184 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
77185 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
77186 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
77187 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
77188 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
77189 & CN*WTC(IC))/8D0
77190 ELSE
77191 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
77192 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
77193 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
77194 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
77195 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
77196 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
77197 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
77198 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
77199 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
77200 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
77201 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
77202 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
77203 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
77204 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
77205 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
77206 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
77207 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
77208 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
77209 ENDIF
77210
77211C...Permutations of momenta in matrix element. Weighting.
77212 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
77213 YSAV=Y13
77214 Y13=Y14
77215 Y14=YSAV
77216 YSAV=Y23
77217 Y23=Y24
77218 Y24=YSAV
77219 YSAV=Y123
77220 Y123=Y124
77221 Y124=YSAV
77222 ENDIF
77223 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
77224 YSAV=Y13
77225 Y13=Y23
77226 Y23=YSAV
77227 YSAV=Y14
77228 Y14=Y24
77229 Y24=YSAV
77230 YSAV=Y134
77231 Y134=Y234
77232 Y234=YSAV
77233 ENDIF
77234 IF(IC.LE.3) GOTO 120
77235 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
77236 IC=5
77237
77238C...qqgg events: string configuration and event type.
77239 IF(IT.EQ.1) THEN
77240 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
77241 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
77242 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
77243 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
77244 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
77245 IF(ID.EQ.2) GOTO 130
77246 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
77247 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
77248 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
77249 IF(ID.EQ.2) GOTO 130
77250 ENDIF
77251 MSTJ(120)=3
77252 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
77253 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
77254 KFLN=21
77255
77256C...Mass cuts. Kinematical variables out.
77257 IF(Y12.LE.CUT+QME) NJET=2
77258 IF(NJET.EQ.2) GOTO 150
77259 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
77260 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
77261 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
77262 X2=1D0-Y124
77263 X12=(1D0-Q12)*Y13+Q12*Y23
77264 X14=Y12-0.5D0*QME
77265 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77266
77267C...qqbarqqbar events: string configuration, choose new flavour.
77268 ELSE
77269 IF(ID.EQ.1) THEN
77270 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
77271 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
77272 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
77273 IF(WTR.LT.WTD(4)) ID=4
77274 IF(ID.GE.2) GOTO 130
77275 ENDIF
77276 MSTJ(120)=5
77277 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
77278 140 KFLN=1+INT(5D0*PYR(0))
77279 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
77280 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
77281 IF(KFLN.GT.MSTJ(104)) NJET=2
77282 PMQN=PYMASS(KFLN)
77283 QMEN=(2D0*PMQN/ECM)**2
77284
77285C...Mass cuts. Kinematical variables out.
77286 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
77287 IF(NJET.EQ.2) GOTO 150
77288 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
77289 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
77290 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
77291 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
77292 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
77293 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
77294 & Q13*Y23)
77295 X14=Y24-0.5D0*QME
77296 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
77297 & Q13*Y14)
77298 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
77299 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
77300 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77301 ENDIF
77302 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
77303
77304 RETURN
77305 END
77306
77307C*********************************************************************
77308
77309C...PYXDIF
77310C...Gives the angular orientation of events.
77311
77312 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
77313
77314C...Double precision and integer declarations.
77315 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77316 IMPLICIT INTEGER(I-N)
77317 INTEGER PYK,PYCHGE,PYCOMP
77318C...Commonblocks.
77319 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77320 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77321 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77322 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77323
77324C...Charge. Factors depending on polarization for QED case.
77325 QF=KCHG(KFL,1)/3D0
77326 POLL=1D0-PARJ(131)*PARJ(132)
77327 POLD=PARJ(132)-PARJ(131)
77328 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
77329 HF1=POLL
77330 HF2=0D0
77331 HF3=PARJ(133)**2
77332 HF4=0D0
77333
77334C...Factors depending on flavour, energy and polarization for QFD case.
77335 ELSE
77336 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
77337 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
77338 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
77339 AE=-1D0
77340 VE=4D0*PARU(102)-1D0
77341 AF=SIGN(1D0,QF)
77342 VF=AF-4D0*QF*PARU(102)
77343 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
77344 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
77345 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
77346 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
77347 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
77348 & SFW*SFF**2*(VE**2-AE**2))
77349 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
77350 & SFF*AE
77351 ENDIF
77352
77353C...Mass factor. Differential cross-sections for two-jet events.
77354 SQ2=SQRT(2D0)
77355 QME=0D0
77356 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
77357 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
77358 IF(NJET.EQ.2) THEN
77359 SIGU=4D0*SQRT(1D0-QME)
77360 SIGL=2D0*QME*SQRT(1D0-QME)
77361 SIGT=0D0
77362 SIGI=0D0
77363 SIGA=0D0
77364 SIGP=4D0
77365
77366C...Kinematical variables. Reduce four-jet event to three-jet one.
77367 ELSE
77368 IF(NJET.EQ.3) THEN
77369 X1=2D0*P(NC+1,4)/ECM
77370 X2=2D0*P(NC+3,4)/ECM
77371 ELSE
77372 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
77373 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
77374 X1=2D0*P(NC+1,4)/ECMR
77375 X2=2D0*P(NC+4,4)/ECMR
77376 ENDIF
77377
77378C...Differential cross-sections for three-jet (or reduced four-jet).
77379 XQ=(1D0-X1)/(1D0-X2)
77380 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
77381 ST12=SQRT(1D0-CT12**2)
77382 IF(MSTJ(109).NE.1) THEN
77383 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
77384 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
77385 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
77386 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
77387 & X2)*XQ
77388 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
77389 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
77390 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
77391 SIGA=X2**2*ST12/SQ2
77392 SIGP=2D0*(X1**2-X2**2*CT12)
77393
77394C...Differential cross-sect for scalar gluons (no mass effects).
77395 ELSE
77396 X3=2D0-X1-X2
77397 XT=X2*ST12
77398 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
77399 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
77400 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
77401 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
77402 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
77403 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
77404 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
77405 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
77406 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
77407 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
77408 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
77409 ENDIF
77410 ENDIF
77411
77412C...Upper bounds for differential cross-section.
77413 HF1A=ABS(HF1)
77414 HF2A=ABS(HF2)
77415 HF3A=ABS(HF3)
77416 HF4A=ABS(HF4)
77417 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
77418 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
77419 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
77420 &2D0*HF2A*ABS(SIGP)
77421
77422C...Generate angular orientation according to differential cross-sect.
77423 100 CHI=PARU(2)*PYR(0)
77424 CTHE=2D0*PYR(0)-1D0
77425 PHI=PARU(2)*PYR(0)
77426 CCHI=COS(CHI)
77427 SCHI=SIN(CHI)
77428 C2CHI=COS(2D0*CHI)
77429 S2CHI=SIN(2D0*CHI)
77430 THE=ACOS(CTHE)
77431 STHE=SIN(THE)
77432 C2PHI=COS(2D0*(PHI-PARJ(134)))
77433 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77434 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
77435 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
77436 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
77437 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
77438 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
77439 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
77440 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
77441 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
77442
77443 RETURN
77444 END
77445
77446C*********************************************************************
77447
77448C...PYONIA
77449C...Generates Upsilon and toponium decays into three gluons
77450C...or two gluons and a photon.
77451
77452 SUBROUTINE PYONIA(KFL,ECM)
77453
77454C...Double precision and integer declarations.
77455 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77456 IMPLICIT INTEGER(I-N)
77457 INTEGER PYK,PYCHGE,PYCOMP
77458C...Commonblocks.
77459 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77460 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77461 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77463
77464C...Printout. Check input parameters.
77465 IF(MSTU(12).NE.12345) CALL PYLIST(0)
77466 IF(KFL.LT.0.OR.KFL.GT.8) THEN
77467 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
77468 IF(MSTU(21).GE.1) RETURN
77469 ENDIF
77470 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
77471 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
77472 IF(MSTU(21).GE.1) RETURN
77473 ENDIF
77474
77475C...Initial e+e- and onium state (optional).
77476 NC=0
77477 IF(MSTJ(115).GE.2) THEN
77478 NC=NC+2
77479 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
77480 K(NC-1,1)=21
77481 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
77482 K(NC,1)=21
77483 ENDIF
77484 KFLC=IABS(KFL)
77485 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
77486 NC=NC+1
77487 KF=110*KFLC+3
77488 MSTU10=MSTU(10)
77489 MSTU(10)=1
77490 P(NC,5)=ECM
77491 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
77492 K(NC,1)=21
77493 K(NC,3)=1
77494 MSTU(10)=MSTU10
77495 ENDIF
77496
77497C...Choose x1 and x2 according to matrix element.
77498 NTRY=0
77499 100 X1=PYR(0)
77500 X2=PYR(0)
77501 X3=2D0-X1-X2
77502 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
77503 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
77504 NTRY=NTRY+1
77505 NJET=3
77506 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
77507 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
77508
77509C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77510 MSTU(111)=MSTJ(108)
77511 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
77512 &MSTU(111)=1
77513 PARU(112)=PARJ(121)
77514 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
77515 QF=0D0
77516 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
77517 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
77518 MK=0
77519 ECMC=ECM
77520 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
77521 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
77522 & NJET=2
77523 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
77524 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
77525 ELSE
77526 MK=1
77527 ECMC=SQRT(1D0-X1)*ECM
77528 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
77529 K(NC+1,1)=1
77530 K(NC+1,2)=22
77531 K(NC+1,4)=0
77532 K(NC+1,5)=0
77533 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
77534 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
77535 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
77536 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
77537 NJET=2
77538 IF(ECMC.LT.4D0*PARJ(127)) THEN
77539 MSTU10=MSTU(10)
77540 MSTU(10)=1
77541 P(NC+2,5)=ECMC
77542 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
77543 MSTU(10)=MSTU10
77544 NJET=0
77545 ENDIF
77546 ENDIF
77547 DO 110 IP=NC+1,N
77548 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
77549 110 CONTINUE
77550
77551C...Differential cross-sections. Upper limit for cross-section.
77552 IF(MSTJ(106).EQ.1) THEN
77553 SQ2=SQRT(2D0)
77554 HF1=1D0-PARJ(131)*PARJ(132)
77555 HF3=PARJ(133)**2
77556 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
77557 ST13=SQRT(1D0-CT13**2)
77558 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
77559 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
77560 SIGT=0.5D0*SIGL
77561 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
77562 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
77563 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
77564
77565C...Angular orientation of event.
77566 120 CHI=PARU(2)*PYR(0)
77567 CTHE=2D0*PYR(0)-1D0
77568 PHI=PARU(2)*PYR(0)
77569 CCHI=COS(CHI)
77570 SCHI=SIN(CHI)
77571 C2CHI=COS(2D0*CHI)
77572 S2CHI=SIN(2D0*CHI)
77573 THE=ACOS(CTHE)
77574 STHE=SIN(THE)
77575 C2PHI=COS(2D0*(PHI-PARJ(134)))
77576 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77577 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
77578 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
77579 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
77580 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
77581 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
77582 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
77583 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
77584 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
77585 ENDIF
77586
77587C...Generate parton shower. Rearrange along strings and check.
77588 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
77589 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
77590 MSTJ14=MSTJ(14)
77591 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
77592 IF(MSTJ(105).GE.0) MSTU(28)=0
77593 CALL PYPREP(0)
77594 MSTJ(14)=MSTJ14
77595 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
77596 ENDIF
77597
77598C...Generate fragmentation. Information for PYTABU:
77599 IF(MSTJ(105).EQ.1) CALL PYEXEC
77600 MSTU(161)=110*KFLC+3
77601 MSTU(162)=0
77602
77603 RETURN
77604 END
77605
77606C*********************************************************************
77607
77608C...PYBOOK
77609C...Books a histogram.
77610
77611 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
77612
77613C...Double precision declaration.
77614 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77615 IMPLICIT INTEGER(I-N)
77616C...Commonblock.
77617 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77618 SAVE /PYBINS/
77619C...Local character variables.
77620 CHARACTER TITLE*(*), TITFX*60
77621
77622C...Check that input is sensible. Find initial address in memory.
77623 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77624 &'(PYBOOK:) not allowed histogram number')
77625 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
77626 &'(PYBOOK:) not allowed number of bins')
77627 IF(XL.GE.XU) CALL PYERRM(28,
77628 &'(PYBOOK:) x limits in wrong order')
77629 INDX(ID)=IHIST(4)
77630 IHIST(4)=IHIST(4)+28+NX
77631 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
77632 &'(PYBOOK:) out of histogram space')
77633 IS=INDX(ID)
77634
77635C...Store histogram size and reset contents.
77636 BIN(IS+1)=NX
77637 BIN(IS+2)=XL
77638 BIN(IS+3)=XU
77639 BIN(IS+4)=(XU-XL)/NX
77640 CALL PYNULL(ID)
77641
77642C...Store title by conversion to integer to double precision.
77643 TITFX=TITLE//' '
77644 DO 100 IT=1,20
77645 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
77646 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
77647 100 CONTINUE
77648
77649 RETURN
77650 END
77651
77652C*********************************************************************
77653
77654C...PYFILL
77655C...Fills entry in histogram.
77656
77657 SUBROUTINE PYFILL(ID,X,W)
77658
77659C...Double precision declaration.
77660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77661 IMPLICIT INTEGER(I-N)
77662C...Commonblock.
77663 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77664 SAVE /PYBINS/
77665
77666C...Find initial address in memory. Increase number of entries.
77667 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77668 &'(PYFILL:) not allowed histogram number')
77669 IS=INDX(ID)
77670 IF(IS.EQ.0) CALL PYERRM(28,
77671 &'(PYFILL:) filling unbooked histogram')
77672 BIN(IS+5)=BIN(IS+5)+1D0
77673
77674C...Find bin in x, including under/overflow, and fill.
77675 IF(X.LT.BIN(IS+2)) THEN
77676 BIN(IS+6)=BIN(IS+6)+W
77677 ELSEIF(X.GE.BIN(IS+3)) THEN
77678 BIN(IS+8)=BIN(IS+8)+W
77679 ELSE
77680 BIN(IS+7)=BIN(IS+7)+W
77681 IX=(X-BIN(IS+2))/BIN(IS+4)
77682 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
77683 BIN(IS+9+IX)=BIN(IS+9+IX)+W
77684 ENDIF
77685
77686 RETURN
77687 END
77688
77689C*********************************************************************
77690
77691C...PYFACT
77692C...Multiplies histogram contents by factor.
77693
77694 SUBROUTINE PYFACT(ID,F)
77695
77696C...Double precision declaration.
77697 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77698 IMPLICIT INTEGER(I-N)
77699C...Commonblock.
77700 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77701 SAVE /PYBINS/
77702
77703C...Find initial address in memory. Multiply all contents bins.
77704 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77705 &'(PYFACT:) not allowed histogram number')
77706 IS=INDX(ID)
77707 IF(IS.EQ.0) CALL PYERRM(28,
77708 &'(PYFACT:) scaling unbooked histogram')
77709 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
77710 BIN(IX)=F*BIN(IX)
77711 100 CONTINUE
77712
77713 RETURN
77714 END
77715
77716C*********************************************************************
77717
77718C...PYOPER
77719C...Performs operations between histograms.
77720
77721 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
77722
77723C...Double precision declaration.
77724 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77725 IMPLICIT INTEGER(I-N)
77726C...Commonblock.
77727 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77728 SAVE /PYBINS/
77729C...Character variable.
77730 CHARACTER OPER*(*)
77731
77732C...Find initial addresses in memory, and histogram size.
77733 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
77734 &'(PYFACT:) not allowed histogram number')
77735 IS1=INDX(ID1)
77736 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
77737 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
77738 NX=NINT(BIN(IS3+1))
77739 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
77740
77741C...Update info on number of histogram entries.
77742 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
77743 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
77744 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
77745 BIN(IS3+5)=BIN(IS1+5)
77746 ENDIF
77747
77748C...Operations on pair of histograms: addition, subtraction,
77749C...multiplication, division.
77750 IF(OPER.EQ.'+') THEN
77751 DO 100 IX=6,8+NX
77752 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
77753 100 CONTINUE
77754 ELSEIF(OPER.EQ.'-') THEN
77755 DO 110 IX=6,8+NX
77756 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
77757 110 CONTINUE
77758 ELSEIF(OPER.EQ.'*') THEN
77759 DO 120 IX=6,8+NX
77760 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
77761 120 CONTINUE
77762 ELSEIF(OPER.EQ.'/') THEN
77763 DO 130 IX=6,8+NX
77764 FA2=F2*BIN(IS2+IX)
77765 IF(ABS(FA2).LE.1D-20) THEN
77766 BIN(IS3+IX)=0D0
77767 ELSE
77768 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
77769 ENDIF
77770 130 CONTINUE
77771
77772C...Operations on single histogram: multiplication+addition,
77773C...square root+addition, logarithm+addition.
77774 ELSEIF(OPER.EQ.'A') THEN
77775 DO 140 IX=6,8+NX
77776 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
77777 140 CONTINUE
77778 ELSEIF(OPER.EQ.'S') THEN
77779 DO 150 IX=6,8+NX
77780 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
77781 150 CONTINUE
77782 ELSEIF(OPER.EQ.'L') THEN
77783 ZMIN=1D20
77784 DO 160 IX=9,8+NX
77785 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
77786 & ZMIN=0.8D0*BIN(IS1+IX)
77787 160 CONTINUE
77788 DO 170 IX=6,8+NX
77789 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
77790 170 CONTINUE
77791
77792C...Operation on two or three histograms: average and
77793C...standard deviation.
77794 ELSEIF(OPER.EQ.'M') THEN
77795 DO 180 IX=6,8+NX
77796 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77797 BIN(IS2+IX)=0D0
77798 ELSE
77799 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
77800 ENDIF
77801 IF(ID3.NE.0) THEN
77802 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77803 BIN(IS3+IX)=0D0
77804 ELSE
77805 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
77806 & BIN(IS2+IX)**2))
77807 ENDIF
77808 ENDIF
77809 BIN(IS1+IX)=F1*BIN(IS1+IX)
77810 180 CONTINUE
77811 ENDIF
77812
77813 RETURN
77814 END
77815
77816C*********************************************************************
77817
77818C...PYHIST
77819C...Prints and resets all histograms.
77820
77821 SUBROUTINE PYHIST
77822
77823C...Double precision declaration.
77824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77825 IMPLICIT INTEGER(I-N)
77826C...Commonblock.
77827 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77828 SAVE /PYBINS/
77829
77830C...Loop over histograms, print and reset used ones.
77831 DO 100 ID=1,IHIST(1)
77832 IS=INDX(ID)
77833 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
77834 CALL PYPLOT(ID)
77835 CALL PYNULL(ID)
77836 ENDIF
77837 100 CONTINUE
77838
77839 RETURN
77840 END
77841
77842C*********************************************************************
77843
77844C...PYPLOT
77845C...Prints a histogram (but does not reset it).
77846
77847 SUBROUTINE PYPLOT(ID)
77848
77849C...Double precision declaration.
77850 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77851 IMPLICIT INTEGER(I-N)
77852C...Commonblocks.
77853 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77854 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77855 SAVE /PYDAT1/,/PYBINS/
77856C...Local arrays and character variables.
77857 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
77858 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77859
77860C...Steps in histogram scale. Character sequence.
77861 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77862 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
77863
77864C...Find initial address in memory; skip if empty histogram.
77865 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
77866 IS=INDX(ID)
77867 IF(IS.EQ.0) RETURN
77868 IF(NINT(BIN(IS+5)).LE.0) THEN
77869 WRITE(MSTU(11),5000) ID
77870 RETURN
77871 ENDIF
77872
77873C...Number of histogram lines and x bins.
77874 LIN=IHIST(3)-18
77875 NX=NINT(BIN(IS+1))
77876
77877C...Extract title by conversion from double precision via integer.
77878 DO 100 IT=1,20
77879 IEQ=NINT(BIN(IS+8+NX+IT))
77880 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
77881 & //CHAR(MOD(IEQ,256))
77882 100 CONTINUE
77883
77884C...Find time; print title.
77885 CALL PYTIME(IDATI)
77886 IF(IDATI(1).GT.0) THEN
77887 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
77888 ELSE
77889 WRITE(MSTU(11),5200) ID, TITLE
77890 ENDIF
77891
77892C...Find minimum and maximum bin content.
77893 YMIN=BIN(IS+9)
77894 YMAX=BIN(IS+9)
77895 DO 110 IX=IS+10,IS+8+NX
77896 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
77897 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
77898 110 CONTINUE
77899
77900C...Determine scale and step size for y axis.
77901 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
77902 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
77903 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
77904 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
77905 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
77906 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
77907 DELY=DYAC(1)
77908 DO 120 IDEL=1,9
77909 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
77910 120 CONTINUE
77911 DY=DELY*10D0**IPOT
77912
77913C...Convert bin contents to integer form; fractional fill in top row.
77914 DO 130 IX=1,NX
77915 CTA=ABS(BIN(IS+8+IX))/DY
77916 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
77917 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
77918 130 CONTINUE
77919 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
77920 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
77921
77922C...Print histogram row by row.
77923 DO 150 IR=IRMA,IRMI,-1
77924 IF(IR.EQ.0) GOTO 150
77925 OUT=' '
77926 DO 140 IX=1,NX
77927 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
77928 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
77929 140 CONTINUE
77930 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
77931 150 CONTINUE
77932
77933C...Print sign and value of bin contents.
77934 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
77935 OUT=' '
77936 DO 160 IX=1,NX
77937 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
77938 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
77939 160 CONTINUE
77940 WRITE(MSTU(11),5400) OUT
77941 DO 180 IR=4,1,-1
77942 DO 170 IX=1,NX
77943 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77944 170 CONTINUE
77945 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
77946 180 CONTINUE
77947
77948C...Print sign and value of lower bin edge.
77949 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
77950 & 10.0001D0)-10
77951 OUT=' '
77952 DO 190 IX=1,NX
77953 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
77954 & OUT(IX:IX)=CHA(11)
77955 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
77956 190 CONTINUE
77957 WRITE(MSTU(11),5600) OUT
77958 DO 210 IR=3,1,-1
77959 DO 200 IX=1,NX
77960 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77961 200 CONTINUE
77962 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
77963 210 CONTINUE
77964 ENDIF
77965
77966C...Calculate and print statistics.
77967 CSUM=0D0
77968 CXSUM=0D0
77969 CXXSUM=0D0
77970 DO 220 IX=1,NX
77971 CTA=ABS(BIN(IS+8+IX))
77972 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
77973 CSUM=CSUM+CTA
77974 CXSUM=CXSUM+CTA*X
77975 CXXSUM=CXXSUM+CTA*X**2
77976 220 CONTINUE
77977 XMEAN=CXSUM/MAX(CSUM,1D-20)
77978 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
77979 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
77980 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
77981
77982C...Formats for output.
77983 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
77984 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
77985 &I2,':',I2/)
77986 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
77987 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
77988 5400 FORMAT(/8X,'Contents',3X,A100)
77989 5500 FORMAT(9X,'*10**',I2,3X,A100)
77990 5600 FORMAT(/8X,'Low edge',3X,A100)
77991 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
77992 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
77993 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
77994
77995 RETURN
77996 END
77997
77998C*********************************************************************
77999
78000C...PYNULL
78001C...Resets bin contents of a histogram.
78002
78003 SUBROUTINE PYNULL(ID)
78004
78005C...Double precision declaration.
78006 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78007 IMPLICIT INTEGER(I-N)
78008C...Commonblock.
78009 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78010 SAVE /PYBINS/
78011
78012 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
78013 IS=INDX(ID)
78014 IF(IS.EQ.0) RETURN
78015 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
78016 BIN(IX)=0D0
78017 100 CONTINUE
78018
78019 RETURN
78020 END
78021
78022C*********************************************************************
78023
78024C...PYDUMP
78025C...Dumps histogram contents on file for reading by other program.
78026C...Can also read back own dump.
78027
78028 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
78029
78030C...Double precision declaration.
78031 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78032 IMPLICIT INTEGER(I-N)
78033C...Commonblock.
78034 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78035 SAVE /PYBINS/
78036C...Local arrays and character variables.
78037 DIMENSION IHI(*),ISS(100),VAL(5)
78038 CHARACTER TITLE*60,FORMAT*13
78039
78040C...Dump all histograms that have been booked,
78041C...including titles and ranges, one after the other.
78042 IF(MDUMP.EQ.1) THEN
78043
78044C...Loop over histograms and find which are wanted and booked.
78045 IF(NHI.LE.0) THEN
78046 NW=IHIST(1)
78047 ELSE
78048 NW=NHI
78049 ENDIF
78050 DO 130 IW=1,NW
78051 IF(NHI.EQ.0) THEN
78052 ID=IW
78053 ELSE
78054 ID=IHI(IW)
78055 ENDIF
78056 IS=INDX(ID)
78057 IF(IS.NE.0) THEN
78058
78059C...Write title, histogram size, filling statistics.
78060 NX=NINT(BIN(IS+1))
78061 DO 100 IT=1,20
78062 IEQ=NINT(BIN(IS+8+NX+IT))
78063 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
78064 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
78065 100 CONTINUE
78066 WRITE(LFN,5100) ID,TITLE
78067 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
78068 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
78069 & BIN(IS+8)
78070
78071
78072C...Write histogram contents, in groups of five.
78073 DO 120 IXG=1,(NX+4)/5
78074 DO 110 IXV=1,5
78075 IX=5*IXG+IXV-5
78076 IF(IX.LE.NX) THEN
78077 VAL(IXV)=BIN(IS+8+IX)
78078 ELSE
78079 VAL(IXV)=0D0
78080 ENDIF
78081 110 CONTINUE
78082 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
78083 120 CONTINUE
78084
78085C...Go to next histogram; finish.
78086 ELSEIF(NHI.GT.0) THEN
78087 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78088 ENDIF
78089 130 CONTINUE
78090
78091C...Read back in histograms dumped MDUMP=1.
78092 ELSEIF(MDUMP.EQ.2) THEN
78093
78094C...Read histogram number, title and range, and book.
78095 140 READ(LFN,5100,END=170) ID,TITLE
78096 READ(LFN,5200) NX,XL,XU
78097 CALL PYBOOK(ID,TITLE,NX,XL,XU)
78098 IS=INDX(ID)
78099
78100C...Read filling statistics.
78101 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
78102 BIN(IS+5)=DBLE(NENTRY)
78103
78104C...Read histogram contents, in groups of five.
78105 DO 160 IXG=1,(NX+4)/5
78106 READ(LFN,5400) (VAL(IXV),IXV=1,5)
78107 DO 150 IXV=1,5
78108 IX=5*IXG+IXV-5
78109 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
78110 150 CONTINUE
78111 160 CONTINUE
78112
78113C...Go to next histogram; finish.
78114 GOTO 140
78115 170 CONTINUE
78116
78117C...Write histogram contents in column format,
78118C...convenient e.g. for GNUPLOT input.
78119 ELSEIF(MDUMP.EQ.3) THEN
78120
78121C...Find addresses to wanted histograms.
78122 NSS=0
78123 IF(NHI.LE.0) THEN
78124 NW=IHIST(1)
78125 ELSE
78126 NW=NHI
78127 ENDIF
78128 DO 180 IW=1,NW
78129 IF(NHI.EQ.0) THEN
78130 ID=IW
78131 ELSE
78132 ID=IHI(IW)
78133 ENDIF
78134 IS=INDX(ID)
78135 IF(IS.NE.0.AND.NSS.LT.100) THEN
78136 NSS=NSS+1
78137 ISS(NSS)=IS
78138 ELSEIF(NSS.GE.100) THEN
78139 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
78140 ELSEIF(NHI.GT.0) THEN
78141 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78142 ENDIF
78143 180 CONTINUE
78144
78145C...Check that they have common number of x bins. Fix format.
78146 NX=NINT(BIN(ISS(1)+1))
78147 DO 190 IW=2,NSS
78148 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
78149 CALL PYERRM(8,'(PYDUMP:) different number of bins')
78150 RETURN
78151 ENDIF
78152 190 CONTINUE
78153 FORMAT='(1P,000E12.4)'
78154 WRITE(FORMAT(5:7),'(I3)') NSS+1
78155
78156C...Write histogram contents; first column x values.
78157 DO 200 IX=1,NX
78158 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
78159 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
78160 200 CONTINUE
78161
78162 ENDIF
78163
78164C...Formats for output.
78165 5100 FORMAT(I5,5X,A60)
78166 5200 FORMAT(I5,1P,2D12.4)
78167 5300 FORMAT(I12,1P,3D12.4)
78168 5400 FORMAT(1P,5D12.4)
78169
78170 RETURN
78171 END
78172
78173C*********************************************************************
78174
78175C...PYSTOP
78176C...Allows users to handle STOP statemens
78177
78178 SUBROUTINE PYSTOP(MCOD)
78179
78180C...Double precision and integer declarations.
78181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78182 IMPLICIT INTEGER(I-N)
78183 INTEGER PYK,PYCHGE,PYCOMP
78184C...Commonblocks.
78185 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78186 SAVE /PYDAT1/
78187
78188
78189C...Write message, then stop
78190 WRITE(MSTU(11),5000) MCOD
78191 STOP
78192
78193
78194C...Formats for output.
78195 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
78196 END
78197
78198C*********************************************************************
78199
78200C...PYKCUT
78201C...Dummy routine, which the user can replace in order to make cuts on
78202C...the kinematics on the parton level before the matrix elements are
78203C...evaluated and the event is generated. The cross-section estimates
78204C...will automatically take these cuts into account, so the given
78205C...values are for the allowed phase space region only. MCUT=0 means
78206C...that the event has passed the cuts, MCUT=1 that it has failed.
78207
78208 SUBROUTINE PYKCUT(MCUT)
78209
78210C...Double precision and integer declarations.
78211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78212 IMPLICIT INTEGER(I-N)
78213 INTEGER PYK,PYCHGE,PYCOMP
78214C...Commonblocks.
78215 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78216 COMMON/PYINT1/MINT(400),VINT(400)
78217 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78218 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78219
78220C...Set default value (accepting event) for MCUT.
78221 MCUT=0
78222
78223C...Read out subprocess number.
78224 ISUB=MINT(1)
78225 ISTSB=ISET(ISUB)
78226
78227C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78228 TAU=VINT(21)
78229 YST=VINT(22)
78230 CTH=0D0
78231 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78232 TAUP=0D0
78233 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78234
78235C...Calculate x_1, x_2, x_F.
78236 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
78237 X1=SQRT(TAU)*EXP(YST)
78238 X2=SQRT(TAU)*EXP(-YST)
78239 ELSE
78240 X1=SQRT(TAUP)*EXP(YST)
78241 X2=SQRT(TAUP)*EXP(-YST)
78242 ENDIF
78243 XF=X1-X2
78244
78245C...Calculate shat, that, uhat, p_T^2.
78246 SHAT=TAU*VINT(2)
78247 SQM3=VINT(63)
78248 SQM4=VINT(64)
78249 RM3=SQM3/SHAT
78250 RM4=SQM4/SHAT
78251 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
78252 RPTS=4D0*VINT(71)**2/SHAT
78253 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
78254 RM34=2D0*RM3*RM4
78255 RSQM=1D0+RM34
78256 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
78257 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
78258 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
78259 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
78260
78261C...Decisions by user to be put here.
78262
78263C...Stop program if this routine is ever called.
78264C...You should not copy these lines to your own routine.
78265 WRITE(MSTU(11),5000)
78266 CALL PYSTOP(6)
78267
78268C...Format for error printout.
78269 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
78270 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78271 &1X,'Execution stopped!')
78272
78273 RETURN
78274 END
78275
78276C*********************************************************************
78277
78278C...PYEVWT
78279C...Dummy routine, which the user can replace in order to multiply the
78280C...standard PYTHIA differential cross-section by a process- and
78281C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78282C...to generation of weighted events, with weight 1/WTXS, while for
78283C...MSTP(142)=2 it corresponds to a modification of the underlying
78284C...physics.
78285
78286 SUBROUTINE PYEVWT(WTXS)
78287
78288C...Double precision and integer declarations.
78289 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78290 IMPLICIT INTEGER(I-N)
78291 INTEGER PYK,PYCHGE,PYCOMP
78292C...Commonblocks.
78293 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78294 COMMON/PYINT1/MINT(400),VINT(400)
78295 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78296 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78297
78298C...Set default weight for WTXS.
78299 WTXS=1D0
78300
78301C...Read out subprocess number.
78302 ISUB=MINT(1)
78303 ISTSB=ISET(ISUB)
78304
78305C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78306 TAU=VINT(21)
78307 YST=VINT(22)
78308 CTH=0D0
78309 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78310 TAUP=0D0
78311 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78312
78313C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78314 X1=VINT(41)
78315 X2=VINT(42)
78316 XF=X1-X2
78317 SHAT=VINT(44)
78318 THAT=VINT(45)
78319 UHAT=VINT(46)
78320 PT2=VINT(48)
78321
78322C...Modifications by user to be put here.
78323
78324C...Stop program if this routine is ever called.
78325C...You should not copy these lines to your own routine.
78326 WRITE(MSTU(11),5000)
78327 CALL PYSTOP(4)
78328
78329C...Format for error printout.
78330 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
78331 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78332 &1X,'Execution stopped!')
78333
78334 RETURN
78335 END
78336
78337C*********************************************************************
78338
78339C...UPINIT
78340C...Dummy routine, to be replaced by a user implementing external
78341C...processes. Is supposed to fill the HEPRUP commonblock with info
78342C...on incoming beams and allowed processes.
78343
78344C...New example: handles a standard Les Houches Events File.
78345
78346 SUBROUTINE UPINIT
78347
78348C...Double precision and integer declarations.
78349 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78350 IMPLICIT INTEGER(I-N)
78351
78352C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78353 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78354 SAVE /PYPARS/
78355
78356C...User process initialization commonblock.
78357 INTEGER MAXPUP
78358 PARAMETER (MAXPUP=100)
78359 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78360 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78361 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78362 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78363 &LPRUP(MAXPUP)
78364 SAVE /HEPRUP/
78365
78366C...Lines to read in assumed never longer than 200 characters.
78367 PARAMETER (MAXLEN=200)
78368 CHARACTER*(MAXLEN) STRING
78369
78370C...Format for reading lines.
78371 CHARACTER*6 STRFMT
78372 STRFMT='(A000)'
78373 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78374
78375C...Loop until finds line beginning with "<init>" or "<init ".
78376 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
78377 IBEG=0
78378 110 IBEG=IBEG+1
78379C...Allow indentation.
78380 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
78381 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
78382 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
78383
78384C...Read first line of initialization info.
78385 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78386 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78387
78388C...Read NPRUP subsequent lines with information on each process.
78389 DO 120 IPR=1,NPRUP
78390 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78391 & XMAXUP(IPR),LPRUP(IPR)
78392 120 CONTINUE
78393 RETURN
78394
78395C...Error exit: give up if initalization does not work.
78396 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78397 WRITE(*,*) ' Event generation will be stopped.'
78398 CALL PYSTOP(12)
78399
78400 RETURN
78401 END
78402
78403C...Old example: handles a simple Pythia 6.4 initialization file.
78404
78405c SUBROUTINE UPINIT
78406
78407C...Double precision and integer declarations.
78408c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78409c IMPLICIT INTEGER(I-N)
78410
78411C...Commonblocks.
78412c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78413c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78414c SAVE /PYDAT1/,/PYPARS/
78415
78416C...User process initialization commonblock.
78417c INTEGER MAXPUP
78418c PARAMETER (MAXPUP=100)
78419c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78420c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78421c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78422c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78423c &LPRUP(MAXPUP)
78424c SAVE /HEPRUP/
78425
78426C...Read info from file.
78427c IF(MSTP(161).GT.0) THEN
78428c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78429c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78430c DO 100 IPR=1,NPRUP
78431c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78432c & XMAXUP(IPR),LPRUP(IPR)
78433c 100 CONTINUE
78434c RETURN
78435C...Error or prematurely reached end of file.
78436c 110 WRITE(MSTU(11),5000)
78437c STOP
78438
78439C...Else not implemented.
78440c ELSE
78441c WRITE(MSTU(11),5100)
78442c STOP
78443c ENDIF
78444
78445C...Format for error printout.
78446c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78447c &1X,'Execution stopped!')
78448c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78449c &1X,'Dummy routine in PYTHIA file called instead.'/
78450c &1X,'Execution stopped!')
78451
78452c RETURN
78453c END
78454
78455C*********************************************************************
78456
78457C...UPEVNT
78458C...Dummy routine, to be replaced by a user implementing external
78459C...processes. Depending on cross section model chosen, it either has
78460C...to generate a process of the type IDPRUP requested, or pick a type
78461C...itself and generate this event. The event is to be stored in the
78462C...HEPEUP commonblock, including (often) an event weight.
78463
78464C...New example: handles a standard Les Houches Events File.
78465
78466 SUBROUTINE UPEVNT
78467
78468C...Double precision and integer declarations.
78469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78470 IMPLICIT INTEGER(I-N)
78471
78472C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78473 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78474 SAVE /PYPARS/
78475
78476C...User process event common block.
78477 INTEGER MAXNUP
78478 PARAMETER (MAXNUP=500)
78479 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78480 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78481 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78482 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78483 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78484 SAVE /HEPEUP/
78485
78486C...Lines to read in assumed never longer than 200 characters.
78487 PARAMETER (MAXLEN=200)
78488 CHARACTER*(MAXLEN) STRING
78489
78490C...Format for reading lines.
78491 CHARACTER*6 STRFMT
78492 STRFMT='(A000)'
78493 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78494
78495C...Loop until finds line beginning with "<event>" or "<event ".
78496 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
78497 IBEG=0
78498 110 IBEG=IBEG+1
78499C...Allow indentation.
78500 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
78501 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
78502 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
78503
78504C...Read first line of event info.
78505 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78506 &AQEDUP,AQCDUP
78507
78508C...Read NUP subsequent lines with information on each particle.
78509 DO 120 I=1,NUP
78510 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78511 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78512 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78513 120 CONTINUE
78514 RETURN
78515
78516C...Error exit, typically when no more events.
78517 130 WRITE(*,*) ' Failed to read LHEF event information.'
78518 WRITE(*,*) ' Will assume end of file has been reached.'
78519 NUP=0
78520 MSTI(51)=1
78521
78522 RETURN
78523 END
78524
78525C...Old example: handles a simple Pythia 6.4 event file.
78526
78527c SUBROUTINE UPEVNT
78528
78529C...Double precision and integer declarations.
78530c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78531c IMPLICIT INTEGER(I-N)
78532
78533C...Commonblocks.
78534c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78535c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78536c SAVE /PYDAT1/,/PYPARS/
78537
78538C...User process event common block.
78539c INTEGER MAXNUP
78540c PARAMETER (MAXNUP=500)
78541c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78542c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78543c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78544c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78545c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78546c SAVE /HEPEUP/
78547
78548C...Read info from file.
78549c IF(MSTP(162).GT.0) THEN
78550c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78551c & AQEDUP,AQCDUP
78552c DO 100 I=1,NUP
78553c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78554c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78555c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78556c 100 CONTINUE
78557c RETURN
78558C...Special when reached end of file or other error.
78559c 110 NUP=0
78560
78561C...Else not implemented.
78562c ELSE
78563c WRITE(MSTU(11),5000)
78564c STOP
78565c ENDIF
78566
78567C...Format for error printout.
78568c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78569c &1X,'Dummy routine in PYTHIA file called instead.'/
78570c &1X,'Execution stopped!')
78571
78572c RETURN
78573c END
78574
78575C*********************************************************************
78576
78577C...UPVETO
78578C...Dummy routine, to be replaced by user, to veto event generation
78579C...on the parton level, after parton showers but before multiple
78580C...interactions, beam remnants and hadronization is added.
78581C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78582C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78583C...be undecayed at this stage; if decayed their decay products will
78584C...have been allowed to shower.
78585
78586C...All partons at the end of the shower phase are stored in the
78587C...HEPEVT commonblock. The interesting information is
78588C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78589C...IDHEP(I) = the particle ID code according to PDG conventions,
78590C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78591C...All ISTHEP entries are 1, while the rest is zeroed.
78592
78593C...The user decision is to be conveyed by the IVETO value.
78594C...IVETO = 0 : retain current event and generate in full;
78595C... = 1 : abort generation of current event and move to next.
78596
78597 SUBROUTINE UPVETO(IVETO)
78598
78599C...HEPEVT commonblock.
78600 PARAMETER (NMXHEP=4000)
78601 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
78602 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
78603 DOUBLE PRECISION PHEP,VHEP
78604 SAVE /HEPEVT/
78605
78606C...Next few lines allow you to see what info PYVETO extracted from
78607C...the full event record for the first two events.
78608C...Delete if you don't want it.
78609 DATA NLIST/0/
78610 SAVE NLIST
78611 IF(NLIST.LE.2) THEN
78612 WRITE(*,*) ' Full event record at time of UPVETO call:'
78613 CALL PYLIST(1)
78614 WRITE(*,*) ' Part of event record made available to UPVETO:'
78615 CALL PYLIST(5)
78616 NLIST=NLIST+1
78617 ENDIF
78618
78619C...Make decision here.
78620 IVETO = 0
78621
78622 RETURN
78623 END
78624
78625C*********************************************************************
78626C...SUGRA
78627C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78628
78629 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78630 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78631 IMPLICIT INTEGER(I-N)
78632 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78633 INTEGER IMODL
78634C...Commonblocks.
78635 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78636 SAVE /PYDAT1/
78637
78638C...Stop program if this routine is ever called.
78639 WRITE(MSTU(11),5000)
78640 CALL PYSTOP(110)
78641
78642C...Format for error printout.
78643 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78644 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
78645 &1X,'Execution stopped!')
78646
78647 RETURN
78648 END
78649
78650C*********************************************************************
78651
78652C...VISAJE
78653C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78654
78655 FUNCTION VISAJE()
78656 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78657 IMPLICIT INTEGER(I-N)
78658 CHARACTER*40 VISAJE
78659
78660C...Commonblocks.
78661 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78662 SAVE /PYDAT1/
78663
78664C...Assign default value.
78665 VISAJE='Undefined'
78666
78667C...Stop program if this routine is ever called.
78668 WRITE(MSTU(11),5000)
78669 CALL PYSTOP(110)
78670
78671C...Format for error printout.
78672 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78673 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
78674 &1X,'Execution stopped!')
78675
78676 RETURN
78677 END
78678
78679C*********************************************************************
78680
78681C...SSMSSM
78682C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78683
78684 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78685 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78686 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78687 &IDUM1,IDUM2)
78688 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78689 IMPLICIT INTEGER(I-N)
78690 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78691 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78692 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
78693C...Commonblocks.
78694 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78695 SAVE /PYDAT1/
78696
78697C...Stop program if this routine is ever called.
78698 WRITE(MSTU(11),5000)
78699 CALL PYSTOP(110)
78700
78701C...Format for error printout.
78702 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78703 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78704 &1X,'Execution stopped!')
78705 RETURN
78706 END
78707
78708C*********************************************************************
78709
78710C...FHSETFLAGS
78711C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78712
78713 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78715 IMPLICIT INTEGER(I-N)
78716Cmssmpart = 4 # full MSSM [recommended]
78717Cfieldren = 0 # MSbar field ren. [strongly recommended]
78718Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78719Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78720Cp2approx = 0 # no approximation [recommended]
78721Clooplevel= 2 # include 2-loop corrections
78722Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78723Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78724
78725C...Commonblocks.
78726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78727 SAVE /PYDAT1/
78728
78729C...Stop program if this routine is ever called.
78730 WRITE(MSTU(11),5000)
78731 CALL PYSTOP(103)
78732
78733C...Format for error printout.
78734 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78735 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78736 &1X,'Execution stopped!')
78737 RETURN
78738 END
78739
78740C*********************************************************************
78741
78742C...FHSETPARA
78743C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78744
78745 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78746 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78747 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78748 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78749 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78750 IMPLICIT INTEGER(I-N)
78751
78752 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78753 DOUBLE COMPLEX DMU,
78754 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78755 & DM1, DM2, DM3
78756
78757C...Commonblocks.
78758 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78759 SAVE /PYDAT1/
78760
78761C...Stop program if this routine is ever called.
78762 WRITE(MSTU(11),5000)
78763 CALL PYSTOP(103)
78764
78765C...Format for error printout.
78766 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78767 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78768 &1X,'Execution stopped!')
78769 RETURN
78770 END
78771
78772C*********************************************************************
78773
78774C...FHHIGGSCORR
78775C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78776
78777 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
78778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78779 IMPLICIT INTEGER(I-N)
78780
78781C...FeynHiggs variables
78782 DOUBLE PRECISION RMHIGG(4)
78783 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78784 DOUBLE COMPLEX DMU,
78785 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78786 & DM1, DM2, DM3
78787
78788C...Commonblocks.
78789 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78790 SAVE /PYDAT1/
78791
78792C...Stop program if this routine is ever called.
78793 WRITE(MSTU(11),5000)
78794 CALL PYSTOP(103)
78795
78796C...Format for error printout.
78797 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78798 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78799 &1X,'Execution stopped!')
78800 RETURN
78801 END
78802
78803C*********************************************************************
78804
78805C...PYTAUD
78806C...Dummy routine, to be replaced by user, to handle the decay of a
78807C...polarized tau lepton.
78808C...Input:
78809C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78810C...IORIG is the position where the mother of the tau is stored;
78811C... is 0 when the mother is not stored.
78812C...KFORIG is the flavour of the mother of the tau;
78813C... is 0 when the mother is not known.
78814C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78815C... e.g. in B hadron semileptonic decays the W propagator
78816C... is not explicitly stored but the W code is still unambiguous.
78817C...Output:
78818C...NDECAY is the number of decay products in the current tau decay.
78819C...These decay products should be added to the /PYJETS/ common block,
78820C...in positions N+1 through N+NDECAY. For each product I you must
78821C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78822C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78823
78824 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
78825
78826C...Double precision and integer declarations.
78827 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78828 IMPLICIT INTEGER(I-N)
78829 INTEGER PYK,PYCHGE,PYCOMP
78830C...Commonblocks.
78831 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78832 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78833 SAVE /PYJETS/,/PYDAT1/
78834
78835C...Stop program if this routine is ever called.
78836C...You should not copy these lines to your own routine.
78837 NDECAY=ITAU+IORIG+KFORIG
78838 WRITE(MSTU(11),5000)
78839 CALL PYSTOP(10)
78840
78841C...Format for error printout.
78842 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
78843 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78844 &1X,'Execution stopped!')
78845
78846 RETURN
78847 END
78848
78849C*********************************************************************
78850
78851C...PYTIME
78852C...Finds current date and time.
78853C...Since this task is not standardized in Fortran 77, the routine
78854C...is dummy, to be replaced by the user. Examples are given for
78855C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78856C...you do not have access to suitable routines.
78857
78858 SUBROUTINE PYTIME(IDATI)
78859
78860C...Double precision and integer declarations.
78861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78862 IMPLICIT INTEGER(I-N)
78863 INTEGER PYK,PYCHGE,PYCOMP
78864 CHARACTER*8 ATIME
78865C...Local array.
78866 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
78867
78868C...Example 0: if you do not have suitable routines.
78869 DO 100 J=1,6
78870 IDATI(J)=0
78871 100 CONTINUE
78872
78873C...Example 1: Fortran 90 routine.
78874C CALL DATE_AND_TIME(VALUES=IVAL)
78875C IDATI(1)=IVAL(1)
78876C IDATI(2)=IVAL(2)
78877C IDATI(3)=IVAL(3)
78878C IDATI(4)=IVAL(5)
78879C IDATI(5)=IVAL(6)
78880C IDATI(6)=IVAL(7)
78881
78882C...Example 2: DEC Fortran 77. AIX.
78883C CALL IDATE(IMON,IDAY,IYEAR)
78884C IDATI(1)=IYEAR
78885C IDATI(2)=IMON
78886C IDATI(3)=IDAY
78887C CALL ITIME(IHOUR,IMIN,ISEC)
78888C IDATI(4)=IHOUR
78889C IDATI(5)=IMIN
78890C IDATI(6)=ISEC
78891
78892C...Example 3: DEC Fortran, IRIX, IRIX64.
78893C CALL IDATE(IMON,IDAY,IYEAR)
78894C IDATI(1)=IYEAR
78895C IDATI(2)=IMON
78896C IDATI(3)=IDAY
78897C CALL TIME(ATIME)
78898C IHOUR=0
78899C IMIN=0
78900C ISEC=0
78901C READ(ATIME(1:2),'(I2)') IHOUR
78902C READ(ATIME(4:5),'(I2)') IMIN
78903C READ(ATIME(7:8),'(I2)') ISEC
78904C IDATI(4)=IHOUR
78905C IDATI(5)=IMIN
78906C IDATI(6)=ISEC
78907
78908C...Example 4: GNU LINUX libU77, SunOS.
78909C CALL IDATE(IDTEMP)
78910C IDATI(1)=IDTEMP(3)
78911C IDATI(2)=IDTEMP(2)
78912C IDATI(3)=IDTEMP(1)
78913C CALL ITIME(IDTEMP)
78914C IDATI(4)=IDTEMP(1)
78915C IDATI(5)=IDTEMP(2)
78916C IDATI(6)=IDTEMP(3)
78917
78918C...Common code to ensure right century.
78919 IDATI(1)=2000+MOD(IDATI(1),100)
78920
78921 RETURN
78922 END
78923C... ALICE interface to PDFLIB with possibility to select nuclear structure
78924C... functions.
78925C...
78926C... The MSTP array in the PYPARS common block is used to enable and
78927C... select the nuclear structure functions.
78928C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
78929C... =1: internal PYTHIA acording to MSTP(51)
78930C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
78931C... MSTP( 51) = 1000xNPGROUP+NPSET
78932C... MSTP(151) = 1000xNAGROUP+NASET
78933C... MSTP(192) : Mass number of nucleus side 1
78934C... MSTP(193) : Mass number of nucleus side 2
78935C...
78936C...
78937C... MINT(124) : side (1 or 2)
78938
78939
78940 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
78941C...
78942 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78943 IMPLICIT INTEGER(I-N)
78944C...Interface to PDFLIB.
78945 COMMON/LW50512/QCDL4,QCDL5
78946 SAVE /LW50512/
78947 DOUBLE PRECISION QCDL4,QCDL5
78948 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
78949 SAVE /LW50513/
78950 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
78951C...
78952 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78953 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78954 DOUBLE PRECISION VALUE(20)
78955 CHARACTER*20 PARM(20)
78956 write(6,*) MSTP(52)
78957 write(6,*) PARM
78958 write(6,*) VALUE
78959
78960 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
78961 PARM(5)='NATYPE'
78962 VALUE(5)=4
78963 PARM(6)='NAGROUP'
78964 VALUE(6)=MSTP(191)/1000
78965 PARM(7)='NASET'
78966 VALUE(7)=MOD(MSTP(191),1000)
78967 CALL PDFSET(PARM,VALUE,
78968 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
78969 > QCDL4,QCDL5,
78970 > XMIN,XMAX,Q2MIN,Q2MAX)
78971 IF (MSTP(194) .EQ. 0) THEN
78972 CALL SETLHAPARM("EKS98")
78973 ELSE
78974 CALL SETLHAPARM("EPS08")
78975 ENDIF
78976 ELSE
78977 write(6,*) "-> pdfset"
78978 CALL PDFSET(PARM,VALUE,
78979 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
78980 > QCDL4,QCDL5,
78981 > XMIN,XMAX,Q2MIN,Q2MAX)
78982 ENDIF
78983 write(6,*) "done"
78984 END
78985
78986
78987
78988 SUBROUTINE STRUCTM_ALICE
78989 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
78990C...
78991 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78992 IMPLICIT INTEGER(I-N)
78993 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78994 COMMON/PYINT1/MINT(400),VINT(400)
78995C write(6,*) "structm_alice->"
78996 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
78997 A=MSTP(191+MINT(124))
78998C write(6,*) mint(124), "-> structa ", A
78999 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
79000 ELSE
79001C write(6,*) mint(124), "-> structm "
79002 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
79003 ENDIF
79004 END
79005