C++ Interface to Tauola
pythia-6.4.20.f
1C*********************************************************************
2C*********************************************************************
3C* **
4C* February 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,2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15/
1157 DATA (kfdp(i,1),i=4157,8000)/9*-15,2*15,2*-15,1,2,3,4,5,6,11,12,
1158 &9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1159 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1160 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1161 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1162 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1163 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1164 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1165 &-11,-13,-15,-17,
1166 &649*0,
1167C...UED
1168 &5100023,5100022,5100023,5100022,5100023,5100022,
1169 &5100023,5100022,5100023,5100022,5100023,5100022,
1170 &5100023,-5100024,5100022,5100023,5100024,5100022,
1171 &5100023,-5100024,5100022,5100023,5100024,5100022,
1172 &5100023,-5100024,5100022,5100023,5100024,5100022,
1173 &9*5100022,
1174 &6100001,6100002,6100003,6100004,6100005,6100006,
1175 &5100001,5100002,5100003,5100004,5100005,5100006,
1176 &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1177 &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
1178 &39,
1179 &6100011,6100013,6100015,
1180 &5100011,5100013,5100015,
1181 %5100012,5100014,5100016,
1182 &-6100011,-6100013,-6100015,
1183 &-5100011,-5100013,-5100015,
1184 %-5100012,-5100014,-5100016,
1185 &-5100011,-5100013,-5100015,
1186 &5100012,5100014,5100016,
1187 &2912*0/
1188 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,
1189 &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,
1190 &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,
1191 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1192 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1193 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1194 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1195 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1196 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1197 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1198 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1199 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1200 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1201 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1202 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1203 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1204 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1205 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1206 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1207 &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/
1208 DATA (kfdp(i,2),i= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1209 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1210 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1211 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1212 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1213 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1214 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1215 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1216 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1217 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1218 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1219 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1220 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1221 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1222 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1223 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1224 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1225 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1226 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1227 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1228 DATA (kfdp(i,2),i= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1229 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1230 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1231 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1232 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1233 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1234 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1235 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1236 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1237 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1238 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1239 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1240 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1241 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1242 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1243 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1244 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1245 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1246 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1247 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1248 DATA (kfdp(i,2),i= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1249 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1250 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1251 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1252 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1253 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1254 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1255 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1256 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1257 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1258 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1259 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1260 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1261 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1262 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1263 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1264 &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,
1265 &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,
1266 &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,
1267 &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/
1268 DATA (kfdp(i,2),i=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1269 &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,
1270 &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,
1271 &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,
1272 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1273 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1274 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1275 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1276 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1277 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1278 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1279 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1280 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1281 &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,
1282 &-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,
1283 &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,
1284 &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,
1285 &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,
1286 &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,
1287 &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/
1288 DATA (kfdp(i,2),i=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1289 &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,
1290 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1291 &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,
1292 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1293 &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,
1294 &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,
1295 &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,
1296 &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,
1297 &-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,
1298 &-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,
1299 &-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,
1300 &-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,
1301 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1302 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1303 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1304 &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,
1305 &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,
1306 &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,
1307 &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/
1308 DATA (kfdp(i,2),i=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1309 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1310 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1311 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1312 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1313 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1314 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1315 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1316 &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,
1317 &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,
1318 &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,
1319 &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,
1320 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1321 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1322 &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,
1323 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1324 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1325 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1326 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1327 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1328 DATA (kfdp(i,2),i=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1329 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1330 &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,
1331 &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,
1332 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1333 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1334 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1335 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1336 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1337 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1338 &-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,
1339 &-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,
1340 &-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,
1341 &-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,
1342 &-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,
1343 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1344 &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,
1345 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1346 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1347 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1348 DATA (kfdp(i,2),i=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1349 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1350 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1351 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1352 &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,
1353 &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,
1354 &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,
1355 &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,
1356 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1357 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1358 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1359 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1360 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1361 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1362 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1363 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1364 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1365 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1366 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1367 &-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/
1368 DATA (kfdp(i,2),i=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1369 &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,
1370 &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,
1371 &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,
1372 &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,
1373 &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,
1374 &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,
1375 &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,
1376 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1377 &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,
1378 &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,
1379 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1380 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1381 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1382 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1383 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1384 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1385 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1386 &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,
1387 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1388 DATA (kfdp(i,2),i=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1389 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1390 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1391 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1392 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1393 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1394 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1395 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1396 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1397 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1398 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1399 &649*0,
1400C...UED
1401 &1,1,2,2,3,3,4,4,5,5,6,6,
1402 &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1403 &11,13,15,12,11,14,13,16,15,
1404 &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1405 &1,2,3,4,5,6,1,2,3,4,5,6,
1406 &22,
1407 &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1408 &11,13,15,11,13,15,12,14,16,
1409 &12,14,16,-11,-13,-15,
1410 &2912*0/
1411 DATA (kfdp(i,3),i= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1412 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1413 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1414 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1415 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1416 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1417 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1418 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1419 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1420 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1421 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1422 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1423 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1424 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1425 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1426 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1427 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1428 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1429 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1430 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1431 DATA (kfdp(i,3),i=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1432 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1433 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1434 &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,
1435 &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,
1436 &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,
1437 &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,
1438 &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,
1439 &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,
1440 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1441 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1442 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1443 &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,
1444 &-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,
1445 &-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,
1446 &-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,
1447 &-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,
1448 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1449 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1450 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1451 DATA (kfdp(i,3),i=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1452 &-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,
1453 &-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,
1454 &-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,
1455 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1456 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1457 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1458 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1459 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1460 &-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,
1461 &-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,
1462 &-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,
1463 &-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,
1464 &-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,
1465 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1466 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1467 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1468 &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,
1469 &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,
1470 &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/
1471 DATA (kfdp(i,3),i=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1472 &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,
1473 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1474 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1475 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1476 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1477 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1478 &-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,
1479 &-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,
1480 &-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,
1481 &-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,
1482 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1483 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1484 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1485 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1486 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1487 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1488 &-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,
1489 &-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,
1490 &-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/
1491 DATA (kfdp(i,3),i=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1492 &-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,
1493 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1494 &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,
1495 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1496 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1497 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1498 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1499 &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,
1500 &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,
1501 &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,
1502 &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,
1503 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1504 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1505 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1506 DATA (kfdp(i,4),i= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1507 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1508 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1509 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1510 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1511 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1512 &-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,
1513 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1514 &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,
1515 &162*81,31*0,-211,111,6516*0/
1516 DATA (kfdp(i,5),i= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1517 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1518 &3*111,-211,111,7193*0/
1519
1520C...PYDAT4, with particle names (character strings).
1521 DATA (chaf(i,1),i= 1, 202)/'d','u','s','c','b','t','b''','t''',
1522 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1523 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1524 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1525 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1526 &'junction',' ','system','cluster','string','indep.','CMshower',
1527 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1528 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1529 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1530 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1531 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1532 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1533 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1534 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1535 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1536 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1537 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1538 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1539 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1540 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1541 DATA (chaf(i,1),i= 203, 332)/'Omega_cc+','Omega*_cc+',
1542 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1543 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1544 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1545 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1546 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1547 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1548 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1549 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1550 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1551 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1552 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1553 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1554 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1555 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1556 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1557 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1558 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1559 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1560 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1561 DATA (chaf(i,1),i= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1562 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1563 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1564 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1565 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1566 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1567 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1568 &81*' ',
1569C...UED
1570 &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1571 &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1572 &'e*_S-','mu*_S-','tau*_S-',
1573 &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1574 &'g*','gamma*','Z*0','W*+',25*' '/
1575 DATA (chaf(i,2),i= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1576 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1577 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1578 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1579 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1580 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1581 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1582 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1583 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1584 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1585 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1586 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1587 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1588 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1589 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1590 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1591 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1592 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1593 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1594 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1595 DATA (chaf(i,2),i= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1596 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1597 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1598 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1599 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1600 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1601 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1602 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1603 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1604 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1605 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1606 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1607 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1608 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1609 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1610 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1611 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1612 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1613 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1614 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1615 DATA (chaf(i,2),i= 326, 500)/'~nu_muRbar','~tau_2+',
1616 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1617 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1618 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1619 &81*' ',
1620C...UED
1621 &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1622 &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1623 &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1624 &'nu*_eDbar','e*_Dbar+',
1625 &'nu*_muDbar','mu*_Dbar+',
1626 &'nu*_tauDbar','tau*_Dbar+',
1627 &'g*','gamma*','Z*0','W*-',25*' '/
1628
1629C...PYDATR, with initial values for the random number generator.
1630 DATA mrpy/19780503,0,0,97,33,0/
1631
1632C...Default values for allowed processes and kinematics constraints.
1633 DATA msel/1/
1634 DATA msub/500*0/
1635 DATA ((kfin(i,j),j=-40,40),i=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1636 &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,
1637 &6*1,4*0,4*1,16*0/
1638 DATA ckin/
1639 & 2.0d0, -1.0d0, 0.0d0, -1.0d0, 1.0d0,
1640 & 1.0d0, -10d0, 10d0, -40d0, 40d0,
1641 1 -40d0, 40d0, -40d0, 40d0, -40d0,
1642 1 40d0, -1.0d0, 1.0d0, -1.0d0, 1.0d0,
1643 2 0.0d0, 1.0d0, 0.0d0, 1.0d0, -1.0d0,
1644 2 1.0d0, -1.0d0, 1.0d0, 0d0, 0d0,
1645 3 2.0d0, -1.0d0, 0d0, 0d0, 0.0d0,
1646 3 -1.0d0, 0.0d0, -1.0d0, 4.0d0, -1.0d0,
1647 4 12.0d0, -1.0d0, 12.0d0, -1.0d0, 12.0d0,
1648 4 -1.0d0, 12.0d0, -1.0d0, 0d0, 0d0,
1649 5 0.0d0, -1.0d0, 0.0d0, -1.0d0, 0.0d0,
1650 5 -1.0d0, 0d0, 0d0, 0d0, 0d0,
1651 6 0.0001d0, 0.99d0, 0.0001d0, 0.99d0, 0d0,
1652 6 -1d0, 0d0, -1d0, 0d0, -1d0,
1653 7 0d0, -1d0, 0.0001d0, 0.99d0, 0.0001d0,
1654 7 0.99d0, 2d0, -1d0, 0d0, 0d0,
1655 8 120*0d0/
1656
1657C...Default values for main switches and parameters. Reset information.
1658 DATA (mstp(i),i=1,100)/
1659 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1660 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1661 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1662 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1663 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1664 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1665 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1666 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1667 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1668 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1669 DATA (mstp(i),i=101,200)/
1670 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1671 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1672 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1673 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1674 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1675 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1676 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1677 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1678 8 6, 420, 2009, 02, 20, 0, 0, 0, 0, 0,
1679 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1680 DATA (parp(i),i=1,100)/
1681 & 0.25d0, 10d0, 8*0d0,
1682 1 0d0, 0d0, 1.0d0, 0.01d0, 0.5d0, 1.0d0, 1.0d0, 0.4d0, 2*0d0,
1683 2 10*0d0,
1684 3 1.5d0,2.0d0,0.075d0,1.0d0,0.2d0,0d0,1.0d0,0.70d0,0.006d0,0d0,
1685 4 0.02d0,2.0d0,0.10d0,1000d0,2054d0,123d0,246d0,50d0,0d0,0.054d0,
1686 5 10*0d0,
1687 6 0.25d0, 1.0d0,0.25d0, 1.0d0, 2.0d0,1d-3, 4.0d0,1d-3,2*0d0,
1688 7 4.0d0, 0.25d0, 5*0d0, 0.025d0, 2.0d0, 0.1d0,
1689 8 1.90d0, 2.0d0, 0.5d0, 0.4d0, 0.90d0,
1690 8 0.95d0, 0.7d0, 0.5d0, 1800d0, 0.16d0,
1691 9 2.0d0,0.40d0,5.0d0,1.0d0,0.0d0,3.0d0,1.0d0,0.75d0,1.0d0,5.0d0/
1692 DATA (parp(i),i=101,200)/
1693 & 0.5d0, 0.28d0, 1.0d0, 0.8d0, 0d0, 0d0, 0d0, 0d0, 0d0, 1d0,
1694 1 2.0d0, 3*0d0, 1.5d0, 0.5d0, 0.6d0, 2.5d0, 2.0d0, 1.0d0,
1695 2 1.0d0, 0.4d0, 8*0d0,
1696 3 0.01d0, 9*0d0,
1697 4 1.16d0, 0.0119d0, 0.01d0, 0.01d0, 0.05d0,
1698 4 9.28d0, 0.15d0, 0.02d0, 0.48d0, 0.09d0,
1699 5 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,
1700 6 2.20d0, 23.6d0, 18.4d0, 11.5d0, 0.5d0, 0d0, 0d0, 0d0, 2*0d0,
1701 7 0d0, 0d0, 0d0, 1.0d0, 6*0d0,
1702 8 0.1d0, 0.01d0, 0.01d0, 0.01d0, 0.1d0, 0.01d0, 0.01d0, 0.01d0,
1703 8 0.3d0, 0.64d0,
1704 9 0.64d0, 5.0d0, 1.0d4, 1.0d4, 6*0d0/
1705 DATA msti/200*0/
1706 DATA pari/200*0d0/
1707 DATA mint/400*0/
1708 DATA vint/400*0d0/
1709
1710C...Constants for the generation of the various processes.
1711 DATA (iset(i),i=1,100)/
1712 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1713 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1714 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1715 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1716 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1717 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1718 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1719 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1720 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1721 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1722 DATA (iset(i),i=101,200)/
1723 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1724 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1725 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1726 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1727 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1728 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1729 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1730 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1731 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1732 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1733 DATA (iset(i),i=201,300)/
1734 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1735 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1736 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1737 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1738 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1739 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1740 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1741 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1742 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1743 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1744 DATA (iset(i),i=301,500)/
1745 & 2, 9*-2, 9*2, 21*-2,
1746 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1747 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1748 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1749 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1750 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1751 9 1, 1, 2, 2, 2, 5*-2,
1752 & 5, 5, 18*-2,
1753 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1754 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1755 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1756 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1757 DATA ((kfpr(i,j),j=1,2),i=1,50)/
1758 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1759 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1760 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1761 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1762 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1763 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1764 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1765 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1766 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1767 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1768 DATA ((kfpr(i,j),j=1,2),i=51,100)/
1769 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1770 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1771 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1772 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1773 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1774 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1775 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1776 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1777 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1778 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1779 DATA ((kfpr(i,j),j=1,2),i=101,150)/
1780 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1781 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1782 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1783 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1784 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1785 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1786 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1787 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1788 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1789 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1790 DATA ((kfpr(i,j),j=1,2),i=151,200)/
1791 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1792 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1793 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1794 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1795 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1796 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1797 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1798 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1799 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1800 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1801 DATA ((kfpr(i,j),j=1,2),i=201,240)/
1802 & 1000011, 1000011, 2000011, 2000011, 1000011,
1803 & 2000011, 1000013, 1000013, 2000013, 2000013,
1804 & 1000013, 2000013, 1000015, 1000015, 2000015,
1805 & 2000015, 1000015, 2000015, 1000011, 1000012,
1806 1 1000015, 1000016, 2000015, 1000016, 1000012,
1807 1 1000012, 1000016, 1000016, 0, 0,
1808 1 1000022, 1000022, 1000023, 1000023, 1000025,
1809 1 1000025, 1000035, 1000035, 1000022, 1000023,
1810 2 1000022, 1000025, 1000022, 1000035, 1000023,
1811 2 1000025, 1000023, 1000035, 1000025, 1000035,
1812 2 1000024, 1000024, 1000037, 1000037, 1000024,
1813 2 1000037, 1000022, 1000024, 1000023, 1000024,
1814 3 1000025, 1000024, 1000035, 1000024, 1000022,
1815 3 1000037, 1000023, 1000037, 1000025, 1000037,
1816 3 1000035, 1000037, 1000021, 1000022, 1000021,
1817 3 1000023, 1000021, 1000025, 1000021, 1000035/
1818 DATA ((kfpr(i,j),j=1,2),i=241,280)/
1819 4 1000021, 1000024, 1000021, 1000037, 1000021,
1820 4 1000021, 1000021, 1000021, 0, 0,
1821 4 1000002, 1000022, 2000002, 1000022, 1000002,
1822 4 1000023, 2000002, 1000023, 1000002, 1000025,
1823 5 2000002, 1000025, 1000002, 1000035, 2000002,
1824 5 1000035, 1000001, 1000024, 2000005, 1000024,
1825 5 1000001, 1000037, 2000005, 1000037, 1000002,
1826 5 1000021, 2000002, 1000021, 0, 0,
1827 6 1000006, 1000006, 2000006, 2000006, 1000006,
1828 6 2000006, 1000006, 1000006, 2000006, 2000006,
1829 6 0, 0, 0, 0, 0,
1830 6 0, 0, 0, 0, 0,
1831 7 1000002, 1000002, 2000002, 2000002, 1000002,
1832 7 2000002, 1000002, 1000002, 2000002, 2000002,
1833 7 1000002, 2000002, 1000002, 1000002, 2000002,
1834 7 2000002, 1000002, 1000002, 2000002, 2000002/
1835 DATA ((kfpr(i,j),j=1,2),i=281,350)/
1836 8 1000005, 1000002, 2000005, 2000002, 1000005,
1837 8 2000002, 1000005, 1000002, 2000005, 2000002,
1838 8 1000005, 2000002, 1000005, 1000005, 2000005,
1839 8 2000005, 1000005, 1000005, 2000005, 2000005,
1840 9 1000005, 1000005, 2000005, 2000005, 1000005,
1841 9 2000005, 1000005, 1000021, 2000005, 1000021,
1842 9 1000005, 2000005, 37, 25, 37,
1843 9 35, 36, 25, 36, 35,
1844 & 37, 37, 18*0,
1845C...UED: 311-319
1846 & 5100021, 5100021,
1847 & 5100002, 5100021,
1848 & 5100002, 5100001,
1849 & 5100002, -5100002,
1850 & 5100002, -5100002,
1851 & 5100002, -6100001,
1852 & 5100002, -5100001,
1853 & 5100002, 6100001,
1854 & 5100001, -5100001,
1855 & 42*0,
1856 4 9900041, 0, 9900042, 0, 9900041,
1857 4 11, 9900042, 11, 9900041, 13,
1858 4 9900042, 13, 9900041, 15, 9900042,
1859 4 15, 9900041, 9900041, 9900042, 9900042/
1860 DATA ((kfpr(i,j),j=1,2),i=351,400)/
1861 5 9900041, 0, 9900042, 0, 9900023,
1862 5 0, 9900024, 0, 0, 0,
1863 5 0, 0, 0, 0, 0,
1864 5 0, 0, 0, 0, 0,
1865 6 24, 24, 24, 3000211, 3000211,
1866 6 3000211, 22, 3000111, 22, 3000221,
1867 6 23, 3000111, 23, 3000221, 24,
1868 6 3000211, 0, 0, 24, 23,
1869 7 24, 3000111, 3000211, 23, 3000211,
1870 7 3000111, 22, 3000211, 23, 3000211,
1871 7 24, 3000111, 24, 3000221, 22,
1872 7 24, 22, 23, 23, 23,
1873 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1874 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1875 9 5000039, 0, 5000039, 0, 21,
1876 9 5000039, 0, 5000039, 21, 5000039,
1877 9 10*0/
1878 DATA ((kfpr(i,j),j=1,2),i=401,500)/
1879 & 37, 6, 37, 6, 36*0,
1880 2 443, 21, 9900443, 21, 9900441,
1881 2 21, 9910441, 21, 0, 9900443,
1882 2 0, 9900441, 0, 9910441, 21,
1883 2 9900443, 21, 9900441, 21, 9910441,
1884 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1885 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1886 6 553, 21, 9900553, 21, 9900551,
1887 6 21, 9910551, 21, 0, 9900553,
1888 6 0, 9900551, 0, 9910551, 21,
1889 6 9900553, 21, 9900551, 21, 9910551,
1890 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1891 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1892 DATA coef/10000*0d0/
1893 DATA (((icol(i,j,k),k=1,2),j=1,4),i=1,40)/
1894 &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,
1895 &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,
1896 &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,
1897 &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,
1898 &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,
1899 &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,
1900 &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,
1901 &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,
1902 &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,
1903 &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/
1904
1905C...Treatment of resonances.
1906 DATA (mwid(i) ,i= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1907 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1908 &81*0,21*1,4*1,25*0/
1909
1910C...Character constants: name of processes.
1911 DATA proc(0)/ 'All included subprocesses '/
1912 DATA (proc(i),i=1,20)/
1913 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1914 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1915 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1916 &' ', 'W+ + W- -> h0 ',
1917 &' ', 'f + f'' -> f + f'' (QFD) ',
1918 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1919 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1920 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1921 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1922 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1923 DATA (proc(i),i=21,40)/
1924 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1925 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1926 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1927 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1928 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1929 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1930 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1931 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1932 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1933 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1934 DATA (proc(i),i=41,60)/
1935 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1936 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1937 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1938 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1939 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1940 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1941 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1942 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1943 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1944 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1945 DATA (proc(i),i=61,80)/
1946 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1947 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1948 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1949 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1950 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1951 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1952 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1953 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1954 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1955 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1956 DATA (proc(i),i=81,100)/
1957 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1958 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1959 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1960 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1961 8'g + g -> chi_2c + g ', ' ',
1962 9'Elastic scattering ', 'Single diffractive (XB) ',
1963 9'Single diffractive (AX) ', 'Double diffractive ',
1964 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1965 9' ', ' ',
1966 9'q + gamma* -> q ', ' '/
1967 DATA (proc(i),i=101,120)/
1968 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1969 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1970 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1971 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1972 &' ', 'f + fbar -> gamma + h0 ',
1973 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1974 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1975 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1976 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1977 1' ', ' '/
1978 DATA (proc(i),i=121,140)/
1979 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1980 2'f + f'' -> f + f'' + h0 ',
1981 2'f + f'' -> f" + f"'' + h0 ',
1982 2' ', ' ',
1983 2' ', ' ',
1984 2' ', ' ',
1985 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1986 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1987 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1988 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1989 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1990 DATA (proc(i),i=141,160)/
1991 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1992 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1993 4'q + l -> LQ ', 'e + gamma -> e* ',
1994 4'd + g -> d* ', 'u + g -> u* ',
1995 4'g + g -> eta_tc ', ' ',
1996 5'f + fbar -> H0 ', 'g + g -> H0 ',
1997 5'gamma + gamma -> H0 ', ' ',
1998 5' ', 'f + fbar -> A0 ',
1999 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
2000 5' ', ' '/
2001 DATA (proc(i),i=161,180)/
2002 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
2003 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
2004 6'f + fbar -> f'' + fbar'' (g/Z)',
2005 6'f +fbar'' -> f" + fbar"'' (W) ',
2006 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
2007 6'q + qbar -> e + e* ', ' ',
2008 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
2009 7'f + f'' -> f + f'' + H0 ',
2010 7'f + f'' -> f" + f"'' + H0 ',
2011 7' ', 'f + fbar -> Z0 + A0 ',
2012 7'f + fbar'' -> W+/- + A0 ',
2013 7'f + f'' -> f + f'' + A0 ',
2014 7'f + f'' -> f" + f"'' + A0 ',
2015 7' '/
2016 DATA (proc(i),i=181,200)/
2017 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
2018 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
2019 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
2020 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
2021 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
2022 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
2023 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
2024 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
2025 9' ', ' ',
2026 9' ', ' '/
2027 DATA (proc(i),i=201,220)/
2028 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
2029 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
2030 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
2031 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
2032 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
2033 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2034 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
2035 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
2036 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
2037 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
2038 DATA (proc(i),i=221,240)/
2039 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2040 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2041 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2042 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2043 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2044 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2045 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2046 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2047 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
2048 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
2049 DATA (proc(i),i=241,260)/
2050 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
2051 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
2052 4' ', 'qj + g -> ~qj_L + ~chi1 ',
2053 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
2054 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
2055 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
2056 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
2057 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
2058 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
2059 5'qj + g -> ~qj_R + ~g ', ' '/
2060 DATA (proc(i),i=261,300)/
2061 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
2062 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
2063 6'g + g -> ~t_2 + ~t_2bar ', ' ',
2064 6' ', ' ',
2065 6' ', ' ',
2066 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
2067 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
2068 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
2069 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
2070 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
2071 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
2072 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
2073 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
2074 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
2075 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
2076 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
2077 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
2078 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
2079 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
2080 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
2081 DATA (proc(i),i=301,340)/
2082 &'f + fbar -> H+ + H- ',
2083 &9*' ', 'g + g -> g* + g* ',
2084 &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
2085 &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
2086 &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
2087 &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
2088 &21*' '/
2089 DATA (proc(i),i=341,380)/
2090 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
2091 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
2092 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
2093 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
2094 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
2095 5'f + f -> f'' + f'' + H_L++/-- ',
2096 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
2097 5'f + fbar'' -> W_R+/- ',5*' ',
2098 6' ', 'f + fbar -> W_L+ W_L- ',
2099 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
2100 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
2101 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
2102 6'f + fbar -> W+/- pi_T-/+ ', ' ',
2103 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
2104 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
2105 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
2106 7'f + fbar'' -> W+/- pi_T0 ',
2107 7'f + fbar'' -> W+/- pi_T0'' ',
2108 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2109 7'f + fbar -> Z0 Z0 (ETC) '/
2110 DATA (proc(i),i=381,420)/
2111 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
2112 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
2113 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
2114 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
2115 8' ', ' ',
2116 9'f + fbar -> G* ', 'g + g -> G* ',
2117 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
2118 9'g + g -> g + G* ', ' ',
2119 9 4*' ',
2120 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
2121 & 18*' '/
2122 DATA (proc(i),i=421,460)/
2123 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2124 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2125 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2126 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2127 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2128 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2129 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2130 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2131 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2132 3'q + q~ -> g + cc~[3P2(1)] ',
2133 3 21 *' '/
2134 DATA (proc(i),i=461,500)/
2135 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2136 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2137 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2138 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2139 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2140 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2141 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2142 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2143 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2144 7'q + q~ -> g + bb~[3P2(1)] ',
2145 7 21 *' '/
2146
2147C...Cross sections and slope offsets.
2148 DATA sigt/294*0d0/
2149
2150C...Supersymmetry switches and parameters.
2151 DATA imss/0,
2152 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2153 1 89*0/
2154 DATA rmss/0d0,
2155 & 80d0,160d0,500d0,800d0,2d0,250d0,200d0,800d0,700d0,800d0,
2156 1 700d0,500d0,250d0,200d0,800d0,400d0,0d0,0.1d0,850d0,0.041d0,
2157 2 1d0,800d0,1d4,1d4,1d4,0d0,0d0,0d0,24d17,0d0,
2158 3 10*0d0,
2159 4 0d0,1d0,8*0d0,
2160 5 49*0d0/
2161C...Initial values for R-violating SUSY couplings.
2162C...Should not be changed here. See PYMSIN.
2163 DATA rvlam/27*0d0/
2164 DATA rvlamp/27*0d0/
2165 DATA rvlamb/27*0d0/
2166
2167C...Technicolor switches and parameters
2168 DATA itcm/0,
2169 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2170 1 89*0/
2171 DATA rtcm/0d0,
2172 & 82d0,1.333d0,.333d0,0.408d0,1d0,1d0,.0182d0,1d0,0d0,1.333d0,
2173 1 .05d0,200d0,200d0,0d0,0d0,0d0,0d0,0d0,0d0,0d0,
2174 2 .283d0,.707d0,0d0,0d0,0d0,1.667d0,250d0,250d0,.707d0,0d0,
2175 3 .707d0,0d0,1d0,0d0,0d0,0d0,0d0,0d0,0d0,0d0,
2176 4 1000d0, 1d0, 1d0, 1d0, 1d0, 0d0, 1d0, 3*200d0,
2177 4 200d0, 48*0d0/
2178
2179C...UED switches and parameters.
2180C... IUED(0) empty IUED vector element
2181C... IUED(1) UED ON(=1)/OFF(=0) switch
2182C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2183C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2184C... IUED(4) N the number of large extra dimensions
2185C... IUED(5) Selects whether the code takes Lambda (=0)
2186C... or Lambda*R (=1) as input.
2187C... IUED(6) With radiative corrections to the masses (=1)
2188C... or without (=0)
2189C...
2190C... RUED(0) empty RUED vector element
2191C... RUED(1) RINV (1/R) the curvature of the extra dimension
2192C... RUED(2) XMD the (4+N)-dimensional Planck scale
2193C... RUED(3) LAMUED (Lambda cutoff scale)
2194C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2195C...
2196 DATA iued/0,0,0,5,6,0,1,93*0/
2197 DATA rued/0.d0,1000d0,5000d0,20000.,20.,95*0d0/
2198
2199C...Data for histogramming routines.
2200 DATA ihist/1000,20000,55,1/
2201 DATA indx/1000*0/
2202
2203C...Data for SUSY Les Houches Accord.
2204 DATA cpro/'PYTHIA ','PYTHIA '/
2205 DATA cver/'6.4 ','6.4 '/
2206 DATA modsel/200*0/
2207 DATA parmin/100*0d0/
2208 DATA rmsoft/101*0d0/
2209 DATA au/9*0d0/
2210 DATA ad/9*0d0/
2211 DATA ae/9*0d0/
2212
2213 END
2214
2215C*********************************************************************
2216
2217C...PYCKBD
2218C...Check that BLOCK DATA PYDATA has been loaded.
2219C...Should not be required, except that some compilers/linkers
2220C...are pretty buggy in this respect.
2221
2222 SUBROUTINE pyckbd
2223
2224C...Double precision and integer declarations.
2225 IMPLICIT DOUBLE PRECISION(a-h, o-z)
2226 IMPLICIT INTEGER(I-N)
2227 INTEGER PYK,PYCHGE,PYCOMP
2228C...Commonblocks.
2229 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2230 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2231 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2232 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2233 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2234 common/pypars/mstp(200),parp(200),msti(200),pari(200)
2235 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/
2236
2237C...Check a few variables to see they have been sensibly initialized.
2238 IF(mstu(4).LT.10.OR.mstu(4).GT.900000.OR.pmas(2,1).LT.0.001d0
2239 &.OR.pmas(2,1).GT.1d0.OR.ckin(5).LT.0.01d0.OR.mstp(1).LT.1.OR.
2240 &mstp(1).GT.5) THEN
2241C...If not, abort the run right away.
2242 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2243 WRITE(*,*) 'The program execution is stopped now!'
2244 CALL pystop(8)
2245 ENDIF
2246
2247 RETURN
2248 END
2249
2250C*********************************************************************
2251
2252C...PYTEST
2253C...A simple program (disguised as subroutine) to run at installation
2254C...as a check that the program works as intended.
2255
2256 SUBROUTINE pytest(MTEST)
2257
2258C...Double precision and integer declarations.
2259 IMPLICIT DOUBLE PRECISION(a-h, o-z)
2260 IMPLICIT INTEGER(I-N)
2261 INTEGER PYK,PYCHGE,PYCOMP
2262C...Commonblocks.
2263 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2264 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2265 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2266 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2267 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2268 common/pypars/mstp(200),parp(200),msti(200),pari(200)
2269 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/
2270C...Local arrays.
2271 dimension psum(5),pini(6),pfin(6)
2272
2273C...Save defaults for values that are changed.
2274 mstj1=mstj(1)
2275 mstj3=mstj(3)
2276 mstj11=mstj(11)
2277 mstj42=mstj(42)
2278 mstj43=mstj(43)
2279 mstj44=mstj(44)
2280 parj17=parj(17)
2281 parj22=parj(22)
2282 parj43=parj(43)
2283 parj54=parj(54)
2284 mst101=mstj(101)
2285 mst104=mstj(104)
2286 mst105=mstj(105)
2287 mst107=mstj(107)
2288 mst116=mstj(116)
2289
2290C...First part: loop over simple events to be generated.
2291 IF(mtest.GE.1) CALL pytabu(20)
2292 nerr=0
2293 DO 180 iev=1,500
2294
2295C...Reset parameter values. Switch on some nonstandard features.
2296 mstj(1)=1
2297 mstj(3)=0
2298 mstj(11)=1
2299 mstj(42)=2
2300 mstj(43)=4
2301 mstj(44)=2
2302 parj(17)=0.1d0
2303 parj(22)=1.5d0
2304 parj(43)=1d0
2305 parj(54)=-0.05d0
2306 mstj(101)=5
2307 mstj(104)=5
2308 mstj(105)=0
2309 mstj(107)=1
2310 IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3
2311
2312C...Ten events each for some single jets configurations.
2313 IF(iev.LE.50) THEN
2314 ity=(iev+9)/10
2315 mstj(3)=-1
2316 IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2
2317 IF(ity.EQ.1) CALL py1ent(1,1,15d0,0d0,0d0)
2318 IF(ity.EQ.2) CALL py1ent(1,3101,15d0,0d0,0d0)
2319 IF(ity.EQ.3) CALL py1ent(1,-2203,15d0,0d0,0d0)
2320 IF(ity.EQ.4) CALL py1ent(1,-4,30d0,0d0,0d0)
2321 IF(ity.EQ.5) CALL py1ent(1,21,15d0,0d0,0d0)
2322
2323C...Ten events each for some simple jet systems; string fragmentation.
2324 ELSEIF(iev.LE.130) THEN
2325 ity=(iev-41)/10
2326 IF(ity.EQ.1) CALL py2ent(1,1,-1,40d0)
2327 IF(ity.EQ.2) CALL py2ent(1,4,-4,30d0)
2328 IF(ity.EQ.3) CALL py2ent(1,2,2103,100d0)
2329 IF(ity.EQ.4) CALL py2ent(1,21,21,40d0)
2330 IF(ity.EQ.5) CALL py3ent(1,2101,21,-3203,30d0,0.6d0,0.8d0)
2331 IF(ity.EQ.6) CALL py3ent(1,5,21,-5,40d0,0.9d0,0.8d0)
2332 IF(ity.EQ.7) CALL py3ent(1,21,21,21,60d0,0.7d0,0.5d0)
2333 IF(ity.EQ.8) CALL py4ent(1,2,21,21,-2,40d0,
2334 & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2335
2336C...Seventy events with independent fragmentation and momentum cons.
2337 ELSEIF(iev.LE.200) THEN
2338 ity=1+(iev-131)/16
2339 mstj(2)=1+mod(iev-131,4)
2340 mstj(3)=1+mod((iev-131)/4,4)
2341 IF(ity.EQ.1) CALL py2ent(1,4,-5,40d0)
2342 IF(ity.EQ.2) CALL py3ent(1,3,21,-3,40d0,0.9d0,0.4d0)
2343 IF(ity.EQ.3) CALL py4ent(1,2,21,21,-2,40d0,
2344 & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2345 IF(ity.GE.4) CALL py4ent(1,2,-3,3,-2,40d0,
2346 & 0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)
2347
2348C...A hundred events with random jets (check invariant mass).
2349 ELSEIF(iev.LE.300) THEN
2350 100 DO 110 j=1,5
2351 psum(j)=0d0
2352 110 CONTINUE
2353 njet=2d0+6d0*pyr(0)
2354 DO 130 i=1,njet
2355 kfl=21
2356 IF(i.EQ.1) kfl=int(1d0+4d0*pyr(0))
2357 IF(i.EQ.njet) kfl=-int(1d0+4d0*pyr(0))
2358 ejet=5d0+20d0*pyr(0)
2359 theta=acos(2d0*pyr(0)-1d0)
2360 phi=6.2832d0*pyr(0)
2361 IF(i.LT.njet) CALL py1ent(-i,kfl,ejet,theta,phi)
2362 IF(i.EQ.njet) CALL py1ent(i,kfl,ejet,theta,phi)
2363 IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1
2364 IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+pymass(kfl)
2365 DO 120 j=1,4
2366 psum(j)=psum(j)+p(i,j)
2367 120 CONTINUE
2368 130 CONTINUE
2369 IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.
2370 & (psum(5)+parj(32))**2) GOTO 100
2371
2372C...Fifty e+e- continuum events with matrix elements.
2373 ELSEIF(iev.LE.350) THEN
2374 mstj(101)=2
2375 CALL pyeevt(0,40d0)
2376
2377C...Fifty e+e- continuum event with varying shower options.
2378 ELSEIF(iev.LE.400) THEN
2379 mstj(42)=1+mod(iev,2)
2380 mstj(43)=1+mod(iev/2,4)
2381 mstj(44)=mod(iev/8,3)
2382 CALL pyeevt(0,90d0)
2383
2384C...Fifty e+e- continuum events with coherent shower.
2385 ELSEIF(iev.LE.450) THEN
2386 CALL pyeevt(0,500d0)
2387
2388C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2389 ELSE
2390 CALL pyonia(5,9.46d0)
2391 ENDIF
2392
2393C...Generate event. Find total momentum, energy and charge.
2394 DO 140 j=1,4
2395 pini(j)=pyp(0,j)
2396 140 CONTINUE
2397 pini(6)=pyp(0,6)
2398 CALL pyexec
2399 DO 150 j=1,4
2400 pfin(j)=pyp(0,j)
2401 150 CONTINUE
2402 pfin(6)=pyp(0,6)
2403
2404C...Check conservation of energy, momentum and charge;
2405C...usually exact, but only approximate for single jets.
2406 merr=0
2407 IF(iev.LE.50) THEN
2408 IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.10d0)
2409 & merr=merr+1
2410 epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)
2411 IF(epzrem.LT.0d0.OR.epzrem.GT.2d0*parj(31)) merr=merr+1
2412 IF(abs(pfin(6)-pini(6)).GT.2.1d0) merr=merr+1
2413 ELSE
2414 DO 160 j=1,4
2415 IF(abs(pfin(j)-pini(j)).GT.0.0001d0*pini(4)) merr=merr+1
2416 160 CONTINUE
2417 IF(abs(pfin(6)-pini(6)).GT.0.1d0) merr=merr+1
2418 ENDIF
2419 IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
2420 & (pfin(j),j=1,4),pfin(6)
2421
2422C...Check that all KF codes are known ones, and that partons/particles
2423C...satisfy energy-momentum-mass relation. Store particle statistics.
2424 DO 170 i=1,n
2425 IF(k(i,1).GT.20) GOTO 170
2426 IF(pycomp(k(i,2)).EQ.0) THEN
2427 WRITE(mstu(11),5100) i
2428 merr=merr+1
2429 ENDIF
2430 pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
2431 IF(abs(pd).GT.max(0.1d0,0.001d0*p(i,4)**2).OR.p(i,4).LT.0d0)
2432 & THEN
2433 WRITE(mstu(11),5200) i
2434 merr=merr+1
2435 ENDIF
2436 170 CONTINUE
2437 IF(mtest.GE.1) CALL pytabu(21)
2438
2439C...List all erroneous events and some normal ones.
2440 IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN
2441 IF(merr.GE.1) WRITE(mstu(11),6400)
2442 CALL pylist(2)
2443 ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN
2444 CALL pylist(1)
2445 ENDIF
2446
2447C...Stop execution if too many errors.
2448 IF(merr.NE.0) nerr=nerr+1
2449 IF(nerr.GE.10) THEN
2450 WRITE(mstu(11),6300)
2451 CALL pylist(1)
2452 CALL pystop(9)
2453 ENDIF
2454 180 CONTINUE
2455
2456C...Summarize result of run.
2457 IF(mtest.GE.1) CALL pytabu(22)
2458
2459C...Reset commonblock variables changed during run.
2460 mstj(1)=mstj1
2461 mstj(3)=mstj3
2462 mstj(11)=mstj11
2463 mstj(42)=mstj42
2464 mstj(43)=mstj43
2465 mstj(44)=mstj44
2466 parj(17)=parj17
2467 parj(22)=parj22
2468 parj(43)=parj43
2469 parj(54)=parj54
2470 mstj(101)=mst101
2471 mstj(104)=mst104
2472 mstj(105)=mst105
2473 mstj(107)=mst107
2474 mstj(116)=mst116
2475
2476C...Second part: complete events of various kinds.
2477C...Common initial values. Loop over initiating conditions.
2478 mstp(122)=max(0,min(2,mtest))
2479 mdcy(pycomp(111),1)=0
2480 DO 230 iproc=1,8
2481
2482C...Reset process type, kinematics cuts, and the flags used.
2483 msel=0
2484 DO 190 isub=1,500
2485 msub(isub)=0
2486 190 CONTINUE
2487 ckin(1)=2d0
2488 ckin(3)=0d0
2489 mstp(2)=1
2490 mstp(11)=0
2491 mstp(33)=0
2492 mstp(81)=1
2493 mstp(82)=1
2494 mstp(111)=1
2495 mstp(131)=0
2496 mstp(133)=0
2497 parp(131)=0.01d0
2498
2499C...Prompt photon production at fixed target.
2500 IF(iproc.EQ.1) THEN
2501 pzsum=300d0
2502 pesum=sqrt(pzsum**2+pymass(211)**2)+pymass(2212)
2503 pqsum=2d0
2504 msel=10
2505 ckin(3)=5d0
2506 CALL pyinit('FIXT','pi+','p',pzsum)
2507
2508C...QCD processes at ISR energies.
2509 ELSEIF(iproc.EQ.2) THEN
2510 pesum=63d0
2511 pzsum=0d0
2512 pqsum=2d0
2513 msel=1
2514 ckin(3)=5d0
2515 CALL pyinit('CMS','p','p',pesum)
2516
2517C...W production + multiple interactions at CERN Collider.
2518 ELSEIF(iproc.EQ.3) THEN
2519 pesum=630d0
2520 pzsum=0d0
2521 pqsum=0d0
2522 msel=12
2523 ckin(1)=20d0
2524 mstp(82)=4
2525 mstp(2)=2
2526 mstp(33)=3
2527 CALL pyinit('CMS','p','pbar',pesum)
2528
2529C...W/Z gauge boson pairs + pileup events at the Tevatron.
2530 ELSEIF(iproc.EQ.4) THEN
2531 pesum=1800d0
2532 pzsum=0d0
2533 pqsum=0d0
2534 msub(22)=1
2535 msub(23)=1
2536 msub(25)=1
2537 ckin(1)=200d0
2538 mstp(111)=0
2539 mstp(131)=1
2540 mstp(133)=2
2541 parp(131)=0.04d0
2542 CALL pyinit('CMS','p','pbar',pesum)
2543
2544C...Higgs production at LHC.
2545 ELSEIF(iproc.EQ.5) THEN
2546 pesum=15400d0
2547 pzsum=0d0
2548 pqsum=2d0
2549 msub(3)=1
2550 msub(102)=1
2551 msub(123)=1
2552 msub(124)=1
2553 pmas(25,1)=300d0
2554 ckin(1)=200d0
2555 mstp(81)=0
2556 mstp(111)=0
2557 CALL pyinit('CMS','p','p',pesum)
2558
2559C...Z' production at SSC.
2560 ELSEIF(iproc.EQ.6) THEN
2561 pesum=40000d0
2562 pzsum=0d0
2563 pqsum=2d0
2564 msel=21
2565 pmas(32,1)=600d0
2566 ckin(1)=400d0
2567 mstp(81)=0
2568 mstp(111)=0
2569 CALL pyinit('CMS','p','p',pesum)
2570
2571C...W pair production at 1 TeV e+e- collider.
2572 ELSEIF(iproc.EQ.7) THEN
2573 pesum=1000d0
2574 pzsum=0d0
2575 pqsum=0d0
2576 msub(25)=1
2577 msub(69)=1
2578 mstp(11)=1
2579 CALL pyinit('CMS','e+','e-',pesum)
2580
2581C...Deep inelastic scattering at a LEP+LHC ep collider.
2582 ELSEIF(iproc.EQ.8) THEN
2583 p(1,1)=0d0
2584 p(1,2)=0d0
2585 p(1,3)=8000d0
2586 p(2,1)=0d0
2587 p(2,2)=0d0
2588 p(2,3)=-80d0
2589 pesum=8080d0
2590 pzsum=7920d0
2591 pqsum=0d0
2592 msub(10)=1
2593 ckin(3)=50d0
2594 mstp(111)=0
2595 CALL pyinit('3MOM','p','e-',pesum)
2596 ENDIF
2597
2598C...Generate 20 events of each required type.
2599 DO 220 iev=1,20
2600 CALL pyevnt
2601 pesumm=pesum
2602 IF(iproc.EQ.4) pesumm=msti(41)*pesum
2603
2604C...Check conservation of energy/momentum/flavour.
2605 pini(1)=0d0
2606 pini(2)=0d0
2607 pini(3)=pzsum
2608 pini(4)=pesumm
2609 pini(6)=pqsum
2610 DO 200 j=1,4
2611 pfin(j)=pyp(0,j)
2612 200 CONTINUE
2613 pfin(6)=pyp(0,6)
2614 merr=0
2615 deve=abs(pfin(4)-pini(4))+abs(pfin(3)-pini(3))
2616 devt=abs(pfin(1)-pini(1))+abs(pfin(2)-pini(2))
2617 devq=abs(pfin(6)-pini(6))
2618 IF(deve.GT.2d-3*pesum.OR.devt.GT.max(0.01d0,1d-4*pesum).OR.
2619 & devq.GT.0.1d0) merr=1
2620 IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),
2621 & (pfin(j),j=1,4),pfin(6)
2622
2623C...Check that all KF codes are known ones, and that partons/particles
2624C...satisfy energy-momentum-mass relation.
2625 DO 210 i=1,n
2626 IF(k(i,1).GT.20) GOTO 210
2627 IF(pycomp(k(i,2)).EQ.0) THEN
2628 WRITE(mstu(11),5100) i
2629 merr=merr+1
2630 ENDIF
2631 pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2*
2632 & sign(1d0,p(i,5))
2633 IF(abs(pd).GT.max(0.1d0,0.002d0*p(i,4)**2,0.002d0*p(i,5)**2)
2634 & .OR.(p(i,5).GE.0d0.AND.p(i,4).LT.0d0)) THEN
2635 WRITE(mstu(11),5200) i
2636 merr=merr+1
2637 ENDIF
2638 210 CONTINUE
2639
2640C...Listing of erroneous events, and first event of each type.
2641 IF(merr.GE.1) nerr=nerr+1
2642 IF(nerr.GE.10) THEN
2643 WRITE(mstu(11),6300)
2644 CALL pylist(1)
2645 CALL pystop(9)
2646 ENDIF
2647 IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN
2648 IF(merr.GE.1) WRITE(mstu(11),6400)
2649 CALL pylist(1)
2650 ENDIF
2651 220 CONTINUE
2652
2653C...List statistics for each process type.
2654 IF(mtest.GE.1) CALL pystat(1)
2655 230 CONTINUE
2656
2657C...Summarize result of run.
2658 IF(nerr.EQ.0) WRITE(mstu(11),6500)
2659 IF(nerr.GT.0) WRITE(mstu(11),6600) nerr
2660
2661C...Format statements for output.
2662 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2663 &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,
2664 &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,
2665 &4(1x,f12.5),1x,f8.2)
2666 5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')
2667 5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',
2668 &'kinematics')
2669 6300 FORMAT(/5x,'This is the tenth error experienced! Something is ',
2670 &'wrong.'/5x,'Execution will be stopped after listing of event.')
2671 6400 FORMAT(5x,'Faulty event follows:')
2672 6500 FORMAT(//5x,'End result of PYTEST: no errors detected.')
2673 6600 FORMAT(//5x,'End result of PYTEST:',i2,' errors detected.'/
2674 &5x,'This should not have happened!')
2675
2676 RETURN
2677 END
2678
2679C*********************************************************************
2680
2681C...PYHEPC
2682C...Converts PYTHIA event record contents to or from
2683C...the standard event record commonblock.
2684
2685 SUBROUTINE pyhepc(MCONV)
2686
2687C...Double precision and integer declarations.
2688 IMPLICIT DOUBLE PRECISION(a-h, o-z)
2689 IMPLICIT INTEGER(I-N)
2690 INTEGER PYK,PYCHGE,PYCOMP
2691C...Commonblocks.
2692 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
2693 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2694 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2695 SAVE /pyjets/,/pydat1/,/pydat2/
2696C...HEPEVT commonblock.
2697 parameter(nmxhep=4000)
2698 common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
2699 &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
2700 DOUBLE PRECISION PHEP,VHEP
2701 SAVE /hepevt/
2702
2703C...Store HEPEVT commonblock size (for interfacing issues).
2704 mstu(8)=nmxhep
2705
2706C...Conversion from PYTHIA to standard, the easy part.
2707 IF(mconv.EQ.1) THEN
2708 nevhep=0
2709 IF(n.GT.nmxhep) CALL pyerrm(8,
2710 & '(PYHEPC:) no more space in /HEPEVT/')
2711 nhep=min(n,nmxhep)
2712 DO 150 i=1,nhep
2713 isthep(i)=0
2714 IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1
2715 IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2
2716 IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3
2717 IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)
2718 idhep(i)=k(i,2)
2719 jmohep(1,i)=k(i,3)
2720 jmohep(2,i)=0
2721 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN
2722 jdahep(1,i)=k(i,4)
2723 jdahep(2,i)=k(i,5)
2724 ELSE
2725 jdahep(1,i)=0
2726 jdahep(2,i)=0
2727 ENDIF
2728 DO 100 j=1,5
2729 phep(j,i)=p(i,j)
2730 100 CONTINUE
2731 DO 110 j=1,4
2732 vhep(j,i)=v(i,j)
2733 110 CONTINUE
2734
2735C...Check if new event (from pileup).
2736 IF(i.EQ.1) THEN
2737 inew=1
2738 ELSE
2739 IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i
2740 ENDIF
2741
2742C...Fill in missing mother information.
2743 IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN
2744 imo1=i-2
2745 120 IF(imo1.GT.inew.AND.k(imo1+1,1).EQ.21.AND.k(imo1+1,3).EQ.0)
2746 & THEN
2747 imo1=imo1-1
2748 GOTO 120
2749 ENDIF
2750 jmohep(1,i)=imo1
2751 jmohep(2,i)=imo1+1
2752 ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN
2753 i1=k(i,3)-1
2754 130 i1=i1+1
2755 IF(i1.GE.i) CALL pyerrm(8,
2756 & '(PYHEPC:) translation of inconsistent event history')
2757 IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) GOTO 130
2758 kc=pycomp(k(i1,2))
2759 IF(i1.LT.i.AND.kc.EQ.0) GOTO 130
2760 IF(i1.LT.i.AND.kchg(kc,2).EQ.0) GOTO 130
2761 jmohep(2,i)=i1
2762 ELSEIF(k(i,2).EQ.94) THEN
2763 njet=2
2764 IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3
2765 IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4
2766 jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))
2767 IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=
2768 & mod(k(i+1,4)/mstu(5),mstu(5))
2769 ENDIF
2770
2771C...Fill in missing daughter information.
2772 IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN
2773 DO 140 i1=jdahep(1,i),jdahep(2,i)
2774 i2=mod(k(i1,4)/mstu(5),mstu(5))
2775 jdahep(1,i2)=i
2776 140 CONTINUE
2777 ENDIF
2778 IF(k(i,2).GE.91.AND.k(i,2).LE.94) GOTO 150
2779 i1=jmohep(1,i)
2780 IF(i1.LE.0.OR.i1.GT.nhep) GOTO 150
2781 IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) GOTO 150
2782 IF(jdahep(1,i1).EQ.0) THEN
2783 jdahep(1,i1)=i
2784 ELSE
2785 jdahep(2,i1)=i
2786 ENDIF
2787 150 CONTINUE
2788 DO 160 i=1,nhep
2789 IF(k(i,1).NE.13.AND.k(i,1).NE.14) GOTO 160
2790 IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)
2791 160 CONTINUE
2792
2793C...Conversion from standard to PYTHIA, the easy part.
2794 ELSE
2795 IF(nhep.GT.mstu(4)) CALL pyerrm(8,
2796 & '(PYHEPC:) no more space in /PYJETS/')
2797 n=min(nhep,mstu(4))
2798 nkq=0
2799 kqsum=0
2800 DO 190 i=1,n
2801 k(i,1)=0
2802 IF(isthep(i).EQ.1) k(i,1)=1
2803 IF(isthep(i).EQ.2) k(i,1)=11
2804 IF(isthep(i).EQ.3) k(i,1)=21
2805 k(i,2)=idhep(i)
2806 k(i,3)=jmohep(1,i)
2807 k(i,4)=jdahep(1,i)
2808 k(i,5)=jdahep(2,i)
2809 DO 170 j=1,5
2810 p(i,j)=phep(j,i)
2811 170 CONTINUE
2812 DO 180 j=1,4
2813 v(i,j)=vhep(j,i)
2814 180 CONTINUE
2815 v(i,5)=0d0
2816 IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN
2817 i1=jdahep(1,i)
2818 IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*
2819 & phep(5,i)/phep(4,i)
2820 ENDIF
2821
2822C...Fill in missing information on colour connection in jet systems.
2823 IF(isthep(i).EQ.1) THEN
2824 kc=pycomp(k(i,2))
2825 kq=0
2826 IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))
2827 IF(kq.NE.0) nkq=nkq+1
2828 IF(kq.NE.2) kqsum=kqsum+kq
2829 IF(kq.NE.0.AND.kqsum.NE.0) THEN
2830 k(i,1)=2
2831 ELSEIF(kq.EQ.2.AND.i.LT.n) THEN
2832 IF(k(i+1,2).EQ.21) k(i,1)=2
2833 ENDIF
2834 ENDIF
2835 190 CONTINUE
2836 IF(nkq.EQ.1.OR.kqsum.NE.0) CALL pyerrm(8,
2837 & '(PYHEPC:) input parton configuration not colour singlet')
2838 ENDIF
2839
2840 END
2841
2842C*********************************************************************
2843
2844C...PYINIT
2845C...Initializes the generation procedure; finds maxima of the
2846C...differential cross-sections to be used for weighting.
2847
2848 SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)
2849
2850C...Double precision and integer declarations.
2851 IMPLICIT DOUBLE PRECISION(a-h, o-z)
2852 IMPLICIT INTEGER(I-N)
2853 INTEGER PYK,PYCHGE,PYCOMP
2854C...Commonblocks.
2855 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
2856 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
2857 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
2858 common/pydat4/chaf(500,2)
2859 CHARACTER CHAF*16
2860 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
2861 common/pypars/mstp(200),parp(200),msti(200),pari(200)
2862 common/pyint1/mint(400),vint(400)
2863 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
2864 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
2865 common/pypued/iued(0:99),rued(0:99)
2866 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
2867 &/pyint1/,/pyint2/,/pyint5/,/pypued/
2868C...Local arrays and character variables.
2869 dimension alamin(20),nfin(20)
2870 CHARACTER*(*) FRAME,BEAM,TARGET
2871 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2872
2873C...Interface to PDFLIB.
2874 common/w50511/nptype,ngroup,nset,mode,nfl,lo,tmas
2875 common/w50512/qcdl4,qcdl5
2876 SAVE /w50511/,/w50512/
2877 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2878 CHARACTER*20 PARM(20)
2879 DATA VALUE/20*0d0/,parm/20*' '/
2880
2881C...Data:Lambda and n_f values for parton distributions..
2882 DATA alamin/0.177d0,0.239d0,0.247d0,0.2322d0,0.248d0,0.248d0,
2883 &0.192d0,0.326d0,2*0.2d0,0.2d0,0.2d0,0.29d0,0.2d0,0.4d0,5*0.2d0/,
2884 &nfin/20*4/
2885 DATA chlh/'lepton','hadron'/
2886
2887C...Check that BLOCK DATA PYDATA has been loaded.
2888 CALL pyckbd
2889
2890C...Reset MINT and VINT arrays. Write headers.
2891 msti(53)=0
2892 DO 100 j=1,400
2893 mint(j)=0
2894 vint(j)=0d0
2895 100 CONTINUE
2896 IF(mstu(12).NE.12345) CALL pylist(0)
2897 IF(mstp(122).GE.1) WRITE(mstu(11),5100)
2898
2899C...Reset error counters.
2900 mstu(23)=0
2901 mstu(27)=0
2902 mstu(30)=0
2903
2904C...Reset processes that should not be on.
2905 msub(96)=0
2906 msub(97)=0
2907
2908C...Select global FSR/ISR/UE parameter set = 'tune'
2909C...See routine PYTUNE for details
2910 IF (mstp(5).NE.0) THEN
2911 mstp5=mstp(5)
2912 CALL pytune(mstp5)
2913 ENDIF
2914
2915C...Call user process initialization routine.
2916 IF(frame(1:1).EQ.'u'.OR.frame(1:1).EQ.'U') THEN
2917 msel=0
2918 CALL upinit
2919 msel=0
2920 ENDIF
2921
2922C...Maximum 4 generations; set maximum number of allowed flavours.
2923 mstp(1)=min(4,mstp(1))
2924 mstu(114)=min(mstu(114),2*mstp(1))
2925 mstp(58)=min(mstp(58),2*mstp(1))
2926
2927C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2928 DO 120 i=-20,20
2929 vint(180+i)=0d0
2930 ia=iabs(i)
2931 IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN
2932 DO 110 j=1,mstp(1)
2933 ib=2*j-1+mod(ia,2)
2934 IF(ib.GE.6.AND.mstp(9).EQ.0) GOTO 110
2935 ipm=(5-isign(1,i))/2
2936 idc=j+mdcy(ia,2)+2
2937 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)=
2938 & vint(180+i)+vckm((ia+1)/2,(ib+1)/2)
2939 110 CONTINUE
2940 ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN
2941 vint(180+i)=1d0
2942 ENDIF
2943 120 CONTINUE
2944
2945C...Initialize parton distributions: PDFLIB.
2946 IF(mstp(52).EQ.2) THEN
2947 parm(1)='NPTYPE'
2948 value(1)=1
2949 parm(2)='NGROUP'
2950 value(2)=mstp(51)/1000
2951 parm(3)='NSET'
2952 value(3)=mod(mstp(51),1000)
2953 parm(4)='TMAS'
2954 value(4)=pmas(6,1)
2955 CALL pdfset(parm,VALUE)
2956 mint(93)=1000000+mstp(51)
2957 ENDIF
2958
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
2981
2982C...Initialize the UED masses and widths
2983 IF (iued(1).EQ.1) CALL pyxdin
2984
2985C...Initialize the SUSY generation: couplings, masses,
2986C...decay modes, branching ratios, and so on.
2987 CALL pymsin
2988C...Initialize widths and partial widths for resonances.
2989 CALL pyinre
2990C...Set Z0 mass and width for e+e- routines.
2991 parj(123)=pmas(23,1)
2992 parj(124)=pmas(23,2)
2993
2994C...Identify beam and target particles and frame of process.
2995 chfram=frame//' '
2996 chbeam=beam//' '
2997 chtarg=TARGET//' '
2998 CALL pyinbm(chfram,chbeam,chtarg,win)
2999 IF(mint(65).EQ.1) GOTO 170
3000
3001C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3002C...For e-gamma allow 2 alternatives.
3003 mint(121)=1
3004 IF(mstp(14).EQ.10.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3005 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3006 & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=3
3007 IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=6
3008 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3009 & (iabs(mint(11)).EQ.11.OR.iabs(mint(12)).EQ.11)) mint(121)=2
3010 ELSEIF(mstp(14).EQ.20.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3011 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3012 & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=3
3013 IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=9
3014 ELSEIF(mstp(14).EQ.25.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3015 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3016 & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=2
3017 IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=4
3018 ELSEIF(mstp(14).EQ.30.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN
3019 IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.
3020 & (iabs(mint(11)).GT.100.OR.iabs(mint(12)).GT.100)) mint(121)=4
3021 IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=13
3022 ENDIF
3023 mint(123)=mstp(14)
3024 IF((mstp(14).EQ.10.OR.mstp(14).EQ.20.OR.mstp(14).EQ.25.OR.
3025 &mstp(14).EQ.30).AND.msel.NE.1.AND.msel.NE.2) mint(123)=0
3026 IF(mstp(14).GE.11.AND.mstp(14).LE.19) THEN
3027 IF(mstp(14).EQ.11) mint(123)=0
3028 IF(mstp(14).EQ.12.OR.mstp(14).EQ.14) mint(123)=5
3029 IF(mstp(14).EQ.13.OR.mstp(14).EQ.17) mint(123)=6
3030 IF(mstp(14).EQ.15) mint(123)=2
3031 IF(mstp(14).EQ.16.OR.mstp(14).EQ.18) mint(123)=7
3032 IF(mstp(14).EQ.19) mint(123)=3
3033 ELSEIF(mstp(14).GE.21.AND.mstp(14).LE.24) THEN
3034 IF(mstp(14).EQ.21) mint(123)=0
3035 IF(mstp(14).EQ.22.OR.mstp(14).EQ.23) mint(123)=4
3036 IF(mstp(14).EQ.24) mint(123)=1
3037 ELSEIF(mstp(14).GE.26.AND.mstp(14).LE.29) THEN
3038 IF(mstp(14).EQ.26.OR.mstp(14).EQ.28) mint(123)=8
3039 IF(mstp(14).EQ.27.OR.mstp(14).EQ.29) mint(123)=9
3040 ENDIF
3041
3042C...Set up kinematics of process.
3043 CALL pyinki(0)
3044
3045C...Set up kinematics for photons inside leptons.
3046 IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(1,wtgaga)
3047
3048C...Precalculate flavour selection weights.
3049 CALL pykfin
3050
3051C...Loop over gamma-p or gamma-gamma alternatives.
3052 ckin3=ckin(3)
3053 msav48=0
3054 DO 160 iga=1,mint(121)
3055 ckin(3)=ckin3
3056 mint(122)=iga
3057
3058C...Select partonic subprocesses to be included in the simulation.
3059 CALL pyinpr
3060 mint(101)=1
3061 mint(102)=1
3062 mint(103)=mint(11)
3063 mint(104)=mint(12)
3064
3065C...Count number of subprocesses on.
3066 mint(48)=0
3067 DO 130 isub=1,500
3068 IF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
3069 & msub(isub).EQ.1.AND.mint(121).GT.1) THEN
3070 msub(isub)=0
3071 ELSEIF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.
3072 & msub(isub).EQ.1) THEN
3073 WRITE(mstu(11),5200) isub,chlh(mint(41)),chlh(mint(42))
3074 CALL pystop(1)
3075 ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN
3076 WRITE(mstu(11),5300) isub
3077 CALL pystop(1)
3078 ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN
3079 WRITE(mstu(11),5400) isub
3080 CALL pystop(1)
3081 ELSEIF(msub(isub).EQ.1) THEN
3082 mint(48)=mint(48)+1
3083 ENDIF
3084 130 CONTINUE
3085
3086C...Stop or raise warning flag if no subprocesses on.
3087 IF(mint(121).EQ.1.AND.mint(48).EQ.0) THEN
3088 IF(mstp(127).NE.1) THEN
3089 WRITE(mstu(11),5500)
3090 CALL pystop(1)
3091 ELSE
3092 WRITE(mstu(11),5700)
3093 msti(53)=1
3094 ENDIF
3095 ENDIF
3096 mint(49)=mint(48)-msub(91)-msub(92)-msub(93)-msub(94)
3097 msav48=msav48+mint(48)
3098
3099C...Reset variables for cross-section calculation.
3100 DO 150 i=0,500
3101 DO 140 j=1,3
3102 ngen(i,j)=0
3103 xsec(i,j)=0d0
3104 140 CONTINUE
3105 150 CONTINUE
3106
3107C...Find parametrized total cross-sections.
3108 CALL pyxtot
3109 vint(318)=vint(317)
3110
3111C...Maxima of differential cross-sections.
3112 IF(mstp(121).LE.1) CALL pymaxi
3113
3114C...Initialize possibility of pileup events.
3115 IF(mint(121).GT.1) mstp(131)=0
3116 IF(mstp(131).NE.0) CALL pypile(1)
3117
3118C...Initialize multiple interactions with variable impact parameter.
3119 IF(mint(50).EQ.1) THEN
3120 ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
3121 IF(mod(mstp(81),10).EQ.0.AND.(ckin(3).GT.ptmn.OR.
3122 & ((msel.NE.1.AND.msel.NE.2)))) mstp(82)=min(1,mstp(82))
3123 IF((mint(49).NE.0.OR.mstp(131).NE.0).AND.mstp(82).GE.2) THEN
3124 mint(35)=1
3125 CALL pymult(1)
3126 mint(35)=3
3127 CALL pymign(1)
3128 ENDIF
3129 ENDIF
3130
3131C...Save results for gamma-p and gamma-gamma alternatives.
3132 IF(mint(121).GT.1) CALL pysave(1,iga)
3133 160 CONTINUE
3134
3135C...Initialization finished.
3136 IF(msav48.EQ.0) THEN
3137 IF(mstp(127).NE.1) THEN
3138 WRITE(mstu(11),5500)
3139 CALL pystop(1)
3140 ELSE
3141 WRITE(mstu(11),5700)
3142 msti(53)=1
3143 ENDIF
3144 ENDIF
3145 170 IF(mstp(122).GE.1) WRITE(mstu(11),5600)
3146
3147C...Formats for initialization information.
3148 5100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',
3149 &'routines',1x,17('*'))
3150 5200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,
3151 &'-',a6,' interactions.'/1x,'Execution stopped!')
3152 5300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/
3153 &1x,'Execution stopped!')
3154 5400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/
3155 &1x,'Execution stopped!')
3156 5500 FORMAT(1x,'Error: no subprocess switched on.'/
3157 &1x,'Execution stopped.')
3158 5600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,
3159 &22('*'))
3160 5700 FORMAT(1x,'Error: no subprocess switched on.'/
3161 &1x,'Execution will stop if you try to generate events.')
3162
3163 RETURN
3164 END
3165
3166C*********************************************************************
3167
3168C...PYEVNT
3169C...Administers the generation of a high-pT event via calls to
3170C...a number of subroutines.
3171
3172 SUBROUTINE pyevnt
3173
3174C...Double precision and integer declarations.
3175 IMPLICIT DOUBLE PRECISION(a-h, o-z)
3176 IMPLICIT INTEGER(I-N)
3177 INTEGER PYK,PYCHGE,PYCOMP
3178 parameter(maxnur=1000)
3179C...Commonblocks.
3180 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
3181 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3182 common/pyctag/nct,mct(4000,2)
3183 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3184 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3185 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
3186 common/pypars/mstp(200),parp(200),msti(200),pari(200)
3187 common/pyint1/mint(400),vint(400)
3188 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3189 common/pyint4/mwid(500),wids(500,5)
3190 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
3191 SAVE /pyjets/,/pydat1/,/pyctag/,/pydat2/,/pydat3/,/pypars/,
3192 &/pyint1/,/pyint2/,/pyint4/,/pyint5/
3193C...Local array.
3194 dimension vtx(4)
3195
3196C...Optionally let PYEVNW do the whole job.
3197 IF(mstp(81).GE.20) THEN
3198 CALL pyevnw
3199 RETURN
3200 ENDIF
3201
3202C...Stop if no subprocesses on.
3203 IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
3204 WRITE(mstu(11),5100)
3205 CALL pystop(1)
3206 ENDIF
3207
3208C...Initial values for some counters.
3209 mstu(1)=0
3210 mstu(2)=0
3211 n=0
3212 mint(5)=mint(5)+1
3213 mint(7)=0
3214 mint(8)=0
3215 mint(30)=0
3216 mint(83)=0
3217 mint(84)=mstp(126)
3218 mstu(24)=0
3219 mstu70=0
3220 mstj14=mstj(14)
3221C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3222 nct=0
3223 mint(33)=0
3224
3225C...Let called routines know call is from PYEVNT (not PYEVNW).
3226 mint(35)=1
3227 IF (mstp(81).GE.10) mint(35)=2
3228
3229C...If variable energies: redo incoming kinematics and cross-section.
3230 msti(61)=0
3231 IF(mstp(171).EQ.1) THEN
3232 CALL pyinki(1)
3233 IF(msti(61).EQ.1) THEN
3234 mint(5)=mint(5)-1
3235 RETURN
3236 ENDIF
3237 IF(mint(121).GT.1) CALL pysave(3,1)
3238 CALL pyxtot
3239 ENDIF
3240
3241C...Loop over number of pileup events; check space left.
3242 IF(mstp(131).LE.0) THEN
3243 npile=1
3244 ELSE
3245 CALL pypile(2)
3246 npile=mint(81)
3247 ENDIF
3248 DO 270 ipile=1,npile
3249 IF(mint(84)+100.GE.mstu(4)) THEN
3250 CALL pyerrm(11,
3251 & '(PYEVNT:) no more space in PYJETS for pileup events')
3252 IF(mstu(21).GE.1) GOTO 280
3253 ENDIF
3254 mint(82)=ipile
3255
3256C...Generate variables of hard scattering.
3257 mint(51)=0
3258 msti(52)=0
3259 100 CONTINUE
3260 IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
3261 mint(31)=0
3262 mint(39)=0
3263 mint(51)=0
3264 mint(57)=0
3265 CALL pyrand
3266 IF(msti(61).EQ.1) THEN
3267 mint(5)=mint(5)-1
3268 RETURN
3269 ENDIF
3270 IF(mint(51).EQ.2) RETURN
3271 isub=mint(1)
3272 IF(mstp(111).EQ.-1) GOTO 260
3273
3274C...Loopback point if PYPREP fails, especially for junction topologies.
3275 nprep=0
3276 mnt31s=mint(31)
3277 110 nprep=nprep+1
3278 mint(31)=mnt31s
3279
3280 IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
3281C...Hard scattering (including low-pT):
3282C...reconstruct kinematics and colour flow of hard scattering.
3283 mint31=mint(31)
3284 120 mint(31)=mint31
3285 mint(51)=0
3286 CALL pyscat
3287 IF(mint(51).EQ.1) GOTO 100
3288 ipu1=mint(84)+1
3289 ipu2=mint(84)+2
3290 IF(isub.EQ.95) GOTO 140
3291
3292C...Reset statistics on activity in event.
3293 DO 130 j=351,359
3294 mint(j)=0
3295 vint(j)=0d0
3296 130 CONTINUE
3297
3298C...Showering of initial state partons (optional).
3299 nfin=n
3300 alamsv=parj(81)
3301 parj(81)=parp(72)
3302 IF(mstp(61).GE.1.AND.mint(47).GE.2.AND.mint(111).NE.12)
3303 & CALL pysspa(ipu1,ipu2)
3304 parj(81)=alamsv
3305 IF(mint(51).EQ.1) GOTO 100
3306
3307C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3308 IF (npart.GE.2.AND.(mstj(41).EQ.11.OR.mstj(41).EQ.12)) THEN
3309 ptmax=0.5*sqrt(parp(71))*vint(55)
3310 CALL pyptfs(3,ptmax,0d0,ptgen)
3311 ENDIF
3312
3313C...Showering of final state partons (optional).
3314 alamsv=parj(81)
3315 parj(81)=parp(72)
3316 IF(mstp(71).GE.1.AND.iset(isub).GE.2.AND.iset(isub).LE.10)
3317 & THEN
3318 ipu3=mint(84)+3
3319 ipu4=mint(84)+4
3320 IF(iset(isub).EQ.5) ipu4=-3
3321 qmax=vint(55)
3322 IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)
3323 CALL pyshow(ipu3,ipu4,qmax)
3324 ELSEIF(iset(isub).EQ.11) THEN
3325 CALL pyadsh(nfin)
3326 ENDIF
3327 parj(81)=alamsv
3328
3329C...Allow possibility for user to abort event generation.
3330 iveto=0
3331 IF(ipile.EQ.1.AND.mstp(143).EQ.1) CALL pyveto(iveto)
3332 IF(iveto.EQ.1) GOTO 100
3333
3334C...Decay of final state resonances.
3335 mint(32)=0
3336 IF(mstp(41).GE.1.AND.iset(isub).LE.10) CALL pyresd(0)
3337 IF(mint(51).EQ.1) GOTO 100
3338 mint(52)=n
3339
3340
3341C...Multiple interactions - PYTHIA 6.3 intermediate style.
3342 140 IF(mstp(81).GE.10.AND.mint(50).EQ.1) THEN
3343 IF(isub.EQ.95) mint(31)=mint(31)+1
3344 CALL pymign(6)
3345 IF(mint(51).EQ.1) GOTO 100
3346 mint(53)=n
3347
3348C...Beam remnant flavour and colour assignments - new scheme.
3349 CALL pymihk
3350 IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3351 & GOTO 120
3352 IF(mint(51).EQ.1) GOTO 100
3353
3354C...Primordial kT and beam remnant momentum sharing - new scheme.
3355 CALL pymirm
3356 IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3357 & GOTO 120
3358 IF(mint(51).EQ.1) GOTO 100
3359 IF(isub.EQ.95) mint(31)=mint(31)-1
3360
3361C...Multiple interactions - PYTHIA 6.2 style.
3362 ELSEIF(mint(111).NE.12) THEN
3363 IF (mstp(81).GE.1.AND.mint(50).EQ.1.AND.isub.NE.95) THEN
3364 CALL pymult(6)
3365 mint(53)=n
3366 ENDIF
3367
3368C...Hadron remnants and primordial kT.
3369 CALL pyremn(ipu1,ipu2)
3370 IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) GOTO
3371 & 110
3372 IF(mint(51).EQ.1) GOTO 100
3373 ENDIF
3374
3375 ELSEIF(isub.NE.99) THEN
3376C...Diffractive and elastic scattering.
3377 CALL pydiff
3378
3379 ELSE
3380C...DIS scattering (photon flux external).
3381 CALL pydisg
3382 IF(mint(51).EQ.1) GOTO 100
3383 ENDIF
3384
3385C...Check that no odd resonance left undecayed.
3386 mint(54)=n
3387 IF(mstp(111).GE.1) THEN
3388 nfix=n
3389 DO 150 i=mint(84)+1,nfix
3390 IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
3391 & k(i,2).NE.22) THEN
3392 kca=pycomp(k(i,2))
3393 IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
3394 CALL pyresd(i)
3395 IF(mint(51).EQ.1) GOTO 100
3396 ENDIF
3397 ENDIF
3398 150 CONTINUE
3399 ENDIF
3400
3401C...Boost hadronic subsystem to overall rest frame.
3402C..(Only relevant when photon inside lepton beam.)
3403 IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
3404
3405C...Recalculate energies from momenta and masses (if desired).
3406 IF(mstp(113).GE.1) THEN
3407 DO 160 i=mint(83)+1,n
3408 IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
3409 & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3410 160 CONTINUE
3411 nrecal=n
3412 ENDIF
3413
3414C...Colour reconnection before string formation
3415 IF (mstp(95).GE.2) CALL pyfscr(mint(84)+1)
3416
3417C...Rearrange partons along strings, check invariant mass cuts.
3418 mstu(28)=0
3419 IF(mstp(111).LE.0) mstj(14)=-1
3420 CALL pyprep(mint(84)+1)
3421 mstj(14)=mstj14
3422 IF(mint(51).EQ.1.AND.mstu(24).EQ.1) THEN
3423 mstu(24)=0
3424 GOTO 100
3425 ENDIF
3426 IF (mint(51).EQ.1.AND.nprep.LE.5) GOTO 110
3427 IF (mint(51).EQ.1) GOTO 100
3428 IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) GOTO 100
3429 IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
3430 DO 190 i=mint(84)+1,n
3431 IF(k(i,2).EQ.94) THEN
3432 DO 180 i1=i+1,min(n,i+10)
3433 IF(k(i1,3).EQ.i) THEN
3434 k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))
3435 IF(k(i1,3).EQ.0) THEN
3436 DO 170 ii=mint(84)+1,i-1
3437 IF(k(ii,2).EQ.k(i1,2)) THEN
3438 IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.
3439 & mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii
3440 ENDIF
3441 170 CONTINUE
3442 IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)
3443 ENDIF
3444 ENDIF
3445 180 CONTINUE
3446 ENDIF
3447 190 CONTINUE
3448 CALL pyedit(12)
3449 CALL pyedit(14)
3450 IF(mstp(125).EQ.0) CALL pyedit(15)
3451 IF(mstp(125).EQ.0) mint(4)=0
3452 DO 210 i=mint(83)+1,n
3453 IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN
3454 DO 200 i1=i+1,n
3455 IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1
3456 IF(k(i1,3).EQ.i) k(i,5)=i1
3457 200 CONTINUE
3458 ENDIF
3459 210 CONTINUE
3460 ENDIF
3461
3462C...Introduce separators between sections in PYLIST event listing.
3463 IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN
3464 mstu70=1
3465 mstu(71)=n
3466 ELSEIF(ipile.EQ.1) THEN
3467 mstu70=3
3468 mstu(71)=2
3469 mstu(72)=mint(4)
3470 mstu(73)=n
3471 ENDIF
3472
3473C...Go back to lab frame (needed for vertices, also in fragmentation).
3474 CALL pyfram(1)
3475
3476C...Set nonvanishing production vertex (optional).
3477 IF(mstp(151).EQ.1) THEN
3478 DO 220 j=1,4
3479 vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*
3480 & sin(paru(2)*pyr(0))
3481 220 CONTINUE
3482 DO 240 i=mint(83)+1,n
3483 DO 230 j=1,4
3484 v(i,j)=v(i,j)+vtx(j)
3485 230 CONTINUE
3486 240 CONTINUE
3487 ENDIF
3488
3489C...Perform hadronization (if desired).
3490 IF(mstp(111).GE.1) THEN
3491 CALL pyexec
3492 IF(mstu(24).NE.0) GOTO 100
3493 ENDIF
3494 IF(mstp(113).GE.1) THEN
3495 DO 250 i=nrecal,n
3496 IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+
3497 & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3498 250 CONTINUE
3499 ENDIF
3500 IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)
3501
3502C...Store event information and calculate Monte Carlo estimates of
3503C...subprocess cross-sections.
3504 260 IF(ipile.EQ.1) CALL pydocu
3505
3506C...Set counters for current pileup event and loop to next one.
3507 msti(41)=ipile
3508 IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub
3509 IF(mstu70.LT.10) THEN
3510 mstu70=mstu70+1
3511 mstu(70+mstu70)=n
3512 ENDIF
3513 mint(83)=n
3514 mint(84)=n+mstp(126)
3515 IF(ipile.LT.npile) CALL pyfram(2)
3516 270 CONTINUE
3517
3518C...Generic information on pileup events. Reconstruct missing history.
3519 IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
3520 pari(91)=vint(132)
3521 pari(92)=vint(133)
3522 pari(93)=vint(134)
3523 IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
3524 ENDIF
3525 CALL pyedit(16)
3526
3527C...Transform to the desired coordinate frame.
3528 280 CALL pyfram(mstp(124))
3529 mstu(70)=mstu70
3530 paru(21)=vint(1)
3531
3532C...Error messages
3533 5100 FORMAT(1x,'Error: no subprocess switched on.'/
3534 &1x,'Execution stopped.')
3535
3536 RETURN
3537 END
3538
3539C*********************************************************************
3540
3541C...PYEVNW
3542C...Administers the generation of a high-pT event via calls to
3543C...a number of subroutines for the new multiple interactions and
3544C...showering framework.
3545
3546 SUBROUTINE pyevnw
3547
3548C...Double precision and integer declarations.
3549 IMPLICIT DOUBLE PRECISION(a-h, o-z)
3550 IMPLICIT INTEGER(I-N)
3551 INTEGER PYK,PYCHGE,PYCOMP
3552 parameter(maxnur=1000)
3553C...Commonblocks.
3554 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
3555C...Commonblocks.
3556 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
3557 common/pyctag/nct,mct(4000,2)
3558 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
3559 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
3560 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
3561 common/pypars/mstp(200),parp(200),msti(200),pari(200)
3562 common/pyint1/mint(400),vint(400)
3563 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
3564 common/pyint4/mwid(500),wids(500,5)
3565 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
3566 common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
3567 & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
3568 & xmi(2,240),pt2mi(240),imisep(0:240)
3569 SAVE /pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,
3570 & /pypars/,/pyint1/,/pyint2/,/pyint4/,/pyint5/,/pyintm/
3571C...Local arrays.
3572 dimension vtx(4)
3573
3574C...Stop if no subprocesses on.
3575 IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
3576 WRITE(mstu(11),5100)
3577 CALL pystop(1)
3578 ENDIF
3579
3580C...Initial values for some counters.
3581 mstu(1)=0
3582 mstu(2)=0
3583 n=0
3584 mint(5)=mint(5)+1
3585 mint(7)=0
3586 mint(8)=0
3587 mint(30)=0
3588 mint(83)=0
3589 mint(84)=mstp(126)
3590 mstu(24)=0
3591 mstu70=0
3592 mstj14=mstj(14)
3593C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3594 nct=0
3595 mint(33)=0
3596C...Zero counters for pT-ordered showers (failsafe)
3597 npart=0
3598 npartd=0
3599
3600C...Let called routines know call is from PYEVNW (not PYEVNT).
3601 mint(35)=3
3602
3603C...If variable energies: redo incoming kinematics and cross-section.
3604 msti(61)=0
3605 IF(mstp(171).EQ.1) THEN
3606 CALL pyinki(1)
3607 IF(msti(61).EQ.1) THEN
3608 mint(5)=mint(5)-1
3609 RETURN
3610 ENDIF
3611 IF(mint(121).GT.1) CALL pysave(3,1)
3612 CALL pyxtot
3613 ENDIF
3614
3615C...Loop over number of pileup events; check space left.
3616 IF(mstp(131).LE.0) THEN
3617 npile=1
3618 ELSE
3619 CALL pypile(2)
3620 npile=mint(81)
3621 ENDIF
3622 DO 300 ipile=1,npile
3623 IF(mint(84)+100.GE.mstu(4)) THEN
3624 CALL pyerrm(11,
3625 & '(PYEVNW:) no more space in PYJETS for pileup events')
3626 IF(mstu(21).GE.1) GOTO 310
3627 ENDIF
3628 mint(82)=ipile
3629
3630C...Generate variables of hard scattering.
3631 mint(51)=0
3632 msti(52)=0
3633 loophs =0
3634 100 CONTINUE
3635 loophs = loophs + 1
3636 IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
3637 IF(loophs.GE.10) THEN
3638 CALL pyerrm(19,'(PYEVNW:) failed to evolve shower or '
3639 & //'multiple interactions. Returning.')
3640 mint(51)=1
3641 RETURN
3642 ENDIF
3643 mint(31)=0
3644 mint(39)=0
3645 mint(36)=0
3646 mint(51)=0
3647 mint(57)=0
3648 CALL pyrand
3649 IF(msti(61).EQ.1) THEN
3650 mint(5)=mint(5)-1
3651 RETURN
3652 ENDIF
3653 IF(mint(51).EQ.2) RETURN
3654 isub=mint(1)
3655 IF(mstp(111).EQ.-1) GOTO 290
3656
3657C...Loopback point if PYPREP fails, especially for junction topologies.
3658 nprep=0
3659 mnt31s=mint(31)
3660 110 nprep=nprep+1
3661 mint(31)=mnt31s
3662
3663 IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
3664C...Hard scattering (including low-pT):
3665C...reconstruct kinematics and colour flow of hard scattering.
3666 mint31=mint(31)
3667 120 mint(31)=mint31
3668 mint(51)=0
3669 CALL pyscat
3670 IF(mint(51).EQ.1) GOTO 100
3671 npartd=n
3672 nfin=n
3673
3674C...Intertwined initial state showers and multiple interactions.
3675C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3676C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3677 mstp61=mstp(61)
3678 IF (mint(47).LT.2) mstp(61)=0
3679 mstp81=mstp(81)
3680 IF (mint(50).EQ.0) mstp(81)=0
3681 IF ((mstp(61).GE.1.OR.mod(mstp(81),10).GE.0).AND.
3682 & mint(111).NE.12) THEN
3683C...Absolute max pT2 scale for evolution: phase space limit.
3684 pt2mxs=0.25d0*vint(2)
3685C...Check if more constrained by ISR and MI max scales:
3686 pt2mxs=min(pt2mxs,max(vint(56),vint(62)))
3687C...Loopback point in case of failure in evolution.
3688 loop=0
3689 130 loop=loop+1
3690 mint(51)=0
3691 IF(loop.GT.100) THEN
3692 CALL pyerrm(9,'(PYEVNW:) failed to evolve shower or '
3693 & //'multiple interactions. Trying new point.')
3694 mint(51)=1
3695 RETURN
3696 ENDIF
3697
3698C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3699C...once per event. (E.g. compute constants and save variables to be
3700C...restored later in case of failure.)
3701 IF (loop.EQ.1) CALL pyevol(-1,dummy1,dummy2)
3702
3703C...Initialize interleaved MI/ISR/JI evolution.
3704C...PT2MAX: absolute upper limit for evolution - Initialization may
3705C... return a PT2MAX which is lower than this.
3706C...PT2MIN: absolute lower limit for evolution - Initialization may
3707C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3708 pt2max=pt2mxs
3709 pt2min=0d0
3710 CALL pyevol(0,pt2max,pt2min)
3711C...If failed to initialize evolution, generate a new hard process
3712 IF (mint(51).EQ.1) GOTO 100
3713
3714C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3715C...In principle factorized, so can be stopped and restarted.
3716C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3717C PT2MED=MAX(10D0**2,PT2MIN)
3718C CALL PYEVOL(1,PT2MAX,PT2MED)
3719C IF (MINT(51).EQ.1) GOTO 160
3720C PT2MAX=PT2MED
3721 CALL pyevol(1,pt2max,pt2min)
3722C...If fatal error (e.g., massive hard-process initiator, but no available
3723C...phase space for creation), generate a new hard process
3724 IF (mint(51).EQ.2) GOTO 100
3725C...If smaller error, just try running evolution again
3726 IF (mint(51).EQ.1) GOTO 130
3727
3728C...Finalize interleaved MI/ISR/JI evolution.
3729 CALL pyevol(2,pt2max,pt2min)
3730 IF (mint(51).EQ.1) GOTO 130
3731
3732 ENDIF
3733 mstp(61)=mstp61
3734 mstp(81)=mstp81
3735 IF(mint(51).EQ.1) GOTO 100
3736C...(MINT(52) is actually obsolete in this routine. Set anyway
3737C...to ensure PYDOCU stable.)
3738 mint(52)=n
3739 mint(53)=n
3740
3741C...Beam remnants - new scheme.
3742 140 IF(mint(50).EQ.1) THEN
3743 IF (isub.EQ.95) mint(31)=1
3744
3745C...Beam remnant flavour and colour assignments - new scheme.
3746 CALL pymihk
3747 IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3748 & GOTO 120
3749 IF(mint(51).EQ.1) GOTO 100
3750
3751C...Primordial kT and beam remnant momentum sharing - new scheme.
3752 CALL pymirm
3753 IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5)
3754 & GOTO 120
3755 IF(mint(51).EQ.1) GOTO 100
3756 IF (isub.EQ.95) mint(31)=0
3757 ELSEIF(mint(111).NE.12) THEN
3758C...Hadron remnants and primordial kT - old model.
3759C...Happens e.g. for direct photon on one side.
3760 ipu1=imi(1,1,1)
3761 ipu2=imi(2,1,1)
3762 CALL pyremn(ipu1,ipu2)
3763 IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) GOTO
3764 & 110
3765 IF(mint(51).EQ.1) GOTO 100
3766C...PYREMN does not set colour tags for BRs, so needs to be done now.
3767 DO 160 i=mint(53)+1,n
3768 DO 150 kcs=4,5
3769 ida=mod(k(i,kcs),mstu(5))
3770 IF (ida.NE.0) THEN
3771 mct(i,kcs-3)=mct(ida,6-kcs)
3772 ELSE
3773 mct(i,kcs-3)=0
3774 ENDIF
3775 150 CONTINUE
3776 160 CONTINUE
3777C...Instruct PYPREP to use colour tags
3778 mint(33)=1
3779
3780 DO 360 mqgst=1,2
3781 DO 350 i=mint(84)+1,n
3782
3783C...Look for coloured string endpoint, or (later) leftover gluon.
3784 IF (k(i,1).NE.3) GOTO 350
3785 kc=pycomp(k(i,2))
3786 IF(kc.EQ.0) GOTO 350
3787 kq=kchg(kc,2)
3788 IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) GOTO 350
3789
3790C... Pick up loose string end with no previous tag.
3791 kcs=4
3792 IF(kq*isign(1,k(i,2)).LT.0) kcs=5
3793 IF(mct(i,kcs-3).NE.0) GOTO 350
3794
3795 CALL pycttr(i,kcs,i)
3796 IF(mint(51).NE.0) RETURN
3797
3798 350 CONTINUE
3799 360 CONTINUE
3800C...Now delete any colour processing information if set (since partons
3801C...otherwise not FS showered!)
3802 DO 170 i=mint(84)+1,n
3803 IF (i.LE.n) THEN
3804 k(i,4)=mod(k(i,4),mstu(5)**2)
3805 k(i,5)=mod(k(i,5),mstu(5)**2)
3806 ENDIF
3807 170 CONTINUE
3808 ENDIF
3809
3810C...Showering of final state partons (optional).
3811 alamsv=parj(81)
3812 parj(81)=parp(72)
3813 IF(mstp(71).GE.1.AND.iset(isub).GE.1.AND.iset(isub).LE.10)
3814 & THEN
3815 qmax=vint(55)
3816 IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)
3817 CALL pyptfs(1,qmax,0d0,ptgen)
3818C...External processes: handle successive showers.
3819 ELSEIF(iset(isub).EQ.11) THEN
3820 CALL pyadsh(nfin)
3821 ENDIF
3822 parj(81)=alamsv
3823
3824C...Allow possibility for user to abort event generation.
3825 iveto=0
3826 IF(ipile.EQ.1.AND.mstp(143).EQ.1) CALL pyveto(iveto) ! sm
3827 IF(iveto.EQ.1) GOTO 100
3828
3829
3830C...Decay of final state resonances.
3831 mint(32)=0
3832 IF(mstp(41).GE.1.AND.iset(isub).LE.10) THEN
3833 CALL pyresd(0)
3834 IF(mint(51).NE.0) GOTO 100
3835 ENDIF
3836
3837 IF(mint(51).EQ.1) GOTO 100
3838
3839 ELSEIF(isub.NE.99) THEN
3840C...Diffractive and elastic scattering.
3841 CALL pydiff
3842
3843 ELSE
3844C...DIS scattering (photon flux external).
3845 CALL pydisg
3846 IF(mint(51).EQ.1) GOTO 100
3847 ENDIF
3848
3849C...Check that no odd resonance left undecayed.
3850 mint(54)=n
3851 IF(mstp(111).GE.1) THEN
3852 nfix=n
3853 DO 180 i=mint(84)+1,nfix
3854 IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
3855 & k(i,2).NE.22) THEN
3856 kca=pycomp(k(i,2))
3857 IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
3858 CALL pyresd(i)
3859 IF(mint(51).EQ.1) GOTO 100
3860 ENDIF
3861 ENDIF
3862 180 CONTINUE
3863 ENDIF
3864
3865C...Boost hadronic subsystem to overall rest frame.
3866C..(Only relevant when photon inside lepton beam.)
3867 IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
3868
3869C...Recalculate energies from momenta and masses (if desired).
3870 IF(mstp(113).GE.1) THEN
3871 DO 190 i=mint(83)+1,n
3872 IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+
3873 & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3874 190 CONTINUE
3875 nrecal=n
3876 ENDIF
3877
3878C...Colour reconnection before string formation
3879 CALL pyfscr(mint(84)+1)
3880
3881C...Rearrange partons along strings, check invariant mass cuts.
3882 mstu(28)=0
3883 IF(mstp(111).LE.0) mstj(14)=-1
3884 CALL pyprep(mint(84)+1)
3885 mstj(14)=mstj14
3886 IF(mint(51).EQ.1.AND.mstu(24).EQ.1) THEN
3887 mstu(24)=0
3888 GOTO 100
3889 ENDIF
3890 IF(mint(51).EQ.1) GOTO 110
3891 IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) GOTO 100
3892 IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN
3893 DO 220 i=mint(84)+1,n
3894 IF(k(i,2).EQ.94) THEN
3895 DO 210 i1=i+1,min(n,i+10)
3896 IF(k(i1,3).EQ.i) THEN
3897 k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))
3898 IF(k(i1,3).EQ.0) THEN
3899 DO 200 ii=mint(84)+1,i-1
3900 IF(k(ii,2).EQ.k(i1,2)) THEN
3901 IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.
3902 & mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii
3903 ENDIF
3904 200 CONTINUE
3905 IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)
3906 ENDIF
3907 ENDIF
3908 210 CONTINUE
3909CC...Also collapse particles decaying to themselves (if same KS)
3910 ELSEIF (k(i,1).GT.0.AND.k(i,4).EQ.k(i,5).AND.k(i,4).GT.0
3911 & .AND.k(i,4).LT.n) THEN
3912 ida=k(i,4)
3913 IF (k(ida,1).EQ.k(i,1).AND.k(ida,2).EQ.k(i,2)) THEN
3914 k(i,1)=0
3915 ENDIF
3916 ENDIF
3917 220 CONTINUE
3918 CALL pyedit(12)
3919 CALL pyedit(14)
3920 IF(mstp(125).EQ.0) CALL pyedit(15)
3921 IF(mstp(125).EQ.0) mint(4)=0
3922 DO 240 i=mint(83)+1,n
3923 IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN
3924 DO 230 i1=i+1,n
3925 IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1
3926 IF(k(i1,3).EQ.i) k(i,5)=i1
3927 230 CONTINUE
3928 ENDIF
3929 240 CONTINUE
3930 ENDIF
3931
3932C...Introduce separators between sections in PYLIST event listing.
3933 IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN
3934 mstu70=1
3935 mstu(71)=n
3936 ELSEIF(ipile.EQ.1) THEN
3937 mstu70=3
3938 mstu(71)=2
3939 mstu(72)=mint(4)
3940 mstu(73)=n
3941 ENDIF
3942
3943C...Go back to lab frame (needed for vertices, also in fragmentation).
3944 CALL pyfram(1)
3945
3946C...Set nonvanishing production vertex (optional).
3947 IF(mstp(151).EQ.1) THEN
3948 DO 250 j=1,4
3949 vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*
3950 & sin(paru(2)*pyr(0))
3951 250 CONTINUE
3952 DO 270 i=mint(83)+1,n
3953 DO 260 j=1,4
3954 v(i,j)=v(i,j)+vtx(j)
3955 260 CONTINUE
3956 270 CONTINUE
3957 ENDIF
3958
3959C...Perform hadronization (if desired).
3960 IF(mstp(111).GE.1) THEN
3961 CALL pyexec
3962 IF(mstu(24).NE.0) GOTO 100
3963 ENDIF
3964 IF(mstp(113).GE.1) THEN
3965 DO 280 i=nrecal,n
3966 IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+
3967 & p(i,2)**2+p(i,3)**2+p(i,5)**2)
3968 280 CONTINUE
3969 ENDIF
3970 IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)
3971
3972C...Store event information and calculate Monte Carlo estimates of
3973C...subprocess cross-sections.
3974 290 IF(ipile.EQ.1) CALL pydocu
3975
3976C...Set counters for current pileup event and loop to next one.
3977 msti(41)=ipile
3978 IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub
3979 IF(mstu70.LT.10) THEN
3980 mstu70=mstu70+1
3981 mstu(70+mstu70)=n
3982 ENDIF
3983 mint(83)=n
3984 mint(84)=n+mstp(126)
3985 IF(ipile.LT.npile) CALL pyfram(2)
3986 300 CONTINUE
3987
3988C...Generic information on pileup events. Reconstruct missing history.
3989 IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN
3990 pari(91)=vint(132)
3991 pari(92)=vint(133)
3992 pari(93)=vint(134)
3993 IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)
3994 ENDIF
3995 CALL pyedit(16)
3996
3997C...Transform to the desired coordinate frame.
3998 310 CALL pyfram(mstp(124))
3999 mstu(70)=mstu70
4000 paru(21)=vint(1)
4001
4002C...Error messages
4003 5100 FORMAT(1x,'Error: no subprocess switched on.'/
4004 &1x,'Execution stopped.')
4005
4006 RETURN
4007 END
4008
4009
4010C***********************************************************************
4011
4012C...PYSTAT
4013C...Prints out information about cross-sections, decay widths, branching
4014C...ratios, kinematical limits, status codes and parameter values.
4015
4016 SUBROUTINE pystat(MSTAT)
4017
4018C...Double precision and integer declarations.
4019 IMPLICIT DOUBLE PRECISION(a-h, o-z)
4020 IMPLICIT INTEGER(I-N)
4021 INTEGER PYK,PYCHGE,PYCOMP
4022C...Parameter statement to help give large particle numbers.
4023 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
4024 &kexcit=4000000,kdimen=5000000)
4025 parameter(eps=1d-3)
4026C...Commonblocks.
4027 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4028 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4029 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
4030 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
4031 common/pypars/mstp(200),parp(200),msti(200),pari(200)
4032 common/pyint1/mint(400),vint(400)
4033 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
4034 common/pyint4/mwid(500),wids(500,5)
4035 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
4036 common/pyint6/proc(0:500)
4037 CHARACTER PROC*28, CHTMP*16
4038 common/pymssm/imss(0:99),rmss(0:99)
4039 common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
4040 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
4041 &/pyint2/,/pyint4/,/pyint5/,/pyint6/,/pymssm/,/pymsrv/
4042C...Local arrays, character variables and data.
4043 dimension wdtp(0:400),wdte(0:400,0:5),nmodes(0:20),pbrat(10)
4044 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4045 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4046 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4047 CHARACTER*24 CHD0, CHDC(10)
4048 CHARACTER*6 DNAME(3)
4049 DATA proga/
4050 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4051 &'VMD/hadron * anomalous ','direct * direct ',
4052 &'direct * anomalous ','anomalous * anomalous '/
4053 DATA disga/'e * VMD','e * anomalous'/
4054 DATA progg9/
4055 &'direct * direct ','direct * VMD ',
4056 &'direct * anomalous ','VMD * direct ',
4057 &'VMD * VMD ','VMD * anomalous ',
4058 &'anomalous * direct ','anomalous * VMD ',
4059 &'anomalous * anomalous ','DIS * VMD ',
4060 &'DIS * anomalous ','VMD * DIS ',
4061 &'anomalous * DIS '/
4062 DATA progg4/
4063 &'direct * direct ','direct * resolved ',
4064 &'resolved * direct ','resolved * resolved '/
4065 DATA progg2/
4066 &'direct * hadron ','resolved * hadron '/
4067 DATA progp4/
4068 &'VMD * hadron ','direct * hadron ',
4069 &'anomalous * hadron ','DIS * hadron '/
4070 DATA state/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4071 &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4072 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4073 &' y*_small ',' eta*_large ',' eta*_small ',
4074 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4075 &' x_2 ',' x_F ',' cos(theta_hard) ',
4076 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4077 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4078 &' tau'' '/
4079 DATA dname /'q ','lepton','nu '/
4080
4081C...Cross-sections.
4082 IF(mstat.LE.1) THEN
4083 IF(mint(121).GT.1) CALL pysave(5,0)
4084 WRITE(mstu(11),5000)
4085 WRITE(mstu(11),5100)
4086 WRITE(mstu(11),5200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)
4087 DO 100 i=1,500
4088 IF(msub(i).NE.1) GOTO 100
4089 WRITE(mstu(11),5200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)
4090 100 CONTINUE
4091 IF(mint(121).GT.1) THEN
4092 WRITE(mstu(11),5300)
4093 DO 110 iga=1,mint(121)
4094 CALL pysave(3,iga)
4095 IF(mint(121).EQ.2.AND.mstp(14).EQ.10) THEN
4096 WRITE(mstu(11),5200) iga,disga(iga),ngen(0,3),ngen(0,1),
4097 & xsec(0,3)
4098 ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
4099 WRITE(mstu(11),5200) iga,progg9(iga),ngen(0,3),ngen(0,1),
4100 & xsec(0,3)
4101 ELSEIF(mint(121).EQ.4.AND.mstp(14).EQ.30) THEN
4102 WRITE(mstu(11),5200) iga,progp4(iga),ngen(0,3),ngen(0,1),
4103 & xsec(0,3)
4104 ELSEIF(mint(121).EQ.4) THEN
4105 WRITE(mstu(11),5200) iga,progg4(iga),ngen(0,3),ngen(0,1),
4106 & xsec(0,3)
4107 ELSEIF(mint(121).EQ.2) THEN
4108 WRITE(mstu(11),5200) iga,progg2(iga),ngen(0,3),ngen(0,1),
4109 & xsec(0,3)
4110 ELSE
4111 WRITE(mstu(11),5200) iga,proga(iga),ngen(0,3),ngen(0,1),
4112 & xsec(0,3)
4113 ENDIF
4114 110 CONTINUE
4115 CALL pysave(5,0)
4116 ENDIF
4117 WRITE(mstu(11),5400) mstu(23),mstu(30),mstu(27),
4118 & 1d0-dble(ngen(0,3))/max(1d0,dble(ngen(0,2)))
4119
4120C...Decay widths and branching ratios.
4121 ELSEIF(mstat.EQ.2) THEN
4122 WRITE(mstu(11),5500)
4123 WRITE(mstu(11),5600)
4124 DO 140 kc=1,500
4125 kf=kchg(kc,4)
4126 CALL pyname(kf,chkf)
4127 ioff=0
4128 IF(kc.LE.22) THEN
4129 IF(kc.GT.2*mstp(1).AND.kc.LE.10) GOTO 140
4130 IF(kc.GT.10+2*mstp(1).AND.kc.LE.20) GOTO 140
4131 IF(kc.LE.5.OR.(kc.GE.11.AND.kc.LE.16)) ioff=1
4132 IF(kc.EQ.18.AND.pmas(18,1).LT.1d0) ioff=1
4133 IF(kc.EQ.21.OR.kc.EQ.22) ioff=1
4134 ELSE
4135 IF(mwid(kc).LE.0) GOTO 140
4136 IF(imss(1).LE.0.AND.(kf/ksusy1.EQ.1.OR.
4137 & kf/ksusy1.EQ.2)) GOTO 140
4138 ENDIF
4139C...Off-shell branchings.
4140 IF(ioff.EQ.1) THEN
4141 ngp=0
4142 IF(kc.LE.20) ngp=(mod(kc,10)+1)/2
4143 IF(ngp.LE.mstp(1)) WRITE(mstu(11),5700) kf,chkf(1:10),
4144 & pmas(kc,1),0d0,0d0,state(mdcy(kc,1)),0d0
4145 DO 120 j=1,mdcy(kc,3)
4146 idc=j+mdcy(kc,2)-1
4147 ngp1=0
4148 IF(iabs(kfdp(idc,1)).LE.20) ngp1=
4149 & (mod(iabs(kfdp(idc,1)),10)+1)/2
4150 ngp2=0
4151 IF(iabs(kfdp(idc,2)).LE.20) ngp2=
4152 & (mod(iabs(kfdp(idc,2)),10)+1)/2
4153 CALL pyname(kfdp(idc,1),chd1)
4154 CALL pyname(kfdp(idc,2),chd2)
4155 IF(kfdp(idc,3).EQ.0) THEN
4156 IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
4157 & ngp2.LE.mstp(1)) WRITE(mstu(11),5800) idc,chd1(1:10),
4158 & chd2(1:10),0d0,0d0,state(mdme(idc,1)),0d0
4159 ELSE
4160 CALL pyname(kfdp(idc,3),chd3)
4161 IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.
4162 & ngp2.LE.mstp(1)) WRITE(mstu(11),5900) idc,chd1(1:10),
4163 & chd2(1:10),chd3(1:10),0d0,0d0,state(mdme(idc,1)),0d0
4164 ENDIF
4165 120 CONTINUE
4166C...On-shell decays.
4167 ELSE
4168 CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
4169 brfin=1d0
4170 IF(wdte(0,0).LE.0d0) brfin=0d0
4171 WRITE(mstu(11),5700) kf,chkf(1:10),pmas(kc,1),wdtp(0),1d0,
4172 & state(mdcy(kc,1)),brfin
4173 DO 130 j=1,mdcy(kc,3)
4174 idc=j+mdcy(kc,2)-1
4175 ngp1=0
4176 IF(iabs(kfdp(idc,1)).LE.20) ngp1=
4177 & (mod(iabs(kfdp(idc,1)),10)+1)/2
4178 ngp2=0
4179 IF(iabs(kfdp(idc,2)).LE.20) ngp2=
4180 & (mod(iabs(kfdp(idc,2)),10)+1)/2
4181 brpri=0d0
4182 IF(wdtp(0).GT.0d0) brpri=wdtp(j)/wdtp(0)
4183 brfin=0d0
4184 IF(wdte(0,0).GT.0d0) brfin=wdte(j,0)/wdte(0,0)
4185 CALL pyname(kfdp(idc,1),chd1)
4186 CALL pyname(kfdp(idc,2),chd2)
4187 IF(kfdp(idc,3).EQ.0) THEN
4188 IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
4189 & WRITE(mstu(11),5800) idc,chd1(1:10),
4190 & chd2(1:10),wdtp(j),brpri,
4191 & state(mdme(idc,1)),brfin
4192 ELSE
4193 CALL pyname(kfdp(idc,3),chd3)
4194 IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))
4195 & WRITE(mstu(11),5900) idc,chd1(1:10),
4196 & chd2(1:10),chd3(1:10),wdtp(j),brpri,
4197 & state(mdme(idc,1)),brfin
4198 ENDIF
4199 130 CONTINUE
4200 ENDIF
4201 140 CONTINUE
4202 WRITE(mstu(11),6000)
4203
4204C...Allowed incoming partons/particles at hard interaction.
4205 ELSEIF(mstat.EQ.3) THEN
4206 WRITE(mstu(11),6100)
4207 CALL pyname(mint(11),chau)
4208 chin(1)=chau(1:12)
4209 CALL pyname(mint(12),chau)
4210 chin(2)=chau(1:12)
4211 WRITE(mstu(11),6200) chin(1),chin(2)
4212 DO 150 i=-20,22
4213 IF(i.EQ.0) GOTO 150
4214 ia=iabs(i)
4215 IF(ia.GT.mstp(58).AND.ia.LE.10) GOTO 150
4216 IF(ia.GT.10+2*mstp(1).AND.ia.LE.20) GOTO 150
4217 CALL pyname(i,chau)
4218 WRITE(mstu(11),6300) chau,state(kfin(1,i)),chau,
4219 & state(kfin(2,i))
4220 150 CONTINUE
4221 WRITE(mstu(11),6400)
4222
4223C...User-defined limits on kinematical variables.
4224 ELSEIF(mstat.EQ.4) THEN
4225 WRITE(mstu(11),6500)
4226 WRITE(mstu(11),6600)
4227 shrmax=ckin(2)
4228 IF(shrmax.LT.0d0) shrmax=vint(1)
4229 WRITE(mstu(11),6700) ckin(1),chkin(1),shrmax
4230 pthmin=max(ckin(3),ckin(5))
4231 pthmax=ckin(4)
4232 IF(pthmax.LT.0d0) pthmax=0.5d0*shrmax
4233 WRITE(mstu(11),6800) ckin(3),pthmin,chkin(2),pthmax
4234 WRITE(mstu(11),6900) chkin(3),ckin(6)
4235 DO 160 i=4,14
4236 WRITE(mstu(11),6700) ckin(2*i-1),chkin(i),ckin(2*i)
4237 160 CONTINUE
4238 sprmax=ckin(32)
4239 IF(sprmax.LT.0d0) sprmax=vint(1)
4240 WRITE(mstu(11),6700) ckin(31),chkin(15),sprmax
4241 WRITE(mstu(11),7000)
4242
4243C...Status codes and parameter values.
4244 ELSEIF(mstat.EQ.5) THEN
4245 WRITE(mstu(11),7100)
4246 WRITE(mstu(11),7200)
4247 DO 170 i=1,100
4248 WRITE(mstu(11),7300) i,mstp(i),parp(i),100+i,mstp(100+i),
4249 & parp(100+i)
4250 170 CONTINUE
4251
4252C...List of all processes implemented in the program.
4253 ELSEIF(mstat.EQ.6) THEN
4254 WRITE(mstu(11),7400)
4255 WRITE(mstu(11),7500)
4256 DO 180 i=1,500
4257 IF(iset(i).LT.0) GOTO 180
4258 WRITE(mstu(11),7600) i,proc(i),iset(i),kfpr(i,1),kfpr(i,2)
4259 180 CONTINUE
4260 WRITE(mstu(11),7700)
4261
4262 ELSEIF(mstat.EQ.7) THEN
4263 WRITE (mstu(11),8000)
4264 nmodes(0)=0
4265 nmodes(10)=0
4266 nmodes(9)=0
4267 DO 290 ilr=1,2
4268 DO 280 kfsm=1,16
4269 kfsusy=ilr*ksusy1+kfsm
4270 nrvdc=0
4271C...SDOWN DECAYS
4272 IF (kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5) THEN
4273 nrvdc=3
4274 DO 190 i=1,nrvdc
4275 pbrat(i)=0d0
4276 nmodes(i)=0
4277 190 CONTINUE
4278 CALL pyname(kfsusy,chtmp)
4279 chd0=chtmp//' '
4280 chdc(1)=dname(3) // ' + ' // dname(1)
4281 chdc(2)=dname(2) // ' + ' // dname(1)
4282 chdc(3)=dname(1) // ' + ' // dname(1)
4283 kc=pycomp(kfsusy)
4284 DO 200 j=1,mdcy(kc,3)
4285 idc=j+mdcy(kc,2)-1
4286 id1=iabs(kfdp(idc,1))
4287 id2=iabs(kfdp(idc,2))
4288 IF (kfdp(idc,3).EQ.0) THEN
4289 IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4290 & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4291 pbrat(1)=pbrat(1)+brat(idc)
4292 nmodes(1)=nmodes(1)+1
4293 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4294 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4295 ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4296 & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6)) THEN
4297 pbrat(2)=pbrat(2)+brat(idc)
4298 nmodes(2)=nmodes(2)+1
4299 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4300 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4301 ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4302 & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4303 pbrat(3)=pbrat(3)+brat(idc)
4304 nmodes(3)=nmodes(3)+1
4305 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4306 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4307 ENDIF
4308 ENDIF
4309 200 CONTINUE
4310 ENDIF
4311C...SUP DECAYS
4312 IF (kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6) THEN
4313 nrvdc=2
4314 DO 210 i=1,nrvdc
4315 nmodes(i)=0
4316 pbrat(i)=0d0
4317 210 CONTINUE
4318 CALL pyname(kfsusy,chtmp)
4319 chd0=chtmp//' '
4320 chdc(1)=dname(2) // ' + ' // dname(1)
4321 chdc(2)=dname(1) // ' + ' // dname(1)
4322 kc=pycomp(kfsusy)
4323 DO 220 j=1,mdcy(kc,3)
4324 idc=j+mdcy(kc,2)-1
4325 id1=iabs(kfdp(idc,1))
4326 id2=iabs(kfdp(idc,2))
4327 IF (kfdp(idc,3).EQ.0) THEN
4328 IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).AND.(id2
4329 & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4330 pbrat(1)=pbrat(1)+brat(idc)
4331 nmodes(1)=nmodes(1)+1
4332 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4333 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4334 ELSE IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).AND.(id2
4335 & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4336 pbrat(2)=pbrat(2)+brat(idc)
4337 nmodes(2)=nmodes(2)+1
4338 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4339 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4340 ENDIF
4341 ENDIF
4342 220 CONTINUE
4343 ENDIF
4344C...SLEPTON DECAYS
4345 IF (kfsm.EQ.11.OR.kfsm.EQ.13.OR.kfsm.EQ.15) THEN
4346 nrvdc=2
4347 DO 230 i=1,nrvdc
4348 pbrat(i)=0d0
4349 nmodes(i)=0
4350 230 CONTINUE
4351 CALL pyname(kfsusy,chtmp)
4352 chd0=chtmp//' '
4353 chdc(1)=dname(3) // ' + ' // dname(2)
4354 chdc(2)=dname(1) // ' + ' // dname(1)
4355 kc=pycomp(kfsusy)
4356 DO 240 j=1,mdcy(kc,3)
4357 idc=j+mdcy(kc,2)-1
4358 id1=iabs(kfdp(idc,1))
4359 id2=iabs(kfdp(idc,2))
4360 IF (kfdp(idc,3).EQ.0) THEN
4361 IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4362 & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15)) THEN
4363 pbrat(1)=pbrat(1)+brat(idc)
4364 nmodes(1)=nmodes(1)+1
4365 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4366 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4367 ENDIF
4368 IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).AND.(id2
4369 & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4370 pbrat(2)=pbrat(2)+brat(idc)
4371 nmodes(2)=nmodes(2)+1
4372 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4373 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4374 ENDIF
4375 ENDIF
4376 240 CONTINUE
4377 ENDIF
4378C...SNEUTRINO DECAYS
4379 IF ((kfsm.EQ.12.OR.kfsm.EQ.14.OR.kfsm.EQ.16).AND.ilr.EQ.1)
4380 & THEN
4381 nrvdc=2
4382 DO 250 i=1,nrvdc
4383 pbrat(i)=0d0
4384 nmodes(i)=0
4385 250 CONTINUE
4386 CALL pyname(kfsusy,chtmp)
4387 chd0=chtmp//' '
4388 chdc(1)=dname(2) // ' + ' // dname(2)
4389 chdc(2)=dname(1) // ' + ' // dname(1)
4390 kc=pycomp(kfsusy)
4391 DO 260 j=1,mdcy(kc,3)
4392 idc=j+mdcy(kc,2)-1
4393 id1=iabs(kfdp(idc,1))
4394 id2=iabs(kfdp(idc,2))
4395 IF (kfdp(idc,3).EQ.0) THEN
4396 IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).AND.(id2
4397 & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15)) THEN
4398 pbrat(1)=pbrat(1)+brat(idc)
4399 nmodes(1)=nmodes(1)+1
4400 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4401 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4402 ENDIF
4403 IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).AND.(id2
4404 & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5)) THEN
4405 nmodes(2)=nmodes(2)+1
4406 pbrat(2)=pbrat(2)+brat(idc)
4407 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4408 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4409 ENDIF
4410 ENDIF
4411 260 CONTINUE
4412 ENDIF
4413 IF (nrvdc.NE.0) THEN
4414 DO 270 i=1,nrvdc
4415 WRITE (mstu(11),8200) chd0, chdc(i), pbrat(i), nmodes(i)
4416 nmodes(0)=nmodes(0)+nmodes(i)
4417 270 CONTINUE
4418 ENDIF
4419 280 CONTINUE
4420 290 CONTINUE
4421 DO 370 kfsm=21,37
4422 kfsusy=ksusy1+kfsm
4423 nrvdc=0
4424C...NEUTRALINO DECAYS
4425 IF (kfsm.EQ.22.OR.kfsm.EQ.23.OR.kfsm.EQ.25.OR.kfsm.EQ.35) THEN
4426 nrvdc=4
4427 DO 300 i=1,nrvdc
4428 pbrat(i)=0d0
4429 nmodes(i)=0
4430 300 CONTINUE
4431 CALL pyname(kfsusy,chtmp)
4432 chd0=chtmp//' '
4433 chdc(1)=dname(3) // ' + ' // dname(2) // ' + ' // dname(2)
4434 chdc(2)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4435 chdc(3)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4436 chdc(4)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4437 kc=pycomp(kfsusy)
4438 DO 310 j=1,mdcy(kc,3)
4439 idc=j+mdcy(kc,2)-1
4440 id1=iabs(kfdp(idc,1))
4441 id2=iabs(kfdp(idc,2))
4442 id3=iabs(kfdp(idc,3))
4443 IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4444 & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.EQ.11.or
4445 & .id3.EQ.13.OR.id3.EQ.15)) THEN
4446 pbrat(1)=pbrat(1)+brat(idc)
4447 nmodes(1)=nmodes(1)+1
4448 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4449 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4450 ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4451 & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4452 & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4453 pbrat(2)=pbrat(2)+brat(idc)
4454 nmodes(2)=nmodes(2)+1
4455 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4456 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4457 ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4458 & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.EQ.1
4459 & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4460 pbrat(3)=pbrat(3)+brat(idc)
4461 nmodes(3)=nmodes(3)+1
4462 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4463 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4464 ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4465 & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4466 & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4467 pbrat(4)=pbrat(4)+brat(idc)
4468 nmodes(4)=nmodes(4)+1
4469 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4470 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4471 ENDIF
4472 310 CONTINUE
4473 ENDIF
4474C...CHARGINO DECAYS
4475 IF (kfsm.EQ.24.OR.kfsm.EQ.37) THEN
4476 nrvdc=5
4477 DO 320 i=1,nrvdc
4478 pbrat(i)=0d0
4479 nmodes(i)=0
4480 320 CONTINUE
4481 CALL pyname(kfsusy,chtmp)
4482 chd0=chtmp//' '
4483 chdc(1)=dname(3) // ' + ' // dname(3) // ' + ' // dname(2)
4484 chdc(2)=dname(2) // ' + ' // dname(2) // ' + ' // dname(2)
4485 chdc(3)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4486 chdc(4)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4487 chdc(5)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4488 kc=pycomp(kfsusy)
4489 DO 330 j=1,mdcy(kc,3)
4490 idc=j+mdcy(kc,2)-1
4491 id1=iabs(kfdp(idc,1))
4492 id2=iabs(kfdp(idc,2))
4493 id3=iabs(kfdp(idc,3))
4494 IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4495 & .EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.EQ.12.or
4496 & .id3.EQ.14.OR.id3.EQ.16)) THEN
4497 pbrat(1)=pbrat(1)+brat(idc)
4498 nmodes(1)=nmodes(1)+1
4499 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4500 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4501 ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4502 & .(id2.EQ.12.OR.id2.EQ.14.OR.id2.EQ.16).AND.(id3.eq
4503 & .11.OR.id3.EQ.13.OR.id3.EQ.15)) THEN
4504 pbrat(1)=pbrat(1)+brat(idc)
4505 nmodes(1)=nmodes(1)+1
4506 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4507 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4508 ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4509 & .(id2.EQ.11.OR.id2.EQ.13.OR.id2.EQ.15).AND.(id3.eq
4510 & .11.OR.id3.EQ.13.OR.id3.EQ.15)) THEN
4511 pbrat(2)=pbrat(2)+brat(idc)
4512 nmodes(2)=nmodes(2)+1
4513 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4514 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4515 ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4516 & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4517 & .2.OR.id3.EQ.4.OR.id3.EQ.6)) THEN
4518 pbrat(3)=pbrat(3)+brat(idc)
4519 nmodes(3)=nmodes(3)+1
4520 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4521 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4522 ELSE IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).and
4523 & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4524 & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4525 pbrat(3)=pbrat(3)+brat(idc)
4526 nmodes(3)=nmodes(3)+1
4527 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4528 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4529 ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4530 & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4531 & .2.OR.id3.EQ.4.OR.id3.EQ.6)) THEN
4532 pbrat(4)=pbrat(4)+brat(idc)
4533 nmodes(4)=nmodes(4)+1
4534 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4535 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4536 ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4537 & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4538 & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4539 pbrat(4)=pbrat(4)+brat(idc)
4540 nmodes(4)=nmodes(4)+1
4541 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4542 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4543 ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4544 & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.eq
4545 & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4546 pbrat(5)=pbrat(5)+brat(idc)
4547 nmodes(5)=nmodes(5)+1
4548 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4549 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4550 ELSE IF ((id1.EQ.1.OR.id1.EQ.3.OR.id1.EQ.5).and
4551 & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.eq
4552 & .1.OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4553 pbrat(5)=pbrat(5)+brat(idc)
4554 nmodes(5)=nmodes(5)+1
4555 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4556 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4557 ENDIF
4558 330 CONTINUE
4559 ENDIF
4560C...GLUINO DECAYS
4561 IF (kfsm.EQ.21) THEN
4562 nrvdc=3
4563 DO 340 i=1,nrvdc
4564 pbrat(i)=0d0
4565 nmodes(i)=0
4566 340 CONTINUE
4567 CALL pyname(kfsusy,chtmp)
4568 chd0=chtmp//' '
4569 chdc(1)=dname(3) // ' + ' // dname(1) // ' + ' // dname(1)
4570 chdc(2)=dname(2) // ' + ' // dname(1) // ' + ' // dname(1)
4571 chdc(3)=dname(1) // ' + ' // dname(1) // ' + ' // dname(1)
4572 kc=pycomp(kfsusy)
4573 DO 350 j=1,mdcy(kc,3)
4574 idc=j+mdcy(kc,2)-1
4575 id1=iabs(kfdp(idc,1))
4576 id2=iabs(kfdp(idc,2))
4577 id3=iabs(kfdp(idc,3))
4578 IF ((id1.EQ.12.OR.id1.EQ.14.OR.id1.EQ.16).AND.(id2
4579 & .EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1.or
4580 & .id3.EQ.3.OR.id3.EQ.5)) THEN
4581 pbrat(1)=pbrat(1)+brat(idc)
4582 nmodes(1)=nmodes(1)+1
4583 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4584 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4585 ELSE IF ((id1.EQ.11.OR.id1.EQ.13.OR.id1.EQ.15).and
4586 & .(id2.EQ.2.OR.id2.EQ.4.OR.id2.EQ.6).AND.(id3.EQ.1
4587 & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4588 pbrat(2)=pbrat(2)+brat(idc)
4589 nmodes(2)=nmodes(2)+1
4590 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4591 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4592 ELSE IF ((id1.EQ.2.OR.id1.EQ.4.OR.id1.EQ.6).and
4593 & .(id2.EQ.1.OR.id2.EQ.3.OR.id2.EQ.5).AND.(id3.EQ.1
4594 & .OR.id3.EQ.3.OR.id3.EQ.5)) THEN
4595 pbrat(3)=pbrat(3)+brat(idc)
4596 nmodes(3)=nmodes(3)+1
4597 IF (brat(idc).GT.0d0) nmodes(10)=nmodes(10)+1
4598 IF (brat(idc).GT.eps) nmodes(9)=nmodes(9)+1
4599 ENDIF
4600 350 CONTINUE
4601 ENDIF
4602
4603 IF (nrvdc.NE.0) THEN
4604 DO 360 i=1,nrvdc
4605 WRITE (mstu(11),8200) chd0, chdc(i), pbrat(i), nmodes(i)
4606 nmodes(0)=nmodes(0)+nmodes(i)
4607 360 CONTINUE
4608 ENDIF
4609 370 CONTINUE
4610 WRITE (mstu(11),8100) nmodes(0), nmodes(10), nmodes(9)
4611
4612 IF (imss(51).GE.1.OR.imss(52).GE.1.OR.imss(53).GE.1) THEN
4613 WRITE (mstu(11),8500)
4614 DO 400 irv=1,3
4615 DO 390 jrv=1,3
4616 DO 380 krv=1,3
4617 WRITE (mstu(11),8700) irv,jrv,krv,rvlam(irv,jrv,krv)
4618 & ,rvlamp(irv,jrv,krv),rvlamb(irv,jrv,krv)
4619 380 CONTINUE
4620 390 CONTINUE
4621 400 CONTINUE
4622 WRITE (mstu(11),8600)
4623 ENDIF
4624 ENDIF
4625
4626C...Formats for printouts.
4627 5000 FORMAT('1',9('*'),1x,'PYSTAT: Statistics on Number of ',
4628 &'Events and Cross-sections',1x,9('*'))
4629 5100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x,
4630 &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,
4631 &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),
4632 &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,
4633 &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x,
4634 &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x,
4635 &'I',12x,'I')
4636 5200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p,
4637 &d10.3,1x,'I')
4638 5300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/
4639 &1x,'I',34x,'I',28x,'I',12x,'I')
4640 5400 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//
4641 &1x,'********* Total number of errors, excluding junctions =',
4642 &1x,i8,' *************'/
4643 &1x,'********* Total number of errors, including junctions =',
4644 &1x,i8,' *************'/
4645 &1x,'********* Total number of warnings = ',
4646 &1x,i8,' *************'/
4647 &1x,'********* Fraction of events that fail fragmentation ',
4648 &'cuts =',1x,f8.5,' *********'/)
4649 5500 FORMAT('1',27('*'),1x,'PYSTAT: Decay Widths and Branching ',
4650 &'Ratios',1x,27('*'))
4651 5600 FORMAT(/1x,98('=')/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
4652 &1x,'I',5x,'Mother --> Branching/Decay Channel',8x,'I',1x,
4653 &'Width (GeV)',1x,'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,
4654 &'Eff. B.R.',1x,'I'/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/
4655 &1x,98('='))
4656 5700 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,
4657 &i8,2x,a10,3x,'(m =',f10.3,')',2x,'-->',5x,'I',2x,1p,d10.3,0p,1x,
4658 &'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,d10.3,0p,1x,'I')
4659 5800 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,15x,'I',2x,
4660 &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,
4661 &1p,d10.3,0p,1x,'I')
4662 5900 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,1x,'+',1x,a10,2x,'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 6000 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,98('='))
4666 6100 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/',
4667 &'Particles at Hard Interaction',1x,7('*'))
4668 6200 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,
4669 &'Beam particle:',1x,a12,10x,'I',1x,'Target particle:',1x,a12,7x,
4670 &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',6x,'State',19x,
4671 &'I',1x,'Content',6x,'State',18x,'I'/1x,'I',38x,'I',37x,'I'/1x,
4672 &78('=')/1x,'I',38x,'I',37x,'I')
4673 6300 FORMAT(1x,'I',1x,a9,5x,a4,19x,'I',1x,a9,5x,a4,18x,'I')
4674 6400 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('='))
4675 6500 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',
4676 &'Kinematical Variables',1x,12('*'))
4677 6600 FORMAT(/1x,78('=')/1x,'I',76x,'I')
4678 6700 FORMAT(1x,'I',16x,1p,d10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,d10.3,0p,
4679 &16x,'I')
4680 6800 FORMAT(1x,'I',3x,1p,d10.3,0p,1x,'(',1p,d10.3,0p,')',1x,'<',1x,a,
4681 &1x,'<',1x,1p,d10.3,0p,16x,'I')
4682 6900 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,d10.3,0p,16x,'I')
4683 7000 FORMAT(1x,'I',76x,'I'/1x,78('='))
4684 7100 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ',
4685 &'Parameter Values',1x,12('*'))
4686 7200 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x,
4687 &'PARP(I)'/)
4688 7300 FORMAT(1x,i3,5x,i6,6x,1p,d10.3,0p,18x,i3,5x,i6,6x,1p,d10.3)
4689 7400 FORMAT('1',13('*'),1x,'PYSTAT: List of implemented processes',
4690 &1x,13('*'))
4691 7500 FORMAT(/1x,65('=')/1x,'I',34x,'I',28x,'I'/1x,'I',12x,
4692 &'Subprocess',12x,'I',1x,'ISET',2x,'KFPR(I,1)',2x,'KFPR(I,2)',1x,
4693 &'I'/1x,'I',34x,'I',28x,'I'/1x,65('=')/1x,'I',34x,'I',28x,'I')
4694 7600 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i4,1x,i10,1x,i10,1x,'I')
4695 7700 FORMAT(1x,'I',34x,'I',28x,'I'/1x,65('='))
4696 8000 FORMAT(1x/ 1x/
4697 & 17x,'Sums over R-Violating branching ratios',1x/ 1x
4698 & /1x,70('=')/1x,'I',50x,'I',11x,'I',5x,'I'/1x,'I',4x
4699 & ,'Mother --> Sum over final state flavours',4x,'I',2x
4700 & ,'BR(sum)',2x,'I',2x,'N',2x,'I'/1x,'I',50x,'I',11x,'I',5x,'I'
4701 & /1x,70('=')/1x,'I',50x,'I',11x,'I',5x,'I')
4702 8100 FORMAT(1x,'I',50x,'I',11x,'I',5x,'I'/1x,70('=')/1x,'I',1x
4703 & ,'Total number of R-Violating modes :',3x,i5,24x,'I'/
4704 & 1x,'I',1x,'Total number with non-vanishing BR :',2x,i5,24x
4705 & ,'I'/1x,'I',1x,'Total number with BR > 0.001 :',8x,i5,24x,'I'
4706 & /1x,70('='))
4707 8200 FORMAT(1x,'I',1x,a9,1x,'-->',1x,a24,11x,
4708 & 'I',2x,1p,d8.2,0p,1x,'I',2x,i2,1x,'I')
4709 8300 FORMAT(1x,'I',50x,'I',11x,'I',5x,'I')
4710 8500 FORMAT(1x/ 1x/
4711 & 1x,'R-Violating couplings',1x/ 1x /
4712 & 1x,55('=')/
4713 & 1x,'I',1x,'IJK',1x,'I',2x,'LAMBDA(IJK)',2x,'I',2x
4714 & ,'LAMBDA''(IJK)',1x,'I',1x,"LAMBDA''(IJK)",1x,'I'/1x,'I',5x
4715 & ,'I',15x,'I',15x,'I',15x,'I')
4716 8600 FORMAT(1x,55('='))
4717 8700 FORMAT(1x,'I',1x,i1,i1,i1,1x,'I',1x,1p,d13.3,0p,1x,'I',1x,1p
4718 & ,d13.3,0p,1x,'I',1x,1p,d13.3,0p,1x,'I')
4719
4720 RETURN
4721 END
4722
4723C*********************************************************************
4724
4725C...PYUPEV
4726C...Administers the hard-process generation required for output to the
4727C...Les Houches event record.
4728
4729 SUBROUTINE pyupev
4730
4731C...Double precision and integer declarations.
4732 IMPLICIT DOUBLE PRECISION(a-h, o-z)
4733 IMPLICIT INTEGER(I-N)
4734 INTEGER PYK,PYCHGE,PYCOMP
4735
4736C...Commonblocks.
4737 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
4738 common/pyctag/nct,mct(4000,2)
4739 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
4740 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
4741 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
4742 common/pypars/mstp(200),parp(200),msti(200),pari(200)
4743 common/pyint1/mint(400),vint(400)
4744 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
4745 common/pyint4/mwid(500),wids(500,5)
4746 SAVE /pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,/pypars/,
4747 &/pyint1/,/pyint2/,/pyint4/
4748
4749C...HEPEUP for output.
4750 INTEGER MAXNUP
4751 parameter(maxnup=500)
4752 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4753 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4754 common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
4755 &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
4756 &vtimup(maxnup),spinup(maxnup)
4757 SAVE /hepeup/
4758
4759C...Stop if no subprocesses on.
4760 IF(mint(121).EQ.1.AND.msti(53).EQ.1) THEN
4761 WRITE(mstu(11),5100)
4762 stop
4763 ENDIF
4764
4765C...Special flags for hard-process generation only.
4766 mstp71=mstp(71)
4767 mstp(71)=0
4768 mst128=mstp(128)
4769 mstp(128)=1
4770
4771C...Initial values for some counters.
4772 n=0
4773 mint(5)=mint(5)+1
4774 mint(7)=0
4775 mint(8)=0
4776 mint(30)=0
4777 mint(83)=0
4778 mint(84)=mstp(126)
4779 mstu(24)=0
4780 mstu70=0
4781 mstj14=mstj(14)
4782C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4783 mint(33)=0
4784
4785C...If variable energies: redo incoming kinematics and cross-section.
4786 msti(61)=0
4787 IF(mstp(171).EQ.1) THEN
4788 CALL pyinki(1)
4789 IF(msti(61).EQ.1) THEN
4790 mint(5)=mint(5)-1
4791 RETURN
4792 ENDIF
4793 IF(mint(121).GT.1) CALL pysave(3,1)
4794 CALL pyxtot
4795 ENDIF
4796
4797C...Do not allow pileup events.
4798 mint(82)=1
4799
4800C...Generate variables of hard scattering.
4801 mint(51)=0
4802 msti(52)=0
4803 100 CONTINUE
4804 IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1
4805 mint(31)=0
4806 mint(51)=0
4807 mint(57)=0
4808 CALL pyrand
4809 IF(msti(61).EQ.1) THEN
4810 mint(5)=mint(5)-1
4811 RETURN
4812 ENDIF
4813 IF(mint(51).EQ.2) RETURN
4814 isub=mint(1)
4815
4816 IF((isub.LE.90.OR.isub.GE.95).AND.isub.NE.99) THEN
4817C...Hard scattering (including low-pT):
4818C...reconstruct kinematics and colour flow of hard scattering.
4819 mint31=mint(31)
4820 110 mint(31)=mint31
4821 mint(51)=0
4822 CALL pyscat
4823 IF(mint(51).EQ.1) GOTO 100
4824 ipu1=mint(84)+1
4825 ipu2=mint(84)+2
4826
4827C...Decay of final state resonances.
4828 mint(32)=0
4829 IF(mstp(41).GE.1.AND.iset(isub).LE.10.AND.isub.NE.95)
4830 & CALL pyresd(0)
4831 IF(mint(51).EQ.1) GOTO 100
4832 mint(52)=n
4833
4834C...Longitudinal boost of hard scattering.
4835 betaz=(vint(41)-vint(42))/(vint(41)+vint(42))
4836 CALL pyrobo(mint(84)+1,n,0d0,0d0,0d0,0d0,betaz)
4837
4838 ELSEIF(isub.NE.99) THEN
4839C...Diffractive and elastic scattering.
4840 CALL pydiff
4841
4842 ELSE
4843C...DIS scattering (photon flux external).
4844 CALL pydisg
4845 IF(mint(51).EQ.1) GOTO 100
4846 ENDIF
4847
4848C...Check that no odd resonance left undecayed.
4849 mint(54)=n
4850 nfix=n
4851 DO 120 i=mint(84)+1,nfix
4852 IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.
4853 & k(i,2).NE.22) THEN
4854 kca=pycomp(k(i,2))
4855 IF(mwid(kca).NE.0.AND.mdcy(kca,1).GE.1) THEN
4856 CALL pyresd(i)
4857 IF(mint(51).EQ.1) GOTO 100
4858 ENDIF
4859 ENDIF
4860 120 CONTINUE
4861
4862C...Boost hadronic subsystem to overall rest frame.
4863C..(Only relevant when photon inside lepton beam.)
4864 IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(4,wtgaga)
4865
4866C...Store event information and calculate Monte Carlo estimates of
4867C...subprocess cross-sections.
4868 130 CALL pydocu
4869
4870C...Transform to the desired coordinate frame.
4871 140 CALL pyfram(mstp(124))
4872 mstu(70)=mstu70
4873 paru(21)=vint(1)
4874
4875C...Restore special flags for hard-process generation only.
4876 mstp(71)=mstp71
4877 mstp(128)=mst128
4878
4879C...Trace colour tags; convert to LHA style labels.
4880 nct=100
4881 DO 150 i=mint(84)+1,n
4882 mct(i,1)=0
4883 mct(i,2)=0
4884 150 CONTINUE
4885 DO 160 i=mint(84)+1,n
4886 kq=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
4887 IF(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN
4888 IF(k(i,4).NE.0.AND.(kq.EQ.1.OR.kq.EQ.2).AND.mct(i,1).EQ.0)
4889 & THEN
4890 imo=mod(k(i,4)/mstu(5),mstu(5))
4891 ida=mod(k(i,4),mstu(5))
4892 IF(imo.NE.0.AND.mod(k(imo,5)/mstu(5),mstu(5)).EQ.i.AND.
4893 & mct(imo,2).NE.0) THEN
4894 mct(i,1)=mct(imo,2)
4895 ELSEIF(imo.NE.0.AND.mod(k(imo,4),mstu(5)).EQ.i.AND.
4896 & mct(imo,1).NE.0) THEN
4897 mct(i,1)=mct(imo,1)
4898 ELSEIF(ida.NE.0.AND.mod(k(ida,5),mstu(5)).EQ.i.AND.
4899 & mct(ida,2).NE.0) THEN
4900 mct(i,1)=mct(ida,2)
4901 ELSE
4902 nct=nct+1
4903 mct(i,1)=nct
4904 ENDIF
4905 ENDIF
4906 IF(k(i,5).NE.0.AND.(kq.EQ.-1.OR.kq.EQ.2).AND.mct(i,2).EQ.0)
4907 & THEN
4908 imo=mod(k(i,5)/mstu(5),mstu(5))
4909 ida=mod(k(i,5),mstu(5))
4910 IF(imo.NE.0.AND.mod(k(imo,4)/mstu(5),mstu(5)).EQ.i.AND.
4911 & mct(imo,1).NE.0) THEN
4912 mct(i,2)=mct(imo,1)
4913 ELSEIF(imo.NE.0.AND.mod(k(imo,5),mstu(5)).EQ.i.AND.
4914 & mct(imo,2).NE.0) THEN
4915 mct(i,2)=mct(imo,2)
4916 ELSEIF(ida.NE.0.AND.mod(k(ida,4),mstu(5)).EQ.i.AND.
4917 & mct(ida,1).NE.0) THEN
4918 mct(i,2)=mct(ida,1)
4919 ELSE
4920 nct=nct+1
4921 mct(i,2)=nct
4922 ENDIF
4923 ENDIF
4924 ENDIF
4925 160 CONTINUE
4926
4927C...Put event in HEPEUP commonblock.
4928 nup=n-mint(84)
4929 idprup=mint(1)
4930 xwgtup=1d0
4931 scalup=vint(53)
4932 aqedup=vint(57)
4933 aqcdup=vint(58)
4934 DO 180 i=1,nup
4935 idup(i)=k(i+mint(84),2)
4936 IF(i.LE.2) THEN
4937 istup(i)=-1
4938 mothup(1,i)=0
4939 mothup(2,i)=0
4940 ELSEIF(k(i+4,3).EQ.0) THEN
4941 istup(i)=1
4942 mothup(1,i)=1
4943 mothup(2,i)=2
4944 ELSE
4945 istup(i)=1
4946 mothup(1,i)=k(i+mint(84),3)-mint(84)
4947 mothup(2,i)=0
4948 ENDIF
4949 IF(i.GE.3.AND.k(i+mint(84),3).GT.0)
4950 & istup(k(i+mint(84),3)-mint(84))=2
4951 icolup(1,i)=mct(i+mint(84),1)
4952 icolup(2,i)=mct(i+mint(84),2)
4953 DO 170 j=1,5
4954 pup(j,i)=p(i+mint(84),j)
4955 170 CONTINUE
4956 vtimup(i)=v(i,5)
4957 spinup(i)=9d0
4958 180 CONTINUE
4959
4960C...Optionally write out event to disk. Minimal size for time/spin fields.
4961 IF(mstp(162).GT.0) THEN
4962 WRITE(mstp(162),5200) nup,idprup,xwgtup,scalup,aqedup,aqcdup
4963 DO 190 i=1,nup
4964 IF(vtimup(i).EQ.0d0) THEN
4965 WRITE(mstp(162),5300) idup(i),istup(i),mothup(1,i),
4966 & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5),
4967 & ' 0. 9.'
4968 ELSE
4969 WRITE(mstp(162),5400) idup(i),istup(i),mothup(1,i),
4970 & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5),
4971 & vtimup(i),' 9.'
4972 ENDIF
4973 190 CONTINUE
4974
4975C...Optional extra line with parton-density information.
4976 IF(mstp(165).GE.1) WRITE(mstp(162),5500) msti(15),msti(16),
4977 & pari(33),pari(34),pari(23),pari(29),pari(30)
4978 ENDIF
4979
4980C...Error messages and other print formats.
4981 5100 FORMAT(1x,'Error: no subprocess switched on.'/
4982 &1x,'Execution stopped.')
4983 5200 FORMAT(1p,2i6,4e14.6)
4984 5300 FORMAT(1p,i8,5i5,5e18.10,a6)
4985 5400 FORMAT(1p,i8,5i5,5e18.10,e12.4,a3)
4986 5500 FORMAT(1p,'#pdf ',2i5,5e18.10)
4987
4988 RETURN
4989 END
4990
4991C*********************************************************************
4992
4993C...PYUPIN
4994C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4995C...processes, and optionally stores that information on file.
4996
4997 SUBROUTINE pyupin
4998
4999C...Double precision and integer declarations.
5000 IMPLICIT DOUBLE PRECISION(a-h, o-z)
5001 IMPLICIT INTEGER(I-N)
5002
5003C...Commonblocks.
5004 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5005 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5006 common/pypars/mstp(200),parp(200),msti(200),pari(200)
5007 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
5008 SAVE /pyjets/,/pysubs/,/pypars/,/pyint5/
5009
5010C...User process initialization commonblock.
5011 INTEGER MAXPUP
5012 parameter(maxpup=100)
5013 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5014 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5015 common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5016 &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5017 &lprup(maxpup)
5018 SAVE /heprup/
5019
5020C...Store info on incoming beams.
5021 idbmup(1)=k(1,2)
5022 idbmup(2)=k(2,2)
5023 ebmup(1)=p(1,4)
5024 ebmup(2)=p(2,4)
5025 pdfgup(1)=0
5026 pdfgup(2)=0
5027 pdfsup(1)=mstp(51)
5028 pdfsup(2)=mstp(51)
5029
5030C...Event weighting strategy.
5031 idwtup=3
5032
5033C...Info on individual processes.
5034 nprup=0
5035 DO 100 isub=1,500
5036 IF(msub(isub).EQ.1) THEN
5037 nprup=nprup+1
5038 xsecup(nprup)=1d9*xsec(isub,3)
5039 xerrup(nprup)=xsecup(nprup)/sqrt(max(1d0,dble(ngen(isub,3))))
5040 xmaxup(nprup)=1d0
5041 lprup(nprup)=isub
5042 ENDIF
5043 100 CONTINUE
5044
5045C...Write info to file.
5046 IF(mstp(161).GT.0) THEN
5047 WRITE(mstp(161),5100) idbmup(1),idbmup(2),ebmup(1),ebmup(2),
5048 & pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
5049 DO 110 ipr=1,nprup
5050 WRITE(mstp(161),5200) xsecup(ipr),xerrup(ipr),xmaxup(ipr),
5051 & lprup(ipr)
5052 110 CONTINUE
5053 ENDIF
5054
5055C...Formats for printout.
5056 5100 FORMAT(1p,2i8,2e14.6,6i6)
5057 5200 FORMAT(1p,3e14.6,i6)
5058
5059 RETURN
5060 END
5061
5062
5063C*********************************************************************
5064
5065C...Combine the two old-style Pythia initialization and event files
5066C...into a single Les Houches Event File.
5067
5068 SUBROUTINE pylhef
5069
5070C...Double precision and integer declarations.
5071 IMPLICIT DOUBLE PRECISION(a-h, o-z)
5072 IMPLICIT INTEGER(I-N)
5073
5074C...PYTHIA commonblock: only used to provide read/write units and version.
5075 common/pypars/mstp(200),parp(200),msti(200),pari(200)
5076 SAVE /pypars/
5077
5078C...User process initialization commonblock.
5079 INTEGER MAXPUP
5080 parameter(maxpup=100)
5081 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5082 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5083 common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5084 &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5085 &lprup(maxpup)
5086 SAVE /heprup/
5087
5088C...User process event common block.
5089 INTEGER MAXNUP
5090 parameter(maxnup=500)
5091 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5092 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5093 common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
5094 &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
5095 &vtimup(maxnup),spinup(maxnup)
5096 SAVE /hepeup/
5097
5098C...Lines to read in assumed never longer than 200 characters.
5099 parameter(maxlen=200)
5100 CHARACTER*(MAXLEN) STRING
5101
5102C...Format for reading lines.
5103 CHARACTER*6 STRFMT
5104 strfmt='(A000)'
5105 WRITE(strfmt(3:5),'(I3)') maxlen
5106
5107C...Rewind initialization and event files.
5108 rewind mstp(161)
5109 rewind mstp(162)
5110
5111C...Write header info.
5112 WRITE(mstp(163),'(A)') '<LesHouchesEvents version="1.0">'
5113 WRITE(mstp(163),'(A)') '<!--'
5114 WRITE(mstp(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5115 &mstp(181),'.',mstp(182)
5116 WRITE(mstp(163),'(A)') '-->'
5117
5118C...Read first line of initialization info and get number of processes.
5119 READ(mstp(161),'(A)',END=400,ERR=400) string
5120 READ(string,*,err=400) idbmup(1),idbmup(2),ebmup(1),
5121 &ebmup(2),pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
5122
5123C...Copy initialization lines, omitting trailing blanks.
5124C...Embed in <init> ... </init> block.
5125 WRITE(mstp(163),'(A)') '<init>'
5126 DO 140 ipr=0,nprup
5127 IF(ipr.GT.0) READ(mstp(161),'(A)',END=400,ERR=400) string
5128 len=maxlen+1
5129 120 len=len-1
5130 IF(len.GT.1.AND.string(len:len).EQ.' ') GOTO 120
5131 WRITE(mstp(163),'(A)',err=400) string(1:len)
5132 140 CONTINUE
5133 WRITE(mstp(163),'(A)') '</init>'
5134
5135C...Begin event loop. Read first line of event info or already done.
5136 READ(mstp(162),'(A)',END=320,ERR=400) string
5137 200 CONTINUE
5138
5139C...Look at first line to know number of particles in event.
5140 READ(string,*,err=400) nup,idprup,xwgtup,scalup,aqedup,aqcdup
5141
5142C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5143 WRITE(mstp(163),'(A)') '<event>'
5144 DO 240 i=0,nup
5145 IF(i.GT.0) READ(mstp(162),'(A)',END=400,ERR=400) string
5146 len=maxlen+1
5147 220 len=len-1
5148 IF(len.GT.1.AND.string(len:len).EQ.' ') GOTO 220
5149 WRITE(mstp(163),'(A)',err=400) string(1:len)
5150 240 CONTINUE
5151
5152C...Copy trailing comment lines - with a # in the first column - as is.
5153 260 READ(mstp(162),'(A)',END=300,ERR=400) string
5154 IF(string(1:1).EQ.'#') THEN
5155 len=maxlen+1
5156 280 len=len-1
5157 IF(len.GT.1.AND.string(len:len).EQ.' ') GOTO 280
5158 WRITE(mstp(163),'(A)',err=400) string(1:len)
5159 GOTO 260
5160 ENDIF
5161
5162C..End the <event> block. Loop back to look for next event.
5163 WRITE(mstp(163),'(A)') '</event>'
5164 GOTO 200
5165
5166C...Successfully reached end of event loop: write closing tag
5167C...and remove temporary intermediate files (unless asked not to).
5168 300 WRITE(mstp(163),'(A)') '</event>'
5169 320 WRITE(mstp(163),'(A)') '</LesHouchesEvents>'
5170 IF(mstp(164).EQ.1) RETURN
5171 CLOSE(mstp(161),err=400,status='DELETE')
5172 CLOSE(mstp(162),err=400,status='DELETE')
5173 RETURN
5174
5175C...Error exit.
5176 400 WRITE(*,*) ' PYLHEF file joining failed!'
5177
5178 RETURN
5179 END
5180
5181C*********************************************************************
5182
5183C...PYINRE
5184C...Calculates full and effective widths of gauge bosons, stores
5185C...masses and widths, rescales coefficients to be used for
5186C...resonance production generation.
5187
5188 SUBROUTINE pyinre
5189
5190C...Double precision and integer declarations.
5191 IMPLICIT DOUBLE PRECISION(a-h, o-z)
5192 IMPLICIT INTEGER(I-N)
5193 INTEGER PYK,PYCHGE,PYCOMP
5194C...Parameter statement to help give large particle numbers.
5195 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
5196 &kexcit=4000000,kdimen=5000000)
5197C...Commonblocks.
5198 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5199 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5200 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
5201 common/pydat4/chaf(500,2)
5202 CHARACTER CHAF*16
5203 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5204 common/pypars/mstp(200),parp(200),msti(200),pari(200)
5205 common/pyint1/mint(400),vint(400)
5206 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
5207 common/pyint4/mwid(500),wids(500,5)
5208 common/pyint6/proc(0:500)
5209 CHARACTER PROC*28
5210 common/pymssm/imss(0:99),rmss(0:99)
5211 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,
5212 &/pyint1/,/pyint2/,/pyint4/,/pyint6/,/pymssm/
5213C...Local arrays and data.
5214 dimension wdtp(0:400),wdte(0:400,0:5),wdtpm(0:400),
5215 &wdtem(0:400,0:5),kcord(500),pmord(500)
5216
5217C...Born level couplings in MSSM Higgs doublet sector.
5218 xw=paru(102)
5219 xwv=xw
5220 IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
5221 xw1=1d0-xw
5222 IF(mstp(4).EQ.2) THEN
5223 tanbe=paru(141)
5224 ratbe=((1d0-tanbe**2)/(1d0+tanbe**2))**2
5225 sqmz=pmas(23,1)**2
5226 sqmw=pmas(24,1)**2
5227 sqmh=pmas(25,1)**2
5228 sqma=sqmh*(sqmz-sqmh)/(sqmz*ratbe-sqmh)
5229 sqmhp=0.5d0*(sqma+sqmz+sqrt((sqma+sqmz)**2-4d0*sqma*sqmz*ratbe))
5230 sqmhc=sqma+sqmw
5231 IF(sqmh.GE.sqmz.OR.min(sqma,sqmhp,sqmhc).LE.0d0) THEN
5232 WRITE(mstu(11),5000)
5233 CALL pystop(101)
5234 ENDIF
5235 pmas(35,1)=sqrt(sqmhp)
5236 pmas(36,1)=sqrt(sqma)
5237 pmas(37,1)=sqrt(sqmhc)
5238 alsu=0.5d0*atan(2d0*tanbe*(sqma+sqmz)/((1d0-tanbe**2)*
5239 & (sqma-sqmz)))
5240 besu=atan(tanbe)
5241 paru(142)=1d0
5242 paru(143)=1d0
5243 paru(161)=-sin(alsu)/cos(besu)
5244 paru(162)=cos(alsu)/sin(besu)
5245 paru(163)=paru(161)
5246 paru(164)=sin(besu-alsu)
5247 paru(165)=paru(164)
5248 paru(168)=sin(besu-alsu)+0.5d0*cos(2d0*besu)*sin(besu+alsu)/xw
5249 paru(171)=cos(alsu)/cos(besu)
5250 paru(172)=sin(alsu)/sin(besu)
5251 paru(173)=paru(171)
5252 paru(174)=cos(besu-alsu)
5253 paru(175)=paru(174)
5254 paru(176)=cos(2d0*alsu)*cos(besu+alsu)-2d0*sin(2d0*alsu)*
5255 & sin(besu+alsu)
5256 paru(177)=cos(2d0*besu)*cos(besu+alsu)
5257 paru(178)=cos(besu-alsu)-0.5d0*cos(2d0*besu)*cos(besu+alsu)/xw
5258 paru(181)=tanbe
5259 paru(182)=1d0/tanbe
5260 paru(183)=paru(181)
5261 paru(184)=0d0
5262 paru(185)=paru(184)
5263 paru(186)=cos(besu-alsu)
5264 paru(187)=sin(besu-alsu)
5265 paru(188)=paru(186)
5266 paru(189)=paru(187)
5267 paru(190)=0d0
5268 paru(195)=cos(besu-alsu)
5269 ENDIF
5270
5271C...Reset effective widths of gauge bosons.
5272 DO 110 i=1,500
5273 DO 100 j=1,5
5274 wids(i,j)=1d0
5275 100 CONTINUE
5276 110 CONTINUE
5277
5278C...Order resonances by increasing mass (except Z0 and W+/-).
5279 nres=0
5280 DO 140 kc=1,500
5281 kf=kchg(kc,4)
5282 IF(kf.EQ.0) GOTO 140
5283 IF(mwid(kc).EQ.0) GOTO 140
5284 IF(kc.EQ.7.OR.kc.EQ.8.OR.kc.EQ.17.OR.kc.EQ.18) THEN
5285 IF(mstp(1).LE.3) GOTO 140
5286 ENDIF
5287 IF(kf/ksusy1.EQ.1.OR.kf/ksusy1.EQ.2) THEN
5288 IF(imss(1).LE.0) GOTO 140
5289 ENDIF
5290 nres=nres+1
5291 pmres=pmas(kc,1)
5292 IF(kc.EQ.23.OR.kc.EQ.24) pmres=0d0
5293 DO 120 i1=nres-1,1,-1
5294 IF(pmres.GE.pmord(i1)) GOTO 130
5295 kcord(i1+1)=kcord(i1)
5296 pmord(i1+1)=pmord(i1)
5297 120 CONTINUE
5298 130 kcord(i1+1)=kc
5299 pmord(i1+1)=pmres
5300 140 CONTINUE
5301
5302C...Loop over possible resonances.
5303 DO 180 i=1,nres
5304 kc=kcord(i)
5305 kf=kchg(kc,4)
5306
5307C...Check that no fourth generation channels on by mistake.
5308 IF(mstp(1).LE.3) THEN
5309 DO 150 j=1,mdcy(kc,3)
5310 idc=j+mdcy(kc,2)-1
5311 kfa1=iabs(kfdp(idc,1))
5312 kfa2=iabs(kfdp(idc,2))
5313 IF(kfa1.EQ.7.OR.kfa1.EQ.8.OR.kfa1.EQ.17.OR.kfa1.EQ.18.OR.
5314 & kfa2.EQ.7.OR.kfa2.EQ.8.OR.kfa2.EQ.17.OR.kfa2.EQ.18)
5315 & mdme(idc,1)=-1
5316 150 CONTINUE
5317 ENDIF
5318
5319C...Check that no supersymmetric channels on by mistake.
5320 IF(imss(1).LE.0) THEN
5321 DO 160 j=1,mdcy(kc,3)
5322 idc=j+mdcy(kc,2)-1
5323 kfa1s=iabs(kfdp(idc,1))/ksusy1
5324 kfa2s=iabs(kfdp(idc,2))/ksusy1
5325 IF(kfa1s.EQ.1.OR.kfa1s.EQ.2.OR.kfa2s.EQ.1.OR.kfa2s.EQ.2)
5326 & mdme(idc,1)=-1
5327 160 CONTINUE
5328 ENDIF
5329
5330C...Find mass and evaluate width.
5331 pmr=pmas(kc,1)
5332 IF(kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) mint(62)=1
5333 IF(mwid(kc).EQ.3) mint(63)=1
5334 CALL pywidt(kf,pmr**2,wdtp,wdte)
5335 mint(51)=0
5336
5337C...Evaluate suppression factors due to non-simulated channels.
5338 IF(kchg(kc,3).EQ.0) THEN
5339 wdtp0i=0d0
5340 IF(wdtp(0).GT.0d0) wdtp0i=1d0/wdtp(0)
5341 wids(kc,1)=((wdte(0,1)+wdte(0,2))**2+
5342 & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
5343 & 2d0*wdte(0,4)*wdte(0,5))*wdtp0i**2
5344 wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))*wdtp0i
5345 wids(kc,3)=0d0
5346 wids(kc,4)=0d0
5347 wids(kc,5)=0d0
5348 ELSE
5349 IF(mwid(kc).EQ.3) mint(63)=1
5350 CALL pywidt(-kf,pmr**2,wdtpm,wdtem)
5351 mint(51)=0
5352 wdtp0i=0d0
5353 IF(wdtp(0).GT.0d0) wdtp0i=1d0/wdtp(0)
5354 wids(kc,1)=((wdte(0,1)+wdte(0,2))*(wdtem(0,1)+wdtem(0,3))+
5355 & (wdte(0,1)+wdte(0,2))*(wdtem(0,4)+wdtem(0,5))+
5356 & (wdte(0,4)+wdte(0,5))*(wdtem(0,1)+wdtem(0,3))+
5357 & wdte(0,4)*wdtem(0,5)+wdte(0,5)*wdtem(0,4))*wdtp0i**2
5358 wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))*wdtp0i
5359 wids(kc,3)=(wdtem(0,1)+wdtem(0,3)+wdtem(0,4))*wdtp0i
5360 wids(kc,4)=((wdte(0,1)+wdte(0,2))**2+
5361 & 2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+
5362 & 2d0*wdte(0,4)*wdte(0,5))*wdtp0i**2
5363 wids(kc,5)=((wdtem(0,1)+wdtem(0,3))**2+
5364 & 2d0*(wdtem(0,1)+wdtem(0,3))*(wdtem(0,4)+wdtem(0,5))+
5365 & 2d0*wdtem(0,4)*wdtem(0,5))*wdtp0i**2
5366 ENDIF
5367
5368C...Set resonance widths and branching ratios;
5369C...also on/off switch for decays.
5370 IF(mwid(kc).EQ.1.OR.mwid(kc).EQ.3) THEN
5371 pmas(kc,2)=wdtp(0)
5372 pmas(kc,3)=min(0.9d0*pmas(kc,1),10d0*pmas(kc,2))
5373 IF(mstp(41).EQ.0.OR.mstp(41).EQ.1) mdcy(kc,1)=mstp(41)
5374 DO 170 j=1,mdcy(kc,3)
5375 idc=j+mdcy(kc,2)-1
5376 brat(idc)=0d0
5377 IF(wdtp(0).GT.0d0) brat(idc)=wdtp(j)/wdtp(0)
5378 170 CONTINUE
5379 ENDIF
5380 180 CONTINUE
5381
5382C...Flavours of leptoquark: redefine charge and name.
5383 kflqq=kfdp(mdcy(42,2),1)
5384 kflql=kfdp(mdcy(42,2),2)
5385 kchg(42,1)=kchg(pycomp(kflqq),1)*isign(1,kflqq)+
5386 &kchg(pycomp(kflql),1)*isign(1,kflql)
5387 ll=1
5388 IF(iabs(kflql).EQ.13) ll=2
5389 IF(iabs(kflql).EQ.15) ll=3
5390 chaf(42,1)='LQ_'//chaf(iabs(kflqq),1)(1:1)//
5391 &chaf(iabs(kflql),1)(1:ll)//' '
5392 chaf(42,2)=chaf(42,2)(1:4+ll)//'bar '
5393
5394C...Special cases in treatment of gamma*/Z0: redefine process name.
5395 IF(mstp(43).EQ.1) THEN
5396 proc(1)='f + fbar -> gamma*'
5397 proc(15)='f + fbar -> g + gamma*'
5398 proc(19)='f + fbar -> gamma + gamma*'
5399 proc(30)='f + g -> f + gamma*'
5400 proc(35)='f + gamma -> f + gamma*'
5401 ELSEIF(mstp(43).EQ.2) THEN
5402 proc(1)='f + fbar -> Z0'
5403 proc(15)='f + fbar -> g + Z0'
5404 proc(19)='f + fbar -> gamma + Z0'
5405 proc(30)='f + g -> f + Z0'
5406 proc(35)='f + gamma -> f + Z0'
5407 ELSEIF(mstp(43).EQ.3) THEN
5408 proc(1)='f + fbar -> gamma*/Z0'
5409 proc(15)='f + fbar -> g + gamma*/Z0'
5410 proc(19)='f+ fbar -> gamma + gamma*/Z0'
5411 proc(30)='f + g -> f + gamma*/Z0'
5412 proc(35)='f + gamma -> f + gamma*/Z0'
5413 ENDIF
5414
5415C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5416 IF(mstp(44).EQ.1) THEN
5417 proc(141)='f + fbar -> gamma*'
5418 ELSEIF(mstp(44).EQ.2) THEN
5419 proc(141)='f + fbar -> Z0'
5420 ELSEIF(mstp(44).EQ.3) THEN
5421 proc(141)='f + fbar -> Z''0'
5422 ELSEIF(mstp(44).EQ.4) THEN
5423 proc(141)='f + fbar -> gamma*/Z0'
5424 ELSEIF(mstp(44).EQ.5) THEN
5425 proc(141)='f + fbar -> gamma*/Z''0'
5426 ELSEIF(mstp(44).EQ.6) THEN
5427 proc(141)='f + fbar -> Z0/Z''0'
5428 ELSEIF(mstp(44).EQ.7) THEN
5429 proc(141)='f + fbar -> gamma*/Z0/Z''0'
5430 ENDIF
5431
5432C...Special cases in treatment of WW -> WW: redefine process name.
5433 IF(mstp(45).EQ.1) THEN
5434 proc(77)='W+ + W+ -> W+ + W+'
5435 ELSEIF(mstp(45).EQ.2) THEN
5436 proc(77)='W+ + W- -> W+ + W-'
5437 ELSEIF(mstp(45).EQ.3) THEN
5438 proc(77)='W+/- + W+/- -> W+/- + W+/-'
5439 ENDIF
5440
5441C...Format for error information.
5442 5000 FORMAT(1x,'Error: unphysical input tan^2(beta) and m_H ',
5443 &'combination'/1x,'Execution stopped!')
5444
5445 RETURN
5446 END
5447
5448C*********************************************************************
5449
5450C...PYINBM
5451C...Identifies the two incoming particles and the choice of frame.
5452
5453 SUBROUTINE pyinbm(CHFRAM,CHBEAM,CHTARG,WIN)
5454
5455C...Double precision and integer declarations.
5456 IMPLICIT DOUBLE PRECISION(a-h, o-z)
5457 IMPLICIT INTEGER(I-N)
5458 INTEGER PYK,PYCHGE,PYCOMP
5459
5460C...User process initialization commonblock.
5461 INTEGER MAXPUP
5462 parameter(maxpup=100)
5463 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5464 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5465 common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5466 &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5467 &lprup(maxpup)
5468 SAVE /heprup/
5469
5470C...Commonblocks.
5471 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5472 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5473 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5474 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5475 common/pypars/mstp(200),parp(200),msti(200),pari(200)
5476 common/pyint1/mint(400),vint(400)
5477 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
5478
5479C...Local arrays, character variables and data.
5480 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5481 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5482 dimension len(3),kcde(39),pm(2)
5483 DATA chalp/'abcdefghijklmnopqrstuvwxyz',
5484 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5485 DATA chcde/ 'e- ','e+ ','nu_e ',
5486 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5487 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5488 &'nu_taubar ','pi+ ','pi- ','n0 ',
5489 &'nbar0 ','p+ ','pbar- ','gamma ',
5490 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5491 &'xi- ','xi0 ','omega- ','pi0 ',
5492 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5493 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5494 &'k+ ','k- ','ks0 ','kl0 '/
5495 DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5496 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5497 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5498
5499C...Store initial energy. Default frame.
5500 vint(290)=win
5501 mint(111)=0
5502
5503C...Special user process initialization; convert to normal input.
5504 IF(chfram(1:1).EQ.'u'.OR.chfram(1:1).EQ.'U') THEN
5505 mint(111)=11
5506 IF(pdfgup(1).EQ.-9.OR.pdfgup(2).EQ.-9) mint(111)=12
5507 CALL pyname(idbmup(1),chname)
5508 chbeam=chname(1:12)
5509 CALL pyname(idbmup(2),chname)
5510 chtarg=chname(1:12)
5511 ENDIF
5512
5513C...Convert character variables to lowercase and find their length.
5514 chcom(1)=chfram
5515 chcom(2)=chbeam
5516 chcom(3)=chtarg
5517 DO 130 i=1,3
5518 len(i)=12
5519 DO 110 ll=12,1,-1
5520 IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1
5521 DO 100 la=1,26
5522 IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=
5523 & chalp(1)(la:la)
5524 100 CONTINUE
5525 110 CONTINUE
5526 chidnt(i)=chcom(i)
5527
5528C...Fix up bar, underscore and charge in particle name (if needed).
5529 DO 120 ll=1,10
5530 IF(chidnt(i)(ll:ll).EQ.'~') THEN
5531 chtemp=chidnt(i)
5532 chidnt(i)=chtemp(1:ll-1)//'bar'//chtemp(ll+1:10)//' '
5533 ENDIF
5534 120 CONTINUE
5535 IF(chidnt(i)(1:2).EQ.'nu'.AND.chidnt(i)(3:3).NE.'_') THEN
5536 chtemp=chidnt(i)
5537 chidnt(i)='nu_'//chtemp(3:7)
5538 ELSEIF(chidnt(i)(1:2).EQ.'n ') THEN
5539 chidnt(i)(1:3)='n0 '
5540 ELSEIF(chidnt(i)(1:4).EQ.'nbar') THEN
5541 chidnt(i)(1:5)='nbar0'
5542 ELSEIF(chidnt(i)(1:2).EQ.'p ') THEN
5543 chidnt(i)(1:3)='p+ '
5544 ELSEIF(chidnt(i)(1:4).EQ.'pbar'.OR.
5545 & chidnt(i)(1:2).EQ.'p-') THEN
5546 chidnt(i)(1:5)='pbar-'
5547 ELSEIF(chidnt(i)(1:6).EQ.'lambda') THEN
5548 chidnt(i)(7:7)='0'
5549 ELSEIF(chidnt(i)(1:3).EQ.'reg') THEN
5550 chidnt(i)(1:7)='reggeon'
5551 ELSEIF(chidnt(i)(1:3).EQ.'pom') THEN
5552 chidnt(i)(1:7)='pomeron'
5553 ENDIF
5554 130 CONTINUE
5555
5556C...Identify free initialization.
5557 IF(chcom(1)(1:2).EQ.'no') THEN
5558 mint(65)=1
5559 RETURN
5560 ENDIF
5561
5562C...Identify incoming beam and target particles.
5563 DO 160 i=1,2
5564 DO 140 j=1,39
5565 IF(chidnt(i+1).EQ.chcde(j)) mint(10+i)=kcde(j)
5566 140 CONTINUE
5567 pm(i)=pymass(mint(10+i))
5568 vint(2+i)=pm(i)
5569 mint(140+i)=0
5570 IF(mint(10+i).EQ.22.AND.chidnt(i+1)(6:6).EQ.'/') THEN
5571 chtemp=chidnt(i+1)(7:12)//' '
5572 DO 150 j=1,12
5573 IF(chtemp.EQ.chcde(j)) mint(140+i)=kcde(j)
5574 150 CONTINUE
5575 pm(i)=pymass(mint(140+i))
5576 vint(302+i)=pm(i)
5577 ENDIF
5578 160 CONTINUE
5579 IF(mint(11).EQ.0) WRITE(mstu(11),5000) chbeam(1:len(2))
5580 IF(mint(12).EQ.0) WRITE(mstu(11),5100) chtarg(1:len(3))
5581 IF(mint(11).EQ.0.OR.mint(12).EQ.0) CALL pystop(7)
5582
5583C...Identify choice of frame and input energies.
5584 chinit=' '
5585
5586C...Events defined in the CM frame.
5587 IF(chcom(1)(1:2).EQ.'cm') THEN
5588 mint(111)=1
5589 s=win**2
5590 IF(mstp(122).GE.1) THEN
5591 IF(chcom(2)(1:1).NE.'e') THEN
5592 loffs=(31-(len(2)+len(3)))/2
5593 chinit(loffs+1:76)='PYTHIA will be initialized for a '//
5594 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5595 & ' collider'//' '
5596 ELSE
5597 loffs=(30-(len(2)+len(3)))/2
5598 chinit(loffs+1:76)='PYTHIA will be initialized for an '//
5599 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5600 & ' collider'//' '
5601 ENDIF
5602 WRITE(mstu(11),5200) chinit
5603 WRITE(mstu(11),5300) win
5604 ENDIF
5605
5606C...Events defined in fixed target frame.
5607 ELSEIF(chcom(1)(1:3).EQ.'fix') THEN
5608 mint(111)=2
5609 s=pm(1)**2+pm(2)**2+2d0*pm(2)*sqrt(pm(1)**2+win**2)
5610 IF(mstp(122).GE.1) THEN
5611 loffs=(29-(len(2)+len(3)))/2
5612 chinit(loffs+1:76)='PYTHIA will be initialized for '//
5613 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5614 & ' fixed target'//' '
5615 WRITE(mstu(11),5200) chinit
5616 WRITE(mstu(11),5400) win
5617 WRITE(mstu(11),5500) sqrt(s)
5618 ENDIF
5619
5620C...Frame defined by user three-vectors.
5621 ELSEIF(chcom(1)(1:1).EQ.'3') THEN
5622 mint(111)=3
5623 p(1,5)=pm(1)
5624 p(2,5)=pm(2)
5625 p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
5626 p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
5627 s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5628 & (p(1,3)+p(2,3))**2
5629 IF(mstp(122).GE.1) THEN
5630 loffs=(22-(len(2)+len(3)))/2
5631 chinit(loffs+1:76)='PYTHIA will be initialized for '//
5632 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5633 & ' user configuration'//' '
5634 WRITE(mstu(11),5200) chinit
5635 WRITE(mstu(11),5600)
5636 WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5637 WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5638 WRITE(mstu(11),5500) sqrt(max(0d0,s))
5639 ENDIF
5640
5641C...Frame defined by user four-vectors.
5642 ELSEIF(chcom(1)(1:1).EQ.'4') THEN
5643 mint(111)=4
5644 pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
5645 p(1,5)=sign(sqrt(abs(pms1)),pms1)
5646 pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
5647 p(2,5)=sign(sqrt(abs(pms2)),pms2)
5648 s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5649 & (p(1,3)+p(2,3))**2
5650 IF(mstp(122).GE.1) THEN
5651 loffs=(22-(len(2)+len(3)))/2
5652 chinit(loffs+1:76)='PYTHIA will be initialized for '//
5653 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5654 & ' user configuration'//' '
5655 WRITE(mstu(11),5200) chinit
5656 WRITE(mstu(11),5600)
5657 WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5658 WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5659 WRITE(mstu(11),5500) sqrt(max(0d0,s))
5660 ENDIF
5661
5662C...Frame defined by user five-vectors.
5663 ELSEIF(chcom(1)(1:1).EQ.'5') THEN
5664 mint(111)=5
5665 s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-
5666 & (p(1,3)+p(2,3))**2
5667 IF(mstp(122).GE.1) THEN
5668 loffs=(22-(len(2)+len(3)))/2
5669 chinit(loffs+1:76)='PYTHIA will be initialized for '//
5670 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5671 & ' user configuration'//' '
5672 WRITE(mstu(11),5200) chinit
5673 WRITE(mstu(11),5600)
5674 WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)
5675 WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)
5676 WRITE(mstu(11),5500) sqrt(max(0d0,s))
5677 ENDIF
5678
5679C...Frame defined by HEPRUP common block.
5680 ELSEIF(mint(111).GE.11) THEN
5681 s=(ebmup(1)+ebmup(2))**2-(sqrt(max(0d0,ebmup(1)**2-pm(1)**2))-
5682 & sqrt(max(0d0,ebmup(2)**2-pm(2)**2)))**2
5683 IF(mstp(122).GE.1) THEN
5684 loffs=(22-(len(2)+len(3)))/2
5685 chinit(loffs+1:76)='PYTHIA will be initialized for '//
5686 & chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//
5687 & ' user configuration'//' '
5688 WRITE(mstu(11),5200) chinit
5689 WRITE(mstu(11),6000) ebmup(1),ebmup(2)
5690 WRITE(mstu(11),5500) sqrt(max(0d0,s))
5691 ENDIF
5692
5693C...Unknown frame. Error for too low CM energy.
5694 ELSE
5695 WRITE(mstu(11),5800) chfram(1:len(1))
5696 CALL pystop(7)
5697 ENDIF
5698 IF(s.LT.parp(2)**2) THEN
5699 WRITE(mstu(11),5900) sqrt(s)
5700 CALL pystop(7)
5701 ENDIF
5702
5703C...Formats for initialization and error information.
5704 5000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''D0'/
5705 &1x,'Execution stopped!')
5706 5100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''D0'/
5707 &1x,'Execution stopped!')
5708 5200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I')
5709 5300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',
5710 &19x,'I'/1x,'I',76x,'I'/1x,78('='))
5711 5400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')
5712 5500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,
5713 &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))
5714 5600 FORMAT(1x,'I',76x,'I'/1x,'I',18x,'px (GeV/c)',3x,'py (GeV/c)',3x,
5715 &'pz (GeV/c)',6x,'E (GeV)',9x,'I')
5716 5700 FORMAT(1x,'I',8x,a8,4(2x,f10.3,1x),8x,'I')
5717 5800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''D0'/
5718 &1x,'Execution stopped!')
5719 5900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ',
5720 &'generation.'/1x,'Execution stopped!')
5721 6000 FORMAT(1x,'I',12x,'with',1x,f10.3,1x,'GeV on',1x,f10.3,1x,
5722 &'GeV beam energies',13x,'I')
5723
5724 RETURN
5725 END
5726
5727C*********************************************************************
5728
5729C...PYINKI
5730C...Sets up kinematics, including rotations and boosts to/from CM frame.
5731
5732 SUBROUTINE pyinki(MODKI)
5733
5734C...Double precision and integer declarations.
5735 IMPLICIT DOUBLE PRECISION(a-h, o-z)
5736 IMPLICIT INTEGER(I-N)
5737 INTEGER PYK,PYCHGE,PYCOMP
5738
5739C...User process initialization commonblock.
5740 INTEGER MAXPUP
5741 parameter(maxpup=100)
5742 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5743 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5744 common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5745 &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5746 &lprup(maxpup)
5747 SAVE /heprup/
5748
5749C...Commonblocks.
5750 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
5751 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5752 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
5753 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5754 common/pypars/mstp(200),parp(200),msti(200),pari(200)
5755 common/pyint1/mint(400),vint(400)
5756 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
5757
5758C...Set initial flavour state.
5759 n=2
5760 DO 100 i=1,2
5761 k(i,1)=1
5762 k(i,2)=mint(10+i)
5763 IF(mint(140+i).NE.0) k(i,2)=mint(140+i)
5764 100 CONTINUE
5765
5766C...Reset boost. Do kinematics for various cases.
5767 DO 110 j=6,10
5768 vint(j)=0d0
5769 110 CONTINUE
5770
5771C...Set up kinematics for events defined in CM frame.
5772 IF(mint(111).EQ.1) THEN
5773 win=vint(290)
5774 IF(modki.EQ.1) win=parp(171)*vint(290)
5775 s=win**2
5776 p(1,5)=vint(3)
5777 p(2,5)=vint(4)
5778 IF(mint(141).NE.0) p(1,5)=vint(303)
5779 IF(mint(142).NE.0) p(2,5)=vint(304)
5780 p(1,1)=0d0
5781 p(1,2)=0d0
5782 p(2,1)=0d0
5783 p(2,2)=0d0
5784 p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2d0*p(1,5)*p(2,5))**2)/
5785 & (4d0*s))
5786 p(2,3)=-p(1,3)
5787 p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
5788 p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)
5789
5790C...Set up kinematics for fixed target events.
5791 ELSEIF(mint(111).EQ.2) THEN
5792 win=vint(290)
5793 IF(modki.EQ.1) win=parp(171)*vint(290)
5794 p(1,5)=vint(3)
5795 p(2,5)=vint(4)
5796 IF(mint(141).NE.0) p(1,5)=vint(303)
5797 IF(mint(142).NE.0) p(2,5)=vint(304)
5798 p(1,1)=0d0
5799 p(1,2)=0d0
5800 p(2,1)=0d0
5801 p(2,2)=0d0
5802 p(1,3)=win
5803 p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)
5804 p(2,3)=0d0
5805 p(2,4)=p(2,5)
5806 s=p(1,5)**2+p(2,5)**2+2d0*p(2,4)*p(1,4)
5807 vint(10)=p(1,3)/(p(1,4)+p(2,4))
5808 CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))
5809
5810C...Set up kinematics for events in user-defined frame.
5811 ELSEIF(mint(111).EQ.3) THEN
5812 p(1,5)=vint(3)
5813 p(2,5)=vint(4)
5814 IF(mint(141).NE.0) p(1,5)=vint(303)
5815 IF(mint(142).NE.0) p(2,5)=vint(304)
5816 p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)
5817 p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)
5818 DO 120 j=1,3
5819 vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5820 120 CONTINUE
5821 CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5822 vint(7)=pyangl(p(1,1),p(1,2))
5823 CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5824 vint(6)=pyangl(p(1,3),p(1,1))
5825 CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5826 s=p(1,5)**2+p(2,5)**2+2d0*(p(1,4)*p(2,4)-p(1,3)*p(2,3))
5827
5828C...Set up kinematics for events with user-defined four-vectors.
5829 ELSEIF(mint(111).EQ.4) THEN
5830 pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2
5831 p(1,5)=sign(sqrt(abs(pms1)),pms1)
5832 pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2
5833 p(2,5)=sign(sqrt(abs(pms2)),pms2)
5834 DO 130 j=1,3
5835 vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5836 130 CONTINUE
5837 CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5838 vint(7)=pyangl(p(1,1),p(1,2))
5839 CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5840 vint(6)=pyangl(p(1,3),p(1,1))
5841 CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5842 s=(p(1,4)+p(2,4))**2
5843
5844C...Set up kinematics for events with user-defined five-vectors.
5845 ELSEIF(mint(111).EQ.5) THEN
5846 DO 140 j=1,3
5847 vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))
5848 140 CONTINUE
5849 CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
5850 vint(7)=pyangl(p(1,1),p(1,2))
5851 CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
5852 vint(6)=pyangl(p(1,3),p(1,1))
5853 CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
5854 s=(p(1,4)+p(2,4))**2
5855
5856C...Set up kinematics for events with external user processes.
5857 ELSEIF(mint(111).GE.11) THEN
5858 p(1,5)=vint(3)
5859 p(2,5)=vint(4)
5860 IF(mint(141).NE.0) p(1,5)=vint(303)
5861 IF(mint(142).NE.0) p(2,5)=vint(304)
5862 p(1,1)=0d0
5863 p(1,2)=0d0
5864 p(2,1)=0d0
5865 p(2,2)=0d0
5866 p(1,3)=sqrt(max(0d0,ebmup(1)**2-p(1,5)**2))
5867 p(2,3)=-sqrt(max(0d0,ebmup(2)**2-p(2,5)**2))
5868 p(1,4)=ebmup(1)
5869 p(2,4)=ebmup(2)
5870 vint(10)=(p(1,3)+p(2,3))/(p(1,4)+p(2,4))
5871 CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))
5872 s=(p(1,4)+p(2,4))**2
5873 ENDIF
5874
5875C...Return or error for too low CM energy.
5876 IF(modki.EQ.1.AND.s.LT.parp(2)**2) THEN
5877 IF(mstp(172).LE.1) THEN
5878 CALL pyerrm(23,
5879 & '(PYINKI:) too low invariant mass in this event')
5880 ELSE
5881 msti(61)=1
5882 RETURN
5883 ENDIF
5884 ENDIF
5885
5886C...Save information on incoming particles.
5887 vint(1)=sqrt(s)
5888 vint(2)=s
5889 IF(mint(111).GE.4) THEN
5890 IF(mint(141).EQ.0) THEN
5891 vint(3)=p(1,5)
5892 IF(mint(11).EQ.22.AND.p(1,5).LT.0) vint(307)=p(1,5)**2
5893 ELSE
5894 vint(303)=p(1,5)
5895 ENDIF
5896 IF(mint(142).EQ.0) THEN
5897 vint(4)=p(2,5)
5898 IF(mint(12).EQ.22.AND.p(2,5).LT.0) vint(308)=p(2,5)**2
5899 ELSE
5900 vint(304)=p(2,5)
5901 ENDIF
5902 ENDIF
5903 vint(5)=p(1,3)
5904 IF(modki.EQ.0) vint(289)=s
5905 DO 150 j=1,5
5906 v(1,j)=0d0
5907 v(2,j)=0d0
5908 vint(290+j)=p(1,j)
5909 vint(295+j)=p(2,j)
5910 150 CONTINUE
5911
5912C...Store pT cut-off and related constants to be used in generation.
5913 IF(modki.EQ.0) vint(285)=ckin(3)
5914 IF(mstp(82).LE.1) THEN
5915 ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
5916 ELSE
5917 ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
5918 ENDIF
5919 vint(149)=4d0*ptmn**2/s
5920 vint(154)=ptmn
5921
5922 RETURN
5923 END
5924
5925C*********************************************************************
5926
5927C...PYINPR
5928C...Selects partonic subprocesses to be included in the simulation.
5929
5930 SUBROUTINE pyinpr
5931
5932C...Double precision and integer declarations.
5933 IMPLICIT DOUBLE PRECISION(a-h, o-z)
5934 IMPLICIT INTEGER(I-N)
5935 INTEGER PYK,PYCHGE,PYCOMP
5936
5937C...User process initialization commonblock.
5938 INTEGER MAXPUP
5939 parameter(maxpup=100)
5940 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5941 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5942 common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
5943 &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
5944 &lprup(maxpup)
5945 SAVE /heprup/
5946
5947C...Commonblocks and character variables.
5948 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5949 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
5950 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
5951 common/pypars/mstp(200),parp(200),msti(200),pari(200)
5952 common/pyint1/mint(400),vint(400)
5953 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
5954 common/pyint6/proc(0:500)
5955 CHARACTER PROC*28
5956 SAVE /pydat1/,/pydat3/,/pysubs/,/pypars/,/pyint1/,/pyint2/,
5957 &/pyint6/
5958 CHARACTER CHIPR*10
5959
5960C...Reset processes to be included.
5961 IF(msel.NE.0) THEN
5962 DO 100 i=1,500
5963 msub(i)=0
5964 100 CONTINUE
5965 ENDIF
5966
5967C...Set running pTmin scale.
5968 IF(mstp(82).LE.1) THEN
5969 ptmrun=parp(81)*(vint(1)/parp(89))**parp(90)
5970 ELSE
5971 ptmrun=parp(82)*(vint(1)/parp(89))**parp(90)
5972 ENDIF
5973
5974C...Begin by assuming incoming photon to enter subprocess.
5975 IF(mint(11).EQ.22) mint(15)=22
5976 IF(mint(12).EQ.22) mint(16)=22
5977
5978C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5979 IF(mint(121).EQ.2.AND.mstp(14).EQ.10) THEN
5980 msub(10)=1
5981 mint(123)=mint(122)+1
5982
5983C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5984C...allow mixture.
5985C...Here also set a few parameters otherwise normally not touched.
5986 ELSEIF(mint(121).GT.1) THEN
5987
5988C...Parton distributions dampened at small Q2; go to low energies,
5989C...alpha_s <1; no minimum pT cut-off a priori.
5990 IF(mstp(18).EQ.2) THEN
5991 mstp(57)=3
5992 parp(2)=2d0
5993 paru(115)=1d0
5994 ckin(5)=0.2d0
5995 ckin(6)=0.2d0
5996 ENDIF
5997
5998C...Define pT cut-off parameters and whether run involves low-pT.
5999 ptmvmd=ptmrun
6000 vint(154)=ptmvmd
6001 ptmdir=ptmvmd
6002 IF(mstp(18).EQ.2) ptmdir=parp(15)
6003 ptmano=ptmvmd
6004 IF(mstp(15).EQ.5) ptmano=0.60d0+
6005 & 0.125d0*log(1d0+0.10d0*vint(1))**2
6006 iptl=1
6007 IF(vint(285).GT.max(ptmvmd,ptmdir,ptmano)) iptl=0
6008 IF(msel.EQ.2) iptl=1
6009
6010C...Set up for p/gamma * gamma; real or virtual photons.
6011 IF(mint(121).EQ.3.OR.mint(121).EQ.6.OR.(mint(121).EQ.4.AND.
6012 & mstp(14).EQ.30)) THEN
6013
6014C...Set up for p/VMD * VMD.
6015 IF(mint(122).EQ.1) THEN
6016 mint(123)=2
6017 msub(11)=1
6018 msub(12)=1
6019 msub(13)=1
6020 msub(28)=1
6021 msub(53)=1
6022 msub(68)=1
6023 IF(iptl.EQ.1) msub(95)=1
6024 IF(msel.EQ.2) THEN
6025 msub(91)=1
6026 msub(92)=1
6027 msub(93)=1
6028 msub(94)=1
6029 ENDIF
6030 IF(iptl.EQ.1) ckin(3)=0d0
6031
6032C...Set up for p/VMD * direct gamma.
6033 ELSEIF(mint(122).EQ.2) THEN
6034 mint(123)=0
6035 IF(mint(121).EQ.6) mint(123)=5
6036 msub(131)=1
6037 msub(132)=1
6038 msub(135)=1
6039 msub(136)=1
6040 IF(iptl.EQ.1) ckin(3)=ptmdir
6041
6042C...Set up for p/VMD * anomalous gamma.
6043 ELSEIF(mint(122).EQ.3) THEN
6044 mint(123)=3
6045 IF(mint(121).EQ.6) mint(123)=7
6046 msub(11)=1
6047 msub(12)=1
6048 msub(13)=1
6049 msub(28)=1
6050 msub(53)=1
6051 msub(68)=1
6052 IF(iptl.EQ.1) msub(95)=1
6053 IF(msel.EQ.2) THEN
6054 msub(91)=1
6055 msub(92)=1
6056 msub(93)=1
6057 msub(94)=1
6058 ENDIF
6059 IF(iptl.EQ.1) ckin(3)=0d0
6060
6061C...Set up for DIS * p.
6062 ELSEIF(mint(122).EQ.4.AND.(iabs(mint(11)).GT.100.OR.
6063 & iabs(mint(12)).GT.100)) THEN
6064 mint(123)=8
6065 IF(iptl.EQ.1) msub(99)=1
6066
6067C...Set up for direct * direct gamma (switch off leptons).
6068 ELSEIF(mint(122).EQ.4) THEN
6069 mint(123)=0
6070 msub(137)=1
6071 msub(138)=1
6072 msub(139)=1
6073 msub(140)=1
6074 DO 110 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6075 IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6076 110 CONTINUE
6077 IF(iptl.EQ.1) ckin(3)=ptmdir
6078
6079C...Set up for direct * anomalous gamma.
6080 ELSEIF(mint(122).EQ.5) THEN
6081 mint(123)=6
6082 msub(131)=1
6083 msub(132)=1
6084 msub(135)=1
6085 msub(136)=1
6086 IF(iptl.EQ.1) ckin(3)=ptmano
6087
6088C...Set up for anomalous * anomalous gamma.
6089 ELSEIF(mint(122).EQ.6) THEN
6090 mint(123)=3
6091 msub(11)=1
6092 msub(12)=1
6093 msub(13)=1
6094 msub(28)=1
6095 msub(53)=1
6096 msub(68)=1
6097 IF(iptl.EQ.1) msub(95)=1
6098 IF(msel.EQ.2) THEN
6099 msub(91)=1
6100 msub(92)=1
6101 msub(93)=1
6102 msub(94)=1
6103 ENDIF
6104 IF(iptl.EQ.1) ckin(3)=0d0
6105 ENDIF
6106
6107C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6108 ELSEIF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
6109
6110C...Set up for direct * direct gamma (switch off leptons).
6111 IF(mint(122).EQ.1) THEN
6112 mint(123)=0
6113 msub(137)=1
6114 msub(138)=1
6115 msub(139)=1
6116 msub(140)=1
6117 DO 120 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6118 IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6119 120 CONTINUE
6120 IF(iptl.EQ.1) ckin(3)=ptmdir
6121
6122C...Set up for direct * VMD and VMD * direct gamma.
6123 ELSEIF(mint(122).EQ.2.OR.mint(122).EQ.4) THEN
6124 mint(123)=5
6125 msub(131)=1
6126 msub(132)=1
6127 msub(135)=1
6128 msub(136)=1
6129 IF(iptl.EQ.1) ckin(3)=ptmdir
6130
6131C...Set up for direct * anomalous and anomalous * direct gamma.
6132 ELSEIF(mint(122).EQ.3.OR.mint(122).EQ.7) THEN
6133 mint(123)=6
6134 msub(131)=1
6135 msub(132)=1
6136 msub(135)=1
6137 msub(136)=1
6138 IF(iptl.EQ.1) ckin(3)=ptmano
6139
6140C...Set up for VMD*VMD.
6141 ELSEIF(mint(122).EQ.5) THEN
6142 mint(123)=2
6143 msub(11)=1
6144 msub(12)=1
6145 msub(13)=1
6146 msub(28)=1
6147 msub(53)=1
6148 msub(68)=1
6149 IF(iptl.EQ.1) msub(95)=1
6150 IF(msel.EQ.2) THEN
6151 msub(91)=1
6152 msub(92)=1
6153 msub(93)=1
6154 msub(94)=1
6155 ENDIF
6156 IF(iptl.EQ.1) ckin(3)=0d0
6157
6158C...Set up for VMD * anomalous and anomalous * VMD gamma.
6159 ELSEIF(mint(122).EQ.6.OR.mint(122).EQ.8) THEN
6160 mint(123)=7
6161 msub(11)=1
6162 msub(12)=1
6163 msub(13)=1
6164 msub(28)=1
6165 msub(53)=1
6166 msub(68)=1
6167 IF(iptl.EQ.1) msub(95)=1
6168 IF(msel.EQ.2) THEN
6169 msub(91)=1
6170 msub(92)=1
6171 msub(93)=1
6172 msub(94)=1
6173 ENDIF
6174 IF(iptl.EQ.1) ckin(3)=0d0
6175
6176C...Set up for anomalous * anomalous gamma.
6177 ELSEIF(mint(122).EQ.9) THEN
6178 mint(123)=3
6179 msub(11)=1
6180 msub(12)=1
6181 msub(13)=1
6182 msub(28)=1
6183 msub(53)=1
6184 msub(68)=1
6185 IF(iptl.EQ.1) msub(95)=1
6186 IF(msel.EQ.2) THEN
6187 msub(91)=1
6188 msub(92)=1
6189 msub(93)=1
6190 msub(94)=1
6191 ENDIF
6192 IF(iptl.EQ.1) ckin(3)=0d0
6193
6194C...Set up for DIS * VMD and VMD * DIS gamma.
6195 ELSEIF(mint(122).EQ.10.OR.mint(122).EQ.12) THEN
6196 mint(123)=8
6197 IF(iptl.EQ.1) msub(99)=1
6198
6199C...Set up for DIS * anomalous and anomalous * DIS gamma.
6200 ELSEIF(mint(122).EQ.11.OR.mint(122).EQ.13) THEN
6201 mint(123)=9
6202 IF(iptl.EQ.1) msub(99)=1
6203 ENDIF
6204
6205C...Set up for gamma* * p; virtual photons = dir, res.
6206 ELSEIF(mint(121).EQ.2) THEN
6207
6208C...Set up for direct * p.
6209 IF(mint(122).EQ.1) THEN
6210 mint(123)=0
6211 msub(131)=1
6212 msub(132)=1
6213 msub(135)=1
6214 msub(136)=1
6215 IF(iptl.EQ.1) ckin(3)=ptmdir
6216
6217C...Set up for resolved * p.
6218 ELSEIF(mint(122).EQ.2) THEN
6219 mint(123)=1
6220 msub(11)=1
6221 msub(12)=1
6222 msub(13)=1
6223 msub(28)=1
6224 msub(53)=1
6225 msub(68)=1
6226 IF(iptl.EQ.1) msub(95)=1
6227 IF(msel.EQ.2) THEN
6228 msub(91)=1
6229 msub(92)=1
6230 msub(93)=1
6231 msub(94)=1
6232 ENDIF
6233 IF(iptl.EQ.1) ckin(3)=0d0
6234 ENDIF
6235
6236C...Set up for gamma* * gamma*; virtual photons = dir, res.
6237 ELSEIF(mint(121).EQ.4) THEN
6238
6239C...Set up for direct * direct gamma (switch off leptons).
6240 IF(mint(122).EQ.1) THEN
6241 mint(123)=0
6242 msub(137)=1
6243 msub(138)=1
6244 msub(139)=1
6245 msub(140)=1
6246 DO 130 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6247 IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6248 130 CONTINUE
6249 IF(iptl.EQ.1) ckin(3)=ptmdir
6250
6251C...Set up for direct * resolved and resolved * direct gamma.
6252 ELSEIF(mint(122).EQ.2.OR.mint(122).EQ.3) THEN
6253 mint(123)=5
6254 msub(131)=1
6255 msub(132)=1
6256 msub(135)=1
6257 msub(136)=1
6258 IF(iptl.EQ.1) ckin(3)=ptmdir
6259
6260C...Set up for resolved * resolved gamma.
6261 ELSEIF(mint(122).EQ.4) THEN
6262 mint(123)=2
6263 msub(11)=1
6264 msub(12)=1
6265 msub(13)=1
6266 msub(28)=1
6267 msub(53)=1
6268 msub(68)=1
6269 IF(iptl.EQ.1) msub(95)=1
6270 IF(msel.EQ.2) THEN
6271 msub(91)=1
6272 msub(92)=1
6273 msub(93)=1
6274 msub(94)=1
6275 ENDIF
6276 IF(iptl.EQ.1) ckin(3)=0d0
6277 ENDIF
6278
6279C...End of special set up for gamma-p and gamma-gamma.
6280 ENDIF
6281 ckin(1)=2d0*ckin(3)
6282 ENDIF
6283
6284C...Flavour information for individual beams.
6285 DO 140 i=1,2
6286 mint(40+i)=1
6287 IF(mint(123).GE.1.AND.mint(10+i).EQ.22) mint(40+i)=2
6288 IF(iabs(mint(10+i)).GT.100) mint(40+i)=2
6289 mint(44+i)=mint(40+i)
6290 IF(mstp(11).GE.1.AND.(iabs(mint(10+i)).EQ.11.OR.
6291 & iabs(mint(10+i)).EQ.13.OR.iabs(mint(10+i)).EQ.15)) mint(44+i)=3
6292 140 CONTINUE
6293
6294C...If two real gammas, whereof one direct, pick the first.
6295C...For two virtual photons, keep requested order.
6296 IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
6297 IF(mstp(14).LE.10.AND.mint(123).GE.4.AND.mint(123).LE.6) THEN
6298 mint(41)=1
6299 mint(45)=1
6300 ELSEIF(mstp(14).EQ.12.OR.mstp(14).EQ.13.OR.mstp(14).EQ.22.OR.
6301 & mstp(14).EQ.26.OR.mstp(14).EQ.27) THEN
6302 mint(41)=1
6303 mint(45)=1
6304 ELSEIF(mstp(14).EQ.14.OR.mstp(14).EQ.17.OR.mstp(14).EQ.23.OR.
6305 & mstp(14).EQ.28.OR.mstp(14).EQ.29) THEN
6306 mint(42)=1
6307 mint(46)=1
6308 ELSEIF((mstp(14).EQ.20.OR.mstp(14).EQ.30).AND.(mint(122).EQ.2
6309 & .OR.mint(122).EQ.3.OR.mint(122).EQ.10.OR.mint(122).EQ.11)) THEN
6310 mint(41)=1
6311 mint(45)=1
6312 ELSEIF((mstp(14).EQ.20.OR.mstp(14).EQ.30).AND.(mint(122).EQ.4
6313 & .OR.mint(122).EQ.7.OR.mint(122).EQ.12.OR.mint(122).EQ.13)) THEN
6314 mint(42)=1
6315 mint(46)=1
6316 ELSEIF(mstp(14).EQ.25.AND.mint(122).EQ.2) THEN
6317 mint(41)=1
6318 mint(45)=1
6319 ELSEIF(mstp(14).EQ.25.AND.mint(122).EQ.3) THEN
6320 mint(42)=1
6321 mint(46)=1
6322 ENDIF
6323 ELSEIF(mint(11).EQ.22.OR.mint(12).EQ.22) THEN
6324 IF(mstp(14).EQ.26.OR.mstp(14).EQ.28.OR.mint(122).EQ.4) THEN
6325 IF(mint(11).EQ.22) THEN
6326 mint(41)=1
6327 mint(45)=1
6328 ELSE
6329 mint(42)=1
6330 mint(46)=1
6331 ENDIF
6332 ENDIF
6333 IF(mint(123).GE.4.AND.mint(123).LE.7) CALL pyerrm(26,
6334 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6335 ENDIF
6336
6337C...Flavour information on combination of incoming particles.
6338 mint(43)=2*mint(41)+mint(42)-2
6339 mint(44)=mint(43)
6340 IF(mint(123).LE.0) THEN
6341 IF(mint(11).EQ.22) mint(43)=mint(43)+2
6342 IF(mint(12).EQ.22) mint(43)=mint(43)+1
6343 ELSEIF(mint(123).LE.3) THEN
6344 IF(mint(11).EQ.22) mint(44)=mint(44)-2
6345 IF(mint(12).EQ.22) mint(44)=mint(44)-1
6346 ELSEIF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
6347 mint(43)=4
6348 mint(44)=1
6349 ENDIF
6350 mint(47)=2*min(2,mint(45))+min(2,mint(46))-2
6351 IF(min(mint(45),mint(46)).EQ.3) mint(47)=5
6352 IF(mint(45).EQ.1.AND.mint(46).EQ.3) mint(47)=6
6353 IF(mint(45).EQ.3.AND.mint(46).EQ.1) mint(47)=7
6354 mint(50)=0
6355 IF(mint(41).EQ.2.AND.mint(42).EQ.2.AND.mint(111).NE.12) mint(50)=1
6356 mint(107)=0
6357 mint(108)=0
6358 IF(mint(121).EQ.9.OR.mint(121).EQ.13) THEN
6359 IF((mint(122).GE.4.AND.mint(122).LE.6).OR.mint(122).EQ.12)
6360 & mint(107)=2
6361 IF((mint(122).GE.7.AND.mint(122).LE.9).OR.mint(122).EQ.13)
6362 & mint(107)=3
6363 IF(mint(122).EQ.10.OR.mint(122).EQ.11) mint(107)=4
6364 IF(mint(122).EQ.2.OR.mint(122).EQ.5.OR.mint(122).EQ.8.OR.
6365 & mint(122).EQ.10) mint(108)=2
6366 IF(mint(122).EQ.3.OR.mint(122).EQ.6.OR.mint(122).EQ.9.OR.
6367 & mint(122).EQ.11) mint(108)=3
6368 IF(mint(122).EQ.12.OR.mint(122).EQ.13) mint(108)=4
6369 ELSEIF(mint(121).EQ.4.AND.mstp(14).EQ.25) THEN
6370 IF(mint(122).GE.3) mint(107)=1
6371 IF(mint(122).EQ.2.OR.mint(122).EQ.4) mint(108)=1
6372 ELSEIF(mint(121).EQ.2) THEN
6373 IF(mint(122).EQ.2.AND.mint(11).EQ.22) mint(107)=1
6374 IF(mint(122).EQ.2.AND.mint(12).EQ.22) mint(108)=1
6375 ELSE
6376 IF(mint(11).EQ.22) THEN
6377 mint(107)=mint(123)
6378 IF(mint(123).GE.4) mint(107)=0
6379 IF(mint(123).EQ.7) mint(107)=2
6380 IF(mstp(14).EQ.26.OR.mstp(14).EQ.27) mint(107)=4
6381 IF(mstp(14).EQ.28) mint(107)=2
6382 IF(mstp(14).EQ.29) mint(107)=3
6383 IF(mstp(14).EQ.30.AND.mint(121).EQ.4.AND.mint(122).EQ.4)
6384 & mint(107)=4
6385 ENDIF
6386 IF(mint(12).EQ.22) THEN
6387 mint(108)=mint(123)
6388 IF(mint(123).GE.4) mint(108)=mint(123)-3
6389 IF(mint(123).EQ.7) mint(108)=3
6390 IF(mstp(14).EQ.26) mint(108)=2
6391 IF(mstp(14).EQ.27) mint(108)=3
6392 IF(mstp(14).EQ.28.OR.mstp(14).EQ.29) mint(108)=4
6393 IF(mstp(14).EQ.30.AND.mint(121).EQ.4.AND.mint(122).EQ.4)
6394 & mint(108)=4
6395 ENDIF
6396 IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.(mstp(14).EQ.14.OR.
6397 & mstp(14).EQ.17.OR.mstp(14).EQ.18.OR.mstp(14).EQ.23)) THEN
6398 minttp=mint(107)
6399 mint(107)=mint(108)
6400 mint(108)=minttp
6401 ENDIF
6402 ENDIF
6403 IF(mint(15).EQ.22.AND.mint(41).EQ.2) mint(15)=0
6404 IF(mint(16).EQ.22.AND.mint(42).EQ.2) mint(16)=0
6405
6406C...Select default processes according to incoming beams
6407C...(already done for gamma-p and gamma-gamma with
6408C...MSTP(14) = 10, 20, 25 or 30).
6409 IF(mint(121).GT.1) THEN
6410 ELSEIF(msel.EQ.1.OR.msel.EQ.2) THEN
6411
6412 IF(mint(43).EQ.1) THEN
6413C...Lepton + lepton -> gamma/Z0 or W.
6414 IF(mint(11)+mint(12).EQ.0) msub(1)=1
6415 IF(mint(11)+mint(12).NE.0) msub(2)=1
6416
6417 ELSEIF(mint(43).LE.3.AND.mint(123).EQ.0.AND.
6418 & (mint(11).EQ.22.OR.mint(12).EQ.22)) THEN
6419C...Unresolved photon + lepton: Compton scattering.
6420 msub(133)=1
6421 msub(134)=1
6422
6423 ELSEIF((mint(123).EQ.8.OR.mint(123).EQ.9).AND.(mint(11).EQ.22
6424 & .OR.mint(12).EQ.22)) THEN
6425C...DIS as pure gamma* + f -> f process.
6426 msub(99)=1
6427
6428 ELSEIF(mint(43).LE.3) THEN
6429C...Lepton + hadron: deep inelastic scattering.
6430 msub(10)=1
6431
6432 ELSEIF(mint(123).EQ.0.AND.mint(11).EQ.22.AND.
6433 & mint(12).EQ.22) THEN
6434C...Two unresolved photons: fermion pair production,
6435C...exclude lepton pairs.
6436 DO 150 isub=137,140
6437 msub(isub)=1
6438 150 CONTINUE
6439 DO 160 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1
6440 IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))
6441 160 CONTINUE
6442 ptmdir=ptmrun
6443 IF(mstp(18).EQ.2) ptmdir=parp(15)
6444 IF(ckin(3).LT.ptmrun.OR.msel.EQ.2) ckin(3)=ptmdir
6445 ckin(1)=max(ckin(1),2d0*ckin(3))
6446
6447 ELSEIF((mint(123).EQ.0.AND.(mint(11).EQ.22.OR.mint(12).EQ.22))
6448 & .OR.(mint(123).GE.4.AND.mint(123).LE.6.AND.mint(11).EQ.22.AND.
6449 & mint(12).EQ.22)) THEN
6450C...Unresolved photon + hadron: photon-parton scattering.
6451 DO 170 isub=131,136
6452 msub(isub)=1
6453 170 CONTINUE
6454
6455 ELSEIF(msel.EQ.1) THEN
6456C...High-pT QCD processes:
6457 msub(11)=1
6458 msub(12)=1
6459 msub(13)=1
6460 msub(28)=1
6461 msub(53)=1
6462 msub(68)=1
6463 ptmn=ptmrun
6464 vint(154)=ptmn
6465 IF(ckin(3).LT.ptmn) msub(95)=1
6466 IF(msub(95).EQ.1.AND.mint(50).EQ.0) msub(95)=0
6467
6468 ELSE
6469C...All QCD processes:
6470 msub(11)=1
6471 msub(12)=1
6472 msub(13)=1
6473 msub(28)=1
6474 msub(53)=1
6475 msub(68)=1
6476 msub(91)=1
6477 msub(92)=1
6478 msub(93)=1
6479 msub(94)=1
6480 msub(95)=1
6481 ENDIF
6482
6483 ELSEIF(msel.GE.4.AND.msel.LE.8) THEN
6484C...Heavy quark production.
6485 msub(81)=1
6486 msub(82)=1
6487 msub(84)=1
6488 DO 180 j=1,min(8,mdcy(21,3))
6489 mdme(mdcy(21,2)+j-1,1)=0
6490 180 CONTINUE
6491 mdme(mdcy(21,2)+msel-1,1)=1
6492 msub(85)=1
6493 DO 190 j=1,min(12,mdcy(22,3))
6494 mdme(mdcy(22,2)+j-1,1)=0
6495 190 CONTINUE
6496 mdme(mdcy(22,2)+msel-1,1)=1
6497
6498 ELSEIF(msel.EQ.10) THEN
6499C...Prompt photon production:
6500 msub(14)=1
6501 msub(18)=1
6502 msub(29)=1
6503
6504 ELSEIF(msel.EQ.11) THEN
6505C...Z0/gamma* production:
6506 msub(1)=1
6507
6508 ELSEIF(msel.EQ.12) THEN
6509C...W+/- production:
6510 msub(2)=1
6511
6512 ELSEIF(msel.EQ.13) THEN
6513C...Z0 + jet:
6514 msub(15)=1
6515 msub(30)=1
6516
6517 ELSEIF(msel.EQ.14) THEN
6518C...W+/- + jet:
6519 msub(16)=1
6520 msub(31)=1
6521
6522 ELSEIF(msel.EQ.15) THEN
6523C...Z0 & W+/- pair production:
6524 msub(19)=1
6525 msub(20)=1
6526 msub(22)=1
6527 msub(23)=1
6528 msub(25)=1
6529
6530 ELSEIF(msel.EQ.16) THEN
6531C...h0 production:
6532 msub(3)=1
6533 msub(102)=1
6534 msub(103)=1
6535 msub(123)=1
6536 msub(124)=1
6537
6538 ELSEIF(msel.EQ.17) THEN
6539C...h0 & Z0 or W+/- pair production:
6540 msub(24)=1
6541 msub(26)=1
6542
6543 ELSEIF(msel.EQ.18) THEN
6544C...h0 production; interesting processes in e+e-.
6545 msub(24)=1
6546 msub(103)=1
6547 msub(123)=1
6548 msub(124)=1
6549
6550 ELSEIF(msel.EQ.19) THEN
6551C...h0, H0 and A0 production; interesting processes in e+e-.
6552 msub(24)=1
6553 msub(103)=1
6554 msub(123)=1
6555 msub(124)=1
6556 msub(153)=1
6557 msub(171)=1
6558 msub(173)=1
6559 msub(174)=1
6560 msub(158)=1
6561 msub(176)=1
6562 msub(178)=1
6563 msub(179)=1
6564
6565 ELSEIF(msel.EQ.21) THEN
6566C...Z'0 production:
6567 msub(141)=1
6568
6569 ELSEIF(msel.EQ.22) THEN
6570C...W'+/- production:
6571 msub(142)=1
6572
6573 ELSEIF(msel.EQ.23) THEN
6574C...H+/- production:
6575 msub(143)=1
6576
6577 ELSEIF(msel.EQ.24) THEN
6578C...R production:
6579 msub(144)=1
6580
6581 ELSEIF(msel.EQ.25) THEN
6582C...LQ (leptoquark) production.
6583 msub(145)=1
6584 msub(162)=1
6585 msub(163)=1
6586 msub(164)=1
6587
6588 ELSEIF(msel.GE.35.AND.msel.LE.38) THEN
6589C...Production of one heavy quark (W exchange):
6590 msub(83)=1
6591 DO 200 j=1,min(8,mdcy(21,3))
6592 mdme(mdcy(21,2)+j-1,1)=0
6593 200 CONTINUE
6594 mdme(mdcy(21,2)+msel-31,1)=1
6595
6596CMRENNA++Define SUSY alternatives.
6597 ELSEIF(msel.EQ.39) THEN
6598C...Turn on all SUSY processes.
6599 IF(mint(43).EQ.4) THEN
6600C...Hadron-hadron processes.
6601 DO 210 i=201,301
6602 IF(iset(i).GE.0) msub(i)=1
6603 210 CONTINUE
6604 ELSEIF(mint(43).EQ.1) THEN
6605C...Lepton-lepton processes: QED production of squarks.
6606 DO 220 i=201,214
6607 msub(i)=1
6608 220 CONTINUE
6609 msub(210)=0
6610 msub(211)=0
6611 msub(212)=0
6612 DO 230 i=216,228
6613 msub(i)=1
6614 230 CONTINUE
6615 DO 240 i=261,263
6616 msub(i)=1
6617 240 CONTINUE
6618 msub(277)=1
6619 msub(278)=1
6620 ENDIF
6621
6622 ELSEIF(msel.EQ.40) THEN
6623C...Gluinos and squarks.
6624 IF(mint(43).EQ.4) THEN
6625 msub(243)=1
6626 msub(244)=1
6627 msub(258)=1
6628 msub(259)=1
6629 msub(261)=1
6630 msub(262)=1
6631 msub(264)=1
6632 msub(265)=1
6633 DO 250 i=271,296
6634 msub(i)=1
6635 250 CONTINUE
6636 ELSEIF(mint(43).EQ.1) THEN
6637 msub(277)=1
6638 msub(278)=1
6639 ENDIF
6640
6641 ELSEIF(msel.EQ.41) THEN
6642C...Stop production.
6643 msub(261)=1
6644 msub(262)=1
6645 msub(263)=1
6646 IF(mint(43).EQ.4) THEN
6647 msub(264)=1
6648 msub(265)=1
6649 ENDIF
6650
6651 ELSEIF(msel.EQ.42) THEN
6652C...Slepton production.
6653 DO 260 i=201,214
6654 msub(i)=1
6655 260 CONTINUE
6656 IF(mint(43).NE.4) THEN
6657 msub(210)=0
6658 msub(211)=0
6659 msub(212)=0
6660 ENDIF
6661
6662 ELSEIF(msel.EQ.43) THEN
6663C...Neutralino/Chargino + Gluino/Squark.
6664 IF(mint(43).EQ.4) THEN
6665 DO 270 i=237,242
6666 msub(i)=1
6667 270 CONTINUE
6668 DO 280 i=246,254
6669 msub(i)=1
6670 280 CONTINUE
6671 msub(256)=1
6672 ENDIF
6673
6674 ELSEIF(msel.EQ.44) THEN
6675C...Neutralino/Chargino pair production.
6676 IF(mint(43).EQ.4) THEN
6677 DO 290 i=216,236
6678 msub(i)=1
6679 290 CONTINUE
6680 ELSEIF(mint(43).EQ.1) THEN
6681 DO 300 i=216,228
6682 msub(i)=1
6683 300 CONTINUE
6684 ENDIF
6685
6686 ELSEIF(msel.EQ.45) THEN
6687C...Sbottom production.
6688 msub(287)=1
6689 msub(288)=1
6690 IF(mint(43).EQ.4) THEN
6691 DO 310 i=281,296
6692 msub(i)=1
6693 310 CONTINUE
6694 ENDIF
6695
6696 ELSEIF(msel.EQ.50) THEN
6697C...Pair production of technipions and gauge bosons.
6698 DO 320 i=361,368
6699 msub(i)=1
6700 320 CONTINUE
6701 IF(mint(43).EQ.4) THEN
6702 DO 330 i=370,377
6703 msub(i)=1
6704 330 CONTINUE
6705 ENDIF
6706
6707 ELSEIF(msel.EQ.51) THEN
6708C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6709 DO 340 i=381,386
6710 msub(i)=1
6711 340 CONTINUE
6712
6713 ELSEIF(msel.EQ.61) THEN
6714C...Charmonium production in colour octet model, with recoiling parton.
6715 DO 342 i=421,439
6716 msub(i)=1
6717 342 CONTINUE
6718
6719 ELSEIF(msel.EQ.62) THEN
6720C...Bottomonium production in colour octet model, with recoiling parton.
6721 DO 344 i=461,479
6722 msub(i)=1
6723 344 CONTINUE
6724
6725 ELSEIF(msel.EQ.63) THEN
6726C...Charmonium and bottomonium production in colour octet model.
6727 DO 346 i=421,439
6728 msub(i)=1
6729 msub(i+40)=1
6730 346 CONTINUE
6731 ENDIF
6732
6733C...Find heaviest new quark flavour allowed in processes 81-84.
6734 kflqm=1
6735 DO 350 i=1,min(8,mdcy(21,3))
6736 idc=i+mdcy(21,2)-1
6737 IF(mdme(idc,1).LE.0) GOTO 350
6738 kflqm=i
6739 350 CONTINUE
6740 IF(mstp(7).GE.1.AND.mstp(7).LE.8.AND.(msel.LE.3.OR.msel.GE.9))
6741 &kflqm=mstp(7)
6742 mint(55)=kflqm
6743 kfpr(81,1)=kflqm
6744 kfpr(81,2)=kflqm
6745 kfpr(82,1)=kflqm
6746 kfpr(82,2)=kflqm
6747 kfpr(83,1)=kflqm
6748 kfpr(84,1)=kflqm
6749 kfpr(84,2)=kflqm
6750
6751C...Find heaviest new fermion flavour allowed in process 85.
6752 kflfm=1
6753 DO 360 i=1,min(12,mdcy(22,3))
6754 idc=i+mdcy(22,2)-1
6755 IF(mdme(idc,1).LE.0) GOTO 360
6756 kflfm=kfdp(idc,1)
6757 360 CONTINUE
6758 IF(((mstp(7).GE.1.AND.mstp(7).LE.8).OR.(mstp(7).GE.11.AND.
6759 &mstp(7).LE.18)).AND.(msel.LE.3.OR.msel.GE.9)) kflfm=mstp(7)
6760 mint(56)=kflfm
6761 kfpr(85,1)=kflfm
6762 kfpr(85,2)=kflfm
6763
6764C...Import relevant information on external user processes.
6765 IF(mint(111).GE.11) THEN
6766 ipypr=0
6767 DO 390 iup=1,nprup
6768C...Find next empty PYTHIA process number slot and enable it.
6769 370 ipypr=ipypr+1
6770 IF(ipypr.GT.500) CALL pyerrm(26,
6771 & '(PYINPR.) no more empty slots for user processes')
6772 IF(iset(ipypr).GE.0.AND.iset(ipypr).LE.9) GOTO 370
6773 IF(ipypr.GE.91.AND.ipypr.LE.100) GOTO 370
6774 iset(ipypr)=11
6775C...Overwrite KFPR with references back to process number and ID.
6776 kfpr(ipypr,1)=iup
6777 kfpr(ipypr,2)=lprup(iup)
6778C...Process title.
6779 WRITE(chipr,'(I10)') lprup(iup)
6780 ichin=1
6781 DO 380 ich=1,9
6782 IF(chipr(ich:ich).EQ.' ') ichin=ich+1
6783 380 CONTINUE
6784 proc(ipypr)='User process '//chipr(ichin:10)//' '
6785C...Switch on process.
6786 msub(ipypr)=1
6787 390 CONTINUE
6788 ENDIF
6789
6790 RETURN
6791 END
6792
6793C*********************************************************************
6794
6795C...PYXTOT
6796C...Parametrizes total, elastic and diffractive cross-sections
6797C...for different energies and beams. Donnachie-Landshoff for
6798C...total and Schuler-Sjostrand for elastic and diffractive.
6799C...Process code IPROC:
6800C...= 1 : p + p;
6801C...= 2 : pbar + p;
6802C...= 3 : pi+ + p;
6803C...= 4 : pi- + p;
6804C...= 5 : pi0 + p;
6805C...= 6 : phi + p;
6806C...= 7 : J/psi + p;
6807C...= 11 : rho + rho;
6808C...= 12 : rho + phi;
6809C...= 13 : rho + J/psi;
6810C...= 14 : phi + phi;
6811C...= 15 : phi + J/psi;
6812C...= 16 : J/psi + J/psi;
6813C...= 21 : gamma + p (DL);
6814C...= 22 : gamma + p (VDM).
6815C...= 23 : gamma + pi (DL);
6816C...= 24 : gamma + pi (VDM);
6817C...= 25 : gamma + gamma (DL);
6818C...= 26 : gamma + gamma (VDM).
6819
6820 SUBROUTINE pyxtot
6821
6822C...Double precision and integer declarations.
6823 IMPLICIT DOUBLE PRECISION(a-h, o-z)
6824 IMPLICIT INTEGER(I-N)
6825 INTEGER PYK,PYCHGE,PYCOMP
6826C...Commonblocks.
6827 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
6828 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
6829 common/pypars/mstp(200),parp(200),msti(200),pari(200)
6830 common/pyint1/mint(400),vint(400)
6831 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
6832 common/pyint7/sigt(0:6,0:6,0:5)
6833 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint5/,/pyint7/
6834C...Local arrays.
6835 dimension nproc(30),xpar(30),ypar(30),ihada(20),ihadb(20),
6836 &pmhad(4),bhad(4),betp(4),ifitsd(20),ifitdd(20),ceffs(10,8),
6837 &ceffd(10,9),sigtmp(6,0:5)
6838
6839C...Common constants.
6840 DATA eps/0.0808d0/, eta/-0.4525d0/, alp/0.25d0/, cres/2d0/,
6841 &pmrc/1.062d0/, smp/0.880d0/, facel/0.0511d0/, facsd/0.0336d0/,
6842 &facdd/0.0084d0/
6843
6844C...Number of multiple processes to be evaluated (= 0 : undefined).
6845 DATA nproc/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6846C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6847 DATA xpar/2*21.70d0,3*13.63d0,10.01d0,0.970d0,3*0d0,
6848 &8.56d0,6.29d0,0.609d0,4.62d0,0.447d0,0.0434d0,4*0d0,
6849 &0.0677d0,0.0534d0,0.0425d0,0.0335d0,2.11d-4,1.31d-4,4*0d0/
6850 DATA ypar/
6851 &56.08d0,98.39d0,27.56d0,36.02d0,31.79d0,-1.51d0,-0.146d0,3*0d0,
6852 &13.08d0,-0.62d0,-0.060d0,0.030d0,-0.0028d0,0.00028d0,4*0d0,
6853 &0.129d0,0.115d0,0.081d0,0.072d0,2.15d-4,1.70d-4,4*0d0/
6854
6855C...Beam and target hadron class:
6856C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6857 DATA ihada/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6858 DATA ihadb/7*1,3*0,2,3,4,3,2*4,4*0/
6859C...Characteristic class masses, slope parameters, beta = sqrt(X).
6860 DATA pmhad/0.938d0,0.770d0,1.020d0,3.097d0/
6861 DATA bhad/2.3d0,1.4d0,1.4d0,0.23d0/
6862 DATA betp/4.658d0,2.926d0,2.149d0,0.208d0/
6863
6864C...Fitting constants used in parametrizations of diffractive results.
6865 DATA ifitsd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6866 DATA ifitdd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6867 DATA ((ceffs(j1,j2),j2=1,8),j1=1,10)/
6868 &0.213d0, 0.0d0, -0.47d0, 150d0, 0.213d0, 0.0d0, -0.47d0, 150d0,
6869 &0.213d0, 0.0d0, -0.47d0, 150d0, 0.267d0, 0.0d0, -0.47d0, 100d0,
6870 &0.213d0, 0.0d0, -0.47d0, 150d0, 0.232d0, 0.0d0, -0.47d0, 110d0,
6871 &0.213d0, 7.0d0, -0.55d0, 800d0, 0.115d0, 0.0d0, -0.47d0, 110d0,
6872 &0.267d0, 0.0d0, -0.46d0, 75d0, 0.267d0, 0.0d0, -0.46d0, 75d0,
6873 &0.232d0, 0.0d0, -0.46d0, 85d0, 0.267d0, 0.0d0, -0.48d0, 100d0,
6874 &0.115d0, 0.0d0, -0.50d0, 90d0, 0.267d0, 6.0d0, -0.56d0, 420d0,
6875 &0.232d0, 0.0d0, -0.48d0, 110d0, 0.232d0, 0.0d0, -0.48d0, 110d0,
6876 &0.115d0, 0.0d0, -0.52d0, 120d0, 0.232d0, 6.0d0, -0.56d0, 470d0,
6877 &0.115d0, 5.5d0, -0.58d0, 570d0, 0.115d0, 5.5d0, -0.58d0, 570d0/
6878 DATA ((ceffd(j1,j2),j2=1,9),j1=1,10)/
6879 &3.11d0, -7.34d0, 9.71d0, 0.068d0, -0.42d0, 1.31d0,
6880 &-1.37d0, 35.0d0, 118d0, 3.11d0, -7.10d0, 10.6d0,
6881 &0.073d0, -0.41d0, 1.17d0, -1.41d0, 31.6d0, 95d0,
6882 &3.12d0, -7.43d0, 9.21d0, 0.067d0, -0.44d0, 1.41d0,
6883 &-1.35d0, 36.5d0, 132d0, 3.13d0, -8.18d0, -4.20d0,
6884 &0.056d0, -0.71d0, 3.12d0, -1.12d0, 55.2d0, 1298d0,
6885 &3.11d0, -6.90d0, 11.4d0, 0.078d0, -0.40d0, 1.05d0,
6886 &-1.40d0, 28.4d0, 78d0, 3.11d0, -7.13d0, 10.0d0,
6887 &0.071d0, -0.41d0, 1.23d0, -1.34d0, 33.1d0, 105d0,
6888 &3.12d0, -7.90d0, -1.49d0, 0.054d0, -0.64d0, 2.72d0,
6889 &-1.13d0, 53.1d0, 995d0, 3.11d0, -7.39d0, 8.22d0,
6890 &0.065d0, -0.44d0, 1.45d0, -1.36d0, 38.1d0, 148d0,
6891 &3.18d0, -8.95d0, -3.37d0, 0.057d0, -0.76d0, 3.32d0,
6892 &-1.12d0, 55.6d0, 1472d0, 4.18d0, -29.2d0, 56.2d0,
6893 &0.074d0, -1.36d0, 6.67d0, -1.14d0, 116.2d0, 6532d0/
6894
6895C...Parameters. Combinations of the energy.
6896 aem=paru(101)
6897 pmth=parp(102)
6898 s=vint(2)
6899 srt=vint(1)
6900 seps=s**eps
6901 seta=s**eta
6902 slog=log(s)
6903
6904C...Ratio of gamma/pi (for rescaling in parton distributions).
6905 vint(281)=(xpar(22)*seps+ypar(22)*seta)/
6906 &(xpar(5)*seps+ypar(5)*seta)
6907 vint(317)=1d0
6908 IF(mint(50).NE.1) RETURN
6909
6910C...Order flavours of incoming particles: KF1 < KF2.
6911 IF(iabs(mint(11)).LE.iabs(mint(12))) THEN
6912 kf1=iabs(mint(11))
6913 kf2=iabs(mint(12))
6914 iord=1
6915 ELSE
6916 kf1=iabs(mint(12))
6917 kf2=iabs(mint(11))
6918 iord=2
6919 ENDIF
6920 isgn12=isign(1,mint(11)*mint(12))
6921
6922C...Find process number (for lookup tables).
6923 IF(kf1.GT.1000) THEN
6924 iproc=1
6925 IF(isgn12.LT.0) iproc=2
6926 ELSEIF(kf1.GT.100.AND.kf2.GT.1000) THEN
6927 iproc=3
6928 IF(isgn12.LT.0) iproc=4
6929 IF(kf1.EQ.111) iproc=5
6930 ELSEIF(kf1.GT.100) THEN
6931 iproc=11
6932 ELSEIF(kf2.GT.1000) THEN
6933 iproc=21
6934 IF(mint(123).EQ.2.OR.mint(123).EQ.3) iproc=22
6935 ELSEIF(kf2.GT.100) THEN
6936 iproc=23
6937 IF(mint(123).EQ.2.OR.mint(123).EQ.3) iproc=24
6938 ELSE
6939 iproc=25
6940 IF(mint(123).EQ.2.OR.mint(123).EQ.3.OR.mint(123).EQ.7) iproc=26
6941 ENDIF
6942
6943C... Number of multiple processes to be stored; beam/target side.
6944 npr=nproc(iproc)
6945 mint(101)=1
6946 mint(102)=1
6947 IF(npr.EQ.3) THEN
6948 mint(100+iord)=4
6949 ELSEIF(npr.EQ.6) THEN
6950 mint(101)=4
6951 mint(102)=4
6952 ENDIF
6953 n1=0
6954 IF(mint(101).EQ.4) n1=4
6955 n2=0
6956 IF(mint(102).EQ.4) n2=4
6957
6958C...Do not do any more for user-set or undefined cross-sections.
6959 IF(mstp(31).LE.0) RETURN
6960 IF(npr.EQ.0) CALL pyerrm(26,
6961 &'(PYXTOT:) cross section for this process not yet implemented')
6962
6963C...Parameters. Combinations of the energy.
6964 aem=paru(101)
6965 pmth=parp(102)
6966 s=vint(2)
6967 srt=vint(1)
6968 seps=s**eps
6969 seta=s**eta
6970 slog=log(s)
6971
6972C...Loop over multiple processes (for VDM).
6973 DO 110 i=1,npr
6974 IF(npr.EQ.1) THEN
6975 ipr=iproc
6976 ELSEIF(npr.EQ.3) THEN
6977 ipr=i+4
6978 IF(kf2.LT.1000) ipr=i+10
6979 ELSEIF(npr.EQ.6) THEN
6980 ipr=i+10
6981 ENDIF
6982
6983C...Evaluate hadron species, mass, slope contribution and fit number.
6984 iha=ihada(ipr)
6985 ihb=ihadb(ipr)
6986 pma=pmhad(iha)
6987 pmb=pmhad(ihb)
6988 bha=bhad(iha)
6989 bhb=bhad(ihb)
6990 isd=ifitsd(ipr)
6991 idd=ifitdd(ipr)
6992
6993C...Skip if energy too low relative to masses.
6994 DO 100 j=0,5
6995 sigtmp(i,j)=0d0
6996 100 CONTINUE
6997 IF(srt.LT.pma+pmb+parp(104)) GOTO 110
6998
6999C...Total cross-section. Elastic slope parameter and cross-section.
7000 sigtmp(i,0)=xpar(ipr)*seps+ypar(ipr)*seta
7001 bel=2d0*bha+2d0*bhb+4d0*seps-4.2d0
7002 sigtmp(i,1)=facel*sigtmp(i,0)**2/bel
7003
7004C...Diffractive scattering A + B -> X + B.
7005 bsd=2d0*bhb
7006 sqml=(pma+pmth)**2
7007 sqmu=s*ceffs(isd,1)+ceffs(isd,2)
7008 sum1=log((bsd+2d0*alp*log(s/sqml))/
7009 & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
7010 bxb=ceffs(isd,3)+ceffs(isd,4)/s
7011 sum2=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)/
7012 & (bsd+2d0*alp*log(s/((pma+pmth)*(pma+pmrc)))+bxb)
7013 sigtmp(i,2)=facsd*xpar(ipr)*betp(ihb)*max(0d0,sum1+sum2)
7014
7015C...Diffractive scattering A + B -> A + X.
7016 bsd=2d0*bha
7017 sqml=(pmb+pmth)**2
7018 sqmu=s*ceffs(isd,5)+ceffs(isd,6)
7019 sum1=log((bsd+2d0*alp*log(s/sqml))/
7020 & (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)
7021 bax=ceffs(isd,7)+ceffs(isd,8)/s
7022 sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/
7023 & (bsd+2d0*alp*log(s/((pmb+pmth)*(pmb+pmrc)))+bax)
7024 sigtmp(i,3)=facsd*xpar(ipr)*betp(iha)*max(0d0,sum1+sum2)
7025
7026C...Order single diffractive correctly.
7027 IF(iord.EQ.2) THEN
7028 sigsav=sigtmp(i,2)
7029 sigtmp(i,2)=sigtmp(i,3)
7030 sigtmp(i,3)=sigsav
7031 ENDIF
7032
7033C...Double diffractive scattering A + B -> X1 + X2.
7034 yeff=log(s*smp/((pma+pmth)*(pmb+pmth))**2)
7035 deff=ceffd(idd,1)+ceffd(idd,2)/slog+ceffd(idd,3)/slog**2
7036 sum1=(deff+yeff*(log(max(1d-10,yeff/deff))-1d0))/(2d0*alp)
7037 IF(yeff.LE.0) sum1=0d0
7038 sqmu=s*(ceffd(idd,4)+ceffd(idd,5)/slog+ceffd(idd,6)/slog**2)
7039 slup=log(max(1.1d0,s/(alp*(pma+pmth)**2*(pmb+pmth)*(pmb+pmrc))))
7040 sldn=log(max(1.1d0,s/(alp*sqmu*(pmb+pmth)*(pmb+pmrc))))
7041 sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)*log(slup/sldn)/
7042 & (2d0*alp)
7043 slup=log(max(1.1d0,s/(alp*(pmb+pmth)**2*(pma+pmth)*(pma+pmrc))))
7044 sldn=log(max(1.1d0,s/(alp*sqmu*(pma+pmth)*(pma+pmrc))))
7045 sum3=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)*log(slup/sldn)/
7046 & (2d0*alp)
7047 bxx=ceffd(idd,7)+ceffd(idd,8)/srt+ceffd(idd,9)/s
7048 slrr=log(s/(alp*(pma+pmth)*(pma+pmrc)*(pmb+pmth)*(pmb+pmrc)))
7049 sum4=cres**2*log(1d0+((pma+pmrc)/(pma+pmth))**2)*
7050 & log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/max(0.1d0,2d0*alp*slrr+bxx)
7051 sigtmp(i,4)=facdd*xpar(ipr)*max(0d0,sum1+sum2+sum3+sum4)
7052
7053C...Non-diffractive by unitarity.
7054 sigtmp(i,5)=sigtmp(i,0)-sigtmp(i,1)-sigtmp(i,2)-sigtmp(i,3)-
7055 & sigtmp(i,4)
7056 110 CONTINUE
7057
7058C...Put temporary results in output array: only one process.
7059 IF(mint(101).EQ.1.AND.mint(102).EQ.1) THEN
7060 DO 120 j=0,5
7061 sigt(0,0,j)=sigtmp(1,j)
7062 120 CONTINUE
7063
7064C...Beam multiple processes.
7065 ELSEIF(mint(101).EQ.4.AND.mint(102).EQ.1) THEN
7066 IF(mint(107).EQ.2) THEN
7067 vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(307)))**2
7068 ELSE
7069 vint(317)=16d0*parp(15)**2*vint(154)**2/
7070 & ((4d0*parp(15)**2+vint(307))*(4d0*vint(154)**2+vint(307)))
7071 ENDIF
7072 IF(mstp(20).GT.0) THEN
7073 vint(317)=vint(317)*(vint(2)/(vint(2)+vint(307)))**mstp(20)
7074 ENDIF
7075 DO 140 i=1,4
7076 IF(mint(107).EQ.2) THEN
7077 conv=(aem/parp(160+i))*vint(317)
7078 ELSEIF(vint(154).GT.parp(15)) THEN
7079 conv=(aem/paru(1))*(kchg(i,1)/3d0)**2*parp(18)**2*
7080 & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7081 ELSE
7082 conv=0d0
7083 ENDIF
7084 i1=max(1,i-1)
7085 DO 130 j=0,5
7086 sigt(i,0,j)=conv*sigtmp(i1,j)
7087 130 CONTINUE
7088 140 CONTINUE
7089 DO 150 j=0,5
7090 sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
7091 150 CONTINUE
7092
7093C...Target multiple processes.
7094 ELSEIF(mint(101).EQ.1.AND.mint(102).EQ.4) THEN
7095 IF(mint(108).EQ.2) THEN
7096 vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(308)))**2
7097 ELSE
7098 vint(317)=16d0*parp(15)**2*vint(154)**2/
7099 & ((4d0*parp(15)**2+vint(308))*(4d0*vint(154)**2+vint(308)))
7100 ENDIF
7101 IF(mstp(20).GT.0) THEN
7102 vint(317)=vint(317)*(vint(2)/(vint(2)+vint(308)))**mstp(20)
7103 ENDIF
7104 DO 170 i=1,4
7105 IF(mint(108).EQ.2) THEN
7106 conv=(aem/parp(160+i))*vint(317)
7107 ELSEIF(vint(154).GT.parp(15)) THEN
7108 conv=(aem/paru(1))*(kchg(i,1)/3d0)**2*parp(18)**2*
7109 & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7110 ELSE
7111 conv=0d0
7112 ENDIF
7113 iv=max(1,i-1)
7114 DO 160 j=0,5
7115 sigt(0,i,j)=conv*sigtmp(iv,j)
7116 160 CONTINUE
7117 170 CONTINUE
7118 DO 180 j=0,5
7119 sigt(0,0,j)=sigt(0,1,j)+sigt(0,2,j)+sigt(0,3,j)+sigt(0,4,j)
7120 180 CONTINUE
7121
7122C...Both beam and target multiple processes.
7123 ELSE
7124 IF(mint(107).EQ.2) THEN
7125 vint(317)=(pmhad(2)**2/(pmhad(2)**2+vint(307)))**2
7126 ELSE
7127 vint(317)=16d0*parp(15)**2*vint(154)**2/
7128 & ((4d0*parp(15)**2+vint(307))*(4d0*vint(154)**2+vint(307)))
7129 ENDIF
7130 IF(mint(108).EQ.2) THEN
7131 vint(317)=vint(317)*(pmhad(2)**2/(pmhad(2)**2+vint(308)))**2
7132 ELSE
7133 vint(317)=vint(317)*16d0*parp(15)**2*vint(154)**2/
7134 & ((4d0*parp(15)**2+vint(308))*(4d0*vint(154)**2+vint(308)))
7135 ENDIF
7136 IF(mstp(20).GT.0) THEN
7137 vint(317)=vint(317)*(vint(2)/(vint(2)+vint(307)+
7138 & vint(308)))**mstp(20)
7139 ENDIF
7140 DO 210 i1=1,4
7141 DO 200 i2=1,4
7142 IF(mint(107).EQ.2) THEN
7143 conv=(aem/parp(160+i1))*vint(317)
7144 ELSEIF(vint(154).GT.parp(15)) THEN
7145 conv=(aem/paru(1))*(kchg(i1,1)/3d0)**2*parp(18)**2*
7146 & (1d0/parp(15)**2-1d0/vint(154)**2)*vint(317)
7147 ELSE
7148 conv=0d0
7149 ENDIF
7150 IF(mint(108).EQ.2) THEN
7151 conv=conv*(aem/parp(160+i2))
7152 ELSEIF(vint(154).GT.parp(15)) THEN
7153 conv=conv*(aem/paru(1))*(kchg(i2,1)/3d0)**2*parp(18)**2*
7154 & (1d0/parp(15)**2-1d0/vint(154)**2)
7155 ELSE
7156 conv=0d0
7157 ENDIF
7158 IF(i1.LE.2) THEN
7159 iv=max(1,i2-1)
7160 ELSEIF(i2.LE.2) THEN
7161 iv=max(1,i1-1)
7162 ELSEIF(i1.EQ.i2) THEN
7163 iv=2*i1-2
7164 ELSE
7165 iv=5
7166 ENDIF
7167 DO 190 j=0,5
7168 jv=j
7169 IF(i2.GT.i1.AND.(j.EQ.2.OR.j.EQ.3)) jv=5-j
7170 sigt(i1,i2,j)=conv*sigtmp(iv,jv)
7171 190 CONTINUE
7172 200 CONTINUE
7173 210 CONTINUE
7174 DO 230 j=0,5
7175 DO 220 i=1,4
7176 sigt(i,0,j)=sigt(i,1,j)+sigt(i,2,j)+sigt(i,3,j)+sigt(i,4,j)
7177 sigt(0,i,j)=sigt(1,i,j)+sigt(2,i,j)+sigt(3,i,j)+sigt(4,i,j)
7178 220 CONTINUE
7179 sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)
7180 230 CONTINUE
7181 ENDIF
7182
7183C...Scale up uniformly for Donnachie-Landshoff parametrization.
7184 IF(iproc.EQ.21.OR.iproc.EQ.23.OR.iproc.EQ.25) THEN
7185 rfac=(xpar(iproc)*seps+ypar(iproc)*seta)/sigt(0,0,0)
7186 DO 260 i1=0,n1
7187 DO 250 i2=0,n2
7188 DO 240 j=0,5
7189 sigt(i1,i2,j)=rfac*sigt(i1,i2,j)
7190 240 CONTINUE
7191 250 CONTINUE
7192 260 CONTINUE
7193 ENDIF
7194
7195 RETURN
7196 END
7197
7198C*********************************************************************
7199
7200C...PYMAXI
7201C...Finds optimal set of coefficients for kinematical variable selection
7202C...and the maximum of the part of the differential cross-section used
7203C...in the event weighting.
7204
7205 SUBROUTINE pymaxi
7206
7207C...Double precision and integer declarations.
7208 IMPLICIT DOUBLE PRECISION(a-h, o-z)
7209 IMPLICIT INTEGER(I-N)
7210 INTEGER PYK,PYCHGE,PYCOMP
7211C...Parameter statement to help give large particle numbers.
7212 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
7213 &kexcit=4000000,kdimen=5000000)
7214
7215C...User process initialization commonblock.
7216 INTEGER MAXPUP
7217 parameter(maxpup=100)
7218 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7219 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7220 common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
7221 &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
7222 &lprup(maxpup)
7223 SAVE /heprup/
7224
7225C...Commonblocks.
7226 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
7227 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
7228 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
7229 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
7230 common/pypars/mstp(200),parp(200),msti(200),pari(200)
7231 common/pyint1/mint(400),vint(400)
7232 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
7233 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
7234 common/pyint4/mwid(500),wids(500,5)
7235 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
7236 common/pyint6/proc(0:500)
7237 CHARACTER PROC*28
7238 common/pyint7/sigt(0:6,0:6,0:5)
7239 common/pytcsm/itcm(0:99),rtcm(0:99)
7240 common/pytcco/coefx(194:380,2)
7241 common/tcpara/ires,jres,xmas(3),xwid(3),ymas(2),ywid(2)
7242 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
7243 &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint6/,/pyint7/,/pytcco/,
7244 &/pytcsm/,/tcpara/
7245C...Local arrays, character variables and data.
7246 LOGICAL IOK
7247 CHARACTER CVAR(4)*4
7248 dimension npts(4),mvarpt(500,4),vintpt(500,30),sigspt(500),
7249 &narel(9),wtrel(9),wtmat(9,9),wtreln(9),coefu(9),coefo(9),
7250 &iaccmx(4),sigsmx(4),sigssm(3),pmmn(2),wtrsav(9),tempc(9),
7251 &iq(9),ip(9)
7252 DATA cvar/'tau ','tau''','y* ','cth '/
7253 DATA sigssm/3*0d0/
7254
7255C...Initial values and loop over subprocesses.
7256 nposi=0
7257 vint(143)=1d0
7258 vint(144)=1d0
7259 xsec(0,1)=0d0
7260 itech=0
7261 DO 460 isub=1,500
7262 mint(1)=isub
7263 mint(51)=0
7264
7265C...Find maximum weight factors for photon flux.
7266 IF(msub(isub).EQ.1.OR.(isub.GE.91.AND.isub.LE.100)) THEN
7267 IF(mint(141).NE.0.OR.mint(142).NE.0) CALL pygaga(2,wtgaga)
7268 ENDIF
7269
7270C...Select subprocess to study: skip cases not applicable.
7271 IF(iset(isub).EQ.11) THEN
7272 IF(msub(isub).NE.1) GOTO 460
7273C...User process intialization: cross section model dependent.
7274 IF(iabs(idwtup).EQ.1) THEN
7275 IF(idwtup.GT.0.AND.xmaxup(kfpr(isub,1)).LT.0d0) call
7276 & pyerrm(26,'(PYMAXI:) Negative XMAXUP for user process')
7277 xsec(isub,1)=1.00000001d-9*abs(xmaxup(kfpr(isub,1)))
7278 ELSE
7279 IF((idwtup.EQ.2.OR.idwtup.EQ.3).AND.
7280 & xsecup(kfpr(isub,1)).LT.0d0) call
7281 & pyerrm(26,'(PYMAXI:) Negative XSECUP for user process')
7282 IF(idwtup.EQ.2.AND.xmaxup(kfpr(isub,1)).LT.0d0) call
7283 & pyerrm(26,'(PYMAXI:) Negative XMAXUP for user process')
7284 xsec(isub,1)=1.00000001d-9*abs(xsecup(kfpr(isub,1)))
7285 ENDIF
7286 IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7287 & wtgaga*xsec(isub,1)
7288 nposi=nposi+1
7289 GOTO 450
7290 ELSEIF(isub.GE.91.AND.isub.LE.95) THEN
7291 CALL pysigh(nchn,sigs)
7292 xsec(isub,1)=sigs
7293 IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7294 & wtgaga*xsec(isub,1)
7295 IF(msub(isub).NE.1) GOTO 460
7296 nposi=nposi+1
7297 GOTO 450
7298 ELSEIF(isub.EQ.99.AND.msub(isub).EQ.1) THEN
7299 CALL pysigh(nchn,sigs)
7300 xsec(isub,1)=sigs
7301 IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
7302 & wtgaga*xsec(isub,1)
7303 IF(xsec(isub,1).EQ.0d0) THEN
7304 msub(isub)=0
7305 ELSE
7306 nposi=nposi+1
7307 ENDIF
7308 GOTO 450
7309 ELSEIF(isub.EQ.96) THEN
7310 IF(mint(50).EQ.0) GOTO 460
7311 IF(msub(95).NE.1.AND.mod(mstp(81),10).LE.0.AND.mstp(131).LE.0)
7312 & GOTO 460
7313 IF(mint(49).EQ.0.AND.mstp(131).EQ.0) GOTO 460
7314 ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.
7315 & isub.EQ.53.OR.isub.EQ.68) THEN
7316 IF(msub(isub).NE.1.OR.msub(95).EQ.1) GOTO 460
7317 ELSEIF(isub.GE.381.AND.isub.LE.386) THEN
7318 IF(msub(isub).NE.1.OR.msub(95).EQ.1) GOTO 460
7319 ELSE
7320 IF(msub(isub).NE.1) GOTO 460
7321 ENDIF
7322 istsb=iset(isub)
7323 IF(isub.EQ.96) istsb=2
7324 IF(mstp(122).GE.2) WRITE(mstu(11),5000) isub
7325 mwtxs=0
7326 IF(mstp(142).GE.1.AND.isub.NE.96.AND.msub(91)+msub(92)+msub(93)+
7327 & msub(94)+msub(95).EQ.0) mwtxs=1
7328
7329C...Find resonances (explicit or implicit in cross-section).
7330 mint(72)=0
7331 kfr1=0
7332 IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
7333 kfr1=kfpr(isub,1)
7334 ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165
7335 & .OR.isub.EQ.171.OR.isub.EQ.176) THEN
7336 kfr1=23
7337 ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172
7338 & .OR.isub.EQ.177) THEN
7339 kfr1=24
7340 ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
7341 kfr1=25
7342 IF(mstp(46).EQ.5) THEN
7343 kfr1=89
7344 pmas(89,1)=parp(45)
7345 pmas(89,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
7346 ENDIF
7347 ENDIF
7348 ckmx=ckin(2)
7349 IF(ckmx.LE.0d0) ckmx=vint(1)
7350 kcr1=pycomp(kfr1)
7351 IF(kfr1.NE.0) THEN
7352 IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
7353 & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
7354 ENDIF
7355 IF(kfr1.NE.0) THEN
7356 taur1=pmas(kcr1,1)**2/vint(2)
7357 gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
7358 mint(72)=1
7359 mint(73)=kfr1
7360 vint(73)=taur1
7361 vint(74)=gamr1
7362 ENDIF
7363 kfr2=0
7364 kfr3=0
7365 IF(isub.EQ.141.OR.isub.EQ.194.OR.isub.EQ.195.OR.
7366 $ (isub.GE.361.AND.isub.LE.380))
7367 $ THEN
7368 kfr2=23
7369 IF(isub.EQ.141) THEN
7370 kcr2=pycomp(kfr2)
7371 IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
7372 & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) THEN
7373 kfr2=0
7374 ELSE
7375 taur2=pmas(kcr2,1)**2/vint(2)
7376 gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
7377 mint(72)=2
7378 mint(74)=kfr2
7379 vint(75)=taur2
7380 vint(76)=gamr2
7381 ENDIF
7382 ELSEIF(itech.EQ.0) THEN
7383 alprht=2.16d0*(3d0/dble(itcm(1)))
7384 itech=1
7385 kfr1=ktechn+113
7386 kcr1=pycomp(kfr1)
7387 kfr2=ktechn+223
7388 kcr2=pycomp(kfr2)
7389 kfr3=ktechn+115
7390 kcr3=pycomp(kfr3)
7391 ires=0
7392C...Order the resonances
7393 IF(pmas(kcr3,1).LT.pmas(kcr2,1)) THEN
7394 kct=kcr3
7395 kcr3=kcr2
7396 kcr2=kct
7397 ENDIF
7398 IF(pmas(kcr3,1).LT.pmas(kcr1,1)) THEN
7399 kct=kcr3
7400 kcr3=kcr1
7401 kcr1=kct
7402 ENDIF
7403 IF(pmas(kcr2,1).LT.pmas(kcr1,1)) THEN
7404 kct=kcr2
7405 kcr2=kcr1
7406 kcr1=kct
7407 ENDIF
7408 DO 101 i=1,3
7409 IF(i.EQ.1) THEN
7410 shn0=pmas(kcr1,1)**2
7411 ELSEIF(i.EQ.2) THEN
7412 IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LE.1d-6) GOTO 101
7413 shn0=pmas(kcr2,1)**2
7414 ELSEIF(i.EQ.3) THEN
7415 IF(abs(pmas(kcr3,1)-pmas(kcr3,1)).LE.1d-6) GOTO 101
7416 shn0=pmas(kcr3,1)**2
7417 ENDIF
7418 aem=pyalem(shn0)
7419 far=sqrt(aem/alprht)
7420 shn=shn0*(1d0-far)
7421 CALL pytecm(shn,s1,wido,1)
7422 res=shn-s1
7423 shn=s1*.99d0
7424 shstep=2d0
7425 102 shn=shn+shstep
7426 CALL pytecm(shn,s1,wido,1)
7427 IF(res.LT.0d0.AND.shn-s1.GE.0d0) THEN
7428 iok=.false.
7429 IF(ires.GT.0) THEN
7430 IF(abs(sqrt(s1)-xmas(ires)).GT.1d-6) iok=.true.
7431 ELSEIF(ires.EQ.0) THEN
7432 iok=.true.
7433 ENDIF
7434 IF(iok) THEN
7435 ires=ires+1
7436 xmas(ires)=sqrt(s1)
7437 xwid(ires)=wido
7438 ENDIF
7439 ENDIF
7440 res=shn-s1
7441 IF(ires.LT.3.AND.shn.LT.shn0*(1d0+far)) GOTO 102
7442 101 CONTINUE
7443 jres=0
7444 kfr1=ktechn+213
7445 kcr1=pycomp(kfr1)
7446 kfr2=ktechn+215
7447 kcr2=pycomp(kfr2)
7448 IF(pmas(kcr2,1).LT.pmas(kcr1,1)) THEN
7449 kct=kcr2
7450 kcr2=kcr1
7451 kcr1=kct
7452 ENDIF
7453 DO 103 i=1,2
7454 IF(i.EQ.1) THEN
7455 shn0=pmas(kcr1,1)**2
7456 ELSEIF(i.EQ.2) THEN
7457 IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LE.1d-6) GOTO 103
7458 shn0=pmas(kcr2,1)**2
7459 ENDIF
7460 aem=pyalem(shn0)
7461 far=sqrt(aem/alprht)
7462 shn=shn0*(1d0-far)
7463 CALL pytecm(shn,s1,wido,2)
7464 res=shn-s1
7465 shn=s1*.99d0
7466 shstep=2d0
7467 104 shn=shn+shstep
7468 CALL pytecm(shn,s1,wido,2)
7469 IF(res.LT.0d0.AND.shn-s1.GE.0d0) THEN
7470 iok=.false.
7471 IF(jres.GT.0) THEN
7472 IF(abs(sqrt(s1)-xmas(ires)).GT.1d-6) iok=.true.
7473 ELSEIF(jres.EQ.0) THEN
7474 iok=.true.
7475 ENDIF
7476 IF(iok) THEN
7477 jres=jres+1
7478 ymas(jres)=sqrt(s1)
7479 ywid(jres)=wido
7480 ENDIF
7481 ENDIF
7482 res=shn-s1
7483 IF(jres.LT.2.AND.shn.LT.shn0*(1d0+far)) GOTO 104
7484 103 CONTINUE
7485 ENDIF
7486 IF(isub.EQ.194.OR.(isub.GE.361.AND.isub.LE.368).OR.
7487 & isub.EQ.379.OR.isub.EQ.380) THEN
7488 mint(72)=ires
7489 IF(ires.GE.1) THEN
7490 vint(73)=xmas(1)**2/vint(2)
7491 vint(74)=xmas(1)*xwid(1)/vint(2)
7492 taur1=vint(73)
7493 gamr1=vint(74)
7494 xm1=xmas(1)
7495 xg1=xwid(1)
7496 kfr1=1
7497 ENDIF
7498 IF(ires.GE.2) THEN
7499 vint(75)=xmas(2)**2/vint(2)
7500 vint(76)=xmas(2)*xwid(2)/vint(2)
7501 taur2=vint(75)
7502 gamr2=vint(76)
7503 xm2=xmas(2)
7504 xg2=xwid(2)
7505 kfr2=2
7506 ENDIF
7507 IF(ires.EQ.3) THEN
7508 vint(77)=xmas(3)**2/vint(2)
7509 vint(78)=xmas(3)*xwid(3)/vint(2)
7510 taur3=vint(77)
7511 gamr3=vint(78)
7512 xm3=xmas(3)
7513 xg3=xwid(3)
7514 kfr3=3
7515 ENDIF
7516C...Charged current: rho+- and a+-
7517 ELSEIF(isub.EQ.195.OR.isub.GE.370.AND.isub.LE.378) THEN
7518 mint(72)=ires
7519 IF(jres.GE.1) THEN
7520 vint(73)=ymas(1)**2/vint(2)
7521 vint(74)=ymas(1)*ywid(1)/vint(2)
7522 kfr1=1
7523 taur1=vint(73)
7524 gamr1=vint(74)
7525 xm1=ymas(1)
7526 xg1=ywid(1)
7527 ENDIF
7528 IF(jres.GE.2) THEN
7529 vint(75)=ymas(2)**2/vint(2)
7530 vint(76)=ymas(2)*ywid(2)/vint(2)
7531 kfr2=2
7532 taur2=vint(73)
7533 gamr2=vint(74)
7534 xm2=ymas(2)
7535 xg2=ywid(2)
7536 ENDIF
7537 kfr3=0
7538 ENDIF
7539 IF(isub.NE.141) THEN
7540 IF(kfr1.NE.0.AND.(ckin(1).GT.(xm1+20d0*xg1)
7541 & .OR.ckmx.LT.(xm1-20d0*xg1))) kfr1=0
7542 IF(kfr2.NE.0.AND.(ckin(1).GT.(xm2+20d0*xg2)
7543 & .OR.ckmx.LT.(xm2-20d0*xg2))) kfr2=0
7544 IF(kfr3.NE.0.AND.(ckin(1).GT.(xm3+20d0*xg3)
7545 & .OR.ckmx.LT.(xm3-20d0*xg3))) kfr3=0
7546 IF(kfr3.NE.0.AND.kfr2.NE.0.AND.kfr1.NE.0) THEN
7547
7548 ELSEIF(kfr1.NE.0.AND.kfr2.NE.0) THEN
7549 mint(72)=2
7550 ELSEIF(kfr1.NE.0.AND.kfr3.NE.0) THEN
7551 mint(72)=2
7552 mint(74)=kfr3
7553 vint(75)=taur3
7554 vint(76)=gamr3
7555 ELSEIF(kfr2.NE.0.AND.kfr3.NE.0) THEN
7556 mint(72)=2
7557 mint(73)=kfr2
7558 vint(73)=taur2
7559 vint(74)=gamr2
7560 mint(74)=kfr3
7561 vint(75)=taur3
7562 vint(76)=gamr3
7563 ELSEIF(kfr1.NE.0) THEN
7564 mint(72)=1
7565 ELSEIF(kfr2.NE.0) THEN
7566 mint(72)=1
7567 mint(73)=kfr2
7568 vint(73)=taur2
7569 vint(74)=gamr2
7570 ELSEIF(kfr3.NE.0) THEN
7571 mint(72)=1
7572 mint(73)=kfr3
7573 vint(73)=taur3
7574 vint(74)=gamr3
7575 ELSE
7576 mint(72)=0
7577 ENDIF
7578 ELSE
7579 IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
7580
7581 ELSEIF(kfr2.NE.0) THEN
7582 kfr1=kfr2
7583 taur1=taur2
7584 gamr1=gamr2
7585 mint(72)=1
7586 mint(73)=kfr1
7587 vint(73)=taur1
7588 vint(74)=gamr1
7589 kfr2=0
7590 ELSE
7591 mint(72)=0
7592 ENDIF
7593 ENDIF
7594 ENDIF
7595
7596C...Find product masses and minimum pT of process.
7597 sqm3=0d0
7598 sqm4=0d0
7599 mint(71)=0
7600 vint(71)=ckin(3)
7601 vint(80)=1d0
7602 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
7603 nbw=0
7604 DO 110 i=1,2
7605 pmmn(i)=0d0
7606 IF(kfpr(isub,i).EQ.0) THEN
7607 ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
7608 & parp(41)) THEN
7609 IF(i.EQ.1) sqm3=pmas(pycomp(kfpr(isub,i)),1)**2
7610 IF(i.EQ.2) sqm4=pmas(pycomp(kfpr(isub,i)),1)**2
7611 ELSE
7612 nbw=nbw+1
7613C...This prevents SUSY/t particles from becoming too light.
7614 kflw=kfpr(isub,i)
7615 IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
7616 kcw=pycomp(kflw)
7617 pmmn(i)=pmas(kcw,1)
7618 DO 100 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
7619 IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
7620 pmsum=pmas(pycomp(kfdp(idc,1)),1)+
7621 & pmas(pycomp(kfdp(idc,2)),1)
7622 IF(kfdp(idc,3).NE.0) pmsum=pmsum+
7623 & pmas(pycomp(kfdp(idc,3)),1)
7624 pmmn(i)=min(pmmn(i),pmsum)
7625 ENDIF
7626 100 CONTINUE
7627 ELSEIF(kflw.EQ.6) THEN
7628 pmmn(i)=pmas(24,1)+pmas(5,1)
7629 ENDIF
7630 ENDIF
7631 110 CONTINUE
7632 IF(nbw.GE.1) THEN
7633 ckin41=ckin(41)
7634 ckin43=ckin(43)
7635 ckin(41)=max(pmmn(1),ckin(41))
7636 ckin(43)=max(pmmn(2),ckin(43))
7637 CALL pyofsh(3,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
7638 ckin(41)=ckin41
7639 ckin(43)=ckin43
7640 IF(mint(51).EQ.1) THEN
7641 WRITE(mstu(11),5100) isub
7642 msub(isub)=0
7643 GOTO 460
7644 ENDIF
7645 sqm3=pqm3**2
7646 sqm4=pqm4**2
7647 ENDIF
7648 IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1
7649 IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
7650 IF(isub.EQ.96.AND.mstp(82).LE.1) THEN
7651 vint(71)=parp(81)*(vint(1)/parp(89))**parp(90)
7652 ELSEIF(isub.EQ.96) THEN
7653 vint(71)=0.08d0*parp(82)*(vint(1)/parp(89))**parp(90)
7654 ENDIF
7655 ENDIF
7656 vint(63)=sqm3
7657 vint(64)=sqm4
7658
7659C...Prepare for additional variable choices in 2 -> 3.
7660 IF(istsb.EQ.5) THEN
7661 vint(201)=0d0
7662 IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
7663 vint(206)=vint(201)
7664 IF(isub.EQ.401.OR.isub.EQ.402) vint(206)=pmas(5,1)
7665 vint(204)=pmas(23,1)
7666 IF(isub.EQ.124.OR.isub.EQ.351) vint(204)=pmas(24,1)
7667 IF(isub.EQ.352) vint(204)=pmas(pycomp(9900024),1)
7668 IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182
7669 & .OR.isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402)
7670 & vint(204)=vint(201)
7671 vint(209)=vint(204)
7672 IF(isub.EQ.401.OR.isub.EQ.402) vint(209)=vint(206)
7673 ENDIF
7674
7675C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7676 ipeak7=0
7677 npts(1)=2+2*mint(72)
7678 IF(mint(47).EQ.1) THEN
7679 IF(istsb.EQ.1.OR.istsb.EQ.2) npts(1)=1
7680 ELSEIF(mint(47).GE.5) THEN
7681 IF(istsb.LE.2.OR.istsb.GT.5) THEN
7682 npts(1)=npts(1)+1
7683 ipeak7=1
7684 ENDIF
7685 ENDIF
7686 npts(2)=1
7687 IF(istsb.GE.3.AND.istsb.LE.5) THEN
7688 IF(mint(47).GE.2) npts(2)=2
7689 IF(mint(47).GE.5) npts(2)=3
7690 ENDIF
7691 npts(3)=1
7692 IF(mint(47).EQ.4.OR.mint(47).EQ.5) THEN
7693 npts(3)=3
7694 IF(mint(45).EQ.3) npts(3)=npts(3)+1
7695 IF(mint(46).EQ.3) npts(3)=npts(3)+1
7696 ENDIF
7697 npts(4)=1
7698 IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5
7699 ntry=npts(1)*npts(2)*npts(3)*npts(4)
7700
7701C...Reset coefficients of cross-section weighting.
7702 DO 120 j=1,20
7703 coef(isub,j)=0d0
7704 120 CONTINUE
7705 IF(isub.EQ.194.OR.isub.EQ.195.OR.(isub.GE.361
7706 & .AND.isub.LE.380)) THEN
7707 DO 125 j=1,2
7708 coefx(isub,j)=0d0
7709 125 CONTINUE
7710 ENDIF
7711 coef(isub,1)=1d0
7712 coef(isub,8)=0.5d0
7713 coef(isub,9)=0.5d0
7714 coef(isub,13)=1d0
7715 coef(isub,18)=1d0
7716 mcth=0
7717 mtaup=0
7718 metaup=0
7719 vint(23)=0d0
7720 vint(26)=0d0
7721 sigsam=0d0
7722
7723C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7724C...in grid of phase space points.
7725 CALL pyklim(1)
7726 metau=mint(51)
7727 nacc=0
7728 DO 150 itry=1,ntry
7729 mint(51)=0
7730 IF(metau.EQ.1) GOTO 150
7731 IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN
7732 mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))
7733 IF(mint(72).LE.2.AND.mtau.GT.2+2*mint(72)) THEN
7734 mtau=7
7735 ELSEIF(mint(72).EQ.3.AND.ipeak7.EQ.0.AND.mtau.GE.7) THEN
7736 mtau=mtau+1
7737 ENDIF
7738 rtau=0.5d0
7739C...Special case when both resonances have same mass,
7740C...as is often the case in process 194.
7741c IF(MINT(72).GE.2) THEN
7742c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7743c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7744c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7745c RTAU=0.4D0
7746c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7747c RTAU=0.6D0
7748c ENDIF
7749c ENDIF
7750c ENDIF
7751 CALL pykmap(1,mtau,rtau)
7752 IF(istsb.GE.3.AND.istsb.LE.5) CALL pyklim(4)
7753 metaup=mint(51)
7754 ENDIF
7755 IF(metaup.EQ.1) GOTO 150
7756 IF(istsb.GE.3.AND.istsb.LE.5.AND.mod(itry-1,npts(3)*npts(4))
7757 & .EQ.0) THEN
7758 mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2))
7759 CALL pykmap(4,mtaup,0.5d0)
7760 ENDIF
7761 IF(mod(itry-1,npts(3)*npts(4)).EQ.0) THEN
7762 CALL pyklim(2)
7763 meyst=mint(51)
7764 ENDIF
7765 IF(meyst.EQ.1) GOTO 150
7766 IF(mod(itry-1,npts(4)).EQ.0) THEN
7767 myst=1+mod((itry-1)/npts(4),npts(3))
7768 IF(myst.EQ.4.AND.mint(45).NE.3) myst=5
7769 CALL pykmap(2,myst,0.5d0)
7770 CALL pyklim(3)
7771 mecth=mint(51)
7772 ENDIF
7773 IF(mecth.EQ.1) GOTO 150
7774 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
7775 mcth=1+mod(itry-1,npts(4))
7776 CALL pykmap(3,mcth,0.5d0)
7777 ENDIF
7778 IF(isub.EQ.96) vint(25)=vint(21)*(1d0-vint(23)**2)
7779
7780C...Store position and limits.
7781 mint(51)=0
7782 CALL pyklim(0)
7783 IF(mint(51).EQ.1) GOTO 150
7784 nacc=nacc+1
7785 mvarpt(nacc,1)=mtau
7786 mvarpt(nacc,2)=mtaup
7787 mvarpt(nacc,3)=myst
7788 mvarpt(nacc,4)=mcth
7789 DO 130 j=1,30
7790 vintpt(nacc,j)=vint(10+j)
7791 130 CONTINUE
7792
7793C...Normal case: calculate cross-section.
7794 IF(istsb.NE.5) THEN
7795 CALL pysigh(nchn,sigs)
7796 IF(mwtxs.EQ.1) THEN
7797 CALL pyevwt(wtxs)
7798 sigs=wtxs*sigs
7799 ENDIF
7800
7801C..2 -> 3: find highest value out of a number of tries.
7802 ELSE
7803 sigs=0d0
7804 DO 140 ikin3=1,mstp(129)
7805 CALL pykmap(5,0,0d0)
7806 IF(mint(51).EQ.1) GOTO 140
7807 CALL pysigh(nchn,sigtmp)
7808 IF(mwtxs.EQ.1) THEN
7809 CALL pyevwt(wtxs)
7810 sigtmp=wtxs*sigtmp
7811 ENDIF
7812 IF(sigtmp.GT.sigs) sigs=sigtmp
7813 140 CONTINUE
7814 ENDIF
7815
7816C...Store cross-section.
7817 sigspt(nacc)=sigs
7818 IF(sigs.GT.sigsam) sigsam=sigs
7819 IF(mstp(122).GE.2) WRITE(mstu(11),5200) mtau,myst,mcth,mtaup,
7820 & vint(21),vint(22),vint(23),vint(26),sigs
7821 150 CONTINUE
7822 IF(nacc.EQ.0) THEN
7823 WRITE(mstu(11),5100) isub
7824 msub(isub)=0
7825 GOTO 460
7826 ELSEIF(sigsam.EQ.0d0) THEN
7827 WRITE(mstu(11),5300) isub
7828 msub(isub)=0
7829 GOTO 460
7830 ENDIF
7831 IF(isub.NE.96) nposi=nposi+1
7832
7833C...Calculate integrals in tau over maximal phase space limits.
7834 taumin=vint(11)
7835 taumax=vint(31)
7836 atau1=log(taumax/taumin)
7837 IF(npts(1).GE.2) THEN
7838 atau2=(taumax-taumin)/(taumax*taumin)
7839 ENDIF
7840 IF(npts(1).GE.4) THEN
7841 atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1
7842 atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/
7843 & gamr1
7844 ENDIF
7845 IF(npts(1).GE.6) THEN
7846 atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2
7847 atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/
7848 & gamr2
7849 ENDIF
7850 IF(npts(1).GE.8) THEN
7851 atau8=log(taumax/taumin*(taumin+taur3)/(taumax+taur3))/taur3
7852 atau9=(atan((taumax-taur3)/gamr3)-atan((taumin-taur3)/gamr3))/
7853 & gamr3
7854 ENDIF
7855 IF(ipeak7.EQ.1) THEN
7856 atau7=log(max(2d-10,1d0-taumin)/max(2d-10,1d0-taumax))
7857 ENDIF
7858
7859C...Reset. Sum up cross-sections in points calculated.
7860 DO 320 ivar=1,4
7861 IF(npts(ivar).EQ.1) GOTO 320
7862 IF(isub.EQ.96.AND.ivar.EQ.4) GOTO 320
7863 nbin=npts(ivar)
7864 DO 170 j1=1,nbin
7865 narel(j1)=0
7866 wtrel(j1)=0d0
7867 coefu(j1)=0d0
7868 DO 160 j2=1,nbin
7869 wtmat(j1,j2)=0d0
7870 160 CONTINUE
7871 170 CONTINUE
7872 DO 180 iacc=1,nacc
7873 ibin=mvarpt(iacc,ivar)
7874 IF(ivar.EQ.1) THEN
7875 IF(ibin.GT.7.AND.ipeak7.EQ.0) THEN
7876 ibin=ibin-1
7877 ELSEIF(ibin.EQ.7.AND.ipeak7.EQ.1.AND.mstp(72).LT.3) THEN
7878 ibin=3+2*mint(72)
7879 ENDIF
7880 ENDIF
7881 IF(ivar.EQ.3.AND.ibin.EQ.5.AND.mint(45).NE.3) ibin=4
7882 narel(ibin)=narel(ibin)+1
7883 wtrel(ibin)=wtrel(ibin)+sigspt(iacc)
7884
7885C...Sum up tau cross-section pieces in points used.
7886 IF(ivar.EQ.1) THEN
7887 tau=vintpt(iacc,11)
7888 wtmat(ibin,1)=wtmat(ibin,1)+1d0
7889 wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau
7890 IF(nbin.GE.4) THEN
7891 wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1)
7892 wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/
7893 & ((tau-taur1)**2+gamr1**2)
7894 ENDIF
7895 IF(nbin.GE.6) THEN
7896 wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2)
7897 wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/
7898 & ((tau-taur2)**2+gamr2**2)
7899 ENDIF
7900 IF(mint(72).LE.2.AND.ipeak7.EQ.1) THEN
7901 wtmat(ibin,3+2*mint(72))=wtmat(ibin,3+2*mint(72))
7902 & +(atau1/atau7)*tau/max(2d-10,1d0-tau)
7903 ELSEIF(mint(72).EQ.3.AND.ipeak7.EQ.1) THEN
7904 wtmat(ibin,7)=wtmat(ibin,7)
7905 & +(atau1/atau7)*tau/max(2d-10,1d0-tau)
7906 ENDIF
7907 IF(mint(72).EQ.3) THEN
7908 wtmat(ibin,7+ipeak7)=wtmat(ibin,7+ipeak7)
7909 & +(atau1/atau8)/(tau+taur3)
7910 wtmat(ibin,8+ipeak7)=wtmat(ibin,8+ipeak7)
7911 & +(atau1/atau9)*tau/((tau-taur3)**2+gamr3**2)
7912 ENDIF
7913C...Sum up tau' cross-section pieces in points used.
7914 ELSEIF(ivar.EQ.2) THEN
7915 tau=vintpt(iacc,11)
7916 taup=vintpt(iacc,16)
7917 taupmn=vintpt(iacc,6)
7918 taupmx=vintpt(iacc,26)
7919 ataup1=log(taupmx/taupmn)
7920 ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
7921 wtmat(ibin,1)=wtmat(ibin,1)+1d0
7922 wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*
7923 & (1d0-tau/taup)**3/taup
7924 IF(nbin.GE.3) THEN
7925 ataup3=log(max(2d-10,1d0-taupmn)/max(2d-10,1d0-taupmx))
7926 wtmat(ibin,3)=wtmat(ibin,3)+(ataup1/ataup3)*
7927 & taup/max(2d-10,1d0-taup)
7928 ENDIF
7929
7930C...Sum up y* cross-section pieces in points used.
7931 ELSEIF(ivar.EQ.3) THEN
7932 yst=vintpt(iacc,12)
7933 ystmin=vintpt(iacc,2)
7934 ystmax=vintpt(iacc,22)
7935 ayst0=ystmax-ystmin
7936 ayst1=0.5d0*(ystmax-ystmin)**2
7937 ayst2=ayst1
7938 ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
7939 wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)
7940 wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst2)*(ystmax-yst)
7941 wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst)
7942 IF(mint(45).EQ.3) THEN
7943 taue=vintpt(iacc,11)
7944 IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
7945 yst0=-0.5d0*log(taue)
7946 ayst4=log(max(1d-10,exp(yst0-ystmin)-1d0)/
7947 & max(1d-10,exp(yst0-ystmax)-1d0))
7948 wtmat(ibin,4)=wtmat(ibin,4)+(ayst0/ayst4)/
7949 & max(1d-10,1d0-exp(yst-yst0))
7950 ENDIF
7951 IF(mint(46).EQ.3) THEN
7952 taue=vintpt(iacc,11)
7953 IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)
7954 yst0=-0.5d0*log(taue)
7955 ayst5=log(max(1d-10,exp(yst0+ystmax)-1d0)/
7956 & max(1d-10,exp(yst0+ystmin)-1d0))
7957 wtmat(ibin,nbin)=wtmat(ibin,nbin)+(ayst0/ayst5)/
7958 & max(1d-10,1d0-exp(-yst-yst0))
7959 ENDIF
7960
7961C...Sum up cos(theta-hat) cross-section pieces in points used.
7962 ELSE
7963 rm34=max(1d-20,2d0*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2)
7964 rsqm=1d0+rm34
7965 cthmax=sqrt(1d0-4d0*vint(71)**2/(taumax*vint(2)))
7966 cthmin=-cthmax
7967 IF(cthmax.GT.0.9999d0) rm34=max(rm34,2d0*vint(71)**2/
7968 & (taumax*vint(2)))
7969 acth1=cthmax-cthmin
7970 acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))
7971 acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))
7972 acth4=1d0/max(rm34,rsqm-cthmax)-1d0/max(rm34,rsqm-cthmin)
7973 acth5=1d0/max(rm34,rsqm+cthmin)-1d0/max(rm34,rsqm+cthmax)
7974 cth=vintpt(iacc,13)
7975 wtmat(ibin,1)=wtmat(ibin,1)+1d0
7976 wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/
7977 & max(rm34,rsqm-cth)
7978 wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/
7979 & max(rm34,rsqm+cth)
7980 wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/
7981 & max(rm34,rsqm-cth)**2
7982 wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/
7983 & max(rm34,rsqm+cth)**2
7984 ENDIF
7985 180 CONTINUE
7986
7987C...Check that equation system solvable.
7988 IF(mstp(122).GE.2) WRITE(mstu(11),5400) cvar(ivar)
7989 msolv=1
7990 wtrels=0d0
7991 DO 190 ibin=1,nbin
7992 IF(mstp(122).GE.2) WRITE(mstu(11),5500) (wtmat(ibin,ired),
7993 & ired=1,nbin),wtrel(ibin)
7994 IF(narel(ibin).EQ.0) msolv=0
7995 wtrels=wtrels+wtrel(ibin)
7996 190 CONTINUE
7997 IF(abs(wtrels).LT.1d-20) msolv=0
7998
7999C...Solve to find relative importance of cross-section pieces.
8000 IF(msolv.EQ.1) THEN
8001 DO 200 ibin=1,nbin
8002 wtreln(ibin)=max(0.1d0,wtrel(ibin)/wtrels)
8003 wtrsav(ibin)=wtrel(ibin)
8004 200 CONTINUE
8005C...Auxiliary vectors to record order of permutations
8006 DO i=1,nbin
8007 ip(i) = i
8008 iq(i) = i
8009 ENDDO
8010 DO 230 ired=1,nbin-1
8011 mrow=ired
8012 resmax=abs(wtrel(mrow))
8013C...Find row with largest residual
8014 DO jbin=ired+1,nbin
8015 IF(resmax.LT.abs(wtrel(jbin))) THEN
8016 mrow=jbin
8017 resmax=abs(wtrel(mrow))
8018 ENDIF
8019 ENDDO
8020 IF(resmax.LT.1d-20) THEN
8021 msolv=0
8022 GOTO 260
8023 ENDIF
8024 mcol = ired
8025 amax = abs(wtmat(mrow,mcol))
8026C...Find column with largest entry
8027 DO jbin=ired+1,nbin
8028 IF (amax.LT.abs(wtmat(mrow,jbin))) THEN
8029 mcol = jbin
8030 amax = abs(wtmat(mrow,mcol))
8031 ENDIF
8032 ENDDO
8033C...Swap rows if necessary
8034 IF(mrow.NE.ired) THEN
8035 DO jbin=1,nbin
8036 tmpe=wtmat(ired,jbin)
8037 wtmat(ired,jbin)=wtmat(mrow,jbin)
8038 wtmat(mrow,jbin)=tmpe
8039 ENDDO
8040 tmpe=wtrel(ired)
8041 wtrel(ired)=wtrel(mrow)
8042 wtrel(mrow)=tmpe
8043 mtmp=iq(ired)
8044 iq(ired)=iq(mrow)
8045 iq(mrow)=mtmp
8046 ENDIF
8047C...Swap columns if necessary
8048 IF(mcol.NE.ired) THEN
8049 DO jbin=1,nbin
8050 tmpe=wtmat(jbin,ired)
8051 wtmat(jbin,ired)=wtmat(jbin,mcol)
8052 wtmat(jbin,mcol)=tmpe
8053 ENDDO
8054 mtmp=ip(ired)
8055 ip(ired)=ip(mcol)
8056 ip(mcol)=mtmp
8057 ENDIF
8058C...Begin eliminating equations
8059 DO 220 ibin=ired+1,nbin
8060 IF(abs(wtmat(ired,ired)).LT.1d-20) THEN
8061 msolv=0
8062 GOTO 260
8063 ENDIF
8064C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8065 rqtu=wtmat(ibin,ired)
8066 rqtl=wtmat(ired,ired)
8067C...Switch order of operations
8068 wtrel(ibin)=wtrel(ibin)-rqtu*
8069 $ (wtrel(ired)/rqtl)
8070 DO 210 icoe=ired,nbin
8071 wtmat(ibin,icoe)=wtmat(ibin,icoe)-
8072 $ rqtu*(wtmat(ired,icoe)/rqtl)
8073 210 CONTINUE
8074 220 CONTINUE
8075 230 CONTINUE
8076 DO 250 ired=nbin,1,-1
8077 DO 240 icoe=ired+1,nbin
8078 wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)
8079 240 CONTINUE
8080 IF(abs(wtmat(ired,ired)).LT.1d-20) THEN
8081 msolv=0
8082 GOTO 260
8083 ENDIF
8084 coefu(ired)=wtrel(ired)/wtmat(ired,ired)
8085 tempc(ired)=coefu(ired)
8086 250 CONTINUE
8087C...Return to original order
8088 DO ibin=1,nbin
8089 mtmp=ip(ibin)
8090 coefu(mtmp)=tempc(ibin)
8091 ENDDO
8092 ENDIF
8093
8094C...Share evenly if failure.
8095 260 IF(msolv.EQ.0) THEN
8096 DO 270 ibin=1,nbin
8097 coefu(ibin)=1d0
8098 wtreln(ibin)=0.1d0
8099 IF(wtrels.GT.0d0) wtreln(ibin)=max(0.1d0,
8100 & wtrsav(ibin)/wtrels)
8101 270 CONTINUE
8102 ENDIF
8103
8104C...Normalize coefficients, with piece shared democratically.
8105 coefsu=0d0
8106 wtrels=0d0
8107 DO 280 ibin=1,nbin
8108 coefu(ibin)=max(0d0,coefu(ibin))
8109 coefsu=coefsu+coefu(ibin)
8110 wtrels=wtrels+wtreln(ibin)
8111 280 CONTINUE
8112 IF(coefsu.GT.0d0) THEN
8113 DO 290 ibin=1,nbin
8114 coefo(ibin)=parp(122)/nbin+(1d0-parp(122))*0.5d0*
8115 & (coefu(ibin)/coefsu+wtreln(ibin)/wtrels)
8116 290 CONTINUE
8117 ELSE
8118 DO 300 ibin=1,nbin
8119 coefo(ibin)=1d0/nbin
8120 300 CONTINUE
8121 ENDIF
8122 IF(ivar.EQ.1) ioff=0
8123 IF(ivar.EQ.2) ioff=17
8124 IF(ivar.EQ.3) ioff=7
8125 IF(ivar.EQ.4) ioff=12
8126 DO 310 ibin=1,nbin
8127 icof=ioff+ibin
8128 IF(ivar.EQ.1) THEN
8129 IF(ibin.EQ.nbin.AND.(mint(72).LE.2.AND.ipeak7.EQ.1)) THEN
8130 icof=7
8131 ENDIF
8132 ENDIF
8133 IF(ivar.EQ.3.AND.ibin.EQ.4.AND.mint(45).NE.3) icof=icof+1
8134 IF(ivar.EQ.1.AND.ibin.GE.7+ipeak7.AND.mint(72).EQ.3) THEN
8135 coefx(isub,ibin-6-ipeak7)=coefo(ibin)
8136 ELSE
8137 coef(isub,icof)=coefo(ibin)
8138 ENDIF
8139 310 CONTINUE
8140
8141 IF(mstp(122).GE.2) WRITE(mstu(11),5600) cvar(ivar),
8142 & (coefo(ibin),ibin=1,nbin)
8143
8144 320 CONTINUE
8145
8146C...Find two most promising maxima among points previously determined.
8147 DO 330 j=1,4
8148 iaccmx(j)=0
8149 sigsmx(j)=0d0
8150 330 CONTINUE
8151 nmax=0
8152 DO 390 iacc=1,nacc
8153 DO 340 j=1,30
8154 vint(10+j)=vintpt(iacc,j)
8155 340 CONTINUE
8156 IF(istsb.NE.5) THEN
8157 CALL pysigh(nchn,sigs)
8158 IF(mwtxs.EQ.1) THEN
8159 CALL pyevwt(wtxs)
8160 sigs=wtxs*sigs
8161 ENDIF
8162 ELSE
8163 sigs=0d0
8164 DO 350 ikin3=1,mstp(129)
8165 CALL pykmap(5,0,0d0)
8166 IF(mint(51).EQ.1) GOTO 350
8167 CALL pysigh(nchn,sigtmp)
8168 IF(mwtxs.EQ.1) THEN
8169 CALL pyevwt(wtxs)
8170 sigtmp=wtxs*sigtmp
8171 ENDIF
8172 IF(sigtmp.GT.sigs) sigs=sigtmp
8173 350 CONTINUE
8174 ENDIF
8175 ieq=0
8176 DO 360 imv=1,nmax
8177 IF(abs(sigs-sigsmx(imv)).LT.1d-4*(sigs+sigsmx(imv))) ieq=imv
8178 360 CONTINUE
8179 IF(ieq.EQ.0) THEN
8180 DO 370 imv=nmax,1,-1
8181 iin=imv+1
8182 IF(sigs.LE.sigsmx(imv)) GOTO 380
8183 iaccmx(imv+1)=iaccmx(imv)
8184 sigsmx(imv+1)=sigsmx(imv)
8185 370 CONTINUE
8186 iin=1
8187 380 iaccmx(iin)=iacc
8188 sigsmx(iin)=sigs
8189 IF(nmax.LE.1) nmax=nmax+1
8190 ENDIF
8191 390 CONTINUE
8192
8193C...Read out starting position for search.
8194 IF(mstp(122).GE.2) WRITE(mstu(11),5700)
8195 sigsam=sigsmx(1)
8196 DO 440 imax=1,nmax
8197 iacc=iaccmx(imax)
8198 mtau=mvarpt(iacc,1)
8199 mtaup=mvarpt(iacc,2)
8200 myst=mvarpt(iacc,3)
8201 mcth=mvarpt(iacc,4)
8202 vtau=0.5d0
8203 vyst=0.5d0
8204 vcth=0.5d0
8205 vtaup=0.5d0
8206
8207C...Starting point and step size in parameter space.
8208 DO 430 irpt=1,2
8209 DO 420 ivar=1,4
8210 IF(npts(ivar).EQ.1) GOTO 420
8211 IF(ivar.EQ.1) vvar=vtau
8212 IF(ivar.EQ.2) vvar=vtaup
8213 IF(ivar.EQ.3) vvar=vyst
8214 IF(ivar.EQ.4) vvar=vcth
8215 IF(ivar.EQ.1) mvar=mtau
8216 IF(ivar.EQ.2) mvar=mtaup
8217 IF(ivar.EQ.3) mvar=myst
8218 IF(ivar.EQ.4) mvar=mcth
8219 IF(irpt.EQ.1) vdel=0.1d0
8220 IF(irpt.EQ.2) vdel=max(0.01d0,min(0.05d0,vvar-0.02d0,
8221 & 0.98d0-vvar))
8222 IF(irpt.EQ.1) vmar=0.02d0
8223 IF(irpt.EQ.2) vmar=0.002d0
8224 imov0=1
8225 IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0
8226 DO 410 imov=imov0,8
8227
8228C...Define new point in parameter space.
8229 IF(imov.EQ.0) THEN
8230 inew=2
8231 vnew=vvar
8232 ELSEIF(imov.EQ.1) THEN
8233 inew=3
8234 vnew=vvar+vdel
8235 ELSEIF(imov.EQ.2) THEN
8236 inew=1
8237 vnew=vvar-vdel
8238 ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND.
8239 & vvar+2d0*vdel.LT.1d0-vmar) THEN
8240 vvar=vvar+vdel
8241 sigssm(1)=sigssm(2)
8242 sigssm(2)=sigssm(3)
8243 inew=3
8244 vnew=vvar+vdel
8245 ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND.
8246 & vvar-2d0*vdel.GT.vmar) THEN
8247 vvar=vvar-vdel
8248 sigssm(3)=sigssm(2)
8249 sigssm(2)=sigssm(1)
8250 inew=1
8251 vnew=vvar-vdel
8252 ELSEIF(sigssm(3).GE.sigssm(1)) THEN
8253 vdel=0.5d0*vdel
8254 vvar=vvar+vdel
8255 sigssm(1)=sigssm(2)
8256 inew=2
8257 vnew=vvar
8258 ELSE
8259 vdel=0.5d0*vdel
8260 vvar=vvar-vdel
8261 sigssm(3)=sigssm(2)
8262 inew=2
8263 vnew=vvar
8264 ENDIF
8265
8266C...Convert to relevant variables and find derived new limits.
8267 ilerr=0
8268 IF(ivar.EQ.1) THEN
8269 vtau=vnew
8270 CALL pykmap(1,mtau,vtau)
8271 IF(istsb.GE.3.AND.istsb.LE.5) THEN
8272 CALL pyklim(4)
8273 IF(mint(51).EQ.1) ilerr=1
8274 ENDIF
8275 ENDIF
8276 IF(ivar.LE.2.AND.istsb.GE.3.AND.istsb.LE.5.AND.
8277 & ilerr.EQ.0) THEN
8278 IF(ivar.EQ.2) vtaup=vnew
8279 CALL pykmap(4,mtaup,vtaup)
8280 ENDIF
8281 IF(ivar.LE.2.AND.ilerr.EQ.0) THEN
8282 CALL pyklim(2)
8283 IF(mint(51).EQ.1) ilerr=1
8284 ENDIF
8285 IF(ivar.LE.3.AND.ilerr.EQ.0) THEN
8286 IF(ivar.EQ.3) vyst=vnew
8287 CALL pykmap(2,myst,vyst)
8288 CALL pyklim(3)
8289 IF(mint(51).EQ.1) ilerr=1
8290 ENDIF
8291 IF((istsb.EQ.2.OR.istsb.EQ.4.OR.istsb.EQ.6).AND.
8292 & ilerr.EQ.0) THEN
8293 IF(ivar.EQ.4) vcth=vnew
8294 CALL pykmap(3,mcth,vcth)
8295 ENDIF
8296 IF(isub.EQ.96) vint(25)=vint(21)*(1.-vint(23)**2)
8297
8298C...Evaluate cross-section. Save new maximum. Final maximum.
8299 IF(ilerr.NE.0) THEN
8300 sigs=0.
8301 ELSEIF(istsb.NE.5) THEN
8302 CALL pysigh(nchn,sigs)
8303 IF(mwtxs.EQ.1) THEN
8304 CALL pyevwt(wtxs)
8305 sigs=wtxs*sigs
8306 ENDIF
8307 ELSE
8308 sigs=0d0
8309 DO 400 ikin3=1,mstp(129)
8310 CALL pykmap(5,0,0d0)
8311 IF(mint(51).EQ.1) GOTO 400
8312 CALL pysigh(nchn,sigtmp)
8313 IF(mwtxs.EQ.1) THEN
8314 CALL pyevwt(wtxs)
8315 sigtmp=wtxs*sigtmp
8316 ENDIF
8317 IF(sigtmp.GT.sigs) sigs=sigtmp
8318 400 CONTINUE
8319 ENDIF
8320 sigssm(inew)=sigs
8321 IF(sigs.GT.sigsam) sigsam=sigs
8322 IF(mstp(122).GE.2) WRITE(mstu(11),5800) imax,ivar,mvar,
8323 & imov,vnew,vint(21),vint(22),vint(23),vint(26),sigs
8324 410 CONTINUE
8325 420 CONTINUE
8326 430 CONTINUE
8327 440 CONTINUE
8328 IF(mstp(121).EQ.1) sigsam=parp(121)*sigsam
8329 xsec(isub,1)=1.05d0*sigsam
8330C...Add extra headroom for UED
8331 IF(isub.GT.310.AND.isub.LT.320) xsec(isub,1)=xsec(isub,1)*1.1d0
8332 IF(mint(141).NE.0.OR.mint(142).NE.0) xsec(isub,1)=
8333 & wtgaga*xsec(isub,1)
8334 450 CONTINUE
8335 IF(mstp(173).EQ.1.AND.isub.NE.96) xsec(isub,1)=
8336 & parp(174)*xsec(isub,1)
8337 IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)
8338 460 CONTINUE
8339 mint(51)=0
8340
8341C...Print summary table.
8342 IF(mint(121).EQ.1.AND.nposi.EQ.0) THEN
8343 IF(mstp(127).NE.1) THEN
8344 WRITE(mstu(11),5900)
8345 CALL pystop(1)
8346 ELSE
8347 WRITE(mstu(11),6400)
8348 msti(53)=1
8349 ENDIF
8350 ENDIF
8351 IF(mstp(122).GE.1) THEN
8352 WRITE(mstu(11),6000)
8353 WRITE(mstu(11),6100)
8354 DO 470 isub=1,500
8355 IF(msub(isub).NE.1.AND.isub.NE.96) GOTO 470
8356 IF(isub.EQ.96.AND.mint(50).EQ.0) GOTO 470
8357 IF(isub.EQ.96.AND.msub(95).NE.1.AND.mod(mstp(81),10).LE.0)
8358 & GOTO 470
8359 IF(isub.EQ.96.AND.mint(49).EQ.0.AND.mstp(131).EQ.0) GOTO 470
8360 IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13
8361 & .OR.isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) GOTO 470
8362 IF(msub(95).EQ.1.AND.isub.GE.381.AND.isub.LE.386) GOTO 470
8363 WRITE(mstu(11),6200) isub,proc(isub),xsec(isub,1)
8364 470 CONTINUE
8365 WRITE(mstu(11),6300)
8366 ENDIF
8367
8368C...Format statements for maximization results.
8369 5000 FORMAT(/1x,'Coefficient optimization and maximum search for ',
8370 &'subprocess no',i4/1x,'Coefficient modes tau',10x,'y*',9x,
8371 &'cth',9x,'tau''',7x,'sigma')
8372 5100 FORMAT(1x,'Warning: requested subprocess ',i3,' has no allowed ',
8373 &'phase space.'/1x,'Process switched off!')
8374 5200 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,d12.4)
8375 5300 FORMAT(1x,'Warning: requested subprocess ',i3,' has vanishing ',
8376 &'cross-section.'/1x,'Process switched off!')
8377 5400 FORMAT(1x,'Coefficients of equation system to be solved for ',a4)
8378 5500 FORMAT(1x,1p,10d11.3)
8379 5600 FORMAT(1x,'Result for ',a4,':',9f9.4)
8380 5700 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',
8381 &'MOD MOV VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma')
8382 5800 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,d12.4)
8383 5900 FORMAT(1x,'Error: no requested process has non-vanishing ',
8384 &'cross-section.'/1x,'Execution stopped!')
8385 6000 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',
8386 &'cross-section maximum search',1x,8('*'))
8387 6100 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I ISUB ',
8388 &'Subprocess name',15x,'I Maximum value I'/11x,'I',38x,'I',
8389 &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')
8390 6200 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,d12.4,3x,'I')
8391 6300 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))
8392 6400 FORMAT(1x,'Error: no requested process has non-vanishing ',
8393 &'cross-section.'/
8394 &1x,'Execution will stop if you try to generate events.')
8395
8396 RETURN
8397 END
8398
8399C*********************************************************************
8400
8401C...PYPILE
8402C...Initializes multiplicity distribution and selects mutliplicity
8403C...of pileup events, i.e. several events occuring at the same
8404C...beam crossing.
8405
8406 SUBROUTINE pypile(MPILE)
8407
8408C...Double precision and integer declarations.
8409 IMPLICIT DOUBLE PRECISION(a-h, o-z)
8410 IMPLICIT INTEGER(I-N)
8411 INTEGER PYK,PYCHGE,PYCOMP
8412C...Commonblocks.
8413 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
8414 common/pypars/mstp(200),parp(200),msti(200),pari(200)
8415 common/pyint1/mint(400),vint(400)
8416 common/pyint7/sigt(0:6,0:6,0:5)
8417 SAVE /pydat1/,/pypars/,/pyint1/,/pyint7/
8418C...Local arrays and saved variables.
8419 dimension wti(0:200)
8420 SAVE imin,imax,wti,wts
8421
8422C...Sum of allowed cross-sections for pileup events.
8423 IF(mpile.EQ.1) THEN
8424 vint(131)=sigt(0,0,5)
8425 IF(mstp(132).GE.2) vint(131)=vint(131)+sigt(0,0,4)
8426 IF(mstp(132).GE.3) vint(131)=vint(131)+sigt(0,0,2)+sigt(0,0,3)
8427 IF(mstp(132).GE.4) vint(131)=vint(131)+sigt(0,0,1)
8428 IF(mstp(133).LE.0) RETURN
8429
8430C...Initialize multiplicity distribution at maximum.
8431 xnave=vint(131)*parp(131)
8432 IF(xnave.GT.120d0) WRITE(mstu(11),5000) xnave
8433 inave=max(1,min(200,nint(xnave)))
8434 wti(inave)=1d0
8435 wts=wti(inave)
8436 wtn=wti(inave)*inave
8437
8438C...Find shape of multiplicity distribution below maximum.
8439 imin=inave
8440 DO 100 i=inave-1,1,-1
8441 IF(mstp(133).EQ.1) wti(i)=wti(i+1)*(i+1)/xnave
8442 IF(mstp(133).GE.2) wti(i)=wti(i+1)*i/xnave
8443 IF(wti(i).LT.1d-6) GOTO 110
8444 wts=wts+wti(i)
8445 wtn=wtn+wti(i)*i
8446 imin=i
8447 100 CONTINUE
8448
8449C...Find shape of multiplicity distribution above maximum.
8450 110 imax=inave
8451 DO 120 i=inave+1,200
8452 IF(mstp(133).EQ.1) wti(i)=wti(i-1)*xnave/i
8453 IF(mstp(133).GE.2) wti(i)=wti(i-1)*xnave/(i-1)
8454 IF(wti(i).LT.1d-6) GOTO 130
8455 wts=wts+wti(i)
8456 wtn=wtn+wti(i)*i
8457 imax=i
8458 120 CONTINUE
8459 130 vint(132)=xnave
8460 vint(133)=wtn/wts
8461 IF(mstp(133).EQ.1.AND.imin.EQ.1) vint(134)=
8462 & wts/(wts+wti(1)/xnave)
8463 IF(mstp(133).EQ.1.AND.imin.GT.1) vint(134)=1d0
8464 IF(mstp(133).GE.2) vint(134)=xnave
8465
8466C...Pick multiplicity of pileup events.
8467 ELSE
8468 IF(mstp(133).LE.0) THEN
8469 mint(81)=max(1,mstp(134))
8470 ELSE
8471 wtr=wts*pyr(0)
8472 DO 140 i=imin,imax
8473 mint(81)=i
8474 wtr=wtr-wti(i)
8475 IF(wtr.LE.0d0) GOTO 150
8476 140 CONTINUE
8477 150 CONTINUE
8478 ENDIF
8479 ENDIF
8480
8481C...Format statement for error message.
8482 5000 FORMAT(1x,'Warning: requested average number of events per bunch',
8483 &'crossing too large, ',1p,d12.4)
8484
8485 RETURN
8486 END
8487
8488C*********************************************************************
8489
8490C...PYSAVE
8491C...Saves and restores parameter and cross section values for the
8492C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8493C...Also makes random choice between alternatives.
8494
8495 SUBROUTINE pysave(ISAVE,IGA)
8496
8497C...Double precision and integer declarations.
8498 IMPLICIT DOUBLE PRECISION(a-h, o-z)
8499 IMPLICIT INTEGER(I-N)
8500 INTEGER PYK,PYCHGE,PYCOMP
8501C...Commonblocks.
8502 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
8503 common/pypars/mstp(200),parp(200),msti(200),pari(200)
8504 common/pyint1/mint(400),vint(400)
8505 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
8506 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
8507 common/pyint7/sigt(0:6,0:6,0:5)
8508 SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint5/,/pyint7/
8509C...Local arrays and saved variables.
8510 dimension ncp(15),nsubcp(15,20),msubcp(15,20),coefcp(15,20,20),
8511 &ngencp(15,0:20,3),xseccp(15,0:20,3),sigtcp(15,0:6,0:6,0:5),
8512 &intcp(15,20),recp(15,20)
8513 SAVE ncp,nsubcp,msubcp,coefcp,ngencp,xseccp,sigtcp,intcp,recp
8514
8515C...Save list of subprocesses and cross-section information.
8516 IF(isave.EQ.1) THEN
8517 icp=0
8518 DO 120 i=1,500
8519 IF(msub(i).EQ.0.AND.i.NE.96.AND.i.NE.97) GOTO 120
8520 icp=icp+1
8521 nsubcp(iga,icp)=i
8522 msubcp(iga,icp)=msub(i)
8523 DO 100 j=1,20
8524 coefcp(iga,icp,j)=coef(i,j)
8525 100 CONTINUE
8526 DO 110 j=1,3
8527 ngencp(iga,icp,j)=ngen(i,j)
8528 xseccp(iga,icp,j)=xsec(i,j)
8529 110 CONTINUE
8530 120 CONTINUE
8531 ncp(iga)=icp
8532 DO 130 j=1,3
8533 ngencp(iga,0,j)=ngen(0,j)
8534 xseccp(iga,0,j)=xsec(0,j)
8535 130 CONTINUE
8536 DO 160 i1=0,6
8537 DO 150 i2=0,6
8538 DO 140 j=0,5
8539 sigtcp(iga,i1,i2,j)=sigt(i1,i2,j)
8540 140 CONTINUE
8541 150 CONTINUE
8542 160 CONTINUE
8543
8544C...Save various common process variables.
8545 DO 170 j=1,10
8546 intcp(iga,j)=mint(40+j)
8547 170 CONTINUE
8548 intcp(iga,11)=mint(101)
8549 intcp(iga,12)=mint(102)
8550 intcp(iga,13)=mint(107)
8551 intcp(iga,14)=mint(108)
8552 intcp(iga,15)=mint(123)
8553 recp(iga,1)=ckin(3)
8554 recp(iga,2)=vint(318)
8555
8556C...Save cross-section information only.
8557 ELSEIF(isave.EQ.2) THEN
8558 DO 190 icp=1,ncp(iga)
8559 i=nsubcp(iga,icp)
8560 DO 180 j=1,3
8561 ngencp(iga,icp,j)=ngen(i,j)
8562 xseccp(iga,icp,j)=xsec(i,j)
8563 180 CONTINUE
8564 190 CONTINUE
8565 DO 200 j=1,3
8566 ngencp(iga,0,j)=ngen(0,j)
8567 xseccp(iga,0,j)=xsec(0,j)
8568 200 CONTINUE
8569
8570C...Choose between allowed alternatives.
8571 ELSEIF(isave.EQ.3.OR.isave.EQ.4) THEN
8572 IF(isave.EQ.4) THEN
8573 xsumcp=0d0
8574 DO 210 ig=1,mint(121)
8575 xsumcp=xsumcp+xseccp(ig,0,1)
8576 210 CONTINUE
8577 xsumcp=xsumcp*pyr(0)
8578 DO 220 ig=1,mint(121)
8579 iga=ig
8580 xsumcp=xsumcp-xseccp(ig,0,1)
8581 IF(xsumcp.LE.0d0) GOTO 230
8582 220 CONTINUE
8583 230 CONTINUE
8584 ENDIF
8585
8586C...Restore cross-section information.
8587 DO 240 i=1,500
8588 msub(i)=0
8589 240 CONTINUE
8590 DO 270 icp=1,ncp(iga)
8591 i=nsubcp(iga,icp)
8592 msub(i)=msubcp(iga,icp)
8593 DO 250 j=1,20
8594 coef(i,j)=coefcp(iga,icp,j)
8595 250 CONTINUE
8596 DO 260 j=1,3
8597 ngen(i,j)=ngencp(iga,icp,j)
8598 xsec(i,j)=xseccp(iga,icp,j)
8599 260 CONTINUE
8600 270 CONTINUE
8601 DO 280 j=1,3
8602 ngen(0,j)=ngencp(iga,0,j)
8603 xsec(0,j)=xseccp(iga,0,j)
8604 280 CONTINUE
8605 DO 310 i1=0,6
8606 DO 300 i2=0,6
8607 DO 290 j=0,5
8608 sigt(i1,i2,j)=sigtcp(iga,i1,i2,j)
8609 290 CONTINUE
8610 300 CONTINUE
8611 310 CONTINUE
8612
8613C...Restore various common process variables.
8614 DO 320 j=1,10
8615 mint(40+j)=intcp(iga,j)
8616 320 CONTINUE
8617 mint(101)=intcp(iga,11)
8618 mint(102)=intcp(iga,12)
8619 mint(107)=intcp(iga,13)
8620 mint(108)=intcp(iga,14)
8621 mint(123)=intcp(iga,15)
8622 ckin(3)=recp(iga,1)
8623 ckin(1)=2d0*ckin(3)
8624 vint(318)=recp(iga,2)
8625
8626C...Sum up cross-section info (for PYSTAT).
8627 ELSEIF(isave.EQ.5) THEN
8628 DO 330 i=1,500
8629 msub(i)=0
8630 ngen(i,1)=0
8631 ngen(i,3)=0
8632 xsec(i,3)=0d0
8633 330 CONTINUE
8634 ngen(0,1)=0
8635 ngen(0,2)=0
8636 ngen(0,3)=0
8637 xsec(0,3)=0
8638 DO 350 ig=1,mint(121)
8639 DO 340 icp=1,ncp(ig)
8640 i=nsubcp(ig,icp)
8641 IF(msubcp(ig,icp).EQ.1) msub(i)=1
8642 ngen(i,1)=ngen(i,1)+ngencp(ig,icp,1)
8643 ngen(i,3)=ngen(i,3)+ngencp(ig,icp,3)
8644 xsec(i,3)=xsec(i,3)+xseccp(ig,icp,3)
8645 340 CONTINUE
8646 ngen(0,1)=ngen(0,1)+ngencp(ig,0,1)
8647 ngen(0,2)=ngen(0,2)+ngencp(ig,0,2)
8648 ngen(0,3)=ngen(0,3)+ngencp(ig,0,3)
8649 xsec(0,3)=xsec(0,3)+xseccp(ig,0,3)
8650 350 CONTINUE
8651 ENDIF
8652
8653 RETURN
8654 END
8655
8656C*********************************************************************
8657
8658C...PYGAGA
8659C...For lepton beams it gives photon-hadron or photon-photon systems
8660C...to be treated with the ordinary machinery and combines this with a
8661C...description of the lepton -> lepton + photon branching.
8662
8663 SUBROUTINE pygaga(IGAGA,WTGAGA)
8664
8665C...Double precision and integer declarations.
8666 IMPLICIT DOUBLE PRECISION(a-h, o-z)
8667 IMPLICIT INTEGER(I-N)
8668 INTEGER PYK,PYCHGE,PYCOMP
8669C...Commonblocks.
8670 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
8671 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
8672 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
8673 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
8674 common/pypars/mstp(200),parp(200),msti(200),pari(200)
8675 common/pyint1/mint(400),vint(400)
8676 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
8677 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
8678 &/pyint5/
8679C...Local variables and data statement.
8680 dimension pms(2),xmin(2),xmax(2),q2min(2),q2max(2),pmc(3),
8681 &x(2),q2(2),y(2),theta(2),phi(2),pt(2),beta(3)
8682 SAVE pms,xmin,xmax,q2min,q2max,pmc,x,q2,theta,phi,pt,w2min
8683 DATA eps/1d-4/
8684
8685C...Initialize generation of photons inside leptons.
8686 IF(igaga.EQ.1) THEN
8687
8688C...Save quantities on incoming lepton system.
8689 vint(301)=vint(1)
8690 vint(302)=vint(2)
8691 pms(1)=vint(303)**2
8692 IF(mint(141).EQ.0) pms(1)=sign(vint(3)**2,vint(3))
8693 pms(2)=vint(304)**2
8694 IF(mint(142).EQ.0) pms(2)=sign(vint(4)**2,vint(4))
8695 pmc(3)=vint(302)-pms(1)-pms(2)
8696 w2min=max(ckin(77),2d0*ckin(3),2d0*ckin(5))**2
8697
8698C...Calculate range of x and Q2 values allowed in generation.
8699 DO 100 i=1,2
8700 pmc(i)=vint(302)+pms(i)-pms(3-i)
8701 IF(mint(140+i).NE.0) THEN
8702 xmin(i)=max(ckin(59+2*i),eps)
8703 xmax(i)=min(ckin(60+2*i),1d0-2d0*vint(301)*sqrt(pms(i))/
8704 & pmc(i),1d0-eps)
8705 ymin=max(ckin(71+2*i),eps)
8706 ymax=min(ckin(72+2*i),1d0-eps)
8707 IF(ckin(64+2*i).GT.0d0) xmin(i)=max(xmin(i),
8708 & (ymin*pmc(3)-ckin(64+2*i))/pmc(i))
8709 xmax(i)=min(xmax(i),(ymax*pmc(3)-ckin(63+2*i))/pmc(i))
8710 themin=max(ckin(67+2*i),0d0)
8711 themax=min(ckin(68+2*i),paru(1))
8712 IF(ckin(68+2*i).LT.0d0) themax=paru(1)
8713 q2min(i)=max(ckin(63+2*i),xmin(i)**2*pms(i)/(1d0-xmin(i))+
8714 & ((1d0-xmax(i))*(vint(302)-2d0*pms(3-i))-
8715 & 2d0*pms(i)/(1d0-xmax(i)))*sin(themin/2d0)**2,0d0)
8716 q2max(i)=xmax(i)**2*pms(i)/(1d0-xmax(i))+
8717 & ((1d0-xmin(i))*(vint(302)-2d0*pms(3-i))-
8718 & 2d0*pms(i)/(1d0-xmin(i)))*sin(themax/2d0)**2
8719 IF(ckin(64+2*i).GT.0d0) q2max(i)=min(ckin(64+2*i),q2max(i))
8720C...W limits when lepton on one side only.
8721 IF(mint(143-i).EQ.0) THEN
8722 xmin(i)=max(xmin(i),(w2min-pms(3-i))/pmc(i))
8723 IF(ckin(78).GT.0d0) xmax(i)=min(xmax(i),
8724 & (ckin(78)**2-pms(3-i))/pmc(i))
8725 ENDIF
8726 ENDIF
8727 100 CONTINUE
8728
8729C...W limits when lepton on both sides.
8730 IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
8731 IF(ckin(78).GT.0d0) xmax(1)=min(xmax(1),
8732 & (ckin(78)**2+pmc(3)-pmc(2)*xmin(2))/pmc(1))
8733 IF(ckin(78).GT.0d0) xmax(2)=min(xmax(2),
8734 & (ckin(78)**2+pmc(3)-pmc(1)*xmin(1))/pmc(2))
8735 IF(iabs(mint(141)).NE.iabs(mint(142))) THEN
8736 xmin(1)=max(xmin(1),(pms(1)-pms(2)+vint(302)*(w2min-
8737 & pms(1)-pms(2))/(pmc(2)*xmax(2)+pms(1)-pms(2)))/pmc(1))
8738 xmin(2)=max(xmin(2),(pms(2)-pms(1)+vint(302)*(w2min-
8739 & pms(1)-pms(2))/(pmc(1)*xmax(1)+pms(2)-pms(1)))/pmc(2))
8740 ELSE
8741 xmin(1)=max(xmin(1),w2min/(vint(302)*xmax(2)))
8742 xmin(2)=max(xmin(2),w2min/(vint(302)*xmax(1)))
8743 ENDIF
8744 ENDIF
8745
8746C...Q2 and W values and photon flux weight factors for initialization.
8747 ELSEIF(igaga.EQ.2) THEN
8748 isub=mint(1)
8749 mint(15)=0
8750 mint(16)=0
8751
8752C...W value for photon on one or both sides, and for processes
8753C...with gamma-gamma cross section peaked at small shat.
8754 IF(mint(141).NE.0.AND.mint(142).EQ.0) THEN
8755 vint(2)=vint(302)+pms(1)-pmc(1)*(1d0-xmax(1))
8756 ELSEIF(mint(141).EQ.0.AND.mint(142).NE.0) THEN
8757 vint(2)=vint(302)+pms(2)-pmc(2)*(1d0-xmax(2))
8758 ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
8759 vint(2)=max(ckin(77)**2,12d0*max(ckin(3),ckin(5))**2)
8760 IF(ckin(78).GT.0d0) vint(2)=min(vint(2),ckin(78)**2)
8761 ELSE
8762 vint(2)=xmax(1)*xmax(2)*vint(302)
8763 IF(ckin(78).GT.0d0) vint(2)=min(vint(2),ckin(78)**2)
8764 ENDIF
8765 vint(1)=sqrt(max(0d0,vint(2)))
8766
8767C...Upper estimate of photon flux weight factor.
8768C...Initialization Q2 scale. Flag incoming unresolved photon.
8769 wtgaga=1d0
8770 DO 110 i=1,2
8771 IF(mint(140+i).NE.0) THEN
8772 wtgaga=wtgaga*2d0*(paru(101)/paru(2))*
8773 & log(xmax(i)/xmin(i))*log(q2max(i)/q2min(i))
8774 IF(isub.EQ.99.AND.mint(106+i).EQ.4.AND.mint(109-i).EQ.3)
8775 & THEN
8776 q2init=5d0+q2min(3-i)
8777 ELSEIF(isub.EQ.99.AND.mint(106+i).EQ.4) THEN
8778 q2init=pmas(pycomp(113),1)**2+q2min(3-i)
8779 ELSEIF(isub.EQ.132.OR.isub.EQ.134.OR.isub.EQ.136) THEN
8780 q2init=max(ckin(1),2d0*ckin(3),2d0*ckin(5))**2/3d0
8781 ELSEIF((isub.EQ.138.AND.i.EQ.2).OR.
8782 & (isub.EQ.139.AND.i.EQ.1)) THEN
8783 q2init=vint(2)/3d0
8784 ELSEIF(isub.EQ.140) THEN
8785 q2init=vint(2)/2d0
8786 ELSE
8787 q2init=q2min(i)
8788 ENDIF
8789 vint(2+i)=-sqrt(max(q2min(i),min(q2max(i),q2init)))
8790 IF(mstp(14).EQ.0.OR.(isub.GE.131.AND.isub.LE.140))
8791 & mint(14+i)=22
8792 vint(306+i)=vint(2+i)**2
8793 ENDIF
8794 110 CONTINUE
8795 vint(320)=wtgaga
8796
8797C...Update pTmin and cross section information.
8798 IF(mstp(82).LE.1) THEN
8799 ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
8800 ELSE
8801 ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
8802 ENDIF
8803 vint(149)=4d0*ptmn**2/vint(2)
8804 vint(154)=ptmn
8805 CALL pyxtot
8806 vint(318)=vint(317)
8807
8808C...Generate photons inside leptons and
8809C...calculate photon flux weight factors.
8810 ELSEIF(igaga.EQ.3) THEN
8811 isub=mint(1)
8812 mint(15)=0
8813 mint(16)=0
8814
8815C...Generate phase space point and check against cuts.
8816 loop=0
8817 120 loop=loop+1
8818 DO 130 i=1,2
8819 IF(mint(140+i).NE.0) THEN
8820C...Pick x and Q2
8821 x(i)=xmin(i)*(xmax(i)/xmin(i))**pyr(0)
8822 q2(i)=q2min(i)*(q2max(i)/q2min(i))**pyr(0)
8823C...Cuts on internal consistency in x and Q2.
8824 IF(q2(i).LT.x(i)**2*pms(i)/(1d0-x(i))) GOTO 120
8825 IF(q2(i).GT.(1d0-x(i))*(vint(302)-2d0*pms(3-i))-
8826 & (2d0-x(i)**2)*pms(i)/(1d0-x(i))) GOTO 120
8827C...Cuts on y and theta.
8828 y(i)=(pmc(i)*x(i)+q2(i))/pmc(3)
8829 IF(y(i).LT.ckin(71+2*i).OR.y(i).GT.ckin(72+2*i)) GOTO 120
8830 rat=((1d0-x(i))*q2(i)-x(i)**2*pms(i))/
8831 & ((1d0-x(i))**2*(vint(302)-2d0*pms(3-i)-2d0*pms(i)))
8832 theta(i)=2d0*asin(sqrt(max(0d0,min(1d0,rat))))
8833 IF(theta(i).LT.ckin(67+2*i)) GOTO 120
8834 IF(ckin(68+2*i).GT.0d0.AND.theta(i).GT.ckin(68+2*i))
8835 & GOTO 120
8836
8837C...Phi angle isotropic. Reconstruct pT.
8838 phi(i)=paru(2)*pyr(0)
8839 pt(i)=sqrt(((1d0-x(i))*pmc(i))**2/(4d0*vint(302))-
8840 & pms(i))*sin(theta(i))
8841
8842C...Store info on variables selected, for documentation purposes.
8843 vint(2+i)=-sqrt(q2(i))
8844 vint(304+i)=x(i)
8845 vint(306+i)=q2(i)
8846 vint(308+i)=y(i)
8847 vint(310+i)=theta(i)
8848 vint(312+i)=phi(i)
8849 ELSE
8850 vint(304+i)=1d0
8851 vint(306+i)=0d0
8852 vint(308+i)=1d0
8853 vint(310+i)=0d0
8854 vint(312+i)=0d0
8855 ENDIF
8856 130 CONTINUE
8857
8858C...Cut on W combines info from two sides.
8859 IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
8860 w2=-q2(1)-q2(2)+0.5d0*x(1)*pmc(1)*x(2)*pmc(2)/vint(302)-
8861 & 2d0*pt(1)*pt(2)*cos(phi(1)-phi(2))+2d0*
8862 & sqrt((0.5d0*x(1)*pmc(1)/vint(301))**2+q2(1)-pt(1)**2)*
8863 & sqrt((0.5d0*x(2)*pmc(2)/vint(301))**2+q2(2)-pt(2)**2)
8864 IF(w2.LT.w2min) GOTO 120
8865 IF(ckin(78).GT.0d0.AND.w2.GT.ckin(78)**2) GOTO 120
8866 pms1=-q2(1)
8867 pms2=-q2(2)
8868 ELSEIF(mint(141).NE.0) THEN
8869 w2=(vint(302)+pms(1))*x(1)+pms(2)*(1d0-x(1))
8870 pms1=-q2(1)
8871 pms2=pms(2)
8872 ELSEIF(mint(142).NE.0) THEN
8873 w2=(vint(302)+pms(2))*x(2)+pms(1)*(1d0-x(2))
8874 pms1=pms(1)
8875 pms2=-q2(2)
8876 ENDIF
8877
8878C...Store kinematics info for photon(s) in subsystem cm frame.
8879 vint(2)=w2
8880 vint(1)=sqrt(w2)
8881 vint(291)=0d0
8882 vint(292)=0d0
8883 vint(293)=0.5d0*sqrt((w2-pms1-pms2)**2-4d0*pms1*pms2)/vint(1)
8884 vint(294)=0.5d0*(w2+pms1-pms2)/vint(1)
8885 vint(295)=sign(sqrt(abs(pms1)),pms1)
8886 vint(296)=0d0
8887 vint(297)=0d0
8888 vint(298)=-vint(293)
8889 vint(299)=0.5d0*(w2+pms2-pms1)/vint(1)
8890 vint(300)=sign(sqrt(abs(pms2)),pms2)
8891
8892C...Assign weight for photon flux; different for transverse and
8893C...longitudinal photons. Flag incoming unresolved photon.
8894 wtgaga=1d0
8895 DO 140 i=1,2
8896 IF(mint(140+i).NE.0) THEN
8897 wtgaga=wtgaga*2d0*(paru(101)/paru(2))*
8898 & log(xmax(i)/xmin(i))*log(q2max(i)/q2min(i))
8899 IF(mstp(16).EQ.0) THEN
8900 xy=x(i)
8901 ELSE
8902 wtgaga=wtgaga*x(i)/y(i)
8903 xy=y(i)
8904 ENDIF
8905 IF(isub.EQ.132.OR.isub.EQ.134.OR.isub.EQ.136) THEN
8906 wtgaga=wtgaga*(1d0-xy)
8907 ELSEIF(i.EQ.1.AND.(isub.EQ.139.OR.isub.EQ.140)) THEN
8908 wtgaga=wtgaga*(1d0-xy)
8909 ELSEIF(i.EQ.2.AND.(isub.EQ.138.OR.isub.EQ.140)) THEN
8910 wtgaga=wtgaga*(1d0-xy)
8911 ELSE
8912 wtgaga=wtgaga*(0.5d0*(1d0+(1d0-xy)**2)-
8913 & pms(i)*xy**2/q2(i))
8914 ENDIF
8915 IF(mint(106+i).EQ.0) mint(14+i)=22
8916 ENDIF
8917 140 CONTINUE
8918 vint(319)=wtgaga
8919 mint(143)=loop
8920
8921C...Update pTmin and cross section information.
8922 IF(mstp(82).LE.1) THEN
8923 ptmn=parp(81)*(vint(1)/parp(89))**parp(90)
8924 ELSE
8925 ptmn=parp(82)*(vint(1)/parp(89))**parp(90)
8926 ENDIF
8927 vint(149)=4d0*ptmn**2/vint(2)
8928 vint(154)=ptmn
8929 CALL pyxtot
8930
8931C...Reconstruct kinematics of photons inside leptons.
8932 ELSEIF(igaga.EQ.4) THEN
8933
8934C...Make place for incoming particles and scattered leptons.
8935 move=3
8936 IF(mint(141).NE.0.AND.mint(142).NE.0) move=4
8937 mint(4)=mint(4)+move
8938 DO 160 i=mint(84)-move,mint(83)+1,-1
8939 IF(k(i,1).EQ.21) THEN
8940 DO 150 j=1,5
8941 k(i+move,j)=k(i,j)
8942 p(i+move,j)=p(i,j)
8943 v(i+move,j)=v(i,j)
8944 150 CONTINUE
8945 IF(k(i,3).GT.mint(83).AND.k(i,3).LE.mint(84))
8946 & k(i+move,3)=k(i,3)+move
8947 IF(k(i,4).GT.mint(83).AND.k(i,4).LE.mint(84))
8948 & k(i+move,4)=k(i,4)+move
8949 IF(k(i,5).GT.mint(83).AND.k(i,5).LE.mint(84))
8950 & k(i+move,5)=k(i,5)+move
8951 ENDIF
8952 160 CONTINUE
8953 DO 170 i=mint(84)+1,n
8954 IF(k(i,3).GT.mint(83).AND.k(i,3).LE.mint(84))
8955 & k(i,3)=k(i,3)+move
8956 170 CONTINUE
8957
8958C...Fill in incoming particles.
8959 DO 190 i=mint(83)+1,mint(83)+move
8960 DO 180 j=1,5
8961 k(i,j)=0
8962 p(i,j)=0d0
8963 v(i,j)=0d0
8964 180 CONTINUE
8965 190 CONTINUE
8966 DO 200 i=1,2
8967 k(mint(83)+i,1)=21
8968 IF(mint(140+i).NE.0) THEN
8969 k(mint(83)+i,2)=mint(140+i)
8970 p(mint(83)+i,5)=vint(302+i)
8971 ELSE
8972 k(mint(83)+i,2)=mint(10+i)
8973 p(mint(83)+i,5)=vint(2+i)
8974 ENDIF
8975 p(mint(83)+i,3)=0.5d0*sqrt((pmc(3)**2-4d0*pms(1)*pms(2))/
8976 & vint(302))*(-1d0)**(i+1)
8977 p(mint(83)+i,4)=0.5d0*pmc(i)/vint(301)
8978 200 CONTINUE
8979
8980C...New mother-daughter relations in documentation section.
8981 IF(mint(141).NE.0.AND.mint(142).NE.0) THEN
8982 k(mint(83)+1,4)=mint(83)+3
8983 k(mint(83)+1,5)=mint(83)+5
8984 k(mint(83)+2,4)=mint(83)+4
8985 k(mint(83)+2,5)=mint(83)+6
8986 k(mint(83)+3,3)=mint(83)+1
8987 k(mint(83)+5,3)=mint(83)+1
8988 k(mint(83)+4,3)=mint(83)+2
8989 k(mint(83)+6,3)=mint(83)+2
8990 ELSEIF(mint(141).NE.0) THEN
8991 k(mint(83)+1,4)=mint(83)+3
8992 k(mint(83)+1,5)=mint(83)+4
8993 k(mint(83)+2,4)=mint(83)+5
8994 k(mint(83)+3,3)=mint(83)+1
8995 k(mint(83)+4,3)=mint(83)+1
8996 k(mint(83)+5,3)=mint(83)+2
8997 ELSEIF(mint(142).NE.0) THEN
8998 k(mint(83)+1,4)=mint(83)+4
8999 k(mint(83)+2,4)=mint(83)+3
9000 k(mint(83)+2,5)=mint(83)+5
9001 k(mint(83)+3,3)=mint(83)+2
9002 k(mint(83)+4,3)=mint(83)+1
9003 k(mint(83)+5,3)=mint(83)+2
9004 ENDIF
9005
9006C...Fill scattered lepton(s).
9007 DO 210 i=1,2
9008 IF(mint(140+i).NE.0) THEN
9009 lsc=mint(83)+min(i+2,move)
9010 k(lsc,1)=21
9011 k(lsc,2)=mint(140+i)
9012 p(lsc,1)=pt(i)*cos(phi(i))
9013 p(lsc,2)=pt(i)*sin(phi(i))
9014 p(lsc,4)=(1d0-x(i))*p(mint(83)+i,4)
9015 p(lsc,3)=sqrt(p(lsc,4)**2-pms(i))*cos(theta(i))*
9016 & (-1d0)**(i-1)
9017 p(lsc,5)=vint(302+i)
9018 ENDIF
9019 210 CONTINUE
9020
9021C...Find incoming four-vectors to subprocess.
9022 k(n+1,1)=21
9023 IF(mint(141).NE.0) THEN
9024 DO 220 j=1,4
9025 p(n+1,j)=p(mint(83)+1,j)-p(mint(83)+3,j)
9026 220 CONTINUE
9027 ELSE
9028 DO 230 j=1,4
9029 p(n+1,j)=p(mint(83)+1,j)
9030 230 CONTINUE
9031 ENDIF
9032 k(n+2,1)=21
9033 IF(mint(142).NE.0) THEN
9034 DO 240 j=1,4
9035 p(n+2,j)=p(mint(83)+2,j)-p(mint(83)+move,j)
9036 240 CONTINUE
9037 ELSE
9038 DO 250 j=1,4
9039 p(n+2,j)=p(mint(83)+2,j)
9040 250 CONTINUE
9041 ENDIF
9042
9043C...Define boost and rotation between hadronic subsystem and
9044C...collision rest frame; boost hadronic subsystem to this frame.
9045 DO 260 j=1,3
9046 beta(j)=(p(n+1,j)+p(n+2,j))/(p(n+1,4)+p(n+2,4))
9047 260 CONTINUE
9048 CALL pyrobo(n+1,n+2,0d0,0d0,-beta(1),-beta(2),-beta(3))
9049 bphi=pyangl(p(n+1,1),p(n+1,2))
9050 CALL pyrobo(n+1,n+2,0d0,-bphi,0d0,0d0,0d0)
9051 btheta=pyangl(p(n+1,3),p(n+1,1))
9052 CALL pyrobo(mint(83)+move+1,n,btheta,bphi,beta(1),beta(2),
9053 & beta(3))
9054
9055C...Add on scattered leptons to final state.
9056 DO 280 i=1,2
9057 IF(mint(140+i).NE.0) THEN
9058 lsc=mint(83)+min(i+2,move)
9059 n=n+1
9060 DO 270 j=1,5
9061 k(n,j)=k(lsc,j)
9062 p(n,j)=p(lsc,j)
9063 v(n,j)=v(lsc,j)
9064 270 CONTINUE
9065 k(n,1)=1
9066 k(n,3)=lsc
9067 ENDIF
9068 280 CONTINUE
9069 ENDIF
9070
9071 RETURN
9072 END
9073
9074C*********************************************************************
9075
9076C...PYRAND
9077C...Generates quantities characterizing the high-pT scattering at the
9078C...parton level according to the matrix elements. Chooses incoming,
9079C...reacting partons, their momentum fractions and one of the possible
9080C...subprocesses.
9081
9082 SUBROUTINE pyrand
9083
9084C...Double precision and integer declarations.
9085 IMPLICIT DOUBLE PRECISION(a-h, o-z)
9086 IMPLICIT INTEGER(I-N)
9087 INTEGER PYK,PYCHGE,PYCOMP
9088C...Parameter statement to help give large particle numbers.
9089 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
9090 &kexcit=4000000,kdimen=5000000)
9091
9092C...User process initialization and event commonblocks.
9093 INTEGER MAXPUP
9094 parameter(maxpup=100)
9095 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9096 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9097 common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
9098 &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
9099 &lprup(maxpup)
9100 INTEGER MAXNUP
9101 parameter(maxnup=500)
9102 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9103 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9104 common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
9105 &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
9106 &vtimup(maxnup),spinup(maxnup)
9107 SAVE /heprup/,/hepeup/
9108
9109C...Commonblocks.
9110 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
9111 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
9112 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
9113 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
9114 common/pypars/mstp(200),parp(200),msti(200),pari(200)
9115 common/pyint1/mint(400),vint(400)
9116 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
9117 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
9118 common/pyint4/mwid(500),wids(500,5)
9119 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
9120 common/pyint7/sigt(0:6,0:6,0:5)
9121 common/pymssm/imss(0:99),rmss(0:99)
9122 common/pytcco/coefx(194:380,2)
9123 common/tcpara/ires,jres,xmas(3),xwid(3),ymas(2),ywid(2)
9124 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
9125 &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,/pymssm/,/pytcco/,
9126 &/tcpara/
9127C...Local arrays.
9128 dimension xpq(-25:25),pmm(2),pdif(4),bhad(4),pmmn(2)
9129
9130C...Parameters and data used in elastic/diffractive treatment.
9131 DATA eps/0.0808d0/, alp/0.25d0/, cres/2d0/, pmrc/1.062d0/,
9132 &smp/0.880d0/, bhad/2.3d0,1.4d0,1.4d0,0.23d0/
9133
9134C...Initial values, specifically for (first) semihard interaction.
9135 mint(10)=0
9136 mint(17)=0
9137 mint(18)=0
9138 vint(143)=1d0
9139 vint(144)=1d0
9140 vint(157)=0d0
9141 vint(158)=0d0
9142 mfail=0
9143 IF(mstp(171).EQ.1.AND.mstp(172).EQ.2) mfail=1
9144 isub=0
9145 istsb=0
9146 loop=0
9147 100 loop=loop+1
9148 mint(51)=0
9149 mint(143)=1
9150 vint(97)=1d0
9151
9152C...Start by assuming incoming photon is entering subprocess.
9153 IF(mint(11).EQ.22) THEN
9154 mint(15)=22
9155 vint(307)=vint(3)**2
9156 ENDIF
9157 IF(mint(12).EQ.22) THEN
9158 mint(16)=22
9159 vint(308)=vint(4)**2
9160 ENDIF
9161 mint(103)=mint(11)
9162 mint(104)=mint(12)
9163
9164C...Choice of process type - first event of pileup.
9165 inmult=0
9166 IF(mint(82).EQ.1.AND.isub.GE.91.AND.isub.LE.96) THEN
9167 ELSEIF(mint(82).EQ.1) THEN
9168
9169C...For gamma-p or gamma-gamma first pick between alternatives.
9170 iga=0
9171 IF(mint(121).GT.1) CALL pysave(4,iga)
9172 mint(122)=iga
9173
9174C...For real gamma + gamma with different nature, flip at random.
9175 IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
9176 & mstp(14).LE.10.AND.pyr(0).GT.0.5d0) THEN
9177 mintsv=mint(41)
9178 mint(41)=mint(42)
9179 mint(42)=mintsv
9180 mintsv=mint(45)
9181 mint(45)=mint(46)
9182 mint(46)=mintsv
9183 mintsv=mint(107)
9184 mint(107)=mint(108)
9185 mint(108)=mintsv
9186 IF(mint(47).EQ.2.OR.mint(47).EQ.3) mint(47)=5-mint(47)
9187 ENDIF
9188
9189C...Pick process type, possibly by user process machinery.
9190C...(If the latter, also event will be picked here.)
9191 IF(mint(111).GE.11.AND.iabs(idwtup).EQ.2.AND.loop.GE.2) THEN
9192 CALL upevnt
9193 CALL pyupre
9194 ELSEIF(mint(111).GE.11.AND.iabs(idwtup).GE.3) THEN
9195 CALL upevnt
9196 CALL pyupre
9197 isub=0
9198 110 isub=isub+1
9199 IF((iset(isub).NE.11.OR.kfpr(isub,2).NE.idprup).AND.
9200 & isub.LT.500) GOTO 110
9201 ELSE
9202 rsub=xsec(0,1)*pyr(0)
9203 DO 120 i=1,500
9204 IF(msub(i).NE.1.OR.i.EQ.96) GOTO 120
9205 isub=i
9206 rsub=rsub-xsec(i,1)
9207 IF(rsub.LE.0d0) GOTO 130
9208 120 CONTINUE
9209 130 IF(isub.EQ.95) isub=96
9210 IF(isub.EQ.96) inmult=1
9211 IF(iset(isub).EQ.11) THEN
9212 idprup=kfpr(isub,2)
9213 CALL upevnt
9214 CALL pyupre
9215 ENDIF
9216 ENDIF
9217
9218C...Choice of inclusive process type - pileup events.
9219 ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN
9220 rsub=vint(131)*pyr(0)
9221 isub=96
9222 IF(rsub.GT.sigt(0,0,5)) isub=94
9223 IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)) isub=93
9224 IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)) isub=92
9225 IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)+sigt(0,0,2))
9226 & isub=91
9227 IF(isub.EQ.96) inmult=1
9228 ENDIF
9229
9230C...Choice of photon energy and flux factor inside lepton.
9231 IF(mint(141).NE.0.OR.mint(142).NE.0) THEN
9232 CALL pygaga(3,wtgaga)
9233 IF(isub.GE.131.AND.isub.LE.140) THEN
9234 ckin(3)=max(vint(285),vint(154))
9235 ckin(1)=2d0*ckin(3)
9236 ENDIF
9237C...When necessary set direct/resolved photon by hand.
9238 ELSEIF(mint(15).EQ.22.OR.mint(16).EQ.22) THEN
9239 IF(mint(15).EQ.22.AND.mint(41).EQ.2) mint(15)=0
9240 IF(mint(16).EQ.22.AND.mint(42).EQ.2) mint(16)=0
9241 ENDIF
9242
9243C...Restrict direct*resolved processes to pTmin >= Q,
9244C...to avoid doublecounting with DIS.
9245 IF(mstp(18).EQ.3.AND.isub.GE.131.AND.isub.LE.136) THEN
9246 IF(mint(15).EQ.22) THEN
9247 ckin(3)=max(vint(285),vint(154),abs(vint(3)))
9248 ELSE
9249 ckin(3)=max(vint(285),vint(154),abs(vint(4)))
9250 ENDIF
9251 ckin(1)=2d0*ckin(3)
9252 ENDIF
9253
9254C...Set up for multiple interactions (may include impact parameter).
9255 IF(inmult.EQ.1) THEN
9256 IF(mint(35).LE.1) CALL pymult(2)
9257 IF(mint(35).GE.2) CALL pymign(2)
9258 ENDIF
9259
9260C...Loopback point for minimum bias in photon physics.
9261 loop2=0
9262 140 loop2=loop2+1
9263 IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+mint(143)
9264 IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+mint(143)
9265 IF(isub.EQ.96.AND.loop2.EQ.1.AND.mint(82).EQ.1)
9266 &ngen(97,1)=ngen(97,1)+mint(143)
9267 mint(1)=isub
9268 istsb=iset(isub)
9269
9270C...Random choice of flavour for some SUSY processes.
9271 IF(isub.GE.201.AND.isub.LE.301) THEN
9272C...~e_L ~nu_e or ~mu_L ~nu_mu.
9273 IF(isub.EQ.210) THEN
9274 kfpr(isub,1)=ksusy1+11+2*int(0.5d0+pyr(0))
9275 kfpr(isub,2)=kfpr(isub,1)+1
9276C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9277 ELSEIF(isub.EQ.213) THEN
9278 kfpr(isub,1)=ksusy1+12+2*int(0.5d0+pyr(0))
9279 kfpr(isub,2)=kfpr(isub,1)
9280C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9281 ELSEIF(isub.GE.246.AND.isub.LE.259.AND.isub.NE.255.AND.
9282 & isub.NE.257) THEN
9283 IF(isub.GE.258) THEN
9284 rkf=4d0
9285 ELSE
9286 rkf=5d0
9287 ENDIF
9288 IF(mod(isub,2).EQ.0) THEN
9289 kfpr(isub,1)=ksusy1+1+int(rkf*pyr(0))
9290 ELSE
9291 kfpr(isub,1)=ksusy2+1+int(rkf*pyr(0))
9292 ENDIF
9293C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9294 ELSEIF(isub.GE.271.AND.isub.LE.276) THEN
9295 IF(isub.EQ.271.OR.isub.EQ.274) THEN
9296 ksu1=ksusy1
9297 ksu2=ksusy1
9298 ELSEIF(isub.EQ.272.OR.isub.EQ.275) THEN
9299 ksu1=ksusy2
9300 ksu2=ksusy2
9301 ELSEIF(pyr(0).LT.0.5d0) THEN
9302 ksu1=ksusy1
9303 ksu2=ksusy2
9304 ELSE
9305 ksu1=ksusy2
9306 ksu2=ksusy1
9307 ENDIF
9308 kfpr(isub,1)=ksu1+1+int(4d0*pyr(0))
9309 kfpr(isub,2)=ksu2+1+int(4d0*pyr(0))
9310C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9311 ELSEIF(isub.EQ.277.OR.isub.EQ.279) THEN
9312 kfpr(isub,1)=ksusy1+1+int(4d0*pyr(0))
9313 kfpr(isub,2)=kfpr(isub,1)
9314 ELSEIF(isub.EQ.278.OR.isub.EQ.280) THEN
9315 kfpr(isub,1)=ksusy2+1+int(4d0*pyr(0))
9316 kfpr(isub,2)=kfpr(isub,1)
9317C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9318 ELSEIF(isub.GE.281.AND.isub.LE.286) THEN
9319 IF(isub.EQ.281.OR.isub.EQ.284) THEN
9320 ksu1=ksusy1
9321 ksu2=ksusy1
9322 ELSEIF(isub.EQ.282.OR.isub.EQ.285) THEN
9323 ksu1=ksusy2
9324 ksu2=ksusy2
9325 ELSEIF(pyr(0).LT.0.5d0) THEN
9326 ksu1=ksusy1
9327 ksu2=ksusy2
9328 ELSE
9329 ksu1=ksusy2
9330 ksu2=ksusy1
9331 ENDIF
9332 IF(isub.EQ.281.OR.isub.LE.283) THEN
9333 rkf=5d0
9334 ELSE
9335 rkf=4d0
9336 ENDIF
9337 kfpr(isub,2)=ksu2+1+int(rkf*pyr(0))
9338 ENDIF
9339 ENDIF
9340
9341C...Random choice of flavours for some UED processes
9342c...The production processes can generate a doublet pair,
9343c...a singlet pair, or a doublet + singlet.
9344 IF(isub.EQ.313)THEN
9345C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9346 IF(pyr(0).LE.0.1)THEN
9347 kfpr(isub,1)=5100001
9348 ELSE
9349 kfpr(isub,1)=5100002
9350 ENDIF
9351 kfpr(isub,2)=kfpr(isub,1)
9352 ELSEIF(isub.EQ.314.OR.isub.EQ.315)THEN
9353C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9354C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9355 IF(pyr(0).LE.0.1)THEN
9356 kfpr(isub,1)=5100001
9357 ELSE
9358 kfpr(isub,1)=5100002
9359 ENDIF
9360 kfpr(isub,2)=-kfpr(isub,1)
9361 ELSEIF(isub.EQ.316)THEN
9362C...qi + qbarj -> q*_Di + q*_Sbarj
9363 IF(pyr(0).LE.0.5)THEN
9364 kfpr(isub,1)=5100001
9365c Changed from private pythia6410_ued code
9366c KFPR(ISUB,2)=-5010001
9367 kfpr(isub,2)=-6100002
9368 ELSE
9369 kfpr(isub,1)=5100002
9370c Changed from private pythia6410_ued code
9371c KFPR(ISUB,2)=-5010002
9372 kfpr(isub,2)=-6100001
9373 ENDIF
9374 ELSEIF(isub.EQ.317)THEN
9375C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9376 IF(pyr(0).LE.0.5)THEN
9377 kfpr(isub,1)=5100001
9378 kfpr(isub,2)=-5100002
9379 ELSE
9380 kfpr(isub,1)=5100002
9381 kfpr(isub,2)=-5100001
9382 ENDIF
9383 ELSEIF(isub.EQ.318)THEN
9384C...qi + qj -> q*_Di + q*_Sj
9385 IF(pyr(0).LE.0.5)THEN
9386 kfpr(isub,1)=5100001
9387 kfpr(isub,2)=6100002
9388 ELSE
9389 kfpr(isub,1)=5100002
9390 kfpr(isub,2)=6100001
9391 ENDIF
9392 ENDIF
9393
9394C...Find resonances (explicit or implicit in cross-section).
9395 mint(72)=0
9396 kfr1=0
9397 IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
9398 kfr1=kfpr(isub,1)
9399 ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165.OR.
9400 & isub.EQ.171.OR.isub.EQ.176) THEN
9401 kfr1=23
9402 ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172.OR.
9403 & isub.EQ.177) THEN
9404 kfr1=24
9405 ELSEIF(isub.GE.71.AND.isub.LE.77) THEN
9406 kfr1=25
9407 IF(mstp(46).EQ.5) THEN
9408 kfr1=89
9409 pmas(89,1)=parp(45)
9410 pmas(89,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)
9411 ENDIF
9412 ENDIF
9413 ckmx=ckin(2)
9414 IF(ckmx.LE.0d0) ckmx=vint(1)
9415 kcr1=pycomp(kfr1)
9416 IF(kfr1.NE.0) THEN
9417 IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.
9418 & ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0
9419 ENDIF
9420 IF(kfr1.NE.0) THEN
9421 taur1=pmas(kcr1,1)**2/vint(2)
9422 gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)
9423 mint(72)=1
9424 mint(73)=kfr1
9425 vint(73)=taur1
9426 vint(74)=gamr1
9427 ENDIF
9428 kfr2=0
9429 kfr3=0
9430 IF(isub.EQ.141.OR.isub.EQ.194.OR.isub.EQ.195.OR.
9431 $(isub.GE.361.AND.isub.LE.380))
9432 $THEN
9433 kfr2=23
9434 IF(isub.EQ.141) THEN
9435 kcr2=pycomp(kfr2)
9436 IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.
9437 & ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) THEN
9438 kfr2=0
9439 ELSE
9440 taur2=pmas(kcr2,1)**2/vint(2)
9441 gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)
9442 mint(72)=2
9443 mint(74)=kfr2
9444 vint(75)=taur2
9445 vint(76)=gamr2
9446 ENDIF
9447C...3 resonances at work: rho, omega, a
9448 ELSEIF(isub.EQ.194.OR.(isub.GE.361.AND.isub.LE.368)
9449 & .OR.isub.EQ.379.OR.isub.EQ.380) THEN
9450 mint(72)=ires
9451 IF(ires.GE.1) THEN
9452 vint(73)=xmas(1)**2/vint(2)
9453 vint(74)=xmas(1)*xwid(1)/vint(2)
9454 taur1=vint(73)
9455 gamr1=vint(74)
9456 kfr1=1
9457 ENDIF
9458 IF(ires.GE.2) THEN
9459 vint(75)=xmas(2)**2/vint(2)
9460 vint(76)=xmas(2)*xwid(2)/vint(2)
9461 taur2=vint(75)
9462 gamr2=vint(76)
9463 kfr2=2
9464 ENDIF
9465 IF(ires.EQ.3) THEN
9466 vint(77)=xmas(3)**2/vint(2)
9467 vint(78)=xmas(3)*xwid(3)/vint(2)
9468 taur3=vint(77)
9469 gamr3=vint(78)
9470 kfr3=3
9471 ENDIF
9472C...Charged current: rho+- and a+-
9473 ELSEIF(isub.EQ.195.OR.isub.GE.370.AND.isub.LE.378) THEN
9474 mint(72)=ires
9475 IF(jres.GE.1) THEN
9476 vint(73)=ymas(1)**2/vint(2)
9477 vint(74)=ymas(1)*ywid(1)/vint(2)
9478 kfr1=1
9479 taur1=vint(73)
9480 gamr1=vint(74)
9481 ENDIF
9482 IF(jres.GE.2) THEN
9483 vint(75)=ymas(2)**2/vint(2)
9484 vint(76)=ymas(2)*ywid(2)/vint(2)
9485 kfr2=2
9486 taur2=vint(73)
9487 gamr2=vint(74)
9488 ENDIF
9489 kfr3=0
9490 ENDIF
9491 IF(isub.NE.141) THEN
9492 IF(kfr3.NE.0.AND.kfr2.NE.0.AND.kfr1.NE.0) THEN
9493
9494 ELSEIF(kfr1.NE.0.AND.kfr2.NE.0) THEN
9495 mint(72)=2
9496 ELSEIF(kfr1.NE.0.AND.kfr3.NE.0) THEN
9497 mint(72)=2
9498 mint(74)=kfr3
9499 vint(75)=taur3
9500 vint(76)=gamr3
9501 ELSEIF(kfr2.NE.0.AND.kfr3.NE.0) THEN
9502 mint(72)=2
9503 mint(73)=kfr2
9504 vint(73)=taur2
9505 vint(74)=gamr2
9506 mint(74)=kfr3
9507 vint(75)=taur3
9508 vint(76)=gamr3
9509 ELSEIF(kfr1.NE.0) THEN
9510 mint(72)=1
9511 ELSEIF(kfr2.NE.0) THEN
9512 mint(72)=1
9513 mint(73)=kfr2
9514 vint(73)=taur2
9515 vint(74)=gamr2
9516 ELSEIF(kfr3.NE.0) THEN
9517 mint(72)=1
9518 mint(73)=kfr3
9519 vint(73)=taur3
9520 vint(74)=gamr3
9521 ELSE
9522 mint(72)=0
9523 ENDIF
9524 ELSE
9525 IF(kfr2.NE.0.AND.kfr1.NE.0) THEN
9526
9527 ELSEIF(kfr2.NE.0) THEN
9528 kfr1=kfr2
9529 taur1=taur2
9530 gamr1=gamr2
9531 mint(72)=1
9532 mint(73)=kfr1
9533 vint(73)=taur1
9534 vint(74)=gamr1
9535 kfr2=0
9536 ELSE
9537 mint(72)=0
9538 ENDIF
9539 ENDIF
9540 ENDIF
9541
9542C...Find product masses and minimum pT of process,
9543C...optionally with broadening according to a truncated Breit-Wigner.
9544 vint(63)=0d0
9545 vint(64)=0d0
9546 mint(71)=0
9547 vint(71)=ckin(3)
9548 IF(mint(82).GE.2) vint(71)=0d0
9549 vint(80)=1d0
9550 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
9551 nbw=0
9552 DO 160 i=1,2
9553 pmmn(i)=0d0
9554 IF(kfpr(isub,i).EQ.0) THEN
9555 ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.
9556 & parp(41)) THEN
9557 vint(62+i)=pmas(pycomp(kfpr(isub,i)),1)**2
9558 ELSE
9559 nbw=nbw+1
9560C...This prevents SUSY/t particles from becoming too light.
9561 kflw=kfpr(isub,i)
9562 IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
9563 kcw=pycomp(kflw)
9564 pmmn(i)=pmas(kcw,1)
9565 DO 150 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
9566 IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
9567 pmsum=pmas(pycomp(kfdp(idc,1)),1)+
9568 & pmas(pycomp(kfdp(idc,2)),1)
9569 IF(kfdp(idc,3).NE.0) pmsum=pmsum+
9570 & pmas(pycomp(kfdp(idc,3)),1)
9571 pmmn(i)=min(pmmn(i),pmsum)
9572 ENDIF
9573 150 CONTINUE
9574 ELSEIF(kflw.EQ.6) THEN
9575 pmmn(i)=pmas(24,1)+pmas(5,1)
9576 ENDIF
9577 ENDIF
9578 160 CONTINUE
9579 IF(nbw.GE.1) THEN
9580 ckin41=ckin(41)
9581 ckin43=ckin(43)
9582 ckin(41)=max(pmmn(1),ckin(41))
9583 ckin(43)=max(pmmn(2),ckin(43))
9584 CALL pyofsh(4,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)
9585 ckin(41)=ckin41
9586 ckin(43)=ckin43
9587 IF(mint(51).EQ.1) THEN
9588 IF(mint(121).GT.1) CALL pysave(2,iga)
9589 IF(mfail.EQ.1) THEN
9590 msti(61)=1
9591 RETURN
9592 ENDIF
9593 GOTO 100
9594 ENDIF
9595 vint(63)=pqm3**2
9596 vint(64)=pqm4**2
9597 ENDIF
9598 IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1
9599 IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))
9600 ENDIF
9601
9602C...Prepare for additional variable choices in 2 -> 3.
9603 IF(istsb.EQ.5) THEN
9604 vint(201)=0d0
9605 IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)
9606 vint(206)=vint(201)
9607 IF(isub.EQ.401.OR.isub.EQ.402) vint(206)=pmas(5,1)
9608 vint(204)=pmas(23,1)
9609 IF(isub.EQ.124.OR.isub.EQ.174.OR.isub.EQ.179.OR.isub.EQ.351)
9610 & vint(204)=pmas(24,1)
9611 IF(isub.EQ.352) vint(204)=pmas(pycomp(9900024),1)
9612 IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.
9613 & isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402)
9614 & vint(204)=vint(201)
9615 vint(209)=vint(204)
9616 IF(isub.EQ.401.OR.isub.EQ.402) vint(209)=vint(206)
9617 ENDIF
9618
9619C...Select incoming VDM particle (rho/omega/phi/J/psi).
9620 IF(istsb.NE.0.AND.(mint(101).GE.2.OR.mint(102).GE.2).AND.
9621 &(mint(123).EQ.2.OR.mint(123).EQ.3.OR.mint(123).EQ.7)) THEN
9622 vrn=pyr(0)*sigt(0,0,5)
9623 IF(mint(101).LE.1) THEN
9624 i1mn=0
9625 i1mx=0
9626 ELSE
9627 i1mn=1
9628 i1mx=mint(101)
9629 ENDIF
9630 IF(mint(102).LE.1) THEN
9631 i2mn=0
9632 i2mx=0
9633 ELSE
9634 i2mn=1
9635 i2mx=mint(102)
9636 ENDIF
9637 DO 180 i1=i1mn,i1mx
9638 kfv1=110*i1+3
9639 DO 170 i2=i2mn,i2mx
9640 kfv2=110*i2+3
9641 vrn=vrn-sigt(i1,i2,5)
9642 IF(vrn.LE.0d0) GOTO 190
9643 170 CONTINUE
9644 180 CONTINUE
9645 190 IF(mint(101).GE.2) mint(103)=kfv1
9646 IF(mint(102).GE.2) mint(104)=kfv2
9647 ENDIF
9648
9649 IF(istsb.EQ.0) THEN
9650C...Elastic scattering or single or double diffractive scattering.
9651
9652C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9653 mint(103)=mint(11)
9654 mint(104)=mint(12)
9655 pmm(1)=vint(3)
9656 pmm(2)=vint(4)
9657 IF(mint(101).GE.2.OR.mint(102).GE.2) THEN
9658 jj=isub-90
9659 vrn=pyr(0)*sigt(0,0,jj)
9660 IF(mint(101).LE.1) THEN
9661 i1mn=0
9662 i1mx=0
9663 ELSE
9664 i1mn=1
9665 i1mx=mint(101)
9666 ENDIF
9667 IF(mint(102).LE.1) THEN
9668 i2mn=0
9669 i2mx=0
9670 ELSE
9671 i2mn=1
9672 i2mx=mint(102)
9673 ENDIF
9674 DO 210 i1=i1mn,i1mx
9675 kfv1=110*i1+3
9676 DO 200 i2=i2mn,i2mx
9677 kfv2=110*i2+3
9678 vrn=vrn-sigt(i1,i2,jj)
9679 IF(vrn.LE.0d0) GOTO 220
9680 200 CONTINUE
9681 210 CONTINUE
9682 220 IF(mint(101).GE.2) THEN
9683 mint(103)=kfv1
9684 pmm(1)=pymass(kfv1)
9685 ENDIF
9686 IF(mint(102).GE.2) THEN
9687 mint(104)=kfv2
9688 pmm(2)=pymass(kfv2)
9689 ENDIF
9690 ENDIF
9691 vint(67)=pmm(1)
9692 vint(68)=pmm(2)
9693
9694C...Select mass for GVMD states (rejecting previous assignment).
9695 q0s=4d0*parp(15)**2
9696 q1s=4d0*vint(154)**2
9697 loop3=0
9698 230 loop3=loop3+1
9699 DO 240 jt=1,2
9700 IF(mint(106+jt).EQ.3) THEN
9701 ps=vint(2+jt)**2
9702 pmm(jt)=sqrt((q0s+ps)*(q1s+ps)/
9703 & (q0s+pyr(0)*(q1s-q0s)+ps)-ps)
9704 IF(mint(102+jt).GE.333) pmm(jt)=pmm(jt)-
9705 & pmas(pycomp(113),1)+pmas(pycomp(mint(102+jt)),1)
9706 ENDIF
9707 240 CONTINUE
9708 IF(pmm(1)+pmm(2)+parp(104).GE.vint(1)) THEN
9709 IF(loop3.LT.100.AND.(mint(107).EQ.3.OR.mint(108).EQ.3))
9710 & GOTO 230
9711 GOTO 100
9712 ENDIF
9713
9714C...Side/sides of diffractive system.
9715 mint(17)=0
9716 mint(18)=0
9717 IF(isub.EQ.92.OR.isub.EQ.94) mint(17)=1
9718 IF(isub.EQ.93.OR.isub.EQ.94) mint(18)=1
9719
9720C...Find masses of particles and minimal masses of diffractive states.
9721 DO 250 jt=1,2
9722 pdif(jt)=pmm(jt)
9723 vint(68+jt)=pdif(jt)
9724 IF(mint(16+jt).EQ.1) pdif(jt)=pdif(jt)+parp(102)
9725 250 CONTINUE
9726 sh=vint(2)
9727 sqm1=pmm(1)**2
9728 sqm2=pmm(2)**2
9729 sqm3=pdif(1)**2
9730 sqm4=pdif(2)**2
9731 smres1=(pmm(1)+pmrc)**2
9732 smres2=(pmm(2)+pmrc)**2
9733
9734C...Find elastic slope and lower limit diffractive slope.
9735 iha=max(2,iabs(mint(103))/110)
9736 IF(iha.GE.5) iha=1
9737 ihb=max(2,iabs(mint(104))/110)
9738 IF(ihb.GE.5) ihb=1
9739 IF(isub.EQ.91) THEN
9740 bmn=2d0*bhad(iha)+2d0*bhad(ihb)+4d0*sh**eps-4.2d0
9741 ELSEIF(isub.EQ.92) THEN
9742 bmn=max(2d0,2d0*bhad(ihb))
9743 ELSEIF(isub.EQ.93) THEN
9744 bmn=max(2d0,2d0*bhad(iha))
9745 ELSEIF(isub.EQ.94) THEN
9746 bmn=2d0*alp*4d0
9747 ENDIF
9748
9749C...Determine maximum possible t range and coefficient of generation.
9750 sqla12=(sh-sqm1-sqm2)**2-4d0*sqm1*sqm2
9751 sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
9752 tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
9753 thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
9754 thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
9755 & (sqm1*sqm4-sqm2*sqm3)/sh
9756 thl=-0.5d0*(tha+thb)
9757 thu=thc/thl
9758 thrnd=exp(max(-50d0,bmn*(thl-thu)))-1d0
9759
9760C...Select diffractive mass/masses according to dm^2/m^2.
9761 loop3=0
9762 260 loop3=loop3+1
9763 DO 270 jt=1,2
9764 IF(mint(16+jt).EQ.0) THEN
9765 pdif(2+jt)=pdif(jt)
9766 ELSE
9767 pmmin=pdif(jt)
9768 pmmax=max(vint(2+jt),vint(1)-pdif(3-jt))
9769 pdif(2+jt)=pmmin*(pmmax/pmmin)**pyr(0)
9770 ENDIF
9771 270 CONTINUE
9772 sqm3=pdif(3)**2
9773 sqm4=pdif(4)**2
9774
9775C..Additional mass factors, including resonance enhancement.
9776 IF(pdif(3)+pdif(4).GE.vint(1)) THEN
9777 IF(loop3.LT.100) GOTO 260
9778 GOTO 100
9779 ENDIF
9780 IF(isub.EQ.92) THEN
9781 fsd=(1d0-sqm3/sh)*(1d0+cres*smres1/(smres1+sqm3))
9782 IF(fsd.LT.pyr(0)*(1d0+cres)) GOTO 260
9783 ELSEIF(isub.EQ.93) THEN
9784 fsd=(1d0-sqm4/sh)*(1d0+cres*smres2/(smres2+sqm4))
9785 IF(fsd.LT.pyr(0)*(1d0+cres)) GOTO 260
9786 ELSEIF(isub.EQ.94) THEN
9787 fdd=(1d0-(pdif(3)+pdif(4))**2/sh)*(sh*smp/
9788 & (sh*smp+sqm3*sqm4))*(1d0+cres*smres1/(smres1+sqm3))*
9789 & (1d0+cres*smres2/(smres2+sqm4))
9790 IF(fdd.LT.pyr(0)*(1d0+cres)**2) GOTO 260
9791 ENDIF
9792
9793C...Select t according to exp(Bmn*t) and correct to right slope.
9794 th=thu+log(1d0+thrnd*pyr(0))/bmn
9795 IF(isub.GE.92) THEN
9796 IF(isub.EQ.92) THEN
9797 badd=2d0*alp*log(sh/sqm3)
9798 IF(bhad(ihb).LT.1d0) badd=max(0d0,badd+2d0*bhad(ihb)-2d0)
9799 ELSEIF(isub.EQ.93) THEN
9800 badd=2d0*alp*log(sh/sqm4)
9801 IF(bhad(iha).LT.1d0) badd=max(0d0,badd+2d0*bhad(iha)-2d0)
9802 ELSEIF(isub.EQ.94) THEN
9803 badd=2d0*alp*(log(exp(4d0)+sh/(alp*sqm3*sqm4))-4d0)
9804 ENDIF
9805 IF(exp(max(-50d0,badd*(th-thu))).LT.pyr(0)) GOTO 260
9806 ENDIF
9807
9808C...Check whether m^2 and t choices are consistent.
9809 sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4
9810 tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh
9811 thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh
9812 IF(thb.LE.1d-8) GOTO 260
9813 thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*
9814 & (sqm1*sqm4-sqm2*sqm3)/sh
9815 thlm=-0.5d0*(tha+thb)
9816 thum=thc/thlm
9817 IF(th.LT.thlm.OR.th.GT.thum) GOTO 260
9818
9819C...Information to output.
9820 vint(21)=1d0
9821 vint(22)=0d0
9822 vint(23)=min(1d0,max(-1d0,(tha+2d0*th)/thb))
9823 vint(45)=th
9824 vint(59)=2d0*sqrt(max(0d0,-(thc+tha*th+th**2)))/thb
9825 vint(63)=pdif(3)**2
9826 vint(64)=pdif(4)**2
9827 vint(283)=pmm(1)**2/4d0
9828 vint(284)=pmm(2)**2/4d0
9829
9830C...Note: in the following, by In is meant the integral over the
9831C...quantity multiplying coefficient cn.
9832C...Choose tau according to h1(tau)/tau, where
9833C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9834C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9835C...I1/I5*c5*1/(tau+tau_R') +
9836C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9837C...I1/I7*c7*tau/(1.-tau), and
9838C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9839 ELSEIF(istsb.GE.1.AND.istsb.LE.5) THEN
9840 CALL pyklim(1)
9841 IF(mint(51).NE.0) THEN
9842 IF(mint(121).GT.1) CALL pysave(2,iga)
9843 IF(mfail.EQ.1) THEN
9844 msti(61)=1
9845 RETURN
9846 ENDIF
9847 GOTO 100
9848 ENDIF
9849 rtau=pyr(0)
9850 mtau=1
9851 IF(rtau.GT.coef(isub,1)) mtau=2
9852 IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3
9853 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4
9854 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4))
9855 & mtau=5
9856 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
9857 & coef(isub,5)) mtau=6
9858 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+
9859 & coef(isub,5)+coef(isub,6)) mtau=7
9860C...Additional check to handle techni-processes with extra resonance
9861C....Only modify tau treatment
9862 IF(isub.EQ.194.OR.isub.EQ.195.OR.(isub.GE.361.AND.isub.LE.380))
9863 & THEN
9864 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)
9865 & +coef(isub,4)+coef(isub,5)+coef(isub,6)+coef(isub,7)) mtau=8
9866 IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)
9867 & +coef(isub,4)+coef(isub,5)+coef(isub,6)+coef(isub,7)
9868 & +coefx(isub,1)) mtau=9
9869 ENDIF
9870 CALL pykmap(1,mtau,pyr(0))
9871
9872C...2 -> 3, 4 processes:
9873C...Choose tau' according to h4(tau,tau')/tau', where
9874C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9875C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9876 IF(istsb.GE.3.AND.istsb.LE.5) THEN
9877 CALL pyklim(4)
9878 IF(mint(51).NE.0) THEN
9879 IF(mint(121).GT.1) CALL pysave(2,iga)
9880 IF(mfail.EQ.1) THEN
9881 msti(61)=1
9882 RETURN
9883 ENDIF
9884 GOTO 100
9885 ENDIF
9886 rtaup=pyr(0)
9887 mtaup=1
9888 IF(rtaup.GT.coef(isub,18)) mtaup=2
9889 IF(rtaup.GT.coef(isub,18)+coef(isub,19)) mtaup=3
9890 CALL pykmap(4,mtaup,pyr(0))
9891 ENDIF
9892
9893C...Choose y* according to h2(y*), where
9894C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9895C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9896C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9897C...and c1 + c2 + c3 + c4 + c5 = 1.
9898 CALL pyklim(2)
9899 IF(mint(51).NE.0) THEN
9900 IF(mint(121).GT.1) CALL pysave(2,iga)
9901 IF(mfail.EQ.1) THEN
9902 msti(61)=1
9903 RETURN
9904 ENDIF
9905 GOTO 100
9906 ENDIF
9907 ryst=pyr(0)
9908 myst=1
9909 IF(ryst.GT.coef(isub,8)) myst=2
9910 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
9911 IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)) myst=4
9912 IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)+
9913 & coef(isub,11)) myst=5
9914 CALL pykmap(2,myst,pyr(0))
9915
9916C...2 -> 2 processes:
9917C...Choose cos(theta-hat) (cth) according to h3(cth), where
9918C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9919C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9920C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9921C...and c0 + c1 + c2 + c3 + c4 = 1.
9922 CALL pyklim(3)
9923 IF(mint(51).NE.0) THEN
9924 IF(mint(121).GT.1) CALL pysave(2,iga)
9925 IF(mfail.EQ.1) THEN
9926 msti(61)=1
9927 RETURN
9928 ENDIF
9929 GOTO 100
9930 ENDIF
9931 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
9932 rcth=pyr(0)
9933 mcth=1
9934 IF(rcth.GT.coef(isub,13)) mcth=2
9935 IF(rcth.GT.coef(isub,13)+coef(isub,14)) mcth=3
9936 IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)) mcth=4
9937 IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)+
9938 & coef(isub,16)) mcth=5
9939 CALL pykmap(3,mcth,pyr(0))
9940 ENDIF
9941
9942C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9943 IF(istsb.EQ.5) THEN
9944 CALL pykmap(5,0,0d0)
9945 IF(mint(51).NE.0) THEN
9946 IF(mint(121).GT.1) CALL pysave(2,iga)
9947 IF(mfail.EQ.1) THEN
9948 msti(61)=1
9949 RETURN
9950 ENDIF
9951 GOTO 100
9952 ENDIF
9953 ENDIF
9954
9955C...DIS as f + gamma* -> f process: set dummy values.
9956 ELSEIF(istsb.EQ.8) THEN
9957 vint(21)=0.9d0
9958 vint(22)=0d0
9959 vint(23)=0d0
9960 vint(47)=0d0
9961 vint(48)=0d0
9962
9963C...Low-pT or multiple interactions (first semihard interaction).
9964 ELSEIF(istsb.EQ.9) THEN
9965 IF(mint(35).LE.1) CALL pymult(3)
9966 IF(mint(35).GE.2) CALL pymign(3)
9967 isub=mint(1)
9968
9969C...Study user-defined process: kinematics plus weight.
9970 ELSEIF(istsb.EQ.11) THEN
9971 IF(idwtup.GT.0.AND.xwgtup.LT.0d0) call
9972 & pyerrm(26,'(PYRAND:) Negative XWGTUP for user process')
9973 msti(51)=0
9974 IF(nup.LE.0) THEN
9975 mint(51)=2
9976 msti(51)=1
9977 IF(mint(82).EQ.1) THEN
9978 ngen(0,1)=ngen(0,1)-1
9979 ngen(isub,1)=ngen(isub,1)-1
9980 ENDIF
9981 IF(mint(121).GT.1) CALL pysave(2,iga)
9982 RETURN
9983 ENDIF
9984
9985C...Extract cross section event weight.
9986 IF(iabs(idwtup).EQ.1.OR.iabs(idwtup).EQ.4) THEN
9987 sigs=1d-9*xwgtup
9988 ELSE
9989 sigs=1d-9*xsecup(kfpr(isub,1))
9990 ENDIF
9991 IF(iabs(idwtup).GE.1.AND.iabs(idwtup).LE.3) THEN
9992 vint(97)=sign(1d0,xwgtup)
9993 ELSE
9994 vint(97)=1d-9*xwgtup
9995 ENDIF
9996
9997C...Construct 'trivial' kinematical variables needed.
9998 kfl1=idup(1)
9999 kfl2=idup(2)
10000 vint(41)=pup(4,1)/ebmup(1)
10001 vint(42)=pup(4,2)/ebmup(2)
10002 IF (vint(41).GT.1.000001.OR.vint(42).GT.1.000001) THEN
10003 CALL pyerrm(9,'(PYRAND:) x > 1 in external event '//
10004 & '(listing follows):')
10005 CALL pylist(7)
10006 ENDIF
10007 vint(21)=vint(41)*vint(42)
10008 vint(22)=0.5d0*log(vint(41)/vint(42))
10009 vint(44)=vint(21)*vint(2)
10010 vint(43)=sqrt(max(0d0,vint(44)))
10011 vint(55)=scalup
10012 IF(scalup.LE.0d0) vint(55)=vint(43)
10013 vint(56)=vint(55)**2
10014 vint(57)=aqedup
10015 vint(58)=aqcdup
10016
10017C...Construct other kinematical variables needed (approximately).
10018 vint(23)=0d0
10019 vint(26)=vint(21)
10020 vint(45)=-0.5d0*vint(44)
10021 vint(46)=-0.5d0*vint(44)
10022 vint(49)=vint(43)
10023 vint(50)=vint(44)
10024 vint(51)=vint(55)
10025 vint(52)=vint(56)
10026 vint(53)=vint(55)
10027 vint(54)=vint(56)
10028 vint(25)=0d0
10029 vint(48)=0d0
10030 IF(istup(1).NE.-1.OR.istup(2).NE.-1) CALL pyerrm(26,
10031 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10032 DO 280 iup=3,nup
10033 IF(istup(iup).LT.1.OR.istup(iup).GT.3) CALL pyerrm(26,
10034 & '(PYRAND:) unacceptable ISTUP code for particles')
10035 IF(istup(iup).EQ.1) vint(25)=vint(25)+2d0*(pup(5,iup)**2+
10036 & pup(1,iup)**2+pup(2,iup)**2)/vint(2)
10037 IF(istup(iup).EQ.1) vint(48)=vint(48)+0.5d0*(pup(1,iup)**2+
10038 & pup(2,iup)**2)
10039 280 CONTINUE
10040 vint(47)=sqrt(vint(48))
10041 ENDIF
10042
10043C...Choose azimuthal angle.
10044 vint(24)=0d0
10045 IF(istsb.NE.11) vint(24)=paru(2)*pyr(0)
10046
10047C...Check against user cuts on kinematics at parton level.
10048 mint(51)=0
10049 IF((isub.LE.90.OR.isub.GT.100).AND.istsb.LE.10) CALL pyklim(0)
10050 IF(mint(51).NE.0) THEN
10051 IF(mint(121).GT.1) CALL pysave(2,iga)
10052 IF(mfail.EQ.1) THEN
10053 msti(61)=1
10054 RETURN
10055 ENDIF
10056 GOTO 100
10057 ENDIF
10058 IF(mint(82).EQ.1.AND.mstp(141).GE.1.AND.istsb.LE.10) THEN
10059 mcut=0
10060 IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)
10061 & CALL pykcut(mcut)
10062 IF(mcut.NE.0) THEN
10063 IF(mint(121).GT.1) CALL pysave(2,iga)
10064 IF(mfail.EQ.1) THEN
10065 msti(61)=1
10066 RETURN
10067 ENDIF
10068 GOTO 100
10069 ENDIF
10070 ENDIF
10071
10072C...Calculate differential cross-section for different subprocesses.
10073 IF(istsb.LE.10) CALL pysigh(nchn,sigs)
10074 sigsor=sigs
10075 siglpt=sigt(0,0,5)*vint(315)*vint(316)
10076
10077C...Multiply cross section by lepton -> photon flux factor.
10078 IF(mint(141).NE.0.OR.mint(142).NE.0) THEN
10079 sigs=wtgaga*sigs
10080 DO 290 ichn=1,nchn
10081 sigh(ichn)=wtgaga*sigh(ichn)
10082 290 CONTINUE
10083 siglpt=wtgaga*siglpt
10084 ENDIF
10085
10086C...Multiply cross-section by user-defined weights.
10087 IF(mstp(173).EQ.1) THEN
10088 sigs=parp(173)*sigs
10089 DO 300 ichn=1,nchn
10090 sigh(ichn)=parp(173)*sigh(ichn)
10091 300 CONTINUE
10092 siglpt=parp(173)*siglpt
10093 ENDIF
10094 wtxs=1d0
10095 sigswt=sigs
10096 vint(99)=1d0
10097 vint(100)=1d0
10098 IF(mint(82).EQ.1.AND.mstp(142).GE.1) THEN
10099 IF(isub.NE.96.AND.msub(91)+msub(92)+msub(93)+msub(94)+
10100 & msub(95).EQ.0) CALL pyevwt(wtxs)
10101 sigswt=wtxs*sigs
10102 vint(99)=wtxs
10103 IF(mstp(142).EQ.1) vint(100)=1d0/wtxs
10104 ENDIF
10105
10106C...Calculations for Monte Carlo estimate of all cross-sections.
10107 IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN
10108 IF(mstp(142).LE.1) THEN
10109 xsec(isub,2)=xsec(isub,2)+sigs
10110 ELSE
10111 xsec(isub,2)=xsec(isub,2)+sigswt
10112 ENDIF
10113 ELSEIF(mint(82).EQ.1) THEN
10114 xsec(isub,2)=xsec(isub,2)+sigs
10115 ENDIF
10116 IF((isub.EQ.95.OR.isub.EQ.96).AND.loop2.EQ.1.AND.
10117 &mint(82).EQ.1) xsec(97,2)=xsec(97,2)+siglpt
10118
10119C...Multiple interactions: store results of cross-section calculation.
10120 IF(mint(50).EQ.1.AND.mstp(82).GE.3) THEN
10121 vint(153)=sigsor
10122 IF(mint(35).LE.1) CALL pymult(4)
10123 IF(mint(35).GE.2) CALL pymign(4)
10124 ENDIF
10125
10126C...Ratio of actual to maximum cross section.
10127 IF(istsb.NE.11) THEN
10128 viol=sigswt/xsec(isub,1)
10129 IF(isub.EQ.96.AND.mstp(173).EQ.1) viol=viol/parp(174)
10130 ELSEIF(idwtup.EQ.1.OR.idwtup.EQ.2) THEN
10131 viol=xwgtup/xmaxup(kfpr(isub,1))
10132 ELSEIF(idwtup.EQ.-1.OR.idwtup.EQ.-2) THEN
10133 viol=abs(xwgtup)/abs(xmaxup(kfpr(isub,1)))
10134 ELSE
10135 viol=1d0
10136 ENDIF
10137
10138C...Check that weight not negative.
10139 IF(mstp(123).LE.0) THEN
10140 IF(viol.LT.-1d-3) THEN
10141 WRITE(mstu(11),5000) viol,ngen(0,3)+1
10142 IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
10143 & vint(22),vint(23),vint(26)
10144 CALL pystop(2)
10145 ENDIF
10146 ELSE
10147 IF(viol.LT.min(-1d-3,vint(109))) THEN
10148 vint(109)=viol
10149 IF(mstp(123).LE.2) WRITE(mstu(11),5200) viol,ngen(0,3)+1
10150 IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),
10151 & vint(22),vint(23),vint(26)
10152 ENDIF
10153 ENDIF
10154
10155C...Weighting using estimate of maximum of differential cross-section.
10156 ratnd=1d0
10157 IF(mfail.EQ.0.AND.isub.NE.95.AND.isub.NE.96) THEN
10158 IF(viol.LT.pyr(0)) THEN
10159 IF(mint(121).GT.1) CALL pysave(2,iga)
10160 IF(isub.GE.91.AND.isub.LE.94) isub=0
10161 GOTO 100
10162 ENDIF
10163 ELSEIF(mfail.EQ.0) THEN
10164 ratnd=siglpt/xsec(95,1)
10165 viol=viol/ratnd
10166 IF(loop2.EQ.1.AND.ratnd.LT.pyr(0)) THEN
10167 IF(viol.GT.pyr(0).AND.mint(82).EQ.1.AND.msub(95).EQ.1.AND.
10168 & (isub.LE.90.OR.isub.GE.95)) ngen(95,1)=ngen(95,1)+mint(143)
10169 IF(mint(121).GT.1) CALL pysave(2,iga)
10170 isub=0
10171 GOTO 100
10172 ENDIF
10173 IF(viol.LT.pyr(0)) THEN
10174 GOTO 140
10175 ENDIF
10176 ELSEIF(isub.NE.95.AND.isub.NE.96) THEN
10177 IF(viol.LT.pyr(0)) THEN
10178 msti(61)=1
10179 IF(mint(121).GT.1) CALL pysave(2,iga)
10180 RETURN
10181 ENDIF
10182 ELSE
10183 ratnd=siglpt/xsec(95,1)
10184 IF(loop.EQ.1.AND.ratnd.LT.pyr(0)) THEN
10185 msti(61)=1
10186 IF(mint(121).GT.1) CALL pysave(2,iga)
10187 RETURN
10188 ENDIF
10189 viol=viol/ratnd
10190 IF(viol.LT.pyr(0)) THEN
10191 IF(mint(121).GT.1) CALL pysave(2,iga)
10192 GOTO 100
10193 ENDIF
10194 ENDIF
10195
10196C...Check for possible violation of estimated maximum of differential
10197C...cross-section used in weighting.
10198 IF(mstp(123).LE.0) THEN
10199 IF(viol.GT.1d0) THEN
10200 WRITE(mstu(11),5300) viol,ngen(0,3)+1
10201 IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10202 & vint(22),vint(23),vint(26)
10203 CALL pystop(2)
10204 ENDIF
10205 ELSEIF(mstp(123).EQ.1) THEN
10206 IF(viol.GT.vint(108)) THEN
10207 vint(108)=viol
10208 IF(viol.GT.1.0001d0) THEN
10209 mint(10)=1
10210 WRITE(mstu(11),5400) viol,ngen(0,3)+1
10211 IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10212 & vint(22),vint(23),vint(26)
10213 ENDIF
10214 ENDIF
10215 ELSEIF(viol.GT.vint(108)) THEN
10216 vint(108)=viol
10217 IF(viol.GT.1d0) THEN
10218 mint(10)=1
10219 IF(mstp(123).EQ.2) WRITE(mstu(11),5400) viol,ngen(0,3)+1
10220 IF(istsb.EQ.11.AND.(iabs(idwtup).EQ.1.OR.iabs(idwtup).EQ.2))
10221 & THEN
10222 xmaxup(kfpr(isub,1))=viol*xmaxup(kfpr(isub,1))
10223 IF(kfpr(isub,1).LE.9) THEN
10224 IF(mstp(123).EQ.2) WRITE(mstu(11),5800) kfpr(isub,1),
10225 & xmaxup(kfpr(isub,1))
10226 ELSEIF(kfpr(isub,1).LE.99) THEN
10227 IF(mstp(123).EQ.2) WRITE(mstu(11),5900) kfpr(isub,1),
10228 & xmaxup(kfpr(isub,1))
10229 ELSE
10230 IF(mstp(123).EQ.2) WRITE(mstu(11),6000) kfpr(isub,1),
10231 & xmaxup(kfpr(isub,1))
10232 ENDIF
10233 ENDIF
10234 IF(istsb.NE.11.OR.iabs(idwtup).EQ.1) THEN
10235 xdif=xsec(isub,1)*(viol-1d0)
10236 xsec(isub,1)=xsec(isub,1)+xdif
10237 IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))
10238 & xsec(0,1)=xsec(0,1)+xdif
10239 IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),
10240 & vint(22),vint(23),vint(26)
10241 IF(isub.LE.9) THEN
10242 IF(mstp(123).EQ.2) WRITE(mstu(11),5500) isub,xsec(isub,1)
10243 ELSEIF(isub.LE.99) THEN
10244 IF(mstp(123).EQ.2) WRITE(mstu(11),5600) isub,xsec(isub,1)
10245 ELSE
10246 IF(mstp(123).EQ.2) WRITE(mstu(11),5700) isub,xsec(isub,1)
10247 ENDIF
10248 ENDIF
10249 vint(108)=1d0
10250 ENDIF
10251 ENDIF
10252
10253C...Multiple interactions: choose impact parameter (if not already done).
10254 IF(mint(39).EQ.0) vint(148)=1d0
10255 IF(mint(50).EQ.1.AND.(isub.LE.90.OR.isub.GE.96).AND.
10256 &mstp(82).GE.3) THEN
10257 IF(mint(35).LE.1) CALL pymult(5)
10258 IF(mint(35).GE.2) CALL pymign(5)
10259 IF(vint(150).LT.pyr(0)) THEN
10260 IF(mint(121).GT.1) CALL pysave(2,iga)
10261 IF(mfail.EQ.1) THEN
10262 msti(61)=1
10263 RETURN
10264 ENDIF
10265 GOTO 100
10266 ENDIF
10267 ENDIF
10268 IF(mint(82).EQ.1) ngen(0,2)=ngen(0,2)+1
10269 IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN
10270 IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+mint(143)
10271 IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1
10272 ENDIF
10273 IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1
10274
10275C...Choose flavour of reacting partons (and subprocess).
10276 IF(istsb.GE.11) GOTO 320
10277 rsigs=sigs*pyr(0)
10278 qt2=vint(48)
10279 rqqbar=parp(87)*(1d0-(qt2/(qt2+(parp(88)*parp(82)*
10280 &(vint(1)/parp(89))**parp(90))**2))**2)
10281 IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.
10282 &pyr(0).GT.rqqbar)) THEN
10283 DO 310 ichn=1,nchn
10284 kfl1=isig(ichn,1)
10285 kfl2=isig(ichn,2)
10286 mint(2)=isig(ichn,3)
10287 rsigs=rsigs-sigh(ichn)
10288 IF(rsigs.LE.0d0) GOTO 320
10289 310 CONTINUE
10290
10291C...Multiple interactions: choose qqbar preferentially at small pT.
10292 ELSEIF(isub.EQ.96) THEN
10293 mint(105)=mint(103)
10294 mint(109)=mint(107)
10295 CALL pyspli(mint(11),21,kfl1,kfldum)
10296 mint(105)=mint(104)
10297 mint(109)=mint(108)
10298 CALL pyspli(mint(12),21,kfl2,kfldum)
10299 mint(1)=11
10300 mint(2)=1
10301 IF(kfl1.EQ.kfl2.AND.pyr(0).LT.0.5d0) mint(2)=2
10302
10303C...Low-pT: choose string drawing configuration.
10304 ELSE
10305 kfl1=21
10306 kfl2=21
10307 rsigs=6d0*pyr(0)
10308 mint(2)=1
10309 IF(rsigs.GT.1d0) mint(2)=2
10310 IF(rsigs.GT.2d0) mint(2)=3
10311 ENDIF
10312
10313C...Reassign QCD process. Partons before initial state radiation.
10314 320 IF(mint(2).GT.10) THEN
10315 mint(1)=mint(2)/10
10316 mint(2)=mod(mint(2),10)
10317 ENDIF
10318 IF(mint(82).EQ.1.AND.mstp(111).GE.0) ngen(mint(1),2)=
10319 &ngen(mint(1),2)+1
10320 mint(15)=kfl1
10321 mint(16)=kfl2
10322 mint(13)=mint(15)
10323 mint(14)=mint(16)
10324 vint(141)=vint(41)
10325 vint(142)=vint(42)
10326 vint(151)=0d0
10327 vint(152)=0d0
10328
10329C...Calculate x value of photon for parton inside photon inside e.
10330 DO 350 jt=1,2
10331 mint(18+jt)=0
10332 vint(154+jt)=0d0
10333 mspli=0
10334 IF(jt.EQ.1.AND.mint(43).LE.2) mspli=1
10335 IF(jt.EQ.2.AND.mod(mint(43),2).EQ.1) mspli=1
10336 IF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) mspli=mspli+1
10337 IF(mspli.EQ.2) THEN
10338 kflh=mint(14+jt)
10339 xhrd=vint(140+jt)
10340 q2hrd=vint(54)
10341 mint(105)=mint(102+jt)
10342 mint(109)=mint(106+jt)
10343 vint(120)=vint(2+jt)
10344 IF(mstp(57).LE.1) THEN
10345 CALL pypdfu(22,xhrd,q2hrd,xpq)
10346 ELSE
10347 CALL pypdfl(22,xhrd,q2hrd,xpq)
10348 ENDIF
10349 wtmx=4d0*xpq(kflh)
10350 IF(mstp(13).EQ.2) THEN
10351 q2pms=q2hrd/pmas(11,1)**2
10352 wtmx=wtmx*log(max(2d0,q2pms*(1d0-xhrd)/xhrd**2))
10353 ENDIF
10354 330 xe=xhrd**pyr(0)
10355 xg=min(1d0-1d-10,xhrd/xe)
10356 IF(mstp(57).LE.1) THEN
10357 CALL pypdfu(22,xg,q2hrd,xpq)
10358 ELSE
10359 CALL pypdfl(22,xg,q2hrd,xpq)
10360 ENDIF
10361 wt=(1d0+(1d0-xe)**2)*xpq(kflh)
10362 IF(mstp(13).EQ.2) wt=wt*log(max(2d0,q2pms*(1d0-xe)/xe**2))
10363 IF(wt.LT.pyr(0)*wtmx) GOTO 330
10364 mint(18+jt)=1
10365 vint(154+jt)=xe
10366 DO 340 kfls=-25,25
10367 xsfx(jt,kfls)=xpq(kfls)
10368 340 CONTINUE
10369 ENDIF
10370 350 CONTINUE
10371
10372C...Pick scale where photon is resolved.
10373 q0s=parp(15)**2
10374 q1s=vint(154)**2
10375 vint(283)=0d0
10376 IF(mint(107).EQ.3) THEN
10377 IF(mstp(66).EQ.1) THEN
10378 vint(283)=q0s*(vint(54)/q0s)**pyr(0)
10379 ELSEIF(mstp(66).EQ.2) THEN
10380 ps=vint(3)**2
10381 q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
10382 & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
10383 q2int=sqrt(q0s*q2eff)
10384 vint(283)=q2int*(vint(54)/q2int)**pyr(0)
10385 ELSEIF(mstp(66).EQ.3) THEN
10386 vint(283)=q0s*(q1s/q0s)**pyr(0)
10387 ELSEIF(mstp(66).GE.4) THEN
10388 ps=0.25d0*vint(3)**2
10389 vint(283)=(q0s+ps)*(q1s+ps)/
10390 & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
10391 ENDIF
10392 ENDIF
10393 vint(284)=0d0
10394 IF(mint(108).EQ.3) THEN
10395 IF(mstp(66).EQ.1) THEN
10396 vint(284)=q0s*(vint(54)/q0s)**pyr(0)
10397 ELSEIF(mstp(66).EQ.2) THEN
10398 ps=vint(4)**2
10399 q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
10400 & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
10401 q2int=sqrt(q0s*q2eff)
10402 vint(284)=q2int*(vint(54)/q2int)**pyr(0)
10403 ELSEIF(mstp(66).EQ.3) THEN
10404 vint(284)=q0s*(q1s/q0s)**pyr(0)
10405 ELSEIF(mstp(66).GE.4) THEN
10406 ps=0.25d0*vint(4)**2
10407 vint(284)=(q0s+ps)*(q1s+ps)/
10408 & (q0s+pyr(0)*(q1s-q0s)+ps)-ps
10409 ENDIF
10410 ENDIF
10411 IF(mint(121).GT.1) CALL pysave(2,iga)
10412
10413C...Format statements for differential cross-section maximum violations.
10414 5000 FORMAT(/1x,'Error: negative cross-section fraction',1p,d11.3,1x,
10415 &'in event',1x,i7,'D0'/1x,'Execution stopped!')
10416 5100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p,
10417 &d11.3,', y* =',d11.3,', cthe = ',0p,f11.7,', tau'' =',1p,d11.3)
10418 5200 FORMAT(/1x,'Warning: negative cross-section fraction',1p,d11.3,1x,
10419 &'in event',1x,i7)
10420 5300 FORMAT(/1x,'Error: maximum violated by',1p,d11.3,1x,
10421 &'in event',1x,i7,'D0'/1x,'Execution stopped!')
10422 5400 FORMAT(/1x,'Advisory warning: maximum violated by',1p,d11.3,1x,
10423 &'in event',1x,i7)
10424 5500 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,d11.3)
10425 5600 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,d11.3)
10426 5700 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,d11.3)
10427 5800 FORMAT(1x,'XMAXUP(',i1,') increased to',1p,d11.3)
10428 5900 FORMAT(1x,'XMAXUP(',i2,') increased to',1p,d11.3)
10429 6000 FORMAT(1x,'XMAXUP(',i3,') increased to',1p,d11.3)
10430
10431 RETURN
10432 END
10433
10434C*********************************************************************
10435
10436C...PYSCAT
10437C...Finds outgoing flavours and event type; sets up the kinematics
10438C...and colour flow of the hard scattering
10439
10440 SUBROUTINE pyscat
10441
10442C...Double precision and integer declarations
10443 IMPLICIT DOUBLE PRECISION(a-h, o-z)
10444 IMPLICIT INTEGER(I-N)
10445 INTEGER PYK,PYCHGE,PYCOMP
10446C...Parameter statement to help give large particle numbers.
10447 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
10448 &kexcit=4000000,kdimen=5000000)
10449C...Parameter statement for maximum size of showers.
10450 parameter(maxnur=1000)
10451
10452C...User process event common block.
10453 INTEGER MAXNUP
10454 parameter(maxnup=500)
10455 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10456 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10457 common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
10458 &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
10459 &vtimup(maxnup),spinup(maxnup)
10460 SAVE /hepeup/
10461
10462C...Commonblocks.
10463 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
10464 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
10465 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
10466 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
10467 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
10468 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
10469 common/pypars/mstp(200),parp(200),msti(200),pari(200)
10470 common/pyint1/mint(400),vint(400)
10471 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
10472 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
10473 common/pyint4/mwid(500),wids(500,5)
10474 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
10475 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
10476 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
10477 common/pytcsm/itcm(0:99),rtcm(0:99)
10478 common/pypued/iued(0:99),rued(0:99)
10479 SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,
10480 &/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyssmt/,
10481 &/pytcsm/,/pypued/
10482C...Local arrays and saved variables
10483 dimension wdtp(0:400),wdte(0:400,0:5),pmq(2),z(2),cthe(2),
10484 &phi(2),kuppo(100),vintsv(41:66),ilab(100)
10485 INTEGER IOKFLA(6),IIFLAV
10486C...UED related declarations:
10487C...equivalences between ordered particles (451->475)
10488C...and UED particle code (5 000 000 + id)
10489 dimension iuedeq(475),mued(2)
10490 DATA (iuedeq(i),i=451,475)/
10491 & 6100001,6100002,6100003,6100004,6100005,6100006,
10492 & 5100001,5100002,5100003,5100004,5100005,5100006,
10493 & 6100011,6100013,6100015,
10494 & 5100012,5100011,5100014,5100013,5100016,5100015,
10495 & 5100021,5100022,5100023,5100024/
10496 SAVE vintsv
10497
10498C...Read out process
10499 isub=mint(1)
10500 isubsv=isub
10501
10502C...Restore information for low-pT processes
10503 IF(isub.EQ.95.AND.mint(57).GE.1) THEN
10504 DO 100 j=41,66
10505 100 vint(j)=vintsv(j)
10506 ENDIF
10507
10508C...Convert H' or A process into equivalent H one
10509 ihigg=1
10510 kfhigg=25
10511 IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
10512 &isub.LE.190)) THEN
10513 ihigg=2
10514 IF(mod(isub-1,10).GE.5) ihigg=3
10515 kfhigg=33+ihigg
10516 IF(isub.EQ.151.OR.isub.EQ.156) isub=3
10517 IF(isub.EQ.152.OR.isub.EQ.157) isub=102
10518 IF(isub.EQ.153.OR.isub.EQ.158) isub=103
10519 IF(isub.EQ.171.OR.isub.EQ.176) isub=24
10520 IF(isub.EQ.172.OR.isub.EQ.177) isub=26
10521 IF(isub.EQ.173.OR.isub.EQ.178) isub=123
10522 IF(isub.EQ.174.OR.isub.EQ.179) isub=124
10523 IF(isub.EQ.181.OR.isub.EQ.186) isub=121
10524 IF(isub.EQ.182.OR.isub.EQ.187) isub=122
10525 IF(isub.EQ.183.OR.isub.EQ.188) isub=111
10526 IF(isub.EQ.184.OR.isub.EQ.189) isub=112
10527 IF(isub.EQ.185.OR.isub.EQ.190) isub=113
10528 ENDIF
10529
10530 IF(isub.EQ.401.OR.isub.EQ.402) kfhigg=kfpr(isub,1)
10531
10532C...Convert bottomonium process into equivalent charmonium ones.
10533 IF(isub.GE.461.AND.isub.LE.479) isub=isub-40
10534
10535C...Choice of subprocess, number of documentation lines
10536 idoc=6+iset(isub)
10537 IF(isub.EQ.95) idoc=8
10538 IF(iset(isub).EQ.5) idoc=9
10539 IF(iset(isub).EQ.11) idoc=4+nup
10540 mint(3)=idoc-6
10541 IF(idoc.GE.9.AND.iset(isub).LE.4) idoc=idoc+2
10542 mint(4)=idoc
10543 ipu1=mint(84)+1
10544 ipu2=mint(84)+2
10545 ipu3=mint(84)+3
10546 ipu4=mint(84)+4
10547 ipu5=mint(84)+5
10548 ipu6=mint(84)+6
10549
10550C...Reset K, P and V vectors. Store incoming particles
10551 DO 120 jt=1,mstp(126)+100
10552 i=mint(83)+jt
10553 IF(i.GT.mstu(4)) GOTO 120
10554 DO 110 j=1,5
10555 k(i,j)=0
10556 p(i,j)=0d0
10557 v(i,j)=0d0
10558 110 CONTINUE
10559 120 CONTINUE
10560 DO 140 jt=1,2
10561 i=mint(83)+jt
10562 k(i,1)=21
10563 k(i,2)=mint(10+jt)
10564 DO 130 j=1,5
10565 p(i,j)=vint(285+5*jt+j)
10566 130 CONTINUE
10567 140 CONTINUE
10568 mint(6)=2
10569 kfres=0
10570
10571C...Store incoming partons in their CM-frame. Save pdf value.
10572 sh=vint(44)
10573 shr=sqrt(sh)
10574 shp=vint(26)*vint(2)
10575 shpr=sqrt(shp)
10576 shuser=shr
10577 IF(iset(isub).GE.3.AND.iset(isub).LE.5) shuser=shpr
10578 DO 150 jt=1,2
10579 i=mint(84)+jt
10580 k(i,1)=14
10581 k(i,2)=mint(14+jt)
10582 k(i,3)=mint(83)+2+jt
10583 p(i,3)=0.5d0*shuser*(-1d0)**(jt-1)
10584 p(i,4)=0.5d0*shuser
10585 vint(38+jt)=xsfx(jt,mint(14+jt))
10586 150 CONTINUE
10587
10588C...Copy incoming partons to documentation lines
10589 DO 170 jt=1,2
10590 i1=mint(83)+4+jt
10591 i2=mint(84)+jt
10592 k(i1,1)=21
10593 k(i1,2)=k(i2,2)
10594 k(i1,3)=i1-2
10595 DO 160 j=1,5
10596 p(i1,j)=p(i2,j)
10597 160 CONTINUE
10598 170 CONTINUE
10599
10600C...Choose new quark/lepton flavour for relevant annihilation graphs
10601 IF(isub.EQ.12.OR.isub.EQ.53.OR.isub.EQ.54.OR.isub.EQ.58.OR.
10602 &isub.EQ.314.OR.isub.EQ.319.OR.isub.EQ.316.OR.
10603 &(isub.GE.135.AND.isub.LE.140).OR.isub.EQ.382.OR.isub.EQ.385) THEN
10604 iglga=21
10605 IF(isub.EQ.58.OR.(isub.GE.137.AND.isub.LE.140)) iglga=22
10606 CALL pywidt(iglga,sh,wdtp,wdte)
10607 180 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
10608 DO 190 i=1,mdcy(iglga,3)
10609 kflf=kfdp(i+mdcy(iglga,2)-1,1)
10610 rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
10611 IF(rkfl.LE.0d0) GOTO 200
10612 190 CONTINUE
10613 200 CONTINUE
10614 IF((isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319
10615 & .OR.isub.EQ.316).AND.mint(2).LE.2) THEN
10616 IF(kflf.GE.4) GOTO 180
10617 ELSEIF((isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319.
10618 & or.isub.EQ.316).AND.mint(2).LE.4) THEN
10619 kflf=4
10620 mint(2)=mint(2)-2
10621 ELSEIF(isub.EQ.53.OR.isub.EQ.385.OR.isub.EQ.314.OR.isub.EQ.319.
10622 & or.isub.EQ.316) THEN
10623 kflf=5
10624 mint(2)=mint(2)-4
10625 ELSEIF(isub.EQ.382.AND.itcm(5).EQ.1.AND.iabs(mint(15)).LE.2
10626 & .AND.iabs(kflf).GE.3) THEN
10627 facqqb=vint(58)**2*4d0/9d0*(vint(45)**2+vint(46)**2)/
10628 & vint(44)**2
10629 faccib=vint(46)**2/rtcm(41)**4
10630 IF(facqqb/(facqqb+faccib).LT.pyr(0)) GOTO 180
10631 ELSEIF(isub.EQ.382.AND.itcm(5).EQ.5.AND.mint(2).EQ.2) THEN
10632 kflf=5
10633 mint(2)=1
10634 ELSEIF(isub.EQ.382.AND.itcm(5).EQ.5.AND.mint(2).EQ.1) THEN
10635 IF(kflf.EQ.5) GOTO 180
10636 ELSEIF(isub.EQ.54.OR.isub.EQ.135.OR.isub.EQ.136) THEN
10637 IF((kchg(pycomp(kflf),1)/2d0)**2.LT.pyr(0)) GOTO 180
10638 ELSEIF(isub.EQ.58.OR.(isub.GE.137.AND.isub.LE.140)) THEN
10639 IF((kchg(pycomp(kflf),1)/3d0)**2.LT.pyr(0)) GOTO 180
10640 ENDIF
10641 ENDIF
10642
10643C...Final state flavours and colour flow: default values
10644 js=1
10645 mint(21)=mint(15)
10646 mint(22)=mint(16)
10647 mint(23)=0
10648 mint(24)=0
10649 kcc=20
10650 kcs=isign(1,mint(15))
10651
10652 IF(iset(isub).EQ.11) THEN
10653C...User-defined processes: find products
10654 mint(3)=0
10655 DO 210 iup=3,nup
10656 IF(istup(iup).LT.1.OR.istup(iup).GT.3) THEN
10657 ELSEIF(nup.EQ.5.AND.iup.GE.4.AND.mothup(1,4).EQ.3) THEN
10658 mint(21+iup)=idup(iup)
10659 ELSEIF(istup(iup).EQ.1.AND.(istup(mothup(1,iup)).EQ.2.OR.
10660 & istup(mothup(1,iup)).EQ.3).AND.idup(mothup(1,iup)).NE.0) THEN
10661 ELSEIF(idup(iup).EQ.0) THEN
10662 ELSE
10663 mint(3)=mint(3)+1
10664 IF(mint(3).LE.6) mint(20+mint(3))=idup(iup)
10665 ENDIF
10666 210 CONTINUE
10667
10668 ELSEIF(isub.LE.10) THEN
10669 IF(isub.EQ.1) THEN
10670C...f + fbar -> gamma*/Z0
10671 kfres=23
10672
10673 ELSEIF(isub.EQ.2) THEN
10674C...f + fbar' -> W+/-
10675 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10676 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10677 kfres=isign(24,kch1+kch2)
10678
10679 ELSEIF(isub.EQ.3) THEN
10680C...f + fbar -> h0 (or H0, or A0)
10681 kfres=kfhigg
10682
10683 ELSEIF(isub.EQ.4) THEN
10684C...gamma + W+/- -> W+/-
10685
10686 ELSEIF(isub.EQ.5) THEN
10687C...Z0 + Z0 -> h0
10688 xh=sh/shp
10689 mint(21)=mint(15)
10690 mint(22)=mint(16)
10691 pmq(1)=pymass(mint(21))
10692 pmq(2)=pymass(mint(22))
10693 220 jt=int(1.5d0+pyr(0))
10694 zmin=2d0*pmq(jt)/shpr
10695 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
10696 & (shpr*(shpr-pmq(3-jt)))
10697 zmax=min(1d0-xh,zmax)
10698 z(jt)=zmin+(zmax-zmin)*pyr(0)
10699 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
10700 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 220
10701 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
10702 IF(sqc1.LT.1d-8) GOTO 220
10703 c1=sqrt(sqc1)
10704 c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
10705 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10706 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
10707 z(3-jt)=1d0-xh/(1d0-z(jt))
10708 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
10709 IF(sqc1.LT.1d-8) GOTO 220
10710 c1=sqrt(sqc1)
10711 c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
10712 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10713 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
10714 phir=paru(2)*pyr(0)
10715 cphi=cos(phir)
10716 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
10717 & sqrt(1d0-cthe(2)**2)*cphi
10718 z1=2d0-z(jt)
10719 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
10720 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
10721 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
10722 & pmq(3-jt)**2/shp))
10723 zmin=2d0*pmq(3-jt)/shpr
10724 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
10725 zmax=min(1d0-xh,zmax)
10726 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 220
10727 kcc=22
10728 kfres=25
10729
10730 ELSEIF(isub.EQ.6) THEN
10731C...Z0 + W+/- -> W+/-
10732
10733 ELSEIF(isub.EQ.7) THEN
10734C...W+ + W- -> Z0
10735
10736 ELSEIF(isub.EQ.8) THEN
10737C...W+ + W- -> h0
10738 xh=sh/shp
10739 230 DO 260 jt=1,2
10740 i=mint(14+jt)
10741 ia=iabs(i)
10742 IF(ia.LE.10) THEN
10743 rvckm=vint(180+i)*pyr(0)
10744 DO 240 j=1,mstp(1)
10745 ib=2*j-1+mod(ia,2)
10746 ipm=(5-isign(1,i))/2
10747 idc=j+mdcy(ia,2)+2
10748 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 240
10749 mint(20+jt)=isign(ib,i)
10750 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
10751 IF(rvckm.LE.0d0) GOTO 250
10752 240 CONTINUE
10753 ELSE
10754 ib=2*((ia+1)/2)-1+mod(ia,2)
10755 mint(20+jt)=isign(ib,i)
10756 ENDIF
10757 250 pmq(jt)=pymass(mint(20+jt))
10758 260 CONTINUE
10759 jt=int(1.5d0+pyr(0))
10760 zmin=2d0*pmq(jt)/shpr
10761 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
10762 & (shpr*(shpr-pmq(3-jt)))
10763 zmax=min(1d0-xh,zmax)
10764 IF(zmin.GE.zmax) GOTO 230
10765 z(jt)=zmin+(zmax-zmin)*pyr(0)
10766 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
10767 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 230
10768 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
10769 IF(sqc1.LT.1d-8) GOTO 230
10770 c1=sqrt(sqc1)
10771 c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
10772 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10773 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
10774 z(3-jt)=1d0-xh/(1d0-z(jt))
10775 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
10776 IF(sqc1.LT.1d-8) GOTO 230
10777 c1=sqrt(sqc1)
10778 c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
10779 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
10780 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
10781 phir=paru(2)*pyr(0)
10782 cphi=cos(phir)
10783 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
10784 & sqrt(1d0-cthe(2)**2)*cphi
10785 z1=2d0-z(jt)
10786 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
10787 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
10788 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
10789 & pmq(3-jt)**2/shp))
10790 zmin=2d0*pmq(3-jt)/shpr
10791 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
10792 zmax=min(1d0-xh,zmax)
10793 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 230
10794 kcc=22
10795 kfres=25
10796
10797 ELSEIF(isub.EQ.10) THEN
10798C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10799 IF(mint(2).EQ.1) THEN
10800 kcc=22
10801 ELSE
10802C...W exchange: need to mix flavours according to CKM matrix
10803 DO 280 jt=1,2
10804 i=mint(14+jt)
10805 ia=iabs(i)
10806 IF(ia.LE.10) THEN
10807 rvckm=vint(180+i)*pyr(0)
10808 DO 270 j=1,mstp(1)
10809 ib=2*j-1+mod(ia,2)
10810 ipm=(5-isign(1,i))/2
10811 idc=j+mdcy(ia,2)+2
10812 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 270
10813 mint(20+jt)=isign(ib,i)
10814 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
10815 IF(rvckm.LE.0d0) GOTO 280
10816 270 CONTINUE
10817 ELSE
10818 ib=2*((ia+1)/2)-1+mod(ia,2)
10819 mint(20+jt)=isign(ib,i)
10820 ENDIF
10821 280 CONTINUE
10822 kcc=22
10823 ENDIF
10824 ENDIF
10825
10826 ELSEIF(isub.LE.20) THEN
10827 IF(isub.EQ.11) THEN
10828C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10829 kcc=mint(2)
10830 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
10831
10832 ELSEIF(isub.EQ.12) THEN
10833C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10834 mint(21)=isign(kflf,mint(15))
10835 mint(22)=-mint(21)
10836 kcc=4
10837
10838 ELSEIF(isub.EQ.13) THEN
10839C...f + fbar -> g + g; th arbitrary
10840 mint(21)=21
10841 mint(22)=21
10842 kcc=mint(2)+4
10843
10844 ELSEIF(isub.EQ.14) THEN
10845C...f + fbar -> g + gamma; th arbitrary
10846 IF(pyr(0).GT.0.5d0) js=2
10847 mint(20+js)=21
10848 mint(23-js)=22
10849 kcc=17+js
10850
10851 ELSEIF(isub.EQ.15) THEN
10852C...f + fbar -> g + Z0; th arbitrary
10853 IF(pyr(0).GT.0.5d0) js=2
10854 mint(20+js)=21
10855 mint(23-js)=23
10856 kcc=17+js
10857
10858 ELSEIF(isub.EQ.16) THEN
10859C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10860 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10861 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10862 IF(mint(15)*(kch1+kch2).LT.0) js=2
10863 mint(20+js)=21
10864 mint(23-js)=isign(24,kch1+kch2)
10865 kcc=17+js
10866
10867 ELSEIF(isub.EQ.17) THEN
10868C...f + fbar -> g + h0; th arbitrary
10869 IF(pyr(0).GT.0.5d0) js=2
10870 mint(20+js)=21
10871 mint(23-js)=25
10872 kcc=17+js
10873
10874 ELSEIF(isub.EQ.18) THEN
10875C...f + fbar -> gamma + gamma; th arbitrary
10876 mint(21)=22
10877 mint(22)=22
10878
10879 ELSEIF(isub.EQ.19) THEN
10880C...f + fbar -> gamma + Z0; th arbitrary
10881 IF(pyr(0).GT.0.5d0) js=2
10882 mint(20+js)=22
10883 mint(23-js)=23
10884
10885 ELSEIF(isub.EQ.20) THEN
10886C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10887C...(p(fbar')-p(W+))**2
10888 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10889 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10890 IF(mint(15)*(kch1+kch2).LT.0) js=2
10891 mint(20+js)=22
10892 mint(23-js)=isign(24,kch1+kch2)
10893 ENDIF
10894
10895 ELSEIF(isub.LE.30) THEN
10896 IF(isub.EQ.21) THEN
10897C...f + fbar -> gamma + h0; th arbitrary
10898 IF(pyr(0).GT.0.5d0) js=2
10899 mint(20+js)=22
10900 mint(23-js)=25
10901
10902 ELSEIF(isub.EQ.22) THEN
10903C...f + fbar -> Z0 + Z0; th arbitrary
10904 mint(21)=23
10905 mint(22)=23
10906
10907 ELSEIF(isub.EQ.23) THEN
10908C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10909 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10910 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10911 IF(mint(15)*(kch1+kch2).LT.0) js=2
10912 mint(20+js)=23
10913 mint(23-js)=isign(24,kch1+kch2)
10914
10915 ELSEIF(isub.EQ.24) THEN
10916C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10917 IF(pyr(0).GT.0.5d0) js=2
10918 mint(20+js)=23
10919 mint(23-js)=kfhigg
10920
10921 ELSEIF(isub.EQ.25) THEN
10922C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10923 mint(21)=-isign(24,mint(15))
10924 mint(22)=-mint(21)
10925
10926 ELSEIF(isub.EQ.26) THEN
10927C...f + fbar' -> W+/- + h0 (or H0, or A0);
10928C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10929 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
10930 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
10931 IF(mint(15)*(kch1+kch2).GT.0) js=2
10932 mint(20+js)=isign(24,kch1+kch2)
10933 mint(23-js)=kfhigg
10934
10935 ELSEIF(isub.EQ.27) THEN
10936C...f + fbar -> h0 + h0
10937
10938 ELSEIF(isub.EQ.28) THEN
10939C...f + g -> f + g; th = (p(f)-p(f))**2
10940 IF(mint(15).EQ.21) js=2
10941 kcc=mint(2)+6
10942 IF(mint(15).EQ.21) kcc=kcc+2
10943 IF(mint(15).NE.21) kcs=isign(1,mint(15))
10944 IF(mint(16).NE.21) kcs=isign(1,mint(16))
10945
10946 ELSEIF(isub.EQ.29) THEN
10947C...f + g -> f + gamma; th = (p(f)-p(f))**2
10948 IF(mint(15).EQ.21) js=2
10949 mint(23-js)=22
10950 kcc=15+js
10951 kcs=isign(1,mint(14+js))
10952
10953 ELSEIF(isub.EQ.30) THEN
10954C...f + g -> f + Z0; th = (p(f)-p(f))**2
10955 IF(mint(15).EQ.21) js=2
10956 mint(23-js)=23
10957 kcc=15+js
10958 kcs=isign(1,mint(14+js))
10959 ENDIF
10960
10961 ELSEIF(isub.LE.40) THEN
10962 IF(isub.EQ.31) THEN
10963C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10964 IF(mint(15).EQ.21) js=2
10965 i=mint(14+js)
10966 ia=iabs(i)
10967 mint(23-js)=isign(24,kchg(ia,1)*i)
10968 rvckm=vint(180+i)*pyr(0)
10969 DO 290 j=1,mstp(1)
10970 ib=2*j-1+mod(ia,2)
10971 ipm=(5-isign(1,i))/2
10972 idc=j+mdcy(ia,2)+2
10973 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 290
10974 mint(20+js)=isign(ib,i)
10975 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
10976 IF(rvckm.LE.0d0) GOTO 300
10977 290 CONTINUE
10978 300 kcc=15+js
10979 kcs=isign(1,mint(14+js))
10980
10981 ELSEIF(isub.EQ.32) THEN
10982C...f + g -> f + h0; th = (p(f)-p(f))**2
10983 IF(mint(15).EQ.21) js=2
10984 mint(23-js)=25
10985 kcc=15+js
10986 kcs=isign(1,mint(14+js))
10987
10988 ELSEIF(isub.EQ.33) THEN
10989C...f + gamma -> f + g; th=(p(f)-p(f))**2
10990 IF(mint(15).EQ.22) js=2
10991 mint(23-js)=21
10992 kcc=24+js
10993 kcs=isign(1,mint(14+js))
10994
10995 ELSEIF(isub.EQ.34) THEN
10996C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10997 IF(mint(15).EQ.22) js=2
10998 kcc=22
10999 kcs=isign(1,mint(14+js))
11000
11001 ELSEIF(isub.EQ.35) THEN
11002C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11003 IF(mint(15).EQ.22) js=2
11004 mint(23-js)=23
11005 kcc=22
11006
11007 ELSEIF(isub.EQ.36) THEN
11008C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11009 IF(mint(15).EQ.22) js=2
11010 i=mint(14+js)
11011 ia=iabs(i)
11012 mint(23-js)=isign(24,kchg(ia,1)*i)
11013 IF(ia.LE.10) THEN
11014 rvckm=vint(180+i)*pyr(0)
11015 DO 310 j=1,mstp(1)
11016 ib=2*j-1+mod(ia,2)
11017 ipm=(5-isign(1,i))/2
11018 idc=j+mdcy(ia,2)+2
11019 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 310
11020 mint(20+js)=isign(ib,i)
11021 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11022 IF(rvckm.LE.0d0) GOTO 320
11023 310 CONTINUE
11024 ELSE
11025 ib=2*((ia+1)/2)-1+mod(ia,2)
11026 mint(20+js)=isign(ib,i)
11027 ENDIF
11028 320 kcc=22
11029
11030 ELSEIF(isub.EQ.37) THEN
11031C...f + gamma -> f + h0
11032
11033 ELSEIF(isub.EQ.38) THEN
11034C...f + Z0 -> f + g
11035
11036 ELSEIF(isub.EQ.39) THEN
11037C...f + Z0 -> f + gamma
11038
11039 ELSEIF(isub.EQ.40) THEN
11040C...f + Z0 -> f + Z0
11041 ENDIF
11042
11043 ELSEIF(isub.LE.50) THEN
11044 IF(isub.EQ.41) THEN
11045C...f + Z0 -> f' + W+/-
11046
11047 ELSEIF(isub.EQ.42) THEN
11048C...f + Z0 -> f + h0
11049
11050 ELSEIF(isub.EQ.43) THEN
11051C...f + W+/- -> f' + g
11052
11053 ELSEIF(isub.EQ.44) THEN
11054C...f + W+/- -> f' + gamma
11055
11056 ELSEIF(isub.EQ.45) THEN
11057C...f + W+/- -> f' + Z0
11058
11059 ELSEIF(isub.EQ.46) THEN
11060C...f + W+/- -> f' + W+/-
11061
11062 ELSEIF(isub.EQ.47) THEN
11063C...f + W+/- -> f' + h0
11064
11065 ELSEIF(isub.EQ.48) THEN
11066C...f + h0 -> f + g
11067
11068 ELSEIF(isub.EQ.49) THEN
11069C...f + h0 -> f + gamma
11070
11071 ELSEIF(isub.EQ.50) THEN
11072C...f + h0 -> f + Z0
11073 ENDIF
11074
11075 ELSEIF(isub.LE.60) THEN
11076 IF(isub.EQ.51) THEN
11077C...f + h0 -> f' + W+/-
11078
11079 ELSEIF(isub.EQ.52) THEN
11080C...f + h0 -> f + h0
11081
11082 ELSEIF(isub.EQ.53) THEN
11083C...g + g -> f + fbar; th arbitrary
11084 kcs=(-1)**int(1.5d0+pyr(0))
11085 mint(21)=isign(kflf,kcs)
11086 mint(22)=-mint(21)
11087 kcc=mint(2)+10
11088
11089 ELSEIF(isub.EQ.54) THEN
11090C...g + gamma -> f + fbar; th arbitrary
11091 kcs=(-1)**int(1.5d0+pyr(0))
11092 mint(21)=isign(kflf,kcs)
11093 mint(22)=-mint(21)
11094 kcc=27
11095 IF(mint(16).EQ.21) kcc=28
11096
11097 ELSEIF(isub.EQ.55) THEN
11098C...g + Z0 -> f + fbar
11099
11100 ELSEIF(isub.EQ.56) THEN
11101C...g + W+/- -> f + fbar'
11102
11103 ELSEIF(isub.EQ.57) THEN
11104C...g + h0 -> f + fbar
11105
11106 ELSEIF(isub.EQ.58) THEN
11107C...gamma + gamma -> f + fbar; th arbitrary
11108 kcs=(-1)**int(1.5d0+pyr(0))
11109 mint(21)=isign(kflf,kcs)
11110 mint(22)=-mint(21)
11111 kcc=21
11112
11113 ELSEIF(isub.EQ.59) THEN
11114C...gamma + Z0 -> f + fbar
11115
11116 ELSEIF(isub.EQ.60) THEN
11117C...gamma + W+/- -> f + fbar'
11118 ENDIF
11119
11120 ELSEIF(isub.LE.70) THEN
11121 IF(isub.EQ.61) THEN
11122C...gamma + h0 -> f + fbar
11123
11124 ELSEIF(isub.EQ.62) THEN
11125C...Z0 + Z0 -> f + fbar
11126
11127 ELSEIF(isub.EQ.63) THEN
11128C...Z0 + W+/- -> f + fbar'
11129
11130 ELSEIF(isub.EQ.64) THEN
11131C...Z0 + h0 -> f + fbar
11132
11133 ELSEIF(isub.EQ.65) THEN
11134C...W+ + W- -> f + fbar
11135
11136 ELSEIF(isub.EQ.66) THEN
11137C...W+/- + h0 -> f + fbar'
11138
11139 ELSEIF(isub.EQ.67) THEN
11140C...h0 + h0 -> f + fbar
11141
11142 ELSEIF(isub.EQ.68) THEN
11143C...g + g -> g + g; th arbitrary
11144 kcc=mint(2)+12
11145 kcs=(-1)**int(1.5d0+pyr(0))
11146
11147 ELSEIF(isub.EQ.69) THEN
11148C...gamma + gamma -> W+ + W-; th arbitrary
11149 mint(21)=24
11150 mint(22)=-24
11151 kcc=21
11152
11153 ELSEIF(isub.EQ.70) THEN
11154C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11155 IF(mint(15).EQ.22) mint(21)=23
11156 IF(mint(16).EQ.22) mint(22)=23
11157 kcc=21
11158 ENDIF
11159
11160 ELSEIF(isub.LE.80) THEN
11161 IF(isub.EQ.71.OR.isub.EQ.72) THEN
11162C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11163 xh=sh/shp
11164 mint(21)=mint(15)
11165 mint(22)=mint(16)
11166 pmq(1)=pymass(mint(21))
11167 pmq(2)=pymass(mint(22))
11168 330 jt=int(1.5d0+pyr(0))
11169 zmin=2d0*pmq(jt)/shpr
11170 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11171 & (shpr*(shpr-pmq(3-jt)))
11172 zmax=min(1d0-xh,zmax)
11173 z(jt)=zmin+(zmax-zmin)*pyr(0)
11174 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11175 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 330
11176 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11177 IF(sqc1.LT.1d-8) GOTO 330
11178 c1=sqrt(sqc1)
11179 c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
11180 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11181 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11182 z(3-jt)=1d0-xh/(1d0-z(jt))
11183 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11184 IF(sqc1.LT.1d-8) GOTO 330
11185 c1=sqrt(sqc1)
11186 c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11187 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11188 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11189 phir=paru(2)*pyr(0)
11190 cphi=cos(phir)
11191 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11192 & sqrt(1d0-cthe(2)**2)*cphi
11193 z1=2d0-z(jt)
11194 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11195 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11196 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11197 & pmq(3-jt)**2/shp))
11198 zmin=2d0*pmq(3-jt)/shpr
11199 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11200 zmax=min(1d0-xh,zmax)
11201 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 330
11202 kcc=22
11203
11204 ELSEIF(isub.EQ.73) THEN
11205C...Z0 + W+/- -> Z0 + W+/-
11206 js=mint(2)
11207 xh=sh/shp
11208 340 jt=3-mint(2)
11209 i=mint(14+jt)
11210 ia=iabs(i)
11211 IF(ia.LE.10) THEN
11212 rvckm=vint(180+i)*pyr(0)
11213 DO 350 j=1,mstp(1)
11214 ib=2*j-1+mod(ia,2)
11215 ipm=(5-isign(1,i))/2
11216 idc=j+mdcy(ia,2)+2
11217 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 350
11218 mint(20+jt)=isign(ib,i)
11219 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11220 IF(rvckm.LE.0d0) GOTO 360
11221 350 CONTINUE
11222 ELSE
11223 ib=2*((ia+1)/2)-1+mod(ia,2)
11224 mint(20+jt)=isign(ib,i)
11225 ENDIF
11226 360 pmq(jt)=pymass(mint(20+jt))
11227 mint(23-jt)=mint(17-jt)
11228 pmq(3-jt)=pymass(mint(23-jt))
11229 jt=int(1.5d0+pyr(0))
11230 zmin=2d0*pmq(jt)/shpr
11231 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11232 & (shpr*(shpr-pmq(3-jt)))
11233 zmax=min(1d0-xh,zmax)
11234 IF(zmin.GE.zmax) GOTO 340
11235 z(jt)=zmin+(zmax-zmin)*pyr(0)
11236 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11237 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 340
11238 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11239 IF(sqc1.LT.1d-8) GOTO 340
11240 c1=sqrt(sqc1)
11241 c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)
11242 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11243 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11244 z(3-jt)=1d0-xh/(1d0-z(jt))
11245 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11246 IF(sqc1.LT.1d-8) GOTO 340
11247 c1=sqrt(sqc1)
11248 c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11249 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11250 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11251 phir=paru(2)*pyr(0)
11252 cphi=cos(phir)
11253 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11254 & sqrt(1d0-cthe(2)**2)*cphi
11255 z1=2d0-z(jt)
11256 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11257 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11258 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11259 & pmq(3-jt)**2/shp))
11260 zmin=2d0*pmq(3-jt)/shpr
11261 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11262 zmax=min(1d0-xh,zmax)
11263 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 340
11264 kcc=22
11265
11266 ELSEIF(isub.EQ.74) THEN
11267C...Z0 + h0 -> Z0 + h0
11268
11269 ELSEIF(isub.EQ.75) THEN
11270C...W+ + W- -> gamma + gamma
11271
11272 ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN
11273C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11274 xh=sh/shp
11275 370 DO 400 jt=1,2
11276 i=mint(14+jt)
11277 ia=iabs(i)
11278 IF(ia.LE.10) THEN
11279 rvckm=vint(180+i)*pyr(0)
11280 DO 380 j=1,mstp(1)
11281 ib=2*j-1+mod(ia,2)
11282 ipm=(5-isign(1,i))/2
11283 idc=j+mdcy(ia,2)+2
11284 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 380
11285 mint(20+jt)=isign(ib,i)
11286 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11287 IF(rvckm.LE.0d0) GOTO 390
11288 380 CONTINUE
11289 ELSE
11290 ib=2*((ia+1)/2)-1+mod(ia,2)
11291 mint(20+jt)=isign(ib,i)
11292 ENDIF
11293 390 pmq(jt)=pymass(mint(20+jt))
11294 400 CONTINUE
11295 jt=int(1.5d0+pyr(0))
11296 zmin=2d0*pmq(jt)/shpr
11297 zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/
11298 & (shpr*(shpr-pmq(3-jt)))
11299 zmax=min(1d0-xh,zmax)
11300 IF(zmin.GE.zmax) GOTO 370
11301 z(jt)=zmin+(zmax-zmin)*pyr(0)
11302 IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.
11303 & (1d0-xh)**2/(4d0*xh)*pyr(0)) GOTO 370
11304 sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)
11305 IF(sqc1.LT.1d-8) GOTO 370
11306 c1=sqrt(sqc1)
11307 c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)
11308 cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11309 cthe(jt)=min(1d0,max(-1d0,cthe(jt)))
11310 z(3-jt)=1d0-xh/(1d0-z(jt))
11311 sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)
11312 IF(sqc1.LT.1d-8) GOTO 370
11313 c1=sqrt(sqc1)
11314 c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)
11315 cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1
11316 cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))
11317 phir=paru(2)*pyr(0)
11318 cphi=cos(phir)
11319 ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*
11320 & sqrt(1d0-cthe(2)**2)*cphi
11321 z1=2d0-z(jt)
11322 z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)
11323 z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp
11324 z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*
11325 & pmq(3-jt)**2/shp))
11326 zmin=2d0*pmq(3-jt)/shpr
11327 zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))
11328 zmax=min(1d0-xh,zmax)
11329 IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) GOTO 370
11330 kcc=22
11331
11332 ELSEIF(isub.EQ.78) THEN
11333C...W+/- + h0 -> W+/- + h0
11334
11335 ELSEIF(isub.EQ.79) THEN
11336C...h0 + h0 -> h0 + h0
11337
11338 ELSEIF(isub.EQ.80) THEN
11339C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11340 IF(mint(15).EQ.22) js=2
11341 i=mint(14+js)
11342 ia=iabs(i)
11343 mint(23-js)=isign(211,kchg(ia,1)*i)
11344 ib=3-ia
11345 mint(20+js)=isign(ib,i)
11346 kcc=22
11347 ENDIF
11348
11349 ELSEIF(isub.LE.90) THEN
11350 IF(isub.EQ.81) THEN
11351C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11352 mint(21)=isign(mint(55),mint(15))
11353 mint(22)=-mint(21)
11354 kcc=4
11355
11356 ELSEIF(isub.EQ.82) THEN
11357C...g + g -> Q + Qbar; th arbitrary
11358 kcs=(-1)**int(1.5d0+pyr(0))
11359 mint(21)=isign(mint(55),kcs)
11360 mint(22)=-mint(21)
11361 kcc=mint(2)+10
11362
11363 ELSEIF(isub.EQ.83) THEN
11364C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11365 kfold=mint(16)
11366 IF(mint(2).EQ.2) kfold=mint(15)
11367 kfaold=iabs(kfold)
11368 IF(kfaold.GT.10) THEN
11369 kfanew=kfaold+2*mod(kfaold,2)-1
11370 ELSE
11371 rckm=vint(180+kfold)*pyr(0)
11372 ipm=(5-isign(1,kfold))/2
11373 kfanew=-mod(kfaold+1,2)
11374 410 kfanew=kfanew+2
11375 idc=mdcy(kfaold,2)+(kfanew+1)/2+2
11376 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) THEN
11377 IF(mod(kfaold,2).EQ.0) rckm=rckm-
11378 & vckm(kfaold/2,(kfanew+1)/2)
11379 IF(mod(kfaold,2).EQ.1) rckm=rckm-
11380 & vckm(kfanew/2,(kfaold+1)/2)
11381 ENDIF
11382 IF(kfanew.LE.6.AND.rckm.GT.0d0) GOTO 410
11383 ENDIF
11384 IF(mint(2).EQ.1) THEN
11385 mint(21)=isign(mint(55),mint(15))
11386 mint(22)=isign(kfanew,mint(16))
11387 ELSE
11388 mint(21)=isign(kfanew,mint(15))
11389 mint(22)=isign(mint(55),mint(16))
11390 js=2
11391 ENDIF
11392 kcc=22
11393
11394 ELSEIF(isub.EQ.84) THEN
11395C...g + gamma -> Q + Qbar; th arbitary
11396 kcs=(-1)**int(1.5d0+pyr(0))
11397 mint(21)=isign(mint(55),kcs)
11398 mint(22)=-mint(21)
11399 kcc=27
11400 IF(mint(16).EQ.21) kcc=28
11401
11402 ELSEIF(isub.EQ.85) THEN
11403C...gamma + gamma -> F + Fbar; th arbitary
11404 kcs=(-1)**int(1.5d0+pyr(0))
11405 mint(21)=isign(mint(56),kcs)
11406 mint(22)=-mint(21)
11407 kcc=21
11408
11409 ELSEIF(isub.GE.86.AND.isub.LE.89) THEN
11410C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11411 mint(21)=kfpr(isub,1)
11412 mint(22)=kfpr(isub,2)
11413 kcc=24
11414 kcs=(-1)**int(1.5d0+pyr(0))
11415 ENDIF
11416
11417 ELSEIF(isub.LE.100) THEN
11418 IF(isub.EQ.95) THEN
11419C...Low-pT ( = energyless g + g -> g + g)
11420 kcc=mint(2)+12
11421 kcs=(-1)**int(1.5d0+pyr(0))
11422
11423 ELSEIF(isub.EQ.96) THEN
11424C...Multiple interactions (should be reassigned to QCD process)
11425 ENDIF
11426
11427 ELSEIF(isub.LE.110) THEN
11428 IF(isub.EQ.101) THEN
11429C...g + g -> gamma*/Z0
11430 kcc=21
11431 kfres=22
11432
11433 ELSEIF(isub.EQ.102) THEN
11434C...g + g -> h0 (or H0, or A0)
11435 kcc=21
11436 kfres=kfhigg
11437
11438 ELSEIF(isub.EQ.103) THEN
11439C...gamma + gamma -> h0 (or H0, or A0)
11440 kcc=21
11441 kfres=kfhigg
11442
11443 ELSEIF(isub.EQ.104.OR.isub.EQ.105) THEN
11444C...g + g -> chi_0c or chi_2c.
11445 kcc=21
11446 kfres=kfpr(isub,1)
11447
11448 ELSEIF(isub.EQ.106) THEN
11449C...g + g -> J/Psi + gamma
11450 mint(21)=kfpr(isub,1)
11451 mint(22)=kfpr(isub,2)
11452 kcc=21
11453
11454 ELSEIF(isub.EQ.107) THEN
11455C...g + gamma -> J/Psi + g
11456 mint(21)=kfpr(isub,1)
11457 mint(22)=kfpr(isub,2)
11458 kcc=22
11459 IF(mint(16).EQ.22) kcc=33
11460
11461 ELSEIF(isub.EQ.108) THEN
11462C...gamma + gamma -> J/Psi + gamma
11463 mint(21)=kfpr(isub,1)
11464 mint(22)=kfpr(isub,2)
11465
11466 ELSEIF(isub.EQ.110) THEN
11467C...f + fbar -> gamma + h0; th arbitrary
11468 IF(pyr(0).GT.0.5d0) js=2
11469 mint(20+js)=22
11470 mint(23-js)=kfhigg
11471 ENDIF
11472
11473 ELSEIF(isub.LE.120) THEN
11474 IF(isub.EQ.111) THEN
11475C...f + fbar -> g + h0; th arbitrary
11476 IF(pyr(0).GT.0.5d0) js=2
11477 mint(20+js)=21
11478 mint(23-js)=kfhigg
11479 kcc=17+js
11480
11481 ELSEIF(isub.EQ.112) THEN
11482C...f + g -> f + h0; th = (p(f) - p(f))**2
11483 IF(mint(15).EQ.21) js=2
11484 mint(23-js)=kfhigg
11485 kcc=15+js
11486 kcs=isign(1,mint(14+js))
11487
11488 ELSEIF(isub.EQ.113) THEN
11489C...g + g -> g + h0; th arbitrary
11490 IF(pyr(0).GT.0.5d0) js=2
11491 mint(23-js)=kfhigg
11492 kcc=22+js
11493 kcs=(-1)**int(1.5d0+pyr(0))
11494
11495 ELSEIF(isub.EQ.114) THEN
11496C...g + g -> gamma + gamma; th arbitrary
11497 IF(pyr(0).GT.0.5d0) js=2
11498 mint(21)=22
11499 mint(22)=22
11500 kcc=21
11501
11502 ELSEIF(isub.EQ.115) THEN
11503C...g + g -> g + gamma; th arbitrary
11504 IF(pyr(0).GT.0.5d0) js=2
11505 mint(23-js)=22
11506 kcc=22+js
11507 kcs=(-1)**int(1.5d0+pyr(0))
11508
11509 ELSEIF(isub.EQ.116) THEN
11510C...g + g -> gamma + Z0
11511
11512 ELSEIF(isub.EQ.117) THEN
11513C...g + g -> Z0 + Z0
11514
11515 ELSEIF(isub.EQ.118) THEN
11516C...g + g -> W+ + W-
11517 ENDIF
11518
11519 ELSEIF(isub.LE.140) THEN
11520 IF(isub.EQ.121) THEN
11521C...g + g -> Q + Qbar + h0
11522 kcs=(-1)**int(1.5d0+pyr(0))
11523 mint(21)=isign(kfpr(isubsv,2),kcs)
11524 mint(22)=-mint(21)
11525 kcc=11+int(0.5d0+pyr(0))
11526 kfres=kfhigg
11527
11528 ELSEIF(isub.EQ.122) THEN
11529C...q + qbar -> Q + Qbar + h0
11530 mint(21)=isign(kfpr(isubsv,2),mint(15))
11531 mint(22)=-mint(21)
11532 kcc=4
11533 kfres=kfhigg
11534
11535 ELSEIF(isub.EQ.123) THEN
11536C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11537C...inner process)
11538 kcc=22
11539 kfres=kfhigg
11540
11541 ELSEIF(isub.EQ.124) THEN
11542C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11543C...inner process)
11544 DO 430 jt=1,2
11545 i=mint(14+jt)
11546 ia=iabs(i)
11547 IF(ia.LE.10) THEN
11548 rvckm=vint(180+i)*pyr(0)
11549 DO 420 j=1,mstp(1)
11550 ib=2*j-1+mod(ia,2)
11551 ipm=(5-isign(1,i))/2
11552 idc=j+mdcy(ia,2)+2
11553 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 420
11554 mint(20+jt)=isign(ib,i)
11555 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
11556 IF(rvckm.LE.0d0) GOTO 430
11557 420 CONTINUE
11558 ELSE
11559 ib=2*((ia+1)/2)-1+mod(ia,2)
11560 mint(20+jt)=isign(ib,i)
11561 ENDIF
11562 430 CONTINUE
11563 kcc=22
11564 kfres=kfhigg
11565
11566 ELSEIF(isub.EQ.131.OR.isub.EQ.132) THEN
11567C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11568 IF(mint(15).EQ.22) js=2
11569 mint(23-js)=21
11570 kcc=24+js
11571 kcs=isign(1,mint(14+js))
11572
11573 ELSEIF(isub.EQ.133.OR.isub.EQ.134) THEN
11574C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11575 IF(mint(15).EQ.22) js=2
11576 kcc=22
11577 kcs=isign(1,mint(14+js))
11578
11579 ELSEIF(isub.EQ.135.OR.isub.EQ.136) THEN
11580C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11581 kcs=(-1)**int(1.5d0+pyr(0))
11582 mint(21)=isign(kflf,kcs)
11583 mint(22)=-mint(21)
11584 kcc=27
11585 IF(mint(16).EQ.21) kcc=28
11586
11587 ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
11588C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11589 kcs=(-1)**int(1.5d0+pyr(0))
11590 mint(21)=isign(kflf,kcs)
11591 mint(22)=-mint(21)
11592 kcc=21
11593
11594 ENDIF
11595
11596 ELSEIF(isub.LE.160) THEN
11597 IF(isub.EQ.141) THEN
11598C...f + fbar -> gamma*/Z0/Z'0
11599 kfres=32
11600
11601 ELSEIF(isub.EQ.142) THEN
11602C...f + fbar' -> W'+/-
11603 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11604 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11605 kfres=isign(34,kch1+kch2)
11606
11607 ELSEIF(isub.EQ.143) THEN
11608C...f + fbar' -> H+/-
11609 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11610 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11611 kfres=isign(37,kch1+kch2)
11612
11613 ELSEIF(isub.EQ.144) THEN
11614C...f + fbar' -> R
11615 kfres=isign(41,mint(15)+mint(16))
11616
11617 ELSEIF(isub.EQ.145) THEN
11618C...q + l -> LQ (leptoquark)
11619 IF(iabs(mint(16)).LE.8) js=2
11620 kfres=isign(42,mint(14+js))
11621 kcc=28+js
11622 kcs=isign(1,mint(14+js))
11623
11624 ELSEIF(isub.EQ.146) THEN
11625C...e + gamma -> e* (excited lepton)
11626 IF(mint(15).EQ.22) js=2
11627 kfres=isign(kfpr(isub,1),mint(14+js))
11628 kcc=22
11629
11630 ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
11631C...q + g -> q* (excited quark)
11632 IF(mint(15).EQ.21) js=2
11633 kfres=isign(kfpr(isub,1),mint(14+js))
11634 kcc=30+js
11635 kcs=isign(1,mint(14+js))
11636
11637 ELSEIF(isub.EQ.149) THEN
11638C...g + g -> eta_tc
11639 kfres=ktechn+331
11640 kcc=23
11641 kcs=(-1)**int(1.5d0+pyr(0))
11642 ENDIF
11643
11644 ELSEIF(isub.LE.200) THEN
11645 IF(isub.EQ.161) THEN
11646C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11647 IF(mint(15).EQ.21) js=2
11648 i=mint(14+js)
11649 ia=iabs(i)
11650 mint(23-js)=isign(37,kchg(ia,1)*i)
11651 ib=ia+mod(ia,2)-mod(ia+1,2)
11652 mint(20+js)=isign(ib,i)
11653 kcc=15+js
11654 kcs=isign(1,mint(14+js))
11655
11656 ELSEIF(isub.EQ.162) THEN
11657C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11658 IF(mint(15).EQ.21) js=2
11659 mint(20+js)=isign(42,mint(14+js))
11660 kflql=kfdp(mdcy(42,2),2)
11661 mint(23-js)=-isign(kflql,mint(14+js))
11662 kcc=15+js
11663 kcs=isign(1,mint(14+js))
11664
11665 ELSEIF(isub.EQ.163) THEN
11666C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11667 kcs=(-1)**int(1.5d0+pyr(0))
11668 mint(21)=isign(42,kcs)
11669 mint(22)=-mint(21)
11670 kcc=mint(2)+10
11671
11672 ELSEIF(isub.EQ.164) THEN
11673C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11674 mint(21)=isign(42,mint(15))
11675 mint(22)=-mint(21)
11676 kcc=4
11677
11678 ELSEIF(isub.EQ.165) THEN
11679C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11680 mint(21)=isign(kfpr(isub,1),mint(15))
11681 mint(22)=-mint(21)
11682
11683 ELSEIF(isub.EQ.166) THEN
11684C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11685 IF(mod(mint(15),2).EQ.0) THEN
11686 mint(21)=isign(kfpr(isub,1)+1,mint(15))
11687 mint(22)=isign(kfpr(isub,1),mint(16))
11688 ELSE
11689 mint(21)=isign(kfpr(isub,1),mint(15))
11690 mint(22)=isign(kfpr(isub,1)+1,mint(16))
11691 ENDIF
11692
11693 ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
11694C...q + q' -> q" + q* (excited quark)
11695 kfqstr=kfpr(isub,2)
11696 kfqexc=mod(kfqstr,kexcit)
11697 js=mint(2)
11698 mint(20+js)=isign(kfqstr,mint(14+js))
11699 IF(iabs(mint(15)).NE.kfqexc.AND.iabs(mint(16)).NE.kfqexc)
11700 & mint(23-js)=isign(kfqexc,mint(17-js))
11701 kcc=22
11702 js=3-js
11703
11704 ELSEIF(isub.EQ.169) THEN
11705C...q + qbar -> e + e* (excited lepton)
11706 kfqstr=kfpr(isub,2)
11707 kfqexc=mod(kfqstr,kexcit)
11708 js=mint(2)
11709 mint(20+js)=isign(kfqstr,mint(14+js))
11710 mint(23-js)=isign(kfqexc,mint(17-js))
11711 js=3-js
11712
11713 ELSEIF(isub.EQ.191) THEN
11714C...f + fbar -> rho_tc0.
11715 kfres=ktechn+113
11716
11717 ELSEIF(isub.EQ.192) THEN
11718C...f + fbar' -> rho_tc+/-
11719 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11720 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11721 kfres=isign(ktechn+213,kch1+kch2)
11722
11723 ELSEIF(isub.EQ.193) THEN
11724C...f + fbar -> omega_tc0.
11725 kfres=ktechn+223
11726
11727 ELSEIF(isub.EQ.194) THEN
11728C...f + fbar -> f' + fbar' via mixture of s-channel
11729C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11730 mint(21)=isign(kfpr(isub,1),mint(15))
11731 mint(22)=-mint(21)
11732
11733 ELSEIF(isub.EQ.195) THEN
11734C...f + fbar' -> f'' + fbar''' via s-channel
11735C...rho_tc+ th=(p(f)-p(f'))**2
11736C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11737 IF(mod(mint(15),2).EQ.0) THEN
11738 mint(21)=isign(kfpr(isub,1)+1,mint(15))
11739 mint(22)=isign(kfpr(isub,1),mint(16))
11740 ELSE
11741 mint(21)=isign(kfpr(isub,1),mint(15))
11742 mint(22)=isign(kfpr(isub,1)+1,mint(16))
11743 ENDIF
11744 ENDIF
11745
11746CMRENNA++
11747 ELSEIF(isub.LE.215) THEN
11748 IF(isub.EQ.201) THEN
11749C...f + fbar -> ~e_L + ~e_Lbar
11750 mint(21)=isign(ksusy1+11,kcs)
11751 mint(22)=-mint(21)
11752
11753 ELSEIF(isub.EQ.202) THEN
11754C...f + fbar -> ~e_R + ~e_Rbar
11755 mint(21)=isign(ksusy2+11,kcs)
11756 mint(22)=-mint(21)
11757
11758 ELSEIF(isub.EQ.203) THEN
11759C...f + fbar -> ~e_L + ~e_Rbar
11760 IF(mint(15).LT.0) js=2
11761 IF(mint(2).EQ.1) THEN
11762 mint(20+js)=kfpr(isub,1)
11763 mint(23-js)=-kfpr(isub,2)
11764 ELSE
11765 mint(20+js)=-kfpr(isub,1)
11766 mint(23-js)=kfpr(isub,2)
11767 ENDIF
11768
11769 ELSEIF(isub.EQ.204) THEN
11770C...f + fbar -> ~mu_L + ~mu_Lbar
11771 mint(21)=isign(ksusy1+13,kcs)
11772 mint(22)=-mint(21)
11773
11774 ELSEIF(isub.EQ.205) THEN
11775C...f + fbar -> ~mu_R + ~mu_Rbar
11776 mint(21)=isign(ksusy2+13,kcs)
11777 mint(22)=-mint(21)
11778
11779 ELSEIF(isub.EQ.206) THEN
11780C...f + fbar -> ~mu_L + ~mu_Rbar
11781 IF(mint(15).LT.0) js=2
11782 IF(mint(2).EQ.1) THEN
11783 mint(20+js)=kfpr(isub,1)
11784 mint(23-js)=-kfpr(isub,2)
11785 ELSE
11786 mint(20+js)=-kfpr(isub,1)
11787 mint(23-js)=kfpr(isub,2)
11788 ENDIF
11789
11790 ELSEIF(isub.EQ.207) THEN
11791C...f + fbar -> ~tau_1 + ~tau_1bar
11792 mint(21)=isign(ksusy1+15,kcs)
11793 mint(22)=-mint(21)
11794
11795 ELSEIF(isub.EQ.208) THEN
11796C...f + fbar -> ~tau_2 + ~tau_2bar
11797 mint(21)=isign(ksusy2+15,kcs)
11798 mint(22)=-mint(21)
11799
11800 ELSEIF(isub.EQ.209) THEN
11801C...f + fbar -> ~tau_1 + ~tau_2bar
11802 IF(mint(15).LT.0) js=2
11803 IF(mint(2).EQ.1) THEN
11804 mint(20+js)=kfpr(isub,1)
11805 mint(23-js)=-kfpr(isub,2)
11806 ELSE
11807 mint(20+js)=-kfpr(isub,1)
11808 mint(23-js)=kfpr(isub,2)
11809 ENDIF
11810
11811 ELSEIF(isub.EQ.210) THEN
11812C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11813 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11814 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11815 mint(21)=-isign(kfpr(isub,1),kch1+kch2)
11816 mint(22)=isign(kfpr(isub,2),kch1+kch2)
11817
11818 ELSEIF(isub.EQ.211) THEN
11819C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11820 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11821 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11822 mint(21)=-isign(ksusy1+15,kch1+kch2)
11823 mint(22)=isign(ksusy1+16,kch1+kch2)
11824
11825 ELSEIF(isub.EQ.212) THEN
11826C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11827 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11828 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11829 mint(21)=-isign(ksusy2+15,kch1+kch2)
11830 mint(22)=isign(ksusy1+16,kch1+kch2)
11831
11832 ELSEIF(isub.EQ.213) THEN
11833C...f + fbar -> ~nul + ~nulbar
11834 mint(21)=isign(kfpr(isub,1),kcs)
11835 mint(22)=-mint(21)
11836
11837 ELSEIF(isub.EQ.214) THEN
11838C...f + fbar -> ~nutau + ~nutaubar
11839 mint(21)=isign(ksusy1+16,kcs)
11840 mint(22)=-mint(21)
11841 ENDIF
11842
11843 ELSEIF(isub.LE.225) THEN
11844 IF(isub.EQ.216) THEN
11845C...f + fbar -> ~chi01 + ~chi01
11846 mint(21)=ksusy1+22
11847 mint(22)=ksusy1+22
11848
11849 ELSEIF(isub.EQ.217) THEN
11850C...f + fbar -> ~chi02 + ~chi02
11851 mint(21)=ksusy1+23
11852 mint(22)=ksusy1+23
11853
11854 ELSEIF(isub.EQ.218 ) THEN
11855C...f + fbar -> ~chi03 + ~chi03
11856 mint(21)=ksusy1+25
11857 mint(22)=ksusy1+25
11858
11859 ELSEIF(isub.EQ.219 ) THEN
11860C...f + fbar -> ~chi04 + ~chi04
11861 mint(21)=ksusy1+35
11862 mint(22)=ksusy1+35
11863
11864 ELSEIF(isub.EQ.220 ) THEN
11865C...f + fbar -> ~chi01 + ~chi02
11866 IF(mint(15).LT.0) js=2
11867C IF(PYR(0).GT.0.5D0) JS=2
11868 mint(20+js)=ksusy1+22
11869 mint(23-js)=ksusy1+23
11870
11871 ELSEIF(isub.EQ.221 ) THEN
11872C...f + fbar -> ~chi01 + ~chi03
11873 IF(mint(15).LT.0) js=2
11874C IF(PYR(0).GT.0.5D0) JS=2
11875 mint(20+js)=ksusy1+22
11876 mint(23-js)=ksusy1+25
11877
11878 ELSEIF(isub.EQ.222) THEN
11879C...f + fbar -> ~chi01 + ~chi04
11880 IF(mint(15).LT.0) js=2
11881C IF(PYR(0).GT.0.5D0) JS=2
11882 mint(20+js)=ksusy1+22
11883 mint(23-js)=ksusy1+35
11884
11885 ELSEIF(isub.EQ.223) THEN
11886C...f + fbar -> ~chi02 + ~chi03
11887 IF(mint(15).LT.0) js=2
11888C IF(PYR(0).GT.0.5D0) JS=2
11889 mint(20+js)=ksusy1+23
11890 mint(23-js)=ksusy1+25
11891
11892 ELSEIF(isub.EQ.224) THEN
11893C...f + fbar -> ~chi02 + ~chi04
11894 IF(mint(15).LT.0) js=2
11895C IF(PYR(0).GT.0.5D0) JS=2
11896 mint(20+js)=ksusy1+23
11897 mint(23-js)=ksusy1+35
11898
11899 ELSEIF(isub.EQ.225) THEN
11900C...f + fbar -> ~chi03 + ~chi04
11901 IF(mint(15).LT.0) js=2
11902C IF(PYR(0).GT.0.5D0) JS=2
11903 mint(20+js)=ksusy1+25
11904 mint(23-js)=ksusy1+35
11905 ENDIF
11906
11907 ELSEIF(isub.LE.236) THEN
11908 IF(isub.EQ.226) THEN
11909C...f + fbar -> ~chi+-1 + ~chi-+1
11910C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11911 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11912 mint(21)=isign(ksusy1+24,kch1)
11913 mint(22)=-mint(21)
11914
11915 ELSEIF(isub.EQ.227) THEN
11916C...f + fbar -> ~chi+-2 + ~chi-+2
11917 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11918 mint(21)=isign(ksusy1+37,kch1)
11919 mint(22)=-mint(21)
11920
11921 ELSEIF(isub.EQ.228) THEN
11922C...f + fbar -> ~chi+-1 + ~chi-+2
11923C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11924C...js=1 if pyr<.5, js=2 if pyr>.5
11925C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11926C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11927C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11928C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11929 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11930 kch2=int(1-kch1)/2
11931 IF(mint(2).EQ.1) THEN
11932 mint(21)= isign(ksusy1+24,kch1)
11933 mint(22)= -isign(ksusy1+37,kch1)
11934c IF(KCH2.EQ.0) JS=2
11935 ELSE
11936 mint(21)= isign(ksusy1+37,kch1)
11937 mint(22)= -isign(ksusy1+24,kch1)
11938 js=2
11939c IF(KCH2.EQ.1) JS=2
11940 ENDIF
11941
11942 ELSEIF(isub.EQ.229) THEN
11943C...q + qbar' -> ~chi01 + ~chi+-1
11944C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11945 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11946 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11947C...CHECK THIS
11948 IF(mod(mint(15),2).EQ.0) js=2
11949 mint(20+js)=ksusy1+22
11950 mint(23-js)=isign(ksusy1+24,kch1+kch2)
11951
11952 ELSEIF(isub.EQ.230) THEN
11953C...q + qbar' -> ~chi02 + ~chi+-1
11954 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11955 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11956 IF(mod(mint(15),2).EQ.0) js=2
11957 mint(20+js)=ksusy1+23
11958 mint(23-js)=isign(ksusy1+24,kch1+kch2)
11959
11960 ELSEIF(isub.EQ.231) THEN
11961C...q + qbar' -> ~chi03 + ~chi+-1
11962 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11963 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11964 IF(mod(mint(15),2).EQ.0) js=2
11965 mint(20+js)=ksusy1+25
11966 mint(23-js)=isign(ksusy1+24,kch1+kch2)
11967
11968 ELSEIF(isub.EQ.232) THEN
11969C...q + qbar' -> ~chi04 + ~chi+-1
11970 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11971 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11972 IF(mod(mint(15),2).EQ.0) js=2
11973 mint(20+js)=ksusy1+35
11974 mint(23-js)=isign(ksusy1+24,kch1+kch2)
11975
11976 ELSEIF(isub.EQ.233) THEN
11977C...q + qbar' -> ~chi01 + ~chi+-2
11978 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11979 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11980 IF(mod(mint(15),2).EQ.0) js=2
11981 mint(20+js)=ksusy1+22
11982 mint(23-js)=isign(ksusy1+37,kch1+kch2)
11983
11984 ELSEIF(isub.EQ.234) THEN
11985C...q + qbar' -> ~chi02 + ~chi+-2
11986 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11987 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11988 IF(mod(mint(15),2).EQ.0) js=2
11989 mint(20+js)=ksusy1+23
11990 mint(23-js)=isign(ksusy1+37,kch1+kch2)
11991
11992 ELSEIF(isub.EQ.235) THEN
11993C...q + qbar' -> ~chi03 + ~chi+-2
11994 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
11995 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
11996 IF(mod(mint(15),2).EQ.0) js=2
11997 mint(20+js)=ksusy1+25
11998 mint(23-js)=isign(ksusy1+37,kch1+kch2)
11999
12000 ELSEIF(isub.EQ.236) THEN
12001C...q + qbar' -> ~chi04 + ~chi+-2
12002 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12003 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12004 IF(mod(mint(15),2).EQ.0) js=2
12005 mint(20+js)=ksusy1+35
12006 mint(23-js)=isign(ksusy1+37,kch1+kch2)
12007 ENDIF
12008
12009 ELSEIF(isub.LE.245) THEN
12010 IF(isub.EQ.237) THEN
12011C...q + qbar -> ~chi01 + ~g
12012C...th arbitrary
12013 IF(pyr(0).GT.0.5d0) js=2
12014 mint(20+js)=ksusy1+21
12015 mint(23-js)=ksusy1+22
12016 kcc=17+js
12017
12018 ELSEIF(isub.EQ.238) THEN
12019C...q + qbar -> ~chi02 + ~g
12020C...th arbitrary
12021 IF(pyr(0).GT.0.5d0) js=2
12022 mint(20+js)=ksusy1+21
12023 mint(23-js)=ksusy1+23
12024 kcc=17+js
12025
12026 ELSEIF(isub.EQ.239) THEN
12027C...q + qbar -> ~chi03 + ~g
12028C...th arbitrary
12029 IF(pyr(0).GT.0.5d0) js=2
12030 mint(20+js)=ksusy1+21
12031 mint(23-js)=ksusy1+25
12032 kcc=17+js
12033
12034 ELSEIF(isub.EQ.240) THEN
12035C...q + qbar -> ~chi04 + ~g
12036C...th arbitrary
12037 IF(pyr(0).GT.0.5d0) js=2
12038 mint(20+js)=ksusy1+21
12039 mint(23-js)=ksusy1+35
12040 kcc=17+js
12041
12042 ELSEIF(isub.EQ.241) THEN
12043C...q + qbar' -> ~chi+-1 + ~g
12044C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12045C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12046C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12047C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12048C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12049 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12050 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12051 js=1
12052 IF(mint(15)*(kch1+kch2).GT.0) js=2
12053 mint(20+js)=ksusy1+21
12054 mint(23-js)=isign(ksusy1+24,kch1+kch2)
12055 kcc=17+js
12056
12057 ELSEIF(isub.EQ.242) THEN
12058C...q + qbar' -> ~chi+-2 + ~g
12059C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12060C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12061C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12062C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12063C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12064 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12065 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12066 js=1
12067 IF(mint(15)*(kch1+kch2).GT.0) js=2
12068 mint(20+js)=ksusy1+21
12069 mint(23-js)=isign(ksusy1+37,kch1+kch2)
12070 kcc=17+js
12071
12072 ELSEIF(isub.EQ.243) THEN
12073C...q + qbar -> ~g + ~g ; th arbitrary
12074 mint(21)=ksusy1+21
12075 mint(22)=ksusy1+21
12076 kcc=mint(2)+4
12077
12078 ELSEIF(isub.EQ.244) THEN
12079C...g + g -> ~g + ~g ; th arbitrary
12080 kcc=mint(2)+12
12081 kcs=(-1)**int(1.5d0+pyr(0))
12082 mint(21)=ksusy1+21
12083 mint(22)=ksusy1+21
12084 ENDIF
12085
12086 ELSEIF(isub.LE.260) THEN
12087 IF(isub.EQ.246) THEN
12088C...qj + g -> ~qj_L + ~chi01
12089 IF(mint(15).EQ.21) js=2
12090 i=mint(14+js)
12091 ia=iabs(i)
12092 mint(20+js)=isign(ksusy1+ia,i)
12093 mint(23-js)=ksusy1+22
12094 kcc=15+js
12095 kcs=isign(1,mint(14+js))
12096
12097 ELSEIF(isub.EQ.247) THEN
12098C...qj + g -> ~qj_R + ~chi01
12099 IF(mint(15).EQ.21) js=2
12100 i=mint(14+js)
12101 ia=iabs(i)
12102 mint(20+js)=isign(ksusy2+ia,i)
12103 mint(23-js)=ksusy1+22
12104 kcc=15+js
12105 kcs=isign(1,mint(14+js))
12106
12107 ELSEIF(isub.EQ.248) THEN
12108C...qj + g -> ~qj_L + ~chi02
12109 IF(mint(15).EQ.21) js=2
12110 i=mint(14+js)
12111 ia=iabs(i)
12112 mint(20+js)=isign(ksusy1+ia,i)
12113 mint(23-js)=ksusy1+23
12114 kcc=15+js
12115 kcs=isign(1,mint(14+js))
12116
12117 ELSEIF(isub.EQ.249) THEN
12118C...qj + g -> ~qj_R + ~chi02
12119 IF(mint(15).EQ.21) js=2
12120 i=mint(14+js)
12121 ia=iabs(i)
12122 mint(20+js)=isign(ksusy2+ia,i)
12123 mint(23-js)=ksusy1+23
12124 kcc=15+js
12125 kcs=isign(1,mint(14+js))
12126
12127 ELSEIF(isub.EQ.250) THEN
12128C...qj + g -> ~qj_L + ~chi03
12129 IF(mint(15).EQ.21) js=2
12130 i=mint(14+js)
12131 ia=iabs(i)
12132 mint(20+js)=isign(ksusy1+ia,i)
12133 mint(23-js)=ksusy1+25
12134 kcc=15+js
12135 kcs=isign(1,mint(14+js))
12136
12137 ELSEIF(isub.EQ.251) THEN
12138C...qj + g -> ~qj_R + ~chi03
12139 IF(mint(15).EQ.21) js=2
12140 i=mint(14+js)
12141 ia=iabs(i)
12142 mint(20+js)=isign(ksusy2+ia,i)
12143 mint(23-js)=ksusy1+25
12144 kcc=15+js
12145 kcs=isign(1,mint(14+js))
12146
12147 ELSEIF(isub.EQ.252) THEN
12148C...qj + g -> ~qj_L + ~chi04
12149 IF(mint(15).EQ.21) js=2
12150 i=mint(14+js)
12151 ia=iabs(i)
12152 mint(20+js)=isign(ksusy1+ia,i)
12153 mint(23-js)=ksusy1+35
12154 kcc=15+js
12155 kcs=isign(1,mint(14+js))
12156
12157 ELSEIF(isub.EQ.253) THEN
12158C...qj + g -> ~qj_R + ~chi04
12159 IF(mint(15).EQ.21) js=2
12160 i=mint(14+js)
12161 ia=iabs(i)
12162 mint(20+js)=isign(ksusy2+ia,i)
12163 mint(23-js)=ksusy1+35
12164 kcc=15+js
12165 kcs=isign(1,mint(14+js))
12166
12167 ELSEIF(isub.EQ.254) THEN
12168C...qj + g -> ~qk_L + ~chi+-1
12169 IF(mint(15).EQ.21) js=2
12170 i=mint(14+js)
12171 ia=iabs(i)
12172 mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
12173 ib=-ia+int((ia+1)/2)*4-1
12174 mint(20+js)=isign(ksusy1+ib,i)
12175 kcc=15+js
12176 kcs=isign(1,mint(14+js))
12177
12178 ELSEIF(isub.EQ.255) THEN
12179C...qj + g -> ~qk_L + ~chi+-1
12180 IF(mint(15).EQ.21) js=2
12181 i=mint(14+js)
12182 ia=iabs(i)
12183 mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)
12184 ib=-ia+int((ia+1)/2)*4-1
12185 mint(20+js)=isign(ksusy2+ib,i)
12186 kcc=15+js
12187 kcs=isign(1,mint(14+js))
12188
12189 ELSEIF(isub.EQ.256) THEN
12190C...qj + g -> ~qk_L + ~chi+-2
12191 IF(mint(15).EQ.21) js=2
12192 i=mint(14+js)
12193 ia=iabs(i)
12194 ib=-ia+int((ia+1)/2)*4-1
12195 mint(20+js)=isign(ksusy1+ib,i)
12196 mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
12197 kcc=15+js
12198 kcs=isign(1,mint(14+js))
12199
12200 ELSEIF(isub.EQ.257) THEN
12201C...qj + g -> ~qk_R + ~chi+-2
12202 IF(mint(15).EQ.21) js=2
12203 i=mint(14+js)
12204 ia=iabs(i)
12205 ib=-ia+int((ia+1)/2)*4-1
12206 mint(20+js)=isign(ksusy2+ib,i)
12207 mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)
12208 kcc=15+js
12209 kcs=isign(1,mint(14+js))
12210
12211 ELSEIF(isub.EQ.258) THEN
12212C...qj + g -> ~qj_L + ~g
12213 IF(mint(15).EQ.21) js=2
12214 i=mint(14+js)
12215 ia=iabs(i)
12216 mint(20+js)=isign(ksusy1+ia,i)
12217 mint(23-js)=ksusy1+21
12218 kcc=mint(2)+6
12219 IF(js.EQ.2) kcc=kcc+2
12220 kcs=isign(1,i)
12221
12222 ELSEIF(isub.EQ.259) THEN
12223C...qj + g -> ~qj_R + ~g
12224 IF(mint(15).EQ.21) js=2
12225 i=mint(14+js)
12226 ia=iabs(i)
12227 mint(20+js)=isign(ksusy2+ia,i)
12228 mint(23-js)=ksusy1+21
12229 kcc=mint(2)+6
12230 IF(js.EQ.2) kcc=kcc+2
12231 kcs=isign(1,i)
12232 ENDIF
12233
12234 ELSEIF(isub.LE.270) THEN
12235 IF(isub.EQ.261) THEN
12236C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12237 isgn=1
12238 IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12239 mint(21)=isgn*isign(kfpr(isub,1),kcs)
12240 mint(22)=-mint(21)
12241C...Correct color combination
12242 IF(mint(43).EQ.4) kcc=4
12243
12244 ELSEIF(isub.EQ.262) THEN
12245C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12246 isgn=1
12247 IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12248 mint(21)=isgn*isign(kfpr(isub,1),kcs)
12249 mint(22)=-mint(21)
12250C...Correct color combination
12251 IF(mint(43).EQ.4) kcc=4
12252
12253 ELSEIF(isub.EQ.263) THEN
12254C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12255 IF((kcs.GT.0.AND.mint(2).EQ.1).OR.
12256 & (kcs.LT.0.AND.mint(2).EQ.2)) THEN
12257 mint(21)=isign(kfpr(isub,1),kcs)
12258 mint(22)=-isign(kfpr(isub,2),kcs)
12259 ELSE
12260 js=2
12261 mint(21)=isign(kfpr(isub,2),kcs)
12262 mint(22)=-isign(kfpr(isub,1),kcs)
12263 ENDIF
12264C...Correct color combination
12265 IF(mint(43).EQ.4) kcc=4
12266
12267 ELSEIF(isub.EQ.264) THEN
12268C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12269 kcs=(-1)**int(1.5d0+pyr(0))
12270 mint(21)=isign(kfpr(isub,1),kcs)
12271 mint(22)=-mint(21)
12272 kcc=mint(2)+10
12273
12274 ELSEIF(isub.EQ.265) THEN
12275C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12276 kcs=(-1)**int(1.5d0+pyr(0))
12277 mint(21)=isign(kfpr(isub,1),kcs)
12278 mint(22)=-mint(21)
12279 kcc=mint(2)+10
12280 ENDIF
12281
12282 ELSEIF(isub.LE.296) THEN
12283 IF(isub.EQ.271.OR.isub.EQ.281.OR.isub.EQ.291) THEN
12284C...qi + qj -> ~qi_L + ~qj_L
12285 kcc=mint(2)
12286 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12287 mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
12288 mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
12289
12290 ELSEIF(isub.EQ.272.OR.isub.EQ.282.OR.isub.EQ.292) THEN
12291C...qi + qj -> ~qi_R + ~qj_R
12292 kcc=mint(2)
12293 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12294 mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
12295 mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
12296
12297 ELSEIF(isub.EQ.273.OR.isub.EQ.283.OR.isub.EQ.293) THEN
12298C...qi + qj -> ~qi_L + ~qj_R
12299 mint(21)=isign(kfpr(isub,1),mint(15))
12300 mint(22)=isign(kfpr(isub,2),mint(16))
12301 kcc=mint(2)
12302 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12303
12304 ELSEIF(isub.EQ.274.OR.isub.EQ.284) THEN
12305C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12306 mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))
12307 mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))
12308 kcc=mint(2)
12309 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12310
12311 ELSEIF(isub.EQ.275.OR.isub.EQ.285) THEN
12312C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12313 mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))
12314 mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))
12315 kcc=mint(2)
12316 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12317
12318 ELSEIF(isub.EQ.276.OR.isub.EQ.286.OR.isub.EQ.296) THEN
12319C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12320 mint(21)=isign(kfpr(isub,1),mint(15))
12321 mint(22)=isign(kfpr(isub,2),mint(16))
12322 kcc=mint(2)
12323 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12324
12325 ELSEIF(isub.EQ.277.OR.isub.EQ.287) THEN
12326C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12327 isgn=1
12328 IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12329 mint(21)=isgn*isign(kfpr(isub,1),kcs)
12330 mint(22)=-mint(21)
12331 IF(mint(43).EQ.4) kcc=4
12332
12333 ELSEIF(isub.EQ.278.OR.isub.EQ.288) THEN
12334C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12335 isgn=1
12336 IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1
12337 mint(21)=isgn*isign(kfpr(isub,1),kcs)
12338 mint(22)=-mint(21)
12339 IF(mint(43).EQ.4) kcc=4
12340
12341 ELSEIF(isub.EQ.279.OR.isub.EQ.289) THEN
12342C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12343C...pure LL + RR
12344 kcs=(-1)**int(1.5d0+pyr(0))
12345 mint(21)=isign(kfpr(isub,1),kcs)
12346 mint(22)=-mint(21)
12347 kcc=mint(2)+10
12348
12349 ELSEIF(isub.EQ.280.OR.isub.EQ.290) THEN
12350C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12351 kcs=(-1)**int(1.5d0+pyr(0))
12352 mint(21)=isign(kfpr(isub,1),kcs)
12353 mint(22)=-mint(21)
12354 kcc=mint(2)+10
12355
12356 ELSEIF(isub.EQ.294) THEN
12357C...qj + g -> ~qj_L + ~g
12358 IF(mint(15).EQ.21) js=2
12359 i=mint(14+js)
12360 ia=iabs(i)
12361 mint(20+js)=isign(ksusy1+ia,i)
12362 mint(23-js)=ksusy1+21
12363 kcc=mint(2)+6
12364 IF(js.EQ.2) kcc=kcc+2
12365 kcs=isign(1,i)
12366
12367 ELSEIF(isub.EQ.295) THEN
12368C...qj + g -> ~qj_R + ~g
12369 IF(mint(15).EQ.21) js=2
12370 i=mint(14+js)
12371 ia=iabs(i)
12372 mint(20+js)=isign(ksusy2+ia,i)
12373 mint(23-js)=ksusy1+21
12374 kcc=mint(2)+6
12375 IF(js.EQ.2) kcc=kcc+2
12376 kcs=isign(1,i)
12377 ENDIF
12378
12379 ELSEIF(isub.LE.330) THEN
12380 IF(isub.EQ.311)THEN
12381C...g + g -> g* + g* (UED)
12382 kcc=mint(2)+12
12383 kcs=(-1)**int(1.5d0+pyr(0))
12384 mued(1)=472
12385 mued(2)=472
12386 mint(21)=iuedeq(472)
12387 mint(22)=iuedeq(472)
12388 ELSEIF(isub.EQ.312)THEN
12389C...q + g -> q*_D + g*, q*_S + g*
12390C...The two channels have the same cross section
12391 kkflmi=450
12392 IF(pyr(0).GT.0.5)kkflmi=456
12393 IF(mint(15).EQ.21) js=2
12394 kcc=mint(2)+6
12395 IF(mint(15).EQ.21)kcc=kcc+2
12396 IF(mint(15).NE.21)THEN
12397 kcs=isign(1,mint(15))
12398 mued(2)=472
12399 mued(1)=kcs*(kkflmi+iabs(mint(15)))
12400 mint(22)=iuedeq(472)
12401 mint(21)=kcs*iuedeq(kkflmi+iabs(mint(15)))
12402 ENDIF
12403 IF(mint(16).NE.21)THEN
12404 kcs=isign(1,mint(16))
12405 mued(2)=kcs*(kkflmi+iabs(mint(16)))
12406 mued(1)=472
12407 mint(22)=kcs*iuedeq(kkflmi+iabs(mint(16)))
12408 mint(21)=iuedeq(472)
12409 ENDIF
12410 ELSEIF(isub.EQ.313)THEN
12411C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12412C...The two channels have the same cross section
12413 kkflmi=450
12414 IF(pyr(0).GT.0.5)kkflmi=456
12415 kcc=mint(2)
12416 IF(mint(15).EQ.mint(16))THEN
12417 mued(1)=sign(1,mint(15))*(kkflmi+iabs(mint(15)))
12418 mued(2)=mint(21)
12419 mint(21)=sign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12420 mint(22)=mint(21)
12421 ELSE
12422 mued(1)=sign(1,mint(15))*(kkflmi+iabs(mint(15)))
12423 mued(2)=sign(1,mint(16))*(kkflmi+iabs(mint(16)))
12424 mint(21)=sign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12425 mint(22)=sign(1,mint(16))*iuedeq(kkflmi+iabs(mint(16)))
12426 ENDIF
12427 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12428 ELSEIF(isub.EQ.314)THEN
12429C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12430C...The two channels have the same cross section
12431 kkflmi=450
12432 IF(pyr(0).GT.0.5)kkflmi=456
12433 kcs=(-1)**int(1.5d0+pyr(0))
12434 xflaout=pyr(0)
12435 IF(xflaout.LE.0.2)THEN
12436 mued(1)=isign(1,kcs)*(kkflmi+1)
12437 mint(21)=isign(1,kcs)*iuedeq(kkflmi+1)
12438 ELSEIF(xflaout.LE.0.4)THEN
12439 mued(1)=isign(1,kcs)*(kkflmi+2)
12440 mint(21)=isign(1,kcs)*iuedeq(kkflmi+2)
12441 ELSEIF(xflaout.LE.0.6)THEN
12442 mued(1)=isign(1,kcs)*(kkflmi+3)
12443 mint(21)=isign(1,kcs)*iuedeq(kkflmi+3)
12444 ELSEIF(xflaout.LE.0.8)THEN
12445 mued(1)=isign(1,kcs)*(kkflmi+4)
12446 mint(21)=isign(1,kcs)*iuedeq(kkflmi+4)
12447 ELSE
12448 mued(1)=isign(1,kcs)*(kkflmi+5)
12449 mint(21)=isign(1,kcs)*iuedeq(kkflmi+5)
12450 ENDIF
12451 mint(22)=-mint(21)
12452 mued(2)=-mued(1)
12453 kcc=mint(2)+10
12454 ELSEIF(isub.EQ.315)THEN
12455C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12456C...The two channels have the same cross section
12457 kkflmi=450
12458 IF(pyr(0).GT.0.5)kkflmi=456
12459 mued(1)=isign(1,mint(15))*(kkflmi+iabs(mint(15)))
12460 mued(2)=-mint(21)
12461 mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12462 mint(22)=-mint(21)
12463 kcc=4
12464 ELSEIF(isub.EQ.316)THEN
12465C...q + qbar' -> q*_D + q*_S_bar'
12466 mued(1)=isign(1,mint(15))*(456+iabs(mint(15)))
12467 mued(2)=isign(1,mint(16))*(450+iabs(mint(16)))
12468 mint(21)=isign(1,mint(15))*iuedeq(456+iabs(mint(15)))
12469 mint(22)=isign(1,mint(16))*iuedeq(450+iabs(mint(16)))
12470 kcc=mint(2)+2
12471 ELSEIF(isub.EQ.317)THEN
12472C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12473C...The two channels have the same cross section
12474 kkflmi=450
12475 IF(pyr(0).GT.0.5)kkflmi=456
12476 mued(1)=isign(1,mint(15))*(kkflmi+iabs(mint(15)))
12477 mued(2)=isign(1,mint(16))*(kkflmi+iabs(mint(16)))
12478 mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iabs(mint(15)))
12479 mint(22)=isign(1,mint(16))*iuedeq(kkflmi+iabs(mint(16)))
12480 kcc=mint(2)+2
12481 ELSEIF(isub.EQ.318)THEN
12482C...q + q' -> q*_D + q*_S'
12483 kcc=mint(2)
12484 mued(1)=sign(1,mint(15))*(456+iabs(mint(15)))
12485 mued(2)=sign(1,mint(16))*(450+iabs(mint(16)))
12486 mint(21)=sign(1,mint(15))*iuedeq(456+iabs(mint(15)))
12487 mint(22)=sign(1,mint(16))*iuedeq(450+iabs(mint(16)))
12488 ELSEIF(isub.EQ.319)THEN
12489C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12490C...The two channels have the same cross section
12491 kkflmi=450
12492 IF(pyr(0).GT.0.5)kkflmi=456
12493 xflaout=pyr(0)
12494 iiflav=0
12495C...N.B. NFLAVOURS=IUED(3)
12496C DO I=1,NFLAVOURS
12497 DO 433 i=1,iued(3)
12498 IF(i.NE.iabs(mint(15)))THEN
12499 iiflav=iiflav+1
12500 iokfla(iiflav)=i
12501 ENDIF
12502 433 CONTINUE
12503 flastep=1./(iued(3)-1)
12504 DO i=1,iued(3)-1
12505 flavv=flastep*i
12506 IF(xflaout.LE.flavv)THEN
12507 mued(1)=isign(1,mint(15))*(kkflmi+iokfla(i))
12508 mint(21)=isign(1,mint(15))*iuedeq(kkflmi+iokfla(i))
12509 GOTO 435
12510 ENDIF
12511 ENDDO
12512 435 CONTINUE
12513 IF(iabs(mued(1)).LT.451.AND.iabs(mued(1)).GT.462)THEN
12514 WRITE(mstu(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12515 CALL pystop(5000000)
12516 ENDIF
12517 mint(22)=-mint(21)
12518 kcc=4
12519 ENDIF
12520
12521 ELSEIF(isub.LE.340) THEN
12522
12523 IF(isub.EQ.297.OR.isub.EQ.298) THEN
12524C...q + qbar' -> H+ + H0
12525 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12526 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12527 IF(mint(15)*(kch1+kch2).GT.0) js=2
12528 mint(20+js)=isign(37,kch1+kch2)
12529 mint(23-js)=kfpr(isub,2)
12530 ELSEIF(isub.EQ.299.OR.isub.EQ.300) THEN
12531C...f + fbar -> A0 + H0; th arbitrary
12532 IF(pyr(0).GT.0.5d0) js=2
12533 mint(20+js)=kfpr(isub,1)
12534 mint(23-js)=kfpr(isub,2)
12535 ELSEIF(isub.EQ.301) THEN
12536C...f + fbar -> H+ H-
12537 mint(21)=isign(kfpr(isub,1),kcs)
12538 mint(22)=-mint(21)
12539 ENDIF
12540CMRENNA--
12541
12542 ELSEIF(isub.LE.360) THEN
12543
12544 IF(isub.EQ.341.OR.isub.EQ.342) THEN
12545C...l + l -> H_L++/--, H_R++/--
12546 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12547 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12548 kfres=isign(kfpr(isub,1),kch1+kch2)
12549
12550 ELSEIF(isub.GE.343.AND.isub.LE.348) THEN
12551C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12552 IF(mint(15).EQ.22) js=2
12553 mint(20+js)=isign(kfpr(isub,1),-mint(14+js))
12554 mint(23-js)=isign(kfpr(isub,2),-mint(14+js))
12555 kcc=22
12556
12557 ELSEIF(isub.EQ.349.OR.isub.EQ.350) THEN
12558C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12559 mint(21)=-isign(kfpr(isub,1),mint(15))
12560 mint(22)=-mint(21)
12561
12562 ELSEIF(isub.EQ.351.OR.isub.EQ.352) THEN
12563C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12564C...as inner process).
12565 DO 450 jt=1,2
12566 i=mint(14+jt)
12567 ia=iabs(i)
12568 IF(ia.LE.10) THEN
12569 rvckm=vint(180+i)*pyr(0)
12570 DO 440 j=1,mstp(1)
12571 ib=2*j-1+mod(ia,2)
12572 ipm=(5-isign(1,i))/2
12573 idc=j+mdcy(ia,2)+2
12574 IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) GOTO 440
12575 mint(20+jt)=isign(ib,i)
12576 rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)
12577 IF(rvckm.LE.0d0) GOTO 450
12578 440 CONTINUE
12579 ELSE
12580 ib=2*((ia+1)/2)-1+mod(ia,2)
12581 mint(20+jt)=isign(ib,i)
12582 ENDIF
12583 450 CONTINUE
12584 kcc=22
12585 kfres=isign(kfpr(isub,1),mint(15))
12586 IF(mod(mint(15),2).EQ.1) kfres=-kfres
12587
12588 ELSEIF(isub.EQ.353) THEN
12589C...f + fbar -> Z_R0
12590 kfres=kfpr(isub,1)
12591
12592 ELSEIF(isub.EQ.354) THEN
12593C...f + fbar' -> W+/-
12594 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12595 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12596 kfres=isign(kfpr(isub,1),kch1+kch2)
12597
12598 ENDIF
12599
12600 ELSEIF(isub.LE.380) THEN
12601
12602 IF(isub.LE.363.OR.isub.EQ.368) THEN
12603C...f + fbar -> charged+ charged- technicolor
12604 ksw=(-1)**int(1.5d0+pyr(0))
12605 mint(21)=isign(kfpr(isub,1),ksw)
12606 mint(22)=-isign(kfpr(isub,2),ksw)
12607
12608 ELSEIF(isub.LE.367.OR.isub.EQ.379.OR.isub.EQ.380) THEN
12609C...f + fbar -> neutral neutral technicolor
12610 mint(21)=kfpr(isub,1)
12611 mint(22)=kfpr(isub,2)
12612
12613 ELSEIF(isub.EQ.374.OR.isub.EQ.375.OR.isub.EQ.378) THEN
12614C...f + fbar' -> neutral charged technicolor
12615 in=1
12616 ic=2
12617 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12618 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12619 IF(mint(15)*(kch1+kch2).LT.0) js=2
12620 mint(23-js)=isign(kfpr(isub,ic),kch1+kch2)
12621 mint(20+js)=kfpr(isub,in)
12622
12623 ELSEIF(isub.GE.370.AND.isub.LE.377) THEN
12624C...f + fbar' -> charged neutral technicolor
12625 in=2
12626 ic=1
12627 kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))
12628 kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))
12629 IF(mint(15)*(kch1+kch2).GT.0) js=2
12630 mint(20+js)=isign(kfpr(isub,ic),kch1+kch2)
12631 mint(23-js)=kfpr(isub,in)
12632 ENDIF
12633
12634 ELSEIF(isub.LE.400) THEN
12635 IF(isub.EQ.381) THEN
12636C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12637 kcc=mint(2)
12638 IF(mint(15)*mint(16).LT.0) kcc=kcc+2
12639
12640 ELSEIF(isub.EQ.382) THEN
12641C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12642 mint(21)=isign(kflf,mint(15))
12643 mint(22)=-mint(21)
12644 kcc=4
12645
12646 ELSEIF(isub.EQ.383) THEN
12647C...f + fbar -> g + g; th arbitrary, TC extensions
12648 mint(21)=21
12649 mint(22)=21
12650 kcc=mint(2)+4
12651
12652 ELSEIF(isub.EQ.384) THEN
12653C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12654 IF(mint(15).EQ.21) js=2
12655 kcc=mint(2)+6
12656 IF(mint(15).EQ.21) kcc=kcc+2
12657 IF(mint(15).NE.21) kcs=isign(1,mint(15))
12658 IF(mint(16).NE.21) kcs=isign(1,mint(16))
12659
12660 ELSEIF(isub.EQ.385) THEN
12661C...g + g -> f + fbar; th arbitrary, TC extensions
12662 kcs=(-1)**int(1.5d0+pyr(0))
12663 mint(21)=isign(kflf,kcs)
12664 mint(22)=-mint(21)
12665 kcc=mint(2)+10
12666
12667 ELSEIF(isub.EQ.386) THEN
12668C...g + g -> g + g; th arbitrary, TC extensions
12669 kcc=mint(2)+12
12670 kcs=(-1)**int(1.5d0+pyr(0))
12671
12672 ELSEIF(isub.EQ.387) THEN
12673C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12674 mint(21)=isign(mint(55),mint(15))
12675 mint(22)=-mint(21)
12676 kcc=4
12677
12678 ELSEIF(isub.EQ.388) THEN
12679C...g + g -> Q + Qbar; th arbitrary, TC extensions
12680 kcs=(-1)**int(1.5d0+pyr(0))
12681 mint(21)=isign(mint(55),kcs)
12682 mint(22)=-mint(21)
12683 kcc=mint(2)+10
12684
12685 ELSEIF(isub.EQ.391) THEN
12686C...f + fbar -> G*.
12687 kfres=kfpr(isub,1)
12688
12689 ELSEIF(isub.EQ.392) THEN
12690C...g + g -> G*.
12691 kcc=21
12692 kfres=kfpr(isub,1)
12693
12694 ELSEIF(isub.EQ.393) THEN
12695C...q + qbar -> g + G*; th arbitrary.
12696 IF(pyr(0).GT.0.5d0) js=2
12697 mint(20+js)=kfpr(isub,1)
12698 mint(23-js)=kfpr(isub,2)
12699 kcc=17+js
12700
12701 ELSEIF(isub.EQ.394) THEN
12702C...q + g -> q + G*; th = (p(f) - p(f))**2
12703 IF(mint(15).EQ.21) js=2
12704 mint(23-js)=kfpr(isub,2)
12705 kcc=15+js
12706 kcs=isign(1,mint(14+js))
12707
12708 ELSEIF(isub.EQ.395) THEN
12709C...g + g -> G* + g; th arbitrary.
12710 IF(pyr(0).GT.0.5d0) js=2
12711 mint(23-js)=kfpr(isub,2)
12712 kcc=22+js
12713 ENDIF
12714
12715 ELSEIF(isub.LE.420) THEN
12716 IF(isub.EQ.401) THEN
12717C...g + g -> t + b + H+/-
12718 kcs=(-1)**int(1.5d0+pyr(0))
12719 mint(21)=isign(kfpr(isubsv,2),kcs)
12720 mint(22)=isign(5,-kcs)
12721 kcc=11+int(0.5d0+pyr(0))
12722 kfres=isign(kfhigg,-kcs)
12723
12724 ELSEIF(isub.EQ.402) THEN
12725C...q + qbar -> t + b + H+/-
12726 kfl=(-1)**int(1.5d0+pyr(0))
12727 mint(21)=isign(int(6.+.5*kfl),kcs)
12728 mint(22)=isign(int(6.-.5*kfl),-kcs)
12729 kcc=4
12730 kfres=isign(kfhigg,-kfl*kcs)
12731 ENDIF
12732
12733C...QUARKONIA+++
12734C...Additional code by Stefan Wolf
12735 ELSEIF(isub.LE.430) THEN
12736 IF(isub.GE.421.AND.isub.LE.424) THEN
12737C...g + g -> QQ~[n] + g
12738C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12739C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12740C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12741C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12742C...or from ISUB.EQ.68 (for ISUB.NE.421)
12743C...[g + g -> g + g; th arbitrary]
12744 mint(21)=kfpr(isubsv,1)
12745 mint(22)=kfpr(isubsv,2)
12746 IF(isub.EQ.421) THEN
12747 kcc=24
12748 kcs=(-1)**int(1.5d0+pyr(0))
12749 ELSE
12750 kcc=mint(2)+12
12751 kcs=(-1)**int(1.5d0+pyr(0))
12752 ENDIF
12753
12754 ELSEIF(isub.GE.425.AND.isub.LE.427) THEN
12755C...q + g -> q + QQ~[n]
12756C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12757C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12758C...KCC copied from ISUB.EQ.28
12759C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12760 IF(mint(15).EQ.21) js=2
12761 mint(23-js)=kfpr(isubsv,2)
12762 kcc=mint(2)+6
12763 IF(mint(15).EQ.21) kcc=kcc+2
12764 IF(mint(15).NE.21) kcs=isign(1,mint(15))
12765 IF(mint(16).NE.21) kcs=isign(1,mint(16))
12766
12767 ELSEIF(isub.GE.428.AND.isub.LE.430) THEN
12768C...q + q~ -> g + QQ~[n]
12769C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12770C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12771C...KCC copied from ISUB.EQ.13
12772C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12773 IF(pyr(0).GT.0.5) js=2
12774 mint(20+js)=21
12775 mint(23-js)=kfpr(isubsv,2)
12776 kcc=mint(2)+4
12777 ENDIF
12778
12779 ELSEIF(isub.LE.440) THEN
12780 IF(isub.GE.431.AND.isub.LE.433) THEN
12781C...g + g -> QQ~[n] + g
12782C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12783C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12784C...KCC and KCS copied from ISUB.EQ.86-89
12785C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12786 mint(21)=kfpr(isubsv,1)
12787 mint(22)=kfpr(isubsv,2)
12788 kcc=24
12789 kcs=(-1)**int(1.5d0+pyr(0))
12790
12791 ELSEIF(isub.GE.434.AND.isub.LE.436) THEN
12792C...q + g -> q + QQ~[n]
12793C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12794C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12795C...KCC and KCS copied from ISUB.EQ.112
12796C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12797 IF(mint(15).EQ.21) js=2
12798 mint(23-js)=kfpr(isubsv,2)
12799 kcc=15+js
12800 kcs=isign(1,mint(14+js))
12801
12802 ELSEIF(isub.GE.437.AND.isub.LE.439) THEN
12803C...q + q~ -> g + QQ~[n]
12804C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12805C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12806C...KCC copied from ISUB.EQ.111
12807C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12808 IF(pyr(0).GT.0.5) js=2
12809 mint(20+js)=21
12810 mint(23-js)=kfpr(isubsv,2)
12811 kcc=17+js
12812 ENDIF
12813C...QUARKONIA---
12814
12815 ENDIF
12816
12817 IF(iset(isub).EQ.11) THEN
12818C...Store documentation for user-defined processes
12819 bezup=(pup(3,1)+pup(3,2))/(pup(4,1)+pup(4,2))
12820 kuppo(1)=mint(83)+5
12821 kuppo(2)=mint(83)+6
12822 i=mint(83)+6
12823 DO 470 iup=3,nup
12824 kuppo(iup)=0
12825 IF(mstp(128).GE.2.AND.mothup(1,iup).GE.3) THEN
12826 idoc=idoc-1
12827 mint(4)=mint(4)-1
12828 GOTO 470
12829 ENDIF
12830 i=i+1
12831 kuppo(iup)=i
12832 k(i,1)=21
12833 k(i,2)=idup(iup)
12834 IF(idup(iup).EQ.0) k(i,2)=90
12835 k(i,3)=0
12836 IF(mothup(1,iup).GE.3) k(i,3)=kuppo(mothup(1,iup))
12837 k(i,4)=0
12838 k(i,5)=0
12839 DO 460 j=1,5
12840 p(i,j)=pup(j,iup)
12841 460 CONTINUE
12842 v(i,5)=vtimup(iup)
12843 470 CONTINUE
12844 CALL pyrobo(mint(83)+7,mint(83)+4+nup,0d0,vint(24),0d0,0d0,
12845 & -bezup)
12846
12847C...Store final state partons for user-defined processes
12848 n=ipu2
12849 DO 490 iup=3,nup
12850 n=n+1
12851 k(n,1)=1
12852 IF(istup(iup).EQ.2.OR.istup(iup).EQ.3) k(n,1)=11
12853 k(n,2)=idup(iup)
12854 IF(idup(iup).EQ.0) k(n,2)=90
12855 IF(mstp(128).LE.0.OR.mothup(1,iup).EQ.0) THEN
12856 k(n,3)=kuppo(iup)
12857 ELSE
12858 k(n,3)=mint(84)+mothup(1,iup)
12859 ENDIF
12860 k(n,4)=0
12861 k(n,5)=0
12862C...Search for daughters of intermediate colourless particles.
12863 IF(k(n,1).EQ.11.AND.kchg(pycomp(k(n,2)),2).EQ.0) THEN
12864 DO 475 iupdau=iup+1,nup
12865 IF(mothup(1,iupdau).EQ.iup.AND.k(n,4).EQ.0) k(n,4)=
12866 & n+iupdau-iup
12867 IF(mothup(1,iupdau).EQ.iup) k(n,5)=n+iupdau-iup
12868 475 CONTINUE
12869 ENDIF
12870 DO 480 j=1,5
12871 p(n,j)=pup(j,iup)
12872 480 CONTINUE
12873 v(n,5)=vtimup(iup)
12874 490 CONTINUE
12875 CALL pyrobo(ipu3,n,0d0,vint(24),0d0,0d0,-bezup)
12876
12877C...Arrange colour flow for user-defined processes
12878 nlbl=0
12879 DO 540 iup1=1,nup
12880 i1=mint(84)+iup1
12881 IF(kchg(pycomp(k(i1,2)),2).EQ.0) GOTO 540
12882 IF(k(i1,1).EQ.1) k(i1,1)=3
12883 IF(k(i1,1).EQ.11) k(i1,1)=14
12884C...Find a not yet considered colour/anticolour line.
12885 DO 530 isde1=1,2
12886 IF(icolup(isde1,iup1).EQ.0) GOTO 530
12887 nmat=0
12888 DO 500 ilbl=1,nlbl
12889 IF(icolup(isde1,iup1).EQ.ilab(ilbl)) nmat=1
12890 500 CONTINUE
12891 IF(nmat.EQ.0) THEN
12892 nlbl=nlbl+1
12893 ilab(nlbl)=icolup(isde1,iup1)
12894C...Find all others belonging to same line.
12895 i3=i1
12896 i4=0
12897 DO 520 iup2=iup1+1,nup
12898 i2=mint(84)+iup2
12899 DO 510 isde2=1,2
12900 IF(icolup(isde2,iup2).EQ.icolup(isde1,iup1)) THEN
12901 IF(isde2.EQ.isde1) THEN
12902 k(i3,3+isde2)=k(i3,3+isde2)+i2
12903 k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i3
12904 i3=i2
12905 ELSEIF(i4.NE.0) THEN
12906 k(i4,3+isde2)=k(i4,3+isde2)+i2
12907 k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i4
12908 i4=i2
12909 ELSEIF(iup2.LE.2) THEN
12910 k(i1,3+isde1)=k(i1,3+isde1)+i2
12911 k(i2,3+isde2)=k(i2,3+isde2)+i1
12912 i4=i2
12913 ELSE
12914 k(i1,3+isde1)=k(i1,3+isde1)+mstu(5)*i2
12915 k(i2,3+isde2)=k(i2,3+isde2)+mstu(5)*i1
12916 i4=i2
12917 ENDIF
12918 ENDIF
12919 510 CONTINUE
12920 520 CONTINUE
12921 ENDIF
12922 530 CONTINUE
12923 540 CONTINUE
12924
12925 ELSEIF(idoc.EQ.7) THEN
12926C...Resonance not decaying; store kinematics
12927 i=mint(83)+7
12928 k(ipu3,1)=1
12929 k(ipu3,2)=kfres
12930 k(ipu3,3)=i
12931 p(ipu3,4)=shuser
12932 p(ipu3,5)=shuser
12933 k(i,1)=21
12934 k(i,2)=kfres
12935 p(i,4)=shuser
12936 p(i,5)=shuser
12937 n=ipu3
12938 mint(21)=kfres
12939 mint(22)=0
12940
12941C...Special cases: colour flow in coloured resonances
12942 kcres=pycomp(kfres)
12943 IF(kchg(kcres,2).NE.0) THEN
12944 k(ipu3,1)=3
12945 DO 550 j=1,2
12946 jc=j
12947 IF(kcs.EQ.-1) jc=3-j
12948 IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
12949 & mint(84)+icol(kcc,1,jc)
12950 IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
12951 & mint(84)+icol(kcc,2,jc)
12952 IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
12953 & mstu(5)*(mint(84)+icol(kcc,3,jc))
12954 550 CONTINUE
12955 ELSE
12956 k(ipu1,4)=ipu2
12957 k(ipu1,5)=ipu2
12958 k(ipu2,4)=ipu1
12959 k(ipu2,5)=ipu1
12960 ENDIF
12961
12962 ELSEIF(idoc.EQ.8) THEN
12963C...2 -> 2 processes: store outgoing partons in their CM-frame
12964 DO 560 jt=1,2
12965 i=mint(84)+2+jt
12966 kca=pycomp(mint(20+jt))
12967 k(i,1)=1
12968 IF(kchg(kca,2).NE.0) k(i,1)=3
12969 k(i,2)=mint(20+jt)
12970 k(i,3)=mint(83)+idoc+jt-2
12971 kfaa=iabs(k(i,2))
12972 IF(kfpr(isubsv,1+mod(js+jt,2)).NE.0) THEN
12973 p(i,5)=sqrt(vint(63+mod(js+jt,2)))
12974 ELSE
12975 p(i,5)=pymass(k(i,2))
12976 ENDIF
12977 IF((kfaa.EQ.6.OR.kfaa.EQ.7.OR.kfaa.EQ.8).AND.
12978 & p(i,5).LT.parp(42)) p(i,5)=pymass(k(i,2))
12979 560 CONTINUE
12980 IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN
12981 kfa1=iabs(mint(21))
12982 kfa2=iabs(mint(22))
12983 IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))
12984 & THEN
12985 mint(51)=1
12986 RETURN
12987 ENDIF
12988 p(ipu3,5)=0d0
12989 p(ipu4,5)=0d0
12990 ENDIF
12991 p(ipu3,4)=0.5d0*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr)
12992 p(ipu3,3)=sqrt(max(0d0,p(ipu3,4)**2-p(ipu3,5)**2))
12993 p(ipu4,4)=shr-p(ipu3,4)
12994 p(ipu4,3)=-p(ipu3,3)
12995 n=ipu4
12996 mint(7)=mint(83)+7
12997 mint(8)=mint(83)+8
12998
12999C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13000 CALL pyrobo(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)
13001
13002 ELSEIF(idoc.EQ.9) THEN
13003C...2 -> 3 processes: store outgoing partons in their CM frame
13004 DO 570 jt=1,2
13005 i=mint(84)+2+jt
13006 kca=pycomp(mint(20+jt))
13007 k(i,1)=1
13008 IF(kchg(kca,2).NE.0) k(i,1)=3
13009 k(i,2)=mint(20+jt)
13010 k(i,3)=mint(83)+idoc+jt-3
13011 jta=jt
13012C...t and b in opposide order in event list as compared to
13013C...matrix element?
13014 IF(isub.EQ.402.AND.iabs(mint(21)).EQ.5) jta=3-jt
13015 IF(iabs(k(i,2)).LE.22) THEN
13016 p(i,5)=pymass(k(i,2))
13017 ELSE
13018 p(i,5)=sqrt(vint(63+mod(js+jta,2)))
13019 ENDIF
13020 pt=sqrt(max(0d0,vint(197+5*jta)-p(i,5)**2+vint(196+5*jta)**2))
13021 p(i,1)=pt*cos(vint(198+5*jta))
13022 p(i,2)=pt*sin(vint(198+5*jta))
13023 570 CONTINUE
13024 k(ipu5,1)=1
13025 k(ipu5,2)=kfres
13026 k(ipu5,3)=mint(83)+idoc
13027 p(ipu5,5)=shr
13028 p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
13029 p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
13030 pms1=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
13031 pms2=p(ipu4,5)**2+p(ipu4,1)**2+p(ipu4,2)**2
13032 pms3=p(ipu5,5)**2+p(ipu5,1)**2+p(ipu5,2)**2
13033 pmt3=sqrt(pms3)
13034 p(ipu5,3)=pmt3*sinh(vint(211))
13035 p(ipu5,4)=pmt3*cosh(vint(211))
13036 pms12=(shpr-p(ipu5,4))**2-p(ipu5,3)**2
13037 sql12=(pms12-pms1-pms2)**2-4d0*pms1*pms2
13038 IF(sql12.LE.0d0) THEN
13039 mint(51)=1
13040 RETURN
13041 ENDIF
13042 p(ipu3,3)=(-p(ipu5,3)*(pms12+pms1-pms2)+
13043 & vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)
13044 p(ipu4,3)=-p(ipu3,3)-p(ipu5,3)
13045 IF(isub.EQ.402.AND.iabs(mint(21)).EQ.5) THEN
13046C...t and b in opposide order in event list as compared to
13047C...matrix element
13048 p(ipu4,3)=(-p(ipu5,3)*(pms12+pms2-pms1)+
13049 & vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)
13050 p(ipu3,3)=-p(ipu4,3)-p(ipu5,3)
13051 END IF
13052 p(ipu3,4)=sqrt(pms1+p(ipu3,3)**2)
13053 p(ipu4,4)=sqrt(pms2+p(ipu4,3)**2)
13054 mint(23)=kfres
13055 n=ipu5
13056 mint(7)=mint(83)+7
13057 mint(8)=mint(83)+8
13058
13059 ELSEIF(idoc.EQ.11) THEN
13060C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13061 phi(1)=paru(2)*pyr(0)
13062 phi(2)=phi(1)-phir
13063 DO 580 jt=1,2
13064 i=mint(84)+2+jt
13065 k(i,1)=1
13066 IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
13067 k(i,2)=mint(20+jt)
13068 k(i,3)=mint(83)+idoc+jt-2
13069 p(i,5)=pymass(k(i,2))
13070 IF(0.5d0*shpr*z(jt).LE.p(i,5)) THEN
13071 mint(51)=1
13072 RETURN
13073 ENDIF
13074 pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
13075 ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
13076 p(i,1)=ptabs*cos(phi(jt))
13077 p(i,2)=ptabs*sin(phi(jt))
13078 p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
13079 p(i,4)=0.5d0*shpr*z(jt)
13080 izw=mint(83)+6+jt
13081 k(izw,1)=21
13082 k(izw,2)=23
13083 IF(isub.EQ.8) k(izw,2)=isign(24,pychge(mint(14+jt)))
13084 k(izw,3)=izw-2
13085 p(izw,1)=-p(i,1)
13086 p(izw,2)=-p(i,2)
13087 p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
13088 p(izw,4)=0.5d0*shpr*(1d0-z(jt))
13089 p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
13090 580 CONTINUE
13091 i=mint(83)+9
13092 k(ipu5,1)=1
13093 k(ipu5,2)=kfres
13094 k(ipu5,3)=i
13095 p(ipu5,5)=shr
13096 p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)
13097 p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)
13098 p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)
13099 p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)
13100 k(i,1)=21
13101 k(i,2)=kfres
13102 DO 590 j=1,5
13103 p(i,j)=p(ipu5,j)
13104 590 CONTINUE
13105 n=ipu5
13106 mint(23)=kfres
13107
13108 ELSEIF(idoc.EQ.12) THEN
13109C...Z0 and W+/- scattering: store bosons and outgoing partons
13110 phi(1)=paru(2)*pyr(0)
13111 phi(2)=phi(1)-phir
13112 jtran=int(1.5d0+pyr(0))
13113 DO 600 jt=1,2
13114 i=mint(84)+2+jt
13115 k(i,1)=1
13116 IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3
13117 k(i,2)=mint(20+jt)
13118 k(i,3)=mint(83)+idoc+jt-2
13119 p(i,5)=pymass(k(i,2))
13120 IF(0.5d0*shpr*z(jt).LE.p(i,5)) p(i,5)=0d0
13121 pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))
13122 ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))
13123 p(i,1)=ptabs*cos(phi(jt))
13124 p(i,2)=ptabs*sin(phi(jt))
13125 p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)
13126 p(i,4)=0.5d0*shpr*z(jt)
13127 izw=mint(83)+6+jt
13128 k(izw,1)=21
13129 IF(mint(14+jt).EQ.mint(20+jt)) THEN
13130 k(izw,2)=23
13131 ELSE
13132 k(izw,2)=isign(24,pychge(mint(14+jt))-pychge(mint(20+jt)))
13133 ENDIF
13134 k(izw,3)=izw-2
13135 p(izw,1)=-p(i,1)
13136 p(izw,2)=-p(i,2)
13137 p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)
13138 p(izw,4)=0.5d0*shpr*(1d0-z(jt))
13139 p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))
13140 ipu=mint(84)+4+jt
13141 k(ipu,1)=3
13142 k(ipu,2)=kfpr(isub,jt)
13143 IF(isub.EQ.72.AND.jt.EQ.jtran) k(ipu,2)=-k(ipu,2)
13144 IF(isub.EQ.73.OR.isub.EQ.77) k(ipu,2)=k(izw,2)
13145 k(ipu,3)=mint(83)+8+jt
13146 IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN
13147 p(ipu,5)=pymass(k(ipu,2))
13148 ELSE
13149 p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))
13150 ENDIF
13151 mint(22+jt)=k(ipu,2)
13152 600 CONTINUE
13153C...Find rotation and boost for hard scattering subsystem
13154 i1=mint(83)+7
13155 i2=mint(83)+8
13156 bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))
13157 beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))
13158 bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))
13159 gamcm=(p(i1,4)+p(i2,4))/shr
13160 bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3)
13161 px=p(i1,1)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bexcm
13162 py=p(i1,2)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*beycm
13163 pz=p(i1,3)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bezcm
13164 thecm=pyangl(pz,sqrt(px**2+py**2))
13165 phicm=pyangl(px,py)
13166C...Store hard scattering subsystem. Rotate and boost it
13167 sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4d0*p(ipu5,5)**2*
13168 & p(ipu6,5)**2
13169 pabs=sqrt(max(0d0,sqlam/(4d0*sh)))
13170 cthwz=vint(23)
13171 sthwz=sqrt(max(0d0,1d0-cthwz**2))
13172 phiwz=vint(24)-phicm
13173 p(ipu5,1)=pabs*sthwz*cos(phiwz)
13174 p(ipu5,2)=pabs*sthwz*sin(phiwz)
13175 p(ipu5,3)=pabs*cthwz
13176 p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)
13177 p(ipu6,1)=-p(ipu5,1)
13178 p(ipu6,2)=-p(ipu5,2)
13179 p(ipu6,3)=-p(ipu5,3)
13180 p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)
13181 CALL pyrobo(ipu5,ipu6,thecm,phicm,bexcm,beycm,bezcm)
13182 DO 620 jt=1,2
13183 i1=mint(83)+8+jt
13184 i2=mint(84)+4+jt
13185 k(i1,1)=21
13186 k(i1,2)=k(i2,2)
13187 DO 610 j=1,5
13188 p(i1,j)=p(i2,j)
13189 610 CONTINUE
13190 620 CONTINUE
13191 n=ipu6
13192 mint(7)=mint(83)+9
13193 mint(8)=mint(83)+10
13194 ENDIF
13195
13196 IF(iset(isub).EQ.11) THEN
13197 ELSEIF(idoc.GE.8) THEN
13198C...Store colour connection indices
13199 DO 630 j=1,2
13200 jc=j
13201 IF(kcs.EQ.-1) jc=3-j
13202 IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
13203 & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)
13204 IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
13205 & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)
13206 IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=
13207 & mstu(5)*(mint(84)+icol(kcc,3,jc))
13208 IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
13209 & mstu(5)*(mint(84)+icol(kcc,4,jc))
13210 630 CONTINUE
13211
13212C...Copy outgoing partons to documentation lines
13213 imax=2
13214 IF(idoc.EQ.9) imax=3
13215 DO 650 i=1,imax
13216 i1=mint(83)+idoc-imax+i
13217 i2=mint(84)+2+i
13218 k(i1,1)=21
13219 k(i1,2)=k(i2,2)
13220 IF(idoc.LE.9) k(i1,3)=0
13221 IF(idoc.GE.11) k(i1,3)=mint(83)+2+i
13222 DO 640 j=1,5
13223 p(i1,j)=p(i2,j)
13224 640 CONTINUE
13225 650 CONTINUE
13226
13227 ELSEIF(idoc.EQ.9) THEN
13228C...Store colour connection indices
13229 DO 660 j=1,2
13230 jc=j
13231 IF(kcs.EQ.-1) jc=3-j
13232 IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=
13233 & k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)+
13234 & max(0,min(1,icol(kcc,1,jc)-2))
13235 IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=
13236 & k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)+
13237 & max(0,min(1,icol(kcc,2,jc)-2))
13238 IF(icol(kcc,3,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=
13239 & mstu(5)*(mint(84)+icol(kcc,3,jc))
13240 IF(icol(kcc,4,jc).NE.0.AND.k(ipu5,1).EQ.3) k(ipu5,j+3)=
13241 & mstu(5)*(mint(84)+icol(kcc,4,jc))
13242 660 CONTINUE
13243
13244C...Copy outgoing partons to documentation lines
13245 DO 680 i=1,3
13246 i1=mint(83)+idoc-3+i
13247 i2=mint(84)+2+i
13248 k(i1,1)=21
13249 k(i1,2)=k(i2,2)
13250 k(i1,3)=0
13251 DO 670 j=1,5
13252 p(i1,j)=p(i2,j)
13253 670 CONTINUE
13254 680 CONTINUE
13255 ENDIF
13256
13257C...Copy outgoing partons to list of allowed radiators.
13258 npart=0
13259 IF(mint(35).GE.2.AND.iset(isub).NE.0) THEN
13260 DO 690 i=mint(84)+3,n
13261 npart=npart+1
13262 ipart(npart)=i
13263 ptpart(npart)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2)
13264 690 CONTINUE
13265 ENDIF
13266
13267C...Low-pT events: remove gluons used for string drawing purposes
13268 IF(isub.EQ.95) THEN
13269 IF(mint(35).LE.1) THEN
13270 k(ipu3,1)=k(ipu3,1)+10
13271 k(ipu4,1)=k(ipu4,1)+10
13272 ENDIF
13273 DO 700 j=41,66
13274 vintsv(j)=vint(j)
13275 vint(j)=0d0
13276 700 CONTINUE
13277 DO 720 i=mint(83)+5,mint(83)+8
13278 DO 710 j=1,5
13279 p(i,j)=0d0
13280 710 CONTINUE
13281 720 CONTINUE
13282 ENDIF
13283
13284 RETURN
13285 END
13286
13287C***********************************************************************
13288
13289C...PYEVOL
13290C...Handles intertwined pT-ordered spacelike initial-state parton
13291C...and multiple interactions.
13292
13293 SUBROUTINE pyevol(MODE,PT2MAX,PT2MIN)
13294C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13295C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13296C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13297
13298C...Double precision and integer declarations.
13299 IMPLICIT DOUBLE PRECISION(a-h, o-z)
13300 IMPLICIT INTEGER(I-N)
13301 INTEGER PYK,PYCHGE,PYCOMP
13302C...External
13303 EXTERNAL pyalps
13304 DOUBLE PRECISION PYALPS
13305C...Parameter statement for maximum size of showers.
13306 parameter(maxnur=1000)
13307C...Commonblocks.
13308 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
13309 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13310 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13311 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
13312 common/pypars/mstp(200),parp(200),msti(200),pari(200)
13313 common/pyint1/mint(400),vint(400)
13314 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
13315 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
13316 common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
13317 & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
13318 & xmi(2,240),pt2mi(240),imisep(0:240)
13319 common/pyctag/nct,mct(4000,2)
13320 common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
13321 & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
13322 common/pyisjn/mjn1mx,mjn2mx,mjoind(2,240)
13323C...Local arrays and saved variables.
13324 dimension vintsv(11:80),ksav(4,5),psav(4,5),vsav(4,5),shat(240)
13325 SAVE nsav,nparts,m15sv,m16sv,m21sv,m22sv,vintsv,shat,isubhd,alam3
13326 & ,psav,ksav,vsav
13327
13328 SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,
13329 & /pyint2/,/pyint3/,/pyintm/,/pyctag/,/pyismx/,/pyisjn/
13330
13331C----------------------------------------------------------------------
13332C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13333C...done only once per event, while MODE=0 is repeated each time the
13334C...evolution needs to be restarted.
13335 IF (mode.EQ.-1) THEN
13336 isubhd=mint(1)
13337 nsav=n
13338 nparts=npart
13339C...Store hard scattering variables
13340 m15sv=mint(15)
13341 m16sv=mint(16)
13342 m21sv=mint(21)
13343 m22sv=mint(22)
13344 DO 100 j=11,80
13345 vintsv(j)=vint(j)
13346 100 CONTINUE
13347 DO 120 j=1,5
13348 DO 110 is=1,4
13349 i=is+mint(84)
13350 psav(is,j)=p(i,j)
13351 ksav(is,j)=k(i,j)
13352 vsav(is,j)=v(i,j)
13353 110 CONTINUE
13354 120 CONTINUE
13355
13356C...Set shat for hardest scattering
13357 shat(1)=vint(44)
13358 IF(iset(isubhd).GE.3.AND.iset(isubhd).LE.5) shat(1)=vint(26)
13359 & *vint(2)
13360
13361C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13362 rmc=pmas(4,1)
13363 rmb=pmas(5,1)
13364 alam4=parp(61)
13365 IF(mstu(112).LT.4) alam4=parp(61)*(parp(61)/rmc)**(2d0/25d0)
13366 IF(mstu(112).GT.4) alam4=parp(61)*(rmb/parp(61))**(2d0/25d0)
13367 alam3=alam4*(rmc/alam4)**(2d0/27d0)
13368
13369C----------------------------------------------------------------------
13370C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13371C...interaction initiators, with no previous evolution. Check the input
13372C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13373C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13374C...smaller than the CM energy / 2.)
13375 ELSEIF (mode.EQ.0) THEN
13376C...Reset counters and switches
13377 n=nsav
13378 npart=nparts
13379 mint(30)=0
13380 mint(31)=1
13381 mint(36)=1
13382C...Reset hard scattering variables
13383 mint(1)=isubhd
13384 DO 130 j=11,80
13385 vint(j)=vintsv(j)
13386 130 CONTINUE
13387 DO 150 j=1,5
13388 DO 140 is=1,4
13389 i=is+mint(84)
13390 p(i,j)=psav(is,j)
13391 k(i,j)=ksav(is,j)
13392 v(i,j)=vsav(is,j)
13393 p(mint(83)+4+is,j)=psav(is,j)
13394 v(mint(83)+4+is,j)=vsav(is,j)
13395 140 CONTINUE
13396 150 CONTINUE
13397C...Reset statistics on activity in event.
13398 DO 160 j=351,359
13399 mint(j)=0
13400 vint(j)=0d0
13401 160 CONTINUE
13402C...Reset extra companion reweighting factor
13403 vint(140)=1d0
13404
13405C...We do not generate MI for soft process (ISUB=95), but the
13406C...initialization must be done regardless, for later purposes.
13407 mint(36)=1
13408
13409C...Initialize multiple interactions.
13410 CALL pyptmi(-1,ptdum1,ptdum2,ptdum3,idum)
13411 IF(mint(51).NE.0) RETURN
13412
13413C...Decide whether quarks in hard scattering were valence or sea
13414 pt2hd=vint(54)
13415 DO 170 js=1,2
13416 mint(30)=js
13417 CALL pyptmi(2,pt2hd,ptdum2,ptdum3,idum)
13418 IF(mint(51).NE.0) RETURN
13419 170 CONTINUE
13420
13421C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13422 vint(18)=0d0
13423 pt2min=max(pt2min,(1.1d0*alam3)**2)
13424 IF (mstp(70).EQ.2) THEN
13425C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13426 vint(18)=(parp(82)*(vint(1)/parp(89))**parp(90))**2
13427 ELSEIF (mstp(70).EQ.3) THEN
13428C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13429 alpha0 = max(1d-6,parp(73))
13430 q20 = alam3**2/parp(64)
13431 IF (mstp(64).EQ.3) q20 = q20 * 1.661**2
13432 vint(18) = q20 * (exp(12*paru(1)/27d0/alpha0)-1d0)
13433 ENDIF
13434C...Also store PT2MIN in VINT(17).
13435 180 vint(17)=pt2min
13436
13437C...Set FS masses zero now.
13438 vint(63)=0d0
13439 vint(64)=0d0
13440
13441C...Initialize IS showers with VINT(56) as max scale.
13442 pt2isr=vint(56)
13443 pt20=pt2min
13444 IF (mstp(70).EQ.0) THEN
13445 pt20=max(pt2min,parp(62)**2)
13446 ELSEIF (mstp(70).EQ.1) THEN
13447 pt20=max(pt2min,(parp(81)*(vint(1)/parp(89))**parp(90))**2)
13448 ENDIF
13449 CALL pyptis(-1,pt2isr,pt20,pt2dum,ifail)
13450 IF(mint(51).NE.0) RETURN
13451
13452 RETURN
13453
13454C----------------------------------------------------------------------
13455C...MODE= 1: Evolve event from PTMAX to PTMIN.
13456 ELSEIF (mode.EQ.1) THEN
13457
13458C...Skip if no phase space.
13459 190 IF (pt2max.LE.pt2min) GOTO 330
13460
13461C...Starting pT2 max scale (to be udpated successively).
13462 pt2cmx=pt2max
13463
13464C...Evolve two sides of the event to find which branches at highest pT.
13465 200 jsmx=-1
13466 mimx=0
13467 pt2mx=0d0
13468
13469C...Loop over current shower initiators.
13470 IF (mstp(61).GE.1) THEN
13471 DO 230 mi=1,mint(31)
13472 IF (mi.GE.2.AND.mstp(84).LE.0) GOTO 230
13473 isub=96
13474 IF (mi.EQ.1) isub=isubhd
13475 mint(1)=isub
13476 mint(36)=mi
13477C...Set up shat, initiator x values, and x remaining in BR.
13478 vint(44)=shat(mi)
13479 vint(141)=xmi(1,mi)
13480 vint(142)=xmi(2,mi)
13481 vint(143)=1d0
13482 vint(144)=1d0
13483 DO 210 ji=1,mint(31)
13484 IF (ji.EQ.mint(36)) GOTO 210
13485 vint(143)=vint(143)-xmi(1,ji)
13486 vint(144)=vint(144)-xmi(2,ji)
13487 210 CONTINUE
13488C...Loop over sides.
13489C...Generate trial branchings for this interaction. The hardest
13490C...branching so far is automatically updated if necessary in /PYISMX/.
13491 DO 220 js=1,2
13492 mint(30)=js
13493 pt20=pt2min
13494 IF (mstp(70).EQ.0) THEN
13495 pt20=max(pt2min,parp(62)**2)
13496 ELSEIF (mstp(70).EQ.1) THEN
13497 pt20=max(pt2min,
13498 & (parp(81)*(vint(1)/parp(89))**parp(90))**2)
13499 ENDIF
13500 CALL pyptis(0,pt2cmx,pt20,pt2new,ifail)
13501 IF (mint(51).NE.0) RETURN
13502 220 CONTINUE
13503 230 CONTINUE
13504 ENDIF
13505
13506C...Generate trial additional interaction.
13507 mint(36)=mint(31)+1
13508 240 IF (mod(mstp(81),10).GE.1) THEN
13509 mint(1)=96
13510C...Set up X remaining in BR.
13511 vint(143)=1d0
13512 vint(144)=1d0
13513 DO 250 ji=1,mint(31)
13514 vint(143)=vint(143)-xmi(1,ji)
13515 vint(144)=vint(144)-xmi(2,ji)
13516 250 CONTINUE
13517C...Generate trial interaction
13518 260 CALL pyptmi(0,pt2cmx,pt2min,pt2new,ifail)
13519 IF (mint(51).EQ.1) RETURN
13520 ENDIF
13521
13522C...And the winner is:
13523 IF (pt2mx.LT.pt2min) THEN
13524 GOTO 330
13525 ELSEIF (jsmx.EQ.0) THEN
13526C...Accept additional interaction (may still fail).
13527 CALL pyptmi(1,pt2new,pt2min,pt2dum,ifail)
13528 IF(mint(51).NE.0) RETURN
13529 IF (ifail.EQ.0) THEN
13530 shat(mint(36))=vint(44)
13531C...Decide on flavours (valence/sea/companion).
13532 DO 270 js=1,2
13533 mint(30)=js
13534 CALL pyptmi(2,pt2new,pt2min,pt2dum,ifail)
13535 IF(mint(51).NE.0) RETURN
13536 270 CONTINUE
13537 ENDIF
13538 ELSEIF (jsmx.EQ.1.OR.jsmx.EQ.2) THEN
13539C...Reconstruct kinematics of acceptable ISR branching.
13540C...Set up shat, initiator x values, and x remaining in BR.
13541 mint(30)=jsmx
13542 mint(36)=mimx
13543 vint(44)=shat(mint(36))
13544 vint(141)=xmi(1,mint(36))
13545 vint(142)=xmi(2,mint(36))
13546 vint(143)=1d0
13547 vint(144)=1d0
13548 DO 280 ji=1,mint(31)
13549 IF (ji.EQ.mint(36)) GOTO 280
13550 vint(143)=vint(143)-xmi(1,ji)
13551 vint(144)=vint(144)-xmi(2,ji)
13552 280 CONTINUE
13553 pt2new=pt2mx
13554 CALL pyptis(1,pt2new,pt2dm1,pt2dm2,ifail)
13555 IF (mint(51).EQ.1) RETURN
13556 ELSEIF (jsmx.EQ.3.OR.jsmx.EQ.4) THEN
13557C...Bookeep joining. Cannot (yet) be constructed kinematically.
13558 mint(354)=mint(354)+1
13559 vint(354)=vint(354)+sqrt(pt2mx)
13560 IF (mint(354).EQ.1) vint(359)=sqrt(pt2mx)
13561 mjoind(jsmx-2,mjn1mx)=mjn2mx
13562 mjoind(jsmx-2,mjn2mx)=mjn1mx
13563 ENDIF
13564
13565C...Update PT2 iteration scale.
13566 pt2cmx=pt2mx
13567
13568C...Loop back to continue evolution.
13569 IF(n.GT.mstu(4)-mstu(32)-10) THEN
13570 CALL pyerrm(11,'(PYEVOL:) no more memory left in PYJETS')
13571 ELSE
13572 IF (jsmx.GE.0.AND.pt2cmx.GE.pt2min) GOTO 200
13573 ENDIF
13574
13575C----------------------------------------------------------------------
13576C...MODE= 2: (Re-)store user information on hardest interaction etc.
13577 ELSEIF (mode.EQ.2) THEN
13578
13579C...Revert to "ordinary" meanings of some parameters.
13580 290 DO 310 js=1,2
13581 mint(12+js)=k(imi(js,1,1),2)
13582 vint(140+js)=xmi(js,1)
13583 IF(mint(18+js).EQ.1) vint(140+js)=vint(154+js)*xmi(js,1)
13584 vint(142+js)=1d0
13585 DO 300 mi=1,mint(31)
13586 vint(142+js)=vint(142+js)-xmi(js,mi)
13587 300 CONTINUE
13588 310 CONTINUE
13589
13590C...Restore saved quantities for hardest interaction.
13591 mint(1)=isubhd
13592 mint(15)=m15sv
13593 mint(16)=m16sv
13594 mint(21)=m21sv
13595 mint(22)=m22sv
13596 DO 320 j=11,80
13597 vint(j)=vintsv(j)
13598 320 CONTINUE
13599
13600 ENDIF
13601
13602 330 RETURN
13603 END
13604
13605C*********************************************************************
13606
13607C...PYSSPA
13608C...Generates spacelike parton showers.
13609
13610 SUBROUTINE pysspa(IPU1,IPU2)
13611
13612C...Double precision and integer declarations.
13613 IMPLICIT DOUBLE PRECISION(a-h, o-z)
13614 IMPLICIT INTEGER(I-N)
13615 INTEGER PYK,PYCHGE,PYCOMP
13616 parameter(maxnur=1000)
13617C...Commonblocks.
13618 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
13619 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
13620 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
13621 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
13622 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
13623 common/pypars/mstp(200),parp(200),msti(200),pari(200)
13624 common/pyint1/mint(400),vint(400)
13625 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
13626 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
13627 common/pyctag/nct,mct(4000,2)
13628 SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,
13629 &/pyint1/,/pyint2/,/pyint3/,/pyctag/
13630C...Local arrays and data.
13631 dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevcsv(2),tevesv(2),
13632 &xfs(2,-25:25),xfa(-25:25),xfb(-25:25),xfn(-25:25),wtapc(-25:25),
13633 &wtape(-25:25),wtsf(-25:25),the2(2),alam(2),dq2(3),dpc(3),dpd(4),
13634 &dpb(4),robo(5),more(2),kfbeam(2),q2mncs(2),kcfi(2),nfis(2),
13635 &thefis(2,2),isfi(2),dphi(2),mcesv(2)
13636 DATA is/2*0/
13637
13638C...Read out basic information; set global Q^2 scale.
13639 ipus1=ipu1
13640 ipus2=ipu2
13641 isub=mint(1)
13642 q2mx=vint(56)
13643 vint2r=vint(2)*vint(143)*vint(144)
13644 IF(iset(isub).EQ.2.OR.iset(isub).EQ.9.OR.iset(isub).EQ.11) q2mx=
13645 &min(vint2r,parp(67)*vint(56))
13646 fcq2mx=1d0
13647
13648C...Define which processes ME corrections have been implemented for.
13649 mecor=0
13650 IF(mstp(68).EQ.1.OR.mstp(68).EQ.3) THEN
13651 IF(isub.EQ.1.OR.isub.EQ.2.OR.isub.EQ.141.OR.isub.EQ.142.OR.
13652 & isub.EQ.144) mecor=1
13653 IF(isub.EQ.102.OR.isub.EQ.152.OR.isub.EQ.157) mecor=2
13654 IF(isub.EQ.3.OR.isub.EQ.151.OR.isub.EQ.156) mecor=3
13655 ENDIF
13656
13657C...Initialize QCD evolution and check phase space.
13658 q2mnc=parp(62)**2
13659 q2mncs(1)=q2mnc
13660 q2mncs(2)=q2mnc
13661 IF(mint(107).EQ.2.AND.mstp(66).EQ.2) THEN
13662 q0s=parp(15)**2
13663 ps=vint(3)**2
13664 q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
13665 & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
13666 q2int=sqrt(q0s*q2eff)
13667 q2mncs(1)=max(q2mnc,q2int)
13668 ELSEIF(mint(107).EQ.3.AND.mstp(66).GE.1) THEN
13669 q2mncs(1)=max(q2mnc,vint(283))
13670 ENDIF
13671 IF(mint(108).EQ.2.AND.mstp(66).EQ.2) THEN
13672 q0s=parp(15)**2
13673 ps=vint(4)**2
13674 q2eff=vint(54)*((q0s+ps)/(vint(54)+ps))*
13675 & exp(ps*(vint(54)-q0s)/((vint(54)+ps)*(q0s+ps)))
13676 q2int=sqrt(q0s*q2eff)
13677 q2mncs(2)=max(q2mnc,q2int)
13678 ELSEIF(mint(108).EQ.3.AND.mstp(66).GE.1) THEN
13679 q2mncs(2)=max(q2mnc,vint(284))
13680 ENDIF
13681 mcev=0
13682 alams=paru(112)
13683 paru(112)=parp(61)
13684 fq2c=1d0
13685 tcmx=0d0
13686 IF(mint(47).GE.2.AND.(mint(47).LT.5.OR.mstp(12).GE.1)) THEN
13687 mcev=1
13688 IF(mstp(64).EQ.1) fq2c=parp(63)
13689 IF(mstp(64).EQ.2) fq2c=parp(64)
13690 tcmx=log(fq2c*q2mx/parp(61)**2)
13691 IF(q2mx.LT.max(q2mnc,2d0*parp(61)**2).OR.tcmx.LT.0.2d0)
13692 & mcev=0
13693 ENDIF
13694
13695C...Initialize QED evolution and check phase space.
13696 meev=0
13697 xee=1d-10
13698 spme=pmas(11,1)**2
13699 IF(iabs(mint(11)).EQ.13.OR.iabs(mint(12)).EQ.13)
13700 &spme=pmas(13,1)**2
13701 IF(iabs(mint(11)).EQ.15.OR.iabs(mint(12)).EQ.15)
13702 &spme=pmas(15,1)**2
13703 q2mne=max(parp(68)**2,2d0*spme)
13704 temx=0d0
13705 fwte=10d0
13706 IF(mint(45).EQ.3.OR.mint(46).EQ.3) THEN
13707 meev=1
13708 temx=log(q2mx/spme)
13709 IF(q2mx.LE.q2mne.OR.temx.LT.0.2d0) meev=0
13710 ENDIF
13711 IF(mstp(61).GE.2.AND.mcev.EQ.1.AND.meev.EQ.0) THEN
13712 meev=2
13713 temx=tcmx
13714 fwte=1d0
13715 ENDIF
13716 IF(mcev.EQ.0.AND.meev.EQ.0) RETURN
13717
13718C...Loopback point in case of failure to reconstruct kinematics.
13719 ns=n
13720 nparts=npart
13721 loop=0
13722 mnt352=mint(352)
13723 mnt353=mint(353)
13724 vnt352=vint(352)
13725 vnt353=vint(353)
13726 100 loop=loop+1
13727 IF(loop.GT.100) THEN
13728 mint(51)=1
13729 RETURN
13730 ENDIF
13731 n=ns
13732 npart=nparts
13733 mint(352)=mnt352
13734 mint(353)=mnt353
13735 vint(352)=vnt352
13736 vint(353)=vnt353
13737
13738C...Initial values: flavours, momenta, virtualities.
13739 DO 120 jt=1,2
13740 more(jt)=1
13741 kfbeam(jt)=mint(10+jt)
13742 IF(mint(18+jt).EQ.1)kfbeam(jt)=22
13743 kfls(jt)=mint(14+jt)
13744 kfls(jt+2)=kfls(jt)
13745 xs(jt)=vint(40+jt)
13746 IF(mint(18+jt).EQ.1) xs(jt)=vint(40+jt)/vint(154+jt)
13747 IF(mint(31).GE.2) xs(jt)=xs(jt)/vint(142+jt)
13748 zs(jt)=1d0
13749 q2s(jt)=fcq2mx*q2mx
13750 dq2(jt)=0d0
13751 tevcsv(jt)=tcmx
13752 alam(jt)=parp(61)
13753 the2(jt)=1d0
13754 tevesv(jt)=temx
13755 mcesv(jt)=0
13756C...Calculate initial parton distribution weights.
13757 mint(105)=mint(102+jt)
13758 mint(109)=mint(106+jt)
13759 vint(120)=vint(2+jt)
13760 IF(xs(jt).LT.1d0-xee) THEN
13761 IF(mint(31).GE.2) mint(30)=jt
13762 IF(mstp(57).LE.1) THEN
13763 CALL pypdfu(kfbeam(jt),xs(jt),q2s(jt),xfb)
13764 ELSE
13765 CALL pypdfl(kfbeam(jt),xs(jt),q2s(jt),xfb)
13766 ENDIF
13767 ENDIF
13768 DO 110 kfl=-25,25
13769 xfs(jt,kfl)=xfb(kfl)
13770 110 CONTINUE
13771C...Special kinematics check for c/b quarks (that g -> c cbar or
13772C...b bbar kinematically possible).
13773 kflcb=iabs(kfls(jt))
13774 IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5)) THEN
13775 IF(xs(jt).GT.0.9d0*q2s(jt)/(pmas(kflcb,1)**2+q2s(jt))) THEN
13776 mint(51)=1
13777 RETURN
13778 ENDIF
13779 ENDIF
13780 120 CONTINUE
13781 dsh=vint(44)
13782 IF(iset(isub).GE.3.AND.iset(isub).LE.5) dsh=vint(26)*vint(2)
13783
13784C...Find if interference with final state partons.
13785 mfis=0
13786 IF(mstp(67).GE.1.AND.mstp(67).LE.3) mfis=mstp(67)
13787 IF(mfis.NE.0) THEN
13788 DO 140 i=1,2
13789 kcfi(i)=0
13790 kca=pycomp(iabs(kfls(i)))
13791 IF(kca.NE.0) kcfi(i)=kchg(kca,2)*isign(1,kfls(i))
13792 nfis(i)=0
13793 IF(kcfi(i).NE.0) THEN
13794 IF(i.EQ.1) ipfs=ipus1
13795 IF(i.EQ.2) ipfs=ipus2
13796 DO 130 j=1,2
13797 icsi=mod(k(ipfs,3+j),mstu(5))
13798 IF(icsi.GT.0.AND.icsi.NE.ipus1.AND.icsi.NE.ipus2.AND.
13799 & (kcfi(i).EQ.(-1)**(j+1).OR.kcfi(i).EQ.2)) THEN
13800 nfis(i)=nfis(i)+1
13801 thefis(i,nfis(i))=pyangl(p(icsi,3),sqrt(p(icsi,1)**2+
13802 & p(icsi,2)**2))
13803 IF(i.EQ.2) thefis(i,nfis(i))=paru(1)-thefis(i,nfis(i))
13804 ENDIF
13805 130 CONTINUE
13806 ENDIF
13807 140 CONTINUE
13808 IF(nfis(1)+nfis(2).EQ.0) mfis=0
13809 ENDIF
13810
13811C...Pick up leg with highest virtuality.
13812 jtold=1
13813 150 n=n+1
13814 jt=1
13815 IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2
13816 IF(n.EQ.ns+2.AND.jt.EQ.jtold) jt=3-jt
13817 IF(more(jt).EQ.0) jt=3-jt
13818 jtold=jt
13819 kflb=kfls(jt)
13820 xb=xs(jt)
13821 DO 160 kfl=-25,25
13822 xfb(kfl)=xfs(jt,kfl)
13823 160 CONTINUE
13824 dshr=2d0*sqrt(dsh)
13825 dshz=dsh/zs(jt)
13826
13827C...Check if allowed to branch.
13828 mcev=0
13829 IF(iabs(kflb).LE.10.OR.kflb.EQ.21) THEN
13830 mcev=1
13831 xec=max(parp(65)*dshr/vint2r,xb*(1d0/(1d0-parp(66))-1d0))
13832 IF(xb.GE.1d0-2d0*xec) mcev=0
13833 ENDIF
13834 meev=0
13835 IF(mint(44+jt).EQ.3) THEN
13836 meev=1
13837 IF(xb.GE.1d0-2d0*xee) meev=0
13838 IF((iabs(kflb).LE.10.OR.kflb.EQ.21).AND.xb.GE.1d0-2d0*xec)
13839 & meev=0
13840C***Currently kill QED shower for resolved photoproduction.
13841 IF(mint(18+jt).EQ.1) meev=0
13842C***Currently kill shower for W inside electron.
13843 IF(iabs(kflb).EQ.24) THEN
13844 mcev=0
13845 meev=0
13846 ENDIF
13847 ENDIF
13848 IF(mstp(61).GE.2.AND.mcev.EQ.1.AND.meev.EQ.0.AND.iabs(kflb).LE.10)
13849 &meev=2
13850 IF(mcev.EQ.0.AND.meev.EQ.0) THEN
13851 q2b=0d0
13852 GOTO 260
13853 ENDIF
13854
13855C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13856 q2b=q2s(jt)
13857 tevcb=tevcsv(jt)
13858 teveb=tevesv(jt)
13859 IF(mstp(62).LE.1) THEN
13860 IF(zs(jt).GT.0.99999d0) THEN
13861 q2b=q2s(jt)
13862 ELSE
13863 q2b=0.5d0*(1d0/zs(jt)+1d0)*q2s(jt)+0.5d0*(1d0/zs(jt)-1d0)*
13864 & (q2s(3-jt)-dsh+sqrt((dsh+q2s(1)+q2s(2))**2+
13865 & 8d0*q2s(1)*q2s(2)*zs(jt)/(1d0-zs(jt))))
13866 ENDIF
13867 IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
13868 IF(meev.EQ.1) teveb=log(q2b/spme)
13869 ENDIF
13870 IF(mcev.EQ.1) THEN
13871 alsdum=pyalps(fq2c*q2b)
13872 tevcb=tevcb+2d0*log(alam(jt)/paru(117))
13873 alam(jt)=paru(117)
13874 b0=(33d0-2d0*mstu(118))/6d0
13875 ENDIF
13876 IF(meev.EQ.2) teveb=tevcb
13877 tevcbs=tevcb
13878 tevebs=teveb
13879
13880C...Select side for interference with final state partons.
13881 IF(mfis.GE.1.AND.n.LE.ns+2) THEN
13882 ifi=n-ns
13883 isfi(ifi)=0
13884 IF(iabs(kcfi(ifi)).EQ.1.AND.nfis(ifi).EQ.1) THEN
13885 isfi(ifi)=1
13886 ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.1) THEN
13887 IF(pyr(0).GT.0.5d0) isfi(ifi)=1
13888 ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.2) THEN
13889 isfi(ifi)=1
13890 IF(pyr(0).GT.0.5d0) isfi(ifi)=2
13891 ENDIF
13892 ENDIF
13893
13894C...Calculate preweighting factor for ME-corrected processes.
13895 IF(mecor.GE.1) CALL pymemx(mecor,wtff,wtgf,wtfg,wtgg)
13896
13897C...Calculate Altarelli-Parisi weights.
13898 DO 170 kfl=-25,25
13899 wtapc(kfl)=0d0
13900 wtape(kfl)=0d0
13901 wtsf(kfl)=0d0
13902 170 CONTINUE
13903C...q -> q (g or gamma emission), g -> q.
13904 IF(iabs(kflb).LE.10) THEN
13905 wtapc(kflb)=(8d0/3d0)*log((1d0-xec-xb)*(xb+xec)/(xec*(1d0-xec)))
13906 wtapc(21)=0.5d0*(xb/(xb+xec)-xb/(1d0-xec))
13907 eq2=1d0/9d0
13908 IF(mod(iabs(kflb),2).EQ.0) eq2=4d0*eq2
13909 IF(meev.EQ.2) wtape(kflb)=2.*eq2*log((1d0-xec-xb)*(xb+xec)/
13910 & (xec*(1d0-xec)))
13911 IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
13912 wtapc(kflb)=wtff*wtapc(kflb)
13913 wtapc(21)=wtgf*wtapc(21)
13914 wtape(kflb)=wtff*wtape(kflb)
13915 ENDIF
13916C...f -> f, gamma -> f.
13917 ELSEIF(iabs(kflb).LE.20) THEN
13918 wtapf1=log((1d0-xee-xb)*(xb+xee)/(xee*(1d0-xee)))
13919 wtapf2=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))
13920 wtape(kflb)=2d0*(wtapf1+wtapf2)
13921 IF(mstp(12).GE.1) wtape(22)=xb/(xb+xee)-xb/(1d0-xee)
13922 IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
13923 wtape(kflb)=wtff*wtape(kflb)
13924 wtape(22)=wtgf*wtape(22)
13925 ENDIF
13926C...f -> g, g -> g.
13927 ELSEIF(kflb.EQ.21) THEN
13928 wtapq=(16d0/3d0)*(sqrt((1d0-xec)/xb)-sqrt((xb+xec)/xb))
13929 DO 180 kfl=1,mstp(58)
13930 wtapc(kfl)=wtapq
13931 wtapc(-kfl)=wtapq
13932 180 CONTINUE
13933 wtapc(21)=6d0*log((1d0-xec-xb)/xec)
13934 IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
13935 DO 190 kfl=1,mstp(58)
13936 wtapc(kfl)=wtfg*wtapc(kfl)
13937 wtapc(-kfl)=wtfg*wtapc(-kfl)
13938 190 CONTINUE
13939 wtapc(21)=wtgg*wtapc(21)
13940 ENDIF
13941C...f -> gamma, W+, W-.
13942 ELSEIF(kflb.EQ.22) THEN
13943 wtapf=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))/xb
13944 wtape(11)=wtapf
13945 wtape(-11)=wtapf
13946 IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
13947 wtape(11)=wtfg*wtape(11)
13948 wtape(-11)=wtfg*wtape(-11)
13949 ENDIF
13950 ELSEIF(kflb.EQ.24) THEN
13951 wtape(-11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
13952 & (xee*(xb+xee)))/xb
13953 ELSEIF(kflb.EQ.-24) THEN
13954 wtape(11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/
13955 & (xee*(xb+xee)))/xb
13956 ENDIF
13957
13958C...Calculate parton distribution weights and sum.
13959 ntry=0
13960 200 ntry=ntry+1
13961 IF(ntry.GT.500) THEN
13962 mint(51)=1
13963 RETURN
13964 ENDIF
13965 wtsumc=0d0
13966 wtsume=0d0
13967 xfbo=max(1d-10,xfb(kflb))
13968 DO 210 kfl=-25,25
13969 wtsf(kfl)=xfb(kfl)/xfbo
13970 wtsumc=wtsumc+wtapc(kfl)*wtsf(kfl)
13971 wtsume=wtsume+wtape(kfl)*wtsf(kfl)
13972 210 CONTINUE
13973 wtsumc=max(0.0001d0,wtsumc)
13974 wtsume=max(0.0001d0/fwte,wtsume)
13975
13976C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13977 ntry2=0
13978 220 ntry2=ntry2+1
13979 IF(ntry2.GT.500) THEN
13980 mint(51)=1
13981 RETURN
13982 ENDIF
13983 IF(mcev.EQ.1) THEN
13984 IF(mstp(64).LE.0) THEN
13985 tevcb=tevcb+log(pyr(0))*paru(2)/(paru(111)*wtsumc)
13986 ELSEIF(mstp(64).EQ.1) THEN
13987 tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/wtsumc))
13988 ELSE
13989 tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/(5d0*wtsumc)))
13990 ENDIF
13991 ENDIF
13992 IF(meev.EQ.1) THEN
13993 teveb=teveb*exp(max(-50d0,log(pyr(0))*paru(2)/
13994 & (paru(101)*fwte*wtsume*temx)))
13995 ELSEIF(meev.EQ.2) THEN
13996 teveb=teveb+log(pyr(0))*paru(2)/(paru(101)*wtsume)
13997 ENDIF
13998
13999C...Translate t into Q2 scale; choose between QCD and QED evolution.
14000 230 IF(mcev.EQ.1) q2cb=alam(jt)**2*exp(max(-50d0,tevcb))/fq2c
14001 IF(meev.EQ.1) q2eb=spme*exp(max(-50d0,teveb))
14002 IF(meev.EQ.2) q2eb=alam(jt)**2*exp(max(-50d0,teveb))/fq2c
14003C...Ensure that Q2 is above threshold for charm/bottom.
14004 kflcb=iabs(kflb)
14005 IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5).AND.
14006 &mcev.EQ.1) THEN
14007 IF(q2cb.LT.pmas(kflcb,1)**2) THEN
14008 q2cb=1.1d0*pmas(kflcb,1)**2
14009 tevcb=log(fq2c*q2b/alam(jt)**2)
14010 fcq2mx=min(2d0,1.05d0*fcq2mx)
14011 ENDIF
14012 ENDIF
14013 IF(kfbeam(jt).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5).AND.
14014 &meev.EQ.2) THEN
14015 IF(q2eb.LT.pmas(kflcb,1)**2) meev=0
14016 ENDIF
14017 mce=0
14018 IF(mcev.EQ.0.AND.meev.EQ.0) THEN
14019 ELSEIF(mcev.EQ.1.AND.meev.EQ.0) THEN
14020 IF(q2cb.GT.q2mncs(jt)) mce=1
14021 ELSEIF(mcev.EQ.0.AND.meev.EQ.1) THEN
14022 IF(q2eb.GT.q2mne) mce=2
14023 ELSEIF(mcev.EQ.0.AND.meev.EQ.2) THEN
14024 IF(q2eb.GT.q2mncs(jt)) mce=2
14025 ELSEIF(mcev.EQ.1.AND.meev.EQ.2) THEN
14026 IF(q2cb.GT.q2eb.AND.q2cb.GT.q2mncs(jt)) mce=1
14027 IF(q2eb.GT.q2cb.AND.q2eb.GT.q2mncs(jt)) mce=2
14028 ELSEIF(q2mncs(jt).GT.q2mne) THEN
14029 mce=1
14030 IF(q2eb.GT.q2cb.OR.q2cb.LE.q2mncs(jt)) mce=2
14031 IF(mce.EQ.2.AND.q2eb.LE.q2mne) mce=0
14032 ELSE
14033 mce=2
14034 IF(q2cb.GT.q2eb.OR.q2eb.LE.q2mne) mce=1
14035 IF(mce.EQ.1.AND.q2cb.LE.q2mncs(jt)) mce=0
14036 ENDIF
14037
14038C...Evolution possibly ended. Update t values.
14039 IF(mce.EQ.0) THEN
14040 q2b=0d0
14041 GOTO 260
14042 ELSEIF(mce.EQ.1) THEN
14043 q2b=q2cb
14044 q2ref=fq2c*q2b
14045 IF(meev.EQ.1) teveb=log(q2b/spme)
14046 IF(meev.EQ.2) teveb=log(fq2c*q2b/alam(jt)**2)
14047 ELSE
14048 q2b=q2eb
14049 q2ref=q2b
14050 IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)
14051 ENDIF
14052
14053C...Select flavour for branching parton.
14054 IF(mce.EQ.1) wtran=pyr(0)*wtsumc
14055 IF(mce.EQ.2) wtran=pyr(0)*wtsume
14056 kfla=-25
14057 240 kfla=kfla+1
14058 IF(mce.EQ.1) wtran=wtran-wtapc(kfla)*wtsf(kfla)
14059 IF(mce.EQ.2) wtran=wtran-wtape(kfla)*wtsf(kfla)
14060 IF(kfla.LE.24.AND.wtran.GT.0d0) GOTO 240
14061 IF(kfla.EQ.25) THEN
14062 q2b=0d0
14063 GOTO 260
14064 ENDIF
14065
14066C...Choose z value and corrective weight.
14067 wtz=0d0
14068C...q -> q + g or q -> q + gamma.
14069 IF(iabs(kfla).LE.10.AND.iabs(kflb).LE.10) THEN
14070 z=1d0-((1d0-xb-xec)/(1d0-xec))*
14071 & (xec*(1d0-xec)/((xb+xec)*(1d0-xb-xec)))**pyr(0)
14072 wtz=0.5d0*(1d0+z**2)
14073C...q -> g + q.
14074 ELSEIF(iabs(kfla).LE.10.AND.kflb.EQ.21) THEN
14075 z=xb/(sqrt(xb+xec)+pyr(0)*(sqrt(1d0-xec)-sqrt(xb+xec)))**2
14076 wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)
14077C...f -> f + gamma.
14078 ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
14079 IF(wtapf1.GT.pyr(0)*(wtapf1+wtapf2)) THEN
14080 z=1d0-((1d0-xb-xee)/(1d0-xee))*
14081 & (xee*(1d0-xee)/((xb+xee)*(1d0-xb-xee)))**pyr(0)
14082 ELSE
14083 z=xb+xb*(xee/(1d0-xee))*
14084 & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14085 ENDIF
14086 wtz=0.5d0*(1d0+z**2)*(z-xb)/(1d0-xb)
14087C...f -> gamma + f.
14088 ELSEIF(iabs(kfla).LE.20.AND.kflb.EQ.22) THEN
14089 z=xb+xb*(xee/(1d0-xee))*
14090 & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14091 wtz=0.5d0*(1d0+(1d0-z)**2)*xb*(z-xb)/z
14092C...f -> W+- + f.
14093 ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).EQ.24) THEN
14094 z=xb+xb*(xee/(1d0-xee))*
14095 & ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)
14096 wtz=0.5d0*(1d0+(1d0-z)**2)*(xb*(z-xb)/z)*
14097 & (q2b/(q2b+pmas(24,1)**2))
14098C...g -> q + qbar.
14099 ELSEIF(kfla.EQ.21.AND.iabs(kflb).LE.10) THEN
14100 z=xb/(1d0-xec)+pyr(0)*(xb/(xb+xec)-xb/(1d0-xec))
14101 wtz=1d0-2d0*z*(1d0-z)
14102C...g -> g + g.
14103 ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
14104 z=1d0/(1d0+((1d0-xec-xb)/xb)*(xec/(1d0-xec-xb))**pyr(0))
14105 wtz=(1d0-z*(1d0-z))**2
14106C...gamma -> f + fbar.
14107 ELSEIF(kfla.EQ.22.AND.iabs(kflb).LE.20) THEN
14108 z=xb/(1d0-xee)+pyr(0)*(xb/(xb+xee)-xb/(1d0-xee))
14109 wtz=1d0-2d0*z*(1d0-z)
14110 ENDIF
14111 IF(mce.EQ.2.AND.meev.EQ.1) wtz=(wtz/fwte)*(teveb/temx)
14112
14113C...Option with resummation of soft gluon emission as effective z shift.
14114 IF(mce.EQ.1) THEN
14115 IF(mstp(65).GE.1) THEN
14116 rsoft=6d0
14117 IF(kflb.NE.21) rsoft=8d0/3d0
14118 z=z*(tevcb/tevcsv(jt))**(rsoft*xec/((xb+xec)*b0))
14119 IF(z.LE.xb) GOTO 220
14120 ENDIF
14121
14122C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14123 IF(mstp(64).GE.2) THEN
14124 IF((1d0-z)*q2b.LT.q2mncs(jt)) GOTO 220
14125 alprat=tevcb/(tevcb+log(1d0-z))
14126 IF(alprat.LT.5d0*pyr(0)) GOTO 220
14127 IF(alprat.GT.5d0) wtz=wtz*alprat/5d0
14128 ENDIF
14129 ENDIF
14130
14131C...Remove kinematically impossible branchings.
14132 uhat=q2b-dsh*(1d0-z)/z
14133 IF(mstp(68).GE.0.AND.uhat.GT.0d0) GOTO 220
14134
14135C...Select phi angle of branching at random.
14136 phibr=paru(2)*pyr(0)
14137
14138C...Matrix-element corrections for some processes.
14139 IF(mecor.GE.1.AND.(n.EQ.ns+1.OR.n.EQ.ns+2)) THEN
14140 IF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN
14141 CALL pymewt(mecor,1,q2b,z,phibr,wtme)
14142 wtz=wtz*wtme/wtff
14143 ELSEIF((kfla.EQ.21.OR.kfla.EQ.22).AND.iabs(kflb).LE.20) THEN
14144 CALL pymewt(mecor,2,q2b,z,phibr,wtme)
14145 wtz=wtz*wtme/wtgf
14146 ELSEIF(iabs(kfla).LE.20.AND.(kflb.EQ.21.OR.kflb.EQ.22)) THEN
14147 CALL pymewt(mecor,3,q2b,z,phibr,wtme)
14148 wtz=wtz*wtme/wtfg
14149 ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
14150 CALL pymewt(mecor,4,q2b,z,phibr,wtme)
14151 wtz=wtz*wtme/wtgg
14152 ENDIF
14153 ENDIF
14154
14155C...Impose angular constraint in first branching from interference
14156C...with final state partons.
14157 IF(mce.EQ.1) THEN
14158 IF(mfis.GE.1.AND.n.LE.ns+2.AND.ntry2.LT.200) THEN
14159 the2d=(4d0*q2b)/(dsh*(1d0-z))
14160 IF(n.EQ.ns+1.AND.isfi(1).GE.1) THEN
14161 IF(the2d.GT.thefis(1,isfi(1))**2) GOTO 220
14162 ELSEIF(n.EQ.ns+2.AND.isfi(2).GE.1) THEN
14163 IF(the2d.GT.thefis(2,isfi(2))**2) GOTO 220
14164 ENDIF
14165 ENDIF
14166
14167C...Option with angular ordering requirement.
14168 IF(mstp(62).GE.3.AND.ntry2.LT.200) THEN
14169 the2t=(4d0*z**2*q2b)/(4d0*z**2*q2b+(1d0-z)*xb**2*vint2r)
14170 IF(the2t.GT.the2(jt)) GOTO 220
14171 ENDIF
14172 ENDIF
14173
14174C...Weighting with new parton distributions.
14175 mint(105)=mint(102+jt)
14176 mint(109)=mint(106+jt)
14177 vint(120)=vint(2+jt)
14178 IF(mint(31).GE.2) mint(30)=jt
14179 IF(mstp(57).LE.1) THEN
14180 CALL pypdfu(kfbeam(jt),xb,q2ref,xfn)
14181 ELSE
14182 CALL pypdfl(kfbeam(jt),xb,q2ref,xfn)
14183 ENDIF
14184 xfbn=xfn(kflb)
14185 IF(xfbn.LT.1d-20) THEN
14186 IF(kfla.EQ.kflb) THEN
14187 tevcb=tevcbs
14188 teveb=tevebs
14189 wtapc(kflb)=0d0
14190 wtape(kflb)=0d0
14191 GOTO 200
14192 ELSEIF(mce.EQ.1.AND.tevcbs-tevcb.GT.0.2d0) THEN
14193 tevcb=0.5d0*(tevcbs+tevcb)
14194 GOTO 230
14195 ELSEIF(mce.EQ.2.AND.tevebs-teveb.GT.0.2d0) THEN
14196 teveb=0.5d0*(tevebs+teveb)
14197 GOTO 230
14198 ELSE
14199 xfbn=1d-10
14200 xfn(kflb)=xfbn
14201 ENDIF
14202 ENDIF
14203 DO 250 kfl=-25,25
14204 xfb(kfl)=xfn(kfl)
14205 250 CONTINUE
14206 xa=xb/z
14207 IF(mint(31).GE.2) mint(30)=jt
14208 IF(mstp(57).LE.1) THEN
14209 CALL pypdfu(kfbeam(jt),xa,q2ref,xfa)
14210 ELSE
14211 CALL pypdfl(kfbeam(jt),xa,q2ref,xfa)
14212 ENDIF
14213 xfan=xfa(kfla)
14214 IF(xfan.LT.1d-20) GOTO 200
14215 wtsfa=wtsf(kfla)
14216 IF(wtz*xfan/xfbn.LT.pyr(0)*wtsfa) GOTO 200
14217
14218C...Define two hard scatterers in their CM-frame.
14219 260 IF(n.EQ.ns+2) THEN
14220 dq2(jt)=q2b
14221 dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr
14222 DO 280 jr=1,2
14223 i=ns+jr
14224 IF(jr.EQ.1) ipo=ipus1
14225 IF(jr.EQ.2) ipo=ipus2
14226 DO 270 j=1,5
14227 k(i,j)=0
14228 p(i,j)=0d0
14229 v(i,j)=0d0
14230 270 CONTINUE
14231 k(i,1)=14
14232 k(i,2)=kfls(jr+2)
14233 k(i,4)=ipo
14234 k(i,5)=ipo
14235 p(i,3)=dplcm*(-1)**(jr+1)
14236 p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr
14237 p(i,5)=-sqrt(dq2(jr))
14238 k(ipo,1)=14
14239 k(ipo,3)=i
14240 k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i
14241 k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i
14242 mct(i,1)=mct(ipo,1)
14243 mct(i,2)=mct(ipo,2)
14244 280 CONTINUE
14245
14246C...Find maximum allowed mass of timelike parton.
14247 ELSEIF(n.GT.ns+2) THEN
14248 jr=3-jt
14249 dq2(3)=q2b
14250 dpc(1)=p(is(1),4)
14251 dpc(2)=p(is(2),4)
14252 dpc(3)=0.5d0*(abs(p(is(1),3))+abs(p(is(2),3)))
14253 dpd(1)=dsh+dq2(jr)+dq2(jt)
14254 dpd(2)=dshz+dq2(jr)+dq2(3)
14255 dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))
14256 dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))
14257 ikin=0
14258 IF(q2s(jr).GE.0.25d0*q2mnc.AND.dpd(1)-dpd(3).GE.
14259 & 1d-10*dpd(1)) ikin=1
14260 IF(ikin.EQ.0) dmsma=(dq2(jt)/zs(jt)-dq2(3))*
14261 & (dsh/(dsh+dq2(jt))-dsh/(dshz+dq2(3)))
14262 IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/
14263 & (2d0*dq2(jr))-dq2(jt)-dq2(3)
14264
14265C...Generate timelike parton shower (if required).
14266 it=n
14267 DO 290 j=1,5
14268 k(it,j)=0
14269 p(it,j)=0d0
14270 v(it,j)=0d0
14271 290 CONTINUE
14272C...f -> f + g (gamma).
14273 IF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).LE.20) THEN
14274 k(it,2)=21
14275 IF(mcesv(jt).EQ.2.OR.iabs(kflb).GE.11) k(it,2)=22
14276C...f -> g (gamma, W+-) + f.
14277 ELSEIF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).GT.20) THEN
14278 k(it,2)=kflb
14279 IF(kfls(jt+2).EQ.24) THEN
14280 k(it,2)=-12
14281 ELSEIF(kfls(jt+2).EQ.-24) THEN
14282 k(it,2)=12
14283 ENDIF
14284C...g (gamma) -> f + fbar, g + g.
14285 ELSE
14286 k(it,2)=-kfls(jt+2)
14287 IF(kfls(jt+2).GT.20) k(it,2)=kfls(jt+2)
14288 ENDIF
14289 k(it,1)=3
14290 IF((iabs(k(it,2)).GE.11.AND.iabs(k(it,2)).LE.18).OR.
14291 & iabs(k(it,2)).EQ.22) k(it,1)=1
14292 p(it,5)=pymass(k(it,2))
14293 IF(dmsma.LE.p(it,5)**2) GOTO 100
14294 IF(mstp(63).GE.1.AND.mcesv(jt).EQ.1) THEN
14295 mstj48=mstj(48)
14296 parj85=parj(85)
14297 p(it,4)=(dshz-dsh-p(it,5)**2)/dshr
14298 p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)
14299 IF(mstp(63).EQ.1) THEN
14300 q2tim=dmsma
14301 ELSEIF(mstp(63).EQ.2) THEN
14302 q2tim=min(dmsma,parp(71)*q2s(jt))
14303 ELSE
14304 q2tim=dmsma
14305 mstj(48)=1
14306 IF(ikin.EQ.0) dpt2=dmsma*(dshz+dq2(3))/(dsh+dq2(jt))
14307 IF(ikin.EQ.1) dpt2=dmsma*(0.5d0*dpd(1)*dpd(2)+0.5d0*dpd(3)*
14308 & dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)))/(4d0*dsh*dpc(3)**2)
14309 parj(85)=sqrt(max(0d0,dpt2))*
14310 & (1d0/p(it,4)+1d0/p(is(jt),4))
14311 ENDIF
14312C...Only do timelike shower here if using PYSHOW
14313 IF (mstj(41).NE.11.AND.mstj(41).NE.12) THEN
14314 CALL pyshow(it,0,sqrt(q2tim))
14315 ENDIF
14316 mstj(48)=mstj48
14317 parj(85)=parj85
14318 IF(n.GE.it+1) p(it,5)=p(it+1,5)
14319 ENDIF
14320
14321C...Reconstruct kinematics of branching: timelike parton shower.
14322 dms=p(it,5)**2
14323 IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))
14324 IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5d0*dpd(1)*dpd(2)+
14325 & 0.5d0*dpd(3)*dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/
14326 & (4d0*dsh*dpc(3)**2)
14327 IF(dpt2.LT.0d0) GOTO 100
14328 dpb(1)=(0.5d0*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/
14329 & dshr)/dpc(3)-dpc(3)
14330 p(it,1)=sqrt(dpt2)
14331 p(it,3)=dpb(1)*(-1)**(jt+1)
14332 p(it,4)=sqrt(dpt2+dpb(1)**2+dms)
14333 IF(n.GE.it+1) THEN
14334 dpb(1)=sqrt(dpb(1)**2+dpt2)
14335 dpb(2)=sqrt(dpb(1)**2+dms)
14336 dpb(3)=p(it+1,3)
14337 dpb(4)=sqrt(dpb(3)**2+dms)
14338 dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)*
14339 & dpb(1))
14340 CALL pyrobo(it+1,n,0d0,0d0,0d0,0d0,dbez)
14341 the=pyangl(p(it,3),p(it,1))
14342 CALL pyrobo(it+1,n,the,0d0,0d0,0d0,0d0)
14343 ENDIF
14344
14345C...Reconstruct kinematics of branching: spacelike parton.
14346 DO 300 j=1,5
14347 k(n+1,j)=0
14348 p(n+1,j)=0d0
14349 v(n+1,j)=0d0
14350 300 CONTINUE
14351 k(n+1,1)=14
14352 k(n+1,2)=kflb
14353 p(n+1,1)=p(it,1)
14354 p(n+1,3)=p(it,3)+p(is(jt),3)
14355 p(n+1,4)=p(it,4)+p(is(jt),4)
14356 p(n+1,5)=-sqrt(dq2(3))
14357 mct(n+1,1)=0
14358 mct(n+1,2)=0
14359
14360C...Define colour flow of branching.
14361 k(is(jt),3)=n+1
14362 k(it,3)=n+1
14363 im1=n+1
14364 im2=n+1
14365C...f -> f + gamma (Z, W).
14366 IF(iabs(k(it,2)).GE.22) THEN
14367 k(it,1)=1
14368 id1=is(jt)
14369 id2=is(jt)
14370C...f -> gamma (Z, W) + f.
14371 ELSEIF(iabs(k(is(jt),2)).GE.22) THEN
14372 id1=it
14373 id2=it
14374C...gamma -> q + qbar, g + g.
14375 ELSEIF(k(n+1,2).EQ.22) THEN
14376 id1=is(jt)
14377 id2=it
14378 im1=id2
14379 im2=id1
14380C...q -> q + g.
14381 ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(it,2).EQ.21) THEN
14382 id1=it
14383 id2=is(jt)
14384C...q -> g + q.
14385 ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21) THEN
14386 id1=is(jt)
14387 id2=it
14388C...qbar -> qbar + g.
14389 ELSEIF(k(n+1,2).LT.0.AND.k(it,2).EQ.21) THEN
14390 id1=is(jt)
14391 id2=it
14392C...qbar -> g + qbar.
14393 ELSEIF(k(n+1,2).LT.0) THEN
14394 id1=it
14395 id2=is(jt)
14396C...g -> g + g; g -> q + qbar.
14397 ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN
14398 id1=is(jt)
14399 id2=it
14400 ELSE
14401 id1=it
14402 id2=is(jt)
14403 ENDIF
14404 IF(im1.EQ.n+1) k(im1,4)=k(im1,4)+id1
14405 IF(im2.EQ.n+1) k(im2,5)=k(im2,5)+id2
14406 k(id1,4)=k(id1,4)+mstu(5)*im1
14407 k(id2,5)=k(id2,5)+mstu(5)*im2
14408 IF(id1.NE.id2) THEN
14409 k(id1,5)=k(id1,5)+mstu(5)*id2
14410 k(id2,4)=k(id2,4)+mstu(5)*id1
14411 ENDIF
14412 n=n+1
14413 IF(k(it,1).EQ.1) THEN
14414 k(it,4)=0
14415 k(it,5)=0
14416 ENDIF
14417
14418C...Boost to new CM-frame.
14419 dbsvx=(p(n,1)+p(is(jr),1))/(p(n,4)+p(is(jr),4))
14420 dbsvz=(p(n,3)+p(is(jr),3))/(p(n,4)+p(is(jr),4))
14421 IF(dbsvx**2+dbsvz**2.GE.1d0) GOTO 100
14422 CALL pyrobo(ns+1,n,0d0,0d0,-dbsvx,0d0,-dbsvz)
14423 ir=n+(jt-1)*(is(1)-n)
14424 CALL pyrobo(ns+1,n,-pyangl(p(ir,3),p(ir,1)),dphi(jt),
14425 & 0d0,0d0,0d0)
14426
14427C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14428 IF (mstj(41).EQ.11.OR.mstj(41).EQ.12) THEN
14429 npart=npart+1
14430 ipart(npart)=it
14431 ptpart(npart)=sqrt(parp(71)*dpt2)
14432 ENDIF
14433
14434C...Global statistics.
14435 mint(352)=mint(352)+1
14436 vint(352)=vint(352)+sqrt(p(it,1)**2+p(it,2)**2)
14437 IF (mint(352).EQ.1) vint(357)=sqrt(p(it,1)**2+p(it,2)**2)
14438
14439 ENDIF
14440
14441C...Update kinematics variables.
14442 is(jt)=n
14443 dq2(jt)=q2b
14444 IF(mstp(62).GE.3.AND.ntry2.LT.200.AND.mce.EQ.1) the2(jt)=the2t
14445 dsh=dshz
14446
14447C...Save quantities; loop back.
14448 q2s(jt)=q2b
14449 dphi(jt)=phibr
14450 mcesv(jt)=mce
14451 IF((mcev.EQ.1.AND.q2b.GE.0.25d0*q2mnc).OR.
14452 &(meev.EQ.1.AND.q2b.GE.q2mne)) THEN
14453 kfls(jt+2)=kfls(jt)
14454 kfls(jt)=kfla
14455 xs(jt)=xa
14456 zs(jt)=z
14457 DO 310 kfl=-25,25
14458 xfs(jt,kfl)=xfa(kfl)
14459 310 CONTINUE
14460 tevcsv(jt)=tevcb
14461 tevesv(jt)=teveb
14462 ELSE
14463 more(jt)=0
14464 IF(jt.EQ.1) ipu1=n
14465 IF(jt.EQ.2) ipu2=n
14466 ENDIF
14467 IF(n.GT.mstu(4)-mstu(32)-10) THEN
14468 CALL pyerrm(11,'(PYSSPA:) no more memory left in PYJETS')
14469 IF(mstu(21).GE.1) n=ns
14470 IF(mstu(21).GE.1) RETURN
14471 ENDIF
14472 IF(more(1).EQ.1.OR.more(2).EQ.1) GOTO 150
14473
14474C...Boost hard scattering partons to frame of shower initiators.
14475 DO 320 j=1,3
14476 robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4))
14477 320 CONTINUE
14478 k(n+2,1)=1
14479 DO 330 j=1,5
14480 p(n+2,j)=p(ns+1,j)
14481 330 CONTINUE
14482 CALL pyrobo(n+2,n+2,0d0,0d0,-robo(3),-robo(4),-robo(5))
14483 robo(2)=pyangl(p(n+2,1),p(n+2,2))
14484 robo(1)=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
14485 imin=mint(83)+5
14486 IF(mint(31).GE.2) imin=min(ipus1,ipus2)
14487 CALL pyrobo(imin,ns,0d0,-robo(2),0d0,0d0,0d0)
14488 CALL pyrobo(imin,ns,robo(1),robo(2),robo(3),robo(4),robo(5))
14489
14490C...Store user information. Reset Lambda value.
14491 IF(mint(31).LE.1) THEN
14492 k(ipu1,3)=mint(83)+3
14493 k(ipu2,3)=mint(83)+4
14494 ELSE
14495 k(ipu1,3)=mint(83)+1
14496 k(ipu2,3)=mint(83)+2
14497 ENDIF
14498 DO 340 jt=1,2
14499 mint(12+jt)=kfls(jt)
14500 vint(140+jt)=xs(jt)
14501 IF(mint(18+jt).EQ.1) vint(140+jt)=vint(154+jt)*xs(jt)
14502 IF(mint(31).GE.2) vint(140+jt)=vint(140+jt)*vint(142+jt)
14503 340 CONTINUE
14504 paru(112)=alams
14505
14506 RETURN
14507 END
14508
14509C*********************************************************************
14510
14511C...PYPTIS
14512C...Generates pT-ordered spacelike initial-state parton showers and
14513C...trial joinings.
14514C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14515C... interaction initiators at PT2NOW.
14516C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14517C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14518C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14519C... is below PT2CUT.
14520C... (Also generate test joinings if MSTP(96)=1.)
14521C...MODE= 1: Accept stored shower branching. Update event record etc.
14522C...PT2NOW : Starting (max) PT2 scale for evolution.
14523C...PT2CUT : Lower limit for evolution.
14524C...PT2 : Result of evolution. Generated PT2 for trial emission.
14525C...IFAIL : Status return code. IFAIL=0 when all is well.
14526
14527 SUBROUTINE pyptis(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14528
14529C...Double precision and integer declarations.
14530 IMPLICIT DOUBLE PRECISION(a-h, o-z)
14531 IMPLICIT INTEGER(I-N)
14532 INTEGER PYK,PYCHGE,PYCOMP
14533C...Parameter statement for maximum size of showers.
14534 parameter(maxnur=1000)
14535C...Commonblocks.
14536 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
14537 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
14538 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
14539 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
14540 common/pypars/mstp(200),parp(200),msti(200),pari(200)
14541 common/pyint1/mint(400),vint(400)
14542 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
14543 common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
14544 & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
14545 & xmi(2,240),pt2mi(240),imisep(0:240)
14546 common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
14547 & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
14548 common/pyctag/nct,mct(4000,2)
14549 common/pyisjn/mjn1mx,mjn2mx,mjoind(2,240)
14550 SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,
14551 & /pyint2/,/pyintm/,/pyismx/,/pyctag/,/pyisjn/
14552C...Local variables
14553 dimension zsav(2,240),pt2sav(2,240),
14554 & xfb(-25:25),xfa(-25:25),xfn(-25:25),xfj(-25:25),
14555 & wtap(-25:25),wtpdf(-25:25),shtnow(240),
14556 & wtapj(240),wtpdfj(240),x1(240),y(240)
14557 SAVE zsav,pt2sav,xfb,xfa,xfn,wtap,wtpdf,xmxc,shtnow,
14558 & rmb2,rmc2,alam3,alam4,alam5,tmin,ptemax,wtemax,aem2pi
14559C...For check on excessive weights.
14560 CHARACTER CHWT*12
14561
14562C...Only give errors for very large weights, otherwise just warnings
14563 DATA wtemax /1.5d0/
14564C...Only give errors for large pT, otherwise just warnings
14565 DATA ptemax /5d0/
14566
14567 ifail=-1
14568
14569C----------------------------------------------------------------------
14570C...MODE=-1: Initialize initial state showers from scratch, i.e.
14571C...starting from the hardest interaction initiators.
14572 IF (mode.EQ.-1) THEN
14573C...Set hard scattering SHAT.
14574 shtnow(1)=vint(44)
14575C...Mass thresholds and Lambda for QCD evolution.
14576 aem2pi=paru(101)/paru(2)
14577 rmb=pmas(5,1)
14578 rmc=pmas(4,1)
14579 alam4=parp(61)
14580 IF(mstu(112).LT.4) alam4=parp(61)*(parp(61)/rmc)**(2d0/25d0)
14581 IF(mstu(112).GT.4) alam4=parp(61)*(rmb/parp(61))**(2d0/25d0)
14582 alam5=alam4*(alam4/rmb)**(2d0/23d0)
14583 alam3=alam4*(rmc/alam4)**(2d0/27d0)
14584C...Optionally use Lambda_MC = Lambda_CMW
14585 IF (mstp(64).EQ.3) THEN
14586 alam5 = alam5 * 1.569
14587 alam4 = alam4 * 1.618
14588 alam3 = alam3 * 1.661
14589 ENDIF
14590 rmb2=rmb**2
14591 rmc2=rmc**2
14592C...Massive quark forced creation threshold (in M**2).
14593 tmin=1.01d0
14594C...Set upper limit for X (ensures some X left for beam remnant).
14595 xmxc=1d0-2d0*parp(111)/vint(1)
14596
14597 IF (mstp(61).GE.1) THEN
14598C...Initial values: flavours, momenta, virtualities.
14599 DO 100 js=1,2
14600 nisgen(js,1)=0
14601
14602C...Special kinematics check for c/b quarks (that g -> c cbar or
14603C...b bbar kinematically possible).
14604 kflb=k(imi(js,1,1),2)
14605 kflcb=iabs(kflb)
14606 IF(kfbeam(js).NE.22.AND.(kflcb.EQ.4.OR.kflcb.EQ.5)) THEN
14607C...Check PT2MAX > mQ^2
14608 IF (vint(56).LT.1.05d0*pmas(pycomp(kflcb),1)**2) THEN
14609 CALL pyerrm(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14610 & 'No Q creation possible.')
14611 mint(51)=1
14612 RETURN
14613 ELSE
14614C...Check for physical z values (m == MQ / sqrt(s))
14615C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14616 fmq=pmas(kflcb,1)/sqrt(shtnow(1))
14617 zmxcr=(1d0-fmq)/(1d0+fmq*(1d0-fmq))
14618 IF (xmi(js,1).GT.0.9d0*zmxcr) THEN
14619 CALL pyerrm(9,'(PYPTIS:) No physical z value for '//
14620 & 'Q creation.')
14621 mint(51)=1
14622 RETURN
14623 ENDIF
14624 ENDIF
14625 ENDIF
14626 100 CONTINUE
14627 ENDIF
14628
14629 mint(354)=0
14630C...Zero joining array
14631 DO 110 mj=1,240
14632 mjoind(1,mj)=0
14633 mjoind(2,mj)=0
14634 110 CONTINUE
14635
14636C----------------------------------------------------------------------
14637C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14638C...MINT(30). Store if emission PT2 scale is largest so far.
14639C...Also generate test joinings if MSTP(96)=1.
14640 ELSEIF(mode.EQ.0) THEN
14641 ifail=-1
14642 mecor=0
14643 isub=mint(1)
14644 js=mint(30)
14645C...No shower for structureless beam
14646 IF (mint(44+js).EQ.1) RETURN
14647 mi=mint(36)
14648 shat=vint(44)
14649C...Absolute shower max scale = VINT(56)
14650 pt2=min(pt2now,vint(56))
14651 IF (nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) shtnow(mi)=shat
14652C...Define for which processes ME corrections have been implemented.
14653 IF(mstp(68).EQ.1.OR.mstp(68).EQ.3) THEN
14654 IF(isub.EQ.1.OR.isub.EQ.2.OR.isub.EQ.141.OR.isub.eq
14655 & .142.OR.isub.EQ.144) mecor=1
14656 IF(isub.EQ.102.OR.isub.EQ.152.OR.isub.EQ.157) mecor=2
14657 IF(isub.EQ.3.OR.isub.EQ.151.OR.isub.EQ.156) mecor=3
14658C...Calculate preweighting factor for ME-corrected processes.
14659 IF(mecor.GE.1) CALL pymemx(mecor,wtff,wtgf,wtfg,wtgg)
14660 ENDIF
14661C...Basic info on daughter for which to find mother.
14662 kflb=k(imi(js,mi,1),2)
14663 kflba=iabs(kflb)
14664C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14665C...second companion.
14666 ksvcb=max(-1,imi(js,mi,2))
14667C...Treat "first" companion of a pair like an ordinary sea quark
14668C...(except that creation diagram is not allowed)
14669 IF(imi(js,mi,2).GT.imisep(mi)) ksvcb=-1
14670C...X (rescaled to [0,1])
14671 xb=xmi(js,mi)/vint(142+js)
14672C...Massive quarks (use physical masses.)
14673 rmq2=0d0
14674 mqmass=0
14675 IF (kflba.EQ.4.OR.kflba.EQ.5) THEN
14676 rmq2=rmc2
14677 IF (kflba.EQ.5) rmq2=rmb2
14678C...Special threshold treatment for non-photon beams
14679 IF (kfbeam(js).NE.22) mqmass=kflba
14680 ENDIF
14681
14682C...Flags for parton distribution calls.
14683 mint(105)=mint(102+js)
14684 mint(109)=mint(106+js)
14685 vint(120)=vint(2+js)
14686
14687C...Calculate initial parton distribution weights.
14688 IF(xb.GE.xmxc) THEN
14689 RETURN
14690 ELSEIF(mqmass.EQ.0) THEN
14691 CALL pypdfu(kfbeam(js),xb,pt2,xfb)
14692 ELSE
14693C...Initialize massive quark PT2 dependent pdf underestimate.
14694 pt20=pt2
14695 CALL pypdfu(kfbeam(js),xb,pt20,xfb)
14696C.!.Tentative treatment of massive valence quarks.
14697 xq0=max(1d-10,xpsvc(kflb,ksvcb))
14698 xg0=xfb(21)
14699 tpm0=log(pt20/rmq2)
14700 wpdf0=tpm0*xg0/xq0
14701 ENDIF
14702 IF (kflba.LE.6) THEN
14703C...For quarks, only include respective sea, val, or cmp part.
14704 IF (ksvcb.LE.0) THEN
14705 xfb(kflb)=xpsvc(kflb,ksvcb)
14706 ELSE
14707C...Find companion's companion
14708 misea=0
14709 120 misea=misea+1
14710 IF (imi(js,misea,2).NE.imi(js,mi,1)) GOTO 120
14711 xs=xmi(js,misea)
14712 xrem=vint(142+js)
14713 ys=xs/(xrem+xs)
14714C...Momentum fraction of the companion quark.
14715C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14716 yb=xb*(1d0-ys)
14717 xfb(kflb)=pyfcmp(yb/vint(140),ys/vint(140),mstp(87))
14718 ENDIF
14719 ENDIF
14720
14721C...Determine overestimated z range: switch at c and b masses.
14722 130 IF (pt2.GT.tmin*rmb2) THEN
14723 izrg=3
14724 pt2mne=max(tmin*rmb2,pt2cut)
14725 b0=23d0/6d0
14726 alam2=alam5**2
14727 ELSEIF(pt2.GT.tmin*rmc2) THEN
14728 izrg=2
14729 pt2mne=max(tmin*rmc2,pt2cut)
14730 b0=25d0/6d0
14731 alam2=alam4**2
14732 ELSE
14733 izrg=1
14734 pt2mne=pt2cut
14735 b0=27d0/6d0
14736 alam2=alam3**2
14737 ENDIF
14738C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14739 alam2=alam2/parp(64)
14740C...Overestimated ZMAX:
14741 IF (mqmass.EQ.0) THEN
14742C...Massless
14743 zmax=1d0-0.5d0*(pt2mne/shtnow(mi))*(sqrt(1d0+4d0*shtnow(mi)
14744 & /pt2mne)-1d0)
14745 ELSE
14746C...Massive (limit for bremsstrahlung diagram > creation)
14747 fmq=sqrt(rmq2/shtnow(mi))
14748 zmax=1d0/(1d0+fmq)
14749 ENDIF
14750 zmin=xb/xmxc
14751
14752C...If kinematically impossible then do not evolve.
14753 IF(pt2.LT.pt2cut.OR.zmax.LE.zmin) RETURN
14754
14755C...Reset Altarelli-Parisi and PDF weights.
14756 DO 140 kfl=-5,5
14757 wtap(kfl)=0d0
14758 wtpdf(kfl)=0d0
14759 140 CONTINUE
14760 wtap(21)=0d0
14761 wtpdf(21)=0d0
14762C...Zero joining weights and compute X(partner) and X(mother) values.
14763 IF (mstp(96).NE.0) THEN
14764 njn=0
14765 DO 150 mj=1,mint(31)
14766 wtapj(mj)=0d0
14767 wtpdfj(mj)=0d0
14768 x1(mj)=xmi(js,mj)/(vint(142+js)+xmi(js,mj))
14769 y(mj)=(xmi(js,mi)+xmi(js,mj))/(vint(142+js)+xmi(js,mj)
14770 & +xmi(js,mi))
14771 150 CONTINUE
14772 ENDIF
14773
14774C...Approximate Altarelli-Parisi weights (integrated AP dz).
14775C...q -> q, g -> q or q -> q + gamma (already set which).
14776 IF(kflba.LE.5) THEN
14777C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14778 IF (ksvcb.LT.0) THEN
14779 wtap(kflb)=(8d0/3d0)*log((1d0-zmin)/(1d0-zmax))
14780 ELSE
14781 rmin=(1+sqrt(zmin))/(1-sqrt(zmin))
14782 rmax=(1+sqrt(zmax))/(1-sqrt(zmax))
14783 wtap(kflb)=(8d0/3d0)*log(rmax/rmin)
14784 ENDIF
14785 wtap(21)=0.5d0*(zmax-zmin)
14786 wtape=(2d0/9d0)*log((1d0-zmin)/(1d0-zmax))
14787 IF(mod(kflba,2).EQ.0) wtape=4d0*wtape
14788 IF(mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
14789 wtap(kflb)=wtff*wtap(kflb)
14790 wtap(21)=wtgf*wtap(21)
14791 wtape=wtff*wtape
14792 ENDIF
14793 IF (ksvcb.GE.1) THEN
14794C...Kill normal creation but add joining diagrams for cmp quark.
14795 wtap(21)=0d0
14796 IF (kflba.EQ.4.OR.kflba.EQ.5) THEN
14797 CALL pyerrm(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14798 & " quark here. Not handled yet, giving up!")
14799 pt2=0d0
14800 mint(51)=1
14801 RETURN
14802 ENDIF
14803C...Check for possible joinings
14804 IF (mstp(96).NE.0.AND.mjoind(js,mi).EQ.0) THEN
14805C...Find companion's companion.
14806 mj=0
14807 160 mj=mj+1
14808 IF (imi(js,mj,2).NE.imi(js,mi,1)) GOTO 160
14809 IF (mjoind(js,mj).EQ.0) THEN
14810 y(mi)=yb+ys
14811 z=yb/y(mi)
14812 wtapj(mj)=z*(1d0-z)*0.5d0*(z**2+(1d0-z)**2)
14813 IF (wtapj(mj).GT.1d-6) THEN
14814 njn=1
14815 ELSE
14816 wtapj(mj)=0d0
14817 ENDIF
14818 ENDIF
14819C...Add trial gluon joinings.
14820 DO 170 mj=1,mint(31)
14821 kflc=k(imi(js,mj,1),2)
14822 IF (kflc.NE.21.OR.mjoind(js,mj).NE.0) GOTO 170
14823 z=xmi(js,mj)/(xmi(js,mi)+xmi(js,mj))
14824 wtapj(mj)=6d0*(z**2+(1d0-z)**2)
14825 IF (wtapj(mj).GT.1d-6) THEN
14826 njn=njn+1
14827 ELSE
14828 wtapj(mj)=0d0
14829 ENDIF
14830 170 CONTINUE
14831 ENDIF
14832 ELSEIF (imi(js,mi,2).GE.0) THEN
14833C...Kill creation diagram for val quarks and sea quarks with companions.
14834 wtap(21)=0d0
14835 ELSEIF (mqmass.EQ.0) THEN
14836C...Extra safety factor for massless sea quark creation.
14837 wtap(21)=wtap(21)*1.25d0
14838 ENDIF
14839
14840C... q -> g, g -> g.
14841 ELSEIF(kflb.EQ.21) THEN
14842C...Here we decide later whether a quark picked up is valence or
14843C...sea, so we maintain the extra factor sqrt(z) since we deal
14844C...with the *sum* of sea and valence in this context.
14845 wtapq=(16d0/3d0)*(sqrt(1d0/zmin)-sqrt(1d0/zmax))
14846C...new: do not allow backwards evol to pick up heavy flavour.
14847 DO 180 kfl=1,min(3,mstp(58))
14848 wtap(kfl)=wtapq
14849 wtap(-kfl)=wtapq
14850 180 CONTINUE
14851 wtap(21)=6d0*log(zmax*(1d0-zmin)/(zmin*(1d0-zmax)))
14852 IF(mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
14853 wtapq=wtfg*wtapq
14854 wtap(21)=wtgg*wtap(21)
14855 ENDIF
14856C...Check for possible joinings (companions handled separately above)
14857 IF (mstp(96).NE.0.AND.mint(31).GE.2.AND.mjoind(js,mi).EQ.0)
14858 & THEN
14859 DO 190 mj=1,mint(31)
14860 IF (mj.EQ.mi.OR.mjoind(js,mj).NE.0) GOTO 190
14861 ksvcc=imi(js,mj,2)
14862 IF (imi(js,mj,2).GT.imisep(mj)) ksvcc=-1
14863 IF (ksvcc.GE.1) GOTO 190
14864 kflc=k(imi(js,mj,1),2)
14865C...Only try g -> g + g once.
14866 IF (mj.GT.mi.AND.kflc.EQ.21) GOTO 190
14867 z=xmi(js,mj)/(xmi(js,mi)+xmi(js,mj))
14868 IF (kflc.EQ.21) THEN
14869 wtapj(mj)=6d0*(z**2+(1d0-z)**2)
14870 ELSE
14871 wtapj(mj)=z*4d0/3d0*(1d0+z**2)
14872 ENDIF
14873 IF (wtapj(mj).GT.1d-6) THEN
14874 njn=njn+1
14875 ELSE
14876 wtapj(mj)=0d0
14877 ENDIF
14878 190 CONTINUE
14879 ENDIF
14880 ENDIF
14881
14882C...Initialize massive quark evolution
14883 IF (mqmass.NE.0) THEN
14884 rml=(rmq2+vint(18))/alam2
14885 tml=log(rml)
14886 tpl=log((pt2+vint(18))/alam2)
14887 tpm=log((pt2+vint(18))/rmq2)
14888 wn=wtap(21)*wpdf0/b0
14889 ENDIF
14890
14891
14892C...Loopback point for iteration
14893 ntry=0
14894 nthres=0
14895 200 ntry=ntry+1
14896 IF(ntry.GT.500) THEN
14897 CALL pyerrm(9,'(PYPTIS:) failed to evolve shower.')
14898 mint(51)=1
14899 RETURN
14900 ENDIF
14901
14902C... Calculate PDF weights and sum for evolution rate.
14903 wtsum=0d0
14904 xfbo=max(1d-10,xfb(kflb))
14905 DO 210 kfl=-5,5
14906 wtpdf(kfl)=xfb(kfl)/xfbo
14907 wtsum=wtsum+wtap(kfl)*wtpdf(kfl)
14908 210 CONTINUE
14909C...Only add gluon mother diagram for massless KFLB.
14910 IF(mqmass.EQ.0) THEN
14911 wtpdf(21)=xfb(21)/xfbo
14912 wtsum=wtsum+wtap(21)*wtpdf(21)
14913 ENDIF
14914 wtsum=max(0.0001d0,wtsum)
14915 wtsums=wtsum
14916C...Add joining diagrams where applicable.
14917 wtjoin=0d0
14918 IF (mstp(96).NE.0.AND.njn.NE.0) THEN
14919 DO 220 mj=1,mint(31)
14920 IF (wtapj(mj).LT.1d-3) GOTO 220
14921 wtpdfj(mj)=1d0/xfbo
14922C...x and x*pdf (+ sea/val) for parton C.
14923 kflc=k(imi(js,mj,1),2)
14924 kflca=iabs(kflc)
14925 ksvcc=max(-1,imi(js,mj,2))
14926 IF (imi(js,mj,2).GT.imisep(mj)) ksvcc=-1
14927 mint(30)=js
14928 mint(36)=mj
14929 CALL pypdfu(kfbeam(js),x1(mj),pt2,xfj)
14930 mint(36)=mi
14931 IF (kflca.LE.6.AND.ksvcc.LE.0) THEN
14932 xfj(kflc)=xpsvc(kflc,ksvcc)
14933 ELSEIF (ksvcc.GE.1) THEN
14934 print*, 'error! parton C is companion!'
14935 ENDIF
14936 wtpdfj(mj)=wtpdfj(mj)/xfj(kflc)
14937C...x and x*pdf (+ sea/val) for parton A.
14938 kfla=21
14939 ksvca=0
14940 IF (kflca.EQ.21.AND.kflba.LE.5) THEN
14941 kfla=kflb
14942 ksvca=ksvcb
14943 ELSEIF (kflba.EQ.21.AND.kflca.LE.5) THEN
14944 kfla=kflc
14945 ksvca=ksvcc
14946 ENDIF
14947 mint(30)=js
14948 IF (ksvca.LE.0) THEN
14949C...Consider C the "evolved" parton if B is gluon. Val/sea
14950C...counting will then be done correctly in PYPDFU.
14951 IF (kflba.EQ.21) mint(36)=mj
14952 CALL pypdfu(kfbeam(js),y(mj),pt2,xfj)
14953 mint(36)=mi
14954 IF (iabs(kfla).LE.6) xfj(kfla)=xpsvc(kfla,ksvca)
14955 ELSE
14956C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14957 xfj(kfla)=pyfcmp(y(mi)/vint(140),ys/vint(140),mstp(87))
14958 ENDIF
14959 wtpdfj(mj)=xfj(kfla)*wtpdfj(mj)
14960 wtjoin=wtjoin+wtapj(mj)*wtpdfj(mj)
14961 220 CONTINUE
14962 ENDIF
14963
14964C...Pick normal pT2 (in overestimated z range).
14965 230 pt2old=pt2
14966 wtsum=wtsums
14967 pt2=alam2*((pt2+vint(18))/alam2)**(pyr(0)**(b0/wtsum))-vint(18)
14968 kflc=21
14969
14970C...Evolve q -> q gamma separately, pick it if larger pT.
14971 IF(kflba.LE.5) THEN
14972 pt2qed=(pt2old+vint(18))*pyr(0)**(1d0/(aem2pi*wtape))-vint(18)
14973 IF(pt2qed.GT.pt2) THEN
14974 pt2=pt2qed
14975 kflc=22
14976 kfla=kflb
14977 ENDIF
14978 ENDIF
14979
14980C... Evolve massive quark creation separately.
14981 mcrqq=0
14982 IF (mqmass.NE.0) THEN
14983 pt2cr=(rmq2+vint(18))*(rml**(tpm/(tpl*pyr(0)**(-tml/wn)-tpm)))
14984 & -vint(18)
14985C... Ensure mininimum PT2CR and force creation near threshold.
14986 IF (pt2cr.LT.tmin*rmq2) THEN
14987 nthres=nthres+1
14988 IF (nthres.GT.50) THEN
14989 CALL pyerrm(9,'(PYPTIS:) no phase space left for '//
14990 & 'massive quark creation. Gave up trying.')
14991 mint(51)=1
14992C...Special return code if failing before any evolution at all: bad event
14993 IF (nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) mint(51)=2
14994 RETURN
14995 ENDIF
14996 pt2=0d0
14997 pt2cr=tmin*rmq2
14998 mcrqq=2
14999 ENDIF
15000C... Select largest PT2 (brems or creation):
15001 IF (pt2cr.GT.pt2) THEN
15002 mcrqq=max(mcrqq,1)
15003 wtsum=0d0
15004 pt2=pt2cr
15005 kfla=21
15006 ELSE
15007 mcrqq=0
15008 kfla=kflb
15009 ENDIF
15010C... Compute logarithms for this PT2
15011 tpl=log((pt2+vint(18))/alam2)
15012 tpm=log((pt2+vint(18))/(rmq2+vint(18)))
15013 wtcrqq=tpm/log(pt2/rmq2)
15014 ENDIF
15015
15016C...Evolve joining separately
15017 mjoin=0
15018 IF (mstp(96).NE.0.AND.njn.NE.0) THEN
15019 pt2jn=alam2*((pt2old+vint(18))/alam2)**(pyr(0)**(b0/wtjoin))
15020 & -vint(18)
15021 IF (pt2jn.GE.pt2) THEN
15022 mjoin=1
15023 pt2=pt2jn
15024 ENDIF
15025 ENDIF
15026
15027C...Loopback if crossed c/b mass thresholds.
15028 IF(izrg.EQ.3.AND.pt2.LT.rmb2) THEN
15029 pt2=rmb2
15030 GOTO 130
15031 ELSEIF(izrg.EQ.2.AND.pt2.LT.rmc2) THEN
15032 pt2=rmc2
15033 GOTO 130
15034 ENDIF
15035
15036C...Speed up shower. Skip if higher-PT acceptable branching
15037C...already found somewhere else.
15038C...Also finish if below lower cutoff.
15039
15040 IF (pt2.LT.pt2mx.OR.pt2.LT.pt2cut) RETURN
15041
15042C...Select parton A flavour (massive Q handled above.)
15043 IF (mqmass.EQ.0.AND.kflc.NE.22.AND.mjoin.EQ.0) THEN
15044 wtran=pyr(0)*wtsum
15045 kfla=-6
15046 240 kfla=kfla+1
15047 wtran=wtran-wtap(kfla)*wtpdf(kfla)
15048 IF(kfla.LE.5.AND.wtran.GT.0d0) GOTO 240
15049 IF(kfla.EQ.6) kfla=21
15050 ELSEIF (mjoin.EQ.1) THEN
15051C...Tentative joining accept/reject.
15052 wtran=pyr(0)*wtjoin
15053 mj=0
15054 250 mj=mj+1
15055 wtran=wtran-wtapj(mj)*wtpdfj(mj)
15056 IF(mj.LE.mint(31)-1.AND.wtran.GT.0d0) GOTO 250
15057 IF(mjoind(js,mj).NE.0.OR.mjoind(js,mi).NE.0) THEN
15058 CALL pyerrm(9,'(PYPTIS:) Attempted double joining.'//
15059 & ' Rejected.')
15060 GOTO 230
15061 ENDIF
15062C...x*pdf (+ sea/val) at new pT2 for parton B.
15063 IF (ksvcb.LE.0) THEN
15064 mint(30)=js
15065 CALL pypdfu(kfbeam(js),xb,pt2,xfb)
15066 IF (kflba.LE.6) xfb(kflb)=xpsvc(kflb,ksvcb)
15067 ELSE
15068C...Companion distributions do not evolve.
15069 xfb(kflb)=xfbo
15070 ENDIF
15071 wtveto=1d0/wtpdfj(mj)/xfb(kflb)
15072 kflc=k(imi(js,mj,1),2)
15073 kflca=iabs(kflc)
15074 ksvcc=max(-1,imi(js,mj,2))
15075 IF (ksvcb.GE.1) ksvcc=-1
15076C...x*pdf (+ sea/val) at new pT2 for parton C.
15077 mint(30)=js
15078 mint(36)=mj
15079 CALL pypdfu(kfbeam(js),x1(mj),pt2,xfj)
15080 mint(36)=mi
15081 IF (kflca.LE.6.AND.ksvcc.LE.0) xfj(kflc)=xpsvc(kflc,ksvcc)
15082 wtveto=wtveto/xfj(kflc)
15083C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15084 kfla=21
15085 ksvca=0
15086 IF (kflca.EQ.21.AND.kflba.LE.5) THEN
15087 kfla=kflb
15088 ksvca=ksvcb
15089 ELSEIF (kflba.EQ.21.AND.kflca.LE.5) THEN
15090 kfla=kflc
15091 ksvca=ksvcc
15092 ENDIF
15093 IF (ksvca.LE.0) THEN
15094 mint(30)=js
15095 IF (kflb.EQ.21) mint(36)=mj
15096 CALL pypdfu(kfbeam(js),y(mj),pt2,xfj)
15097 mint(36)=mi
15098 IF (iabs(kfla).LE.6) xfj(kfla)=xpsvc(kfla,ksvca)
15099 ELSE
15100 xfj(kfla)=pyfcmp(y(mj)/vint(140),ys/vint(140),mstp(87))
15101 ENDIF
15102 wtveto=wtveto*xfj(kfla)
15103C...Monte Carlo veto.
15104 IF (wtveto.LT.pyr(0)) GOTO 200
15105C...If accept, save PT2 of this joining.
15106 IF (pt2.GT.pt2mx) THEN
15107 pt2mx=pt2
15108 jsmx=2+js
15109 mjn1mx=mj
15110 mjn2mx=mi
15111 wtapj(mj)=0d0
15112 njn=0
15113 ENDIF
15114C...Exit and continue evolution.
15115 GOTO 390
15116 ENDIF
15117 kflaa=iabs(kfla)
15118
15119C...Choose z value (still in overestimated range) and corrective weight.
15120C...Unphysical z will be rejected below when Q2 has is computed.
15121 wtz=0d0
15122
15123C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15124C...q -> q + g or q -> q + gamma (already set which).
15125 IF (kflaa.LE.5.AND.kflba.LE.5) THEN
15126 IF (ksvcb.LT.0) THEN
15127 z=1d0-(1d0-zmin)*((1d0-zmax)/(1d0-zmin))**pyr(0)
15128 ELSE
15129 zfac=rmin*(rmax/rmin)**pyr(0)
15130 z=((1-zfac)/(1+zfac))**2
15131 ENDIF
15132 wtz=0.5d0*(1d0+z**2)
15133C...Massive weight correction.
15134 IF (kflba.GE.4) wtz=wtz-z*(1d0-z)**2*rmq2/pt2
15135C...Valence quark weight correction (extra sqrt)
15136 IF (ksvcb.GE.0) wtz=wtz*sqrt(z)
15137
15138C...q -> g + q.
15139C...NB: MQ>0 not yet implemented. Forced absent above.
15140 ELSEIF (kflaa.LE.5.AND.kflb.EQ.21) THEN
15141 kflc=kfla
15142 z=zmax/(1d0+pyr(0)*(sqrt(zmax/zmin)-1d0))**2
15143 wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)
15144
15145C...g -> q + qbar.
15146 ELSEIF (kfla.EQ.21.AND.kflba.LE.5) THEN
15147 kflc=-kflb
15148 z=zmin+pyr(0)*(zmax-zmin)
15149 wtz=z**2+(1d0-z)**2
15150C...Massive correction
15151 IF (mqmass.NE.0) THEN
15152 wtz=wtz+2d0*z*(1d0-z)*rmq2/pt2
15153C...Extra safety margin for light sea quark creation
15154 ELSEIF (ksvcb.LT.0) THEN
15155 wtz=wtz/1.25d0
15156 ENDIF
15157
15158C...g -> g + g.
15159 ELSEIF (kfla.EQ.21.AND.kflb.EQ.21) THEN
15160 kflc=21
15161 z=1d0/(1d0+((1d0-zmin)/zmin)*((1d0-zmax)*zmin/
15162 & (zmax*(1d0-zmin)))**pyr(0))
15163 wtz=(1d0-z*(1d0-z))**2
15164 ENDIF
15165
15166C...Derive Q2 from pT2.
15167 q2b=pt2/(1d0-z)
15168 IF (kflba.GE.4) q2b=q2b-rmq2
15169
15170C...Loopback if outside allowed z range for given pT2.
15171 rm2c=pymass(kflc)**2
15172 pt2adj=q2b-z*(shtnow(mi)+q2b)*(q2b+rm2c)/shtnow(mi)
15173 IF (pt2adj.LT.1d-6) GOTO 230
15174
15175C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15176C...No modification for very first emission if using ME correction
15177 mstp67 = mstp(67)
15178 IF (mecor.GE.1.AND.nisgen(1,mi).EQ.0.AND.nisgen(2,mi).EQ.0) THEN
15179 mstp67 = 0
15180 ENDIF
15181
15182C...For 1st branching, limit phase space by s-hat with color-partner
15183 IF (mstp67.GE.1.AND.nisgen(js,mi).EQ.0) THEN
15184 mside=1
15185 idip=imi(js,mi,1)
15186C...Use anticolor tag for antiquark, or for gluon half the time
15187 IF ((kflb.LT.0.AND.kflba.LT.10).OR.(
15188 & kflb.EQ.21.AND.pyr(0).GT.0.5)) mside=2
15189C...Tag
15190 mctag=mct(idip,mside)
15191C...Default is to set up phase space using the opposite incoming parton
15192 jdip=imi(3-js,mi,1)
15193 ndip=0
15194C...Alternatively, look for final-state color partner (pick first if several)
15195 DO 260 ifs=1,npart
15196 IF (mct(ipart(ifs),mside).EQ.mctag.AND.ndip.EQ.0) THEN
15197 jdip=ipart(ifs)
15198 ndip=ndip+1
15199 ENDIF
15200 260 CONTINUE
15201C...Compute mass of pair
15202 sdip=(p(idip,4)+p(jdip,4))**2-(p(idip,3)+p(jdip,3))**2
15203 & -(p(idip,2)+p(jdip,2))**2-(p(idip,1)+p(jdip,1))**2
15204 IF (mstp67.EQ.1) THEN
15205C...1 Option to completely kill radiation above s_dip * PARP(67)
15206 IF (4*pt2.GT.parp(67)*sdip) GOTO 230
15207 ELSE IF (mstp67.EQ.2) THEN
15208C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15209C... (-> improved power showers?)
15210 IF (4*pt2*pyr(0).GT.parp(67)*sdip) GOTO 230
15211 ENDIF
15212
15213C...For subsequent branchings, loopback if nonordered in angle/rapidity
15214 ELSE IF (mstp(62).GE.3.AND.nisgen(js,mi).GE.1) THEN
15215 IF(pt2.GT.((1d0-z)/(z*(1d0-zsav(js,mi))))**2*pt2sav(js,mi))
15216 & GOTO 230
15217 ENDIF
15218
15219C...Select phi angle of branching at random.
15220 phi=paru(2)*pyr(0)
15221
15222C...Matrix-element corrections for some processes.
15223 IF (mecor.GE.1.AND.nisgen(js,mi).EQ.0) THEN
15224 IF (kflaa.LE.20.AND.kflba.LE.20) THEN
15225 CALL pymewt(mecor,1,q2b*shat/shtnow(mi),z,phi,wtme)
15226 wtz=wtz*wtme/wtff
15227 ELSEIF((kfla.EQ.21.OR.kfla.EQ.22).AND.kflba.LE.20) THEN
15228 CALL pymewt(mecor,2,q2b*shat/shtnow(mi),z,phi,wtme)
15229 wtz=wtz*wtme/wtgf
15230 ELSEIF(kflaa.LE.20.AND.(kflb.EQ.21.OR.kflb.EQ.22)) THEN
15231 CALL pymewt(mecor,3,q2b*shat/shtnow(mi),z,phi,wtme)
15232 wtz=wtz*wtme/wtfg
15233 ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN
15234 CALL pymewt(mecor,4,q2b*shat/shtnow(mi),z,phi,wtme)
15235 wtz=wtz*wtme/wtgg
15236 ENDIF
15237 ENDIF
15238
15239C...Parton distributions at new pT2 but old x.
15240 mint(30)=js
15241 CALL pypdfu(kfbeam(js),xb,pt2,xfn)
15242C...Treat val and cmp separately
15243 IF (kflba.LE.6.AND.ksvcb.LE.0) xfn(kflb)=xpsvc(kflb,ksvcb)
15244 IF (ksvcb.GE.1)
15245 & xfn(kflb)=pyfcmp(yb/vint(140),ys/vint(140),mstp(87))
15246 xfbn=xfn(kflb)
15247 IF(xfbn.LT.1d-20) THEN
15248 IF(kfla.EQ.kflb) THEN
15249 wtap(kflb)=0d0
15250 GOTO 200
15251 ELSE
15252 xfbn=1d-10
15253 xfn(kflb)=xfbn
15254 ENDIF
15255 ENDIF
15256 DO 270 kfl=-5,5
15257 xfb(kfl)=xfn(kfl)
15258 270 CONTINUE
15259 xfb(21)=xfn(21)
15260
15261C...Parton distributions at new pT2 and new x.
15262 xa=xb/z
15263 mint(30)=js
15264 CALL pypdfu(kfbeam(js),xa,pt2,xfa)
15265 IF (kflba.LE.5.AND.kflaa.LE.5) THEN
15266C...q -> q + g: only consider respective sea, val, or cmp content.
15267 IF (ksvcb.LE.0) THEN
15268 xfa(kfla)=xpsvc(kfla,ksvcb)
15269 ELSE
15270 ya=xa*(1d0-ys)
15271 xfa(kflb)=pyfcmp(ya/vint(140),ys/vint(140),mstp(87))
15272 ENDIF
15273 ENDIF
15274 xfan=xfa(kfla)
15275 IF(xfan.LT.1d-20) THEN
15276 GOTO 200
15277 ENDIF
15278
15279C...If weighting fails continue evolution.
15280 wttot=0d0
15281 IF (mcrqq.EQ.0) THEN
15282 wtpdfa=1d0/wtpdf(kfla)
15283 wttot=wtz*xfan/xfbn*wtpdfa
15284 ELSEIF(mcrqq.EQ.1) THEN
15285 wtpdfa=tpm/wpdf0
15286 wttot=wtcrqq*wtz*xfan/xfbn*wtpdfa
15287 xbest=tpm/tpm0*xq0
15288 ELSEIF(mcrqq.EQ.2) THEN
15289C...Force massive quark creation.
15290 wttot=1d0
15291 ENDIF
15292
15293C...Loop back if trial emission fails.
15294 IF(wttot.GE.0d0.AND.wttot.LT.pyr(0)) GOTO 200
15295 wtacc=((1d0+pt2)/(0.25d0+pt2))**2
15296 IF(wttot.LT.0d0) THEN
15297 WRITE(chwt,'(1P,E12.4)') wttot
15298 CALL pyerrm(19,'(PYPTIS:) Weight '//chwt//' negative')
15299 ELSEIF(wttot.GT.wtacc) THEN
15300 WRITE(chwt,'(1P,E12.4)') wttot
15301 IF (pt2.GT.ptemax.OR.wttot.GE.wtemax) THEN
15302C...Too high weight: write out as error, but do not update error counter
15303 IF(mstu(29).EQ.0) mstu(23)=mstu(23)-1
15304 CALL pyerrm(19,
15305 & '(PYPTIS:) Weight '//chwt//' above unity')
15306 IF (pt2.GT.ptemax) ptemax=pt2
15307 IF (wttot.GT.wtemax) wtemax=wttot
15308 ELSE
15309 CALL pyerrm(9,
15310 & '(PYPTIS:) Weight '//chwt//' above unity')
15311 ENDIF
15312C...Useful for debugging but commented out for distribution:
15313C print*, 'JS, MI',JS, MI
15314C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15315C print*, 'A -> B C',KFLA, KFLB, KFLC
15316C XFAO=XFBO/WTPDFA
15317C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15318 ENDIF
15319
15320C...Save acceptable branching.
15321 IF(pt2.GT.pt2mx) THEN
15322 mimx=mint(36)
15323 jsmx=js
15324 pt2mx=pt2
15325 kflamx=kfla
15326 kflcmx=kflc
15327 rm2cmx=rm2c
15328 q2bmx=q2b
15329 zmx=z
15330 pt2amx=pt2adj
15331 phimx=phi
15332 ENDIF
15333
15334C----------------------------------------------------------------------
15335C...MODE= 1: Accept stored shower branching. Update event record etc.
15336 ELSEIF (mode.EQ.1) THEN
15337 mi=mimx
15338 js=jsmx
15339 shat=shtnow(mi)
15340 side=3d0-2d0*js
15341C...Shift down rest of event record to make room for insertion.
15342 it=imisep(mi)+1
15343 im=it+1
15344 is=imi(js,mi,1)
15345 DO 290 i=n,it,-1
15346 IF (k(i,3).GE.it) k(i,3)=k(i,3)+2
15347 kt1=k(i,4)/mstu(5)**2
15348 kt2=k(i,5)/mstu(5)**2
15349 id1=mod(k(i,4),mstu(5))
15350 id2=mod(k(i,5),mstu(5))
15351 im1=mod(k(i,4)/mstu(5),mstu(5))
15352 im2=mod(k(i,5)/mstu(5),mstu(5))
15353 IF (id1.GE.it) id1=id1+2
15354 IF (id2.GE.it) id2=id2+2
15355 IF (im1.GE.it) im1=im1+2
15356 IF (im2.GE.it) im2=im2+2
15357 k(i,4)=kt1*mstu(5)**2+im1*mstu(5)+id1
15358 k(i,5)=kt2*mstu(5)**2+im2*mstu(5)+id2
15359 DO 280 ix=1,5
15360 k(i+2,ix)=k(i,ix)
15361 p(i+2,ix)=p(i,ix)
15362 v(i+2,ix)=v(i,ix)
15363 280 CONTINUE
15364 mct(i+2,1)=mct(i,1)
15365 mct(i+2,2)=mct(i,2)
15366 290 CONTINUE
15367 n=n+2
15368C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15369 DO 300 ji=1,mint(31)
15370 IF (imi(1,ji,1).GE.it) imi(1,ji,1)=imi(1,ji,1)+2
15371 IF (imi(1,ji,2).GE.it) imi(1,ji,2)=imi(1,ji,2)+2
15372 IF (imi(2,ji,1).GE.it) imi(2,ji,1)=imi(2,ji,1)+2
15373 IF (imi(2,ji,2).GE.it) imi(2,ji,2)=imi(2,ji,2)+2
15374 IF (ji.GE.mi) imisep(ji)=imisep(ji)+2
15375C...Also update companion pointers to the present mother.
15376 IF (imi(js,ji,2).EQ.is) imi(js,ji,2)=im
15377 300 CONTINUE
15378 DO 310 ifs=1,npart
15379 IF (ipart(ifs).GE.it) ipart(ifs)=ipart(ifs)+2
15380 310 CONTINUE
15381C...Zero entries dedicated for new timelike and mother partons.
15382 DO 330 i=it,it+1
15383 DO 320 j=1,5
15384 k(i,j)=0
15385 p(i,j)=0d0
15386 v(i,j)=0d0
15387 320 CONTINUE
15388 mct(i,1)=0
15389 mct(i,2)=0
15390 330 CONTINUE
15391
15392C...Define timelike and new mother partons. History.
15393 k(it,1)=3
15394 k(it,2)=kflcmx
15395 k(im,1)=14
15396 k(im,2)=kflamx
15397 k(is,3)=im
15398 k(it,3)=im
15399C...Set mother origin = side.
15400 k(im,3)=mint(83)+js+2
15401 IF(mi.GE.2) k(im,3)=mint(83)+js
15402
15403C...Define colour flow of branching.
15404 im1=im
15405 im2=im
15406C...q -> q + gamma.
15407 IF(k(it,2).EQ.22) THEN
15408 k(it,1)=1
15409 id1=is
15410 id2=is
15411C...q -> q + g.
15412 ELSEIF(k(im,2).GT.0.AND.k(im,2).LE.5.AND.k(it,2).EQ.21) THEN
15413 id1=it
15414 id2=is
15415C...q -> g + q.
15416 ELSEIF(k(im,2).GT.0.AND.k(im,2).LE.5) THEN
15417 id1=is
15418 id2=it
15419C...qbar -> qbar + g.
15420 ELSEIF(k(im,2).LT.0.AND.k(im,2).GE.-5.AND.k(it,2).EQ.21) THEN
15421 id1=is
15422 id2=it
15423C...qbar -> g + qbar.
15424 ELSEIF(k(im,2).LT.0.AND.k(im,2).GE.-5) THEN
15425 id1=it
15426 id2=is
15427C...g -> g + g; g -> q + qbar..
15428 ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN
15429 id1=is
15430 id2=it
15431 ELSE
15432 id1=it
15433 id2=is
15434 ENDIF
15435 IF(im1.EQ.im) k(im1,4)=k(im1,4)+id1
15436 IF(im2.EQ.im) k(im2,5)=k(im2,5)+id2
15437 k(id1,4)=k(id1,4)+mstu(5)*im1
15438 k(id2,5)=k(id2,5)+mstu(5)*im2
15439 IF(id1.NE.id2) THEN
15440 k(id1,5)=k(id1,5)+mstu(5)*id2
15441 k(id2,4)=k(id2,4)+mstu(5)*id1
15442 ENDIF
15443 IF(k(it,1).EQ.1) THEN
15444 k(it,4)=0
15445 k(it,5)=0
15446 ENDIF
15447C...Update IMI and colour tag arrays.
15448 imi(js,mi,1)=im
15449 DO 340 mc=1,2
15450 mct(it,mc)=0
15451 mct(im,mc)=0
15452 340 CONTINUE
15453 DO 350 jcs=4,5
15454 kcs=jcs
15455C...If mother flag not yet set for spacelike parton, trace it.
15456 IF (k(is,kcs)/mstu(5)**2.LE.1) CALL pycttr(is,-kcs,im)
15457 IF(mint(51).NE.0) RETURN
15458 350 CONTINUE
15459 DO 360 jcs=4,5
15460 kcs=jcs
15461C...If mother flag not yet set for timelike parton, trace it.
15462 IF (k(it,kcs)/mstu(5)**2.LE.1) CALL pycttr(it,kcs,im)
15463 IF(mint(51).NE.0) RETURN
15464 360 CONTINUE
15465
15466C...Boost recoiling parton to compensate for Q2 scale.
15467 betaz=side*(1d0-(1d0+q2bmx/shat)**2)/
15468 & (1d0+(1d0+q2bmx/shat)**2)
15469 ir=imi(3-js,mi,1)
15470 CALL pyrobo(ir,ir,0d0,0d0,0d0,0d0,betaz)
15471
15472C...Define system to be rotated and boosted
15473C...(not including the 2 just added partons)
15474C...(but including the docu lines for first interaction)
15475 imin=imisep(mi-1)+1
15476 IF (mi.EQ.1) imin=mint(83)+5
15477 imax=imisep(mi)-2
15478
15479C...Rotate back system in phi to compensate for subsequent rotation.
15480 CALL pyrobo(imin,imax,0d0,-phimx,0d0,0d0,0d0)
15481
15482C...Define kinematics of new partons in old frame.
15483 imax=imisep(mi)
15484 p(im,1)=sqrt(pt2amx)*shat/(zmx*(shat+q2bmx))
15485 p(im,3)=0.5d0*sqrt(shat)*((shat-q2bmx)/((shat
15486 & +q2bmx)*zmx)+(q2bmx+rm2cmx)/shat)*side
15487 p(im,4)=sqrt(p(im,1)**2+p(im,3)**2)
15488 p(it,1)=p(im,1)
15489 p(it,3)=p(im,3)-0.5d0*(shat+q2bmx)/sqrt(shat)*side
15490 p(it,4)=sqrt(p(it,1)**2+p(it,3)**2+rm2cmx)
15491 p(it,5)=sqrt(rm2cmx)
15492
15493C...Update internal line, now spacelike
15494 p(is,1)=p(im,1)-p(it,1)
15495 p(is,2)=p(im,2)-p(it,2)
15496 p(is,3)=p(im,3)-p(it,3)
15497 p(is,4)=p(im,4)-p(it,4)
15498 p(is,5)=p(is,4)**2-p(is,1)**2-p(is,2)**2-p(is,3)**2
15499C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15500 IF (p(is,5).LT.0d0) THEN
15501 p(is,5)=-sqrt(abs(p(is,5)))
15502 ELSE
15503 p(is,5)=sqrt(p(is,5))
15504 ENDIF
15505
15506C...Boost entire system and rotate to new frame.
15507C...(including docu lines)
15508 betax=(p(im,1)+p(ir,1))/(p(im,4)+p(ir,4))
15509 betaz=(p(im,3)+p(ir,3))/(p(im,4)+p(ir,4))
15510 IF(betax**2+betaz**2.GE.1d0) THEN
15511 CALL pyerrm(1,'(PYPTIS:) boost bigger than unity')
15512 mint(51)=1
15513 ifail=-1
15514 RETURN
15515 ENDIF
15516 CALL pyrobo(imin,imax,0d0,0d0,-betax,0d0,-betaz)
15517 i1=imi(1,mi,1)
15518 theta=pyangl(p(i1,3),p(i1,1))
15519 CALL pyrobo(imin,imax,-theta,phimx,0d0,0d0,0d0)
15520
15521C...Global statistics.
15522 mint(352)=mint(352)+1
15523 vint(352)=vint(352)+sqrt(p(it,1)**2+p(it,2)**2)
15524 IF (mint(352).EQ.1) vint(357)=sqrt(p(it,1)**2+p(it,2)**2)
15525
15526C...Add parton with relevant pT scale for timelike shower.
15527 IF (k(it,2).NE.22) THEN
15528 npart=npart+1
15529 ipart(npart)=it
15530 ptpart(npart)=sqrt(pt2amx)
15531 ENDIF
15532
15533C...Update saved variables.
15534 shtnow(mimx)=shtnow(mimx)/zmx
15535 nisgen(jsmx,mimx)=nisgen(jsmx,mimx)+1
15536 xmi(jsmx,mimx)=xmi(jsmx,mimx)/zmx
15537 pt2sav(jsmx,mimx)=pt2mx
15538 zsav(js,mimx)=zmx
15539
15540 ksa=iabs(k(is,2))
15541 kma=iabs(k(im,2))
15542 IF (ksa.EQ.21.AND.kma.GE.1.AND.kma.LE.5) THEN
15543C...Gluon reconstructs to quark.
15544C...Decide whether newly created quark is valence or sea:
15545 mint(30)=js
15546 CALL pyptmi(2,pt2now,ptdum1,ptdum2,ifail)
15547 IF(mint(51).NE.0) RETURN
15548 ENDIF
15549 IF(ksa.GE.1.AND.ksa.LE.5.AND.kma.EQ.21) THEN
15550C...Quark reconstructs to gluon.
15551C...Now some guy may have lost his companion. Check.
15552 icmp=imi(js,mi,2)
15553 IF (icmp.GT.0) THEN
15554 CALL pyerrm(9,'(PYPTIS:) Sorry, companion quark radiated'
15555 & //' away. Cannot handle that yet. Giving up.')
15556 mint(51)=1
15557 RETURN
15558 ELSEIF(icmp.LT.0) THEN
15559C...A sea quark with companion still in BR was reconstructed to a gluon.
15560C...Companion should now be removed from the beam remnant.
15561C...(Momentum integral is automatically updated in next call to PYPDFU.)
15562 icmp=-icmp
15563 ifl=-k(is,2)
15564 DO 380 jcmp=icmp,nvc(js,ifl)-1
15565 xassoc(js,ifl,jcmp)=xassoc(js,ifl,jcmp+1)
15566 DO 370 ji=1,mint(31)
15567 kmi=-imi(js,ji,2)
15568 jfl=-k(imi(js,ji,1),2)
15569 IF (kmi.EQ.jcmp+1.AND.jfl.EQ.ifl) imi(js,ji,2)=imi(js,ji
15570 & ,2)+1
15571 370 CONTINUE
15572 380 CONTINUE
15573 nvc(js,ifl)=nvc(js,ifl)-1
15574 ENDIF
15575C...Set gluon IMI(JS,MI,2) = 0.
15576 imi(js,mi,2)=0
15577 ELSEIF(ksa.GE.1.AND.ksa.LE.5.AND.kma.NE.21) THEN
15578C...Quark reconstructing to quark. If sea with companion still in BR
15579C...then update associated x value.
15580C...(Momentum integral is automatically updated in next call to PYPDFU.)
15581 IF (imi(js,mi,2).LT.0) THEN
15582 icmp=-imi(js,mi,2)
15583 ifl=-k(is,2)
15584 xassoc(js,ifl,icmp)=xmi(jsmx,mimx)
15585 ENDIF
15586 ENDIF
15587
15588 ENDIF
15589
15590C...If reached this point, normal exit.
15591 390 ifail=0
15592
15593 RETURN
15594 END
15595
15596C*********************************************************************
15597
15598C...PYMEMX
15599C...Generates maximum ME weight in some initial-state showers.
15600C...Inparameter MECOR: kind of hard scattering process
15601C...Outparameter WTFF: maximum weight for fermion -> fermion
15602C... WTGF: maximum weight for gluon/photon -> fermion
15603C... WTFG: maximum weight for fermion -> gluon/photon
15604C... WTGG: maximum weight for gluon -> gluon
15605
15606 SUBROUTINE pymemx(MECOR,WTFF,WTGF,WTFG,WTGG)
15607
15608C...Double precision and integer declarations.
15609 IMPLICIT DOUBLE PRECISION(a-h, o-z)
15610 IMPLICIT INTEGER(I-N)
15611 INTEGER PYK,PYCHGE,PYCOMP
15612C...Commonblocks.
15613 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
15614 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15615 common/pypars/mstp(200),parp(200),msti(200),pari(200)
15616 common/pyint1/mint(400),vint(400)
15617 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15618 SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyint2/
15619
15620C...Default maximum weight.
15621 wtff=1d0
15622 wtgf=1d0
15623 wtfg=1d0
15624 wtgg=1d0
15625
15626C...Select maximum weight by process.
15627 IF(mecor.EQ.1) THEN
15628 wtff=1d0
15629 wtgf=3d0
15630 ELSEIF(mecor.EQ.2) THEN
15631 wtfg=1d0
15632 wtgg=1d0
15633 ENDIF
15634
15635 RETURN
15636 END
15637
15638C*********************************************************************
15639
15640C...PYMEWT
15641C...Calculates actual ME weight in some initial-state showers.
15642C...Inparameter MECOR: kind of hard scattering process
15643C... IFLCB: flavour combination of branching,
15644C... 1 for fermion -> fermion,
15645C... 2 for gluon/photon -> fermion
15646C... 3 for fermion -> gluon/photon,
15647C... 4 for gluon -> gluon
15648C... Q2: Q2 value of shower branching
15649C... Z: Z value of branching
15650C...In+outparameter PHIBR: azimuthal angle of branching
15651C...Outparameter WTME: actual ME weight
15652
15653 SUBROUTINE pymewt(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15654
15655C...Double precision and integer declarations.
15656 IMPLICIT DOUBLE PRECISION(a-h, o-z)
15657 IMPLICIT INTEGER(I-N)
15658 INTEGER PYK,PYCHGE,PYCOMP
15659C...Commonblocks.
15660 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
15661 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15662 common/pypars/mstp(200),parp(200),msti(200),pari(200)
15663 common/pyint1/mint(400),vint(400)
15664 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15665 SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyint2/
15666
15667C...Default output.
15668 wtme=1d0
15669
15670C...Define kinematics of shower branching in Mandelstam variables.
15671 sqm=vint(44)
15672 sh=sqm/z
15673 th=-q2
15674 uh=q2-sqm*(1d0-z)/z
15675
15676C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15677 IF(mecor.EQ.1) THEN
15678 IF(iflcb.EQ.1) THEN
15679 wtme=(th**2+uh**2+2d0*sqm*sh)/(sh**2+sqm**2)
15680 ELSEIF(iflcb.EQ.2) THEN
15681 wtme=(sh**2+th**2+2d0*sqm*uh)/((sh-sqm)**2+sqm**2)
15682 ENDIF
15683
15684C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15685 ELSEIF(mecor.EQ.2) THEN
15686 IF(iflcb.EQ.3) THEN
15687 wtme=(sh**2+uh**2)/(sh**2+(sh-sqm)**2)
15688 ELSEIF(iflcb.EQ.4) THEN
15689 wtme=0.5d0*(sh**4+uh**4+th**4+sqm**4)/(sh**2-sqm*(sh-sqm))**2
15690 ENDIF
15691
15692C...Matrix-element corrections for q + qbar -> Higgs (h0)
15693 ELSEIF(mecor.EQ.3) THEN
15694 IF(iflcb.EQ.2) THEN
15695 wtme=(sh**2+th**2+2d0*(sqm-th)*(sqm-sh))/
15696 1 (sh**2+2d0*sqm*(sqm-sh))
15697 ENDIF
15698 ENDIF
15699
15700 RETURN
15701 END
15702
15703C*********************************************************************
15704
15705C...PYPTMI
15706C...Handles the generation of additional interactions in the new
15707C...multiple interactions framework.
15708C...MODE=-1 : Initalize MI from scratch.
15709C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15710C... Sudakov for PT2, abort if below PT2CUT.
15711C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15712C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15713C...PT2NOW : Starting (max) PT2 scale for evolution.
15714C...PT2CUT : Lower limit for evolution.
15715C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15716C...IFAIL : Status return code.
15717C... = 0: All is well.
15718C... < 0: Phase space exhausted, generation to be terminated.
15719C... > 0: Additional interaction vetoed, but continue evolution.
15720
15721 SUBROUTINE pyptmi(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15722C...Double precision and integer declarations.
15723 IMPLICIT DOUBLE PRECISION(a-h, o-z)
15724 IMPLICIT INTEGER(I-N)
15725 INTEGER PYK,PYCHGE,PYCOMP
15726C...Parameter statement for maximum size of showers.
15727 parameter(maxnur=1000)
15728C...Commonblocks.
15729 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
15730 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
15731 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
15732 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
15733 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
15734 common/pypars/mstp(200),parp(200),msti(200),pari(200)
15735 common/pyint1/mint(400),vint(400)
15736 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
15737 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
15738 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
15739 common/pyint7/sigt(0:6,0:6,0:5)
15740 common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
15741 & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
15742 & xmi(2,240),pt2mi(240),imisep(0:240)
15743 common/pyismx/mimx,jsmx,kflamx,kflcmx,kfbeam(2),nisgen(2,240),
15744 & pt2mx,pt2amx,zmx,rm2cmx,q2bmx,phimx
15745 common/pyctag/nct,mct(4000,2)
15746C...Local arrays and saved variables.
15747 dimension wdtp(0:400),wdte(0:400,0:5),xpq(-25:25)
15748
15749 SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pydat3/,/pypars/,
15750 & /pyint1/,/pyint2/,/pyint3/,/pyint5/,/pyint7/,/pyintm/,
15751 & /pyismx/,/pyctag/
15752 SAVE xt2fac,sigs
15753
15754 ifail=0
15755C...Set MI subprocess = QCD 2 -> 2.
15756 isub=96
15757
15758C----------------------------------------------------------------------
15759C...MODE=-1: Initialize from scratch
15760 IF (mode.EQ.-1) THEN
15761C...Initialize PT2 array.
15762 pt2mi(1)=vint(54)
15763C...Initialize list of incoming beams and partons from two sides.
15764 DO 110 js=1,2
15765 DO 100 mi=1,240
15766 imi(js,mi,1)=0
15767 imi(js,mi,2)=0
15768 100 CONTINUE
15769 nmi(js)=1
15770 imi(js,1,1)=mint(84)+js
15771 imi(js,1,2)=0
15772 xmi(js,1)=vint(40+js)
15773C...Rescale x values to fractions of photon energy.
15774 IF(mint(18+js).EQ.1) xmi(js,1)=vint(40+js)/vint(154+js)
15775C...Hard reset: hard interaction initiators motherless by definition.
15776 k(mint(84)+js,3)=2+js
15777 k(mint(84)+js,4)=mod(k(mint(84)+js,4),mstu(5))
15778 k(mint(84)+js,5)=mod(k(mint(84)+js,5),mstu(5))
15779 110 CONTINUE
15780 imisep(0)=mint(84)
15781 imisep(1)=n
15782 IF (mod(mstp(81),10).GE.1) THEN
15783 IF(mstp(82).LE.1) THEN
15784 sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0
15785 & ,5))
15786 IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
15787 & vint(317)/(vint(318)*vint(320))
15788 xt2fac=sigrat*vint(149)/(1d0-vint(149))
15789 ELSE
15790 xt2fac=vint(146)*vint(148)*xsec(isub,1)/
15791 & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
15792 ENDIF
15793 ENDIF
15794C...Zero entries relating to scatterings beyond the first.
15795 DO 120 mi=2,240
15796 imi(1,mi,1)=0
15797 imi(2,mi,1)=0
15798 imi(1,mi,2)=0
15799 imi(2,mi,2)=0
15800 imisep(mi)=imisep(1)
15801 pt2mi(mi)=0d0
15802 xmi(1,mi)=0d0
15803 xmi(2,mi)=0d0
15804 120 CONTINUE
15805C...Initialize factors for PDF reshaping.
15806 DO 140 js=1,2
15807 kfbeam(js)=mint(10+js)
15808 IF(mint(18+js).EQ.1) kfbeam(js)=22
15809 kfabm=iabs(kfbeam(js))
15810 kfsbm=isign(1,kfbeam(js))
15811
15812C...Zero flavour content of incoming beam particle.
15813 kfival(js,1)=0
15814 kfival(js,2)=0
15815 kfival(js,3)=0
15816C... Flavour content of baryon.
15817 IF(kfabm.GT.1000) THEN
15818 kfival(js,1)=kfsbm*mod(kfabm/1000,10)
15819 kfival(js,2)=kfsbm*mod(kfabm/100,10)
15820 kfival(js,3)=kfsbm*mod(kfabm/10,10)
15821C... Flavour content of pi+-, K+-.
15822 ELSEIF(kfabm.EQ.211) THEN
15823 kfival(js,1)=kfsbm*2
15824 kfival(js,2)=-kfsbm
15825 ELSEIF(kfabm.EQ.321) THEN
15826 kfival(js,1)=-kfsbm*3
15827 kfival(js,2)=kfsbm*2
15828C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15829 ENDIF
15830
15831C...Zero initial valence and companion content.
15832 DO 130 ifl=-6,6
15833 nvc(js,ifl)=0
15834 130 CONTINUE
15835 140 CONTINUE
15836C...Set up colour line tags starting from hard interaction initiators.
15837 nct=0
15838C...Reset colour tag array and colour processing flags.
15839 DO 150 i=imisep(0)+1,n
15840 mct(i,1)=0
15841 mct(i,2)=0
15842 k(i,4)=mod(k(i,4),mstu(5)**2)
15843 k(i,5)=mod(k(i,5),mstu(5)**2)
15844 150 CONTINUE
15845C... Consider each side in turn.
15846 DO 170 js=1,2
15847 i1=imi(js,1,1)
15848 i2=imi(3-js,1,1)
15849 DO 160 jcs=4,5
15850 IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
15851 & GOTO 160
15852 IF (k(i1,jcs)/mstu(5)**2.NE.0) GOTO 160
15853 kcs=jcs
15854 CALL pycttr(i1,kcs,i2)
15855 IF(mint(51).NE.0) RETURN
15856 160 CONTINUE
15857 170 CONTINUE
15858
15859C...Range checking for companion quark pdf large-x param.
15860 IF (mstp(87).LT.0) THEN
15861 CALL pyerrm(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15862 & ' MSTP(87)=0')
15863 mstp(87)=0
15864 ELSEIF (mstp(87).GT.4) THEN
15865 CALL pyerrm(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15866 & ' MSTP(87)=4')
15867 mstp(87)=4
15868 ENDIF
15869
15870C----------------------------------------------------------------------
15871C...MODE=0: Generate trial interaction. Return codes:
15872C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15873C...IFAIL = 0: Additional interaction generated at PT2.
15874C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15875 ELSEIF (mode.EQ.0) THEN
15876C...Abolute MI max scale = VINT(62)
15877 xt2=4d0*min(pt2now,vint(62))/vint(2)
15878 180 IF(mstp(82).LE.1) THEN
15879 xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
15880 IF(xt2.LT.vint(149)) ifail=-2
15881 ELSE
15882 IF(xt2.LE.0.01001d0*vint(149)) THEN
15883 ifail=-3
15884 ELSE
15885 xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
15886 & log(pyr(0)))-vint(149)
15887 ENDIF
15888 ENDIF
15889C...Also exit if below lower limit or if higher trial branching
15890C...already found.
15891 pt2=0.25d0*vint(2)*xt2
15892 IF (pt2.LE.pt2cut) ifail=-4
15893 IF (pt2.LE.pt2mx) ifail=-5
15894 IF (ifail.NE.0) THEN
15895 pt2=0d0
15896 RETURN
15897 ENDIF
15898 IF(mstp(82).GE.2) pt2=max(0.25d0*vint(2)*0.01d0*vint(149),pt2)
15899 vint(25)=4d0*pt2/vint(2)
15900 xt2=vint(25)
15901
15902C...Choose tau and y*. Calculate cos(theta-hat).
15903 IF(pyr(0).LE.coef(isub,1)) THEN
15904 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
15905 tau=xt2*(1d0+taut)**2/(4d0*taut)
15906 ELSE
15907 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
15908 ENDIF
15909 vint(21)=tau
15910C...New: require shat > 1.
15911 IF(tau*vint(2).LT.1d0) GOTO 180
15912 CALL pyklim(2)
15913 ryst=pyr(0)
15914 myst=1
15915 IF(ryst.GT.coef(isub,8)) myst=2
15916 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
15917 CALL pykmap(2,myst,pyr(0))
15918 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
15919
15920C...Check that x not used up. Accept or reject kinematical variables.
15921 x1m=sqrt(tau)*exp(vint(22))
15922 x2m=sqrt(tau)*exp(-vint(22))
15923 IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) GOTO 180
15924 vint(71)=0.5d0*vint(1)*sqrt(xt2)
15925 CALL pysigh(nchn,sigs)
15926 IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
15927 IF(sigs.LT.xsec(isub,1)*pyr(0)) GOTO 180
15928 IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs/vint(320)
15929
15930C...Save if highest PT so far.
15931 IF (pt2.GT.pt2mx) THEN
15932 jsmx=0
15933 mimx=mint(31)+1
15934 pt2mx=pt2
15935 ENDIF
15936
15937C----------------------------------------------------------------------
15938C...MODE=1: Generate and save accepted scattering.
15939 ELSEIF (mode.EQ.1) THEN
15940 pt2=pt2now
15941C...Reset K, P, V, and MCT vectors.
15942 DO 200 i=n+1,n+4
15943 DO 190 j=1,5
15944 k(i,j)=0
15945 p(i,j)=0d0
15946 v(i,j)=0d0
15947 190 CONTINUE
15948 mct(i,1)=0
15949 mct(i,2)=0
15950 200 CONTINUE
15951
15952 ntry=0
15953C...Choose flavour of reacting partons (and subprocess).
15954 210 ntry=ntry+1
15955 IF (ntry.GT.50) THEN
15956 CALL pyerrm(9,'(PYPTMI:) Unable to generate additional '
15957 & //'interaction. Giving up!')
15958 mint(51)=1
15959 RETURN
15960 ENDIF
15961 rsigs=sigs*pyr(0)
15962 DO 220 ichn=1,nchn
15963 kfl1=isig(ichn,1)
15964 kfl2=isig(ichn,2)
15965 iconmi=isig(ichn,3)
15966 rsigs=rsigs-sigh(ichn)
15967 IF(rsigs.LE.0d0) GOTO 230
15968 220 CONTINUE
15969
15970C...Reassign to appropriate process codes.
15971 230 isubmi=iconmi/10
15972 iconmi=mod(iconmi,10)
15973
15974C...Choose new quark flavour for annihilation graphs
15975 IF(isubmi.EQ.12.OR.isubmi.EQ.53) THEN
15976 sh=vint(21)*vint(2)
15977 CALL pywidt(21,sh,wdtp,wdte)
15978 240 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
15979 DO 250 i=1,mdcy(21,3)
15980 kflf=kfdp(i+mdcy(21,2)-1,1)
15981 rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
15982 IF(rkfl.LE.0d0) GOTO 260
15983 250 CONTINUE
15984 260 IF(isubmi.EQ.53.AND.iconmi.LE.2) THEN
15985 IF(kflf.GE.4) GOTO 240
15986 ELSEIF(isubmi.EQ.53.AND.iconmi.LE.4) THEN
15987 kflf=4
15988 iconmi=iconmi-2
15989 ELSEIF(isubmi.EQ.53) THEN
15990 kflf=5
15991 iconmi=iconmi-4
15992 ENDIF
15993 ENDIF
15994
15995C...Final state flavours and colour flow: default values
15996 js=1
15997 kfl3=kfl1
15998 kfl4=kfl2
15999 kcc=20
16000 kcs=isign(1,kfl1)
16001
16002 IF(isubmi.EQ.11) THEN
16003C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16004 kcc=iconmi
16005 IF(kfl1*kfl2.LT.0) kcc=kcc+2
16006
16007 ELSEIF(isubmi.EQ.12) THEN
16008C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16009 kfl3=isign(kflf,kfl1)
16010 kfl4=-kfl3
16011 kcc=4
16012
16013 ELSEIF(isubmi.EQ.13) THEN
16014C...f + fbar -> g + g; th arbitrary
16015 kfl3=21
16016 kfl4=21
16017 kcc=iconmi+4
16018
16019 ELSEIF(isubmi.EQ.28) THEN
16020C...f + g -> f + g; th = (p(f)-p(f))**2
16021 IF(kfl1.EQ.21) js=2
16022 kcc=iconmi+6
16023 IF(kfl1.EQ.21) kcc=kcc+2
16024 IF(kfl1.NE.21) kcs=isign(1,kfl1)
16025 IF(kfl2.NE.21) kcs=isign(1,kfl2)
16026
16027 ELSEIF(isubmi.EQ.53) THEN
16028C...g + g -> f + fbar; th arbitrary
16029 kcs=(-1)**int(1.5d0+pyr(0))
16030 kfl3=isign(kflf,kcs)
16031 kfl4=-kfl3
16032 kcc=iconmi+10
16033
16034 ELSEIF(isubmi.EQ.68) THEN
16035C...g + g -> g + g; th arbitrary
16036 kcc=iconmi+12
16037 kcs=(-1)**int(1.5d0+pyr(0))
16038 ENDIF
16039
16040C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16041 IF (iabs(kfl3).EQ.4.OR.iabs(kfl4).EQ.4.OR.iabs(kfl3).EQ.5
16042 & .OR.iabs(kfl4).EQ.5) THEN
16043 rmmax2=max(pmas(pycomp(kfl3),1),pmas(pycomp(kfl4),1))**2
16044 IF (pt2.LE.1.05*rmmax2) THEN
16045 IF (ntry.EQ.2) CALL pyerrm(9,'(PYPTMI:) Heavy quarks'
16046 & //' too close to threshold (2nd try).')
16047 GOTO 210
16048 ENDIF
16049 ENDIF
16050
16051C...Store flavours of scattering.
16052 mint(13)=kfl1
16053 mint(14)=kfl2
16054 mint(15)=kfl1
16055 mint(16)=kfl2
16056 mint(21)=kfl3
16057 mint(22)=kfl4
16058
16059C...Set flavours and mothers of scattering partons.
16060 k(n+1,1)=14
16061 k(n+2,1)=14
16062 k(n+3,1)=3
16063 k(n+4,1)=3
16064 k(n+1,2)=kfl1
16065 k(n+2,2)=kfl2
16066 k(n+3,2)=kfl3
16067 k(n+4,2)=kfl4
16068 k(n+1,3)=mint(83)+1
16069 k(n+2,3)=mint(83)+2
16070 k(n+3,3)=n+1
16071 k(n+4,3)=n+2
16072
16073C...Store colour connection indices.
16074 DO 270 j=1,2
16075 jc=j
16076 IF(kcs.EQ.-1) jc=3-j
16077 IF(icol(kcc,1,jc).NE.0) k(n+1,j+3)=n+icol(kcc,1,jc)
16078 IF(icol(kcc,2,jc).NE.0) k(n+2,j+3)=n+icol(kcc,2,jc)
16079 IF(icol(kcc,3,jc).NE.0) k(n+3,j+3)=mstu(5)*(n+icol(kcc,3,jc))
16080 IF(icol(kcc,4,jc).NE.0) k(n+4,j+3)=mstu(5)*(n+icol(kcc,4,jc))
16081 270 CONTINUE
16082
16083C...Store incoming and outgoing partons in their CM-frame.
16084 shr=sqrt(vint(21))*vint(1)
16085 p(n+1,3)=0.5d0*shr
16086 p(n+1,4)=0.5d0*shr
16087 p(n+2,3)=-0.5d0*shr
16088 p(n+2,4)=0.5d0*shr
16089 p(n+3,5)=pymass(k(n+3,2))
16090 p(n+4,5)=pymass(k(n+4,2))
16091 IF(p(n+3,5)+p(n+4,5).GE.shr) THEN
16092 ifail=1
16093 RETURN
16094 ENDIF
16095 p(n+3,4)=0.5d0*(shr+(p(n+3,5)**2-p(n+4,5)**2)/shr)
16096 p(n+3,3)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,5)**2))
16097 p(n+4,4)=shr-p(n+3,4)
16098 p(n+4,3)=-p(n+3,3)
16099
16100C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16101 phi=paru(2)*pyr(0)
16102 CALL pyrobo(n+3,n+4,acos(vint(23)),phi,0d0,0d0,0d0)
16103
16104C...Global statistics.
16105 mint(351)=mint(351)+1
16106 vint(351)=vint(351)+sqrt(p(n+3,1)**2+p(n+3,2)**2)
16107 IF (mint(351).EQ.1) vint(356)=sqrt(p(n+3,1)**2+p(n+3,2)**2)
16108
16109C...Keep track of loose colour ends and information on scattering.
16110 mint(31)=mint(31)+1
16111 mint(36)=mint(31)
16112 pt2mi(mint(36))=pt2
16113 imisep(mint(31))=n+4
16114 DO 280 js=1,2
16115 imi(js,mint(31),1)=n+js
16116 imi(js,mint(31),2)=0
16117 xmi(js,mint(31))=vint(40+js)
16118 nmi(js)=nmi(js)+1
16119C...Update cumulative counters
16120 vint(142+js)=vint(142+js)-vint(40+js)
16121 vint(150+js)=vint(150+js)+vint(40+js)
16122 280 CONTINUE
16123
16124C...Add to list of final state partons
16125 ipart(npart+1)=n+3
16126 ipart(npart+2)=n+4
16127 ptpart(npart+1)=sqrt(pt2)
16128 ptpart(npart+2)=sqrt(pt2)
16129 npart=npart+2
16130
16131C...Initialize ISR
16132 nisgen(1,mint(31))=0
16133 nisgen(2,mint(31))=0
16134
16135C...Update ER
16136 n=n+4
16137 IF(n.GT.mstu(4)-mstu(32)-10) THEN
16138 CALL pyerrm(11,'(PYMIGN:) no more memory left in PYJETS')
16139 mint(51)=1
16140 RETURN
16141 ENDIF
16142
16143C...Finally, assign colour tags to new partons
16144 DO 300 js=1,2
16145 i1=imi(js,mint(31),1)
16146 i2=imi(3-js,mint(31),1)
16147 DO 290 jcs=4,5
16148 IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
16149 & GOTO 290
16150 IF (k(i1,jcs)/mstu(5)**2.NE.0) GOTO 290
16151 kcs=jcs
16152 CALL pycttr(i1,kcs,i2)
16153 IF(mint(51).NE.0) RETURN
16154 290 CONTINUE
16155 300 CONTINUE
16156
16157C----------------------------------------------------------------------
16158C...MODE=2: Decide whether quarks in last scattering were valence,
16159C...companion, or sea.
16160 ELSEIF (mode.EQ.2) THEN
16161 js=mint(30)
16162 mi=mint(36)
16163 pt2=pt2now
16164 kfsbm=isign(1,mint(10+js))
16165 ifl=k(imi(js,mi,1),2)
16166 imi(js,mi,2)=0
16167 IF (iabs(ifl).GE.6) THEN
16168 IF (iabs(ifl).EQ.6) THEN
16169 CALL pyerrm(29,'(PYPTMI:) top in initial state!')
16170 ENDIF
16171 RETURN
16172 ENDIF
16173C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16174C...(Do not include the parton itself in the X rescaling.)
16175 x=xmi(js,mi)
16176 xrsc=x/(vint(142+js)+x)
16177C...Note: XPSVC = x*pdf.
16178 mint(30)=js
16179 CALL pypdfu(kfbeam(js),xrsc,pt2,xpq)
16180 sea=xpsvc(ifl,-1)
16181 val=xpsvc(ifl,0)
16182C...Ensure that pdfs are positive definite
16183 IF (sea.LT.0d0) THEN
16184 CALL pyerrm(9,'(PYPTMI:) Sea distribution negative.')
16185 sea=max(0d0,sea)
16186 ELSEIF (val.LT.0d0) THEN
16187 CALL pyerrm(9,'(PYPTMI:) Val distribution negative.')
16188 val=max(0d0,val)
16189 ENDIF
16190 cmp=0d0
16191 DO 310 ivc=1,nvc(js,ifl)
16192 cmp=cmp+xpsvc(ifl,ivc)
16193 310 CONTINUE
16194
16195 ntry=0
16196C...Decide (Extra factor x cancels in the dvision).
16197 320 rvcs=pyr(0)*(sea+val+cmp)
16198 ivnow=1
16199 ntry=ntry+1
16200 330 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
16201C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16202 ivnow=0
16203 IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
16204 IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
16205 IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
16206 IF(kfival(js,1).EQ.0) THEN
16207 IF(kfbeam(js).EQ.111.AND.iabs(ifl).LE.2) ivnow=1
16208 IF(kfbeam(js).EQ.22.AND.iabs(ifl).LE.5) ivnow=1
16209 IF((kfbeam(js).EQ.130.OR.kfbeam(js).EQ.310).AND.
16210 & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
16211 ELSE
16212C...Count down valence remaining. Do not count current scattering.
16213 DO 340 i1=1,nmi(js)
16214 IF (i1.EQ.mint(36)) GOTO 340
16215 IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
16216 & ivnow=ivnow-1
16217 340 CONTINUE
16218 ENDIF
16219 IF(ivnow.EQ.0) GOTO 330
16220C...Mark valence.
16221 imi(js,mi,2)=0
16222C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16223 IF(kfival(js,1).EQ.0) THEN
16224 IF(kfbeam(js).EQ.111.OR.kfbeam(js).EQ.22) THEN
16225 kfival(js,1)=ifl
16226 kfival(js,2)=-ifl
16227 ELSEIF(kfbeam(js).EQ.130.OR.kfbeam(js).EQ.310) THEN
16228 kfival(js,1)=ifl
16229 IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
16230 IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
16231 ENDIF
16232 ENDIF
16233
16234 ELSEIF (rvcs.LE.val+sea) THEN
16235C...If sea, add opposite sign companion parton. Store X and I.
16236 nvc(js,-ifl)=nvc(js,-ifl)+1
16237 xassoc(js,-ifl,nvc(js,-ifl))=xmi(js,mi)
16238C...Set pointer to companion
16239 imi(js,mi,2)=-nvc(js,-ifl)
16240
16241 ELSE
16242C...If companion, check whether we've got any in the books
16243 IF (nvc(js,ifl).EQ.0) THEN
16244 cmp=0d0
16245C...Only report error first time for this event
16246 IF (ntry.EQ.1)
16247 & CALL pyerrm(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16248C...Try a few times
16249 IF (ntry.LE.10) THEN
16250 GOTO 320
16251C... But if it stil fails, abort this event
16252 ELSE
16253 mint(51)=1
16254 RETURN
16255 ENDIF
16256 ENDIF
16257C...If several possibilities, decide which one
16258 cmpsum=val+sea
16259 isel=0
16260 350 isel=isel+1
16261 cmpsum=cmpsum+xpsvc(ifl,isel)
16262 IF (rvcs.GT.cmpsum.AND.isel.LT.nvc(js,ifl)) GOTO 350
16263C...Find original sea (anti-)quark. Do not consider current scattering.
16264 iassoc=0
16265 DO 360 i1=1,nmi(js)
16266 IF (i1.EQ.mint(36)) GOTO 360
16267 IF (k(imi(js,i1,1),2).NE.-ifl) GOTO 360
16268 IF (-imi(js,i1,2).EQ.isel) THEN
16269 imi(js,mi,2)=imi(js,i1,1)
16270 imi(js,i1,2)=imi(js,mi,1)
16271 ENDIF
16272 360 CONTINUE
16273C...Mark companion "out-kicked".
16274 xassoc(js,ifl,isel)=-xassoc(js,ifl,isel)
16275 ENDIF
16276
16277 ENDIF
16278 RETURN
16279 END
16280
16281C*********************************************************************
16282
16283C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16284C...Giving the x*f pdf of a companion quark, with its partner at XS,
16285C...using an approximate gluon density like (1-X)^NPOW/X. The value
16286C...corresponds to an unrescaled range between 0 and 1-X.
16287
16288 FUNCTION pyfcmp(XC,XS,NPOW)
16289 IMPLICIT NONE
16290 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16291 INTEGER NPOW
16292
16293 pyfcmp=0d0
16294C...Parent gluon momentum fraction
16295 y=xc+xs
16296 IF (y.GE.1d0) RETURN
16297C...Common factor (includes factor XC, since PYFCMP=x*f)
16298 fac=3d0*xc*xs*(xc**2+xs**2)/(y**4)
16299C...Store normalized companion x*f distribution.
16300 IF (npow.LE.0) THEN
16301 pyfcmp=fac/(2d0-xs*(3d0-xs*(3d0-2d0*xs)))
16302 ELSEIF (npow.EQ.1) THEN
16303 pyfcmp=fac*(1d0-y)/(2d0+xs**2*(-3d0+xs)+3d0*xs*log(xs))
16304 ELSEIF (npow.EQ.2) THEN
16305 pyfcmp=fac*(1d0-y)**2/(2d0*((1d0-xs)*(1d0+xs*(4d0+xs))
16306 & +3d0*xs*(1d0+xs)*log(xs)))
16307 ELSEIF (npow.EQ.3) THEN
16308 pyfcmp=fac*(1d0-y)**3*2d0/(4d0+27d0*xs-31d0*xs**3
16309 & +6d0*xs*log(xs)*(3d0+2d0*xs*(3d0+xs)))
16310 ELSEIF (npow.GE.4) THEN
16311 pyfcmp=fac*(1d0-y)**4/(2d0*(1d0+2d0*xs)*((1d0-xs)*(1d0+
16312 & xs*(10d0+xs))+6d0*xs*log(xs)*(1d0+xs)))
16313 ENDIF
16314 RETURN
16315 END
16316
16317C*********************************************************************
16318
16319C...PYPCMP: Auxiliary to PYPDFU.
16320C...Giving the momentum integral of a companion quark, with its
16321C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16322C...The value corresponds to an unrescaled range between 0 and 1-XS.
16323
16324 FUNCTION pypcmp(XS,NPOW)
16325 IMPLICIT NONE
16326 DOUBLE PRECISION XS, PYPCMP
16327 INTEGER NPOW
16328 IF (xs.GE.1d0.OR.xs.LE.0d0) THEN
16329 pypcmp=0d0
16330 ELSEIF (npow.LE.0) THEN
16331 pypcmp=xs*(5d0+xs*(-9d0-2d0*xs*(-3d0+xs))+3d0*log(xs))
16332 pypcmp=pypcmp/((-1d0+xs)*(2d0+xs*(-1d0+2d0*xs)))
16333 ELSEIF (npow.EQ.1) THEN
16334 pypcmp=-1d0-3d0*xs+(2d0*(-1d0+xs)**2*(1d0+xs+xs**2))
16335 & /(2d0+xs**2*(xs-3d0)+3d0*xs*log(xs))
16336 ELSEIF (npow.EQ.2) THEN
16337 pypcmp=xs*((1d0-xs)*(19d0+xs*(43d0+4d0*xs))
16338 & +6d0*log(xs)*(1d0+6d0*xs+4d0*xs**2))
16339 pypcmp=pypcmp/(4d0*((xs-1d0)*(1d0+xs*(4d0+xs))
16340 & -3d0*xs*log(xs)*(1+xs)))
16341 ELSEIF (npow.EQ.3) THEN
16342 pypcmp=3d0*xs*((xs-1)*(7d0+xs*(28d0+13d0*xs))
16343 & -2d0*log(xs)*(1d0+xs*(9d0+2d0*xs*(6d0+xs))))
16344 pypcmp=pypcmp/(4d0+27d0*xs-31d0*xs**3
16345 & +6d0*xs*log(xs)*(3d0+2d0*xs*(3d0+xs)))
16346 ELSE
16347 pypcmp=(-9d0*xs*(xs**2-1d0)*(5d0+xs*(24d0+xs))+12d0*xs*log(xs)
16348 & *(1d0+2d0*xs)*(1d0+2d0*xs*(5d0+2d0*xs)))
16349 pypcmp=pypcmp/(8d0*(1d0+2d0*xs)*((xs-1d0)*(1d0+xs*(10d0+xs))
16350 & -6d0*xs*log(xs)*(1d0+xs)))
16351 ENDIF
16352 RETURN
16353 END
16354
16355C*********************************************************************
16356
16357C...PYUPRE
16358C...Rearranges contents of the HEPEUP commonblock so that
16359C...mothers precede daughters and daughters of a decay are
16360C...listed consecutively.
16361
16362 SUBROUTINE pyupre
16363
16364C...Double precision and integer declarations.
16365 IMPLICIT DOUBLE PRECISION(a-h, o-z)
16366 IMPLICIT INTEGER(I-N)
16367
16368C...User process event common block.
16369 INTEGER MAXNUP
16370 parameter(maxnup=500)
16371 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16372 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16373 common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
16374 &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
16375 &vtimup(maxnup),spinup(maxnup)
16376 SAVE /hepeup/
16377
16378C...Local arrays.
16379 dimension newpos(0:maxnup),idupt(maxnup),istupt(maxnup),
16380 &motupt(2,maxnup),icoupt(2,maxnup),pupt(5,maxnup),
16381 &vtiupt(maxnup),spiupt(maxnup)
16382
16383C...Check whether a rearrangement is required.
16384 need=0
16385 DO 100 iup=1,nup
16386 IF(mothup(1,iup).GT.iup) need=need+1
16387 100 CONTINUE
16388 DO 110 iup=2,nup
16389 IF(mothup(1,iup).LT.mothup(1,iup-1)) need=need+1
16390 110 CONTINUE
16391
16392 IF(need.NE.0) THEN
16393C...Find the new order that particles should have.
16394 newpos(0)=0
16395 nnew=0
16396 inew=-1
16397 120 inew=inew+1
16398 DO 130 iup=1,nup
16399 IF(mothup(1,iup).EQ.newpos(inew)) THEN
16400 nnew=nnew+1
16401 newpos(nnew)=iup
16402 ENDIF
16403 130 CONTINUE
16404 IF(inew.LT.nnew.AND.inew.LT.nup) GOTO 120
16405 IF(nnew.NE.nup) THEN
16406 CALL pyerrm(2,
16407 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16408 RETURN
16409 ENDIF
16410
16411C...Copy old info into temporary storage.
16412 DO 150 i=1,nup
16413 idupt(i)=idup(i)
16414 istupt(i)=istup(i)
16415 motupt(1,i)=mothup(1,i)
16416 motupt(2,i)=mothup(2,i)
16417 icoupt(1,i)=icolup(1,i)
16418 icoupt(2,i)=icolup(2,i)
16419 DO 140 j=1,5
16420 pupt(j,i)=pup(j,i)
16421 140 CONTINUE
16422 vtiupt(i)=vtimup(i)
16423 spiupt(i)=spinup(i)
16424 150 CONTINUE
16425
16426C...Copy info back into HEPEUP in right order.
16427 DO 180 i=1,nup
16428 iold=newpos(i)
16429 idup(i)=idupt(iold)
16430 istup(i)=istupt(iold)
16431 mothup(1,i)=0
16432 mothup(2,i)=0
16433 DO 160 imot=1,i-1
16434 IF(motupt(1,iold).EQ.newpos(imot)) mothup(1,i)=imot
16435 IF(motupt(2,iold).EQ.newpos(imot)) mothup(2,i)=imot
16436 160 CONTINUE
16437 IF(mothup(2,i).GT.0.AND.mothup(2,i).LT.mothup(1,i)) THEN
16438 mothsw=mothup(1,i)
16439 mothup(1,i)=mothup(2,i)
16440 mothup(2,i)=mothsw
16441 ENDIF
16442 icolup(1,i)=icoupt(1,iold)
16443 icolup(2,i)=icoupt(2,iold)
16444 DO 170 j=1,5
16445 pup(j,i)=pupt(j,iold)
16446 170 CONTINUE
16447 vtimup(i)=vtiupt(iold)
16448 spinup(i)=spiupt(iold)
16449 180 CONTINUE
16450 ENDIF
16451
16452c...If incoming particles are massive recalculate to put them massless.
16453 IF(pup(5,1).NE.0d0.OR.pup(5,2).NE.0d0) THEN
16454 pplus=(pup(4,1)+pup(3,1))+(pup(4,2)+pup(3,2))
16455 pminus=(pup(4,1)-pup(3,1))+(pup(4,2)-pup(3,2))
16456 pup(4,1)=0.5d0*pplus
16457 pup(3,1)=pup(4,1)
16458 pup(5,1)=0d0
16459 pup(4,2)=0.5d0*pminus
16460 pup(3,2)=-pup(4,2)
16461 pup(5,2)=0d0
16462 ENDIF
16463
16464 RETURN
16465 END
16466
16467C*********************************************************************
16468
16469C...PYADSH
16470C...Administers the generation of successive final-state showers
16471C...in external processes.
16472
16473 SUBROUTINE pyadsh(NFIN)
16474
16475C...Double precision and integer declarations.
16476 IMPLICIT DOUBLE PRECISION(a-h, o-z)
16477 IMPLICIT INTEGER(I-N)
16478 INTEGER PYK,PYCHGE,PYCOMP
16479C...Parameter statement for maximum size of showers.
16480 parameter(maxnur=1000)
16481C...Commonblocks.
16482 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
16483 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16484 common/pyctag/nct,mct(4000,2)
16485 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16486 common/pypars/mstp(200),parp(200),msti(200),pari(200)
16487 common/pyint1/mint(400),vint(400)
16488 SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pypars/,/pyint1/
16489C...Local array.
16490 dimension ibeg(100),ksav(100,5),psum(4),beta(3)
16491
16492C...Set primary vertex.
16493 DO 100 j=1,5
16494 v(mint(83)+5,j)=0d0
16495 v(mint(83)+6,j)=0d0
16496 v(mint(84)+1,j)=0d0
16497 v(mint(84)+2,j)=0d0
16498 100 CONTINUE
16499
16500C...Isolate systems of particles with the same mother.
16501 nsys=0
16502 ims=-1
16503 DO 140 i=mint(84)+3,nfin
16504 im=k(i,3)
16505 IF(im.GT.0.AND.im.LE.mint(84)) im=k(im,3)
16506 IF(im.NE.ims) THEN
16507 nsys=nsys+1
16508 ibeg(nsys)=i
16509 ims=im
16510 ENDIF
16511
16512C...Set production vertices.
16513 IF(im.LE.mint(83)+6.OR.(im.GT.mint(84).AND.im.LE.mint(84)+2))
16514 & THEN
16515 DO 110 j=1,4
16516 v(i,j)=0d0
16517 110 CONTINUE
16518 ELSE
16519 DO 120 j=1,4
16520 v(i,j)=v(im,j)+v(im,5)*p(im,j)/p(im,5)
16521 120 CONTINUE
16522 ENDIF
16523 IF(mstp(125).GE.1) THEN
16524 idoc=i-mstp(126)+4
16525 DO 130 j=1,5
16526 v(idoc,j)=v(i,j)
16527 130 CONTINUE
16528 ENDIF
16529 140 CONTINUE
16530
16531C...End loop over systems. Return if no showers to be performed.
16532 ibeg(nsys+1)=nfin+1
16533 IF(mstp(71).LE.0) RETURN
16534
16535C...Loop through systems of particles; check that sensible size.
16536 DO 270 isys=1,nsys
16537 nsiz=ibeg(isys+1)-ibeg(isys)
16538 IF(mint(35).LE.2) THEN
16539 IF(nsiz.EQ.1.AND.isys.EQ.1) THEN
16540 GOTO 270
16541 ELSEIF(nsiz.LE.1) THEN
16542 CALL pyerrm(2,'(PYADSH:) only one particle in system')
16543 GOTO 270
16544 ELSEIF(nsiz.GT.80) THEN
16545 CALL pyerrm(2,'(PYADSH:) more than 80 particles in system')
16546 GOTO 270
16547 ENDIF
16548 ENDIF
16549
16550C...Save status codes and daughters of showering particles; reset them.
16551 DO 150 j=1,4
16552 psum(j)=0d0
16553 150 CONTINUE
16554 DO 170 ii=1,nsiz
16555 i=ibeg(isys)-1+ii
16556 ksav(ii,1)=k(i,1)
16557 IF(k(i,1).GT.10) THEN
16558 k(i,1)=1
16559 IF(ksav(ii,1).EQ.14) k(i,1)=3
16560 ENDIF
16561 IF(ksav(ii,1).LE.10) THEN
16562 ELSEIF(k(i,1).EQ.1) THEN
16563 ksav(ii,4)=k(i,4)
16564 ksav(ii,5)=k(i,5)
16565 k(i,4)=0
16566 k(i,5)=0
16567 ELSE
16568 ksav(ii,4)=mod(k(i,4),mstu(5))
16569 ksav(ii,5)=mod(k(i,5),mstu(5))
16570 k(i,4)=k(i,4)-ksav(ii,4)
16571 k(i,5)=k(i,5)-ksav(ii,5)
16572 ENDIF
16573 DO 160 j=1,4
16574 psum(j)=psum(j)+p(i,j)
16575 160 CONTINUE
16576 170 CONTINUE
16577
16578C...Perform shower.
16579 qmax=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-
16580 & psum(3)**2))
16581 IF(isys.EQ.1) qmax=min(qmax,sqrt(parp(71))*vint(55))
16582 nsav=n
16583 IF(mint(35).LE.2) THEN
16584 IF(nsiz.EQ.2) THEN
16585 CALL pyshow(ibeg(isys),ibeg(isys)+1,qmax)
16586 ELSE
16587 CALL pyshow(ibeg(isys),-nsiz,qmax)
16588 ENDIF
16589
16590C...For external processes, first call, also ISR partons radiate.
16591C...Can use existing PYPART list, removing partons that radiate later.
16592 ELSEIF(isys.EQ.1) THEN
16593 npartn=0
16594 DO 175 ii=1,npart
16595 IF(ipart(ii).LT.ibeg(2).OR.ipart(ii).GE.ibeg(nsys+1)) THEN
16596 npartn=npartn+1
16597 ipart(npartn)=ipart(ii)
16598 ptpart(npartn)=ptpart(ii)
16599 ENDIF
16600 175 CONTINUE
16601 npart=npartn
16602 CALL pyptfs(1,0.5d0*qmax,0d0,ptgen)
16603 ELSE
16604C...For subsequent calls use the systems excluded above.
16605 npart=nsiz
16606 npartd=0
16607 DO 180 ii=1,nsiz
16608 i=ibeg(isys)-1+ii
16609 ipart(ii)=i
16610 ptpart(ii)=0.5d0*qmax
16611 180 CONTINUE
16612 CALL pyptfs(2,0.5d0*qmax,0d0,ptgen)
16613 ENDIF
16614
16615C...Look up showered copies of original showering particles.
16616 DO 260 ii=1,nsiz
16617 i=ibeg(isys)-1+ii
16618 imv=i
16619C...Particles without daughters need not be studied.
16620 IF(ksav(ii,1).LE.10) GOTO 260
16621 IF(n.EQ.nsav.OR.k(i,1).LE.10) THEN
16622 ELSEIF(k(i,1).EQ.11) THEN
16623 190 imv=mod(k(imv,4),mstu(5))
16624 IF(k(imv,1).EQ.11) GOTO 190
16625 ELSE
16626 kda1=mod(k(i,4),mstu(5))
16627 IF(kda1.GT.0) THEN
16628 IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
16629 ENDIF
16630 kda2=mod(k(i,5),mstu(5))
16631 IF(kda2.GT.0) THEN
16632 IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
16633 ENDIF
16634 DO 200 i3=i+1,n
16635 IF(k(i3,2).EQ.k(i,2).AND.(i3.EQ.kda1.OR.i3.EQ.kda2))
16636 & THEN
16637 imv=i3
16638 kda1=mod(k(i3,4),mstu(5))
16639 IF(kda1.GT.0) THEN
16640 IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
16641 ENDIF
16642 kda2=mod(k(i3,5),mstu(5))
16643 IF(kda2.GT.0) THEN
16644 IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
16645 ENDIF
16646 ENDIF
16647 200 CONTINUE
16648 ENDIF
16649
16650C...Restore daughter info of original partons to showered copies.
16651 IF(ksav(ii,1).GT.10) k(imv,1)=ksav(ii,1)
16652 IF(ksav(ii,1).LE.10) THEN
16653 ELSEIF(k(i,1).EQ.1) THEN
16654 k(imv,4)=ksav(ii,4)
16655 k(imv,5)=ksav(ii,5)
16656 ELSE
16657 k(imv,4)=k(imv,4)+ksav(ii,4)
16658 k(imv,5)=k(imv,5)+ksav(ii,5)
16659 ENDIF
16660
16661C...Reset mother info of existing daughters to showered copies.
16662 DO 210 i3=ibeg(isys+1),nfin
16663 IF(k(i3,3).EQ.i) k(i3,3)=imv
16664 IF(k(i3,1).EQ.3.OR.k(i3,1).EQ.14) THEN
16665 IF(k(i3,4)/mstu(5).EQ.i) k(i3,4)=k(i3,4)+mstu(5)*(imv-i)
16666 IF(k(i3,5)/mstu(5).EQ.i) k(i3,5)=k(i3,5)+mstu(5)*(imv-i)
16667 ENDIF
16668 210 CONTINUE
16669
16670C...Boost all original daughters to new frame of showered copy.
16671C...Also update their colour tags.
16672 IF(imv.NE.i) THEN
16673 DO 220 j=1,3
16674 beta(j)=(p(imv,j)-p(i,j))/(p(imv,4)+p(i,4))
16675 220 CONTINUE
16676 fac=2d0/(1d0+beta(1)**2+beta(2)**2+beta(3)**2)
16677 DO 230 j=1,3
16678 beta(j)=fac*beta(j)
16679 230 CONTINUE
16680 DO 250 i3=ibeg(isys+1),nfin
16681 imo=i3
16682 240 imo=k(imo,3)
16683 IF(mstp(128).LE.0) THEN
16684 IF(imo.GT.0.AND.imo.NE.i.AND.imo.NE.k(i,3)) GOTO 240
16685 IF(imo.EQ.i.OR.(k(i,3).LE.mint(84).AND.imo.EQ.k(i,3)))
16686 & THEN
16687 CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
16688 IF(mct(i3,1).EQ.mct(i,1)) mct(i3,1)=mct(imv,1)
16689 IF(mct(i3,2).EQ.mct(i,2)) mct(i3,2)=mct(imv,2)
16690 ENDIF
16691 ELSE
16692 IF(imo.EQ.imv) THEN
16693 CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
16694 IF(mct(i3,1).EQ.mct(i,1)) mct(i3,1)=mct(imv,1)
16695 IF(mct(i3,2).EQ.mct(i,2)) mct(i3,2)=mct(imv,2)
16696 ELSEIF(imo.GT.0.AND.imo.NE.i.AND.imo.NE.k(i,3)) THEN
16697 GOTO 240
16698 ENDIF
16699 ENDIF
16700 250 CONTINUE
16701 ENDIF
16702 260 CONTINUE
16703
16704C...End of loop over showering systems
16705 270 CONTINUE
16706
16707 RETURN
16708 END
16709
16710C*********************************************************************
16711
16712C...PYVETO
16713C...Interface to UPVETO, which allows user to veto event generation
16714C...on the parton level, after parton showers but before multiple
16715C...interactions, beam remnants and hadronization is added.
16716
16717 SUBROUTINE pyveto(IVETO)
16718
16719C...All real arithmetic in double precision.
16720 IMPLICIT DOUBLE PRECISION(a-h, o-z)
16721C...Three Pythia functions return integers, so need declaring.
16722 INTEGER PYK,PYCHGE,PYCOMP
16723
16724C...PYTHIA commonblocks.
16725 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16726 common/pypars/mstp(200),parp(200),msti(200),pari(200)
16727 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16728 common/pyint1/mint(400),vint(400)
16729 SAVE /pyjets/,/pypars/,/pyint1/
16730C...HEPEVT commonblock.
16731 parameter(nmxhep=4000)
16732 common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
16733 &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
16734 DOUBLE PRECISION PHEP,VHEP
16735 SAVE /hepevt/
16736C...Local array.
16737 dimension ireso(100)
16738
16739C...Define longitudinal boost from initiator rest frame to cm frame.
16740 gamma=0.5d0*(vint(141)+vint(142))/sqrt(vint(141)*vint(142))
16741 gabez=0.5d0*(vint(141)-vint(142))/sqrt(vint(141)*vint(142))
16742
16743C...Presentation is different if using pT-ordered shower
16744 IF(mint(35).EQ.3) THEN
16745 gamma=1d0
16746 gabez=0d0
16747 ENDIF
16748
16749C... Reset counters.
16750 nevhep=0
16751 nhep=0
16752 nreso=0
16753
16754C...Oth pass: identify beam and incoming partons
16755 DO 140 i=mint(83)+1,mint(83)+6
16756 istore=0
16757 IF(k(i,2).EQ.94) THEN
16758
16759 ELSE
16760 nreso=nreso+1
16761 ireso(nreso)=i
16762 imoth=k(i,3)
16763 ENDIF
16764 140 CONTINUE
16765
16766C...First pass: identify final locations of resonances
16767C...and of their daughters before showering.
16768 DO 150 i=mint(84)+3,n
16769 istore=0
16770 imoth=0
16771
16772C...Skip shower CM frame documentation lines.
16773 IF(k(i,2).EQ.94) THEN
16774
16775C... Store a new intermediate product, when mother in documentation.
16776 ELSEIF(mstp(128).EQ.0.AND.k(i,3).GT.mint(83)+6.AND.
16777 & k(i,3).LE.mint(84)) THEN
16778 istore=1
16779 nhep=nhep+1
16780 ii=nhep
16781 nreso=nreso+1
16782 ireso(nreso)=i
16783 imoth=max(0,k(k(i,3),3)-(mint(83)+6))
16784
16785C... Store a new intermediate product, when mother in main section.
16786 ELSEIF(mstp(128).EQ.1.AND.k(i-mint(84)+mint(83)+4,1).EQ.21.AND.
16787 & k(i-mint(84)+mint(83)+4,2).EQ.k(i,2)) THEN
16788 istore=1
16789 nhep=nhep+1
16790 ii=nhep
16791 nreso=nreso+1
16792 ireso(nreso)=i
16793 imoth=max(0,k(i-mint(84)+mint(83)+4,3)-(mint(83)+6))
16794 ENDIF
16795
16796 IF(istore.EQ.1) THEN
16797C...Copy parton info, boosting momenta along z axis to cm frame.
16798 isthep(ii)=2
16799 idhep(ii)=k(i,2)
16800 phep(1,ii)=p(i,1)
16801 phep(2,ii)=p(i,2)
16802 phep(3,ii)=gamma*p(i,3)+gabez*p(i,4)
16803 phep(4,ii)=gamma*p(i,4)+gabez*p(i,3)
16804 phep(5,ii)=p(i,5)
16805C...Store one mother. Rest of history and vertex info zeroed.
16806 jmohep(1,ii)=imoth
16807 jmohep(2,ii)=0
16808 jdahep(1,ii)=0
16809 jdahep(2,ii)=0
16810 vhep(1,ii)=0d0
16811 vhep(2,ii)=0d0
16812 vhep(3,ii)=0d0
16813 vhep(4,ii)=0d0
16814 ENDIF
16815 150 CONTINUE
16816
16817C...Second pass: identify current set of "final" partons.
16818 DO 200 i=mint(84)+3,n
16819 istore=0
16820 imoth=0
16821
16822C...Store a final parton.
16823 IF(k(i,1).GE.1.AND.k(i,1).LE.10) THEN
16824 istore=1
16825 nhep=nhep+1
16826 ii=nhep
16827C..Trace it back through shower, to check if from documented particle.
16828 ihist=i
16829 isave=ihist
16830 160 CONTINUE
16831 IF(ihist.GT.mint(84)) THEN
16832 IF(k(ihist,2).EQ.94) ihist=k(ihist,3)+(isave-1-ihist)
16833 DO 170 iri=1,nreso
16834 IF(ihist.EQ.ireso(iri)) imoth=iri
16835 170 CONTINUE
16836 isave=ihist
16837 ihist=k(ihist,3)
16838 IF(imoth.EQ.0) GOTO 160
16839 imoth=max(0,imoth-6)
16840 ELSEIF(ihist.LE.4) THEN
16841 IF(ihist.EQ.1.OR.ihist.EQ.2) THEN
16842 istore=0
16843 nhep=nhep-1
16844 ELSE
16845 imoth=0
16846 ENDIF
16847 ENDIF
16848 ENDIF
16849
16850 IF(istore.EQ.1) THEN
16851C...Copy parton info, boosting momenta along z axis to cm frame.
16852 isthep(ii)=1
16853 idhep(ii)=k(i,2)
16854 phep(1,ii)=p(i,1)
16855 phep(2,ii)=p(i,2)
16856 phep(3,ii)=gamma*p(i,3)+gabez*p(i,4)
16857 phep(4,ii)=gamma*p(i,4)+gabez*p(i,3)
16858 phep(5,ii)=p(i,5)
16859C...Store one mother. Rest of history and vertex info zeroed.
16860 jmohep(1,ii)=imoth
16861 jmohep(2,ii)=0
16862 jdahep(1,ii)=0
16863 jdahep(2,ii)=0
16864 vhep(1,ii)=0d0
16865 vhep(2,ii)=0d0
16866 vhep(3,ii)=0d0
16867 vhep(4,ii)=0d0
16868 ENDIF
16869 200 CONTINUE
16870C...Call user-written routine to decide whether to keep events.
16871 CALL upveto(iveto)
16872 RETURN
16873 END
16874C*********************************************************************
16875
16876C...PYRESD
16877C...Allows resonances to decay (including parton showers for hadronic
16878C...channels).
16879
16880 SUBROUTINE pyresd(IRES)
16881
16882C...Double precision and integer declarations.
16883 IMPLICIT DOUBLE PRECISION(a-h, o-z)
16884 IMPLICIT INTEGER(I-N)
16885 INTEGER PYK,PYCHGE,PYCOMP
16886C...Parameter statement to help give large particle numbers.
16887 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
16888 &kexcit=4000000,kdimen=5000000)
16889C...Parameter statement for maximum size of showers.
16890 parameter(maxnur=1000)
16891C...Commonblocks.
16892 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
16893 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
16894 common/pyctag/nct,mct(4000,2)
16895 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
16896 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
16897 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
16898 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
16899 common/pypars/mstp(200),parp(200),msti(200),pari(200)
16900 common/pyint1/mint(400),vint(400)
16901 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
16902 common/pyint4/mwid(500),wids(500,5)
16903 common/pypued/iued(0:99),rued(0:99)
16904 SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pydat2/,/pydat3/,
16905 &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint4/,/pypued/
16906C...Local arrays and complex and character variables.
16907 dimension iref(50,8),kdcy(3),kfl1(3),kfl2(3),kfl3(3),keql(3),
16908 &kcqm(3),kcq1(3),kcq2(3),kcq3(3),nsd(3),pmmn(3),ilin(6),
16909 &hgz(3,3),coup(6,4),corl(2,2,2),pk(6,4),pkk(6,6),cthe(3),
16910 &phi(3),wdtp(0:400),wdte(0:400,0:5),dpmo(5),xm(5),vdcy(4),
16911 &itjunc(3),ctm2(3),kcq(0:10),iant(3),itri(3),ioct(3)
16912 COMPLEX FGK,HA(6,6),HC(6,6)
16913 REAL TIR,UIR
16914 CHARACTER CODE*9,MASS*9
16915
16916C...The F, Xi and Xj functions of Gunion and Kunszt
16917C...(Phys. Rev. D33, 665, plus errata from the authors).
16918 fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)*
16919 &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))
16920 digk(dt,du)=-4d0*d34*d56+dt*(3d0*dt+4d0*du)+dt**2*(dt*du/
16921 &(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+2d0*(d34/d56+d56/d34))
16922 djgk(dt,du)=8d0*(d34+d56)**2-8d0*(d34+d56)*(dt+du)-6d0*dt*du-
16923 &2d0*dt*du*(dt*du/(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+
16924 &2d0*(d34/d56+d56/d34))
16925
16926C...Some general constants.
16927 xw=paru(102)
16928 xwv=xw
16929 IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
16930 xw1=1d0-xw
16931 sqmz=pmas(23,1)**2
16932
16933 gmmz=pmas(23,1)*pmas(23,2)
16934 sqmw=pmas(24,1)**2
16935 gmmw=pmas(24,1)*pmas(24,2)
16936 sh=vint(44)
16937
16938C...Boost and rotate to rest frame of incoming partons,
16939C...to get proper amount of smearing of decay angles.
16940 ibst=0
16941 IF(ires.EQ.0) THEN
16942 ibst=1
16943 iin1=mint(84)+1
16944 iin2=mint(84)+2
16945C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
16946C...(101,102) are off shell and can have inconsistent momenta, resulting
16947C...in boosts larger than unity. However, the corresponding docu partons
16948C...(5,6) are kept on shell, and have consistent momenta that can be used
16949C...to derive this boost instead. Ultimately, should change the way the new
16950C...shower stores intermediate partons, but just using partons (5,6) for now
16951C...does define the boost and furnishes a quick and much needed solution.
16952 IF (mint(35).EQ.3) THEN
16953 iin1=mint(83)+5
16954 iin2=mint(83)+6
16955 ENDIF
16956 etotin=p(iin1,4)+p(iin2,4)
16957 bexin=(p(iin1,1)+p(iin2,1))/etotin
16958 beyin=(p(iin1,2)+p(iin2,2))/etotin
16959 bezin=(p(iin1,3)+p(iin2,3))/etotin
16960 CALL pyrobo(mint(83)+7,n,0d0,0d0,-bexin,-beyin,-bezin)
16961 phiin=pyangl(p(mint(84)+1,1),p(mint(84)+1,2))
16962 CALL pyrobo(mint(83)+7,n,0d0,-phiin,0d0,0d0,0d0)
16963 thein=pyangl(p(mint(84)+1,3),p(mint(84)+1,1))
16964 CALL pyrobo(mint(83)+7,n,-thein,0d0,0d0,0d0,0d0)
16965 ENDIF
16966
16967C...Reset original resonance configuration.
16968 DO 100 jt=1,8
16969 iref(1,jt)=0
16970 100 CONTINUE
16971
16972C...Define initial one, two or three objects for subprocess.
16973 ihdec=0
16974 IF(ires.EQ.0) THEN
16975 isub=mint(1)
16976 IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
16977 iref(1,1)=mint(84)+2+iset(isub)
16978 iref(1,4)=mint(83)+6+iset(isub)
16979 jtmax=1
16980 ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN
16981 iref(1,1)=mint(84)+1+iset(isub)
16982 iref(1,2)=mint(84)+2+iset(isub)
16983 iref(1,4)=mint(83)+5+iset(isub)
16984 iref(1,5)=mint(83)+6+iset(isub)
16985 jtmax=2
16986 ELSEIF(iset(isub).EQ.5) THEN
16987 iref(1,1)=mint(84)+3
16988 iref(1,2)=mint(84)+4
16989 iref(1,3)=mint(84)+5
16990 iref(1,4)=mint(83)+7
16991 iref(1,5)=mint(83)+8
16992 iref(1,6)=mint(83)+9
16993 jtmax=3
16994 ENDIF
16995
16996C...Define original resonance for odd cases.
16997 ELSE
16998 isub=0
16999 IF(k(ires,2).EQ.25.OR.k(ires,2).EQ.35.OR.k(ires,2).EQ.36)
17000 & ihdec=1
17001 IF(ihdec.EQ.1) isub=3
17002 iref(1,1)=ires
17003 iref(1,4)=k(ires,3)
17004 irestm=ires
17005 IF(iref(1,4).GT.mint(84)) THEN
17006 110 itmpmo=iref(1,4)
17007 IF(k(itmpmo,2).EQ.94) THEN
17008 iref(1,4)=k(itmpmo,3)+(irestm-itmpmo-1)
17009 IF(k(iref(1,4),3).LE.mint(84)) iref(1,4)=k(iref(1,4),3)
17010 ELSEIF(k(itmpmo,2).EQ.k(ires,2)) THEN
17011 irestm=itmpmo
17012C...Explicitly check that reference particle exists, otherwise stop recursion
17013 IF(itmpmo.GT.0.AND.k(itmpmo,3).GT.0) THEN
17014 iref(1,4)=k(itmpmo,3)
17015 GOTO 110
17016 ENDIF
17017 ENDIF
17018 ENDIF
17019 IF(iref(1,4).GT.mint(84)) THEN
17020 ematch=1d10
17021 iref14=iref(1,4)
17022 DO 120 ii=mint(83)+7,mint(83)+mint(4)
17023 IF(k(ii,2).EQ.k(ires,2).AND.abs(p(ii,4)-p(iref14,4)).LT.
17024 & ematch) THEN
17025 iref(1,4)=ii
17026 ematch=abs(p(ii,4)-p(iref14,4))
17027 ENDIF
17028 120 CONTINUE
17029 ENDIF
17030 jtmax=1
17031 ENDIF
17032
17033C...Check if initial resonance has been moved (in resonance + jet).
17034 DO 140 jt=1,3
17035 IF(iref(1,jt).GT.0) THEN
17036 IF(k(iref(1,jt),1).GT.10) THEN
17037 kfa=iabs(k(iref(1,jt),2))
17038 IF(kfa.GE.6.AND.kchg(pycomp(kfa),2).NE.0) THEN
17039 kda1=mod(k(iref(1,jt),4),mstu(5))
17040 kda2=mod(k(iref(1,jt),5),mstu(5))
17041 IF(kda1.GT.iref(1,jt).AND.kda1.LE.n) THEN
17042 IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
17043 ENDIF
17044 IF(kda2.GT.iref(1,jt).AND.kda2.LE.n) THEN
17045 IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
17046 ENDIF
17047 DO 130 i=iref(1,jt)+1,n
17048 IF(k(i,2).EQ.k(iref(1,jt),2).AND.(i.EQ.kda1.OR.
17049 & i.EQ.kda2)) THEN
17050 iref(1,jt)=i
17051 kda1=mod(k(iref(1,jt),4),mstu(5))
17052 kda2=mod(k(iref(1,jt),5),mstu(5))
17053 IF(kda1.GT.iref(1,jt).AND.kda1.LE.n) THEN
17054 IF(k(kda1,2).EQ.21) kda1=k(kda1,5)/mstu(5)
17055 ENDIF
17056 IF(kda2.GT.iref(1,jt).AND.kda2.LE.n) THEN
17057 IF(k(kda2,2).EQ.21) kda2=k(kda2,4)/mstu(5)
17058 ENDIF
17059 ENDIF
17060 130 CONTINUE
17061 ELSE
17062 kda=mod(k(iref(1,jt),4),mstu(5))
17063 IF(mwid(pycomp(kfa)).NE.0.AND.kda.GT.1) iref(1,jt)=kda
17064 ENDIF
17065 ENDIF
17066 ENDIF
17067 140 CONTINUE
17068
17069C...Set decay vertex for initial resonances
17070 DO 160 jt=1,jtmax
17071 DO 150 i=1,4
17072 v(iref(1,jt),i)=0d0
17073 150 CONTINUE
17074 160 CONTINUE
17075
17076C...Loop over decay history.
17077 np=1
17078 ip=0
17079 170 ip=ip+1
17080 ninh=0
17081 jtmax=2
17082 IF(iref(ip,2).EQ.0) jtmax=1
17083 IF(iref(ip,3).NE.0) jtmax=3
17084 it4=0
17085 nsav=n
17086
17087C...Check for Higgs which appears as decay product of user-process.
17088 IF(isub.EQ.0) THEN
17089 ihdec=0
17090 IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)
17091 & .EQ.36) ihdec=1
17092 IF(ihdec.EQ.1) isub=3
17093 ENDIF
17094
17095C...Start treatment of one, two or three resonances in parallel.
17096 180 n=nsav
17097 DO 340 jt=1,jtmax
17098 id=iref(ip,jt)
17099 kdcy(jt)=0
17100 kfl1(jt)=0
17101 kfl2(jt)=0
17102 kfl3(jt)=0
17103 keql(jt)=0
17104 nsd(jt)=id
17105 itjunc(jt)=0
17106
17107C...Check whether particle can/is allowed to decay.
17108 IF(id.EQ.0) GOTO 330
17109 kfa=iabs(k(id,2))
17110 kca=pycomp(kfa)
17111 IF(mwid(kca).EQ.0) GOTO 330
17112 IF(k(id,1).GT.10.OR.mdcy(kca,1).EQ.0) GOTO 330
17113 IF(kfa.EQ.6.OR.kfa.EQ.7.OR.kfa.EQ.8.OR.kfa.EQ.17.OR.
17114 & kfa.EQ.18) it4=it4+1
17115 k(id,4)=mstu(5)*(k(id,4)/mstu(5))
17116 k(id,5)=mstu(5)*(k(id,5)/mstu(5))
17117
17118C...Choose lifetime and determine decay vertex.
17119 IF(k(id,1).EQ.5) THEN
17120 v(id,5)=0d0
17121 ELSEIF(k(id,1).NE.4) THEN
17122 v(id,5)=-pmas(kca,4)*log(pyr(0))
17123 ENDIF
17124 DO 190 j=1,4
17125 vdcy(j)=v(id,j)+v(id,5)*p(id,j)/p(id,5)
17126 190 CONTINUE
17127
17128C...Determine whether decay allowed or not.
17129 mout=0
17130 IF(mstj(22).EQ.2) THEN
17131 IF(pmas(kca,4).GT.parj(71)) mout=1
17132 ELSEIF(mstj(22).EQ.3) THEN
17133 IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
17134 ELSEIF(mstj(22).EQ.4) THEN
17135 IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
17136 IF(abs(vdcy(3)).GT.parj(74)) mout=1
17137 ENDIF
17138 IF(mout.EQ.1.AND.k(id,1).NE.5) THEN
17139 k(id,1)=4
17140 GOTO 330
17141 ENDIF
17142
17143C...Info for selection of decay channel: sign, pairings.
17144 IF(kchg(kca,3).EQ.0) THEN
17145 ipm=2
17146 ELSE
17147 ipm=(5-isign(1,k(id,2)))/2
17148 ENDIF
17149 kfb=0
17150 IF(jtmax.EQ.2) THEN
17151 kfb=iabs(k(iref(ip,3-jt),2))
17152 ELSEIF(jtmax.EQ.3) THEN
17153 jt2=jt+1-3*(jt/3)
17154 kfb=iabs(k(iref(ip,jt2),2))
17155 IF(kfb.NE.kfa) THEN
17156 jt2=jt+2-3*((jt+1)/3)
17157 kfb=iabs(k(iref(ip,jt2),2))
17158 ENDIF
17159 ENDIF
17160
17161C...Select decay channel.
17162 IF(isub.EQ.1.OR.isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.
17163 & isub.EQ.30.OR.isub.EQ.35.OR.isub.EQ.141) mint(61)=1
17164 CALL pywidt(kfa,p(id,5)**2,wdtp,wdte)
17165 wdte0s=wdte(0,1)+wdte(0,ipm)+wdte(0,4)
17166 IF(kfb.EQ.kfa) wdte0s=wdte0s+wdte(0,5)
17167 IF(wdte0s.LE.0d0) GOTO 330
17168 rkfl=wdte0s*pyr(0)
17169 idl=0
17170 200 idl=idl+1
17171 idc=idl+mdcy(kca,2)-1
17172 rkfl=rkfl-(wdte(idl,1)+wdte(idl,ipm)+wdte(idl,4))
17173 IF(kfb.EQ.kfa) rkfl=rkfl-wdte(idl,5)
17174 IF(idl.LT.mdcy(kca,3).AND.rkfl.GT.0d0) GOTO 200
17175
17176C...Read out flavours and colour charges of decay channel chosen.
17177 kcqm(jt)=kchg(kca,2)*isign(1,k(id,2))
17178 IF(kcqm(jt).EQ.-2) kcqm(jt)=2
17179 kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))
17180 kfc1a=pycomp(iabs(kfl1(jt)))
17181 IF(kchg(kfc1a,3).EQ.0) kfl1(jt)=iabs(kfl1(jt))
17182 kcq1(jt)=kchg(kfc1a,2)*isign(1,kfl1(jt))
17183 IF(kcq1(jt).EQ.-2) kcq1(jt)=2
17184 kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))
17185 kfc2a=pycomp(iabs(kfl2(jt)))
17186 IF(kchg(kfc2a,3).EQ.0) kfl2(jt)=iabs(kfl2(jt))
17187 kcq2(jt)=kchg(kfc2a,2)*isign(1,kfl2(jt))
17188 IF(kcq2(jt).EQ.-2) kcq2(jt)=2
17189 kfl3(jt)=kfdp(idc,3)*isign(1,k(id,2))
17190 kcq3(jt)=0
17191 IF(kfl3(jt).NE.0) THEN
17192 kfc3a=pycomp(iabs(kfl3(jt)))
17193 IF(kchg(kfc3a,3).EQ.0) kfl3(jt)=iabs(kfl3(jt))
17194 kcq3(jt)=kchg(kfc3a,2)*isign(1,kfl3(jt))
17195 IF(kcq3(jt).EQ.-2) kcq3(jt)=2
17196 ENDIF
17197
17198C...Set/save further info on channel.
17199 kdcy(jt)=1
17200 IF(kfb.EQ.kfa) keql(jt)=mdme(idc,1)
17201 nsd(jt)=n
17202 hgz(jt,1)=vint(111)
17203 hgz(jt,2)=vint(112)
17204 hgz(jt,3)=vint(114)
17205 jtz=jt
17206
17207C...Select masses; to begin with assume resonances narrow.
17208 DO 220 i=1,3
17209 p(n+i,5)=0d0
17210 pmmn(i)=0d0
17211 IF(i.EQ.1) THEN
17212 kflw=iabs(kfl1(jt))
17213 kcw=kfc1a
17214 ELSEIF(i.EQ.2) THEN
17215 kflw=iabs(kfl2(jt))
17216 kcw=kfc2a
17217 ELSEIF(i.EQ.3) THEN
17218 IF(kfl3(jt).EQ.0) GOTO 220
17219 kflw=iabs(kfl3(jt))
17220 kcw=kfc3a
17221 ENDIF
17222 p(n+i,5)=pmas(kcw,1)
17223CMRENNA++
17224C...This prevents SUSY/t particles from becoming too light.
17225 IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN
17226 pmmn(i)=pmas(kcw,1)
17227 DO 210 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1
17228 IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN
17229 pmsum=pmas(pycomp(kfdp(idc,1)),1)+
17230 & pmas(pycomp(kfdp(idc,2)),1)
17231 IF(kfdp(idc,3).NE.0) pmsum=pmsum+
17232 & pmas(pycomp(kfdp(idc,3)),1)
17233 pmmn(i)=min(pmmn(i),pmsum)
17234 ENDIF
17235 210 CONTINUE
17236C MRENNA--
17237 ELSEIF(kflw.EQ.6) THEN
17238 pmmn(i)=pmas(24,1)+pmas(5,1)
17239 ENDIF
17240C...UED: select a graviton mass from continuous distribution
17241C...(stored in PMAS(39,1) so no value returned)
17242 IF (iued(1).EQ.1.AND.iued(2).EQ.1.AND.kflw.EQ.39)
17243 & CALL pygram(1)
17244 220 CONTINUE
17245
17246C...Check which two out of three are widest.
17247 iwid1=1
17248 iwid2=2
17249 pwid1=pmas(kfc1a,2)
17250 pwid2=pmas(kfc2a,2)
17251 kflw1=iabs(kfl1(jt))
17252 kflw2=iabs(kfl2(jt))
17253 IF(kfl3(jt).NE.0) THEN
17254 pwid3=pmas(kfc3a,2)
17255 IF(pwid3.GT.pwid1.AND.pwid2.GE.pwid1) THEN
17256 iwid1=3
17257 pwid1=pwid3
17258 kflw1=iabs(kfl3(jt))
17259 ELSEIF(pwid3.GT.pwid2) THEN
17260 iwid2=3
17261 pwid2=pwid3
17262 kflw2=iabs(kfl3(jt))
17263 ENDIF
17264 ENDIF
17265
17266C...If all narrow then only check that masses consistent.
17267 IF(mstp(42).LE.0.OR.(pwid1.LT.parp(41).AND.
17268 & pwid2.LT.parp(41))) THEN
17269CMRENNA++
17270C....Handle near degeneracy cases.
17271 IF(kfa/ksusy1.EQ.1.OR.kfa/ksusy1.EQ.2) THEN
17272 IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN
17273 p(n+1,5)=p(id,5)-p(n+2,5)-0.5d0
17274 IF(p(n+1,5).LT.0d0) p(n+1,5)=0d0
17275 ENDIF
17276 ENDIF
17277CMRENNA--
17278 IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN
17279 CALL pyerrm(13,'(PYRESD:) daughter masses too large')
17280 mint(51)=1
17281 GOTO 720
17282 ELSEIF(p(n+1,5)+p(n+2,5)+p(n+3,5)+parj(64).GT.p(id,5)) THEN
17283 CALL pyerrm(3,'(PYRESD:) daughter masses too large')
17284 mint(51)=1
17285 GOTO 720
17286 ENDIF
17287
17288C...For three wide resonances select narrower of three
17289C...according to BW decoupled from rest.
17290 ELSE
17291 pmtot=p(id,5)
17292 IF(kfl3(jt).NE.0) THEN
17293 iwid3=6-iwid1-iwid2
17294 kflw3=iabs(kfl1(jt))+iabs(kfl2(jt))+iabs(kfl3(jt))-
17295 & kflw1-kflw2
17296 loop=0
17297 230 loop=loop+1
17298 p(n+iwid3,5)=pymass(kflw3)
17299 IF(loop.LE.10.AND. p(n+iwid3,5).LE.pmmn(iwid3)) GOTO 230
17300 pmtot=pmtot-p(n+iwid3,5)
17301 ENDIF
17302C...Select other two correlated within remaining phase space.
17303 IF(ip.EQ.1) THEN
17304 ckin45=ckin(45)
17305 ckin47=ckin(47)
17306 ckin(45)=max(pmmn(iwid1),ckin(45))
17307 ckin(47)=max(pmmn(iwid2),ckin(47))
17308 CALL pyofsh(2,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
17309 & p(n+iwid2,5))
17310 ckin(45)=ckin45
17311 ckin(47)=ckin47
17312 ELSE
17313 ckin(49)=pmmn(iwid1)
17314 ckin(50)=pmmn(iwid2)
17315 CALL pyofsh(5,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),
17316 & p(n+iwid2,5))
17317 ckin(49)=0d0
17318 ckin(50)=0d0
17319 ENDIF
17320 IF(mint(51).EQ.1) GOTO 720
17321 ENDIF
17322
17323C...Begin fill decay products, with colour flow for coloured objects.
17324 mstu10=mstu(10)
17325 mstu(10)=1
17326 mstu(19)=1
17327
17328C...Three-body decays
17329 IF(kfl3(jt).NE.0) THEN
17330 DO 250 i=n+1,n+3
17331 DO 240 j=1,5
17332 k(i,j)=0
17333 v(i,j)=0d0
17334 240 CONTINUE
17335 mct(i,1)=0
17336 mct(i,2)=0
17337 250 CONTINUE
17338 k(n+1,1)=1
17339 k(n+1,2)=kfl1(jt)
17340 k(n+2,1)=1
17341 k(n+2,2)=kfl2(jt)
17342 k(n+3,1)=1
17343 k(n+3,2)=kfl3(jt)
17344 idin=id
17345
17346C...Generate kinematics (default is flat)
17347 CALL pytbdy(idin)
17348
17349C...Set generic colour flows whenever unambiguous,
17350C...(independently of the order of the decay products)
17351C...Sum up total colour content
17352 nant=0
17353 ntri=0
17354 noct=0
17355 kcq(0)=kcqm(jt)
17356 kcq(1)=kcq1(jt)
17357 kcq(2)=kcq2(jt)
17358 kcq(3)=kcq3(jt)
17359 DO 255 j=0,3
17360 IF (kcq(j).EQ.-1) THEN
17361 nant=nant+1
17362 iant(nant)=n+j
17363 ELSEIF (kcq(j).EQ.1) THEN
17364 ntri=ntri+1
17365 itri(ntri)=n+j
17366 ELSEIF (kcq(j).EQ.2) THEN
17367 noct=noct+1
17368 ioct(noct)=n+j
17369 ENDIF
17370 255 CONTINUE
17371
17372C...Set color flow for generic 1 -> N processes (N arbitrary)
17373 IF (ntri.EQ.0.AND.nant.EQ.0.AND.noct.EQ.0) THEN
17374C...All singlets: do nothing
17375
17376 ELSEIF (noct.EQ.2.AND.ntri.EQ.0.AND.nant.EQ.0) THEN
17377C...Two octets, zero triplets, n singlets:
17378 IF (kcq(0).EQ.2) THEN
17379C...8 -> 8 + n(1)
17380 k(id,4)=k(id,4)+ioct(2)
17381 k(id,5)=k(id,5)+ioct(2)
17382 k(ioct(2),1)=3
17383 k(ioct(2),4)=mstu(5)*id
17384 k(ioct(2),5)=mstu(5)*id
17385 mct(ioct(2),1)=mct(id,1)
17386 mct(ioct(2),2)=mct(id,2)
17387 ELSE
17388C...1 -> 8 + 8 + n(1)
17389 k(ioct(1),1)=3
17390 k(ioct(1),4)=mstu(5)*ioct(2)
17391 k(ioct(1),5)=mstu(5)*ioct(2)
17392 k(ioct(2),1)=3
17393 k(ioct(2),4)=mstu(5)*ioct(1)
17394 k(ioct(2),5)=mstu(5)*ioct(1)
17395 nct=nct+1
17396 mct(ioct(1),1)=nct
17397 mct(ioct(2),2)=nct
17398 nct=nct+1
17399 mct(ioct(2),1)=nct
17400 mct(ioct(1),2)=nct
17401 ENDIF
17402
17403 ELSEIF (ntri+nant.EQ.2.AND.noct.EQ.0) THEN
17404C...Two triplets, zero octets, n singlets.
17405 IF (kcq(0).EQ.1) THEN
17406C...3 -> 3 + n(1)
17407 k(id,4)=k(id,4)+itri(2)
17408 k(itri(2),1)=3
17409 k(itri(2),4)=mstu(5)*id
17410 mct(itri(2),1)=mct(id,1)
17411 ELSEIF (kcq(0).EQ.-1) THEN
17412C...3bar -> 3bar + n(1)
17413 k(id,5)=k(id,5)+iant(2)
17414 k(iant(2),1)=3
17415 k(iant(2),5)=mstu(5)*id
17416 mct(iant(2),2)=mct(id,2)
17417 ELSE
17418C...1 -> 3 + 3bar + n(1)
17419 k(itri(1),1)=3
17420 k(itri(1),4)=mstu(5)*iant(1)
17421 k(iant(1),1)=3
17422 k(iant(1),5)=mstu(5)*itri(1)
17423 nct=nct+1
17424 mct(itri(1),1)=nct
17425 mct(iant(1),2)=nct
17426 ENDIF
17427
17428 ELSEIF(ntri+nant.EQ.2.AND.noct.EQ.1) THEN
17429C...Two triplets, one octet, n singlets.
17430 IF (kcq(0).EQ.2) THEN
17431C...8 -> 3 + 3bar + n(1)
17432 k(id,4)=k(id,4)+itri(1)
17433 k(id,5)=k(id,5)+iant(1)
17434 k(itri(1),1)=3
17435 k(itri(1),4)=mstu(5)*id
17436 k(iant(1),1)=3
17437 k(iant(1),5)=mstu(5)*id
17438 mct(itri(1),1)=mct(id,1)
17439 mct(iant(1),2)=mct(id,2)
17440 ELSEIF (kcq(0).EQ.1) THEN
17441C...3 -> 8 + 3 + n(1)
17442 k(id,4)=k(id,4)+ioct(1)
17443 k(ioct(1),1)=3
17444 k(ioct(1),4)=mstu(5)*id
17445 k(ioct(1),5)=mstu(5)*itri(2)
17446 k(itri(2),1)=3
17447 k(itri(2),4)=mstu(5)*ioct(1)
17448 mct(ioct(1),1)=mct(id,1)
17449 nct=nct+1
17450 mct(ioct(1),2)=nct
17451 mct(itri(2),1)=nct
17452 ELSEIF (kcq(0).EQ.-1) THEN
17453C...3bar -> 8 + 3bar + n(1)
17454 k(id,5)=k(id,5)+ioct(1)
17455 k(ioct(1),1)=3
17456 k(ioct(1),5)=mstu(5)*id
17457 k(ioct(1),4)=mstu(5)*iant(2)
17458 k(iant(2),1)=3
17459 k(iant(2),5)=mstu(5)*ioct(1)
17460 mct(ioct(1),2)=mct(id,2)
17461 nct=nct+1
17462 mct(ioct(1),1)=nct
17463 mct(iant(2),2)=nct
17464 ELSE
17465C...1 -> 3 + 3bar + 8 + n(1)
17466 k(itri(1),1)=3
17467 k(itri(1),4)=mstu(5)*ioct(1)
17468 k(ioct(1),1)=3
17469 k(ioct(1),5)=mstu(5)*itri(1)
17470 k(ioct(1),4)=mstu(5)*iant(1)
17471 k(iant(1),1)=3
17472 k(iant(1),5)=mstu(5)*ioct(1)
17473 nct=nct+1
17474 mct(itri(1),1)=nct
17475 mct(ioct(1),2)=nct
17476 nct=nct+1
17477 mct(ioct(1),1)=nct
17478 mct(iant(1),2)=nct
17479 ENDIF
17480CPS-- End of generic cases
17481C...(could three octets also be handled?)
17482C...(could (some of) the RPV cases be made generic as well?)
17483
17484C...Special cases (= old treatment)
17485C...Set colour flow for t -> W + b + Z.
17486 ELSEIF(kfa.EQ.6) THEN
17487 k(n+2,1)=3
17488 isid=4
17489 IF(kcqm(jt).EQ.-1) isid=5
17490 idau=n+2
17491 k(id,isid)=k(id,isid)+idau
17492 k(idau,isid)=mstu(5)*id
17493
17494C...Set colour flow in three-body decays - programmed as special cases.
17495
17496 ELSEIF(kfc2a.LE.6) THEN
17497 k(n+2,1)=3
17498 k(n+3,1)=3
17499 isid=4
17500 IF(kfl2(jt).LT.0) isid=5
17501 k(n+2,isid)=mstu(5)*(n+3)
17502 k(n+3,9-isid)=mstu(5)*(n+2)
17503C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17504 ELSEIF(kfa.GT.ksusy1.AND.mod(kfa,ksusy1).LT.10
17505 & .AND.kfl3(jt).NE.0) THEN
17506 kqsuma=iabs(kcq1(jt))+iabs(kcq2(jt))+iabs(kcq3(jt))
17507C...3-body decays of squarks to colour singlets plus one quark
17508 IF (kqsuma.EQ.1) THEN
17509C...Find quark
17510 iq=0
17511 IF (kcq1(jt).NE.0) iq=1
17512 IF (kcq2(jt).NE.0) iq=2
17513 IF (kcq3(jt).NE.0) iq=3
17514 isid=4
17515 IF (k(n+iq,2).LT.0) isid=5
17516 k(n+iq,1)=3
17517 k(id,isid)=k(id,isid)+(n+iq)
17518 k(n+iq,isid)=mstu(5)*id
17519 ENDIF
17520C...PS--
17521 ELSEIF(kfl1(jt).EQ.ksusy1+21) THEN
17522 k(n+1,1)=3
17523 k(n+2,1)=3
17524 k(n+3,1)=3
17525 isid=4
17526 IF(kfl2(jt).LT.0) isid=5
17527 k(n+1,isid)=mstu(5)*(n+2)
17528 k(n+1,9-isid)=mstu(5)*(n+3)
17529 k(n+2,isid)=mstu(5)*(n+1)
17530 k(n+3,9-isid)=mstu(5)*(n+1)
17531 ELSEIF(kfa.EQ.ksusy1+21) THEN
17532 k(n+2,1)=3
17533 k(n+3,1)=3
17534 isid=4
17535 IF(kfl2(jt).LT.0) isid=5
17536 k(id,isid)=k(id,isid)+(n+2)
17537 k(id,9-isid)=k(id,9-isid)+(n+3)
17538 k(n+2,isid)=mstu(5)*id
17539 k(n+3,9-isid)=mstu(5)*id
17540CMRENNA--
17541
17542 ELSEIF(kfa.GE.ksusy1+22.AND.kfa.LE.ksusy1+37.AND.
17543 & iabs(kcq2(jt)).EQ.1) THEN
17544 k(n+2,1)=3
17545 k(n+3,1)=3
17546 isid=4
17547 IF(kfl2(jt).LT.0) isid=5
17548 k(n+2,isid)=mstu(5)*(n+3)
17549 k(n+3,9-isid)=mstu(5)*(n+2)
17550 ENDIF
17551
17552 nsav=n
17553
17554C...Set colour flow in three-body decays with baryon number violation.
17555C...Neutralino and chargino decays first.
17556 kcqsum=kcq1(jt)+kcq2(jt)+kcq3(jt)
17557 IF(kcqm(jt).EQ.0.AND.iabs(kcqsum).EQ.3) THEN
17558 itjunc(jt)=(1+(1-kcq1(jt))/2)
17559 k(n+4,4)=itjunc(jt)*mstu(5)
17560C...Insert junction to keep track of colours.
17561 IF(kcq1(jt).NE.0) k(n+1,1)=3
17562 IF(kcq2(jt).NE.0) k(n+2,1)=3
17563 IF(kcq3(jt).NE.0) k(n+3,1)=3
17564C...Set special junction codes:
17565 k(n+4,1)=42
17566 k(n+4,2)=88
17567
17568C...Order decay products by invariant mass. (will be used in PYSTRF).
17569 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)-
17570 & p(n+1,3)*p(n+2,3)
17571 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)-
17572 & p(n+1,3)*p(n+3,3)
17573 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)-
17574 & p(n+2,3)*p(n+3,3)
17575 IF(pm12.LT.pm13.AND.pm12.LT.pm23) THEN
17576 k(n+4,4)=n+3+k(n+4,4)
17577 k(n+4,5)=n+1+mstu(5)*(n+2)
17578 ELSEIF(pm13.LT.pm23) THEN
17579 k(n+4,4)=n+2+k(n+4,4)
17580 k(n+4,5)=n+1+mstu(5)*(n+3)
17581 ELSE
17582 k(n+4,4)=n+1+k(n+4,4)
17583 k(n+4,5)=n+2+mstu(5)*(n+3)
17584 ENDIF
17585 DO 260 j=1,5
17586 p(n+4,j)=0d0
17587 v(n+4,j)=0d0
17588 260 CONTINUE
17589C...Connect daughters to junction.
17590 DO 270 ii=n+1,n+3
17591 k(ii,4)=0
17592 k(ii,5)=0
17593 k(ii,itjunc(jt)+3)=mstu(5)*(n+4)
17594 270 CONTINUE
17595C...Particle counter should be stepped up one extra for junction.
17596 n=n+1
17597
17598C...Gluino decays.
17599 ELSEIF (kcqm(jt).EQ.2.AND.iabs(kcqsum).EQ.3) THEN
17600 itjunc(jt)=(5+(1-kcq1(jt))/2)
17601 k(n+4,4)=itjunc(jt)*mstu(5)
17602C...Insert junction to keep track of colours.
17603 IF(kcq1(jt).NE.0) k(n+1,1)=3
17604 IF(kcq2(jt).NE.0) k(n+2,1)=3
17605 IF(kcq3(jt).NE.0) k(n+3,1)=3
17606 k(n+4,1)=42
17607 k(n+4,2)=88
17608 DO 280 j=1,5
17609 p(n+4,j)=0d0
17610 v(n+4,j)=0d0
17611 280 CONTINUE
17612 ctmsum=0d0
17613 DO 290 ii=n+1,n+3
17614 k(ii,4)=0
17615 k(ii,5)=0
17616C...Start by connecting all daughters to junction.
17617 k(ii,itjunc(jt)-1)=mstu(5)*(n+4)
17618C...Only consider colour topologies with off shell resonances.
17619 rmq1=pmas(pycomp(k(ii,2)),1)
17620 rmres=pmas(pycomp(ksusy1+iabs(k(ii,2))),1)
17621 rmglu=pmas(pycomp(ksusy1+21),1)
17622 IF (rmglu-rmq1.LT.rmres) THEN
17623C...Calculate propagators for each colour topology.
17624 rm2q23=rmglu**2+rmq1**2-2d0*(p(ii,4)*p(id,4)+p(ii,1)
17625 & *p(id,1)+p(ii,2)*p(id,2)+p(ii,3)*p(id,3))
17626 ctm2(ii-n)=1d0/(rm2q23-rmres**2)**2
17627 ELSE
17628 ctm2(ii-n)=0d0
17629 ENDIF
17630 ctmsum=ctmsum+ctm2(ii-n)
17631 290 CONTINUE
17632 ctmsum=pyr(0)*ctmsum
17633C...Select colour topology J, with most off shell least likely.
17634 j=0
17635 300 j=j+1
17636 ctmsum=ctmsum-ctm2(j)
17637 IF (ctmsum.GT.0d0) GOTO 300
17638C...The lucky winner gets its colour (anti-colour) directly from gluino.
17639 k(n+j,itjunc(jt)-1)=mstu(5)*id
17640 k(id,itjunc(jt)-1)=n+j+(k(id,itjunc(jt)-1)/mstu(5))*mstu(5)
17641C...The other gluino colour is connected to junction
17642 k(id,10-itjunc(jt))=n+4+(k(id,10-itjunc(jt))/mstu(5))*
17643 & mstu(5)
17644 k(n+4,4)=k(n+4,4)+id
17645C...Lastly, connect junction to remaining daughters.
17646 k(n+4,5)=n+1+mod(j,3)+mstu(5)*(n+1+mod(j+1,3))
17647C...Particle counter should be stepped up one extra for junction.
17648 n=n+1
17649 ENDIF
17650
17651C...Update particle counter.
17652 n=n+3
17653
17654C...2) Everything else two-body decay.
17655 ELSE
17656 CALL py2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))
17657 mct(n-1,1)=0
17658 mct(n-1,2)=0
17659 mct(n,1)=0
17660 mct(n,2)=0
17661C...First set colour flow as if mother colour singlet.
17662 IF(kcq1(jt).NE.0) THEN
17663 k(n-1,1)=3
17664 IF(kcq1(jt).NE.-1) k(n-1,4)=mstu(5)*n
17665 IF(kcq1(jt).NE.1) k(n-1,5)=mstu(5)*n
17666 ENDIF
17667 IF(kcq2(jt).NE.0) THEN
17668 k(n,1)=3
17669 IF(kcq2(jt).NE.-1) k(n,4)=mstu(5)*(n-1)
17670 IF(kcq2(jt).NE.1) k(n,5)=mstu(5)*(n-1)
17671 ENDIF
17672C...Then redirect colour flow if mother (anti)triplet.
17673 IF(kcqm(jt).EQ.0) THEN
17674 ELSEIF(kcqm(jt).NE.2) THEN
17675 isid=4
17676 IF(kcqm(jt).EQ.-1) isid=5
17677 idau=n-1
17678 IF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.2) idau=n
17679 k(id,isid)=k(id,isid)+idau
17680 k(idau,isid)=mstu(5)*id
17681C...Then redirect colour flow if mother octet.
17682 ELSEIF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.0) THEN
17683 idau=n-1
17684 IF(kcq1(jt).EQ.0) idau=n
17685 k(id,4)=k(id,4)+idau
17686 k(id,5)=k(id,5)+idau
17687 k(idau,4)=mstu(5)*id
17688 k(idau,5)=mstu(5)*id
17689 ELSE
17690 isid=4
17691 IF(kcq1(jt).EQ.-1) isid=5
17692 IF(kcq1(jt).EQ.2) isid=int(4.5d0+pyr(0))
17693 k(id,isid)=k(id,isid)+(n-1)
17694 k(id,9-isid)=k(id,9-isid)+n
17695 k(n-1,isid)=mstu(5)*id
17696 k(n,9-isid)=mstu(5)*id
17697 ENDIF
17698
17699C...Insert junction
17700 IF(iabs(kcq1(jt)+kcq2(jt)-kcqm(jt)).EQ.3) THEN
17701 n=n+1
17702C...~q* mother: type 3 junction. ~q mother: type 4.
17703 itjunc(jt)=(7+kcqm(jt))/2
17704C...Specify junction KF and set colour flow from junction
17705 k(n,1)=42
17706 k(n,2)=88
17707 k(n,3)=id
17708C...Junction type encoded together with mother:
17709 k(n,4)=id+itjunc(jt)*mstu(5)
17710 k(n,5)=n-1+mstu(5)*(n-2)
17711C...Zero P and V for junction (V filled later)
17712 DO 310 j=1,5
17713 p(n,j)=0d0
17714 v(n,j)=0d0
17715 310 CONTINUE
17716C...Set colour flow from mother to junction
17717 k(id,8-itjunc(jt))= n + mstu(5)*(k(id,8-itjunc(jt))/mstu(5))
17718C...Set colour flow from daughters to junction
17719 DO 320 ii=n-2,n-1
17720 k(ii,4) = 0
17721 k(ii,5) = 0
17722C...(Anti-)colour mother is junction.
17723 k(ii,1+itjunc(jt)) = mstu(5)*(n)
17724 320 CONTINUE
17725 ENDIF
17726 ENDIF
17727
17728C...End loop over resonances for daughter flavour and mass selection.
17729 mstu(10)=mstu10
17730 330 IF(mwid(kca).NE.0.AND.(kfl1(jt).EQ.0.OR.kfl3(jt).NE.0))
17731 & ninh=ninh+1
17732 IF(ires.GT.0.AND.mwid(kca).NE.0.AND.mdcy(kca,1).NE.0.AND.
17733 & kfl1(jt).EQ.0) THEN
17734 WRITE(code,'(I9)') k(id,2)
17735 WRITE(mass,'(F9.3)') p(id,5)
17736 CALL pyerrm(3,'(PYRESD:) Failed to decay particle'//
17737 & code//' with mass'//mass)
17738 mint(51)=1
17739 GOTO 720
17740 ENDIF
17741 340 CONTINUE
17742
17743C...Check for allowed combinations. Skip if no decays.
17744 IF(jtmax.EQ.1) THEN
17745 IF(kdcy(1).EQ.0) GOTO 710
17746 ELSEIF(jtmax.EQ.2) THEN
17747 IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0) GOTO 710
17748 IF(keql(1).EQ.4.AND.keql(2).EQ.4) GOTO 180
17749 IF(keql(1).EQ.5.AND.keql(2).EQ.5) GOTO 180
17750 ELSEIF(jtmax.EQ.3) THEN
17751 IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0.AND.kdcy(3).EQ.0) GOTO 710
17752 IF(keql(1).EQ.4.AND.keql(2).EQ.4) GOTO 180
17753 IF(keql(1).EQ.4.AND.keql(3).EQ.4) GOTO 180
17754 IF(keql(2).EQ.4.AND.keql(3).EQ.4) GOTO 180
17755 IF(keql(1).EQ.5.AND.keql(2).EQ.5) GOTO 180
17756 IF(keql(1).EQ.5.AND.keql(3).EQ.5) GOTO 180
17757 IF(keql(2).EQ.5.AND.keql(3).EQ.5) GOTO 180
17758 ENDIF
17759
17760C...Special case: matrix element option for Z0 decay to quarks.
17761 IF(mstp(48).EQ.1.AND.isub.EQ.1.AND.jtmax.EQ.1.AND.
17762 &iabs(mint(11)).EQ.11.AND.iabs(kfl1(1)).LE.5) THEN
17763
17764C...Check consistency of MSTJ options set.
17765 IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
17766 CALL pyerrm(6,
17767 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17768 mstj(110)=1
17769 ENDIF
17770 IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
17771 CALL pyerrm(6,
17772 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17773
17774 mstj(111)=0
17775 ENDIF
17776
17777C...Select alpha_strong behaviour.
17778 mst111=mstu(111)
17779 par112=paru(112)
17780 mstu(111)=mstj(108)
17781 IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
17782 & mstu(111)=1
17783 paru(112)=parj(121)
17784 IF(mstu(111).EQ.2) paru(112)=parj(122)
17785
17786C...Find axial fraction in total cross section for scalar gluon model.
17787 parj(171)=0d0
17788 IF((iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.1).OR.
17789 & (mstj(101).EQ.5.AND.mstj(49).EQ.1)) THEN
17790 poll=1d0-parj(131)*parj(132)
17791 sff=1d0/(16d0*xw*xw1)
17792 sfw=p(id,5)**4/((p(id,5)**2-parj(123)**2)**2+
17793 & (parj(123)*parj(124))**2)
17794 sfi=sfw*(1d0-(parj(123)/p(id,5))**2)
17795 ve=4d0*xw-1d0
17796 hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
17797 hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*
17798 & (parj(132)-parj(131)))
17799 kflc=iabs(kfl1(1))
17800 pmq=pymass(kflc)
17801 qf=kchg(kflc,1)/3d0
17802 vq=1d0
17803 IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,
17804 & 1d0-(2d0*pmq/p(id,5))**2))
17805 vf=sign(1d0,qf)-4d0*qf*xw
17806 rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+
17807 & vf**2*hf1w)+vq**3*hf1w
17808 IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
17809 ENDIF
17810
17811C...Choice of jet configuration.
17812 CALL pyxjet(p(id,5),njet,cut)
17813 kflc=iabs(kfl1(1))
17814 kfln=21
17815 IF(njet.EQ.4) THEN
17816 CALL pyx4jt(njet,cut,kflc,p(id,5),kfln,x1,x2,x4,x12,x14)
17817 ELSEIF(njet.EQ.3) THEN
17818 CALL pyx3jt(njet,cut,kflc,p(id,5),x1,x3)
17819 ELSE
17820 mstj(120)=1
17821 ENDIF
17822
17823C...Fill jet configuration; return if incorrect kinematics.
17824 nc=n-2
17825 IF(njet.EQ.2.AND.mstj(101).NE.5) THEN
17826 CALL py2ent(nc+1,kflc,-kflc,p(id,5))
17827 ELSEIF(njet.EQ.2) THEN
17828 CALL py2ent(-(nc+1),kflc,-kflc,p(id,5))
17829 ELSEIF(njet.EQ.3) THEN
17830 CALL py3ent(nc+1,kflc,21,-kflc,p(id,5),x1,x3)
17831 ELSEIF(kfln.EQ.21) THEN
17832 CALL py4ent(nc+1,kflc,kfln,kfln,-kflc,p(id,5),x1,x2,x4,
17833 & x12,x14)
17834 ELSE
17835 CALL py4ent(nc+1,kflc,-kfln,kfln,-kflc,p(id,5),x1,x2,x4,
17836 & x12,x14)
17837 ENDIF
17838 IF(mstu(24).NE.0) THEN
17839 mint(51)=1
17840 mstu(111)=mst111
17841 paru(112)=par112
17842 GOTO 720
17843 ENDIF
17844
17845C...Angular orientation according to matrix element.
17846 IF(mstj(106).EQ.1) THEN
17847 CALL pyxdif(nc,njet,kflc,p(id,5),chiz,thez,phiz)
17848 IF(mint(11).LT.0) thez=paru(1)-thez
17849 cthe(1)=cos(thez)
17850 CALL pyrobo(nc+1,n,0d0,chiz,0d0,0d0,0d0)
17851 CALL pyrobo(nc+1,n,thez,phiz,0d0,0d0,0d0)
17852 ENDIF
17853
17854C...Boost partons to Z0 rest frame.
17855 CALL pyrobo(nc+1,n,0d0,0d0,p(id,1)/p(id,4),
17856 & p(id,2)/p(id,4),p(id,3)/p(id,4))
17857
17858C...Mark decayed resonance and add documentation lines,
17859 k(id,1)=k(id,1)+10
17860 idoc=mint(83)+mint(4)
17861 DO 360 i=nc+1,n
17862 i1=mint(83)+mint(4)+1
17863 k(i,3)=i1
17864 IF(mstp(128).GE.1) k(i,3)=id
17865 IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
17866 mint(4)=mint(4)+1
17867 k(i1,1)=21
17868 k(i1,2)=k(i,2)
17869 k(i1,3)=iref(ip,4)
17870 DO 350 j=1,5
17871 p(i1,j)=p(i,j)
17872 350 CONTINUE
17873 ENDIF
17874 360 CONTINUE
17875
17876C...Generate parton shower.
17877 IF(mstj(101).EQ.5.AND.mint(35).LE.1) THEN
17878 CALL pyshow(n-1,n,p(id,5))
17879 ELSEIF(mstj(101).EQ.5.AND.mint(35).GE.2) THEN
17880 npart=2
17881 ipart(1)=n-1
17882 ipart(2)=n
17883 ptpart(1)=0.5d0*p(id,5)
17884 ptpart(2)=ptpart(1)
17885 nct=nct+1
17886 IF(k(n-1,2).GT.0) THEN
17887 mct(n-1,1)=nct
17888 mct(n,2)=nct
17889 ELSE
17890 mct(n-1,2)=nct
17891 mct(n,1)=nct
17892 ENDIF
17893 CALL pyptfs(2,0.5d0*p(id,5),0d0,ptgen)
17894 ENDIF
17895
17896C... End special case for Z0: skip ahead.
17897 mstu(111)=mst111
17898 paru(112)=par112
17899 GOTO 700
17900 ENDIF
17901
17902C...Order incoming partons and outgoing resonances.
17903 IF(jtmax.EQ.2.AND.isub.NE.0.AND.mstp(47).GE.1.AND.
17904 &ninh.EQ.0) THEN
17905 ilin(1)=mint(84)+1
17906 IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2
17907 IF(k(ilin(1),2).EQ.21.OR.k(ilin(1),2).EQ.22)
17908 & ilin(1)=2*mint(84)+3-ilin(1)
17909 ilin(2)=2*mint(84)+3-ilin(1)
17910 imin=1
17911 IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)
17912 & .EQ.36) imin=3
17913 imax=2
17914 iord=1
17915 IF(k(iref(ip,1),2).EQ.23) iord=2
17916 IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2
17917 iakipd=iabs(k(iref(ip,iord),2))
17918 IF(iakipd.EQ.25.OR.iakipd.EQ.35.OR.iakipd.EQ.36) iord=3-iord
17919 IF(kdcy(iord).EQ.0) iord=3-iord
17920
17921C...Order decay products of resonances.
17922 DO 370 jt=iord,3-iord,3-2*iord
17923 IF(kdcy(jt).EQ.0) THEN
17924 ilin(imax+1)=nsd(jt)
17925 imax=imax+1
17926 ELSEIF(k(nsd(jt)+1,2).GT.0) THEN
17927 ilin(imax+1)=n+2*jt-1
17928 ilin(imax+2)=n+2*jt
17929 imax=imax+2
17930 k(n+2*jt-1,2)=k(nsd(jt)+1,2)
17931 k(n+2*jt,2)=k(nsd(jt)+2,2)
17932 ELSE
17933 ilin(imax+1)=n+2*jt
17934
17935 ilin(imax+2)=n+2*jt-1
17936 imax=imax+2
17937 k(n+2*jt-1,2)=k(nsd(jt)+1,2)
17938 k(n+2*jt,2)=k(nsd(jt)+2,2)
17939 ENDIF
17940 370 CONTINUE
17941
17942C...Find charge, isospin, left- and righthanded couplings.
17943 DO 390 i=imin,imax
17944 DO 380 j=1,4
17945 coup(i,j)=0d0
17946 380 CONTINUE
17947 kfa=iabs(k(ilin(i),2))
17948 IF(kfa.EQ.0.OR.kfa.GT.20) GOTO 390
17949 coup(i,1)=kchg(kfa,1)/3d0
17950 coup(i,2)=(-1)**mod(kfa,2)
17951 coup(i,4)=-2d0*coup(i,1)*xwv
17952 coup(i,3)=coup(i,2)+coup(i,4)
17953 390 CONTINUE
17954
17955C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
17956 IF(isub.EQ.22) THEN
17957 DO 420 i=3,5,2
17958 i1=iord
17959 IF(i.EQ.5) i1=3-iord
17960 DO 410 j1=1,2
17961 DO 400 j2=1,2
17962 corl(i/2,j1,j2)=coup(1,1)**2*hgz(i1,1)*coup(i,1)**2/
17963 & 16d0+coup(1,1)*coup(1,j1+2)*hgz(i1,2)*coup(i,1)*
17964 & coup(i,j2+2)/4d0+coup(1,j1+2)**2*hgz(i1,3)*
17965 & coup(i,j2+2)**2
17966 400 CONTINUE
17967 410 CONTINUE
17968 420 CONTINUE
17969 cowt12=(corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
17970 & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2))
17971 comx12=(corl(1,1,1)+corl(1,1,2)+corl(1,2,1)+corl(1,2,2))*
17972 & (corl(2,1,1)+corl(2,1,2)+corl(2,2,1)+corl(2,2,2))
17973
17974 IF(cowt12.LT.pyr(0)*comx12) GOTO 180
17975 ENDIF
17976 ENDIF
17977
17978C...Select angular orientation type - Z'/W' only.
17979 mzpwp=0
17980 IF(isub.EQ.141) THEN
17981 IF(pyr(0).LT.paru(130)) mzpwp=1
17982 IF(ip.EQ.2) THEN
17983 IF(iabs(k(iref(2,1),2)).EQ.37) mzpwp=2
17984 iakir=iabs(k(iref(2,2),2))
17985 IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
17986 IF(iakir.LE.20) mzpwp=2
17987 ENDIF
17988 IF(ip.GE.3) mzpwp=2
17989 ELSEIF(isub.EQ.142) THEN
17990 IF(pyr(0).LT.paru(136)) mzpwp=1
17991 IF(ip.EQ.2) THEN
17992 iakir=iabs(k(iref(2,2),2))
17993 IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2
17994 IF(iakir.LE.20) mzpwp=2
17995 ENDIF
17996 IF(ip.GE.3) mzpwp=2
17997 ENDIF
17998
17999C...Select random angles (begin of weighting procedure).
18000 430 DO 440 jt=1,jtmax
18001 IF(kdcy(jt).EQ.0) GOTO 440
18002 IF(jtmax.EQ.1.AND.isub.NE.0.AND.ihdec.EQ.0) THEN
18003 cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*pyr(0)
18004 IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)
18005 phi(jt)=vint(24)
18006 ELSE
18007 cthe(jt)=2d0*pyr(0)-1d0
18008 phi(jt)=paru(2)*pyr(0)
18009 ENDIF
18010 440 CONTINUE
18011
18012 IF(jtmax.EQ.2.AND.mstp(47).GE.1.AND.ninh.EQ.0) THEN
18013C...Construct massless four-vectors.
18014 DO 460 i=n+1,n+4
18015 k(i,1)=1
18016 DO 450 j=1,5
18017 p(i,j)=0d0
18018 v(i,j)=0d0
18019 450 CONTINUE
18020 460 CONTINUE
18021 DO 470 jt=1,jtmax
18022 IF(kdcy(jt).EQ.0) GOTO 470
18023 id=iref(ip,jt)
18024 p(n+2*jt-1,3)=0.5d0*p(id,5)
18025 p(n+2*jt-1,4)=0.5d0*p(id,5)
18026 p(n+2*jt,3)=-0.5d0*p(id,5)
18027 p(n+2*jt,4)=0.5d0*p(id,5)
18028 CALL pyrobo(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),
18029 & p(id,1)/p(id,4),p(id,2)/p(id,4),p(id,3)/p(id,4))
18030 470 CONTINUE
18031
18032C...Store incoming and outgoing momenta, with random rotation to
18033C...avoid accidental zeroes in HA expressions.
18034 IF(isub.NE.0) THEN
18035 DO 490 i=imin,imax
18036 k(n+4+i,1)=1
18037 p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+
18038 & p(ilin(i),3)**2+p(ilin(i),5)**2)
18039 p(n+4+i,5)=p(ilin(i),5)
18040 DO 480 j=1,3
18041 p(n+4+i,j)=p(ilin(i),j)
18042 480 CONTINUE
18043 490 CONTINUE
18044 500 therr=acos(2d0*pyr(0)-1d0)
18045 phirr=paru(2)*pyr(0)
18046 CALL pyrobo(n+4+imin,n+4+imax,therr,phirr,0d0,0d0,0d0)
18047 DO 520 i=imin,imax
18048 IF(p(n+4+i,1)**2+p(n+4+i,2)**2.LT.1d-4*(p(n+4+i,1)**2+
18049 & p(n+4+i,2)**2+p(n+4+i,3)**2)) GOTO 500
18050 DO 510 j=1,4
18051 pk(i,j)=p(n+4+i,j)
18052 510 CONTINUE
18053 520 CONTINUE
18054 ENDIF
18055
18056C...Calculate internal products.
18057 IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25.OR.isub.EQ.141.OR.
18058 & isub.EQ.142) THEN
18059 DO 540 i1=imin,imax-1
18060 DO 530 i2=i1+1,imax
18061 ha(i1,i2)=sngl(sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+
18062 & pk(i2,3))/(1d-20+pk(i1,1)**2+pk(i1,2)**2)))*
18063 & cmplx(sngl(pk(i1,1)),sngl(pk(i1,2)))-
18064 & sngl(sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/
18065 & (1d-20+pk(i2,1)**2+pk(i2,2)**2)))*
18066 & cmplx(sngl(pk(i2,1)),sngl(pk(i2,2)))
18067 hc(i1,i2)=conjg(ha(i1,i2))
18068 IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)
18069 IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)
18070 ha(i2,i1)=-ha(i1,i2)
18071 hc(i2,i1)=-hc(i1,i2)
18072 530 CONTINUE
18073 540 CONTINUE
18074 ENDIF
18075
18076C...Calculate four-products.
18077 IF(isub.NE.0) THEN
18078 DO 560 i=1,2
18079 DO 550 j=1,4
18080 pk(i,j)=-pk(i,j)
18081 550 CONTINUE
18082 560 CONTINUE
18083 DO 580 i1=imin,imax-1
18084 DO 570 i2=i1+1,imax
18085 pkk(i1,i2)=2d0*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-
18086 & pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))
18087 pkk(i2,i1)=pkk(i1,i2)
18088 570 CONTINUE
18089 580 CONTINUE
18090 ENDIF
18091 ENDIF
18092
18093 kfagm=iabs(iref(ip,7))
18094 IF(mstp(47).LE.0.OR.ninh.NE.0) THEN
18095C...Isotropic decay selected by user.
18096 wt=1d0
18097 wtmax=1d0
18098
18099 ELSEIF(jtmax.EQ.3) THEN
18100C...Isotropic decay when three mother particles.
18101 wt=1d0
18102 wtmax=1d0
18103
18104 ELSEIF(it4.GE.1) THEN
18105C... Isotropic decay t -> b + W etc for 4th generation q and l.
18106 wt=1d0
18107 wtmax=1d0
18108
18109 ELSEIF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.
18110 & iref(ip,7).EQ.36) THEN
18111C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18112C...CP-odd case added by Kari Ertresvag Myklevoll.
18113C...Now also with mixed Higgs CP-states
18114 eta=parp(25)
18115 IF(ip.EQ.1) wtmax=sh**2
18116 IF(ip.GE.2) wtmax=p(iref(ip,8),5)**4
18117 kfa=iabs(k(iref(ip,1),2))
18118 kft=iabs(k(iref(ip,2),2))
18119
18120 IF((kfa.EQ.kft).AND.(kfa.EQ.23.OR.kfa.EQ.24).AND.
18121 & mstp(25).GE.3) THEN
18122C...For mixed CP states need epsilon product.
18123 p10=pk(3,4)
18124 p20=pk(4,4)
18125 p30=pk(5,4)
18126 p40=pk(6,4)
18127 p11=pk(3,1)
18128 p21=pk(4,1)
18129 p31=pk(5,1)
18130 p41=pk(6,1)
18131 p12=pk(3,2)
18132 p22=pk(4,2)
18133 p32=pk(5,2)
18134 p42=pk(6,2)
18135 p13=pk(3,3)
18136 p23=pk(4,3)
18137 p33=pk(5,3)
18138 p43=pk(6,3)
18139 epsi=p10*p21*p32*p43-p10*p21*p33*p42-p10*p22*p31*p43+p10*p22*
18140 & p33*p41+p10*p23*p31*p42-p10*p23*p32*p41-p11*p20*p32*p43+p11*
18141 & p20*p33*p42+p11*p22*p30*p43-p11*p22*p33*p40-p11*p23*p30*p42+
18142 & p11*p23*p32*p40+p12*p20*p31*p43-p12*p20*p33*p41-p12*p21*p30*
18143 & p43+p12*p21*p33*p40+p12*p23*p30*p41-p12*p23*p31*p40-p13*p20*
18144 & p31*p42+p13*p20*p32*p41+p13*p21*p30*p42-p13*p21*p32*p40-p13*
18145 & p22*p30*p41+p13*p22*p31*p40
18146C...For mixed CP states need gauge boson masses.
18147 xma=sqrt(max(0d0,(pk(3,4)+pk(4,4))**2-(pk(3,1)+pk(4,1))**2-
18148 & (pk(3,2)+pk(4,2))**2-(pk(3,3)+pk(4,3))**2))
18149 xmb=sqrt(max(0d0,(pk(5,4)+pk(6,4))**2-(pk(5,1)+pk(6,1))**2-
18150 & (pk(5,2)+pk(6,2))**2-(pk(5,3)+pk(6,3))**2))
18151 xmv=pmas(kfa,1)
18152 ENDIF
18153
18154C...Z decay
18155 IF(kfa.EQ.23.AND.kfa.EQ.kft) THEN
18156 kflf1a=iabs(kfl1(1))
18157 ef1=kchg(kflf1a,1)/3d0
18158 af1=sign(1d0,ef1+0.1d0)
18159 vf1=af1-4d0*ef1*xwv
18160 kflf2a=iabs(kfl1(2))
18161 ef2=kchg(kflf2a,1)/3d0
18162 af2=sign(1d0,ef2+0.1d0)
18163 vf2=af2-4d0*ef2*xwv
18164 va12as=4d0*vf1*af1*vf2*af2/((vf1**2+af1**2)*(vf2**2+af2**2))
18165 IF((mstp(25).EQ.0.AND.iref(ip,7).NE.36).OR.mstp(25).EQ.1)
18166 & THEN
18167C...CP-even decay
18168 wt=8d0*(1d0+va12as)*pkk(3,5)*pkk(4,6)+
18169 & 8d0*(1d0-va12as)*pkk(3,6)*pkk(4,5)
18170 ELSEIF(mstp(25).LE.2) THEN
18171C...CP-odd decay
18172 wt=((pkk(3,5)+pkk(4,6))**2 +(pkk(3,6)+pkk(4,5))**2
18173 & -2*pkk(3,4)*pkk(5,6)
18174 & -2*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2/
18175 & (pkk(3,4)*pkk(5,6))
18176 & +va12as*(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))*
18177 & (pkk(3,5)+pkk(4,5)-pkk(3,6)-pkk(4,6)))/(1+va12as)
18178 ELSE
18179C...Mixed CP states.
18180 wt=32d0*(0.25d0*((1d0+va12as)*pkk(3,5)*pkk(4,6)
18181 & +(1d0-va12as)*pkk(3,6)*pkk(4,5))
18182 & -0.5d0*eta/xmv**2*epsi*((1d0+va12as)*(pkk(3,5)+pkk(4,6))
18183 & -(1d0-va12as)*(pkk(3,6)+pkk(4,5)))
18184 & +6.25d-2*eta**2/xmv**4*(-2d0*pkk(3,4)**2*pkk(5,6)**2
18185 & -2d0*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2
18186 & +pkk(3,4)*pkk(5,6)
18187 & *((pkk(3,5)+pkk(4,6))**2+(pkk(3,6)+pkk(4,5))**2)
18188 & +va12as*pkk(3,4)*pkk(5,6)
18189 & *(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))
18190 & *(pkk(3,5)-pkk(3,6)+pkk(4,5)-pkk(4,6))))
18191 & /(1d0 +2d0*eta*xma*xmb/xmv**2
18192 & +2d0*(eta*xma*xmb/xmv**2)**2*(1d0+va12as))
18193 ENDIF
18194
18195C...W decay
18196 ELSEIF(kfa.EQ.24.AND.kfa.EQ.kft) THEN
18197 IF((mstp(25).EQ.0.AND.iref(ip,7).NE.36).OR.mstp(25).EQ.1)
18198 & THEN
18199C...CP-even decay
18200 wt=16d0*pkk(3,5)*pkk(4,6)
18201 ELSEIF(mstp(25).LE.2) THEN
18202C...CP-odd decay
18203 wt=0.5d0*((pkk(3,5)+pkk(4,6))**2 +(pkk(3,6)+pkk(4,5))**2
18204 & -2*pkk(3,4)*pkk(5,6)
18205 & -2*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2/
18206 & (pkk(3,4)*pkk(5,6))
18207 & +(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))*
18208 & (pkk(3,5)+pkk(4,5)-pkk(3,6)-pkk(4,6)))
18209 ELSE
18210C...Mixed CP states.
18211 wt=32d0*(0.25d0*2d0*pkk(3,5)*pkk(4,6)
18212 & -0.5d0*eta/xmv**2*epsi*2d0*(pkk(3,5)+pkk(4,6))
18213 & +6.25d-2*eta**2/xmv**4*(-2d0*pkk(3,4)**2*pkk(5,6)**2
18214 & -2d0*(pkk(3,5)*pkk(4,6)-pkk(3,6)*pkk(4,5))**2
18215 & +pkk(3,4)*pkk(5,6)
18216 & *((pkk(3,5)+pkk(4,6))**2+(pkk(3,6)+pkk(4,5))**2)
18217 & +pkk(3,4)*pkk(5,6)
18218 & *(pkk(3,5)+pkk(3,6)-pkk(4,5)-pkk(4,6))
18219 & *(pkk(3,5)-pkk(3,6)+pkk(4,5)-pkk(4,6))))
18220 & /(1d0 +2d0*eta*xma*xmb/xmv**2
18221 & +(2d0*eta*xma*xmb/xmv**2)**2)
18222 ENDIF
18223
18224C...No angular correlations in other Higgs decays.
18225 ELSE
18226 wt=wtmax
18227 ENDIF
18228
18229 ELSEIF((kfagm.EQ.6.OR.kfagm.EQ.7.OR.kfagm.EQ.8.OR.
18230 & kfagm.EQ.17.OR.kfagm.EQ.18).AND.iabs(k(iref(ip,1),2)).EQ.24)
18231 & THEN
18232C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18233 i1=iref(ip,8)
18234 IF(mod(kfagm,2).EQ.0) THEN
18235 i2=n+1
18236 i3=n+2
18237 ELSE
18238 i2=n+2
18239 i3=n+1
18240 ENDIF
18241 i4=iref(ip,2)
18242 wt=(p(i1,4)*p(i2,4)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
18243 & p(i1,3)*p(i2,3))*(p(i3,4)*p(i4,4)-p(i3,1)*p(i4,1)-
18244 & p(i3,2)*p(i4,2)-p(i3,3)*p(i4,3))
18245 wtmax=(p(i1,5)**4-p(iref(ip,1),5)**4)/8d0
18246
18247 ELSEIF(isub.EQ.1) THEN
18248C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18249 ei=kchg(iabs(mint(15)),1)/3d0
18250 ai=sign(1d0,ei+0.1d0)
18251 vi=ai-4d0*ei*xwv
18252 ef=kchg(iabs(kfl1(1)),1)/3d0
18253 af=sign(1d0,ef+0.1d0)
18254
18255 vf=af-4d0*ef*xwv
18256 rmf=min(1d0,4d0*pmas(iabs(kfl1(1)),1)**2/sh)
18257 wt1=ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18258 & (vi**2+ai**2)*vint(114)*(vf**2+(1d0-rmf)*af**2)
18259 wt2=rmf*(ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18260 & (vi**2+ai**2)*vint(114)*vf**2)
18261 wt3=sqrt(1d0-rmf)*(ei*ai*vint(112)*ef*af+
18262 & 4d0*vi*ai*vint(114)*vf*af)
18263 wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+
18264 & 2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))
18265 wtmax=2d0*(wt1+abs(wt3))
18266
18267 ELSEIF(isub.EQ.2) THEN
18268C...Angular weight for W+/- -> 2 quarks/leptons.
18269 rm3=pmas(iabs(kfl1(1)),1)**2/sh
18270 rm4=pmas(iabs(kfl2(1)),1)**2/sh
18271 be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
18272 wt=(1d0+be34*cthe(1)*isign(1,mint(15)*kfl1(1)))**2-(rm3-rm4)**2
18273 wtmax=4d0
18274
18275 ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN
18276C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18277C...-> gluon/gamma + 2 quarks/leptons.
18278 clilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18279 & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18280 & coup(1,3)**2*hgz(jtz,3)*coup(3,3)**2
18281 clirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18282 & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18283 & coup(1,3)**2*hgz(jtz,3)*coup(3,4)**2
18284 crilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18285 & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18286 & coup(1,4)**2*hgz(jtz,3)*coup(3,3)**2
18287 crirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18288 & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18289 & coup(1,4)**2*hgz(jtz,3)*coup(3,4)**2
18290 wt=(clilf+crirf)*(pkk(1,3)**2+pkk(2,4)**2)+
18291 & (clirf+crilf)*(pkk(1,4)**2+pkk(2,3)**2)
18292 wtmax=(clilf+clirf+crilf+crirf)*
18293 & ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2)
18294
18295 ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN
18296C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18297C...-> gluon/gamma + 2 quarks/leptons.
18298 wt=pkk(1,3)**2+pkk(2,4)**2
18299 wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2
18300
18301 ELSEIF(isub.EQ.22) THEN
18302C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18303 s34=p(iref(ip,iord),5)**2
18304 s56=p(iref(ip,3-iord),5)**2
18305 ti=pkk(1,3)+pkk(1,4)+s34
18306 ui=pkk(1,5)+pkk(1,6)+s56
18307 tir=real(ti)
18308 uir=real(ui)
18309 fgk135=abs(fgk(1,2,3,4,5,6)/tir+fgk(1,2,5,6,3,4)/uir)**2
18310 fgk145=abs(fgk(1,2,4,3,5,6)/tir+fgk(1,2,5,6,4,3)/uir)**2
18311 fgk136=abs(fgk(1,2,3,4,6,5)/tir+fgk(1,2,6,5,3,4)/uir)**2
18312 fgk146=abs(fgk(1,2,4,3,6,5)/tir+fgk(1,2,6,5,4,3)/uir)**2
18313 fgk253=abs(fgk(2,1,5,6,3,4)/tir+fgk(2,1,3,4,5,6)/uir)**2
18314 fgk263=abs(fgk(2,1,6,5,3,4)/tir+fgk(2,1,3,4,6,5)/uir)**2
18315 fgk254=abs(fgk(2,1,5,6,4,3)/tir+fgk(2,1,4,3,5,6)/uir)**2
18316 fgk264=abs(fgk(2,1,6,5,4,3)/tir+fgk(2,1,4,3,6,5)/uir)**2
18317
18318 wt=
18319 & corl(1,1,1)*corl(2,1,1)*fgk135+corl(1,1,2)*corl(2,1,1)*fgk145+
18320 & corl(1,1,1)*corl(2,1,2)*fgk136+corl(1,1,2)*corl(2,1,2)*fgk146+
18321 & corl(1,2,1)*corl(2,2,1)*fgk253+corl(1,2,2)*corl(2,2,1)*fgk263+
18322 & corl(1,2,1)*corl(2,2,2)*fgk254+corl(1,2,2)*corl(2,2,2)*fgk264
18323 wtmax=16d0*((corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+
18324 & (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2)))*s34*s56*
18325 & ((ti**2+ui**2+2d0*sh*(s34+s56))/(ti*ui)-s34*s56*(1d0/ti**2+
18326 & 1d0/ui**2))
18327
18328 ELSEIF(isub.EQ.23) THEN
18329C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18330 d34=p(iref(ip,iord),5)**2
18331 d56=p(iref(ip,3-iord),5)**2
18332 dt=pkk(1,3)+pkk(1,4)+d34
18333 du=pkk(1,5)+pkk(1,6)+d56
18334 facbw=1d0/((sh-sqmw)**2+gmmw**2)
18335 cawz=coup(2,3)/dt-2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
18336 cbwz=coup(1,3)/du+2d0*xw1*coup(1,2)*(sh-sqmw)*facbw
18337 fgk135=abs(real(cawz)*fgk(1,2,3,4,5,6)+
18338
18339 & real(cbwz)*fgk(1,2,5,6,3,4))
18340 fgk136=abs(real(cawz)*fgk(1,2,3,4,6,5)+
18341 & real(cbwz)*fgk(1,2,6,5,3,4))
18342 wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
18343 wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*
18344 & digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))
18345
18346 ELSEIF(isub.EQ.24.OR.isub.EQ.171.OR.isub.EQ.176) THEN
18347C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18348C...(or H0, or A0).
18349 wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*
18350 & pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)*
18351 & coup(3,3))**2)*pkk(1,4)*pkk(2,3)
18352 wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*
18353 & (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
18354
18355 ELSEIF(isub.EQ.25) THEN
18356C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18357 polr=(1d0+parj(132))*(1d0-parj(131))
18358 poll=(1d0-parj(132))*(1d0+parj(131))
18359 d34=p(iref(ip,iord),5)**2
18360 d56=p(iref(ip,3-iord),5)**2
18361 dt=pkk(1,3)+pkk(1,4)+d34
18362 du=pkk(1,5)+pkk(1,6)+d56
18363 facbw=1d0/((sh-sqmz)**2+sqmz*pmas(23,2)**2)
18364 cdww=(coup(1,3)*sqmz*(sh-sqmz)*facbw+coup(1,2))/sh
18365 caww=cdww+0.5d0*(coup(1,2)+1d0)/dt
18366 cbww=cdww+0.5d0*(coup(1,2)-1d0)/du
18367 ccww=coup(1,4)*sqmz*(sh-sqmz)*facbw/sh
18368 fgk135=abs(real(caww)*fgk(1,2,3,4,5,6)-
18369 & real(cbww)*fgk(1,2,5,6,3,4))
18370 fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
18371 IF(mstp(50).LE.0) THEN
18372 wt=fgk135**2+(ccww*fgk253)**2
18373 wtmax=4d0*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-
18374 & caww*cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-
18375 & djgk(dt,du)))
18376 ELSE
18377 wt=poll*fgk135**2+polr*(ccww*fgk253)**2
18378 wtmax=4d0*d34*d56*(poll*(caww**2*digk(dt,du)+
18379 & cbww**2*digk(du,dt)-caww*cbww*djgk(dt,du))+
18380 & polr*ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du)))
18381 ENDIF
18382
18383 ELSEIF(isub.EQ.26.OR.isub.EQ.172.OR.isub.EQ.177) THEN
18384C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18385C...(or H0, or A0).
18386 wt=pkk(1,3)*pkk(2,4)
18387 wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))
18388
18389 ELSEIF(isub.EQ.30.OR.isub.EQ.35) THEN
18390C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18391C...-> f + 2 quarks/leptons.
18392 clilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18393 & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18394 & coup(1,3)**2*hgz(jtz,3)*coup(3,3)**2
18395 clirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18396 & coup(1,1)*coup(1,3)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18397 & coup(1,3)**2*hgz(jtz,3)*coup(3,4)**2
18398 crilf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18399 & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,3)/4d0+
18400 & coup(1,4)**2*hgz(jtz,3)*coup(3,3)**2
18401 crirf=coup(1,1)**2*hgz(jtz,1)*coup(3,1)**2/16d0+
18402 & coup(1,1)*coup(1,4)*hgz(jtz,2)*coup(3,1)*coup(3,4)/4d0+
18403 & coup(1,4)**2*hgz(jtz,3)*coup(3,4)**2
18404 IF(k(ilin(1),2).GT.0) wt=(clilf+crirf)*(pkk(1,4)**2+
18405 & pkk(3,5)**2)+(clirf+crilf)*(pkk(1,3)**2+pkk(4,5)**2)
18406 IF(k(ilin(1),2).LT.0) wt=(clilf+crirf)*(pkk(1,3)**2+
18407 & pkk(4,5)**2)+(clirf+crilf)*(pkk(1,4)**2+pkk(3,5)**2)
18408 wtmax=(clilf+clirf+crilf+crirf)*
18409 & ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2)
18410
18411 ELSEIF(isub.EQ.31.OR.isub.EQ.36) THEN
18412C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18413 IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2
18414 IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2
18415 wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2
18416
18417 ELSEIF(isub.EQ.71.OR.isub.EQ.72.OR.isub.EQ.73.OR.isub.EQ.76.OR.
18418 & isub.EQ.77) THEN
18419C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18420 wt=16d0*pkk(3,5)*pkk(4,6)
18421 wtmax=sh**2
18422
18423 ELSEIF(isub.EQ.110) THEN
18424C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18425 wt=1d0
18426 wtmax=1d0
18427
18428 ELSEIF(isub.EQ.141) THEN
18429C...Special case: if only branching ratios known then isotropic decay.
18430 IF(mwid(32).EQ.2) THEN
18431 wt=1d0
18432 wtmax=1d0
18433 ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
18434C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18435C...Couplings of incoming flavour.
18436 kfai=iabs(mint(15))
18437 ei=kchg(kfai,1)/3d0
18438 ai=sign(1d0,ei+0.1d0)
18439 vi=ai-4d0*ei*xwv
18440 kfaic=1
18441 IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
18442 IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
18443 IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
18444 IF(kfai.LE.2.OR.kfai.EQ.11.OR.kfai.EQ.12) THEN
18445 vpi=paru(119+2*kfaic)
18446 api=paru(120+2*kfaic)
18447 ELSEIF(kfai.LE.4.OR.kfai.EQ.13.OR.kfai.EQ.14) THEN
18448 vpi=parj(178+2*kfaic)
18449 api=parj(179+2*kfaic)
18450 ELSE
18451 vpi=parj(186+2*kfaic)
18452 api=parj(187+2*kfaic)
18453 ENDIF
18454C...Couplings of final flavour.
18455 kfaf=iabs(kfl1(1))
18456 ef=kchg(kfaf,1)/3d0
18457 af=sign(1d0,ef+0.1d0)
18458 vf=af-4d0*ef*xwv
18459 kfafc=1
18460 IF(kfaf.LE.10.AND.mod(kfaf,2).EQ.0) kfafc=2
18461 IF(kfaf.GT.10.AND.mod(kfaf,2).NE.0) kfafc=3
18462 IF(kfaf.GT.10.AND.mod(kfaf,2).EQ.0) kfafc=4
18463 IF(kfaf.LE.2.OR.kfaf.EQ.11.OR.kfaf.EQ.12) THEN
18464 vpf=paru(119+2*kfafc)
18465 apf=paru(120+2*kfafc)
18466 ELSEIF(kfaf.LE.4.OR.kfaf.EQ.13.OR.kfaf.EQ.14) THEN
18467 vpf=parj(178+2*kfafc)
18468 apf=parj(179+2*kfafc)
18469 ELSE
18470 vpf=parj(186+2*kfafc)
18471 apf=parj(187+2*kfafc)
18472 ENDIF
18473C...Asymmetry and weight.
18474 asym=2d0*(ei*ai*vint(112)*ef*af+ei*api*vint(113)*ef*apf+
18475 & 4d0*vi*ai*vint(114)*vf*af+(vi*api+vpi*ai)*vint(115)*
18476 & (vf*apf+vpf*af)+4d0*vpi*api*vint(116)*vpf*apf)/
18477 & (ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+
18478 & ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
18479 & (vf**2+af**2)+(vi*vpi+ai*api)*vint(115)*(vf*vpf+af*apf)+
18480 & (vpi**2+api**2)*vint(116)*(vpf**2+apf**2))
18481 wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
18482 wtmax=2d0+abs(asym)
18483 ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).EQ.24) THEN
18484C...Angular weight for f + fbar -> Z' -> W+ + W-.
18485 rm1=p(nsd(1)+1,5)**2/sh
18486 rm2=p(nsd(1)+2,5)**2/sh
18487 ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
18488 & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
18489 cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
18490 & (rm2-rm1)**2)
18491 wt=cflat+ccos2*cthe(1)**2
18492 wtmax=cflat+max(0d0,ccos2)
18493 ELSEIF(ip.EQ.1.AND.(kfl1(1).EQ.25.OR.kfl1(1).EQ.35.OR.
18494 & iabs(kfl1(1)).EQ.37)) THEN
18495C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18496 wt=1d0-cthe(1)**2
18497 wtmax=1d0
18498 ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
18499C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18500 rm1=p(nsd(1)+1,5)**2/sh
18501 rm2=p(nsd(1)+2,5)**2/sh
18502 flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
18503 wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
18504 wtmax=1d0+flam2/(8d0*rm1)
18505 ELSEIF(mzpwp.EQ.0) THEN
18506C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18507C...(W:s like if intermediate Z).
18508 d34=p(iref(ip,iord),5)**2
18509 d56=p(iref(ip,3-iord),5)**2
18510 dt=pkk(1,3)+pkk(1,4)+d34
18511 du=pkk(1,5)+pkk(1,6)+d56
18512 fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
18513 fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))
18514 wt=(coup(1,3)*fgk135)**2+(coup(1,4)*fgk253)**2
18515 wtmax=4d0*d34*d56*(coup(1,3)**2+coup(1,4)**2)*
18516 & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
18517 ELSEIF(mzpwp.EQ.1) THEN
18518C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18519C...(W:s approximately longitudinal, like if intermediate H).
18520 wt=16d0*pkk(3,5)*pkk(4,6)
18521 wtmax=sh**2
18522 ELSE
18523C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18524C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18525 wt=1d0
18526 wtmax=1d0
18527 ENDIF
18528
18529 ELSEIF(isub.EQ.142) THEN
18530C...Special case: if only branching ratios known then isotropic decay.
18531 IF(mwid(34).EQ.2) THEN
18532 wt=1d0
18533 wtmax=1d0
18534 ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN
18535C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18536 kfai=iabs(mint(15))
18537 kfaic=1
18538 IF(kfai.GT.10) kfaic=2
18539 vi=paru(129+2*kfaic)
18540 ai=paru(130+2*kfaic)
18541 kfaf=iabs(kfl1(1))
18542 kfafc=1
18543 IF(kfaf.GT.10) kfafc=2
18544 vf=paru(129+2*kfafc)
18545 af=paru(130+2*kfafc)
18546 asym=8d0*vi*ai*vf*af/((vi**2+ai**2)*(vf**2+af**2))
18547 wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2
18548 wtmax=2d0+abs(asym)
18549 ELSEIF(ip.EQ.1.AND.iabs(kfl2(1)).EQ.23) THEN
18550C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18551 rm1=p(nsd(1)+1,5)**2/sh
18552 rm2=p(nsd(1)+2,5)**2/sh
18553 ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*
18554 & (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
18555 cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+
18556 & (rm2-rm1)**2)
18557 wt=cflat+ccos2*cthe(1)**2
18558 wtmax=cflat+max(0d0,ccos2)
18559 ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN
18560C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18561 rm1=p(nsd(1)+1,5)**2/sh
18562 rm2=p(nsd(1)+2,5)**2/sh
18563 flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)
18564 wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)
18565 wtmax=1d0+flam2/(8d0*rm1)
18566 ELSEIF(mzpwp.EQ.0) THEN
18567C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18568C...(W/Z like if intermediate W).
18569 d34=p(iref(ip,iord),5)**2
18570 d56=p(iref(ip,3-iord),5)**2
18571 dt=pkk(1,3)+pkk(1,4)+d34
18572 du=pkk(1,5)+pkk(1,6)+d56
18573 fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))
18574 fgk136=abs(fgk(1,2,3,4,6,5)-fgk(1,2,6,5,3,4))
18575 wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2
18576 wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*
18577 & (digk(dt,du)+digk(du,dt)-djgk(dt,du))
18578 ELSEIF(mzpwp.EQ.1) THEN
18579C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18580C...(W/Z approximately longitudinal, like if intermediate H).
18581 wt=16d0*pkk(3,5)*pkk(4,6)
18582 wtmax=sh**2
18583 ELSE
18584C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18585C...t + bbar -> t + W + bbar.
18586 wt=1d0
18587 wtmax=1d0
18588 ENDIF
18589
18590 ELSEIF(isub.EQ.145.OR.isub.EQ.162.OR.isub.EQ.163.OR.isub.EQ.164)
18591 & THEN
18592C...Isotropic decay of leptoquarks (assumed spin 0).
18593 wt=1d0
18594 wtmax=1d0
18595
18596 ELSEIF(isub.GE.146.AND.isub.LE.148) THEN
18597C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18598 side=1d0
18599 IF(mint(16).EQ.21.OR.mint(16).EQ.22) side=-1d0
18600 IF(ip.EQ.1.AND.(kfl1(1).EQ.21.OR.kfl1(1).EQ.22)) THEN
18601 wt=1d0+side*cthe(1)
18602 wtmax=2d0
18603 ELSEIF(ip.EQ.1) THEN
18604
18605 rm1=p(nsd(1)+1,5)**2/sh
18606 wt=1d0+side*cthe(1)*(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
18607 wtmax=1d0+(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)
18608 ELSE
18609C...W/Z decay assumed isotropic, since not known.
18610 wt=1d0
18611 wtmax=1d0
18612 ENDIF
18613
18614 ELSEIF(isub.EQ.149) THEN
18615C...Isotropic decay of techni-eta.
18616 wt=1d0
18617 wtmax=1d0
18618
18619 ELSEIF(isub.EQ.191) THEN
18620 IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
18621C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18622C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18623 wt=1d0-cthe(1)**2
18624 wtmax=1d0
18625 ELSEIF(ip.EQ.1) THEN
18626C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18627 cthesg=cthe(1)*isign(1,mint(15))
18628 xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
18629 bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
18630 bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
18631 kfai=iabs(mint(15))
18632 ei=kchg(kfai,1)/3d0
18633 ai=sign(1d0,ei+0.1d0)
18634 vi=ai-4d0*ei*xwv
18635 vali=0.5d0*(vi+ai)
18636 vari=0.5d0*(vi-ai)
18637 alefti=(ei+vali*bwzr)**2+(vali*bwzi)**2
18638 arighi=(ei+vari*bwzr)**2+(vari*bwzi)**2
18639 kfaf=iabs(kfl1(1))
18640 ef=kchg(kfaf,1)/3d0
18641 af=sign(1d0,ef+0.1d0)
18642 vf=af-4d0*ef*xwv
18643 valf=0.5d0*(vf+af)
18644 varf=0.5d0*(vf-af)
18645 aleftf=(ef+valf*bwzr)**2+(valf*bwzi)**2
18646 arighf=(ef+varf*bwzr)**2+(varf*bwzi)**2
18647 asame=alefti*aleftf+arighi*arighf
18648 aflip=alefti*arighf+arighi*aleftf
18649 wt=asame*(1d0+cthesg)**2+aflip*(1d0-cthesg)**2
18650 wtmax=4d0*max(asame,aflip)
18651 ELSE
18652C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18653 wt=1d0
18654 wtmax=1d0
18655 ENDIF
18656
18657 ELSEIF(isub.EQ.192) THEN
18658 IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
18659C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18660C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18661 wt=1d0-cthe(1)**2
18662 wtmax=1d0
18663 ELSEIF(ip.EQ.1) THEN
18664C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18665 cthesg=cthe(1)*isign(1,mint(15))
18666 wt=(1d0+cthesg)**2
18667 wtmax=4d0
18668 ELSE
18669C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18670 wt=1d0
18671 wtmax=1d0
18672 ENDIF
18673
18674 ELSEIF(isub.EQ.193) THEN
18675 IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN
18676C...Angular weight for f + fbar -> omega_tc0 ->
18677C...gamma pi_tc0 or Z0 pi_tc0.
18678 wt=1d0+cthe(1)**2
18679 wtmax=2d0
18680 ELSEIF(ip.EQ.1) THEN
18681C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18682 cthesg=cthe(1)*isign(1,mint(15))
18683 bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
18684 bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
18685 kfai=iabs(mint(15))
18686 ei=kchg(kfai,1)/3d0
18687 ai=sign(1d0,ei+0.1d0)
18688 vi=ai-4d0*ei*xwv
18689 vali=0.5d0*(vi+ai)
18690 vari=0.5d0*(vi-ai)
18691 blefti=(ei-vali*bwzr)**2+(vali*bwzi)**2
18692 brighi=(ei-vari*bwzr)**2+(vari*bwzi)**2
18693 kfaf=iabs(kfl1(1))
18694 ef=kchg(kfaf,1)/3d0
18695 af=sign(1d0,ef+0.1d0)
18696 vf=af-4d0*ef*xwv
18697 valf=0.5d0*(vf+af)
18698 varf=0.5d0*(vf-af)
18699 bleftf=(ef-valf*bwzr)**2+(valf*bwzi)**2
18700 brighf=(ef-varf*bwzr)**2+(varf*bwzi)**2
18701 bsame=blefti*bleftf+brighi*brighf
18702 bflip=blefti*brighf+brighi*bleftf
18703 wt=bsame*(1d0+cthesg)**2+bflip*(1d0-cthesg)**2
18704 wtmax=4d0*max(bsame,bflip)
18705 ELSE
18706C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18707 wt=1d0
18708 wtmax=1d0
18709 ENDIF
18710
18711 ELSEIF(isub.EQ.353) THEN
18712C...Angular weight for Z_R0 -> 2 quarks/leptons.
18713 ei=kchg(iabs(mint(15)),1)/3d0
18714 ai=sign(1d0,ei+0.1d0)
18715 vi=ai-4d0*ei*xwv
18716 ef=kchg(pycomp(kfl1(1)),1)/3d0
18717 af=sign(1d0,ef+0.1d0)
18718 vf=af-4d0*ef*xwv
18719 rmf=min(1d0,4d0*pmas(pycomp(kfl1(1)),1)**2/sh)
18720 wt1=(vi**2+ai**2)*(vf**2+(1d0-rmf)*af**2)
18721 wt2=rmf*(vi**2+ai**2)*vf**2
18722 wt3=sqrt(1d0-rmf)*4d0*vi*ai*vf*af
18723 wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+
18724 & 2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))
18725 wtmax=2d0*(wt1+abs(wt3))
18726
18727 ELSEIF(isub.EQ.354) THEN
18728C...Angular weight for W_R+/- -> 2 quarks/leptons.
18729 rm3=pmas(pycomp(kfl1(1)),1)**2/sh
18730 rm4=pmas(pycomp(kfl2(1)),1)**2/sh
18731 be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
18732 wt=(1d0+be34*cthe(1)*isign(1,mint(15)*kfl1(1)))**2-(rm3-rm4)**2
18733 wtmax=4d0
18734
18735 ELSEIF(isub.EQ.391) THEN
18736C...Angular weight for f + fbar -> G* -> f + fbar
18737 IF(ip.EQ.1.AND.iabs(kfl1(1)).LE.18) THEN
18738 wt=1d0-3d0*cthe(1)**2+4d0*cthe(1)**4
18739 wtmax=2d0
18740C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18741C...implemented by M.-C. Lemaire
18742 ELSEIF(ip.EQ.1.AND.(iabs(kfl1(1)).EQ.21.OR.
18743 & iabs(kfl1(1)).EQ.22)) THEN
18744 wt=1d0-cthe(1)**4
18745 wtmax=1d0
18746C...Other G* decays not yet implemented angular distributions.
18747 ELSE
18748 wt=1d0
18749 wtmax=1d0
18750 ENDIF
18751
18752 ELSEIF(isub.EQ.392) THEN
18753C...Angular weight for g + g -> G* -> f + fbar
18754 IF(ip.EQ.1.AND.iabs(kfl1(1)).LE.18) THEN
18755 wt=1d0-cthe(1)**4
18756 wtmax=1d0
18757C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18758C...implemented by M.-C. Lemaire
18759 ELSEIF(ip.EQ.1.AND.(iabs(kfl1(1)).EQ.21.OR.
18760 & iabs(kfl1(1)).EQ.22)) THEN
18761 wt=1d0+6d0*cthe(1)**2+cthe(1)**4
18762 wtmax=8d0
18763C...Other G* decays not yet implemented angular distributions.
18764 ELSE
18765 wt=1d0
18766 wtmax=1d0
18767 ENDIF
18768
18769C...Obtain correct angular distribution by rejection techniques.
18770 ELSE
18771 wt=1d0
18772 wtmax=1d0
18773 ENDIF
18774 IF(wt.LT.pyr(0)*wtmax) GOTO 430
18775
18776C...Construct massive four-vectors using angles chosen.
18777 590 DO 690 jt=1,jtmax
18778 IF(kdcy(jt).EQ.0) GOTO 690
18779 id=iref(ip,jt)
18780 DO 600 j=1,5
18781 dpmo(j)=p(id,j)
18782 600 CONTINUE
18783 dpmo(4)=sqrt(dpmo(1)**2+dpmo(2)**2+dpmo(3)**2+dpmo(5)**2)
18784CMRENNA++
18785 IF(kfl3(jt).EQ.0) THEN
18786 CALL pyrobo(nsd(jt)+1,nsd(jt)+2,acos(cthe(jt)),phi(jt),
18787 & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
18788 n0=nsd(jt)+2
18789 ELSE
18790 CALL pyrobo(nsd(jt)+1,nsd(jt)+3,acos(cthe(jt)),phi(jt),
18791 & dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))
18792 n0=nsd(jt)+3
18793 ENDIF
18794
18795 DO 610 j=1,4
18796 vdcy(j)=v(id,j)+v(id,5)*p(id,j)/p(id,5)
18797 610 CONTINUE
18798C...Fill in position of decay vertex.
18799 DO 630 i=nsd(jt)+1,n0
18800 DO 620 j=1,4
18801 v(i,j)=vdcy(j)
18802 620 CONTINUE
18803 v(i,5)=0d0
18804
18805 630 CONTINUE
18806CMRENNA--
18807
18808C...Mark decayed resonances; trace history.
18809 k(id,1)=k(id,1)+10
18810 kfa=iabs(k(id,2))
18811 kca=pycomp(kfa)
18812 IF(kcqm(jt).NE.0) THEN
18813C...Do not kill colour flow through coloured resonance!
18814 ELSE
18815 k(id,4)=nsd(jt)+1
18816 k(id,5)=nsd(jt)+2
18817C...If 3-body or 2-body with junction:
18818 IF(kfl3(jt).NE.0.OR.itjunc(jt).NE.0) k(id,5)=nsd(jt)+3
18819C...If 3-body with junction:
18820 IF(itjunc(jt).NE.0.AND.kfl3(jt).NE.0) k(id,5)=nsd(jt)+4
18821 ENDIF
18822
18823C...Add documentation lines.
18824 isubrg=max(1,min(500,mint(1)))
18825 IF(ires.EQ.0.OR.iset(isubrg).EQ.11) THEN
18826 idoc=mint(83)+mint(4)
18827CMRENNA+++
18828 ihi=nsd(jt)+2
18829 IF(kfl3(jt).NE.0) ihi=ihi+1
18830 DO 650 i=nsd(jt)+1,ihi
18831CMRENNA---
18832 i1=mint(83)+mint(4)+1
18833 k(i,3)=i1
18834 IF(mstp(128).GE.1) k(i,3)=id
18835 IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN
18836 mint(4)=mint(4)+1
18837 k(i1,1)=21
18838 k(i1,2)=k(i,2)
18839 k(i1,3)=iref(ip,jt+3)
18840 DO 640 j=1,5
18841 p(i1,j)=p(i,j)
18842 640 CONTINUE
18843 ENDIF
18844 650 CONTINUE
18845 ELSE
18846 k(nsd(jt)+1,3)=id
18847 k(nsd(jt)+2,3)=id
18848C...If 3-body or 2-body with junction:
18849 IF(kfl3(jt).NE.0.OR.itjunc(jt).GT.0) k(nsd(jt)+3,3)=id
18850C...If 3-body with junction:
18851 IF(kfl3(jt).NE.0.AND.itjunc(jt).GT.0) k(nsd(jt)+4,3)=id
18852 ENDIF
18853
18854C...Do showering of two or three objects.
18855 nshbef=n
18856 IF(mstp(71).GE.1.AND.mint(35).LE.1) THEN
18857 IF(kfl3(jt).EQ.0) THEN
18858 CALL pyshow(nsd(jt)+1,nsd(jt)+2,p(id,5))
18859 ELSE
18860 CALL pyshow(nsd(jt)+1,-3,p(id,5))
18861 ENDIF
18862
18863c...For pT-ordered shower need set up first, especially colour tags.
18864C...(Need to set up colour tags even if MSTP(71) = 0)
18865 ELSEIF(mint(35).GE.2) THEN
18866 npart=2
18867 IF(kfl3(jt).NE.0) npart=3
18868 ipart(1)=nsd(jt)+1
18869 ipart(2)=nsd(jt)+2
18870 ipart(3)=nsd(jt)+3
18871 ptpart(1)=0.5d0*p(id,5)
18872 ptpart(2)=ptpart(1)
18873 ptpart(3)=ptpart(1)
18874 IF(kcq1(jt).EQ.1.OR.kcq1(jt).EQ.2) THEN
18875 mother=k(nsd(jt)+1,4)/mstu(5)
18876 IF(mother.LE.nsd(jt)) THEN
18877 mct(nsd(jt)+1,1)=mct(mother,1)
18878 ELSE
18879 nct=nct+1
18880 mct(nsd(jt)+1,1)=nct
18881 mct(mother,2)=nct
18882 ENDIF
18883 ENDIF
18884 IF(kcq1(jt).EQ.-1.OR.kcq1(jt).EQ.2) THEN
18885 mother=k(nsd(jt)+1,5)/mstu(5)
18886 IF(mother.LE.nsd(jt)) THEN
18887 mct(nsd(jt)+1,2)=mct(mother,2)
18888 ELSE
18889 nct=nct+1
18890 mct(nsd(jt)+1,2)=nct
18891 mct(mother,1)=nct
18892 ENDIF
18893 ENDIF
18894 IF(mct(nsd(jt)+2,1).EQ.0.AND.(kcq2(jt).EQ.1.OR.
18895 & kcq2(jt).EQ.2)) THEN
18896 mother=k(nsd(jt)+2,4)/mstu(5)
18897 IF(mother.LE.nsd(jt)) THEN
18898 mct(nsd(jt)+2,1)=mct(mother,1)
18899 ELSE
18900 nct=nct+1
18901 mct(nsd(jt)+2,1)=nct
18902 mct(mother,2)=nct
18903 ENDIF
18904 ENDIF
18905 IF(mct(nsd(jt)+2,2).EQ.0.AND.(kcq2(jt).EQ.-1.OR.
18906 & kcq2(jt).EQ.2)) THEN
18907 mother=k(nsd(jt)+2,5)/mstu(5)
18908 IF(mother.LE.nsd(jt)) THEN
18909 mct(nsd(jt)+2,2)=mct(mother,2)
18910 ELSE
18911 nct=nct+1
18912 mct(nsd(jt)+2,2)=nct
18913 mct(mother,1)=nct
18914 ENDIF
18915 ENDIF
18916 IF(npart.EQ.3.AND.mct(nsd(jt)+3,1).EQ.0.AND.
18917 & (kcq3(jt).EQ.1.OR. kcq3(jt).EQ.2)) THEN
18918 mother=k(nsd(jt)+3,4)/mstu(5)
18919 mct(nsd(jt)+3,1)=mct(mother,1)
18920 ENDIF
18921 IF(npart.EQ.3.AND.mct(nsd(jt)+3,2).EQ.0.AND.
18922 & (kcq3(jt).EQ.-1.OR.kcq3(jt).EQ.2)) THEN
18923 mother=k(nsd(jt)+3,5)/mstu(5)
18924 mct(nsd(jt)+2,2)=mct(mother,2)
18925 ENDIF
18926 IF (mstp(71).GE.1) CALL pyptfs(2,0.5d0*p(id,5),0d0,ptgen)
18927 ENDIF
18928 nshaft=n
18929 IF(jt.EQ.1) naft1=n
18930
18931C...Check if decay products moved by shower.
18932 nsd1=nsd(jt)+1
18933 nsd2=nsd(jt)+2
18934 nsd3=nsd(jt)+3
18935 IF(nshaft.GT.nshbef) THEN
18936 IF(k(nsd1,1).GT.10) THEN
18937 DO 660 i=nshbef+1,nshaft
18938 IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd1,2)) nsd1=i
18939 660 CONTINUE
18940 ENDIF
18941 IF(k(nsd2,1).GT.10) THEN
18942 DO 670 i=nshbef+1,nshaft
18943 IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd2,2).AND.
18944 & i.NE.nsd1) nsd2=i
18945 670 CONTINUE
18946 ENDIF
18947 IF(kfl3(jt).NE.0.AND.k(nsd3,1).GT.10) THEN
18948 DO 680 i=nshbef+1,nshaft
18949 IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd3,2).AND.
18950 & i.NE.nsd1.AND.i.NE.nsd2) nsd3=i
18951 680 CONTINUE
18952 ENDIF
18953 ENDIF
18954
18955C...Store decay products for further treatment.
18956 np=np+1
18957 iref(np,1)=nsd1
18958 iref(np,2)=nsd2
18959 iref(np,3)=0
18960 IF(kfl3(jt).NE.0) iref(np,3)=nsd3
18961 iref(np,4)=idoc+1
18962 iref(np,5)=idoc+2
18963 iref(np,6)=0
18964 IF(kfl3(jt).NE.0) iref(np,6)=idoc+3
18965 iref(np,7)=k(iref(ip,jt),2)
18966 iref(np,8)=iref(ip,jt)
18967 690 CONTINUE
18968
18969
18970C...Fill information for 2 -> 1 -> 2.
18971 700 IF(jtmax.EQ.1.AND.kdcy(1).NE.0.AND.isub.NE.0) THEN
18972 mint(7)=mint(83)+6+2*iset(isub)
18973 mint(8)=mint(83)+7+2*iset(isub)
18974 mint(25)=kfl1(1)
18975 mint(26)=kfl2(1)
18976 vint(23)=cthe(1)
18977 rm3=p(n-1,5)**2/sh
18978 rm4=p(n,5)**2/sh
18979 be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
18980 vint(45)=-0.5d0*sh*(1d0-rm3-rm4-be34*cthe(1))
18981 vint(46)=-0.5d0*sh*(1d0-rm3-rm4+be34*cthe(1))
18982 vint(48)=0.25d0*sh*be34**2*max(0d0,1d0-cthe(1)**2)
18983 vint(47)=sqrt(vint(48))
18984 ENDIF
18985
18986C...Possibility of colour rearrangement in W+W- events.
18987 IF((isub.EQ.25.OR.isub.EQ.22).AND.mstp(115).GE.1) THEN
18988 iakf1=iabs(kfl1(1))
18989 iakf2=iabs(kfl1(2))
18990 iakf3=iabs(kfl2(1))
18991 iakf4=iabs(kfl2(2))
18992 IF(min(iakf1,iakf2,iakf3,iakf4).GE.1.AND.
18993 & max(iakf1,iakf2,iakf3,iakf4).LE.5) call
18994 & pyreco(iref(1,1),iref(1,2),nsd(1),naft1)
18995 IF(mint(51).NE.0) RETURN
18996 ENDIF
18997
18998C...Loop back if needed.
18999 710 IF(ip.LT.np) GOTO 170
19000
19001C...Boost back to standard frame.
19002 720 IF(ibst.EQ.1) CALL pyrobo(mint(83)+7,n,thein,phiin,bexin,beyin,
19003 &bezin)
19004
19005 RETURN
19006 END
19007
19008C*********************************************************************
19009
19010C...PYMULT
19011C...Initializes treatment of multiple interactions, selects kinematics
19012C...of hardest interaction if low-pT physics included in run, and
19013C...generates all non-hardest interactions.
19014
19015 SUBROUTINE pymult(MMUL)
19016
19017C...Double precision and integer declarations.
19018 IMPLICIT DOUBLE PRECISION(a-h, o-z)
19019 IMPLICIT INTEGER(I-N)
19020 INTEGER PYK,PYCHGE,PYCOMP
19021C...Commonblocks.
19022 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
19023 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
19024 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
19025 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
19026 common/pypars/mstp(200),parp(200),msti(200),pari(200)
19027 common/pyint1/mint(400),vint(400)
19028 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
19029 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
19030 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
19031 common/pyint7/sigt(0:6,0:6,0:5)
19032 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,
19033 &/pyint2/,/pyint3/,/pyint5/,/pyint7/
19034C...Local arrays and saved variables.
19035 dimension nmul(20),sigm(20),kstr(500,2),vintsv(80)
19036 SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm,p83a,p83b,p83c,
19037 &cq2i,cq2r,pik,bdiv,b,plowb,phighb,pallb,s4a,s4b,s4c,powip,
19038 &rpwip,b2rpdv,b2rpmx,bavg,vnt145,vnt146,vnt147
19039
19040C...Initialization of multiple interaction treatment.
19041 IF(mmul.EQ.1) THEN
19042 IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)
19043 isub=96
19044 mint(1)=96
19045 vint(63)=0d0
19046 vint(64)=0d0
19047 vint(143)=1d0
19048 vint(144)=1d0
19049
19050C...Loop over phase space points: xT2 choice in 20 bins.
19051 100 sigsum=0d0
19052 DO 120 ixt2=1,20
19053 nmul(ixt2)=mstp(83)
19054 sigm(ixt2)=0d0
19055 DO 110 itry=1,mstp(83)
19056 rsca=0.05d0*((21-ixt2)-pyr(0))
19057 xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)
19058 xt2=max(0.01d0*vint(149),xt2)
19059 vint(25)=xt2
19060
19061C...Choose tau and y*. Calculate cos(theta-hat).
19062 IF(pyr(0).LE.coef(isub,1)) THEN
19063 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
19064 tau=xt2*(1d0+taut)**2/(4d0*taut)
19065 ELSE
19066 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
19067 ENDIF
19068 vint(21)=tau
19069 CALL pyklim(2)
19070 ryst=pyr(0)
19071 myst=1
19072 IF(ryst.GT.coef(isub,8)) myst=2
19073 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
19074 CALL pykmap(2,myst,pyr(0))
19075 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
19076
19077C...Calculate differential cross-section.
19078 vint(71)=0.5d0*vint(1)*sqrt(xt2)
19079 CALL pysigh(nchn,sigs)
19080 sigm(ixt2)=sigm(ixt2)+sigs
19081 110 CONTINUE
19082 sigsum=sigsum+sigm(ixt2)
19083 120 CONTINUE
19084 sigsum=sigsum/(20d0*mstp(83))
19085
19086C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19087 IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN
19088 IF(mstp(122).GE.1) WRITE(mstu(11),5100)
19089 & parp(82)*(vint(1)/parp(89))**parp(90),sigsum
19090 parp(82)=0.9d0*parp(82)
19091 vint(149)=4d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
19092 & vint(2)
19093 GOTO 100
19094 ENDIF
19095 IF(mstp(122).GE.1) WRITE(mstu(11),5200)
19096 & parp(82)*(vint(1)/parp(89))**parp(90), sigsum
19097
19098C...Start iteration to find k factor.
19099 yke=sigsum/max(1d-10,sigt(0,0,5))
19100 p83a=(1d0-parp(83))**2
19101 p83b=2d0*parp(83)*(1d0-parp(83))
19102 p83c=parp(83)**2
19103 cq2i=1d0/parp(84)**2
19104 cq2r=2d0/(1d0+parp(84)**2)
19105 so=0.5d0
19106 xi=0d0
19107 yi=0d0
19108 xf=0d0
19109 yf=0d0
19110 xk=0.5d0
19111 iit=0
19112 130 IF(iit.EQ.0) THEN
19113 xk=2d0*xk
19114 ELSEIF(iit.EQ.1) THEN
19115 xk=0.5d0*xk
19116 ELSE
19117 xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
19118 ENDIF
19119
19120C...Evaluate overlap integrals. Find where to divide the b range.
19121 IF(mstp(82).EQ.2) THEN
19122 sp=0.5d0*paru(1)*(1d0-exp(-xk))
19123 sop=sp/paru(1)
19124 ELSE
19125 IF(mstp(82).EQ.3) THEN
19126 deltab=0.02d0
19127 ELSEIF(mstp(82).EQ.4) THEN
19128 deltab=min(0.01d0,0.05d0*parp(84))
19129 ELSE
19130 powip=max(0.4d0,parp(83))
19131 rpwip=2d0/powip-1d0
19132 deltab=max(0.02d0,0.02d0*(2d0/powip)**(1d0/powip))
19133 so=0d0
19134 ENDIF
19135 sp=0d0
19136 sop=0d0
19137 bsp=0d0
19138 sohigh=0d0
19139 ibdiv=0
19140 b=-0.5d0*deltab
19141 140 b=b+deltab
19142 IF(mstp(82).EQ.3) THEN
19143 ov=exp(-b**2)/paru(2)
19144 ELSEIF(mstp(82).EQ.4) THEN
19145 ov=(p83a*exp(-min(50d0,b**2))+
19146 & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19147 & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19148 ELSE
19149 ov=exp(-b**powip)/paru(2)
19150 so=so+paru(2)*b*deltab*ov
19151 ENDIF
19152 IF(ibdiv.EQ.1) sohigh=sohigh+paru(2)*b*deltab*ov
19153 pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))
19154 sp=sp+paru(2)*b*deltab*pacc
19155 sop=sop+paru(2)*b*deltab*ov*pacc
19156 bsp=bsp+b*paru(2)*b*deltab*pacc
19157 IF(ibdiv.EQ.0.AND.paru(1)*xk*ov.LT.1d0) THEN
19158 ibdiv=1
19159 bdiv=b+0.5d0*deltab
19160 ENDIF
19161 IF(b.LT.1d0.OR.b*pacc.GT.1d-6) GOTO 140
19162 ENDIF
19163 yk=paru(1)*xk*so/sp
19164
19165C...Continue iteration until convergence.
19166 IF(yk.LT.yke) THEN
19167 xi=xk
19168 yi=yk
19169 IF(iit.EQ.1) iit=2
19170 ELSE
19171 xf=xk
19172 yf=yk
19173 IF(iit.EQ.0) iit=1
19174 ENDIF
19175 IF(abs(yk-yke).GE.1d-5*yke) GOTO 130
19176
19177C...Store some results for subsequent use.
19178 bavg=bsp/sp
19179 vint(145)=sigsum
19180 vint(146)=sop/so
19181 vint(147)=sop/sp
19182 vnt145=vint(145)
19183 vnt146=vint(146)
19184 vnt147=vint(147)
19185C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19186 pik=(vnt146/vnt147)*yke
19187
19188C...Find relative weight for low and high impact parameter.
19189 plowb=paru(1)*bdiv**2
19190 IF(mstp(82).EQ.3) THEN
19191 phighb=pik*0.5*exp(-bdiv**2)
19192 ELSEIF(mstp(82).EQ.4) THEN
19193 s4a=p83a*exp(-bdiv**2)
19194 s4b=p83b*exp(-bdiv**2*cq2r)
19195 s4c=p83c*exp(-bdiv**2*cq2i)
19196 phighb=pik*0.5*(s4a+s4b+s4c)
19197 ELSEIF(parp(83).GE.1.999d0) THEN
19198 phighb=pik*sohigh
19199 b2rpdv=bdiv**powip
19200 ELSE
19201 phighb=pik*sohigh
19202 b2rpdv=bdiv**powip
19203 b2rpmx=max(2d0*rpwip,b2rpdv)
19204 ENDIF
19205 pallb=plowb+phighb
19206
19207C...Initialize iteration in xT2 for hardest interaction.
19208 ELSEIF(mmul.EQ.2) THEN
19209 vint(145)=vnt145
19210 vint(146)=vnt146
19211 vint(147)=vnt147
19212 IF(mstp(82).LE.0) THEN
19213 ELSEIF(mstp(82).EQ.1) THEN
19214 xt2=1d0
19215 sigrat=xsec(96,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
19216 IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
19217 & vint(317)/(vint(318)*vint(320))
19218 xt2fac=sigrat*vint(149)/(1d0-vint(149))
19219 ELSEIF(mstp(82).EQ.2) THEN
19220 xt2=1d0
19221 xt2fac=vnt146*xsec(96,1)/max(1d-10,sigt(0,0,5))*
19222 & vint(149)*(1d0+vint(149))
19223 ELSE
19224 xc2=4d0*ckin(3)**2/vint(2)
19225 IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0
19226 ENDIF
19227
19228C...Select impact parameter for hardest interaction.
19229 IF(mstp(82).LE.2) RETURN
19230 142 IF(pyr(0)*pallb.LT.plowb) THEN
19231C...Treatment in low b region.
19232 mint(39)=1
19233 b=bdiv*sqrt(pyr(0))
19234 IF(mstp(82).EQ.3) THEN
19235 ov=exp(-b**2)/paru(2)
19236 ELSEIF(mstp(82).EQ.4) THEN
19237 ov=(p83a*exp(-min(50d0,b**2))+
19238 & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19239 & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19240 ELSE
19241 ov=exp(-b**powip)/paru(2)
19242 ENDIF
19243 vint(148)=ov/vnt147
19244 pacc=1d0-exp(-min(50d0,pik*ov))
19245 xt2=1d0
19246 xt2fac=vnt146*vint(148)*xsec(96,1)/max(1d-10,sigt(0,0,5))*
19247 & vint(149)*(1d0+vint(149))
19248 ELSE
19249C...Treatment in high b region.
19250 mint(39)=2
19251 IF(mstp(82).EQ.3) THEN
19252 b=sqrt(bdiv**2-log(pyr(0)))
19253 ov=exp(-b**2)/paru(2)
19254 ELSEIF(mstp(82).EQ.4) THEN
19255 s4rndm=pyr(0)*(s4a+s4b+s4c)
19256 IF(s4rndm.LT.s4a) THEN
19257 b=sqrt(bdiv**2-log(pyr(0)))
19258 ELSEIF(s4rndm.LT.s4a+s4b) THEN
19259 b=sqrt(bdiv**2-log(pyr(0))/cq2r)
19260 ELSE
19261 b=sqrt(bdiv**2-log(pyr(0))/cq2i)
19262 ENDIF
19263 ov=(p83a*exp(-min(50d0,b**2))+
19264 & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
19265 & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
19266 ELSEIF(parp(83).GE.1.999d0) THEN
19267 144 b2rpw=b2rpdv-log(pyr(0))
19268 accip=(b2rpw/b2rpdv)**rpwip
19269 IF(accip.LT.pyr(0)) GOTO 144
19270 ov=exp(-b2rpw)/paru(2)
19271 b=b2rpw**(1d0/powip)
19272 ELSE
19273 146 b2rpw=b2rpdv-2d0*log(pyr(0))
19274 accip=(b2rpw/b2rpmx)**rpwip*exp(-0.5d0*(b2rpw-b2rpmx))
19275 IF(accip.LT.pyr(0)) GOTO 146
19276 ov=exp(-b2rpw)/paru(2)
19277 b=b2rpw**(1d0/powip)
19278 ENDIF
19279 vint(148)=ov/vnt147
19280 pacc=(1d0-exp(-min(50d0,pik*ov)))/(pik*ov)
19281 ENDIF
19282 IF(pacc.LT.pyr(0)) GOTO 142
19283 vint(139)=b/bavg
19284
19285 ELSEIF(mmul.EQ.3) THEN
19286C...Low-pT or multiple interactions (first semihard interaction):
19287C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19288C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19289 isub=mint(1)
19290 vint(145)=vnt145
19291 vint(146)=vnt146
19292 vint(147)=vnt147
19293 IF(mstp(82).LE.0) THEN
19294 xt2=0d0
19295 ELSEIF(mstp(82).EQ.1) THEN
19296 xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
19297C...Use with "Sudakov" for low b values when impact parameter dependence.
19298 ELSEIF(mstp(82).EQ.2.OR.mint(39).EQ.1) THEN
19299 IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
19300 & vint(149)))).GT.pyr(0)) xt2=1d0
19301 IF(xt2.GE.1d0) THEN
19302 xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-
19303 & pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-
19304 & vint(149)
19305 ELSE
19306 xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*
19307 & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
19308 & vint(149)
19309 ENDIF
19310 xt2=max(0.01d0*vint(149),xt2)
19311C...Use without "Sudakov" for high b values when impact parameter dep.
19312 ELSE
19313 xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-
19314 & pyr(0)*(1d0-xc2))-vint(149)
19315 xt2=max(0.01d0*vint(149),xt2)
19316 ENDIF
19317 vint(25)=xt2
19318
19319C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19320 IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
19321 IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-mint(143)
19322 IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-mint(143)
19323 isub=95
19324 mint(1)=isub
19325 vint(21)=0.01d0*vint(149)
19326 vint(22)=0d0
19327 vint(23)=0d0
19328 vint(25)=0.01d0*vint(149)
19329
19330 ELSE
19331C...Multiple interactions (first semihard interaction).
19332C...Choose tau and y*. Calculate cos(theta-hat).
19333 IF(pyr(0).LE.coef(isub,1)) THEN
19334 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
19335 tau=xt2*(1d0+taut)**2/(4d0*taut)
19336 ELSE
19337 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
19338 ENDIF
19339 vint(21)=tau
19340 CALL pyklim(2)
19341 ryst=pyr(0)
19342 myst=1
19343 IF(ryst.GT.coef(isub,8)) myst=2
19344 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
19345 CALL pykmap(2,myst,pyr(0))
19346 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
19347 ENDIF
19348 vint(71)=0.5d0*vint(1)*sqrt(vint(25))
19349
19350C...Store results of cross-section calculation.
19351 ELSEIF(mmul.EQ.4) THEN
19352 isub=mint(1)
19353 vint(145)=vnt145
19354 vint(146)=vnt146
19355 vint(147)=vnt147
19356 xts=vint(25)
19357 IF(iset(isub).EQ.1) xts=vint(21)
19358 IF(iset(isub).EQ.2)
19359 & xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
19360 IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)
19361 rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/
19362 & (xts+vint(149))))
19363 irbin=int(1d0+20d0*rbin)
19364 IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN
19365 nmul(irbin)=nmul(irbin)+1
19366 sigm(irbin)=sigm(irbin)+vint(153)
19367 ENDIF
19368
19369C...Choose impact parameter if not already done.
19370 ELSEIF(mmul.EQ.5) THEN
19371 isub=mint(1)
19372 vint(145)=vnt145
19373 vint(146)=vnt146
19374 vint(147)=vnt147
19375 150 IF(mint(39).GT.0) THEN
19376 ELSEIF(mstp(82).EQ.3) THEN
19377 expb2=pyr(0)
19378 b2=-log(pyr(0))
19379 vint(148)=expb2/(paru(2)*vnt147)
19380 vint(139)=sqrt(b2)/bavg
19381 ELSEIF(mstp(82).EQ.4) THEN
19382 rtype=pyr(0)
19383 IF(rtype.LT.p83a) THEN
19384 b2=-log(pyr(0))
19385 ELSEIF(rtype.LT.p83a+p83b) THEN
19386 b2=-log(pyr(0))/cq2r
19387 ELSE
19388 b2=-log(pyr(0))/cq2i
19389 ENDIF
19390 vint(148)=(p83a*exp(-min(50d0,b2))+
19391 & p83b*cq2r*exp(-min(50d0,b2*cq2r))+
19392 & p83c*cq2i*exp(-min(50d0,b2*cq2i)))/(paru(2)*vnt147)
19393 vint(139)=sqrt(b2)/bavg
19394 ELSEIF(parp(83).GE.1.999d0) THEN
19395 powip=max(2d0,parp(83))
19396 rpwip=2d0/powip-1d0
19397 prob1=powip/(2d0*exp(-1d0)+powip)
19398 160 IF(pyr(0).LT.prob1) THEN
19399 b2rpw=pyr(0)**(0.5d0*powip)
19400 accip=exp(-b2rpw)
19401 ELSE
19402 b2rpw=1d0-log(pyr(0))
19403 accip=b2rpw**rpwip
19404 ENDIF
19405 IF(accip.LT.pyr(0)) GOTO 160
19406 vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
19407 vint(139)=b2rpw**(1d0/powip)/bavg
19408 ELSE
19409 powip=max(0.4d0,parp(83))
19410 rpwip=2d0/powip-1d0
19411 prob1=rpwip/(rpwip+2d0**rpwip*exp(-rpwip))
19412 170 IF(pyr(0).LT.prob1) THEN
19413 b2rpw=2d0*rpwip*pyr(0)
19414 accip=(b2rpw/rpwip)**rpwip*exp(rpwip-b2rpw)
19415 ELSE
19416 b2rpw=2d0*(rpwip-log(pyr(0)))
19417 accip=(0.5d0*b2rpw/rpwip)**rpwip*exp(rpwip-0.5d0*b2rpw)
19418 ENDIF
19419 IF(accip.lt .pyr(0)) GOTO 170
19420 vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
19421 vint(139)=b2rpw**(1d0/powip)/bavg
19422 ENDIF
19423
19424C...Multiple interactions (variable impact parameter) : reject with
19425C...probability exp(-overlap*cross-section above pT/normalization).
19426C...Does not apply to low-b region, where "Sudakov" already included.
19427 vint(150)=1d0
19428 IF(mint(39).NE.1) THEN
19429 rncor=(irbin-20d0*rbin)*nmul(irbin)
19430 sigcor=(irbin-20d0*rbin)*sigm(irbin)
19431 DO 180 ibin=irbin+1,20
19432 rncor=rncor+nmul(ibin)
19433 sigcor=sigcor+sigm(ibin)
19434 180 CONTINUE
19435 sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))
19436 IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)
19437 vint(150)=exp(-min(50d0,vnt146*vint(148)*
19438 & sigabv/max(1d-10,sigt(0,0,5))))
19439 ENDIF
19440 IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isub.NE.11.AND.
19441 & isub.NE.12.AND.isub.NE.13.AND.isub.NE.28.AND.isub.NE.53
19442 & .AND.isub.NE.68.AND.isub.NE.95.AND.isub.NE.96)) THEN
19443 IF(vint(150).LT.pyr(0)) GOTO 150
19444 vint(150)=1d0
19445 ENDIF
19446
19447C...Generate additional multiple semihard interactions.
19448 ELSEIF(mmul.EQ.6) THEN
19449 isubsv=mint(1)
19450 vint(145)=vnt145
19451 vint(146)=vnt146
19452 vint(147)=vnt147
19453 DO 190 j=11,80
19454 vintsv(j)=vint(j)
19455 190 CONTINUE
19456 isub=96
19457 mint(1)=96
19458 vint(151)=0d0
19459 vint(152)=0d0
19460
19461C...Reconstruct strings in hard scattering.
19462 nmax=mint(84)+4
19463 IF(iset(isubsv).EQ.1) nmax=mint(84)+2
19464 IF(iset(isubsv).EQ.11) nmax=mint(84)+2+mint(3)
19465 nstr=0
19466 DO 210 i=mint(84)+1,nmax
19467 kcs=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
19468 IF(kcs.EQ.0) GOTO 210
19469 DO 200 j=1,4
19470 IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) GOTO 200
19471 IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) GOTO 200
19472 IF(j.LE.2) THEN
19473 ist=mod(k(i,j+3)/mstu(5),mstu(5))
19474 ELSE
19475 ist=mod(k(i,j+1),mstu(5))
19476 ENDIF
19477 IF(ist.LT.mint(84).OR.ist.GT.i) GOTO 200
19478 IF(kchg(pycomp(k(ist,2)),2).EQ.0) GOTO 200
19479 nstr=nstr+1
19480 IF(j.EQ.1.OR.j.EQ.4) THEN
19481 kstr(nstr,1)=i
19482 kstr(nstr,2)=ist
19483 ELSE
19484 kstr(nstr,1)=ist
19485 kstr(nstr,2)=i
19486 ENDIF
19487 200 CONTINUE
19488 210 CONTINUE
19489
19490C...Set up starting values for iteration in xT2.
19491 xt2=4d0*vint(62)/vint(2)
19492 IF(mstp(82).LE.1) THEN
19493 sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
19494 IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
19495 & vint(317)/(vint(318)*vint(320))
19496 xt2fac=sigrat*vint(149)/(1d0-vint(149))
19497 ELSE
19498 xt2fac=vnt146*vint(148)*xsec(isub,1)/
19499 & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
19500 ENDIF
19501 vint(63)=0d0
19502 vint(64)=0d0
19503 vint(143)=1d0-vint(141)
19504 vint(144)=1d0-vint(142)
19505
19506C...Iterate downwards in xT2.
19507 220 IF(mstp(82).LE.1) THEN
19508 xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
19509 IF(xt2.LT.vint(149)) GOTO 270
19510 ELSE
19511 IF(xt2.LE.0.01001d0*vint(149)) GOTO 270
19512 xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
19513 & log(pyr(0)))-vint(149)
19514 IF(xt2.LE.0d0) GOTO 270
19515 xt2=max(0.01d0*vint(149),xt2)
19516 ENDIF
19517 vint(25)=xt2
19518
19519C...Choose tau and y*. Calculate cos(theta-hat).
19520 IF(pyr(0).LE.coef(isub,1)) THEN
19521 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
19522 tau=xt2*(1d0+taut)**2/(4d0*taut)
19523 ELSE
19524 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
19525 ENDIF
19526 vint(21)=tau
19527 CALL pyklim(2)
19528 ryst=pyr(0)
19529 myst=1
19530 IF(ryst.GT.coef(isub,8)) myst=2
19531 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
19532 CALL pykmap(2,myst,pyr(0))
19533 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
19534
19535C...Check that x not used up. Accept or reject kinematical variables.
19536 x1m=sqrt(tau)*exp(vint(22))
19537 x2m=sqrt(tau)*exp(-vint(22))
19538 IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) GOTO 220
19539 vint(71)=0.5d0*vint(1)*sqrt(xt2)
19540 CALL pysigh(nchn,sigs)
19541 IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
19542 IF(sigs.LT.xsec(isub,1)*pyr(0)) GOTO 220
19543
19544C...Reset K, P and V vectors. Select some variables.
19545 DO 240 i=n+1,n+2
19546 DO 230 j=1,5
19547 k(i,j)=0
19548 p(i,j)=0d0
19549 v(i,j)=0d0
19550 230 CONTINUE
19551 240 CONTINUE
19552 rflav=pyr(0)
19553 pt=0.5d0*vint(1)*sqrt(xt2)
19554 phi=paru(2)*pyr(0)
19555 cth=vint(23)
19556
19557C...Add first parton to event record.
19558 k(n+1,1)=3
19559 k(n+1,2)=21
19560 IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=
19561 & 1+int((2d0+parj(2))*pyr(0))
19562 p(n+1,1)=pt*cos(phi)
19563 p(n+1,2)=pt*sin(phi)
19564 p(n+1,3)=0.25d0*vint(1)*(vint(41)*(1d0+cth)-vint(42)*(1d0-cth))
19565 p(n+1,4)=0.25d0*vint(1)*(vint(41)*(1d0+cth)+vint(42)*(1d0-cth))
19566 p(n+1,5)=0d0
19567
19568C...Add second parton to event record.
19569 k(n+2,1)=3
19570 k(n+2,2)=21
19571 IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)
19572 p(n+2,1)=-p(n+1,1)
19573 p(n+2,2)=-p(n+1,2)
19574 p(n+2,3)=0.25d0*vint(1)*(vint(41)*(1d0-cth)-vint(42)*(1d0+cth))
19575 p(n+2,4)=0.25d0*vint(1)*(vint(41)*(1d0-cth)+vint(42)*(1d0+cth))
19576 p(n+2,5)=0d0
19577
19578 IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN
19579C....Choose relevant string pieces to place gluons on.
19580 DO 260 i=n+1,n+2
19581 dmin=1d8
19582 DO 250 istr=1,nstr
19583 i1=kstr(istr,1)
19584 i2=kstr(istr,2)
19585 dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-
19586 & p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-
19587 & p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1d0,p(i1,4)*p(i2,4)-
19588 & p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))
19589 IF(istr.EQ.1.OR.dist.LT.dmin) THEN
19590 dmin=dist
19591 ist1=i1
19592 ist2=i2
19593 istm=istr
19594 ENDIF
19595 250 CONTINUE
19596
19597C....Colour flow adjustments, new string pieces.
19598 IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+
19599 & mod(k(ist1,4),mstu(5))
19600 IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)=
19601 & mstu(5)*(k(ist1,5)/mstu(5))+i
19602 k(i,5)=mstu(5)*ist1
19603 k(i,4)=mstu(5)*ist2
19604 IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+
19605 & mod(k(ist2,5),mstu(5))
19606 IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)=
19607 & mstu(5)*(k(ist2,4)/mstu(5))+i
19608 kstr(istm,2)=i
19609 kstr(nstr+1,1)=i
19610 kstr(nstr+1,2)=ist2
19611 nstr=nstr+1
19612 260 CONTINUE
19613
19614C...String drawing and colour flow for gluon loop.
19615 ELSEIF(k(n+1,2).EQ.21) THEN
19616 k(n+1,4)=mstu(5)*(n+2)
19617 k(n+1,5)=mstu(5)*(n+2)
19618 k(n+2,4)=mstu(5)*(n+1)
19619 k(n+2,5)=mstu(5)*(n+1)
19620 kstr(nstr+1,1)=n+1
19621 kstr(nstr+1,2)=n+2
19622 kstr(nstr+2,1)=n+2
19623 kstr(nstr+2,2)=n+1
19624 nstr=nstr+2
19625
19626C...String drawing and colour flow for qqbar pair.
19627 ELSE
19628 k(n+1,4)=mstu(5)*(n+2)
19629 k(n+2,5)=mstu(5)*(n+1)
19630 kstr(nstr+1,1)=n+1
19631 kstr(nstr+1,2)=n+2
19632 nstr=nstr+1
19633 ENDIF
19634
19635C...Global statistics.
19636 mint(351)=mint(351)+1
19637 vint(351)=vint(351)+pt
19638 IF (mint(351).EQ.1) vint(356)=pt
19639
19640C...Update remaining energy; iterate.
19641 n=n+2
19642 IF(n.GT.mstu(4)-mstu(32)-10) THEN
19643 CALL pyerrm(11,'(PYMULT:) no more memory left in PYJETS')
19644 mint(51)=1
19645 RETURN
19646 ENDIF
19647 mint(31)=mint(31)+1
19648 vint(151)=vint(151)+vint(41)
19649 vint(152)=vint(152)+vint(42)
19650 vint(143)=vint(143)-vint(41)
19651 vint(144)=vint(144)-vint(42)
19652C...Allow FSR for UE (always handle with old showers)
19653 IF(mstp(152).EQ.1) THEN
19654 m41sav=mstj(41)
19655 IF (mstj(41).EQ.10) mstj(41)=2
19656 mstj(41)=mod(mstj(41),10)
19657 CALL pyshow(n-1,n,sqrt(parp(71))*pt)
19658 mstj(41)=m41sav
19659 ENDIF
19660 IF(mint(31).LT.240) GOTO 220
19661 270 CONTINUE
19662 mint(1)=isubsv
19663 DO 280 j=11,80
19664 vint(j)=vintsv(j)
19665 280 CONTINUE
19666 ENDIF
19667
19668C...Format statements for printout.
19669 5000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter',
19670 &'actions for MSTP(82) =',i2,' ******')
19671 5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
19672 &d9.2,' mb: rejected')
19673 5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
19674 &d9.2,' mb: accepted')
19675
19676 RETURN
19677 END
19678
19679C*********************************************************************
19680
19681C...PYREMN
19682C...Adds on target remnants (one or two from each side) and
19683C...includes primordial kT for hadron beams.
19684
19685 SUBROUTINE pyremn(IPU1,IPU2)
19686
19687C...Double precision and integer declarations.
19688 IMPLICIT DOUBLE PRECISION(a-h, o-z)
19689 IMPLICIT INTEGER(I-N)
19690 INTEGER PYK,PYCHGE,PYCOMP
19691C...Commonblocks.
19692 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
19693 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
19694 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
19695 common/pypars/mstp(200),parp(200),msti(200),pari(200)
19696 common/pyint1/mint(400),vint(400)
19697 SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
19698C...Local arrays.
19699 dimension kflch(2),kflsp(2),chi(2),pms(0:6),is(2),isn(2),robo(5),
19700 &psys(0:2,5),pmin(0:2),qold(4),qnew(4),dbe(3),psum(4)
19701
19702C...Find event type and remaining energy.
19703 isub=mint(1)
19704 ns=n
19705 IF(mint(50).EQ.0.OR.mod(mstp(81),10).LE.0) THEN
19706 vint(143)=1d0-vint(141)
19707 vint(144)=1d0-vint(142)
19708 ENDIF
19709
19710C...Define initial partons.
19711 ntry=0
19712 100 ntry=ntry+1
19713 DO 130 jt=1,2
19714 i=mint(83)+jt+2
19715 IF(jt.EQ.1) ipu=ipu1
19716 IF(jt.EQ.2) ipu=ipu2
19717 k(i,1)=21
19718 k(i,2)=k(ipu,2)
19719 k(i,3)=i-2
19720 pms(jt)=0d0
19721 vint(156+jt)=0d0
19722 vint(158+jt)=0d0
19723 IF(mint(47).EQ.1) THEN
19724 DO 110 j=1,5
19725 p(i,j)=p(i-2,j)
19726 110 CONTINUE
19727 ELSEIF(isub.EQ.95) THEN
19728 k(i,2)=21
19729 ELSE
19730 p(i,5)=p(ipu,5)
19731
19732C...No primordial kT, or chosen according to truncated Gaussian or
19733C...exponential, or (for photon) predetermined or power law.
19734 120 IF(mint(40+jt).EQ.2.AND.mint(10+jt).NE.22) THEN
19735 IF(mstp(91).LE.0) THEN
19736 pt=0d0
19737 ELSEIF(mstp(91).EQ.1) THEN
19738 pt=parp(91)*sqrt(-log(pyr(0)))
19739 ELSE
19740 rpt1=pyr(0)
19741 rpt2=pyr(0)
19742 pt=-parp(92)*log(rpt1*rpt2)
19743 ENDIF
19744 IF(pt.GT.parp(93)) GOTO 120
19745 ELSEIF(mint(106+jt).EQ.3) THEN
19746 pta=sqrt(vint(282+jt))
19747 ptb=0d0
19748 IF(mstp(66).EQ.5.AND.mstp(93).EQ.1) THEN
19749 ptb=parp(99)*sqrt(-log(pyr(0)))
19750 ELSEIF(mstp(66).EQ.5.AND.mstp(93).EQ.2) THEN
19751 rpt1=pyr(0)
19752 rpt2=pyr(0)
19753 ptb=-parp(99)*log(rpt1*rpt2)
19754 ENDIF
19755 IF(ptb.GT.parp(100)) GOTO 120
19756 pt=sqrt(pta**2+ptb**2+2d0*pta*ptb*cos(paru(2)*pyr(0)))
19757 pt=pt*0.8d0**mint(57)
19758 IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
19759 ELSEIF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) THEN
19760 IF(mstp(93).LE.0) THEN
19761 pt=0d0
19762 ELSEIF(mstp(93).EQ.1) THEN
19763 pt=parp(99)*sqrt(-log(pyr(0)))
19764 ELSEIF(mstp(93).EQ.2) THEN
19765 rpt1=pyr(0)
19766 rpt2=pyr(0)
19767 pt=-parp(99)*log(rpt1*rpt2)
19768 ELSEIF(mstp(93).EQ.3) THEN
19769 ha=parp(99)**2
19770 hb=parp(100)**2
19771 pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
19772 ELSE
19773 ha=parp(99)**2
19774 hb=parp(100)**2
19775 IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
19776 pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
19777 ENDIF
19778 IF(pt.GT.parp(100)) GOTO 120
19779 ELSE
19780 pt=0d0
19781 ENDIF
19782 vint(156+jt)=pt
19783 phi=paru(2)*pyr(0)
19784 p(i,1)=pt*cos(phi)
19785 p(i,2)=pt*sin(phi)
19786 pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
19787 ENDIF
19788 130 CONTINUE
19789 IF(mint(47).EQ.1) RETURN
19790
19791C...Kinematics construction for initial partons.
19792 i1=mint(83)+3
19793 i2=mint(83)+4
19794 IF(isub.EQ.95) THEN
19795 shs=0d0
19796 shr=0d0
19797 ELSE
19798 shs=vint(141)*vint(142)*vint(2)+(p(i1,1)+p(i2,1))**2+
19799 & (p(i1,2)+p(i2,2))**2
19800 shr=sqrt(max(0d0,shs))
19801 IF((shs-pms(1)-pms(2))**2-4d0*pms(1)*pms(2).LE.0d0) GOTO 100
19802 p(i1,4)=0.5d0*(shr+(pms(1)-pms(2))/shr)
19803 p(i1,3)=sqrt(max(0d0,p(i1,4)**2-pms(1)))
19804 p(i2,4)=shr-p(i1,4)
19805 p(i2,3)=-p(i1,3)
19806
19807C...Transform partons to overall CM-frame.
19808 robo(3)=(p(i1,1)+p(i2,1))/shr
19809 robo(4)=(p(i1,2)+p(i2,2))/shr
19810 CALL pyrobo(i1,i2,0d0,0d0,-robo(3),-robo(4),0d0)
19811 robo(2)=pyangl(p(i1,1),p(i1,2))
19812 CALL pyrobo(i1,i2,0d0,-robo(2),0d0,0d0,0d0)
19813 robo(1)=pyangl(p(i1,3),p(i1,1))
19814 CALL pyrobo(i1,i2,-robo(1),0d0,0d0,0d0,0d0)
19815 CALL pyrobo(i2+1,mint(52),0d0,-robo(2),0d0,0d0,0d0)
19816 CALL pyrobo(i1,mint(52),robo(1),robo(2),robo(3),robo(4),0d0)
19817 robo(5)=(vint(141)-vint(142))/(vint(141)+vint(142))
19818 CALL pyrobo(i1,mint(52),0d0,0d0,0d0,0d0,robo(5))
19819 ENDIF
19820
19821C...Optionally fix up x and Q2 definitions for leptoproduction.
19822 idisxq=0
19823 IF((mint(43).EQ.2.OR.mint(43).EQ.3).AND.((isub.EQ.10.AND.
19824 &mstp(23).GE.1).OR.(isub.EQ.83.AND.mstp(23).GE.2))) idisxq=1
19825 IF(idisxq.EQ.1) THEN
19826
19827C...Find where incoming and outgoing leptons/partons are sitting.
19828 lesd=1
19829 IF(mint(42).EQ.1) lesd=2
19830 lpin=mint(83)+3-lesd
19831 lein=mint(84)+lesd
19832 lqin=mint(84)+3-lesd
19833 leout=mint(84)+2+lesd
19834 lqout=mint(84)+5-lesd
19835 IF(k(lein,3).GT.lein) lein=k(lein,3)
19836 IF(k(lqin,3).GT.lqin) lqin=k(lqin,3)
19837 lscms=0
19838 DO 140 i=mint(84)+5,n
19839 IF(k(i,2).EQ.94) THEN
19840 lscms=i
19841 leout=i+lesd
19842 lqout=i+3-lesd
19843 ENDIF
19844 140 CONTINUE
19845 lqbg=ipu1
19846 IF(lesd.EQ.1) lqbg=ipu2
19847
19848C...Calculate actual and wanted momentum transfer.
19849 xnom=vint(43-lesd)
19850 q2nom=-vint(45)
19851 hpk=2d0*(p(lpin,4)*p(lein,4)-p(lpin,1)*p(lein,1)-
19852 & p(lpin,2)*p(lein,2)-p(lpin,3)*p(lein,3))*
19853 & (p(mint(83)+lesd,4)*vint(40+lesd)/p(lein,4))
19854 hpt2=max(0d0,q2nom*(1d0-q2nom/(xnom*hpk)))
19855 fac=sqrt(hpt2/(p(leout,1)**2+p(leout,2)**2))
19856 p(n+1,1)=fac*p(leout,1)
19857 p(n+1,2)=fac*p(leout,2)
19858 p(n+1,3)=0.25d0*((hpk-q2nom/xnom)/p(lpin,4)-
19859 & q2nom/(p(mint(83)+lesd,4)*vint(40+lesd)))*(-1)**(lesd+1)
19860 p(n+1,4)=sqrt(p(leout,5)**2+p(n+1,1)**2+p(n+1,2)**2+
19861 & p(n+1,3)**2)
19862 DO 150 j=1,4
19863 qold(j)=p(lein,j)-p(leout,j)
19864 qnew(j)=p(lein,j)-p(n+1,j)
19865 150 CONTINUE
19866
19867C...Boost outgoing electron and daughters.
19868 IF(lscms.EQ.0) THEN
19869 DO 160 j=1,4
19870 p(leout,j)=p(n+1,j)
19871 160 CONTINUE
19872 ELSE
19873 DO 170 j=1,3
19874 p(n+2,j)=(p(n+1,j)-p(leout,j))/(p(n+1,4)+p(leout,4))
19875 170 CONTINUE
19876 pinv=2d0/(1d0+p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2)
19877 DO 180 j=1,3
19878 dbe(j)=pinv*p(n+2,j)
19879 180 CONTINUE
19880 DO 200 i=lscms+1,n
19881 iorig=i
19882 190 iorig=k(iorig,3)
19883 IF(iorig.GT.leout) GOTO 190
19884 IF(i.EQ.leout.OR.iorig.EQ.leout)
19885 & CALL pyrobo(i,i,0d0,0d0,dbe(1),dbe(2),dbe(3))
19886 200 CONTINUE
19887 ENDIF
19888
19889C...Copy shower initiator and all outgoing partons.
19890 ncop=n+1
19891 k(ncop,3)=lqbg
19892 DO 210 j=1,5
19893 p(ncop,j)=p(lqbg,j)
19894 210 CONTINUE
19895 DO 240 i=mint(84)+1,n
19896 icop=0
19897 IF(k(i,1).GT.10) GOTO 240
19898 IF(i.EQ.lqbg.OR.i.EQ.lqout) THEN
19899 icop=i
19900 ELSE
19901 iorig=i
19902 220 iorig=k(iorig,3)
19903 IF(iorig.EQ.lqbg.OR.iorig.EQ.lqout) THEN
19904 icop=iorig
19905 ELSEIF(iorig.GT.mint(84).AND.iorig.LE.n) THEN
19906 GOTO 220
19907 ENDIF
19908 ENDIF
19909 IF(icop.NE.0) THEN
19910 ncop=ncop+1
19911 k(ncop,3)=i
19912 DO 230 j=1,5
19913 p(ncop,j)=p(i,j)
19914 230 CONTINUE
19915 ENDIF
19916 240 CONTINUE
19917
19918C...Calculate relative rescaling factors.
19919 slc=3-2*lesd
19920 plcsum=0d0
19921 DO 250 i=n+2,ncop
19922 plcsum=plcsum+(p(i,4)+slc*p(i,3))
19923 250 CONTINUE
19924 DO 260 i=n+2,ncop
19925 v(i,1)=(p(i,4)+slc*p(i,3))/plcsum
19926 260 CONTINUE
19927
19928C...Transfer extra three-momentum of current.
19929 DO 280 i=n+2,ncop
19930 DO 270 j=1,3
19931 p(i,j)=p(i,j)+v(i,1)*(qnew(j)-qold(j))
19932 270 CONTINUE
19933 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
19934 280 CONTINUE
19935
19936C...Iterate change of initiator momentum to get energy right.
19937 iter=0
19938 290 iter=iter+1
19939 peex=-p(n+1,4)-qnew(4)
19940 pemv=-p(n+1,3)/p(n+1,4)
19941 DO 300 i=n+2,ncop
19942 peex=peex+p(i,4)
19943 pemv=pemv+v(i,1)*p(i,3)/p(i,4)
19944 300 CONTINUE
19945 IF(abs(pemv).LT.1d-10) THEN
19946 mint(51)=1
19947 mint(57)=mint(57)+1
19948 RETURN
19949 ENDIF
19950 pzch=-peex/pemv
19951 p(n+1,3)=p(n+1,3)+pzch
19952 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)
19953 DO 310 i=n+2,ncop
19954 p(i,3)=p(i,3)+v(i,1)*pzch
19955 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
19956 310 CONTINUE
19957 IF(iter.LT.10.AND.abs(peex).GT.1d-6*p(n+1,4)) GOTO 290
19958
19959C...Modify momenta in event record.
19960 hbe=2d0*(p(n+1,4)+p(lqbg,4))*(p(n+1,3)-p(lqbg,3))/
19961 & ((p(n+1,4)+p(lqbg,4))**2+(p(n+1,3)-p(lqbg,3))**2)
19962 IF(abs(hbe).GE.1d0) THEN
19963 mint(51)=1
19964 mint(57)=mint(57)+1
19965 RETURN
19966 ENDIF
19967 i=mint(83)+5-lesd
19968 CALL pyrobo(i,i,0d0,0d0,0d0,0d0,hbe)
19969 DO 330 i=n+1,ncop
19970 icop=k(i,3)
19971 DO 320 j=1,4
19972 p(icop,j)=p(i,j)
19973 320 CONTINUE
19974 330 CONTINUE
19975 ENDIF
19976
19977C...Check minimum invariant mass of remnant system(s).
19978 psys(0,4)=p(i1,4)+p(i2,4)+0.5d0*vint(1)*(vint(151)+vint(152))
19979 psys(0,3)=p(i1,3)+p(i2,3)+0.5d0*vint(1)*(vint(151)-vint(152))
19980 pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
19981 pmin(0)=sqrt(pms(0))
19982 DO 340 jt=1,2
19983 psys(jt,4)=0.5d0*vint(1)*vint(142+jt)
19984 psys(jt,3)=psys(jt,4)*(-1)**(jt-1)
19985 pmin(jt)=0d0
19986 IF(mint(44+jt).EQ.1) GOTO 340
19987 mint(105)=mint(102+jt)
19988 mint(109)=mint(106+jt)
19989 CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))
19990 IF(mint(51).NE.0) THEN
19991 mint(57)=mint(57)+1
19992 RETURN
19993 ENDIF
19994 IF(kflch(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflch(jt))
19995 IF(kflsp(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflsp(jt))
19996 IF(kflch(jt)*kflsp(jt).NE.0) pmin(jt)=pmin(jt)+0.5d0*parp(111)
19997 pmin(jt)=sqrt(pmin(jt)**2+p(mint(83)+jt+2,1)**2+
19998 & p(mint(83)+jt+2,2)**2)
19999 340 CONTINUE
20000 IF(pmin(0)+pmin(1)+pmin(2).GT.vint(1).OR.(mint(45).GE.2.AND.
20001 &pmin(1).GT.psys(1,4)).OR.(mint(46).GE.2.AND.pmin(2).GT.
20002 &psys(2,4))) THEN
20003 mint(51)=1
20004 mint(57)=mint(57)+1
20005 RETURN
20006 ENDIF
20007
20008C...Loop over two remnants; skip if none there.
20009 i=ns
20010 DO 410 jt=1,2
20011 isn(jt)=0
20012 IF(mint(44+jt).EQ.1) GOTO 410
20013 IF(jt.EQ.1) ipu=ipu1
20014 IF(jt.EQ.2) ipu=ipu2
20015
20016C...Store first remnant parton.
20017 i=i+1
20018 is(jt)=i
20019 isn(jt)=1
20020 DO 350 j=1,5
20021 k(i,j)=0
20022 p(i,j)=0d0
20023 v(i,j)=0d0
20024 350 CONTINUE
20025 k(i,1)=1
20026 k(i,2)=kflsp(jt)
20027 k(i,3)=mint(83)+jt
20028 p(i,5)=pymass(k(i,2))
20029
20030C...First parton colour connections and kinematics.
20031 kcol=kchg(pycomp(kflsp(jt)),2)
20032 IF(kcol.EQ.2) THEN
20033 k(i,1)=3
20034 k(i,4)=mstu(5)*ipu+ipu
20035 k(i,5)=mstu(5)*ipu+ipu
20036 k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
20037 k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
20038 ELSEIF(kcol.NE.0) THEN
20039 k(i,1)=3
20040 kfls=(3-kcol*isign(1,kflsp(jt)))/2
20041 k(i,kfls+3)=ipu
20042 k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
20043 ENDIF
20044 IF(kflch(jt).EQ.0) THEN
20045 p(i,1)=-p(mint(83)+jt+2,1)
20046 p(i,2)=-p(mint(83)+jt+2,2)
20047 pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2
20048 psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
20049 p(i,3)=psys(jt,3)
20050 p(i,4)=psys(jt,4)
20051
20052C...When extra remnant parton or hadron: store extra remnant.
20053 ELSE
20054 i=i+1
20055 isn(jt)=2
20056 DO 360 j=1,5
20057 k(i,j)=0
20058 p(i,j)=0d0
20059 v(i,j)=0d0
20060 360 CONTINUE
20061 k(i,1)=1
20062 k(i,2)=kflch(jt)
20063 k(i,3)=mint(83)+jt
20064 p(i,5)=pymass(k(i,2))
20065
20066C...Find parton colour connections of extra remnant.
20067 kcol=kchg(pycomp(kflch(jt)),2)
20068 IF(kcol.EQ.2) THEN
20069 k(i,1)=3
20070 k(i,4)=mstu(5)*ipu+ipu
20071 k(i,5)=mstu(5)*ipu+ipu
20072 k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i
20073 k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i
20074 ELSEIF(kcol.NE.0) THEN
20075 k(i,1)=3
20076 kfls=(3-kcol*isign(1,kflch(jt)))/2
20077 k(i,kfls+3)=ipu
20078 k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i
20079 ENDIF
20080
20081C...Relative transverse momentum when two remnants.
20082 loop=0
20083 370 loop=loop+1
20084 CALL pyptdi(1,p(i-1,1),p(i-1,2))
20085 IF(iabs(mint(10+jt)).LT.20) THEN
20086 p(i-1,1)=0d0
20087 p(i-1,2)=0d0
20088 ELSE
20089 p(i-1,1)=p(i-1,1)-0.5d0*p(mint(83)+jt+2,1)
20090 p(i-1,2)=p(i-1,2)-0.5d0*p(mint(83)+jt+2,2)
20091 ENDIF
20092 pms(jt+2)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
20093 p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1)
20094 p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2)
20095 pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
20096
20097C...Meson or baryon; photon as meson. For splitup below.
20098 imb=1
20099 IF(mod(mint(10+jt)/1000,10).NE.0) imb=2
20100
20101C***Relative distribution for electron into two electrons. Temporary!
20102 IF(iabs(mint(10+jt)).LT.20.AND.mint(14+jt).EQ.-mint(10+jt))
20103 & THEN
20104 chi(jt)=pyr(0)
20105
20106C...Relative distribution of electron energy into electron plus parton.
20107 ELSEIF(iabs(mint(10+jt)).LT.20) THEN
20108 xhrd=vint(140+jt)
20109 xe=vint(154+jt)
20110 chi(jt)=(xe-xhrd)/(1d0-xhrd)
20111
20112C...Relative distribution of energy for particle into two jets.
20113 ELSEIF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN
20114 chik=parp(92+2*imb)
20115 IF(mstp(92).LE.1) THEN
20116 IF(imb.EQ.1) chi(jt)=pyr(0)
20117 IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
20118 ELSEIF(mstp(92).EQ.2) THEN
20119 chi(jt)=1d0-pyr(0)**(1d0/(1d0+chik))
20120 ELSEIF(mstp(92).EQ.3) THEN
20121 cut=2d0*0.3d0/vint(1)
20122 380 chi(jt)=pyr(0)**2
20123 IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25d0*
20124 & (1d0-chi(jt))**chik.LT.pyr(0)) GOTO 380
20125 ELSEIF(mstp(92).EQ.4) THEN
20126 cut=2d0*0.3d0/vint(1)
20127 cutr=(1d0+sqrt(1d0+cut**2))/cut
20128 390 chir=cut*cutr**pyr(0)
20129 chi(jt)=(chir**2-cut**2)/(2d0*chir)
20130 IF((1d0-chi(jt))**chik.LT.pyr(0)) GOTO 390
20131 ELSE
20132 cut=2d0*0.3d0/vint(1)
20133 cuta=cut**(1d0-parp(98))
20134 cutb=(1d0+cut)**(1d0-parp(98))
20135 400 chi(jt)=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
20136 IF(((chi(jt)+cut)**2/(2d0*(chi(jt)**2+cut**2)))**
20137 & (0.5d0*parp(98))*(1d0-chi(jt))**chik.LT.pyr(0)) GOTO 400
20138 ENDIF
20139
20140C...Relative distribution of energy for particle into jet plus particle.
20141 ELSE
20142 IF(mstp(94).LE.1) THEN
20143 IF(imb.EQ.1) chi(jt)=pyr(0)
20144 IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))
20145 IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
20146 ELSEIF(mstp(94).EQ.2) THEN
20147 chi(jt)=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
20148 IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)
20149 ELSEIF(mstp(94).EQ.3) THEN
20150 CALL pyzdis(1,0,pms(jt+4),zz)
20151 chi(jt)=zz
20152 ELSE
20153 CALL pyzdis(1000,0,pms(jt+4),zz)
20154 chi(jt)=zz
20155 ENDIF
20156 ENDIF
20157
20158C...Construct total transverse mass; reject if too large.
20159 chi(jt)=max(1d-8,min(1d0-1d-8,chi(jt)))
20160 pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1d0-chi(jt))
20161 IF(pms(jt).GT.psys(jt,4)**2) THEN
20162 IF(loop.LT.100) THEN
20163 GOTO 370
20164 ELSE
20165 mint(51)=1
20166 mint(57)=mint(57)+1
20167 RETURN
20168 ENDIF
20169 ENDIF
20170 psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)
20171 vint(158+jt)=chi(jt)
20172
20173C...Subdivide longitudinal momentum according to value selected above.
20174 pw1=chi(jt)*(psys(jt,4)+abs(psys(jt,3)))
20175 p(is(jt)+1,4)=0.5d0*(pw1+pms(jt+4)/pw1)
20176 p(is(jt)+1,3)=0.5d0*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)
20177 p(is(jt),4)=psys(jt,4)-p(is(jt)+1,4)
20178 p(is(jt),3)=psys(jt,3)-p(is(jt)+1,3)
20179 ENDIF
20180 410 CONTINUE
20181 n=i
20182
20183C...Check if longitudinal boosts needed - if so pick two systems.
20184 pdev=abs(psys(0,4)+psys(1,4)+psys(2,4)-vint(1))+
20185 &abs(psys(0,3)+psys(1,3)+psys(2,3))
20186 IF(pdev.LE.1d-6*vint(1)) RETURN
20187 IF(isn(1).EQ.0) THEN
20188 ir=0
20189 il=2
20190 ELSEIF(isn(2).EQ.0) THEN
20191 ir=1
20192 il=0
20193 ELSEIF(vint(143).GT.0.2d0.AND.vint(144).GT.0.2d0) THEN
20194 ir=1
20195 il=2
20196 ELSEIF(vint(143).GT.0.2d0) THEN
20197 ir=1
20198 il=0
20199 ELSEIF(vint(144).GT.0.2d0) THEN
20200 ir=0
20201 il=2
20202 ELSEIF(pms(1)/psys(1,4)**2.GT.pms(2)/psys(2,4)**2) THEN
20203 ir=1
20204 il=0
20205 ELSE
20206 ir=0
20207 il=2
20208 ENDIF
20209 ig=3-ir-il
20210
20211C...E+-pL wanted for system to be modified.
20212 IF((ig.EQ.1.AND.isn(1).EQ.0).OR.(ig.EQ.2.AND.isn(2).EQ.0)) THEN
20213 ppb=vint(1)
20214 pnb=vint(1)
20215 ELSE
20216 ppb=vint(1)-(psys(ig,4)+psys(ig,3))
20217 pnb=vint(1)-(psys(ig,4)-psys(ig,3))
20218 ENDIF
20219
20220C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20221 IF(idisxq.EQ.1.AND.ig.NE.0) THEN
20222 ppb=ppb-(psys(0,4)+psys(0,3))
20223 pnb=pnb-(psys(0,4)-psys(0,3))
20224 DO 420 j=1,4
20225 psys(0,j)=0d0
20226 420 CONTINUE
20227 DO 450 i=mint(84)+1,ns
20228 IF(k(i,1).GT.10) GOTO 450
20229 incl=0
20230 iorig=i
20231 430 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20232 iorig=k(iorig,3)
20233 IF(iorig.GT.lpin) GOTO 430
20234 IF(incl.EQ.0) GOTO 450
20235 DO 440 j=1,4
20236 psys(0,j)=psys(0,j)+p(i,j)
20237 440 CONTINUE
20238 450 CONTINUE
20239 pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)
20240 ppb=ppb+(psys(0,4)+psys(0,3))
20241 pnb=pnb+(psys(0,4)-psys(0,3))
20242 ENDIF
20243
20244C...Construct longitudinal boosts.
20245 dpmtb=ppb*pnb
20246 dpmtr=pms(ir)
20247 dpmtl=pms(il)
20248 dsqlam=sqrt(max(0d0,(dpmtb-dpmtr-dpmtl)**2-4d0*dpmtr*dpmtl))
20249 IF(dsqlam.LE.1d-6*dpmtb) THEN
20250 mint(51)=1
20251 mint(57)=mint(57)+1
20252 RETURN
20253 ENDIF
20254 dsqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))
20255 drkr=(dpmtb+dpmtr-dpmtl+dsqlam*dsqsgn)/
20256 &(2d0*(psys(ir,4)+psys(ir,3))*pnb)
20257 drkl=(dpmtb+dpmtl-dpmtr+dsqlam*dsqsgn)/
20258 &(2d0*(psys(il,4)-psys(il,3))*ppb)
20259 dber=(drkr**2-1d0)/(drkr**2+1d0)
20260 dbel=-(drkl**2-1d0)/(drkl**2+1d0)
20261
20262C...Perform longitudinal boosts.
20263 IF(ir.EQ.1.AND.isn(1).EQ.1.AND.dber.LE.-0.99999999d0) THEN
20264 p(is(1),3)=0d0
20265 p(is(1),4)=sqrt(p(is(1),5)**2+p(is(1),1)**2+p(is(1),2)**2)
20266 ELSEIF(ir.EQ.1) THEN
20267 CALL pyrobo(is(1),is(1)+isn(1)-1,0d0,0d0,0d0,0d0,dber)
20268 ELSEIF(idisxq.EQ.1) THEN
20269 DO 470 i=i1,ns
20270 incl=0
20271 iorig=i
20272 460 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20273 iorig=k(iorig,3)
20274 IF(iorig.GT.lpin) GOTO 460
20275 IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dber)
20276 470 CONTINUE
20277 ELSE
20278 CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dber)
20279 ENDIF
20280 IF(il.EQ.2.AND.isn(2).EQ.1.AND.dbel.GE.0.99999999d0) THEN
20281 p(is(2),3)=0d0
20282 p(is(2),4)=sqrt(p(is(2),5)**2+p(is(2),1)**2+p(is(2),2)**2)
20283 ELSEIF(il.EQ.2) THEN
20284 CALL pyrobo(is(2),is(2)+isn(2)-1,0d0,0d0,0d0,0d0,dbel)
20285 ELSEIF(idisxq.EQ.1) THEN
20286 DO 490 i=i1,ns
20287 incl=0
20288 iorig=i
20289 480 IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1
20290 iorig=k(iorig,3)
20291 IF(iorig.GT.lpin) GOTO 480
20292 IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dbel)
20293 490 CONTINUE
20294 ELSE
20295 CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dbel)
20296 ENDIF
20297
20298C...Final check that energy-momentum conservation worked.
20299 pesum=0d0
20300 pzsum=0d0
20301 DO 500 i=mint(84)+1,n
20302 IF(k(i,1).GT.10) GOTO 500
20303 pesum=pesum+p(i,4)
20304 pzsum=pzsum+p(i,3)
20305 500 CONTINUE
20306 pdev=abs(pesum-vint(1))+abs(pzsum)
20307 IF(pdev.GT.1d-4*vint(1)) THEN
20308 mint(51)=1
20309 mint(57)=mint(57)+1
20310 RETURN
20311 ENDIF
20312
20313C...Calculate rotation and boost from overall CM frame to
20314C...hadronic CM frame in leptoproduction.
20315 mint(91)=0
20316 IF(mint(82).EQ.1.AND.(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
20317 mint(91)=1
20318 lesd=1
20319 IF(mint(42).EQ.1) lesd=2
20320 lpin=mint(83)+3-lesd
20321
20322C...Sum upp momenta of everything not lepton or photon to define boost.
20323 DO 510 j=1,4
20324 psum(j)=0d0
20325 510 CONTINUE
20326 DO 530 i=1,n
20327 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 530
20328 IF(iabs(k(i,2)).GE.11.AND.iabs(k(i,2)).LE.20) GOTO 530
20329 IF(k(i,2).EQ.22) GOTO 530
20330 DO 520 j=1,4
20331 psum(j)=psum(j)+p(i,j)
20332 520 CONTINUE
20333 530 CONTINUE
20334 vint(223)=-psum(1)/psum(4)
20335 vint(224)=-psum(2)/psum(4)
20336 vint(225)=-psum(3)/psum(4)
20337
20338C...Boost incoming hadron to hadronic CM frame to determine rotations.
20339 k(n+1,1)=1
20340 DO 540 j=1,5
20341 p(n+1,j)=p(lpin,j)
20342 v(n+1,j)=v(lpin,j)
20343 540 CONTINUE
20344 CALL pyrobo(n+1,n+1,0d0,0d0,vint(223),vint(224),vint(225))
20345 vint(222)=-pyangl(p(n+1,1),p(n+1,2))
20346 CALL pyrobo(n+1,n+1,0d0,vint(222),0d0,0d0,0d0)
20347 IF(lesd.EQ.2) THEN
20348 vint(221)=-pyangl(p(n+1,3),p(n+1,1))
20349 ELSE
20350 vint(221)=pyangl(-p(n+1,3),p(n+1,1))
20351 ENDIF
20352 ENDIF
20353
20354 RETURN
20355 END
20356
20357C*********************************************************************
20358
20359C...PYMIGN
20360C...Initializes treatment of new multiple interactions scenario,
20361C...selects kinematics of hardest interaction if low-pT physics
20362C...included in run, and generates all non-hardest interactions.
20363
20364 SUBROUTINE pymign(MMUL)
20365
20366C...Double precision and integer declarations.
20367 IMPLICIT DOUBLE PRECISION(a-h, o-z)
20368 IMPLICIT INTEGER(I-N)
20369 INTEGER PYK,PYCHGE,PYCOMP
20370 EXTERNAL pyalps
20371 DOUBLE PRECISION PYALPS
20372C...Commonblocks.
20373 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
20374 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
20375 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
20376 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
20377 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
20378 common/pypars/mstp(200),parp(200),msti(200),pari(200)
20379 common/pyint1/mint(400),vint(400)
20380 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
20381 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
20382 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
20383 common/pyint7/sigt(0:6,0:6,0:5)
20384 common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
20385 & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
20386 & xmi(2,240),pt2mi(240),imisep(0:240)
20387 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
20388 &/pyint1/,/pyint2/,/pyint3/,/pyint5/,/pyint7/,/pyintm/
20389C...Local arrays and saved variables.
20390 dimension nmul(20),sigm(20),kstr(500,2),vintsv(80),
20391 &wdtp(0:400),wdte(0:400,0:5),xpq(-25:25),ksav(4,5),psav(4,5)
20392 SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm,p83a,p83b,p83c,
20393 &cq2i,cq2r,pik,bdiv,b,plowb,phighb,pallb,s4a,s4b,s4c,powip,
20394 &rpwip,b2rpdv,b2rpmx,bavg,vnt145,vnt146,vnt147
20395
20396C...Initialization of multiple interaction treatment.
20397 IF(mmul.EQ.1) THEN
20398 IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)
20399 isub=96
20400 mint(1)=96
20401 vint(63)=0d0
20402 vint(64)=0d0
20403 vint(143)=1d0
20404 vint(144)=1d0
20405
20406C...Loop over phase space points: xT2 choice in 20 bins.
20407 100 sigsum=0d0
20408 DO 120 ixt2=1,20
20409 nmul(ixt2)=mstp(83)
20410 sigm(ixt2)=0d0
20411 DO 110 itry=1,mstp(83)
20412 rsca=0.05d0*((21-ixt2)-pyr(0))
20413 xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)
20414 xt2=max(0.01d0*vint(149),xt2)
20415 vint(25)=xt2
20416
20417C...Choose tau and y*. Calculate cos(theta-hat).
20418 IF(pyr(0).LE.coef(isub,1)) THEN
20419 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
20420 tau=xt2*(1d0+taut)**2/(4d0*taut)
20421 ELSE
20422 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
20423 ENDIF
20424 vint(21)=tau
20425 CALL pyklim(2)
20426 ryst=pyr(0)
20427 myst=1
20428 IF(ryst.GT.coef(isub,8)) myst=2
20429 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
20430 CALL pykmap(2,myst,pyr(0))
20431 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
20432
20433C...Calculate differential cross-section.
20434 vint(71)=0.5d0*vint(1)*sqrt(xt2)
20435 CALL pysigh(nchn,sigs)
20436 sigm(ixt2)=sigm(ixt2)+sigs
20437 110 CONTINUE
20438 sigsum=sigsum+sigm(ixt2)
20439 120 CONTINUE
20440 sigsum=sigsum/(20d0*mstp(83))
20441
20442C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20443 IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN
20444 IF(mstp(122).GE.1) WRITE(mstu(11),5100)
20445 & parp(82)*(vint(1)/parp(89))**parp(90),sigsum
20446 parp(82)=0.9d0*parp(82)
20447 vint(149)=4d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
20448 & vint(2)
20449 GOTO 100
20450 ENDIF
20451 IF(mstp(122).GE.1) WRITE(mstu(11),5200)
20452 & parp(82)*(vint(1)/parp(89))**parp(90), sigsum
20453
20454C...Start iteration to find k factor.
20455 yke=sigsum/max(1d-10,sigt(0,0,5))
20456 p83a=(1d0-parp(83))**2
20457 p83b=2d0*parp(83)*(1d0-parp(83))
20458 p83c=parp(83)**2
20459 cq2i=1d0/parp(84)**2
20460 cq2r=2d0/(1d0+parp(84)**2)
20461 so=0.5d0
20462 xi=0d0
20463 yi=0d0
20464 xf=0d0
20465 yf=0d0
20466 xk=0.5d0
20467 iit=0
20468 130 IF(iit.EQ.0) THEN
20469 xk=2d0*xk
20470 ELSEIF(iit.EQ.1) THEN
20471 xk=0.5d0*xk
20472 ELSE
20473 xk=xi+(yke-yi)*(xf-xi)/(yf-yi)
20474 ENDIF
20475
20476C...Evaluate overlap integrals. Find where to divide the b range.
20477 IF(mstp(82).EQ.2) THEN
20478 sp=0.5d0*paru(1)*(1d0-exp(-xk))
20479 sop=sp/paru(1)
20480 ELSE
20481 IF(mstp(82).EQ.3) THEN
20482 deltab=0.02d0
20483 ELSEIF(mstp(82).EQ.4) THEN
20484 deltab=min(0.01d0,0.05d0*parp(84))
20485 ELSE
20486 powip=max(0.4d0,parp(83))
20487 rpwip=2d0/powip-1d0
20488 deltab=max(0.02d0,0.02d0*(2d0/powip)**(1d0/powip))
20489 so=0d0
20490 ENDIF
20491 sp=0d0
20492 sop=0d0
20493 bsp=0d0
20494 sohigh=0d0
20495 ibdiv=0
20496 b=-0.5d0*deltab
20497 140 b=b+deltab
20498 IF(mstp(82).EQ.3) THEN
20499 ov=exp(-b**2)/paru(2)
20500 ELSEIF(mstp(82).EQ.4) THEN
20501 ov=(p83a*exp(-min(50d0,b**2))+
20502 & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
20503 & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
20504 ELSE
20505 ov=exp(-b**powip)/paru(2)
20506 so=so+paru(2)*b*deltab*ov
20507 ENDIF
20508 IF(ibdiv.EQ.1) sohigh=sohigh+paru(2)*b*deltab*ov
20509 pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))
20510 sp=sp+paru(2)*b*deltab*pacc
20511 sop=sop+paru(2)*b*deltab*ov*pacc
20512 bsp=bsp+b*paru(2)*b*deltab*pacc
20513 IF(ibdiv.EQ.0.AND.paru(1)*xk*ov.LT.1d0) THEN
20514 ibdiv=1
20515 bdiv=b+0.5d0*deltab
20516 ENDIF
20517 IF(b.LT.1d0.OR.b*pacc.GT.1d-6) GOTO 140
20518 ENDIF
20519 yk=paru(1)*xk*so/sp
20520
20521C...Continue iteration until convergence.
20522 IF(yk.LT.yke) THEN
20523 xi=xk
20524 yi=yk
20525 IF(iit.EQ.1) iit=2
20526 ELSE
20527 xf=xk
20528 yf=yk
20529 IF(iit.EQ.0) iit=1
20530 ENDIF
20531 IF(abs(yk-yke).GE.1d-5*yke) GOTO 130
20532
20533C...Store some results for subsequent use.
20534 bavg=bsp/sp
20535 vint(145)=sigsum
20536 vint(146)=sop/so
20537 vint(147)=sop/sp
20538 vnt145=vint(145)
20539 vnt146=vint(146)
20540 vnt147=vint(147)
20541C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20542 pik=(vnt146/vnt147)*yke
20543
20544C...Find relative weight for low and high impact parameter..
20545 plowb=paru(1)*bdiv**2
20546 IF(mstp(82).EQ.3) THEN
20547 phighb=pik*0.5*exp(-bdiv**2)
20548 ELSEIF(mstp(82).EQ.4) THEN
20549 s4a=p83a*exp(-bdiv**2)
20550 s4b=p83b*exp(-bdiv**2*cq2r)
20551 s4c=p83c*exp(-bdiv**2*cq2i)
20552 phighb=pik*0.5*(s4a+s4b+s4c)
20553 ELSEIF(parp(83).GE.1.999d0) THEN
20554 phighb=pik*sohigh
20555 b2rpdv=bdiv**powip
20556 ELSE
20557 phighb=pik*sohigh
20558 b2rpdv=bdiv**powip
20559 b2rpmx=max(2d0*rpwip,b2rpdv)
20560 ENDIF
20561 pallb=plowb+phighb
20562
20563C...Initialize iteration in xT2 for hardest interaction.
20564 ELSEIF(mmul.EQ.2) THEN
20565 vint(145)=vnt145
20566 vint(146)=vnt146
20567 vint(147)=vnt147
20568 IF(mstp(82).LE.0) THEN
20569 ELSEIF(mstp(82).EQ.1) THEN
20570 xt2=1d0
20571 sigrat=xsec(96,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
20572 IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
20573 & vint(317)/(vint(318)*vint(320))
20574 xt2fac=sigrat*vint(149)/(1d0-vint(149))
20575 ELSEIF(mstp(82).EQ.2) THEN
20576 xt2=1d0
20577 xt2fac=vnt146*xsec(96,1)/max(1d-10,sigt(0,0,5))*
20578 & vint(149)*(1d0+vint(149))
20579 ELSE
20580 xc2=4d0*ckin(3)**2/vint(2)
20581 IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0
20582 ENDIF
20583
20584C...Select impact parameter for hardest interaction.
20585 IF(mstp(82).LE.2) RETURN
20586 142 IF(pyr(0)*pallb.LT.plowb) THEN
20587C...Treatment in low b region.
20588 mint(39)=1
20589 b=bdiv*sqrt(pyr(0))
20590 IF(mstp(82).EQ.3) THEN
20591 ov=exp(-b**2)/paru(2)
20592 ELSEIF(mstp(82).EQ.4) THEN
20593 ov=(p83a*exp(-min(50d0,b**2))+
20594 & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
20595 & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
20596 ELSE
20597 ov=exp(-b**powip)/paru(2)
20598 ENDIF
20599 vint(148)=ov/vnt147
20600 pacc=1d0-exp(-min(50d0,pik*ov))
20601 xt2=1d0
20602 xt2fac=vnt146*vint(148)*xsec(96,1)/max(1d-10,sigt(0,0,5))*
20603 & vint(149)*(1d0+vint(149))
20604 ELSE
20605C...Treatment in high b region.
20606 mint(39)=2
20607 IF(mstp(82).EQ.3) THEN
20608 b=sqrt(bdiv**2-log(pyr(0)))
20609 ov=exp(-b**2)/paru(2)
20610 ELSEIF(mstp(82).EQ.4) THEN
20611 s4rndm=pyr(0)*(s4a+s4b+s4c)
20612 IF(s4rndm.LT.s4a) THEN
20613 b=sqrt(bdiv**2-log(pyr(0)))
20614 ELSEIF(s4rndm.LT.s4a+s4b) THEN
20615 b=sqrt(bdiv**2-log(pyr(0))/cq2r)
20616 ELSE
20617 b=sqrt(bdiv**2-log(pyr(0))/cq2i)
20618 ENDIF
20619 ov=(p83a*exp(-min(50d0,b**2))+
20620 & p83b*cq2r*exp(-min(50d0,b**2*cq2r))+
20621 & p83c*cq2i*exp(-min(50d0,b**2*cq2i)))/paru(2)
20622 ELSEIF(parp(83).GE.1.999d0) THEN
20623 144 b2rpw=b2rpdv-log(pyr(0))
20624 accip=(b2rpw/b2rpdv)**rpwip
20625 IF(accip.LT.pyr(0)) GOTO 144
20626 ov=exp(-b2rpw)/paru(2)
20627 b=b2rpw**(1d0/powip)
20628 ELSE
20629 146 b2rpw=b2rpdv-2d0*log(pyr(0))
20630 accip=(b2rpw/b2rpmx)**rpwip*exp(-0.5d0*(b2rpw-b2rpmx))
20631 IF(accip.LT.pyr(0)) GOTO 146
20632 ov=exp(-b2rpw)/paru(2)
20633 b=b2rpw**(1d0/powip)
20634 ENDIF
20635 vint(148)=ov/vnt147
20636 pacc=(1d0-exp(-min(50d0,pik*ov)))/(pik*ov)
20637 ENDIF
20638 IF(pacc.LT.pyr(0)) GOTO 142
20639 vint(139)=b/bavg
20640
20641 ELSEIF(mmul.EQ.3) THEN
20642C...Low-pT or multiple interactions (first semihard interaction):
20643C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20644C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20645 isub=mint(1)
20646 vint(145)=vnt145
20647 vint(146)=vnt146
20648 vint(147)=vnt147
20649 IF(mstp(82).LE.0) THEN
20650 xt2=0d0
20651 ELSEIF(mstp(82).EQ.1) THEN
20652 xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
20653C...Use with "Sudakov" for low b values when impact parameter dependence.
20654 ELSEIF(mstp(82).EQ.2.OR.mint(39).EQ.1) THEN
20655 IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+
20656 & vint(149)))).GT.pyr(0)) xt2=1d0
20657 IF(xt2.GE.1d0) THEN
20658 xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-
20659 & pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-
20660 & vint(149)
20661 ELSE
20662 xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*
20663 & (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-
20664 & vint(149)
20665 ENDIF
20666 xt2=max(0.01d0*vint(149),xt2)
20667C...Use without "Sudakov" for high b values when impact parameter dep.
20668 ELSE
20669 xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-
20670 & pyr(0)*(1d0-xc2))-vint(149)
20671 xt2=max(0.01d0*vint(149),xt2)
20672 ENDIF
20673 vint(25)=xt2
20674
20675C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20676 IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN
20677 IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-mint(143)
20678 IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-mint(143)
20679 isub=95
20680 mint(1)=isub
20681 vint(21)=1d-12*vint(149)
20682 vint(22)=0d0
20683 vint(23)=0d0
20684 vint(25)=1d-12*vint(149)
20685
20686 ELSE
20687C...Multiple interactions (first semihard interaction).
20688C...Choose tau and y*. Calculate cos(theta-hat).
20689 IF(pyr(0).LE.coef(isub,1)) THEN
20690 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
20691 tau=xt2*(1d0+taut)**2/(4d0*taut)
20692 ELSE
20693 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
20694 ENDIF
20695 vint(21)=tau
20696 CALL pyklim(2)
20697 ryst=pyr(0)
20698 myst=1
20699 IF(ryst.GT.coef(isub,8)) myst=2
20700 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
20701 CALL pykmap(2,myst,pyr(0))
20702 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
20703 ENDIF
20704 vint(71)=0.5d0*vint(1)*sqrt(vint(25))
20705
20706C...Store results of cross-section calculation.
20707 ELSEIF(mmul.EQ.4) THEN
20708 isub=mint(1)
20709 vint(145)=vnt145
20710 vint(146)=vnt146
20711 vint(147)=vnt147
20712 xts=vint(25)
20713 IF(iset(isub).EQ.1) xts=vint(21)
20714 IF(iset(isub).EQ.2)
20715 & xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
20716 IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)
20717 rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/
20718 & (xts+vint(149))))
20719 irbin=int(1d0+20d0*rbin)
20720 IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN
20721 nmul(irbin)=nmul(irbin)+1
20722 sigm(irbin)=sigm(irbin)+vint(153)
20723 ENDIF
20724
20725C...Choose impact parameter if not already done.
20726 ELSEIF(mmul.EQ.5) THEN
20727 isub=mint(1)
20728 vint(145)=vnt145
20729 vint(146)=vnt146
20730 vint(147)=vnt147
20731 150 IF(mint(39).GT.0) THEN
20732 ELSEIF(mstp(82).EQ.3) THEN
20733 expb2=pyr(0)
20734 b2=-log(pyr(0))
20735 vint(148)=expb2/(paru(2)*vnt147)
20736 vint(139)=sqrt(b2)/bavg
20737 ELSEIF(mstp(82).EQ.4) THEN
20738 rtype=pyr(0)
20739 IF(rtype.LT.p83a) THEN
20740 b2=-log(pyr(0))
20741 ELSEIF(rtype.LT.p83a+p83b) THEN
20742 b2=-log(pyr(0))/cq2r
20743 ELSE
20744 b2=-log(pyr(0))/cq2i
20745 ENDIF
20746 vint(148)=(p83a*exp(-min(50d0,b2))+
20747 & p83b*cq2r*exp(-min(50d0,b2*cq2r))+
20748 & p83c*cq2i*exp(-min(50d0,b2*cq2i)))/(paru(2)*vnt147)
20749 vint(139)=sqrt(b2)/bavg
20750 ELSEIF(parp(83).GE.1.999d0) THEN
20751 powip=max(2d0,parp(83))
20752 rpwip=2d0/powip-1d0
20753 prob1=powip/(2d0*exp(-1d0)+powip)
20754 160 IF(pyr(0).LT.prob1) THEN
20755 b2rpw=pyr(0)**(0.5d0*powip)
20756 accip=exp(-b2rpw)
20757 ELSE
20758 b2rpw=1d0-log(pyr(0))
20759 accip=b2rpw**rpwip
20760 ENDIF
20761 IF(accip.LT.pyr(0)) GOTO 160
20762 vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
20763 vint(139)=b2rpw**(1d0/powip)/bavg
20764 ELSE
20765 powip=max(0.4d0,parp(83))
20766 rpwip=2d0/powip-1d0
20767 prob1=rpwip/(rpwip+2d0**rpwip*exp(-rpwip))
20768 170 IF(pyr(0).LT.prob1) THEN
20769 b2rpw=2d0*rpwip*pyr(0)
20770 accip=(b2rpw/rpwip)**rpwip*exp(rpwip-b2rpw)
20771 ELSE
20772 b2rpw=2d0*(rpwip-log(pyr(0)))
20773 accip=(0.5d0*b2rpw/rpwip)**rpwip*exp(rpwip-0.5d0*b2rpw)
20774 ENDIF
20775 IF(accip.lt .pyr(0)) GOTO 170
20776 vint(148)=exp(-b2rpw)/(paru(2)*vnt147)
20777 vint(139)=b2rpw**(1d0/powip)/bavg
20778 ENDIF
20779
20780C...Multiple interactions (variable impact parameter) : reject with
20781C...probability exp(-overlap*cross-section above pT/normalization).
20782C...Does not apply to low-b region, where "Sudakov" already included.
20783 vint(150)=1d0
20784 IF(mint(39).NE.1) THEN
20785 rncor=(irbin-20d0*rbin)*nmul(irbin)
20786 sigcor=(irbin-20d0*rbin)*sigm(irbin)
20787 DO 180 ibin=irbin+1,20
20788 rncor=rncor+nmul(ibin)
20789 sigcor=sigcor+sigm(ibin)
20790 180 CONTINUE
20791 sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))
20792 IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)
20793 vint(150)=exp(-min(50d0,vnt146*vint(148)*
20794 & sigabv/max(1d-10,sigt(0,0,5))))
20795 ENDIF
20796 IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isub.NE.11.AND.
20797 & isub.NE.12.AND.isub.NE.13.AND.isub.NE.28.AND.isub.NE.53
20798 & .AND.isub.NE.68.AND.isub.NE.95.AND.isub.NE.96)) THEN
20799 IF(vint(150).LT.pyr(0)) GOTO 150
20800 vint(150)=1d0
20801 ENDIF
20802
20803C...Generate additional multiple semihard interactions.
20804 ELSEIF(mmul.EQ.6) THEN
20805
20806C...Save data for hardest initeraction, to be restored.
20807 isubsv=mint(1)
20808 vint(145)=vnt145
20809 vint(146)=vnt146
20810 vint(147)=vnt147
20811 m13sv=mint(13)
20812 m14sv=mint(14)
20813 m15sv=mint(15)
20814 m16sv=mint(16)
20815 m21sv=mint(21)
20816 m22sv=mint(22)
20817 DO 190 j=11,80
20818 vintsv(j)=vint(j)
20819 190 CONTINUE
20820 v141sv=vint(141)
20821 v142sv=vint(142)
20822
20823C...Store data on hardest interaction.
20824 xmi(1,1)=vint(141)
20825 xmi(2,1)=vint(142)
20826 pt2mi(1)=vint(54)
20827 imisep(0)=mint(84)
20828 imisep(1)=n
20829
20830C...Change process to generate; sum of x values so far.
20831 isub=96
20832 mint(1)=96
20833 vint(143)=1d0-vint(141)
20834 vint(144)=1d0-vint(142)
20835 vint(151)=0d0
20836 vint(152)=0d0
20837
20838C...Initialize factors for PDF reshaping.
20839 DO 230 js=1,2
20840 kfbeam=mint(10+js)
20841 kfabm=iabs(kfbeam)
20842 kfsbm=isign(1,kfbeam)
20843
20844C...Zero flavour content of incoming beam particle.
20845 kfival(js,1)=0
20846 kfival(js,2)=0
20847 kfival(js,3)=0
20848C...Flavour content of baryon.
20849 IF(kfabm.GT.1000) THEN
20850 kfival(js,1)=kfsbm*mod(kfabm/1000,10)
20851 kfival(js,2)=kfsbm*mod(kfabm/100,10)
20852 kfival(js,3)=kfsbm*mod(kfabm/10,10)
20853C...Flavour content of pi+-, K+-.
20854 ELSEIF(kfabm.EQ.211) THEN
20855 kfival(js,1)=kfsbm*2
20856 kfival(js,2)=-kfsbm
20857 ELSEIF(kfabm.EQ.321) THEN
20858 kfival(js,1)=-kfsbm*3
20859 kfival(js,2)=kfsbm*2
20860C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20861 ENDIF
20862
20863C...Zero initial valence and companion content.
20864 DO 200 ifl=-6,6
20865 nvc(js,ifl)=0
20866 200 CONTINUE
20867
20868C...Initiate listing of all incoming partons from two sides.
20869 nmi(js)=0
20870 DO 210 i=mint(84)+1,n
20871 IF(k(i,3).EQ.mint(83)+2+js) THEN
20872 imi(js,1,1)=i
20873 imi(js,1,2)=0
20874 ENDIF
20875 210 CONTINUE
20876
20877C...Decide whether quarks in hard scattering were valence or sea.
20878 ifl=k(imi(js,1,1),2)
20879 IF (iabs(ifl).GT.6) GOTO 230
20880
20881C...Get PDFs at X and Q2 of the parton shower initiator for the
20882C...hard scattering.
20883 x=vint(140+js)
20884 IF(mstp(61).GE.1) THEN
20885 q2=parp(62)**2
20886 ELSE
20887 q2=vint(54)
20888 ENDIF
20889C...Note: XPSVC = x*pdf.
20890 mint(30)=js
20891 CALL pypdfu(kfbeam,x,q2,xpq)
20892 sea=xpsvc(ifl,-1)
20893 val=xpsvc(ifl,0)
20894
20895C...Decide (Extra factor x cancels in the division).
20896 rvcs=pyr(0)*(sea+val)
20897 ivnow=1
20898 220 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
20899C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20900 ivnow=0
20901 IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
20902 IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
20903 IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
20904 IF(kfival(js,1).EQ.0) THEN
20905 IF(kfbeam.EQ.111.AND.iabs(ifl).LE.2) ivnow=1
20906 IF(kfbeam.EQ.22.AND.iabs(ifl).LE.5) ivnow=1
20907 IF((kfbeam.EQ.130.OR.kfbeam.EQ.310).AND.
20908 & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
20909 ENDIF
20910 IF(ivnow.EQ.0) GOTO 220
20911C...Mark valence.
20912 imi(js,1,2)=0
20913C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20914 IF(kfival(js,1).EQ.0) THEN
20915 IF(kfbeam.EQ.111.OR.kfbeam.EQ.22) THEN
20916 kfival(js,1)=ifl
20917 kfival(js,2)=-ifl
20918 ELSEIF(kfbeam.EQ.130.OR.kfbeam.EQ.310) THEN
20919 kfival(js,1)=ifl
20920 IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
20921 IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
20922 ENDIF
20923 ENDIF
20924
20925C...If sea, add opposite sign companion parton. Store X and I.
20926 ELSE
20927 nvc(js,-ifl)=nvc(js,-ifl)+1
20928 xassoc(js,-ifl,nvc(js,-ifl))=x
20929C...Set pointer to companion
20930 imi(js,1,2)=-nvc(js,-ifl)
20931 ENDIF
20932 230 CONTINUE
20933
20934C...Update counter number of multiple interactions.
20935 nmi(1)=1
20936 nmi(2)=1
20937
20938C...Set up starting values for iteration in xT2.
20939 IF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isubsv.NE.11.AND.
20940 & isubsv.NE.12.AND.isubsv.NE.13.AND.isubsv.NE.28.AND.
20941 & isubsv.NE.53.AND.isubsv.NE.68.AND.isubsv.NE.95.AND.
20942 & isubsv.NE.96)) THEN
20943 xt2=(1d0-vint(141))*(1d0-vint(142))
20944 ELSE
20945 xt2=vint(25)
20946 IF(iset(isubsv).EQ.1) xt2=vint(21)
20947 IF(iset(isubsv).EQ.2)
20948 & xt2=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
20949 IF(iset(isubsv).GE.3.AND.iset(isubsv).LE.5) xt2=vint(26)
20950 ENDIF
20951 IF(mstp(82).LE.1) THEN
20952 sigrat=xsec(isub,1)/max(1d-10,vint(315)*vint(316)*sigt(0,0,5))
20953 IF(mint(141).NE.0.OR.mint(142).NE.0) sigrat=sigrat*
20954 & vint(317)/(vint(318)*vint(320))
20955 xt2fac=sigrat*vint(149)/(1d0-vint(149))
20956 ELSE
20957 xt2fac=vnt146*vint(148)*xsec(isub,1)/
20958 & max(1d-10,sigt(0,0,5))*vint(149)*(1d0+vint(149))
20959 ENDIF
20960 vint(63)=0d0
20961 vint(64)=0d0
20962
20963C...Iterate downwards in xT2.
20964 240 IF((mint(35).EQ.2.AND.mstp(81).EQ.10).OR.isubsv.EQ.95) THEN
20965 xt2=0d0
20966 GOTO 440
20967 ELSEIF(mstp(82).LE.1) THEN
20968 xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))
20969 IF(xt2.LT.vint(149)) GOTO 440
20970 ELSE
20971 IF(xt2.LE.0.01001d0*vint(149)) GOTO 440
20972 xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*
20973 & log(pyr(0)))-vint(149)
20974 IF(xt2.LE.0d0) GOTO 440
20975 xt2=max(0.01d0*vint(149),xt2)
20976 ENDIF
20977 vint(25)=xt2
20978
20979C...Choose tau and y*. Calculate cos(theta-hat).
20980 IF(pyr(0).LE.coef(isub,1)) THEN
20981 taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)
20982 tau=xt2*(1d0+taut)**2/(4d0*taut)
20983 ELSE
20984 tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)
20985 ENDIF
20986 vint(21)=tau
20987C...New: require shat > 1.
20988 IF(tau*vint(2).LT.1d0) GOTO 240
20989 CALL pyklim(2)
20990 ryst=pyr(0)
20991 myst=1
20992 IF(ryst.GT.coef(isub,8)) myst=2
20993 IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3
20994 CALL pykmap(2,myst,pyr(0))
20995 vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))
20996
20997C...Check that x not used up. Accept or reject kinematical variables.
20998 x1m=sqrt(tau)*exp(vint(22))
20999 x2m=sqrt(tau)*exp(-vint(22))
21000 IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) GOTO 240
21001 vint(71)=0.5d0*vint(1)*sqrt(xt2)
21002 CALL pysigh(nchn,sigs)
21003 IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs*vint(320)
21004 IF(sigs.LT.xsec(isub,1)*pyr(0)) GOTO 240
21005 IF(mint(141).NE.0.OR.mint(142).NE.0) sigs=sigs/vint(320)
21006
21007C...Reset K, P and V vectors.
21008 DO 260 i=n+1,n+4
21009 DO 250 j=1,5
21010 k(i,j)=0
21011 p(i,j)=0d0
21012 v(i,j)=0d0
21013 250 CONTINUE
21014 260 CONTINUE
21015 pt=0.5d0*vint(1)*sqrt(xt2)
21016
21017C...Choose flavour of reacting partons (and subprocess).
21018 rsigs=sigs*pyr(0)
21019 DO 270 ichn=1,nchn
21020 kfl1=isig(ichn,1)
21021 kfl2=isig(ichn,2)
21022 iconmi=isig(ichn,3)
21023 rsigs=rsigs-sigh(ichn)
21024 IF(rsigs.LE.0d0) GOTO 280
21025 270 CONTINUE
21026
21027C...Reassign to appropriate process codes.
21028 280 isubmi=iconmi/10
21029 iconmi=mod(iconmi,10)
21030
21031C...Choose new quark flavour for annihilation graphs
21032 IF(isubmi.EQ.12.OR.isubmi.EQ.53) THEN
21033 sh=tau*vint(2)
21034 CALL pywidt(21,sh,wdtp,wdte)
21035 290 rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)
21036 DO 300 i=1,mdcy(21,3)
21037 kflf=kfdp(i+mdcy(21,2)-1,1)
21038 rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))
21039 IF(rkfl.LE.0d0) GOTO 310
21040 300 CONTINUE
21041 310 IF(isubmi.EQ.53.AND.iconmi.LE.2) THEN
21042 IF(kflf.GE.4) GOTO 290
21043 ELSEIF(isubmi.EQ.53.AND.iconmi.LE.4) THEN
21044 kflf=4
21045 iconmi=iconmi-2
21046 ELSEIF(isubmi.EQ.53) THEN
21047 kflf=5
21048 iconmi=iconmi-4
21049 ENDIF
21050 ENDIF
21051
21052C...Final state flavours and colour flow: default values
21053 js=1
21054 kfl3=kfl1
21055 kfl4=kfl2
21056 kcc=20
21057 kcs=isign(1,kfl1)
21058
21059 IF(isubmi.EQ.11) THEN
21060C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21061 kcc=iconmi
21062 IF(kfl1*kfl2.LT.0) kcc=kcc+2
21063
21064 ELSEIF(isubmi.EQ.12) THEN
21065C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21066 kfl3=isign(kflf,kfl1)
21067 kfl4=-kfl3
21068 kcc=4
21069
21070 ELSEIF(isubmi.EQ.13) THEN
21071C...f + fbar -> g + g; th arbitrary
21072 kfl3=21
21073 kfl4=21
21074 kcc=iconmi+4
21075
21076 ELSEIF(isubmi.EQ.28) THEN
21077C...f + g -> f + g; th = (p(f)-p(f))**2
21078 IF(kfl1.EQ.21) js=2
21079 kcc=iconmi+6
21080 IF(kfl1.EQ.21) kcc=kcc+2
21081 IF(kfl1.NE.21) kcs=isign(1,kfl1)
21082 IF(kfl2.NE.21) kcs=isign(1,kfl2)
21083
21084 ELSEIF(isubmi.EQ.53) THEN
21085C...g + g -> f + fbar; th arbitrary
21086 kcs=(-1)**int(1.5d0+pyr(0))
21087 kfl3=isign(kflf,kcs)
21088 kfl4=-kfl3
21089 kcc=iconmi+10
21090
21091 ELSEIF(isubmi.EQ.68) THEN
21092C...g + g -> g + g; th arbitrary
21093 kcc=iconmi+12
21094 kcs=(-1)**int(1.5d0+pyr(0))
21095 ENDIF
21096
21097C...Store flavours of scattering.
21098 mint(13)=kfl1
21099 mint(14)=kfl2
21100 mint(15)=kfl1
21101 mint(16)=kfl2
21102 mint(21)=kfl3
21103 mint(22)=kfl4
21104
21105C...Set flavours and mothers of scattering partons.
21106 k(n+1,1)=14
21107 k(n+2,1)=14
21108 k(n+3,1)=3
21109 k(n+4,1)=3
21110 k(n+1,2)=kfl1
21111 k(n+2,2)=kfl2
21112 k(n+3,2)=kfl3
21113 k(n+4,2)=kfl4
21114 k(n+1,3)=mint(83)+1
21115 k(n+2,3)=mint(83)+2
21116 k(n+3,3)=n+1
21117 k(n+4,3)=n+2
21118
21119C...Store colour connection indices.
21120 DO 320 j=1,2
21121 jc=j
21122 IF(kcs.EQ.-1) jc=3-j
21123 IF(icol(kcc,1,jc).NE.0) k(n+1,j+3)=n+icol(kcc,1,jc)
21124 IF(icol(kcc,2,jc).NE.0) k(n+2,j+3)=n+icol(kcc,2,jc)
21125 IF(icol(kcc,3,jc).NE.0) k(n+3,j+3)=mstu(5)*(n+icol(kcc,3,jc))
21126 IF(icol(kcc,4,jc).NE.0) k(n+4,j+3)=mstu(5)*(n+icol(kcc,4,jc))
21127 320 CONTINUE
21128
21129C...Store incoming and outgoing partons in their CM-frame.
21130 shr=sqrt(tau)*vint(1)
21131 p(n+1,3)=0.5d0*shr
21132 p(n+1,4)=0.5d0*shr
21133 p(n+2,3)=-0.5d0*shr
21134 p(n+2,4)=0.5d0*shr
21135 p(n+3,5)=pymass(k(n+3,2))
21136 p(n+4,5)=pymass(k(n+4,2))
21137 IF(p(n+3,5)+p(n+4,5).GE.shr) GOTO 240
21138 p(n+3,4)=0.5d0*(shr+(p(n+3,5)**2-p(n+4,5)**2)/shr)
21139 p(n+3,3)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,5)**2))
21140 p(n+4,4)=shr-p(n+3,4)
21141 p(n+4,3)=-p(n+3,3)
21142
21143C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21144 phi=paru(2)*pyr(0)
21145 CALL pyrobo(n+3,n+4,acos(vint(23)),phi,0d0,0d0,0d0)
21146
21147C...Set up default values before showers.
21148 mint(31)=mint(31)+1
21149 ipu1=n+1
21150 ipu2=n+2
21151 ipu3=n+3
21152 ipu4=n+4
21153 vint(141)=vint(41)
21154 vint(142)=vint(42)
21155 n=n+4
21156
21157C...Showering of initial state partons (optional).
21158C...Note: no showering of final state partons here; it comes later.
21159 IF(mstp(84).GE.1.AND.mstp(61).GE.1) THEN
21160 mint(51)=0
21161 alamsv=parj(81)
21162 parj(81)=parp(72)
21163 nsav=n
21164 DO 340 i=1,4
21165 DO 330 j=1,5
21166 ksav(i,j)=k(n-4+i,j)
21167 psav(i,j)=p(n-4+i,j)
21168 330 CONTINUE
21169 340 CONTINUE
21170 CALL pysspa(ipu1,ipu2)
21171 parj(81)=alamsv
21172C...If shower failed then restore to situation before shower.
21173 IF(mint(51).GE.1) THEN
21174 n=nsav
21175 DO 360 i=1,4
21176 DO 350 j=1,5
21177 k(n-4+i,j)=ksav(i,j)
21178 p(n-4+i,j)=psav(i,j)
21179 350 CONTINUE
21180 360 CONTINUE
21181 ipu1=n-3
21182 ipu2=n-2
21183 vint(141)=vint(41)
21184 vint(142)=vint(42)
21185 ENDIF
21186 ENDIF
21187
21188C...Keep track of loose colour ends and information on scattering.
21189 370 imi(1,mint(31),1)=ipu1
21190 imi(2,mint(31),1)=ipu2
21191 imi(1,mint(31),2)=0
21192 imi(2,mint(31),2)=0
21193 xmi(1,mint(31))=vint(141)
21194 xmi(2,mint(31))=vint(142)
21195 pt2mi(mint(31))=vint(54)
21196 imisep(mint(31))=n
21197
21198C...Decide whether quarks in last scattering were valence, companion or
21199C...sea.
21200 DO 430 js=1,2
21201 kfbeam=mint(10+js)
21202 kfsbm=isign(1,mint(10+js))
21203 ifl=k(imi(js,mint(31),1),2)
21204 imi(js,mint(31),2)=0
21205 IF (iabs(ifl).GT.6) GOTO 430
21206
21207C...Get PDFs at X and Q2 of the parton shower initiator for the
21208C...last scattering. At this point VINT(143:144) do not yet
21209C...include the scattered x values VINT(141:142).
21210 x=vint(140+js)/vint(142+js)
21211 IF(mstp(84).GE.1.AND.mstp(61).GE.1) THEN
21212 q2=parp(62)**2
21213 ELSE
21214 q2=vint(54)
21215 ENDIF
21216C...Note: XPSVC = x*pdf.
21217 mint(30)=js
21218 CALL pypdfu(kfbeam,x,q2,xpq)
21219 sea=xpsvc(ifl,-1)
21220 val=xpsvc(ifl,0)
21221 cmp=0d0
21222 DO 380 ivc=1,nvc(js,ifl)
21223 cmp=cmp+xpsvc(ifl,ivc)
21224 380 CONTINUE
21225
21226C...Decide (Extra factor x cancels in the dvision).
21227 rvcs=pyr(0)*(sea+val+cmp)
21228 ivnow=1
21229 390 IF (rvcs.LE.val.AND.ivnow.GE.1) THEN
21230C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21231 ivnow=0
21232 IF(kfival(js,1).EQ.ifl) ivnow=ivnow+1
21233 IF(kfival(js,2).EQ.ifl) ivnow=ivnow+1
21234 IF(kfival(js,3).EQ.ifl) ivnow=ivnow+1
21235 IF(kfival(js,1).EQ.0) THEN
21236 IF(kfbeam.EQ.111.AND.iabs(ifl).LE.2) ivnow=1
21237 IF(kfbeam.EQ.22.AND.iabs(ifl).LE.5) ivnow=1
21238 IF((kfbeam.EQ.130.OR.kfbeam.EQ.310).AND.
21239 & (iabs(ifl).EQ.1.OR.iabs(ifl).EQ.3)) ivnow=1
21240 ELSE
21241 DO 400 i1=1,nmi(js)
21242 IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
21243 & ivnow=ivnow-1
21244 400 CONTINUE
21245 ENDIF
21246 IF(ivnow.EQ.0) GOTO 390
21247C...Mark valence.
21248 imi(js,mint(31),2)=0
21249C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21250 IF(kfival(js,1).EQ.0) THEN
21251 IF(kfbeam.EQ.111.OR.kfbeam.EQ.22) THEN
21252 kfival(js,1)=ifl
21253 kfival(js,2)=-ifl
21254 ELSEIF(kfbeam.EQ.130.OR.kfbeam.EQ.310) THEN
21255 kfival(js,1)=ifl
21256 IF(iabs(ifl).EQ.1) kfival(js,2)=isign(3,-ifl)
21257 IF(iabs(ifl).NE.1) kfival(js,2)=isign(1,-ifl)
21258 ENDIF
21259 ENDIF
21260
21261 ELSEIF (rvcs.LE.val+sea.OR.nvc(js,ifl).EQ.0) THEN
21262C...If sea, add opposite sign companion parton. Store X and I.
21263 nvc(js,-ifl)=nvc(js,-ifl)+1
21264 xassoc(js,-ifl,nvc(js,-ifl))=x
21265C...Set pointer to companion
21266 imi(js,mint(31),2)=-nvc(js,-ifl)
21267 ELSE
21268C...If companion, decide which one.
21269 cmpsum=val+sea
21270 isel=0
21271 410 isel=isel+1
21272 cmpsum=cmpsum+xpsvc(ifl,isel)
21273 IF (rvcs.GT.cmpsum.AND.isel.LT.nvc(js,ifl)) GOTO 410
21274C...Find original sea (anti-)quark:
21275 iassoc=0
21276 DO 420 i1=1,nmi(js)
21277 IF (k(imi(js,i1,1),2).NE.-ifl) GOTO 420
21278 IF (-imi(js,i1,2).EQ.isel) THEN
21279 imi(js,mint(31),2)=imi(js,i1,1)
21280 imi(js,i1,2)=imi(js,mint(31),1)
21281 ENDIF
21282 420 CONTINUE
21283C...Change X to what associated companion had, so that the correct
21284C...amount of momentum can be subtracted from the companion sum below.
21285 x=xassoc(js,ifl,isel)
21286C...Mark companion read.
21287 xassoc(js,ifl,isel)=0d0
21288 ENDIF
21289 430 CONTINUE
21290
21291C...Global statistics.
21292 mint(351)=mint(351)+1
21293 vint(351)=vint(351)+pt
21294 IF (mint(351).EQ.1) vint(356)=pt
21295
21296C...Update remaining energy and other counters.
21297 IF(n.GT.mstu(4)-mstu(32)-10) THEN
21298 CALL pyerrm(11,'(PYMIGN:) no more memory left in PYJETS')
21299 mint(51)=1
21300 RETURN
21301 ENDIF
21302 nmi(1)=nmi(1)+1
21303 nmi(2)=nmi(2)+1
21304 vint(151)=vint(151)+vint(41)
21305 vint(152)=vint(152)+vint(42)
21306 vint(143)=vint(143)-vint(141)
21307 vint(144)=vint(144)-vint(142)
21308
21309C...Iterate, with more interactions allowed.
21310 IF(mint(31).LT.240) GOTO 240
21311 440 CONTINUE
21312
21313C...Restore saved quantities for hardest interaction.
21314 mint(1)=isubsv
21315 mint(13)=m13sv
21316 mint(14)=m14sv
21317 mint(15)=m15sv
21318 mint(16)=m16sv
21319 mint(21)=m21sv
21320 mint(22)=m22sv
21321 DO 450 j=11,80
21322 vint(j)=vintsv(j)
21323 450 CONTINUE
21324 vint(141)=v141sv
21325 vint(142)=v142sv
21326
21327 ENDIF
21328
21329C...Format statements for printout.
21330 5000 FORMAT(/1x,'****** PYMIGN: initialization of multiple inter',
21331 &'actions for MSTP(82) =',i2,' ******')
21332 5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
21333 &d9.2,' mb: rejected')
21334 5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,
21335 &d9.2,' mb: accepted')
21336
21337 RETURN
21338 END
21339
21340C*********************************************************************
21341
21342C...PYMIHK
21343C...Finds left-behind remnant flavour content and hooks up
21344C...the colour flow between the hard scattering and remnants
21345
21346 SUBROUTINE pymihk
21347
21348C...Double precision and integer declarations.
21349 IMPLICIT DOUBLE PRECISION(a-h, o-z)
21350 IMPLICIT INTEGER(I-N)
21351 INTEGER PYK,PYCHGE,PYCOMP
21352C...The event record
21353 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
21354C...Parameters
21355 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
21356 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
21357 common/pypars/mstp(200),parp(200),msti(200),pari(200)
21358 common/pyint1/mint(400),vint(400)
21359C...The common block of dangling ends
21360 common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
21361 & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
21362 & xmi(2,240),pt2mi(240),imisep(0:240)
21363 SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyintm/
21364C...Local variables
21365 parameter(nersiz=4000)
21366 COMMON /pycbls/mco(nersiz,2),ncc,jcco(nersiz,2),jccn(nersiz,2)
21367 & ,maccpt
21368 COMMON /pyctag/nct,mct(nersiz,2)
21369 SAVE /pycbls/,/pyctag/
21370 dimension jst(2,3),iv(2,3),idq(3),nvsum(2),nbrtot(2),ng(2)
21371 & ,itjunc(2),mout(2),insr(1000,3),istr(6),ymi(240)
21372 DATA nerrpr/0/
21373 SAVE nerrpr
21374 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)
21375
21376C...Set up error checkers
21377 iboost=0
21378
21379C...Initialize colour arrays: MCO (Original) and MCT (New)
21380 DO 110 i=mint(84)+1,nersiz
21381 DO 100 jc=1,2
21382 mct(i,jc)=0
21383 mco(i,jc)=0
21384 100 CONTINUE
21385C...Also zero colour tracing information, if existed.
21386 IF (i.LE.n) THEN
21387 k(i,4)=mod(k(i,4),mstu(5)**2)
21388 k(i,5)=mod(k(i,5),mstu(5)**2)
21389 ENDIF
21390 110 CONTINUE
21391
21392C...Initialize colour tag collapse arrays:
21393C...JCCO (Original) and JCCN (New).
21394 DO 130 mg=mint(84)+1,nersiz
21395 DO 120 jc=1,2
21396 jcco(mg,jc)=0
21397 jccn(mg,jc)=0
21398 120 CONTINUE
21399 130 CONTINUE
21400
21401C...Zero gluon insertion array
21402 DO 150 im=1,1000
21403 DO 140 j=1,3
21404 insr(im,j)=0
21405 140 CONTINUE
21406 150 CONTINUE
21407
21408C...Compute hard scattering system rapidities
21409 IF (mstp(89).EQ.1) THEN
21410 DO 160 im=1,240
21411 IF (im.LE.mint(31)) THEN
21412 ymi(im)=log(xmi(1,im)/xmi(2,im))
21413 ELSE
21414C...Set (unsigned) rapidity = 100 for beam remnant systems.
21415 ymi(im)=100d0
21416 ENDIF
21417 160 CONTINUE
21418 ENDIF
21419
21420C...Treat each side separately
21421 DO 290 js=1,2
21422
21423C...Initialize side.
21424 ng(js)=0
21425 jv=0
21426 kfs=isign(1,mint(10+js))
21427
21428C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21429 IF(kfival(js,1).EQ.0) THEN
21430 IF(mint(10+js).EQ.111) THEN
21431 kfival(js,1)=int(1.5d0+pyr(0))
21432 kfival(js,2)=-kfival(js,1)
21433 ELSEIF(mint(10+js).EQ.22) THEN
21434 pyrkf=pyr(0)
21435 kfival(js,1)=1
21436 IF(pyrkf.GT.0.1d0) kfival(js,1)=2
21437 IF(pyrkf.GT.0.5d0) kfival(js,1)=3
21438 IF(pyrkf.GT.0.6d0) kfival(js,1)=4
21439 kfival(js,2)=-kfival(js,1)
21440 ELSEIF(mint(10+js).EQ.130.OR.mint(10+js).EQ.310) THEN
21441 IF(pyr(0).GT.0.5d0) THEN
21442 kfival(js,1)=1
21443 kfival(js,2)=-3
21444 ELSE
21445 kfival(js,1)=3
21446 kfival(js,2)=-1
21447 ENDIF
21448 ENDIF
21449 ENDIF
21450
21451C...Initialize beam remnant sea and valence content flavour by flavour.
21452 nvsum(js)=0
21453 nbrtot(js)=0
21454 DO 210 jfa=1,6
21455C...Count up original number of JFA valence quarks and antiquarks.
21456 nvalq=0
21457 nvalqb=0
21458 nsea=0
21459 DO 170 j=1,3
21460 IF(kfival(js,j).EQ.jfa) nvalq=nvalq+1
21461 IF(kfival(js,j).EQ.-jfa) nvalqb=nvalqb+1
21462 170 CONTINUE
21463 nvsum(js)=nvsum(js)+nvalq+nvalqb
21464C...Subtract kicked out valence and determine sea from flavour cons.
21465 DO 180 im=1,nmi(js)
21466 ifl = k(imi(js,im,1),2)
21467 ifa = iabs(ifl)
21468 ifs = isign(1,ifl)
21469 IF (ifl.EQ.jfa.AND.imi(js,im,2).EQ.0) THEN
21470C...Subtract K.O. valence quark from remainder.
21471 nvalq=nvalq-1
21472 jv=nvsum(js)-nvalq-nvalqb
21473 iv(js,jv)=imi(js,im,1)
21474 ELSEIF (ifl.EQ.-jfa.AND.imi(js,im,2).EQ.0) THEN
21475C...Subtract K.O. valence antiquark from remainder.
21476 nvalqb=nvalqb-1
21477 jv=nvsum(js)-nvalq-nvalqb
21478 iv(js,jv)=imi(js,im,1)
21479 ELSEIF (ifa.EQ.jfa) THEN
21480C...Outside sea without companion: add opposite sea flavour inside.
21481 IF (imi(js,im,2).LT.0) nsea=nsea-ifs
21482 ENDIF
21483 180 CONTINUE
21484C...Check if space left in PYJETS for additional BR flavours
21485 nflsum=iabs(nsea)+nvalq+nvalqb
21486 nbrtot(js)=nbrtot(js)+nflsum
21487 IF (n+nflsum+1.GT.mstu(4)) THEN
21488 CALL pyerrm(11,'(PYMIHK:) no more memory left in PYJETS')
21489 mint(51)=1
21490 RETURN
21491 ENDIF
21492C...Add required val+sea content to beam remnant.
21493 IF (nflsum.GT.0) THEN
21494 DO 200 ia=1,nflsum
21495C...Insert beam remnant quark as p.t. symbolic parton in ER.
21496 n=n+1
21497 DO 190 ix=1,5
21498 k(n,ix)=0
21499 p(n,ix)=0d0
21500 v(n,ix)=0d0
21501 190 CONTINUE
21502 k(n,1)=3
21503 k(n,2)=isign(jfa,nsea)
21504 IF (ia.LE.nvalq) k(n,2)=jfa
21505 IF (ia.GT.nvalq.AND.ia.LE.nvalq+nvalqb) k(n,2)=-jfa
21506 k(n,3)=mint(83)+js
21507C...Also update NMI, IMI, and IV arrays.
21508 nmi(js)=nmi(js)+1
21509 imi(js,nmi(js),1)=n
21510 imi(js,nmi(js),2)=-1
21511 IF (ia.LE.nvalq+nvalqb) THEN
21512 imi(js,nmi(js),2)=0
21513 jv=jv+1
21514 iv(js,jv)=imi(js,nmi(js),1)
21515 ENDIF
21516 200 CONTINUE
21517 ENDIF
21518 210 CONTINUE
21519
21520 im=0
21521 220 im=im+1
21522 IF (im.LE.nmi(js)) THEN
21523 IF (k(imi(js,im,1),2).EQ.21) THEN
21524 ng(js)=ng(js)+1
21525C...Add fictitious parent gluons for companion pairs.
21526 ELSEIF (imi(js,im,2).NE.0.AND.k(imi(js,im,1),2).GT.0) THEN
21527C...Randomly assign companions to sea quarks which have none.
21528 IF (imi(js,im,2).LT.0) THEN
21529 imc=pyr(0)*nmi(js)
21530 230 imc=mod(imc,nmi(js))+1
21531 IF (k(imi(js,imc,1),2).NE.-k(imi(js,im,1),2)) GOTO 230
21532 IF (imi(js,imc,2).GE.0) GOTO 230
21533 imi(js, im,2) = imi(js,imc,1)
21534 imi(js,imc,2) = imi(js, im,1)
21535 ENDIF
21536C...Add fictitious parent gluon
21537 n=n+1
21538 DO 240 ix=1,5
21539 k(n,ix)=0
21540 p(n,ix)=0d0
21541 v(n,ix)=0d0
21542 240 CONTINUE
21543 k(n,1)=14
21544 k(n,2)=21
21545 k(n,3)=mint(83)+js
21546C...Set gluon (anti-)colour daughter pointers
21547 k(n,4)=imi(js, im,1)
21548 k(n,5)=imi(js, im,2)
21549C...Set quark (anti-)colour parent pointers
21550 k(imi(js, im,2),5)=k(imi(js, im,2),5)+mstu(5)*n
21551 k(imi(js, im,1),4)=k(imi(js, im,1),4)+mstu(5)*n
21552C...Add gluon to IMI
21553 nmi(js)=nmi(js)+1
21554 imi(js,nmi(js),1)=n
21555 imi(js,nmi(js),2)=0
21556 ENDIF
21557 GOTO 220
21558 ENDIF
21559
21560C...If incoming (anti-)baryon, insert inside (anti-)junction.
21561C...Set up initial v-v-j-v configuration. Otherwise set up
21562C...mesonic v-vbar configuration
21563 IF (iabs(mint(10+js)).GT.1000) THEN
21564C...Determine junction type (1: B=1 2: B=-1)
21565 itjunc(js) = (3-kfs)/2
21566C...Insert junction.
21567 n=n+1
21568 DO 250 ix=1,5
21569 k(n,ix)=0
21570 p(n,ix)=0d0
21571 v(n,ix)=0d0
21572 250 CONTINUE
21573C...Set special junction codes:
21574 k(n,1)=42
21575 k(n,2)=88
21576C...Set parent to side.
21577 k(n,3)=mint(83)+js
21578 k(n,4)=itjunc(js)*mstu(5)
21579 k(n,5)=0
21580C...Connect valence quarks to junction.
21581 mout(js)=0
21582 manti=itjunc(js)-1
21583C...Set (anti)colour mother = junction.
21584 DO 260 jv=1,3
21585 k(iv(js,jv),4+manti)=mod(k(iv(js,jv),4+manti),mstu(5))
21586 & +mstu(5)*n
21587C...Keep track of partons adjacent to junction:
21588 jst(js,jv)=iv(js,jv)
21589 260 CONTINUE
21590 ELSE
21591C...Mesons: set up initial q-qbar topology
21592 itjunc(js)=0
21593 IF (k(iv(js,1),2).GT.0) THEN
21594 iq=iv(js,1)
21595 iqbar=iv(js,2)
21596 ELSE
21597 iq=iv(js,2)
21598 iqbar=iv(js,1)
21599 ENDIF
21600 iv(js,3)=0
21601 jst(js,1)=iq
21602 jst(js,2)=iqbar
21603 jst(js,3)=0
21604 k(iq,4)=mod(k(iq,4),mstu(5))+mstu(5)*iqbar
21605 k(iqbar,5)=mod(k(iqbar,5),mstu(5))+mstu(5)*iq
21606C...Special for mesons. Insert gluon if BR empty.
21607 IF (nbrtot(js).EQ.0) THEN
21608 n=n+1
21609 DO 270 ix=1,5
21610 k(n,ix)=0
21611 p(n,ix)=0d0
21612 v(n,ix)=0d0
21613 270 CONTINUE
21614 k(n,1)=3
21615 k(n,2)=21
21616 k(n,3)=mint(83)+js
21617 k(n,4)=0
21618 k(n,5)=0
21619 nbrtot(js)=1
21620 ng(js)=ng(js)+1
21621C...Add gluon to IMI
21622 nmi(js)=nmi(js)+1
21623 imi(js,nmi(js),1)=n
21624 imi(js,nmi(js),2)=0
21625 ENDIF
21626 mout(js)=0
21627 ENDIF
21628
21629C...Count up number of valence quarks outside BR.
21630 DO 280 jv=1,3
21631 IF (jst(js,jv).LE.mint(53).AND.jst(js,jv).GT.0)
21632 & mout(js)=mout(js)+1
21633 280 CONTINUE
21634
21635 290 CONTINUE
21636
21637C...Now both sides have been prepared in an initial vvjv (baryonic) or
21638C...v(g)vbar (mesonic) configuration.
21639
21640C...Create colour line tags starting from initiators.
21641 nct=0
21642 DO 320 im=1,mint(31)
21643C...Consider each side in turn.
21644 DO 310 js=1,2
21645 i1=imi(js,im,1)
21646 i2=imi(3-js,im,1)
21647 DO 300 jcs=4,5
21648 IF (k(i1,2).NE.21.AND.(9-2*jcs).NE.isign(1,k(i1,2)))
21649 & GOTO 300
21650 IF (k(i1,jcs)/mstu(5)**2.NE.0) GOTO 300
21651
21652 kcs=jcs
21653 CALL pycttr(i1,kcs,i2)
21654 IF(mint(51).NE.0) RETURN
21655
21656 300 CONTINUE
21657 310 CONTINUE
21658 320 CONTINUE
21659
21660 DO 340 js=1,2
21661C...Create colour tags for beam remnant partons.
21662 DO 330 im=mint(31)+1,nmi(js)
21663 ip=imi(js,im,1)
21664 IF (k(ip,2).NE.21) THEN
21665 jc=(3-isign(1,k(ip,2)))/2
21666 IF (mct(ip,jc).EQ.0) THEN
21667 nct=nct+1
21668 mct(ip,jc)=nct
21669 ENDIF
21670 ELSE
21671C...Gluons
21672 icd=k(ip,4)
21673 iad=k(ip,5)
21674 IF (icd.NE.0) THEN
21675C...Fictituous gluons just inherit from their quark daughters.
21676 icc=mct(icd,1)
21677 iac=mct(iad,2)
21678 ELSE
21679C...Real beam remnant gluons get their own colours
21680 icc=nct+1
21681 iac=nct+2
21682 nct=nct+2
21683 ENDIF
21684 mct(ip,1)=icc
21685 mct(ip,2)=iac
21686 ENDIF
21687 330 CONTINUE
21688 340 CONTINUE
21689
21690C...Create colour tags for colour lines which are detached from the
21691C...initial state.
21692
21693 DO 360 mqgst=1,2
21694 DO 350 i=mint(84)+1,n
21695
21696C...Look for coloured string endpoint, or (later) leftover gluon.
21697 IF (k(i,1).NE.3) GOTO 350
21698 kc=pycomp(k(i,2))
21699 IF(kc.EQ.0) GOTO 350
21700 kq=kchg(kc,2)
21701 IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) GOTO 350
21702
21703C...Pick up loose string end with no previous tag.
21704 kcs=4
21705 IF(kq*isign(1,k(i,2)).LT.0) kcs=5
21706 IF(mct(i,kcs-3).NE.0) GOTO 350
21707
21708 CALL pycttr(i,kcs,i)
21709 IF(mint(51).NE.0) RETURN
21710
21711 350 CONTINUE
21712 360 CONTINUE
21713
21714C...Store original colour tags
21715 DO 370 i=mint(84)+1,n
21716 mco(i,1)=mct(i,1)
21717 mco(i,2)=mct(i,2)
21718 370 CONTINUE
21719
21720C...Iteratively add gluons to already existing string pieces, enforcing
21721C...various possible orderings, and rejecting insertions that would give
21722C...rise to singlet gluons.
21723C...<kappa tau> normalization.
21724 rm0=1.5d0
21725 mretry=0
21726 parp80=parp(80)
21727
21728C...Set up simplified kinematics.
21729C...Boost hard interaction systems.
21730 iboost=iboost+1
21731 DO 380 im=1,mint(31)
21732 beta=(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
21733 CALL pyrobo(imisep(im-1)+1,imisep(im),0d0,0d0,0d0,0d0,beta)
21734 380 CONTINUE
21735C...Assign preliminary beam remnant momenta.
21736 DO 390 i=mint(53)+1,n
21737 js=k(i,3)
21738 p(i,1)=0d0
21739 p(i,2)=0d0
21740 IF (k(i,2).NE.88) THEN
21741 p(i,4)=0.5d0*vint(142+js)*vint(1)/max(1,nmi(js)-mint(31))
21742 p(i,3)=p(i,4)
21743 IF (js.EQ.2) p(i,3)=-p(i,3)
21744 ELSE
21745C...Junctions are wildcards for the present.
21746 p(i,4)=0d0
21747 p(i,3)=0d0
21748 ENDIF
21749 390 CONTINUE
21750
21751C...Reset colour processing information.
21752 400 DO 410 i=mint(84)+1,n
21753 k(i,4)=mod(k(i,4),mstu(5)**2)
21754 k(i,5)=mod(k(i,5),mstu(5)**2)
21755 410 CONTINUE
21756
21757 ncc=0
21758 DO 430 js=1,2
21759C...If meson, without gluon in BR, collapse q-qbar colour tags:
21760 IF (itjunc(js).EQ.0) THEN
21761 jc1=mct(jst(js,1),1)
21762 jc2=mct(jst(js,2),2)
21763 ncc=ncc+1
21764 jcco(ncc,1)=max(jc1,jc2)
21765 jcco(ncc,2)=min(jc1,jc2)
21766C...Collapse colour tags in event record
21767 DO 420 i=mint(84)+1,n
21768 IF (mct(i,1).EQ.jcco(ncc,1)) mct(i,1)=jcco(ncc,2)
21769 IF (mct(i,2).EQ.jcco(ncc,1)) mct(i,2)=jcco(ncc,2)
21770 420 CONTINUE
21771 ENDIF
21772 430 CONTINUE
21773
21774 440 js=1
21775 IF (pyr(0).GT.0.5d0.OR.ng(1).EQ.0) js=2
21776 IF (ng(js).GT.0) THEN
21777 nopt=0
21778 rlopt=1d9
21779C...Start at random gluon (optimizes speed for random attachments)
21780 nmgl=0
21781 imgl=pyr(0)*nmi(js)+1
21782 450 imgl=mod(imgl,nmi(js))+1
21783 nmgl=nmgl+1
21784C...Only loop through NMI once (with upper limit to save time)
21785 IF (nmgl.LE.nmi(js).AND.nopt.LE.3) THEN
21786 igl = imi(js,imgl,1)
21787C...If not gluon or if already connected, try next.
21788 IF (k(igl,2).NE.21.OR.k(igl,4)/mstu(5).NE.0
21789 & .OR.k(igl,5)/mstu(5).NE.0) GOTO 450
21790C...Now loop through all possible insertions of this gluon.
21791 nmp1=0
21792 imp1=pyr(0)*nmi(js)+1
21793 460 imp1=mod(imp1,nmi(js))+1
21794 nmp1=nmp1+1
21795 IF (imp1.EQ.imgl) GOTO 460
21796C...Only loop through NMI once (with upper limit to save time).
21797 IF (nmp1.LE.nmi(js).AND.nopt.LE.3) THEN
21798 ip1 = imi(js,imp1,1)
21799C...Try both colour mother and colour anti-mother.
21800C...Randomly select which one to try first.
21801 nanti=0
21802 manti=pyr(0)*2
21803 470 manti=mod(manti+1,2)
21804 nanti=nanti+1
21805 IF (nanti.LE.2) THEN
21806 ip2 =mod(k(ip1,4+manti)/mstu(5),mstu(5))
21807C...Reject if no appropriate mother (or if mother is fictitious
21808C...parent gluon.)
21809 IF (ip2.LE.0) GOTO 470
21810 IF (k(ip2,2).EQ.21.AND.ip2.GT.mint(53)) GOTO 470
21811C...Also reject if this link has already been tried.
21812 IF (k(ip1,4+manti)/mstu(5)**2.EQ.2) GOTO 470
21813 IF (k(ip2,5-manti)/mstu(5)**2.EQ.2) GOTO 470
21814C...Set flag to indicate that this link has now been tried for this
21815C...gluon. IP2 may be junction, which has several mothers.
21816 k(ip1,4+manti)=k(ip1,4+manti)+2*mstu(5)**2
21817 IF (k(ip2,2).NE.88) THEN
21818 k(ip2,5-manti)=k(ip2,5-manti)+2*mstu(5)**2
21819 ENDIF
21820
21821C...JCG1: Original colour tag of gluon on IP1 side
21822C...JCG2: Original colour tag of gluon on IP2 side
21823C...JCP1: Original colour tag of IP1 on gluon side
21824C...JCP2: Original colour tag of IP2 on gluon side.
21825 jcg1=mco(igl,2-manti)
21826 jcg2=mco(igl,1+manti)
21827 jcp1=mco(ip1,1+manti)
21828 jcp2=mco(ip2,2-manti)
21829
21830 CALL pymihg(jcp1,jcg1,jcp2,jcg2)
21831C...Reject gluon attachments that give rise to singlet gluons.
21832 IF (maccpt.EQ.0) GOTO 470
21833
21834C...Update colours
21835 jcg1=mct(igl,2-manti)
21836 jcg2=mct(igl,1+manti)
21837 jcp1=mct(ip1,1+manti)
21838 jcp2=mct(ip2,2-manti)
21839
21840C...Select whether to accept this insertion
21841 IF (mstp(89).EQ.0) THEN
21842C...Random insertions: no measure.
21843 rl=1d0
21844C...For random ordering, we want to suppress beam remnant breakups
21845C...already at this point.
21846 IF (ip1.GT.mint(53).AND.ip2.GT.mint(53)
21847 & .AND.mout(js).NE.0.AND.pyr(0).GT.parp80) THEN
21848 nmp1=0
21849 nmgl=0
21850 GOTO 470
21851 ENDIF
21852 ELSEIF (mstp(89).EQ.1) THEN
21853C...Rapidity ordering:
21854C...YGL = Rapidity of gluon.
21855 ygl=ymi(imgl)
21856C...If fictitious gluon
21857 IF (ygl.EQ.100d0) THEN
21858 ygl=(3-2*js)*100d0
21859 ida1=mod(k(igl,4),mstu(5))
21860 ida2=mod(k(igl,5),mstu(5))
21861 DO 480 imt=1,nmi(js)
21862C...Select (arbitrarily) the most central daughter.
21863 IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2)
21864 & THEN
21865 IF (abs(ygl).GT.abs(ymi(imt))) ygl=ymi(imt)
21866 ENDIF
21867 480 CONTINUE
21868 ENDIF
21869C...YP1 = Rapidity IP1
21870 yp1=ymi(imp1)
21871C...If fictitious gluon
21872 IF (yp1.EQ.100d0) THEN
21873 yp1=(3-2*js)*yp1
21874 ida1=mod(k(ip1,4),mstu(5))
21875 ida2=mod(k(ip1,5),mstu(5))
21876 DO 490 imt=1,nmi(js)
21877C...Select (arbitrarily) the most central daughter.
21878 IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2)
21879 & THEN
21880 IF (abs(yp1).GT.abs(ymi(imt))) yp1=ymi(imt)
21881 ENDIF
21882 490 CONTINUE
21883 ENDIF
21884C...YP2 = Rapidity of mother system
21885 IF (k(ip2,2).NE.88) THEN
21886 DO 500 imt=1,nmi(js)
21887 IF (imi(js,imt,1).EQ.ip2) yp2=ymi(imt)
21888 500 CONTINUE
21889C...If fictitious gluon
21890 IF (yp2.EQ.100d0) THEN
21891 yp2=(3-2*js)*yp2
21892 ida1=mod(k(ip2,4),mstu(5))
21893 ida2=mod(k(ip2,5),mstu(5))
21894 DO 510 imt=1,nmi(js)
21895C...Select (arbitrarily) the most central daughter.
21896 IF (imi(js,imt,1).EQ.ida1.OR.imi(js,imt,1).EQ.ida2
21897 & ) THEN
21898 IF (abs(yp2).GT.abs(ymi(imt))) yp2=ymi(imt)
21899 ENDIF
21900 510 CONTINUE
21901 ENDIF
21902C...Assign (arbitrarily) 100D0 to junction also
21903 ELSE
21904 yp2=(3-2*js)*100d0
21905 ENDIF
21906 rl=abs(ygl-yp1)+abs(ygl-yp2)
21907 ELSEIF (mstp(89).EQ.2) THEN
21908C...Lambda ordering:
21909C...Compute lambda measure for this insertion.
21910 rl=1d0
21911 DO 520 ist=1,6
21912 istr(ist)=0
21913 520 CONTINUE
21914C...If IP2 is junction, not caught below.
21915 IF (jcp2.EQ.0) THEN
21916 itju=mod(k(ip2,4)/mstu(5),mstu(5))
21917C...Anti-junction is colour endpoint et vv., always on JCG2.
21918 istr(5-itju)=ip2
21919 ENDIF
21920 DO 530 i=mint(84)+1,n
21921 IF (k(i,1).LT.10) THEN
21922C...The new string pieces
21923 IF (mct(i,1).EQ.jcg1) istr(1)=i
21924 IF (mct(i,2).EQ.jcg1) istr(2)=i
21925 IF (mct(i,1).EQ.jcg2) istr(3)=i
21926 IF (mct(i,2).EQ.jcg2) istr(4)=i
21927 ENDIF
21928 530 CONTINUE
21929C...Also identify junctions as string endpoints.
21930 DO 540 i=mint(84)+1,n
21931 icmo=mod(k(i,4)/mstu(5),mstu(5))
21932 iamo=mod(k(i,5)/mstu(5),mstu(5))
21933C...Find partons adjacent to junctions.
21934 IF (icmo.GT.0.AND.icmo.LE.n) THEN
21935 IF (k(icmo,1).EQ.42.AND.mct(i,1).EQ.jcg1.AND.istr(2)
21936 & .EQ.0) istr(2) = icmo
21937 IF (k(icmo,1).EQ.42.AND.mct(i,1).EQ.jcg2.AND.istr(4)
21938 & .EQ.0) istr(4) = icmo
21939 ENDIF
21940 IF (iamo.GT.0.AND.iamo.LE.n) THEN
21941 IF (k(iamo,1).EQ.42.AND.mct(i,2).EQ.jcg1.AND.istr(1)
21942 & .EQ.0) istr(1) = iamo
21943 IF (k(iamo,1).EQ.42.AND.mct(i,2).EQ.jcg2.AND.istr(3)
21944 & .EQ.0) istr(3) = iamo
21945 ENDIF
21946 540 CONTINUE
21947C...The old string piece
21948 istr(5)=istr(1+2*manti)
21949 istr(6)=istr(4-2*manti)
21950 IF (istr(1).EQ.0.OR.istr(2).EQ.0.OR.istr(3).EQ.0.OR.
21951 & istr(4).EQ.0.OR.istr(5).EQ.0.OR.istr(6).EQ.0) THEN
21952C...If one or more of the colour tags for this connection is/are still
21953C...dangling, skip this attempt for the time being.
21954 rl=1d6
21955 ELSE
21956 rl=max(1d0,four(istr(1),istr(2)))*max(1d0,four(istr(3)
21957 & ,istr(4)))/max(1d0,four(istr(5),istr(6)))
21958 rl=log(rl)
21959 ENDIF
21960 ENDIF
21961C...Allow some breadth to speed things up.
21962 IF (abs(1d0-rl/rlopt).LT.0.05d0) THEN
21963 nopt=nopt+1
21964 ELSEIF (rl.GT.rlopt) THEN
21965 GOTO 470
21966 ELSE
21967 nopt=1
21968 rlopt=rl
21969 ENDIF
21970C...INSR(NOPT,1)=Gluon colour mother
21971C...INSR(NOPT,2)=Gluon
21972C...INSR(NOPT,3)=Gluon anticolour mother
21973 IF (nopt.GT.1000) GOTO 470
21974 insr(nopt,1+2*manti)=ip2
21975 insr(nopt,2)=igl
21976 insr(nopt,3-2*manti)=ip1
21977 IF (mstp(89).GT.0.OR.nopt.EQ.0) GOTO 470
21978 ENDIF
21979 IF (mstp(89).GT.0.OR.nopt.EQ.0) GOTO 460
21980 ENDIF
21981C...Reset link test information.
21982 DO 550 i=mint(84)+1,n
21983 k(i,4)=mod(k(i,4),mstu(5)**2)
21984 k(i,5)=mod(k(i,5),mstu(5)**2)
21985 550 CONTINUE
21986 IF (mstp(89).GT.0.OR.nopt.EQ.0) GOTO 450
21987 ENDIF
21988C...Now we have a list of best gluon insertions, none of which cause
21989C...singlets to arise. If list is empty, try again a few times. Note:
21990C...this should never happen if we have a meson with a gluon inserted
21991C...in the beam remnant, since that breaks up the colour line.
21992 IF (nopt.EQ.0) THEN
21993C...Abandon BR-g-BR suppression for retries. This is not serious, it
21994C...just means we happened to start with trying a bad sequence.
21995 parp80=1d0
21996 IF (mretry.LE.10.AND.(itjunc(1).NE.0.OR.jst(1,3).EQ.0).and
21997 & .(itjunc(2).NE.0.OR.jst(2,3).EQ.0)) THEN
21998 mretry=mretry+1
21999 DO 590 js=1,2
22000 IF (itjunc(js).NE.0) THEN
22001 jst(js,1)=iv(js,1)
22002 jst(js,2)=iv(js,2)
22003 jst(js,3)=iv(js,3)
22004C...Reset valence quark parent pointers
22005 DO 560 i=mint(53)+1,n
22006 IF (k(i,2).EQ.88.AND.k(i,3).EQ.js) iju=i
22007 560 CONTINUE
22008 manti=itjunc(js)-1
22009C...Set (anti)colour mother = junction.
22010 DO 570 jv=1,3
22011 k(iv(js,jv),4+manti)=mod(k(iv(js,jv),4+manti),mstu(5))
22012 & +mstu(5)*iju
22013 570 CONTINUE
22014 ELSE
22015C...Same for mesons. JST unchanged, so needn't be restored.
22016 iq=jst(js,1)
22017 iqbar=jst(js,2)
22018 k(iq,4)=mod(k(iq,4),mstu(5))+mstu(5)*iqbar
22019 k(iqbar,5)=mod(k(iqbar,5),mstu(5))+mstu(5)*iq
22020 ENDIF
22021C...Also reset gluon parent pointers.
22022 ng(js)=0
22023 DO 580 im=1,nmi(js)
22024 i=imi(js,im,1)
22025 IF (k(i,2).EQ.21) THEN
22026 k(i,4)=mod(k(i,4),mstu(5))
22027 k(i,5)=mod(k(i,5),mstu(5))
22028 ng(js)=ng(js)+1
22029 ENDIF
22030 580 CONTINUE
22031 590 CONTINUE
22032C...Reset colour tags
22033 DO 600 i=mint(84)+1,n
22034 mct(i,1)=mco(i,1)
22035 mct(i,2)=mco(i,2)
22036 600 CONTINUE
22037 GOTO 400
22038 ELSE
22039 IF(nerrpr.LT.5) THEN
22040 nerrpr=nerrpr+1
22041 CALL pylist(4)
22042 CALL pyerrm(19,'(PYMIHK:) No physical colour flow found!')
22043 WRITE(mstu(11),*) 'NG:', ng,' MOUT:', mout(js)
22044 ENDIF
22045C...Kill event and start another.
22046 mint(51)=1
22047 RETURN
22048 ENDIF
22049 ELSE
22050C...Select between insertions, suppressing insertions wholly in the BR.
22051 iin=pyr(0)*nopt+1
22052 610 iin=mod(iin,nopt)+1
22053 IF (insr(iin,1).GT.mint(53).AND.insr(iin,3).GT.mint(53)
22054 & .AND.mout(js).NE.0.AND.pyr(0).GT.parp80) GOTO 610
22055 ENDIF
22056
22057C...Now we know which gluon to insert where. Colour tags in JCCO and
22058C...colour connection information should be updated, NG(JS) should be
22059C...counted down, and a new loop performed if there are still gluons
22060C...left on any side.
22061 icm=insr(iin,1)
22062 iacm=insr(iin,3)
22063 igl=insr(iin,2)
22064C...JCG : Original gluon colour tag
22065C...JCAG: Original gluon anticolour tag.
22066C...JCM : Original anticolour tag of gluon colour mother
22067C...JACM: Original colour tag of gluon anticolour mother
22068 jcg=mco(igl,1)
22069 jcm=mco(icm,2)
22070 jacg=mco(igl,2)
22071 jacm=mco(iacm,1)
22072
22073 CALL pymihg(jacm,jacg,jcm,jcg)
22074 IF (maccpt.EQ.0) THEN
22075 IF(nerrpr.LT.5) THEN
22076 nerrpr=nerrpr+1
22077 CALL pylist(4)
22078 CALL pyerrm(11,'(PYMIHK:) Unphysical colour flow!')
22079 WRITE(mstu(11),*) 'attaching', igl,' between', icm, iacm
22080 ENDIF
22081C...Kill event and start another.
22082 mint(51)=1
22083 RETURN
22084 ELSE
22085C...If everything went fine, store new JCCN in JCCO.
22086 ncc=ncc+1
22087 DO 620 icc=1,ncc
22088 jcco(icc,1)=jccn(icc,1)
22089 jcco(icc,2)=jccn(icc,2)
22090 620 CONTINUE
22091 ENDIF
22092
22093C...One gluon attached is counted as equivalent to one end outside.
22094 mout(js)=1
22095C...Set IGL colour mother = ICM.
22096 k(igl,4)=mod(k(igl,4),mstu(5))+mstu(5)*icm
22097C...Set ICM anticolour mother = IGL colour.
22098 IF (k(icm,2).NE.88) THEN
22099 k(icm,5)=mod(k(icm,5),mstu(5))+mstu(5)*igl
22100 ELSE
22101C...If ICM is junction, just update JST array for now.
22102 DO 630 msj=1,3
22103 IF (jst(js,msj).EQ.iacm) jst(js,msj)=igl
22104 630 CONTINUE
22105 ENDIF
22106C...Set IGL anticolour mother = IACM.
22107 k(igl,5)=mod(k(igl,5),mstu(5))+mstu(5)*iacm
22108C...Set IACM anticolour mother = IGL anticolour.
22109 IF (k(iacm,2).NE.88) THEN
22110 k(iacm,4)=mod(k(iacm,4),mstu(5))+mstu(5)*igl
22111 ELSE
22112C...If IACM is junction, just update JST array for now.
22113 DO 640 msj=1,3
22114 IF (jst(js,msj).EQ.icm) jst(js,msj)=igl
22115 640 CONTINUE
22116 ENDIF
22117C...Count down # unconnected gluons.
22118 ng(js)=ng(js)-1
22119 ENDIF
22120 IF (ng(1).GT.0.OR.ng(2).GT.0) GOTO 440
22121
22122 DO 840 js=1,2
22123C...Collapse fictitious gluons.
22124 DO 670 igl=mint(53)+1,n
22125 IF (k(igl,2).EQ.21.AND.k(igl,3).EQ.mint(83)+js.AND.
22126 & k(igl,1).EQ.14) THEN
22127 icm=k(igl,4)/mstu(5)
22128 iam=k(igl,5)/mstu(5)
22129 icd=mod(k(igl,4),mstu(5))
22130 iad=mod(k(igl,5),mstu(5))
22131C...Set gluon daughters pointing to gluon mothers
22132 k(iad,5)=mod(k(iad,5),mstu(5))+mstu(5)*iam
22133 k(icd,4)=mod(k(icd,4),mstu(5))+mstu(5)*icm
22134C...Set gluon mothers pointing to gluon daughters.
22135 IF (k(icm,2).NE.88) THEN
22136 k(icm,5)=mod(k(icm,5),mstu(5))+mstu(5)*icd
22137 ELSE
22138C...Special case: mother=junction. Just update JST array for now.
22139 DO 650 msj=1,3
22140 IF (jst(js,msj).EQ.igl) jst(js,msj)=icd
22141 650 CONTINUE
22142 ENDIF
22143 IF (k(iam,2).NE.88) THEN
22144 k(iam,4)=mod(k(iam,4),mstu(5))+mstu(5)*iad
22145 ELSE
22146 DO 660 msj=1,3
22147 IF (jst(js,msj).EQ.igl) jst(js,msj)=iad
22148 660 CONTINUE
22149 ENDIF
22150 ENDIF
22151 670 CONTINUE
22152
22153C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22154 im=nmi(js)+1
22155 680 im=im-1
22156 IF (im.GT.mint(31).AND.k(imi(js,im,1),2).NE.21) GOTO 680
22157 IF (im.GT.mint(31)) THEN
22158 nmi(js)=nmi(js)-1
22159 DO 690 imr=im,nmi(js)
22160 imi(js,imr,1)=imi(js,imr+1,1)
22161 imi(js,imr,2)=imi(js,imr+1,2)
22162 690 CONTINUE
22163 GOTO 680
22164 ENDIF
22165
22166C...Finally, connect junction.
22167 IF (itjunc(js).NE.0) THEN
22168 DO 700 i=mint(53)+1,n
22169 IF (k(i,2).EQ.88.AND.k(i,3).EQ.mint(83)+js) iju=i
22170 700 CONTINUE
22171C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22172 nbrjq =0
22173 nbrvq =0
22174 DO 720 msj=1,3
22175 idq(msj)=0
22176C...Find jq with no glue inbetween inside beam remnant.
22177 IF (jst(js,msj).GT.mint(53).AND.iabs(k(jst(js,msj),2)).LE.5)
22178 & THEN
22179 nbrjq=nbrjq+1
22180C...Set IDQ = -I if q non-valence and = +I if q valence.
22181 idq(nbrjq)=-jst(js,msj)
22182 DO 710 jv=1,3
22183 IF (iv(js,jv).EQ.jst(js,msj)) THEN
22184 idq(nbrjq)=jst(js,msj)
22185 nbrvq=nbrvq+1
22186 ENDIF
22187 710 CONTINUE
22188 ENDIF
22189 i12=mod(msj+1,2)
22190 i45=5
22191 IF (msj.EQ.3) i45=4
22192 k(iju,i45)=k(iju,i45)+(mstu(5)**i12)*jst(js,msj)
22193 720 CONTINUE
22194
22195C...Check if diquark can be formed.
22196 IF ((mstp(88).GE.0.AND.nbrvq.GE.2).OR.(nbrjq.GE.2.AND.mstp(88)
22197 & .GE.1)) THEN
22198C...If there is less than 2 valence quarks connected to junction
22199C...and MSTP(88)>1, use random non-valence quarks to fill up.
22200 IF (nbrvq.LE.1) THEN
22201 ndiq=nbrvq
22202 730 jflip=nbrjq*pyr(0)+1
22203 IF (idq(jflip).LT.0) THEN
22204 idq(jflip)=-idq(jflip)
22205 ndiq=ndiq+1
22206 ENDIF
22207 IF (ndiq.LE.1) GOTO 730
22208 ENDIF
22209C...Place selected quarks first in IDQ, ordered in flavour.
22210 DO 740 jdq=1,3
22211 IF (idq(jdq).LE.0) THEN
22212 itemp1 = idq(jdq)
22213 idq(jdq)= idq(3)
22214 idq(3) = -itemp1
22215 IF (iabs(k(idq(1),2)).LT.iabs(k(idq(2),2))) THEN
22216 itemp1 = idq(1)
22217 idq(1) = idq(2)
22218 idq(2) = itemp1
22219 ENDIF
22220 ENDIF
22221 740 CONTINUE
22222C...Choose diquark spin.
22223 IF (nbrvq.EQ.2) THEN
22224C...If the selected quarks are both valence, we may use SU(6) rules
22225C...to figure out which spin the diquark has, by a subdivision of the
22226C...original beam hadron into the selected diquark system plus a kicked
22227C...out quark, IKO.
22228 jko=6
22229 DO 760 jdq=1,2
22230 DO 750 jv=1,3
22231 IF (idq(jdq).EQ.iv(js,jv)) jko=jko-jv
22232 750 CONTINUE
22233 760 CONTINUE
22234 iko=iv(js,jko)
22235 CALL pyspli(mint(10+js),k(iko,2),kfdum,kfdq)
22236 ELSE
22237C...If one or more of the selected quarks are not valence, we cannot use
22238C...SU(6) subdivisions of the original beam hadron. Instead, with the
22239C...flavours of the diquark already selected, we assume for now
22240C...50:50 spin-1:spin-0 (where spin-0 possible).
22241 kfdq=1000*k(idq(1),2)+100*k(idq(2),2)
22242 is=3
22243 IF (k(idq(1),2).NE.k(idq(2),2).AND.
22244 & (1d0+3d0*parj(4))*pyr(0).LT.1d0) is=1
22245 kfdq=kfdq+isign(is,kfdq)
22246 ENDIF
22247
22248C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22249C...Note: third quark can per definition not also be valence,
22250C...therefore we can only do this if we are allowed to use sea quarks.
22251 770 IF (idq(3).NE.0.AND.mstp(88).GE.2) THEN
22252 ntry=0
22253 780 ntry=ntry+1
22254 CALL pykfdi(kfdq,k(iabs(idq(3)),2),kfdum,kfbar)
22255 IF (kfbar.EQ.0.AND.ntry.LE.100) THEN
22256 GOTO 780
22257 ELSEIF(ntry.GT.100) THEN
22258C...If no baryon can be found, give up and form diquark.
22259 idq(3)=0
22260 GOTO 770
22261 ELSE
22262C...Replace junction by baryon.
22263 k(iju,1)=1
22264 k(iju,2)=kfbar
22265 k(iju,3)=mint(83)+js
22266 k(iju,4)=0
22267 k(iju,5)=0
22268 p(iju,5)=pymass(kfbar)
22269 DO 790 msj=1,3
22270C...Prepare removal of participating quarks from ER.
22271 k(jst(js,msj),1)=-1
22272 790 CONTINUE
22273 ENDIF
22274 ELSE
22275C...If collapse to baryon not possible or not allowed, replace junction
22276C...by diquark. This way, collapsed gluons that were pointing at the
22277C...junction will now point (correctly) at diquark.
22278 manti=itjunc(js)-1
22279 k(iju,1)=3
22280 k(iju,2)=kfdq
22281 k(iju,3)=mint(83)+js
22282 k(iju,4)=0
22283 k(iju,5)=0
22284 DO 800 msj=1,3
22285 ip=jst(js,msj)
22286 IF (ip.NE.idq(1).AND.ip.NE.idq(2)) THEN
22287 k(iju,4+manti)=0
22288 k(iju,5-manti)=ip*mstu(5)
22289 k(ip,4+manti)=mod(k(ip,4+manti),mstu(5))+
22290 & mstu(5)*iju
22291 mct(iju,2-manti)=mct(ip,1+manti)
22292 ELSE
22293C...Prepare removal of participating quarks from ER.
22294 k(ip,1)=-1
22295 ENDIF
22296 800 CONTINUE
22297 ENDIF
22298
22299C...Update so ER pointers to collapsed quarks
22300C...now go to collapsed object.
22301 DO 820 i=mint(84)+1,n
22302 IF ((k(i,3).EQ.mint(83)+js.OR.k(i,3).EQ.mint(83)+2+js).and
22303 & .k(i,1).GT.0) THEN
22304 DO 810 isid=4,5
22305 imo=k(i,isid)/mstu(5)
22306 ida=mod(k(i,isid),mstu(5))
22307 IF (imo.GT.0) THEN
22308 IF (k(imo,1).EQ.-1) imo=iju
22309 ENDIF
22310 IF (ida.GT.0) THEN
22311 IF (k(ida,1).EQ.-1) ida=iju
22312 ENDIF
22313 k(i,isid)=ida+mstu(5)*imo
22314 810 CONTINUE
22315 ENDIF
22316 820 CONTINUE
22317 ENDIF
22318 ENDIF
22319
22320C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22321C...(this only happens for baryons, where we want to force the gluon
22322C...to sit next to the junction. Mesons handled above.)
22323 IF (nbrtot(js).EQ.0) THEN
22324 n=n+1
22325 DO 830 ix=1,5
22326 k(n,ix)=0
22327 p(n,ix)=0d0
22328 v(n,ix)=0d0
22329 830 CONTINUE
22330 igl=n
22331 k(igl,1)=3
22332 k(igl,2)=21
22333 k(igl,3)=mint(83)+js
22334 IF (itjunc(js).NE.0) THEN
22335C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22336 jleg=pyr(0)*nvsum(js)+1
22337 i1=jst(js,jleg)
22338 jst(js,jleg)=igl
22339 jct=mct(i1,itjunc(js))
22340 mct(igl,3-itjunc(js))=jct
22341 nct=nct+1
22342 mct(igl,itjunc(js))=nct
22343 manti=itjunc(js)-1
22344 ELSE
22345C...Meson. Should not happen.
22346 CALL pyerrm(19,'(PYMIHK:) Empty meson beam remnant')
22347 IF(nerrpr.LT.5) THEN
22348 WRITE(mstu(11),*) 'This should not have been possible!'
22349 CALL pylist(4)
22350 nerrpr=nerrpr+1
22351 ENDIF
22352 mint(51)=1
22353 RETURN
22354 ENDIF
22355 i2=mod(k(i1,4+manti)/mstu(5),mstu(5))
22356 k(i1,4+manti)=mod(k(i1,4+manti),mstu(5))+mstu(5)*igl
22357 k(igl,5-manti)=mod(k(igl,5-manti),mstu(5))+mstu(5)*i1
22358 k(igl,4+manti)=mod(k(igl,4+manti),mstu(5))+mstu(5)*i2
22359 IF (k(i2,2).NE.88) THEN
22360 k(i2,5-manti)=mod(k(i2,5-manti),mstu(5))+mstu(5)*igl
22361 ELSE
22362 IF (mod(k(i2,4),mstu(5)).EQ.i1) THEN
22363 k(i2,4)=(k(i2,4)/mstu(5))*mstu(5)+igl
22364 ELSEIF(mod(k(i2,5)/mstu(5),mstu(5)).EQ.i1) THEN
22365 k(i2,5)=mod(k(i2,5),mstu(5))+mstu(5)*igl
22366 ELSE
22367 k(i2,5)=(k(i2,5)/mstu(5))*mstu(5)+igl
22368 ENDIF
22369 ENDIF
22370 ENDIF
22371 840 CONTINUE
22372
22373C...Remove collapsed quarks and junctions from ER and update IMI.
22374 CALL pyedit(11)
22375
22376C...Also update beam remnant part of IMI.
22377 nmi(1)=mint(31)
22378 nmi(2)=mint(31)
22379 DO 850 i=mint(53)+1,n
22380 IF (k(i,1).LE.0) GOTO 850
22381C...Restore BR quark/diquark/baryon pointers in IMI.
22382 IF ((k(i,2).NE.21.OR.k(i,1).NE.14).AND.k(i,2).NE.88) THEN
22383 js=k(i,3)-mint(83)
22384 nmi(js)=nmi(js)+1
22385 imi(js,nmi(js),1)=i
22386 imi(js,nmi(js),2)=0
22387 ENDIF
22388 850 CONTINUE
22389
22390C...Restore companion information from collapsed gluons.
22391 DO 870 i=mint(53)+1,n
22392 IF (k(i,2).EQ.21.AND.k(i,1).EQ.14) THEN
22393 js=k(i,3)-mint(83)
22394 jcd=mod(k(i,4),mstu(5))
22395 jad=mod(k(i,5),mstu(5))
22396 DO 860 im=1,nmi(js)
22397 IF (imi(js,im,1).EQ.jcd) imc=im
22398 IF (imi(js,im,1).EQ.jad) ima=im
22399 860 CONTINUE
22400 imi(js,imc,2)=imi(js,ima,1)
22401 imi(js,ima,2)=imi(js,imc,1)
22402 ENDIF
22403 870 CONTINUE
22404
22405C...Renumber colour lines (since some have disappeared)
22406 jct=0
22407 jcd=0
22408 880 jct=jct+1
22409 mfound=0
22410 i=mint(84)
22411 890 i=i+1
22412 IF (i.EQ.n+1) THEN
22413 IF (mfound.EQ.0) jcd=jcd+1
22414 ELSEIF (mct(i,1).EQ.jct.AND.k(i,1).GE.1) THEN
22415 mct(i,1)=jct-jcd
22416 mfound=1
22417 ELSEIF (mct(i,2).EQ.jct.AND.k(i,1).GE.1) THEN
22418 mct(i,2)=jct-jcd
22419 mfound=1
22420 ENDIF
22421 IF (i.LE.n) GOTO 890
22422 IF (jct.LT.nct) GOTO 880
22423 nct=jct-jcd
22424
22425C...Reset hard interaction subsystems to their CM frames.
22426 IF (iboost.EQ.1) THEN
22427 DO 900 im=1,mint(31)
22428 beta=-(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
22429 CALL pyrobo(imisep(im-1)+1,imisep(im),0d0,0d0,0d0,0d0,beta)
22430 900 CONTINUE
22431C...Zero beam remnant longitudinal momenta and energies
22432 DO 910 i=mint(53)+1,n
22433 p(i,3)=0d0
22434 p(i,4)=0d0
22435 910 CONTINUE
22436 ELSE
22437 CALL pyerrm(9
22438 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22439C...Kill event and start another.
22440 mint(51)=1
22441 RETURN
22442 ENDIF
22443
22444 9999 RETURN
22445 END
22446C*********************************************************************
22447
22448C...PYCTTR
22449C...Adapted from PYPREP.
22450C...Assigns LHA1 colour tags to coloured partons based on
22451C...K(I,4) and K(I,5) colour connection record.
22452C...KCS negative signifies that a previous tracing should be continued.
22453C...(in case the tag to be continued is empty, the routine exits)
22454C...Starts at I and ends at I or IEND.
22455C...Special considerations for systems with junctions.
22456C...Special: if IEND=-1, means trace this parton to its color partner,
22457C... then exit. If no partner found, exit with 0.
22458
22459 SUBROUTINE pycttr(I,KCS,IEND)
22460C...Double precision and integer declarations.
22461 IMPLICIT DOUBLE PRECISION(a-h, o-z)
22462 INTEGER PYK,PYCHGE,PYCOMP
22463C...Commonblocks.
22464 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
22465 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
22466 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
22467 common/pyint1/mint(400),vint(400)
22468C...The common block of colour tags.
22469 common/pyctag/nct,mct(4000,2)
22470 SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/,/pyctag/
22471 DATA nerrpr/0/
22472 SAVE nerrpr
22473
22474C...Skip if parton not existing or does not have KCS
22475 IF (k(i,1).LE.0) GOTO 120
22476 kc=pycomp(k(i,2))
22477 IF (kc.EQ.0) GOTO 120
22478 kq=kchg(kc,2)
22479 IF (kq.EQ.0) GOTO 120
22480 IF (iabs(kq).EQ.1.AND.kq*(9-2*abs(kcs)).NE.isign(1,k(i,2)))
22481 & GOTO 120
22482
22483 IF (kcs.GT.0) THEN
22484 nct=nct+1
22485C...Set colour tag of first parton.
22486 mct(i,kcs-3)=nct
22487 ncs=nct
22488 ELSE
22489 kcs=-kcs
22490 ncs=mct(i,kcs-3)
22491 IF (ncs.EQ.0) GOTO 120
22492 ENDIF
22493
22494 ia=i
22495 nstp=0
22496 100 nstp=nstp+1
22497 IF(nstp.GT.4*n) THEN
22498 CALL pyerrm(14,'(PYCTTR:) caught in infinite loop')
22499 GOTO 120
22500 ENDIF
22501
22502C...Finished if reached final-state triplet.
22503 IF(k(ia,1).EQ.3) THEN
22504 IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) GOTO 120
22505 ENDIF
22506
22507C...Also finished if reached junction.
22508 IF(k(ia,1).EQ.42) THEN
22509 GOTO 120
22510 ENDIF
22511
22512C...GOTO next parton in colour space.
22513 110 ib=ia
22514C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22515 IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5))
22516 & .NE.0) THEN
22517 ia=mod(k(ib,kcs),mstu(5))
22518 k(ib,kcs)=k(ib,kcs)+mstu(5)**2
22519 mrev=0
22520 ELSE
22521C...If KCS mother traced or KCS mother nonexistent, switch colour.
22522 IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
22523 & mstu(5)).EQ.0) THEN
22524 kcs=9-kcs
22525 nct=nct+1
22526 ncs=nct
22527C...Assign new colour tag on other side of old parton.
22528 mct(ib,kcs-3)=nct
22529 ENDIF
22530C...Goto (new) KCS mother, set mother traced tag
22531 ia=mod(k(ib,kcs)/mstu(5),mstu(5))
22532 k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
22533 mrev=1
22534 ENDIF
22535 IF(ia.LE.0.OR.ia.GT.n) THEN
22536 IF (iend.EQ.-1) THEN
22537 iend=0
22538 GOTO 120
22539 ENDIF
22540 CALL pyerrm(12,'(PYCTTR:) colour tag tracing failed')
22541 IF(nerrpr.LT.5) THEN
22542 write(*,*) 'began at ',i
22543 write(*,*) 'ended going from', ib, ' to', ia, ' KCS=',kcs,
22544 & ' NCS=',ncs,' MREV=',mrev
22545 CALL pylist(4)
22546 nerrpr=nerrpr+1
22547 ENDIF
22548 mint(51)=1
22549 RETURN
22550 ENDIF
22551 IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),
22552 & mstu(5)).EQ.ib) THEN
22553 IF(mrev.EQ.1) kcs=9-kcs
22554 IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
22555C...Set KSC mother traced tag for IA
22556 k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
22557 ELSE
22558 IF(mrev.EQ.0) kcs=9-kcs
22559 IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
22560C...Set KCS daughter traced tag for IA
22561 k(ia,kcs)=k(ia,kcs)+mstu(5)**2
22562 ENDIF
22563C...Assign new colour tag
22564 mct(ia,kcs-3)=ncs
22565C...Finish if IEND=-1 and found final-state color partner
22566 IF (iend.EQ.-1.AND.k(ia,1).LT.10) THEN
22567 iend=ia
22568 GOTO 120
22569 ENDIF
22570 IF (ia.NE.i.AND.ia.NE.iend) GOTO 100
22571
22572 120 RETURN
22573 END
22574
22575*********************************************************************
22576
22577C...PYMIHG
22578C...Collapse JCP1 and connecting tags to JCG1.
22579C...Collapse JCP2 and connecting tags to JCG2.
22580
22581 SUBROUTINE pymihg(JCP1,JCG1,JCP2,JCG2)
22582C...Double precision and integer declarations.
22583 IMPLICIT DOUBLE PRECISION(a-h, o-z)
22584 IMPLICIT INTEGER(I-N)
22585 INTEGER PYK,PYCHGE,PYCOMP
22586C...The event record
22587 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
22588C...Parameters
22589 common/pyint1/mint(400),vint(400)
22590 SAVE /pyjets/,/pyint1/
22591C...Local variables
22592 COMMON /pycbls/mco(4000,2),ncc,jcco(4000,2),jccn(4000,2),maccpt
22593 COMMON /pyctag/nct,mct(4000,2)
22594 SAVE /pycbls/,/pyctag/
22595
22596C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22597C...in temporary tag collapse array JCCN. Only break up one connection.
22598 maccpt=1
22599 mclps=0
22600 DO 100 icc=1,ncc
22601 jccn(icc,1)=jcco(icc,1)
22602 jccn(icc,2)=jcco(icc,2)
22603C...If there was a mother, it was previously connected to JCP1.
22604C...Should be changed to JCP2.
22605 IF (mclps.EQ.0) THEN
22606 IF (jccn(icc,1).EQ.max(jcp1,jcp2).AND.jccn(icc,2).EQ.min(jcp1
22607 & ,jcp2)) THEN
22608 jccn(icc,1)=max(jcg2,jcp2)
22609 jccn(icc,2)=min(jcg2,jcp2)
22610 mclps=1
22611 ENDIF
22612 ENDIF
22613 100 CONTINUE
22614C...Also collapse colours on JCP1 side of JCG1
22615 IF (jcp1.NE.0) THEN
22616 jccn(ncc+1,1)=max(jcp1,jcg1)
22617 jccn(ncc+1,2)=min(jcp1,jcg1)
22618 ELSE
22619 jccn(ncc+1,1)=max(jcp2,jcg2)
22620 jccn(ncc+1,2)=min(jcp2,jcg2)
22621 ENDIF
22622
22623C...Initialize event record colour tag array MCT array to MCO.
22624 DO 110 i=mint(84)+1,n
22625 mct(i,1)=mco(i,1)
22626 mct(i,2)=mco(i,2)
22627 110 CONTINUE
22628
22629C...Collapse tags:
22630C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22631C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22632C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22633C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22634 DO 160 is=1,4
22635C...Skip if junction.
22636 IF ((is.EQ.4.AND.jcp2.EQ.0).OR.(is.EQ.3).AND.jcp1.EQ.0) GOTO 160
22637C...Define starting point in tag space.
22638C...JCA = previous tag
22639C...JCO = present tag
22640C...JCN = new tag
22641 IF (mod(is,2).EQ.1) THEN
22642 jco=jcp1
22643 jcn=jcg1
22644 jcall=jcg1
22645 ELSEIF (mod(is,2).EQ.0) THEN
22646 jco=jcp2
22647 jcn=jcg2
22648 jcall=jcg2
22649 ENDIF
22650 itrace=0
22651 120 itrace=itrace+1
22652 IF (itrace.GT.1000) THEN
22653C...NB: Proper error message should be defined here.
22654 CALL pyerrm(14
22655 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22656 mint(57)=mint(57)+1
22657 mint(51)=1
22658 RETURN
22659 ENDIF
22660C...Collapse all JCN tags to JCALL
22661 DO 130 i=mint(84)+1,n
22662 IF (mco(i,1).EQ.jcn) mct(i,1)=jcall
22663 IF (mco(i,2).EQ.jcn) mct(i,2)=jcall
22664 130 CONTINUE
22665C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22666 IF (is.GT.2.AND.(jcn.EQ.jcall)) THEN
22667 jca=jcn
22668 jcn=jco
22669 ELSE
22670 jca=jco
22671 jco=jcn
22672 ENDIF
22673C...If possible, step from JCO to new tag JCN not equal to JCA.
22674 DO 140 icc=1,ncc+1
22675 IF (jccn(icc,1).EQ.jco.AND.jccn(icc,2).NE.jca) jcn=
22676 & jccn(icc,2)
22677 IF (jccn(icc,2).EQ.jco.AND.jccn(icc,1).NE.jca) jcn=
22678 & jccn(icc,1)
22679 140 CONTINUE
22680C...Iterate if new colour was arrived at, but don't go in circles.
22681 IF (jcn.NE.jco.AND.jcn.NE.jcall) GOTO 120
22682C...Change all JCN tags in MCO to JCALL in MCT.
22683 DO 150 i=mint(84)+1,n
22684 IF (mco(i,1).EQ.jcn) mct(i,1)=jcall
22685 IF (mco(i,2).EQ.jcn) mct(i,2)=jcall
22686C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22687 IF (k(i,2).EQ.21.AND.mct(i,1).EQ.mct(i,2).AND.mct(i,1)
22688 & .NE.0) maccpt=0
22689 150 CONTINUE
22690 160 CONTINUE
22691
22692 DO 200 jcl=nct,1,-1
22693 jca=0
22694 jcn=jcl
22695 170 jco=jcn
22696 DO 180 icc=1,ncc+1
22697 IF (jccn(icc,1).EQ.jco.AND.jccn(icc,2).NE.jca) jcn
22698 & =jccn(icc,2)
22699 IF (jccn(icc,2).EQ.jco.AND.jccn(icc,1).NE.jca) jcn
22700 & =jccn(icc,1)
22701 180 CONTINUE
22702C...Overpaint all JCN with JCL
22703 IF (jcn.NE.jco.AND.jcn.NE.jcl) THEN
22704 DO 190 i=mint(84)+1,n
22705 IF (mct(i,1).EQ.jcn) mct(i,1)=jcl
22706 IF (mct(i,2).EQ.jcn) mct(i,2)=jcl
22707C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22708 IF (k(i,2).EQ.21.AND.mct(i,1).EQ.mct(i,2).AND.mct(i,1)
22709 & .NE.0) maccpt=0
22710 190 CONTINUE
22711 jca=jco
22712 GOTO 170
22713 ENDIF
22714 200 CONTINUE
22715
22716 RETURN
22717 END
22718
22719C*********************************************************************
22720
22721C...PYMIRM
22722C...Picks primordial kT and shares longitudinal momentum among
22723C...beam remnants.
22724
22725 SUBROUTINE pymirm
22726
22727C...Double precision and integer declarations.
22728 IMPLICIT DOUBLE PRECISION(a-h, o-z)
22729 IMPLICIT INTEGER(I-N)
22730 INTEGER PYK,PYCHGE,PYCOMP
22731C...The event record
22732 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
22733C...Parameters
22734 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
22735 common/pypars/mstp(200),parp(200),msti(200),pari(200)
22736 common/pyint1/mint(400),vint(400)
22737C...The common block of colour tags.
22738 common/pyctag/nct,mct(4000,2)
22739C...The common block of dangling ends
22740 common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
22741 & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
22742 & xmi(2,240),pt2mi(240),imisep(0:240)
22743 SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/,/pyintm/,/pyctag/
22744C...Local variables
22745 dimension w(0:2,0:2),vb(3),nnxt(2),ivalq(2),icomq(2)
22746C...W(I,J)| J=0 | 1 | 2 |
22747C... I=0 | Wrem**2 | W+ | W- |
22748C... 1 | W1**2 | W1+ | W1- |
22749C... 2 | W2**2 | W2+ | W2- |
22750C...4-product
22751 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)
22752C...Tentative parametrization of <kT> as a function of Q.
22753 sigpt(q)=max(parj(21),2.1d0*q/(7d0+q))
22754C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22755C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22756 getpt(q,sigma)=min(sigma*sqrt(-log(pyr(0))),parp(93))
22757C...Lambda kinematic function.
22758 flam(a,b,c)=a**2+b**2+c**2-2d0*(a*b+b*c+c*a)
22759
22760C...Beginning and end of beam remnant partons
22761 nout=mint(53)
22762 isub=mint(1)
22763
22764C...Loopback point if kinematic choices gives impossible configuration.
22765 ntry=0
22766 100 ntry=ntry+1
22767
22768C...Assign kT values on each side separately.
22769 DO 180 js=1,2
22770
22771C...First zero all kT on this side. Skip if no kT to generate.
22772 DO 110 im=1,nmi(js)
22773 p(imi(js,im,1),1)=0d0
22774 p(imi(js,im,1),2)=0d0
22775 110 CONTINUE
22776 IF(mstp(91).LE.0) GOTO 180
22777
22778C...Now assign kT to each (non-collapsed) parton in IMI.
22779 DO 170 im=1,nmi(js)
22780 i=imi(js,im,1)
22781C...Select kT according to truncated gaussian or 1/kt6 tails.
22782C...For first interaction, either use rms width = PARP(91) or fitted.
22783 IF (im.EQ.1) THEN
22784 sigma=parp(91)
22785 IF (mstp(91).GE.11.AND.mstp(91).LE.20) THEN
22786 q=sqrt(pt2mi(im))
22787 sigma=sigpt(q)
22788 ENDIF
22789 ELSE
22790C...For subsequent interactions and BR partons use fragmentation width.
22791 sigma=parj(21)
22792 ENDIF
22793 phi=paru(2)*pyr(0)
22794 pt=0d0
22795 IF(ntry.LE.100) THEN
22796 111 IF (mstp(91).EQ.1.OR.mstp(91).EQ.11) THEN
22797 pt=getpt(q,sigma)
22798 ptx=pt*cos(phi)
22799 pty=pt*sin(phi)
22800 ELSEIF (mstp(91).EQ.2) THEN
22801 CALL pyerrm(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22802 & 'available, using MSTP(91)=1.')
22803 CALL pygive('MSTP(91)=1')
22804 GOTO 111
22805 ELSEIF(mstp(91).EQ.3.OR.mstp(91).EQ.13) THEN
22806C...Use distribution with kt**6 tails, rms width = PARP(91).
22807 eps=sqrt(3d0/2d0)*sigma
22808C...Generate PTX and PTY separately, each propto 1/KT**6
22809 DO 119 ixy=1,2
22810C...Decide which interval to try
22811 112 p12=1d0/(1d0+27d0/40d0*sigma**6/eps**6)
22812 IF (pyr(0).LT.p12) THEN
22813C...Use flat approx with accept/reject up to EPS.
22814 pt=pyr(0)*eps
22815 wt=(3d0/2d0*sigma**2/(pt**2+3d0/2d0*sigma**2))**3
22816 IF (pyr(0).GT.wt) GOTO 112
22817 ELSE
22818C...Above EPS, use 1/kt**6 approx with accept/reject.
22819 pt=eps/(pyr(0)**(1d0/5d0))
22820 wt=pt**6/(pt**2+3d0/2d0*sigma**2)**3
22821 IF (pyr(0).GT.wt) GOTO 112
22822 ENDIF
22823 msign=1
22824 IF (pyr(0).GT.0.5d0) msign=-1
22825 IF (ixy.EQ.1) ptx=msign*pt
22826 IF (ixy.EQ.2) pty=msign*pt
22827 119 CONTINUE
22828 ELSEIF (mstp(91).EQ.4.OR.mstp(91).EQ.14) THEN
22829 ptx=sigma*(sqrt(6d0)*pyr(0)-sqrt(3d0/2d0))
22830 pty=sigma*(sqrt(6d0)*pyr(0)-sqrt(3d0/2d0))
22831 ENDIF
22832C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22833 pt=sqrt(ptx**2+pty**2)
22834 wt=1d0
22835 IF (pt.GT.parp(93)) wt=sqrt(parp(93)/pt)
22836 IF(isub.EQ.95.AND.im.EQ.1) wt=0d0
22837 ptx=ptx*wt
22838 pty=pty*wt
22839 pt=sqrt(ptx**2+pty**2)
22840 ENDIF
22841
22842 p(i,1)=p(i,1)+ptx
22843 p(i,2)=p(i,2)+pty
22844
22845C...Compensation kicks, with varying degree of local anticorrelations.
22846 mcorr=mstp(90)
22847 IF (mcorr.EQ.0.OR.isub.EQ.95) THEN
22848 ptcx=-ptx/(nmi(js)-1)
22849 ptcy=-pty/(nmi(js)-1)
22850 IF(isub.EQ.95) THEN
22851 ptcx=-ptx/(nmi(js)-2)
22852 ptcy=-pty/(nmi(js)-2)
22853 ENDIF
22854 DO 120 imc=1,nmi(js)
22855 IF (imc.EQ.im) GOTO 120
22856 IF(isub.EQ.95.AND.imc.EQ.1) GOTO 120
22857 p(imi(js,imc,1),1)=p(imi(js,imc,1),1)+ptcx
22858 p(imi(js,imc,1),2)=p(imi(js,imc,1),2)+ptcy
22859 120 CONTINUE
22860 ELSEIF (mcorr.GE.1) THEN
22861 DO 140 msid=4,5
22862 nnxt(msid-3)=0
22863C...Count up # of neighbours on either side
22864 imo=i
22865 130 imo=k(imo,msid)/mstu(5)
22866 IF (imo.EQ.0) GOTO 140
22867 nnxt(msid-3)=nnxt(msid-3)+1
22868C...Stop at quarks and junctions
22869 IF (mcorr.EQ.1.AND.k(imo,2).EQ.21) GOTO 130
22870 140 CONTINUE
22871C...How should compensation be shared when unequal numbers on the
22872C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22873 nsum=nnxt(1)+nnxt(2)
22874 t1=0
22875 DO 160 msid=4,5
22876C...Total momentum to be compensated on this side
22877 IF (nnxt(msid-3).EQ.0) GOTO 160
22878 ptcx=-(nnxt(msid-3)*ptx)/nsum
22879 ptcy=-(nnxt(msid-3)*pty)/nsum
22880C...RS: compensation supression factor as we go out from parton I.
22881C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22882C...since (for now) MSTP(90) provides enough variability.
22883 rs=0.5d0
22884 fac=(1d0-rs)/(rs*(1-rs**nnxt(msid-3)))
22885 imo=i
22886 150 ida=imo
22887 imo=k(imo,msid)/mstu(5)
22888 IF (imo.EQ.0) GOTO 160
22889 fac=fac*rs
22890 IF (k(imo,2).NE.88) THEN
22891 p(imo,1)=p(imo,1)+fac*ptcx
22892 p(imo,2)=p(imo,2)+fac*ptcy
22893 IF (mcorr.EQ.1.AND.k(imo,2).EQ.21) GOTO 150
22894C...If we reach junction, divide out the kT that would have been
22895C...assigned to the junction on each of its other legs.
22896 ELSE
22897 l1=mod(k(imo,4),mstu(5))
22898 l2=k(imo,5)/mstu(5)
22899 l3=mod(k(imo,5),mstu(5))
22900 p(l1,1)=p(l1,1)+0.5d0*fac*ptcx
22901 p(l1,2)=p(l1,2)+0.5d0*fac*ptcy
22902 p(l2,1)=p(l2,1)+0.5d0*fac*ptcx
22903 p(l2,2)=p(l2,2)+0.5d0*fac*ptcy
22904 p(l3,1)=p(l3,1)+0.5d0*fac*ptcx
22905 p(l3,2)=p(l3,2)+0.5d0*fac*ptcy
22906 p(ida,1)=p(ida,1)-0.5d0*fac*ptcx
22907 p(ida,2)=p(ida,2)-0.5d0*fac*ptcy
22908 ENDIF
22909
22910 160 CONTINUE
22911 ENDIF
22912 170 CONTINUE
22913C...End assignment of kT values to initiators and remnants.
22914 180 CONTINUE
22915
22916C...Check kinematics constraints for non-BR partons.
22917 DO 190 im=1,mint(31)
22918 shat=xmi(1,im)*xmi(2,im)*vint(2)
22919 pt1=sqrt(p(imi(1,im,1),1)**2+p(imi(1,im,1),2)**2)
22920 pt2=sqrt(p(imi(2,im,1),1)**2+p(imi(2,im,1),2)**2)
22921 pt1pt2=p(imi(1,im,1),1)*p(imi(2,im,1),1)
22922 & +p(imi(1,im,1),2)*p(imi(2,im,1),2)
22923 IF (shat.LT.2d0*(pt1*pt2-pt1pt2).AND.ntry.LE.100) THEN
22924 IF(ntry.GE.100) THEN
22925C...Kill this event and start another.
22926 CALL pyerrm(1,
22927 & '(PYMIRM:) No consistent (x,kT) sets found')
22928 mint(51)=1
22929 RETURN
22930 ENDIF
22931 GOTO 100
22932 ENDIF
22933 190 CONTINUE
22934
22935C...Calculate W+ and W- available for combined remnant system.
22936 w(0,1)=vint(1)
22937 w(0,2)=vint(1)
22938 DO 200 im=1,mint(31)
22939 pt2 = (p(imi(1,im,1),1)+p(imi(2,im,1),1))**2
22940 & +(p(imi(1,im,1),2)+p(imi(2,im,1),2))**2
22941 st=xmi(1,im)*xmi(2,im)*vint(2)+pt2
22942 w(0,1)=w(0,1)-sqrt(xmi(1,im)/xmi(2,im)*st)
22943 w(0,2)=w(0,2)-sqrt(xmi(2,im)/xmi(1,im)*st)
22944 200 CONTINUE
22945C...Also store Wrem**2 = W+ * W-
22946 w(0,0)=w(0,1)*w(0,2)
22947
22948 IF ((w(0,0).LT.0d0.OR.w(0,1)+w(0,2).LT.0d0).AND.ntry.LE.100) THEN
22949 IF(ntry.GE.100) THEN
22950C...Kill this event and start another.
22951 CALL pyerrm(1,
22952 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
22953 mint(51)=1
22954 RETURN
22955 ENDIF
22956 GOTO 100
22957 ENDIF
22958
22959C...Assign unscaled x values to partons/hadrons in each of the
22960C...beam remnants and calculate unscaled W+ and W- from them.
22961 ntryx=0
22962 210 ntryx=ntryx+1
22963 DO 280 js=1,2
22964 w(js,1)=0d0
22965 w(js,2)=0d0
22966 DO 270 im=mint(31)+1,nmi(js)
22967 i=imi(js,im,1)
22968 kf=k(i,2)
22969 kfa=iabs(kf)
22970 icomp=imi(js,im,2)
22971
22972C...Skip collapsed gluons and junctions. Reset.
22973 IF (kfa.EQ.21.AND.k(i,1).EQ.14) GOTO 270
22974 IF (kfa.EQ.88) GOTO 270
22975 x=0d0
22976 ivalq(1)=0
22977 ivalq(2)=0
22978 icomq(1)=0
22979 icomq(2)=0
22980
22981C...If gluon then only beam remnant, so takes all.
22982 IF(kfa.EQ.21) THEN
22983 x=1d0
22984C...If valence quark then use parametrized valence distribution.
22985 ELSEIF(kfa.LE.6.AND.icomp.EQ.0) THEN
22986 ivalq(1)=kf
22987C...If companion quark then derive from companion x.
22988 ELSEIF(kfa.LE.6) THEN
22989 icomq(1)=icomp
22990C...If valence diquark then use two parametrized valence distributions.
22991 ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0.AND.
22992 & icomp.EQ.0) THEN
22993 ivalq(1)=isign(kfa/1000,kf)
22994 ivalq(2)=isign(mod(kfa/100,10),kf)
22995C...If valence+sea diquark then combine valence + companion choices.
22996 ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0.AND.
22997 & icomp.LT.mstu(5)) THEN
22998 IF(kfa/1000.EQ.iabs(k(icomp,2))) THEN
22999 ivalq(1)=isign(mod(kfa/100,10),kf)
23000 ELSE
23001 ivalq(1)=isign(kfa/1000,kf)
23002 ENDIF
23003 icomq(1)=icomp
23004C...Extra code: workaround for diquark made out of two sea
23005C...quarks, but where not (yet) ICOMP > MSTU(5).
23006 DO 220 im1=1,mint(31)
23007 IF(imi(js,im1,2).EQ.i.AND.imi(js,im1,1).NE.icomp) THEN
23008 icomq(2)=imi(js,im1,1)
23009 ivalq(1)=0
23010 ENDIF
23011 220 CONTINUE
23012C...If sea diquark then sum of two derived from companion x.
23013 ELSEIF(kfa.GT.1000.AND.mod(kfa/10,10).EQ.0) THEN
23014 icomq(1)=mod(icomp,mstu(5))
23015 icomq(2)=icomp/mstu(5)
23016C...If meson or baryon then use fragmentation function.
23017C...Somewhat arbitrary split into old and new flavour, but OK normally.
23018 ELSE
23019 kfl3=mod(kfa/10,10)
23020 IF(mod(kfa/1000,10).EQ.0) THEN
23021 kfl1=mod(kfa/100,10)
23022 ELSE
23023 kfl1=mod(kfa,10000)-10*kfl3-1
23024 IF(mod(kfa/1000,10).EQ.mod(kfa/100,10).AND.
23025 & mod(kfa,10).EQ.2) kfl1=kfl1+2
23026 ENDIF
23027 pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
23028 CALL pyzdis(kfl1,kfl3,pr,x)
23029 ENDIF
23030
23031 DO 260 iq=1,2
23032C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23033C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23034C...In other baryons combine u and d from proton appropriately.
23035 IF(ivalq(iq).NE.0) THEN
23036 nval=0
23037 IF(kfival(js,1).EQ.ivalq(iq)) nval=nval+1
23038 IF(kfival(js,2).EQ.ivalq(iq)) nval=nval+1
23039 IF(kfival(js,3).EQ.ivalq(iq)) nval=nval+1
23040C...Meson.
23041 IF(kfival(js,3).EQ.0) THEN
23042 mdu=0
23043C...Baryon with three identical quarks: mix u and d forms.
23044 ELSEIF(nval.EQ.3) THEN
23045 mdu=int(pyr(0)+5d0/3d0)
23046C...Baryon, one of two identical quarks: u form.
23047 ELSEIF(nval.EQ.2) THEN
23048 mdu=2
23049C...Baryon with two identical quarks, but not the one picked: d form.
23050 ELSEIF(kfival(js,1).EQ.kfival(js,2).OR.kfival(js,2).EQ.
23051 & kfival(js,3).OR.kfival(js,1).EQ.kfival(js,3)) THEN
23052 mdu=1
23053C...Baryon with three nonidentical quarks: mix u and d forms.
23054 ELSE
23055 mdu=int(pyr(0)+5d0/3d0)
23056 ENDIF
23057 xpow=0.8d0
23058 IF(mdu.EQ.1) xpow=3.5d0
23059 IF(mdu.EQ.2) xpow=2d0
23060 230 xx=pyr(0)**2
23061 IF((1d0-xx)**xpow.LT.pyr(0)) GOTO 230
23062 x=x+xx
23063 ENDIF
23064
23065C...Calculation of x of companion quark.
23066 IF(icomq(iq).NE.0) THEN
23067 xcomp=1d-4
23068 DO 240 im1=1,mint(31)
23069 IF(imi(js,im1,1).EQ.icomq(iq)) xcomp=xmi(js,im1)
23070 240 CONTINUE
23071 npow=max(0,min(4,mstp(87)))
23072 250 xx=xcomp*(1d0/(1d0-pyr(0)*(1d0-xcomp))-1d0)
23073 corr=((1d0-xcomp-xx)/(1d0-xcomp))**npow*
23074 & (xcomp**2+xx**2)/(xcomp+xx)**2
23075 IF(corr.LT.pyr(0)) GOTO 250
23076 x=x+xx
23077 ENDIF
23078 260 CONTINUE
23079
23080C...Optionally enchance x of composite systems (e.g. diquarks)
23081 IF (kfa.GT.100) x=parp(79)*x
23082
23083C...Store x. Also calculate light cone energies of each system.
23084 xmi(js,im)=x
23085 w(js,js)=w(js,js)+x
23086 w(js,3-js)=w(js,3-js)+(p(i,5)**2+p(i,1)**2+p(i,2)**2)/x
23087 270 CONTINUE
23088 w(js,js)=w(js,js)*w(0,js)
23089 w(js,3-js)=w(js,3-js)/w(0,js)
23090 w(js,0)=w(js,1)*w(js,2)
23091 280 CONTINUE
23092
23093C...Check W1 W2 < Wrem (can be done before rescaling, since W
23094C...insensitive to global rescalings of the BR x values).
23095 IF (sqrt(w(1,0))+sqrt(w(2,0)).GT.sqrt(w(0,0)).AND.ntryx.LE.100)
23096 & THEN
23097 GOTO 210
23098 ELSEIF (ntryx.GT.100.AND.ntry.LE.100) THEN
23099 GOTO 100
23100 ELSEIF (ntryx.GT.100) THEN
23101 CALL pyerrm(1,'(PYMIRM:) No consistent (x,kT) sets found')
23102 mint(57)=mint(57)+1
23103 mint(51)=1
23104 RETURN
23105 ENDIF
23106
23107C...Compute x rescaling factors
23108 comtrm=w(0,0)+sqrt(flam(w(0,0),w(1,0),w(2,0)))
23109 r1=(comtrm+w(1,0)-w(2,0))/(2d0*w(1,1)*w(0,2))
23110 r2=(comtrm+w(2,0)-w(1,0))/(2d0*w(2,2)*w(0,1))
23111
23112 IF (r1.LT.0.OR.r2.LT.0) THEN
23113 CALL pyerrm(19,'(PYMIRM:) negative rescaling factors !')
23114 mint(57)=mint(57)+1
23115 mint(51)=1
23116 ENDIF
23117
23118C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23119 w(1,1)=w(1,1)*r1
23120 w(1,2)=w(1,2)/r1
23121 w(2,1)=w(2,1)/r2
23122 w(2,2)=w(2,2)*r2
23123
23124C...Rescale BR x values.
23125 DO 290 im=mint(31)+1,max(nmi(1),nmi(2))
23126 xmi(1,im)=xmi(1,im)*r1
23127 xmi(2,im)=xmi(2,im)*r2
23128 290 CONTINUE
23129
23130C...Now we have a consistent set of x and kT values.
23131C...First set up the initiators and their daughters correctly.
23132 DO 300 im=1,mint(31)
23133 i1=imi(1,im,1)
23134 i2=imi(2,im,1)
23135 st=xmi(1,im)*xmi(2,im)*vint(2)+(p(i1,1)+p(i2,1))**2+
23136 & (p(i1,2)+p(i2,2))**2
23137 pt12=p(i1,1)**2+p(i1,2)**2
23138 pt22=p(i2,1)**2+p(i2,2)**2
23139C...p_z
23140 p(i1,3)=sqrt(flam(st,pt12,pt22)/(4d0*st))
23141 p(i2,3)=-p(i1,3)
23142C...Energies (masses should be zero at this stage)
23143 p(i1,4)=sqrt(pt12+p(i1,3)**2)
23144 p(i2,4)=sqrt(pt22+p(i2,3)**2)
23145
23146C...Transverse 12 system initiator velocity:
23147 vb(1)=(p(i1,1)+p(i2,1))/sqrt(st)
23148 vb(2)=(p(i1,2)+p(i2,2))/sqrt(st)
23149C...Boost to overall initiator system rest frame
23150 CALL pyrobo(i1,i1,0d0,0d0,-vb(1),-vb(2),0d0)
23151 CALL pyrobo(i2,i2,0d0,0d0,-vb(1),-vb(2),0d0)
23152
23153C...Compute phi,theta coordinates of I1 and rotate z axis.
23154 phi=pyangl(p(i1,1),p(i1,2))
23155 the=pyangl(p(i1,3),sqrt(p(i1,1)**2+p(i1,2)**2))
23156 imin=imisep(im-1)+1
23157C...(include documentation lines if MI = 1)
23158 IF (im.EQ.1) imin=mint(83)+5
23159 imax=imisep(im)
23160C...Rotate entire system in phi
23161 CALL pyrobo(imin,imax,0d0,-phi,0d0,0d0,0d0)
23162C...Only rotate 12 system in theta
23163 CALL pyrobo(i1,i1,-the,0d0,0d0,0d0,0d0)
23164 CALL pyrobo(i2,i2,-the,0d0,0d0,0d0,0d0)
23165
23166C...Now boost entire system back to LAB
23167 vb(3)=(xmi(1,im)-xmi(2,im))/(xmi(1,im)+xmi(2,im))
23168 CALL pyrobo(imin,imax,the,phi,vb(1),vb(2),0d0)
23169 CALL pyrobo(imin,imax,0d0,0d0,0d0,0d0,vb(3))
23170
23171 300 CONTINUE
23172
23173
23174C...For the beam remnant partons/hadrons, we only need to set pz and E.
23175 DO 320 js=1,2
23176 DO 310 im=mint(31)+1,nmi(js)
23177 i=imi(js,im,1)
23178C...Skip collapsed gluons and junctions.
23179 IF (k(i,2).EQ.21.AND.k(i,1).EQ.14) GOTO 310
23180 IF (kfa.EQ.88) GOTO 310
23181 rmt2=p(i,5)**2+p(i,1)**2+p(i,2)**2
23182 p(i,4)=0.5d0*(xmi(js,im)*w(0,js)+rmt2/(xmi(js,im)*w(0,js)))
23183 p(i,3)=0.5d0*(xmi(js,im)*w(0,js)-rmt2/(xmi(js,im)*w(0,js)))
23184 IF (js.EQ.2) p(i,3)=-p(i,3)
23185 310 CONTINUE
23186 320 CONTINUE
23187
23188
23189C...Documentation lines
23190 DO 340 js=1,2
23191 in=mint(83)+js+2
23192 io=imi(js,1,1)
23193 k(in,1)=21
23194 k(in,2)=k(io,2)
23195 k(in,3)=mint(83)+js
23196 k(in,4)=0
23197 k(in,5)=0
23198 DO 330 j=1,5
23199 p(in,j)=p(io,j)
23200 v(in,j)=v(io,j)
23201 330 CONTINUE
23202 mct(in,1)=mct(io,1)
23203 mct(in,2)=mct(io,2)
23204 340 CONTINUE
23205
23206C...Final state colour reconnections.
23207 IF (mstp(95).NE.1.OR.mint(31).LE.1) GOTO 380
23208
23209C...Number of colour tags for which a recoupling will be tried.
23210 ntot=nct
23211C...Number of recouplings to try
23212 mint(34)=0
23213 nrecp=0
23214 niter=0
23215 350 nrecp=mint(34)
23216 niter=niter+1
23217 iiter=0
23218 360 iiter=iiter+1
23219 IF (iiter.LE.parp(78)*ntot) THEN
23220C...Select two colour tags at random
23221C...NB: jj strings do not have colour tags assigned to them,
23222C...thus they are as yet not affected by anything done here.
23223 jct=pyr(0)*nct+1
23224 kct=mod(int(jct+pyr(0)*nct),nct)+1
23225 ij1=0
23226 ij2=0
23227 ik1=0
23228 ik2=0
23229C...Find final state partons with this (anti)colour
23230 DO 370 i=mint(84)+1,n
23231 IF (k(i,1).EQ.3) THEN
23232 IF (mct(i,1).EQ.jct) ij1=i
23233 IF (mct(i,2).EQ.jct) ij2=i
23234 IF (mct(i,1).EQ.kct) ik1=i
23235 IF (mct(i,2).EQ.kct) ik2=i
23236 ENDIF
23237 370 CONTINUE
23238C...Only consider recouplings not involving junctions for now.
23239 IF (ij1.EQ.0.OR.ij2.EQ.0.OR.ik1.EQ.0.OR.ik2.EQ.0) GOTO 360
23240
23241 rlo=2d0*four(ij1,ij2)*2d0*four(ik1,ik2)
23242 rln=2d0*four(ij1,ik2)*2d0*four(ik1,ij2)
23243 IF (rln.LT.rlo.AND.mct(ij2,1).NE.kct.AND.mct(ik2,1).NE.jct) THEN
23244 mct(ij2,2)=kct
23245 mct(ik2,2)=jct
23246C...Count up number of reconnections
23247 mint(34)=mint(34)+1
23248 ENDIF
23249 IF (mint(34).LE.1000) THEN
23250 GOTO 360
23251 ELSE
23252 CALL pyerrm(4,'(PYMIRM:) caught in infinite loop')
23253 GOTO 380
23254 ENDIF
23255 ENDIF
23256 IF (nrecp.LT.mint(34)) GOTO 350
23257
23258C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23259 380 mint(33)=1
23260
23261 RETURN
23262 END
23263
23264C*********************************************************************
23265
23266C...PYFSCR
23267C...Performs colour annealing.
23268C...MSTP(95) : CR Type
23269C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23270C... = 2 : Type I(no gg loops); hadron-hadron only
23271C... = 3 : Type I(no gg loops); all beams
23272C... = 4 : Type II(gg loops) ; hadron-hadron only
23273C... = 5 : Type II(gg loops) ; all beams
23274C... = 6 : Type S ; hadron-hadron only
23275C... = 7 : Type S ; all beams
23276C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23277C...Type S is driven by starting only from free triplets, not octets.
23278C...A string piece remains unchanged with probability
23279C... PKEEP = (1-PARP(78))**N
23280C...This scaling corresponds to each string piece having to go through
23281C...N other ones, each with probability PARP(78) for reconnection, where
23282C...N is here chosen simply as the number of multiple interactions,
23283C...for a rough scaling with the general level of activity.
23284
23285 SUBROUTINE pyfscr(IP)
23286C...Double precision and integer declarations.
23287 IMPLICIT DOUBLE PRECISION(a-h, o-z)
23288 INTEGER PYK,PYCHGE,PYCOMP
23289C...Commonblocks.
23290 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23291 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23292 common/pypars/mstp(200),parp(200),msti(200),pari(200)
23293 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
23294 common/pyint1/mint(400),vint(400)
23295C...The common block of colour tags.
23296 common/pyctag/nct,mct(4000,2)
23297 SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/,/pyctag/,
23298 &/pypars/
23299C...MCN: Temporary storage of new colour tags
23300 INTEGER MCN(4000,2)
23301C...Arrays for storing color string lengths
23302 INTEGER ICR(4000),MSCR(4000)
23303 INTEGER IOPT(4000)
23304 DOUBLE PRECISION RLOPTC(4000)
23305
23306C...Function to give four-product.
23307 four(i,j)=p(i,4)*p(j,4)
23308 & -p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)
23309
23310C...Check valid range of MSTP(95), local copy
23311 IF (mstp(95).LE.1.OR.mstp(95).GE.10) RETURN
23312 mstp95=mod(mstp(95),10)
23313C...Set whether CR allowed inside resonance systems or not
23314C...(not implemented yet)
23315C MRESCR=1
23316C IF (MSTP(95).GE.10) MRESCR=0
23317
23318C...Check whether colour tags already defined
23319 IF (mint(33).EQ.0) THEN
23320C...Erase any existing colour tags for this event
23321 DO 100 i=1,n
23322 mct(i,1)=0
23323 mct(i,2)=0
23324 100 CONTINUE
23325C...Create colour tags for this event
23326 DO 120 i=1,n
23327 IF (k(i,1).EQ.3) THEN
23328 DO 110 kcs=4,5
23329 kcsin=kcs
23330 IF (mct(i,kcsin-3).EQ.0) THEN
23331 CALL pycttr(i,kcsin,i)
23332 ENDIF
23333 110 CONTINUE
23334 ENDIF
23335 120 CONTINUE
23336C...Instruct PYPREP to use colour tags
23337 mint(33)=1
23338 ENDIF
23339
23340C...For MSTP(95) even, only apply to hadron-hadron
23341 ka1=iabs(mint(11))
23342 ka2=iabs(mint(12))
23343 IF (mod(mstp(95),2).EQ.0.AND.(ka1.LT.100.OR.ka2.LT.100)) GOTO 9999
23344
23345C...Initialize new tag array (but do not delete old yet)
23346 lct=nct
23347 DO 130 i=max(1,ip),n
23348 mcn(i,1)=0
23349 mcn(i,2)=0
23350 130 CONTINUE
23351
23352C...For each final-state dipole, check whether string should be
23353C...preserved.
23354 ncr=0
23355 ia=0
23356 ic=0
23357
23358 DO 150 ict=1,nct
23359 ia=0
23360 ic=0
23361 DO 140 i=max(1,ip),n
23362 IF (k(i,1).EQ.3.AND.mct(i,1).EQ.ict) ic=i
23363 IF (k(i,1).EQ.3.AND.mct(i,2).EQ.ict) ia=i
23364 140 CONTINUE
23365 IF (ic.NE.0.AND.ia.NE.0) THEN
23366 crmodf=1d0
23367C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23368C...(so far ignores the possibility that the whole "muck" may be moving.)
23369 IF (parp(77).GT.0d0) THEN
23370 pt2str=(p(ia,1)+p(ic,1))**2+(p(ia,2)+p(ic,2))**2
23371C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23372 IF (ka1.LT.100.AND.ka2.LT.100) THEN
23373 p2str = pt2str + (p(ia,3)+p(ic,3))**2
23374 ELSE
23375 p2str = 3d0/2d0 * pt2str
23376 ENDIF
23377 rm2str=(p(ia,4)+p(ic,4))**2-(p(ia,3)+p(ic,3))**2-pt2str
23378 rm2str=max(rm2str,pmas(pycomp(111),1)**2)
23379C...Estimate number of particles ~ log(M2), cut off at 1.
23380 rlogm2=max(1d0,log(rm2str))
23381 p2avg=p2str/rlogm2
23382C...Supress reconnection probability by 1/(1+P77*P2AVG)
23383 crmodf=1d0/(1d0+parp(77)**2*p2avg)
23384 ENDIF
23385 pkeep=(1d0-parp(78)*crmodf)**mint(31)
23386 IF (pyr(0).LE.pkeep) THEN
23387 lct=lct+1
23388 mcn(ic,1)=lct
23389 mcn(ia,2)=lct
23390 ELSE
23391C...Add coloured parton
23392 ncr=ncr+1
23393 icr(ncr)=ic
23394 mscr(ncr)=1
23395 iopt(ncr)=0
23396 rloptc(ncr)=1d19
23397C...Add anti-coloured parton
23398 ncr=ncr+1
23399 icr(ncr)=ia
23400 mscr(ncr)=2
23401 iopt(ncr)=0
23402 rloptc(ncr)=1d19
23403 ENDIF
23404 ENDIF
23405 150 CONTINUE
23406
23407C...Skip if there is only one possibility
23408 IF (ncr.LE.2) THEN
23409 GOTO 9999
23410 ENDIF
23411
23412C...Reorder, so ordered in I (in order to correspond to old algorithm)
23413 nloop=0
23414 151 nloop=nloop+1
23415 mord=1
23416 DO 155 ic1=1,ncr-1
23417 i1=icr(ic1)
23418 i2=icr(ic1+1)
23419 IF (i1.GT.i2) THEN
23420 it=i1
23421 mst=mscr(ic1)
23422 icr(ic1)=i2
23423 mscr(ic1)=mscr(ic1+1)
23424 icr(ic1+1)=it
23425 mscr(ic1+1)=mst
23426 mord=0
23427 ENDIF
23428 155 CONTINUE
23429C...Max do 1000 reordering loops
23430 IF (mord.EQ.0.AND.nloop.LE.1000) GOTO 151
23431
23432C...Loop over CR partons
23433C...(Ignore junctions for now.)
23434 nloop=0
23435 160 nloop=nloop+1
23436 rlmax=0d0
23437 icrmax=0
23438C...Loop over coloured partons
23439 DO 230 ic1=1,ncr
23440C...Retrieve parton Event Record index and Colour Side
23441 i=icr(ic1)
23442 msi=mscr(ic1)
23443C...Skip already connected partons
23444 IF (mcn(i,msi).NE.0) GOTO 230
23445C...Shorthand for colour charge
23446 mci=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
23447C...For Seattle algorithm, only start from partons with one dangling
23448C...colour tag
23449 IF (mstp(95).GE.6.AND.mstp(95).LE.9) THEN
23450 IF (mci.EQ.2.AND.mcn(i,1).EQ.0.AND.mcn(i,2).EQ.0) GOTO 230
23451 ENDIF
23452C...Retrieve saved optimal partner
23453 io=iopt(ic1)
23454 IF (io.NE.0) THEN
23455C...Reject saved optimal partner if latter is now connected
23456C...(Also reject if using model S1, since saved partner may
23457C...now give rise to gg loop.)
23458 IF (mcn(io,3-msi).NE.0.OR.mstp(95).LE.3) THEN
23459 iopt(ic1)=0
23460 rloptc(ic1)=1d19
23461 ENDIF
23462 ENDIF
23463 rlopt=rloptc(ic1)
23464C...Search for new optimal partner if necessary
23465 IF (iopt(ic1).EQ.0) THEN
23466 mbropt=0
23467 mggopt=0
23468 rlopt=1d19
23469C...Loop over partons you can connect to
23470 DO 210 ic2=1,ncr
23471 j=icr(ic2)
23472 msj=mscr(ic2)
23473C...Skip if already connected
23474 IF (mcn(j,msj).NE.0) GOTO 210
23475C...Skip if this not colour-anticolour pair
23476 IF (msi.EQ.msj) GOTO 210
23477C...And do not let gluons connect to themselves
23478 IF (i.EQ.j) GOTO 210
23479C...Suppress direct connections between partons in same Beam Remnant
23480 mbrstr=0
23481 IF (k(i,3).LE.2.AND.k(i,3).GE.1.AND.k(i,3).EQ.k(j,3))
23482 & mbrstr=1
23483C...Shorthand for colour charge
23484 mcj=kchg(pycomp(k(j,2)),2)*isign(1,k(j,2))
23485C...Check for gluon loops
23486 mggstr=0
23487 IF (mcj.EQ.2.AND.mci.EQ.2) THEN
23488 IF (mcn(i,2).EQ.mcn(j,1).AND.mstp(95).LE.3.AND.
23489 & mcn(i,2).NE.0) mggstr=1
23490 ENDIF
23491C...Save connection with smallest lambda measure
23492 rl=four(i,j)
23493C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23494 IF (mstp(95).GE.7.AND.mstp(95).LE.8) THEN
23495 IF (k(i,2).EQ.21) rl=0.5d0*rl
23496 IF (k(j,2).EQ.21) rl=0.5d0*rl
23497 ENDIF
23498C...If best so far was a BR string and this is not, also save.
23499C...If best so far was a gg string and this is not, also save.
23500C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23501C...string with a small Lambda measure as the last step, this connection
23502C...will be saved regardless of whether other possibilities existed.
23503C...I.e., there should really be a check whether another possibility has
23504C...already been found, but since these models are now actively in use
23505C...and uncertainties are anyway large, the algorithm is left as it is.
23506C...(correction --> Pythia 8 ?)
23507 IF (rl.LT.rlopt.OR.(rl.EQ.rlopt.AND.pyr(0).LE.0.5d0)
23508 & .OR.(mbropt.EQ.1.AND.mbrstr.EQ.0)
23509 & .OR.(mggopt.EQ.1.AND.mggstr.EQ.0)) THEN
23510 rlopt=rl
23511 rloptc(ic1)=rlopt
23512 iopt(ic1)=j
23513 mbropt=mbrstr
23514 mggopt=mggstr
23515 ENDIF
23516 210 CONTINUE
23517 ENDIF
23518 IF (iopt(ic1).NE.0) THEN
23519C...Save pair with largest RLOPT so far
23520 IF (rlopt.GE.rlmax) THEN
23521 icrmax=ic1
23522 rlmax=rlopt
23523 ENDIF
23524 ENDIF
23525 230 CONTINUE
23526C...Save and iterate
23527 IF (icrmax.GT.0) THEN
23528 lct=lct+1
23529 ilmax=icr(icrmax)
23530 jlmax=iopt(icrmax)
23531 icmax=mscr(icrmax)
23532 jcmax=3-icmax
23533 mcn(ilmax,icmax)=lct
23534 mcn(jlmax,jcmax)=lct
23535 IF (nloop.LE.2*(n-ip)) THEN
23536 GOTO 160
23537 ELSE
23538 CALL pyerrm(31,' PYFSCR: infinite loop in color annealing')
23539 CALL pystop(11)
23540 ENDIF
23541 ELSE
23542C...Save and exit. First check for leftover gluon(s)
23543 DO 260 i=max(1,ip),n
23544C...Check colour charge
23545 mci=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))
23546 IF (k(i,1).NE.3.OR.mci.NE.2) GOTO 260
23547 IF(mcn(i,1).EQ.0.AND.mcn(i,2).EQ.0) THEN
23548C...Decide where to put left-over gluon (minimal insertion)
23549 ilmax=0
23550 rlmax=1d19
23551 DO 250 kct=nct+1,lct
23552 DO 240 it=max(1,ip),n
23553 IF (it.EQ.i.OR.k(it,1).NE.3) GOTO 240
23554 IF (mcn(it,1).EQ.kct) ic=it
23555 IF (mcn(it,2).EQ.kct) ia=it
23556 240 CONTINUE
23557 rl=four(ic,i)*four(ia,i)
23558 IF (rl.LT.rlmax) THEN
23559 rlmax=rl
23560 icmax=ic
23561 iamax=ia
23562 ENDIF
23563 250 CONTINUE
23564 lct=lct+1
23565 mcn(i,1)=mcn(icmax,1)
23566 mcn(i,2)=lct
23567 mcn(icmax,1)=lct
23568 ENDIF
23569 260 CONTINUE
23570C...Here we need to loop over entire event.
23571 DO 270 iz=max(1,ip),n
23572C...Do not erase parton shower colour history
23573 IF (k(iz,1).NE.3) GOTO 270
23574C...Check colour charge
23575 mci=kchg(pycomp(k(iz,2)),2)*isign(1,k(iz,2))
23576 IF (mci.EQ.0) GOTO 270
23577 IF (mcn(iz,1).NE.0) mct(iz,1)=mcn(iz,1)
23578 IF (mcn(iz,2).NE.0) mct(iz,2)=mcn(iz,2)
23579 270 CONTINUE
23580 ENDIF
23581
23582 9999 RETURN
23583 END
23584
23585C*********************************************************************
23586
23587C...PYDIFF
23588C...Handles diffractive and elastic scattering.
23589
23590 SUBROUTINE pydiff
23591
23592C...Double precision and integer declarations.
23593 IMPLICIT DOUBLE PRECISION(a-h, o-z)
23594 IMPLICIT INTEGER(I-N)
23595 INTEGER PYK,PYCHGE,PYCOMP
23596C...Commonblocks.
23597 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23598 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23599 common/pypars/mstp(200),parp(200),msti(200),pari(200)
23600 common/pyint1/mint(400),vint(400)
23601 SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/
23602
23603C...Reset K, P and V vectors. Store incoming particles.
23604 DO 110 jt=1,mstp(126)+10
23605 i=mint(83)+jt
23606 DO 100 j=1,5
23607 k(i,j)=0
23608 p(i,j)=0d0
23609 v(i,j)=0d0
23610 100 CONTINUE
23611 110 CONTINUE
23612 n=mint(84)
23613 mint(3)=0
23614 mint(21)=0
23615 mint(22)=0
23616 mint(23)=0
23617 mint(24)=0
23618 mint(4)=4
23619 DO 130 jt=1,2
23620 i=mint(83)+jt
23621 k(i,1)=21
23622 k(i,2)=mint(10+jt)
23623 DO 120 j=1,5
23624 p(i,j)=vint(285+5*jt+j)
23625 120 CONTINUE
23626 130 CONTINUE
23627 mint(6)=2
23628
23629C...Subprocess; kinematics.
23630 sqlam=(vint(2)-vint(63)-vint(64))**2-4d0*vint(63)*vint(64)
23631 pz=sqrt(sqlam)/(2d0*vint(1))
23632 DO 200 jt=1,2
23633 i=mint(83)+jt
23634 pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2d0*vint(1))
23635 kfh=mint(102+jt)
23636
23637C...Elastically scattered particle. (Except elastic GVMD states.)
23638 IF(mint(16+jt).LE.0.AND.(mint(10+jt).NE.22.OR.
23639 & mint(106+jt).NE.3)) THEN
23640 n=n+1
23641 k(n,1)=1
23642 k(n,2)=kfh
23643 k(n,3)=i+2
23644 p(n,3)=pz*(-1)**(jt+1)
23645 p(n,4)=pe
23646 p(n,5)=sqrt(vint(62+jt))
23647
23648C...Decay rho from elastic scattering of gamma with sin**2(theta)
23649C...distribution of decay products (in rho rest frame).
23650 IF(kfh.EQ.113.AND.mint(10+jt).EQ.22.AND.mstp(102).EQ.1) THEN
23651 nsav=n
23652 dbetaz=p(n,3)/sqrt(p(n,3)**2+p(n,5)**2)
23653 p(n,3)=0d0
23654 p(n,4)=p(n,5)
23655 CALL pydecy(nsav)
23656 IF(n.EQ.nsav+2.AND.iabs(k(nsav+1,2)).EQ.211) THEN
23657 phi=pyangl(p(nsav+1,1),p(nsav+1,2))
23658 CALL pyrobo(nsav+1,nsav+2,0d0,-phi,0d0,0d0,0d0)
23659 the=pyangl(p(nsav+1,3),p(nsav+1,1))
23660 CALL pyrobo(nsav+1,nsav+2,-the,0d0,0d0,0d0,0d0)
23661 140 cthe=2d0*pyr(0)-1d0
23662 IF(1d0-cthe**2.LT.pyr(0)) GOTO 140
23663 CALL pyrobo(nsav+1,nsav+2,acos(cthe),phi,0d0,0d0,0d0)
23664 ENDIF
23665 CALL pyrobo(nsav,nsav+2,0d0,0d0,0d0,0d0,dbetaz)
23666 ENDIF
23667
23668C...Diffracted particle: low-mass system to two particles.
23669 ELSEIF(vint(62+jt).LT.(vint(66+jt)+parp(103))**2) THEN
23670 n=n+2
23671 k(n-1,1)=1
23672 k(n,1)=1
23673 k(n-1,3)=i+2
23674 k(n,3)=i+2
23675 pmmas=sqrt(vint(62+jt))
23676 ntry=0
23677 150 ntry=ntry+1
23678 IF(ntry.LT.20) THEN
23679 mint(105)=mint(102+jt)
23680 mint(109)=mint(106+jt)
23681 CALL pyspli(kfh,21,kfl1,kfl2)
23682 CALL pykfdi(kfl1,0,kfl3,kf1)
23683 IF(kf1.EQ.0) GOTO 150
23684 CALL pykfdi(kfl2,-kfl3,kfldum,kf2)
23685 IF(kf2.EQ.0) GOTO 150
23686 ELSE
23687 kf1=kfh
23688 kf2=111
23689 ENDIF
23690 pm1=pymass(kf1)
23691 pm2=pymass(kf2)
23692 IF(pm1+pm2+parj(64).GT.pmmas) GOTO 150
23693 k(n-1,2)=kf1
23694 k(n,2)=kf2
23695 p(n-1,5)=pm1
23696 p(n,5)=pm2
23697 pzp=sqrt(max(0d0,(pmmas**2-pm1**2-pm2**2)**2-
23698 & 4d0*pm1**2*pm2**2))/(2d0*pmmas)
23699 p(n-1,3)=pzp
23700 p(n,3)=-pzp
23701 p(n-1,4)=sqrt(pm1**2+pzp**2)
23702 p(n,4)=sqrt(pm2**2+pzp**2)
23703 CALL pyrobo(n-1,n,acos(2d0*pyr(0)-1d0),paru(2)*pyr(0),
23704 & 0d0,0d0,0d0)
23705 dbetaz=pz*(-1)**(jt+1)/sqrt(pz**2+pmmas**2)
23706 CALL pyrobo(n-1,n,0d0,0d0,0d0,0d0,dbetaz)
23707
23708C...Diffracted particle: valence quark kicked out.
23709 ELSEIF(mstp(101).EQ.1.OR.(mstp(101).EQ.3.AND.pyr(0).LT.
23710 & parp(101))) THEN
23711 n=n+2
23712 k(n-1,1)=2
23713 k(n,1)=1
23714 k(n-1,3)=i+2
23715 k(n,3)=i+2
23716 mint(105)=mint(102+jt)
23717 mint(109)=mint(106+jt)
23718 CALL pyspli(kfh,21,k(n,2),k(n-1,2))
23719 p(n-1,5)=pymass(k(n-1,2))
23720 p(n,5)=pymass(k(n,2))
23721 sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-
23722 & 4d0*p(n-1,5)**2*p(n,5)**2
23723 p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-
23724 & p(n,5)**2))/(2d0*vint(62+jt))*(-1)**(jt+1)
23725 p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)
23726 p(n,3)=pz*(-1)**(jt+1)-p(n-1,3)
23727 p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
23728
23729C...Diffracted particle: gluon kicked out.
23730 ELSE
23731 n=n+3
23732 k(n-2,1)=2
23733 k(n-1,1)=2
23734 k(n,1)=1
23735 k(n-2,3)=i+2
23736 k(n-1,3)=i+2
23737 k(n,3)=i+2
23738 mint(105)=mint(102+jt)
23739 mint(109)=mint(106+jt)
23740 CALL pyspli(kfh,21,k(n,2),k(n-2,2))
23741 k(n-1,2)=21
23742 p(n-2,5)=pymass(k(n-2,2))
23743 p(n-1,5)=0d0
23744 p(n,5)=pymass(k(n,2))
23745C...Energy distribution for particle into two jets.
23746 160 imb=1
23747 IF(mod(kfh/1000,10).NE.0) imb=2
23748 chik=parp(92+2*imb)
23749 IF(mstp(92).LE.1) THEN
23750 IF(imb.EQ.1) chi=pyr(0)
23751 IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
23752 ELSEIF(mstp(92).EQ.2) THEN
23753 chi=1d0-pyr(0)**(1d0/(1d0+chik))
23754 ELSEIF(mstp(92).EQ.3) THEN
23755 cut=2d0*0.3d0/vint(1)
23756 170 chi=pyr(0)**2
23757 IF((chi**2/(chi**2+cut**2))**0.25d0*(1d0-chi)**chik.LT.
23758 & pyr(0)) GOTO 170
23759 ELSEIF(mstp(92).EQ.4) THEN
23760 cut=2d0*0.3d0/vint(1)
23761 cutr=(1d0+sqrt(1d0+cut**2))/cut
23762 180 chir=cut*cutr**pyr(0)
23763 chi=(chir**2-cut**2)/(2d0*chir)
23764 IF((1d0-chi)**chik.LT.pyr(0)) GOTO 180
23765 ELSE
23766 cut=2d0*0.3d0/vint(1)
23767 cuta=cut**(1d0-parp(98))
23768 cutb=(1d0+cut)**(1d0-parp(98))
23769 190 chi=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))
23770 IF(((chi+cut)**2/(2d0*(chi**2+cut**2)))**
23771 & (0.5d0*parp(98))*(1d0-chi)**chik.LT.pyr(0)) GOTO 190
23772 ENDIF
23773 IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1d0-p(n-2,5)**2/
23774 & vint(62+jt)) GOTO 160
23775 sqm=p(n-2,5)**2/(1d0-chi)+p(n,5)**2/chi
23776 pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/
23777 & (2d0*vint(62+jt))
23778 pei=sqrt(pzi**2+sqm)
23779 pqqp=(1d0-chi)*(pei+pzi)
23780 p(n-2,3)=0.5d0*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)
23781 p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)
23782 p(n-1,4)=0.5d0*(vint(62+jt)-sqm)/(pei+pzi)
23783 p(n-1,3)=p(n-1,4)*(-1)**jt
23784 p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)
23785 p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)
23786 ENDIF
23787
23788C...Documentation lines.
23789 k(i+2,1)=21
23790 IF(mint(16+jt).EQ.0) k(i+2,2)=kfh
23791 IF(mint(16+jt).NE.0.OR.(mint(10+jt).EQ.22.AND.
23792 & mint(106+jt).EQ.3)) k(i+2,2)=isign(9900000,kfh)+10*(kfh/10)
23793 k(i+2,3)=i
23794 p(i+2,3)=pz*(-1)**(jt+1)
23795 p(i+2,4)=pe
23796 p(i+2,5)=sqrt(vint(62+jt))
23797 200 CONTINUE
23798
23799C...Rotate outgoing partons/particles using cos(theta).
23800 IF(vint(23).LT.0.9d0) THEN
23801 CALL pyrobo(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0)
23802 ELSE
23803 CALL pyrobo(mint(83)+3,n,asin(vint(59)),vint(24),0d0,0d0,0d0)
23804 ENDIF
23805
23806 RETURN
23807 END
23808
23809C*********************************************************************
23810
23811C...PYDISG
23812C...Set up a DIS process as gamma* + f -> f, with beam remnant
23813C...and showering added consecutively. Photon flux by the PYGAGA
23814C...routine (if at all).
23815
23816 SUBROUTINE pydisg
23817
23818C...Double precision and integer declarations.
23819 IMPLICIT DOUBLE PRECISION(a-h, o-z)
23820 IMPLICIT INTEGER(I-N)
23821 INTEGER PYK,PYCHGE,PYCOMP
23822C...Parameter statement to help give large particle numbers.
23823 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
23824 &kexcit=4000000,kdimen=5000000)
23825C...Commonblocks.
23826 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
23827 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
23828 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
23829 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
23830 common/pypars/mstp(200),parp(200),msti(200),pari(200)
23831 common/pyint1/mint(400),vint(400)
23832 SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/
23833C...Local arrays.
23834 dimension pms(4)
23835
23836C...Choice of subprocess, number of documentation lines
23837 idoc=7
23838 mint(3)=idoc-6
23839 mint(4)=idoc
23840 ipu1=mint(84)+1
23841 ipu2=mint(84)+2
23842 ipu3=mint(84)+3
23843 iside=1
23844 IF(mint(107).EQ.4) iside=2
23845
23846C...Reset K, P and V vectors. Store incoming particles
23847 DO 110 jt=1,mstp(126)+20
23848 i=mint(83)+jt
23849 DO 100 j=1,5
23850 k(i,j)=0
23851 p(i,j)=0d0
23852 v(i,j)=0d0
23853 100 CONTINUE
23854 110 CONTINUE
23855 DO 130 jt=1,2
23856 i=mint(83)+jt
23857 k(i,1)=21
23858 k(i,2)=mint(10+jt)
23859 DO 120 j=1,5
23860 p(i,j)=vint(285+5*jt+j)
23861 120 CONTINUE
23862 130 CONTINUE
23863 mint(6)=2
23864
23865C...Store incoming partons in hadronic CM-frame
23866 DO 140 jt=1,2
23867 i=mint(84)+jt
23868 k(i,1)=14
23869 k(i,2)=mint(14+jt)
23870 k(i,3)=mint(83)+2+jt
23871 140 CONTINUE
23872 IF(mint(15).EQ.22) THEN
23873 p(mint(84)+1,3)=0.5d0*(vint(1)+vint(307)/vint(1))
23874 p(mint(84)+1,4)=0.5d0*(vint(1)-vint(307)/vint(1))
23875 p(mint(84)+1,5)=-sqrt(vint(307))
23876 p(mint(84)+2,3)=-0.5d0*vint(307)/vint(1)
23877 p(mint(84)+2,4)=0.5d0*vint(307)/vint(1)
23878 kfres=mint(16)
23879 iside=2
23880 ELSE
23881 p(mint(84)+1,3)=0.5d0*vint(308)/vint(1)
23882 p(mint(84)+1,4)=0.5d0*vint(308)/vint(1)
23883 p(mint(84)+2,3)=-0.5d0*(vint(1)+vint(308)/vint(1))
23884 p(mint(84)+2,4)=0.5d0*(vint(1)-vint(308)/vint(1))
23885 p(mint(84)+1,5)=-sqrt(vint(308))
23886 kfres=mint(15)
23887 iside=1
23888 ENDIF
23889 sidesg=(-1d0)**(iside-1)
23890
23891C...Copy incoming partons to documentation lines.
23892 DO 170 jt=1,2
23893 i1=mint(83)+4+jt
23894 i2=mint(84)+jt
23895 k(i1,1)=21
23896 k(i1,2)=k(i2,2)
23897 k(i1,3)=i1-2
23898 DO 150 j=1,5
23899 p(i1,j)=p(i2,j)
23900 150 CONTINUE
23901
23902C...Second copy for partons before ISR shower, since no such.
23903 i1=mint(83)+2+jt
23904 k(i1,1)=21
23905 k(i1,2)=k(i2,2)
23906 k(i1,3)=i1-2
23907 DO 160 j=1,5
23908 p(i1,j)=p(i2,j)
23909 160 CONTINUE
23910 170 CONTINUE
23911
23912C...Define initial partons.
23913 ntry=0
23914 180 ntry=ntry+1
23915 IF(ntry.GT.100) THEN
23916 mint(51)=1
23917 RETURN
23918 ENDIF
23919
23920C...Scattered quark in hadronic CM frame.
23921 i=mint(83)+7
23922 k(ipu3,1)=3
23923 k(ipu3,2)=kfres
23924 k(ipu3,3)=i
23925 p(ipu3,5)=pymass(kfres)
23926 p(ipu3,3)=p(ipu1,3)+p(ipu2,3)
23927 p(ipu3,4)=p(ipu1,4)+p(ipu2,4)
23928 p(ipu3,5)=0d0
23929 k(i,1)=21
23930 k(i,2)=kfres
23931 k(i,3)=mint(83)+4+iside
23932 p(i,3)=p(ipu3,3)
23933 p(i,4)=p(ipu3,4)
23934 p(i,5)=p(ipu3,5)
23935 n=ipu3
23936 mint(21)=kfres
23937 mint(22)=0
23938
23939C...No primordial kT, or chosen according to truncated Gaussian or
23940C...exponential, or (for photon) predetermined or power law.
23941 190 IF(mint(40+iside).EQ.2.AND.mint(10+iside).NE.22) THEN
23942 IF(mstp(91).LE.0) THEN
23943 pt=0d0
23944 ELSEIF(mstp(91).EQ.1) THEN
23945 pt=parp(91)*sqrt(-log(pyr(0)))
23946 ELSE
23947 rpt1=pyr(0)
23948 rpt2=pyr(0)
23949 pt=-parp(92)*log(rpt1*rpt2)
23950 ENDIF
23951 IF(pt.GT.parp(93)) GOTO 190
23952 ELSEIF(mint(106+iside).EQ.3) THEN
23953 pta=sqrt(vint(282+iside))
23954 ptb=0d0
23955 IF(mstp(66).EQ.5.AND.mstp(93).EQ.1) THEN
23956 ptb=parp(99)*sqrt(-log(pyr(0)))
23957 ELSEIF(mstp(66).EQ.5.AND.mstp(93).EQ.2) THEN
23958 rpt1=pyr(0)
23959 rpt2=pyr(0)
23960 ptb=-parp(99)*log(rpt1*rpt2)
23961 ENDIF
23962 IF(ptb.GT.parp(100)) GOTO 190
23963 pt=sqrt(pta**2+ptb**2+2d0*pta*ptb*cos(paru(2)*pyr(0)))
23964 IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)
23965 ELSEIF(iabs(mint(14+iside)).LE.8.OR.mint(14+iside).EQ.21) THEN
23966 IF(mstp(93).LE.0) THEN
23967 pt=0d0
23968 ELSEIF(mstp(93).EQ.1) THEN
23969 pt=parp(99)*sqrt(-log(pyr(0)))
23970 ELSEIF(mstp(93).EQ.2) THEN
23971 rpt1=pyr(0)
23972 rpt2=pyr(0)
23973 pt=-parp(99)*log(rpt1*rpt2)
23974 ELSEIF(mstp(93).EQ.3) THEN
23975 ha=parp(99)**2
23976 hb=parp(100)**2
23977 pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))
23978 ELSE
23979 ha=parp(99)**2
23980 hb=parp(100)**2
23981 IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)
23982 pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))
23983 ENDIF
23984 IF(pt.GT.parp(100)) GOTO 190
23985 ELSE
23986 pt=0d0
23987 ENDIF
23988 vint(156+iside)=pt
23989 phi=paru(2)*pyr(0)
23990 p(ipu3,1)=pt*cos(phi)
23991 p(ipu3,2)=pt*sin(phi)
23992 p(ipu3,4)=sqrt(p(ipu3,5)**2+pt**2+p(ipu3,3)**2)
23993 pms(3-iside)=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2
23994 pcp=p(ipu3,4)+abs(p(ipu3,3))
23995
23996C...Find one or two beam remnants.
23997 mint(105)=mint(102+iside)
23998 mint(109)=mint(106+iside)
23999 CALL pyspli(mint(10+iside),mint(12+iside),kflch,kflsp)
24000 IF(mint(51).NE.0) THEN
24001 mint(51)=0
24002 GOTO 180
24003 ENDIF
24004
24005C...Store first remnant parton, with colour info and kinematics.
24006 i=n+1
24007 k(i,1)=1
24008 k(i,2)=kflsp
24009 k(i,3)=mint(83)+iside
24010 p(i,5)=pymass(k(i,2))
24011 kcol=kchg(pycomp(kflsp),2)
24012 IF(kcol.NE.0) THEN
24013 k(i,1)=3
24014 kfls=(3-kcol*isign(1,kflsp))/2
24015 k(i,kfls+3)=mstu(5)*ipu3
24016 k(ipu3,6-kfls)=mstu(5)*i
24017 icolr=i
24018 ENDIF
24019 IF(kflch.EQ.0) THEN
24020 p(i,1)=-p(ipu3,1)
24021 p(i,2)=-p(ipu3,2)
24022 pms(iside)=p(i,5)**2+p(i,1)**2+p(i,2)**2
24023 p(i,3)=-p(ipu3,3)
24024 p(i,4)=sqrt(pms(iside)+p(i,3)**2)
24025 prp=p(i,4)+abs(p(i,3))
24026
24027C...When extra remnant parton or hadron: store extra remnant.
24028 ELSE
24029 i=i+1
24030 k(i,1)=1
24031 k(i,2)=kflch
24032 k(i,3)=mint(83)+iside
24033 p(i,5)=pymass(k(i,2))
24034 kcol=kchg(pycomp(kflch),2)
24035 IF(kcol.NE.0) THEN
24036 k(i,1)=3
24037 kfls=(3-kcol*isign(1,kflch))/2
24038 k(i,kfls+3)=mstu(5)*ipu3
24039 k(ipu3,6-kfls)=mstu(5)*i
24040 icolr=i
24041 ENDIF
24042
24043C...Relative transverse momentum when two remnants.
24044 loop=0
24045 200 loop=loop+1
24046 CALL pyptdi(1,p(i-1,1),p(i-1,2))
24047 p(i-1,1)=p(i-1,1)-0.5d0*p(ipu3,1)
24048 p(i-1,2)=p(i-1,2)-0.5d0*p(ipu3,2)
24049 pms(3)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2
24050 p(i,1)=-p(ipu3,1)-p(i-1,1)
24051 p(i,2)=-p(ipu3,2)-p(i-1,2)
24052 pms(4)=p(i,5)**2+p(i,1)**2+p(i,2)**2
24053
24054C...Relative distribution of energy for particle into jet plus particle.
24055 imb=1
24056 IF(mod(mint(10+iside)/1000,10).NE.0) imb=2
24057 IF(mstp(94).LE.1) THEN
24058 IF(imb.EQ.1) chi=pyr(0)
24059 IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))
24060 IF(mod(kflch/1000,10).NE.0) chi=1d0-chi
24061 ELSEIF(mstp(94).EQ.2) THEN
24062 chi=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))
24063 IF(mod(kflch/1000,10).NE.0) chi=1d0-chi
24064 ELSEIF(mstp(94).EQ.3) THEN
24065 CALL pyzdis(1,0,pms(4),zz)
24066 chi=zz
24067 ELSE
24068 CALL pyzdis(1000,0,pms(4),zz)
24069 chi=zz
24070 ENDIF
24071
24072C...Construct total transverse mass; reject if too large.
24073 chi=max(1d-8,min(1d0-1d-8,chi))
24074 pms(iside)=pms(4)/chi+pms(3)/(1d0-chi)
24075 IF(pms(iside).GT.p(ipu3,4)**2) THEN
24076 IF(loop.LT.10) GOTO 200
24077 GOTO 180
24078 ENDIF
24079 vint(158+iside)=chi
24080
24081C...Subdivide longitudinal momentum according to value selected above.
24082 prp=sqrt(pms(iside)+p(ipu3,3)**2)+abs(p(ipu3,3))
24083 pw1=(1d0-chi)*prp
24084 p(i-1,4)=0.5d0*(pw1+pms(3)/pw1)
24085 p(i-1,3)=0.5d0*(pw1-pms(3)/pw1)*sidesg
24086 pw2=chi*prp
24087 p(i,4)=0.5d0*(pw2+pms(4)/pw2)
24088 p(i,3)=0.5d0*(pw2-pms(4)/pw2)*sidesg
24089 ENDIF
24090 n=i
24091
24092C...Boost current and remnant systems to correct frame.
24093 IF(sqrt(pms(1))+sqrt(pms(2)).GT.0.99d0*vint(1)) GOTO 180
24094 dsqlam=sqrt(max(0d0,(vint(2)-pms(1)-pms(2))**2-4d0*pms(1)*pms(2)))
24095 drkc=(vint(2)+pms(3-iside)-pms(iside)+dsqlam)/
24096 &(2d0*vint(1)*pcp)
24097 drkr=(vint(2)+pms(iside)-pms(3-iside)+dsqlam)/
24098 &(2d0*vint(1)*prp)
24099 dbec=-sidesg*(drkc**2-1d0)/(drkc**2+1d0)
24100 dber=sidesg*(drkr**2-1d0)/(drkr**2+1d0)
24101 CALL pyrobo(ipu3,ipu3,0d0,0d0,0d0,0d0,dbec)
24102 CALL pyrobo(ipu3+1,n,0d0,0d0,0d0,0d0,dber)
24103
24104C...Let current quark shower; recoil but no showering by colour partner.
24105 qmax=2d0*sqrt(vint(309-iside))
24106 mstj48=mstj(48)
24107 mstj(48)=1
24108 parj86=parj(86)
24109 parj(86)=0d0
24110 IF(mstp(71).EQ.1) CALL pyshow(ipu3,icolr,qmax)
24111 mstj(48)=mstj48
24112 parj(86)=parj86
24113
24114 RETURN
24115 END
24116
24117C*********************************************************************
24118
24119C...PYDOCU
24120C...Handles the documentation of the process in MSTI and PARI,
24121C...and also computes cross-sections based on accumulated statistics.
24122
24123 SUBROUTINE pydocu
24124
24125C...Double precision and integer declarations.
24126 IMPLICIT DOUBLE PRECISION(a-h, o-z)
24127 IMPLICIT INTEGER(I-N)
24128 INTEGER PYK,PYCHGE,PYCOMP
24129C...Commonblocks.
24130 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
24131 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24132 common/pypars/mstp(200),parp(200),msti(200),pari(200)
24133 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
24134 common/pyint1/mint(400),vint(400)
24135 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
24136 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
24137 SAVE /pyjets/,/pydat1/,/pysubs/,/pypars/,/pyint1/,/pyint2/,
24138 &/pyint5/
24139
24140C...Calculate Monte Carlo estimates of cross-sections.
24141 isub=mint(1)
24142 IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1
24143 ngen(0,3)=ngen(0,3)+1
24144 xsec(0,3)=0d0
24145 DO 100 i=1,500
24146 IF(i.EQ.96.OR.i.EQ.97) THEN
24147 xsec(i,3)=0d0
24148 ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR.
24149 & i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN
24150 xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*
24151 & dble(ngen(96,2)))
24152 ELSEIF(msub(95).EQ.1.AND.i.GE.381.AND.i.LE.386) THEN
24153 xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*
24154 & dble(ngen(96,2)))
24155 ELSEIF(msub(i).EQ.0.OR.ngen(i,1).EQ.0) THEN
24156 xsec(i,3)=0d0
24157 ELSEIF(ngen(i,2).EQ.0) THEN
24158 xsec(i,3)=xsec(i,2)*ngen(0,3)/(dble(ngen(i,1))*
24159 & dble(ngen(0,2)))
24160 ELSE
24161 xsec(i,3)=xsec(i,2)*ngen(i,3)/(dble(ngen(i,1))*
24162 & dble(ngen(i,2)))
24163 ENDIF
24164 xsec(0,3)=xsec(0,3)+xsec(i,3)
24165 100 CONTINUE
24166
24167C...Rescale to known low-pT cross-section for standard QCD processes.
24168 IF(msub(95).EQ.1) THEN
24169 xsech=xsec(11,3)+xsec(12,3)+xsec(13,3)+xsec(28,3)+xsec(53,3)+
24170 & xsec(68,3)+xsec(95,3)
24171 xsecw=xsec(97,2)/max(1d0,dble(ngen(97,1)))
24172 IF(xsech.GT.1d-20.AND.xsecw.GT.1d-20) THEN
24173 fac=xsecw/xsech
24174 xsec(11,3)=fac*xsec(11,3)
24175 xsec(12,3)=fac*xsec(12,3)
24176 xsec(13,3)=fac*xsec(13,3)
24177 xsec(28,3)=fac*xsec(28,3)
24178 xsec(53,3)=fac*xsec(53,3)
24179 xsec(68,3)=fac*xsec(68,3)
24180 xsec(95,3)=fac*xsec(95,3)
24181 xsec(0,3)=xsec(0,3)-xsech+xsecw
24182 ENDIF
24183 ENDIF
24184
24185C...Save information for gamma-p and gamma-gamma.
24186 IF(mint(121).GT.1) THEN
24187 iga=mint(122)
24188 CALL pysave(2,iga)
24189 CALL pysave(5,0)
24190 ENDIF
24191
24192C...Reset information on hard interaction.
24193 DO 110 j=1,200
24194 msti(j)=0
24195 pari(j)=0d0
24196 110 CONTINUE
24197
24198C...Copy integer valued information from MINT into MSTI.
24199 DO 120 j=1,32
24200 msti(j)=mint(j)
24201 120 CONTINUE
24202 IF(mint(121).GT.1) msti(9)=mint(122)
24203
24204C...Store cross-section variables in PARI.
24205 pari(1)=xsec(0,3)
24206 pari(2)=xsec(0,3)/mint(5)
24207 pari(7)=vint(97)
24208 pari(9)=vint(99)
24209 pari(10)=vint(100)
24210 vint(98)=vint(98)+vint(100)
24211 IF(mstp(142).EQ.1) pari(2)=xsec(0,3)/vint(98)
24212
24213C...Store kinematics variables in PARI.
24214 pari(11)=vint(1)
24215 pari(12)=vint(2)
24216 IF(isub.NE.95) THEN
24217 DO 130 j=13,26
24218 pari(j)=vint(30+j)
24219 130 CONTINUE
24220 pari(29)=vint(39)
24221 pari(30)=vint(40)
24222 pari(31)=vint(141)
24223 pari(32)=vint(142)
24224 pari(33)=vint(41)
24225 pari(34)=vint(42)
24226 pari(35)=pari(33)-pari(34)
24227 pari(36)=vint(21)
24228 pari(37)=vint(22)
24229 pari(38)=vint(26)
24230 pari(39)=vint(157)
24231 pari(40)=vint(158)
24232 pari(41)=vint(23)
24233 pari(42)=2d0*vint(47)/vint(1)
24234 ENDIF
24235
24236C...Store information on scattered partons in PARI.
24237 IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN
24238 DO 140 is=7,8
24239 i=mint(is)
24240 pari(36+is)=p(i,3)/vint(1)
24241 pari(38+is)=p(i,4)/vint(1)
24242 pr=max(1d-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)
24243 pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
24244 & sqrt(pr),1d20)),p(i,3))
24245 pr=max(1d-20,p(i,1)**2+p(i,2)**2)
24246 pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/
24247 & sqrt(pr),1d20)),p(i,3))
24248 pari(44+is)=p(i,3)/sqrt(1d-20+p(i,1)**2+p(i,2)**2+p(i,3)**2)
24249 pari(46+is)=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
24250 pari(48+is)=pyangl(p(i,1),p(i,2))
24251 140 CONTINUE
24252 ENDIF
24253
24254C...Store sum up transverse and longitudinal momenta.
24255 pari(65)=2d0*pari(17)
24256 IF(isub.LE.90.OR.isub.GE.95) THEN
24257 DO 150 i=mstp(126)+1,n
24258 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 150
24259 pt=sqrt(p(i,1)**2+p(i,2)**2)
24260 pari(69)=pari(69)+pt
24261 IF(i.LE.mint(52)) pari(66)=pari(66)+pt
24262 IF(i.GT.mint(52).AND.i.LE.mint(53)) pari(68)=pari(68)+pt
24263 150 CONTINUE
24264 pari(67)=pari(68)
24265 pari(71)=vint(151)
24266 pari(72)=vint(152)
24267 pari(73)=vint(151)
24268 pari(74)=vint(152)
24269 ELSE
24270 pari(66)=pari(65)
24271 pari(69)=pari(65)
24272 ENDIF
24273
24274C...Store various other pieces of information into PARI.
24275 pari(61)=vint(148)
24276 pari(75)=vint(155)
24277 pari(76)=vint(156)
24278 pari(77)=vint(159)
24279 pari(78)=vint(160)
24280 pari(81)=vint(138)
24281
24282C...Store information on lepton -> lepton + gamma in PYGAGA.
24283 msti(71)=mint(141)
24284 msti(72)=mint(142)
24285 pari(101)=vint(301)
24286 pari(102)=vint(302)
24287 DO 160 i=103,114
24288 pari(i)=vint(i+202)
24289 160 CONTINUE
24290
24291C...Set information for PYTABU.
24292 IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN
24293 mstu(161)=mint(21)
24294 mstu(162)=0
24295 ELSEIF(iset(isub).EQ.5) THEN
24296 mstu(161)=mint(23)
24297 mstu(162)=0
24298 ELSE
24299 mstu(161)=mint(21)
24300 mstu(162)=mint(22)
24301 ENDIF
24302
24303 RETURN
24304 END
24305
24306C*********************************************************************
24307
24308C...PYFRAM
24309C...Performs transformations between different coordinate frames.
24310
24311 SUBROUTINE pyfram(IFRAME)
24312
24313C...Double precision and integer declarations.
24314 IMPLICIT DOUBLE PRECISION(a-h, o-z)
24315 IMPLICIT INTEGER(I-N)
24316 INTEGER PYK,PYCHGE,PYCOMP
24317C...Commonblocks.
24318 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24319 common/pypars/mstp(200),parp(200),msti(200),pari(200)
24320 common/pyint1/mint(400),vint(400)
24321 SAVE /pydat1/,/pypars/,/pyint1/
24322
24323C...Check that transformation can and should be done.
24324 IF(iframe.EQ.1.OR.iframe.EQ.2.OR.(iframe.EQ.3.AND.
24325 &mint(91).EQ.1)) THEN
24326 IF(iframe.EQ.mint(6)) RETURN
24327 ELSE
24328 WRITE(mstu(11),5000) iframe,mint(6)
24329 RETURN
24330 ENDIF
24331
24332 IF(mint(6).EQ.1) THEN
24333C...Transform from fixed target or user specified frame to
24334C...overall CM frame.
24335 CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))
24336 CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)
24337 CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)
24338 ELSEIF(mint(6).EQ.3) THEN
24339C...Transform from hadronic CM frame in DIS to overall CM frame.
24340 CALL pyrobo(0,0,-vint(221),-vint(222),-vint(223),-vint(224),
24341 & -vint(225))
24342 ENDIF
24343
24344 IF(iframe.EQ.1) THEN
24345C...Transform from overall CM frame to fixed target or user specified
24346C...frame.
24347 CALL pyrobo(0,0,vint(6),vint(7),vint(8),vint(9),vint(10))
24348 ELSEIF(iframe.EQ.3) THEN
24349C...Transform from overall CM frame to hadronic CM frame in DIS.
24350 CALL pyrobo(0,0,0d0,0d0,vint(223),vint(224),vint(225))
24351 CALL pyrobo(0,0,0d0,vint(222),0d0,0d0,0d0)
24352 CALL pyrobo(0,0,vint(221),0d0,0d0,0d0,0d0)
24353 ENDIF
24354
24355C...Set information about new frame.
24356 mint(6)=iframe
24357 msti(6)=iframe
24358
24359 5000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,
24360 &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =',
24361 &1x,i5)
24362
24363 RETURN
24364 END
24365
24366C*********************************************************************
24367
24368C...PYWIDT
24369C...Calculates full and partial widths of resonances.
24370
24371 SUBROUTINE pywidt(KFLR,SH,WDTP,WDTE)
24372
24373C...Double precision and integer declarations.
24374 IMPLICIT DOUBLE PRECISION(a-h, o-z)
24375 IMPLICIT INTEGER(I-N)
24376 INTEGER PYK,PYCHGE,PYCOMP
24377C...Parameter statement to help give large particle numbers.
24378 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
24379 &kexcit=4000000,kdimen=5000000)
24380C...Commonblocks.
24381 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
24382 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
24383 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
24384 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
24385 common/pypars/mstp(200),parp(200),msti(200),pari(200)
24386 common/pyint1/mint(400),vint(400)
24387 common/pyint4/mwid(500),wids(500,5)
24388 common/pymssm/imss(0:99),rmss(0:99)
24389 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
24390 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
24391 common/pytcsm/itcm(0:99),rtcm(0:99)
24392 common/pypued/iued(0:99),rued(0:99)
24393 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
24394 &/pyint4/,/pymssm/,/pyssmt/,/pytcsm/,/pypued/
24395C...Local arrays and saved variables.
24396 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24397 dimension wdtp(0:400),wdte(0:400,0:5),mofsv(3,2),widwsv(3,2),
24398 &wid2sv(3,2),wdtpp(0:400),wdtep(0:400,0:5)
24399C...UED: equivalences between ordered particles (451->475)
24400C...and UED particle code (5 000 000 + id)
24401 parameter(kkflmi=451,kkflma=475)
24402 dimension chidel(3), iuedpr(25)
24403 dimension iuedeq(kkflma),mued(2)
24404 common/sw1/sw21,cw21
24405 DATA (iuedeq(i),i=kkflmi,kkflma)/
24406 & 6100001,6100002,6100003,6100004,6100005,6100006,
24407 & 5100001,5100002,5100003,5100004,5100005,5100006,
24408 & 6100011,6100013,6100015,
24409 & 5100012,5100011,5100014,5100013,5100016,5100015,
24410 & 5100021,5100022,5100023,5100024/
24411C...Save local variables
24412 SAVE mofsv,widwsv,wid2sv
24413C...Initial values
24414 DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
24415 DATA chidel/1.1d-03,1.d0,7.4d+2/
24416 DATA iuedpr/25*0/
24417C...UED: inline functions used in kk width calculus
24418 fkac1(x,y)=1.-x**2/y**2
24419 fkac2(x,y)=2.+x**2/y**2
24420
24421C...Compressed code and sign; mass.
24422 kfla=iabs(kflr)
24423 kfls=isign(1,kflr)
24424 kc=pycomp(kfla)
24425 shr=sqrt(sh)
24426 pmr=pmas(kc,1)
24427
24428C...Reset width information.
24429 DO 110 i=0,mdcy(kc,3)
24430 wdtp(i)=0d0
24431 DO 100 j=0,5
24432 wdte(i,j)=0d0
24433 100 CONTINUE
24434 110 CONTINUE
24435
24436C...Allow for fudge factor to rescale resonance width.
24437 fudge=1d0
24438 IF(mstp(110).NE.0.AND.(mwid(kc).EQ.1.OR.mwid(kc).EQ.2.OR.
24439 &(mwid(kc).EQ.3.AND.mint(63).EQ.1))) THEN
24440 IF(mstp(110).EQ.kfla) THEN
24441 fudge=parp(110)
24442 ELSEIF(mstp(110).EQ.-1) THEN
24443 IF(kfla.NE.6.AND.kfla.NE.23.AND.kfla.NE.24) fudge=parp(110)
24444 ELSEIF(mstp(110).EQ.-2) THEN
24445 fudge=parp(110)
24446 ENDIF
24447 ENDIF
24448
24449C...Not to be treated as a resonance: return.
24450 IF((mwid(kc).LE.0.OR.mwid(kc).GE.4).AND.kfla.NE.21.AND.
24451 &kfla.NE.22) THEN
24452 wdtp(0)=1d0
24453 wdte(0,0)=1d0
24454 mint(61)=0
24455 mint(62)=0
24456 mint(63)=0
24457 RETURN
24458
24459C...Treatment as a resonance based on tabulated branching ratios.
24460 ELSEIF(mwid(kc).EQ.2.OR.(mwid(kc).EQ.3.AND.mint(63).EQ.0)) THEN
24461C...Loop over possible decay channels; skip irrelevant ones.
24462 DO 120 i=1,mdcy(kc,3)
24463 idc=i+mdcy(kc,2)-1
24464 IF(mdme(idc,1).LT.0) GOTO 120
24465
24466C...Read out decay products and nominal masses.
24467 kfd1=kfdp(idc,1)
24468 kfc1=pycomp(kfd1)
24469 IF(kchg(kfc1,3).EQ.1) kfd1=kfls*kfd1
24470 pm1=pmas(kfc1,1)
24471 kfd2=kfdp(idc,2)
24472 kfc2=pycomp(kfd2)
24473 IF(kchg(kfc2,3).EQ.1) kfd2=kfls*kfd2
24474 pm2=pmas(kfc2,1)
24475 kfd3=kfdp(idc,3)
24476 pm3=0d0
24477 IF(kfd3.NE.0) THEN
24478 kfc3=pycomp(kfd3)
24479 IF(kchg(kfc3,3).EQ.1) kfd3=kfls*kfd3
24480 pm3=pmas(kfc3,1)
24481 ENDIF
24482
24483C...Naive partial width and alternative threshold factors.
24484 wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)
24485 IF(mdme(idc,2).GE.51.AND.mdme(idc,2).LE.53.AND.
24486 & pm1+pm2+pm3.GE.shr) THEN
24487 wdtp(i)=0d0
24488 ELSEIF(mdme(idc,2).EQ.52.AND.kfd3.EQ.0) THEN
24489 wdtp(i)=wdtp(i)*sqrt(max(0d0,(sh-pm1**2-pm2**2)**2-
24490 & 4d0*pm1**2*pm2**2))/sh
24491 ELSEIF(mdme(idc,2).EQ.52) THEN
24492 pma=max(pm1,pm2,pm3)
24493 pmc=min(pm1,pm2,pm3)
24494 pmb=pm1+pm2+pm3-pma-pmc
24495 pmbc=pmb+pmc+0.5d0*(shr-pma-pmc-pmc)
24496 pman=pma**2/sh
24497 pmbn=pmb**2/sh
24498 pmcn=pmc**2/sh
24499 pmbcn=pmbc**2/sh
24500 wdtp(i)=wdtp(i)*sqrt(max(0d0,
24501 & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
24502 & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
24503 & ((shr-pma)**2-(pmb+pmc)**2)*
24504 & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
24505 & ((1d0-pmbcn)*pmbcn*sh)
24506 ELSEIF(mdme(idc,2).EQ.53.AND.kfd3.EQ.0) THEN
24507 wdtp(i)=wdtp(i)*sqrt(
24508 & max(0d0,(sh-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2)/
24509 & max(1d-4,(pmr**2-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2))
24510 ELSEIF(mdme(idc,2).EQ.53) THEN
24511 pma=max(pm1,pm2,pm3)
24512 pmc=min(pm1,pm2,pm3)
24513 pmb=pm1+pm2+pm3-pma-pmc
24514 pmbc=pmb+pmc+0.5d0*(shr-pma-pmb-pmc)
24515 pman=pma**2/sh
24516 pmbn=pmb**2/sh
24517 pmcn=pmc**2/sh
24518 pmbcn=pmbc**2/sh
24519 facact=sqrt(max(0d0,
24520 & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
24521 & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
24522 & ((shr-pma)**2-(pmb+pmc)**2)*
24523 & (1d0+0.25d0*(pma+pmb+pmc)/shr)/
24524 & ((1d0-pmbcn)*pmbcn*sh)
24525 pmbc=pmb+pmc+0.5d0*(pmr-pma-pmb-pmc)
24526 pman=pma**2/pmr**2
24527 pmbn=pmb**2/pmr**2
24528 pmcn=pmc**2/pmr**2
24529 pmbcn=pmbc**2/pmr**2
24530 facnom=sqrt(max(0d0,
24531 & ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*
24532 & ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*
24533 & ((pmr-pma)**2-(pmb+pmc)**2)*
24534 & (1d0+0.25d0*(pma+pmb+pmc)/pmr)/
24535 & ((1d0-pmbcn)*pmbcn*pmr**2)
24536 wdtp(i)=wdtp(i)*facact/max(1d-6,facnom)
24537 ENDIF
24538 wdtp(i)=fudge*wdtp(i)
24539 wdtp(0)=wdtp(0)+wdtp(i)
24540
24541C...Calculate secondary width (at most two identical/opposite).
24542 wid2=1d0
24543 IF(mdme(idc,1).GT.0) THEN
24544 IF(kfd2.EQ.kfd1) THEN
24545 IF(kchg(kfc1,3).EQ.0) THEN
24546 wid2=wids(kfc1,1)
24547 ELSEIF(kfd1.GT.0) THEN
24548 wid2=wids(kfc1,4)
24549 ELSE
24550 wid2=wids(kfc1,5)
24551 ENDIF
24552 IF(kfd3.GT.0) THEN
24553 wid2=wid2*wids(kfc3,2)
24554 ELSEIF(kfd3.LT.0) THEN
24555 wid2=wid2*wids(kfc3,3)
24556 ENDIF
24557 ELSEIF(kfd2.EQ.-kfd1) THEN
24558 wid2=wids(kfc1,1)
24559 IF(kfd3.GT.0) THEN
24560 wid2=wid2*wids(kfc3,2)
24561 ELSEIF(kfd3.LT.0) THEN
24562 wid2=wid2*wids(kfc3,3)
24563 ENDIF
24564 ELSEIF(kfd3.EQ.kfd1) THEN
24565 IF(kchg(kfc1,3).EQ.0) THEN
24566 wid2=wids(kfc1,1)
24567 ELSEIF(kfd1.GT.0) THEN
24568 wid2=wids(kfc1,4)
24569 ELSE
24570 wid2=wids(kfc1,5)
24571 ENDIF
24572 IF(kfd2.GT.0) THEN
24573 wid2=wid2*wids(kfc2,2)
24574 ELSEIF(kfd2.LT.0) THEN
24575 wid2=wid2*wids(kfc2,3)
24576 ENDIF
24577 ELSEIF(kfd3.EQ.-kfd1) THEN
24578 wid2=wids(kfc1,1)
24579 IF(kfd2.GT.0) THEN
24580 wid2=wid2*wids(kfc2,2)
24581 ELSEIF(kfd2.LT.0) THEN
24582 wid2=wid2*wids(kfc2,3)
24583 ENDIF
24584 ELSEIF(kfd3.EQ.kfd2) THEN
24585 IF(kchg(kfc2,3).EQ.0) THEN
24586 wid2=wids(kfc2,1)
24587 ELSEIF(kfd2.GT.0) THEN
24588 wid2=wids(kfc2,4)
24589 ELSE
24590 wid2=wids(kfc2,5)
24591 ENDIF
24592 IF(kfd1.GT.0) THEN
24593 wid2=wid2*wids(kfc1,2)
24594 ELSEIF(kfd1.LT.0) THEN
24595 wid2=wid2*wids(kfc1,3)
24596 ENDIF
24597 ELSEIF(kfd3.EQ.-kfd2) THEN
24598 wid2=wids(kfc2,1)
24599 IF(kfd1.GT.0) THEN
24600 wid2=wid2*wids(kfc1,2)
24601 ELSEIF(kfd1.LT.0) THEN
24602 wid2=wid2*wids(kfc1,3)
24603 ENDIF
24604 ELSE
24605 IF(kfd1.GT.0) THEN
24606 wid2=wids(kfc1,2)
24607 ELSE
24608 wid2=wids(kfc1,3)
24609 ENDIF
24610 IF(kfd2.GT.0) THEN
24611 wid2=wid2*wids(kfc2,2)
24612 ELSE
24613 wid2=wid2*wids(kfc2,3)
24614 ENDIF
24615 IF(kfd3.GT.0) THEN
24616 wid2=wid2*wids(kfc3,2)
24617 ELSEIF(kfd3.LT.0) THEN
24618 wid2=wid2*wids(kfc3,3)
24619 ENDIF
24620 ENDIF
24621
24622C...Store effective widths according to case.
24623 wdte(i,mdme(idc,1))=wdtp(i)*wid2
24624 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24625 wdte(i,0)=wdte(i,mdme(idc,1))
24626 wdte(0,0)=wdte(0,0)+wdte(i,0)
24627 ENDIF
24628 120 CONTINUE
24629C...Return.
24630 mint(61)=0
24631 mint(62)=0
24632 mint(63)=0
24633 RETURN
24634 ENDIF
24635
24636C...Here begins detailed dynamical calculation of resonance widths.
24637C...Shared treatment of Higgs states.
24638 kfhigg=25
24639 ihigg=1
24640 IF(kfla.EQ.35.OR.kfla.EQ.36) THEN
24641 kfhigg=kfla
24642 ihigg=kfla-33
24643 ENDIF
24644
24645C...Common electroweak and strong constants.
24646 xw=paru(102)
24647 xwv=xw
24648 IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
24649 xw1=1d0-xw
24650 aem=pyalem(sh)
24651 IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
24652 as=pyalps(sh)
24653 radc=1d0+as/paru(1)
24654
24655 IF(kfla.EQ.6) THEN
24656C...t quark.
24657 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24658 radct=1d0-2.5d0*as/paru(1)
24659 DO 140 i=1,mdcy(kc,3)
24660 idc=i+mdcy(kc,2)-1
24661 IF(mdme(idc,1).LT.0) GOTO 140
24662 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24663 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24664 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 140
24665 wid2=1d0
24666 IF(i.GE.4.AND.i.LE.7) THEN
24667C...t -> W + q; including approximate QCD correction factor.
24668 wdtp(i)=fac*vckm(3,i-3)*radct*
24669 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24670 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24671 IF(kflr.GT.0) THEN
24672 wid2=wids(24,2)
24673 IF(i.EQ.7) wid2=wid2*wids(7,2)
24674 ELSE
24675 wid2=wids(24,3)
24676 IF(i.EQ.7) wid2=wid2*wids(7,3)
24677 ENDIF
24678 ELSEIF(i.EQ.9) THEN
24679C...t -> H + b.
24680 rm2r=pymrun(kfdp(idc,2),sh)**2/sh
24681 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24682 & ((1d0+rm2-rm1)*(rm2r*paru(141)**2+1d0/paru(141)**2)+
24683 & 4d0*sqrt(rm2r*rm2))
24684 wid2=wids(37,2)
24685 IF(kflr.LT.0) wid2=wids(37,3)
24686CMRENNA++
24687 ELSEIF(i.GE.10.AND.i.LE.13.AND.imss(1).NE.0) THEN
24688C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24689 beta=atan(rmss(5))
24690 sinb=sin(beta)
24691 tanw=sqrt(paru(102)/(1d0-paru(102)))
24692 et=kchg(6,1)/3d0
24693 t3l=sign(0.5d0,et)
24694 kfc1=pycomp(kfdp(idc,1))
24695 kfc2=pycomp(kfdp(idc,2))
24696 pmnchi=pmas(kfc1,1)
24697 pmstop=pmas(kfc2,1)
24698 IF(shr.GT.pmnchi+pmstop) THEN
24699 iz=i-9
24700 DO 130 ik=1,4
24701 zmixc(iz,ik)=dcmplx(zmix(iz,ik),zmixi(iz,ik))
24702 130 CONTINUE
24703 al=shr*dconjg(zmixc(iz,4))/(2.0d0*pmas(24,1)*sinb)
24704 ar=-et*zmixc(iz,1)*tanw
24705 bl=t3l*(zmixc(iz,2)-zmixc(iz,1)*tanw)-ar
24706 br=al
24707 fl=sfmix(6,1)*al+sfmix(6,2)*ar
24708 fr=sfmix(6,1)*bl+sfmix(6,2)*br
24709 pcm=sqrt((sh-(pmnchi+pmstop)**2)*
24710 & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
24711 wdtp(i)=(0.5d0*pyalem(sh)/paru(102))*pcm*
24712 & ((abs(fl)**2+abs(fr)**2)*(sh+pmnchi**2-pmstop**2)+
24713 & smz(iz)*4d0*shr*dble(fl*dconjg(fr)))/sh
24714 IF(kflr.GT.0) THEN
24715 wid2=wids(kfc1,2)*wids(kfc2,2)
24716 ELSE
24717 wid2=wids(kfc1,2)*wids(kfc2,3)
24718 ENDIF
24719 ENDIF
24720 ELSEIF(i.EQ.14.AND.imss(1).NE.0) THEN
24721C...t -> ~g + ~t
24722 kfc1=pycomp(kfdp(idc,1))
24723 kfc2=pycomp(kfdp(idc,2))
24724 pmnchi=pmas(kfc1,1)
24725 pmstop=pmas(kfc2,1)
24726 IF(shr.GT.pmnchi+pmstop) THEN
24727 rl=sfmix(6,1)
24728 rr=-sfmix(6,2)
24729 pcm=sqrt((sh-(pmnchi+pmstop)**2)*
24730 & (sh-(pmnchi-pmstop)**2))/(2d0*shr)
24731 wdtp(i)=4d0/3d0*0.5d0*pyalps(sh)*pcm*((rl**2+rr**2)*
24732 & (sh+pmnchi**2-pmstop**2)+pmnchi*4d0*shr*rl*rr)/sh
24733 IF(kflr.GT.0) THEN
24734 wid2=wids(kfc1,2)*wids(kfc2,2)
24735 ELSE
24736 wid2=wids(kfc1,2)*wids(kfc2,3)
24737 ENDIF
24738 ENDIF
24739 ELSEIF(i.EQ.15.AND.imss(1).NE.0) THEN
24740C...t -> ~gravitino + ~t
24741 xmp2=rmss(29)**2
24742 kfc1=pycomp(kfdp(idc,1))
24743 xmgr2=pmas(kfc1,1)**2
24744 wdtp(i)=sh**2*shr/(96d0*paru(1)*xmp2*xmgr2)*(1d0-rm2)**4
24745 kfc2=pycomp(kfdp(idc,2))
24746 wid2=wids(kfc2,2)
24747 IF(kflr.LT.0) wid2=wids(kfc2,3)
24748CMRENNA--
24749 ENDIF
24750 wdtp(i)=fudge*wdtp(i)
24751 wdtp(0)=wdtp(0)+wdtp(i)
24752 IF(mdme(idc,1).GT.0) THEN
24753 wdte(i,mdme(idc,1))=wdtp(i)*wid2
24754 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24755 wdte(i,0)=wdte(i,mdme(idc,1))
24756 wdte(0,0)=wdte(0,0)+wdte(i,0)
24757 ENDIF
24758 140 CONTINUE
24759
24760 ELSEIF(kfla.EQ.7) THEN
24761C...b' quark.
24762 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24763 DO 150 i=1,mdcy(kc,3)
24764 idc=i+mdcy(kc,2)-1
24765 IF(mdme(idc,1).LT.0) GOTO 150
24766 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24767 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24768 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 150
24769 wid2=1d0
24770 IF(i.GE.4.AND.i.LE.7) THEN
24771C...b' -> W + q.
24772 wdtp(i)=fac*vckm(i-3,4)*
24773 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24774 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24775 IF(kflr.GT.0) THEN
24776 wid2=wids(24,3)
24777 IF(i.EQ.6) wid2=wid2*wids(6,2)
24778 IF(i.EQ.7) wid2=wid2*wids(8,2)
24779 ELSE
24780 wid2=wids(24,2)
24781 IF(i.EQ.6) wid2=wid2*wids(6,3)
24782 IF(i.EQ.7) wid2=wid2*wids(8,3)
24783 ENDIF
24784 wid2=wids(24,3)
24785 IF(kflr.LT.0) wid2=wids(24,2)
24786 ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
24787C...b' -> H + q.
24788 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24789 & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
24790 IF(kflr.GT.0) THEN
24791 wid2=wids(37,3)
24792 IF(i.EQ.10) wid2=wid2*wids(6,2)
24793 ELSE
24794 wid2=wids(37,2)
24795 IF(i.EQ.10) wid2=wid2*wids(6,3)
24796 ENDIF
24797 ENDIF
24798 wdtp(i)=fudge*wdtp(i)
24799 wdtp(0)=wdtp(0)+wdtp(i)
24800 IF(mdme(idc,1).GT.0) THEN
24801 wdte(i,mdme(idc,1))=wdtp(i)*wid2
24802 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24803 wdte(i,0)=wdte(i,mdme(idc,1))
24804 wdte(0,0)=wdte(0,0)+wdte(i,0)
24805 ENDIF
24806 150 CONTINUE
24807
24808 ELSEIF(kfla.EQ.8) THEN
24809C...t' quark.
24810 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24811 DO 160 i=1,mdcy(kc,3)
24812 idc=i+mdcy(kc,2)-1
24813 IF(mdme(idc,1).LT.0) GOTO 160
24814 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24815 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24816 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 160
24817 wid2=1d0
24818 IF(i.GE.4.AND.i.LE.7) THEN
24819C...t' -> W + q.
24820 wdtp(i)=fac*vckm(4,i-3)*
24821 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24822 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24823 IF(kflr.GT.0) THEN
24824 wid2=wids(24,2)
24825 IF(i.EQ.7) wid2=wid2*wids(7,2)
24826 ELSE
24827 wid2=wids(24,3)
24828 IF(i.EQ.7) wid2=wid2*wids(7,3)
24829 ENDIF
24830 ELSEIF(i.EQ.9.OR.i.EQ.10) THEN
24831C...t' -> H + q.
24832 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24833 & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
24834 IF(kflr.GT.0) THEN
24835 wid2=wids(37,2)
24836 IF(i.EQ.10) wid2=wid2*wids(7,2)
24837 ELSE
24838 wid2=wids(37,3)
24839 IF(i.EQ.10) wid2=wid2*wids(7,3)
24840 ENDIF
24841 ENDIF
24842 wdtp(i)=fudge*wdtp(i)
24843 wdtp(0)=wdtp(0)+wdtp(i)
24844 IF(mdme(idc,1).GT.0) THEN
24845 wdte(i,mdme(idc,1))=wdtp(i)*wid2
24846 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24847 wdte(i,0)=wdte(i,mdme(idc,1))
24848 wdte(0,0)=wdte(0,0)+wdte(i,0)
24849 ENDIF
24850 160 CONTINUE
24851
24852 ELSEIF(kfla.EQ.17) THEN
24853C...tau' lepton.
24854 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24855 DO 170 i=1,mdcy(kc,3)
24856 idc=i+mdcy(kc,2)-1
24857 IF(mdme(idc,1).LT.0) GOTO 170
24858 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24859 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24860 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 170
24861 wid2=1d0
24862 IF(i.EQ.3) THEN
24863C...tau' -> W + nu'_tau.
24864 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24865 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24866 IF(kflr.GT.0) THEN
24867 wid2=wids(24,3)
24868 wid2=wid2*wids(18,2)
24869 ELSE
24870 wid2=wids(24,2)
24871 wid2=wid2*wids(18,3)
24872 ENDIF
24873 ELSEIF(i.EQ.5) THEN
24874C...tau' -> H + nu'_tau.
24875 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24876 & ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)
24877 IF(kflr.GT.0) THEN
24878 wid2=wids(37,3)
24879 wid2=wid2*wids(18,2)
24880 ELSE
24881 wid2=wids(37,2)
24882 wid2=wid2*wids(18,3)
24883 ENDIF
24884 ENDIF
24885 wdtp(i)=fudge*wdtp(i)
24886 wdtp(0)=wdtp(0)+wdtp(i)
24887 IF(mdme(idc,1).GT.0) THEN
24888 wdte(i,mdme(idc,1))=wdtp(i)*wid2
24889 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24890 wdte(i,0)=wdte(i,mdme(idc,1))
24891 wdte(0,0)=wdte(0,0)+wdte(i,0)
24892 ENDIF
24893 170 CONTINUE
24894
24895 ELSEIF(kfla.EQ.18) THEN
24896C...nu'_tau neutrino.
24897 fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr
24898 DO 180 i=1,mdcy(kc,3)
24899 idc=i+mdcy(kc,2)-1
24900 IF(mdme(idc,1).LT.0) GOTO 180
24901 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
24902 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
24903 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 180
24904 wid2=1d0
24905 IF(i.EQ.2) THEN
24906C...nu'_tau -> W + tau'.
24907 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24908 & ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)
24909 IF(kflr.GT.0) THEN
24910 wid2=wids(24,2)
24911 wid2=wid2*wids(17,2)
24912 ELSE
24913 wid2=wids(24,3)
24914 wid2=wid2*wids(17,3)
24915 ENDIF
24916 ELSEIF(i.EQ.3) THEN
24917C...nu'_tau -> H + tau'.
24918 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
24919 & ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)
24920 IF(kflr.GT.0) THEN
24921 wid2=wids(37,2)
24922 wid2=wid2*wids(17,2)
24923 ELSE
24924 wid2=wids(37,3)
24925 wid2=wid2*wids(17,3)
24926 ENDIF
24927 ENDIF
24928 wdtp(i)=fudge*wdtp(i)
24929 wdtp(0)=wdtp(0)+wdtp(i)
24930 IF(mdme(idc,1).GT.0) THEN
24931 wdte(i,mdme(idc,1))=wdtp(i)*wid2
24932 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24933 wdte(i,0)=wdte(i,mdme(idc,1))
24934 wdte(0,0)=wdte(0,0)+wdte(i,0)
24935 ENDIF
24936 180 CONTINUE
24937
24938 ELSEIF(kfla.EQ.21) THEN
24939C...QCD:
24940C***Note that widths are not given in dimensional quantities here.
24941 DO 190 i=1,mdcy(kc,3)
24942 idc=i+mdcy(kc,2)-1
24943 IF(mdme(idc,1).LT.0) GOTO 190
24944 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
24945 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
24946 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 190
24947 wid2=1d0
24948 IF(i.LE.8) THEN
24949C...QCD -> q + qbar
24950 wdtp(i)=(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
24951 IF(i.EQ.6) wid2=wids(6,1)
24952 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
24953 ENDIF
24954 wdtp(i)=fudge*wdtp(i)
24955 wdtp(0)=wdtp(0)+wdtp(i)
24956 IF(mdme(idc,1).GT.0) THEN
24957 wdte(i,mdme(idc,1))=wdtp(i)*wid2
24958 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24959 wdte(i,0)=wdte(i,mdme(idc,1))
24960 wdte(0,0)=wdte(0,0)+wdte(i,0)
24961 ENDIF
24962 190 CONTINUE
24963
24964 ELSEIF(kfla.EQ.22) THEN
24965C...QED photon.
24966C***Note that widths are not given in dimensional quantities here.
24967 DO 200 i=1,mdcy(kc,3)
24968 idc=i+mdcy(kc,2)-1
24969 IF(mdme(idc,1).LT.0) GOTO 200
24970 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
24971 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
24972 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 200
24973 wid2=1d0
24974 IF(i.LE.8) THEN
24975C...QED -> q + qbar.
24976 ef=kchg(i,1)/3d0
24977 fcof=3d0*radc
24978 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
24979 wdtp(i)=fcof*ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
24980 IF(i.EQ.6) wid2=wids(6,1)
24981 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
24982 ELSEIF(i.LE.12) THEN
24983C...QED -> l+ + l-.
24984 ef=kchg(9+2*(i-8),1)/3d0
24985 wdtp(i)=ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
24986 IF(i.EQ.12) wid2=wids(17,1)
24987 ENDIF
24988 wdtp(i)=fudge*wdtp(i)
24989 wdtp(0)=wdtp(0)+wdtp(i)
24990 IF(mdme(idc,1).GT.0) THEN
24991 wdte(i,mdme(idc,1))=wdtp(i)*wid2
24992 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
24993 wdte(i,0)=wdte(i,mdme(idc,1))
24994 wdte(0,0)=wdte(0,0)+wdte(i,0)
24995 ENDIF
24996 200 CONTINUE
24997
24998 ELSEIF(kfla.EQ.23) THEN
24999C...Z0:
25000 icase=1
25001 xwc=1d0/(16d0*xw*xw1)
25002 fac=(aem*xwc/3d0)*shr
25003 210 CONTINUE
25004 IF(mint(61).GE.1.AND.icase.EQ.2) THEN
25005 vint(111)=0d0
25006 vint(112)=0d0
25007 vint(114)=0d0
25008 ENDIF
25009 IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25010 kfi=iabs(mint(15))
25011 IF(kfi.GT.20) kfi=iabs(mint(16))
25012 ei=kchg(kfi,1)/3d0
25013 ai=sign(1d0,ei)
25014 vi=ai-4d0*ei*xwv
25015 sqmz=pmas(23,1)**2
25016 hz=shr*wdtp(0)
25017 IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=1d0
25018 IF(mstp(43).EQ.3) vint(112)=
25019 & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
25020 IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
25021 & xwc**2*sh**2/((sh-sqmz)**2+hz**2)
25022 ENDIF
25023 DO 220 i=1,mdcy(kc,3)
25024 idc=i+mdcy(kc,2)-1
25025 IF(mdme(idc,1).LT.0) GOTO 220
25026 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
25027 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
25028 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 220
25029 wid2=1d0
25030 IF(i.LE.8) THEN
25031C...Z0 -> q + qbar
25032 ef=kchg(i,1)/3d0
25033 af=sign(1d0,ef+0.1d0)
25034 vf=af-4d0*ef*xwv
25035 fcof=3d0*radc
25036 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
25037 IF(i.EQ.6) wid2=wids(6,1)
25038 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25039 ELSEIF(i.LE.16) THEN
25040C...Z0 -> l+ + l-, nu + nubar
25041 ef=kchg(i+2,1)/3d0
25042 af=sign(1d0,ef+0.1d0)
25043 vf=af-4d0*ef*xwv
25044 fcof=1d0
25045 IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
25046 ENDIF
25047 be34=sqrt(max(0d0,1d0-4d0*rm1))
25048 IF(icase.EQ.1) THEN
25049 wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
25050 & be34
25051 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25052 wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
25053 & ef*vf+(vi**2+ai**2)*vint(114)*vf**2)*(1d0+2d0*rm1)+
25054 & (vi**2+ai**2)*vint(114)*af**2*(1d0-4d0*rm1))*be34
25055 ELSEIF(mint(61).EQ.2.AND.icase.EQ.2) THEN
25056 fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
25057 fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
25058 fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
25059 ENDIF
25060 IF(icase.EQ.1) wdtp(i)=fudge*wdtp(i)
25061 IF(icase.EQ.1) wdtp(0)=wdtp(0)+wdtp(i)
25062 IF(mdme(idc,1).GT.0) THEN
25063 IF((icase.EQ.1.AND.mint(61).NE.1).OR.
25064 & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
25065 wdte(i,mdme(idc,1))=wdtp(i)*wid2
25066 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
25067 & wdte(i,mdme(idc,1))
25068 wdte(i,0)=wdte(i,mdme(idc,1))
25069 wdte(0,0)=wdte(0,0)+wdte(i,0)
25070 ENDIF
25071 IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
25072 IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=
25073 & vint(111)+fggf*wid2
25074 IF(mstp(43).EQ.3) vint(112)=vint(112)+fgzf*wid2
25075 IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=
25076 & vint(114)+fzzf*wid2
25077 ENDIF
25078 ENDIF
25079 220 CONTINUE
25080 IF(mint(61).GE.1) icase=3-icase
25081 IF(icase.EQ.2) GOTO 210
25082
25083 ELSEIF(kfla.EQ.24) THEN
25084C...W+/-:
25085 fac=(aem/(24d0*xw))*shr
25086 DO 230 i=1,mdcy(kc,3)
25087 idc=i+mdcy(kc,2)-1
25088 IF(mdme(idc,1).LT.0) GOTO 230
25089 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
25090 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
25091 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 230
25092 wid2=1d0
25093 IF(i.LE.16) THEN
25094C...W+/- -> q + qbar'
25095 fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
25096 IF(kflr.GT.0) THEN
25097 IF(mod(i,4).EQ.3) wid2=wids(6,2)
25098 IF(mod(i,4).EQ.0) wid2=wids(8,2)
25099 IF(i.GE.13) wid2=wid2*wids(7,3)
25100 ELSE
25101 IF(mod(i,4).EQ.3) wid2=wids(6,3)
25102 IF(mod(i,4).EQ.0) wid2=wids(8,3)
25103 IF(i.GE.13) wid2=wid2*wids(7,2)
25104 ENDIF
25105 ELSEIF(i.LE.20) THEN
25106C...W+/- -> l+/- + nu
25107 fcof=1d0
25108 IF(kflr.GT.0) THEN
25109 IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
25110 ELSE
25111 IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
25112 ENDIF
25113 ENDIF
25114 wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
25115 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25116 wdtp(i)=fudge*wdtp(i)
25117 wdtp(0)=wdtp(0)+wdtp(i)
25118 IF(mdme(idc,1).GT.0) THEN
25119 wdte(i,mdme(idc,1))=wdtp(i)*wid2
25120 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25121 wdte(i,0)=wdte(i,mdme(idc,1))
25122 wdte(0,0)=wdte(0,0)+wdte(i,0)
25123 ENDIF
25124 230 CONTINUE
25125
25126 ELSEIF(kfla.EQ.25.OR.kfla.EQ.35.OR.kfla.EQ.36) THEN
25127C...h0 (or H0, or A0):
25128 shfs=sh
25129 fac=(aem/(8d0*xw))*(shfs/pmas(24,1)**2)*shr
25130 DO 270 i=1,mdcy(kfhigg,3)
25131 idc=i+mdcy(kfhigg,2)-1
25132 IF(mdme(idc,1).LT.0) GOTO 270
25133 kfc1=pycomp(kfdp(idc,1))
25134 kfc2=pycomp(kfdp(idc,2))
25135 rm1=pmas(kfc1,1)**2/sh
25136 rm2=pmas(kfc2,1)**2/sh
25137 IF(i.NE.16.AND.i.NE.17.AND.sqrt(rm1)+sqrt(rm2).GT.1d0)
25138 & GOTO 270
25139 wid2=1d0
25140
25141 IF(i.LE.8) THEN
25142C...h0 -> q + qbar
25143 wdtp(i)=fac*3d0*(pymrun(kfdp(idc,1),sh)**2/shfs)*
25144 & sqrt(max(0d0,1d0-4d0*rm1))*radc
25145C...A0 behaves like beta, ho and H0 like beta**3.
25146 IF(ihigg.NE.3) wdtp(i)=wdtp(i)*(1d0-4d0*rm1)
25147 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25148 IF(mod(i,2).EQ.1) wdtp(i)=wdtp(i)*paru(151+10*ihigg)**2
25149 IF(mod(i,2).EQ.0) wdtp(i)=wdtp(i)*paru(152+10*ihigg)**2
25150 IF(imss(1).NE.0.AND.kfc1.EQ.5) THEN
25151 wdtp(i)=wdtp(i)/(1d0+rmss(41))**2
25152 IF(ihigg.NE.3) THEN
25153 wdtp(i)=wdtp(i)*(1d0+rmss(41)*paru(152+10*ihigg)/
25154 & paru(151+10*ihigg))**2
25155 ENDIF
25156 ENDIF
25157 ENDIF
25158 IF(i.EQ.6) wid2=wids(6,1)
25159 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25160 ELSEIF(i.LE.12) THEN
25161C...h0 -> l+ + l-
25162 wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))*(sh/shfs)
25163C...A0 behaves like beta, ho and H0 like beta**3.
25164 IF(ihigg.NE.3) wdtp(i)=wdtp(i)*(1d0-4d0*rm1)
25165 IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
25166 & paru(153+10*ihigg)**2
25167 IF(i.EQ.12) wid2=wids(17,1)
25168
25169 ELSEIF(i.EQ.13) THEN
25170C...h0 -> g + g; quark loop contribution only
25171 etare=0d0
25172 etaim=0d0
25173 DO 240 j=1,2*mstp(1)
25174 eps=(2d0*pmas(j,1))**2/sh
25175C...Loop integral; function of eps=4m^2/shat; different for A0.
25176 IF(eps.LE.1d0) THEN
25177 IF(eps.GT.1d-4) THEN
25178 root=sqrt(1d0-eps)
25179 rln=log((1d0+root)/(1d0-root))
25180 ELSE
25181 rln=log(4d0/eps-2d0)
25182 ENDIF
25183 phire=-0.25d0*(rln**2-paru(1)**2)
25184 phiim=0.5d0*paru(1)*rln
25185 ELSE
25186 phire=(asin(1d0/sqrt(eps)))**2
25187 phiim=0d0
25188 ENDIF
25189 IF(ihigg.LE.2) THEN
25190 etarej=-0.5d0*eps*(1d0+(1d0-eps)*phire)
25191 etaimj=-0.5d0*eps*(1d0-eps)*phiim
25192 ELSE
25193 etarej=-0.5d0*eps*phire
25194 etaimj=-0.5d0*eps*phiim
25195 ENDIF
25196C...Couplings (=1 for standard model Higgs).
25197 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25198 IF(mod(j,2).EQ.1) THEN
25199 etarej=etarej*paru(151+10*ihigg)
25200 etaimj=etaimj*paru(151+10*ihigg)
25201 ELSE
25202 etarej=etarej*paru(152+10*ihigg)
25203 etaimj=etaimj*paru(152+10*ihigg)
25204 ENDIF
25205 ENDIF
25206 etare=etare+etarej
25207 etaim=etaim+etaimj
25208 240 CONTINUE
25209 eta2=etare**2+etaim**2
25210 wdtp(i)=fac*(as/paru(1))**2*eta2
25211
25212 ELSEIF(i.EQ.14) THEN
25213C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25214 etare=0d0
25215 etaim=0d0
25216 jmax=3*mstp(1)+1
25217 IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
25218 DO 250 j=1,jmax
25219 IF(j.LE.2*mstp(1)) THEN
25220 ej=kchg(j,1)/3d0
25221 eps=(2d0*pmas(j,1))**2/sh
25222 ELSEIF(j.LE.3*mstp(1)) THEN
25223 jl=2*(j-2*mstp(1))-1
25224 ej=kchg(10+jl,1)/3d0
25225 eps=(2d0*pmas(10+jl,1))**2/sh
25226 ELSEIF(j.EQ.3*mstp(1)+1) THEN
25227 eps=(2d0*pmas(24,1))**2/sh
25228 ELSE
25229 eps=(2d0*pmas(37,1))**2/sh
25230 ENDIF
25231C...Loop integral; function of eps=4m^2/shat.
25232 IF(eps.LE.1d0) THEN
25233 IF(eps.GT.1d-4) THEN
25234 root=sqrt(1d0-eps)
25235 rln=log((1d0+root)/(1d0-root))
25236 ELSE
25237 rln=log(4d0/eps-2d0)
25238 ENDIF
25239 phire=-0.25d0*(rln**2-paru(1)**2)
25240 phiim=0.5d0*paru(1)*rln
25241 ELSE
25242 phire=(asin(1d0/sqrt(eps)))**2
25243 phiim=0d0
25244 ENDIF
25245 IF(j.LE.3*mstp(1)) THEN
25246C...Fermion loops: loop integral different for A0; charges.
25247 IF(ihigg.LE.2) THEN
25248 phipre=-0.5d0*eps*(1d0+(1d0-eps)*phire)
25249 phipim=-0.5d0*eps*(1d0-eps)*phiim
25250 ELSE
25251 phipre=-0.5d0*eps*phire
25252 phipim=-0.5d0*eps*phiim
25253 ENDIF
25254 IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
25255 ejc=3d0*ej**2
25256 ejh=paru(151+10*ihigg)
25257 ELSEIF(j.LE.2*mstp(1)) THEN
25258 ejc=3d0*ej**2
25259 ejh=paru(152+10*ihigg)
25260 ELSE
25261 ejc=ej**2
25262 ejh=paru(153+10*ihigg)
25263 ENDIF
25264 IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
25265 etarej=ejc*ejh*phipre
25266 etaimj=ejc*ejh*phipim
25267 ELSEIF(j.EQ.3*mstp(1)+1) THEN
25268C...W loops: loop integral and charges.
25269 etarej=0.5d0+0.75d0*eps*(1d0+(2d0-eps)*phire)
25270 etaimj=0.75d0*eps*(2d0-eps)*phiim
25271 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25272 etarej=etarej*paru(155+10*ihigg)
25273 etaimj=etaimj*paru(155+10*ihigg)
25274 ENDIF
25275 ELSE
25276C...Charged H loops: loop integral and charges.
25277 fachhh=(pmas(24,1)/pmas(37,1))**2*
25278 & paru(158+10*ihigg+2*(ihigg/3))
25279 etarej=eps*(1d0-eps*phire)*fachhh
25280 etaimj=-eps**2*phiim*fachhh
25281 ENDIF
25282 etare=etare+etarej
25283 etaim=etaim+etaimj
25284 250 CONTINUE
25285 eta2=etare**2+etaim**2
25286 wdtp(i)=fac*(aem/paru(1))**2*0.5d0*eta2
25287
25288 ELSEIF(i.EQ.15) THEN
25289C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25290 etare=0d0
25291 etaim=0d0
25292 jmax=3*mstp(1)+1
25293 IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1
25294 DO 260 j=1,jmax
25295 IF(j.LE.2*mstp(1)) THEN
25296 ej=kchg(j,1)/3d0
25297 aj=sign(1d0,ej+0.1d0)
25298 vj=aj-4d0*ej*xwv
25299 eps=(2d0*pmas(j,1))**2/sh
25300 epsp=(2d0*pmas(j,1)/pmas(23,1))**2
25301 ELSEIF(j.LE.3*mstp(1)) THEN
25302 jl=2*(j-2*mstp(1))-1
25303 ej=kchg(10+jl,1)/3d0
25304 aj=sign(1d0,ej+0.1d0)
25305 vj=aj-4d0*ej*xwv
25306 eps=(2d0*pmas(10+jl,1))**2/sh
25307 epsp=(2d0*pmas(10+jl,1)/pmas(23,1))**2
25308 ELSE
25309 eps=(2d0*pmas(24,1))**2/sh
25310 epsp=(2d0*pmas(24,1)/pmas(23,1))**2
25311 ENDIF
25312C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25313 IF(eps.LE.1d0) THEN
25314 root=sqrt(1d0-eps)
25315 IF(eps.GT.1d-4) THEN
25316 rln=log((1d0+root)/(1d0-root))
25317 ELSE
25318 rln=log(4d0/eps-2d0)
25319 ENDIF
25320 phire=-0.25d0*(rln**2-paru(1)**2)
25321 phiim=0.5d0*paru(1)*rln
25322 psire=0.5d0*root*rln
25323 psiim=-0.5d0*root*paru(1)
25324 ELSE
25325 phire=(asin(1d0/sqrt(eps)))**2
25326 phiim=0d0
25327 psire=sqrt(eps-1d0)*asin(1d0/sqrt(eps))
25328 psiim=0d0
25329 ENDIF
25330 IF(epsp.LE.1d0) THEN
25331 root=sqrt(1d0-epsp)
25332 IF(epsp.GT.1d-4) THEN
25333 rln=log((1d0+root)/(1d0-root))
25334 ELSE
25335 rln=log(4d0/epsp-2d0)
25336 ENDIF
25337 phirep=-0.25d0*(rln**2-paru(1)**2)
25338 phiimp=0.5d0*paru(1)*rln
25339 psirep=0.5d0*root*rln
25340 psiimp=-0.5d0*root*paru(1)
25341 ELSE
25342 phirep=(asin(1d0/sqrt(epsp)))**2
25343 phiimp=0d0
25344 psirep=sqrt(epsp-1d0)*asin(1d0/sqrt(epsp))
25345 psiimp=0d0
25346 ENDIF
25347 fxyre=eps*epsp/(8d0*(eps-epsp))*(1d0+eps*epsp/(eps-epsp)*
25348 & (phire-phirep)+2d0*eps/(eps-epsp)*(psire-psirep))
25349 fxyim=eps**2*epsp/(8d0*(eps-epsp)**2)*
25350 & (epsp*(phiim-phiimp)+2d0*(psiim-psiimp))
25351 f1re=-eps*epsp/(2d0*(eps-epsp))*(phire-phirep)
25352 f1im=-eps*epsp/(2d0*(eps-epsp))*(phiim-phiimp)
25353 IF(j.LE.3*mstp(1)) THEN
25354C...Fermion loops: loop integral different for A0; charges.
25355 IF(ihigg.EQ.3) fxyre=0d0
25356 IF(ihigg.EQ.3) fxyim=0d0
25357 IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN
25358 ejc=-3d0*ej*vj
25359 ejh=paru(151+10*ihigg)
25360 ELSEIF(j.LE.2*mstp(1)) THEN
25361 ejc=-3d0*ej*vj
25362 ejh=paru(152+10*ihigg)
25363 ELSE
25364 ejc=-ej*vj
25365 ejh=paru(153+10*ihigg)
25366 ENDIF
25367 IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0
25368 etarej=ejc*ejh*(fxyre-0.25d0*f1re)
25369 etaimj=ejc*ejh*(fxyim-0.25d0*f1im)
25370 ELSEIF(j.EQ.3*mstp(1)+1) THEN
25371C...W loops: loop integral and charges.
25372 heps=(1d0+2d0/eps)*xw/xw1-(5d0+2d0/eps)
25373 etarej=-xw1*((3d0-xw/xw1)*f1re+heps*fxyre)
25374 etaimj=-xw1*((3d0-xw/xw1)*f1im+heps*fxyim)
25375 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
25376 etarej=etarej*paru(155+10*ihigg)
25377 etaimj=etaimj*paru(155+10*ihigg)
25378 ENDIF
25379 ELSE
25380C...Charged H loops: loop integral and charges.
25381 fachhh=(pmas(24,1)/pmas(37,1))**2*(1d0-2d0*xw)*
25382 & paru(158+10*ihigg+2*(ihigg/3))
25383 etarej=fachhh*fxyre
25384 etaimj=fachhh*fxyim
25385 ENDIF
25386 etare=etare+etarej
25387 etaim=etaim+etaimj
25388 260 CONTINUE
25389 eta2=(etare**2+etaim**2)/(xw*xw1)
25390 wdtp(i)=fac*(aem/paru(1))**2*(1d0-pmas(23,1)**2/sh)**3*eta2
25391 wid2=wids(23,2)
25392
25393 ELSEIF(i.LE.17) THEN
25394C...h0 -> Z0 + Z0, W+ + W-
25395 pm1=pmas(iabs(kfdp(idc,1)),1)
25396 pg1=pmas(iabs(kfdp(idc,1)),2)
25397 IF(mint(62).GE.1) THEN
25398 IF(mstp(42).EQ.0.OR.(4d0*(pm1+10d0*pg1)**2.LT.sh.AND.
25399 & ckin(46).LT.ckin(45).AND.ckin(48).LT.ckin(47).AND.
25400 & max(ckin(45),ckin(47)).LT.pm1-10d0*pg1)) THEN
25401 mofsv(ihigg,i-15)=0
25402 widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
25403 & 1d0-4d0*rm1))
25404 wid2=1d0
25405 ELSE
25406 mofsv(ihigg,i-15)=1
25407 rmas=sqrt(max(0d0,sh))
25408 CALL pyofsh(1,kfla,kfdp(idc,1),kfdp(idc,2),rmas,widw,
25409 & wid2)
25410 widwsv(ihigg,i-15)=widw
25411 wid2sv(ihigg,i-15)=wid2
25412 ENDIF
25413 ELSE
25414 IF(mofsv(ihigg,i-15).EQ.0) THEN
25415 widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,
25416 & 1d0-4d0*rm1))
25417 wid2=1d0
25418 ELSE
25419 widw=widwsv(ihigg,i-15)
25420 wid2=wid2sv(ihigg,i-15)
25421 ENDIF
25422 ENDIF
25423 wdtp(i)=fac*widw/(2d0*(18-i))
25424 IF(mstp(49).NE.0) wdtp(i)=wdtp(i)*pmas(kfhigg,1)**2/shfs
25425 IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*
25426 & paru(138+i+10*ihigg)**2
25427 wid2=wid2*wids(7+i,1)
25428
25429 ELSEIF(i.EQ.18.AND.ihigg.GE.2) THEN
25430C...H0 -> Z0 + h0, A0-> Z0 + h0
25431 wdtp(i)=fac*0.5d0*sqrt(max(0d0,
25432 & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25433 IF(ihigg.EQ.2) THEN
25434 wdtp(i)=wdtp(i)*paru(179)**2
25435 ELSEIF(ihigg.EQ.3) THEN
25436 wdtp(i)=wdtp(i)*paru(186)**2
25437 ENDIF
25438 wid2=wids(23,2)*wids(25,2)
25439
25440 ELSEIF(i.EQ.19.AND.ihigg.GE.2) THEN
25441C...H0 -> h0 + h0, A0-> h0 + h0
25442 wdtp(i)=fac*0.25d0*
25443 & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
25444 IF(ihigg.EQ.2) THEN
25445 wdtp(i)=wdtp(i)*paru(176)**2
25446 ELSEIF(ihigg.EQ.3) THEN
25447 wdtp(i)=wdtp(i)*paru(169)**2
25448 ENDIF
25449 wid2=wids(25,1)
25450 ELSEIF((i.EQ.20.OR.i.EQ.21).AND.ihigg.GE.2) THEN
25451C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25452 wdtp(i)=fac*0.5d0*sqrt(max(0d0,
25453 & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25454 & *paru(195+ihigg)**2
25455 IF(i.EQ.20) THEN
25456 wid2=wids(24,2)*wids(37,3)
25457 ELSEIF(i.EQ.21) THEN
25458 wid2=wids(24,3)*wids(37,2)
25459 ENDIF
25460
25461 ELSEIF(i.EQ.22.AND.ihigg.EQ.2) THEN
25462C...H0 -> Z0 + A0.
25463 wdtp(i)=fac*0.5d0*paru(187)**2*sqrt(max(0d0,
25464 & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25465 wid2=wids(36,2)*wids(23,2)
25466
25467 ELSEIF(i.EQ.23.AND.ihigg.EQ.2) THEN
25468C...H0 -> h0 + A0.
25469 wdtp(i)=fac*0.5d0*paru(180)**2*
25470 & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
25471 wid2=wids(25,2)*wids(36,2)
25472
25473 ELSEIF(i.EQ.24.AND.ihigg.EQ.2) THEN
25474C...H0 -> A0 + A0
25475 wdtp(i)=fac*0.25d0*paru(177)**2*
25476 & pmas(23,1)**4/sh**2*sqrt(max(0d0,1d0-4d0*rm1))
25477 wid2=wids(36,1)
25478
25479CMRENNA++
25480 ELSE
25481C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25482 rm10=rm1*sh/pmr**2
25483 rm20=rm2*sh/pmr**2
25484 wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
25485 wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
25486 IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
25487 wfac=0d0
25488 ELSE
25489 wfac=wfac/wfac0
25490 ENDIF
25491 wdtp(i)=pmas(kfla,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
25492CMRENNA--
25493 IF(kfc2.EQ.kfc1) THEN
25494 wid2=wids(kfc1,1)
25495 ELSE
25496 ksgn1=2
25497 IF(kfdp(idc,1).LT.0) ksgn1=3
25498 ksgn2=2
25499 IF(kfdp(idc,2).LT.0) ksgn2=3
25500 wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
25501 ENDIF
25502 ENDIF
25503 wdtp(i)=fudge*wdtp(i)
25504 wdtp(0)=wdtp(0)+wdtp(i)
25505 IF(mdme(idc,1).GT.0) THEN
25506 wdte(i,mdme(idc,1))=wdtp(i)*wid2
25507 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25508 wdte(i,0)=wdte(i,mdme(idc,1))
25509 wdte(0,0)=wdte(0,0)+wdte(i,0)
25510 ENDIF
25511 270 CONTINUE
25512
25513 ELSEIF(kfla.EQ.32) THEN
25514C...Z'0:
25515 icase=1
25516 xwc=1d0/(16d0*xw*xw1)
25517 fac=(aem*xwc/3d0)*shr
25518 vint(117)=0d0
25519 280 CONTINUE
25520 IF(mint(61).GE.1.AND.icase.EQ.2) THEN
25521 vint(111)=0d0
25522 vint(112)=0d0
25523 vint(113)=0d0
25524 vint(114)=0d0
25525 vint(115)=0d0
25526 vint(116)=0d0
25527 ENDIF
25528 IF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25529 kfai=iabs(mint(15))
25530 ei=kchg(kfai,1)/3d0
25531 ai=sign(1d0,ei+0.1d0)
25532 vi=ai-4d0*ei*xwv
25533 kfaic=1
25534 IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2
25535 IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3
25536 IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4
25537 IF(kfai.LE.2.OR.kfai.EQ.11.OR.kfai.EQ.12) THEN
25538 vpi=paru(119+2*kfaic)
25539 api=paru(120+2*kfaic)
25540 ELSEIF(kfai.LE.4.OR.kfai.EQ.13.OR.kfai.EQ.14) THEN
25541 vpi=parj(178+2*kfaic)
25542 api=parj(179+2*kfaic)
25543 ELSE
25544 vpi=parj(186+2*kfaic)
25545 api=parj(187+2*kfaic)
25546 ENDIF
25547 sqmz=pmas(23,1)**2
25548 hz=shr*vint(117)
25549 sqmzp=pmas(32,1)**2
25550 hzp=shr*wdtp(0)
25551 IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
25552 & mstp(44).EQ.7) vint(111)=1d0
25553 IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=
25554 & 2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)
25555 IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=
25556 & 2d0*xwc*sh*(sh-sqmzp)/((sh-sqmzp)**2+hzp**2)
25557 IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
25558 & mstp(44).EQ.7) vint(114)=xwc**2*sh**2/((sh-sqmz)**2+hz**2)
25559 IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=
25560 & 2d0*xwc**2*sh**2*((sh-sqmz)*(sh-sqmzp)+hz*hzp)/
25561 & (((sh-sqmz)**2+hz**2)*((sh-sqmzp)**2+hzp**2))
25562 IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
25563 & mstp(44).EQ.7) vint(116)=xwc**2*sh**2/((sh-sqmzp)**2+hzp**2)
25564 ENDIF
25565 DO 290 i=1,mdcy(kc,3)
25566 idc=i+mdcy(kc,2)-1
25567 IF(mdme(idc,1).LT.0) GOTO 290
25568 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25569 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25570 IF(sqrt(rm1)+sqrt(rm2).GT.1d0.OR.mdme(idc,1).LT.0) GOTO 290
25571 wid2=1d0
25572 IF(i.LE.16) THEN
25573 IF(i.LE.8) THEN
25574C...Z'0 -> q + qbar
25575 ef=kchg(i,1)/3d0
25576 af=sign(1d0,ef+0.1d0)
25577 vf=af-4d0*ef*xwv
25578 IF(i.LE.2) THEN
25579 vpf=paru(123-2*mod(i,2))
25580 apf=paru(124-2*mod(i,2))
25581 ELSEIF(i.LE.4) THEN
25582 vpf=parj(182-2*mod(i,2))
25583 apf=parj(183-2*mod(i,2))
25584 ELSE
25585 vpf=parj(190-2*mod(i,2))
25586 apf=parj(191-2*mod(i,2))
25587 ENDIF
25588 fcof=3d0*radc
25589 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*
25590 & pyhfth(sh,sh*rm1,1d0)
25591 IF(i.EQ.6) wid2=wids(6,1)
25592 IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)
25593 ELSEIF(i.LE.16) THEN
25594C...Z'0 -> l+ + l-, nu + nubar
25595 ef=kchg(i+2,1)/3d0
25596 af=sign(1d0,ef+0.1d0)
25597 vf=af-4d0*ef*xwv
25598 IF(i.LE.10) THEN
25599 vpf=paru(127-2*mod(i,2))
25600 apf=paru(128-2*mod(i,2))
25601 ELSEIF(i.LE.12) THEN
25602 vpf=parj(186-2*mod(i,2))
25603 apf=parj(187-2*mod(i,2))
25604 ELSE
25605 vpf=parj(194-2*mod(i,2))
25606 apf=parj(195-2*mod(i,2))
25607 ENDIF
25608 fcof=1d0
25609 IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)
25610 ENDIF
25611 be34=sqrt(max(0d0,1d0-4d0*rm1))
25612 IF(icase.EQ.1) THEN
25613 wdtpz=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
25614 wdtp(i)=fac*fcof*(vpf**2*(1d0+2d0*rm1)+
25615 & apf**2*(1d0-4d0*rm1))*be34
25616 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25617 wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*
25618 & ef*vf+ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*
25619 & vf**2+(vi*vpi+ai*api)*vint(115)*vf*vpf+(vpi**2+api**2)*
25620 & vint(116)*vpf**2)*(1d0+2d0*rm1)+((vi**2+ai**2)*vint(114)*
25621 & af**2+(vi*vpi+ai*api)*vint(115)*af*apf+(vpi**2+api**2)*
25622 & vint(116)*apf**2)*(1d0-4d0*rm1))*be34
25623 ELSEIF(mint(61).EQ.2) THEN
25624 fggf=fcof*ef**2*(1d0+2d0*rm1)*be34
25625 fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34
25626 fgzpf=fcof*ef*vpf*(1d0+2d0*rm1)*be34
25627 fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34
25628 fzzpf=fcof*(vf*vpf*(1d0+2d0*rm1)+af*apf*(1d0-4d0*rm1))*
25629 & be34
25630 fzpzpf=fcof*(vpf**2*(1d0+2d0*rm1)+apf**2*(1d0-4d0*rm1))*
25631 & be34
25632 ENDIF
25633 ELSEIF(i.EQ.17) THEN
25634C...Z'0 -> W+ + W-
25635 wdtpzp=paru(129)**2*xw1**2*
25636 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
25637 & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
25638 IF(icase.EQ.1) THEN
25639 wdtpz=0d0
25640 wdtp(i)=fac*wdtpzp
25641 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25642 wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
25643 ELSEIF(mint(61).EQ.2) THEN
25644 fggf=0d0
25645 fgzf=0d0
25646 fgzpf=0d0
25647 fzzf=0d0
25648 fzzpf=0d0
25649 fzpzpf=wdtpzp
25650 ENDIF
25651 wid2=wids(24,1)
25652 ELSEIF(i.EQ.18) THEN
25653C...Z'0 -> H+ + H-
25654 czc=2d0*(1d0-2d0*xw)
25655 be34c=(1d0-4d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))
25656 IF(icase.EQ.1) THEN
25657 wdtpz=0.25d0*paru(142)**2*czc**2*be34c
25658 wdtp(i)=fac*0.25d0*paru(143)**2*czc**2*be34c
25659 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25660 wdtp(i)=fac*0.25d0*(ei**2*vint(111)+paru(142)*ei*vi*
25661 & vint(112)*czc+paru(143)*ei*vpi*vint(113)*czc+paru(142)**2*
25662 & (vi**2+ai**2)*vint(114)*czc**2+paru(142)*paru(143)*
25663 & (vi*vpi+ai*api)*vint(115)*czc**2+paru(143)**2*
25664 & (vpi**2+api**2)*vint(116)*czc**2)*be34c
25665 ELSEIF(mint(61).EQ.2) THEN
25666 fggf=0.25d0*be34c
25667 fgzf=0.25d0*paru(142)*czc*be34c
25668 fgzpf=0.25d0*paru(143)*czc*be34c
25669 fzzf=0.25d0*paru(142)**2*czc**2*be34c
25670 fzzpf=0.25d0*paru(142)*paru(143)*czc**2*be34c
25671 fzpzpf=0.25d0*paru(143)**2*czc**2*be34c
25672 ENDIF
25673 wid2=wids(37,1)
25674 ELSEIF(i.EQ.19) THEN
25675C...Z'0 -> Z0 + gamma.
25676 ELSEIF(i.EQ.20) THEN
25677C...Z'0 -> Z0 + h0
25678 flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25679 wdtpzp=paru(145)**2*4d0*abs(1d0-2d0*xw)*
25680 & (3d0*rm1+0.25d0*flam**2)*flam
25681 IF(icase.EQ.1) THEN
25682 wdtpz=0d0
25683 wdtp(i)=fac*wdtpzp
25684 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25685 wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp
25686 ELSEIF(mint(61).EQ.2) THEN
25687 fggf=0d0
25688 fgzf=0d0
25689 fgzpf=0d0
25690 fzzf=0d0
25691 fzzpf=0d0
25692 fzpzpf=wdtpzp
25693 ENDIF
25694 wid2=wids(23,2)*wids(25,2)
25695 ELSEIF(i.EQ.21.OR.i.EQ.22) THEN
25696C...Z' -> h0 + A0 or H0 + A0.
25697 be34c=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25698 IF(i.EQ.21) THEN
25699 czah=paru(186)
25700 czpah=paru(188)
25701 ELSE
25702 czah=paru(187)
25703 czpah=paru(189)
25704 ENDIF
25705 IF(icase.EQ.1) THEN
25706 wdtpz=czah**2*be34c
25707 wdtp(i)=fac*czpah**2*be34c
25708 ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN
25709 wdtp(i)=fac*(czah**2*(vi**2+ai**2)*vint(114)+czah*czpah*
25710 & (vi*vpi+ai*api)*vint(115)+czpah**2*(vpi**2+api**2)*
25711 & vint(116))*be34c
25712 ELSEIF(mint(61).EQ.2) THEN
25713 fggf=0d0
25714 fgzf=0d0
25715 fgzpf=0d0
25716 fzzf=czah**2*be34c
25717 fzzpf=czah*czpah*be34c
25718 fzpzpf=czpah**2*be34c
25719 ENDIF
25720 IF(i.EQ.21) wid2=wids(25,2)*wids(36,2)
25721 IF(i.EQ.22) wid2=wids(35,2)*wids(36,2)
25722 ENDIF
25723 IF(icase.EQ.1) THEN
25724 vint(117)=vint(117)+fac*wdtpz
25725 wdtp(i)=fudge*wdtp(i)
25726 wdtp(0)=wdtp(0)+wdtp(i)
25727 ENDIF
25728 IF(mdme(idc,1).GT.0) THEN
25729 IF((icase.EQ.1.AND.mint(61).NE.1).OR.
25730 & (icase.EQ.2.AND.mint(61).EQ.1)) THEN
25731 wdte(i,mdme(idc,1))=wdtp(i)*wid2
25732 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+
25733 & wdte(i,mdme(idc,1))
25734 wdte(i,0)=wdte(i,mdme(idc,1))
25735 wdte(0,0)=wdte(0,0)+wdte(i,0)
25736 ENDIF
25737 IF(mint(61).EQ.2.AND.icase.EQ.2) THEN
25738 IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.
25739 & mstp(44).EQ.7) vint(111)=vint(111)+fggf*wid2
25740 IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=vint(112)+
25741 & fgzf*wid2
25742 IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=vint(113)+
25743 & fgzpf*wid2
25744 IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.
25745 & mstp(44).EQ.7) vint(114)=vint(114)+fzzf*wid2
25746 IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=vint(115)+
25747 & fzzpf*wid2
25748 IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.
25749 & mstp(44).EQ.7) vint(116)=vint(116)+fzpzpf*wid2
25750 ENDIF
25751 ENDIF
25752 290 CONTINUE
25753 IF(mint(61).GE.1) icase=3-icase
25754 IF(icase.EQ.2) GOTO 280
25755
25756 ELSEIF(kfla.EQ.34) THEN
25757C...W'+/-:
25758 fac=(aem/(24d0*xw))*shr
25759 DO 300 i=1,mdcy(kc,3)
25760 idc=i+mdcy(kc,2)-1
25761 IF(mdme(idc,1).LT.0) GOTO 300
25762 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25763 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25764 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 300
25765 wid2=1d0
25766 IF(i.LE.20) THEN
25767 IF(i.LE.16) THEN
25768C...W'+/- -> q + qbar'
25769 fcof=3d0*radc*(paru(131)**2+paru(132)**2)*
25770 & vckm((i-1)/4+1,mod(i-1,4)+1)
25771 IF(kflr.GT.0) THEN
25772 IF(mod(i,4).EQ.3) wid2=wids(6,2)
25773 IF(mod(i,4).EQ.0) wid2=wids(8,2)
25774 IF(i.GE.13) wid2=wid2*wids(7,3)
25775 ELSE
25776 IF(mod(i,4).EQ.3) wid2=wids(6,3)
25777 IF(mod(i,4).EQ.0) wid2=wids(8,3)
25778 IF(i.GE.13) wid2=wid2*wids(7,2)
25779 ENDIF
25780 ELSEIF(i.LE.20) THEN
25781C...W'+/- -> l+/- + nu
25782 fcof=paru(133)**2+paru(134)**2
25783 IF(kflr.GT.0) THEN
25784 IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)
25785 ELSE
25786 IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)
25787 ENDIF
25788 ENDIF
25789 wdtp(i)=fac*fcof*0.5d0*(2d0-rm1-rm2-(rm1-rm2)**2)*
25790 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25791 ELSEIF(i.EQ.21) THEN
25792C...W'+/- -> W+/- + Z0
25793 wdtp(i)=fac*paru(135)**2*0.5d0*xw1*(rm1/rm2)*
25794 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
25795 & (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)
25796 IF(kflr.GT.0) wid2=wids(24,2)*wids(23,2)
25797 IF(kflr.LT.0) wid2=wids(24,3)*wids(23,2)
25798 ELSEIF(i.EQ.23) THEN
25799C...W'+/- -> W+/- + h0
25800 flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25801 wdtp(i)=fac*paru(146)**2*2d0*(3d0*rm1+0.25d0*flam**2)*flam
25802 IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
25803 IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
25804 ENDIF
25805 wdtp(i)=fudge*wdtp(i)
25806 wdtp(0)=wdtp(0)+wdtp(i)
25807 IF(mdme(idc,1).GT.0) THEN
25808 wdte(i,mdme(idc,1))=wdtp(i)*wid2
25809 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25810 wdte(i,0)=wdte(i,mdme(idc,1))
25811 wdte(0,0)=wdte(0,0)+wdte(i,0)
25812 ENDIF
25813 300 CONTINUE
25814
25815 ELSEIF(kfla.EQ.37) THEN
25816C...H+/-:
25817C IF(MSTP(49).EQ.0) THEN
25818 shfs=sh
25819C ELSE
25820C SHFS=PMAS(37,1)**2
25821C ENDIF
25822 fac=(aem/(8d0*xw))*(shfs/pmas(24,1)**2)*shr
25823 DO 310 i=1,mdcy(kc,3)
25824 idc=i+mdcy(kc,2)-1
25825 IF(mdme(idc,1).LT.0) GOTO 310
25826 kfc1=pycomp(kfdp(idc,1))
25827 kfc2=pycomp(kfdp(idc,2))
25828 rm1=pmas(kfc1,1)**2/sh
25829 rm2=pmas(kfc2,1)**2/sh
25830 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 310
25831 wid2=1d0
25832 IF(i.LE.4) THEN
25833C...H+/- -> q + qbar'
25834 rm1r=pymrun(kfdp(idc,1),sh)**2/sh
25835 rm2r=pymrun(kfdp(idc,2),sh)**2/sh
25836 wdtp(i)=fac*3d0*radc*max(0d0,(rm1r*paru(141)**2+
25837 & rm2r/paru(141)**2)*(1d0-rm1r-rm2r)-4d0*rm1r*rm2r)*
25838 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*(sh/shfs)
25839 IF(kflr.GT.0) THEN
25840 IF(i.EQ.3) wid2=wids(6,2)
25841 IF(i.EQ.4) wid2=wids(7,3)*wids(8,2)
25842 ELSE
25843 IF(i.EQ.3) wid2=wids(6,3)
25844 IF(i.EQ.4) wid2=wids(7,2)*wids(8,3)
25845 ENDIF
25846 ELSEIF(i.LE.8) THEN
25847C...H+/- -> l+/- + nu
25848 wdtp(i)=fac*((rm1*paru(141)**2+rm2/paru(141)**2)*
25849 & (1d0-rm1-rm2)-4d0*rm1*rm2)*sqrt(max(0d0,
25850 & (1d0-rm1-rm2)**2-4d0*rm1*rm2))*(sh/shfs)
25851 IF(kflr.GT.0) THEN
25852 IF(i.EQ.8) wid2=wids(17,3)*wids(18,2)
25853 ELSE
25854 IF(i.EQ.8) wid2=wids(17,2)*wids(18,3)
25855 ENDIF
25856 ELSEIF(i.EQ.9) THEN
25857C...H+/- -> W+/- + h0.
25858 wdtp(i)=fac*paru(195)**2*0.5d0*sqrt(max(0d0,
25859 & (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25860 IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)
25861 IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)
25862
25863CMRENNA++
25864 ELSE
25865C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25866 rm10=rm1*sh/pmr**2
25867 rm20=rm2*sh/pmr**2
25868 wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)
25869 wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)
25870 IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN
25871 wfac=0d0
25872 ELSE
25873 wfac=wfac/wfac0
25874 ENDIF
25875 wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)*sqrt(wfac)
25876CMRENNA--
25877 ksgn1=2
25878 IF(kfls*kfdp(idc,1).LT.0.AND.kchg(kfc1,3).EQ.1) ksgn1=3
25879 ksgn2=2
25880 IF(kfls*kfdp(idc,2).LT.0.AND.kchg(kfc2,3).EQ.1) ksgn2=3
25881 wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)
25882 ENDIF
25883 wdtp(i)=fudge*wdtp(i)
25884 wdtp(0)=wdtp(0)+wdtp(i)
25885 IF(mdme(idc,1).GT.0) THEN
25886 wdte(i,mdme(idc,1))=wdtp(i)*wid2
25887 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25888 wdte(i,0)=wdte(i,mdme(idc,1))
25889 wdte(0,0)=wdte(0,0)+wdte(i,0)
25890 ENDIF
25891 310 CONTINUE
25892
25893 ELSEIF(kfla.EQ.41) THEN
25894C...R:
25895 fac=(aem/(12d0*xw))*shr
25896 DO 320 i=1,mdcy(kc,3)
25897 idc=i+mdcy(kc,2)-1
25898 IF(mdme(idc,1).LT.0) GOTO 320
25899 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25900 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25901 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 320
25902 wid2=1d0
25903 IF(i.LE.6) THEN
25904C...R -> q + qbar'
25905 fcof=3d0*radc
25906 ELSEIF(i.LE.9) THEN
25907C...R -> l+ + l'-
25908 fcof=1d0
25909 ENDIF
25910 wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
25911 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
25912 IF(kflr.GT.0) THEN
25913 IF(i.EQ.4) wid2=wids(6,3)
25914 IF(i.EQ.5) wid2=wids(7,3)
25915 IF(i.EQ.6) wid2=wids(6,2)*wids(8,3)
25916 IF(i.EQ.9) wid2=wids(17,3)
25917 ELSE
25918 IF(i.EQ.4) wid2=wids(6,2)
25919 IF(i.EQ.5) wid2=wids(7,2)
25920 IF(i.EQ.6) wid2=wids(6,3)*wids(8,2)
25921 IF(i.EQ.9) wid2=wids(17,2)
25922 ENDIF
25923 wdtp(i)=fudge*wdtp(i)
25924 wdtp(0)=wdtp(0)+wdtp(i)
25925 IF(mdme(idc,1).GT.0) THEN
25926 wdte(i,mdme(idc,1))=wdtp(i)*wid2
25927 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25928 wdte(i,0)=wdte(i,mdme(idc,1))
25929 wdte(0,0)=wdte(0,0)+wdte(i,0)
25930 ENDIF
25931 320 CONTINUE
25932
25933 ELSEIF(kfla.EQ.42) THEN
25934C...LQ (leptoquark).
25935 fac=(aem/4d0)*paru(151)*shr
25936 DO 330 i=1,mdcy(kc,3)
25937 idc=i+mdcy(kc,2)-1
25938 IF(mdme(idc,1).LT.0) GOTO 330
25939 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
25940 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
25941 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 330
25942 wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
25943 wid2=1d0
25944 ilqq=kfdp(idc,1)*isign(1,kflr)
25945 IF(ilqq.GE.6) wid2=wids(ilqq,2)
25946 IF(ilqq.LE.-6) wid2=wids(-ilqq,3)
25947 ilql=kfdp(idc,2)*isign(1,kflr)
25948 IF(ilql.GE.17) wid2=wid2*wids(ilql,2)
25949 IF(ilql.LE.-17) wid2=wid2*wids(-ilql,3)
25950 wdtp(i)=fudge*wdtp(i)
25951 wdtp(0)=wdtp(0)+wdtp(i)
25952 IF(mdme(idc,1).GT.0) THEN
25953 wdte(i,mdme(idc,1))=wdtp(i)*wid2
25954 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
25955 wdte(i,0)=wdte(i,mdme(idc,1))
25956 wdte(0,0)=wdte(0,0)+wdte(i,0)
25957 ENDIF
25958 330 CONTINUE
25959
25960C...UED: kk state width decays : flav: 451 476
25961 ELSEIF(iued(1).EQ.1.AND.
25962 & pycomp(abs(kfla)).GE.kkflmi.AND.
25963 & pycomp(abs(kfla)).LE.kkflma) THEN
25964 kcla=pycomp(kfla)
25965C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
25966 rmflas=pmas(kcla,1)
25967 facsh=sh/pmas(kcla,1)**2
25968 alphem=pyalem(rmflas**2)
25969 alphs=pyalps(rmflas**2)
25970
25971C...uedcor parameters (alpha_s is calculated at mkk scale)
25972C...alpha_em is calculated at z pole !
25973 alphem=paru(101)
25974 facsh=1.
25975
25976 DO 1070 i=1,mdcy(kcla,3)
25977 idc=i+mdcy(kcla,2)-1
25978
25979 IF(mdme(idc,1).LT.0) GOTO 1070
25980 kfc1=pycomp(abs(kfdp(idc,1)))
25981 kfc2=pycomp(abs(kfdp(idc,2)))
25982 rm1=pmas(kfc1,1)**2/sh
25983 rm2=pmas(kfc2,1)**2/sh
25984 IF(sqrt(rm1)+sqrt(rm2).GT.1d0)
25985 & GOTO 1070
25986 wid2=1d0
25987
25988C...N.B. RINV=RUED(1)
25989 rmkk=rued(1)
25990 rmwkk=pmas(475,1)
25991 rmzkk=pmas(474,1)
25992 sw2=paru(102)
25993 cw2=1.-sw2
25994 kkcla=kcla-kkflmi+1
25995 IF(abs(kfc1).GE.kkflmi)kkpart=kfc1
25996 IF(abs(kfc2).GE.kkflmi)kkpart=kfc2
25997 IF(kkcla.LE.6) THEN
25998C...q*_S -> q + gamma* (in first time sw21=0)
25999 fac=0.25*alphem*rmflas*0.5*cw21/cw2*kchg(kcla,1)**2/9.
26000C...Eventually change the following by enabling a choice of open or closed.
26001C...Only the gamma_kk channel is open.
26002 IF(mod(i,2).EQ.0)
26003 + wdtp(i)=fac*fkac2(rmflas,rmkk)*fkac1(rmkk,rmflas)**2
26004 wdtp(i)=facsh*wdtp(i)
26005 wid2=wids(473,2)
26006 ELSEIF(kkcla.GT.6.AND.kkcla.LE.12)THEN
26007C...q*_D -> q + Z*/W*
26008 fac=0.25*alphem*rmflas/(4.*sw2)
26009 gammaw=fac*fkac2(rmflas,rmwkk)*fkac1(rmwkk,rmflas)**2
26010 IF(i.EQ.1)THEN
26011C...q*_D -> q + Z*
26012 wdtp(i)=0.5*gammaw
26013 wid2=wids(474,2)
26014 ELSEIF(i.EQ.2)THEN
26015C...q*_D -> q + W*
26016 wdtp(i)=gammaw
26017 wid2=wids(475,2)
26018 ENDIF
26019 wdtp(i)=facsh*wdtp(i)
26020C...q*_D -> q + gamma* is closed
26021 ELSEIF(kkcla.GT.12.AND.kkcla.LE.21)THEN
26022C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26023 fac=alphem/4.*rmflas/cw2/8.
26024 rmgakk=pmas(473,1)
26025 wdtp(i)=fac*fkac2(rmflas,rmgakk)*
26026 + fkac1(rmgakk,rmflas)**2
26027 wdtp(i)=facsh*wdtp(i)
26028 wid2=wids(473,2)
26029 ELSEIF(kkcla.EQ.22)THEN
26030 rmqst=pmas(kkpart,1)
26031 wid2=wids(kkpart,2)
26032C...g* -> q*_S/q*_D + q
26033 fac=10.*alphs/12.*rmflas
26034 wdtp(i)=fac*fkac1(rmqst,rmflas)**2*fkac2(rmqst,rmflas)
26035 wdtp(i)=facsh*wdtp(i)
26036 ELSEIF(kkcla.EQ.23)THEN
26037C...gamma* decays to graviton + gamma : initial value is used
26038 ichi=iued(4)/2
26039 wdtp(i)=rmflas*(rmflas/rued(2))**(iued(4)+2)
26040 & *chidel(ichi)
26041 ELSEIF(kkcla.EQ.24)THEN
26042C...Z* -> l*_S + l is closed
26043C... Z* -> l*_D + l
26044 IF(i.LE.3)GOTO 1070
26045c... After closing the channels for a Z* decaying into positively charged
26046C... KK lepton singlets, close the channels for a Z* decaying into negatively
26047C... charged KK lepton singlets + positively charged SM particles
26048 IF(i.GE.10.AND.i.LE.12)GOTO 1070
26049 fac=3./2.*alphem/24./sw2*rmzkk
26050 rmlst=pmas(kkpart,1)
26051 wdtp(i)=fac*fkac1(rmlst,rmzkk)**2*fkac2(rmlst,rmzkk)
26052 wdtp(i)=facsh*wdtp(i)
26053 wid2=wids(kkpart,2)
26054 ELSEIF(kkcla.EQ.25)THEN
26055C...W* -> l*_D lbar
26056 fac=3.*alphem/12./sw2*rmwkk
26057 rmlst=pmas(kkpart,1)
26058 wdtp(i)=fac*fkac1(rmlst,rmwkk)**2*fkac2(rmlst,rmwkk)
26059 wdtp(i)=facsh*wdtp(i)
26060 wid2=wids(kkpart,2)
26061 ENDIF
26062 wdtp(0)=wdtp(0)+wdtp(i)
26063 IF(mdme(idc,1).GT.0) THEN
26064 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26065 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26066 wdte(i,0)=wdte(i,mdme(idc,1))
26067 wdte(0,0)=wdte(0,0)+wdte(i,0)
26068 ENDIF
26069 1070 CONTINUE
26070 iuedpr(kkcla)=1
26071
26072 ELSEIF(kfla.EQ.ktechn+111.OR.kfla.EQ.ktechn+221) THEN
26073C...Techni-pi0 and techni-pi0':
26074 fac=(1d0/(32d0*paru(1)*rtcm(1)**2))*shr
26075 DO 340 i=1,mdcy(kc,3)
26076 idc=i+mdcy(kc,2)-1
26077 IF(mdme(idc,1).LT.0) GOTO 340
26078 pm1=pmas(pycomp(kfdp(idc,1)),1)
26079 pm2=pmas(pycomp(kfdp(idc,2)),1)
26080 rm1=pm1**2/sh
26081 rm2=pm2**2/sh
26082 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 340
26083 wid2=1d0
26084C...pi_tc -> g + g
26085 IF(i.EQ.8) THEN
26086 facp=(as/(4d0*paru(1))*itcm(1)/rtcm(1))**2
26087 & /(8d0*paru(1))*sh*shr
26088 IF(kfla.EQ.ktechn+111) THEN
26089 facp=facp*rtcm(9)
26090 ELSE
26091 facp=facp*rtcm(10)
26092 ENDIF
26093 wdtp(i)=facp
26094 ELSE
26095C...pi_tc -> f + fbar.
26096 fcof=1d0
26097 ika=iabs(kfdp(idc,1))
26098 IF(ika.LT.10) fcof=3d0*radc
26099 hm1=pm1
26100 hm2=pm2
26101 IF(ika.GE.4.AND.ika.LE.6) THEN
26102 fcof=fcof*rtcm(1+ika)**2
26103 hm1=pymrun(kfdp(idc,1),sh)
26104 hm2=pymrun(kfdp(idc,2),sh)
26105 ELSEIF(ika.EQ.15) THEN
26106 fcof=fcof*rtcm(8)**2
26107 ENDIF
26108 wdtp(i)=fac*fcof*(hm1+hm2)**2*
26109 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26110 ENDIF
26111 wdtp(i)=fudge*wdtp(i)
26112 wdtp(0)=wdtp(0)+wdtp(i)
26113 IF(mdme(idc,1).GT.0) THEN
26114 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26115 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26116 wdte(i,0)=wdte(i,mdme(idc,1))
26117 wdte(0,0)=wdte(0,0)+wdte(i,0)
26118 ENDIF
26119 340 CONTINUE
26120
26121 ELSEIF(kfla.EQ.ktechn+211) THEN
26122C...pi+_tc
26123 fac=(1d0/(32d0*paru(1)*rtcm(1)**2))*shr
26124 DO 350 i=1,mdcy(kc,3)
26125 idc=i+mdcy(kc,2)-1
26126 IF(mdme(idc,1).LT.0) GOTO 350
26127 pm1=pmas(pycomp(kfdp(idc,1)),1)
26128 pm2=pmas(pycomp(kfdp(idc,2)),1)
26129 pm3=0d0
26130 IF(i.EQ.5) pm3=pmas(pycomp(kfdp(idc,3)),1)
26131 rm1=pm1**2/sh
26132 rm2=pm2**2/sh
26133 rm3=pm3**2/sh
26134 IF(sqrt(rm1)+sqrt(rm2)+sqrt(rm3).GT.1d0) GOTO 350
26135 wid2=1d0
26136C...pi_tc -> f + f'.
26137 fcof=1d0
26138 IF(iabs(kfdp(idc,1)).LT.10) fcof=3d0*radc
26139C...pi_tc+ -> W b b~
26140 IF(i.EQ.5.AND.shr.LT.pmas(6,1)+pmas(5,1)) THEN
26141 fcof=3d0*radc
26142 xmt2=pmas(6,1)**2/sh
26143 facp=fac/(4d0*paru(1))*fcof*xmt2*rtcm(7)**2
26144 kfc3=pycomp(kfdp(idc,3))
26145 check = sqrt(rm1)+sqrt(rm2)+sqrt(rm3)
26146 check = sqrt(rm1)
26147 t0 = (1d0-check**2)*
26148 & (xmt2*(6d0*xmt2**2+3d0*xmt2*rm1-4d0*rm1**2)-
26149 & (5d0*xmt2**2+2d0*xmt2*rm1-8d0*rm1**2))/(4d0*xmt2**2)
26150 t1 = (1d0-xmt2)*(rm1-xmt2)*((xmt2**2+xmt2*rm1+4d0*rm1**2)
26151 & -3d0*xmt2**2*(xmt2+rm1))/(2d0*xmt2**3)
26152 t3 = rm1**2/xmt2**3*(3d0*xmt2-4d0*rm1+4d0*xmt2*rm1)
26153 wdtp(i)=facp*(t0 + t1*log((xmt2-check**2)/(xmt2-1d0))
26154 & +t3*log(check))
26155 IF(kflr.GT.0) THEN
26156 wid2=wids(24,2)
26157 ELSE
26158 wid2=wids(24,3)
26159 ENDIF
26160 ELSE
26161 fcof=1d0
26162 ika=iabs(kfdp(idc,1))
26163 IF(ika.LT.10) fcof=3d0*radc
26164 hm1=pm1
26165 hm2=pm2
26166 IF(i.GE.1.AND.i.LE.5) THEN
26167 IF(i.LE.2) THEN
26168 fcof=fcof*rtcm(5)**2
26169 ELSEIF(i.LE.4) THEN
26170 fcof=fcof*rtcm(6)**2
26171 ELSEIF(i.EQ.5) THEN
26172 fcof=fcof*rtcm(7)**2
26173 ENDIF
26174 hm1=pymrun(kfdp(idc,1),sh)
26175 hm2=pymrun(kfdp(idc,2),sh)
26176 ELSEIF(i.EQ.8) THEN
26177 fcof=fcof*rtcm(8)**2
26178 ENDIF
26179 wdtp(i)=fac*fcof*(hm1+hm2)**2*
26180 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26181 ENDIF
26182 wdtp(i)=fudge*wdtp(i)
26183 wdtp(0)=wdtp(0)+wdtp(i)
26184 IF(mdme(idc,1).GT.0) THEN
26185 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26186 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26187 wdte(i,0)=wdte(i,mdme(idc,1))
26188 wdte(0,0)=wdte(0,0)+wdte(i,0)
26189 ENDIF
26190 350 CONTINUE
26191
26192 ELSEIF(kfla.EQ.ktechn+331) THEN
26193C...Techni-eta.
26194 fac=(sh/parp(46)**2)*shr
26195 DO 360 i=1,mdcy(kc,3)
26196 idc=i+mdcy(kc,2)-1
26197 IF(mdme(idc,1).LT.0) GOTO 360
26198 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26199 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26200 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 360
26201 wid2=1d0
26202 IF(i.LE.2) THEN
26203 wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))/(4d0*paru(1))
26204 IF(i.EQ.2) wid2=wids(6,1)
26205 ELSE
26206 wdtp(i)=fac*5d0*as**2/(96d0*paru(1)**3)
26207 ENDIF
26208 wdtp(i)=fudge*wdtp(i)
26209 wdtp(0)=wdtp(0)+wdtp(i)
26210 IF(mdme(idc,1).GT.0) THEN
26211 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26212 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26213 wdte(i,0)=wdte(i,mdme(idc,1))
26214 wdte(0,0)=wdte(0,0)+wdte(i,0)
26215 ENDIF
26216 360 CONTINUE
26217
26218 ELSEIF(kfla.EQ.ktechn+113) THEN
26219C...Techni-rho0:
26220 alprht=2.16d0*(3d0/itcm(1))
26221 fac=(alprht/12d0)*shr
26222 facf=(1d0/6d0)*(aem**2/alprht)*shr
26223 sqmz=pmas(23,1)**2
26224 sqmw=pmas(24,1)**2
26225 shp=sh
26226 CALL pywidx(23,shp,wdtpp,wdtep)
26227 gmmz=shr*wdtpp(0)
26228 xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
26229 bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
26230 bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
26231 DO 370 i=1,mdcy(kc,3)
26232 idc=i+mdcy(kc,2)-1
26233 IF(mdme(idc,1).LT.0) GOTO 370
26234 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26235 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26236 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 370
26237 wid2=1d0
26238 IF(i.EQ.1) THEN
26239C...rho_tc0 -> W+ + W-.
26240C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26241 wdtp(i)=fac*rtcm(3)**4*
26242 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26243 & 2d0*aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26244 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
26245 & rtcm(3)**2/4d0/xw/24d0/rtcm(13)**2*shr**3
26246 wid2=wids(24,1)
26247 ELSEIF(i.EQ.2) THEN
26248C...rho_tc0 -> W+ + pi_tc-.
26249C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26250 wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26251 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26252 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26253 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*rm1)*
26254 & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
26255 wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
26256 ELSEIF(i.EQ.3) THEN
26257C...rho_tc0 -> pi_tc+ + W-.
26258 wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26259 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26260 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26261 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*rm2)*
26262 & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
26263 wid2=wids(pycomp(ktechn+211),2)*wids(24,3)
26264 ELSEIF(i.EQ.4) THEN
26265C...rho_tc0 -> pi_tc+ + pi_tc-.
26266 wdtp(i)=fac*(1d0-rtcm(3)**2)**2*
26267 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26268 wid2=wids(pycomp(ktechn+211),1)
26269 ELSEIF(i.EQ.5) THEN
26270C...rho_tc0 -> gamma + pi_tc0
26271 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26272 & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
26273 & shr**3
26274 wid2=wids(pycomp(ktechn+111),2)
26275 ELSEIF(i.EQ.6) THEN
26276C...rho_tc0 -> gamma + pi_tc0'
26277 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26278 & (1d0-rtcm(4)**2)/24d0/rtcm(12)**2*shr**3
26279 wid2=wids(pycomp(ktechn+221),2)
26280 ELSEIF(i.EQ.7) THEN
26281C...rho_tc0 -> Z0 + pi_tc0
26282 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26283 & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
26284 & xw/xw1*shr**3
26285 wid2=wids(23,2)*wids(pycomp(ktechn+111),2)
26286 ELSEIF(i.EQ.8) THEN
26287C...rho_tc0 -> Z0 + pi_tc0'
26288 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26289 & (1d0-rtcm(4)**2)/24d0/rtcm(12)**2*(1d0-2d0*xw)**2/4d0/
26290 & xw/xw1*shr**3
26291 wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
26292 ELSEIF(i.EQ.9) THEN
26293C...rho_tc0 -> gamma + Z0
26294 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26295 & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2/24d0/rtcm(12)**2*shr**3
26296 wid2=wids(23,2)
26297 ELSEIF(i.EQ.10) THEN
26298C...rho_tc0 -> Z0 + Z0
26299 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26300 & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2*xw/xw1/24d0/rtcm(12)**2*
26301 & shr**3
26302 wid2=wids(23,1)
26303 ELSE
26304C...rho_tc0 -> f + fbar.
26305 wid2=1d0
26306 IF(i.LE.18) THEN
26307 ia=i-10
26308 fcof=3d0*radc
26309 IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
26310 ELSE
26311 ia=i-6
26312 fcof=1d0
26313 IF(ia.GE.17) wid2=wids(ia,1)
26314 ENDIF
26315 ei=kchg(ia,1)/3d0
26316 ai=sign(1d0,ei+0.1d0)
26317 vi=ai-4d0*ei*xwv
26318 vali=0.5d0*(vi+ai)
26319 vari=0.5d0*(vi-ai)
26320 wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
26321 & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
26322 & (ei+vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
26323 & (ei+vali*bwzr)*(ei+vari*bwzr)+vali*vari*bwzi**2))
26324 ENDIF
26325 wdtp(i)=fudge*wdtp(i)
26326 wdtp(0)=wdtp(0)+wdtp(i)
26327 IF(mdme(idc,1).GT.0) THEN
26328 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26329 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26330 wdte(i,0)=wdte(i,mdme(idc,1))
26331 wdte(0,0)=wdte(0,0)+wdte(i,0)
26332 ENDIF
26333 370 CONTINUE
26334
26335 ELSEIF(kfla.EQ.ktechn+213) THEN
26336C...Techni-rho+/-:
26337 alprht=2.16d0*(3d0/itcm(1))
26338 fac=(alprht/12d0)*shr
26339 sqmz=pmas(23,1)**2
26340 sqmw=pmas(24,1)**2
26341 shp=sh
26342 CALL pywidx(24,shp,wdtpp,wdtep)
26343 gmmw=shr*wdtpp(0)
26344 facf=(1d0/12d0)*(aem**2/alprht)*shr*
26345 & (0.125d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
26346 DO 380 i=1,mdcy(kc,3)
26347 idc=i+mdcy(kc,2)-1
26348 IF(mdme(idc,1).LT.0) GOTO 380
26349 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26350 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26351 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 380
26352 wid2=1d0
26353 pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26354c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26355c & /3D0*SHR**3
26356 IF(i.EQ.1) THEN
26357C...rho_tc+ -> W+ + Z0.
26358C......Goldstone
26359 wdtp(i)=fac*rtcm(3)**4*
26360 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26361 va2=rtcm(3)**2*(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(12)**2
26362 aa2=rtcm(3)**2/rtcm(13)**2/4d0/xw/xw1
26363C......W_L Z_T
26364 wdtp(i)=wdtp(i)+aem*pcm*(aa2*(pcm**2+1.5d0*rm2)+pcm**2*va2)
26365 & /3d0*shr**3
26366 va2=0d0
26367 aa2=rtcm(3)**2/rtcm(13)**2/4d0/xw
26368C......W_T Z_L
26369 wdtp(i)=wdtp(i)+aem*pcm*(aa2*(pcm**2+1.5d0*rm1)+pcm**2*va2)
26370 & /3d0*shr**3
26371 IF(kflr.GT.0) THEN
26372 wid2=wids(24,2)*wids(23,2)
26373 ELSE
26374 wid2=wids(24,3)*wids(23,2)
26375 ENDIF
26376 ELSEIF(i.EQ.2) THEN
26377C...rho_tc+ -> W+ + pi_tc0.
26378 wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26379 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26380 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26381 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmw/sh)*
26382 & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(13)**2*shr**3
26383 IF(kflr.GT.0) THEN
26384 wid2=wids(24,2)*wids(pycomp(ktechn+111),2)
26385 ELSE
26386 wid2=wids(24,3)*wids(pycomp(ktechn+111),2)
26387 ENDIF
26388 ELSEIF(i.EQ.3) THEN
26389C...rho_tc+ -> pi_tc+ + Z0.
26390 wdtp(i)=fac*rtcm(3)**2*(1d0-rtcm(3)**2)*
26391 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26392 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*
26393 & ((1d0-rm1-rm2)**2-4d0*rm1*rm2 + 6d0*sqmz/sh)*
26394 & (1d0-rtcm(3)**2)/4d0/xw/xw1/24d0/rtcm(13)**2*shr**3+
26395 & aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26396 & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
26397 & shr**3*xw/xw1
26398 IF(kflr.GT.0) THEN
26399 wid2=wids(pycomp(ktechn+211),2)*wids(23,2)
26400 ELSE
26401 wid2=wids(pycomp(ktechn+211),3)*wids(23,2)
26402 ENDIF
26403 ELSEIF(i.EQ.4) THEN
26404C...rho_tc+ -> pi_tc+ + pi_tc0.
26405 wdtp(i)=fac*(1d0-rtcm(3)**2)**2*
26406 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26407 IF(kflr.GT.0) THEN
26408 wid2=wids(pycomp(ktechn+211),2)*wids(pycomp(ktechn+111),2)
26409 ELSE
26410 wid2=wids(pycomp(ktechn+211),3)*wids(pycomp(ktechn+111),2)
26411 ENDIF
26412 ELSEIF(i.EQ.5) THEN
26413C...rho_tc+ -> pi_tc+ + gamma
26414 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26415 & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(3)**2)/24d0/rtcm(12)**2*
26416 & shr**3
26417 IF(kflr.GT.0) THEN
26418 wid2=wids(pycomp(ktechn+211),2)
26419 ELSE
26420 wid2=wids(pycomp(ktechn+211),3)
26421 ENDIF
26422 ELSEIF(i.EQ.6) THEN
26423C...rho_tc+ -> W+ + pi_tc0'
26424 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26425 & (1d0-rtcm(4)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3
26426 IF(kflr.GT.0) THEN
26427 wid2=wids(24,2)*wids(pycomp(ktechn+221),2)
26428 ELSE
26429 wid2=wids(24,3)*wids(pycomp(ktechn+221),2)
26430 ENDIF
26431 ELSEIF(i.EQ.7) THEN
26432C...rho_tc+ -> W+ + gamma
26433 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26434 & (2d0*rtcm(2)-1d0)**2*rtcm(3)**2/24d0/rtcm(12)**2*shr**3
26435 IF(kflr.GT.0) THEN
26436 wid2=wids(24,2)
26437 ELSE
26438 wid2=wids(24,3)
26439 ENDIF
26440 ELSE
26441C...rho_tc+ -> f + fbar'.
26442 ia=i-7
26443 wid2=1d0
26444 IF(ia.LE.16) THEN
26445 fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)
26446 IF(kflr.GT.0) THEN
26447 IF(mod(ia,4).EQ.3) wid2=wids(6,2)
26448 IF(mod(ia,4).EQ.0) wid2=wids(8,2)
26449 IF(ia.GE.13) wid2=wid2*wids(7,3)
26450 ELSE
26451 IF(mod(ia,4).EQ.3) wid2=wids(6,3)
26452 IF(mod(ia,4).EQ.0) wid2=wids(8,3)
26453 IF(ia.GE.13) wid2=wid2*wids(7,2)
26454 ENDIF
26455 ELSE
26456 fcof=1d0
26457 IF(kflr.GT.0) THEN
26458 IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)
26459 ELSE
26460 IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)
26461 ENDIF
26462 ENDIF
26463 wdtp(i)=facf*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
26464 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26465 ENDIF
26466 wdtp(i)=fudge*wdtp(i)
26467 wdtp(0)=wdtp(0)+wdtp(i)
26468 IF(mdme(idc,1).GT.0) THEN
26469 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26470 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26471 wdte(i,0)=wdte(i,mdme(idc,1))
26472 wdte(0,0)=wdte(0,0)+wdte(i,0)
26473 ENDIF
26474 380 CONTINUE
26475
26476 ELSEIF(kfla.EQ.ktechn+223) THEN
26477C...Techni-omega:
26478 alprht=2.16d0*(3d0/itcm(1))
26479 fac=(alprht/12d0)*shr
26480 facf=(1d0/6d0)*(aem**2/alprht)*shr*(2d0*rtcm(2)-1d0)**2
26481 sqmz=pmas(23,1)**2
26482 shp=sh
26483 CALL pywidx(23,shp,wdtpp,wdtep)
26484 gmmz=shr*wdtpp(0)
26485 bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
26486 bwzi=-(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
26487 DO 390 i=1,mdcy(kc,3)
26488 idc=i+mdcy(kc,2)-1
26489 IF(mdme(idc,1).LT.0) GOTO 390
26490 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26491 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26492 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 390
26493 wid2=1d0
26494 IF(i.EQ.1) THEN
26495C...omega_tc0 -> gamma + pi_tc0.
26496 wdtp(i)=aem/24d0/rtcm(12)**2*(1d0-rtcm(3)**2)*
26497 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*shr**3
26498 wid2=wids(pycomp(ktechn+111),2)
26499 ELSEIF(i.EQ.2) THEN
26500C...omega_tc0 -> Z0 + pi_tc0
26501 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26502 & (1d0-rtcm(3)**2)/24d0/rtcm(12)**2*(1d0-2d0*xw)**2/4d0/
26503 & xw/xw1*shr**3
26504 wid2=wids(23,2)*wids(pycomp(ktechn+111),2)
26505 ELSEIF(i.EQ.3) THEN
26506C...omega_tc0 -> gamma + pi_tc0'
26507 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26508 & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(4)**2)/24d0/rtcm(12)**2*
26509 & shr**3
26510 wid2=wids(pycomp(ktechn+221),2)
26511 ELSEIF(i.EQ.4) THEN
26512C...omega_tc0 -> Z0 + pi_tc0'
26513 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26514 & (2d0*rtcm(2)-1d0)**2*(1d0-rtcm(4)**2)/24d0/rtcm(12)**2*
26515 & xw/xw1*shr**3
26516 wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
26517 ELSEIF(i.EQ.5) THEN
26518C...omega_tc0 -> W+ + pi_tc-
26519 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26520 & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3+
26521 & fac*rtcm(3)**2*(1d0-rtcm(3)**2)*rtcm(11)**2*
26522 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26523 wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
26524 ELSEIF(i.EQ.6) THEN
26525C...omega_tc0 -> pi_tc+ + W-
26526 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26527 & (1d0-rtcm(3)**2)/4d0/xw/24d0/rtcm(12)**2*shr**3+
26528 & fac*rtcm(3)**2*(1d0-rtcm(3)**2)*rtcm(11)**2*
26529 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26530 wid2=wids(24,3)*wids(pycomp(ktechn+211),2)
26531 ELSEIF(i.EQ.7) THEN
26532C...omega_tc0 -> W+ + W-.
26533C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26534 wdtp(i)=fac*rtcm(3)**4*rtcm(11)**2*
26535 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3+
26536 & 2d0*aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26537 & rtcm(3)**2/4d0/xw/24d0/rtcm(12)**2*shr**3
26538 wid2=wids(24,1)
26539 ELSEIF(i.EQ.8) THEN
26540C...omega_tc0 -> pi_tc+ + pi_tc-.
26541 wdtp(i)=fac*(1d0-rtcm(3)**2)**2*rtcm(11)**2*
26542 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3
26543 wid2=wids(pycomp(ktechn+211),1)
26544C...omega_tc0 -> gamma + Z0
26545 ELSEIF(i.EQ.9) THEN
26546 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26547 & rtcm(3)**2/24d0/rtcm(12)**2*shr**3
26548 wid2=wids(23,2)
26549C...omega_tc0 -> Z0 + Z0
26550 ELSEIF(i.EQ.10) THEN
26551 wdtp(i)=aem*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*
26552 & rtcm(3)**2*(xw1-xw)**2/xw/xw1/4d0
26553 & /24d0/rtcm(12)**2*shr**3
26554 wid2=wids(23,1)
26555 ELSE
26556C...omega_tc0 -> f + fbar.
26557 wid2=1d0
26558 IF(i.LE.18) THEN
26559 ia=i-10
26560 fcof=3d0*radc
26561 IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
26562 ELSE
26563 ia=i-8
26564 fcof=1d0
26565 IF(ia.GE.17) wid2=wids(ia,1)
26566 ENDIF
26567 ei=kchg(ia,1)/3d0
26568 ai=sign(1d0,ei+0.1d0)
26569 vi=ai-4d0*ei*xwv
26570 vali=-0.5d0*(vi+ai)
26571 vari=-0.5d0*(vi-ai)
26572 wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
26573 & ((ei+vali*bwzr)**2+(vali*bwzi)**2+
26574 & (ei+vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
26575 & (ei+vali*bwzr)*(ei+vari*bwzr)+vali*vari*bwzi**2))
26576 ENDIF
26577 wdtp(i)=fudge*wdtp(i)
26578 wdtp(0)=wdtp(0)+wdtp(i)
26579 IF(mdme(idc,1).GT.0) THEN
26580 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26581 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26582 wdte(i,0)=wdte(i,mdme(idc,1))
26583 wdte(0,0)=wdte(0,0)+wdte(i,0)
26584 ENDIF
26585 390 CONTINUE
26586
26587C.....V8 -> quark anti-quark
26588 ELSEIF(kfla.EQ.ktechn+100021) THEN
26589 fac=as/6d0*shr
26590 tant3=rtcm(21)
26591 IF(itcm(2).EQ.0) THEN
26592 imdl=1
26593 ELSEIF(itcm(2).EQ.1) THEN
26594 imdl=2
26595 ENDIF
26596 DO 400 i=1,mdcy(kc,3)
26597 idc=i+mdcy(kc,2)-1
26598 IF(mdme(idc,1).LT.0) GOTO 400
26599 pm1=pmas(pycomp(kfdp(idc,1)),1)
26600 rm1=pm1**2/sh
26601 IF(rm1.GT.0.25d0) GOTO 400
26602 wid2=1d0
26603 IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
26604 fmix=1d0/tant3**2
26605 ELSE
26606 fmix=tant3**2
26607 ENDIF
26608 wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*fmix
26609 IF(i.EQ.6) wid2=wids(6,1)
26610 wdtp(i)=fudge*wdtp(i)
26611 wdtp(0)=wdtp(0)+wdtp(i)
26612 IF(mdme(idc,1).GT.0) THEN
26613 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26614 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26615 wdte(i,0)=wdte(i,mdme(idc,1))
26616 wdte(0,0)=wdte(0,0)+wdte(i,0)
26617 ENDIF
26618 400 CONTINUE
26619
26620 ELSEIF(kfla.EQ.ktechn+100111.OR.kfla.EQ.ktechn+200111) THEN
26621 fac=(1d0/(4d0*paru(1)*rtcm(1)**2))*shr
26622 clebf=0d0
26623 DO 410 i=1,mdcy(kc,3)
26624 idc=i+mdcy(kc,2)-1
26625 IF(mdme(idc,1).LT.0) GOTO 410
26626 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26627 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26628 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 410
26629 wid2=1d0
26630C...pi_tc -> g + g
26631 IF(i.EQ.7) THEN
26632 IF(kfla.EQ.ktechn+100111) THEN
26633 clebg=4d0/3d0
26634 ELSE
26635 clebg=5d0/3d0
26636 ENDIF
26637 facp=(as/(8d0*paru(1))*itcm(1)/rtcm(1))**2
26638 & /(2d0*paru(1))*sh*shr*clebg
26639 wdtp(i)=facp
26640 ELSE
26641C...pi_tc -> f + fbar.
26642 IF(i.EQ.6) wid2=wids(6,1)
26643 fcof=1d0
26644 ika=iabs(kfdp(idc,1))
26645 IF(ika.LT.10) fcof=3d0*radc
26646 hm1=pymrun(kfdp(idc,1),sh)
26647 wdtp(i)=fac*fcof*hm1**2*clebf*
26648 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
26649 ENDIF
26650 wdtp(i)=fudge*wdtp(i)
26651 wdtp(0)=wdtp(0)+wdtp(i)
26652 IF(mdme(idc,1).GT.0) THEN
26653 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26654 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26655 wdte(i,0)=wdte(i,mdme(idc,1))
26656 wdte(0,0)=wdte(0,0)+wdte(i,0)
26657 ENDIF
26658 410 CONTINUE
26659
26660 ELSEIF(kfla.GE.ktechn+100113.AND.kfla.LE.ktechn+400113) THEN
26661 fac=as/6d0*shr
26662 alprht=2.16d0*(3d0/itcm(1))
26663 tant3=rtcm(21)
26664 sin2t=2d0*tant3/(tant3**2+1d0)
26665 sint3=tant3/sqrt(tant3**2+1d0)
26666 csxpp=rtcm(22)
26667 rm82=rtcm(27)**2
26668 x12=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*cos(rtcm(30))+
26669 & rtcm(31)*sqrt(1d0-rtcm(31)**2)*cos(rtcm(32)))/sqrt(2d0)
26670 x21=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*sin(rtcm(30))+
26671 & rtcm(31)*sqrt(1d0-rtcm(31)**2)*sin(rtcm(32)))/sqrt(2d0)
26672 x11=(.25d0*(rtcm(29)**2+rtcm(31)**2+2d0)-
26673 & sint3**2)*2d0
26674 x22=(.25d0*(2d0-rtcm(29)**2-rtcm(31)**2)-
26675 & sint3**2)*2d0
26676 CALL pywidx(ktechn+100021,sh,wdtpp,wdtep)
26677
26678 IF(wdtpp(0).GT.rtcm(33)*shr) wdtpp(0)=rtcm(33)*shr
26679 gmv8=shr*wdtpp(0)
26680 rmv8=pmas(pycomp(ktechn+100021),1)
26681 fv8re=sh*(sh-rmv8**2)/((sh-rmv8**2)**2+gmv8**2)
26682 fv8im=sh*gmv8/((sh-rmv8**2)**2+gmv8**2)
26683 IF(itcm(2).EQ.0) THEN
26684 imdl=1
26685 ELSE
26686 imdl=2
26687 ENDIF
26688 DO 420 i=1,mdcy(kc,3)
26689 IF(i.EQ.7.AND.(kfla.EQ.ktechn+200113.OR.
26690 & kfla.EQ.ktechn+300113)) GOTO 420
26691 idc=i+mdcy(kc,2)-1
26692 IF(mdme(idc,1).LT.0) GOTO 420
26693 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26694 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26695 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 420
26696 wid2=1d0
26697 IF(i.LE.6) THEN
26698 IF(i.EQ.6) wid2=wids(6,1)
26699 xig=1d0
26700 IF(kfla.EQ.ktechn+200113) THEN
26701 xig=0d0
26702 xij=x12
26703 ELSEIF(kfla.EQ.ktechn+300113) THEN
26704 xig=0d0
26705 xij=x21
26706 ELSEIF(kfla.EQ.ktechn+100113) THEN
26707 xij=x11
26708 ELSE
26709 xij=x22
26710 ENDIF
26711 IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
26712 fmix=1d0/tant3/sin2t
26713 ELSE
26714 fmix=-tant3/sin2t
26715 ENDIF
26716 xfac=(xig+fmix*xij*fv8re)**2+(fmix*xij*fv8im)**2
26717 wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*as/alprht*xfac
26718 ELSEIF(i.EQ.7) THEN
26719 wdtp(i)=shr*as**2/(4d0*alprht)
26720 ELSEIF(kfla.EQ.ktechn+400113.AND.i.LE.9) THEN
26721 psh=shr*(1d0-rm1)/2d0
26722 wdtp(i)=as/9d0*psh**3/rm82
26723 IF(i.EQ.8) THEN
26724 wdtp(i)=2d0*wdtp(i)*csxpp**2
26725 wid2=wids(pycomp(kfdp(idc,1)),2)
26726 ELSE
26727 wdtp(i)=5d0*wdtp(i)
26728 wid2=wids(pycomp(kfdp(idc,1)),2)
26729 ENDIF
26730 ENDIF
26731 wdtp(i)=fudge*wdtp(i)
26732 wdtp(0)=wdtp(0)+wdtp(i)
26733 IF(mdme(idc,1).GT.0) THEN
26734 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26735 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26736 wdte(i,0)=wdte(i,mdme(idc,1))
26737 wdte(0,0)=wdte(0,0)+wdte(i,0)
26738 ENDIF
26739 420 CONTINUE
26740
26741 ELSEIF(kfla.EQ.kexcit+1) THEN
26742C...d* excited quark.
26743 fac=(sh/rtcm(41)**2)*shr
26744 DO 430 i=1,mdcy(kc,3)
26745 idc=i+mdcy(kc,2)-1
26746 IF(mdme(idc,1).LT.0) GOTO 430
26747 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26748 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26749 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 430
26750 wid2=1d0
26751 IF(i.EQ.1) THEN
26752C...d* -> g + d.
26753 wdtp(i)=fac*as*rtcm(45)**2/3d0
26754 wid2=1d0
26755 ELSEIF(i.EQ.2) THEN
26756C...d* -> gamma + d.
26757 qf=-rtcm(43)/2d0+rtcm(44)/6d0
26758 wdtp(i)=fac*aem*qf**2/4d0
26759 wid2=1d0
26760 ELSEIF(i.EQ.3) THEN
26761C...d* -> Z0 + d.
26762 qf=-rtcm(43)*xw1/2d0-rtcm(44)*xw/6d0
26763 wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
26764 & (1d0-rm1)**2*(2d0+rm1)
26765 wid2=wids(23,2)
26766 ELSEIF(i.EQ.4) THEN
26767C...d* -> W- + u.
26768 wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
26769 & (1d0-rm1)**2*(2d0+rm1)
26770 IF(kflr.GT.0) wid2=wids(24,3)
26771 IF(kflr.LT.0) wid2=wids(24,2)
26772 ENDIF
26773 wdtp(i)=fudge*wdtp(i)
26774 wdtp(0)=wdtp(0)+wdtp(i)
26775 IF(mdme(idc,1).GT.0) THEN
26776 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26777 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26778 wdte(i,0)=wdte(i,mdme(idc,1))
26779 wdte(0,0)=wdte(0,0)+wdte(i,0)
26780 ENDIF
26781 430 CONTINUE
26782
26783 ELSEIF(kfla.EQ.kexcit+2) THEN
26784C...u* excited quark.
26785 fac=(sh/rtcm(41)**2)*shr
26786 DO 440 i=1,mdcy(kc,3)
26787 idc=i+mdcy(kc,2)-1
26788 IF(mdme(idc,1).LT.0) GOTO 440
26789 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26790 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26791 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 440
26792 wid2=1d0
26793 IF(i.EQ.1) THEN
26794C...u* -> g + u.
26795 wdtp(i)=fac*as*rtcm(45)**2/3d0
26796 wid2=1d0
26797 ELSEIF(i.EQ.2) THEN
26798C...u* -> gamma + u.
26799 qf=rtcm(43)/2d0+rtcm(44)/6d0
26800 wdtp(i)=fac*aem*qf**2/4d0
26801 wid2=1d0
26802 ELSEIF(i.EQ.3) THEN
26803C...u* -> Z0 + u.
26804 qf=rtcm(43)*xw1/2d0-rtcm(44)*xw/6d0
26805 wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
26806 & (1d0-rm1)**2*(2d0+rm1)
26807 wid2=wids(23,2)
26808 ELSEIF(i.EQ.4) THEN
26809C...u* -> W+ + d.
26810 wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
26811 & (1d0-rm1)**2*(2d0+rm1)
26812 IF(kflr.GT.0) wid2=wids(24,2)
26813 IF(kflr.LT.0) wid2=wids(24,3)
26814 ENDIF
26815 wdtp(i)=fudge*wdtp(i)
26816 wdtp(0)=wdtp(0)+wdtp(i)
26817 IF(mdme(idc,1).GT.0) THEN
26818 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26819 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26820 wdte(i,0)=wdte(i,mdme(idc,1))
26821 wdte(0,0)=wdte(0,0)+wdte(i,0)
26822 ENDIF
26823 440 CONTINUE
26824
26825 ELSEIF(kfla.EQ.kexcit+11) THEN
26826C...e* excited lepton.
26827 fac=(sh/rtcm(41)**2)*shr
26828 DO 450 i=1,mdcy(kc,3)
26829 idc=i+mdcy(kc,2)-1
26830 IF(mdme(idc,1).LT.0) GOTO 450
26831 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26832 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26833 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 450
26834 wid2=1d0
26835 IF(i.EQ.1) THEN
26836C...e* -> gamma + e.
26837 qf=-rtcm(43)/2d0-rtcm(44)/2d0
26838 wdtp(i)=fac*aem*qf**2/4d0
26839 wid2=1d0
26840 ELSEIF(i.EQ.2) THEN
26841C...e* -> Z0 + e.
26842 qf=-rtcm(43)*xw1/2d0+rtcm(44)*xw/2d0
26843 wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
26844 & (1d0-rm1)**2*(2d0+rm1)
26845 wid2=wids(23,2)
26846 ELSEIF(i.EQ.3) THEN
26847C...e* -> W- + nu.
26848 wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
26849 & (1d0-rm1)**2*(2d0+rm1)
26850 IF(kflr.GT.0) wid2=wids(24,3)
26851 IF(kflr.LT.0) wid2=wids(24,2)
26852 ENDIF
26853 wdtp(i)=fudge*wdtp(i)
26854 wdtp(0)=wdtp(0)+wdtp(i)
26855 IF(mdme(idc,1).GT.0) THEN
26856 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26857 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26858 wdte(i,0)=wdte(i,mdme(idc,1))
26859 wdte(0,0)=wdte(0,0)+wdte(i,0)
26860 ENDIF
26861 450 CONTINUE
26862
26863 ELSEIF(kfla.EQ.kexcit+12) THEN
26864C...nu*_e excited neutrino.
26865 fac=(sh/rtcm(41)**2)*shr
26866 DO 460 i=1,mdcy(kc,3)
26867 idc=i+mdcy(kc,2)-1
26868 IF(mdme(idc,1).LT.0) GOTO 460
26869 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26870 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26871 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 460
26872 wid2=1d0
26873 IF(i.EQ.1) THEN
26874C...nu*_e -> Z0 + nu*_e.
26875 qf=rtcm(43)*xw1/2d0+rtcm(44)*xw/2d0
26876 wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*
26877 & (1d0-rm1)**2*(2d0+rm1)
26878 wid2=wids(23,2)
26879 ELSEIF(i.EQ.2) THEN
26880C...nu*_e -> W+ + e.
26881 wdtp(i)=fac*aem*rtcm(43)**2/(16d0*xw)*
26882 & (1d0-rm1)**2*(2d0+rm1)
26883 IF(kflr.GT.0) wid2=wids(24,2)
26884 IF(kflr.LT.0) wid2=wids(24,3)
26885 ENDIF
26886 wdtp(i)=fudge*wdtp(i)
26887 wdtp(0)=wdtp(0)+wdtp(i)
26888 IF(mdme(idc,1).GT.0) THEN
26889 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26890 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26891 wdte(i,0)=wdte(i,mdme(idc,1))
26892 wdte(0,0)=wdte(0,0)+wdte(i,0)
26893 ENDIF
26894 460 CONTINUE
26895
26896 ELSEIF(kfla.EQ.kdimen+39) THEN
26897C...G* (graviton resonance):
26898 fac=(parp(50)**2/paru(1))*shr
26899 DO 470 i=1,mdcy(kc,3)
26900 idc=i+mdcy(kc,2)-1
26901 IF(mdme(idc,1).LT.0) GOTO 470
26902 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26903 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26904 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 470
26905 wid2=1d0
26906 IF(i.LE.8) THEN
26907C...G* -> q + qbar
26908 fcof=3d0*radc
26909 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*
26910 & pyhfth(sh,sh*rm1,1d0)
26911 wdtp(i)=fac*fcof*sqrt(max(0d0,1d0-4d0*rm1))**3*
26912 & (1d0+8d0*rm1/3d0)/320d0
26913 IF(i.EQ.6) wid2=wids(6,1)
26914 IF(i.EQ.7.OR.i.EQ.8) wid2=wids(i,1)
26915 ELSEIF(i.LE.16) THEN
26916C...G* -> l+ + l-, nu + nubar
26917 fcof=1d0
26918 wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))**3*
26919 & (1d0+8d0*rm1/3d0)/320d0
26920 IF(i.EQ.15.OR.i.EQ.16) wid2=wids(2+i,1)
26921 ELSEIF(i.EQ.17) THEN
26922C...G* -> g + g.
26923 wdtp(i)=fac/20d0
26924 ELSEIF(i.EQ.18) THEN
26925C...G* -> gamma + gamma.
26926 wdtp(i)=fac/160d0
26927 ELSEIF(i.EQ.19) THEN
26928C...G* -> Z0 + Z0.
26929 wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))*(13d0/12d0+
26930 & 14d0*rm1/3d0+4d0*rm1**2)/160d0
26931 wid2=wids(23,1)
26932 ELSEIF(i.EQ.20) THEN
26933C...G* -> W+ + W-.
26934 wdtp(i)=fac*sqrt(max(0d0,1d0-4d0*rm1))*(13d0/12d0+
26935 & 14d0*rm1/3d0+4d0*rm1**2)/80d0
26936 wid2=wids(24,1)
26937 ENDIF
26938 wdtp(i)=fudge*wdtp(i)
26939 wdtp(0)=wdtp(0)+wdtp(i)
26940 IF(mdme(idc,1).GT.0) THEN
26941 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26942 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26943 wdte(i,0)=wdte(i,mdme(idc,1))
26944 wdte(0,0)=wdte(0,0)+wdte(i,0)
26945 ENDIF
26946 470 CONTINUE
26947
26948 ELSEIF(kfla.EQ.9900012.OR.kfla.EQ.9900014.OR.kfla.EQ.9900016) THEN
26949C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
26950 pmwr=max(1.001d0*shr,pmas(pycomp(9900024),1))
26951 fac=(aem**2/(768d0*paru(1)*xw**2))*shr**5/pmwr**4
26952 DO 480 i=1,mdcy(kc,3)
26953 idc=i+mdcy(kc,2)-1
26954 IF(mdme(idc,1).LT.0) GOTO 480
26955 pm1=pmas(pycomp(kfdp(idc,1)),1)
26956 pm2=pmas(pycomp(kfdp(idc,2)),1)
26957 pm3=pmas(pycomp(kfdp(idc,3)),1)
26958 IF(pm1+pm2+pm3.GE.shr) GOTO 480
26959 wid2=1d0
26960 IF(i.LE.9) THEN
26961C...nu_lR -> l- qbar q'
26962 fcof=3d0*radc*vckm((i-1)/3+1,mod(i-1,3)+1)
26963 IF(mod(i,3).EQ.0) wid2=wids(6,2)
26964 ELSEIF(i.LE.18) THEN
26965C...nu_lR -> l+ q qbar'
26966 fcof=3d0*radc*vckm((i-10)/3+1,mod(i-10,3)+1)
26967 IF(mod(i-9,3).EQ.0) wid2=wids(6,3)
26968 ELSE
26969C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
26970 fcof=1d0
26971 wid2=wids(pycomp(kfdp(idc,3)),2)
26972 ENDIF
26973 x=(pm1+pm2+pm3)/shr
26974 fx=1d0-8d0*x**2+8d0*x**6-x**8-24d0*x**4*log(x)
26975 y=(shr/pmwr)**2
26976 fy=(12d0*(1d0-y)*log(1d0-y)+12d0*y-6d0*y**2-2d0*y**3)/y**4
26977 wdtp(i)=fac*fcof*fx*fy
26978 wdtp(i)=fudge*wdtp(i)
26979 wdtp(0)=wdtp(0)+wdtp(i)
26980 IF(mdme(idc,1).GT.0) THEN
26981 wdte(i,mdme(idc,1))=wdtp(i)*wid2
26982 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
26983 wdte(i,0)=wdte(i,mdme(idc,1))
26984 wdte(0,0)=wdte(0,0)+wdte(i,0)
26985 ENDIF
26986 480 CONTINUE
26987
26988 ELSEIF(kfla.EQ.9900023) THEN
26989C...Z_R0:
26990 fac=(aem/(48d0*xw*xw1*(1d0-2d0*xw)))*shr
26991 DO 490 i=1,mdcy(kc,3)
26992 idc=i+mdcy(kc,2)-1
26993 IF(mdme(idc,1).LT.0) GOTO 490
26994 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
26995 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
26996 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 490
26997 wid2=1d0
26998 symmet=1d0
26999 IF(i.LE.6) THEN
27000C...Z_R0 -> q + qbar
27001 ef=kchg(i,1)/3d0
27002 af=sign(1d0,ef+0.1d0)*(1d0-2d0*xw)
27003 vf=sign(1d0,ef+0.1d0)-4d0*ef*xw
27004 fcof=3d0*radc
27005 IF(i.EQ.6) wid2=wids(6,1)
27006 ELSEIF(i.EQ.7.OR.i.EQ.10.OR.i.EQ.13) THEN
27007C...Z_R0 -> l+ + l-
27008 af=-(1d0-2d0*xw)
27009 vf=-1d0+4d0*xw
27010 fcof=1d0
27011 ELSEIF(i.EQ.8.OR.i.EQ.11.OR.i.EQ.14) THEN
27012C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27013 af=-2d0*xw
27014 vf=0d0
27015 fcof=1d0
27016 symmet=0.5d0
27017 ELSEIF(i.LE.15) THEN
27018C...Z0 -> nu_R + nu_R, assumed Majorana.
27019 af=2d0*xw1
27020 vf=0d0
27021 fcof=1d0
27022 wid2=wids(pycomp(kfdp(idc,1)),1)
27023 symmet=0.5d0
27024 ENDIF
27025 wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
27026 & sqrt(max(0d0,1d0-4d0*rm1))*symmet
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 490 CONTINUE
27036
27037 ELSEIF(kfla.EQ.9900024) THEN
27038C...W_R+/-:
27039 fac=(aem/(24d0*xw))*shr
27040 DO 500 i=1,mdcy(kc,3)
27041 idc=i+mdcy(kc,2)-1
27042 IF(mdme(idc,1).LT.0) GOTO 500
27043 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27044 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27045 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 500
27046 wid2=1d0
27047 IF(i.LE.9) THEN
27048C...W_R+/- -> q + qbar'
27049 fcof=3d0*radc*vckm((i-1)/3+1,mod(i-1,3)+1)
27050 IF(kflr.GT.0) THEN
27051 IF(mod(i,3).EQ.0) wid2=wids(6,2)
27052 ELSE
27053 IF(mod(i,3).EQ.0) wid2=wids(6,3)
27054 ENDIF
27055 ELSEIF(i.LE.12) THEN
27056C...W_R+/- -> l+/- + nu_R
27057 fcof=1d0
27058 ENDIF
27059 wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
27060 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27061 wdtp(i)=fudge*wdtp(i)
27062 wdtp(0)=wdtp(0)+wdtp(i)
27063 IF(mdme(idc,1).GT.0) THEN
27064 wdte(i,mdme(idc,1))=wdtp(i)*wid2
27065 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27066 wdte(i,0)=wdte(i,mdme(idc,1))
27067 wdte(0,0)=wdte(0,0)+wdte(i,0)
27068 ENDIF
27069 500 CONTINUE
27070
27071 ELSEIF(kfla.EQ.9900041) THEN
27072C...H_L++/--:
27073 fac=(1d0/(8d0*paru(1)))*shr
27074 DO 510 i=1,mdcy(kc,3)
27075 idc=i+mdcy(kc,2)-1
27076 IF(mdme(idc,1).LT.0) GOTO 510
27077 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27078 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27079 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 510
27080 wid2=1d0
27081 IF(i.LE.6) THEN
27082C...H_L++/-- -> l+/- + l'+/-
27083 fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
27084 & (iabs(kfdp(idc,2))-9)/2)**2
27085 IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
27086 ELSEIF(i.EQ.7) THEN
27087C...H_L++/-- -> W_L+/- + W_L+/-
27088 fcof=0.5d0*parp(190)**4*parp(192)**2/pmas(24,1)**2*
27089 & (3d0*rm1+0.25d0/rm1-1d0)
27090 wid2=wids(24,4+(1-kfls)/2)
27091 ENDIF
27092 wdtp(i)=fac*fcof*
27093 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27094 wdtp(i)=fudge*wdtp(i)
27095 wdtp(0)=wdtp(0)+wdtp(i)
27096 IF(mdme(idc,1).GT.0) THEN
27097 wdte(i,mdme(idc,1))=wdtp(i)*wid2
27098 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27099 wdte(i,0)=wdte(i,mdme(idc,1))
27100 wdte(0,0)=wdte(0,0)+wdte(i,0)
27101 ENDIF
27102 510 CONTINUE
27103
27104 ELSEIF(kfla.EQ.9900042) THEN
27105C...H_R++/--:
27106 fac=(1d0/(8d0*paru(1)))*shr
27107 DO 520 i=1,mdcy(kc,3)
27108 idc=i+mdcy(kc,2)-1
27109 IF(mdme(idc,1).LT.0) GOTO 520
27110 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27111 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27112 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 520
27113 wid2=1d0
27114 IF(i.LE.6) THEN
27115C...H_R++/-- -> l+/- + l'+/-
27116 fcof=parp(180+3*((iabs(kfdp(idc,1))-11)/2)+
27117 & (iabs(kfdp(idc,2))-9)/2)**2
27118 IF(kfdp(idc,1).NE.kfdp(idc,2)) fcof=2d0*fcof
27119 ELSEIF(i.EQ.7) THEN
27120C...H_R++/-- -> W_R+/- + W_R+/-
27121 fcof=parp(191)**2*(3d0*rm1+0.25d0/rm1-1d0)
27122 wid2=wids(pycomp(9900024),4+(1-kfls)/2)
27123 ENDIF
27124 wdtp(i)=fac*fcof*
27125 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27126 wdtp(i)=fudge*wdtp(i)
27127 wdtp(0)=wdtp(0)+wdtp(i)
27128 IF(mdme(idc,1).GT.0) THEN
27129 wdte(i,mdme(idc,1))=wdtp(i)*wid2
27130 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27131 wdte(i,0)=wdte(i,mdme(idc,1))
27132 wdte(0,0)=wdte(0,0)+wdte(i,0)
27133 ENDIF
27134 520 CONTINUE
27135
27136 ELSEIF(kfla.EQ.ktechn+115) THEN
27137C...Techni-a2:
27138C...Need to update to alpha_rho
27139 alprht=2.16d0*(3d0/itcm(1))*rtcm(47)**2
27140 fac=(alprht/12d0)*shr
27141 facf=(1d0/6d0)*(aem**2/alprht)*shr
27142 sqmz=pmas(23,1)**2
27143 sqmw=pmas(24,1)**2
27144 shp=sh
27145 CALL pywidx(23,shp,wdtpp,wdtep)
27146 gmmz=shr*wdtpp(0)
27147 xwrht=1d0/(4d0*xw*(1d0-xw))
27148 bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
27149 bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
27150 DO 530 i=1,mdcy(kc,3)
27151 idc=i+mdcy(kc,2)-1
27152 IF(mdme(idc,1).LT.0) GOTO 530
27153 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27154 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27155 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 530
27156 wid2=1d0
27157 pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27158 IF(i.LE.4) THEN
27159 facpv=pcm**2
27160 facpa=pcm**2+1.5d0*rm1
27161 va2=0d0
27162 aa2=0d0
27163C...a2_tc0 -> W+ + W-
27164 IF(i.EQ.1) THEN
27165 aa2=2d0*rtcm(3)**2/4d0/xw/rtcm(49)**2
27166C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27167 wid2=wids(24,1)
27168C...a2_tc0 -> W+ + pi_tc- + c.c.
27169 ELSEIF(i.EQ.2.OR.i.EQ.3) THEN
27170 aa2=(1d0-rtcm(3)**2)/4d0/xw/rtcm(49)**2
27171 IF(i.EQ.6) THEN
27172 wid2=wids(24,2)*wids(pycomp(ktechn+211),3)
27173 ELSE
27174 wid2=wids(24,3)*wids(pycomp(ktechn+211),2)
27175 ENDIF
27176 ELSEIF(i.EQ.4) THEN
27177C...a2_tc0 -> Z0 + pi_tc0'
27178 va2=(1d0-rtcm(4)**2)/4d0/xw/xw1/rtcm(48)**2
27179 wid2=wids(23,2)*wids(pycomp(ktechn+221),2)
27180 ENDIF
27181 wdtp(i)=aem*shr**3*pcm/3d0*(va2*facpv+aa2*facpa)
27182 ELSEIF(i.GE.5.AND.i.LE.10) THEN
27183 facpv=pcm**2*(1d0+rm1+rm2)+3d0*rm1*rm2
27184 facpa=pcm**2*(1d0+rm1+rm2)
27185 va2=0d0
27186 aa2=0d0
27187 IF(i.EQ.5) THEN
27188C...a_T^0 -> gamma rho_T^0
27189 va2=(2d0*rtcm(2)-1d0)**2/rtcm(50)**4
27190 wid2=wids(pycomp(ktechn+113),2)
27191 ELSEIF(i.EQ.6) THEN
27192C...a_T^0 -> gamma omega_T
27193 va2=1d0/rtcm(50)**4
27194 wid2=wids(pycomp(ktechn+223),2)
27195 ELSEIF(i.EQ.7.OR.i.EQ.8) THEN
27196C...a_T^0 -> W^+- rho_T^-+
27197 aa2=.25d0/xw/rtcm(51)**4
27198 IF(i.EQ.7) THEN
27199 wid2=wids(24,2)*wids(pycomp(ktechn+213),3)
27200 ELSE
27201 wid2=wids(24,3)*wids(pycomp(ktechn+213),2)
27202 ENDIF
27203 ELSEIF(i.EQ.9) THEN
27204C...a_T^0 -> Z^0 rho_T^0
27205 va2=(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(50)**4
27206 wid2=wids(23,2)*wids(pycomp(ktechn+113),2)
27207 ELSEIF(i.EQ.10) THEN
27208C...a_T^0 -> Z^0 omega_T
27209 va2=.25d0*(1d0-2d0*xw)**2/xw/xw1/rtcm(50)**4
27210 wid2=wids(23,2)*wids(pycomp(ktechn+223),2)
27211 ENDIF
27212 wdtp(i)=aem*shr**5*pcm/12d0*(va2*facpv+aa2*facpa)
27213 ELSE
27214C...a2_tc0 -> f + fbar.
27215 wid2=1d0
27216 IF(i.LE.18) THEN
27217 ia=i-10
27218 fcof=3d0*radc
27219 IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)
27220 ELSE
27221 ia=i-8
27222 fcof=1d0
27223 IF(ia.GE.17) wid2=wids(ia,1)
27224 ENDIF
27225 ei=kchg(ia,1)/3d0
27226 ai=sign(1d0,ei+0.1d0)
27227 vi=ai-4d0*ei*xwv
27228 vali=0.5d0*(vi+ai)
27229 vari=0.5d0*(vi-ai)
27230 wdtp(i)=facf*fcof*sqrt(max(0d0,1d0-4d0*rm1))*((1d0-rm1)*
27231 & ((vali*bwzr)**2+(vali*bwzi)**2+
27232 & (vari*bwzr)**2+(vari*bwzi)**2)+6d0*rm1*(
27233 & (vali*bwzr)*(vari*bwzr)+vali*vari*bwzi**2))
27234 ENDIF
27235 wdtp(i)=fudge*wdtp(i)
27236 wdtp(0)=wdtp(0)+wdtp(i)
27237 IF(mdme(idc,1).GT.0) THEN
27238 wdte(i,mdme(idc,1))=wdtp(i)*wid2
27239 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27240 wdte(i,0)=wdte(i,mdme(idc,1))
27241 wdte(0,0)=wdte(0,0)+wdte(i,0)
27242 ENDIF
27243 530 CONTINUE
27244
27245 ELSEIF(kfla.EQ.ktechn+215) THEN
27246C...Techni-a2+/-:
27247 alprht=2.16d0*(3d0/itcm(1))*rtcm(47)**2
27248 fac=(alprht/12d0)*shr
27249 sqmz=pmas(23,1)**2
27250 sqmw=pmas(24,1)**2
27251 shp=sh
27252 CALL pywidx(24,shp,wdtpp,wdtep)
27253 gmmw=shr*wdtpp(0)
27254 facf=(1d0/12d0)*(aem**2/alprht)*shr*
27255 & (0.125d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
27256 DO 540 i=1,mdcy(kc,3)
27257 idc=i+mdcy(kc,2)-1
27258 IF(mdme(idc,1).LT.0) GOTO 540
27259 rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh
27260 rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh
27261 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 540
27262 wid2=1d0
27263 pcm=.5d0*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27264 IF(kflr.GT.0) THEN
27265 ichann=2
27266 ELSE
27267 ichann=3
27268 ENDIF
27269 IF(i.LE.7) THEN
27270 aa2=0
27271 va2=0
27272C...a2_tc+ -> gamma + W+.
27273 IF(i.EQ.1) THEN
27274 aa2=rtcm(3)**2/rtcm(49)**2
27275 wid2=wids(24,ichann)
27276C...a2_tc+ -> gamma + pi_tc+.
27277 ELSEIF(i.EQ.2) THEN
27278 aa2=(1d0-rtcm(3)**2)/rtcm(49)**2
27279 wid2=wids(pycomp(ktechn+211),ichann)
27280C...a2_tc+ -> W+ + Z
27281 ELSEIF(i.EQ.3) THEN
27282 aa2=rtcm(3)**2*(1d0/4d0/xw1 +
27283 & (xw-xw1)**2/4./xw/xw1)/rtcm(49)**2
27284 wid2=wids(24,ichann)*wids(23,2)
27285C...a2_tc+ -> W+ + pi_tc0.
27286 ELSEIF(i.EQ.4) THEN
27287 aa2=(1d0-rtcm(3)**2)/4d0/xw/rtcm(49)**2
27288 wid2=wids(24,ichann)*wids(pycomp(ktechn+111),2)
27289C...a2_tc+ -> W+ + pi_tc'0.
27290 ELSEIF(i.EQ.5) THEN
27291 va2=(1d0-rtcm(4)**2)/4d0/xw/rtcm(48)**2
27292 wid2=wids(24,ichann)*wids(pycomp(ktechn+221),2)
27293C...a2_tc+ -> Z0 + pi_tc+.
27294 ELSEIF(i.EQ.6) THEN
27295 aa2=(1d0-rtcm(3)**2)/4d0/xw/xw1*(1d0-2d0*xw)**2/
27296 & rtcm(49)**2
27297 wid2=wids(23,2)*wids(pycomp(ktechn+211),ichann)
27298 ENDIF
27299 wdtp(i)=aem*pcm*(aa2*(pcm**2+1.5d0*rm1)+pcm**2*va2)
27300 & /3d0*shr**3
27301 ELSEIF(i.LE.10) THEN
27302 facpv=pcm**2*(1d0+rm1+rm2)+3d0*rm1*rm2
27303 facpa=pcm**2*(1d0+rm1+rm2)
27304 va2=0d0
27305 aa2=0d0
27306C...a2_tc+ -> gamma + rho_tc+
27307 IF(i.EQ.7) THEN
27308 va2=(2d0*rtcm(2)-1d0)**2/rtcm(50)**4
27309 wid2=wids(pycomp(ktechn+213),ichann)
27310C...a2_tc+ -> W+ + rho_T^0
27311 ELSEIF(i.EQ.8) THEN
27312 aa2=1d0/(4d0*xw)/rtcm(51)**4
27313 wid2=wids(24,ichann)*wids(pycomp(ktechn+113),2)
27314C...a2_tc+ -> W+ + omega_T
27315 ELSEIF(i.EQ.9) THEN
27316 va2=.25d0/xw/rtcm(50)**4
27317 wid2=wids(24,ichann)*wids(pycomp(ktechn+223),2)
27318C...a2_tc+ -> Z^0 + rho_T^+
27319 ELSEIF(i.EQ.10) THEN
27320 va2=(2d0*rtcm(2)-1d0)**2*xw/xw1/rtcm(50)**4
27321 aa2=1d0/(4d0*xw*xw1)/rtcm(51)**4
27322 wid2=wids(23,2)*wids(pycomp(ktechn+213),ichann)
27323 ENDIF
27324 wdtp(i)=aem*shr**5*pcm/12d0*(va2*facpv+aa2*facpa)
27325 ELSE
27326C...a2_tc+ -> f + fbar'.
27327 ia=i-10
27328 wid2=1d0
27329 IF(ia.LE.16) THEN
27330 fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)
27331 IF(kflr.GT.0) THEN
27332 IF(mod(ia,4).EQ.3) wid2=wids(6,2)
27333 IF(mod(ia,4).EQ.0) wid2=wids(8,2)
27334 IF(ia.GE.13) wid2=wid2*wids(7,3)
27335 ELSE
27336 IF(mod(ia,4).EQ.3) wid2=wids(6,3)
27337 IF(mod(ia,4).EQ.0) wid2=wids(8,3)
27338 IF(ia.GE.13) wid2=wid2*wids(7,2)
27339 ENDIF
27340 ELSE
27341 fcof=1d0
27342 IF(kflr.GT.0) THEN
27343 IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)
27344 ELSE
27345 IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)
27346 ENDIF
27347 ENDIF
27348 wdtp(i)=facf*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
27349 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27350 ENDIF
27351 wdtp(i)=fudge*wdtp(i)
27352 wdtp(0)=wdtp(0)+wdtp(i)
27353 IF(mdme(idc,1).GT.0) THEN
27354 wdte(i,mdme(idc,1))=wdtp(i)*wid2
27355 wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))
27356 wdte(i,0)=wdte(i,mdme(idc,1))
27357 wdte(0,0)=wdte(0,0)+wdte(i,0)
27358 ENDIF
27359 540 CONTINUE
27360
27361 ENDIF
27362 mint(61)=0
27363 mint(62)=0
27364 mint(63)=0
27365 RETURN
27366 END
27367
27368C***********************************************************************
27369
27370C...PYOFSH
27371C...Calculates partial width and differential cross-section maxima
27372C...of channels/processes not allowed on mass-shell, and selects
27373C...masses in such channels/processes.
27374
27375 SUBROUTINE pyofsh(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27376
27377C...Double precision and integer declarations.
27378 IMPLICIT DOUBLE PRECISION(a-h, o-z)
27379 IMPLICIT INTEGER(I-N)
27380 INTEGER PYK,PYCHGE,PYCOMP
27381C...Commonblocks.
27382 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
27383 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
27384 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
27385 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
27386 common/pypars/mstp(200),parp(200),msti(200),pari(200)
27387 common/pyint1/mint(400),vint(400)
27388 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
27389 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
27390 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
27391 &/pyint2/,/pyint5/
27392C...Local arrays.
27393 dimension kfd(2),mbw(2),pmd(2),pgd(2),pmg(2),pml(2),pmu(2),
27394 &pmh(2),atl(2),atu(2),ath(2),rmg(2),inx1(100),xpt1(100),
27395 &fpt1(100),inx2(100),xpt2(100),fpt2(100),wdtp(0:400),
27396 &wdte(0:400,0:5)
27397
27398C...Find if particles equal, maximum mass, matrix elements, etc.
27399 mint(51)=0
27400 isub=mint(1)
27401 kfd(1)=iabs(kfd1)
27402 kfd(2)=iabs(kfd2)
27403 meql=0
27404 IF(kfd(1).EQ.kfd(2)) meql=1
27405 mlm=0
27406 IF(mofsh.GE.2.AND.meql.EQ.1) mlm=int(1.5d0+pyr(0))
27407 IF(mofsh.LE.2.OR.mofsh.EQ.5) THEN
27408 noff=44
27409 pmmx=pmmo
27410 ELSE
27411 noff=40
27412 pmmx=vint(1)
27413 IF(ckin(2).GT.ckin(1)) pmmx=min(ckin(2),vint(1))
27414 ENDIF
27415 mmed=0
27416 IF((kfmo.EQ.25.OR.kfmo.EQ.35.OR.kfmo.EQ.36).AND.meql.EQ.1.AND.
27417 &(kfd(1).EQ.23.OR.kfd(1).EQ.24)) mmed=1
27418 IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(1).EQ.23.OR.
27419 &kfd(1).EQ.24).AND.(kfd(2).EQ.23.OR.kfd(2).EQ.24)) mmed=2
27420 IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(2).EQ.25.OR.
27421 &kfd(2).EQ.35.OR.kfd(2).EQ.36)) mmed=3
27422 loop=1
27423
27424C...Find where Breit-Wigners are required, else select discrete masses.
27425 100 DO 110 i=1,2
27426 kfca=pycomp(kfd(i))
27427 IF(kfca.GT.0) THEN
27428 pmd(i)=pmas(kfca,1)
27429 pgd(i)=pmas(kfca,2)
27430 ELSE
27431 pmd(i)=0d0
27432 pgd(i)=0d0
27433 ENDIF
27434 IF(mstp(42).LE.0.OR.pgd(i).LT.parp(41)) THEN
27435 mbw(i)=0
27436 pmg(i)=pmd(i)
27437 rmg(i)=(pmg(i)/pmmx)**2
27438 ELSE
27439 mbw(i)=1
27440 ENDIF
27441 110 CONTINUE
27442
27443C...Find allowed mass range and Breit-Wigner parameters.
27444 DO 120 i=1,2
27445 IF(mofsh.EQ.1.AND.loop.EQ.1.AND.mbw(i).EQ.1) THEN
27446 pml(i)=parp(42)
27447 pmu(i)=pmmx-parp(42)
27448 IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
27449 IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
27450 ELSEIF(mbw(i).EQ.1.AND.mofsh.NE.5) THEN
27451 ilm=i
27452 IF(mlm.EQ.2) ilm=3-i
27453 pml(i)=max(ckin(noff+2*ilm-1),parp(42))
27454 IF(mbw(3-i).EQ.0) THEN
27455 pmu(i)=pmmx-pmd(3-i)
27456 ELSE
27457 pmu(i)=pmmx-max(ckin(noff+5-2*ilm),parp(42))
27458 ENDIF
27459 IF(ckin(noff+2*ilm).GT.ckin(noff+2*ilm-1)) pmu(i)=
27460 & min(pmu(i),ckin(noff+2*ilm))
27461 IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
27462 IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
27463 IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
27464 IF(mbw(i).EQ.1) THEN
27465 atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
27466 atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
27467 IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
27468 & pgd(i)))
27469 ENDIF
27470 ELSEIF(mbw(i).EQ.1.AND.mofsh.EQ.5) THEN
27471 ilm=i
27472 IF(mlm.EQ.2) ilm=3-i
27473 pml(i)=max(ckin(48+i),parp(42))
27474 pmu(i)=pmmx-max(ckin(51-i),parp(42))
27475 IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))
27476 IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)
27477 IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)
27478 IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1
27479 IF(mbw(i).EQ.1) THEN
27480 atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
27481 atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))
27482 IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*
27483 & pgd(i)))
27484 ENDIF
27485 ENDIF
27486 120 CONTINUE
27487 IF(mbw(1).LT.0.OR.mbw(2).LT.0.OR.(mbw(1).EQ.0.AND.mbw(2).EQ.0))
27488 &THEN
27489 CALL pyerrm(3,'(PYOFSH:) no allowed decay product masses')
27490 mint(51)=1
27491 RETURN
27492 ENDIF
27493
27494C...Calculation of partial width of resonance.
27495 IF(mofsh.EQ.1) THEN
27496
27497C..If only one integration, pick that to be the inner.
27498 IF(mbw(1).EQ.0) THEN
27499 pm2=pmd(1)
27500 pmd(1)=pmd(2)
27501 pgd(1)=pgd(2)
27502 pml(1)=pml(2)
27503 pmu(1)=pmu(2)
27504 ELSEIF(mbw(2).EQ.0) THEN
27505 pm2=pmd(2)
27506 ENDIF
27507
27508C...Start outer loop of integration.
27509 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
27510 atl2=atan((pml(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
27511 atu2=atan((pmu(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))
27512 npt2=1
27513 xpt2(1)=1d0
27514 inx2(1)=0
27515 fmax2=0d0
27516 ENDIF
27517 130 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
27518 pm2s=pmd(2)**2+pmd(2)*pgd(2)*tan(atl2+xpt2(npt2)*(atu2-atl2))
27519 pm2=min(pmu(2),max(pml(2),sqrt(max(0d0,pm2s))))
27520 ENDIF
27521 rm2=(pm2/pmmx)**2
27522
27523C...Start inner loop of integration.
27524 pml1=pml(1)
27525 pmu1=min(pmu(1),pmmx-pm2)
27526 IF(meql.EQ.1) pmu1=min(pmu1,pm2)
27527 atl1=atan((pml1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
27528 atu1=atan((pmu1**2-pmd(1)**2)/(pmd(1)*pgd(1)))
27529 IF(pml1+parj(64).GE.pmu1.OR.atl1+1d-7.GE.atu1) THEN
27530 func2=0d0
27531 GOTO 180
27532 ENDIF
27533 npt1=1
27534 xpt1(1)=1d0
27535 inx1(1)=0
27536 fmax1=0d0
27537 140 pm1s=pmd(1)**2+pmd(1)*pgd(1)*tan(atl1+xpt1(npt1)*(atu1-atl1))
27538 pm1=min(pmu1,max(pml1,sqrt(max(0d0,pm1s))))
27539 rm1=(pm1/pmmx)**2
27540
27541C...Evaluate function value - inner loop.
27542 func1=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
27543 IF(mmed.EQ.1) func1=func1*((1d0-rm1-rm2)**2+8d0*rm1*rm2)
27544 IF(mmed.EQ.2) func1=func1**3*(1d0+10d0*rm1+10d0*rm2+rm1**2+
27545 & rm2**2+10d0*rm1*rm2)
27546 IF(func1.GT.fmax1) fmax1=func1
27547 fpt1(npt1)=func1
27548
27549C...Go to next position in inner loop.
27550 IF(npt1.EQ.1) THEN
27551 npt1=npt1+1
27552 xpt1(npt1)=0d0
27553 inx1(npt1)=1
27554 GOTO 140
27555 ELSEIF(npt1.LE.8) THEN
27556 npt1=npt1+1
27557 IF(npt1.LE.4.OR.npt1.EQ.6) ish1=1
27558 ish1=ish1+1
27559 xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
27560 inx1(npt1)=inx1(ish1)
27561 inx1(ish1)=npt1
27562 GOTO 140
27563 ELSEIF(npt1.LT.100) THEN
27564 isn1=ish1
27565 150 ish1=ish1+1
27566 IF(ish1.GT.npt1) ish1=2
27567 IF(ish1.EQ.isn1) GOTO 160
27568 dfpt1=abs(fpt1(ish1)-fpt1(inx1(ish1)))
27569 IF(dfpt1.LT.parp(43)*fmax1) GOTO 150
27570 npt1=npt1+1
27571 xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))
27572 inx1(npt1)=inx1(ish1)
27573 inx1(ish1)=npt1
27574 GOTO 140
27575 ENDIF
27576
27577C...Calculate integral over inner loop.
27578 160 fsum1=0d0
27579 DO 170 ipt1=2,npt1
27580 fsum1=fsum1+0.5d0*(fpt1(ipt1)+fpt1(inx1(ipt1)))*
27581 & (xpt1(inx1(ipt1))-xpt1(ipt1))
27582 170 CONTINUE
27583 func2=fsum1*(atu1-atl1)/paru(1)
27584 180 IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN
27585 IF(func2.GT.fmax2) fmax2=func2
27586 fpt2(npt2)=func2
27587
27588C...Go to next position in outer loop.
27589 IF(npt2.EQ.1) THEN
27590 npt2=npt2+1
27591 xpt2(npt2)=0d0
27592 inx2(npt2)=1
27593 GOTO 130
27594 ELSEIF(npt2.LE.8) THEN
27595 npt2=npt2+1
27596 IF(npt2.LE.4.OR.npt2.EQ.6) ish2=1
27597 ish2=ish2+1
27598 xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
27599 inx2(npt2)=inx2(ish2)
27600 inx2(ish2)=npt2
27601 GOTO 130
27602 ELSEIF(npt2.LT.100) THEN
27603 isn2=ish2
27604 190 ish2=ish2+1
27605 IF(ish2.GT.npt2) ish2=2
27606 IF(ish2.EQ.isn2) GOTO 200
27607 dfpt2=abs(fpt2(ish2)-fpt2(inx2(ish2)))
27608 IF(dfpt2.LT.parp(43)*fmax2) GOTO 190
27609 npt2=npt2+1
27610 xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))
27611 inx2(npt2)=inx2(ish2)
27612 inx2(ish2)=npt2
27613 GOTO 130
27614 ENDIF
27615
27616C...Calculate integral over outer loop.
27617 200 fsum2=0d0
27618 DO 210 ipt2=2,npt2
27619 fsum2=fsum2+0.5d0*(fpt2(ipt2)+fpt2(inx2(ipt2)))*
27620 & (xpt2(inx2(ipt2))-xpt2(ipt2))
27621 210 CONTINUE
27622 fsum2=fsum2*(atu2-atl2)/paru(1)
27623 IF(meql.EQ.1) fsum2=2d0*fsum2
27624 ELSE
27625 fsum2=func2
27626 ENDIF
27627
27628C...Save result; second integration for user-selected mass range.
27629 IF(loop.EQ.1) widw=fsum2
27630 wid2=fsum2
27631 IF(loop.EQ.1.AND.(ckin(46).GE.ckin(45).OR.ckin(48).GE.ckin(47)
27632 & .OR.max(ckin(45),ckin(47)).GE.1.01d0*parp(42))) THEN
27633 loop=2
27634 GOTO 100
27635 ENDIF
27636 ret1=widw
27637 ret2=wid2/widw
27638
27639C...Select two decay product masses of a resonance.
27640 ELSEIF(mofsh.EQ.2.OR.mofsh.EQ.5) THEN
27641 220 DO 230 i=1,2
27642 IF(mbw(i).EQ.0) GOTO 230
27643 pmbw=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*
27644 & (atu(i)-atl(i)))
27645 pmg(i)=min(pmu(i),max(pml(i),sqrt(max(0d0,pmbw))))
27646 rmg(i)=(pmg(i)/pmmx)**2
27647 230 CONTINUE
27648 IF((meql.EQ.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
27649 & pmg(1)+pmg(2)+parj(64).GT.pmmx) GOTO 220
27650
27651C...Weight with matrix element (if none known, use beta factor).
27652 flam=sqrt(max(0d0,(1d0-rmg(1)-rmg(2))**2-4d0*rmg(1)*rmg(2)))
27653 IF(mmed.EQ.1) THEN
27654 wtbe=flam*((1d0-rmg(1)-rmg(2))**2+8d0*rmg(1)*rmg(2))
27655 ELSEIF(mmed.EQ.2) THEN
27656 wtbe=flam**3*(1d0+10d0*rmg(1)+10d0*rmg(2)+rmg(1)**2+
27657 & rmg(2)**2+10d0*rmg(1)*rmg(2))
27658 ELSEIF(mmed.EQ.3) THEN
27659 wtbe=flam*(rmg(1)+flam**2/12d0)
27660 ELSE
27661 wtbe=flam
27662 ENDIF
27663 IF(wtbe.LT.pyr(0)) GOTO 220
27664 ret1=pmg(1)
27665 ret2=pmg(2)
27666
27667C...Find suitable set of masses for initialization of 2 -> 2 processes.
27668 ELSEIF(mofsh.EQ.3) THEN
27669 IF(mbw(1).NE.0.AND.mbw(2).EQ.0) THEN
27670 pmg(1)=min(pmd(1),0.5d0*(pml(1)+pmu(1)))
27671 pmg(2)=pmd(2)
27672 ELSEIF(mbw(2).NE.0.AND.mbw(1).EQ.0) THEN
27673 pmg(1)=pmd(1)
27674 pmg(2)=min(pmd(2),0.5d0*(pml(2)+pmu(2)))
27675 ELSE
27676 idiv=-1
27677 240 idiv=idiv+1
27678 pmg(1)=min(pmd(1),0.1d0*(idiv*pml(1)+(10-idiv)*pmu(1)))
27679 pmg(2)=min(pmd(2),0.1d0*(idiv*pml(2)+(10-idiv)*pmu(2)))
27680 IF(idiv.LE.9.AND.pmg(1)+pmg(2).GT.0.9d0*pmmx) GOTO 240
27681 ENDIF
27682 ret1=pmg(1)
27683 ret2=pmg(2)
27684
27685C...Evaluate importance of excluded tails of Breit-Wigners.
27686 IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
27687 & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
27688 IF(meql.LE.1) THEN
27689 vint(80)=1d0
27690 DO 250 i=1,2
27691 IF(mbw(i).NE.0) vint(80)=vint(80)*1.25d0*(atu(i)-atl(i))/
27692 & paru(1)
27693 250 CONTINUE
27694 ELSE
27695 vint(80)=(1.25d0/paru(1))**2*max((atu(1)-atl(1))*
27696 & (ath(2)-atl(2)),(ath(1)-atl(1))*(atu(2)-atl(2)))
27697 ENDIF
27698 IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.30.OR.isub.EQ.35).AND.
27699 & mstp(43).NE.2) vint(80)=2d0*vint(80)
27700 IF(isub.EQ.22.AND.mstp(43).NE.2) vint(80)=4d0*vint(80)
27701 IF(meql.GE.1) vint(80)=2d0*vint(80)
27702
27703C...Pick one particle to be the lighter (if improves efficiency).
27704 ELSEIF(mofsh.EQ.4) THEN
27705 IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)
27706 & .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2
27707 260 IF(meql.EQ.2) mlm=int(1.5d0+pyr(0))
27708
27709C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27710 DO 270 i=1,2
27711 IF(mbw(i).EQ.0) GOTO 270
27712 pmv=pmu(i)
27713 IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
27714 atv=atu(i)
27715 IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
27716 rbr=pyr(0)
27717 IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
27718 & isub.EQ.35).AND.mstp(43).NE.2) rbr=2d0*rbr
27719 IF(rbr.LT.0.8d0) THEN
27720 pmsr=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*(atv-atl(i)))
27721 pmg(i)=min(pmv,max(pml(i),sqrt(max(0d0,pmsr))))
27722 ELSEIF(rbr.LT.0.9d0) THEN
27723 pmg(i)=sqrt(max(0d0,pml(i)**2+pyr(0)*(pmv**2-pml(i)**2)))
27724 ELSEIF(rbr.LT.1.5d0) THEN
27725 pmg(i)=pml(i)*(pmv/pml(i))**pyr(0)
27726 ELSE
27727 pmg(i)=sqrt(max(0d0,pml(i)**2*pmv**2/(pml(i)**2+pyr(0)*
27728 & (pmv**2-pml(i)**2))))
27729 ENDIF
27730 270 CONTINUE
27731 IF((meql.GE.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.
27732 & pmg(1)+pmg(2)+parj(64).GT.pmmx) THEN
27733 IF(mint(48).EQ.1.AND.mstp(171).EQ.0) THEN
27734 ngen(0,1)=ngen(0,1)+1
27735 ngen(mint(1),1)=ngen(mint(1),1)+1
27736 GOTO 260
27737 ELSE
27738 mint(51)=1
27739 RETURN
27740 ENDIF
27741 ENDIF
27742 ret1=pmg(1)
27743 ret2=pmg(2)
27744
27745C...Give weight for selected mass distribution.
27746 vint(80)=1d0
27747 DO 280 i=1,2
27748 IF(mbw(i).EQ.0) GOTO 280
27749 pmv=pmu(i)
27750 IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)
27751 atv=atu(i)
27752 IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)
27753 f0=pmd(i)*pgd(i)/((pmg(i)**2-pmd(i)**2)**2+
27754 & (pmd(i)*pgd(i))**2)/paru(1)
27755 f1=1d0
27756 f2=1d0/pmg(i)**2
27757 f3=1d0/pmg(i)**4
27758 fi0=(atv-atl(i))/paru(1)
27759 fi1=pmv**2-pml(i)**2
27760 fi2=2d0*log(pmv/pml(i))
27761 fi3=1d0/pml(i)**2-1d0/pmv**2
27762 IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.
27763 & isub.EQ.35).AND.mstp(43).NE.2) THEN
27764 vint(80)=vint(80)*20d0/(8d0+(fi0/f0)*(f1/fi1+6d0*f2/fi2+
27765 & 5d0*f3/fi3))
27766 ELSE
27767 vint(80)=vint(80)*10d0/(8d0+(fi0/f0)*(f1/fi1+f2/fi2))
27768 ENDIF
27769 vint(80)=vint(80)*fi0
27770 280 CONTINUE
27771 IF(meql.GE.1) vint(80)=2d0*vint(80)
27772 ENDIF
27773
27774 RETURN
27775 END
27776
27777C***********************************************************************
27778
27779C...PYRECO
27780C...Handles the possibility of colour reconnection in W+W- events,
27781C...Based on the main scenarios of the Sjostrand and Khoze study:
27782C...I, II, II', intermediate and instantaneous; plus one model
27783C...along the lines of the Gustafson and Hakkinen: GH.
27784C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27785C...is as if first resonance is W+ and second W-.
27786
27787 SUBROUTINE pyreco(IW1,IW2,NSD1,NAFT1)
27788
27789C...Double precision and integer declarations.
27790 IMPLICIT DOUBLE PRECISION(a-h, o-z)
27791 IMPLICIT INTEGER(I-N)
27792 INTEGER PYK,PYCHGE,PYCOMP
27793C...Parameter value; number of points in MC integration.
27794 parameter(npt=100)
27795C...Commonblocks.
27796 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
27797 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
27798 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
27799 common/pypars/mstp(200),parp(200),msti(200),pari(200)
27800 common/pyint1/mint(400),vint(400)
27801 SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
27802C...Local arrays.
27803 dimension nbeg(2),nend(2),inp(50),inm(50),beww(3),xp(3),xm(3),
27804 &v1(3),v2(3),betp(50,4),dirp(50,3),betm(50,4),dirm(50,3),
27805 &xd(4),xb(4),iap(npt),iam(npt),wta(npt),v1p(3),v2p(3),v1m(3),
27806 &v2m(3),q(4,3),xpp(3),xmm(3),ipc(20),imc(20),tc(0:20),tpc(20),
27807 &tmc(20),ijoin(100)
27808
27809C...Functions to give four-product and to do determinants.
27810 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)
27811 deter(i,j,l)=q(i,1)*q(j,2)*q(l,3)-q(i,1)*q(l,2)*q(j,3)+
27812 &q(j,1)*q(l,2)*q(i,3)-q(j,1)*q(i,2)*q(l,3)+
27813 &q(l,1)*q(i,2)*q(j,3)-q(l,1)*q(j,2)*q(i,3)
27814
27815C...Only allow fraction of recoupling for GH, intermediate and
27816C...instantaneous.
27817 IF(mstp(115).EQ.5.OR.mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
27818 IF(pyr(0).GT.parp(120)) RETURN
27819 ENDIF
27820 isub=mint(1)
27821
27822C...Common part for scenarios I, II, II', and GH.
27823 IF(mstp(115).EQ.1.OR.mstp(115).EQ.2.OR.mstp(115).EQ.3.OR.
27824 &mstp(115).EQ.5) THEN
27825
27826C...Read out frequently-used parameters.
27827 pi=paru(1)
27828 hbar=paru(3)
27829 pmw=pmas(24,1)
27830 IF(isub.EQ.22) pmw=pmas(23,1)
27831 pgw=pmas(24,2)
27832 IF(isub.EQ.22) pgw=pmas(23,2)
27833 tfrag=parp(115)
27834 rhad=parp(116)
27835 fact=parp(117)
27836 blowr=parp(118)
27837 blowt=parp(119)
27838
27839C...Find range of decay products of the W's.
27840C...Background: the W's are stored in IW1 and IW2.
27841C...Their direct decay products in NSD1+1 through NSD1+4.
27842C...Products after shower (if any) in NSD1+5 through NAFT1
27843C...for first W and in NAFT1+1 through N for the second.
27844 IF(naft1.GT.nsd1+4) THEN
27845 nbeg(1)=nsd1+5
27846 nend(1)=naft1
27847 ELSE
27848 nbeg(1)=nsd1+1
27849 nend(1)=nsd1+2
27850 ENDIF
27851 IF(n.GT.naft1) THEN
27852 nbeg(2)=naft1+1
27853 nend(2)=n
27854 ELSE
27855 nbeg(2)=nsd1+3
27856 nend(2)=nsd1+4
27857 ENDIF
27858
27859C...Rearrange parton shower products along strings.
27860 nold=n
27861 CALL pyprep(nsd1+1)
27862 IF(mint(51).NE.0) RETURN
27863
27864C...Find partons pointing back to W+ and W-; store them with quark
27865C...end of string first.
27866 nnp=0
27867 nnm=0
27868 isgp=0
27869 isgm=0
27870 DO 120 i=nold+1,n
27871 IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 120
27872 IF(iabs(k(i,2)).GE.22) GOTO 120
27873 IF(k(i,3).GE.nbeg(1).AND.k(i,3).LE.nend(1)) THEN
27874 IF(isgp.EQ.0) isgp=isign(1,k(i,2))
27875 nnp=nnp+1
27876 IF(isgp.EQ.1) THEN
27877 inp(nnp)=i
27878 ELSE
27879 DO 100 i1=nnp,2,-1
27880 inp(i1)=inp(i1-1)
27881 100 CONTINUE
27882 inp(1)=i
27883 ENDIF
27884 IF(k(i,1).EQ.1) isgp=0
27885 ELSEIF(k(i,3).GE.nbeg(2).AND.k(i,3).LE.nend(2)) THEN
27886 IF(isgm.EQ.0) isgm=isign(1,k(i,2))
27887 nnm=nnm+1
27888 IF(isgm.EQ.1) THEN
27889 inm(nnm)=i
27890 ELSE
27891 DO 110 i1=nnm,2,-1
27892 inm(i1)=inm(i1-1)
27893 110 CONTINUE
27894 inm(1)=i
27895 ENDIF
27896 IF(k(i,1).EQ.1) isgm=0
27897 ENDIF
27898 120 CONTINUE
27899
27900C...Boost to W+W- rest frame (not strictly needed).
27901 DO 130 j=1,3
27902 beww(j)=(p(iw1,j)+p(iw2,j))/(p(iw1,4)+p(iw2,4))
27903 130 CONTINUE
27904 CALL pyrobo(iw1,iw1,0d0,0d0,-beww(1),-beww(2),-beww(3))
27905 CALL pyrobo(iw2,iw2,0d0,0d0,-beww(1),-beww(2),-beww(3))
27906 CALL pyrobo(nold+1,n,0d0,0d0,-beww(1),-beww(2),-beww(3))
27907
27908C...Select decay vertices of W+ and W-.
27909 tp=hbar*(-log(pyr(0)))*p(iw1,4)/
27910 & sqrt((p(iw1,5)**2-pmw**2)**2+(p(iw1,5)**2*pgw/pmw)**2)
27911 tm=hbar*(-log(pyr(0)))*p(iw2,4)/
27912 & sqrt((p(iw2,5)**2-pmw**2)**2+(p(iw2,5)**2*pgw/pmw)**2)
27913 gtmax=max(tp,tm)
27914 DO 140 j=1,3
27915 xp(j)=tp*p(iw1,j)/p(iw1,4)
27916 xm(j)=tm*p(iw2,j)/p(iw2,4)
27917 140 CONTINUE
27918
27919C...Begin scenario I specifics.
27920 IF(mstp(115).EQ.1) THEN
27921
27922C...Reconstruct velocity and direction of W+ string pieces.
27923 DO 170 iip=1,nnp-1
27924 IF(k(inp(iip),2).LT.0) GOTO 170
27925 i1=inp(iip)
27926 i2=inp(iip+1)
27927 p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
27928 p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
27929 DO 150 j=1,3
27930 v1(j)=p(i1,j)/p1a
27931 v2(j)=p(i2,j)/p2a
27932 betp(iip,j)=0.5d0*(v1(j)+v2(j))
27933 dirp(iip,j)=v1(j)-v2(j)
27934 150 CONTINUE
27935 betp(iip,4)=1d0/sqrt(1d0-betp(iip,1)**2-betp(iip,2)**2-
27936 & betp(iip,3)**2)
27937 dirl=sqrt(dirp(iip,1)**2+dirp(iip,2)**2+dirp(iip,3)**2)
27938 DO 160 j=1,3
27939 dirp(iip,j)=dirp(iip,j)/dirl
27940 160 CONTINUE
27941 170 CONTINUE
27942
27943C...Reconstruct velocity and direction of W- string pieces.
27944 DO 200 iim=1,nnm-1
27945 IF(k(inm(iim),2).LT.0) GOTO 200
27946 i1=inm(iim)
27947 i2=inm(iim+1)
27948 p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)
27949 p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)
27950 DO 180 j=1,3
27951 v1(j)=p(i1,j)/p1a
27952 v2(j)=p(i2,j)/p2a
27953 betm(iim,j)=0.5d0*(v1(j)+v2(j))
27954 dirm(iim,j)=v1(j)-v2(j)
27955 180 CONTINUE
27956 betm(iim,4)=1d0/sqrt(1d0-betm(iim,1)**2-betm(iim,2)**2-
27957 & betm(iim,3)**2)
27958 dirl=sqrt(dirm(iim,1)**2+dirm(iim,2)**2+dirm(iim,3)**2)
27959 DO 190 j=1,3
27960 dirm(iim,j)=dirm(iim,j)/dirl
27961 190 CONTINUE
27962 200 CONTINUE
27963
27964C...Loop over number of space-time points.
27965 nacc=0
27966 sum=0d0
27967 DO 250 ipt=1,npt
27968
27969C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
27970 r=sqrt(-log(pyr(0)))
27971 phi=2d0*pi*pyr(0)
27972 x=blowr*rhad*r*cos(phi)
27973 y=blowr*rhad*r*sin(phi)
27974 r=sqrt(-log(pyr(0)))
27975 phi=2d0*pi*pyr(0)
27976 z=blowr*rhad*r*cos(phi)
27977 t=gtmax+blowt*sqrt(0.5d0)*tfrag*r*abs(sin(phi))
27978
27979C...Reject impossible points. Weight for sample distribution.
27980 IF(t**2-x**2-y**2-z**2.LT.0d0) GOTO 250
27981 wtsmp=exp(-(x**2+y**2+z**2)/(blowr*rhad)**2)*
27982 & exp(-2d0*(t-gtmax)**2/(blowt*tfrag)**2)
27983
27984C...Loop over W+ string pieces and find one with largest weight.
27985 imaxp=0
27986 wtmaxp=1d-10
27987 xd(1)=x-xp(1)
27988 xd(2)=y-xp(2)
27989 xd(3)=z-xp(3)
27990 xd(4)=t-tp
27991 DO 220 iip=1,nnp-1
27992 IF(k(inp(iip),2).LT.0) GOTO 220
27993 bed=betp(iip,1)*xd(1)+betp(iip,2)*xd(2)+betp(iip,3)*xd(3)
27994 bedg=betp(iip,4)*(betp(iip,4)*bed/(1d0+betp(iip,4))-xd(4))
27995 DO 210 j=1,3
27996 xb(j)=xd(j)+bedg*betp(iip,j)
27997 210 CONTINUE
27998 xb(4)=betp(iip,4)*(xd(4)-bed)
27999 sr2=xb(1)**2+xb(2)**2+xb(3)**2
28000 sz2=(dirp(iip,1)*xb(1)+dirp(iip,2)*xb(2)+
28001 & dirp(iip,3)*xb(3))**2
28002 wtp=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
28003 & tfrag**2)
28004 IF(xb(4)-sqrt(sr2).LT.0d0) wtp=0d0
28005 IF(wtp.GT.wtmaxp) THEN
28006 imaxp=iip
28007 wtmaxp=wtp
28008 ENDIF
28009 220 CONTINUE
28010
28011C...Loop over W- string pieces and find one with largest weight.
28012 imaxm=0
28013 wtmaxm=1d-10
28014 xd(1)=x-xm(1)
28015 xd(2)=y-xm(2)
28016 xd(3)=z-xm(3)
28017 xd(4)=t-tm
28018 DO 240 iim=1,nnm-1
28019 IF(k(inm(iim),2).LT.0) GOTO 240
28020 bed=betm(iim,1)*xd(1)+betm(iim,2)*xd(2)+betm(iim,3)*xd(3)
28021 bedg=betm(iim,4)*(betm(iim,4)*bed/(1d0+betm(iim,4))-xd(4))
28022 DO 230 j=1,3
28023 xb(j)=xd(j)+bedg*betm(iim,j)
28024 230 CONTINUE
28025 xb(4)=betm(iim,4)*(xd(4)-bed)
28026 sr2=xb(1)**2+xb(2)**2+xb(3)**2
28027 sz2=(dirm(iim,1)*xb(1)+dirm(iim,2)*xb(2)+
28028 & dirm(iim,3)*xb(3))**2
28029 wtm=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/
28030 & tfrag**2)
28031 IF(xb(4)-sqrt(sr2).LT.0d0) wtm=0d0
28032 IF(wtm.GT.wtmaxm) THEN
28033 imaxm=iim
28034 wtmaxm=wtm
28035 ENDIF
28036 240 CONTINUE
28037
28038C...Result of integration.
28039 wt=0d0
28040 IF(imaxp.NE.0.AND.imaxm.NE.0) THEN
28041 wt=wtmaxp*wtmaxm/wtsmp
28042 sum=sum+wt
28043 nacc=nacc+1
28044 iap(nacc)=imaxp
28045 iam(nacc)=imaxm
28046 wta(nacc)=wt
28047 ENDIF
28048 250 CONTINUE
28049 res=blowr**3*blowt*sum/npt
28050
28051C...Decide whether to reconnect and, if so, where.
28052 iacc=0
28053 prec=1d0-exp(-fact*res)
28054 IF(prec.GT.pyr(0)) THEN
28055 rsum=pyr(0)*sum
28056 DO 260 ia=1,nacc
28057 iacc=ia
28058 rsum=rsum-wta(ia)
28059 IF(rsum.LE.0d0) GOTO 270
28060 260 CONTINUE
28061 270 iip=iap(iacc)
28062 iim=iam(iacc)
28063 ENDIF
28064
28065C...Begin scenario II and II' specifics.
28066 ELSEIF(mstp(115).EQ.2.OR.mstp(115).EQ.3) THEN
28067
28068C...Loop through all string pieces, one from W+ and one from W-.
28069 ncross=0
28070 tc(0)=0d0
28071 DO 340 iip=1,nnp-1
28072 IF(k(inp(iip),2).LT.0) GOTO 340
28073 i1p=inp(iip)
28074 i2p=inp(iip+1)
28075 DO 330 iim=1,nnm-1
28076 IF(k(inm(iim),2).LT.0) GOTO 330
28077 i1m=inm(iim)
28078 i2m=inm(iim+1)
28079
28080C...Find endpoint velocity vectors.
28081 DO 280 j=1,3
28082 v1p(j)=p(i1p,j)/p(i1p,4)
28083 v2p(j)=p(i2p,j)/p(i2p,4)
28084 v1m(j)=p(i1m,j)/p(i1m,4)
28085 v2m(j)=p(i2m,j)/p(i2m,4)
28086 280 CONTINUE
28087
28088C...Define q matrix and find t.
28089 DO 290 j=1,3
28090 q(1,j)=v2p(j)-v1p(j)
28091 q(2,j)=-(v2m(j)-v1m(j))
28092 q(3,j)=xp(j)-xm(j)-tp*v1p(j)+tm*v1m(j)
28093 q(4,j)=v1p(j)-v1m(j)
28094 290 CONTINUE
28095 t=-deter(1,2,3)/deter(1,2,4)
28096
28097C...Find alpha and beta; i.e. coordinates of crossing point.
28098 s11=q(1,1)*(t-tp)
28099 s12=q(2,1)*(t-tm)
28100 s13=q(3,1)+q(4,1)*t
28101 s21=q(1,2)*(t-tp)
28102 s22=q(2,2)*(t-tm)
28103 s23=q(3,2)+q(4,2)*t
28104 den=s11*s22-s12*s21
28105 alp=(s12*s23-s22*s13)/den
28106 bet=(s21*s13-s11*s23)/den
28107
28108C...Check if solution acceptable.
28109 iansw=1
28110 IF(t.LT.gtmax) iansw=0
28111 IF(alp.LT.0d0.OR.alp.GT.1d0) iansw=0
28112 IF(bet.LT.0d0.OR.bet.GT.1d0) iansw=0
28113
28114C...Find point of crossing and check that not inconsistent.
28115 DO 300 j=1,3
28116 xpp(j)=xp(j)+(v1p(j)+alp*(v2p(j)-v1p(j)))*(t-tp)
28117 xmm(j)=xm(j)+(v1m(j)+bet*(v2m(j)-v1m(j)))*(t-tm)
28118 300 CONTINUE
28119 d2pm=(xpp(1)-xmm(1))**2+(xpp(2)-xmm(2))**2+
28120 & (xpp(3)-xmm(3))**2
28121 d2p=xpp(1)**2+xpp(2)**2+xpp(3)**2
28122 d2m=xmm(1)**2+xmm(2)**2+xmm(3)**2
28123 IF(d2pm.GT.1d-4*(d2p+d2m)) iansw=-1
28124
28125C...Find string eigentimes at crossing.
28126 IF(iansw.EQ.1) THEN
28127 taup=sqrt(max(0d0,(t-tp)**2-(xpp(1)-xp(1))**2-
28128 & (xpp(2)-xp(2))**2-(xpp(3)-xp(3))**2))
28129 taum=sqrt(max(0d0,(t-tm)**2-(xmm(1)-xm(1))**2-
28130 & (xmm(2)-xm(2))**2-(xmm(3)-xm(3))**2))
28131 ELSE
28132 taup=0d0
28133 taum=0d0
28134 ENDIF
28135
28136C...Order crossings by time. End loop over crossings.
28137 IF(iansw.EQ.1.AND.ncross.LT.20) THEN
28138 ncross=ncross+1
28139 DO 310 i1=ncross,1,-1
28140 IF(t.GT.tc(i1-1).OR.i1.EQ.1) THEN
28141 ipc(i1)=iip
28142 imc(i1)=iim
28143 tc(i1)=t
28144 tpc(i1)=taup
28145 tmc(i1)=taum
28146 GOTO 320
28147 ELSE
28148 ipc(i1)=ipc(i1-1)
28149 imc(i1)=imc(i1-1)
28150 tc(i1)=tc(i1-1)
28151 tpc(i1)=tpc(i1-1)
28152 tmc(i1)=tmc(i1-1)
28153 ENDIF
28154 310 CONTINUE
28155 320 CONTINUE
28156 ENDIF
28157 330 CONTINUE
28158 340 CONTINUE
28159
28160C...Loop over crossings; find first (if any) acceptable one.
28161 iacc=0
28162 IF(ncross.GE.1) THEN
28163 DO 350 ic=1,ncross
28164 pnfrag=exp(-(tpc(ic)**2+tmc(ic)**2)/tfrag**2)
28165 IF(pnfrag.GT.pyr(0)) THEN
28166C...Scenario II: only compare with fragmentation time.
28167 IF(mstp(115).EQ.2) THEN
28168 iacc=ic
28169 iip=ipc(iacc)
28170 iim=imc(iacc)
28171 GOTO 360
28172C...Scenario II': also require that string length decreases.
28173 ELSE
28174 iip=ipc(ic)
28175 iim=imc(ic)
28176 i1p=inp(iip)
28177 i2p=inp(iip+1)
28178 i1m=inm(iim)
28179 i2m=inm(iim+1)
28180 elold=four(i1p,i2p)*four(i1m,i2m)
28181 elnew=four(i1p,i2m)*four(i1m,i2p)
28182 IF(elnew.LT.elold) THEN
28183 iacc=ic
28184 iip=ipc(iacc)
28185 iim=imc(iacc)
28186 GOTO 360
28187 ENDIF
28188 ENDIF
28189 ENDIF
28190 350 CONTINUE
28191 360 CONTINUE
28192 ENDIF
28193
28194C...Begin scenario GH specifics.
28195 ELSEIF(mstp(115).EQ.5) THEN
28196
28197C...Loop through all string pieces, one from W+ and one from W-.
28198 iacc=0
28199 elmin=1d0
28200 DO 380 iip=1,nnp-1
28201 IF(k(inp(iip),2).LT.0) GOTO 380
28202 i1p=inp(iip)
28203 i2p=inp(iip+1)
28204 DO 370 iim=1,nnm-1
28205 IF(k(inm(iim),2).LT.0) GOTO 370
28206 i1m=inm(iim)
28207 i2m=inm(iim+1)
28208
28209C...Look for largest decrease of (exponent of) Lambda measure.
28210 elold=four(i1p,i2p)*four(i1m,i2m)
28211 elnew=four(i1p,i2m)*four(i1m,i2p)
28212 eldif=elnew/max(1d-10,elold)
28213 IF(eldif.LT.elmin) THEN
28214 iacc=iip+iim
28215 elmin=eldif
28216 ipc(1)=iip
28217 imc(1)=iim
28218 ENDIF
28219 370 CONTINUE
28220 380 CONTINUE
28221 iip=ipc(1)
28222 iim=imc(1)
28223 ENDIF
28224
28225C...Common for scenarios I, II, II' and GH: reconnect strings.
28226 IF(iacc.NE.0) THEN
28227 mint(32)=1
28228 njoin=0
28229 DO 390 is=1,nnp+nnm
28230 njoin=njoin+1
28231 IF(is.LE.iip) THEN
28232 i=inp(is)
28233 ELSEIF(is.LE.iip+nnm-iim) THEN
28234 i=inm(is-iip+iim)
28235 ELSEIF(is.LE.iip+nnm) THEN
28236 i=inm(is-iip-nnm+iim)
28237 ELSE
28238 i=inp(is-nnm)
28239 ENDIF
28240 ijoin(njoin)=i
28241 IF(k(i,2).LT.0) THEN
28242 CALL pyjoin(njoin,ijoin)
28243 njoin=0
28244 ENDIF
28245 390 CONTINUE
28246
28247C...Restore original event record if no reconnection.
28248 ELSE
28249 DO 400 i=nsd1+1,nold
28250 IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN
28251 k(i,4)=mod(k(i,4),mstu(5)**2)
28252 k(i,5)=mod(k(i,5),mstu(5)**2)
28253 ENDIF
28254 400 CONTINUE
28255 DO 410 i=nold+1,n
28256 k(k(i,3),1)=3
28257 410 CONTINUE
28258 n=nold
28259 ENDIF
28260
28261C...Boost back system.
28262 CALL pyrobo(iw1,iw1,0d0,0d0,beww(1),beww(2),beww(3))
28263 CALL pyrobo(iw2,iw2,0d0,0d0,beww(1),beww(2),beww(3))
28264 IF(n.GT.nold) CALL pyrobo(nold+1,n,0d0,0d0,
28265 & beww(1),beww(2),beww(3))
28266
28267C...Common part for intermediate and instantaneous scenarios.
28268 ELSEIF(mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN
28269 mint(32)=1
28270
28271C...Remove old shower products and reset showering ones.
28272 n=nsd1+4
28273 DO 420 i=nsd1+1,nsd1+4
28274 k(i,1)=3
28275 k(i,4)=mod(k(i,4),mstu(5)**2)
28276 k(i,5)=mod(k(i,5),mstu(5)**2)
28277 420 CONTINUE
28278
28279C...Identify quark-antiquark pairs.
28280 iq1=nsd1+1
28281 iq2=nsd1+2
28282 iq3=nsd1+3
28283 IF(k(iq1,2)*k(iq3,2).LT.0) iq3=nsd1+4
28284 iq4=2*nsd1+7-iq3
28285
28286C...Reconnect strings.
28287 ijoin(1)=iq1
28288 ijoin(2)=iq4
28289 CALL pyjoin(2,ijoin)
28290 ijoin(1)=iq3
28291 ijoin(2)=iq2
28292 CALL pyjoin(2,ijoin)
28293
28294C...Do new parton showers in intermediate scenario.
28295 IF(mstp(71).GE.1.AND.mstp(115).EQ.11) THEN
28296 mstj50=mstj(50)
28297 mstj(50)=0
28298 CALL pyshow(iq1,iq2,p(iw1,5))
28299 CALL pyshow(iq3,iq4,p(iw2,5))
28300 mstj(50)=mstj50
28301
28302C...Do new parton showers in instantaneous scenario.
28303 ELSEIF(mstp(71).GE.1.AND.mstp(115).EQ.12) THEN
28304 ppm2=(p(iq1,4)+p(iq4,4))**2-(p(iq1,1)+p(iq4,1))**2-
28305 & (p(iq1,2)+p(iq4,2))**2-(p(iq1,3)+p(iq4,3))**2
28306 ppm=sqrt(max(0d0,ppm2))
28307 CALL pyshow(iq1,iq4,ppm)
28308 ppm2=(p(iq3,4)+p(iq2,4))**2-(p(iq3,1)+p(iq2,1))**2-
28309 & (p(iq3,2)+p(iq2,2))**2-(p(iq3,3)+p(iq2,3))**2
28310 ppm=sqrt(max(0d0,ppm2))
28311 CALL pyshow(iq3,iq2,ppm)
28312 ENDIF
28313 ENDIF
28314
28315 RETURN
28316 END
28317
28318C***********************************************************************
28319
28320C...PYKLIM
28321C...Checks generated variables against pre-set kinematical limits;
28322C...also calculates limits on variables used in generation.
28323
28324 SUBROUTINE pyklim(ILIM)
28325
28326C...Double precision and integer declarations.
28327 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28328 IMPLICIT INTEGER(I-N)
28329 INTEGER PYK,PYCHGE,PYCOMP
28330C...Commonblocks.
28331 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
28332 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28333 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28334 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
28335 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
28336 common/pypars/mstp(200),parp(200),msti(200),pari(200)
28337 common/pyint1/mint(400),vint(400)
28338 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
28339 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
28340 &/pyint1/,/pyint2/
28341
28342C...Common kinematical expressions.
28343 mint(51)=0
28344 isub=mint(1)
28345 istsb=iset(isub)
28346 IF(isub.EQ.96) GOTO 100
28347 sqm3=vint(63)
28348 sqm4=vint(64)
28349 IF(ilim.NE.0) THEN
28350 IF(abs(sqm3).LT.1d-4.AND.abs(sqm4).LT.1d-4) THEN
28351 ckin09=max(ckin(9),ckin(13))
28352 ckin10=min(ckin(10),ckin(14))
28353 ckin11=max(ckin(11),ckin(15))
28354 ckin12=min(ckin(12),ckin(16))
28355 ELSE
28356 ckin09=max(ckin(9),min(0d0,ckin(13)))
28357 ckin10=min(ckin(10),max(0d0,ckin(14)))
28358 ckin11=max(ckin(11),min(0d0,ckin(15)))
28359 ckin12=min(ckin(12),max(0d0,ckin(16)))
28360 ENDIF
28361 ENDIF
28362 IF(ilim.NE.1) THEN
28363 tau=vint(21)
28364 rm3=sqm3/(tau*vint(2))
28365 rm4=sqm4/(tau*vint(2))
28366 be34=sqrt(max(1d-20,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
28367 ENDIF
28368 pthmin=ckin(3)
28369 IF(min(sqm3,sqm4).LT.ckin(6)**2.AND.istsb.NE.1.AND.istsb.NE.3)
28370 &pthmin=max(ckin(3),ckin(5))
28371
28372 IF(ilim.EQ.0) THEN
28373C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28374C...pre-set kinematical limits.
28375 yst=vint(22)
28376 cth=vint(23)
28377 taup=vint(26)
28378 taue=tau
28379 IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
28380 x1=sqrt(taue)*exp(yst)
28381 x2=sqrt(taue)*exp(-yst)
28382 xf=x1-x2
28383 IF(mint(47).NE.1) THEN
28384 IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1
28385 IF(ckin(2).GE.0d0.AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1
28386 IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1
28387 IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1
28388 ENDIF
28389 IF(mint(45).NE.1) THEN
28390 IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1
28391 ENDIF
28392 IF(mint(46).NE.1) THEN
28393 IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1
28394 ENDIF
28395 IF(mint(45).EQ.2) THEN
28396 IF(x1.GT.1d0-2d0*parp(111)/vint(1)) mint(51)=1
28397 ENDIF
28398 IF(mint(46).EQ.2) THEN
28399 IF(x2.GT.1d0-2d0*parp(111)/vint(1)) mint(51)=1
28400 ENDIF
28401 IF(istsb.EQ.2.OR.istsb.EQ.4) THEN
28402 pth=0.5d0*be34*sqrt(tau*vint(2)*max(0d0,1d0-cth**2))
28403 expy3=max(1d-20,(1d0+rm3-rm4+be34*cth)/
28404 & max(1d-20,(1d0+rm3-rm4-be34*cth)))
28405 expy4=max(1d-20,(1d0-rm3+rm4-be34*cth)/
28406 & max(1d-20,(1d0-rm3+rm4+be34*cth)))
28407 y3=yst+0.5d0*log(expy3)
28408 y4=yst+0.5d0*log(expy4)
28409 ylarge=max(y3,y4)
28410 ysmall=min(y3,y4)
28411 etalar=20d0
28412 etasma=-20d0
28413 sth=sqrt(max(0d0,1d0-cth**2))
28414 exsq3=sqrt(max(1d-20,((1d0+rm3-rm4)*cosh(yst)+be34*sinh(yst)*
28415 & cth)**2-4d0*rm3))
28416 exsq4=sqrt(max(1d-20,((1d0-rm3+rm4)*cosh(yst)-be34*sinh(yst)*
28417 & cth)**2-4d0*rm4))
28418 IF(sth.GE.1d-10) THEN
28419 expet3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+exsq3)/
28420 & (be34*sth)
28421 expet4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+exsq4)/
28422 & (be34*sth)
28423 eta3=log(min(1d10,max(1d-10,expet3)))
28424 eta4=log(min(1d10,max(1d-10,expet4)))
28425 etalar=max(eta3,eta4)
28426 etasma=min(eta3,eta4)
28427 ENDIF
28428 cts3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/exsq3
28429 cts4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/exsq4
28430 ctslar=min(1d0,max(-1d0,cts3,cts4))
28431 ctssma=max(-1d0,min(1d0,cts3,cts4))
28432 sh=tau*vint(2)
28433 rpts=4d0*vint(71)**2/sh
28434 be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
28435 rm34=max(1d-20,2d0*rm3*rm4)
28436 IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
28437 & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
28438 rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
28439 tha=0.5d0*sh*max(rthm,1d0-rm3-rm4-be34*cth)
28440 uha=0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
28441 IF(pth.LT.pthmin) mint(51)=1
28442 IF(ckin(4).GE.0d0.AND.pth.GT.ckin(4)) mint(51)=1
28443 IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1
28444 IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1
28445 IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1
28446 IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1
28447 IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1
28448 IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1
28449 IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1
28450 IF(tha.LT.ckin(35)) mint(51)=1
28451 IF(ckin(36).GE.0d0.AND.tha.GT.ckin(36)) mint(51)=1
28452 IF(uha.LT.ckin(37)) mint(51)=1
28453 IF(ckin(38).GE.0d0.AND.uha.GT.ckin(38)) mint(51)=1
28454 ENDIF
28455 IF(istsb.GE.3.AND.istsb.LE.5) THEN
28456 IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1
28457 IF(ckin(32).GE.0d0.AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1
28458 ENDIF
28459
28460C...Additional cuts on W2 (approximately) in DIS.
28461 IF(isub.EQ.10.AND.mint(43).GE.2) THEN
28462 xbj=x2
28463 IF(iabs(mint(12)).LT.20) xbj=x1
28464 q2bj=tha
28465 w2bj=q2bj*(1d0-xbj)/xbj
28466 IF(w2bj.LT.ckin(39)) mint(51)=1
28467 IF(ckin(40).GT.0d0.AND.w2bj.GT.ckin(40)) mint(51)=1
28468 ENDIF
28469
28470 ELSEIF(ilim.EQ.1) THEN
28471C...Calculate limits on tau
28472C...0) due to definition
28473 taumn0=0d0
28474 taumx0=1d0
28475C...1) due to limits on subsystem mass
28476 taumn1=ckin(1)**2/vint(2)
28477 taumx1=1d0
28478 IF(ckin(2).GE.0d0) taumx1=ckin(2)**2/vint(2)
28479C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28480 tm3=sqrt(sqm3+pthmin**2)
28481 tm4=sqrt(sqm4+pthmin**2)
28482 ydcosh=1d0
28483 IF(ckin09.GT.ckin12) ydcosh=cosh(ckin09-ckin12)
28484 taumn2=(tm3**2+2d0*tm3*tm4*ydcosh+tm4**2)/vint(2)
28485 taumx2=1d0
28486C...3) due to limits on pT-hat and cos(theta-hat)
28487 cth2mn=min(ckin(27)**2,ckin(28)**2)
28488 cth2mx=max(ckin(27)**2,ckin(28)**2)
28489 taumn3=0d0
28490 IF(ckin(27)*ckin(28).GT.0d0) taumn3=
28491 & (sqrt(sqm3+pthmin**2/(1d0-cth2mn))+
28492 & sqrt(sqm4+pthmin**2/(1d0-cth2mn)))**2/vint(2)
28493 taumx3=1d0
28494 IF(ckin(4).GE.0d0.AND.cth2mx.LT.1d0) taumx3=
28495 & (sqrt(sqm3+ckin(4)**2/(1d0-cth2mx))+
28496 & sqrt(sqm4+ckin(4)**2/(1d0-cth2mx)))**2/vint(2)
28497C...4) due to limits on x1 and x2
28498 taumn4=ckin(21)*ckin(23)
28499 taumx4=ckin(22)*ckin(24)
28500C...5) due to limits on xF
28501 taumn5=0d0
28502 taumx5=max(1d0-ckin(25),1d0+ckin(26))
28503C...6) due to limits on that and uhat
28504 taumn6=(sqm3+sqm4+ckin(35)+ckin(37))/vint(2)
28505 taumx6=1d0
28506 IF(ckin(36).GT.0d0.AND.ckin(38).GT.0d0) taumx6=
28507 & (sqm3+sqm4+ckin(36)+ckin(38))/vint(2)
28508
28509C...Net effect of all separate limits.
28510 vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5,taumn6)
28511 vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5,taumx6)
28512 IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
28513 vint(11)=1d0-1d-9
28514 vint(31)=1d0+1d-9
28515 ELSEIF(mint(47).EQ.5) THEN
28516 vint(31)=min(vint(31),1d0-2d-10)
28517 ELSEIF(mint(47).GE.6) THEN
28518 vint(31)=min(vint(31),1d0-1d-10)
28519 ENDIF
28520 IF(vint(31).LE.vint(11)) mint(51)=1
28521
28522 ELSEIF(ilim.EQ.2) THEN
28523C...Calculate limits on y*
28524 taue=tau
28525 IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
28526 taurt=sqrt(taue)
28527C...0) due to kinematics
28528 ystmn0=log(taurt)
28529 ystmx0=-ystmn0
28530C...1) due to explicit limits
28531 ystmn1=ckin(7)
28532 ystmx1=ckin(8)
28533C...2) due to limits on x1
28534 ystmn2=log(max(taue,ckin(21))/taurt)
28535 ystmx2=log(max(taue,ckin(22))/taurt)
28536C...3) due to limits on x2
28537 ystmn3=-log(max(taue,ckin(24))/taurt)
28538 ystmx3=-log(max(taue,ckin(23))/taurt)
28539C...4) due to limits on xF
28540 yepmn4=0.5d0*abs(ckin(25))/taurt
28541 ystmn4=sign(log(max(1d-20,sqrt(1d0+yepmn4**2)+yepmn4)),ckin(25))
28542 yepmx4=0.5d0*abs(ckin(26))/taurt
28543 ystmx4=sign(log(max(1d-20,sqrt(1d0+yepmx4**2)+yepmx4)),ckin(26))
28544C...5) due to simultaneous limits on y-large and y-small
28545 yepsmn=(rm3-rm4)*sinh(ckin09-ckin11)
28546 yepsmx=(rm3-rm4)*sinh(ckin10-ckin12)
28547 ydifmn=abs(log(max(1d-20,sqrt(1d0+yepsmn**2)-yepsmn)))
28548 ydifmx=abs(log(max(1d-20,sqrt(1d0+yepsmx**2)-yepsmx)))
28549 ystmn5=0.5d0*(ckin09+ckin11-ydifmn)
28550 ystmx5=0.5d0*(ckin10+ckin12+ydifmx)
28551C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28552C... y-small
28553 cthlim=sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*taue*vint(2))))
28554 rzmn=be34*max(ckin(27),-cthlim)
28555 rzmx=be34*min(ckin(28),cthlim)
28556 yex3mx=(1d0+rm3-rm4+rzmx)/max(1d-10,1d0+rm3-rm4-rzmx)
28557 yex4mx=(1d0+rm4-rm3-rzmn)/max(1d-10,1d0+rm4-rm3+rzmn)
28558 yex3mn=max(1d-10,1d0+rm3-rm4+rzmn)/(1d0+rm3-rm4-rzmn)
28559 yex4mn=max(1d-10,1d0+rm4-rm3-rzmx)/(1d0+rm4-rm3+rzmx)
28560 ystmn6=ckin09-0.5d0*log(max(yex3mx,yex4mx))
28561 ystmx6=ckin12-0.5d0*log(min(yex3mn,yex4mn))
28562
28563C...Net effect of all separate limits.
28564 vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)
28565 vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)
28566 IF(mint(47).EQ.1) THEN
28567 vint(12)=-1d-9
28568 vint(32)=1d-9
28569 ELSEIF(mint(47).EQ.2.OR.mint(47).EQ.6) THEN
28570 vint(12)=(1d0-1d-9)*ystmx0
28571 vint(32)=(1d0+1d-9)*ystmx0
28572 ELSEIF(mint(47).EQ.3.OR.mint(47).EQ.7) THEN
28573 vint(12)=-(1d0+1d-9)*ystmx0
28574 vint(32)=-(1d0-1d-9)*ystmx0
28575 ELSEIF(mint(47).EQ.5) THEN
28576 ystee=log((1d0-1d-10)/taurt)
28577 vint(12)=max(vint(12),-ystee)
28578 vint(32)=min(vint(32),ystee)
28579 ENDIF
28580 IF(vint(32).LE.vint(12)) mint(51)=1
28581
28582 ELSEIF(ilim.EQ.3) THEN
28583C...Calculate limits on cos(theta-hat)
28584 yst=vint(22)
28585C...0) due to definition
28586 ctnmn0=-1d0
28587 ctnmx0=0d0
28588 ctpmn0=0d0
28589 ctpmx0=1d0
28590C...1) due to explicit limits
28591 ctnmn1=min(0d0,ckin(27))
28592 ctnmx1=min(0d0,ckin(28))
28593 ctpmn1=max(0d0,ckin(27))
28594 ctpmx1=max(0d0,ckin(28))
28595C...2) due to limits on pT-hat
28596 ctnmn2=-sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*tau*vint(2))))
28597 ctpmx2=-ctnmn2
28598 ctnmx2=0d0
28599 ctpmn2=0d0
28600 IF(ckin(4).GE.0d0) THEN
28601 ctnmx2=-sqrt(max(0d0,1d0-4d0*ckin(4)**2/
28602 & (be34**2*tau*vint(2))))
28603 ctpmn2=-ctnmx2
28604 ENDIF
28605C...3) due to limits on y-large and y-small
28606 ctnmn3=min(0d0,max((1d0+rm3-rm4)/be34*tanh(ckin11-yst),
28607 & -(1d0-rm3+rm4)/be34*tanh(ckin10-yst)))
28608 ctnmx3=min(0d0,(1d0+rm3-rm4)/be34*tanh(ckin12-yst),
28609 & -(1d0-rm3+rm4)/be34*tanh(ckin09-yst))
28610 ctpmn3=max(0d0,(1d0+rm3-rm4)/be34*tanh(ckin09-yst),
28611 & -(1d0-rm3+rm4)/be34*tanh(ckin12-yst))
28612 ctpmx3=max(0d0,min((1d0+rm3-rm4)/be34*tanh(ckin10-yst),
28613 & -(1d0-rm3+rm4)/be34*tanh(ckin11-yst)))
28614C...4) due to limits on that
28615 ctnmn4=-1d0
28616 ctnmx4=0d0
28617 ctpmn4=0d0
28618 ctpmx4=1d0
28619 sh=tau*vint(2)
28620 IF(ckin(35).GT.0d0) THEN
28621 ctlim=(1d0-rm3-rm4-2d0*ckin(35)/sh)/be34
28622 IF(ctlim.GT.0d0) THEN
28623 ctpmx4=ctlim
28624 ELSE
28625 ctpmx4=0d0
28626 ctnmx4=ctlim
28627 ENDIF
28628 ENDIF
28629 IF(ckin(36).GT.0d0) THEN
28630 ctlim=(1d0-rm3-rm4-2d0*ckin(36)/sh)/be34
28631 IF(ctlim.LT.0d0) THEN
28632 ctnmn4=ctlim
28633 ELSE
28634 ctnmn4=0d0
28635 ctpmn4=ctlim
28636 ENDIF
28637 ENDIF
28638C...5) due to limits on uhat
28639 ctnmn5=-1d0
28640 ctnmx5=0d0
28641 ctpmn5=0d0
28642 ctpmx5=1d0
28643 IF(ckin(37).GT.0d0) THEN
28644 ctlim=(2d0*ckin(37)/sh-(1d0-rm3-rm4))/be34
28645 IF(ctlim.LT.0d0) THEN
28646 ctnmn5=ctlim
28647 ELSE
28648 ctnmn5=0d0
28649 ctpmn5=ctlim
28650 ENDIF
28651 ENDIF
28652 IF(ckin(38).GT.0d0) THEN
28653 ctlim=(2d0*ckin(38)/sh-(1d0-rm3-rm4))/be34
28654 IF(ctlim.GT.0d0) THEN
28655 ctpmx5=ctlim
28656 ELSE
28657 ctpmx5=0d0
28658 ctnmx5=ctlim
28659 ENDIF
28660 ENDIF
28661
28662C...Net effect of all separate limits.
28663 vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3,ctnmn4,ctnmn5)
28664 vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3,ctnmx4,ctnmx5)
28665 vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3,ctpmn4,ctpmn5)
28666 vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3,ctpmx4,ctpmx5)
28667 IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1
28668
28669 IF(vint(14).GT.vint(34)) vint(34)=vint(14)
28670 IF(vint(13).GT.vint(33)) vint(33)=vint(13)
28671
28672 ELSEIF(ilim.EQ.4) THEN
28673C...Calculate limits on tau'
28674C...0) due to kinematics
28675 tapmn0=tau
28676 IF(istsb.EQ.5.AND.vint(201).GT.0d0) THEN
28677 pqrat=(vint(201)+vint(206))/vint(1)
28678 tapmn0=(sqrt(tau)+pqrat)**2
28679 ENDIF
28680 tapmx0=1d0
28681C...1) due to explicit limits
28682 tapmn1=ckin(31)**2/vint(2)
28683 tapmx1=1d0
28684 IF(ckin(32).GE.0d0) tapmx1=ckin(32)**2/vint(2)
28685
28686C...Net effect of all separate limits.
28687 vint(16)=max(tapmn0,tapmn1)
28688 vint(36)=min(tapmx0,tapmx1)
28689 IF(mint(47).EQ.1) THEN
28690 vint(16)=1d0-1d-9
28691 vint(36)=1d0+1d-9
28692 ELSEIF(mint(47).EQ.5) THEN
28693 vint(36)=min(vint(36),1d0-2d-10)
28694 ELSEIF(mint(47).EQ.6.OR.mint(47).EQ.7) THEN
28695 vint(36)=min(vint(36),1d0-1d-10)
28696 ENDIF
28697 IF(vint(36).LE.vint(16)) mint(51)=1
28698
28699 ENDIF
28700 RETURN
28701
28702C...Special case for low-pT and multiple interactions:
28703C...effective kinematical limits for tau, y*, cos(theta-hat).
28704 100 IF(ilim.EQ.0) THEN
28705 ELSEIF(ilim.EQ.1) THEN
28706 IF(mstp(82).LE.1) THEN
28707 vint(11)=4d0*(parp(81)*(vint(1)/parp(89))**parp(90))**2/
28708 & vint(2)
28709 ELSE
28710 vint(11)=(parp(82)*(vint(1)/parp(89))**parp(90))**2/vint(2)
28711 ENDIF
28712 vint(31)=1d0
28713 ELSEIF(ilim.EQ.2) THEN
28714 vint(12)=0.5d0*log(vint(21))
28715 vint(32)=-vint(12)
28716 ELSEIF(ilim.EQ.3) THEN
28717 IF(mstp(82).LE.1) THEN
28718 st2eff=4d0*(parp(81)*(vint(1)/parp(89))**parp(90))**2/
28719 & (vint(21)*vint(2))
28720 ELSE
28721 st2eff=0.01d0*(parp(82)*(vint(1)/parp(89))**parp(90))**2/
28722 & (vint(21)*vint(2))
28723 ENDIF
28724 vint(13)=-sqrt(max(0d0,1d0-st2eff))
28725 vint(33)=0d0
28726 vint(14)=0d0
28727 vint(34)=-vint(13)
28728 ENDIF
28729
28730 RETURN
28731 END
28732
28733C*********************************************************************
28734
28735C...PYKMAP
28736C...Maps a uniform distribution into a distribution of a kinematical
28737C...variable according to one of the possibilities allowed. It is
28738C...assumed that kinematical limits have been set by a PYKLIM call.
28739
28740 SUBROUTINE pykmap(IVAR,MVAR,VVAR)
28741
28742C...Double precision and integer declarations.
28743 IMPLICIT DOUBLE PRECISION(a-h, o-z)
28744 IMPLICIT INTEGER(I-N)
28745 INTEGER PYK,PYCHGE,PYCOMP
28746C...Commonblocks.
28747 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
28748 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
28749 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
28750 common/pypars/mstp(200),parp(200),msti(200),pari(200)
28751 common/pyint1/mint(400),vint(400)
28752 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
28753 SAVE /pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,/pyint2/
28754
28755C...Convert VVAR to tau variable.
28756 isub=mint(1)
28757 istsb=iset(isub)
28758 IF(ivar.EQ.1) THEN
28759 taumin=vint(11)
28760 taumax=vint(31)
28761 IF(mvar.EQ.3.OR.mvar.EQ.4) THEN
28762 taure=vint(73)
28763 gamre=vint(74)
28764 ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN
28765 taure=vint(75)
28766 gamre=vint(76)
28767 ELSEIF(mvar.EQ.8.OR.mvar.EQ.9) THEN
28768 taure=vint(77)
28769 gamre=vint(78)
28770 ENDIF
28771 IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN
28772 tau=1d0
28773 ELSEIF(mvar.EQ.1) THEN
28774 tau=taumin*(taumax/taumin)**vvar
28775 ELSEIF(mvar.EQ.2) THEN
28776 tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)
28777 ELSEIF(mvar.EQ.3.OR.mvar.EQ.5.OR.mvar.EQ.8) THEN
28778 ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax
28779 tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin)
28780 ELSEIF(mvar.EQ.4.OR.mvar.EQ.6.OR.mvar.EQ.9) THEN
28781 aupp=atan((taumax-taure)/gamre)
28782 alow=atan((taumin-taure)/gamre)
28783 tau=taure+gamre*tan(alow+(aupp-alow)*vvar)
28784 ELSEIF(mint(47).EQ.5) THEN
28785 aupp=log(max(2d-10,1d0-taumax))
28786 alow=log(max(2d-10,1d0-taumin))
28787 tau=1d0-exp(aupp+vvar*(alow-aupp))
28788 ELSE
28789 aupp=log(max(1d-10,1d0-taumax))
28790 alow=log(max(1d-10,1d0-taumin))
28791 tau=1d0-exp(aupp+vvar*(alow-aupp))
28792 ENDIF
28793 vint(21)=min(taumax,max(taumin,tau))
28794
28795C...Convert VVAR to y* variable.
28796 ELSEIF(ivar.EQ.2) THEN
28797 ystmin=vint(12)
28798 ystmax=vint(32)
28799 taue=vint(21)
28800 IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)
28801 IF(mint(47).EQ.1) THEN
28802 yst=0d0
28803 ELSEIF(mint(47).EQ.2.OR.mint(47).EQ.6) THEN
28804 yst=-0.5d0*log(taue)
28805 ELSEIF(mint(47).EQ.3.OR.mint(47).EQ.7) THEN
28806 yst=0.5d0*log(taue)
28807 ELSEIF(mvar.EQ.1) THEN
28808 yst=ystmin+(ystmax-ystmin)*sqrt(vvar)
28809 ELSEIF(mvar.EQ.2) THEN
28810 yst=ystmax-(ystmax-ystmin)*sqrt(1d0-vvar)
28811 ELSEIF(mvar.EQ.3) THEN
28812 aupp=atan(exp(ystmax))
28813 alow=atan(exp(ystmin))
28814 yst=log(tan(alow+(aupp-alow)*vvar))
28815 ELSEIF(mvar.EQ.4) THEN
28816 yst0=-0.5d0*log(taue)
28817 aupp=log(max(1d-10,exp(yst0-ystmin)-1d0))
28818 alow=log(max(1d-10,exp(yst0-ystmax)-1d0))
28819 yst=yst0-log(1d0+exp(alow+vvar*(aupp-alow)))
28820 ELSE
28821 yst0=-0.5d0*log(taue)
28822 aupp=log(max(1d-10,exp(yst0+ystmin)-1d0))
28823 alow=log(max(1d-10,exp(yst0+ystmax)-1d0))
28824 yst=log(1d0+exp(aupp+vvar*(alow-aupp)))-yst0
28825 ENDIF
28826 vint(22)=min(ystmax,max(ystmin,yst))
28827
28828C...Convert VVAR to cos(theta-hat) variable.
28829 ELSEIF(ivar.EQ.3) THEN
28830 rm34=max(1d-20,2d0*vint(63)*vint(64)/(vint(21)*vint(2))**2)
28831 rsqm=1d0+rm34
28832 IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)
28833 & rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))
28834 ctnmin=vint(13)
28835 ctnmax=vint(33)
28836 ctpmin=vint(14)
28837 ctpmax=vint(34)
28838 IF(mvar.EQ.1) THEN
28839 aneg=ctnmax-ctnmin
28840 apos=ctpmax-ctpmin
28841 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28842 vctn=vvar*(aneg+apos)/aneg
28843 cth=ctnmin+(ctnmax-ctnmin)*vctn
28844 ELSE
28845 vctp=(vvar*(aneg+apos)-aneg)/apos
28846 cth=ctpmin+(ctpmax-ctpmin)*vctp
28847 ENDIF
28848 ELSEIF(mvar.EQ.2) THEN
28849 rmnmin=max(rm34,rsqm-ctnmin)
28850 rmnmax=max(rm34,rsqm-ctnmax)
28851 rmpmin=max(rm34,rsqm-ctpmin)
28852 rmpmax=max(rm34,rsqm-ctpmax)
28853 aneg=log(rmnmin/rmnmax)
28854 apos=log(rmpmin/rmpmax)
28855 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28856 vctn=vvar*(aneg+apos)/aneg
28857 cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn
28858 ELSE
28859 vctp=(vvar*(aneg+apos)-aneg)/apos
28860 cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp
28861 ENDIF
28862 ELSEIF(mvar.EQ.3) THEN
28863 rmnmin=max(rm34,rsqm+ctnmin)
28864 rmnmax=max(rm34,rsqm+ctnmax)
28865 rmpmin=max(rm34,rsqm+ctpmin)
28866 rmpmax=max(rm34,rsqm+ctpmax)
28867 aneg=log(rmnmax/rmnmin)
28868 apos=log(rmpmax/rmpmin)
28869 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28870 vctn=vvar*(aneg+apos)/aneg
28871 cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm
28872 ELSE
28873 vctp=(vvar*(aneg+apos)-aneg)/apos
28874 cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm
28875 ENDIF
28876 ELSEIF(mvar.EQ.4) THEN
28877 rmnmin=max(rm34,rsqm-ctnmin)
28878 rmnmax=max(rm34,rsqm-ctnmax)
28879 rmpmin=max(rm34,rsqm-ctpmin)
28880 rmpmax=max(rm34,rsqm-ctpmax)
28881 aneg=1d0/rmnmax-1d0/rmnmin
28882 apos=1d0/rmpmax-1d0/rmpmin
28883 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28884 vctn=vvar*(aneg+apos)/aneg
28885 cth=rsqm-1d0/(1d0/rmnmin+aneg*vctn)
28886 ELSE
28887 vctp=(vvar*(aneg+apos)-aneg)/apos
28888 cth=rsqm-1d0/(1d0/rmpmin+apos*vctp)
28889 ENDIF
28890 ELSEIF(mvar.EQ.5) THEN
28891 rmnmin=max(rm34,rsqm+ctnmin)
28892 rmnmax=max(rm34,rsqm+ctnmax)
28893 rmpmin=max(rm34,rsqm+ctpmin)
28894 rmpmax=max(rm34,rsqm+ctpmax)
28895 aneg=1d0/rmnmin-1d0/rmnmax
28896 apos=1d0/rmpmin-1d0/rmpmax
28897 IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN
28898 vctn=vvar*(aneg+apos)/aneg
28899 cth=1d0/(1d0/rmnmin-aneg*vctn)-rsqm
28900 ELSE
28901 vctp=(vvar*(aneg+apos)-aneg)/apos
28902 cth=1d0/(1d0/rmpmin-apos*vctp)-rsqm
28903 ENDIF
28904 ENDIF
28905 IF(cth.LT.0d0) cth=min(ctnmax,max(ctnmin,cth))
28906 IF(cth.GT.0d0) cth=min(ctpmax,max(ctpmin,cth))
28907 vint(23)=cth
28908
28909C...Convert VVAR to tau' variable.
28910 ELSEIF(ivar.EQ.4) THEN
28911 tau=vint(21)
28912 taupmn=vint(16)
28913 taupmx=vint(36)
28914 IF(mint(47).EQ.1) THEN
28915 taup=1d0
28916 ELSEIF(mvar.EQ.1) THEN
28917 taup=taupmn*(taupmx/taupmn)**vvar
28918 ELSEIF(mvar.EQ.2) THEN
28919 aupp=(1d0-tau/taupmx)**4
28920 alow=(1d0-tau/taupmn)**4
28921 taup=tau/max(1d-10,1d0-(alow+(aupp-alow)*vvar)**0.25d0)
28922 ELSEIF(mint(47).EQ.5) THEN
28923 aupp=log(max(2d-10,1d0-taupmx))
28924 alow=log(max(2d-10,1d0-taupmn))
28925 taup=1d0-exp(aupp+vvar*(alow-aupp))
28926 ELSE
28927 aupp=log(max(1d-10,1d0-taupmx))
28928 alow=log(max(1d-10,1d0-taupmn))
28929 taup=1d0-exp(aupp+vvar*(alow-aupp))
28930 ENDIF
28931 vint(26)=min(taupmx,max(taupmn,taup))
28932
28933C...Selection of extra variables needed in 2 -> 3 process:
28934C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
28935C...Since no options are available, the functions of PYKLIM
28936C...and PYKMAP are joint for these choices.
28937 ELSEIF(ivar.EQ.5) THEN
28938
28939C...Read out total energy and particle masses.
28940 mint(51)=0
28941 mptpk=1
28942 IF(isub.EQ.123.OR.isub.EQ.124.OR.isub.EQ.173.OR.isub.EQ.174
28943 & .OR.isub.EQ.178.OR.isub.EQ.179.OR.isub.EQ.351.OR.isub.EQ.352)
28944 & mptpk=2
28945 shp=vint(26)*vint(2)
28946 shpr=sqrt(shp)
28947 pm1=vint(201)
28948 pm2=vint(206)
28949 pm3=sqrt(vint(21))*vint(1)
28950 IF(pm1+pm2+pm3.GT.0.9999d0*shpr) THEN
28951 mint(51)=1
28952 RETURN
28953 ENDIF
28954 pmrs1=vint(204)**2
28955 pmrs2=vint(209)**2
28956
28957C...Specify coefficients of pT choice; upper and lower limits.
28958 IF(mptpk.EQ.1) THEN
28959 hwt1=0.4d0
28960 hwt2=0.4d0
28961 ELSE
28962 hwt1=0.05d0
28963 hwt2=0.05d0
28964 ENDIF
28965 hwt3=1d0-hwt1-hwt2
28966 ptsmx1=((shp-pm1**2-(pm2+pm3)**2)**2-(2d0*pm1*(pm2+pm3))**2)/
28967 & (4d0*shp)
28968 IF(ckin(52).GT.0d0) ptsmx1=min(ptsmx1,ckin(52)**2)
28969 ptsmn1=ckin(51)**2
28970 ptsmx2=((shp-pm2**2-(pm1+pm3)**2)**2-(2d0*pm2*(pm1+pm3))**2)/
28971 & (4d0*shp)
28972 IF(ckin(54).GT.0d0) ptsmx2=min(ptsmx2,ckin(54)**2)
28973 ptsmn2=ckin(53)**2
28974
28975C...Select transverse momenta according to
28976C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
28977 hmx=pmrs1+ptsmx1
28978 hmn=pmrs1+ptsmn1
28979 IF(hmx.LT.1.0001d0*hmn) THEN
28980 mint(51)=1
28981 RETURN
28982 ENDIF
28983 hde=ptsmx1-ptsmn1
28984 rpt=pyr(0)
28985 IF(rpt.LT.hwt1) THEN
28986 pts1=ptsmn1+pyr(0)*hde
28987 ELSEIF(rpt.LT.hwt1+hwt2) THEN
28988 pts1=max(ptsmn1,hmn*(hmx/hmn)**pyr(0)-pmrs1)
28989 ELSE
28990 pts1=max(ptsmn1,hmn*hmx/(hmn+pyr(0)*hde)-pmrs1)
28991 ENDIF
28992 wtpts1=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs1+pts1))+
28993 & hwt3*hmn*hmx/(pmrs1+pts1)**2)
28994 hmx=pmrs2+ptsmx2
28995 hmn=pmrs2+ptsmn2
28996 IF(hmx.LT.1.0001d0*hmn) THEN
28997 mint(51)=1
28998 RETURN
28999 ENDIF
29000 hde=ptsmx2-ptsmn2
29001 rpt=pyr(0)
29002 IF(rpt.LT.hwt1) THEN
29003 pts2=ptsmn2+pyr(0)*hde
29004 ELSEIF(rpt.LT.hwt1+hwt2) THEN
29005 pts2=max(ptsmn2,hmn*(hmx/hmn)**pyr(0)-pmrs2)
29006 ELSE
29007 pts2=max(ptsmn2,hmn*hmx/(hmn+pyr(0)*hde)-pmrs2)
29008 ENDIF
29009 wtpts2=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs2+pts2))+
29010 & hwt3*hmn*hmx/(pmrs2+pts2)**2)
29011
29012C...Select azimuthal angles and check pT choice.
29013 phi1=paru(2)*pyr(0)
29014 phi2=paru(2)*pyr(0)
29015 phir=phi2-phi1
29016 pts3=max(0d0,pts1+pts2+2d0*sqrt(pts1*pts2)*cos(phir))
29017 IF(pts3.LT.ckin(55)**2.OR.(ckin(56).GT.0d0.AND.pts3.GT.
29018 & ckin(56)**2)) THEN
29019 mint(51)=1
29020 RETURN
29021 ENDIF
29022
29023C...Calculate transverse masses and check phase space not closed.
29024 pms1=pm1**2+pts1
29025 pms2=pm2**2+pts2
29026 pms3=pm3**2+pts3
29027 pmt1=sqrt(pms1)
29028 pmt2=sqrt(pms2)
29029 pmt3=sqrt(pms3)
29030 pm12=(pmt1+pmt2)**2
29031 IF(pmt1+pmt2+pmt3.GT.0.9999d0*shpr) THEN
29032 mint(51)=1
29033 RETURN
29034 ENDIF
29035
29036C...Select rapidity for particle 3 and check phase space not closed.
29037 y3max=log((shp+pms3-pm12+sqrt(max(0d0,(shp-pms3-pm12)**2-
29038 & 4d0*pms3*pm12)))/(2d0*shpr*pmt3))
29039 IF(y3max.LT.1d-6) THEN
29040 mint(51)=1
29041 RETURN
29042 ENDIF
29043 y3=(2d0*pyr(0)-1d0)*0.999999d0*y3max
29044 pz3=pmt3*sinh(y3)
29045 pe3=pmt3*cosh(y3)
29046
29047C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29048 pz12=-pz3
29049 pe12=shpr-pe3
29050 pms12=pe12**2-pz12**2
29051 sql12=sqrt(max(0d0,(pms12-pms1-pms2)**2-4d0*pms1*pms2))
29052 IF(sql12.LT.1d-6*shp) THEN
29053 mint(51)=1
29054 RETURN
29055 ENDIF
29056 pmm1=pms12+pms1-pms2
29057 pmm2=pms12+pms2-pms1
29058 tfac=-shpr/(2d0*pms12)
29059 t1p=tfac*(pe12-pz12)*(pmm1-sql12)
29060 t1n=tfac*(pe12-pz12)*(pmm1+sql12)
29061 t2p=tfac*(pe12+pz12)*(pmm2-sql12)
29062 t2n=tfac*(pe12+pz12)*(pmm2+sql12)
29063
29064C...Construct relative mirror weights and make choice.
29065 IF(mptpk.EQ.1.OR.isub.EQ.351.OR.isub.EQ.352) THEN
29066 wtpu=1d0
29067 wtnu=1d0
29068 ELSE
29069 wtpu=1d0/((t1p-pmrs1)*(t2p-pmrs2))**2
29070 wtnu=1d0/((t1n-pmrs1)*(t2n-pmrs2))**2
29071 ENDIF
29072 wtp=wtpu/(wtpu+wtnu)
29073 wtn=wtnu/(wtpu+wtnu)
29074 eps=1d0
29075 IF(wtn.GT.pyr(0)) eps=-1d0
29076
29077C...Store result of variable choice and associated weights.
29078 vint(202)=pts1
29079 vint(207)=pts2
29080 vint(203)=phi1
29081 vint(208)=phi2
29082 vint(205)=wtpts1
29083 vint(210)=wtpts2
29084 vint(211)=y3
29085 vint(212)=y3max
29086 vint(213)=eps
29087 IF(eps.GT.0d0) THEN
29088 vint(214)=1d0/wtp
29089 vint(215)=t1p
29090 vint(216)=t2p
29091 ELSE
29092 vint(214)=1d0/wtn
29093 vint(215)=t1n
29094 vint(216)=t2n
29095 ENDIF
29096 vint(217)=-0.5d0*tfac*(pe12-pz12)*(pmm2+eps*sql12)
29097 vint(218)=-0.5d0*tfac*(pe12+pz12)*(pmm1+eps*sql12)
29098 vint(219)=0.5d0*(pms12-pts3)
29099 vint(220)=sql12
29100 ENDIF
29101
29102 RETURN
29103 END
29104
29105C***********************************************************************
29106
29107C...PYSIGH
29108C...Differential matrix elements for all included subprocesses
29109C...Note that what is coded is (disregarding the COMFAC factor)
29110C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29111C...when d(sigma-hat) is given in the zero-width limit, the delta
29112C...function in tau is replaced by a (modified) Breit-Wigner:
29113C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29114C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29115C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29116C...i.e., dimensionless quantities
29117C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29118C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29119C...(2pi)^4 delta^4(P - sum p_i)
29120C...COMFAC contains the factor pi/s (or equivalent) and
29121C...the conversion factor from GeV^-2 to mb
29122
29123 SUBROUTINE pysigh(NCHN,SIGS)
29124
29125C...Double precision and integer declarations
29126 IMPLICIT DOUBLE PRECISION(a-h, o-z)
29127 IMPLICIT INTEGER(I-N)
29128 INTEGER PYK,PYCHGE,PYCOMP
29129C...Parameter statement to help give large particle numbers.
29130 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
29131 &kexcit=4000000,kdimen=5000000)
29132C...Commonblocks
29133 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
29134 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29135 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29136 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
29137 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
29138 common/pypars/mstp(200),parp(200),msti(200),pari(200)
29139 common/pyint1/mint(400),vint(400)
29140 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
29141 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
29142 common/pyint4/mwid(500),wids(500,5)
29143 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
29144 common/pyint7/sigt(0:6,0:6,0:5)
29145 common/pymssm/imss(0:99),rmss(0:99)
29146 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
29147 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
29148 common/pytcsm/itcm(0:99),rtcm(0:99)
29149 common/pypued/iued(0:99),rued(0:99)
29150 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
29151 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
29152 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
29153 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
29154 common/pytcco/coefx(194:380,2)
29155 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,
29156 &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,
29157 &/pymssm/,/pyssmt/,/pytcsm/,/pypued/,/pysgcm/,/pytcco/
29158C...Local arrays and complex variables
29159 dimension xpq(-25:25)
29160
29161C...Map of processes onto which routine to call
29162C...in order to evaluate cross section:
29163C...0 = not implemented;
29164C...1 = standard QCD (including photons);
29165C...2 = heavy flavours;
29166C...3 = W/Z;
29167C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29168C...5 = SUSY;
29169C...6 = Technicolor;
29170C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29171C...8 = Universal Extra Dimensions
29172 dimension mappr(500)
29173 DATA (mappr(i),i=1,180)/
29174 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29175 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29176 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29177 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29178 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29179 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29180 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29181 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29182 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29183 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29184 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29185 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29186 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29187 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29188 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29189 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29190 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29191 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29192 DATA (mappr(i),i=181,500)/
29193 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29194 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29195 & 100*5,
29196 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29197 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29198 1 20*0,
29199 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29200 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29201 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29202 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29203 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29204 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29205 & 4, 4, 18*0,
29206 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29207 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29208 4 20*0,
29209 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29210 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29211 8 20*0/
29212
29213C...Reset number of channels and cross-section
29214 nchn=0
29215 sigs=0d0
29216
29217C...Read process to consider.
29218 isub=mint(1)
29219 isubsv=isub
29220 map=mappr(isub)
29221
29222C...Read kinematical variables and limits
29223 istsb=iset(isubsv)
29224 taumin=vint(11)
29225 ystmin=vint(12)
29226 ctnmin=vint(13)
29227 ctpmin=vint(14)
29228 taupmn=vint(16)
29229 tau=vint(21)
29230 yst=vint(22)
29231 cth=vint(23)
29232 xt2=vint(25)
29233 taup=vint(26)
29234 taumax=vint(31)
29235 ystmax=vint(32)
29236 ctnmax=vint(33)
29237 ctpmax=vint(34)
29238 taupmx=vint(36)
29239
29240C...Derive kinematical quantities
29241 taue=tau
29242 IF(istsb.GE.3.AND.istsb.LE.5) taue=taup
29243 x(1)=sqrt(taue)*exp(yst)
29244 x(2)=sqrt(taue)*exp(-yst)
29245 IF(mint(45).EQ.2.AND.istsb.GE.1) THEN
29246 IF(x(1).GT.1d0-1d-7) RETURN
29247 ELSEIF(mint(45).EQ.3) THEN
29248 x(1)=min(1d0-1.1d-10,x(1))
29249 ENDIF
29250 IF(mint(46).EQ.2.AND.istsb.GE.1) THEN
29251 IF(x(2).GT.1d0-1d-7) RETURN
29252 ELSEIF(mint(46).EQ.3) THEN
29253 x(2)=min(1d0-1.1d-10,x(2))
29254 ENDIF
29255 sh=max(1d0,tau*vint(2))
29256 sqm3=vint(63)
29257 sqm4=vint(64)
29258 rm3=sqm3/sh
29259 rm4=sqm4/sh
29260 be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
29261 rpts=4d0*vint(71)**2/sh
29262 be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
29263 rm34=max(1d-20,2d0*rm3*rm4)
29264 rsqm=1d0+rm34
29265 IF(2d0*vint(71)**2/max(1d0,vint(21)*vint(2)).LT.0.0001d0)
29266 &rm34=max(rm34,2d0*vint(71)**2/max(1d0,vint(21)*vint(2)))
29267 rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
29268 IF(istsb.EQ.0) THEN
29269 th=vint(45)
29270 uh=-0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)
29271 sqpth=max(vint(71)**2,0.25d0*sh*be34**2*vint(59)**2)
29272 ELSE
29273C...Kinematics with incoming masses tricky: now depends on how
29274C...subprocess has been set up w.r.t. order of incoming partons.
29275 rm1=0d0
29276 IF(mint(15).EQ.22.AND.vint(3).LT.0d0) rm1=-vint(3)**2/sh
29277 rm2=0d0
29278 IF(mint(16).EQ.22.AND.vint(4).LT.0d0) rm2=-vint(4)**2/sh
29279 IF(isub.EQ.35) THEN
29280 rm2=min(rm1,rm2)
29281 rm1=0d0
29282 ENDIF
29283 be12=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
29284 tucom=(1d0-rm1-rm2)*(1d0-rm3-rm4)
29285 th=-0.5d0*sh*max(rthm,tucom-2d0*rm1*rm4-2d0*rm2*rm3-
29286 & be12*be34*cth)
29287 uh=-0.5d0*sh*max(rthm,tucom-2d0*rm1*rm3-2d0*rm2*rm4+
29288 & be12*be34*cth)
29289 sqpth=max(vint(71)**2,0.25d0*sh*be34**2*(1d0-cth**2))
29290 ENDIF
29291 shr=sqrt(sh)
29292 sh2=sh**2
29293 th2=th**2
29294 uh2=uh**2
29295
29296C...Choice of Q2 scale for hard process (e.g. alpha_s).
29297 IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN
29298 q2=sh
29299 ELSEIF(istsb.EQ.8) THEN
29300 IF(mint(107).EQ.4) q2=vint(307)
29301 IF(mint(108).EQ.4) q2=vint(308)
29302 ELSEIF(mod(istsb,2).EQ.0.OR.istsb.EQ.9) THEN
29303 q2in1=0d0
29304 IF(mint(11).EQ.22.AND.vint(3).LT.0d0) q2in1=vint(3)**2
29305 q2in2=0d0
29306 IF(mint(12).EQ.22.AND.vint(4).LT.0d0) q2in2=vint(4)**2
29307 IF(mstp(32).EQ.1) THEN
29308 q2=2d0*sh*th*uh/(sh**2+th**2+uh**2)
29309 ELSEIF(mstp(32).EQ.2) THEN
29310 q2=sqpth+0.5d0*(sqm3+sqm4)
29311 ELSEIF(mstp(32).EQ.3) THEN
29312 q2=min(-th,-uh)
29313 ELSEIF(mstp(32).EQ.4) THEN
29314 q2=sh
29315 ELSEIF(mstp(32).EQ.5) THEN
29316 q2=-th
29317 ELSEIF(mstp(32).EQ.6) THEN
29318 xsf1=x(1)
29319 IF(istsb.EQ.9) xsf1=x(1)/vint(143)
29320 xsf2=x(2)
29321 IF(istsb.EQ.9) xsf2=x(2)/vint(144)
29322 q2=(1d0+xsf1*q2in1/sh+xsf2*q2in2/sh)*
29323 & (sqpth+0.5d0*(sqm3+sqm4))
29324 ELSEIF(mstp(32).EQ.7) THEN
29325 q2=(1d0+q2in1/sh+q2in2/sh)*(sqpth+0.5d0*(sqm3+sqm4))
29326 ELSEIF(mstp(32).EQ.8) THEN
29327 q2=sqpth+0.5d0*(q2in1+q2in2+sqm3+sqm4)
29328 ELSEIF(mstp(32).EQ.9) THEN
29329 q2=sqpth+q2in1+q2in2+sqm3+sqm4
29330 ELSEIF(mstp(32).EQ.10) THEN
29331 q2=vint(2)
29332C..Begin JA 040914
29333 ELSEIF(mstp(32).EQ.11) THEN
29334 q2=0.25*(sqm3+sqm4+2*sqrt(sqm3*sqm4))
29335 ELSEIF(mstp(32).EQ.12) THEN
29336 q2=parp(193)
29337C..End JA
29338 ELSEIF(mstp(32).EQ.13) THEN
29339 q2=sqpth
29340 ENDIF
29341 IF(mint(35).LE.2.AND.istsb.EQ.9) q2=sqpth
29342 IF(istsb.EQ.9.AND.mstp(82).GE.2) q2=q2+
29343 & (parp(82)*(vint(1)/parp(89))**parp(90))**2
29344 ENDIF
29345
29346C...Choice of Q2 scale for parton densities.
29347 q2sf=q2
29348C..Begin JA 040914
29349 IF(mstp(32).EQ.12.AND.(mod(istsb,2).EQ.0.OR.istsb.EQ.9)
29350 & .OR.mstp(39).EQ.8.AND.(istsb.GE.3.AND.istsb.LE.5))
29351 & q2=parp(194)
29352C..End JA
29353 IF(istsb.GE.3.AND.istsb.LE.5) THEN
29354 q2sf=pmas(23,1)**2
29355 IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77.OR.isub.EQ.124.OR.
29356 & isub.EQ.174.OR.isub.EQ.179.OR.isub.EQ.351) q2sf=pmas(24,1)**2
29357 IF(isub.EQ.352) q2sf=pmas(pycomp(9900024),1)**2
29358 IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.
29359 & isub.EQ.186.OR.isub.EQ.187.OR.isub.EQ.401.OR.isub.EQ.402) THEN
29360 q2sf=pmas(pycomp(kfpr(isubsv,2)),1)**2
29361 IF(mstp(39).EQ.2) q2sf=
29362 & max(vint(201)**2+vint(202),vint(206)**2+vint(207))
29363 IF(mstp(39).EQ.3) q2sf=sh
29364 IF(mstp(39).EQ.4) q2sf=vint(26)*vint(2)
29365 IF(mstp(39).EQ.5) q2sf=pmas(pycomp(kfpr(isubsv,1)),1)**2
29366C..Begin JA 040914
29367 IF(mstp(39).EQ.6) q2sf=0.25*(vint(201)+sqrt(sh))**2
29368 IF(mstp(39).EQ.7) q2sf=
29369 & (vint(201)**2+vint(202)+vint(206)**2+vint(207))/2d0
29370 IF(mstp(39).EQ.8) q2sf=parp(193)
29371C..End JA
29372 ENDIF
29373 ENDIF
29374 IF(mint(35).GE.3.AND.istsb.EQ.9) q2sf=sqpth
29375
29376 q2ps=q2sf
29377 q2sf=q2sf*parp(34)
29378 IF(mstp(69).GE.1.AND.mint(47).EQ.5) q2sf=vint(2)
29379 IF(mstp(69).GE.2) q2sf=vint(2)
29380
29381C...Identify to which class(es) subprocess belongs
29382 ismecr=0
29383 isqcd=0
29384 isjets=0
29385 IF (isubsv.EQ.1.OR.isubsv.EQ.2.OR.isubsv.EQ.3.OR.
29386 & isubsv.EQ.102.OR.isubsv.EQ.141.OR.isubsv.EQ.142.OR.
29387 & isubsv.EQ.144.OR.isubsv.EQ.151.OR.isubsv.EQ.152.OR.
29388 & isubsv.EQ.156.OR.isubsv.EQ.157) ismecr=1
29389 IF (isubsv.EQ.11.OR.isubsv.EQ.12.OR.isubsv.EQ.13.OR.
29390 & isubsv.EQ.28.OR.isubsv.EQ.53.OR.isubsv.EQ.68) isqcd=1
29391 IF ((isubsv.EQ.81.OR.isubsv.EQ.82).AND.mint(55).LE.5) isqcd=1
29392 IF (isubsv.GE.381.AND.isubsv.LE.386) isqcd=1
29393 IF ((isubsv.EQ.387.OR.isubsv.EQ.388).AND.mint(55).LE.5) isqcd=1
29394 IF (istsb.EQ.9) isqcd=1
29395 IF ((isubsv.GE.86.AND.isubsv.LE.89).OR.isubsv.EQ.107.OR.
29396 & (isubsv.GE.14.AND.isubsv.LE.16).OR.(isubsv.GE.29.AND.
29397 & isubsv.LE.32).OR.(isubsv.GE.111.AND.isubsv.LE.113).OR.
29398 & isubsv.EQ.115.OR.(isubsv.GE.183.AND.isubsv.LE.185).OR.
29399 & (isubsv.GE.188.AND.isubsv.LE.190).OR.isubsv.EQ.161.OR.
29400 & isubsv.EQ.167.OR.isubsv.EQ.168.OR.(isubsv.GE.393.AND.
29401 & isubsv.LE.395).OR.(isubsv.GE.421.AND.isubsv.LE.439).OR.
29402 & (isubsv.GE.461.AND.isubsv.LE.479)) isjets=1
29403C...WBF is special case of ISJETS
29404 IF (isubsv.EQ.5.OR.isubsv.EQ.8.OR.
29405 & (isubsv.GE.71.AND.isubsv.LE.73).OR.
29406 & isubsv.EQ.76.OR.isubsv.EQ.77.OR.
29407 & (isubsv.GE.121.AND.isubsv.LE.124).OR.
29408 & isubsv.EQ.173.OR.isubsv.EQ.174.OR.
29409 & isubsv.EQ.178.OR.isubsv.EQ.179.OR.
29410 & isubsv.EQ.181.OR.isubsv.EQ.182.OR.
29411 & isubsv.EQ.186.OR.isubsv.EQ.187.OR.
29412 & isubsv.EQ.351.OR.isubsv.EQ.352) isjets=2
29413C...Some processes with photons also belong here.
29414 IF (isubsv.EQ.10.OR.(isubsv.GE.18.AND.isubsv.LE.20).OR.
29415 & (isubsv.GE.33.AND.isubsv.LE.36).OR.isubsv.EQ.54.OR.
29416 & isubsv.EQ.58.OR.isubsv.EQ.69.OR.isubsv.EQ.70.OR.
29417 & isubsv.EQ.80.OR.(isubsv.GE.83.AND.isubsv.LE.85).OR.
29418 & (isubsv.GE.106.AND.isubsv.LE.110).OR.isubsv.EQ.114.OR.
29419 & (isubsv.GE.131.AND.isubsv.LE.140)) isjets=3
29420
29421C...Choice of Q2 scale for parton-shower activity.
29422 IF(mstp(22).GE.1.AND.(isub.EQ.10.OR.isub.EQ.83).AND.
29423 &(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN
29424 xbj=x(2)
29425 IF(mint(43).EQ.3) xbj=x(1)
29426 IF(mstp(22).EQ.1) THEN
29427 q2ps=-th
29428 ELSEIF(mstp(22).EQ.2) THEN
29429 q2ps=((1d0-xbj)/xbj)*(-th)
29430 ELSEIF(mstp(22).EQ.3) THEN
29431 q2ps=sqrt((1d0-xbj)/xbj)*(-th)
29432 ELSE
29433 q2ps=(1d0-xbj)*max(1d0,-log(xbj))*(-th)
29434 ENDIF
29435 ENDIF
29436C...For multiple interactions, start from scale defined above
29437C...For all other QCD or "+jets"-type events, start shower from pThard.
29438 IF (isjets.EQ.1.OR.isqcd.EQ.1.AND.istsb.NE.9) q2ps=sqpth
29439 IF((mstp(68).EQ.1.OR.mstp(68).EQ.3).AND.ismecr.EQ.1) THEN
29440C...Max shower scale = s for ME corrected processes.
29441C...(pT-ordering: max pT2 is s/4)
29442 q2ps=vint(2)
29443 IF (mint(35).GE.3) q2ps=q2ps*0.25d0
29444 ELSEIF(mstp(68).GE.2.AND.isqcd.EQ.0.AND.isjets.EQ.0) THEN
29445C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29446C...(pT-ordering: max pT2 is s/4)
29447 q2ps=vint(2)
29448 IF (mint(35).GE.3) q2ps=q2ps*0.25d0
29449 ENDIF
29450 IF(mint(35).EQ.2.AND.istsb.EQ.9) q2ps=sqpth
29451
29452C...Elastic and diffractive events not associated with scales so set 0.
29453 IF(isubsv.GE.91.AND.isubsv.LE.94) THEN
29454 q2sf=0d0
29455 q2ps=0d0
29456 ENDIF
29457
29458C...Store derived kinematical quantities
29459 vint(41)=x(1)
29460 vint(42)=x(2)
29461 vint(44)=sh
29462 vint(43)=sqrt(sh)
29463 vint(45)=th
29464 vint(46)=uh
29465 IF(istsb.NE.8) vint(48)=sqpth
29466 IF(istsb.NE.8) vint(47)=sqrt(sqpth)
29467 vint(50)=taup*vint(2)
29468 vint(49)=sqrt(max(0d0,vint(50)))
29469 vint(52)=q2
29470 vint(51)=sqrt(q2)
29471 vint(54)=q2sf
29472 vint(53)=sqrt(q2sf)
29473 vint(56)=q2ps
29474 vint(55)=sqrt(q2ps)
29475
29476C...Set starting scale for multiple interactions
29477 IF (isubsv.EQ.95) THEN
29478 xt2gmx=0d0
29479 ELSEIF(mstp(86).EQ.3.OR.(mstp(86).EQ.2.AND.isubsv.NE.11.AND.
29480 & isubsv.NE.12.AND.isubsv.NE.13.AND.isubsv.NE.28.AND.
29481 & isubsv.NE.53.AND.isubsv.NE.68.AND.isubsv.NE.95.AND.
29482 & isubsv.NE.96)) THEN
29483C...All accessible phase space allowed.
29484 xt2gmx=(1d0-vint(41))*(1d0-vint(42))
29485 ELSE
29486C...Scale of hard process sets limit.
29487C...2 -> 1. Limit is tau = x1*x2.
29488C...2 -> 2. Limit is XT2 for hard process + FS masses.
29489C...2 -> n > 2. Limit is tau' = tau of outer process.
29490 xt2gmx=vint(25)
29491 IF(istsb.EQ.1) xt2gmx=vint(21)
29492 IF(istsb.EQ.2)
29493 & xt2gmx=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)
29494 IF(istsb.GE.3.AND.istsb.LE.5) xt2gmx=vint(26)
29495 ENDIF
29496 vint(62)=0.25d0*xt2gmx*vint(2)
29497 vint(61)=sqrt(max(0d0,vint(62)))
29498
29499C...Calculate parton distributions
29500 IF(istsb.LE.0) GOTO 160
29501 IF(mint(47).GE.2) THEN
29502 DO 110 i=3-min(2,mint(45)),min(2,mint(46))
29503 xsf=x(i)
29504 IF(istsb.EQ.9) xsf=x(i)/vint(142+i)
29505 IF(isub.EQ.99) THEN
29506 IF(mint(140+i).EQ.0) THEN
29507 xsf=vint(309-i)/(vint(2)+vint(309-i)-vint(i+2)**2)
29508 ELSE
29509 xsf=vint(309-i)/(vint(2)+vint(307)+vint(308))
29510 ENDIF
29511 vint(40+i)=xsf
29512 q2sf=vint(309-i)
29513 ENDIF
29514 mint(105)=mint(102+i)
29515 mint(109)=mint(106+i)
29516 vint(120)=vint(2+i)
29517 IF(mstp(57).LE.1) THEN
29518 CALL pypdfu(mint(10+i),xsf,q2sf,xpq)
29519 ELSE
29520 CALL pypdfl(mint(10+i),xsf,q2sf,xpq)
29521 ENDIF
29522C...Safety margin against heavy flavour very close to threshold,
29523C...e.g. caused by mismatch in c and b masses.
29524 IF(q2sf.LT.1.1*pmas(4,1)**2) THEN
29525 xpq(4)=0d0
29526 xpq(-4)=0d0
29527 ENDIF
29528 IF(q2sf.LT.1.1*pmas(5,1)**2) THEN
29529 xpq(5)=0d0
29530 xpq(-5)=0d0
29531 ENDIF
29532 DO 100 kfl=-25,25
29533 xsfx(i,kfl)=xpq(kfl)
29534 100 CONTINUE
29535 110 CONTINUE
29536 ENDIF
29537
29538C...Calculate alpha_em, alpha_strong and K-factor
29539 xw=paru(102)
29540 xwv=xw
29541 IF(mstp(8).GE.2.OR.(isub.GE.71.AND.isub.LE.77)) xw=
29542 &1d0-(pmas(24,1)/pmas(23,1))**2
29543 xw1=1d0-xw
29544 xwc=1d0/(16d0*xw*xw1)
29545 aem=pyalem(q2)
29546 IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
29547 IF(mstp(33).NE.3) as=pyalps(parp(34)*q2)
29548 fack=1d0
29549 faca=1d0
29550 IF(mstp(33).EQ.1) THEN
29551 fack=parp(31)
29552 ELSEIF(mstp(33).EQ.2) THEN
29553 fack=parp(31)
29554 faca=parp(32)/parp(31)
29555 ELSEIF(mstp(33).EQ.3) THEN
29556 q2as=parp(33)*q2
29557 IF(istsb.EQ.9.AND.mstp(82).GE.2) q2as=q2as+
29558 & paru(112)*parp(82)*(vint(1)/parp(89))**parp(90)
29559 as=pyalps(q2as)
29560 ENDIF
29561 vint(138)=1d0
29562 vint(57)=aem
29563 vint(58)=as
29564
29565C...Set flags for allowed reacting partons/leptons
29566 DO 140 i=1,2
29567 DO 120 j=-25,25
29568 kfac(i,j)=0
29569 120 CONTINUE
29570 IF(mint(44+i).EQ.1) THEN
29571 kfac(i,mint(10+i))=1
29572 ELSEIF(mint(40+i).EQ.1.AND.mstp(12).EQ.0) THEN
29573 kfac(i,mint(10+i))=1
29574 kfac(i,22)=1
29575 kfac(i,24)=1
29576 kfac(i,-24)=1
29577 ELSE
29578 DO 130 j=-25,25
29579 kfac(i,j)=kfin(i,j)
29580 IF(iabs(j).GT.mstp(58).AND.iabs(j).LE.10) kfac(i,j)=0
29581 IF(xsfx(i,j).LT.1d-10) kfac(i,j)=0
29582 130 CONTINUE
29583 ENDIF
29584 140 CONTINUE
29585
29586C...Lower and upper limit for fermion flavour loops
29587 mmin1=0
29588 mmax1=0
29589 mmin2=0
29590 mmax2=0
29591 DO 150 j=-20,20
29592 IF(kfac(1,-j).EQ.1) mmin1=-j
29593 IF(kfac(1,j).EQ.1) mmax1=j
29594 IF(kfac(2,-j).EQ.1) mmin2=-j
29595 IF(kfac(2,j).EQ.1) mmax2=j
29596 150 CONTINUE
29597 mmina=min(mmin1,mmin2)
29598 mmaxa=max(mmax1,mmax2)
29599
29600C...Common resonance mass and width combinations
29601 sqmz=pmas(23,1)**2
29602 sqmw=pmas(24,1)**2
29603 gmmz=pmas(23,1)*pmas(23,2)
29604 gmmw=pmas(24,1)*pmas(24,2)
29605
29606C...Polarization factors...implemented so far for W+W-(25)
29607 polr=(1d0+parj(132))*(1d0-parj(131))
29608 poll=(1d0-parj(132))*(1d0+parj(131))
29609 polrr=(1d0+parj(132))*(1d0+parj(131))
29610 polll=(1d0-parj(132))*(1d0-parj(131))
29611
29612C...Phase space integral in tau
29613 comfac=paru(1)*paru(5)/vint(2)
29614 IF(mint(41).EQ.2.AND.mint(42).EQ.2) comfac=comfac*fack
29615 IF((mint(47).GE.2.OR.(istsb.GE.3.AND.istsb.LE.5)).AND.
29616 &istsb.NE.8.AND.istsb.NE.9) THEN
29617 atau1=log(taumax/taumin)
29618 atau2=(taumax-taumin)/(taumax*taumin)
29619 h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/tau
29620 IF(mint(72).GE.1) THEN
29621 taur1=vint(73)
29622 gamr1=vint(74)
29623 ataud=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))
29624 atau3=ataud/taur1
29625 IF(ataud.GT.1d-10) h1=h1+
29626 & (atau1/atau3)*coef(isubsv,3)/(tau+taur1)
29627 ataud=atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1)
29628 atau4=ataud/gamr1
29629 IF(ataud.GT.1d-10) h1=h1+
29630 & (atau1/atau4)*coef(isubsv,4)*tau/((tau-taur1)**2+gamr1**2)
29631 ENDIF
29632 IF(mint(72).GE.2) THEN
29633 taur2=vint(75)
29634 gamr2=vint(76)
29635 ataud=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))
29636 atau5=ataud/taur2
29637 IF(ataud.GT.1d-10) h1=h1+
29638 & (atau1/atau5)*coef(isubsv,5)/(tau+taur2)
29639 ataud=atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2)
29640 atau6=ataud/gamr2
29641 IF(ataud.GT.1d-10) h1=h1+
29642 & (atau1/atau6)*coef(isubsv,6)*tau/((tau-taur2)**2+gamr2**2)
29643 ENDIF
29644 IF(mint(72).EQ.3) THEN
29645 taur3=vint(77)
29646 gamr3=vint(78)
29647 ataud=log(taumax/taumin*(taumin+taur3)/(taumax+taur3))
29648 atau50=ataud/taur3
29649 IF(ataud.GT.1d-10) h1=h1+
29650 & (atau1/atau50)*coefx(isubsv,1)/(tau+taur3)
29651 ataud=atan((taumax-taur3)/gamr3)-atan((taumin-taur3)/gamr3)
29652 atau60=ataud/gamr3
29653 IF(ataud.GT.1d-10) h1=h1+
29654 & (atau1/atau60)*coefx(isubsv,2)*tau/((tau-taur3)**2+gamr3**2)
29655 ENDIF
29656 IF(mint(47).EQ.5.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
29657 atau7=log(max(2d-10,1d0-taumin)/max(2d-10,1d0-taumax))
29658 IF(atau7.GT.1d-10) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
29659 & max(2d-10,1d0-tau)
29660 ELSEIF(mint(47).GE.6.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN
29661 atau7=log(max(1d-10,1d0-taumin)/max(1d-10,1d0-taumax))
29662 IF(atau7.GT.1d-10) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/
29663 & max(1d-10,1d0-tau)
29664 ENDIF
29665 comfac=comfac*atau1/(tau*h1)
29666 ENDIF
29667
29668C...Phase space integral in y*
29669 IF((mint(47).EQ.4.OR.mint(47).EQ.5).AND.istsb.NE.8.AND.istsb.NE.9)
29670 &THEN
29671 ayst0=ystmax-ystmin
29672 IF(ayst0.LT.1d-10) THEN
29673 comfac=0d0
29674 ELSE
29675 ayst1=0.5d0*(ystmax-ystmin)**2
29676 ayst2=ayst1
29677 ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
29678 h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
29679 & (ayst0/ayst2)*coef(isubsv,9)*(ystmax-yst)+
29680 & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
29681 IF(mint(45).EQ.3) THEN
29682 yst0=-0.5d0*log(taue)
29683 ayst4=log(max(1d-10,exp(yst0-ystmin)-1d0)/
29684 & max(1d-10,exp(yst0-ystmax)-1d0))
29685 IF(ayst4.GT.1d-10) h2=h2+(ayst0/ayst4)*coef(isubsv,11)/
29686 & max(1d-10,1d0-exp(yst-yst0))
29687 ENDIF
29688 IF(mint(46).EQ.3) THEN
29689 yst0=-0.5d0*log(taue)
29690 ayst5=log(max(1d-10,exp(yst0+ystmax)-1d0)/
29691 & max(1d-10,exp(yst0+ystmin)-1d0))
29692 IF(ayst5.GT.1d-10) h2=h2+(ayst0/ayst5)*coef(isubsv,12)/
29693 & max(1d-10,1d0-exp(-yst-yst0))
29694 ENDIF
29695 comfac=comfac*ayst0/h2
29696 ENDIF
29697 ENDIF
29698
29699C...2 -> 1 processes: reduction in angular part of phase space integral
29700C...for case of decaying resonance
29701 acth0=ctnmax-ctnmin+ctpmax-ctpmin
29702 IF((istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5)) THEN
29703 IF(mdcy(pycomp(kfpr(isubsv,1)),1).EQ.1) THEN
29704 IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37.OR.
29705 & kfpr(isub,1).EQ.39) THEN
29706 comfac=comfac*0.5d0*acth0
29707 ELSE
29708 comfac=comfac*0.125d0*(3d0*acth0+ctnmax**3-ctnmin**3+
29709 & ctpmax**3-ctpmin**3)
29710 ENDIF
29711 ENDIF
29712
29713C...2 -> 2 processes: angular part of phase space integral
29714 ELSEIF(istsb.EQ.2.OR.istsb.EQ.4) THEN
29715 acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/
29716 & (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))
29717 acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/
29718 & (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))
29719 acth3=1d0/max(rm34,rsqm-ctnmax)-1d0/max(rm34,rsqm-ctnmin)+
29720 & 1d0/max(rm34,rsqm-ctpmax)-1d0/max(rm34,rsqm-ctpmin)
29721 acth4=1d0/max(rm34,rsqm+ctnmin)-1d0/max(rm34,rsqm+ctnmax)+
29722 & 1d0/max(rm34,rsqm+ctpmin)-1d0/max(rm34,rsqm+ctpmax)
29723 h3=coef(isubsv,13)+
29724 & (acth0/acth1)*coef(isubsv,14)/max(rm34,rsqm-cth)+
29725 & (acth0/acth2)*coef(isubsv,15)/max(rm34,rsqm+cth)+
29726 & (acth0/acth3)*coef(isubsv,16)/max(rm34,rsqm-cth)**2+
29727 & (acth0/acth4)*coef(isubsv,17)/max(rm34,rsqm+cth)**2
29728 comfac=comfac*acth0*0.5d0*be34/h3
29729
29730C...2 -> 2 processes: take into account final state Breit-Wigners
29731 comfac=comfac*vint(80)
29732 ENDIF
29733
29734C...2 -> 3, 4 processes: phace space integral in tau'
29735 IF(mint(47).GE.2.AND.istsb.GE.3.AND.istsb.LE.5) THEN
29736 ataup1=log(taupmx/taupmn)
29737 ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)
29738 h4=coef(isubsv,18)+
29739 & (ataup1/ataup2)*coef(isubsv,19)*(1d0-tau/taup)**3/taup
29740 IF(mint(47).EQ.5) THEN
29741 ataup3=log(max(2d-10,1d0-taupmn)/max(2d-10,1d0-taupmx))
29742 h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(2d-10,1d0-taup)
29743 ELSEIF(mint(47).GE.6) THEN
29744 ataup3=log(max(1d-10,1d0-taupmn)/max(1d-10,1d0-taupmx))
29745 h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(1d-10,1d0-taup)
29746 ENDIF
29747 comfac=comfac*ataup1/h4
29748 ENDIF
29749
29750C...2 -> 3, 4 processes: effective W/Z parton distributions
29751 IF(istsb.EQ.3.OR.istsb.EQ.4) THEN
29752 IF(1d0-tau/taup.GT.1d-4) THEN
29753 fzw=(1d0+tau/taup)*log(taup/tau)-2d0*(1d0-tau/taup)
29754 ELSE
29755 fzw=1d0/6d0*(1d0-tau/taup)**3*tau/taup
29756 ENDIF
29757 comfac=comfac*fzw
29758 ENDIF
29759
29760C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29761 IF(istsb.EQ.5) THEN
29762 comfac=comfac*vint(205)*vint(210)*vint(212)*vint(214)/
29763 & (128d0*paru(1)**4*vint(220))*(tau**2/taup)
29764 ENDIF
29765
29766C...Phase space integral for low-pT and multiple interactions
29767 IF(istsb.EQ.9) THEN
29768 comfac=paru(1)*paru(5)*fack*0.5d0*vint(2)/sh2
29769 atau1=log(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)
29770 atau2=2d0*atan(1d0/xt2-1d0)/sqrt(xt2)
29771 h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/sqrt(tau)
29772 comfac=comfac*atau1/h1
29773 ayst0=ystmax-ystmin
29774 ayst1=0.5d0*(ystmax-ystmin)**2
29775 ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))
29776 h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+
29777 & (ayst0/ayst1)*coef(isubsv,9)*(ystmax-yst)+
29778 & (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)
29779 comfac=comfac*ayst0/h2
29780 IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1d0/vint(149)-1d0)
29781C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29782C...introduced to make cross-section finite for xT2 -> 0
29783 IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*
29784 & (1d0+vint(149)))
29785 ENDIF
29786
29787C...Real gamma + gamma: include factor 2 when different nature
29788 160 IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.
29789 &mstp(14).LE.10) comfac=2d0*comfac
29790
29791C...Extra factors to include the effects of
29792C...longitudinal resolved photons (but not direct or DIS ones).
29793 DO 170 isde=1,2
29794 IF(mint(10+isde).EQ.22.AND.mint(106+isde).GE.1.AND.
29795 & mint(106+isde).LE.3) THEN
29796 vint(314+isde)=1d0
29797 xy=parp(166+isde)
29798 IF(mstp(16).EQ.0) THEN
29799 IF(vint(304+isde).GT.0d0.AND.vint(304+isde).LT.1d0)
29800 & xy=vint(304+isde)
29801 ELSE
29802 IF(vint(308+isde).GT.0d0.AND.vint(308+isde).LT.1d0)
29803 & xy=vint(308+isde)
29804 ENDIF
29805 q2ga=vint(306+isde)
29806 IF(mstp(17).GT.0.AND.xy.GT.0d0.AND.xy.LT.1d0.AND.
29807 & q2ga.GT.0d0) THEN
29808 reduce=0d0
29809 IF(mstp(17).EQ.1) THEN
29810 reduce=4d0*q2*q2ga/(q2+q2ga)**2
29811 ELSEIF(mstp(17).EQ.2) THEN
29812 reduce=4d0*q2ga/(q2+q2ga)
29813 ELSEIF(mstp(17).EQ.3) THEN
29814 pmvirt=pmas(pycomp(113),1)
29815 reduce=4d0*q2ga/(pmvirt**2+q2ga)
29816 ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.1) THEN
29817 pmvirt=pmas(pycomp(113),1)
29818 reduce=4d0*pmvirt**2*q2ga/(pmvirt**2+q2ga)**2
29819 ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.2) THEN
29820 pmvirt=pmas(pycomp(113),1)
29821 reduce=4d0*pmvirt**2*q2ga/(pmvirt**2+q2ga)**2
29822 ELSEIF(mstp(17).EQ.4.AND.mint(106+isde).EQ.3) THEN
29823 pmvsmn=4d0*parp(15)**2
29824 pmvsmx=4d0*vint(154)**2
29825 redtra=1d0/(pmvsmn+q2ga)-1d0/(pmvsmx+q2ga)
29826 redlon=(3d0*pmvsmn+q2ga)/(pmvsmn+q2ga)**3-
29827 & (3d0*pmvsmx+q2ga)/(pmvsmx+q2ga)**3
29828 reduce=4d0*(q2ga/6d0)*redlon/redtra
29829 ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.1) THEN
29830 pmvirt=pmas(pycomp(113),1)
29831 reduce=4d0*q2ga/(pmvirt**2+q2ga)
29832 ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.2) THEN
29833 pmvirt=pmas(pycomp(113),1)
29834 reduce=4d0*q2ga/(pmvirt**2+q2ga)
29835 ELSEIF(mstp(17).EQ.5.AND.mint(106+isde).EQ.3) THEN
29836 pmvsmn=4d0*parp(15)**2
29837 pmvsmx=4d0*vint(154)**2
29838 redtra=1d0/(pmvsmn+q2ga)-1d0/(pmvsmx+q2ga)
29839 redlon=1d0/(pmvsmn+q2ga)**2-1d0/(pmvsmx+q2ga)**2
29840 reduce=4d0*(q2ga/2d0)*redlon/redtra
29841 ENDIF
29842 beamas=pymass(11)
29843 IF(vint(302+isde).GT.0d0) beamas=vint(302+isde)
29844 fraclt=1d0/(1d0+xy**2/2d0/(1d0-xy)*
29845 & (1d0-2d0*beamas**2/q2ga))
29846 vint(314+isde)=1d0+parp(165)*reduce*fraclt
29847 ENDIF
29848 ELSE
29849 vint(314+isde)=1d0
29850 ENDIF
29851 comfac=comfac*vint(314+isde)
29852 170 CONTINUE
29853
29854C...Evaluate cross sections - done in separate routines by kind
29855C...of physics, to keep PYSIGH of sensible size.
29856 IF(map.EQ.1) THEN
29857C...Standard QCD (including photons).
29858 CALL pysgqc(nchn,sigs)
29859 ELSEIF(map.EQ.2) THEN
29860C...Heavy flavours.
29861 CALL pysghf(nchn,sigs)
29862 ELSEIF(map.EQ.3) THEN
29863C...W/Z.
29864 CALL pysgwz(nchn,sigs)
29865 ELSEIF(map.EQ.4) THEN
29866C...Higgs (2 doublets; including longitudinal W/Z scattering).
29867 CALL pysghg(nchn,sigs)
29868 ELSEIF(map.EQ.5) THEN
29869C...SUSY.
29870 CALL pysgsu(nchn,sigs)
29871 ELSEIF(map.EQ.6) THEN
29872C...Technicolor.
29873 CALL pysgtc(nchn,sigs)
29874 ELSEIF(map.EQ.7) THEN
29875C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29876 CALL pysgex(nchn,sigs)
29877 ELSEIF(map.EQ.8) THEN
29878C... Universal Extra Dimensions
29879 CALL pyxued(nchn,sigs)
29880 ENDIF
29881
29882C...Multiply with parton distributions
29883 IF(isub.LE.90.OR.isub.GE.96) THEN
29884 DO 180 ichn=1,nchn
29885 IF(mint(45).GE.2) THEN
29886 kfl1=isig(ichn,1)
29887 sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)
29888 ENDIF
29889 IF(mint(46).GE.2) THEN
29890 kfl2=isig(ichn,2)
29891 sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)
29892 ENDIF
29893 sigs=sigs+sigh(ichn)
29894 180 CONTINUE
29895 ENDIF
29896
29897 RETURN
29898 END
29899
29900C*********************************************************************
29901
29902C...PYSGQC
29903C...Subprocess cross sections for QCD processes,
29904C...including photons.
29905C...Auxiliary to PYSIGH.
29906
29907 SUBROUTINE pysgqc(NCHN,SIGS)
29908
29909C...Double precision and integer declarations
29910 IMPLICIT DOUBLE PRECISION(a-h, o-z)
29911 IMPLICIT INTEGER(I-N)
29912 INTEGER PYK,PYCHGE,PYCOMP
29913C...Parameter statement to help give large particle numbers.
29914 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
29915 &kexcit=4000000,kdimen=5000000)
29916C...Commonblocks
29917 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
29918 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
29919 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
29920 common/pypars/mstp(200),parp(200),msti(200),pari(200)
29921 common/pyint1/mint(400),vint(400)
29922 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
29923 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
29924 common/pyint4/mwid(500),wids(500,5)
29925 common/pyint7/sigt(0:6,0:6,0:5)
29926 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
29927 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
29928 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
29929 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
29930 SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
29931 &/pyint3/,/pyint4/,/pyint7/,/pysgcm/
29932C...Local arrays
29933 dimension wdtp(0:400),wdte(0:400,0:5)
29934
29935C...Differential cross section expressions.
29936
29937 IF(isub.LE.20) THEN
29938 IF(isub.EQ.10) THEN
29939C...f + f' -> f + f' (gamma/Z/W exchange)
29940 facggf=comfac*aem**2*2d0*(sh2+uh2)/th2
29941 facgzf=comfac*aem**2*xwc*4d0*sh2/(th*(th-sqmz))
29942 faczzf=comfac*(aem*xwc)**2*2d0*sh2/(th-sqmz)**2
29943 facwwf=comfac*(0.5d0*aem/xw)**2*sh2/(th-sqmw)**2
29944 DO 110 i=mmin1,mmax1
29945 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 110
29946 ia=iabs(i)
29947 DO 100 j=mmin2,mmax2
29948 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 100
29949 ja=iabs(j)
29950C...Electroweak couplings
29951 ei=kchg(ia,1)*isign(1,i)/3d0
29952 ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
29953 vi=ai-4d0*ei*xwv
29954 ej=kchg(ja,1)*isign(1,j)/3d0
29955 aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
29956 vj=aj-4d0*ej*xwv
29957 epsij=isign(1,i*j)
29958C...gamma/Z exchange, only gamma exchange, or only Z exchange
29959 IF(mstp(21).GE.1.AND.mstp(21).LE.4) THEN
29960 IF(mstp(21).EQ.1.OR.mstp(21).EQ.4) THEN
29961 facncf=facggf*ei**2*ej**2+facgzf*ei*ej*
29962 & (vi*vj*(1d0+uh2/sh2)+ai*aj*epsij*(1d0-uh2/sh2))+
29963 & faczzf*((vi**2+ai**2)*(vj**2+aj**2)*(1d0+uh2/sh2)+
29964 & 4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
29965 ELSEIF(mstp(21).EQ.2) THEN
29966 facncf=facggf*ei**2*ej**2
29967 ELSE
29968 facncf=faczzf*((vi**2+ai**2)*(vj**2+aj**2)*
29969 & (1d0+uh2/sh2)+4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))
29970 ENDIF
29971C...Extrafactor 2 for only one incoming neutrino spin state.
29972 IF(ia.GT.10.AND.mod(ia,2).EQ.0) facncf=2d0*facncf
29973 IF(ja.GT.10.AND.mod(ja,2).EQ.0) facncf=2d0*facncf
29974 nchn=nchn+1
29975 isig(nchn,1)=i
29976 isig(nchn,2)=j
29977 isig(nchn,3)=1
29978 sigh(nchn)=facncf
29979 ENDIF
29980C...W exchange
29981 IF((mstp(21).EQ.1.OR.mstp(21).EQ.5).AND.ai*aj.LT.0d0) THEN
29982 facccf=facwwf*vint(180+i)*vint(180+j)
29983 IF(epsij.LT.0d0) facccf=facccf*uh2/sh2
29984 IF(ia.GT.10.AND.mod(ia,2).EQ.0) facccf=2d0*facccf
29985 IF(ja.GT.10.AND.mod(ja,2).EQ.0) facccf=2d0*facccf
29986 nchn=nchn+1
29987 isig(nchn,1)=i
29988 isig(nchn,2)=j
29989 isig(nchn,3)=2
29990 sigh(nchn)=facccf
29991 ENDIF
29992 100 CONTINUE
29993 110 CONTINUE
29994
29995 ELSEIF(isub.EQ.11) THEN
29996C...f + f' -> f + f' (g exchange)
29997 facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
29998 facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
29999 & mstp(34)*2d0/3d0*uh2/(sh*th))
30000 facqq2=comfac*as**2*4d0/9d0*((sh2+th2)/uh2-
30001 & mstp(34)*2d0/3d0*sh2/(th*uh))
30002 DO 130 i=mmin1,mmax1
30003 ia=iabs(i)
30004 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 130
30005 DO 120 j=mmin2,mmax2
30006 ja=iabs(j)
30007 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 120
30008 nchn=nchn+1
30009 isig(nchn,1)=i
30010 isig(nchn,2)=j
30011 isig(nchn,3)=1
30012 sigh(nchn)=facqq1
30013 IF(i.EQ.-j) sigh(nchn)=facqqb
30014 IF(i.EQ.j) THEN
30015 sigh(nchn)=0.5d0*sigh(nchn)
30016 nchn=nchn+1
30017 isig(nchn,1)=i
30018 isig(nchn,2)=j
30019 isig(nchn,3)=2
30020 sigh(nchn)=0.5d0*facqq2
30021 ENDIF
30022 120 CONTINUE
30023 130 CONTINUE
30024
30025 ELSEIF(isub.EQ.12) THEN
30026C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30027 CALL pywidt(21,sh,wdtp,wdte)
30028 facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
30029 & (wdte(0,1)+wdte(0,2)+wdte(0,4))
30030 DO 140 i=mmina,mmaxa
30031 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30032 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 140
30033 nchn=nchn+1
30034 isig(nchn,1)=i
30035 isig(nchn,2)=-i
30036 isig(nchn,3)=1
30037 sigh(nchn)=facqqb
30038 140 CONTINUE
30039
30040 ELSEIF(isub.EQ.13) THEN
30041C...f + fbar -> g + g (q + qbar -> g + g only)
30042 facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30043 & uh2/sh2)
30044 facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30045 & th2/sh2)
30046 DO 150 i=mmina,mmaxa
30047 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30048 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 150
30049 nchn=nchn+1
30050 isig(nchn,1)=i
30051 isig(nchn,2)=-i
30052 isig(nchn,3)=1
30053 sigh(nchn)=0.5d0*facgg1
30054 nchn=nchn+1
30055 isig(nchn,1)=i
30056 isig(nchn,2)=-i
30057 isig(nchn,3)=2
30058 sigh(nchn)=0.5d0*facgg2
30059 150 CONTINUE
30060
30061 ELSEIF(isub.EQ.14) THEN
30062C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30063 facgg=comfac*as*aem*8d0/9d0*(th2+uh2)/(th*uh)
30064 DO 160 i=mmina,mmaxa
30065 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30066 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 160
30067 ei=kchg(iabs(i),1)/3d0
30068 nchn=nchn+1
30069 isig(nchn,1)=i
30070 isig(nchn,2)=-i
30071 isig(nchn,3)=1
30072 sigh(nchn)=facgg*ei**2
30073 160 CONTINUE
30074
30075 ELSEIF(isub.EQ.18) THEN
30076C...f + fbar -> gamma + gamma
30077 facgg=comfac*aem**2*2d0*(th2+uh2)/(th*uh)
30078 DO 170 i=mmina,mmaxa
30079 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 170
30080 ei=kchg(iabs(i),1)/3d0
30081 fcoi=1d0
30082 IF(iabs(i).LE.10) fcoi=faca/3d0
30083 nchn=nchn+1
30084 isig(nchn,1)=i
30085 isig(nchn,2)=-i
30086 isig(nchn,3)=1
30087 sigh(nchn)=0.5d0*facgg*fcoi*ei**4
30088 170 CONTINUE
30089 ENDIF
30090
30091 ELSEIF(isub.LE.40) THEN
30092 IF(isub.EQ.28) THEN
30093C...f + g -> f + g (q + g -> q + g only)
30094 facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
30095 & uh/sh)*faca
30096 facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
30097 & sh/uh)
30098 DO 190 i=mmina,mmaxa
30099 IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 190
30100 DO 180 isde=1,2
30101 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 180
30102 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 180
30103 nchn=nchn+1
30104 isig(nchn,isde)=i
30105 isig(nchn,3-isde)=21
30106 isig(nchn,3)=1
30107 sigh(nchn)=facqg1
30108 nchn=nchn+1
30109 isig(nchn,isde)=i
30110 isig(nchn,3-isde)=21
30111 isig(nchn,3)=2
30112 sigh(nchn)=facqg2
30113 180 CONTINUE
30114 190 CONTINUE
30115
30116 ELSEIF(isub.EQ.29) THEN
30117C...f + g -> f + gamma (q + g -> q + gamma only)
30118 fgq=comfac*faca*as*aem*1d0/3d0*(sh2+uh2)/(-sh*uh)
30119 DO 210 i=mmina,mmaxa
30120 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 210
30121 ei=kchg(iabs(i),1)/3d0
30122 facgq=fgq*ei**2
30123 DO 200 isde=1,2
30124 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 200
30125 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 200
30126 nchn=nchn+1
30127 isig(nchn,isde)=i
30128 isig(nchn,3-isde)=21
30129 isig(nchn,3)=1
30130 sigh(nchn)=facgq
30131 200 CONTINUE
30132 210 CONTINUE
30133
30134 ELSEIF(isub.EQ.33) THEN
30135C...f + gamma -> f + g (q + gamma -> q + g only)
30136 fgq=comfac*as*aem*8d0/3d0*(sh2+uh2)/(-sh*uh)
30137 DO 230 i=mmina,mmaxa
30138 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 230
30139 ei=kchg(iabs(i),1)/3d0
30140 facgq=fgq*ei**2
30141 DO 220 isde=1,2
30142 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 220
30143 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 220
30144 nchn=nchn+1
30145 isig(nchn,isde)=i
30146 isig(nchn,3-isde)=22
30147 isig(nchn,3)=1
30148 sigh(nchn)=facgq
30149 220 CONTINUE
30150 230 CONTINUE
30151
30152 ELSEIF(isub.EQ.34) THEN
30153C...f + gamma -> f + gamma
30154 fgq=comfac*aem**2*2d0*(sh2+uh2)/(-sh*uh)
30155 DO 250 i=mmina,mmaxa
30156 IF(i.EQ.0) GOTO 250
30157 ei=kchg(iabs(i),1)/3d0
30158 facgq=fgq*ei**4
30159 DO 240 isde=1,2
30160 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 240
30161 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 240
30162 nchn=nchn+1
30163 isig(nchn,isde)=i
30164 isig(nchn,3-isde)=22
30165 isig(nchn,3)=1
30166 sigh(nchn)=facgq
30167 240 CONTINUE
30168 250 CONTINUE
30169 ENDIF
30170
30171 ELSEIF(isub.LE.80) THEN
30172 IF(isub.EQ.53) THEN
30173C...g + g -> f + fbar (g + g -> q + qbar only)
30174 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 270
30175 idc0=mdcy(21,2)-1
30176C...Begin by d, u, s flavours.
30177 flavwt=0d0
30178 IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
30179 & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
30180 IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
30181 & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
30182 IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
30183 & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
30184 facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30185 & uh2/sh2)*flavwt*faca
30186 facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30187 & th2/sh2)*flavwt*faca
30188 nchn=nchn+1
30189 isig(nchn,1)=21
30190 isig(nchn,2)=21
30191 isig(nchn,3)=1
30192 sigh(nchn)=facqq1
30193 nchn=nchn+1
30194 isig(nchn,1)=21
30195 isig(nchn,2)=21
30196 isig(nchn,3)=2
30197 sigh(nchn)=facqq2
30198C...Next c and b flavours: modified that and uhat for fixed
30199C...cos(theta-hat).
30200 DO 260 ifl=4,5
30201 sqmavg=pmas(ifl,1)**2
30202 IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
30203 be34=sqrt(1d0-4d0*sqmavg/sh)
30204 thq=-0.5d0*sh*(1d0-be34*cth)
30205 uhq=-0.5d0*sh*(1d0+be34*cth)
30206 thuhq=thq*uhq-sqmavg*sh
30207 IF(mstp(34).EQ.0) THEN
30208 facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
30209 facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
30210 ELSE
30211 facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30212 & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
30213 facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30214 & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
30215 ENDIF
30216 facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
30217 facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
30218 nchn=nchn+1
30219 isig(nchn,1)=21
30220 isig(nchn,2)=21
30221 isig(nchn,3)=1+2*(ifl-3)
30222 sigh(nchn)=facqq1
30223 nchn=nchn+1
30224 isig(nchn,1)=21
30225 isig(nchn,2)=21
30226 isig(nchn,3)=2+2*(ifl-3)
30227 sigh(nchn)=facqq2
30228 ENDIF
30229 260 CONTINUE
30230 270 CONTINUE
30231
30232 ELSEIF(isub.EQ.54) THEN
30233C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30234 CALL pywidt(21,sh,wdtp,wdte)
30235 wdtesu=0d0
30236 DO 280 i=1,min(8,mdcy(21,3))
30237 ef=kchg(i,1)/3d0
30238 wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30239 & wdte(i,4))
30240 280 CONTINUE
30241 facqq=comfac*aem*as*wdtesu*(th2+uh2)/(th*uh)
30242 IF(kfac(1,21)*kfac(2,22).NE.0) THEN
30243 nchn=nchn+1
30244 isig(nchn,1)=21
30245 isig(nchn,2)=22
30246 isig(nchn,3)=1
30247 sigh(nchn)=facqq
30248 ENDIF
30249 IF(kfac(1,22)*kfac(2,21).NE.0) THEN
30250 nchn=nchn+1
30251 isig(nchn,1)=22
30252 isig(nchn,2)=21
30253 isig(nchn,3)=1
30254 sigh(nchn)=facqq
30255 ENDIF
30256
30257 ELSEIF(isub.EQ.58) THEN
30258C...gamma + gamma -> f + fbar
30259 CALL pywidt(22,sh,wdtp,wdte)
30260 wdtesu=0d0
30261 DO 290 i=1,min(12,mdcy(22,3))
30262 IF(i.LE.8) ef= kchg(i,1)/3d0
30263 IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
30264 wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30265 & wdte(i,4))
30266 290 CONTINUE
30267 facff=comfac*aem**2*wdtesu*2d0*(th2+uh2)/(th*uh)
30268 IF(kfac(1,22)*kfac(2,22).NE.0) THEN
30269 nchn=nchn+1
30270 isig(nchn,1)=22
30271 isig(nchn,2)=22
30272 isig(nchn,3)=1
30273 sigh(nchn)=facff
30274 ENDIF
30275
30276 ELSEIF(isub.EQ.68) THEN
30277C...g + g -> g + g
30278 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 300
30279 facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+2d0*th/sh+
30280 & th2/sh2)*faca
30281 facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+2d0*sh/uh+
30282 & sh2/uh2)*faca
30283 facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+2d0*uh/th+
30284 & uh2/th2)
30285 nchn=nchn+1
30286 isig(nchn,1)=21
30287 isig(nchn,2)=21
30288 isig(nchn,3)=1
30289 sigh(nchn)=0.5d0*facgg1
30290 nchn=nchn+1
30291 isig(nchn,1)=21
30292 isig(nchn,2)=21
30293 isig(nchn,3)=2
30294 sigh(nchn)=0.5d0*facgg2
30295 nchn=nchn+1
30296 isig(nchn,1)=21
30297 isig(nchn,2)=21
30298 isig(nchn,3)=3
30299 sigh(nchn)=0.5d0*facgg3
30300 300 CONTINUE
30301
30302 ELSEIF(isub.EQ.80) THEN
30303C...q + gamma -> q' + pi+/-
30304 fqpi=comfac*(2d0*aem/9d0)*(-sh/th)*(1d0/sh2+1d0/th2)
30305 assh=pyalps(max(0.5d0,0.5d0*sh))
30306 q2fpsh=0.55d0/log(max(2d0,2d0*sh))
30307 delsh=uh*sqrt(assh*q2fpsh)
30308 asuh=pyalps(max(0.5d0,-0.5d0*uh))
30309 q2fpuh=0.55d0/log(max(2d0,-2d0*uh))
30310 deluh=sh*sqrt(asuh*q2fpuh)
30311 DO 320 i=max(-2,mmina),min(2,mmaxa)
30312 IF(i.EQ.0) GOTO 320
30313 ei=kchg(iabs(i),1)/3d0
30314 ej=sign(1d0-abs(ei),ei)
30315 DO 310 isde=1,2
30316 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 310
30317 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 310
30318 nchn=nchn+1
30319 isig(nchn,isde)=i
30320 isig(nchn,3-isde)=22
30321 isig(nchn,3)=1
30322 sigh(nchn)=fqpi*(ei*delsh+ej*deluh)**2
30323 310 CONTINUE
30324 320 CONTINUE
30325 ENDIF
30326
30327 ELSEIF(isub.LE.100) THEN
30328 IF(isub.EQ.91) THEN
30329C...Elastic scattering
30330 sigs=vint(315)*vint(316)*sigt(0,0,1)
30331
30332 ELSEIF(isub.EQ.92) THEN
30333C...Single diffractive scattering (first side, i.e. XB)
30334 sigs=vint(315)*vint(316)*sigt(0,0,2)
30335
30336 ELSEIF(isub.EQ.93) THEN
30337C...Single diffractive scattering (second side, i.e. AX)
30338 sigs=vint(315)*vint(316)*sigt(0,0,3)
30339
30340 ELSEIF(isub.EQ.94) THEN
30341C...Double diffractive scattering
30342 sigs=vint(315)*vint(316)*sigt(0,0,4)
30343
30344 ELSEIF(isub.EQ.95) THEN
30345C...Low-pT scattering
30346 sigs=vint(315)*vint(316)*sigt(0,0,5)
30347
30348 ELSEIF(isub.EQ.96) THEN
30349C...Multiple interactions: sum of QCD processes
30350 CALL pywidt(21,sh,wdtp,wdte)
30351
30352C...q + q' -> q + q'
30353 facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2
30354 facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-
30355 & mstp(34)*2d0/3d0*uh2/(sh*th))
30356 facqq2=comfac*as**2*4d0/9d0*(sh2+th2)/uh2
30357 facqqi=-comfac*as**2*4d0/9d0*mstp(34)*2d0/3d0*sh2/(th*uh)
30358 ratqqi=(facqq1+facqq2+facqqi)/(facqq1+facqq2)
30359 DO 340 i=-5,5
30360 IF(i.EQ.0) GOTO 340
30361 DO 330 j=-5,5
30362 IF(j.EQ.0) GOTO 330
30363 nchn=nchn+1
30364 isig(nchn,1)=i
30365 isig(nchn,2)=j
30366 isig(nchn,3)=111
30367 sigh(nchn)=facqq1
30368 IF(i.EQ.-j) sigh(nchn)=facqqb
30369 IF(i.EQ.j) THEN
30370 sigh(nchn)=0.5d0*facqq1*ratqqi
30371 nchn=nchn+1
30372 isig(nchn,1)=i
30373 isig(nchn,2)=j
30374 isig(nchn,3)=112
30375 sigh(nchn)=0.5d0*facqq2*ratqqi
30376 ENDIF
30377 330 CONTINUE
30378 340 CONTINUE
30379
30380C...q + qbar -> q' + qbar' or g + g
30381 facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*
30382 & (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))
30383 facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30384 & uh2/sh2)
30385 facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30386 & th2/sh2)
30387 DO 350 i=-5,5
30388 IF(i.EQ.0) GOTO 350
30389 nchn=nchn+1
30390 isig(nchn,1)=i
30391 isig(nchn,2)=-i
30392 isig(nchn,3)=121
30393 sigh(nchn)=facqqb
30394 nchn=nchn+1
30395 isig(nchn,1)=i
30396 isig(nchn,2)=-i
30397 isig(nchn,3)=131
30398 sigh(nchn)=0.5d0*facgg1
30399 nchn=nchn+1
30400 isig(nchn,1)=i
30401 isig(nchn,2)=-i
30402 isig(nchn,3)=132
30403 sigh(nchn)=0.5d0*facgg2
30404 350 CONTINUE
30405
30406C...q + g -> q + g
30407 facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
30408 & uh/sh)*faca
30409 facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
30410 & sh/uh)
30411 DO 370 i=-5,5
30412 IF(i.EQ.0) GOTO 370
30413 DO 360 isde=1,2
30414 nchn=nchn+1
30415 isig(nchn,isde)=i
30416 isig(nchn,3-isde)=21
30417 isig(nchn,3)=281
30418 sigh(nchn)=facqg1
30419 nchn=nchn+1
30420 isig(nchn,isde)=i
30421 isig(nchn,3-isde)=21
30422 isig(nchn,3)=282
30423 sigh(nchn)=facqg2
30424 360 CONTINUE
30425 370 CONTINUE
30426
30427C...g + g -> q + qbar (only d, u, s)
30428 idc0=mdcy(21,2)-1
30429 flavwt=0d0
30430 IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
30431 & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
30432 IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
30433 & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
30434 IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
30435 & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
30436 facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
30437 & uh2/sh2)*flavwt*faca
30438 facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
30439 & th2/sh2)*flavwt*faca
30440 nchn=nchn+1
30441 isig(nchn,1)=21
30442 isig(nchn,2)=21
30443 isig(nchn,3)=531
30444 sigh(nchn)=facqq1
30445 nchn=nchn+1
30446 isig(nchn,1)=21
30447 isig(nchn,2)=21
30448 isig(nchn,3)=532
30449 sigh(nchn)=facqq2
30450
30451C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30452C...cos(theta-hat)
30453 DO 380 ifl=4,5
30454 sqmavg=pmas(ifl,1)**2
30455 IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
30456 be34=sqrt(1d0-4d0*sqmavg/sh)
30457 thq=-0.5d0*sh*(1d0-be34*cth)
30458 uhq=-0.5d0*sh*(1d0+be34*cth)
30459 thuhq=thq*uhq-sqmavg*sh
30460 IF(mstp(34).EQ.0) THEN
30461 facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
30462 facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
30463 ELSE
30464 facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30465 & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
30466 facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30467 & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
30468 ENDIF
30469 facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
30470 facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
30471 nchn=nchn+1
30472 isig(nchn,1)=21
30473 isig(nchn,2)=21
30474 isig(nchn,3)=531+2*(ifl-3)
30475 sigh(nchn)=facqq1
30476 nchn=nchn+1
30477 isig(nchn,1)=21
30478 isig(nchn,2)=21
30479 isig(nchn,3)=532+2*(ifl-3)
30480 sigh(nchn)=facqq2
30481 ENDIF
30482 380 CONTINUE
30483
30484C...g + g -> g + g
30485 facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+
30486 & 2d0*th/sh+th2/sh2)*faca
30487 facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+
30488 & 2d0*sh/uh+sh2/uh2)*faca
30489 facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3+
30490 & 2d0*uh/th+uh2/th2)
30491 nchn=nchn+1
30492 isig(nchn,1)=21
30493 isig(nchn,2)=21
30494 isig(nchn,3)=681
30495 sigh(nchn)=0.5d0*facgg1
30496 nchn=nchn+1
30497 isig(nchn,1)=21
30498 isig(nchn,2)=21
30499 isig(nchn,3)=682
30500 sigh(nchn)=0.5d0*facgg2
30501 nchn=nchn+1
30502 isig(nchn,1)=21
30503 isig(nchn,2)=21
30504 isig(nchn,3)=683
30505 sigh(nchn)=0.5d0*facgg3
30506
30507 ELSEIF(isub.EQ.99) THEN
30508C...f + gamma* -> f.
30509 IF(mint(107).EQ.4) THEN
30510 q2ga=vint(307)
30511 p2ga=vint(308)
30512 isde=2
30513 ELSE
30514 q2ga=vint(308)
30515 p2ga=vint(307)
30516 isde=1
30517 ENDIF
30518 comfac=paru(5)*4d0*paru(1)**2*paru(101)*vint(315)*vint(316)
30519 pm2rho=pmas(pycomp(113),1)**2
30520 IF(mstp(19).EQ.0) THEN
30521 comfac=comfac/q2ga
30522 ELSEIF(mstp(19).EQ.1) THEN
30523 comfac=comfac/(q2ga+pm2rho)
30524 ELSEIF(mstp(19).EQ.2) THEN
30525 comfac=comfac*q2ga/(q2ga+pm2rho)**2
30526 ELSE
30527 comfac=comfac*q2ga/(q2ga+pm2rho)**2
30528 w2ga=vint(2)
30529 IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN
30530 rdrds=4.1d-3*w2ga**2.167d0/((q2ga+0.15d0*w2ga)**2*
30531 & q2ga**0.75d0)*(1d0+0.11d0*q2ga*p2ga/(1d0+0.02d0*p2ga**2))
30532 xga=q2ga/(w2ga+vint(307)+vint(308))
30533 ELSE
30534 rdrds=1.5d-4*w2ga**2.167d0/((q2ga+0.041d0*w2ga)**2*
30535 & q2ga**0.57d0)
30536 xga=q2ga/(w2ga+q2ga-pmas(pycomp(mint(10+isde)),1)**2)
30537 ENDIF
30538 comfac=comfac*exp(-max(1d-10,rdrds))
30539 IF(mstp(19).EQ.4) comfac=comfac/max(1d-2,1d0-xga)
30540 ENDIF
30541 DO 390 i=mmina,mmaxa
30542 IF(i.EQ.0.OR.kfac(isde,i).EQ.0) GOTO 390
30543 IF(iabs(i).LT.10.AND.iabs(i).GT.mstp(58)) GOTO 390
30544 ei=kchg(iabs(i),1)/3d0
30545 nchn=nchn+1
30546 isig(nchn,isde)=i
30547 isig(nchn,3-isde)=22
30548 isig(nchn,3)=1
30549 sigh(nchn)=comfac*ei**2
30550 390 CONTINUE
30551 ENDIF
30552
30553 ELSE
30554 IF(isub.EQ.114.OR.isub.EQ.115) THEN
30555C...g + g -> gamma + gamma or g + g -> g + gamma
30556 a0stur=0d0
30557 a0stui=0d0
30558 a0tsur=0d0
30559 a0tsui=0d0
30560 a0utsr=0d0
30561 a0utsi=0d0
30562 a1stur=0d0
30563 a1stui=0d0
30564 a2stur=0d0
30565 a2stui=0d0
30566 alst=log(-sh/th)
30567 alsu=log(-sh/uh)
30568 altu=log(th/uh)
30569 imax=2*mstp(1)
30570 IF(mstp(38).GE.1.AND.mstp(38).LE.8) imax=mstp(38)
30571 DO 400 i=1,imax
30572 ei=kchg(iabs(i),1)/3d0
30573 eiwt=ei**2
30574 IF(isub.EQ.115) eiwt=ei
30575 sqmq=pmas(i,1)**2
30576 epss=4d0*sqmq/sh
30577 epst=4d0*sqmq/th
30578 epsu=4d0*sqmq/uh
30579 IF((mstp(38).GE.1.AND.mstp(38).LE.8).OR.epss.LT.1d-4) THEN
30580 b0stur=1d0+(th-uh)/sh*altu+0.5d0*(th2+uh2)/sh2*(altu**2+
30581 & paru(1)**2)
30582 b0stui=0d0
30583 b0tsur=1d0+(sh-uh)/th*alsu+0.5d0*(sh2+uh2)/th2*alsu**2
30584 b0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*alsu)
30585 b0utsr=1d0+(sh-th)/uh*alst+0.5d0*(sh2+th2)/uh2*alst**2
30586 b0utsi=-paru(1)*((sh-th)/uh+(sh2+th2)/uh2*alst)
30587 b1stur=-1d0
30588 b1stui=0d0
30589 b2stur=-1d0
30590 b2stui=0d0
30591 ELSE
30592 CALL pywaux(1,epss,w1sr,w1si)
30593 CALL pywaux(1,epst,w1tr,w1ti)
30594 CALL pywaux(1,epsu,w1ur,w1ui)
30595 CALL pywaux(2,epss,w2sr,w2si)
30596 CALL pywaux(2,epst,w2tr,w2ti)
30597 CALL pywaux(2,epsu,w2ur,w2ui)
30598 CALL pyi3au(epss,th/uh,y3stur,y3stui)
30599 CALL pyi3au(epss,uh/th,y3sutr,y3suti)
30600 CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
30601 CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
30602 CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
30603 CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
30604 b0stur=1d0+(1d0+2d0*th/sh)*w1tr+(1d0+2d0*uh/sh)*w1ur+
30605 & 0.5d0*((th2+uh2)/sh2-epss)*(w2tr+w2ur)-
30606 & 0.25d0*epst*(1d0-0.5d0*epss)*(y3sutr+y3tusr)-
30607 & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stur+y3utsr)+
30608 & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
30609 & 0.5d0*epst*epsu)*(y3tsur+y3ustr)
30610 b0stui=(1d0+2d0*th/sh)*w1ti+(1d0+2d0*uh/sh)*w1ui+
30611 & 0.5d0*((th2+uh2)/sh2-epss)*(w2ti+w2ui)-
30612 & 0.25d0*epst*(1d0-0.5d0*epss)*(y3suti+y3tusi)-
30613 & 0.25d0*epsu*(1d0-0.5d0*epss)*(y3stui+y3utsi)+
30614 & 0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+
30615 & 0.5d0*epst*epsu)*(y3tsui+y3usti)
30616 b0tsur=1d0+(1d0+2d0*sh/th)*w1sr+(1d0+2d0*uh/th)*w1ur+
30617 & 0.5d0*((sh2+uh2)/th2-epst)*(w2sr+w2ur)-
30618 & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusr+y3sutr)-
30619 & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsur+y3ustr)+
30620 & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
30621 & 0.5d0*epss*epsu)*(y3stur+y3utsr)
30622 b0tsui=(1d0+2d0*sh/th)*w1si+(1d0+2d0*uh/th)*w1ui+
30623 & 0.5d0*((sh2+uh2)/th2-epst)*(w2si+w2ui)-
30624 & 0.25d0*epss*(1d0-0.5d0*epst)*(y3tusi+y3suti)-
30625 & 0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsui+y3usti)+
30626 & 0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+
30627 & 0.5d0*epss*epsu)*(y3stui+y3utsi)
30628 b0utsr=1d0+(1d0+2d0*th/uh)*w1tr+(1d0+2d0*sh/uh)*w1sr+
30629 & 0.5d0*((th2+sh2)/uh2-epsu)*(w2tr+w2sr)-
30630 & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3ustr+y3tsur)-
30631 & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsr+y3stur)+
30632 & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
30633 & 0.5d0*epst*epss)*(y3tusr+y3sutr)
30634 b0utsi=(1d0+2d0*th/uh)*w1ti+(1d0+2d0*sh/uh)*w1si+
30635 & 0.5d0*((th2+sh2)/uh2-epsu)*(w2ti+w2si)-
30636 & 0.25d0*epst*(1d0-0.5d0*epsu)*(y3usti+y3tsui)-
30637 & 0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsi+y3stui)+
30638 & 0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+
30639 & 0.5d0*epst*epss)*(y3tusi+y3suti)
30640 b1stur=-1d0-0.25d0*(epss+epst+epsu)*(w2sr+w2tr+w2ur)+
30641 & 0.25d0*(epsu+0.5d0*epss*epst)*(y3sutr+y3tusr)+
30642 & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stur+y3utsr)+
30643 & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsur+y3ustr)
30644 b1stui=-0.25d0*(epss+epst+epsu)*(w2si+w2ti+w2ui)+
30645 & 0.25d0*(epsu+0.5d0*epss*epst)*(y3suti+y3tusi)+
30646 & 0.25d0*(epst+0.5d0*epss*epsu)*(y3stui+y3utsi)+
30647 & 0.25d0*(epss+0.5d0*epst*epsu)*(y3tsui+y3usti)
30648 b2stur=-1d0+0.125d0*epss*epst*(y3sutr+y3tusr)+
30649 & 0.125d0*epss*epsu*(y3stur+y3utsr)+
30650 & 0.125d0*epst*epsu*(y3tsur+y3ustr)
30651 b2stui=0.125d0*epss*epst*(y3suti+y3tusi)+
30652 & 0.125d0*epss*epsu*(y3stui+y3utsi)+
30653 & 0.125d0*epst*epsu*(y3tsui+y3usti)
30654 ENDIF
30655 a0stur=a0stur+eiwt*b0stur
30656 a0stui=a0stui+eiwt*b0stui
30657 a0tsur=a0tsur+eiwt*b0tsur
30658 a0tsui=a0tsui+eiwt*b0tsui
30659 a0utsr=a0utsr+eiwt*b0utsr
30660 a0utsi=a0utsi+eiwt*b0utsi
30661 a1stur=a1stur+eiwt*b1stur
30662 a1stui=a1stui+eiwt*b1stui
30663 a2stur=a2stur+eiwt*b2stur
30664 a2stui=a2stui+eiwt*b2stui
30665 400 CONTINUE
30666 asqsum=a0stur**2+a0stui**2+a0tsur**2+a0tsui**2+a0utsr**2+
30667 & a0utsi**2+4d0*a1stur**2+4d0*a1stui**2+a2stur**2+a2stui**2
30668 facgg=comfac*faca/(16d0*paru(1)**2)*as**2*aem**2*asqsum
30669 facgp=comfac*faca*5d0/(192d0*paru(1)**2)*as**3*aem*asqsum
30670 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 410
30671 nchn=nchn+1
30672 isig(nchn,1)=21
30673 isig(nchn,2)=21
30674 isig(nchn,3)=1
30675 IF(isub.EQ.114) sigh(nchn)=0.5d0*facgg
30676 IF(isub.EQ.115) sigh(nchn)=facgp
30677 410 CONTINUE
30678
30679 ELSEIF(isub.EQ.131.OR.isub.EQ.132) THEN
30680C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30681 ph=0d0
30682 IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
30683 & ph=vint(3)**2
30684 IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
30685 & ph=vint(4)**2
30686 IF(isub.EQ.131) THEN
30687 fgq=comfac*as*aem*8d0/3d0*sh**2/(sh+ph)**2*
30688 & ((sh2+uh2-2d0*ph*th)/(-sh*uh)-2d0*ph*th/(sh+ph)**2)
30689 ELSE
30690 fgq=comfac*as*aem*8d0/3d0*sh**2/(sh+ph)**4*(-4d0*ph*th)
30691 ENDIF
30692 DO 430 i=mmina,mmaxa
30693 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 430
30694 ei=kchg(iabs(i),1)/3d0
30695 facgq=fgq*ei**2
30696 DO 420 isde=1,2
30697 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 420
30698 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 420
30699 nchn=nchn+1
30700 isig(nchn,isde)=i
30701 isig(nchn,3-isde)=22
30702 isig(nchn,3)=1
30703 sigh(nchn)=facgq
30704 420 CONTINUE
30705 430 CONTINUE
30706
30707 ELSEIF(isub.EQ.133.OR.isub.EQ.134) THEN
30708C...f + gamma*_(T,L) -> f + gamma
30709 ph=0d0
30710 IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
30711 & ph=vint(3)**2
30712 IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
30713 & ph=vint(4)**2
30714 IF(isub.EQ.133) THEN
30715 fgq=comfac*aem**2*2d0*sh**2/(sh+ph)**2*
30716 & ((sh2+uh2-2d0*ph*th)/(-sh*uh)-2d0*ph*th/(sh+ph)**2)
30717 ELSE
30718 fgq=comfac*aem**2*2d0*sh**2/(sh+ph)**4*(-4d0*ph*th)
30719 ENDIF
30720 DO 450 i=mmina,mmaxa
30721 IF(i.EQ.0) GOTO 450
30722 ei=kchg(iabs(i),1)/3d0
30723 facgq=fgq*ei**4
30724 DO 440 isde=1,2
30725 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 440
30726 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 440
30727 nchn=nchn+1
30728 isig(nchn,isde)=i
30729 isig(nchn,3-isde)=22
30730 isig(nchn,3)=1
30731 sigh(nchn)=facgq
30732 440 CONTINUE
30733 450 CONTINUE
30734
30735 ELSEIF(isub.EQ.135.OR.isub.EQ.136) THEN
30736C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30737 ph=0d0
30738 IF(mint(15).EQ.22.AND.mint(107).EQ.0.AND.vint(3).LT.0d0)
30739 & ph=vint(3)**2
30740 IF(mint(16).EQ.22.AND.mint(108).EQ.0.AND.vint(4).LT.0d0)
30741 & ph=vint(4)**2
30742 CALL pywidt(21,sh,wdtp,wdte)
30743 wdtesu=0d0
30744 DO 460 i=1,min(8,mdcy(21,3))
30745 ef=kchg(i,1)/3d0
30746 wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30747 & wdte(i,4))
30748 460 CONTINUE
30749 IF(isub.EQ.135) THEN
30750 facqq=comfac*aem*as*wdtesu*sh**2/(sh+ph)**2*
30751 & ((th2+uh2-2d0*ph*sh)/(th*uh)+4d0*ph*sh/(sh+ph)**2)
30752 ELSE
30753 facqq=comfac*aem*as*wdtesu*sh**2/(sh+ph)**4*8d0*ph*sh
30754 ENDIF
30755 IF(kfac(1,21)*kfac(2,22).NE.0) THEN
30756 nchn=nchn+1
30757 isig(nchn,1)=21
30758 isig(nchn,2)=22
30759 isig(nchn,3)=1
30760 sigh(nchn)=facqq
30761 ENDIF
30762 IF(kfac(1,22)*kfac(2,21).NE.0) THEN
30763 nchn=nchn+1
30764 isig(nchn,1)=22
30765 isig(nchn,2)=21
30766 isig(nchn,3)=1
30767 sigh(nchn)=facqq
30768 ENDIF
30769
30770 ELSEIF(isub.GE.137.AND.isub.LE.140) THEN
30771C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30772 ph1=0d0
30773 IF(vint(3).LT.0d0) ph1=vint(3)**2
30774 ph2=0d0
30775 IF(vint(4).LT.0d0) ph2=vint(4)**2
30776 CALL pywidt(22,sh,wdtp,wdte)
30777 wdtesu=0d0
30778 DO 470 i=1,min(12,mdcy(22,3))
30779 IF(i.LE.8) ef= kchg(i,1)/3d0
30780 IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0
30781 wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+
30782 & wdte(i,4))
30783 470 CONTINUE
30784 dlamb2=(th+uh)**2-4d0*ph1*ph2
30785 IF(isub.EQ.137) THEN
30786 fparam=-sh*(th+uh)/dlamb2
30787 facff=comfac*aem**2*wdtesu*2d0*sh2/(dlamb2*th2*uh2)*
30788 & (th*uh-ph1*ph2)*((th2+uh2)*(1d0-2d0*fparam*(1d0-fparam))-
30789 & 2d0*ph1*ph2*fparam**2)
30790 ELSEIF(isub.EQ.138) THEN
30791 facff=comfac*aem**2*wdtesu*4d0*sh2*sh/(dlamb2**2*th2*uh2)*
30792 & ph2*(4d0*(th*uh-ph1*ph2)*(th*uh+ph1*sh*(th-uh)**2/dlamb2)+
30793 & 2d0*ph1**2*(th-uh)**2)
30794 ELSEIF(isub.EQ.139) THEN
30795 facff=comfac*aem**2*wdtesu*4d0*sh2*sh/(dlamb2**2*th2*uh2)*
30796 & ph1*(4d0*(th*uh-ph1*ph2)*(th*uh+ph2*sh*(th-uh)**2/dlamb2)+
30797 & 2d0*ph2**2*(th-uh)**2)
30798 ELSE
30799 facff=comfac*aem**2*wdtesu*32d0*sh2**2/(dlamb2**3*th2*uh2)*
30800 & ph1*ph2*(th*uh-ph1*ph2)*(th-uh)**2
30801 ENDIF
30802 IF(kfac(1,22)*kfac(2,22).NE.0) THEN
30803 nchn=nchn+1
30804 isig(nchn,1)=22
30805 isig(nchn,2)=22
30806 isig(nchn,3)=1
30807 sigh(nchn)=facff
30808 ENDIF
30809
30810 ENDIF
30811 ENDIF
30812
30813 RETURN
30814 END
30815
30816C*********************************************************************
30817
30818C...PYSGHF
30819C...Subprocess cross sections for heavy flavour production,
30820C...open and closed.
30821C...Auxiliary to PYSIGH.
30822
30823 SUBROUTINE pysghf(NCHN,SIGS)
30824
30825C...Double precision and integer declarations
30826 IMPLICIT DOUBLE PRECISION(a-h, o-z)
30827 IMPLICIT INTEGER(I-N)
30828 INTEGER PYK,PYCHGE,PYCOMP
30829C...Parameter statement to help give large particle numbers.
30830 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
30831 &kexcit=4000000,kdimen=5000000)
30832C...Commonblocks
30833 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
30834 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
30835 common/pypars/mstp(200),parp(200),msti(200),pari(200)
30836 common/pyint1/mint(400),vint(400)
30837 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
30838 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
30839 common/pyint4/mwid(500),wids(500,5)
30840 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
30841 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
30842 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
30843 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
30844 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
30845 &/pyint4/,/pysgcm/
30846C...Local arrays
30847 dimension wdtp(0:400),wdte(0:400,0:5)
30848
30849C...Determine where are charmonium/bottomonium wave function parameters.
30850 ionium=140
30851 IF(isub.GE.461.AND.isub.LE.479) ionium=145
30852
30853C...Convert bottomonium process into equivalent charmonium ones.
30854 IF(isub.GE.461.AND.isub.LE.479) isub=isub-40
30855
30856C...Differential cross section expressions.
30857
30858 IF(isub.LE.100) THEN
30859 IF(isub.EQ.81) THEN
30860C...q + qbar -> Q + Qbar
30861 sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
30862 thq=-0.5d0*sh*(1d0-be34*cth)
30863 uhq=-0.5d0*sh*(1d0+be34*cth)
30864 facqqb=comfac*as**2*4d0/9d0*((thq**2+uhq**2)/sh2+
30865 & 2d0*sqmavg/sh)
30866 IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqmavg,0d0)
30867 wid2=1d0
30868 IF(mint(55).EQ.6) wid2=wids(6,1)
30869 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
30870 facqqb=facqqb*wid2
30871 DO 100 i=mmina,mmaxa
30872 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
30873 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 100
30874 nchn=nchn+1
30875 isig(nchn,1)=i
30876 isig(nchn,2)=-i
30877 isig(nchn,3)=1
30878 sigh(nchn)=facqqb
30879 100 CONTINUE
30880
30881 ELSEIF(isub.EQ.82) THEN
30882C...g + g -> Q + Qbar
30883 sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
30884 thq=-0.5d0*sh*(1d0-be34*cth)
30885 uhq=-0.5d0*sh*(1d0+be34*cth)
30886 thuhq=thq*uhq-sqmavg*sh
30887 IF(mstp(34).EQ.0) THEN
30888 facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
30889 facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
30890 ELSE
30891 facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30892 & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
30893 facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
30894 & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
30895 ENDIF
30896 facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1
30897 facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2
30898 IF(mstp(35).GE.1) THEN
30899 fatre=pyhfth(sh,sqmavg,2d0/7d0)
30900 facqq1=facqq1*fatre
30901 facqq2=facqq2*fatre
30902 ENDIF
30903 wid2=1d0
30904 IF(mint(55).EQ.6) wid2=wids(6,1)
30905 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
30906 facqq1=facqq1*wid2
30907 facqq2=facqq2*wid2
30908 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 110
30909 nchn=nchn+1
30910 isig(nchn,1)=21
30911 isig(nchn,2)=21
30912 isig(nchn,3)=1
30913 sigh(nchn)=facqq1
30914 nchn=nchn+1
30915 isig(nchn,1)=21
30916 isig(nchn,2)=21
30917 isig(nchn,3)=2
30918 sigh(nchn)=facqq2
30919 110 CONTINUE
30920
30921 ELSEIF(isub.EQ.83) THEN
30922C...f + q -> f' + Q
30923 facqqs=comfac*(0.5d0*aem/xw)**2*sh*(sh-sqm3)/(sqmw-th)**2
30924 facqqu=comfac*(0.5d0*aem/xw)**2*uh*(uh-sqm3)/(sqmw-th)**2
30925 DO 130 i=mmin1,mmax1
30926 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 130
30927 DO 120 j=mmin2,mmax2
30928 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 120
30929 IF(i*j.GT.0.AND.mod(iabs(i+j),2).EQ.0) GOTO 120
30930 IF(i*j.LT.0.AND.mod(iabs(i+j),2).EQ.1) GOTO 120
30931 IF(iabs(i).LT.mint(55).AND.mod(iabs(i+mint(55)),2).EQ.1)
30932 & THEN
30933 nchn=nchn+1
30934 isig(nchn,1)=i
30935 isig(nchn,2)=j
30936 isig(nchn,3)=1
30937 IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
30938 & (iabs(i)+1)/2)*vint(180+j)
30939 IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(i)/2,
30940 & (mint(55)+1)/2)*vint(180+j)
30941 wid2=1d0
30942 IF(i.GT.0) THEN
30943 IF(mint(55).EQ.6) wid2=wids(6,2)
30944 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
30945 & wids(mint(55),2)
30946 ELSE
30947 IF(mint(55).EQ.6) wid2=wids(6,3)
30948 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
30949 & wids(mint(55),3)
30950 ENDIF
30951 IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
30952 IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
30953 ENDIF
30954 IF(iabs(j).LT.mint(55).AND.mod(iabs(j+mint(55)),2).EQ.1)
30955 & THEN
30956 nchn=nchn+1
30957 isig(nchn,1)=i
30958 isig(nchn,2)=j
30959 isig(nchn,3)=2
30960 IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,
30961 & (iabs(j)+1)/2)*vint(180+i)
30962 IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(j)/2,
30963 & (mint(55)+1)/2)*vint(180+i)
30964 wid2=1d0
30965 IF(j.GT.0) THEN
30966 IF(mint(55).EQ.6) wid2=wids(6,2)
30967 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
30968 & wids(mint(55),2)
30969 ELSE
30970 IF(mint(55).EQ.6) wid2=wids(6,3)
30971 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=
30972 & wids(mint(55),3)
30973 ENDIF
30974 IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2
30975 IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2
30976 ENDIF
30977 120 CONTINUE
30978 130 CONTINUE
30979
30980 ELSEIF(isub.EQ.84) THEN
30981C...g + gamma -> Q + Qbar
30982 sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
30983 thq=-0.5d0*sh*(1d0-be34*cth)
30984 uhq=-0.5d0*sh*(1d0+be34*cth)
30985 facqq=comfac*as*aem*(kchg(iabs(mint(55)),1)/3d0)**2*
30986 & (thq**2+uhq**2+4d0*sqmavg*sh*(1d0-sqmavg*sh/(thq*uhq)))/
30987 & (thq*uhq)
30988 IF(mstp(35).GE.1) facqq=facqq*pyhfth(sh,sqmavg,0d0)
30989 wid2=1d0
30990 IF(mint(55).EQ.6) wid2=wids(6,1)
30991 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
30992 facqq=facqq*wid2
30993 IF(kfac(1,21)*kfac(2,22).NE.0) THEN
30994 nchn=nchn+1
30995 isig(nchn,1)=21
30996 isig(nchn,2)=22
30997 isig(nchn,3)=1
30998 sigh(nchn)=facqq
30999 ENDIF
31000 IF(kfac(1,22)*kfac(2,21).NE.0) THEN
31001 nchn=nchn+1
31002 isig(nchn,1)=22
31003 isig(nchn,2)=21
31004 isig(nchn,3)=1
31005 sigh(nchn)=facqq
31006 ENDIF
31007
31008 ELSEIF(isub.EQ.85) THEN
31009C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31010 sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
31011 thq=-0.5d0*sh*(1d0-be34*cth)
31012 uhq=-0.5d0*sh*(1d0+be34*cth)
31013 facff=comfac*aem**2*(kchg(iabs(mint(56)),1)/3d0)**4*2d0*
31014 & ((1d0-parj(131)*parj(132))*(thq*uhq-sqmavg*sh)*
31015 & (uhq**2+thq**2+2d0*sqmavg*sh)+(1d0+parj(131)*parj(132))*
31016 & sqmavg*sh**2*(sh-2d0*sqmavg))/(thq*uhq)**2
31017 IF(iabs(mint(56)).LT.10) facff=3d0*facff
31018 IF(iabs(mint(56)).LT.10.AND.mstp(35).GE.1)
31019 & facff=facff*pyhfth(sh,sqmavg,1d0)
31020 wid2=1d0
31021 IF(mint(56).EQ.6) wid2=wids(6,1)
31022 IF(mint(56).EQ.7.OR.mint(56).EQ.8) wid2=wids(mint(56),1)
31023 IF(mint(56).EQ.17) wid2=wids(17,1)
31024 facff=facff*wid2
31025 IF(kfac(1,22)*kfac(2,22).NE.0) THEN
31026 nchn=nchn+1
31027 isig(nchn,1)=22
31028 isig(nchn,2)=22
31029 isig(nchn,3)=1
31030 sigh(nchn)=facff
31031 ENDIF
31032
31033 ELSEIF(isub.EQ.86) THEN
31034C...g + g -> J/Psi + g
31035 facqqg=comfac*as**3*(5d0/9d0)*parp(38)*sqrt(sqm3)*
31036 & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31037 & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31038 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31039 nchn=nchn+1
31040 isig(nchn,1)=21
31041 isig(nchn,2)=21
31042 isig(nchn,3)=1
31043 sigh(nchn)=facqqg
31044 ENDIF
31045
31046 ELSEIF(isub.EQ.87) THEN
31047C...g + g -> chi_0c + g
31048 pgtw=(sh*th+th*uh+uh*sh)/sh2
31049 qgtw=(sh*th*uh)/sh**3
31050 rgtw=sqm3/sh
31051 facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31052 & (9d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
31053 & 6d0*rgtw*pgtw**3*qgtw*(2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)-
31054 & pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)+
31055 & 2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)+6d0*rgtw**2*qgtw**4)/
31056 & (qgtw*(qgtw-rgtw*pgtw)**4)
31057 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31058 nchn=nchn+1
31059 isig(nchn,1)=21
31060 isig(nchn,2)=21
31061 isig(nchn,3)=1
31062 sigh(nchn)=facqqg
31063 ENDIF
31064
31065 ELSEIF(isub.EQ.88) THEN
31066C...g + g -> chi_1c + g
31067 pgtw=(sh*th+th*uh+uh*sh)/sh2
31068 qgtw=(sh*th*uh)/sh**3
31069 rgtw=sqm3/sh
31070 facqqg=comfac*as**3*12d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31071 & pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)+2d0*qgtw*(-rgtw**4+
31072 & 5d0*rgtw**2*pgtw+pgtw**2)-15d0*rgtw*qgtw**2)/
31073 & (qgtw-rgtw*pgtw)**4
31074 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31075 nchn=nchn+1
31076 isig(nchn,1)=21
31077 isig(nchn,2)=21
31078 isig(nchn,3)=1
31079 sigh(nchn)=facqqg
31080 ENDIF
31081
31082 ELSEIF(isub.EQ.89) THEN
31083C...g + g -> chi_2c + g
31084 pgtw=(sh*th+th*uh+uh*sh)/sh2
31085 qgtw=(sh*th*uh)/sh**3
31086 rgtw=sqm3/sh
31087 facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*
31088 & (12d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-
31089 & 3d0*rgtw*pgtw**3*qgtw*(8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)+
31090 & 2d0*pgtw**2*qgtw**2*(-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)+
31091 & rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)+12d0*rgtw**2*
31092 & qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
31093 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31094 nchn=nchn+1
31095 isig(nchn,1)=21
31096 isig(nchn,2)=21
31097 isig(nchn,3)=1
31098 sigh(nchn)=facqqg
31099 ENDIF
31100 ENDIF
31101
31102 ELSEIF(isub.LE.200) THEN
31103 IF(isub.EQ.104) THEN
31104C...g + g -> chi_c0.
31105 kc=pycomp(10441)
31106 facbw=comfac*12d0*as**2*parp(39)*pmas(kc,2)/
31107 & ((sh-pmas(kc,1)**2)**2+(pmas(kc,1)*pmas(kc,2))**2)
31108 IF(abs(sqrt(sh)-pmas(kc,1)).GT.50d0*pmas(kc,2)) facbw=0d0
31109 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31110 nchn=nchn+1
31111 isig(nchn,1)=21
31112 isig(nchn,2)=21
31113 isig(nchn,3)=1
31114 sigh(nchn)=facbw
31115 ENDIF
31116
31117 ELSEIF(isub.EQ.105) THEN
31118C...g + g -> chi_c2.
31119 kc=pycomp(445)
31120 facbw=comfac*16d0*as**2*parp(39)*pmas(kc,2)/
31121 & ((sh-pmas(kc,1)**2)**2+(pmas(kc,1)*pmas(kc,2))**2)
31122 IF(abs(sqrt(sh)-pmas(kc,1)).GT.50d0*pmas(kc,2)) facbw=0d0
31123 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31124 nchn=nchn+1
31125 isig(nchn,1)=21
31126 isig(nchn,2)=21
31127 isig(nchn,3)=1
31128 sigh(nchn)=facbw
31129 ENDIF
31130
31131 ELSEIF(isub.EQ.106) THEN
31132C...g + g -> J/Psi + gamma.
31133 eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31134 facqqg=comfac*aem*eq**2*as**2*(4d0/3d0)*parp(38)*sqrt(sqm3)*
31135 & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31136 & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31137 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31138 nchn=nchn+1
31139 isig(nchn,1)=21
31140 isig(nchn,2)=21
31141 isig(nchn,3)=1
31142 sigh(nchn)=facqqg
31143 ENDIF
31144
31145 ELSEIF(isub.EQ.107) THEN
31146C...g + gamma -> J/Psi + g.
31147 eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31148 facqqg=comfac*aem*eq**2*as**2*(32d0/3d0)*parp(38)*sqrt(sqm3)*
31149 & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31150 & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31151 IF(kfac(1,21)*kfac(2,22).NE.0) THEN
31152 nchn=nchn+1
31153 isig(nchn,1)=21
31154 isig(nchn,2)=22
31155 isig(nchn,3)=1
31156 sigh(nchn)=facqqg
31157 ENDIF
31158 IF(kfac(1,22)*kfac(2,21).NE.0) THEN
31159 nchn=nchn+1
31160 isig(nchn,1)=22
31161 isig(nchn,2)=21
31162 isig(nchn,3)=1
31163 sigh(nchn)=facqqg
31164 ENDIF
31165
31166 ELSEIF(isub.EQ.108) THEN
31167C...gamma + gamma -> J/Psi + gamma.
31168 eq=kchg(mod(kfpr(isub,1)/10,10),1)/3d0
31169 facqqg=comfac*aem**3*eq**6*384d0*parp(38)*sqrt(sqm3)*
31170 & (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/
31171 & ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2
31172 IF(kfac(1,22)*kfac(2,22).NE.0) THEN
31173 nchn=nchn+1
31174 isig(nchn,1)=22
31175 isig(nchn,2)=22
31176 isig(nchn,3)=1
31177 sigh(nchn)=facqqg
31178 ENDIF
31179 ENDIF
31180
31181C...QUARKONIA+++
31182C...Additional code by Stefan Wolf
31183 ELSE
31184
31185C...Common code for quarkonium production.
31186 shth=sh+th
31187 thuh=th+uh
31188 uhsh=uh+sh
31189 shth2=shth**2
31190 thuh2=thuh**2
31191 uhsh2=uhsh**2
31192 IF ( (isub.GE.421.AND.isub.LE.424).OR.
31193 & (isub.GE.431.AND.isub.LE.433)) THEN
31194 sqmqq=sqm3
31195 ELSEIF((isub.GE.425.AND.isub.LE.430).OR.
31196 & (isub.GE.434.AND.isub.LE.439)) THEN
31197 sqmqq=sqm4
31198 ENDIF
31199 sqmqqr=sqrt(sqmqq)
31200 IF(mstp(145).EQ.1) THEN
31201 IF ( (isub.GE.421.AND.isub.LE.427).OR.
31202 & (isub.GE.431.AND.isub.LE.436)) THEN
31203 aq=uhsh/(2d0*x(1)) + shth/(2d0*x(2))
31204 bq=uhsh/(2d0*x(1)) - shth/(2d0*x(2))
31205 atilk1=x(1)*vint(2)/2d0-uhsh/(2d0*sqmqq)*aq
31206 atilk2=x(2)*vint(2)/2d0-shth/(2d0*sqmqq)*aq
31207 btilk1=-x(1)*vint(2)/2d0-uhsh/(2d0*sqmqq)*bq
31208 btilk2=x(2)*vint(2)/2d0-shth/(2d0*sqmqq)*bq
31209 ELSEIF( (isub.GE.428.AND.isub.LE.430).OR.
31210 & isub.GE.437) THEN
31211 aq=shth/(2d0*x(1)) + uhsh/(2d0*x(2))
31212 bq=shth/(2d0*x(1)) - uhsh/(2d0*x(2))
31213 atilk1=x(1)*vint(2)/2d0-shth/(2d0*sqmqq)*aq
31214 atilk2=x(2)*vint(2)/2d0-uhsh/(2d0*sqmqq)*aq
31215 btilk1=-x(1)*vint(2)/2d0-shth/(2d0*sqmqq)*bq
31216 btilk2=x(2)*vint(2)/2d0-uhsh/(2d0*sqmqq)*bq
31217 ENDIF
31218 aq2=aq**2
31219 bq2=bq**2
31220 smqq2=sqmqq*vint(2)
31221C...Polarisation frames
31222 IF(mstp(146).EQ.1) THEN
31223C...Recoil frame
31224 polh1=sqrt(aq2-smqq2)
31225 polh2=sqrt(vint(2)*(aq2-bq2-smqq2))
31226 az=-sqmqqr/polh1
31227 bz=0d0
31228 ax=aq*bq/(polh1*polh2)
31229 bx=-polh1/polh2
31230 ELSEIF(mstp(146).EQ.2) THEN
31231C...Gottfried Jackson frame
31232 polh1=aq+bq
31233 polh2=polh1*sqrt(vint(2)*(aq2-bq2-smqq2))
31234 az=sqmqqr/polh1
31235 bz=az
31236 ax=-(bq2+aq*bq+smqq2)/polh2
31237 bx=(aq2+aq*bq-smqq2)/polh2
31238 ELSEIF(mstp(146).EQ.3) THEN
31239C...Target frame
31240 polh1=aq-bq
31241 polh2=polh1*sqrt(vint(2)*(aq2-bq2-smqq2))
31242 az=-sqmqqr/polh1
31243 bz=-az
31244 ax=-(bq2-aq*bq+smqq2)/polh2
31245 bx=-(aq2-aq*bq-smqq2)/polh2
31246 ELSEIF(mstp(146).EQ.4) THEN
31247C...Collins Soper frame
31248 polh1=aq2-bq2
31249 polh2=sqrt(vint(2)*polh1)
31250 az=-bq/polh2
31251 bz=aq/polh2
31252 ax=-sqmqqr*aq/sqrt(polh1*(polh1-smqq2))
31253 bx=sqmqqr*bq/sqrt(polh1*(polh1-smqq2))
31254 ENDIF
31255C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31256 el1k10=az*atilk1+bz*btilk1
31257 el1k20=az*atilk2+bz*btilk2
31258 el2k10=el1k10
31259 el2k20=el1k20
31260 el1k11=1d0/sqrt(2d0)*(ax*atilk1+bx*btilk1)
31261 el1k21=1d0/sqrt(2d0)*(ax*atilk2+bx*btilk2)
31262 el2k11=el1k11
31263 el2k21=el1k21
31264 ENDIF
31265
31266 IF(isub.EQ.421) THEN
31267C...g + g -> QQ~[3S11] + g
31268 IF(mstp(145).EQ.0) THEN
31269* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31270* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
31271 facqqg=comfac*paru(1)*as**3*(10d0/81d0)*sqmqqr*
31272 & (sh2*thuh2+th2*uhsh2+uh2*shth2)/shth2/thuh2/uhsh2
31273* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31274* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31275 ELSE
31276 ff=-paru(1)*as**3*(10d0/81d0)*sqmqqr/thuh2/shth2/uhsh2
31277 aa=(shth2*uh2+uhsh2*th2+thuh2*sh2)/2d0
31278 bb=2d0*(sh2+th2)
31279 cc=2d0*(sh2+uh2)
31280 dd=2d0*sh2
31281 IF(mstp(147).EQ.0) THEN
31282 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31283 & +dd*(el1k10*el2k20+el1k20*el2k10))
31284 ELSEIF(mstp(147).EQ.1) THEN
31285 facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31286 & +dd*(el1k11*el2k21+el1k21*el2k11)))
31287 ELSEIF(mstp(147).EQ.3) THEN
31288 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31289 & +dd*(el1k10*el2k20+el1k20*el2k10))
31290 ELSEIF(mstp(147).EQ.4) THEN
31291 facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31292 & +dd*(el1k11*el2k21+el1k21*el2k11))
31293 ELSEIF(mstp(147).EQ.5) THEN
31294 facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31295 & +dd*(el1k11*el2k20+el1k21*el2k10))
31296 ELSEIF(mstp(147).EQ.6) THEN
31297 facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31298 & +dd*(el1k11*el2k21+el1k21*el2k11))
31299 ENDIF
31300 facqqg=comfac*ff*facqqg
31301 ENDIF
31302 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31303 nchn=nchn+1
31304 isig(nchn,1)=21
31305 isig(nchn,2)=21
31306 isig(nchn,3)=1
31307 sigh(nchn)=facqqg*parp(ionium+1)
31308 ENDIF
31309
31310 ELSEIF(isub.EQ.422) THEN
31311C...g + g -> QQ~[3S18] + g
31312 IF(mstp(145).EQ.0) THEN
31313 facqqg=-comfac*paru(1)*as**3*(1d0/72d0)*
31314 & (16d0*sqmqq**2-27d0*(shth2+thuh2+uhsh2))/
31315 & (sqmqq*sqmqqr)*
31316 & ((sh2*thuh2+th2*uhsh2+uh2*shth2)/shth2/thuh2/uhsh2)
31317 ELSE
31318 ff=paru(1)*as**3*(16d0*sqmqq**2-27d0*(shth2+thuh2+uhsh2))/
31319 & (72d0*sqmqq*sqmqqr*shth2*thuh2*uhsh2)
31320 aa=(shth2*uh2+uhsh2*th2+thuh2*sh2)/2d0
31321 bb=2d0*(sh2+th2)
31322 cc=2d0*(sh2+uh2)
31323 dd=2d0*sh2
31324 IF(mstp(147).EQ.0) THEN
31325 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31326 & +dd*(el1k10*el2k20+el1k20*el2k10))
31327 ELSEIF(mstp(147).EQ.1) THEN
31328 facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31329 & +dd*(el1k11*el2k21+el1k21*el2k11)))
31330 ELSEIF(mstp(147).EQ.3) THEN
31331 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31332 & +dd*(el1k10*el2k20+el1k20*el2k10))
31333 ELSEIF(mstp(147).EQ.4) THEN
31334 facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31335 & +dd*(el1k11*el2k21+el1k21*el2k11))
31336 ELSEIF(mstp(147).EQ.5) THEN
31337 facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31338 & +dd*(el1k11*el2k20+el1k21*el2k10))
31339 ELSEIF(mstp(147).EQ.6) THEN
31340 facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31341 & +dd*(el1k11*el2k21+el1k21*el2k11))
31342 ENDIF
31343 facqqg=comfac*ff*facqqg
31344 ENDIF
31345C...Split total contribution into different colour flows just like
31346C...in g g -> g g (recalculate kinematics for massless partons).
31347 thp=-0.5d0*sh*(1d0-cth)
31348 uhp=-0.5d0*sh*(1d0+cth)
31349 facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
31350 facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
31351 facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
31352 facggs=facgg1+facgg2+facgg3
31353 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31354 nchn=nchn+1
31355 isig(nchn,1)=21
31356 isig(nchn,2)=21
31357 isig(nchn,3)=1
31358 sigh(nchn)=facqqg*parp(ionium+2)*facgg1/facggs
31359 nchn=nchn+1
31360 isig(nchn,1)=21
31361 isig(nchn,2)=21
31362 isig(nchn,3)=2
31363 sigh(nchn)=facqqg*parp(ionium+2)*facgg2/facggs
31364 nchn=nchn+1
31365 isig(nchn,1)=21
31366 isig(nchn,2)=21
31367 isig(nchn,3)=3
31368 sigh(nchn)=facqqg*parp(ionium+2)*facgg3/facggs
31369 ENDIF
31370
31371 ELSEIF(isub.EQ.423) THEN
31372C...g + g -> QQ~[1S08] + g
31373 IF(mstp(145).EQ.0) THEN
31374* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31375* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31376* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31377* & (SHTH2*THUH2*UHSH2)
31378 facqqg=comfac*paru(1)*as**3*(5d0/16d0)*sqmqqr*
31379 & (uh2/(thuh2*uhsh2)+sh2/(shth2*uhsh2)+
31380 & th2/(shth2*thuh2))*
31381 & (12d0+(shth2**2+thuh2**2+uhsh2**2)/(sqmqq*sh*th*uh))
31382 ELSE
31383 fa=paru(1)*as**3*(5d0/48d0)*sqmqqr*
31384 & (uh2/(thuh2*uhsh2)+sh2/(shth2*uhsh2)+
31385 & th2/(shth2*thuh2))*
31386 & (12d0+(shth2**2+thuh2**2+uhsh2**2)/(sqmqq*sh*th*uh))
31387 IF(mstp(147).EQ.0) THEN
31388 facqqg=comfac*fa
31389 ELSEIF(mstp(147).EQ.1) THEN
31390 facqqg=comfac*2d0*fa
31391 ELSEIF(mstp(147).EQ.3) THEN
31392 facqqg=comfac*fa
31393 ELSEIF(mstp(147).EQ.4) THEN
31394 facqqg=comfac*fa
31395 ELSEIF(mstp(147).EQ.5) THEN
31396 facqqg=0d0
31397 ELSEIF(mstp(147).EQ.6) THEN
31398 facqqg=0d0
31399 ENDIF
31400 ENDIF
31401C...Split total contribution into different colour flows just like
31402C...in g g -> g g (recalculate kinematics for massless partons).
31403 thp=-0.5d0*sh*(1d0-cth)
31404 uhp=-0.5d0*sh*(1d0+cth)
31405 facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
31406 facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
31407 facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
31408 facggs=facgg1+facgg2+facgg3
31409 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31410 nchn=nchn+1
31411 isig(nchn,1)=21
31412 isig(nchn,2)=21
31413 isig(nchn,3)=1
31414 sigh(nchn)=facqqg*parp(ionium+3)*facgg1/facggs
31415 nchn=nchn+1
31416 isig(nchn,1)=21
31417 isig(nchn,2)=21
31418 isig(nchn,3)=2
31419 sigh(nchn)=facqqg*parp(ionium+3)*facgg2/facggs
31420 nchn=nchn+1
31421 isig(nchn,1)=21
31422 isig(nchn,2)=21
31423 isig(nchn,3)=3
31424 sigh(nchn)=facqqg*parp(ionium+3)*facgg3/facggs
31425 ENDIF
31426
31427 ELSEIF(isub.EQ.424) THEN
31428C...g + g -> QQ~[3PJ8] + g
31429 poly=sh2+sh*th+th2
31430 IF(mstp(145).EQ.0) THEN
31431 facqqg=comfac*5d0*paru(1)*as**3*(3d0*sh*th*shth*poly**4
31432 & -sqmqq*poly**2*(7d0*sh**6+36d0*sh**5*th+45d0*sh**4*th2
31433 & +28d0*sh**3*th**3+45d0*sh2*th**4+36d0*sh*th**5
31434 & +7d0*th**6)
31435 & +sqmqq**2*shth*(35d0*sh**8+169d0*sh**7*th
31436 & +299d0*sh**6*th2+401d0*sh**5*th**3+418d0*sh**4*th**4
31437 & +401d0*sh**3*th**5+299d0*sh2*th**6+169d0*sh*th**7
31438 & +35d0*th**8)
31439 & -sqmqq**3*(84d0*sh**8+432d0*sh**7*th+905d0*sh**6*th2
31440 & +1287d0*sh**5*th**3+1436d0*sh**4*th**4
31441 & +1287d0*sh**3*th**5+905d0*sh2*th**6+432d0*sh*th**7
31442 & +84d0*th**8)
31443 & +sqmqq**4*shth*(126d0*sh**6+451d0*sh**5*th
31444 & +677d0*sh**4*th2+836d0*sh**3*th**3+677d0*sh2*th**4
31445 & +451d0*sh*th**5+126d0*th**6)
31446 & -3d0*sqmqq**5*(42d0*sh**6+171d0*sh**5*th
31447 & +304d0*sh**4*th2+362d0*sh**3*th**3+304d0*sh2*th**4
31448 & +171d0*sh*th**5+42d0*th**6)
31449 & +2d0*sqmqq**6*shth*(42d0*sh**4+106d0*sh**3*th
31450 & +119d0*sh2*th2+106d0*sh*th**3+42d0*th**4)
31451 & -sqmqq**7*(35d0*sh**4+99d0*sh**3*th+120d0*sh2*th2
31452 & +99d0*sh*th**3+35d0*th**4)
31453 & +7d0*sqmqq**8*shth*poly)/
31454 & (sh*th*uh*sqmqqr*sqmqq*
31455 & shth*shth2*thuh*thuh2*uhsh*uhsh2)
31456 ELSE
31457 ff=-5d0*paru(1)*as**3/(sh2*th2*uh2
31458 & *sqmqqr*sqmqq*shth*shth2*thuh*thuh2*uhsh*uhsh2)
31459 aa=sh*th*uh*(sh*th*shth*poly**4
31460 & -sqmqq*shth2*poly**2*
31461 & (sh**4+6d0*sh**3*th-6d0*sh2*th2+6d0*sh*th**3+th**4)
31462 & +sqmqq**2*shth*(5d0*sh**8+35d0*sh**7*th+49d0*sh**6*th2
31463 & +57d0*sh**5*th**3+46d0*sh**4*th**4+57d0*sh**3*th**5
31464 & +49d0*sh2*th**6+35d0*sh*th**7+5d0*th**8)
31465 & -sqmqq**3*(16d0*sh**8+104d0*sh**7*th+215d0*sh**6*th2
31466 & +291d0*sh**5*th**3+316d0*sh**4*th**4+291d0*sh**3*th**5
31467 & +215d0*sh2*th**6+104d0*sh*th**7+16d0*th**8)
31468 & +sqmqq**4*shth*(34d0*sh**6+145d0*sh**5*th
31469 & +211d0*sh**4*th2+262d0*sh**3*th**3+211d0*sh2*th**4
31470 & +145d0*sh*th**5+34d0*th**6)
31471 & -sqmqq**5*(44d0*sh**6+193d0*sh**5*th+346d0*sh**4*th2
31472 & +410d0*sh**3*th**3+346d0*sh2*th**4+193d0*sh*th**5
31473 & +44d0*th**6)
31474 & +2d0*sqmqq**6*shth*(17d0*sh**4+45d0*sh**3*th
31475 & +49d0*sh2*th2+45d0*sh*th**3+17d0*th**4)
31476 & -sqmqq**7*(3d0*sh2+2d0*sh*th+3d0*th2)
31477 & *(5d0*sh2+11d0*sh*th+5d0*th2)
31478 & +3d0*sqmqq**8*shth*poly)
31479 bb=4d0*shth2*poly**3
31480 & *(sh**4+sh**3*th-sh2*th2+sh*th**3+th**4)
31481 & -sqmqq*shth*(20d0*sh**10+84d0*sh**9*th+166d0*sh**8*th2
31482 & +231d0*sh**7*th**3+250d0*sh**6*th**4+250d0*sh**5*th**5
31483 & +250d0*sh**4*th**6+231d0*sh**3*th**7+166d0*sh2*th**8
31484 & +84d0*sh*th**9+20d0*th**10)
31485 & +sqmqq**2*shth2*(40d0*sh**8+86d0*sh**7*th
31486 & +66d0*sh**6*th2+67d0*sh**5*th**3+6d0*sh**4*th**4
31487 & +67d0*sh**3*th**5+66d0*sh2*th**6+86d0*sh*th**7
31488 & +40d0*th**8)
31489 & -sqmqq**3*shth*(40d0*sh**8+57d0*sh**7*th
31490 & -110d0*sh**6*th2-263d0*sh**5*th**3-384d0*sh**4*th**4
31491 & -263d0*sh**3*th**5-110d0*sh2*th**6+57d0*sh*th**7
31492 & +40d0*th**8)
31493 & +sqmqq**4*(20d0*sh**8-33d0*sh**7*th-368d0*sh**6*th2
31494 & -751d0*sh**5*th**3-920d0*sh**4*th**4-751d0*sh**3*th**5
31495 & -368d0*sh2*th**6-33d0*sh*th**7+20d0*th**8)
31496 & -sqmqq**5*shth*(4d0*sh**6-81d0*sh**5*th-242d0*sh**4*th2
31497 & -250d0*sh**3*th**3-242d0*sh2*th**4-81d0*sh*th**5
31498 & +4d0*th**6)
31499 & -sqmqq**6*sh*th*(41d0*sh**4+120d0*sh**3*th
31500 & +142d0*sh2*th2+120d0*sh*th**3+41d0*th**4)
31501 & +8d0*sqmqq**7*sh*th*shth*poly
31502 cc=4d0*th2*poly**3
31503 & *(-sh**4-2d0*sh**3*th+2d0*sh2*th2+3d0*sh*th**3+th**4)
31504 & -sqmqq*th2*(-20d0*sh**9-56d0*sh**8*th-24d0*sh**7*th2
31505 & +147d0*sh**6*th**3+409d0*sh**5*th**4+599d0*sh**4*th**5
31506 & +571d0*sh**3*th**6+370d0*sh2*th**7+148d0*sh*th**8
31507 & +28d0*th**9)
31508 & +sqmqq**2*(4d0*sh**10+20d0*sh**9*th-16d0*sh**8*th2
31509 & -48d0*sh**7*th**3+150d0*sh**6*th**4+611d0*sh**5*th**5
31510 & +1060d0*sh**4*th**6+1155d0*sh**3*th**7+854d0*sh2*th**8
31511 & +394d0*sh*th**9+84d0*th**10)
31512 & -sqmqq**3*shth*(20d0*sh**8+68d0*sh**7*th-20d0*sh**6*th2
31513 & +32d0*sh**5*th**3+286d0*sh**4*th**4+577d0*sh**3*th**5
31514 & +618d0*sh2*th**6+443d0*sh*th**7+140d0*th**8)
31515 & +sqmqq**4*(40d0*sh**8+152d0*sh**7*th+94d0*sh**6*th2
31516 & +38d0*sh**5*th**3+290d0*sh**4*th**4+631d0*sh**3*th**5
31517 & +738d0*sh2*th**6+513d0*sh*th**7+140d0*th**8)
31518 & -sqmqq**5*(40d0*sh**7+129d0*sh**6*th+53d0*sh**5*th2
31519 & +7d0*sh**4*th**3+129d0*sh**3*th**4+264d0*sh2*th**5
31520 & +266d0*sh*th**6+84d0*th**7)
31521 & +sqmqq**6*(20d0*sh**6+55d0*sh**5*th+2d0*sh**4*th2
31522 & -15d0*sh**3*th**3+30d0*sh2*th**4+76d0*sh*th**5
31523 & +28d0*th**6)
31524 & -sqmqq**7*shth*(4d0*sh**4+7d0*sh**3*th-14d0*sh2*th2
31525 & +7d0*sh*th**3+4*th**4)
31526 & +sqmqq**8*sh*(sh-th)**2*th
31527 dd=2d0*th2*shth2*poly**3
31528 & *(-sh2+2*sh*th+2*th2)
31529 & +sqmqq*(4d0*sh**11+22d0*sh**10*th+70d0*sh**9*th2
31530 & +115d0*sh**8*th**3+71d0*sh**7*th**4-119d0*sh**6*th**5
31531 & -381d0*sh**5*th**6-552d0*sh**4*th**7-512d0*sh**3*th**8
31532 & -320d0*sh2*th**9-126d0*sh*th**10-24d0*th**11)
31533 & -sqmqq**2*shth*(20d0*sh**9+84d0*sh**8*th
31534 & +212d0*sh**7*th2+247d0*sh**6*th**3+105d0*sh**5*th**4
31535 & -178d0*sh**4*th**5-380d0*sh**3*th**6-364d0*sh2*th**7
31536 & -210d0*sh*th**8-60d0*th**9)
31537 & +sqmqq**3*shth*(40d0*sh**8+159d0*sh**7*th
31538 & +374d0*sh**6*th2+404d0*sh**5*th**3+192d0*sh**4*th**4
31539 & -141d0*sh**3*th**5-264d0*sh2*th**6-216d0*sh*th**7
31540 & -80d0*th**8)
31541 & -sqmqq**4*(40d0*sh**8+197d0*sh**7*th+506d0*sh**6*th2
31542 & +672d0*sh**5*th**3+460d0*sh**4*th**4+79d0*sh**3*th**5
31543 & -138d0*sh2*th**6-164d0*sh*th**7-60d0*th**8)
31544 & +sqmqq**5*(20d0*sh**7+107d0*sh**6*th+267d0*sh**5*th2
31545 & +307d0*sh**4*th**3+185d0*sh**3*th**4+56d0*sh2*th**5
31546 & -30d0*sh*th**6-24d0*th**7)
31547 & -sqmqq**6*(4d0*sh**6+31d0*sh**5*th+74d0*sh**4*th2
31548 & +71d0*sh**3*th**3+46d0*sh2*th**4+10d0*sh*th**5
31549 & -4d0*th**6)
31550 & +4d0*sqmqq**7*sh*th*shth*poly
31551 IF(mstp(147).EQ.0) THEN
31552 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31553 & +dd*(el1k10*el2k20+el1k20*el2k10))
31554 ELSEIF(mstp(147).EQ.1) THEN
31555 facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31556 & +dd*(el1k11*el2k21+el1k21*el2k11)))
31557 ELSEIF(mstp(147).EQ.3) THEN
31558 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31559 & +dd*(el1k10*el2k20+el1k20*el2k10))
31560 ELSEIF(mstp(147).EQ.4) THEN
31561 facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31562 & +dd*(el1k11*el2k21+el1k21*el2k11))
31563 ELSEIF(mstp(147).EQ.5) THEN
31564 facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31565 & +dd*(el1k11*el2k20+el1k21*el2k10))
31566 ELSEIF(mstp(147).EQ.6) THEN
31567 facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31568 & +dd*(el1k11*el2k21+el1k21*el2k11))
31569 ENDIF
31570 facqqg=comfac*ff*facqqg
31571 ENDIF
31572C...Split total contribution into different colour flows just like
31573C...in g g -> g g (recalculate kinematics for massless partons).
31574 thp=-0.5d0*sh*(1d0-cth)
31575 uhp=-0.5d0*sh*(1d0+cth)
31576 facgg1=(sh/thp)**2+2d0*sh/thp+3d0+2d0*thp/sh+(thp/sh)**2
31577 facgg2=(uhp/sh)**2+2d0*uhp/sh+3d0+2d0*sh/uhp+(sh/uhp)**2
31578 facgg3=(thp/uhp)**2+2d0*thp/uhp+3d0+2d0*uhp/thp+(uhp/thp)**2
31579 facggs=facgg1+facgg2+facgg3
31580 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31581 nchn=nchn+1
31582 isig(nchn,1)=21
31583 isig(nchn,2)=21
31584 isig(nchn,3)=1
31585 sigh(nchn)=facqqg*parp(ionium+4)*facgg1/facggs
31586 nchn=nchn+1
31587 isig(nchn,1)=21
31588 isig(nchn,2)=21
31589 isig(nchn,3)=2
31590 sigh(nchn)=facqqg*parp(ionium+4)*facgg2/facggs
31591 nchn=nchn+1
31592 isig(nchn,1)=21
31593 isig(nchn,2)=21
31594 isig(nchn,3)=3
31595 sigh(nchn)=facqqg*parp(ionium+4)*facgg3/facggs
31596 ENDIF
31597
31598 ELSEIF(isub.EQ.425) THEN
31599C...q + g -> q + QQ~[3S18]
31600 IF(mstp(145).EQ.0) THEN
31601 facqqg=-comfac*paru(1)*as**3*(1d0/27d0)*
31602 & (4d0*(sh2+uh2)-sh*uh)*(shth2+thuh2)/
31603 & (sqmqq*sqmqqr*sh*uh*uhsh2)
31604 ELSE
31605 ff=paru(1)*as**3*(4d0*(sh2+uh2)-sh*uh)/
31606 & (54d0*sqmqq*sqmqqr*sh*uh*uhsh2)
31607 aa=shth2+thuh2
31608 bb=4d0
31609 cc=8d0
31610 dd=4d0
31611 IF(mstp(147).EQ.0) THEN
31612 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31613 & +dd*(el1k10*el2k20+el1k20*el2k10))
31614 ELSEIF(mstp(147).EQ.1) THEN
31615 facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31616 & +dd*(el1k11*el2k21+el1k21*el2k11)))
31617 ELSEIF(mstp(147).EQ.3) THEN
31618 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31619 & +dd*(el1k10*el2k20+el1k20*el2k10))
31620 ELSEIF(mstp(147).EQ.4) THEN
31621 facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31622 & +dd*(el1k11*el2k21+el1k21*el2k11))
31623 ELSEIF(mstp(147).EQ.5) THEN
31624 facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31625 & +dd*(el1k11*el2k20+el1k21*el2k10))
31626 ELSEIF(mstp(147).EQ.6) THEN
31627 facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31628 & +dd*(el1k11*el2k21+el1k21*el2k11))
31629 ENDIF
31630 facqqg=comfac*ff*facqqg
31631 ENDIF
31632C...Split total contribution into different colour flows just like
31633C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31634C...(recalculate kinematics for massless partons).
31635 thp=-0.5d0*sh*(1d0-cth)
31636 uhp=-0.5d0*sh*(1d0+cth)
31637 facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
31638 facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
31639 facqgs=facqg1+facqg2
31640 DO 2442 i=mmina,mmaxa
31641 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2442
31642 DO 2441 isde=1,2
31643 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2441
31644 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2441
31645 nchn=nchn+1
31646 isig(nchn,isde)=i
31647 isig(nchn,3-isde)=21
31648 isig(nchn,3)=1
31649 sigh(nchn)=facqqg*parp(ionium+2)*facqg1/facqgs
31650 nchn=nchn+1
31651 isig(nchn,isde)=i
31652 isig(nchn,3-isde)=21
31653 isig(nchn,3)=2
31654 sigh(nchn)=facqqg*parp(ionium+2)*facqg2/facqgs
31655 2441 CONTINUE
31656 2442 CONTINUE
31657
31658 ELSEIF(isub.EQ.426) THEN
31659C...q + g -> q + QQ~[1S08]
31660 IF(mstp(145).EQ.0) THEN
31661 facqqg=-comfac*paru(1)*as**3*(5d0/18d0)*
31662 & (sh2+uh2)/(sqmqqr*th*uhsh2)
31663 ELSE
31664 fa=-paru(1)*as**3*(5d0/54d0)*(sh2+uh2)/(sqmqqr*th*uhsh2)
31665 IF(mstp(147).EQ.0) THEN
31666 facqqg=comfac*fa
31667 ELSEIF(mstp(147).EQ.1) THEN
31668 facqqg=comfac*2d0*fa
31669 ELSEIF(mstp(147).EQ.3) THEN
31670 facqqg=comfac*fa
31671 ELSEIF(mstp(147).EQ.4) THEN
31672 facqqg=comfac*fa
31673 ELSEIF(mstp(147).EQ.5) THEN
31674 facqqg=0d0
31675 ELSEIF(mstp(147).EQ.6) THEN
31676 facqqg=0d0
31677 ENDIF
31678 ENDIF
31679C...Split total contribution into different colour flows just like
31680C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31681C...(recalculate kinematics for massless partons).
31682 thp=-0.5d0*sh*(1d0-cth)
31683 uhp=-0.5d0*sh*(1d0+cth)
31684 facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
31685 facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
31686 facqgs=facqg1+facqg2
31687 DO 2444 i=mmina,mmaxa
31688 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2444
31689 DO 2443 isde=1,2
31690 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2443
31691 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2443
31692 nchn=nchn+1
31693 isig(nchn,isde)=i
31694 isig(nchn,3-isde)=21
31695 isig(nchn,3)=1
31696 sigh(nchn)=facqqg*parp(ionium+3)*facqg1/facqgs
31697 nchn=nchn+1
31698 isig(nchn,isde)=i
31699 isig(nchn,3-isde)=21
31700 isig(nchn,3)=2
31701 sigh(nchn)=facqqg*parp(ionium+3)*facqg2/facqgs
31702 2443 CONTINUE
31703 2444 CONTINUE
31704
31705 ELSEIF(isub.EQ.427) THEN
31706C...q + g -> q + QQ~[3PJ8]
31707 IF(mstp(145).EQ.0) THEN
31708 facqqg=-comfac*paru(1)*as**3*(10d0/9d0)*
31709 & ((7d0*uhsh+8d0*th)*(sh2+uh2)
31710 & +4d0*th*(2d0*sqmqq**2-shth2-thuh2))/
31711 & (sqmqq*sqmqqr*th*uhsh2*uhsh)
31712 ELSE
31713 ff=10d0*paru(1)*as**3/
31714 & (9d0*sqmqq*sqmqqr*th2*uhsh2*uhsh)
31715 aa=th*uhsh*(2d0*sqmqq**2+shth2+thuh2)
31716 bb=8d0*(shth2+th*uh)
31717 cc=8d0*uhsh*(shth+thuh)
31718 dd=4d0*(2d0*sqmqq*sh+th*uhsh)
31719 IF(mstp(147).EQ.0) THEN
31720 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31721 & +dd*(el1k10*el2k20+el1k20*el2k10))
31722 ELSEIF(mstp(147).EQ.1) THEN
31723 facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31724 & +dd*(el1k11*el2k21+el1k21*el2k11)))
31725 ELSEIF(mstp(147).EQ.3) THEN
31726 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31727 & +dd*(el1k10*el2k20+el1k20*el2k10))
31728 ELSEIF(mstp(147).EQ.4) THEN
31729 facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31730 & +dd*(el1k11*el2k21+el1k21*el2k11))
31731 ELSEIF(mstp(147).EQ.5) THEN
31732 facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31733 & +dd*(el1k11*el2k20+el1k21*el2k10))
31734 ELSEIF(mstp(147).EQ.6) THEN
31735 facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31736 & +dd*(el1k11*el2k21+el1k21*el2k11))
31737 ENDIF
31738 facqqg=comfac*ff*facqqg
31739 ENDIF
31740C...Split total contribution into different colour flows just like
31741C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31742C...(recalculate kinematics for massless partons).
31743 thp=-0.5d0*sh*(1d0-cth)
31744 uhp=-0.5d0*sh*(1d0+cth)
31745 facqg1=9d0/4d0*(uhp/thp)**2-uhp/sh
31746 facqg2=9d0/4d0*(sh/thp)**2-sh/uhp
31747 facqgs=facqg1+facqg2
31748 DO 2446 i=mmina,mmaxa
31749 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2446
31750 DO 2445 isde=1,2
31751 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2445
31752 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2445
31753 nchn=nchn+1
31754 isig(nchn,isde)=i
31755 isig(nchn,3-isde)=21
31756 isig(nchn,3)=1
31757 sigh(nchn)=facqqg*parp(ionium+4)*facqg1/facqgs
31758 nchn=nchn+1
31759 isig(nchn,isde)=i
31760 isig(nchn,3-isde)=21
31761 isig(nchn,3)=2
31762 sigh(nchn)=facqqg*parp(ionium+4)*facqg2/facqgs
31763 2445 CONTINUE
31764 2446 CONTINUE
31765
31766 ELSEIF(isub.EQ.428) THEN
31767C...q + q~ -> g + QQ~[3S18]
31768 IF(mstp(145).EQ.0) THEN
31769 facqqg=comfac*paru(1)*as**3*(8d0/81d0)*
31770 & (4d0*(th2+uh2)-th*uh)*(shth2+uhsh2)/
31771 & (sqmqq*sqmqqr*th*uh*thuh2)
31772 ELSE
31773 ff=-4d0*paru(1)*as**3*(4d0*(th2+uh2)-th*uh)/
31774 & (81d0*sqmqq*sqmqqr*th*uh*thuh2)
31775 aa=shth2+uhsh2
31776 bb=4d0
31777 cc=4d0
31778 dd=0d0
31779 IF(mstp(147).EQ.0) THEN
31780 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31781 & +dd*(el1k10*el2k20+el1k20*el2k10))
31782 ELSEIF(mstp(147).EQ.1) THEN
31783 facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31784 & +dd*(el1k11*el2k21+el1k21*el2k11)))
31785 ELSEIF(mstp(147).EQ.3) THEN
31786 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31787 & +dd*(el1k10*el2k20+el1k20*el2k10))
31788 ELSEIF(mstp(147).EQ.4) THEN
31789 facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31790 & +dd*(el1k11*el2k21+el1k21*el2k11))
31791 ELSEIF(mstp(147).EQ.5) THEN
31792 facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31793 & +dd*(el1k11*el2k20+el1k21*el2k10))
31794 ELSEIF(mstp(147).EQ.6) THEN
31795 facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31796 & +dd*(el1k11*el2k21+el1k21*el2k11))
31797 ENDIF
31798 facqqg=comfac*ff*facqqg
31799 ENDIF
31800C...Split total contribution into different colour flows just like
31801C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31802C...(recalculate kinematics for massless partons).
31803 thp=-0.5d0*sh*(1d0-cth)
31804 uhp=-0.5d0*sh*(1d0+cth)
31805 facgg1=uh/th-9d0/4d0*uh2/sh2
31806 facgg2=th/uh-9d0/4d0*th2/sh2
31807 facggs=facgg1+facgg2
31808 DO 2447 i=mmina,mmaxa
31809 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
31810 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2447
31811 nchn=nchn+1
31812 isig(nchn,1)=i
31813 isig(nchn,2)=-i
31814 isig(nchn,3)=1
31815 sigh(nchn)=facqqg*parp(ionium+2)*facgg1/facggs
31816 nchn=nchn+1
31817 isig(nchn,1)=i
31818 isig(nchn,2)=-i
31819 isig(nchn,3)=2
31820 sigh(nchn)=facqqg*parp(ionium+2)*facgg2/facggs
31821 2447 CONTINUE
31822
31823 ELSEIF(isub.EQ.429) THEN
31824C...q + q~ -> g + QQ~[1S08]
31825 IF(mstp(145).EQ.0) THEN
31826 facqqg=comfac*paru(1)*as**3*(20d0/27d0)*
31827 & (th2+uh2)/(sqmqqr*sh*thuh2)
31828 ELSE
31829 fa=paru(1)*as**3*(20d0/81d0)*(th2+uh2)/(sqmqqr*sh*thuh2)
31830 IF(mstp(147).EQ.0) THEN
31831 facqqg=comfac*fa
31832 ELSEIF(mstp(147).EQ.1) THEN
31833 facqqg=comfac*2d0*fa
31834 ELSEIF(mstp(147).EQ.3) THEN
31835 facqqg=comfac*fa
31836 ELSEIF(mstp(147).EQ.4) THEN
31837 facqqg=comfac*fa
31838 ELSEIF(mstp(147).EQ.5) THEN
31839 facqqg=0d0
31840 ELSEIF(mstp(147).EQ.6) THEN
31841 facqqg=0d0
31842 ENDIF
31843 ENDIF
31844C...Split total contribution into different colour flows just like
31845C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31846C...(recalculate kinematics for massless partons).
31847 thp=-0.5d0*sh*(1d0-cth)
31848 uhp=-0.5d0*sh*(1d0+cth)
31849 facgg1=uh/th-9d0/4d0*uh2/sh2
31850 facgg2=th/uh-9d0/4d0*th2/sh2
31851 facggs=facgg1+facgg2
31852 DO 2448 i=mmina,mmaxa
31853 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
31854 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2448
31855 nchn=nchn+1
31856 isig(nchn,1)=i
31857 isig(nchn,2)=-i
31858 isig(nchn,3)=1
31859 sigh(nchn)=facqqg*parp(ionium+3)*facgg1/facggs
31860 nchn=nchn+1
31861 isig(nchn,1)=i
31862 isig(nchn,2)=-i
31863 isig(nchn,3)=2
31864 sigh(nchn)=facqqg*parp(ionium+3)*facgg2/facggs
31865 2448 CONTINUE
31866
31867 ELSEIF(isub.EQ.430) THEN
31868C...q + q~ -> g + QQ~[3PJ8]
31869 IF(mstp(145).EQ.0) THEN
31870 facqqg=comfac*paru(1)*as**3*(80d0/27d0)*
31871 & ((7d0*thuh+8d0*sh)*(th2+uh2)
31872 & +4d0*sh*(2d0*sqmqq**2-shth2-uhsh2))/
31873 & (sqmqq*sqmqqr*sh*thuh2*thuh)
31874 ELSE
31875 ff=-80d0*paru(1)*as**3/(27d0*sqmqq*sqmqqr*sh2*thuh2*thuh)
31876 aa=sh*thuh*(2d0*sqmqq**2+shth2+uhsh2)
31877 bb=8d0*(uhsh2+sh*th)
31878 cc=8d0*(shth2+sh*uh)
31879 dd=4d0*(shth2+uhsh2+sh*sqmqq-sqmqq**2)
31880 IF(mstp(147).EQ.0) THEN
31881 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31882 & +dd*(el1k10*el2k20+el1k20*el2k10))
31883 ELSEIF(mstp(147).EQ.1) THEN
31884 facqqg=2d0*(-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31885 & +dd*(el1k11*el2k21+el1k21*el2k11)))
31886 ELSEIF(mstp(147).EQ.3) THEN
31887 facqqg=-aa+sqmqq*(bb*el1k10*el2k10+cc*el1k20*el2k20
31888 & +dd*(el1k10*el2k20+el1k20*el2k10))
31889 ELSEIF(mstp(147).EQ.4) THEN
31890 facqqg=-aa+sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31891 & +dd*(el1k11*el2k21+el1k21*el2k11))
31892 ELSEIF(mstp(147).EQ.5) THEN
31893 facqqg=sqmqq*(bb*el1k11*el2k10+cc*el1k21*el2k20
31894 & +dd*(el1k11*el2k20+el1k21*el2k10))
31895 ELSEIF(mstp(147).EQ.6) THEN
31896 facqqg=sqmqq*(bb*el1k11*el2k11+cc*el1k21*el2k21
31897 & +dd*(el1k11*el2k21+el1k21*el2k11))
31898 ENDIF
31899 facqqg=comfac*ff*facqqg
31900 ENDIF
31901C...Split total contribution into different colour flows just like
31902C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31903C...(recalculate kinematics for massless partons).
31904 thp=-0.5d0*sh*(1d0-cth)
31905 uhp=-0.5d0*sh*(1d0+cth)
31906 facgg1=uh/th-9d0/4d0*uh2/sh2
31907 facgg2=th/uh-9d0/4d0*th2/sh2
31908 facggs=facgg1+facgg2
31909 DO 2449 i=mmina,mmaxa
31910 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
31911 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2449
31912 nchn=nchn+1
31913 isig(nchn,1)=i
31914 isig(nchn,2)=-i
31915 isig(nchn,3)=1
31916 sigh(nchn)=facqqg*parp(ionium+4)*facgg1/facggs
31917 nchn=nchn+1
31918 isig(nchn,1)=i
31919 isig(nchn,2)=-i
31920 isig(nchn,3)=2
31921 sigh(nchn)=facqqg*parp(ionium+4)*facgg2/facggs
31922 2449 CONTINUE
31923
31924 ELSEIF(isub.EQ.431) THEN
31925C...g + g -> QQ~[3P01] + g
31926 pgtw=(sh*th+th*uh+uh*sh)/sh2
31927 qgtw=(sh*th*uh)/sh**3
31928 rgtw=sqmqq/sh
31929 IF(mstp(145).EQ.0) THEN
31930 facqqg=comfac*paru(1)*as**3*8d0/(9d0*sqmqqr*sh)*
31931 & (9d0*rgtw**2*pgtw**4*
31932 & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
31933 & -6d0*rgtw*pgtw**3*qgtw*
31934 & (2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)
31935 & -pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)
31936 & +2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)
31937 & +6d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
31938 ELSE
31939 fc1=paru(1)*as**3*8d0/(27d0*sqmqqr*sh)*
31940 & (9d0*rgtw**2*pgtw**4*
31941 & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
31942 & -6d0*rgtw*pgtw**3*qgtw*
31943 & (2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)
31944 & -pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)
31945 & +2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)
31946 & +6d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
31947 IF(mstp(147).EQ.0) THEN
31948 facqqg=comfac*fc1
31949 ELSEIF(mstp(147).EQ.1) THEN
31950 facqqg=comfac*2d0*fc1
31951 ELSEIF(mstp(147).EQ.3) THEN
31952 facqqg=comfac*fc1
31953 ELSEIF(mstp(147).EQ.4) THEN
31954 facqqg=comfac*fc1
31955 ELSEIF(mstp(147).EQ.5) THEN
31956 facqqg=0d0
31957 ELSEIF(mstp(147).EQ.6) THEN
31958 facqqg=0d0
31959 ENDIF
31960 ENDIF
31961 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
31962 nchn=nchn+1
31963 isig(nchn,1)=21
31964 isig(nchn,2)=21
31965 isig(nchn,3)=1
31966 sigh(nchn)=facqqg*parp(ionium+5)
31967 ENDIF
31968
31969 ELSEIF(isub.EQ.432) THEN
31970C...g + g -> QQ~[3P11] + g
31971 pgtw=(sh*th+th*uh+uh*sh)/sh2
31972 qgtw=(sh*th*uh)/sh**3
31973 rgtw=sqmqq/sh
31974 IF(mstp(145).EQ.0) THEN
31975 facqqg=comfac*paru(1)*as**3*8d0/(3d0*sqmqqr*sh)*
31976 & pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)
31977 & +2d0*qgtw*(-rgtw**4+5d0*rgtw**2*pgtw+pgtw**2)
31978 & -15d0*rgtw*qgtw**2)/(qgtw-rgtw*pgtw)**4
31979 ELSE
31980 ff=4d0/3d0*paru(1)*as**3*sqmqqr/shth2**2/thuh2**2/uhsh2**2
31981 c1=(4d0*pgtw**5+23d0*pgtw**2*qgtw**2
31982 & +(-14d0*pgtw**3*qgtw+3d0*qgtw**3)*rgtw
31983 & -(pgtw**4+2d0*pgtw*qgtw**2)*rgtw**2
31984 & +3d0*pgtw**2*qgtw*rgtw**3)*sh2**5
31985 c2=2d0*shth2*(sh2*thuh*(sh*thuh*(sh-th)*(sh-uh)
31986 & -th*uh*(th-uh)**2)+sh2**2*(th-uh)*(th2+uh2-sh*thuh)
31987 & *(pgtw**2-qgtw*(sh+2d0*uh)/sh))
31988 c3=2d0*uhsh2*(sh2*thuh*(sh*thuh*(sh-th)*(sh-uh)
31989 & -th*uh*(th-uh)**2)-sh2**2*(th-uh)*(th2+uh2-sh*thuh)
31990 & *(pgtw**2-qgtw*(sh+2d0*th)/sh))
31991 c4=-4d0*thuh*(th-uh)**2*
31992 & (th**3*uh**3+sh2**2*(2d0*th+uh)*(th+2d0*uh)
31993 & -sh2*th*uh*(th2+uh2))
31994 & +4d0*thuh2*(sh**3*(sh2**2+th2**2+uh2**2)
31995 & -sh*th*uh*(sh2**2+th*uh*(th2-3d0*th*uh+uh2)
31996 & +sh2*(5d0*thuh2-17d0*th*uh)))
31997 IF(mstp(147).EQ.0) THEN
31998 facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
31999 & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32000 ELSEIF(mstp(147).EQ.1) THEN
32001 facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32002 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
32003 ELSEIF(mstp(147).EQ.3) THEN
32004 facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32005 & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32006 ELSEIF(mstp(147).EQ.4) THEN
32007 facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32008 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32009 ELSEIF(mstp(147).EQ.5) THEN
32010 facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
32011 & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
32012 ELSEIF(mstp(147).EQ.6) THEN
32013 facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
32014 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32015 ENDIF
32016 facqqg=comfac*ff*facqqg
32017 ENDIF
32018 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32019 nchn=nchn+1
32020 isig(nchn,1)=21
32021 isig(nchn,2)=21
32022 isig(nchn,3)=1
32023 sigh(nchn)=facqqg*parp(ionium+5)
32024 ENDIF
32025
32026 ELSEIF(isub.EQ.433) THEN
32027C...g + g -> QQ~[3P21] + g
32028 pgtw=(sh*th+th*uh+uh*sh)/sh2
32029 qgtw=(sh*th*uh)/sh**3
32030 rgtw=sqmqq/sh
32031 IF(mstp(145).EQ.0) THEN
32032 facqqg=comfac*paru(1)*as**3*8d0/(9d0*sqmqqr*sh)*
32033 & (12d0*rgtw**2*pgtw**4*
32034 & (rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)
32035 & -3d0*rgtw*pgtw**3*qgtw*
32036 & (8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)
32037 & +2d0*pgtw**2*qgtw**2*
32038 & (-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)
32039 & +rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)
32040 & +12d0*rgtw**2*qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)
32041 ELSE
32042 ff=(16d0*paru(1)*as**3*sqmqq*sqmqqr)/
32043 & (3d0*sh2*th2*uh2*shth2**2*thuh2**2*uhsh2**2)
32044 c1=pgtw**2*qgtw*(pgtw*rgtw-qgtw)**2*(rgtw**2-2d0*pgtw)
32045 & *sh*sh2**7
32046 c2=2d0*shth2*(-sh2**3*th2**3-sh**5*th**5*uh*shth
32047 & +sh2**2*th2**2*uh2*(8d0*shth2-5d0*sh*th)
32048 & +sh**3*th**3*uh**3*shth*(17d0*shth2-2d0*sh*th)
32049 & +sh2*th2*uh2**2*(105d0*sh2*th2+64d0*sh*th*(sh2+th2)
32050 & +10d0*(sh2**2+th2**2))
32051 & +sh2*th2*uh**5*shth*(32d0*shth2+7d0*sh*th)
32052 & -uh2**3*(sh2**3-87d0*sh**3*th**3+th2**3
32053 & -45d0*sh2*th2*(sh2+th2)-5d0*sh*th*(sh2**2+th2**2))
32054 & +sh*th*uh**7*shth*(7d0*shth2+12d0*sh*th)
32055 & +4d0*sh*th*uh2**4*shth2)
32056 c3=2d0*uhsh2*(-sh2**3*uh2**3-sh**5*uh**5*th*uhsh
32057 & +sh2**2*uh2**2*th2*(8d0*uhsh2-5d0*sh*uh)
32058 & +sh**3*uh**3*th**3*uhsh*(17d0*uhsh2-2d0*sh*uh)
32059 & +sh2*uh2*th2**2*(105d0*sh2*uh2+64d0*sh*uh*(sh2+uh2)
32060 & +10d0*(sh2**2+uh2**2))
32061 & +sh2*uh2*th**5*uhsh*(32d0*uhsh2+7d0*sh*uh)
32062 & -th2**3*(sh2**3-87d0*sh**3*uh**3+uh2**3
32063 & -45d0*sh2*uh2*(sh2+uh2)-5d0*sh*uh*(sh2**2+uh2**2))
32064 & +sh*uh*th**7*uhsh*(7d0*uhsh2+12d0*sh*uh)
32065 & +4d0*sh*uh*th2**4*uhsh2)
32066 c4=-2d0*shth*uhsh*(-2d0*th2**3*uh2**3
32067 & -sh**5*th2*uh2*thuh*(5d0*th+3d0*uh)*(3d0*th+5d0*uh)
32068 & +sh2**3*(2d0*th+uh)*(th+2d0*uh)*(th2-uh2)**2
32069 & -sh*th2**2*uh2**2*thuh*(5d0*thuh2-4d0*th*uh)
32070 & -sh2*th**3*uh**3*thuh2*(13d0*thuh2-16d0*th*uh)
32071 & -sh**3*th2*uh2*(92d0*th2*uh2*thuh
32072 & +53d0*th*uh*(th**3+uh**3)+11d0*(th**5+uh**5))
32073 & -sh2**2*th*uh*(114d0*th**3*uh**3
32074 & +83d0*th2*uh2*(th2+uh2)+28d0*th*uh*(th2**2+uh2**2)
32075 & +3d0*(th2**3+uh2**3)))
32076 c5=4d0*sh*th*uh2*shth2*(2d0*sh*th+sh*uh+th*uh)**2
32077 & *(2d0*uh*sqmqq**2+shth*(sh*th-uh2))
32078 c6=4d0*sh*uh*th2*uhsh2*(2d0*sh*uh+sh*th+th*uh)**2
32079 & *(2d0*th*sqmqq**2+uhsh*(sh*uh-th2))
32080 c7=4d0*sh*th*uh2*shth*(sh2**2*th**3*(11d0*sh+16d0*th)
32081 & +sh**3*th2*uh*(31d0*sh2+83d0*sh*th+61d0*th2)
32082 & +sh2*th*uh2*(19d0*sh**3+110d0*sh2*th+156d0*sh*th2+
32083 & 82d0*th**3)
32084 & +sh*th*uh**3*(43d0*sh**3+132d0*sh2*th+124d0*sh*th2
32085 & +45d0*th**3)
32086 & +th*uh2**2*(37d0*sh**3+68d0*sh2*th+43d0*sh*th2+
32087 & 8d0*th**3)
32088 & +th*uh**5*(11d0*sh2+13d0*sh*th+5d0*th2)
32089 & +sh**3*uh**3*(3d0*uhsh2-2d0*sh*uh)
32090 & +th**5*uhsh*(5d0*uhsh2+2d0*sh*uh))
32091 c8=4d0*sh*uh*th2*uhsh*(sh2**2*uh**3*(11d0*sh+16d0*uh)
32092 & +sh**3*uh2*th*(31d0*sh2+83d0*sh*uh+61d0*uh2)
32093 & +sh2*uh*th2*(19d0*sh**3+110d0*sh2*uh+156d0*sh*uh2+
32094 & 82d0*uh**3)
32095 & +sh*uh*th**3*(43d0*sh**3+132d0*sh2*uh+124d0*sh*uh2
32096 & +45d0*uh**3)
32097 & +uh*th2**2*(37d0*sh**3+68d0*sh2*uh+43d0*sh*uh2+
32098 & 8d0*uh**3)
32099 & +uh*th**5*(11d0*sh2+13d0*sh*uh+5d0*uh2)
32100 & +sh**3*th**3*(3d0*shth2-2d0*sh*th)
32101 & +uh**5*shth*(5d0*shth2+2d0*sh*th))
32102 c9=4d0*shth*uhsh*(2d0*th**5*uh**5*thuh
32103 & +4d0*sh*th2**2*uh2**2*thuh2
32104 & -sh2*th**3*uh**3*thuh*(th2+uh2)
32105 & -2d0*sh**3*th2*uh2*(thuh2**2+2d0*th*uh*thuh2-th2*uh2)
32106 & +sh2**2*th*uh*thuh*(-th*uh*thuh2+3d0*(th2**2+uh2**2))
32107 & +sh**5*(4d0*th2*uh2*(thuh2-th*uh)
32108 & +5d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3)))
32109 c0=-4d0*(2d0*th2**3*uh2**3*sqmqq
32110 & -sh2*th2**2*uh2**2*thuh*(19d0*thuh2-4d0*th*uh)
32111 & -sh**3*th**3*uh**3*thuh2*(32d0*thuh2+29d0*th*uh)
32112 & -sh2**2*th2*uh2*thuh*(264d0*th2*uh2
32113 & +136d0*th*uh*(th2+uh2)+15d0*(th2**2+uh2**2))
32114 & +sh**5*th*uh*(-428d0*th**3*uh**3
32115 & -256d0*th2*uh2*(th2+uh2)-43d0*th*uh*(th2**2+uh2**2)
32116 & +2d0*(th2**3+uh2**3))
32117 & +sh**7*(-46d0*th**3*uh**3-21d0*th2*uh2*(th2+uh2)
32118 & +2d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3))
32119 & +sh2**3*thuh*(-134*th**3*uh**3-53d0*th2*uh2*(th2+uh2)
32120 & +4d0*th*uh*(th2**2+uh2**2)+2d0*(th2**3+uh2**3)))
32121 IF(mstp(147).EQ.0) THEN
32122 facqqg=1d0/3d0*(c1*3d0
32123 & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
32124 & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
32125 & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
32126 & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
32127 & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
32128 & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
32129 & *(el1k10*el2k20-el1k11*el2k21)
32130 & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
32131 & *(el1k10*el2k20-el1k11*el2k21)
32132 & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
32133 & *(el1k20*el2k20-el1k21*el2k21)
32134 & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
32135 ELSEIF(mstp(147).EQ.1) THEN
32136 facqqg=c1*2d0
32137 & -c2*(el1k10*el2k10+el1k11*el2k11)
32138 & -c3*(el1k20*el2k20+el1k21*el2k21)
32139 & -c4*(el1k10*el2k20+el1k11*el2k21)
32140 & +c5*4d0*el1k10*el2k10*el1k11*el2k11
32141 & +c6*4d0*el1k20*el2k20*el1k21*el2k21
32142 & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
32143 & +el1k10*el2k20*el1k11*el2k11)
32144 & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
32145 & +el1k10*el2k20*el1k21*el2k21)
32146 & +c9*4d0*el1k10*el2k20*el1k11*el2k21
32147 & +c0*(el1k10*el2k10*el1k21*el2k21
32148 & +2d0*el1k10*el2k20*el1k11*el2k21
32149 & +el1k20*el2k20*el1k11*el2k11)
32150 ELSEIF(mstp(147).EQ.2) THEN
32151 facqqg=2d0*(c1
32152 & -c2*el1k11*el2k11
32153 & -c3*el1k21*el2k21
32154 & -c4*el1k11*el2k21
32155 & +c5*(el1k11*el2k11)**2
32156 & +c6*(el1k21*el2k21)**2
32157 & +c7*el1k11*el2k11*el1k11*el2k21
32158 & +c8*el1k21*el2k21*el1k11*el2k21
32159 & +(c9+c0)*(el1k11*el2k21)**2)
32160 ENDIF
32161 facqqg=comfac*ff*facqqg
32162 ENDIF
32163 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
32164 nchn=nchn+1
32165 isig(nchn,1)=21
32166 isig(nchn,2)=21
32167 isig(nchn,3)=1
32168 sigh(nchn)=facqqg*parp(ionium+5)
32169 ENDIF
32170
32171 ELSEIF(isub.EQ.434) THEN
32172C...q + g -> q + QQ~[3P01]
32173 IF(mstp(145).EQ.0) THEN
32174 facqqg=-comfac*paru(1)*as**3*(16d0/81d0)*
32175 & (th-3d0*sqmqq)**2*(sh2+uh2)/(sqmqqr*th*uhsh2**2)
32176 ELSE
32177 fa=-paru(1)*as**3*(16d0/243d0)*
32178 & (th-3d0*sqmqq)**2*(sh2+uh2)/(sqmqqr*th*uhsh2**2)
32179 IF(mstp(147).EQ.0) THEN
32180 facqqg=comfac*fa
32181 ELSEIF(mstp(147).EQ.1) THEN
32182 facqqg=comfac*2d0*fa
32183 ELSEIF(mstp(147).EQ.3) THEN
32184 facqqg=comfac*fa
32185 ELSEIF(mstp(147).EQ.4) THEN
32186 facqqg=comfac*fa
32187 ELSEIF(mstp(147).EQ.5) THEN
32188 facqqg=0d0
32189 ELSEIF(mstp(147).EQ.6) THEN
32190 facqqg=0d0
32191 ENDIF
32192 ENDIF
32193 DO 2452 i=mmina,mmaxa
32194 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2452
32195 DO 2451 isde=1,2
32196 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2451
32197 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2451
32198 nchn=nchn+1
32199 isig(nchn,isde)=i
32200 isig(nchn,3-isde)=21
32201 isig(nchn,3)=1
32202 sigh(nchn)=facqqg*parp(ionium+5)
32203 2451 CONTINUE
32204 2452 CONTINUE
32205
32206 ELSEIF(isub.EQ.435) THEN
32207C...q + g -> q + QQ~[3P11]
32208 IF(mstp(145).EQ.0) THEN
32209 facqqg=-comfac*paru(1)*as**3*(32d0/27d0)*
32210 & (4d0*sqmqq*sh*uh+th*(sh2+uh2))/(sqmqqr*uhsh2**2)
32211 ELSE
32212 ff=(64d0*paru(1)*as**3*sqmqqr)/(27d0*uhsh2**2)
32213 c1=sh*uh
32214 c2=2d0*sh
32215 c3=0d0
32216 c4=2d0*(sh-uh)
32217 IF(mstp(147).EQ.0) THEN
32218 facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32219 & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32220 ELSEIF(mstp(147).EQ.1) THEN
32221 facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32222 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
32223 ELSEIF(mstp(147).EQ.3) THEN
32224 facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32225 & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32226 ELSEIF(mstp(147).EQ.4) THEN
32227 facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32228 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32229 ELSEIF(mstp(147).EQ.5) THEN
32230 facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
32231 & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
32232 ELSEIF(mstp(147).EQ.6) THEN
32233 facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
32234 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32235 ENDIF
32236 facqqg=comfac*ff*facqqg
32237 ENDIF
32238 DO 2454 i=mmina,mmaxa
32239 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2454
32240 DO 2453 isde=1,2
32241 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2453
32242 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2453
32243 nchn=nchn+1
32244 isig(nchn,isde)=i
32245 isig(nchn,3-isde)=21
32246 isig(nchn,3)=1
32247 sigh(nchn)=facqqg*parp(ionium+5)
32248 2453 CONTINUE
32249 2454 CONTINUE
32250
32251 ELSEIF(isub.EQ.436) THEN
32252C...q + g -> q + QQ~[3P21]
32253 IF(mstp(145).EQ.0) THEN
32254 facqqg=-comfac*paru(1)*as**3*(32d0/81d0)*
32255 & ((6d0*sqmqq**2+th2)*uhsh2
32256 & -2d0*sh*uh*(th2+6d0*sqmqq*uhsh))/
32257 & (sqmqqr*th*uhsh2**2)
32258 ELSE
32259 ff=-(32d0*paru(1)*as**3*sqmqq*sqmqqr)/(27d0*th2*uhsh2**2)
32260 c1=th*uhsh2
32261 c2=4d0*(sh2+th2+2d0*th*uhsh)
32262 c3=4d0*uhsh2
32263 c4=8d0*sh*uhsh
32264 c5=8d0*th
32265 c6=0d0
32266 c7=16d0*th
32267 c8=0d0
32268 c9=-16d0*uhsh
32269 c0=16d0*sqmqq
32270 IF(mstp(147).EQ.0) THEN
32271 facqqg=1d0/3d0*(c1*3d0
32272 & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
32273 & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
32274 & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
32275 & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
32276 & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
32277 & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
32278 & *(el1k10*el2k20-el1k11*el2k21)
32279 & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
32280 & *(el1k10*el2k20-el1k11*el2k21)
32281 & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
32282 & *(el1k20*el2k20-el1k21*el2k21)
32283 & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
32284 ELSEIF(mstp(147).EQ.1) THEN
32285 facqqg=c1*2d0
32286 & -c2*(el1k10*el2k10+el1k11*el2k11)
32287 & -c3*(el1k20*el2k20+el1k21*el2k21)
32288 & -c4*(el1k10*el2k20+el1k11*el2k21)
32289 & +c5*4d0*el1k10*el2k10*el1k11*el2k11
32290 & +c6*4d0*el1k20*el2k20*el1k21*el2k21
32291 & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
32292 & +el1k10*el2k20*el1k11*el2k11)
32293 & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
32294 & +el1k10*el2k20*el1k21*el2k21)
32295 & +c9*4d0*el1k10*el2k20*el1k11*el2k21
32296 & +c0*(el1k10*el2k10*el1k21*el2k21
32297 & +2d0*el1k10*el2k20*el1k11*el2k21
32298 & +el1k20*el2k20*el1k11*el2k11)
32299 ELSEIF(mstp(147).EQ.2) THEN
32300 facqqg=2d0*(c1
32301 & -c2*el1k11*el2k11
32302 & -c3*el1k21*el2k21
32303 & -c4*el1k11*el2k21
32304 & +c5*(el1k11*el2k11)**2
32305 & +c6*(el1k21*el2k21)**2
32306 & +c7*el1k11*el2k11*el1k11*el2k21
32307 & +c8*el1k21*el2k21*el1k11*el2k21
32308 & +(c9+c0)*(el1k11*el2k21)**2)
32309 ENDIF
32310 facqqg=comfac*ff*facqqg
32311 ENDIF
32312 DO 2456 i=mmina,mmaxa
32313 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 2456
32314 DO 2455 isde=1,2
32315 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 2455
32316 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 2455
32317 nchn=nchn+1
32318 isig(nchn,isde)=i
32319 isig(nchn,3-isde)=21
32320 isig(nchn,3)=1
32321 sigh(nchn)=facqqg*parp(ionium+5)
32322 2455 CONTINUE
32323 2456 CONTINUE
32324
32325 ELSEIF(isub.EQ.437) THEN
32326C...q + q~ -> g + QQ~[3P01]
32327 IF(mstp(145).EQ.0) THEN
32328 facqqg=comfac*paru(1)*as**3*(128d0/243d0)*
32329 & (sh-3d0*sqmqq)**2*(th2+uh2)/(sqmqqr*sh*thuh2**2)
32330 ELSE
32331 fa=paru(1)*as**3*(128d0/729d0)*
32332 & (sh-3d0*sqmqq)**2*(th2+uh2)/(sqmqqr*sh*thuh2**2)
32333 IF(mstp(147).EQ.0) THEN
32334 facqqg=comfac*fa
32335 ELSEIF(mstp(147).EQ.1) THEN
32336 facqqg=comfac*2d0*fa
32337 ELSEIF(mstp(147).EQ.3) THEN
32338 facqqg=comfac*fa
32339 ELSEIF(mstp(147).EQ.4) THEN
32340 facqqg=comfac*fa
32341 ELSEIF(mstp(147).EQ.5) THEN
32342 facqqg=0d0
32343 ELSEIF(mstp(147).EQ.6) THEN
32344 facqqg=0d0
32345 ENDIF
32346 ENDIF
32347 DO 2457 i=mmina,mmaxa
32348 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32349 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2457
32350 nchn=nchn+1
32351 isig(nchn,1)=i
32352 isig(nchn,2)=-i
32353 isig(nchn,3)=1
32354 sigh(nchn)=facqqg*parp(ionium+5)
32355 2457 CONTINUE
32356
32357 ELSEIF(isub.EQ.438) THEN
32358C...q + q~ -> g + QQ~[3P11]
32359 IF(mstp(145).EQ.0) THEN
32360 facqqg=comfac*paru(1)*as**3*256d0/81d0*
32361 & (4d0*sqmqq*th*uh+sh*(th2+uh2))/(sqmqqr*thuh2**2)
32362 ELSE
32363 ff=-(512d0*paru(1)*as**3*sqmqqr)/(81d0*thuh2**2)
32364 c1=th*uh
32365 c2=2d0*uh
32366 c3=2d0*th
32367 c4=2d0*thuh
32368 IF(mstp(147).EQ.0) THEN
32369 facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32370 & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32371 ELSEIF(mstp(147).EQ.1) THEN
32372 facqqg=2d0*(-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32373 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0)
32374 ELSEIF(mstp(147).EQ.3) THEN
32375 facqqg=-c1+c2*el1k10*el2k10+c3*el1k20*el2k20
32376 & +c4*(el1k10*el2k20+el1k20*el2k10)/2d0
32377 ELSEIF(mstp(147).EQ.4) THEN
32378 facqqg=-c1+c2*el1k11*el2k11+c3*el1k21*el2k21
32379 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32380 ELSEIF(mstp(147).EQ.5) THEN
32381 facqqg=c2*el1k11*el2k10+c3*el1k21*el2k20
32382 & +c4*(el1k11*el2k20+el1k21*el2k10)/2d0
32383 ELSEIF(mstp(147).EQ.6) THEN
32384 facqqg=c2*el1k11*el2k11+c3*el1k21*el2k21
32385 & +c4*(el1k11*el2k21+el1k21*el2k11)/2d0
32386 ENDIF
32387 facqqg=comfac*ff*facqqg
32388 ENDIF
32389 DO 2458 i=mmina,mmaxa
32390 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32391 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2458
32392 nchn=nchn+1
32393 isig(nchn,1)=i
32394 isig(nchn,2)=-i
32395 isig(nchn,3)=1
32396 sigh(nchn)=facqqg*parp(ionium+5)
32397 2458 CONTINUE
32398
32399 ELSEIF(isub.EQ.439) THEN
32400C...q + q~ -> g + QQ~[3P21]
32401 IF(mstp(145).EQ.0) THEN
32402 facqqg=comfac*paru(1)*as**3*(256d0/243d0)*
32403 & ((6d0*sqmqq**2+sh2)*thuh2
32404 & -2d0*th*uh*(sh2+6d0*sqmqq*thuh))/
32405 & (sqmqqr*sh*thuh2**2)
32406 ELSE
32407 ff=(256d0*paru(1)*as**3*sqmqq*sqmqqr)/(81d0*sh2*thuh2**2)
32408 c1=sh*thuh2
32409 c2=4d0*(sh2+uh2+2d0*sh*thuh)
32410 c3=4d0*(sh2+th2+2d0*sh*thuh)
32411 c4=8d0*(sh2-th*uh+2d0*sh*thuh)
32412 c5=8d0*sh
32413 c6=c5
32414 c7=16d0*sh
32415 c8=c7
32416 c9=-16d0*thuh
32417 c0=16d0*sqmqq
32418 IF(mstp(147).EQ.0) THEN
32419 facqqg=1d0/3d0*(c1*3d0
32420 & -c2*(2d0*el1k10*el2k10+el1k11*el2k11)
32421 & -c3*(2d0*el1k20*el2k20+el1k21*el2k21)
32422 & -c4*(2d0*el1k10*el2k20+el1k11*el2k21)
32423 & +c5*2d0*(el1k10*el2k10-el1k11*el2k11)**2
32424 & +c6*2d0*(el1k20*el2k20-el1k21*el2k21)**2
32425 & +c7*2d0*(el1k10*el2k10-el1k11*el2k11)
32426 & *(el1k10*el2k20-el1k11*el2k21)
32427 & +c8*2d0*(el1k20*el2k20-el1k21*el2k21)
32428 & *(el1k10*el2k20-el1k11*el2k21)
32429 & +c9*2d0*(el1k10*el2k10-el1k11*el2k11)
32430 & *(el1k20*el2k20-el1k21*el2k21)
32431 & +c0*2d0*(el1k10*el2k20-el1k11*el2k21)**2)
32432 ELSEIF(mstp(147).EQ.1) THEN
32433 facqqg=c1*2d0
32434 & -c2*(el1k10*el2k10+el1k11*el2k11)
32435 & -c3*(el1k20*el2k20+el1k21*el2k21)
32436 & -c4*(el1k10*el2k20+el1k11*el2k21)
32437 & +c5*4d0*el1k10*el2k10*el1k11*el2k11
32438 & +c6*4d0*el1k20*el2k20*el1k21*el2k21
32439 & +c7*2d0*(el1k10*el2k10*el1k11*el2k21
32440 & +el1k10*el2k20*el1k11*el2k11)
32441 & +c8*2d0*(el1k20*el2k20*el1k11*el2k21
32442 & +el1k10*el2k20*el1k21*el2k21)
32443 & +c9*4d0*el1k10*el2k20*el1k11*el2k21
32444 & +c0*(el1k10*el2k10*el1k21*el2k21
32445 & +2d0*el1k10*el2k20*el1k11*el2k21
32446 & +el1k20*el2k20*el1k11*el2k11)
32447 ELSEIF(mstp(147).EQ.2) THEN
32448 facqqg=2d0*(c1
32449 & -c2*el1k11*el2k11
32450 & -c3*el1k21*el2k21
32451 & -c4*el1k11*el2k21
32452 & +c5*(el1k11*el2k11)**2
32453 & +c6*(el1k21*el2k21)**2
32454 & +c7*el1k11*el2k11*el1k11*el2k21
32455 & +c8*el1k21*el2k21*el1k11*el2k21
32456 & +(c9+c0)*(el1k11*el2k21)**2)
32457 ENDIF
32458 facqqg=comfac*ff*facqqg
32459 ENDIF
32460 DO 2459 i=mmina,mmaxa
32461 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32462 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 2459
32463 nchn=nchn+1
32464 isig(nchn,1)=i
32465 isig(nchn,2)=-i
32466 isig(nchn,3)=1
32467 sigh(nchn)=facqqg*parp(ionium+5)
32468 2459 CONTINUE
32469 ENDIF
32470C...QUARKONIA---
32471
32472 ENDIF
32473
32474 RETURN
32475 END
32476
32477C*********************************************************************
32478
32479C...PYSGWZ
32480C...Subprocess cross sections for W/Z processes,
32481C...except that longitudinal WW scattering is in Higgs sector.
32482C...Auxiliary to PYSIGH.
32483
32484 SUBROUTINE pysgwz(NCHN,SIGS)
32485
32486C...Double precision and integer declarations
32487 IMPLICIT DOUBLE PRECISION(a-h, o-z)
32488 IMPLICIT INTEGER(I-N)
32489 INTEGER PYK,PYCHGE,PYCOMP
32490C...Parameter statement to help give large particle numbers.
32491 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
32492 &kexcit=4000000,kdimen=5000000)
32493C...Commonblocks
32494 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
32495 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
32496 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
32497 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
32498 common/pypars/mstp(200),parp(200),msti(200),pari(200)
32499 common/pyint1/mint(400),vint(400)
32500 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
32501 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
32502 common/pyint4/mwid(500),wids(500,5)
32503 common/pytcsm/itcm(0:99),rtcm(0:99)
32504 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
32505 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
32506 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
32507 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
32508 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
32509 &/pyint2/,/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
32510C...Local arrays and complex numbers
32511 dimension wdtp(0:400),wdte(0:400,0:5),hgz(6,3),hl3(3),hr3(3),
32512 &hl4(3),hr4(3)
32513 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32514
32515C...Differential cross section expressions.
32516
32517 IF(isub.LE.20) THEN
32518 IF(isub.EQ.1) THEN
32519C...f + fbar -> gamma*/Z0
32520 mint(61)=2
32521 CALL pywidt(23,sh,wdtp,wdte)
32522 hs=shr*wdtp(0)
32523 facz=4d0*comfac*3d0
32524 hp0=aem/3d0*sh
32525 hp1=aem/3d0*xwc*sh
32526 DO 100 i=mmina,mmaxa
32527 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 100
32528 ei=kchg(iabs(i),1)/3d0
32529 ai=sign(1d0,ei)
32530 vi=ai-4d0*ei*xwv
32531 hi0=hp0
32532 IF(iabs(i).LE.10) hi0=hi0*faca/3d0
32533 hi1=hp1
32534 IF(iabs(i).LE.10) hi1=hi1*faca/3d0
32535 nchn=nchn+1
32536 isig(nchn,1)=i
32537 isig(nchn,2)=-i
32538 isig(nchn,3)=1
32539 sigh(nchn)=facz*(ei**2/sh2*hi0*hp0*vint(111)+
32540 & ei*vi*(1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*
32541 & (hi0*hp1+hi1*hp0)*vint(112)+(vi**2+ai**2)/
32542 & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114))
32543 100 CONTINUE
32544
32545 ELSEIF(isub.EQ.2) THEN
32546C...f + fbar' -> W+/-
32547 CALL pywidt(24,sh,wdtp,wdte)
32548 hs=shr*wdtp(0)
32549 facbw=4d0*comfac/((sh-sqmw)**2+hs**2)*3d0
32550 hp=aem/(24d0*xw)*sh
32551 DO 120 i=mmin1,mmax1
32552 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 120
32553 ia=iabs(i)
32554 DO 110 j=mmin2,mmax2
32555 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 110
32556 ja=iabs(j)
32557 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 110
32558 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
32559 & GOTO 110
32560 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
32561 hi=hp*2d0
32562 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
32563 nchn=nchn+1
32564 isig(nchn,1)=i
32565 isig(nchn,2)=j
32566 isig(nchn,3)=1
32567 hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
32568 sigh(nchn)=hi*facbw*hf
32569 110 CONTINUE
32570 120 CONTINUE
32571
32572 ELSEIF(isub.EQ.15) THEN
32573C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32574 faczg=comfac*as*aem*(8d0/9d0)*(th2+uh2+2d0*sqm4*sh)/(th*uh)
32575C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32576 hfgg=0d0
32577 hfgz=0d0
32578 hfzz=0d0
32579 radc4=1d0+pyalps(sqm4)/paru(1)
32580 DO 130 i=1,min(16,mdcy(23,3))
32581 idc=i+mdcy(23,2)-1
32582 IF(mdme(idc,1).LT.0) GOTO 130
32583 imdm=0
32584 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
32585 & imdm=1
32586 IF(i.LE.8) THEN
32587 ef=kchg(i,1)/3d0
32588 af=sign(1d0,ef+0.1d0)
32589 vf=af-4d0*ef*xwv
32590 ELSEIF(i.LE.16) THEN
32591 ef=kchg(i+2,1)/3d0
32592 af=sign(1d0,ef+0.1d0)
32593 vf=af-4d0*ef*xwv
32594 ENDIF
32595 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
32596 IF(4d0*rm1.LT.1d0) THEN
32597 fcof=1d0
32598 IF(i.LE.8) fcof=3d0*radc4
32599 be34=sqrt(max(0d0,1d0-4d0*rm1))
32600 IF(imdm.EQ.1) THEN
32601 hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
32602 hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
32603 hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
32604 & af**2*(1d0-4d0*rm1))*be34
32605 ENDIF
32606 ENDIF
32607 130 CONTINUE
32608C...Propagators: as simulated in PYOFSH and as desired
32609 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
32610 mint15=mint(15)
32611 mint(15)=1
32612 mint(61)=1
32613 CALL pywidt(23,sqm4,wdtp,wdte)
32614 mint(15)=mint15
32615 hfaem=(paru(108)/paru(2))*(2d0/3d0)
32616 hfgg=hfgg*hfaem*vint(111)/sqm4
32617 hfgz=hfgz*hfaem*vint(112)/sqm4
32618 hfzz=hfzz*hfaem*vint(114)/sqm4
32619C...Loop over flavours; consider full gamma/Z structure
32620 DO 140 i=mmina,mmaxa
32621 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
32622 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 140
32623 ei=kchg(iabs(i),1)/3d0
32624 ai=sign(1d0,ei)
32625 vi=ai-4d0*ei*xwv
32626 nchn=nchn+1
32627 isig(nchn,1)=i
32628 isig(nchn,2)=-i
32629 isig(nchn,3)=1
32630 sigh(nchn)=faczg*(ei**2*hfgg+ei*vi*hfgz+
32631 & (vi**2+ai**2)*hfzz)/hbw4
32632 140 CONTINUE
32633
32634 ELSEIF(isub.EQ.16) THEN
32635C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32636 facwg=comfac*as*aem/xw*2d0/9d0*(th2+uh2+2d0*sqm4*sh)/(th*uh)
32637C...Propagators: as simulated in PYOFSH and as desired
32638 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
32639 CALL pywidt(24,sqm4,wdtp,wdte)
32640 gmmwc=sqrt(sqm4)*wdtp(0)
32641 hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
32642 facwg=facwg*hbw4c/hbw4
32643 DO 160 i=mmin1,mmax1
32644 ia=iabs(i)
32645 IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 160
32646 DO 150 j=mmin2,mmax2
32647 ja=iabs(j)
32648 IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 150
32649 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 150
32650 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
32651 widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
32652 fckm=vckm((ia+1)/2,(ja+1)/2)
32653 nchn=nchn+1
32654 isig(nchn,1)=i
32655 isig(nchn,2)=j
32656 isig(nchn,3)=1
32657 sigh(nchn)=facwg*fckm*widsc
32658 150 CONTINUE
32659 160 CONTINUE
32660
32661 ELSEIF(isub.EQ.19) THEN
32662C...f + fbar -> gamma + (gamma*/Z0)
32663 facgz=comfac*2d0*aem**2*(th2+uh2+2d0*sqm4*sh)/(th*uh)
32664C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32665 hfgg=0d0
32666 hfgz=0d0
32667 hfzz=0d0
32668 radc4=1d0+pyalps(sqm4)/paru(1)
32669 DO 170 i=1,min(16,mdcy(23,3))
32670 idc=i+mdcy(23,2)-1
32671 IF(mdme(idc,1).LT.0) GOTO 170
32672 imdm=0
32673 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
32674 & imdm=1
32675 IF(i.LE.8) THEN
32676 ef=kchg(i,1)/3d0
32677 af=sign(1d0,ef+0.1d0)
32678 vf=af-4d0*ef*xwv
32679 ELSEIF(i.LE.16) THEN
32680 ef=kchg(i+2,1)/3d0
32681 af=sign(1d0,ef+0.1d0)
32682 vf=af-4d0*ef*xwv
32683 ENDIF
32684 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
32685 IF(4d0*rm1.LT.1d0) THEN
32686 fcof=1d0
32687 IF(i.LE.8) fcof=3d0*radc4
32688 be34=sqrt(max(0d0,1d0-4d0*rm1))
32689 IF(imdm.EQ.1) THEN
32690 hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
32691 hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
32692 hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
32693 & af**2*(1d0-4d0*rm1))*be34
32694 ENDIF
32695 ENDIF
32696 170 CONTINUE
32697C...Propagators: as simulated in PYOFSH and as desired
32698 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
32699 mint15=mint(15)
32700 mint(15)=1
32701 mint(61)=1
32702 CALL pywidt(23,sqm4,wdtp,wdte)
32703 mint(15)=mint15
32704 hfaem=(paru(108)/paru(2))*(2d0/3d0)
32705 hfgg=hfgg*hfaem*vint(111)/sqm4
32706 hfgz=hfgz*hfaem*vint(112)/sqm4
32707 hfzz=hfzz*hfaem*vint(114)/sqm4
32708C...Loop over flavours; consider full gamma/Z structure
32709 DO 180 i=mmina,mmaxa
32710 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 180
32711 ei=kchg(iabs(i),1)/3d0
32712 ai=sign(1d0,ei)
32713 vi=ai-4d0*ei*xwv
32714 fcoi=1d0
32715 IF(iabs(i).LE.10) fcoi=faca/3d0
32716 nchn=nchn+1
32717 isig(nchn,1)=i
32718 isig(nchn,2)=-i
32719 isig(nchn,3)=1
32720 sigh(nchn)=facgz*fcoi*ei**2*(ei**2*hfgg+ei*vi*hfgz+
32721 & (vi**2+ai**2)*hfzz)/hbw4
32722 180 CONTINUE
32723
32724 ELSEIF(isub.EQ.20) THEN
32725C...f + fbar' -> gamma + W+/-
32726 facgw=comfac*0.5d0*aem**2/xw
32727C...Propagators: as simulated in PYOFSH and as desired
32728 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
32729 CALL pywidt(24,sqm4,wdtp,wdte)
32730 gmmwc=sqrt(sqm4)*wdtp(0)
32731 hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
32732 facgw=facgw*hbw4c/hbw4
32733C...Anomalous couplings
32734 term1=(th2+uh2+2d0*sqm4*sh)/(th*uh)
32735 term2=0d0
32736 term3=0d0
32737 IF(itcm(5).GE.1.AND.itcm(5).LE.4) THEN
32738 term2=rtcm(46)*(th-uh)/(th+uh)
32739 term3=0.5d0*rtcm(46)**2*(th*uh+(th2+uh2)*sh/
32740 & (4d0*sqmw))/(th+uh)**2
32741 ENDIF
32742 DO 200 i=mmin1,mmax1
32743 ia=iabs(i)
32744 IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 200
32745 DO 190 j=mmin2,mmax2
32746 ja=iabs(j)
32747 IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 190
32748 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 190
32749 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
32750 & GOTO 190
32751 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
32752 widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
32753 IF(ia.LE.10) THEN
32754 facwr=uh/(th+uh)-1d0/3d0
32755 fckm=vckm((ia+1)/2,(ja+1)/2)
32756 fcoi=faca/3d0
32757 ELSE
32758 facwr=-th/(th+uh)
32759 fckm=1d0
32760 fcoi=1d0
32761 ENDIF
32762 facwk=term1*facwr**2+term2*facwr+term3
32763 nchn=nchn+1
32764 isig(nchn,1)=i
32765 isig(nchn,2)=j
32766 isig(nchn,3)=1
32767 sigh(nchn)=facgw*facwk*fcoi*fckm*widsc
32768 190 CONTINUE
32769 200 CONTINUE
32770 ENDIF
32771
32772 ELSEIF(isub.LE.40) THEN
32773 IF(isub.EQ.22) THEN
32774C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32775C...Kinematics dependence
32776 faczz=comfac*aem**2*((th2+uh2+2d0*(sqm3+sqm4)*sh)/(th*uh)-
32777 & sqm3*sqm4*(1d0/th2+1d0/uh2))
32778C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32779 DO 220 i=1,6
32780 DO 210 j=1,3
32781 hgz(i,j)=0d0
32782 210 CONTINUE
32783 220 CONTINUE
32784 radc3=1d0+pyalps(sqm3)/paru(1)
32785 radc4=1d0+pyalps(sqm4)/paru(1)
32786 DO 230 i=1,min(16,mdcy(23,3))
32787 idc=i+mdcy(23,2)-1
32788 IF(mdme(idc,1).LT.0) GOTO 230
32789 imdm=0
32790 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2) imdm=1
32791 IF(mdme(idc,1).EQ.4.OR.mdme(idc,1).EQ.5) imdm=mdme(idc,1)-2
32792 IF(i.LE.8) THEN
32793 ef=kchg(i,1)/3d0
32794 af=sign(1d0,ef+0.1d0)
32795 vf=af-4d0*ef*xwv
32796 ELSEIF(i.LE.16) THEN
32797 ef=kchg(i+2,1)/3d0
32798 af=sign(1d0,ef+0.1d0)
32799 vf=af-4d0*ef*xwv
32800 ENDIF
32801 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm3
32802 IF(4d0*rm1.LT.1d0) THEN
32803 fcof=1d0
32804 IF(i.LE.8) fcof=3d0*radc3
32805 be34=sqrt(max(0d0,1d0-4d0*rm1))
32806 IF(imdm.GE.1) THEN
32807 hgz(1,imdm)=hgz(1,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
32808 hgz(2,imdm)=hgz(2,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
32809 hgz(3,imdm)=hgz(3,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
32810 & af**2*(1d0-4d0*rm1))*be34
32811 ENDIF
32812 ENDIF
32813 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
32814 IF(4d0*rm1.LT.1d0) THEN
32815 fcof=1d0
32816 IF(i.LE.8) fcof=3d0*radc4
32817 be34=sqrt(max(0d0,1d0-4d0*rm1))
32818 IF(imdm.GE.1) THEN
32819 hgz(4,imdm)=hgz(4,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34
32820 hgz(5,imdm)=hgz(5,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34
32821 hgz(6,imdm)=hgz(6,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+
32822 & af**2*(1d0-4d0*rm1))*be34
32823 ENDIF
32824 ENDIF
32825 230 CONTINUE
32826C...Propagators: as simulated in PYOFSH and as desired
32827 hbw3=(1d0/paru(1))*gmmz/((sqm3-sqmz)**2+gmmz**2)
32828 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
32829 mint15=mint(15)
32830 mint(15)=1
32831 mint(61)=1
32832 CALL pywidt(23,sqm3,wdtp,wdte)
32833 mint(15)=mint15
32834 hfaem=(paru(108)/paru(2))*(2d0/3d0)
32835 DO 240 j=1,3
32836 hgz(1,j)=hgz(1,j)*hfaem*vint(111)/sqm3
32837 hgz(2,j)=hgz(2,j)*hfaem*vint(112)/sqm3
32838 hgz(3,j)=hgz(3,j)*hfaem*vint(114)/sqm3
32839 240 CONTINUE
32840 mint15=mint(15)
32841 mint(15)=1
32842 mint(61)=1
32843 CALL pywidt(23,sqm4,wdtp,wdte)
32844 mint(15)=mint15
32845 hfaem=(paru(108)/paru(2))*(2d0/3d0)
32846 DO 250 j=1,3
32847 hgz(4,j)=hgz(4,j)*hfaem*vint(111)/sqm4
32848 hgz(5,j)=hgz(5,j)*hfaem*vint(112)/sqm4
32849 hgz(6,j)=hgz(6,j)*hfaem*vint(114)/sqm4
32850 250 CONTINUE
32851C...Loop over flavours; separate left- and right-handed couplings
32852 DO 270 i=mmina,mmaxa
32853 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 270
32854 ei=kchg(iabs(i),1)/3d0
32855 ai=sign(1d0,ei)
32856 vi=ai-4d0*ei*xwv
32857 vali=vi-ai
32858 vari=vi+ai
32859 fcoi=1d0
32860 IF(iabs(i).LE.10) fcoi=faca/3d0
32861 DO 260 j=1,3
32862 hl3(j)=ei**2*hgz(1,j)+ei*vali*hgz(2,j)+vali**2*hgz(3,j)
32863 hr3(j)=ei**2*hgz(1,j)+ei*vari*hgz(2,j)+vari**2*hgz(3,j)
32864 hl4(j)=ei**2*hgz(4,j)+ei*vali*hgz(5,j)+vali**2*hgz(6,j)
32865 hr4(j)=ei**2*hgz(4,j)+ei*vari*hgz(5,j)+vari**2*hgz(6,j)
32866 260 CONTINUE
32867 faclr=hl3(1)*hl4(1)+hl3(1)*(hl4(2)+hl4(3))+
32868 & hl4(1)*(hl3(2)+hl3(3))+hl3(2)*hl4(3)+hl4(2)*hl3(3)+
32869 & hr3(1)*hr4(1)+hr3(1)*(hr4(2)+hr4(3))+
32870 & hr4(1)*(hr3(2)+hr3(3))+hr3(2)*hr4(3)+hr4(2)*hr3(3)
32871 nchn=nchn+1
32872 isig(nchn,1)=i
32873 isig(nchn,2)=-i
32874 isig(nchn,3)=1
32875 sigh(nchn)=0.5d0*faczz*fcoi*faclr/(hbw3*hbw4)
32876 270 CONTINUE
32877
32878 ELSEIF(isub.EQ.23) THEN
32879C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32880 faczw=comfac*0.5d0*(aem/xw)**2
32881 faczw=faczw*wids(23,2)
32882 thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
32883 facbw=1d0/((sh-sqmw)**2+gmmw**2)
32884 DO 290 i=mmin1,mmax1
32885 ia=iabs(i)
32886 IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 290
32887 DO 280 j=mmin2,mmax2
32888 ja=iabs(j)
32889 IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 280
32890 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 280
32891 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
32892 & GOTO 280
32893 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
32894 ei=kchg(ia,1)/3d0
32895 ai=sign(1d0,ei+0.1d0)
32896 vi=ai-4d0*ei*xwv
32897 ej=kchg(ja,1)/3d0
32898 aj=sign(1d0,ej+0.1d0)
32899 vj=aj-4d0*ej*xwv
32900 IF(vi+ai.GT.0) THEN
32901 visav=vi
32902 aisav=ai
32903 vi=vj
32904 ai=aj
32905 vj=visav
32906 aj=aisav
32907 ENDIF
32908 fckm=1d0
32909 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
32910 fcoi=1d0
32911 IF(ia.LE.10) fcoi=faca/3d0
32912 nchn=nchn+1
32913 isig(nchn,1)=i
32914 isig(nchn,2)=j
32915 isig(nchn,3)=1
32916 sigh(nchn)=faczw*fcoi*fckm*(facbw*((9d0-8d0*xw)/4d0*thuh+
32917 & (8d0*xw-6d0)/4d0*sh*(sqm3+sqm4))+(thuh-sh*(sqm3+sqm4))*
32918 & (sh-sqmw)*facbw*0.5d0*((vj+aj)/th-(vi+ai)/uh)+
32919 & thuh/(16d0*xw1)*((vj+aj)**2/th2+(vi+ai)**2/uh2)+
32920 & sh*(sqm3+sqm4)/(8d0*xw1)*(vi+ai)*(vj+aj)/(th*uh))*
32921 & wids(24,(5-kchw)/2)
32922C***Protect against slightly negative cross sections. (Reason yet to be
32923C***sorted out. One possibility: addition of width to the W propagator.)
32924 sigh(nchn)=max(0d0,sigh(nchn))
32925 280 CONTINUE
32926 290 CONTINUE
32927
32928 ELSEIF(isub.EQ.25) THEN
32929C...f + fbar -> W+ + W-
32930C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
32931 gmmzc=gmmz
32932 hbwzc=sh**2/((sh-sqmz)**2+gmmzc**2)
32933 hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)
32934 CALL pywidt(24,sqm3,wdtp,wdte)
32935 gmmw3=sqrt(sqm3)*wdtp(0)
32936 hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)
32937 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
32938 CALL pywidt(24,sqm4,wdtp,wdte)
32939 gmmw4=sqrt(sqm4)*wdtp(0)
32940 hbw4c=gmmw4/((sqm4-sqmw)**2+gmmw4**2)
32941C...Kinematical functions
32942 thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
32943 thuh34=(2d0*sh*(sqm3+sqm4)+thuh)/(sqm3*sqm4)
32944 gs=(((sh-sqm3-sqm4)**2-4d0*sqm3*sqm4)*thuh34+12d0*thuh)/sh2
32945 gt=thuh34+4d0*thuh/th2
32946 gst=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/th)/sh
32947 gu=thuh34+4d0*thuh/uh2
32948 gsu=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/uh)/sh
32949C...Common factors and couplings
32950 facww=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)
32951 facww=facww*wids(24,1)
32952 cgg=aem**2/2d0
32953 cgz=aem**2/(4d0*xw)*hbwzc*(1d0-sqmz/sh)
32954 czz=aem**2/(32d0*xw**2)*hbwzc
32955 cng=aem**2/(4d0*xw)
32956 cnz=aem**2/(16d0*xw**2)*hbwzc*(1d0-sqmz/sh)
32957 cnn=aem**2/(16d0*xw**2)
32958C...Coulomb factor for W+W- pair
32959 IF(mstp(40).GE.1.AND.mstp(40).LE.3) THEN
32960 coule=(sh-4d0*sqmw)/(4d0*pmas(24,1))
32961 coulp=max(1d-10,0.5d0*be34*sqrt(sh))
32962 IF(coule.LT.100d0*pmas(24,2)) THEN
32963 coulp1=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
32964 & pmas(24,2)**2)-coule))
32965 ELSE
32966 coulp1=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/coule))
32967 ENDIF
32968 IF(coule.GT.-100d0*pmas(24,2)) THEN
32969 coulp2=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+
32970 & pmas(24,2)**2)+coule))
32971 ELSE
32972 coulp2=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/
32973 & abs(coule)))
32974 ENDIF
32975 IF(mstp(40).EQ.1) THEN
32976 couldc=paru(1)-2d0*atan((coulp1**2+coulp2**2-coulp**2)/
32977 & max(1d-10,2d0*coulp*coulp1))
32978 faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
32979 ELSEIF(mstp(40).EQ.2) THEN
32980 coulck=dcmplx(dble(coulp1),dble(coulp2))
32981 coulcp=dcmplx(0d0,dble(coulp))
32982 coulcd=(coulck+coulcp)/(coulck-coulcp)
32983 coulcr=1d0+dble(paru(101)*sqrt(sh))/
32984 & (4d0*coulcp)*log(coulcd)
32985 coulcs=dcmplx(0d0,0d0)
32986 nstp=100
32987 DO 300 istp=1,nstp
32988 coulxx=(istp-0.5)/nstp
32989 coulcs=coulcs+(1d0/coulxx)*log((1d0+coulxx*coulcd)/
32990 & (1d0+coulxx/coulcd))
32991 300 CONTINUE
32992 coulcr=coulcr+dble(paru(101)**2*sh)/(16d0*coulcp*coulck)*
32993 & (coulcs/nstp)
32994 faccou=abs(coulcr)**2
32995 ELSEIF(mstp(40).EQ.3) THEN
32996 couldc=paru(1)-2d0*(1d0-be34)**2*atan((coulp1**2+
32997 & coulp2**2-coulp**2)/max(1d-10,2d0*coulp*coulp1))
32998 faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)
32999 ENDIF
33000 ELSEIF(mstp(40).EQ.4) THEN
33001 faccou=1d0+0.5d0*paru(101)*paru(1)/max(1d-5,be34)
33002 ELSE
33003 faccou=1d0
33004 ENDIF
33005 vint(95)=faccou
33006 facww=facww*faccou
33007C...Loop over allowed flavours
33008 DO 310 i=mmina,mmaxa
33009 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 310
33010 ei=kchg(iabs(i),1)/3d0
33011 ai=sign(1d0,ei+0.1d0)
33012 vi=ai-4d0*ei*xwv
33013 fcoi=1d0
33014 IF(iabs(i).LE.10) fcoi=faca/3d0
33015 IF(mstp(50).LE.0.OR.iabs(i).LE.10) THEN
33016 IF(ai.LT.0d0) THEN
33017 dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs+
33018 & (cng*ei+cnz*(vi+ai))*gst+cnn*gt
33019 ELSE
33020 dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs-
33021 & (cng*ei+cnz*(vi+ai))*gsu+cnn*gu
33022 ENDIF
33023 ELSE
33024 xmw02=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
33025 bet=sqrt(1d0-4d0*xmw02/sh)
33026 gat=1d0/sqrt(1d0-bet**2)
33027 sthe2=1d0-cth**2
33028 ampzg=bet**3*(16d0+(4d0*bet**2*gat**2+3d0/gat**2)*sthe2)
33029 ampnu=bet*(2d0+bet**2*gat**2*sthe2/2d0+
33030 & 2d0*bet**2*(1d0-bet**2)*sthe2/(1d0-2d0*bet*cth+bet**2)**2)
33031 ampng=bet*((1d0+bet**2)*(4d0+bet**2*gat**2*sthe2)+
33032 & 2d0*(1d0-bet**2)*(bet**2*sthe2-2d0*(1d0-bet**2))/
33033 & (1d0-2d0*bet*cth+bet**2))
33034 propi1=(0.25d0*sqmz/xmw02)*hbwzc*(1d0-sqmz/sh)
33035 propi2=(0.25d0*sqmz/xmw02)**2*hbwzc
33036 a0=(2d0*(xmw02/sqmz)-(1d0-bet**2)*xw)*poll
33037 a1=(2d0*(xmw02/sqmz)**2-2*xmw02/sqmz*(1d0-bet**2)*xw)*poll
33038 a2=(1d0-bet**2)**2*xw**2*(polr+poll)/2d0
33039 atot=ampnu*poll+(a1+a2)*propi2*ampzg-a0*propi1*ampng
33040 atot=atot*cnn/sqmw*sh/bet*2d0
33041 dsigww=atot
33042 ENDIF
33043 nchn=nchn+1
33044 isig(nchn,1)=i
33045 isig(nchn,2)=-i
33046 isig(nchn,3)=1
33047 sigh(nchn)=facww*fcoi*dsigww
33048 310 CONTINUE
33049
33050 ELSEIF(isub.EQ.30) THEN
33051C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33052 fzq=comfac*faca*as*aem*(1d0/3d0)*(sh2+uh2+2d0*sqm4*th)/
33053 & (-sh*uh)
33054C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33055 hfgg=0d0
33056 hfgz=0d0
33057 hfzz=0d0
33058 radc4=1d0+pyalps(sqm4)/paru(1)
33059 DO 320 i=1,min(16,mdcy(23,3))
33060 idc=i+mdcy(23,2)-1
33061 IF(mdme(idc,1).LT.0) GOTO 320
33062 imdm=0
33063 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
33064 & imdm=1
33065 IF(i.LE.8) THEN
33066 ef=kchg(i,1)/3d0
33067 af=sign(1d0,ef+0.1d0)
33068 vf=af-4d0*ef*xwv
33069 ELSEIF(i.LE.16) THEN
33070 ef=kchg(i+2,1)/3d0
33071 af=sign(1d0,ef+0.1d0)
33072 vf=af-4d0*ef*xwv
33073 ENDIF
33074 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33075 IF(4d0*rm1.LT.1d0) THEN
33076 fcof=1d0
33077 IF(i.LE.8) fcof=3d0*radc4
33078 be34=sqrt(max(0d0,1d0-4d0*rm1))
33079 IF(imdm.EQ.1) THEN
33080 hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
33081 hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
33082 hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
33083 & af**2*(1d0-4d0*rm1))*be34
33084 ENDIF
33085 ENDIF
33086 320 CONTINUE
33087C...Propagators: as simulated in PYOFSH and as desired
33088 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33089 mint15=mint(15)
33090 mint(15)=1
33091 mint(61)=1
33092 CALL pywidt(23,sqm4,wdtp,wdte)
33093 mint(15)=mint15
33094 hfaem=(paru(108)/paru(2))*(2d0/3d0)
33095 hfgg=hfgg*hfaem*vint(111)/sqm4
33096 hfgz=hfgz*hfaem*vint(112)/sqm4
33097 hfzz=hfzz*hfaem*vint(114)/sqm4
33098C...Loop over flavours; consider full gamma/Z structure
33099 DO 340 i=mmina,mmaxa
33100 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 340
33101 ei=kchg(iabs(i),1)/3d0
33102 ai=sign(1d0,ei)
33103 vi=ai-4d0*ei*xwv
33104 faczq=fzq*(ei**2*hfgg+ei*vi*hfgz+
33105 & (vi**2+ai**2)*hfzz)/hbw4
33106 DO 330 isde=1,2
33107 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 330
33108 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 330
33109 nchn=nchn+1
33110 isig(nchn,isde)=i
33111 isig(nchn,3-isde)=21
33112 isig(nchn,3)=1
33113 sigh(nchn)=faczq
33114 330 CONTINUE
33115 340 CONTINUE
33116
33117 ELSEIF(isub.EQ.31) THEN
33118C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33119 facwq=comfac*faca*as*aem/xw*1d0/12d0*
33120 & (sh2+uh2+2d0*sqm4*th)/(-sh*uh)
33121C...Propagators: as simulated in PYOFSH and as desired
33122 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33123 CALL pywidt(24,sqm4,wdtp,wdte)
33124 gmmwc=sqrt(sqm4)*wdtp(0)
33125 hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
33126 facwq=facwq*hbw4c/hbw4
33127 DO 360 i=mmina,mmaxa
33128 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 360
33129 ia=iabs(i)
33130 kchw=isign(1,kchg(ia,1)*isign(1,i))
33131 widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
33132 DO 350 isde=1,2
33133 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 350
33134 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 350
33135 nchn=nchn+1
33136 isig(nchn,isde)=i
33137 isig(nchn,3-isde)=21
33138 isig(nchn,3)=1
33139 sigh(nchn)=facwq*vint(180+i)*widsc
33140 350 CONTINUE
33141 360 CONTINUE
33142
33143 ELSEIF(isub.EQ.35) THEN
33144C...f + gamma -> f + (gamma*/Z0)
33145 IF(mint(15).EQ.22.AND.vint(3).LT.0d0) THEN
33146 fzqn=sh2+uh2+2d0*(sqm4-vint(3)**2)*th
33147 fzqdtm=vint(3)**2*sqm4-sh*(uh-vint(4)**2)
33148 ELSEIF(mint(16).EQ.22.AND.vint(4).LT.0d0) THEN
33149 fzqn=sh2+uh2+2d0*(sqm4-vint(4)**2)*th
33150 fzqdtm=vint(4)**2*sqm4-sh*(uh-vint(3)**2)
33151 ELSE
33152 fzqn=sh2+uh2+2d0*sqm4*th
33153 fzqdtm=-sh*uh
33154 ENDIF
33155 fzqn=comfac*2d0*aem**2*max(0d0,fzqn)
33156C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33157 hfgg=0d0
33158 hfgz=0d0
33159 hfzz=0d0
33160 radc4=1d0+pyalps(sqm4)/paru(1)
33161 DO 370 i=1,min(16,mdcy(23,3))
33162 idc=i+mdcy(23,2)-1
33163 IF(mdme(idc,1).LT.0) GOTO 370
33164 imdm=0
33165 IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)
33166 & imdm=1
33167 IF(i.LE.8) THEN
33168 ef=kchg(i,1)/3d0
33169 af=sign(1d0,ef+0.1d0)
33170 vf=af-4d0*ef*xwv
33171 ELSEIF(i.LE.16) THEN
33172 ef=kchg(i+2,1)/3d0
33173 af=sign(1d0,ef+0.1d0)
33174 vf=af-4d0*ef*xwv
33175 ENDIF
33176 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4
33177 IF(4d0*rm1.LT.1d0) THEN
33178 fcof=1d0
33179 IF(i.LE.8) fcof=3d0*radc4
33180 be34=sqrt(max(0d0,1d0-4d0*rm1))
33181 IF(imdm.EQ.1) THEN
33182 hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34
33183 hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34
33184 hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+
33185 & af**2*(1d0-4d0*rm1))*be34
33186 ENDIF
33187 ENDIF
33188 370 CONTINUE
33189C...Propagators: as simulated in PYOFSH and as desired
33190 hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)
33191 mint15=mint(15)
33192 mint(15)=1
33193 mint(61)=1
33194 CALL pywidt(23,sqm4,wdtp,wdte)
33195 mint(15)=mint15
33196 hfaem=(paru(108)/paru(2))*(2d0/3d0)
33197 hfgg=hfgg*hfaem*vint(111)/sqm4
33198 hfgz=hfgz*hfaem*vint(112)/sqm4
33199 hfzz=hfzz*hfaem*vint(114)/sqm4
33200C...Loop over flavours; consider full gamma/Z structure
33201 DO 390 i=mmina,mmaxa
33202 IF(i.EQ.0) GOTO 390
33203 ei=kchg(iabs(i),1)/3d0
33204 ai=sign(1d0,ei)
33205 vi=ai-4d0*ei*xwv
33206 faczq=ei**2*(ei**2*hfgg+ei*vi*hfgz+
33207 & (vi**2+ai**2)*hfzz)/hbw4
33208 fzqd=max(pmas(iabs(i),1)**2*sqm4,fzqdtm)
33209 DO 380 isde=1,2
33210 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 380
33211 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 380
33212 nchn=nchn+1
33213 isig(nchn,isde)=i
33214 isig(nchn,3-isde)=22
33215 isig(nchn,3)=1
33216 sigh(nchn)=faczq*fzqn/fzqd
33217 380 CONTINUE
33218 390 CONTINUE
33219
33220 ELSEIF(isub.EQ.36) THEN
33221C...f + gamma -> f' + W+/-
33222 fwq=comfac*aem**2/(2d0*xw)*
33223 & (sh2+uh2+2d0*sqm4*th)/(sqpth*sqm4-sh*uh)
33224C...Propagators: as simulated in PYOFSH and as desired
33225 hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)
33226 CALL pywidt(24,sqm4,wdtp,wdte)
33227 gmmwc=sqrt(sqm4)*wdtp(0)
33228 hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)
33229 fwq=fwq*hbw4c/hbw4
33230 DO 410 i=mmina,mmaxa
33231 IF(i.EQ.0) GOTO 410
33232 ia=iabs(i)
33233 eia=abs(kchg(iabs(i),1)/3d0)
33234 facwq=fwq*(eia-sh/(sh+uh))**2
33235 kchw=isign(1,kchg(ia,1)*isign(1,i))
33236 widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)
33237 DO 400 isde=1,2
33238 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 400
33239 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 400
33240 nchn=nchn+1
33241 isig(nchn,isde)=i
33242 isig(nchn,3-isde)=22
33243 isig(nchn,3)=1
33244 sigh(nchn)=facwq*vint(180+i)*widsc
33245 400 CONTINUE
33246 410 CONTINUE
33247 ENDIF
33248
33249 ELSEIF(isub.LE.100) THEN
33250 IF(isub.EQ.69) THEN
33251C...gamma + gamma -> W+ + W-
33252 sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
33253 fprop=sh2/((sqmwe-th)*(sqmwe-uh))
33254 facww=comfac*6d0*aem**2*(1d0-fprop*(4d0/3d0+2d0*sqmwe/sh)+
33255 & fprop**2*(2d0/3d0+2d0*(sqmwe/sh)**2))*wids(24,1)
33256 IF(kfac(1,22)*kfac(2,22).EQ.0) GOTO 420
33257 nchn=nchn+1
33258 isig(nchn,1)=22
33259 isig(nchn,2)=22
33260 isig(nchn,3)=1
33261 sigh(nchn)=facww
33262 420 CONTINUE
33263
33264 ELSEIF(isub.EQ.70) THEN
33265C...gamma + W+/- -> Z0 + W+/-
33266 sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))
33267 fprop=(th-sqmwe)**2/(-sh*(sqmwe-uh))
33268 faczw=comfac*6d0*aem**2*(xw1/xw)*
33269 & (1d0-fprop*(4d0/3d0+2d0*sqmwe/(th-sqmwe))+
33270 & fprop**2*(2d0/3d0+2d0*(sqmwe/(th-sqmwe))**2))*wids(23,2)
33271 DO 440 kchw=1,-1,-2
33272 DO 430 isde=1,2
33273 IF(kfac(isde,22)*kfac(3-isde,24*kchw).EQ.0) GOTO 430
33274 nchn=nchn+1
33275 isig(nchn,isde)=22
33276 isig(nchn,3-isde)=24*kchw
33277 isig(nchn,3)=1
33278 sigh(nchn)=faczw*wids(24,(5-kchw)/2)
33279 430 CONTINUE
33280 440 CONTINUE
33281 ENDIF
33282 ENDIF
33283
33284 RETURN
33285 END
33286
33287C*********************************************************************
33288
33289C...PYSGHG
33290C...Subprocess cross sections for Higgs processes,
33291C...except Higgs pairs in PYSGSU, but including WW scattering.
33292C...Auxiliary to PYSIGH.
33293
33294 SUBROUTINE pysghg(NCHN,SIGS)
33295
33296C...Double precision and integer declarations
33297 IMPLICIT DOUBLE PRECISION(a-h, o-z)
33298 IMPLICIT INTEGER(I-N)
33299 INTEGER PYK,PYCHGE,PYCOMP
33300C...Parameter statement to help give large particle numbers.
33301 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
33302 &kexcit=4000000,kdimen=5000000)
33303C...Commonblocks
33304 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
33305 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
33306 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
33307 common/pypars/mstp(200),parp(200),msti(200),pari(200)
33308 common/pyint1/mint(400),vint(400)
33309 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
33310 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
33311 common/pyint4/mwid(500),wids(500,5)
33312 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
33313 common/pymssm/imss(0:99),rmss(0:99)
33314 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
33315 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
33316 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
33317 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
33318 SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
33319 &/pyint3/,/pyint4/,/pysubs/,/pymssm/,/pysgcm/
33320C...Local arrays and complex variables
33321 dimension wdtp(0:400),wdte(0:400,0:5)
33322 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33323 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33324
33325C...Convert H or A process into equivalent h one
33326 ihigg=1
33327 kfhigg=25
33328 IF(isub.EQ.401.OR.isub.EQ.402) THEN
33329 kfhigg=kfpr(isub,1)
33330 END IF
33331 IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.
33332 &isub.LE.190)) THEN
33333 ihigg=2
33334 IF(mod(isub-1,10).GE.5) ihigg=3
33335 kfhigg=33+ihigg
33336 IF(isub.EQ.151.OR.isub.EQ.156) isub=3
33337 IF(isub.EQ.152.OR.isub.EQ.157) isub=102
33338 IF(isub.EQ.153.OR.isub.EQ.158) isub=103
33339 IF(isub.EQ.171.OR.isub.EQ.176) isub=24
33340 IF(isub.EQ.172.OR.isub.EQ.177) isub=26
33341 IF(isub.EQ.173.OR.isub.EQ.178) isub=123
33342 IF(isub.EQ.174.OR.isub.EQ.179) isub=124
33343 IF(isub.EQ.181.OR.isub.EQ.186) isub=121
33344 IF(isub.EQ.182.OR.isub.EQ.187) isub=122
33345 IF(isub.EQ.183.OR.isub.EQ.188) isub=111
33346 IF(isub.EQ.184.OR.isub.EQ.189) isub=112
33347 IF(isub.EQ.185.OR.isub.EQ.190) isub=113
33348 ENDIF
33349 sqmh=pmas(kfhigg,1)**2
33350 gmmh=pmas(kfhigg,1)*pmas(kfhigg,2)
33351
33352C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33353 IF((mstp(46).GE.3.AND.mstp(46).LE.6).AND.(isub.EQ.71.OR.isub.EQ.
33354 &72.OR.isub.EQ.73.OR.isub.EQ.76.OR.isub.EQ.77)) THEN
33355C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33356 IF(mstp(46).LE.4) THEN
33357 hdtlh=log(pmas(25,1)/parp(44))
33358 hdtmr=(4.5d0*paru(1)/sqrt(3d0)-74d0/9d0)/8d0+hdtlh/12d0
33359 hdtnr=-1d0/18d0+hdtlh/6d0
33360 ELSE
33361 hdtnm=0.125d0*(1d0/(288d0*paru(1)**2)+(parp(47)/parp(45))**2)
33362 hdtlq=log(parp(45)/parp(44))
33363 hdtmr=-(4d0*paru(1))**2*0.5d0*hdtnm+hdtlq/12d0
33364 hdtnr=(4d0*paru(1))**2*hdtnm+hdtlq/6d0
33365 ENDIF
33366
33367C...Calculate lowest and next-to-lowest order partial wave amplitudes
33368 hdtv=1d0/(16d0*paru(1)*parp(47)**2)
33369 a00l=dble(hdtv*sh)
33370 a20l=-0.5d0*a00l
33371 a11l=a00l/6d0
33372 hdtls=log(sh/parp(44)**2)
33373 a004=dble((hdtv*sh)**2/(4d0*paru(1)))*
33374 & cmplx(dble((176d0*hdtmr+112d0*hdtnr)/3d0+11d0/27d0-
33375 & (50d0/9d0)*hdtls),dble(4d0*paru(1)))
33376 a204=dble((hdtv*sh)**2/(4d0*paru(1)))*
33377 & cmplx(dble(32d0*(hdtmr+2d0*hdtnr)/3d0+25d0/54d0-
33378 & (20d0/9d0)*hdtls),dble(paru(1)))
33379 a114=dble((hdtv*sh)**2/(6d0*paru(1)))*
33380 & cmplx(dble(4d0*(-2d0*hdtmr+hdtnr)-1d0/18d0),dble(paru(1)/6d0))
33381
33382C...Unitarize partial wave amplitudes with Pade or K-matrix method
33383 IF(mstp(46).EQ.3.OR.mstp(46).EQ.5) THEN
33384 a00u=a00l/(1d0-a004/a00l)
33385 a20u=a20l/(1d0-a204/a20l)
33386 a11u=a11l/(1d0-a114/a11l)
33387 ELSE
33388 a00u=(a00l+dble(a004))/(1d0-dcmplx(0.d0,a00l+dble(a004)))
33389 a20u=(a20l+dble(a204))/(1d0-dcmplx(0.d0,a20l+dble(a204)))
33390 a11u=(a11l+dble(a114))/(1d0-dcmplx(0.d0,a11l+dble(a114)))
33391 ENDIF
33392 ENDIF
33393
33394C...Differential cross section expressions.
33395
33396 IF(isub.LE.60) THEN
33397 IF(isub.EQ.3) THEN
33398C...f + fbar -> h0 (or H0, or A0)
33399 CALL pywidt(kfhigg,sh,wdtp,wdte)
33400 hs=shr*wdtp(0)
33401 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33402 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
33403 & facbw=0d0
33404 hp=aem/(8d0*xw)*sh/sqmw*sh
33405 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33406 DO 100 i=mmina,mmaxa
33407 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 100
33408 ia=iabs(i)
33409 rmq=pymrun(ia,sh)**2/sh
33410 hi=hp*rmq
33411 IF(ia.LE.10) hi=hp*rmq*faca/3d0
33412 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
33413 ikfi=1
33414 IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
33415 IF(ia.GT.10) ikfi=3
33416 hi=hi*paru(150+10*ihigg+ikfi)**2
33417 IF(imss(1).NE.0.AND.ia.EQ.5) THEN
33418 hi=hi/(1d0+rmss(41))**2
33419 IF(ihigg.NE.3) THEN
33420 hi=hi*(1d0+rmss(41)*paru(152+10*ihigg)/
33421 & paru(151+10*ihigg))**2
33422 ENDIF
33423 ENDIF
33424 ENDIF
33425 nchn=nchn+1
33426 isig(nchn,1)=i
33427 isig(nchn,2)=-i
33428 isig(nchn,3)=1
33429 sigh(nchn)=hi*facbw*hf
33430 100 CONTINUE
33431
33432 ELSEIF(isub.EQ.5) THEN
33433C...Z0 + Z0 -> h0
33434 CALL pywidt(25,sh,wdtp,wdte)
33435 hs=shr*wdtp(0)
33436 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33437 IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
33438 hp=aem/(8d0*xw)*sh/sqmw*sh
33439 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33440 hi=hp/4d0
33441 faci=8d0/(paru(1)**2*xw1)*(aem*xwc)**2
33442 DO 120 i=mmin1,mmax1
33443 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 120
33444 DO 110 j=mmin2,mmax2
33445 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 110
33446 ei=kchg(iabs(i),1)/3d0
33447 ai=sign(1d0,ei)
33448 vi=ai-4d0*ei*xwv
33449 ej=kchg(iabs(j),1)/3d0
33450 aj=sign(1d0,ej)
33451 vj=aj-4d0*ej*xwv
33452 nchn=nchn+1
33453 isig(nchn,1)=i
33454 isig(nchn,2)=j
33455 isig(nchn,3)=1
33456 sigh(nchn)=faci*(vi**2+ai**2)*(vj**2+aj**2)*hi*facbw*hf
33457 110 CONTINUE
33458 120 CONTINUE
33459
33460 ELSEIF(isub.EQ.8) THEN
33461C...W+ + W- -> h0
33462 CALL pywidt(25,sh,wdtp,wdte)
33463 hs=shr*wdtp(0)
33464 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33465 IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0
33466 hp=aem/(8d0*xw)*sh/sqmw*sh
33467 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33468 hi=hp/2d0
33469 faci=1d0/(4d0*paru(1)**2)*(aem/xw)**2
33470 DO 140 i=mmin1,mmax1
33471 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 140
33472 ei=sign(1d0,dble(i))*kchg(iabs(i),1)
33473 DO 130 j=mmin2,mmax2
33474 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 130
33475 ej=sign(1d0,dble(j))*kchg(iabs(j),1)
33476 IF(ei*ej.GT.0d0) GOTO 130
33477 nchn=nchn+1
33478 isig(nchn,1)=i
33479 isig(nchn,2)=j
33480 isig(nchn,3)=1
33481 sigh(nchn)=faci*vint(180+i)*vint(180+j)*hi*facbw*hf
33482 130 CONTINUE
33483 140 CONTINUE
33484
33485 ELSEIF(isub.EQ.24) THEN
33486C...f + fbar -> Z0 + h0 (or H0, or A0)
33487C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33488 hbw3=gmmz/((sqm3-sqmz)**2+gmmz**2)
33489 CALL pywidt(23,sqm3,wdtp,wdte)
33490 gmmz3=sqrt(sqm3)*wdtp(0)
33491 hbw3c=gmmz3/((sqm3-sqmz)**2+gmmz3**2)
33492 hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
33493 CALL pywidt(kfhigg,sqm4,wdtp,wdte)
33494 gmmh4=sqrt(sqm4)*wdtp(0)
33495 hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
33496 thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
33497 fachz=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)*8d0*(aem*xwc)**2*
33498 & (thuh+2d0*sh*sqm3)/((sh-sqmz)**2+gmmz**2)
33499 fachz=fachz*wids(23,2)*wids(kfhigg,2)
33500 IF(mstp(4).GE.1.OR.ihigg.GE.2) fachz=fachz*
33501 & paru(154+10*ihigg)**2
33502 DO 150 i=mmina,mmaxa
33503 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 150
33504 ei=kchg(iabs(i),1)/3d0
33505 ai=sign(1d0,ei)
33506 vi=ai-4d0*ei*xwv
33507 fcoi=1d0
33508 IF(iabs(i).LE.10) fcoi=faca/3d0
33509 nchn=nchn+1
33510 isig(nchn,1)=i
33511 isig(nchn,2)=-i
33512 isig(nchn,3)=1
33513 sigh(nchn)=fachz*fcoi*(vi**2+ai**2)
33514 150 CONTINUE
33515
33516 ELSEIF(isub.EQ.26) THEN
33517C...f + fbar' -> W+/- + h0 (or H0, or A0)
33518C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33519 hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)
33520 CALL pywidt(24,sqm3,wdtp,wdte)
33521 gmmw3=sqrt(sqm3)*wdtp(0)
33522 hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)
33523 hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
33524 CALL pywidt(kfhigg,sqm4,wdtp,wdte)
33525 gmmh4=sqrt(sqm4)*wdtp(0)
33526 hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
33527 thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)
33528 fachw=comfac*0.125d0*(aem/xw)**2*(thuh+2d0*sh*sqm3)/
33529 & ((sh-sqmw)**2+gmmw**2)*(hbw3c/hbw3)*(hbw4c/hbw4)
33530 fachw=fachw*wids(kfhigg,2)
33531 IF(mstp(4).GE.1.OR.ihigg.GE.2) fachw=fachw*
33532 & paru(155+10*ihigg)**2
33533 DO 170 i=mmin1,mmax1
33534 ia=iabs(i)
33535 IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 170
33536 DO 160 j=mmin2,mmax2
33537 ja=iabs(j)
33538 IF(j.EQ.0.OR.ja.GT.20.OR.kfac(1,j).EQ.0) GOTO 160
33539 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 160
33540 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
33541 & GOTO 160
33542 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
33543 fckm=1d0
33544 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
33545 fcoi=1d0
33546 IF(ia.LE.10) fcoi=faca/3d0
33547 nchn=nchn+1
33548 isig(nchn,1)=i
33549 isig(nchn,2)=j
33550 isig(nchn,3)=1
33551 sigh(nchn)=fachw*fcoi*fckm*wids(24,(5-kchw)/2)
33552 160 CONTINUE
33553 170 CONTINUE
33554
33555 ELSEIF(isub.EQ.32) THEN
33556C...f + g -> f + h0 (q + g -> q + h0 only)
33557 fhcq=comfac*faca*as*aem/xw*1d0/24d0
33558C...H propagator: as simulated in PYOFSH and as desired
33559 sqmhc=pmas(25,1)**2
33560 gmmhc=pmas(25,1)*pmas(25,2)
33561 hbw4=gmmhc/((sqm4-sqmhc)**2+gmmhc**2)
33562 CALL pywidt(25,sqm4,wdtp,wdte)
33563 gmmhcc=sqrt(sqm4)*wdtp(0)
33564 hbw4c=gmmhcc/((sqm4-sqmhc)**2+gmmhcc**2)
33565 fhcq=fhcq*hbw4c/hbw4
33566 DO 190 i=mmina,mmaxa
33567 ia=iabs(i)
33568 IF(ia.NE.5) GOTO 190
33569 sqml=pymrun(ia,sh)**2
33570 sqmq=pmas(ia,1)**2
33571 fachcq=fhcq*sqml/sqmw*
33572 & (sh/(sqmq-uh)+2d0*sqmq*(sqm4-uh)/(sqmq-uh)**2+(sqmq-uh)/sh-
33573 & 2d0*sqmq/(sqmq-uh)+2d0*(sqm4-uh)/(sqmq-uh)*
33574 & (sqm4-sqmq-sh)/sh)
33575 DO 180 isde=1,2
33576 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 180
33577 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 180
33578 nchn=nchn+1
33579 isig(nchn,isde)=i
33580 isig(nchn,3-isde)=21
33581 isig(nchn,3)=1
33582 sigh(nchn)=fachcq*wids(25,2)
33583 180 CONTINUE
33584 190 CONTINUE
33585 ENDIF
33586
33587 ELSEIF(isub.LE.80) THEN
33588 IF(isub.EQ.71) THEN
33589C...Z0 + Z0 -> Z0 + Z0
33590 IF(sh.LE.4.01d0*sqmz) GOTO 220
33591
33592 IF(mstp(46).LE.2) THEN
33593C...Exact scattering ME:s for on-mass-shell gauge bosons
33594 be2=1d0-4d0*sqmz/sh
33595 th=-0.5d0*sh*be2*(1d0-cth)
33596 uh=-0.5d0*sh*be2*(1d0+cth)
33597 IF(max(th,uh).GT.-1d0) GOTO 220
33598 shang=1d0/xw1*sqmw/sqmz*(1d0+be2)**2
33599 ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
33600 ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
33601 thang=1d0/xw1*sqmw/sqmz*(be2-cth)**2
33602 athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
33603 athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
33604 uhang=1d0/xw1*sqmw/sqmz*(be2+cth)**2
33605 auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
33606 auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
33607 faczz=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
33608 & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
33609 IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
33610 IF(mstp(46).EQ.1) faczz=faczz*((ashre+athre+auhre)**2+
33611 & (ashim+athim+auhim)**2)
33612 IF(mstp(46).EQ.2) faczz=0d0
33613
33614 ELSE
33615C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33616 faczz=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
33617 & abs(a00u+2d0*a20u)**2
33618 ENDIF
33619 faczz=faczz*wids(23,1)
33620
33621 DO 210 i=mmin1,mmax1
33622 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 210
33623 ei=kchg(iabs(i),1)/3d0
33624 ai=sign(1d0,ei)
33625 vi=ai-4d0*ei*xwv
33626 avi=ai**2+vi**2
33627 DO 200 j=mmin2,mmax2
33628 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 200
33629 ej=kchg(iabs(j),1)/3d0
33630 aj=sign(1d0,ej)
33631 vj=aj-4d0*ej*xwv
33632 avj=aj**2+vj**2
33633 nchn=nchn+1
33634 isig(nchn,1)=i
33635 isig(nchn,2)=j
33636 isig(nchn,3)=1
33637 sigh(nchn)=0.5d0*faczz*avi*avj
33638 200 CONTINUE
33639 210 CONTINUE
33640 220 CONTINUE
33641
33642 ELSEIF(isub.EQ.72) THEN
33643C...Z0 + Z0 -> W+ + W-
33644 IF(sh.LE.4.01d0*sqmz) GOTO 250
33645
33646 IF(mstp(46).LE.2) THEN
33647C...Exact scattering ME:s for on-mass-shell gauge bosons
33648 be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
33649 cth2=cth**2
33650 th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
33651 uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
33652 IF(max(th,uh).GT.-1d0) GOTO 250
33653 shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
33654 & (1d0-2d0*sqmz/sh)
33655 ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
33656 ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
33657 atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
33658 & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
33659 & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
33660 & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
33661 & 2d0*(sqmw+sqmz)/sh*be2*cth))
33662 atwim=0d0
33663 auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
33664 & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
33665 & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
33666 & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
33667 & 2d0*(sqmw+sqmz)/sh*be2*cth))
33668 auwim=0d0
33669 a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
33670 a4im=0d0
33671 facww=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*
33672 & (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2
33673 IF(mstp(46).LE.0) facww=facww*(ashre**2+ashim**2)
33674 IF(mstp(46).EQ.1) facww=facww*((ashre+atwre+auwre+a4re)**2+
33675 & (ashim+atwim+auwim+a4im)**2)
33676 IF(mstp(46).EQ.2) facww=facww*((atwre+auwre+a4re)**2+
33677 & (atwim+auwim+a4im)**2)
33678
33679 ELSE
33680C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33681 facww=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*
33682 & abs(a00u-a20u)**2
33683 ENDIF
33684 facww=facww*wids(24,1)
33685
33686 DO 240 i=mmin1,mmax1
33687 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 240
33688 ei=kchg(iabs(i),1)/3d0
33689 ai=sign(1d0,ei)
33690 vi=ai-4d0*ei*xwv
33691 avi=ai**2+vi**2
33692 DO 230 j=mmin2,mmax2
33693 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 230
33694 ej=kchg(iabs(j),1)/3d0
33695 aj=sign(1d0,ej)
33696 vj=aj-4d0*ej*xwv
33697 avj=aj**2+vj**2
33698 nchn=nchn+1
33699 isig(nchn,1)=i
33700 isig(nchn,2)=j
33701 isig(nchn,3)=1
33702 sigh(nchn)=facww*avi*avj
33703 230 CONTINUE
33704 240 CONTINUE
33705 250 CONTINUE
33706
33707 ELSEIF(isub.EQ.73) THEN
33708C...Z0 + W+/- -> Z0 + W+/-
33709 IF(sh.LE.2d0*sqmz+2d0*sqmw) GOTO 280
33710
33711 IF(mstp(46).LE.2) THEN
33712C...Exact scattering ME:s for on-mass-shell gauge bosons
33713 be2=1d0-2d0*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2
33714 ep1=1d0-(sqmz-sqmw)/sh
33715 ep2=1d0+(sqmz-sqmw)/sh
33716 th=-0.5d0*sh*be2*(1d0-cth)
33717 uh=(sqmz-sqmw)**2/sh-0.5d0*sh*be2*(1d0+cth)
33718 IF(max(th,uh).GT.-1d0) GOTO 280
33719 thang=(be2-ep1*cth)*(be2-ep2*cth)
33720 athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
33721 athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
33722 aswre=-xw1/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+
33723 & 1d0/4d0*(be2+ep1*ep2)**2*((ep1-ep2)**2-4d0*be2*cth)+
33724 & 2d0*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-
33725 & 1d0/16d0*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2)
33726 aswim=0d0
33727 auwre=xw1/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*
33728 & (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*
33729 & (be2+ep1*ep2*cth)*(2d0*ep2-ep2*cth+ep1)-
33730 & be2*(ep2+ep1*cth)**2*(be2-ep2**2*cth)-1d0/8d0*
33731 & (be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2d0*be2*(1d0-cth))+
33732 & 1d0/32d0*sh/sqmw*(be2+ep1*ep2*cth)**2*
33733 & (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)*
33734 & (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*
33735 & (2d0*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*
33736 & (be2-ep1**2*cth)-1d0/8d0*(be2+ep1*ep2*cth)**2*
33737 & ((ep1+ep2)**2+2d0*be2*(1d0-cth))+1d0/32d0*sh/sqmw*
33738 & (be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2)
33739 auwim=0d0
33740 a4re=xw1/sqmz*(ep1**2*ep2**2*(cth**2-1d0)-
33741 & 2d0*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2d0*be2*ep1*ep2)
33742 a4im=0d0
33743 faczw=comfac*1d0/(4096d0*paru(1)**2*4d0*xw1)*(aem/xw)**4*
33744 & (sh/sqmw)**2*sqrt(sqmz/sqmw)*sh2
33745 IF(mstp(46).LE.0) faczw=0d0
33746 IF(mstp(46).EQ.1) faczw=faczw*((athre+aswre+auwre+a4re)**2+
33747 & (athim+aswim+auwim+a4im)**2)
33748 IF(mstp(46).EQ.2) faczw=faczw*((aswre+auwre+a4re)**2+
33749 & (aswim+auwim+a4im)**2)
33750
33751 ELSE
33752C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33753 faczw=comfac*aem**2/(64d0*paru(1)**2*xw**2*xw1)*16d0*
33754 & abs(a20u+3d0*a11u*dble(cth))**2
33755 ENDIF
33756 faczw=faczw*wids(23,2)
33757
33758 DO 270 i=mmin1,mmax1
33759 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 270
33760 ei=kchg(iabs(i),1)/3d0
33761 ai=sign(1d0,ei)
33762 vi=ai-4d0*ei*xwv
33763 avi=ai**2+vi**2
33764 kchwi=isign(1,kchg(iabs(i),1)*isign(1,i))
33765 DO 260 j=mmin2,mmax2
33766 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 260
33767 ej=kchg(iabs(j),1)/3d0
33768 aj=sign(1d0,ej)
33769 vj=ai-4d0*ej*xwv
33770 avj=aj**2+vj**2
33771 kchwj=isign(1,kchg(iabs(j),1)*isign(1,j))
33772 nchn=nchn+1
33773 isig(nchn,1)=i
33774 isig(nchn,2)=j
33775 isig(nchn,3)=1
33776 sigh(nchn)=faczw*avi*vint(180+j)*wids(24,(5-kchwj)/2)
33777 nchn=nchn+1
33778 isig(nchn,1)=i
33779 isig(nchn,2)=j
33780 isig(nchn,3)=2
33781 sigh(nchn)=faczw*vint(180+i)*wids(24,(5-kchwi)/2)*avj
33782 260 CONTINUE
33783 270 CONTINUE
33784 280 CONTINUE
33785
33786 ELSEIF(isub.EQ.75) THEN
33787C...W+ + W- -> gamma + gamma
33788
33789 ELSEIF(isub.EQ.76) THEN
33790C...W+ + W- -> Z0 + Z0
33791 IF(sh.LE.4.01d0*sqmz) GOTO 310
33792
33793 IF(mstp(46).LE.2) THEN
33794C...Exact scattering ME:s for on-mass-shell gauge bosons
33795 be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))
33796 cth2=cth**2
33797 th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)
33798 uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)
33799 IF(max(th,uh).GT.-1d0) GOTO 310
33800 shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*
33801 & (1d0-2d0*sqmz/sh)
33802 ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
33803 ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
33804 atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*
33805 & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
33806 & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
33807 & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+
33808 & 2d0*(sqmw+sqmz)/sh*be2*cth))
33809 atwim=0d0
33810 auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*
33811 & cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*
33812 & ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*
33813 & (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-
33814 & 2d0*(sqmw+sqmz)/sh*be2*cth))
33815 auwim=0d0
33816 a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)
33817 a4im=0d0
33818 faczz=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
33819 & (sh/sqmw)**2*sh2
33820 IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)
33821 IF(mstp(46).EQ.1) faczz=faczz*((ashre+atwre+auwre+a4re)**2+
33822 & (ashim+atwim+auwim+a4im)**2)
33823 IF(mstp(46).EQ.2) faczz=faczz*((atwre+auwre+a4re)**2+
33824 & (atwim+auwim+a4im)**2)
33825
33826 ELSE
33827C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33828 faczz=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
33829 & abs(a00u-a20u)**2
33830 ENDIF
33831 faczz=faczz*wids(23,1)
33832
33833 DO 300 i=mmin1,mmax1
33834 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 300
33835 ei=sign(1d0,dble(i))*kchg(iabs(i),1)
33836 DO 290 j=mmin2,mmax2
33837 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 290
33838 ej=sign(1d0,dble(j))*kchg(iabs(j),1)
33839 IF(ei*ej.GT.0d0) GOTO 290
33840 nchn=nchn+1
33841 isig(nchn,1)=i
33842 isig(nchn,2)=j
33843 isig(nchn,3)=1
33844 sigh(nchn)=0.5d0*faczz*vint(180+i)*vint(180+j)
33845 290 CONTINUE
33846 300 CONTINUE
33847 310 CONTINUE
33848
33849 ELSEIF(isub.EQ.77) THEN
33850C...W+/- + W+/- -> W+/- + W+/-
33851 IF(sh.LE.4.01d0*sqmw) GOTO 340
33852
33853 IF(mstp(46).LE.2) THEN
33854C...Exact scattering ME:s for on-mass-shell gauge bosons
33855 be2=1d0-4d0*sqmw/sh
33856 be4=be2**2
33857 cth2=cth**2
33858 cth3=cth**3
33859 th=-0.5d0*sh*be2*(1d0-cth)
33860 uh=-0.5d0*sh*be2*(1d0+cth)
33861 IF(max(th,uh).GT.-1d0) GOTO 340
33862 shang=(1d0+be2)**2
33863 ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang
33864 ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang
33865 thang=(be2-cth)**2
33866 athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang
33867 athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang
33868 uhang=(be2+cth)**2
33869 auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang
33870 auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang
33871 sgzang=1d0/sqmw*be2*(3d0-be2)**2*cth
33872 asgre=xw*sgzang
33873 asgim=0d0
33874 aszre=xw1*sh/(sh-sqmz)*sgzang
33875 aszim=0d0
33876 tgzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)+be2*(4d0-10d0*be2+
33877 & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2+be2*cth3)
33878 atgre=0.5d0*xw*sh/th*tgzang
33879 atgim=0d0
33880 atzre=0.5d0*xw1*sh/(th-sqmz)*tgzang
33881 atzim=0d0
33882 ugzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)-be2*(4d0-10d0*be2+
33883 & be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2-be2*cth3)
33884 augre=0.5d0*xw*sh/uh*ugzang
33885 augim=0d0
33886 auzre=0.5d0*xw1*sh/(uh-sqmz)*ugzang
33887 auzim=0d0
33888 a4are=1d0/sqmw*(1d0+2d0*be2-6d0*be2*cth-cth2)
33889 a4aim=0d0
33890 a4sre=2d0/sqmw*(1d0+2d0*be2-cth2)
33891 a4sim=0d0
33892 fww=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*
33893 & (sh/sqmw)**2*sh2
33894 IF(mstp(46).LE.0) THEN
33895 awware=ashre
33896 awwaim=ashim
33897 awwsre=0d0
33898 awwsim=0d0
33899 ELSEIF(mstp(46).EQ.1) THEN
33900 awware=ashre+athre+asgre+aszre+atgre+atzre+a4are
33901 awwaim=ashim+athim+asgim+aszim+atgim+atzim+a4aim
33902 awwsre=-athre-auhre+atgre+atzre+augre+auzre+a4sre
33903 awwsim=-athim-auhim+atgim+atzim+augim+auzim+a4sim
33904 ELSE
33905 awware=asgre+aszre+atgre+atzre+a4are
33906 awwaim=asgim+aszim+atgim+atzim+a4aim
33907 awwsre=atgre+atzre+augre+auzre+a4sre
33908 awwsim=atgim+atzim+augim+auzim+a4sim
33909 ENDIF
33910 awwa2=awware**2+awwaim**2
33911 awws2=awwsre**2+awwsim**2
33912
33913 ELSE
33914C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33915 fwwa=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*
33916 & abs(a00u+0.5d0*a20u+4.5d0*a11u*dble(cth))**2
33917 fwws=comfac*(aem/(4d0*paru(1)*xw))**2*64d0*abs(a20u)**2
33918 ENDIF
33919
33920 DO 330 i=mmin1,mmax1
33921 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 330
33922 ei=sign(1d0,dble(i))*kchg(iabs(i),1)
33923 DO 320 j=mmin2,mmax2
33924 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 320
33925 ej=sign(1d0,dble(j))*kchg(iabs(j),1)
33926 IF(ei*ej.LT.0d0) THEN
33927C...W+W-
33928 IF(mstp(45).EQ.1) GOTO 320
33929 IF(mstp(46).LE.2) facww=fww*awwa2*wids(24,1)
33930 IF(mstp(46).GE.3) facww=fwwa*wids(24,1)
33931 ELSE
33932C...W+W+/W-W-
33933 IF(mstp(45).EQ.2) GOTO 320
33934 IF(mstp(46).LE.2) facww=fww*awws2
33935 IF(mstp(46).GE.3) facww=fwws
33936 IF(ei.GT.0d0) facww=facww*wids(24,4)
33937 IF(ei.LT.0d0) facww=facww*wids(24,5)
33938 ENDIF
33939 nchn=nchn+1
33940 isig(nchn,1)=i
33941 isig(nchn,2)=j
33942 isig(nchn,3)=1
33943 sigh(nchn)=facww*vint(180+i)*vint(180+j)
33944 IF(ei*ej.GT.0d0) sigh(nchn)=0.5d0*sigh(nchn)
33945 320 CONTINUE
33946 330 CONTINUE
33947 340 CONTINUE
33948 ENDIF
33949
33950 ELSEIF(isub.LE.120) THEN
33951 IF(isub.EQ.102) THEN
33952C...g + g -> h0 (or H0, or A0)
33953 CALL pywidt(kfhigg,sh,wdtp,wdte)
33954 hs=shr*wdtp(0)
33955 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33956 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33957 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
33958 & facbw=0d0
33959C...PS: Only use fixed-width when using SLHA decay table for this Higgs
33960 IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
33961 wdtp13=0d0
33962 DO 345 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
33963 IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
33964 & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
33965 345 CONTINUE
33966 IF(wdtp13.EQ.0d0) CALL pyerrm(26,
33967 & '(PYSGHG:) did not find Higgs -> g g channel')
33968 hi=shr*wdtp13/32d0
33969 ELSE
33970 hi=shr*wdtp(13)/32d0
33971 ENDIF
33972 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 350
33973 nchn=nchn+1
33974 isig(nchn,1)=21
33975 isig(nchn,2)=21
33976 isig(nchn,3)=1
33977 sigh(nchn)=hi*facbw*hf
33978 350 CONTINUE
33979
33980 ELSEIF(isub.EQ.103) THEN
33981C...gamma + gamma -> h0 (or H0, or A0)
33982 CALL pywidt(kfhigg,sh,wdtp,wdte)
33983 hs=shr*wdtp(0)
33984 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
33985 facbw=4d0*comfac/((sh-sqmh)**2+hs**2)
33986 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
33987 & facbw=0d0
33988C...PS: Only use fixed-width when using SLHA decay table for this Higgs
33989 IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
33990 wdtp14=0d0
33991 DO 355 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
33992 IF(kfdp(idc,1).EQ.22.AND.kfdp(idc,2).EQ.22.AND.
33993 & kfdp(idc,3).EQ.0) wdtp14=pmas(kfhigg,2)*brat(idc)
33994 355 CONTINUE
33995 IF(wdtp14.EQ.0d0) CALL pyerrm(26,
33996 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
33997 hi=shr*wdtp14*2d0
33998 ELSE
33999 hi=shr*wdtp(14)*2d0
34000 ENDIF
34001 IF(kfac(1,22)*kfac(2,22).EQ.0) GOTO 360
34002 nchn=nchn+1
34003 isig(nchn,1)=22
34004 isig(nchn,2)=22
34005 isig(nchn,3)=1
34006 sigh(nchn)=hi*facbw*hf
34007 360 CONTINUE
34008
34009 ELSEIF(isub.EQ.110) THEN
34010C...f + fbar -> gamma + h0
34011 thuh=max(th*uh,sh*ckin(3)**2)
34012 fachg=comfac*(3d0*aem**4)/(2d0*paru(1)**2*xw*sqmw)*sh*thuh
34013 fachg=fachg*wids(kfhigg,2)
34014C...Calculate loop contributions for intermediate gamma* and Z0
34015 cigtot=dcmplx(0d0,0d0)
34016 ciztot=dcmplx(0d0,0d0)
34017 jmax=3*mstp(1)+1
34018 DO 370 j=1,jmax
34019 IF(j.LE.2*mstp(1)) THEN
34020 fnc=1d0
34021 ej=kchg(j,1)/3d0
34022 aj=sign(1d0,ej+0.1d0)
34023 vj=aj-4d0*ej*xwv
34024 balp=sqm4/(2d0*pmas(j,1))**2
34025 bbet=sh/(2d0*pmas(j,1))**2
34026 ELSEIF(j.LE.3*mstp(1)) THEN
34027 fnc=3d0
34028 jl=2*(j-2*mstp(1))-1
34029 ej=kchg(10+jl,1)/3d0
34030 aj=sign(1d0,ej+0.1d0)
34031 vj=aj-4d0*ej*xwv
34032 balp=sqm4/(2d0*pmas(10+jl,1))**2
34033 bbet=sh/(2d0*pmas(10+jl,1))**2
34034 ELSE
34035 balp=sqm4/(2d0*pmas(24,1))**2
34036 bbet=sh/(2d0*pmas(24,1))**2
34037 ENDIF
34038 babi=1d0/(balp-bbet)
34039 IF(balp.LT.1d0) THEN
34040 f0alp=dcmplx(dble(asin(sqrt(balp))),0d0)
34041 f1alp=f0alp**2
34042 ELSE
34043 f0alp=dcmplx(dble(log(sqrt(balp)+sqrt(balp-1d0))),
34044 & -dble(0.5d0*paru(1)))
34045 f1alp=-f0alp**2
34046 ENDIF
34047 f2alp=dble(sqrt(abs(balp-1d0)/balp))*f0alp
34048 IF(bbet.LT.1d0) THEN
34049 f0bet=dcmplx(dble(asin(sqrt(bbet))),0d0)
34050 f1bet=f0bet**2
34051 ELSE
34052 f0bet=dcmplx(dble(log(sqrt(bbet)+sqrt(bbet-1d0))),
34053 & -dble(0.5d0*paru(1)))
34054 f1bet=-f0bet**2
34055 ENDIF
34056 f2bet=dble(sqrt(abs(bbet-1d0)/bbet))*f0bet
34057 IF(j.LE.3*mstp(1)) THEN
34058 fif=dble(0.5d0*babi)+dble(babi**2)*(dble(0.5d0*(1d0-balp+
34059 & bbet))*(f1bet-f1alp)+dble(bbet)*(f2bet-f2alp))
34060 cigtot=cigtot+dble(fnc*ej**2)*fif
34061 ciztot=ciztot+dble(fnc*ej*vj)*fif
34062 ELSE
34063 txw=xw/xw1
34064 cigtot=cigtot-0.5*(dble(babi*(1.5d0+balp))+dble(babi**2)*
34065 & (dble(1.5d0-3d0*balp+4d0*bbet)*(f1bet-f1alp)+
34066 & dble(bbet*(2d0*balp+3d0))*(f2bet-f2alp)))
34067 ciztot=ciztot-dble(0.5d0*babi*xw1)*(dble(5d0-txw+2d0*balp*
34068 & (1d0-txw))*(1d0+dble(2d0*babi*bbet)*(f2bet-f2alp))+
34069 & dble(babi*(4d0*bbet*(3d0-txw)-(2d0*balp-1d0)*(5d0-txw)))*
34070 & (f1bet-f1alp))
34071 ENDIF
34072 370 CONTINUE
34073 cigtot=cigtot/dble(sh)
34074 ciztot=ciztot*dble(xwc)/dcmplx(dble(sh-sqmz),dble(gmmz))
34075C...Loop over initial flavours
34076 DO 380 i=mmina,mmaxa
34077 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 380
34078 ei=kchg(iabs(i),1)/3d0
34079 ai=sign(1d0,ei)
34080 vi=ai-4d0*ei*xwv
34081 fcoi=1d0
34082 IF(iabs(i).LE.10) fcoi=faca/3d0
34083 nchn=nchn+1
34084 isig(nchn,1)=i
34085 isig(nchn,2)=-i
34086 isig(nchn,3)=1
34087 sigh(nchn)=fachg*fcoi*(abs(dble(ei)*cigtot+dble(vi)*
34088 & ciztot)**2+ai**2*abs(ciztot)**2)
34089 380 CONTINUE
34090
34091 ELSEIF(isub.EQ.111) THEN
34092C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34093 IF(mstp(38).NE.0) THEN
34094C...Simple case: only do gg <-> h exactly.
34095 CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34096C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34097 IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34098 wdtp13=0d0
34099 DO 385 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34100 IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34101 & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34102 385 CONTINUE
34103 IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34104 & '(PYSGHG:) did not find Higgs -> g g channel')
34105 facgh=comfac*faca*(2d0/9d0)*as*(wdtp13/sqrt(sqm4))*
34106 & (th**2+uh**2)/(sh*sqm4)
34107 ELSE
34108 facgh=comfac*faca*(2d0/9d0)*as*(wdtp(13)/sqrt(sqm4))*
34109 & (th**2+uh**2)/(sh*sqm4)
34110 ENDIF
34111C...Propagators: as simulated in PYOFSH and as desired
34112 hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34113 gmmhc=sqrt(sqm4)*wdtp(0)
34114 hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34115 & ((sqm4-sqmh)**2+gmmhc**2)
34116 facgh=facgh*hbw4c/hbw4
34117 ELSE
34118C...Messy case: do full loop integrals
34119 a5stur=0d0
34120 a5stui=0d0
34121 DO 390 i=1,2*mstp(1)
34122 sqmq=pmas(i,1)**2
34123 epss=4d0*sqmq/sh
34124 epsh=4d0*sqmq/sqmh
34125 CALL pywaux(1,epss,w1sr,w1si)
34126 CALL pywaux(1,epsh,w1hr,w1hi)
34127 CALL pywaux(2,epss,w2sr,w2si)
34128 CALL pywaux(2,epsh,w2hr,w2hi)
34129 a5stur=a5stur+epsh*(1d0+sh/(th+uh)*(w1sr-w1hr)+
34130 & (0.25d0-sqmq/(th+uh))*(w2sr-w2hr))
34131 a5stui=a5stui+epsh*(sh/(th+uh)*(w1si-w1hi)+
34132 & (0.25d0-sqmq/(th+uh))*(w2si-w2hi))
34133 390 CONTINUE
34134 facgh=comfac*faca/(144d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
34135 & sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)
34136 facgh=facgh*wids(25,2)
34137 ENDIF
34138 DO 400 i=mmina,mmaxa
34139 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
34140 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 400
34141 nchn=nchn+1
34142 isig(nchn,1)=i
34143 isig(nchn,2)=-i
34144 isig(nchn,3)=1
34145 sigh(nchn)=facgh
34146 400 CONTINUE
34147
34148 ELSEIF(isub.EQ.112) THEN
34149C...f + g -> f + h0 (q + g -> q + h0 only)
34150 IF(mstp(38).NE.0) THEN
34151C...Simple case: only do gg <-> h exactly.
34152 CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34153C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34154 IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34155 wdtp13=0d0
34156 DO 405 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34157 IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34158 & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34159 405 CONTINUE
34160 IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34161 & '(PYSGHG:) did not find Higgs -> g g channel')
34162 facqh=comfac*faca*(1d0/12d0)*as*(wdtp13/sqrt(sqm4))*
34163 & (sh**2+uh**2)/(-th*sqm4)
34164 ELSE
34165 facqh=comfac*faca*(1d0/12d0)*as*(wdtp(13)/sqrt(sqm4))*
34166 & (sh**2+uh**2)/(-th*sqm4)
34167 ENDIF
34168C...Propagators: as simulated in PYOFSH and as desired
34169 hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34170 gmmhc=sqrt(sqm4)*wdtp(0)
34171 hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34172 & ((sqm4-sqmh)**2+gmmhc**2)
34173 facqh=facqh*hbw4c/hbw4
34174 ELSE
34175C...Messy case: do full loop integrals
34176 a5tsur=0d0
34177 a5tsui=0d0
34178 DO 410 i=1,2*mstp(1)
34179 sqmq=pmas(i,1)**2
34180 epst=4d0*sqmq/th
34181 epsh=4d0*sqmq/sqmh
34182 CALL pywaux(1,epst,w1tr,w1ti)
34183 CALL pywaux(1,epsh,w1hr,w1hi)
34184 CALL pywaux(2,epst,w2tr,w2ti)
34185 CALL pywaux(2,epsh,w2hr,w2hi)
34186 a5tsur=a5tsur+epsh*(1d0+th/(sh+uh)*(w1tr-w1hr)+
34187 & (0.25d0-sqmq/(sh+uh))*(w2tr-w2hr))
34188 a5tsui=a5tsui+epsh*(th/(sh+uh)*(w1ti-w1hi)+
34189 & (0.25d0-sqmq/(sh+uh))*(w2ti-w2hi))
34190 410 CONTINUE
34191 facqh=comfac*faca/(384d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*
34192 & sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)
34193 facqh=facqh*wids(25,2)
34194 ENDIF
34195 DO 430 i=mmina,mmaxa
34196 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 430
34197 DO 420 isde=1,2
34198 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 420
34199 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 420
34200 nchn=nchn+1
34201 isig(nchn,isde)=i
34202 isig(nchn,3-isde)=21
34203 isig(nchn,3)=1
34204 sigh(nchn)=facqh
34205 420 CONTINUE
34206 430 CONTINUE
34207
34208 ELSEIF(isub.EQ.113) THEN
34209C...g + g -> g + h0
34210 IF(mstp(38).NE.0) THEN
34211C...Simple case: only do gg <-> h exactly.
34212 CALL pywidt(kfhigg,sqm4,wdtp,wdte)
34213C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34214 IF (imss(22).GE.1.AND.mwid(kfhigg).EQ.2) THEN
34215 wdtp13=0d0
34216 DO 435 idc=mdcy(kfhigg,2),mdcy(kfhigg,2)+mdcy(kfhigg,3)-1
34217 IF(kfdp(idc,1).EQ.21.AND.kfdp(idc,2).EQ.21.AND.
34218 & kfdp(idc,3).EQ.0) wdtp13=pmas(kfhigg,2)*brat(idc)
34219 435 CONTINUE
34220 IF(wdtp13.EQ.0d0) CALL pyerrm(26,
34221 & '(PYSGHG:) did not find Higgs -> g g channel')
34222 facgh=comfac*faca*(3d0/16d0)*as*(wdtp13/sqrt(sqm4))*
34223 & (sh**4+th**4+uh**4+sqm4**4)/(sh*th*uh*sqm4)
34224 ELSE
34225 facgh=comfac*faca*(3d0/16d0)*as*(wdtp(13)/sqrt(sqm4))*
34226 & (sh**4+th**4+uh**4+sqm4**4)/(sh*th*uh*sqm4)
34227 ENDIF
34228C...Propagators: as simulated in PYOFSH and as desired
34229 hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
34230 gmmhc=sqrt(sqm4)*wdtp(0)
34231 hbw4c=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))/
34232 & ((sqm4-sqmh)**2+gmmhc**2)
34233 facgh=facgh*hbw4c/hbw4
34234 ELSE
34235C...Messy case: do full loop integrals
34236 a2stur=0d0
34237 a2stui=0d0
34238 a2ustr=0d0
34239 a2usti=0d0
34240 a2tusr=0d0
34241 a2tusi=0d0
34242 a4stur=0d0
34243 a4stui=0d0
34244 DO 440 i=1,2*mstp(1)
34245 sqmq=pmas(i,1)**2
34246 epss=4d0*sqmq/sh
34247 epst=4d0*sqmq/th
34248 epsu=4d0*sqmq/uh
34249 epsh=4d0*sqmq/sqmh
34250 IF(epsh.LT.1d-6) GOTO 440
34251 CALL pywaux(1,epss,w1sr,w1si)
34252 CALL pywaux(1,epst,w1tr,w1ti)
34253 CALL pywaux(1,epsu,w1ur,w1ui)
34254 CALL pywaux(1,epsh,w1hr,w1hi)
34255 CALL pywaux(2,epss,w2sr,w2si)
34256 CALL pywaux(2,epst,w2tr,w2ti)
34257 CALL pywaux(2,epsu,w2ur,w2ui)
34258 CALL pywaux(2,epsh,w2hr,w2hi)
34259 CALL pyi3au(epss,th/uh,y3stur,y3stui)
34260 CALL pyi3au(epss,uh/th,y3sutr,y3suti)
34261 CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)
34262 CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)
34263 CALL pyi3au(epsu,sh/th,y3ustr,y3usti)
34264 CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)
34265 CALL pyi3au(epsh,sqmh/sh*th/uh,yhstur,yhstui)
34266 CALL pyi3au(epsh,sqmh/sh*uh/th,yhsutr,yhsuti)
34267 CALL pyi3au(epsh,sqmh/th*sh/uh,yhtsur,yhtsui)
34268 CALL pyi3au(epsh,sqmh/th*uh/sh,yhtusr,yhtusi)
34269 CALL pyi3au(epsh,sqmh/uh*sh/th,yhustr,yhusti)
34270 CALL pyi3au(epsh,sqmh/uh*th/sh,yhutsr,yhutsi)
34271 w3stur=yhstur-y3stur-y3utsr
34272 w3stui=yhstui-y3stui-y3utsi
34273 w3sutr=yhsutr-y3sutr-y3tusr
34274 w3suti=yhsuti-y3suti-y3tusi
34275 w3tsur=yhtsur-y3tsur-y3ustr
34276 w3tsui=yhtsui-y3tsui-y3usti
34277 w3tusr=yhtusr-y3tusr-y3sutr
34278 w3tusi=yhtusi-y3tusi-y3suti
34279 w3ustr=yhustr-y3ustr-y3tsur
34280 w3usti=yhusti-y3usti-y3tsui
34281 w3utsr=yhutsr-y3utsr-y3stur
34282 w3utsi=yhutsi-y3utsi-y3stui
34283 b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2d0*th*uh*
34284 & (uh+2d0*sh)/(sh+uh)**2*(w1tr-w1hr)+(sqmq-sh/4d0)*
34285 & (0.5d0*w2sr+0.5d0*w2hr-w2tr+w3stur)+sh2*(2d0*sqmq/
34286 & (sh+uh)**2-0.5d0/(sh+uh))*(w2tr-w2hr)+0.5d0*th*uh/sh*
34287 & (w2hr-2d0*w2tr)+0.125d0*(sh-12d0*sqmq-4d0*th*uh/sh)*w3tsur)
34288 b2stui=sqmq/sqmh**2*(2d0*th*uh*(uh+2d0*sh)/(sh+uh)**2*
34289 & (w1ti-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ti+
34290 & w3stui)+sh2*(2d0*sqmq/(sh+uh)**2-0.5d0/(sh+uh))*
34291 & (w2ti-w2hi)+0.5d0*th*uh/sh*(w2hi-2d0*w2ti)+0.125d0*
34292 & (sh-12d0*sqmq-4d0*th*uh/sh)*w3tsui)
34293 b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2d0*uh*th*
34294 & (th+2d0*sh)/(sh+th)**2*(w1ur-w1hr)+(sqmq-sh/4d0)*
34295 & (0.5d0*w2sr+0.5d0*w2hr-w2ur+w3sutr)+sh2*(2d0*sqmq/
34296 & (sh+th)**2-0.5d0/(sh+th))*(w2ur-w2hr)+0.5d0*uh*th/sh*
34297 & (w2hr-2d0*w2ur)+0.125d0*(sh-12d0*sqmq-4d0*uh*th/sh)*w3ustr)
34298 b2suti=sqmq/sqmh**2*(2d0*uh*th*(th+2d0*sh)/(sh+th)**2*
34299 & (w1ui-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ui+
34300 & w3suti)+sh2*(2d0*sqmq/(sh+th)**2-0.5d0/(sh+th))*
34301 & (w2ui-w2hi)+0.5d0*uh*th/sh*(w2hi-2d0*w2ui)+0.125d0*
34302 & (sh-12d0*sqmq-4d0*uh*th/sh)*w3usti)
34303 b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2d0*sh*uh*
34304 & (uh+2d0*th)/(th+uh)**2*(w1sr-w1hr)+(sqmq-th/4d0)*
34305 & (0.5d0*w2tr+0.5d0*w2hr-w2sr+w3tsur)+th2*(2d0*sqmq/
34306 & (th+uh)**2-0.5d0/(th+uh))*(w2sr-w2hr)+0.5d0*sh*uh/th*
34307 & (w2hr-2d0*w2sr)+0.125d0*(th-12d0*sqmq-4d0*sh*uh/th)*w3stur)
34308 b2tsui=sqmq/sqmh**2*(2d0*sh*uh*(uh+2d0*th)/(th+uh)**2*
34309 & (w1si-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2si+
34310 & w3tsui)+th2*(2d0*sqmq/(th+uh)**2-0.5d0/(th+uh))*
34311 & (w2si-w2hi)+0.5d0*sh*uh/th*(w2hi-2d0*w2si)+0.125d0*
34312 & (th-12d0*sqmq-4d0*sh*uh/th)*w3stui)
34313 b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2d0*uh*sh*
34314 & (sh+2d0*th)/(th+sh)**2*(w1ur-w1hr)+(sqmq-th/4d0)*
34315 & (0.5d0*w2tr+0.5d0*w2hr-w2ur+w3tusr)+th2*(2d0*sqmq/
34316 & (th+sh)**2-0.5d0/(th+sh))*(w2ur-w2hr)+0.5d0*uh*sh/th*
34317 & (w2hr-2d0*w2ur)+0.125d0*(th-12d0*sqmq-4d0*uh*sh/th)*w3utsr)
34318 b2tusi=sqmq/sqmh**2*(2d0*uh*sh*(sh+2d0*th)/(th+sh)**2*
34319 & (w1ui-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2ui+
34320 & w3tusi)+th2*(2d0*sqmq/(th+sh)**2-0.5d0/(th+sh))*
34321 & (w2ui-w2hi)+0.5d0*uh*sh/th*(w2hi-2d0*w2ui)+0.125d0*
34322 & (th-12d0*sqmq-4d0*uh*sh/th)*w3utsi)
34323 b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2d0*sh*th*
34324 & (th+2d0*uh)/(uh+th)**2*(w1sr-w1hr)+(sqmq-uh/4d0)*
34325 & (0.5d0*w2ur+0.5d0*w2hr-w2sr+w3ustr)+uh2*(2d0*sqmq/
34326 & (uh+th)**2-0.5d0/(uh+th))*(w2sr-w2hr)+0.5d0*sh*th/uh*
34327 & (w2hr-2d0*w2sr)+0.125d0*(uh-12d0*sqmq-4d0*sh*th/uh)*w3sutr)
34328 b2usti=sqmq/sqmh**2*(2d0*sh*th*(th+2d0*uh)/(uh+th)**2*
34329 & (w1si-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2si+
34330 & w3usti)+uh2*(2d0*sqmq/(uh+th)**2-0.5d0/(uh+th))*
34331 & (w2si-w2hi)+0.5d0*sh*th/uh*(w2hi-2d0*w2si)+0.125d0*
34332 & (uh-12d0*sqmq-4d0*sh*th/uh)*w3suti)
34333 b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2d0*th*sh*
34334 & (sh+2d0*uh)/(uh+sh)**2*(w1tr-w1hr)+(sqmq-uh/4d0)*
34335 & (0.5d0*w2ur+0.5d0*w2hr-w2tr+w3utsr)+uh2*(2d0*sqmq/
34336 & (uh+sh)**2-0.5d0/(uh+sh))*(w2tr-w2hr)+0.5d0*th*sh/uh*
34337 & (w2hr-2d0*w2tr)+0.125d0*(uh-12d0*sqmq-4d0*th*sh/uh)*w3tusr)
34338 b2utsi=sqmq/sqmh**2*(2d0*th*sh*(sh+2d0*uh)/(uh+sh)**2*
34339 & (w1ti-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2ti+
34340 & w3utsi)+uh2*(2d0*sqmq/(uh+sh)**2-0.5d0/(uh+sh))*
34341 & (w2ti-w2hi)+0.5d0*th*sh/uh*(w2hi-2d0*w2ti)+0.125d0*
34342 & (uh-12d0*sqmq-4d0*th*sh/uh)*w3tusi)
34343 b4stur=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
34344 & (w2sr-w2hr+w3stur))
34345 b4stui=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2si-w2hi+w3stui)
34346 b4tusr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
34347 & (w2tr-w2hr+w3tusr))
34348 b4tusi=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ti-w2hi+w3tusi)
34349 b4ustr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*
34350 & (w2ur-w2hr+w3ustr))
34351 b4usti=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ui-w2hi+w3usti)
34352 a2stur=a2stur+b2stur+b2sutr
34353 a2stui=a2stui+b2stui+b2suti
34354 a2ustr=a2ustr+b2ustr+b2utsr
34355 a2usti=a2usti+b2usti+b2utsi
34356 a2tusr=a2tusr+b2tusr+b2tsur
34357 a2tusi=a2tusi+b2tusi+b2tsui
34358 a4stur=a4stur+b4stur+b4ustr+b4tusr
34359 a4stui=a4stui+b4stui+b4usti+b4tusi
34360 440 CONTINUE
34361 facgh=comfac*faca*3d0/(128d0*paru(1)**2)*aem/xw*as**3*
34362 & sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+
34363 & a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)
34364 facgh=facgh*wids(25,2)
34365 ENDIF
34366 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 450
34367 nchn=nchn+1
34368 isig(nchn,1)=21
34369 isig(nchn,2)=21
34370 isig(nchn,3)=1
34371 sigh(nchn)=facgh
34372 450 CONTINUE
34373 ENDIF
34374
34375 ELSEIF(isub.LE.170) THEN
34376 IF(isub.EQ.121) THEN
34377C...g + g -> Q + Qbar + h0
34378 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 460
34379 ia=kfpr(isubsv,2)
34380 pmf=pymrun(ia,sh)
34381 facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
34382 & (0.5d0*pmf/pmas(24,1))**2
34383 wid2=1d0
34384 IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
34385 facqqh=facqqh*wid2
34386 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
34387 ikfi=1
34388 IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
34389 IF(ia.GT.10) ikfi=3
34390 facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
34391 IF(imss(1).NE.0.AND.ia.EQ.5) THEN
34392 facqqh=facqqh/(1d0+rmss(41))**2
34393 IF(ihigg.NE.3) THEN
34394 facqqh=facqqh*(1d0+rmss(41)*paru(152+10*ihigg)/
34395 & paru(151+10*ihigg))**2
34396 ENDIF
34397 ENDIF
34398 ENDIF
34399 CALL pyqqbh(wtqqbh)
34400 CALL pywidt(kfhigg,sh,wdtp,wdte)
34401 hs=shr*wdtp(0)
34402 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34403 facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
34404 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34405 & facbw=0d0
34406 nchn=nchn+1
34407 isig(nchn,1)=21
34408 isig(nchn,2)=21
34409 isig(nchn,3)=1
34410 sigh(nchn)=facqqh*wtqqbh*facbw
34411 460 CONTINUE
34412
34413 ELSEIF(isub.EQ.122) THEN
34414C...q + qbar -> Q + Qbar + h0
34415 ia=kfpr(isubsv,2)
34416 pmf=pymrun(ia,sh)
34417 facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*
34418 & (0.5d0*pmf/pmas(24,1))**2
34419 wid2=1d0
34420 IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)
34421 facqqh=facqqh*wid2
34422 IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN
34423 ikfi=1
34424 IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2
34425 IF(ia.GT.10) ikfi=3
34426 facqqh=facqqh*paru(150+10*ihigg+ikfi)**2
34427 IF(imss(1).NE.0.AND.ia.EQ.5) THEN
34428 facqqh=facqqh/(1d0+rmss(41))**2
34429 IF(ihigg.NE.3) THEN
34430 facqqh=facqqh*(1d0+rmss(41)*paru(152+10*ihigg)/
34431 & paru(151+10*ihigg))**2
34432 ENDIF
34433 ENDIF
34434 ENDIF
34435 CALL pyqqbh(wtqqbh)
34436 CALL pywidt(kfhigg,sh,wdtp,wdte)
34437 hs=shr*wdtp(0)
34438 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34439 facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
34440 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34441 & facbw=0d0
34442 DO 470 i=mmina,mmaxa
34443 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
34444 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 470
34445 nchn=nchn+1
34446 isig(nchn,1)=i
34447 isig(nchn,2)=-i
34448 isig(nchn,3)=1
34449 sigh(nchn)=facqqh*wtqqbh*facbw
34450 470 CONTINUE
34451
34452 ELSEIF(isub.EQ.123) THEN
34453C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34454C...inner process)
34455 facnor=comfac*(4d0*paru(1)*aem/(xw*xw1))**3*sqmz/32d0
34456 IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
34457 & paru(154+10*ihigg)**2
34458 facprp=1d0/((vint(215)-vint(204)**2)*
34459 & (vint(216)-vint(209)**2))**2
34460 faczz1=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
34461 faczz2=facnor*facprp*vint(217)*vint(218)
34462 CALL pywidt(kfhigg,sh,wdtp,wdte)
34463 hs=shr*wdtp(0)
34464 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34465 facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
34466 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34467 & facbw=0d0
34468 DO 490 i=mmin1,mmax1
34469 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 490
34470 ia=iabs(i)
34471 DO 480 j=mmin2,mmax2
34472 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 480
34473 ja=iabs(j)
34474 ei=kchg(ia,1)*isign(1,i)/3d0
34475 ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)
34476 vi=ai-4d0*ei*xwv
34477 ej=kchg(ja,1)*isign(1,j)/3d0
34478 aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)
34479 vj=aj-4d0*ej*xwv
34480 faclr1=(vi**2+ai**2)*(vj**2+aj**2)+4d0*vi*ai*vj*aj
34481 faclr2=(vi**2+ai**2)*(vj**2+aj**2)-4d0*vi*ai*vj*aj
34482 nchn=nchn+1
34483 isig(nchn,1)=i
34484 isig(nchn,2)=j
34485 isig(nchn,3)=1
34486 sigh(nchn)=(faclr1*faczz1+faclr2*faczz2)*facbw
34487 480 CONTINUE
34488 490 CONTINUE
34489
34490 ELSEIF(isub.EQ.124) THEN
34491C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34492C...inner process)
34493 facnor=comfac*(4d0*paru(1)*aem/xw)**3*sqmw
34494 IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*
34495 & paru(155+10*ihigg)**2
34496 facprp=1d0/((vint(215)-vint(204)**2)*
34497 & (vint(216)-vint(209)**2))**2
34498 facww=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)
34499 CALL pywidt(kfhigg,sh,wdtp,wdte)
34500 hs=shr*wdtp(0)
34501 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
34502 facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)
34503 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34504 & facbw=0d0
34505 DO 510 i=mmin1,mmax1
34506 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 510
34507 ei=sign(1d0,dble(i))*kchg(iabs(i),1)
34508 DO 500 j=mmin2,mmax2
34509 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 500
34510 ej=sign(1d0,dble(j))*kchg(iabs(j),1)
34511 IF(ei*ej.GT.0d0) GOTO 500
34512 faclr=vint(180+i)*vint(180+j)
34513 nchn=nchn+1
34514 isig(nchn,1)=i
34515 isig(nchn,2)=j
34516 isig(nchn,3)=1
34517 sigh(nchn)=faclr*facww*facbw
34518 500 CONTINUE
34519 510 CONTINUE
34520
34521 ELSEIF(isub.EQ.143) THEN
34522C...f + fbar' -> H+/-
34523 sqmhc=pmas(37,1)**2
34524 CALL pywidt(37,sh,wdtp,wdte)
34525 hs=shr*wdtp(0)
34526 facbw=4d0*comfac/((sh-sqmhc)**2+hs**2)
34527 hp=aem/(8d0*xw)*sh/sqmw*sh
34528 DO 530 i=mmin1,mmax1
34529 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 530
34530 ia=iabs(i)
34531 im=(mod(ia,10)+1)/2
34532 DO 520 j=mmin2,mmax2
34533 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 520
34534 ja=iabs(j)
34535 jm=(mod(ja,10)+1)/2
34536 IF(i*j.GT.0.OR.ia.EQ.ja.OR.im.NE.jm) GOTO 520
34537 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
34538 & GOTO 520
34539 IF(mod(ia,2).EQ.0) THEN
34540 iu=ia
34541 il=ja
34542 ELSE
34543 iu=ja
34544 il=ia
34545 ENDIF
34546 rml=pymrun(il,sh)**2/sh
34547 rmu=pymrun(iu,sh)**2/sh
34548 hi=hp*(rml*paru(141)**2+rmu/paru(141)**2)
34549 IF(ia.LE.10) hi=hi*faca/3d0
34550 kchhc=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
34551 hf=shr*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))
34552 nchn=nchn+1
34553 isig(nchn,1)=i
34554 isig(nchn,2)=j
34555 isig(nchn,3)=1
34556 sigh(nchn)=hi*facbw*hf
34557 520 CONTINUE
34558 530 CONTINUE
34559
34560 ELSEIF(isub.EQ.161) THEN
34561C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34562C...(choice of only b and t to avoid kinematics problems)
34563 fhcq=comfac*faca*as*aem/xw*1d0/24
34564C...H propagator: as simulated in PYOFSH and as desired
34565 sqmhc=pmas(37,1)**2
34566 gmmhc=pmas(37,1)*pmas(37,2)
34567 hbw4=gmmhc/((sqm4-sqmhc)**2+gmmhc**2)
34568 CALL pywidt(37,sqm4,wdtp,wdte)
34569 gmmhcc=sqrt(sqm4)*wdtp(0)
34570 hbw4c=gmmhcc/((sqm4-sqmhc)**2+gmmhcc**2)
34571 fhcq=fhcq*hbw4c/hbw4
34572 q2rm=sh
34573 IF(mstp(32).EQ.12) q2rm=parp(194)
34574 DO 550 i=mmina,mmaxa
34575 ia=iabs(i)
34576 IF(ia.NE.5) GOTO 550
34577 sqml=pymrun(ia,q2rm)**2
34578 iua=ia+mod(ia,2)
34579 sqmq=pymrun(iua,q2rm)**2
34580 fachcq=fhcq*(sqml*paru(141)**2+sqmq/paru(141)**2)/sqmw*
34581 & (sh/(sqmq-uh)+2d0*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh-
34582 & 2d0*sqmq/(sqmq-uh)+2d0*(sqmhc-uh)/(sqmq-uh)*
34583 & (sqmhc-sqmq-sh)/sh)
34584 kchhc=isign(1,kchg(ia,1)*isign(1,i))
34585 DO 540 isde=1,2
34586 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 540
34587 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 540
34588 nchn=nchn+1
34589 isig(nchn,isde)=i
34590 isig(nchn,3-isde)=21
34591 isig(nchn,3)=1
34592 sigh(nchn)=fachcq*wids(37,(5-kchhc)/2)
34593 IF(iua.EQ.6) sigh(nchn)=sigh(nchn)*wids(6,(5+kchhc)/2)
34594 540 CONTINUE
34595 550 CONTINUE
34596 ENDIF
34597
34598 ELSEIF(isub.LE.402) THEN
34599 IF(isub.EQ.401) THEN
34600C... g + g -> t + bbar + H-
34601 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 560
34602 ia=kfpr(isubsv,2)
34603 CALL pystbh(wttbh)
34604 CALL pywidt(kfhigg,sh,wdtp,wdte)
34605 hs=shr*wdtp(0)
34606 facbw=(1d0/paru(1))*vint(2)*hs/((sh-sqmh)**2+hs**2)
34607 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34608 & facbw=0d0
34609 nchn=nchn+1
34610 isig(nchn,1)=21
34611 isig(nchn,2)=21
34612 isig(nchn,3)=1
34613 sigh(nchn)=2d0*comfac*wttbh*facbw
34614c Since we don't know yet if H+ or H-, assume H+
34615c when calculating suppression due to closed channels.
34616 sigh(nchn)=sigh(nchn)*wids(37,2)*wids(6,3)
34617 IF(abs(wids(37,2)-wids(37,3))
34618 & .GE.1d-6*(wids(37,2)+wids(37,3)).OR.
34619 & abs(wids(6,2)-wids(6,3))
34620 & .GE.1d-6*(wids(6,2)+wids(6,3))) THEN
34621 WRITE(*,*)'Error: Process 401 cannot handle different'
34622 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34623 WRITE(*,*)'Execution stopped.'
34624 CALL pystop(108)
34625 END IF
34626 560 CONTINUE
34627
34628 ELSEIF(isub.EQ.402) THEN
34629C... q + qbar -> t + bbar + H-
34630 ia=kfpr(isubsv,2)
34631 CALL pystbh(wttbh)
34632 CALL pywidt(kfhigg,sh,wdtp,wdte)
34633 hs=shr*wdtp(0)
34634 facbw=(1d0/paru(1))*vint(2)*hs/((sh-sqmh)**2+hs**2)
34635 IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))
34636 & facbw=0d0
34637 DO 570 i=mmina,mmaxa
34638 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
34639 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 570
34640 nchn=nchn+1
34641 isig(nchn,1)=i
34642 isig(nchn,2)=-i
34643 isig(nchn,3)=1
34644 sigh(nchn)=2d0*comfac*wttbh*facbw
34645c Since we don't know yet if H+ or H-, assume H+
34646c when calculating suppression due to closed channels.
34647 sigh(nchn)=sigh(nchn)*wids(37,2)*wids(6,3)
34648 IF(abs(wids(37,2)-wids(37,3))/(wids(37,2)+wids(37,3))
34649 & .GE.1d-6.OR.
34650 & abs(wids(6,2)-wids(6,3))/(wids(6,2)+wids(6,3))
34651 & .GE.1d-6) THEN
34652 WRITE(*,*)'Error: Process 402 cannot handle different'
34653 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34654 WRITE(*,*)'Execution stopped.'
34655 CALL pystop(108)
34656 END IF
34657 570 CONTINUE
34658 ENDIF
34659 ENDIF
34660
34661 RETURN
34662 END
34663
34664C*********************************************************************
34665
34666C...PYSGSU
34667C...Subprocess cross sections for SUSY processes,
34668C...including Higgs pair production.
34669C...Auxiliary to PYSIGH.
34670
34671 SUBROUTINE pysgsu(NCHN,SIGS)
34672
34673C...Double precision and integer declarations
34674 IMPLICIT DOUBLE PRECISION(a-h, o-z)
34675 IMPLICIT INTEGER(I-N)
34676 INTEGER PYK,PYCHGE,PYCOMP
34677C...Parameter statement to help give large particle numbers.
34678 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
34679 &kexcit=4000000,kdimen=5000000)
34680C...Commonblocks
34681 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
34682 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
34683 common/pypars/mstp(200),parp(200),msti(200),pari(200)
34684 common/pyint1/mint(400),vint(400)
34685 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
34686 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
34687 common/pyint4/mwid(500),wids(500,5)
34688 common/pymssm/imss(0:99),rmss(0:99)
34689 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
34690 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
34691 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
34692 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
34693 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
34694 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
34695 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
34696 &/pyint4/,/pymssm/,/pyssmt/,/pysgcm/
34697C...Local arrays and complex variables
34698 dimension wdtp(0:400),wdte(0:400,0:5)
34699 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34700 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34701 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34702
34703CMRENNA++
34704C...Z and W width, combinations of weak mixing angle
34705 zwid=pmas(23,2)
34706 wwid=pmas(24,2)
34707 tanw=sqrt(xw/xw1)
34708 ct2w=(1d0-2d0*xw)/(2d0*xw/tanw)
34709
34710C...Convert almost equivalent SUSY processes into each other
34711C...Extract differences in flavours and couplings
34712
34713C...Sleptons and sneutrinos
34714 IF(isub.EQ.201.OR.isub.EQ.204.OR.isub.EQ.207) THEN
34715 kfid=mod(kfpr(isub,1),ksusy1)
34716 isub=201
34717 ilr=0
34718 ELSEIF(isub.EQ.202.OR.isub.EQ.205.OR.isub.EQ.208) THEN
34719 kfid=mod(kfpr(isub,1),ksusy1)
34720 isub=201
34721 ilr=1
34722 ELSEIF(isub.EQ.203.OR.isub.EQ.206.OR.isub.EQ.209) THEN
34723 kfid=mod(kfpr(isub,1),ksusy1)
34724 isub=203
34725 ELSEIF(isub.GE.210.AND.isub.LE.212) THEN
34726 IF(isub.EQ.210) THEN
34727 rkf=2.0d0
34728 ELSEIF(isub.EQ.211) THEN
34729 rkf=sfmix(15,1)**2
34730 ELSEIF(isub.EQ.212) THEN
34731 rkf=sfmix(15,2)**2
34732 ENDIF
34733 isub=210
34734 ELSEIF(isub.EQ.213.OR.isub.EQ.214) THEN
34735 IF(isub.EQ.213) THEN
34736 kfid=mod(kfpr(isub,1),ksusy1)
34737 rkf=2.0d0
34738 ELSEIF(isub.EQ.214) THEN
34739 kfid=16
34740 rkf=1.0d0
34741 ENDIF
34742 isub=213
34743
34744C...Neutralinos
34745 ELSEIF(isub.GE.216.AND.isub.LE.225) THEN
34746 IF(isub.EQ.216) THEN
34747 izid1=1
34748 izid2=1
34749 ELSEIF(isub.EQ.217) THEN
34750 izid1=2
34751 izid2=2
34752 ELSEIF(isub.EQ.218) THEN
34753 izid1=3
34754 izid2=3
34755 ELSEIF(isub.EQ.219) THEN
34756 izid1=4
34757 izid2=4
34758 ELSEIF(isub.EQ.220) THEN
34759 izid1=1
34760 izid2=2
34761 ELSEIF(isub.EQ.221) THEN
34762 izid1=1
34763 izid2=3
34764 ELSEIF(isub.EQ.222) THEN
34765 izid1=1
34766 izid2=4
34767 ELSEIF(isub.EQ.223) THEN
34768 izid1=2
34769 izid2=3
34770 ELSEIF(isub.EQ.224) THEN
34771 izid1=2
34772 izid2=4
34773 ELSEIF(isub.EQ.225) THEN
34774 izid1=3
34775 izid2=4
34776 ENDIF
34777 isub=216
34778
34779C...Charginos
34780 ELSEIF(isub.GE.226.AND.isub.LE.228) THEN
34781 IF(isub.EQ.226) THEN
34782 izid1=1
34783 izid2=1
34784 ELSEIF(isub.EQ.227) THEN
34785 izid1=2
34786 izid2=2
34787 ELSEIF(isub.EQ.228) THEN
34788 izid1=1
34789 izid2=2
34790 ENDIF
34791 isub=226
34792
34793C...Neutralino + chargino
34794 ELSEIF(isub.GE.229.AND.isub.LE.236) THEN
34795 IF(isub.EQ.229) THEN
34796 izid1=1
34797 izid2=1
34798 ELSEIF(isub.EQ.230) THEN
34799 izid1=1
34800 izid2=2
34801 ELSEIF(isub.EQ.231) THEN
34802 izid1=1
34803 izid2=3
34804 ELSEIF(isub.EQ.232) THEN
34805 izid1=1
34806 izid2=4
34807 ELSEIF(isub.EQ.233) THEN
34808 izid1=2
34809 izid2=1
34810 ELSEIF(isub.EQ.234) THEN
34811 izid1=2
34812 izid2=2
34813 ELSEIF(isub.EQ.235) THEN
34814 izid1=2
34815 izid2=3
34816 ELSEIF(isub.EQ.236) THEN
34817 izid1=2
34818 izid2=4
34819 ENDIF
34820 isub=229
34821
34822C...Gluino + neutralino
34823 ELSEIF(isub.GE.237.AND.isub.LE.240) THEN
34824 IF(isub.EQ.237) THEN
34825 izid=1
34826 ELSEIF(isub.EQ.238) THEN
34827 izid=2
34828 ELSEIF(isub.EQ.239) THEN
34829 izid=3
34830 ELSEIF(isub.EQ.240) THEN
34831 izid=4
34832 ENDIF
34833 isub=237
34834
34835C...Gluino + chargino
34836 ELSEIF(isub.GE.241.AND.isub.LE.242) THEN
34837 IF(isub.EQ.241) THEN
34838 izid=1
34839 ELSEIF(isub.EQ.242) THEN
34840 izid=2
34841 ENDIF
34842 isub=241
34843
34844C...Squark + neutralino
34845 ELSEIF(isub.GE.246.AND.isub.LE.253) THEN
34846 ilr=0
34847 IF(mod(isub,2).NE.0) ilr=1
34848 IF(isub.LE.247) THEN
34849 izid=1
34850 ELSEIF(isub.LE.249) THEN
34851 izid=2
34852 ELSEIF(isub.LE.251) THEN
34853 izid=3
34854 ELSEIF(isub.LE.253) THEN
34855 izid=4
34856 ENDIF
34857 isub=246
34858 rkf=5d0
34859
34860C...Squark + chargino
34861 ELSEIF(isub.GE.254.AND.isub.LE.257) THEN
34862 IF(isub.LE.255) THEN
34863 izid=1
34864 ELSEIF(isub.LE.257) THEN
34865 izid=2
34866 ENDIF
34867 IF(mod(isub,2).EQ.0) THEN
34868 ilr=0
34869 ELSE
34870 ilr=1
34871 ENDIF
34872 isub=254
34873 rkf=5d0
34874
34875C...Squark + gluino
34876 ELSEIF(isub.EQ.258.OR.isub.EQ.259) THEN
34877 isub=258
34878 rkf=4d0
34879
34880C...Stops
34881 ELSEIF(isub.EQ.261.OR.isub.EQ.262) THEN
34882 ilr=0
34883 IF(isub.EQ.262) ilr=1
34884 isub=261
34885 ELSEIF(isub.EQ.265) THEN
34886 isub=264
34887
34888C...Squarks
34889 ELSEIF(isub.GE.271.AND.isub.LE.280) THEN
34890 ilr=0
34891 IF(isub.LE.273) THEN
34892 IF(isub.EQ.273) ilr=1
34893 isub=271
34894 rkf=16d0
34895 ELSEIF(isub.LE.276) THEN
34896 IF(isub.EQ.276) ilr=1
34897 isub=274
34898 rkf=16d0
34899 ELSEIF(isub.LE.278) THEN
34900 IF(isub.EQ.278) ilr=1
34901 isub=277
34902 rkf=4d0
34903 ELSE
34904 IF(isub.EQ.280) ilr=1
34905 isub=279
34906 rkf=4d0
34907 ENDIF
34908C...Sbottoms
34909 ELSEIF(isub.GE.281.AND.isub.LE.296) THEN
34910 ilr=0
34911 IF(isub.LE.283) THEN
34912 IF(isub.EQ.283) ilr=1
34913 isub=271
34914 rkf=4d0
34915 ELSEIF(isub.LE.286) THEN
34916 IF(isub.EQ.286) ilr=1
34917 isub=274
34918 rkf=4d0
34919 ELSEIF(isub.LE.288) THEN
34920 IF(isub.EQ.288) ilr=1
34921 isub=277
34922 rkf=1d0
34923 ELSEIF(isub.LE.290) THEN
34924 IF(isub.EQ.290) ilr=1
34925 isub=279
34926 rkf=1d0
34927 ELSEIF(isub.LE.293) THEN
34928 IF(isub.EQ.293) ilr=1
34929 isub=271
34930 rkf=1d0
34931 ELSEIF(isub.EQ.296) THEN
34932 ilr=1
34933 isub=274
34934 rkf=1d0
34935C...Squark + gluino
34936 ELSEIF(isub.EQ.294.OR.isub.EQ.295) THEN
34937 isub=258
34938 rkf=1d0
34939 ENDIF
34940C...H+/- + H0
34941 ELSEIF(isub.EQ.297.OR.isub.EQ.298) THEN
34942 IF(isub.EQ.297) THEN
34943 rkf=.5d0*paru(195)**2
34944 ELSEIF(isub.EQ.298) THEN
34945 rkf=.5d0*(1d0-paru(195)**2)
34946 ENDIF
34947 isub=210
34948C...A0 + H0
34949 ELSEIF(isub.EQ.299.OR.isub.EQ.300) THEN
34950 IF(isub.EQ.299) THEN
34951 rkf=paru(186)**2
34952 kfid=25
34953 ELSEIF(isub.EQ.300) THEN
34954 rkf=paru(187)**2
34955 kfid=35
34956 ENDIF
34957 isub=213
34958C...H+ + H-
34959 ELSEIF(isub.EQ.301) THEN
34960 kfid=37
34961 rkf=1d0
34962 isub=201
34963 ENDIF
34964
34965C...Supersymmetric processes - all of type 2 -> 2 :
34966C...correct final-state Breit-Wigners from fixed to running width.
34967 IF(mstp(42).GT.0) THEN
34968 DO 100 i=1,2
34969 kflw=kfpr(isubsv,i)
34970 kcw=pycomp(kflw)
34971 IF(pmas(kcw,2).LT.parp(41)) GOTO 100
34972 IF(i.EQ.1) sqmi=sqm3
34973 IF(i.EQ.2) sqmi=sqm4
34974 sqms=pmas(kcw,1)**2
34975 gmms=pmas(kcw,1)*pmas(kcw,2)
34976 hbws=gmms/((sqmi-sqms)**2+gmms**2)
34977 CALL pywidt(kflw,sqmi,wdtp,wdte)
34978 gmmi=sqrt(sqmi)*wdtp(0)
34979 hbwi=gmmi/((sqmi-sqms)**2+gmmi**2)
34980 comfac=comfac*(hbwi/hbws)
34981 100 CONTINUE
34982 ENDIF
34983
34984C...Differential cross section expressions.
34985
34986 IF(isub.LE.210) THEN
34987 IF(isub.EQ.201) THEN
34988C...f + fbar -> e_L + e_Lbar
34989 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
34990 DO 130 i=mmin1,mmax1
34991 ia=iabs(i)
34992 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 130
34993 ei=kchg(ia,1)/3d0
34994 tt3i=sign(1d0,ei+1d-6)/2d0
34995 ej=-1d0
34996 tt3j=-1d0/2d0
34997 fcol=1d0
34998C...Color factor for e+ e-
34999 IF(ia.GE.11) fcol=3d0
35000 IF(isubsv.EQ.301) THEN
35001 a1=1d0
35002 a2=0d0
35003 ELSEIF(ilr.EQ.1) THEN
35004 a1=sfmix(kfid,3)**2
35005 a2=sfmix(kfid,4)**2
35006 ELSEIF(ilr.EQ.0) THEN
35007 a1=sfmix(kfid,1)**2
35008 a2=sfmix(kfid,2)**2
35009 ENDIF
35010 xlq=(tt3j-ej*xw)*a1
35011 xrq=(-ej*xw)*a2
35012 xlf=(tt3i-ei*xw)
35013 xrf=(-ei*xw)
35014 taa=(ei*ej)**2*(poll+polr)
35015 tzz=(xlf**2*poll+xrf**2*polr)*(xlq+xrq)**2/xw**2/xw1**2
35016 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*zwid/sh**2)
35017 taz=2d0*ei*ej*(xlq+xrq)*(xlf*poll+xrf*polr)/xw/xw1
35018 taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
35019 tnn=0.0d0
35020 tan=0.0d0
35021 tzn=0.0d0
35022 IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
35023 fac2=sqrt(2d0)
35024 tnn1=0d0
35025 tnn2=0d0
35026 tnn3=0d0
35027 DO 120 ii=1,4
35028 dk=1d0/(th-smz(ii)**2)
35029 flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
35030 & zmix(ii,1))
35031 frek=fac2*tanw*ei*zmix(ii,1)
35032 tnn1=tnn1+flek**2*dk
35033 tnn2=tnn2+frek**2*dk
35034 DO 110 jj=1,4
35035 dl=1d0/(th-smz(jj)**2)
35036 flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
35037 & zmix(jj,1))
35038 frel=fac2*tanw*ej*zmix(jj,1)
35039 tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
35040 110 CONTINUE
35041 120 CONTINUE
35042 tnn=(uh*th-sqm3*sqm4)*(a1**2*tnn1**2*poll+
35043 & a2**2*tnn2**2*polr)
35044 tnn=(tnn+sh*a1*a2*tnn3*((1d0-parj(131))*(1d0-parj(132))+
35045 & (1d0+parj(131))*(1d0+parj(132))))/4d0/xw**2
35046 tzn=(uh*th-sqm3*sqm4)*(xlq+xrq)*
35047 & (tnn1*xlf*a1*poll+tnn2*xrf*a2*polr)
35048 tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
35049 & (1d0-sqmz/sh)/sh
35050 tzn=tzn/xw**2/xw1
35051 tan=ei*ej*(uh*th-sqm3*sqm4)/sh*(a1*tnn1*poll+
35052 & a2*tnn2*polr)/xw
35053 ENDIF
35054 facqq1=comfac*aem**2*(taa+tzz+taz)*fcol/3d0
35055 facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh**2
35056 facqq2=comfac*aem**2*(tnn+tzn+tan)*fcol/3d0
35057 nchn=nchn+1
35058 isig(nchn,1)=i
35059 isig(nchn,2)=-i
35060 isig(nchn,3)=1
35061 sigh(nchn)=facqq1+facqq2
35062 130 CONTINUE
35063
35064 ELSEIF(isub.EQ.203) THEN
35065C...f + fbar -> e_L + e_Rbar
35066 DO 160 i=mmin1,mmax1
35067 ia=iabs(i)
35068 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 160
35069 ei=kchg(iabs(i),1)/3d0
35070 tt3i=sign(1d0,ei)/2d0
35071 ej=-1
35072 tt3j=-1d0/2d0
35073 fcol=1d0
35074C...Color factor for e+ e-
35075 IF(ia.GE.11) fcol=3d0
35076 a1=sfmix(kfid,1)**2
35077 a2=sfmix(kfid,2)**2
35078 xlq=(tt3j-ej*xw)
35079 xrq=(-ej*xw)
35080 xlf=(tt3i-ei*xw)
35081 xrf=(-ei*xw)
35082 tzz=(xlf**2*poll+xrf**2*polr)*(xlq-xrq)**2
35083 & /xw**2/xw1**2*a1*a2
35084 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35085 tnn=0.0d0
35086 tzn=0.0d0
35087 tnna=0d0
35088 tnnb=0d0
35089 IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN
35090 fac2=sqrt(2d0)
35091 tnn1=0d0
35092 tnn2=0d0
35093 tnn3=0d0
35094 DO 150 ii=1,4
35095 dk=1d0/(th-smz(ii)**2)
35096 flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*
35097 & zmix(ii,1))
35098 frek=fac2*tanw*ei*zmix(ii,1)
35099 tnn1=tnn1+flek**2*dk
35100 tnn2=tnn2+frek**2*dk
35101 DO 140 jj=1,4
35102 dl=1d0/(th-smz(jj)**2)
35103 flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*
35104 & zmix(jj,1))
35105 frel=fac2*tanw*ej*zmix(jj,1)
35106 tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)
35107 140 CONTINUE
35108 150 CONTINUE
35109 tnn=(uh*th-sqm3*sqm4)*a1*a2*(tnn2**2*polr+tnn1**2*poll)
35110 tnna=(tnn+sh*(a1**2*polll+a2**2*polrr)*tnn3)/4d0
35111 tnnb=(tnn+sh*(a1**2*polrr+a2**2*polll)*tnn3)/4d0
35112 tzn=(uh*th-sqm3*sqm4)*a1*a2
35113 tzn=tzn*(xlq-xrq)*(xlf*tnn1*poll-xrf*tnn2*polr)/xw1
35114 tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*
35115 & (1d0-sqmz/sh)/sh
35116 ENDIF
35117 facqq0=comfac*aem**2*tzz*fcol/3d0*(uh*th-sqm3*sqm4)/sh2
35118 facqq2=comfac*aem**2/xw**2*(tnna+tzn)*fcol/3d0
35119 facqq1=comfac*aem**2/xw**2*(tnnb+tzn)*fcol/3d0
35120C%%%%%%%%%%%
35121 nchn=nchn+1
35122 isig(nchn,1)=i
35123 isig(nchn,2)=-i
35124 isig(nchn,3)=1
35125 sigh(nchn)=(facqq0+facqq1)*wids(pycomp(kfpr(isubsv,1)),2)*
35126 & wids(pycomp(kfpr(isubsv,2)),3)
35127 nchn=nchn+1
35128 isig(nchn,1)=i
35129 isig(nchn,2)=-i
35130 isig(nchn,3)=2
35131 sigh(nchn)=(facqq0+facqq2)*wids(pycomp(kfpr(isubsv,1)),3)*
35132 & wids(pycomp(kfpr(isubsv,2)),2)
35133 160 CONTINUE
35134
35135 ELSEIF(isub.EQ.210) THEN
35136C...q + qbar' -> W*- > ~l_L + ~nu_L
35137 fac0=rkf*comfac*aem**2/xw**2/12d0
35138 fac1=(th*uh-sqm3*sqm4)/((sh-sqmw)**2+wwid**2*sqmw)
35139 DO 180 i=mmin1,mmax1
35140 ia=iabs(i)
35141 IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 180
35142 DO 170 j=mmin2,mmax2
35143 ja=iabs(j)
35144 IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 170
35145 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 170
35146 fckm=3d0
35147 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
35148 kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
35149 kchw=2
35150 IF(kchsum.LT.0) kchw=3
35151 nchn=nchn+1
35152 isig(nchn,1)=i
35153 isig(nchn,2)=j
35154 isig(nchn,3)=1
35155 IF(isubsv.EQ.297.OR.isubsv.EQ.298) THEN
35156 facr=wids(pycomp(kfpr(isubsv,1)),5-kchw)*
35157 & wids(pycomp(kfpr(isubsv,2)),2)
35158 ELSE
35159 facr=wids(pycomp(kfpr(isubsv,1)),5-kchw)*
35160 & wids(pycomp(kfpr(isubsv,2)),kchw)
35161 ENDIF
35162 sigh(nchn)=fac0*fac1*fckm*facr
35163 170 CONTINUE
35164 180 CONTINUE
35165 ENDIF
35166
35167 ELSEIF(isub.LE.220) THEN
35168 IF(isub.EQ.213) THEN
35169C...f + fbar -> ~nu_L + ~nu_Lbar
35170 IF(isubsv.EQ.299.OR.isubsv.EQ.300) THEN
35171 facr=wids(pycomp(kfpr(isubsv,1)),2)*
35172 & wids(pycomp(kfpr(isubsv,2)),2)
35173 ELSE
35174 facr=wids(pycomp(kfpr(isubsv,1)),1)
35175 ENDIF
35176 comfac=comfac*facr
35177 propz2=(sh-sqmz)**2+zwid**2*sqmz
35178 xll=0.5d0
35179 xlr=0.0d0
35180 DO 190 i=mmin1,mmax1
35181 ia=iabs(i)
35182 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 190
35183 ei=kchg(ia,1)/3d0
35184 fcol=1d0
35185C...Color factor for e+ e-
35186 IF(ia.GE.11) fcol=3d0
35187 xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0
35188 xrq=-ei*xw
35189 tzc=0.0d0
35190 tcc=0.0d0
35191 IF(ia.GE.11.AND.kfid.EQ.ia+1) THEN
35192 tzc=vmix(1,1)**2/(th-smw(1)**2)+vmix(2,1)**2/
35193 & (th-smw(2)**2)
35194 tcc=tzc**2
35195 tzc=tzc/xw1*(sh-sqmz)/propz2*xlq*xll
35196 ENDIF
35197 facqq1=(xlq**2+xrq**2)*(xll+xlr)**2/xw1**2/propz2
35198 facqq2=tzc+tcc/4d0
35199 nchn=nchn+1
35200 isig(nchn,1)=i
35201 isig(nchn,2)=-i
35202 isig(nchn,3)=1
35203 sigh(nchn)=(facqq1+facqq2)*rkf*(uh*th-sqm3*sqm4)*comfac
35204 & *aem**2*fcol/3d0/xw**2
35205 190 CONTINUE
35206
35207 ELSEIF(isub.EQ.216) THEN
35208C...q + qbar -> ~chi0_1 + ~chi0_1
35209 IF(izid1.EQ.izid2) THEN
35210 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
35211 ELSE
35212 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
35213 & wids(pycomp(kfpr(isubsv,2)),2)
35214 ENDIF
35215 facxx=comfac*aem**2/3d0/xw**2
35216 IF(izid1.EQ.izid2) facxx=facxx/2d0
35217 zm12=sqm3
35218 zm22=sqm4
35219 wu2 = (uh-zm12)*(uh-zm22)
35220 wt2 = (th-zm12)*(th-zm22)
35221 ws2 = smz(izid1)*smz(izid2)*sh
35222 propz2 = (sh-sqmz)**2 + sqmz*zwid**2
35223 propz=dcmplx(sh-sqmz,-zwid*pmas(23,1))/dcmplx(propz2)
35224 DO 200 i=1,4
35225 zmixc(izid1,i)=dcmplx(zmix(izid1,i),zmixi(izid1,i))
35226 IF(izid2.NE.izid1) THEN
35227 zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
35228 ENDIF
35229 200 CONTINUE
35230 olpp=(zmixc(izid1,3)*dconjg(zmixc(izid2,3))-
35231 & zmixc(izid1,4)*dconjg(zmixc(izid2,4)))/2d0
35232 orpp=dconjg(olpp)
35233 DO 210 i=mmina,mmaxa
35234 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 210
35235 ei=kchg(iabs(i),1)/3d0
35236 t3i=sign(1d0,ei+1d-6)/2d0
35237 xml2=pmas(pycomp(ksusy1+iabs(i)),1)**2
35238 xmr2=pmas(pycomp(ksusy2+iabs(i)),1)**2
35239 glij=(t3i*zmixc(izid1,2)-tanw*(t3i-ei)*zmixc(izid1,1))*
35240 & dconjg(t3i*zmixc(izid2,2)-tanw*(t3i-ei)*zmixc(izid2,1))
35241 grij=zmixc(izid1,1)*dconjg(zmixc(izid2,1))*(ei*tanw)**2
35242 qll=dcmplx((t3i-ei*xw)/xw1)*olpp*propz-glij/dcmplx(uh-xml2)
35243 qlr=-dcmplx((t3i-ei*xw)/xw1)*orpp*propz+dconjg(glij)
35244 & /dcmplx(th-xml2)
35245 qrl=-dcmplx((ei*xw)/xw1)*olpp*propz+grij/dcmplx(th-xmr2)
35246 qrr=dcmplx((ei*xw)/xw1)*orpp*propz
35247 & -dconjg(grij)/dcmplx(uh-xmr2)
35248 fcol=1d0
35249 IF(iabs(i).GE.11) fcol=3d0
35250 facgg1=(abs(qll)**2*poll+abs(qrr)**2*polr)*wu2+
35251 & (abs(qrl)**2*polr+abs(qlr)**2*poll)*wt2+
35252 & 2d0*dble(qlr*dconjg(qll)*poll+
35253 & qrl*dconjg(qrr)*polr)*ws2
35254 nchn=nchn+1
35255 isig(nchn,1)=i
35256 isig(nchn,2)=-i
35257 isig(nchn,3)=1
35258 sigh(nchn)=facxx*facgg1*fcol
35259 210 CONTINUE
35260 ENDIF
35261
35262 ELSEIF(isub.LE.230) THEN
35263 IF(isub.EQ.226) THEN
35264C...f + fbar -> ~chi+_1 + ~chi-_1
35265 facxx=comfac*aem**2/3d0
35266 zm12=sqm3
35267 zm22=sqm4
35268 wu2 = (uh-zm12)*(uh-zm22)
35269 wt2 = (th-zm12)*(th-zm22)
35270 ws2 = smw(izid1)*smw(izid2)*sh
35271 propz2 = (sh-sqmz)**2 + sqmz*zwid**2
35272 propz=dcmplx(sh-sqmz,-zwid*pmas(23,1))/dcmplx(propz2)
35273 diff=0d0
35274 IF(izid1.EQ.izid2) diff=1d0
35275 DO 220 i=1,2
35276 vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
35277 umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
35278 IF(izid2.NE.izid1) THEN
35279 vmixc(izid2,i)=dcmplx(vmix(izid2,i),vmixi(izid2,i))
35280 umixc(izid2,i)=dcmplx(umix(izid2,i),umixi(izid2,i))
35281 ENDIF
35282 220 CONTINUE
35283 olp=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))-
35284 & vmixc(izid2,2)*dconjg(vmixc(izid1,2))/2d0+dcmplx(xw*diff)
35285 orp=-umixc(izid1,1)*dconjg(umixc(izid2,1))-
35286 & umixc(izid1,2)*dconjg(umixc(izid2,2))/2d0+dcmplx(xw*diff)
35287 DO 230 i=mmina,mmaxa
35288 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 230
35289 ei=kchg(iabs(i),1)/3d0
35290 t3i=sign(1d0,ei+1d-6)/2d0
35291 qrl=dcmplx(-ei/sh*diff)-dcmplx(ei/xw1)*propz*orp
35292 qll=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*propz*orp
35293 qrr=dcmplx(-ei/sh*diff)-dcmplx(ei/xw1)*propz*olp
35294 IF(mod(i,2).EQ.0) THEN
35295 xml2=pmas(pycomp(ksusy1+iabs(i)-1),1)**2
35296 qlr=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*
35297 & propz*olp-umixc(izid2,1)*dconjg(umixc(izid1,1))*
35298 & dcmplx(t3i/xw/(th-xml2))
35299 ELSE
35300 xml2=pmas(pycomp(ksusy1+iabs(i)+1),1)**2
35301 qlr=dcmplx(-ei/sh*diff)+dcmplx((t3i-xw*ei)/xw/xw1)*
35302 & propz*olp-vmixc(izid2,1)*dconjg(vmixc(izid1,1))*
35303 & dcmplx(t3i/xw/(th-xml2))
35304 ENDIF
35305 fcol=1d0
35306 IF(iabs(i).GE.11) fcol=3d0
35307 facsum=((abs(qll)**2*poll+abs(qrr)**2*polr)*wu2+
35308 & (abs(qrl)**2*polr+abs(qlr)**2*poll)*wt2+
35309 & 2d0*dble(qlr*dconjg(qll)*poll+
35310 & qrl*dconjg(qrr)*polr)*ws2)*facxx*fcol
35311 nchn=nchn+1
35312 isig(nchn,1)=i
35313 isig(nchn,2)=-i
35314 isig(nchn,3)=1
35315 IF(izid1.EQ.izid2) THEN
35316 sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),1)
35317 ELSE
35318 sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),3)*
35319 & wids(pycomp(kfpr(isubsv,2)),2)
35320 nchn=nchn+1
35321 isig(nchn,1)=i
35322 isig(nchn,2)=-i
35323 isig(nchn,3)=2
35324 sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),2)*
35325 & wids(pycomp(kfpr(isubsv,2)),3)
35326 ENDIF
35327 230 CONTINUE
35328
35329 ELSEIF(isub.EQ.229) THEN
35330C...q + qbar' -> ~chi0_1 + ~chi+-_1
35331 facxx=comfac*aem**2/6d0/xw**2
35332 zm12=sqm3
35333 zm22=sqm4
35334 wu2 = (uh-zm12)*(uh-zm22)
35335 wt2 = (th-zm12)*(th-zm22)
35336 ws2 = smw(izid1)*smz(izid2)*sh
35337 rt2i = 1d0/sqrt(2d0)
35338 propw = dcmplx(sh-sqmw,-wwid*pmas(24,1))/
35339 & dcmplx((sh-sqmw)**2+wwid**2*sqmw,0d0)
35340 DO 240 i=1,2
35341 vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
35342 umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
35343 240 CONTINUE
35344 DO 250 i=1,4
35345 zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
35346 250 CONTINUE
35347 ol=(dconjg(zmixc(izid2,2))*vmixc(izid1,1)-
35348 & dconjg(zmixc(izid2,4))*vmixc(izid1,2)*rt2i)*propw
35349 or=(zmixc(izid2,2)*dconjg(umixc(izid1,1))+
35350 & zmixc(izid2,3)*dconjg(umixc(izid1,2))*rt2i)*propw
35351
35352 DO 270 i=mmin1,mmax1
35353 ia=iabs(i)
35354 IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) GOTO 270
35355 ei=kchg(ia,1)/3d0
35356 t3i=sign(1d0,ei+1d-6)/2d0
35357 DO 260 j=mmin2,mmax2
35358 ja=iabs(j)
35359 IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) GOTO 260
35360 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 260
35361 ej=kchg(ja,1)/3d0
35362 t3j=sign(1d0,ej+1d-6)/2d0
35363 fckm=3d0
35364 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
35365 kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
35366 kchw=2
35367 IF(kchsum.LT.0) kchw=3
35368 IF(mod(ia,2).EQ.0) THEN
35369 zmi2 = pmas(pycomp(ksusy1+ia),1)**2
35370 zmj2 = pmas(pycomp(ksusy1+ja),1)**2
35371 qll=ol+vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ei-t3i)*
35372 & tanw+zmixc(izid2,2)*t3i)/dcmplx(uh-zmi2)
35373 qlr=or-dconjg(umixc(izid1,1))*(
35374 & zmixc(izid2,1)*(ej-t3j)*tanw+zmixc(izid2,2)*t3j)
35375 & /dcmplx(th-zmj2)
35376 ELSE
35377 zmi2 = pmas(pycomp(ksusy1+ja),1)**2
35378 zmj2 = pmas(pycomp(ksusy1+ia),1)**2
35379 qll=ol+vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ej-t3j)*
35380 & tanw+zmixc(izid2,2)*t3j)/dcmplx(uh-zmj2)
35381 qlr=or-dconjg(umixc(izid1,1))*(
35382 & zmixc(izid2,1)*(ei-t3i)*tanw+zmixc(izid2,2)*t3i)
35383 & /dcmplx(th-zmi2)
35384 ENDIF
35385 zintr=dble(qlr*dconjg(qll))
35386 facgg1=facxx*(abs(qll)**2*wu2+abs(qlr)**2*wt2+
35387 & 2d0*zintr*ws2)
35388 nchn=nchn+1
35389 isig(nchn,1)=i
35390 isig(nchn,2)=j
35391 isig(nchn,3)=1
35392 sigh(nchn)=facgg1*fckm*wids(pycomp(kfpr(isubsv,1)),2)*
35393 & wids(pycomp(kfpr(isubsv,2)),kchw)
35394 260 CONTINUE
35395 270 CONTINUE
35396 ENDIF
35397
35398 ELSEIF(isub.LE.240) THEN
35399 IF(isub.EQ.237) THEN
35400C...q + qbar -> gluino + ~chi0_1
35401 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*
35402 & wids(pycomp(kfpr(isubsv,2)),2)
35403 asyuk=rmss(42)*as
35404 fac0=comfac*asyuk*aem*4d0/9d0/xw
35405 gm2=sqm3
35406 zm2=sqm4
35407 DO 280 i=mmina,mmaxa
35408 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 280
35409 ei=kchg(iabs(i),1)/3d0
35410 ia=iabs(i)
35411 xlqc = -tanw*ei*zmix(izid,1)
35412 xrqc =(sign(1d0,ei)*zmix(izid,2)-tanw*
35413 & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
35414 xlq2=xlqc**2
35415 xrq2=xrqc**2
35416 xml2=pmas(pycomp(ksusy1+ia),1)**2
35417 xmr2=pmas(pycomp(ksusy2+ia),1)**2
35418 atkin=(th-gm2)*(th-zm2)/(th-xml2)**2
35419 aukin=(uh-gm2)*(uh-zm2)/(uh-xml2)**2
35420 atukin=smz(izid)*sqrt(gm2)*sh/(th-xml2)/(uh-xml2)
35421 sgchil=xlq2*(atkin+aukin-2d0*atukin)
35422 atkin=(th-gm2)*(th-zm2)/(th-xmr2)**2
35423 aukin=(uh-gm2)*(uh-zm2)/(uh-xmr2)**2
35424 atukin=smz(izid)*sqrt(gm2)*sh/(th-xmr2)/(uh-xmr2)
35425 sgchir=xrq2*(atkin+aukin-2d0*atukin)
35426 nchn=nchn+1
35427 isig(nchn,1)=i
35428 isig(nchn,2)=-i
35429 isig(nchn,3)=1
35430 sigh(nchn)=fac0*(sgchil+sgchir)
35431 280 CONTINUE
35432 ENDIF
35433
35434 ELSEIF(isub.LE.250) THEN
35435 IF(isub.EQ.241) THEN
35436C...q + qbar' -> ~chi+-_1 + gluino
35437 facwg=comfac*as*aem/xw*2d0/9d0
35438 gm2=sqm3
35439 zm2=sqm4
35440 fac01=2d0*umix(izid,1)*vmix(izid,1)
35441 fac0=umix(izid,1)**2
35442 fac1=vmix(izid,1)**2
35443 DO 300 i=mmin1,mmax1
35444 ia=iabs(i)
35445 IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) GOTO 300
35446 DO 290 j=mmin2,mmax2
35447 ja=iabs(j)
35448 IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) GOTO 290
35449 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 290
35450 fckm=1d0
35451 IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)
35452 kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)
35453 kchw=2
35454 IF(kchsum.LT.0) kchw=3
35455 xmu2=pmas(pycomp(ksusy1+2),1)**2
35456 xmd2=pmas(pycomp(ksusy1+1),1)**2
35457 atkin=(th-gm2)*(th-zm2)/(th-xmu2)**2
35458 aukin=(uh-gm2)*(uh-zm2)/(uh-xmd2)**2
35459 atukin=smw(izid)*sqrt(gm2)*sh/(th-xmu2)/(uh-xmd2)
35460 xmu2=pmas(pycomp(ksusy2+2),1)**2
35461 xmd2=pmas(pycomp(ksusy2+1),1)**2
35462 atkin=(atkin+(th-gm2)*(th-zm2)/(th-xmu2)**2)/2d0
35463 aukin=(aukin+(uh-gm2)*(uh-zm2)/(uh-xmd2)**2)/2d0
35464 atukin=(atukin+smw(izid)*sqrt(gm2)*
35465 & sh/(th-xmu2)/(uh-xmd2))/2d0
35466 nchn=nchn+1
35467 isig(nchn,1)=i
35468 isig(nchn,2)=j
35469 isig(nchn,3)=1
35470 sigh(nchn)=facwg*fckm*(fac0*atkin+fac1*aukin-
35471 & fac01*atukin)*wids(pycomp(kfpr(isubsv,1)),2)*
35472 & wids(pycomp(kfpr(isubsv,2)),kchw)
35473 290 CONTINUE
35474 300 CONTINUE
35475
35476 ELSEIF(isub.EQ.243) THEN
35477C...q + qbar -> gluino + gluino
35478 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
35479 xmt=sqm3-th
35480 xmu=sqm3-uh
35481 DO 310 i=mmina,mmaxa
35482 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
35483 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 310
35484 nchn=nchn+1
35485 xsu=pmas(pycomp(ksusy1+iabs(i)),1)**2-uh
35486 xst=pmas(pycomp(ksusy1+iabs(i)),1)**2-th
35487 facgg1=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
35488 & 2d0*sqm3*sh)/sh2 + rmss(42)**2*(4d0/9d0*(xmt**2/xst**2+
35489 & xmu**2/xsu**2) + sqm3*sh/xst/xsu/9d0) - rmss(42)*(
35490 & (xmt**2+sh*sqm3)/sh/xst + (xmu**2+sh*sqm3)/sh/xsu ))
35491 xsu=pmas(pycomp(ksusy2+iabs(i)),1)**2-uh
35492 xst=pmas(pycomp(ksusy2+iabs(i)),1)**2-th
35493 facgg2=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+
35494 & 2d0*sqm3*sh)/sh2 + rmss(42)**2*(4d0/9d0*(xmt**2/xst**2+
35495 & xmu**2/xsu**2) + sqm3*sh/xst/xsu/9d0) - rmss(42)*(
35496 & (xmt**2+sh*sqm3)/sh/xst + (xmu**2+sh*sqm3)/sh/xsu ))
35497 isig(nchn,1)=i
35498 isig(nchn,2)=-i
35499 isig(nchn,3)=1
35500C...1/2 for identical particles
35501 sigh(nchn)=0.25d0*(facgg1+facgg2)
35502 310 CONTINUE
35503
35504 ELSEIF(isub.EQ.244) THEN
35505C...g + g -> gluino + gluino
35506 comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)
35507 xmt=sqm3-th
35508 xmu=sqm3-uh
35509 facqq1=comfac*as**2*9d0/4d0*(
35510 & (xmt*xmu-2d0*sqm3*(th+sqm3))/xmt**2 -
35511 & (xmt*xmu+sqm3*(uh-th))/sh/xmt )
35512 facqq2=comfac*as**2*9d0/4d0*(
35513 & (xmu*xmt-2d0*sqm3*(uh+sqm3))/xmu**2 -
35514 & (xmu*xmt+sqm3*(th-uh))/sh/xmu )
35515 facqq3=comfac*as**2*9d0/4d0*(2d0*xmt*xmu/sh2 +
35516 & sqm3*(sh-4d0*sqm3)/xmt/xmu)
35517 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 320
35518 nchn=nchn+1
35519 isig(nchn,1)=21
35520 isig(nchn,2)=21
35521 isig(nchn,3)=1
35522 sigh(nchn)=facqq1/2d0
35523 nchn=nchn+1
35524 isig(nchn,1)=21
35525 isig(nchn,2)=21
35526 isig(nchn,3)=2
35527 sigh(nchn)=facqq2/2d0
35528 nchn=nchn+1
35529 isig(nchn,1)=21
35530 isig(nchn,2)=21
35531 isig(nchn,3)=3
35532 sigh(nchn)=facqq3/2d0
35533 320 CONTINUE
35534
35535 ELSEIF(isub.EQ.246) THEN
35536C...g + q_j -> ~chi0_1 + ~q_j
35537 fac0=comfac*as*aem/6d0/xw
35538 zm2=sqm4
35539 qm2=sqm3
35540 faczq0=fac0*( (zm2-th)/sh +
35541 & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
35542 & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
35543 kfnsq=mod(kfpr(isubsv,1),ksusy1)
35544 DO 340 i=-kfnsq,kfnsq,2*kfnsq
35545 IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 340
35546 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 340
35547 ei=kchg(iabs(i),1)/3d0
35548 ia=iabs(i)
35549 xrqz = -tanw*ei*zmix(izid,1)
35550 xlqz =(sign(1d0,ei)*zmix(izid,2)-tanw*
35551 & (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0
35552 IF(ilr.EQ.0) THEN
35553 bs=xlqz**2*sfmix(ia,1)**2+xrqz**2*sfmix(ia,2)**2
35554 ELSE
35555 bs=xlqz**2*sfmix(ia,3)**2+xrqz**2*sfmix(ia,4)**2
35556 ENDIF
35557 faczq=faczq0*bs
35558 kchq=2
35559 IF(i.LT.0) kchq=3
35560 DO 330 isde=1,2
35561 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 330
35562 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 330
35563 nchn=nchn+1
35564 isig(nchn,isde)=i
35565 isig(nchn,3-isde)=21
35566 isig(nchn,3)=1
35567 sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35568 & wids(pycomp(kfpr(isubsv,2)),2)
35569 330 CONTINUE
35570 340 CONTINUE
35571 ENDIF
35572
35573 ELSEIF(isub.LE.260) THEN
35574 IF(isub.EQ.254) THEN
35575C...g + q_j -> ~chi1_1 + ~q_i
35576 fac0=comfac*as*aem/12d0/xw
35577 zm2=sqm4
35578 qm2=sqm3
35579 au=umix(izid,1)**2
35580 ad=vmix(izid,1)**2
35581 faczq0=fac0*( (zm2-th)/sh +
35582 & (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -
35583 & (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )
35584 kfnsq1=mod(kfpr(isubsv,1),ksusy1)
35585 IF(mod(kfnsq1,2).EQ.0) THEN
35586 kfnsq=kfnsq1-1
35587 kchw=2
35588 ELSE
35589 kfnsq=kfnsq1+1
35590 kchw=3
35591 ENDIF
35592 DO 360 i=-kfnsq,kfnsq,2*kfnsq
35593 IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 360
35594 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 360
35595 ia=iabs(i)
35596 IF(mod(ia,2).EQ.0) THEN
35597 faczq=faczq0*au
35598 ELSE
35599 faczq=faczq0*ad
35600 ENDIF
35601 faczq=faczq*sfmix(kfnsq1,1+2*ilr)**2
35602 kchq=2
35603 IF(i.LT.0) kchq=3
35604 kchwq=kchw
35605 IF(i.LT.0) kchwq=5-kchw
35606 DO 350 isde=1,2
35607 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 350
35608 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 350
35609 nchn=nchn+1
35610 isig(nchn,isde)=i
35611 isig(nchn,3-isde)=21
35612 isig(nchn,3)=1
35613 sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35614 & wids(pycomp(kfpr(isubsv,2)),kchwq)
35615 350 CONTINUE
35616 360 CONTINUE
35617
35618 ELSEIF(isub.EQ.258) THEN
35619C...g + q_j -> gluino + ~q_i
35620 xg2=sqm4
35621 xq2=sqm3
35622 xmt=xg2-th
35623 xmu=xg2-uh
35624 xst=xq2-th
35625 xsu=xq2-uh
35626 facqg1=0.5d0*4d0/9d0*xmt/sh + (xmt*sh+2d0*xg2*xst)/xmt**2 -
35627 & ( (sh-xq2+xg2)*(-xst)-sh*xg2 )/sh/(-xmt) +
35628 & 0.5d0*1d0/2d0*( xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst) +
35629 & (-xmu)*(th+xg2+2d0*xq2) )/2d0/xmt/xsu
35630 facqg2= 4d0/9d0*(-xmu)*(uh+xq2)/xsu**2 + 1d0/18d0*
35631 & (sh*(uh+xg2)
35632 & +2d0*(xq2-xg2)*xmu)/sh/(-xsu) + 0.5d0*4d0/9d0*xmt/sh +
35633 & 0.5d0*1d0/2d0*(xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst)+
35634 & (-xmu)*(th+xg2+2d0*xq2))/2d0/xmt/xsu
35635 asyuk=rmss(42)*as
35636 facqg1=comfac*as*asyuk*facqg1/2d0
35637 facqg2=comfac*as*asyuk*facqg2/2d0
35638 kfnsq=mod(kfpr(isubsv,1),ksusy1)
35639 DO 380 i=-kfnsq,kfnsq,2*kfnsq
35640 IF(i.LT.mmina.OR.i.GT.mmaxa) GOTO 380
35641 IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 380
35642 kchq=2
35643 IF(i.LT.0) kchq=3
35644 facsel=rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35645 & wids(pycomp(kfpr(isubsv,2)),2)
35646 DO 370 isde=1,2
35647 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 370
35648 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 370
35649 nchn=nchn+1
35650 isig(nchn,isde)=i
35651 isig(nchn,3-isde)=21
35652 isig(nchn,3)=1
35653 sigh(nchn)=facqg1*facsel
35654 nchn=nchn+1
35655 isig(nchn,isde)=i
35656 isig(nchn,3-isde)=21
35657 isig(nchn,3)=2
35658 sigh(nchn)=facqg2*facsel
35659 370 CONTINUE
35660 380 CONTINUE
35661 ENDIF
35662
35663 ELSEIF(isub.LE.270) THEN
35664 IF(isub.EQ.261) THEN
35665C...q_i + q_ibar -> ~t_1 + ~t_1bar
35666 facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )*
35667 & wids(pycomp(kfpr(isubsv,1)),1)
35668 kfnsq=mod(kfpr(isubsv,1),ksusy1)
35669 fac0=as**2*4d0/9d0
35670 DO 390 i=mmin1,mmax1
35671 ia=iabs(i)
35672 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 390
35673 IF(ia.GE.11.AND.ia.LE.18) THEN
35674 ei=kchg(ia,1)/3d0
35675 ej=kchg(kfnsq,1)/3d0
35676 t3i=sign(1d0,ei)/2d0
35677 t3j=sign(1d0,ej)/2d0
35678 xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,2*ilr+1)**2
35679 xrq=2d0*(-ej*xw)*sfmix(kfnsq,2*ilr+2)**2
35680 xlf=2d0*(t3i-ei*xw)
35681 xrf=2d0*(-ei*xw)
35682 taa=0.5d0*(ei*ej)**2
35683 tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/xw1**2
35684 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35685 taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/xw1
35686 taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
35687 fac0=aem**2*12d0*(taa+tzz+taz)
35688 ENDIF
35689 nchn=nchn+1
35690 isig(nchn,1)=i
35691 isig(nchn,2)=-i
35692 isig(nchn,3)=1
35693 sigh(nchn)=facqq1*fac0
35694 390 CONTINUE
35695
35696 ELSEIF(isub.EQ.263) THEN
35697C...f + fbar -> ~t1 + ~t2bar
35698 DO 400 i=mmin1,mmax1
35699 ia=iabs(i)
35700 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 400
35701 ei=kchg(iabs(i),1)/3d0
35702 tt3i=sign(1d0,ei)/2d0
35703 ej=2d0/3d0
35704 tt3j=1d0/2d0
35705 fcol=1d0
35706C...Color factor for e+ e-
35707 IF(ia.GE.11) fcol=3d0
35708 xlq=2d0*(tt3j-ej*xw)
35709 xrq=2d0*(-ej*xw)
35710 xlf=2d0*(tt3i-ei*xw)
35711 xrf=2d0*(-ei*xw)
35712 tzz=(xlf**2+xrf**2)*(xlq-xrq)**2/64d0/xw**2/xw1**2
35713 tzz=tzz*(sfmix(6,1)*sfmix(6,2))**2
35714 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35715C...Factor of 2 for t1 t2bar + t2 t1bar
35716 facqq1=2d0*comfac*aem**2*tzz*fcol*4d0
35717 facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh2
35718 nchn=nchn+1
35719 isig(nchn,1)=i
35720 isig(nchn,2)=-i
35721 isig(nchn,3)=1
35722 sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),2)*
35723 & wids(pycomp(kfpr(isubsv,2)),3)
35724 nchn=nchn+1
35725 isig(nchn,1)=i
35726 isig(nchn,2)=-i
35727 isig(nchn,3)=2
35728 sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),3)*
35729 & wids(pycomp(kfpr(isubsv,2)),2)
35730 400 CONTINUE
35731
35732 ELSEIF(isub.EQ.264) THEN
35733C...g + g -> ~t_1 + ~t_1bar
35734 xsu=sqm3-uh
35735 xst=sqm3-th
35736 fac0=comfac*as**2*(7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )*0.5d0*
35737 & wids(pycomp(kfpr(isubsv,1)),1)
35738 facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
35739 facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
35740 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 410
35741 nchn=nchn+1
35742 isig(nchn,1)=21
35743 isig(nchn,2)=21
35744 isig(nchn,3)=1
35745 sigh(nchn)=facqq1
35746 nchn=nchn+1
35747 isig(nchn,1)=21
35748 isig(nchn,2)=21
35749 isig(nchn,3)=2
35750 sigh(nchn)=facqq2
35751 410 CONTINUE
35752 ENDIF
35753
35754 ELSEIF(isub.LE.280) THEN
35755 IF(isub.EQ.271) THEN
35756C...q + q' -> ~q + ~q' (~g exchange)
35757 xmg2=pmas(pycomp(ksusy1+21),1)**2
35758 xmt=xmg2-th
35759 xmu=xmg2-uh
35760 xsu1=sqm3-uh
35761 xsu2=sqm4-uh
35762 xst1=sqm3-th
35763 xst2=sqm4-th
35764 asyuk=rmss(42)*as
35765 IF(ilr.EQ.1) THEN
35766 facqq1=comfac*asyuk**2*4d0/9d0*( -(xst1*xst2+sh*th)/xmt**2 )
35767 facqq2=comfac*asyuk**2*4d0/9d0*( -(xsu1*xsu2+sh*uh)/xmu**2 )
35768 facqqb=0.0d0
35769 ELSE
35770 facqq1=0.5d0*comfac*asyuk**2*4d0/9d0*( sh*xmg2/xmt**2 )
35771 facqq2=0.5d0*comfac*asyuk**2*4d0/9d0*( sh*xmg2/xmu**2 )
35772 facqqb=0.5d0*comfac*asyuk**2*4d0/9d0*( -2d0*sh*xmg2/3d0/
35773 & xmt/xmu )
35774 ENDIF
35775 kfnsqi=mod(kfpr(isubsv,1),ksusy1)
35776 kfnsqj=mod(kfpr(isubsv,2),ksusy1)
35777 DO 430 i=-kfnsqi,kfnsqi,2*kfnsqi
35778 IF(i.LT.mmin1.OR.i.GT.mmax1) GOTO 430
35779 ia=iabs(i)
35780 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 430
35781 kchq=2
35782 IF(i.LT.0) kchq=3
35783 DO 420 j=-kfnsqj,kfnsqj,2*kfnsqj
35784 IF(j.LT.mmin2.OR.j.GT.mmax2) GOTO 420
35785 ja=iabs(j)
35786 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 420
35787 IF(i*j.LT.0) GOTO 420
35788 nchn=nchn+1
35789 isig(nchn,1)=i
35790 isig(nchn,2)=j
35791 isig(nchn,3)=1
35792 sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35793 & wids(pycomp(kfpr(isubsv,2)),kchq)
35794 IF(i.EQ.j) THEN
35795 IF(ilr.EQ.0) THEN
35796 sigh(nchn)=0.5d0*(facqq1+0.5d0*facqqb)*rkf*
35797 & wids(pycomp(kfpr(isubsv,1)),kchq+2)
35798 ELSE
35799 sigh(nchn)=0.5d0*facqq1*rkf*
35800 & wids(pycomp(kfpr(isubsv,1)),kchq)*
35801 & wids(pycomp(kfpr(isubsv,2)),kchq)
35802 ENDIF
35803 nchn=nchn+1
35804 isig(nchn,1)=i
35805 isig(nchn,2)=j
35806 isig(nchn,3)=2
35807 IF(ilr.EQ.0) THEN
35808 sigh(nchn)=0.5d0*(facqq2+0.5d0*facqqb)*rkf*
35809 & wids(pycomp(kfpr(isubsv,1)),kchq+2)
35810 ELSE
35811 sigh(nchn)=0.5d0*facqq2*rkf*
35812 & wids(pycomp(kfpr(isubsv,1)),kchq)*
35813 & wids(pycomp(kfpr(isubsv,2)),kchq)
35814 ENDIF
35815 ENDIF
35816 420 CONTINUE
35817 430 CONTINUE
35818
35819 ELSEIF(isub.EQ.274) THEN
35820C...q + qbar' -> ~q + ~qbar'
35821 xmg2=pmas(pycomp(ksusy1+21),1)**2
35822 xmt=xmg2-th
35823 xmu=xmg2-uh
35824 IF(ilr.EQ.0) THEN
35825C...Mrenna...Normalization.and.1/XMT
35826 facqq1=comfac*as**2*2d0/9d0*(
35827 & (uh*th-sqm3*sqm4)/xmt**2 )*rmss(42)**2
35828 facqqb=comfac*as**2*4d0/9d0*(
35829 & (uh*th-sqm3*sqm4)/sh2 )
35830 facqqi=-comfac*as**2*4d0/27d0*(
35831 & (uh*th-sqm3*sqm4)/sh/xmt )*rmss(42)
35832 facqqb=facqqb+facqq1+facqqi
35833 ELSE
35834 facqq1=comfac*as**2*4d0/9d0*( xmg2*sh/xmt**2 )*rmss(42)**2
35835 facqqb=facqq1
35836 ENDIF
35837 kfnsqi=mod(kfpr(isubsv,1),ksusy1)
35838 kfnsqj=mod(kfpr(isubsv,2),ksusy1)
35839 DO 450 i=-kfnsqi,kfnsqi,2*kfnsqi
35840 IF(i.LT.mmin1.OR.i.GT.mmax1) GOTO 450
35841 ia=iabs(i)
35842 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 450
35843 kchq=2
35844 IF(i.LT.0) kchq=3
35845 DO 440 j=-kfnsqj,kfnsqj,2*kfnsqj
35846 IF(j.LT.mmin2.OR.j.GT.mmax2) GOTO 440
35847 ja=iabs(j)
35848 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 440
35849 IF(i*j.GT.0) GOTO 440
35850 nchn=nchn+1
35851 isig(nchn,1)=i
35852 isig(nchn,2)=j
35853 isig(nchn,3)=1
35854 sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*
35855 & wids(pycomp(kfpr(isubsv,2)),5-kchq)
35856 IF(ilr.EQ.0.AND.i.EQ.-j) sigh(nchn)=facqqb*rkf*
35857 & wids(pycomp(kfpr(isubsv,1)),1)
35858 440 CONTINUE
35859 450 CONTINUE
35860
35861 ELSEIF(isub.EQ.277) THEN
35862C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35863C...if i .eq. j covered in 274
35864 facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )
35865 kfnsq=mod(kfpr(isubsv,1),ksusy1)
35866 fac0=0d0
35867 DO 460 i=mmin1,mmax1
35868 ia=iabs(i)
35869 IF(i.EQ.0.OR.(ia.GT.mstp(58).AND.ia.LE.10).OR.
35870 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 460
35871 IF(ia.EQ.kfnsq) GOTO 460
35872 IF(ia.EQ.11.OR.ia.EQ.13.OR.ia.EQ.15) THEN
35873 ei=kchg(ia,1)/3d0
35874 ej=kchg(kfnsq,1)/3d0
35875 t3j=sign(0.5d0,ej)
35876 t3i=sign(1d0,ei)/2d0
35877 IF(ilr.EQ.0) THEN
35878 xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,1)
35879 xrq=2d0*(-ej*xw)*sfmix(kfnsq,2)
35880 ELSE
35881 xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,3)
35882 xrq=2d0*(-ej*xw)*sfmix(kfnsq,4)
35883 ENDIF
35884 xlf=2d0*(t3i-ei*xw)
35885 xrf=2d0*(-ei*xw)
35886 IF(ilr.EQ.0) THEN
35887 xrq=0d0
35888 ELSE
35889 xlq=0d0
35890 ENDIF
35891 taa=0.5d0*(ei*ej)**2
35892 tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/xw1**2
35893 tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)
35894 taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/xw1
35895 taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)
35896 fac0=aem**2*12d0*(taa+tzz+taz)
35897 ELSEIF(ia.LE.6) THEN
35898 fac0=as**2*8d0/9d0/2d0
35899 ENDIF
35900 nchn=nchn+1
35901 isig(nchn,1)=i
35902 isig(nchn,2)=-i
35903 isig(nchn,3)=1
35904 sigh(nchn)=facqq1*fac0*rkf*wids(pycomp(kfpr(isubsv,1)),1)
35905 460 CONTINUE
35906
35907 ELSEIF(isub.EQ.279) THEN
35908C...g + g -> ~q_j + ~q_jbar
35909 xsu=sqm3-uh
35910 xst=sqm3-th
35911C...5=RKF because ~t ~tbar treated separately
35912 fac0=rkf*comfac*as**2*( 7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )
35913 facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)
35914 facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)
35915 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 470
35916 nchn=nchn+1
35917 isig(nchn,1)=21
35918 isig(nchn,2)=21
35919 isig(nchn,3)=1
35920 sigh(nchn)=facqq1/2d0*wids(pycomp(kfpr(isubsv,1)),1)
35921 nchn=nchn+1
35922 isig(nchn,1)=21
35923 isig(nchn,2)=21
35924 isig(nchn,3)=2
35925 sigh(nchn)=facqq2/2d0*wids(pycomp(kfpr(isubsv,1)),1)
35926 470 CONTINUE
35927
35928 ENDIF
35929 ENDIF
35930CMRENNA--
35931
35932 RETURN
35933 END
35934
35935C*********************************************************************
35936
35937C...PYSGTC
35938C...Subprocess cross sections for Technicolor processes.
35939C...Auxiliary to PYSIGH.
35940
35941 SUBROUTINE pysgtc(NCHN,SIGS)
35942
35943C...Double precision and integer declarations
35944 IMPLICIT DOUBLE PRECISION(a-h, o-z)
35945 IMPLICIT INTEGER(I-N)
35946 INTEGER PYK,PYCHGE,PYCOMP
35947C...Parameter statement to help give large particle numbers.
35948 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
35949 &kexcit=4000000,kdimen=5000000)
35950C...Commonblocks
35951 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
35952 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
35953 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
35954 common/pypars/mstp(200),parp(200),msti(200),pari(200)
35955 common/pyint1/mint(400),vint(400)
35956 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
35957 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
35958 common/pyint4/mwid(500),wids(500,5)
35959 common/pytcsm/itcm(0:99),rtcm(0:99)
35960 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
35961 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
35962 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
35963 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
35964 SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
35965 &/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
35966C...Local arrays and complex variables
35967 dimension wdtp(0:400),wdte(0:400,0:5)
35968 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
35969 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
35970 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
35971 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
35972 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
35973 COMPLEX*16 DVVS,DVVT,DVVU
35974 INTEGER INDX(6)
35975
35976C...Combinations of weak mixing angle.
35977 tanw=sqrt(xw/xw1)
35978 ct2w=(1d0-2d0*xw)/(2d0*xw/tanw)
35979
35980C...Convert almost equivalent technicolor processes into
35981C...a few basic processes, and set distinguishing parameters.
35982 IF(isub.GE.361.AND.isub.LE.380) THEN
35983 sqtv=rtcm(12)**2
35984 sqta=rtcm(13)**2
35985 sn2w=2d0*sqrt(xw*xw1)
35986 cs2w=1d0-2d0*xw
35987 ct2w=cs2w/sn2w
35988 csxi=cos(asin(rtcm(3)))
35989 csxip=cos(asin(rtcm(4)))
35990 qupd=2d0*rtcm(2)-1d0
35991 q2ud=rtcm(2)**2+(rtcm(2)-1d0)**2
35992 cab2=0d0
35993 vogp=0d0
35994 vrgp=0d0
35995 aogp=0d0
35996 argp=0d0
35997 vxgp=0d0
35998 axgp=0d0
35999 vagp=0d0
36000 vzgp=0d0
36001 vwgp=0d0
36002C... rho_tc0, etc. -> W_L W_L, W_L W_T
36003 IF(isub.EQ.361) THEN
36004 kfa=24
36005 kfb=24
36006 cab2=rtcm(3)**4
36007 axgp=-rtcm(3)/(2d0*sqrt(xw))/rtcm(49)
36008 argp=rtcm(3)/(2d0*sqrt(xw))/rtcm(13)
36009 vogp=rtcm(3)/(2d0*sqrt(xw))/rtcm(12)
36010C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36011 axgp = sqrt(2d0)*axgp
36012 argp = sqrt(2d0)*argp
36013 vogp = sqrt(2d0)*vogp
36014C... rho_tc0 -> W_L pi_tc-
36015 ELSEIF(isub.EQ.362) THEN
36016 kfa=24
36017 kfb=ktechn+211
36018 isub=361
36019 cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36020C... pi_tc pi_tc
36021 ELSEIF(isub.EQ.363) THEN
36022 kfa=ktechn+211
36023 kfb=ktechn+211
36024 isub=361
36025 cab2=(1d0-rtcm(3)**2)**2
36026C... rho_tc0/omega_tc -> gamma pi_tc
36027 ELSEIF(isub.EQ.364) THEN
36028 kfa=22
36029 kfb=ktechn+111
36030 isub=361
36031 vogp=csxi/rtcm(12)
36032 vrgp=vogp*qupd
36033 vagp=2d0*qupd*csxi
36034 vzgp=qupd*csxi*(1d0-4d0*xw)/sn2w
36035C... gamma pi_tc'
36036 ELSEIF(isub.EQ.365) THEN
36037 kfa=22
36038 kfb=ktechn+221
36039 isub=361
36040 vrgp=csxip/rtcm(12)
36041 vogp=vrgp*qupd
36042 vagp=2d0*q2ud*csxip
36043 vzgp=csxip/sn2w*(1d0-4d0*xw*q2ud)
36044C... Z pi_tc
36045 ELSEIF(isub.EQ.366) THEN
36046 kfa=23
36047 kfb=ktechn+111
36048 isub=361
36049 vogp=csxi*ct2w/rtcm(12)
36050 vrgp=-qupd*csxi*tanw/rtcm(12)
36051 vagp=qupd*csxi*(1d0-4d0*xw)/sn2w
36052 vzgp=-qupd*csxi*cs2w/xw1
36053C... Z pi_tc'
36054 ELSEIF(isub.EQ.367) THEN
36055 kfa=23
36056 kfb=ktechn+221
36057 isub=361
36058C...RTCM(48) is the M_V for the techni-a
36059 vxgp=-csxip/sn2w/rtcm(48)
36060 vrgp=csxip*ct2w/rtcm(12)
36061 vogp=-qupd*csxip*tanw/rtcm(12)
36062 vagp=csxip*(1d0-4d0*q2ud*xw)/sn2w
36063 vzgp=2d0*csxip*(cs2w+4d0*q2ud*xw**2)/sn2w**2
36064C... W_T pi_tc
36065 ELSEIF(isub.EQ.368) THEN
36066 kfa=24
36067 kfb=ktechn+211
36068 isub=361
36069C...RTCM(49) is the M_A for the techni-a
36070 axgp=-csxi/(2d0*sqrt(xw))/rtcm(49)
36071 vogp=csxi/(2d0*sqrt(xw))/rtcm(12)
36072 argp=csxi/(2d0*sqrt(xw))/rtcm(13)
36073 vagp=qupd*csxi/(2d0*sqrt(xw))
36074 vzgp=-qupd*csxi/(2d0*sqrt(xw1))
36075C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36076 ELSEIF(isub.EQ.370) THEN
36077 kfa=24
36078 kfb=23
36079 cab2=rtcm(3)**4
36080 argp=-rtcm(3)/(2d0*sqrt(xw))/rtcm(13)
36081 axgp=rtcm(3)/(2d0*sqrt(xw))/rtcm(49)
36082C... W_L pi_tc0
36083 ELSEIF(isub.EQ.371) THEN
36084 kfa=24
36085 kfb=ktechn+111
36086 isub=370
36087 cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36088C... Z_L pi_tc+
36089 ELSEIF(isub.EQ.372) THEN
36090 kfa=ktechn+211
36091 kfb=23
36092 isub=370
36093 cab2=rtcm(3)**2*(1d0-rtcm(3)**2)
36094C... pi_tc+ pi_tc0
36095 ELSEIF(isub.EQ.373) THEN
36096 kfa=ktechn+211
36097 kfb=ktechn+111
36098 isub=370
36099 cab2=(1d0-rtcm(3)**2)**2
36100C... gamma pi_tc+
36101 ELSEIF(isub.EQ.374) THEN
36102 kfa=ktechn+211
36103 kfb=22
36104 isub=370
36105 vrgp=qupd*csxi/rtcm(12)
36106 vwgp=qupd*csxi/(2d0*sqrt(xw))
36107 axgp=-csxi/rtcm(49)
36108C... Z_T pi_tc+
36109 ELSEIF(isub.EQ.375) THEN
36110 kfa=ktechn+211
36111 kfb=23
36112 isub=370
36113 vrgp=-qupd*csxi*tanw/rtcm(12)
36114 argp=csxi/(2d0*sqrt(xw*xw1))/rtcm(13)
36115 vwgp=-qupd*csxi/(2d0*sqrt(xw1))
36116 axgp=-csxi*ct2w/rtcm(49)
36117C... W_T pi_tc0
36118 ELSEIF(isub.EQ.376) THEN
36119 kfa=24
36120 kfb=ktechn+111
36121 isub=370
36122 vrgp=0d0
36123 argp=-csxi/(2d0*sqrt(xw))/rtcm(13)
36124 axgp=csxi/(2d0*sqrt(xw))/rtcm(49)
36125C... W_T pi_tc0'
36126 ELSEIF(isub.EQ.377) THEN
36127 kfa=24
36128 kfb=ktechn+221
36129 isub=370
36130 vrgp=csxip/(2d0*sqrt(xw))/rtcm(12)
36131 vwgp=csxip/(2d0*xw)
36132 vxgp=-csxip/(2d0*sqrt(xw))/rtcm(48)
36133C... gamma W+
36134 ELSEIF(isub.EQ.378) THEN
36135 kfa=24
36136 kfb=22
36137 isub=370
36138 vrgp=qupd*rtcm(3)/rtcm(12)
36139 axgp=-rtcm(3)/rtcm(49)
36140C... gamma Z
36141 ELSEIF(isub.EQ.379) THEN
36142 kfa=23
36143 kfb=22
36144 isub=361
36145 vogp=rtcm(3)/rtcm(12)
36146 vrgp=qupd*rtcm(3)/rtcm(12)
36147 ELSEIF(isub.EQ.380) THEN
36148 kfa=23
36149 kfb=23
36150 isub=361
36151 vogp=rtcm(3)*ct2w/rtcm(12)
36152 vrgp=-qupd*rtcm(3)*tanw/rtcm(12)
36153 ENDIF
36154 ENDIF
36155
36156C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36157 IF(isub.GE.381.AND.isub.LE.388) THEN
36158 IF(itcm(5).LE.4) THEN
36159 sqdqqs=1d0/sh2
36160 sqdqqt=1d0/th2
36161 sqdqqu=1d0/uh2
36162 sqdggs=sqdqqs
36163 sqdggt=sqdqqt
36164 sqdggu=sqdqqu
36165 redggs=1d0/sh
36166 redggt=1d0/th
36167 redggu=1d0/uh
36168 redgtu=1d0/uh/th
36169 redgsu=1d0/sh/uh
36170 redgst=1d0/sh/th
36171 redqst=1d0/sh/th
36172 redqtu=1d0/uh/th
36173 sqdlgs=0d0
36174 sqdlgt=0d0
36175 sqdqts=sqdqqs
36176 ELSEIF(itcm(5).EQ.5) THEN
36177 tant3=rtcm(21)
36178 IF(itcm(2).EQ.0) THEN
36179 imdl=1
36180 ELSE
36181 imdl=2
36182 ENDIF
36183 alprht=2.16d0*(3d0/itcm(1))
36184 sin2t=2d0*tant3/(tant3**2+1d0)
36185 sint3=tant3/sqrt(tant3**2+1d0)
36186 xig=sqrt(pyalps(sh)/alprht)
36187 x12=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*cos(rtcm(30))+
36188 & rtcm(31)*sqrt(1d0-rtcm(31)**2)*cos(rtcm(32)))/sqrt(2d0)/sin2t
36189 x21=(rtcm(29)*sqrt(1d0-rtcm(29)**2)*sin(rtcm(30))+
36190 & rtcm(31)*sqrt(1d0-rtcm(31)**2)*sin(rtcm(32)))/sqrt(2d0)/sin2t
36191 x11=(.25d0*(rtcm(29)**2+rtcm(31)**2+2d0)-
36192 & sint3**2)*2d0/sin2t
36193 x22=(.25d0*(2d0-rtcm(29)**2-rtcm(31)**2)-
36194 & sint3**2)*2d0/sin2t
36195
36196 sm1122=.5d0*(2d0-rtcm(29)**2-rtcm(31)**2)*rtcm(28)**2
36197 sm1112=x12*rtcm(28)**2*sin2t
36198 sm1121=-x21*rtcm(28)**2*sin2t
36199 sm2212=-sm1112
36200 sm2221=-sm1121
36201 sm1221=-.5d0*((1d0-rtcm(29)**2)*sin(2d0*rtcm(30))+
36202 & (1d0-rtcm(31)**2)*sin(2d0*rtcm(32)))*rtcm(28)**2
36203
36204C.........SH LOOP
36205 ztc(1,1)=dcmplx(sh,0d0)
36206 CALL pywidt(3100021,sh,wdtp,wdte)
36207 IF(wdtp(0).GT.rtcm(33)*shr) wdtp(0)=rtcm(33)*shr
36208 ztc(2,2)=dcmplx(sh-pmas(pycomp(3100021),1)**2,-shr*wdtp(0))
36209 CALL pywidt(3100113,sh,wdtp,wdte)
36210 ztc(3,3)=dcmplx(sh-pmas(pycomp(3100113),1)**2,-shr*wdtp(0))
36211 CALL pywidt(3400113,sh,wdtp,wdte)
36212 ztc(4,4)=dcmplx(sh-pmas(pycomp(3400113),1)**2,-shr*wdtp(0))
36213 CALL pywidt(3200113,sh,wdtp,wdte)
36214 ztc(5,5)=dcmplx(sh-pmas(pycomp(3200113),1)**2,-shr*wdtp(0))
36215 CALL pywidt(3300113,sh,wdtp,wdte)
36216 ztc(6,6)=dcmplx(sh-pmas(pycomp(3300113),1)**2,-shr*wdtp(0))
36217 ztc(1,2)=(0d0,0d0)
36218 ztc(1,3)=dcmplx(sh*xig,0d0)
36219 ztc(1,4)=ztc(1,3)
36220 ztc(1,5)=ztc(1,2)
36221 ztc(1,6)=ztc(1,2)
36222 ztc(2,3)=dcmplx(sh*xig*x11,0d0)
36223 ztc(2,4)=dcmplx(sh*xig*x22,0d0)
36224 ztc(2,5)=dcmplx(sh*xig*x12,0d0)
36225 ztc(2,6)=dcmplx(sh*xig*x21,0d0)
36226 ztc(3,4)=-sm1122
36227 ztc(3,5)=-sm1112
36228 ztc(3,6)=-sm1121
36229 ztc(4,5)=-sm2212
36230 ztc(4,6)=-sm2221
36231 ztc(5,6)=-sm1221
36232
36233 DO 110 i=1,5
36234 DO 100 j=i+1,6
36235 ztc(j,i)=ztc(i,j)
36236 100 CONTINUE
36237 110 CONTINUE
36238 CALL pyldcm(ztc,6,6,indx,d)
36239 DO 130 i=1,6
36240 DO 120 j=1,6
36241 ytc(i,j)=(0d0,0d0)
36242 IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
36243 120 CONTINUE
36244 130 CONTINUE
36245
36246 DO 140 i=1,6
36247 CALL pybksb(ztc,6,6,indx,ytc(1,i))
36248 140 CONTINUE
36249 dggs=ytc(1,1)
36250 dvvs=ytc(2,2)
36251 dgvs=ytc(1,2)
36252
36253 xig=sqrt(pyalps(-th)/alprht)
36254C.........TH LOOP
36255 ztc(1,1)=dcmplx(th)
36256 ztc(2,2)=dcmplx(th-pmas(pycomp(3100021),1)**2)
36257 ztc(3,3)=dcmplx(th-pmas(pycomp(3100113),1)**2)
36258 ztc(4,4)=dcmplx(th-pmas(pycomp(3400113),1)**2)
36259 ztc(5,5)=dcmplx(th-pmas(pycomp(3200113),1)**2)
36260 ztc(6,6)=dcmplx(th-pmas(pycomp(3300113),1)**2)
36261 ztc(1,2)=(0d0,0d0)
36262 ztc(1,3)=dcmplx(th*xig,0d0)
36263 ztc(1,4)=ztc(1,3)
36264 ztc(1,5)=ztc(1,2)
36265 ztc(1,6)=ztc(1,2)
36266 ztc(2,3)=dcmplx(th*xig*x11,0d0)
36267 ztc(2,4)=dcmplx(th*xig*x22,0d0)
36268 ztc(2,5)=dcmplx(th*xig*x12,0d0)
36269 ztc(2,6)=dcmplx(th*xig*x21,0d0)
36270 ztc(3,4)=-sm1122
36271 ztc(3,5)=-sm1112
36272 ztc(3,6)=-sm1121
36273 ztc(4,5)=-sm2212
36274 ztc(4,6)=-sm2221
36275 ztc(5,6)=-sm1221
36276 DO 160 i=1,5
36277 DO 150 j=i+1,6
36278 ztc(j,i)=ztc(i,j)
36279 150 CONTINUE
36280 160 CONTINUE
36281 CALL pyldcm(ztc,6,6,indx,d)
36282 DO 180 i=1,6
36283 DO 170 j=1,6
36284 ytc(i,j)=(0d0,0d0)
36285 IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
36286 170 CONTINUE
36287 180 CONTINUE
36288 DO 190 i=1,6
36289 CALL pybksb(ztc,6,6,indx,ytc(1,i))
36290 190 CONTINUE
36291 dggt=ytc(1,1)
36292 dvvt=ytc(2,2)
36293 dgvt=ytc(1,2)
36294
36295 xig=sqrt(pyalps(-uh)/alprht)
36296C.........UH LOOP
36297 ztc(1,1)=dcmplx(uh,0d0)
36298 ztc(2,2)=dcmplx(uh-pmas(pycomp(3100021),1)**2)
36299 ztc(3,3)=dcmplx(uh-pmas(pycomp(3100113),1)**2)
36300 ztc(4,4)=dcmplx(uh-pmas(pycomp(3400113),1)**2)
36301 ztc(5,5)=dcmplx(uh-pmas(pycomp(3200113),1)**2)
36302 ztc(6,6)=dcmplx(uh-pmas(pycomp(3300113),1)**2)
36303 ztc(1,2)=(0d0,0d0)
36304 ztc(1,3)=dcmplx(uh*xig,0d0)
36305 ztc(1,4)=ztc(1,3)
36306 ztc(1,5)=ztc(1,2)
36307 ztc(1,6)=ztc(1,2)
36308 ztc(2,3)=dcmplx(uh*xig*x11,0d0)
36309 ztc(2,4)=dcmplx(uh*xig*x22,0d0)
36310 ztc(2,5)=dcmplx(uh*xig*x12,0d0)
36311 ztc(2,6)=dcmplx(uh*xig*x21,0d0)
36312 ztc(3,4)=-sm1122
36313 ztc(3,5)=-sm1112
36314 ztc(3,6)=-sm1121
36315 ztc(4,5)=-sm2212
36316 ztc(4,6)=-sm2221
36317 ztc(5,6)=-sm1221
36318 DO 210 i=1,5
36319 DO 200 j=i+1,6
36320 ztc(j,i)=ztc(i,j)
36321 200 CONTINUE
36322 210 CONTINUE
36323 CALL pyldcm(ztc,6,6,indx,d)
36324 DO 230 i=1,6
36325 DO 220 j=1,6
36326 ytc(i,j)=(0d0,0d0)
36327 IF(i.EQ.j) ytc(i,j)=(1d0,0d0)
36328 220 CONTINUE
36329 230 CONTINUE
36330 DO 240 i=1,6
36331 CALL pybksb(ztc,6,6,indx,ytc(1,i))
36332 240 CONTINUE
36333 dggu=ytc(1,1)
36334 dvvu=ytc(2,2)
36335 dgvu=ytc(1,2)
36336
36337 IF(imdl.EQ.1) THEN
36338 dqqs=dggs+dvvs*dcmplx(tant3**2)-dgvs*dcmplx(2d0*tant3)
36339 dqqt=dggt+dvvt*dcmplx(tant3**2)-dgvt*dcmplx(2d0*tant3)
36340 dqqu=dggu+dvvu*dcmplx(tant3**2)-dgvu*dcmplx(2d0*tant3)
36341 dqts=dggs-dvvs-dgvs*dcmplx(tant3-1d0/tant3)
36342 dqgs=dggs-dgvs*dcmplx(tant3)
36343 dtgs=dggs+dgvs*dcmplx(1d0/tant3)
36344 ELSE
36345 dqqs=dggs+dvvs*dcmplx(1d0/tant3**2)+dgvs*dcmplx(2d0/tant3)
36346 dqqt=dggt+dvvt*dcmplx(1d0/tant3**2)+dgvt*dcmplx(2d0/tant3)
36347 dqqu=dggu+dvvu*dcmplx(1d0/tant3**2)+dgvu*dcmplx(2d0/tant3)
36348 dqts=dggs+dvvs*dcmplx(1d0/tant3**2)+dgvs*dcmplx(2d0/tant3)
36349 dqgs=dggs+dgvs*dcmplx(1d0/tant3)
36350 dtgs=dggs+dgvs*dcmplx(1d0/tant3)
36351 ENDIF
36352
36353 sqdqts=abs(dqts)**2
36354 sqdqqs=abs(dqqs)**2
36355 sqdqqt=abs(dqqt)**2
36356 sqdqqu=abs(dqqu)**2
36357 sqdlgs=abs(dcmplx(sh)*dqgs-dcmplx(1d0))**2
36358 redlgs=dble(dqgs)
36359 sqdhgs=abs(dcmplx(sh)*dtgs-dcmplx(1d0))**2
36360 redhgs=dble(dtgs)
36361 sqdlgt=abs(dcmplx(th)*dggt-dcmplx(1d0))**2
36362
36363 sqdggs=abs(dggs)**2
36364 sqdggt=abs(dggt)**2
36365 sqdggu=abs(dggu)**2
36366 redggs=dble(dggs)
36367 redggt=dble(dggt)
36368 redggu=dble(dggu)
36369 redgtu=dble(dggu*dconjg(dggt))
36370 redgsu=dble(dggu*dconjg(dggs))
36371 redgst=dble(dggs*dconjg(dggt))
36372 redqst=dble(dqqs*dconjg(dqqt))
36373 redqtu=dble(dqqt*dconjg(dqqu))
36374 ENDIF
36375 ENDIF
36376
36377
36378C...Differential cross section expressions.
36379
36380 IF(isub.LE.190) THEN
36381 IF(isub.EQ.149) THEN
36382C...g + g -> eta_tc
36383 kctc=pycomp(ktechn+331)
36384 CALL pywidt(ktechn+331,sh,wdtp,wdte)
36385 hs=shr*wdtp(0)
36386 facbw=comfac*0.5d0/((sh-pmas(kctc,1)**2)**2+hs**2)
36387 IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
36388 hp=sh
36389 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 250
36390 hi=hp*wdtp(3)
36391 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
36392 nchn=nchn+1
36393 isig(nchn,1)=21
36394 isig(nchn,2)=21
36395 isig(nchn,3)=1
36396 sigh(nchn)=hi*facbw*hf
36397 250 CONTINUE
36398
36399 ELSEIF(isub.EQ.165) THEN
36400C...q + qbar -> l+ + l- (including contact term for compositeness)
36401 zratr=xwc*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
36402 zrati=xwc*sh*gmmz/((sh-sqmz)**2+gmmz**2)
36403 kff=iabs(kfpr(isub,1))
36404 ef=kchg(kff,1)/3d0
36405 af=sign(1d0,ef+0.1d0)
36406 vf=af-4d0*ef*xwv
36407 valf=vf+af
36408 varf=vf-af
36409 fcof=1d0
36410 IF(kff.LE.10) fcof=3d0
36411 wid2=1d0
36412 IF(kff.EQ.6) wid2=wids(6,1)
36413 IF(kff.EQ.7.OR.kff.EQ.8) wid2=wids(kff,1)
36414 IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
36415 DO 260 i=mmina,mmaxa
36416 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 260
36417 ei=kchg(iabs(i),1)/3d0
36418 ai=sign(1d0,ei+0.1d0)
36419 vi=ai-4d0*ei*xwv
36420 vali=vi+ai
36421 vari=vi-ai
36422 fcoi=1d0
36423 IF(iabs(i).LE.10) fcoi=faca/3d0
36424 IF((itcm(5).EQ.1.AND.iabs(i).LE.2).OR.itcm(5).EQ.2) THEN
36425 fgza=(ei*ef+vali*valf*zratr+rtcm(42)*sh/
36426 & (aem*rtcm(41)**2))**2+(vali*valf*zrati)**2+
36427 & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
36428 ELSE
36429 fgza=(ei*ef+vali*valf*zratr)**2+(vali*valf*zrati)**2+
36430 & (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2
36431 ENDIF
36432 fgzb=(ei*ef+vali*varf*zratr)**2+(vali*varf*zrati)**2+
36433 & (ei*ef+vari*valf*zratr)**2+(vari*valf*zrati)**2
36434 fgzab=aem**2*(fgza*uh2/sh2+fgzb*th2/sh2)
36435 IF((itcm(5).EQ.3.AND.iabs(i).EQ.2).OR.(itcm(5).EQ.4.AND.
36436 & mod(iabs(i),2).EQ.0)) fgzab=fgzab+sh2/(2d0*rtcm(41)**4)
36437 nchn=nchn+1
36438 isig(nchn,1)=i
36439 isig(nchn,2)=-i
36440 isig(nchn,3)=1
36441 sigh(nchn)=comfac*fcoi*fcof*fgzab*wid2
36442 260 CONTINUE
36443
36444 ELSEIF(isub.EQ.166) THEN
36445C...q + q'bar -> l + nu_l (including contact term for compositeness)
36446 wfac=(1d0/4d0)*(aem/xw)**2*uh2/((sh-sqmw)**2+gmmw**2)
36447 wcifac=wfac+sh2/(4d0*rtcm(41)**4)
36448 kff=iabs(kfpr(isub,1))
36449 fcof=1d0
36450 IF(kff.LE.10) fcof=3d0
36451 DO 280 i=mmin1,mmax1
36452 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 280
36453 ia=iabs(i)
36454 DO 270 j=mmin2,mmax2
36455 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 270
36456 ja=iabs(j)
36457 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 270
36458 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
36459 & GOTO 270
36460 fcoi=1d0
36461 IF(ia.LE.10) fcoi=vckm((ia+1)/2,(ja+1)/2)*faca/3d0
36462 wid2=1d0
36463 IF((i.GT.0.AND.mod(i,2).EQ.0).OR.(j.GT.0.AND.
36464 & mod(j,2).EQ.0)) THEN
36465 IF(kff.EQ.5) wid2=wids(6,2)
36466 IF(kff.EQ.7) wid2=wids(8,2)*wids(7,3)
36467 IF(kff.EQ.17) wid2=wids(18,2)*wids(17,3)
36468 ELSE
36469 IF(kff.EQ.5) wid2=wids(6,3)
36470 IF(kff.EQ.7) wid2=wids(8,3)*wids(7,2)
36471 IF(kff.EQ.17) wid2=wids(18,3)*wids(17,2)
36472 ENDIF
36473 nchn=nchn+1
36474 isig(nchn,1)=i
36475 isig(nchn,2)=j
36476 isig(nchn,3)=1
36477 sigh(nchn)=comfac*fcoi*fcof*wfac*wid2
36478 IF((itcm(5).EQ.3.AND.ia.LE.2.AND.ja.LE.2).OR.itcm(5).EQ.4)
36479 & sigh(nchn)=comfac*fcoi*fcof*wcifac*wid2
36480 270 CONTINUE
36481 280 CONTINUE
36482 ENDIF
36483
36484 ELSEIF(isub.LE.200) THEN
36485 IF(isub.EQ.191) THEN
36486C...q + qbar -> rho_tc0.
36487 kctc=pycomp(ktechn+113)
36488 sqmrht=pmas(kctc,1)**2
36489 CALL pywidt(ktechn+113,sh,wdtp,wdte)
36490 hs=shr*wdtp(0)
36491 facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
36492 IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
36493 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
36494 alprht=2.16d0*(3d0/itcm(1))
36495 hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)
36496 xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))
36497 bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
36498 bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)
36499 DO 290 i=mmina,mmaxa
36500 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 290
36501 ia=iabs(i)
36502 ei=kchg(iabs(i),1)/3d0
36503 ai=sign(1d0,ei+0.1d0)
36504 vi=ai-4d0*ei*xwv
36505 vali=0.5d0*(vi+ai)
36506 vari=0.5d0*(vi-ai)
36507 hi=hp*((ei+vali*bwzr)**2+(vali*bwzi)**2+
36508 & (ei+vari*bwzr)**2+(vari*bwzi)**2)
36509 IF(ia.LE.10) hi=hi*faca/3d0
36510 nchn=nchn+1
36511 isig(nchn,1)=i
36512 isig(nchn,2)=-i
36513 isig(nchn,3)=1
36514 sigh(nchn)=hi*facbw*hf
36515 290 CONTINUE
36516
36517 ELSEIF(isub.EQ.192) THEN
36518C...q + qbar' -> rho_tc+/-.
36519 kctc=pycomp(ktechn+213)
36520 sqmrht=pmas(kctc,1)**2
36521 CALL pywidt(ktechn+213,sh,wdtp,wdte)
36522 hs=shr*wdtp(0)
36523 facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)
36524 IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
36525 alprht=2.16d0*(3d0/itcm(1))
36526 hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)*
36527 & (0.25d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)
36528 DO 310 i=mmin1,mmax1
36529 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 310
36530 ia=iabs(i)
36531 DO 300 j=mmin2,mmax2
36532 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 300
36533 ja=iabs(j)
36534 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 300
36535 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
36536 & GOTO 300
36537 kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
36538 hf=shr*(wdte(0,1)+wdte(0,(5-kchr)/2)+wdte(0,4))
36539 hi=hp
36540 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
36541 nchn=nchn+1
36542 isig(nchn,1)=i
36543 isig(nchn,2)=j
36544 isig(nchn,3)=1
36545 sigh(nchn)=hi*facbw*hf
36546 300 CONTINUE
36547 310 CONTINUE
36548
36549 ELSEIF(isub.EQ.193) THEN
36550C...q + qbar -> omega_tc0.
36551 kctc=pycomp(ktechn+223)
36552 sqmomt=pmas(kctc,1)**2
36553 CALL pywidt(ktechn+223,sh,wdtp,wdte)
36554 hs=shr*wdtp(0)
36555 facbw=12d0*comfac/((sh-sqmomt)**2+hs**2)
36556 IF(abs(shr-pmas(kctc,1)).GT.parp(48)*pmas(kctc,2)) facbw=0d0
36557 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
36558 alprht=2.16d0*(3d0/itcm(1))
36559 hp=(1d0/6d0)*(aem**2/alprht)*(sqmomt**2/sh)*
36560 & (2d0*rtcm(2)-1d0)**2
36561 bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)
36562 bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)
36563 DO 320 i=mmina,mmaxa
36564 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 320
36565 ia=iabs(i)
36566 ei=kchg(iabs(i),1)/3d0
36567 ai=sign(1d0,ei+0.1d0)
36568 vi=ai-4d0*ei*xwv
36569 vali=0.5d0*(vi+ai)
36570 vari=0.5d0*(vi-ai)
36571 hi=hp*((ei-vali*bwzr)**2+(vali*bwzi)**2+
36572 & (ei-vari*bwzr)**2+(vari*bwzi)**2)
36573 IF(ia.LE.10) hi=hi*faca/3d0
36574 nchn=nchn+1
36575 isig(nchn,1)=i
36576 isig(nchn,2)=-i
36577 isig(nchn,3)=1
36578 sigh(nchn)=hi*facbw*hf
36579 320 CONTINUE
36580
36581 ELSEIF(isub.EQ.194) THEN
36582C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36583C...Default final state is e+e-
36584 kfa=kfpr(isubsv,1)
36585 alprht=2.16d0*(3d0/itcm(1))
36586 hp=aem**2*comfac
36587
36588 sn2w=2d0*sqrt(xw*xw1)
36589C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36590C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36591
36592 qupd=2d0*rtcm(2)-1d0
36593 far=sqrt(aem/alprht)
36594 fao=far*qupd
36595 fzr=far*ct2w
36596 fzo=-fao*tanw
36597C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36598 fzx=-far/sn2w*rtcm(47)
36599 sfar=far**2
36600 sfao=fao**2
36601 sfzr=fzr**2
36602 sfzo=fzo**2
36603 sfzx=fzx**2
36604 CALL pywidt(23,sh,wdtp,wdte)
36605 ssmz=dcmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
36606 CALL pywidt(ktechn+113,sh,wdtp,wdte)
36607 ssmr=dcmplx(1d0-pmas(pycomp(ktechn+113),1)**2/sh,wdtp(0)/shr)
36608 CALL pywidt(ktechn+223,sh,wdtp,wdte)
36609 ssmo=dcmplx(1d0-pmas(pycomp(ktechn+223),1)**2/sh,wdtp(0)/shr)
36610 CALL pywidt(ktechn+115,sh,wdtp,wdte)
36611 ssmx=dcmplx(1d0-pmas(pycomp(ktechn+115),1)**2/sh,wdtp(0)/shr)
36612C...Propagator including a_T^0
36613 detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
36614 $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
36615C...Add in techni-a contribution
36616 detd=ssmx*detd-sfzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)
36617 daa=(-ssmx*(sfzo*ssmr+sfzr*ssmo-ssmo*ssmr*ssmz)-
36618 $ sfzx*ssmr*ssmo)/detd/sh
36619 dzz=-(sfao*ssmr+sfar*ssmo-ssmo*ssmr)/detd/sh*ssmx
36620 daz=(far*fzr*ssmo+fao*fzo*ssmr)/detd/sh*ssmx
36621
36622 xwrht=1d0/(4d0*xw*(1d0-xw))
36623 kff=iabs(kfpr(isub,1))
36624 ef=kchg(kff,1)/3d0
36625 af=sign(1d0,ef+0.1d0)
36626 vf=af-4d0*ef*xwv
36627 valf=0.5d0*(vf+af)
36628 varf=0.5d0*(vf-af)
36629 fcof=1d0
36630 IF(kff.LE.10) fcof=3d0
36631
36632 wid2=1d0
36633 IF(kff.GE.6.AND.kff.LE.8) wid2=wids(kff,1)
36634 IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)
36635 dzz=dzz*dcmplx(xwrht,0d0)
36636 daz=daz*dcmplx(sqrt(xwrht),0d0)
36637
36638 DO 330 i=mmina,mmaxa
36639 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 330
36640 ei=kchg(iabs(i),1)/3d0
36641 ai=sign(1d0,ei+0.1d0)
36642 vi=ai-4d0*ei*xwv
36643 vali=0.5d0*(vi+ai)
36644 vari=0.5d0*(vi-ai)
36645 fcoi=fcof
36646 IF(iabs(i).LE.10) fcoi=fcoi/3d0
36647 difll=abs(ei*ef*daa+vali*valf*dzz+daz*(ei*valf+ef*vali))**2
36648 difrr=abs(ei*ef*daa+vari*varf*dzz+daz*(ei*varf+ef*vari))**2
36649 diflr=abs(ei*ef*daa+vali*varf*dzz+daz*(ei*varf+ef*vali))**2
36650 difrl=abs(ei*ef*daa+vari*valf*dzz+daz*(ei*valf+ef*vari))**2
36651 facsig=(difll+difrr)*((uh-sqm4)**2+sh*sqm4)+
36652 & (diflr+difrl)*((th-sqm3)**2+sh*sqm3)
36653 nchn=nchn+1
36654 isig(nchn,1)=i
36655 isig(nchn,2)=-i
36656 isig(nchn,3)=1
36657 sigh(nchn)=hp*fcoi*facsig*wid2
36658 330 CONTINUE
36659
36660 ELSEIF(isub.EQ.195) THEN
36661C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36662 kfa=kfpr(isubsv,1)
36663 kfb=kfa+1
36664 alprht=2.16d0*(3d0/itcm(1))
36665 factc=comfac*(aem**2/12d0/xw**2)*(uh-sqm3)*(uh-sqm4)*3d0
36666
36667 fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
36668C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36669C
36670C...Propagator including a_T^+
36671 fwx=-fwr*rtcm(47)
36672 CALL pywidt(24,sh,wdtp,wdte)
36673 ssmz=dcmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
36674 CALL pywidt(ktechn+213,sh,wdtp,wdte)
36675 ssmr=dcmplx(1d0-pmas(pycomp(ktechn+213),1)**2/sh,wdtp(0)/shr)
36676 CALL pywidt(ktechn+215,sh,wdtp,wdte)
36677 ssmx=dcmplx(1d0-pmas(pycomp(ktechn+215),1)**2/sh,wdtp(0)/shr)
36678 detd=ssmx*(ssmz*ssmr-dcmplx(fwr**2,0d0))-
36679 & dcmplx(fwx**2,0d0)*ssmr
36680 dww=ssmr*ssmx/detd/sh
36681 fcof=1d0
36682 IF(kfa.LE.8) fcof=3d0
36683 hp=factc*abs(dww)**2*fcof
36684
36685 DO 350 i=mmin1,mmax1
36686 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 350
36687 ia=iabs(i)
36688 DO 340 j=mmin2,mmax2
36689 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 340
36690 ja=iabs(j)
36691 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 340
36692 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
36693 & GOTO 340
36694 kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
36695 hi=hp
36696 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
36697 nchn=nchn+1
36698 isig(nchn,1)=i
36699 isig(nchn,2)=j
36700 isig(nchn,3)=1
36701 sigh(nchn)=hi*wids(kfa,(5-kchr)/2)*wids(kfb,(5+kchr)/2)
36702 340 CONTINUE
36703 350 CONTINUE
36704 ENDIF
36705
36706 ELSEIF(isub.LE.380) THEN
36707 alprht=2.16d0*(3d0/itcm(1))
36708 IF(isub.EQ.361) THEN
36709 far=sqrt(aem/alprht)
36710 fao=far*qupd
36711 fzr=far*ct2w
36712 fzo=-fao*tanw
36713C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36714 fzx=-far/sn2w*rtcm(47)
36715 sfar=far**2
36716 sfao=fao**2
36717 sfzr=fzr**2
36718 sfzo=fzo**2
36719 sfzx=fzx**2
36720 CALL pywidt(23,sh,wdtp,wdte)
36721 ssmz=dcmplx(1d0-pmas(23,1)**2/sh,wdtp(0)/shr)
36722 CALL pywidt(ktechn+113,sh,wdtp,wdte)
36723 ssmr=dcmplx(1d0-pmas(pycomp(ktechn+113),1)**2/sh,wdtp(0)/shr)
36724 CALL pywidt(ktechn+223,sh,wdtp,wdte)
36725 ssmo=dcmplx(1d0-pmas(pycomp(ktechn+223),1)**2/sh,wdtp(0)/shr)
36726 CALL pywidt(ktechn+115,sh,wdtp,wdte)
36727 ssmx=dcmplx(1d0-pmas(pycomp(ktechn+115),1)**2/sh,wdtp(0)/shr)
36728 detd=(far*fzo-fao*fzr)**2+ssmz*ssmr*ssmo-sfzr*ssmo-
36729 $ sfzo*ssmr-sfar*ssmo*ssmz-sfao*ssmr*ssmz
36730C...Add in techni-a contribution
36731 detd=ssmx*detd-sfzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)
36732 darho=-(ssmx*(-far*sfzo+fao*fzo*fzr+far*ssmo*ssmz)-
36733 $ sfzx*far*ssmo)/detd/sh
36734 dzrho=-(-fzr*sfao+fao*fzo*far+fzr*ssmo)/detd/sh*ssmx
36735 daome=-(ssmx*(-fao*sfzr+far*fzo*fzr+fao*ssmr*ssmz)-
36736 $ sfzx*fao*ssmr)/detd/sh
36737 dzome=-(-fzo*sfar+far*fao*fzr+fzo*ssmr)/detd/sh*ssmx
36738 daast=-fzx*(fao*fzo*ssmr+far*fzr*ssmo)/detd/sh
36739 dzast=-fzx*(ssmr*ssmo-sfao*ssmr-sfar*ssmo)/detd/sh
36740 daa=(-ssmx*(sfzo*ssmr+sfzr*ssmo-ssmo*ssmr*ssmz)-
36741 $ sfzx*ssmr*ssmo)/detd/sh
36742 dzz=-(sfao*ssmr+sfar*ssmo-ssmo*ssmr)/detd/sh*ssmx
36743 daz=(far*fzr*ssmo+fao*fzo*ssmr)/detd/sh*ssmx
36744
36745C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36746C...W+W-, W pi_tc, pi_T pi_T, etc.
36747 faca=(sh**2*be34**2-(th-uh)**2)
36748 vfac=(th**2+uh**2-2d0*sqm3*sqm4)
36749 afac=(th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm3)
36750 fanom=sqrt(paru(1)*aem)*itcm(1)/paru(2)**2/rtcm(1)
36751 hp=(1d0/24d0)*aem**2*comfac*3d0*sh
36752 DO 370 i=mmina,mmaxa
36753 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 370
36754 ia=iabs(i)
36755 ei=kchg(iabs(i),1)/3d0
36756 ai=sign(1d0,ei+0.1d0)
36757 vi=ai-4d0*ei*xwv
36758 vali=0.25d0*(vi+ai) ! = \zeta_{iL} in PRD67-115011
36759 vari=0.25d0*(vi-ai) ! = \zeta_{iR} in PRD67-115011
36760C...........Eqs. (5) and (6) in LSTC-rates.pdf
36761 f2l=(ei*darho+vali*dzrho/sqrt(xw*xw1))*vrgp
36762 f2l=f2l+(ei*daome+vali*dzome/sqrt(xw*xw1))*vogp
36763 f2l=f2l+(ei*daast+vali*dzast/sqrt(xw*xw1))*vxgp
36764 f2l=f2l+fanom*(vagp*(ei*daa+vali*daz/sqrt(xw*xw1))+
36765 $ vzgp*(ei*daz+vali*dzz/sqrt(xw*xw1)))
36766 f2r=(ei*darho+vari*dzrho/sqrt(xw*xw1))*vrgp
36767 f2r=f2r+(ei*daome+vari*dzome/sqrt(xw*xw1))*vogp
36768 f2r=f2r+(ei*daast+vari*dzast/sqrt(xw*xw1))*vxgp
36769 f2r=f2r+fanom*(vagp*(ei*daa+vari*daz/sqrt(xw*xw1))+
36770 $ vzgp*(ei*daz+vari*dzz/sqrt(xw*xw1)))
36771 hi=(abs(f2l)**2+abs(f2r)**2)*vfac
36772C...........Eqs. (5) and (7) in LSTC-rates.pdf
36773 f2l=(ei*darho+vali*dzrho/sqrt(xw*xw1))*argp
36774 f2l=f2l+(ei*daome+vali*dzome/sqrt(xw*xw1))*aogp
36775 f2l=f2l+(ei*daast+vali*dzast/sqrt(xw*xw1))*axgp
36776 f2r=(ei*darho+vari*dzrho/sqrt(xw*xw1))*argp
36777 f2r=f2r+(ei*daome+vari*dzome/sqrt(xw*xw1))*aogp
36778 f2r=f2r+(ei*daast+vari*dzast/sqrt(xw*xw1))*axgp
36779 hj=(abs(f2l)**2+abs(f2r)**2)*afac
36780C
36781C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36782C
36783c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36784c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36785c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36786c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36787 f2l=ei*darho/far + vali*ct2w*dzrho/fzr/sqrt(xw*xw1)
36788 f2r=ei*darho/far + vari*ct2w*dzrho/fzr/sqrt(xw*xw1)
36789 hk=(abs(f2l)**2+abs(f2r)**2)*2d0*faca*cab2/sh
36790 hi=hi+hj+hk
36791 IF(ia.LE.10) hi=hi/3d0
36792 nchn=nchn+1
36793 isig(nchn,1)=i
36794 isig(nchn,2)=-i
36795 isig(nchn,3)=1
36796 IF(kfa.EQ.kfb) THEN
36797 sigh(nchn)=hi*hp*wids(pycomp(kfa),1)
36798 ELSEIF(isubsv.EQ.362.OR.isubsv.EQ.368) THEN
36799 sigh(nchn)=hi*hp*wids(pycomp(kfa),2)*wids(pycomp(kfb),3)
36800 nchn=nchn+1
36801 isig(nchn,1)=i
36802 isig(nchn,2)=-i
36803 isig(nchn,3)=2
36804 sigh(nchn)=hi*hp*wids(pycomp(kfa),3)*wids(pycomp(kfb),2)
36805 ELSE
36806 sigh(nchn)=hi*hp*wids(pycomp(kfa),2)*wids(pycomp(kfb),2)
36807 ENDIF
36808 370 CONTINUE
36809
36810 ELSEIF(isub.EQ.370) THEN
36811C...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
36812C...f + fbar' -> gamma pi_tc, etc.
36813 faca=(sh**2*be34**2-(th-uh)**2)
36814 fanom=sqrt(paru(1)*aem)*itcm(1)/paru(2)**2/rtcm(1)
36815 vfac=(th**2+uh**2-2d0*sqm3*sqm4)
36816 afac=(th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm3)
36817 alprht=2.16d0*(3d0/itcm(1))
36818 fachp=(1d0/48d0)*aem**2/xw*comfac*3d0*sh
36819 fwr=sqrt(aem/alprht)/(2d0*sqrt(xw))
36820C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36821 fwx=-fwr*rtcm(47)
36822 CALL pywidt(24,sh,wdtp,wdte)
36823 ssmz=dcmplx(1d0-pmas(24,1)**2/sh,wdtp(0)/shr)
36824 CALL pywidt(ktechn+213,sh,wdtp,wdte)
36825 ssmr=dcmplx(1d0-pmas(pycomp(ktechn+213),1)**2/sh,wdtp(0)/shr)
36826 CALL pywidt(ktechn+215,sh,wdtp,wdte)
36827 ssmx=dcmplx(1d0-pmas(pycomp(ktechn+215),1)**2/sh,wdtp(0)/shr)
36828 detd=ssmx*(ssmz*ssmr-dcmplx(fwr**2,0d0))-
36829 & dcmplx(fwx**2,0d0)*ssmr
36830 dww=ssmr*ssmx/detd/sh
36831 dwrho=-dcmplx(fwr,0d0)*ssmx/detd/sh
36832 dwast=-dcmplx(fwx,0d0)*ssmr/detd/sh
36833 hp=fachp*(afac*abs(dwrho*argp+dwast*axgp)**2+
36834 $ vfac*abs(fanom*dww*vwgp+dwrho*vrgp+dwast*vxgp)**2)
36835C
36836C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36837C
36838c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36839 hp=hp+.5d0*fachp*cab2*faca/xw/sh*abs(dwrho/fwr)**2
36840C...Add in W_L Z_T axial and vector contributions.
36841 IF(isubsv.EQ.370) hp=hp+fachp*rtcm(3)**2*(
36842 $ (th**2+uh**2-2d0*sqm3*sqm4+4d0*sh*sqm4)* !AFAC w/ switched masses.
36843 $ abs(dwrho/rtcm(13)-dwast/rtcm(49)*cs2w)**2/sn2w**2+
36844 $ vfac*qupd**2*xw/xw1*abs(dwrho)**2/rtcm(12)**2)
36845 DO 410 i=mmin1,mmax1
36846 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 410
36847 ia=iabs(i)
36848 DO 400 j=mmin2,mmax2
36849 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 400
36850 ja=iabs(j)
36851 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 400
36852 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
36853 & GOTO 400
36854 kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
36855 hi=hp
36856 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)/3d0
36857 nchn=nchn+1
36858 isig(nchn,1)=i
36859 isig(nchn,2)=j
36860 isig(nchn,3)=1
36861 IF(isubsv.EQ.374.OR.isubsv.EQ.378) THEN
36862 sigh(nchn)=hi*wids(pycomp(kfa),(5-kchr)/2)
36863 ELSE
36864 sigh(nchn)=hi*wids(pycomp(kfa),(5-kchr)/2)*
36865 & wids(pycomp(kfb),2)
36866 ENDIF
36867 400 CONTINUE
36868 410 CONTINUE
36869 ENDIF
36870
36871 ELSEIF(isub.LE.390) THEN
36872 IF(isub.EQ.381) THEN
36873C...f + f' -> f + f' (g exchange)
36874 facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)*sqdqqt
36875 facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)*sqdqqt*faca-
36876 & mstp(34)*2d0/3d0*uh2*redqst)
36877 facqq2=comfac*as**2*4d0/9d0*(sh2+th2)*sqdqqu
36878 facqqi=-comfac*as**2*4d0/9d0*mstp(34)*2d0/3d0*sh2/(th*uh)
36879 ratqqi=(facqq1+facqq2+facqqi)/(facqq1+facqq2)
36880 IF(itcm(5).GE.1.AND.itcm(5).LE.4) THEN
36881C...Modifications from contact interactions (compositeness)
36882 facci1=facqq1+comfac*(sh2/rtcm(41)**4)
36883 faccib=facqqb+comfac*(8d0/9d0)*(as*rtcm(42)/rtcm(41)**2)*
36884 & (uh2/th+uh2/sh)+comfac*(5d0/3d0)*(uh2/rtcm(41)**4)
36885 facci2=facqq2+comfac*(8d0/9d0)*(as*rtcm(42)/rtcm(41)**2)*
36886 & (sh2/th+sh2/uh)+comfac*(5d0/3d0)*(sh2/rtcm(41)**4)
36887 facci3=facqq1+comfac*(uh2/rtcm(41)**4)
36888 ratcii=(facci1+facci2+facqqi)/(facci1+facci2)
36889 ELSEIF(itcm(5).EQ.5) THEN
36890 facci1=facqq1
36891 faccib=facqqb
36892 facci2=facqq2
36893 facci3=facqq1
36894CSM.......Check this change from
36895CSM RATCII=1D0
36896 ratcii=ratqqi
36897 ENDIF
36898 DO 430 i=mmin1,mmax1
36899 ia=iabs(i)
36900 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 430
36901 DO 420 j=mmin2,mmax2
36902 ja=iabs(j)
36903 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 420
36904 nchn=nchn+1
36905 isig(nchn,1)=i
36906 isig(nchn,2)=j
36907 isig(nchn,3)=1
36908 IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.(ia.GE.3.OR.
36909 & ja.GE.3))) THEN
36910 sigh(nchn)=facqq1
36911 IF(i.EQ.-j) sigh(nchn)=facqqb
36912 ELSE
36913 sigh(nchn)=facci1
36914 IF(i*j.LT.0) sigh(nchn)=facci3
36915 IF(i.EQ.-j) sigh(nchn)=faccib
36916 ENDIF
36917 IF(i.EQ.j) THEN
36918 nchn=nchn+1
36919 isig(nchn,1)=i
36920 isig(nchn,2)=j
36921 isig(nchn,3)=2
36922 IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.ia.GE.3)) THEN
36923 sigh(nchn-1)=0.5d0*facqq1*ratqqi
36924 sigh(nchn)=0.5d0*facqq2*ratqqi
36925 ELSE
36926 sigh(nchn-1)=0.5d0*facci1*ratcii
36927 sigh(nchn)=0.5d0*facci2*ratcii
36928 ENDIF
36929 ENDIF
36930 420 CONTINUE
36931 430 CONTINUE
36932
36933 ELSEIF(isub.EQ.382) THEN
36934C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
36935 CALL pywidt(21,sh,wdtp,wdte)
36936 facqqf=comfac*as**2*4d0/9d0*(th2+uh2)
36937 facqqb=facqqf*sqdqqs*(wdte(0,1)+wdte(0,2)+wdte(0,4))
36938 IF(itcm(5).EQ.1) THEN
36939C...Modifications from contact interactions (compositeness)
36940 faccib=facqqb
36941 DO 440 i=1,2
36942 faccib=faccib+comfac*(uh2/rtcm(41)**4)*(wdte(i,1)+
36943 & wdte(i,2)+wdte(i,4))
36944 440 CONTINUE
36945 ELSEIF(itcm(5).GE.2.AND.itcm(5).LE.4) THEN
36946 faccib=facqqb+comfac*(uh2/rtcm(41)**4)*
36947 & (wdte(0,1)+wdte(0,2)+wdte(0,4))
36948 ELSEIF(itcm(5).EQ.5) THEN
36949 facqqb=facqqf*sqdqqs*(wdte(0,1)+wdte(0,2)+wdte(0,4)-
36950 & wdte(5,1)-wdte(5,2)-wdte(5,4))
36951 faccib=facqqf*sqdqts*(wdte(5,1)+wdte(5,2)+wdte(5,4))
36952 ENDIF
36953 DO 450 i=mmina,mmaxa
36954 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
36955 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 450
36956 nchn=nchn+1
36957 isig(nchn,1)=i
36958 isig(nchn,2)=-i
36959 isig(nchn,3)=1
36960 IF(itcm(5).LE.0.OR.(itcm(5).EQ.1.AND.iabs(i).GE.3)) THEN
36961 sigh(nchn)=facqqb
36962 ELSEIF(itcm(5).EQ.5) THEN
36963 sigh(nchn)=facqqb
36964 nchn=nchn+1
36965 isig(nchn,1)=i
36966 isig(nchn,2)=-i
36967 isig(nchn,3)=2
36968 sigh(nchn)=faccib
36969 ELSE
36970 sigh(nchn)=faccib
36971 ENDIF
36972 450 CONTINUE
36973
36974 ELSEIF(isub.EQ.383) THEN
36975C...f + fbar -> g + g (q + qbar -> g + g only)
36976 facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
36977 & uh2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)
36978 facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
36979 & th2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)
36980 IF(itcm(5).EQ.5) THEN
36981 facgg3=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
36982 & uh2/sh2+9d0/4d0*th*uh/sh2*sqdhgs)
36983 facgg4=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
36984 & th2/sh2+9d0/4d0*th*uh/sh2*sqdhgs)
36985 ENDIF
36986 DO 460 i=mmina,mmaxa
36987 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
36988 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 460
36989 nchn=nchn+1
36990 isig(nchn,1)=i
36991 isig(nchn,2)=-i
36992 isig(nchn,3)=1
36993 sigh(nchn)=0.5d0*facgg1
36994 IF(itcm(5).EQ.5.AND.iabs(i).EQ.5) sigh(nchn)=0.5d0*facgg3
36995 nchn=nchn+1
36996 isig(nchn,1)=i
36997 isig(nchn,2)=-i
36998 isig(nchn,3)=2
36999 sigh(nchn)=0.5d0*facgg2
37000 IF(itcm(5).EQ.5.AND.iabs(i).EQ.5) sigh(nchn)=0.5d0*facgg4
37001 460 CONTINUE
37002
37003 ELSEIF(isub.EQ.384) THEN
37004C...f + g -> f + g (q + g -> q + g only)
37005 facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-
37006 & uh/sh-9d0/4d0*sh*uh/th2*sqdlgt)*faca
37007 facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-
37008 & sh/uh-9d0/4d0*sh*uh/th2*sqdlgt)
37009 DO 480 i=mmina,mmaxa
37010 IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 480
37011 DO 470 isde=1,2
37012 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 470
37013 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 470
37014 nchn=nchn+1
37015 isig(nchn,isde)=i
37016 isig(nchn,3-isde)=21
37017 isig(nchn,3)=1
37018 sigh(nchn)=facqg1
37019 nchn=nchn+1
37020 isig(nchn,isde)=i
37021 isig(nchn,3-isde)=21
37022 isig(nchn,3)=2
37023 sigh(nchn)=facqg2
37024 470 CONTINUE
37025 480 CONTINUE
37026
37027 ELSEIF(isub.EQ.385) THEN
37028C...g + g -> f + fbar (g + g -> q + qbar only)
37029 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 500
37030 idc0=mdcy(21,2)-1
37031C...Begin by d, u, s flavours.
37032 flavwt=0d0
37033 IF(mdme(idc0+1,1).GE.1) flavwt=flavwt+
37034 & sqrt(max(0d0,1d0-4d0*pmas(1,1)**2/sh))
37035 IF(mdme(idc0+2,1).GE.1) flavwt=flavwt+
37036 & sqrt(max(0d0,1d0-4d0*pmas(2,1)**2/sh))
37037 IF(mdme(idc0+3,1).GE.1) flavwt=flavwt+
37038 & sqrt(max(0d0,1d0-4d0*pmas(3,1)**2/sh))
37039 facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*
37040 & uh2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)*flavwt*faca
37041 facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*
37042 & th2/sh2+9d0/4d0*th*uh/sh2*sqdlgs)*flavwt*faca
37043 nchn=nchn+1
37044 isig(nchn,1)=21
37045 isig(nchn,2)=21
37046 isig(nchn,3)=1
37047 sigh(nchn)=facqq1
37048 nchn=nchn+1
37049 isig(nchn,1)=21
37050 isig(nchn,2)=21
37051 isig(nchn,3)=2
37052 sigh(nchn)=facqq2
37053C...Next c and b flavours: modified that and uhat for fixed
37054C...cos(theta-hat).
37055 DO 490 ifl=4,5
37056 sqmavg=pmas(ifl,1)**2
37057 IF(mdme(idc0+ifl,1).GE.1.AND.sh.GT.4.04d0*sqmavg) THEN
37058 be34=sqrt(1d0-4d0*sqmavg/sh)
37059 thq=-0.5d0*sh*(1d0-be34*cth)
37060 uhq=-0.5d0*sh*(1d0+be34*cth)
37061 thuhq=thq*uhq-sqmavg*sh
37062 IF(mstp(34).EQ.0) THEN
37063 facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
37064 facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
37065 ELSE
37066 facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37067 & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
37068 facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37069 & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
37070 ENDIF
37071 IF(itcm(5).GE.5) THEN
37072 IF(ifl.EQ.4) THEN
37073 facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redlgs+
37074 & 2.25d0*thq*uhq/sh2*sqdlgs
37075 facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redlgs+
37076 & 2.25d0*thq*uhq/sh2*sqdlgs
37077 ELSE
37078 facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redhgs+
37079 & 2.25d0*thq*uhq/sh2*sqdhgs
37080 facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redhgs+
37081 & 2.25d0*thq*uhq/sh2*sqdhgs
37082 ENDIF
37083 ENDIF
37084 facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1*be34
37085 facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2*be34
37086 nchn=nchn+1
37087 isig(nchn,1)=21
37088 isig(nchn,2)=21
37089 isig(nchn,3)=1+2*(ifl-3)
37090 sigh(nchn)=facqq1
37091 nchn=nchn+1
37092 isig(nchn,1)=21
37093 isig(nchn,2)=21
37094 isig(nchn,3)=2+2*(ifl-3)
37095 sigh(nchn)=facqq2
37096 ENDIF
37097 490 CONTINUE
37098 500 CONTINUE
37099
37100 ELSEIF(isub.EQ.386) THEN
37101C...g + g -> g + g
37102 IF(itcm(5).LE.4) THEN
37103 facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+
37104 & 2d0*th/sh+th2/sh2)*faca
37105 facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+
37106 & 2d0*sh/uh+sh2/uh2)*faca
37107 facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+
37108 & 2d0*uh/th+uh2/th2)
37109 ELSE
37110 gst= (12d0 + 40d0*th/sh + 56d0*th2/sh2 + 32d0*th**3/sh**3 +
37111 & 16d0*th**4/sh**4 + sqdggs*(4d0*sh2 + 16d0*sh*th + 16d0*th2)+
37112 & 4d0*redgst*(sh + 2d0*th)*
37113 & (2d0*sh**3 - 3d0*sh2*th - 2d0*sh*th2 + 2d0*th**3)/sh2 +
37114 & 2d0*redggs*(2d0*sh - 12d0*th2/sh - 8d0*th**3/sh2) +
37115 & 2d0*redggt*(4d0*sh - 22d0*th - 68d0*th2/sh - 60d0*th**3/sh2-
37116 & 32d0*th**4/sh**3 - 16d0*th**5/sh**4) +
37117 & sqdggt*(16d0*sh2 + 16d0*sh*th + 68d0*th2 + 144d0*th**3/sh +
37118 & 96d0*th**4/sh2 + 32d0*th**5/sh**3 + 16d0*th**6/sh**4))/16d0
37119 gsu= (12d0 + 40d0*uh/sh + 56d0*uh2/sh2 + 32d0*uh**3/sh**3 +
37120 & 16d0*uh**4/sh**4 + sqdggs*(4d0*sh2 + 16d0*sh*uh + 16d0*uh2)+
37121 & 4d0*redgsu*(sh + 2d0*uh)*
37122 & (2d0*sh**3 - 3d0*sh2*uh - 2d0*sh*uh2 + 2d0*uh**3)/sh2 +
37123 & 2d0*redggs*(2d0*sh - 12d0*uh2/sh - 8d0*uh**3/sh2) +
37124 & 2d0*redggu*(4d0*sh - 22d0*uh - 68d0*uh2/sh - 60d0*uh**3/sh2-
37125 & 32d0*uh**4/sh**3 - 16d0*uh**5/sh**4) +
37126 & sqdggu*(16d0*sh2 + 16d0*sh*uh + 68d0*uh2 + 144d0*uh**3/sh +
37127 & 96d0*uh**4/sh2 + 32d0*uh**5/sh**3 + 16d0*uh**6/sh**4))/16d0
37128 gut= (12d0 - 16d0*th*(th - uh)**2*uh/sh**4 +
37129 & 4d0*redggu*(2d0*th**5 - 15d0*th**4*uh - 48d0*th**3*uh2 -
37130 & 58d0*th2*uh**3 - 10d0*th*uh**4 + uh**5)/sh**4 +
37131 & 4d0*redggt*(th**5 - 10d0*th**4*uh - 58d0*th**3*uh2 -
37132 & 48d0*th2*uh**3 - 15d0*th*uh**4 + 2d0*uh**5)/sh**4 +
37133 & 4d0*sqdggu*(4d0*th**6 + 20d0*th**5*uh + 57d0*th**4*uh2 +
37134 & 72d0*th**3*uh**3+ 38d0*th2*uh**4+4d0*th*uh**5 +uh**6)/sh**4+
37135 & 4d0*sqdggt*(4d0*uh**6 + 4d0*th**5*uh + 38d0*th**4*uh2 +
37136 & 72d0*th**3*uh**3 +57d0*th2*uh**4+20d0*th*uh**5+th**6)/sh**4+
37137 & 2d0*redgtu*((th - uh)**2* (th**4 + 20d0*th**3*uh +
37138 & 30d0*th2*uh2 + 20d0*th*uh**3 + uh**4) +
37139 & sh2*(7d0*th**4 + 52d0*th**3*uh + 274d0*th2*uh2 +
37140 & 52d0*th*uh**3 + 7d0*uh**4))/(2d0*sh**4))/16d0
37141 facgg1=comfac*as**2*9d0/4d0*gst*faca
37142 facgg2=comfac*as**2*9d0/4d0*gsu*faca
37143 facgg3=comfac*as**2*9d0/4d0*gut
37144 ENDIF
37145 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 510
37146 nchn=nchn+1
37147 isig(nchn,1)=21
37148 isig(nchn,2)=21
37149 isig(nchn,3)=1
37150 sigh(nchn)=0.5d0*facgg1
37151 nchn=nchn+1
37152 isig(nchn,1)=21
37153 isig(nchn,2)=21
37154 isig(nchn,3)=2
37155 sigh(nchn)=0.5d0*facgg2
37156 nchn=nchn+1
37157 isig(nchn,1)=21
37158 isig(nchn,2)=21
37159 isig(nchn,3)=3
37160 sigh(nchn)=0.5d0*facgg3
37161 510 CONTINUE
37162
37163 ELSEIF(isub.EQ.387) THEN
37164C...q + qbar -> Q + Qbar
37165 sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
37166 thq=-0.5d0*sh*(1d0-be34*cth)
37167 uhq=-0.5d0*sh*(1d0+be34*cth)
37168 facqqb=comfac*as**2*4d0/9d0*((thq**2+uhq**2)/sh2+
37169 & 2d0*sqmavg/sh)
37170 IF(itcm(5).GE.5) THEN
37171 IF(mint(55).EQ.5.OR.mint(55).EQ.6) THEN
37172 facqqb=facqqb*sh2*sqdqts
37173 ELSE
37174 facqqb=facqqb*sh2*sqdqqs
37175 ENDIF
37176 ENDIF
37177 IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqmavg,0d0)
37178 wid2=1d0
37179 IF(mint(55).EQ.6) wid2=wids(6,1)
37180 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
37181 facqqb=facqqb*wid2
37182 DO 520 i=mmina,mmaxa
37183 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37184 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 520
37185 nchn=nchn+1
37186 isig(nchn,1)=i
37187 isig(nchn,2)=-i
37188 isig(nchn,3)=1
37189 sigh(nchn)=facqqb
37190 520 CONTINUE
37191
37192 ELSEIF(isub.EQ.388) THEN
37193C...g + g -> Q + Qbar
37194 sqmavg=0.5d0*(sqm3+sqm4)-0.25d0*(sqm3-sqm4)**2/sh
37195 thq=-0.5d0*sh*(1d0-be34*cth)
37196 uhq=-0.5d0*sh*(1d0+be34*cth)
37197 thuhq=thq*uhq-sqmavg*sh
37198 IF(mstp(34).EQ.0) THEN
37199 facqq1=uhq/thq-2d0*uhq**2/sh2+4d0*(sqmavg/sh)*thuhq/thq**2
37200 facqq2=thq/uhq-2d0*thq**2/sh2+4d0*(sqmavg/sh)*thuhq/uhq**2
37201 ELSE
37202 facqq1=uhq/thq-2.25d0*uhq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37203 & thq**2+0.5d0*sqmavg*(thq+sqmavg)/thq**2-sqmavg**2/(sh*thq)
37204 facqq2=thq/uhq-2.25d0*thq**2/sh2+4.5d0*(sqmavg/sh)*thuhq/
37205 & uhq**2+0.5d0*sqmavg*(uhq+sqmavg)/uhq**2-sqmavg**2/(sh*uhq)
37206 ENDIF
37207 IF(itcm(5).GE.5) THEN
37208 IF(mint(55).EQ.5.OR.mint(55).EQ.6) THEN
37209 facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redhgs+
37210 & 2.25d0*thq*uhq/sh2*sqdhgs
37211 facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redhgs+
37212 & 2.25d0*thq*uhq/sh2*sqdhgs
37213 ELSE
37214 facqq1=facqq1+2.25d0*sqmavg*(thq-uhq)/(sh*thq)*redlgs+
37215 & 2.25d0*thq*uhq/sh2*sqdlgs
37216 facqq2=facqq2+2.25d0*sqmavg*(uhq-thq)/(sh*uhq)*redlgs+
37217 & 2.25d0*thq*uhq/sh2*sqdlgs
37218 ENDIF
37219 ENDIF
37220 facqq1=comfac*faca*as**2*(1d0/6d0)*facqq1
37221 facqq2=comfac*faca*as**2*(1d0/6d0)*facqq2
37222 IF(mstp(35).GE.1) THEN
37223 fatre=pyhfth(sh,sqmavg,2d0/7d0)
37224 facqq1=facqq1*fatre
37225 facqq2=facqq2*fatre
37226 ENDIF
37227 wid2=1d0
37228 IF(mint(55).EQ.6) wid2=wids(6,1)
37229 IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)
37230 facqq1=facqq1*wid2
37231 facqq2=facqq2*wid2
37232 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 530
37233 nchn=nchn+1
37234 isig(nchn,1)=21
37235 isig(nchn,2)=21
37236 isig(nchn,3)=1
37237 sigh(nchn)=facqq1
37238 nchn=nchn+1
37239 isig(nchn,1)=21
37240 isig(nchn,2)=21
37241 isig(nchn,3)=2
37242 sigh(nchn)=facqq2
37243 530 CONTINUE
37244 ENDIF
37245 ENDIF
37246
37247CMRENNA--
37248
37249 RETURN
37250 END
37251
37252C*********************************************************************
37253
37254C...PYSGEX
37255C...Subprocess cross sections for assorted exotic processes,
37256C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37257C...Auxiliary to PYSIGH.
37258
37259 SUBROUTINE pysgex(NCHN,SIGS)
37260
37261C...Double precision and integer declarations
37262 IMPLICIT DOUBLE PRECISION(a-h, o-z)
37263 IMPLICIT INTEGER(I-N)
37264 INTEGER PYK,PYCHGE,PYCOMP
37265C...Parameter statement to help give large particle numbers.
37266 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
37267 &kexcit=4000000,kdimen=5000000)
37268C...Commonblocks
37269 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
37270 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
37271 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
37272 common/pypars/mstp(200),parp(200),msti(200),pari(200)
37273 common/pyint1/mint(400),vint(400)
37274 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
37275 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
37276 common/pyint4/mwid(500),wids(500,5)
37277 common/pytcsm/itcm(0:99),rtcm(0:99)
37278 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
37279 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
37280 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
37281 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
37282 SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint1/,/pyint2/,
37283 &/pyint3/,/pyint4/,/pytcsm/,/pysgcm/
37284C...Local arrays
37285 dimension wdtp(0:400),wdte(0:400,0:5)
37286
37287C...Differential cross section expressions.
37288
37289 IF(isub.LE.160) THEN
37290 IF(isub.EQ.141) THEN
37291C...f + fbar -> gamma*/Z0/Z'0
37292 sqmzp=pmas(32,1)**2
37293 mint(61)=2
37294 CALL pywidt(32,sh,wdtp,wdte)
37295 hp0=aem/3d0*sh
37296 hp1=aem/3d0*xwc*sh
37297 hp2=hp1
37298 hs=shr*vint(117)
37299 hsp=shr*wdtp(0)
37300 faczp=4d0*comfac*3d0
37301 DO 100 i=mmina,mmaxa
37302 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 100
37303 ei=kchg(iabs(i),1)/3d0
37304 ai=sign(1d0,ei)
37305 vi=ai-4d0*ei*xwv
37306 ia=iabs(i)
37307 IF(ia.LT.10) THEN
37308 IF(ia.LE.2) THEN
37309 vpi=paru(123-2*mod(iabs(i),2))
37310 api=paru(124-2*mod(iabs(i),2))
37311 ELSEIF(ia.LE.4) THEN
37312 vpi=parj(182-2*mod(iabs(i),2))
37313 api=parj(183-2*mod(iabs(i),2))
37314 ELSE
37315 vpi=parj(190-2*mod(iabs(i),2))
37316 api=parj(191-2*mod(iabs(i),2))
37317 ENDIF
37318 ELSE
37319 IF(ia.LE.12) THEN
37320 vpi=paru(127-2*mod(iabs(i),2))
37321 api=paru(128-2*mod(iabs(i),2))
37322 ELSEIF(ia.LE.14) THEN
37323 vpi=parj(186-2*mod(iabs(i),2))
37324 api=parj(187-2*mod(iabs(i),2))
37325 ELSE
37326 vpi=parj(194-2*mod(iabs(i),2))
37327 api=parj(195-2*mod(iabs(i),2))
37328 ENDIF
37329 ENDIF
37330 hi0=hp0
37331 IF(iabs(i).LE.10) hi0=hi0*faca/3d0
37332 hi1=hp1
37333 IF(iabs(i).LE.10) hi1=hi1*faca/3d0
37334 hi2=hp2
37335 IF(iabs(i).LE.10) hi2=hi2*faca/3d0
37336 nchn=nchn+1
37337 isig(nchn,1)=i
37338 isig(nchn,2)=-i
37339 isig(nchn,3)=1
37340C...Special case: if only branching ratios known then use them.
37341 IF(mwid(32).EQ.2.AND.mstp(44).EQ.3) THEN
37342 hi=0d0
37343 IF(ia.LT.10) THEN
37344 hi=shr*wdtp(ia)*faca/9d0
37345 ELSEIF(ia.LT.20) THEN
37346 hi=shr*wdtp(ia-2)
37347 ENDIF
37348 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37349 sigh(nchn)=hi*faczp*hf/((sh-sqmzp)**2+hsp**2)
37350 ELSE
37351C...Normal cross section.
37352 sigh(nchn)=faczp*(ei**2/sh2*hi0*hp0*vint(111)+ei*vi*
37353 & (1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*(hi0*hp1+hi1*hp0)*
37354 & vint(112)+ei*vpi*(1d0-sqmzp/sh)/((sh-sqmzp)**2+hsp**2)*
37355 & (hi0*hp2+hi2*hp0)*vint(113)+(vi**2+ai**2)/
37356 & ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114)+(vi*vpi+ai*api)*
37357 & ((sh-sqmz)*(sh-sqmzp)+hs*hsp)/(((sh-sqmz)**2+hs**2)*
37358 & ((sh-sqmzp)**2+hsp**2))*(hi1*hp2+hi2*hp1)*vint(115)+
37359 & (vpi**2+api**2)/((sh-sqmzp)**2+hsp**2)*hi2*hp2*vint(116))
37360 ENDIF
37361 100 CONTINUE
37362
37363 ELSEIF(isub.EQ.142) THEN
37364C...f + fbar' -> W'+/-
37365 sqmwp=pmas(34,1)**2
37366 CALL pywidt(34,sh,wdtp,wdte)
37367 hs=shr*wdtp(0)
37368 facbw=4d0*comfac/((sh-sqmwp)**2+hs**2)*3d0
37369 hp=aem/(24d0*xw)*sh
37370 DO 120 i=mmin1,mmax1
37371 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 120
37372 ia=iabs(i)
37373 DO 110 j=mmin2,mmax2
37374 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 110
37375 ja=iabs(j)
37376 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 110
37377 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
37378 & GOTO 110
37379 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37380C...Special case: if only branching ratios known then use them.
37381 IF(mwid(34).EQ.2) THEN
37382 hi=0d0
37383 DO 105 idc=mdcy(34,2),mdcy(34,2)+mdcy(34,3)-1
37384 IF((ia.EQ.iabs(kfdp(idc,1)).AND.ja.EQ.
37385 & iabs(kfdp(idc,2))).OR.(ia.EQ.iabs(kfdp(idc,2))
37386 & .AND.ja.EQ.iabs(kfdp(idc,1))))
37387 & hi=shr*wdtp(idc+1-mdcy(34,2))
37388 105 CONTINUE
37389 IF(ia.LT.10) hi=hi*faca/9d0
37390 ELSE
37391C...Normal cross section.
37392 hi=hp*(paru(133)**2+paru(134)**2)
37393 IF(ia.LE.10) hi=hp*(paru(131)**2+paru(132)**2)*
37394 & vckm((ia+1)/2,(ja+1)/2)*faca/3d0
37395 ENDIF
37396 nchn=nchn+1
37397 isig(nchn,1)=i
37398 isig(nchn,2)=j
37399 isig(nchn,3)=1
37400 hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
37401 sigh(nchn)=hi*facbw*hf
37402 110 CONTINUE
37403 120 CONTINUE
37404
37405 ELSEIF(isub.EQ.144) THEN
37406C...f + fbar' -> R
37407 sqmr=pmas(41,1)**2
37408 CALL pywidt(41,sh,wdtp,wdte)
37409 hs=shr*wdtp(0)
37410 facbw=4d0*comfac/((sh-sqmr)**2+hs**2)*3d0
37411 hp=aem/(12d0*xw)*sh
37412 DO 140 i=mmin1,mmax1
37413 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 140
37414 ia=iabs(i)
37415 DO 130 j=mmin2,mmax2
37416 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 130
37417 ja=iabs(j)
37418 IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) GOTO 130
37419 hi=hp
37420 IF(ia.LE.10) hi=hi*faca/3d0
37421 hf=shr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))
37422 nchn=nchn+1
37423 isig(nchn,1)=i
37424 isig(nchn,2)=j
37425 isig(nchn,3)=1
37426 sigh(nchn)=hi*facbw*hf
37427 130 CONTINUE
37428 140 CONTINUE
37429
37430 ELSEIF(isub.EQ.145) THEN
37431C...q + l -> LQ (leptoquark)
37432 sqmlq=pmas(42,1)**2
37433 CALL pywidt(42,sh,wdtp,wdte)
37434 hs=shr*wdtp(0)
37435 facbw=4d0*comfac/((sh-sqmlq)**2+hs**2)
37436 IF(abs(shr-pmas(42,1)).GT.parp(48)*pmas(42,2)) facbw=0d0
37437 hp=aem/4d0*sh
37438 kflqq=kfdp(mdcy(42,2),1)
37439 kflql=kfdp(mdcy(42,2),2)
37440 DO 160 i=mmin1,mmax1
37441 IF(kfac(1,i).EQ.0) GOTO 160
37442 ia=iabs(i)
37443 IF(ia.NE.kflqq.AND.ia.NE.iabs(kflql)) GOTO 160
37444 DO 150 j=mmin2,mmax2
37445 IF(kfac(2,j).EQ.0) GOTO 150
37446 ja=iabs(j)
37447 IF(ja.NE.kflqq.AND.ja.NE.iabs(kflql)) GOTO 150
37448 IF(i*j.NE.kflqq*kflql) GOTO 150
37449 IF(ja.EQ.ia) GOTO 150
37450 IF(ia.EQ.kflqq) kchlq=isign(1,i)
37451 IF(ja.EQ.kflqq) kchlq=isign(1,j)
37452 hi=hp*paru(151)
37453 hf=shr*(wdte(0,1)+wdte(0,(5-kchlq)/2)+wdte(0,4))
37454 nchn=nchn+1
37455 isig(nchn,1)=i
37456 isig(nchn,2)=j
37457 isig(nchn,3)=1
37458 sigh(nchn)=hi*facbw*hf
37459 150 CONTINUE
37460 160 CONTINUE
37461
37462 ELSEIF(isub.EQ.146) THEN
37463C...e + gamma* -> e* (excited lepton)
37464 kfqstr=kfpr(isub,1)
37465 kcqstr=pycomp(kfqstr)
37466 kfqexc=mod(kfqstr,kexcit)
37467 CALL pywidt(kfqstr,sh,wdtp,wdte)
37468 hs=shr*wdtp(0)
37469 facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
37470 qf=-rtcm(43)/2d0-rtcm(44)/2d0
37471 facbw=facbw*aem*qf**2*sh/rtcm(41)**2
37472 IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
37473 & facbw=0d0
37474 hp=sh
37475 DO 180 i=-kfqexc,kfqexc,2*kfqexc
37476 DO 170 isde=1,2
37477 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 170
37478 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 170
37479 hi=hp
37480 IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37481 IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
37482 nchn=nchn+1
37483 isig(nchn,isde)=i
37484 isig(nchn,3-isde)=22
37485 isig(nchn,3)=1
37486 sigh(nchn)=hi*facbw*hf
37487 170 CONTINUE
37488 180 CONTINUE
37489
37490 ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN
37491C...d + g -> d* and u + g -> u* (excited quarks)
37492 kfqstr=kfpr(isub,1)
37493 kcqstr=pycomp(kfqstr)
37494 kfqexc=mod(kfqstr,kexcit)
37495 CALL pywidt(kfqstr,sh,wdtp,wdte)
37496 hs=shr*wdtp(0)
37497 facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)
37498 facbw=facbw*as*rtcm(45)**2*sh/(3d0*rtcm(41)**2)
37499 IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))
37500 & facbw=0d0
37501 hp=sh
37502 DO 200 i=-kfqexc,kfqexc,2*kfqexc
37503 DO 190 isde=1,2
37504 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 190
37505 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 190
37506 hi=hp
37507 IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37508 IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))
37509 nchn=nchn+1
37510 isig(nchn,isde)=i
37511 isig(nchn,3-isde)=21
37512 isig(nchn,3)=1
37513 sigh(nchn)=hi*facbw*hf
37514 190 CONTINUE
37515 200 CONTINUE
37516 ENDIF
37517
37518 ELSEIF(isub.LE.190) THEN
37519 IF(isub.EQ.162) THEN
37520C...q + g -> LQ + lbar; LQ=leptoquark
37521 sqmlq=pmas(42,1)**2
37522 faclq=comfac*faca*paru(151)*(as*aem/6d0)*(-th/sh)*
37523 & (uh2+sqmlq**2)/(uh-sqmlq)**2
37524 kflqq=kfdp(mdcy(42,2),1)
37525 DO 220 i=mmina,mmaxa
37526 IF(iabs(i).NE.kflqq) GOTO 220
37527 kchlq=isign(1,i)
37528 DO 210 isde=1,2
37529 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 210
37530 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 210
37531 nchn=nchn+1
37532 isig(nchn,isde)=i
37533 isig(nchn,3-isde)=21
37534 isig(nchn,3)=1
37535 sigh(nchn)=faclq*wids(42,(5-kchlq)/2)
37536 210 CONTINUE
37537 220 CONTINUE
37538
37539 ELSEIF(isub.EQ.163) THEN
37540C...g + g -> LQ + LQbar; LQ=leptoquark
37541 sqmlq=pmas(42,1)**2
37542 faclq=comfac*faca*wids(42,1)*(as**2/2d0)*
37543 & (7d0/48d0+3d0*(uh-th)**2/(16d0*sh2))*(1d0+2d0*sqmlq*th/
37544 & (th-sqmlq)**2+2d0*sqmlq*uh/(uh-sqmlq)**2+4d0*sqmlq**2/
37545 & ((th-sqmlq)*(uh-sqmlq)))
37546 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 230
37547 nchn=nchn+1
37548 isig(nchn,1)=21
37549 isig(nchn,2)=21
37550C...Since don't know proper colour flow, randomize between alternatives
37551 isig(nchn,3)=int(1.5d0+pyr(0))
37552 sigh(nchn)=faclq
37553 230 CONTINUE
37554
37555 ELSEIF(isub.EQ.164) THEN
37556C...q + qbar -> LQ + LQbar; LQ=leptoquark
37557 delta=0.25d0*(sqm3-sqm4)**2/sh
37558 sqmlq=0.5d0*(sqm3+sqm4)-delta
37559 th=th-delta
37560 uh=uh-delta
37561C SQMLQ=PMAS(42,1)**2
37562 faclqa=comfac*wids(42,1)*(as**2/9d0)*
37563 & (sh*(sh-4d0*sqmlq)-(uh-th)**2)/sh2
37564 faclqs=comfac*wids(42,1)*((paru(151)**2*aem**2/8d0)*
37565 & (-sh*th-(sqmlq-th)**2)/th2+(paru(151)*aem*as/18d0)*
37566 & ((sqmlq-th)*(uh-th)+sh*(sqmlq+th))/(sh*th))
37567 kflqq=kfdp(mdcy(42,2),1)
37568 DO 240 i=mmina,mmaxa
37569 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37570 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 240
37571 nchn=nchn+1
37572 isig(nchn,1)=i
37573 isig(nchn,2)=-i
37574 isig(nchn,3)=1
37575 sigh(nchn)=faclqa
37576 IF(iabs(i).EQ.kflqq) sigh(nchn)=faclqa+faclqs
37577 240 CONTINUE
37578
37579 ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN
37580C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37581 kfqstr=kfpr(isub,2)
37582 kcqstr=pycomp(kfqstr)
37583 kfqexc=mod(kfqstr,kexcit)
37584 facqsa=comfac*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)
37585 facqsb=comfac*0.25d0*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)*
37586 & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
37587C...Propagators: as simulated in PYOFSH and as desired
37588 gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
37589 hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
37590 CALL pywidt(kfqstr,sqm4,wdtp,wdte)
37591 gmmqc=sqrt(sqm4)*wdtp(0)
37592 hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
37593 facqsa=facqsa*hbw4c/hbw4
37594 facqsb=facqsb*hbw4c/hbw4
37595C...Branching ratios.
37596 brpos=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
37597 brneg=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
37598 DO 260 i=mmin1,mmax1
37599 ia=iabs(i)
37600 IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) GOTO 260
37601 DO 250 j=mmin2,mmax2
37602 ja=iabs(j)
37603 IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) GOTO 250
37604 IF(ia.EQ.kfqexc.AND.i.EQ.j) THEN
37605 nchn=nchn+1
37606 isig(nchn,1)=i
37607 isig(nchn,2)=j
37608 isig(nchn,3)=1
37609 IF(i.GT.0) sigh(nchn)=(4d0/3d0)*facqsa*brpos
37610 IF(i.LT.0) sigh(nchn)=(4d0/3d0)*facqsa*brneg
37611 nchn=nchn+1
37612 isig(nchn,1)=i
37613 isig(nchn,2)=j
37614 isig(nchn,3)=2
37615 IF(j.GT.0) sigh(nchn)=(4d0/3d0)*facqsa*brpos
37616 IF(j.LT.0) sigh(nchn)=(4d0/3d0)*facqsa*brneg
37617 ELSEIF((ia.EQ.kfqexc.OR.ja.EQ.kfqexc).AND.i*j.GT.0) THEN
37618 nchn=nchn+1
37619 isig(nchn,1)=i
37620 isig(nchn,2)=j
37621 isig(nchn,3)=1
37622 IF(ja.EQ.kfqexc) isig(nchn,3)=2
37623 IF(isig(nchn,isig(nchn,3)).GT.0) sigh(nchn)=facqsa*brpos
37624 IF(isig(nchn,isig(nchn,3)).LT.0) sigh(nchn)=facqsa*brneg
37625 ELSEIF(ia.EQ.kfqexc.AND.i.EQ.-j) THEN
37626 nchn=nchn+1
37627 isig(nchn,1)=i
37628 isig(nchn,2)=j
37629 isig(nchn,3)=1
37630 IF(i.GT.0) sigh(nchn)=(8d0/3d0)*facqsb*brpos
37631 IF(i.LT.0) sigh(nchn)=(8d0/3d0)*facqsb*brneg
37632 nchn=nchn+1
37633 isig(nchn,1)=i
37634 isig(nchn,2)=j
37635 isig(nchn,3)=2
37636 IF(j.GT.0) sigh(nchn)=(8d0/3d0)*facqsb*brpos
37637 IF(j.LT.0) sigh(nchn)=(8d0/3d0)*facqsb*brneg
37638 ELSEIF(i.EQ.-j) THEN
37639 nchn=nchn+1
37640 isig(nchn,1)=i
37641 isig(nchn,2)=j
37642 isig(nchn,3)=1
37643 IF(i.GT.0) sigh(nchn)=facqsb*brpos
37644 IF(i.LT.0) sigh(nchn)=facqsb*brneg
37645 nchn=nchn+1
37646 isig(nchn,1)=i
37647 isig(nchn,2)=j
37648 isig(nchn,3)=2
37649 IF(j.GT.0) sigh(nchn)=facqsb*brpos
37650 IF(j.LT.0) sigh(nchn)=facqsb*brneg
37651 ELSEIF(ia.EQ.kfqexc.OR.ja.EQ.kfqexc) THEN
37652 nchn=nchn+1
37653 isig(nchn,1)=i
37654 isig(nchn,2)=j
37655 isig(nchn,3)=1
37656 IF(ja.EQ.kfqexc) isig(nchn,3)=2
37657 IF(isig(nchn,isig(nchn,3)).GT.0) sigh(nchn)=facqsb*brpos
37658 IF(isig(nchn,isig(nchn,3)).LT.0) sigh(nchn)=facqsb*brneg
37659 ENDIF
37660 250 CONTINUE
37661 260 CONTINUE
37662
37663 ELSEIF(isub.EQ.169) THEN
37664C...q + qbar -> e + e* (excited lepton)
37665 kfqstr=kfpr(isub,2)
37666 kcqstr=pycomp(kfqstr)
37667 kfqexc=mod(kfqstr,kexcit)
37668 facqsb=(comfac/12d0)*(sh/rtcm(41)**2)**2*(1d0-sqm4/sh)*
37669 & (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)
37670C...Propagators: as simulated in PYOFSH and as desired
37671 gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)
37672 hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)
37673 CALL pywidt(kfqstr,sqm4,wdtp,wdte)
37674 gmmqc=sqrt(sqm4)*wdtp(0)
37675 hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)
37676 facqsb=facqsb*hbw4c/hbw4
37677C...Branching ratios.
37678 brpos=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)
37679 brneg=(wdte(0,1)+wdte(0,3)+wdte(0,4))/wdtp(0)
37680 DO 270 i=mmin1,mmax1
37681 ia=iabs(i)
37682 IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) GOTO 270
37683 j=-i
37684 ja=iabs(j)
37685 IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) GOTO 270
37686 nchn=nchn+1
37687 isig(nchn,1)=i
37688 isig(nchn,2)=j
37689 isig(nchn,3)=1
37690 IF(i.GT.0) sigh(nchn)=facqsb*brpos
37691 IF(i.LT.0) sigh(nchn)=facqsb*brneg
37692 nchn=nchn+1
37693 isig(nchn,1)=i
37694 isig(nchn,2)=j
37695 isig(nchn,3)=2
37696 IF(j.GT.0) sigh(nchn)=facqsb*brpos
37697 IF(j.LT.0) sigh(nchn)=facqsb*brneg
37698 270 CONTINUE
37699 ENDIF
37700
37701 ELSEIF(isub.LE.360) THEN
37702 IF(isub.EQ.341.OR.isub.EQ.342) THEN
37703C...l + l -> H_L++/-- or H_R++/--.
37704 kfres=kfpr(isub,1)
37705 kfrec=pycomp(kfres)
37706 CALL pywidt(kfres,sh,wdtp,wdte)
37707 hs=shr*wdtp(0)
37708 facbw=8d0*comfac/((sh-pmas(kfrec,1)**2)**2+hs**2)
37709 DO 290 i=mmin1,mmax1
37710 ia=iabs(i)
37711 IF((ia.NE.11.AND.ia.NE.13.AND.ia.NE.15).OR.kfac(1,i).EQ.0)
37712 & GOTO 290
37713 DO 280 j=mmin2,mmax2
37714 ja=iabs(j)
37715 IF((ja.NE.11.AND.ja.NE.13.AND.ja.NE.15).OR.kfac(2,j).EQ.0)
37716 & GOTO 280
37717 IF(i*j.LT.0) GOTO 280
37718 kchh=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37719 nchn=nchn+1
37720 isig(nchn,1)=i
37721 isig(nchn,2)=j
37722 isig(nchn,3)=1
37723 hi=sh*parp(181+3*((ia-11)/2)+(ja-11)/2)**2/(8d0*paru(1))
37724 hf=shr*(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))
37725 sigh(nchn)=hi*facbw*hf
37726 280 CONTINUE
37727 290 CONTINUE
37728
37729 ELSEIF(isub.GE.343.AND.isub.LE.348) THEN
37730C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37731 kfres=kfpr(isub,1)
37732 kfrec=pycomp(kfres)
37733C...Propagators: as simulated in PYOFSH and as desired
37734 hbw3=pmas(kfrec,1)*pmas(kfrec,2)/((sqm3-pmas(kfrec,1)**2)**2+
37735 & (pmas(kfrec,1)*pmas(kfrec,2))**2)
37736 CALL pywidt(kfres,sqm3,wdtp,wdte)
37737 gmmc=sqrt(sqm3)*wdtp(0)
37738 hbw3c=gmmc/((sqm3-pmas(kfrec,1)**2)**2+gmmc**2)
37739 fhcc=comfac*aem*hbw3c/hbw3
37740 DO 310 i=mmina,mmaxa
37741 ia=iabs(i)
37742 IF(ia.NE.11.AND.ia.NE.13.AND.ia.NE.15) GOTO 310
37743 sqml=pmas(ia,1)**2
37744 j=isign(kfpr(isub,2),-i)
37745 kchh=isign(2,kchg(ia,1)*isign(1,i))
37746 widsc=(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))/wdtp(0)
37747 smm1=8d0*(sh+th-sqm3)*(sh+th-2d0*sqm3-sqml-sqm4)/
37748 & (uh-sqm3)**2
37749 smm2=2d0*((2d0*sqm3-3d0*sqml)*sqm4+(sqml-2d0*sqm4)*th-
37750 & (th-sqm4)*sh)/(th-sqm4)**2
37751 smm3=2d0*((2d0*sqm3-3d0*sqm4+th)*sqml-(2d0*sqml-sqm4+th)*
37752 & sh)/(sh-sqml)**2
37753 smm12=4d0*((2d0*sqml-sqm4-2d0*sqm3+th)*sh+(th-3d0*sqm3-
37754 & 3d0*sqm4)*th+(2d0*sqm3-2d0*sqml+3d0*sqm4)*sqm3)/
37755 & ((uh-sqm3)*(th-sqm4))
37756 smm13=-4d0*((th+sqml-2d0*sqm4)*th-(sqm3+3d0*sqml-2d0*sqm4)*
37757 & sqm3+(sqm3+3d0*sqml+th)*sh-(th-sqm3+sh)**2)/
37758 & ((uh-sqm3)*(sh-sqml))
37759 smm23=-4d0*((sqml-sqm4+sqm3)*th-sqm3**2+sqm3*(sqml+sqm4)-
37760 & 3d0*sqml*sqm4-(sqml-sqm4-sqm3+th)*sh)/
37761 & ((sh-sqml)*(th-sqm4))
37762 smm=(sh/(sh-sqml))**2*(smm1+smm2+smm3+smm12+smm13+smm23)*
37763 & parp(181+3*((ia-11)/2)+(iabs(j)-11)/2)**2/(4d0*paru(1))
37764 DO 300 isde=1,2
37765 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) GOTO 300
37766 IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) GOTO 300
37767 nchn=nchn+1
37768 isig(nchn,isde)=i
37769 isig(nchn,3-isde)=22
37770 isig(nchn,3)=0
37771 sigh(nchn)=fhcc*smm*widsc
37772 300 CONTINUE
37773 310 CONTINUE
37774
37775 ELSEIF(isub.EQ.349.OR.isub.EQ.350) THEN
37776C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37777 kfres=kfpr(isub,1)
37778 kfrec=pycomp(kfres)
37779 sqmh=pmas(kfrec,1)**2
37780 gmmh=pmas(kfrec,1)*pmas(kfrec,2)
37781C...Propagators: H++/-- as simulated in PYOFSH and as desired
37782 hbw3=gmmh/((sqm3-sqmh)**2+gmmh**2)
37783 CALL pywidt(kfres,sqm3,wdtp,wdte)
37784 gmmh3=sqrt(sqm3)*wdtp(0)
37785 hbw3c=gmmh3/((sqm3-sqmh)**2+gmmh3**2)
37786 hbw4=gmmh/((sqm4-sqmh)**2+gmmh**2)
37787 CALL pywidt(kfres,sqm4,wdtp,wdte)
37788 gmmh4=sqrt(sqm4)*wdtp(0)
37789 hbw4c=gmmh4/((sqm4-sqmh)**2+gmmh4**2)
37790C...Kinematical and coupling functions
37791 fachh=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)*(th*uh-sqm3*sqm4)
37792 xwhh=(1d0-2d0*xwv)/(8d0*xwv*(1d0-xwv))
37793C...Loop over allowed flavours
37794 DO 320 i=mmina,mmaxa
37795 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 320
37796 ei=kchg(iabs(i),1)/3d0
37797 ai=sign(1d0,ei+0.1d0)
37798 vi=ai-4d0*ei*xwv
37799 fcoi=1d0
37800 IF(iabs(i).LE.10) fcoi=faca/3d0
37801 IF(isub.EQ.349) THEN
37802 hbwz=1d0/((sh-sqmz)**2+gmmz**2)
37803 IF(iabs(i).LT.10) THEN
37804 dsighh=8d0*aem**2*(ei**2/sh2+
37805 & 2d0*ei*vi*xwhh*(sh-sqmz)*hbwz/sh+
37806 & (vi**2+ai**2)*xwhh**2*hbwz)
37807 ELSE
37808 iaoff=181+3*((iabs(i)-11)/2)
37809 hsum=(parp(iaoff)**2+parp(iaoff+1)**2+parp(iaoff+2)**2)/
37810 & (4d0*paru(1))
37811 dsighh=8d0*aem**2*(ei**2/sh2+
37812 & 2d0*ei*vi*xwhh*(sh-sqmz)*hbwz/sh+
37813 & (vi**2+ai**2)*xwhh**2*hbwz)+
37814 & 8d0*aem*(ei*hsum/(sh*th)+
37815 & (vi+ai)*xwhh*hsum*(sh-sqmz)*hbwz/th)+
37816 & 4d0*hsum**2/th2
37817 ENDIF
37818 ELSE
37819 IF(iabs(i).LT.10) THEN
37820 dsighh=8d0*aem**2*ei**2/sh2
37821 ELSE
37822 iaoff=181+3*((iabs(i)-11)/2)
37823 hsum=(parp(iaoff)**2+parp(iaoff+1)**2+parp(iaoff+2)**2)/
37824 & (4d0*paru(1))
37825 dsighh=8d0*aem**2*ei**2/sh2+8d0*aem*ei*hsum/(sh*th)+
37826 & 4d0*hsum**2/th2
37827 ENDIF
37828 ENDIF
37829 nchn=nchn+1
37830 isig(nchn,1)=i
37831 isig(nchn,2)=-i
37832 isig(nchn,3)=1
37833 sigh(nchn)=fachh*fcoi*dsighh
37834 320 CONTINUE
37835
37836 ELSEIF(isub.EQ.351.OR.isub.EQ.352) THEN
37837C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37838 kfres=kfpr(isub,1)
37839 kfrec=pycomp(kfres)
37840 sqmh=pmas(kfrec,1)**2
37841 IF(isub.EQ.351) facnor=parp(190)**8*parp(192)**2
37842 IF(isub.EQ.352) facnor=parp(191)**6*2d0*
37843 & pmas(pycomp(9900024),1)**2
37844 facww=comfac*facnor*taup*vint(2)*vint(219)
37845 facprt=1d0/((vint(204)**2-vint(215))*
37846 & (vint(209)**2-vint(216)))
37847 facpru=1d0/((vint(204)**2+2d0*vint(217))*
37848 & (vint(209)**2+2d0*vint(218)))
37849 CALL pywidt(kfres,sh,wdtp,wdte)
37850 hs=shr*wdtp(0)
37851 facbw=(1d0/paru(1))*vint(2)/((sh-sqmh)**2+hs**2)
37852 IF(abs(shr-pmas(kfrec,1)).GT.parp(48)*pmas(kfrec,2))
37853 & facbw=0d0
37854 DO 340 i=mmin1,mmax1
37855 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 340
37856 IF(isub.EQ.352.AND.iabs(i).GT.10) GOTO 340
37857 kchwi=(1-2*mod(iabs(i),2))*isign(1,i)
37858 DO 330 j=mmin2,mmax2
37859 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 330
37860 IF(isub.EQ.352.AND.iabs(j).GT.10) GOTO 330
37861 kchwj=(1-2*mod(iabs(j),2))*isign(1,j)
37862 kchh=kchwi+kchwj
37863 IF(iabs(kchh).NE.2) GOTO 330
37864 faclr=vint(180+i)*vint(180+j)
37865 hf=shr*(wdte(0,1)+wdte(0,(5-kchh/2)/2)+wdte(0,4))
37866 IF(i.EQ.j.AND.iabs(i).GT.10) THEN
37867 facprp=0.5d0*(facprt+facpru)**2
37868 ELSE
37869 facprp=facprt**2
37870 ENDIF
37871 nchn=nchn+1
37872 isig(nchn,1)=i
37873 isig(nchn,2)=j
37874 isig(nchn,3)=1
37875 sigh(nchn)=faclr*facww*facprp*facbw*hf
37876 330 CONTINUE
37877 340 CONTINUE
37878
37879 ELSEIF(isub.EQ.353) THEN
37880C...f + fbar -> Z_R0
37881 sqmzr=pmas(pycomp(kfpr(isub,1)),1)**2
37882 CALL pywidt(kfpr(isub,1),sh,wdtp,wdte)
37883 hs=shr*wdtp(0)
37884 facbw=4d0*comfac/((sh-sqmzr)**2+hs**2)*3d0
37885 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37886 hp=(aem/(3d0*(1d0-2d0*xw)))*xwc*sh
37887 DO 350 i=mmina,mmaxa
37888 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 350
37889 IF(iabs(i).LE.8) THEN
37890 ei=kchg(iabs(i),1)/3d0
37891 ai=sign(1d0,ei+0.1d0)*(1d0-2d0*xw)
37892 vi=sign(1d0,ei+0.1d0)-4d0*ei*xw
37893 ELSE
37894 ai=-(1d0-2d0*xw)
37895 vi=-1d0+4d0*xw
37896 ENDIF
37897 hi=hp*(vi**2+ai**2)
37898 IF(iabs(i).LE.10) hi=hi*faca/3d0
37899 nchn=nchn+1
37900 isig(nchn,1)=i
37901 isig(nchn,2)=-i
37902 isig(nchn,3)=1
37903 sigh(nchn)=hi*facbw*hf
37904 350 CONTINUE
37905
37906 ELSEIF(isub.EQ.354) THEN
37907C...f + fbar' -> W_R+/-
37908 sqmwr=pmas(pycomp(kfpr(isub,1)),1)**2
37909 CALL pywidt(kfpr(isub,1),sh,wdtp,wdte)
37910 hs=shr*wdtp(0)
37911 facbw=4d0*comfac/((sh-sqmwr)**2+hs**2)*3d0
37912 hp=aem/(24d0*xw)*sh
37913 DO 370 i=mmin1,mmax1
37914 IF(i.EQ.0.OR.kfac(1,i).EQ.0) GOTO 370
37915 ia=iabs(i)
37916 DO 360 j=mmin2,mmax2
37917 IF(j.EQ.0.OR.kfac(2,j).EQ.0) GOTO 360
37918 ja=iabs(j)
37919 IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) GOTO 360
37920 IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))
37921 & GOTO 360
37922 kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3
37923 hi=hp*2d0
37924 IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0
37925 nchn=nchn+1
37926 isig(nchn,1)=i
37927 isig(nchn,2)=j
37928 isig(nchn,3)=1
37929 hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))
37930 sigh(nchn)=hi*facbw*hf
37931 360 CONTINUE
37932 370 CONTINUE
37933 ENDIF
37934
37935 ELSEIF(isub.LE.400) THEN
37936 IF(isub.EQ.391) THEN
37937C...f + fbar -> G*.
37938 kfgstr=kfpr(isub,1)
37939 kcgstr=pycomp(kfgstr)
37940 CALL pywidt(kfgstr,sh,wdtp,wdte)
37941 hs=shr*wdtp(0)
37942 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37943 facg=comfac*parp(50)**2/(16d0*paru(1))*sh*hf/
37944 & ((sh-pmas(kcgstr,1)**2)**2+hs**2)
37945C...Modify cross section in wings of peak.
37946 facg = facg * sh**2 / pmas(kcgstr,1)**4
37947 DO 380 i=mmina,mmaxa
37948 IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) GOTO 380
37949 hi=1d0
37950 IF(iabs(i).LE.10) hi=hi*faca/3d0
37951 nchn=nchn+1
37952 isig(nchn,1)=i
37953 isig(nchn,2)=-i
37954 isig(nchn,3)=1
37955 sigh(nchn)=facg*hi
37956 380 CONTINUE
37957
37958 ELSEIF(isub.EQ.392) THEN
37959C...g + g -> G*.
37960 kfgstr=kfpr(isub,1)
37961 kcgstr=pycomp(kfgstr)
37962 CALL pywidt(kfgstr,sh,wdtp,wdte)
37963 hs=shr*wdtp(0)
37964 hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37965 facg=comfac*parp(50)**2/(32d0*paru(1))*sh*hf/
37966 & ((sh-pmas(kcgstr,1)**2)**2+hs**2)
37967C...Modify cross section in wings of peak.
37968 facg = facg * sh**2 / pmas(kcgstr,1)**4
37969 IF(kfac(1,21)*kfac(2,21).EQ.0) GOTO 390
37970 nchn=nchn+1
37971 isig(nchn,1)=21
37972 isig(nchn,2)=21
37973 isig(nchn,3)=1
37974 sigh(nchn)=facg
37975 390 CONTINUE
37976
37977 ELSEIF(isub.EQ.393) THEN
37978C...q + qbar -> g + G*.
37979 kfgstr=kfpr(isub,2)
37980 kcgstr=pycomp(kfgstr)
37981 facg=comfac*parp(50)**2*as*sh/(72d0*paru(1)*sqm4)*
37982 & (4d0*(th2+uh2)/sh2+9d0*(th+uh)/sh+(th2/uh+uh2/th)/sh+
37983 & 3d0*(4d0+th/uh+uh/th)+4d0*(sh/uh+sh/th)+
37984 & 2d0*sh2/(th*uh))
37985C...Propagators: as simulated in PYOFSH and as desired
37986 gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
37987 hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
37988 CALL pywidt(kfgstr,sqm4,wdtp,wdte)
37989 hs=sqrt(sqm4)*wdtp(0)
37990 hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
37991 hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
37992 facg=facg*hbw4c/hbw4
37993 DO 400 i=mmina,mmaxa
37994 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
37995 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 400
37996 nchn=nchn+1
37997 isig(nchn,1)=i
37998 isig(nchn,2)=-i
37999 isig(nchn,3)=1
38000 sigh(nchn)=facg
38001 400 CONTINUE
38002
38003 ELSEIF(isub.EQ.394) THEN
38004C...q + g -> q + G*.
38005 kfgstr=kfpr(isub,2)
38006 kcgstr=pycomp(kfgstr)
38007 facg=-comfac*parp(50)**2*as*sh/(192d0*paru(1)*sqm4)*
38008 & (4d0*(sh2+uh2)/(th*sh)+9d0*(sh+uh)/sh+sh/uh+uh2/sh2+
38009 & 3d0*th*(4d0+sh/uh+uh/sh)/sh+4d0*th2*(1d0/uh+1d0/sh)/sh+
38010 & 2d0*th2*th/(uh*sh2))
38011C...Propagators: as simulated in PYOFSH and as desired
38012 gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
38013 hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
38014 CALL pywidt(kfgstr,sqm4,wdtp,wdte)
38015 hs=sqrt(sqm4)*wdtp(0)
38016 hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38017 hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
38018 facg=facg*hbw4c/hbw4
38019 DO 420 i=mmina,mmaxa
38020 IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) GOTO 420
38021 DO 410 isde=1,2
38022 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 410
38023 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 410
38024 nchn=nchn+1
38025 isig(nchn,isde)=i
38026 isig(nchn,3-isde)=21
38027 isig(nchn,3)=1
38028 sigh(nchn)=facg
38029 410 CONTINUE
38030 420 CONTINUE
38031
38032 ELSEIF(isub.EQ.395) THEN
38033C...g + g -> g + G*.
38034 kfgstr=kfpr(isub,2)
38035 kcgstr=pycomp(kfgstr)
38036 facg=comfac*3d0*parp(50)**2*as*sh/(32d0*paru(1)*sqm4)*
38037 & ((th2+th*uh+uh2)**2/(sh2*th*uh)+2d0*(th2/uh+uh2/th)/sh+
38038 & 3d0*(th/uh+uh/th)+2d0*(sh/uh+sh/th)+sh2/(th*uh))
38039C...Propagators: as simulated in PYOFSH and as desired
38040 gmmg=pmas(kcgstr,1)*pmas(kcgstr,2)
38041 hbw4=gmmg/((sqm4-pmas(kcgstr,1)**2)**2+gmmg**2)
38042 CALL pywidt(kfgstr,sqm4,wdtp,wdte)
38043 hs=sqrt(sqm4)*wdtp(0)
38044 hf=sqrt(sqm4)*(wdte(0,1)+wdte(0,2)+wdte(0,4))
38045 hbw4c=hf/((sqm4-pmas(kcgstr,1)**2)**2+hs**2)
38046 facg=facg*hbw4c/hbw4
38047 IF(kfac(1,21)*kfac(2,21).NE.0) THEN
38048 nchn=nchn+1
38049 isig(nchn,1)=21
38050 isig(nchn,2)=21
38051 isig(nchn,3)=1
38052 sigh(nchn)=facg
38053 ENDIF
38054 ENDIF
38055 ENDIF
38056
38057 RETURN
38058 END
38059
38060C*********************************************************************
38061
38062C...PYPDFU
38063C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38064C...parton distributions according to a few different parametrizations.
38065C...Note that what is coded is x times the probability distribution,
38066C...i.e. xq(x,Q2) etc.
38067
38068 SUBROUTINE pypdfu(KF,X,Q2,XPQ)
38069
38070C...Double precision and integer declarations.
38071 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38072 IMPLICIT INTEGER(I-N)
38073 INTEGER PYK,PYCHGE,PYCOMP
38074C...Commonblocks.
38075 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
38076 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38077 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38078 common/pypars/mstp(200),parp(200),msti(200),pari(200)
38079 common/pyint1/mint(400),vint(400)
38080 common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
38081 &xpdir(-6:6)
38082 common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)
38083 common/pyintm/kfival(2,3),nmi(2),imi(2,800,2),nvc(2,-6:6),
38084 & xassoc(2,-6:6,240),xpsvc(-6:6,-1:240),pvctot(2,-1:1),
38085 & xmi(2,240),pt2mi(240),imisep(0:240)
38086 SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint8/,
38087 &/pyint9/,/pyintm/
38088C...Local arrays.
38089 dimension xpq(-25:25),xpel(-25:25),xpga(-6:6),vxpga(-6:6),
38090 &xppi(-6:6),xppr(-6:6),xpval(-6:6),ppar(6,2)
38091 SAVE ppar
38092
38093C...Interface to PDFLIB.
38094 common/w50513/xmin,xmax,q2min,q2max
38095 SAVE /w50513/
38096 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38097 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38098 CHARACTER*20 PARM(20)
38099 DATA VALUE/20*0d0/,parm/20*' '/
38100
38101C...Data related to Schuler-Sjostrand photon distributions.
38102 DATA alamga/0.2d0/, pmcga/1.3d0/, pmbga/4.6d0/
38103
38104C...Valence PDF momentum integral parametrizations PER PARTON!
38105 DATA (ppar(1,ipar),ipar=1,2) /0.385d0,1.60d0/
38106 DATA (ppar(2,ipar),ipar=1,2) /0.480d0,1.56d0/
38107 pavg(ifl,q2)=ppar(ifl,1)/(1d0+ppar(ifl,2)*
38108 &log(log(max(q2,1d0)/0.04d0)))
38109
38110C...Reset parton distributions.
38111 mint(92)=0
38112 DO 100 kfl=-25,25
38113 xpq(kfl)=0d0
38114 100 CONTINUE
38115 DO 110 kfl=-6,6
38116 xpval(kfl)=0d0
38117 110 CONTINUE
38118
38119C...Check x and particle species.
38120 IF(x.LE.0d0.OR.x.GE.1d0) THEN
38121 WRITE(mstu(11),5000) x
38122 GOTO 9999
38123 ENDIF
38124 kfa=iabs(kf)
38125 IF(kfa.NE.11.AND.kfa.NE.13.AND.kfa.NE.15.AND.kfa.NE.22.AND.
38126 &kfa.NE.211.AND.kfa.NE.2112.AND.kfa.NE.2212.AND.kfa.NE.3122.AND.
38127 &kfa.NE.3112.AND.kfa.NE.3212.AND.kfa.NE.3222.AND.kfa.NE.3312.AND.
38128 &kfa.NE.3322.AND.kfa.NE.3334.AND.kfa.NE.111.AND.kfa.NE.321.AND.
38129 &kfa.NE.310.AND.kfa.NE.130) THEN
38130 WRITE(mstu(11),5100) kf
38131 GOTO 9999
38132 ENDIF
38133
38134C...Electron (or muon or tau) parton distribution call.
38135 IF(kfa.EQ.11.OR.kfa.EQ.13.OR.kfa.EQ.15) THEN
38136 CALL pypdel(kfa,x,q2,xpel)
38137 DO 120 kfl=-25,25
38138 xpq(kfl)=xpel(kfl)
38139 120 CONTINUE
38140
38141C...Photon parton distribution call (VDM+anomalous).
38142 ELSEIF(kfa.EQ.22.AND.mint(109).LE.1) THEN
38143 IF(mstp(56).EQ.1.AND.mstp(55).EQ.1) THEN
38144 CALL pypdga(x,q2,xpga)
38145 DO 130 kfl=-6,6
38146 xpq(kfl)=xpga(kfl)
38147 130 CONTINUE
38148 xpvu=4d0*(xpq(2)-xpq(1))/3d0
38149 xpval(1)=xpvu/4d0
38150 xpval(2)=xpvu
38151 xpval(3)=min(xpq(3),xpvu/4d0)
38152 xpval(4)=min(xpq(4),xpvu)
38153 xpval(5)=min(xpq(5),xpvu/4d0)
38154 xpval(-1)=xpval(1)
38155 xpval(-2)=xpval(2)
38156 xpval(-3)=xpval(3)
38157 xpval(-4)=xpval(4)
38158 xpval(-5)=xpval(5)
38159 ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.5.AND.mstp(55).LE.8) THEN
38160 q2mx=q2
38161 p2mx=0.36d0
38162 IF(mstp(55).GE.7) p2mx=4.0d0
38163 IF(mstp(57).EQ.0) q2mx=p2mx
38164 p2=0d0
38165 IF(vint(120).LT.0d0) p2=vint(120)**2
38166 CALL pyggam(mstp(55)-4,x,q2mx,p2,mstp(60),f2gam,xpga)
38167 DO 140 kfl=-6,6
38168 xpq(kfl)=xpga(kfl)
38169 xpval(kfl)=vxpdgm(kfl)
38170 140 CONTINUE
38171 vint(231)=p2mx
38172 ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.9.AND.mstp(55).LE.12) THEN
38173 q2mx=q2
38174 p2mx=0.36d0
38175 IF(mstp(55).GE.11) p2mx=4.0d0
38176 IF(mstp(57).EQ.0) q2mx=p2mx
38177 p2=0d0
38178 IF(vint(120).LT.0d0) p2=vint(120)**2
38179 CALL pyggam(mstp(55)-8,x,q2mx,p2,mstp(60),f2gam,xpga)
38180 DO 150 kfl=-6,6
38181 xpq(kfl)=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
38182 xpval(kfl)=vxpvmd(kfl)+vxpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
38183 150 CONTINUE
38184 vint(231)=p2mx
38185 ELSEIF(mstp(56).EQ.2) THEN
38186C...Call PDFLIB parton distributions.
38187 parm(1)='NPTYPE'
38188 value(1)=3
38189 parm(2)='NGROUP'
38190 value(2)=mstp(55)/1000
38191 parm(3)='NSET'
38192 value(3)=mod(mstp(55),1000)
38193 IF(mint(93).NE.3000000+mstp(55)) THEN
38194 CALL pdfset(parm,VALUE)
38195 mint(93)=3000000+mstp(55)
38196 ENDIF
38197 xx=x
38198 qq2=max(0d0,q2min,q2)
38199 IF(mstp(57).EQ.0) qq2=q2min
38200 p2=0d0
38201 IF(vint(120).LT.0d0) p2=vint(120)**2
38202 ip2=mstp(60)
38203 IF(mstp(55).EQ.5004) THEN
38204 IF(5d0*p2.LT.qq2.AND.
38205 & qq2.GT.0.6d0.AND.qq2.LT.5d4.AND.
38206 & p2.GE.0d0.AND.p2.LT.10d0.AND.
38207 & xx.GT.1d-4.AND.xx.LT.1d0) THEN
38208 CALL structp(xx,qq2,p2,ip2,upv,dnv,usea,dsea,str,chm,
38209 & bot,top,glu)
38210 ELSE
38211 upv=0d0
38212 dnv=0d0
38213 usea=0d0
38214 dsea=0d0
38215 str=0d0
38216 chm=0d0
38217 bot=0d0
38218 top=0d0
38219 glu=0d0
38220 ENDIF
38221 ELSE
38222 IF(p2.LT.qq2) THEN
38223 CALL structp(xx,qq2,p2,ip2,upv,dnv,usea,dsea,str,chm,
38224 & bot,top,glu)
38225 ELSE
38226 upv=0d0
38227 dnv=0d0
38228 usea=0d0
38229 dsea=0d0
38230 str=0d0
38231 chm=0d0
38232 bot=0d0
38233 top=0d0
38234 glu=0d0
38235 ENDIF
38236 ENDIF
38237 vint(231)=q2min
38238 xpq(0)=glu
38239 xpq(1)=dnv
38240 xpq(-1)=dnv
38241 xpq(2)=upv
38242 xpq(-2)=upv
38243 xpq(3)=str
38244 xpq(-3)=str
38245 xpq(4)=chm
38246 xpq(-4)=chm
38247 xpq(5)=bot
38248 xpq(-5)=bot
38249 xpq(6)=top
38250 xpq(-6)=top
38251 xpvu=4d0*(xpq(2)-xpq(1))/3d0
38252 xpval(1)=xpvu/4d0
38253 xpval(2)=xpvu
38254 xpval(3)=min(xpq(3),xpvu/4d0)
38255 xpval(4)=min(xpq(4),xpvu)
38256 xpval(5)=min(xpq(5),xpvu/4d0)
38257 xpval(-1)=xpval(1)
38258 xpval(-2)=xpval(2)
38259 xpval(-3)=xpval(3)
38260 xpval(-4)=xpval(4)
38261 xpval(-5)=xpval(5)
38262 ELSE
38263 WRITE(mstu(11),5200) kf,mstp(56),mstp(55)
38264 ENDIF
38265
38266C...Pion/gammaVDM parton distribution call.
38267 ELSEIF(kfa.EQ.211.OR.kfa.EQ.111.OR.kfa.EQ.321.OR.kfa.EQ.130.OR.
38268 &kfa.EQ.310.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN
38269 IF(kfa.EQ.22.AND.mstp(56).EQ.1.AND.mstp(55).GE.5.AND.
38270 & mstp(55).LE.12) THEN
38271 iset=1+mod(mstp(55)-1,4)
38272 q2mx=q2
38273 p2mx=0.36d0
38274 IF(iset.GE.3) p2mx=4.0d0
38275 IF(mstp(57).EQ.0) q2mx=p2mx
38276 p2=0d0
38277 IF(vint(120).LT.0d0) p2=vint(120)**2
38278 CALL pyggam(iset,x,q2mx,p2,mstp(60),f2gam,xpga)
38279 DO 160 kfl=-6,6
38280 xpq(kfl)=xpvmd(kfl)
38281 xpval(kfl)=vxpvmd(kfl)
38282 160 CONTINUE
38283 vint(231)=p2mx
38284 ELSEIF(mstp(54).EQ.1.AND.mstp(53).GE.1.AND.mstp(53).LE.3) THEN
38285 CALL pypdpi(x,q2,xppi)
38286 DO 170 kfl=-6,6
38287 xpq(kfl)=xppi(kfl)
38288 170 CONTINUE
38289 xpval(2)=xpq(2)-xpq(-2)
38290 xpval(-1)=xpq(-1)-xpq(1)
38291 ELSEIF(mstp(54).EQ.2) THEN
38292C...Call PDFLIB parton distributions.
38293 parm(1)='NPTYPE'
38294 value(1)=2
38295 parm(2)='NGROUP'
38296 value(2)=mstp(53)/1000
38297 parm(3)='NSET'
38298 value(3)=mod(mstp(53),1000)
38299 IF(mint(93).NE.2000000+mstp(53)) THEN
38300 CALL pdfset(parm,VALUE)
38301 mint(93)=2000000+mstp(53)
38302 ENDIF
38303 xx=x
38304 qq=sqrt(max(0d0,q2min,q2))
38305 IF(mstp(57).EQ.0) qq=sqrt(q2min)
38306 CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
38307 vint(231)=q2min
38308 xpq(0)=glu
38309 xpq(1)=dsea
38310 xpq(-1)=upv+dsea
38311 xpq(2)=upv+usea
38312 xpq(-2)=usea
38313 xpq(3)=str
38314 xpq(-3)=str
38315 xpq(4)=chm
38316 xpq(-4)=chm
38317 xpq(5)=bot
38318 xpq(-5)=bot
38319 xpq(6)=top
38320 xpq(-6)=top
38321 xpval(2)=upv
38322 xpval(-1)=upv
38323 ELSE
38324 WRITE(mstu(11),5200) kf,mstp(54),mstp(53)
38325 ENDIF
38326
38327C...Anomalous photon parton distribution call.
38328 ELSEIF(kfa.EQ.22.AND.mint(109).EQ.3) THEN
38329 q2mx=q2
38330 p2mx=parp(15)**2
38331 IF(mstp(56).EQ.1.AND.mstp(55).LE.8) THEN
38332 IF(mstp(55).EQ.5.OR.mstp(55).EQ.6) p2mx=0.36d0
38333 IF(mstp(55).EQ.7.OR.mstp(55).EQ.8) p2mx=4.0d0
38334 IF(mstp(57).EQ.0) q2mx=p2mx
38335 p2=0d0
38336 IF(vint(120).LT.0d0) p2=vint(120)**2
38337 CALL pyggam(mstp(55)-4,x,q2mx,p2,mstp(60),f2gm,xpga)
38338 DO 180 kfl=-6,6
38339 xpq(kfl)=xpanl(kfl)+xpanh(kfl)
38340 xpval(kfl)=vxpanl(kfl)+vxpanh(kfl)
38341 180 CONTINUE
38342 vint(231)=p2mx
38343 ELSEIF(mstp(56).EQ.1) THEN
38344 IF(mstp(55).EQ.9.OR.mstp(55).EQ.10) p2mx=0.36d0
38345 IF(mstp(55).EQ.11.OR.mstp(55).EQ.12) p2mx=4.0d0
38346 IF(mstp(57).EQ.0) q2mx=p2mx
38347 p2=0d0
38348 IF(vint(120).LT.0d0) p2=vint(120)**2
38349 CALL pyggam(mstp(55)-8,x,q2mx,p2,mstp(60),f2gm,xpga)
38350 DO 190 kfl=-6,6
38351 xpq(kfl)=max(0d0,xpanl(kfl)+xpbeh(kfl)+xpdir(kfl))
38352 xpval(kfl)=max(0d0,vxpanl(kfl)+xpbeh(kfl)+xpdir(kfl))
38353 190 CONTINUE
38354 vint(231)=p2mx
38355 ELSEIF(mstp(56).EQ.2) THEN
38356 IF(mstp(57).EQ.0) q2mx=p2mx
38357 CALL pygano(0,x,q2mx,p2mx,alamga,xpga,vxpga)
38358 DO 200 kfl=-6,6
38359 xpq(kfl)=xpga(kfl)
38360 xpval(kfl)=vxpga(kfl)
38361 200 CONTINUE
38362 vint(231)=p2mx
38363 ELSEIF(mstp(55).GE.1.AND.mstp(55).LE.5) THEN
38364 IF(mstp(57).EQ.0) q2mx=p2mx
38365 CALL pygvmd(0,mstp(55),x,q2mx,p2mx,parp(1),xpga,vxpga)
38366 DO 210 kfl=-6,6
38367 xpq(kfl)=xpga(kfl)
38368 xpval(kfl)=vxpga(kfl)
38369 210 CONTINUE
38370 vint(231)=p2mx
38371 ELSE
38372 220 rkf=11d0*pyr(0)
38373 kfr=1
38374 IF(rkf.GT.1d0) kfr=2
38375 IF(rkf.GT.5d0) kfr=3
38376 IF(rkf.GT.6d0) kfr=4
38377 IF(rkf.GT.10d0) kfr=5
38378 IF(kfr.EQ.4.AND.q2.LT.pmcga**2) GOTO 220
38379 IF(kfr.EQ.5.AND.q2.LT.pmbga**2) GOTO 220
38380 IF(mstp(57).EQ.0) q2mx=p2mx
38381 CALL pygvmd(0,kfr,x,q2mx,p2mx,parp(1),xpga,vxpga)
38382 DO 230 kfl=-6,6
38383 xpq(kfl)=xpga(kfl)
38384 xpval(kfl)=vxpga(kfl)
38385 230 CONTINUE
38386 vint(231)=p2mx
38387 ENDIF
38388
38389C...Proton parton distribution call.
38390 ELSE
38391 IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.20) THEN
38392 CALL pypdpr(x,q2,xppr)
38393 DO 240 kfl=-6,6
38394 xpq(kfl)=xppr(kfl)
38395 240 CONTINUE
38396C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38397 xpval(1)=max(0d0,xpq(1)-xpq(-1))
38398 xpval(2)=max(0d0,xpq(2)-xpq(-2))
38399 ELSEIF(mstp(52).EQ.2) THEN
38400C...Call PDFLIB parton distributions.
38401 parm(1)='NPTYPE'
38402 value(1)=1
38403 parm(2)='NGROUP'
38404 value(2)=mstp(51)/1000
38405 parm(3)='NSET'
38406 value(3)=mod(mstp(51),1000)
38407 IF(mint(93).NE.1000000+mstp(51)) THEN
38408 CALL pdfset(parm,VALUE)
38409 mint(93)=1000000+mstp(51)
38410 ENDIF
38411 xx=x
38412 qq=sqrt(max(0d0,q2min,q2))
38413 IF(mstp(57).EQ.0) qq=sqrt(q2min)
38414 CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
38415 vint(231)=q2min
38416 xpq(0)=glu
38417 xpq(1)=dnv+dsea
38418 xpq(-1)=dsea
38419 xpq(2)=upv+usea
38420 xpq(-2)=usea
38421 xpq(3)=str
38422 xpq(-3)=str
38423 xpq(4)=chm
38424 xpq(-4)=chm
38425 xpq(5)=bot
38426 xpq(-5)=bot
38427 xpq(6)=top
38428 xpq(-6)=top
38429 xpval(1)=dnv
38430 xpval(2)=upv
38431 ELSE
38432 WRITE(mstu(11),5200) kf,mstp(52),mstp(51)
38433 ENDIF
38434 ENDIF
38435
38436C...Isospin average for pi0/gammaVDM.
38437 IF(kfa.EQ.111.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN
38438 IF(kfa.EQ.22.AND.mstp(55).GE.5.AND.mstp(55).LE.12) THEN
38439 xpv=xpq(2)-xpq(1)
38440 xpq(2)=xpq(1)
38441 xpq(-2)=xpq(-1)
38442 ELSE
38443 xps=0.5d0*(xpq(1)+xpq(-2))
38444 xpv=0.5d0*(xpq(2)+xpq(-1))-xps
38445 xpq(2)=xps
38446 xpq(-1)=xps
38447 ENDIF
38448 xpvl=0.5d0*(xpval(1)+xpval(2)+xpval(-1)+xpval(-2))+
38449 & xpval(3)+xpval(4)+xpval(5)
38450 DO 250 kfl=-6,6
38451 xpval(kfl)=0d0
38452 250 CONTINUE
38453 IF(kfa.EQ.22.AND.mint(105).LE.223) THEN
38454 xpq(1)=xpq(1)+0.2d0*xpv
38455 xpq(2)=xpq(2)+0.8d0*xpv
38456 xpval(1)=0.2d0*xpvl
38457 xpval(2)=0.8d0*xpvl
38458 ELSEIF(kfa.EQ.22.AND.mint(105).EQ.333) THEN
38459 xpq(3)=xpq(3)+xpv
38460 xpval(3)=xpvl
38461 ELSEIF(kfa.EQ.22.AND.mint(105).EQ.443) THEN
38462 xpq(4)=xpq(4)+xpv
38463 xpval(4)=xpvl
38464 IF(mstp(55).GE.9) THEN
38465 DO 260 kfl=-6,6
38466 xpq(kfl)=0d0
38467 260 CONTINUE
38468 ENDIF
38469 ELSE
38470 xpq(1)=xpq(1)+0.5d0*xpv
38471 xpq(2)=xpq(2)+0.5d0*xpv
38472 xpval(1)=0.5d0*xpvl
38473 xpval(2)=0.5d0*xpvl
38474 ENDIF
38475 DO 270 kfl=1,6
38476 xpq(-kfl)=xpq(kfl)
38477 xpval(-kfl)=xpval(kfl)
38478 270 CONTINUE
38479
38480C...Rescale for gammaVDM by effective gamma -> rho coupling.
38481C+++Do not rescale?
38482 IF(kfa.EQ.22.AND.mint(109).EQ.2.AND..NOT.(mstp(56).EQ.1
38483 & .AND.mstp(55).GE.5.AND.mstp(55).LE.12)) THEN
38484 DO 280 kfl=-6,6
38485 xpq(kfl)=vint(281)*xpq(kfl)
38486 xpval(kfl)=vint(281)*xpval(kfl)
38487 280 CONTINUE
38488 vint(232)=vint(281)*xpv
38489 ENDIF
38490
38491C...Simple recipes for kaons.
38492 ELSEIF(kfa.EQ.321) THEN
38493 xpq(-3)=xpq(-3)+xpq(-1)-xpq(1)
38494 xpq(-1)=xpq(1)
38495 xpval(-3)=xpval(-1)
38496 xpval(-1)=0d0
38497 ELSEIF(kfa.EQ.130.OR.kfa.EQ.310) THEN
38498 xps=0.5d0*(xpq(1)+xpq(-2))
38499 xpv=0.5d0*(xpq(2)+xpq(-1))-xps
38500 xpq(2)=xps
38501 xpq(-1)=xps
38502 xpq(1)=xpq(1)+0.5d0*xpv
38503 xpq(-1)=xpq(-1)+0.5d0*xpv
38504 xpq(3)=xpq(3)+0.5d0*xpv
38505 xpq(-3)=xpq(-3)+0.5d0*xpv
38506 xpv=0.5d0*(xpval(2)+xpval(-1))
38507 xpval(2)=0d0
38508 xpval(-1)=0d0
38509 xpval(1)=0.5d0*xpv
38510 xpval(-1)=0.5d0*xpv
38511 xpval(3)=0.5d0*xpv
38512 xpval(-3)=0.5d0*xpv
38513
38514C...Isospin conjugation for neutron.
38515 ELSEIF(kfa.EQ.2112) THEN
38516 xpsv=xpq(1)
38517 xpq(1)=xpq(2)
38518 xpq(2)=xpsv
38519 xpsv=xpq(-1)
38520 xpq(-1)=xpq(-2)
38521 xpq(-2)=xpsv
38522 xpsv=xpval(1)
38523 xpval(1)=xpval(2)
38524 xpval(2)=xpsv
38525
38526C...Simple recipes for hyperon (average valence parton distribution).
38527 ELSEIF(kfa.EQ.3122.OR.kfa.EQ.3112.OR.kfa.EQ.3212.OR.kfa.EQ.3222
38528 & .OR.kfa.EQ.3312.OR.kfa.EQ.3322.OR.kfa.EQ.3334) THEN
38529 xpv=(xpq(1)+xpq(2)-xpq(-1)-xpq(-2))/3d0
38530 xps=0.5d0*(xpq(-1)+xpq(-2))
38531 xpq(1)=xps
38532 xpq(2)=xps
38533 xpq(-1)=xps
38534 xpq(-2)=xps
38535 xpq(kfa/1000)=xpq(kfa/1000)+xpv
38536 xpq(mod(kfa/100,10))=xpq(mod(kfa/100,10))+xpv
38537 xpq(mod(kfa/10,10))=xpq(mod(kfa/10,10))+xpv
38538 xpv=(xpval(1)+xpval(2))/3d0
38539 xpval(1)=0d0
38540 xpval(2)=0d0
38541 xpval(kfa/1000)=xpval(kfa/1000)+xpv
38542 xpval(mod(kfa/100,10))=xpval(mod(kfa/100,10))+xpv
38543 xpval(mod(kfa/10,10))=xpval(mod(kfa/10,10))+xpv
38544 ENDIF
38545
38546C...Charge conjugation for antiparticle.
38547 IF(kf.LT.0) THEN
38548 DO 290 kfl=1,25
38549 IF(kfl.EQ.21.OR.kfl.EQ.22.OR.kfl.EQ.23.OR.kfl.EQ.25) GOTO 290
38550 xpsv=xpq(kfl)
38551 xpq(kfl)=xpq(-kfl)
38552 xpq(-kfl)=xpsv
38553 290 CONTINUE
38554 DO 300 kfl=1,6
38555 xpsv=xpval(kfl)
38556 xpval(kfl)=xpval(-kfl)
38557 xpval(-kfl)=xpsv
38558 300 CONTINUE
38559 ENDIF
38560
38561C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38562C...Set side.
38563 js=mint(30)
38564C...Only reshape PDFs for the non-first interactions;
38565C...But need valence/sea separation already from first interaction.
38566 IF ((js.EQ.1.OR.js.EQ.2).AND.mint(35).GE.2) THEN
38567 kfvsel=kfival(js,1)
38568C...If valence quark kicked out of pi0 or gamma then that decides
38569C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38570 IF(kfvsel.NE.0.AND.(kfa.EQ.111.OR.kfa.EQ.22)) THEN
38571 xpvl=0d0
38572 DO 310 kfl=1,6
38573 xpvl=xpvl+xpval(kfl)
38574 xpq(kfl)=max(0d0,xpq(kfl)-xpval(kfl))
38575 xpval(kfl)=0d0
38576 310 CONTINUE
38577 xpq(iabs(kfvsel))=xpq(iabs(kfvsel))+xpvl
38578 xpval(iabs(kfvsel))=xpvl
38579 DO 320 kfl=1,6
38580 xpq(-kfl)=xpq(kfl)
38581 xpval(-kfl)=xpval(kfl)
38582 320 CONTINUE
38583
38584C...If valence quark kicked out of K0S or K0S then that decides whether
38585C...we should consider state as d sbar or s dbar.
38586 ELSEIF(kfvsel.NE.0.AND.(kfa.EQ.130.OR.kfa.EQ.310)) THEN
38587 kfs=1
38588 IF(kfvsel.EQ.-1.OR.kfvsel.EQ.3) kfs=-1
38589 xpq(kfs)=xpq(kfs)+xpval(-kfs)
38590 xpval(kfs)=xpval(kfs)+xpval(-kfs)
38591 xpq(-kfs)=max(0d0,xpq(-kfs)-xpval(-kfs))
38592 xpval(-kfs)=0d0
38593 kfs=-3*kfs
38594 xpq(kfs)=xpq(kfs)+xpval(-kfs)
38595 xpval(kfs)=xpval(kfs)+xpval(-kfs)
38596 xpq(-kfs)=max(0d0,xpq(-kfs)-xpval(-kfs))
38597 xpval(-kfs)=0d0
38598 ENDIF
38599
38600C...XPQ distributions are nominal for a (signed) beam particle
38601C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38602 cmpfac=1d0
38603 nresc=0
38604 345 nresc=nresc+1
38605 pvctot(js,-1)=0d0
38606 pvctot(js, 0)=0d0
38607 pvctot(js, 1)=0d0
38608 DO 350 ifl=-6,6
38609 IF(ifl.EQ.0) GOTO 350
38610
38611C...Count up number of original IFL valence quarks.
38612 ivorg=0
38613 IF(kfival(js,1).EQ.ifl) ivorg=ivorg+1
38614 IF(kfival(js,2).EQ.ifl) ivorg=ivorg+1
38615 IF(kfival(js,3).EQ.ifl) ivorg=ivorg+1
38616C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38617C...bookkeep as if d dbar (for total momentum sum in valence sector).
38618 IF(kfival(js,1).EQ.0.AND.iabs(ifl).EQ.1) ivorg=1
38619C...Count down number of remaining IFL valence quarks. Skip current
38620C...interaction initiator.
38621 ivrem=ivorg
38622 DO 330 i1=1,nmi(js)
38623 IF (i1.EQ.mint(36)) GOTO 330
38624 IF (k(imi(js,i1,1),2).EQ.ifl.AND.imi(js,i1,2).EQ.0)
38625 & ivrem=ivrem-1
38626 330 CONTINUE
38627
38628C...Separate out original VALENCE and SEA content.
38629 val=xpval(ifl)
38630 sea=max(0d0,xpq(ifl)-val)
38631 xpsvc(ifl,0)=val
38632 xpsvc(ifl,-1)=sea
38633
38634C...Rescale valence content if changed.
38635 IF (ivorg.NE.0.AND.ivrem.NE.ivorg) xpsvc(ifl,0)=
38636 & (val*ivrem)/ivorg
38637
38638C...Momentum integrals of original and removed valence quarks.
38639 IF(ivorg.NE.0) THEN
38640C...For p/n/pbar/nbar beams can split into d_val and u_val.
38641C...Isospin conjugation for neutrons
38642 IF(kfa.EQ.2212.OR.kfa.EQ.2112) THEN
38643 iaflp=iabs(ifl)
38644 IF (kfa.EQ.2112) iaflp=3-iaflp
38645 vpavg=pavg(iaflp,q2)
38646C...For other baryons average d_val and u_val, like for PDFs.
38647 ELSEIF(kfa.GT.1000) THEN
38648 vpavg=(pavg(1,q2)+2d0*pavg(2,q2))/3d0
38649C...For mesons and photon average d_val and u_val and scale by 3/2.
38650C...Very crude, especially for photon.
38651 ELSE
38652 vpavg=0.5d0*(pavg(1,q2)+2d0*pavg(2,q2))
38653 ENDIF
38654 pvctot(js,-1)=pvctot(js,-1)+ivorg*vpavg
38655 pvctot(js, 0)=pvctot(js, 0)+(ivorg-ivrem)*vpavg
38656 ENDIF
38657
38658C...Now add companions (at X with partner having been at Z=XASSOC).
38659C...NOTE: due to the assumed simple x scaling, the partner was at what
38660C...corresponds to a higher Z than XASSOC, if there were intermediate
38661C...scatterings. Nothing done about that for the moment.
38662 DO 340 ivc=1,nvc(js,ifl)
38663C...Skip companions that have been kicked out
38664 IF (xassoc(js,ifl,ivc).LE.0d0) THEN
38665 xpsvc(ifl,ivc)=0d0
38666 GOTO 340
38667 ELSE
38668C...Momentum fraction of the partner quark.
38669C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38670 xs=xassoc(js,ifl,ivc)
38671 xrem=vint(142+js)
38672 ys=xs/(xrem+xs)
38673C...Momentum fraction of the companion quark.
38674C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38675 y=x*(1d0-ys)
38676 xpsvc(ifl,ivc)=pyfcmp(y/cmpfac,ys/cmpfac,mstp(87))
38677C...Add to momentum sum, with rescaling compensation factor.
38678 xcfac=(xrem+xs)/xrem*cmpfac
38679 pvctot(js,1)=pvctot(js,1)+xcfac*pypcmp(ys/cmpfac,mstp(87))
38680 ENDIF
38681 340 CONTINUE
38682 350 CONTINUE
38683
38684C...Wait until all flavours treated, then rescale seas and gluon.
38685 xpsvc(0,-1)=xpq(0)
38686 xpsvc(0,0)=0d0
38687 rsfac=1d0+(pvctot(js,0)-pvctot(js,1))/(1d0-pvctot(js,-1))
38688 IF (rsfac.LE.0d0) THEN
38689C...First calculate factor needed to exactly restore pz cons.
38690 IF (nresc.EQ.1) cmpfac =
38691 & (1d0-(pvctot(js,-1)-pvctot(js,0)))/pvctot(js,1)
38692C...Add a bit of headroom
38693 cmpfac=0.99*cmpfac
38694C...Try a few times if more headroom is needed, then print error message.
38695 IF (nresc.LE.10) GOTO 345
38696 CALL pyerrm(15,
38697 & '(PYPDFU:) Negative reshaping factor persists!')
38698 WRITE(mstu(11),5300) (pvctot(js,itmp),itmp=-1,1), rsfac
38699 rsfac=0d0
38700 ENDIF
38701 DO 370 ifl=-6,6
38702 xpsvc(ifl,-1)=rsfac*xpsvc(ifl,-1)
38703C...Also store resulting distributions in XPQ
38704 xpq(ifl)=0d0
38705 DO 360 isvc=-1,nvc(js,ifl)
38706 xpq(ifl)=xpq(ifl)+xpsvc(ifl,isvc)
38707 360 CONTINUE
38708 370 CONTINUE
38709C...Save companion reweighting factor for PYPTIS.
38710 vint(140)=cmpfac
38711 ENDIF
38712
38713
38714C...Allow gluon also in position 21.
38715 xpq(21)=xpq(0)
38716
38717C...Check positivity and reset above maximum allowed flavour.
38718 DO 380 kfl=-25,25
38719 xpq(kfl)=max(0d0,xpq(kfl))
38720 IF(iabs(kfl).GT.mstp(58).AND.iabs(kfl).LE.8) xpq(kfl)=0d0
38721 380 CONTINUE
38722
38723C...Formats for error printouts.
38724 5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
38725 5100 FORMAT(' Error: illegal particle code for parton distribution;',
38726 &' KF =',i5)
38727 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38728 &3i5)
38729 5300 FORMAT(' Original valence momentum fraction : ',f6.3/
38730 & ' Removed valence momentum fraction : ',f6.3/
38731 & ' Added companion momentum fraction : ',f6.3/
38732 & ' Resulting rescale factor : ',f6.3)
38733
38734C...Reset side pointer and return
38735 9999 mint(30)=0
38736
38737 RETURN
38738 END
38739
38740C*********************************************************************
38741
38742C...PYPDFL
38743C...Gives proton parton distribution at small x and/or Q^2 according to
38744C...correct limiting behaviour.
38745
38746 SUBROUTINE pypdfl(KF,X,Q2,XPQ)
38747
38748C...Double precision and integer declarations.
38749 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38750 IMPLICIT INTEGER(I-N)
38751 INTEGER PYK,PYCHGE,PYCOMP
38752C...Commonblocks.
38753 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38754 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38755 common/pypars/mstp(200),parp(200),msti(200),pari(200)
38756 common/pyint1/mint(400),vint(400)
38757 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
38758C...Local arrays.
38759 dimension xpq(-25:25),xpa(-25:25),xpb(-25:25),wtsb(-3:3)
38760 DATA rmr/0.92d0/,rmp/0.38d0/,wtsb/0.5d0,1d0,1d0,5d0,1d0,1d0,0.5d0/
38761
38762C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38763 mint(92)=0
38764 kfa=iabs(kf)
38765 iacc=0
38766 IF((kfa.EQ.2212.OR.kfa.EQ.2112).AND.mstp(57).GE.2) iacc=1
38767 IF(kfa.EQ.211.AND.mstp(57).GE.3) iacc=1
38768 IF(kfa.EQ.22.AND.mint(109).EQ.2.AND.mstp(57).GE.3) iacc=1
38769 IF(iacc.EQ.0) THEN
38770 CALL pypdfu(kf,x,q2,xpq)
38771 RETURN
38772 ENDIF
38773
38774C...Reset. Check x.
38775 DO 100 kfl=-25,25
38776 xpq(kfl)=0d0
38777 100 CONTINUE
38778 IF(x.LE.0d0.OR.x.GE.1d0) THEN
38779 WRITE(mstu(11),5000) x
38780 RETURN
38781 ENDIF
38782
38783C...Define valence content.
38784 kfc=kf
38785 nv1=2
38786 nv2=1
38787 IF(kf.EQ.2212) THEN
38788 kfv1=2
38789 kfv2=1
38790 ELSEIF(kf.EQ.-2212) THEN
38791 kfv1=-2
38792 kfv2=-1
38793 ELSEIF(kf.EQ.2112) THEN
38794 kfv1=1
38795 kfv2=2
38796 ELSEIF(kf.EQ.-2112) THEN
38797 kfv1=-1
38798 kfv2=-2
38799 ELSEIF(kf.EQ.211) THEN
38800 nv1=1
38801 kfv1=2
38802 kfv2=-1
38803 ELSEIF(kf.EQ.-211) THEN
38804 nv1=1
38805 kfv1=-2
38806 kfv2=1
38807 ELSEIF(mint(105).LE.223) THEN
38808 kfv1=1
38809 wtv1=0.2d0
38810 kfv2=2
38811 wtv2=0.8d0
38812 ELSEIF(mint(105).EQ.333) THEN
38813 kfv1=3
38814 wtv1=1.0d0
38815 kfv2=1
38816 wtv2=0.0d0
38817 ELSEIF(mint(105).EQ.443) THEN
38818 kfv1=4
38819 wtv1=1.0d0
38820 kfv2=1
38821 wtv2=0.0d0
38822 ENDIF
38823
38824C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38825 mint30=mint(30)
38826 CALL pypdfu(kfc,x,q2,xpa)
38827 q2mn=max(3d0,vint(231))
38828 q2b=2d0+0.052d0**2*exp(3.56d0*sqrt(max(0d0,-log(3d0*x))))
38829 xmn=exp(-(log((q2mn-2d0)/0.052d0**2)/3.56d0)**2)/3d0
38830
38831C...Large Q2 and large x: naive call is enough.
38832 IF(q2.GT.q2mn.AND.q2.GT.q2b) THEN
38833 DO 110 kfl=-25,25
38834 xpq(kfl)=xpa(kfl)
38835 110 CONTINUE
38836 mint(92)=1
38837
38838C...Small Q2 and large x: dampen boundary value.
38839 ELSEIF(x.GT.xmn) THEN
38840
38841C...Evaluate at boundary and define dampening factors.
38842 mint(30)=mint30
38843 CALL pypdfu(kfc,x,q2mn,xpa)
38844 fv=(q2*(q2mn+rmr)/(q2mn*(q2+rmr)))**(0.55d0*(1d0-x)/(1d0-xmn))
38845 fs=(q2*(q2mn+rmp)/(q2mn*(q2+rmp)))**1.08d0
38846
38847C...Separate valence and sea parts of parton distribution.
38848 IF(kfa.NE.22) THEN
38849 xfv1=xpa(kfv1)-xpa(-kfv1)
38850 xpa(kfv1)=xpa(-kfv1)
38851 xfv2=xpa(kfv2)-xpa(-kfv2)
38852 xpa(kfv2)=xpa(-kfv2)
38853 ELSE
38854 xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
38855 xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
38856 xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
38857 xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
38858 ENDIF
38859
38860C...Dampen valence and sea separately. Put back together.
38861 DO 120 kfl=-25,25
38862 xpq(kfl)=fs*xpa(kfl)
38863 120 CONTINUE
38864 IF(kfa.NE.22) THEN
38865 xpq(kfv1)=xpq(kfv1)+fv*xfv1
38866 xpq(kfv2)=xpq(kfv2)+fv*xfv2
38867 ELSE
38868 xpq(kfv1)=xpq(kfv1)+fv*wtv1*vint(232)
38869 xpq(-kfv1)=xpq(-kfv1)+fv*wtv1*vint(232)
38870 xpq(kfv2)=xpq(kfv2)+fv*wtv2*vint(232)
38871 xpq(-kfv2)=xpq(-kfv2)+fv*wtv2*vint(232)
38872 ENDIF
38873 mint(92)=2
38874
38875C...Large Q2 and small x: interpolate behaviour.
38876 ELSEIF(q2.GT.q2mn) THEN
38877
38878C...Evaluate at extremes and define coefficients for interpolation.
38879 mint(30)=mint30
38880 CALL pypdfu(kfc,xmn,q2mn,xpa)
38881 vi232a=vint(232)
38882 mint(30)=mint30
38883 CALL pypdfu(kfc,x,q2b,xpb)
38884 vi232b=vint(232)
38885 fla=log(q2b/q2)/log(q2b/q2mn)
38886 fva=(x/xmn)**0.45d0*fla
38887 fsa=(x/xmn)**(-0.08d0)*fla
38888 fb=1d0-fla
38889
38890C...Separate valence and sea parts of parton distribution.
38891 IF(kfa.NE.22) THEN
38892 xfva1=xpa(kfv1)-xpa(-kfv1)
38893 xpa(kfv1)=xpa(-kfv1)
38894 xfva2=xpa(kfv2)-xpa(-kfv2)
38895 xpa(kfv2)=xpa(-kfv2)
38896 xfvb1=xpb(kfv1)-xpb(-kfv1)
38897 xpb(kfv1)=xpb(-kfv1)
38898 xfvb2=xpb(kfv2)-xpb(-kfv2)
38899 xpb(kfv2)=xpb(-kfv2)
38900 ELSE
38901 xpa(kfv1)=xpa(kfv1)-wtv1*vi232a
38902 xpa(-kfv1)=xpa(-kfv1)-wtv1*vi232a
38903 xpa(kfv2)=xpa(kfv2)-wtv2*vi232a
38904 xpa(-kfv2)=xpa(-kfv2)-wtv2*vi232a
38905 xpb(kfv1)=xpb(kfv1)-wtv1*vi232b
38906 xpb(-kfv1)=xpb(-kfv1)-wtv1*vi232b
38907 xpb(kfv2)=xpb(kfv2)-wtv2*vi232b
38908 xpb(-kfv2)=xpb(-kfv2)-wtv2*vi232b
38909 ENDIF
38910
38911C...Interpolate for valence and sea. Put back together.
38912 DO 130 kfl=-25,25
38913 xpq(kfl)=fsa*xpa(kfl)+fb*xpb(kfl)
38914 130 CONTINUE
38915 IF(kfa.NE.22) THEN
38916 xpq(kfv1)=xpq(kfv1)+(fva*xfva1+fb*xfvb1)
38917 xpq(kfv2)=xpq(kfv2)+(fva*xfva2+fb*xfvb2)
38918 ELSE
38919 xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vi232a+fb*vi232b)
38920 xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vi232a+fb*vi232b)
38921 xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vi232a+fb*vi232b)
38922 xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vi232a+fb*vi232b)
38923 ENDIF
38924 mint(92)=3
38925
38926C...Small Q2 and small x: dampen boundary value and add term.
38927 ELSE
38928
38929C...Evaluate at boundary and define dampening factors.
38930 mint(30)=mint30
38931 CALL pypdfu(kfc,xmn,q2mn,xpa)
38932 fb=(xmn-x)*(q2mn-q2)/(xmn*q2mn)
38933 fa=1d0-fb
38934 fvc=(x/xmn)**0.45d0*(q2/(q2+rmr))**0.55d0
38935 fva=fvc*fa*((q2mn+rmr)/q2mn)**0.55d0
38936 fvb=fvc*fb*1.10d0*xmn**0.45d0*0.11d0
38937 fsc=(x/xmn)**(-0.08d0)*(q2/(q2+rmp))**1.08d0
38938 fsa=fsc*fa*((q2mn+rmp)/q2mn)**1.08d0
38939 fsb=fsc*fb*0.21d0*xmn**(-0.08d0)*0.21d0
38940
38941C...Separate valence and sea parts of parton distribution.
38942 IF(kfa.NE.22) THEN
38943 xfv1=xpa(kfv1)-xpa(-kfv1)
38944 xpa(kfv1)=xpa(-kfv1)
38945 xfv2=xpa(kfv2)-xpa(-kfv2)
38946 xpa(kfv2)=xpa(-kfv2)
38947 ELSE
38948 xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)
38949 xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)
38950 xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)
38951 xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)
38952 ENDIF
38953
38954C...Dampen valence and sea separately. Add constant terms.
38955C...Put back together.
38956 DO 140 kfl=-25,25
38957 xpq(kfl)=fsa*xpa(kfl)
38958 140 CONTINUE
38959 IF(kfa.NE.22) THEN
38960 DO 150 kfl=-3,3
38961 xpq(kfl)=xpq(kfl)+fsb*wtsb(kfl)
38962 150 CONTINUE
38963 xpq(kfv1)=xpq(kfv1)+(fva*xfv1+fvb*nv1)
38964 xpq(kfv2)=xpq(kfv2)+(fva*xfv2+fvb*nv2)
38965 ELSE
38966 DO 160 kfl=-3,3
38967 xpq(kfl)=xpq(kfl)+vint(281)*fsb*wtsb(kfl)
38968 160 CONTINUE
38969 xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
38970 xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))
38971 xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
38972 xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))
38973 ENDIF
38974 xpq(21)=xpq(0)
38975 mint(92)=4
38976 ENDIF
38977
38978C...Format for error printout.
38979 5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)
38980
38981 RETURN
38982 END
38983
38984C*********************************************************************
38985
38986C...PYPDEL
38987C...Gives electron (or muon, or tau) parton distribution.
38988
38989 SUBROUTINE pypdel(KFA,X,Q2,XPEL)
38990
38991C...Double precision and integer declarations.
38992 IMPLICIT DOUBLE PRECISION(a-h, o-z)
38993 IMPLICIT INTEGER(I-N)
38994 INTEGER PYK,PYCHGE,PYCOMP
38995C...Commonblocks.
38996 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
38997 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
38998 common/pypars/mstp(200),parp(200),msti(200),pari(200)
38999 common/pyint1/mint(400),vint(400)
39000 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
39001C...Local arrays.
39002 dimension xpel(-25:25),xpga(-6:6),sxp(0:6)
39003
39004C...Interface to PDFLIB.
39005 common/w50513/xmin,xmax,q2min,q2max
39006 SAVE /w50513/
39007 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39008 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39009 CHARACTER*20 PARM(20)
39010 DATA VALUE/20*0d0/,parm/20*' '/
39011
39012C...Some common constants.
39013 DO 100 kfl=-25,25
39014 xpel(kfl)=0d0
39015 100 CONTINUE
39016 aem=paru(101)
39017 pme=pmas(11,1)
39018 IF(kfa.EQ.13) pme=pmas(13,1)
39019 IF(kfa.EQ.15) pme=pmas(15,1)
39020 xl=log(max(1d-10,x))
39021 x1l=log(max(1d-10,1d0-x))
39022 hle=log(max(3d0,q2/pme**2))
39023 hbe2=(aem/paru(1))*(hle-1d0)
39024
39025C...Electron inside electron, see R. Kleiss et al., in Z physics at
39026C...LEP 1, CERN 89-08, p. 34
39027 IF(mstp(59).LE.1) THEN
39028 hde=1d0+(aem/paru(1))*(1.5d0*hle+1.289868d0)+(aem/paru(1))**2*
39029 & (-2.164868d0*hle**2+9.840808d0*hle-10.130464d0)
39030 hee=hbe2*(1d0-x)**(hbe2-1d0)*sqrt(max(0d0,hde))-
39031 & 0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*(-4d0*x1l+3d0*xl)-
39032 & 4d0*xl/(1d0-x)-5d0-x)
39033 ELSE
39034 hee=hbe2*(1d0-x)**(hbe2-1d0)*exp(0.172784d0*hbe2)/
39035 & pygamm(1d0+hbe2)-0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*
39036 & (-4d0*x1l+3d0*xl)-4d0*xl/(1d0-x)-5d0-x)
39037 ENDIF
39038C...Zero distribution for very large x and rescale it for intermediate.
39039 IF(x.GT.1d0-1d-10) THEN
39040 hee=0d0
39041 ELSEIF(x.GT.1d0-1d-7) THEN
39042 hee=hee*1000d0**hbe2/(1000d0**hbe2-1d0)
39043 ENDIF
39044 xpel(kfa)=x*hee
39045
39046C...Photon and (transverse) W- inside electron.
39047 aemp=pyalem(pme*sqrt(max(0d0,q2)))/paru(2)
39048 IF(mstp(13).LE.1) THEN
39049 hlg=hle
39050 ELSE
39051 hlg=log(max(1d0,(parp(13)/pme**2)*(1d0-x)/x**2))
39052 ENDIF
39053 xpel(22)=aemp*hlg*(1d0+(1d0-x)**2)
39054 hlw=log(1d0+q2/pmas(24,1)**2)/(4d0*paru(102))
39055 xpel(-24)=aemp*hlw*(1d0+(1d0-x)**2)
39056
39057C...Electron or positron inside photon inside electron.
39058 IF(kfa.EQ.11.AND.mstp(12).EQ.1) THEN
39059 xfsea=0.5d0*(aemp*(hle-1d0))**2*(4d0/3d0+x-x**2-4d0*x**3/3d0+
39060 & 2d0*x*(1d0+x)*xl)
39061 xpel(11)=xpel(11)+xfsea
39062 xpel(-11)=xfsea
39063
39064C...Initialize PDFLIB photon parton distributions.
39065 IF(mstp(56).EQ.2) THEN
39066 parm(1)='NPTYPE'
39067 value(1)=3
39068 parm(2)='NGROUP'
39069 value(2)=mstp(55)/1000
39070 parm(3)='NSET'
39071 value(3)=mod(mstp(55),1000)
39072 IF(mint(93).NE.3000000+mstp(55)) THEN
39073 CALL pdfset(parm,VALUE)
39074 mint(93)=3000000+mstp(55)
39075 ENDIF
39076 ENDIF
39077
39078C...Quarks and gluons inside photon inside electron:
39079C...numerical convolution required.
39080 DO 110 kfl=0,6
39081 sxp(kfl)=0d0
39082 110 CONTINUE
39083 sumxpp=0d0
39084 iter=-1
39085 120 iter=iter+1
39086 sumxp=sumxpp
39087 nstp=2**(iter-1)
39088 IF(iter.EQ.0) nstp=2
39089 DO 130 kfl=0,6
39090 sxp(kfl)=0.5d0*sxp(kfl)
39091 130 CONTINUE
39092 wtstp=0.5d0/nstp
39093 IF(iter.EQ.0) wtstp=0.5d0
39094C...Pick grid of x_{gamma} values logarithmically even.
39095 DO 150 istp=1,nstp
39096 IF(iter.EQ.0) THEN
39097 xle=xl*(istp-1)
39098 ELSE
39099 xle=xl*(istp-0.5d0)/nstp
39100 ENDIF
39101 xe=min(1d0-1d-10,exp(xle))
39102 xg=min(1d0-1d-10,x/xe)
39103C...Evaluate photon inside electron parton distribution for convolution.
39104 xpgp=1d0+(1d0-xe)**2
39105 IF(mstp(13).LE.1) THEN
39106 xpgp=xpgp*hle
39107 ELSE
39108 xpgp=xpgp*log(max(1d0,(parp(13)/pme**2)*(1d0-xe)/xe**2))
39109 ENDIF
39110C...Evaluate photon parton distributions for convolution.
39111 IF(mstp(56).EQ.1) THEN
39112 IF(mstp(55).EQ.1) THEN
39113 CALL pypdga(xg,q2,xpga)
39114 ELSEIF(mstp(55).GE.5.AND.mstp(55).LE.8) THEN
39115 q2mx=q2
39116 p2mx=0.36d0
39117 IF(mstp(55).GE.7) p2mx=4.0d0
39118 IF(mstp(57).EQ.0) q2mx=p2mx
39119 p2=0d0
39120 IF(vint(120).LT.0d0) p2=vint(120)**2
39121 CALL pyggam(mstp(55)-4,xg,q2mx,p2,mstp(60),f2gam,xpga)
39122 vint(231)=p2mx
39123 ELSEIF(mstp(55).GE.9.AND.mstp(55).LE.12) THEN
39124 q2mx=q2
39125 p2mx=0.36d0
39126 IF(mstp(55).GE.11) p2mx=4.0d0
39127 IF(mstp(57).EQ.0) q2mx=p2mx
39128 p2=0d0
39129 IF(vint(120).LT.0d0) p2=vint(120)**2
39130 CALL pyggam(mstp(55)-8,xg,q2mx,p2,mstp(60),f2gam,xpga)
39131 vint(231)=p2mx
39132 ENDIF
39133 DO 140 kfl=0,5
39134 sxp(kfl)=sxp(kfl)+wtstp*xpgp*xpga(kfl)
39135 140 CONTINUE
39136 ELSEIF(mstp(56).EQ.2) THEN
39137C...Call PDFLIB parton distributions.
39138 xx=xg
39139 qq=sqrt(max(0d0,q2min,q2))
39140 IF(mstp(57).EQ.0) qq=sqrt(q2min)
39141 CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)
39142 sxp(0)=sxp(0)+wtstp*xpgp*glu
39143 sxp(1)=sxp(1)+wtstp*xpgp*dnv
39144 sxp(2)=sxp(2)+wtstp*xpgp*upv
39145 sxp(3)=sxp(3)+wtstp*xpgp*str
39146 sxp(4)=sxp(4)+wtstp*xpgp*chm
39147 sxp(5)=sxp(5)+wtstp*xpgp*bot
39148 sxp(6)=sxp(6)+wtstp*xpgp*top
39149 ENDIF
39150 150 CONTINUE
39151 sumxpp=sxp(0)+2d0*sxp(1)+2d0*sxp(2)
39152 IF(iter.LE.2.OR.(iter.LE.7.AND.abs(sumxpp-sumxp).GT.
39153 & parp(14)*(sumxpp+sumxp))) GOTO 120
39154
39155C...Put convolution into output arrays.
39156 fconv=aemp*(-xl)
39157 xpel(0)=fconv*sxp(0)
39158 DO 160 kfl=1,6
39159 xpel(kfl)=fconv*sxp(kfl)
39160 xpel(-kfl)=xpel(kfl)
39161 160 CONTINUE
39162 ENDIF
39163
39164 RETURN
39165 END
39166
39167C*********************************************************************
39168
39169C...PYPDGA
39170C...Gives photon parton distribution.
39171
39172 SUBROUTINE pypdga(X,Q2,XPGA)
39173
39174C...Double precision and integer declarations.
39175 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39176 IMPLICIT INTEGER(I-N)
39177 INTEGER PYK,PYCHGE,PYCOMP
39178C...Commonblocks.
39179 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39180 common/pypars/mstp(200),parp(200),msti(200),pari(200)
39181 common/pyint1/mint(400),vint(400)
39182 SAVE /pydat1/,/pypars/,/pyint1/
39183C...Local arrays.
39184 dimension xpga(-6:6),dgag(4,3),dgbg(4,3),dgcg(4,3),dgan(4,3),
39185 &dgbn(4,3),dgcn(4,3),dgdn(4,3),dgen(4,3),dgas(4,3),dgbs(4,3),
39186 &dgcs(4,3),dgds(4,3),dges(4,3)
39187
39188C...The following data lines are coefficients needed in the
39189C...Drees and Grassie photon parton distribution parametrization.
39190 DATA dgag/-.207d0,.6158d0,1.074d0,0.d0,.8926d-2,.6594d0,
39191 &.4766d0,.1975d-1,.03197d0,1.018d0,.2461d0,.2707d-1/
39192 DATA dgbg/-.1987d0,.6257d0,8.352d0,5.024d0,.5085d-1,.2774d0,
39193 &-.3906d0,-.3212d0,-.618d-2,.9476d0,-.6094d0,-.1067d-1/
39194 DATA dgcg/5.119d0,-.2752d0,-6.993d0,2.298d0,-.2313d0,.1382d0,
39195 &6.542d0,.5162d0,-.1216d0,.9047d0,2.653d0,.2003d-2/
39196 DATA dgan/2.285d0,-.1526d-1,1330.d0,4.219d0,-.3711d0,1.061d0,
39197 &4.758d0,-.1503d-1,15.8d0,-.9464d0,-.5d0,-.2118d0/
39198 DATA dgbn/6.073d0,-.8132d0,-41.31d0,3.165d0,-.1717d0,.7815d0,
39199 &1.535d0,.7067d-2,2.742d0,-.7332d0,.7148d0,3.287d0/
39200 DATA dgcn/-.4202d0,.1778d-1,.9216d0,.18d0,.8766d-1,.2197d-1,
39201 &.1096d0,.204d0,.2917d-1,.4657d-1,.1785d0,.4811d-1/
39202 DATA dgdn/-.8083d-1,.6346d0,1.208d0,.203d0,-.8915d0,.2857d0,
39203 &2.973d0,.1185d0,-.342d-1,.7196d0,.7338d0,.8139d-1/
39204 DATA dgen/.5526d-1,1.136d0,.9512d0,.1163d-1,-.1816d0,.5866d0,
39205 &2.421d0,.4059d0,-.2302d-1,.9229d0,.5873d0,-.79d-4/
39206 DATA dgas/16.69d0,-.7916d0,1099.d0,4.428d0,-.1207d0,1.071d0,
39207 &1.977d0,-.8625d-2,6.734d0,-1.008d0,-.8594d-1,.7625d-1/
39208 DATA dgbs/.176d0,.4794d-1,1.047d0,.25d-1,25.d0,-1.648d0,
39209 &-.1563d-1,6.438d0,59.88d0,-2.983d0,4.48d0,.9686d0/
39210 DATA dgcs/-.208d-1,.3386d-2,4.853d0,.8404d0,-.123d-1,1.162d0,
39211 &.4824d0,-.11d-1,-.3226d-2,.8432d0,.3616d0,.1383d-2/
39212 DATA dgds/-.1685d-1,1.353d0,1.426d0,1.239d0,-.9194d-1,.7912d0,
39213 &.6397d0,2.327d0,-.3321d-1,.9475d0,-.3198d0,.2132d-1/
39214 DATA dges/-.1986d0,1.1d0,1.136d0,-.2779d0,.2015d-1,.9869d0,
39215 &-.7036d-1,.1694d-1,.1059d0,.6954d0,-.6663d0,.3683d0/
39216
39217C...Photon parton distribution from Drees and Grassie.
39218C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39219 DO 100 kfl=-6,6
39220 xpga(kfl)=0d0
39221 100 CONTINUE
39222 vint(231)=1d0
39223 IF(mstp(57).LE.0) THEN
39224 t=log(1d0/0.16d0)
39225 ELSE
39226 t=log(min(1d4,max(1d0,q2))/0.16d0)
39227 ENDIF
39228 x1=1d0-x
39229 nf=3
39230 IF(q2.GT.25d0) nf=4
39231 IF(q2.GT.300d0) nf=5
39232 nfe=nf-2
39233 aem=paru(101)
39234
39235C...Evaluate gluon content.
39236 dga=dgag(1,nfe)*t**dgag(2,nfe)+dgag(3,nfe)*t**(-dgag(4,nfe))
39237 dgb=dgbg(1,nfe)*t**dgbg(2,nfe)+dgbg(3,nfe)*t**(-dgbg(4,nfe))
39238 dgc=dgcg(1,nfe)*t**dgcg(2,nfe)+dgcg(3,nfe)*t**(-dgcg(4,nfe))
39239 xpgl=dga*x**dgb*x1**dgc
39240
39241C...Evaluate up- and down-type quark content.
39242 dga=dgan(1,nfe)*t**dgan(2,nfe)+dgan(3,nfe)*t**(-dgan(4,nfe))
39243 dgb=dgbn(1,nfe)*t**dgbn(2,nfe)+dgbn(3,nfe)*t**(-dgbn(4,nfe))
39244 dgc=dgcn(1,nfe)*t**dgcn(2,nfe)+dgcn(3,nfe)*t**(-dgcn(4,nfe))
39245 dgd=dgdn(1,nfe)*t**dgdn(2,nfe)+dgdn(3,nfe)*t**(-dgdn(4,nfe))
39246 dge=dgen(1,nfe)*t**dgen(2,nfe)+dgen(3,nfe)*t**(-dgen(4,nfe))
39247 xpqn=x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
39248 dga=dgas(1,nfe)*t**dgas(2,nfe)+dgas(3,nfe)*t**(-dgas(4,nfe))
39249 dgb=dgbs(1,nfe)*t**dgbs(2,nfe)+dgbs(3,nfe)*t**(-dgbs(4,nfe))
39250 dgc=dgcs(1,nfe)*t**dgcs(2,nfe)+dgcs(3,nfe)*t**(-dgcs(4,nfe))
39251 dgd=dgds(1,nfe)*t**dgds(2,nfe)+dgds(3,nfe)*t**(-dgds(4,nfe))
39252 dge=dges(1,nfe)*t**dges(2,nfe)+dges(3,nfe)*t**(-dges(4,nfe))
39253 dgf=9d0
39254 IF(nf.EQ.4) dgf=10d0
39255 IF(nf.EQ.5) dgf=55d0/6d0
39256 xpqs=dgf*x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge
39257 IF(nf.LE.3) THEN
39258 xpqu=(xpqs+9d0*xpqn)/6d0
39259 xpqd=(xpqs-4.5d0*xpqn)/6d0
39260 ELSEIF(nf.EQ.4) THEN
39261 xpqu=(xpqs+6d0*xpqn)/8d0
39262 xpqd=(xpqs-6d0*xpqn)/8d0
39263 ELSE
39264 xpqu=(xpqs+7.5d0*xpqn)/10d0
39265 xpqd=(xpqs-5d0*xpqn)/10d0
39266 ENDIF
39267
39268C...Put into output arrays.
39269 xpga(0)=aem*xpgl
39270 xpga(1)=aem*xpqd
39271 xpga(2)=aem*xpqu
39272 xpga(3)=aem*xpqd
39273 IF(nf.GE.4) xpga(4)=aem*xpqu
39274 IF(nf.GE.5) xpga(5)=aem*xpqd
39275 DO 110 kfl=1,6
39276 xpga(-kfl)=xpga(kfl)
39277 110 CONTINUE
39278
39279 RETURN
39280 END
39281
39282C*********************************************************************
39283
39284C...PYGGAM
39285C...Constructs the F2 and parton distributions of the photon
39286C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39287C...For F2, c and b are included by the Bethe-Heitler formula;
39288C...in the 'MSbar' scheme additionally a Cgamma term is added.
39289C...Contains the SaS sets 1D, 1M, 2D and 2M.
39290C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39291
39292 SUBROUTINE pyggam(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39293
39294C...Double precision and integer declarations.
39295 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39296 IMPLICIT INTEGER(I-N)
39297 INTEGER PYK,PYCHGE,PYCOMP
39298C...Commonblocks.
39299 common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
39300 &xpdir(-6:6)
39301 common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)
39302 SAVE /pyint8/,/pyint9/
39303C...Local arrays.
39304 dimension xpdfgm(-6:6),xpga(-6:6), vxpga(-6:6)
39305C...Charm and bottom masses (low to compensate for J/psi etc.).
39306 DATA pmc/1.3d0/, pmb/4.6d0/
39307C...alpha_em and alpha_em/(2*pi).
39308 DATA aem/0.007297d0/, aem2pi/0.0011614d0/
39309C...Lambda value for 4 flavours.
39310 DATA alam/0.20d0/
39311C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39312 DATA fracu/0.8d0/
39313C...VMD couplings f_V**2/(4*pi).
39314 DATA frho/2.20d0/, fomega/23.6d0/, fphi/18.4d0/
39315C...Masses for rho (=omega) and phi.
39316 DATA pmrho/0.770d0/, pmphi/1.020d0/
39317C...Number of points in integration for IP2=1.
39318 DATA nstep/100/
39319
39320C...Reset output.
39321 f2gm=0d0
39322 DO 100 kfl=-6,6
39323 xpdfgm(kfl)=0d0
39324 xpvmd(kfl)=0d0
39325 xpanl(kfl)=0d0
39326 xpanh(kfl)=0d0
39327 xpbeh(kfl)=0d0
39328 xpdir(kfl)=0d0
39329 vxpvmd(kfl)=0d0
39330 vxpanl(kfl)=0d0
39331 vxpanh(kfl)=0d0
39332 vxpdgm(kfl)=0d0
39333 100 CONTINUE
39334
39335C...Set Q0 cut-off parameter as function of set used.
39336 IF(iset.LE.2) THEN
39337 q0=0.6d0
39338 ELSE
39339 q0=2d0
39340 ENDIF
39341 q02=q0**2
39342
39343C...Scale choice for off-shell photon; common factors.
39344 q2a=q2
39345 facnor=1d0
39346 IF(ip2.EQ.1) THEN
39347 p2mx=p2+q02
39348 q2a=q2+p2*q02/max(q02,q2)
39349 facnor=log(q2/q02)/nstep
39350 ELSEIF(ip2.EQ.2) THEN
39351 p2mx=max(p2,q02)
39352 ELSEIF(ip2.EQ.3) THEN
39353 p2mx=p2+q02
39354 q2a=q2+p2*q02/max(q02,q2)
39355 ELSEIF(ip2.EQ.4) THEN
39356 p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
39357 & ((q2+p2)*(q02+p2)))
39358 ELSEIF(ip2.EQ.5) THEN
39359 p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
39360 & ((q2+p2)*(q02+p2)))
39361 p2mx=q0*sqrt(p2mxa)
39362 facnor=log(q2/p2mxa)/log(q2/p2mx)
39363 ELSEIF(ip2.EQ.6) THEN
39364 p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
39365 & ((q2+p2)*(q02+p2)))
39366 p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
39367 ELSE
39368 p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/
39369 & ((q2+p2)*(q02+p2)))
39370 p2mx=q0*sqrt(p2mxa)
39371 p2mxb=p2mx
39372 p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)
39373 p2mxb=max(0d0,1d0-p2/q2)*p2mxb+min(1d0,p2/q2)*p2mxa
39374 IF(abs(q2-q02).GT.1d-6) THEN
39375 facnor=log(q2/p2mxa)/log(q2/p2mxb)
39376 ELSEIF(p2.LT.q02) THEN
39377 facnor=q02**3/(q02+p2)/(q02**2-p2**2/2d0)
39378 ELSE
39379 facnor=1d0
39380 ENDIF
39381 ENDIF
39382
39383C...Call VMD parametrization for d quark and use to give rho, omega,
39384C...phi. Note dipole dampening for off-shell photon.
39385 CALL pygvmd(iset,1,x,q2a,p2mx,alam,xpga,vxpga)
39386 xfval=vxpga(1)
39387 xpga(1)=xpga(2)
39388 xpga(-1)=xpga(-2)
39389 facud=aem*(1d0/frho+1d0/fomega)*(pmrho**2/(pmrho**2+p2))**2
39390 facs=aem*(1d0/fphi)*(pmphi**2/(pmphi**2+p2))**2
39391 DO 110 kfl=-5,5
39392 xpvmd(kfl)=(facud+facs)*xpga(kfl)
39393 110 CONTINUE
39394 xpvmd(1)=xpvmd(1)+(1d0-fracu)*facud*xfval
39395 xpvmd(2)=xpvmd(2)+fracu*facud*xfval
39396 xpvmd(3)=xpvmd(3)+facs*xfval
39397 xpvmd(-1)=xpvmd(-1)+(1d0-fracu)*facud*xfval
39398 xpvmd(-2)=xpvmd(-2)+fracu*facud*xfval
39399 xpvmd(-3)=xpvmd(-3)+facs*xfval
39400 vxpvmd(1)=(1d0-fracu)*facud*xfval
39401 vxpvmd(2)=fracu*facud*xfval
39402 vxpvmd(3)=facs*xfval
39403 vxpvmd(-1)=(1d0-fracu)*facud*xfval
39404 vxpvmd(-2)=fracu*facud*xfval
39405 vxpvmd(-3)=facs*xfval
39406
39407 IF(ip2.NE.1) THEN
39408C...Anomalous parametrizations for different strategies
39409C...for off-shell photons; except full integration.
39410
39411C...Call anomalous parametrization for d + u + s.
39412 CALL pygano(-3,x,q2a,p2mx,alam,xpga,vxpga)
39413 DO 120 kfl=-5,5
39414 xpanl(kfl)=facnor*xpga(kfl)
39415 vxpanl(kfl)=facnor*vxpga(kfl)
39416 120 CONTINUE
39417
39418C...Call anomalous parametrization for c and b.
39419 CALL pygano(4,x,q2a,p2mx,alam,xpga,vxpga)
39420 DO 130 kfl=-5,5
39421 xpanh(kfl)=facnor*xpga(kfl)
39422 vxpanh(kfl)=facnor*vxpga(kfl)
39423 130 CONTINUE
39424 CALL pygano(5,x,q2a,p2mx,alam,xpga,vxpga)
39425 DO 140 kfl=-5,5
39426 xpanh(kfl)=xpanh(kfl)+facnor*xpga(kfl)
39427 vxpanh(kfl)=vxpanh(kfl)+facnor*vxpga(kfl)
39428 140 CONTINUE
39429
39430 ELSE
39431C...Special option: loop over flavours and integrate over k2.
39432 DO 170 kf=1,5
39433 DO 160 istep=1,nstep
39434 q2step=q02*(q2/q02)**((istep-0.5d0)/nstep)
39435 IF((kf.EQ.4.AND.q2step.LT.pmc**2).OR.
39436 & (kf.EQ.5.AND.q2step.LT.pmb**2)) GOTO 160
39437 CALL pygvmd(0,kf,x,q2,q2step,alam,xpga,vxpga)
39438 facq=aem2pi*(q2step/(q2step+p2))**2*facnor
39439 IF(mod(kf,2).EQ.0) facq=facq*(8d0/9d0)
39440 IF(mod(kf,2).EQ.1) facq=facq*(2d0/9d0)
39441 DO 150 kfl=-5,5
39442 IF(kf.LE.3) xpanl(kfl)=xpanl(kfl)+facq*xpga(kfl)
39443 IF(kf.GE.4) xpanh(kfl)=xpanh(kfl)+facq*xpga(kfl)
39444 IF(kf.LE.3) vxpanl(kfl)=vxpanl(kfl)+facq*vxpga(kfl)
39445 IF(kf.GE.4) vxpanh(kfl)=vxpanh(kfl)+facq*vxpga(kfl)
39446 150 CONTINUE
39447 160 CONTINUE
39448 170 CONTINUE
39449 ENDIF
39450
39451C...Call Bethe-Heitler term expression for charm and bottom.
39452 CALL pygbeh(4,x,q2,p2,pmc**2,xpbh)
39453 xpbeh(4)=xpbh
39454 xpbeh(-4)=xpbh
39455 CALL pygbeh(5,x,q2,p2,pmb**2,xpbh)
39456 xpbeh(5)=xpbh
39457 xpbeh(-5)=xpbh
39458
39459C...For MSbar subtraction call C^gamma term expression for d, u, s.
39460 IF(iset.EQ.2.OR.iset.EQ.4) THEN
39461 CALL pygdir(x,q2,p2,q02,xpga)
39462 DO 180 kfl=-5,5
39463 xpdir(kfl)=xpga(kfl)
39464 180 CONTINUE
39465 ENDIF
39466
39467C...Store result in output array.
39468 DO 190 kfl=-5,5
39469 chsq=1d0/9d0
39470 IF(iabs(kfl).EQ.2.OR.iabs(kfl).EQ.4) chsq=4d0/9d0
39471 xpf2=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)
39472 IF(kfl.NE.0) f2gm=f2gm+chsq*xpf2
39473 xpdfgm(kfl)=xpvmd(kfl)+xpanl(kfl)+xpanh(kfl)
39474 vxpdgm(kfl)=vxpvmd(kfl)+vxpanl(kfl)+vxpanh(kfl)
39475 190 CONTINUE
39476
39477 RETURN
39478 END
39479
39480C*********************************************************************
39481
39482C...PYGVMD
39483C...Evaluates the VMD parton distributions of a photon,
39484C...evolved homogeneously from an initial scale P2 to Q2.
39485C...Does not include dipole suppression factor.
39486C...ISET is parton distribution set, see above;
39487C...additionally ISET=0 is used for the evolution of an anomalous photon
39488C...which branched at a scale P2 and then evolved homogeneously to Q2.
39489C...ALAM is the 4-flavour Lambda, which is automatically converted
39490C...to 3- and 5-flavour equivalents as needed.
39491C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39492
39493 SUBROUTINE pygvmd(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39494
39495C...Double precision and integer declarations.
39496 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39497 IMPLICIT INTEGER(I-N)
39498 INTEGER PYK,PYCHGE,PYCOMP
39499C...Local arrays and data.
39500 dimension xpga(-6:6), vxpga(-6:6)
39501 DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
39502
39503C...Reset output.
39504 DO 100 kfl=-6,6
39505 xpga(kfl)=0d0
39506 vxpga(kfl)=0d0
39507 100 CONTINUE
39508 kfa=iabs(kf)
39509
39510C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39511 alam3=alam*(pmc/alam)**(2d0/27d0)
39512 alam5=alam*(alam/pmb)**(2d0/23d0)
39513 p2eff=max(p2,1.2d0*alam3**2)
39514 IF(kfa.EQ.4) p2eff=max(p2eff,pmc**2)
39515 IF(kfa.EQ.5) p2eff=max(p2eff,pmb**2)
39516 q2eff=max(q2,p2eff)
39517
39518C...Find number of flavours at lower and upper scale.
39519 nfp=4
39520 IF(p2eff.LT.pmc**2) nfp=3
39521 IF(p2eff.GT.pmb**2) nfp=5
39522 nfq=4
39523 IF(q2eff.LT.pmc**2) nfq=3
39524 IF(q2eff.GT.pmb**2) nfq=5
39525
39526C...Find s as sum of 3-, 4- and 5-flavour parts.
39527 s=0d0
39528 IF(nfp.EQ.3) THEN
39529 q2div=pmc**2
39530 IF(nfq.EQ.3) q2div=q2eff
39531 s=s+(6d0/27d0)*log(log(q2div/alam3**2)/log(p2eff/alam3**2))
39532 ENDIF
39533 IF(nfp.LE.4.AND.nfq.GE.4) THEN
39534 p2div=p2eff
39535 IF(nfp.EQ.3) p2div=pmc**2
39536 q2div=q2eff
39537 IF(nfq.EQ.5) q2div=pmb**2
39538 s=s+(6d0/25d0)*log(log(q2div/alam**2)/log(p2div/alam**2))
39539 ENDIF
39540 IF(nfq.EQ.5) THEN
39541 p2div=pmb**2
39542 IF(nfp.EQ.5) p2div=p2eff
39543 s=s+(6d0/23d0)*log(log(q2eff/alam5**2)/log(p2div/alam5**2))
39544 ENDIF
39545
39546C...Calculate frequent combinations of x and s.
39547 x1=1d0-x
39548 xl=-log(x)
39549 s2=s**2
39550 s3=s**3
39551 s4=s**4
39552
39553C...Evaluate homogeneous anomalous parton distributions below or
39554C...above threshold.
39555 IF(iset.EQ.0) THEN
39556 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39557 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39558 xval = x * 1.5d0 * (x**2+x1**2)
39559 xglu = 0d0
39560 xsea = 0d0
39561 ELSE
39562 xval = (1.5d0/(1d0-0.197d0*s+4.33d0*s2)*x**2 +
39563 & (1.5d0+2.10d0*s)/(1d0+3.29d0*s)*x1**2 +
39564 & 5.23d0*s/(1d0+1.17d0*s+19.9d0*s3)*x*x1) *
39565 & x**(1d0/(1d0+1.5d0*s)) * (1d0-x**2)**(2.667d0*s)
39566 xglu = 4d0*s/(1d0+4.76d0*s+15.2d0*s2+29.3d0*s4) *
39567 & x**(-2.03d0*s/(1d0+2.44d0*s)) * (x1*xl)**(1.333d0*s) *
39568 & ((4d0*x**2+7d0*x+4d0)*x1/3d0 - 2d0*x*(1d0+x)*xl)
39569 xsea = s2/(1d0+4.54d0*s+8.19d0*s2+8.05d0*s3) *
39570 & x**(-1.54d0*s/(1d0+1.29d0*s)) * x1**(2.667d0*s) *
39571 & ((8d0-73d0*x+62d0*x**2)*x1/9d0 + (3d0-8d0*x**2/3d0)*x*xl +
39572 & (2d0*x-1d0)*x*xl**2)
39573 ENDIF
39574
39575C...Evaluate set 1D parton distributions below or above threshold.
39576 ELSEIF(iset.EQ.1) THEN
39577 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39578 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39579 xval = 1.294d0 * x**0.80d0 * x1**0.76d0
39580 xglu = 1.273d0 * x**0.40d0 * x1**1.76d0
39581 xsea = 0.100d0 * x1**3.76d0
39582 ELSE
39583 xval = 1.294d0/(1d0+0.252d0*s+3.079d0*s2) *
39584 & x**(0.80d0-0.13d0*s) * x1**(0.76d0+0.667d0*s) * xl**(2d0*s)
39585 xglu = 7.90d0*s/(1d0+5.50d0*s) * exp(-5.16d0*s) *
39586 & x**(-1.90d0*s/(1d0+3.60d0*s)) * x1**1.30d0 *
39587 & xl**(0.50d0+3d0*s) + 1.273d0 * exp(-10d0*s) *
39588 & x**0.40d0 * x1**(1.76d0+3d0*s)
39589 xsea = (0.1d0-0.397d0*s2+1.121d0*s3)/
39590 & (1d0+5.61d0*s2+5.26d0*s3) * x**(-7.32d0*s2/(1d0+10.3d0*s2)) *
39591 & x1**((3.76d0+15d0*s+12d0*s2)/(1d0+4d0*s))
39592 xsea0 = 0.100d0 * x1**3.76d0
39593 ENDIF
39594
39595C...Evaluate set 1M parton distributions below or above threshold.
39596 ELSEIF(iset.EQ.2) THEN
39597 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39598 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39599 xval = 0.8477d0 * x**0.51d0 * x1**1.37d0
39600 xglu = 3.42d0 * x**0.255d0 * x1**2.37d0
39601 xsea = 0d0
39602 ELSE
39603 xval = 0.8477d0/(1d0+1.37d0*s+2.18d0*s2+3.73d0*s3) *
39604 & x**(0.51d0+0.21d0*s) * x1**1.37d0 * xl**(2.667d0*s)
39605 xglu = 24d0*s/(1d0+9.6d0*s+0.92d0*s2+14.34d0*s3) *
39606 & exp(-5.94d0*s) * x**((-0.013d0-1.80d0*s)/(1d0+3.14d0*s)) *
39607 & x1**(2.37d0+0.4d0*s) * xl**(0.32d0+3.6d0*s) + 3.42d0 *
39608 & exp(-12d0*s) * x**0.255d0 * x1**(2.37d0+3d0*s)
39609 xsea = 0.842d0*s/(1d0+21.3d0*s-33.2d0*s2+229d0*s3) *
39610 & x**((0.13d0-2.90d0*s)/(1d0+5.44d0*s)) * x1**(3.45d0+0.5d0*s) *
39611 & xl**(2.8d0*s)
39612 xsea0 = 0d0
39613 ENDIF
39614
39615C...Evaluate set 2D parton distributions below or above threshold.
39616 ELSEIF(iset.EQ.3) THEN
39617 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39618 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39619 xval = x**0.46d0 * x1**0.64d0 + 0.76d0 * x
39620 xglu = 1.925d0 * x1**2
39621 xsea = 0.242d0 * x1**4
39622 ELSE
39623 xval = (1d0+0.186d0*s)/(1d0-0.209d0*s+1.495d0*s2) *
39624 & x**(0.46d0+0.25d0*s) *
39625 & x1**((0.64d0+0.14d0*s+5d0*s2)/(1d0+s)) * xl**(1.9d0*s) +
39626 & (0.76d0+0.4d0*s) * x * x1**(2.667d0*s)
39627 xglu = (1.925d0+5.55d0*s+147d0*s2)/(1d0-3.59d0*s+3.32d0*s2) *
39628 & exp(-18.67d0*s) *
39629 & x**((-5.81d0*s-5.34d0*s2)/(1d0+29d0*s-4.26d0*s2))
39630 & * x1**((2d0-5.9d0*s)/(1d0+1.7d0*s)) *
39631 & xl**(9.3d0*s/(1d0+1.7d0*s))
39632 xsea = (0.242d0-0.252d0*s+1.19d0*s2)/
39633 & (1d0-0.607d0*s+21.95d0*s2) *
39634 & x**(-12.1d0*s2/(1d0+2.62d0*s+16.7d0*s2)) * x1**4 * xl**s
39635 xsea0 = 0.242d0 * x1**4
39636 ENDIF
39637
39638C...Evaluate set 2M parton distributions below or above threshold.
39639 ELSEIF(iset.EQ.4) THEN
39640 IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.
39641 & (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN
39642 xval = 1.168d0 * x**0.50d0 * x1**2.60d0 + 0.965d0 * x
39643 xglu = 1.808d0 * x1**2
39644 xsea = 0.209d0 * x1**4
39645 ELSE
39646 xval = (1.168d0+1.771d0*s+29.35d0*s2) * exp(-5.776d0*s) *
39647 & x**((0.5d0+0.208d0*s)/(1d0-0.794d0*s+1.516d0*s2)) *
39648 & x1**((2.6d0+7.6d0*s)/(1d0+5d0*s)) *
39649 & xl**(5.15d0*s/(1d0+2d0*s)) +
39650 & (0.965d0+22.35d0*s)/(1d0+18.4d0*s) * x * x1**(2.667d0*s)
39651 xglu = (1.808d0+29.9d0*s)/(1d0+26.4d0*s) * exp(-5.28d0*s) *
39652 & x**((-5.35d0*s-10.11d0*s2)/(1d0+31.71d0*s)) *
39653 & x1**((2d0-7.3d0*s+4d0*s2)/(1d0+2.5d0*s)) *
39654 & xl**(10.9d0*s/(1d0+2.5d0*s))
39655 xsea = (0.209d0+0.644d0*s2)/(1d0+0.319d0*s+17.6d0*s2) *
39656 & x**((-0.373d0*s-7.71d0*s2)/(1d0+0.815d0*s+11.0d0*s2)) *
39657 & x1**(4d0+s) * xl**(0.45d0*s)
39658 xsea0 = 0.209d0 * x1**4
39659 ENDIF
39660 ENDIF
39661
39662C...Threshold factors for c and b sea.
39663 sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
39664 xchm=0d0
39665 IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
39666 sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
39667 IF(iset.EQ.0) THEN
39668 xchm=xsea*(1d0-(sch/sll)**2)
39669 ELSE
39670 xchm=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sch/sll)
39671 ENDIF
39672 ENDIF
39673 xbot=0d0
39674 IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
39675 sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
39676 IF(iset.EQ.0) THEN
39677 xbot=xsea*(1d0-(sbt/sll)**2)
39678 ELSE
39679 xbot=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sbt/sll)
39680 ENDIF
39681 ENDIF
39682
39683C...Fill parton distributions.
39684 xpga(0)=xglu
39685 xpga(1)=xsea
39686 xpga(2)=xsea
39687 xpga(3)=xsea
39688 xpga(4)=xchm
39689 xpga(5)=xbot
39690 xpga(kfa)=xpga(kfa)+xval
39691 DO 110 kfl=1,5
39692 xpga(-kfl)=xpga(kfl)
39693 110 CONTINUE
39694 vxpga(kfa)=xval
39695 vxpga(-kfa)=xval
39696
39697 RETURN
39698 END
39699
39700C*********************************************************************
39701
39702C...PYGANO
39703C...Evaluates the parton distributions of the anomalous photon,
39704C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39705C...KF=0 gives the sum over (up to) 5 flavours,
39706C...KF<0 limits to flavours up to abs(KF),
39707C...KF>0 is for flavour KF only.
39708C...ALAM is the 4-flavour Lambda, which is automatically converted
39709C...to 3- and 5-flavour equivalents as needed.
39710C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39711
39712 SUBROUTINE pygano(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39713
39714C...Double precision and integer declarations.
39715 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39716 IMPLICIT INTEGER(I-N)
39717 INTEGER PYK,PYCHGE,PYCOMP
39718C...Local arrays and data.
39719 dimension xpga(-6:6), vxpga(-6:6), alamsq(3:5)
39720 DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/
39721
39722C...Reset output.
39723 DO 100 kfl=-6,6
39724 xpga(kfl)=0d0
39725 vxpga(kfl)=0d0
39726 100 CONTINUE
39727 IF(q2.LE.p2) RETURN
39728 kfa=iabs(kf)
39729
39730C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39731 alamsq(3)=(alam*(pmc/alam)**(2d0/27d0))**2
39732 alamsq(4)=alam**2
39733 alamsq(5)=(alam*(alam/pmb)**(2d0/23d0))**2
39734 p2eff=max(p2,1.2d0*alamsq(3))
39735 IF(kf.EQ.4) p2eff=max(p2eff,pmc**2)
39736 IF(kf.EQ.5) p2eff=max(p2eff,pmb**2)
39737 q2eff=max(q2,p2eff)
39738 xl=-log(x)
39739
39740C...Find number of flavours at lower and upper scale.
39741 nfp=4
39742 IF(p2eff.LT.pmc**2) nfp=3
39743 IF(p2eff.GT.pmb**2) nfp=5
39744 nfq=4
39745 IF(q2eff.LT.pmc**2) nfq=3
39746 IF(q2eff.GT.pmb**2) nfq=5
39747
39748C...Define range of flavour loop.
39749 IF(kf.EQ.0) THEN
39750 kflmn=1
39751 kflmx=5
39752 ELSEIF(kf.LT.0) THEN
39753 kflmn=1
39754 kflmx=kfa
39755 ELSE
39756 kflmn=kfa
39757 kflmx=kfa
39758 ENDIF
39759
39760C...Loop over flavours the photon can branch into.
39761 DO 110 kfl=kflmn,kflmx
39762
39763C...Light flavours: calculate t range and (approximate) s range.
39764 IF(kfl.LE.3.AND.(kfl.EQ.1.OR.kfl.EQ.kf)) THEN
39765 tdiff=log(q2eff/p2eff)
39766 s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
39767 & log(p2eff/alamsq(nfq)))
39768 IF(nfq.GT.nfp) THEN
39769 q2div=pmb**2
39770 IF(nfq.EQ.4) q2div=pmc**2
39771 snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
39772 & log(p2eff/alamsq(nfq)))
39773 snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
39774 & log(p2eff/alamsq(nfq-1)))
39775 s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
39776 ENDIF
39777 IF(nfq.EQ.5.AND.nfp.EQ.3) THEN
39778 q2div=pmc**2
39779 snf4=(6d0/(33d0-2d0*4))*log(log(q2div/alamsq(4))/
39780 & log(p2eff/alamsq(4)))
39781 snf3=(6d0/(33d0-2d0*3))*log(log(q2div/alamsq(3))/
39782 & log(p2eff/alamsq(3)))
39783 s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snf3-snf4)
39784 ENDIF
39785
39786C...u and s quark do not need a separate treatment when d has been done.
39787 ELSEIF(kfl.EQ.2.OR.kfl.EQ.3) THEN
39788
39789C...Charm: as above, but only include range above c threshold.
39790 ELSEIF(kfl.EQ.4) THEN
39791 IF(q2.LE.pmc**2) GOTO 110
39792 p2eff=max(p2eff,pmc**2)
39793 q2eff=max(q2eff,p2eff)
39794 tdiff=log(q2eff/p2eff)
39795 s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
39796 & log(p2eff/alamsq(nfq)))
39797 IF(nfq.EQ.5.AND.nfp.EQ.4) THEN
39798 q2div=pmb**2
39799 snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/
39800 & log(p2eff/alamsq(nfq)))
39801 snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/
39802 & log(p2eff/alamsq(nfq-1)))
39803 s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)
39804 ENDIF
39805
39806C...Bottom: as above, but only include range above b threshold.
39807 ELSEIF(kfl.EQ.5) THEN
39808 IF(q2.LE.pmb**2) GOTO 110
39809 p2eff=max(p2eff,pmb**2)
39810 q2eff=max(q2,p2eff)
39811 tdiff=log(q2eff/p2eff)
39812 s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/
39813 & log(p2eff/alamsq(nfq)))
39814 ENDIF
39815
39816C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39817 chsq=1d0/9d0
39818 IF(kfl.EQ.2.OR.kfl.EQ.4) chsq=4d0/9d0
39819 fac=aem2pi*2d0*chsq*tdiff
39820
39821C...Evaluate parton distributions (normalized to unit momentum sum).
39822 IF(kfl.EQ.1.OR.kfl.EQ.4.OR.kfl.EQ.5.OR.kfl.EQ.kf) THEN
39823 xval= ((1.5d0+2.49d0*s+26.9d0*s**2)/(1d0+32.3d0*s**2)*x**2 +
39824 & (1.5d0-0.49d0*s+7.83d0*s**2)/(1d0+7.68d0*s**2)*(1d0-x)**2 +
39825 & 1.5d0*s/(1d0-3.2d0*s+7d0*s**2)*x*(1d0-x)) *
39826 & x**(1d0/(1d0+0.58d0*s)) * (1d0-x**2)**(2.5d0*s/(1d0+10d0*s))
39827 xglu= 2d0*s/(1d0+4d0*s+7d0*s**2) *
39828 & x**(-1.67d0*s/(1d0+2d0*s)) * (1d0-x**2)**(1.2d0*s) *
39829 & ((4d0*x**2+7d0*x+4d0)*(1d0-x)/3d0 - 2d0*x*(1d0+x)*xl)
39830 xsea= 0.333d0*s**2/(1d0+4.90d0*s+4.69d0*s**2+21.4d0*s**3) *
39831 & x**(-1.18d0*s/(1d0+1.22d0*s)) * (1d0-x)**(1.2d0*s) *
39832 & ((8d0-73d0*x+62d0*x**2)*(1d0-x)/9d0 +
39833 & (3d0-8d0*x**2/3d0)*x*xl + (2d0*x-1d0)*x*xl**2)
39834
39835C...Threshold factors for c and b sea.
39836 sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))
39837 xchm=0d0
39838 IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN
39839 sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))
39840 xchm=xsea*(1d0-(sch/sll)**3)
39841 ENDIF
39842 xbot=0d0
39843 IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN
39844 sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))
39845 xbot=xsea*(1d0-(sbt/sll)**3)
39846 ENDIF
39847 ENDIF
39848
39849C...Add contribution of each valence flavour.
39850 xpga(0)=xpga(0)+fac*xglu
39851 xpga(1)=xpga(1)+fac*xsea
39852 xpga(2)=xpga(2)+fac*xsea
39853 xpga(3)=xpga(3)+fac*xsea
39854 xpga(4)=xpga(4)+fac*xchm
39855 xpga(5)=xpga(5)+fac*xbot
39856 xpga(kfl)=xpga(kfl)+fac*xval
39857 vxpga(kfl)=vxpga(kfl)+fac*xval
39858 110 CONTINUE
39859 DO 120 kfl=1,5
39860 xpga(-kfl)=xpga(kfl)
39861 vxpga(-kfl)=vxpga(kfl)
39862 120 CONTINUE
39863
39864 RETURN
39865 END
39866
39867
39868C*********************************************************************
39869
39870C...PYGBEH
39871C...Evaluates the Bethe-Heitler cross section for heavy flavour
39872C...production.
39873C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39874
39875 SUBROUTINE pygbeh(KF,X,Q2,P2,PM2,XPBH)
39876
39877C...Double precision and integer declarations.
39878 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39879 IMPLICIT INTEGER(I-N)
39880 INTEGER PYK,PYCHGE,PYCOMP
39881
39882C...Local data.
39883 DATA aem2pi/0.0011614d0/
39884
39885C...Reset output.
39886 xpbh=0d0
39887 sigbh=0d0
39888
39889C...Check kinematics limits.
39890 IF(x.GE.q2/(4d0*pm2+q2+p2)) RETURN
39891 w2=q2*(1d0-x)/x-p2
39892 beta2=1d0-4d0*pm2/w2
39893 IF(beta2.LT.1d-10) RETURN
39894 beta=sqrt(beta2)
39895 rmq=4d0*pm2/q2
39896
39897C...Simple case: P2 = 0.
39898 IF(p2.LT.1d-4) THEN
39899 IF(beta.LT.0.99d0) THEN
39900 xbl=log((1d0+beta)/(1d0-beta))
39901 ELSE
39902 xbl=log((1d0+beta)**2*w2/(4d0*pm2))
39903 ENDIF
39904 sigbh=beta*(8d0*x*(1d0-x)-1d0-rmq*x*(1d0-x))+
39905 & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)
39906
39907C...Complicated case: P2 > 0, based on approximation of
39908C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
39909 ELSE
39910 rpq=1d0-4d0*x**2*p2/q2
39911 IF(rpq.GT.1d-10) THEN
39912 rpbe=sqrt(rpq*beta2)
39913 IF(rpbe.LT.0.99d0) THEN
39914 xbl=log((1d0+rpbe)/(1d0-rpbe))
39915 xbi=2d0*rpbe/(1d0-rpbe**2)
39916 ELSE
39917 rpbesn=4d0*pm2/w2+(4d0*x**2*p2/q2)*beta2
39918 xbl=log((1d0+rpbe)**2/rpbesn)
39919 xbi=2d0*rpbe/rpbesn
39920 ENDIF
39921 sigbh=beta*(6d0*x*(1d0-x)-1d0)+
39922 & xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)+
39923 & xbi*(2d0*x/q2)*(pm2*x*(2d0-rmq)-p2*x)
39924 ENDIF
39925 ENDIF
39926
39927C...Multiply by charge-squared etc. to get parton distribution.
39928 chsq=1d0/9d0
39929 IF(iabs(kf).EQ.2.OR.iabs(kf).EQ.4) chsq=4d0/9d0
39930 xpbh=3d0*chsq*aem2pi*x*sigbh
39931
39932 RETURN
39933 END
39934
39935C*********************************************************************
39936
39937C...PYGDIR
39938C...Evaluates the direct contribution, i.e. the C^gamma term,
39939C...as needed in MSbar parametrizations.
39940C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39941
39942 SUBROUTINE pygdir(X,Q2,P2,Q02,XPGA)
39943
39944C...Double precision and integer declarations.
39945 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39946 IMPLICIT INTEGER(I-N)
39947 INTEGER PYK,PYCHGE,PYCOMP
39948C...Local array and data.
39949 dimension xpga(-6:6)
39950 DATA pmc/1.3d0/, pmb/4.6d0/, aem2pi/0.0011614d0/
39951
39952C...Reset output.
39953 DO 100 kfl=-6,6
39954 xpga(kfl)=0d0
39955 100 CONTINUE
39956
39957C...Evaluate common x-dependent expression.
39958 xtmp = (x**2+(1d0-x)**2) * (-log(x)) - 1d0
39959 cgam = 3d0*aem2pi*x * (xtmp*(1d0+p2/(p2+q02)) + 6d0*x*(1d0-x))
39960
39961C...d, u, s part by simple charge factor.
39962 xpga(1)=(1d0/9d0)*cgam
39963 xpga(2)=(4d0/9d0)*cgam
39964 xpga(3)=(1d0/9d0)*cgam
39965
39966C...Also fill for antiquarks.
39967 DO 110 kf=1,5
39968 xpga(-kf)=xpga(kf)
39969 110 CONTINUE
39970
39971 RETURN
39972 END
39973
39974C*********************************************************************
39975
39976C...PYPDPI
39977C...Gives pi+ parton distribution according to two different
39978C...parametrizations.
39979
39980 SUBROUTINE pypdpi(X,Q2,XPPI)
39981
39982C...Double precision and integer declarations.
39983 IMPLICIT DOUBLE PRECISION(a-h, o-z)
39984 IMPLICIT INTEGER(I-N)
39985 INTEGER PYK,PYCHGE,PYCOMP
39986C...Commonblocks.
39987 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
39988 common/pypars/mstp(200),parp(200),msti(200),pari(200)
39989 common/pyint1/mint(400),vint(400)
39990 SAVE /pydat1/,/pypars/,/pyint1/
39991C...Local arrays.
39992 dimension xppi(-6:6),cow(3,5,4,2),xq(9),ts(6)
39993
39994C...The following data lines are coefficients needed in the
39995C...Owens pion parton distribution parametrizations, see below.
39996C...Expansion coefficients for up and down valence quark distributions.
39997 DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/
39998 &4.0000d-01, 7.0000d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
39999 &-6.2120d-02, 6.4780d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40000 &-7.1090d-03, 1.3350d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
40001 DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/
40002 &4.0000d-01, 6.2800d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40003 &-5.9090d-02, 6.4360d-01, 0.0000d+00, 0.0000d+00, 0.0000d+00,
40004 &-6.5240d-03, 1.4510d-02, 0.0000d+00, 0.0000d+00, 0.0000d+00/
40005C...Expansion coefficients for gluon distribution.
40006 DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/
40007 &8.8800d-01, 0.0000d+00, 3.1100d+00, 6.0000d+00, 0.0000d+00,
40008 &-1.8020d+00, -1.5760d+00, -1.3170d-01, 2.8010d+00, -1.7280d+01,
40009 &1.8120d+00, 1.2000d+00, 5.0680d-01, -1.2160d+01, 2.0490d+01/
40010 DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/
40011 &7.9400d-01, 0.0000d+00, 2.8900d+00, 6.0000d+00, 0.0000d+00,
40012 &-9.1440d-01, -1.2370d+00, 5.9660d-01, -3.6710d+00, -8.1910d+00,
40013 &5.9660d-01, 6.5820d-01, -2.5500d-01, -2.3040d+00, 7.7580d+00/
40014C...Expansion coefficients for (up+down+strange) quark sea distribution.
40015 DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/
40016 &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
40017 &-2.4280d-01, -2.1200d-01, 8.6730d-01, 1.2660d+00, 2.3820d+00,
40018 &1.3860d-01, 3.6710d-03, 4.7470d-02, -2.2150d+00, 3.4820d-01/
40019 DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/
40020 &9.0000d-01, 0.0000d+00, 5.0000d+00, 0.0000d+00, 0.0000d+00,
40021 &-1.4170d-01, -1.6970d-01, -2.4740d+00, -2.5340d+00, 5.6210d-01,
40022 &-1.7400d-01, -9.6230d-02, 1.5750d+00, 1.3780d+00, -2.7010d-01/
40023C...Expansion coefficients for charm quark sea distribution.
40024 DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/
40025 &0.0000d+00, -2.2120d-02, 2.8940d+00, 0.0000d+00, 0.0000d+00,
40026 &7.9280d-02, -3.7850d-01, 9.4330d+00, 5.2480d+00, 8.3880d+00,
40027 &-6.1340d-02, -1.0880d-01, -1.0852d+01, -7.1870d+00, -1.1610d+01/
40028 DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/
40029 &0.0000d+00, -8.8200d-02, 1.9240d+00, 0.0000d+00, 0.0000d+00,
40030 &6.2290d-02, -2.8920d-01, 2.4240d-01, -4.4630d+00, -8.3670d-01,
40031 &-4.0990d-02, -1.0820d-01, 2.0360d+00, 5.2090d+00, -4.8400d-02/
40032
40033C...Euler's beta function, requires ordinary Gamma function
40034 eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
40035
40036C...Reset output array.
40037 DO 100 kfl=-6,6
40038 xppi(kfl)=0d0
40039 100 CONTINUE
40040
40041 IF(mstp(53).LE.2) THEN
40042C...Pion parton distributions from Owens.
40043C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40044
40045C...Determine set, Lambda and s expansion variable.
40046 nset=mstp(53)
40047 IF(nset.EQ.1) alam=0.2d0
40048 IF(nset.EQ.2) alam=0.4d0
40049 vint(231)=4d0
40050 IF(mstp(57).LE.0) THEN
40051 sd=0d0
40052 ELSE
40053 q2in=min(2d3,max(4d0,q2))
40054 sd=log(log(q2in/alam**2)/log(4d0/alam**2))
40055 ENDIF
40056
40057C...Calculate parton distributions.
40058 DO 120 kfl=1,4
40059 DO 110 is=1,5
40060 ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+
40061 & cow(3,is,kfl,nset)*sd**2
40062 110 CONTINUE
40063 IF(kfl.EQ.1) THEN
40064 xq(kfl)=x**ts(1)*(1d0-x)**ts(2)/eulbet(ts(1),ts(2)+1d0)
40065 ELSE
40066 xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
40067 & ts(5)*x**2)
40068 ENDIF
40069 120 CONTINUE
40070
40071C...Put into output array.
40072 xppi(0)=xq(2)
40073 xppi(1)=xq(3)/6d0
40074 xppi(2)=xq(1)+xq(3)/6d0
40075 xppi(3)=xq(3)/6d0
40076 xppi(4)=xq(4)
40077 xppi(-1)=xq(1)+xq(3)/6d0
40078 xppi(-2)=xq(3)/6d0
40079 xppi(-3)=xq(3)/6d0
40080 xppi(-4)=xq(4)
40081
40082C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40083C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40084C...10^-5 < x < 1.
40085 ELSE
40086
40087C...Determine s expansion variable and some x expressions.
40088 vint(231)=0.25d0
40089 IF(mstp(57).LE.0) THEN
40090 sd=0d0
40091 ELSE
40092 q2in=min(1d8,max(0.25d0,q2))
40093 sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
40094 ENDIF
40095 sd2=sd**2
40096 xl=-log(x)
40097 xs=sqrt(x)
40098
40099C...Evaluate valence, gluon and sea distributions.
40100 xfval=(0.519d0+0.180d0*sd-0.011d0*sd2)*x**(0.499d0-0.027d0*sd)*
40101 & (1d0+(0.381d0-0.419d0*sd)*xs)*(1d0-x)**(0.367d0+0.563d0*sd)
40102 xfglu=(x**(0.482d0+0.341d0*sqrt(sd))*((0.678d0+0.877d0*
40103 & sd-0.175d0*sd2)+
40104 & (0.338d0-1.597d0*sd)*xs+(-0.233d0*sd+0.406d0*sd2)*x)+
40105 & sd**0.599d0*exp(-(0.618d0+2.070d0*sd)+sqrt(3.676d0*sd**1.263d0*
40106 & xl)))*
40107 & (1d0-x)**(0.390d0+1.053d0*sd)
40108 xfsea=sd**0.55d0*(1d0-0.748d0*xs+(0.313d0+0.935d0*sd)*x)*(1d0-
40109 & x)**3.359d0*
40110 & exp(-(4.433d0+1.301d0*sd)+sqrt((9.30d0-0.887d0*sd)*sd**0.56d0*
40111 & xl))/
40112 & xl**(2.538d0-0.763d0*sd)
40113 IF(sd.LE.0.888d0) THEN
40114 xfchm=0d0
40115 ELSE
40116 xfchm=(sd-0.888d0)**1.02d0*(1d0+1.008d0*x)*(1d0-x)**(1.208d0+
40117 & 0.771d0*sd)*
40118 & exp(-(4.40d0+1.493d0*sd)+sqrt((2.032d0+1.901d0*sd)*sd**0.39d0*
40119 & xl))
40120 ENDIF
40121 IF(sd.LE.1.351d0) THEN
40122 xfbot=0d0
40123 ELSE
40124 xfbot=(sd-1.351d0)**1.03d0*(1d0-x)**(0.697d0+0.855d0*sd)*
40125 & exp(-(4.51d0+1.490d0*sd)+sqrt((3.056d0+1.694d0*sd)*sd**0.39d0*
40126 & xl))
40127 ENDIF
40128
40129C...Put into output array.
40130 xppi(0)=xfglu
40131 xppi(1)=xfsea
40132 xppi(2)=xfsea
40133 xppi(3)=xfsea
40134 xppi(4)=xfchm
40135 xppi(5)=xfbot
40136 DO 130 kfl=1,5
40137 xppi(-kfl)=xppi(kfl)
40138 130 CONTINUE
40139 xppi(2)=xppi(2)+xfval
40140 xppi(-1)=xppi(-1)+xfval
40141 ENDIF
40142
40143 RETURN
40144 END
40145
40146C*********************************************************************
40147
40148C...PYPDPR
40149C...Gives proton parton distributions according to a few different
40150C...parametrizations.
40151
40152 SUBROUTINE pypdpr(X,Q2,XPPR)
40153
40154C...Double precision and integer declarations.
40155 IMPLICIT DOUBLE PRECISION(a-h, o-z)
40156 IMPLICIT INTEGER(I-N)
40157 INTEGER PYK,PYCHGE,PYCOMP
40158C...Commonblocks.
40159 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
40160 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
40161 common/pypars/mstp(200),parp(200),msti(200),pari(200)
40162 common/pyint1/mint(400),vint(400)
40163 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
40164C...Arrays and data.
40165 dimension xppr(-6:6),q2min(16)
40166 DATA q2min/ 2.56d0, 2.56d0, 2.56d0, 0.4d0, 0.4d0, 0.4d0,
40167 &1.0d0, 1.0d0, 2*0d0, 0.25d0, 5d0, 5d0, 4d0, 4d0, 0d0/
40168
40169C...Reset output array.
40170 DO 100 kfl=-6,6
40171 xppr(kfl)=0d0
40172 100 CONTINUE
40173
40174C...Common preliminaries.
40175 nset=max(1,min(16,mstp(51)))
40176 IF(nset.EQ.9.OR.nset.EQ.10) nset=6
40177 vint(231)=q2min(nset)
40178 IF(mstp(57).EQ.0) THEN
40179 q2l=q2min(nset)
40180 ELSE
40181 q2l=max(q2min(nset),q2)
40182 ENDIF
40183
40184 IF(nset.GE.1.AND.nset.LE.3) THEN
40185C...Interface to the CTEQ 3 parton distributions.
40186 qrt=sqrt(max(1d0,q2l))
40187
40188C...Loop over flavours.
40189 DO 110 i=-6,6
40190 IF(i.LE.0) THEN
40191 xppr(i)=pycteq(nset,i,x,qrt)
40192 ELSEIF(i.LE.2) THEN
40193 xppr(i)=pycteq(nset,i,x,qrt)+xppr(-i)
40194 ELSE
40195 xppr(i)=xppr(-i)
40196 ENDIF
40197 110 CONTINUE
40198
40199 ELSEIF(nset.GE.4.AND.nset.LE.6) THEN
40200C...Interface to the GRV 94 distributions.
40201 IF(nset.EQ.4) THEN
40202 CALL pygrvl (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
40203 ELSEIF(nset.EQ.5) THEN
40204 CALL pygrvm (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
40205 ELSE
40206 CALL pygrvd (x, q2l, uv, dv, del, udb, sb, chm, bot, gl)
40207 ENDIF
40208
40209C...Put into output array.
40210 xppr(0)=gl
40211 xppr(-1)=0.5d0*(udb+del)
40212 xppr(-2)=0.5d0*(udb-del)
40213 xppr(-3)=sb
40214 xppr(-4)=chm
40215 xppr(-5)=bot
40216 xppr(1)=dv+xppr(-1)
40217 xppr(2)=uv+xppr(-2)
40218 xppr(3)=sb
40219 xppr(4)=chm
40220 xppr(5)=bot
40221
40222 ELSEIF(nset.EQ.7) THEN
40223C...Interface to the CTEQ 5L parton distributions.
40224C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40225C...freezing x*f(x,Q2) at borders.
40226 qrt=sqrt(max(1d0,min(1d8,q2l)))
40227 xin=max(1d-6,min(1d0,x))
40228
40229C...Loop over flavours (with u <-> d notation mismatch).
40230 sumudb=pyct5l(-1,xin,qrt)
40231 ratudb=pyct5l(-2,xin,qrt)
40232 DO 120 i=-5,2
40233 IF(i.EQ.1) THEN
40234 xppr(i)=xin*pyct5l(2,xin,qrt)
40235 ELSEIF(i.EQ.2) THEN
40236 xppr(i)=xin*pyct5l(1,xin,qrt)
40237 ELSEIF(i.EQ.-1) THEN
40238 xppr(i)=xin*sumudb*ratudb/(1d0+ratudb)
40239 ELSEIF(i.EQ.-2) THEN
40240 xppr(i)=xin*sumudb/(1d0+ratudb)
40241 ELSE
40242 xppr(i)=xin*pyct5l(i,xin,qrt)
40243 IF(i.LT.0) xppr(-i)=xppr(i)
40244 ENDIF
40245 120 CONTINUE
40246
40247 ELSEIF(nset.EQ.8) THEN
40248C...Interface to the CTEQ 5M1 parton distributions.
40249 qrt=sqrt(max(1d0,min(1d8,q2l)))
40250 xin=max(1d-6,min(1d0,x))
40251
40252C...Loop over flavours (with u <-> d notation mismatch).
40253 sumudb=pyct5m(-1,xin,qrt)
40254 ratudb=pyct5m(-2,xin,qrt)
40255 DO 130 i=-5,2
40256 IF(i.EQ.1) THEN
40257 xppr(i)=xin*pyct5m(2,xin,qrt)
40258 ELSEIF(i.EQ.2) THEN
40259 xppr(i)=xin*pyct5m(1,xin,qrt)
40260 ELSEIF(i.EQ.-1) THEN
40261 xppr(i)=xin*sumudb*ratudb/(1d0+ratudb)
40262 ELSEIF(i.EQ.-2) THEN
40263 xppr(i)=xin*sumudb/(1d0+ratudb)
40264 ELSE
40265 xppr(i)=xin*pyct5m(i,xin,qrt)
40266 IF(i.LT.0) xppr(-i)=xppr(i)
40267 ENDIF
40268 130 CONTINUE
40269
40270 ELSEIF(nset.GE.11.AND.nset.LE.15) THEN
40271C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40272C...obsolete but offers backwards compatibility.
40273 CALL pypdpo(x,q2l,xppr)
40274
40275C...Symmetric choice for debugging only
40276 ELSEIF(nset.EQ.16) THEN
40277 xppr(0)=.5d0/x
40278 xppr(1)=.05d0/x
40279 xppr(2)=.05d0/x
40280 xppr(3)=.05d0/x
40281 xppr(4)=.05d0/x
40282 xppr(5)=.05d0/x
40283 xppr(-1)=.05d0/x
40284 xppr(-2)=.05d0/x
40285 xppr(-3)=.05d0/x
40286 xppr(-4)=.05d0/x
40287 xppr(-5)=.05d0/x
40288
40289 ENDIF
40290
40291 RETURN
40292 END
40293
40294C*********************************************************************
40295
40296C...PYCTEQ
40297C...Gives the CTEQ 3 parton distribution function sets in
40298C...parametrized form, of October 24, 1994.
40299C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40300C...J. Qiu, W.K. Tung and H. Weerts.
40301
40302 FUNCTION pycteq (ISET, IPRT, X, Q)
40303
40304C...Double precision declaration.
40305 IMPLICIT DOUBLE PRECISION(a-h, o-z)
40306 IMPLICIT INTEGER(I-N)
40307
40308C...Data on Lambda values of fits, minimum Q and quark masses.
40309 dimension alm(3), qms(4:6)
40310 DATA alm / 0.177d0, 0.239d0, 0.247d0 /
40311 DATA qmn / 1.60d0 /, (qms(i), i=4,6) / 1.60d0, 5.00d0, 180.0d0 /
40312
40313C....Check flavour thresholds. Set up QI for SB.
40314 ip = iabs(iprt)
40315 IF(ip .GE. 4) THEN
40316 IF(q .LE. qms(ip)) THEN
40317 pycteq = 0d0
40318 RETURN
40319 ENDIF
40320 qi = qms(ip)
40321 ELSE
40322 qi = qmn
40323 ENDIF
40324
40325C...Use "standard lambda" of parametrization program for expansion.
40326 alam = alm(iset)
40327 sbl = log(q/alam) / log(qi/alam)
40328 sb = log(sbl)
40329 sb2 = sb*sb
40330 sb3 = sb2*sb
40331
40332C...Expansion for CTEQ3L.
40333 IF(iset .EQ. 1) THEN
40334 IF(iprt .EQ. 2) THEN
40335 a0=exp( 0.1907d+00+0.4205d-01*sb +0.2752d+00*sb2-
40336 & 0.3171d+00*sb3)
40337 a1= 0.4611d+00+0.2331d-01*sb -0.3403d-01*sb2+0.3174d-01*sb3
40338 a2= 0.3504d+01+0.5739d+00*sb +0.2676d+00*sb2-0.1553d+00*sb3
40339 a3= 0.7452d+01-0.6742d+01*sb +0.2849d+01*sb2-0.1964d+00*sb3
40340 a4= 0.1116d+01-0.3435d+00*sb +0.2865d+00*sb2-0.1288d+00*sb3
40341 a5= 0.6659d-01+0.2714d+00*sb -0.2688d+00*sb2+0.2763d+00*sb3
40342 ELSEIF(iprt .EQ. 1) THEN
40343 a0=exp( 0.1141d+00+0.4764d+00*sb -0.1745d+01*sb2+
40344 & 0.7728d+00*sb3)
40345 a1= 0.4275d+00-0.1290d+00*sb +0.3609d+00*sb2-0.1689d+00*sb3
40346 a2= 0.3000d+01+0.2946d+01*sb -0.4117d+01*sb2+0.1989d+01*sb3
40347 a3=-0.1302d+01+0.2322d+01*sb -0.4258d+01*sb2+0.2109d+01*sb3
40348 a4= 0.2586d+01-0.1920d+00*sb -0.3754d+00*sb2+0.2731d+00*sb3
40349 a5=-0.2251d+00-0.5374d+00*sb +0.2245d+01*sb2-0.1034d+01*sb3
40350 ELSEIF(iprt .EQ. 0) THEN
40351 a0=exp(-0.7631d+00-0.7241d+00*sb -0.1170d+01*sb2+
40352 & 0.5343d+00*sb3)
40353 a1=-0.3573d+00+0.3469d+00*sb -0.3396d+00*sb2+0.9188d-01*sb3
40354 a2= 0.5604d+01+0.7458d+00*sb -0.5082d+00*sb2+0.1844d+00*sb3
40355 a3= 0.1549d+02-0.1809d+02*sb +0.1162d+02*sb2-0.3483d+01*sb3
40356 a4= 0.9881d+00+0.1364d+00*sb -0.4421d+00*sb2+0.2051d+00*sb3
40357 a5=-0.9505d-01+0.3259d+01*sb -0.1547d+01*sb2+0.2918d+00*sb3
40358 ELSEIF(iprt .EQ. -1) THEN
40359 a0=exp(-0.2449d+01-0.3513d+01*sb +0.4529d+01*sb2-
40360 & 0.2031d+01*sb3)
40361 a1=-0.4050d+00+0.3411d+00*sb -0.3669d+00*sb2+0.1109d+00*sb3
40362 a2= 0.7470d+01-0.2982d+01*sb +0.5503d+01*sb2-0.2419d+01*sb3
40363 a3= 0.1503d+02+0.1638d+01*sb -0.8772d+01*sb2+0.3852d+01*sb3
40364 a4= 0.1137d+01-0.1006d+01*sb +0.1485d+01*sb2-0.6389d+00*sb3
40365 a5=-0.5299d+00+0.3160d+01*sb -0.3104d+01*sb2+0.1219d+01*sb3
40366 ELSEIF(iprt .EQ. -2) THEN
40367 a0=exp(-0.2740d+01-0.7987d-01*sb -0.9015d+00*sb2-
40368 & 0.9872d-01*sb3)
40369 a1=-0.3909d+00+0.1244d+00*sb -0.4487d-01*sb2+0.1277d-01*sb3
40370 a2= 0.9163d+01+0.2823d+00*sb -0.7720d+00*sb2-0.9360d-02*sb3
40371 a3= 0.1080d+02-0.3915d+01*sb -0.1153d+01*sb2+0.2649d+01*sb3
40372 a4= 0.9894d+00-0.1647d+00*sb -0.9426d-02*sb2+0.2945d-02*sb3
40373 a5=-0.3395d+00+0.6998d+00*sb +0.7000d+00*sb2-0.6730d-01*sb3
40374 ELSEIF(iprt .EQ. -3) THEN
40375 a0=exp(-0.3640d+01+0.1250d+01*sb -0.2914d+01*sb2+
40376 & 0.8390d+00*sb3)
40377 a1=-0.3595d+00-0.5259d-01*sb +0.3122d+00*sb2-0.1642d+00*sb3
40378 a2= 0.7305d+01+0.9727d+00*sb -0.9788d+00*sb2-0.5193d-01*sb3
40379 a3= 0.1198d+02-0.1799d+02*sb +0.2614d+02*sb2-0.1091d+02*sb3
40380 a4= 0.9882d+00-0.6101d+00*sb +0.9737d+00*sb2-0.4935d+00*sb3
40381 a5=-0.1186d+00-0.3231d+00*sb +0.3074d+01*sb2-0.1274d+01*sb3
40382 ELSEIF(iprt .EQ. -4) THEN
40383 a0=sb** 0.1122d+01*exp(-0.3718d+01-0.1335d+01*sb +
40384 & 0.1651d-01*sb2)
40385 a1=-0.4719d+00+0.7509d+00*sb -0.8420d+00*sb2+0.2901d+00*sb3
40386 a2= 0.6194d+01-0.1641d+01*sb +0.4907d+01*sb2-0.2523d+01*sb3
40387 a3= 0.4426d+01-0.4270d+01*sb +0.6581d+01*sb2-0.3474d+01*sb3
40388 a4= 0.2683d+00+0.9876d+00*sb -0.7612d+00*sb2+0.1780d+00*sb3
40389 a5=-0.4547d+00+0.4410d+01*sb -0.3712d+01*sb2+0.1245d+01*sb3
40390 ELSEIF(iprt .EQ. -5) THEN
40391 a0=sb** 0.9838d+00*exp(-0.2548d+01-0.7660d+01*sb +
40392 & 0.3702d+01*sb2)
40393 a1=-0.3122d+00-0.2120d+00*sb +0.5716d+00*sb2-0.3773d+00*sb3
40394 a2= 0.6257d+01-0.8214d-01*sb -0.2537d+01*sb2+0.2981d+01*sb3
40395 a3=-0.6723d+00+0.2131d+01*sb +0.9599d+01*sb2-0.7910d+01*sb3
40396 a4= 0.9169d-01+0.4295d-01*sb -0.5017d+00*sb2+0.3811d+00*sb3
40397 a5= 0.2402d+00+0.2656d+01*sb -0.1586d+01*sb2+0.2880d+00*sb3
40398 ELSEIF(iprt .EQ. -6) THEN
40399 a0=sb** 0.1001d+01*exp(-0.6934d+01+0.3050d+01*sb -
40400 & 0.6943d+00*sb2)
40401 a1=-0.1713d+00-0.5167d+00*sb +0.1241d+01*sb2-0.1703d+01*sb3
40402 a2= 0.6169d+01+0.3023d+01*sb -0.1972d+02*sb2+0.1069d+02*sb3
40403 a3= 0.4439d+01-0.1746d+02*sb +0.1225d+02*sb2+0.8350d+00*sb3
40404 a4= 0.5458d+00-0.4586d+00*sb +0.9089d+00*sb2-0.4049d+00*sb3
40405 a5= 0.3207d+01-0.3362d+01*sb +0.5877d+01*sb2-0.7659d+01*sb3
40406 ENDIF
40407
40408C...Expansion for CTEQ3M.
40409 ELSEIF(iset .EQ. 2) THEN
40410 IF(iprt .EQ. 2) THEN
40411 a0=exp( 0.2259d+00+0.1237d+00*sb +0.3035d+00*sb2-
40412 & 0.2935d+00*sb3)
40413 a1= 0.5085d+00+0.1651d-01*sb -0.3592d-01*sb2+0.2782d-01*sb3
40414 a2= 0.3732d+01+0.4901d+00*sb +0.2218d+00*sb2-0.1116d+00*sb3
40415 a3= 0.7011d+01-0.6620d+01*sb +0.2557d+01*sb2-0.1360d+00*sb3
40416 a4= 0.8969d+00-0.2429d+00*sb +0.1811d+00*sb2-0.6888d-01*sb3
40417 a5= 0.8636d-01+0.2558d+00*sb -0.3082d+00*sb2+0.2535d+00*sb3
40418 ELSEIF(iprt .EQ. 1) THEN
40419 a0=exp(-0.7266d+00-0.1584d+01*sb +0.1259d+01*sb2-
40420 & 0.4305d-01*sb3)
40421 a1= 0.5285d+00-0.3721d+00*sb +0.5150d+00*sb2-0.1697d+00*sb3
40422 a2= 0.4075d+01+0.8282d+00*sb -0.4496d+00*sb2+0.2107d+00*sb3
40423 a3= 0.3279d+01+0.5066d+01*sb -0.9134d+01*sb2+0.2897d+01*sb3
40424 a4= 0.4399d+00-0.5888d+00*sb +0.4802d+00*sb2-0.1664d+00*sb3
40425 a5= 0.3678d+00-0.8929d+00*sb +0.1592d+01*sb2-0.5713d+00*sb3
40426 ELSEIF(iprt .EQ. 0) THEN
40427 a0=exp(-0.2318d+00-0.9779d+00*sb -0.3783d+00*sb2+
40428 & 0.1037d-01*sb3)
40429 a1=-0.2916d+00+0.1754d+00*sb -0.1884d+00*sb2+0.6116d-01*sb3
40430 a2= 0.5349d+01+0.7460d+00*sb +0.2319d+00*sb2-0.2622d+00*sb3
40431 a3= 0.6920d+01-0.3454d+01*sb +0.2027d+01*sb2-0.7626d+00*sb3
40432 a4= 0.1013d+01+0.1423d+00*sb -0.1798d+00*sb2+0.1872d-01*sb3
40433 a5=-0.5465d-01+0.2303d+01*sb -0.9584d+00*sb2+0.3098d+00*sb3
40434 ELSEIF(iprt .EQ. -1) THEN
40435 a0=exp(-0.2328d+01-0.3061d+01*sb +0.3620d+01*sb2-
40436 & 0.1602d+01*sb3)
40437 a1=-0.3358d+00+0.3198d+00*sb -0.4210d+00*sb2+0.1571d+00*sb3
40438 a2= 0.8478d+01-0.3112d+01*sb +0.5243d+01*sb2-0.2255d+01*sb3
40439 a3= 0.1971d+02+0.3389d+00*sb -0.5268d+01*sb2+0.2099d+01*sb3
40440 a4= 0.1128d+01-0.4701d+00*sb +0.7779d+00*sb2-0.3506d+00*sb3
40441 a5=-0.4708d+00+0.3341d+01*sb -0.3375d+01*sb2+0.1353d+01*sb3
40442 ELSEIF(iprt .EQ. -2) THEN
40443 a0=exp(-0.2906d+01-0.1069d+00*sb -0.1055d+01*sb2+
40444 & 0.2496d+00*sb3)
40445 a1=-0.2875d+00+0.6571d-01*sb -0.1987d-01*sb2-0.1800d-02*sb3
40446 a2= 0.9854d+01-0.2715d+00*sb -0.7407d+00*sb2+0.2888d+00*sb3
40447 a3= 0.1583d+02-0.7687d+01*sb +0.3428d+01*sb2-0.3327d+00*sb3
40448 a4= 0.9763d+00+0.7599d-01*sb -0.2128d+00*sb2+0.6852d-01*sb3
40449 a5=-0.8444d-02+0.9434d+00*sb +0.4152d+00*sb2-0.1481d+00*sb3
40450 ELSEIF(iprt .EQ. -3) THEN
40451 a0=exp(-0.3780d+01+0.2499d+01*sb -0.4962d+01*sb2+
40452 & 0.1936d+01*sb3)
40453 a1=-0.2639d+00-0.1575d+00*sb +0.3584d+00*sb2-0.1646d+00*sb3
40454 a2= 0.8082d+01+0.2794d+01*sb -0.5438d+01*sb2+0.2321d+01*sb3
40455 a3= 0.1811d+02-0.2000d+02*sb +0.1951d+02*sb2-0.6904d+01*sb3
40456 a4= 0.9822d+00+0.4972d+00*sb -0.8690d+00*sb2+0.3415d+00*sb3
40457 a5= 0.1772d+00-0.6078d+00*sb +0.3341d+01*sb2-0.1473d+01*sb3
40458 ELSEIF(iprt .EQ. -4) THEN
40459 a0=sb** 0.1122d+01*exp(-0.4232d+01-0.1808d+01*sb +
40460 & 0.5348d+00*sb2)
40461 a1=-0.2824d+00+0.5846d+00*sb -0.7230d+00*sb2+0.2419d+00*sb3
40462 a2= 0.5683d+01-0.2948d+01*sb +0.5916d+01*sb2-0.2560d+01*sb3
40463 a3= 0.2051d+01+0.4795d+01*sb -0.4271d+01*sb2+0.4174d+00*sb3
40464 a4= 0.1737d+00+0.1717d+01*sb -0.1978d+01*sb2+0.6643d+00*sb3
40465 a5= 0.8689d+00+0.3500d+01*sb -0.3283d+01*sb2+0.1026d+01*sb3
40466 ELSEIF(iprt .EQ. -5) THEN
40467 a0=sb** 0.9906d+00*exp(-0.1496d+01-0.6576d+01*sb +
40468 & 0.1569d+01*sb2)
40469 a1=-0.2140d+00-0.6419d-01*sb -0.2741d-02*sb2+0.3185d-02*sb3
40470 a2= 0.5781d+01+0.1049d+00*sb -0.3930d+00*sb2+0.5174d+00*sb3
40471 a3=-0.9420d+00+0.5511d+00*sb +0.8817d+00*sb2+0.1903d+01*sb3
40472 a4= 0.2418d-01+0.4232d-01*sb -0.1244d-01*sb2-0.2365d-01*sb3
40473 a5= 0.7664d+00+0.1794d+01*sb -0.4917d+00*sb2-0.1284d+00*sb3
40474 ELSEIF(iprt .EQ. -6) THEN
40475 a0=sb** 0.1000d+01*exp(-0.8460d+01+0.1154d+01*sb +
40476 & 0.8838d+01*sb2)
40477 a1=-0.4316d-01-0.2976d+00*sb +0.3174d+00*sb2-0.1429d+01*sb3
40478 a2= 0.4910d+01+0.2273d+01*sb +0.5631d+01*sb2-0.1994d+02*sb3
40479 a3= 0.1190d+02-0.2000d+02*sb -0.2000d+02*sb2+0.1292d+02*sb3
40480 a4= 0.5771d+00-0.2552d+00*sb +0.7510d+00*sb2+0.6923d+00*sb3
40481 a5= 0.4402d+01-0.1627d+01*sb -0.2085d+01*sb2-0.6737d+01*sb3
40482 ENDIF
40483
40484C...Expansion for CTEQ3D.
40485 ELSEIF(iset .EQ. 3) THEN
40486 IF(iprt .EQ. 2) THEN
40487 a0=exp( 0.2148d+00+0.5814d-01*sb +0.2734d+00*sb2-
40488 & 0.2902d+00*sb3)
40489 a1= 0.4810d+00+0.1657d-01*sb -0.3800d-01*sb2+0.3125d-01*sb3
40490 a2= 0.3509d+01+0.3923d+00*sb +0.4010d+00*sb2-0.1932d+00*sb3
40491 a3= 0.7055d+01-0.6552d+01*sb +0.3466d+01*sb2-0.5657d+00*sb3
40492 a4= 0.1061d+01-0.3453d+00*sb +0.4089d+00*sb2-0.1817d+00*sb3
40493 a5= 0.8687d-01+0.2548d+00*sb -0.2967d+00*sb2+0.2647d+00*sb3
40494 ELSEIF(iprt .EQ. 1) THEN
40495 a0=exp( 0.3961d+00+0.4914d+00*sb -0.1728d+01*sb2+
40496 & 0.7257d+00*sb3)
40497 a1= 0.4162d+00-0.1419d+00*sb +0.3680d+00*sb2-0.1618d+00*sb3
40498 a2= 0.3248d+01+0.3028d+01*sb -0.4307d+01*sb2+0.1920d+01*sb3
40499 a3=-0.1100d+01+0.2184d+01*sb -0.3820d+01*sb2+0.1717d+01*sb3
40500 a4= 0.2082d+01-0.2756d+00*sb +0.3043d+00*sb2-0.1260d+00*sb3
40501 a5=-0.4822d+00-0.5706d+00*sb +0.2243d+01*sb2-0.9760d+00*sb3
40502 ELSEIF(iprt .EQ. 0) THEN
40503 a0=exp(-0.4665d+00-0.7554d+00*sb -0.3323d+00*sb2-
40504 & 0.2734d-04*sb3)
40505 a1=-0.3359d+00+0.2395d+00*sb -0.2377d+00*sb2+0.7059d-01*sb3
40506 a2= 0.5451d+01+0.6086d+00*sb +0.8606d-01*sb2-0.1425d+00*sb3
40507 a3= 0.1026d+02-0.9352d+01*sb +0.4879d+01*sb2-0.1150d+01*sb3
40508 a4= 0.9935d+00-0.5017d-01*sb -0.1707d-01*sb2-0.1464d-02*sb3
40509 a5=-0.4160d-01+0.2305d+01*sb -0.1063d+01*sb2+0.3211d+00*sb3
40510 ELSEIF(iprt .EQ. -1) THEN
40511 a0=exp(-0.2714d+01-0.2868d+01*sb +0.3700d+01*sb2-
40512 & 0.1671d+01*sb3)
40513 a1=-0.3893d+00+0.3341d+00*sb -0.3897d+00*sb2+0.1420d+00*sb3
40514 a2= 0.8359d+01-0.3267d+01*sb +0.5327d+01*sb2-0.2245d+01*sb3
40515 a3= 0.2359d+02-0.5669d+01*sb -0.4602d+01*sb2+0.3153d+01*sb3
40516 a4= 0.1106d+01-0.4745d+00*sb +0.7739d+00*sb2-0.3417d+00*sb3
40517 a5=-0.5557d+00+0.3433d+01*sb -0.3390d+01*sb2+0.1354d+01*sb3
40518 ELSEIF(iprt .EQ. -2) THEN
40519 a0=exp(-0.3323d+01+0.2296d+00*sb -0.1109d+01*sb2+
40520 & 0.2223d+00*sb3)
40521 a1=-0.3410d+00+0.8847d-01*sb -0.1111d-01*sb2-0.5927d-02*sb3
40522 a2= 0.9753d+01-0.5182d+00*sb -0.4670d+00*sb2+0.1921d+00*sb3
40523 a3= 0.1977d+02-0.1600d+02*sb +0.9481d+01*sb2-0.1864d+01*sb3
40524 a4= 0.9818d+00+0.2839d-02*sb -0.1188d+00*sb2+0.3584d-01*sb3
40525 a5=-0.7934d-01+0.1004d+01*sb +0.3704d+00*sb2-0.1220d+00*sb3
40526 ELSEIF(iprt .EQ. -3) THEN
40527 a0=exp(-0.3985d+01+0.2855d+01*sb -0.5208d+01*sb2+
40528 & 0.1937d+01*sb3)
40529 a1=-0.3337d+00-0.1150d+00*sb +0.3691d+00*sb2-0.1709d+00*sb3
40530 a2= 0.7968d+01+0.3641d+01*sb -0.6599d+01*sb2+0.2642d+01*sb3
40531 a3= 0.1873d+02-0.1999d+02*sb +0.1734d+02*sb2-0.5813d+01*sb3
40532 a4= 0.9731d+00+0.5082d+00*sb -0.8780d+00*sb2+0.3231d+00*sb3
40533 a5=-0.5542d-01-0.4189d+00*sb +0.3309d+01*sb2-0.1439d+01*sb3
40534 ELSEIF(iprt .EQ. -4) THEN
40535 a0=sb** 0.1105d+01*exp(-0.3952d+01-0.1901d+01*sb +
40536 & 0.5137d+00*sb2)
40537 a1=-0.3543d+00+0.6055d+00*sb -0.6941d+00*sb2+0.2278d+00*sb3
40538 a2= 0.5955d+01-0.2629d+01*sb +0.5337d+01*sb2-0.2300d+01*sb3
40539 a3= 0.1933d+01+0.4882d+01*sb -0.3810d+01*sb2+0.2290d+00*sb3
40540 a4= 0.1806d+00+0.1655d+01*sb -0.1893d+01*sb2+0.6395d+00*sb3
40541 a5= 0.4790d+00+0.3612d+01*sb -0.3152d+01*sb2+0.9684d+00*sb3
40542 ELSEIF(iprt .EQ. -5) THEN
40543 a0=sb** 0.9818d+00*exp(-0.1825d+01-0.7464d+01*sb +
40544 & 0.2143d+01*sb2)
40545 a1=-0.2604d+00-0.1400d+00*sb +0.1702d+00*sb2-0.8476d-01*sb3
40546 a2= 0.6005d+01+0.6275d+00*sb -0.2535d+01*sb2+0.2219d+01*sb3
40547 a3=-0.9067d+00+0.1149d+01*sb +0.1974d+01*sb2+0.4716d+01*sb3
40548 a4= 0.3915d-01+0.5945d-01*sb -0.9844d-01*sb2+0.2783d-01*sb3
40549 a5= 0.5500d+00+0.1994d+01*sb -0.6727d+00*sb2-0.1510d+00*sb3
40550 ELSEIF(iprt .EQ. -6) THEN
40551 a0=sb** 0.1002d+01*exp(-0.8553d+01+0.3793d+00*sb +
40552 & 0.9998d+01*sb2)
40553 a1=-0.5870d-01-0.2792d+00*sb +0.6526d+00*sb2-0.1984d+01*sb3
40554 a2= 0.4716d+01+0.4473d+00*sb +0.1128d+02*sb2-0.1937d+02*sb3
40555 a3= 0.1289d+02-0.1742d+02*sb -0.1983d+02*sb2-0.9274d+00*sb3
40556 a4= 0.5647d+00-0.2732d+00*sb +0.1074d+01*sb2+0.5981d+00*sb3
40557 a5= 0.4390d+01-0.1262d+01*sb -0.9026d+00*sb2-0.9394d+01*sb3
40558 ENDIF
40559 ENDIF
40560
40561C...Calculation of x * f(x, Q).
40562 pycteq = max(0d0, a0 *(x**a1) *((1d0-x)**a2) *(1d0+a3*(x**a4))
40563 & *(log(1d0+1d0/x))**a5 )
40564
40565 RETURN
40566 END
40567
40568C*********************************************************************
40569
40570C...PYGRVL
40571C...Gives the GRV 94 L (leading order) parton distribution function set
40572C...in parametrized form.
40573C...Authors: M. Glueck, E. Reya and A. Vogt.
40574
40575 SUBROUTINE pygrvl (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40576
40577C...Double precision declaration.
40578 IMPLICIT DOUBLE PRECISION (a - z)
40579
40580C...Common expressions.
40581 mu2 = 0.23d0
40582 lam2 = 0.2322d0 * 0.2322d0
40583 s = log(log(q2/lam2) / log(mu2/lam2))
40584 ds = sqrt(s)
40585 s2 = s * s
40586 s3 = s2 * s
40587
40588C...uv :
40589 nu = 2.284d0 + 0.802d0 * s + 0.055d0 * s2
40590 aku = 0.590d0 - 0.024d0 * s
40591 bku = 0.131d0 + 0.063d0 * s
40592 au = -0.449d0 - 0.138d0 * s - 0.076d0 * s2
40593 bu = 0.213d0 + 2.669d0 * s - 0.728d0 * s2
40594 cu = 8.854d0 - 9.135d0 * s + 1.979d0 * s2
40595 du = 2.997d0 + 0.753d0 * s - 0.076d0 * s2
40596 uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
40597
40598C...dv :
40599 nd = 0.371d0 + 0.083d0 * s + 0.039d0 * s2
40600 akd = 0.376d0
40601 bkd = 0.486d0 + 0.062d0 * s
40602 ad = -0.509d0 + 3.310d0 * s - 1.248d0 * s2
40603 bd = 12.41d0 - 10.52d0 * s + 2.267d0 * s2
40604 cd = 6.373d0 - 6.208d0 * s + 1.418d0 * s2
40605 dd = 3.691d0 + 0.799d0 * s - 0.071d0 * s2
40606 dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
40607
40608C...del :
40609 ne = 0.082d0 + 0.014d0 * s + 0.008d0 * s2
40610 ake = 0.409d0 - 0.005d0 * s
40611 bke = 0.799d0 + 0.071d0 * s
40612 ae = -38.07d0 + 36.13d0 * s - 0.656d0 * s2
40613 be = 90.31d0 - 74.15d0 * s + 7.645d0 * s2
40614 ce = 0.0d0
40615 de = 7.486d0 + 1.217d0 * s - 0.159d0 * s2
40616 del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
40617
40618C...udb :
40619 alx = 1.451d0
40620 bex = 0.271d0
40621 akx = 0.410d0 - 0.232d0 * s
40622 bkx = 0.534d0 - 0.457d0 * s
40623 agx = 0.890d0 - 0.140d0 * s
40624 bgx = -0.981d0
40625 cx = 0.320d0 + 0.683d0 * s
40626 dx = 4.752d0 + 1.164d0 * s + 0.286d0 * s2
40627 ex = 4.119d0 + 1.713d0 * s
40628 esx = 0.682d0 + 2.978d0 * s
40629 udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
40630 & dx, ex, esx)
40631
40632C...sb :
40633 sts = 0d0
40634 als = 0.914d0
40635 bes = 0.577d0
40636 aks = 1.798d0 - 0.596d0 * s
40637 as = -5.548d0 + 3.669d0 * ds - 0.616d0 * s
40638 bs = 18.92d0 - 16.73d0 * ds + 5.168d0 * s
40639 dst = 6.379d0 - 0.350d0 * s + 0.142d0 * s2
40640 est = 3.981d0 + 1.638d0 * s
40641 ess = 6.402d0
40642 sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
40643
40644C...cb :
40645 stc = 0.888d0
40646 alc = 1.01d0
40647 bec = 0.37d0
40648 akc = 0d0
40649 ac = 0d0
40650 bc = 4.24d0 - 0.804d0 * s
40651 dct = 3.46d0 - 1.076d0 * s
40652 ect = 4.61d0 + 1.49d0 * s
40653 esc = 2.555d0 + 1.961d0 * s
40654 chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
40655
40656C...bb :
40657 stb = 1.351d0
40658 alb = 1.00d0
40659 beb = 0.51d0
40660 akb = 0d0
40661 ab = 0d0
40662 bb = 1.848d0
40663 dbt = 2.929d0 + 1.396d0 * s
40664 ebt = 4.71d0 + 1.514d0 * s
40665 esb = 4.02d0 + 1.239d0 * s
40666 bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
40667
40668C...gl :
40669 alg = 0.524d0
40670 beg = 1.088d0
40671 akg = 1.742d0 - 0.930d0 * s
40672 bkg = - 0.399d0 * s2
40673 ag = 7.486d0 - 2.185d0 * s
40674 bg = 16.69d0 - 22.74d0 * s + 5.779d0 * s2
40675 cg = -25.59d0 + 29.71d0 * s - 7.296d0 * s2
40676 dg = 2.792d0 + 2.215d0 * s + 0.422d0 * s2 - 0.104d0 * s3
40677 eg = 0.807d0 + 2.005d0 * s
40678 esg = 3.841d0 + 0.316d0 * s
40679 gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg,
40680 & dg, eg, esg)
40681
40682 RETURN
40683 END
40684
40685C*********************************************************************
40686
40687C...PYGRVM
40688C...Gives the GRV 94 M (MSbar) parton distribution function set
40689C...in parametrized form.
40690C...Authors: M. Glueck, E. Reya and A. Vogt.
40691
40692 SUBROUTINE pygrvm (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40693
40694C...Double precision declaration.
40695 IMPLICIT DOUBLE PRECISION (a - z)
40696
40697C...Common expressions.
40698 mu2 = 0.34d0
40699 lam2 = 0.248d0 * 0.248d0
40700 s = log(log(q2/lam2) / log(mu2/lam2))
40701 ds = sqrt(s)
40702 s2 = s * s
40703 s3 = s2 * s
40704
40705C...uv :
40706 nu = 1.304d0 + 0.863d0 * s
40707 aku = 0.558d0 - 0.020d0 * s
40708 bku = 0.183d0 * s
40709 au = -0.113d0 + 0.283d0 * s - 0.321d0 * s2
40710 bu = 6.843d0 - 5.089d0 * s + 2.647d0 * s2 - 0.527d0 * s3
40711 cu = 7.771d0 - 10.09d0 * s + 2.630d0 * s2
40712 du = 3.315d0 + 1.145d0 * s - 0.583d0 * s2 + 0.154d0 * s3
40713 uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
40714
40715C...dv :
40716 nd = 0.102d0 - 0.017d0 * s + 0.005d0 * s2
40717 akd = 0.270d0 - 0.019d0 * s
40718 bkd = 0.260d0
40719 ad = 2.393d0 + 6.228d0 * s - 0.881d0 * s2
40720 bd = 46.06d0 + 4.673d0 * s - 14.98d0 * s2 + 1.331d0 * s3
40721 cd = 17.83d0 - 53.47d0 * s + 21.24d0 * s2
40722 dd = 4.081d0 + 0.976d0 * s - 0.485d0 * s2 + 0.152d0 * s3
40723 dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
40724
40725C...del :
40726 ne = 0.070d0 + 0.042d0 * s - 0.011d0 * s2 + 0.004d0 * s3
40727 ake = 0.409d0 - 0.007d0 * s
40728 bke = 0.782d0 + 0.082d0 * s
40729 ae = -29.65d0 + 26.49d0 * s + 5.429d0 * s2
40730 be = 90.20d0 - 74.97d0 * s + 4.526d0 * s2
40731 ce = 0.0d0
40732 de = 8.122d0 + 2.120d0 * s - 1.088d0 * s2 + 0.231d0 * s3
40733 del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
40734
40735C...udb :
40736 alx = 0.877d0
40737 bex = 0.561d0
40738 akx = 0.275d0
40739 bkx = 0.0d0
40740 agx = 0.997d0
40741 bgx = 3.210d0 - 1.866d0 * s
40742 cx = 7.300d0
40743 dx = 9.010d0 + 0.896d0 * ds + 0.222d0 * s2
40744 ex = 3.077d0 + 1.446d0 * s
40745 esx = 3.173d0 - 2.445d0 * ds + 2.207d0 * s
40746 udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
40747 & dx, ex, esx)
40748
40749C...sb :
40750 sts = 0d0
40751 als = 0.756d0
40752 bes = 0.216d0
40753 aks = 1.690d0 + 0.650d0 * ds - 0.922d0 * s
40754 as = -4.329d0 + 1.131d0 * s
40755 bs = 9.568d0 - 1.744d0 * s
40756 dst = 9.377d0 + 1.088d0 * ds - 1.320d0 * s + 0.130d0 * s2
40757 est = 3.031d0 + 1.639d0 * s
40758 ess = 5.837d0 + 0.815d0 * s
40759 sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
40760
40761C...cb :
40762 stc = 0.820d0
40763 alc = 0.98d0
40764 bec = 0d0
40765 akc = -0.625d0 - 0.523d0 * s
40766 ac = 0d0
40767 bc = 1.896d0 + 1.616d0 * s
40768 dct = 4.12d0 + 0.683d0 * s
40769 ect = 4.36d0 + 1.328d0 * s
40770 esc = 0.677d0 + 0.679d0 * s
40771 chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
40772
40773C...bb :
40774 stb = 1.297d0
40775 alb = 0.99d0
40776 beb = 0d0
40777 akb = - 0.193d0 * s
40778 ab = 0d0
40779 bb = 0d0
40780 dbt = 3.447d0 + 0.927d0 * s
40781 ebt = 4.68d0 + 1.259d0 * s
40782 esb = 1.892d0 + 2.199d0 * s
40783 bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
40784
40785C...gl :
40786 alg = 1.014d0
40787 beg = 1.738d0
40788 akg = 1.724d0 + 0.157d0 * s
40789 bkg = 0.800d0 + 1.016d0 * s
40790 ag = 7.517d0 - 2.547d0 * s
40791 bg = 34.09d0 - 52.21d0 * ds + 17.47d0 * s
40792 cg = 4.039d0 + 1.491d0 * s
40793 dg = 3.404d0 + 0.830d0 * s
40794 eg = -1.112d0 + 3.438d0 * s - 0.302d0 * s2
40795 esg = 3.256d0 - 0.436d0 * s
40796 gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
40797
40798 RETURN
40799 END
40800
40801C*********************************************************************
40802
40803C...PYGRVD
40804C...Gives the GRV 94 D (DIS) parton distribution function set
40805C...in parametrized form.
40806C...Authors: M. Glueck, E. Reya and A. Vogt.
40807
40808 SUBROUTINE pygrvd (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40809
40810C...Double precision declaration.
40811 IMPLICIT DOUBLE PRECISION (a - z)
40812
40813C...Common expressions.
40814 mu2 = 0.34d0
40815 lam2 = 0.248d0 * 0.248d0
40816 s = log(log(q2/lam2) / log(mu2/lam2))
40817 ds = sqrt(s)
40818 s2 = s * s
40819 s3 = s2 * s
40820
40821C...uv :
40822 nu = 2.484d0 + 0.116d0 * s + 0.093d0 * s2
40823 aku = 0.563d0 - 0.025d0 * s
40824 bku = 0.054d0 + 0.154d0 * s
40825 au = -0.326d0 - 0.058d0 * s - 0.135d0 * s2
40826 bu = -3.322d0 + 8.259d0 * s - 3.119d0 * s2 + 0.291d0 * s3
40827 cu = 11.52d0 - 12.99d0 * s + 3.161d0 * s2
40828 du = 2.808d0 + 1.400d0 * s - 0.557d0 * s2 + 0.119d0 * s3
40829 uv = pygrvv(x, nu, aku, bku, au, bu, cu, du)
40830
40831C...dv :
40832 nd = 0.156d0 - 0.017d0 * s
40833 akd = 0.299d0 - 0.022d0 * s
40834 bkd = 0.259d0 - 0.015d0 * s
40835 ad = 3.445d0 + 1.278d0 * s + 0.326d0 * s2
40836 bd = -6.934d0 + 37.45d0 * s - 18.95d0 * s2 + 1.463d0 * s3
40837 cd = 55.45d0 - 69.92d0 * s + 20.78d0 * s2
40838 dd = 3.577d0 + 1.441d0 * s - 0.683d0 * s2 + 0.179d0 * s3
40839 dv = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)
40840
40841C...del :
40842 ne = 0.099d0 + 0.019d0 * s + 0.002d0 * s2
40843 ake = 0.419d0 - 0.013d0 * s
40844 bke = 1.064d0 - 0.038d0 * s
40845 ae = -44.00d0 + 98.70d0 * s - 14.79d0 * s2
40846 be = 28.59d0 - 40.94d0 * s - 13.66d0 * s2 + 2.523d0 * s3
40847 ce = 84.57d0 - 108.8d0 * s + 31.52d0 * s2
40848 de = 7.469d0 + 2.480d0 * s - 0.866d0 * s2
40849 del = pygrvv(x, ne, ake, bke, ae, be, ce, de)
40850
40851C...udb :
40852 alx = 1.215d0
40853 bex = 0.466d0
40854 akx = 0.326d0 + 0.150d0 * s
40855 bkx = 0.956d0 + 0.405d0 * s
40856 agx = 0.272d0
40857 bgx = 3.794d0 - 2.359d0 * ds
40858 cx = 2.014d0
40859 dx = 7.941d0 + 0.534d0 * ds - 0.940d0 * s + 0.410d0 * s2
40860 ex = 3.049d0 + 1.597d0 * s
40861 esx = 4.396d0 - 4.594d0 * ds + 3.268d0 * s
40862 udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,
40863 & dx, ex, esx)
40864
40865C...sb :
40866 sts = 0d0
40867 als = 0.175d0
40868 bes = 0.344d0
40869 aks = 1.415d0 - 0.641d0 * ds
40870 as = 0.580d0 - 9.763d0 * ds + 6.795d0 * s - 0.558d0 * s2
40871 bs = 5.617d0 + 5.709d0 * ds - 3.972d0 * s
40872 dst = 13.78d0 - 9.581d0 * s + 5.370d0 * s2 - 0.996d0 * s3
40873 est = 4.546d0 + 0.372d0 * s2
40874 ess = 5.053d0 - 1.070d0 * s + 0.805d0 * s2
40875 sb = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)
40876
40877C...cb :
40878 stc = 0.820d0
40879 alc = 0.98d0
40880 bec = 0d0
40881 akc = -0.625d0 - 0.523d0 * s
40882 ac = 0d0
40883 bc = 1.896d0 + 1.616d0 * s
40884 dct = 4.12d0 + 0.683d0 * s
40885 ect = 4.36d0 + 1.328d0 * s
40886 esc = 0.677d0 + 0.679d0 * s
40887 chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)
40888
40889C...bb :
40890 stb = 1.297d0
40891 alb = 0.99d0
40892 beb = 0d0
40893 akb = - 0.193d0 * s
40894 ab = 0d0
40895 bb = 0d0
40896 dbt = 3.447d0 + 0.927d0 * s
40897 ebt = 4.68d0 + 1.259d0 * s
40898 esb = 1.892d0 + 2.199d0 * s
40899 bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)
40900
40901C...gl :
40902 alg = 1.258d0
40903 beg = 1.846d0
40904 akg = 2.423d0
40905 bkg = 2.427d0 + 1.311d0 * s - 0.153d0 * s2
40906 ag = 25.09d0 - 7.935d0 * s
40907 bg = -14.84d0 - 124.3d0 * ds + 72.18d0 * s
40908 cg = 590.3d0 - 173.8d0 * s
40909 dg = 5.196d0 + 1.857d0 * s
40910 eg = -1.648d0 + 3.988d0 * s - 0.432d0 * s2
40911 esg = 3.232d0 - 0.542d0 * s
40912 gl = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)
40913
40914 RETURN
40915 END
40916
40917C*********************************************************************
40918
40919C...PYGRVV
40920C...Auxiliary for the GRV 94 parton distribution functions
40921C...for u and d valence and d-u sea.
40922C...Authors: M. Glueck, E. Reya and A. Vogt.
40923
40924 FUNCTION pygrvv (X, N, AK, BK, A, B, C, D)
40925
40926C...Double precision declaration.
40927 IMPLICIT DOUBLE PRECISION (a - z)
40928
40929C...Evaluation.
40930 dx = sqrt(x)
40931 pygrvv = n * x**ak * (1d0+ a*x**bk + x * (b + c*dx)) *
40932 & (1d0- x)**d
40933
40934 RETURN
40935 END
40936
40937C*********************************************************************
40938
40939C...PYGRVW
40940C...Auxiliary for the GRV 94 parton distribution functions
40941C...for d+u sea and gluon.
40942C...Authors: M. Glueck, E. Reya and A. Vogt.
40943
40944 FUNCTION pygrvw (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
40945
40946C...Double precision declaration.
40947 IMPLICIT DOUBLE PRECISION (a - z)
40948
40949C...Evaluation.
40950 lx = log(1d0/x)
40951 pygrvw = (x**ak * (a + x * (b + x*c)) * lx**bk + s**al
40952 & * exp(-e + sqrt(es * s**be * lx))) * (1d0- x)**d
40953
40954 RETURN
40955 END
40956
40957C*********************************************************************
40958
40959C...PYGRVS
40960C...Auxiliary for the GRV 94 parton distribution functions
40961C...for s, c and b sea.
40962C...Authors: M. Glueck, E. Reya and A. Vogt.
40963
40964 FUNCTION pygrvs (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
40965
40966C...Double precision declaration.
40967 IMPLICIT DOUBLE PRECISION (a - z)
40968
40969C...Evaluation.
40970 IF(s.LE.sth) THEN
40971 pygrvs = 0d0
40972 ELSE
40973 dx = sqrt(x)
40974 lx = log(1d0/x)
40975 pygrvs = (s - sth)**al / lx**ak * (1d0+ ag*dx + b*x) *
40976 & (1d0- x)**d * exp(-e + sqrt(es * s**be * lx))
40977 ENDIF
40978
40979 RETURN
40980 END
40981
40982C*********************************************************************
40983
40984C...PYCT5L
40985C...Auxiliary function for parametrization of CTEQ5L.
40986C...Author: J. Pumplin 9/99.
40987
40988C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
40989C...in Parametrized Form
40990C... September 15, 1999
40991C
40992C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
40993C... CTEQ5 PPARTON DISTRIBUTIONS"
40994C...hep-ph/9903282
40995
40996C...The CTEQ5M1 set given here is an updated version of the original
40997C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
40998C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
40999C...almost all applications.
41000C...The improvement is in the QCD evolution which is now more
41001C...accurate, and which agrees completely with the benchmark work
41002C...of the HERA 96/97 Workshop.
41003C...The differences between the parametrized and the corresponding
41004C...table versions (on which it is based) are of similar order as
41005C...between the two version.
41006
41007C...!! Because accurate parametrizations over a wide range of (x,Q)
41008C...is hard to obtain, only the most widely used sets CTEQ5M and
41009C...CTEQ5L are available in parametrized form for now.
41010
41011C...These parametrizations were obtained by Jon Pumplin.
41012
41013C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41014C -------------------------------------------------------------------
41015C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41016C 3 CTEQ5L Leading Order 0.127 192 146
41017C -------------------------------------------------------------------
41018C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41019C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41020C...calibration.
41021
41022C...The two Iset value are adopted to agree with the standard table
41023C...versions.
41024
41025C...Range of validity:
41026C...The range of (x, Q) covered by this parametrization of the QCD
41027C...evolved parton distributions is 1E-6 < x < 1 ;
41028C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41029C...data only in a subset of that region; and the assumed DGLAP
41030C...evolution is unlikely to be valid for all of it either.
41031
41032C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41033C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41034C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41035C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41036
41037 FUNCTION pyct5l(IFL,X,Q)
41038
41039C...Double precision declaration.
41040 IMPLICIT DOUBLE PRECISION(a-h, o-z)
41041 IMPLICIT INTEGER(I-N)
41042
41043 parameter(nex=8, nlf=2)
41044 dimension am(0:nex,0:nlf,-5:2)
41045 dimension alfvec(-5:2), qmavec(-5:2)
41046 dimension mexvec(-5:2), mlfvec(-5:2)
41047 dimension ut1vec(-5:2), ut2vec(-5:2)
41048 dimension af(0:nex)
41049
41050 DATA mexvec( 2) / 8 /
41051 DATA mlfvec( 2) / 2 /
41052 DATA ut1vec( 2) / 0.4971265e+01 /
41053 DATA ut2vec( 2) / -0.1105128e+01 /
41054 DATA alfvec( 2) / 0.2987216e+00 /
41055 DATA qmavec( 2) / 0.0000000e+00 /
41056 DATA (am( 0,k, 2),k=0, 2)
41057 & / 0.5292616e+01, -0.2751910e+01, -0.2488990e+01 /
41058 DATA (am( 1,k, 2),k=0, 2)
41059 & / 0.9714424e+00, 0.1011827e-01, -0.1023660e-01 /
41060 DATA (am( 2,k, 2),k=0, 2)
41061 & / -0.1651006e+02, 0.7959721e+01, 0.8810563e+01 /
41062 DATA (am( 3,k, 2),k=0, 2)
41063 & / -0.1643394e+02, 0.5892854e+01, 0.9348874e+01 /
41064 DATA (am( 4,k, 2),k=0, 2)
41065 & / 0.3067422e+02, 0.4235796e+01, -0.5112136e+00 /
41066 DATA (am( 5,k, 2),k=0, 2)
41067 & / 0.2352526e+02, -0.5305168e+01, -0.1169174e+02 /
41068 DATA (am( 6,k, 2),k=0, 2)
41069 & / -0.1095451e+02, 0.3006577e+01, 0.5638136e+01 /
41070 DATA (am( 7,k, 2),k=0, 2)
41071 & / -0.1172251e+02, -0.2183624e+01, 0.4955794e+01 /
41072 DATA (am( 8,k, 2),k=0, 2)
41073 & / 0.1662533e-01, 0.7622870e-02, -0.4895887e-03 /
41074
41075 DATA mexvec( 1) / 8 /
41076 DATA mlfvec( 1) / 2 /
41077 DATA ut1vec( 1) / 0.2612618e+01 /
41078 DATA ut2vec( 1) / -0.1258304e+06 /
41079 DATA alfvec( 1) / 0.3407552e+00 /
41080 DATA qmavec( 1) / 0.0000000e+00 /
41081 DATA (am( 0,k, 1),k=0, 2)
41082 & / 0.9905300e+00, -0.4502235e+00, 0.1624441e+00 /
41083 DATA (am( 1,k, 1),k=0, 2)
41084 & / 0.8867534e+00, 0.1630829e-01, -0.4049085e-01 /
41085 DATA (am( 2,k, 1),k=0, 2)
41086 & / 0.8547974e+00, 0.3336301e+00, 0.1371388e+00 /
41087 DATA (am( 3,k, 1),k=0, 2)
41088 & / 0.2941113e+00, -0.1527905e+01, 0.2331879e+00 /
41089 DATA (am( 4,k, 1),k=0, 2)
41090 & / 0.3384235e+02, 0.3715315e+01, 0.8276930e+00 /
41091 DATA (am( 5,k, 1),k=0, 2)
41092 & / 0.6230115e+01, 0.3134639e+01, -0.1729099e+01 /
41093 DATA (am( 6,k, 1),k=0, 2)
41094 & / -0.1186928e+01, -0.3282460e+00, 0.1052020e+00 /
41095 DATA (am( 7,k, 1),k=0, 2)
41096 & / -0.8545702e+01, -0.6247947e+01, 0.3692561e+01 /
41097 DATA (am( 8,k, 1),k=0, 2)
41098 & / 0.1724598e-01, 0.7120465e-02, 0.4003646e-04 /
41099
41100 DATA mexvec( 0) / 8 /
41101 DATA mlfvec( 0) / 2 /
41102 DATA ut1vec( 0) / -0.4656819e+00 /
41103 DATA ut2vec( 0) / -0.2742390e+03 /
41104 DATA alfvec( 0) / 0.4491863e+00 /
41105 DATA qmavec( 0) / 0.0000000e+00 /
41106 DATA (am( 0,k, 0),k=0, 2)
41107 & / 0.1193572e+03, -0.3886845e+01, -0.1133965e+01 /
41108 DATA (am( 1,k, 0),k=0, 2)
41109 & / -0.9421449e+02, 0.3995885e+01, 0.1607363e+01 /
41110 DATA (am( 2,k, 0),k=0, 2)
41111 & / 0.4206383e+01, 0.2485954e+00, 0.2497468e+00 /
41112 DATA (am( 3,k, 0),k=0, 2)
41113 & / 0.1210557e+03, -0.3015765e+01, -0.1423651e+01 /
41114 DATA (am( 4,k, 0),k=0, 2)
41115 & / -0.1013897e+03, -0.7113478e+00, 0.2621865e+00 /
41116 DATA (am( 5,k, 0),k=0, 2)
41117 & / -0.1312404e+01, -0.9297691e+00, -0.1562531e+00 /
41118 DATA (am( 6,k, 0),k=0, 2)
41119 & / 0.1627137e+01, 0.4954111e+00, -0.6387009e+00 /
41120 DATA (am( 7,k, 0),k=0, 2)
41121 & / 0.1537698e+00, -0.2487878e+00, 0.8305947e+00 /
41122 DATA (am( 8,k, 0),k=0, 2)
41123 & / 0.2496448e-01, 0.2457823e-02, 0.8234276e-03 /
41124
41125 DATA mexvec(-1) / 8 /
41126 DATA mlfvec(-1) / 2 /
41127 DATA ut1vec(-1) / 0.3862583e+01 /
41128 DATA ut2vec(-1) / -0.1265969e+01 /
41129 DATA alfvec(-1) / 0.2457668e+00 /
41130 DATA qmavec(-1) / 0.0000000e+00 /
41131 DATA (am( 0,k,-1),k=0, 2)
41132 & / 0.2647441e+02, 0.1059277e+02, -0.9176654e+00 /
41133 DATA (am( 1,k,-1),k=0, 2)
41134 & / 0.1990636e+01, 0.8558918e-01, 0.4248667e-01 /
41135 DATA (am( 2,k,-1),k=0, 2)
41136 & / -0.1476095e+02, -0.3276255e+02, 0.1558110e+01 /
41137 DATA (am( 3,k,-1),k=0, 2)
41138 & / -0.2966889e+01, -0.3649037e+02, 0.1195914e+01 /
41139 DATA (am( 4,k,-1),k=0, 2)
41140 & / -0.1000519e+03, -0.2464635e+01, 0.1964849e+00 /
41141 DATA (am( 5,k,-1),k=0, 2)
41142 & / 0.3718331e+02, 0.4700389e+02, -0.2772142e+01 /
41143 DATA (am( 6,k,-1),k=0, 2)
41144 & / -0.1872722e+02, -0.2291189e+02, 0.1089052e+01 /
41145 DATA (am( 7,k,-1),k=0, 2)
41146 & / -0.1628146e+02, -0.1823993e+02, 0.2537369e+01 /
41147 DATA (am( 8,k,-1),k=0, 2)
41148 & / -0.1156300e+01, -0.1280495e+00, 0.5153245e-01 /
41149
41150 DATA mexvec(-2) / 7 /
41151 DATA mlfvec(-2) / 2 /
41152 DATA ut1vec(-2) / 0.1895615e+00 /
41153 DATA ut2vec(-2) / -0.3069097e+01 /
41154 DATA alfvec(-2) / 0.5293999e+00 /
41155 DATA qmavec(-2) / 0.0000000e+00 /
41156 DATA (am( 0,k,-2),k=0, 2)
41157 & / -0.6556775e+00, 0.2490190e+00, 0.3966485e-01 /
41158 DATA (am( 1,k,-2),k=0, 2)
41159 & / 0.1305102e+01, -0.1188925e+00, -0.4600870e-02 /
41160 DATA (am( 2,k,-2),k=0, 2)
41161 & / -0.2371436e+01, 0.3566814e+00, -0.2834683e+00 /
41162 DATA (am( 3,k,-2),k=0, 2)
41163 & / -0.6152826e+01, 0.8339877e+00, -0.7233230e+00 /
41164 DATA (am( 4,k,-2),k=0, 2)
41165 & / -0.8346558e+01, 0.2892168e+01, 0.2137099e+00 /
41166 DATA (am( 5,k,-2),k=0, 2)
41167 & / 0.1279530e+02, 0.1021114e+00, 0.5787439e+00 /
41168 DATA (am( 6,k,-2),k=0, 2)
41169 & / 0.5858816e+00, -0.1940375e+01, -0.4029269e+00 /
41170 DATA (am( 7,k,-2),k=0, 2)
41171 & / -0.2795725e+02, -0.5263392e+00, 0.1290229e+01 /
41172
41173 DATA mexvec(-3) / 7 /
41174 DATA mlfvec(-3) / 2 /
41175 DATA ut1vec(-3) / 0.3753257e+01 /
41176 DATA ut2vec(-3) / -0.1113085e+01 /
41177 DATA alfvec(-3) / 0.3713141e+00 /
41178 DATA qmavec(-3) / 0.0000000e+00 /
41179 DATA (am( 0,k,-3),k=0, 2)
41180 & / 0.1580931e+01, -0.2273826e+01, -0.1822245e+01 /
41181 DATA (am( 1,k,-3),k=0, 2)
41182 & / 0.2702644e+01, 0.6763243e+00, 0.7231586e-02 /
41183 DATA (am( 2,k,-3),k=0, 2)
41184 & / -0.1857924e+02, 0.3907500e+01, 0.5850109e+01 /
41185 DATA (am( 3,k,-3),k=0, 2)
41186 & / -0.3044793e+02, 0.2639332e+01, 0.5566644e+01 /
41187 DATA (am( 4,k,-3),k=0, 2)
41188 & / -0.4258011e+01, -0.5429244e+01, 0.4418946e+00 /
41189 DATA (am( 5,k,-3),k=0, 2)
41190 & / 0.3465259e+02, -0.5532604e+01, -0.4904153e+01 /
41191 DATA (am( 6,k,-3),k=0, 2)
41192 & / -0.1658858e+02, 0.2923275e+01, 0.2266286e+01 /
41193 DATA (am( 7,k,-3),k=0, 2)
41194 & / -0.1149263e+02, 0.2877475e+01, -0.7999105e+00 /
41195
41196 DATA mexvec(-4) / 7 /
41197 DATA mlfvec(-4) / 2 /
41198 DATA ut1vec(-4) / 0.4400772e+01 /
41199 DATA ut2vec(-4) / -0.1356116e+01 /
41200 DATA alfvec(-4) / 0.3712017e-01 /
41201 DATA qmavec(-4) / 0.1300000e+01 /
41202 DATA (am( 0,k,-4),k=0, 2)
41203 & / -0.8293661e+00, -0.3982375e+01, -0.6494283e-01 /
41204 DATA (am( 1,k,-4),k=0, 2)
41205 & / 0.2754618e+01, 0.8338636e+00, -0.6885160e-01 /
41206 DATA (am( 2,k,-4),k=0, 2)
41207 & / -0.1657987e+02, 0.1439143e+02, -0.6887240e+00 /
41208 DATA (am( 3,k,-4),k=0, 2)
41209 & / -0.2800703e+02, 0.1535966e+02, -0.7377693e+00 /
41210 DATA (am( 4,k,-4),k=0, 2)
41211 & / -0.6460216e+01, -0.4783019e+01, 0.4913297e+00 /
41212 DATA (am( 5,k,-4),k=0, 2)
41213 & / 0.3141830e+02, -0.3178031e+02, 0.7136013e+01 /
41214 DATA (am( 6,k,-4),k=0, 2)
41215 & / -0.1802509e+02, 0.1862163e+02, -0.4632843e+01 /
41216 DATA (am( 7,k,-4),k=0, 2)
41217 & / -0.1240412e+02, 0.2565386e+02, -0.1066570e+02 /
41218
41219 DATA mexvec(-5) / 6 /
41220 DATA mlfvec(-5) / 2 /
41221 DATA ut1vec(-5) / 0.5562568e+01 /
41222 DATA ut2vec(-5) / -0.1801317e+01 /
41223 DATA alfvec(-5) / 0.4952010e-02 /
41224 DATA qmavec(-5) / 0.4500000e+01 /
41225 DATA (am( 0,k,-5),k=0, 2)
41226 & / -0.6031237e+01, 0.1992727e+01, -0.1076331e+01 /
41227 DATA (am( 1,k,-5),k=0, 2)
41228 & / 0.2933912e+01, 0.5839674e+00, 0.7509435e-01 /
41229 DATA (am( 2,k,-5),k=0, 2)
41230 & / -0.8284919e+01, 0.1488593e+01, -0.8251678e+00 /
41231 DATA (am( 3,k,-5),k=0, 2)
41232 & / -0.1925986e+02, 0.2805753e+01, -0.3015446e+01 /
41233 DATA (am( 4,k,-5),k=0, 2)
41234 & / -0.9480483e+01, -0.9767837e+00, -0.1165544e+01 /
41235 DATA (am( 5,k,-5),k=0, 2)
41236 & / 0.2193195e+02, -0.1788518e+02, 0.9460908e+01 /
41237 DATA (am( 6,k,-5),k=0, 2)
41238 & / -0.1327377e+02, 0.1201754e+02, -0.6277844e+01 /
41239
41240 IF(q .LE. qmavec(ifl)) THEN
41241 pyct5l = 0.d0
41242 RETURN
41243 ENDIF
41244
41245 IF(x .GE. 1.d0) THEN
41246 pyct5l = 0.d0
41247 RETURN
41248 ENDIF
41249
41250 tmp = log(q/alfvec(ifl))
41251 IF(tmp .LE. 0.d0) THEN
41252 pyct5l = 0.d0
41253 RETURN
41254 ENDIF
41255
41256 sb = log(tmp)
41257 sb1 = sb - 1.2d0
41258 sb2 = sb1*sb1
41259
41260 DO 110 i = 0, nex
41261 af(i) = 0.d0
41262 sbx = 1.d0
41263 DO 100 k = 0, mlfvec(ifl)
41264 af(i) = af(i) + sbx*am(i,k,ifl)
41265 sbx = sb1*sbx
41266 100 CONTINUE
41267 110 CONTINUE
41268
41269 y = -log(x)
41270 u = log(x/0.00001d0)
41271
41272 part1 = af(1)*y**(1.d0+0.01d0*af(4))*(1.d0+ af(8)*u)
41273 part2 = af(0)*(1.d0 - x) + af(3)*x
41274 part3 = x*(1.d0-x)*(af(5)+af(6)*(1.d0-x)+af(7)*x*(1.d0-x))
41275 part4 = ut1vec(ifl)*log(1.d0-x) +
41276 & af(2)*log(1.d0+exp(ut2vec(ifl))-x)
41277
41278 pyct5l = exp(log(x) + part1 + part2 + part3 + part4)
41279
41280C...Include threshold factor.
41281 pyct5l = pyct5l * (1.d0 - qmavec(ifl)/q)
41282
41283 RETURN
41284 END
41285
41286C*********************************************************************
41287
41288C...PYCT5M
41289C...Auxiliary function for parametrization of CTEQ5M1.
41290C...Author: J. Pumplin 9/99.
41291
41292 FUNCTION pyct5m(IFL,X,Q)
41293
41294C...Double precision declaration.
41295 IMPLICIT DOUBLE PRECISION(a-h, o-z)
41296 IMPLICIT INTEGER(I-N)
41297
41298 parameter(nex=8, nlf=2)
41299 dimension am(0:nex,0:nlf,-5:2)
41300 dimension alfvec(-5:2), qmavec(-5:2)
41301 dimension mexvec(-5:2), mlfvec(-5:2)
41302 dimension ut1vec(-5:2), ut2vec(-5:2)
41303 dimension af(0:nex)
41304
41305 DATA mexvec( 2) / 8 /
41306 DATA mlfvec( 2) / 2 /
41307 DATA ut1vec( 2) / 0.5141718e+01 /
41308 DATA ut2vec( 2) / -0.1346944e+01 /
41309 DATA alfvec( 2) / 0.5260555e+00 /
41310 DATA qmavec( 2) / 0.0000000e+00 /
41311 DATA (am( 0,k, 2),k=0, 2)
41312 & / 0.4289071e+01, -0.2536870e+01, -0.1259948e+01 /
41313 DATA (am( 1,k, 2),k=0, 2)
41314 & / 0.9839410e+00, 0.4168426e-01, -0.5018952e-01 /
41315 DATA (am( 2,k, 2),k=0, 2)
41316 & / -0.1651961e+02, 0.9246261e+01, 0.5996400e+01 /
41317 DATA (am( 3,k, 2),k=0, 2)
41318 & / -0.2077936e+02, 0.9786469e+01, 0.7656465e+01 /
41319 DATA (am( 4,k, 2),k=0, 2)
41320 & / 0.3054926e+02, 0.1889536e+01, 0.1380541e+01 /
41321 DATA (am( 5,k, 2),k=0, 2)
41322 & / 0.3084695e+02, -0.1212303e+02, -0.1053551e+02 /
41323 DATA (am( 6,k, 2),k=0, 2)
41324 & / -0.1426778e+02, 0.6239537e+01, 0.5254819e+01 /
41325 DATA (am( 7,k, 2),k=0, 2)
41326 & / -0.1909811e+02, 0.3695678e+01, 0.5495729e+01 /
41327 DATA (am( 8,k, 2),k=0, 2)
41328 & / 0.1889751e-01, 0.5027193e-02, 0.6624896e-03 /
41329
41330 DATA mexvec( 1) / 8 /
41331 DATA mlfvec( 1) / 2 /
41332 DATA ut1vec( 1) / 0.4138426e+01 /
41333 DATA ut2vec( 1) / -0.3221374e+01 /
41334 DATA alfvec( 1) / 0.4960962e+00 /
41335 DATA qmavec( 1) / 0.0000000e+00 /
41336 DATA (am( 0,k, 1),k=0, 2)
41337 & / 0.1332497e+01, -0.3703718e+00, 0.1288638e+00 /
41338 DATA (am( 1,k, 1),k=0, 2)
41339 & / 0.7544687e+00, 0.3255075e-01, -0.4706680e-01 /
41340 DATA (am( 2,k, 1),k=0, 2)
41341 & / -0.7638814e+00, 0.5008313e+00, -0.9237374e-01 /
41342 DATA (am( 3,k, 1),k=0, 2)
41343 & / -0.3689889e+00, -0.1055098e+01, -0.4645065e+00 /
41344 DATA (am( 4,k, 1),k=0, 2)
41345 & / 0.3991610e+02, 0.1979881e+01, 0.1775814e+01 /
41346 DATA (am( 5,k, 1),k=0, 2)
41347 & / 0.6201080e+01, 0.2046288e+01, 0.3804571e+00 /
41348 DATA (am( 6,k, 1),k=0, 2)
41349 & / -0.8027900e+00, -0.7011688e+00, -0.8049612e+00 /
41350 DATA (am( 7,k, 1),k=0, 2)
41351 & / -0.8631305e+01, -0.3981200e+01, 0.6970153e+00 /
41352 DATA (am( 8,k, 1),k=0, 2)
41353 & / 0.2371230e-01, 0.5372683e-02, 0.1118701e-02 /
41354
41355 DATA mexvec( 0) / 8 /
41356 DATA mlfvec( 0) / 2 /
41357 DATA ut1vec( 0) / -0.1026789e+01 /
41358 DATA ut2vec( 0) / -0.9051707e+01 /
41359 DATA alfvec( 0) / 0.9462977e+00 /
41360 DATA qmavec( 0) / 0.0000000e+00 /
41361 DATA (am( 0,k, 0),k=0, 2)
41362 & / 0.1191990e+03, -0.8548739e+00, -0.1963040e+01 /
41363 DATA (am( 1,k, 0),k=0, 2)
41364 & / -0.9449972e+02, 0.1074771e+01, 0.2056055e+01 /
41365 DATA (am( 2,k, 0),k=0, 2)
41366 & / 0.3701064e+01, -0.1167947e-02, 0.1933573e+00 /
41367 DATA (am( 3,k, 0),k=0, 2)
41368 & / 0.1171345e+03, -0.1064540e+01, -0.1875312e+01 /
41369 DATA (am( 4,k, 0),k=0, 2)
41370 & / -0.1014453e+03, -0.5707427e+00, 0.4511242e-01 /
41371 DATA (am( 5,k, 0),k=0, 2)
41372 & / 0.6365168e+01, 0.1275354e+01, -0.4964081e+00 /
41373 DATA (am( 6,k, 0),k=0, 2)
41374 & / -0.3370693e+01, -0.1122020e+01, 0.5947751e-01 /
41375 DATA (am( 7,k, 0),k=0, 2)
41376 & / -0.5327270e+01, -0.9293556e+00, 0.6629940e+00 /
41377 DATA (am( 8,k, 0),k=0, 2)
41378 & / 0.2437513e-01, 0.1600939e-02, 0.6855336e-03 /
41379
41380 DATA mexvec(-1) / 8 /
41381 DATA mlfvec(-1) / 2 /
41382 DATA ut1vec(-1) / 0.5243571e+01 /
41383 DATA ut2vec(-1) / -0.2870513e+01 /
41384 DATA alfvec(-1) / 0.6701448e+00 /
41385 DATA qmavec(-1) / 0.0000000e+00 /
41386 DATA (am( 0,k,-1),k=0, 2)
41387 & / 0.2428863e+02, 0.1907035e+01, -0.4606457e+00 /
41388 DATA (am( 1,k,-1),k=0, 2)
41389 & / 0.2006810e+01, -0.1265915e+00, 0.7153556e-02 /
41390 DATA (am( 2,k,-1),k=0, 2)
41391 & / -0.1884546e+02, -0.2339471e+01, 0.5740679e+01 /
41392 DATA (am( 3,k,-1),k=0, 2)
41393 & / -0.2527892e+02, -0.2044124e+01, 0.1280470e+02 /
41394 DATA (am( 4,k,-1),k=0, 2)
41395 & / -0.1013824e+03, -0.1594199e+01, 0.2216401e+00 /
41396 DATA (am( 5,k,-1),k=0, 2)
41397 & / 0.8070930e+02, 0.1792072e+01, -0.2164364e+02 /
41398 DATA (am( 6,k,-1),k=0, 2)
41399 & / -0.4641050e+02, 0.1977338e+00, 0.1273014e+02 /
41400 DATA (am( 7,k,-1),k=0, 2)
41401 & / -0.3910568e+02, 0.1719632e+01, 0.1086525e+02 /
41402 DATA (am( 8,k,-1),k=0, 2)
41403 & / -0.1185496e+01, -0.1905847e+00, -0.8744118e-03 /
41404
41405 DATA mexvec(-2) / 7 /
41406 DATA mlfvec(-2) / 2 /
41407 DATA ut1vec(-2) / 0.4782210e+01 /
41408 DATA ut2vec(-2) / -0.1976856e+02 /
41409 DATA alfvec(-2) / 0.7558374e+00 /
41410 DATA qmavec(-2) / 0.0000000e+00 /
41411 DATA (am( 0,k,-2),k=0, 2)
41412 & / -0.6216935e+00, 0.2369963e+00, -0.7909949e-02 /
41413 DATA (am( 1,k,-2),k=0, 2)
41414 & / 0.1245440e+01, -0.1031510e+00, 0.4916523e-02 /
41415 DATA (am( 2,k,-2),k=0, 2)
41416 & / -0.7060824e+01, -0.3875283e-01, 0.1784981e+00 /
41417 DATA (am( 3,k,-2),k=0, 2)
41418 & / -0.7430595e+01, 0.1964572e+00, -0.1284999e+00 /
41419 DATA (am( 4,k,-2),k=0, 2)
41420 & / -0.6897810e+01, 0.2620543e+01, 0.8012553e-02 /
41421 DATA (am( 5,k,-2),k=0, 2)
41422 & / 0.1507713e+02, 0.2340307e-01, 0.2482535e+01 /
41423 DATA (am( 6,k,-2),k=0, 2)
41424 & / -0.1815341e+01, -0.1538698e+01, -0.2014208e+01 /
41425 DATA (am( 7,k,-2),k=0, 2)
41426 & / -0.2571932e+02, 0.2903941e+00, -0.2848206e+01 /
41427
41428 DATA mexvec(-3) / 7 /
41429 DATA mlfvec(-3) / 2 /
41430 DATA ut1vec(-3) / 0.4518239e+01 /
41431 DATA ut2vec(-3) / -0.2690590e+01 /
41432 DATA alfvec(-3) / 0.6124079e+00 /
41433 DATA qmavec(-3) / 0.0000000e+00 /
41434 DATA (am( 0,k,-3),k=0, 2)
41435 & / -0.2734458e+01, -0.7245673e+00, -0.6351374e+00 /
41436 DATA (am( 1,k,-3),k=0, 2)
41437 & / 0.2927174e+01, 0.4822709e+00, -0.1088787e-01 /
41438 DATA (am( 2,k,-3),k=0, 2)
41439 & / -0.1771017e+02, -0.1416635e+01, 0.8467622e+01 /
41440 DATA (am( 3,k,-3),k=0, 2)
41441 & / -0.4972782e+02, -0.3348547e+01, 0.1767061e+02 /
41442 DATA (am( 4,k,-3),k=0, 2)
41443 & / -0.7102770e+01, -0.3205337e+01, 0.4101704e+00 /
41444 DATA (am( 5,k,-3),k=0, 2)
41445 & / 0.7169698e+02, -0.2205985e+01, -0.2463931e+02 /
41446 DATA (am( 6,k,-3),k=0, 2)
41447 & / -0.4090347e+02, 0.2103486e+01, 0.1416507e+02 /
41448 DATA (am( 7,k,-3),k=0, 2)
41449 & / -0.2952639e+02, 0.5376136e+01, 0.7825585e+01 /
41450
41451 DATA mexvec(-4) / 7 /
41452 DATA mlfvec(-4) / 2 /
41453 DATA ut1vec(-4) / 0.2783230e+01 /
41454 DATA ut2vec(-4) / -0.1746328e+01 /
41455 DATA alfvec(-4) / 0.1115653e+01 /
41456 DATA qmavec(-4) / 0.1300000e+01 /
41457 DATA (am( 0,k,-4),k=0, 2)
41458 & / -0.1743872e+01, -0.1128921e+01, -0.2841969e+00 /
41459 DATA (am( 1,k,-4),k=0, 2)
41460 & / 0.3345755e+01, 0.3187765e+00, 0.1378124e+00 /
41461 DATA (am( 2,k,-4),k=0, 2)
41462 & / -0.2037615e+02, 0.4121687e+01, 0.2236520e+00 /
41463 DATA (am( 3,k,-4),k=0, 2)
41464 & / -0.4703104e+02, 0.5353087e+01, -0.1455347e+01 /
41465 DATA (am( 4,k,-4),k=0, 2)
41466 & / -0.1060230e+02, -0.1551122e+01, -0.1078863e+01 /
41467 DATA (am( 5,k,-4),k=0, 2)
41468 & / 0.5088892e+02, -0.8197304e+01, 0.8083451e+01 /
41469 DATA (am( 6,k,-4),k=0, 2)
41470 & / -0.2819070e+02, 0.4554086e+01, -0.5890995e+01 /
41471 DATA (am( 7,k,-4),k=0, 2)
41472 & / -0.1098238e+02, 0.2590096e+01, -0.8062879e+01 /
41473
41474 DATA mexvec(-5) / 6 /
41475 DATA mlfvec(-5) / 2 /
41476 DATA ut1vec(-5) / 0.1619654e+02 /
41477 DATA ut2vec(-5) / -0.3367346e+01 /
41478 DATA alfvec(-5) / 0.5109891e-02 /
41479 DATA qmavec(-5) / 0.4500000e+01 /
41480 DATA (am( 0,k,-5),k=0, 2)
41481 & / -0.6800138e+01, 0.2493627e+01, -0.1075724e+01 /
41482 DATA (am( 1,k,-5),k=0, 2)
41483 & / 0.3036555e+01, 0.3324733e+00, 0.2008298e+00 /
41484 DATA (am( 2,k,-5),k=0, 2)
41485 & / -0.5203879e+01, -0.8493476e+01, -0.4523208e+01 /
41486 DATA (am( 3,k,-5),k=0, 2)
41487 & / -0.1524239e+01, -0.3411912e+01, -0.1771867e+02 /
41488 DATA (am( 4,k,-5),k=0, 2)
41489 & / -0.1099444e+02, 0.1320930e+01, -0.2353831e+01 /
41490 DATA (am( 5,k,-5),k=0, 2)
41491 & / 0.1699299e+02, -0.3565802e+02, 0.3566872e+02 /
41492 DATA (am( 6,k,-5),k=0, 2)
41493 & / -0.1465793e+02, 0.2703365e+02, -0.2176372e+02 /
41494
41495 IF(q .LE. qmavec(ifl)) THEN
41496 pyct5m = 0.d0
41497 RETURN
41498 ENDIF
41499
41500 IF(x .GE. 1.d0) THEN
41501 pyct5m = 0.d0
41502 RETURN
41503 ENDIF
41504
41505 tmp = log(q/alfvec(ifl))
41506 IF(tmp .LE. 0.d0) THEN
41507 pyct5m = 0.d0
41508 RETURN
41509 ENDIF
41510
41511 sb = log(tmp)
41512 sb1 = sb - 1.2d0
41513 sb2 = sb1*sb1
41514
41515 DO 110 i = 0, nex
41516 af(i) = 0.d0
41517 sbx = 1.d0
41518 DO 100 k = 0, mlfvec(ifl)
41519 af(i) = af(i) + sbx*am(i,k,ifl)
41520 sbx = sb1*sbx
41521 100 CONTINUE
41522 110 CONTINUE
41523
41524 y = -log(x)
41525 u = log(x/0.00001d0)
41526
41527 part1 = af(1)*y**(1.d0+0.01d0*af(4))*(1.d0+ af(8)*u)
41528 part2 = af(0)*(1.d0 - x) + af(3)*x
41529 part3 = x*(1.d0-x)*(af(5)+af(6)*(1.d0-x)+af(7)*x*(1.d0-x))
41530 part4 = ut1vec(ifl)*log(1.d0-x) +
41531 & af(2)*log(1.d0+exp(ut2vec(ifl))-x)
41532
41533 pyct5m = exp(log(x) + part1 + part2 + part3 + part4)
41534
41535C...Include threshold factor.
41536 pyct5m = pyct5m * (1.d0 - qmavec(ifl)/q)
41537
41538 RETURN
41539 END
41540
41541C*********************************************************************
41542
41543C...PYPDPO
41544C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41545C...a few older parametrizations, now obsolete but convenient for
41546C...backwards checks.
41547
41548 SUBROUTINE pypdpo(X,Q2,XPPR)
41549
41550C...Double precision and integer declarations.
41551 IMPLICIT DOUBLE PRECISION(a-h, o-z)
41552 IMPLICIT INTEGER(I-N)
41553 INTEGER PYK,PYCHGE,PYCOMP
41554C...Commonblocks.
41555 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
41556 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
41557 common/pypars/mstp(200),parp(200),msti(200),pari(200)
41558 common/pyint1/mint(400),vint(400)
41559 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/
41560 dimension xppr(-6:6),xq(9),tx(6),tt(6),ts(6),nehlq(8,2),
41561 &cehlq(6,6,2,8,2),cdo(3,6,5,2)
41562
41563
41564C...The following data lines are coefficients needed in the
41565C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41566C...parametrizations, see below.
41567C...Powers of 1-x in different cases.
41568 DATA nehlq/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41569C...Expansion coefficients for up valence quark distribution.
41570 DATA (((cehlq(ix,it,nx,1,1),ix=1,6),it=1,6),nx=1,2)/
41571 1 7.677d-01,-2.087d-01,-3.303d-01,-2.517d-02,-1.570d-02,-1.000d-04,
41572 2-5.326d-01,-2.661d-01, 3.201d-01, 1.192d-01, 2.434d-02, 7.620d-03,
41573 3 2.162d-01, 1.881d-01,-8.375d-02,-6.515d-02,-1.743d-02,-5.040d-03,
41574 4-9.211d-02,-9.952d-02, 1.373d-02, 2.506d-02, 8.770d-03, 2.550d-03,
41575 5 3.670d-02, 4.409d-02, 9.600d-04,-7.960d-03,-3.420d-03,-1.050d-03,
41576 6-1.549d-02,-2.026d-02,-3.060d-03, 2.220d-03, 1.240d-03, 4.100d-04,
41577 1 2.395d-01, 2.905d-01, 9.778d-02, 2.149d-02, 3.440d-03, 5.000d-04,
41578 2 1.751d-02,-6.090d-03,-2.687d-02,-1.916d-02,-7.970d-03,-2.750d-03,
41579 3-5.760d-03,-5.040d-03, 1.080d-03, 2.490d-03, 1.530d-03, 7.500d-04,
41580 4 1.740d-03, 1.960d-03, 3.000d-04,-3.400d-04,-2.900d-04,-1.800d-04,
41581 5-5.300d-04,-6.400d-04,-1.700d-04, 4.000d-05, 6.000d-05, 4.000d-05,
41582 6 1.700d-04, 2.200d-04, 8.000d-05, 1.000d-05,-1.000d-05,-1.000d-05/
41583 DATA (((cehlq(ix,it,nx,1,2),ix=1,6),it=1,6),nx=1,2)/
41584 1 7.237d-01,-2.189d-01,-2.995d-01,-1.909d-02,-1.477d-02, 2.500d-04,
41585 2-5.314d-01,-2.425d-01, 3.283d-01, 1.119d-01, 2.223d-02, 7.070d-03,
41586 3 2.289d-01, 1.890d-01,-9.859d-02,-6.900d-02,-1.747d-02,-5.080d-03,
41587 4-1.041d-01,-1.084d-01, 2.108d-02, 2.975d-02, 9.830d-03, 2.830d-03,
41588 5 4.394d-02, 5.116d-02,-1.410d-03,-1.055d-02,-4.230d-03,-1.270d-03,
41589 6-1.991d-02,-2.539d-02,-2.780d-03, 3.430d-03, 1.720d-03, 5.500d-04,
41590 1 2.410d-01, 2.884d-01, 9.369d-02, 1.900d-02, 2.530d-03, 2.400d-04,
41591 2 1.765d-02,-9.220d-03,-3.037d-02,-2.085d-02,-8.440d-03,-2.810d-03,
41592 3-6.450d-03,-5.260d-03, 1.720d-03, 3.110d-03, 1.830d-03, 8.700d-04,
41593 4 2.120d-03, 2.320d-03, 2.600d-04,-4.900d-04,-3.900d-04,-2.300d-04,
41594 5-6.900d-04,-8.200d-04,-2.000d-04, 7.000d-05, 9.000d-05, 6.000d-05,
41595 6 2.400d-04, 3.100d-04, 1.100d-04, 0.000d+00,-2.000d-05,-2.000d-05/
41596C...Expansion coefficients for down valence quark distribution.
41597 DATA (((cehlq(ix,it,nx,2,1),ix=1,6),it=1,6),nx=1,2)/
41598 1 3.813d-01,-8.090d-02,-1.634d-01,-2.185d-02,-8.430d-03,-6.200d-04,
41599 2-2.948d-01,-1.435d-01, 1.665d-01, 6.638d-02, 1.473d-02, 4.080d-03,
41600 3 1.252d-01, 1.042d-01,-4.722d-02,-3.683d-02,-1.038d-02,-2.860d-03,
41601 4-5.478d-02,-5.678d-02, 8.900d-03, 1.484d-02, 5.340d-03, 1.520d-03,
41602 5 2.220d-02, 2.567d-02,-3.000d-05,-4.970d-03,-2.160d-03,-6.500d-04,
41603 6-9.530d-03,-1.204d-02,-1.510d-03, 1.510d-03, 8.300d-04, 2.700d-04,
41604 1 1.261d-01, 1.354d-01, 3.958d-02, 8.240d-03, 1.660d-03, 4.500d-04,
41605 2 3.890d-03,-1.159d-02,-1.625d-02,-9.610d-03,-3.710d-03,-1.260d-03,
41606 3-1.910d-03,-5.600d-04, 1.590d-03, 1.590d-03, 8.400d-04, 3.900d-04,
41607 4 6.400d-04, 4.900d-04,-1.500d-04,-2.900d-04,-1.800d-04,-1.000d-04,
41608 5-2.000d-04,-1.900d-04, 0.000d+00, 6.000d-05, 4.000d-05, 3.000d-05,
41609 6 7.000d-05, 8.000d-05, 2.000d-05,-1.000d-05,-1.000d-05,-1.000d-05/
41610 DATA (((cehlq(ix,it,nx,2,2),ix=1,6),it=1,6),nx=1,2)/
41611 1 3.578d-01,-8.622d-02,-1.480d-01,-1.840d-02,-7.820d-03,-4.500d-04,
41612 2-2.925d-01,-1.304d-01, 1.696d-01, 6.243d-02, 1.353d-02, 3.750d-03,
41613 3 1.318d-01, 1.041d-01,-5.486d-02,-3.872d-02,-1.038d-02,-2.850d-03,
41614 4-6.162d-02,-6.143d-02, 1.303d-02, 1.740d-02, 5.940d-03, 1.670d-03,
41615 5 2.643d-02, 2.957d-02,-1.490d-03,-6.450d-03,-2.630d-03,-7.700d-04,
41616 6-1.218d-02,-1.497d-02,-1.260d-03, 2.240d-03, 1.120d-03, 3.500d-04,
41617 1 1.263d-01, 1.334d-01, 3.732d-02, 7.070d-03, 1.260d-03, 3.400d-04,
41618 2 3.660d-03,-1.357d-02,-1.795d-02,-1.031d-02,-3.880d-03,-1.280d-03,
41619 3-2.100d-03,-3.600d-04, 2.050d-03, 1.920d-03, 9.800d-04, 4.400d-04,
41620 4 7.700d-04, 5.400d-04,-2.400d-04,-3.900d-04,-2.400d-04,-1.300d-04,
41621 5-2.600d-04,-2.300d-04, 2.000d-05, 9.000d-05, 6.000d-05, 4.000d-05,
41622 6 9.000d-05, 1.000d-04, 2.000d-05,-2.000d-05,-2.000d-05,-1.000d-05/
41623C...Expansion coefficients for up and down sea quark distributions.
41624 DATA (((cehlq(ix,it,nx,3,1),ix=1,6),it=1,6),nx=1,2)/
41625 1 6.870d-02,-6.861d-02, 2.973d-02,-5.400d-03, 3.780d-03,-9.700d-04,
41626 2-1.802d-02, 1.400d-04, 6.490d-03,-8.540d-03, 1.220d-03,-1.750d-03,
41627 3-4.650d-03, 1.480d-03,-5.930d-03, 6.000d-04,-1.030d-03,-8.000d-05,
41628 4 6.440d-03, 2.570d-03, 2.830d-03, 1.150d-03, 7.100d-04, 3.300d-04,
41629 5-3.930d-03,-2.540d-03,-1.160d-03,-7.700d-04,-3.600d-04,-1.900d-04,
41630 6 2.340d-03, 1.930d-03, 5.300d-04, 3.700d-04, 1.600d-04, 9.000d-05,
41631 1 1.014d+00,-1.106d+00, 3.374d-01,-7.444d-02, 8.850d-03,-8.700d-04,
41632 2 9.233d-01,-1.285d+00, 4.475d-01,-9.786d-02, 1.419d-02,-1.120d-03,
41633 3 4.888d-02,-1.271d-01, 8.606d-02,-2.608d-02, 4.780d-03,-6.000d-04,
41634 4-2.691d-02, 4.887d-02,-1.771d-02, 1.620d-03, 2.500d-04,-6.000d-05,
41635 5 7.040d-03,-1.113d-02, 1.590d-03, 7.000d-04,-2.000d-04, 0.000d+00,
41636 6-1.710d-03, 2.290d-03, 3.800d-04,-3.500d-04, 4.000d-05, 1.000d-05/
41637 DATA (((cehlq(ix,it,nx,3,2),ix=1,6),it=1,6),nx=1,2)/
41638 1 1.008d-01,-7.100d-02, 1.973d-02,-5.710d-03, 2.930d-03,-9.900d-04,
41639 2-5.271d-02,-1.823d-02, 1.792d-02,-6.580d-03, 1.750d-03,-1.550d-03,
41640 3 1.220d-02, 1.763d-02,-8.690d-03,-8.800d-04,-1.160d-03,-2.100d-04,
41641 4-1.190d-03,-7.180d-03, 2.360d-03, 1.890d-03, 7.700d-04, 4.100d-04,
41642 5-9.100d-04, 2.040d-03,-3.100d-04,-1.050d-03,-4.000d-04,-2.400d-04,
41643 6 1.190d-03,-1.700d-04,-2.000d-04, 4.200d-04, 1.700d-04, 1.000d-04,
41644 1 1.081d+00,-1.189d+00, 3.868d-01,-8.617d-02, 1.115d-02,-1.180d-03,
41645 2 9.917d-01,-1.396d+00, 4.998d-01,-1.159d-01, 1.674d-02,-1.720d-03,
41646 3 5.099d-02,-1.338d-01, 9.173d-02,-2.885d-02, 5.890d-03,-6.500d-04,
41647 4-3.178d-02, 5.703d-02,-2.070d-02, 2.440d-03, 1.100d-04,-9.000d-05,
41648 5 8.970d-03,-1.392d-02, 2.050d-03, 6.500d-04,-2.300d-04, 2.000d-05,
41649 6-2.340d-03, 3.010d-03, 5.000d-04,-3.900d-04, 6.000d-05, 1.000d-05/
41650C...Expansion coefficients for gluon distribution.
41651 DATA (((cehlq(ix,it,nx,4,1),ix=1,6),it=1,6),nx=1,2)/
41652 1 9.482d-01,-9.578d-01, 1.009d-01,-1.051d-01, 3.456d-02,-3.054d-02,
41653 2-9.627d-01, 5.379d-01, 3.368d-01,-9.525d-02, 1.488d-02,-2.051d-02,
41654 3 4.300d-01,-8.306d-02,-3.372d-01, 4.902d-02,-9.160d-03, 1.041d-02,
41655 4-1.925d-01,-1.790d-02, 2.183d-01, 7.490d-03, 4.140d-03,-1.860d-03,
41656 5 8.183d-02, 1.926d-02,-1.072d-01,-1.944d-02,-2.770d-03,-5.200d-04,
41657 6-3.884d-02,-1.234d-02, 5.410d-02, 1.879d-02, 3.350d-03, 1.040d-03,
41658 1 2.948d+01,-3.902d+01, 1.464d+01,-3.335d+00, 5.054d-01,-5.915d-02,
41659 2 2.559d+01,-3.955d+01, 1.661d+01,-4.299d+00, 6.904d-01,-8.243d-02,
41660 3-1.663d+00, 1.176d+00, 1.118d+00,-7.099d-01, 1.948d-01,-2.404d-02,
41661 4-2.168d-01, 8.170d-01,-7.169d-01, 1.851d-01,-1.924d-02,-3.250d-03,
41662 5 2.088d-01,-4.355d-01, 2.239d-01,-2.446d-02,-3.620d-03, 1.910d-03,
41663 6-9.097d-02, 1.601d-01,-5.681d-02,-2.500d-03, 2.580d-03,-4.700d-04/
41664 DATA (((cehlq(ix,it,nx,4,2),ix=1,6),it=1,6),nx=1,2)/
41665 1 2.367d+00, 4.453d-01, 3.660d-01, 9.467d-02, 1.341d-01, 1.661d-02,
41666 2-3.170d+00,-1.795d+00, 3.313d-02,-2.874d-01,-9.827d-02,-7.119d-02,
41667 3 1.823d+00, 1.457d+00,-2.465d-01, 3.739d-02, 6.090d-03, 1.814d-02,
41668 4-1.033d+00,-9.827d-01, 2.136d-01, 1.169d-01, 5.001d-02, 1.684d-02,
41669 5 5.133d-01, 5.259d-01,-1.173d-01,-1.139d-01,-4.988d-02,-2.021d-02,
41670 6-2.881d-01,-3.145d-01, 5.667d-02, 9.161d-02, 4.568d-02, 1.951d-02,
41671 1 3.036d+01,-4.062d+01, 1.578d+01,-3.699d+00, 6.020d-01,-7.031d-02,
41672 2 2.700d+01,-4.167d+01, 1.770d+01,-4.804d+00, 7.862d-01,-1.060d-01,
41673 3-1.909d+00, 1.357d+00, 1.127d+00,-7.181d-01, 2.232d-01,-2.481d-02,
41674 4-2.488d-01, 9.781d-01,-8.127d-01, 2.094d-01,-2.997d-02,-4.710d-03,
41675 5 2.506d-01,-5.427d-01, 2.672d-01,-3.103d-02,-1.800d-03, 2.870d-03,
41676 6-1.128d-01, 2.087d-01,-6.972d-02,-2.480d-03, 2.630d-03,-8.400d-04/
41677C...Expansion coefficients for strange sea quark distribution.
41678 DATA (((cehlq(ix,it,nx,5,1),ix=1,6),it=1,6),nx=1,2)/
41679 1 4.968d-02,-4.173d-02, 2.102d-02,-3.270d-03, 3.240d-03,-6.700d-04,
41680 2-6.150d-03,-1.294d-02, 6.740d-03,-6.890d-03, 9.000d-04,-1.510d-03,
41681 3-8.580d-03, 5.050d-03,-4.900d-03,-1.600d-04,-9.400d-04,-1.500d-04,
41682 4 7.840d-03, 1.510d-03, 2.220d-03, 1.400d-03, 7.000d-04, 3.500d-04,
41683 5-4.410d-03,-2.220d-03,-8.900d-04,-8.500d-04,-3.600d-04,-2.000d-04,
41684 6 2.520d-03, 1.840d-03, 4.100d-04, 3.900d-04, 1.600d-04, 9.000d-05,
41685 1 9.235d-01,-1.085d+00, 3.464d-01,-7.210d-02, 9.140d-03,-9.100d-04,
41686 2 9.315d-01,-1.274d+00, 4.512d-01,-9.775d-02, 1.380d-02,-1.310d-03,
41687 3 4.739d-02,-1.296d-01, 8.482d-02,-2.642d-02, 4.760d-03,-5.700d-04,
41688 4-2.653d-02, 4.953d-02,-1.735d-02, 1.750d-03, 2.800d-04,-6.000d-05,
41689 5 6.940d-03,-1.132d-02, 1.480d-03, 6.500d-04,-2.100d-04, 0.000d+00,
41690 6-1.680d-03, 2.340d-03, 4.200d-04,-3.400d-04, 5.000d-05, 1.000d-05/
41691 DATA (((cehlq(ix,it,nx,5,2),ix=1,6),it=1,6),nx=1,2)/
41692 1 6.478d-02,-4.537d-02, 1.643d-02,-3.490d-03, 2.710d-03,-6.700d-04,
41693 2-2.223d-02,-2.126d-02, 1.247d-02,-6.290d-03, 1.120d-03,-1.440d-03,
41694 3-1.340d-03, 1.362d-02,-6.130d-03,-7.900d-04,-9.000d-04,-2.000d-04,
41695 4 5.080d-03,-3.610d-03, 1.700d-03, 1.830d-03, 6.800d-04, 4.000d-04,
41696 5-3.580d-03, 6.000d-05,-2.600d-04,-1.050d-03,-3.800d-04,-2.300d-04,
41697 6 2.420d-03, 9.300d-04,-1.000d-04, 4.500d-04, 1.700d-04, 1.100d-04,
41698 1 9.868d-01,-1.171d+00, 3.940d-01,-8.459d-02, 1.124d-02,-1.250d-03,
41699 2 1.001d+00,-1.383d+00, 5.044d-01,-1.152d-01, 1.658d-02,-1.830d-03,
41700 3 4.928d-02,-1.368d-01, 9.021d-02,-2.935d-02, 5.800d-03,-6.600d-04,
41701 4-3.133d-02, 5.785d-02,-2.023d-02, 2.630d-03, 1.600d-04,-8.000d-05,
41702 5 8.840d-03,-1.416d-02, 1.900d-03, 5.800d-04,-2.500d-04, 1.000d-05,
41703 6-2.300d-03, 3.080d-03, 5.500d-04,-3.700d-04, 7.000d-05, 1.000d-05/
41704C...Expansion coefficients for charm sea quark distribution.
41705 DATA (((cehlq(ix,it,nx,6,1),ix=1,6),it=1,6),nx=1,2)/
41706 1 9.270d-03,-1.817d-02, 9.590d-03,-6.390d-03, 1.690d-03,-1.540d-03,
41707 2 5.710d-03,-1.188d-02, 6.090d-03,-4.650d-03, 1.240d-03,-1.310d-03,
41708 3-3.960d-03, 7.100d-03,-3.590d-03, 1.840d-03,-3.900d-04, 3.400d-04,
41709 4 1.120d-03,-1.960d-03, 1.120d-03,-4.800d-04, 1.000d-04,-4.000d-05,
41710 5 4.000d-05,-3.000d-05,-1.800d-04, 9.000d-05,-5.000d-05,-2.000d-05,
41711 6-4.200d-04, 7.300d-04,-1.600d-04, 5.000d-05, 5.000d-05, 5.000d-05,
41712 1 8.098d-01,-1.042d+00, 3.398d-01,-6.824d-02, 8.760d-03,-9.000d-04,
41713 2 8.961d-01,-1.217d+00, 4.339d-01,-9.287d-02, 1.304d-02,-1.290d-03,
41714 3 3.058d-02,-1.040d-01, 7.604d-02,-2.415d-02, 4.600d-03,-5.000d-04,
41715 4-2.451d-02, 4.432d-02,-1.651d-02, 1.430d-03, 1.200d-04,-1.000d-04,
41716 5 1.122d-02,-1.457d-02, 2.680d-03, 5.800d-04,-1.200d-04, 3.000d-05,
41717 6-7.730d-03, 7.330d-03,-7.600d-04,-2.400d-04, 1.000d-05, 0.000d+00/
41718 DATA (((cehlq(ix,it,nx,6,2),ix=1,6),it=1,6),nx=1,2)/
41719 1 9.980d-03,-1.945d-02, 1.055d-02,-6.870d-03, 1.860d-03,-1.560d-03,
41720 2 5.700d-03,-1.203d-02, 6.250d-03,-4.860d-03, 1.310d-03,-1.370d-03,
41721 3-4.490d-03, 7.990d-03,-4.170d-03, 2.050d-03,-4.400d-04, 3.300d-04,
41722 4 1.470d-03,-2.480d-03, 1.460d-03,-5.700d-04, 1.200d-04,-1.000d-05,
41723 5-9.000d-05, 1.500d-04,-3.200d-04, 1.200d-04,-6.000d-05,-4.000d-05,
41724 6-4.200d-04, 7.600d-04,-1.400d-04, 4.000d-05, 7.000d-05, 5.000d-05,
41725 1 8.698d-01,-1.131d+00, 3.836d-01,-8.111d-02, 1.048d-02,-1.300d-03,
41726 2 9.626d-01,-1.321d+00, 4.854d-01,-1.091d-01, 1.583d-02,-1.700d-03,
41727 3 3.057d-02,-1.088d-01, 8.022d-02,-2.676d-02, 5.590d-03,-5.600d-04,
41728 4-2.845d-02, 5.164d-02,-1.918d-02, 2.210d-03,-4.000d-05,-1.500d-04,
41729 5 1.311d-02,-1.751d-02, 3.310d-03, 5.100d-04,-1.200d-04, 5.000d-05,
41730 6-8.590d-03, 8.380d-03,-9.200d-04,-2.600d-04, 1.000d-05,-1.000d-05/
41731C...Expansion coefficients for bottom sea quark distribution.
41732 DATA (((cehlq(ix,it,nx,7,1),ix=1,6),it=1,6),nx=1,2)/
41733 1 9.010d-03,-1.401d-02, 7.150d-03,-4.130d-03, 1.260d-03,-1.040d-03,
41734 2 6.280d-03,-9.320d-03, 4.780d-03,-2.890d-03, 9.100d-04,-8.200d-04,
41735 3-2.930d-03, 4.090d-03,-1.890d-03, 7.600d-04,-2.300d-04, 1.400d-04,
41736 4 3.900d-04,-1.200d-03, 4.400d-04,-2.500d-04, 2.000d-05,-2.000d-05,
41737 5 2.600d-04, 1.400d-04,-8.000d-05, 1.000d-04, 1.000d-05, 1.000d-05,
41738 6-2.600d-04, 3.200d-04, 1.000d-05,-1.000d-05, 1.000d-05,-1.000d-05,
41739 1 8.029d-01,-1.075d+00, 3.792d-01,-7.843d-02, 1.007d-02,-1.090d-03,
41740 2 7.903d-01,-1.099d+00, 4.153d-01,-9.301d-02, 1.317d-02,-1.410d-03,
41741 3-1.704d-02,-1.130d-02, 2.882d-02,-1.341d-02, 3.040d-03,-3.600d-04,
41742 4-7.200d-04, 7.230d-03,-5.160d-03, 1.080d-03,-5.000d-05,-4.000d-05,
41743 5 3.050d-03,-4.610d-03, 1.660d-03,-1.300d-04,-1.000d-05, 1.000d-05,
41744 6-4.360d-03, 5.230d-03,-1.610d-03, 2.000d-04,-2.000d-05, 0.000d+00/
41745 DATA (((cehlq(ix,it,nx,7,2),ix=1,6),it=1,6),nx=1,2)/
41746 1 8.980d-03,-1.459d-02, 7.510d-03,-4.410d-03, 1.310d-03,-1.070d-03,
41747 2 5.970d-03,-9.440d-03, 4.800d-03,-3.020d-03, 9.100d-04,-8.500d-04,
41748 3-3.050d-03, 4.440d-03,-2.100d-03, 8.500d-04,-2.400d-04, 1.400d-04,
41749 4 5.300d-04,-1.300d-03, 5.600d-04,-2.700d-04, 3.000d-05,-2.000d-05,
41750 5 2.000d-04, 1.400d-04,-1.100d-04, 1.000d-04, 0.000d+00, 0.000d+00,
41751 6-2.600d-04, 3.200d-04, 0.000d+00,-3.000d-05, 1.000d-05,-1.000d-05,
41752 1 8.672d-01,-1.174d+00, 4.265d-01,-9.252d-02, 1.244d-02,-1.460d-03,
41753 2 8.500d-01,-1.194d+00, 4.630d-01,-1.083d-01, 1.614d-02,-1.830d-03,
41754 3-2.241d-02,-5.630d-03, 2.815d-02,-1.425d-02, 3.520d-03,-4.300d-04,
41755 4-7.300d-04, 8.030d-03,-5.780d-03, 1.380d-03,-1.300d-04,-4.000d-05,
41756 5 3.460d-03,-5.380d-03, 1.960d-03,-2.100d-04, 1.000d-05, 1.000d-05,
41757 6-4.850d-03, 5.950d-03,-1.890d-03, 2.600d-04,-3.000d-05, 0.000d+00/
41758C...Expansion coefficients for top sea quark distribution.
41759 DATA (((cehlq(ix,it,nx,8,1),ix=1,6),it=1,6),nx=1,2)/
41760 1 4.410d-03,-7.480d-03, 3.770d-03,-2.580d-03, 7.300d-04,-7.100d-04,
41761 2 3.840d-03,-6.050d-03, 3.030d-03,-2.030d-03, 5.800d-04,-5.900d-04,
41762 3-8.800d-04, 1.660d-03,-7.500d-04, 4.700d-04,-1.000d-04, 1.000d-04,
41763 4-8.000d-05,-1.500d-04, 1.200d-04,-9.000d-05, 3.000d-05, 0.000d+00,
41764 5 1.300d-04,-2.200d-04,-2.000d-05,-2.000d-05,-2.000d-05,-2.000d-05,
41765 6-7.000d-05, 1.900d-04,-4.000d-05, 2.000d-05, 0.000d+00, 0.000d+00,
41766 1 6.623d-01,-9.248d-01, 3.519d-01,-7.930d-02, 1.110d-02,-1.180d-03,
41767 2 6.380d-01,-9.062d-01, 3.582d-01,-8.479d-02, 1.265d-02,-1.390d-03,
41768 3-2.581d-02, 2.125d-02, 4.190d-03,-4.980d-03, 1.490d-03,-2.100d-04,
41769 4 7.100d-04, 5.300d-04,-1.270d-03, 3.900d-04,-5.000d-05,-1.000d-05,
41770 5 3.850d-03,-5.060d-03, 1.860d-03,-3.500d-04, 4.000d-05, 0.000d+00,
41771 6-3.530d-03, 4.460d-03,-1.500d-03, 2.700d-04,-3.000d-05, 0.000d+00/
41772 DATA (((cehlq(ix,it,nx,8,2),ix=1,6),it=1,6),nx=1,2)/
41773 1 4.260d-03,-7.530d-03, 3.830d-03,-2.680d-03, 7.600d-04,-7.300d-04,
41774 2 3.640d-03,-6.050d-03, 3.030d-03,-2.090d-03, 5.900d-04,-6.000d-04,
41775 3-9.200d-04, 1.710d-03,-8.200d-04, 5.000d-04,-1.200d-04, 1.000d-04,
41776 4-5.000d-05,-1.600d-04, 1.300d-04,-9.000d-05, 3.000d-05, 0.000d+00,
41777 5 1.300d-04,-2.100d-04,-1.000d-05,-2.000d-05,-2.000d-05,-1.000d-05,
41778 6-8.000d-05, 1.800d-04,-5.000d-05, 2.000d-05, 0.000d+00, 0.000d+00,
41779 1 7.146d-01,-1.007d+00, 3.932d-01,-9.246d-02, 1.366d-02,-1.540d-03,
41780 2 6.856d-01,-9.828d-01, 3.977d-01,-9.795d-02, 1.540d-02,-1.790d-03,
41781 3-3.053d-02, 2.758d-02, 2.150d-03,-4.880d-03, 1.640d-03,-2.500d-04,
41782 4 9.200d-04, 4.200d-04,-1.340d-03, 4.600d-04,-8.000d-05,-1.000d-05,
41783 5 4.230d-03,-5.660d-03, 2.140d-03,-4.300d-04, 6.000d-05, 0.000d+00,
41784 6-3.890d-03, 5.000d-03,-1.740d-03, 3.300d-04,-4.000d-05, 0.000d+00/
41785
41786C...The following data lines are coefficients needed in the
41787C...Duke, Owens proton structure function parametrizations, see below.
41788C...Expansion coefficients for (up+down) valence quark distribution.
41789 DATA ((cdo(ip,is,1,1),is=1,6),ip=1,3)/
41790 1 4.190d-01, 3.460d+00, 4.400d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41791 2 4.000d-03, 7.240d-01,-4.860d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41792 3-7.000d-03,-6.600d-02, 1.330d+00, 0.000d+00, 0.000d+00, 0.000d+00/
41793 DATA ((cdo(ip,is,1,2),is=1,6),ip=1,3)/
41794 1 3.740d-01, 3.330d+00, 6.030d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41795 2 1.400d-02, 7.530d-01,-6.220d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41796 3 0.000d+00,-7.600d-02, 1.560d+00, 0.000d+00, 0.000d+00, 0.000d+00/
41797C...Expansion coefficients for down valence quark distribution.
41798 DATA ((cdo(ip,is,2,1),is=1,6),ip=1,3)/
41799 1 7.630d-01, 4.000d+00, 0.000d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41800 2-2.370d-01, 6.270d-01,-4.210d-01, 0.000d+00, 0.000d+00, 0.000d+00,
41801 3 2.600d-02,-1.900d-02, 3.300d-02, 0.000d+00, 0.000d+00, 0.000d+00/
41802 DATA ((cdo(ip,is,2,2),is=1,6),ip=1,3)/
41803 1 7.610d-01, 3.830d+00, 0.000d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41804 2-2.320d-01, 6.270d-01,-4.180d-01, 0.000d+00, 0.000d+00, 0.000d+00,
41805 3 2.300d-02,-1.900d-02, 3.600d-02, 0.000d+00, 0.000d+00, 0.000d+00/
41806C...Expansion coefficients for (up+down+strange) sea quark distribution.
41807 DATA ((cdo(ip,is,3,1),is=1,6),ip=1,3)/
41808 1 1.265d+00, 0.000d+00, 8.050d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41809 2-1.132d+00,-3.720d-01, 1.590d+00, 6.310d+00,-1.050d+01, 1.470d+01,
41810 3 2.930d-01,-2.900d-02,-1.530d-01,-2.730d-01,-3.170d+00, 9.800d+00/
41811 DATA ((cdo(ip,is,3,2),is=1,6),ip=1,3)/
41812 1 1.670d+00, 0.000d+00, 9.150d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41813 2-1.920d+00,-2.730d-01, 5.300d-01, 1.570d+01,-1.010d+02, 2.230d+02,
41814 3 5.820d-01,-1.640d-01,-7.630d-01,-2.830d+00, 4.470d+01,-1.170d+02/
41815C...Expansion coefficients for charm sea quark distribution.
41816 DATA ((cdo(ip,is,4,1),is=1,6),ip=1,3)/
41817 1 0.000d+00,-3.600d-02, 6.350d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41818 2 1.350d-01,-2.220d-01, 3.260d+00,-3.030d+00, 1.740d+01,-1.790d+01,
41819 3-7.500d-02,-5.800d-02,-9.090d-01, 1.500d+00,-1.130d+01, 1.560d+01/
41820 DATA ((cdo(ip,is,4,2),is=1,6),ip=1,3)/
41821 1 0.000d+00,-1.200d-01, 3.510d+00, 0.000d+00, 0.000d+00, 0.000d+00,
41822 2 6.700d-02,-2.330d-01, 3.660d+00,-4.740d-01, 9.500d+00,-1.660d+01,
41823 3-3.100d-02,-2.300d-02,-4.530d-01, 3.580d-01,-5.430d+00, 1.550d+01/
41824C...Expansion coefficients for gluon distribution.
41825 DATA ((cdo(ip,is,5,1),is=1,6),ip=1,3)/
41826 1 1.560d+00, 0.000d+00, 6.000d+00, 9.000d+00, 0.000d+00, 0.000d+00,
41827 2-1.710d+00,-9.490d-01, 1.440d+00,-7.190d+00,-1.650d+01, 1.530d+01,
41828 3 6.380d-01, 3.250d-01,-1.050d+00, 2.550d-01, 1.090d+01,-1.010d+01/
41829 DATA ((cdo(ip,is,5,2),is=1,6),ip=1,3)/
41830 1 8.790d-01, 0.000d+00, 4.000d+00, 9.000d+00, 0.000d+00, 0.000d+00,
41831 2-9.710d-01,-1.160d+00, 1.230d+00,-5.640d+00,-7.540d+00,-5.960d-01,
41832 3 4.340d-01, 4.760d-01,-2.540d-01,-8.170d-01, 5.500d+00, 1.260d-01/
41833
41834C...Euler's beta function, requires ordinary Gamma function
41835 eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)
41836
41837C...Leading order proton parton distributions from Glueck, Reya and
41838C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41839C...10^-5 < x < 1.
41840 IF(mstp(51).EQ.11) THEN
41841
41842C...Determine s expansion variable and some x expressions.
41843 q2in=min(1d8,max(0.25d0,q2))
41844 sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))
41845 sd2=sd**2
41846 xl=-log(x)
41847 xs=sqrt(x)
41848
41849C...Evaluate valence, gluon and sea distributions.
41850 xfvud=(0.663d0+0.191d0*sd-0.041d0*sd2+0.031d0*sd**3)*
41851 & x**0.326d0*(1d0+(-1.97d0+6.74d0*sd-1.96d0*sd2)*xs+
41852 & (24.4d0-20.7d0*sd+4.08d0*sd2)*x)*
41853 & (1d0-x)**(2.86d0+0.70d0*sd-0.02d0*sd2)
41854 xfvdd=(0.579d0+0.283d0*sd+0.047d0*sd2)*x**(0.523d0-0.015d0*sd)*
41855 & (1d0+(2.22d0-0.59d0*sd-0.27d0*sd2)*xs+(5.95d0-6.19d0*sd+
41856 & 1.55d0*sd2)*x)*(1d0-x)**(3.57d0+0.94d0*sd-0.16d0*sd2)
41857 xfglu=(x**(1.00d0-0.17d0*sd)*((4.879d0*sd-1.383d0*sd2)+
41858 & (25.92d0-28.97d0*sd+5.596d0*sd2)*x+(-25.69d0+23.68d0*sd-
41859 & 1.975d0*sd2)*x**2)+sd**0.558d0*exp(-(0.595d0+2.138d0*sd)+
41860 & sqrt(4.066d0*sd**1.218d0*xl)))*
41861 & (1d0-x)**(2.537d0+1.718d0*sd+0.353d0*sd2)
41862 xfsea=(x**(0.412d0-0.171d0*sd)*(0.363d0-1.196d0*x+(1.029d0+
41863 & 1.785d0*sd-0.459d0*sd2)*x**2)*xl**(0.566d0-0.496d0*sd)+
41864 & sd**1.396d0*exp(-(3.838d0+1.944d0*sd)+sqrt(2.845d0*sd**1.331d0*
41865 & xl)))*(1d0-x)**(4.696d0+2.109d0*sd)
41866 xfstr=sd**0.803d0*(1d0+(-3.055d0+1.024d0*sd**0.67d0)*xs+
41867 & (27.4d0-20.0d0*sd**0.154d0)*x)*(1d0-x)**6.22d0*
41868 & exp(-(4.33d0+1.408d0*sd)+sqrt((8.27d0-0.437d0*sd)*
41869 & sd**0.563d0*xl))/xl**(2.082d0-0.577d0*sd)
41870 IF(sd.LE.0.888d0) THEN
41871 xfchm=0d0
41872 ELSE
41873 xfchm=(sd-0.888d0)**1.01d0*(1.+(4.24d0-0.804d0*sd)*x)*
41874 & (1d0-x)**(3.46d0+1.076d0*sd)*exp(-(4.61d0+1.49d0*sd)+
41875 & sqrt((2.555d0+1.961d0*sd)*sd**0.37d0*xl))
41876 ENDIF
41877 IF(sd.LE.1.351d0) THEN
41878 xfbot=0d0
41879 ELSE
41880 xfbot=(sd-1.351d0)*(1d0+1.848d0*x)*(1d0-x)**(2.929d0+
41881 & 1.396d0*sd)*exp(-(4.71d0+1.514d0*sd)+
41882 & sqrt((4.02d0+1.239d0*sd)*sd**0.51d0*xl))
41883 ENDIF
41884
41885C...Put into output array.
41886 xppr(0)=xfglu
41887 xppr(1)=xfvdd+xfsea
41888 xppr(2)=xfvud-xfvdd+xfsea
41889 xppr(3)=xfstr
41890 xppr(4)=xfchm
41891 xppr(5)=xfbot
41892 xppr(-1)=xfsea
41893 xppr(-2)=xfsea
41894 xppr(-3)=xfstr
41895 xppr(-4)=xfchm
41896 xppr(-5)=xfbot
41897
41898C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41899C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41900 ELSEIF(mstp(51).EQ.12.OR.mstp(51).EQ.13) THEN
41901
41902C...Determine set, Lambda and x and t expansion variables.
41903 nset=mstp(51)-11
41904 IF(nset.EQ.1) alam=0.2d0
41905 IF(nset.EQ.2) alam=0.29d0
41906 tmin=log(5d0/alam**2)
41907 tmax=log(1d8/alam**2)
41908 t=log(max(1d0,q2/alam**2))
41909 vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
41910 nx=1
41911 IF(x.LE.0.1d0) nx=2
41912 IF(nx.EQ.1) vx=(2d0*x-1.1d0)/0.9d0
41913 IF(nx.EQ.2) vx=max(-1d0,(2d0*log(x)+11.51293d0)/6.90776d0)
41914
41915C...Chebyshev polynomials for x and t expansion.
41916 tx(1)=1d0
41917 tx(2)=vx
41918 tx(3)=2d0*vx**2-1d0
41919 tx(4)=4d0*vx**3-3d0*vx
41920 tx(5)=8d0*vx**4-8d0*vx**2+1d0
41921 tx(6)=16d0*vx**5-20d0*vx**3+5d0*vx
41922 tt(1)=1d0
41923 tt(2)=vt
41924 tt(3)=2d0*vt**2-1d0
41925 tt(4)=4d0*vt**3-3d0*vt
41926 tt(5)=8d0*vt**4-8d0*vt**2+1d0
41927 tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
41928
41929C...Calculate structure functions.
41930 DO 120 kfl=1,6
41931 xqsum=0d0
41932 DO 110 it=1,6
41933 DO 100 ix=1,6
41934 xqsum=xqsum+cehlq(ix,it,nx,kfl,nset)*tx(ix)*tt(it)
41935 100 CONTINUE
41936 110 CONTINUE
41937 xq(kfl)=xqsum*(1d0-x)**nehlq(kfl,nset)
41938 120 CONTINUE
41939
41940C...Put into output array.
41941 xppr(0)=xq(4)
41942 xppr(1)=xq(2)+xq(3)
41943 xppr(2)=xq(1)+xq(3)
41944 xppr(3)=xq(5)
41945 xppr(4)=xq(6)
41946 xppr(-1)=xq(3)
41947 xppr(-2)=xq(3)
41948 xppr(-3)=xq(5)
41949 xppr(-4)=xq(6)
41950
41951C...Special expansion for bottom (threshold effects).
41952 IF(mstp(58).GE.5) THEN
41953 IF(nset.EQ.1) tmin=8.1905d0
41954 IF(nset.EQ.2) tmin=7.4474d0
41955 IF(t.GT.tmin) THEN
41956 vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
41957 tt(1)=1d0
41958 tt(2)=vt
41959 tt(3)=2d0*vt**2-1d0
41960 tt(4)=4d0*vt**3-3d0*vt
41961 tt(5)=8d0*vt**4-8d0*vt**2+1d0
41962 tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
41963 xqsum=0d0
41964 DO 140 it=1,6
41965 DO 130 ix=1,6
41966 xqsum=xqsum+cehlq(ix,it,nx,7,nset)*tx(ix)*tt(it)
41967 130 CONTINUE
41968 140 CONTINUE
41969 xppr(5)=xqsum*(1d0-x)**nehlq(7,nset)
41970 xppr(-5)=xppr(5)
41971 ENDIF
41972 ENDIF
41973
41974C...Special expansion for top (threshold effects).
41975 IF(mstp(58).GE.6) THEN
41976 IF(nset.EQ.1) tmin=11.5528d0
41977 IF(nset.EQ.2) tmin=10.8097d0
41978 tmin=tmin+2d0*log(pmas(6,1)/30d0)
41979 tmax=tmax+2d0*log(pmas(6,1)/30d0)
41980 IF(t.GT.tmin) THEN
41981 vt=max(-1d0,min(1d0,(2d0*t-tmax-tmin)/(tmax-tmin)))
41982 tt(1)=1d0
41983 tt(2)=vt
41984 tt(3)=2d0*vt**2-1d0
41985 tt(4)=4d0*vt**3-3d0*vt
41986 tt(5)=8d0*vt**4-8d0*vt**2+1d0
41987 tt(6)=16d0*vt**5-20d0*vt**3+5d0*vt
41988 xqsum=0d0
41989 DO 160 it=1,6
41990 DO 150 ix=1,6
41991 xqsum=xqsum+cehlq(ix,it,nx,8,nset)*tx(ix)*tt(it)
41992 150 CONTINUE
41993 160 CONTINUE
41994 xppr(6)=xqsum*(1d0-x)**nehlq(8,nset)
41995 xppr(-6)=xppr(6)
41996 ENDIF
41997 ENDIF
41998
41999C...Proton parton distributions from Duke, Owens.
42000C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42001 ELSEIF(mstp(51).EQ.14.OR.mstp(51).EQ.15) THEN
42002
42003C...Determine set, Lambda and s expansion parameter.
42004 nset=mstp(51)-13
42005 IF(nset.EQ.1) alam=0.2d0
42006 IF(nset.EQ.2) alam=0.4d0
42007 q2in=min(1d6,max(4d0,q2))
42008 sd=log(log(q2in/alam**2)/log(4d0/alam**2))
42009
42010C...Calculate structure functions.
42011 DO 180 kfl=1,5
42012 DO 170 is=1,6
42013 ts(is)=cdo(1,is,kfl,nset)+cdo(2,is,kfl,nset)*sd+
42014 & cdo(3,is,kfl,nset)*sd**2
42015 170 CONTINUE
42016 IF(kfl.LE.2) THEN
42017 xq(kfl)=x**ts(1)*(1d0-x)**ts(2)*(1d0+ts(3)*x)/(eulbet(ts(1),
42018 & ts(2)+1d0)*(1d0+ts(3)*ts(1)/(ts(1)+ts(2)+1d0)))
42019 ELSE
42020 xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+
42021 & ts(5)*x**2+ts(6)*x**3)
42022 ENDIF
42023 180 CONTINUE
42024
42025C...Put into output arrays.
42026 xppr(0)=xq(5)
42027 xppr(1)=xq(2)+xq(3)/6d0
42028 xppr(2)=3d0*xq(1)-xq(2)+xq(3)/6d0
42029 xppr(3)=xq(3)/6d0
42030 xppr(4)=xq(4)
42031 xppr(-1)=xq(3)/6d0
42032 xppr(-2)=xq(3)/6d0
42033 xppr(-3)=xq(3)/6d0
42034 xppr(-4)=xq(4)
42035
42036 ENDIF
42037
42038 RETURN
42039 END
42040
42041C*********************************************************************
42042
42043C...PYHFTH
42044C...Gives threshold attractive/repulsive factor for heavy flavour
42045C...production.
42046
42047 FUNCTION pyhfth(SH,SQM,FRATT)
42048
42049C...Double precision and integer declarations.
42050 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42051 IMPLICIT INTEGER(I-N)
42052 INTEGER PYK,PYCHGE,PYCOMP
42053C...Commonblocks.
42054 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42055 common/pypars/mstp(200),parp(200),msti(200),pari(200)
42056 common/pyint1/mint(400),vint(400)
42057 SAVE /pydat1/,/pypars/,/pyint1/
42058
42059C...Value for alpha_strong.
42060 IF(mstp(35).LE.1) THEN
42061 alssg=parp(35)
42062 ELSE
42063 mst115=mstu(115)
42064 mstu(115)=mstp(36)
42065 q2bn=sqrt(max(1d0,sqm*((sqrt(sh)-2d0*sqrt(sqm))**2+
42066 & parp(36)**2)))
42067 alssg=pyalps(q2bn)
42068 mstu(115)=mst115
42069 ENDIF
42070
42071C...Evaluate attractive and repulsive factors.
42072 xattr=4d0*paru(1)*alssg/(3d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
42073 fattr=xattr/(1d0-exp(-min(50d0,xattr)))
42074 xrepu=paru(1)*alssg/(6d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))
42075 frepu=xrepu/(exp(min(50d0,xrepu))-1d0)
42076 pyhfth=fratt*fattr+(1d0-fratt)*frepu
42077 vint(138)=pyhfth
42078
42079 RETURN
42080 END
42081
42082C*********************************************************************
42083
42084C...PYSPLI
42085C...Splits a hadron remnant into two (partons or hadron + parton)
42086C...in case it is more complicated than just a quark or a diquark.
42087
42088 SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)
42089
42090C...Double precision and integer declarations.
42091 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42092 IMPLICIT INTEGER(I-N)
42093 INTEGER PYK,PYCHGE,PYCOMP
42094C...Commonblocks. PYDAT1 temporary
42095 common/pypars/mstp(200),parp(200),msti(200),pari(200)
42096 common/pyint1/mint(400),vint(400)
42097 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42098 SAVE /pypars/,/pyint1/,/pydat1/
42099C...Local array.
42100 dimension kfl(3)
42101
42102C...Preliminaries. Parton composition.
42103 kfa=iabs(kf)
42104 kfs=isign(1,kf)
42105 kfl(1)=mod(kfa/1000,10)
42106 kfl(2)=mod(kfa/100,10)
42107 kfl(3)=mod(kfa/10,10)
42108 IF(kfa.EQ.22.AND.mint(109).EQ.2) THEN
42109 kfl(2)=int(1.5d0+pyr(0))
42110 IF(mint(105).EQ.333) kfl(2)=3
42111 IF(mint(105).EQ.443) kfl(2)=4
42112 kfl(3)=kfl(2)
42113 ELSEIF((kfa.EQ.111.OR.kfa.EQ.113).AND.pyr(0).GT.0.5d0) THEN
42114 kfl(2)=2
42115 kfl(3)=2
42116 ELSEIF(kfa.EQ.223.AND.pyr(0).GT.0.5d0) THEN
42117 kfl(2)=1
42118 kfl(3)=1
42119 ELSEIF((kfa.EQ.130.OR.kfa.EQ.310).AND.pyr(0).GT.0.5d0) THEN
42120 kfl(2)=mod(kfa/10,10)
42121 kfl(3)=mod(kfa/100,10)
42122 ENDIF
42123 IF(kflin.NE.21.AND.kflin.NE.22.AND.kflin.NE.23) THEN
42124 kflr=kflin*kfs
42125 ELSE
42126 kflr=kflin
42127 ENDIF
42128 kflch=0
42129
42130C...Subdivide lepton.
42131 IF(kfa.GE.11.AND.kfa.LE.18) THEN
42132 IF(kflr.EQ.kfa) THEN
42133 kflsp=kfs*22
42134 ELSEIF(kflr.EQ.22) THEN
42135 kflsp=kfa
42136 ELSEIF(kflr.EQ.-24.AND.mod(kfa,2).EQ.1) THEN
42137 kflsp=kfa+1
42138 ELSEIF(kflr.EQ.24.AND.mod(kfa,2).EQ.0) THEN
42139 kflsp=kfa-1
42140 ELSEIF(kflr.EQ.21) THEN
42141 kflsp=kfa
42142 kflch=kfs*21
42143 ELSE
42144 kflsp=kfa
42145 kflch=-kflr
42146 ENDIF
42147
42148C...Subdivide photon.
42149 ELSEIF(kfa.EQ.22.AND.mint(109).NE.2) THEN
42150 IF(kflr.NE.21) THEN
42151 kflsp=-kflr
42152 ELSE
42153 ragr=0.75d0*pyr(0)
42154 kflsp=1
42155 IF(ragr.GT.0.125d0) kflsp=2
42156 IF(ragr.GT.0.625d0) kflsp=3
42157 IF(pyr(0).GT.0.5d0) kflsp=-kflsp
42158 kflch=-kflsp
42159 ENDIF
42160
42161C...Subdivide Reggeon or Pomeron.
42162 ELSEIF(kfa.EQ.110.OR.kfa.EQ.990) THEN
42163 IF(kflin.EQ.21) THEN
42164 kflsp=kfs*21
42165 ELSE
42166 kflsp=-kflin
42167 ENDIF
42168
42169C...Subdivide meson.
42170 ELSEIF(kfl(1).EQ.0) THEN
42171 kfl(2)=kfl(2)*(-1)**kfl(2)
42172 kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))
42173 IF(kflr.EQ.kfl(2)) THEN
42174 kflsp=kfl(3)
42175 ELSEIF(kflr.EQ.kfl(3)) THEN
42176 kflsp=kfl(2)
42177 ELSEIF(kflr.EQ.21.AND.pyr(0).GT.0.5d0) THEN
42178 kflsp=kfl(2)
42179 kflch=kfl(3)
42180 ELSEIF(kflr.EQ.21) THEN
42181 kflsp=kfl(3)
42182 kflch=kfl(2)
42183 ELSEIF(kflr*kfl(2).GT.0) THEN
42184 ntry=0
42185 100 ntry=ntry+1
42186 CALL pykfdi(-kflr,kfl(2),kfdump,kflch)
42187 IF(kflch.EQ.0.AND.ntry.LT.100) THEN
42188 GOTO 100
42189 ELSEIF(kflch.EQ.0) THEN
42190 CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
42191 mint(51)=1
42192 RETURN
42193 ENDIF
42194 kflsp=kfl(3)
42195 ELSE
42196 ntry=0
42197 110 ntry=ntry+1
42198 CALL pykfdi(-kflr,kfl(3),kfdump,kflch)
42199 IF(kflch.EQ.0.AND.ntry.LT.100) THEN
42200 GOTO 110
42201 ELSEIF(kflch.EQ.0) THEN
42202 CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
42203 mint(51)=1
42204 RETURN
42205 ENDIF
42206 kflsp=kfl(2)
42207 ENDIF
42208
42209C...Special case for extracting photon from baryon without splitting
42210C...the latter. (Currently only used by external programs.)
42211 ELSEIF(kflin.EQ.22.AND.mstp(98).EQ.1) then
42212 kflsp=kfa
42213 kflch=0
42214
42215C...Subdivide baryon.
42216 ELSE
42217 nagr=0
42218 DO 120 j=1,3
42219 IF(kflr.EQ.kfl(j)) nagr=nagr+1
42220 120 CONTINUE
42221 IF(nagr.GE.1) THEN
42222 ragr=0.00001d0+(nagr-0.00002d0)*pyr(0)
42223 iagr=0
42224 DO 130 j=1,3
42225 IF(kflr.EQ.kfl(j)) ragr=ragr-1d0
42226 IF(iagr.EQ.0.AND.ragr.LE.0d0) iagr=j
42227 130 CONTINUE
42228 ELSE
42229 iagr=1.00001d0+2.99998d0*pyr(0)
42230 ENDIF
42231 id1=1
42232 IF(iagr.EQ.1) id1=2
42233 IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3
42234 id2=6-iagr-id1
42235 ksp=3
42236 IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN
42237 IF(iagr.NE.3.AND.pyr(0).GT.0.25d0) ksp=1
42238 ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN
42239 IF(iagr.NE.1.AND.pyr(0).GT.0.25d0) ksp=1
42240 ELSEIF(mod(kfa,10).EQ.2) THEN
42241 IF(iagr.EQ.1) ksp=1
42242 IF(iagr.NE.1.AND.pyr(0).GT.0.75d0) ksp=1
42243 ENDIF
42244 kflsp=1000*kfl(id1)+100*kfl(id2)+ksp
42245 IF(kflr.EQ.21) THEN
42246 kflch=kfl(iagr)
42247 ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN
42248 ntry=0
42249 140 ntry=ntry+1
42250 CALL pykfdi(-kflr,kfl(iagr),kfdump,kflch)
42251 IF(kflch.EQ.0.AND.ntry.LT.100) THEN
42252 GOTO 140
42253 ELSEIF(kflch.EQ.0) THEN
42254 CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
42255 mint(51)=1
42256 RETURN
42257 ENDIF
42258 ELSEIF(nagr.EQ.0) THEN
42259 ntry=0
42260 150 ntry=ntry+1
42261 CALL pykfdi(10000*kfl(id1)+kflsp,-kflr,kfdump,kflch)
42262 IF(kflch.EQ.0.AND.ntry.LT.100) THEN
42263 GOTO 150
42264 ELSEIF(kflch.EQ.0) THEN
42265 CALL pyerrm(14,'(PYSPLI:) caught in infinite loop')
42266 mint(51)=1
42267 RETURN
42268 ENDIF
42269 kflsp=kfl(iagr)
42270 ENDIF
42271 ENDIF
42272
42273C...Add on correct sign for result.
42274 kflch=kflch*kfs
42275 kflsp=kflsp*kfs
42276
42277 RETURN
42278 END
42279
42280C*********************************************************************
42281
42282C...PYGAMM
42283C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42284C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42285C...(Dover, 1965) 6.1.36.
42286
42287 FUNCTION pygamm(X)
42288
42289C...Double precision and integer declarations.
42290 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42291 IMPLICIT INTEGER(I-N)
42292 INTEGER PYK,PYCHGE,PYCOMP
42293C...Local array and data.
42294 dimension b(8)
42295 DATA b/-0.577191652d0,0.988205891d0,-0.897056937d0,0.918206857d0,
42296 &-0.756704078d0,0.482199394d0,-0.193527818d0,0.035868343d0/
42297
42298 nx=int(x)
42299 dx=x-nx
42300
42301 pygamm=1d0
42302 dxp=1d0
42303 DO 100 i=1,8
42304 dxp=dxp*dx
42305 pygamm=pygamm+b(i)*dxp
42306 100 CONTINUE
42307 IF(x.LT.1d0) THEN
42308 pygamm=pygamm/x
42309 ELSE
42310 DO 110 ix=1,nx-1
42311 pygamm=(x-ix)*pygamm
42312 110 CONTINUE
42313 ENDIF
42314
42315 RETURN
42316 END
42317
42318C***********************************************************************
42319
42320C...PYWAUX
42321C...Calculates real and imaginary parts of the auxiliary functions W1
42322C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42323C...der Bij, Nucl. Phys. B297 (1988) 221.
42324
42325 SUBROUTINE pywaux(IAUX,EPS,WRE,WIM)
42326
42327C...Double precision and integer declarations.
42328 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42329 IMPLICIT INTEGER(I-N)
42330 INTEGER PYK,PYCHGE,PYCOMP
42331C...Commonblocks.
42332 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42333 SAVE /pydat1/
42334
42335 asinh(x)=log(x+sqrt(x**2+1d0))
42336 acosh(x)=log(x+sqrt(x**2-1d0))
42337
42338 IF(eps.LT.0d0) THEN
42339 IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*asinh(sqrt(-1d0/eps))
42340 IF(iaux.EQ.2) wre=4d0*(asinh(sqrt(-1d0/eps)))**2
42341 wim=0d0
42342 ELSEIF(eps.LT.1d0) THEN
42343 IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*acosh(sqrt(1d0/eps))
42344 IF(iaux.EQ.2) wre=4d0*(acosh(sqrt(1d0/eps)))**2-paru(1)**2
42345 IF(iaux.EQ.1) wim=-paru(1)*sqrt(1d0-eps)
42346 IF(iaux.EQ.2) wim=-4d0*paru(1)*acosh(sqrt(1d0/eps))
42347 ELSE
42348 IF(iaux.EQ.1) wre=2d0*sqrt(eps-1d0)*asin(sqrt(1d0/eps))
42349 IF(iaux.EQ.2) wre=-4d0*(asin(sqrt(1d0/eps)))**2
42350 wim=0d0
42351 ENDIF
42352
42353 RETURN
42354 END
42355
42356C***********************************************************************
42357
42358C...PYI3AU
42359C...Calculates real and imaginary parts of the auxiliary function I3;
42360C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42361C...Nucl. Phys. B297 (1988) 221.
42362
42363 SUBROUTINE pyi3au(EPS,RAT,Y3RE,Y3IM)
42364
42365C...Double precision and integer declarations.
42366 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42367 IMPLICIT INTEGER(I-N)
42368 INTEGER PYK,PYCHGE,PYCOMP
42369C...Commonblocks.
42370 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42371 SAVE /pydat1/
42372
42373 be=0.5d0*(1d0+sqrt(1d0+rat*eps))
42374 IF(eps.LT.1d0) ga=0.5d0*(1d0+sqrt(1d0-eps))
42375
42376 IF(eps.LT.0d0) THEN
42377 IF(abs(eps).LT.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
42378 f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
42379 & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
42380 & pyspen(0.25d0*(rat+1d0)*eps/(1d0+0.25d0*rat*eps),0d0,1)-
42381 & pyspen((rat+1d0)/rat,0d0,1)+0.5d0*(log(1d0+0.25d0*rat*eps)**2-
42382 & log(0.25d0*rat*eps)**2)+log(1d0-0.25d0*eps)*
42383 & log((1d0+0.25d0*(rat-1d0)*eps)/(1d0+0.25d0*rat*eps))+
42384 & log(-0.25d0*eps)*log(0.25d0*rat*eps/(1d0+0.25d0*(rat-1d0)*
42385 & eps))
42386 ELSEIF(abs(eps).LT.1d-4.AND.abs(rat*eps).GE.1d-4) THEN
42387 f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
42388 & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
42389 & pyspen((be-1d0+0.25d0*eps)/be,0d0,1)-
42390 & pyspen((be-1d0+0.25d0*eps)/(be-1d0),0d0,1)+
42391 & 0.5d0*(log(be)**2-log(be-1d0)**2)+
42392 & log(1d0-0.25d0*eps)*log((be-0.25d0*eps)/be)+
42393 & log(-0.25d0*eps)*log((be-1d0)/(be-0.25d0*eps))
42394 ELSEIF(abs(eps).GE.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
42395 f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
42396 & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
42397 & pyspen((1d0+0.25d0*rat*eps-ga)/(1d0+0.25d0*rat*eps),0d0,1)-
42398 & pyspen((1d0+0.25d0*rat*eps-ga)/(0.25d0*rat*eps),0d0,1)+
42399 & 0.5d0*(log(1d0+0.25d0*rat*eps)**2-log(0.25d0*rat*eps)**2)+
42400 & log(ga)*log((ga+0.25d0*rat*eps)/(1d0+0.25d0*rat*eps))+
42401 & log(ga-1d0)*log(0.25d0*rat*eps/(ga+0.25d0*rat*eps))
42402 ELSE
42403 f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
42404 & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen((be-ga)/be,0d0,1)-
42405 & pyspen((be-ga)/(be-1d0),0d0,1)+0.5d0*(log(be)**2-
42406 & log(be-1d0)**2)+log(ga)*log((ga+be-1d0)/be)+
42407 & log(ga-1d0)*log((be-1d0)/(ga+be-1d0))
42408 ENDIF
42409 f3im=0d0
42410 ELSEIF(eps.LT.1d0) THEN
42411 IF(abs(eps).LT.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
42412 f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-
42413 & pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+
42414 & pyspen((1d0-0.25d0*eps)/(-0.25d0*(rat+1d0)*eps),0d0,1)-
42415 & pyspen(1d0/(rat+1d0),0d0,1)+log((1d0-0.25d0*eps)/
42416 & (0.25d0*eps))*log((1d0+0.25d0*(rat-1d0)*eps)/
42417 & (0.25d0*(rat+1d0)*eps))
42418 f3im=-paru(1)*log((1d0+0.25d0*(rat-1d0)*eps)/
42419 & (0.25d0*(rat+1d0)*eps))
42420 ELSEIF(abs(eps).LT.1d-4.AND.abs(rat*eps).GE.1d-4) THEN
42421 f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-
42422 & pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+
42423 & pyspen((1d0-0.25d0*eps)/(1d0-0.25d0*eps-be),0d0,1)-
42424 & pyspen(-0.25d0*eps/(1d0-0.25d0*eps-be),0d0,1)+
42425 & log((1d0-0.25d0*eps)/(0.25d0*eps))*
42426 & log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
42427 f3im=-paru(1)*log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))
42428 ELSEIF(abs(eps).GE.1d-4.AND.abs(rat*eps).LT.1d-4) THEN
42429 f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-
42430 & pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+
42431 & pyspen(ga/(ga-1d0-0.25d0*rat*eps),0d0,1)-
42432 & pyspen((ga-1d0)/(ga-1d0-0.25d0*rat*eps),0d0,1)+
42433 & log(ga/(1d0-ga))*log((ga+0.25d0*rat*eps)/
42434 & (1d0+0.25d0*rat*eps-ga))
42435 f3im=-paru(1)*log((ga+0.25d0*rat*eps)/
42436 & (1d0+0.25d0*rat*eps-ga))
42437 ELSE
42438 f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-
42439 & pyspen(ga/(ga+be-1d0),0d0,1)+pyspen(ga/(ga-be),0d0,1)-
42440 & pyspen((ga-1d0)/(ga-be),0d0,1)+log(ga/(1d0-ga))*
42441 & log((ga+be-1d0)/(be-ga))
42442 f3im=-paru(1)*log((ga+be-1d0)/(be-ga))
42443 ENDIF
42444 ELSE
42445 rsq=eps/(eps-1d0+(2d0*be-1d0)**2)
42446 rcthe=rsq*(1d0-2d0*be/eps)
42447 rsthe=sqrt(max(0d0,rsq-rcthe**2))
42448 rcphi=rsq*(1d0+2d0*(be-1d0)/eps)
42449 rsphi=sqrt(max(0d0,rsq-rcphi**2))
42450 r=sqrt(rsq)
42451 the=acos(max(-0.999999d0,min(0.999999d0,rcthe/r)))
42452 phi=acos(max(-0.999999d0,min(0.999999d0,rcphi/r)))
42453 f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-
42454 & pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+
42455 & (phi-the)*(phi+the-paru(1))
42456 f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-
42457 & pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)
42458 ENDIF
42459
42460 y3re=2d0/(2d0*be-1d0)*f3re
42461 y3im=2d0/(2d0*be-1d0)*f3im
42462
42463 RETURN
42464 END
42465
42466C***********************************************************************
42467
42468C...PYSPEN
42469C...Calculates real and imaginary part of Spence function; see
42470C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42471
42472 FUNCTION pyspen(XREIN,XIMIN,IREIM)
42473
42474C...Double precision and integer declarations.
42475 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42476 IMPLICIT INTEGER(I-N)
42477 INTEGER PYK,PYCHGE,PYCOMP
42478C...Commonblocks.
42479 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42480 SAVE /pydat1/
42481C...Local array and data.
42482 dimension b(0:14)
42483 DATA b/
42484 &1.000000d+00, -5.000000d-01, 1.666667d-01,
42485 &0.000000d+00, -3.333333d-02, 0.000000d+00,
42486 &2.380952d-02, 0.000000d+00, -3.333333d-02,
42487 &0.000000d+00, 7.575757d-02, 0.000000d+00,
42488 &-2.531135d-01, 0.000000d+00, 1.166667d+00/
42489
42490 xre=xrein
42491 xim=ximin
42492 IF(abs(1d0-xre).LT.1d-6.AND.abs(xim).LT.1d-6) THEN
42493 IF(ireim.EQ.1) pyspen=paru(1)**2/6d0
42494 IF(ireim.EQ.2) pyspen=0d0
42495 RETURN
42496 ENDIF
42497
42498 xmod=sqrt(xre**2+xim**2)
42499 IF(xmod.LT.1d-6) THEN
42500 IF(ireim.EQ.1) pyspen=0d0
42501 IF(ireim.EQ.2) pyspen=0d0
42502 RETURN
42503 ENDIF
42504
42505 xarg=sign(acos(xre/xmod),xim)
42506 sp0re=0d0
42507 sp0im=0d0
42508 sgn=1d0
42509 IF(xmod.GT.1d0) THEN
42510 algxre=log(xmod)
42511 algxim=xarg-sign(paru(1),xarg)
42512 sp0re=-paru(1)**2/6d0-(algxre**2-algxim**2)/2d0
42513 sp0im=-algxre*algxim
42514 sgn=-1d0
42515 xmod=1d0/xmod
42516 xarg=-xarg
42517 xre=xmod*cos(xarg)
42518 xim=xmod*sin(xarg)
42519 ENDIF
42520 IF(xre.GT.0.5d0) THEN
42521 algxre=log(xmod)
42522 algxim=xarg
42523 xre=1d0-xre
42524 xim=-xim
42525 xmod=sqrt(xre**2+xim**2)
42526 xarg=sign(acos(xre/xmod),xim)
42527 algyre=log(xmod)
42528 algyim=xarg
42529 sp0re=sp0re+sgn*(paru(1)**2/6d0-(algxre*algyre-algxim*algyim))
42530 sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)
42531 sgn=-sgn
42532 ENDIF
42533
42534 xre=1d0-xre
42535 xim=-xim
42536 xmod=sqrt(xre**2+xim**2)
42537 xarg=sign(acos(xre/xmod),xim)
42538 zre=-log(xmod)
42539 zim=-xarg
42540
42541 spre=0d0
42542 spim=0d0
42543 savere=1d0
42544 saveim=0d0
42545 DO 100 i=0,14
42546 IF(max(abs(savere),abs(saveim)).LT.1d-30) GOTO 110
42547 termre=(savere*zre-saveim*zim)/dble(i+1)
42548 termim=(savere*zim+saveim*zre)/dble(i+1)
42549 savere=termre
42550 saveim=termim
42551 spre=spre+b(i)*termre
42552 spim=spim+b(i)*termim
42553 100 CONTINUE
42554
42555 110 IF(ireim.EQ.1) pyspen=sp0re+sgn*spre
42556 IF(ireim.EQ.2) pyspen=sp0im+sgn*spim
42557
42558 RETURN
42559 END
42560
42561C***********************************************************************
42562
42563C...PYQQBH
42564C...Calculates the matrix element for the processes
42565C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42566C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42567C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42568
42569 SUBROUTINE pyqqbh(WTQQBH)
42570
42571C...Double precision and integer declarations.
42572 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42573 IMPLICIT INTEGER(I-N)
42574 INTEGER PYK,PYCHGE,PYCOMP
42575C...Commonblocks.
42576 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42577 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
42578 common/pypars/mstp(200),parp(200),msti(200),pari(200)
42579 common/pyint1/mint(400),vint(400)
42580 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
42581 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/
42582C...Local arrays and function.
42583 dimension pp(15,4),clr(8,8),fm(10,10),rm(8,8),dx(8)
42584 dot(i,j)=pp(i,4)*pp(j,4)-pp(i,1)*pp(j,1)-pp(i,2)*pp(j,2)-
42585 &pp(i,3)*pp(j,3)
42586
42587C...Mass parameters.
42588 wtqqbh=0d0
42589 isub=mint(1)
42590 shpr=sqrt(vint(26))*vint(1)
42591 pq=pmas(pycomp(kfpr(isub,2)),1)
42592 ph=sqrt(vint(21))*vint(1)
42593 spq=pq**2
42594 sph=ph**2
42595
42596C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42597 DO 100 i=1,2
42598 pt=sqrt(max(0d0,vint(197+5*i)))
42599 pp(i,1)=pt*cos(vint(198+5*i))
42600 pp(i,2)=pt*sin(vint(198+5*i))
42601 100 CONTINUE
42602 pp(3,1)=-pp(1,1)-pp(2,1)
42603 pp(3,2)=-pp(1,2)-pp(2,2)
42604 pms1=spq+pp(1,1)**2+pp(1,2)**2
42605 pms2=spq+pp(2,1)**2+pp(2,2)**2
42606 pms3=sph+pp(3,1)**2+pp(3,2)**2
42607 pmt3=sqrt(pms3)
42608 pp(3,3)=pmt3*sinh(vint(211))
42609 pp(3,4)=pmt3*cosh(vint(211))
42610 pms12=(shpr-pp(3,4))**2-pp(3,3)**2
42611 pp(1,3)=(-pp(3,3)*(pms12+pms1-pms2)+
42612 &vint(213)*(shpr-pp(3,4))*vint(220))/(2d0*pms12)
42613 pp(2,3)=-pp(1,3)-pp(3,3)
42614 pp(1,4)=sqrt(pms1+pp(1,3)**2)
42615 pp(2,4)=sqrt(pms2+pp(2,3)**2)
42616
42617C...Set up incoming kinematics and derived momentum combinations.
42618 DO 110 i=4,5
42619 pp(i,1)=0d0
42620 pp(i,2)=0d0
42621 pp(i,3)=-0.5d0*shpr*(-1)**i
42622 pp(i,4)=-0.5d0*shpr
42623 110 CONTINUE
42624 DO 120 j=1,4
42625 pp(6,j)=pp(1,j)+pp(2,j)
42626 pp(7,j)=pp(1,j)+pp(3,j)
42627 pp(8,j)=pp(1,j)+pp(4,j)
42628 pp(9,j)=pp(1,j)+pp(5,j)
42629 pp(10,j)=-pp(2,j)-pp(3,j)
42630 pp(11,j)=-pp(2,j)-pp(4,j)
42631 pp(12,j)=-pp(2,j)-pp(5,j)
42632 pp(13,j)=-pp(4,j)-pp(5,j)
42633 120 CONTINUE
42634
42635C...Derived kinematics invariants.
42636 x1=dot(1,2)
42637 x2=dot(1,3)
42638 x3=dot(1,4)
42639 x4=dot(1,5)
42640 x5=dot(2,3)
42641 x6=dot(2,4)
42642 x7=dot(2,5)
42643 x8=dot(3,4)
42644 x9=dot(3,5)
42645 x10=dot(4,5)
42646
42647C...Propagators.
42648 ss1=dot(7,7)-spq
42649 ss2=dot(8,8)-spq
42650 ss3=dot(9,9)-spq
42651 ss4=dot(10,10)-spq
42652 ss5=dot(11,11)-spq
42653 ss6=dot(12,12)-spq
42654 ss7=dot(13,13)
42655 dx(1)=ss1*ss6
42656 dx(2)=ss2*ss6
42657 dx(3)=ss2*ss4
42658 dx(4)=ss1*ss5
42659 dx(5)=ss3*ss5
42660 dx(6)=ss3*ss4
42661 dx(7)=ss7*ss1
42662 dx(8)=ss7*ss4
42663
42664C...Define colour coefficients for g + g -> Q + Qbar + H.
42665 IF(isub.EQ.121.OR.isub.EQ.181.OR.isub.EQ.186) THEN
42666 DO 140 i=1,3
42667 DO 130 j=1,3
42668 clr(i,j)=16d0/3d0
42669 clr(i+3,j+3)=16d0/3d0
42670 clr(i,j+3)=-2d0/3d0
42671 clr(i+3,j)=-2d0/3d0
42672 130 CONTINUE
42673 140 CONTINUE
42674 DO 160 l=1,2
42675 DO 150 i=1,3
42676 clr(i,6+l)=-6d0
42677 clr(i+3,6+l)=6d0
42678 clr(6+l,i)=-6d0
42679 clr(6+l,i+3)=6d0
42680 150 CONTINUE
42681 160 CONTINUE
42682 DO 180 k1=1,2
42683 DO 170 k2=1,2
42684 clr(6+k1,6+k2)=12d0
42685 170 CONTINUE
42686 180 CONTINUE
42687
42688C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42689 fm(1,1)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x4+x9+2*
42690 & x7+x5)+8*pq**2*ph**2*(-x1-x4+2*x7)+16*pq**2*(x2*x9+4*x2*
42691 & x7+x2*x5-2*x4*x7-2*x9*x7)+8*ph**2*x4*x7-16*x2*x9*x7
42692 fm(1,2)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10+x9-x8+2
42693 & *x7-4*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x4-2*x2*x10+x2*x7-2*
42694 & x2*x6-2*x3*x7+2*x4*x7+4*x10*x7-x9*x7-x8*x7)+16*x2*x7*(x4+
42695 & x10)
42696 fm(1,3)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-2*x3-4*
42697 & x4-8*x10+x9+x8-2*x7-4*x6+2*x5)-(4*pq**2*ph**2)*(x1+x4+x10
42698 & +x6)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
42699 & -4*x2*x4-5*x2*x10+x2*x8-x2*x7-3*x2*x6+x2*x5+x3*x9+2*x3*x7
42700 & -x3*x5+x4*x8+2*x4*x6-3*x4*x5-5*x10*x5+x9*x8+x9*x6+x9*x5+
42701 & x8*x7-4*x6*x5+x5**2)-(16*x2*x5)*(x1+x4+x10+x6)
42702 fm(1,4)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1+x2-x3-x4+x10-
42703 & x9-x8+2*x7+2*x6-x5)+4*pq**2*ph**2*(x1+x3+x4+x10+2*x7+2*x6
42704 & )+8*pq**2*(4*x1*x10+4*x1*x7+4*x1*x6+2*x2*x10-x2*x9-x2*x8+
42705 & 4*x2*x7+4*x2*x6-x2*x5+4*x10*x5+4*x7*x5+4*x6*x5)-(8*ph**2*
42706 & x1)*(x10+x7+x6)+16*x2*x5*(x10+x7+x6)
42707 fm(1,5)=8*pq**4*(-2*x1-2*x4+x10-x9)+4*pq**2*(4*x1**2-2*x1*
42708 & x2+8*x1*x3+6*x1*x10-2*x1*x9+4*x1*x8+4*x1*x7+4*x1*x6+2*x1*
42709 & x5+x2*x10+4*x3*x4-x3*x9+2*x3*x7+3*x4*x8-2*x4*x6+2*x4*x5-4
42710 & *x10*x7+3*x10*x5-3*x9*x6+3*x8*x7-4*x7**2+4*x7*x5)+8*(x1**
42711 & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5-x1*x4*
42712 & x8-x1*x4*x5+x1*x10*x9+x1*x9*x7+x1*x9*x6-x1*x8*x7-x2*x3*x7
42713 & +x2*x4*x6-x2*x10*x7-x2*x7**2+x3*x7*x5-x4*x10*x5-x4*x7*x5-
42714 & x4*x6*x5)
42715 fm(1,6)=16*pq**4*(-4*x1-x4+x9-x7)+4*pq**2*ph**2*(-2*x1-x4-
42716 & x7)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x4-3*x1*x9-2*x1*x7-3*
42717 & x1*x5-2*x2*x4-2*x7*x5)-8*ph**2*x4*x7+8*(-x1*x2*x9-2*x1*x2
42718 & *x5-x1*x9**2-x1*x9*x5+x2**2*x7-x2*x4*x5+x2*x9*x7-x2*x7*x5
42719 & +x4*x9*x5+x4*x5**2)
42720 fm(1,7)=8*pq**4*(2*x3+x4+3*x10+x9+2*x8+3*x7+6*x6)+2*pq**2*
42721 & ph**2*(-2*x3-x4+3*x10+3*x7+6*x6)+4*pq**2*(4*x1*x10+4*x1*
42722 & x7+8*x1*x6+6*x2*x10+x2*x9+2*x2*x8+6*x2*x7+12*x2*x6-8*x3*
42723 & x7+4*x4*x7+4*x4*x6+4*x10*x5+4*x9*x7+4*x9*x6-8*x8*x7+4*x7*
42724 & x5+8*x6*x5)+4*ph**2*(-x1*x10-x1*x7-2*x1*x6+2*x3*x7-x4*x7-
42725 & x4*x6)+8*x2*(x10*x5+x9*x7+x9*x6-2*x8*x7+x7*x5+2*x6*x5)
42726 fm(1,8)=8*pq**4*(2*x3+x4+3*x10+2*x9+x8+3*x7+6*x6)+2*pq**2*
42727 & ph**2*(-2*x3-x4+2*x10+x7+2*x6)+4*pq**2*(4*x1*x10-2*x1*x9+
42728 & 2*x1*x8+4*x1*x7+8*x1*x6+5*x2*x10+2*x2*x9+x2*x8+4*x2*x7+8*
42729 & x2*x6-x3*x9-8*x3*x7+2*x3*x5+2*x4*x9-x4*x8+4*x4*x7+4*x4*x6
42730 & +4*x4*x5+5*x10*x5+x9**2-x9*x8+2*x9*x7+5*x9*x6+x9*x5-7*x8*
42731 & x7+2*x8*x5+2*x7*x5+10*x6*x5)+2*ph**2*(-x1*x10+x3*x7-2*x4*
42732 & x7+x4*x6)+4*(-x1*x9**2+x1*x9*x8-2*x1*x9*x5-x1*x8*x5+2*x2*
42733 & x10*x5+x2*x9*x7+x2*x9*x6-2*x2*x8*x7+3*x2*x6*x5+x3*x9*x5+
42734 & x3*x5**2+x4*x9*x5-2*x4*x8*x5+2*x4*x5**2)
42735 fm(2,2)=16*pq**6+16*pq**4*(-x1+x3-x4-x10+x7-x6)+16*pq**2*(
42736 & x3*x10+x3*x7+x3*x6+x4*x7+x10*x7)-16*x3*x10*x7
42737 fm(2,3)=16*pq**6+8*pq**4*(-2*x1+x2+2*x3-4*x4-4*x10-x9+x8-2
42738 & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5+4*x3*x10-x3*x9-x3*x8-2*x3*
42739 & x7+2*x3*x6+x3*x5-2*x4*x5-2*x10*x5-2*x6*x5)+16*x3*x5*(x10+
42740 & x6)
42741 fm(2,4)=8*pq**4*(-2*x1-2*x3+x10-x8)+4*pq**2*(4*x1**2-2*x1*
42742 & x2+8*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+4*x1*x7+4*x1*x6+2*x1*
42743 & x5+x2*x10+4*x3*x4+3*x3*x9-2*x3*x7+2*x3*x5-x4*x8+2*x4*x6-4
42744 & *x10*x6+3*x10*x5+3*x9*x6-3*x8*x7-4*x6**2+4*x6*x5)+8*(-x1
42745 & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9-x1*x3*x5+x1*x4
42746 & *x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x1*x8*x6+x2*x3*
42747 & x7-x2*x4*x6-x2*x10*x6-x2*x6**2-x3*x10*x5-x3*x7*x5-x3*x6*
42748 & x5+x4*x6*x5)
42749 fm(2,5)=16*pq**4*x10+8*pq**2*(2*x1**2+2*x1*x3+2*x1*x4+2*x1
42750 & *x10+2*x1*x7+2*x1*x6+x3*x7+x4*x6)+8*(-2*x1**3-2*x1**2*x3-
42751 & 2*x1**2*x4-2*x1**2*x10-2*x1**2*x7-2*x1**2*x6-2*x1*x3*x4-
42752 & x1*x3*x10-2*x1*x3*x6-x1*x4*x10-2*x1*x4*x7-x1*x10**2-x1*
42753 & x10*x7-x1*x10*x6-2*x1*x7*x6+x3**2*x7-x3*x4*x7-x3*x4*x6+x3
42754 & *x10*x7+x3*x7**2-x3*x7*x6+x4**2*x6+x4*x10*x6-x4*x7*x6+x4*
42755 & x6**2)
42756 fm(2,6)=8*pq**4*(-2*x1+x10-x9-2*x7)+4*pq**2*(4*x1**2+2*x1*
42757 & x2+4*x1*x3+4*x1*x4+6*x1*x10-2*x1*x9+4*x1*x8+8*x1*x6-2*x1*
42758 & x5+4*x2*x4+3*x2*x10+2*x2*x7-3*x3*x9-2*x3*x7-4*x4**2-4*x4*
42759 & x10+3*x4*x8+2*x4*x6+x10*x5-x9*x6+3*x8*x7+4*x7*x6)+8*(x1**
42760 & 2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5+x1*x4*
42761 & x9-x1*x4*x8-x1*x4*x5+x1*x10*x9+x1*x9*x6-x1*x8*x7-x2*x3*x7
42762 & -x2*x4*x7+x2*x4*x6-x2*x10*x7+x3*x7*x5-x4**2*x5-x4*x10*x5-
42763 & x4*x6*x5)
42764 fm(2,7)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
42765 & 2*x1*x4-2*x1*x10+x1*x9-x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
42766 & x4+3*x2*x10+x2*x7+2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9-2*x3*
42767 & x7-4*x3*x6-x3*x5-6*x4**2-6*x4*x10-3*x4*x9-x4*x8-4*x4*x7-2
42768 & *x4*x6-2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+x10*x5
42769 & +x9*x7-2*x8*x7-2*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
42770 & -x1**2*x9+x1**2*x8-2*x1*x2*x10-3*x1*x2*x7-3*x1*x2*x6+x1*
42771 & x3*x9-x1*x3*x5+x1*x4*x9+x1*x4*x8+x1*x4*x5+x1*x10*x9+x1*
42772 & x10*x8-x1*x9*x6+x1*x8*x6+x2*x3*x7-3*x2*x4*x7-x2*x4*x6-3*
42773 & x2*x10*x7-3*x2*x10*x6-3*x2*x7*x6-3*x2*x6**2-2*x3*x4*x5-x3
42774 & *x10*x5-x3*x6*x5-x4**2*x5-x4*x10*x5+x4*x6*x5)
42775 fm(2,8)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-
42776 & 2*x1*x4-2*x1*x10-x1*x9+x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*
42777 & x4+x2*x10-x2*x7-2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9+x3*x8-2*
42778 & x3*x7-4*x3*x6+x3*x5-6*x4**2-6*x4*x10-2*x4*x9-4*x4*x7-2*x4
42779 & *x6+2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+3*x10*x5-
42780 & x9*x6-2*x8*x7-3*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(
42781 & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6-3*x1*x3*x5+x1*x4*x9-
42782 & x1*x4*x8-3*x1*x4*x5+x1*x10*x9+x1*x10*x8-2*x1*x10*x5+x1*x9
42783 & *x6+x1*x8*x7+x1*x8*x6-x2*x4*x7+x2*x4*x6-x2*x10*x7-x2*x10*
42784 & x6-2*x2*x7*x6-x2*x6**2-3*x3*x4*x5-3*x3*x10*x5+x3*x7*x5-3*
42785 & x3*x6*x5-3*x4**2*x5-3*x4*x10*x5-x4*x6*x5)
42786 fm(3,3)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x3+x8+x6
42787 & +2*x5)+8*pq**2*ph**2*(-x1+2*x3-x6)+16*pq**2*(x2*x5-2*x3*
42788 & x8-2*x3*x6+4*x3*x5+x8*x5)+8*ph**2*x3*x6-16*x3*x8*x5
42789 fm(3,4)=16*pq**4*(-4*x1-x3+x8-x6)+4*pq**2*ph**2*(-2*x1-x3-
42790 & x6)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x3-3*x1*x8-2*x1*x6-3*
42791 & x1*x5-2*x2*x3-2*x6*x5)-8*ph**2*x3*x6+8*(-x1*x2*x8-2*x1*x2
42792 & *x5-x1*x8**2-x1*x8*x5+x2**2*x6-x2*x3*x5+x2*x8*x6-x2*x6*x5
42793 & +x3*x8*x5+x3*x5**2)
42794 fm(3,5)=8*pq**4*(-2*x1+x10-x8-2*x6)+4*pq**2*(4*x1**2+2*x1*
42795 & x2+4*x1*x3+4*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+8*x1*x7-2*x1*
42796 & x5+4*x2*x3+3*x2*x10+2*x2*x6-4*x3**2-4*x3*x10+3*x3*x9+2*x3
42797 & *x7-3*x4*x8-2*x4*x6+x10*x5+3*x9*x6-x8*x7+4*x7*x6)+8*(-x1
42798 & **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9+x1*x3*x8-x1*x3
42799 & *x5+x1*x4*x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x2*x3*
42800 & x7-x2*x3*x6-x2*x4*x6-x2*x10*x6-x3**2*x5-x3*x10*x5-x3*x7*
42801 & x5+x4*x6*x5)
42802 fm(3,6)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1-x2+2*x3+2*x4+
42803 & x10-x9-x8-x7-x6+x5)+4*pq**2*ph**2*(x1+2*x3+2*x4+x10+x7+x6
42804 & )+8*pq**2*(4*x1*x3+4*x1*x4+4*x1*x10+4*x2*x3+4*x2*x4+4*x2*
42805 & x10-x2*x5+4*x3*x5+4*x4*x5+2*x10*x5-x9*x5-x8*x5)-(8*ph**2*
42806 & x1)*(x3+x4+x10)+16*x2*x5*(x3+x4+x10)
42807 fm(3,7)=8*pq**4*(3*x3+6*x4+3*x10+x9+2*x8+2*x7+x6)+2*pq**2*
42808 & ph**2*(x3+2*x4+2*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+4*
42809 & x1*x10+2*x1*x9-2*x1*x8+2*x2*x3+10*x2*x4+5*x2*x10+2*x2*x9+
42810 & x2*x8+2*x2*x7+4*x2*x6-7*x3*x9+2*x3*x8-8*x3*x7+4*x3*x6+4*
42811 & x3*x5+5*x4*x8+4*x4*x6+8*x4*x5+5*x10*x5-x9*x8-x9*x6+x9*x5+
42812 & x8**2-x8*x7+2*x8*x6+2*x8*x5)+2*ph**2*(-x1*x10+x3*x7-2*x3*
42813 & x6+x4*x6)+4*(-x1*x2*x9-2*x1*x2*x8+x1*x9*x8-x1*x8**2+x2**2
42814 & *x7+2*x2**2*x6+3*x2*x4*x5+2*x2*x10*x5-2*x2*x9*x6+x2*x8*x7
42815 & +x2*x8*x6-2*x3*x9*x5+x3*x8*x5+x4*x8*x5)
42816 fm(3,8)=8*pq**4*(3*x3+6*x4+3*x10+2*x9+x8+2*x7+x6)+2*pq**2*
42817 & ph**2*(3*x3+6*x4+3*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+
42818 & 4*x1*x10+4*x2*x3+8*x2*x4+4*x2*x10-8*x3*x9+4*x3*x8-8*x3*x7
42819 & +4*x3*x6+6*x3*x5+4*x4*x8+4*x4*x6+12*x4*x5+6*x10*x5+2*x9*
42820 & x5+x8*x5)+4*ph**2*(-x1*x3-2*x1*x4-x1*x10+2*x3*x7-x3*x6-x4
42821 & *x6)+8*x5*(x2*x3+2*x2*x4+x2*x10-2*x3*x9+x3*x8+x4*x8)
42822 fm(4,4)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x3+x8+2*
42823 & x6+x5)+8*pq**2*ph**2*(-x1-x3+2*x6)+16*pq**2*(x2*x8+4*x2*
42824 & x6+x2*x5-2*x3*x6-2*x8*x6)+8*ph**2*x3*x6-16*x2*x8*x6
42825 fm(4,5)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10-x9+x8-4
42826 & *x7+2*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x3-2*x2*x10-2*x2*x7+
42827 & x2*x6+2*x3*x6-2*x4*x6+4*x10*x6-x9*x6-x8*x6)+16*x2*x6*(x3+
42828 & x10)
42829 fm(4,6)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-4*x3-2*
42830 & x4-8*x10+x9+x8-4*x7-2*x6+2*x5)-(4*pq**2*ph**2)*(x1+x3+x10
42831 & +x7)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2
42832 & -4*x2*x3-5*x2*x10+x2*x9-3*x2*x7-x2*x6+x2*x5+x3*x9+2*x3*x7
42833 & -3*x3*x5+x4*x8+2*x4*x6-x4*x5-5*x10*x5+x9*x8+x9*x6+x8*x7+
42834 & x8*x5-4*x7*x5+x5**2)-(16*x2*x5)*(x1+x3+x10+x7)
42835 fm(4,7)=8*pq**4*(-x3-2*x4-3*x10-2*x9-x8-6*x7-3*x6)+2*pq**2
42836 & *ph**2*(x3+2*x4-3*x10-6*x7-3*x6)+4*pq**2*(-4*x1*x10-8*x1*
42837 & x7-4*x1*x6-6*x2*x10-2*x2*x9-x2*x8-12*x2*x7-6*x2*x6-4*x3*
42838 & x7-4*x3*x6+8*x4*x6-4*x10*x5+8*x9*x6-4*x8*x7-4*x8*x6-8*x7*
42839 & x5-4*x6*x5)+4*ph**2*(x1*x10+2*x1*x7+x1*x6+x3*x7+x3*x6-2*
42840 & x4*x6)+8*x2*(-x10*x5+2*x9*x6-x8*x7-x8*x6-2*x7*x5-x6*x5)
42841 fm(4,8)=8*pq**4*(-x3-2*x4-3*x10-x9-2*x8-6*x7-3*x6)+2*pq**2
42842 & *ph**2*(x3+2*x4-2*x10-2*x7-x6)+4*pq**2*(-4*x1*x10-2*x1*x9
42843 & +2*x1*x8-8*x1*x7-4*x1*x6-5*x2*x10-x2*x9-2*x2*x8-8*x2*x7-4
42844 & *x2*x6+x3*x9-2*x3*x8-4*x3*x7-4*x3*x6-4*x3*x5+x4*x8+8*x4*
42845 & x6-2*x4*x5-5*x10*x5+x9*x8+7*x9*x6-2*x9*x5-x8**2-5*x8*x7-2
42846 & *x8*x6-x8*x5-10*x7*x5-2*x6*x5)+2*ph**2*(x1*x10-x3*x7+2*x3
42847 & *x6-x4*x6)+4*(-x1*x9*x8+x1*x9*x5+x1*x8**2+2*x1*x8*x5-2*x2
42848 & *x10*x5+2*x2*x9*x6-x2*x8*x7-x2*x8*x6-3*x2*x7*x5+2*x3*x9*
42849 & x5-x3*x8*x5-2*x3*x5**2-x4*x8*x5-x4*x5**2)
42850 fm(5,5)=16*pq**6+16*pq**4*(-x1-x3+x4-x10-x7+x6)+16*pq**2*(
42851 & x3*x6+x4*x10+x4*x7+x4*x6+x10*x6)-16*x4*x10*x6
42852 fm(5,6)=16*pq**6+8*pq**4*(-2*x1+x2-4*x3+2*x4-4*x10+x9-x8-2
42853 & *x7-2*x6+x5)+8*pq**2*(-2*x1*x5-2*x3*x5+4*x4*x10-x4*x9-x4*
42854 & x8+2*x4*x7-2*x4*x6+x4*x5-2*x10*x5-2*x7*x5)+16*x4*x5*(x10+
42855 & x7)
42856 fm(5,7)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
42857 & 4*x1*x4+2*x1*x10+x1*x9-x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
42858 & x4-3*x2*x10-2*x2*x7-x2*x6+6*x3**2+6*x3*x4+6*x3*x10+x3*x9+
42859 & 3*x3*x8+2*x3*x7+4*x3*x6+2*x3*x5+6*x4*x10+2*x4*x8+4*x4*x7+
42860 & 2*x4*x6+x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-x10*x5+
42861 & 2*x9*x7+2*x9*x6-x8*x6+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(-
42862 & x1**2*x9+x1**2*x8+2*x1*x2*x10+3*x1*x2*x7+3*x1*x2*x6-x1*x3
42863 & *x9-x1*x3*x8-x1*x3*x5-x1*x4*x8+x1*x4*x5-x1*x10*x9-x1*x10*
42864 & x8-x1*x9*x7+x1*x8*x7+x2*x3*x7+3*x2*x3*x6-x2*x4*x6+3*x2*
42865 & x10*x7+3*x2*x10*x6+3*x2*x7**2+3*x2*x7*x6+x3**2*x5+2*x3*x4
42866 & *x5+x3*x10*x5-x3*x7*x5+x4*x10*x5+x4*x7*x5)
42867 fm(5,8)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+
42868 & 4*x1*x4+2*x1*x10-x1*x9+x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*
42869 & x4-x2*x10+2*x2*x7+x2*x6+6*x3**2+6*x3*x4+6*x3*x10+2*x3*x8+
42870 & 2*x3*x7+4*x3*x6-2*x3*x5+6*x4*x10-x4*x9+2*x4*x8+4*x4*x7+2*
42871 & x4*x6-x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-3*x10*x5+
42872 & 3*x9*x7+2*x9*x6+x8*x7+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(
42873 & x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9-x1*x3*x8+3*
42874 & x1*x3*x5+3*x1*x4*x5-x1*x10*x9-x1*x10*x8+2*x1*x10*x5-x1*x9
42875 & *x7-x1*x9*x6-x1*x8*x7-x2*x3*x7+x2*x3*x6+x2*x10*x7+x2*x10*
42876 & x6+x2*x7**2+2*x2*x7*x6+3*x3**2*x5+3*x3*x4*x5+3*x3*x10*x5+
42877 & x3*x7*x5+3*x4*x10*x5+3*x4*x7*x5-x4*x6*x5)
42878 fm(6,6)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x4+x9+x7
42879 & +2*x5)+8*pq**2*ph**2*(-x1+2*x4-x7)+16*pq**2*(x2*x5-2*x4*
42880 & x9-2*x4*x7+4*x4*x5+x9*x5)+8*ph**2*x4*x7-16*x4*x9*x5
42881 fm(6,7)=8*pq**4*(-6*x3-3*x4-3*x10-2*x9-x8-x7-2*x6)+2*pq**2
42882 & *ph**2*(-2*x3-x4-2*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*x4
42883 & -4*x1*x10+2*x1*x9-2*x1*x8-10*x2*x3-2*x2*x4-5*x2*x10-x2*x9
42884 & -2*x2*x8-4*x2*x7-2*x2*x6-5*x3*x9-4*x3*x7-8*x3*x5-2*x4*x9+
42885 & 7*x4*x8-4*x4*x7+8*x4*x6-4*x4*x5-5*x10*x5-x9**2+x9*x8-2*x9
42886 & *x7+x9*x6-2*x9*x5+x8*x7-x8*x5)+2*ph**2*(x1*x10-x3*x7+2*x4
42887 & *x7-x4*x6)+4*(2*x1*x2*x9+x1*x2*x8+x1*x9**2-x1*x9*x8-2*x2
42888 & **2*x7-x2**2*x6-3*x2*x3*x5-2*x2*x10*x5-x2*x9*x7-x2*x9*x6+
42889 & 2*x2*x8*x7-x3*x9*x5-x4*x9*x5+2*x4*x8*x5)
42890 fm(6,8)=8*pq**4*(-6*x3-3*x4-3*x10-x9-2*x8-x7-2*x6)+2*pq**2
42891 & *ph**2*(-6*x3-3*x4-3*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*
42892 & x4-4*x1*x10-8*x2*x3-4*x2*x4-4*x2*x10-4*x3*x9-4*x3*x7-12*
42893 & x3*x5-4*x4*x9+8*x4*x8-4*x4*x7+8*x4*x6-6*x4*x5-6*x10*x5-x9
42894 & *x5-2*x8*x5)+4*ph**2*(2*x1*x3+x1*x4+x1*x10+x3*x7+x4*x7-2*
42895 & x4*x6)+8*x5*(-2*x2*x3-x2*x4-x2*x10-x3*x9-x4*x9+2*x4*x8)
42896 fm(7,7)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+9*
42897 & x2*x10+7*x3*x7+2*x3*x6+2*x4*x7+7*x4*x6+x10*x5+2*x9*x7+7*
42898 & x9*x6+7*x8*x7+2*x8*x6)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2
42899 & *x4*x7-7*x4*x6)+4*x2*(x10*x5+2*x9*x7+7*x9*x6+7*x8*x7+2*x8
42900 & *x6)
42901 fm(7,8)=72*pq**4*x10+2*pq**2*ph**2*x10+4*pq**2*(2*x1*x10+
42902 & 10*x2*x10+7*x3*x9+2*x3*x8+14*x3*x7+4*x3*x6+2*x4*x9+7*x4*
42903 & x8+4*x4*x7+14*x4*x6+10*x10*x5+x9**2+7*x9*x8+2*x9*x7+7*x9*
42904 & x6+x8**2+7*x8*x7+2*x8*x6)+2*ph**2*(7*x1*x10-7*x3*x7-2*x3*
42905 & x6-2*x4*x7-7*x4*x6)+2*(-2*x1*x9**2-14*x1*x9*x8-2*x1*x8**2
42906 & +2*x2*x10*x5+2*x2*x9*x7+7*x2*x9*x6+7*x2*x8*x7+2*x2*x8*x6+
42907 & 7*x3*x9*x5+2*x3*x8*x5+2*x4*x9*x5+7*x4*x8*x5)
42908 fm(8,8)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+x2
42909 & *x10+7*x3*x9+2*x3*x8+7*x3*x7+2*x3*x6+2*x4*x9+7*x4*x8+2*x4
42910 & *x7+7*x4*x6+9*x10*x5)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2*
42911 & x4*x7-7*x4*x6)+4*x5*(x2*x10+7*x3*x9+2*x3*x8+2*x4*x9+7*x4*
42912 & x8)
42913 fm(9,9)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
42914 & x3*x7+x4*x6-x10*x5+x9*x6+x8*x7)+ph**2*(x1*x10-x3*x7-x4*x6
42915 & )+2*x2*(-x10*x5+x9*x6+x8*x7)
42916 fm(9,10)=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
42917 & x10+2*x3*x9+2*x3*x7+2*x4*x6-2*x10*x5+x9*x8+2*x8*x7)+ph**2
42918 & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x8*x7+x3*
42919 & x9*x5)
42920 fmxx=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*
42921 & x10+2*x4*x8+2*x4*x6+2*x3*x7-2*x10*x5+x9*x8+2*x9*x6)+ph**2
42922 & *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x9*x6+x4*
42923 & x8*x5)
42924 fm(9,10)=0.5d0*(fmxx+fm(9,10))
42925 fm(10,10)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+
42926 & x3*x7+x4*x6-x10*x5+x9*x3+x8*x4)+ph**2*(x1*x10-x3*x7-x4*x6
42927 & )+2*x5*(-x10*x2+x9*x3+x8*x4)
42928
42929C...Repackage matrix elements.
42930 DO 200 i=1,8
42931 DO 190 j=i,8
42932 rm(i,j)=fm(i,j)
42933 190 CONTINUE
42934 200 CONTINUE
42935 rm(7,7)=fm(7,7)-2d0*fm(9,9)
42936 rm(7,8)=fm(7,8)-2d0*fm(9,10)
42937 rm(8,8)=fm(8,8)-2d0*fm(10,10)
42938
42939C...Produce final result: matrix elements * colours * propagators.
42940 DO 220 i=1,8
42941 DO 210 j=i,8
42942 fac=8d0
42943 IF(i.EQ.j)fac=4d0
42944 wtqqbh=wtqqbh+rm(i,j)*fac*clr(i,j)/(dx(i)*dx(j))
42945 210 CONTINUE
42946 220 CONTINUE
42947 wtqqbh=-wtqqbh/256d0
42948
42949 ELSE
42950C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
42951 a11=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x2*x10+x3
42952 & *x7+x4*x6+x9*x6+x8*x7)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x2)*(x9
42953 & *x6+x8*x7)
42954 a12=-8d0*pq**4*x10+4d0*pq**2*(-x2*x10-x3*x9-2d0*x3*x7-x4*x8-
42955 & 2d0*x4*x6-x10*x5-x9*x8-x9*x6-x8*x7)+2d0*ph**2*(-x1*x10+x3*x7
42956 & +x4*x6)+2d0*(2d0*x1*x9*x8-x2*x9*x6-x2*x8*x7-x3*x9*x5-x4*x8*
42957 & x5)
42958 a22=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x3*x9+x3*
42959 & x7+x4*x8+x4*x6+x10*x5)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x5)*(x3
42960 & *x9+x4*x8)
42961
42962C...Produce final result: matrix elements * propagators.
42963 a11=a11/dx(7)**2
42964 a12=a12/(dx(7)*dx(8))
42965 a22=a22/dx(8)**2
42966 wtqqbh=-(a11+a22+2d0*a12)*8d0/9d0
42967 ENDIF
42968
42969 RETURN
42970 END
42971
42972C*********************************************************************
42973
42974C...PYSTBH (and auxiliaries)
42975C.. Evaluates the matrix elements for t + b + H production.
42976
42977 SUBROUTINE pystbh(WTTBH)
42978
42979C...DOUBLE PRECISION AND INTEGER DECLARATIONS
42980 IMPLICIT DOUBLE PRECISION(a-h, o-z)
42981 IMPLICIT INTEGER(I-N)
42982 INTEGER PYK,PYCHGE,PYCOMP
42983
42984C...COMMONBLOCKS
42985 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
42986 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
42987 common/pypars/mstp(200),parp(200),msti(200),pari(200)
42988 common/pyint1/mint(400),vint(400)
42989 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
42990 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
42991 common/pyint4/mwid(500),wids(500,5)
42992 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
42993 common/pymssm/imss(0:99),rmss(0:99)
42994 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
42995 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
42996 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
42997 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
42998 common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
42999 DOUBLE PRECISION MW2
43000 SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,/pyint3/,
43001 &/pyint4/,/pysubs/,/pymssm/,/pysgcm/,/pyctbh/
43002
43003C...LOCAL ARRAYS AND COMPLEX VARIABLES
43004 dimension qq(4,2),pp(4,3)
43005 DATA qq/8*0d0/
43006
43007 wttbh=0d0
43008
43009C...KINEMATIC PARAMETERS.
43010 shpr=sqrt(vint(26))*vint(1)
43011 ph=sqrt(vint(21))*vint(1)
43012 sph=ph**2
43013
43014C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43015 DO 100 i=1,2
43016 pt=sqrt(max(0d0,vint(197+5*i)))
43017 pp(1,i)=pt*cos(vint(198+5*i))
43018 pp(2,i)=pt*sin(vint(198+5*i))
43019 100 CONTINUE
43020 pp(1,3)=-pp(1,1)-pp(1,2)
43021 pp(2,3)=-pp(2,1)-pp(2,2)
43022 pms1=vint(201)**2+pp(1,1)**2+pp(2,1)**2
43023 pms2=vint(206)**2+pp(1,2)**2+pp(2,2)**2
43024 pms3=sph+pp(1,3)**2+pp(2,3)**2
43025 pmt3=sqrt(pms3)
43026 pp(3,3)=pmt3*sinh(vint(211))
43027 pp(4,3)=pmt3*cosh(vint(211))
43028 pms12=(shpr-pp(4,3))**2-pp(3,3)**2
43029 pp(3,1)=(-pp(3,3)*(pms12+pms1-pms2)+
43030 &vint(213)*(shpr-pp(4,3))*vint(220))/(2d0*pms12)
43031 pp(3,2)=-pp(3,1)-pp(3,3)
43032 pp(4,1)=sqrt(pms1+pp(3,1)**2)
43033 pp(4,2)=sqrt(pms2+pp(3,2)**2)
43034
43035C...CM SYSTEM, INGOING QUARKS/GLUONS
43036 qq(3,1) = shpr/2.d0
43037 qq(4,1) = qq(3,1)
43038 qq(3,2) = -qq(3,1)
43039 qq(4,2) = qq(4,1)
43040
43041C...PARAMETERS FOR AMPLITUDE METHOD
43042 alpha = aem
43043 alphas = as
43044 sw2 = paru(102)
43045 mw2 = pmas(24,1)**2
43046 tanb = paru(141)
43047 vtb = vckm(3,3)
43048 rmb=pymrun(5,vint(52))
43049
43050 isub=mint(1)
43051
43052 IF (isub.EQ.401) THEN
43053 CALL pytbhg(qq(1,1),qq(1,2),pp(1,1),pp(1,2),pp(1,3),
43054 & vint(201),vint(206),rmb,vint(43),wttbh)
43055 ELSE IF (isub.EQ.402) THEN
43056 CALL pytbhq(qq(1,1),qq(1,2),pp(1,1),pp(1,2),pp(1,3),
43057 & vint(201),vint(206),rmb,vint(43),wttbh)
43058 END IF
43059
43060 RETURN
43061 END
43062C------------------------------------------------------------------
43063 SUBROUTINE pytbhb(MT,MB,MHP,BR,GAMT)
43064C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43065 IMPLICIT DOUBLE PRECISION(a-h, o-z)
43066 IMPLICIT INTEGER(I-N)
43067 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43068 common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
43069 SAVE /pyctbh/
43070
43071C TOP WIDTH CALCULATION
43072C VTB = 0.99
43073 mw=dsqrt(mw2)
43074 xb=(mb/mt)**2
43075 xw=(mw/mt)**2
43076 xh =(mhp/mt)**2
43077 gamtbh = 0d0
43078 IF (mt .LT. (mhp+mb)) THEN
43079C T ->B W ONLY
43080 betw = dsqrt(1.d0-2*(xb+xw)+(xw-xb)**2)
43081 gamtbw = vtb**2*alpha/(16*sw2)*mt/xw*betw*
43082 & (2*(1.d0-xb-xw)-(1.d0+xb-xw)*(1.d0-xb -2*xw) )
43083 gamt = gamtbw
43084 ELSE
43085C T ->BW +T ->B H^+
43086 betw = dsqrt(1.d0-2*(xb+xw)+(xw-xb)**2)
43087 gamtbw = vtb**2*alpha/(16*sw2)*mt/xw*betw*
43088 & (2*(1.d0-xb-xw)-(1.d0+xb-xw)*(1.d0-xb -2*xw) )
43089C
43090 kfun = dsqrt( (1.d0-(mhp/mt)**2-(mb/mt)**2)**2
43091 & -4.d0*(mhp*mb/mt**2)**2 )
43092 gamtbh= alpha/sw2/8.d0*vtb**2*kfun/mt *
43093 & (v**2*((mt+mb)**2-mhp**2)+a**2*((mt-mb)**2-mhp**2))
43094 gamt = gamtbw+gamtbh
43095 ENDIF
43096C THUS BR IS
43097 br=gamtbh/gamt
43098 RETURN
43099 END
43100
43101C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43102C GG->TBH^+, QQBAR->TBH^+
43103C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43104C (FOR INSTANCE WITH PYTHIA)
43105C------------------------------------------------------------
43106C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43107C PHYS REV. D 60 (1999) 115011
43108C (THESE FILES PREPARED BY J.-L. KNEUR)
43109C------------------------------------------------------------
43110C 1) GG->TBH^+
43111 SUBROUTINE pytbhg(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43112C
43113C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43114C
43115C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43116C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43117C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43118C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43119C "PHYSICAL PARAMETERS" INPUT:
43120C MT,MB TOP AND BOTTOM MASSES;
43121C MHP CHARGED HIGGS MASS
43122C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43123C
43124C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43125C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43126C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43127C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43128C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43129C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43130C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43131C
43132 IMPLICIT DOUBLE PRECISION(a-h, o-z)
43133 IMPLICIT INTEGER(I-N)
43134 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43135 dimension q1(4),q2(4),p1(4),p2(4),p3(4)
43136 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
43137 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
43138 common/pymssm/imss(0:99),rmss(0:99)
43139
43140 common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
43141 SAVE /pydat1/,/pydat2/,/pymssm/,/pyctbh/
43142C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43143C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43144C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43145C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43146C (TAN BETA) VALUES
43147C
43148C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43149C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43150
43151 pi = 4*datan(1.d0)
43152 mw = dsqrt(mw2)
43153C
43154C COLLECTING THE RELEVANT OVERALL FACTORS:
43155C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43156 ps=1.d0/(8.d0*8.d0 *2.d0*2.d0)
43157C COUPLING CONSTANT (OVERALL NORMALIZATION)
43158 fact=(4.d0*pi*alpha)*(4.d0*pi*alphas)**2/sw2/2.d0
43159C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43160C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43161C ALPHAS IS ALPHA_STRONG;
43162C SW2 IS SIN(THETA_W)**2.
43163C
43164C VTB=.998D0
43165C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43166C
43167 v = ( mt/mw/tanb +rmb/mw*tanb)/2.d0
43168 a = (-mt/mw/tanb +rmb/mw*tanb)/2.d0
43169C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43170C
43171C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43172C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43173 DO 100 kk=1,4
43174 p2(kk)=p3(kk)-q1(kk)-q2(kk)+p1(kk)
43175 100 CONTINUE
43176C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43177 s = 2*pytbhs(q1,q2)
43178 p1q1=pytbhs(q1,p1)
43179 p1q2=pytbhs(p1,q2)
43180 p2q1=pytbhs(p2,q1)
43181 p2q2=pytbhs(p2,q2)
43182 p1p2=pytbhs(p1,p2)
43183C
43184C TOP WIDTH CALCULATION
43185 CALL pytbhb(mt,mb,mhp,br,gamt)
43186C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43187C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43188 a1inv= s -2*p1q1 -2*p1q2
43189 a1 =a1inv/(a1inv**2+ (gamt*mt)**2)
43190C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43191C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43192C THE TOP WIDTH
43193 a12 = 1.d0/(a1inv**2+ (gamt*mt)**2)
43194 a2 =1.d0/(s +2*p2q1 +2*p2q2)
43195C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43196C NOW COMES THE AMP**2:
43197C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43198C THE EXPRESSIONS BELOW
43199 v18=0.d0
43200 a18=0.d0
43201 v18= 640*a1/3+640*a2/3+32*a1*a2*mb**2-368*a12*mb*mt-
43202 &512*a1*a2*mb*mt/3-
43203 &368*a2**2*mb*mt+32*a1*a2*mt**2+496*a12*p1p2/3+
43204 &320*a1*a2*p1p2+496*a2**2*p1p2/3+128*a1*mb*mt**3/(3*p1q1**2)+
43205 &128*a1*mt**4/(3*p1q1**2)-256*a12*mb*mt**5/(3*p1q1**2)+
43206 &256*a1*mt**2*p1p2/(3*p1q1**2)-256*a12*mt**4*p1p2/(3*p1q1**2)+
43207 &8/(3*p1q1)-32*a1*mb*mt/p1q1-56*a2*mb*mt/(3*p1q1)+
43208 &88*a1*mt**2/(3*p1q1)+72*a2*mt**2/p1q1+
43209 &704*a12*mb*mt**3/(3*p1q1)-224*a1*a2*mb*mt**3/(3*p1q1)+
43210 &104*a1*p1p2/(3*p1q1)+48*a2*p1p2/p1q1+
43211 &128*a1*a2*mb*mt*p1p2/(3*p1q1)+512*a12*mt**2*p1p2/(3*p1q1)-
43212 &448*a1*a2*mt**2*p1p2/(3*p1q1)-32*a1*a2*p1p2**2/p1q1-
43213 &656*a1*a2*p1q1/3-224*a2**2*p1q1+128*a1*mb*mt**3/(3*p1q2**2)+
43214 &128*a1*mt**4/(3*p1q2**2)-256*a12*mb*mt**5/(3*p1q2**2)+
43215 &256*a1*mt**2*p1p2/(3*p1q2**2)-256*a12*mt**4*p1p2/(3*p1q2**2)+
43216 &256*a1*mt**2*p1q1/(3*p1q2**2)+256*a12*mb*mt**3*p1q1/(3*p1q2**2)+
43217 &8/(3*p1q2)-32*a1*mb*mt/p1q2-56*a2*mb*mt/(3*p1q2)
43218 v18=v18+88*a1*mt**2/(3*p1q2)+72*a2*mt**2/p1q2+
43219 &704*a12*mb*mt**3/(3*p1q2)-224*a1*a2*mb*mt**3/(3*p1q2)+
43220 &104*a1*p1p2/(3*p1q2)+48*a2*p1p2/p1q2+
43221 &128*a1*a2*mb*mt*p1p2/(3*p1q2)+512*a12*mt**2*p1p2/(3*p1q2)-
43222 &448*a1*a2*mt**2*p1p2/(3*p1q2)-32*a1*a2*p1p2**2/p1q2-
43223 &32*a1*mb*mt**3/(3*p1q1*p1q2)-32*a1*mt**4/(3*p1q1*p1q2)+
43224 &64*a12*mb*mt**5/(3*p1q1*p1q2)+16*p1p2/(3*p1q1*p1q2)-
43225 &64*a1*mt**2*p1p2/(3*p1q1*p1q2)+64*a12*mt**4*p1p2/(3*p1q1*p1q2)+
43226 &112*a1*p1q1/p1q2+272*a2*p1q1/(3*p1q2)-
43227 &272*a1*a2*mb**2*p1q1/(3*p1q2)+208*a12*mb*mt*p1q1/(3*p1q2)-
43228 &400*a1*a2*mb*mt*p1q1/(3*p1q2)-80*a1*a2*mt**2*p1q1/p1q2+
43229 &96*a12*p1p2*p1q1/p1q2-320*a1*a2*p1p2*p1q1/p1q2-
43230 &544*a1*a2*p1q1**2/(3*p1q2)-656*a1*a2*p1q2/3-224*a2**2*p1q2+
43231 &256*a1*mt**2*p1q2/(3*p1q1**2)+256*a12*mb*mt**3*p1q2/(3*p1q1**2)+
43232 &112*a1*p1q2/p1q1+272*a2*p1q2/(3*p1q1)-
43233 &272*a1*a2*mb**2*p1q2/(3*p1q1)+208*a12*mb*mt*p1q2/(3*p1q1)-
43234 &400*a1*a2*mb*mt*p1q2/(3*p1q1)-80*a1*a2*mt**2*p1q2/p1q1
43235 v18=v18+96*a12*p1p2*p1q2/p1q1-320*a1*a2*p1p2*p1q2/p1q1-
43236 &544*a1*a2*p1q2**2/(3*p1q1)+128*a2*mb**4/(3*p2q1**2)+
43237 &128*a2*mb**3*mt/(3*p2q1**2)-256*a2**2*mb**5*mt/(3*p2q1**2)+
43238 &256*a2*mb**2*p1p2/(3*p2q1**2)-256*a2**2*mb**4*p1p2/(3*p2q1**2)+
43239 &256*a2*mb**2*p1q1/(3*p2q1**2)-256*a2**2*mb**4*p1q1/(3*p2q1**2)-
43240 &64*mb**3*mt**3/(3*p1q2**2*p2q1**2)-
43241 &64*mb**2*mt**2*p1p2/(3*p1q2**2*p2q1**2)-
43242 &64*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1**2)+
43243 &64*mb**3*mt/(3*p1q2*p2q1**2)+
43244 &256*a2*mb**3*mt*p1p2/(3*p1q2*p2q1**2)+
43245 &256*a2*mb**2*p1p2**2/(3*p1q2*p2q1**2)+
43246 &256*a2*mb**3*mt*p1q1/(3*p1q2*p2q1**2)+
43247 &512*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1**2)+
43248 &256*a2*mb**2*p1q1**2/(3*p1q2*p2q1**2)-
43249 &256*a2**2*mb**4*p1q2/(3*p2q1**2)-8/(3*p2q1)-72*a1*mb**2/p2q1-
43250 &88*a2*mb**2/(3*p2q1)+56*a1*mb*mt/(3*p2q1)+32*a2*mb*mt/p2q1+
43251 &224*a1*a2*mb**3*mt/(3*p2q1)-704*a2**2*mb**3*mt/(3*p2q1)
43252 v18=v18-48*a1*p1p2/p2q1-104*a2*p1p2/(3*p2q1)+
43253 &448*a1*a2*mb**2*p1p2/(3*p2q1)-512*a2**2*mb**2*p1p2/(3*p2q1)-
43254 &128*a1*a2*mb*mt*p1p2/(3*p2q1)+32*a1*a2*p1p2**2/p2q1-
43255 &16*p1p2/(3*p1q1*p2q1)-32*a1*mb*mt*p1p2/(3*p1q1*p2q1)-
43256 &32*a2*mb*mt*p1p2/(3*p1q1*p2q1)-
43257 &64*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q1)-
43258 &64*a1*a2*p1p2**3/(3*p1q1*p2q1)-256*a2*p1q1/(3*p2q1)+
43259 &448*a1*a2*mb**2*p1q1/(3*p2q1)-368*a2**2*mb**2*p1q1/(3*p2q1)+
43260 &224*a1*a2*mb*mt*p1q1/(3*p2q1)+304*a1*a2*p1p2*p1q1/(3*p2q1)-
43261 &64*mb*mt**3/(3*p1q2**2*p2q1)-
43262 &256*a1*mb*mt**3*p1p2/(3*p1q2**2*p2q1)-
43263 &256*a1*mt**2*p1p2**2/(3*p1q2**2*p2q1)+
43264 &64*mt**2*p1q1/(3*p1q2**2*p2q1)-
43265 &128*a1*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1)-
43266 &128*a1*mb*mt**3*p1q1/(3*p1q2**2*p2q1)-
43267 &256*a1*mt**2*p1p2*p1q1/(3*p1q2**2*p2q1)-4*mb**2/(3*p1q2*p2q1)+
43268 &64*mb*mt/(3*p1q2*p2q1)-128*a2*mb**3*mt/(3*p1q2*p2q1)
43269 v18=v18-4*mt**2/(3*p1q2*p2q1)-128*a1*mb**2*mt**2/(3*p1q2*p2q1)-
43270 &128*a2*mb**2*mt**2/(3*p1q2*p2q1)-128*a1*mb*mt**3/(3*p1q2*p2q1)-
43271 &112*a2*mb**2*p1p2/(3*p1q2*p2q1)-32*a1*mb*mt*p1p2/(3*p1q2*p2q1)-
43272 &32*a2*mb*mt*p1p2/(3*p1q2*p2q1)-112*a1*mt**2*p1p2/(3*p1q2*p2q1)-
43273 &48*a1*p1p2**2/(p1q2*p2q1)-48*a2*p1p2**2/(p1q2*p2q1)+
43274 &512*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q1)+
43275 &512*a1*a2*p1p2**3/(3*p1q2*p2q1)-8*mb*mt*p1p2/(3*p1q1*p1q2*p2q1)-
43276 &8*mt**2*p1p2/(3*p1q1*p1q2*p2q1)+
43277 &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q1)-
43278 &16*p1p2**2/(3*p1q1*p1q2*p2q1)+
43279 &32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q1)+8*p1q1/(3*p1q2*p2q1)-
43280 &160*a1*mb**2*p1q1/(3*p1q2*p2q1)-272*a2*mb**2*p1q1/(3*p1q2*p2q1)+
43281 &56*a1*mb*mt*p1q1/(3*p1q2*p2q1)+200*a2*mb*mt*p1q1/(3*p1q2*p2q1)-
43282 &48*a1*p1p2*p1q1/(p1q2*p2q1)-256*a2*p1p2*p1q1/(3*p1q2*p2q1)+
43283 &256*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1)+
43284 &256*a1*a2*mb*mt*p1p2*p1q1/(p1q2*p2q1)+
43285 &1024*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q1)
43286 v18=v18-272*a2*p1q1**2/(3*p1q2*p2q1)+
43287 &256*a1*a2*mb**2*p1q1**2/(3*p1q2*p2q1)+
43288 &256*a1*a2*mb*mt*p1q1**2/(3*p1q2*p2q1)+
43289 &512*a1*a2*p1p2*p1q1**2/(3*p1q2*p2q1)+16*a2*p1q2/(3*p2q1)+
43290 &64*a1*a2*mb**2*p1q2/p2q1+32*a2**2*mb**2*p1q2/(3*p2q1)+
43291 &112*a1*a2*mb*mt*p1q2/(3*p2q1)+368*a1*a2*p1p2*p1q2/(3*p2q1)+
43292 &32*a2*p1p2*p1q2/(3*p1q1*p2q1)-
43293 &32*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1)-
43294 &32*a1*a2*mb*mt*p1p2*p1q2/(3*p1q1*p2q1)-
43295 &64*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q1)+224*a12*p2q1+
43296 &656*a1*a2*p2q1/3-256*a1*mt**2*p2q1/(3*p1q1**2)+
43297 &256*a12*mt**4*p2q1/(3*p1q1**2)-256*a1*p2q1/(3*p1q1)+
43298 &224*a1*a2*mb*mt*p2q1/(3*p1q1)-368*a12*mt**2*p2q1/(3*p1q1)+
43299 &448*a1*a2*mt**2*p2q1/(3*p1q1)+304*a1*a2*p1p2*p2q1/(3*p1q1)+
43300 &256*a12*mt**4*p2q1/(3*p1q2**2)+
43301 &256*a12*mt**2*p1q1*p2q1/(3*p1q2**2)+16*a1*p2q1/(3*p1q2)+
43302 &112*a1*a2*mb*mt*p2q1/(3*p1q2)+32*a12*mt**2*p2q1/(3*p1q2)
43303 v18=v18+64*a1*a2*mt**2*p2q1/p1q2+368*a1*a2*p1p2*p2q1/(3*p1q2)+
43304 &16*a1*mt**2*p2q1/(3*p1q1*p1q2)-64*a12*mt**4*p2q1/(3*p1q1*p1q2)+
43305 &640*a12*p1q1*p2q1/(3*p1q2)+544*a1*a2*p1q1*p2q1/(3*p1q2)+
43306 &32*a12*p1q2*p2q1/p1q1+944*a1*a2*p1q2*p2q1/(3*p1q1)+
43307 &128*a2*mb**4/(3*p2q2**2)+128*a2*mb**3*mt/(3*p2q2**2)-
43308 &256*a2**2*mb**5*mt/(3*p2q2**2)+256*a2*mb**2*p1p2/(3*p2q2**2)-
43309 &256*a2**2*mb**4*p1p2/(3*p2q2**2)-
43310 &64*mb**3*mt**3/(3*p1q1**2*p2q2**2)-
43311 &64*mb**2*mt**2*p1p2/(3*p1q1**2*p2q2**2)+
43312 &64*mb**3*mt/(3*p1q1*p2q2**2)+
43313 &256*a2*mb**3*mt*p1p2/(3*p1q1*p2q2**2)+
43314 &256*a2*mb**2*p1p2**2/(3*p1q1*p2q2**2)-
43315 &256*a2**2*mb**4*p1q1/(3*p2q2**2)+256*a2*mb**2*p1q2/(3*p2q2**2)-
43316 &256*a2**2*mb**4*p1q2/(3*p2q2**2)-
43317 &64*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2**2)+
43318 &256*a2*mb**3*mt*p1q2/(3*p1q1*p2q2**2)+
43319 &512*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2**2)
43320 v18=v18+256*a2*mb**2*p1q2**2/(3*p1q1*p2q2**2)-
43321 &256*a2*mb**2*p2q1/(3*p2q2**2)-256*a2**2*mb**3*mt*p2q1/(3*p2q2**2)+
43322 &64*mb**2*mt**2*p2q1/(3*p1q1**2*p2q2**2)+
43323 &64*mb**2*p2q1/(3*p1q1*p2q2**2)-
43324 &128*a2*mb**3*mt*p2q1/(3*p1q1*p2q2**2)-
43325 &128*a2*mb**2*mt**2*p2q1/(3*p1q1*p2q2**2)-
43326 &256*a2*mb**2*p1p2*p2q1/(3*p1q1*p2q2**2)+
43327 &256*a2**2*mb**2*p1q1*p2q1/(3*p2q2**2)-
43328 &256*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2**2)-8/(3*p2q2)-
43329 &72*a1*mb**2/p2q2-88*a2*mb**2/(3*p2q2)+56*a1*mb*mt/(3*p2q2)+
43330 &32*a2*mb*mt/p2q2+224*a1*a2*mb**3*mt/(3*p2q2)-
43331 &704*a2**2*mb**3*mt/(3*p2q2)-48*a1*p1p2/p2q2-
43332 &104*a2*p1p2/(3*p2q2)+448*a1*a2*mb**2*p1p2/(3*p2q2)-
43333 &512*a2**2*mb**2*p1p2/(3*p2q2)-128*a1*a2*mb*mt*p1p2/(3*p2q2)+
43334 &32*a1*a2*p1p2**2/p2q2-64*mb*mt**3/(3*p1q1**2*p2q2)-
43335 &256*a1*mb*mt**3*p1p2/(3*p1q1**2*p2q2)-
43336 &256*a1*mt**2*p1p2**2/(3*p1q1**2*p2q2)-4*mb**2/(3*p1q1*p2q2)
43337 v18=v18+64*mb*mt/(3*p1q1*p2q2)-128*a2*mb**3*mt/(3*p1q1*p2q2)-
43338 &4*mt**2/(3*p1q1*p2q2)-128*a1*mb**2*mt**2/(3*p1q1*p2q2)-
43339 &128*a2*mb**2*mt**2/(3*p1q1*p2q2)-128*a1*mb*mt**3/(3*p1q1*p2q2)-
43340 &112*a2*mb**2*p1p2/(3*p1q1*p2q2)-32*a1*mb*mt*p1p2/(3*p1q1*p2q2)-
43341 &32*a2*mb*mt*p1p2/(3*p1q1*p2q2)-112*a1*mt**2*p1p2/(3*p1q1*p2q2)-
43342 &48*a1*p1p2**2/(p1q1*p2q2)-48*a2*p1p2**2/(p1q1*p2q2)+
43343 &512*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q2)+
43344 &512*a1*a2*p1p2**3/(3*p1q1*p2q2)+16*a2*p1q1/(3*p2q2)+
43345 &64*a1*a2*mb**2*p1q1/p2q2+32*a2**2*mb**2*p1q1/(3*p2q2)+
43346 &112*a1*a2*mb*mt*p1q1/(3*p2q2)+368*a1*a2*p1p2*p1q1/(3*p2q2)-
43347 &16*p1p2/(3*p1q2*p2q2)-32*a1*mb*mt*p1p2/(3*p1q2*p2q2)-
43348 &32*a2*mb*mt*p1p2/(3*p1q2*p2q2)-
43349 &64*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q2)-
43350 &64*a1*a2*p1p2**3/(3*p1q2*p2q2)-8*mb*mt*p1p2/(3*p1q1*p1q2*p2q2)-
43351 &8*mt**2*p1p2/(3*p1q1*p1q2*p2q2)+
43352 &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q2)-
43353 &16*p1p2**2/(3*p1q1*p1q2*p2q2)
43354 v18=v18+32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q2)+
43355 &32*a2*p1p2*p1q1/(3*p1q2*p2q2)-
43356 &32*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q2)-
43357 &32*a1*a2*mb*mt*p1p2*p1q1/(3*p1q2*p2q2)-
43358 &64*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q2)-256*a2*p1q2/(3*p2q2)+
43359 &448*a1*a2*mb**2*p1q2/(3*p2q2)-368*a2**2*mb**2*p1q2/(3*p2q2)+
43360 &224*a1*a2*mb*mt*p1q2/(3*p2q2)+304*a1*a2*p1p2*p1q2/(3*p2q2)+
43361 &64*mt**2*p1q2/(3*p1q1**2*p2q2)-
43362 &128*a1*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2)-
43363 &128*a1*mb*mt**3*p1q2/(3*p1q1**2*p2q2)-
43364 &256*a1*mt**2*p1p2*p1q2/(3*p1q1**2*p2q2)+8*p1q2/(3*p1q1*p2q2)-
43365 &160*a1*mb**2*p1q2/(3*p1q1*p2q2)-272*a2*mb**2*p1q2/(3*p1q1*p2q2)+
43366 &56*a1*mb*mt*p1q2/(3*p1q1*p2q2)+200*a2*mb*mt*p1q2/(3*p1q1*p2q2)-
43367 &48*a1*p1p2*p1q2/(p1q1*p2q2)-256*a2*p1p2*p1q2/(3*p1q1*p2q2)+
43368 &256*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2)+
43369 &256*a1*a2*mb*mt*p1p2*p1q2/(p1q1*p2q2)+
43370 &1024*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q2)
43371 v18=v18-272*a2*p1q2**2/(3*p1q1*p2q2)+
43372 &256*a1*a2*mb**2*p1q2**2/(3*p1q1*p2q2)+
43373 &256*a1*a2*mb*mt*p1q2**2/(3*p1q1*p2q2)+
43374 &512*a1*a2*p1p2*p1q2**2/(3*p1q1*p2q2)-32*a2*mb**4/(3*p2q1*p2q2)-
43375 &32*a2*mb**3*mt/(3*p2q1*p2q2)+64*a2**2*mb**5*mt/(3*p2q1*p2q2)+
43376 &16*p1p2/(3*p2q1*p2q2)-64*a2*mb**2*p1p2/(3*p2q1*p2q2)+
43377 &64*a2**2*mb**4*p1p2/(3*p2q1*p2q2)+8*mb**2*p1p2/(3*p1q1*p2q1*p2q2)+
43378 &8*mb*mt*p1p2/(3*p1q1*p2q1*p2q2)-
43379 &32*a2*mb**3*mt*p1p2/(3*p1q1*p2q1*p2q2)+
43380 &16*p1p2**2/(3*p1q1*p2q1*p2q2)-
43381 &32*a2*mb**2*p1p2**2/(3*p1q1*p2q1*p2q2)-
43382 &16*a2*mb**2*p1q1/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q1/(3*p2q1*p2q2)+
43383 &8*mb**2*p1p2/(3*p1q2*p2q1*p2q2)+8*mb*mt*p1p2/(3*p1q2*p2q1*p2q2)-
43384 &32*a2*mb**3*mt*p1p2/(3*p1q2*p2q1*p2q2)+
43385 &16*p1p2**2/(3*p1q2*p2q1*p2q2)-
43386 &32*a2*mb**2*p1p2**2/(3*p1q2*p2q1*p2q2)+
43387 &16*mb*mt*p1p2**2/(3*p1q1*p1q2*p2q1*p2q2)
43388 v18=v18+16*p1p2**3/(3*p1q1*p1q2*p2q1*p2q2)-
43389 &32*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1*p2q2)-
43390 &16*a2*mb**2*p1q2/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q2/(3*p2q1*p2q2)-
43391 &32*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1*p2q2)+272*a1*p2q1/(3*p2q2)+
43392 &112*a2*p2q1/p2q2-80*a1*a2*mb**2*p2q1/p2q2-
43393 &400*a1*a2*mb*mt*p2q1/(3*p2q2)+208*a2**2*mb*mt*p2q1/(3*p2q2)-
43394 &272*a1*a2*mt**2*p2q1/(3*p2q2)-320*a1*a2*p1p2*p2q1/p2q2+
43395 &96*a2**2*p1p2*p2q1/p2q2+256*a1*mb*mt**3*p2q1/(3*p1q1**2*p2q2)+
43396 &512*a1*mt**2*p1p2*p2q1/(3*p1q1**2*p2q2)-8*p2q1/(3*p1q1*p2q2)-
43397 &200*a1*mb*mt*p2q1/(3*p1q1*p2q2)-56*a2*mb*mt*p2q1/(3*p1q1*p2q2)+
43398 &272*a1*mt**2*p2q1/(3*p1q1*p2q2)+160*a2*mt**2*p2q1/(3*p1q1*p2q2)+
43399 &256*a1*p1p2*p2q1/(3*p1q1*p2q2)+48*a2*p1p2*p2q1/(p1q1*p2q2)-
43400 &256*a1*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2)-
43401 &256*a1*a2*mt**2*p1p2*p2q1/(3*p1q1*p2q2)-
43402 &1024*a1*a2*p1p2**2*p2q1/(3*p1q1*p2q2)-
43403 &544*a1*a2*p1q1*p2q1/(3*p2q2)-640*a2**2*p1q1*p2q1/(3*p2q2)-
43404 &32*a1*p1p2*p2q1/(3*p1q2*p2q2)
43405 v18=v18+32*a1*a2*mb*mt*p1p2*p2q1/(3*p1q2*p2q2)+
43406 &32*a1*a2*mt**2*p1p2*p2q1/(3*p1q2*p2q2)+
43407 &64*a1*a2*p1p2**2*p2q1/(3*p1q2*p2q2)-
43408 &32*a1*mt**2*p1p2*p2q1/(3*p1q1*p1q2*p2q2)+
43409 &64*a1*a2*p1p2*p1q1*p2q1/(3*p1q2*p2q2)-
43410 &944*a1*a2*p1q2*p2q1/(3*p2q2)-32*a2**2*p1q2*p2q1/p2q2+
43411 &256*a1*mt**2*p1q2*p2q1/(3*p1q1**2*p2q2)+
43412 &96*a1*p1q2*p2q1/(p1q1*p2q2)+96*a2*p1q2*p2q1/(p1q1*p2q2)-
43413 &128*a1*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2)-
43414 &256*a1*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2)-
43415 &128*a1*a2*mt**2*p1q2*p2q1/(3*p1q1*p2q2)-
43416 &512*a1*a2*p1p2*p1q2*p2q1/(p1q1*p2q2)-
43417 &512*a1*a2*p1q2**2*p2q1/(3*p1q1*p2q2)+544*a1*a2*p2q1**2/(3*p2q2)-
43418 &256*a1*mt**2*p2q1**2/(3*p1q1**2*p2q2)-
43419 &272*a1*p2q1**2/(3*p1q1*p2q2)+
43420 &256*a1*a2*mb*mt*p2q1**2/(3*p1q1*p2q2)+
43421 &256*a1*a2*mt**2*p2q1**2/(3*p1q1*p2q2)
43422 v18=v18+512*a1*a2*p1p2*p2q1**2/(3*p1q1*p2q2)+
43423 &512*a1*a2*p1q2*p2q1**2/(3*p1q1*p2q2)+224*a12*p2q2+
43424 &656*a1*a2*p2q2/3+256*a12*mt**4*p2q2/(3*p1q1**2)+
43425 &16*a1*p2q2/(3*p1q1)+112*a1*a2*mb*mt*p2q2/(3*p1q1)+
43426 &32*a12*mt**2*p2q2/(3*p1q1)+64*a1*a2*mt**2*p2q2/p1q1+
43427 &368*a1*a2*p1p2*p2q2/(3*p1q1)-256*a1*mt**2*p2q2/(3*p1q2**2)+
43428 &256*a12*mt**4*p2q2/(3*p1q2**2)-256*a1*p2q2/(3*p1q2)+
43429 &224*a1*a2*mb*mt*p2q2/(3*p1q2)-368*a12*mt**2*p2q2/(3*p1q2)+
43430 &448*a1*a2*mt**2*p2q2/(3*p1q2)+304*a1*a2*p1p2*p2q2/(3*p1q2)+
43431 &16*a1*mt**2*p2q2/(3*p1q1*p1q2)-64*a12*mt**4*p2q2/(3*p1q1*p1q2)+
43432 &32*a12*p1q1*p2q2/p1q2+944*a1*a2*p1q1*p2q2/(3*p1q2)+
43433 &256*a12*mt**2*p1q2*p2q2/(3*p1q1**2)+
43434 &640*a12*p1q2*p2q2/(3*p1q1)+544*a1*a2*p1q2*p2q2/(3*p1q1)-
43435 &256*a2*mb**2*p2q2/(3*p2q1**2)-256*a2**2*mb**3*mt*p2q2/(3*p2q1**2)+
43436 &64*mb**2*mt**2*p2q2/(3*p1q2**2*p2q1**2)+
43437 &64*mb**2*p2q2/(3*p1q2*p2q1**2)-
43438 &128*a2*mb**3*mt*p2q2/(3*p1q2*p2q1**2)
43439 v18=v18-128*a2*mb**2*mt**2*p2q2/(3*p1q2*p2q1**2)-
43440 &256*a2*mb**2*p1p2*p2q2/(3*p1q2*p2q1**2)-
43441 &256*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1**2)+
43442 &256*a2**2*mb**2*p1q2*p2q2/(3*p2q1**2)+272*a1*p2q2/(3*p2q1)+
43443 &112*a2*p2q2/p2q1-80*a1*a2*mb**2*p2q2/p2q1-
43444 &400*a1*a2*mb*mt*p2q2/(3*p2q1)+208*a2**2*mb*mt*p2q2/(3*p2q1)-
43445 &272*a1*a2*mt**2*p2q2/(3*p2q1)-320*a1*a2*p1p2*p2q2/p2q1+
43446 &96*a2**2*p1p2*p2q2/p2q1-32*a1*p1p2*p2q2/(3*p1q1*p2q1)+
43447 &32*a1*a2*mb*mt*p1p2*p2q2/(3*p1q1*p2q1)+
43448 &32*a1*a2*mt**2*p1p2*p2q2/(3*p1q1*p2q1)+
43449 &64*a1*a2*p1p2**2*p2q2/(3*p1q1*p2q1)-944*a1*a2*p1q1*p2q2/(3*p2q1)-
43450 &32*a2**2*p1q1*p2q2/p2q1+256*a1*mb*mt**3*p2q2/(3*p1q2**2*p2q1)+
43451 &512*a1*mt**2*p1p2*p2q2/(3*p1q2**2*p2q1)+
43452 &256*a1*mt**2*p1q1*p2q2/(3*p1q2**2*p2q1)-8*p2q2/(3*p1q2*p2q1)-
43453 &200*a1*mb*mt*p2q2/(3*p1q2*p2q1)-56*a2*mb*mt*p2q2/(3*p1q2*p2q1)+
43454 &272*a1*mt**2*p2q2/(3*p1q2*p2q1)+160*a2*mt**2*p2q2/(3*p1q2*p2q1)+
43455 &256*a1*p1p2*p2q2/(3*p1q2*p2q1)+48*a2*p1p2*p2q2/(p1q2*p2q1)
43456 v18=v18-256*a1*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1)-
43457 &256*a1*a2*mt**2*p1p2*p2q2/(3*p1q2*p2q1)-
43458 &1024*a1*a2*p1p2**2*p2q2/(3*p1q2*p2q1)-
43459 &32*a1*mt**2*p1p2*p2q2/(3*p1q1*p1q2*p2q1)+
43460 &96*a1*p1q1*p2q2/(p1q2*p2q1)+96*a2*p1q1*p2q2/(p1q2*p2q1)-
43461 &128*a1*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1)-
43462 &256*a1*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1)-
43463 &128*a1*a2*mt**2*p1q1*p2q2/(3*p1q2*p2q1)-
43464 &512*a1*a2*p1p2*p1q1*p2q2/(p1q2*p2q1)-
43465 &512*a1*a2*p1q1**2*p2q2/(3*p1q2*p2q1)-544*a1*a2*p1q2*p2q2/(3*p2q1)-
43466 &640*a2**2*p1q2*p2q2/(3*p2q1)+
43467 &64*a1*a2*p1p2*p1q2*p2q2/(3*p1q1*p2q1)+544*a1*a2*p2q2**2/(3*p2q1)-
43468 &256*a1*mt**2*p2q2**2/(3*p1q2**2*p2q1)-
43469 &272*a1*p2q2**2/(3*p1q2*p2q1)+
43470 &256*a1*a2*mb*mt*p2q2**2/(3*p1q2*p2q1)+
43471 &256*a1*a2*mt**2*p2q2**2/(3*p1q2*p2q1)+
43472 &512*a1*a2*p1p2*p2q2**2/(3*p1q2*p2q1)
43473 v18=v18+512*a1*a2*p1q1*p2q2**2/(3*p1q2*p2q1)+
43474 &384*a12*mb*mt*p1q1**2/s**2+
43475 &384*a12*p1p2*p1q1**2/s**2+2688*a12*mb*mt*p1q1*p1q2/s**2+
43476 &2688*a12*p1p2*p1q1*p1q2/s**2+384*a12*mb*mt*p1q2**2/s**2+
43477 &384*a12*p1p2*p1q2**2/s**2+768*a1*a2*mb*mt*p1q1*p2q1/s**2+
43478 &768*a1*a2*p1p2*p1q1*p2q1/s**2+2688*a1*a2*mb*mt*p1q2*p2q1/s**2+
43479 &2688*a1*a2*p1p2*p1q2*p2q1/s**2-960*a12*p1q1*p1q2*p2q1/s**2-
43480 &960*a1*a2*p1q1*p1q2*p2q1/s**2+960*a12*p1q2**2*p2q1/s**2+
43481 &960*a1*a2*p1q2**2*p2q1/s**2+384*a2**2*mb*mt*p2q1**2/s**2+
43482 &384*a2**2*p1p2*p2q1**2/s**2-960*a1*a2*p1q2*p2q1**2/s**2-
43483 &960*a2**2*p1q2*p2q1**2/s**2+2688*a1*a2*mb*mt*p1q1*p2q2/s**2+
43484 &2688*a1*a2*p1p2*p1q1*p2q2/s**2+960*a12*p1q1**2*p2q2/s**2+
43485 &960*a1*a2*p1q1**2*p2q2/s**2+768*a1*a2*mb*mt*p1q2*p2q2/s**2+
43486 &768*a1*a2*p1p2*p1q2*p2q2/s**2-960*a12*p1q1*p1q2*p2q2/s**2-
43487 &960*a1*a2*p1q1*p1q2*p2q2/s**2+2688*a2**2*mb*mt*p2q1*p2q2/s**2+
43488 &2688*a2**2*p1p2*p2q1*p2q2/s**2+960*a1*a2*p1q1*p2q1*p2q2/s**2+
43489 &960*a2**2*p1q1*p2q1*p2q2/s**2+960*a1*a2*p1q2*p2q1*p2q2/s**2+
43490 &960*a2**2*p1q2*p2q1*p2q2/s**2+384*a2**2*mb*mt*p2q2**2/s**2
43491 v18=v18+384*a2**2*p1p2*p2q2**2/s**2-960*a1*a2*p1q1*p2q2**2/s**2-
43492 &960*a2**2*p1q1*p2q2**2/s**2+96*a1*mb*mt/s+96*a2*mb*mt/s-
43493 &768*a2**2*mb**3*mt/s-768*a12*mb*mt**3/s-192*a1*p1p2/s-
43494 &192*a2*p1p2/s-768*a2**2*mb**2*p1p2/s-2304*a1*a2*mb*mt*p1p2/s-
43495 &768*a12*mt**2*p1p2/s-2304*a1*a2*p1p2**2/s-
43496 &96*a1*mb*mt**3/(p1q1*s)-192*a2*mb*mt*p1p2/(p1q1*s)-
43497 &96*a1*mt**2*p1p2/(p1q1*s)-192*a2*p1p2**2/(p1q1*s)-192*a1*p1q1/s-
43498 &144*a2*p1q1/s-384*a1*a2*mb**2*p1q1/s-480*a2**2*mb**2*p1q1/s-
43499 &480*a12*mb*mt*p1q1/s+96*a1*a2*mb*mt*p1q1/s-
43500 &864*a12*p1p2*p1q1/s-672*a1*a2*p1p2*p1q1/s-96*a1*a2*p1q1**2/s-
43501 &96*a1*mb*mt**3/(p1q2*s)-192*a2*mb*mt*p1p2/(p1q2*s)-
43502 &96*a1*mt**2*p1p2/(p1q2*s)-192*a2*p1p2**2/(p1q2*s)-
43503 &48*a1*mb*mt*p1q1/(p1q2*s)+96*a2*mb*mt*p1q1/(p1q2*s)-
43504 &48*a1*mt**2*p1q1/(p1q2*s)-192*a1*p1p2*p1q1/(p1q2*s)-
43505 &192*a2*p1p2*p1q1/(p1q2*s)+192*a1*a2*mb*mt*p1p2*p1q1/(p1q2*s)+
43506 &192*a1*a2*p1p2**2*p1q1/(p1q2*s)-192*a1*p1q1**2/(p1q2*s)-
43507 &192*a2*p1q1**2/(p1q2*s)+192*a1*a2*mb**2*p1q1**2/(p1q2*s)
43508 v18=v18-192*a12*mb*mt*p1q1**2/(p1q2*s)+
43509 &96*a1*a2*mb*mt*p1q1**2/(p1q2*s)+
43510 &192*a1*a2*p1p2*p1q1**2/(p1q2*s)-192*a1*p1q2/s-144*a2*p1q2/s-
43511 &384*a1*a2*mb**2*p1q2/s-480*a2**2*mb**2*p1q2/s-
43512 &480*a12*mb*mt*p1q2/s+96*a1*a2*mb*mt*p1q2/s-
43513 &864*a12*p1p2*p1q2/s-672*a1*a2*p1p2*p1q2/s-
43514 &48*a1*mb*mt*p1q2/(p1q1*s)+96*a2*mb*mt*p1q2/(p1q1*s)-
43515 &48*a1*mt**2*p1q2/(p1q1*s)-192*a1*p1p2*p1q2/(p1q1*s)-
43516 &192*a2*p1p2*p1q2/(p1q1*s)+192*a1*a2*mb*mt*p1p2*p1q2/(p1q1*s)+
43517 &192*a1*a2*p1p2**2*p1q2/(p1q1*s)-576*a1*a2*p1q1*p1q2/s-
43518 &96*a1*a2*p1q2**2/s-192*a1*p1q2**2/(p1q1*s)-
43519 &192*a2*p1q2**2/(p1q1*s)+192*a1*a2*mb**2*p1q2**2/(p1q1*s)-
43520 &192*a12*mb*mt*p1q2**2/(p1q1*s)+96*a1*a2*mb*mt*p1q2**2/(p1q1*s)+
43521 &192*a1*a2*p1p2*p1q2**2/(p1q1*s)+96*a2*mb**3*mt/(p2q1*s)+
43522 &96*a2*mb**2*p1p2/(p2q1*s)+192*a1*mb*mt*p1p2/(p2q1*s)+
43523 &192*a1*p1p2**2/(p2q1*s)+96*a1*mb**2*p1q1/(p2q1*s)+
43524 &192*a2*mb**2*p1q1/(p2q1*s)+96*a1*mb*mt*p1q1/(p2q1*s)+
43525 &192*a1*a2*mb**3*mt*p1q1/(p2q1*s)+192*a1*p1p2*p1q1/(p2q1*s)
43526 v18=v18+192*a1*a2*mb**2*p1p2*p1q1/(p2q1*s)+
43527 &96*a1*a2*mb**2*p1q1**2/(p2q1*s)+
43528 &192*a2*mb**3*mt*p1q1/(p1q2*p2q1*s)+
43529 &192*a2*mb**2*p1p2*p1q1/(p1q2*p2q1*s)+
43530 &96*a1*mb*mt*p1p2*p1q1/(p1q2*p2q1*s)+
43531 &96*a1*p1p2**2*p1q1/(p1q2*p2q1*s)+
43532 &96*a1*mb**2*p1q1**2/(p1q2*p2q1*s)+
43533 &192*a2*mb**2*p1q1**2/(p1q2*p2q1*s)+
43534 &48*a1*mb*mt*p1q1**2/(p1q2*p2q1*s)+
43535 &96*a1*p1p2*p1q1**2/(p1q2*p2q1*s)+96*a1*mb**2*p1q2/(p2q1*s)+
43536 &48*a2*mb**2*p1q2/(p2q1*s)-192*a1*a2*mb**3*mt*p1q2/(p2q1*s)-
43537 &192*a1*a2*mb**2*p1p2*p1q2/(p2q1*s)-
43538 &96*a1*a2*mb**2*p1q2**2/(p2q1*s)+144*a1*p2q1/s+192*a2*p2q1/s-
43539 &96*a1*a2*mb*mt*p2q1/s+480*a2**2*mb*mt*p2q1/s+
43540 &480*a12*mt**2*p2q1/s+384*a1*a2*mt**2*p2q1/s+
43541 &672*a1*a2*p1p2*p2q1/s+864*a2**2*p1p2*p2q1/s+
43542 &96*a2*mb*mt*p2q1/(p1q1*s)+192*a1*mt**2*p2q1/(p1q1*s)
43543 v18=v18+96*a2*mt**2*p2q1/(p1q1*s)+
43544 &192*a1*a2*mb*mt**3*p2q1/(p1q1*s)+
43545 &192*a2*p1p2*p2q1/(p1q1*s)+192*a1*a2*mt**2*p1p2*p2q1/(p1q1*s)-
43546 &192*a12*p1q1*p2q1/s-192*a2**2*p1q1*p2q1/s+
43547 &48*a1*mt**2*p2q1/(p1q2*s)+96*a2*mt**2*p2q1/(p1q2*s)-
43548 &192*a1*a2*mb*mt**3*p2q1/(p1q2*s)-
43549 &192*a1*a2*mt**2*p1p2*p2q1/(p1q2*s)-
43550 &96*a1*a2*mb*mt*p1q1*p2q1/(p1q2*s)-
43551 &192*a12*mt**2*p1q1*p2q1/(p1q2*s)-
43552 &96*a1*a2*mt**2*p1q1*p2q1/(p1q2*s)-
43553 &384*a1*a2*p1p2*p1q1*p2q1/(p1q2*s)-384*a12*p1q1**2*p2q1/(p1q2*s)-
43554 &384*a1*a2*p1q1**2*p2q1/(p1q2*s)-480*a12*p1q2*p2q1/s-
43555 &960*a1*a2*p1q2*p2q1/s-480*a2**2*p1q2*p2q1/s+
43556 &144*a1*p1q2*p2q1/(p1q1*s)+96*a2*p1q2*p2q1/(p1q1*s)-
43557 &384*a1*a2*mb*mt*p1q2*p2q1/(p1q1*s)-
43558 &96*a12*mt**2*p1q2*p2q1/(p1q1*s)+
43559 &96*a1*a2*mt**2*p1q2*p2q1/(p1q1*s)-
43560 &576*a1*a2*p1p2*p1q2*p2q1/(p1q1*s)-192*a12*p1q2**2*p2q1/(p1q1*s)
43561 v18=v18-384*a1*a2*p1q2**2*p2q1/(p1q1*s)-96*a1*a2*p2q1**2/s-
43562 &96*a1*a2*mt**2*p2q1**2/(p1q1*s)+96*a1*a2*mt**2*p2q1**2/(p1q2*s)+
43563 &288*a1*a2*p1q2*p2q1**2/(p1q1*s)+96*a2*mb**3*mt/(p2q2*s)+
43564 &96*a2*mb**2*p1p2/(p2q2*s)+192*a1*mb*mt*p1p2/(p2q2*s)+
43565 &192*a1*p1p2**2/(p2q2*s)+96*a1*mb**2*p1q1/(p2q2*s)+
43566 &48*a2*mb**2*p1q1/(p2q2*s)-192*a1*a2*mb**3*mt*p1q1/(p2q2*s)-
43567 &192*a1*a2*mb**2*p1p2*p1q1/(p2q2*s)-
43568 &96*a1*a2*mb**2*p1q1**2/(p2q2*s)+96*a1*mb**2*p1q2/(p2q2*s)+
43569 &192*a2*mb**2*p1q2/(p2q2*s)+96*a1*mb*mt*p1q2/(p2q2*s)+
43570 &192*a1*a2*mb**3*mt*p1q2/(p2q2*s)+192*a1*p1p2*p1q2/(p2q2*s)+
43571 &192*a1*a2*mb**2*p1p2*p1q2/(p2q2*s)+
43572 &192*a2*mb**3*mt*p1q2/(p1q1*p2q2*s)+
43573 &192*a2*mb**2*p1p2*p1q2/(p1q1*p2q2*s)+
43574 &96*a1*mb*mt*p1p2*p1q2/(p1q1*p2q2*s)+
43575 &96*a1*p1p2**2*p1q2/(p1q1*p2q2*s)+96*a1*a2*mb**2*p1q2**2/(p2q2*s)+
43576 &96*a1*mb**2*p1q2**2/(p1q1*p2q2*s)+
43577 &192*a2*mb**2*p1q2**2/(p1q1*p2q2*s)
43578 v18=v18+48*a1*mb*mt*p1q2**2/(p1q1*p2q2*s)+
43579 &96*a1*p1p2*p1q2**2/(p1q1*p2q2*s)-48*a2*mb**2*p2q1/(p2q2*s)+
43580 &96*a1*mb*mt*p2q1/(p2q2*s)-48*a2*mb*mt*p2q1/(p2q2*s)-
43581 &192*a1*p1p2*p2q1/(p2q2*s)-192*a2*p1p2*p2q1/(p2q2*s)+
43582 &192*a1*a2*mb*mt*p1p2*p2q1/(p2q2*s)+
43583 &192*a1*a2*p1p2**2*p2q1/(p2q2*s)-
43584 &192*a1*mb*mt**3*p2q1/(p1q1*p2q2*s)-
43585 &96*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2*s)-
43586 &192*a1*mt**2*p1p2*p2q1/(p1q1*p2q2*s)-
43587 &96*a2*p1p2**2*p2q1/(p1q1*p2q2*s)+
43588 &96*a1*a2*mb**2*p1q1*p2q1/(p2q2*s)+
43589 &192*a2**2*mb**2*p1q1*p2q1/(p2q2*s)+
43590 &96*a1*a2*mb*mt*p1q1*p2q1/(p2q2*s)+
43591 &384*a1*a2*p1p2*p1q1*p2q1/(p2q2*s)-96*a1*p1q2*p2q1/(p2q2*s)-
43592 &144*a2*p1q2*p2q1/(p2q2*s)-96*a1*a2*mb**2*p1q2*p2q1/(p2q2*s)+
43593 &96*a2**2*mb**2*p1q2*p2q1/(p2q2*s)+
43594 &384*a1*a2*mb*mt*p1q2*p2q1/(p2q2*s)
43595 v18=v18+576*a1*a2*p1p2*p1q2*p2q1/(p2q2*s)-
43596 &96*a2*mb**2*p1q2*p2q1/(p1q1*p2q2*s)+
43597 &48*a1*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)+
43598 &48*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
43599 &96*a1*mt**2*p1q2*p2q1/(p1q1*p2q2*s)-
43600 &96*a1*p1p2*p1q2*p2q1/(p1q1*p2q2*s)-
43601 &96*a2*p1p2*p1q2*p2q1/(p1q1*p2q2*s)+
43602 &96*a1*a2*p1q1*p1q2*p2q1/(p2q2*s)+288*a1*a2*p1q2**2*p2q1/(p2q2*s)-
43603 &96*a1*p1q2**2*p2q1/(p1q1*p2q2*s)-96*a2*p1q2**2*p2q1/(p1q1*p2q2*s)+
43604 &192*a1*p2q1**2/(p2q2*s)+192*a2*p2q1**2/(p2q2*s)-
43605 &96*a1*a2*mb*mt*p2q1**2/(p2q2*s)+192*a2**2*mb*mt*p2q1**2/(p2q2*s)-
43606 &192*a1*a2*mt**2*p2q1**2/(p2q2*s)-192*a1*a2*p1p2*p2q1**2/(p2q2*s)+
43607 &48*a2*mb*mt*p2q1**2/(p1q1*p2q2*s)+
43608 &192*a1*mt**2*p2q1**2/(p1q1*p2q2*s)+
43609 &96*a2*mt**2*p2q1**2/(p1q1*p2q2*s)+
43610 &96*a2*p1p2*p2q1**2/(p1q1*p2q2*s)-384*a1*a2*p1q1*p2q1**2/(p2q2*s)-
43611 &384*a2**2*p1q1*p2q1**2/(p2q2*s)-384*a1*a2*p1q2*p2q1**2/(p2q2*s)
43612 v18=v18-192*a2**2*p1q2*p2q1**2/(p2q2*s)+
43613 &96*a1*p1q2*p2q1**2/(p1q1*p2q2*s)+
43614 &96*a2*p1q2*p2q1**2/(p1q1*p2q2*s)+144*a1*p2q2/s+192*a2*p2q2/s-
43615 &96*a1*a2*mb*mt*p2q2/s+480*a2**2*mb*mt*p2q2/s+
43616 &480*a12*mt**2*p2q2/s+384*a1*a2*mt**2*p2q2/s+
43617 &672*a1*a2*p1p2*p2q2/s+864*a2**2*p1p2*p2q2/s+
43618 &48*a1*mt**2*p2q2/(p1q1*s)+96*a2*mt**2*p2q2/(p1q1*s)-
43619 &192*a1*a2*mb*mt**3*p2q2/(p1q1*s)-
43620 &192*a1*a2*mt**2*p1p2*p2q2/(p1q1*s)-480*a12*p1q1*p2q2/s-
43621 &960*a1*a2*p1q1*p2q2/s-480*a2**2*p1q1*p2q2/s+
43622 &96*a2*mb*mt*p2q2/(p1q2*s)+192*a1*mt**2*p2q2/(p1q2*s)+
43623 &96*a2*mt**2*p2q2/(p1q2*s)+192*a1*a2*mb*mt**3*p2q2/(p1q2*s)+
43624 &192*a2*p1p2*p2q2/(p1q2*s)+192*a1*a2*mt**2*p1p2*p2q2/(p1q2*s)+
43625 &144*a1*p1q1*p2q2/(p1q2*s)+96*a2*p1q1*p2q2/(p1q2*s)-
43626 &384*a1*a2*mb*mt*p1q1*p2q2/(p1q2*s)-
43627 &96*a12*mt**2*p1q1*p2q2/(p1q2*s)+
43628 &96*a1*a2*mt**2*p1q1*p2q2/(p1q2*s)
43629 v18=v18-576*a1*a2*p1p2*p1q1*p2q2/(p1q2*s)-
43630 &192*a12*p1q1**2*p2q2/(p1q2*s)-
43631 &384*a1*a2*p1q1**2*p2q2/(p1q2*s)-192*a12*p1q2*p2q2/s-
43632 &192*a2**2*p1q2*p2q2/s-96*a1*a2*mb*mt*p1q2*p2q2/(p1q1*s)-
43633 &192*a12*mt**2*p1q2*p2q2/(p1q1*s)-
43634 &96*a1*a2*mt**2*p1q2*p2q2/(p1q1*s)-
43635 &384*a1*a2*p1p2*p1q2*p2q2/(p1q1*s)-384*a12*p1q2**2*p2q2/(p1q1*s)-
43636 &384*a1*a2*p1q2**2*p2q2/(p1q1*s)-48*a2*mb**2*p2q2/(p2q1*s)+
43637 &96*a1*mb*mt*p2q2/(p2q1*s)-48*a2*mb*mt*p2q2/(p2q1*s)-
43638 &192*a1*p1p2*p2q2/(p2q1*s)-192*a2*p1p2*p2q2/(p2q1*s)+
43639 &192*a1*a2*mb*mt*p1p2*p2q2/(p2q1*s)+
43640 &192*a1*a2*p1p2**2*p2q2/(p2q1*s)-96*a1*p1q1*p2q2/(p2q1*s)-
43641 &144*a2*p1q1*p2q2/(p2q1*s)-96*a1*a2*mb**2*p1q1*p2q2/(p2q1*s)+
43642 &96*a2**2*mb**2*p1q1*p2q2/(p2q1*s)+
43643 &384*a1*a2*mb*mt*p1q1*p2q2/(p2q1*s)+
43644 &576*a1*a2*p1p2*p1q1*p2q2/(p2q1*s)+288*a1*a2*p1q1**2*p2q2/(p2q1*s)-
43645 &192*a1*mb*mt**3*p2q2/(p1q2*p2q1*s)
43646 v18=v18-96*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1*s)-
43647 &192*a1*mt**2*p1p2*p2q2/(p1q2*p2q1*s)-
43648 &96*a2*p1p2**2*p2q2/(p1q2*p2q1*s)-
43649 &96*a2*mb**2*p1q1*p2q2/(p1q2*p2q1*s)+
43650 &48*a1*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)
43651
43652 v18bis=
43653 &48*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
43654 &96*a1*mt**2*p1q1*p2q2/(p1q2*p2q1*s)-
43655 &96*a1*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
43656 &96*a2*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
43657 &96*a1*p1q1**2*p2q2/(p1q2*p2q1*s)-96*a2*p1q1**2*p2q2/(p1q2*p2q1*s)+
43658 &96*a1*a2*mb**2*p1q2*p2q2/(p2q1*s)+
43659 &192*a2**2*mb**2*p1q2*p2q2/(p2q1*s)+
43660 &96*a1*a2*mb*mt*p1q2*p2q2/(p2q1*s)+
43661 &384*a1*a2*p1p2*p1q2*p2q2/(p2q1*s)+
43662 &96*a1*a2*p1q1*p1q2*p2q2/(p2q1*s)-576*a1*a2*p2q1*p2q2/s+
43663 &96*a1*a2*p1q1*p2q1*p2q2/(p1q2*s)+96*a1*a2*p1q2*p2q1*p2q2/(p1q1*s)-
43664 &96*a1*a2*p2q2**2/s+96*a1*a2*mt**2*p2q2**2/(p1q1*s)-
43665 &96*a1*a2*mt**2*p2q2**2/(p1q2*s)+288*a1*a2*p1q1*p2q2**2/(p1q2*s)+
43666 &192*a1*p2q2**2/(p2q1*s)+192*a2*p2q2**2/(p2q1*s)-
43667 &96*a1*a2*mb*mt*p2q2**2/(p2q1*s)+192*a2**2*mb*mt*p2q2**2/(p2q1*s)-
43668 &192*a1*a2*mt**2*p2q2**2/(p2q1*s)-192*a1*a2*p1p2*p2q2**2/(p2q1*s)
43669 v18bis=v18bis-384*a1*a2*p1q1*p2q2**2/(p2q1*s)-
43670 &192*a2**2*p1q1*p2q2**2/(p2q1*s)+
43671 &48*a2*mb*mt*p2q2**2/(p1q2*p2q1*s)+
43672 &192*a1*mt**2*p2q2**2/(p1q2*p2q1*s)+
43673 &96*a2*mt**2*p2q2**2/(p1q2*p2q1*s)+
43674 &96*a2*p1p2*p2q2**2/(p1q2*p2q1*s)+96*a1*p1q1*p2q2**2/(p1q2*p2q1*s)+
43675 &96*a2*p1q1*p2q2**2/(p1q2*p2q1*s)-384*a1*a2*p1q2*p2q2**2/(p2q1*s)-
43676 &384*a2**2*p1q2*p2q2**2/(p2q1*s)+512*a1*a2*s/3-
43677 &128*a1*mt**2*s/(3*p1q1**2)-128*a12*mb*mt**3*s/(3*p1q1**2)-
43678 &152*a1*s/(3*p1q1)+152*a12*mb*mt*s/(3*p1q1)+
43679 &128*a1*a2*mb*mt*s/(3*p1q1)+112*a1*a2*mt**2*s/(3*p1q1)-
43680 &16*a12*p1p2*s/p1q1+152*a1*a2*p1p2*s/(3*p1q1)-
43681 &128*a1*mt**2*s/(3*p1q2**2)-128*a12*mb*mt**3*s/(3*p1q2**2)-
43682 &152*a1*s/(3*p1q2)+152*a12*mb*mt*s/(3*p1q2)+
43683 &128*a1*a2*mb*mt*s/(3*p1q2)+112*a1*a2*mt**2*s/(3*p1q2)-
43684 &16*a12*p1p2*s/p1q2+152*a1*a2*p1p2*s/(3*p1q2)-
43685 &16*a1*mb*mt*s/(3*p1q1*p1q2)+32*a12*mb*mt**3*s/(3*p1q1*p1q2)
43686 v18bis=v18bis-16*a1*p1p2*s/(3*p1q1*p1q2)+
43687 &272*a1*a2*p1q1*s/(3*p1q2)+
43688 &272*a1*a2*p1q2*s/(3*p1q1)-128*a2*mb**2*s/(3*p2q1**2)-
43689 &128*a2**2*mb**3*mt*s/(3*p2q1**2)+
43690 &32*mb**2*mt**2*s/(3*p1q2**2*p2q1**2)+32*mb**2*s/(3*p1q2*p2q1**2)-
43691 &64*a2*mb**3*mt*s/(3*p1q2*p2q1**2)-
43692 &64*a2*mb**2*mt**2*s/(3*p1q2*p2q1**2)-
43693 &128*a2*mb**2*p1p2*s/(3*p1q2*p2q1**2)-
43694 &128*a2*mb**2*p1q1*s/(3*p1q2*p2q1**2)+
43695 &128*a2**2*mb**2*p1q2*s/(3*p2q1**2)+152*a2*s/(3*p2q1)-
43696 &112*a1*a2*mb**2*s/(3*p2q1)-128*a1*a2*mb*mt*s/(3*p2q1)-
43697 &152*a2**2*mb*mt*s/(3*p2q1)-152*a1*a2*p1p2*s/(3*p2q1)+
43698 &16*a2**2*p1p2*s/p2q1+8*a1*a2*mb**3*mt*s/(3*p1q1*p2q1)+
43699 &16*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q1)+
43700 &8*a1*a2*mb*mt**3*s/(3*p1q1*p2q1)-8*a1*p1p2*s/(3*p1q1*p2q1)-
43701 &8*a2*p1p2*s/(3*p1q1*p2q1)+8*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q1)+
43702 &16*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q1)
43703 v18bis=v18bis+8*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q1)+
43704 &32*a1*a2*p1p2**2*s/(3*p1q1*p2q1)-32*a2**2*p1q1*s/(3*p2q1)-
43705 &32*mt**2*s/(3*p1q2**2*p2q1)+64*a1*mb**2*mt**2*s/(3*p1q2**2*p2q1)+
43706 &64*a1*mb*mt**3*s/(3*p1q2**2*p2q1)+
43707 &128*a1*mt**2*p1p2*s/(3*p1q2**2*p2q1)-12*s/(p1q2*p2q1)+
43708 &24*a1*mb**2*s/(p1q2*p2q1)-64*a1*a2*mb**3*mt*s/(3*p1q2*p2q1)+
43709 &24*a2*mt**2*s/(p1q2*p2q1)-128*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q1)-
43710 &64*a1*a2*mb*mt**3*s/(3*p1q2*p2q1)+56*a1*p1p2*s/(3*p1q2*p2q1)+
43711 &56*a2*p1p2*s/(3*p1q2*p2q1)-64*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q1)-
43712 &128*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q1)-
43713 &64*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q1)-
43714 &256*a1*a2*p1p2**2*s/(3*p1q2*p2q1)+4*p1p2*s/(3*p1q1*p1q2*p2q1)+
43715 &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1)-
43716 &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1)+136*a2*p1q1*s/(3*p1q2*p2q1)-
43717 &128*a1*a2*mb**2*p1q1*s/(3*p1q2*p2q1)-
43718 &128*a1*a2*mb*mt*p1q1*s/(3*p1q2*p2q1)-
43719 &256*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q1)-160*a2**2*p1q2*s/(3*p2q1)
43720 v18bis=v18bis+16*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q1)-
43721 &32*a12*p2q1*s/(3*p1q1)-
43722 &128*a12*mt**2*p2q1*s/(3*p1q2**2)-160*a12*p2q1*s/(3*p1q2)-
43723 &128*a2*mb**2*s/(3*p2q2**2)-128*a2**2*mb**3*mt*s/(3*p2q2**2)+
43724 &32*mb**2*mt**2*s/(3*p1q1**2*p2q2**2)+32*mb**2*s/(3*p1q1*p2q2**2)-
43725 &64*a2*mb**3*mt*s/(3*p1q1*p2q2**2)-
43726 &64*a2*mb**2*mt**2*s/(3*p1q1*p2q2**2)-
43727 &128*a2*mb**2*p1p2*s/(3*p1q1*p2q2**2)+
43728 &128*a2**2*mb**2*p1q1*s/(3*p2q2**2)-
43729 &128*a2*mb**2*p1q2*s/(3*p1q1*p2q2**2)+152*a2*s/(3*p2q2)-
43730 &112*a1*a2*mb**2*s/(3*p2q2)-128*a1*a2*mb*mt*s/(3*p2q2)-
43731 &152*a2**2*mb*mt*s/(3*p2q2)-152*a1*a2*p1p2*s/(3*p2q2)+
43732 &16*a2**2*p1p2*s/p2q2-32*mt**2*s/(3*p1q1**2*p2q2)+
43733 &64*a1*mb**2*mt**2*s/(3*p1q1**2*p2q2)+
43734 &64*a1*mb*mt**3*s/(3*p1q1**2*p2q2)+
43735 &128*a1*mt**2*p1p2*s/(3*p1q1**2*p2q2)-12*s/(p1q1*p2q2)+
43736 &24*a1*mb**2*s/(p1q1*p2q2)-64*a1*a2*mb**3*mt*s/(3*p1q1*p2q2)
43737 v18bis=v18bis+24*a2*mt**2*s/(p1q1*p2q2)-
43738 &128*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q2)-
43739 &64*a1*a2*mb*mt**3*s/(3*p1q1*p2q2)+56*a1*p1p2*s/(3*p1q1*p2q2)+
43740 &56*a2*p1p2*s/(3*p1q1*p2q2)-64*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q2)-
43741 &128*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q2)-
43742 &64*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q2)-
43743 &256*a1*a2*p1p2**2*s/(3*p1q1*p2q2)-160*a2**2*p1q1*s/(3*p2q2)+
43744 &8*a1*a2*mb**3*mt*s/(3*p1q2*p2q2)+
43745 &16*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q2)+
43746 &8*a1*a2*mb*mt**3*s/(3*p1q2*p2q2)-8*a1*p1p2*s/(3*p1q2*p2q2)-
43747 &8*a2*p1p2*s/(3*p1q2*p2q2)+8*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q2)+
43748 &16*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q2)+
43749 &8*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q2)+
43750 &32*a1*a2*p1p2**2*s/(3*p1q2*p2q2)+4*p1p2*s/(3*p1q1*p1q2*p2q2)+
43751 &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q2)-
43752 &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q2)+
43753 &16*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q2)-32*a2**2*p1q2*s/(3*p2q2)
43754 v18bis=v18bis+136*a2*p1q2*s/(3*p1q1*p2q2)-
43755 &128*a1*a2*mb**2*p1q2*s/(3*p1q1*p2q2)-
43756 &128*a1*a2*mb*mt*p1q2*s/(3*p1q1*p2q2)-
43757 &256*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q2)-16*a2*mb*mt*s/(3*p2q1*p2q2)+
43758 &32*a2**2*mb**3*mt*s/(3*p2q1*p2q2)-16*a2*p1p2*s/(3*p2q1*p2q2)-
43759 &4*p1p2*s/(3*p1q1*p2q1*p2q2)+8*a2*mb**2*p1p2*s/(3*p1q1*p2q1*p2q2)-
43760 &8*a2*mb*mt*p1p2*s/(3*p1q1*p2q1*p2q2)-4*p1p2*s/(3*p1q2*p2q1*p2q2)+
43761 &8*a2*mb**2*p1p2*s/(3*p1q2*p2q1*p2q2)-
43762 &8*a2*mb*mt*p1p2*s/(3*p1q2*p2q1*p2q2)+
43763 &2*mb**3*mt*s/(3*p1q1*p1q2*p2q1*p2q2)+
43764 &4*mb**2*mt**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
43765 &2*mb*mt**3*s/(3*p1q1*p1q2*p2q1*p2q2)-
43766 &2*mb**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
43767 &4*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
43768 &2*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
43769 &8*p1p2**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
43770 &8*a2*p1p2*p1q1*s/(3*p1q2*p2q1*p2q2)
43771 v18bis=v18bis+8*a2*p1p2*p1q2*s/(3*p1q1*p2q1*p2q2)+
43772 &272*a1*a2*p2q1*s/(3*p2q2)-
43773 &128*a1*mt**2*p2q1*s/(3*p1q1**2*p2q2)-136*a1*p2q1*s/(3*p1q1*p2q2)+
43774 &128*a1*a2*mb*mt*p2q1*s/(3*p1q1*p2q2)+
43775 &128*a1*a2*mt**2*p2q1*s/(3*p1q1*p2q2)+
43776 &256*a1*a2*p1p2*p2q1*s/(3*p1q1*p2q2)-
43777 &16*a1*a2*p1p2*p2q1*s/(3*p1q2*p2q2)+
43778 &8*a1*p1p2*p2q1*s/(3*p1q1*p1q2*p2q2)+
43779 &256*a1*a2*p1q2*p2q1*s/(3*p1q1*p2q2)-
43780 &128*a12*mt**2*p2q2*s/(3*p1q1**2)-160*a12*p2q2*s/(3*p1q1)-
43781 &32*a12*p2q2*s/(3*p1q2)+272*a1*a2*p2q2*s/(3*p2q1)-
43782 &16*a1*a2*p1p2*p2q2*s/(3*p1q1*p2q1)-
43783 &128*a1*mt**2*p2q2*s/(3*p1q2**2*p2q1)-136*a1*p2q2*s/(3*p1q2*p2q1)+
43784 &128*a1*a2*mb*mt*p2q2*s/(3*p1q2*p2q1)+
43785 &128*a1*a2*mt**2*p2q2*s/(3*p1q2*p2q1)+
43786 &256*a1*a2*p1p2*p2q2*s/(3*p1q2*p2q1)+
43787 &8*a1*p1p2*p2q2*s/(3*p1q1*p1q2*p2q1)
43788 v18bis=v18bis+256*a1*a2*p1q1*p2q2*s/(3*p1q2*p2q1)+
43789 &8*a12*mb*mt*s**2/(3*p1q1*p1q2)+16*a12*p1p2*s**2/(3*p1q1*p1q2)-
43790 &8*a1*a2*p1p2*s**2/(3*p1q1*p2q1)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q1)-
43791 &8*a1*a2*p1p2*s**2/(3*p1q2*p2q2)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q2)+
43792 &8*a2**2*mb*mt*s**2/(3*p2q1*p2q2)+16*a2**2*p1p2*s**2/(3*p2q1*p2q2)-
43793 &4*a2*p1p2*s**2/(3*p1q1*p2q1*p2q2)-
43794 &4*a2*p1p2*s**2/(3*p1q2*p2q1*p2q2)+
43795 &2*p1p2*s**2/(3*p1q1*p1q2*p2q1*p2q2)
43796C
43797
43798 a18 = 640*a1/3+640*a2/3+32*a1*a2*mb**2+368*a12*mb*mt+
43799 &512*a1*a2*mb*mt/3+
43800 &368*a2**2*mb*mt+32*a1*a2*mt**2+496*a12*p1p2/3+
43801 &320*a1*a2*p1p2+496*a2**2*p1p2/3-128*a1*mb*mt**3/(3*p1q1**2)+
43802 &128*a1*mt**4/(3*p1q1**2)+256*a12*mb*mt**5/(3*p1q1**2)+
43803 &256*a1*mt**2*p1p2/(3*p1q1**2)-256*a12*mt**4*p1p2/(3*p1q1**2)+
43804 &8/(3*p1q1)+32*a1*mb*mt/p1q1+56*a2*mb*mt/(3*p1q1)+
43805 &88*a1*mt**2/(3*p1q1)+72*a2*mt**2/p1q1-
43806 &704*a12*mb*mt**3/(3*p1q1)+224*a1*a2*mb*mt**3/(3*p1q1)+
43807 &104*a1*p1p2/(3*p1q1)+48*a2*p1p2/p1q1-
43808 &128*a1*a2*mb*mt*p1p2/(3*p1q1)+512*a12*mt**2*p1p2/(3*p1q1)-
43809 &448*a1*a2*mt**2*p1p2/(3*p1q1)-32*a1*a2*p1p2**2/p1q1-
43810 &656*a1*a2*p1q1/3-224*a2**2*p1q1-128*a1*mb*mt**3/(3*p1q2**2)+
43811 &128*a1*mt**4/(3*p1q2**2)+256*a12*mb*mt**5/(3*p1q2**2)+
43812 &256*a1*mt**2*p1p2/(3*p1q2**2)-256*a12*mt**4*p1p2/(3*p1q2**2)+
43813 &256*a1*mt**2*p1q1/(3*p1q2**2)-256*a12*mb*mt**3*p1q1/(3*p1q2**2)+
43814 &8/(3*p1q2)+32*a1*mb*mt/p1q2+56*a2*mb*mt/(3*p1q2)
43815 a18=a18+88*a1*mt**2/(3*p1q2)+72*a2*mt**2/p1q2-
43816 &704*a12*mb*mt**3/(3*p1q2)+224*a1*a2*mb*mt**3/(3*p1q2)+
43817 &104*a1*p1p2/(3*p1q2)+48*a2*p1p2/p1q2-
43818 &128*a1*a2*mb*mt*p1p2/(3*p1q2)+512*a12*mt**2*p1p2/(3*p1q2)-
43819 &448*a1*a2*mt**2*p1p2/(3*p1q2)-32*a1*a2*p1p2**2/p1q2+
43820 &32*a1*mb*mt**3/(3*p1q1*p1q2)-32*a1*mt**4/(3*p1q1*p1q2)-
43821 &64*a12*mb*mt**5/(3*p1q1*p1q2)+16*p1p2/(3*p1q1*p1q2)-
43822 &64*a1*mt**2*p1p2/(3*p1q1*p1q2)+64*a12*mt**4*p1p2/(3*p1q1*p1q2)+
43823 &112*a1*p1q1/p1q2+272*a2*p1q1/(3*p1q2)-
43824 &272*a1*a2*mb**2*p1q1/(3*p1q2)-208*a12*mb*mt*p1q1/(3*p1q2)+
43825 &400*a1*a2*mb*mt*p1q1/(3*p1q2)-80*a1*a2*mt**2*p1q1/p1q2+
43826 &96*a12*p1p2*p1q1/p1q2-320*a1*a2*p1p2*p1q1/p1q2-
43827 &544*a1*a2*p1q1**2/(3*p1q2)-656*a1*a2*p1q2/3-224*a2**2*p1q2+
43828 &256*a1*mt**2*p1q2/(3*p1q1**2)-256*a12*mb*mt**3*p1q2/(3*p1q1**2)+
43829 &112*a1*p1q2/p1q1+272*a2*p1q2/(3*p1q1)-
43830 &272*a1*a2*mb**2*p1q2/(3*p1q1)-208*a12*mb*mt*p1q2/(3*p1q1)+
43831 &400*a1*a2*mb*mt*p1q2/(3*p1q1)-80*a1*a2*mt**2*p1q2/p1q1
43832 a18=a18+96*a12*p1p2*p1q2/p1q1-320*a1*a2*p1p2*p1q2/p1q1-
43833 &544*a1*a2*p1q2**2/(3*p1q1)+128*a2*mb**4/(3*p2q1**2)-
43834 &128*a2*mb**3*mt/(3*p2q1**2)+256*a2**2*mb**5*mt/(3*p2q1**2)+
43835 &256*a2*mb**2*p1p2/(3*p2q1**2)-256*a2**2*mb**4*p1p2/(3*p2q1**2)+
43836 &256*a2*mb**2*p1q1/(3*p2q1**2)-256*a2**2*mb**4*p1q1/(3*p2q1**2)+
43837 &64*mb**3*mt**3/(3*p1q2**2*p2q1**2)-
43838 &64*mb**2*mt**2*p1p2/(3*p1q2**2*p2q1**2)-
43839 &64*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1**2)-
43840 &64*mb**3*mt/(3*p1q2*p2q1**2)-
43841 &256*a2*mb**3*mt*p1p2/(3*p1q2*p2q1**2)+
43842 &256*a2*mb**2*p1p2**2/(3*p1q2*p2q1**2)-
43843 &256*a2*mb**3*mt*p1q1/(3*p1q2*p2q1**2)+
43844 &512*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1**2)+
43845 &256*a2*mb**2*p1q1**2/(3*p1q2*p2q1**2)-
43846 &256*a2**2*mb**4*p1q2/(3*p2q1**2)-8/(3*p2q1)-72*a1*mb**2/p2q1-
43847 &88*a2*mb**2/(3*p2q1)-56*a1*mb*mt/(3*p2q1)-32*a2*mb*mt/p2q1-
43848 &224*a1*a2*mb**3*mt/(3*p2q1)+704*a2**2*mb**3*mt/(3*p2q1)
43849 a18=a18-48*a1*p1p2/p2q1-104*a2*p1p2/(3*p2q1)+
43850 &448*a1*a2*mb**2*p1p2/(3*p2q1)-512*a2**2*mb**2*p1p2/(3*p2q1)+
43851 &128*a1*a2*mb*mt*p1p2/(3*p2q1)+32*a1*a2*p1p2**2/p2q1-
43852 &16*p1p2/(3*p1q1*p2q1)+32*a1*mb*mt*p1p2/(3*p1q1*p2q1)+
43853 &32*a2*mb*mt*p1p2/(3*p1q1*p2q1)+
43854 &64*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q1)-
43855 &64*a1*a2*p1p2**3/(3*p1q1*p2q1)-256*a2*p1q1/(3*p2q1)+
43856 &448*a1*a2*mb**2*p1q1/(3*p2q1)-368*a2**2*mb**2*p1q1/(3*p2q1)-
43857 &224*a1*a2*mb*mt*p1q1/(3*p2q1)+304*a1*a2*p1p2*p1q1/(3*p2q1)+
43858 &64*mb*mt**3/(3*p1q2**2*p2q1)+
43859 &256*a1*mb*mt**3*p1p2/(3*p1q2**2*p2q1)-
43860 &256*a1*mt**2*p1p2**2/(3*p1q2**2*p2q1)+
43861 &64*mt**2*p1q1/(3*p1q2**2*p2q1)-
43862 &128*a1*mb**2*mt**2*p1q1/(3*p1q2**2*p2q1)+
43863 &128*a1*mb*mt**3*p1q1/(3*p1q2**2*p2q1)-
43864 &256*a1*mt**2*p1p2*p1q1/(3*p1q2**2*p2q1)-4*mb**2/(3*p1q2*p2q1)-
43865 &64*mb*mt/(3*p1q2*p2q1)+128*a2*mb**3*mt/(3*p1q2*p2q1)
43866 a18=a18-4*mt**2/(3*p1q2*p2q1)-128*a1*mb**2*mt**2/(3*p1q2*p2q1)-
43867 &128*a2*mb**2*mt**2/(3*p1q2*p2q1)+128*a1*mb*mt**3/(3*p1q2*p2q1)-
43868 &112*a2*mb**2*p1p2/(3*p1q2*p2q1)+32*a1*mb*mt*p1p2/(3*p1q2*p2q1)+
43869 &32*a2*mb*mt*p1p2/(3*p1q2*p2q1)-112*a1*mt**2*p1p2/(3*p1q2*p2q1)-
43870 &48*a1*p1p2**2/(p1q2*p2q1)-48*a2*p1p2**2/(p1q2*p2q1)-
43871 &512*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q1)+
43872 &512*a1*a2*p1p2**3/(3*p1q2*p2q1)+8*mb*mt*p1p2/(3*p1q1*p1q2*p2q1)-
43873 &8*mt**2*p1p2/(3*p1q1*p1q2*p2q1)-
43874 &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q1)-
43875 &16*p1p2**2/(3*p1q1*p1q2*p2q1)+
43876 &32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q1)+8*p1q1/(3*p1q2*p2q1)-
43877 &160*a1*mb**2*p1q1/(3*p1q2*p2q1)-272*a2*mb**2*p1q1/(3*p1q2*p2q1)-
43878 &56*a1*mb*mt*p1q1/(3*p1q2*p2q1)-200*a2*mb*mt*p1q1/(3*p1q2*p2q1)-
43879 &48*a1*p1p2*p1q1/(p1q2*p2q1)-256*a2*p1p2*p1q1/(3*p1q2*p2q1)+
43880 &256*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1)-
43881 &256*a1*a2*mb*mt*p1p2*p1q1/(p1q2*p2q1)+
43882 &1024*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q1)
43883 a18=a18-272*a2*p1q1**2/(3*p1q2*p2q1)+
43884 &256*a1*a2*mb**2*p1q1**2/(3*p1q2*p2q1)-
43885 &256*a1*a2*mb*mt*p1q1**2/(3*p1q2*p2q1)+
43886 &512*a1*a2*p1p2*p1q1**2/(3*p1q2*p2q1)+16*a2*p1q2/(3*p2q1)+
43887 &64*a1*a2*mb**2*p1q2/p2q1+32*a2**2*mb**2*p1q2/(3*p2q1)-
43888 &112*a1*a2*mb*mt*p1q2/(3*p2q1)+368*a1*a2*p1p2*p1q2/(3*p2q1)+
43889 &32*a2*p1p2*p1q2/(3*p1q1*p2q1)-
43890 &32*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1)+
43891 &32*a1*a2*mb*mt*p1p2*p1q2/(3*p1q1*p2q1)-
43892 &64*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q1)+224*a12*p2q1+
43893 &656*a1*a2*p2q1/3-256*a1*mt**2*p2q1/(3*p1q1**2)+
43894 &256*a12*mt**4*p2q1/(3*p1q1**2)-256*a1*p2q1/(3*p1q1)-
43895 &224*a1*a2*mb*mt*p2q1/(3*p1q1)-368*a12*mt**2*p2q1/(3*p1q1)+
43896 &448*a1*a2*mt**2*p2q1/(3*p1q1)+304*a1*a2*p1p2*p2q1/(3*p1q1)+
43897 &256*a12*mt**4*p2q1/(3*p1q2**2)+
43898 &256*a12*mt**2*p1q1*p2q1/(3*p1q2**2)+16*a1*p2q1/(3*p1q2)-
43899 &112*a1*a2*mb*mt*p2q1/(3*p1q2)+32*a12*mt**2*p2q1/(3*p1q2)
43900 a18=a18+64*a1*a2*mt**2*p2q1/p1q2+368*a1*a2*p1p2*p2q1/(3*p1q2)+
43901 &16*a1*mt**2*p2q1/(3*p1q1*p1q2)-64*a12*mt**4*p2q1/(3*p1q1*p1q2)+
43902 &640*a12*p1q1*p2q1/(3*p1q2)+544*a1*a2*p1q1*p2q1/(3*p1q2)+
43903 &32*a12*p1q2*p2q1/p1q1+944*a1*a2*p1q2*p2q1/(3*p1q1)+
43904 &128*a2*mb**4/(3*p2q2**2)-128*a2*mb**3*mt/(3*p2q2**2)+
43905 &256*a2**2*mb**5*mt/(3*p2q2**2)+256*a2*mb**2*p1p2/(3*p2q2**2)-
43906 &256*a2**2*mb**4*p1p2/(3*p2q2**2)+
43907 &64*mb**3*mt**3/(3*p1q1**2*p2q2**2)-
43908 &64*mb**2*mt**2*p1p2/(3*p1q1**2*p2q2**2)-
43909 &64*mb**3*mt/(3*p1q1*p2q2**2)-
43910 &256*a2*mb**3*mt*p1p2/(3*p1q1*p2q2**2)+
43911 &256*a2*mb**2*p1p2**2/(3*p1q1*p2q2**2)-
43912 &256*a2**2*mb**4*p1q1/(3*p2q2**2)+256*a2*mb**2*p1q2/(3*p2q2**2)-
43913 &256*a2**2*mb**4*p1q2/(3*p2q2**2)-
43914 &64*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2**2)-
43915 &256*a2*mb**3*mt*p1q2/(3*p1q1*p2q2**2)+
43916 &512*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2**2)
43917 a18=a18+256*a2*mb**2*p1q2**2/(3*p1q1*p2q2**2)-
43918 &256*a2*mb**2*p2q1/(3*p2q2**2)+256*a2**2*mb**3*mt*p2q1/(3*p2q2**2)+
43919 &64*mb**2*mt**2*p2q1/(3*p1q1**2*p2q2**2)+
43920 &64*mb**2*p2q1/(3*p1q1*p2q2**2)+
43921 &128*a2*mb**3*mt*p2q1/(3*p1q1*p2q2**2)-
43922 &128*a2*mb**2*mt**2*p2q1/(3*p1q1*p2q2**2)-
43923 &256*a2*mb**2*p1p2*p2q1/(3*p1q1*p2q2**2)+
43924 &256*a2**2*mb**2*p1q1*p2q1/(3*p2q2**2)-
43925 &256*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2**2)-8/(3*p2q2)-
43926 &72*a1*mb**2/p2q2-88*a2*mb**2/(3*p2q2)-56*a1*mb*mt/(3*p2q2)-
43927 &32*a2*mb*mt/p2q2-224*a1*a2*mb**3*mt/(3*p2q2)+
43928 &704*a2**2*mb**3*mt/(3*p2q2)-48*a1*p1p2/p2q2-
43929 &104*a2*p1p2/(3*p2q2)+448*a1*a2*mb**2*p1p2/(3*p2q2)-
43930 &512*a2**2*mb**2*p1p2/(3*p2q2)+128*a1*a2*mb*mt*p1p2/(3*p2q2)+
43931 &32*a1*a2*p1p2**2/p2q2+64*mb*mt**3/(3*p1q1**2*p2q2)+
43932 &256*a1*mb*mt**3*p1p2/(3*p1q1**2*p2q2)-
43933 &256*a1*mt**2*p1p2**2/(3*p1q1**2*p2q2)-4*mb**2/(3*p1q1*p2q2)
43934 a18=a18-64*mb*mt/(3*p1q1*p2q2)+128*a2*mb**3*mt/(3*p1q1*p2q2)-
43935 &4*mt**2/(3*p1q1*p2q2)-128*a1*mb**2*mt**2/(3*p1q1*p2q2)-
43936 &128*a2*mb**2*mt**2/(3*p1q1*p2q2)+128*a1*mb*mt**3/(3*p1q1*p2q2)-
43937 &112*a2*mb**2*p1p2/(3*p1q1*p2q2)+32*a1*mb*mt*p1p2/(3*p1q1*p2q2)+
43938 &32*a2*mb*mt*p1p2/(3*p1q1*p2q2)-112*a1*mt**2*p1p2/(3*p1q1*p2q2)-
43939 &48*a1*p1p2**2/(p1q1*p2q2)-48*a2*p1p2**2/(p1q1*p2q2)-
43940 &512*a1*a2*mb*mt*p1p2**2/(3*p1q1*p2q2)+
43941 &512*a1*a2*p1p2**3/(3*p1q1*p2q2)+16*a2*p1q1/(3*p2q2)+
43942 &64*a1*a2*mb**2*p1q1/p2q2+32*a2**2*mb**2*p1q1/(3*p2q2)-
43943 &112*a1*a2*mb*mt*p1q1/(3*p2q2)+368*a1*a2*p1p2*p1q1/(3*p2q2)-
43944 &16*p1p2/(3*p1q2*p2q2)+32*a1*mb*mt*p1p2/(3*p1q2*p2q2)+
43945 &32*a2*mb*mt*p1p2/(3*p1q2*p2q2)+
43946 &64*a1*a2*mb*mt*p1p2**2/(3*p1q2*p2q2)-
43947 &64*a1*a2*p1p2**3/(3*p1q2*p2q2)+8*mb*mt*p1p2/(3*p1q1*p1q2*p2q2)-
43948 &8*mt**2*p1p2/(3*p1q1*p1q2*p2q2)-
43949 &32*a1*mb*mt**3*p1p2/(3*p1q1*p1q2*p2q2)-
43950 &16*p1p2**2/(3*p1q1*p1q2*p2q2)
43951 a18=a18+32*a1*mt**2*p1p2**2/(3*p1q1*p1q2*p2q2)+
43952 &32*a2*p1p2*p1q1/(3*p1q2*p2q2)-
43953 &32*a1*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q2)+
43954 &32*a1*a2*mb*mt*p1p2*p1q1/(3*p1q2*p2q2)-
43955 &64*a1*a2*p1p2**2*p1q1/(3*p1q2*p2q2)-256*a2*p1q2/(3*p2q2)+
43956 &448*a1*a2*mb**2*p1q2/(3*p2q2)-368*a2**2*mb**2*p1q2/(3*p2q2)-
43957 &224*a1*a2*mb*mt*p1q2/(3*p2q2)+304*a1*a2*p1p2*p1q2/(3*p2q2)+
43958 &64*mt**2*p1q2/(3*p1q1**2*p2q2)-
43959 &128*a1*mb**2*mt**2*p1q2/(3*p1q1**2*p2q2)+
43960 &128*a1*mb*mt**3*p1q2/(3*p1q1**2*p2q2)-
43961 &256*a1*mt**2*p1p2*p1q2/(3*p1q1**2*p2q2)+8*p1q2/(3*p1q1*p2q2)-
43962 &160*a1*mb**2*p1q2/(3*p1q1*p2q2)-272*a2*mb**2*p1q2/(3*p1q1*p2q2)-
43963 &56*a1*mb*mt*p1q2/(3*p1q1*p2q2)-200*a2*mb*mt*p1q2/(3*p1q1*p2q2)-
43964 &48*a1*p1p2*p1q2/(p1q1*p2q2)-256*a2*p1p2*p1q2/(3*p1q1*p2q2)+
43965 &256*a1*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q2)-
43966 &256*a1*a2*mb*mt*p1p2*p1q2/(p1q1*p2q2)+
43967 &1024*a1*a2*p1p2**2*p1q2/(3*p1q1*p2q2)
43968 a18=a18-272*a2*p1q2**2/(3*p1q1*p2q2)+
43969 &256*a1*a2*mb**2*p1q2**2/(3*p1q1*p2q2)-
43970 &256*a1*a2*mb*mt*p1q2**2/(3*p1q1*p2q2)+
43971 &512*a1*a2*p1p2*p1q2**2/(3*p1q1*p2q2)-32*a2*mb**4/(3*p2q1*p2q2)+
43972 &32*a2*mb**3*mt/(3*p2q1*p2q2)-64*a2**2*mb**5*mt/(3*p2q1*p2q2)+
43973 &16*p1p2/(3*p2q1*p2q2)-64*a2*mb**2*p1p2/(3*p2q1*p2q2)+
43974 &64*a2**2*mb**4*p1p2/(3*p2q1*p2q2)+8*mb**2*p1p2/(3*p1q1*p2q1*p2q2)-
43975 &8*mb*mt*p1p2/(3*p1q1*p2q1*p2q2)+
43976 &32*a2*mb**3*mt*p1p2/(3*p1q1*p2q1*p2q2)+
43977 &16*p1p2**2/(3*p1q1*p2q1*p2q2)-
43978 &32*a2*mb**2*p1p2**2/(3*p1q1*p2q1*p2q2)-
43979 &16*a2*mb**2*p1q1/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q1/(3*p2q1*p2q2)+
43980 &8*mb**2*p1p2/(3*p1q2*p2q1*p2q2)-8*mb*mt*p1p2/(3*p1q2*p2q1*p2q2)+
43981 &32*a2*mb**3*mt*p1p2/(3*p1q2*p2q1*p2q2)+
43982 &16*p1p2**2/(3*p1q2*p2q1*p2q2)-
43983 &32*a2*mb**2*p1p2**2/(3*p1q2*p2q1*p2q2)-
43984 &16*mb*mt*p1p2**2/(3*p1q1*p1q2*p2q1*p2q2)
43985 a18=a18+16*p1p2**3/(3*p1q1*p1q2*p2q1*p2q2)-
43986 &32*a2*mb**2*p1p2*p1q1/(3*p1q2*p2q1*p2q2)-
43987 &16*a2*mb**2*p1q2/(3*p2q1*p2q2)+64*a2**2*mb**4*p1q2/(3*p2q1*p2q2)-
43988 &32*a2*mb**2*p1p2*p1q2/(3*p1q1*p2q1*p2q2)+272*a1*p2q1/(3*p2q2)+
43989 &112*a2*p2q1/p2q2-80*a1*a2*mb**2*p2q1/p2q2+
43990 &400*a1*a2*mb*mt*p2q1/(3*p2q2)-208*a2**2*mb*mt*p2q1/(3*p2q2)-
43991 &272*a1*a2*mt**2*p2q1/(3*p2q2)-320*a1*a2*p1p2*p2q1/p2q2+
43992 &96*a2**2*p1p2*p2q1/p2q2-256*a1*mb*mt**3*p2q1/(3*p1q1**2*p2q2)+
43993 &512*a1*mt**2*p1p2*p2q1/(3*p1q1**2*p2q2)-8*p2q1/(3*p1q1*p2q2)+
43994 &200*a1*mb*mt*p2q1/(3*p1q1*p2q2)+56*a2*mb*mt*p2q1/(3*p1q1*p2q2)+
43995 &272*a1*mt**2*p2q1/(3*p1q1*p2q2)+160*a2*mt**2*p2q1/(3*p1q1*p2q2)+
43996 &256*a1*p1p2*p2q1/(3*p1q1*p2q2)+48*a2*p1p2*p2q1/(p1q1*p2q2)+
43997 &256*a1*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2)-
43998 &256*a1*a2*mt**2*p1p2*p2q1/(3*p1q1*p2q2)-
43999 &1024*a1*a2*p1p2**2*p2q1/(3*p1q1*p2q2)-
44000 &544*a1*a2*p1q1*p2q1/(3*p2q2)-640*a2**2*p1q1*p2q1/(3*p2q2)-
44001 &32*a1*p1p2*p2q1/(3*p1q2*p2q2)
44002 a18=a18-32*a1*a2*mb*mt*p1p2*p2q1/(3*p1q2*p2q2)+
44003 &32*a1*a2*mt**2*p1p2*p2q1/(3*p1q2*p2q2)+
44004 &64*a1*a2*p1p2**2*p2q1/(3*p1q2*p2q2)-
44005 &32*a1*mt**2*p1p2*p2q1/(3*p1q1*p1q2*p2q2)+
44006 &64*a1*a2*p1p2*p1q1*p2q1/(3*p1q2*p2q2)-
44007 &944*a1*a2*p1q2*p2q1/(3*p2q2)-32*a2**2*p1q2*p2q1/p2q2+
44008 &256*a1*mt**2*p1q2*p2q1/(3*p1q1**2*p2q2)+
44009 &96*a1*p1q2*p2q1/(p1q1*p2q2)+96*a2*p1q2*p2q1/(p1q1*p2q2)-
44010 &128*a1*a2*mb**2*p1q2*p2q1/(3*p1q1*p2q2)+
44011 &256*a1*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2)-
44012 &128*a1*a2*mt**2*p1q2*p2q1/(3*p1q1*p2q2)-
44013 &512*a1*a2*p1p2*p1q2*p2q1/(p1q1*p2q2)-
44014 &512*a1*a2*p1q2**2*p2q1/(3*p1q1*p2q2)+544*a1*a2*p2q1**2/(3*p2q2)-
44015 &256*a1*mt**2*p2q1**2/(3*p1q1**2*p2q2)-
44016 &272*a1*p2q1**2/(3*p1q1*p2q2)-
44017 &256*a1*a2*mb*mt*p2q1**2/(3*p1q1*p2q2)+
44018 &256*a1*a2*mt**2*p2q1**2/(3*p1q1*p2q2)
44019 a18=a18+512*a1*a2*p1p2*p2q1**2/(3*p1q1*p2q2)+
44020 &512*a1*a2*p1q2*p2q1**2/(3*p1q1*p2q2)+224*a12*p2q2+
44021 &656*a1*a2*p2q2/3+256*a12*mt**4*p2q2/(3*p1q1**2)+
44022 &16*a1*p2q2/(3*p1q1)-112*a1*a2*mb*mt*p2q2/(3*p1q1)+
44023 &32*a12*mt**2*p2q2/(3*p1q1)+64*a1*a2*mt**2*p2q2/p1q1+
44024 &368*a1*a2*p1p2*p2q2/(3*p1q1)-256*a1*mt**2*p2q2/(3*p1q2**2)+
44025 &256*a12*mt**4*p2q2/(3*p1q2**2)-256*a1*p2q2/(3*p1q2)-
44026 &224*a1*a2*mb*mt*p2q2/(3*p1q2)-368*a12*mt**2*p2q2/(3*p1q2)+
44027 &448*a1*a2*mt**2*p2q2/(3*p1q2)+304*a1*a2*p1p2*p2q2/(3*p1q2)+
44028 &16*a1*mt**2*p2q2/(3*p1q1*p1q2)-64*a12*mt**4*p2q2/(3*p1q1*p1q2)+
44029 &32*a12*p1q1*p2q2/p1q2+944*a1*a2*p1q1*p2q2/(3*p1q2)+
44030 &256*a12*mt**2*p1q2*p2q2/(3*p1q1**2)+
44031 &640*a12*p1q2*p2q2/(3*p1q1)+544*a1*a2*p1q2*p2q2/(3*p1q1)-
44032 &256*a2*mb**2*p2q2/(3*p2q1**2)+256*a2**2*mb**3*mt*p2q2/(3*p2q1**2)+
44033 &64*mb**2*mt**2*p2q2/(3*p1q2**2*p2q1**2)+
44034 &64*mb**2*p2q2/(3*p1q2*p2q1**2)+
44035 &128*a2*mb**3*mt*p2q2/(3*p1q2*p2q1**2)
44036 a18=a18-128*a2*mb**2*mt**2*p2q2/(3*p1q2*p2q1**2)-
44037 &256*a2*mb**2*p1p2*p2q2/(3*p1q2*p2q1**2)-
44038 &256*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1**2)+
44039 &256*a2**2*mb**2*p1q2*p2q2/(3*p2q1**2)+272*a1*p2q2/(3*p2q1)+
44040 &112*a2*p2q2/p2q1-80*a1*a2*mb**2*p2q2/p2q1+
44041 &400*a1*a2*mb*mt*p2q2/(3*p2q1)-208*a2**2*mb*mt*p2q2/(3*p2q1)-
44042 &272*a1*a2*mt**2*p2q2/(3*p2q1)-320*a1*a2*p1p2*p2q2/p2q1+
44043 &96*a2**2*p1p2*p2q2/p2q1-32*a1*p1p2*p2q2/(3*p1q1*p2q1)-
44044 &32*a1*a2*mb*mt*p1p2*p2q2/(3*p1q1*p2q1)+
44045 &32*a1*a2*mt**2*p1p2*p2q2/(3*p1q1*p2q1)+
44046 &64*a1*a2*p1p2**2*p2q2/(3*p1q1*p2q1)-944*a1*a2*p1q1*p2q2/(3*p2q1)-
44047 &32*a2**2*p1q1*p2q2/p2q1-256*a1*mb*mt**3*p2q2/(3*p1q2**2*p2q1)+
44048 &512*a1*mt**2*p1p2*p2q2/(3*p1q2**2*p2q1)+
44049 &256*a1*mt**2*p1q1*p2q2/(3*p1q2**2*p2q1)-8*p2q2/(3*p1q2*p2q1)+
44050 &200*a1*mb*mt*p2q2/(3*p1q2*p2q1)+56*a2*mb*mt*p2q2/(3*p1q2*p2q1)+
44051 &272*a1*mt**2*p2q2/(3*p1q2*p2q1)+160*a2*mt**2*p2q2/(3*p1q2*p2q1)+
44052 &256*a1*p1p2*p2q2/(3*p1q2*p2q1)+48*a2*p1p2*p2q2/(p1q2*p2q1)
44053 a18=a18+256*a1*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1)-
44054 &256*a1*a2*mt**2*p1p2*p2q2/(3*p1q2*p2q1)-
44055 &1024*a1*a2*p1p2**2*p2q2/(3*p1q2*p2q1)-
44056 &32*a1*mt**2*p1p2*p2q2/(3*p1q1*p1q2*p2q1)+
44057 &96*a1*p1q1*p2q2/(p1q2*p2q1)+96*a2*p1q1*p2q2/(p1q2*p2q1)-
44058 &128*a1*a2*mb**2*p1q1*p2q2/(3*p1q2*p2q1)+
44059 &256*a1*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1)-
44060 &128*a1*a2*mt**2*p1q1*p2q2/(3*p1q2*p2q1)-
44061 &512*a1*a2*p1p2*p1q1*p2q2/(p1q2*p2q1)-
44062 &512*a1*a2*p1q1**2*p2q2/(3*p1q2*p2q1)-544*a1*a2*p1q2*p2q2/(3*p2q1)-
44063 &640*a2**2*p1q2*p2q2/(3*p2q1)+
44064 &64*a1*a2*p1p2*p1q2*p2q2/(3*p1q1*p2q1)+544*a1*a2*p2q2**2/(3*p2q1)-
44065 &256*a1*mt**2*p2q2**2/(3*p1q2**2*p2q1)-
44066 &272*a1*p2q2**2/(3*p1q2*p2q1)-
44067 &256*a1*a2*mb*mt*p2q2**2/(3*p1q2*p2q1)+
44068 &256*a1*a2*mt**2*p2q2**2/(3*p1q2*p2q1)+
44069 &512*a1*a2*p1p2*p2q2**2/(3*p1q2*p2q1)
44070 a18=a18+512*a1*a2*p1q1*p2q2**2/(3*p1q2*p2q1)-
44071 &384*a12*mb*mt*p1q1**2/s**2+
44072 &384*a12*p1p2*p1q1**2/s**2-2688*a12*mb*mt*p1q1*p1q2/s**2+
44073 &2688*a12*p1p2*p1q1*p1q2/s**2-384*a12*mb*mt*p1q2**2/s**2+
44074 &384*a12*p1p2*p1q2**2/s**2-768*a1*a2*mb*mt*p1q1*p2q1/s**2+
44075 &768*a1*a2*p1p2*p1q1*p2q1/s**2-2688*a1*a2*mb*mt*p1q2*p2q1/s**2+
44076 &2688*a1*a2*p1p2*p1q2*p2q1/s**2-960*a12*p1q1*p1q2*p2q1/s**2-
44077 &960*a1*a2*p1q1*p1q2*p2q1/s**2+960*a12*p1q2**2*p2q1/s**2+
44078 &960*a1*a2*p1q2**2*p2q1/s**2-384*a2**2*mb*mt*p2q1**2/s**2+
44079 &384*a2**2*p1p2*p2q1**2/s**2-960*a1*a2*p1q2*p2q1**2/s**2-
44080 &960*a2**2*p1q2*p2q1**2/s**2-2688*a1*a2*mb*mt*p1q1*p2q2/s**2+
44081 &2688*a1*a2*p1p2*p1q1*p2q2/s**2+960*a12*p1q1**2*p2q2/s**2+
44082 &960*a1*a2*p1q1**2*p2q2/s**2-768*a1*a2*mb*mt*p1q2*p2q2/s**2+
44083 &768*a1*a2*p1p2*p1q2*p2q2/s**2-960*a12*p1q1*p1q2*p2q2/s**2-
44084 &960*a1*a2*p1q1*p1q2*p2q2/s**2-2688*a2**2*mb*mt*p2q1*p2q2/s**2+
44085 &2688*a2**2*p1p2*p2q1*p2q2/s**2+960*a1*a2*p1q1*p2q1*p2q2/s**2+
44086 &960*a2**2*p1q1*p2q1*p2q2/s**2+960*a1*a2*p1q2*p2q1*p2q2/s**2
44087 a18=a18+960*a2**2*p1q2*p2q1*p2q2/s**2-
44088 &384*a2**2*mb*mt*p2q2**2/s**2+
44089 &384*a2**2*p1p2*p2q2**2/s**2-960*a1*a2*p1q1*p2q2**2/s**2-
44090 &960*a2**2*p1q1*p2q2**2/s**2-96*a1*mb*mt/s-96*a2*mb*mt/s+
44091 &768*a2**2*mb**3*mt/s+768*a12*mb*mt**3/s-192*a1*p1p2/s-
44092 &192*a2*p1p2/s-768*a2**2*mb**2*p1p2/s+2304*a1*a2*mb*mt*p1p2/s-
44093 &768*a12*mt**2*p1p2/s-2304*a1*a2*p1p2**2/s+
44094 &96*a1*mb*mt**3/(p1q1*s)+192*a2*mb*mt*p1p2/(p1q1*s)-
44095 &96*a1*mt**2*p1p2/(p1q1*s)-192*a2*p1p2**2/(p1q1*s)-192*a1*p1q1/s-
44096 &144*a2*p1q1/s-384*a1*a2*mb**2*p1q1/s-480*a2**2*mb**2*p1q1/s+
44097 &480*a12*mb*mt*p1q1/s-96*a1*a2*mb*mt*p1q1/s-
44098 &864*a12*p1p2*p1q1/s-672*a1*a2*p1p2*p1q1/s-96*a1*a2*p1q1**2/s+
44099 &96*a1*mb*mt**3/(p1q2*s)+192*a2*mb*mt*p1p2/(p1q2*s)-
44100 &96*a1*mt**2*p1p2/(p1q2*s)-192*a2*p1p2**2/(p1q2*s)+
44101 &48*a1*mb*mt*p1q1/(p1q2*s)-96*a2*mb*mt*p1q1/(p1q2*s)-
44102 &48*a1*mt**2*p1q1/(p1q2*s)-192*a1*p1p2*p1q1/(p1q2*s)-
44103 &192*a2*p1p2*p1q1/(p1q2*s)-192*a1*a2*mb*mt*p1p2*p1q1/(p1q2*s)
44104 a18=a18+192*a1*a2*p1p2**2*p1q1/(p1q2*s)-192*a1*p1q1**2/(p1q2*s)-
44105 &192*a2*p1q1**2/(p1q2*s)+192*a1*a2*mb**2*p1q1**2/(p1q2*s)+
44106 &192*a12*mb*mt*p1q1**2/(p1q2*s)-96*a1*a2*mb*mt*p1q1**2/(p1q2*s)+
44107 &192*a1*a2*p1p2*p1q1**2/(p1q2*s)-192*a1*p1q2/s-144*a2*p1q2/s-
44108 &384*a1*a2*mb**2*p1q2/s-480*a2**2*mb**2*p1q2/s+
44109 &480*a12*mb*mt*p1q2/s-96*a1*a2*mb*mt*p1q2/s-
44110 &864*a12*p1p2*p1q2/s-672*a1*a2*p1p2*p1q2/s+
44111 &48*a1*mb*mt*p1q2/(p1q1*s)-96*a2*mb*mt*p1q2/(p1q1*s)-
44112 &48*a1*mt**2*p1q2/(p1q1*s)-192*a1*p1p2*p1q2/(p1q1*s)-
44113 &192*a2*p1p2*p1q2/(p1q1*s)-192*a1*a2*mb*mt*p1p2*p1q2/(p1q1*s)+
44114 &192*a1*a2*p1p2**2*p1q2/(p1q1*s)-576*a1*a2*p1q1*p1q2/s-
44115 &96*a1*a2*p1q2**2/s-192*a1*p1q2**2/(p1q1*s)-
44116 &192*a2*p1q2**2/(p1q1*s)+192*a1*a2*mb**2*p1q2**2/(p1q1*s)+
44117 &192*a12*mb*mt*p1q2**2/(p1q1*s)-96*a1*a2*mb*mt*p1q2**2/(p1q1*s)+
44118 &192*a1*a2*p1p2*p1q2**2/(p1q1*s)-96*a2*mb**3*mt/(p2q1*s)+
44119 &96*a2*mb**2*p1p2/(p2q1*s)-192*a1*mb*mt*p1p2/(p2q1*s)+
44120 &192*a1*p1p2**2/(p2q1*s)+96*a1*mb**2*p1q1/(p2q1*s)
44121 a18=a18+192*a2*mb**2*p1q1/(p2q1*s)-96*a1*mb*mt*p1q1/(p2q1*s)-
44122 &192*a1*a2*mb**3*mt*p1q1/(p2q1*s)+192*a1*p1p2*p1q1/(p2q1*s)+
44123 &192*a1*a2*mb**2*p1p2*p1q1/(p2q1*s)+
44124 &96*a1*a2*mb**2*p1q1**2/(p2q1*s)-
44125 &192*a2*mb**3*mt*p1q1/(p1q2*p2q1*s)+
44126 &192*a2*mb**2*p1p2*p1q1/(p1q2*p2q1*s)-
44127 &96*a1*mb*mt*p1p2*p1q1/(p1q2*p2q1*s)+
44128 &96*a1*p1p2**2*p1q1/(p1q2*p2q1*s)+
44129 &96*a1*mb**2*p1q1**2/(p1q2*p2q1*s)+
44130 &192*a2*mb**2*p1q1**2/(p1q2*p2q1*s)-
44131 &48*a1*mb*mt*p1q1**2/(p1q2*p2q1*s)+
44132 &96*a1*p1p2*p1q1**2/(p1q2*p2q1*s)+96*a1*mb**2*p1q2/(p2q1*s)+
44133 &48*a2*mb**2*p1q2/(p2q1*s)+192*a1*a2*mb**3*mt*p1q2/(p2q1*s)-
44134 &192*a1*a2*mb**2*p1p2*p1q2/(p2q1*s)-
44135 &96*a1*a2*mb**2*p1q2**2/(p2q1*s)+144*a1*p2q1/s+192*a2*p2q1/s+
44136 &96*a1*a2*mb*mt*p2q1/s-480*a2**2*mb*mt*p2q1/s+
44137 &480*a12*mt**2*p2q1/s+384*a1*a2*mt**2*p2q1/s
44138 a18=a18+672*a1*a2*p1p2*p2q1/s+864*a2**2*p1p2*p2q1/s-
44139 &96*a2*mb*mt*p2q1/(p1q1*s)+192*a1*mt**2*p2q1/(p1q1*s)+
44140 &96*a2*mt**2*p2q1/(p1q1*s)-192*a1*a2*mb*mt**3*p2q1/(p1q1*s)+
44141 &192*a2*p1p2*p2q1/(p1q1*s)+192*a1*a2*mt**2*p1p2*p2q1/(p1q1*s)-
44142 &192*a12*p1q1*p2q1/s-192*a2**2*p1q1*p2q1/s+
44143 &48*a1*mt**2*p2q1/(p1q2*s)+96*a2*mt**2*p2q1/(p1q2*s)+
44144 &192*a1*a2*mb*mt**3*p2q1/(p1q2*s)-
44145 &192*a1*a2*mt**2*p1p2*p2q1/(p1q2*s)+
44146 &96*a1*a2*mb*mt*p1q1*p2q1/(p1q2*s)-
44147 &192*a12*mt**2*p1q1*p2q1/(p1q2*s)-
44148 &96*a1*a2*mt**2*p1q1*p2q1/(p1q2*s)-
44149 &384*a1*a2*p1p2*p1q1*p2q1/(p1q2*s)-384*a12*p1q1**2*p2q1/(p1q2*s)-
44150 &384*a1*a2*p1q1**2*p2q1/(p1q2*s)-480*a12*p1q2*p2q1/s-
44151 &960*a1*a2*p1q2*p2q1/s-480*a2**2*p1q2*p2q1/s+
44152 &144*a1*p1q2*p2q1/(p1q1*s)+96*a2*p1q2*p2q1/(p1q1*s)+
44153 &384*a1*a2*mb*mt*p1q2*p2q1/(p1q1*s)-
44154 &96*a12*mt**2*p1q2*p2q1/(p1q1*s)
44155 a18=a18+96*a1*a2*mt**2*p1q2*p2q1/(p1q1*s)-
44156 &576*a1*a2*p1p2*p1q2*p2q1/(p1q1*s)-192*a12*p1q2**2*p2q1/(p1q1*s)-
44157 &384*a1*a2*p1q2**2*p2q1/(p1q1*s)-96*a1*a2*p2q1**2/s-
44158 &96*a1*a2*mt**2*p2q1**2/(p1q1*s)+96*a1*a2*mt**2*p2q1**2/(p1q2*s)+
44159 &288*a1*a2*p1q2*p2q1**2/(p1q1*s)-96*a2*mb**3*mt/(p2q2*s)+
44160 &96*a2*mb**2*p1p2/(p2q2*s)-192*a1*mb*mt*p1p2/(p2q2*s)+
44161 &192*a1*p1p2**2/(p2q2*s)+96*a1*mb**2*p1q1/(p2q2*s)+
44162 &48*a2*mb**2*p1q1/(p2q2*s)+192*a1*a2*mb**3*mt*p1q1/(p2q2*s)-
44163 &192*a1*a2*mb**2*p1p2*p1q1/(p2q2*s)-
44164 &96*a1*a2*mb**2*p1q1**2/(p2q2*s)+96*a1*mb**2*p1q2/(p2q2*s)+
44165 &192*a2*mb**2*p1q2/(p2q2*s)-96*a1*mb*mt*p1q2/(p2q2*s)-
44166 &192*a1*a2*mb**3*mt*p1q2/(p2q2*s)+192*a1*p1p2*p1q2/(p2q2*s)+
44167 &192*a1*a2*mb**2*p1p2*p1q2/(p2q2*s)-
44168 &192*a2*mb**3*mt*p1q2/(p1q1*p2q2*s)+
44169 &192*a2*mb**2*p1p2*p1q2/(p1q1*p2q2*s)-
44170 &96*a1*mb*mt*p1p2*p1q2/(p1q1*p2q2*s)+
44171 &96*a1*p1p2**2*p1q2/(p1q1*p2q2*s)+96*a1*a2*mb**2*p1q2**2/(p2q2*s)
44172 a18=a18+96*a1*mb**2*p1q2**2/(p1q1*p2q2*s)+
44173 &192*a2*mb**2*p1q2**2/(p1q1*p2q2*s)-
44174 &48*a1*mb*mt*p1q2**2/(p1q1*p2q2*s)+
44175 &96*a1*p1p2*p1q2**2/(p1q1*p2q2*s)-48*a2*mb**2*p2q1/(p2q2*s)-
44176 &96*a1*mb*mt*p2q1/(p2q2*s)+48*a2*mb*mt*p2q1/(p2q2*s)-
44177 &192*a1*p1p2*p2q1/(p2q2*s)-192*a2*p1p2*p2q1/(p2q2*s)-
44178 &192*a1*a2*mb*mt*p1p2*p2q1/(p2q2*s)+
44179 &192*a1*a2*p1p2**2*p2q1/(p2q2*s)+
44180 &192*a1*mb*mt**3*p2q1/(p1q1*p2q2*s)+
44181 &96*a2*mb*mt*p1p2*p2q1/(p1q1*p2q2*s)-
44182 &192*a1*mt**2*p1p2*p2q1/(p1q1*p2q2*s)-
44183 &96*a2*p1p2**2*p2q1/(p1q1*p2q2*s)+
44184 &96*a1*a2*mb**2*p1q1*p2q1/(p2q2*s)+
44185 &192*a2**2*mb**2*p1q1*p2q1/(p2q2*s)-
44186 &96*a1*a2*mb*mt*p1q1*p2q1/(p2q2*s)+
44187 &384*a1*a2*p1p2*p1q1*p2q1/(p2q2*s)-96*a1*p1q2*p2q1/(p2q2*s)-
44188 &144*a2*p1q2*p2q1/(p2q2*s)-96*a1*a2*mb**2*p1q2*p2q1/(p2q2*s)
44189 a18=a18+96*a2**2*mb**2*p1q2*p2q1/(p2q2*s)-
44190 &384*a1*a2*mb*mt*p1q2*p2q1/(p2q2*s)+
44191 &576*a1*a2*p1p2*p1q2*p2q1/(p2q2*s)-
44192 &96*a2*mb**2*p1q2*p2q1/(p1q1*p2q2*s)-
44193 &48*a1*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
44194 &48*a2*mb*mt*p1q2*p2q1/(p1q1*p2q2*s)-
44195 &96*a1*mt**2*p1q2*p2q1/(p1q1*p2q2*s)-
44196 &96*a1*p1p2*p1q2*p2q1/(p1q1*p2q2*s)-
44197 &96*a2*p1p2*p1q2*p2q1/(p1q1*p2q2*s)+
44198 &96*a1*a2*p1q1*p1q2*p2q1/(p2q2*s)+288*a1*a2*p1q2**2*p2q1/(p2q2*s)-
44199 &96*a1*p1q2**2*p2q1/(p1q1*p2q2*s)-96*a2*p1q2**2*p2q1/(p1q1*p2q2*s)+
44200 &192*a1*p2q1**2/(p2q2*s)+192*a2*p2q1**2/(p2q2*s)+
44201 &96*a1*a2*mb*mt*p2q1**2/(p2q2*s)-192*a2**2*mb*mt*p2q1**2/(p2q2*s)-
44202 &192*a1*a2*mt**2*p2q1**2/(p2q2*s)-192*a1*a2*p1p2*p2q1**2/(p2q2*s)-
44203 &48*a2*mb*mt*p2q1**2/(p1q1*p2q2*s)+
44204 &192*a1*mt**2*p2q1**2/(p1q1*p2q2*s)+
44205 &96*a2*mt**2*p2q1**2/(p1q1*p2q2*s)
44206 a18=a18+96*a2*p1p2*p2q1**2/(p1q1*p2q2*s)-
44207 &384*a1*a2*p1q1*p2q1**2/(p2q2*s)-
44208 &384*a2**2*p1q1*p2q1**2/(p2q2*s)-384*a1*a2*p1q2*p2q1**2/(p2q2*s)-
44209 &192*a2**2*p1q2*p2q1**2/(p2q2*s)+96*a1*p1q2*p2q1**2/(p1q1*p2q2*s)+
44210 &96*a2*p1q2*p2q1**2/(p1q1*p2q2*s)+144*a1*p2q2/s+192*a2*p2q2/s+
44211 &96*a1*a2*mb*mt*p2q2/s-480*a2**2*mb*mt*p2q2/s+
44212 &480*a12*mt**2*p2q2/s+384*a1*a2*mt**2*p2q2/s+
44213 &672*a1*a2*p1p2*p2q2/s+864*a2**2*p1p2*p2q2/s+
44214 &48*a1*mt**2*p2q2/(p1q1*s)+96*a2*mt**2*p2q2/(p1q1*s)+
44215 &192*a1*a2*mb*mt**3*p2q2/(p1q1*s)-
44216 &192*a1*a2*mt**2*p1p2*p2q2/(p1q1*s)-480*a12*p1q1*p2q2/s-
44217 &960*a1*a2*p1q1*p2q2/s-480*a2**2*p1q1*p2q2/s-
44218 &96*a2*mb*mt*p2q2/(p1q2*s)+192*a1*mt**2*p2q2/(p1q2*s)+
44219 &96*a2*mt**2*p2q2/(p1q2*s)-192*a1*a2*mb*mt**3*p2q2/(p1q2*s)+
44220 &192*a2*p1p2*p2q2/(p1q2*s)+192*a1*a2*mt**2*p1p2*p2q2/(p1q2*s)+
44221 &144*a1*p1q1*p2q2/(p1q2*s)+96*a2*p1q1*p2q2/(p1q2*s)+
44222 &384*a1*a2*mb*mt*p1q1*p2q2/(p1q2*s)
44223 a18=a18-96*a12*mt**2*p1q1*p2q2/(p1q2*s)+
44224 &96*a1*a2*mt**2*p1q1*p2q2/(p1q2*s)-
44225 &576*a1*a2*p1p2*p1q1*p2q2/(p1q2*s)-192*a12*p1q1**2*p2q2/(p1q2*s)-
44226 &384*a1*a2*p1q1**2*p2q2/(p1q2*s)-192*a12*p1q2*p2q2/s-
44227 &192*a2**2*p1q2*p2q2/s+96*a1*a2*mb*mt*p1q2*p2q2/(p1q1*s)-
44228 &192*a12*mt**2*p1q2*p2q2/(p1q1*s)-
44229 &96*a1*a2*mt**2*p1q2*p2q2/(p1q1*s)-
44230 &384*a1*a2*p1p2*p1q2*p2q2/(p1q1*s)-384*a12*p1q2**2*p2q2/(p1q1*s)-
44231 &384*a1*a2*p1q2**2*p2q2/(p1q1*s)-48*a2*mb**2*p2q2/(p2q1*s)-
44232 &96*a1*mb*mt*p2q2/(p2q1*s)+48*a2*mb*mt*p2q2/(p2q1*s)-
44233 &192*a1*p1p2*p2q2/(p2q1*s)-192*a2*p1p2*p2q2/(p2q1*s)-
44234 &192*a1*a2*mb*mt*p1p2*p2q2/(p2q1*s)+
44235 &192*a1*a2*p1p2**2*p2q2/(p2q1*s)-96*a1*p1q1*p2q2/(p2q1*s)-
44236 &144*a2*p1q1*p2q2/(p2q1*s)-96*a1*a2*mb**2*p1q1*p2q2/(p2q1*s)+
44237 &96*a2**2*mb**2*p1q1*p2q2/(p2q1*s)-
44238 &384*a1*a2*mb*mt*p1q1*p2q2/(p2q1*s)+
44239 &576*a1*a2*p1p2*p1q1*p2q2/(p2q1*s)+288*a1*a2*p1q1**2*p2q2/(p2q1*s)
44240 a18=a18+192*a1*mb*mt**3*p2q2/(p1q2*p2q1*s)+
44241 &96*a2*mb*mt*p1p2*p2q2/(p1q2*p2q1*s)-
44242 &192*a1*mt**2*p1p2*p2q2/(p1q2*p2q1*s)-
44243 &96*a2*p1p2**2*p2q2/(p1q2*p2q1*s)-
44244 &96*a2*mb**2*p1q1*p2q2/(p1q2*p2q1*s)-
44245 &48*a1*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
44246 &48*a2*mb*mt*p1q1*p2q2/(p1q2*p2q1*s)-
44247 &96*a1*mt**2*p1q1*p2q2/(p1q2*p2q1*s)-
44248 &96*a1*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
44249 &96*a2*p1p2*p1q1*p2q2/(p1q2*p2q1*s)-
44250 &96*a1*p1q1**2*p2q2/(p1q2*p2q1*s)-96*a2*p1q1**2*p2q2/(p1q2*p2q1*s)+
44251 &96*a1*a2*mb**2*p1q2*p2q2/(p2q1*s)+
44252 &192*a2**2*mb**2*p1q2*p2q2/(p2q1*s)-
44253 &96*a1*a2*mb*mt*p1q2*p2q2/(p2q1*s)+
44254 &384*a1*a2*p1p2*p1q2*p2q2/(p2q1*s)+
44255 &96*a1*a2*p1q1*p1q2*p2q2/(p2q1*s)-576*a1*a2*p2q1*p2q2/s+
44256 &96*a1*a2*p1q1*p2q1*p2q2/(p1q2*s)+96*a1*a2*p1q2*p2q1*p2q2/(p1q1*s)
44257 a18=a18-96*a1*a2*p2q2**2/s+96*a1*a2*mt**2*p2q2**2/(p1q1*s)-
44258 &96*a1*a2*mt**2*p2q2**2/(p1q2*s)+288*a1*a2*p1q1*p2q2**2/(p1q2*s)+
44259 &192*a1*p2q2**2/(p2q1*s)+192*a2*p2q2**2/(p2q1*s)+
44260 &96*a1*a2*mb*mt*p2q2**2/(p2q1*s)-192*a2**2*mb*mt*p2q2**2/(p2q1*s)-
44261 &192*a1*a2*mt**2*p2q2**2/(p2q1*s)-192*a1*a2*p1p2*p2q2**2/(p2q1*s)-
44262 &384*a1*a2*p1q1*p2q2**2/(p2q1*s)-192*a2**2*p1q1*p2q2**2/(p2q1*s)-
44263 &48*a2*mb*mt*p2q2**2/(p1q2*p2q1*s)+
44264 &192*a1*mt**2*p2q2**2/(p1q2*p2q1*s)+
44265 &96*a2*mt**2*p2q2**2/(p1q2*p2q1*s)+
44266 &96*a2*p1p2*p2q2**2/(p1q2*p2q1*s)+96*a1*p1q1*p2q2**2/(p1q2*p2q1*s)+
44267 &96*a2*p1q1*p2q2**2/(p1q2*p2q1*s)-384*a1*a2*p1q2*p2q2**2/(p2q1*s)-
44268 &384*a2**2*p1q2*p2q2**2/(p2q1*s)+512*a1*a2*s/3-
44269 &128*a1*mt**2*s/(3*p1q1**2)+128*a12*mb*mt**3*s/(3*p1q1**2)-
44270 &152*a1*s/(3*p1q1)-152*a12*mb*mt*s/(3*p1q1)-
44271 &128*a1*a2*mb*mt*s/(3*p1q1)+112*a1*a2*mt**2*s/(3*p1q1)-
44272 &16*a12*p1p2*s/p1q1+152*a1*a2*p1p2*s/(3*p1q1)-
44273 &128*a1*mt**2*s/(3*p1q2**2)+128*a12*mb*mt**3*s/(3*p1q2**2)
44274 a18=a18-152*a1*s/(3*p1q2)-152*a12*mb*mt*s/(3*p1q2)-
44275 &128*a1*a2*mb*mt*s/(3*p1q2)+112*a1*a2*mt**2*s/(3*p1q2)-
44276 &16*a12*p1p2*s/p1q2+152*a1*a2*p1p2*s/(3*p1q2)+
44277 &16*a1*mb*mt*s/(3*p1q1*p1q2)-32*a12*mb*mt**3*s/(3*p1q1*p1q2)-
44278 &16*a1*p1p2*s/(3*p1q1*p1q2)+272*a1*a2*p1q1*s/(3*p1q2)+
44279 &272*a1*a2*p1q2*s/(3*p1q1)-128*a2*mb**2*s/(3*p2q1**2)+
44280 &128*a2**2*mb**3*mt*s/(3*p2q1**2)+
44281 &32*mb**2*mt**2*s/(3*p1q2**2*p2q1**2)+32*mb**2*s/(3*p1q2*p2q1**2)
44282
44283 a18bis=
44284 &64*a2*mb**3*mt*s/(3*p1q2*p2q1**2)-
44285 &64*a2*mb**2*mt**2*s/(3*p1q2*p2q1**2)-
44286 &128*a2*mb**2*p1p2*s/(3*p1q2*p2q1**2)-
44287 &128*a2*mb**2*p1q1*s/(3*p1q2*p2q1**2)+
44288 &128*a2**2*mb**2*p1q2*s/(3*p2q1**2)+152*a2*s/(3*p2q1)-
44289 &112*a1*a2*mb**2*s/(3*p2q1)+128*a1*a2*mb*mt*s/(3*p2q1)+
44290 &152*a2**2*mb*mt*s/(3*p2q1)-152*a1*a2*p1p2*s/(3*p2q1)+
44291 &16*a2**2*p1p2*s/p2q1-8*a1*a2*mb**3*mt*s/(3*p1q1*p2q1)+
44292 &16*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q1)-
44293 &8*a1*a2*mb*mt**3*s/(3*p1q1*p2q1)-8*a1*p1p2*s/(3*p1q1*p2q1)-
44294 &8*a2*p1p2*s/(3*p1q1*p2q1)+8*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q1)-
44295 &16*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q1)+
44296 &8*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q1)+
44297 &32*a1*a2*p1p2**2*s/(3*p1q1*p2q1)-32*a2**2*p1q1*s/(3*p2q1)-
44298 &32*mt**2*s/(3*p1q2**2*p2q1)+64*a1*mb**2*mt**2*s/(3*p1q2**2*p2q1)-
44299 &64*a1*mb*mt**3*s/(3*p1q2**2*p2q1)
44300 a18bis=a18bis+128*a1*mt**2*p1p2*s/(3*p1q2**2*p2q1)-
44301 &12*s/(p1q2*p2q1)+
44302 &24*a1*mb**2*s/(p1q2*p2q1)+64*a1*a2*mb**3*mt*s/(3*p1q2*p2q1)+
44303 &24*a2*mt**2*s/(p1q2*p2q1)-128*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q1)+
44304 &64*a1*a2*mb*mt**3*s/(3*p1q2*p2q1)+56*a1*p1p2*s/(3*p1q2*p2q1)+
44305 &56*a2*p1p2*s/(3*p1q2*p2q1)-64*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q1)+
44306 &128*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q1)-
44307 &64*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q1)-
44308 &256*a1*a2*p1p2**2*s/(3*p1q2*p2q1)+4*p1p2*s/(3*p1q1*p1q2*p2q1)-
44309 &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1)-
44310 &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1)+136*a2*p1q1*s/(3*p1q2*p2q1)-
44311 &128*a1*a2*mb**2*p1q1*s/(3*p1q2*p2q1)+
44312 &128*a1*a2*mb*mt*p1q1*s/(3*p1q2*p2q1)-
44313 &256*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q1)-160*a2**2*p1q2*s/(3*p2q1)+
44314 &16*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q1)-32*a12*p2q1*s/(3*p1q1)-
44315 &128*a12*mt**2*p2q1*s/(3*p1q2**2)-160*a12*p2q1*s/(3*p1q2)-
44316 &128*a2*mb**2*s/(3*p2q2**2)+128*a2**2*mb**3*mt*s/(3*p2q2**2)
44317 a18bis=a18bis+32*mb**2*mt**2*s/(3*p1q1**2*p2q2**2)+
44318 &32*mb**2*s/(3*p1q1*p2q2**2)+
44319 &64*a2*mb**3*mt*s/(3*p1q1*p2q2**2)-
44320 &64*a2*mb**2*mt**2*s/(3*p1q1*p2q2**2)-
44321 &128*a2*mb**2*p1p2*s/(3*p1q1*p2q2**2)+
44322 &128*a2**2*mb**2*p1q1*s/(3*p2q2**2)-
44323 &128*a2*mb**2*p1q2*s/(3*p1q1*p2q2**2)+152*a2*s/(3*p2q2)-
44324 &112*a1*a2*mb**2*s/(3*p2q2)+128*a1*a2*mb*mt*s/(3*p2q2)+
44325 &152*a2**2*mb*mt*s/(3*p2q2)-152*a1*a2*p1p2*s/(3*p2q2)+
44326 &16*a2**2*p1p2*s/p2q2-32*mt**2*s/(3*p1q1**2*p2q2)+
44327 &64*a1*mb**2*mt**2*s/(3*p1q1**2*p2q2)-
44328 &64*a1*mb*mt**3*s/(3*p1q1**2*p2q2)+
44329 &128*a1*mt**2*p1p2*s/(3*p1q1**2*p2q2)-12*s/(p1q1*p2q2)+
44330 &24*a1*mb**2*s/(p1q1*p2q2)+64*a1*a2*mb**3*mt*s/(3*p1q1*p2q2)+
44331 &24*a2*mt**2*s/(p1q1*p2q2)-128*a1*a2*mb**2*mt**2*s/(3*p1q1*p2q2)+
44332 &64*a1*a2*mb*mt**3*s/(3*p1q1*p2q2)+56*a1*p1p2*s/(3*p1q1*p2q2)+
44333 &56*a2*p1p2*s/(3*p1q1*p2q2)-64*a1*a2*mb**2*p1p2*s/(3*p1q1*p2q2)
44334 a18bis=a18bis+128*a1*a2*mb*mt*p1p2*s/(3*p1q1*p2q2)-
44335 &64*a1*a2*mt**2*p1p2*s/(3*p1q1*p2q2)-
44336 &256*a1*a2*p1p2**2*s/(3*p1q1*p2q2)-160*a2**2*p1q1*s/(3*p2q2)-
44337 &8*a1*a2*mb**3*mt*s/(3*p1q2*p2q2)+
44338 &16*a1*a2*mb**2*mt**2*s/(3*p1q2*p2q2)-
44339 &8*a1*a2*mb*mt**3*s/(3*p1q2*p2q2)-8*a1*p1p2*s/(3*p1q2*p2q2)-
44340 &8*a2*p1p2*s/(3*p1q2*p2q2)+8*a1*a2*mb**2*p1p2*s/(3*p1q2*p2q2)-
44341 &16*a1*a2*mb*mt*p1p2*s/(3*p1q2*p2q2)+
44342 &8*a1*a2*mt**2*p1p2*s/(3*p1q2*p2q2)+
44343 &32*a1*a2*p1p2**2*s/(3*p1q2*p2q2)+4*p1p2*s/(3*p1q1*p1q2*p2q2)-
44344 &8*a1*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q2)-
44345 &8*a1*mt**2*p1p2*s/(3*p1q1*p1q2*p2q2)+
44346 &16*a1*a2*p1p2*p1q1*s/(3*p1q2*p2q2)-32*a2**2*p1q2*s/(3*p2q2)+
44347 &136*a2*p1q2*s/(3*p1q1*p2q2)-128*a1*a2*mb**2*p1q2*s/(3*p1q1*p2q2)+
44348 &128*a1*a2*mb*mt*p1q2*s/(3*p1q1*p2q2)-
44349 &256*a1*a2*p1p2*p1q2*s/(3*p1q1*p2q2)+16*a2*mb*mt*s/(3*p2q1*p2q2)-
44350 &32*a2**2*mb**3*mt*s/(3*p2q1*p2q2)-16*a2*p1p2*s/(3*p2q1*p2q2)
44351 a18bis=a18bis-4*p1p2*s/(3*p1q1*p2q1*p2q2)+
44352 &8*a2*mb**2*p1p2*s/(3*p1q1*p2q1*p2q2)+
44353 &8*a2*mb*mt*p1p2*s/(3*p1q1*p2q1*p2q2)-4*p1p2*s/(3*p1q2*p2q1*p2q2)+
44354 &8*a2*mb**2*p1p2*s/(3*p1q2*p2q1*p2q2)+
44355 &8*a2*mb*mt*p1p2*s/(3*p1q2*p2q1*p2q2)-
44356 &2*mb**3*mt*s/(3*p1q1*p1q2*p2q1*p2q2)+
44357 &4*mb**2*mt**2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44358 &2*mb*mt**3*s/(3*p1q1*p1q2*p2q1*p2q2)-
44359 &2*mb**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)+
44360 &4*mb*mt*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44361 &2*mt**2*p1p2*s/(3*p1q1*p1q2*p2q1*p2q2)-
44362 &8*p1p2**2*s/(3*p1q1*p1q2*p2q1*p2q2)+
44363 &8*a2*p1p2*p1q1*s/(3*p1q2*p2q1*p2q2)+
44364 &8*a2*p1p2*p1q2*s/(3*p1q1*p2q1*p2q2)+272*a1*a2*p2q1*s/(3*p2q2)-
44365 &128*a1*mt**2*p2q1*s/(3*p1q1**2*p2q2)-136*a1*p2q1*s/(3*p1q1*p2q2)-
44366 &128*a1*a2*mb*mt*p2q1*s/(3*p1q1*p2q2)+
44367 &128*a1*a2*mt**2*p2q1*s/(3*p1q1*p2q2)
44368 a18bis=a18bis+256*a1*a2*p1p2*p2q1*s/(3*p1q1*p2q2)-
44369 &16*a1*a2*p1p2*p2q1*s/(3*p1q2*p2q2)+
44370 &8*a1*p1p2*p2q1*s/(3*p1q1*p1q2*p2q2)+
44371 &256*a1*a2*p1q2*p2q1*s/(3*p1q1*p2q2)-
44372 &128*a12*mt**2*p2q2*s/(3*p1q1**2)-160*a12*p2q2*s/(3*p1q1)-
44373 &32*a12*p2q2*s/(3*p1q2)+272*a1*a2*p2q2*s/(3*p2q1)-
44374 &16*a1*a2*p1p2*p2q2*s/(3*p1q1*p2q1)-
44375 &128*a1*mt**2*p2q2*s/(3*p1q2**2*p2q1)-136*a1*p2q2*s/(3*p1q2*p2q1)-
44376 &128*a1*a2*mb*mt*p2q2*s/(3*p1q2*p2q1)+
44377 &128*a1*a2*mt**2*p2q2*s/(3*p1q2*p2q1)+
44378 &256*a1*a2*p1p2*p2q2*s/(3*p1q2*p2q1)+
44379 &8*a1*p1p2*p2q2*s/(3*p1q1*p1q2*p2q1)+
44380 &256*a1*a2*p1q1*p2q2*s/(3*p1q2*p2q1)-
44381 &8*a12*mb*mt*s**2/(3*p1q1*p1q2)+16*a12*p1p2*s**2/(3*p1q1*p1q2)-
44382 &8*a1*a2*p1p2*s**2/(3*p1q1*p2q1)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q1)-
44383 &8*a1*a2*p1p2*s**2/(3*p1q2*p2q2)+4*a1*p1p2*s**2/(3*p1q1*p1q2*p2q2)-
44384 &8*a2**2*mb*mt*s**2/(3*p2q1*p2q2)+16*a2**2*p1p2*s**2/(3*p2q1*p2q2)
44385 a18bis=a18bis-4*a2*p1p2*s**2/(3*p1q1*p2q1*p2q2)-
44386 &4*a2*p1p2*s**2/(3*p1q2*p2q1*p2q2)+
44387 &2*p1p2*s**2/(3*p1q1*p1q2*p2q1*p2q2)
44388C
44389 v18=v18+v18bis
44390 a18=a18+a18bis
44391 v910 =-48*a12*mb*mt-48*a2**2*mb*mt-48*a12*p1p2-48*a2**2*p1p2-
44392 &384*a12*mb*mt*p1q1*p1q2/s**2-384*a12*p1p2*p1q1*p1q2/s**2-
44393 &384*a1*a2*mb*mt*p1q2*p2q1/s**2-384*a1*a2*p1p2*p1q2*p2q1/s**2+
44394 &192*a12*p1q1*p1q2*p2q1/s**2+192*a1*a2*p1q1*p1q2*p2q1/s**2-
44395 &192*a12*p1q2**2*p2q1/s**2-192*a1*a2*p1q2**2*p2q1/s**2+
44396 &192*a1*a2*p1q2*p2q1**2/s**2+192*a2**2*p1q2*p2q1**2/s**2-
44397 &384*a1*a2*mb*mt*p1q1*p2q2/s**2-384*a1*a2*p1p2*p1q1*p2q2/s**2-
44398 &192*a12*p1q1**2*p2q2/s**2-192*a1*a2*p1q1**2*p2q2/s**2+
44399 &192*a12*p1q1*p1q2*p2q2/s**2+192*a1*a2*p1q1*p1q2*p2q2/s**2-
44400 &384*a2**2*mb*mt*p2q1*p2q2/s**2-384*a2**2*p1p2*p2q1*p2q2/s**2-
44401 &192*a1*a2*p1q1*p2q1*p2q2/s**2-192*a2**2*p1q1*p2q1*p2q2/s**2-
44402 &192*a1*a2*p1q2*p2q1*p2q2/s**2-192*a2**2*p1q2*p2q1*p2q2/s**2+
44403 &192*a1*a2*p1q1*p2q2**2/s**2+192*a2**2*p1q1*p2q2**2/s**2+
44404 &96*a12*mb*mt*p1q1/s-96*a1*a2*mb*mt*p1q1/s+
44405 &96*a12*p1p2*p1q1/s-96*a1*a2*p1p2*p1q1/s+96*a12*mb*mt*p1q2/s-
44406 &96*a1*a2*mb*mt*p1q2/s+96*a12*p1p2*p1q2/s-96*a1*a2*p1p2*p1q2/s+
44407 &96*a1*a2*mb*mt*p2q1/s-96*a2**2*mb*mt*p2q1/s
44408 v910=v910+96*a1*a2*p1p2*p2q1/s-
44409 &96*a2**2*p1p2*p2q1/s+96*a12*p1q2*p2q1/s+
44410 &192*a1*a2*p1q2*p2q1/s+96*a2**2*p1q2*p2q1/s+
44411 &96*a1*a2*mb*mt*p2q2/s-96*a2**2*mb*mt*p2q2/s+
44412 &96*a1*a2*p1p2*p2q2/s-96*a2**2*p1p2*p2q2/s+96*a12*p1q1*p2q2/s+
44413 &192*a1*a2*p1q1*p2q2/s+96*a2**2*p1q1*p2q2/s
44414C
44415 a910 = 48*a12*mb*mt+48*a2**2*mb*mt-48*a12*p1p2-48*a2**2*p1p2+
44416 &384*a12*mb*mt*p1q1*p1q2/s**2-384*a12*p1p2*p1q1*p1q2/s**2+
44417 &384*a1*a2*mb*mt*p1q2*p2q1/s**2-384*a1*a2*p1p2*p1q2*p2q1/s**2+
44418 &192*a12*p1q1*p1q2*p2q1/s**2+192*a1*a2*p1q1*p1q2*p2q1/s**2-
44419 &192*a12*p1q2**2*p2q1/s**2-192*a1*a2*p1q2**2*p2q1/s**2+
44420 &192*a1*a2*p1q2*p2q1**2/s**2+192*a2**2*p1q2*p2q1**2/s**2+
44421 &384*a1*a2*mb*mt*p1q1*p2q2/s**2-384*a1*a2*p1p2*p1q1*p2q2/s**2-
44422 &192*a12*p1q1**2*p2q2/s**2-192*a1*a2*p1q1**2*p2q2/s**2+
44423 &192*a12*p1q1*p1q2*p2q2/s**2+192*a1*a2*p1q1*p1q2*p2q2/s**2+
44424 &384*a2**2*mb*mt*p2q1*p2q2/s**2-384*a2**2*p1p2*p2q1*p2q2/s**2-
44425 &192*a1*a2*p1q1*p2q1*p2q2/s**2-192*a2**2*p1q1*p2q1*p2q2/s**2-
44426 &192*a1*a2*p1q2*p2q1*p2q2/s**2-192*a2**2*p1q2*p2q1*p2q2/s**2+
44427 &192*a1*a2*p1q1*p2q2**2/s**2+192*a2**2*p1q1*p2q2**2/s**2-
44428 &96*a12*mb*mt*p1q1/s+96*a1*a2*mb*mt*p1q1/s+
44429 &96*a12*p1p2*p1q1/s-96*a1*a2*p1p2*p1q1/s-96*a12*mb*mt*p1q2/s+
44430 &96*a1*a2*mb*mt*p1q2/s+96*a12*p1p2*p1q2/s-96*a1*a2*p1p2*p1q2/s-
44431 &96*a1*a2*mb*mt*p2q1/s+96*a2**2*mb*mt*p2q1/s
44432 a910=a910+96*a1*a2*p1p2*p2q1/s-
44433 &96*a2**2*p1p2*p2q1/s+96*a12*p1q2*p2q1/s+
44434 &192*a1*a2*p1q2*p2q1/s+96*a2**2*p1q2*p2q1/s-
44435 &96*a1*a2*mb*mt*p2q2/s+96*a2**2*mb*mt*p2q2/s+
44436 &96*a1*a2*p1p2*p2q2/s-96*a2**2*p1p2*p2q2/s+96*a12*p1q1*p2q2/s+
44437 &192*a1*a2*p1q1*p2q2/s+96*a2**2*p1q1*p2q2/s
44438C
44439C FINAL RESULT;
44440C
44441 amp2= fact*ps*vtb**2*(v**2 *(v18 +v910)+a**2 *(a18+a910) )
44442
44443 END
44444C---------------------------------------------------------
44445C 2) Q QBAR ->TBH^+
44446 SUBROUTINE pytbhq(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44447C
44448C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44449C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44450 IMPLICIT DOUBLE PRECISION(a-h, o-z)
44451 IMPLICIT INTEGER(I-N)
44452 DOUBLE PRECISION MW2,MT,MB,MHP,MW
44453 dimension q1(4),q2(4),p1(4),p2(4),p3(4)
44454 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
44455 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
44456 common/pymssm/imss(0:99),rmss(0:99)
44457 common/pyctbh/ alpha,alphas,sw2,mw2,tanb,vtb,v,a
44458 SAVE /pydat1/,/pydat2/,/pymssm/,/pyctbh/
44459C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44460C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44461C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44462C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44463C
44464C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44465C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44466C
44467 dimension yy(2,2)
44468
44469 pi = 4*datan(1.d0)
44470 mw = dsqrt(mw2)
44471
44472C COLLECTING THE RELEVANT OVERALL FACTORS:
44473C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44474 ps=1.d0/(3.d0*3.d0 *2.d0*2.d0)
44475C COUPLING CONSTANT (OVERALL NORMALIZATION)
44476 fact=(4.d0*pi*alpha)*(4.d0*pi*alphas)**2/sw2/2.d0
44477C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44478C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44479C ALPHAS IS ALPHA_STRONG;
44480C SW2 IS SIN(THETA_W)**2.
44481C
44482C VTB=.998D0
44483C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44484C
44485 v = ( mt/mw/tanb +rmb/mw*tanb)/2.d0
44486 a = (-mt/mw/tanb +rmb/mw*tanb)/2.d0
44487C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44488C
44489C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44490C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44491 DO 100 kk=1,4
44492 p2(kk)=p3(kk)-q1(kk)-q2(kk)+p1(kk)
44493 100 CONTINUE
44494C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44495 s = 2*pytbhs(q1,q2)
44496 p1q1=pytbhs(q1,p1)
44497 p1q2=pytbhs(p1,q2)
44498 p2q1=pytbhs(p2,q1)
44499 p2q2=pytbhs(p2,q2)
44500 p1p2=pytbhs(p1,p2)
44501C
44502C TOP WIDTH CALCULATION
44503 CALL pytbhb(mt,mb,mhp,br,gamt)
44504C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44505C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44506 a1inv= s -2*p1q1 -2*p1q2
44507 a1 =a1inv/(a1inv**2+ (gamt*mt)**2)
44508C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44509C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44510 a12 = 1.d0/(a1inv**2+ (gamt*mt)**2)
44511 a2 =1.d0/(s +2*p2q1 +2*p2q2)
44512C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44513C NOW COMES THE AMP**2:
44514C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44515C THE EXPRESSIONS BELOW
44516 yy(1, 1) = -16*a**2*a2**2*mb*mt+
44517 &64*a**2*a2**2*p1q2*p2q1**2/s**2+
44518 &128*a**2*a2**2*mb*mt*p2q1*p2q2/s**2-
44519 &128*a**2*a2**2*p1p2*p2q1*p2q2/s**2-
44520 &64*a**2*a2**2*p1q1*p2q1*p2q2/s**2-
44521 &64*a**2*a2**2*p1q2*p2q1*p2q2/s**2+
44522 &64*a**2*a2**2*p1q1*p2q2**2/s**2-
44523 &32*a**2*a2**2*mb**3*mt/s+32*a**2*a2**2*mb**2*p1p2/s+
44524 &32*a**2*a2**2*mb**2*p1q1/s+32*a**2*a2**2*mb**2*p1q2/s-
44525 &32*a**2*a2**2*p1p2*p2q1/s-32*a**2*a2**2*p1q1*p2q1/s-
44526 &32*a**2*a2**2*p1p2*p2q2/s-32*a**2*a2**2*p1q2*p2q2/s+
44527 &16*a2**2*mb*mt*v**2+64*a2**2*p1q2*p2q1**2*v**2/s**2-
44528 &128*a2**2*mb*mt*p2q1*p2q2*v**2/s**2-
44529 &128*a2**2*p1p2*p2q1*p2q2*v**2/s**2-
44530 &64*a2**2*p1q1*p2q1*p2q2*v**2/s**2-
44531 &64*a2**2*p1q2*p2q1*p2q2*v**2/s**2+
44532 &64*a2**2*p1q1*p2q2**2*v**2/s**2
44533 yy(1, 1)=yy(1, 1)+32*a2**2*mb**3*mt*v**2/s+
44534 &32*a2**2*mb**2*p1p2*v**2/s+
44535 &32*a2**2*mb**2*p1q1*v**2/s+32*a2**2*mb**2*p1q2*v**2/s-
44536 &32*a2**2*p1p2*p2q1*v**2/s-32*a2**2*p1q1*p2q1*v**2/s-
44537 &32*a2**2*p1p2*p2q2*v**2/s-32*a2**2*p1q2*p2q2*v**2/s
44538 yy(1, 1)=2*yy(1, 1)
44539
44540 yy(1, 2) = -32*a**2*a1*a2*mb*mt+
44541 &128*a**2*a1*a2*mb*mt*p1q2*p2q1/s**2-
44542 &128*a**2*a1*a2*p1p2*p1q2*p2q1/s**2+
44543 &64*a**2*a1*a2*p1q1*p1q2*p2q1/s**2-
44544 &64*a**2*a1*a2*p1q2**2*p2q1/s**2+
44545 &64*a**2*a1*a2*p1q2*p2q1**2/s**2+
44546 &128*a**2*a1*a2*mb*mt*p1q1*p2q2/s**2-
44547 &128*a**2*a1*a2*p1p2*p1q1*p2q2/s**2-
44548 &64*a**2*a1*a2*p1q1**2*p2q2/s**2+
44549 &64*a**2*a1*a2*p1q1*p1q2*p2q2/s**2-
44550 &64*a**2*a1*a2*p1q1*p2q1*p2q2/s**2-
44551 &64*a**2*a1*a2*p1q2*p2q1*p2q2/s**2+
44552 &64*a**2*a1*a2*p1q1*p2q2**2/s**2-
44553 &64*a**2*a1*a2*mb*mt*p1p2/s+
44554 &64*a**2*a1*a2*p1p2**2/s+32*a**2*a1*a2*mb**2*p1q1/s+
44555 &32*a**2*a1*a2*p1p2*p1q1/s+32*a**2*a1*a2*mb**2*p1q2/s+
44556 &32*a**2*a1*a2*p1p2*p1q2/s-32*a**2*a1*a2*mt**2*p2q1/s
44557 yy(1, 2)=yy(1, 2)-32*a**2*a1*a2*p1p2*p2q1/s-
44558 &64*a**2*a1*a2*p1q1*p2q1/s-
44559 &32*a**2*a1*a2*mt**2*p2q2/s-32*a**2*a1*a2*p1p2*p2q2/s-
44560 &64*a**2*a1*a2*p1q2*p2q2/s+32*a1*a2*mb*mt*v**2-
44561 &128*a1*a2*mb*mt*p1q2*p2q1*v**2/s**2 -
44562 &128*a1*a2*p1p2*p1q2*p2q1*v**2/s**2+
44563 &64*a1*a2*p1q1*p1q2*p2q1*v**2/s**2-
44564 &64*a1*a2*p1q2**2*p2q1*v**2/s**2+
44565 &64*a1*a2*p1q2*p2q1**2*v**2/s**2-
44566 &128*a1*a2*mb*mt*p1q1*p2q2*v**2/s**2-
44567 &128*a1*a2*p1p2*p1q1*p2q2*v**2/s**2-
44568 &64*a1*a2*p1q1**2*p2q2*v**2/s**2+
44569 &64*a1*a2*p1q1*p1q2*p2q2*v**2/s**2-
44570 &64*a1*a2*p1q1*p2q1*p2q2*v**2/s**2-
44571 &64*a1*a2*p1q2*p2q1*p2q2*v**2/s**2+
44572 &64*a1*a2*p1q1*p2q2**2*v**2/s**2+
44573 &64*a1*a2*mb*mt*p1p2*v**2/s+64*a1*a2*p1p2**2*v**2/s
44574 yy(1, 2)=yy(1, 2)+32*a1*a2*mb**2*p1q1*v**2/s+
44575 &32*a1*a2*p1p2*p1q1*v**2/s+
44576 &32*a1*a2*mb**2*p1q2*v**2/s+32*a1*a2*p1p2*p1q2*v**2/s-
44577 &32*a1*a2*mt**2*p2q1*v**2/s-32*a1*a2*p1p2*p2q1*v**2/s-
44578 &64*a1*a2*p1q1*p2q1*v**2/s-32*a1*a2*mt**2*p2q2*v**2/s-
44579 &32*a1*a2*p1p2*p2q2*v**2/s-64*a1*a2*p1q2*p2q2*v**2/s
44580
44581
44582 yy(2, 2) =-16*a**2*a12*mb*mt+
44583 &128*a**2*a12*mb*mt*p1q1*p1q2/s**2-
44584 &128*a**2*a12*p1p2*p1q1*p1q2/s**2+
44585 &64*a**2*a12*p1q1*p1q2*p2q1/s**2-
44586 &64*a**2*a12*p1q2**2*p2q1/s**2-64*a**2*a12*p1q1**2*p2q2/s**2+
44587 &64*a**2*a12*p1q1*p1q2*p2q2/s**2-32*a**2*a12*mb*mt**3/s+
44588 &32*a**2*a12*mt**2*p1p2/s+32*a**2*a12*p1p2*p1q1/s+
44589 &32*a**2*a12*p1p2*p1q2/s-32*a**2*a12*mt**2*p2q1/s-
44590 &32*a**2*a12*p1q1*p2q1/s-32*a**2*a12*mt**2*p2q2/s-
44591 &32*a**2*a12*p1q2*p2q2/s+16*a12*mb*mt*v**2-
44592 &128*a12*mb*mt*p1q1*p1q2*v**2/s**2-
44593 &128*a12*p1p2*p1q1*p1q2*v**2/s**2+
44594 &64*a12*p1q1*p1q2*p2q1*v**2/s**2-
44595 &64*a12*p1q2**2*p2q1*v**2/s**2-64*a12*p1q1**2*p2q2*v**2/s**2+
44596 &64*a12*p1q1*p1q2*p2q2*v**2/s**2+32*a12*mb*mt**3*v**2/s+
44597 &32*a12*mt**2*p1p2*v**2/s+32*a12*p1p2*p1q1*v**2/s+
44598 &32*a12*p1p2*p1q2*v**2/s-32*a12*mt**2*p2q1*v**2/s
44599 yy(2, 2)=yy(2, 2)-32*a12*p1q1*p2q1*v**2/s-
44600 &32*a12*mt**2*p2q2*v**2/s-
44601 &32*a12*p1q2*p2q2*v**2/s
44602 yy(2, 2)=2*yy(2, 2)
44603
44604 res=yy(1,1)+2*yy(1,2)+yy(2,2)
44605 amp2= fact*ps*vtb**2*res
44606
44607 END
44608C=====================================================================
44609C ************* FUNCTION SCALAR PRODUCTS *************************
44610 DOUBLE PRECISION FUNCTION pytbhs(A,B)
44611 IMPLICIT DOUBLE PRECISION(a-h, o-z)
44612 IMPLICIT INTEGER(I-N)
44613 dimension a(4),b(4)
44614 dum=a(4)*b(4)
44615 DO 100 id=1,3
44616 dum=dum-a(id)*b(id)
44617 100 CONTINUE
44618 pytbhs=dum
44619 RETURN
44620 END
44621
44622C*********************************************************************
44623
44624C...PYMSIN
44625C...Initializes supersymmetry: finds sparticle masses and
44626C...branching ratios and stores this information.
44627C...AUTHOR: STEPHEN MRENNA
44628C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44629
44630 SUBROUTINE pymsin
44631
44632C...Double precision and integer declarations.
44633 IMPLICIT DOUBLE PRECISION(a-h, o-z)
44634 IMPLICIT INTEGER(I-N)
44635 INTEGER PYK,PYCHGE,PYCOMP
44636C...Parameter statement to help give large particle numbers.
44637 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
44638 &kexcit=4000000,kdimen=5000000)
44639C...Commonblocks.
44640 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
44641 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
44642 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
44643 common/pydat4/chaf(500,2)
44644 CHARACTER CHAF*16
44645 common/pypars/mstp(200),parp(200),msti(200),pari(200)
44646 common/pyint4/mwid(500),wids(500,5)
44647 common/pymssm/imss(0:99),rmss(0:99)
44648 common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
44649 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
44650 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
44651 common/pyhtri/hhh(7)
44652 common/pyqnum/nqnum,nqdum,kqnum(500,0:9)
44653 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pypars/,/pyint4/,
44654 &/pymssm/,/pymsrv/,/pyssmt/
44655
44656C...Local variables.
44657 DOUBLE PRECISION ALFA,BETA
44658 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44659 INTEGER I,J,J1,I1,K1
44660 INTEGER KC,LKNT,IDLAM(400,3)
44661 DOUBLE PRECISION XLAM(0:400)
44662 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44663 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44664 DOUBLE PRECISION DELM,XMDIF
44665 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44666 DOUBLE PRECISION ARG,SGNMU,R
44667 INTEGER IMSSM
44668 INTEGER IRPRTY
44669 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44670 SAVE mwidsu,mdcysu
44671 DATA kfsusy/
44672 &1000001,2000001,1000002,2000002,1000003,2000003,
44673 &1000004,2000004,1000005,2000005,1000006,2000006,
44674 &1000011,2000011,1000012,2000012,1000013,2000013,
44675 &1000014,2000014,1000015,2000015,1000016,2000016,
44676 &1000021,1000022,1000023,1000025,1000035,1000024,
44677 &1000037,1000039, 25, 35, 36, 37,
44678 & 6, 24, 45, 46,1000045, 9*0/
44679 DATA init/0/
44680
44681C...Automatically read QNUMBERS, MASS, and DECAY tables
44682 IF (imss(21).NE.0.OR.mstp(161).NE.0) THEN
44683 nqnum=0
44684 CALL pyslha(0,0,ifail)
44685 CALL pyslha(5,0,ifail)
44686 ENDIF
44687 IF (imss(22).NE.0.OR.mstp(161).NE.0) CALL pyslha(2,0,ifail)
44688
44689C...Do nothing further if SUSY not requested
44690 imssm=imss(1)
44691 IF(imssm.EQ.0) RETURN
44692
44693C...Save copy of MWID(KC) and MDCY(KC,1) values before
44694C...they are set to zero for the LSP.
44695 IF(init.EQ.0) THEN
44696 init=1
44697 DO 100 i=1,36
44698 kf=kfsusy(i)
44699 kc=pycomp(kf)
44700 mwidsu(i)=mwid(kc)
44701 mdcysu(i)=mdcy(kc,1)
44702 100 CONTINUE
44703 ENDIF
44704
44705C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44706 DO 110 i=1,36
44707 kf=kfsusy(i)
44708 kc=pycomp(kf)
44709 IF(mdcy(kc,1).EQ.0.AND.mdcysu(i).NE.0) THEN
44710 mwid(kc)=mwidsu(i)
44711 mdcy(kc,1)=mdcysu(i)
44712 ENDIF
44713 110 CONTINUE
44714
44715C...First part of routine: set masses and couplings.
44716
44717C...Reset mixing values in sfermion sector to pure left/right.
44718 DO 120 i=1,16
44719 sfmix(i,1)=1d0
44720 sfmix(i,4)=1d0
44721 sfmix(i,2)=0d0
44722 sfmix(i,3)=0d0
44723 120 CONTINUE
44724
44725C...Add NMSSM states if NMSSM switched on, and change old names.
44726 IF (imss(13).NE.0.AND.pycomp(1000045).EQ.0) THEN
44727C... Switch on NMSSM
44728 WRITE(mstu(11),*) '(PYMSIN:) switching on NMSSM'
44729
44730 kfn=25
44731 kcn=kfn
44732 chaf(kcn,1)='h_10'
44733 chaf(kcn,2)=' '
44734
44735 kfn=35
44736 kcn=kfn
44737 chaf(kcn,1)='h_20'
44738 chaf(kcn,2)=' '
44739
44740 kfn=45
44741 kcn=kfn
44742 chaf(kcn,1)='h_30'
44743 chaf(kcn,2)=' '
44744
44745 kfn=36
44746 kcn=kfn
44747 chaf(kcn,1)='A_10'
44748 chaf(kcn,2)=' '
44749
44750 kfn=46
44751 kcn=kfn
44752 chaf(kcn,1)='A_20'
44753 chaf(kcn,2)=' '
44754
44755 kfn=1000045
44756 kcn=pycomp(kfn)
44757 IF (kcn.EQ.0) THEN
44758 DO 123 kct=100,mstu(6)
44759 IF(kchg(kct,4).GT.100) kcn=kct
44760 123 CONTINUE
44761 kcn=kcn+1
44762 kchg(kcn,4)=kfn
44763 mstu(20)=0
44764 ENDIF
44765C... Set stable for now
44766 pmas(kcn,2)=1d-6
44767 mwid(kcn)=0
44768 mdcy(kcn,1)=0
44769 mdcy(kcn,2)=0
44770 mdcy(kcn,3)=0
44771 chaf(kcn,1)='~chi_50'
44772 chaf(kcn,2)=' '
44773 ENDIF
44774
44775C...Read spectrum from SLHA file.
44776 IF (imssm.EQ.11) THEN
44777 CALL pyslha(1,0,ifail)
44778 ENDIF
44779
44780C...Common couplings.
44781 tanb=rmss(5)
44782 beta=atan(tanb)
44783 cosb=cos(beta)
44784 sinb=tanb*cosb
44785 cos2b=cos(2d0*beta)
44786 alfa=rmss(18)
44787 xmw2=pmas(24,1)**2
44788 xmz2=pmas(23,1)**2
44789 xw=paru(102)
44790
44791C...Define sparticle masses for a general MSSM simulation.
44792 IF(imssm.EQ.1) THEN
44793 IF(imss(9).EQ.0) rmss(22)=rmss(9)
44794 DO 130 i=1,5,2
44795 kc=pycomp(ksusy1+i)
44796 pmas(kc,1)=sqrt(rmss(8)**2-(2d0*xmw2+xmz2)*cos2b/6d0)
44797 kc=pycomp(ksusy2+i)
44798 pmas(kc,1)=sqrt(rmss(9)**2+(xmw2-xmz2)*cos2b/3d0)
44799 kc=pycomp(ksusy1+i+1)
44800 pmas(kc,1)=sqrt(rmss(8)**2+(4d0*xmw2-xmz2)*cos2b/6d0)
44801 kc=pycomp(ksusy2+i+1)
44802 pmas(kc,1)=sqrt(rmss(22)**2-(xmw2-xmz2)*cos2b*2d0/3d0)
44803 130 CONTINUE
44804 xarg=rmss(6)**2-pmas(24,1)**2*abs(cos(2d0*beta))
44805 IF(xarg.LT.0d0) THEN
44806 WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44807 & ' FROM THE SUM RULE. '
44808 WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44809 RETURN
44810 ELSE
44811 xarg=sqrt(xarg)
44812 ENDIF
44813 DO 140 i=11,15,2
44814 pmas(pycomp(ksusy1+i),1)=rmss(6)
44815 pmas(pycomp(ksusy2+i),1)=rmss(7)
44816 pmas(pycomp(ksusy1+i+1),1)=xarg
44817 pmas(pycomp(ksusy2+i+1),1)=9999d0
44818 140 CONTINUE
44819 IF(imss(8).EQ.1) THEN
44820 rmss(13)=rmss(6)
44821 rmss(14)=rmss(7)
44822 ENDIF
44823
44824C...Alternatively derive masses from SUGRA relations.
44825 ELSEIF(imssm.EQ.2) THEN
44826 rmss(36)=rmss(16)
44827 CALL pyapps
44828C...Or use ISASUSY
44829 ELSEIF(imssm.EQ.12.OR.imssm.EQ.13) THEN
44830 rmss(36)=rmss(16)
44831 CALL pysugi
44832 alfa=rmss(18)
44833 GOTO 170
44834 ELSE
44835 GOTO 170
44836 ENDIF
44837
44838C...Add in extra D-term contributions.
44839 IF(imss(7).EQ.1) THEN
44840 r=0.43d0
44841 dx=rmss(23)
44842 dy=rmss(24)
44843 ds=rmss(25)
44844 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44845 WRITE(mstu(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44846 WRITE(mstu(11),*) 'C IN A U(B-L) THEORY '
44847 WRITE(mstu(11),*) 'C DX = ',dx
44848 WRITE(mstu(11),*) 'C DY = ',dy
44849 WRITE(mstu(11),*) 'C DS = ',ds
44850 WRITE(mstu(11),*) 'C '
44851 dy=r*dy-4d0/33d0*(1d0-r)*dx+(1d0-r)/33d0*ds
44852 WRITE(mstu(11),*) 'C DY AT THE WEAK SCALE = ',dy
44853 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44854 dq2=dy/6d0-dx/3d0-ds/3d0
44855 du2=-2d0*dy/3d0-dx/3d0-ds/3d0
44856 dd2=dy/3d0+dx-2d0*ds/3d0
44857 dl2=-dy/2d0+dx-2d0*ds/3d0
44858 de2=dy-dx/3d0-ds/3d0
44859 dhu2=dy/2d0+2d0*dx/3d0+2d0*ds/3d0
44860 dhd2=-dy/2d0-2d0*dx/3d0+ds
44861 dmu2=(-dy/2d0-2d0/3d0*dx+(cosb**2-2d0*sinb**2/3d0)*ds)
44862 & /abs(cos2b)
44863 dma2 = 2d0*dmu2+dhu2+dhd2
44864 DO 150 i=1,5,2
44865 kc=pycomp(ksusy1+i)
44866 pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
44867 kc=pycomp(ksusy2+i)
44868 pmas(kc,1)=sqrt(pmas(kc,1)**2+dd2)
44869 kc=pycomp(ksusy1+i+1)
44870 pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)
44871 kc=pycomp(ksusy2+i+1)
44872 pmas(kc,1)=sqrt(pmas(kc,1)**2+du2)
44873 150 CONTINUE
44874 DO 160 i=11,15,2
44875 kc=pycomp(ksusy1+i)
44876 pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
44877 kc=pycomp(ksusy2+i)
44878 pmas(kc,1)=sqrt(pmas(kc,1)**2+de2)
44879 kc=pycomp(ksusy1+i+1)
44880 pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)
44881 160 CONTINUE
44882 IF(rmss(4)**2+dmu2.LT.0d0) THEN
44883 WRITE(mstu(11),*) ' MU2 DRIVEN NEGATIVE '
44884 CALL pystop(104)
44885 ENDIF
44886 sgnmu=sign(1d0,rmss(4))
44887 rmss(4)=sgnmu*sqrt(rmss(4)**2+dmu2)
44888 arg=rmss(10)**2*sign(1d0,rmss(10))+dq2
44889 rmss(10)=sign(sqrt(abs(arg)),arg)
44890 arg=rmss(11)**2*sign(1d0,rmss(11))+dd2
44891 rmss(11)=sign(sqrt(abs(arg)),arg)
44892 arg=rmss(12)**2*sign(1d0,rmss(12))+du2
44893 rmss(12)=sign(sqrt(abs(arg)),arg)
44894 arg=rmss(13)**2*sign(1d0,rmss(13))+dl2
44895 rmss(13)=sign(sqrt(abs(arg)),arg)
44896 arg=rmss(14)**2*sign(1d0,rmss(14))+de2
44897 rmss(14)=sign(sqrt(abs(arg)),arg)
44898 IF( rmss(19)**2 + dma2 .LE. 50d0 ) THEN
44899 WRITE(mstu(11),*) ' MA DRIVEN TOO LOW '
44900 CALL pystop(104)
44901 ENDIF
44902 rmss(19)=sqrt(rmss(19)**2+dma2)
44903 rmss(6)=sqrt(rmss(6)**2+dl2)
44904 rmss(7)=sqrt(rmss(7)**2+de2)
44905 WRITE(mstu(11),*) ' MTL = ',rmss(10)
44906 WRITE(mstu(11),*) ' MBR = ',rmss(11)
44907 WRITE(mstu(11),*) ' MTR = ',rmss(12)
44908 WRITE(mstu(11),*) ' SEL = ',rmss(6),rmss(13)
44909 WRITE(mstu(11),*) ' SER = ',rmss(7),rmss(14)
44910 ENDIF
44911
44912C...Fix the third generation sfermions.
44913 CALL pythrg
44914
44915C...Fix the neutralino--chargino--gluino sector.
44916 CALL pyinom
44917
44918C...Fix the Higgs sector.
44919 CALL pyhggm(alfa)
44920
44921C...Choose the Gunion-Haber convention.
44922 alfa=-alfa
44923 rmss(18)=alfa
44924
44925C...Print information on mass parameters.
44926 IF(imssm.EQ.2.AND.mstp(122).GT.0) THEN
44927 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44928 WRITE(mstu(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
44929 WRITE(mstu(11),*) ' M0 = ',rmss(8)
44930 WRITE(mstu(11),*) ' M1/2=',rmss(1)
44931 WRITE(mstu(11),*) ' TANB=',rmss(5)
44932 WRITE(mstu(11),*) ' MU = ',rmss(4)
44933 WRITE(mstu(11),*) ' AT = ',rmss(16)
44934 WRITE(mstu(11),*) ' MA = ',rmss(19)
44935 WRITE(mstu(11),*) ' MTOP=',pmas(6,1)
44936 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44937 ENDIF
44938 IF(imss(20).EQ.1) THEN
44939 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44940 WRITE(mstu(11),*) ' DEBUG MODE '
44941 WRITE(mstu(11),*) ' UMIX = ',umix(1,1),umix(1,2),
44942 & umix(2,1),umix(2,2)
44943 WRITE(mstu(11),*) ' UMIXI = ',umixi(1,1),umixi(1,2),
44944 & umixi(2,1),umixi(2,2)
44945 WRITE(mstu(11),*) ' VMIX = ',vmix(1,1),vmix(1,2),
44946 & vmix(2,1),vmix(2,2)
44947 WRITE(mstu(11),*) ' VMIXI = ',vmixi(1,1),vmixi(1,2),
44948 & vmixi(2,1),vmixi(2,2)
44949 WRITE(mstu(11),*) ' ZMIX = ',(zmix(1,i),i=1,4)
44950 WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(1,i),i=1,4)
44951 WRITE(mstu(11),*) ' ZMIX = ',(zmix(2,i),i=1,4)
44952 WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(2,i),i=1,4)
44953 WRITE(mstu(11),*) ' ZMIX = ',(zmix(3,i),i=1,4)
44954 WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(3,i),i=1,4)
44955 WRITE(mstu(11),*) ' ZMIX = ',(zmix(4,i),i=1,4)
44956 WRITE(mstu(11),*) ' ZMIXI = ',(zmixi(4,i),i=1,4)
44957 WRITE(mstu(11),*) ' ALFA = ',alfa
44958 WRITE(mstu(11),*) ' BETA = ',beta
44959 WRITE(mstu(11),*) ' STOP = ',(sfmix(6,i),i=1,4)
44960 WRITE(mstu(11),*) ' SBOT = ',(sfmix(5,i),i=1,4)
44961 WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44962 ENDIF
44963
44964C...Set up the Higgs couplings - needed here since initialization
44965C...in PYINRE did not yet occur when PYWIDT is called below.
44966 170 al=alfa
44967 be=beta
44968 sina=sin(al)
44969 cosa=cos(al)
44970 cosb=cos(be)
44971 sinb=tanb*cosb
44972 sbma=sin(be-al)
44973 sapb=sin(al+be)
44974 capb=cos(al+be)
44975 cbma=cos(be-al)
44976 c2a=cos(2d0*al)
44977 c2b=cosb**2-sinb**2
44978C...tanb (used for H+)
44979 paru(141)=tanb
44980
44981C...Firstly: h
44982C...Coupling to d-type quarks
44983 paru(161)=sina/cosb
44984C...Coupling to u-type quarks
44985 paru(162)=-cosa/sinb
44986C...Coupling to leptons
44987 paru(163)=paru(161)
44988C...Coupling to Z
44989 paru(164)=sbma
44990C...Coupling to W
44991 paru(165)=paru(164)
44992
44993C...Secondly: H
44994C...Coupling to d-type quarks
44995 paru(171)=-cosa/cosb
44996C...Coupling to u-type quarks
44997 paru(172)=-sina/sinb
44998C...Coupling to leptons
44999 paru(173)=paru(171)
45000C...Coupling to Z
45001 paru(174)=cbma
45002C...Coupling to W
45003 paru(175)=paru(174)
45004C...Coupling to h
45005 IF(imss(4).GE.2) THEN
45006 paru(176)=cos(2d0*al)*cos(be+al)-2d0*sin(2d0*al)*sin(be+al)
45007 ELSE
45008 hhh(3)=hhh(3)+hhh(4)+hhh(5)
45009 paru(176)=-3d0/hhh(1)*(hhh(1)*sina**2*cosb*cosa+
45010 1 hhh(2)*cosa**2*sinb*sina+hhh(3)*(sina**3*sinb+cosa**3*cosb-
45011 2 2d0/3d0*cbma)-hhh(6)*sina*(cosb*c2a+cosa*capb)+
45012 3 hhh(7)*cosa*(sinb*c2a+sina*capb))
45013 ENDIF
45014C...Coupling to H+
45015C...Define later
45016 IF(imss(4).GE.2) THEN
45017 paru(168)=-sbma-cos(2d0*be)*sapb/2d0/(1d0-xw)
45018 ELSE
45019 paru(168)=1d0/hhh(1)*(hhh(1)*sinb**2*cosb*sina-
45020 1 hhh(2)*cosb**2*sinb*cosa-hhh(3)*(sinb**3*cosa-cosb**3*sina)+
45021 2 2d0*hhh(5)*sbma-hhh(6)*sinb*(cosb*sapb+sina*c2b)-
45022 3 hhh(7)*cosb*(cosa*c2b-sinb*sapb)-(hhh(5)-hhh(4))*sbma)
45023 ENDIF
45024C...Coupling to A
45025 IF(imss(4).GE.2) THEN
45026 paru(177)=cos(2d0*be)*cos(be+al)
45027 ELSE
45028 paru(177)=-1d0/hhh(1)*(hhh(1)*sinb**2*cosb*cosa+
45029 1 hhh(2)*cosb**2*sinb*sina+hhh(3)*(sinb**3*sina+cosb**3*cosa)-
45030 2 2d0*hhh(5)*cbma-hhh(6)*sinb*(cosb*capb+cosa*c2b)+
45031 3 hhh(7)*cosb*(sinb*capb+sina*c2b))
45032 ENDIF
45033C...Coupling to H+
45034 IF(imss(4).GE.2) THEN
45035 paru(178)=paru(177)
45036 ELSE
45037 paru(178)=paru(177)-(hhh(5)-hhh(4))/hhh(1)*cbma
45038 ENDIF
45039C...Thirdly, A
45040C...Coupling to d-type quarks
45041 paru(181)=tanb
45042C...Coupling to u-type quarks
45043 paru(182)=1d0/paru(181)
45044C...Coupling to leptons
45045 paru(183)=paru(181)
45046 paru(184)=0d0
45047 paru(185)=0d0
45048C...Coupling to Z h
45049 paru(186)=cos(be-al)
45050C...Coupling to Z H
45051 paru(187)=sin(be-al)
45052 paru(188)=0d0
45053 paru(189)=0d0
45054 paru(190)=0d0
45055
45056C...Finally: H+
45057C...Coupling to W h
45058 paru(195)=cos(be-al)
45059
45060C...Tell that all Higgs couplings have been set.
45061 mstp(4)=1
45062
45063C...Set R-Violating couplings.
45064C...Set lambda couplings to common value or "natural values".
45065 IF ((imss(51).NE.3).AND.(imss(51).NE.0)) THEN
45066 vir3=1d0/(126d0)**3
45067 DO 200 irk=1,3
45068 DO 190 iri=1,3
45069 DO 180 irj=1,3
45070 IF (iri.NE.irj) THEN
45071 IF (iri.LT.irj) THEN
45072 rvlam(iri,irj,irk)=rmss(51)
45073 IF (imss(51).EQ.2) rvlam(iri,irj,irk)=rmss(51)*
45074 & sqrt(pmas(9+2*iri,1)*pmas(9+2*irj,1)*
45075 & pmas(9+2*irk,1)*vir3)
45076 ELSE
45077 rvlam(iri,irj,irk)=-rvlam(irj,iri,irk)
45078 ENDIF
45079 ELSE
45080 rvlam(iri,irj,irk)=0d0
45081 ENDIF
45082 180 CONTINUE
45083 190 CONTINUE
45084 200 CONTINUE
45085 ENDIF
45086C...Set lambda' couplings to common value or "natural values".
45087 IF ((imss(52).NE.3).AND.(imss(52).NE.0)) THEN
45088 vir3=1d0/(126d0)**3
45089 DO 230 iri=1,3
45090 DO 220 irj=1,3
45091 DO 210 irk=1,3
45092 rvlamp(iri,irj,irk)=rmss(52)
45093 IF (imss(52).EQ.2) rvlamp(iri,irj,irk)=rmss(52)*
45094 & sqrt(pmas(9+2*iri,1)*0.5d0*(pmas(2*irj,1)+
45095 & pmas(2*irj-1,1))*pmas(2*irk-1,1)*vir3)
45096 210 CONTINUE
45097 220 CONTINUE
45098 230 CONTINUE
45099 ENDIF
45100C...Set lambda'' couplings to common value or "natural values".
45101 IF ((imss(53).NE.3).AND.(imss(53).NE.0)) THEN
45102 vir3=1d0/(126d0)**3
45103 DO 260 iri=1,3
45104 DO 250 irj=1,3
45105 DO 240 irk=1,3
45106 IF (irj.NE.irk) THEN
45107 IF (irj.LT.irk) THEN
45108 rvlamb(iri,irj,irk)=rmss(53)
45109 IF (imss(53).EQ.2) rvlamb(iri,irj,irk)=
45110 & rmss(53)*sqrt(pmas(2*iri,1)*pmas(2*irj-1,1)*
45111 & pmas(2*irk-1,1)*vir3)
45112 ELSE
45113 rvlamb(iri,irj,irk)=-rvlamb(iri,irk,irj)
45114 ENDIF
45115 ELSE
45116 rvlamb(iri,irj,irk) = 0d0
45117 ENDIF
45118 240 CONTINUE
45119 250 CONTINUE
45120 260 CONTINUE
45121 ENDIF
45122
45123C...Antisymmetrize couplings set by user
45124 IF (imss(51).EQ.3.OR.imss(53).EQ.3) THEN
45125 DO 290 iri=1,3
45126 DO 280 irj=1,3
45127 DO 270 irk=1,3
45128 IF (rvlam(iri,irj,irk).NE.-rvlam(irj,iri,irk)) THEN
45129 rvlam(irj,iri,irk)=-rvlam(iri,irj,irk)
45130 IF (iri.EQ.irj) rvlam(iri,irj,irk)=0d0
45131 ENDIF
45132 IF (rvlamb(iri,irj,irk).NE.-rvlamb(iri,irk,irj)) THEN
45133 rvlamb(iri,irk,irj)=-rvlamb(iri,irj,irk)
45134 IF (irj.EQ.irk) rvlamb(iri,irj,irk)=0d0
45135 ENDIF
45136 270 CONTINUE
45137 280 CONTINUE
45138 290 CONTINUE
45139 ENDIF
45140
45141C...Write spectrum to SLHA file
45142 IF (imss(23).NE.0) THEN
45143 ifail=0
45144 CALL pyslha(3,0,ifail)
45145 ENDIF
45146
45147C...Second part of routine: set decay modes and branching ratios.
45148
45149C...Allow chi10 -> gravitino + gamma or not.
45150 kc=pycomp(ksusy1+39)
45151 IF( imss(11) .NE. 0 ) THEN
45152 pmas(kc,1)=rmss(21)/1d9
45153 pmas(kc,2)=0d0
45154 irprty=0
45155 WRITE(mstu(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45156 ELSE IF (imss(51).GE.1.OR.imss(52).GE.1.OR.imss(53).GE.1) THEN
45157 irprty=0
45158 IF (imss(51).GE.1) WRITE(mstu(11),*)
45159 & ' ALLOWING SUSY LLE DECAYS'
45160 IF (imss(52).GE.1) WRITE(mstu(11),*)
45161 & ' ALLOWING SUSY LQD DECAYS'
45162 IF (imss(53).GE.1) WRITE(mstu(11),*)
45163 & ' ALLOWING SUSY UDD DECAYS'
45164 IF (imss(53).GE.1.AND.imss(52).GE.1) WRITE(mstu(11),*)
45165 & ' --- Warning: R-Violating couplings possibly',
45166 & ' incompatible with proton decay'
45167 ELSE
45168 pmas(kc,1)=9999d0
45169 irprty=1
45170 ENDIF
45171
45172C...Loop over sparticle and Higgs species.
45173 pmchi1=pmas(pycomp(ksusy1+22),1)
45174C...Find the LSP or NLSP for a gravitino LSP
45175 ilsp=0
45176 pmlsp=1d20
45177 DO 300 i=1,36
45178 kf=kfsusy(i)
45179 IF(kf.EQ.1000039) GOTO 300
45180 kc=pycomp(kf)
45181 IF(pmas(kc,1).LT.pmlsp) THEN
45182 ilsp=i
45183 pmlsp=pmas(kc,1)
45184 ENDIF
45185 300 CONTINUE
45186 DO 370 i=1,50
45187 IF (i.GT.39.AND.imss(13).NE.1) GOTO 370
45188 kf=kfsusy(i)
45189 IF (kf.EQ.0) GOTO 370
45190 kc=pycomp(kf)
45191 lknt=0
45192
45193C...Check if there are any decays listed for this sparticle
45194C...in a file
45195 IF (imss(22).NE.0.OR.mstp(161).NE.0) THEN
45196 ifail=0
45197 CALL pyslha(2,kf,ifail)
45198 IF (ifail.EQ.0.OR.kf.EQ.6.OR.kf.EQ.24) GOTO 370
45199 ELSEIF (i.GE.37) THEN
45200 GOTO 370
45201 ENDIF
45202
45203C...Sfermion decays.
45204 IF(i.LE.24) THEN
45205C...First check to see if sneutrino is lighter than chi10.
45206 IF((i.EQ.15.OR.i.EQ.19.OR.i.EQ.23).AND.
45207 & pmas(kc,1).LT.pmchi1) THEN
45208 ELSE
45209 CALL pysfdc(kf,xlam,idlam,lknt)
45210 ENDIF
45211
45212C...Gluino decays.
45213 ELSEIF(i.EQ.25) THEN
45214 CALL pyglui(kf,xlam,idlam,lknt)
45215 IF(i.EQ.ilsp.AND.irprty.EQ.1) lknt=0
45216
45217C...Neutralino decays.
45218 ELSEIF(i.GE.26.AND.i.LE.29) THEN
45219 CALL pynjdc(kf,xlam,idlam,lknt)
45220C...chi10 stable or chi10 -> gravitino + gamma.
45221 IF(i.EQ.26.AND.irprty.EQ.1) THEN
45222 pmas(kc,2)=1d-6
45223 mdcy(kc,1)=0
45224 mwid(kc)=0
45225 ENDIF
45226
45227C...Chargino decays.
45228 ELSEIF(i.GE.30.AND.i.LE.31) THEN
45229 CALL pycjdc(kf,xlam,idlam,lknt)
45230
45231C...Gravitino is stable.
45232 ELSEIF(i.EQ.32) THEN
45233 mdcy(kc,1)=0
45234 mwid(kc)=0
45235
45236C...Higgs decays.
45237 ELSEIF(i.GE.33.AND.i.LE.36) THEN
45238C...Calculate decays to non-SUSY particles.
45239 CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)
45240 lknt=0
45241 DO 310 i1=0,100
45242 xlam(i1)=0d0
45243 310 CONTINUE
45244 DO 330 i1=1,mdcy(kc,3)
45245 k1=mdcy(kc,2)+i1-1
45246 IF(iabs(kfdp(k1,1)).GT.ksusy1.OR.
45247 & iabs(kfdp(k1,2)).GT.ksusy1) GOTO 330
45248 xlam(i1)=wdtp(i1)
45249 xlam(0)=xlam(0)+xlam(i1)
45250 DO 320 j1=1,3
45251 idlam(i1,j1)=kfdp(k1,j1)
45252 320 CONTINUE
45253 lknt=lknt+1
45254 330 CONTINUE
45255C...Add the decays to SUSY particles.
45256 CALL pyhext(kf,xlam,idlam,lknt)
45257 ENDIF
45258C...Zero the branching ratios for use in loop mode
45259C...thanks to K. Matchev (FNAL)
45260 DO 340 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
45261 brat(idc)=0d0
45262 340 CONTINUE
45263
45264C...Set stable particles.
45265 IF(lknt.EQ.0) THEN
45266 mdcy(kc,1)=0
45267 mwid(kc)=0
45268 pmas(kc,2)=1d-6
45269 pmas(kc,3)=1d-5
45270 pmas(kc,4)=0d0
45271
45272C...Store branching ratios in the standard tables.
45273 ELSE
45274 idc=mdcy(kc,2)+mdcy(kc,3)-1
45275 delm=1d6
45276 DO 360 il=1,lknt
45277 idcsv=idc
45278 350 idc=idc+1
45279 brat(idc)=0d0
45280 IF(idc.EQ.mdcy(kc,2)+mdcy(kc,3)) idc=mdcy(kc,2)
45281 IF(idlam(il,1).EQ.kfdp(idc,1).AND.idlam(il,2).EQ.
45282 & kfdp(idc,2).AND.idlam(il,3).EQ.kfdp(idc,3)) THEN
45283 brat(idc)=xlam(il)/xlam(0)
45284 xmdif=pmas(kc,1)
45285 IF(mdme(idc,1).GE.1) THEN
45286 xmdif=xmdif-pmas(pycomp(kfdp(idc,1)),1)-
45287 & pmas(pycomp(kfdp(idc,2)),1)
45288 IF(kfdp(idc,3).NE.0) xmdif=xmdif-
45289 & pmas(pycomp(kfdp(idc,3)),1)
45290 ENDIF
45291 IF(i.LE.32) THEN
45292 IF(xmdif.GE.0d0) THEN
45293 delm=min(delm,xmdif)
45294 ELSE
45295 WRITE(mstu(11),*) ' ERROR WITH DELM ',delm,xmdif
45296 WRITE(mstu(11),*) ' KF = ',kf
45297 WRITE(mstu(11),*) ' KF(decay) = ',(kfdp(idc,j),j=1,3)
45298 ENDIF
45299 ENDIF
45300 GOTO 360
45301 ELSEIF(idc.EQ.idcsv) THEN
45302 WRITE(mstu(11),*) ' Error in PYMSIN: SUSY decay ',
45303 & 'channel not recognized:'
45304 WRITE(mstu(11),*) kf,' -> ',(idlam(il,j),j=1,3)
45305 GOTO 360
45306 ELSE
45307 GOTO 350
45308 ENDIF
45309 360 CONTINUE
45310
45311C...Store width, cutoff and lifetime.
45312 pmas(kc,2)=xlam(0)
45313 IF(pmas(kc,2).LT.0.1d0*delm) THEN
45314 pmas(kc,3)=pmas(kc,2)*10d0
45315 ELSE
45316 pmas(kc,3)=0.95d0*delm
45317 ENDIF
45318 IF(pmas(kc,2).NE.0d0) THEN
45319 pmas(kc,4)=paru(3)/pmas(kc,2)*1d-12
45320 ENDIF
45321C...Write decays to SLHA file
45322 IF (imss(24).NE.0) THEN
45323 ifail=0
45324 CALL pyslha(4,kf,ifail)
45325 ENDIF
45326
45327 ENDIF
45328 370 CONTINUE
45329
45330 RETURN
45331 END
45332C*********************************************************************
45333
45334C...PYSLHA
45335C...Read/write spectrum or decay data from SLHA standard file(s).
45336C...P. Skands
45337
45338C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45339C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45340C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45341C... (KFORIG=0 : read all decay tables)
45342C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45343C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45344C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45345C... (KFORIG=0 : read all MASS entries)
45346
45347 SUBROUTINE pyslha(MUPDA,KFORIG,IRETRN)
45348
45349C...Double precision and integer declarations.
45350 IMPLICIT DOUBLE PRECISION(a-h, o-z)
45351 IMPLICIT INTEGER(I-N)
45352 INTEGER PYK,PYCHGE,PYCOMP
45353 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
45354 &kexcit=4000000,kdimen=5000000)
45355C...Commonblocks.
45356 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
45357 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
45358 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
45359 common/pydat4/chaf(500,2)
45360 CHARACTER CHAF*16
45361 common/pypars/mstp(200),parp(200),msti(200),pari(200)
45362 CHARACTER*40 ISAVER,VISAJE
45363 common/pyint4/mwid(500),wids(500,5)
45364 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pypars/,/pyint4/
45365C...SUSY blocks
45366 common/pymssm/imss(0:99),rmss(0:99)
45367 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
45368 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
45369 common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
45370 SAVE /pymssm/,/pyssmt/,/pymsrv/
45371
45372C...Local arrays, character variables and data.
45373 common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
45374 & au(3,3),ad(3,3),ae(3,3)
45375 common/pylh3c/cpro(2),cver(2)
45376C...The common block of new states (QNUMBERS / PARTICLE)
45377 common/pyqnum/nqnum,nqdum,kqnum(500,0:9)
45378C...- NQNUM : Number of QNUMBERS blocks that have been read in
45379C...- KQNUM(I,0) : KF of new state
45380C...- KQNUM(I,1) : 3 times electric charge
45381C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45382C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45383C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45384C...- KQNUM(I,5:9) : space available for further quantum numbers
45385 dimension mmod(100),mspc(100),kfdec(100)
45386 SAVE /pylh3p/,/pylh3c/,/pyqnum/,mmod,mspc,kfdec
45387C...MMOD: flags to set for each block read in.
45388C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45389C...MSPC: Flags to set for each block read in.
45390C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45391C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45392C...11: AD 12: AE 13: YU 14: YD 15: YE
45393C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45394 CHARACTER CPRO*12,CVER*12,CHNLIN*6
45395 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45396 CHARACTER CHINL*120,CHKF*9,CHTMP*16
45397 INTEGER VERBOS
45398 SAVE verbos
45399C...Date of last Change
45400 parameter(doc='23 Jan 2009')
45401C...Local arrays and initial values
45402 dimension idc(5),kfsusy(50)
45403 SAVE kfsusy
45404 DATA nqnum /0/
45405 DATA ndecay /0/
45406 DATA verbos /1/
45407 DATA nhello /0/
45408 DATA mlhef /0/
45409 DATA mlhefd /0/
45410 DATA kfsusy/
45411 &1000001,1000002,1000003,1000004,1000005,1000006,
45412 &2000001,2000002,2000003,2000004,2000005,2000006,
45413 &1000011,1000012,1000013,1000014,1000015,1000016,
45414 &2000011,2000012,2000013,2000014,2000015,2000016,
45415 &1000021,1000022,1000023,1000025,1000035,1000024,
45416 &1000037,1000039, 25, 35, 36, 37,
45417 & 6, 24, 45, 46,1000045, 9*0/
45418 DATA kfdec/100*0/
45419 rmfun(ip)=pmas(pycomp(ip),1)
45420
45421C...Shorthand for spectrum and decay table unit numbers
45422 imss21=imss(21)
45423 imss22=imss(22)
45424
45425C...Default for LHEF input: read header information
45426 IF (imss21.EQ.0.AND.mstp(161).NE.0) imss21=mstp(161)
45427 IF (imss22.EQ.0.AND.mstp(161).NE.0) imss22=mstp(161)
45428 IF (imss21.EQ.mstp(161)) mlhef=1
45429 IF (imss22.EQ.mstp(161)) mlhefd=1
45430
45431C...Hello World
45432 IF (nhello.EQ.0) THEN
45433 IF ((mlhef.NE.1.AND.mlhefd.NE.1).OR.(imss(1).NE.0)) THEN
45434 WRITE(mstu(11),5000) doc
45435 nhello=1
45436 ENDIF
45437 ENDIF
45438
45439C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45440C...+MUPDA).
45441 lfn=imss21
45442 IF (mupda.EQ.2) lfn=imss22
45443 IF (mupda.EQ.3) lfn=imss(23)
45444 IF (mupda.EQ.4) lfn=imss(24)
45445C...Flag that we have not yet found whatever we were asked to find.
45446 iretrn=1
45447
45448C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45449 IF (lfn.EQ.0) THEN
45450 WRITE(mstu(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45451 GOTO 9999
45452 ENDIF
45453
45454C...If reading LHEF header, start by rewinding file
45455 IF (mlhef.EQ.1.OR.mlhefd.EQ.1) rewind(lfn)
45456
45457C...If told to read spectrum, first zero all previous information.
45458 IF (mupda.EQ.1) THEN
45459C...Zero all block read flags
45460 DO 100 m=1,100
45461 mmod(m)=0
45462 mspc(m)=0
45463 100 CONTINUE
45464C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45465 DO 110 isusy=1,36
45466 kc=pycomp(kfsusy(isusy))
45467 pmas(kc,1)=0d0
45468 110 CONTINUE
45469C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45470 DO 130 j=1,4
45471 sfmix(5,j) =0d0
45472 sfmix(6,j) =0d0
45473 sfmix(15,j)=0d0
45474 DO 120 l=1,4
45475 zmix(l,j) =0d0
45476 zmixi(l,j)=0d0
45477 IF (j.LE.2.AND.l.LE.2) THEN
45478 umix(l,j) =0d0
45479 umixi(l,j)=0d0
45480 vmix(l,j) =0d0
45481 vmixi(l,j)=0d0
45482 ENDIF
45483 120 CONTINUE
45484C...Zero signed masses.
45485 smz(j)=0d0
45486 IF (j.LE.2) smw(j)=0d0
45487 130 CONTINUE
45488
45489C...If reading decays, reset PYTHIA decay counters.
45490 ELSEIF (mupda.EQ.2) THEN
45491C...Check if DECAY for this KF already read
45492 IF (kforig.NE.0) THEN
45493 DO 140 idec=1,ndecay
45494 IF (kforig.EQ.kfdec(idec)) THEN
45495 iretrn=0
45496 RETURN
45497 ENDIF
45498 140 CONTINUE
45499 ENDIF
45500 kcc=100
45501 ndc=0
45502 brsum=0d0
45503 DO 150 kc=1,mstu(6)
45504 IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc
45505 ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)
45506 150 CONTINUE
45507 ELSEIF (mupda.EQ.5) THEN
45508C...Zero block read flags
45509 DO 160 m=1,100
45510 mspc(m)=0
45511 160 CONTINUE
45512 ENDIF
45513
45514C............READ
45515C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45516 IF(mupda.EQ.0.OR.mupda.EQ.1.OR.mupda.EQ.2.OR.mupda.EQ.5) THEN
45517C...Initialize program and version strings
45518 IF(mupda.EQ.1.OR.mupda.EQ.2) THEN
45519 cpro(mupda)=' '
45520 cver(mupda)=' '
45521 ENDIF
45522
45523C...Initialize read loop
45524 merr=0
45525 nline=0
45526 chblck=' '
45527C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45528 170 chinl=' '
45529 READ(lfn,'(A120)',END=400) chinl
45530C...Count which line number we're at.
45531 nline=nline+1
45532 WRITE(chnlin,'(I6)') nline
45533
45534C...Skip comment and empty lines without processing.
45535 IF (chinl(1:1).EQ.'#'.OR.chinl.EQ.' ') GOTO 170
45536
45537C...We assume all upper case below. Rewrite CHINL to all upper case.
45538 inl=0
45539 igood=0
45540 180 inl=inl+1
45541 IF (chinl(inl:inl).NE.'#') THEN
45542 DO 190 ich=97,122
45543 IF (char(ich).EQ.chinl(inl:inl)) chinl(inl:inl)=char(ich-32)
45544 190 CONTINUE
45545C...Extra safety. Chek for sensible input on line
45546 IF (igood.EQ.0) THEN
45547 DO 200 ich=48,90
45548 IF (char(ich).EQ.chinl(inl:inl)) igood=1
45549 200 CONTINUE
45550 ENDIF
45551 IF (inl.LT.120) GOTO 180
45552 ENDIF
45553 IF (igood.EQ.0) GOTO 170
45554
45555C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45556 DO 210 i1=1,10
45557 IF (chinl(i1:i1+5).EQ.'</SLHA'
45558 & .OR.chinl(i1:i1+5).EQ.'<EVENT'
45559 & .OR.chinl(i1:i1+4).EQ.'<INIT') THEN
45560 rewind(lfn)
45561 GOTO 400
45562 ENDIF
45563 210 CONTINUE
45564
45565C...Check for BLOCK begin statement (spectrum).
45566 IF (chinl(1:5).EQ.'BLOCK') THEN
45567 merr=0
45568 READ(chinl,'(A6,A)',err=580) chdum,chblck
45569C...Check if another of this type of block was already read.
45570C...(logarithmic interpolation not yet implemented, so duplicates always
45571C...give errors)
45572 IF (chblck(1:6).EQ.'MODSEL'.AND.mmod(1).NE.0) merr=7
45573 IF (chblck(1:6).EQ.'MINPAR'.AND.mmod(2).NE.0) merr=7
45574 IF (chblck(1:6).EQ.'EXTPAR'.AND.mmod(3).NE.0) merr=7
45575 IF (chblck(1:8).EQ.'SMINPUTS'.AND.mmod(4).NE.0) merr=7
45576 IF (chblck(1:4).EQ.'MASS'.AND.mspc(1).NE.0) merr=7
45577 IF (chblck(1:4).EQ.'NMIX'.AND.mspc(2).NE.0) merr=7
45578 IF (chblck(1:4).EQ.'UMIX'.AND.mspc(3).NE.0) merr=7
45579 IF (chblck(1:4).EQ.'VMIX'.AND.mspc(4).NE.0) merr=7
45580 IF (chblck(1:7).EQ.'SBOTMIX'.AND.mspc(5).NE.0) merr=7
45581 IF (chblck(1:7).EQ.'STOPMIX'.AND.mspc(6).NE.0) merr=7
45582 IF (chblck(1:7).EQ.'STAUMIX'.AND.mspc(7).NE.0) merr=7
45583 IF (chblck(1:4).EQ.'HMIX'.AND.mspc(8).NE.0) merr=7
45584 IF (chblck(1:5).EQ.'ALPHA'.AND.mspc(17).NE.0) merr=7
45585 IF (chblck(1:5).EQ.'AU'.AND.mspc(10).NE.0) merr=7
45586 IF (chblck(1:5).EQ.'AD'.AND.mspc(11).NE.0) merr=7
45587 IF (chblck(1:5).EQ.'AE'.AND.mspc(12).NE.0) merr=7
45588 IF (chblck(1:5).EQ.'MSOFT'.AND.mspc(18).NE.0) merr=7
45589C...Check for new particles
45590 IF (chblck(1:8).EQ.'QNUMBERS'.OR.chblck(1:8).EQ.'PARTICLE')
45591 & THEN
45592 mspc(19)=mspc(19)+1
45593C...Read PDG code
45594 READ(chblck(9:60),*) kfq
45595
45596 DO 220 mq=1,nqnum
45597 IF (kqnum(mq,0).EQ.kfq) THEN
45598 merr=17
45599 GOTO 380
45600 ENDIF
45601 220 CONTINUE
45602 IF (nhello.EQ.0) THEN
45603 WRITE(mstu(11),5000) doc
45604 nhello=1
45605 ENDIF
45606 WRITE(mstu(11),'(A,I9,A,F12.3)')
45607 & ' * (PYSLHA:) Reading '//chblck(1:8)//
45608 & ' for KF =',kfq
45609 nqnum=nqnum+1
45610 kqnum(nqnum,0)=kfq
45611 mspc(19)=mspc(19)+1
45612 kcq=pycomp(kfq)
45613C...Only read in new codes (also OK to overwrite if KF > 3000000)
45614 IF (kcq.EQ.0.OR.iabs(kfq).GE.3000000) THEN
45615 IF (kcq.EQ.0) THEN
45616 DO 230 kct=100,mstu(6)
45617 IF(kchg(kct,4).GT.100) kcq=kct
45618 230 CONTINUE
45619 kcq=kcq+1
45620 ENDIF
45621 kcc=kcq
45622 kchg(kcq,4)=kfq
45623C...First write PDG code as name
45624 WRITE(chtmp,*) kfq
45625 WRITE(chtmp,'(A)') chtmp(2:10)
45626C...Then look for real name
45627 ibeg=9
45628 240 ibeg=ibeg+1
45629 IF (chblck(ibeg:ibeg).NE.'#'.AND.ibeg.LT.59) GOTO 240
45630 250 ibeg=ibeg+1
45631 IF (chblck(ibeg:ibeg).EQ.' '.AND.ibeg.LT.59) GOTO 250
45632 iend=ibeg-1
45633 260 iend=iend+1
45634 IF (chblck(iend+1:iend+1).NE.' '.AND.iend.LT.59) GOTO 260
45635 IF (iend.LT.59) THEN
45636 READ(chblck(ibeg:iend),'(A)',err=270) chdum
45637 IF (chdum.NE.' ') chtmp=chdum
45638 ENDIF
45639 270 READ(chtmp,'(A)') chaf(kcq,1)
45640 mstu(20)=0
45641C...Set stable for now
45642 pmas(kcq,2)=1d-6
45643 mwid(kcq)=0
45644 mdcy(kcq,1)=0
45645 mdcy(kcq,2)=0
45646 mdcy(kcq,3)=0
45647 ELSE
45648 WRITE(mstu(11),*)
45649 & '* (PYSLHA:) KF =',kfq,' already exists: ',
45650 & chaf(kcq,1), '. Entry ignored.'
45651 merr=7
45652 ENDIF
45653 ENDIF
45654C...Finalize this line and read next.
45655 GOTO 380
45656C...Check for DECAY begin statement (decays).
45657 ELSEIF (chinl(1:3).EQ.'DEC') THEN
45658 merr=0
45659 brsum=0d0
45660 chblck='DECAY'
45661C...Read KF code and WIDTH
45662 mpsign=1
45663 READ(chinl(7:inl),*,err=590) kf, width
45664 IF (kf.LE.0) THEN
45665 kf=-kf
45666 mpsign=-1
45667 ENDIF
45668C...If this is not the KF we're looking for...
45669 IF ((kforig.NE.0.AND.kf.NE.kforig).OR.mupda.NE.2) THEN
45670C...Set block skip flag and read next line.
45671 merr=16
45672 GOTO 380
45673 ELSE
45674C...Check whether decay table for this particle already read in
45675 DO 280 idecay=1,ndecay
45676 IF (kfdec(idecay).EQ.kf) THEN
45677 WRITE(mstu(11),'(A,A,I9,A,A6,A)')
45678 & ' * (PYSLHA:) Ignoring DECAY table ',
45679 & 'for KF =',kf,' on line ',chnlin,
45680 & ' (duplicate)'
45681 merr=16
45682 GOTO 380
45683 ENDIF
45684 280 CONTINUE
45685 ENDIF
45686
45687C...Determine PYTHIA KC code of particle
45688 kcrep=0
45689 IF(kf.LE.100) THEN
45690 kcrep=kf
45691 ELSE
45692 DO 290 kcr=101,kcc
45693 IF(kchg(kcr,4).EQ.kf) kcrep=kcr
45694 290 CONTINUE
45695 ENDIF
45696 kc=kcrep
45697 IF (kcrep.NE.0) THEN
45698C...Particle is already known. Do not overwrite low-mass SM particles,
45699C...since this could give problems at hadronization / hadron decay stage.
45700 IF (iabs(kf).LT.1000000.AND.pmas(kc,1).LT.20d0) THEN
45701C...Set block skip flag and read next line
45702 WRITE(mstu(11),'(A,I9,A,F12.3)')
45703 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45704 & kf, ' (SLHA read-in not allowed)'
45705 merr=16
45706 GOTO 380
45707 ENDIF
45708 ELSE
45709C... Add new particle. Actually, this should not happen.
45710C... New particles should be added already when reading the spectrum
45711C... information, so go under previously stable category.
45712 kcc=kcc+1
45713 kc=kcc
45714 ENDIF
45715
45716 IF (width.LE.0d0) THEN
45717C...Stable (i.e. LSP)
45718 WRITE(mstu(11),'(A,I9,A,A)')
45719 & '* (PYSLHA:) Reading SLHA stable particle KF =',
45720 & kf,', ',chaf(kcrep,1)(1:16)
45721 IF (width.LT.0d0) THEN
45722 CALL pyerrm(19,'(PYSLHA:) Negative width forced to'//
45723 & ' zero !')
45724 width=0d0
45725 ENDIF
45726 pmas(kc,2)=1d-6
45727 mwid(kc)=0
45728 mdcy(kc,1)=0
45729C...Ignore any decay lines that may be present for this KF
45730 merr=16
45731 mdcy(kc,2)=0
45732 mdcy(kc,3)=0
45733C...Return ok
45734 iretrn=0
45735 ENDIF
45736C...Finalize and start reading in decay modes.
45737 GOTO 380
45738 ELSEIF (mod(merr,10).GE.6) THEN
45739C...If ignore block flag set, skip directly to next line.
45740 GOTO 170
45741 ENDIF
45742
45743C...READ SPECTRUM
45744 IF (mupda.EQ.0.AND.merr.EQ.0) THEN
45745 IF (chblck(1:8).EQ.'QNUMBERS'.OR.chblck(1:8).EQ.'PARTICLE')
45746 & THEN
45747 READ(chinl,*) indx, ival
45748 IF (indx.GE.1.AND.indx.LE.9) kqnum(nqnum,indx)=ival
45749 IF (indx.EQ.1) kchg(kcq,1)=ival
45750 IF (indx.EQ.3) kchg(kcq,2)=0
45751 IF (indx.EQ.3.AND.ival.EQ.3) kchg(kcq,2)=1
45752 IF (indx.EQ.3.AND.ival.EQ.-3) kchg(kcq,2)=-1
45753 IF (indx.EQ.3.AND.ival.EQ.8) kchg(kcq,2)=2
45754 IF (indx.EQ.4) THEN
45755 kchg(kcq,3)=ival
45756 IF (ival.EQ.1) THEN
45757 chtmp=chaf(kcq,1)
45758 IF (chtmp.EQ.' ') THEN
45759 WRITE(chaf(kcq,1),*) kchg(kcq,4)
45760 WRITE(chaf(kcq,2),*) -kchg(kcq,4)
45761 ELSE
45762 ilast=17
45763 300 ilast=ilast-1
45764 IF (chtmp(ilast:ilast).EQ.' ') GOTO 300
45765 IF (chtmp(ilast:ilast).EQ.'+') THEN
45766 chtmp(ilast:ilast)='-'
45767 ELSE
45768 chtmp(ilast+1:min(16,ilast+4))='bar'
45769 ENDIF
45770 chaf(kcq,2)=chtmp
45771 ENDIF
45772 ENDIF
45773 ENDIF
45774 ELSE
45775 merr=8
45776 ENDIF
45777 ELSEIF ((mupda.EQ.1.OR.mupda.EQ.5).AND.merr.EQ.0) THEN
45778C...MASS: Mass spectrum
45779 IF (chblck(1:4).EQ.'MASS') THEN
45780 READ(chinl,*) kf, val
45781 merr=1
45782 kc=0
45783 IF (mupda.EQ.1.OR.kf.EQ.kforig.OR.kforig.EQ.0) THEN
45784C...Read in masses for almost anything
45785 merr=0
45786 kc=pycomp(kf)
45787 IF (kc.NE.0) THEN
45788C...Don't read in masses for special code particles
45789 IF (iabs(kf).GE.80.AND.iabs(kf).LT.100) THEN
45790 WRITE(mstu(11),'(A,I9,A,F12.3)')
45791 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45792 & kf, ' (KF reserved by PYTHIA)'
45793 GOTO 170
45794 ENDIF
45795C...Be careful with light SM particles / hadrons
45796 IF (pmas(kc,1).LE.20d0) THEN
45797 IF (iabs(kf).LE.22) THEN
45798 WRITE(mstu(11),'(A,I9,A,F12.3)')
45799 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45800 & kf, ' (SLHA read-in not allowed)'
45801
45802 GOTO 170
45803 ELSEIF (iabs(kf).GE.100.AND.iabs(kf).LT.1000000) THEN
45804 WRITE(mstu(11),'(A,I9,A,F12.3)')
45805 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45806 & kf, ' (SLHA read-in not allowed)'
45807 GOTO 170
45808 ENDIF
45809 ENDIF
45810 mspc(1)=mspc(1)+1
45811 pmas(kc,1) = abs(val)
45812 IF (mupda.EQ.5.AND.imss(1).EQ.0) THEN
45813 WRITE(mstu(11),'(A,I9,A,F12.3)')
45814 & ' * (PYSLHA:) Reading MASS entry for KF =',
45815 & kf, ', pole mass =', val
45816 iretrn=0
45817 ENDIF
45818C...Check Z, W and top masses
45819 IF (kf.EQ.23.AND.abs(pmas(pycomp(23),1)-91.2d0).GT.1d0)
45820 & THEN
45821 WRITE(chtmp,*) pmas(pycomp(23),1)
45822 CALL pyerrm(9,'(PYSLHA:) Note Z boson mass, M ='
45823 & //chtmp)
45824 ENDIF
45825 IF (kf.EQ.24.AND.abs(pmas(pycomp(24),1)-80.4d0).GT.1d0)
45826 & THEN
45827 WRITE(chtmp,*) pmas(pycomp(23),1)
45828 CALL pyerrm(9,'(PYSLHA:) Note W boson mass, M ='
45829 & //chtmp)
45830 ENDIF
45831 IF (kf.EQ.6.AND.abs(pmas(pycomp(6),1)-175d0).GT.25d0)
45832 & THEN
45833 WRITE(chtmp,*) pmas(pycomp(6),1)
45834 CALL pyerrm(9,'(PYSLHA:) Note top quark mass, M ='
45835 & //chtmp//'GeV')
45836 ENDIF
45837C... Signed masses
45838 IF (kf.EQ.1000021.AND.mspc(18).EQ.0) rmss(3)=val
45839 IF (kf.EQ.1000022) smz(1)=val
45840 IF (kf.EQ.1000023) smz(2)=val
45841 IF (kf.EQ.1000025) smz(3)=val
45842 IF (kf.EQ.1000035) smz(4)=val
45843 IF (kf.EQ.1000024) smw(1)=val
45844 IF (kf.EQ.1000037) smw(2)=val
45845 ENDIF
45846 ELSEIF (mupda.EQ.5) THEN
45847 merr=0
45848 ENDIF
45849C... MODSEL: Model selection and global switches
45850 ELSEIF (chblck(1:6).EQ.'MODSEL') THEN
45851 READ(chinl,*) indx, ival
45852 IF (indx.LE.200.AND.indx.GT.0) THEN
45853 IF (imss(1).EQ.0) imss(1)=11
45854 modsel(indx)=ival
45855 mmod(1)=mmod(1)+1
45856 IF (indx.EQ.3.AND.ival.EQ.1.AND.pycomp(1000045).EQ.0) THEN
45857C... Switch on NMSSM
45858 WRITE(mstu(11),*) '* (PYSLHA:) switching on NMSSM'
45859 imss(13)=max(1,imss(13))
45860C... Add NMSSM states if not already done
45861
45862 kfn=25
45863 kcn=kfn
45864 chaf(kcn,1)='h_10'
45865 chaf(kcn,2)=' '
45866
45867 kfn=35
45868 kcn=kfn
45869 chaf(kcn,1)='h_20'
45870 chaf(kcn,2)=' '
45871
45872 kfn=45
45873 kcn=kfn
45874 chaf(kcn,1)='h_30'
45875 chaf(kcn,2)=' '
45876
45877 kfn=36
45878 kcn=kfn
45879 chaf(kcn,1)='A_10'
45880 chaf(kcn,2)=' '
45881
45882 kfn=46
45883 kcn=kfn
45884 chaf(kcn,1)='A_20'
45885 chaf(kcn,2)=' '
45886
45887 kfn=1000045
45888 kcn=pycomp(kfn)
45889 IF (kcn.EQ.0) THEN
45890 DO 310 kct=100,mstu(6)
45891 IF(kchg(kct,4).GT.100) kcn=kct
45892 310 CONTINUE
45893 kcn=kcn+1
45894 kchg(kcn,4)=kfn
45895 mstu(20)=0
45896 ENDIF
45897C... Set stable for now
45898 pmas(kcn,2)=1d-6
45899 mwid(kcn)=0
45900 mdcy(kcn,1)=0
45901 mdcy(kcn,2)=0
45902 mdcy(kcn,3)=0
45903 chaf(kcn,1)='~chi_50'
45904 chaf(kcn,2)=' '
45905 ENDIF
45906 ELSE
45907 merr=1
45908 ENDIF
45909 ELSEIF (mupda.EQ.5) THEN
45910C...If MUPDA = 5, skip all except MASS, return if MODSEL
45911 merr=8
45912 ELSEIF (chblck(1:8).EQ.'QNUMBERS'.OR.
45913 & chblck(1:8).EQ.'PARTICLE') THEN
45914C...Don't print a warning for QNUMBERS when reading spectrum
45915 merr=8
45916C...MINPAR: Minimal model parameters
45917 ELSEIF (chblck(1:6).EQ.'MINPAR') THEN
45918 READ(chinl,*) indx, val
45919 IF (indx.LE.100.AND.indx.GT.0) THEN
45920 parmin(indx)=val
45921 mmod(2)=mmod(2)+1
45922 ELSE
45923 merr=1
45924 ENDIF
45925 IF (mmod(3).NE.0) THEN
45926 WRITE(mstu(11),*)
45927 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
45928 merr=1
45929 ENDIF
45930C...tan(beta)
45931 IF (indx.EQ.3) rmss(5)=val
45932C...EXTPAR: non-minimal model parameters.
45933 ELSEIF (chblck(1:6).EQ.'EXTPAR') THEN
45934 IF (mmod(1).NE.0) THEN
45935 READ(chinl,*) indx, val
45936 IF (indx.LE.200.AND.indx.GT.0) THEN
45937 parext(indx)=val
45938 mmod(3)=mmod(3)+1
45939 ELSE
45940 merr=1
45941 ENDIF
45942 ELSE
45943 WRITE(mstu(11),*)
45944 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
45945 merr=1
45946 ENDIF
45947C...tan(beta)
45948 IF (indx.EQ.25) rmss(5)=val
45949 ELSEIF (chblck(1:8).EQ.'SMINPUTS') THEN
45950 READ(chinl,*) indx, val
45951 IF (indx.LE.3.OR.indx.EQ.5.OR.indx.GE.7) THEN
45952 merr=1
45953 ELSEIF (indx.EQ.4) THEN
45954 pmas(pycomp(23),1)=val
45955 ELSEIF (indx.EQ.6) THEN
45956 pmas(pycomp(6),1)=val
45957 ENDIF
45958 ELSEIF (chblck(1:4).EQ.'NMIX'.OR.chblck(1:4).EQ.'VMIX'.or
45959 $ .chblck(1:4).EQ.'UMIX'.OR.chblck(1:7).EQ.'STOPMIX'.or
45960 $ .chblck(1:7).EQ.'SBOTMIX'.OR.chblck(1:7).EQ.'STAUMIX')
45961 $ THEN
45962C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
45963 im=0
45964 IF (chblck(5:6).EQ.'IM') im=1
45965 320 READ(chinl,*) indx1, indx2, val
45966 IF (chblck(1:1).EQ.'N'.AND.indx1.LE.4.AND.indx2.LE.4) THEN
45967 IF (im.EQ.0) zmix(indx1,indx2) = val
45968 IF (im.EQ.1) zmixi(indx1,indx2)= val
45969 mspc(2)=mspc(2)+1
45970 ELSEIF (chblck(1:1).EQ.'U') THEN
45971 IF (im.EQ.0) umix(indx1,indx2) = val
45972 IF (im.EQ.1) umixi(indx1,indx2)= val
45973 mspc(3)=mspc(3)+1
45974 ELSEIF (chblck(1:1).EQ.'V') THEN
45975 IF (im.EQ.0) vmix(indx1,indx2) = val
45976 IF (im.EQ.1) vmixi(indx1,indx2)= val
45977 mspc(4)=mspc(4)+1
45978 ELSEIF (chblck(1:4).EQ.'STOP'.OR.chblck(1:4).EQ.'SBOT'.or
45979 $ .chblck(1:4).EQ.'STAU') THEN
45980 IF (chblck(1:4).EQ.'STOP') THEN
45981 kfsm=6
45982 ispc=6
45983 ELSEIF (chblck(1:4).EQ.'SBOT') THEN
45984 kfsm=5
45985 ispc=5
45986 ELSEIF (chblck(1:4).EQ.'STAU') THEN
45987 kfsm=15
45988 ispc=7
45989 ENDIF
45990C...Set SFMIX element
45991 sfmix(kfsm,2*(indx1-1)+indx2)=val
45992 mspc(ispc)=mspc(ispc)+1
45993 ENDIF
45994C...Running parameters
45995 ELSEIF (chblck(1:4).EQ.'HMIX') THEN
45996 READ(chblck(8:25),*,err=620) q
45997 READ(chinl,*) indx, val
45998 mspc(8)=mspc(8)+1
45999 IF (indx.EQ.1) THEN
46000 rmss(4) = val
46001 ELSE
46002 merr=1
46003 mspc(8)=mspc(8)-1
46004 ENDIF
46005 ELSEIF (chblck(1:5).EQ.'ALPHA') THEN
46006 READ(chinl,*,err=630) val
46007 rmss(18)= val
46008 mspc(17)=mspc(17)+1
46009C...Higgs parameters set manually or with FeynHiggs.
46010 imss(4)=max(2,imss(4))
46011 ELSEIF (chblck(1:2).EQ.'AU'.OR.chblck(1:2).EQ.'AD'.or
46012 & .chblck(1:2).EQ.'AE') THEN
46013 READ(chblck(9:26),*,err=620) q
46014 READ(chinl,*) indx1, indx2, val
46015 IF (chblck(2:2).EQ.'U') THEN
46016 au(indx1,indx2)=val
46017 IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(16)=val
46018 mspc(11)=mspc(11)+1
46019 ELSEIF (chblck(2:2).EQ.'D') THEN
46020 ad(indx1,indx2)=val
46021 IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(15)=val
46022 mspc(10)=mspc(10)+1
46023 ELSEIF (chblck(2:2).EQ.'E') THEN
46024 ae(indx1,indx2)=val
46025 IF (indx1.EQ.3.AND.indx2.EQ.3) rmss(17)=val
46026 mspc(12)=mspc(12)+1
46027 ELSE
46028 merr=1
46029 ENDIF
46030 ELSEIF (chblck(1:5).EQ.'MSOFT') THEN
46031 IF (mspc(18).EQ.0) THEN
46032 READ(chblck(9:25),*,err=620) q
46033 rmsoft(0)=q
46034 ENDIF
46035 READ(chinl,*) indx, val
46036 rmsoft(indx)=val
46037 mspc(18)=mspc(18)+1
46038 ELSEIF (chblck(1:5).EQ.'GAUGE') THEN
46039 merr=8
46040 ELSEIF (chblck(1:2).EQ.'YU'.OR.chblck(1:2).EQ.'YD'.or
46041 & .chblck(1:2).EQ.'YE') THEN
46042 merr=8
46043 ELSEIF (chblck(1:6).EQ.'SPINFO') THEN
46044 READ(chinl(1:6),*) indx
46045 it=0
46046 mird=0
46047 330 it=it+1
46048 IF (chinl(it:it).EQ.' ') GOTO 330
46049C...Don't read index
46050 IF (chinl(it:it).EQ.char(indx+48).AND.mird.EQ.0) THEN
46051 mird=1
46052 GOTO 330
46053 ENDIF
46054 IF (indx.EQ.1) cpro(1)=chinl(it:it+12)
46055 IF (indx.EQ.2) cver(1)=chinl(it:it+12)
46056 ELSE
46057C... Set unrecognized block flag.
46058 merr=6
46059 ENDIF
46060
46061C...DECAY TABLES
46062C...Read in decay information
46063 ELSEIF (mupda.EQ.2.AND.merr.EQ.0) THEN
46064C...Read new decay chanel
46065 IF(chinl(1:1).EQ.' '.AND.chblck(1:5).EQ.'DECAY') THEN
46066 ndc=ndc+1
46067C...Read in branching ratio and number of daughters for this mode.
46068 READ(chinl(4:50),*,err=390) brat(ndc)
46069 READ(chinl(4:50),*,err=600) dum, nda
46070 IF (nda.LE.5) THEN
46071 IF(ndc.GT.mstu(7)) CALL pyerrm(27,
46072 & '(PYSLHA:) Decay data arrays full by KF = '
46073 $ //chaf(kc,1))
46074C...If first decay channel, set decays start point in decay table
46075 IF(brsum.LE.0d0.AND.brat(ndc).NE.0d0) THEN
46076 IF (kforig.EQ.0) WRITE(mstu(11),'(1x,A,I9,A,A16)')
46077 & '* (PYSLHA:) Reading DECAY table for '//
46078 & 'KF =',kf,', ',chaf(kcrep,1)(1:16)
46079C...Set particle parameters (mass set when reading BLOCK MASS above)
46080 pmas(kc,2)=width
46081 IF (kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) THEN
46082 WRITE(mstu(11),'(1x,A)')
46083 & '* Note: the Pythia gg->h/H/A cross section'//
46084 & ' is proportional to the h/H/A->gg width'
46085 ELSEIF (kf.EQ.23.OR.kf.EQ.24.OR.kf.EQ.6.OR.kf.EQ.32
46086 & .OR.kf.EQ.33.OR.kf.EQ.34) THEN
46087 WRITE(mstu(11),'(1x,A,A16)')
46088 & '* Warning: will use DECAY table (fixed-width,'//
46089 & ' flat PS) for ',chaf(kc,1)(1:16)
46090 ENDIF
46091 pmas(kc,3)=0d0
46092 pmas(kc,4)=paru(3)*1d-12/width
46093 mwid(kc)=2
46094 mdcy(kc,1)=1
46095 mdcy(kc,2)=ndc
46096 mdcy(kc,3)=0
46097C...Add to list of DECAY blocks currently read
46098 ndecay=ndecay+1
46099 kfdec(ndecay)=kf
46100C...Return ok
46101 iretrn=0
46102 ENDIF
46103C... Count up number of decay modes for this particle
46104 mdcy(kc,3)=mdcy(kc,3)+1
46105C... Read in decay daughters.
46106 READ(chinl(4:120),*,err=610) dum,idm, (idc(ida),ida=1,nda)
46107C... Flip sign if reading antiparticle decays (if antipartner exists)
46108 DO 340 ida=1,nda
46109 IF (kchg(pycomp(idc(ida)),3).NE.0)
46110 & idc(ida)=mpsign*idc(ida)
46111 340 CONTINUE
46112C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46113 mdme(ndc,1)=1
46114 IF (brat(ndc).LE.0d0) mdme(ndc,1)=0
46115 brsum=brsum+abs(brat(ndc))
46116 brat(ndc)=abs(brat(ndc))
46117 350 iflip=0
46118 DO 360 ida=1,nda-1
46119 IF (iabs(idc(ida+1)).GT.iabs(idc(ida))) THEN
46120 itmp=idc(ida)
46121 idc(ida)=idc(ida+1)
46122 idc(ida+1)=itmp
46123 iflip=iflip+1
46124 ENDIF
46125 360 CONTINUE
46126 IF (iflip.GT.0) GOTO 350
46127C...Treat as ordinary decay, no fancy stuff.
46128 mdme(ndc,2)=0
46129 DO 370 ida=1,5
46130 IF (ida.LE.nda) THEN
46131 kfdp(ndc,ida)=idc(ida)
46132 ELSE
46133 kfdp(ndc,ida)=0
46134 ENDIF
46135 370 CONTINUE
46136C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46137C & (KFDP(NDC,J),J=1,NDA)
46138 ELSE
46139 CALL pyerrm(7,'(PYSLHA:) Too many daughters on line '//
46140 & chnlin)
46141 merr=11
46142 ndc=ndc-1
46143 ENDIF
46144 ELSEIF(chinl(1:1).EQ.'+') THEN
46145 merr=11
46146 ELSEIF(chblck(1:6).EQ.'DCINFO') THEN
46147 merr=16
46148 ELSE
46149 merr=16
46150 ENDIF
46151 ENDIF
46152C... Error check.
46153 380 IF (mod(merr,10).EQ.1.AND.(mupda.EQ.1.OR.mupda.EQ.2)) THEN
46154 WRITE(mstu(11),*) '* (PYSLHA:) Ignoring line '//chnlin//': '
46155 & //chinl(1:40)
46156 merr=0
46157 ELSEIF (merr.EQ.6.AND.mupda.EQ.1) THEN
46158 WRITE(mstu(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46159 & chblck(1:min(inl,40))//'... on line '//chnlin
46160 ELSEIF (merr.EQ.8.AND.mupda.EQ.1) THEN
46161 WRITE(mstu(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46162 & //chblck(1:inl)//'... on line'//chnlin
46163 ELSEIF (merr.EQ.16.AND.mupda.EQ.2.AND.imss21.EQ.0.AND.
46164 & chblck(1:1).NE.'D'.AND.verbos.EQ.1) THEN
46165 WRITE(mstu(11),*) '* (PYSLHA:) Ignoring BLOCK '//chblck(1:inl)
46166 & //'... on line'//chnlin
46167 ELSEIF (merr.EQ.7.AND.mupda.EQ.1) THEN
46168 WRITE(mstu(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46169 & /chblck(1:inl)//'... on line'//chnlin
46170 ELSEIF (merr.EQ.2.AND.mupda.EQ.1) THEN
46171 WRITE (chtmp,*) kf
46172 WRITE(mstu(11),*)
46173 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46174 & chtmp(1:9)//' on line'//chnlin
46175 ENDIF
46176C...Iterate read loop
46177 GOTO 170
46178C...Error catching
46179 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',nline,
46180 & ', ignoring subsequent lines.'
46181 WRITE(*,*) '* (PYSLHA:) Offending line:',chinl(1:46)
46182 chblck=' '
46183 GOTO 170
46184C...End of read loop
46185 400 CONTINUE
46186C...Set flag that KC codes have been rearranged.
46187 mstu(20)=0
46188 verbos=0
46189
46190C...Perform possible tests that new information is consistent.
46191 IF (mupda.EQ.1) THEN
46192 mstu23=mstu(23)
46193 mstu27=mstu(27)
46194C...Check masses
46195 DO 410 isusy=1,37
46196 kf=kfsusy(isusy)
46197C...Don't complain about right-handed neutrinos
46198 IF (kf.EQ.ksusy2+12.OR.kf.EQ.ksusy2+14.OR.kf.EQ.ksusy2
46199 & +16) GOTO 410
46200C...Only check gravitino in GMSB scenarios
46201 IF (modsel(1).NE.2.AND.kf.EQ.ksusy1+39) GOTO 410
46202 kc=pycomp(kf)
46203 IF (pmas(kc,1).EQ.0d0) THEN
46204 WRITE(chtmp,*) kf
46205 CALL pyerrm(9
46206 & ,'(PYSLHA:) No mass information found for KF ='
46207 & //chtmp)
46208 ENDIF
46209 410 CONTINUE
46210C...Check mixing matrices (MSSM only)
46211 IF (imss(13).EQ.0) THEN
46212 IF (mspc(2).NE.16.AND.mspc(2).NE.32) CALL pyerrm(9
46213 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46214 IF (mspc(3).NE.4.AND.mspc(3).NE.8) CALL pyerrm(9
46215 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46216 IF (mspc(4).NE.4.AND.mspc(4).NE.8) CALL pyerrm(9
46217 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46218 IF (mspc(5).NE.4) CALL pyerrm(9
46219 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46220 IF (mspc(6).NE.4) CALL pyerrm(9
46221 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46222 IF (mspc(7).NE.4) CALL pyerrm(9
46223 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46224 IF (mspc(8).LT.1) CALL pyerrm(9
46225 & ,'(PYSLHA:) Too few elements in HMIX')
46226 IF (mspc(10).EQ.0) CALL pyerrm(9
46227 & ,'(PYSLHA:) Missing A_b trilinear coupling')
46228 IF (mspc(11).EQ.0) CALL pyerrm(9
46229 & ,'(PYSLHA:) Missing A_t trilinear coupling')
46230 IF (mspc(12).EQ.0) CALL pyerrm(9
46231 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46232 IF (mspc(17).LT.1) CALL pyerrm(9
46233 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46234 ENDIF
46235C...Check wavefunction normalizations.
46236C...Sfermions
46237 DO 420 ispc=5,7
46238 IF (mspc(ispc).EQ.4) THEN
46239 kfsm=ispc
46240 IF (ispc.EQ.7) kfsm=15
46241 check=abs(sfmix(kfsm,1)*sfmix(kfsm,4)-sfmix(kfsm,2)
46242 & *sfmix(kfsm,3))
46243 IF (abs(1d0-check).GT.1d-3) THEN
46244 kcsm=pycomp(kfsm)
46245 CALL pyerrm(17
46246 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46247 & //chaf(kcsm,1))
46248 ENDIF
46249C...Bug fix 30/09 2008: PS
46250C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46251 IF (sfmix(kfsm,1)*sfmix(kfsm,4).LT.0d0) THEN
46252 sfmix(kfsm,3) = -sfmix(kfsm,3)
46253 sfmix(kfsm,4) = -sfmix(kfsm,4)
46254 ENDIF
46255 ENDIF
46256 420 CONTINUE
46257C...Neutralinos + charginos
46258 DO 440 j=1,4
46259 cn1=0d0
46260 cn2=0d0
46261 cu1=0d0
46262 cu2=0d0
46263 cv1=0d0
46264 cv2=0d0
46265 DO 430 l=1,4
46266 cn1=cn1+zmix(j,l)**2
46267 cn2=cn2+zmix(l,j)**2
46268 IF (j.LE.2.AND.l.LE.2) THEN
46269 cu1=cu1+umix(j,l)**2
46270 cu2=cu2+umix(l,j)**2
46271 cv1=cv1+vmix(j,l)**2
46272 cv2=cv2+vmix(l,j)**2
46273 ENDIF
46274 430 CONTINUE
46275C...NMIX normalization
46276 IF (mspc(2).EQ.16.AND.(abs(1d0-cn1).GT.1d-3.OR.abs(1d0-cn2)
46277 & .GT.1d-3).AND.imss(13).EQ.0) THEN
46278 CALL pyerrm(19,
46279 & '(PYSLHA:) NMIX: Inconsistent normalization.')
46280 WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F7.4))') j, cn1, cn2
46281 ENDIF
46282C...UMIX, VMIX normalizations
46283 IF (mspc(3).EQ.4.OR.mspc(4).EQ.4.AND.imss(13).EQ.0) THEN
46284 IF (j.LE.2) THEN
46285 IF (abs(1d0-cu1).GT.1d-3.OR.abs(1d0-cu2).GT.1d-3) THEN
46286 CALL pyerrm(19
46287 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46288 WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F6.2))') j, cu1,
46289 & cu2
46290 ENDIF
46291 IF (abs(1d0-cv1).GT.1d-3.OR.abs(1d0-cv2).GT.1d-3) THEN
46292 CALL pyerrm(19,
46293 & '(PYSLHA:) VMIX: Inconsistent normalization.')
46294 WRITE(mstu(11),'(7x,I2,1x,":",2(1x,F6.2))') j, cv1,
46295 & cv2
46296 ENDIF
46297 ENDIF
46298 ENDIF
46299 440 CONTINUE
46300 IF (mstu(27).EQ.mstu27.AND.mstu(23).EQ.mstu23) THEN
46301 WRITE(mstu(11),'(1x,"*"/1x,A/1x,"*")')
46302 & '* (PYSLHA:) No spectrum inconsistencies were found.'
46303 ELSE
46304 WRITE(mstu(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46305 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46306 & ,' Warning: one or more (serious)'//
46307 & ' inconsistencies were found in the spectrum !'
46308 & ,' Read the error messages above and check your'//
46309 & ' input file.'
46310 ENDIF
46311C...Increase precision in Higgs sector using FeynHiggs
46312 IF (imss(4).EQ.3) THEN
46313C...FeynHiggs needs MSOFT.
46314 ierr=0
46315 IF (mspc(18).EQ.0) THEN
46316 WRITE(mstu(11),'(1x,"*"/1x,A/)')
46317 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46318 & ' Cannot call FeynHiggs.'
46319 ierr=-1
46320 ELSE
46321 WRITE(mstu(11),'(1x,/1x,A/)')
46322 & '* (PYSLHA:) Now calling FeynHiggs.'
46323 CALL pyfeyn(ierr)
46324 IF (ierr.NE.0) imss(4)=2
46325 ENDIF
46326 ENDIF
46327 ELSEIF (mupda.EQ.2.AND.iretrn.EQ.0.AND.merr.NE.16) THEN
46328 ibeg=1
46329 IF (kforig.NE.0) ibeg=ndecay
46330 DO 490 idecay=ibeg,ndecay
46331 kf = kfdec(idecay)
46332 kc = pycomp(kf)
46333 WRITE(chkf,8300) kf
46334 IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3
46335 $ ),pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0.OR.(mdcy(kc,3)
46336 $ .EQ.0.AND.mdcy(kc,1).GE.1)) CALL pyerrm(17
46337 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46338 $ //chkf)
46339 brsum=0d0
46340 bropn=0d0
46341 DO 460 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
46342 IF(mdme(ida,2).GT.80) GOTO 460
46343 kq=kchg(kc,1)
46344 pms=pmas(kc,1)-pmas(kc,3)-parj(64)
46345 merr=0
46346 DO 450 j=1,5
46347 kp=kfdp(ida,j)
46348 IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
46349 IF(kp.EQ.81) kq=0
46350 ELSEIF(pycomp(kp).EQ.0) THEN
46351 merr=3
46352 ELSE
46353 kq=kq-pychge(kp)
46354 kpc=pycomp(kp)
46355 pms=pms-pmas(kpc,1)
46356 IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),
46357 & pmas(kpc,3))
46358 ENDIF
46359 450 CONTINUE
46360 IF(kq.NE.0) merr=max(2,merr)
46361 IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)
46362 & merr=max(1,merr)
46363 IF(merr.EQ.3) CALL pyerrm(17,
46364 & '(PYSLHA:) Unknown particle code in decay of KF ='
46365 $ //chkf)
46366 IF(merr.EQ.2) CALL pyerrm(17,
46367 & '(PYSLHA:) Charge not conserved in decay of KF ='
46368 $ //chkf)
46369 IF(merr.EQ.1) CALL pyerrm(7,
46370 & '(PYSLHA:) Kinematically unallowed decay of KF ='
46371 $ //chkf)
46372 brsum=brsum+brat(ida)
46373 IF (mdme(ida,1).GT.0) bropn=bropn+brat(ida)
46374 460 CONTINUE
46375C...Check branching ratio sum.
46376 IF (bropn.LE.0d0) THEN
46377C...If zero, set stable.
46378 WRITE(chtmp,8500) bropn
46379 CALL pyerrm(7
46380 & ,"(PYSLHA:) Effective BR sum for KF="//chkf//' is '//
46381 & chtmp(9:16)//'. Changed to stable.')
46382 pmas(kc,2)=1d-6
46383 mwid(kc)=0
46384C...If BR's > 1, rescale.
46385 ELSEIF (brsum.GT.(1d0+1d-6)) THEN
46386 WRITE(chtmp,8500) brsum
46387 IF (brsum.GT.(1d0+1d-3)) CALL pyerrm(7
46388 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//chkf//
46389 & ' ; sum was'//chtmp(9:16)//'.')
46390 fac=1d0/brsum
46391 DO 470 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
46392 IF(mdme(ida,2).GT.80) GOTO 470
46393 brat(ida)=fac*brat(ida)
46394 470 CONTINUE
46395 ELSEIF (brsum.LT.(1d0-1d-6)) THEN
46396C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46397 WRITE(chtmp,8500) brsum
46398 IF (brsum.LT.(1d0-1d-3)) CALL pyerrm(7
46399 & ,"(PYSLHA:) Sum of BR's for KF="//chkf//' is '//
46400 & chtmp(9:16)//'. Dummy mode will be inserted.')
46401C...Move table and insert dummy mode
46402 DO 480 ida=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
46403 ndc=ndc+1
46404 brat(ndc)=brat(ida)
46405 kfdp(ndc,1)=kfdp(ida,1)
46406 kfdp(ndc,2)=kfdp(ida,2)
46407 kfdp(ndc,3)=kfdp(ida,3)
46408 kfdp(ndc,4)=kfdp(ida,4)
46409 kfdp(ndc,5)=kfdp(ida,5)
46410 mdme(ndc,1)=mdme(ida,1)
46411 480 CONTINUE
46412 ndc=ndc+1
46413 brat(ndc)=1d0-brsum
46414 kfdp(ndc,1)=0
46415 kfdp(ndc,2)=0
46416 kfdp(ndc,3)=0
46417 kfdp(ndc,4)=0
46418 kfdp(ndc,5)=0
46419 mdme(ndc,1)=0
46420 brsum=1d0
46421C...Update MDCY
46422 mdcy(kc,3)=mdcy(kc,3)+1
46423 mdcy(kc,2)=ndc-mdcy(kc,3)+1
46424 ENDIF
46425 490 CONTINUE
46426 ENDIF
46427
46428
46429C...WRITE SPECTRUM ON SLHA FILE
46430 ELSEIF(mupda.EQ.3) THEN
46431C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46432 IF (imss(1).EQ.2.OR.imss(1).EQ.12) THEN
46433 modsel(1)=1
46434 parmin(1)=rmss(8)
46435 parmin(2)=rmss(1)
46436 parmin(3)=rmss(5)
46437 parmin(4)=sign(1d0,rmss(4))
46438 parmin(5)=rmss(36)
46439 ENDIF
46440C...Write spectrum
46441 WRITE(lfn,7000) 'SLHA MSSM spectrum'
46442 WRITE(lfn,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46443 & // ' P. Skands.'
46444 WRITE(lfn,7010) 'MODSEL', 'Model selection'
46445 WRITE(lfn,7110) 1, modsel(1)
46446 WRITE(lfn,7010) 'MINPAR', 'Parameters for minimal model.'
46447 IF (modsel(1).EQ.1) THEN
46448 WRITE(lfn,7210) 1, parmin(1), 'm0'
46449 WRITE(lfn,7210) 2, parmin(2), 'm12'
46450 WRITE(lfn,7210) 3, parmin(3), 'tan(beta)'
46451 WRITE(lfn,7210) 4, parmin(4), 'sign(mu)'
46452 WRITE(lfn,7210) 5, parmin(5), 'a0'
46453 ELSEIF(modsel(2).EQ.2) THEN
46454 WRITE(lfn,7210) 1, parmin(1), 'Lambda'
46455 WRITE(lfn,7210) 2, parmin(2), 'M'
46456 WRITE(lfn,7210) 3, parmin(3), 'tan(beta)'
46457 WRITE(lfn,7210) 4, parmin(4), 'sign(mu)'
46458 WRITE(lfn,7210) 5, parmin(5), 'N5'
46459 WRITE(lfn,7210) 6, parmin(6), 'c_grav'
46460 ENDIF
46461 WRITE(lfn,7000) ' '
46462 WRITE(lfn,7010) 'MASS', 'Mass spectrum'
46463 DO 500 i=1,36
46464 kf=kfsusy(i)
46465 kc=pycomp(kf)
46466 IF (kf.EQ.1000039.AND.modsel(1).NE.2) GOTO 500
46467 kfsm=kf-ksusy1
46468 IF (kfsm.GE.22.AND.kfsm.LE.37) THEN
46469 IF (kfsm.EQ.22) WRITE(lfn,7220) kf, smz(1), chaf(kc,1)
46470 IF (kfsm.EQ.23) WRITE(lfn,7220) kf, smz(2), chaf(kc,1)
46471 IF (kfsm.EQ.25) WRITE(lfn,7220) kf, smz(3), chaf(kc,1)
46472 IF (kfsm.EQ.35) WRITE(lfn,7220) kf, smz(4), chaf(kc,1)
46473 IF (kfsm.EQ.24) WRITE(lfn,7220) kf, smw(1), chaf(kc,1)
46474 IF (kfsm.EQ.37) WRITE(lfn,7220) kf, smw(2), chaf(kc,1)
46475 ELSE
46476 WRITE(lfn,7220) kf, pmas(kc,1), chaf(kc,1)
46477 ENDIF
46478 500 CONTINUE
46479C...SUSY scale
46480 rmsusy=sqrt(pmas(pycomp(ksusy1+6),1)*pmas(pycomp(ksusy2+6),1))
46481 WRITE(lfn,7020) 'HMIX',rmsusy,'Higgs parameters'
46482 WRITE(lfn,7210) 1, rmss(4),'mu'
46483 WRITE(lfn,7010) 'ALPHA',' '
46484 WRITE(lfn,7210) 1, rmss(18), 'alpha'
46485 WRITE(lfn,7020) 'AU',rmsusy
46486 WRITE(lfn,7410) 3, 3, rmss(16), 'A_t'
46487 WRITE(lfn,7020) 'AD',rmsusy
46488 WRITE(lfn,7410) 3, 3, rmss(15), 'A_b'
46489 WRITE(lfn,7020) 'AE',rmsusy
46490 WRITE(lfn,7410) 3, 3, rmss(17), 'A_tau'
46491 WRITE(lfn,7010) 'STOPMIX','~t mixing matrix'
46492 WRITE(lfn,7410) 1, 1, sfmix(6,1)
46493 WRITE(lfn,7410) 1, 2, sfmix(6,2)
46494 WRITE(lfn,7410) 2, 1, sfmix(6,3)
46495 WRITE(lfn,7410) 2, 2, sfmix(6,4)
46496 WRITE(lfn,7010) 'SBOTMIX','~b mixing matrix'
46497 WRITE(lfn,7410) 1, 1, sfmix(5,1)
46498 WRITE(lfn,7410) 1, 2, sfmix(5,2)
46499 WRITE(lfn,7410) 2, 1, sfmix(5,3)
46500 WRITE(lfn,7410) 2, 2, sfmix(5,4)
46501 WRITE(lfn,7010) 'STAUMIX','~tau mixing matrix'
46502 WRITE(lfn,7410) 1, 1, sfmix(15,1)
46503 WRITE(lfn,7410) 1, 2, sfmix(15,2)
46504 WRITE(lfn,7410) 2, 1, sfmix(15,3)
46505 WRITE(lfn,7410) 2, 2, sfmix(15,4)
46506 WRITE(lfn,7010) 'NMIX','~chi0 mixing matrix'
46507 DO 520 i1=1,4
46508 DO 510 i2=1,4
46509 WRITE(lfn,7410) i1, i2, zmix(i1,i2)
46510 510 CONTINUE
46511 520 CONTINUE
46512 WRITE(lfn,7010) 'UMIX','~chi^+ U mixing matrix'
46513 DO 540 i1=1,2
46514 DO 530 i2=1,2
46515 WRITE(lfn,7410) i1, i2, umix(i1,i2)
46516 530 CONTINUE
46517 540 CONTINUE
46518 WRITE(lfn,7010) 'VMIX','~chi^+ V mixing matrix'
46519 DO 560 i1=1,2
46520 DO 550 i2=1,2
46521 WRITE(lfn,7410) i1, i2, vmix(i1,i2)
46522 550 CONTINUE
46523 560 CONTINUE
46524 WRITE(lfn,7010) 'SPINFO'
46525 IF (imss(1).EQ.2) THEN
46526 cpro(1)='PYTHIA'
46527 cver(1)='6.4'
46528 ELSEIF (imss(1).EQ.12) THEN
46529 isaver=visaje()
46530 cpro(1)='ISASUSY'
46531 cver(1)=isaver(1:12)
46532 ENDIF
46533 WRITE(lfn,7310) 1, cpro(1), 'Spectrum Calculator'
46534 WRITE(lfn,7310) 2, cver(1), 'Version number'
46535 ENDIF
46536
46537C...Print user information about spectrum
46538 IF (mupda.EQ.1.OR.mupda.EQ.3) THEN
46539 IF (cpro(mod(mupda,2)).NE.' '.AND.cver(mod(mupda,2)).NE.' ')
46540 & WRITE(mstu(11),5030) cpro(1), cver(1)
46541 IF (imss(4).EQ.3) WRITE(mstu(11),5040)
46542 IF (mupda.EQ.1) THEN
46543 WRITE(mstu(11),5020) lfn
46544 ELSE
46545 WRITE(mstu(11),5010) lfn
46546 ENDIF
46547
46548 WRITE(mstu(11),5400)
46549 WRITE(mstu(11),5500) 'Pole masses'
46550 WRITE(mstu(11),5700) (rmfun(ksusy1+ip),ip=1,6)
46551 $ ,(rmfun(ksusy2+ip),ip=1,6)
46552 WRITE(mstu(11),5800) (rmfun(ksusy1+ip),ip=11,16)
46553 $ ,(rmfun(ksusy2+ip),ip=11,16)
46554 IF (imss(13).EQ.0) THEN
46555 WRITE(mstu(11),5900) rmfun(ksusy1+21),rmfun(ksusy1+22)
46556 $ ,rmfun(ksusy1+23),rmfun(ksusy1+25),rmfun(ksusy1+35),
46557 $ rmfun(ksusy1+24),rmfun(ksusy1+37)
46558 WRITE(mstu(11),6000) chaf(25,1),chaf(35,1),chaf(36,1),
46559 & chaf(37,1), ' ', ' ',' ',' ',
46560 & rmfun(25), rmfun(35), rmfun(36), rmfun(37)
46561 ELSEIF (imss(13).EQ.1) THEN
46562 kf1=ksusy1+21
46563 kf2=ksusy1+22
46564 kf3=ksusy1+23
46565 kf4=ksusy1+25
46566 kf5=ksusy1+35
46567 kf6=ksusy1+45
46568 kf7=ksusy1+24
46569 kf8=ksusy1+37
46570 WRITE(mstu(11),6000) chaf(pycomp(kf1),1),chaf(pycomp(kf2),1),
46571 & chaf(pycomp(kf3),1),chaf(pycomp(kf4),1),
46572 & chaf(pycomp(kf5),1),chaf(pycomp(kf6),1),
46573 & chaf(pycomp(kf7),1),chaf(pycomp(kf8),1),
46574 & rmfun(kf1),rmfun(kf2),rmfun(kf3),rmfun(kf4),
46575 & rmfun(kf5),rmfun(kf6),rmfun(kf7),rmfun(kf8)
46576 WRITE(mstu(11),6000) chaf(25,1), chaf(35,1), chaf(45,1),
46577 & chaf(36,1), chaf(46,1), chaf(37,1),' ',' ',
46578 & rmfun(25), rmfun(35), rmfun(45), rmfun(36), rmfun(46),
46579 & rmfun(37)
46580 ENDIF
46581 WRITE(mstu(11),5400)
46582 WRITE(mstu(11),5500) 'Mixing structure'
46583 WRITE(mstu(11),6100) ((zmix(i,j), j=1,4),i=1,4)
46584 WRITE(mstu(11),6200) (umix(1,j), j=1,2),(vmix(1,j),j=1,2)
46585 & ,(umix(2,j), j=1,2),(vmix(2,j),j=1,2)
46586 WRITE(mstu(11),6300) (sfmix(5,j), j=1,2),(sfmix(6,j),j=1,2)
46587 & ,(sfmix(15,j), j=1,2),(sfmix(5,j),j=3,4),(sfmix(6,j), j=3,4
46588 & ),(sfmix(15,j),j=3,4)
46589 WRITE(mstu(11),5400)
46590 WRITE(mstu(11),5500) 'Couplings'
46591 WRITE(mstu(11),6400) rmss(15),rmss(16),rmss(17)
46592 WRITE(mstu(11),6450) rmss(18), rmss(5), rmss(4)
46593 WRITE(mstu(11),5400)
46594 WRITE(mstu(11),6500)
46595
46596 ENDIF
46597
46598C...Only rewind when reading
46599 IF (mupda.LE.2.OR.mupda.EQ.5) rewind(lfn)
46600
46601 9999 RETURN
46602
46603C...Serious error catching
46604 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',nline
46605 write(*,*) chinl(1:80)
46606 CALL pystop(106)
46607 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',nline
46608 WRITE(*,*) chinl(1:72)
46609 CALL pystop(106)
46610 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',nline
46611 WRITE(*,*) chinl(1:80)
46612 CALL pystop(106)
46613 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',nline
46614 WRITE(*,*) chinl(1:80)
46615 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',chblck
46616 CALL pystop(106)
46617 630 WRITE(*,*) '* (PYSLHA:) read error in line ',nline,':'
46618 WRITE(*,*) chinl(1:80)
46619 CALL pystop(106)
46620
46621 8300 FORMAT(i9)
46622 8500 FORMAT(f16.5)
46623
46624C...Formats for user information printout.
46625 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.12: SUSY/BSM SPECTRUM '
46626 & ,'INTERFACE',1x,17('*')/1x,'*',1x
46627 & ,'(PYSLHA:) Last Change',1x,a,1x,'-',1x,'P.Z. Skands')
46628 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',i3)
46629 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',i3)
46630 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',a,' version ',a)
46631 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46632 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46633 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46634 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(f8.2,1x),i8,2x,f8.2)
46635 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46636 & ,'----------------')
46637 5400 FORMAT(1x,'*',1x,a)
46638 5500 FORMAT(1x,'*',1x,a,':')
46639 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46640 & 1x,'*',2x,1p,2(1x,e8.2),2x,e8.2)
46641 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46642 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46643 & ,6(f8.2,1x)/1x,'*',2x,'R',1x,6(f8.2,1x))
46644 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46645 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46646 & ,'L',1x,6(f8.2,1x)/1x,'*',2x,'R',1x,6(f8.2,1x))
46647 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46648 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46649 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(f8.2,1x))
46650 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,a7,1x)/1x,'*',3x,1x,8(f8.2,1x))
46651 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46652 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46653 & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46654 & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46655 & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46656 & ,1x,f6.3,1x),'|')
46657 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46658 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46659 & ,'~chi_1+',1x,2('|',1x,f6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46660 & ,f6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,f6.3,1x),'|',9x
46661 & ,'~chi_2+',1x,2('|',1x,f6.3,1x),'|')
46662 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46663 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46664 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46665 & 1x,'*',3x,'~b_1',1x,2('|',1x,f6.3,1x),'|',3x,'~t_1',1x,2('|'
46666 & ,1x,f6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,f6.3,1x),'|'/
46667 & 1x,'*',3x,'~b_2',1x,2('|',1x,f6.3,1x),'|',3x,'~t_2',1x,2('|'
46668 & ,1x,f6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,f6.3,1x),'|')
46669 6400 FORMAT(1x,'*',3x,' A_b = ',f8.2,4x,' A_t = ',f8.2,4x
46670 & ,'A_tau = ',f8.2)
46671 6450 FORMAT(1x,'*',3x,'alpha = ',f8.2,4x,'tan(beta) = ',f8.2,4x
46672 & ,' mu = ',f8.2)
46673 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46674
46675C...Format to use for comments
46676 7000 FORMAT('# ',a)
46677C...Format to use for block statements
46678 7010 FORMAT('Block',1x,a,3x,'#',1x,a)
46679 7020 FORMAT('Block',1x,a,1x,'Q=',1p,e16.8,0p,3x,'#',1x,a)
46680C...Indexed Int
46681 7110 FORMAT(1x,i4,1x,i4,3x,'#')
46682C...Non-Indexed Double
46683 7200 FORMAT(9x,1p,e16.8,0p,3x,'#',1x,a)
46684C...Indexed Double
46685 7210 FORMAT(1x,i4,3x,1p,e16.8,0p,3x,'#',1x,a)
46686C...Long Indexed Double (PDG + double)
46687 7220 FORMAT(1x,i9,3x,1p,e16.8,0p,3x,'#',1x,a)
46688C...Indexed Char(12)
46689 7310 FORMAT(1x,i4,3x,a12,3x,'#',1x,a)
46690C...Single matrix
46691 7410 FORMAT(1x,i2,1x,i2,3x,1p,e16.8,0p,3x,'#',1x,a)
46692C...Double Matrix
46693 7420 FORMAT(1x,i2,1x,i2,3x,1p,e16.8,3x,e16.8,0p,3x,'#',1x,a)
46694C...Write Decay Table
46695 7500 FORMAT('Decay',1x,i9,1x,'WIDTH=',1p,e16.8,0p,3x,'#',1x,a)
46696 7510 FORMAT(4x,i5,1x,1p,e16.8,0p,3x,i2,3x,'IDA=',1x,5(1x,i9),
46697 & 3x,'#',1x,a)
46698
46699 END
46700
46701
46702C*********************************************************************
46703
46704C...PYAPPS
46705C...Uses approximate analytical formulae to determine the full set of
46706C...MSSM parameters from SUGRA input.
46707C...See M. Drees and S.P. Martin, hep-ph/9504124
46708
46709 SUBROUTINE pyapps
46710
46711C...Double precision and integer declarations.
46712 IMPLICIT DOUBLE PRECISION(a-h, o-z)
46713 IMPLICIT INTEGER(I-N)
46714 INTEGER PYK,PYCHGE,PYCOMP
46715C...Parameter statement to help give large particle numbers.
46716 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
46717 &kexcit=4000000,kdimen=5000000)
46718C...Commonblocks.
46719 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46720 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
46721 common/pymssm/imss(0:99),rmss(0:99)
46722 SAVE /pydat1/,/pydat2/,/pymssm/
46723
46724 WRITE(mstu(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46725 &' not intended for serious physics studies'
46726 imss(5)=0
46727 imss(8)=0
46728 xmt=pmas(6,1)
46729 xmz2=pmas(23,1)**2
46730 xmw2=pmas(24,1)**2
46731 tanb=rmss(5)
46732 beta=atan(tanb)
46733 xw=paru(102)
46734 xmg=rmss(1)
46735 xmg2=xmg*xmg
46736 xm0=rmss(8)
46737 xm02=xm0*xm0
46738C...Temporary sign change for AT. Others unchanged.
46739 at=-rmss(16)
46740 rmss(15)=rmss(16)
46741 rmss(17)=rmss(16)
46742 sinb=tanb/sqrt(tanb**2+1d0)
46743 cosb=sinb/tanb
46744
46745 dterm=xmz2*cos(2d0*beta)
46746 xmer=sqrt(xm02+0.15d0*xmg2-xw*dterm)
46747 xmel=sqrt(xm02+0.52d0*xmg2-(0.5d0-xw)*dterm)
46748 rmss(6)=xmel
46749 rmss(7)=xmer
46750 xmur=sqrt(pyrnmq(2,2d0/3d0*xw*dterm))
46751 xmdr=sqrt(pyrnmq(3,-1d0/3d0*xw*dterm))
46752 xmul=sqrt(pyrnmq(1,(0.5d0-2d0/3d0*xw)*dterm))
46753 xmdl=sqrt(pyrnmq(1,-(0.5d0-1d0/3d0*xw)*dterm))
46754 DO 100 i=1,5,2
46755 pmas(pycomp(ksusy1+i),1)=xmdl
46756 pmas(pycomp(ksusy2+i),1)=xmdr
46757 pmas(pycomp(ksusy1+i+1),1)=xmul
46758 pmas(pycomp(ksusy2+i+1),1)=xmur
46759 100 CONTINUE
46760 xarg=xmel**2-xmw2*abs(cos(2d0*beta))
46761 IF(xarg.LT.0d0) THEN
46762 WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46763 & ' FROM THE SUM RULE. '
46764 WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46765 RETURN
46766 ELSE
46767 xarg=sqrt(xarg)
46768 ENDIF
46769 DO 110 i=11,15,2
46770 pmas(pycomp(ksusy1+i),1)=xmel
46771 pmas(pycomp(ksusy2+i),1)=xmer
46772 pmas(pycomp(ksusy1+i+1),1)=xarg
46773 pmas(pycomp(ksusy2+i+1),1)=9999d0
46774 110 CONTINUE
46775 rmt=pymrun(6,pmas(6,1)**2)
46776 xtop=(rmt/150d0/sinb)**2*(.9d0*xm02+2.1d0*xmg2+
46777 &(1d0-(rmt/190d0/sinb)**3)*(.24d0*at**2+at*xmg))
46778 rmb=pymrun(5,pmas(6,1)**2)
46779 xbot=(rmb/150d0/cosb)**2*(.9d0*xm02+2.1d0*xmg2+
46780 &(1d0-(rmb/190d0/cosb)**3)*(.24d0*at**2+at*xmg))
46781 xtau=1d-4/cosb**2*(xm02+0.15d0*xmg2+at**2/3d0)
46782 atp=at*(1d0-(rmt/190d0/sinb)**2)+xmg*(3.47d0-1.9d0*(rmt/190d0/
46783 &sinb)**2)
46784 rmss(16)=-atp
46785 xmu2=-.5d0*xmz2+(sinb**2*(xm02+.52d0*xmg2-xtop)-
46786 &cosb**2*(xm02+.52d0*xmg2-xbot-xtau/3d0))/(cosb**2-sinb**2)
46787 xma2=2d0*(xm02+.52d0*xmg2+xmu2)-xtop-xbot-xtau/3d0
46788 xmu=sign(sqrt(xmu2),rmss(4))
46789 rmss(4)=xmu
46790 IF(xma2.GT.0d0) THEN
46791 rmss(19)=sqrt(xma2)
46792 ELSE
46793 WRITE(mstu(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46794 CALL pystop(102)
46795 ENDIF
46796 arg=xm02+0.15d0*xmg2-2d0*xtau/3d0-xw*dterm
46797 IF(arg.GT.0d0) THEN
46798 rmss(14)=sqrt(arg)
46799 ELSE
46800 WRITE(mstu(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46801 CALL pystop(102)
46802 ENDIF
46803 arg=xm02+0.52d0*xmg2-xtau/3d0-(0.5d0-xw)*dterm
46804 IF(arg.GT.0d0) THEN
46805 rmss(13)=sqrt(arg)
46806 ELSE
46807 WRITE(mstu(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46808 CALL pystop(102)
46809 ENDIF
46810 arg=pyrnmq(1,-(xbot+xtop)/3d0)
46811 IF(arg.GT.0d0) THEN
46812 rmss(10)=sqrt(arg)
46813 ELSE
46814 rmss(10)=-sqrt(-arg)
46815 ENDIF
46816 arg=pyrnmq(2,-2d0*xtop/3d0)
46817 IF(arg.GT.0d0) THEN
46818 rmss(12)=sqrt(arg)
46819 ELSE
46820 rmss(12)=-sqrt(-arg)
46821 ENDIF
46822 arg=pyrnmq(3,-2d0*xbot/3d0)
46823 IF(arg.GT.0d0) THEN
46824 rmss(11)=sqrt(arg)
46825 ELSE
46826 rmss(11)=-sqrt(-arg)
46827 ENDIF
46828
46829 RETURN
46830 END
46831
46832C*********************************************************************
46833
46834C...PYSUGI
46835C...Interface to ISASUSY version 7.71.
46836C...Warning: this interface should not be used with earlier versions
46837C...of ISASUSY, since common block incompatibilities may then arise.
46838C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46839C...Then converts to Gunion-Haber conventions.
46840
46841 SUBROUTINE pysugi
46842 IMPLICIT DOUBLE PRECISION(a-h, o-z)
46843
46844 INTEGER PYK,PYCHGE,PYCOMP
46845 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
46846 &kexcit=4000000,kdimen=5000000)
46847
46848C...Date of Change
46849 CHARACTER DOC*11
46850 parameter(doc='01 May 2006')
46851
46852C...ISASUGRA Input:
46853 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46854C...XISAIN contains the MSSMi inputs in natural order.
46855 COMMON /sugxin/ xisain(24),xsugin(7),xgmin(14),xnrin(4),
46856 $xamin(7)
46857 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46858 SAVE /sugxin/
46859C...ISASUGRA Output
46860 CHARACTER*40 ISAVER,VISAJE
46861 REAL SUPER
46862 COMMON /sspar/ super(72)
46863 COMMON /sugmg/ mss(32),gss(31),mgutss,ggutss,agutss,ftgut,
46864 $fbgut,ftagut,fngut
46865 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46866 COMMON /sugpas/ xtanb,msusy,amt,mgut,mu,g2,gp,v,vp,xw,
46867 $a1mz,a2mz,asmz,ftamz,fbmz,b,sin2b,ftmt,g3mt,vev,higfrz,
46868 $fnmz,amnrmj,nogood,ial3un,itachy,mhpneg,asm3,
46869 $vumt,vdmt,asmtp,asmss,m3q
46870 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46871 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46872 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46873 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46874 INTEGER IALLOW
46875 SAVE /sugmg/,/sspar/
46876C SUPER: Filled by ISASUGRA.
46877C SUPER(1) = mass of ~g
46878C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46879C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46880C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46881C ,~tau_2
46882C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46883C SUPER(29) = Higgsino mass = - mu
46884C SUPER(30) = ratio v2/v1 of vev's
46885C SUPER(31:34) = Signed neutralino masses
46886C SUPER(35:50) = Neutralino mixing matrix
46887C SUPER(51:52) = Signed chargino masses
46888C SUPER(53:54) = Chargino left, right mixing angles
46889C SUPER(55:58) = mass of h0, H0, A0, H+
46890C SUPER(59) = Higgs mixing angle alpha
46891C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46892C SUPER(66) = Gravitino mass
46893C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46894C SUPER(70) = b-Yukawa at mA scale (not used)
46895C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46896C GSS: Filled by ISASUGRA
46897C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
46898C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
46899C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
46900C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
46901C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
46902C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
46903C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
46904C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
46905C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
46906C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
46907C GSS(31) = log(vuq)
46908C MSS: Filled by ISASUGRA
46909C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
46910C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
46911C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
46912C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
46913C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
46914C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
46915C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
46916C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
46917C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
46918C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
46919C MSS(31) = ha0 MSS(32) = h+
46920C Unification, filled by ISASUGRA if applicable.
46921C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
46922
46923C...SPYTHIA Input/Output
46924 INTEGER IMSS
46925 DOUBLE PRECISION RMSS
46926 common/pymssm/imss(0:99),rmss(0:99)
46927 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
46928 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
46929C...SLHA Input/Output
46930 common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
46931 & au(3,3),ad(3,3),ae(3,3)
46932C...PYTHIA common blocks
46933 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
46934 common/pypars/mstp(200),parp(200),msti(200),pari(200)
46935 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
46936
46937 SAVE /pymssm/,/pyssmt/,/pylh3p/,/pydat1/,/pypars/,/pydat2/
46938CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46939 INTEGER IMODEL
46940 REAL M0,MHF,A0,MT
46941 CHARACTER*20 CHMOD(5)
46942 CHARACTER*32 FNAME
46943
46944 COMMON /sugnu/ xnusug(18)
46945 REAL XNUSUG
46946 SAVE /sugnu/
46947
46948 DATA chmod/'mSUGRA','mGMSB','non-universal SUGRA',
46949 & 'truly unified SUGRA', 'non-minimal GMSB'/
46950
46951C...Start by checking for incompatibilities/inconsistencies:
46952 DO 100 ichk=2,9
46953 IF (ichk.NE.8.AND.ichk.NE.4.AND.imss(ichk).NE.0) THEN
46954 WRITE (mstu(11),*) '(PYSUGI:) IMSS(',ichk,')=',imss(ichk)
46955 & ,' option not used by PYSUGI'
46956 ENDIF
46957 100 CONTINUE
46958C...ISAJET works with REAL numbers.
46959 mzero=real(rmss(8))
46960 mhlf=real(rmss(1))
46961 azero=real(rmss(16))
46962 tanb=real(rmss(5))
46963 sgnmu=real(rmss(4))
46964 mtop=real(pmas(6,1))
46965 imodel=0
46966 IF (imss(1).EQ.12) THEN
46967 imodel=1
46968 GOTO 130
46969 ELSEIF(imss(1).EQ.13) THEN
46970C...Read from isajet par file in IMSS(20)
46971 lfn=imss(20)
46972C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46973 IF (lfn.EQ.0) THEN
46974 WRITE(mstu(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
46975 GOTO 9999
46976 ENDIF
46977 WRITE(mstu(11),*) 'READING SUSY MODEL FROM FILE...'
46978CMrenna change to allow any susy model
46979 WRITE(mstu(11),*) 'ENTER 1 for mSUGRA:'
46980 WRITE(mstu(11),*) 'ENTER 2 for mGMSB:'
46981 WRITE(mstu(11),*) 'ENTER 3 for non-universal SUGRA:'
46982 WRITE(mstu(11),*) 'ENTER 4 for SUGRA with truly unified'//
46983 & ' gauge couplings:'
46984 WRITE(mstu(11),*) 'ENTER 5 for non-minimal GMSB:'
46985 READ(lfn,*) imodel
46986 IF (imodel.EQ.4) THEN
46987 ial3un=1
46988 imodel=1
46989 ENDIF
46990 IF (imodel.EQ.1.OR.imodel.EQ.3) THEN
46991 WRITE(mstu(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
46992 & //' sgn(mu), M_t:'
46993 READ(lfn,*) m0,mhf,a0,tanb,sgnmu,mt
46994 IF (imodel.EQ.3) THEN
46995 imodel=1
46996 110 WRITE(mstu(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
46997 & //' 0 to continue:'
46998 WRITE(mstu(11),*) ' NUSUG1 = GUT scale gaugino masses'
46999 WRITE(mstu(11),*) ' NUSUG2 = GUT scale A terms'
47000 WRITE(mstu(11),*) ' NUSUG3 = GUT scale Higgs masses'
47001 WRITE(mstu(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47002 & //' generation masses'
47003 WRITE(mstu(11),*)
47004 & ' NUSUG5 = GUT scale 3rd generation masses'
47005 READ(lfn,*) inusug
47006 IF (inusug.EQ.0) THEN
47007 GOTO 120
47008 ELSEIF (inusug.EQ.1) THEN
47009 WRITE(mstu(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47010 READ(lfn,*) xnusug(1),xnusug(2),xnusug(3)
47011 IF (xnusug(3).LE.0.) THEN
47012 WRITE(mstu(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47013 CALL pystop(109)
47014 END IF
47015 ELSEIF (inusug.EQ.2) THEN
47016 WRITE(mstu(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47017 READ(lfn,*) xnusug(6),xnusug(5),xnusug(4)
47018 ELSEIF (inusug.EQ.3) THEN
47019 WRITE(mstu(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47020 READ(lfn,*) xnusug(7),xnusug(8)
47021 ELSEIF (inusug.EQ.4) THEN
47022 WRITE(mstu(11),*) 'Enter GUT scale M(ul), M(dr),'
47023 & //' M(ur), M(el), M(er):'
47024 READ(lfn,*) xnusug(13),xnusug(11),xnusug(12),
47025 & xnusug(10),xnusug(9)
47026 ELSEIF (inusug.EQ.5) THEN
47027 WRITE(mstu(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47028 & //' M(Ll), M(Lr):'
47029 READ(lfn,*) xnusug(18),xnusug(16),xnusug(17),
47030 & xnusug(15),xnusug(14)
47031 ENDIF
47032 GOTO 110
47033 ENDIF
47034 ELSEIF (imodel.EQ.2.OR.imodel.EQ.5) THEN
47035 imss(11)=1
47036 WRITE(mstu(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47037 & ,' sgn(mu), M_t, C_gv:'
47038 READ(lfn,*) m0,mhf,a0,tanb,sgnmu,mt,xcmgv
47039 xgmin(7)=xcmgv
47040 xgmin(8)=1.
47041C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47042 ampl=2.4d18
47043 amgvss=m0*mhf*xcmgv/sqrt(3d0)/ampl
47044 IF (imodel.EQ.5) THEN
47045 imodel=2
47046 WRITE(mstu(11),*) 'Rsl = factor multiplying gaugino'
47047 & ,' masses at M_mes'
47048 WRITE(mstu(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47049 & ,' shifts at M_mes'
47050 WRITE(mstu(11),*) 'd_Y = mass**2 shifts proportional to',
47051 & ' Y at M_mes'
47052 WRITE(mstu(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47053 & ,'SU(2),SU(3)'
47054 WRITE(mstu(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47055 & ,' n5_2, n5_3'
47056 READ(lfn,*) xgmin(8),xgmin(9),xgmin(10),xgmin(11),xgmin(12),
47057 $ xgmin(13),xgmin(14)
47058 ENDIF
47059 ELSE
47060 WRITE(mstu(11),*) 'Invalid model choice.'
47061 GOTO 9999
47062 ENDIF
47063 ENDIF
47064
47065 120 mzero=m0
47066 mhlf=mhf
47067 azero=a0
47068C TANB=REAL(RMSS(5))
47069C SGNMU=REAL(RMSS(4))
47070 mtop=mt
47071
47072C...Initialize MSSM parameter array
47073 130 DO 140 ipar=1,72
47074 super(ipar)=0.0
47075 140 CONTINUE
47076C...Call ISASUGRA
47077 CALL sugra(mzero,mhlf,azero,tanb,sgnmu,mtop,imodel)
47078C...Check whether ISASUSY thought the model was OK.
47079 IF (nogood.NE.0) THEN
47080 IF (nogood.EQ.1) CALL pyerrm(26
47081 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47082 IF (nogood.EQ.2) CALL pyerrm(26
47083 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47084 IF (nogood.EQ.3) CALL pyerrm(26
47085 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47086 IF (nogood.EQ.4) CALL pyerrm(26
47087 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47088 IF (nogood.EQ.7) CALL pyerrm(26
47089 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47090 IF (nogood.EQ.8) CALL pyerrm(26
47091 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47092C...Give warning, but don't stop, if LSP not ~chi_10.
47093 IF (nogood.EQ.5) CALL pyerrm(16
47094 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47095 ENDIF
47096C...Warn about possible GUT scale tachyons.
47097 IF (itachy.NE.0) CALL pyerrm(16,
47098 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47099C...Finalize spectrum (last iteration)
47100C...(Thanks to A. Raklev for pointing this out.)
47101C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47102 CALL ssmssm(xisain(1),xisain(2),xisain(3),
47103 $ xisain(4),xisain(5),xisain(6),xisain(7),xisain(8),xisain(9),
47104 $ xisain(10),xisain(11),xisain(12),xisain(13),xisain(14),
47105 $ xisain(15),xisain(16),xisain(17),xisain(18),xisain(19),
47106 $ xisain(20),xisain(21),xisain(22),xisain(23),xisain(24),
47107 $ mtop,iallow,1)
47108
47109C...M1, M2, M3.
47110 rmss(1)=dble(gss(7))
47111 rmss(2)=dble(gss(8))
47112 rmss(3)=dble(gss(9))
47113 rmsoft(1)=dble(gss(7))
47114 rmsoft(2)=dble(gss(8))
47115 rmsoft(3)=dble(gss(9))
47116C...Mu = - Higgsino mass.
47117 rmss(4)=-super(29)
47118 rmss(5)=tanb
47119C...Slepton and squark masses. 2 first generations.
47120 rmss(6)=0.5*(super(18)+super(20))
47121 rmss(7)=0.5*(super(19)+super(21))
47122 rmss(8)=0.25*(super(2)+super(4)+super(6)+super(8))
47123 rmss(9)=0.25*(super(3)+super(5)+super(7)+super(9))
47124C...Third generation.
47125 rmss(10)=0.5*(super(14)+super(10))
47126 rmss(11)=super(11)
47127 rmss(12)=super(15)
47128 rmss(13)=super(22)
47129 rmss(14)=super(23)
47130C...SLHA: store exact soft spectrum in RMSOFT
47131 rmsoft(31)=super(18)
47132 rmsoft(32)=super(20)
47133 rmsoft(33)=super(22)
47134 rmsoft(34)=super(19)
47135 rmsoft(35)=super(21)
47136 rmsoft(36)=super(23)
47137 rmsoft(41)=0.5d0*(super(2)+super(4))
47138 rmsoft(42)=0.5d0*(super(6)+super(8))
47139 rmsoft(43)=0.5d0*(super(10)+super(14))
47140 rmsoft(44)=super(3)
47141 rmsoft(45)=super(9)
47142 rmsoft(46)=super(15)
47143 rmsoft(47)=super(5)
47144 rmsoft(48)=super(7)
47145 rmsoft(49)=super(11)
47146
47147C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47148 rmss(15)=super(62)
47149 rmss(16)=super(60)
47150 rmss(17)=super(64)
47151 rmss(26)=super(63)
47152 rmss(27)=super(61)
47153 rmss(28)=super(65)
47154C...SLHA trilinears
47155 DO 142 k1=1,3
47156 DO 141 k2=1,3
47157 ae(k1,k2)=0d0
47158 au(k1,k2)=0d0
47159 ad(k1,k2)=0d0
47160 141 CONTINUE
47161 142 CONTINUE
47162 ae(3,3)=super(64)
47163 au(3,3)=super(60)
47164 ad(3,3)=super(62)
47165C...Higgs mixing angle alpha (Gunion-Haber convention).
47166 rmss(18)=-super(59)
47167C...A0 mass.
47168 rmss(19)=super(57)
47169C...GUT scale coupling
47170 rmss(20)=agutss
47171C...Gravitino mass (for future compatibility)
47172 rmss(21)=max(rmss(21),dble(super(66)))
47173
47174C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47175C...Higgs sector.
47176 pmas(pycomp(25),1)=abs(super(55))
47177 pmas(pycomp(35),1)=abs(super(56))
47178 pmas(pycomp(36),1)=abs(super(57))
47179 pmas(pycomp(37),1)=abs(super(58))
47180C...Gluino.
47181 pmas(pycomp(ksusy1+21),1)=abs(super(1))
47182C...Squarks and Sleptons.
47183 DO 150 ilr=1,2
47184 ilrm=ilr-1
47185 pmas(pycomp(ilr*ksusy1+1),1)=abs(super(4+ilrm))
47186 pmas(pycomp(ilr*ksusy1+2),1)=abs(super(2+ilrm))
47187 pmas(pycomp(ilr*ksusy1+3),1)=abs(super(6+ilrm))
47188 pmas(pycomp(ilr*ksusy1+4),1)=abs(super(8+ilrm))
47189 pmas(pycomp(ilr*ksusy1+5),1)=abs(super(12+ilrm))
47190 pmas(pycomp(ilr*ksusy1+6),1)=abs(super(16+ilrm))
47191 pmas(pycomp(ilr*ksusy1+11),1)=abs(super(18+ilrm))
47192 pmas(pycomp(ilr*ksusy1+13),1)=abs(super(20+ilrm))
47193 pmas(pycomp(ilr*ksusy1+15),1)=abs(super(24+ilrm))
47194 150 CONTINUE
47195 pmas(pycomp(ksusy1+12),1)=abs(super(26))
47196 pmas(pycomp(ksusy1+14),1)=abs(super(27))
47197 pmas(pycomp(ksusy1+16),1)=abs(super(28))
47198C...Neutralinos.
47199 pmas(pycomp(ksusy1+22),1)=abs(super(31))
47200 pmas(pycomp(ksusy1+23),1)=abs(super(32))
47201 pmas(pycomp(ksusy1+25),1)=abs(super(33))
47202 pmas(pycomp(ksusy1+35),1)=abs(super(34))
47203C...Signed masses (extra minus from going to G-H convention).
47204 smz(1)=-super(31)
47205 smz(2)=-super(32)
47206 smz(3)=-super(33)
47207 smz(4)=-super(34)
47208C...Charginos
47209 pmas(pycomp(ksusy1+24),1)=abs(super(51))
47210 pmas(pycomp(ksusy1+37),1)=abs(super(52))
47211C...Signed masses (extra minus from going to G-H convention).
47212 smw(1)=-super(51)
47213 smw(2)=-super(52)
47214
47215C... Neutralino Mixing.
47216 DO 160 in=1,4
47217 zmix(in,1)= super(38+4*(in-1))
47218 zmix(in,2)= super(37+4*(in-1))
47219 zmix(in,3)=-super(36+4*(in-1))
47220 zmix(in,4)=-super(35+4*(in-1))
47221 160 CONTINUE
47222C...Chargino Mixing (PYTHIA same angle as HERWIG).
47223 thx=1d0
47224 thy=1d0
47225 IF (super(53).GT.0) thx=-1d0
47226 IF (super(54).GT.0) thy=-1d0
47227 umix(1,1) = -sin(super(53))
47228 umix(1,2) = -cos(super(53))
47229 umix(2,1) = -thx*cos(super(53))
47230 umix(2,2) = thx*sin(super(53))
47231 vmix(1,1) = -sin(super(54))
47232 vmix(1,2) = -cos(super(54))
47233 vmix(2,1) = -thy*cos(super(54))
47234 vmix(2,2) = thy*sin(super(54))
47235C...Sfermion mixing (PYTHIA same angle as ISAJET)
47236 sfmix(5,1)=cos(super(63))
47237 sfmix(5,2)=sin(super(63))
47238 sfmix(5,3)=-sin(super(63))
47239 sfmix(5,4)=cos(super(63))
47240 sfmix(6,1)=cos(super(61))
47241 sfmix(6,2)=sin(super(61))
47242 sfmix(6,3)=-sin(super(61))
47243 sfmix(6,4)=cos(super(61))
47244 sfmix(15,1)=cos(super(65))
47245 sfmix(15,2)=sin(super(65))
47246 sfmix(15,3)=-sin(super(65))
47247 sfmix(15,4)=cos(super(65))
47248
47249 IF (mstp(122).NE.0) THEN
47250C...Print a few lines to make the user know what's happening
47251 isaver=visaje()
47252 WRITE(mstu(11),5000) doc, isaver
47253 WRITE(mstu(11),5100)
47254 IF (imodel.EQ.1) THEN
47255 WRITE(mstu(11),5200) mzero, mhlf, azero, tanb, nint(sgnmu),
47256 & mtop
47257 WRITE(mstu(11),5300)
47258 ENDIF
47259 WRITE(mstu(11),5500) 'Pole masses'
47260 WRITE(mstu(11),5700) (super(ip),ip=2,16,2),(super(ip),ip=3,17,2)
47261 WRITE(mstu(11),5800) (super(ip),ip=18,24,2),(super(ip),ip=26,28)
47262 & ,(super(ip),ip=19,25,2)
47263 WRITE(mstu(11),5900) super(1),(smz(ip),ip=1,4), (smw(ip)
47264 & ,ip=1,2)
47265 WRITE(mstu(11),5400)
47266 WRITE(mstu(11),6000) (super(ip),ip=55,58)
47267 WRITE(mstu(11),5400)
47268 WRITE(mstu(11),5500) 'EW scale mixing structure'
47269 WRITE(mstu(11),6100) ((zmix(i,j), j=1,4),i=1,4)
47270 WRITE(mstu(11),6200) (umix(1,j), j=1,2),(vmix(1,j),j=1,2)
47271 & ,(umix(2,j), j=1,2),(vmix(2,j),j=1,2)
47272 WRITE(mstu(11),6300) (sfmix(5,j), j=1,2),(sfmix(6,j),j=1,2)
47273 & ,(sfmix(15,j), j=1,2),(sfmix(5,j),j=3,4),(sfmix(6,j), j=3,4
47274 & ),(sfmix(15,j),j=3,4)
47275 WRITE(mstu(11),5400)
47276 WRITE(mstu(11),6450) rmss(18)
47277 WRITE(mstu(11),5400)
47278 WRITE(mstu(11),5500) 'Couplings'
47279 WRITE(mstu(11),6400) rmss(15),rmss(16),rmss(17),rmss(20)
47280 WRITE(mstu(11),5400)
47281 ENDIF
47282
47283C...Call FeynHiggs to improve Higgs sector if requested
47284 IF (imss(4).EQ.3) THEN
47285 IF (mstp(122).NE.0) WRITE(mstu(11),'(1x,"*"/1x,"*",A)')
47286 & ' (PYSUGI:) Now calling FeynHiggs.'
47287 CALL pyfeyn(ierr)
47288 IF (ierr.EQ.0) THEN
47289 imss(4)=2
47290 IF (mstp(122).NE.0) THEN
47291 WRITE(mstu(11),5400)
47292 WRITE(mstu(11),5500)
47293 & 'Corrected Higgs masses and mixing'
47294 WRITE(mstu(11),6000) pmas(25,1),pmas(35,1),pmas(36,1),
47295 & pmas(37,1)
47296 WRITE(mstu(11),6450) rmss(18)
47297 WRITE(mstu(11),5400)
47298 ENDIF
47299 ENDIF
47300 ENDIF
47301
47302 IF (mstp(122).NE.0) WRITE(mstu(11),6500)
47303
47304C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47305C...output by ISASUSY.
47306 imss(4)=max(2,imss(4))
47307
47308 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47309 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,a
47310 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,a/1x,'*')
47311 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47312 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47313 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(f8.2,1x),i8,2x,f8.2)
47314 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47315 & ,'----------------')
47316 5400 FORMAT(1x,'*',1x,a)
47317 5500 FORMAT(1x,'*',1x,a,':')
47318 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47319 & 1x,'*',2x,1p,2(1x,e8.2),2x,e8.2)
47320 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47321 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47322 & '~t(12)'/1x,'*',2x,'L',1x,8(f8.2,1x)/1x,'*',2x,'R',1x,8(f8.2
47323 & ,1x))
47324 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47325 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47326 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(f8.2,1x)/1x,'*',2x,'R',1x,4(f8
47327 & .2,1x))
47328 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47329 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47330 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(f8.2,1x))
47331 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47332 & ,1x,4x,'H+'/1x,'*',3x,1x,5(f8.2,1x))
47333 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47334 & ,1x,4x,'H+'/1x,'*',3x,1x,5(f8.2,1x),3x,'(Before FeynHiggs)')
47335 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47336 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47337 & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47338 & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47339 & ,1x,f6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47340 & ,1x,f6.3,1x),'|')
47341 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47342 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47343 & ,'~chi_1+',1x,2('|',1x,f6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47344 & ,f6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,f6.3,1x),'|',9x
47345 & ,'~chi_2+',1x,2('|',1x,f6.3,1x),'|')
47346 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47347 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47348 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47349 & 1x,'*',3x,'~b_1',1x,2('|',1x,f6.3,1x),'|',3x,'~t_1',1x,2('|'
47350 & ,1x,f6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,f6.3,1x),'|'/
47351 & 1x,'*',3x,'~b_2',1x,2('|',1x,f6.3,1x),'|',3x,'~t_2',1x,2('|'
47352 & ,1x,f6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,f6.3,1x),'|')
47353 6400 FORMAT(1x,'*',3x,'A_b = ',f8.2,4x,'A_t = ',f8.2,4x,'A_tau = ',f8.2
47354 & ,4x,'Alpha_GUT = ',f8.2)
47355 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',f8.4)
47356 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47357
47358 9999 RETURN
47359 END
47360
47361C*********************************************************************
47362
47363C...PYFEYN
47364C...Interface to FeynHiggs for MSSM Higgs sector.
47365C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47366C...P. Skands
47367
47368 SUBROUTINE pyfeyn(IERR)
47369
47370C...Double precision and integer declarations.
47371 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47372 IMPLICIT INTEGER(I-N)
47373 INTEGER PYK,PYCHGE,PYCOMP
47374C...Commonblocks.
47375 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47376 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47377C...SUSY blocks
47378 common/pymssm/imss(0:99),rmss(0:99)
47379C...FeynHiggs variables
47380 DOUBLE PRECISION RMHIGG(4)
47381 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47382 DOUBLE COMPLEX DMU,
47383 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47384 & DM1, DM2, DM3
47385C...SLHA Common Block
47386 common/pylh3p/modsel(200),parmin(100),parext(200),rmsoft(0:100),
47387 & au(3,3),ad(3,3),ae(3,3)
47388 SAVE /pydat1/,/pydat2/,/pymssm/,/pylh3p/
47389
47390 ierr=0
47391 CALL fhsetflags(ierr,4,0,0,2,0,2,1,1)
47392 IF (ierr.NE.0) THEN
47393 CALL pyerrm(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47394 & //'Will not use FeynHiggs for this run.')
47395 RETURN
47396 ENDIF
47397 q=rmsoft(0)
47398 dmb=pmas(5,1)
47399 dmt=pmas(6,1)
47400 dmz=pmas(23,1)
47401 dmw=pmas(24,1)
47402 dma=pmas(36,1)
47403 dm1=rmsoft(1)
47404 dm2=rmsoft(2)
47405 dm3=rmsoft(3)
47406 dtanb=rmss(5)
47407 dmu=rmss(4)
47408 dm3sl=rmsoft(33)
47409 dm3se=rmsoft(36)
47410 dm3sq=rmsoft(43)
47411 dm3su=rmsoft(46)
47412 dm3sd=rmsoft(49)
47413 dm2sl=rmsoft(32)
47414 dm2se=rmsoft(35)
47415 dm2sq=rmsoft(42)
47416 dm2su=rmsoft(45)
47417 dm2sd=rmsoft(48)
47418 dm1sl=rmsoft(31)
47419 dm1se=rmsoft(34)
47420 dm1sq=rmsoft(41)
47421 dm1su=rmsoft(44)
47422 dm1sd=rmsoft(47)
47423 ae33=ae(3,3)
47424 ae22=ae(2,2)
47425 ae11=ae(1,1)
47426 au33=au(3,3)
47427 au22=au(2,2)
47428 au11=au(1,1)
47429 ad33=ad(3,3)
47430 ad22=ad(2,2)
47431 ad11=ad(1,1)
47432 CALL fhsetpara(ierr, 1d0, dmt, dmb, dmw, dmz, dtanb,
47433 & dma,0d0, dm3sl, dm3se, dm3sq, dm3su, dm3sd,
47434 & dm2sl, dm2se, dm2sq, dm2su, dm2sd,
47435 & dm1sl, dm1se, dm1sq, dm1su, dm1sd,dmu,
47436 & ae33, au33, ad33, ae22, au22, ad22, ae11, au11, ad11,
47437 & dm1, dm2, dm3, 0d0, 0d0,q,q,q)
47438 IF (ierr.NE.0) THEN
47439 CALL pyerrm(11,'(PYHGGM:) Caught error from FHSETPARA.'
47440 & //' Will not use FeynHiggs for this run.')
47441 RETURN
47442 ENDIF
47443C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47444 saeff=0d0
47445 CALL fhhiggscorr(ierr, rmhigg, saeff, uhiggs)
47446 IF (ierr.NE.0) THEN
47447 CALL pyerrm(11,'(PYFEYN:) Caught error from FHHIG'//
47448 & 'GSCORR. Will not use FeynHiggs for this run.')
47449 RETURN
47450 ENDIF
47451 alpha = asin(dble(saeff))
47452 r=rmss(18)/alpha
47453 IF (r.LT.0d0.OR.abs(r).GT.1.2d0.OR.abs(r).LT.0.8d0) THEN
47454 CALL pyerrm(1,'(PYFEYN:) Large corrections in Higgs sector.')
47455 WRITE(mstu(11),*) ' Old Alpha:', rmss(18)
47456 WRITE(mstu(11),*) ' New Alpha:', alpha
47457 ENDIF
47458 IF (rmhigg(1).LT.0.85d0*pmas(25,1).OR.rmhigg(1).GT.
47459 & 1.15d0*pmas(25,1)) THEN
47460 CALL pyerrm(1,'(PYFEYN:) Large corrections in Higgs sector.')
47461 WRITE(mstu(11),*) ' Old m(h0):', pmas(25,1)
47462 WRITE(mstu(11),*) ' New m(h0):', rmhigg(1)
47463 ENDIF
47464 rmss(18)=alpha
47465 pmas(25,1)=rmhigg(1)
47466 pmas(35,1)=rmhigg(2)
47467 pmas(36,1)=rmhigg(3)
47468 pmas(37,1)=rmhigg(4)
47469
47470 RETURN
47471 END
47472
47473C*********************************************************************
47474
47475C...PYRNMQ
47476C...Determines the running mass of Squarks.
47477
47478 FUNCTION pyrnmq(ID,DTERM)
47479
47480C...Double precision and integer declarations.
47481 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47482 IMPLICIT INTEGER(I-N)
47483 INTEGER PYK,PYCHGE,PYCOMP
47484C...Commonblock.
47485 common/pymssm/imss(0:99),rmss(0:99)
47486 SAVE /pymssm/
47487
47488C...Local variables.
47489 DOUBLE PRECISION PI,R
47490 DOUBLE PRECISION TOL
47491 DOUBLE PRECISION CI(3)
47492 EXTERNAL pyalps
47493 DOUBLE PRECISION PYALPS
47494 DATA tol/0.001d0/
47495 DATA pi,r/3.141592654d0,.61803399d0/
47496 DATA ci/0.47d0,0.07d0,0.02d0/
47497
47498 c=1d0-r
47499 ca=ci(id)
47500 ag=(0.71d0)**2/4d0/pi
47501 ag=rmss(20)
47502 xm0=rmss(8)
47503 xmg=rmss(1)
47504 xm02=xm0*xm0
47505 xmg2=xmg*xmg
47506
47507 as=pyalps(xm02+6d0*xmg2)
47508 cg=8d0/9d0*((as/ag)**2-1d0)
47509 bx=xm02+(ca+cg)*xmg2+dterm
47510 ax=min(50d0**2,0.5d0*bx)
47511 cx=max(2000d0**2,2d0*bx)
47512
47513 x0=ax
47514 x3=cx
47515 IF(abs(cx-bx).GT.abs(bx-ax))THEN
47516 x1=bx
47517 x2=bx+c*(cx-bx)
47518 ELSE
47519 x2=bx
47520 x1=bx-c*(bx-ax)
47521 ENDIF
47522 as1=pyalps(x1)
47523 cg=8d0/9d0*((as1/ag)**2-1d0)
47524 f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
47525 as2=pyalps(x2)
47526 cg=8d0/9d0*((as2/ag)**2-1d0)
47527 f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
47528 100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
47529 IF(f2.LT.f1) THEN
47530 x0=x1
47531 x1=x2
47532 x2=r*x1+c*x3
47533 f1=f2
47534 as2=pyalps(x2)
47535 cg=8d0/9d0*((as2/ag)**2-1d0)
47536 f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)
47537 ELSE
47538 x3=x2
47539 x2=x1
47540 x1=r*x2+c*x0
47541 f2=f1
47542 as1=pyalps(x1)
47543 cg=8d0/9d0*((as1/ag)**2-1d0)
47544 f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)
47545 ENDIF
47546 GOTO 100
47547 ENDIF
47548 IF(f1.LT.f2) THEN
47549 pyrnmq=x1
47550 xmin=x1
47551 ELSE
47552 pyrnmq=x2
47553 xmin=x2
47554 ENDIF
47555
47556 RETURN
47557 END
47558
47559C*********************************************************************
47560
47561C...PYTHRG
47562C...Calculates the mass eigenstates of the third generation sfermions.
47563C...Created: 5-31-96
47564
47565 SUBROUTINE pythrg
47566
47567C...Double precision and integer declarations.
47568 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47569 IMPLICIT INTEGER(I-N)
47570 INTEGER PYK,PYCHGE,PYCOMP
47571C...Parameter statement to help give large particle numbers.
47572 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
47573 &kexcit=4000000,kdimen=5000000)
47574C...Commonblocks.
47575 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47576 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47577 common/pymssm/imss(0:99),rmss(0:99)
47578 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
47579 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
47580 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
47581
47582C...Local variables.
47583 DOUBLE PRECISION BETA
47584 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47585 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47586 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47587 DOUBLE PRECISION ATR,AMQR,AMQL
47588 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47589 INTEGER IF,I,J,II,JJ,IT,L
47590 LOGICAL DTERM
47591 DATA small/1d-3/
47592 DATA id1/10,10,13/
47593 DATA id2/5,6,15/
47594 DATA id3/15,16,17/
47595 DATA id4/11,12,14/
47596 DATA dterm/.true./
47597
47598 xmz2=pmas(23,1)**2
47599 xmw2=pmas(24,1)**2
47600 tanb=rmss(5)
47601 xmu=-rmss(4)
47602 beta=atan(tanb)
47603 cos2b=cos(2d0*beta)
47604
47605C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47606
47607 iopt=imss(5)
47608 IF(iopt.EQ.1) THEN
47609 ctt=dcos(rmss(27))
47610 ctt2=ctt**2
47611 stt=dsin(rmss(27))
47612 stt2=stt**2
47613 xm12=rmss(10)**2
47614 xm22=rmss(12)**2
47615 xmql2=ctt2*xm12+stt2*xm22
47616 xmqr2=stt2*xm12+ctt2*xm22
47617 xmf2=pymrun(6,pmas(6,1)**2)**2
47618 atop=-xmu/tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
47619 rmss(16)=atop
47620C......SUBTRACT OUT D-TERM AND FERMION MASS
47621 xmql2=xmql2-xmf2-(4d0*xmw2-xmz2)*cos2b/6d0
47622 xmqr2=xmqr2-xmf2+(xmw2-xmz2)*cos2b*2d0/3d0
47623 IF(xmql2.GE.0d0) THEN
47624 rmss(10)=sqrt(xmql2)
47625 ELSE
47626 rmss(10)=-sqrt(-xmql2)
47627 ENDIF
47628 IF(xmqr2.GE.0d0) THEN
47629 rmss(12)=sqrt(xmqr2)
47630 ELSE
47631 rmss(12)=-sqrt(-xmqr2)
47632 ENDIF
47633
47634C SAME FOR BOTTOM SQUARK
47635 ctt=dcos(rmss(26))
47636 ctt2=ctt**2
47637 stt=dsin(rmss(26))
47638 stt2=stt**2
47639 xm22=rmss(11)**2
47640 xmf2=pymrun(5,pmas(6,1)**2)**2
47641 xmql2=sign(rmss(10)**2,rmss(10))-(2d0*xmw2+xmz2)*cos2b/6d0+xmf2
47642 IF(abs(ctt).GE..9999d0) THEN
47643 abot=-xmu*tanb
47644 xmqr2=rmss(11)**2
47645 ELSEIF(abs(ctt).LE.1d-4) THEN
47646 abot=-xmu*tanb
47647 xmqr2=rmss(11)**2
47648 ELSE
47649 xm12=(xmql2-stt2*xm22)/ctt2
47650 xmqr2=stt2*xm12+ctt2*xm22
47651 abot=-xmu*tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
47652 ENDIF
47653 rmss(15)=abot
47654C......SUBTRACT OUT D-TERM AND FERMION MASS
47655 xmqr2=xmqr2-(xmw2-xmz2)*cos2b/3d0-xmf2
47656 IF(xmqr2.GE.0d0) THEN
47657 rmss(11)=sqrt(xmqr2)
47658 ELSE
47659 rmss(11)=-sqrt(-xmqr2)
47660 ENDIF
47661C SAME FOR TAU SLEPTON
47662 ctt=dcos(rmss(28))
47663 ctt2=ctt**2
47664 stt=dsin(rmss(28))
47665 stt2=stt**2
47666 xm12=rmss(13)**2
47667 xm22=rmss(14)**2
47668 xmql2=ctt2*xm12+stt2*xm22
47669 xmqr2=stt2*xm12+ctt2*xm22
47670 xmfr=pmas(15,1)
47671 xmf2=xmfr**2
47672 atau=-xmu*tanb+ctt*stt*(xm12-xm22)/sqrt(xmf2)
47673 rmss(17)=atau
47674C......SUBTRACT OUT D-TERM AND FERMION MASS
47675 xmql2=xmql2-xmf2+(-.5d0*xmz2+xmw2)*cos2b
47676 xmqr2=xmqr2-xmf2+(xmz2-xmw2)*cos2b
47677 IF(xmql2.GE.0d0) THEN
47678 rmss(13)=sqrt(xmql2)
47679 ELSE
47680 rmss(13)=-sqrt(-xmql2)
47681 ENDIF
47682 IF(xmqr2.GE.0d0) THEN
47683 rmss(14)=sqrt(xmqr2)
47684 ELSE
47685 rmss(14)=-sqrt(-xmqr2)
47686 ENDIF
47687 ENDIF
47688 DO 170 l=1,3
47689 amql=rmss(id1(l))
47690 IF(amql.LT.0d0) THEN
47691 xmql2=-amql**2
47692 ELSE
47693 xmql2=amql**2
47694 ENDIF
47695 atr=rmss(id3(l))
47696 amqr=rmss(id4(l))
47697 IF(amqr.LT.0d0) THEN
47698 xmqr2=-amqr**2
47699 ELSE
47700 xmqr2=amqr**2
47701 ENDIF
47702 if=id2(l)
47703 xmf=pymrun(IF,pmas(6,1)**2)
47704 xmf2=xmf**2
47705 am2(1,1)=xmql2+xmf2
47706 am2(2,2)=xmqr2+xmf2
47707 IF(am2(1,1).EQ.am2(2,2)) am2(2,2)=am2(2,2)*1.00001d0
47708 IF(dterm) THEN
47709 IF(l.EQ.1) THEN
47710 am2(1,1)=am2(1,1)-(2d0*xmw2+xmz2)*cos2b/6d0
47711 am2(2,2)=am2(2,2)+(xmw2-xmz2)*cos2b/3d0
47712 am2(1,2)=xmf*(atr+xmu*tanb)
47713 ELSEIF(l.EQ.2) THEN
47714 am2(1,1)=am2(1,1)+(4d0*xmw2-xmz2)*cos2b/6d0
47715 am2(2,2)=am2(2,2)-(xmw2-xmz2)*cos2b*2d0/3d0
47716 am2(1,2)=xmf*(atr+xmu/tanb)
47717 ELSEIF(l.EQ.3) THEN
47718 IF(imss(8).EQ.1) THEN
47719 am2(1,1)=rmss(6)**2
47720 am2(2,2)=rmss(7)**2
47721 am2(1,2)=0d0
47722 rmss(13)=rmss(6)
47723 rmss(14)=rmss(7)
47724 ELSE
47725 am2(1,1)=am2(1,1)-(-.5d0*xmz2+xmw2)*cos2b
47726 am2(2,2)=am2(2,2)-(xmz2-xmw2)*cos2b
47727 am2(1,2)=xmf*(atr+xmu*tanb)
47728 ENDIF
47729 ENDIF
47730 ENDIF
47731 am2(2,1)=am2(1,2)
47732 detm=am2(1,1)*am2(2,2)-am2(2,1)**2
47733 IF(detm.LT.0d0) THEN
47734 WRITE(mstu(11),*) id2(l),detm,am2
47735 CALL pyerrm(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47736 ENDIF
47737 same=0.5d0*(am2(1,1)+am2(2,2))
47738 diff=0.5d0*sqrt((am2(1,1)-am2(2,2))**2+4d0*am2(1,2)*am2(2,1))
47739 xmf12=same-diff
47740 xmf22=same+diff
47741 it=0
47742 IF(xmf22-xmf12.GT.0d0) THEN
47743 rt(1,1) = sqrt(max(0d0,(xmf22-am2(1,1))/(xmf22-xmf12)))
47744 rt(2,2) = rt(1,1)
47745 rt(1,2) = -sign(sqrt(max(0d0,1d0-rt(1,1)**2)),
47746 & am2(1,2)/(xmf22-xmf12))
47747 rt(2,1) = -rt(1,2)
47748 ELSE
47749 rt(1,1) = 1d0
47750 rt(2,2) = rt(1,1)
47751 rt(1,2) = 0d0
47752 rt(2,1) = -rt(1,2)
47753 ENDIF
47754 100 CONTINUE
47755 it=it+1
47756
47757 DO 140 i=1,2
47758 DO 130 jj=1,2
47759 di(i,jj)=0d0
47760 DO 120 ii=1,2
47761 DO 110 j=1,2
47762 di(i,jj)=di(i,jj)+rt(i,j)*am2(j,ii)*rt(jj,ii)
47763 110 CONTINUE
47764 120 CONTINUE
47765 130 CONTINUE
47766 140 CONTINUE
47767
47768 IF(di(1,1).GT.di(2,2)) THEN
47769 WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION '
47770 WRITE(mstu(11),*) l,sqrt(xmf12),sqrt(xmf22)
47771 WRITE(mstu(11),*) am2
47772 WRITE(mstu(11),*) di
47773 WRITE(mstu(11),*) rt
47774 di(1,1)=-rt(2,1)
47775 di(2,2)=rt(1,2)
47776 di(1,2)=-rt(2,2)
47777 di(2,1)=rt(1,1)
47778 DO 160 i=1,2
47779 DO 150 j=1,2
47780 rt(i,j)=di(i,j)
47781 150 CONTINUE
47782 160 CONTINUE
47783 GOTO 100
47784 ELSEIF(abs(di(1,2)*di(2,1)/di(1,1)/di(2,2)).GT.small) THEN
47785 WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
47786 & ' OFF DIAGONAL ELEMENTS '
47787 WRITE(mstu(11),*) 'MASSES = ',l,sqrt(xmf12),sqrt(xmf22)
47788 WRITE(mstu(11),*) di
47789 WRITE(mstu(11),*) ' ROTATION = ',rt
47790C...STOP
47791 ELSEIF(di(1,1).LT.0d0.OR.di(2,2).LT.0d0) THEN
47792 WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//
47793 & ' NEGATIVE MASSES '
47794 CALL pystop(111)
47795 ENDIF
47796 pmas(pycomp(ksusy1+if),1)=sqrt(xmf12)
47797 pmas(pycomp(ksusy2+if),1)=sqrt(xmf22)
47798 sfmix(IF,1)=rt(1,1)
47799 sfmix(IF,2)=rt(1,2)
47800 sfmix(IF,3)=rt(2,1)
47801 sfmix(IF,4)=rt(2,2)
47802 170 CONTINUE
47803
47804C.....TAU SNEUTRINO MASS...L=3
47805
47806 xarg=am2(1,1)+xmw2*cos2b
47807 IF(xarg.LT.0d0) THEN
47808 WRITE(mstu(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47809 & ' FROM THE SUM RULE. '
47810 WRITE(mstu(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47811 RETURN
47812 ELSE
47813 pmas(pycomp(ksusy1+16),1)=sqrt(xarg)
47814 ENDIF
47815
47816 RETURN
47817 END
47818C*********************************************************************
47819
47820C...PYINOM
47821C...Finds the mass eigenstates and mixing matrices for neutralinos
47822C...and charginos.
47823
47824 SUBROUTINE pyinom
47825
47826C...Double precision and integer declarations.
47827 IMPLICIT DOUBLE PRECISION(a-h, o-z)
47828 IMPLICIT INTEGER(I-N)
47829 INTEGER PYCOMP
47830C...Parameter statement to help give large particle numbers.
47831 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
47832 &kexcit=4000000,kdimen=5000000)
47833C...Commonblocks.
47834 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
47835 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
47836 common/pymssm/imss(0:99),rmss(0:99)
47837 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
47838 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
47839 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
47840
47841C...Local variables.
47842 DOUBLE PRECISION XMW,XMZ,XM(4)
47843 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47844 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47845 DOUBLE PRECISION COSW,SINW
47846 DOUBLE PRECISION XMU
47847 DOUBLE PRECISION TANB,COSB,SINB
47848 DOUBLE PRECISION XM1,XM2,XM3,BETA
47849 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47850 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47851 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47852 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47853 DOUBLE PRECISION PYALPS,PYALEM
47854 DOUBLE PRECISION PYRNM3
47855 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47856 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47857 DATA kfnchi/1000022,1000023,1000025,1000035/
47858
47859 iopt=imss(2)
47860 IF(imss(1).EQ.2) THEN
47861 iopt=1
47862 ENDIF
47863C...M1, M2, AND M3 ARE INDEPENDENT
47864 IF(iopt.EQ.0) THEN
47865 xm1=rmss(1)
47866 xm2=rmss(2)
47867 xm3=rmss(3)
47868 ELSEIF(iopt.GE.1) THEN
47869 q2=pmas(23,1)**2
47870 aem=pyalem(q2)
47871 a2=aem/paru(102)
47872 a1=aem/(1d0-paru(102))
47873 xm1=rmss(1)
47874 xm2=rmss(2)
47875 IF(imss(1).EQ.2) xm1=rmss(1)/rmss(20)*a1*5d0/3d0
47876 IF(iopt.EQ.1) THEN
47877 xm2=xm1*a2/a1*3d0/5d0
47878 rmss(2)=xm2
47879 ELSEIF(iopt.EQ.3) THEN
47880 xm1=xm2*5d0/3d0*a1/a2
47881 rmss(1)=xm1
47882 ENDIF
47883 xm3=pyrnm3(xm2/a2)
47884 rmss(3)=xm3
47885 IF(xm3.LE.0d0) THEN
47886 WRITE(mstu(11),*) ' ERROR WITH M3 = ',xm3
47887 CALL pystop(105)
47888 ENDIF
47889 ENDIF
47890
47891C...GLUINO MASS
47892 IF(imss(3).EQ.1) THEN
47893 pmas(pycomp(ksusy1+21),1)=abs(xm3)
47894 ELSE
47895 aq=0d0
47896 DO 110 i=1,4
47897 DO 100 ilr=1,2
47898 rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
47899 aq=aq+0.5d0*((2d0-rm1)*(rm1*log(rm1)-1d0)
47900 & +(1d0-rm1)**2*log(abs(1d0-rm1)))
47901 100 CONTINUE
47902 110 CONTINUE
47903
47904 DO 130 i=5,6
47905 DO 120 ilr=1,2
47906 rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2
47907 rm2=pmas(i,1)**2/xm3**2
47908 arg=(rm1-rm2-1d0)**2-4d0*rm2**2
47909 IF(arg.GE.0d0) THEN
47910 x0=0.5d0*(1d0+rm2-rm1-sqrt(arg))
47911 ax0=abs(x0)
47912 x1=0.5d0*(1d0+rm2-rm1+sqrt(arg))
47913 ax1=abs(x1)
47914 IF(x0.EQ.1d0) THEN
47915 at=-1d0
47916 bt=0.25d0
47917 ELSEIF(x0.EQ.0d0) THEN
47918 at=0d0
47919 bt=-0.25d0
47920 ELSE
47921 at=0.5d0*log(abs(1d0-x0))*(1d0-x0**2)+
47922 & 0.5d0*x0**2*log(ax0)
47923 bt=(-1d0-2d0*x0)/4d0
47924 ENDIF
47925 IF(x1.EQ.1d0) THEN
47926 at=-1d0+at
47927 bt=0.25d0+bt
47928 ELSEIF(x1.EQ.0d0) THEN
47929 at=0d0+at
47930 bt=-0.25d0+bt
47931 ELSE
47932 at=0.5d0*log(abs(1d0-x1))*(1d0-x1**2)+0.5d0*
47933 & x1**2*log(ax1)+at
47934 bt=(-1d0-2d0*x1)/4d0+bt
47935 ENDIF
47936 aq=aq+at+bt
47937 ELSE
47938 x0=0.5d0*(1d0+rm2-rm1)
47939 y0=-0.5d0*sqrt(-arg)
47940 amgx0=sqrt(x0**2+y0**2)
47941 am1x0=sqrt((1d0-x0)**2+y0**2)
47942 argx0=atan2(-x0,-y0)
47943 ar1x0=atan2(1d0-x0,y0)
47944 x1=x0
47945 y1=-y0
47946 amgx1=amgx0
47947 am1x1=am1x0
47948 argx1=atan2(-x1,-y1)
47949 ar1x1=atan2(1d0-x1,y1)
47950 at=0.5d0*log(am1x0)*(1d0-x0**2+3d0*y0**2)
47951 & +0.5d0*(x0**2-y0**2)*log(amgx0)
47952 bt=(-1d0-2d0*x0)/4d0+x0*y0*( ar1x0-argx0 )
47953 at=at+0.5d0*log(am1x1)*(1d0-x1**2+3d0*y1**2)
47954 & +0.5d0*(x1**2-y1**2)*log(amgx1)
47955 bt=bt+(-1d0-2d0*x1)/4d0+x1*y1*( ar1x1-argx1 )
47956 aq=aq+at+bt
47957 ENDIF
47958 120 CONTINUE
47959 130 CONTINUE
47960 pmas(pycomp(ksusy1+21),1)=abs(xm3)*(1d0+pyalps(xm3**2)
47961 & /(2d0*paru(2))*(15d0+aq))
47962 ENDIF
47963
47964C...NEUTRALINO MASSES
47965 DO 150 i=1,4
47966 DO 140 j=1,4
47967 ai(i,j)=0d0
47968 140 CONTINUE
47969 150 CONTINUE
47970 xmz=pmas(23,1)/100d0
47971 xmw=pmas(24,1)/100d0
47972 xmu=rmss(4)/100d0
47973 sinw=sqrt(paru(102))
47974 cosw=sqrt(1d0-paru(102))
47975 tanb=rmss(5)
47976 beta=atan(tanb)
47977 cosb=cos(beta)
47978 sinb=tanb*cosb
47979
47980 xm2=xm2/100d0
47981 xm1=xm1/100d0
47982
47983
47984C... Definitions:
47985C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
47986C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
47987 ar(1,1) = xm1*cos(rmss(30))
47988 ai(1,1) = xm1*sin(rmss(30))
47989 ar(2,2) = xm2*cos(rmss(31))
47990 ai(2,2) = xm2*sin(rmss(31))
47991 ar(3,3) = 0d0
47992 ar(4,4) = 0d0
47993 ar(1,2) = 0d0
47994 ar(2,1) = 0d0
47995 ar(1,3) = -xmz*sinw*cosb
47996 ar(3,1) = ar(1,3)
47997 ar(1,4) = xmz*sinw*sinb
47998 ar(4,1) = ar(1,4)
47999 ar(2,3) = xmz*cosw*cosb
48000 ar(3,2) = ar(2,3)
48001 ar(2,4) = -xmz*cosw*sinb
48002 ar(4,2) = ar(2,4)
48003 ar(3,4) = -xmu*cos(rmss(33))
48004 ai(3,4) = -xmu*sin(rmss(33))
48005 ar(4,3) = -xmu*cos(rmss(33))
48006 ai(4,3) = -xmu*sin(rmss(33))
48007C CALL PYEIG4(AR,WR,ZR)
48008 CALL pyeicg(5,4,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
48009 IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
48010 & 'PROBLEM WITH PYEICG IN PYINOM ')
48011 DO 160 i=1,4
48012 index(i)=i
48013 xm(i)=abs(wr(i))
48014 160 CONTINUE
48015 DO 180 i=2,4
48016 k=i
48017 DO 170 j=i-1,1,-1
48018 IF(xm(k).LT.xm(j)) THEN
48019 itmp=index(j)
48020 xtmp=xm(j)
48021 index(j)=index(k)
48022 xm(j)=xm(k)
48023 index(k)=itmp
48024 xm(k)=xtmp
48025 k=k-1
48026 ELSE
48027 GOTO 180
48028 ENDIF
48029 170 CONTINUE
48030 180 CONTINUE
48031
48032
48033 DO 210 i=1,4
48034 k=index(i)
48035 smz(i)=wr(k)*100d0
48036 pmas(pycomp(kfnchi(i)),1)=abs(smz(i))
48037 s=0d0
48038 DO 190 j=1,4
48039 s=s+zr(j,k)**2+zi(j,k)**2
48040 190 CONTINUE
48041 DO 200 j=1,4
48042 zmix(i,j)=zr(j,k)/sqrt(s)
48043 zmixi(i,j)=zi(j,k)/sqrt(s)
48044 IF(abs(zmix(i,j)).LT.1d-6) zmix(i,j)=0d0
48045 IF(abs(zmixi(i,j)).LT.1d-6) zmixi(i,j)=0d0
48046 200 CONTINUE
48047 210 CONTINUE
48048
48049C...CHARGINO MASSES
48050C.....Find eigenvectors of X X^*
48051 DO i=1,4
48052 DO j=1,4
48053 ar(i,j)=0d0
48054 ai(i,j)=0d0
48055 ENDDO
48056 ENDDO
48057 ai(1,1) = 0d0
48058 ai(2,2) = 0d0
48059 ar(1,1) = xm2**2+2d0*xmw**2*sinb**2
48060 ar(2,2) = xmu**2+2d0*xmw**2*cosb**2
48061 ar(1,2) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*cosb+
48062 &xmu*cos(rmss(33))*sinb)
48063 ai(1,2) = sqrt(2d0)*xmw*(xm2*sin(rmss(31))*cosb-
48064 &xmu*sin(rmss(33))*sinb)
48065 ar(2,1) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*cosb+
48066 &xmu*cos(rmss(33))*sinb)
48067 ai(2,1) = sqrt(2d0)*xmw*(-xm2*sin(rmss(31))*cosb+
48068 &xmu*sin(rmss(33))*sinb)
48069 CALL pyeicg(5,2,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
48070 IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
48071 & 'PROBLEM WITH PYEICG IN PYINOM ')
48072 index(1)=1
48073 index(2)=2
48074 IF(wr(2).LT.wr(1)) THEN
48075 index(1)=2
48076 index(2)=1
48077 ENDIF
48078
48079
48080 DO 240 i=1,2
48081 k=index(i)
48082 smw(i)=sqrt(wr(k))*100d0
48083 s=0d0
48084 DO 220 j=1,2
48085 s=s+zr(j,k)**2+zi(j,k)**2
48086 220 CONTINUE
48087 DO 230 j=1,2
48088 umix(i,j)=zr(j,k)/sqrt(s)
48089 umixi(i,j)=-zi(j,k)/sqrt(s)
48090 IF(abs(umix(i,j)).LT.1d-6) umix(i,j)=0d0
48091 IF(abs(umixi(i,j)).LT.1d-6) umixi(i,j)=0d0
48092 230 CONTINUE
48093 240 CONTINUE
48094C...Force chargino mass > neutralino mass
48095 ifrc=0
48096 IF(abs(smw(1)).LT.abs(smz(1))+2d0*pmas(pycomp(111),1)) THEN
48097 CALL pyerrm(8,'(PYINOM:) '//
48098 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48099 smw(1)=sign(abs(smz(1))+2d0*pmas(pycomp(111),1),smw(1))
48100 ifrc=1
48101 ENDIF
48102 pmas(pycomp(ksusy1+24),1)=smw(1)
48103 pmas(pycomp(ksusy1+37),1)=smw(2)
48104
48105C.....Find eigenvectors of X^* X
48106 DO i=1,4
48107 DO j=1,4
48108 ar(i,j)=0d0
48109 ai(i,j)=0d0
48110 zr(i,j)=0d0
48111 zi(i,j)=0d0
48112 ENDDO
48113 ENDDO
48114 ai(1,1) = 0d0
48115 ai(2,2) = 0d0
48116 ar(1,1) = xm2**2+2d0*xmw**2*cosb**2
48117 ar(2,2) = xmu**2+2d0*xmw**2*sinb**2
48118 ar(1,2) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*sinb+
48119 &xmu*cos(rmss(33))*cosb)
48120 ai(1,2) = sqrt(2d0)*xmw*(-xm2*sin(rmss(31))*sinb+
48121 &xmu*sin(rmss(33))*cosb)
48122 ar(2,1) = sqrt(2d0)*xmw*(xm2*cos(rmss(31))*sinb+
48123 &xmu*cos(rmss(33))*cosb)
48124 ai(2,1) = sqrt(2d0)*xmw*(xm2*sin(rmss(31))*sinb-
48125 &xmu*sin(rmss(33))*cosb)
48126 CALL pyeicg(5,2,ar,ai,wr,wi,1,zr,zi,fv1,fv2,fv3,ierr)
48127 IF(ierr.NE.0) CALL pyerrm(18,'(PYINOM:) '//
48128 & 'PROBLEM WITH PYEICG IN PYINOM ')
48129 index(1)=1
48130 index(2)=2
48131 IF(wr(2).LT.wr(1)) THEN
48132 index(1)=2
48133 index(2)=1
48134 ENDIF
48135
48136 simag=0d0
48137 DO 270 i=1,2
48138 k=index(i)
48139 s=0d0
48140 DO 250 j=1,2
48141 s=s+zr(j,k)**2+zi(j,k)**2
48142 simag=simag+zi(j,k)**2
48143 250 CONTINUE
48144 DO 260 j=1,2
48145 vmix(i,j)=zr(j,k)/sqrt(s)
48146 vmixi(i,j)=-zi(j,k)/sqrt(s)
48147 IF(abs(vmix(i,j)).LT.1d-6) vmix(i,j)=0d0
48148 IF(abs(vmixi(i,j)).LT.1d-6) vmixi(i,j)=0d0
48149 260 CONTINUE
48150 270 CONTINUE
48151
48152C.....Simplify if no phases
48153 IF(simag.LT.1d-6) THEN
48154 ar(1,1) = xm2*cos(rmss(31))
48155 ar(2,2) = xmu*cos(rmss(33))
48156 ar(1,2) = sqrt(2d0)*xmw*sinb
48157 ar(2,1) = sqrt(2d0)*xmw*cosb
48158 iknt=0
48159 300 CONTINUE
48160 DO i=1,2
48161 DO j=1,2
48162 zr(i,j)=0d0
48163 ENDDO
48164 ENDDO
48165
48166 DO i=1,2
48167 DO j=1,2
48168 DO k=1,2
48169 DO l=1,2
48170 zr(i,j)=zr(i,j)+umix(i,k)*ar(k,l)*vmix(j,l)
48171 ENDDO
48172 ENDDO
48173 ENDDO
48174 ENDDO
48175 vmix(1,1)=vmix(1,1)*smw(1)/zr(1,1)/100d0
48176 vmix(1,2)=vmix(1,2)*smw(1)/zr(1,1)/100d0
48177 vmix(2,1)=vmix(2,1)*smw(2)/zr(2,2)/100d0
48178 vmix(2,2)=vmix(2,2)*smw(2)/zr(2,2)/100d0
48179 IF(iknt.EQ.2.AND.ifrc.EQ.0) THEN
48180 CALL pyerrm(18,'(PYINOM:) Problem with Charginos')
48181 ELSEIF(zr(1,1).LT.0d0.OR.zr(2,2).LT.0d0) THEN
48182 iknt=iknt+1
48183 GOTO 300
48184 ENDIF
48185C.....Must deal with phases
48186 ELSE
48187 car(1,1) = xm2*cmplx(cos(rmss(31)),sin(rmss(31)))
48188 car(2,2) = xmu*cmplx(cos(rmss(33)),sin(rmss(33)))
48189 car(1,2) = sqrt(2d0)*xmw*sinb*cmplx(1d0,0d0)
48190 car(2,1) = sqrt(2d0)*xmw*cosb*cmplx(1d0,0d0)
48191
48192 iknt=0
48193 310 CONTINUE
48194 DO i=1,2
48195 DO j=1,2
48196 cai(i,j)=cmplx(0d0,0d0)
48197 ENDDO
48198 ENDDO
48199
48200 DO i=1,2
48201 DO j=1,2
48202 DO k=1,2
48203 DO l=1,2
48204 cai(i,j)=cai(i,j)+cmplx(umix(i,k),-umixi(i,k))*car(k,l)*
48205 & cmplx(vmix(j,l),vmixi(j,l))
48206 ENDDO
48207 ENDDO
48208 ENDDO
48209 ENDDO
48210
48211 ca1=smw(1)*cai(1,1)/abs(cai(1,1))**2/100d0
48212 ca2=smw(2)*cai(2,2)/abs(cai(2,2))**2/100d0
48213 tempr=vmix(1,1)
48214 tempi=vmixi(1,1)
48215 vmix(1,1)=tempr*dble(ca1)-tempi*dimag(ca1)
48216 vmixi(1,1)=tempi*dble(ca1)+tempr*dimag(ca1)
48217 tempr=vmix(1,2)
48218 tempi=vmixi(1,2)
48219 vmix(1,2)=tempr*dble(ca1)-tempi*dimag(ca1)
48220 vmixi(1,2)=tempi*dble(ca1)+tempr*dimag(ca1)
48221 tempr=vmix(2,1)
48222 tempi=vmixi(2,1)
48223 vmix(2,1)=tempr*dble(ca2)-tempi*dimag(ca2)
48224 vmixi(2,1)=tempi*dble(ca2)+tempr*dimag(ca2)
48225 tempr=vmix(2,2)
48226 tempi=vmixi(2,2)
48227 vmix(2,2)=tempr*dble(ca2)-tempi*dimag(ca2)
48228 vmixi(2,2)=tempi*dble(ca2)+tempr*dimag(ca2)
48229 IF(iknt.EQ.2.AND.ifrc.EQ.0) THEN
48230 CALL pyerrm(18,'(PYINOM:) Problem with Charginos')
48231 ELSEIF(dble(ca1).LT.0d0.OR.dble(ca2).LT.0d0.OR.
48232 & abs(imag(ca1)).GT.1d-3.OR.abs(imag(ca2)).GT.1d-3) THEN
48233 iknt=iknt+1
48234 GOTO 310
48235 ENDIF
48236 ENDIF
48237 RETURN
48238 END
48239
48240C*********************************************************************
48241
48242C...PYRNM3
48243C...Calculates the running of M3, the SU(3) gluino mass parameter.
48244
48245 FUNCTION pyrnm3(RGUT)
48246
48247C...Double precision and integer declarations.
48248 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48249 IMPLICIT INTEGER(I-N)
48250 INTEGER PYK,PYCHGE,PYCOMP
48251
48252C...Local variables.
48253 DOUBLE PRECISION R
48254 DOUBLE PRECISION TOL
48255 EXTERNAL pyalps
48256 DOUBLE PRECISION PYALPS
48257 DATA tol/0.001d0/
48258 DATA r/0.61803399d0/
48259
48260 c=1d0-r
48261
48262 bx=rgut*pyalps(rgut**2)
48263 ax=min(50d0,bx*0.5d0)
48264 cx=max(2000d0,2d0*bx)
48265
48266 x0=ax
48267 x3=cx
48268 IF(abs(cx-bx).GT.abs(bx-ax))THEN
48269 x1=bx
48270 x2=bx+c*(cx-bx)
48271 ELSE
48272 x2=bx
48273 x1=bx-c*(bx-ax)
48274 ENDIF
48275 as1=pyalps(x1**2)
48276 f1=abs(x1-rgut*as1)
48277 as2=pyalps(x2**2)
48278 f2=abs(x2-rgut*as2)
48279 100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN
48280 IF(f2.LT.f1) THEN
48281 x0=x1
48282 x1=x2
48283 x2=r*x1+c*x3
48284 f1=f2
48285 as2=pyalps(x2**2)
48286 f2=abs(x2-rgut*as2)
48287 ELSE
48288 x3=x2
48289 x2=x1
48290 x1=r*x2+c*x0
48291 f2=f1
48292 as1=pyalps(x1**2)
48293 f1=abs(x1-rgut*as1)
48294 ENDIF
48295 GOTO 100
48296 ENDIF
48297 IF(f1.LT.f2) THEN
48298 pyrnm3=x1
48299 xmin=x1
48300 ELSE
48301 pyrnm3=x2
48302 xmin=x2
48303 ENDIF
48304
48305 RETURN
48306 END
48307
48308C*********************************************************************
48309
48310C...PYEIG4
48311C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48312C...Specific application: mixing in neutralino sector.
48313
48314 SUBROUTINE pyeig4(A,W,Z)
48315
48316C...Double precision and integer declarations.
48317 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48318 IMPLICIT INTEGER(I-N)
48319 INTEGER PYK,PYCHGE,PYCOMP
48320
48321C...Arrays: in call and local.
48322 dimension a(4,4),w(4),z(4,4),x(4),d(4,4),e(4)
48323
48324C...Coefficients of fourth-degree equation from matrix.
48325C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48326 b3=-(a(1,1)+a(2,2)+a(3,3)+a(4,4))
48327 b2=0d0
48328 DO 110 i=1,3
48329 DO 100 j=i+1,4
48330 b2=b2+a(i,i)*a(j,j)-a(i,j)*a(j,i)
48331 100 CONTINUE
48332 110 CONTINUE
48333 b1=0d0
48334 b0=0d0
48335 DO 120 i=1,4
48336 i1=mod(i,4)+1
48337 i2=mod(i+1,4)+1
48338 i3=mod(i+2,4)+1
48339 b1=b1+a(i,i)*(-a(i1,i1)*a(i2,i2)+a(i1,i2)*a(i2,i1)+
48340 & a(i1,i3)*a(i3,i1)+a(i2,i3)*a(i3,i2))-
48341 & a(i,i1)*a(i1,i2)*a(i2,i)-a(i,i2)*a(i2,i1)*a(i1,i)
48342 b0=b0+(-1d0)**(i+1)*a(1,i)*(
48343 & a(2,i1)*(a(3,i2)*a(4,i3)-a(3,i3)*a(4,i2))+
48344 & a(2,i2)*(a(3,i3)*a(4,i1)-a(3,i1)*a(4,i3))+
48345 & a(2,i3)*(a(3,i1)*a(4,i2)-a(3,i2)*a(4,i1)))
48346 120 CONTINUE
48347
48348C...Coefficients of third-degree equation needed for
48349C...separation into two second-degree equations.
48350C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48351 c2=-b2
48352 c1=b1*b3-4d0*b0
48353 c0=-b1**2-b0*b3**2+4d0*b0*b2
48354 cq=c1/3d0-c2**2/9d0
48355 cr=c1*c2/6d0-c0/2d0-c2**3/27d0
48356 cqr=cq**3+cr**2
48357
48358C...Cases with one or three real roots.
48359 IF(cqr.GE.0d0) THEN
48360 s1=(cr+sqrt(cqr))**(1d0/3d0)
48361 s2=(cr-sqrt(cqr))**(1d0/3d0)
48362 u=s1+s2-c2/3d0
48363 ELSE
48364 sabs=sqrt(-cq)
48365 the=acos(cr/sabs**3)/3d0
48366 sre=sabs*cos(the)
48367 u=2d0*sre-c2/3d0
48368 ENDIF
48369
48370C...Find and solve two second-degree equations.
48371 p1=b3/2d0-sqrt(b3**2/4d0+u-b2)
48372 p2=b3/2d0+sqrt(b3**2/4d0+u-b2)
48373 q1=u/2d0+sqrt(u**2/4d0-b0)
48374 q2=u/2d0-sqrt(u**2/4d0-b0)
48375 IF(abs(p1*q1+p2*q2-b1).LT.abs(p1*q2+p2*q1-b1)) THEN
48376 qsav=q1
48377 q1=q2
48378 q2=qsav
48379 ENDIF
48380 x(1)=-p1/2d0+sqrt(p1**2/4d0-q1)
48381 x(2)=-p1/2d0-sqrt(p1**2/4d0-q1)
48382 x(3)=-p2/2d0+sqrt(p2**2/4d0-q2)
48383 x(4)=-p2/2d0-sqrt(p2**2/4d0-q2)
48384
48385C...Order eigenvalues in asceding mass.
48386 w(1)=x(1)
48387 DO 150 i1=2,4
48388 DO 130 i2=i1-1,1,-1
48389 IF(abs(x(i1)).GE.abs(w(i2))) GOTO 140
48390 w(i2+1)=w(i2)
48391 130 CONTINUE
48392 140 w(i2+1)=x(i1)
48393 150 CONTINUE
48394
48395C...Find equation system for eigenvectors.
48396 DO 250 i=1,4
48397 DO 170 j1=1,4
48398 d(j1,j1)=a(j1,j1)-w(i)
48399 DO 160 j2=j1+1,4
48400 d(j1,j2)=a(j1,j2)
48401 d(j2,j1)=a(j2,j1)
48402 160 CONTINUE
48403 170 CONTINUE
48404
48405C...Find largest element in matrix.
48406 damax=0d0
48407 DO 190 j1=1,4
48408 DO 180 j2=1,4
48409 IF(abs(d(j1,j2)).LE.damax) GOTO 180
48410 ja=j1
48411 jb=j2
48412 damax=abs(d(j1,j2))
48413 180 CONTINUE
48414 190 CONTINUE
48415
48416C...Subtract others by multiple of row selected above.
48417 damax=0d0
48418 DO 210 j3=ja+1,ja+3
48419 j1=j3-4*((j3-1)/4)
48420 rl=d(j1,jb)/d(ja,jb)
48421 DO 200 j2=1,4
48422 d(j1,j2)=d(j1,j2)-rl*d(ja,j2)
48423 IF(abs(d(j1,j2)).LE.damax) GOTO 200
48424 jc=j1
48425 jd=j2
48426 damax=abs(d(j1,j2))
48427 200 CONTINUE
48428 210 CONTINUE
48429
48430C...Do one more subtraction of a row.
48431 damax=0d0
48432 DO 230 j3=jc+1,jc+3
48433 j1=j3-4*((j3-1)/4)
48434 IF(j1.EQ.ja) GOTO 230
48435 rl=d(j1,jd)/d(jc,jd)
48436 DO 220 j2=1,4
48437 IF(j2.EQ.jb) GOTO 220
48438 d(j1,j2)=d(j1,j2)-rl*d(jc,j2)
48439 IF(abs(d(j1,j2)).LE.damax) GOTO 220
48440 je=j1
48441 damax=abs(d(j1,j2))
48442 220 CONTINUE
48443 230 CONTINUE
48444
48445C...Construct unnormalized eigenvector.
48446 jf1=jd+1-4*(jd/4)
48447 jf2=jd+2-4*((jd+1)/4)
48448 IF(jf1.EQ.jb) jf1=jd+3-4*((jd+2)/4)
48449 IF(jf2.EQ.jb) jf2=jd+3-4*((jd+2)/4)
48450 e(jf1)=-d(je,jf2)
48451 e(jf2)=d(je,jf1)
48452 e(jd)=-(d(jc,jf1)*e(jf1)+d(jc,jf2)*e(jf2))/d(jc,jd)
48453 e(jb)=-(d(ja,jf1)*e(jf1)+d(ja,jf2)*e(jf2)+d(ja,jd)*e(jd))/
48454 & d(ja,jb)
48455
48456C...Normalize and fill in final array.
48457 ea=sqrt(e(1)**2+e(2)**2+e(3)**2+e(4)**2)
48458 sgn=(-1d0)**int(pyr(0)+0.5d0)
48459 DO 240 j=1,4
48460 z(i,j)=sgn*e(j)/ea
48461 240 CONTINUE
48462 250 CONTINUE
48463
48464 RETURN
48465 END
48466
48467C*********************************************************************
48468
48469C...PYHGGM
48470C...Determines the Higgs boson mass spectrum using several inputs.
48471
48472 SUBROUTINE pyhggm(ALPHA)
48473
48474C...Double precision and integer declarations.
48475 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48476 IMPLICIT INTEGER(I-N)
48477 INTEGER PYK,PYCHGE,PYCOMP
48478C...Parameter statement to help give large particle numbers.
48479 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
48480 &kexcit=4000000,kdimen=5000000)
48481C...Commonblocks.
48482 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48483 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48484 common/pypars/mstp(200),parp(200),msti(200),pari(200)
48485 common/pymssm/imss(0:99),rmss(0:99)
48486 SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/
48487
48488C...Local variables.
48489 DOUBLE PRECISION AT,AB,XMU,TANB
48490 DOUBLE PRECISION ALPHA
48491 INTEGER IHOPT
48492 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48493 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48494 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48495 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48496
48497 ihopt=imss(4)
48498 IF(ihopt.EQ.2) THEN
48499 alpha=rmss(18)
48500 RETURN
48501 ENDIF
48502 at=rmss(16)
48503 ab=rmss(15)
48504 dmgl=rmss(3)
48505 xmu=rmss(4)
48506 tanb=rmss(5)
48507
48508 dma=rmss(19)
48509 dtanb=tanb
48510 dmq=rmss(10)
48511 dmur=rmss(12)
48512 dmdr=rmss(11)
48513 dmtop=pmas(6,1)
48514 dmc=pmas(pycomp(ksusy1+37),1)
48515 dau=at
48516 dad=ab
48517 dmu=xmu
48518 rmss(40)=0d0
48519 rmss(41)=0d0
48520
48521 IF(ihopt.EQ.0) THEN
48522 CALL pysubh (dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
48523 & dmhch,dsa,dca,dtanba)
48524 ELSEIF(ihopt.EQ.1) THEN
48525 CALL pysubh (dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,
48526 & dmhch,dsa,dca,dtanba)
48527 CALL pypole(3,dmc,dma,dtanb,dmq,dmur,dmdr,dmtop,dau,dad,dmu,
48528 & dmh,dmhp,dhm,dhmp,damp,dsa,dca,
48529 & dstop1,dstop2,dsbot1,dsbot2,dtanba,dmgl,ddt,ddb)
48530 rmss(40)=ddt
48531 rmss(41)=ddb
48532 dmh=dmhp
48533 dhm=dhmp
48534 dma=damp
48535 IF(abs(pmas(pycomp(1000006),1)-dstop2).GT.5d-1) THEN
48536 WRITE(mstu(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48537 WRITE(mstu(11),*) ' STOP1 MASSES = ',
48538 & pmas(pycomp(1000006),1),dstop2
48539 ENDIF
48540 IF(abs(pmas(pycomp(2000006),1)-dstop1).GT.5d-1) THEN
48541 WRITE(mstu(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48542 WRITE(mstu(11),*) ' STOP2 MASSES = ',
48543 & pmas(pycomp(2000006),1),dstop1
48544 ENDIF
48545 IF(abs(pmas(pycomp(1000005),1)-dsbot2).GT.5d-1) THEN
48546 WRITE(mstu(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48547 WRITE(mstu(11),*) ' SBOT1 MASSES = ',
48548 & pmas(pycomp(1000005),1),dsbot2
48549 ENDIF
48550 IF(abs(pmas(pycomp(2000005),1)-dsbot1).GT.5d-1) THEN
48551 WRITE(mstu(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48552 WRITE(mstu(11),*) ' SBOT2 MASSES = ',
48553 & pmas(pycomp(2000005),1),dsbot1
48554 ENDIF
48555
48556 ELSEIF (ihopt.EQ.3) THEN
48557c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48558C...Currently only available for SLHA spectrum read-in.
48559 IF (imss(1).NE.11.AND.imss(1).NE.12.AND.imss(1).NE.13) THEN
48560 CALL pyerrm(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48561 & //' spectrum, change IMSS(1) or IMSS(4) option.')
48562 ENDIF
48563 alpha=rmss(18)
48564 RETURN
48565 ENDIF
48566
48567 alpha=acos(dca)
48568
48569 pmas(25,1)=dmh
48570 pmas(35,1)=dhm
48571 pmas(36,1)=dma
48572 pmas(37,1)=dmhch
48573
48574 RETURN
48575 END
48576
48577C*********************************************************************
48578
48579C...PYSUBH
48580C...This routine computes the renormalization group improved
48581C...values of Higgs masses and couplings in the MSSM.
48582
48583C...Program based on the work by M. Carena, J.R. Espinosa,
48584c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48585
48586C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48587C...All masses in GeV units. MA is the CP-odd Higgs mass,
48588C...MTOP is the physical top mass, MQ and MUR are the soft
48589C...supersymmetry breaking mass parameters of left handed
48590C...and right handed stops respectively, AU and AD are the
48591C...stop and sbottom trilinear soft breaking terms,
48592C...respectively, and MU is the supersymmetric
48593C...Higgs mass parameter. We use the conventions from
48594C...the physics report of Haber and Kane: left right
48595C...stop mixing term proportional to (AU - MU/TANB)
48596C...We use as input TANB defined at the scale MTOP
48597
48598C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48599C...where MH and HM are the lightest and heaviest CP-even
48600C...Higgs masses, MHCH is the charged Higgs mass and
48601C...ALPHA is the Higgs mixing angle
48602C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48603
48604C...Range of validity:
48605C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48606C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48607C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48608C...are the sbottom mass eigenvalues, respectively. This
48609C...range automatically excludes the existence of tachyons.
48610C...For the charged Higgs mass computation, the method is
48611C...valid if
48612C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48613C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48614C...where M_SUSY**2 is the average of the squared stop mass
48615C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48616C...masses have been assumed to be of order of the stop ones
48617C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48618
48619 SUBROUTINE pysubh (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48620 &XMHCH,SA,CA,TANBA)
48621
48622C...Double precision and integer declarations.
48623 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48624 IMPLICIT INTEGER(I-N)
48625 INTEGER PYK,PYCHGE,PYCOMP
48626C...Parameter statement to help give large particle numbers.
48627 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
48628 &kexcit=4000000,kdimen=5000000)
48629C...Commonblocks.
48630 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48631 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
48632 common/pyhtri/hhh(7)
48633 SAVE /pydat1/,/pydat2/
48634
48635C...Local variables.
48636 DOUBLE PRECISION PYALEM,PYALPS
48637 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48638 DOUBLE PRECISION XMHCH,SA,CA
48639 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48640 DOUBLE PRECISION Q02
48641 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48642 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48643 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48644 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48645 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48646 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48647 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48648 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48649
48650 xmz = pmas(23,1)
48651 q02=xmz**2
48652 aem=pyalem(q02)
48653 alp1=aem/(1d0-paru(102))
48654 alp2=aem/paru(102)
48655 alph3z=pyalps(q02)
48656
48657 alp1 = 0.0101d0
48658 alp2 = 0.0337d0
48659 alph3z = 0.12d0
48660
48661 v = 174.1d0
48662 pi = paru(1)
48663 tanba = tanb
48664 tanbt = tanb
48665
48666C...MBOTTOM(MTOP) = 3. GEV
48667 xmb = pymrun(5,xmtop**2)
48668 alp3 = alph3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alph3z*
48669 &log(xmtop**2/xmz**2))
48670
48671C...RMTOP= RUNNING TOP QUARK MASS
48672 rmtop = xmtop/(1d0+4d0*alp3/3d0/pi)
48673 xms = ((xmq**2 + xmur**2)/2d0 + xmtop**2)**0.5d0
48674 t = log(xms**2/xmtop**2)
48675 sinb = tanb/((1d0 + tanb**2)**0.5d0)
48676 cosb = sinb/tanb
48677C...IF(MA.LE.XMTOP) TANBA = TANBT
48678 IF(xma.GT.xmtop)
48679 &tanba = tanbt*(1d0-3d0/32d0/pi**2*
48680 &(rmtop**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*
48681 &log(xma**2/xmtop**2))
48682
48683 sinbt = tanbt/sqrt(1d0 + tanbt**2)
48684 cosbt = 1d0/sqrt(1d0 + tanbt**2)
48685C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48686 g1 = sqrt(alp1*4d0*pi)
48687 g2 = sqrt(alp2*4d0*pi)
48688 g3 = sqrt(alp3*4d0*pi)
48689 hu = rmtop/v/sinbt
48690 hd = xmb/v/cosbt
48691 hu2=hu*hu
48692 hd2=hd*hd
48693 hu4=hu2*hu2
48694 hd4=hd2*hd2
48695 au2=au**2
48696 ad2=ad**2
48697 xms2=xms**2
48698 xms3=xms**3
48699 xms4=xms2*xms2
48700 xmu2=xmu*xmu
48701 pi2=pi*pi
48702
48703 xau = (2d0*au2/xms2)*(1d0 - au2/12d0/xms2)
48704 xad = (2d0*ad2/xms2)*(1d0 - ad2/12d0/xms2)
48705 aud = (-6d0*xmu2/xms2 - ( xmu2- ad*au)**2/xms4
48706 &+ 3d0*(au + ad)**2/xms2)/6d0
48707 xlam1 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hd2*t/8d0/pi2)
48708 &+(3d0*hd4/8d0/pi2) * (t + xad/2d0 + (3d0*hd2/2d0 + hu2/2d0
48709 &- 8d0*g3**2) * (xad*t + t**2)/16d0/pi2)
48710 &-(3d0*hu4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hu2 -5d0* hd2
48711 &- 16d0*g3**2) *t/16d0/pi2)
48712 xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu2*t/8d0/pi2)
48713 &+(3d0*hu4/8d0/pi2) * (t + xau/2d0 + (3d0*hu2/2d0 + hd2/2d0
48714 &- 8d0*g3**2) * (xau*t + t**2)/16d0/pi2)
48715 &-(3d0*hd4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hd2 -5d0* hu2
48716 &- 16d0*g3**2) *t/16d0/pi2)
48717 xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
48718 &(hu2 + hd2)*t/16d0/pi2)
48719 &+(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
48720 &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
48721 &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
48722 &xms4)* (1d0+ (6d0*hu2 -2d0* hd2/2d0
48723 &- 16d0*g3**2) *t/16d0/pi2)
48724 &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
48725 &xms4)*(1d0+ (6d0*hd2 -2d0* hu2
48726 &- 16d0*g3**2) *t/16d0/pi2)
48727 xlam4 = (- g2**2/2d0)*(1d0-3d0*(hu2 + hd2)*t/16d0/pi2)
48728 &-(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2
48729 &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)
48730 &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/
48731 &xms4)*
48732 &(1+ (6d0*hu2 -2d0* hd2
48733 &- 16d0*g3**2) *t/16d0/pi2)
48734 &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/
48735 &xms4)*
48736 &(1+ (6d0*hd2 -2d0* hu2/2d0
48737 &- 16d0*g3**2) *t/16d0/pi2)
48738 xlam5 = -(3d0*hu4* xmu2*au2/96d0/pi2/xms4) *
48739 &(1- (2d0*hd2 -6d0* hu2 + 16d0*g3**2) *t/16d0/pi2)
48740 &-(3d0*hd4* xmu2*ad2/96d0/pi2/xms4) *
48741 &(1- (2d0*hu2 -6d0* hd2 + 16d0*g3**2) *t/16d0/pi2)
48742 xlam6 = (3d0*hu4* xmu**3*au/96d0/pi2/xms4) *
48743 &(1- (7d0*hd2/2d0 -15d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
48744 &+(3d0*hd4* xmu *(ad**3/xms3 - 6d0*ad/xms )/96d0/pi2/xms) *
48745 &(1- (hu2/2d0 -9d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
48746 xlam7 = (3d0*hd4* xmu**3*ad/96d0/pi2/xms4) *
48747 &(1- (7d0*hu2/2d0 -15d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)
48748 &+(3d0*hu4* xmu *(au**3/xms3 - 6d0*au/xms )/96d0/pi2/xms) *
48749 &(1- (hd2/2d0 -9d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)
48750 hhh(1)=xlam1
48751 hhh(2)=xlam2
48752 hhh(3)=xlam3
48753 hhh(4)=xlam4
48754 hhh(5)=xlam5
48755 hhh(6)=xlam6
48756 hhh(7)=xlam7
48757 trm2 = xma**2 + 2d0*v**2* (xlam1* cosbt**2 +
48758 &2d0* xlam6*sinbt*cosbt
48759 &+ xlam5*sinbt**2 + xlam2* sinbt**2 + 2d0* xlam7*sinbt*cosbt
48760 &+ xlam5*cosbt**2)
48761 detm2 = 4d0*v**4*(-(sinbt*cosbt*(xlam3 + xlam4) +
48762 &xlam6*cosbt**2
48763 &+ xlam7* sinbt**2)**2 + (xlam1* cosbt**2 +
48764 &2d0* xlam6* cosbt*sinbt
48765 &+ xlam5*sinbt**2)*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
48766 &+ xlam5*cosbt**2)) + xma**2*2d0*v**2 *
48767 &((xlam1* cosbt**2 +2d0*
48768 &xlam6* cosbt*sinbt + xlam5*sinbt**2)*cosbt**2 +
48769 &(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt + xlam5*cosbt**2)
48770 &*sinbt**2
48771 &+2d0*sinbt*cosbt* (sinbt*cosbt*(xlam3
48772 &+ xlam4) + xlam6*cosbt**2
48773 &+ xlam7* sinbt**2))
48774
48775 xmh2 = (trm2 - sqrt(trm2**2 - 4d0* detm2))/2d0
48776 xhm2 = (trm2 + sqrt(trm2**2 - 4d0* detm2))/2d0
48777 xhm = sqrt(xhm2)
48778 xmh = sqrt(xmh2)
48779 xmhch2 = xma**2 + (xlam5 - xlam4)* v**2
48780 xmhch = sqrt(xmhch2)
48781
48782 sinalp = sqrt(((trm2**2 - 4d0* detm2)**0.5d0) -
48783 &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
48784 &xlam6* cosbt*sinbt
48785 &+ xlam5*sinbt**2) + xma**2*sinbt**2)
48786 &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
48787 &+ xlam5*cosbt**2) + xma**2*cosbt**2)))/
48788 &sqrt(((trm2**2 - 4d0* detm2)**0.5d0))/2d0**0.5d0
48789
48790 cosalp = (2d0*(2d0*v**2*(sinbt*cosbt*(xlam3 + xlam4) +
48791 &xlam6*cosbt**2 + xlam7* sinbt**2) -
48792 &xma**2*sinbt*cosbt))/2d0**0.5d0/
48793 &sqrt(((trm2**2 - 4d0* detm2)**0.5d0)*
48794 &(((trm2**2 - 4d0* detm2)**0.5d0) -
48795 &((2d0*v**2*(xlam1* cosbt**2 + 2d0*
48796 &xlam6* cosbt*sinbt
48797 &+ xlam5*sinbt**2) + xma**2*sinbt**2)
48798 &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt
48799 &+ xlam5*cosbt**2) + xma**2*cosbt**2))))
48800
48801 sa = -sinalp
48802 ca = -cosalp
48803
48804 100 CONTINUE
48805
48806 RETURN
48807 END
48808
48809C*********************************************************************
48810
48811C...PYPOLE
48812C...This subroutine computes the CP-even higgs and CP-odd pole
48813c...Higgs masses and mixing angles.
48814
48815C...Program based on the work by M. Carena, M. Quiros
48816C...and C.E.M. Wagner, "Effective potential methods and
48817C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48818
48819C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48820C...AT,AB,MU
48821C...where MCHI is the largest chargino mass, MA is the running
48822C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48823C...expectaion values at the scale MTOP, MQ is the third generation
48824C...left handed squark mass parameter, MUR is the third generation
48825C...right handed stop mass parameter, MDR is the third generation
48826C...right handed sbottom mass parameter, MTOP is the pole top quark
48827C...mass; AT,AB are the soft supersymmetry breaking trilinear
48828C...couplings of the stop and sbottoms, respectively, and MU is the
48829C...supersymmetric mass parameter
48830
48831C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48832C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48833C...masses are given, what makes the running of the program
48834c...much faster and it is quite generally a good approximation
48835c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48836C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48837c...and if IHIGGS=3, then h,H,A polarizations are computed
48838
48839C...Output: MH and MHP which are the lightest CP-even Higgs running
48840C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48841C...Higgs running and pole masses, repectively; SA and CA are the
48842C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48843C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48844C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48845C...the value of TANB at the CP-odd Higgs mass scale
48846
48847C...This subroutine makes use of CERN library subroutine
48848C...integration package, which makes the computation of the
48849C...pole Higgs masses somewhat faster. We thank P. Janot for this
48850C...improvement. Those who are not able to call the CERN
48851C...libraries, please use the subroutine SUBHPOLE2.F, which
48852C...although somewhat slower, gives identical results
48853
48854 SUBROUTINE pypole(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48855 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48856
48857C...Double precision and integer declarations.
48858 IMPLICIT DOUBLE PRECISION(a-h, o-z)
48859 IMPLICIT INTEGER(I-N)
48860
48861C...Parameters.
48862 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
48863 SAVE /pydat1/
48864 INTEGER PYK,PYCHGE,PYCOMP
48865
48866C...Local variables.
48867 dimension delta(2,2),coupt(2,2),t(2,2),sstop2(2),
48868 &ssbot2(2),b(2,2),coupb(2,2),
48869 &hcoupt(2,2),hcoupb(2,2),
48870 &acoupt(2,2),acoupb(2,2),pr(3), polar(3)
48871
48872 delta(1,1) = 1d0
48873 delta(2,2) = 1d0
48874 delta(1,2) = 0d0
48875 delta(2,1) = 0d0
48876 v = 174.1d0
48877 xmz=91.18d0
48878 pi=paru(1)
48879 rxmt=pymrun(6,xmt**2)
48880 CALL pyrghm(xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,
48881 &xmu,xmh,hm,xmch,sa,ca,sab,cab,tanba,xmg,dt,db)
48882
48883 sinb = tanb/(tanb**2+1d0)**0.5d0
48884 cosb = 1d0/(tanb**2+1d0)**0.5d0
48885 cos2b = sinb**2 - cosb**2
48886 sinbpa = sinb*ca + cosb*sa
48887 cosbpa = cosb*ca - sinb*sa
48888 rmbot = pymrun(5,xmt**2)
48889 xmq2 = xmq**2
48890 xmur2 = xmur**2
48891 IF(xmur.LT.0d0) xmur2=-xmur2
48892 xmdr2 = xmdr**2
48893 xmst11 = rxmt**2 + xmq2 - 0.35d0*xmz**2*cos2b
48894 xmst22 = rxmt**2 + xmur2 - 0.15d0*xmz**2*cos2b
48895 IF(xmst11.LT.0d0) GOTO 500
48896 IF(xmst22.LT.0d0) GOTO 500
48897 xmsb11 = rmbot**2 + xmq2 + 0.42d0*xmz**2*cos2b
48898 xmsb22 = rmbot**2 + xmdr2 + 0.08d0*xmz**2*cos2b
48899 IF(xmsb11.LT.0d0) GOTO 500
48900 IF(xmsb22.LT.0d0) GOTO 500
48901C WMST11 = RXMT**2 + XMQ2
48902C WMST22 = RXMT**2 + XMUR2
48903 xmst12 = rxmt*(at - xmu/tanb)
48904 xmsb12 = rmbot*(ab - xmu*tanb)
48905
48906CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48907C...STOP EIGENVALUES CALCULATION
48908CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48909
48910 stop12 = 0.5d0*(xmst11+xmst22) +
48911 &0.5d0*((xmst11+xmst22)**2 -
48912 &4d0*(xmst11*xmst22 - xmst12**2))**0.5d0
48913 stop22 = 0.5d0*(xmst11+xmst22) -
48914 &0.5d0*((xmst11+xmst22)**2 - 4d0*(xmst11*xmst22 -
48915 &xmst12**2))**0.5d0
48916
48917 IF(stop22.LT.0d0) GOTO 500
48918 sstop2(1) = stop12
48919 sstop2(2) = stop22
48920 stop1 = stop12**0.5d0
48921 stop2 = stop22**0.5d0
48922C STOP1W = STOP1
48923C STOP2W = STOP2
48924
48925 IF(xmst12.EQ.0d0) xst11 = 1d0
48926 IF(xmst12.EQ.0d0) xst12 = 0d0
48927 IF(xmst12.EQ.0d0) xst21 = 0d0
48928 IF(xmst12.EQ.0d0) xst22 = 1d0
48929
48930 IF(xmst12.EQ.0d0) GOTO 110
48931
48932 100 xst11 = xmst12/(xmst12**2+(xmst11-stop12)**2)**0.5d0
48933 xst12 = - (xmst11-stop12)/(xmst12**2+(xmst11-stop12)**2)**0.5d0
48934 xst21 = xmst12/(xmst12**2+(xmst11-stop22)**2)**0.5d0
48935 xst22 = - (xmst11-stop22)/(xmst12**2+(xmst11-stop22)**2)**0.5d0
48936
48937 110 t(1,1) = xst11
48938 t(2,2) = xst22
48939 t(1,2) = xst12
48940 t(2,1) = xst21
48941
48942 sbot12 = 0.5d0*(xmsb11+xmsb22) +
48943 &0.5d0*((xmsb11+xmsb22)**2 -
48944 &4d0*(xmsb11*xmsb22 - xmsb12**2))**0.5d0
48945 sbot22 = 0.5d0*(xmsb11+xmsb22) -
48946 &0.5d0*((xmsb11+xmsb22)**2 - 4d0*(xmsb11*xmsb22 -
48947 &xmsb12**2))**0.5d0
48948 IF(sbot22.LT.0d0) GOTO 500
48949 sbot1 = sbot12**0.5d0
48950 sbot2 = sbot22**0.5d0
48951
48952 ssbot2(1) = sbot12
48953 ssbot2(2) = sbot22
48954
48955 IF(xmsb12.EQ.0d0) xsb11 = 1d0
48956 IF(xmsb12.EQ.0d0) xsb12 = 0d0
48957 IF(xmsb12.EQ.0d0) xsb21 = 0d0
48958 IF(xmsb12.EQ.0d0) xsb22 = 1d0
48959
48960 IF(xmsb12.EQ.0d0) GOTO 130
48961
48962 120 xsb11 = xmsb12/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
48963 xsb12 = - (xmsb11-sbot12)/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0
48964 xsb21 = xmsb12/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
48965 xsb22 = - (xmsb11-sbot22)/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0
48966
48967 130 b(1,1) = xsb11
48968 b(2,2) = xsb22
48969 b(1,2) = xsb12
48970 b(2,1) = xsb21
48971
48972
48973 sint = 0.2320d0
48974 sqr = dsqrt(2d0)
48975 vp = 174.1d0*sqr
48976
48977CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48978C...STARTING OF LIGHT HIGGS
48979CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48980
48981 IF(ihiggs.EQ.0) GOTO 490
48982
48983 DO 150 i = 1,2
48984 DO 140 j = 1,2
48985 coupt(i,j) =
48986 & sint*xmz**2*2d0*sqr/174.1d0/3d0*sinbpa*(delta(i,j) +
48987 & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
48988 & -rxmt**2/174.1d0**2*vp/sinb*ca*delta(i,j)
48989 & -rxmt/vp/sinb*(at*ca + xmu*sa)*(t(1,i)*t(2,j) +
48990 & t(1,j)*t(2,i))
48991 140 CONTINUE
48992 150 CONTINUE
48993
48994
48995 DO 170 i = 1,2
48996 DO 160 j = 1,2
48997 coupb(i,j) =
48998 & -sint*xmz**2*2d0*sqr/174.1d0/6d0*sinbpa*(delta(i,j) +
48999 & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
49000 & +rmbot**2/174.1d0**2*vp/cosb*sa*delta(i,j)
49001 & +rmbot/vp/cosb*(ab*sa + xmu*ca)*(b(1,i)*b(2,j) +
49002 & b(1,j)*b(2,i))
49003 160 CONTINUE
49004 170 CONTINUE
49005
49006 prun = xmh
49007 eps = 1d-4*prun
49008 iter = 0
49009 180 iter = iter + 1
49010 DO 230 i3 = 1,3
49011
49012 pr(i3)=prun+(i3-2)*eps/2
49013 p2=pr(i3)**2
49014 polt = 0d0
49015 DO 200 i = 1,2
49016 DO 190 j = 1,2
49017 polt = polt + coupt(i,j)**2*3d0*
49018 & pyfint(p2,sstop2(i),sstop2(j))/16d0/pi**2
49019 190 CONTINUE
49020 200 CONTINUE
49021
49022 polb = 0d0
49023 DO 220 i = 1,2
49024 DO 210 j = 1,2
49025 polb = polb + coupb(i,j)**2*3d0*
49026 & pyfint(p2,ssbot2(i),ssbot2(j))/16d0/pi**2
49027 210 CONTINUE
49028 220 CONTINUE
49029C RXMT2 = RXMT**2
49030 xmt2=xmt**2
49031
49032 poltt =
49033 & 3d0*rxmt**2/8d0/pi**2/ v **2*
49034 & ca**2/sinb**2 *
49035 & (-2d0*xmt**2+0.5d0*p2)*
49036 & pyfint(p2,xmt2,xmt2)
49037
49038 pol = polt + polb + poltt
49039 polar(i3) = p2 - xmh**2 - pol
49040 230 CONTINUE
49041 deriv = (polar(3)-polar(1))/eps
49042 drun = - polar(2)/deriv
49043 prun = prun + drun
49044 p2 = prun**2
49045 IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) GOTO 240
49046 GOTO 180
49047 240 CONTINUE
49048
49049 xmhp = dsqrt(p2)
49050
49051CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49052C...END OF LIGHT HIGGS
49053CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49054
49055 250 IF(ihiggs.EQ.1) GOTO 490
49056
49057CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49058C... STARTING OF HEAVY HIGGS
49059CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49060
49061 DO 270 i = 1,2
49062 DO 260 j = 1,2
49063 hcoupt(i,j) =
49064 & -sint*xmz**2*2d0*sqr/174.1d0/3d0*cosbpa*(delta(i,j) +
49065 & (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))
49066 & -rxmt**2/174.1d0**2*vp/sinb*sa*delta(i,j)
49067 & -rxmt/vp/sinb*(at*sa - xmu*ca)*(t(1,i)*t(2,j) +
49068 & t(1,j)*t(2,i))
49069 260 CONTINUE
49070 270 CONTINUE
49071
49072 DO 290 i = 1,2
49073 DO 280 j = 1,2
49074 hcoupb(i,j) =
49075 & sint*xmz**2*2d0*sqr/174.1d0/6d0*cosbpa*(delta(i,j) +
49076 & (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))
49077 & -rmbot**2/174.1d0**2*vp/cosb*ca*delta(i,j)
49078 & -rmbot/vp/cosb*(ab*ca - xmu*sa)*(b(1,i)*b(2,j) +
49079 & b(1,j)*b(2,i))
49080 hcoupb(i,j)=0d0
49081 280 CONTINUE
49082 290 CONTINUE
49083
49084 prun = hm
49085 eps = 1d-4*prun
49086 iter = 0
49087 300 iter = iter + 1
49088 DO 350 i3 = 1,3
49089 pr(i3)=prun+(i3-2)*eps/2
49090 hp2=pr(i3)**2
49091
49092 hpolt = 0d0
49093 DO 320 i = 1,2
49094 DO 310 j = 1,2
49095 hpolt = hpolt + hcoupt(i,j)**2*3d0*
49096 & pyfint(hp2,sstop2(i),sstop2(j))/16d0/pi**2
49097 310 CONTINUE
49098 320 CONTINUE
49099
49100 hpolb = 0d0
49101 DO 340 i = 1,2
49102 DO 330 j = 1,2
49103 hpolb = hpolb + hcoupb(i,j)**2*3d0*
49104 & pyfint(hp2,ssbot2(i),ssbot2(j))/16d0/pi**2
49105 330 CONTINUE
49106 340 CONTINUE
49107
49108C RXMT2 = RXMT**2
49109 xmt2 = xmt**2
49110
49111 hpoltt =
49112 & 3d0*rxmt**2/8d0/pi**2/ v **2*
49113 & sa**2/sinb**2 *
49114 & (-2d0*xmt**2+0.5d0*hp2)*
49115 & pyfint(hp2,xmt2,xmt2)
49116
49117 hpol = hpolt + hpolb + hpoltt
49118 polar(i3) =hp2-hm**2-hpol
49119 350 CONTINUE
49120 deriv = (polar(3)-polar(1))/eps
49121 drun = - polar(2)/deriv
49122 prun = prun + drun
49123 hp2 = prun**2
49124 IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) GOTO 360
49125 GOTO 300
49126 360 CONTINUE
49127
49128
49129 370 CONTINUE
49130 hmp = hp2**0.5d0
49131
49132CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49133C... END OF HEAVY HIGGS
49134CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49135
49136 IF(ihiggs.EQ.2) GOTO 490
49137
49138CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49139C...BEGINNING OF PSEUDOSCALAR HIGGS
49140CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49141
49142 DO 390 i = 1,2
49143 DO 380 j = 1,2
49144 acoupt(i,j) =
49145 & -rxmt/vp/sinb*(at*cosb + xmu*sinb)*
49146 & (t(1,i)*t(2,j) -t(1,j)*t(2,i))
49147 380 CONTINUE
49148 390 CONTINUE
49149 DO 410 i = 1,2
49150 DO 400 j = 1,2
49151 acoupb(i,j) =
49152 & rmbot/vp/cosb*(ab*sinb + xmu*cosb)*
49153 & (b(1,i)*b(2,j) -b(1,j)*b(2,i))
49154 400 CONTINUE
49155 410 CONTINUE
49156
49157 prun = xma
49158 eps = 1d-4*prun
49159 iter = 0
49160 420 iter = iter + 1
49161 DO 470 i3 = 1,3
49162 pr(i3)=prun+(i3-2)*eps/2
49163 ap2=pr(i3)**2
49164 apolt = 0d0
49165 DO 440 i = 1,2
49166 DO 430 j = 1,2
49167 apolt = apolt + acoupt(i,j)**2*3d0*
49168 & pyfint(ap2,sstop2(i),sstop2(j))/16d0/pi**2
49169 430 CONTINUE
49170 440 CONTINUE
49171 apolb = 0d0
49172 DO 460 i = 1,2
49173 DO 450 j = 1,2
49174 apolb = apolb + acoupb(i,j)**2*3d0*
49175 & pyfint(ap2,ssbot2(i),ssbot2(j))/16d0/pi**2
49176 450 CONTINUE
49177 460 CONTINUE
49178C RXMT2 = RXMT**2
49179 xmt2=xmt**2
49180 apoltt =
49181 & 3d0*rxmt**2/8d0/pi**2/ v **2*
49182 & cosb**2/sinb**2 *
49183 & (-0.5d0*ap2)*
49184 & pyfint(ap2,xmt2,xmt2)
49185 apol = apolt + apolb + apoltt
49186 polar(i3) = ap2 - xma**2 -apol
49187 470 CONTINUE
49188 deriv = (polar(3)-polar(1))/eps
49189 drun = - polar(2)/deriv
49190 prun = prun + drun
49191 ap2 = prun**2
49192 IF( abs(drun) .LT. 1d-4 .OR.iter.GT.500) GOTO 480
49193 GOTO 420
49194 480 CONTINUE
49195
49196 amp = dsqrt(ap2)
49197
49198CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49199C...END OF PSEUDOSCALAR HIGGS
49200CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49201
49202 IF(ihiggs.EQ.3) GOTO 490
49203
49204 490 CONTINUE
49205 RETURN
49206 500 CONTINUE
49207 WRITE(mstu(11),*) ' EXITING IN PYPOLE '
49208 WRITE(mstu(11),*) ' XMST11,XMST22 = ',xmst11,xmst22
49209 WRITE(mstu(11),*) ' XMSB11,XMSB22 = ',xmsb11,xmsb22
49210 WRITE(mstu(11),*) ' STOP22,SBOT22 = ',stop22,sbot22
49211 CALL pystop(107)
49212 END
49213
49214C*********************************************************************
49215
49216C...PYRGHM
49217C...Auxiliary to PYPOLE.
49218
49219 SUBROUTINE pyrghm(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49220 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49221 IMPLICIT DOUBLE PRECISION(a-h,l,m,o-z)
49222 dimension vh(2,2),m2(2,2),m2p(2,2)
49223C...Parameters.
49224 INTEGER MSTU,MSTJ
49225 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49226 SAVE /pydat1/
49227
49228 mz = 91.18d0
49229 pi = paru(1)
49230 v = 174.1d0
49231 alpha1 = 0.0101d0
49232 alpha2 = 0.0337d0
49233 alpha3z = 0.12d0
49234 tanba = tanb
49235 tanbt = tanb
49236C MBOTTOM(MTOP) = 3. GEV
49237 mb = pymrun(5,mtop**2)
49238 alpha3 = alpha3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alpha3z*
49239 *log(mtop**2/mz**2))
49240C RMTOP= RUNNING TOP QUARK MASS
49241 rmtop = mtop/(1d0+4d0*alpha3/3d0/pi)
49242 tq = log((mq**2+mtop**2)/mtop**2)
49243 tu = log((mur**2 + mtop**2)/mtop**2)
49244 td = log((md**2 + mtop**2)/mtop**2)
49245CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49246C
49247C NEW DEFINITION, TGLU.
49248C
49249CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49250 tglu = log(mglu**2/mtop**2)
49251 sinb = tanb/dsqrt(1d0 + tanb**2)
49252 cosb = sinb/tanb
49253 IF(ma.GT.mtop)
49254 *tanba = tanb*(1d0-3d0/32d0/pi**2*
49255 *(rmtop**2/v**2/sinb**2-mb**2/v**2/cosb**2)*
49256 *log(ma**2/mtop**2))
49257 IF(ma.LT.mtop.OR.ma.EQ.mtop) tanbt = tanba
49258 sinb = tanbt/sqrt(1d0 + tanbt**2)
49259 cosb = 1d0/dsqrt(1d0 + tanbt**2)
49260 g1 = sqrt(alpha1*4d0*pi)
49261 g2 = sqrt(alpha2*4d0*pi)
49262 g3 = sqrt(alpha3*4d0*pi)
49263 hu = rmtop/v/sinb
49264 hd = mb/v/cosb
49265 CALL pygfxx(ma,tanba,mq,mur,md,mtop,au,ad,mu,mglu,vh,stop1,stop2,
49266 *sbot1,sbot2,deltamt,deltamb)
49267 IF(mq.GT.mur) tp = tq - tu
49268 IF(mq.LT.mur.OR.mq.EQ.mur) tp = tu - tq
49269 IF(mq.GT.mur) tdp = tu
49270 IF(mq.LT.mur.OR.mq.EQ.mur) tdp = tq
49271 IF(mq.GT.md) tpd = tq - td
49272 IF(mq.LT.md.OR.mq.EQ.md) tpd = td - tq
49273 IF(mq.GT.md) tdpd = td
49274 IF(mq.LT.md.OR.mq.EQ.md) tdpd = tq
49275
49276 IF(mq.GT.md) dlambda1 = 6d0/96d0/pi**2*g1**2*hd**2*tpd
49277 IF(mq.LT.md.OR.mq.EQ.md) dlambda1 = 3d0/32d0/pi**2*
49278 * hd**2*(g1**2/3d0+g2**2)*tpd
49279
49280 IF(mq.GT.mur) dlambda2 =12d0/96d0/pi**2*g1**2*hu**2*tp
49281 IF(mq.LT.mur.OR.mq.EQ.mur) dlambda2 = 3d0/32d0/pi**2*
49282 * hu**2*(-g1**2/3d0+g2**2)*tp
49283
49284CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49285C
49286C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49287C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49288C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49289C TWO STOPS.
49290C
49291C
49292CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49293
49294 dlambdap2 = 0d0
49295 IF(mglu.LT.mur.OR.mglu.LT.mq) THEN
49296 IF(mq.GT.mur.AND.mglu.GT.mur) THEN
49297 dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tglu**2)
49298 ENDIF
49299
49300 IF(mq.GT.mur.AND.mglu.LT.mur) THEN
49301 dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tu**2)
49302 ENDIF
49303
49304 IF(mq.GT.mur.AND.mglu.EQ.mur) THEN
49305 dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tq**2-tu**2)
49306 ENDIF
49307
49308 IF(mur.GT.mq.AND.mglu.GT.mq) THEN
49309 dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tglu**2)
49310 ENDIF
49311
49312 IF(mur.GT.mq.AND.mglu.LT.mq) THEN
49313 dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tq**2)
49314 ENDIF
49315
49316 IF(mur.GT.mq.AND.mglu.EQ.mq) THEN
49317 dlambdap2 = -4d0/(16d0*pi**2)**2*hu**4*(tu**2-tq**2)
49318 ENDIF
49319 ENDIF
49320 dlambda3 = 0d0
49321 dlambda4 = 0d0
49322 IF(mq.GT.md) dlambda3 = -1d0/32d0/pi**2*g1**2*hd**2*tpd
49323 IF(mq.LT.md.OR.mq.EQ.md) dlambda3 = 3d0/64d0/pi**2*hd**2*
49324 *(g2**2-g1**2/3d0)*tpd
49325 IF(mq.GT.mur) dlambda3 = dlambda3 -
49326 *1d0/16d0/pi**2*g1**2*hu**2*tp
49327 IF(mq.LT.mur.OR.mq.EQ.mur) dlambda3 = dlambda3 +
49328 * 3d0/64d0/pi**2*hu**2*(g2**2+g1**2/3d0)*tp
49329 IF(mq.LT.mur) dlambda4 = -3d0/32d0/pi**2*g2**2*hu**2*tp
49330 IF(mq.LT.md) dlambda4 = dlambda4 - 3d0/32d0/pi**2*g2**2*
49331 *hd**2*tpd
49332 lambda1 = ((g1**2 + g2**2)/4d0)*
49333 * (1d0-3d0*hd**2*(tpd + tdpd)/8d0/pi**2)
49334 *+(3d0*hd**4d0/16d0/pi**2) *tpd*(1d0
49335 *+ (3d0*hd**2/2d0 + hu**2/2d0
49336 *- 8d0*g3**2) * (tpd + 2d0*tdpd)/16d0/pi**2)
49337 *+(3d0*hd**4d0/8d0/pi**2) *tdpd*(1d0 + (3d0*hd**2/2d0 + hu**2/2d0
49338 *- 8d0*g3**2) * tdpd/16d0/pi**2) + dlambda1
49339 lambda2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu**2*
49340 *(tp + tdp)/8d0/pi**2)
49341 *+(3d0*hu**4d0/16d0/pi**2) *tp*(1d0
49342 *+ (3d0*hu**2/2d0 + hd**2/2d0
49343 *- 8d0*g3**2) * (tp + 2d0*tdp)/16d0/pi**2)
49344 *+(3d0*hu**4d0/8d0/pi**2) *tdp*(1d0 + (3d0*hu**2/2d0 + hd**2/2d0
49345 *- 8d0*g3**2) * tdp/16d0/pi**2) + dlambda2 + dlambdap2
49346 lambda3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*
49347 *(hu**2)*(tp + tdp)/16d0/pi**2 -3d0*
49348 *(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlambda3
49349 lambda4 = (- g2**2/2d0)*(1d0
49350 *-3d0*(hu**2)*(tp + tdp)/16d0/pi**2
49351 *-3d0*(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlambda4
49352
49353 lambda5 = 0d0
49354 lambda6 = 0d0
49355 lambda7 = 0d0
49356
49357 m2(1,1) = 2d0*v**2*(lambda1*cosb**2+2d0*lambda6*
49358 *cosb*sinb + lambda5*sinb**2) + ma**2*sinb**2
49359
49360 m2(2,2) = 2d0*v**2*(lambda5*cosb**2+2d0*lambda7*
49361 *cosb*sinb + lambda2*sinb**2) + ma**2*cosb**2
49362 m2(1,2) = 2d0*v**2*(lambda6*cosb**2+(lambda3+lambda4)*
49363 *cosb*sinb + lambda7*sinb**2) - ma**2*sinb*cosb
49364
49365 m2(2,1) = m2(1,2)
49366CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49367CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49368CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49369
49370 mssusy=dsqrt(.5d0*(mq**2+mur**2)+mtop**2)
49371
49372 IF(mchi.GT.mssusy) GOTO 100
49373 IF(mchi.LT.mtop) mchi=mtop
49374
49375 tchar=log(mssusy**2/mchi**2)
49376
49377 deltal12=(9d0/64d0/pi**2*g2**4+5d0/192d0/pi**2*g1**4)*tchar
49378 deltal3p4=(3d0/64d0/pi**2*g2**4+7d0/192d0/pi**2*g1**4
49379 *+4d0/32d0/pi**2*g1**2*g2**2)*tchar
49380
49381 deltam112=2d0*deltal12*v**2*cosb**2
49382 deltam222=2d0*deltal12*v**2*sinb**2
49383 deltam122=2d0*deltal3p4*v**2*sinb*cosb
49384
49385 m2(1,1)=m2(1,1)+deltam112
49386 m2(2,2)=m2(2,2)+deltam222
49387 m2(1,2)=m2(1,2)+deltam122
49388 m2(2,1)=m2(2,1)+deltam122
49389
49390 100 CONTINUE
49391
49392CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49393CCC END OF CHARGINOS/NEUTRALINOS
49394CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49395
49396 DO 120 i = 1,2
49397 DO 110 j = 1,2
49398 m2p(i,j) = m2(i,j) + vh(i,j)
49399 110 CONTINUE
49400 120 CONTINUE
49401 trm2p = m2p(1,1) + m2p(2,2)
49402 detm2p = m2p(1,1)*m2p(2,2) - m2p(1,2)*m2p(2,1)
49403 mh2p = (trm2p - dsqrt(trm2p**2 - 4d0* detm2p))/2d0
49404 hm2p = (trm2p + dsqrt(trm2p**2 - 4d0* detm2p))/2d0
49405 hmp = dsqrt(hm2p)
49406 mch2=ma**2+(lambda5-lambda4)*v**2
49407 mch=dsqrt(mch2)
49408 IF(mh2p.LT.0.) GOTO 130
49409 mhp = sqrt(mh2p)
49410 sin2alpha = 2d0*m2p(1,2)/sqrt(trm2p**2-4d0*detm2p)
49411 cos2alpha = (m2p(1,1)-m2p(2,2))/sqrt(trm2p**2-4d0*detm2p)
49412 IF(cos2alpha.GE.0.) THEN
49413 alpha = asin(sin2alpha)/2d0
49414 ELSE
49415 alpha = -pi/2d0-asin(sin2alpha)/2d0
49416 ENDIF
49417 sa = sin(alpha)
49418 ca = cos(alpha)
49419CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49420C
49421C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49422C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49423C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49424C
49425C
49426CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49427 sab = sa*(1d0-deltamb/(1d0+deltamb)*(1d0+ca/sa/tanb))
49428 cab = ca*(1d0-deltamb/(1d0+deltamb)*(1d0-sa/ca/tanb))
49429 130 CONTINUE
49430 RETURN
49431 END
49432
49433C*********************************************************************
49434
49435C...PYGFXX
49436C...Auxiliary to PYRGHM.
49437
49438 SUBROUTINE pygfxx(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49439 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49440 IMPLICIT DOUBLE PRECISION(a-h,m,o-z)
49441 dimension vh(2,2),vh3t(2,2),vh3b(2,2),al(2,2)
49442C...Commonblocks.
49443 INTEGER MSTU,MSTJ,KCHG
49444 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49445 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49446 SAVE /pydat1/,/pydat2/
49447
49448 g(x,y) = 2.d0 - (x+y)/(x-y)*dlog(x/y)
49449
49450 t(x,y,z) = (x**2*y**2*log(x**2/y**2) + x**2*z**2*log(z**2/x**2)
49451 * + y**2*z**2*log(y**2/z**2))/((x**2-y**2)*(y**2-z**2)*(x**2-z**2))
49452
49453 IF(dabs(xmu).LT.0.000001d0) xmu = 0.000001d0
49454 mq2 = mq**2
49455 mur2 = mur**2
49456 md2 = md**2
49457 tanba = tanb
49458 sinba = tanba/dsqrt(tanba**2+1d0)
49459 cosba = sinba/tanba
49460
49461 sinb = tanb/dsqrt(tanb**2+1d0)
49462 cosb = sinb/tanb
49463
49464 pi = paru(1)
49465 mz = pmas(23,1)
49466 mw = pmas(24,1)
49467 sw = 1d0-mw**2/mz**2
49468 v = 174.1d0
49469
49470 alpha3 = 0.12d0/(1d0+23/12d0/pi*0.12d0*log(mtop**2/mz**2))
49471 g2 = dsqrt(0.0336d0*4d0*pi)
49472 g1 = dsqrt(0.0101d0*4d0*pi)
49473
49474 IF(mq.GT.mur) mst = mq
49475 IF(mur.GT.mq.OR.mur.EQ.mq) mst = mur
49476
49477 msusyt = dsqrt(mst**2 + mtop**2)
49478
49479 IF(mq.GT.md) msb = mq
49480 IF(md.GT.mq.OR.md.EQ.mq) msb = md
49481
49482 mb = pymrun(5,msb**2)
49483 msusyb = dsqrt(msb**2 + mb**2)
49484 tt = log(msusyt**2/mtop**2)
49485 tb = log(msusyb**2/mtop**2)
49486
49487 rmtop = mtop/(1d0+4d0*alpha3/3d0/pi)
49488 ht = rmtop/(v*sinb)
49489 htst = rmtop/v
49490 hb = mb/v/cosb
49491 g32 = alpha3*4d0*pi
49492 bt2 = -(8d0*g32 - 9d0*ht**2/2d0 - hb**2/2d0)/(4d0*pi)**2
49493 bb2 = -(8d0*g32 - 9d0*hb**2/2d0 - ht**2/2d0)/(4d0*pi)**2
49494 al2 = 3d0/8d0/pi**2*ht**2
49495C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49496C ALST = 3./8./PI**2*HTST**2
49497 al1 = 3d0/8d0/pi**2*hb**2
49498
49499 al(1,1) = al1
49500 al(1,2) = (al2+al1)/2d0
49501 al(2,1) = (al2+al1)/2d0
49502 al(2,2) = al2
49503
49504 IF(ma.GT.mtop) THEN
49505 vi = v*(1d0 + 3d0/32d0/pi**2*htst**2*
49506 * log(mtop**2/ma**2))
49507 h1i = vi* cosba
49508 h2i = vi*sinba
49509 h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(ma**2/msusyt**2))**.25d0
49510 h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(ma**2/msusyt**2))**.25d0
49511 h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(ma**2/msusyb**2))**.25d0
49512 h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(ma**2/msusyb**2))**.25d0
49513 ELSE
49514 vi = v
49515 h1i = vi*cosb
49516 h2i = vi*sinb
49517 h1t=h1i*(1d0+3d0/8d0/pi**2*hb**2*log(mtop**2/msusyt**2))**.25d0
49518 h2t=h2i*(1d0+3d0/8d0/pi**2*ht**2*log(mtop**2/msusyt**2))**.25d0
49519 h1b=h1i*(1d0+3d0/8d0/pi**2*hb**2*log(mtop**2/msusyb**2))**.25d0
49520 h2b=h2i*(1d0+3d0/8d0/pi**2*ht**2*log(mtop**2/msusyb**2))**.25d0
49521 ENDIF
49522
49523 tanbst = h2t/h1t
49524 sinbt = tanbst/dsqrt(1d0+tanbst**2)
49525
49526 tanbsb = h2b/h1b
49527 sinbb = tanbsb/dsqrt(1d0+tanbsb**2)
49528 cosbb = sinbb/tanbsb
49529
49530 deltamt = 0d0
49531 deltamb = 0d0
49532
49533 mtop4 = rmtop**4*(1d0+2d0*bt2*tt- al2*tt - 4d0*deltamt)
49534 mtop2 = dsqrt(mtop4)
49535 mbot4 = mb**4*(1d0+2d0*bb2*tb - al1*tb)
49536 * /(1d0+deltamb)**4
49537 mbot2 = dsqrt(mbot4)
49538
49539 stop12 = (mq2 + mur2)*.5d0 + mtop2
49540 * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
49541 * +sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
49542 * mq2 - mur2)**2*0.25d0 + mtop2*(at-xmu/tanbst)**2)
49543 stop22 = (mq2 + mur2)*.5d0 + mtop2
49544 * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
49545 * - sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
49546 * mq2 - mur2)**2*0.25d0
49547 * + mtop2*(at-xmu/tanbst)**2)
49548 IF(stop22.LT.0.) GOTO 120
49549 sbot12 = (mq2 + md2)*.5d0
49550 * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
49551 * + sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
49552 * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
49553 sbot22 = (mq2 + md2)*.5d0
49554 * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
49555 * - sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
49556 * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
49557 IF(sbot22.LT.0.) sbot22 = 10000d0
49558
49559 stop1 = dsqrt(stop12)
49560 stop2 = dsqrt(stop22)
49561 sbot1 = dsqrt(sbot12)
49562 sbot2 = dsqrt(sbot22)
49563
49564CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49565C
49566C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49567C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49568C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49569C INDUCED CORRECTIONS.
49570C
49571CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49572
49573 x=sbot1
49574 y=sbot2
49575 z=xmgl
49576 IF(x.EQ.y) x = x - 0.00001d0
49577 IF(x.EQ.z) x = x - 0.00002d0
49578 IF(y.EQ.z) y = y - 0.00003d0
49579
49580 t1=t(x,y,z)
49581 x=stop1
49582 y=stop2
49583 z=xmu
49584 IF(x.EQ.y) x = x - 0.00001d0
49585 IF(x.EQ.z) x = x - 0.00002d0
49586 IF(y.EQ.z) y = y - 0.00003d0
49587 t2=t(x,y,z)
49588 deltamb = -2*alpha3/3d0/pi*xmgl*(ab-xmu*tanb)*t1
49589 * + ht**2/(4d0*pi)**2*(at-xmu/tanb)*xmu*tanb*t2
49590 x=stop1
49591 y=stop2
49592 z=xmgl
49593 IF(x.EQ.y) x = x - 0.00001d0
49594 IF(x.EQ.z) x = x - 0.00002d0
49595 IF(y.EQ.z) y = y - 0.00003d0
49596 t3=t(x,y,z)
49597 deltamt = -2d0*alpha3/3d0/pi*(at-xmu/tanb)*xmgl*t3
49598
49599CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49600C
49601C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49602C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49603C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49604C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49605C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49606C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49607C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49608C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49609C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49610C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49611C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49612C
49613C
49614CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49615
49616 mtop4 = rmtop**4*(1d0+2d0*bt2*tt- al2*tt - 4d0*deltamt)
49617 mtop2 = dsqrt(mtop4)
49618 mbot4 = mb**4*(1d0+2d0*bb2*tb - al1*tb)
49619 * /(1d0+deltamb)**4
49620 mbot2 = dsqrt(mbot4)
49621
49622 stop12 = (mq2 + mur2)*.5d0 + mtop2
49623 * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
49624 * +sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
49625 * mq2 - mur2)**2*0.25d0 + mtop2*(at-xmu/tanbst)**2)
49626 stop22 = (mq2 + mur2)*.5d0 + mtop2
49627 * +1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)
49628 * - sqrt(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +
49629 * mq2 - mur2)**2*0.25d0
49630 * + mtop2*(at-xmu/tanbst)**2)
49631
49632 IF(stop22.LT.0.) GOTO 120
49633 sbot12 = (mq2 + md2)*.5d0
49634 * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
49635 * + sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
49636 * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
49637 sbot22 = (mq2 + md2)*.5d0
49638 * - 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)
49639 * - sqrt(((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +
49640 * mq2 - md2)**2*0.25d0 + mbot2*(ab-xmu*tanbsb)**2)
49641 IF(sbot22.LT.0.) GOTO 120
49642
49643
49644 stop1 = dsqrt(stop12)
49645 stop2 = dsqrt(stop22)
49646 sbot1 = dsqrt(sbot12)
49647 sbot2 = dsqrt(sbot22)
49648
49649CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49650CCC D-TERMS
49651CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49652 stw=sw
49653
49654 f1t=(mq2-mur2)/(stop12-stop22)*(.5d0-4d0/3d0*stw)*
49655 * log(stop1/stop2)
49656 * +(.5d0-2d0/3d0*stw)*log(stop1*stop2/(mq2+mtop2))
49657 * + 2d0/3d0*stw*log(stop1*stop2/(mur2+mtop2))
49658
49659 f1b=(mq2-md2)/(sbot12-sbot22)*(-.5d0+2d0/3d0*stw)*
49660 * log(sbot1/sbot2)
49661 * +(-.5d0+1d0/3d0*stw)*log(sbot1*sbot2/(mq2+mbot2))
49662 * - 1d0/3d0*stw*log(sbot1*sbot2/(md2+mbot2))
49663
49664 f2t=dsqrt(mtop2)*(at-xmu/tanbst)/(stop12-stop22)*
49665 * (-.5d0*log(stop12/stop22)
49666 * +(4d0/3d0*stw-.5d0)*(mq2-mur2)/(stop12-stop22)*
49667 * g(stop12,stop22))
49668
49669 f2b=dsqrt(mbot2)*(ab-xmu*tanbsb)/(sbot12-sbot22)*
49670 * (.5d0*log(sbot12/sbot22)
49671 * +(-2d0/3d0*stw+.5d0)*(mq2-md2)/(sbot12-sbot22)*
49672 * g(sbot12,sbot22))
49673
49674 vh3b(1,1) = mbot4/(cosbb**2)*(log(sbot1**2*sbot2**2/
49675 * (mq2+mbot2)/(md2+mbot2))
49676 * + 2d0*(ab*(ab-xmu*tanbsb)/(sbot1**2-sbot2**2))*
49677 * log(sbot1**2/sbot2**2)) +
49678 * mbot4/(cosbb**2)*(ab*(ab-xmu*tanbsb)/
49679 * (sbot1**2-sbot2**2))**2*g(sbot12,sbot22)
49680
49681 vh3t(1,1) =
49682 * mtop4/(sinbt**2)*(xmu*(-at+xmu/tanbst)/(stop1**2
49683 * -stop2**2))**2*g(stop12,stop22)
49684
49685 vh3b(1,1)=vh3b(1,1)+
49686 * mz**2*(2*mbot2*f1b-dsqrt(mbot2)*ab*f2b)
49687
49688 vh3t(1,1) = vh3t(1,1) +
49689 * mz**2*(dsqrt(mtop2)*xmu/tanbst*f2t)
49690
49691 vh3t(2,2) = mtop4/(sinbt**2)*(log(stop1**2*stop2**2/
49692 * (mq2+mtop2)/(mur2+mtop2))
49693 * + 2d0*(at*(at-xmu/tanbst)/(stop1**2-stop2**2))*
49694 * log(stop1**2/stop2**2)) +
49695 * mtop4/(sinbt**2)*(at*(at-xmu/tanbst)/
49696 * (stop1**2-stop2**2))**2*g(stop12,stop22)
49697
49698 vh3b(2,2) =
49699 * mbot4/(cosbb**2)*(xmu*(-ab+xmu*tanbsb)/(sbot1**2
49700 * -sbot2**2))**2*g(sbot12,sbot22)
49701
49702 vh3t(2,2)=vh3t(2,2)+
49703 * mz**2*(-2*mtop2*f1t+dsqrt(mtop2)*at*f2t)
49704 vh3b(2,2) = vh3b(2,2) -mz**2*dsqrt(mbot2)*xmu*tanbsb*f2b
49705 vh3t(1,2) = -
49706 * mtop4/(sinbt**2)*xmu*(at-xmu/tanbst)/
49707 * (stop1**2-stop2**2)*(log(stop1**2/stop2**2) + at*
49708 * (at - xmu/tanbst)/(stop1**2-stop2**2)*g(stop12,stop22))
49709
49710 vh3b(1,2) =
49711 * - mbot4/(cosbb**2)*xmu*(ab-xmu*tanbsb)/
49712 * (sbot1**2-sbot2**2)*(log(sbot1**2/sbot2**2) + ab*
49713 * (ab - xmu*tanbsb)/(sbot1**2-sbot2**2)*g(sbot12,sbot22))
49714
49715
49716 vh3t(1,2)=vh3t(1,2) +
49717 *mz**2*(mtop2/tanbst*f1t-dsqrt(mtop2)*(at/tanbst+xmu)/2d0*f2t)
49718
49719 vh3b(1,2)=vh3b(1,2) +
49720 *mz**2*(-mbot2*tanbsb*f1b+dsqrt(mbot2)*(ab*tanbsb+xmu)/2d0*f2b)
49721
49722 vh3t(2,1) = vh3t(1,2)
49723 vh3b(2,1) = vh3b(1,2)
49724
49725C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49726C TU = LOG((MUR2+MTOP2)/MTOP2)
49727C TQD = LOG((MQ2 + MB**2)/MB**2)
49728C TD = LOG((MD2+MB**2)/MB**2)
49729
49730 DO 110 i = 1,2
49731 DO 100 j = 1,2
49732 vh(i,j) =
49733 * 6d0/(8d0*pi**2*(h1t**2+h2t**2))
49734 * *vh3t(i,j)*0.5d0*(1d0-al(i,j)*tt/2d0) +
49735 * 6d0/(8d0*pi**2*(h1b**2+h2b**2))
49736 * *vh3b(i,j)*0.5d0*(1d0-al(i,j)*tb/2d0)
49737 100 CONTINUE
49738 110 CONTINUE
49739
49740 GOTO 150
49741 120 DO 140 i =1,2
49742 DO 130 j = 1,2
49743 vh(i,j) = -1d15
49744 130 CONTINUE
49745 140 CONTINUE
49746
49747
49748 150 RETURN
49749 END
49750
49751
49752
49753
49754
49755C*********************************************************************
49756
49757C...PYFINT
49758C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49759
49760 FUNCTION pyfint(A,B,C)
49761
49762C...Double precision and integer declarations.
49763 IMPLICIT DOUBLE PRECISION(a-h, o-z)
49764 IMPLICIT INTEGER(I-N)
49765 INTEGER PYK,PYCHGE,PYCOMP
49766C...Commonblock.
49767 common/pyints/xxm(20)
49768 SAVE/pyints/
49769
49770C...Local variables.
49771 EXTERNAL pyfisb
49772 DOUBLE PRECISION PYFISB
49773
49774 XXM(1)=a
49775 xxm(2)=b
49776 xxm(3)=c
49777 xlo=0d0
49778 xhi=1d0
49779 pyfint = pygaus(pyfisb,xlo,xhi,1d-3)
49780
49781 RETURN
49782 END
49783
49784C*********************************************************************
49785
49786C...PYFISB
49787C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49788
49789 FUNCTION pyfisb(X)
49790
49791C...Double precision and integer declarations.
49792 IMPLICIT DOUBLE PRECISION(a-h, o-z)
49793 IMPLICIT INTEGER(I-N)
49794 INTEGER PYK,PYCHGE,PYCOMP
49795C...Commonblock.
49796 common/pyints/xxm(20)
49797 SAVE/pyints/
49798
49799 pyfisb = log(abs(x*xxm(2)+(1-x)*xxm(3)-x*(1-x)*xxm(1))/
49800 &(x*(xxm(2)-xxm(3))+xxm(3)))
49801
49802 RETURN
49803 END
49804
49805C*********************************************************************
49806
49807C...PYSFDC
49808C...Calculates decays of sfermions.
49809
49810 SUBROUTINE pysfdc(KFIN,XLAM,IDLAM,IKNT)
49811
49812C...Double precision and integer declarations.
49813 IMPLICIT DOUBLE PRECISION(a-h, o-z)
49814 IMPLICIT INTEGER(I-N)
49815 INTEGER PYK,PYCHGE,PYCOMP
49816C...Parameter statement to help give large particle numbers.
49817 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
49818 &kexcit=4000000,kdimen=5000000)
49819C...Commonblocks.
49820 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
49821 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
49822 common/pymssm/imss(0:99),rmss(0:99)
49823 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
49824 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
49825 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
49826
49827C...Local variables.
49828 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49829 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49830 INTEGER KFIN,KCIN
49831 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49832 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49833 DOUBLE PRECISION PYLAMF,XL
49834 DOUBLE PRECISION TANW,XW,AEM,C1,AS
49835 DOUBLE PRECISION AL,AR,BL,BR
49836 DOUBLE PRECISION CH1,CH2,CH3,CH4
49837 DOUBLE PRECISION XMBOT,XMTOP
49838 DOUBLE PRECISION XLAM(0:400)
49839 INTEGER IDLAM(400,3)
49840 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49841 DOUBLE PRECISION SR2
49842 DOUBLE PRECISION CBETA,SBETA
49843 DOUBLE PRECISION CW
49844 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49845 DOUBLE PRECISION COSA,SINA,TANB
49846 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49847 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49848 INTEGER IG,KF1,KF2
49849 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49850 DATA igg/23,25,35,36/
49851 DATA pi/3.141592654d0/
49852 DATA sr2/1.4142136d0/
49853 DATA kfnchi/1000022,1000023,1000025,1000035/
49854 DATA kfcchi/1000024,1000037/
49855
49856C...COUNT THE NUMBER OF DECAY MODES
49857 lknt=0
49858
49859C...NO NU_R DECAYS
49860 IF(kfin.EQ.ksusy2+12.OR.kfin.EQ.ksusy2+14.OR.
49861 &kfin.EQ.ksusy2+16) RETURN
49862
49863 xmw=pmas(24,1)
49864 xmw2=xmw**2
49865 xmz=pmas(23,1)
49866 xw=paru(102)
49867 tanw = sqrt(xw/(1d0-xw))
49868 cw=sqrt(1d0-xw)
49869
49870 DO 110 i=1,4
49871 DO 100 j=1,4
49872 zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
49873 100 CONTINUE
49874 110 CONTINUE
49875 DO 130 i=1,2
49876 DO 120 j=1,2
49877 vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
49878 umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
49879 120 CONTINUE
49880 130 CONTINUE
49881
49882C...KCIN
49883 kcin=pycomp(kfin)
49884C...ILR is 1 for left and 2 for right.
49885 ilr=kfin/ksusy1
49886C...IFL is matching non-SUSY flavour.
49887 ifl=mod(kfin,ksusy1)
49888C...IDU is weak isospin, 1 for down and 2 for up.
49889 idu=2-mod(ifl,2)
49890
49891 xmi=pmas(kcin,1)
49892 xmi2=xmi**2
49893 aem=pyalem(xmi2)
49894 as =pyalps(xmi2)
49895 c1=aem/xw
49896 xmi3=xmi**3
49897 ei=kchg(ifl,1)/3d0
49898
49899 xmbot=pymrun(5,xmi2)
49900 xmtop=pymrun(6,xmi2)
49901
49902 tanb=rmss(5)
49903 beta=atan(tanb)
49904 alfa=rmss(18)
49905 cbeta=cos(beta)
49906 sbeta=tanb*cbeta
49907 sina=sin(alfa)
49908 cosa=cos(alfa)
49909 xmu=-rmss(4)
49910 atrit=rmss(16)
49911 atrib=rmss(15)
49912 atril=rmss(17)
49913
49914C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
49915
49916 IF(imss(11).EQ.1) THEN
49917 xmp=rmss(29)
49918 idg=39+ksusy1
49919 xmgr=pmas(pycomp(idg),1)
49920 xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi
49921 IF(ifl.EQ.5) THEN
49922 xmf=xmbot
49923 ELSEIF(ifl.EQ.6) THEN
49924 xmf=xmtop
49925 ELSE
49926 xmf=pmas(ifl,1)
49927 ENDIF
49928 IF(xmi.GT.xmgr+xmf) THEN
49929 lknt=lknt+1
49930 idlam(lknt,1)=idg
49931 idlam(lknt,2)=ifl
49932 idlam(lknt,3)=0
49933 xlam(lknt)=xfac*(1d0-xmf**2/xmi2)**4
49934 ENDIF
49935 ENDIF
49936
49937C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
49938
49939C...CHARGED DECAYS:
49940 DO 140 ix=1,2
49941C...DI -> U CHI1-,CHI2-
49942 IF(idu.EQ.1) THEN
49943 xmfp=pmas(ifl+1,1)
49944 xmf =pmas(ifl,1)
49945C...UI -> D CHI1+,CHI2+
49946 ELSE
49947 xmfp=pmas(ifl-1,1)
49948 xmf =pmas(ifl,1)
49949 ENDIF
49950 xmj=smw(ix)
49951 axmj=abs(xmj)
49952 IF(xmi.GE.axmj+xmfp) THEN
49953 xma2=xmj**2
49954 xmb2=xmfp**2
49955 IF(idu.EQ.2) THEN
49956 IF(ifl.EQ.6) THEN
49957 xmfp=xmbot
49958 xmf =xmtop
49959 ELSEIF(ifl.LT.6) THEN
49960 xmf=0d0
49961 xmfp=0d0
49962 ENDIF
49963 cbl=vmixc(ix,1)
49964 cal=-xmfp*umixc(ix,2)/sr2/xmw/cbeta
49965 cbr=-xmf*vmixc(ix,2)/sr2/xmw/sbeta
49966 car=0d0
49967 ELSE
49968 IF(ifl.EQ.5) THEN
49969 xmf =xmbot
49970 xmfp=xmtop
49971 ELSEIF(ifl.LT.5) THEN
49972 xmf=0d0
49973 xmfp=0d0
49974 ENDIF
49975 cbl=umixc(ix,1)
49976 cal=-xmfp*vmixc(ix,2)/sr2/xmw/sbeta
49977 cbr=-xmf*umixc(ix,2)/sr2/xmw/cbeta
49978 car=0d0
49979 ENDIF
49980
49981 calp=sfmix(ifl,1)*cal + sfmix(ifl,2)*car
49982 cblp=sfmix(ifl,1)*cbl + sfmix(ifl,2)*cbr
49983 carp=sfmix(ifl,4)*car + sfmix(ifl,3)*cal
49984 cbrp=sfmix(ifl,4)*cbr + sfmix(ifl,3)*cbl
49985 cal=calp
49986 cbl=cblp
49987 car=carp
49988 cbr=cbrp
49989
49990C...F1 -> F` CHI
49991 IF(ilr.EQ.1) THEN
49992 ca=cal
49993 cb=cbl
49994C...F2 -> F` CHI
49995 ELSE
49996 ca=car
49997 cb=cbr
49998 ENDIF
49999 lknt=lknt+1
50000 xl=pylamf(xmi2,xma2,xmb2)
50001C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50002 xlam(lknt)=2d0*c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
50003 & (abs(ca)**2+abs(cb)**2)-4d0*dble(ca*dconjg(cb))*xmj*xmfp)
50004 idlam(lknt,3)=0
50005 IF(idu.EQ.1) THEN
50006 idlam(lknt,1)=-kfcchi(ix)
50007 idlam(lknt,2)=ifl+1
50008 ELSE
50009 idlam(lknt,1)=kfcchi(ix)
50010 idlam(lknt,2)=ifl-1
50011 ENDIF
50012 ENDIF
50013 140 CONTINUE
50014
50015C...NEUTRAL DECAYS
50016 DO 150 ix=1,4
50017C...DI -> D CHI10
50018 xmf=pmas(ifl,1)
50019 xmj=smz(ix)
50020 axmj=abs(xmj)
50021 IF(xmi.GE.axmj+xmf) THEN
50022 xma2=xmj**2
50023 xmb2=xmf**2
50024 IF(idu.EQ.1) THEN
50025 IF(ifl.EQ.5) THEN
50026 xmf=xmbot
50027 ELSEIF(ifl.LT.5) THEN
50028 xmf=0d0
50029 ENDIF
50030 cbl=-zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei+1)
50031 cal=xmf*zmixc(ix,3)/xmw/cbeta
50032 car=-2d0*ei*tanw*zmixc(ix,1)
50033 cbr=cal
50034 ELSE
50035 IF(ifl.EQ.6) THEN
50036 xmf=xmtop
50037 ELSEIF(ifl.LT.5) THEN
50038 xmf=0d0
50039 ENDIF
50040 cbl=zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-1)
50041 cal=xmf*zmixc(ix,4)/xmw/sbeta
50042 car=-2d0*ei*tanw*zmixc(ix,1)
50043 cbr=cal
50044 ENDIF
50045
50046 calp=sfmix(ifl,1)*cal + sfmix(ifl,2)*car
50047 cblp=sfmix(ifl,1)*cbl + sfmix(ifl,2)*cbr
50048 carp=sfmix(ifl,4)*car + sfmix(ifl,3)*cal
50049 cbrp=sfmix(ifl,4)*cbr + sfmix(ifl,3)*cbl
50050 cal=calp
50051 cbl=cblp
50052 car=carp
50053 cbr=cbrp
50054
50055C...F1 -> F CHI
50056 IF(ilr.EQ.1) THEN
50057 ca=cal
50058 cb=cbl
50059C...F2 -> F CHI
50060 ELSE
50061 ca=car
50062 cb=cbr
50063 ENDIF
50064 lknt=lknt+1
50065 xl=pylamf(xmi2,xma2,xmb2)
50066C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50067 xlam(lknt)=c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
50068 & (abs(ca)**2+abs(cb)**2)-4d0*dble(ca*dconjg(cb))*xmj*xmf)
50069 idlam(lknt,1)=kfnchi(ix)
50070 idlam(lknt,2)=ifl
50071 idlam(lknt,3)=0
50072 ENDIF
50073 150 CONTINUE
50074
50075C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50076C...IG=23,25,35,36
50077 DO 160 ii=1,4
50078 ig=igg(ii)
50079 IF(ilr.EQ.1) GOTO 160
50080 xmb=pmas(ig,1)
50081 xmsf1=pmas(pycomp(kfin-ksusy1),1)
50082 IF(xmi.LT.xmsf1+xmb) GOTO 160
50083 IF(ig.EQ.23) THEN
50084 bl=-sign(.5d0,ei)/cw+ei*xw/cw
50085 br=ei*xw/cw
50086 blr=0d0
50087 ELSEIF(ig.EQ.25) THEN
50088 IF(ifl.EQ.5) THEN
50089 xmf=xmbot
50090 ELSEIF(ifl.EQ.6) THEN
50091 xmf=xmtop
50092 ELSEIF(ifl.LT.5) THEN
50093 xmf=0d0
50094 ELSE
50095 xmf=pmas(ifl,1)
50096 ENDIF
50097 IF(idu.EQ.2) THEN
50098 ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
50099 & xmf**2/xmw*cosa/sbeta
50100 ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
50101 & xmf**2/xmw*cosa/sbeta
50102 ELSE
50103 ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+
50104 & xmf**2/xmw*(-sina)/cbeta
50105 ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+
50106 & xmf**2/xmw*(-sina)/cbeta
50107 ENDIF
50108 IF(ifl.EQ.5) THEN
50109 at=atrib
50110 ELSEIF(ifl.EQ.6) THEN
50111 at=atrit
50112 ELSEIF(ifl.EQ.15) THEN
50113 at=atril
50114 ELSE
50115 at=0d0
50116 ENDIF
50117C.........need to complexify
50118 IF(idu.EQ.2) THEN
50119 ghlr=xmf/2d0/xmw/sbeta*(-xmu*sina+
50120 & at*cosa)
50121 ELSE
50122 ghlr=xmf/2d0/xmw/cbeta*(xmu*cosa-
50123 & at*sina)
50124 ENDIF
50125 bl=ghll
50126 br=ghrr
50127 blr=-ghlr
50128 ELSEIF(ig.EQ.35) THEN
50129 IF(ifl.EQ.5) THEN
50130 xmf=xmbot
50131 ELSEIF(ifl.EQ.6) THEN
50132 xmf=xmtop
50133 ELSEIF(ifl.LT.5) THEN
50134 xmf=0d0
50135 ELSE
50136 xmf=pmas(ifl,1)
50137 ENDIF
50138 IF(idu.EQ.2) THEN
50139 ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
50140 & xmf**2/xmw*sina/sbeta
50141 ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
50142 & xmf**2/xmw*sina/sbeta
50143 ELSE
50144 ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+
50145 & xmf**2/xmw*cosa/cbeta
50146 ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+
50147 & xmf**2/xmw*cosa/cbeta
50148 ENDIF
50149 IF(ifl.EQ.5) THEN
50150 at=atrib
50151 ELSEIF(ifl.EQ.6) THEN
50152 at=atrit
50153 ELSEIF(ifl.EQ.15) THEN
50154 at=atril
50155 ELSE
50156 at=0d0
50157 ENDIF
50158C.........Need to complexify
50159 IF(idu.EQ.2) THEN
50160 ghlr=xmf/2d0/xmw/sbeta*(xmu*cosa+
50161 & at*sina)
50162 ELSE
50163 ghlr=xmf/2d0/xmw/cbeta*(xmu*sina+
50164 & at*cosa)
50165 ENDIF
50166 bl=ghll
50167 br=ghrr
50168 blr=ghlr
50169 ELSEIF(ig.EQ.36) THEN
50170 ghll=0d0
50171 ghrr=0d0
50172 IF(ifl.EQ.5) THEN
50173 xmf=xmbot
50174 ELSEIF(ifl.EQ.6) THEN
50175 xmf=xmtop
50176 ELSEIF(ifl.LT.5) THEN
50177 xmf=0d0
50178 ELSE
50179 xmf=pmas(ifl,1)
50180 ENDIF
50181 IF(ifl.EQ.5) THEN
50182 at=atrib
50183 ELSEIF(ifl.EQ.6) THEN
50184 at=atrit
50185 ELSEIF(ifl.EQ.15) THEN
50186 at=atril
50187 ELSE
50188 at=0d0
50189 ENDIF
50190C.........Need to complexify
50191 IF(idu.EQ.2) THEN
50192 ghlr=xmf/2d0/xmw*(-xmu+at/tanb)
50193 ELSE
50194 ghlr=xmf/2d0/xmw/(-xmu+at*tanb)
50195 ENDIF
50196 bl=ghll
50197 br=ghrr
50198 blr=ghlr
50199 ENDIF
50200 al=sfmix(ifl,1)*sfmix(ifl,3)*bl+
50201 & sfmix(ifl,2)*sfmix(ifl,4)*br+
50202 & (sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,3)*sfmix(ifl,2))*blr
50203 xl=pylamf(xmi2,xmsf1**2,xmb**2)
50204 lknt=lknt+1
50205 IF(ig.EQ.23) THEN
50206 xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
50207 ELSE
50208 xlam(lknt)=c1/4d0/xmi3*sqrt(xl)*al**2
50209 ENDIF
50210 idlam(lknt,3)=0
50211 idlam(lknt,1)=kfin-ksusy1
50212 idlam(lknt,2)=ig
50213 160 CONTINUE
50214
50215C...SF -> SF' + W
50216 xmb=pmas(24,1)
50217 IF(mod(ifl,2).EQ.0) THEN
50218 kf1=ksusy1+ifl-1
50219 ELSE
50220 kf1=ksusy1+ifl+1
50221 ENDIF
50222 kf2=kf1+ksusy1
50223 xmsf1=pmas(pycomp(kf1),1)
50224 xmsf2=pmas(pycomp(kf2),1)
50225 IF(xmi.GT.xmb+xmsf1) THEN
50226 IF(mod(ifl,2).EQ.0) THEN
50227 IF(ilr.EQ.1) THEN
50228 al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,1)
50229 ELSE
50230 al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,1)
50231 ENDIF
50232 ELSE
50233 IF(ilr.EQ.1) THEN
50234 al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,1)
50235 ELSE
50236 al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,1)
50237 ENDIF
50238 ENDIF
50239 xl=pylamf(xmi2,xmsf1**2,xmb**2)
50240 lknt=lknt+1
50241 xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
50242 idlam(lknt,3)=0
50243 idlam(lknt,1)=kf1
50244 idlam(lknt,2)=sign(24,kchg(ifl,1))
50245 ENDIF
50246 IF(xmi.GT.xmb+xmsf2) THEN
50247 IF(mod(ifl,2).EQ.0) THEN
50248 IF(ilr.EQ.1) THEN
50249 al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,3)
50250 ELSE
50251 al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,3)
50252 ENDIF
50253 ELSE
50254 IF(ilr.EQ.1) THEN
50255 al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,3)
50256 ELSE
50257 al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,3)
50258 ENDIF
50259 ENDIF
50260 xl=pylamf(xmi2,xmsf2**2,xmb**2)
50261 lknt=lknt+1
50262 xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2
50263 idlam(lknt,3)=0
50264 idlam(lknt,1)=kf2
50265 idlam(lknt,2)=sign(24,kchg(ifl,1))
50266 ENDIF
50267
50268C...SF -> SF' + HC
50269 xmb=pmas(37,1)
50270 IF(mod(ifl,2).EQ.0) THEN
50271 kf1=ksusy1+ifl-1
50272 ELSE
50273 kf1=ksusy1+ifl+1
50274 ENDIF
50275 kf2=kf1+ksusy1
50276 xmsf1=pmas(pycomp(kf1),1)
50277 xmsf2=pmas(pycomp(kf2),1)
50278 IF(xmi.GT.xmb+xmsf1) THEN
50279 xmf=0d0
50280 xmfp=0d0
50281 at=0d0
50282 ab=0d0
50283 IF(mod(ifl,2).EQ.0) THEN
50284C...T1-> B1 HC
50285 IF(ilr.EQ.1) THEN
50286 ch1=-sfmix(ifl,1)*sfmix(ifl-1,1)
50287 ch2= sfmix(ifl,2)*sfmix(ifl-1,2)
50288 ch3=-sfmix(ifl,1)*sfmix(ifl-1,2)
50289 ch4=-sfmix(ifl,2)*sfmix(ifl-1,1)
50290C...T2-> B1 HC
50291 ELSE
50292 ch1= sfmix(ifl,3)*sfmix(ifl-1,1)
50293 ch2=-sfmix(ifl,4)*sfmix(ifl-1,2)
50294 ch3= sfmix(ifl,3)*sfmix(ifl-1,2)
50295 ch4= sfmix(ifl,4)*sfmix(ifl-1,1)
50296 ENDIF
50297 IF(ifl.EQ.6) THEN
50298 xmf=xmtop
50299 xmfp=xmbot
50300 at=atrit
50301 ab=atrib
50302 ENDIF
50303 ELSE
50304C...B1 -> T1 HC
50305 IF(ilr.EQ.1) THEN
50306 ch1=-sfmix(ifl+1,1)*sfmix(ifl,1)
50307 ch2= sfmix(ifl+1,2)*sfmix(ifl,2)
50308 ch3=-sfmix(ifl+1,1)*sfmix(ifl,2)
50309 ch4=-sfmix(ifl+1,2)*sfmix(ifl,1)
50310C...B2-> T1 HC
50311 ELSE
50312 ch1= sfmix(ifl,3)*sfmix(ifl+1,1)
50313 ch2=-sfmix(ifl,4)*sfmix(ifl+1,2)
50314 ch3= sfmix(ifl,4)*sfmix(ifl+1,1)
50315 ch4= sfmix(ifl,3)*sfmix(ifl+1,2)
50316 ENDIF
50317 IF(ifl.EQ.5) THEN
50318 xmf=xmtop
50319 xmfp=xmbot
50320 at=atrit
50321 ab=atrib
50322 ENDIF
50323 ENDIF
50324 xl=pylamf(xmi2,xmsf1**2,xmb**2)
50325 lknt=lknt+1
50326C.......Need to complexify
50327 al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
50328 & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
50329 & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
50330 xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
50331 idlam(lknt,3)=0
50332 idlam(lknt,1)=kf1
50333 idlam(lknt,2)=sign(37,kchg(ifl,1))
50334 ENDIF
50335 IF(xmi.GT.xmb+xmsf2) THEN
50336 xmf=0d0
50337 xmfp=0d0
50338 at=0d0
50339 ab=0d0
50340 IF(mod(ifl,2).EQ.0) THEN
50341C...T1-> B2 HC
50342 IF(ilr.EQ.1) THEN
50343 ch1= sfmix(ifl-1,3)*sfmix(ifl,1)
50344 ch2=-sfmix(ifl-1,4)*sfmix(ifl,2)
50345 ch3= sfmix(ifl-1,4)*sfmix(ifl,1)
50346 ch4= sfmix(ifl-1,3)*sfmix(ifl,2)
50347C...T2-> B2 HC
50348 ELSE
50349 ch1= -sfmix(ifl,3)*sfmix(ifl-1,3)
50350 ch2= sfmix(ifl,4)*sfmix(ifl-1,4)
50351 ch3= -sfmix(ifl,3)*sfmix(ifl-1,4)
50352 ch4= -sfmix(ifl,4)*sfmix(ifl-1,3)
50353 ENDIF
50354 IF(ifl.EQ.6) THEN
50355 xmf=xmtop
50356 xmfp=xmbot
50357 at=atrit
50358 ab=atrib
50359 ENDIF
50360 ELSE
50361C...B1 -> T2 HC
50362 IF(ilr.EQ.1) THEN
50363 ch1= sfmix(ifl+1,3)*sfmix(ifl,1)
50364 ch2=-sfmix(ifl+1,4)*sfmix(ifl,2)
50365 ch3= sfmix(ifl+1,3)*sfmix(ifl,2)
50366 ch4= sfmix(ifl+1,4)*sfmix(ifl,1)
50367C...B2-> T2 HC
50368 ELSE
50369 ch1= -sfmix(ifl+1,3)*sfmix(ifl,3)
50370 ch2= sfmix(ifl+1,4)*sfmix(ifl,4)
50371 ch3= -sfmix(ifl+1,3)*sfmix(ifl,4)
50372 ch4= -sfmix(ifl+1,4)*sfmix(ifl,3)
50373 ENDIF
50374 IF(ifl.EQ.5) THEN
50375 xmf=xmtop
50376 xmfp=xmbot
50377 at=atrit
50378 ab=atrib
50379 ENDIF
50380 ENDIF
50381 xl=pylamf(xmi2,xmsf1**2,xmb**2)
50382 lknt=lknt+1
50383C.......Need to complexify
50384 al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+
50385 & ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+
50386 & ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)
50387 xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2
50388 idlam(lknt,3)=0
50389 idlam(lknt,1)=kf2
50390 idlam(lknt,2)=sign(37,kchg(ifl,1))
50391 ENDIF
50392
50393C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50394
50395 IF(ifl.LE.6) THEN
50396 xmfp=0d0
50397 xmf=0d0
50398 IF(ifl.EQ.6) xmf=pmas(6,1)
50399 IF(ifl.EQ.5) xmf=pmas(5,1)
50400 xmj=pmas(pycomp(ksusy1+21),1)
50401 axmj=abs(xmj)
50402 IF(xmi.GE.axmj+xmf) THEN
50403 al=-sfmix(ifl,3)
50404 bl=sfmix(ifl,1)
50405 ar=-sfmix(ifl,4)
50406 br=sfmix(ifl,2)
50407C...F1 -> F CHI
50408 IF(ilr.EQ.1) THEN
50409 xca=al
50410 xcb=bl
50411C...F2 -> F CHI
50412 ELSE
50413 xca=ar
50414 xcb=br
50415 ENDIF
50416 lknt=lknt+1
50417 xma2=xmj**2
50418 xmb2=xmf**2
50419 xl=pylamf(xmi2,xma2,xmb2)
50420 xlam(lknt)=4d0/3d0*as/2d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*
50421 & (xca**2+xcb**2)+4d0*xca*xcb*xmj*xmf)
50422 idlam(lknt,1)=ksusy1+21
50423 idlam(lknt,2)=ifl
50424 idlam(lknt,3)=0
50425 ENDIF
50426 ENDIF
50427
50428C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50429 IF(kfin.EQ.ksusy1+6.AND.pmas(kcin,1).GT.
50430 &pmas(pycomp(ksusy1+22),1)+pmas(4,1)) THEN
50431C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50432C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50433C...M*M = C1**2 * G**2/(16PI**2)
50434C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50435 lknt=lknt+1
50436 xl=pylamf(xmi2,0d0,pmas(pycomp(ksusy1+22),1)**2)
50437 xlam(lknt)=c1**3/64d0/pi**2/xmi3*sqrt(xl)
50438 IF(xlam(lknt).EQ.0) xlam(lknt)=1d-3
50439 idlam(lknt,1)=ksusy1+22
50440 idlam(lknt,2)=4
50441 idlam(lknt,3)=0
50442 ENDIF
50443
50444C...R-violating sfermion decays (SKANDS).
50445 CALL pyrvsf(kfin,xlam,idlam,lknt)
50446
50447 iknt=lknt
50448 xlam(0)=0d0
50449 DO 170 i=1,iknt
50450 IF(xlam(i).LT.0d0) xlam(i)=0d0
50451 xlam(0)=xlam(0)+xlam(i)
50452 170 CONTINUE
50453 IF(xlam(0).EQ.0d0) xlam(0)=1d-3
50454
50455 RETURN
50456 END
50457
50458C*********************************************************************
50459
50460C...PYGLUI
50461C...Calculates gluino decay modes.
50462
50463 SUBROUTINE pyglui(KFIN,XLAM,IDLAM,IKNT)
50464
50465C...Double precision and integer declarations.
50466 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50467 IMPLICIT INTEGER(I-N)
50468 INTEGER PYK,PYCHGE,PYCOMP
50469C...Parameter statement to help give large particle numbers.
50470 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
50471 &kexcit=4000000,kdimen=5000000)
50472C...Commonblocks.
50473 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50474 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
50475 common/pymssm/imss(0:99),rmss(0:99)
50476 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
50477 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
50478CC &SFMIX(16,4),
50479C COMMON/PYINTS/XXM(20)
50480 COMPLEX*16 CXC
50481 COMMON/PYINTC/XXC(10),CXC(8)
50482 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50483
50484C...Local variables
50485 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50486 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50487 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50488 DOUBLE PRECISION PYLAMF,XL
50489 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50490 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50491 DOUBLE PRECISION XLAM(0:400)
50492 INTEGER IDLAM(400,3)
50493 INTEGER LKNT,IX,ILR,I,IKNT,IFL
50494 DOUBLE PRECISION SR2
50495 DOUBLE PRECISION GAM
50496 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50497 EXTERNAL pygaus,pyxxz6
50498 DOUBLE PRECISION PYGAUS,PYXXZ6
50499 DOUBLE PRECISION PREC
50500 INTEGER KFNCHI(4),KFCCHI(2)
50501 DATA pi/3.141592654d0/
50502 DATA sr2/1.4142136d0/
50503 DATA prec/1d-2/
50504 DATA kfnchi/1000022,1000023,1000025,1000035/
50505 DATA kfcchi/1000024,1000037/
50506
50507C...COUNT THE NUMBER OF DECAY MODES
50508 lknt=0
50509 IF(kfin.NE.ksusy1+21) RETURN
50510 kcin=pycomp(kfin)
50511
50512 xw=paru(102)
50513 tanw = sqrt(xw/(1d0-xw))
50514
50515 xmi=pmas(kcin,1)
50516 axmi=abs(xmi)
50517 xmi2=xmi**2
50518 aem=pyalem(xmi2)
50519 as =pyalps(xmi2)
50520 c1=aem/xw
50521 xmi3=axmi**3
50522
50523 xmi=sign(xmi,rmss(3))
50524
50525C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50526
50527 IF(imss(11).EQ.1) THEN
50528 xmp=rmss(29)
50529 idg=39+ksusy1
50530 xmgr=pmas(pycomp(idg),1)
50531 xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
50532 IF(axmi.GT.xmgr) THEN
50533 lknt=lknt+1
50534 idlam(lknt,1)=idg
50535 idlam(lknt,2)=21
50536 idlam(lknt,3)=0
50537 xlam(lknt)=xfac
50538 ENDIF
50539 ENDIF
50540
50541C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50542
50543 DO 110 ifl=1,6
50544 DO 100 ilr=1,2
50545 xmj=pmas(pycomp(ilr*ksusy1+ifl),1)
50546 axmj=abs(xmj)
50547 xmf=pmas(ifl,1)
50548 IF(axmi.GE.axmj+xmf) THEN
50549C...Minus sign difference from gluino-quark-squark feynman rules
50550 al=sfmix(ifl,1)
50551 bl=-sfmix(ifl,3)
50552 ar=sfmix(ifl,2)
50553 br=-sfmix(ifl,4)
50554C...F1 -> F CHI
50555 IF(ilr.EQ.1) THEN
50556 ca=al
50557 cb=bl
50558C...F2 -> F CHI
50559 ELSE
50560 ca=ar
50561 cb=br
50562 ENDIF
50563 lknt=lknt+1
50564 xma2=xmj**2
50565 xmb2=xmf**2
50566 xl=pylamf(xmi2,xma2,xmb2)
50567 xlam(lknt)=4d0/8d0*as/4d0/xmi3*sqrt(xl)*((xmi2+xmb2-xma2)*
50568 & (ca**2+cb**2)-4d0*ca*cb*xmi*xmf)
50569 idlam(lknt,1)=ilr*ksusy1+ifl
50570 idlam(lknt,2)=-ifl
50571 idlam(lknt,3)=0
50572 lknt=lknt+1
50573 xlam(lknt)=xlam(lknt-1)
50574 idlam(lknt,1)=-idlam(lknt-1,1)
50575 idlam(lknt,2)=-idlam(lknt-1,2)
50576 idlam(lknt,3)=0
50577 ENDIF
50578 100 CONTINUE
50579 110 CONTINUE
50580
50581C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50582C...GLUINO -> NI Q QBAR
50583 DO 170 ix=1,4
50584 xmj=smz(ix)
50585 axmj=abs(xmj)
50586 IF(axmi.GE.axmj) THEN
50587 DO 120 i=1,4
50588 zmixc(ix,i)=dcmplx(zmix(ix,i),zmixi(ix,i))
50589 120 CONTINUE
50590 olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))/sr2
50591 orpp=dconjg(olpp)
50592 xxc(1)=0d0
50593 xxc(2)=xmj
50594 xxc(3)=0d0
50595 xxc(4)=xmi
50596 ia=1
50597 xxc(5)=pmas(pycomp(ksusy1+ia),1)
50598 xxc(6)=pmas(pycomp(ksusy2+ia),1)
50599 xxc(7)=xxc(5)
50600 xxc(8)=xxc(6)
50601 xxc(9)=1d6
50602 xxc(10)=0d0
50603 ei=kchg(ia,1)/3d0
50604 t3i=sign(1d0,ei+1d-6)/2d0
50605 glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
50606 grij=zmixc(ix,1)*(ei*tanw)*orpp
50607 cxc(1)=0d0
50608 cxc(2)=-glij
50609 cxc(3)=0d0
50610 cxc(4)=dconjg(glij)
50611 cxc(5)=0d0
50612 cxc(6)=grij
50613 cxc(7)=0d0
50614 cxc(8)=-dconjg(grij)
50615 s12min=0d0
50616 s12max=(axmi-axmj)**2
50617 IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 130
50618 IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
50619 lknt=lknt+1
50620 xlam(lknt)=c1*as/xmi3/(16d0*pi)*
50621 & pygaus(pyxxz6,s12min,s12max,1d-2)
50622 idlam(lknt,1)=kfnchi(ix)
50623 idlam(lknt,2)=1
50624 idlam(lknt,3)=-1
50625 ENDIF
50626 IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
50627 lknt=lknt+1
50628 xlam(lknt)=xlam(lknt-1)
50629 idlam(lknt,1)=kfnchi(ix)
50630 idlam(lknt,2)=3
50631 idlam(lknt,3)=-3
50632 ENDIF
50633 130 CONTINUE
50634 IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
50635 pmold=pmas(pycomp(ksusy1+5),1)
50636 IF(axmi.GT.pmas(pycomp(ksusy2+5),1)+pmas(5,1)) THEN
50637 GOTO 140
50638 ELSEIF(axmi.GT.pmas(pycomp(ksusy1+5),1)+pmas(5,1)) THEN
50639 pmas(pycomp(ksusy1+5),1)=100d0*xmi
50640 ENDIF
50641 CALL pytbbn(ix,100,-1d0/3d0,xmi,gam)
50642 lknt=lknt+1
50643 xlam(lknt)=gam
50644 idlam(lknt,1)=kfnchi(ix)
50645 idlam(lknt,2)=5
50646 idlam(lknt,3)=-5
50647 pmas(pycomp(ksusy1+5),1)=pmold
50648 ENDIF
50649C...U-TYPE QUARKS
50650 140 CONTINUE
50651 ia=2
50652 xxc(5)=pmas(pycomp(ksusy1+ia),1)
50653 xxc(6)=pmas(pycomp(ksusy2+ia),1)
50654C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50655 xxc(7)=xxc(5)
50656 xxc(8)=xxc(6)
50657 ei=kchg(ia,1)/3d0
50658 t3i=sign(1d0,ei+1d-6)/2d0
50659 glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
50660 grij=zmixc(ix,1)*(ei*tanw)*orpp
50661 cxc(2)=-glij
50662 cxc(4)=dconjg(glij)
50663 cxc(6)=grij
50664 cxc(8)=-dconjg(grij)
50665 IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 150
50666 IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
50667 lknt=lknt+1
50668 xlam(lknt)=c1*as/xmi3/(16d0*pi)*
50669 & pygaus(pyxxz6,s12min,s12max,1d-2)
50670 idlam(lknt,1)=kfnchi(ix)
50671 idlam(lknt,2)=2
50672 idlam(lknt,3)=-2
50673 ENDIF
50674 IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
50675 lknt=lknt+1
50676 xlam(lknt)=xlam(lknt-1)
50677 idlam(lknt,1)=kfnchi(ix)
50678 idlam(lknt,2)=4
50679 idlam(lknt,3)=-4
50680 ENDIF
50681 150 CONTINUE
50682C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50683C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50684 xmf=pmas(6,1)
50685 IF(axmi.GE.axmj+2d0*xmf) THEN
50686 pmold=pmas(pycomp(ksusy1+6),1)
50687 IF(axmi.GT.pmas(pycomp(ksusy2+6),1)+xmf) THEN
50688 GOTO 160
50689 ELSEIF(axmi.GT.pmas(pycomp(ksusy1+6),1)+xmf) THEN
50690 pmas(pycomp(ksusy1+6),1)=100d0*xmi
50691 ENDIF
50692 CALL pytbbn(ix,100,2d0/3d0,xmi,gam)
50693 lknt=lknt+1
50694 xlam(lknt)=gam
50695 idlam(lknt,1)=kfnchi(ix)
50696 idlam(lknt,2)=6
50697 idlam(lknt,3)=-6
50698 pmas(pycomp(ksusy1+6),1)=pmold
50699 ENDIF
50700 160 CONTINUE
50701 ENDIF
50702 170 CONTINUE
50703
50704C...GLUINO -> CI Q QBAR'
50705 DO 210 ix=1,2
50706 xmj=smw(ix)
50707 axmj=abs(xmj)
50708 IF(axmi.GE.axmj) THEN
50709 DO 180 i=1,2
50710 vmixc(ix,i)=dcmplx(vmix(ix,i),vmixi(ix,i))
50711 umixc(ix,i)=dcmplx(umix(ix,i),umixi(ix,i))
50712 180 CONTINUE
50713 s12min=0d0
50714 s12max=(axmi-axmj)**2
50715 xxc(1)=0d0
50716 xxc(2)=xmj
50717 xxc(3)=0d0
50718 xxc(4)=xmi
50719 xxc(5)=pmas(pycomp(ksusy1+1),1)
50720 xxc(6)=pmas(pycomp(ksusy1+2),1)
50721 xxc(9)=1d6
50722 xxc(10)=0d0
50723 olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))
50724 orpp=dconjg(olpp)
50725 cxc(1)=dcmplx(0d0,0d0)
50726 cxc(3)=dcmplx(0d0,0d0)
50727 cxc(5)=dcmplx(0d0,0d0)
50728 cxc(7)=dcmplx(0d0,0d0)
50729 cxc(2)=umixc(ix,1)*olpp/sr2
50730 cxc(4)=-dconjg(vmixc(ix,1))*orpp/sr2
50731 cxc(6)=dcmplx(0d0,0d0)
50732 cxc(8)=dcmplx(0d0,0d0)
50733 IF(xxc(5).LT.axmi) THEN
50734 xxc(5)=1d6
50735 ELSEIF(xxc(6).LT.axmi) THEN
50736 xxc(6)=1d6
50737 ENDIF
50738 xxc(7)=xxc(6)
50739 xxc(8)=xxc(5)
50740 IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 190
50741 IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
50742 lknt=lknt+1
50743 xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
50744 & pygaus(pyxxz6,s12min,s12max,prec)
50745 idlam(lknt,1)=kfcchi(ix)
50746 idlam(lknt,2)=1
50747 idlam(lknt,3)=-2
50748 lknt=lknt+1
50749 xlam(lknt)=xlam(lknt-1)
50750 idlam(lknt,1)=-idlam(lknt-1,1)
50751 idlam(lknt,2)=-idlam(lknt-1,2)
50752 idlam(lknt,3)=-idlam(lknt-1,3)
50753 ENDIF
50754 IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
50755 lknt=lknt+1
50756 xlam(lknt)=xlam(lknt-1)
50757 idlam(lknt,1)=kfcchi(ix)
50758 idlam(lknt,2)=3
50759 idlam(lknt,3)=-4
50760 lknt=lknt+1
50761 xlam(lknt)=xlam(lknt-1)
50762 idlam(lknt,1)=-idlam(lknt-1,1)
50763 idlam(lknt,2)=-idlam(lknt-1,2)
50764 idlam(lknt,3)=-idlam(lknt-1,3)
50765 ENDIF
50766 190 CONTINUE
50767
50768 xmf=pmas(6,1)
50769 xmfp=pmas(5,1)
50770 IF(axmi.GE.axmj+xmf+xmfp) THEN
50771 IF(xmi.GT.min(pmas(pycomp(ksusy1+5),1)+xmfp,
50772 $ pmas(pycomp(ksusy2+6),1)+xmf)) GOTO 200
50773 pmolt2=pmas(pycomp(ksusy2+6),1)
50774 pmolb2=pmas(pycomp(ksusy2+5),1)
50775 pmolt1=pmas(pycomp(ksusy1+6),1)
50776 pmolb1=pmas(pycomp(ksusy1+5),1)
50777 IF(xmi.GT.pmolt2+xmf) pmas(pycomp(ksusy2+6),1)=100d0*axmi
50778 IF(xmi.GT.pmolt1+xmf) pmas(pycomp(ksusy1+6),1)=100d0*axmi
50779 IF(xmi.GT.pmolb2+xmfp) pmas(pycomp(ksusy2+5),1)=100d0*axmi
50780 IF(xmi.GT.pmolb1+xmfp) pmas(pycomp(ksusy1+5),1)=100d0*axmi
50781 CALL pytbbc(ix,100,xmi,gam)
50782 lknt=lknt+1
50783 xlam(lknt)=gam
50784 idlam(lknt,1)=kfcchi(ix)
50785 idlam(lknt,2)=5
50786 idlam(lknt,3)=-6
50787 lknt=lknt+1
50788 xlam(lknt)=xlam(lknt-1)
50789 idlam(lknt,1)=-idlam(lknt-1,1)
50790 idlam(lknt,2)=-idlam(lknt-1,2)
50791 idlam(lknt,3)=-idlam(lknt-1,3)
50792 pmas(pycomp(ksusy2+6),1)=pmolt2
50793 pmas(pycomp(ksusy2+5),1)=pmolb2
50794 pmas(pycomp(ksusy1+6),1)=pmolt1
50795 pmas(pycomp(ksusy1+5),1)=pmolb1
50796 ENDIF
50797 200 CONTINUE
50798 ENDIF
50799 210 CONTINUE
50800
50801C...R-parity violating (3-body) decays.
50802 CALL pyrvgl(kfin,xlam,idlam,lknt)
50803
50804 iknt=lknt
50805 xlam(0)=0d0
50806 DO 220 i=1,iknt
50807 IF(xlam(i).LT.0d0) xlam(i)=0d0
50808 xlam(0)=xlam(0)+xlam(i)
50809 220 CONTINUE
50810 IF(xlam(0).EQ.0d0) xlam(0)=1d-6
50811
50812 RETURN
50813 END
50814
50815
50816C*********************************************************************
50817
50818C...PYTBBN
50819C...Calculates the three-body decay of gluinos into
50820C...neutralinos and third generation fermions.
50821
50822 SUBROUTINE pytbbn(I,NN,E,XMGLU,GAM)
50823
50824C...Double precision and integer declarations.
50825 IMPLICIT DOUBLE PRECISION(a-h, o-z)
50826 IMPLICIT INTEGER(I-N)
50827 INTEGER PYK,PYCHGE,PYCOMP
50828C...Parameter statement to help give large particle numbers.
50829 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
50830 &kexcit=4000000,kdimen=5000000)
50831C...Commonblocks.
50832 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
50833 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
50834 common/pymssm/imss(0:99),rmss(0:99)
50835 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
50836 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
50837 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
50838
50839C...Local variables.
50840 EXTERNAL pysimp,pylamf
50841 DOUBLE PRECISION PYSIMP,PYLAMF
50842 INTEGER LIN,NN
50843 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50844 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50845 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50846 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50847 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50848 DOUBLE PRECISION XLN1,XLN2,B1,B2
50849 DOUBLE PRECISION E,XMGLU,GAM
50850 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50851 SAVE hrb,hlb,flb,frb
50852 DOUBLE PRECISION ALPHAW,ALPHAS
50853 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50854 SAVE hlt,hrt,flt,frt
50855 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50856 SAVE amn,an,zn
50857 DOUBLE PRECISION AMBOT,SINC,COSC
50858 DOUBLE PRECISION AMTOP,SINA,COSA
50859 DOUBLE PRECISION SINW,COSW,TANW
50860 DOUBLE PRECISION ROT1(4,4)
50861 LOGICAL IFIRST
50862 SAVE ifirst
50863 DATA ifirst/.true./
50864
50865 tanb=rmss(5)
50866 sinb=tanb/sqrt(1d0+tanb**2)
50867 cosb=sinb/tanb
50868 xw=paru(102)
50869 sinw=sqrt(xw)
50870 cosw=sqrt(1d0-xw)
50871 tanw=sinw/cosw
50872 amw=pmas(24,1)
50873 cosc=sfmix(5,1)
50874 sinc=sfmix(5,3)
50875 cosa=sfmix(6,1)
50876 sina=sfmix(6,3)
50877 ambot=pymrun(5,xmglu**2)
50878 amtop=pymrun(6,xmglu**2)
50879 w2=sqrt(2d0)
50880 fakt1=ambot/w2/amw/cosb
50881 fakt2=amtop/w2/amw/sinb
50882 IF(ifirst) THEN
50883 DO 110 ii=1,4
50884 amn(ii)=smz(ii)
50885 DO 100 j=1,4
50886 rot1(ii,j)=0d0
50887 an(ii,j)=0d0
50888 100 CONTINUE
50889 110 CONTINUE
50890 rot1(1,1)=cosw
50891 rot1(1,2)=-sinw
50892 rot1(2,1)=-rot1(1,2)
50893 rot1(2,2)=rot1(1,1)
50894 rot1(3,3)=cosb
50895 rot1(3,4)=sinb
50896 rot1(4,3)=-rot1(3,4)
50897 rot1(4,4)=rot1(3,3)
50898 DO 140 ii=1,4
50899 DO 130 j=1,4
50900 DO 120 jj=1,4
50901 an(ii,j)=an(ii,j)+zmix(ii,jj)*rot1(jj,j)
50902 120 CONTINUE
50903 130 CONTINUE
50904 140 CONTINUE
50905 DO 150 j=1,4
50906 zn(1)=-fakt2*(-sinb*an(j,3)+cosb*an(j,4))
50907 zn(2)=-2d0*w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
50908 zn(3)=-2*w2/3d0*sinw*an(j,1)-w2*(0.5d0-2d0/3d0*
50909 & xw)*an(j,2)/cosw
50910 hrt(j)=zn(1)*cosa-zn(3)*sina
50911 hlt(j)=zn(1)*cosa+zn(2)*sina
50912 flt(j)=zn(3)*cosa+zn(1)*sina
50913 frt(j)=zn(2)*cosa-zn(1)*sina
50914C FLU(J)=ZN(3)
50915C FRU(J)=ZN(2)
50916 zn(1)=-fakt1*(cosb*an(j,3)+sinb*an(j,4))
50917 zn(2)=w2/3d0*sinw*(tanw*an(j,2)-an(j,1))
50918 zn(3)=w2/3d0*sinw*an(j,1)+w2*(0.5d0-xw/3d0)*an(j,2)/cosw
50919 hrb(j)=zn(1)*cosc-zn(3)*sinc
50920 hlb(j)=zn(1)*cosc+zn(2)*sinc
50921 flb(j)=zn(3)*cosc+zn(1)*sinc
50922 frb(j)=zn(2)*cosc-zn(1)*sinc
50923C FLD(J)=ZN(3)
50924C FRD(J)=ZN(2)
50925 150 CONTINUE
50926C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50927C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50928C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50929C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50930 ifirst=.false.
50931 ENDIF
50932
50933 IF(nint(3d0*e).EQ.2) THEN
50934 hl=hlt(i)
50935 hr=hrt(i)
50936 fl=flt(i)
50937 fr=frt(i)
50938 cosd=sfmix(6,1)
50939 sind=sfmix(6,3)
50940 xms2(1)=pmas(pycomp(ksusy1+6),1)**2
50941 xms2(2)=pmas(pycomp(ksusy2+6),1)**2
50942 xm=pmas(6,1)
50943 ELSE
50944 hl=hlb(i)
50945 hr=hrb(i)
50946 fl=flb(i)
50947 fr=frb(i)
50948 cosd=sfmix(5,1)
50949 sind=sfmix(5,3)
50950 xms2(1)=pmas(pycomp(ksusy1+5),1)**2
50951 xms2(2)=pmas(pycomp(ksusy2+5),1)**2
50952 xm=pmas(5,1)
50953 ENDIF
50954 cosd2=cosd*cosd
50955 sind2=sind*sind
50956 cos2d=cosd2-sind2
50957 sin2d=sind*cosd*2d0
50958 hl2=hl*hl
50959 hr2=hr*hr
50960 fl2=fl*fl
50961 fr2=fr*fr
50962 ff=fl*fr
50963 hh=hl*hr
50964 hfl=hl*fl
50965 hfr=hr*fr
50966 hrfl=hr*fl
50967 hlfr=hl*fr
50968 xm2=xm*xm
50969 xmg=xmglu
50970 xmg2=xmg*xmg
50971 alphaw=pyalem(xmg2)
50972 alphas=pyalps(xmg2)
50973 xmr=amn(i)
50974 xmr2=xmr*xmr
50975 xmq4=xmg*xm2*xmr
50976 xm24=(xmg2+xm2)*(xm2+xmr2)
50977 smin=4d0*xm2
50978 smax=(xmg-abs(xmr))**2
50979 xmqa=xmg2+2d0*xm2+xmr2
50980 DO 170 lin=1,nn-1
50981 sbar=smin+dble(lin)*(smax-smin)/dble(nn)
50982 grs=sbar-xmqa
50983 w=pylamf(xmg2,xmr2,sbar)*(0.25d0-xm2/sbar)
50984 w=dsqrt(w)
50985 xln1=log(abs((grs/2d0+xms2(1)-w)/(grs/2d0+xms2(1)+w)))
50986 xln2=log(abs((grs/2d0+xms2(2)-w)/(grs/2d0+xms2(2)+w)))
50987 b1=1d0/(grs/2d0+xms2(1)-w)-1d0/(grs/2d0+xms2(1)+w)
50988 b2=1d0/(grs/2d0+xms2(2)-w)-1d0/(grs/2d0+xms2(2)+w)
50989 g(0)=-2d0*(hl2+fl2+hr2+fr2+(hfr-hfl)*sin2d
50990 & +2d0*(ff*sind2-hh*cosd2))*w
50991 g(1)=((hl2+fl2)*(xmqa-2d0*xms2(1)-2d0*xm*xmg*sin2d)
50992 & +4d0*hfl*xm*xmr)*xln1
50993 & +((hl2+fl2)*((xmqa-xms2(1))*xms2(1)-xm24
50994 & +2d0*xm*xmg*(xm2+xmr2-xms2(1))*sin2d)
50995 & -4d0*hfl*xmr*xm*(xmg2+xm2-xms2(1))
50996 & +8d0*hfl*xmq4*sin2d)*b1
50997 g(2)=((hr2+fr2)*(xmqa-2d0*xms2(2)+2d0*xm*xmg*sin2d)
50998 & +4d0*hfr*xmr*xm)*xln2
50999 & +((hr2+fr2)*((xmqa-xms2(2))*xms2(2)-xm24
51000 & +2d0*xmg*xm*sin2d*(xms2(2)-xm2-xmr2))
51001 & +4d0*hfr*xm*xmr*(xms2(2)-xmg2-xm2)
51002 & -8d0*hfr*xmq4*sin2d)*b2
51003 g(3)=(2d0*hfl*sin2d*(xms2(1)*(grs+xms2(1))+xm2*(sbar-xmg2-xmr2)
51004 & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hl2*sind2+fl2*cosd2)*sbar
51005 & -2d0*xmg*xm*hfl*(sbar+xmr2-xmg2)
51006 & +xmr*xm*(hl2+fl2)*sin2d*(sbar+xmg2-xmr2)
51007 & -4d0*xmq4*(hl2-fl2)*cos2d)/(grs+2d0*xms2(1))*xln1
51008 g(4)=4d0*cos2d*xm*xmg/(xms2(1)-xms2(2))*
51009 & (((hlfr+hrfl)*(xm2+xmr2)+2d0*xm*xmr*(hh+ff))*(xln1-xln2)
51010 & +(hlfr+hrfl)*(xms2(2)*xln2-xms2(1)*xln1))
51011 g(5)=(2d0*(hh*cosd2-ff*sind2)
51012 & *((xms2(2)*(xms2(2)+grs)+xm2*xm2+xmg2*xmr2)*xln2
51013 & +(xms2(1)*(xms2(1)+grs)+xm2*xm2+xmg2*xmr2)*xln1)
51014 & +xm*((hh-ff)*sin2d*xmg-(hrfl-hlfr)*xmr)
51015 & *((grs+xms2(1)*2d0)*xln1-(grs+xms2(2)*2d0)*xln2)
51016 & +((hrfl-hlfr)*xmr*(sin2d*xmg*(sbar-4d0*xm2)
51017 & +cos2d*xm*(sbar+xmg2-xmr2))
51018 & +2d0*(ff*cosd2-hh*sind2)*xm2*(sbar-xmg2-xmr2))
51019 & *(xln1+xln2))/(grs+xms2(1)+xms2(2))
51020 g(6)=(-2d0*hfr*sin2d*(xms2(2)*(grs+xms2(2))+xm2*(sbar-xmg2-xmr2)
51021 & +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hr2*sind2+fr2*cosd2)*sbar
51022 & -2d0*xmg*xm*hfr*(sbar+xmr2-xmg2)
51023 & -xmr*xm*(hr2+fr2)*sin2d*(sbar+xmg2-xmr2)
51024 & -4d0*xmq4*(hr2-fr2)*cos2d)/(grs+2d0*xms2(2))*xln2
51025 summe(lin)=0d0
51026 DO 160 j=0,6
51027 summe(lin)=summe(lin)+g(j)
51028 160 CONTINUE
51029 170 CONTINUE
51030 summe(0)=0d0
51031 summe(nn)=0d0
51032 gam = alphaw * alphas * pysimp(summe,smin,smax,nn)
51033 &/ (16d0 * paru(1) * paru(102) * xmglu**3)
51034
51035 RETURN
51036 END
51037
51038C*********************************************************************
51039
51040C...PYTBBC
51041C...Calculates the three-body decay of gluinos into
51042C...charginos and third generation fermions.
51043
51044 SUBROUTINE pytbbc(I,NN,XMGLU,GAM)
51045
51046C...Double precision and integer declarations.
51047 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51048 IMPLICIT INTEGER(I-N)
51049 INTEGER PYK,PYCHGE,PYCOMP
51050C...Parameter statement to help give large particle numbers.
51051 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
51052 &kexcit=4000000,kdimen=5000000)
51053C...Commonblocks.
51054 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51055 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
51056 common/pymssm/imss(0:99),rmss(0:99)
51057 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
51058 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
51059 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/
51060
51061C...Local variables.
51062 EXTERNAL pysimp,pylamf
51063 DOUBLE PRECISION PYSIMP,PYLAMF
51064 INTEGER I,NN,LIN
51065 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51066 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51067 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51068 DOUBLE PRECISION SUMME(0:100),A(4,8)
51069 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51070 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51071 DOUBLE PRECISION XMGLU,GAM
51072 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51073 &ddd(2),eee(2),fff(2)
51074 SAVE xx1,xx2,aaa,bbb,ccc,ddd,eee,fff
51075 DOUBLE PRECISION ALPHAW,ALPHAS
51076 DOUBLE PRECISION AMC(2)
51077 SAVE AMC
51078 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51079 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51080 SAVE amsb,amst
51081 LOGICAL IFIRST
51082 SAVE ifirst
51083 DATA ifirst/.true./
51084
51085 tanb=rmss(5)
51086 sinb=tanb/sqrt(1d0+tanb**2)
51087 cosb=sinb/tanb
51088 xw=paru(102)
51089 amw=pmas(24,1)
51090 cosc=sfmix(5,1)
51091 sinc=sfmix(5,3)
51092 cosa=sfmix(6,1)
51093 sina=sfmix(6,3)
51094 ambot=pymrun(5,xmglu**2)
51095 amtop=pymrun(6,xmglu**2)
51096 w2=sqrt(2d0)
51097 amw=pmas(24,1)
51098 fakt1=ambot/w2/amw/cosb
51099 fakt2=amtop/w2/amw/sinb
51100 IF(ifirst) THEN
51101 amc(1)=smw(1)
51102 amc(2)=smw(2)
51103 DO 100 jj=1,2
51104 ccc(jj)=fakt1*umix(jj,2)*sinc-umix(jj,1)*cosc
51105 eee(jj)=fakt2*vmix(jj,2)*cosc
51106 ddd(jj)=fakt1*umix(jj,2)*cosc+umix(jj,1)*sinc
51107 fff(jj)=fakt2*vmix(jj,2)*sinc
51108 xx1(jj)=fakt2*vmix(jj,2)*sina-vmix(jj,1)*cosa
51109 aaa(jj)=fakt1*umix(jj,2)*cosa
51110 xx2(jj)=fakt2*vmix(jj,2)*cosa+vmix(jj,1)*sina
51111 bbb(jj)=fakt1*umix(jj,2)*sina
51112 100 CONTINUE
51113 amst(1)=pmas(pycomp(ksusy1+6),1)
51114 amst(2)=pmas(pycomp(ksusy2+6),1)
51115 amsb(1)=pmas(pycomp(ksusy1+5),1)
51116 amsb(2)=pmas(pycomp(ksusy2+5),1)
51117 ifirst=.false.
51118 ENDIF
51119
51120 ulr(1)=xx1(i)*xx1(i)+aaa(i)*aaa(i)
51121 ulr(2)=xx2(i)*xx2(i)+bbb(i)*bbb(i)
51122 vlr(1)=ccc(i)*ccc(i)+eee(i)*eee(i)
51123 vlr(2)=ddd(i)*ddd(i)+fff(i)*fff(i)
51124
51125 cos2a=cosa**2-sina**2
51126 sin2a=sina*cosa*2d0
51127 cos2c=cosc**2-sinc**2
51128 sin2c=sinc*cosc*2d0
51129
51130 xmg=xmglu
51131 xmt=pmas(6,1)
51132 xmb=pmas(5,1)
51133 xmr=amc(i)
51134 xmg2=xmg*xmg
51135 alphaw=pyalem(xmg2)
51136 alphas=pyalps(xmg2)
51137 xmt2=xmt*xmt
51138 xmb2=xmb*xmb
51139 xmr2=xmr*xmr
51140 xmq2=xmg2+xmt2+xmb2+xmr2
51141 xmq4=xmg*xmt*xmb*xmr
51142 xmq3=xmg2*xmr2+xmt2*xmb2
51143 xmgbtr=(xmg2+xmb2)*(xmt2+xmr2)
51144 xmgtbr=(xmg2+xmt2)*(xmb2+xmr2)
51145
51146 xmst(1)=amst(1)*amst(1)
51147 xmst(2)=amst(1)*amst(1)
51148 xmst(3)=amst(2)*amst(2)
51149 xmst(4)=amst(2)*amst(2)
51150 xmsb(1)=amsb(1)*amsb(1)
51151 xmsb(2)=amsb(2)*amsb(2)
51152 xmsb(3)=amsb(1)*amsb(1)
51153 xmsb(4)=amsb(2)*amsb(2)
51154
51155 a(1,1)=-cosa*sinc*ccc(i)*aaa(i)-sina*cosc*eee(i)*xx1(i)
51156 a(1,2)=xmg*xmb*(cosa*cosc*ccc(i)*aaa(i)+sina*sinc*eee(i)*xx1(i))
51157 a(1,3)=-xmg*xmr*(cosa*cosc*ccc(i)*xx1(i)+sina*sinc*eee(i)*aaa(i))
51158 a(1,4)=xmb*xmr*(cosa*sinc*ccc(i)*xx1(i)+sina*cosc*eee(i)*aaa(i))
51159 a(1,5)=xmg*xmt*(cosa*cosc*eee(i)*xx1(i)+sina*sinc*ccc(i)*aaa(i))
51160 a(1,6)=-xmt*xmb*(cosa*sinc*eee(i)*xx1(i)+sina*cosc*ccc(i)*aaa(i))
51161 a(1,7)=xmt*xmr*(cosa*sinc*eee(i)*aaa(i)+sina*cosc*ccc(i)*xx1(i))
51162 a(1,8)=-xmq4*(cosa*cosc*eee(i)*aaa(i)+sina*sinc*ccc(i)*xx1(i))
51163
51164 a(2,1)=-cosa*cosc*ddd(i)*aaa(i)-sina*sinc*fff(i)*xx1(i)
51165 a(2,2)=-xmg*xmb*(cosa*sinc*ddd(i)*aaa(i)+sina*cosc*fff(i)*xx1(i))
51166 a(2,3)=xmg*xmr*(cosa*sinc*ddd(i)*xx1(i)+sina*cosc*fff(i)*aaa(i))
51167 a(2,4)=xmb*xmr*(cosa*cosc*ddd(i)*xx1(i)+sina*sinc*fff(i)*aaa(i))
51168 a(2,5)=xmg*xmt*(cosa*sinc*fff(i)*xx1(i)+sina*cosc*ddd(i)*aaa(i))
51169 a(2,6)=xmt*xmb*(cosa*cosc*fff(i)*xx1(i)+sina*sinc*ddd(i)*aaa(i))
51170 a(2,7)=-xmt*xmr*(cosa*cosc*fff(i)*aaa(i)+sina*sinc*ddd(i)*xx1(i))
51171 a(2,8)=-xmq4*(cosa*sinc*fff(i)*aaa(i)+sina*cosc*ddd(i)*xx1(i))
51172
51173 a(3,1)=-cosa*cosc*eee(i)*xx2(i)-sina*sinc*ccc(i)*bbb(i)
51174 a(3,2)=xmg*xmb*(cosa*sinc*eee(i)*xx2(i)+sina*cosc*ccc(i)*bbb(i))
51175 a(3,3)=xmg*xmr*(cosa*sinc*eee(i)*bbb(i)+sina*cosc*ccc(i)*xx2(i))
51176 a(3,4)=-xmb*xmr*(cosa*cosc*eee(i)*bbb(i)+sina*sinc*ccc(i)*xx2(i))
51177 a(3,5)=-xmg*xmt*(cosa*sinc*ccc(i)*bbb(i)+sina*cosc*eee(i)*xx2(i))
51178 a(3,6)=xmt*xmb*(cosa*cosc*ccc(i)*bbb(i)+sina*sinc*eee(i)*xx2(i))
51179 a(3,7)=xmt*xmr*(cosa*cosc*ccc(i)*xx2(i)+sina*sinc*eee(i)*bbb(i))
51180 a(3,8)=-xmq4*(cosa*sinc*ccc(i)*xx2(i)+sina*cosc*eee(i)*bbb(i))
51181
51182 a(4,1)=-cosa*sinc*fff(i)*xx2(i)-sina*cosc*ddd(i)*bbb(i)
51183 a(4,2)=-xmg*xmb*(cosa*cosc*fff(i)*xx2(i)+sina*sinc*ddd(i)*bbb(i))
51184 a(4,3)=-xmg*xmr*(cosa*cosc*fff(i)*bbb(i)+sina*sinc*ddd(i)*xx2(i))
51185 a(4,4)=-xmb*xmr*(cosa*sinc*fff(i)*bbb(i)+sina*cosc*ddd(i)*xx2(i))
51186 a(4,5)=-xmg*xmt*(cosa*cosc*ddd(i)*bbb(i)+sina*sinc*fff(i)*xx2(i))
51187 a(4,6)=-xmt*xmb*(cosa*sinc*ddd(i)*bbb(i)+sina*cosc*fff(i)*xx2(i))
51188 a(4,7)=-xmt*xmr*(cosa*sinc*ddd(i)*xx2(i)+sina*cosc*fff(i)*bbb(i))
51189 a(4,8)=-xmq4*(cosa*cosc*ddd(i)*xx2(i)+sina*sinc*fff(i)*bbb(i))
51190
51191 smax=(xmg-abs(xmr))**2
51192 smin=(xmb+xmt)**2+0.1d0
51193
51194 DO 120 lin=0,nn-1
51195 sbar=smin+dble(lin)*(smax-smin)/dble(nn)
51196 am=(xmg2-xmr2)*(xmt2-xmb2)/2d0/sbar
51197 grs=sbar-xmq2
51198 w=pylamf(sbar,xmb2,xmt2)*pylamf(sbar,xmg2,xmr2)
51199 w=dsqrt(w)/2d0/sbar
51200 ant1=log(abs((grs/2d0+am+xmst(1)-w)/(grs/2d0+am+xmst(1)+w)))
51201 ant2=log(abs((grs/2d0+am+xmst(3)-w)/(grs/2d0+am+xmst(3)+w)))
51202 anb1=log(abs((grs/2d0-am+xmsb(1)-w)/(grs/2d0-am+xmsb(1)+w)))
51203 anb2=log(abs((grs/2d0-am+xmsb(2)-w)/(grs/2d0-am+xmsb(2)+w)))
51204 summe(lin)=-ulr(1)*w+(ulr(1)*(xmq2/2d0-xmst(1)-xmg*xmt*sin2a)
51205 & +2d0*xx1(i)*aaa(i)*xmr*xmb)*ant1
51206 & +(ulr(1)/2d0*(xmst(1)*(xmq2-xmst(1))-xmgtbr
51207 & -2d0*xmg*xmt*sin2a*(xmst(1)-xmb2-xmr2))
51208 & +2d0*xx1(i)*aaa(i)*xmr*xmb*(xmst(1)-xmg2-xmt2)
51209 & +4d0*sin2a*xx1(i)*aaa(i)*xmq4)
51210 & *(1d0/(grs/2d0+am+xmst(1)-w)-1d0/(grs/2d0+am+xmst(1)+w))
51211 summe(lin)=summe(lin)-ulr(2)*w
51212 & +(ulr(2)*(xmq2/2d0-xmst(3)+xmg*xmt*sin2a)
51213 & -2d0*xx2(i)*bbb(i)*xmr*xmb)*ant2
51214 & +(ulr(2)/2d0*(xmst(3)*(xmq2-xmst(3))-xmgtbr
51215 & +2d0*xmg*xmt*sin2a*(xmst(3)-xmb2-xmr2))
51216 & -2d0*xx2(i)*bbb(i)*xmr*xmb*(xmst(3)-xmg2-xmt2)
51217 & +4d0*sin2a*xx2(i)*bbb(i)*xmq4)
51218 & *(1d0/(grs/2d0+am+xmst(3)-w)-1d0/(grs/2d0+am+xmst(3)+w))
51219 summe(lin)=summe(lin)-vlr(1)*w
51220 & +(vlr(1)*(xmq2/2d0-xmsb(1)-xmg*xmb*sin2c)
51221 & +2d0*ccc(i)*eee(i)*xmr*xmt)*anb1
51222 & +(vlr(1)/2d0*(xmsb(1)*(xmq2-xmsb(1))-xmgbtr
51223 & -2d0*xmg*xmb*sin2c*(xmsb(1)-xmt2-xmr2))
51224 & +2d0*ccc(i)*eee(i)*xmr*xmt*(xmsb(1)-xmg2-xmb2)
51225 & +4d0*sin2c*ccc(i)*eee(i)*xmq4)
51226 & *(1d0/(grs/2d0-am+xmsb(1)-w)-1d0/(grs/2d0-am+xmsb(1)+w))
51227 summe(lin)=summe(lin)-vlr(2)*w
51228 & +(vlr(2)*(xmq2/2d0-xmsb(2)+xmg*xmb*sin2c)
51229 & -2d0*ddd(i)*fff(i)*xmr*xmt)*anb2
51230 & +(vlr(2)/2d0*(xmsb(2)*(xmq2-xmsb(2))-xmgbtr
51231 & +2d0*xmg*xmb*sin2c*(xmsb(2)-xmt2-xmr2))
51232 & -2d0*ddd(i)*fff(i)*xmr*xmt*(xmsb(2)-xmg2-xmb2)
51233 & +4d0*sin2c*ddd(i)*fff(i)*xmq4)
51234 & *(1d0/(grs/2d0-am+xmsb(2)-w)-1d0/(grs/2d0-am+xmsb(2)+w))
51235 summe(lin)=summe(lin)+2d0*xmg*xmt*cos2a/(xmst(3)-xmst(1))
51236 & *((aaa(i)*bbb(i)-xx1(i)*xx2(i))
51237 & *((xmst(3)-xmb2-xmr2)*ant2-(xmst(1)-xmb2-xmr2)*ant1)
51238 & +2d0*(aaa(i)*xx2(i)-xx1(i)*bbb(i))*xmb*xmr*(ant2-ant1))
51239 summe(lin)=summe(lin)+2d0*xmg*xmb*cos2c/(xmsb(2)-xmsb(1))
51240 & *((eee(i)*fff(i)-ccc(i)*ddd(i))
51241 & *((xmsb(2)-xmt2-xmr2)*anb2-(xmsb(1)-xmt2-xmr2)*anb1)
51242 & +2d0*(eee(i)*ddd(i)-ccc(i)*fff(i))*xmt*xmr*(anb2-anb1))
51243 DO 110 j=1,4
51244 summe(lin)=summe(lin)-2d0*a(j,1)*w
51245 & +((-a(j,1)*(xmsb(j)*(grs+xmsb(j))+xmq3)
51246 & +a(j,2)*(xmsb(j)-xmt2-xmr2)+a(j,3)*(sbar-xmb2-xmt2)
51247 & +a(j,4)*(xmsb(j)+sbar-xmb2-xmr2)
51248 & -a(j,5)*(xmsb(j)+sbar-xmg2-xmt2)+a(j,6)*(xmg2+xmr2-sbar)
51249 & -a(j,7)*(xmsb(j)-xmg2-xmb2)+2d0*a(j,8))
51250 & *log(abs((grs/2d0+xmsb(j)-am-w)/(grs/2d0+xmsb(j)-am+w)))
51251 & -(a(j,1)*(xmst(j)*(grs+xmst(j))+xmq3)
51252 & +a(j,2)*(xmst(j)+sbar-xmg2-xmb2)-a(j,3)*(sbar-xmb2-xmt2)
51253 & +a(j,4)*(xmst(j)-xmg2-xmt2)-a(j,5)*(xmst(j)-xmr2-xmb2)
51254 & -a(j,6)*(xmg2+xmr2-sbar)
51255 & -a(j,7)*(xmst(j)+sbar-xmt2-xmr2)-2d0*a(j,8))
51256 & *log(abs((grs/2d0+xmst(j)+am-w)/(grs/2d0+xmst(j)+am+w))))
51257 & /(grs+xmsb(j)+xmst(j))
51258 110 CONTINUE
51259 120 CONTINUE
51260 summe(nn)=0d0
51261 gam= alphaw * alphas * pysimp(summe,smin,smax,nn)
51262 &/ (16d0 * paru(1) * paru(102) * xmglu**3)
51263
51264 RETURN
51265 END
51266
51267C*********************************************************************
51268
51269C...PYNJDC
51270C...Calculates decay widths for the neutralinos (admixtures of
51271C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51272
51273C...Input: KCIN = KF code for particle
51274C...Output: XLAM = widths
51275C... IDLAM = KF codes for decay particles
51276C... IKNT = number of decay channels defined
51277C...AUTHOR: STEPHEN MRENNA
51278C...Last change:
51279C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51280C...when CHIGAMMA .NE. 0
51281C...10 FEB 96: Calculate this decay for small tan(beta)
51282
51283 SUBROUTINE pynjdc(KFIN,XLAM,IDLAM,IKNT)
51284
51285C...Double precision and integer declarations.
51286 IMPLICIT DOUBLE PRECISION(a-h, o-z)
51287 IMPLICIT INTEGER(I-N)
51288 INTEGER PYK,PYCHGE,PYCOMP
51289C...Parameter statement to help give large particle numbers.
51290 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
51291 &kexcit=4000000,kdimen=5000000)
51292C...Commonblocks.
51293 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
51294 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
51295 common/pymssm/imss(0:99),rmss(0:99)
51296c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51297c &SFMIX(16,4)
51298 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
51299 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
51300C COMMON/PYINTS/XXM(20)
51301 COMPLEX*16 CXC
51302 common/pyintc/xxc(10),cxc(8)
51303 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyintc/
51304
51305C...Local variables.
51306 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51307 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51308 INTEGER KFIN
51309 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51310 &xmz,xmz2,axmj,axmi
51311 DOUBLE PRECISION S12MIN,S12MAX
51312 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51313 DOUBLE PRECISION PYLAMF,XL
51314 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51315 DOUBLE PRECISION PYX2XH,PYX2XG
51316 DOUBLE PRECISION XLAM(0:400)
51317 INTEGER IDLAM(400,3)
51318 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51319 INTEGER ITH(3),KF1,KF2
51320 INTEGER ITHC
51321 DOUBLE PRECISION DH(3),EH(3)
51322 DOUBLE PRECISION SR2
51323 DOUBLE PRECISION CBETA,SBETA
51324 DOUBLE PRECISION GAMCON,XMT1,XMT2
51325 DOUBLE PRECISION PYALEM,PI,PYALPS
51326 DOUBLE PRECISION RAT1,RAT2
51327 DOUBLE PRECISION T3T,FCOL
51328 DOUBLE PRECISION ALFA,BETA,TANB
51329 DOUBLE PRECISION PYXXGA
51330 EXTERNAL pygaus,pyxxz6
51331 DOUBLE PRECISION PYGAUS,PYXXZ6
51332 DOUBLE PRECISION PREC
51333 INTEGER KFNCHI(4),KFCCHI(2)
51334 DATA ith/25,35,36/
51335 DATA ithc/37/
51336 DATA prec/1d-2/
51337 DATA pi/3.141592654d0/
51338 DATA sr2/1.4142136d0/
51339 DATA kfnchi/1000022,1000023,1000025,1000035/
51340 DATA kfcchi/1000024,1000037/
51341
51342C...COUNT THE NUMBER OF DECAY MODES
51343 lknt=0
51344
51345 xmw=pmas(24,1)
51346 xmw2=xmw**2
51347 xmz=pmas(23,1)
51348 xmz2=xmz**2
51349 xw=1d0-xmw2/xmz2
51350 xw1=1d0-xw
51351 tanw = sqrt(xw/xw1)
51352
51353C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51354 ix=1
51355 IF(kfin.EQ.kfnchi(2)) ix=2
51356 IF(kfin.EQ.kfnchi(3)) ix=3
51357 IF(kfin.EQ.kfnchi(4)) ix=4
51358
51359 xmi=smz(ix)
51360 xmi2=xmi**2
51361 axmi=abs(xmi)
51362 aem=pyalem(xmi2)
51363 as =pyalps(xmi2)
51364 c1=aem/xw
51365 xmi3=abs(xmi**3)
51366
51367 tanb=rmss(5)
51368 beta=atan(tanb)
51369 alfa=rmss(18)
51370 cbeta=cos(beta)
51371 sbeta=tanb*cbeta
51372 calfa=cos(alfa)
51373 salfa=sin(alfa)
51374
51375 DO 110 i=1,4
51376 DO 100 j=1,4
51377 zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
51378 100 CONTINUE
51379 110 CONTINUE
51380 DO 130 i=1,2
51381 DO 120 j=1,2
51382 vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
51383 umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
51384 120 CONTINUE
51385 130 CONTINUE
51386
51387C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51388 IF(ix.EQ.1.AND.imss(11).EQ.0) GOTO 300
51389
51390C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51391 IF(ix.EQ.2 .AND. imss(10).NE.0 ) THEN
51392 xmj=smz(1)
51393 axmj=abs(xmj)
51394 lknt=lknt+1
51395 gamcon=aem**3/8d0/pi/xmw2/xw
51396 xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
51397 xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
51398 xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
51399 idlam(lknt,1)=ksusy1+22
51400 idlam(lknt,2)=22
51401 idlam(lknt,3)=0
51402 WRITE(mstu(11),*) 'FORCED N2 -> N1 + GAMMA ',xlam(lknt)
51403 GOTO 340
51404 ENDIF
51405
51406C...GRAVITINO DECAY MODES
51407
51408 IF(imss(11).EQ.1) THEN
51409 xmp=rmss(29)
51410 idg=39+ksusy1
51411 xmgr=pmas(pycomp(idg),1)
51412 sinw=sqrt(xw)
51413 cosw=sqrt(1d0-xw)
51414 xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
51415 IF(axmi.GT.xmgr+pmas(22,1)) THEN
51416 lknt=lknt+1
51417 idlam(lknt,1)=idg
51418 idlam(lknt,2)=22
51419 idlam(lknt,3)=0
51420 xlam(lknt)=xfac*abs(zmixc(ix,1)*cosw+zmixc(ix,2)*sinw)**2
51421 ENDIF
51422 IF(axmi.GT.xmgr+xmz) THEN
51423 lknt=lknt+1
51424 idlam(lknt,1)=idg
51425 idlam(lknt,2)=23
51426 idlam(lknt,3)=0
51427 xlam(lknt)=xfac*(abs(zmixc(ix,1)*sinw-zmixc(ix,2)*cosw)**2 +
51428 $ .5d0*abs(zmixc(ix,3)*cbeta-zmixc(ix,4)*sbeta)**2)*
51429 & (1d0-xmz2/xmi2)**4
51430 ENDIF
51431 IF(axmi.GT.xmgr+pmas(25,1)) THEN
51432 lknt=lknt+1
51433 idlam(lknt,1)=idg
51434 idlam(lknt,2)=25
51435 idlam(lknt,3)=0
51436 xlam(lknt)=xfac*(abs(zmixc(ix,3)*salfa-zmixc(ix,4)*calfa)**2)*
51437 $ .5d0*(1d0-pmas(25,1)**2/xmi2)**4
51438 ENDIF
51439 IF(axmi.GT.xmgr+pmas(35,1)) THEN
51440 lknt=lknt+1
51441 idlam(lknt,1)=idg
51442 idlam(lknt,2)=35
51443 idlam(lknt,3)=0
51444 xlam(lknt)=xfac*(abs(zmixc(ix,3)*calfa+zmixc(ix,4)*salfa)**2)*
51445 $ .5d0*(1d0-pmas(35,1)**2/xmi2)**4
51446 ENDIF
51447 IF(axmi.GT.xmgr+pmas(36,1)) THEN
51448 lknt=lknt+1
51449 idlam(lknt,1)=idg
51450 idlam(lknt,2)=36
51451 idlam(lknt,3)=0
51452 xlam(lknt)=xfac*(abs(zmixc(ix,3)*sbeta+zmixc(ix,4)*cbeta)**2)*
51453 $ .5d0*(1d0-pmas(36,1)**2/xmi2)**4
51454 ENDIF
51455 IF(ix.EQ.1) GOTO 300
51456 ENDIF
51457
51458 DO 220 ij=1,ix-1
51459 xmj=smz(ij)
51460 axmj=abs(xmj)
51461 xmj2=xmj**2
51462
51463C...CHI0_I -> CHI0_J + GAMMA
51464 IF(axmi.GE.axmj.AND.sbeta/cbeta.LE.2d0) THEN
51465 rat1=abs(zmixc(ij,1))**2+abs(zmixc(ij,2))**2
51466 rat1=rat1/( 1d-6+abs(zmixc(ix,3))**2+abs(zmixc(ix,4))**2 )
51467 rat2=abs(zmixc(ix,1))**2+abs(zmixc(ix,2))**2
51468 rat2=rat2/( 1d-6+abs(zmixc(ij,3))**2+abs(zmixc(ij,4))**2 )
51469 IF((rat1.GT. 0.90d0 .AND. rat1.LT. 1.10d0) .OR.
51470 & (rat2.GT. 0.90d0 .AND. rat2.LT. 1.10d0)) THEN
51471 lknt=lknt+1
51472 idlam(lknt,1)=kfnchi(ij)
51473 idlam(lknt,2)=22
51474 idlam(lknt,3)=0
51475 gamcon=aem**3/8d0/pi/xmw2/xw
51476 xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2
51477 xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2
51478 xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)
51479 ENDIF
51480 ENDIF
51481
51482C...CHI0_I -> CHI0_J + Z0
51483 IF(axmi.GE.axmj+xmz) THEN
51484 lknt=lknt+1
51485 olpp=(zmixc(ix,3)*dconjg(zmixc(ij,3))-
51486 & zmixc(ix,4)*dconjg(zmixc(ij,4)))/2d0
51487 orpp=-dconjg(olpp)
51488 gx2=abs(olpp)**2+abs(orpp)**2
51489 glr=dble(olpp*dconjg(orpp))
51490 xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gx2,glr)
51491 idlam(lknt,1)=kfnchi(ij)
51492 idlam(lknt,2)=23
51493 idlam(lknt,3)=0
51494 ELSEIF(axmi.GE.axmj) THEN
51495 xxc(1)=0d0
51496 xxc(2)=xmj
51497 xxc(3)=0d0
51498 xxc(4)=xmi
51499 xxc(9)=xmz
51500 xxc(10)=pmas(23,2)
51501 olpp=(zmixc(ix,3)*dconjg(zmixc(ij,3))-
51502 & zmixc(ix,4)*dconjg(zmixc(ij,4)))/2d0
51503 orpp=dconjg(olpp)
51504C...CHARGED LEPTONS
51505 fid=11
51506 xxc(5)=pmas(pycomp(ksusy1+fid),1)
51507 xxc(6)=pmas(pycomp(ksusy2+fid),1)
51508 ei=kchg(fid,1)/3d0
51509 t3i=sign(1d0,ei+1d-6)/2d0
51510 glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
51511 & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
51512 grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
51513 cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
51514 cxc(2)=-glij
51515 cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
51516 cxc(4)=dconjg(glij)
51517 cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
51518 cxc(6)=grij
51519 cxc(7)=dcmplx((ei*xw)/xw1)*orpp
51520 cxc(8)=-dconjg(grij)
51521 s12min=0d0
51522 s12max=(axmi-axmj)**2
51523 IF( xxc(5).LT.axmi ) THEN
51524 xxc(5)=1d6
51525 ENDIF
51526 IF(xxc(6).LT.axmi ) THEN
51527 xxc(6)=1d6
51528 ENDIF
51529 xxc(7)=xxc(5)
51530 xxc(8)=xxc(6)
51531
51532 IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
51533 lknt=lknt+1
51534 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51535 & pygaus(pyxxz6,s12min,s12max,1d-3)
51536 idlam(lknt,1)=kfnchi(ij)
51537 idlam(lknt,2)=fid
51538 idlam(lknt,3)=-fid
51539 IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
51540 lknt=lknt+1
51541 xlam(lknt)=xlam(lknt-1)
51542 idlam(lknt,1)=kfnchi(ij)
51543 idlam(lknt,2)=13
51544 idlam(lknt,3)=-13
51545 ENDIF
51546 ENDIF
51547 140 CONTINUE
51548 IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
51549 xxc(5)=pmas(pycomp(ksusy1+15),1)
51550 xxc(6)=pmas(pycomp(ksusy2+15),1)
51551 ELSE
51552 xxc(6)=pmas(pycomp(ksusy1+15),1)
51553 xxc(5)=pmas(pycomp(ksusy2+15),1)
51554 ENDIF
51555 IF( xxc(5).LT.axmi ) THEN
51556 xxc(5)=1d6
51557 ENDIF
51558 IF(xxc(6).LT.axmi ) THEN
51559 xxc(6)=1d6
51560 ENDIF
51561 xxc(7)=xxc(5)
51562 xxc(8)=xxc(6)
51563
51564 IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
51565 lknt=lknt+1
51566 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51567 & pygaus(pyxxz6,s12min,s12max,1d-3)
51568 idlam(lknt,1)=kfnchi(ij)
51569 idlam(lknt,2)=15
51570 idlam(lknt,3)=-15
51571 ENDIF
51572
51573C...NEUTRINOS
51574 150 CONTINUE
51575 fid=12
51576 xxc(5)=pmas(pycomp(ksusy1+fid),1)
51577 xxc(6)=pmas(pycomp(ksusy2+fid),1)
51578 ei=kchg(fid,1)/3d0
51579 t3i=sign(1d0,ei+1d-6)/2d0
51580 glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
51581 & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
51582 grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
51583 cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
51584 cxc(2)=-glij
51585 cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
51586 cxc(4)=dconjg(glij)
51587 cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
51588 cxc(6)=grij
51589 cxc(7)=dcmplx((ei*xw)/xw1)*orpp
51590 cxc(8)=-dconjg(grij)
51591 s12min=0d0
51592 s12max=(axmi-axmj)**2
51593 IF( xxc(5).LT.axmi ) THEN
51594 xxc(5)=1d6
51595 ENDIF
51596 IF( xxc(6).LT.axmi ) THEN
51597 xxc(6)=1d6
51598 ENDIF
51599 xxc(7)=xxc(5)
51600 xxc(8)=xxc(6)
51601
51602 lknt=lknt+1
51603 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51604 & pygaus(pyxxz6,s12min,s12max,1d-3)
51605 idlam(lknt,1)=kfnchi(ij)
51606 idlam(lknt,2)=12
51607 idlam(lknt,3)=-12
51608 lknt=lknt+1
51609 xlam(lknt)=xlam(lknt-1)
51610 idlam(lknt,1)=kfnchi(ij)
51611 idlam(lknt,2)=14
51612 idlam(lknt,3)=-14
51613 160 CONTINUE
51614
51615 IF(pmas(pycomp(ksusy1+16),1).NE.pmas(pycomp(ksusy1+12),1))
51616 & THEN
51617 xxc(5)=pmas(pycomp(ksusy1+16),1)
51618 IF( xxc(5).LT.axmi ) THEN
51619 xxc(5)=1d6
51620 ENDIF
51621 xxc(7)=xxc(5)
51622 lknt=lknt+1
51623 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51624 & pygaus(pyxxz6,s12min,s12max,1d-3)
51625 ELSE
51626 lknt=lknt+1
51627 xlam(lknt)=xlam(lknt-1)
51628 ENDIF
51629 idlam(lknt,1)=kfnchi(ij)
51630 idlam(lknt,2)=16
51631 idlam(lknt,3)=-16
51632C...D-TYPE QUARKS
51633 170 CONTINUE
51634 fid=1
51635 xxc(5)=pmas(pycomp(ksusy1+fid),1)
51636 xxc(6)=pmas(pycomp(ksusy2+fid),1)
51637 ei=kchg(fid,1)/3d0
51638 t3i=sign(1d0,ei+1d-6)/2d0
51639 glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
51640 & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
51641 grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
51642 cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
51643 cxc(2)=-glij
51644 cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
51645 cxc(4)=dconjg(glij)
51646 cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
51647 cxc(6)=grij
51648 cxc(7)=dcmplx((ei*xw)/xw1)*orpp
51649 cxc(8)=-dconjg(grij)
51650 s12min=0d0
51651 s12max=(axmi-axmj)**2
51652 IF( xxc(5).LT.axmi ) THEN
51653 xxc(5)=1d6
51654 ENDIF
51655 IF( xxc(6).LT.axmi ) THEN
51656 xxc(6)=1d6
51657 ENDIF
51658 xxc(7)=xxc(5)
51659 xxc(8)=xxc(6)
51660
51661 IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
51662 lknt=lknt+1
51663 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51664 & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
51665 idlam(lknt,1)=kfnchi(ij)
51666 idlam(lknt,2)=1
51667 idlam(lknt,3)=-1
51668 IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
51669 lknt=lknt+1
51670 xlam(lknt)=xlam(lknt-1)
51671 idlam(lknt,1)=kfnchi(ij)
51672 idlam(lknt,2)=3
51673 idlam(lknt,3)=-3
51674 ENDIF
51675 ENDIF
51676 180 CONTINUE
51677 IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
51678 xxc(5)=pmas(pycomp(ksusy1+5),1)
51679 xxc(6)=pmas(pycomp(ksusy2+5),1)
51680 ELSE
51681 xxc(6)=pmas(pycomp(ksusy1+5),1)
51682 xxc(5)=pmas(pycomp(ksusy2+5),1)
51683 ENDIF
51684 IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) GOTO 190
51685 IF(xxc(5).LT.axmi) THEN
51686 xxc(5)=1d6
51687 ELSEIF(xxc(6).LT.axmi) THEN
51688 xxc(6)=1d6
51689 ENDIF
51690 xxc(7)=xxc(5)
51691 xxc(8)=xxc(6)
51692 IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
51693 lknt=lknt+1
51694 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51695 & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
51696 idlam(lknt,1)=kfnchi(ij)
51697 idlam(lknt,2)=5
51698 idlam(lknt,3)=-5
51699 ENDIF
51700
51701C...U-TYPE QUARKS
51702 190 CONTINUE
51703 fid=2
51704 xxc(5)=pmas(pycomp(ksusy1+fid),1)
51705 xxc(6)=pmas(pycomp(ksusy2+fid),1)
51706 ei=kchg(fid,1)/3d0
51707 t3i=sign(1d0,ei+1d-6)/2d0
51708 glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*
51709 & dconjg(t3i*zmixc(ij,2)-tanw*(t3i-ei)*zmixc(ij,1))
51710 grij=zmixc(ix,1)*dconjg(zmixc(ij,1))*(ei*tanw)**2
51711 cxc(1)=dcmplx((t3i-ei*xw)/xw1)*olpp
51712 cxc(2)=-glij
51713 cxc(3)=-dcmplx((t3i-ei*xw)/xw1)*orpp
51714 cxc(4)=dconjg(glij)
51715 cxc(5)=-dcmplx((ei*xw)/xw1)*olpp
51716 cxc(6)=grij
51717 cxc(7)=dcmplx((ei*xw)/xw1)*orpp
51718 cxc(8)=-dconjg(grij)
51719
51720 IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) GOTO 200
51721 IF(xxc(5).LT.axmi) THEN
51722 xxc(5)=1d6
51723 ELSEIF(xxc(6).LT.axmi) THEN
51724 xxc(6)=1d6
51725 ENDIF
51726 xxc(7)=xxc(5)
51727 xxc(8)=xxc(6)
51728
51729 IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
51730 lknt=lknt+1
51731 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51732 & pygaus(pyxxz6,s12min,s12max,1d-3)*3d0
51733 idlam(lknt,1)=kfnchi(ij)
51734 idlam(lknt,2)=2
51735 idlam(lknt,3)=-2
51736 IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
51737 lknt=lknt+1
51738 xlam(lknt)=xlam(lknt-1)
51739 idlam(lknt,1)=kfnchi(ij)
51740 idlam(lknt,2)=4
51741 idlam(lknt,3)=-4
51742 ENDIF
51743 ENDIF
51744 200 CONTINUE
51745 ENDIF
51746
51747C...CHI0_I -> CHI0_J + H0_K
51748 eh(1)=sin(alfa)
51749 eh(2)=cos(alfa)
51750 eh(3)=-sin(beta)
51751 dh(1)=cos(alfa)
51752 dh(2)=-sin(alfa)
51753 dh(3)=cos(beta)
51754 qij=zmixc(ix,3)*dconjg(zmixc(ij,2))+
51755 & dconjg(zmixc(ij,3))*zmixc(ix,2)-
51756 & tanw*(zmixc(ix,3)*dconjg(zmixc(ij,1))+
51757 & dconjg(zmixc(ij,3))*zmixc(ix,1))
51758 rij=dconjg(zmixc(ix,4))*zmixc(ij,2)+
51759 & zmixc(ij,4)*dconjg(zmixc(ix,2))-
51760 & tanw*(dconjg(zmixc(ix,4))*zmixc(ij,1)+
51761 & zmixc(ij,4)*dconjg(zmixc(ix,1)))
51762 DO 210 ih=1,3
51763 xmh=pmas(ith(ih),1)
51764 xmh2=xmh**2
51765 IF(axmi.GE.axmj+xmh) THEN
51766 lknt=lknt+1
51767 xl=pylamf(xmi2,xmj2,xmh2)
51768 f21k=0.5d0*(qij*eh(ih)+rij*dh(ih))
51769 f12k=f21k
51770C...SIGN OF MASSES I,J
51771 xmk=xmj
51772 IF(ih.EQ.3) xmk=-xmk
51773 gx2=abs(f21k)**2+abs(f12k)**2
51774 glr=dble(f21k*dconjg(f12k))
51775 xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,gx2,glr)
51776 idlam(lknt,1)=kfnchi(ij)
51777 idlam(lknt,2)=ith(ih)
51778 idlam(lknt,3)=0
51779 ENDIF
51780 210 CONTINUE
51781 220 CONTINUE
51782
51783C...CHI0_I -> CHI+_J + W-
51784 DO 260 ij=1,2
51785 xmj=smw(ij)
51786 axmj=abs(xmj)
51787 xmj2=xmj**2
51788 IF(axmi.GE.axmj+xmw) THEN
51789 lknt=lknt+1
51790 cxc(1)=(dconjg(zmixc(ix,2))*vmixc(ij,1)-
51791 & dconjg(zmixc(ix,4))*vmixc(ij,2)/sr2)
51792 cxc(3)=(zmixc(ix,2)*dconjg(umixc(ij,1))+
51793 & zmixc(ix,3)*dconjg(umixc(ij,2))/sr2)
51794 gx2=abs(cxc(1))**2+abs(cxc(3))**2
51795 glr=dble(cxc(1)*dconjg(cxc(3)))
51796 xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gx2,glr)
51797 idlam(lknt,1)=kfcchi(ij)
51798 idlam(lknt,2)=-24
51799 idlam(lknt,3)=0
51800 lknt=lknt+1
51801 xlam(lknt)=xlam(lknt-1)
51802 idlam(lknt,1)=-kfcchi(ij)
51803 idlam(lknt,2)=24
51804 idlam(lknt,3)=0
51805 ELSEIF(axmi.GE.axmj) THEN
51806 s12min=0d0
51807 s12max=(axmi-axmj)**2
51808 rt2i = 1d0/sqrt(2d0)
51809 cxc(1)=(dconjg(zmixc(ix,2))*vmixc(ij,1)-
51810 & dconjg(zmixc(ix,4))*vmixc(ij,2)*rt2i)*rt2i
51811 cxc(3)=(zmixc(ix,2)*dconjg(umixc(ij,1))+
51812 & zmixc(ix,3)*dconjg(umixc(ij,2))*rt2i)*rt2i
51813 cxc(5)=dcmplx(0d0,0d0)
51814 cxc(7)=dcmplx(0d0,0d0)
51815 ia=11
51816 ja=12
51817 ei=kchg(ia,1)/3d0
51818 t3i=sign(1d0,ei+1d-6)/2d0
51819 ej=kchg(ja,1)/3d0
51820 t3j=sign(1d0,ej+1d-6)/2d0
51821 cxc(2)=vmixc(ij,1)*dconjg(zmixc(ix,1)*(ej-t3j)*
51822 & tanw+zmixc(ix,2)*t3j)*rt2i
51823 cxc(4)=-dconjg(umixc(ij,1))*(
51824 & zmixc(ix,1)*(ei-t3i)*tanw+zmixc(ix,2)*t3i)*rt2i
51825 cxc(6)=dcmplx(0d0,0d0)
51826 cxc(8)=dcmplx(0d0,0d0)
51827 xxc(1)=0d0
51828 xxc(2)=xmj
51829 xxc(3)=0d0
51830 xxc(4)=xmi
51831 xxc(5)=pmas(pycomp(ksusy1+ja),1)
51832 xxc(6)=pmas(pycomp(ksusy1+ia),1)
51833 xxc(9)=pmas(24,1)
51834 xxc(10)=pmas(24,2)
51835 IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) GOTO 230
51836 IF(xxc(5).LT.axmi) THEN
51837 xxc(5)=1d6
51838 ELSEIF(xxc(6).LT.axmi) THEN
51839 xxc(6)=1d6
51840 ENDIF
51841 xxc(7)=xxc(6)
51842 xxc(8)=xxc(5)
51843 IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
51844 lknt=lknt+1
51845 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51846 & pygaus(pyxxz6,s12min,s12max,prec)
51847 idlam(lknt,1)=kfcchi(ij)
51848 idlam(lknt,2)=11
51849 idlam(lknt,3)=-12
51850 lknt=lknt+1
51851 xlam(lknt)=xlam(lknt-1)
51852 idlam(lknt,1)=-idlam(lknt-1,1)
51853 idlam(lknt,2)=-idlam(lknt-1,2)
51854 idlam(lknt,3)=-idlam(lknt-1,3)
51855 IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
51856 lknt=lknt+1
51857 xlam(lknt)=xlam(lknt-1)
51858 idlam(lknt,1)=kfcchi(ij)
51859 idlam(lknt,2)=13
51860 idlam(lknt,3)=-14
51861 lknt=lknt+1
51862 xlam(lknt)=xlam(lknt-1)
51863 idlam(lknt,1)=-idlam(lknt-1,1)
51864 idlam(lknt,2)=-idlam(lknt-1,2)
51865 idlam(lknt,3)=-idlam(lknt-1,3)
51866 ENDIF
51867 ENDIF
51868 230 CONTINUE
51869 IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
51870 xxc(5)=pmas(pycomp(ksusy1+15),1)
51871 xxc(6)=pmas(pycomp(ksusy1+16),1)
51872 ELSE
51873 xxc(5)=pmas(pycomp(ksusy2+15),1)
51874 xxc(6)=pmas(pycomp(ksusy1+16),1)
51875 ENDIF
51876 IF(xxc(5).LT.axmi) THEN
51877 xxc(5)=1d6
51878 ENDIF
51879 IF(xxc(6).LT.axmi) THEN
51880 xxc(6)=1d6
51881 ENDIF
51882 xxc(7)=xxc(6)
51883 xxc(8)=xxc(5)
51884 IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
51885 lknt=lknt+1
51886 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
51887 & pygaus(pyxxz6,s12min,s12max,prec)
51888 xlam(lknt)=xlam(lknt-1)
51889 idlam(lknt,1)=kfcchi(ij)
51890 idlam(lknt,2)=15
51891 idlam(lknt,3)=-16
51892 lknt=lknt+1
51893 xlam(lknt)=xlam(lknt-1)
51894 idlam(lknt,1)=-idlam(lknt-1,1)
51895 idlam(lknt,2)=-idlam(lknt-1,2)
51896 idlam(lknt,3)=-idlam(lknt-1,3)
51897 ENDIF
51898
51899C...NOW, DO THE QUARKS
51900 240 CONTINUE
51901 ia=1
51902 ja=2
51903 ei=kchg(ia,1)/3d0
51904 t3i=sign(1d0,ei+1d-6)/2d0
51905 ej=kchg(ja,1)/3d0
51906 t3j=sign(1d0,ej+1d-6)/2d0
51907 cxc(2)=vmixc(ij,1)*dconjg(zmixc(ix,1)*(ej-t3j)*
51908 & tanw+zmixc(ix,2)*t3j)
51909 cxc(4)=-dconjg(umixc(ij,1))*(
51910 & zmixc(ix,1)*(ei-t3i)*tanw+zmixc(ix,2)*t3i)
51911 xxc(5)=pmas(pycomp(ksusy1+ia),1)
51912 xxc(6)=pmas(pycomp(ksusy1+ja),1)
51913 IF(xxc(5).LT.axmi) THEN
51914 xxc(5)=1d6
51915 ENDIF
51916 IF(xxc(6).LT.axmi) THEN
51917 xxc(6)=1d6
51918 ENDIF
51919 xxc(7)=xxc(6)
51920 xxc(8)=xxc(5)
51921 IF(axmi.GE.axmj+pmas(2,1)+pmas(1,1)) THEN
51922 lknt=lknt+1
51923 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
51924 & pygaus(pyxxz6,s12min,s12max,prec)
51925 idlam(lknt,1)=kfcchi(ij)
51926 idlam(lknt,2)=1
51927 idlam(lknt,3)=-2
51928 lknt=lknt+1
51929 xlam(lknt)=xlam(lknt-1)
51930 idlam(lknt,1)=-idlam(lknt-1,1)
51931 idlam(lknt,2)=-idlam(lknt-1,2)
51932 idlam(lknt,3)=-idlam(lknt-1,3)
51933 IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
51934 lknt=lknt+1
51935 xlam(lknt)=xlam(lknt-1)
51936 idlam(lknt,1)=kfcchi(ij)
51937 idlam(lknt,2)=3
51938 idlam(lknt,3)=-4
51939 lknt=lknt+1
51940 xlam(lknt)=xlam(lknt-1)
51941 idlam(lknt,1)=-idlam(lknt-1,1)
51942 idlam(lknt,2)=-idlam(lknt-1,2)
51943 idlam(lknt,3)=-idlam(lknt-1,3)
51944 ENDIF
51945 ENDIF
51946 250 CONTINUE
51947 ENDIF
51948 260 CONTINUE
51949 270 CONTINUE
51950
51951C...CHI0_I -> CHI+_I + H-
51952 DO 280 ij=1,2
51953 xmj=smw(ij)
51954 axmj=abs(xmj)
51955 xmj2=xmj**2
51956 xmhp=pmas(ithc,1)
51957 IF(axmi.GE.axmj+xmhp) THEN
51958 lknt=lknt+1
51959 olpp=cbeta*(zmixc(ix,4)*dconjg(vmixc(ij,1))+(zmixc(ix,2)+
51960 & zmixc(ix,1)*tanw)*dconjg(vmixc(ij,2))/sr2)
51961 orpp=sbeta*(dconjg(zmixc(ix,3))*umixc(ij,1)-
51962 & (dconjg(zmixc(ix,2))+dconjg(zmixc(ix,1))*tanw)*
51963 & umixc(ij,2)/sr2)
51964 gx2=abs(olpp)**2+abs(orpp)**2
51965 glr=dble(olpp*dconjg(orpp))
51966 xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gx2,glr)
51967 idlam(lknt,1)=kfcchi(ij)
51968 idlam(lknt,2)=-ithc
51969 idlam(lknt,3)=0
51970 lknt=lknt+1
51971 xlam(lknt)=xlam(lknt-1)
51972 idlam(lknt,1)=-idlam(lknt-1,1)
51973 idlam(lknt,2)=-idlam(lknt-1,2)
51974 idlam(lknt,3)=-idlam(lknt-1,3)
51975 ELSE
51976
51977 ENDIF
51978 280 CONTINUE
51979
51980C...2-BODY DECAYS TO FERMION SFERMION
51981 DO 290 j=1,16
51982 IF(j.GE.7.AND.j.LE.10) GOTO 290
51983 kf1=ksusy1+j
51984 kf2=ksusy2+j
51985 xmsf1=pmas(pycomp(kf1),1)
51986 xmsf2=pmas(pycomp(kf2),1)
51987 xmf=pmas(j,1)
51988 IF(j.LE.6) THEN
51989 fcol=3d0
51990 ELSE
51991 fcol=1d0
51992 ENDIF
51993
51994 ei=kchg(j,1)/3d0
51995 t3t=sign(1d0,ei)
51996 IF(j.EQ.12.OR.j.EQ.14.OR.j.EQ.16) t3t=1d0
51997 IF(mod(j,2).EQ.0) THEN
51998 cbl=t3t*zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-t3t)
51999 cal=xmf*zmixc(ix,4)/xmw/sbeta
52000 car=-2d0*ei*tanw*zmixc(ix,1)
52001 cbr=cal
52002 ELSE
52003 cbl=t3t*zmixc(ix,2)+tanw*zmixc(ix,1)*(2d0*ei-t3t)
52004 cal=xmf*zmixc(ix,3)/xmw/cbeta
52005 car=-2d0*ei*tanw*zmixc(ix,1)
52006 cbr=cal
52007 ENDIF
52008
52009C...D~ D_L
52010 IF(axmi.GE.xmf+xmsf1) THEN
52011 lknt=lknt+1
52012 xma2=xmsf1**2
52013 xmb2=xmf**2
52014 xl=pylamf(xmi2,xma2,xmb2)
52015 ca=cal*sfmix(j,1)+car*sfmix(j,2)
52016 cb=cbl*sfmix(j,1)+cbr*sfmix(j,2)
52017 xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52018 & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52019 idlam(lknt,1)=kf1
52020 idlam(lknt,2)=-j
52021 idlam(lknt,3)=0
52022 lknt=lknt+1
52023 xlam(lknt)=xlam(lknt-1)
52024 idlam(lknt,1)=-idlam(lknt-1,1)
52025 idlam(lknt,2)=-idlam(lknt-1,2)
52026 idlam(lknt,3)=0
52027 ENDIF
52028
52029C...D~ D_R
52030 IF(axmi.GE.xmf+xmsf2) THEN
52031 lknt=lknt+1
52032 xma2=xmsf2**2
52033 xmb2=xmf**2
52034 ca=cal*sfmix(j,3)+car*sfmix(j,4)
52035 cb=cbl*sfmix(j,3)+cbr*sfmix(j,4)
52036 xl=pylamf(xmi2,xma2,xmb2)
52037 xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52038 & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52039 idlam(lknt,1)=kf2
52040 idlam(lknt,2)=-j
52041 idlam(lknt,3)=0
52042 lknt=lknt+1
52043 xlam(lknt)=xlam(lknt-1)
52044 idlam(lknt,1)=-idlam(lknt-1,1)
52045 idlam(lknt,2)=-idlam(lknt-1,2)
52046 idlam(lknt,3)=0
52047 ENDIF
52048 290 CONTINUE
52049 300 CONTINUE
52050C...3-BODY DECAY TO Q Q~ GLUINO
52051 xmj=pmas(pycomp(ksusy1+21),1)
52052 IF(axmi.GE.xmj) THEN
52053 rt2i = 1d0/sqrt(2d0)
52054 olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))*rt2i
52055 orpp=dconjg(olpp)
52056 axmj=abs(xmj)
52057 xxc(1)=0d0
52058 xxc(2)=xmj
52059 xxc(3)=0d0
52060 xxc(4)=xmi
52061 fid=1
52062 xxc(5)=pmas(pycomp(ksusy1+fid),1)
52063 xxc(6)=pmas(pycomp(ksusy2+fid),1)
52064 xxc(7)=xxc(5)
52065 xxc(8)=xxc(6)
52066 xxc(9)=1d6
52067 xxc(10)=0d0
52068 ei=kchg(fid,1)/3d0
52069 t3i=sign(1d0,ei+1d-6)/2d0
52070 glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
52071 grij=zmixc(ix,1)*(ei*tanw)*orpp
52072 cxc(1)=0d0
52073 cxc(2)=-glij
52074 cxc(3)=0d0
52075 cxc(4)=dconjg(glij)
52076 cxc(5)=0d0
52077 cxc(6)=grij
52078 cxc(7)=0d0
52079 cxc(8)=-dconjg(grij)
52080 s12min=0d0
52081 s12max=(axmi-axmj)**2
52082CMRENNA.This statement must be here to define S12MAX
52083 IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 310
52084C...ALL QUARKS BUT T
52085 IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
52086 lknt=lknt+1
52087 xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
52088 & pygaus(pyxxz6,s12min,s12max,1d-3)
52089 idlam(lknt,1)=ksusy1+21
52090 idlam(lknt,2)=1
52091 idlam(lknt,3)=-1
52092 IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
52093 lknt=lknt+1
52094 xlam(lknt)=xlam(lknt-1)
52095 idlam(lknt,1)=ksusy1+21
52096 idlam(lknt,2)=3
52097 idlam(lknt,3)=-3
52098 ENDIF
52099 ENDIF
52100 310 CONTINUE
52101 IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
52102 xxc(5)=pmas(pycomp(ksusy1+5),1)
52103 xxc(6)=pmas(pycomp(ksusy2+5),1)
52104 ELSE
52105 xxc(6)=pmas(pycomp(ksusy1+5),1)
52106 xxc(5)=pmas(pycomp(ksusy2+5),1)
52107 ENDIF
52108 IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 320
52109 xxc(7)=xxc(5)
52110 xxc(8)=xxc(6)
52111 IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
52112 lknt=lknt+1
52113 xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
52114 & pygaus(pyxxz6,s12min,s12max,1d-3)
52115 idlam(lknt,1)=ksusy1+21
52116 idlam(lknt,2)=5
52117 idlam(lknt,3)=-5
52118 ENDIF
52119C...U-TYPE QUARKS
52120 320 CONTINUE
52121 fid=2
52122 xxc(5)=pmas(pycomp(ksusy1+fid),1)
52123 xxc(6)=pmas(pycomp(ksusy2+fid),1)
52124 IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 330
52125 xxc(7)=xxc(5)
52126 xxc(8)=xxc(6)
52127 ei=kchg(fid,1)/3d0
52128 t3i=sign(1d0,ei+1d-6)/2d0
52129 glij=(t3i*zmixc(ix,2)-tanw*(t3i-ei)*zmixc(ix,1))*olpp
52130 grij=zmixc(ix,1)*(ei*tanw)*orpp
52131 cxc(2)=-glij
52132 cxc(4)=dconjg(glij)
52133 cxc(6)=grij
52134 cxc(8)=-dconjg(grij)
52135 IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
52136 lknt=lknt+1
52137 xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*
52138 & pygaus(pyxxz6,s12min,s12max,1d-3)
52139 idlam(lknt,1)=ksusy1+21
52140 idlam(lknt,2)=2
52141 idlam(lknt,3)=-2
52142 IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
52143 lknt=lknt+1
52144 xlam(lknt)=xlam(lknt-1)
52145 idlam(lknt,1)=ksusy1+21
52146 idlam(lknt,2)=4
52147 idlam(lknt,3)=-4
52148 ENDIF
52149 ENDIF
52150 330 CONTINUE
52151 ENDIF
52152
52153C...R-violating decay modes (SKANDS).
52154 CALL pyrvne(kfin,xlam,idlam,lknt)
52155
52156 340 iknt=lknt
52157 xlam(0)=0d0
52158 DO 350 i=1,iknt
52159 IF(xlam(i).LT.0d0) xlam(i)=0d0
52160 xlam(0)=xlam(0)+xlam(i)
52161 350 CONTINUE
52162 IF(xlam(0).EQ.0d0) xlam(0)=1d-6
52163
52164 RETURN
52165 END
52166
52167C*********************************************************************
52168
52169C...PYCJDC
52170C...Calculate decay widths for the charginos (admixtures of
52171C...charged Wino and charged Higgsino.
52172
52173C...Input: KCIN = KF code for particle
52174C...Output: XLAM = widths
52175C... IDLAM = KF codes for decay particles
52176C... IKNT = number of decay channels defined
52177C...AUTHOR: STEPHEN MRENNA
52178C...Last change:
52179C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52180C...when CHIENU .NE. 0
52181
52182 SUBROUTINE pycjdc(KFIN,XLAM,IDLAM,IKNT)
52183
52184C...Double precision and integer declarations.
52185 IMPLICIT DOUBLE PRECISION(a-h, o-z)
52186 IMPLICIT INTEGER(I-N)
52187 INTEGER PYK,PYCHGE,PYCOMP
52188C...Parameter statement to help give large particle numbers.
52189 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
52190 &kexcit=4000000,kdimen=5000000)
52191C...Commonblocks.
52192 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
52193 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
52194 common/pymssm/imss(0:99),rmss(0:99)
52195 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
52196 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
52197CC &SFMIX(16,4),
52198C COMMON/PYINTS/XXM(20)
52199 COMPLEX*16 CXC
52200 COMMON/PYINTC/XXC(10),CXC(8)
52201 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52202
52203C...Local variables
52204 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52205 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52206 INTEGER KFIN,KCIN
52207 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52208 &xmz,xmz2,axmj,axmi
52209 DOUBLE PRECISION S12MIN,S12MAX
52210 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52211 DOUBLE PRECISION PYLAMF,XL
52212 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52213 DOUBLE PRECISION PYX2XH,PYX2XG
52214 DOUBLE PRECISION XLAM(0:400)
52215 INTEGER IDLAM(400,3)
52216 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52217 INTEGER ITH(3)
52218 INTEGER ITHC
52219 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52220 DOUBLE PRECISION SR2
52221 DOUBLE PRECISION CBETA,SBETA,TANB
52222
52223 DOUBLE PRECISION PYALEM,PI,PYALPS
52224 DOUBLE PRECISION FCOL
52225 INTEGER KF1,KF2,ISF
52226 INTEGER KFNCHI(4),KFCCHI(2)
52227
52228 DOUBLE PRECISION TEMP
52229 EXTERNAL pygaus,pyxxz6
52230 DOUBLE PRECISION PYGAUS,PYXXZ6
52231 DOUBLE PRECISION PREC
52232 DATA ith/25,35,36/
52233 DATA ithc/37/
52234 DATA etah/1d0,1d0,-1d0/
52235 DATA sr2/1.4142136d0/
52236 DATA pi/3.141592654d0/
52237 DATA prec/1d-2/
52238 DATA kfnchi/1000022,1000023,1000025,1000035/
52239 DATA kfcchi/1000024,1000037/
52240
52241C...COUNT THE NUMBER OF DECAY MODES
52242 lknt=0
52243 xmw=pmas(24,1)
52244 xmw2=xmw**2
52245 xmz=pmas(23,1)
52246 xmz2=xmz**2
52247 xw=1d0-xmw2/xmz2
52248 xw1=1d0-xw
52249 tanw = sqrt(xw/xw1)
52250
52251C...1 OR 2 DEPENDING ON CHARGINO TYPE
52252 ix=1
52253 IF(kfin.EQ.kfcchi(2)) ix=2
52254 kcin=pycomp(kfin)
52255
52256 xmi=smw(ix)
52257 xmi2=xmi**2
52258 axmi=abs(xmi)
52259 aem=pyalem(xmi2)
52260 as =pyalps(xmi2)
52261 c1=aem/xw
52262 xmi3=abs(xmi**3)
52263 tanb=rmss(5)
52264 beta=atan(tanb)
52265 cbeta=cos(beta)
52266 sbeta=tanb*cbeta
52267 alfa=rmss(18)
52268
52269 DO 110 i=1,2
52270 DO 100 j=1,2
52271 vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
52272 umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
52273 100 CONTINUE
52274 110 CONTINUE
52275
52276C...GRAVITINO DECAY MODES
52277
52278 IF(imss(11).EQ.1) THEN
52279 xmp=rmss(29)
52280 idg=39+ksusy1
52281 xmgr=pmas(pycomp(idg),1)
52282C SINW=SQRT(XW)
52283C COSW=SQRT(1D0-XW)
52284 xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi
52285 IF(axmi.GT.xmgr+xmw) THEN
52286 lknt=lknt+1
52287 idlam(lknt,1)=idg
52288 idlam(lknt,2)=24
52289 idlam(lknt,3)=0
52290 xlam(lknt)=xfac*(
52291 & .5d0*(abs(vmixc(ix,1))**2+abs(umixc(ix,1))**2)+
52292 & .5d0*((abs(vmixc(ix,2))*sbeta)**2+(abs(umixc(ix,2))*cbeta)**2))*
52293 & (1d0-xmw2/xmi2)**4
52294 ENDIF
52295 IF(axmi.GT.xmgr+pmas(37,1)) THEN
52296 lknt=lknt+1
52297 idlam(lknt,1)=idg
52298 idlam(lknt,2)=37
52299 idlam(lknt,3)=0
52300 xlam(lknt)=xfac*(.5d0*((abs(vmixc(ix,2))*cbeta)**2+
52301 & (abs(umixc(ix,2))*sbeta)**2))
52302 & *(1d0-pmas(37,1)**2/xmi2)**4
52303 ENDIF
52304 ENDIF
52305
52306C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52307 IF(ix.EQ.1) GOTO 170
52308 xmj=smw(1)
52309 axmj=abs(xmj)
52310 xmj2=xmj**2
52311
52312C...CHI_2+ -> CHI_1+ + Z0
52313 IF(axmi.GE.axmj+xmz) THEN
52314 lknt=lknt+1
52315 ij=1
52316 olpp=-vmixc(ij,1)*dconjg(vmixc(ix,1))-
52317 & vmixc(ij,2)*dconjg(vmixc(ix,2))/2d0
52318 orpp=-umixc(ix,1)*dconjg(umixc(ij,1))-
52319 & umixc(ix,2)*dconjg(umixc(ij,2))/2d0
52320 gx2=abs(olpp)**2+abs(orpp)**2
52321 glr=dble(olpp*dconjg(orpp))
52322 xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gx2,glr)
52323 idlam(lknt,1)=kfcchi(1)
52324 idlam(lknt,2)=23
52325 idlam(lknt,3)=0
52326
52327C...CHARGED LEPTONS
52328 ELSEIF(axmi.GE.axmj) THEN
52329 s12min=0d0
52330 s12max=(axmi-axmj)**2
52331 ia=11
52332 ja=12
52333 ei=kchg(iabs(ia),1)/3d0
52334 t3i=sign(1d0,ei+1d-6)/2d0
52335 xxc(1)=0d0
52336 xxc(2)=xmj
52337 xxc(3)=0d0
52338 xxc(4)=xmi
52339 xxc(5)=pmas(pycomp(ksusy1+ja),1)
52340 xxc(6)=1d6
52341 xxc(9)=pmas(23,1)
52342 xxc(10)=pmas(23,2)
52343 ij=1
52344 olpp=-vmixc(ij,1)*dconjg(vmixc(ix,1))-
52345 & vmixc(ij,2)*dconjg(vmixc(ix,2))/2d0
52346 orpp=-umixc(ix,1)*dconjg(umixc(ij,1))-
52347 & umixc(ix,2)*dconjg(umixc(ij,2))/2d0
52348 cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
52349 cxc(2)=dcmplx(0d0,0d0)
52350 cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
52351 cxc(4)=-vmixc(ij,1)*dconjg(vmixc(ix,1))*dcmplx(t3i/xw)
52352 cxc(5)=-dcmplx(ei/xw1)*orpp
52353 cxc(6)=dcmplx(0d0,0d0)
52354 cxc(7)=-dcmplx(ei/xw1)*olpp
52355 cxc(8)=dcmplx(0d0,0d0)
52356 IF( xxc(5).LT.axmi ) THEN
52357 xxc(5)=1d6
52358 ENDIF
52359 xxc(7)=xxc(5)
52360 xxc(8)=xxc(6)
52361 IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN
52362 lknt=lknt+1
52363 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52364 & pygaus(pyxxz6,s12min,s12max,prec)
52365 idlam(lknt,1)=kfcchi(1)
52366 idlam(lknt,2)=11
52367 idlam(lknt,3)=-11
52368 IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN
52369 lknt=lknt+1
52370 xlam(lknt)=xlam(lknt-1)
52371 idlam(lknt,1)=kfcchi(1)
52372 idlam(lknt,2)=13
52373 idlam(lknt,3)=-13
52374 ENDIF
52375 IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN
52376 lknt=lknt+1
52377 xlam(lknt)=xlam(lknt-1)
52378 idlam(lknt,1)=kfcchi(1)
52379 idlam(lknt,2)=15
52380 idlam(lknt,3)=-15
52381 ENDIF
52382 ENDIF
52383
52384C...NEUTRINOS
52385 120 CONTINUE
52386 ia=12
52387 ja=11
52388 ei=kchg(iabs(ia),1)/3d0
52389 t3i=sign(1d0,ei+1d-6)/2d0
52390 xxc(5)=pmas(pycomp(ksusy1+ja),1)
52391 xxc(6)=1d6
52392 cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
52393 cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
52394 cxc(4)=-umixc(ij,1)*dconjg(umixc(ix,1))*dcmplx(t3i/xw)
52395 cxc(5)=-dcmplx(ei/xw1)*orpp
52396 cxc(7)=-dcmplx(ei/xw1)*olpp
52397 IF( xxc(5).LT.axmi ) THEN
52398 xxc(5)=1d6
52399 ENDIF
52400 xxc(7)=xxc(5)
52401 xxc(8)=xxc(6)
52402 IF(axmi.GE.axmj+2d0*pmas(12,1)) THEN
52403 lknt=lknt+1
52404 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52405 & pygaus(pyxxz6,s12min,s12max,prec)
52406 idlam(lknt,1)=kfcchi(1)
52407 idlam(lknt,2)=12
52408 idlam(lknt,3)=-12
52409 lknt=lknt+1
52410 xlam(lknt)=xlam(lknt-1)
52411 idlam(lknt,1)=kfcchi(1)
52412 idlam(lknt,2)=14
52413 idlam(lknt,3)=-14
52414 ENDIF
52415 IF(axmi.GE.axmj+2d0*pmas(16,1)) THEN
52416 IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
52417 xxc(5)=pmas(pycomp(ksusy1+15),1)
52418 ELSE
52419 xxc(5)=pmas(pycomp(ksusy2+15),1)
52420 ENDIF
52421 IF( xxc(5).LT.axmi ) THEN
52422 xxc(5)=1d6
52423 ENDIF
52424 xxc(7)=xxc(5)
52425 lknt=lknt+1
52426 xlam(lknt)=c1**2/xmi3/(16d0*pi)*
52427 & pygaus(pyxxz6,s12min,s12max,prec)
52428 idlam(lknt,1)=kfcchi(1)
52429 idlam(lknt,2)=16
52430 idlam(lknt,3)=-16
52431 ENDIF
52432
52433C...D-TYPE QUARKS
52434 130 CONTINUE
52435 ia=1
52436 ja=2
52437 ei=kchg(iabs(ia),1)/3d0
52438 t3i=sign(1d0,ei+1d-6)/2d0
52439 xxc(5)=pmas(pycomp(ksusy1+ja),1)
52440 xxc(6)=1d6
52441 cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
52442 cxc(2)=dcmplx(0d0,0d0)
52443 cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
52444 cxc(4)=-vmixc(ij,1)*dconjg(vmixc(ix,1))*dcmplx(t3i/xw)
52445 cxc(5)=-dcmplx(ei/xw1)*orpp
52446 cxc(6)=dcmplx(0d0,0d0)
52447 cxc(7)=-dcmplx(ei/xw1)*olpp
52448 cxc(8)=dcmplx(0d0,0d0)
52449 IF( xxc(5).LT.axmi ) THEN
52450 xxc(5)=1d6
52451 ENDIF
52452 xxc(7)=xxc(5)
52453 xxc(8)=xxc(6)
52454 IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN
52455 lknt=lknt+1
52456 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52457 & pygaus(pyxxz6,s12min,s12max,prec)
52458 idlam(lknt,1)=kfcchi(1)
52459 idlam(lknt,2)=1
52460 idlam(lknt,3)=-1
52461 IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN
52462 lknt=lknt+1
52463 xlam(lknt)=xlam(lknt-1)
52464 idlam(lknt,1)=kfcchi(1)
52465 idlam(lknt,2)=3
52466 idlam(lknt,3)=-3
52467 ENDIF
52468 ENDIF
52469 IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN
52470 IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN
52471 xxc(5)=pmas(pycomp(ksusy1+5),1)
52472 ELSE
52473 xxc(5)=pmas(pycomp(ksusy2+5),1)
52474 ENDIF
52475 IF( xxc(5).LT.axmi ) THEN
52476 xxc(5)=1d6
52477 ENDIF
52478 xxc(7)=xxc(5)
52479 lknt=lknt+1
52480 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52481 & pygaus(pyxxz6,s12min,s12max,prec)
52482 idlam(lknt,1)=kfcchi(1)
52483 idlam(lknt,2)=5
52484 idlam(lknt,3)=-5
52485 ENDIF
52486
52487C...U-TYPE QUARKS
52488 140 CONTINUE
52489 ia=2
52490 ja=1
52491 ei=kchg(iabs(ia),1)/3d0
52492 t3i=sign(1d0,ei+1d-6)/2d0
52493 xxc(5)=pmas(pycomp(ksusy1+ja),1)
52494 xxc(6)=1d6
52495 cxc(1)=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
52496 cxc(2)=dcmplx(0d0,0d0)
52497 cxc(3)=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
52498 cxc(4)=-umixc(ij,1)*dconjg(umixc(ix,1))*dcmplx(t3i/xw)
52499 cxc(5)=-dcmplx(ei/xw1)*orpp
52500 cxc(6)=dcmplx(0d0,0d0)
52501 cxc(7)=-dcmplx(ei/xw1)*olpp
52502 cxc(8)=dcmplx(0d0,0d0)
52503 IF( xxc(5).LT.axmi ) THEN
52504 xxc(5)=1d6
52505 ENDIF
52506 xxc(7)=xxc(5)
52507 xxc(8)=xxc(6)
52508 IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN
52509 lknt=lknt+1
52510 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52511 & pygaus(pyxxz6,s12min,s12max,prec)
52512 idlam(lknt,1)=kfcchi(1)
52513 idlam(lknt,2)=2
52514 idlam(lknt,3)=-2
52515 IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN
52516 lknt=lknt+1
52517 xlam(lknt)=xlam(lknt-1)
52518 idlam(lknt,1)=kfcchi(1)
52519 idlam(lknt,2)=4
52520 idlam(lknt,3)=-4
52521 ENDIF
52522 ENDIF
52523 150 CONTINUE
52524 ENDIF
52525
52526C...CHI_2+ -> CHI_1+ + H0_K
52527 eh(2)=cos(alfa)
52528 eh(1)=sin(alfa)
52529 eh(3)=-sbeta
52530 dh(2)=-sin(alfa)
52531 dh(1)=cos(alfa)
52532 dh(3)=cos(beta)
52533 DO 160 ih=1,3
52534 xmh=pmas(ith(ih),1)
52535 xmh2=xmh**2
52536C...NO 3-BODY OPTION
52537 IF(axmi.GE.axmj+xmh) THEN
52538 lknt=lknt+1
52539 xl=pylamf(xmi2,xmj2,xmh2)
52540 olpp=(vmixc(2,1)*dconjg(umixc(1,2))*eh(ih) -
52541 & vmixc(2,2)*dconjg(umixc(1,1))*dh(ih))/sr2
52542 orpp=(dconjg(vmixc(1,1))*umixc(2,2)*eh(ih) -
52543 & dconjg(vmixc(1,2))*umixc(2,1)*dh(ih))/sr2
52544 xmk=xmj*etah(ih)
52545 gx2=abs(olpp)**2+abs(orpp)**2
52546 glr=dble(olpp*dconjg(orpp))
52547 xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,gx2,glr)
52548 idlam(lknt,1)=kfcchi(1)
52549 idlam(lknt,2)=ith(ih)
52550 idlam(lknt,3)=0
52551 ENDIF
52552 160 CONTINUE
52553
52554C...CHI1 JUMPS TO HERE
52555 170 CONTINUE
52556
52557C...CHI+_I -> CHI0_J + W+
52558 DO 220 ij=1,4
52559 xmj=smz(ij)
52560 axmj=abs(xmj)
52561 xmj2=xmj**2
52562 IF(axmi.GE.axmj+xmw) THEN
52563 lknt=lknt+1
52564 DO 180 i=1,4
52565 zmixc(ij,i)=dcmplx(zmix(ij,i),zmixi(ij,i))
52566 180 CONTINUE
52567 cxc(1)=(dconjg(zmixc(ij,2))*vmixc(ix,1)-
52568 & dconjg(zmixc(ij,4))*vmixc(ix,2)/sr2)
52569 cxc(3)=(zmixc(ij,2)*dconjg(umixc(ix,1))+
52570 & zmixc(ij,3)*dconjg(umixc(ix,2))/sr2)
52571 gx2=abs(cxc(1))**2+abs(cxc(3))**2
52572 glr=dble(cxc(1)*dconjg(cxc(3)))
52573 xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gx2,glr)
52574 idlam(lknt,1)=kfnchi(ij)
52575 idlam(lknt,2)=24
52576 idlam(lknt,3)=0
52577C...LEPTONS
52578 ELSEIF(axmi.GE.axmj) THEN
52579 s12min=0d0
52580 s12max=(axmi-axmj)**2
52581 DO 190 i=1,4
52582 zmixc(ij,i)=dcmplx(zmix(ij,i),zmixi(ij,i))
52583 190 CONTINUE
52584 cxc(1)=(dconjg(zmixc(ij,2))*vmixc(ix,1)-
52585 & dconjg(zmixc(ij,4))*vmixc(ix,2)/sr2)/sr2
52586 cxc(3)=(zmixc(ij,2)*dconjg(umixc(ix,1))+
52587 & zmixc(ij,3)*dconjg(umixc(ix,2))/sr2)/sr2
52588 cxc(5)=dcmplx(0d0,0d0)
52589 cxc(7)=dcmplx(0d0,0d0)
52590 ia=11
52591 ja=12
52592 ei=kchg(ia,1)/3d0
52593 t3i=sign(1d0,ei+1d-6)/2d0
52594 ej=kchg(ja,1)/3d0
52595 t3j=sign(1d0,ej+1d-6)/2d0
52596 cxc(2)=vmixc(ix,1)*dconjg(zmixc(ij,1)*(ej-t3j)*
52597 & tanw+zmixc(ij,2)*t3j)/sr2
52598 cxc(4)=-dconjg(umixc(ix,1))*(
52599 & zmixc(ij,1)*(ei-t3i)*tanw+zmixc(ij,2)*t3i)/sr2
52600 cxc(6)=dcmplx(0d0,0d0)
52601 cxc(8)=dcmplx(0d0,0d0)
52602 xxc(1)=0d0
52603 xxc(2)=xmj
52604 xxc(3)=0d0
52605 xxc(4)=xmi
52606 xxc(5)=pmas(pycomp(ksusy1+ja),1)
52607 xxc(6)=pmas(pycomp(ksusy1+ia),1)
52608 xxc(9)=pmas(24,1)
52609 xxc(10)=pmas(24,2)
52610CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52611 IF(xxc(5).LT.axmi) THEN
52612 xxc(5)=1d6
52613 ELSEIF(xxc(6).LT.axmi) THEN
52614 xxc(6)=1d6
52615 ENDIF
52616 xxc(7)=xxc(6)
52617 xxc(8)=xxc(5)
52618C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52619C...--> 1/(16PI)/M**3*(AEM/XW)**2
52620 IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN
52621 lknt=lknt+1
52622 temp=pygaus(pyxxz6,s12min,s12max,prec)
52623 xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
52624 idlam(lknt,1)=kfnchi(ij)
52625 idlam(lknt,2)=-11
52626 idlam(lknt,3)=12
52627C...ONLY DECAY CHI+1 -> E+ NU_E
52628 IF( imss(12).NE. 0 ) GOTO 260
52629 IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN
52630 lknt=lknt+1
52631 xlam(lknt)=xlam(lknt-1)
52632 idlam(lknt,1)=kfnchi(ij)
52633 idlam(lknt,2)=-13
52634 idlam(lknt,3)=14
52635 ENDIF
52636 ENDIF
52637 IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN
52638 lknt=lknt+1
52639 IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN
52640 xxc(6)=pmas(pycomp(ksusy1+15),1)
52641 ELSE
52642 xxc(6)=pmas(pycomp(ksusy2+15),1)
52643 ENDIF
52644 xxc(5)=pmas(pycomp(ksusy1+16),1)
52645 IF(xxc(5).LT.axmi) THEN
52646 xxc(5)=1d6
52647 ELSEIF(xxc(6).LT.axmi) THEN
52648 xxc(6)=1d6
52649 ENDIF
52650 xxc(7)=xxc(6)
52651 xxc(8)=xxc(5)
52652 temp=pygaus(pyxxz6,s12min,s12max,prec)
52653 xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp
52654 idlam(lknt,1)=kfnchi(ij)
52655 idlam(lknt,2)=-15
52656 idlam(lknt,3)=16
52657 ENDIF
52658
52659C...NOW, DO THE QUARKS
52660 200 CONTINUE
52661 ia=1
52662 ja=2
52663 ei=kchg(ia,1)/3d0
52664 t3i=sign(1d0,ei+1d-6)/2d0
52665 ej=kchg(ja,1)/3d0
52666 t3j=sign(1d0,ej+1d-6)/2d0
52667 cxc(2)=vmixc(ix,1)*dconjg(zmixc(ij,1)*(ej-t3j)*
52668 & tanw+zmixc(ij,2)*t3j)
52669 cxc(4)=-dconjg(umixc(ix,1))*(
52670 & zmixc(ij,1)*(ei-t3i)*tanw+zmixc(ij,2)*t3i)
52671 xxc(5)=pmas(pycomp(ksusy1+ja),1)
52672 xxc(6)=pmas(pycomp(ksusy1+ia),1)
52673 IF( xxc(5).LT.axmi .AND. xxc(6).LT.axmi ) GOTO 210
52674 IF(xxc(5).LT.axmi) THEN
52675 xxc(5)=1d6
52676 ENDIF
52677 IF(xxc(6).LT.axmi) THEN
52678 xxc(6)=1d6
52679 ENDIF
52680 xxc(7)=xxc(6)
52681 xxc(8)=xxc(5)
52682 IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
52683 lknt=lknt+1
52684 xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*
52685 & pygaus(pyxxz6,s12min,s12max,prec)
52686 idlam(lknt,1)=kfnchi(ij)
52687 idlam(lknt,2)=-1
52688 idlam(lknt,3)=2
52689 IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
52690 lknt=lknt+1
52691 xlam(lknt)=xlam(lknt-1)
52692 idlam(lknt,1)=kfnchi(ij)
52693 idlam(lknt,2)=-3
52694 idlam(lknt,3)=4
52695 ENDIF
52696 ENDIF
52697 210 CONTINUE
52698 ENDIF
52699 220 CONTINUE
52700
52701C...CHI+_I -> CHI0_J + H+
52702 DO 230 ij=1,4
52703 xmj=smz(ij)
52704 axmj=abs(xmj)
52705 xmj2=xmj**2
52706 xmhp=pmas(ithc,1)
52707 IF(axmi.GE.axmj+xmhp) THEN
52708 lknt=lknt+1
52709 olpp=cbeta*(zmixc(ij,4)*dconjg(vmixc(ix,1))+(zmixc(ij,2)+
52710 & zmixc(ij,1)*tanw)*dconjg(vmixc(ix,2))/sr2)
52711 orpp=sbeta*(dconjg(zmixc(ij,3))*umixc(ix,1)-
52712 & (dconjg(zmixc(ij,2))+dconjg(zmixc(ij,1))*tanw)*
52713 & umixc(ix,2)/sr2)
52714 gx2=abs(olpp)**2+abs(orpp)**2
52715 glr=dble(olpp*dconjg(orpp))
52716 xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gx2,glr)
52717 idlam(lknt,1)=kfnchi(ij)
52718 idlam(lknt,2)=ithc
52719 idlam(lknt,3)=0
52720 ELSE
52721
52722 ENDIF
52723 230 CONTINUE
52724
52725C...2-BODY DECAYS TO FERMION SFERMION
52726 DO 240 j=1,16
52727 IF(j.GE.7.AND.j.LE.10) GOTO 240
52728 IF(mod(j,2).EQ.0) THEN
52729 kf1=ksusy1+j-1
52730 ELSE
52731 kf1=ksusy1+j+1
52732 ENDIF
52733 kf2=kf1+ksusy1
52734 xmsf1=pmas(pycomp(kf1),1)
52735 xmsf2=pmas(pycomp(kf2),1)
52736 xmf=pmas(j,1)
52737 IF(j.LE.6) THEN
52738 fcol=3d0
52739 ELSE
52740 fcol=1d0
52741 ENDIF
52742
52743C...U~ D_L
52744 IF(mod(j,2).EQ.0) THEN
52745 xmfp=pmas(j-1,1)
52746 cal=umixc(ix,1)
52747 cbl=-xmf*vmixc(ix,2)/xmw/sbeta/sr2
52748 car=-xmfp*umixc(ix,2)/xmw/cbeta/sr2
52749 cbr=0d0
52750 isf=j-1
52751 ELSE
52752 xmfp=pmas(j+1,1)
52753 cal=vmixc(ix,1)
52754 cbl=-xmf*umixc(ix,2)/xmw/cbeta/sr2
52755 cbr=0d0
52756 car=-xmfp*vmixc(ix,2)/xmw/sbeta/sr2
52757 isf=j+1
52758 ENDIF
52759
52760C...~U_L D
52761 IF(axmi.GE.xmf+xmsf1) THEN
52762 lknt=lknt+1
52763 xma2=xmsf1**2
52764 xmb2=xmf**2
52765 xl=pylamf(xmi2,xma2,xmb2)
52766 ca=cal*sfmix(isf,1)+car*sfmix(isf,2)
52767 cb=cbl*sfmix(isf,1)+cbr*sfmix(isf,2)
52768 xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52769 & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52770 idlam(lknt,3)=0
52771 IF(mod(j,2).EQ.0) THEN
52772 idlam(lknt,1)=-kf1
52773 idlam(lknt,2)=j
52774 ELSE
52775 idlam(lknt,1)=kf1
52776 idlam(lknt,2)=-j
52777 ENDIF
52778 ENDIF
52779
52780C...U~ D_R
52781 IF(axmi.GE.xmf+xmsf2) THEN
52782 lknt=lknt+1
52783 xma2=xmsf2**2
52784 xmb2=xmf**2
52785 ca=cal*sfmix(isf,3)+car*sfmix(isf,4)
52786 cb=cbl*sfmix(isf,3)+cbr*sfmix(isf,4)
52787 xl=pylamf(xmi2,xma2,xmb2)
52788 xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*
52789 & (abs(ca)**2+abs(cb)**2)+4d0*dble(ca*dconjg(cb))*xmf*xmi)
52790 idlam(lknt,3)=0
52791 IF(mod(j,2).EQ.0) THEN
52792 idlam(lknt,1)=-kf2
52793 idlam(lknt,2)=j
52794 ELSE
52795 idlam(lknt,1)=kf2
52796 idlam(lknt,2)=-j
52797 ENDIF
52798 ENDIF
52799 240 CONTINUE
52800
52801C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52802C...A 2-BODY -- 2-BODY CHAIN
52803 xmj=pmas(pycomp(ksusy1+21),1)
52804 IF(axmi.GE.xmj) THEN
52805 axmj=abs(xmj)
52806 s12min=0d0
52807 s12max=(axmi-axmj)**2
52808 xxc(1)=0d0
52809 xxc(2)=xmj
52810 xxc(3)=0d0
52811 xxc(4)=xmi
52812 xxc(5)=pmas(pycomp(ksusy1+1),1)
52813 xxc(6)=pmas(pycomp(ksusy1+2),1)
52814 xxc(9)=1d6
52815 xxc(10)=0d0
52816 olpp=dcmplx(cos(rmss(32)),sin(rmss(32)))
52817 orpp=dconjg(olpp)
52818 cxc(1)=dcmplx(0d0,0d0)
52819 cxc(3)=dcmplx(0d0,0d0)
52820 cxc(5)=dcmplx(0d0,0d0)
52821 cxc(7)=dcmplx(0d0,0d0)
52822 cxc(2)=umixc(ix,1)*olpp/sr2
52823 cxc(4)=-dconjg(vmixc(ix,1))*orpp/sr2
52824 cxc(6)=dcmplx(0d0,0d0)
52825 cxc(8)=dcmplx(0d0,0d0)
52826 IF(xxc(5).LT.axmi) THEN
52827 xxc(5)=1d6
52828 ELSEIF(xxc(6).LT.axmi) THEN
52829 xxc(6)=1d6
52830 ENDIF
52831 xxc(7)=xxc(6)
52832 xxc(8)=xxc(5)
52833 IF( xxc(5).LT.axmi .OR. xxc(6).LT.axmi ) GOTO 250
52834 IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN
52835 lknt=lknt+1
52836 xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*
52837 & pygaus(pyxxz6,s12min,s12max,prec)
52838 idlam(lknt,1)=ksusy1+21
52839 idlam(lknt,2)=-1
52840 idlam(lknt,3)=2
52841 IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN
52842 lknt=lknt+1
52843 xlam(lknt)=xlam(lknt-1)
52844 idlam(lknt,1)=ksusy1+21
52845 idlam(lknt,2)=-3
52846 idlam(lknt,3)=4
52847 ENDIF
52848 ENDIF
52849 250 CONTINUE
52850 ENDIF
52851
52852C...R-violating decay modes (SKANDS).
52853 CALL pyrvch(kfin,xlam,idlam,lknt)
52854
52855 260 iknt=lknt
52856 xlam(0)=0d0
52857 DO 270 i=1,iknt
52858 xlam(0)=xlam(0)+xlam(i)
52859 IF(xlam(i).LT.0d0) THEN
52860 WRITE(mstu(11),*) ' XLAM(I) = ',xlam(i),kcin,
52861 & (idlam(i,j),j=1,3)
52862 xlam(i)=0d0
52863 ENDIF
52864 270 CONTINUE
52865 IF(xlam(0).EQ.0d0) THEN
52866 xlam(0)=1d-6
52867 WRITE(mstu(11),*) ' XLAM(0) = ',xlam(0)
52868 WRITE(mstu(11),*) lknt
52869 WRITE(mstu(11),*) (xlam(j),j=1,lknt)
52870 ENDIF
52871
52872 RETURN
52873 END
52874
52875C*********************************************************************
52876
52877C...PYXXZ6
52878C...Used in the calculation of inoi -> inoj + f + ~f.
52879
52880 FUNCTION pyxxz6(X)
52881
52882C...Double precision and integer declarations.
52883 IMPLICIT DOUBLE PRECISION(a-h, o-z)
52884 IMPLICIT INTEGER(I-N)
52885 INTEGER PYK,PYCHGE,PYCOMP
52886C...Parameter statement to help give large particle numbers.
52887 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
52888 &kexcit=4000000,kdimen=5000000)
52889C...Commonblocks.
52890 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
52891C COMMON/PYINTS/XXM(20)
52892 COMPLEX*16 CXC
52893 COMMON/PYINTC/XXC(10),CXC(8)
52894 SAVE /pydat1/,/pyintc/
52895
52896C...Local variables.
52897 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
52898 DOUBLE PRECISION PYXXZ6,X
52899 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
52900 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
52901 DOUBLE PRECISION SIJ
52902 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
52903 DOUBLE PRECISION OL2
52904 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
52905 INTEGER I
52906
52907C...Statement functions.
52908C...Integral from x to y of (t-a)(b-t) dt.
52909 tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)
52910C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
52911 tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-
52912 &log(abs((x-c)/(y-c)))*(c-b)*(c-a)
52913C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
52914 tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+
52915 &(b+a-2d0*c)*log(abs((x-c)/(y-c)))
52916C...Integral from x to y of (t-a)/(b-t) dt.
52917 utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)
52918C...Integral from x to y of 1/(t-a) dt.
52919 tprop(x,y,a)=log(abs((x-a)/(y-a)))
52920
52921 xm12=xxc(1)**2
52922 xm22=xxc(2)**2
52923 xm32=xxc(3)**2
52924 s=xxc(4)**2
52925 s13=x
52926
52927 s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)
52928 s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*
52929 &( (x-xm22-s)**2 -4d0*xm22*s ) )
52930
52931 s23min=(s23ave-s23del)
52932 s23max=(s23ave+s23del)
52933
52934 xmsd1=xxc(5)**2
52935 xmsd2=xxc(7)**2
52936 xmsu1=xxc(6)**2
52937 xmsu2=xxc(8)**2
52938
52939 xmv=xxc(9)
52940 xmg=xxc(10)
52941 qlls=cxc(1)
52942 qllu=cxc(2)
52943 qlrs=cxc(3)
52944 qlrt=cxc(4)
52945 qrls=cxc(5)
52946 qrlt=cxc(6)
52947 qrrs=cxc(7)
52948 qrru=cxc(8)
52949 wprop2=(s13-xmv**2)**2+(xmv*xmg)**2
52950 sij=2d0*xxc(2)*xxc(4)*s13
52951 IF(xmv.LE.1000d0) THEN
52952 ol2=abs(qlls)**2+abs(qrrs)**2+abs(qlrs)**2+abs(qrls)**2
52953 olr=-2d0*dble(qlrs*dconjg(qlls)+qrls*dconjg(qrrs))
52954 ww=(ol2*2d0*tint(s23max,s23min,xm22,s)
52955 & +olr*sij*(s23max-s23min))/wprop2
52956 IF(xxc(5).LE.10000d0) THEN
52957 wfl1=4d0*(dble(qlls*dconjg(qllu))*
52958 & tint2(s23max,s23min,xm22,s,xmsd1)-
52959 & .5d0*dble(qlls*dconjg(qlrt))*sij*tprop(s23max,s23min,xmsd2)+
52960 & dble(qlrs*dconjg(qlrt))*tint2(s23max,s23min,xm22,s,xmsd2)-
52961 & .5d0*dble(qlrs*dconjg(qllu))*sij*tprop(s23max,s23min,xmsd1))
52962 & *(s13-xmv**2)/wprop2
52963 ELSE
52964 wfl1=0d0
52965 ENDIF
52966
52967 IF(xxc(6).LE.10000d0) THEN
52968 wfl2=4d0*(dble(qrrs*dconjg(qrru))*
52969 & tint2(s23max,s23min,xm22,s,xmsu1)-
52970 & .5d0*dble(qrrs*dconjg(qrlt))*sij*tprop(s23max,s23min,xmsu2)+
52971 & dble(qrls*dconjg(qrlt))*tint2(s23max,s23min,xm22,s,xmsu2)-
52972 & .5d0*dble(qrls*dconjg(qrru))*sij*tprop(s23max,s23min,xmsu1))
52973 & *(s13-xmv**2)/wprop2
52974 ELSE
52975 wfl2=0d0
52976 ENDIF
52977 ELSE
52978 ww=0d0
52979 wfl1=0d0
52980 wfl2=0d0
52981 ENDIF
52982 IF(xxc(5).LE.10000d0) THEN
52983 wf1=2d0*abs(qllu)**2*tint3(s23max,s23min,xm22,s,xmsd1)
52984 & +2d0*abs(qlrt)**2*tint3(s23max,s23min,xm22,s,xmsd2)
52985 & - 2d0*dble(qlrt*dconjg(qllu))*
52986 & sij*utint(s23max,s23min,xmsd1,xm22+s-s13-xmsd2)
52987 ELSE
52988 wf1=0d0
52989 ENDIF
52990 IF(xxc(6).LE.10000d0) THEN
52991 wf2=2d0*abs(qrru)**2*tint3(s23max,s23min,xm22,s,xmsu1)
52992 & +2d0*abs(qrlt)**2*tint3(s23max,s23min,xm22,s,xmsu2)
52993 & - 2d0*dble(qrlt*dconjg(qrru))*
52994 & sij*utint(s23max,s23min,xmsu1,xm22+s-s13-xmsu2)
52995 ELSE
52996 wf2=0d0
52997 ENDIF
52998
52999 pyxxz6=(ww+wf1+wf2+wfl1+wfl2)
53000
53001 IF(pyxxz6.LT.0d0) THEN
53002 WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ6 '
53003 WRITE(mstu(11),*) (xxc(i),i=1,5)
53004 WRITE(mstu(11),*) (xxc(i),i=6,10)
53005 WRITE(mstu(11),*) ww,wf1,wf2,wfl1,wfl2
53006 WRITE(mstu(11),*) s23min,s23max
53007 pyxxz6=0d0
53008 ENDIF
53009
53010 RETURN
53011 END
53012
53013
53014C*********************************************************************
53015
53016C...PYXXGA
53017C...Calculates chi0_i -> chi0_j + gamma.
53018
53019 FUNCTION pyxxga(C0,XM1,XM2,XMTR,XMTL)
53020
53021C...Double precision and integer declarations.
53022 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53023 IMPLICIT INTEGER(I-N)
53024 INTEGER PYK,PYCHGE,PYCOMP
53025
53026C...Local variables.
53027 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53028 DOUBLE PRECISION F1,F2
53029
53030 F1=(1d0+xmtr/(1d0-xmtr)*log(xmtr))/(1d0-xmtr)
53031 f2=(1d0+xmtl/(1d0-xmtl)*log(xmtl))/(1d0-xmtl)
53032 pyxxga=c0*((xm1**2-xm2**2)/xm1)**3
53033 pyxxga=pyxxga*(2d0/3d0*(f1+f2)-13d0/12d0)**2
53034
53035 RETURN
53036 END
53037
53038C*********************************************************************
53039
53040C...PYX2XG
53041C...Calculates the decay rate for ino -> ino + gauge boson.
53042
53043 FUNCTION pyx2xg(C1,XM1,XM2,XM3,GX2,GLR)
53044
53045C...Double precision and integer declarations.
53046 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53047 IMPLICIT INTEGER(I-N)
53048 INTEGER PYK,PYCHGE,PYCOMP
53049
53050C...Local variables.
53051 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53052 DOUBLE PRECISION XL,PYLAMF,C1
53053 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53054
53055 xmi2=xm1**2
53056 xmi3=abs(xm1**3)
53057 xmj2=xm2**2
53058 xmv2=xm3**2
53059 xl=pylamf(xmi2,xmj2,xmv2)
53060 pyx2xg=c1/8d0/xmi3*sqrt(xl)
53061 &*(gx2*(xl+3d0*xmv2*(xmi2+xmj2-xmv2))-
53062 &12d0*glr*xm1*xm2*xmv2)
53063
53064 RETURN
53065 END
53066
53067C*********************************************************************
53068
53069C...PYX2XH
53070C...Calculates the decay rate for ino -> ino + H.
53071
53072 FUNCTION pyx2xh(C1,XM1,XM2,XM3,GX2,GLR)
53073
53074C...Double precision and integer declarations.
53075 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53076 IMPLICIT INTEGER(I-N)
53077 INTEGER PYK,PYCHGE,PYCOMP
53078
53079C...Local variables.
53080 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53081 DOUBLE PRECISION XL,PYLAMF,C1
53082 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53083
53084 xmi2=xm1**2
53085 xmi3=abs(xm1**3)
53086 xmj2=xm2**2
53087 xmv2=xm3**2
53088 xl=pylamf(xmi2,xmj2,xmv2)
53089 pyx2xh=c1/8d0/xmi3*sqrt(xl)
53090 &*(gx2*(xmi2+xmj2-xmv2)+
53091 &4d0*glr*xm1*xm2)
53092
53093 RETURN
53094 END
53095
53096C*********************************************************************
53097
53098C...PYHEXT
53099C...Calculates the non-standard decay modes of the Higgs boson.
53100C...
53101C...Author: Stephen Mrenna
53102C...Last Update: April 2001
53103C......Allow complex values for Z,U, and V
53104
53105 SUBROUTINE pyhext(KFIN,XLAM,IDLAM,IKNT)
53106
53107C...Double precision and integer declarations.
53108 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53109 IMPLICIT INTEGER(I-N)
53110 INTEGER PYK,PYCHGE,PYCOMP
53111C...Parameter statement to help give large particle numbers.
53112 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
53113 &kexcit=4000000,kdimen=5000000)
53114C...Commonblocks.
53115 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
53116 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
53117 common/pypars/mstp(200),parp(200),msti(200),pari(200)
53118 common/pymssm/imss(0:99),rmss(0:99)
53119 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
53120 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
53121 SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/,/pyssmt/
53122
53123C...Local variables.
53124 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53125 COMPLEX*16 QIJ,RIJ,F21K,F12K
53126 INTEGER KFIN
53127 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53128 DOUBLE PRECISION XMI2,XMI3,XMJ2
53129 DOUBLE PRECISION PYLAMF,XL,CF,EI
53130 INTEGER IDU,IFL
53131 DOUBLE PRECISION TANW,XW,AEM,C1,AS
53132 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53133 DOUBLE PRECISION XLAM(0:400)
53134 INTEGER IDLAM(400,3)
53135 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53136 INTEGER ITH(4)
53137 INTEGER KFNCHI(4),KFCCHI(2)
53138 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53139 DOUBLE PRECISION SR2
53140 DOUBLE PRECISION BETA,ALFA
53141 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53142 DOUBLE PRECISION PYALEM
53143 DOUBLE PRECISION AL,AR,ALR
53144 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53145 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53146 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53147 DATA ith/25,35,36,37/
53148 DATA etah/1d0,1d0,-1d0/
53149 DATA sr2/1.4142136d0/
53150 DATA kfnchi/1000022,1000023,1000025,1000035/
53151 DATA kfcchi/1000024,1000037/
53152
53153C...COUNT THE NUMBER OF DECAY MODES
53154 lknt=iknt
53155
53156 xmw=pmas(24,1)
53157 xmw2=xmw**2
53158 xmz=pmas(23,1)
53159 xw=paru(102)
53160 tanw = sqrt(xw/(1d0-xw))
53161 cw=sqrt(1d0-xw)
53162
53163C...1 - 4 DEPENDING ON Higgs species.
53164 ih=1
53165 IF(kfin.EQ.ith(2)) ih=2
53166 IF(kfin.EQ.ith(3)) ih=3
53167 IF(kfin.EQ.ith(4)) ih=4
53168
53169 xmi=pmas(kfin,1)
53170 xmi2=xmi**2
53171 axmi=abs(xmi)
53172 aem=pyalem(xmi2)
53173 c1=aem/xw
53174 xmi3=abs(xmi**3)
53175
53176 tanb=rmss(5)
53177 beta=atan(tanb)
53178 cbeta=cos(beta)
53179 sbeta=tanb*cbeta
53180 alfa=rmss(18)
53181 cosa=cos(alfa)
53182 sina=sin(alfa)
53183 atrit=rmss(16)
53184 atrib=rmss(15)
53185 atril=rmss(17)
53186 xmuz=-rmss(4)
53187
53188 DO 110 i=1,4
53189 DO 100 j=1,4
53190 zmixc(j,i)=dcmplx(zmix(j,i),zmixi(j,i))
53191 100 CONTINUE
53192 110 CONTINUE
53193 DO 130 i=1,2
53194 DO 120 j=1,2
53195 vmixc(j,i)=dcmplx(vmix(j,i),vmixi(j,i))
53196 umixc(j,i)=dcmplx(umix(j,i),umixi(j,i))
53197 120 CONTINUE
53198 130 CONTINUE
53199
53200
53201 IF(ih.EQ.4) GOTO 220
53202
53203C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53204C...H0_K -> CHI0_I + CHI0_J
53205 eh(2)=sina
53206 eh(1)=cosa
53207 eh(3)=cbeta
53208 dh(2)=cosa
53209 dh(1)=-sina
53210 dh(3)=sbeta
53211 DO 150 ij=1,4
53212 xmj=smz(ij)
53213 axmj=abs(xmj)
53214 DO 140 ik=1,ij
53215 xmk=smz(ik)
53216 axmk=abs(xmk)
53217 IF(axmi.GE.axmj+axmk) THEN
53218 lknt=lknt+1
53219 qij=zmixc(ik,3)*zmixc(ij,2)+
53220 & zmixc(ij,3)*zmixc(ik,2)-
53221 & tanw*(zmixc(ik,3)*zmixc(ij,1)+
53222 & zmixc(ij,3)*zmixc(ik,1))
53223 rij=zmixc(ik,4)*zmixc(ij,2)+
53224 & zmixc(ij,4)*zmixc(ik,2)-
53225 & tanw*(zmixc(ik,4)*zmixc(ij,1)+
53226 & zmixc(ij,4)*zmixc(ik,1))
53227 f21k=0.5d0*dconjg(qij*dh(ih)-rij*eh(ih))
53228 f12k=0.5d0*(qij*dh(ih)-rij*eh(ih))
53229C...SIGN OF MASSES I,J
53230 xml=xmk*etah(ih)
53231 gx2=abs(f12k)**2+abs(f21k)**2
53232 glr=dble(f12k*dconjg(f21k))
53233 xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,gx2,glr)
53234 IF(ij.EQ.ik) xlam(lknt)=xlam(lknt)*0.5d0
53235 idlam(lknt,1)=kfnchi(ij)
53236 idlam(lknt,2)=kfnchi(ik)
53237 idlam(lknt,3)=0
53238 ENDIF
53239 140 CONTINUE
53240 150 CONTINUE
53241
53242C...H0_K -> CHI+_I CHI-_J
53243 DO 170 ij=1,2
53244 xmj=smw(ij)
53245 axmj=abs(xmj)
53246 DO 160 ik=1,2
53247 xmk=smw(ik)
53248 axmk=abs(xmk)
53249 IF(axmi.GE.axmj+axmk) THEN
53250 lknt=lknt+1
53251 olpp=dconjg(vmixc(ij,1)*umixc(ik,2)*dh(ih) +
53252 & vmixc(ij,2)*umixc(ik,1)*eh(ih))/sr2
53253 orpp=(vmixc(ik,1)*umixc(ij,2)*dh(ih) +
53254 & vmixc(ik,2)*umixc(ij,1)*eh(ih))/sr2
53255 gx2=abs(olpp)**2+abs(orpp)**2
53256 glr=dble(olpp*dconjg(orpp))
53257 xml=xmk*etah(ih)
53258 xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,gx2,glr)
53259 idlam(lknt,1)=kfcchi(ij)
53260 idlam(lknt,2)=-kfcchi(ik)
53261 idlam(lknt,3)=0
53262 ENDIF
53263 160 CONTINUE
53264 170 CONTINUE
53265
53266C...HIGGS TO SFERMION SFERMION
53267 DO 200 ifl=1,16
53268 IF(ifl.GE.7.AND.ifl.LE.10) GOTO 200
53269 ij=ksusy1+ifl
53270 xmjl=pmas(pycomp(ij),1)
53271 xmjr=pmas(pycomp(ij+ksusy1),1)
53272 IF(axmi.GE.2d0*min(xmjl,xmjr)) THEN
53273 xmj=xmjl
53274 xmj2=xmj**2
53275 xl=pylamf(xmi2,xmj2,xmj2)
53276 xmf=pmas(ifl,1)
53277 ei=kchg(ifl,1)/3d0
53278 idu=2-mod(ifl,2)
53279
53280 IF(ih.EQ.1) THEN
53281 IF(idu.EQ.1) THEN
53282 ghll=-xmz/cw*(0.5d0+ei*xw)*sin(alfa+beta)+
53283 & xmf**2/xmw*sina/cbeta
53284 ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)+
53285 & xmf**2/xmw*sina/cbeta
53286 IF(ifl.EQ.5) THEN
53287 ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
53288 & atrib*sina)
53289 ELSEIF(ifl.EQ.15) THEN
53290 ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-
53291 & atril*sina)
53292 ELSE
53293 ghlr=0d0
53294 ENDIF
53295 ELSE
53296 ghll=xmz/cw*(0.5d0-ei*xw)*sin(alfa+beta)-
53297 & xmf**2/xmw*cosa/sbeta
53298 ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)-
53299 & xmf**2/xmw*cosa/sbeta
53300 IF(ifl.EQ.6) THEN
53301 ghlr=xmf/2d0/xmw/sbeta*(xmuz*sina-
53302 & atrit*cosa)
53303 ELSE
53304 ghlr=0d0
53305 ENDIF
53306 ENDIF
53307
53308 ELSEIF(ih.EQ.2) THEN
53309 IF(idu.EQ.1) THEN
53310 ghll=xmz/cw*(0.5d0+ei*xw)*cos(alfa+beta)-
53311 & xmf**2/xmw*cosa/cbeta
53312 ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
53313 & xmf**2/xmw*cosa/cbeta
53314 IF(ifl.EQ.5) THEN
53315 ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
53316 & atrib*cosa)
53317 ELSEIF(ifl.EQ.15) THEN
53318 ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+
53319 & atril*cosa)
53320 ELSE
53321 ghlr=0d0
53322 ENDIF
53323 ELSE
53324 ghll=-xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)-
53325 & xmf**2/xmw*sina/sbeta
53326 ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-
53327 & xmf**2/xmw*sina/sbeta
53328 IF(ifl.EQ.6) THEN
53329 ghlr=-xmf/2d0/xmw/sbeta*(xmuz*cosa+
53330 & atrit*sina)
53331 ELSE
53332 ghlr=0d0
53333 ENDIF
53334 ENDIF
53335
53336 ELSEIF(ih.EQ.3) THEN
53337 ghll=0d0
53338 ghrr=0d0
53339 ghlr=0d0
53340 IF(idu.EQ.1) THEN
53341 IF(ifl.EQ.5) THEN
53342 ghlr=xmf/2d0/xmw*(atrib*tanb-xmuz)
53343 ELSEIF(ifl.EQ.15) THEN
53344 ghlr=xmf/2d0/xmw*(atril*tanb-xmuz)
53345 ENDIF
53346 ELSE
53347 IF(ifl.EQ.6) THEN
53348 ghlr=xmf/2d0/xmw*(atrit/tanb-xmuz)
53349 ENDIF
53350 ENDIF
53351 ENDIF
53352 IF(ih.EQ.3) GOTO 180
53353
53354 al=sfmix(ifl,1)**2
53355 ar=sfmix(ifl,2)**2
53356 alr=sfmix(ifl,1)*sfmix(ifl,2)
53357 IF(ifl.LE.6) THEN
53358 cf=3d0
53359 ELSE
53360 cf=1d0
53361 ENDIF
53362
53363 IF(axmi.GE.2d0*xmj) THEN
53364 lknt=lknt+1
53365 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53366 & (ghll*al+ghrr*ar
53367 & +2d0*ghlr*alr)**2
53368 idlam(lknt,1)=ij
53369 idlam(lknt,2)=-ij
53370 idlam(lknt,3)=0
53371 ENDIF
53372
53373 IF(axmi.GE.2d0*xmjr) THEN
53374 lknt=lknt+1
53375 al=sfmix(ifl,3)**2
53376 ar=sfmix(ifl,4)**2
53377 alr=sfmix(ifl,3)*sfmix(ifl,4)
53378 xmj=xmjr
53379 xmj2=xmj**2
53380 xl=pylamf(xmi2,xmj2,xmj2)
53381 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53382 & (ghll*al+ghrr*ar
53383 & +2d0*ghlr*alr)**2
53384 idlam(lknt,1)=ij+ksusy1
53385 idlam(lknt,2)=-(ij+ksusy1)
53386 idlam(lknt,3)=0
53387 ENDIF
53388 180 CONTINUE
53389
53390 IF(axmi.GE.xmjl+xmjr) THEN
53391 lknt=lknt+1
53392 al=sfmix(ifl,1)*sfmix(ifl,3)
53393 ar=sfmix(ifl,2)*sfmix(ifl,4)
53394 alr=sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,2)*sfmix(ifl,3)
53395 xmj=xmjr
53396 xmj2=xmj**2
53397 xl=pylamf(xmi2,xmj2,xmjl**2)
53398 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53399 & (ghll*al+ghrr*ar)**2
53400 idlam(lknt,1)=ij
53401 idlam(lknt,2)=-(ij+ksusy1)
53402 idlam(lknt,3)=0
53403 lknt=lknt+1
53404 idlam(lknt,1)=-ij
53405 idlam(lknt,2)=ij+ksusy1
53406 idlam(lknt,3)=0
53407 xlam(lknt)=xlam(lknt-1)
53408 ENDIF
53409 ENDIF
53410 190 CONTINUE
53411 200 CONTINUE
53412 210 CONTINUE
53413
53414 GOTO 270
53415 220 CONTINUE
53416
53417C...H+ -> CHI+_I + CHI0_J
53418 DO 240 ij=1,4
53419 xmj=smz(ij)
53420 axmj=abs(xmj)
53421 xmj2=xmj**2
53422 DO 230 ik=1,2
53423 xmk=smw(ik)
53424 axmk=abs(xmk)
53425 IF(axmi.GE.axmj+axmk) THEN
53426 lknt=lknt+1
53427 olpp=cbeta*dconjg(zmixc(ij,4)*vmixc(ik,1)+(zmixc(ij,2)+
53428 & zmixc(ij,1)*tanw)*vmixc(ik,2)/sr2)
53429 orpp=sbeta*(zmixc(ij,3)*umixc(ik,1)-
53430 & (zmixc(ij,2)+zmixc(ij,1)*tanw)*umixc(ik,2)/sr2)
53431 gx2=abs(olpp)**2+abs(orpp)**2
53432 glr=dble(olpp*dconjg(orpp))
53433 xlam(lknt)=pyh2xx(c1,xmi,xmj,-xmk,gx2,glr)
53434 idlam(lknt,1)=kfnchi(ij)
53435 idlam(lknt,2)=kfcchi(ik)
53436 idlam(lknt,3)=0
53437 ENDIF
53438 230 CONTINUE
53439 240 CONTINUE
53440
53441 gl=-xmw/sr2*(sin(2d0*beta)-pmas(6,1)**2/tanb/xmw2)
53442 gr=-pmas(6,1)/sr2/xmw*(xmuz-atrit/tanb)
53443 al=0d0
53444 ar=0d0
53445 cf=3d0
53446
53447C...H+ -> T_1 B_1~
53448 xm1=pmas(pycomp(ksusy1+6),1)
53449 xm2=pmas(pycomp(ksusy1+5),1)
53450 IF(xmi.GE.xm1+xm2) THEN
53451 xl=pylamf(xmi2,xm1**2,xm2**2)
53452 lknt=lknt+1
53453 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53454 & (gl*sfmix(6,1)*sfmix(5,1)+gr*sfmix(6,2)*sfmix(5,1))**2
53455 idlam(lknt,1)=ksusy1+6
53456 idlam(lknt,2)=-(ksusy1+5)
53457 idlam(lknt,3)=0
53458 ENDIF
53459
53460C...H+ -> T_2 B_1~
53461 xm1=pmas(pycomp(ksusy2+6),1)
53462 xm2=pmas(pycomp(ksusy1+5),1)
53463 IF(xmi.GE.xm1+xm2) THEN
53464 xl=pylamf(xmi2,xm1**2,xm2**2)
53465 lknt=lknt+1
53466 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53467 & (gl*sfmix(6,3)*sfmix(5,1)+gr*sfmix(6,4)*sfmix(5,1))**2
53468 idlam(lknt,1)=ksusy2+6
53469 idlam(lknt,2)=-(ksusy1+5)
53470 idlam(lknt,3)=0
53471 ENDIF
53472
53473C...H+ -> T_1 B_2~
53474 xm1=pmas(pycomp(ksusy1+6),1)
53475 xm2=pmas(pycomp(ksusy2+5),1)
53476 IF(xmi.GE.xm1+xm2) THEN
53477 xl=pylamf(xmi2,xm1**2,xm2**2)
53478 lknt=lknt+1
53479 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53480 & (gl*sfmix(6,1)*sfmix(5,3)+gr*sfmix(6,2)*sfmix(5,3))**2
53481 idlam(lknt,1)=ksusy1+6
53482 idlam(lknt,2)=-(ksusy2+5)
53483 idlam(lknt,3)=0
53484 ENDIF
53485
53486C...H+ -> T_2 B_2~
53487 xm1=pmas(pycomp(ksusy2+6),1)
53488 xm2=pmas(pycomp(ksusy2+5),1)
53489 IF(xmi.GE.xm1+xm2) THEN
53490 xl=pylamf(xmi2,xm1**2,xm2**2)
53491 lknt=lknt+1
53492 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*
53493 & (gl*sfmix(6,3)*sfmix(5,3)+gr*sfmix(6,4)*sfmix(5,3))**2
53494 idlam(lknt,1)=ksusy2+6
53495 idlam(lknt,2)=-(ksusy2+5)
53496 idlam(lknt,3)=0
53497 ENDIF
53498
53499C...H+ -> UL DL~
53500 gl=-xmw/sr2*sin(2d0*beta)
53501 DO 250 ij=1,3,2
53502 xm1=pmas(pycomp(ksusy1+ij),1)
53503 xm2=pmas(pycomp(ksusy1+ij+1),1)
53504 IF(xmi.GE.xm1+xm2) THEN
53505 xl=pylamf(xmi2,xm1**2,xm2**2)
53506 lknt=lknt+1
53507 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2
53508 idlam(lknt,1)=-(ksusy1+ij)
53509 idlam(lknt,2)=ksusy1+ij+1
53510 idlam(lknt,3)=0
53511 ENDIF
53512 250 CONTINUE
53513
53514C...H+ -> EL~ NUL
53515 cf=1d0
53516 DO 260 ij=11,13,2
53517 xm1=pmas(pycomp(ksusy1+ij),1)
53518 xm2=pmas(pycomp(ksusy1+ij+1),1)
53519 IF(xmi.GE.xm1+xm2) THEN
53520 xl=pylamf(xmi2,xm1**2,xm2**2)
53521 lknt=lknt+1
53522 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2
53523 idlam(lknt,1)=-(ksusy1+ij)
53524 idlam(lknt,2)=ksusy1+ij+1
53525 idlam(lknt,3)=0
53526 ENDIF
53527 260 CONTINUE
53528
53529C...H+ -> TAU1 NUTAUL
53530 xm1=pmas(pycomp(ksusy1+15),1)
53531 xm2=pmas(pycomp(ksusy1+16),1)
53532 IF(xmi.GE.xm1+xm2) THEN
53533 xl=pylamf(xmi2,xm1**2,xm2**2)
53534 lknt=lknt+1
53535 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2*sfmix(15,1)**2
53536 idlam(lknt,1)=-(ksusy1+15)
53537 idlam(lknt,2)= ksusy1+16
53538 idlam(lknt,3)=0
53539 ENDIF
53540
53541C...H+ -> TAU2 NUTAUL
53542 xm1=pmas(pycomp(ksusy2+15),1)
53543 xm2=pmas(pycomp(ksusy1+16),1)
53544 IF(xmi.GE.xm1+xm2) THEN
53545 xl=pylamf(xmi2,xm1**2,xm2**2)
53546 lknt=lknt+1
53547 xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*gl**2*sfmix(15,3)**2
53548 idlam(lknt,1)=-(ksusy2+15)
53549 idlam(lknt,2)= ksusy1+16
53550 idlam(lknt,3)=0
53551 ENDIF
53552
53553 270 CONTINUE
53554 iknt=lknt
53555 xlam(0)=0d0
53556 DO 280 i=1,iknt
53557 IF(xlam(i).LE.0d0) xlam(i)=0d0
53558 xlam(0)=xlam(0)+xlam(i)
53559 280 CONTINUE
53560 IF(xlam(0).EQ.0d0) xlam(0)=1d-6
53561
53562 RETURN
53563 END
53564
53565C*********************************************************************
53566
53567C...PYH2XX
53568C...Calculates the decay rate for a Higgs to an ino pair.
53569
53570 FUNCTION pyh2xx(C1,XM1,XM2,XM3,GX2,GLR)
53571
53572C...Double precision and integer declarations.
53573 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53574 IMPLICIT INTEGER(I-N)
53575 INTEGER PYK,PYCHGE,PYCOMP
53576C...Commonblocks.
53577 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
53578 SAVE /pydat1/
53579
53580C...Local variables.
53581 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53582 DOUBLE PRECISION XL,PYLAMF,C1
53583 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53584
53585 xmi2=xm1**2
53586 xmi3=abs(xm1**3)
53587 xmj2=xm2**2
53588 xmk2=xm3**2
53589 xl=pylamf(xmi2,xmj2,xmk2)
53590 pyh2xx=c1/4d0/xmi3*sqrt(xl)
53591 &*(gx2*(xmi2-xmj2-xmk2)-
53592 &4d0*glr*xm3*xm2)
53593 IF(pyh2xx.LT.0d0) pyh2xx=0d0
53594
53595 RETURN
53596 END
53597
53598C*********************************************************************
53599
53600C...PYGAUS
53601C...Integration by adaptive Gaussian quadrature.
53602C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53603
53604 FUNCTION pygaus(F, A, B, EPS)
53605
53606C...Double precision and integer declarations.
53607 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53608 IMPLICIT INTEGER(I-N)
53609 INTEGER PYK,PYCHGE,PYCOMP
53610
53611C...Local declarations.
53612 EXTERNAL f
53613 DOUBLE PRECISION F,W(12), X(12)
53614 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53615 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53616 DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/
53617 DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/
53618 DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/
53619 DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/
53620 DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/
53621 DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/
53622 DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/
53623 DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/
53624 DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/
53625 DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/
53626
53627C...The Gaussian quadrature algorithm.
53628 h = 0d0
53629 IF(b .EQ. a) GOTO 140
53630 const = 5d-3 / abs(b-a)
53631 bb = a
53632 100 CONTINUE
53633 aa = bb
53634 bb = b
53635 110 CONTINUE
53636 c1 = 0.5d0*(bb+aa)
53637 c2 = 0.5d0*(bb-aa)
53638 s8 = 0d0
53639 DO 120 i = 1, 4
53640 u = c2*x(i)
53641 s8 = s8 + w(i) * (f(c1+u) + f(c1-u))
53642 120 CONTINUE
53643 s16 = 0d0
53644 DO 130 i = 5, 12
53645 u = c2*x(i)
53646 s16 = s16 + w(i) * (f(c1+u) + f(c1-u))
53647 130 CONTINUE
53648 s16 = c2*s16
53649 IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN
53650 h = h + s16
53651 IF(bb .NE. b) GOTO 100
53652 ELSE
53653 bb = c1
53654 IF(1d0 + const*abs(c2) .NE. 1d0) GOTO 110
53655 h = 0d0
53656 CALL pyerrm(18,'(PYGAUS:) too high accuracy required')
53657 GOTO 140
53658 ENDIF
53659 140 CONTINUE
53660 pygaus = h
53661
53662 RETURN
53663 END
53664
53665C*********************************************************************
53666
53667C...PYGAU2
53668C...Integration by adaptive Gaussian quadrature.
53669C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53670C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53671
53672 FUNCTION pygau2(F, A, B, EPS)
53673
53674C...Double precision and integer declarations.
53675 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53676 IMPLICIT INTEGER(I-N)
53677 INTEGER PYK,PYCHGE,PYCOMP
53678
53679C...Local declarations.
53680 EXTERNAL f
53681 DOUBLE PRECISION F,W(12), X(12)
53682 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53683 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53684 DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/
53685 DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/
53686 DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/
53687 DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/
53688 DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/
53689 DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/
53690 DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/
53691 DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/
53692 DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/
53693 DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/
53694
53695C...The Gaussian quadrature algorithm.
53696 h = 0d0
53697 IF(b .EQ. a) GOTO 140
53698 const = 5d-3 / abs(b-a)
53699 bb = a
53700 100 CONTINUE
53701 aa = bb
53702 bb = b
53703 110 CONTINUE
53704 c1 = 0.5d0*(bb+aa)
53705 c2 = 0.5d0*(bb-aa)
53706 s8 = 0d0
53707 DO 120 i = 1, 4
53708 u = c2*x(i)
53709 s8 = s8 + w(i) * (f(c1+u) + f(c1-u))
53710 120 CONTINUE
53711 s16 = 0d0
53712 DO 130 i = 5, 12
53713 u = c2*x(i)
53714 s16 = s16 + w(i) * (f(c1+u) + f(c1-u))
53715 130 CONTINUE
53716 s16 = c2*s16
53717 IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN
53718 h = h + s16
53719 IF(bb .NE. b) GOTO 100
53720 ELSE
53721 bb = c1
53722 IF(1d0 + const*abs(c2) .NE. 1d0) GOTO 110
53723 h = 0d0
53724 CALL pyerrm(18,'(PYGAU2:) too high accuracy required')
53725 GOTO 140
53726 ENDIF
53727 140 CONTINUE
53728 pygau2 = h
53729
53730 RETURN
53731 END
53732
53733C*********************************************************************
53734
53735C...PYSIMP
53736C...Simpson formula for an integral.
53737
53738 FUNCTION pysimp(Y,X0,X1,N)
53739
53740C...Double precision and integer declarations.
53741 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53742 IMPLICIT INTEGER(I-N)
53743 INTEGER PYK,PYCHGE,PYCOMP
53744
53745C...Local variables.
53746 DOUBLE PRECISION Y,X0,X1,H,S
53747 dimension y(0:n)
53748
53749 s=0d0
53750 h=(x1-x0)/n
53751 DO 100 i=0,n-2,2
53752 s=s+y(i)+4d0*y(i+1)+y(i+2)
53753 100 CONTINUE
53754 pysimp=s*h/3d0
53755
53756 RETURN
53757 END
53758
53759C*********************************************************************
53760
53761C...PYLAMF
53762C...The standard lambda function.
53763
53764 FUNCTION pylamf(X,Y,Z)
53765
53766C...Double precision and integer declarations.
53767 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53768 IMPLICIT INTEGER(I-N)
53769 INTEGER PYK,PYCHGE,PYCOMP
53770
53771C...Local variables.
53772 DOUBLE PRECISION PYLAMF,X,Y,Z
53773
53774 pylamf=(x-(y+z))**2-4d0*y*z
53775 IF(pylamf.LT.0d0) pylamf=0d0
53776
53777 RETURN
53778 END
53779
53780C*********************************************************************
53781
53782C...PYTBDY
53783C...Generates 3-body decays of gauginos.
53784
53785 SUBROUTINE pytbdy(IDIN)
53786
53787C...Double precision and integer declarations.
53788 IMPLICIT DOUBLE PRECISION(a-h, o-z)
53789 IMPLICIT INTEGER(I-N)
53790 INTEGER PYK,PYCHGE,PYCOMP
53791C...Parameter statement to help give large particle numbers.
53792 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
53793 &kexcit=4000000,kdimen=5000000)
53794C...Commonblocks.
53795 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
53796 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
53797 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
53798C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53799C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53800 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
53801 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
53802C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53803 SAVE /pyjets/,/pydat1/,/pydat2/,/pyssmt/
53804
53805C...Local variables.
53806 DOUBLE PRECISION XM(5)
53807 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53808 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53809 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53810 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53811 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53812 DOUBLE PRECISION CPHI1,SPHI1
53813 DOUBLE PRECISION S23DEL,EPS
53814 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53815 parameter(r=0.61803399d0,c=1d0-r,tol=1d-3)
53816 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53817 INTEGER INOID(4)
53818 DATA inoid/22,23,25,35/
53819 DATA eps/1d-6/
53820
53821 id=idin
53822 iskip=1
53823 xm(1)=p(n+1,5)
53824 xm(2)=p(n+2,5)
53825 xm(3)=p(n+3,5)
53826 xm(5)=p(id,5)
53827
53828C...GENERATE S12
53829 s12min=(xm(1)+xm(2))**2
53830 s12max=(xm(5)-xm(3))**2
53831 yjaco1=s12max-s12min
53832
53833C...Initialize some parameters
53834 xw=paru(102)
53835 xw1=1d0-xw
53836 tanw=sqrt(xw/xw1)
53837 izid1=0
53838 iwid1=0
53839 izid2=0
53840 iwid2=0
53841
53842 ia=k(n+2,2)
53843 ja=k(n+3,2)
53844
53845C...Mrenna: check that we are indeed decaying a SUSY particle
53846 IF(iabs(k(id,2)).LT.ksusy1.OR.iabs(k(id,2)).GE.3000000) THEN
53847
53848 ELSE
53849 DO 100 i1=1,4
53850 IF(mod(k(n+1,2),ksusy1).EQ.inoid(i1)) izid1=i1
53851 IF(mod(k(id,2),ksusy1).EQ.inoid(i1)) izid2=i1
53852 100 CONTINUE
53853 IF(mod(k(n+1,2),ksusy1).EQ.24) iwid1=1
53854 IF(mod(k(n+1,2),ksusy1).EQ.37) iwid1=2
53855 IF(mod(k(id,2),ksusy1).EQ.24) iwid2=1
53856 IF(mod(k(id,2),ksusy1).EQ.37) iwid2=2
53857 zm12=xm(5)**2
53858 zm22=xm(1)**2
53859 ei=kchg(pycomp(iabs(ia)),1)/3d0
53860 t3i=sign(1d0,ei+1d-6)/2d0
53861 ENDIF
53862
53863 IF(max(abs(ia),abs(ja)).EQ.6) THEN
53864 iskip=0
53865 ELSEIF(izid1*izid2.NE.0) THEN
53866 sqmz=pmas(23,1)**2
53867 gmmz=pmas(23,1)*pmas(23,2)
53868 DO 110 i=1,4
53869 zmixc(izid1,i)=dcmplx(zmix(izid1,i),zmixi(izid1,i))
53870 zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
53871 110 CONTINUE
53872 olpp=(zmixc(izid1,3)*dconjg(zmixc(izid2,3))-
53873 & zmixc(izid1,4)*dconjg(zmixc(izid2,4)))/2d0
53874 orpp=dconjg(olpp)
53875 xll2=pmas(pycomp(ksusy1+iabs(ia)),1)**2
53876 xlr2=xll2
53877 xrr2=pmas(pycomp(ksusy2+iabs(ia)),1)**2
53878 xrl2=xrr2
53879 glij=(t3i*zmixc(izid1,2)-tanw*(t3i-ei)*zmixc(izid1,1))*
53880 & dconjg(t3i*zmixc(izid2,2)-tanw*(t3i-ei)*zmixc(izid2,1))
53881 grij=zmixc(izid1,1)*dconjg(zmixc(izid2,1))*(ei*tanw)**2
53882 xm1m2=smz(izid1)*smz(izid2)
53883 qlls=dcmplx((t3i-ei*xw)/xw1)*olpp
53884 qllu=-glij
53885 qlrs=-dcmplx((t3i-ei*xw)/xw1)*orpp
53886 qlrt=dconjg(glij)
53887 qrls=-dcmplx((ei*xw)/xw1)*olpp
53888 qrlt=grij
53889 qrrs=dcmplx((ei*xw)/xw1)*orpp
53890 qrru=-dconjg(grij)
53891 ELSEIF(izid1*iwid2.NE.0.OR.izid2*iwid1.NE.0) THEN
53892 IF(izid1.NE.0) THEN
53893 xm1m2=smz(izid1)*smw(iwid2)
53894 izid1=iwid2
53895 izid2=izid1
53896 ELSE
53897 xm1m2=smz(izid2)*smw(iwid1)
53898 izid1=iwid1
53899 ENDIF
53900 rt2i = 1d0/sqrt(2d0)
53901 sqmz=pmas(24,1)**2
53902 gmmz=pmas(24,1)*pmas(24,2)
53903 DO 120 i=1,2
53904 vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
53905 umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
53906 120 CONTINUE
53907 DO 130 i=1,4
53908 zmixc(izid2,i)=dcmplx(zmix(izid2,i),zmixi(izid2,i))
53909 130 CONTINUE
53910 qlls=(dconjg(zmixc(izid2,2))*vmixc(izid1,1)-
53911 & dconjg(zmixc(izid2,4))*vmixc(izid1,2)*rt2i)
53912 qlrs=(zmixc(izid2,2)*dconjg(umixc(izid1,1))+
53913 & zmixc(izid2,3)*dconjg(umixc(izid1,2))*rt2i)
53914 ej=kchg(iabs(ja),1)/3d0
53915 t3j=sign(1d0,ej+1d-6)/2d0
53916 qrls=dcmplx(0d0,0d0)
53917 qrlt=qrls
53918 qrrs=qrls
53919 qrru=qrls
53920 xrr2=1d6**2
53921 xrl2=xrr2
53922 xlr2 = pmas(pycomp(ksusy1+iabs(ja)),1)**2
53923 xll2 = pmas(pycomp(ksusy1+iabs(ia)),1)**2
53924 IF(mod(ia,2).EQ.0) THEN
53925 qllu=vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ei-t3i)*
53926 & tanw+zmixc(izid2,2)*t3i)
53927 qlrt=-dconjg(umixc(izid1,1))*(
53928 & zmixc(izid2,1)*(ej-t3j)*tanw+zmixc(izid2,2)*t3j)
53929 ELSE
53930 qllu=vmixc(izid1,1)*dconjg(zmixc(izid2,1)*(ej-t3j)*
53931 & tanw+zmixc(izid2,2)*t3j)
53932 qlrt=-dconjg(umixc(izid1,1))*(
53933 & zmixc(izid2,1)*(ei-t3i)*tanw+zmixc(izid2,2)*t3i)
53934 ENDIF
53935 ELSEIF(iwid1*iwid2.NE.0) THEN
53936 izid1=iwid1
53937 izid2=iwid2
53938 xm1m2=smw(iwid1)*smw(iwid2)
53939 sqmz=pmas(23,1)**2
53940 gmmz=pmas(23,1)*pmas(23,2)
53941 DO 140 i=1,2
53942 vmixc(izid1,i)=dcmplx(vmix(izid1,i),vmixi(izid1,i))
53943 umixc(izid1,i)=dcmplx(umix(izid1,i),umixi(izid1,i))
53944 vmixc(izid2,i)=dcmplx(vmix(izid2,i),vmixi(izid2,i))
53945 umixc(izid2,i)=dcmplx(umix(izid2,i),umixi(izid2,i))
53946 140 CONTINUE
53947 olpp=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))-
53948 & vmixc(izid2,2)*dconjg(vmixc(izid1,2))/2d0
53949 orpp=-umixc(izid1,1)*dconjg(umixc(izid2,1))-
53950 & umixc(izid1,2)*dconjg(umixc(izid2,2))/2d0
53951 qrls=-dcmplx(ei/xw1)*orpp
53952 qlls=dcmplx((t3i-xw*ei)/xw/xw1)*orpp
53953 qrrs=-dcmplx(ei/xw1)*olpp
53954 qlrs=dcmplx((t3i-xw*ei)/xw/xw1)*olpp
53955 IF(mod(ia,2).EQ.0) THEN
53956 xlr2=pmas(pycomp(ksusy1+iabs(ia)-1),1)**2
53957 qlrt=-umixc(izid2,1)*dconjg(umixc(izid1,1))*dcmplx(t3i/xw)
53958 ELSE
53959 xlr2=pmas(pycomp(ksusy1+iabs(ia)+1),1)**2
53960 qlrt=-vmixc(izid2,1)*dconjg(vmixc(izid1,1))*dcmplx(t3i/xw)
53961 ENDIF
53962 ELSEIF(mod(k(n+1,2),ksusy1).EQ.21.OR.mod(k(id,2),ksusy1).EQ.21)
53963 &THEN
53964 iskip=0
53965 ELSE
53966 iskip=0
53967 ENDIF
53968
53969 IF(iskip.NE.0) THEN
53970 wtmax=0d0
53971 DO 160 kt=1,100
53972 s12=s12min+yjaco1*(kt-1)/99
53973 s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)
53974 & *(s12+xm(3)**2-xm(5)**2)/(2d0*s12)
53975 s23df1=(s12-xm(2)**2-xm(1)**2)**2
53976 & -(2d0*xm(1)*xm(2))**2
53977 s23df2=(s12-xm(3)**2-xm(5)**2)**2
53978 & -(2d0*xm(3)*xm(5))**2
53979 s23df1=s23df1*eps
53980 s23df2=s23df2*eps
53981 s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*s12)
53982 s23del=s23del/eps
53983 s23min=s23ave-s23del
53984 s23max=s23ave+s23del
53985 yjaco2=s23max-s23min
53986 th=s12
53987 DO 150 ks=1,100
53988 s23=s23min+yjaco2*(ks-1)/99
53989 sh=s23
53990 uh=zm12+zm22-sh-th
53991 wu2 = (uh-zm12)*(uh-zm22)
53992 wt2 = (th-zm12)*(th-zm22)
53993 ws2 = xm1m2*sh
53994 propz2 = (sh-sqmz)**2 + gmmz**2
53995 propz=dcmplx(sh-sqmz,-gmmz)/dcmplx(propz2)
53996 qll=qlls*propz+qllu/dcmplx(uh-xll2)
53997 qlr=qlrs*propz+qlrt/dcmplx(th-xlr2)
53998 qrl=qrls*propz+qrlt/dcmplx(th-xrl2)
53999 qrr=qrrs*propz+qrru/dcmplx(uh-xrr2)
54000 wt0=-((abs(qll)**2+abs(qrr)**2)*wu2+
54001 & (abs(qrl)**2+abs(qlr)**2)*wt2+
54002 & 2d0*dble(qlr*dconjg(qll)+qrl*dconjg(qrr))*ws2)
54003 IF(wt0.GT.wtmax) wtmax=wt0
54004 150 CONTINUE
54005 160 CONTINUE
54006
54007 wtmax=wtmax*1.05d0
54008 ENDIF
54009
54010C...FIND S12*
54011 ax=s12min
54012 cx=s12max
54013 bx=s12min+0.5d0*yjaco1
54014 x0=ax
54015 x3=cx
54016 IF(abs(cx-bx).GT.abs(bx-ax))THEN
54017 x1=bx
54018 x2=bx+c*(cx-bx)
54019 ELSE
54020 x2=bx
54021 x1=bx-c*(bx-ax)
54022 ENDIF
54023
54024C...SOLVE FOR F1 AND F2
54025 s23df1=(x1-xm(2)**2-xm(1)**2)**2
54026 &-(2d0*xm(1)*xm(2))**2
54027 s23df2=(x1-xm(3)**2-xm(5)**2)**2
54028 &-(2d0*xm(3)*xm(5))**2
54029 s23df1=s23df1*eps
54030 s23df2=s23df2*eps
54031 s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x1)
54032 f1=-2d0*s23del/eps
54033 s23df1=(x2-xm(2)**2-xm(1)**2)**2
54034 &-(2d0*xm(1)*xm(2))**2
54035 s23df2=(x2-xm(3)**2-xm(5)**2)**2
54036 &-(2d0*xm(3)*xm(5))**2
54037 s23df1=s23df1*eps
54038 s23df2=s23df2*eps
54039 s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x2)
54040 f2=-2d0*s23del/eps
54041
54042 170 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2)))THEN
54043C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54044 IF(f2.LE.f1)THEN
54045 x0=x1
54046 x1=x2
54047 x2=r*x1+c*x3
54048 f1=f2
54049 s23df1=(x2-xm(2)**2-xm(1)**2)**2
54050 & -(2d0*xm(1)*xm(2))**2
54051 s23df2=(x2-xm(3)**2-xm(5)**2)**2
54052 & -(2d0*xm(3)*xm(5))**2
54053 s23df1=s23df1*eps
54054 s23df2=s23df2*eps
54055 s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x2)
54056 f2=-2d0*s23del/eps
54057 ELSE
54058 x3=x2
54059 x2=x1
54060 x1=r*x2+c*x0
54061 f2=f1
54062 s23df1=(x1-xm(2)**2-xm(1)**2)**2
54063 & -(2d0*xm(1)*xm(2))**2
54064 s23df2=(x1-xm(3)**2-xm(5)**2)**2
54065 & -(2d0*xm(3)*xm(5))**2
54066 s23df1=s23df1*eps
54067 s23df2=s23df2*eps
54068 s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*x1)
54069 f1=-2d0*s23del/eps
54070 ENDIF
54071 GOTO 170
54072 ENDIF
54073C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54074 IF(f1.LT.f2)THEN
54075 golden=-f1
54076 xmin=x1
54077 ELSE
54078 golden=-f2
54079 xmin=x2
54080 ENDIF
54081
54082 iknt=0
54083 180 s12=s12min+pyr(0)*yjaco1
54084 iknt=iknt+1
54085C...GENERATE S23
54086 s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)
54087 &*(s12+xm(3)**2-xm(5)**2)/(2d0*s12)
54088 s23df1=(s12-xm(2)**2-xm(1)**2)**2
54089 &-(2d0*xm(1)*xm(2))**2
54090 s23df2=(s12-xm(3)**2-xm(5)**2)**2
54091 &-(2d0*xm(3)*xm(5))**2
54092 s23df1=s23df1*eps
54093 s23df2=s23df2*eps
54094 s23del=sqrt(max(0d0,s23df1*s23df2))/(2d0*s12)
54095 s23del=s23del/eps
54096 s23min=s23ave-s23del
54097 s23max=s23ave+s23del
54098 yjaco2=s23max-s23min
54099 s23=s23min+pyr(0)*yjaco2
54100
54101C...CHECK THE SAMPLING
54102 IF(iknt.GT.100) THEN
54103 WRITE(mstu(11),*) ' IKNT > 100 IN PYTBDY '
54104 GOTO 190
54105 ENDIF
54106 IF(yjaco2.LT.pyr(0)*golden) GOTO 180
54107
54108 IF(iskip.EQ.0) GOTO 190
54109
54110 sh=s23
54111 th=s12
54112 uh=zm12+zm22-sh-th
54113
54114 wu2 = (uh-zm12)*(uh-zm22)
54115 wt2 = (th-zm12)*(th-zm22)
54116 ws2 = xm1m2*sh
54117 propz2 = (sh-sqmz)**2 + gmmz**2
54118 propz=dcmplx(sh-sqmz,-gmmz)/dcmplx(propz2)
54119
54120 qll=qlls*propz+qllu/dcmplx(uh-xll2)
54121 qlr=qlrs*propz+qlrt/dcmplx(th-xlr2)
54122 qrl=qrls*propz+qrlt/dcmplx(th-xrl2)
54123 qrr=qrrs*propz+qrru/dcmplx(uh-xrr2)
54124c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54125c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54126c &/DCMPLX(TH-XML2)
54127c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54128c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54129c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54130 wt=-((abs(qll)**2+abs(qrr)**2)*wu2+
54131 &(abs(qrl)**2+abs(qlr)**2)*wt2+
54132 &2d0*dble(qlr*dconjg(qll)+qrl*dconjg(qrr))*ws2)
54133
54134 IF(wt.LT.pyr(0)*wtmax) GOTO 180
54135 IF(wt.GT.wtmax) print*,' WT > WTMAX ',wt,wtmax
54136
54137 190 d3=(xm(5)**2+xm(3)**2-s12)/(2d0*xm(5))
54138 d1=(xm(5)**2+xm(1)**2-s23)/(2d0*xm(5))
54139 d2=xm(5)-d1-d3
54140 p1=sqrt(d1*d1-xm(1)**2)
54141 p2=sqrt(d2*d2-xm(2)**2)
54142 p3=sqrt(d3*d3-xm(3)**2)
54143 cthe1=2d0*pyr(0)-1d0
54144 ang1=2d0*pyr(0)*paru(1)
54145 cphi1=cos(ang1)
54146 sphi1=sin(ang1)
54147 arg=1d0-cthe1**2
54148 IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
54149 sthe1=sqrt(arg)
54150 p(n+1,1)=p1*sthe1*cphi1
54151 p(n+1,2)=p1*sthe1*sphi1
54152 p(n+1,3)=p1*cthe1
54153 p(n+1,4)=d1
54154
54155C...GET CPHI3
54156 ang3=2d0*pyr(0)*paru(1)
54157 cphi3=cos(ang3)
54158 sphi3=sin(ang3)
54159 cthe3=(p2**2-p1**2-p3**2)/2d0/p1/p3
54160 arg=1d0-cthe3**2
54161 IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0
54162 sthe3=sqrt(arg)
54163 p(n+3,1)=-p3*sthe3*cphi3*cthe1*cphi1
54164 &+p3*sthe3*sphi3*sphi1
54165 &+p3*cthe3*sthe1*cphi1
54166 p(n+3,2)=-p3*sthe3*cphi3*cthe1*sphi1
54167 &-p3*sthe3*sphi3*cphi1
54168 &+p3*cthe3*sthe1*sphi1
54169 p(n+3,3)=p3*sthe3*cphi3*sthe1
54170 &+p3*cthe3*cthe1
54171 p(n+3,4)=d3
54172
54173 DO 200 i=1,3
54174 p(n+2,i)=-p(n+1,i)-p(n+3,i)
54175 200 CONTINUE
54176 p(n+2,4)=d2
54177
54178 RETURN
54179 END
54180
54181
54182C*********************************************************************
54183
54184C...PYTECM
54185C...Finds the s-hat dependent eigenvalues of the inverse propagator
54186C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54187C...phase space generation. Extended to include techni-a meson, and
54188C...to return the width.
54189
54190 SUBROUTINE pytecm(SMIN,SMOU,WIDO,IOPT)
54191
54192C...Double precision and integer declarations.
54193 IMPLICIT DOUBLE PRECISION(a-h, o-z)
54194 IMPLICIT INTEGER(I-N)
54195 INTEGER PYK,PYCHGE,PYCOMP
54196C...Parameter statement to help give large particle numbers.
54197 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
54198 &kexcit=4000000,kdimen=5000000)
54199C...Commonblocks.
54200 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54201 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54202 common/pypars/mstp(200),parp(200),msti(200),pari(200)
54203 common/pytcsm/itcm(0:99),rtcm(0:99)
54204 SAVE /pydat1/,/pydat2/,/pypars/,/pytcsm/
54205
54206C...Local variables.
54207 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54208 &at(5,5),wi(5),fv1(5),fv2(5),fv3(5),sh,aem,tanw,ct2w,qupd,alprht,
54209 &far,fao,fzr,fzo,shr,r1,r2,s1,s2,wdtp(0:400),wdte(0:400,0:5),wx(5)
54210 INTEGER i,j,ierr
54211
54212 sh=smin
54213 shr=sqrt(sh)
54214 aem=pyalem(sh)
54215
54216 sinw=min(sqrt(paru(102)),1d0)
54217 cosw=sqrt(1d0-sinw**2)
54218 tanw=sinw/cosw
54219 ct2w=(1d0-2d0*paru(102))/(2d0*paru(102)/tanw)
54220 qupd=2d0*rtcm(2)-1d0
54221
54222 alprht=2.16d0*(3d0/dble(itcm(1)))
54223 far=sqrt(aem/alprht)
54224 fao=far*qupd
54225 fzr=far*ct2w
54226 fzo=-fao*tanw
54227 fzx=-far/rtcm(47)/(2d0*sinw*cosw)
54228 fwr=far/(2d0*sinw)
54229 fwx=-fwr/rtcm(47)
54230
54231 DO 110 i=1,5
54232 DO 100 j=1,5
54233 at(i,j)=0d0
54234 100 CONTINUE
54235 110 CONTINUE
54236
54237C...NC
54238 IF(iopt.EQ.1) THEN
54239 ar(1,1) = sh
54240 ar(2,2) = sh-pmas(23,1)**2
54241 ar(3,3) = sh-pmas(pycomp(ktechn+113),1)**2
54242 ar(4,4) = sh-pmas(pycomp(ktechn+223),1)**2
54243 ar(5,5) = sh-pmas(pycomp(ktechn+115),1)**2
54244 ar(1,2) = 0d0
54245 ar(2,1) = 0d0
54246 ar(1,3) = sh*far
54247 ar(3,1) = ar(1,3)
54248 ar(1,4) = sh*fao
54249 ar(4,1) = ar(1,4)
54250 ar(2,3) = sh*fzr
54251 ar(3,2) = ar(2,3)
54252 ar(2,4) = sh*fzo
54253 ar(4,2) = ar(2,4)
54254 ar(3,4) = 0d0
54255 ar(4,3) = 0d0
54256 ar(2,5) = sh*fzx
54257 ar(5,2) = ar(2,5)
54258 ar(1,5) = 0d0
54259 ar(5,1) = ar(1,5)
54260 ar(3,5) = 0d0
54261 ar(5,3) = ar(3,5)
54262 ar(4,5) = 0d0
54263 ar(5,4) = ar(4,5)
54264 CALL pywidt(23,sh,wdtp,wdte)
54265 at(2,2) = wdtp(0)*shr
54266 CALL pywidt(ktechn+113,sh,wdtp,wdte)
54267 at(3,3) = wdtp(0)*shr
54268 CALL pywidt(ktechn+223,sh,wdtp,wdte)
54269 at(4,4) = wdtp(0)*shr
54270 CALL pywidt(ktechn+115,sh,wdtp,wdte)
54271 at(5,5) = wdtp(0)*shr
54272 idim=5
54273C...CC
54274 ELSE
54275 ar(1,1) = sh-pmas(24,1)**2
54276 ar(2,2) = sh-pmas(pycomp(ktechn+213),1)**2
54277 ar(3,3) = sh-pmas(pycomp(ktechn+215),1)**2
54278 ar(1,2) = sh*fwr
54279 ar(2,1) = ar(1,2)
54280 ar(1,3) = sh*fwx
54281 ar(3,1) = ar(1,3)
54282 ar(2,3) = 0d0
54283 ar(3,2) = 0d0
54284 CALL pywidt(24,sh,wdtp,wdte)
54285 at(1,1) = wdtp(0)*shr
54286 CALL pywidt(ktechn+213,sh,wdtp,wdte)
54287 at(2,2) = wdtp(0)*shr
54288 CALL pywidt(ktechn+215,sh,wdtp,wdte)
54289 at(3,3) = wdtp(0)*shr
54290 idim=3
54291 ENDIF
54292 CALL pyeicg(idim,idim,ar,at,wr,wi,0,zr,zi,fv1,fv2,fv3,ierr)
54293
54294 imin=1
54295 sxmn=1d20
54296 DO 120 i=1,idim
54297 wx(i)=sqrt(abs(sh-wr(i)))
54298 wr(i)=abs(wr(i))
54299 IF(wr(i).LT.sxmn) THEN
54300 sxmn=wr(i)
54301 imin=i
54302 ENDIF
54303 120 CONTINUE
54304 smou=wx(imin)**2
54305 wido=wi(imin)/shr
54306
54307 RETURN
54308 END
54309C*********************************************************************
54310
54311C...PYXDIN
54312C...Universal Extra Dimensions Model (UED)
54313C...Initialize the xd masses and widths
54314C...M. ELKACIMI 4/03/2006
54315C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54316
54317 SUBROUTINE pyxdin
54318
54319C...Double precision and integer declarations.
54320 IMPLICIT DOUBLE PRECISION(a-h, o-z)
54321 IMPLICIT INTEGER(I-N)
54322 INTEGER PYK,PYCHGE,PYCOMP
54323C...Commonblocks.
54324 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54325 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
54326 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
54327C...UED Pythia common
54328 common/pypued/iued(0:99),rued(0:99)
54329
54330C...SAVE statements
54331 SAVE /pydat1/,/pydat3/,/pysubs/,/pypued/
54332
54333C...Print out some info about the UED model
54334 WRITE(mstu(11),7000)
54335 & ' ',
54336 & '********** PYXDIN: initialization of UED ******************',
54337 & ' ',
54338 & 'Universal Extra Dimensions (UED) switched on ',
54339 & ' ',
54340 & 'This implementation is courtesy of',
54341 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54342 & ' see [hep-ph/0602198] (Les Houches 2005) ',
54343 & ' ',
54344 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54345 & 'Dobrescu), with gravity-mediated decay widths calculated in',
54346 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54347 & 'radiative corrections to the KK masses from [hep/ph0204342]',
54348 & '(Cheng, Matchev, Schmaltz).'
54349 WRITE(mstu(11),7000)
54350 & ' ',
54351 & 'SM particles can propagate into one small extra dimension ',
54352 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54353 & 'graviton is further allowed to propagate into N = IUED(4)',
54354 & 'large (eV^-1) extra dimensions.'
54355 WRITE(mstu(11),7000)
54356 & ' ',
54357 & 'The switches and parameters for UED are:',
54358 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54359 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54360 & ' IUED(3): (D=5) number of quark flavours',
54361 & ' IUED(4): (D=6) number of large extra dimensions into',
54362 & ' which the graviton propagates',
54363 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54364 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54365 & ' ',
54366 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54367 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54368 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54369 & ' when IUED(5)=0',
54370 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54371 WRITE(mstu(11),7000)
54372 & ' ',
54373 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54374 & 'model, but is set through pmas(25,1).',
54375 & ' '
54376
54377C...Hardcoded switch, required by current implementation
54378 CALL pygive('MSTP(42)=0')
54379
54380C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54381 IF(iued(2).EQ.0) CALL pygive('MDCY(C5100022,1)=0')
54382
54383C...Calculated the radiative corrections to the KK particle masses
54384 CALL pyuedc
54385
54386C...Initialize the graviton mass
54387C...only if the KK particles decays gravitationally
54388 IF(iued(2).EQ.1) CALL pygram(0)
54389
54390 WRITE(mstu(11),7000)
54391 & '********** PYXDIN: UED initialization completed ***********'
54392
54393C...Format to use for comments
54394 7000 FORMAT(' * ',a)
54395
54396 RETURN
54397 END
54398C*********************************************************************
54399
54400C...PYUEDC
54401C...Auxiliary to PYXDIN
54402C...Mass kk states radiative corrections
54403C...Radiative corrections are included (hep/ph0204342)
54404
54405 SUBROUTINE pyuedc
54406
54407C...Double precision and integer declarations.
54408 IMPLICIT DOUBLE PRECISION(a-h, o-z)
54409 IMPLICIT INTEGER(I-N)
54410 INTEGER PYK,PYCHGE,PYCOMP
54411
54412 parameter(kkpart=25,kkfla=450)
54413
54414C...UED Pythia common
54415 common/pypued/iued(0:99),rued(0:99)
54416C...Pythia common: particles properties
54417 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54418C...Parameters.
54419 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54420C...Decay information.
54421 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
54422C...Resonance width and secondary decay treatment.
54423 common/pyint4/mwid(500),wids(500,5)
54424 common/pypars/mstp(200),parp(200),msti(200),pari(200)
54425
54426C...Local variables
54427 DOUBLE PRECISION PI,QUP,QDW
54428 DOUBLE PRECISION WDTP,WDTE
54429 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54430 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54431 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54432 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54433 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54434 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54435 DOUBLE PRECISION SWW1,CWW1
54436 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54437 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54438 DOUBLE PRECISION SW21,CW21,SW021,CW021
54439 common/sw1/sw021,cw021
54440C...UED related declarations:
54441C...equivalences between ordered particles (451->475)
54442C...and UED particle code (5 000 000 + id)
54443 dimension iuedeq(475)
54444 DATA (iuedeq(i),i=451,475)/
54445C...Singlet quarks
54446 & 6100001,6100002,6100003,6100004,6100005,6100006,
54447C...Doublet quarks
54448 & 5100001,5100002,5100003,5100004,5100005,5100006,
54449C...Singlet leptons
54450 & 6100011,6100013,6100015,
54451C...Doublet leptons
54452 & 5100012,5100011,5100014,5100013,5100016,5100015,
54453C...Gauge boson KK excitations
54454 & 5100021,5100022,5100023,5100024/
54455
54456C...N.B. rinv=rued(1)
54457 IF(rued(1).LE.0.)THEN
54458 WRITE(mstu(11),*) 'PYUEDC: RINV < 0 : ',rued(1)
54459 WRITE(mstu(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54460 RETURN
54461 ENDIF
54462
54463 pi=dacos(-1.d0)
54464 rmz = pmas(23,1)
54465 rmz2 = rmz**2
54466 rmw = pmas(24,1)
54467 rmw2 = rmw**2
54468 alphem = paru(101)
54469 qup = 2./3.
54470 qdw = -1./3.
54471
54472c...qt is q-tilde, qs is q-star
54473c...strong coupling value
54474 q2 = rued(1)**2
54475 alphs=pyalps(q2)
54476
54477c...weak mixing angle
54478 sw2=paru(102)
54479 cw2=1d0-paru(102)
54480
54481c...for the mass corrections
54482 rmkk = rued(1)
54483 rmkk2 = rmkk**2
54484 zeta3= 1.2
54485
54486C... Either fix the cutoff scale LAMUED
54487 IF(iued(5).EQ.0)THEN
54488 loglam = dlog((rued(3)*(1./rued(1)))**2)
54489C... or the ratio LAMUED/RINV (=product Lambda*R)
54490 ELSEIF(iued(5).EQ.1)THEN
54491 loglam = dlog(rued(4)**2)
54492 ELSE
54493 WRITE(mstu(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54494 CALL pystop(6000)
54495 ENDIF
54496
54497C...Calculate the radiative corrections for the UED KK masses
54498 IF(iued(6).EQ.1)THEN
54499 rfact=1.d0
54500C...or induce a minute mass difference
54501C...keeping the UED KK mass values nearly equal to 1/R
54502 ELSEIF(iued(6).EQ.0)THEN
54503 rfact=0.01d0
54504 ELSE
54505 WRITE(mstu(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54506 CALL pystop(6001)
54507 ENDIF
54508
54509c...Take into account only the strong interactions:
54510
54511c...The space bulk corrections :
54512 dsmg2 = rmkk2*(-1.5)*(alphs/4./pi)*zeta3/pi**2
54513c...The boundary terms:
54514 dbmg2 = rmkk2*(23./2.)*(alphs/4./pi)*loglam
54515
54516c...Mass corrections for fermions are extracted from
54517c...Phys. Rev. D66 036005(2002)9
54518 dbmqdo=rmkk*(3.*(alphs/4./pi)+27./16.*(alphem/4./pi/sw2)
54519 . +1./16.*(alphem/4./pi/cw2))*loglam
54520 dbmqu=rmkk*(3.*(alphs/4./pi)
54521 . +(alphem/4./pi/cw2))*loglam
54522 dbmqd=rmkk*(3.*(alphs/4./pi)
54523 . +0.25*(alphem/4./pi/cw2))*loglam
54524
54525 dbmldo=rmkk *((27./16.)*(alphem/4./pi/sw2)+9./16.*
54526 . (alphem/4./pi/cw2))*loglam
54527 dbmle=rmkk *(9./4.*(alphem/4./pi/cw2))*loglam
54528
54529c...Vector boson masss matrix diagonalization
54530 dbmb2 = rmkk2*(-1./6.)*(alphem/4./pi/cw2)*loglam
54531 dsmb2 = rmkk2*(-39./2.)*(alphem/4./pi**3/cw2)*zeta3
54532 dbma2 = rmkk2*(15./2.)*(alphem/4./pi/sw2)*loglam
54533 dsma2 = rmkk2*(-5./2.)*(alphem/4./pi**3/sw2)*zeta3
54534
54535c...Elements of the mass matrix
54536 a = rmz2*sw2 + dbmb2 + dsmb2
54537 b = rmz2*cw2 + dbma2 + dsma2
54538 c = rmz2*dsqrt(sw2*cw2)
54539 sqrdel = dsqrt( (a-b)**2 + 4*c**2 )
54540
54541c...Eigenvalues: corrections to X1 and Z1 masses
54542 dmb2 = (a+b-sqrdel)/2.
54543 dma2 = (a+b+sqrdel)/2.
54544
54545c...Rotation angles
54546 sww1 = 2*c
54547 cww1 = a-b-sqrdel
54548C...Weinberg angle
54549 sw21= sww1**2/(sww1**2 + cww1**2)
54550 cw21= 1. - sw21
54551
54552 sw021=sw21
54553 cw021=cw21
54554
54555c...Masses:
54556 rmgst = rmkk+rfact*(dsqrt(rmkk2 + dsmg2 + dbmg2)-rmkk)
54557
54558 rmdqst=rmkk+rfact*dbmqdo
54559 rmsqus=rmkk+rfact*dbmqu
54560 rmsqds=rmkk+rfact*dbmqd
54561
54562C...Note: MZ mass is included in ma2
54563 rmphst= rmkk+rfact*(dsqrt(rmkk2 + dmb2)-rmkk)
54564 rmzst = rmkk+rfact*(dsqrt(rmkk2 + dma2)-rmkk)
54565 rmwst = rmkk+rfact*(dsqrt(rmkk2 + dbma2 + dsma2 + rmw**2)-rmkk)
54566
54567 rmlsld=rmkk+rfact*dbmldo
54568 rmlsle=rmkk+rfact*dbmle
54569
54570 DO 100 ipart=1,5,2
54571 pmas(kkfla+ipart,1)=rmsqds
54572 100 CONTINUE
54573 DO 110 ipart=2,6,2
54574 pmas(kkfla+ipart,1)=rmsqus
54575 110 CONTINUE
54576 DO 120 ipart=7,12
54577 pmas(kkfla+ipart,1)=rmdqst
54578 120 CONTINUE
54579 DO 130 ipart=13,15
54580 pmas(kkfla+ipart,1)=rmlsle
54581 130 CONTINUE
54582 DO 140 ipart=16,21
54583 pmas(kkfla+ipart,1)=rmlsld
54584 140 CONTINUE
54585 pmas(kkfla+22,1)=rmgst
54586 pmas(kkfla+23,1)=rmphst
54587 pmas(kkfla+24,1)=rmzst
54588 pmas(kkfla+25,1)=rmwst
54589
54590 WRITE(mstu(11),7000) ' PYUEDC: ',
54591 & 'UED Mass Spectrum (GeV) :'
54592 WRITE(mstu(11),7100) ' m(d*_S,s*_S,b*_S) = ',rmsqds
54593 WRITE(mstu(11),7100) ' m(u*_S,c*_S,t*_S) = ',rmsqus
54594 WRITE(mstu(11),7100) ' m(q*_D) = ',rmdqst
54595 WRITE(mstu(11),7100) ' m(l*_S) = ',rmlsle
54596 WRITE(mstu(11),7100) ' m(l*_D) = ',rmlsld
54597 WRITE(mstu(11),7100) ' m(g*) = ',rmgst
54598 WRITE(mstu(11),7100) ' m(gamma*) = ',rmphst
54599 WRITE(mstu(11),7100) ' m(Z*) = ',rmzst
54600 WRITE(mstu(11),7100) ' m(W*) = ',rmwst
54601 WRITE(mstu(11),7000) ' '
54602
54603C...Initialize widths, branching ratios and life time
54604 DO 199 ipart=1,25
54605 kc=kkfla+ipart
54606 IF(mwid(kc).EQ.1.AND.mdcy(kc,1).EQ.1)THEN
54607 CALL pywidt(iuedeq(kc),pmas(kc,1)**2,wdtp,wdte)
54608 IF(wdtp(0).LE.0)THEN
54609 WRITE(mstu(11),*)
54610 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', kc
54611 WRITE(mstu(11),*) 'INITIAL VALUE IS TAKEN',pmas(kc,2)
54612 GOTO 199
54613 ELSE
54614 DO 180 idc=1,mdcy(kc,3)
54615 ic=idc+mdcy(kc,2)-1
54616 IF(mdme(ic,1).EQ.1.AND.wdtp(idc).GT.0.)THEN
54617C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54618 pmas(kc,4)=paru(3)/wdtp(idc)*1.d-12
54619 brat(ic)=wdtp(idc)/wdtp(0)
54620 ENDIF
54621 180 CONTINUE
54622 ENDIF
54623 ENDIF
54624 199 CONTINUE
54625
54626C...Format to use for comments
54627 7000 FORMAT(' * ',a)
54628 7100 FORMAT(' * ',a,f12.3)
54629
54630 END
54631C********************************************************************
54632C...PYXUED
54633C... Last change:
54634C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54635C... Original version:
54636C... M. El Kacimi
54637C... 05/07/2005
54638C Universal Extra Dimensions Subprocess cross sections
54639C The expressions used are from atl-com-phys-2005-003
54640C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54641C For each UED subprocess, the color flow used is the same
54642C as the equivalent QCD subprocess. Different configuration
54643C color flows are considered to have the same probability.
54644C
54645C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54646C by G.Azuelos and P.H.Beauchemin.
54647C
54648C This routine is called from pysigh.
54649
54650 SUBROUTINE pyxued(NCHN,SIGS)
54651
54652C...Double precision and integer declarations
54653 IMPLICIT DOUBLE PRECISION(a-h, o-z)
54654 IMPLICIT INTEGER(I-N)
54655C...
54656 INTEGER NGRDEC
54657 common/decmod/ngrdec
54658C...
54659 parameter(kkpart=25,kkfla=450)
54660C...Commonblocks
54661 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54662 common/pypars/mstp(200),parp(200),msti(200),pari(200)
54663 common/pyint1/mint(400),vint(400)
54664 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
54665 common/pysgcm/isub,isubsv,mmin1,mmax1,mmin2,mmax2,mmina,mmaxa,
54666 &kfac(2,-40:40),comfac,fack,faca,sh,th,uh,sh2,th2,uh2,sqm3,sqm4,
54667 &shr,sqpth,taup,be34,cth,x(2),sqmz,sqmw,gmmz,gmmw,
54668 &aem,as,xw,xw1,xwc,xwv,poll,polr,polll,polrr
54669 SAVE /pydat2/,/pyint1/,/pyint3/,/pypars/
54670C...UED Pythia common
54671 common/pypued/iued(0:99),rued(0:99)
54672C...Local arrays and complex variables
54673 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54674 + ,FAC1,XMNKK,XMUED,SIGS
54675 INTEGER NCHN
54676
54677C...Return if UED not switched on
54678 IF (iued(1).LE.0) THEN
54679 RETURN
54680 ENDIF
54681
54682C...Energy scale of the parton processus
54683C...taken equal to the mass of the final state kk
54684c Q2=XMNKK**2
54685
54686C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54687 xmnkk=pmas(kkfla+23,1)
54688
54689C...To compare the cross section with phys-pub-2005-03
54690C...(no radiative corrections),
54691C...take xmnkk=rinv and q2=rinv**2
54692c++lnk
54693C...n.b. (rinv=rued(1))
54694c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54695 IF(ngrdec.EQ.1)xmnkk=rued(1)
54696c--lnk
54697
54698 shat=vint(44)
54699 sp=shat
54700 that=vint(45)
54701 tp=that-xmnkk**2
54702 uhat=vint(46)
54703 up=uhat-xmnkk**2
54704 beta34=dsqrt(1.d0-4.d0*xmnkk**2/shat)
54705 pi=dacos(-1.d0)
54706c++lnk
54707c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54708 q2=rued(1)**2+(tp*up-rued(1)**4)/sp
54709
54710c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54711 IF(ngrdec.EQ.1)q2=rued(1)**2
54712c--lnk
54713
54714C...Strong coupling value
54715 alphas=pyalps(q2)
54716
54717 IF(isub.EQ.311)THEN
54718C...gg --> g* g*
54719 fac1=9./8.*alphas**2/(sp*tp*up)**2
54720 xmued=fac1*(xmnkk**4*(6.*tp**4+18.*tp**3*up+
54721 & 24.*tp**2*up**2+18.*tp*up**3+6.*up**4)
54722 & +xmnkk**2*(6.*tp**4*up+12.*tp**3*up**2+
54723 & 12.*tp**2*up**3+6*tp*up**4)
54724 & +2.*tp**6+6*tp**5*up+13*tp**4*up**2+
54725 & 15.*tp**3*up**3+13*tp**2*up**4+
54726 & 6.*tp*up**5+2.*up**6)
54727 nchn=nchn+1
54728 isig(nchn,1)=21
54729 isig(nchn,2)=21
54730C...Three color flow configurations (qcd g+g->g+g)
54731 xcol=pyr(0)
54732 IF(xcol.LE.1./3.)THEN
54733 isig(nchn,3)=1
54734 ELSEIF(xcol.LE.2./3.)THEN
54735 isig(nchn,3)=2
54736 ELSE
54737 isig(nchn,3)=3
54738 ENDIF
54739 sigh(nchn)=comfac*xmued
54740 ELSEIF(isub.EQ.312)THEN
54741C...q + g -> q*_D + g*, q*_S + g*
54742C...(the two channels have the same cross section)
54743 fac1=-1./36.*alphas**2/(sp*tp*up)**2
54744 xmued=fac1*(12.*sp*up**5+5.*sp**2*up**4+22.*sp**3*up**3+
54745 & 5.*sp**4*up**2+12.*sp**5*up)
54746 xmued=comfac*2.*xmued
54747
54748 DO 190 i=mmina,mmaxa
54749 IF(i.EQ.0.OR.iabs(i).GT.10) GOTO 190
54750 DO 180 isde=1,2
54751
54752 IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) GOTO 180
54753 IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) GOTO 180
54754 nchn=nchn+1
54755 isig(nchn,isde)=i
54756 isig(nchn,3-isde)=21
54757 isig(nchn,3)=1
54758 sigh(nchn)=xmued
54759 IF(pyr(0).GT.0.5)isig(nchn,3)=2
54760 180 CONTINUE
54761 190 CONTINUE
54762
54763 ELSEIF(isub.EQ.313)THEN
54764C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54765C...(the two channels have the same cross section)
54766C...qi and qj have the same charge sign
54767 DO 100 i=mmin1,mmax1
54768 ia=iabs(i)
54769 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 100
54770 DO 101 j=mmin2,mmax2
54771 ja=iabs(j)
54772 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).
54773 & eq.0) GOTO 101
54774 IF(j*i.LE.0)GOTO 101
54775 nchn=nchn+1
54776 isig(nchn,1)=i
54777 isig(nchn,2)=j
54778 IF(j.EQ.i)THEN
54779 fac1=1./72.*alphas**2/(tp*up)**2
54780 xmued=fac1*
54781 & (xmnkk**2*(8*tp**3+4./3.*tp**2*up+4./3.*tp*up**2
54782 & +8.*up**3)+8.*tp**4+56./3.*tp**3*up+
54783 & 20.*tp**2*up**2+56./3.*
54784 & tp*up**3+8.*up**4)
54785 sigh(nchn)=comfac*2.*xmued
54786 isig(nchn,3)=1
54787 IF(pyr(0).GT.0.5)isig(nchn,3)=2
54788 ELSE
54789 fac1=2./9.*alphas**2/tp**2
54790 xmued=fac1*(-xmnkk**2*sp+sp**2+0.25*tp**2)
54791 sigh(nchn)=comfac*2.*xmued
54792 isig(nchn,3)=1
54793 ENDIF
54794 101 CONTINUE
54795 100 CONTINUE
54796 ELSEIF(isub.EQ.314)THEN
54797C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54798C...(the two channels have the same cross section)
54799 nchn=nchn+1
54800 isig(nchn,1)=21
54801 isig(nchn,2)=21
54802 isig(nchn,3)=int(1.5+pyr(0))
54803
54804 fac1=5./6.*alphas**2/(sp*tp*up)**2
54805 xmued=fac1*(-xmnkk**4*(8.*tp*up**3+8.*tp**2*up**2+8.*tp**3*up
54806 + +4.*up**4+4*tp**4)
54807 + -xmnkk**2*(0.5*tp*up**4+4.*tp**2*up**3+15./2.*tp**3
54808 + *up**2+ 4.*tp**4*up)+tp*up**5-0.25*tp**2*up**4+
54809 + 2.*tp**3*up**3-0.25*tp**4*up**2+tp**5*up)
54810
54811 sigh(nchn)=comfac*xmued
54812C...has been multiplied by 5: all possible quark flavors in final state
54813
54814 ELSEIF(isub.EQ.315)THEN
54815C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54816C...(the two channels have the same cross section)
54817 DO 141 i=mmin1,mmax1
54818 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
54819 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 141
54820 DO 142 j=mmin2,mmax2
54821 IF(j.EQ.0.OR.abs(i).NE.abs(j).OR.i*j.GE.0) GOTO 142
54822 fac1=2./9.*alphas**2*1./(sp*tp)**2
54823 xmued=fac1*(xmnkk**2*sp*(4.*tp**2-sp*tp-sp**2)+
54824 & 4.*tp**4+3.*sp*tp**3+11./12.*tp**2*sp**2-
54825 & 2./3.*sp**3*tp+sp**4)
54826 nchn=nchn+1
54827 isig(nchn,1)=i
54828 isig(nchn,2)=-i
54829 isig(nchn,3)=1
54830 sigh(nchn)=comfac*2.*xmued
54831 142 CONTINUE
54832 141 CONTINUE
54833 ELSEIF(isub.EQ.316)THEN
54834C...q + qbar' -> q*_D + q*_Sbar'
54835 fac1=2./9.*alphas**2
54836 DO 300 i=mmin1,mmax1
54837 ia=iabs(i)
54838 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 300
54839 DO 301 j=mmin2,mmax2
54840 ja=iabs(j)
54841 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 301
54842 IF(j*i.GE.0.OR.ia.EQ.ja)GOTO 301
54843 nchn=nchn+1
54844 isig(nchn,1)=i
54845 isig(nchn,2)=j
54846 isig(nchn,3)=1
54847 fac1=2./9.*alphas**2/tp**2
54848 xmued=fac1*(-xmnkk**2*sp+sp**2+0.25*tp**2)
54849 sigh(nchn)=comfac*xmued
54850 301 CONTINUE
54851 300 CONTINUE
54852
54853 ELSEIF(isub.EQ.317)THEN
54854C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54855C...(the two channels have the same cross section)
54856 DO 400 i=mmin1,mmax1
54857 ia=iabs(i)
54858 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 400
54859 DO 401 j=mmin1,mmax1
54860 ja=iabs(j)
54861 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 401
54862 IF(j*i.GE.0.OR.ia.EQ.ja)GOTO 401
54863 nchn=nchn+1
54864 isig(nchn,1)=i
54865 isig(nchn,2)=j
54866 isig(nchn,3)=1
54867 fac1=1./18.*alphas**2/tp**2
54868 xmued=fac1*(4.*xmnkk**2*sp+4.*sp**2+8.*sp*tp+5*tp**2)
54869 sigh(nchn)=comfac*2.*xmued
54870 401 CONTINUE
54871 400 CONTINUE
54872 ELSEIF(isub.EQ.318)THEN
54873C...q + q' -> q*_D + q*_S'
54874 DO 500 i=mmin1,mmax1
54875 ia=iabs(i)
54876 IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) GOTO 500
54877 DO 501 j=mmin2,mmax2
54878 ja=iabs(j)
54879 IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) GOTO 501
54880 IF(j*i.LE.0)GOTO 501
54881 IF(ia.EQ.ja)THEN
54882 nchn=nchn+1
54883 isig(nchn,1)=i
54884 isig(nchn,2)=j
54885 isig(nchn,3)=int(1.5+pyr(0))
54886 fac1=1./36.*alphas**2/(tp*up)**2
54887 xmued=fac1*(-8.*xmnkk**2*(tp**3+tp**2*up+tp*up**2+up**3)
54888 & +8.*tp**4+4.*tp**2*up**2+8.*up**4)
54889 sigh(nchn)=comfac*xmued
54890 ELSE
54891 nchn=nchn+1
54892 isig(nchn,1)=i
54893 isig(nchn,2)=j
54894 isig(nchn,3)=1
54895 fac1=1./18.*alphas**2/tp**2
54896 xmued=fac1*(4.*xmnkk**2*sp+4.*sp**2+8.*sp*tp+5*tp**2)
54897 sigh(nchn)=comfac*2.*xmued
54898 ENDIF
54899 501 CONTINUE
54900 500 CONTINUE
54901 ELSEIF(isub.EQ.319)THEN
54902C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
54903C...(the two channels have the same cross section)
54904 DO 741 i=mmin1,mmax1
54905 IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.
54906 & kfac(1,i)*kfac(2,-i).EQ.0) GOTO 741
54907 DO 742 j=mmin2,mmax2
54908 IF(j.EQ.0.OR.iabs(j).NE.iabs(i).OR.j*i.GT.0) GOTO 742
54909 fac1=16./9.*alphas**2*1./(sp)**2
54910 xmued=fac1*(2.*xmnkk**2*sp+sp**2+2.*sp*tp+2.*tp**2)
54911 nchn=nchn+1
54912 isig(nchn,1)=i
54913 isig(nchn,2)=-i
54914 isig(nchn,3)=1
54915 sigh(nchn)=comfac*2.*xmued
54916 742 CONTINUE
54917 741 CONTINUE
54918
54919 ENDIF
54920
54921 RETURN
54922 END
54923C*********************************************************************
54924
54925C...PYGRAM
54926C...Universal Extra Dimensions Model (UED)
54927C...Computation of the Graviton mass.
54928
54929 SUBROUTINE pygram(IN)
54930
54931C...Double precision and integer declarations
54932 IMPLICIT DOUBLE PRECISION(a-h, o-z)
54933 IMPLICIT INTEGER(I-N)
54934
54935C...Pythia commonblocks
54936 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
54937 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
54938C...UED Pythia common
54939 common/pypued/iued(0:99),rued(0:99)
54940
54941C...Local variables
54942 INTEGER KCFLA,NMAX
54943 parameter(kcfla=450,nmax=5000)
54944 dimension yvec(5000),resvec(5000)
54945 common/intsav/ysav,ymax,resmax
54946 common/uedgra/xmplnk,xmd,rinv,ndim
54947 common/kappa/xkappa
54948
54949C...External function (used in call to PYGAUS)
54950 EXTERNAL pygraw
54951
54952C...SAVE statements
54953 SAVE /pydat1/,/pydat2/,/pypued/,/intsav/
54954
54955C...Initialization
54956 ndim=iued(4)
54957 rinv=rued(1)
54958 xmd=rued(2)
54959 pi=paru(1)
54960
54961C...Initialize for numerical integration
54962 xmplnk=2.4d+18
54963 xkappa=dsqrt(2.d0)/xmplnk
54964
54965C...For NDIM=2, compute graviton mass distribution numerically
54966 IF(ndim.EQ.2)THEN
54967
54968C... For first event: tabulate distribution of stepwise integrals:
54969C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
54970 IF(in.EQ.0)THEN
54971 resmax = 0d0
54972 ymax = 0d0
54973 DO 100 i=1,nmax
54974 ysav = (i-0.5)/dble(nmax)
54975 tol = 1d-6
54976C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
54977 resint = pygaus(pygraw,0d0,1d0,tol)
54978 yvec(i) = ysav
54979 resvec(i) = resint
54980C... Save max of distribution (for accept/reject below)
54981 IF(resint.GT.resmax)THEN
54982 resmax = resint
54983 ymax = yvec(i)
54984 ENDIF
54985 100 CONTINUE
54986 ENDIF
54987
54988C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
54989 pcujet=1d0
54990 kcgakk=kcfla+23
54991 xmgamk=pmas(kcgakk,1)
54992
54993C... Pick random graviton mass, accept according to stored integrals
54994 ammax=dsqrt(xmgamk**2-2d0*xmgamk*pcujet)
54995 110 rmg=ammax*pyr(0)
54996 x=rmg/xmgamk
54997
54998C... Bin enumeration starts at 1, but make sure always in range
54999 ibin=int(nmax*x)+1
55000 ibin=min(ibin,nmax)
55001 IF(resvec(ibin)/resmax.LT.pyr(0)) GOTO 110
55002
55003C... For NDIM=4 and 6, the analytical expression for the
55004C... graviton mass distribution integral is used.
55005 ELSEIF(ndim.EQ.4.OR.ndim.EQ.6)THEN
55006
55007C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55008 pcujet=1d0
55009
55010C... KK photon (?) compressed code and mass
55011 kcgakk=kcfla+23
55012 xmgamk=pmas(kcgakk,1)
55013
55014C... Find maximum of (dGamma/dMg)
55015 IF(in.EQ.0)THEN
55016 resmax=0d0
55017 ymax=0d0
55018 DO 120 i=1,nmax-1
55019 y=i/dble(nmax)
55020 resint=y**(ndim-3)*(1d0/(1d0-y**2))*(1d0+dcos(pi*y))
55021 IF(resint.GE.resmax)THEN
55022 resmax=resint
55023 ymax=y
55024 ENDIF
55025 120 CONTINUE
55026 ENDIF
55027
55028C... Pick random graviton mass, accept/reject
55029 ammax=dsqrt(xmgamk**2-2d0*xmgamk*pcujet)
55030 130 rmg=ammax*pyr(0)
55031 x=rmg/xmgamk
55032 dgadmg=x**(ndim-3)*(1./(1.-x**2))*(1.+dcos(pi*x))
55033 IF(dgadmg/resmax.LT.pyr(0)) GOTO 130
55034
55035C... If the user has not chosen N=2,4 or 6, STOP
55036 ELSE
55037 WRITE(mstu(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',ndim,
55038 & ' (MUST BE 2, 4, OR 6) '
55039 CALL pystop(6002)
55040 ENDIF
55041
55042C... Now store the sampled Mg
55043 pmas(39,1)=rmg
55044
55045 RETURN
55046 END
55047
55048C*********************************************************************
55049
55050C...PYGRAW
55051C...Universal Extra Dimensions Model (UED)
55052C...
55053C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55054C...
55055C...Integrand for the KK boson -> SM boson + graviton
55056C...graviton mass distribution (and gravity mediated total width),
55057C...which contains (see 0201300 and below for the full product)
55058C...the gravity mediated partial decay width Gamma(xx, yy)
55059C... i.e. GRADEN(YY)*PYWDKK(XXA)
55060C... where xx is exclusive to gravity
55061C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55062C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55063
55064 DOUBLE PRECISION FUNCTION pygraw(YIN)
55065
55066C...Double precision and integer declarations
55067 IMPLICIT DOUBLE PRECISION (a-h,o-z)
55068 IMPLICIT INTEGER (I-N)
55069
55070C...Pythia commonblocks
55071 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
55072
55073C...Local UED commonblocks and variables
55074 common/uedgra/xmplnk,xmd,rinv,ndim
55075 common/intsav/ysav,ymax,resmax
55076
55077C...SAVE statements
55078 SAVE /pydat1/,/intsav/
55079
55080C...External: Pythia's Gamma function
55081 EXTERNAL pygamm
55082
55083C...Pi
55084 pi=paru(1)
55085 pi2=pi*pi
55086
55087 ymin=1.d-9/rinv
55088 yy=ysav
55089 xx=dsqrt(1.-yy**2)*yin
55090 djac=(1.-ymin)*dsqrt(1.-yy**2)
55091 fac=2.*pi**((ndim-1.)/2.)*xmplnk**2*rinv**ndim/xmd**(ndim+2)
55092 xnd=(ndim-1.)/2.
55093 gammn=pygamm(xnd)
55094 fac=fac/gammn
55095 xxa=dsqrt(xx**2+yy**2)
55096 graden=4./pi2 * (yy**2/(1.-yy**2)**2)*(1.+dcos(pi*yy))
55097
55098 pygraw=djac*
55099 + fac*xx**(ndim-2)*graden*pywdkk(xxa)
55100
55101 RETURN
55102 END
55103C*********************************************************************
55104
55105C...PYWDKK
55106C...Universal Extra Dimensions Model (UED)
55107C...
55108C...Multiplied by the square modulus of a form factor
55109C...(see GRADEN in function PYGRAW)
55110C...PYWDKK is the KK boson -> SM boson + graviton
55111C...gravity mediated partial decay width Gamma(xx, yy)
55112C... where xx is exclusive to gravity
55113C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55114C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55115C...
55116C...N.B. The Feynman rules for the couplings of the graviton fields
55117C...to the UED fields are related to the corresponding couplings of
55118C...the graviton fields to the SM fields by the form factor.
55119
55120 DOUBLE PRECISION FUNCTION pywdkk(X)
55121
55122C...Double precision and integer declarations
55123 IMPLICIT DOUBLE PRECISION (a-h,o-z)
55124 IMPLICIT INTEGER (I-N)
55125
55126C...Pythia commonblocks
55127 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
55128 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
55129
55130C...Local UED commonblocks and variables
55131 common/uedgra/xmplnk,xmd,rinv,ndim
55132 common/kappa/xkappa
55133
55134C...SAVE statements
55135 SAVE /pydat1/,/pydat2/,/uedgra/,/kappa/
55136
55137 pi=paru(1)
55138
55139C...gamma* mass 473
55140 kcqkk=473
55141 xmnkk=pmas(kcqkk,1)
55142
55143C...Bosons partial width Macesanu hep-ph/0201300
55144 pywdkk=xkappa**2/(96.*pi)*xmnkk**3/x**4*
55145 + ((1.-x**2)**2*(1.+3.*x**2+6.*x**4))
55146
55147 RETURN
55148 END
55149
55150C*********************************************************************
55151
55152C...PYEIGC
55153C...Finds eigenvalues of a general complex matrix
55154C
55155C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55156C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55157C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55158C OF A COMPLEX GENERAL MATRIX.
55159C
55160C ON INPUT
55161C
55162C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55163C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55164C DIMENSION STATEMENT.
55165C
55166C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55167C
55168C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55169C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55170C
55171C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55172C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55173C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55174C
55175C ON OUTPUT
55176C
55177C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55178C RESPECTIVELY, OF THE EIGENVALUES.
55179C
55180C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55181C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55182C
55183C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55184C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55185C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55186C
55187C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55188C
55189C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55190C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55191C
55192C THIS VERSION DATED AUGUST 1983.
55193C
55194
55195 SUBROUTINE pyeicg(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55196
55197 INTEGER N,NM,IS1,IS2,IERR,MATZ
55198 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55199 x fv1(5),fv2(5),fv3(5)
55200 IF (n .LE. nm) GOTO 100
55201 ierr = 10 * n
55202 GOTO 120
55203C
55204 100 CALL pycbal(nm,n,ar,ai,is1,is2,fv1)
55205 CALL pycrth(nm,n,is1,is2,ar,ai,fv2,fv3)
55206 IF (matz .NE. 0) GOTO 110
55207C .......... FIND EIGENVALUES ONLY ..........
55208 CALL pycmqr(nm,n,is1,is2,ar,ai,wr,wi,ierr)
55209 GOTO 120
55210C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55211 110 CALL pycmq2(nm,n,is1,is2,fv2,fv3,ar,ai,wr,wi,zr,zi,ierr)
55212 IF (ierr .NE. 0) GOTO 120
55213 CALL pycba2(nm,n,is1,is2,fv1,n,zr,zi)
55214 120 RETURN
55215 END
55216
55217C*********************************************************************
55218
55219C...PYCMQR
55220C...Auxiliary to PYEICG.
55221C
55222C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55223C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55224C AND WILKINSON.
55225C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55226C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55227C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55228C
55229C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55230C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55231C
55232C ON INPUT
55233C
55234C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55235C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55236C DIMENSION STATEMENT.
55237C
55238C N IS THE ORDER OF THE MATRIX.
55239C
55240C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55241C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55242C SET LOW=1, IGH=N.
55243C
55244C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55245C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55246C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55247C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55248C THE REDUCTION BY CORTH, IF PERFORMED.
55249C
55250C ON OUTPUT
55251C
55252C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55253C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55254C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55255C EIGENVECTORS IS TO BE PERFORMED.
55256C
55257C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55258C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55259C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55260C FOR INDICES IERR+1,...,N.
55261C
55262C IERR IS SET TO
55263C ZERO FOR NORMAL RETURN,
55264C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55265C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55266C
55267C CALLS PYCDIV FOR COMPLEX DIVISION.
55268C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55269C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55270C
55271C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55272C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55273C
55274C THIS VERSION DATED AUGUST 1983.
55275C
55276
55277 SUBROUTINE pycmqr(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55278
55279 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55280 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55281 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55282 X PYTHAG
55283
55284 ierr = 0
55285 IF (low .EQ. igh) GOTO 130
55286C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55287 l = low + 1
55288C
55289 DO 120 i = l, igh
55290 ll = min0(i+1,igh)
55291 IF (hi(i,i-1) .EQ. 0.0d0) GOTO 120
55292 norm = pythag(hr(i,i-1),hi(i,i-1))
55293 yr = hr(i,i-1) / norm
55294 yi = hi(i,i-1) / norm
55295 hr(i,i-1) = norm
55296 hi(i,i-1) = 0.0d0
55297C
55298 DO 100 j = i, igh
55299 si = yr * hi(i,j) - yi * hr(i,j)
55300 hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
55301 hi(i,j) = si
55302 100 CONTINUE
55303C
55304 DO 110 j = low, ll
55305 si = yr * hi(j,i) + yi * hr(j,i)
55306 hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
55307 hi(j,i) = si
55308 110 CONTINUE
55309C
55310 120 CONTINUE
55311C .......... STORE ROOTS ISOLATED BY CBAL ..........
55312 130 DO 140 i = 1, n
55313 IF (i .GE. low .AND. i .LE. igh) GOTO 140
55314 wr(i) = hr(i,i)
55315 wi(i) = hi(i,i)
55316 140 CONTINUE
55317C
55318 en = igh
55319 tr = 0.0d0
55320 ti = 0.0d0
55321 itn = 30*n
55322C .......... SEARCH FOR NEXT EIGENVALUE ..........
55323 150 IF (en .LT. low) GOTO 320
55324 its = 0
55325 enm1 = en - 1
55326C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55327C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55328 160 DO 170 ll = low, en
55329 l = en + low - ll
55330 IF (l .EQ. low) GOTO 180
55331 tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
55332 x + dabs(hr(l,l)) + dabs(hi(l,l))
55333 tst2 = tst1 + dabs(hr(l,l-1))
55334 IF (tst2 .EQ. tst1) GOTO 180
55335 170 CONTINUE
55336C .......... FORM SHIFT ..........
55337 180 IF (l .EQ. en) GOTO 300
55338 IF (itn .EQ. 0) GOTO 310
55339 IF (its .EQ. 10 .OR. its .EQ. 20) GOTO 200
55340 sr = hr(en,en)
55341 si = hi(en,en)
55342 xr = hr(enm1,en) * hr(en,enm1)
55343 xi = hi(enm1,en) * hr(en,enm1)
55344 IF (xr .EQ. 0.0d0 .AND. xi .EQ. 0.0d0) GOTO 210
55345 yr = (hr(enm1,enm1) - sr) / 2.0d0
55346 yi = (hi(enm1,enm1) - si) / 2.0d0
55347 CALL pycsrt(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
55348 IF (yr * zzr + yi * zzi .GE. 0.0d0) GOTO 190
55349 zzr = -zzr
55350 zzi = -zzi
55351 190 CALL pycdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
55352 sr = sr - xr
55353 si = si - xi
55354 GOTO 210
55355C .......... FORM EXCEPTIONAL SHIFT ..........
55356 200 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
55357 si = 0.0d0
55358C
55359 210 DO 220 i = low, en
55360 hr(i,i) = hr(i,i) - sr
55361 hi(i,i) = hi(i,i) - si
55362 220 CONTINUE
55363C
55364 tr = tr + sr
55365 ti = ti + si
55366 its = its + 1
55367 itn = itn - 1
55368C .......... REDUCE TO TRIANGLE (ROWS) ..........
55369 lp1 = l + 1
55370C
55371 DO 240 i = lp1, en
55372 sr = hr(i,i-1)
55373 hr(i,i-1) = 0.0d0
55374 norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
55375 xr = hr(i-1,i-1) / norm
55376 wr(i-1) = xr
55377 xi = hi(i-1,i-1) / norm
55378 wi(i-1) = xi
55379 hr(i-1,i-1) = norm
55380 hi(i-1,i-1) = 0.0d0
55381 hi(i,i-1) = sr / norm
55382C
55383 DO 230 j = i, en
55384 yr = hr(i-1,j)
55385 yi = hi(i-1,j)
55386 zzr = hr(i,j)
55387 zzi = hi(i,j)
55388 hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
55389 hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
55390 hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
55391 hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
55392 230 CONTINUE
55393C
55394 240 CONTINUE
55395C
55396 si = hi(en,en)
55397 IF (si .EQ. 0.0d0) GOTO 250
55398 norm = pythag(hr(en,en),si)
55399 sr = hr(en,en) / norm
55400 si = si / norm
55401 hr(en,en) = norm
55402 hi(en,en) = 0.0d0
55403C .......... INVERSE OPERATION (COLUMNS) ..........
55404 250 DO 280 j = lp1, en
55405 xr = wr(j-1)
55406 xi = wi(j-1)
55407C
55408 DO 270 i = l, j
55409 yr = hr(i,j-1)
55410 yi = 0.0d0
55411 zzr = hr(i,j)
55412 zzi = hi(i,j)
55413 IF (i .EQ. j) GOTO 260
55414 yi = hi(i,j-1)
55415 hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
55416 260 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
55417 hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
55418 hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
55419 270 CONTINUE
55420C
55421 280 CONTINUE
55422C
55423 IF (si .EQ. 0.0d0) GOTO 160
55424C
55425 DO 290 i = l, en
55426 yr = hr(i,en)
55427 yi = hi(i,en)
55428 hr(i,en) = sr * yr - si * yi
55429 hi(i,en) = sr * yi + si * yr
55430 290 CONTINUE
55431C
55432 GOTO 160
55433C .......... A ROOT FOUND ..........
55434 300 wr(en) = hr(en,en) + tr
55435 wi(en) = hi(en,en) + ti
55436 en = enm1
55437 GOTO 150
55438C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55439C CONVERGED AFTER 30*N ITERATIONS ..........
55440 310 ierr = en
55441 320 RETURN
55442 END
55443
55444C*********************************************************************
55445
55446C...PYCMQ2
55447C...Auxiliary to PYEICG.
55448C
55449C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55450C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55451C AND WILKINSON.
55452C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55453C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55454C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55455C
55456C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55457C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55458C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55459C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55460C THIS GENERAL MATRIX TO HESSENBERG FORM.
55461C
55462C ON INPUT
55463C
55464C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55465C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55466C DIMENSION STATEMENT.
55467C
55468C N IS THE ORDER OF THE MATRIX.
55469C
55470C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55471C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55472C SET LOW=1, IGH=N.
55473C
55474C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55475C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55476C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55477C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55478C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55479C
55480C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55481C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55482C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55483C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55484C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55485C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55486C ARBITRARY.
55487C
55488C ON OUTPUT
55489C
55490C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55491C HAVE BEEN DESTROYED.
55492C
55493C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55494C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55495C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55496C FOR INDICES IERR+1,...,N.
55497C
55498C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55499C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55500C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55501C THE EIGENVECTORS HAS BEEN FOUND.
55502C
55503C IERR IS SET TO
55504C ZERO FOR NORMAL RETURN,
55505C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55506C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55507C
55508C CALLS PYCDIV FOR COMPLEX DIVISION.
55509C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55510C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55511C
55512C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55513C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55514C
55515C THIS VERSION DATED OCTOBER 1989.
55516C
55517C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55518C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55519C
55520
55521 SUBROUTINE pycmq2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55522
55523 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55524 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55525 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55526 X ORTR(5),ORTI(5)
55527 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55528 X PYTHAG
55529
55530 ierr = 0
55531C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55532 DO 110 j = 1, n
55533C
55534 DO 100 i = 1, n
55535 zr(i,j) = 0.0d0
55536 zi(i,j) = 0.0d0
55537 100 CONTINUE
55538 zr(j,j) = 1.0d0
55539 110 CONTINUE
55540C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55541C FROM THE INFORMATION LEFT BY CORTH ..........
55542 iend = igh - low - 1
55543 IF (iend.LT.0) GOTO 220
55544 IF (iend.EQ.0) GOTO 170
55545C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55546 DO 160 ii = 1, iend
55547 i = igh - ii
55548 IF (ortr(i) .EQ. 0.0d0 .AND. orti(i) .EQ. 0.0d0) GOTO 160
55549 IF (hr(i,i-1) .EQ. 0.0d0 .AND. hi(i,i-1) .EQ. 0.0d0) GOTO 160
55550C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55551 norm = hr(i,i-1) * ortr(i) + hi(i,i-1) * orti(i)
55552 ip1 = i + 1
55553C
55554 DO 120 k = ip1, igh
55555 ortr(k) = hr(k,i-1)
55556 orti(k) = hi(k,i-1)
55557 120 CONTINUE
55558C
55559 DO 150 j = i, igh
55560 sr = 0.0d0
55561 si = 0.0d0
55562C
55563 DO 130 k = i, igh
55564 sr = sr + ortr(k) * zr(k,j) + orti(k) * zi(k,j)
55565 si = si + ortr(k) * zi(k,j) - orti(k) * zr(k,j)
55566 130 CONTINUE
55567C
55568 sr = sr / norm
55569 si = si / norm
55570C
55571 DO 140 k = i, igh
55572 zr(k,j) = zr(k,j) + sr * ortr(k) - si * orti(k)
55573 zi(k,j) = zi(k,j) + sr * orti(k) + si * ortr(k)
55574 140 CONTINUE
55575C
55576 150 CONTINUE
55577C
55578 160 CONTINUE
55579C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55580 170 l = low + 1
55581C
55582 DO 210 i = l, igh
55583 ll = min0(i+1,igh)
55584 IF (hi(i,i-1) .EQ. 0.0d0) GOTO 210
55585 norm = pythag(hr(i,i-1),hi(i,i-1))
55586 yr = hr(i,i-1) / norm
55587 yi = hi(i,i-1) / norm
55588 hr(i,i-1) = norm
55589 hi(i,i-1) = 0.0d0
55590C
55591 DO 180 j = i, n
55592 si = yr * hi(i,j) - yi * hr(i,j)
55593 hr(i,j) = yr * hr(i,j) + yi * hi(i,j)
55594 hi(i,j) = si
55595 180 CONTINUE
55596C
55597 DO 190 j = 1, ll
55598 si = yr * hi(j,i) + yi * hr(j,i)
55599 hr(j,i) = yr * hr(j,i) - yi * hi(j,i)
55600 hi(j,i) = si
55601 190 CONTINUE
55602C
55603 DO 200 j = low, igh
55604 si = yr * zi(j,i) + yi * zr(j,i)
55605 zr(j,i) = yr * zr(j,i) - yi * zi(j,i)
55606 zi(j,i) = si
55607 200 CONTINUE
55608C
55609 210 CONTINUE
55610C .......... STORE ROOTS ISOLATED BY CBAL ..........
55611 220 DO 230 i = 1, n
55612 IF (i .GE. low .AND. i .LE. igh) GOTO 230
55613 wr(i) = hr(i,i)
55614 wi(i) = hi(i,i)
55615 230 CONTINUE
55616C
55617 en = igh
55618 tr = 0.0d0
55619 ti = 0.0d0
55620 itn = 30*n
55621C .......... SEARCH FOR NEXT EIGENVALUE ..........
55622 240 IF (en .LT. low) GOTO 430
55623 its = 0
55624 enm1 = en - 1
55625C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55626C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55627 250 DO 260 ll = low, en
55628 l = en + low - ll
55629 IF (l .EQ. low) GOTO 270
55630 tst1 = dabs(hr(l-1,l-1)) + dabs(hi(l-1,l-1))
55631 x + dabs(hr(l,l)) + dabs(hi(l,l))
55632 tst2 = tst1 + dabs(hr(l,l-1))
55633 IF (tst2 .EQ. tst1) GOTO 270
55634 260 CONTINUE
55635C .......... FORM SHIFT ..........
55636 270 IF (l .EQ. en) GOTO 420
55637 IF (itn .EQ. 0) GOTO 550
55638 IF (its .EQ. 10 .OR. its .EQ. 20) GOTO 290
55639 sr = hr(en,en)
55640 si = hi(en,en)
55641 xr = hr(enm1,en) * hr(en,enm1)
55642 xi = hi(enm1,en) * hr(en,enm1)
55643 IF (xr .EQ. 0.0d0 .AND. xi .EQ. 0.0d0) GOTO 300
55644 yr = (hr(enm1,enm1) - sr) / 2.0d0
55645 yi = (hi(enm1,enm1) - si) / 2.0d0
55646 CALL pycsrt(yr**2-yi**2+xr,2.0d0*yr*yi+xi,zzr,zzi)
55647 IF (yr * zzr + yi * zzi .GE. 0.0d0) GOTO 280
55648 zzr = -zzr
55649 zzi = -zzi
55650 280 CALL pycdiv(xr,xi,yr+zzr,yi+zzi,xr,xi)
55651 sr = sr - xr
55652 si = si - xi
55653 GOTO 300
55654C .......... FORM EXCEPTIONAL SHIFT ..........
55655 290 sr = dabs(hr(en,enm1)) + dabs(hr(enm1,en-2))
55656 si = 0.0d0
55657C
55658 300 DO 310 i = low, en
55659 hr(i,i) = hr(i,i) - sr
55660 hi(i,i) = hi(i,i) - si
55661 310 CONTINUE
55662C
55663 tr = tr + sr
55664 ti = ti + si
55665 its = its + 1
55666 itn = itn - 1
55667C .......... REDUCE TO TRIANGLE (ROWS) ..........
55668 lp1 = l + 1
55669C
55670 DO 330 i = lp1, en
55671 sr = hr(i,i-1)
55672 hr(i,i-1) = 0.0d0
55673 norm = pythag(pythag(hr(i-1,i-1),hi(i-1,i-1)),sr)
55674 xr = hr(i-1,i-1) / norm
55675 wr(i-1) = xr
55676 xi = hi(i-1,i-1) / norm
55677 wi(i-1) = xi
55678 hr(i-1,i-1) = norm
55679 hi(i-1,i-1) = 0.0d0
55680 hi(i,i-1) = sr / norm
55681C
55682 DO 320 j = i, n
55683 yr = hr(i-1,j)
55684 yi = hi(i-1,j)
55685 zzr = hr(i,j)
55686 zzi = hi(i,j)
55687 hr(i-1,j) = xr * yr + xi * yi + hi(i,i-1) * zzr
55688 hi(i-1,j) = xr * yi - xi * yr + hi(i,i-1) * zzi
55689 hr(i,j) = xr * zzr - xi * zzi - hi(i,i-1) * yr
55690 hi(i,j) = xr * zzi + xi * zzr - hi(i,i-1) * yi
55691 320 CONTINUE
55692C
55693 330 CONTINUE
55694C
55695 si = hi(en,en)
55696 IF (si .EQ. 0.0d0) GOTO 350
55697 norm = pythag(hr(en,en),si)
55698 sr = hr(en,en) / norm
55699 si = si / norm
55700 hr(en,en) = norm
55701 hi(en,en) = 0.0d0
55702 IF (en .EQ. n) GOTO 350
55703 ip1 = en + 1
55704C
55705 DO 340 j = ip1, n
55706 yr = hr(en,j)
55707 yi = hi(en,j)
55708 hr(en,j) = sr * yr + si * yi
55709 hi(en,j) = sr * yi - si * yr
55710 340 CONTINUE
55711C .......... INVERSE OPERATION (COLUMNS) ..........
55712 350 DO 390 j = lp1, en
55713 xr = wr(j-1)
55714 xi = wi(j-1)
55715C
55716 DO 370 i = 1, j
55717 yr = hr(i,j-1)
55718 yi = 0.0d0
55719 zzr = hr(i,j)
55720 zzi = hi(i,j)
55721 IF (i .EQ. j) GOTO 360
55722 yi = hi(i,j-1)
55723 hi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
55724 360 hr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
55725 hr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
55726 hi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
55727 370 CONTINUE
55728C
55729 DO 380 i = low, igh
55730 yr = zr(i,j-1)
55731 yi = zi(i,j-1)
55732 zzr = zr(i,j)
55733 zzi = zi(i,j)
55734 zr(i,j-1) = xr * yr - xi * yi + hi(j,j-1) * zzr
55735 zi(i,j-1) = xr * yi + xi * yr + hi(j,j-1) * zzi
55736 zr(i,j) = xr * zzr + xi * zzi - hi(j,j-1) * yr
55737 zi(i,j) = xr * zzi - xi * zzr - hi(j,j-1) * yi
55738 380 CONTINUE
55739C
55740 390 CONTINUE
55741C
55742 IF (si .EQ. 0.0d0) GOTO 250
55743C
55744 DO 400 i = 1, en
55745 yr = hr(i,en)
55746 yi = hi(i,en)
55747 hr(i,en) = sr * yr - si * yi
55748 hi(i,en) = sr * yi + si * yr
55749 400 CONTINUE
55750C
55751 DO 410 i = low, igh
55752 yr = zr(i,en)
55753 yi = zi(i,en)
55754 zr(i,en) = sr * yr - si * yi
55755 zi(i,en) = sr * yi + si * yr
55756 410 CONTINUE
55757C
55758 GOTO 250
55759C .......... A ROOT FOUND ..........
55760 420 hr(en,en) = hr(en,en) + tr
55761 wr(en) = hr(en,en)
55762 hi(en,en) = hi(en,en) + ti
55763 wi(en) = hi(en,en)
55764 en = enm1
55765 GOTO 240
55766C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55767C VECTORS OF UPPER TRIANGULAR FORM ..........
55768 430 norm = 0.0d0
55769C
55770 DO 440 i = 1, n
55771C
55772 DO 440 j = i, n
55773 tr = dabs(hr(i,j)) + dabs(hi(i,j))
55774 IF (tr .GT. norm) norm = tr
55775 440 CONTINUE
55776C
55777 IF (n .EQ. 1 .OR. norm .EQ. 0.0d0) GOTO 560
55778C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55779 DO 500 nn = 2, n
55780 en = n + 2 - nn
55781 xr = wr(en)
55782 xi = wi(en)
55783 hr(en,en) = 1.0d0
55784 hi(en,en) = 0.0d0
55785 enm1 = en - 1
55786C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55787 DO 490 ii = 1, enm1
55788 i = en - ii
55789 zzr = 0.0d0
55790 zzi = 0.0d0
55791 ip1 = i + 1
55792C
55793 DO 450 j = ip1, en
55794 zzr = zzr + hr(i,j) * hr(j,en) - hi(i,j) * hi(j,en)
55795 zzi = zzi + hr(i,j) * hi(j,en) + hi(i,j) * hr(j,en)
55796 450 CONTINUE
55797C
55798 yr = xr - wr(i)
55799 yi = xi - wi(i)
55800 IF (yr .NE. 0.0d0 .OR. yi .NE. 0.0d0) GOTO 470
55801 tst1 = norm
55802 yr = tst1
55803 460 yr = 0.01d0 * yr
55804 tst2 = norm + yr
55805 IF (tst2 .GT. tst1) GOTO 460
55806 470 CONTINUE
55807 CALL pycdiv(zzr,zzi,yr,yi,hr(i,en),hi(i,en))
55808C .......... OVERFLOW CONTROL ..........
55809 tr = dabs(hr(i,en)) + dabs(hi(i,en))
55810 IF (tr .EQ. 0.0d0) GOTO 490
55811 tst1 = tr
55812 tst2 = tst1 + 1.0d0/tst1
55813 IF (tst2 .GT. tst1) GOTO 490
55814 DO 480 j = i, en
55815 hr(j,en) = hr(j,en)/tr
55816 hi(j,en) = hi(j,en)/tr
55817 480 CONTINUE
55818C
55819 490 CONTINUE
55820C
55821 500 CONTINUE
55822C .......... END BACKSUBSTITUTION ..........
55823C .......... VECTORS OF ISOLATED ROOTS ..........
55824 DO 520 i = 1, n
55825 IF (i .GE. low .AND. i .LE. igh) GOTO 520
55826C
55827 DO 510 j = i, n
55828 zr(i,j) = hr(i,j)
55829 zi(i,j) = hi(i,j)
55830 510 CONTINUE
55831C
55832 520 CONTINUE
55833C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55834C VECTORS OF ORIGINAL FULL MATRIX.
55835C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55836 DO 540 jj = low, n
55837 j = n + low - jj
55838 m = min0(j,igh)
55839C
55840 DO 540 i = low, igh
55841 zzr = 0.0d0
55842 zzi = 0.0d0
55843C
55844 DO 530 k = low, m
55845 zzr = zzr + zr(i,k) * hr(k,j) - zi(i,k) * hi(k,j)
55846 zzi = zzi + zr(i,k) * hi(k,j) + zi(i,k) * hr(k,j)
55847 530 CONTINUE
55848C
55849 zr(i,j) = zzr
55850 zi(i,j) = zzi
55851 540 CONTINUE
55852C
55853 GOTO 560
55854C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55855C CONVERGED AFTER 30*N ITERATIONS ..........
55856 550 ierr = en
55857 560 RETURN
55858 END
55859
55860C*********************************************************************
55861
55862C...PYCDIV
55863C...Auxiliary to PYCMQR
55864C
55865C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55866C
55867
55868 SUBROUTINE pycdiv(AR,AI,BR,BI,CR,CI)
55869
55870 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55871 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55872
55873 s = dabs(br) + dabs(bi)
55874 ars = ar/s
55875 ais = ai/s
55876 brs = br/s
55877 bis = bi/s
55878 s = brs**2 + bis**2
55879 cr = (ars*brs + ais*bis)/s
55880 ci = (ais*brs - ars*bis)/s
55881 RETURN
55882 END
55883
55884C*********************************************************************
55885
55886C...PYCSRT
55887C...Auxiliary to PYCMQR
55888C
55889C (YR,YI) = COMPLEX DSQRT(XR,XI)
55890C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
55891C
55892
55893 SUBROUTINE pycsrt(XR,XI,YR,YI)
55894
55895 DOUBLE PRECISION XR,XI,YR,YI
55896 DOUBLE PRECISION S,TR,TI,PYTHAG
55897
55898 tr = xr
55899 ti = xi
55900 s = dsqrt(0.5d0*(pythag(tr,ti) + dabs(tr)))
55901 IF (tr .GE. 0.0d0) yr = s
55902 IF (ti .LT. 0.0d0) s = -s
55903 IF (tr .LE. 0.0d0) yi = s
55904 IF (tr .LT. 0.0d0) yr = 0.5d0*(ti/yi)
55905 IF (tr .GT. 0.0d0) yi = 0.5d0*(ti/yr)
55906 RETURN
55907 END
55908
55909 DOUBLE PRECISION FUNCTION pythag(A,B)
55910 DOUBLE PRECISION A,B
55911C
55912C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
55913C
55914 DOUBLE PRECISION P,R,S,T,U
55915 P = dmax1(dabs(a),dabs(b))
55916 IF (p .EQ. 0.0d0) GOTO 110
55917 r = (dmin1(dabs(a),dabs(b))/p)**2
55918 100 CONTINUE
55919 t = 4.0d0 + r
55920 IF (t .EQ. 4.0d0) GOTO 110
55921 s = r/t
55922 u = 1.0d0 + 2.0d0*s
55923 p = u*p
55924 r = (s/u)**2 * r
55925 GOTO 100
55926 110 pythag = p
55927 RETURN
55928 END
55929
55930C*********************************************************************
55931
55932C...PYCBAL
55933C...Auxiliary to PYEICG
55934C
55935C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
55936C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
55937C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
55938C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
55939C
55940C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
55941C EIGENVALUES WHENEVER POSSIBLE.
55942C
55943C ON INPUT
55944C
55945C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55946C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55947C DIMENSION STATEMENT.
55948C
55949C N IS THE ORDER OF THE MATRIX.
55950C
55951C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55952C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
55953C
55954C ON OUTPUT
55955C
55956C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55957C RESPECTIVELY, OF THE BALANCED MATRIX.
55958C
55959C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
55960C ARE EQUAL TO ZERO IF
55961C (1) I IS GREATER THAN J AND
55962C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
55963C
55964C SCALE CONTAINS INFORMATION DETERMINING THE
55965C PERMUTATIONS AND SCALING FACTORS USED.
55966C
55967C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
55968C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
55969C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
55970C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
55971C SCALE(J) = P(J), FOR J = 1,...,LOW-1
55972C = D(J,J) J = LOW,...,IGH
55973C = P(J) J = IGH+1,...,N.
55974C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
55975C THEN 1 TO LOW-1.
55976C
55977C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
55978C
55979C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
55980C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
55981C K,L HAVE BEEN REVERSED.)
55982C
55983C ARITHMETIC IS REAL THROUGHOUT.
55984C
55985C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55986C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55987C
55988C THIS VERSION DATED AUGUST 1983.
55989C
55990
55991 SUBROUTINE pycbal(NM,N,AR,AI,LOW,IGH,SCALE)
55992
55993 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
55994 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
55995 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
55996 LOGICAL NOCONV
55997
55998 radix = 16.0d0
55999C
56000 b2 = radix * radix
56001 k = 1
56002 l = n
56003 GOTO 150
56004C .......... IN-LINE PROCEDURE FOR ROW AND
56005C COLUMN EXCHANGE ..........
56006 100 scale(m) = j
56007 IF (j .EQ. m) GOTO 130
56008C
56009 DO 110 i = 1, l
56010 f = ar(i,j)
56011 ar(i,j) = ar(i,m)
56012 ar(i,m) = f
56013 f = ai(i,j)
56014 ai(i,j) = ai(i,m)
56015 ai(i,m) = f
56016 110 CONTINUE
56017C
56018 DO 120 i = k, n
56019 f = ar(j,i)
56020 ar(j,i) = ar(m,i)
56021 ar(m,i) = f
56022 f = ai(j,i)
56023 ai(j,i) = ai(m,i)
56024 ai(m,i) = f
56025 120 CONTINUE
56026C
56027 130 IF(iexc.EQ.1) GOTO 140
56028 IF(iexc.EQ.2) GOTO 180
56029C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56030C AND PUSH THEM DOWN ..........
56031 140 IF (l .EQ. 1) GOTO 320
56032 l = l - 1
56033C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56034 150 DO 170 jj = 1, l
56035 j = l + 1 - jj
56036C
56037 DO 160 i = 1, l
56038 IF (i .EQ. j) GOTO 160
56039 IF (ar(j,i) .NE. 0.0d0 .OR. ai(j,i) .NE. 0.0d0) GOTO 170
56040 160 CONTINUE
56041C
56042 m = l
56043 iexc = 1
56044 GOTO 100
56045 170 CONTINUE
56046C
56047 GOTO 190
56048C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56049C AND PUSH THEM LEFT ..........
56050 180 k = k + 1
56051C
56052 190 DO 210 j = k, l
56053C
56054 DO 200 i = k, l
56055 IF (i .EQ. j) GOTO 200
56056 IF (ar(i,j) .NE. 0.0d0 .OR. ai(i,j) .NE. 0.0d0) GOTO 210
56057 200 CONTINUE
56058C
56059 m = k
56060 iexc = 2
56061 GOTO 100
56062 210 CONTINUE
56063C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56064 DO 220 i = k, l
56065 220 scale(i) = 1.0d0
56066C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56067 230 noconv = .false.
56068C
56069 DO 310 i = k, l
56070 c = 0.0d0
56071 r = 0.0d0
56072C
56073 DO 240 j = k, l
56074 IF (j .EQ. i) GOTO 240
56075 c = c + dabs(ar(j,i)) + dabs(ai(j,i))
56076 r = r + dabs(ar(i,j)) + dabs(ai(i,j))
56077 240 CONTINUE
56078C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56079 IF (c .EQ. 0.0d0 .OR. r .EQ. 0.0d0) GOTO 310
56080 g = r / radix
56081 f = 1.0d0
56082 s = c + r
56083 250 IF (c .GE. g) GOTO 260
56084 f = f * radix
56085 c = c * b2
56086 GOTO 250
56087 260 g = r * radix
56088 270 IF (c .LT. g) GOTO 280
56089 f = f / radix
56090 c = c / b2
56091 GOTO 270
56092C .......... NOW BALANCE ..........
56093 280 IF ((c + r) / f .GE. 0.95d0 * s) GOTO 310
56094 g = 1.0d0 / f
56095 scale(i) = scale(i) * f
56096 noconv = .true.
56097C
56098 DO 290 j = k, n
56099 ar(i,j) = ar(i,j) * g
56100 ai(i,j) = ai(i,j) * g
56101 290 CONTINUE
56102C
56103 DO 300 j = 1, l
56104 ar(j,i) = ar(j,i) * f
56105 ai(j,i) = ai(j,i) * f
56106 300 CONTINUE
56107C
56108 310 CONTINUE
56109C
56110 IF (noconv) GOTO 230
56111C
56112 320 low = k
56113 igh = l
56114 RETURN
56115 END
56116
56117C*********************************************************************
56118
56119C...PYCBA2
56120C...Auxiliary to PYEICG.
56121C
56122C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56123C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56124C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56125C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56126C
56127C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56128C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56129C BALANCED MATRIX DETERMINED BY CBAL.
56130C
56131C ON INPUT
56132C
56133C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56134C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56135C DIMENSION STATEMENT.
56136C
56137C N IS THE ORDER OF THE MATRIX.
56138C
56139C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56140C
56141C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56142C AND SCALING FACTORS USED BY CBAL.
56143C
56144C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56145C
56146C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56147C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56148C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56149C
56150C ON OUTPUT
56151C
56152C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56153C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56154C IN THEIR FIRST M COLUMNS.
56155C
56156C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56157C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56158C
56159C THIS VERSION DATED AUGUST 1983.
56160C
56161
56162 SUBROUTINE pycba2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56163
56164 INTEGER I,J,K,M,N,II,NM,IGH,LOW
56165 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56166 DOUBLE PRECISION S
56167
56168 IF (m .EQ. 0) GOTO 150
56169 IF (igh .EQ. low) GOTO 120
56170C
56171 DO 110 i = low, igh
56172 s = scale(i)
56173C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56174C IF THE FOREGOING STATEMENT IS REPLACED BY
56175C S=1.0D0/SCALE(I). ..........
56176 DO 100 j = 1, m
56177 zr(i,j) = zr(i,j) * s
56178 zi(i,j) = zi(i,j) * s
56179 100 CONTINUE
56180C
56181 110 CONTINUE
56182C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56183C IGH+1 STEP 1 UNTIL N DO -- ..........
56184 120 DO 140 ii = 1, n
56185 i = ii
56186 IF (i .GE. low .AND. i .LE. igh) GOTO 140
56187 IF (i .LT. low) i = low - ii
56188 k = scale(i)
56189 IF (k .EQ. i) GOTO 140
56190C
56191 DO 130 j = 1, m
56192 s = zr(i,j)
56193 zr(i,j) = zr(k,j)
56194 zr(k,j) = s
56195 s = zi(i,j)
56196 zi(i,j) = zi(k,j)
56197 zi(k,j) = s
56198 130 CONTINUE
56199C
56200 140 CONTINUE
56201C
56202 150 RETURN
56203 END
56204
56205C*********************************************************************
56206
56207C...PYCRTH
56208C...Auxiliary to PYEICG.
56209C
56210C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56211C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56212C BY MARTIN AND WILKINSON.
56213C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56214C
56215C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56216C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56217C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56218C UNITARY SIMILARITY TRANSFORMATIONS.
56219C
56220C ON INPUT
56221C
56222C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56223C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56224C DIMENSION STATEMENT.
56225C
56226C N IS THE ORDER OF THE MATRIX.
56227C
56228C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56229C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56230C SET LOW=1, IGH=N.
56231C
56232C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56233C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56234C
56235C ON OUTPUT
56236C
56237C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56238C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56239C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56240C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56241C HESSENBERG MATRIX.
56242C
56243C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56244C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56245C
56246C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56247C
56248C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56249C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56250C
56251C THIS VERSION DATED AUGUST 1983.
56252C
56253
56254 SUBROUTINE pycrth(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56255
56256 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56257 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56258 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56259
56260 la = igh - 1
56261 kp1 = low + 1
56262 IF (la .LT. kp1) GOTO 210
56263C
56264 DO 200 m = kp1, la
56265 h = 0.0d0
56266 ortr(m) = 0.0d0
56267 orti(m) = 0.0d0
56268 scale = 0.0d0
56269C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56270 DO 100 i = m, igh
56271 100 scale = scale + dabs(ar(i,m-1)) + dabs(ai(i,m-1))
56272C
56273 IF (scale .EQ. 0.0d0) GOTO 200
56274 mp = m + igh
56275C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56276 DO 110 ii = m, igh
56277 i = mp - ii
56278 ortr(i) = ar(i,m-1) / scale
56279 orti(i) = ai(i,m-1) / scale
56280 h = h + ortr(i) * ortr(i) + orti(i) * orti(i)
56281 110 CONTINUE
56282C
56283 g = dsqrt(h)
56284 f = pythag(ortr(m),orti(m))
56285 IF (f .EQ. 0.0d0) GOTO 120
56286 h = h + f * g
56287 g = g / f
56288 ortr(m) = (1.0d0 + g) * ortr(m)
56289 orti(m) = (1.0d0 + g) * orti(m)
56290 GOTO 130
56291C
56292 120 ortr(m) = g
56293 ar(m,m-1) = scale
56294C .......... FORM (I-(U*UT)/H) * A ..........
56295 130 DO 160 j = m, n
56296 fr = 0.0d0
56297 fi = 0.0d0
56298C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56299 DO 140 ii = m, igh
56300 i = mp - ii
56301 fr = fr + ortr(i) * ar(i,j) + orti(i) * ai(i,j)
56302 fi = fi + ortr(i) * ai(i,j) - orti(i) * ar(i,j)
56303 140 CONTINUE
56304C
56305 fr = fr / h
56306 fi = fi / h
56307C
56308 DO 150 i = m, igh
56309 ar(i,j) = ar(i,j) - fr * ortr(i) + fi * orti(i)
56310 ai(i,j) = ai(i,j) - fr * orti(i) - fi * ortr(i)
56311 150 CONTINUE
56312C
56313 160 CONTINUE
56314C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56315 DO 190 i = 1, igh
56316 fr = 0.0d0
56317 fi = 0.0d0
56318C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56319 DO 170 jj = m, igh
56320 j = mp - jj
56321 fr = fr + ortr(j) * ar(i,j) - orti(j) * ai(i,j)
56322 fi = fi + ortr(j) * ai(i,j) + orti(j) * ar(i,j)
56323 170 CONTINUE
56324C
56325 fr = fr / h
56326 fi = fi / h
56327C
56328 DO 180 j = m, igh
56329 ar(i,j) = ar(i,j) - fr * ortr(j) - fi * orti(j)
56330 ai(i,j) = ai(i,j) + fr * orti(j) - fi * ortr(j)
56331 180 CONTINUE
56332C
56333 190 CONTINUE
56334C
56335 ortr(m) = scale * ortr(m)
56336 orti(m) = scale * orti(m)
56337 ar(m,m-1) = -g * ar(m,m-1)
56338 ai(m,m-1) = -g * ai(m,m-1)
56339 200 CONTINUE
56340C
56341 210 RETURN
56342 END
56343
56344C*********************************************************************
56345
56346C...PYLDCM
56347C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56348C...processes.
56349
56350 SUBROUTINE pyldcm(A,N,NP,INDX,D)
56351 IMPLICIT NONE
56352 INTEGER N,NP,INDX(N)
56353 REAL*8 D,TINY
56354 COMPLEX*16 A(NP,NP)
56355 parameter(tiny=1.0d-20)
56356 INTEGER I,IMAX,J,K
56357 real*8 aamax,vv(6),dum
56358 COMPLEX*16 SUM,DUMC
56359
56360 d=1d0
56361 DO 110 i=1,n
56362 aamax=0d0
56363 DO 100 j=1,n
56364 IF (abs(a(i,j)).GT.aamax) aamax=abs(a(i,j))
56365 100 CONTINUE
56366 IF (aamax.EQ.0d0) CALL pyerrm(28,'(PYLDCM:) singular matrix')
56367 vv(i)=1d0/aamax
56368 110 CONTINUE
56369 DO 180 j=1,n
56370 DO 130 i=1,j-1
56371 sum=a(i,j)
56372 DO 120 k=1,i-1
56373 sum=sum-a(i,k)*a(k,j)
56374 120 CONTINUE
56375 a(i,j)=sum
56376 130 CONTINUE
56377 aamax=0d0
56378 DO 150 i=j,n
56379 sum=a(i,j)
56380 DO 140 k=1,j-1
56381 sum=sum-a(i,k)*a(k,j)
56382 140 CONTINUE
56383 a(i,j)=sum
56384 dum=vv(i)*abs(sum)
56385 IF (dum.GE.aamax) THEN
56386 imax=i
56387 aamax=dum
56388 ENDIF
56389 150 CONTINUE
56390 IF (j.NE.imax)THEN
56391 DO 160 k=1,n
56392 dumc=a(imax,k)
56393 a(imax,k)=a(j,k)
56394 a(j,k)=dumc
56395 160 CONTINUE
56396 d=-d
56397 vv(imax)=vv(j)
56398 ENDIF
56399 indx(j)=imax
56400 IF(abs(a(j,j)).EQ.0d0) a(j,j)=dcmplx(tiny,0d0)
56401 IF(j.NE.n)THEN
56402 DO 170 i=j+1,n
56403 a(i,j)=a(i,j)/a(j,j)
56404 170 CONTINUE
56405 ENDIF
56406 180 CONTINUE
56407
56408 RETURN
56409 END
56410
56411C*********************************************************************
56412
56413C...PYBKSB
56414C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56415C...processes.
56416
56417 SUBROUTINE pybksb(A,N,NP,INDX,B)
56418 IMPLICIT NONE
56419 INTEGER N,NP,INDX(N)
56420 COMPLEX*16 A(NP,NP),B(N)
56421 INTEGER I,II,J,LL
56422 COMPLEX*16 SUM
56423
56424 ii=0
56425 DO 110 i=1,n
56426 ll=indx(i)
56427 sum=b(ll)
56428 b(ll)=b(i)
56429 IF (ii.NE.0)THEN
56430 DO 100 j=ii,i-1
56431 sum=sum-a(i,j)*b(j)
56432 100 CONTINUE
56433 ELSE IF (abs(sum).NE.0d0) THEN
56434 ii=i
56435 ENDIF
56436 b(i)=sum
56437 110 CONTINUE
56438 DO 130 i=n,1,-1
56439 sum=b(i)
56440 DO 120 j=i+1,n
56441 sum=sum-a(i,j)*b(j)
56442 120 CONTINUE
56443 b(i)=sum/a(i,i)
56444 130 CONTINUE
56445 RETURN
56446 END
56447
56448C***********************************************************************
56449
56450C...PYWIDX
56451C...Calculates full and partial widths of resonances.
56452C....copy of PYWIDT, used for techniparticle widths
56453
56454 SUBROUTINE pywidx(KFLR,SH,WDTP,WDTE)
56455
56456C...Double precision and integer declarations.
56457 IMPLICIT DOUBLE PRECISION(a-h, o-z)
56458 IMPLICIT INTEGER(I-N)
56459 INTEGER PYK,PYCHGE,PYCOMP
56460C...Parameter statement to help give large particle numbers.
56461 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
56462 &kexcit=4000000,kdimen=5000000)
56463C...Commonblocks.
56464 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
56465 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
56466 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
56467 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
56468 common/pypars/mstp(200),parp(200),msti(200),pari(200)
56469 common/pyint1/mint(400),vint(400)
56470 common/pyint4/mwid(500),wids(500,5)
56471 common/pymssm/imss(0:99),rmss(0:99)
56472 common/pytcsm/itcm(0:99),rtcm(0:99)
56473 SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,
56474 &/pyint4/,/pymssm/,/pytcsm/
56475C...Local arrays and saved variables.
56476 dimension wdtp(0:400),wdte(0:400,0:5),mofsv(3,2),widwsv(3,2),
56477 &wid2sv(3,2)
56478 SAVE mofsv,widwsv,wid2sv
56479 DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/
56480
56481C...Compressed code and sign; mass.
56482 kfla=iabs(kflr)
56483 kfls=isign(1,kflr)
56484 kc=pycomp(kfla)
56485 shr=sqrt(sh)
56486 pmr=pmas(kc,1)
56487
56488C...Reset width information.
56489 DO i=0,400
56490 wdtp(i)=0d0
56491 ENDDO
56492
56493C...Common electroweak and strong constants.
56494 xw=paru(102)
56495 xwv=xw
56496 IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2
56497 xw1=1d0-xw
56498 aem=pyalem(sh)
56499 IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)
56500 as=pyalps(sh)
56501 radc=1d0+as/paru(1)
56502
56503 IF(kfla.EQ.23) THEN
56504C...Z0:
56505 xwc=1d0/(16d0*xw*xw1)
56506 fac=(aem*xwc/3d0)*shr
56507 120 CONTINUE
56508 DO 130 i=1,mdcy(kc,3)
56509 idc=i+mdcy(kc,2)-1
56510 IF(mdme(idc,1).LT.0) GOTO 130
56511 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
56512 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
56513 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 130
56514 IF(i.LE.8) THEN
56515C...Z0 -> q + qbar
56516 ef=kchg(i,1)/3d0
56517 af=sign(1d0,ef+0.1d0)
56518 vf=af-4d0*ef*xwv
56519 fcof=3d0*radc
56520 IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)
56521 ELSEIF(i.LE.16) THEN
56522C...Z0 -> l+ + l-, nu + nubar
56523 ef=kchg(i+2,1)/3d0
56524 af=sign(1d0,ef+0.1d0)
56525 vf=af-4d0*ef*xwv
56526 fcof=1d0
56527 ENDIF
56528 be34=sqrt(max(0d0,1d0-4d0*rm1))
56529 wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*
56530 & be34
56531 wdtp(0)=wdtp(0)+wdtp(i)
56532 130 CONTINUE
56533
56534
56535 ELSEIF(kfla.EQ.24) THEN
56536C...W+/-:
56537 fac=(aem/(24d0*xw))*shr
56538 DO 140 i=1,mdcy(kc,3)
56539 idc=i+mdcy(kc,2)-1
56540 IF(mdme(idc,1).LT.0) GOTO 140
56541 rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh
56542 rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh
56543 IF(sqrt(rm1)+sqrt(rm2).GT.1d0) GOTO 140
56544 wid2=1d0
56545 IF(i.LE.16) THEN
56546C...W+/- -> q + qbar'
56547 fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)
56548 ELSEIF(i.LE.20) THEN
56549C...W+/- -> l+/- + nu
56550 fcof=1d0
56551 ENDIF
56552 wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*
56553 & sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))
56554 wdtp(0)=wdtp(0)+wdtp(i)
56555 140 CONTINUE
56556
56557C.....V8 -> quark anti-quark
56558 ELSEIF(kfla.EQ.ktechn+100021) THEN
56559 fac=as/6d0*shr
56560 tant3=rtcm(21)
56561 IF(itcm(2).EQ.0) THEN
56562 imdl=1
56563 ELSEIF(itcm(2).EQ.1) THEN
56564 imdl=2
56565 ENDIF
56566 DO 150 i=1,mdcy(kc,3)
56567 idc=i+mdcy(kc,2)-1
56568 IF(mdme(idc,1).LT.0) GOTO 150
56569 pm1=pmas(pycomp(kfdp(idc,1)),1)
56570 rm1=pm1**2/sh
56571 IF(rm1.GT.0.25d0) GOTO 150
56572 wid2=1d0
56573 IF(i.EQ.5.OR.i.EQ.6.OR.imdl.EQ.2) THEN
56574 fmix=1d0/tant3**2
56575 ELSE
56576 fmix=tant3**2
56577 ENDIF
56578 wdtp(i)=fac*(1d0+2d0*rm1)*sqrt(1d0-4d0*rm1)*fmix
56579 IF(i.EQ.6) wid2=wids(6,1)
56580 wdtp(0)=wdtp(0)+wdtp(i)
56581 150 CONTINUE
56582 ENDIF
56583
56584 RETURN
56585 END
56586
56587C*********************************************************************
56588
56589C...PYRVSF
56590C...Calculates R-violating decays of sfermions.
56591C...P. Z. Skands
56592
56593 SUBROUTINE pyrvsf(KFIN,XLAM,IDLAM,LKNT)
56594
56595C...Double precision and integer declarations.
56596 IMPLICIT DOUBLE PRECISION(a-h, o-z)
56597 IMPLICIT INTEGER(I-N)
56598C...Parameter statement to help give large particle numbers.
56599 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
56600 &kexcit=4000000,kdimen=5000000)
56601C...Commonblocks.
56602 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
56603 common/pymssm/imss(0:99),rmss(0:99)
56604 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
56605 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
56606 common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
56607C...Local variables.
56608 DOUBLE PRECISION XLAM(0:400)
56609 INTEGER IDLAM(400,3), PYCOMP
56610 SAVE /pymsrv/,/pyssmt/,/pymssm/,/pydat2/
56611
56612C...IS R-VIOLATION ON ?
56613 IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
56614C...Mass eigenstate counter
56615 icnt=int(kfin/ksusy1)
56616C...SM KF code of SUSY particle
56617 kfsm=kfin-icnt*ksusy1
56618C...Squared Sparticle Mass
56619 sm=pmas(pycomp(kfin),1)**2
56620C... Squared mass of top quark
56621 smt=pmas(pycomp(6),1)**2
56622C...IS L-VIOLATION ON ?
56623 IF ((imss(51).GE.1).OR.(imss(52).GE.1)) THEN
56624C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56625 IF(icnt.NE.0.AND.(kfsm.EQ.11.OR.kfsm.EQ.13.OR.kfsm.EQ.15))
56626 & THEN
56627 k=int((kfsm-9)/2)
56628 DO 110 i=1,3
56629 DO 100 j=1,3
56630 IF(i.NE.j) THEN
56631C...~e,~mu,~tau -> nu_I + lepton-_J
56632 lknt = lknt+1
56633 idlam(lknt,1)= 12 +2*(i-1)
56634 idlam(lknt,2)= 11 +2*(j-1)
56635 idlam(lknt,3)= 0
56636 xlam(lknt)=0d0
56637 rm2=rvlam(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
56638 IF (imss(51).NE.0) xlam(lknt) =
56639 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56640C...KINEMATICS CHECK
56641 IF (xlam(lknt).EQ.0d0) THEN
56642 lknt=lknt-1
56643 ENDIF
56644 ENDIF
56645 100 CONTINUE
56646 110 CONTINUE
56647C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56648 j=int((kfsm-9)/2)
56649 DO 130 i=1,3
56650 IF(i.NE.j) THEN
56651 DO 120 k=1,3
56652 lknt = lknt+1
56653 idlam(lknt,1)=-12 -2*(i-1)
56654 idlam(lknt,2)= 11 +2*(k-1)
56655 idlam(lknt,3)= 0
56656 xlam(lknt)=0d0
56657 rm2=rvlam(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
56658 IF (imss(51).NE.0) xlam(lknt) =
56659 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56660C...KINEMATICS CHECK
56661 IF (xlam(lknt).EQ.0d0) THEN
56662 lknt=lknt-1
56663 ENDIF
56664 120 CONTINUE
56665 ENDIF
56666 130 CONTINUE
56667C...~e,~mu,~tau -> u_Jbar + d_K
56668 i=int((kfsm-9)/2)
56669 DO 150 j=1,3
56670 DO 140 k=1,3
56671 lknt = lknt+1
56672 idlam(lknt,1)=-2 -2*(j-1)
56673 idlam(lknt,2)= 1 +2*(k-1)
56674 idlam(lknt,3)= 0
56675 xlam(lknt)=0
56676 IF (imss(52).NE.0) THEN
56677C...Use massive top quark
56678 IF (idlam(lknt,1).EQ.-6) THEN
56679 rm2=3*rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2
56680 & * (sm-smt)
56681 xlam(lknt) =
56682 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,3)
56683C...If no top quark, all decay products massless
56684 ELSE
56685 rm2=3*rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
56686 xlam(lknt) =
56687 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56688 ENDIF
56689C...KINEMATICS CHECK
56690 IF (xlam(lknt).EQ.0d0) THEN
56691 lknt=lknt-1
56692 ENDIF
56693 ENDIF
56694 140 CONTINUE
56695 150 CONTINUE
56696 ENDIF
56697C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56698C...No right-handed neutrinos
56699 IF(icnt.EQ.1) THEN
56700 IF(kfsm.EQ.12.OR.kfsm.EQ.14.OR.kfsm.EQ.16) THEN
56701 j=int((kfsm-10)/2)
56702 DO 170 i=1,3
56703 DO 160 k=1,3
56704 IF (i.NE.j) THEN
56705C...~nu_J -> lepton+_I + lepton-_K
56706 lknt = lknt+1
56707 idlam(lknt,1)=-11 -2*(i-1)
56708 idlam(lknt,2)= 11 +2*(k-1)
56709 idlam(lknt,3)= 0
56710 xlam(lknt)=0d0
56711 rm2=rvlam(i,j,k)**2 * sm
56712 IF (imss(51).NE.0) xlam(lknt) =
56713 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56714C...KINEMATICS CHECK
56715 IF (xlam(lknt).EQ.0d0) THEN
56716 lknt=lknt-1
56717 ENDIF
56718 ENDIF
56719 160 CONTINUE
56720 170 CONTINUE
56721C...~nu_I -> dbar_J + d_K
56722 i=int((kfsm-10)/2)
56723 DO 190 j=1,3
56724 DO 180 k=1,3
56725 lknt = lknt+1
56726 idlam(lknt,1)=-1 -2*(j-1)
56727 idlam(lknt,2)= 1 +2*(k-1)
56728 idlam(lknt,3)= 0
56729 xlam(lknt)=0d0
56730 rm2=3*rvlamp(i,j,k)**2 * sm
56731 IF (imss(52).NE.0) xlam(lknt) =
56732 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56733C...KINEMATICS CHECK
56734 IF (xlam(lknt).EQ.0d0) THEN
56735 lknt=lknt-1
56736 ENDIF
56737 180 CONTINUE
56738 190 CONTINUE
56739 ENDIF
56740 ENDIF
56741C * SDOWN -> NU(BAR) + D and LEPTON- + U
56742 IF(icnt.NE.0.AND.(kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5)) THEN
56743 j=int((kfsm+1)/2)
56744 DO 210 i=1,3
56745 DO 200 k=1,3
56746C...~d_J -> nu_Ibar + d_K
56747 lknt = lknt+1
56748 idlam(lknt,1)=-12 -2*(i-1)
56749 idlam(lknt,2)= 1 +2*(k-1)
56750 idlam(lknt,3)= 0
56751 xlam(lknt)=0d0
56752 rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
56753 IF (imss(52).NE.0) xlam(lknt) =
56754 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56755C...KINEMATICS CHECK
56756 IF (xlam(lknt).EQ.0d0) THEN
56757 lknt=lknt-1
56758 ENDIF
56759 200 CONTINUE
56760 210 CONTINUE
56761 k=int((kfsm+1)/2)
56762 DO 240 i=1,3
56763 DO 230 j=1,3
56764C...~d_K -> nu_I + d_J
56765 lknt = lknt+1
56766 idlam(lknt,1)= 12 +2*(i-1)
56767 idlam(lknt,2)= 1 +2*(j-1)
56768 idlam(lknt,3)= 0
56769 xlam(lknt)=0d0
56770 rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
56771 IF (imss(52).NE.0) xlam(lknt) =
56772 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56773C...KINEMATICS CHECK
56774 IF (xlam(lknt).EQ.0d0) THEN
56775 lknt=lknt-1
56776 ENDIF
56777C...~d_K -> lepton_I- + u_J
56778 220 lknt = lknt+1
56779 idlam(lknt,1)= 11 +2*(i-1)
56780 idlam(lknt,2)= 2 +2*(j-1)
56781 idlam(lknt,3)= 0
56782 xlam(lknt)=0d0
56783 IF (imss(52).NE.0) THEN
56784C...Use massive top quark
56785 IF (idlam(lknt,2).EQ.6) THEN
56786 rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2*(sm-smt)
56787 xlam(lknt) =
56788 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,2)
56789C...If no top quark, all decay products massless
56790 ELSE
56791 rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
56792 xlam(lknt) =
56793 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56794 ENDIF
56795C...KINEMATICS CHECK
56796 IF (xlam(lknt).EQ.0d0) THEN
56797 lknt=lknt-1
56798 ENDIF
56799 ENDIF
56800 230 CONTINUE
56801 240 CONTINUE
56802 ENDIF
56803C * SUP -> LEPTON+ + D
56804 IF(icnt.NE.0.AND.(kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6)) THEN
56805 j=nint(kfsm/2.)
56806 DO 260 i=1,3
56807 DO 250 k=1,3
56808C...~u_J -> lepton_I+ + d_K
56809 lknt = lknt+1
56810 idlam(lknt,1)=-11 -2*(i-1)
56811 idlam(lknt,2)= 1 +2*(k-1)
56812 idlam(lknt,3)= 0
56813 xlam(lknt)=0d0
56814 rm2=rvlamp(i,j,k)**2*sfmix(kfsm,2*icnt-1)**2 * sm
56815 IF (imss(52).NE.0) xlam(lknt) =
56816 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56817C...KINEMATICS CHECK
56818 IF (xlam(lknt).EQ.0d0) THEN
56819 lknt=lknt-1
56820 ENDIF
56821 250 CONTINUE
56822 260 CONTINUE
56823 ENDIF
56824 ENDIF
56825C...BARYON NUMBER VIOLATING DECAYS
56826 IF (imss(53).GE.1) THEN
56827C * SUP -> DBAR + DBAR
56828 IF(icnt.NE.0.AND.(kfsm.EQ.2.OR.kfsm.EQ.4.OR.kfsm.EQ.6)) THEN
56829 i = kfsm/2
56830 DO 280 j=1,3
56831 DO 270 k=1,3
56832C...~u_I -> dbar_J + dbar_K
56833 IF (j.LT.k) THEN
56834C...(anti-) symmetry J <-> K.
56835 lknt = lknt + 1
56836 idlam(lknt,1) = -1 -2*(j-1)
56837 idlam(lknt,2) = -1 -2*(k-1)
56838 idlam(lknt,3) = 0
56839 xlam(lknt) = 0d0
56840 rm2 = 2.*(rvlamb(i,j,k)**2)
56841 & * sfmix(kfsm,2*icnt)**2 * sm
56842 xlam(lknt) =
56843 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56844C...KINEMATICS CHECK
56845 IF (xlam(lknt).EQ.0d0) THEN
56846 lknt = lknt-1
56847 ENDIF
56848 ENDIF
56849 270 CONTINUE
56850 280 CONTINUE
56851 ENDIF
56852C * SDOWN -> UBAR + DBAR
56853 IF(icnt.NE.0.AND.(kfsm.EQ.1.OR.kfsm.EQ.3.OR.kfsm.EQ.5)) THEN
56854 k=(kfsm+1)/2
56855 DO 300 i=1,3
56856 DO 290 j=1,3
56857C...LAMB coupling antisymmetric in J and K.
56858 IF (j.NE.k) THEN
56859C...~d_K -> ubar_I + dbar_K
56860 lknt = lknt + 1
56861 idlam(lknt,1)= -2 -2*(i-1)
56862 idlam(lknt,2)= -1 -2*(j-1)
56863 idlam(lknt,3)= 0
56864 xlam(lknt)=0d0
56865C...Use massive top quark
56866 IF (idlam(lknt,1).EQ.-6) THEN
56867 rm2=2*rvlamb(i,j,k)**2*sfmix(kfsm,2*icnt)**2*(sm-smt
56868 & )
56869 xlam(lknt) =
56870 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,3)
56871C...If no top quark, all decay products massless
56872 ELSE
56873 rm2=2*rvlamb(i,j,k)**2*sfmix(kfsm,2*icnt)**2 * sm
56874 xlam(lknt) =
56875 & pyrvsb(kfin,idlam(lknt,1),idlam(lknt,2),rm2,4)
56876 ENDIF
56877C...KINEMATICS CHECK
56878 IF (xlam(lknt).EQ.0d0) THEN
56879 lknt=lknt-1
56880 ENDIF
56881 ENDIF
56882 290 CONTINUE
56883 300 CONTINUE
56884 ENDIF
56885 ENDIF
56886 ENDIF
56887
56888 RETURN
56889 END
56890
56891C*********************************************************************
56892
56893C...PYRVNE
56894C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
56895C...P. Z. Skands
56896
56897 SUBROUTINE pyrvne(KFIN,XLAM,IDLAM,LKNT)
56898
56899C...Double precision and integer declarations.
56900 IMPLICIT DOUBLE PRECISION(a-h, o-z)
56901 IMPLICIT INTEGER(I-N)
56902C...Parameter statement to help give large particle numbers.
56903 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
56904 &kexcit=4000000,kdimen=5000000)
56905C...Commonblocks.
56906 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
56907 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
56908 common/pymssm/imss(0:99),rmss(0:99)
56909 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
56910 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
56911 common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
56912C...Local variables.
56913 common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
56914 & ,dcmass,kfr(3)
56915 DOUBLE PRECISION XLAM(0:400)
56916 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
56917 INTEGER IDLAM(400,3), PYCOMP
56918 LOGICAL DCMASS
56919 SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pymsrv/,/pyrvnv/
56920
56921C...R-VIOLATING DECAYS
56922 IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
56923 kfsm=kfin-ksusy1
56924 IF(kfsm.EQ.22.OR.kfsm.EQ.23.OR.kfsm.EQ.25.OR.kfsm.EQ.35) THEN
56925C...WHICH NEUTRALINO ?
56926 nchi=1
56927 IF (kfsm.EQ.23) nchi=2
56928 IF (kfsm.EQ.25) nchi=3
56929 IF (kfsm.EQ.35) nchi=4
56930C...SIGN OF MASS (Opposite convention as HERWIG)
56931 ism = 1
56932 IF (smz(nchi).LT.0d0) ism = -ism
56933
56934C...Useful parameters for the calculation of the A and B constants.
56935 wmass = pmas(pycomp(24),1)
56936 echg = 2*sqrt(paru(103)*paru(1))
56937 cosb=1/(sqrt(1+rmss(5)**2))
56938 sinb=rmss(5)/sqrt(1+rmss(5)**2)
56939 cosw=sqrt(1-paru(102))
56940 sinw=sqrt(paru(102))
56941 gw=2d0*sqrt(paru(103)*paru(1))/sinw
56942C...Run quark masses to neutralino mass squared (for Higgs-type
56943C...couplings)
56944 sqmchi=pmas(pycomp(kfin),1)**2
56945 DO 100 i=1,6
56946 rmq(i)=pymrun(i,sqmchi)
56947 100 CONTINUE
56948C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
56949 DO 110 nchj=1,4
56950 zpmix(nchj,1)= zmix(nchj,1)*cosw+zmix(nchj,2)*sinw
56951 zpmix(nchj,2)=-zmix(nchj,1)*sinw+zmix(nchj,2)*cosw
56952 zpmix(nchj,3)= zmix(nchj,3)
56953 zpmix(nchj,4)= zmix(nchj,4)
56954 110 CONTINUE
56955 c1=gw*zpmix(nchi,3)/(2d0*cosb*wmass)
56956 c1u=gw*zpmix(nchi,4)/(2d0*sinb*wmass)
56957 c2=echg*zpmix(nchi,1)
56958 c3=gw*zpmix(nchi,2)/cosw
56959 eu=2d0/3d0
56960 ed=-1d0/3d0
56961C... AB(x,y,z):
56962C x=1-2 : Select A or B constant (1:A ; 2:B)
56963C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
56964C 11-16:e,nu_e,mu,...)
56965C z=1-2 : Mass eigenstate number
56966C...CALCULATE COUPLINGS
56967 DO 120 i = 11,15,2
56968 cms=pmas(pycomp(i),1)
56969C...Intermediate sleptons
56970 ab(1,i,1)=ism*(cms*c1*sfmix(i,1) + sfmix(i,2)
56971 & *(c2-c3*sinw**2))
56972 ab(1,i,2)=ism*(cms*c1*sfmix(i,3) + sfmix(i,4)
56973 & *(c2-c3*sinw**2))
56974 ab(2,i,1)= cms*c1*sfmix(i,2) - sfmix(i,1)*(c2+c3*(5d-1-sinw
56975 & **2))
56976 ab(2,i,2)=cms*c1*sfmix(i,4) - sfmix(i,3)*(c2+c3*(5d-1-sinw
56977 & **2))
56978C...Inermediate sneutrinos
56979 ab(1,i+1,1)=0d0
56980 ab(2,i+1,1)=5d-1*c3
56981 ab(1,i+1,2)=0d0
56982 ab(2,i+1,2)=0d0
56983C...Inermediate sdown
56984 j=i-10
56985 cms=rmq(j)
56986 ab(1,j,1)=ism*(cms*c1*sfmix(j,1) - sfmix(j,2)
56987 & *ed*(c2-c3*sinw**2))
56988 ab(1,j,2)=ism*(cms*c1*sfmix(j,3) - sfmix(j,4)
56989 & *ed*(c2-c3*sinw**2))
56990 ab(2,j,1)=cms*c1*sfmix(j,2) + sfmix(j,1)
56991 & *(ed*c2-c3*(1d0/2d0+ed*sinw**2))
56992 ab(2,j,2)=cms*c1*sfmix(j,4) + sfmix(j,3)
56993 & *(ed*c2-c3*(1d0/2d0+ed*sinw**2))
56994C...Inermediate sup
56995 j=j+1
56996 cms=rmq(j)
56997 ab(1,j,1)=ism*(cms*c1u*sfmix(j,1) - sfmix(j,2)
56998 & *eu*(c2-c3*sinw**2))
56999 ab(1,j,2)=ism*(cms*c1u*sfmix(j,3) - sfmix(j,4)
57000 & *eu*(c2-c3*sinw**2))
57001 ab(2,j,1)=cms*c1u*sfmix(j,2) + sfmix(j,1)
57002 & *(eu*c2+c3*(1d0/2d0-eu*sinw**2))
57003 ab(2,j,2)=cms*c1u*sfmix(j,4) + sfmix(j,3)
57004 & *(eu*c2+c3*(1d0/2d0-eu*sinw**2))
57005 120 CONTINUE
57006
57007 IF (imss(51).GE.1) THEN
57008C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57009C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57010C...STEP IN I,J,K USING SINGLE COUNTER
57011 DO 130 isc=0,26
57012C...LAMBDA COUPLING ASYM IN I,J
57013 IF(mod(isc/9,3).NE.mod(isc/3,3)) THEN
57014 lknt = lknt+1
57015 idlam(lknt,1) =-12 -2*mod(isc/9,3)
57016 idlam(lknt,2) =-11 -2*mod(isc/3,3)
57017 idlam(lknt,3) = 11 +2*mod(isc,3)
57018 xlam(lknt) = 0d0
57019C...Set coupling, and decay product masses on/off
57020 rvlamc = rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1
57021 & ,mod(isc,3)+1)**2
57022 dcmass=.false.
57023 IF (idlam(lknt,2).EQ.-15.OR.idlam(lknt,3).EQ.15)
57024 & dcmass = .true.
57025C...Resonance KF codes (1=I,2=J,3=K)
57026 kfr(1)=-idlam(lknt,1)
57027 kfr(2)=-idlam(lknt,2)
57028 kfr(3)=-idlam(lknt,3)
57029C...Calculate width.
57030 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57031 & idlam(lknt,3),xlam(lknt))
57032 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57033C...Charge conjugate mode.
57034 lknt=lknt+1
57035 idlam(lknt,1)=-idlam(lknt-1,1)
57036 idlam(lknt,2)=-idlam(lknt-1,2)
57037 idlam(lknt,3)=-idlam(lknt-1,3)
57038 xlam(lknt)=xlam(lknt-1)
57039C...KINEMATICS CHECK
57040 IF (xlam(lknt).EQ.0d0) THEN
57041 lknt=lknt-2
57042 ENDIF
57043 ENDIF
57044 130 CONTINUE
57045 ENDIF
57046
57047 IF (imss(52).GE.1) THEN
57048C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57049C * CHI0 -> NUBAR_I + DBAR_J + D_K
57050 DO 140 isc=0,26
57051 lknt = lknt+1
57052 idlam(lknt,1) =-12 -2*mod(isc/9,3)
57053 idlam(lknt,2) = -1 -2*mod(isc/3,3)
57054 idlam(lknt,3) = 1 +2*mod(isc,3)
57055 xlam(lknt) = 0d0
57056C...Set coupling, and decay product masses on/off
57057 rvlamc = 3 * rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1
57058 & ,mod(isc,3)+1)**2
57059 dcmass=.false.
57060 IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.5)
57061 & dcmass = .true.
57062C...Resonance KF codes (1=I,2=J,3=K)
57063 kfr(1)=-idlam(lknt,1)
57064 kfr(2)=-idlam(lknt,2)
57065 kfr(3)=-idlam(lknt,3)
57066C...Calculate width.
57067 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57068 & ,xlam(lknt))
57069 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57070C...Charge conjugate mode.
57071 lknt=lknt+1
57072 idlam(lknt,1)=-idlam(lknt-1,1)
57073 idlam(lknt,2)=-idlam(lknt-1,2)
57074 idlam(lknt,3)=-idlam(lknt-1,3)
57075 xlam(lknt)=xlam(lknt-1)
57076C...KINEMATICS CHECK
57077 IF (xlam(lknt).EQ.0d0) THEN
57078 lknt=lknt-2
57079 ENDIF
57080
57081C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57082 lknt = lknt+1
57083 idlam(lknt,1) =-11 -2*mod(isc/9,3)
57084 idlam(lknt,2) = -2 -2*mod(isc/3,3)
57085 idlam(lknt,3) = 1 +2*mod(isc,3)
57086 xlam(lknt) = 0d0
57087C...Set coupling, and decay product masses on/off
57088 rvlamc = 3 * rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1
57089 & ,mod(isc,3)+1)**2
57090 dcmass=.false.
57091 IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-6
57092 & .OR.idlam(lknt,3).EQ.5) dcmass=.true.
57093C...Resonance KF codes (1=I,2=J,3=K)
57094 kfr(1)=-idlam(lknt,1)
57095 kfr(2)=-idlam(lknt,2)
57096 kfr(3)=-idlam(lknt,3)
57097C...Calculate width.
57098 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57099 & ,xlam(lknt))
57100 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57101C...Charge conjugate mode.
57102 lknt=lknt+1
57103 idlam(lknt,1)=-idlam(lknt-1,1)
57104 idlam(lknt,2)=-idlam(lknt-1,2)
57105 idlam(lknt,3)=-idlam(lknt-1,3)
57106 xlam(lknt)=xlam(lknt-1)
57107C...KINEMATICS CHECK
57108 IF (xlam(lknt).EQ.0d0) THEN
57109 lknt=lknt-2
57110 ENDIF
57111 140 CONTINUE
57112 ENDIF
57113
57114 IF (imss(53).GE.1) THEN
57115C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57116C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57117 DO 150 isc=0,26
57118C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57119 IF (mod(isc/3,3).LT.mod(isc,3)) THEN
57120 lknt = lknt+1
57121 idlam(lknt,1) = -2 -2*mod(isc/9,3)
57122 idlam(lknt,2) = -1 -2*mod(isc/3,3)
57123 idlam(lknt,3) = -1 -2*mod(isc,3)
57124 xlam(lknt) = 0d0
57125C...Set coupling, and decay product masses on/off
57126 rvlamc = 6. * rvlamb(mod(isc/9,3)+1,mod(isc/3,3)
57127 & +1,mod(isc,3)+1)**2
57128 dcmass=.false.
57129 IF (idlam(lknt,1).EQ.-6.OR.idlam(lknt,2).EQ.-5
57130 & .OR.idlam(lknt,3).EQ.-5) dcmass=.true.
57131C...Resonance KF codes (1=I,2=J,3=K)
57132 kfr(1) = idlam(lknt,1)
57133 kfr(2) = idlam(lknt,2)
57134 kfr(3) = idlam(lknt,3)
57135C...Calculate width.
57136 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57137 & idlam(lknt,3),xlam(lknt))
57138 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57139C...Charge conjugate mode.
57140 lknt=lknt+1
57141 idlam(lknt,1)=-idlam(lknt-1,1)
57142 idlam(lknt,2)=-idlam(lknt-1,2)
57143 idlam(lknt,3)=-idlam(lknt-1,3)
57144 xlam(lknt)=xlam(lknt-1)
57145C...KINEMATICS CHECK
57146 IF (xlam(lknt).EQ.0d0) THEN
57147 lknt=lknt-2
57148 ENDIF
57149 ENDIF
57150 150 CONTINUE
57151 ENDIF
57152 ENDIF
57153 ENDIF
57154
57155 RETURN
57156 END
57157
57158C*********************************************************************
57159
57160C...PYRVCH
57161C...Calculates R-violating chargino decay widths.
57162C...P. Z. Skands
57163
57164 SUBROUTINE pyrvch(KFIN,XLAM,IDLAM,LKNT)
57165
57166C...Double precision and integer declarations.
57167 IMPLICIT DOUBLE PRECISION(a-h, o-z)
57168 IMPLICIT INTEGER(I-N)
57169C...Parameter statement to help give large particle numbers.
57170 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57171 &kexcit=4000000,kdimen=5000000)
57172C...Commonblocks.
57173 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
57174 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57175 common/pymssm/imss(0:99),rmss(0:99)
57176 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
57177 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
57178 common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
57179C...Local variables.
57180 DOUBLE PRECISION XLAM(0:400)
57181 INTEGER IDLAM(400,3), PYCOMP
57182C...Information from main routine to PYRVGW
57183 common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
57184 & ,dcmass,kfr(3)
57185C...Auxiliary variables needed for BV (RV Gauge STOre)
57186 common/rvgsto/xresi,xresj,xresk,xresij,xresik,xresjk,rvlijk,rvlkij
57187 & ,rvljki,rvljik
57188C...Running quark masses
57189 DOUBLE PRECISION RMQ(6)
57190C...Decay product masses on/off
57191 LOGICAL DCMASS
57192 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57193 & /rvgsto/
57194
57195
57196C...IF R-VIOLATION ON.
57197 IF ((imss(51).GE.1).OR.(imss(52).GE.1).OR.(imss(53).GE.1)) THEN
57198 kfsm=kfin-ksusy1
57199 IF(kfsm.EQ.24.OR.kfsm.EQ.37) THEN
57200C...WHICH CHARGINO ?
57201 nchi = 1
57202 IF (kfsm.EQ.37) nchi = 2
57203
57204C...Useful parameters for calculating the A and B constants.
57205C...SIGN OF MASS (Opposite convention as HERWIG)
57206 ism = 1
57207 IF (smw(nchi).LT.0d0) ism = -1
57208 wmass = pmas(pycomp(24),1)
57209 cosb = 1/(sqrt(1+rmss(5)**2))
57210 sinb = rmss(5)/sqrt(1+rmss(5)**2)
57211 gw2 = 4*paru(103)*paru(1)/paru(102)
57212 c1u = umix(nchi,2)/(sqrt(2d0)*cosb*wmass)
57213 c1v = vmix(nchi,2)/(sqrt(2d0)*sinb*wmass)
57214 c2 = umix(nchi,1)
57215 c3 = vmix(nchi,1)
57216C...Running masses at Q^2=MCHI^2.
57217 sqmchi = pmas(pycomp(kfsm),1)**2
57218 DO 100 i=1,6
57219 rmq(i)=pymrun(i,sqmchi)
57220 100 CONTINUE
57221
57222C... AB(x,y,z) coefficients:
57223C x=1-2 : A or B coefficient (1:A ; 2:B)
57224C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57225C 11-16:e,nu_e,mu,...)
57226C z=1-2 : Mass eigenstate number
57227 DO 110 i = 11,15,2
57228C...Intermediate sleptons
57229 ab(1,i,1) = 0d0
57230 ab(1,i,2) = 0d0
57231 ab(2,i,1) = -pmas(pycomp(i),1)*c1u*sfmix(i,2) +
57232 & sfmix(i,1)*c2
57233 ab(2,i,2) = -pmas(pycomp(i),1)*c1u*sfmix(i,4) +
57234 & sfmix(i,3)*c2
57235C...Intermediate sneutrinos
57236 ab(1,i+1,1) = -pmas(pycomp(i),1)*c1u
57237 ab(1,i+1,2) = 0d0
57238 ab(2,i+1,1) = ism*c3
57239 ab(2,i+1,2) = 0d0
57240C...Intermediate sdown
57241 j=i-10
57242 ab(1,j,1) = -rmq(j+1)*c1v*sfmix(j,1)
57243 ab(1,j,2) = -rmq(j+1)*c1v*sfmix(j,3)
57244 ab(2,j,1) = -ism*(rmq(j)*c1u*sfmix(j,2) - sfmix(j,1)*c2)
57245 ab(2,j,2) = -ism*(rmq(j)*c1u*sfmix(j,4) - sfmix(j,3)*c2)
57246C...Intermediate sup
57247 j=j+1
57248 ab(1,j,1) = -rmq(j-1)*c1u*sfmix(j,1)
57249 ab(1,j,2) = -rmq(j-1)*c1u*sfmix(j,3)
57250 ab(2,j,1) = -ism*(rmq(j)*c1v*sfmix(j,2) - sfmix(j,1)*c3)
57251 ab(2,j,2) = -ism*(rmq(j)*c1v*sfmix(j,4) - sfmix(j,3)*c3)
57252 110 CONTINUE
57253
57254C...LLE TYPE R-VIOLATION
57255 IF (imss(51).GE.1) THEN
57256C...LOOP OVER DECAY MODES
57257 DO 140 isc=0,26
57258
57259C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57260 IF(mod(isc/9,3).NE.mod(isc/3,3)) THEN
57261 lknt = lknt+1
57262 idlam(lknt,1) = -12 -2*mod(isc/9,3)
57263 idlam(lknt,2) = -11 -2*mod(isc/3,3)
57264 idlam(lknt,3) = 12 +2*mod(isc,3)
57265 xlam(lknt) = 0d0
57266C...Set coupling, and decay product masses on/off
57267 rvlamc = gw2 * 5d-1 *
57268 & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
57269 & **2
57270 dcmass=.false.
57271 IF (idlam(lknt,2).EQ.-15) dcmass = .true.
57272C...Resonance KF codes (1=I,2=J,3=K).
57273 kfr(1) = 0
57274 kfr(2) = 0
57275 kfr(3) = -idlam(lknt,3)+1
57276C...Calculate width.
57277 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57278 & idlam(lknt,3),xlam(lknt))
57279 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57280C...KINEMATICS CHECK
57281 IF (xlam(lknt).EQ.0d0) THEN
57282 lknt=lknt-1
57283 ENDIF
57284
57285C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57286 120 IF (mod(isc/9,3).LT.mod(isc/3,3)) THEN
57287 lknt = lknt+1
57288 idlam(lknt,1) = 12 +2*mod(isc/9,3)
57289 idlam(lknt,2) = 12 +2*mod(isc/3,3)
57290 idlam(lknt,3) =-11 -2*mod(isc,3)
57291 xlam(lknt) = 0d0
57292C...Set coupling, and decay product masses on/off
57293 rvlamc = gw2 * 5d-1 *
57294 & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57295C...I,J SYMMETRY => FACTOR 2
57296 rvlamc=2*rvlamc
57297 dcmass=.false.
57298 IF (idlam(lknt,3).EQ.-15) dcmass = .true.
57299C...Resonance KF codes (1=I,2=J,3=K)
57300 kfr(1)=idlam(lknt,1)-1
57301 kfr(2)=idlam(lknt,2)-1
57302 kfr(3)=0
57303C...Calculate width.
57304 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57305 & idlam(lknt,3),xlam(lknt))
57306 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57307C...KINEMATICS CHECK
57308 IF (xlam(lknt).EQ.0d0) THEN
57309 lknt=lknt-1
57310 ENDIF
57311 130 ENDIF
57312
57313C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57314 lknt = lknt+1
57315 idlam(lknt,1) =-11 -2*mod(isc/9,3)
57316 idlam(lknt,2) =-11 -2*mod(isc/3,3)
57317 idlam(lknt,3) = 11 +2*mod(isc,3)
57318 xlam(lknt) = 0d0
57319C...Set coupling, and decay product masses on/off
57320 rvlamc = gw2 * 5d-1 *
57321 & rvlam(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57322C...I,J SYMMETRY => FACTOR 2
57323 rvlamc=2*rvlamc
57324 dcmass=.false.
57325 IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-15
57326 & .OR.idlam(lknt,3).EQ.15) dcmass = .true.
57327C...Resonance KF codes (1=I,2=J,3=K)
57328 kfr(1) =-idlam(lknt,1)+1
57329 kfr(2) =-idlam(lknt,2)+1
57330 kfr(3) = 0
57331C...Calculate width.
57332 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57333 & idlam(lknt,3),xlam(lknt))
57334 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57335C...KINEMATICS CHECK
57336 IF (xlam(lknt).EQ.0d0) THEN
57337 lknt=lknt-1
57338 ENDIF
57339 ENDIF
57340 140 CONTINUE
57341 ENDIF
57342
57343C...LQD TYPE R-VIOLATION
57344 IF (imss(52).GE.1) THEN
57345C...LOOP OVER DECAY MODES
57346 DO 180 isc=0,26
57347
57348C...CHI+ -> NUBAR_I + DBAR_J + U_K
57349 lknt = lknt+1
57350 idlam(lknt,1) =-12 -2*mod(isc/9,3)
57351 idlam(lknt,2) = -1 -2*mod(isc/3,3)
57352 idlam(lknt,3) = 2 +2*mod(isc,3)
57353 xlam(lknt) = 0d0
57354C...Set coupling, and decay product masses on/off
57355 rvlamc = 3. * gw2 * 5d-1 *
57356 & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57357 dcmass=.false.
57358 IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.6)
57359 & dcmass = .true.
57360C...Resonance KF codes (1=I,2=J,3=K)
57361 kfr(1)=0
57362 kfr(2)=0
57363 kfr(3)=-idlam(lknt,3)+1
57364C...Calculate width.
57365 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57366 & ,xlam(lknt))
57367 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57368C...KINEMATICS CHECK
57369 IF (xlam(lknt).EQ.0d0) THEN
57370 lknt=lknt-1
57371 ENDIF
57372
57373C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57374 150 lknt = lknt+1
57375 idlam(lknt,1) =-11 -2*mod(isc/9,3)
57376 idlam(lknt,2) = -2 -2*mod(isc/3,3)
57377 idlam(lknt,3) = 2 +2*mod(isc,3)
57378 xlam(lknt) = 0d0
57379C...Set coupling, and decay product masses on/off
57380 rvlamc = 3. * gw2 * 5d-1 *
57381 & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57382 dcmass=.false.
57383 IF (idlam(lknt,1).EQ.-11.OR.idlam(lknt,2).EQ.-6
57384 & .OR.idlam(lknt,3).EQ.6) dcmass = .true.
57385C...Resonance KF codes (1=I,2=J,3=K)
57386 kfr(1)=0
57387 kfr(2)=0
57388 kfr(3)=-idlam(lknt,3)+1
57389C...Calculate width.
57390 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57391 & ,xlam(lknt))
57392 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57393C...KINEMATICS CHECK
57394 IF (xlam(lknt).EQ.0d0) THEN
57395 lknt=lknt-1
57396 ENDIF
57397
57398C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57399 160 lknt = lknt+1
57400 idlam(lknt,1) =-11 -2*mod(isc/9,3)
57401 idlam(lknt,2) = -1 -2*mod(isc/3,3)
57402 idlam(lknt,3) = 1 +2*mod(isc,3)
57403 xlam(lknt) = 0d0
57404C...Set coupling, and decay product masses on/off
57405 rvlamc = 3. * gw2 * 5d-1 *
57406 & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57407 dcmass = .false.
57408 IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-5
57409 & .OR.idlam(lknt,3).EQ.5) dcmass = .true.
57410C...Resonance KF codes (1=I,2=J,3=K)
57411 kfr(1)=-idlam(lknt,1)+1
57412 kfr(2)=-idlam(lknt,2)+1
57413 kfr(3)=0
57414C...Calculate width.
57415 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57416 & ,xlam(lknt))
57417 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57418C...KINEMATICS CHECK
57419 IF (xlam(lknt).EQ.0d0) THEN
57420 lknt=lknt-1
57421 ENDIF
57422
57423C * CHI+ -> NU_I + U_J + DBAR_K.
57424 170 lknt = lknt+1
57425 idlam(lknt,1) = 12 +2*mod(isc/9,3)
57426 idlam(lknt,2) = 2 +2*mod(isc/3,3)
57427 idlam(lknt,3) = -1 -2*mod(isc,3)
57428 xlam(lknt) = 0d0
57429C...Set coupling, and decay product masses on/off
57430 dcmass = .false.
57431 rvlamc = 3. * gw2 * 5d-1 *
57432 & rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57433 IF (idlam(lknt,2).EQ.6.OR.idlam(lknt,3).EQ.-5)
57434 & dcmass = .true.
57435C...Resonance KF codes (1=I,2=J,3=K)
57436 kfr(1)=idlam(lknt,1)-1
57437 kfr(2)=idlam(lknt,2)-1
57438 kfr(3)=0
57439C...Calculate width.
57440 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57441 & ,xlam(lknt))
57442 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57443C...KINEMATICS CHECK
57444 IF (xlam(lknt).EQ.0d0) THEN
57445 lknt=lknt-1
57446 ENDIF
57447
57448 180 CONTINUE
57449 ENDIF
57450
57451C...UDD TYPE R-VIOLATION
57452C...These decays need special treatment since more than one BV coupling
57453C...contributes (with interference). Consider e.g. (symbolically)
57454C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57455C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57456C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57457C...The problem is that a single call to PYRVGW would evaluate all
57458C...these terms and sum them, but without the different couplings. The
57459C...way out is to call PYRVGW three times, once for the first line, once
57460C...for the second line, and then once for all the lines (it is
57461C...impossible to get just the last line out) without multiplying by
57462C...couplings. The last line is then obtained as the result of the third
57463C...call minus the results of the two first calls. Each term is then
57464C...multiplied by its respective coupling before the whole thing is
57465C...summed up in XLAM.
57466C...Note that with three interfering resonances, this procedure becomes
57467C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57468
57469 IF (imss(53).GE.1) THEN
57470C...LOOP OVER DECAY MODES
57471 DO 190 isc=1,25
57472
57473C...CHI+ -> U_I + U_J + D_K
57474C...Decay mode I<->J symmetric.
57475 IF (mod(isc/9,3).LE.mod(isc/3,3).AND.isc.NE.13) THEN
57476 lknt = lknt+1
57477 idlam(lknt,1) = 2 +2*mod(isc/9,3)
57478 idlam(lknt,2) = 2 +2*mod(isc/3,3)
57479 idlam(lknt,3) = 1 +2*mod(isc,3)
57480 xlam(lknt) = 0d0
57481C...Set coupling, and decay product masses on/off
57482 rvlamc= 6. * gw2 * 5d-1
57483 rvljik= rvlamb(mod(isc/3,3)+1,mod(isc/9,3)+1,mod(isc,3)
57484 & +1)
57485 rvlijk= rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)
57486 & +1)
57487 IF (mod(isc/9,3).EQ.mod(isc/3,3)) rvlamc = 5d-1
57488 & * rvlamc
57489 dcmass=.false.
57490 IF (idlam(lknt,1).EQ.6.OR.idlam(lknt,2).EQ.6
57491 & .OR.idlam(lknt,3).EQ.5) dcmass =.true.
57492C...Resonance KF codes (1=I,2=J,3=K)
57493 kfr(1) = -idlam(lknt,1)+1
57494 kfr(2) = 0
57495 kfr(3) = 0
57496C...Calculate width.
57497 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57498 & idlam(lknt,3),xresi)
57499C...Resonance KF codes (1=I,2=J,3=K)
57500 kfr(1) = 0
57501 kfr(2) = -idlam(lknt,2)+1
57502 kfr(3) = 0
57503C...Calculate width.
57504 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57505 & idlam(lknt,3),xresj)
57506C...Resonance KF codes (1=I,2=J,3=K)
57507 kfr(1) = -idlam(lknt,1)+1
57508 kfr(2) = -idlam(lknt,2)+1
57509 kfr(3) = 0
57510C...Calculate width.
57511 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57512 & idlam(lknt,3),xresij)
57513 IF (abs(xresi+xresj-xresij).GT.1d-4*xresij) THEN
57514 xresij = xresij-xresi-xresj
57515 ELSE
57516 xresij = 0d0
57517 ENDIF
57518C...CALCULATE TOTAL WIDTH
57519 xlam(lknt) = rvljik**2 * xresi + rvlijk**2 * xresj
57520 & + rvljik*rvlijk * xresij
57521 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57522C...KINEMATICS CHECK
57523 IF (xlam(lknt).EQ.0d0) THEN
57524 lknt=lknt-1
57525 ENDIF
57526 ENDIF
57527C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57528C...Symmetry I<->J<->K.
57529 IF ((mod(isc/9,3).LE.mod(isc/3,3)).AND.(mod(isc/3,3).le
57530 & .mod(isc,3)).AND.isc.NE.13) THEN
57531 lknt = lknt+1
57532 idlam(lknt,1) = -1 -2*mod(isc/9,3)
57533 idlam(lknt,2) = -1 -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 rvlamc = 6. * gw2 * 5d-1
57538 rvlijk = rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)
57539 & +1)
57540 rvlkij = rvlamb(mod(isc,3)+1,mod(isc/9,3)+1,mod(isc/3,3)
57541 & +1)
57542 rvljki = rvlamb(mod(isc/3,3)+1,mod(isc,3)+1,mod(isc/9,3)
57543 & +1)
57544 dcmass = .false.
57545 IF (idlam(lknt,1).EQ.-5.OR.idlam(lknt,2).EQ.-5
57546 & .OR.idlam(lknt,3).EQ.-5) dcmass = .true.
57547C...Collect symmetry factors
57548 IF (mod(isc/9,3).EQ.mod(isc/3,3).OR.mod(isc/3,3).eq
57549 & .mod(isc,3).OR.mod(isc/9,3).EQ.mod(isc,3))
57550 & rvlamc = 5d-1 * rvlamc
57551C...Resonance KF codes (1=I,2=J,3=K)
57552 kfr(1) = idlam(lknt,1)-1
57553 kfr(2) = 0
57554 kfr(3) = 0
57555C...Calculate width.
57556 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57557 & idlam(lknt,3),xresi)
57558C...Resonance KF codes (1=I,2=J,3=K)
57559 kfr(1) = 0
57560 kfr(2) = idlam(lknt,2)-1
57561 kfr(3) = 0
57562C...Calculate width.
57563 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57564 & idlam(lknt,3),xresj)
57565C...Resonance KF codes (1=I,2=J,3=K)
57566 kfr(1) = 0
57567 kfr(2) = 0
57568 kfr(3) = idlam(lknt,3)-1
57569C...Calculate width.
57570 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57571 & idlam(lknt,3),xresk)
57572C...Resonance KF codes (1=I,2=J,3=K)
57573 kfr(1) = idlam(lknt,1)-1
57574 kfr(2) = idlam(lknt,2)-1
57575 kfr(3) = 0
57576C...Calculate width.
57577 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57578 & idlam(lknt,3),xresij)
57579 IF (abs(xresi+xresj-xresij).GT.1d-4*(xresi+xresj)) THEN
57580 xresij = xresi+xresj-xresij
57581 ELSE
57582 xresij = 0d0
57583 ENDIF
57584C...Resonance KF codes (1=I,2=J,3=K)
57585 kfr(1) = 0
57586 kfr(2) = idlam(lknt,2)-1
57587 kfr(3) = idlam(lknt,3)-1
57588C...Calculate width.
57589 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57590 & idlam(lknt,3),xresjk)
57591 IF (abs(xresj+xresk-xresjk).GT.1d-4*(xresj+xresk)) THEN
57592 xresjk = xresj+xresk-xresjk
57593 ELSE
57594 xresjk = 0d0
57595 ENDIF
57596C...Resonance KF codes (1=I,2=J,3=K)
57597 kfr(1) = idlam(lknt,1)-1
57598 kfr(2) = 0
57599 kfr(3) = idlam(lknt,3)-1
57600C...Calculate width.
57601 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),
57602 & idlam(lknt,3),xresik)
57603 IF (abs(xresi+xresk-xresik).GT.1d-4*(xresi+xresk)) THEN
57604 xresik = xresi+xresk-xresik
57605 ELSE
57606 xresik = 0d0
57607 ENDIF
57608C...CALCULATE TOTAL WIDTH
57609 xlam(lknt) =
57610 & rvlijk**2 * xresi
57611 & + rvljki**2 * xresj
57612 & + rvlkij**2 * xresk
57613 & + rvlijk*rvljki * xresij
57614 & + rvlijk*rvlkij * xresik
57615 & + rvljki*rvlkij * xresjk
57616 xlam(lknt)=xlam(lknt)*rvlamc/((2.*paru(1)*rms(0))**3*32)
57617C...KINEMATICS CHECK
57618 IF (xlam(lknt).EQ.0d0) THEN
57619 lknt=lknt-1
57620 ENDIF
57621 ENDIF
57622 190 CONTINUE
57623 ENDIF
57624 ENDIF
57625 ENDIF
57626
57627 RETURN
57628 END
57629
57630C*********************************************************************
57631
57632C...PYRVGL
57633C...Calculates R-violating gluino decay widths.
57634C...See BV part of PYRVCH for comments about the way the BV decay width
57635C...is calculated. Same comments apply here.
57636C...P. Z. Skands
57637
57638 SUBROUTINE pyrvgl(KFIN,XLAM,IDLAM,LKNT)
57639
57640C...Double precision and integer declarations.
57641 IMPLICIT DOUBLE PRECISION(a-h, o-z)
57642 IMPLICIT INTEGER(I-N)
57643C...Parameter statement to help give large particle numbers.
57644 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57645 &kexcit=4000000,kdimen=5000000)
57646C...Commonblocks.
57647 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
57648 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57649 common/pymssm/imss(0:99),rmss(0:99)
57650 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
57651 &sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
57652 common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
57653C...Local variables.
57654 DOUBLE PRECISION XLAM(0:400)
57655 INTEGER IDLAM(400,3), PYCOMP
57656C...Information from main routine to PYRVGW
57657 common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
57658 & ,dcmass,kfr(3)
57659C...Auxiliary variables needed for BV (RV Gauge STOre)
57660 common/rvgsto/xresi,xresj,xresk,xresij,xresik,xresjk,rvlijk,rvlkij
57661 & ,rvljki,rvljik
57662C...Running quark masses
57663 DOUBLE PRECISION RMQ(6)
57664C...Decay product masses on/off
57665 LOGICAL DCMASS
57666 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57667 & /rvgsto/
57668
57669C...IF LQD OR UDD TYPE R-VIOLATION ON.
57670 IF (imss(52).GE.1.OR.imss(53).GE.1) THEN
57671 kfsm=kfin-ksusy1
57672
57673C... AB(x,y,z):
57674C x=1-2 : Select A or B coupling (1:A ; 2:B)
57675C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57676C 11-16:e,nu_e,mu,... not used here)
57677C z=1-2 : Mass eigenstate number
57678 DO 100 i = 1,6
57679C...A Couplings
57680 ab(1,i,1) = sfmix(i,2)
57681 ab(1,i,2) = sfmix(i,4)
57682C...B Couplings
57683 ab(2,i,1) = -sfmix(i,1)
57684 ab(2,i,2) = -sfmix(i,3)
57685 100 CONTINUE
57686 gstr2 = 4d0*paru(1) * pyalps(pmas(pycomp(kfin),1)**2)
57687C...LQD DECAYS.
57688 IF (imss(52).GE.1) THEN
57689C...STEP IN I,J,K USING SINGLE COUNTER
57690 DO 120 isc=0,26
57691C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57692 lknt = lknt+1
57693 idlam(lknt,1) =-12 -2*mod(isc/9,3)
57694 idlam(lknt,2) = -1 -2*mod(isc/3,3)
57695 idlam(lknt,3) = 1 +2*mod(isc,3)
57696 xlam(lknt)=0d0
57697C...Set coupling, and decay product masses on/off
57698 rvlamc=rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)**2
57699 & * 5d-1 * gstr2
57700 dcmass = .false.
57701 IF (idlam(lknt,2).EQ.-5.OR.idlam(lknt,3).EQ.5) dcmass=.true.
57702C...Resonance KF codes (1=I,2=J,3=K)
57703 kfr(1) = 0
57704 kfr(2) = -idlam(lknt,2)
57705 kfr(3) = -idlam(lknt,3)
57706C...Calculate width.
57707 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57708 & ,xlam(lknt))
57709C...Normalize
57710 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57711C...Charge conjugate mode.
57712 110 lknt = lknt+1
57713 idlam(lknt,1) =-idlam(lknt-1,1)
57714 idlam(lknt,2) =-idlam(lknt-1,2)
57715 idlam(lknt,3) =-idlam(lknt-1,3)
57716 xlam(lknt) = xlam(lknt-1)
57717C...KINEMATICS CHECK
57718 IF (xlam(lknt).EQ.0d0) THEN
57719 lknt=lknt-2
57720 ENDIF
57721
57722C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57723 lknt = lknt+1
57724 idlam(lknt,1) =-11 -2*mod(isc/9,3)
57725 idlam(lknt,2) = -2 -2*mod(isc/3,3)
57726 idlam(lknt,3) = 1 +2*mod(isc,3)
57727 xlam(lknt)=0d0
57728C...Set coupling, and decay product masses on/off
57729 rvlamc = rvlamp(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
57730 & **2* 5d-1 * gstr2
57731 dcmass = .false.
57732 IF (idlam(lknt,1).EQ.-15.OR.idlam(lknt,2).EQ.-6
57733 & .OR.idlam(lknt,3).EQ.5) dcmass = .true.
57734C...Resonance KF codes (1=I,2=J,3=K)
57735 kfr(1) = 0
57736 kfr(2) = -idlam(lknt,2)
57737 kfr(3) = -idlam(lknt,3)
57738C...Calculate width.
57739 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57740 & ,xlam(lknt))
57741 xlam(lknt)=xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57742C...Charge conjugate mode.
57743 lknt=lknt+1
57744 idlam(lknt,1) = -idlam(lknt-1,1)
57745 idlam(lknt,2) = -idlam(lknt-1,2)
57746 idlam(lknt,3) = -idlam(lknt-1,3)
57747 xlam(lknt) = xlam(lknt-1)
57748C...KINEMATICS CHECK
57749 IF (xlam(lknt).EQ.0d0) THEN
57750 lknt=lknt-2
57751 ENDIF
57752
57753 120 CONTINUE
57754 ENDIF
57755
57756C...UDD DECAYS.
57757 IF (imss(53).GE.1) THEN
57758C...STEP IN I,J,K USING SINGLE COUNTER
57759 DO 130 isc=0,26
57760C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57761 IF (mod(isc/3,3).LT.mod(isc,3)) THEN
57762 lknt = lknt+1
57763 idlam(lknt,1) = -2 -2*mod(isc/9,3)
57764 idlam(lknt,2) = -1 -2*mod(isc/3,3)
57765 idlam(lknt,3) = -1 -2*mod(isc,3)
57766 xlam(lknt)=0d0
57767C...Set coupling, and decay product masses on/off. A factor of 2 for
57768C...(N_C-1) has been used to cancel a factor 0.5.
57769 rvlamc=rvlamb(mod(isc/9,3)+1,mod(isc/3,3)+1,mod(isc,3)+1)
57770 & **2 * gstr2
57771 dcmass = .false.
57772 IF (idlam(lknt,1).EQ.-6.OR.idlam(lknt,2).EQ.-5
57773 & .OR.idlam(lknt,3).EQ.-5) dcmass=.true.
57774C...Resonance KF codes (1=I,2=J,3=K)
57775 kfr(1) = idlam(lknt,1)
57776 kfr(2) = 0
57777 kfr(3) = 0
57778C...Calculate width.
57779 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57780 & ,xresi)
57781C...Resonance KF codes (1=I,2=J,3=K)
57782 kfr(1) = 0
57783 kfr(2) = idlam(lknt,2)
57784 kfr(3) = 0
57785C...Calculate width.
57786 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57787 & ,xresj)
57788C...Resonance KF codes (1=I,2=J,3=K)
57789 kfr(1) = 0
57790 kfr(2) = 0
57791 kfr(3) = idlam(lknt,3)
57792C...Calculate width.
57793 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57794 & ,xresk)
57795C...Resonance KF codes (1=I,2=J,3=K)
57796 kfr(1) = idlam(lknt,1)
57797 kfr(2) = idlam(lknt,2)
57798 kfr(3) = 0
57799C...Calculate width.
57800 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57801 & ,xresij)
57802C...Calculate interference function. (Factor -1/2 to make up for factor
57803C...-2 in PYRVGW.
57804 IF (abs(xresi+xresj-xresij).GT.1d-4*xresij) THEN
57805 xresij = 5d-1 * (xresi+xresj-xresij)
57806 ELSE
57807 xresij = 0d0
57808 ENDIF
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 & ,xresjk)
57816 IF (abs(xresj+xresk-xresjk).GT.1d-4*xresjk) THEN
57817 xresjk = 5d-1 * (xresj+xresk-xresjk)
57818 ELSE
57819 xresjk = 0d0
57820 ENDIF
57821C...Resonance KF codes (1=I,2=J,3=K)
57822 kfr(1) = idlam(lknt,1)
57823 kfr(2) = 0
57824 kfr(3) = idlam(lknt,3)
57825C...Calculate width.
57826 CALL pyrvgw(kfin,idlam(lknt,1),idlam(lknt,2),idlam(lknt,3)
57827 & ,xresik)
57828 IF (abs(xresi+xresk-xresik).GT.1d-4*xresik) THEN
57829 xresik = 5d-1 * (xresi+xresk-xresik)
57830 ELSE
57831 xresik = 0d0
57832 ENDIF
57833C...Calculate total width (factor 1/2 from 1/(N_C-1))
57834 xlam(lknt) = xresi + xresj + xresk
57835 & + 5d-1 * (xresij + xresik + xresjk)
57836C...Normalize
57837 xlam(lknt) = xlam(lknt)*rvlamc/((2*paru(1)*rms(0))**3*32)
57838C...Charge conjugate mode.
57839 lknt = lknt+1
57840 idlam(lknt,1) =-idlam(lknt-1,1)
57841 idlam(lknt,2) =-idlam(lknt-1,2)
57842 idlam(lknt,3) =-idlam(lknt-1,3)
57843 xlam(lknt) = xlam(lknt-1)
57844C...KINEMATICS CHECK
57845 IF (xlam(lknt).EQ.0d0) THEN
57846 lknt=lknt-2
57847 ENDIF
57848 ENDIF
57849 130 CONTINUE
57850 ENDIF
57851 ENDIF
57852 RETURN
57853 END
57854
57855C*********************************************************************
57856
57857C...PYRVSB
57858C...Auxiliary function to PYRVSF for calculating R-Violating
57859C...sfermion widths. Though the decay products are most often treated
57860C...as massless in the calculation, the kinematical boundary of phase
57861C...space is tested using the true masses.
57862C...MODE = 1: All decay products massive
57863C...MODE = 2: Decay product 1 massless
57864C...MODE = 3: Decay product 2 massless
57865C...MODE = 4: All decay products massless
57866
57867 FUNCTION pyrvsb(KFIN,ID1,ID2,RM2,MODE)
57868
57869 IMPLICIT DOUBLE PRECISION (a-h,o-z)
57870 IMPLICIT INTEGER (I-N)
57871 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
57872 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57873 SAVE /pydat1/,/pydat2/
57874 DOUBLE PRECISION SM(3)
57875 INTEGER PYCOMP, KC(3)
57876 kc(1)=pycomp(kfin)
57877 kc(2)=pycomp(id1)
57878 kc(3)=pycomp(id2)
57879 sm(1)=pmas(kc(1),1)**2
57880 sm(2)=pmas(kc(2),1)**2
57881 sm(3)=pmas(kc(3),1)**2
57882C...Kinematics check
57883 IF ((sm(1)-(pmas(kc(2),1)+pmas(kc(3),1))**2).LE.0d0) THEN
57884 pyrvsb=0d0
57885 RETURN
57886 ENDIF
57887C...CM momenta squared
57888 IF (mode.EQ.1) THEN
57889 p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(2),1)+pmas(kc(3),1))**2)
57890 & * (sm(1)-(pmas(kc(2),1)-pmas(kc(3),1))**2)
57891 ELSE IF (mode.EQ.2) THEN
57892 p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(3),1))**2)**2
57893 ELSE IF (mode.EQ.3) THEN
57894 p2cm=1./(4*sm(1))*(sm(1)-(pmas(kc(2),1))**2)**2
57895 ELSE
57896 p2cm=sm(1)/4.
57897 ENDIF
57898C...Calculate Width
57899 pyrvsb=rm2*sqrt(max(0d0,p2cm))/(8*paru(1)*sm(1))
57900 RETURN
57901 END
57902
57903C*********************************************************************
57904
57905C...PYRVGW
57906C...Generalized Matrix Element for R-Violating 3-body widths.
57907C...P. Z. Skands
57908 SUBROUTINE pyrvgw(KFIN,ID1,ID2,ID3,XLAM)
57909
57910 IMPLICIT DOUBLE PRECISION (a-h,o-z)
57911 IMPLICIT INTEGER (I-N)
57912 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
57913 &kexcit=4000000,kdimen=5000000)
57914 parameter(eps=1d-4)
57915 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
57916 common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
57917 & ,dcmass,kfr(3)
57918 common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),
57919 & sfmix(16,4),zmixi(4,4),umixi(2,2),vmixi(2,2)
57920 DOUBLE PRECISION XLIM(3,3)
57921 INTEGER KC(0:3), PYCOMP
57922 LOGICAL DCMASS, DCHECK(6)
57923 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
57924
57925 xlam = 0d0
57926
57927 kc(0) = pycomp(kfin)
57928 kc(1) = pycomp(id1)
57929 kc(2) = pycomp(id2)
57930 kc(3) = pycomp(id3)
57931 rms(0) = pmas(kc(0),1)
57932 rms(1) = pymrun(id1,pmas(kc(1),1)**2)
57933 rms(2) = pymrun(id2,pmas(kc(2),1)**2)
57934 rms(3) = pymrun(id3,pmas(kc(3),1)**2)
57935C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
57936 xlim(1,1)=(rms(1)+rms(2))**2
57937 xlim(1,2)=(rms(0)-rms(3))**2
57938 xlim(1,3)=xlim(1,2)-xlim(1,1)
57939 xlim(2,1)=(rms(2)+rms(3))**2
57940 xlim(2,2)=(rms(0)-rms(1))**2
57941 xlim(2,3)=xlim(2,2)-xlim(2,1)
57942 xlim(3,1)=(rms(1)+rms(3))**2
57943 xlim(3,2)=(rms(0)-rms(2))**2
57944 xlim(3,3)=xlim(3,2)-xlim(3,1)
57945C...Check Phase Space
57946 IF (xlim(1,3).LT.0d0.OR.xlim(2,3).LT.0d0.OR.xlim(3,3).LT.0d0) THEN
57947 RETURN
57948 ENDIF
57949
57950C...INITIALIZE RESONANCE INFORMATION
57951 DO 110 jres = 1,3
57952 DO 100 imass = 1,2
57953 ires = 2*(jres-1)+imass
57954 intres(ires,1) = 0
57955 dcheck(ires) =.false.
57956C...NO RIGHT-HANDED NEUTRINOS
57957 IF (((imass.EQ.2).AND.((iabs(kfr(jres)).EQ.12).or
57958 & .(iabs(kfr(jres)).EQ.14).OR.(iabs(kfr(jres)).EQ.16))).or
57959 & .kfr(jres).EQ.0) GOTO 100
57960 res(ires,1) = pmas(pycomp(imass*ksusy1+iabs(kfr(jres))),1)
57961 res(ires,2) = pmas(pycomp(imass*ksusy1+iabs(kfr(jres))),2)
57962 intres(ires,1) = iabs(kfr(jres))
57963 intres(ires,2) = imass
57964 IF (kfr(jres).LT.0) intres(ires,3) = 1
57965 IF (kfr(jres).GT.0) intres(ires,3) = 0
57966 100 CONTINUE
57967 110 CONTINUE
57968
57969C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
57970
57971C...RESONANCE CONTRIBUTIONS
57972C...(Only sum contributions where the resonance is off shell).
57973C...Store whether diagram on/off in DCHECK.
57974C...LOOP OVER MASS STATES
57975 DO 120 j=1,2
57976 idr=j
57977 IF(intres(idr,1).NE.0) THEN
57978
57979 tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
57980 IF ((rms(0).LT.(rms(1)+res(idr,1)).OR.(res(idr,1).LT.(rms(2)
57981 & +rms(3)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
57982 dcheck(idr) =.true.
57983 xlam = xlam + tmix * pyrvi1(2,3,1)
57984 ENDIF
57985 ENDIF
57986
57987 idr=j+2
57988 IF(intres(idr,1).NE.0) THEN
57989 tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
57990 IF ((rms(0).LT.(rms(2)+res(idr,1)).OR.(res(idr,1).LT.(rms(1)
57991 & +rms(3)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
57992 dcheck(idr) =.true.
57993 xlam = xlam + tmix * pyrvi1(1,3,2)
57994 ENDIF
57995 ENDIF
57996
57997 idr=j+4
57998 IF(intres(idr,1).NE.0) THEN
57999 tmix = sfmix(intres(idr,1),2*j+intres(idr,3)-1)**2
58000 IF ((rms(0).LT.(rms(3)+res(idr,1)).OR.(res(idr,1).LT.(rms(1)
58001 & +rms(2)))).AND.tmix.GT.eps.AND.intres(idr,1).NE.0) THEN
58002 dcheck(idr) =.true.
58003 xlam = xlam + tmix * pyrvi1(1,2,3)
58004 ENDIF
58005 ENDIF
58006 120 CONTINUE
58007C... L-R INTERFERENCES
58008C... (Only add contributions where both contributing diagrams
58009C... are non-resonant).
58010 idr=1
58011 IF (dcheck(1).AND.dcheck(2)) THEN
58012C...Bug corrected 11/12 2001. Skands.
58013 xlam = xlam + 2d0 * pyrvi2(2,3,1)
58014 & * sfmix(intres(1,1),2+intres(1,3)-1)
58015 & * sfmix(intres(2,1),4+intres(2,3)-1)
58016 ENDIF
58017
58018 idr=3
58019 IF (dcheck(3).AND.dcheck(4)) THEN
58020 xlam = xlam + 2d0 * pyrvi2(1,3,2)
58021 & * sfmix(intres(3,1),2+intres(3,3)-1)
58022 & * sfmix(intres(4,1),4+intres(4,3)-1)
58023 ENDIF
58024
58025 idr=5
58026 IF (dcheck(5).AND.dcheck(6)) THEN
58027 xlam = xlam + 2d0 * pyrvi2(1,2,3)
58028 & * sfmix(intres(5,1),2+intres(5,3)-1)
58029 & * sfmix(intres(6,1),4+intres(6,3)-1)
58030 ENDIF
58031C... TRUE INTERFERENCES
58032C... (Only add contributions where both contributing diagrams
58033C... are non-resonant).
58034 pref=-2d0
58035 IF ((kfin-ksusy1).EQ.24.OR.(kfin-ksusy1).EQ.37) pref=2d0
58036 DO 140 ikr1 = 1,2
58037 DO 130 ikr2 = 1,2
58038 idr = ikr1+2
58039 idr2 = ikr2
58040 IF (dcheck(idr).AND.dcheck(idr2)) THEN
58041 xlam = xlam + pref*pyrvi3(1,3,2) *
58042 & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
58043 & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
58044 ENDIF
58045
58046 idr = ikr1+4
58047 idr2 = ikr2
58048 IF (dcheck(idr).AND.dcheck(idr2)) THEN
58049 xlam = xlam + pref*pyrvi3(1,2,3) *
58050 & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
58051 & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
58052 ENDIF
58053
58054 idr = ikr1+4
58055 idr2 = ikr2+2
58056 IF (dcheck(idr).AND.dcheck(idr2)) THEN
58057 xlam = xlam + pref*pyrvi3(2,1,3) *
58058 & sfmix(intres(idr,1),2*ikr1+intres(idr,3)-1)
58059 & *sfmix(intres(idr2,1),2*ikr2+intres(idr2,3)-1)
58060 ENDIF
58061 130 CONTINUE
58062 140 CONTINUE
58063
58064 RETURN
58065 END
58066
58067C*********************************************************************
58068
58069C...PYRVI1
58070C...Function to integrate resonance contributions
58071
58072 FUNCTION pyrvi1(ID1,ID2,ID3)
58073
58074 IMPLICIT NONE
58075 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58076 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58077 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58078 LOGICAL MFLAG,DCMASS
58079 EXTERNAL pyrvg1,pygaus
58080 common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58081 & ,dcmass,kfr(3)
58082 common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58083 SAVE/pyrvnv/,/pyrvpm/
58084C...Initialize mass and width information
58085 pyrvi1 = 0d0
58086 rm(0) = rms(0)
58087 rm(1) = rms(id1)
58088 rm(2) = rms(id2)
58089 rm(3) = rms(id3)
58090 resm(1)= res(idr,1)
58091 resw(1)= res(idr,2)
58092C...A->B and B->A for antisparticles
58093 a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
58094 b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
58095C...Integration boundaries and mass flag
58096 lo = (rm(1)+rm(2))**2
58097 hi = (rm(0)-rm(3))**2
58098 mflag = dcmass
58099 pyrvi1 = pygaus(pyrvg1,lo,hi,1d-3)
58100 RETURN
58101 END
58102
58103C*********************************************************************
58104
58105C...PYRVI2
58106C...Function to integrate L-R interference contributions
58107
58108 FUNCTION pyrvi2(ID1,ID2,ID3)
58109
58110 IMPLICIT NONE
58111 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58112 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58113 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58114 LOGICAL MFLAG,DCMASS
58115 EXTERNAL pyrvg2,pygaus
58116 common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58117 & ,dcmass,kfr(3)
58118 common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58119 SAVE/pyrvnv/,/pyrvpm/
58120C...Initialize mass and width information
58121 pyrvi2 = 0d0
58122 rm(0) = rms(0)
58123 rm(1) = rms(id1)
58124 rm(2) = rms(id2)
58125 rm(3) = rms(id3)
58126 resm(1)= res(idr,1)
58127 resw(1)= res(idr,2)
58128 resm(2)= res(idr+1,1)
58129 resw(2)= res(idr+1,2)
58130C...A->B and B->A for antisparticles
58131 a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
58132 b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
58133 a(2) = ab(1+intres(idr+1,3),intres(idr+1,1),intres(idr+1,2))
58134 b(2) = ab(2-intres(idr+1,3),intres(idr+1,1),intres(idr+1,2))
58135C...Boundaries and mass flag
58136 lo = (rm(1)+rm(2))**2
58137 hi = (rm(0)-rm(3))**2
58138 mflag = dcmass
58139 pyrvi2 = pygaus(pyrvg2,lo,hi,1d-3)
58140 RETURN
58141 END
58142
58143C*********************************************************************
58144
58145C...PYRVI3
58146C...Function to integrate true interference contributions
58147
58148 FUNCTION pyrvi3(ID1,ID2,ID3)
58149
58150 IMPLICIT NONE
58151 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58152 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58153 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58154 LOGICAL MFLAG,DCMASS
58155 EXTERNAL pyrvg3,pygaus
58156 common/pyrvnv/ab(2,16,2),rms(0:3),res(6,2),intres(6,3),idr,idr2
58157 & ,dcmass,kfr(3)
58158 common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58159 SAVE/pyrvnv/,/pyrvpm/
58160C...Initialize mass and width information
58161 pyrvi3 = 0d0
58162 rm(0) = rms(0)
58163 rm(1) = rms(id1)
58164 rm(2) = rms(id2)
58165 rm(3) = rms(id3)
58166 resm(1)= res(idr,1)
58167 resw(1)= res(idr,2)
58168 resm(2)= res(idr2,1)
58169 resw(2)= res(idr2,2)
58170C...A -> B and B -> A for antisparticles
58171 a(1) = ab(1+intres(idr,3),intres(idr,1),intres(idr,2))
58172 b(1) = ab(2-intres(idr,3),intres(idr,1),intres(idr,2))
58173 a(2) = ab(1+intres(idr2,3),intres(idr2,1),intres(idr2,2))
58174 b(2) = ab(2-intres(idr2,3),intres(idr2,1),intres(idr2,2))
58175C...Boundaries and mass flag
58176 lo = (rm(1)+rm(2))**2
58177 hi = (rm(0)-rm(3))**2
58178 mflag = dcmass
58179 pyrvi3 = pygaus(pyrvg3,lo,hi,1d-3)
58180 RETURN
58181 END
58182
58183C*********************************************************************
58184
58185C...PYRVG1
58186C...Integrand for resonance contributions
58187
58188 FUNCTION pyrvg1(X)
58189
58190 IMPLICIT NONE
58191 common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58192 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58193 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58194 LOGICAL MFLAG
58195 SAVE/pyrvpm/
58196 rvr = pyrvr(x,resm(1),resw(1))
58197 c1 = 2d0*sqrt(max(0d0,x))
58198 IF (.NOT.mflag) THEN
58199 e2 = x/c1
58200 e3 = (rm(0)**2-x)/c1
58201 deltay = 4d0*e2*e3
58202 pyrvg1 = deltay*rvr*x*(a(1)**2+b(1)**2)*(rm(0)**2-x)
58203 ELSE
58204 e2 = (x-rm(1)**2+rm(2)**2)/c1
58205 e3 = (rm(0)**2-x-rm(3)**2)/c1
58206 sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
58207 sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
58208 deltay = 4d0*sr1*sr2
58209 a1 = 4.*a(1)*b(1)*rm(3)*rm(0)
58210 a2 = (a(1)**2+b(1)**2)*(rm(0)**2+rm(3)**2-x)
58211 pyrvg1 = deltay*rvr*(x-rm(1)**2-rm(2)**2)*(a1+a2)
58212 ENDIF
58213 RETURN
58214 END
58215
58216C*********************************************************************
58217
58218C...PYRVG2
58219C...Integrand for L-R interference contributions
58220
58221 FUNCTION pyrvg2(X)
58222
58223 IMPLICIT NONE
58224 common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58225 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58226 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58227 LOGICAL MFLAG
58228 SAVE/pyrvpm/
58229 c1 = 2d0*sqrt(max(0d0,x))
58230 rvs = pyrvs(x,x,resm(1),resw(1),resm(2),resw(2))
58231 IF (.NOT.mflag) THEN
58232 e2 = x/c1
58233 e3 = (rm(0)**2-x)/c1
58234 deltay = 4d0*e2*e3
58235 pyrvg2 = deltay*rvs*x*(a(1)*a(2)+b(1)*b(2))*(rm(0)**2-x)
58236 ELSE
58237 e2 = (x-rm(1)**2+rm(2)**2)/c1
58238 e3 = (rm(0)**2-x-rm(3)**2)/c1
58239 sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
58240 sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
58241 deltay = 4d0*sr1*sr2
58242 pyrvg2 = deltay*rvs*(x-rm(1)**2-rm(2)**2)*((a(1)*a(2)
58243 & + b(1)*b(2))*(rm(0)**2+rm(3)**2-x)
58244 & + 2d0*(a(1)*b(2)+a(2)*b(1))*rm(3)*rm(0))
58245 ENDIF
58246 RETURN
58247 END
58248
58249C*********************************************************************
58250
58251C...PYRVG3
58252C...Function to do Y integration over true interference contributions
58253
58254 FUNCTION pyrvg3(X)
58255
58256 IMPLICIT NONE
58257 common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58258C...Second Dalitz variable for PYRVG4
58259 common/pyg2dx/x1
58260 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58261 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58262 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58263 LOGICAL MFLAG
58264 EXTERNAL pygau2,pyrvg4
58265 SAVE/pyrvpm/,/pyg2dx/
58266 pyrvg3=0d0
58267 c1=2d0*sqrt(max(1d-9,x))
58268 x1=x
58269 IF (.NOT.mflag) THEN
58270 e2 = x/c1
58271 e3 = (rm(0)**2-x)/c1
58272 ymin = 0d0
58273 ymax = 4d0*e2*e3
58274 ELSE
58275 e2 = (x-rm(1)**2+rm(2)**2)/c1
58276 e3 = (rm(0)**2-x-rm(3)**2)/c1
58277 sq1 = (e2+e3)**2
58278 sr1 = sqrt(max(0d0,e2**2-rm(2)**2))
58279 sr2 = sqrt(max(0d0,e3**2-rm(3)**2))
58280 ymin = sq1-(sr1+sr2)**2
58281 ymax = sq1-(sr1-sr2)**2
58282 ENDIF
58283 pyrvg3 = pygau2(pyrvg4,ymin,ymax,1d-3)
58284 RETURN
58285 END
58286
58287C*********************************************************************
58288
58289C...PYRVG4
58290C...Integrand for true intereference contributions
58291
58292 FUNCTION pyrvg4(Y)
58293
58294 IMPLICIT NONE
58295 common/pyrvpm/rm(0:3),a(2),b(2),resm(2),resw(2),mflag
58296 common/pyg2dx/x
58297 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58298 LOGICAL MFLAG
58299 SAVE /pyrvpm/,/pyg2dx/
58300 pyrvg4=0d0
58301 rvs=pyrvs(x,y,resm(1),resw(1),resm(2),resw(2))
58302 IF (.NOT.mflag) THEN
58303 pyrvg4 = rvs*b(1)*b(2)*x*y
58304 ELSE
58305 pyrvg4 = rvs*(rm(1)*rm(3)*a(1)*a(2)*(x+y-rm(1)**2-rm(3)**2)
58306 & + rm(1)*rm(0)*b(1)*a(2)*(y-rm(2)**2-rm(3)**2)
58307 & + rm(3)*rm(0)*a(1)*b(2)*(x-rm(1)**2-rm(2)**2)
58308 & + b(1)*b(2)*(x*y-(rm(1)*rm(3))**2-(rm(0)*rm(2))**2))
58309 ENDIF
58310 RETURN
58311 END
58312
58313C*********************************************************************
58314
58315C...PYRVR
58316C...Breit-Wigner for resonance contributions
58317
58318 FUNCTION pyrvr(Mab2,RM,RW)
58319
58320 IMPLICIT NONE
58321 DOUBLE PRECISION Mab2,RM,RW,PYRVR
58322 pyrvr = 1d0/((mab2-rm**2)**2+rm**2*rw**2)
58323 RETURN
58324 END
58325
58326C*********************************************************************
58327
58328C...PYRVS
58329C...Interference function
58330
58331 FUNCTION pyrvs(X,Y,M1,W1,M2,W2)
58332
58333 IMPLICIT NONE
58334 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58335 pyrvs = pyrvr(x,m1,w1)*pyrvr(y,m2,w2)*((x-m1**2)*(y-m2**2)
58336 & +w1*w2*m1*m2)
58337 RETURN
58338 END
58339
58340C*********************************************************************
58341
58342C...PY1ENT
58343C...Stores one parton/particle in commonblock PYJETS.
58344
58345 SUBROUTINE py1ent(IP,KF,PE,THE,PHI)
58346
58347C...Double precision and integer declarations.
58348 IMPLICIT DOUBLE PRECISION(a-h, o-z)
58349 IMPLICIT INTEGER(I-N)
58350 INTEGER PYK,PYCHGE,PYCOMP
58351C...Commonblocks.
58352 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58353 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58354 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58355 SAVE /pyjets/,/pydat1/,/pydat2/
58356
58357C...Standard checks.
58358 mstu(28)=0
58359 IF(mstu(12).NE.12345) CALL pylist(0)
58360 ipa=max(1,iabs(ip))
58361 IF(ipa.GT.mstu(4)) CALL pyerrm(21,
58362 &'(PY1ENT:) writing outside PYJETS memory')
58363 kc=pycomp(kf)
58364 IF(kc.EQ.0) CALL pyerrm(12,'(PY1ENT:) unknown flavour code')
58365
58366C...Find mass. Reset K, P and V vectors.
58367 pm=0d0
58368 IF(mstu(10).EQ.1) pm=p(ipa,5)
58369 IF(mstu(10).GE.2) pm=pymass(kf)
58370 DO 100 j=1,5
58371 k(ipa,j)=0
58372 p(ipa,j)=0d0
58373 v(ipa,j)=0d0
58374 100 CONTINUE
58375
58376C...Store parton/particle in K and P vectors.
58377 k(ipa,1)=1
58378 IF(ip.LT.0) k(ipa,1)=2
58379 k(ipa,2)=kf
58380 p(ipa,5)=pm
58381 p(ipa,4)=max(pe,pm)
58382 pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)
58383 p(ipa,1)=pa*sin(the)*cos(phi)
58384 p(ipa,2)=pa*sin(the)*sin(phi)
58385 p(ipa,3)=pa*cos(the)
58386
58387C...Set N. Optionally fragment/decay.
58388 n=ipa
58389 IF(ip.EQ.0) CALL pyexec
58390
58391 RETURN
58392 END
58393
58394C*********************************************************************
58395
58396C...PY2ENT
58397C...Stores two partons/particles in their CM frame,
58398C...with the first along the +z axis.
58399
58400 SUBROUTINE py2ent(IP,KF1,KF2,PECM)
58401
58402C...Double precision and integer declarations.
58403 IMPLICIT DOUBLE PRECISION(a-h, o-z)
58404 IMPLICIT INTEGER(I-N)
58405 INTEGER PYK,PYCHGE,PYCOMP
58406C...Commonblocks.
58407 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58408 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58409 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58410 SAVE /pyjets/,/pydat1/,/pydat2/
58411
58412C...Standard checks.
58413 mstu(28)=0
58414 IF(mstu(12).NE.12345) CALL pylist(0)
58415 ipa=max(1,iabs(ip))
58416 IF(ipa.GT.mstu(4)-1) CALL pyerrm(21,
58417 &'(PY2ENT:) writing outside PYJETS memory')
58418 kc1=pycomp(kf1)
58419 kc2=pycomp(kf2)
58420 IF(kc1.EQ.0.OR.kc2.EQ.0) CALL pyerrm(12,
58421 &'(PY2ENT:) unknown flavour code')
58422
58423C...Find masses. Reset K, P and V vectors.
58424 pm1=0d0
58425 IF(mstu(10).EQ.1) pm1=p(ipa,5)
58426 IF(mstu(10).GE.2) pm1=pymass(kf1)
58427 pm2=0d0
58428 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
58429 IF(mstu(10).GE.2) pm2=pymass(kf2)
58430 DO 110 i=ipa,ipa+1
58431 DO 100 j=1,5
58432 k(i,j)=0
58433 p(i,j)=0d0
58434 v(i,j)=0d0
58435 100 CONTINUE
58436 110 CONTINUE
58437
58438C...Check flavours.
58439 kq1=kchg(kc1,2)*isign(1,kf1)
58440 kq2=kchg(kc2,2)*isign(1,kf2)
58441 IF(mstu(19).EQ.1) THEN
58442 mstu(19)=0
58443 ELSE
58444 IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL pyerrm(2,
58445 & '(PY2ENT:) unphysical flavour combination')
58446 ENDIF
58447 k(ipa,2)=kf1
58448 k(ipa+1,2)=kf2
58449
58450C...Store partons/particles in K vectors for normal case.
58451 IF(ip.GE.0) THEN
58452 k(ipa,1)=1
58453 IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2
58454 k(ipa+1,1)=1
58455
58456C...Store partons in K vectors for parton shower evolution.
58457 ELSE
58458 k(ipa,1)=3
58459 k(ipa+1,1)=3
58460 k(ipa,4)=mstu(5)*(ipa+1)
58461 k(ipa,5)=k(ipa,4)
58462 k(ipa+1,4)=mstu(5)*ipa
58463 k(ipa+1,5)=k(ipa+1,4)
58464 ENDIF
58465
58466C...Check kinematics and store partons/particles in P vectors.
58467 IF(pecm.LE.pm1+pm2) CALL pyerrm(13,
58468 &'(PY2ENT:) energy smaller than sum of masses')
58469 pa=sqrt(max(0d0,(pecm**2-pm1**2-pm2**2)**2-(2d0*pm1*pm2)**2))/
58470 &(2d0*pecm)
58471 p(ipa,3)=pa
58472 p(ipa,4)=sqrt(pm1**2+pa**2)
58473 p(ipa,5)=pm1
58474 p(ipa+1,3)=-pa
58475 p(ipa+1,4)=sqrt(pm2**2+pa**2)
58476 p(ipa+1,5)=pm2
58477
58478C...Set N. Optionally fragment/decay.
58479 n=ipa+1
58480 IF(ip.EQ.0) CALL pyexec
58481
58482 RETURN
58483 END
58484
58485C*********************************************************************
58486
58487C...PY3ENT
58488C...Stores three partons or particles in their CM frame,
58489C...with the first along the +z axis and the third in the (x,z)
58490C...plane with x > 0.
58491
58492 SUBROUTINE py3ent(IP,KF1,KF2,KF3,PECM,X1,X3)
58493
58494C...Double precision and integer declarations.
58495 IMPLICIT DOUBLE PRECISION(a-h, o-z)
58496 IMPLICIT INTEGER(I-N)
58497 INTEGER PYK,PYCHGE,PYCOMP
58498C...Commonblocks.
58499 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58500 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58501 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58502 SAVE /pyjets/,/pydat1/,/pydat2/
58503
58504C...Standard checks.
58505 mstu(28)=0
58506 IF(mstu(12).NE.12345) CALL pylist(0)
58507 ipa=max(1,iabs(ip))
58508 IF(ipa.GT.mstu(4)-2) CALL pyerrm(21,
58509 &'(PY3ENT:) writing outside PYJETS memory')
58510 kc1=pycomp(kf1)
58511 kc2=pycomp(kf2)
58512 kc3=pycomp(kf3)
58513 IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL pyerrm(12,
58514 &'(PY3ENT:) unknown flavour code')
58515
58516C...Find masses. Reset K, P and V vectors.
58517 pm1=0d0
58518 IF(mstu(10).EQ.1) pm1=p(ipa,5)
58519 IF(mstu(10).GE.2) pm1=pymass(kf1)
58520 pm2=0d0
58521 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
58522 IF(mstu(10).GE.2) pm2=pymass(kf2)
58523 pm3=0d0
58524 IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
58525 IF(mstu(10).GE.2) pm3=pymass(kf3)
58526 DO 110 i=ipa,ipa+2
58527 DO 100 j=1,5
58528 k(i,j)=0
58529 p(i,j)=0d0
58530 v(i,j)=0d0
58531 100 CONTINUE
58532 110 CONTINUE
58533
58534C...Check flavours.
58535 kq1=kchg(kc1,2)*isign(1,kf1)
58536 kq2=kchg(kc2,2)*isign(1,kf2)
58537 kq3=kchg(kc3,2)*isign(1,kf3)
58538 IF(mstu(19).EQ.1) THEN
58539 mstu(19)=0
58540 ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN
58541 ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.
58542 & kq1+kq3.EQ.4)) THEN
58543 ELSE
58544 CALL pyerrm(2,'(PY3ENT:) unphysical flavour combination')
58545 ENDIF
58546 k(ipa,2)=kf1
58547 k(ipa+1,2)=kf2
58548 k(ipa+2,2)=kf3
58549
58550C...Store partons/particles in K vectors for normal case.
58551 IF(ip.GE.0) THEN
58552 k(ipa,1)=1
58553 IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2
58554 k(ipa+1,1)=1
58555 IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2
58556 k(ipa+2,1)=1
58557
58558C...Store partons in K vectors for parton shower evolution.
58559 ELSE
58560 k(ipa,1)=3
58561 k(ipa+1,1)=3
58562 k(ipa+2,1)=3
58563 kcs=4
58564 IF(kq1.EQ.-1) kcs=5
58565 k(ipa,kcs)=mstu(5)*(ipa+1)
58566 k(ipa,9-kcs)=mstu(5)*(ipa+2)
58567 k(ipa+1,kcs)=mstu(5)*(ipa+2)
58568 k(ipa+1,9-kcs)=mstu(5)*ipa
58569 k(ipa+2,kcs)=mstu(5)*ipa
58570 k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
58571 ENDIF
58572
58573C...Check kinematics.
58574 mkerr=0
58575 IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*(2d0-x1-x3)*pecm.LE.pm2.OR.
58576 &0.5d0*x3*pecm.LE.pm3) mkerr=1
58577 pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
58578 pa2=sqrt(max(1d-10,(0.5d0*(2d0-x1-x3)*pecm)**2-pm2**2))
58579 pa3=sqrt(max(1d-10,(0.5d0*x3*pecm)**2-pm3**2))
58580 cthe2=(pa3**2-pa1**2-pa2**2)/(2d0*pa1*pa2)
58581 cthe3=(pa2**2-pa1**2-pa3**2)/(2d0*pa1*pa3)
58582 IF(abs(cthe2).GE.1.001d0.OR.abs(cthe3).GE.1.001d0) mkerr=1
58583 cthe3=max(-1d0,min(1d0,cthe3))
58584 IF(mkerr.NE.0) CALL pyerrm(13,
58585 &'(PY3ENT:) unphysical kinematical variable setup')
58586
58587C...Store partons/particles in P vectors.
58588 p(ipa,3)=pa1
58589 p(ipa,4)=sqrt(pa1**2+pm1**2)
58590 p(ipa,5)=pm1
58591 p(ipa+2,1)=pa3*sqrt(1d0-cthe3**2)
58592 p(ipa+2,3)=pa3*cthe3
58593 p(ipa+2,4)=sqrt(pa3**2+pm3**2)
58594 p(ipa+2,5)=pm3
58595 p(ipa+1,1)=-p(ipa+2,1)
58596 p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)
58597 p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)
58598 p(ipa+1,5)=pm2
58599
58600C...Set N. Optionally fragment/decay.
58601 n=ipa+2
58602 IF(ip.EQ.0) CALL pyexec
58603
58604 RETURN
58605 END
58606
58607C*********************************************************************
58608
58609C...PY4ENT
58610C...Stores four partons or particles in their CM frame, with
58611C...the first along the +z axis, the last in the xz plane with x > 0
58612C...and the second having y < 0 and y > 0 with equal probability.
58613
58614 SUBROUTINE py4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58615
58616C...Double precision and integer declarations.
58617 IMPLICIT DOUBLE PRECISION(a-h, o-z)
58618 IMPLICIT INTEGER(I-N)
58619 INTEGER PYK,PYCHGE,PYCOMP
58620C...Commonblocks.
58621 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58622 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58623 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
58624 SAVE /pyjets/,/pydat1/,/pydat2/
58625
58626C...Standard checks.
58627 mstu(28)=0
58628 IF(mstu(12).NE.12345) CALL pylist(0)
58629 ipa=max(1,iabs(ip))
58630 IF(ipa.GT.mstu(4)-3) CALL pyerrm(21,
58631 &'(PY4ENT:) writing outside PYJETS momory')
58632 kc1=pycomp(kf1)
58633 kc2=pycomp(kf2)
58634 kc3=pycomp(kf3)
58635 kc4=pycomp(kf4)
58636 IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL pyerrm(12,
58637 &'(PY4ENT:) unknown flavour code')
58638
58639C...Find masses. Reset K, P and V vectors.
58640 pm1=0d0
58641 IF(mstu(10).EQ.1) pm1=p(ipa,5)
58642 IF(mstu(10).GE.2) pm1=pymass(kf1)
58643 pm2=0d0
58644 IF(mstu(10).EQ.1) pm2=p(ipa+1,5)
58645 IF(mstu(10).GE.2) pm2=pymass(kf2)
58646 pm3=0d0
58647 IF(mstu(10).EQ.1) pm3=p(ipa+2,5)
58648 IF(mstu(10).GE.2) pm3=pymass(kf3)
58649 pm4=0d0
58650 IF(mstu(10).EQ.1) pm4=p(ipa+3,5)
58651 IF(mstu(10).GE.2) pm4=pymass(kf4)
58652 DO 110 i=ipa,ipa+3
58653 DO 100 j=1,5
58654 k(i,j)=0
58655 p(i,j)=0d0
58656 v(i,j)=0d0
58657 100 CONTINUE
58658 110 CONTINUE
58659
58660C...Check flavours.
58661 kq1=kchg(kc1,2)*isign(1,kf1)
58662 kq2=kchg(kc2,2)*isign(1,kf2)
58663 kq3=kchg(kc3,2)*isign(1,kf3)
58664 kq4=kchg(kc4,2)*isign(1,kf4)
58665 IF(mstu(19).EQ.1) THEN
58666 mstu(19)=0
58667 ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN
58668 ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.
58669 & kq1+kq4.EQ.4)) THEN
58670 ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0d0)
58671 & THEN
58672 ELSE
58673 CALL pyerrm(2,'(PY4ENT:) unphysical flavour combination')
58674 ENDIF
58675 k(ipa,2)=kf1
58676 k(ipa+1,2)=kf2
58677 k(ipa+2,2)=kf3
58678 k(ipa+3,2)=kf4
58679
58680C...Store partons/particles in K vectors for normal case.
58681 IF(ip.GE.0) THEN
58682 k(ipa,1)=1
58683 IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2
58684 k(ipa+1,1)=1
58685 IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))
58686 & k(ipa+1,1)=2
58687 k(ipa+2,1)=1
58688 IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2
58689 k(ipa+3,1)=1
58690
58691C...Store partons for parton shower evolution from q-g-g-qbar or
58692C...g-g-g-g event.
58693 ELSEIF(kq1+kq2.NE.0) THEN
58694 k(ipa,1)=3
58695 k(ipa+1,1)=3
58696 k(ipa+2,1)=3
58697 k(ipa+3,1)=3
58698 kcs=4
58699 IF(kq1.EQ.-1) kcs=5
58700 k(ipa,kcs)=mstu(5)*(ipa+1)
58701 k(ipa,9-kcs)=mstu(5)*(ipa+3)
58702 k(ipa+1,kcs)=mstu(5)*(ipa+2)
58703 k(ipa+1,9-kcs)=mstu(5)*ipa
58704 k(ipa+2,kcs)=mstu(5)*(ipa+3)
58705 k(ipa+2,9-kcs)=mstu(5)*(ipa+1)
58706 k(ipa+3,kcs)=mstu(5)*ipa
58707 k(ipa+3,9-kcs)=mstu(5)*(ipa+2)
58708
58709C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58710 ELSE
58711 k(ipa,1)=3
58712 k(ipa+1,1)=3
58713 k(ipa+2,1)=3
58714 k(ipa+3,1)=3
58715 k(ipa,4)=mstu(5)*(ipa+1)
58716 k(ipa,5)=k(ipa,4)
58717 k(ipa+1,4)=mstu(5)*ipa
58718 k(ipa+1,5)=k(ipa+1,4)
58719 k(ipa+2,4)=mstu(5)*(ipa+3)
58720 k(ipa+2,5)=k(ipa+2,4)
58721 k(ipa+3,4)=mstu(5)*(ipa+2)
58722 k(ipa+3,5)=k(ipa+3,4)
58723 ENDIF
58724
58725C...Check kinematics.
58726 mkerr=0
58727 IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*x2*pecm.LE.pm2.OR.
58728 &0.5d0*(2d0-x1-x2-x4)*pecm.LE.pm3.OR.0.5d0*x4*pecm.LE.pm4)
58729 &mkerr=1
58730 pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))
58731 pa2=sqrt(max(1d-10,(0.5d0*x2*pecm)**2-pm2**2))
58732 pa4=sqrt(max(1d-10,(0.5d0*x4*pecm)**2-pm4**2))
58733 x24=x1+x2+x4-1d0-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2
58734 cthe4=(x1*x4-2d0*x14)*pecm**2/(4d0*pa1*pa4)
58735 IF(abs(cthe4).GE.1.002d0) mkerr=1
58736 cthe4=max(-1d0,min(1d0,cthe4))
58737 sthe4=sqrt(1d0-cthe4**2)
58738 cthe2=(x1*x2-2d0*x12)*pecm**2/(4d0*pa1*pa2)
58739 IF(abs(cthe2).GE.1.002d0) mkerr=1
58740 cthe2=max(-1d0,min(1d0,cthe2))
58741 sthe2=sqrt(1d0-cthe2**2)
58742 cphi2=((x2*x4-2d0*x24)*pecm**2-4d0*pa2*cthe2*pa4*cthe4)/
58743 &max(1d-8*pecm**2,4d0*pa2*sthe2*pa4*sthe4)
58744 IF(abs(cphi2).GE.1.05d0) mkerr=1
58745 cphi2=max(-1d0,min(1d0,cphi2))
58746 IF(mkerr.EQ.1) CALL pyerrm(13,
58747 &'(PY4ENT:) unphysical kinematical variable setup')
58748
58749C...Store partons/particles in P vectors.
58750 p(ipa,3)=pa1
58751 p(ipa,4)=sqrt(pa1**2+pm1**2)
58752 p(ipa,5)=pm1
58753 p(ipa+3,1)=pa4*sthe4
58754 p(ipa+3,3)=pa4*cthe4
58755 p(ipa+3,4)=sqrt(pa4**2+pm4**2)
58756 p(ipa+3,5)=pm4
58757 p(ipa+1,1)=pa2*sthe2*cphi2
58758 p(ipa+1,2)=pa2*sthe2*sqrt(1d0-cphi2**2)*(-1d0)**int(pyr(0)+0.5d0)
58759 p(ipa+1,3)=pa2*cthe2
58760 p(ipa+1,4)=sqrt(pa2**2+pm2**2)
58761 p(ipa+1,5)=pm2
58762 p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)
58763 p(ipa+2,2)=-p(ipa+1,2)
58764 p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)
58765 p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)
58766 p(ipa+2,5)=pm3
58767
58768C...Set N. Optionally fragment/decay.
58769 n=ipa+3
58770 IF(ip.EQ.0) CALL pyexec
58771
58772 RETURN
58773 END
58774
58775C*********************************************************************
58776
58777C...PY2FRM
58778C...An interface from a two-fermion generator to include
58779C...parton showers and hadronization.
58780
58781 SUBROUTINE py2frm(IRAD,ITAU,ICOM)
58782
58783C...Double precision and integer declarations.
58784 IMPLICIT DOUBLE PRECISION(a-h, o-z)
58785 IMPLICIT INTEGER(I-N)
58786 INTEGER PYK,PYCHGE,PYCOMP
58787C...Commonblocks.
58788 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58789 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58790 SAVE /pyjets/,/pydat1/
58791C...Local arrays.
58792 dimension ijoin(2),intau(2)
58793
58794C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58795 IF(icom.EQ.0) THEN
58796 mstu(28)=0
58797 CALL pyhepc(2)
58798 ENDIF
58799
58800C...Loop through entries and pick up all final fermions/antifermions.
58801 i1=0
58802 i2=0
58803 DO 100 i=1,n
58804 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
58805 kfa=iabs(k(i,2))
58806 IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
58807 IF(k(i,2).GT.0) THEN
58808 IF(i1.EQ.0) THEN
58809 i1=i
58810 ELSE
58811 CALL pyerrm(16,'(PY2FRM:) more than one fermion')
58812 ENDIF
58813 ELSE
58814 IF(i2.EQ.0) THEN
58815 i2=i
58816 ELSE
58817 CALL pyerrm(16,'(PY2FRM:) more than one antifermion')
58818 ENDIF
58819 ENDIF
58820 ENDIF
58821 100 CONTINUE
58822
58823C...Check that event is arranged according to conventions.
58824 IF(i1.EQ.0.OR.i2.EQ.0) THEN
58825 CALL pyerrm(16,'(PY2FRM:) event contains too few fermions')
58826 ENDIF
58827 IF(i2.LT.i1) THEN
58828 CALL pyerrm(6,'(PY2FRM:) fermions arranged in wrong order')
58829 ENDIF
58830
58831C...Check whether fermion pair is quarks or leptons.
58832 IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
58833 iql12=1
58834 ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
58835 iql12=2
58836 ELSE
58837 CALL pyerrm(16,'(PY2FRM:) fermion pair inconsistent')
58838 ENDIF
58839
58840C...Decide whether to allow or not photon radiation in showers.
58841 mstj(41)=2
58842 IF(irad.EQ.0) mstj(41)=1
58843
58844C...Do colour joining and parton showers.
58845 ip1=i1
58846 ip2=i2
58847 IF(iql12.EQ.1) THEN
58848 ijoin(1)=ip1
58849 ijoin(2)=ip2
58850 CALL pyjoin(2,ijoin)
58851 ENDIF
58852 IF(iql12.EQ.1.OR.irad.EQ.1) THEN
58853 pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
58854 & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
58855 CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
58856 ENDIF
58857
58858C...Do fragmentation and decays. Possibly except tau decay.
58859 IF(itau.EQ.0) THEN
58860 ntau=0
58861 DO 110 i=1,n
58862 IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
58863 ntau=ntau+1
58864 intau(ntau)=i
58865 k(i,1)=11
58866 ENDIF
58867 110 CONTINUE
58868 ENDIF
58869 CALL pyexec
58870 IF(itau.EQ.0) THEN
58871 DO 120 i=1,ntau
58872 k(intau(i),1)=1
58873 120 CONTINUE
58874 ENDIF
58875
58876C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58877 IF(icom.EQ.0) THEN
58878 mstu(28)=0
58879 CALL pyhepc(1)
58880 ENDIF
58881
58882 END
58883
58884C*********************************************************************
58885
58886C...PY4FRM
58887C...An interface from a four-fermion generator to include
58888C...parton showers and hadronization.
58889
58890 SUBROUTINE py4frm(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
58891
58892C...Double precision and integer declarations.
58893 IMPLICIT DOUBLE PRECISION(a-h, o-z)
58894 IMPLICIT INTEGER(I-N)
58895 INTEGER PYK,PYCHGE,PYCOMP
58896C...Commonblocks.
58897 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
58898 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
58899 common/pypars/mstp(200),parp(200),msti(200),pari(200)
58900 common/pyint1/mint(400),vint(400)
58901 SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/
58902C...Local arrays.
58903 dimension ijoin(2),intau(4)
58904
58905C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58906 IF(icom.EQ.0) THEN
58907 mstu(28)=0
58908 CALL pyhepc(2)
58909 ENDIF
58910
58911C...Loop through entries and pick up all final fermions/antifermions.
58912 i1=0
58913 i2=0
58914 i3=0
58915 i4=0
58916 DO 100 i=1,n
58917 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
58918 kfa=iabs(k(i,2))
58919 IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
58920 IF(k(i,2).GT.0) THEN
58921 IF(i1.EQ.0) THEN
58922 i1=i
58923 ELSEIF(i3.EQ.0) THEN
58924 i3=i
58925 ELSE
58926 CALL pyerrm(16,'(PY4FRM:) more than two fermions')
58927 ENDIF
58928 ELSE
58929 IF(i2.EQ.0) THEN
58930 i2=i
58931 ELSEIF(i4.EQ.0) THEN
58932 i4=i
58933 ELSE
58934 CALL pyerrm(16,'(PY4FRM:) more than two antifermions')
58935 ENDIF
58936 ENDIF
58937 ENDIF
58938 100 CONTINUE
58939
58940C...Check that event is arranged according to conventions.
58941 IF(i3.EQ.0.OR.i4.EQ.0) THEN
58942 CALL pyerrm(16,'(PY4FRM:) event contains too few fermions')
58943 ENDIF
58944 IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3) THEN
58945 CALL pyerrm(6,'(PY4FRM:) fermions arranged in wrong order')
58946 ENDIF
58947
58948C...Check which fermion pairs are quarks and which leptons.
58949 IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
58950 iql12=1
58951 ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
58952 iql12=2
58953 ELSE
58954 CALL pyerrm(16,'(PY4FRM:) first fermion pair inconsistent')
58955 ENDIF
58956 IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
58957 iql34=1
58958 ELSEIF(iabs(k(i3,2)).GT.10.AND.iabs(k(i4,2)).GT.10) THEN
58959 iql34=2
58960 ELSE
58961 CALL pyerrm(16,'(PY4FRM:) second fermion pair inconsistent')
58962 ENDIF
58963
58964C...Decide whether to allow or not photon radiation in showers.
58965 mstj(41)=2
58966 IF(irad.EQ.0) mstj(41)=1
58967
58968C...Decide on dipole pairing.
58969 ip1=i1
58970 ip2=i2
58971 ip3=i3
58972 ip4=i4
58973 IF(iql12.EQ.iql34) THEN
58974 r1sq=a1sq
58975 r2sq=a2sq
58976 delta=atotsq-a1sq-a2sq
58977 IF(istrat.EQ.1) THEN
58978 IF(delta.GT.0d0) r1sq=r1sq+delta
58979 IF(delta.LT.0d0) r2sq=max(0d0,r2sq+delta)
58980 ELSEIF(istrat.EQ.2) THEN
58981 IF(delta.GT.0d0) r2sq=r2sq+delta
58982 IF(delta.LT.0d0) r1sq=max(0d0,r1sq+delta)
58983 ENDIF
58984 IF(r2sq.GT.pyr(0)*(r1sq+r2sq)) THEN
58985 ip2=i4
58986 ip4=i2
58987 ENDIF
58988 ENDIF
58989
58990C...If colour reconnection then bookkeep W+W- or Z0Z0
58991C...and copy q qbar q qbar consecutively.
58992 IF(mstp(115).GE.1.AND.iql12.EQ.1.AND.iql34.EQ.1) THEN
58993 k(n+1,1)=11
58994 k(n+1,3)=ip1
58995 k(n+1,4)=n+3
58996 k(n+1,5)=n+4
58997 k(n+2,1)=11
58998 k(n+2,3)=ip3
58999 k(n+2,4)=n+5
59000 k(n+2,5)=n+6
59001 IF(k(ip1,2)+k(ip2,2).EQ.0) THEN
59002 k(n+1,2)=23
59003 k(n+2,2)=23
59004 mint(1)=22
59005 ELSEIF(pychge(k(ip1,2)).GT.0) THEN
59006 k(n+1,2)=24
59007 k(n+2,2)=-24
59008 mint(1)=25
59009 ELSE
59010 k(n+1,2)=-24
59011 k(n+2,2)=24
59012 mint(1)=25
59013 ENDIF
59014 DO 110 j=1,5
59015 k(n+3,j)=k(ip1,j)
59016 k(n+4,j)=k(ip2,j)
59017 k(n+5,j)=k(ip3,j)
59018 k(n+6,j)=k(ip4,j)
59019 p(n+1,j)=p(ip1,j)+p(ip2,j)
59020 p(n+2,j)=p(ip3,j)+p(ip4,j)
59021 p(n+3,j)=p(ip1,j)
59022 p(n+4,j)=p(ip2,j)
59023 p(n+5,j)=p(ip3,j)
59024 p(n+6,j)=p(ip4,j)
59025 v(n+1,j)=v(ip1,j)
59026 v(n+2,j)=v(ip3,j)
59027 v(n+3,j)=v(ip1,j)
59028 v(n+4,j)=v(ip2,j)
59029 v(n+5,j)=v(ip3,j)
59030 v(n+6,j)=v(ip4,j)
59031 110 CONTINUE
59032 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59033 & p(n+1,3)**2))
59034 p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59035 & p(n+2,3)**2))
59036 k(n+3,3)=n+1
59037 k(n+4,3)=n+1
59038 k(n+5,3)=n+2
59039 k(n+6,3)=n+2
59040C...Remove original q qbar q qbar and update counters.
59041 k(ip1,1)=k(ip1,1)+10
59042 k(ip2,1)=k(ip2,1)+10
59043 k(ip3,1)=k(ip3,1)+10
59044 k(ip4,1)=k(ip4,1)+10
59045 iw1=n+1
59046 iw2=n+2
59047 nsd1=n+2
59048 ip1=n+3
59049 ip2=n+4
59050 ip3=n+5
59051 ip4=n+6
59052 n=n+6
59053 ENDIF
59054
59055C...Do colour joinings and parton showers.
59056 IF(iql12.EQ.1) THEN
59057 ijoin(1)=ip1
59058 ijoin(2)=ip2
59059 CALL pyjoin(2,ijoin)
59060 ENDIF
59061 IF(iql12.EQ.1.OR.irad.EQ.1) THEN
59062 pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
59063 & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
59064 CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
59065 ENDIF
59066 naft1=n
59067 IF(iql34.EQ.1) THEN
59068 ijoin(1)=ip3
59069 ijoin(2)=ip4
59070 CALL pyjoin(2,ijoin)
59071 ENDIF
59072 IF(iql34.EQ.1.OR.irad.EQ.1) THEN
59073 pm34s=(p(ip3,4)+p(ip4,4))**2-(p(ip3,1)+p(ip4,1))**2-
59074 & (p(ip3,2)+p(ip4,2))**2-(p(ip3,3)+p(ip4,3))**2
59075 CALL pyshow(ip3,ip4,sqrt(max(0d0,pm34s)))
59076 ENDIF
59077
59078C...Optionally do colour reconnection.
59079 mint(32)=0
59080 msti(32)=0
59081 IF(mstp(115).GE.1.AND.iql12.EQ.1.AND.iql34.EQ.1) THEN
59082 CALL pyreco(iw1,iw2,nsd1,naft1)
59083 msti(32)=mint(32)
59084 ENDIF
59085
59086C...Do fragmentation and decays. Possibly except tau decay.
59087 IF(itau.EQ.0) THEN
59088 ntau=0
59089 DO 120 i=1,n
59090 IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
59091 ntau=ntau+1
59092 intau(ntau)=i
59093 k(i,1)=11
59094 ENDIF
59095 120 CONTINUE
59096 ENDIF
59097 CALL pyexec
59098 IF(itau.EQ.0) THEN
59099 DO 130 i=1,ntau
59100 k(intau(i),1)=1
59101 130 CONTINUE
59102 ENDIF
59103
59104C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59105 IF(icom.EQ.0) THEN
59106 mstu(28)=0
59107 CALL pyhepc(1)
59108 ENDIF
59109
59110 END
59111
59112C*********************************************************************
59113
59114C...PY6FRM
59115C...An interface from a six-fermion generator to include
59116C...parton showers and hadronization.
59117
59118 SUBROUTINE py6frm(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59119
59120C...Double precision and integer declarations.
59121 IMPLICIT DOUBLE PRECISION(a-h, o-z)
59122 IMPLICIT INTEGER(I-N)
59123 INTEGER PYK,PYCHGE,PYCOMP
59124C...Commonblocks.
59125 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59126 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59127 SAVE /pyjets/,/pydat1/
59128C...Local arrays.
59129 dimension ijoin(2),intau(6),beta(3),betao(3),betan(3)
59130
59131C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59132 IF(icom.EQ.0) THEN
59133 mstu(28)=0
59134 CALL pyhepc(2)
59135 ENDIF
59136
59137C...Loop through entries and pick up all final fermions/antifermions.
59138 i1=0
59139 i2=0
59140 i3=0
59141 i4=0
59142 i5=0
59143 i6=0
59144 DO 100 i=1,n
59145 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
59146 kfa=iabs(k(i,2))
59147 IF((kfa.GE.1.AND.kfa.LE.6).OR.(kfa.GE.11.AND.kfa.LE.16)) THEN
59148 IF(k(i,2).GT.0) THEN
59149 IF(i1.EQ.0) THEN
59150 i1=i
59151 ELSEIF(i3.EQ.0) THEN
59152 i3=i
59153 ELSEIF(i5.EQ.0) THEN
59154 i5=i
59155 ELSE
59156 CALL pyerrm(16,'(PY6FRM:) more than three fermions')
59157 ENDIF
59158 ELSE
59159 IF(i2.EQ.0) THEN
59160 i2=i
59161 ELSEIF(i4.EQ.0) THEN
59162 i4=i
59163 ELSEIF(i6.EQ.0) THEN
59164 i6=i
59165 ELSE
59166 CALL pyerrm(16,'(PY6FRM:) more than three antifermions')
59167 ENDIF
59168 ENDIF
59169 ENDIF
59170 100 CONTINUE
59171
59172C...Check that event is arranged according to conventions.
59173 IF(i5.EQ.0.OR.i6.EQ.0) THEN
59174 CALL pyerrm(16,'(PY6FRM:) event contains too few fermions')
59175 ENDIF
59176 IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3.OR.i5.LT.i4.OR.i6.LT.i5) THEN
59177 CALL pyerrm(6,'(PY6FRM:) fermions arranged in wrong order')
59178 ENDIF
59179
59180C...Check which fermion pairs are quarks and which leptons.
59181 IF(iabs(k(i1,2)).LT.10.AND.iabs(k(i2,2)).LT.10) THEN
59182 iql12=1
59183 ELSEIF(iabs(k(i1,2)).GT.10.AND.iabs(k(i2,2)).GT.10) THEN
59184 iql12=2
59185 ELSE
59186 CALL pyerrm(16,'(PY6FRM:) first fermion pair inconsistent')
59187 ENDIF
59188 IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
59189 iql34=1
59190 ELSEIF(iabs(k(i3,2)).GT.10.AND.iabs(k(i4,2)).GT.10) THEN
59191 iql34=2
59192 ELSE
59193 CALL pyerrm(16,'(PY6FRM:) second fermion pair inconsistent')
59194 ENDIF
59195 IF(iabs(k(i5,2)).LT.10.AND.iabs(k(i6,2)).LT.10) THEN
59196 iql56=1
59197 ELSEIF(iabs(k(i5,2)).GT.10.AND.iabs(k(i6,2)).GT.10) THEN
59198 iql56=2
59199 ELSE
59200 CALL pyerrm(16,'(PY6FRM:) third fermion pair inconsistent')
59201 ENDIF
59202
59203C...Decide whether to allow or not photon radiation in showers.
59204 mstj(41)=2
59205 IF(irad.EQ.0) mstj(41)=1
59206
59207C...Allow dipole pairings only among leptons and quarks separately.
59208 p12d=p12
59209 p13d=0d0
59210 IF(iql34.EQ.iql56) p13d=p13
59211 p21d=0d0
59212 IF(iql12.EQ.iql34) p21d=p21
59213 p23d=0d0
59214 IF(iql12.EQ.iql34.AND.iql12.EQ.iql56) p23d=p23
59215 p31d=0d0
59216 IF(iql12.EQ.iql34.AND.iql12.EQ.iql56) p31d=p31
59217 p32d=0d0
59218 IF(iql12.EQ.iql56) p32d=p32
59219
59220C...Decide whether t+tbar.
59221 itop=0
59222 IF(pyr(0).LT.ptop) THEN
59223 itop=1
59224
59225C...If t+tbar: reconstruct t's.
59226 it=n+1
59227 itb=n+2
59228 DO 110 j=1,5
59229 k(it,j)=0
59230 k(itb,j)=0
59231 p(it,j)=p(i1,j)+p(i3,j)+p(i4,j)
59232 p(itb,j)=p(i2,j)+p(i5,j)+p(i6,j)
59233 v(it,j)=0d0
59234 v(itb,j)=0d0
59235 110 CONTINUE
59236 k(it,1)=1
59237 k(itb,1)=1
59238 k(it,2)=6
59239 k(itb,2)=-6
59240 p(it,5)=sqrt(max(0d0,p(it,4)**2-p(it,1)**2-p(it,2)**2-
59241 & p(it,3)**2))
59242 p(itb,5)=sqrt(max(0d0,p(itb,4)**2-p(itb,1)**2-p(itb,2)**2-
59243 & p(itb,3)**2))
59244 n=n+2
59245
59246C...If t+tbar: colour join t's and let them shower.
59247 ijoin(1)=it
59248 ijoin(2)=itb
59249 CALL pyjoin(2,ijoin)
59250 pmtts=(p(it,4)+p(itb,4))**2-(p(it,1)+p(itb,1))**2-
59251 & (p(it,2)+p(itb,2))**2-(p(it,3)+p(itb,3))**2
59252 CALL pyshow(it,itb,sqrt(max(0d0,pmtts)))
59253
59254C...If t+tbar: pick up the t's after shower.
59255 itnew=it
59256 itbnew=itb
59257 DO 120 i=itb+1,n
59258 IF(k(i,2).EQ.6) itnew=i
59259 IF(k(i,2).EQ.-6) itbnew=i
59260 120 CONTINUE
59261
59262C...If t+tbar: loop over two top systems.
59263 DO 200 it1=1,2
59264 IF(it1.EQ.1) THEN
59265 ito=it
59266 itn=itnew
59267 ibo=i1
59268 iw1=i3
59269 iw2=i4
59270 ELSE
59271 ito=itb
59272 itn=itbnew
59273 ibo=i2
59274 iw1=i5
59275 iw2=i6
59276 ENDIF
59277 IF(iabs(k(ibo,2)).NE.5) CALL pyerrm(6,
59278 & '(PY6FRM:) not b in t decay')
59279
59280C...If t+tbar: find boost from original to new top frame.
59281 DO 130 j=1,3
59282 betao(j)=p(ito,j)/p(ito,4)
59283 betan(j)=p(itn,j)/p(itn,4)
59284 130 CONTINUE
59285
59286C...If t+tbar: boost copy of b by t shower and connect it in colour.
59287 n=n+1
59288 ib=n
59289 k(ib,1)=3
59290 k(ib,2)=k(ibo,2)
59291 k(ib,3)=itn
59292 DO 140 j=1,5
59293 p(ib,j)=p(ibo,j)
59294 v(ib,j)=0d0
59295 140 CONTINUE
59296 CALL pyrobo(ib,ib,0d0,0d0,-betao(1),-betao(2),-betao(3))
59297 CALL pyrobo(ib,ib,0d0,0d0,betan(1),betan(2),betan(3))
59298 k(ib,4)=mstu(5)*itn
59299 k(ib,5)=mstu(5)*itn
59300 k(itn,4)=k(itn,4)+ib
59301 k(itn,5)=k(itn,5)+ib
59302 k(itn,1)=k(itn,1)+10
59303 k(ibo,1)=k(ibo,1)+10
59304
59305C...If t+tbar: construct W recoiling against b.
59306 n=n+1
59307 iw=n
59308 DO 150 j=1,5
59309 k(iw,j)=0
59310 v(iw,j)=0d0
59311 150 CONTINUE
59312 k(iw,1)=1
59313 kchw=pychge(k(iw1,2))+pychge(k(iw2,2))
59314 IF(iabs(kchw).EQ.3) THEN
59315 k(iw,2)=isign(24,kchw)
59316 ELSE
59317 CALL pyerrm(16,'(PY6FRM:) fermion pair inconsistent with W')
59318 ENDIF
59319 k(iw,3)=iw1
59320
59321C...If t+tbar: construct W momentum, including boost by t shower.
59322 DO 160 j=1,4
59323 p(iw,j)=p(iw1,j)+p(iw2,j)
59324 160 CONTINUE
59325 p(iw,5)=sqrt(max(0d0,p(iw,4)**2-p(iw,1)**2-p(iw,2)**2-
59326 & p(iw,3)**2))
59327 CALL pyrobo(iw,iw,0d0,0d0,-betao(1),-betao(2),-betao(3))
59328 CALL pyrobo(iw,iw,0d0,0d0,betan(1),betan(2),betan(3))
59329
59330C...If t+tbar: boost b and W to top rest frame.
59331 DO 170 j=1,3
59332 beta(j)=(p(ib,j)+p(iw,j))/(p(ib,4)+p(iw,4))
59333 170 CONTINUE
59334 CALL pyrobo(ib,ib,0d0,0d0,-beta(1),-beta(2),-beta(3))
59335 CALL pyrobo(iw,iw,0d0,0d0,-beta(1),-beta(2),-beta(3))
59336
59337C...If t+tbar: let b shower and pick up modified W.
59338 pmts=(p(ib,4)+p(iw,4))**2-(p(ib,1)+p(iw,1))**2-
59339 & (p(ib,2)+p(iw,2))**2-(p(ib,3)+p(iw,3))**2
59340 CALL pyshow(ib,iw,sqrt(max(0d0,pmts)))
59341 DO 180 i=iw,n
59342 IF(iabs(k(i,2)).EQ.24) iwm=i
59343 180 CONTINUE
59344
59345C...If t+tbar: take copy of W decay products.
59346 DO 190 j=1,5
59347 k(n+1,j)=k(iw1,j)
59348 p(n+1,j)=p(iw1,j)
59349 v(n+1,j)=v(iw1,j)
59350 k(n+2,j)=k(iw2,j)
59351 p(n+2,j)=p(iw2,j)
59352 v(n+2,j)=v(iw2,j)
59353 190 CONTINUE
59354 k(iw1,1)=k(iw1,1)+10
59355 k(iw2,1)=k(iw2,1)+10
59356 k(iwm,1)=k(iwm,1)+10
59357 k(iwm,4)=n+1
59358 k(iwm,5)=n+2
59359 k(n+1,3)=iwm
59360 k(n+2,3)=iwm
59361 IF(it1.EQ.1) THEN
59362 i3=n+1
59363 i4=n+2
59364 ELSE
59365 i5=n+1
59366 i6=n+2
59367 ENDIF
59368 n=n+2
59369
59370C...If t+tbar: boost W decay products, first by effects of t shower,
59371C...then by those of b shower. b and its shower simple boost back.
59372 CALL pyrobo(n-1,n,0d0,0d0,-betao(1),-betao(2),-betao(3))
59373 CALL pyrobo(n-1,n,0d0,0d0,betan(1),betan(2),betan(3))
59374 CALL pyrobo(n-1,n,0d0,0d0,-beta(1),-beta(2),-beta(3))
59375 CALL pyrobo(n-1,n,0d0,0d0,-p(iw,1)/p(iw,4),
59376 & -p(iw,2)/p(iw,4),-p(iw,3)/p(iw,4))
59377 CALL pyrobo(n-1,n,0d0,0d0,p(iwm,1)/p(iwm,4),
59378 & p(iwm,2)/p(iwm,4),p(iwm,3)/p(iwm,4))
59379 CALL pyrobo(ib,ib,0d0,0d0,beta(1),beta(2),beta(3))
59380 CALL pyrobo(iw,n,0d0,0d0,beta(1),beta(2),beta(3))
59381 200 CONTINUE
59382 ENDIF
59383
59384C...Decide on dipole pairing.
59385 ip1=i1
59386 ip3=i3
59387 ip5=i5
59388 prn=pyr(0)*(p12d+p13d+p21d+p23d+p31d+p32d)
59389 IF(itop.EQ.1.OR.prn.LT.p12d) THEN
59390 ip2=i2
59391 ip4=i4
59392 ip6=i6
59393 ELSEIF(prn.LT.p12d+p13d) THEN
59394 ip2=i2
59395 ip4=i6
59396 ip6=i4
59397 ELSEIF(prn.LT.p12d+p13d+p21d) THEN
59398 ip2=i4
59399 ip4=i2
59400 ip6=i6
59401 ELSEIF(prn.LT.p12d+p13d+p21d+p23d) THEN
59402 ip2=i4
59403 ip4=i6
59404 ip6=i2
59405 ELSEIF(prn.LT.p12d+p13d+p21d+p23d+p31d) THEN
59406 ip2=i6
59407 ip4=i2
59408 ip6=i4
59409 ELSE
59410 ip2=i6
59411 ip4=i4
59412 ip6=i2
59413 ENDIF
59414
59415C...Do colour joinings and parton showers
59416C...(except ones already made for t+tbar).
59417 IF(itop.EQ.0) THEN
59418 IF(iql12.EQ.1) THEN
59419 ijoin(1)=ip1
59420 ijoin(2)=ip2
59421 CALL pyjoin(2,ijoin)
59422 ENDIF
59423 IF(iql12.EQ.1.OR.irad.EQ.1) THEN
59424 pm12s=(p(ip1,4)+p(ip2,4))**2-(p(ip1,1)+p(ip2,1))**2-
59425 & (p(ip1,2)+p(ip2,2))**2-(p(ip1,3)+p(ip2,3))**2
59426 CALL pyshow(ip1,ip2,sqrt(max(0d0,pm12s)))
59427 ENDIF
59428 ENDIF
59429 IF(iql34.EQ.1) THEN
59430 ijoin(1)=ip3
59431 ijoin(2)=ip4
59432 CALL pyjoin(2,ijoin)
59433 ENDIF
59434 IF(iql34.EQ.1.OR.irad.EQ.1) THEN
59435 pm34s=(p(ip3,4)+p(ip4,4))**2-(p(ip3,1)+p(ip4,1))**2-
59436 & (p(ip3,2)+p(ip4,2))**2-(p(ip3,3)+p(ip4,3))**2
59437 CALL pyshow(ip3,ip4,sqrt(max(0d0,pm34s)))
59438 ENDIF
59439 IF(iql56.EQ.1) THEN
59440 ijoin(1)=ip5
59441 ijoin(2)=ip6
59442 CALL pyjoin(2,ijoin)
59443 ENDIF
59444 IF(iql56.EQ.1.OR.irad.EQ.1) THEN
59445 pm56s=(p(ip5,4)+p(ip6,4))**2-(p(ip5,1)+p(ip6,1))**2-
59446 & (p(ip5,2)+p(ip6,2))**2-(p(ip5,3)+p(ip6,3))**2
59447 CALL pyshow(ip5,ip6,sqrt(max(0d0,pm56s)))
59448 ENDIF
59449
59450C...Do fragmentation and decays. Possibly except tau decay.
59451 IF(itau.EQ.0) THEN
59452 ntau=0
59453 DO 210 i=1,n
59454 IF(iabs(k(i,2)).EQ.15.AND.k(i,1).EQ.1) THEN
59455 ntau=ntau+1
59456 intau(ntau)=i
59457 k(i,1)=11
59458 ENDIF
59459 210 CONTINUE
59460 ENDIF
59461 CALL pyexec
59462 IF(itau.EQ.0) THEN
59463 DO 220 i=1,ntau
59464 k(intau(i),1)=1
59465 220 CONTINUE
59466 ENDIF
59467
59468C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59469 IF(icom.EQ.0) THEN
59470 mstu(28)=0
59471 CALL pyhepc(1)
59472 ENDIF
59473
59474 END
59475
59476C*********************************************************************
59477
59478C...PY4JET
59479C...An interface from a four-parton generator to include
59480C...parton showers and hadronization.
59481
59482 SUBROUTINE py4jet(PMAX,IRAD,ICOM)
59483
59484C...Double precision and integer declarations.
59485 IMPLICIT DOUBLE PRECISION(a-h, o-z)
59486 IMPLICIT INTEGER(I-N)
59487 INTEGER PYK,PYCHGE,PYCOMP
59488C...Commonblocks.
59489 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59490 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59491 SAVE /pyjets/,/pydat1/
59492C...Local arrays.
59493 dimension ijoin(2),ptot(4),beta(3)
59494
59495C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59496 IF(icom.EQ.0) THEN
59497 mstu(28)=0
59498 CALL pyhepc(2)
59499 ENDIF
59500
59501C...Loop through entries and pick up all final partons.
59502 i1=0
59503 i2=0
59504 i3=0
59505 i4=0
59506 DO 100 i=1,n
59507 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
59508 kfa=iabs(k(i,2))
59509 IF((kfa.GE.1.AND.kfa.LE.6).OR.kfa.EQ.21) THEN
59510 IF(k(i,2).GT.0.AND.k(i,2).LE.6) THEN
59511 IF(i1.EQ.0) THEN
59512 i1=i
59513 ELSEIF(i3.EQ.0) THEN
59514 i3=i
59515 ELSE
59516 CALL pyerrm(16,'(PY4JET:) more than two quarks')
59517 ENDIF
59518 ELSEIF(k(i,2).LT.0) THEN
59519 IF(i2.EQ.0) THEN
59520 i2=i
59521 ELSEIF(i4.EQ.0) THEN
59522 i4=i
59523 ELSE
59524 CALL pyerrm(16,'(PY4JET:) more than two antiquarks')
59525 ENDIF
59526 ELSE
59527 IF(i3.EQ.0) THEN
59528 i3=i
59529 ELSEIF(i4.EQ.0) THEN
59530 i4=i
59531 ELSE
59532 CALL pyerrm(16,'(PY4JET:) more than two gluons')
59533 ENDIF
59534 ENDIF
59535 ENDIF
59536 100 CONTINUE
59537
59538C...Check that event is arranged according to conventions.
59539 IF(i1.EQ.0.OR.i2.EQ.0.OR.i3.EQ.0.OR.i4.EQ.0) THEN
59540 CALL pyerrm(16,'(PY4JET:) event contains too few partons')
59541 ENDIF
59542 IF(i2.LT.i1.OR.i3.LT.i2.OR.i4.LT.i3) THEN
59543 CALL pyerrm(6,'(PY4JET:) partons arranged in wrong order')
59544 ENDIF
59545
59546C...Check whether second pair are quarks or gluons.
59547 IF(iabs(k(i3,2)).LT.10.AND.iabs(k(i4,2)).LT.10) THEN
59548 iqg34=1
59549 ELSEIF(k(i3,2).EQ.21.AND.k(i4,2).EQ.21) THEN
59550 iqg34=2
59551 ELSE
59552 CALL pyerrm(16,'(PY4JET:) second parton pair inconsistent')
59553 ENDIF
59554
59555C...Boost partons to their cm frame.
59556 DO 110 j=1,4
59557 ptot(j)=p(i1,j)+p(i2,j)+p(i3,j)+p(i4,j)
59558 110 CONTINUE
59559 ecm=sqrt(max(0d0,ptot(4)**2-ptot(1)**2-ptot(2)**2-ptot(3)**2))
59560 DO 120 j=1,3
59561 beta(j)=ptot(j)/ptot(4)
59562 120 CONTINUE
59563 CALL pyrobo(i1,i1,0d0,0d0,-beta(1),-beta(2),-beta(3))
59564 CALL pyrobo(i2,i2,0d0,0d0,-beta(1),-beta(2),-beta(3))
59565 CALL pyrobo(i3,i3,0d0,0d0,-beta(1),-beta(2),-beta(3))
59566 CALL pyrobo(i4,i4,0d0,0d0,-beta(1),-beta(2),-beta(3))
59567 nsav=n
59568
59569C...Decide and set up shower history for q qbar q' qbar' events.
59570 IF(iqg34.EQ.1) THEN
59571 w1=py4jtw(0,i1,i3,i4)
59572 w2=py4jtw(0,i2,i3,i4)
59573 IF(w1.GT.pyr(0)*(w1+w2)) THEN
59574 CALL py4jts(0,i1,i3,i4,i2,qmax)
59575 ELSE
59576 CALL py4jts(0,i2,i3,i4,i1,qmax)
59577 ENDIF
59578
59579C...Decide and set up shower history for q qbar g g events.
59580 ELSE
59581 w1=py4jtw(i1,i3,i2,i4)
59582 w2=py4jtw(i1,i4,i2,i3)
59583 w3=py4jtw(0,i3,i1,i4)
59584 w4=py4jtw(0,i4,i1,i3)
59585 w5=py4jtw(0,i3,i2,i4)
59586 w6=py4jtw(0,i4,i2,i3)
59587 w7=py4jtw(0,i1,i3,i4)
59588 w8=py4jtw(0,i2,i3,i4)
59589 wr=(w1+w2+w3+w4+w5+w6+w7+w8)*pyr(0)
59590 IF(w1.GT.wr) THEN
59591 CALL py4jts(i1,i3,i2,i4,0,qmax)
59592 ELSEIF(w1+w2.GT.wr) THEN
59593 CALL py4jts(i1,i4,i2,i3,0,qmax)
59594 ELSEIF(w1+w2+w3.GT.wr) THEN
59595 CALL py4jts(0,i3,i1,i4,i2,qmax)
59596 ELSEIF(w1+w2+w3+w4.GT.wr) THEN
59597 CALL py4jts(0,i4,i1,i3,i2,qmax)
59598 ELSEIF(w1+w2+w3+w4+w5.GT.wr) THEN
59599 CALL py4jts(0,i3,i2,i4,i1,qmax)
59600 ELSEIF(w1+w2+w3+w4+w5+w6.GT.wr) THEN
59601 CALL py4jts(0,i4,i2,i3,i1,qmax)
59602 ELSEIF(w1+w2+w3+w4+w5+w6+w7.GT.wr) THEN
59603 CALL py4jts(0,i1,i3,i4,i2,qmax)
59604 ELSE
59605 CALL py4jts(0,i2,i3,i4,i1,qmax)
59606 ENDIF
59607 ENDIF
59608
59609C...Boost back original partons and mark them as deleted.
59610 CALL pyrobo(i1,i1,0d0,0d0,beta(1),beta(2),beta(3))
59611 CALL pyrobo(i2,i2,0d0,0d0,beta(1),beta(2),beta(3))
59612 CALL pyrobo(i3,i3,0d0,0d0,beta(1),beta(2),beta(3))
59613 CALL pyrobo(i4,i4,0d0,0d0,beta(1),beta(2),beta(3))
59614 k(i1,1)=k(i1,1)+10
59615 k(i2,1)=k(i2,1)+10
59616 k(i3,1)=k(i3,1)+10
59617 k(i4,1)=k(i4,1)+10
59618
59619C...Rotate shower initiating partons to be along z axis.
59620 phi=pyangl(p(nsav+1,1),p(nsav+1,2))
59621 CALL pyrobo(nsav+1,nsav+6,0d0,-phi,0d0,0d0,0d0)
59622 the=pyangl(p(nsav+1,3),p(nsav+1,1))
59623 CALL pyrobo(nsav+1,nsav+6,-the,0d0,0d0,0d0,0d0)
59624
59625C...Set up copy of shower initiating partons as on mass shell.
59626 DO 140 i=n+1,n+2
59627 DO 130 j=1,5
59628 k(i,j)=0
59629 p(i,j)=0d0
59630 v(i,j)=v(i1,j)
59631 130 CONTINUE
59632 k(i,1)=1
59633 k(i,2)=k(i-6,2)
59634 140 CONTINUE
59635 IF(k(nsav+1,2).EQ.k(i1,2)) THEN
59636 k(n+1,3)=i1
59637 p(n+1,5)=p(i1,5)
59638 k(n+2,3)=i2
59639 p(n+2,5)=p(i2,5)
59640 ELSE
59641 k(n+1,3)=i2
59642 p(n+1,5)=p(i2,5)
59643 k(n+2,3)=i1
59644 p(n+2,5)=p(i1,5)
59645 ENDIF
59646 pabs=sqrt(max(0d0,(ecm**2-p(n+1,5)**2-p(n+2,5)**2)**2-
59647 &(2d0*p(n+1,5)*p(n+2,5))**2))/(2d0*ecm)
59648 p(n+1,3)=pabs
59649 p(n+1,4)=sqrt(pabs**2+p(n+1,5)**2)
59650 p(n+2,3)=-pabs
59651 p(n+2,4)=sqrt(pabs**2+p(n+2,5)**2)
59652 n=n+2
59653
59654C...Decide whether to allow or not photon radiation in showers.
59655C...Connect up colours.
59656 mstj(41)=2
59657 IF(irad.EQ.0) mstj(41)=1
59658 ijoin(1)=n-1
59659 ijoin(2)=n
59660 CALL pyjoin(2,ijoin)
59661
59662C...Decide on maximum virtuality and do parton shower.
59663 IF(pmax.LT.parj(82)) THEN
59664 pqmax=qmax
59665 ELSE
59666 pqmax=pmax
59667 ENDIF
59668 CALL pyshow(nsav+1,-100,pqmax)
59669
59670C...Rotate and boost back system.
59671 CALL pyrobo(nsav+1,n,the,phi,beta(1),beta(2),beta(3))
59672
59673C...Do fragmentation and decays.
59674 CALL pyexec
59675
59676C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59677 IF(icom.EQ.0) THEN
59678 mstu(28)=0
59679 CALL pyhepc(1)
59680 ENDIF
59681
59682 RETURN
59683 END
59684
59685C*********************************************************************
59686
59687C...PY4JTW
59688C...Auxiliary to PY4JET, to evaluate weight of configuration.
59689
59690 FUNCTION py4jtw(IA1,IA2,IA3,IA4)
59691
59692C...Double precision and integer declarations.
59693 IMPLICIT DOUBLE PRECISION(a-h, o-z)
59694 IMPLICIT INTEGER(I-N)
59695 INTEGER PYK,PYCHGE,PYCOMP
59696C...Commonblocks.
59697 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59698 SAVE /pyjets/
59699
59700C...First case: when both original partons radiate.
59701C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59702 IF(ia1.NE.0) THEN
59703 DO 100 j=1,4
59704 p(n+1,j)=p(ia1,j)+p(ia2,j)
59705 p(n+2,j)=p(ia3,j)+p(ia4,j)
59706 100 CONTINUE
59707 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59708 & p(n+1,3)**2))
59709 p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59710 & p(n+2,3)**2))
59711 z1=p(ia1,4)/p(n+1,4)
59712 wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-p(ia1,5)**2)
59713 z2=p(ia3,4)/p(n+2,4)
59714 wt2=(4d0/3d0)*((1d0+z2**2)/(1d0-z2))/(p(n+2,5)**2-p(ia3,5)**2)
59715
59716C...Second case: when one original parton radiates to three.
59717C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59718 ELSE
59719 DO 110 j=1,4
59720 p(n+2,j)=p(ia3,j)+p(ia4,j)
59721 p(n+1,j)=p(n+2,j)+p(ia2,j)
59722 110 CONTINUE
59723 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59724 & p(n+1,3)**2))
59725 p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59726 & p(n+2,3)**2))
59727 IF(k(ia2,2).EQ.21) THEN
59728 z1=p(n+2,4)/p(n+1,4)
59729 wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-
59730 & p(ia3,5)**2)
59731 ELSE
59732 z1=p(ia2,4)/p(n+1,4)
59733 wt1=(4d0/3d0)*((1d0+z1**2)/(1d0-z1))/(p(n+1,5)**2-
59734 & p(ia2,5)**2)
59735 ENDIF
59736 z2=p(ia3,4)/p(n+2,4)
59737 IF(k(ia2,2).EQ.21) THEN
59738 wt2=(4d0/3d0)*((1d0+z2**2)/(1d0-z2))/(p(n+2,5)**2-
59739 & p(ia3,5)**2)
59740 ELSEIF(k(ia3,2).EQ.21) THEN
59741 wt2=3d0*((1d0-z2*(1d0-z2))**2/(z2*(1d0-z2)))/p(n+2,5)**2
59742 ELSE
59743 wt2=0.5d0*(z2**2+(1d0-z2)**2)
59744 ENDIF
59745 ENDIF
59746
59747C...Total weight.
59748 py4jtw=wt1*wt2
59749
59750 RETURN
59751 END
59752
59753C*********************************************************************
59754
59755C...PY4JTS
59756C...Auxiliary to PY4JET, to set up chosen configuration.
59757
59758 SUBROUTINE py4jts(IA1,IA2,IA3,IA4,IA5,QMAX)
59759
59760C...Double precision and integer declarations.
59761 IMPLICIT DOUBLE PRECISION(a-h, o-z)
59762 IMPLICIT INTEGER(I-N)
59763 INTEGER PYK,PYCHGE,PYCOMP
59764C...Commonblocks.
59765 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59766 SAVE /pyjets/
59767
59768C...Reset info.
59769 DO 110 i=n+1,n+6
59770 DO 100 j=1,5
59771 k(i,j)=0
59772 v(i,j)=v(ia2,j)
59773 100 CONTINUE
59774 k(i,1)=16
59775 110 CONTINUE
59776
59777C...First case: when both original partons radiate.
59778C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59779 IF(ia1.NE.0) THEN
59780
59781C...Set up flavour and history pointers for new partons.
59782 k(n+1,2)=k(ia1,2)
59783 k(n+2,2)=k(ia3,2)
59784 k(n+3,2)=k(ia1,2)
59785 k(n+4,2)=k(ia2,2)
59786 k(n+5,2)=k(ia3,2)
59787 k(n+6,2)=k(ia4,2)
59788 k(n+1,3)=ia1
59789 k(n+1,4)=n+3
59790 k(n+1,5)=n+4
59791 k(n+2,3)=ia3
59792 k(n+2,4)=n+5
59793 k(n+2,5)=n+6
59794 k(n+3,3)=n+1
59795 k(n+4,3)=n+1
59796 k(n+5,3)=n+2
59797 k(n+6,3)=n+2
59798
59799C...Set up momenta for new partons.
59800 DO 120 j=1,5
59801 p(n+1,j)=p(ia1,j)+p(ia2,j)
59802 p(n+2,j)=p(ia3,j)+p(ia4,j)
59803 p(n+3,j)=p(ia1,j)
59804 p(n+4,j)=p(ia2,j)
59805 p(n+5,j)=p(ia3,j)
59806 p(n+6,j)=p(ia4,j)
59807 120 CONTINUE
59808 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59809 & p(n+1,3)**2))
59810 p(n+2,5)=sqrt(max(0d0,p(n+2,4)**2-p(n+2,1)**2-p(n+2,2)**2-
59811 & p(n+2,3)**2))
59812 qmax=min(p(n+1,5),p(n+2,5))
59813
59814C...Second case: q radiates twice.
59815C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59816C...IA5=N+2 does not radiate.
59817 ELSEIF(k(ia2,2).EQ.21) THEN
59818
59819C...Set up flavour and history pointers for new partons.
59820 k(n+1,2)=k(ia3,2)
59821 k(n+2,2)=k(ia5,2)
59822 k(n+3,2)=k(ia3,2)
59823 k(n+4,2)=k(ia2,2)
59824 k(n+5,2)=k(ia3,2)
59825 k(n+6,2)=k(ia4,2)
59826 k(n+1,3)=ia3
59827 k(n+1,4)=n+3
59828 k(n+1,5)=n+4
59829 k(n+2,3)=ia5
59830 k(n+3,3)=n+1
59831 k(n+3,4)=n+5
59832 k(n+3,5)=n+6
59833 k(n+4,3)=n+1
59834 k(n+5,3)=n+3
59835 k(n+6,3)=n+3
59836
59837C...Set up momenta for new partons.
59838 DO 130 j=1,5
59839 p(n+1,j)=p(ia2,j)+p(ia3,j)+p(ia4,j)
59840 p(n+2,j)=p(ia5,j)
59841 p(n+3,j)=p(ia3,j)+p(ia4,j)
59842 p(n+4,j)=p(ia2,j)
59843 p(n+5,j)=p(ia3,j)
59844 p(n+6,j)=p(ia4,j)
59845 130 CONTINUE
59846 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59847 & p(n+1,3)**2))
59848 p(n+3,5)=sqrt(max(0d0,p(n+3,4)**2-p(n+3,1)**2-p(n+3,2)**2-
59849 & p(n+3,3)**2))
59850 qmax=p(n+3,5)
59851
59852C...Third case: q radiates g, g branches.
59853C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59854C...IA5=N+2 does not radiate.
59855 ELSE
59856
59857C...Set up flavour and history pointers for new partons.
59858 k(n+1,2)=k(ia2,2)
59859 k(n+2,2)=k(ia5,2)
59860 k(n+3,2)=k(ia2,2)
59861 k(n+4,2)=21
59862 k(n+5,2)=k(ia3,2)
59863 k(n+6,2)=k(ia4,2)
59864 k(n+1,3)=ia2
59865 k(n+1,4)=n+3
59866 k(n+1,5)=n+4
59867 k(n+2,3)=ia5
59868 k(n+3,3)=n+1
59869 k(n+4,3)=n+1
59870 k(n+4,4)=n+5
59871 k(n+4,5)=n+6
59872 k(n+5,3)=n+4
59873 k(n+6,3)=n+4
59874
59875C...Set up momenta for new partons.
59876 DO 140 j=1,5
59877 p(n+1,j)=p(ia2,j)+p(ia3,j)+p(ia4,j)
59878 p(n+2,j)=p(ia5,j)
59879 p(n+3,j)=p(ia2,j)
59880 p(n+4,j)=p(ia3,j)+p(ia4,j)
59881 p(n+5,j)=p(ia3,j)
59882 p(n+6,j)=p(ia4,j)
59883 140 CONTINUE
59884 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
59885 & p(n+1,3)**2))
59886 p(n+4,5)=sqrt(max(0d0,p(n+4,4)**2-p(n+4,1)**2-p(n+4,2)**2-
59887 & p(n+4,3)**2))
59888 qmax=p(n+4,5)
59889
59890 ENDIF
59891 n=n+6
59892
59893 RETURN
59894 END
59895
59896C*********************************************************************
59897
59898C...PYJOIN
59899C...Connects a sequence of partons with colour flow indices,
59900C...as required for subsequent shower evolution (or other operations).
59901
59902 SUBROUTINE pyjoin(NJOIN,IJOIN)
59903
59904C...Double precision and integer declarations.
59905 IMPLICIT DOUBLE PRECISION(a-h, o-z)
59906 IMPLICIT INTEGER(I-N)
59907 INTEGER PYK,PYCHGE,PYCOMP
59908C...Commonblocks.
59909 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59910 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59911 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
59912 SAVE /pyjets/,/pydat1/,/pydat2/
59913C...Local array.
59914 dimension ijoin(*)
59915
59916C...Check that partons are of right types to be connected.
59917 IF(njoin.LT.2) GOTO 120
59918 kqsum=0
59919 DO 100 ijn=1,njoin
59920 i=ijoin(ijn)
59921 IF(i.LE.0.OR.i.GT.n) GOTO 120
59922 IF(k(i,1).LT.1.OR.k(i,1).GT.3) GOTO 120
59923 kc=pycomp(k(i,2))
59924 IF(kc.EQ.0) GOTO 120
59925 kq=kchg(kc,2)*isign(1,k(i,2))
59926 IF(kq.EQ.0) GOTO 120
59927 IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) GOTO 120
59928 IF(kq.NE.2) kqsum=kqsum+kq
59929 IF(ijn.EQ.1) kqs=kq
59930 100 CONTINUE
59931 IF(kqsum.NE.0) GOTO 120
59932
59933C...Connect the partons sequentially (closing for gluon loop).
59934 kcs=(9-kqs)/2
59935 IF(kqs.EQ.2) kcs=int(4.5d0+pyr(0))
59936 DO 110 ijn=1,njoin
59937 i=ijoin(ijn)
59938 k(i,1)=3
59939 IF(ijn.NE.1) ip=ijoin(ijn-1)
59940 IF(ijn.EQ.1) ip=ijoin(njoin)
59941 IF(ijn.NE.njoin) in=ijoin(ijn+1)
59942 IF(ijn.EQ.njoin) in=ijoin(1)
59943 k(i,kcs)=mstu(5)*in
59944 k(i,9-kcs)=mstu(5)*ip
59945 IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0
59946 IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0
59947 110 CONTINUE
59948
59949C...Error exit: no action taken.
59950 RETURN
59951 120 CALL pyerrm(12,
59952 &'(PYJOIN:) given entries can not be joined by one string')
59953
59954 RETURN
59955 END
59956
59957C*********************************************************************
59958
59959C...PYGIVE
59960C...Sets values of commonblock variables.
59961
59962 SUBROUTINE pygive(CHIN)
59963
59964C...Double precision and integer declarations.
59965 IMPLICIT DOUBLE PRECISION(a-h, o-z)
59966 IMPLICIT INTEGER(I-N)
59967 INTEGER PYK,PYCHGE,PYCOMP
59968C...Commonblocks.
59969 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
59970 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
59971 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
59972 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
59973 common/pydat4/chaf(500,2)
59974 CHARACTER CHAF*16
59975 common/pydatr/mrpy(6),rrpy(100)
59976 common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
59977 common/pypars/mstp(200),parp(200),msti(200),pari(200)
59978 common/pyint1/mint(400),vint(400)
59979 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
59980 common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)
59981 common/pyint4/mwid(500),wids(500,5)
59982 common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)
59983 common/pyint6/proc(0:500)
59984 CHARACTER PROC*28
59985 common/pyint7/sigt(0:6,0:6,0:5)
59986 common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),
59987 &xpdir(-6:6)
59988 common/pymssm/imss(0:99),rmss(0:99)
59989 common/pymsrv/rvlam(3,3,3), rvlamp(3,3,3), rvlamb(3,3,3)
59990 common/pytcsm/itcm(0:99),rtcm(0:99)
59991 common/pypued/iued(0:99),rued(0:99)
59992 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,
59993 &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,
59994 &/pyint6/,/pyint7/,/pyint8/,/pymssm/,/pymsrv/,/pytcsm/,/pypued/
59995C...Local arrays and character variables.
59996 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
59997 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
59998 &CHINR*16,CHDIG*10
59999 DIMENSION MSVAR(56,8)
60000
60001C...For each variable to be translated give: name,
60002C...integer/real/character, no. of indices, lower&upper index bounds.
60003 DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60004 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60005 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60006 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60007 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60008 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60009 &'ITCM','RTCM','IUED','RUED'/
60010 DATA ((msvar(i,j),j=1,8),i=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60011 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60012 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60013 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60014 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60015 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60016 &1,1,1,6,4*0, 2,1,1,100,4*0,
60017 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60018 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60019 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60020 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60021 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60022 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60023 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60024 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60025 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60026 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60027 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60028 DATA chalp/'abcdefghijklmnopqrstuvwxyz',
60029 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, chdig/'1234567890'/
60030
60031C...Length of character variable. Subdivide it into instructions.
60032 IF(mstu(12).NE.12345.AND.chin.NE.'mstu(12)=12345'.AND.
60033 &chin.NE.'MSTU(12)=12345') CALL pylist(0)
60034 chbit=chin//' '
60035 lbit=101
60036 100 lbit=lbit-1
60037 IF(chbit(lbit:lbit).EQ.' ') GOTO 100
60038 ltot=0
60039 DO 110 lcom=1,lbit
60040 IF(chbit(lcom:lcom).EQ.' ') GOTO 110
60041 ltot=ltot+1
60042 chfix(ltot:ltot)=chbit(lcom:lcom)
60043 110 CONTINUE
60044 llow=0
60045 120 lhig=llow+1
60046 130 lhig=lhig+1
60047 IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') GOTO 130
60048 lbit=lhig-llow-1
60049 chbit(1:lbit)=chfix(llow+1:lhig-1)
60050
60051C...Send off decay-mode on/off commands to PYONOF.
60052 ionof=0
60053 DO 135 ldig=1,10
60054 IF(chbit(1:1).EQ.chdig(ldig:ldig)) ionof=1
60055 135 CONTINUE
60056 IF(ionof.EQ.1) THEN
60057 CALL pyonof(chin)
60058 RETURN
60059 ENDIF
60060
60061C...Peel off any text following exclamation mark.
60062 lhig2=lbit
60063 DO 140 llow2=lhig2,1,-1
60064 IF(chbit(llow2:llow2).EQ.'!') lbit=llow2-1
60065 140 CONTINUE
60066 IF(lbit.EQ.0) RETURN
60067
60068C...Identify commonblock variable.
60069 lnam=1
60070 150 lnam=lnam+1
60071 IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.
60072 &lnam.LE.6) GOTO 150
60073 chnam=chbit(1:lnam-1)//' '
60074 DO 170 lcom=1,lnam-1
60075 DO 160 lalp=1,26
60076 IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=
60077 & chalp(2)(lalp:lalp)
60078 160 CONTINUE
60079 170 CONTINUE
60080 ivar=0
60081 DO 180 iv=1,56
60082 IF(chnam.EQ.chvar(iv)) ivar=iv
60083 180 CONTINUE
60084 IF(ivar.EQ.0) THEN
60085 CALL pyerrm(18,'(PYGIVE:) do not recognize variable '//chnam)
60086 llow=lhig
60087 IF(llow.LT.ltot) GOTO 120
60088 RETURN
60089 ENDIF
60090
60091C...Identify any indices.
60092 i1=0
60093 i2=0
60094 i3=0
60095 nindx=0
60096 IF(chbit(lnam:lnam).EQ.'(') THEN
60097 lind=lnam
60098 190 lind=lind+1
60099 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 190
60100 chind=' '
60101 IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c')
60102 & .AND.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17.OR.
60103 & ivar.EQ.37)) THEN
60104 chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)
60105 READ(chind,'(I8)') kf
60106 i1=pycomp(kf)
60107 ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.
60108 & 'c') THEN
60109 CALL pyerrm(18,'(PYGIVE:) not allowed to use C index for '//
60110 & chnam)
60111 llow=lhig
60112 IF(llow.LT.ltot) GOTO 120
60113 RETURN
60114 ELSE
60115 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
60116 READ(chind,'(I8)') i1
60117 ENDIF
60118 lnam=lind
60119 IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
60120 nindx=1
60121 ENDIF
60122 IF(chbit(lnam:lnam).EQ.',') THEN
60123 lind=lnam
60124 200 lind=lind+1
60125 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 200
60126 chind=' '
60127 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
60128 READ(chind,'(I8)') i2
60129 lnam=lind
60130 IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1
60131 nindx=2
60132 ENDIF
60133 IF(chbit(lnam:lnam).EQ.',') THEN
60134 lind=lnam
60135 210 lind=lind+1
60136 IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') GOTO 210
60137 chind=' '
60138 chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)
60139 READ(chind,'(I8)') i3
60140 lnam=lind+1
60141 nindx=3
60142 ENDIF
60143
60144C...Check that indices allowed.
60145 ierr=0
60146 IF(nindx.NE.msvar(ivar,2)) ierr=1
60147 IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))
60148 &ierr=2
60149 IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))
60150 &ierr=3
60151 IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))
60152 &ierr=4
60153 IF(chbit(lnam:lnam).NE.'=') ierr=5
60154 IF(ierr.GE.1) THEN
60155 CALL pyerrm(18,'(PYGIVE:) unallowed indices for '//
60156 & chbit(1:lnam-1))
60157 llow=lhig
60158 IF(llow.LT.ltot) GOTO 120
60159 RETURN
60160 ENDIF
60161
60162C...Save old value of variable.
60163 IF(ivar.EQ.1) THEN
60164 iold=n
60165 ELSEIF(ivar.EQ.2) THEN
60166 iold=k(i1,i2)
60167 ELSEIF(ivar.EQ.3) THEN
60168 rold=p(i1,i2)
60169 ELSEIF(ivar.EQ.4) THEN
60170 rold=v(i1,i2)
60171 ELSEIF(ivar.EQ.5) THEN
60172 iold=mstu(i1)
60173 ELSEIF(ivar.EQ.6) THEN
60174 rold=paru(i1)
60175 ELSEIF(ivar.EQ.7) THEN
60176 iold=mstj(i1)
60177 ELSEIF(ivar.EQ.8) THEN
60178 rold=parj(i1)
60179 ELSEIF(ivar.EQ.9) THEN
60180 iold=kchg(i1,i2)
60181 ELSEIF(ivar.EQ.10) THEN
60182 rold=pmas(i1,i2)
60183 ELSEIF(ivar.EQ.11) THEN
60184 rold=parf(i1)
60185 ELSEIF(ivar.EQ.12) THEN
60186 rold=vckm(i1,i2)
60187 ELSEIF(ivar.EQ.13) THEN
60188 iold=mdcy(i1,i2)
60189 ELSEIF(ivar.EQ.14) THEN
60190 iold=mdme(i1,i2)
60191 ELSEIF(ivar.EQ.15) THEN
60192 rold=brat(i1)
60193 ELSEIF(ivar.EQ.16) THEN
60194 iold=kfdp(i1,i2)
60195 ELSEIF(ivar.EQ.17) THEN
60196 chold=chaf(i1,i2)(1:8)
60197 ELSEIF(ivar.EQ.18) THEN
60198 iold=mrpy(i1)
60199 ELSEIF(ivar.EQ.19) THEN
60200 rold=rrpy(i1)
60201 ELSEIF(ivar.EQ.20) THEN
60202 iold=msel
60203 ELSEIF(ivar.EQ.21) THEN
60204 iold=msub(i1)
60205 ELSEIF(ivar.EQ.22) THEN
60206 iold=kfin(i1,i2)
60207 ELSEIF(ivar.EQ.23) THEN
60208 rold=ckin(i1)
60209 ELSEIF(ivar.EQ.24) THEN
60210 iold=mstp(i1)
60211 ELSEIF(ivar.EQ.25) THEN
60212 rold=parp(i1)
60213 ELSEIF(ivar.EQ.26) THEN
60214 iold=msti(i1)
60215 ELSEIF(ivar.EQ.27) THEN
60216 rold=pari(i1)
60217 ELSEIF(ivar.EQ.28) THEN
60218 iold=mint(i1)
60219 ELSEIF(ivar.EQ.29) THEN
60220 rold=vint(i1)
60221 ELSEIF(ivar.EQ.30) THEN
60222 iold=iset(i1)
60223 ELSEIF(ivar.EQ.31) THEN
60224 iold=kfpr(i1,i2)
60225 ELSEIF(ivar.EQ.32) THEN
60226 rold=coef(i1,i2)
60227 ELSEIF(ivar.EQ.33) THEN
60228 iold=icol(i1,i2,i3)
60229 ELSEIF(ivar.EQ.34) THEN
60230 rold=xsfx(i1,i2)
60231 ELSEIF(ivar.EQ.35) THEN
60232 iold=isig(i1,i2)
60233 ELSEIF(ivar.EQ.36) THEN
60234 rold=sigh(i1)
60235 ELSEIF(ivar.EQ.37) THEN
60236 iold=mwid(i1)
60237 ELSEIF(ivar.EQ.38) THEN
60238 rold=wids(i1,i2)
60239 ELSEIF(ivar.EQ.39) THEN
60240 iold=ngen(i1,i2)
60241 ELSEIF(ivar.EQ.40) THEN
60242 rold=xsec(i1,i2)
60243 ELSEIF(ivar.EQ.41) THEN
60244 chold2=proc(i1)
60245 ELSEIF(ivar.EQ.42) THEN
60246 rold=sigt(i1,i2,i3)
60247 ELSEIF(ivar.EQ.43) THEN
60248 rold=xpvmd(i1)
60249 ELSEIF(ivar.EQ.44) THEN
60250 rold=xpanl(i1)
60251 ELSEIF(ivar.EQ.45) THEN
60252 rold=xpanh(i1)
60253 ELSEIF(ivar.EQ.46) THEN
60254 rold=xpbeh(i1)
60255 ELSEIF(ivar.EQ.47) THEN
60256 rold=xpdir(i1)
60257 ELSEIF(ivar.EQ.48) THEN
60258 iold=imss(i1)
60259 ELSEIF(ivar.EQ.49) THEN
60260 rold=rmss(i1)
60261 ELSEIF(ivar.EQ.50) THEN
60262 rold=rvlam(i1,i2,i3)
60263 ELSEIF(ivar.EQ.51) THEN
60264 rold=rvlamp(i1,i2,i3)
60265 ELSEIF(ivar.EQ.52) THEN
60266 rold=rvlamb(i1,i2,i3)
60267 ELSEIF(ivar.EQ.53) THEN
60268 iold=itcm(i1)
60269 ELSEIF(ivar.EQ.54) THEN
60270 rold=rtcm(i1)
60271 ELSEIF(ivar.EQ.55) THEN
60272 iold=iued(i1)
60273 ELSEIF(ivar.EQ.56) THEN
60274 rold=rued(i1)
60275 ENDIF
60276
60277C...Print current value of variable. Loop back.
60278 IF(lnam.GE.lbit) THEN
60279 chbit(lnam:14)=' '
60280 chbit(15:60)=' has the value '
60281 IF(msvar(ivar,1).EQ.1) THEN
60282 WRITE(chbit(51:60),'(I10)') iold
60283 ELSEIF(msvar(ivar,1).EQ.2) THEN
60284 WRITE(chbit(47:60),'(F14.5)') rold
60285 ELSEIF(msvar(ivar,1).EQ.3) THEN
60286 chbit(53:60)=chold
60287 ELSE
60288 chbit(33:60)=chold
60289 ENDIF
60290 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
60291 llow=lhig
60292 IF(llow.LT.ltot) GOTO 120
60293 RETURN
60294 ENDIF
60295
60296C...Read in new variable value.
60297 IF(msvar(ivar,1).EQ.1) THEN
60298 chini=' '
60299 chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)
60300 READ(chini,'(I10)') inew
60301 ELSEIF(msvar(ivar,1).EQ.2) THEN
60302 chinr=' '
60303 chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)
60304 READ(chinr,*) rnew
60305 ELSEIF(msvar(ivar,1).EQ.3) THEN
60306 chnew=chbit(lnam+1:lbit)//' '
60307 ELSE
60308 chnew2=chbit(lnam+1:lbit)//' '
60309 ENDIF
60310
60311C...Store new variable value.
60312 IF(ivar.EQ.1) THEN
60313 n=inew
60314 ELSEIF(ivar.EQ.2) THEN
60315 k(i1,i2)=inew
60316 ELSEIF(ivar.EQ.3) THEN
60317 p(i1,i2)=rnew
60318 ELSEIF(ivar.EQ.4) THEN
60319 v(i1,i2)=rnew
60320 ELSEIF(ivar.EQ.5) THEN
60321 mstu(i1)=inew
60322 ELSEIF(ivar.EQ.6) THEN
60323 paru(i1)=rnew
60324 ELSEIF(ivar.EQ.7) THEN
60325 mstj(i1)=inew
60326 ELSEIF(ivar.EQ.8) THEN
60327 parj(i1)=rnew
60328 ELSEIF(ivar.EQ.9) THEN
60329 kchg(i1,i2)=inew
60330 ELSEIF(ivar.EQ.10) THEN
60331 pmas(i1,i2)=rnew
60332 ELSEIF(ivar.EQ.11) THEN
60333 parf(i1)=rnew
60334 ELSEIF(ivar.EQ.12) THEN
60335 vckm(i1,i2)=rnew
60336 ELSEIF(ivar.EQ.13) THEN
60337 mdcy(i1,i2)=inew
60338 ELSEIF(ivar.EQ.14) THEN
60339 mdme(i1,i2)=inew
60340 ELSEIF(ivar.EQ.15) THEN
60341 brat(i1)=rnew
60342 ELSEIF(ivar.EQ.16) THEN
60343 kfdp(i1,i2)=inew
60344 ELSEIF(ivar.EQ.17) THEN
60345 chaf(i1,i2)=chnew
60346 ELSEIF(ivar.EQ.18) THEN
60347 mrpy(i1)=inew
60348 ELSEIF(ivar.EQ.19) THEN
60349 rrpy(i1)=rnew
60350 ELSEIF(ivar.EQ.20) THEN
60351 msel=inew
60352 ELSEIF(ivar.EQ.21) THEN
60353 msub(i1)=inew
60354 ELSEIF(ivar.EQ.22) THEN
60355 kfin(i1,i2)=inew
60356 ELSEIF(ivar.EQ.23) THEN
60357 ckin(i1)=rnew
60358 ELSEIF(ivar.EQ.24) THEN
60359 mstp(i1)=inew
60360 ELSEIF(ivar.EQ.25) THEN
60361 parp(i1)=rnew
60362 ELSEIF(ivar.EQ.26) THEN
60363 msti(i1)=inew
60364 ELSEIF(ivar.EQ.27) THEN
60365 pari(i1)=rnew
60366 ELSEIF(ivar.EQ.28) THEN
60367 mint(i1)=inew
60368 ELSEIF(ivar.EQ.29) THEN
60369 vint(i1)=rnew
60370 ELSEIF(ivar.EQ.30) THEN
60371 iset(i1)=inew
60372 ELSEIF(ivar.EQ.31) THEN
60373 kfpr(i1,i2)=inew
60374 ELSEIF(ivar.EQ.32) THEN
60375 coef(i1,i2)=rnew
60376 ELSEIF(ivar.EQ.33) THEN
60377 icol(i1,i2,i3)=inew
60378 ELSEIF(ivar.EQ.34) THEN
60379 xsfx(i1,i2)=rnew
60380 ELSEIF(ivar.EQ.35) THEN
60381 isig(i1,i2)=inew
60382 ELSEIF(ivar.EQ.36) THEN
60383 sigh(i1)=rnew
60384 ELSEIF(ivar.EQ.37) THEN
60385 mwid(i1)=inew
60386 ELSEIF(ivar.EQ.38) THEN
60387 wids(i1,i2)=rnew
60388 ELSEIF(ivar.EQ.39) THEN
60389 ngen(i1,i2)=inew
60390 ELSEIF(ivar.EQ.40) THEN
60391 xsec(i1,i2)=rnew
60392 ELSEIF(ivar.EQ.41) THEN
60393 proc(i1)=chnew2
60394 ELSEIF(ivar.EQ.42) THEN
60395 sigt(i1,i2,i3)=rnew
60396 ELSEIF(ivar.EQ.43) THEN
60397 xpvmd(i1)=rnew
60398 ELSEIF(ivar.EQ.44) THEN
60399 xpanl(i1)=rnew
60400 ELSEIF(ivar.EQ.45) THEN
60401 xpanh(i1)=rnew
60402 ELSEIF(ivar.EQ.46) THEN
60403 xpbeh(i1)=rnew
60404 ELSEIF(ivar.EQ.47) THEN
60405 xpdir(i1)=rnew
60406 ELSEIF(ivar.EQ.48) THEN
60407 imss(i1)=inew
60408 ELSEIF(ivar.EQ.49) THEN
60409 rmss(i1)=rnew
60410 ELSEIF(ivar.EQ.50) THEN
60411 rvlam(i1,i2,i3)=rnew
60412 ELSEIF(ivar.EQ.51) THEN
60413 rvlamp(i1,i2,i3)=rnew
60414 ELSEIF(ivar.EQ.52) THEN
60415 rvlamb(i1,i2,i3)=rnew
60416 ELSEIF(ivar.EQ.53) THEN
60417 itcm(i1)=inew
60418 ELSEIF(ivar.EQ.54) THEN
60419 rtcm(i1)=rnew
60420 ELSEIF(ivar.EQ.55) THEN
60421 iued(i1)=inew
60422 ELSEIF(ivar.EQ.56) THEN
60423 rued(i1)=rnew
60424 ENDIF
60425
60426C...Write old and new value. Loop back.
60427 chbit(lnam:14)=' '
60428 chbit(15:60)=' changed from to '
60429 IF(msvar(ivar,1).EQ.1) THEN
60430 WRITE(chbit(33:42),'(I10)') iold
60431 WRITE(chbit(51:60),'(I10)') inew
60432 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
60433 ELSEIF(msvar(ivar,1).EQ.2) THEN
60434 WRITE(chbit(29:42),'(F14.5)') rold
60435 WRITE(chbit(47:60),'(F14.5)') rnew
60436 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
60437 ELSEIF(msvar(ivar,1).EQ.3) THEN
60438 chbit(35:42)=chold
60439 chbit(53:60)=chnew
60440 IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)
60441 ELSE
60442 chbit(15:88)=' changed from '//chold2//' to '//chnew2
60443 IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)
60444 ENDIF
60445 llow=lhig
60446 IF(llow.LT.ltot) GOTO 120
60447
60448C...Format statement for output on unit MSTU(11) (by default 6).
60449 5000 FORMAT(5x,a60)
60450 5100 FORMAT(5x,a88)
60451
60452 RETURN
60453 END
60454
60455C*********************************************************************
60456
60457C...PYONOF
60458C...Switches on and off decay channel by search for match.
60459
60460 SUBROUTINE pyonof(CHIN)
60461
60462C...Double precision and integer declarations.
60463 IMPLICIT DOUBLE PRECISION(a-h, o-z)
60464 IMPLICIT INTEGER(I-N)
60465 INTEGER PYK,PYCHGE,PYCOMP
60466C...Commonblocks.
60467 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
60468 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
60469 SAVE /pydat1/,/pydat3/
60470C...Local arrays and character variables.
60471 INTEGER KFCMP(10),KFTMP(10)
60472 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60473 &chalp(2)*26
60474 DATA chalp/'abcdefghijklmnopqrstuvwxyz',
60475 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60476
60477C...Determine length of character variable.
60478 chtmp=chin//' '
60479 lbeg=0
60480 100 lbeg=lbeg+1
60481 IF(chtmp(lbeg:lbeg).EQ.' ') GOTO 100
60482 lend=lbeg-1
60483 105 lend=lend+1
60484 IF(lend.LE.100.AND.chtmp(lend:lend).NE.'!') GOTO 105
60485 110 lend=lend-1
60486 IF(chtmp(lend:lend).EQ.' ') GOTO 110
60487 len=1+lend-lbeg
60488 chfix(1:len)=chtmp(lbeg:lend)
60489
60490C...Find colon separator and particle code.
60491 lcolon=0
60492 120 lcolon=lcolon+1
60493 IF(chfix(lcolon:lcolon).NE.':') GOTO 120
60494 chcode=' '
60495 chcode(10-lcolon:8)=chfix(1:lcolon-1)
60496 READ(chcode,'(I8)',err=300) kf
60497 kc=pycomp(kf)
60498
60499C...Done if unknown code or no decay channels.
60500 IF(kc.EQ.0) THEN
60501 CALL pyerrm(18,'(PYONOF:) unrecognized particle '//chcode)
60502 RETURN
60503 ENDIF
60504 idcbeg=mdcy(kc,2)
60505 idclen=mdcy(kc,3)
60506 IF(idcbeg.EQ.0.OR.idclen.EQ.0) THEN
60507 CALL pyerrm(18,'(PYONOF:) no decay channels for '//chcode)
60508 RETURN
60509 ENDIF
60510
60511C...Find command name up to blank or equal sign.
60512 lsep=lcolon
60513 130 lsep=lsep+1
60514 IF(lsep.LE.len.AND.chfix(lsep:lsep).NE.' '.AND.
60515 &chfix(lsep:lsep).NE.'=') GOTO 130
60516 chmode=' '
60517 lmode=lsep-lcolon-1
60518 chmode(1:lmode)=chfix(lcolon+1:lsep-1)
60519
60520C...Convert to uppercase.
60521 DO 150 lcom=1,lmode
60522 DO 140 lalp=1,26
60523 IF(chmode(lcom:lcom).EQ.chalp(1)(lalp:lalp))
60524 & chmode(lcom:lcom)=chalp(2)(lalp:lalp)
60525 140 CONTINUE
60526 150 CONTINUE
60527
60528C...Identify command. Failed if not identified.
60529 mode=0
60530 IF(chmode.EQ.'ALLOFF') mode=1
60531 IF(chmode.EQ.'ALLON') mode=2
60532 IF(chmode.EQ.'OFFIFANY') mode=3
60533 IF(chmode.EQ.'ONIFANY') mode=4
60534 IF(chmode.EQ.'OFFIFALL') mode=5
60535 IF(chmode.EQ.'ONIFALL') mode=6
60536 IF(chmode.EQ.'OFFIFMATCH') mode=7
60537 IF(chmode.EQ.'ONIFMATCH') mode=8
60538 IF(mode.EQ.0) THEN
60539 CALL pyerrm(18,'(PYONOF:) unknown command '//chmode)
60540 RETURN
60541 ENDIF
60542
60543C...Simple cases when all on or all off.
60544 IF(mode.EQ.1.OR.mode.EQ.2) THEN
60545 WRITE(mstu(11),1000) kf,chmode
60546 DO 160 idc=idcbeg,idcbeg+idclen-1
60547 IF(mdme(idc,1).LT.0) GOTO 160
60548 mdme(idc,1)=mode-1
60549 160 CONTINUE
60550 RETURN
60551 ENDIF
60552
60553C...Identify matching list.
60554 ncmp=0
60555 lbeg=lsep
60556 170 lbeg=lbeg+1
60557 IF(lbeg.GT.len) GOTO 190
60558 IF(lbeg.LT.len.AND.(chfix(lbeg:lbeg).EQ.' '.OR.
60559 &chfix(lbeg:lbeg).EQ.'='.OR.chfix(lbeg:lbeg).EQ.',')) GOTO 170
60560 lend=lbeg-1
60561 180 lend=lend+1
60562 IF(lend.LT.len.AND.chfix(lend:lend).NE.' '.AND.
60563 &chfix(lend:lend).NE.'='.AND.chfix(lend:lend).NE.',') GOTO 180
60564 IF(lend.LT.len) lend=lend-1
60565 chcode=' '
60566 chcode(8-lend+lbeg:8)=chfix(lbeg:lend)
60567 READ(chcode,'(I8)',err=300) kfread
60568 ncmp=ncmp+1
60569 kfcmp(ncmp)=iabs(kfread)
60570 lbeg=lend
60571 IF(ncmp.LT.10) GOTO 170
60572 190 CONTINUE
60573 WRITE(mstu(11),1100) kf,chmode,(kfcmp(icmp),icmp=1,ncmp)
60574
60575C...Only one matching required.
60576 IF(mode.EQ.3.OR.mode.EQ.4) THEN
60577 DO 220 idc=idcbeg,idcbeg+idclen-1
60578 IF(mdme(idc,1).LT.0) GOTO 220
60579 DO 210 ikf=1,5
60580 kfnow=iabs(kfdp(idc,ikf))
60581 IF(kfnow.EQ.0) GOTO 210
60582 DO 200 icmp=1,ncmp
60583 IF(kfcmp(icmp).EQ.kfnow) THEN
60584 mdme(idc,1)=mode-3
60585 GOTO 220
60586 ENDIF
60587 200 CONTINUE
60588 210 CONTINUE
60589 220 CONTINUE
60590 RETURN
60591 ENDIF
60592
60593C...Multiple matchings required.
60594 DO 260 idc=idcbeg,idcbeg+idclen-1
60595 IF(mdme(idc,1).LT.0) GOTO 260
60596 ntmp=ncmp
60597 DO 230 itmp=1,ntmp
60598 kftmp(itmp)=kfcmp(itmp)
60599 230 CONTINUE
60600 nfin=0
60601 DO 250 ikf=1,5
60602 kfnow=iabs(kfdp(idc,ikf))
60603 IF(kfnow.EQ.0) GOTO 250
60604 nfin=nfin+1
60605 DO 240 itmp=1,ntmp
60606 IF(kftmp(itmp).EQ.kfnow) THEN
60607 kftmp(itmp)=kftmp(ntmp)
60608 ntmp=ntmp-1
60609 GOTO 250
60610 ENDIF
60611 240 CONTINUE
60612 250 CONTINUE
60613 IF(ntmp.EQ.0.AND.mode.LE.6) mdme(idc,1)=mode-5
60614 IF(ntmp.EQ.0.AND.nfin.EQ.ncmp.AND.mode.GE.7)
60615 & mdme(idc,1)=mode-7
60616 260 CONTINUE
60617 RETURN
60618
60619C...Error exit for impossible read of particle code.
60620 300 CALL pyerrm(18,'(PYONOF:) could not interpret particle code '
60621 &//chcode)
60622
60623C...Formats for output.
60624 1000 FORMAT(' Decays for',i8,' set ',a10)
60625 1100 FORMAT(' Decays for',i8,' set ',a10,' if match',10i8)
60626
60627 RETURN
60628 END
60629C*********************************************************************
60630
60631C...PYTUNE
60632C...Presets for a few specific underlying-event and min-bias tunes
60633C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60634C...others require particular versions of pythia (e.g. the SCI and GAL
60635C...models). See below for details.
60636 SUBROUTINE pytune(ITUNE)
60637C
60638C ITUNE NAME (detailed descriptions below)
60639C 0 Default : No settings changed => defaults.
60640C
60641C ====== Old UE, Q2-ordered showers ====================================
60642C 100 A : Rick Field's CDF Tune A (Oct 2002)
60643C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60644C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60645C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60646C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60647C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60648C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60649C 107 ACR : Tune A modified with new CR model (Mar 2007)
60650C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60651C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60652C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60653C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60654C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60655C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60656C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60657C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60658C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60659C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60660C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60661C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60662C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60663C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60664C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60665C
60666C ====== Intermediate and Hybrid Models ================================
60667C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60668C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60669C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60670C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60671C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60672C
60673C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60674C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60675C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60676C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60677C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60678C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60679C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60680C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60681C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60682C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60683C 311 S1-Pro : S1 -"- (Oct 2008)
60684C 312 S2-Pro : S2 -"- (Oct 2008)
60685C 313 S0A-Pro : S0A -"- (Oct 2008)
60686C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60687C 315 Old-Pro : Old -"- (Oct 2008)
60688C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60689C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60690C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60691C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60692C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60693C balance & different scaling to LHC & RHIC (Feb 2009)
60694C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60695C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60696C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60697C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60698C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60699C
60700C ======= The Uppsala models ===========================================
60701C ( NB! must be run with special modified Pythia 6.215 version )
60702C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60703C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60704C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60705C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60706C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60707C
60708C More details;
60709C
60710C Quick Dictionary:
60711C BE : Bose-Einstein
60712C BR : Beam Remnants
60713C CR : Colour Reconnections
60714C HAD: Hadronization
60715C ISR/FSR: Initial-State Radiation / Final-State Radiation
60716C FSI: Final-State Interactions (=CR+BE)
60717C MB : Minimum-bias
60718C MI : Multiple Interactions
60719C UE : Underlying Event
60720C
60721C=======================================================================
60722C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60723C=======================================================================
60724C
60725C A (100) and AW (101). CTEQ5L parton distributions
60726C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60727C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60728C...Key feature: extensively compared to CDF data (R.D. Field).
60729C...* Large starting scale for ISR (PARP(67)=4)
60730C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60731C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60732C
60733C BW (102). CTEQ5L parton distributions
60734C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60735C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60736C...Key feature: extensively compared to CDF data (R.D. Field).
60737C...NB: Can also be run with Pythia 6.2 or 6.312+
60738C...* Small starting scale for ISR (PARP(67)=1)
60739C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60740C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60741C
60742C DW (103) and DWT (104). CTEQ5L parton distributions
60743C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60744C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60745C...Key feature: extensively compared to CDF data (R.D. Field).
60746C...NB: Can also be run with Pythia 6.2 or 6.312+
60747C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60748C...* DWT has a different reference energy, the same as the "S" models
60749C... below, leading to more UE activity at the LHC, but less at RHIC.
60750C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60751C
60752C QW (105). CTEQ61 parton distributions
60753C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60754C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60755C...Key feature: uses CTEQ61 (external pdf library must be linked)
60756C
60757C ATLAS-DC2 (106). CTEQ5L parton distributions
60758C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60759C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60760C...Key feature: tune used by the ATLAS collaboration.
60761C
60762C ACR (107). CTEQ5L parton distributions
60763C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60764C...Key feature: Tune A modified to use annealing CR.
60765C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60766C
60767C D6 (108) and D6T (109). CTEQ6L parton distributions
60768C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60769C
60770C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60771C Old UE model, Q2-ordered showers.
60772C...Key feature: Rick Field's family of tunes revamped with the
60773C...Professor Q2-ordered final-state shower and fragmentation tunes
60774C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60775C...Key feature: improved descriptions of LEP data.
60776C
60777C Pro-Q20 (129). CTEQ5L parton distributions
60778C Old UE model, Q2-ordered showers.
60779C...Key feature: Complete retune of old model by Professor, including
60780C...large amounts of both LEP and Tevatron data.
60781C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60782C...extreme in this tune, corresponding to using mu_R = pT/3 .
60783C
60784C=======================================================================
60785C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60786C=======================================================================
60787C
60788C IM1 (200). Intermediate model, Q2-ordered showers,
60789C CTEQ5L parton distributions
60790C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60791C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60792C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60793C
60794C APT (201). Old UE model, pT-ordered final-state showers,
60795C CTEQ5L parton distributions
60796C...Key feature: Rick Field's Tune A, but with new final-state showers
60797C
60798C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60799C CTEQ5L parton distributions
60800C...Key feature: APT revamped with the Professor pT-ordered final-state
60801C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60802C...Perugia MPI workshop in October 2008.
60803C
60804C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60805C CTEQ5L parton distributions
60806C...Key feature: APT-Pro with final-state showers off the MPI,
60807C...lower ISR renormalization scale to improve agreement with the
60808C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60809C...to min-bias at 630 GeV.
60810C
60811C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60812C CTEQ6L1 parton distributions.
60813C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60814C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60815C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60816C
60817C=======================================================================
60818C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60819C=======================================================================
60820C
60821C S0 (300) and S0A (303). CTEQ5L parton distributions
60822C...Key feature: large amount of multiple interactions
60823C...* Somewhat faster than the other colour annealing scenarios.
60824C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60825C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60826C...* Small amount of radiation.
60827C...* Large amount of low-pT MI
60828C...* Low degree of proton lumpiness (broad matter dist.)
60829C...* CR Type S (driven by free triplets), of medium strength.
60830C...* See: Pythia6402 update notes or later.
60831C
60832C S1 (301). CTEQ5L parton distributions
60833C...Key feature: large amount of radiation.
60834C...* Large amount of low-pT perturbative ISR
60835C...* Large amount of FSR off ISR partons
60836C...* Small amount of low-pT multiple interactions
60837C...* Moderate degree of proton lumpiness
60838C...* Least aggressive CR type (S+S Type I), but with large strength
60839C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60840C
60841C S2 (302). CTEQ5L parton distributions
60842C...Key feature: very lumpy proton + gg string cluster formation allowed
60843C...* Small amount of radiation
60844C...* Moderate amount of low-pT MI
60845C...* High degree of proton lumpiness (more spiky matter distribution)
60846C...* Most aggressive CR type (S+S Type II), but with small strength
60847C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60848C
60849C NOCR (304). CTEQ5L parton distributions
60850C...Key feature: no colour reconnections (NB: "Best fit" only).
60851C...* NB: <pT>(Nch) problematic in this tune.
60852C...* Small amount of radiation
60853C...* Small amount of low-pT MI
60854C...* Low degree of proton lumpiness
60855C...* Large BR composite x enhancement factor
60856C...* Most clever colour flow without CR ("Lambda ordering")
60857C
60858C ATLAS-CSC (306). CTEQ6L parton distributions
60859C...Key feature: 11-parameter ATLAS tune of the new framework.
60860C...* Old (pre-annealing) colour reconnections a la 305.
60861C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60862C
60863C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60864C...Key feature: the S0 family of tunes revamped with the Professor
60865C...pT-ordered final-state shower and fragmentation tunes presented by
60866C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60867C...Key feature: improved descriptions of LEP data.
60868C
60869C Perugia-0 (320). CTEQ5L parton distributions.
60870C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60871C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60872C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60873C...beam-remnant breakup (more baryon number transport), and suppression
60874C...of CR in high-pT string pieces.
60875C
60876C Perugia-HARD (321). CTEQ5L parton distributions.
60877C...Key feature: More ISR, More FSR, Less MPI, Less BR
60878C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60879C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60880C...baryon number transport), and more fragmentation pT.
60881C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60882C...DY pT spectrum is HARD.
60883C
60884C Perugia-SOFT (322). CTEQ5L parton distributions.
60885C...Key feature: Less ISR, Less FSR, More MPI, More BR
60886C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60887C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
60888C...number transport), and less fragmentation pT.
60889C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
60890C...DY pT spectrum is SOFT
60891C
60892C Perugia-3 (323). CTEQ5L parton distributions.
60893C...Key feature: variant of Perugia-0 with more extreme energy scaling
60894C...properties while still agreeing with Tevatron data from 630 to 1960.
60895C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
60896C...allows FSR off the active end of dipoles stretched to the remnant.
60897C
60898C Perugia-NOCR (324). CTEQ5L parton distributions.
60899C...Key feature: Retune of NOCR-Pro with better scaling properties to
60900C...lower energies and somewhat better agreement with Tevatron data
60901C...at 1800/1960.
60902C
60903C Perugia-* (325). MRST LO* parton distributions for generators
60904C...Key feature: first attempt at using the LO* distributions
60905C...(external pdf library must be linked).
60906C
60907C Perugia-6 (326). CTEQ6L1 parton distributions
60908C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
60909C
60910C Pro-pT0 (329). CTEQ5L parton distributions
60911C...Key feature: Complete retune of new model by Professor, including
60912C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
60913C
60914C=======================================================================
60915C OTHER TUNES
60916C=======================================================================
60917C
60918C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
60919C...with an unmodified Pythia distribution.
60920C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
60921C
60922C ::: + Future improvements?
60923C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
60924C (problem: K-factor affects everything so only works as
60925C intended for min-bias, not for UE ... probably need a
60926C better long-term solution to handle UE as well. Anyway,
60927C Mark uses MSTP(33) and PARP(31)-PARP(33).)
60928
60929C...Global statements
60930 IMPLICIT DOUBLE PRECISION(a-h, o-z)
60931 INTEGER PYK,PYCHGE,PYCOMP
60932
60933C...Commonblocks.
60934 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
60935 common/pypars/mstp(200),parp(200),msti(200),pari(200)
60936
60937C...SCI and GAL Commonblocks
60938 COMMON /scipar/mswi(2),parsci(2)
60939
60940C...SAVE statements
60941 SAVE /pydat1/,/pypars/
60942 SAVE /scipar/
60943
60944C...Internal parameters
60945 parameter(mxtuns=500)
60946 CHARACTER*8 CHVERS, CHDOC
60947 PARAMETER (CHVERS='1.015 ',chdoc='Jan 2009')
60948 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
60949 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
60950 & chparj(1:100), ch40
60951 CHARACTER*60 CH60
60952 CHARACTER*70 CH70
60953 DATA (chnams(i),i=0,1)/'Default',' '/
60954 DATA (chnams(i),i=100,119)/
60955 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
60956 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
60957 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
60958 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
60959 1 'Tune D6-Pro','Tune D6T-Pro'/
60960 DATA (chnams(i),i=120,129)/
60961 & 9*' ','Pro-Q20'/
60962 DATA (chnams(i),i=300,309)/
60963 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
60964 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
60965 DATA (chnams(i),i=310,315)/
60966 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
60967 & 'NOCR-Pro','Old-Pro'/
60968 DATA (chnams(i),i=320,329)/
60969 & 'Perugia 0','Perugia HARD','Perugia SOFT',
60970 & 'Perugia 3','Perugia NOCR','Perugia LO*',
60971 & 'Perugia 6',2*' ','Pro-pT0'/
60972 DATA (chnams(i),i=200,229)/
60973 & 'IM Tune 1','Tune APT',8*' ',
60974 & ' ','Tune APT-Pro',8*' ',
60975 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
60976 DATA (chnams(i),i=400,409)/
60977 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
60978 DATA (chmstj(i),i=11,20)/
60979 & 'HAD choice of fragmentation function(s)',4*' ',
60980 & 'HAD treatment of small-mass systems',4*' '/
60981 DATA (chmstj(i),i=41,50)/
60982 & 'FSR type (Q2 or pT) for old framework',9*' '/
60983 DATA (chmstp(i),i=51,100)/
60984 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
60985 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
60986 6 'ISR coherence option for 1st emission',
60987 6 'ISR phase space choice & ME corrections',' ',
60988 7 'ISR IR regularization scheme',' ',
60989 7 'ISR scheme for FSR off ISR',8*' ',
60990 8 'UE model',
60991 8 'UE hadron transverse mass distribution',5*' ',
60992 8 'BR composite scheme','BR colour scheme',
60993 9 'BR primordial kT compensation',
60994 9 'BR primordial kT distribution',
60995 9 'BR energy partitioning scheme',2*' ',
60996 9 'FSI colour (re-)connection model',5*' '/
60997 DATA (chparp(i),i=61,100)/
60998 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
60999 6 2*' ','ISR Q2max factor',3*' ',
61000 7 'FSR Q2max factor for non-s-channel procs',5*' ',
61001 7 'FSI colour reco high-pT dampening strength',
61002 7 'FSI colour reconnection strength',
61003 7 'BR composite x enhancement','BR breakup suppression',
61004 8 2*'UE IR cutoff at reference ecm',
61005 8 2*'UE mass distribution parameter',
61006 8 'UE gg colour correlated fraction','UE total gg fraction',
61007 8 2*' ',
61008 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61009 9 'BR primordial kT width <|kT|>',' ',
61010 9 'BR primordial kT UV cutoff',7*' '/
61011 DATA (chparj(i),i=1,30)/
61012 & 'HAD diquark suppression','HAD strangeness suppression',
61013 & 'HAD strange diquark suppression',
61014 & 'HAD vector diquark suppression',6*' ',
61015 1 'HAD P(vector meson), u and d only',
61016 1 'HAD P(vector meson), contains s',
61017 1 'HAD P(vector meson), heavy quarks',7*' ',
61018 2 'HAD fragmentation pT',' ',' ',' ',
61019 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61020 DATA (chparj(i),i=41,90)/
61021 4 'HAD string parameter a','HAD string parameter b',3*' ',
61022 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61023 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61024 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61025 6 10*' ',10*' ',
61026 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61027
61028C...1) Shorthand notation
61029 m13=mstu(13)
61030 m11=mstu(11)
61031 IF (itune.LE.mxtuns.AND.itune.GE.0) THEN
61032 chname=chnams(itune)
61033 IF (itune.EQ.0) GOTO 9999
61034 ELSE
61035 CALL pyerrm(9,'(PYTUNE:) Tune number > max. Using defaults.')
61036 GOTO 9999
61037 ENDIF
61038
61039C...2) Hello World
61040 IF (m13.GE.1) WRITE(m11,5000) chvers, chdoc
61041
61042C...3) Tune parameters
61043
61044C=======================================================================
61045C...S0, S1, S2, S0A, NOCR, Rap,
61046C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61047C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61048C...Pro-pT0
61049 IF ((itune.GE.300.AND.itune.LE.305)
61050 & .OR.(itune.GE.310.AND.itune.LE.315)
61051 & .OR.(itune.GE.320.AND.itune.LE.326).OR.itune.EQ.329) THEN
61052 IF (m13.GE.1) WRITE(m11,5010) itune, chname
61053 IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
61054 CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61055 & ' with tune.')
61056 ELSEIF(itune.GE.320.AND.itune.LE.326.AND.itune.NE.324.AND.
61057 & (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.419)))
61058 & THEN
61059 CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61060 & ' with tune.')
61061 ENDIF
61062
61063C...Use Professor's LEP pars if ITUNE >= 310
61064C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61065 IF (itune.LT.310) THEN
61066C...# Old default flavour parameters
61067
61068 ELSEIF (itune.GE.310) THEN
61069C...# Tuned flavour parameters:
61070 parj(1) = 0.073
61071 parj(2) = 0.2
61072 parj(3) = 0.94
61073 parj(4) = 0.032
61074 parj(11) = 0.31
61075 parj(12) = 0.4
61076 parj(13) = 0.54
61077 parj(25) = 0.63
61078 parj(26) = 0.12
61079C...# Always use pT-ordered shower:
61080 mstj(41) = 12
61081C...# Switch on Bowler:
61082 mstj(11) = 5
61083C...# Fragmentation
61084 parj(21) = 0.313
61085 parj(41) = 0.49
61086 parj(42) = 1.2
61087 parj(47) = 1.0
61088 parj(81) = 0.257
61089 parj(82) = 0.8
61090 ENDIF
61091
61092C...Remove middle digit now for Professor variants, since identical pars
61093 ituneb=itune
61094 IF (itune.GE.310.AND.itune.LE.319) THEN
61095 ituneb=(itune/100)*100+mod(itune,10)
61096 ENDIF
61097
61098C...PDFs: all use CTEQ5L as starting point
61099 mstp(52)=1
61100 mstp(51)=7
61101 IF (itune.EQ.325) THEN
61102C...MRST LO* for 325
61103 mstp(52)=2
61104 mstp(51)=20650
61105 ELSEIF (itune.EQ.326) THEN
61106C...CTEQ6L1 for 326
61107 mstp(52)=2
61108 mstp(51)=10042
61109 ENDIF
61110
61111C...ISR: use Lambda_MSbar with default scale for S0(A)
61112 mstp(64)=2
61113 parp(64)=1d0
61114 IF (itune.EQ.320.OR.itune.EQ.323.OR.itune.EQ.324.OR.
61115 & itune.EQ.326) THEN
61116C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61117 mstp(64)=3
61118 parp(64)=1d0
61119 ELSEIF (itune.EQ.321) THEN
61120C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61121 mstp(64)=3
61122 parp(64)=0.25d0
61123 ELSEIF (itune.EQ.322) THEN
61124C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61125 mstp(64)=2
61126 parp(64)=2d0
61127 ELSEIF (itune.EQ.325) THEN
61128C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61129 mstp(64)=3
61130 parp(64)=2d0
61131 ELSEIF (itune.EQ.329) THEN
61132C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61133 mstp(64)=2
61134 parp(64)=1.3d0
61135 ENDIF
61136
61137C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61138 mstp(67)=2
61139 parp(67)=4d0
61140C...Perugia tunes have stronger suppression, except HARD
61141 IF (itune.GE.320.AND.itune.LE.326) THEN
61142 parp(67)=1d0
61143 IF (itune.EQ.321) parp(67)=4d0
61144 IF (itune.EQ.322) parp(67)=0.5d0
61145 ENDIF
61146
61147C...ISR IR cutoff type and FSR off ISR setting:
61148C...Smooth ISR, low FSR-off-ISR
61149 mstp(70)=2
61150 mstp(72)=0
61151 IF (ituneb.EQ.301) THEN
61152C...S1, S1-Pro: sharp ISR, high FSR
61153 mstp(70)=0
61154 mstp(72)=1
61155 ELSEIF (itune.EQ.320.OR.itune.EQ.324.OR.itune.EQ.326
61156 & .OR.itune.EQ.325) THEN
61157C...Perugia default is smooth ISR, high FSR-off-ISR
61158 mstp(70)=2
61159 mstp(72)=1
61160 ELSEIF (itune.EQ.321) THEN
61161C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61162 mstp(70)=0
61163 parp(62)=1.25d0
61164 mstp(72)=1
61165 ELSEIF (itune.EQ.322) THEN
61166C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61167 mstp(70)=1
61168 parp(81)=1.5d0
61169 mstp(72)=0
61170 ELSEIF (itune.EQ.323) THEN
61171C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61172 mstp(70)=0
61173 parp(62)=1.25d0
61174 mstp(72)=2
61175 ENDIF
61176
61177C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61178C...by Professor tunes (with HARD and SOFT variations)
61179 parp(71)=4d0
61180 IF (itune.GE.320.AND.itune.LE.326) THEN
61181 parp(71)=2d0
61182 IF (itune.EQ.321) parp(71)=4d0
61183 IF (itune.EQ.322) parp(71)=1d0
61184 ENDIF
61185
61186C...FSR: Lambda_FSR scale (only if not using professor)
61187 IF (itune.LT.310) parj(81)=0.23d0
61188 IF (itune.EQ.321) parj(81)=0.30d0
61189 IF (itune.EQ.322) parj(81)=0.20d0
61190
61191C...UE on, new model
61192 mstp(81)=21
61193
61194C...UE: hadron-hadron overlap profile (expOfPow for all)
61195 mstp(82)=5
61196C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61197 parp(83)=1.6d0
61198 IF (ituneb.EQ.301) parp(83)=1.4d0
61199 IF (ituneb.EQ.302) parp(83)=1.2d0
61200C...NOCR variants have very smooth distributions
61201 IF (ituneb.EQ.304) parp(83)=1.8d0
61202 IF (ituneb.EQ.305) parp(83)=2.0d0
61203 IF (itune.GE.320.AND.itune.LE.326) THEN
61204C...Perugia variants have slightly smoother profiles by default
61205C...(to compensate for more tail by added radiation)
61206C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61207 parp(83)=1.7d0
61208 IF (itune.EQ.322) parp(83)=1.5d0
61209 IF (itune.EQ.324) parp(83)=1.8d0
61210 ENDIF
61211C...Professor-pT0 also has very smooth distribution
61212 IF (itune.EQ.329) parp(83)=1.8
61213
61214C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61215 parp(82)=1.85d0
61216 IF (ituneb.EQ.301) parp(82)=2.1d0
61217 IF (ituneb.EQ.302) parp(82)=1.9d0
61218 IF (ituneb.EQ.304) parp(82)=2.05d0
61219 IF (ituneb.EQ.305) parp(82)=1.9d0
61220 IF (itune.GE.320.AND.itune.LE.326) THEN
61221C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61222C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61223C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61224C...slightly higher, due to increased activity.
61225 parp(82)=2.0d0
61226 IF (itune.EQ.321) parp(82)=2.3d0
61227 IF (itune.EQ.322) parp(82)=1.9d0
61228 IF (itune.EQ.323) parp(82)=2.2d0
61229 IF (itune.EQ.324) parp(82)=1.95d0
61230 IF (itune.EQ.325) parp(82)=2.2d0
61231 IF (itune.EQ.326) parp(82)=1.95d0
61232 ENDIF
61233C...Professor-pT0 maintains low pT0 vaue
61234 IF (itune.EQ.329) parp(82)=1.85d0
61235
61236C...UE: IR cutoff reference energy and default energy scaling pace
61237 parp(89)=1800d0
61238 parp(90)=0.16d0
61239C...S0A, S0A-Pro have tune A energy scaling
61240 IF (ituneb.EQ.303) parp(90)=0.25d0
61241 IF (itune.GE.320.AND.itune.LE.326) THEN
61242C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61243 parp(90)=0.26
61244 IF (itune.EQ.321) parp(90)=0.30d0
61245 IF (itune.EQ.322) parp(90)=0.24d0
61246 IF (itune.EQ.323) parp(90)=0.32d0
61247 IF (itune.EQ.324) parp(90)=0.24d0
61248C...LO* and CTEQ6L1 tunes have slower energy scaling
61249 IF (itune.EQ.325) parp(90)=0.23d0
61250 IF (itune.EQ.326) parp(90)=0.22d0
61251 ENDIF
61252C...Professor-pT0 has intermediate scaling
61253 IF (itune.EQ.329) parp(90)=0.22d0
61254
61255C...BR: MPI initiator color connections rap-ordered by default
61256C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61257 mstp(89)=1
61258 IF (ituneb.EQ.304.OR.itune.EQ.324) mstp(89)=2
61259 IF (itune.EQ.322) mstp(89)=0
61260
61261C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61262 parp(80)=0.01d0
61263 IF (itune.GE.320.AND.itune.LE.326) THEN
61264C...Perugia tunes have more beam blowup by default
61265 parp(80)=0.05d0
61266 IF (itune.EQ.321) parp(80)=0.01
61267 IF (itune.EQ.323) parp(80)=0.03
61268 IF (itune.EQ.324) parp(80)=0.01
61269 ENDIF
61270
61271C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61272 mstp(88)=0
61273 parp(79)=2d0
61274 IF (ituneb.EQ.304) parp(79)=3d0
61275 IF (itune.EQ.329) parp(79)=1.18
61276
61277C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61278 mstp(91)=1
61279 parp(91)=2d0
61280 parp(93)=10d0
61281C...Perugia-HARD only uses 1.0 GeV
61282 IF (itune.EQ.321) parp(91)=1.0d0
61283C...Perugia-3 only uses 1.5 GeV
61284 IF (itune.EQ.323) parp(91)=1.5d0
61285C...Professor-pT0 uses 7-GeV cutoff
61286 IF (itune.EQ.329) parp(93)=7.0
61287
61288C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61289 mstp(95)=6
61290C...S1, S1-Pro: use S1
61291 IF (ituneb.EQ.301) mstp(95)=2
61292C...S2, S2-Pro: use S2
61293 IF (ituneb.EQ.302) mstp(95)=4
61294C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61295 IF (itune.EQ.304.OR.itune.EQ.314.OR.itune.EQ.324) mstp(95)=0
61296C..."Old" and "Old"-Pro: use old CR
61297 IF (ituneb.EQ.305) mstp(95)=1
61298
61299C...FSI: CR strength and high-pT dampening, default is S0
61300 IF (itune.LT.320.OR.itune.EQ.329) THEN
61301 parp(78)=0.2d0
61302 parp(77)=0d0
61303 IF (ituneb.EQ.301) parp(78)=0.35d0
61304 IF (ituneb.EQ.302) parp(78)=0.15d0
61305 IF (ituneb.EQ.304) parp(78)=0.0d0
61306 IF (ituneb.EQ.305) parp(78)=1.0d0
61307 IF (itune.EQ.329) parp(78)=0.17d0
61308 ELSE
61309C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61310 parp(78)=0.33
61311 parp(77)=0.9d0
61312 IF (itune.EQ.321) THEN
61313C...HARD has HIGH amount of CR
61314 parp(78)=0.37d0
61315 parp(77)=0.4d0
61316 ELSEIF (itune.EQ.322) THEN
61317C...SOFT has LOW amount of CR
61318 parp(78)=0.15d0
61319 parp(77)=0.5d0
61320 ELSEIF (itune.EQ.323) THEN
61321C...Scaling variant appears to need slightly more than default
61322 parp(78)=0.35d0
61323 parp(77)=0.6d0
61324 ELSEIF (itune.EQ.324) THEN
61325C...NOCR has no CR
61326 parp(78)=0d0
61327 parp(77)=0d0
61328 ENDIF
61329 ENDIF
61330
61331C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61332 IF (itune.EQ.321) parj(21)=0.34d0
61333 IF (itune.EQ.322) parj(21)=0.28d0
61334
61335C...Switch off trial joinings
61336 mstp(96)=0
61337
61338C...S0 (300), S0A (303)
61339 IF (ituneb.EQ.300.OR.ituneb.EQ.303) THEN
61340 IF (m13.GE.1) THEN
61341 ch60='see P. Skands & D. Wicke, hep-ph/0703081'
61342 WRITE(m11,5030) ch60
61343 ch60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61344 WRITE(m11,5030) ch60
61345 ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61346 WRITE(m11,5030) ch60
61347 IF (itune.GE.310) THEN
61348 ch60='LEP parameters tuned by Professor'
61349 WRITE(m11,5030) ch60
61350 ENDIF
61351 ENDIF
61352
61353C...S1 (301)
61354 ELSEIF(ituneb.EQ.301) THEN
61355 IF (m13.GE.1) THEN
61356 ch60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61357 WRITE(m11,5030) ch60
61358 ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61359 WRITE(m11,5030) ch60
61360 IF (itune.GE.310) THEN
61361 ch60='LEP parameters tuned with Professor'
61362 WRITE(m11,5030) ch60
61363 ENDIF
61364 ENDIF
61365
61366C...S2 (302)
61367 ELSEIF(ituneb.EQ.302) THEN
61368 IF (m13.GE.1) THEN
61369 ch60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61370 WRITE(m11,5030) ch60
61371 ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61372 WRITE(m11,5030) ch60
61373 IF (itune.GE.310) THEN
61374 ch60='LEP parameters tuned by Professor'
61375 WRITE(m11,5030) ch60
61376 ENDIF
61377 ENDIF
61378
61379C...NOCR (304)
61380 ELSEIF(ituneb.EQ.304) THEN
61381 IF (m13.GE.1) THEN
61382 ch60='"best try" without colour reconnections'
61383 WRITE(m11,5030) ch60
61384 ch60='see P. Skands & D. Wicke, hep-ph/0703081'
61385 WRITE(m11,5030) ch60
61386 ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61387 WRITE(m11,5030) ch60
61388 IF (itune.GE.310) THEN
61389 ch60='LEP parameters tuned by Professor'
61390 WRITE(m11,5030) ch60
61391 ENDIF
61392 ENDIF
61393
61394C..."Lo FSR" retune (305)
61395 ELSEIF(ituneb.EQ.305) THEN
61396 IF (m13.GE.1) THEN
61397 ch60='"Lo FSR retune" with primitive colour reconnections'
61398 WRITE(m11,5030) ch60
61399 ch60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61400 WRITE(m11,5030) ch60
61401 IF (itune.GE.310) THEN
61402 ch60='LEP parameters tuned by Professor'
61403 WRITE(m11,5030) ch60
61404 ENDIF
61405 ENDIF
61406
61407C...Perugia Tunes (320-326)
61408 ELSEIF(itune.GE.320.AND.itune.LE.326) THEN
61409 IF (m13.GE.1) THEN
61410 ch60='P. Skands, Perugia MPI workshop October 2008'
61411 WRITE(m11,5030) ch60
61412 ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61413 WRITE(m11,5030) ch60
61414 ch60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61415 WRITE(m11,5030) ch60
61416 ch60='LEP parameters tuned by Professor'
61417 WRITE(m11,5030) ch60
61418 IF (itune.EQ.325) THEN
61419 ch70='NB! This tune requires MRST LO* pdfs to be '//
61420 & 'externally linked'
61421 WRITE(m11,5035) ch70
61422 ELSEIF (itune.EQ.326) THEN
61423 ch70='NB! This tune requires CTEQ6L1 pdfs to be '//
61424 & 'externally linked'
61425 WRITE(m11,5035) ch70
61426 ELSEIF (itune.EQ.321) THEN
61427 ch60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61428 WRITE(m11,5030) ch60
61429 ELSEIF (itune.EQ.322) THEN
61430 ch60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61431 WRITE(m11,5030) ch60
61432 ENDIF
61433 ENDIF
61434
61435C...Professor-pT0 (329)
61436 ELSEIF(itune.EQ.329) THEN
61437 IF (m13.GE.1) THEN
61438 ch60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61439 WRITE(m11,5030) ch60
61440 ch60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61441 WRITE(m11,5030) ch60
61442 ch60='LEP/Tevatron parameters tuned by Professor'
61443 WRITE(m11,5030) ch60
61444 ENDIF
61445
61446 ENDIF
61447
61448C...Output
61449 IF (m13.GE.1) THEN
61450 WRITE(m11,5030) ' '
61451 WRITE(m11,5040) 51, mstp(51), chmstp(51)
61452 WRITE(m11,5040) 52, mstp(52), chmstp(52)
61453 IF (mstp(70).EQ.0) THEN
61454 WRITE(m11,5050) 62, parp(62), chparp(62)
61455 ELSEIF (mstp(70).EQ.1) THEN
61456 WRITE(m11,5050) 81, parp(81), chparp(62)
61457 ch60='(Note: PARP(81) replaces PARP(62).)'
61458 WRITE(m11,5030) ch60
61459 ENDIF
61460 WRITE(m11,5040) 64, mstp(64), chmstp(64)
61461 WRITE(m11,5050) 64, parp(64), chparp(64)
61462 WRITE(m11,5040) 67, mstp(67), chmstp(67)
61463 WRITE(m11,5050) 67, parp(67), chparp(67)
61464 WRITE(m11,5040) 68, mstp(68), chmstp(68)
61465 ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61466 WRITE(m11,5030) ch60
61467 WRITE(m11,5040) 70, mstp(70), chmstp(70)
61468 WRITE(m11,5040) 72, mstp(72), chmstp(72)
61469 WRITE(m11,5050) 71, parp(71), chparp(71)
61470 WRITE(m11,5060) 81, parj(81), chparj(81)
61471 WRITE(m11,5060) 82, parj(82), chparj(82)
61472 WRITE(m11,5040) 81, mstp(81), chmstp(81)
61473 WRITE(m11,5050) 82, parp(82), chparp(82)
61474 IF (mstp(70).EQ.2) THEN
61475 ch60='(Note: PARP(82) replaces PARP(62).)'
61476 WRITE(m11,5030) ch60
61477 ENDIF
61478 WRITE(m11,5050) 89, parp(89), chparp(89)
61479 WRITE(m11,5050) 90, parp(90), chparp(90)
61480 WRITE(m11,5040) 82, mstp(82), chmstp(82)
61481 WRITE(m11,5050) 83, parp(83), chparp(83)
61482 WRITE(m11,5040) 88, mstp(88), chmstp(88)
61483 WRITE(m11,5040) 89, mstp(89), chmstp(89)
61484 WRITE(m11,5050) 79, parp(79), chparp(79)
61485 WRITE(m11,5050) 80, parp(80), chparp(80)
61486 WRITE(m11,5040) 91, mstp(91), chmstp(91)
61487 WRITE(m11,5050) 91, parp(91), chparp(91)
61488 WRITE(m11,5050) 93, parp(93), chparp(93)
61489 WRITE(m11,5040) 95, mstp(95), chmstp(95)
61490 IF (mstp(95).GE.1) THEN
61491 WRITE(m11,5050) 78, parp(78), chparp(78)
61492 IF (mstp(95).GE.2) WRITE(m11,5050) 77, parp(77), chparp(77)
61493 ENDIF
61494 WRITE(m11,5070) 11, mstj(11), chmstj(11)
61495 WRITE(m11,5060) 21, parj(21), chparj(21)
61496 WRITE(m11,5060) 41, parj(41), chparj(41)
61497 WRITE(m11,5060) 42, parj(42), chparj(42)
61498 IF (mstj(11).LE.3) THEN
61499 WRITE(m11,5060) 54, parj(54), chparj(54)
61500 WRITE(m11,5060) 55, parj(55), chparj(55)
61501 ELSE
61502 WRITE(m11,5060) 46, parj(46), chparj(46)
61503 ENDIF
61504 IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
61505 ENDIF
61506
61507C=======================================================================
61508C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61509 ELSEIF (itune.EQ.306) THEN
61510 IF (m13.GE.1) WRITE(m11,5010) itune, chname
61511 IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
61512 CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61513 & ' with tune.')
61514 ENDIF
61515
61516C...PDFs
61517 mstp(52)=2
61518 mstp(54)=2
61519 mstp(51)=10042
61520 mstp(53)=10042
61521C...ISR
61522C PARP(64)=1D0
61523C...UE on, new model.
61524 mstp(81)=21
61525C...Energy scaling
61526 parp(89)=1800d0
61527 parp(90)=0.22d0
61528C...Switch off trial joinings
61529 mstp(96)=0
61530C...Primordial kT cutoff
61531
61532 IF (m13.GE.1) THEN
61533 ch60='see presentations by A. Moraes (ATLAS),'
61534 WRITE(m11,5030) ch60
61535 ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61536 WRITE(m11,5030) ch60
61537 WRITE(m11,5030) ' '
61538 ch70='NB! This tune requires CTEQ6.1 pdfs to be '//
61539 & 'externally linked'
61540 WRITE(m11,5035) ch70
61541 ENDIF
61542C...Smooth ISR, low FSR
61543 mstp(70)=2
61544 mstp(72)=0
61545C...pT0
61546 parp(82)=1.9d0
61547C...Transverse density profile.
61548 mstp(82)=4
61549 parp(83)=0.3d0
61550 parp(84)=0.5d0
61551C...ISR & FSR in interactions after the first (default)
61552 mstp(84)=1
61553 mstp(85)=1
61554C...No double-counting (default)
61555 mstp(86)=2
61556C...Companion quark parent gluon (1-x) power
61557 mstp(87)=4
61558C...Primordial kT compensation along chaings (default = 0 : uniform)
61559 mstp(90)=1
61560C...Colour Reconnections
61561 mstp(95)=1
61562 parp(78)=0.2d0
61563C...Lambda_FSR scale.
61564 parj(81)=0.23d0
61565C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61566 mstp(89)=1
61567 mstp(88)=0
61568C PARP(79)=2D0
61569 parp(80)=0.01d0
61570C...Peterson charm frag, and c and b hadr parameters
61571 mstj(11)=3
61572 parj(54)=-0.07
61573 parj(55)=-0.006
61574C... Output
61575 IF (m13.GE.1) THEN
61576 WRITE(m11,5030) ' '
61577 WRITE(m11,5040) 51, mstp(51), chmstp(51)
61578 WRITE(m11,5040) 52, mstp(52), chmstp(52)
61579 WRITE(m11,5050) 64, parp(64), chparp(64)
61580 WRITE(m11,5040) 68, mstp(68), chmstp(68)
61581 ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61582 WRITE(m11,5030) ch60
61583 WRITE(m11,5040) 70, mstp(70), chmstp(70)
61584 WRITE(m11,5040) 72, mstp(72), chmstp(72)
61585 WRITE(m11,5050) 71, parp(71), chparp(71)
61586 WRITE(m11,5060) 81, parj(81), chparj(81)
61587 ch60='(Note: PARJ(81) changed from 0.14! See update notes)'
61588 WRITE(m11,5030) ch60
61589 WRITE(m11,5040) 81, mstp(81), chmstp(81)
61590 WRITE(m11,5050) 82, parp(82), chparp(82)
61591 WRITE(m11,5050) 89, parp(89), chparp(89)
61592 WRITE(m11,5050) 90, parp(90), chparp(90)
61593 WRITE(m11,5040) 82, mstp(82), chmstp(82)
61594 WRITE(m11,5050) 83, parp(83), chparp(83)
61595 WRITE(m11,5050) 84, parp(84), chparp(84)
61596 WRITE(m11,5040) 88, mstp(88), chmstp(88)
61597 WRITE(m11,5040) 89, mstp(89), chmstp(89)
61598 WRITE(m11,5040) 90, mstp(90), chmstp(90)
61599 WRITE(m11,5050) 79, parp(79), chparp(79)
61600 WRITE(m11,5050) 80, parp(80), chparp(80)
61601 WRITE(m11,5050) 93, parp(93), chparp(93)
61602 WRITE(m11,5040) 95, mstp(95), chmstp(95)
61603 WRITE(m11,5050) 78, parp(78), chparp(78)
61604 WRITE(m11,5070) 11, mstj(11), chmstj(11)
61605 WRITE(m11,5060) 21, parj(21), chparj(21)
61606 WRITE(m11,5060) 41, parj(41), chparj(41)
61607 WRITE(m11,5060) 42, parj(42), chparj(42)
61608 IF (mstj(11).LE.3) THEN
61609 WRITE(m11,5060) 54, parj(54), chparj(54)
61610 WRITE(m11,5060) 55, parj(55), chparj(55)
61611 ELSE
61612 WRITE(m11,5060) 46, parj(46), chparj(46)
61613 ENDIF
61614 IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
61615 ENDIF
61616
61617C=======================================================================
61618C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61619C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61620C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61621 ELSEIF ((itune.GE.100.AND.itune.LE.106).OR.itune.EQ.108.OR.
61622 & itune.EQ.109.OR.(itune.GE.110.AND.itune.LE.116).OR.
61623 & itune.EQ.118.OR.itune.EQ.119.OR.itune.EQ.129) THEN
61624 IF (m13.GE.1.AND.itune.NE.106.AND.itune.NE.129) THEN
61625 WRITE(m11,5010) itune, chname
61626 ch60='see R.D. Field, in hep-ph/0610012'
61627 WRITE(m11,5030) ch60
61628 ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61629 WRITE(m11,5030) ch60
61630 IF (itune.GE.110.AND.itune.LE.119) THEN
61631 ch60='LEP parameters tuned by Professor'
61632 WRITE(m11,5030) ch60
61633 ENDIF
61634 ELSEIF (m13.GE.1.AND.itune.EQ.129) THEN
61635 WRITE(m11,5010) itune, chname
61636 ch60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61637 WRITE(m11,5030) ch60
61638 ch60='LEP/Tevatron parameters tuned by Professor'
61639 WRITE(m11,5030) ch60
61640 ENDIF
61641
61642C...Make sure we start from old default fragmentation parameters
61643 parj(81) = 0.29
61644 parj(82) = 1.0
61645
61646C...Use Professor's LEP pars if ITUNE >= 110
61647C...(i.e., for A-Pro, DW-Pro etc)
61648 IF (itune.GE.110) THEN
61649C...# Tuned flavour parameters:
61650 parj(1) = 0.073
61651 parj(2) = 0.2
61652 parj(3) = 0.94
61653 parj(4) = 0.032
61654 parj(11) = 0.31
61655 parj(12) = 0.4
61656 parj(13) = 0.54
61657 parj(25) = 0.63
61658 parj(26) = 0.12
61659C...# Switch on Bowler:
61660 mstj(11) = 5
61661C...# Fragmentation
61662 parj(21) = 0.325
61663 parj(41) = 0.5
61664 parj(42) = 0.6
61665 parj(47) = 0.67
61666 parj(81) = 0.29
61667 parj(82) = 1.65
61668 ENDIF
61669
61670C...Remove middle digit now for Professor variants, since identical pars
61671 ituneb=itune
61672 IF (itune.GE.110.AND.itune.LE.119) THEN
61673 ituneb=(itune/100)*100+mod(itune,10)
61674 ENDIF
61675
61676C...Multiple interactions on, old framework
61677 mstp(81)=1
61678C...Fast IR cutoff energy scaling by default
61679 parp(89)=1800d0
61680 parp(90)=0.25d0
61681C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61682 mstp(51)=7
61683 mstp(52)=1
61684 IF (ituneb.EQ.105) THEN
61685 mstp(51)=10150
61686 mstp(52)=2
61687 ELSEIF(ituneb.EQ.108.OR.ituneb.EQ.109) THEN
61688 mstp(52)=2
61689 mstp(54)=2
61690 mstp(51)=10042
61691 mstp(53)=10042
61692 ENDIF
61693C...Double Gaussian matter distribution.
61694 mstp(82)=4
61695 parp(83)=0.5d0
61696 parp(84)=0.4d0
61697C...FSR activity.
61698 parp(71)=4d0
61699C...Fragmentation functions and c and b parameters
61700C...(only if not using Professor)
61701 IF (itune.LE.109) THEN
61702 mstj(11)=4
61703 parj(54)=-0.05
61704 parj(55)=-0.005
61705 ENDIF
61706
61707C...Tune A and AW
61708 IF(ituneb.EQ.100.OR.ituneb.EQ.101) THEN
61709C...pT0.
61710 parp(82)=2.0d0
61711c...String drawing almost completely minimizes string length.
61712 parp(85)=0.9d0
61713 parp(86)=0.95d0
61714C...ISR cutoff, muR scale factor, and phase space size
61715 parp(62)=1d0
61716 parp(64)=1d0
61717 parp(67)=4d0
61718C...Intrinsic kT, size, and max
61719 mstp(91)=1
61720 parp(91)=1d0
61721 parp(93)=5d0
61722C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61723 IF (ituneb.EQ.101) THEN
61724 parp(62)=1.25d0
61725 parp(64)=0.2d0
61726 parp(91)=2.1d0
61727 parp(92)=15.0d0
61728 ENDIF
61729
61730C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61731 ELSEIF (ituneb.EQ.102) THEN
61732C...pT0.
61733 parp(82)=1.9d0
61734c...String drawing completely minimizes string length.
61735 parp(85)=1.0d0
61736 parp(86)=1.0d0
61737C...ISR cutoff, muR scale factor, and phase space size
61738 parp(62)=1.25d0
61739 parp(64)=0.2d0
61740 parp(67)=1d0
61741C...Intrinsic kT, size, and max
61742 mstp(91)=1
61743 parp(91)=2.1d0
61744 parp(93)=15d0
61745
61746C...Tune DW
61747 ELSEIF (ituneb.EQ.103) THEN
61748C...pT0.
61749 parp(82)=1.9d0
61750c...String drawing completely minimizes string length.
61751 parp(85)=1.0d0
61752 parp(86)=1.0d0
61753C...ISR cutoff, muR scale factor, and phase space size
61754 parp(62)=1.25d0
61755 parp(64)=0.2d0
61756 parp(67)=2.5d0
61757C...Intrinsic kT, size, and max
61758 mstp(91)=1
61759 parp(91)=2.1d0
61760 parp(93)=15d0
61761
61762C...Tune DWT
61763 ELSEIF (ituneb.EQ.104) THEN
61764C...pT0.
61765 parp(82)=1.9409d0
61766C...Run II ref scale and slow scaling
61767 parp(89)=1960d0
61768 parp(90)=0.16d0
61769c...String drawing completely minimizes string length.
61770 parp(85)=1.0d0
61771 parp(86)=1.0d0
61772C...ISR cutoff, muR scale factor, and phase space size
61773 parp(62)=1.25d0
61774 parp(64)=0.2d0
61775 parp(67)=2.5d0
61776C...Intrinsic kT, size, and max
61777 mstp(91)=1
61778 parp(91)=2.1d0
61779 parp(93)=15d0
61780
61781C...Tune QW
61782 ELSEIF(ituneb.EQ.105) THEN
61783 IF (m13.GE.1) THEN
61784 WRITE(m11,5030) ' '
61785 ch70='NB! This tune requires CTEQ6.1 pdfs to be '//
61786 & 'externally linked'
61787 WRITE(m11,5035) ch70
61788 ENDIF
61789C...pT0.
61790 parp(82)=1.1d0
61791c...String drawing completely minimizes string length.
61792 parp(85)=1.0d0
61793 parp(86)=1.0d0
61794C...ISR cutoff, muR scale factor, and phase space size
61795 parp(62)=1.25d0
61796 parp(64)=0.2d0
61797 parp(67)=2.5d0
61798C...Intrinsic kT, size, and max
61799 mstp(91)=1
61800 parp(91)=2.1d0
61801 parp(93)=15d0
61802
61803C...Tune D6 and D6T
61804 ELSEIF(ituneb.EQ.108.OR.ituneb.EQ.109) THEN
61805 IF (m13.GE.1) THEN
61806 WRITE(m11,5030) ' '
61807 ch70='NB! This tune requires CTEQ6L pdfs to be '//
61808 & 'externally linked'
61809 WRITE(m11,5035) ch70
61810 ENDIF
61811C...The "Rick" proton, double gauss with 0.5/0.4
61812 mstp(82)=4
61813 parp(83)=0.5d0
61814 parp(84)=0.4d0
61815c...String drawing completely minimizes string length.
61816 parp(85)=1.0d0
61817 parp(86)=1.0d0
61818 IF (ituneb.EQ.108) THEN
61819C...D6: pT0, Run I ref scale, and fast energy scaling
61820 parp(82)=1.8d0
61821 parp(89)=1800d0
61822 parp(90)=0.25d0
61823 ELSE
61824C...D6T: pT0, Run II ref scale, and slow energy scaling
61825 parp(82)=1.8387d0
61826 parp(89)=1960d0
61827 parp(90)=0.16d0
61828 ENDIF
61829C...ISR cutoff, muR scale factor, and phase space size
61830 parp(62)=1.25d0
61831 parp(64)=0.2d0
61832 parp(67)=2.5d0
61833C...Intrinsic kT, size, and max
61834 mstp(91)=1
61835 parp(91)=2.1d0
61836 parp(93)=15d0
61837
61838C...Old ATLAS-DC2 5-parameter tune
61839 ELSEIF(ituneb.EQ.106) THEN
61840 IF (m13.GE.1) THEN
61841 WRITE(m11,5010) itune, chname
61842 ch60='see A. Moraes et al., SN-ATLAS-2006-057,'
61843 WRITE(m11,5030) ch60
61844 ch60=' R. Field in hep-ph/0610012,'
61845 WRITE(m11,5030) ch60
61846 ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61847 WRITE(m11,5030) ch60
61848 ENDIF
61849C... pT0.
61850 parp(82)=1.8d0
61851C... Different ref and rescaling pacee
61852 parp(89)=1000d0
61853 parp(90)=0.16d0
61854C... Parameters of mass distribution
61855 parp(83)=0.5d0
61856 parp(84)=0.5d0
61857C... Old default string drawing
61858 parp(85)=0.33d0
61859 parp(86)=0.66d0
61860C... ISR, phase space equivalent to Tune B
61861 parp(62)=1d0
61862 parp(64)=1d0
61863 parp(67)=1d0
61864C... FSR
61865 parp(71)=4d0
61866C... Intrinsic kT
61867 mstp(91)=1
61868 parp(91)=1d0
61869 parp(93)=5d0
61870
61871C...Professor's Pro-Q20 Tune
61872 ELSEIF(itune.EQ.129) THEN
61873 IF (m13.GE.1) THEN
61874 ch60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
61875 WRITE(m11,5030) ch60
61876 ENDIF
61877 parp(62)=2.9
61878 parp(64)=0.14
61879 parp(67)=2.65
61880 parp(82)=1.9
61881 parp(83)=0.83
61882 parp(84)=0.6
61883 parp(85)=0.86
61884 parp(86)=0.93
61885 parp(89)=1800d0
61886 parp(90)=0.22
61887 mstp(91)=1
61888 parp(91)=2.1
61889 parp(93)=5.0
61890
61891 ENDIF
61892
61893C... Output
61894 IF (m13.GE.1) THEN
61895 WRITE(m11,5030) ' '
61896 WRITE(m11,5040) 51, mstp(51), chmstp(51)
61897 WRITE(m11,5040) 52, mstp(52), chmstp(52)
61898 WRITE(m11,5050) 62, parp(62), chparp(62)
61899 WRITE(m11,5050) 64, parp(64), chparp(64)
61900 WRITE(m11,5050) 67, parp(67), chparp(67)
61901 WRITE(m11,5040) 68, mstp(68), chmstp(68)
61902 ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61903 WRITE(m11,5030) ch60
61904 WRITE(m11,5050) 71, parp(71), chparp(71)
61905 WRITE(m11,5060) 81, parj(81), chparj(81)
61906 WRITE(m11,5060) 82, parj(82), chparj(82)
61907 WRITE(m11,5040) 81, mstp(81), chmstp(81)
61908 WRITE(m11,5050) 82, parp(82), chparp(82)
61909 WRITE(m11,5050) 89, parp(89), chparp(89)
61910 WRITE(m11,5050) 90, parp(90), chparp(90)
61911 WRITE(m11,5040) 82, mstp(82), chmstp(82)
61912 WRITE(m11,5050) 83, parp(83), chparp(83)
61913 WRITE(m11,5050) 84, parp(84), chparp(84)
61914 WRITE(m11,5050) 85, parp(85), chparp(85)
61915 WRITE(m11,5050) 86, parp(86), chparp(86)
61916 WRITE(m11,5040) 91, mstp(91), chmstp(91)
61917 WRITE(m11,5050) 91, parp(91), chparp(91)
61918 WRITE(m11,5050) 93, parp(93), chparp(93)
61919 WRITE(m11,5070) 11, mstj(11), chmstj(11)
61920 WRITE(m11,5060) 21, parj(21), chparj(21)
61921 WRITE(m11,5060) 41, parj(41), chparj(41)
61922 WRITE(m11,5060) 42, parj(42), chparj(42)
61923 IF (mstj(11).LE.3) THEN
61924 WRITE(m11,5060) 54, parj(54), chparj(54)
61925 WRITE(m11,5060) 55, parj(55), chparj(55)
61926 ELSE
61927 WRITE(m11,5060) 46, parj(46), chparj(46)
61928 ENDIF
61929 IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
61930 ENDIF
61931
61932C=======================================================================
61933C... ACR, tune A with new CR (107)
61934 ELSEIF(itune.EQ.107.OR.itune.EQ.117) THEN
61935 IF (m13.GE.1) THEN
61936 WRITE(m11,5010) itune, chname
61937 ch60='Tune A modified with new colour reconnections'
61938 WRITE(m11,5030) ch60
61939 ch60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
61940 WRITE(m11,5030) ch60
61941 ch60='see P. Skands & D. Wicke, hep-ph/0703081,'
61942 WRITE(m11,5030) ch60
61943 ch60=' R. Field, in hep-ph/0610012 (Tune A),'
61944 WRITE(m11,5030) ch60
61945 ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61946 WRITE(m11,5030) ch60
61947 IF (itune.EQ.117) THEN
61948 ch60='LEP parameters tuned by Professor'
61949 WRITE(m11,5030) ch60
61950 ENDIF
61951 ENDIF
61952 IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.406))THEN
61953 CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61954 & ' with tune. Using defaults.')
61955 GOTO 100
61956 ENDIF
61957
61958C...Make sure we start from old default fragmentation parameters
61959 parj(81) = 0.29
61960 parj(82) = 1.0
61961
61962C...Use Professor's LEP pars if ITUNE >= 110
61963C...(i.e., for A-Pro, DW-Pro etc)
61964 IF (itune.GE.110) THEN
61965C...# Tuned flavour parameters:
61966 parj(1) = 0.073
61967 parj(2) = 0.2
61968 parj(3) = 0.94
61969 parj(4) = 0.032
61970 parj(11) = 0.31
61971 parj(12) = 0.4
61972 parj(13) = 0.54
61973 parj(25) = 0.63
61974 parj(26) = 0.12
61975C...# Switch on Bowler:
61976 mstj(11) = 5
61977C...# Fragmentation
61978 parj(21) = 0.325
61979 parj(41) = 0.5
61980 parj(42) = 0.6
61981 parj(47) = 0.67
61982 parj(81) = 0.29
61983 parj(82) = 1.65
61984 ENDIF
61985
61986 mstp(81)=1
61987 parp(89)=1800d0
61988 parp(90)=0.25d0
61989 mstp(82)=4
61990 parp(83)=0.5d0
61991 parp(84)=0.4d0
61992 mstp(51)=7
61993 mstp(52)=1
61994 parp(71)=4d0
61995 parp(82)=2.0d0
61996 parp(85)=0.0d0
61997 parp(86)=0.66d0
61998 parp(62)=1d0
61999 parp(64)=1d0
62000 parp(67)=4d0
62001 mstp(91)=1
62002 parp(91)=1d0
62003 parp(93)=5d0
62004 mstp(95)=6
62005C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62006 parp(78)=0.09d0
62007C...Frag functions (only if not using Professor)
62008 IF (itune.LE.109) THEN
62009 mstj(11)=4
62010 parj(54)=-0.05
62011 parj(55)=-0.005
62012 ENDIF
62013
62014C...Output
62015 IF (m13.GE.1) THEN
62016 WRITE(m11,5030) ' '
62017 WRITE(m11,5040) 51, mstp(51), chmstp(51)
62018 WRITE(m11,5040) 52, mstp(52), chmstp(52)
62019 WRITE(m11,5050) 62, parp(62), chparp(62)
62020 WRITE(m11,5050) 64, parp(64), chparp(64)
62021 WRITE(m11,5050) 67, parp(67), chparp(67)
62022 WRITE(m11,5040) 68, mstp(68), chmstp(68)
62023 ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62024 WRITE(m11,5030) ch60
62025 WRITE(m11,5050) 71, parp(71), chparp(71)
62026 WRITE(m11,5060) 81, parj(81), chparj(81)
62027 WRITE(m11,5060) 82, parj(82), chparj(82)
62028 WRITE(m11,5040) 81, mstp(81), chmstp(81)
62029 WRITE(m11,5050) 82, parp(82), chparp(82)
62030 WRITE(m11,5050) 89, parp(89), chparp(89)
62031 WRITE(m11,5050) 90, parp(90), chparp(90)
62032 WRITE(m11,5040) 82, mstp(82), chmstp(82)
62033 WRITE(m11,5050) 83, parp(83), chparp(83)
62034 WRITE(m11,5050) 84, parp(84), chparp(84)
62035 WRITE(m11,5050) 85, parp(85), chparp(85)
62036 WRITE(m11,5050) 86, parp(86), chparp(86)
62037 WRITE(m11,5040) 91, mstp(91), chmstp(91)
62038 WRITE(m11,5050) 91, parp(91), chparp(91)
62039 WRITE(m11,5050) 93, parp(93), chparp(93)
62040 WRITE(m11,5040) 95, mstp(95), chmstp(95)
62041 WRITE(m11,5050) 78, parp(78), chparp(78)
62042 WRITE(m11,5070) 11, mstj(11), chmstj(11)
62043 WRITE(m11,5060) 21, parj(21), chparj(21)
62044 WRITE(m11,5060) 41, parj(41), chparj(41)
62045 WRITE(m11,5060) 42, parj(42), chparj(42)
62046 IF (mstj(11).LE.3) THEN
62047 WRITE(m11,5060) 54, parj(54), chparj(54)
62048 WRITE(m11,5060) 55, parj(55), chparj(55)
62049 ELSE
62050 WRITE(m11,5060) 46, parj(46), chparj(46)
62051 ENDIF
62052 IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
62053 ENDIF
62054
62055C=======================================================================
62056C...Intermediate model. Rap tune
62057C...(retuned to post-6.406 IR factorization)
62058 ELSEIF(itune.EQ.200) THEN
62059 IF (m13.GE.1) THEN
62060 WRITE(m11,5010) itune, chname
62061 ch60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62062 WRITE(m11,5030) ch60
62063 ENDIF
62064 IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.405))THEN
62065 CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62066 & ' with tune.')
62067 ENDIF
62068C...PDF
62069 mstp(51)=7
62070 mstp(52)=1
62071C...ISR
62072 parp(62)=1d0
62073 parp(64)=1d0
62074 parp(67)=4d0
62075C...FSR
62076 parp(71)=4d0
62077 parj(81)=0.29d0
62078C...UE
62079 mstp(81)=11
62080 parp(82)=2.25d0
62081 parp(89)=1800d0
62082 parp(90)=0.25d0
62083C... ExpOfPow(1.8) overlap profile
62084 mstp(82)=5
62085 parp(83)=1.8d0
62086C... Valence qq
62087 mstp(88)=0
62088C... Rap Tune
62089 mstp(89)=1
62090C... Default diquark, BR-g-BR supp
62091 parp(79)=2d0
62092 parp(80)=0.01d0
62093C... Final state reconnect.
62094 mstp(95)=1
62095 parp(78)=0.55d0
62096C...Fragmentation functions and c and b parameters
62097 mstj(11)=4
62098 parj(54)=-0.05
62099 parj(55)=-0.005
62100C... Output
62101 IF (m13.GE.1) THEN
62102 WRITE(m11,5030) ' '
62103 WRITE(m11,5040) 51, mstp(51), chmstp(51)
62104 WRITE(m11,5040) 52, mstp(52), chmstp(52)
62105 WRITE(m11,5050) 62, parp(62), chparp(62)
62106 WRITE(m11,5050) 64, parp(64), chparp(64)
62107 WRITE(m11,5050) 67, parp(67), chparp(67)
62108 WRITE(m11,5040) 68, mstp(68), chmstp(68)
62109 ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62110 WRITE(m11,5030) ch60
62111 WRITE(m11,5050) 71, parp(71), chparp(71)
62112 WRITE(m11,5060) 81, parj(81), chparj(81)
62113 WRITE(m11,5040) 81, mstp(81), chmstp(81)
62114 WRITE(m11,5050) 82, parp(82), chparp(82)
62115 WRITE(m11,5050) 89, parp(89), chparp(89)
62116 WRITE(m11,5050) 90, parp(90), chparp(90)
62117 WRITE(m11,5040) 82, mstp(82), chmstp(82)
62118 WRITE(m11,5050) 83, parp(83), chparp(83)
62119 WRITE(m11,5040) 88, mstp(88), chmstp(88)
62120 WRITE(m11,5040) 89, mstp(89), chmstp(89)
62121 WRITE(m11,5050) 79, parp(79), chparp(79)
62122 WRITE(m11,5050) 80, parp(80), chparp(80)
62123 WRITE(m11,5050) 93, parp(93), chparp(93)
62124 WRITE(m11,5040) 95, mstp(95), chmstp(95)
62125 WRITE(m11,5050) 78, parp(78), chparp(78)
62126 WRITE(m11,5070) 11, mstj(11), chmstj(11)
62127 WRITE(m11,5060) 21, parj(21), chparj(21)
62128 WRITE(m11,5060) 41, parj(41), chparj(41)
62129 WRITE(m11,5060) 42, parj(42), chparj(42)
62130 IF (mstj(11).LE.3) THEN
62131 WRITE(m11,5060) 54, parj(54), chparj(54)
62132 WRITE(m11,5060) 55, parj(55), chparj(55)
62133 ELSE
62134 WRITE(m11,5060) 46, parj(46), chparj(46)
62135 ENDIF
62136 IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
62137 ENDIF
62138
62139C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62140C...Old model for ISR and UE, new pT-ordered model for FSR
62141 ELSEIF(itune.EQ.201.OR.itune.EQ.211.OR.itune.EQ.221.or
62142 & .itune.EQ.226) THEN
62143 IF (m13.GE.1) THEN
62144 WRITE(m11,5010) itune, chname
62145 ch60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62146 WRITE(m11,5030) ch60
62147 ch60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62148 WRITE(m11,5030) ch60
62149 ch60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62150 WRITE(m11,5030) ch60
62151 ch60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62152 WRITE(m11,5030) ch60
62153 IF (itune.EQ.211.OR.itune.GE.221) THEN
62154 ch60='LEP parameters tuned by Professor'
62155 WRITE(m11,5030) ch60
62156 ENDIF
62157 ENDIF
62158 IF (mstp(181).LE.5.OR.(mstp(181).EQ.6.AND.mstp(182).LE.411))THEN
62159 CALL pyerrm(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62160 & ' with tune.')
62161 ENDIF
62162C...First set as if Pythia tune A
62163C...Multiple interactions on, old framework
62164 mstp(81)=1
62165C...Fast IR cutoff energy scaling by default
62166 parp(89)=1800d0
62167 parp(90)=0.25d0
62168C...Default CTEQ5L (internal)
62169 mstp(51)=7
62170 mstp(52)=1
62171C...Double Gaussian matter distribution.
62172 mstp(82)=4
62173 parp(83)=0.5d0
62174 parp(84)=0.4d0
62175C...FSR activity.
62176 parp(71)=4d0
62177c...String drawing almost completely minimizes string length.
62178 parp(85)=0.9d0
62179 parp(86)=0.95d0
62180C...ISR cutoff, muR scale factor, and phase space size
62181 parp(62)=1d0
62182 parp(64)=1d0
62183 parp(67)=4d0
62184C...Intrinsic kT, size, and max
62185 mstp(91)=1
62186 parp(91)=1d0
62187 parp(93)=5d0
62188C...Use 2 GeV of primordial kT for "Perugia" version
62189 IF (itune.EQ.221) THEN
62190 parp(91)=2d0
62191 parp(93)=10d0
62192 ENDIF
62193C...Use pT-ordered FSR
62194 mstj(41)=12
62195C...Lambda_FSR scale for pT-ordering
62196 parj(81)=0.23d0
62197C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62198 parp(82)=2.05d0
62199C...Fragmentation functions and c and b parameters
62200C...(overwritten for 211, i.e., if using Professor pars)
62201 mstj(11)=4
62202 parj(54)=-0.05
62203 parj(55)=-0.005
62204
62205C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62206 IF (itune.EQ.211.OR.itune.GE.221) THEN
62207C...# Tuned flavour parameters:
62208 parj(1) = 0.073
62209 parj(2) = 0.2
62210 parj(3) = 0.94
62211 parj(4) = 0.032
62212 parj(11) = 0.31
62213 parj(12) = 0.4
62214 parj(13) = 0.54
62215 parj(25) = 0.63
62216 parj(26) = 0.12
62217C...# Always use pT-ordered shower:
62218 mstj(41) = 12
62219C...# Switch on Bowler:
62220 mstj(11) = 5
62221C...# Fragmentation
62222 parj(21) = 3.1327e-01
62223 parj(41) = 4.8989e-01
62224 parj(42) = 1.2018e+00
62225 parj(47) = 1.0000e+00
62226 parj(81) = 2.5696e-01
62227 parj(82) = 8.0000e-01
62228 ENDIF
62229
62230C...221, 226 : Perugia-APT and Perugia-APT6
62231 IF (itune.EQ.221.OR.itune.EQ.226) THEN
62232
62233 parp(64)=0.5d0
62234 parp(82)=2.05d0
62235 parp(90)=0.26d0
62236 parp(91)=2.0d0
62237C...The Perugia variants use Steve's showers off the old MPI
62238 mstp(152)=1
62239C...And use a lower PARP(71) as suggested by Professor tunings
62240C...(although not certain that applies to Q2-pT2 hybrid)
62241 parp(71)=2.5d0
62242
62243C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62244 IF (itune.EQ.226) THEN
62245 ch70='NB! This tune requires CTEQ6L1 pdfs to be '//
62246 & 'externally linked'
62247 WRITE(m11,5035) ch70
62248 mstp(52)=2
62249 mstp(51)=10042
62250 parp(82)=1.95d0
62251 ENDIF
62252
62253 ENDIF
62254
62255C... Output
62256 IF (m13.GE.1) THEN
62257 WRITE(m11,5030) ' '
62258 WRITE(m11,5040) 51, mstp(51), chmstp(51)
62259 WRITE(m11,5040) 52, mstp(52), chmstp(52)
62260 WRITE(m11,5050) 62, parp(62), chparp(62)
62261 WRITE(m11,5050) 64, parp(64), chparp(64)
62262 WRITE(m11,5050) 67, parp(67), chparp(67)
62263 WRITE(m11,5040) 68, mstp(68), chmstp(68)
62264 ch60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62265 WRITE(m11,5030) ch60
62266 WRITE(m11,5070) 41, mstj(41), chmstj(41)
62267 WRITE(m11,5050) 71, parp(71), chparp(71)
62268 WRITE(m11,5060) 81, parj(81), chparj(81)
62269 WRITE(m11,5040) 81, mstp(81), chmstp(81)
62270 WRITE(m11,5050) 82, parp(82), chparp(82)
62271 WRITE(m11,5050) 89, parp(89), chparp(89)
62272 WRITE(m11,5050) 90, parp(90), chparp(90)
62273 WRITE(m11,5040) 82, mstp(82), chmstp(82)
62274 WRITE(m11,5050) 83, parp(83), chparp(83)
62275 WRITE(m11,5050) 84, parp(84), chparp(84)
62276 WRITE(m11,5050) 85, parp(85), chparp(85)
62277 WRITE(m11,5050) 86, parp(86), chparp(86)
62278 WRITE(m11,5040) 91, mstp(91), chmstp(91)
62279 WRITE(m11,5050) 91, parp(91), chparp(91)
62280 WRITE(m11,5050) 93, parp(93), chparp(93)
62281 WRITE(m11,5070) 11, mstj(11), chmstj(11)
62282 WRITE(m11,5060) 21, parj(21), chparj(21)
62283 WRITE(m11,5060) 41, parj(41), chparj(41)
62284 WRITE(m11,5060) 42, parj(42), chparj(42)
62285 IF (mstj(11).LE.3) THEN
62286 WRITE(m11,5060) 54, parj(54), chparj(54)
62287 WRITE(m11,5060) 55, parj(55), chparj(55)
62288 ELSE
62289 WRITE(m11,5060) 46, parj(46), chparj(46)
62290 ENDIF
62291 IF (mstj(11).EQ.5) WRITE(m11,5060) 47, parj(47), chparj(47)
62292 ENDIF
62293
62294C======================================================================
62295C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62296 ELSEIF(chname.EQ.'GAL Tune 0'.OR.chname.EQ.'GAL Tune 1') THEN
62297 IF (m13.GE.1) THEN
62298 WRITE(m11,5010) itune, chname
62299 ch60='see J. Rathsman, PLB452(1999)364'
62300 WRITE(m11,5030) ch60
62301C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62302C ? WRITE(M11,5030)
62303 ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62304 WRITE(m11,5030) ch60
62305 WRITE(m11,5030) ' '
62306 ch70='NB! The GAL model must be run with modified '//
62307 & 'Pythia v6.215:'
62308 WRITE(m11,5035) ch70
62309 ch70='available from http://www.isv.uu.se/thep/MC/scigal/'
62310 WRITE(m11,5035) ch70
62311 WRITE(m11,5030) ' '
62312 ENDIF
62313C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62314 mswi(2) = 3
62315 parsci(2) = 0.10
62316 mswi(1) = 2
62317 parsci(1) = 0.44
62318 mstj(16) = 0
62319 parj(42) = 0.45
62320 parj(82) = 2.0
62321 parp(62) = 2.0
62322 mstp(81) = 1
62323 mstp(82) = 1
62324 parp(81) = 1.9
62325 mstp(92) = 1
62326 IF(chname.EQ.'GAL Tune 1') THEN
62327C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62328 mstp(82)=4
62329 parp(83)=0.25d0
62330 parp(84)=0.5d0
62331 parp(82) = 1.75
62332 IF (m13.GE.1) THEN
62333 WRITE(m11,5040) 81, mstp(81), chmstp(81)
62334 WRITE(m11,5050) 82, parp(82), chparp(82)
62335 WRITE(m11,5040) 82, mstp(82), chmstp(82)
62336 WRITE(m11,5050) 83, parp(83), chparp(83)
62337 WRITE(m11,5050) 84, parp(84), chparp(84)
62338 ENDIF
62339 ELSE
62340 IF (m13.GE.1) THEN
62341 WRITE(m11,5040) 81, mstp(81), chmstp(81)
62342 WRITE(m11,5050) 81, parp(81), chparp(81)
62343 WRITE(m11,5040) 82, mstp(82), chmstp(82)
62344 ENDIF
62345 ENDIF
62346C...Output
62347 IF (m13.GE.1) THEN
62348 WRITE(m11,5050) 62, parp(62), chparp(62)
62349 WRITE(m11,5060) 82, parj(82), chparj(82)
62350 WRITE(m11,5040) 92, mstp(92), chmstp(92)
62351 ch40='FSI SCI/GAL selection'
62352 WRITE(m11,6040) 1, mswi(1), ch40
62353 ch40='FSI SCI/GAL sea quark treatment'
62354 WRITE(m11,6040) 2, mswi(2), ch40
62355 ch40='FSI SCI/GAL sea quark treatment parm'
62356 WRITE(m11,6050) 1, parsci(1), ch40
62357 ch40='FSI SCI/GAL string reco probability R_0'
62358 WRITE(m11,6050) 2, parsci(2), ch40
62359 WRITE(m11,5060) 42, parj(42), chparj(42)
62360 WRITE(m11,5070) 16, mstj(16), chmstj(16)
62361 ENDIF
62362 ELSEIF(chname.EQ.'SCI Tune 0'.OR.chname.EQ.'SCI Tune 1') THEN
62363 IF (m13.GE.1) THEN
62364 WRITE(m11,5010) itune, chname
62365 ch60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62366 WRITE(m11,5030) ch60
62367 ch60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62368 WRITE(m11,5030) ch60
62369 WRITE(m11,5030) ' '
62370 ch70='NB! The SCI model must be run with modified '//
62371 & 'Pythia v6.215:'
62372 WRITE(m11,5035) ch70
62373 ch70='available from http://www.isv.uu.se/thep/MC/scigal/'
62374 WRITE(m11,5035) ch70
62375 WRITE(m11,5030) ' '
62376 ENDIF
62377C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62378 mstp(81)=1
62379 mstp(82)=1
62380 parp(81)=2.2
62381 mstp(92)=1
62382 mswi(2)=2
62383 parsci(2)=0.50
62384 mswi(1)=2
62385 parsci(1)=0.44
62386 mstj(16)=0
62387 IF (chname.EQ.'SCI Tune 1') THEN
62388C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62389 mstp(81) = 1
62390 mstp(82) = 3
62391 parp(82) = 2.4
62392 parp(83) = 0.5d0
62393 parp(62) = 1.5
62394 parp(84)=0.25d0
62395 IF (m13.GE.1) THEN
62396 WRITE(m11,5040) 81, mstp(81), chmstp(81)
62397 WRITE(m11,5050) 82, parp(82), chparp(82)
62398 WRITE(m11,5040) 82, mstp(82), chmstp(82)
62399 WRITE(m11,5050) 83, parp(83), chparp(83)
62400 WRITE(m11,5050) 62, parp(62), chparp(62)
62401 ENDIF
62402 ELSE
62403 IF (m13.GE.1) THEN
62404 WRITE(m11,5040) 81, mstp(81), chmstp(81)
62405 WRITE(m11,5050) 81, parp(81), chparp(81)
62406 WRITE(m11,5040) 82, mstp(82), chmstp(82)
62407 ENDIF
62408 ENDIF
62409C...Output
62410 IF (m13.GE.1) THEN
62411 WRITE(m11,5040) 92, mstp(92), chmstp(92)
62412 ch40='FSI SCI/GAL selection'
62413 WRITE(m11,6040) 1, mswi(1), ch40
62414 ch40='FSI SCI/GAL sea quark treatment'
62415 WRITE(m11,6040) 2, mswi(2), ch40
62416 ch40='FSI SCI/GAL sea quark treatment parm'
62417 WRITE(m11,6050) 1, parsci(1), ch40
62418 ch40='FSI SCI/GAL string reco probability R_0'
62419 WRITE(m11,6050) 2, parsci(2), ch40
62420 WRITE(m11,5070) 16, mstj(16), chmstj(16)
62421 ENDIF
62422
62423 ELSE
62424 IF (mstu(13).GE.1) WRITE(m11,5020) itune
62425
62426 ENDIF
62427
62428 100 IF (mstu(13).GE.1) WRITE(m11,6000)
62429
62430 9999 RETURN
62431
62432 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',a6,' : ',
62433 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62434 & 20x,'Last Change : ',a8,' - P. Skands',22x,'*'/' *',76x,'*')
62435 5010 FORMAT(' *',3x,i4,1x,a16,52x,'*')
62436 5020 FORMAT(' *',3x,'Tune ',i4, ' not recognized. Using defaults.')
62437 5030 FORMAT(' *',3x,10x,a60,3x,'*')
62438 5035 FORMAT(' *',3x,a70,3x,'*')
62439 5040 FORMAT(' *',5x,'MSTP(',i2,') = ',i12,3x,a42,3x,'*')
62440 5050 FORMAT(' *',5x,'PARP(',i2,') = ',f12.4,3x,a40,5x,'*')
62441 5060 FORMAT(' *',5x,'PARJ(',i2,') = ',f12.4,3x,a40,5x,'*')
62442 5070 FORMAT(' *',5x,'MSTJ(',i2,') = ',i12,3x,a40,5x,'*')
62443 5140 FORMAT(' *',5x,'MSTP(',i3,')= ',i12,3x,a40,5x,'*')
62444 5150 FORMAT(' *',5x,'PARP(',i3,')= ',f12.4,3x,a40,5x,'*')
62445 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62446 6040 FORMAT(' *',5x,'MSWI(',i1,') = ',i12,3x,a40,5x,'*')
62447 6050 FORMAT(' *',5x,'PARSCI(',i1,')= ',f12.4,3x,a40,5x,'*')
62448
62449 END
62450
62451C*********************************************************************
62452
62453C...PYEXEC
62454C...Administrates the fragmentation and decay chain.
62455
62456 SUBROUTINE pyexec
62457
62458C...Double precision and integer declarations.
62459 IMPLICIT DOUBLE PRECISION(a-h, o-z)
62460 IMPLICIT INTEGER(I-N)
62461 INTEGER PYK,PYCHGE,PYCOMP
62462C...Commonblocks.
62463 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
62464 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
62465 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
62466 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
62467 common/pyint1/mint(400),vint(400)
62468 common/pyint4/mwid(500),wids(500,5)
62469 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint1/,/pyint4/
62470C...Local array.
62471 dimension ps(2,6),ijoin(100)
62472
62473C...Initialize and reset.
62474 mstu(24)=0
62475 IF(mstu(12).NE.12345) CALL pylist(0)
62476 mstu(29)=0
62477 mstu(31)=mstu(31)+1
62478 mstu(1)=0
62479 mstu(2)=0
62480 mstu(3)=0
62481 IF(mstu(17).LE.0) mstu(90)=0
62482 mcons=1
62483
62484C...Sum up momentum, energy and charge for starting entries.
62485 nsav=n
62486 DO 110 i=1,2
62487 DO 100 j=1,6
62488 ps(i,j)=0d0
62489 100 CONTINUE
62490 110 CONTINUE
62491 DO 130 i=1,n
62492 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 130
62493 DO 120 j=1,4
62494 ps(1,j)=ps(1,j)+p(i,j)
62495 120 CONTINUE
62496 ps(1,6)=ps(1,6)+pychge(k(i,2))
62497 130 CONTINUE
62498 paru(21)=ps(1,4)
62499
62500C...Start by all decays of coloured resonances involved in shower.
62501 norig=n
62502 DO 140 i=1,norig
62503 IF(k(i,1).EQ.3) THEN
62504 kc=pycomp(k(i,2))
62505 IF(mwid(kc).NE.0.AND.kchg(kc,2).NE.0) CALL pyresd(i)
62506 ENDIF
62507 140 CONTINUE
62508
62509C...Prepare system for subsequent fragmentation/decay.
62510 CALL pyprep(0)
62511 IF(mint(51).NE.0) RETURN
62512
62513C...Loop through jet fragmentation and particle decays.
62514 mbe=0
62515 150 mbe=mbe+1
62516 ip=0
62517 160 ip=ip+1
62518 kc=0
62519 IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=pycomp(k(ip,2))
62520 IF(kc.EQ.0) THEN
62521
62522C...Deal with any remaining undecayed resonance
62523C...(normally the task of PYEVNT, so seldom used).
62524 ELSEIF(mwid(kc).NE.0) THEN
62525 ibeg=ip
62526 IF(kchg(kc,2).NE.0.AND.k(i,1).NE.3) THEN
62527 ibeg=ip+1
62528 170 ibeg=ibeg-1
62529 IF(ibeg.GE.2.AND.k(ibeg,1).EQ.2) GOTO 170
62530 IF(k(ibeg,1).NE.2) ibeg=ibeg+1
62531 iend=ip-1
62532 180 iend=iend+1
62533 IF(iend.LT.n.AND.k(iend,1).EQ.2) GOTO 180
62534 IF(iend.LT.n.AND.kchg(pycomp(k(iend,2)),2).EQ.0) GOTO 180
62535 njoin=0
62536 DO 190 i=ibeg,iend
62537 IF(kchg(pycomp(k(iend,2)),2).NE.0) THEN
62538 njoin=njoin+1
62539 ijoin(njoin)=i
62540 ENDIF
62541 190 CONTINUE
62542 ENDIF
62543 CALL pyresd(ip)
62544 CALL pyprep(ibeg)
62545 IF(mint(51).NE.0) RETURN
62546
62547C...Particle decay if unstable and allowed. Save long-lived particle
62548C...decays until second pass after Bose-Einstein effects.
62549 ELSEIF(kchg(kc,2).EQ.0) THEN
62550 IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe
62551 & .EQ.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))
62552 & CALL pydecy(ip)
62553
62554C...Decay products may develop a shower.
62555 IF(mstj(92).GT.0) THEN
62556 ip1=mstj(92)
62557 qmax=sqrt(max(0d0,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,
62558 & 1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))
62559 mint(33)=0
62560 CALL pyshow(ip1,ip1+1,qmax)
62561 CALL pyprep(ip1)
62562 IF(mint(51).NE.0) RETURN
62563 mstj(92)=0
62564 ELSEIF(mstj(92).LT.0) THEN
62565 ip1=-mstj(92)
62566 mint(33)=0
62567 CALL pyshow(ip1,-3,p(ip,5))
62568 CALL pyprep(ip1)
62569 IF(mint(51).NE.0) RETURN
62570 mstj(92)=0
62571 ENDIF
62572
62573C...Jet fragmentation: string or independent fragmentation.
62574 ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN
62575 mfrag=mstj(1)
62576 IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2
62577 IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN
62578 IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.
62579 & k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN
62580 IF(kchg(pycomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)
62581 ENDIF
62582 ENDIF
62583 IF(mfrag.EQ.1) CALL pystrf(ip)
62584 IF(mfrag.EQ.2) CALL pyindf(ip)
62585 IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0
62586 IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0
62587 ENDIF
62588
62589C...Loop back if enough space left in PYJETS and no error abort.
62590 IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN
62591 ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN
62592 GOTO 160
62593 ELSEIF(ip.LT.n) THEN
62594 CALL pyerrm(11,'(PYEXEC:) no more memory left in PYJETS')
62595 ENDIF
62596
62597C...Include simple Bose-Einstein effect parametrization if desired.
62598 IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN
62599 CALL pyboei(nsav)
62600 GOTO 150
62601 ENDIF
62602
62603C...Check that momentum, energy and charge were conserved.
62604 DO 210 i=1,n
62605 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 210
62606 DO 200 j=1,4
62607 ps(2,j)=ps(2,j)+p(i,j)
62608 200 CONTINUE
62609 ps(2,6)=ps(2,6)+pychge(k(i,2))
62610 210 CONTINUE
62611 pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-
62612 &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1d0+abs(ps(2,4))+abs(ps(1,4)))
62613 IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL pyerrm(15,
62614 &'(PYEXEC:) four-momentum was not conserved')
62615 IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1d0) CALL pyerrm(15,
62616 &'(PYEXEC:) charge was not conserved')
62617
62618 RETURN
62619 END
62620
62621C*********************************************************************
62622
62623C...PYPREP
62624C...Rearranges partons along strings.
62625C...Special considerations for systems with junctions, with
62626C...possibility of junction-antijunction annihilation.
62627C...Allows small systems to collapse into one or two particles.
62628C...Checks flavours and colour singlet invariant masses.
62629
62630 SUBROUTINE pyprep(IP)
62631
62632C...Double precision and integer declarations.
62633 IMPLICIT DOUBLE PRECISION(a-h, o-z)
62634 INTEGER PYK,PYCHGE,PYCOMP
62635C...Commonblocks.
62636 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62637 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
62638 common/pypars/mstp(200),parp(200),msti(200),pari(200)
62639 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
62640 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
62641 common/pyint1/mint(400),vint(400)
62642C...The common block of colour tags.
62643 common/pyctag/nct,mct(4000,2)
62644 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint1/,/pyctag/,
62645 &/pypars/
62646 DATA nerrpr/0/
62647 SAVE nerrpr
62648C...Local arrays.
62649 dimension dps(5),dpc(5),ue(3),pg(5),e1(3),e2(3),e3(3),e4(3),
62650 &ecl(3),ijunc(10,0:4),ipiece(30,0:4),kfend(4),kfq(4),
62651 &ijur(4),pju(4,6),irng(4,2),tjj(2,5),t(5),pul(3,5),
62652 &ijcp(0:6),tjuold(5)
62653 CHARACTER CHTMP*6
62654
62655C...Function to give four-product.
62656 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)
62657
62658C...Rearrange parton shower product listing along strings: begin loop.
62659 mstu(24)=0
62660 nold=n
62661 i1=n
62662 njunc=0
62663 npiece=0
62664 njjstr=0
62665 mstu32=mstu(32)+1
62666 DO 100 i=max(1,ip),n
62667C...First store junction positions.
62668 IF(k(i,1).EQ.42) THEN
62669 njunc=njunc+1
62670 ijunc(njunc,0)=i
62671 ijunc(njunc,4)=0
62672 ENDIF
62673 100 CONTINUE
62674
62675 DO 250 mqgst=1,3
62676 DO 240 i=max(1,ip),n
62677C...Special treatment for junctions
62678 IF (k(i,1).LE.0) GOTO 240
62679 IF(k(i,1).EQ.42) THEN
62680C...MQGST=2: Look for junction-junction strings (not detected in the
62681C...main search below).
62682 IF (mqgst.EQ.2.AND.npiece.NE.3*njunc) THEN
62683 IF (njjstr.EQ.0) THEN
62684 njjstr = (3*njunc-npiece)/2
62685 ENDIF
62686C...Check how many already identified strings end on this junction
62687 ilc=0
62688 DO 110 j=1,npiece
62689 IF (ipiece(j,4).EQ.i) ilc=ilc+1
62690 110 CONTINUE
62691C...If less than 3, remaining must be to another junction
62692 IF (ilc.LT.3) THEN
62693 IF (ilc.NE.2) THEN
62694C...Multiple j-j connections not handled yet.
62695 CALL pyerrm(2,
62696 & '(PYPREP:) Too many junction-junction strings.')
62697 mint(51)=1
62698 RETURN
62699 ENDIF
62700C...The colour information in the junction is unreadable for the
62701C...colour space search further down in this routine, so we must
62702C...start on the colour mother of this junction and then "artificially"
62703C...prevent the colour mother from connecting here again.
62704 itjunc=mod(k(i,4)/mstu(5),mstu(5))
62705 kcs=4
62706 IF (mod(itjunc,2).EQ.0) kcs=5
62707C...Switch colour if the junction-junction leg is presumably a
62708C...junction mother leg rather than a junction daughter leg.
62709 IF (itjunc.GE.3) kcs=9-kcs
62710 IF (mint(33).EQ.0) THEN
62711C...Find the unconnected leg and reorder junction daughter pointers so
62712C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62713C...piece.
62714 ia=mod(k(i,4),mstu(5))
62715 IF (k(ia,kcs)/mstu(5)**2.GE.2) THEN
62716 itmp=mod(k(i,5),mstu(5))
62717 IF (k(itmp,kcs)/mstu(5)**2.GE.2) THEN
62718 itmp=mod(k(i,5)/mstu(5),mstu(5))
62719 k(i,5)=k(i,5)+(ia-itmp)*mstu(5)
62720 ELSE
62721 k(i,5)=k(i,5)+(ia-itmp)
62722 ENDIF
62723 k(i,4)=k(i,4)+(itmp-ia)
62724 ia=itmp
62725 ENDIF
62726 IF (itjunc.LE.2) THEN
62727C...Beam baryon junction
62728 k(ia,kcs) = k(ia,kcs) + 2*mstu(5)**2
62729 k(i,kcs) = k(i,kcs) + 1*mstu(5)**2
62730C...Else 1 -> 2 decay junction
62731 ELSE
62732 k(ia,kcs) = k(ia,kcs) + mstu(5)**2
62733 k(i,kcs) = k(i,kcs) + 2*mstu(5)**2
62734 ENDIF
62735 i1beg = i1
62736 nstp = 0
62737 GOTO 170
62738C...Alternatively use colour tag information.
62739 ELSE
62740C...Find a final state parton with appropriate dangling colour tag.
62741 jct=0
62742 ia=0
62743 ijumo=k(i,3)
62744 DO 140 j1=max(1,ip),n
62745 IF (k(j1,1).NE.3) GOTO 140
62746C...Check for matching final-state colour tag
62747 imatch=0
62748 DO 120 j2=max(1,ip),n
62749 IF (k(j2,1).NE.3) GOTO 120
62750 IF (mct(j1,kcs-3).EQ.mct(j2,6-kcs)) imatch=1
62751 120 CONTINUE
62752 IF (imatch.EQ.1) GOTO 140
62753C...Check whether this colour tag belongs to the present junction
62754C...by seeing whether any parton with this colour tag has the same
62755C...mother as the junction.
62756 jct=mct(j1,kcs-3)
62757 imatch=0
62758 DO 130 j2=mint(84)+1,n
62759 imo2=k(j2,3)
62760C...First scattering partons have IMO1 = 3 and 4.
62761 IF (imo2.EQ.mint(83)+3.OR.imo2.EQ.mint(83)+4)
62762 & imo2=imo2-2
62763 IF (mct(j2,kcs-3).EQ.jct.AND.imo2.EQ.ijumo)
62764 & imatch=1
62765 130 CONTINUE
62766 IF (imatch.EQ.0) GOTO 140
62767 ia=j1
62768 140 CONTINUE
62769C...Check for junction-junction strings without intermediate final state
62770C...glue (not detected above).
62771 IF (ia.EQ.0) THEN
62772 DO 160 mju=1,njunc
62773 iju2=ijunc(mju,0)
62774 IF (iju2.EQ.i) GOTO 160
62775 itju2=mod(k(iju2,4)/mstu(5),mstu(5))
62776C...Only opposite types of junctions can connect to each other.
62777 IF (mod(itju2,2).EQ.mod(itjunc,2)) GOTO 160
62778 is=0
62779 DO 150 j=1,npiece
62780 IF (ipiece(j,4).EQ.iju2) is=is+1
62781 150 CONTINUE
62782 IF (is.EQ.3) GOTO 160
62783 ib=i
62784 ia=iju2
62785 160 CONTINUE
62786 ENDIF
62787C...Switch to other side of adjacent parton and step from there.
62788 kcs=9-kcs
62789 i1beg = i1
62790 nstp = 0
62791 GOTO 170
62792 ENDIF
62793 ELSE IF (ilc.NE.3) THEN
62794 ENDIF
62795 ENDIF
62796 ENDIF
62797
62798C...Look for coloured string endpoint, or (later) leftover gluon.
62799 IF(k(i,1).NE.3) GOTO 240
62800 kc=pycomp(k(i,2))
62801 IF(kc.EQ.0) GOTO 240
62802 kq=kchg(kc,2)
62803 IF(kq.EQ.0.OR.(mqgst.LE.2.AND.kq.EQ.2)) GOTO 240
62804
62805C...Pick up loose string end.
62806 kcs=4
62807 IF(kq*isign(1,k(i,2)).LT.0) kcs=5
62808 ia=i
62809 ib=i
62810 i1beg=i1
62811 nstp=0
62812 170 nstp=nstp+1
62813 IF(nstp.GT.4*n) THEN
62814 CALL pyerrm(14,'(PYPREP:) caught in infinite loop')
62815 mint(51)=1
62816 RETURN
62817 ENDIF
62818
62819C...Copy undecayed parton. Finished if reached string endpoint.
62820 IF(k(ia,1).EQ.3) THEN
62821 IF(i1.GE.mstu(4)-mstu32-5) THEN
62822 CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')
62823 mint(51)=1
62824 mstu(24)=1
62825 RETURN
62826 ENDIF
62827 i1=i1+1
62828 k(i1,1)=2
62829 IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) k(i1,1)=1
62830 k(i1,2)=k(ia,2)
62831 k(i1,3)=ia
62832 k(i1,4)=0
62833 k(i1,5)=0
62834 DO 180 j=1,5
62835 p(i1,j)=p(ia,j)
62836 v(i1,j)=v(ia,j)
62837 180 CONTINUE
62838 k(ia,1)=k(ia,1)+10
62839 IF(k(i1,1).EQ.1) GOTO 240
62840 ENDIF
62841
62842C...Also finished (for now) if reached junction; then copy to end.
62843 IF(k(ia,1).EQ.42) THEN
62844 ncopy=i1-i1beg
62845 IF(i1.GE.mstu(4)-mstu32-ncopy-5) THEN
62846 CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')
62847 mint(51)=1
62848 mstu(24)=1
62849 RETURN
62850 ENDIF
62851 IF (mqgst.LE.2.AND.ncopy.NE.0) THEN
62852 DO 200 icopy=1,ncopy
62853 DO 190 j=1,5
62854 k(mstu(4)-mstu32-icopy,j)=k(i1beg+icopy,j)
62855 p(mstu(4)-mstu32-icopy,j)=p(i1beg+icopy,j)
62856 v(mstu(4)-mstu32-icopy,j)=v(i1beg+icopy,j)
62857 190 CONTINUE
62858 200 CONTINUE
62859 ENDIF
62860C...For junction-junction strings, find end leg and reorder junction
62861C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
62862C...junction-junction string piece.
62863 IF (k(i,1).EQ.42.AND.mint(33).EQ.0) THEN
62864 itmp=mod(k(ia,4),mstu(5))
62865 IF (itmp.NE.ib) THEN
62866 IF (mod(k(ia,5),mstu(5)).EQ.ib) THEN
62867 k(ia,5)=k(ia,5)+(itmp-ib)
62868 ELSE
62869 k(ia,5)=k(ia,5)+(itmp-ib)*mstu(5)
62870 ENDIF
62871 k(ia,4)=k(ia,4)+(ib-itmp)
62872 ENDIF
62873 ENDIF
62874 npiece=npiece+1
62875C...IPIECE:
62876C...0: endpoint in original ER
62877C...1:
62878C...2:
62879C...3: Parton immediately next to junction
62880C...4: Junction
62881 ipiece(npiece,0)=i
62882 ipiece(npiece,1)=mstu32+1
62883 ipiece(npiece,2)=mstu32+ncopy
62884 ipiece(npiece,3)=ib
62885 ipiece(npiece,4)=ia
62886 mstu32=mstu32+ncopy
62887 i1=i1beg
62888 GOTO 240
62889 ENDIF
62890
62891C...GOTO next parton in colour space.
62892 ib=ia
62893 IF (mint(33).EQ.0) THEN
62894 IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5
62895 & )).NE.0) THEN
62896 ia=mod(k(ib,kcs),mstu(5))
62897 k(ib,kcs)=k(ib,kcs)+mstu(5)**2
62898 mrev=0
62899 ELSE
62900 IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),
62901 & mstu(5)).EQ.0) kcs=9-kcs
62902 ia=mod(k(ib,kcs)/mstu(5),mstu(5))
62903 k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2
62904 mrev=1
62905 ENDIF
62906 IF(ia.LE.0.OR.ia.GT.n) THEN
62907 CALL pyerrm(12,'(PYPREP:) colour rearrangement failed')
62908 IF(nerrpr.LT.5) THEN
62909 nerrpr=nerrpr+1
62910 WRITE(mstu(11),*) 'started at:', i
62911 WRITE(mstu(11),*) 'ended going from',ib,' to',ia
62912 WRITE(mstu(11),*) 'MQGST =',mqgst
62913 CALL pylist(4)
62914 ENDIF
62915 mint(51)=1
62916 RETURN
62917 ENDIF
62918 IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5)
62919 & ,mstu(5)).EQ.ib) THEN
62920 IF(mrev.EQ.1) kcs=9-kcs
62921 IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs
62922 k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2
62923 ELSE
62924 IF(mrev.EQ.0) kcs=9-kcs
62925 IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs
62926 k(ia,kcs)=k(ia,kcs)+mstu(5)**2
62927 ENDIF
62928 IF(ia.NE.i) GOTO 170
62929C...Use colour tag information
62930 ELSE
62931C...First create colour tags starting on IB if none already present.
62932 IF (mct(ib,kcs-3).EQ.0) THEN
62933 CALL pycttr(ib,kcs,ib)
62934 IF(mint(51).NE.0) RETURN
62935 ENDIF
62936 jct=mct(ib,kcs-3)
62937 ifound=0
62938C...Find final state tag partner
62939 DO 210 it=max(1,ip),n
62940 IF (it.EQ.ib) GOTO 210
62941 IF (mct(it,6-kcs).EQ.jct.AND.k(it,1).LT.10.AND.k(it,1).gt
62942 & .0) THEN
62943 ifound=ifound+1
62944 ia=it
62945 ENDIF
62946 210 CONTINUE
62947C...Just copy and goto next if exactly one partner found.
62948 IF (ifound.EQ.1) THEN
62949 GOTO 170
62950C...When no match found, match is presumably junction.
62951 ELSEIF (ifound.EQ.0.AND.mqgst.LE.2) THEN
62952C...Check whether this colour tag matches a junction
62953C...by seeing whether any parton with this colour tag has the same
62954C...mother as a junction.
62955C...NB: Only type 1 and 2 junctions handled presently.
62956 DO 230 iju=1,njunc
62957 ijumo=k(ijunc(iju,0),3)
62958 itjunc=mod(k(ijunc(iju,0),4)/mstu(5),mstu(5))
62959C...Colours only connect to junctions, anti-colours to antijunctions:
62960 IF (mod(itjunc+1,2)+1.NE.kcs-3) GOTO 230
62961 imatch=0
62962 DO 220 j1=max(1,ip),n
62963 IF (k(j1,1).LE.0) GOTO 220
62964C...First scattering partons have IMO1 = 3 and 4.
62965 imo=k(j1,3)
62966 IF (imo.EQ.mint(83)+3.OR.imo.EQ.mint(83)+4)
62967 & imo=imo-2
62968 IF (mct(j1,kcs-3).EQ.jct.AND.imo.EQ.ijumo.AND.mod(k(j1
62969 & ,3+itjunc)/mstu(5),mstu(5)).EQ.ijunc(iju,0))
62970 & imatch=1
62971C...Attempt at handling type > 3 junctions also. Not tested.
62972 IF (itjunc.GE.3.AND.mct(j1,6-kcs).EQ.jct.AND.imo.eq
62973 & .ijumo) imatch=1
62974 220 CONTINUE
62975 IF (imatch.EQ.0) GOTO 230
62976 ia=ijunc(iju,0)
62977 ifound=ifound+1
62978 230 CONTINUE
62979
62980 IF (ifound.EQ.1) THEN
62981 GOTO 170
62982 ELSEIF (ifound.EQ.0) THEN
62983 WRITE(chtmp,*) jct
62984 CALL pyerrm(12,'(PYPREP:) no matching colour tag: '
62985 & //chtmp)
62986 IF(nerrpr.LT.5) THEN
62987 nerrpr=nerrpr+1
62988 CALL pylist(4)
62989 ENDIF
62990 mint(51)=1
62991 RETURN
62992 ENDIF
62993 ELSEIF (ifound.GE.2) THEN
62994 WRITE(chtmp,*) jct
62995 CALL pyerrm(12
62996 & ,'(PYPREP:) too many occurences of colour line: '//
62997 & chtmp)
62998 IF(nerrpr.LT.5) THEN
62999 nerrpr=nerrpr+1
63000 CALL pylist(4)
63001 ENDIF
63002 mint(51)=1
63003 RETURN
63004 ENDIF
63005 ENDIF
63006 k(i1,1)=1
63007 240 CONTINUE
63008 250 CONTINUE
63009
63010C...Junction systems remain.
63011 iju=0
63012 ijus=0
63013 ijucnt=0
63014 mrev=0
63015 ijjstr=0
63016 260 ijucnt=ijucnt+1
63017 IF (ijucnt.LE.njunc) THEN
63018C...If we are not processing a j-j string, treat this junction as new.
63019 IF (ijjstr.EQ.0) THEN
63020 iju=ijunc(ijucnt,0)
63021 mrev=0
63022C...If junction has already been read, ignore it.
63023 IF (ijunc(ijucnt,4).EQ.1) GOTO 260
63024C...If we are on a j-j string, goto second j-j junction.
63025 ELSE
63026 ijucnt=ijucnt-1
63027 iju=ijus
63028 ENDIF
63029C...Mark selected junction read.
63030 DO 270 j=1,njunc
63031 IF (ijunc(j,0).EQ.iju) ijunc(j,4)=1
63032 270 CONTINUE
63033C...Determine junction type
63034 itjunc = mod(k(iju,4)/mstu(5),mstu(5))
63035C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63036C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63037C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63038 IF (itjunc.GE.1.AND.itjunc.LE.6) THEN
63039 ihk=0
63040 280 ihk=ihk+1
63041C...Find which quarks belong to given junction.
63042 ihf=0
63043 DO 290 ipc=1,npiece
63044 IF (ipiece(ipc,4).EQ.iju) THEN
63045 ihf=ihf+1
63046 IF (ihf.EQ.ihk) iend=ipiece(ipc,3)
63047 ENDIF
63048 IF (ihk.EQ.3.AND.ipiece(ipc,0).EQ.iju) iend=ipiece(ipc,3)
63049 290 CONTINUE
63050C...IHK = 3 is special. Either normal string piece, or j-j string.
63051 IF(ihk.EQ.3) THEN
63052 IF (mrev.NE.1) THEN
63053 DO 300 ipc=1,npiece
63054C...If there is a j-j string starting on the present junction which has
63055C...zero length, insert next junction immediately.
63056 IF (ipiece(ipc,0).EQ.iju.AND.k(ipiece(ipc,4),1)
63057 & .EQ.42.AND.ipiece(ipc,1)-1-ipiece(ipc,2).EQ.0) THEN
63058 ijjstr = 1
63059 GOTO 340
63060 ENDIF
63061 300 CONTINUE
63062 mrev = 1
63063C...If MREV is 1 and IHK is 3 we are finished with this system.
63064 ELSE
63065 mrev=0
63066 GOTO 260
63067 ENDIF
63068 ENDIF
63069
63070C...If we've gotten this far, then either IHK < 3, or
63071C...an interjunction string exists, or just a third normal string.
63072 ijunc(ijucnt,ihk)=0
63073 ijjstr = 0
63074C..Order pieces belonging to this junction. Also look for j-j.
63075 DO 310 ipc=1,npiece
63076 IF (ipiece(ipc,3).EQ.iend) ijunc(ijucnt,ihk)=ipc
63077 IF (ihk.EQ.3.AND.ipiece(ipc,0).EQ.ijunc(ijucnt,0)
63078 & .AND.k(ipiece(ipc,4),1).EQ.42) THEN
63079 ijunc(ijucnt,ihk)=ipc
63080 ijjstr = 1
63081 mrev = 0
63082 ENDIF
63083 310 CONTINUE
63084C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63085 ipc=ijunc(ijucnt,ihk)
63086C...Temporary solution to cover for bug.
63087 IF(ipc.LE.0) THEN
63088 CALL pyerrm(12,'(PYPREP:) fails to hook up junctions')
63089 mint(51)=1
63090 RETURN
63091 ENDIF
63092 DO 330 icp=ipiece(ipc,1+mrev),ipiece(ipc,2-mrev),1-2*mrev
63093 i1=i1+1
63094 DO 320 j=1,5
63095 k(i1,j)=k(mstu(4)-icp,j)
63096 p(i1,j)=p(mstu(4)-icp,j)
63097 v(i1,j)=v(mstu(4)-icp,j)
63098 320 CONTINUE
63099 330 CONTINUE
63100 k(i1,1)=2
63101C...Mark last quark.
63102 IF (mrev.EQ.1.AND.ihk.GE.2) k(i1,1)=1
63103C...Do not insert junctions at wrong places.
63104 IF(ihk.LT.2.OR.mrev.NE.0) GOTO 360
63105C...Insert junction.
63106 340 ijus = iju
63107 IF (ihk.EQ.3) THEN
63108C...Shift to end junction if a j-j string has been processed.
63109 IF (ijjstr.NE.0) ijus = ipiece(ipc,4)
63110 mrev= 1
63111 ENDIF
63112 i1=i1+1
63113 DO 350 j=1,5
63114 k(i1,j)=0
63115 p(i1,j)=0.
63116 v(i1,j)=0.
63117 350 CONTINUE
63118 k(i1,1)=41
63119 k(ijus,1)=k(ijus,1)+10
63120 k(i1,2)=k(ijus,2)
63121 k(i1,3)=ijus
63122 360 IF (ihk.LT.3) GOTO 280
63123 ELSE
63124 CALL pyerrm(12,'(PYPREP:) Unknown junction type')
63125 mint(51)=1
63126 RETURN
63127 ENDIF
63128 IF (ijucnt.NE.njunc) GOTO 260
63129 ENDIF
63130 n=i1
63131
63132C...Rearrange three strings from junction, e.g. in case one has been
63133C...shortened by shower, so the last is the largest-energy one.
63134 IF(njunc.GE.1) THEN
63135C...Find systems with exactly one junction.
63136 mjun1=0
63137 nbeg=nold+1
63138 DO 470 i=nold+1,n
63139 IF(k(i,1).NE.1.AND.k(i,1).NE.41) THEN
63140 ELSEIF(k(i,1).EQ.41) THEN
63141 mjun1=mjun1+1
63142 ELSEIF(k(i,1).EQ.1.AND.mjun1.NE.1) THEN
63143 mjun1=0
63144 nbeg=i+1
63145 ELSE
63146 nend=i
63147C...Sum up energy-momentum in each junction string.
63148 DO 370 j=1,5
63149 pju(1,j)=0d0
63150 pju(2,j)=0d0
63151 pju(3,j)=0d0
63152 370 CONTINUE
63153 nju=0
63154 DO 390 i1=nbeg,nend
63155 IF(k(i1,2).NE.21) THEN
63156 nju=nju+1
63157 ijur(nju)=i1
63158 ENDIF
63159 DO 380 j=1,5
63160 pju(min(nju,3),j)=pju(min(nju,3),j)+p(i1,j)
63161 380 CONTINUE
63162 390 CONTINUE
63163C...Find which of them has highest energy (minus mass) in rest frame.
63164 DO 400 j=1,5
63165 pju(4,j)=pju(1,j)+pju(2,j)+pju(3,j)
63166 400 CONTINUE
63167 pmju=sqrt(max(0d0,pju(4,4)**2-pju(4,1)**2-pju(4,2)**2-
63168 & pju(4,3)**2))
63169 DO 410 i2=1,3
63170 pju(i2,6)=(pju(4,4)*pju(i2,4)-pju(4,1)*pju(i2,1)-
63171 & pju(4,2)*pju(i2,2)-pju(4,3)*pju(i2,3))/pmju-pju(i2,5)
63172 410 CONTINUE
63173 IF(pju(3,6).LT.min(pju(1,6),pju(2,6))) THEN
63174C...Decide how to rearrange so that new last has highest energy.
63175 IF(pju(1,6).LT.pju(2,6)) THEN
63176 irng(1,1)=ijur(1)
63177 irng(1,2)=ijur(2)-1
63178 irng(2,1)=ijur(4)
63179 irng(2,2)=ijur(3)+1
63180 irng(4,1)=ijur(3)-1
63181 irng(4,2)=ijur(2)
63182 ELSE
63183 irng(1,1)=ijur(4)
63184 irng(1,2)=ijur(3)+1
63185 irng(2,1)=ijur(2)
63186 irng(2,2)=ijur(3)-1
63187 irng(4,1)=ijur(2)-1
63188 irng(4,2)=ijur(1)
63189 ENDIF
63190 irng(3,1)=ijur(3)
63191 irng(3,2)=ijur(3)
63192C...Copy in correct order below bottom of current event record.
63193 i2=n
63194 DO 440 ii=1,4
63195 DO 430 i1=irng(ii,1),irng(ii,2),
63196 & isign(1,irng(ii,2)-irng(ii,1))
63197 i2=i2+1
63198 IF(i2.GE.mstu(4)-mstu32-5) THEN
63199 CALL pyerrm(11,
63200 & '(PYPREP:) no more memory left in PYJETS')
63201 mint(51)=1
63202 mstu(24)=1
63203 RETURN
63204 ENDIF
63205 DO 420 j=1,5
63206 k(i2,j)=k(i1,j)
63207 p(i2,j)=p(i1,j)
63208 v(i2,j)=v(i1,j)
63209 420 CONTINUE
63210 IF(k(i2,1).EQ.1) k(i2,1)=2
63211 430 CONTINUE
63212 440 CONTINUE
63213 k(i2,1)=1
63214C...Copy back up, overwriting but now in correct order.
63215 DO 460 i1=nbeg,nend
63216 i2=i1-nbeg+n+1
63217 DO 450 j=1,5
63218 k(i1,j)=k(i2,j)
63219 p(i1,j)=p(i2,j)
63220 v(i1,j)=v(i2,j)
63221 450 CONTINUE
63222 460 CONTINUE
63223 ENDIF
63224 mjun1=0
63225 nbeg=i+1
63226 ENDIF
63227 470 CONTINUE
63228
63229C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63230C...to two q-qbar systems.
63231C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63232 IF (mstj(19).NE.1) THEN
63233 mjun1 = 0
63234 jjglue = 0
63235 nbeg = nold+1
63236C...Force collapse when MSTJ(19)=2.
63237 IF (mstj(19).EQ.2) THEN
63238 delmjj = 1d9
63239 delmqq = 0d0
63240 ENDIF
63241C...Find systems with exactly two junctions.
63242 DO 700 i=nold+1,n
63243C...Count junctions
63244 IF (k(i,1).EQ.41) THEN
63245 mjun1 = mjun1+1
63246C...Check for interjunction gluons
63247 IF (mjun1.EQ.2.AND.k(i-1,1).NE.41) THEN
63248 jjglue = 1
63249 ENDIF
63250 ELSEIF(k(i,1).EQ.1.AND.(mjun1.NE.2)) THEN
63251C...If end of system reached with either zero or one junction, restart
63252C...with next system.
63253 mjun1 = 0
63254 jjglue = 0
63255 nbeg = i+1
63256 ELSEIF(k(i,1).EQ.1) THEN
63257C...If end of system reached with exactly two junctions, compute string
63258C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63259C...length measure for the (q-qbar)(q-qbar) topology.
63260 nend=i
63261C...Loop down through chain.
63262 isid=0
63263 DO 480 i1=nbeg,nend
63264C...Store string piece division locations in event record
63265 IF (k(i1,2).NE.21) THEN
63266 isid = isid+1
63267 ijcp(isid) = i1
63268 ENDIF
63269 480 CONTINUE
63270C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63271 isw=0
63272 IF (pyr(0).LT.0.5d0) isw=1
63273C...Randomly choose which qqbar string gets the jj gluons.
63274 igs=1
63275 IF (pyr(0).GT.0.5d0) igs=2
63276C...Only compute string lengths when no topology forced.
63277 IF (mstj(19).EQ.0) THEN
63278C...Repeat following for each junction
63279 DO 570 iju=1,2
63280C...Initialize iterative procedure for finding JRF
63281 ijrfit=0
63282 DO 490 ix=1,3
63283 tjuold(ix)=0d0
63284 490 CONTINUE
63285 tjuold(4)=1d0
63286C...Start iteration. Sum up momenta in string pieces
63287 500 DO 540 ijs=1,3
63288C...JD=-1 for first junction, +1 for second junction.
63289C...Find out where piece starts and ends and which direction to go.
63290 jd=2*iju-3
63291 IF (ijs.LE.2) THEN
63292 ia = ijcp((iju-1)*7 - jd*(ijs+1)) + jd
63293 ib = ijcp((iju-1)*7 - jd*ijs)
63294 ELSEIF (ijs.EQ.3) THEN
63295 jd =-jd
63296 ia = ijcp((iju-1)*7 + jd*(ijs)) + jd
63297 ib = ijcp((iju-1)*7 + jd*(ijs+3))
63298 ENDIF
63299C...Initialize junction pull 4-vector.
63300 DO 510 j=1,5
63301 pul(ijs,j)=0d0
63302 510 CONTINUE
63303C...Initialize weight
63304 pwt = 0d0
63305 pwtold = 0d0
63306C...Sum up (weighted) momenta along each string piece
63307 DO 530 isp=ia,ib,jd
63308C...If present parton not last in chain
63309 IF (isp.NE.ia.AND.isp.NE.ib) THEN
63310C...If last parton was a junction, store present weight
63311 IF (k(isp-jd,2).EQ.88) THEN
63312 pwtold = pwt
63313C...If last parton was a quark, reset to stored weight.
63314 ELSEIF (k(isp-jd,2).NE.21) THEN
63315 pwt = pwtold
63316 ENDIF
63317 ENDIF
63318C...Skip next parton if weight already large
63319 IF (pwt.GT.10d0) GOTO 530
63320C...Compute momentum in TJUOLD frame:
63321 tdp=tjuold(1)*p(isp,1)+tjuold(2)*p(isp,2)+tjuold(3
63322 & )*p(isp,3)
63323 bfc=tdp/(1d0+tjuold(4))+p(isp,4)
63324 DO 520 j=1,3
63325 tmp=p(isp,j)+tjuold(j)*bfc
63326 pul(ijs,j)=pul(ijs,j)+tmp*exp(-pwt)
63327 520 CONTINUE
63328C...Boosted energy
63329 tmp=tjuold(4)*p(isp,4)+tdp
63330 pul(ijs,4)=pul(ijs,j)+tmp*exp(-pwt)
63331C...Update weight
63332 pwt=pwt+tmp/parj(48)
63333C...Put |p| rather than m in 5th slot
63334 pul(ijs,5)=sqrt(pul(ijs,1)**2+pul(ijs,2)**2
63335 & +pul(ijs,3)**2)
63336 530 CONTINUE
63337 540 CONTINUE
63338C...Compute boost
63339 ijrfit=ijrfit+1
63340 CALL pyjurf(pul,t)
63341C...Combine new boost (T) with old boost (TJUOLD)
63342 tmp=t(1)*tjuold(1)+t(2)*tjuold(2)+t(3)*tjuold(3)
63343 DO 550 ix=1,3
63344 tjuold(ix)=t(ix)+tjuold(ix)*(tmp/(1d0+tjuold(4))+t(4
63345 & ))
63346 550 CONTINUE
63347 tjuold(4)=sqrt(1d0+tjuold(1)**2+tjuold(2)**2+tjuold(3)
63348 & **2)
63349C...If last boost small, accept JRF, else iterate.
63350C...Also prevent possibility of infinite loop.
63351 IF (abs((t(4)-1d0)/tjuold(4)).GT.0.01d0.AND.
63352 & ijrfit.LT.mstj(18))THEN
63353 GOTO 500
63354 ELSEIF (ijrfit.GE.mstj(18)) THEN
63355 CALL pyerrm(1,'(PYPREP:) failed to converge on JRF')
63356 ENDIF
63357C...Store final boost, with change of sign since TJJ motion vector.
63358 DO 560 ix=1,3
63359 tjj(iju,ix)=-tjuold(ix)
63360 560 CONTINUE
63361 tjj(iju,4)=sqrt(1d0+tjj(iju,1)**2+tjj(iju,2)**2
63362 & +tjj(iju,3)**2)
63363 570 CONTINUE
63364C...String length measure for (q-qbar)(q-qbar) topology.
63365C...Note only momenta of nearest partons used (since rest of system
63366C...identical).
63367 IF (jjglue.EQ.0) THEN
63368 delmqq=4d0*four(ijcp(2)-1,ijcp(4+isw)+1)*four(ijcp(3)
63369 & -1,ijcp(5-isw)+1)
63370 ELSE
63371C...Put jj gluons on selected string (IGS selected randomly above).
63372 IF (igs.EQ.1) THEN
63373 delmqq=8d0*four(ijcp(2)-1,ijcp(4)-1)*four(ijcp(3)+1
63374 & ,ijcp(4+isw)+1)*four(ijcp(3)-1,ijcp(5-isw)+1)
63375 ELSE
63376 delmqq=8d0*four(ijcp(2)-1,ijcp(4+isw)+1)
63377 & *four(ijcp(3)-1,ijcp(4)-1)*four(ijcp(3)+1
63378 & ,ijcp(5-isw)+1)
63379 ENDIF
63380 ENDIF
63381C...String length measure for q-q-j-j-q-q topology.
63382 t1g1=0d0
63383 t2g2=0d0
63384 t1t2=0d0
63385 t1p1=0d0
63386 t1p2=0d0
63387 t2p3=0d0
63388 t2p4=0d0
63389 isgn=-1
63390C...Note only momenta of nearest partons used (since rest of system
63391C...identical).
63392 DO 580 ix=1,4
63393 IF (ix.EQ.4) isgn=1
63394 t1p1=t1p1+isgn*tjj(1,ix)*p(ijcp(2)-1,ix)
63395 t1p2=t1p2+isgn*tjj(1,ix)*p(ijcp(3)-1,ix)
63396 t2p3=t2p3+isgn*tjj(2,ix)*p(ijcp(4)+1,ix)
63397 t2p4=t2p4+isgn*tjj(2,ix)*p(ijcp(5)+1,ix)
63398 IF (jjglue.EQ.0) THEN
63399C...Junction motion vector dot product gives length when inter-junction
63400C...gluons absent.
63401 t1t2=t1t2+isgn*tjj(1,ix)*tjj(2,ix)
63402 ELSE
63403C...Junction motion vector dot products with gluon momenta give length
63404C...when inter-junction gluons present.
63405 t1g1=t1g1+isgn*tjj(1,ix)*p(ijcp(3)+1,ix)
63406 t2g2=t2g2+isgn*tjj(2,ix)*p(ijcp(4)-1,ix)
63407 ENDIF
63408 580 CONTINUE
63409 delmjj=16d0*t1p1*t1p2*t2p3*t2p4
63410 IF (jjglue.EQ.0) THEN
63411 delmjj=delmjj*(t1t2+sqrt(t1t2**2-1))
63412 ELSE
63413 delmjj=delmjj*4d0*t1g1*t2g2
63414 ENDIF
63415 ENDIF
63416C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63417C...(Always the case for MSTJ(19)=2 due to initialization above)
63418 IF (delmjj.GT.delmqq) THEN
63419C...Put new system at end of event record
63420 ncop=n
63421 DO 650 ist=1,2
63422 DO 600 icop=ijcp(ist),ijcp(ist+1)-1
63423 ncop=ncop+1
63424 DO 590 ix=1,5
63425 p(ncop,ix)=p(icop,ix)
63426 k(ncop,ix)=k(icop,ix)
63427 590 CONTINUE
63428 600 CONTINUE
63429 IF (jjglue.NE.0.AND.ist.EQ.igs) THEN
63430C...Insert inter-junction gluon string piece (reversed)
63431 njjgl=0
63432 DO 620 icop=ijcp(4)-1,ijcp(3)+1,-1
63433 njjgl=njjgl+1
63434 ncop=ncop+1
63435 DO 610 ix=1,5
63436 p(ncop,ix)=p(icop,ix)
63437 k(ncop,ix)=k(icop,ix)
63438 610 CONTINUE
63439 620 CONTINUE
63440 ENDIF
63441 ifc=-2*ist+3
63442 DO 640 icop=ijcp(ist+ifc*isw+3)+1,ijcp(ist+ifc*isw+4)
63443 ncop=ncop+1
63444 DO 630 ix=1,5
63445 p(ncop,ix)=p(icop,ix)
63446 k(ncop,ix)=k(icop,ix)
63447 630 CONTINUE
63448 640 CONTINUE
63449 k(ncop,1)=1
63450 650 CONTINUE
63451C...Copy system back in right order
63452 DO 670 icop=nbeg,nend-2
63453 DO 660 ix=1,5
63454 p(icop,ix)=p(n+icop-nbeg+1,ix)
63455 k(icop,ix)=k(n+icop-nbeg+1,ix)
63456 660 CONTINUE
63457 670 CONTINUE
63458C...Shift down rest of event record
63459 DO 690 icop=nend+1,n
63460 DO 680 ix=1,5
63461 p(icop-2,ix)=p(icop,ix)
63462 k(icop-2,ix)=k(icop,ix)
63463 680 CONTINUE
63464 690 CONTINUE
63465C...Update length of event record.
63466 n=n-2
63467 ENDIF
63468 mjun1=0
63469 nbeg=i+1
63470 ENDIF
63471 700 CONTINUE
63472 ENDIF
63473 ENDIF
63474
63475C...Done if no checks on small-mass systems.
63476 IF(mstj(14).LT.0) RETURN
63477 IF(mstj(14).EQ.0) GOTO 1140
63478
63479C...Find lowest-mass colour singlet jet system.
63480 ns=n
63481 710 nsin=n-ns
63482 pdmin=1d0+parj(32)
63483 ic=0
63484 DO 770 i=max(1,ip),n
63485 IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN
63486 ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN
63487 nsin=nsin+1
63488 ic=i
63489 DO 720 j=1,4
63490 dps(j)=p(i,j)
63491 720 CONTINUE
63492 mstj(93)=1
63493 dps(5)=pymass(k(i,2))
63494 ELSEIF(k(i,1).EQ.2.AND.k(i,2).NE.21) THEN
63495 DO 730 j=1,4
63496 dps(j)=dps(j)+p(i,j)
63497 730 CONTINUE
63498 mstj(93)=1
63499 dps(5)=dps(5)+pymass(k(i,2))
63500 ELSEIF(k(i,1).EQ.2) THEN
63501 DO 740 j=1,4
63502 dps(j)=dps(j)+p(i,j)
63503 740 CONTINUE
63504 ELSEIF(ic.NE.0.AND.kchg(pycomp(k(i,2)),2).NE.0) THEN
63505 DO 750 j=1,4
63506 dps(j)=dps(j)+p(i,j)
63507 750 CONTINUE
63508 mstj(93)=1
63509 dps(5)=dps(5)+pymass(k(i,2))
63510 pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-
63511 & dps(5)
63512 IF(pd.LT.pdmin) THEN
63513 pdmin=pd
63514 DO 760 j=1,5
63515 dpc(j)=dps(j)
63516 760 CONTINUE
63517 ic1=ic
63518 ic2=i
63519 ENDIF
63520 ic=0
63521 ELSE
63522 nsin=nsin+1
63523 ENDIF
63524 770 CONTINUE
63525
63526C...Done if lowest-mass system above threshold for string frag.
63527 IF(pdmin.GE.parj(32)) GOTO 1140
63528
63529C...Fill small-mass system as cluster.
63530 nsav=n
63531 pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))
63532 k(n+1,1)=11
63533 k(n+1,2)=91
63534 k(n+1,3)=ic1
63535 p(n+1,1)=dpc(1)
63536 p(n+1,2)=dpc(2)
63537 p(n+1,3)=dpc(3)
63538 p(n+1,4)=dpc(4)
63539 p(n+1,5)=pecm
63540
63541C...Set up history, assuming cluster -> 2 hadrons.
63542 nbody=2
63543 k(n+1,4)=n+2
63544 k(n+1,5)=n+3
63545 k(n+2,1)=1
63546 k(n+3,1)=1
63547 IF(mstu(16).NE.2) THEN
63548 k(n+2,3)=n+1
63549 k(n+3,3)=n+1
63550 ELSE
63551 k(n+2,3)=ic1
63552 k(n+3,3)=ic2
63553 ENDIF
63554 k(n+2,4)=0
63555 k(n+3,4)=0
63556 k(n+2,5)=0
63557 k(n+3,5)=0
63558 v(n+1,5)=0d0
63559 v(n+2,5)=0d0
63560 v(n+3,5)=0d0
63561
63562C...Find total flavour content - complicated by presence of junctions.
63563 nq=0
63564 ndiq=0
63565 DO 780 i=ic1,ic2
63566 IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.k(i,2).NE.21) THEN
63567 nq=nq+1
63568 kfq(nq)=k(i,2)
63569 IF(iabs(k(i,2)).GT.1000) ndiq=ndiq+1
63570 ENDIF
63571 780 CONTINUE
63572
63573C...If several diquarks, split up one to give even number of flavours.
63574 IF(nq.EQ.3.AND.ndiq.GE.2) THEN
63575 i1=3
63576 IF(iabs(kfq(3)).LT.1000) i1=1
63577 kfq(4)=isign(mod(iabs(kfq(i1))/100,10),kfq(i1))
63578 kfq(i1)=kfq(i1)/1000
63579 nq=4
63580 ndiq=ndiq-1
63581 ENDIF
63582
63583C...If four quark ends, join two to diquark.
63584 IF(nq.EQ.4.AND.ndiq.EQ.0) THEN
63585 i1=1
63586 i2=2
63587 IF(kfq(i1)*kfq(i2).LT.0) i2=3
63588 IF(i2.EQ.3.AND.kfq(i1)*kfq(i2).LT.0) i2=4
63589 kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
63590 IF(kfq(i1).EQ.kfq(i2)) kfls=3
63591 kfq(i1)=isign(1000*max(iabs(kfq(i1)),iabs(kfq(i2)))+
63592 & 100*min(iabs(kfq(i1)),iabs(kfq(i2)))+kfls,kfq(i1))
63593 kfq(i2)=kfq(4)
63594 nq=3
63595 ndiq=1
63596 ENDIF
63597
63598C...If two quark ends, plus quark or diquark, join quarks to diquark.
63599 IF(nq.EQ.3) THEN
63600 i1=1
63601 i2=2
63602 IF(iabs(kfq(i1)).GT.1000) i1=3
63603 IF(iabs(kfq(i2)).GT.1000) i2=3
63604 kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
63605 IF(kfq(i1).EQ.kfq(i2)) kfls=3
63606 kfq(i1)=isign(1000*max(iabs(kfq(i1)),iabs(kfq(i2)))+
63607 & 100*min(iabs(kfq(i1)),iabs(kfq(i2)))+kfls,kfq(i1))
63608 kfq(i2)=kfq(3)
63609 nq=2
63610 ndiq=ndiq+1
63611 ENDIF
63612
63613C...Form two particles from flavours of lowest-mass system, if feasible.
63614 ntry = 0
63615 790 ntry = ntry + 1
63616
63617C...Open string with two specified endpoint flavours.
63618 IF(nq.EQ.2) THEN
63619 kc1=pycomp(kfq(1))
63620 kc2=pycomp(kfq(2))
63621 IF(kc1.EQ.0.OR.kc2.EQ.0) GOTO 1140
63622 kq1=kchg(kc1,2)*isign(1,kfq(1))
63623 kq2=kchg(kc2,2)*isign(1,kfq(2))
63624 IF(kq1+kq2.NE.0) GOTO 1140
63625C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63626 800 k1=kfq(1)
63627 IF(iabs(kfq(2)).GT.1000) k1=kfq(2)
63628 mstu(125)=0
63629 CALL pydcyk(k1,0,kfln,k(n+2,2))
63630 CALL pydcyk(kfq(1)+kfq(2)-k1,-kfln,kfldmp,k(n+3,2))
63631 IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 800
63632
63633C...Open string with four specified flavours.
63634 ELSEIF(nq.EQ.4) THEN
63635 kc1=pycomp(kfq(1))
63636 kc2=pycomp(kfq(2))
63637 kc3=pycomp(kfq(3))
63638 kc4=pycomp(kfq(4))
63639 IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) GOTO 1140
63640 kq1=kchg(kc1,2)*isign(1,kfq(1))
63641 kq2=kchg(kc2,2)*isign(1,kfq(2))
63642 kq3=kchg(kc3,2)*isign(1,kfq(3))
63643 kq4=kchg(kc4,2)*isign(1,kfq(4))
63644 IF(kq1+kq2+kq3+kq4.NE.0) GOTO 1140
63645C...Combine flavours pairwise to form two hadrons.
63646 810 i1=1
63647 i2=2
63648 IF(kq1*kq2.GT.0.OR.(iabs(kfq(1)).GT.1000.AND.
63649 & iabs(kfq(2)).GT.1000)) i2=3
63650 IF(i2.EQ.3.AND.(kq1*kq3.GT.0.OR.(iabs(kfq(1)).GT.1000.AND.
63651 & iabs(kfq(3)).GT.1000))) i2=4
63652 i3=3
63653 IF(i2.EQ.3) i3=2
63654 i4=10-i1-i2-i3
63655 CALL pydcyk(kfq(i1),kfq(i2),kfldmp,k(n+2,2))
63656 CALL pydcyk(kfq(i3),kfq(i4),kfldmp,k(n+3,2))
63657 IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 810
63658
63659C...Closed string.
63660 ELSE
63661 IF(iabs(k(ic2,2)).NE.21) GOTO 1140
63662C...No room for popcorn mesons in closed string -> 2 hadrons.
63663 mstu(125)=0
63664 820 CALL pydcyk(1+int((2d0+parj(2))*pyr(0)),0,kfln,kfdmp)
63665 CALL pydcyk(kfln,0,kflm,k(n+2,2))
63666 CALL pydcyk(-kfln,-kflm,kfldmp,k(n+3,2))
63667 IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) GOTO 820
63668 ENDIF
63669 p(n+2,5)=pymass(k(n+2,2))
63670 p(n+3,5)=pymass(k(n+3,2))
63671
63672C...If it does not work: try again (a number of times), give up (if no
63673C...place to shuffle momentum or too many flavours), or form one hadron.
63674 IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) THEN
63675 IF(ntry.LT.mstj(17).OR.(nq.EQ.4.AND.ntry.LT.5*mstj(17))) THEN
63676 GOTO 790
63677 ELSEIF(nsin.EQ.1.OR.nq.EQ.4) THEN
63678 GOTO 1140
63679 ELSE
63680 GOTO 890
63681 END IF
63682 END IF
63683
63684C...Perform two-particle decay of jet system.
63685C...First step: find reference axis in decaying system rest frame.
63686C...(Borrow slot N+2 for temporary direction.)
63687 DO 830 j=1,4
63688 p(n+2,j)=p(ic1,j)
63689 830 CONTINUE
63690 DO 850 i=ic1+1,ic2-1
63691 IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
63692 & kchg(pycomp(k(i,2)),2).NE.0) THEN
63693 frac1=four(ic2,i)/(four(ic1,i)+four(ic2,i))
63694 DO 840 j=1,4
63695 p(n+2,j)=p(n+2,j)+frac1*p(i,j)
63696 840 CONTINUE
63697 ENDIF
63698 850 CONTINUE
63699 CALL pyrobo(n+2,n+2,0d0,0d0,-dpc(1)/dpc(4),-dpc(2)/dpc(4),
63700 &-dpc(3)/dpc(4))
63701 the1=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))
63702 phi1=pyangl(p(n+2,1),p(n+2,2))
63703
63704C...Second step: generate isotropic/anisotropic decay.
63705 pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-
63706 &(p(n+2,5)-p(n+3,5))**2))/(2d0*pecm)
63707 860 ue(3)=pyr(0)
63708 IF(parj(21).LE.0.01d0) ue(3)=1d0
63709 pt2=(1d0-ue(3)**2)*pa**2
63710 IF(mstj(16).LE.0) THEN
63711 prev=0.5d0
63712 ELSE
63713 IF(exp(-pt2/(2d0*max(0.01d0,parj(21))**2)).LT.pyr(0)) GOTO 860
63714 pr1=p(n+2,5)**2+pt2
63715 pr2=p(n+3,5)**2+pt2
63716 alambd=sqrt(max(0d0,(pecm**2-pr1-pr2)**2-4d0*pr1*pr2))
63717 prevcf=parj(42)
63718 IF(mstj(11).EQ.2) prevcf=parj(39)
63719 prev=1d0/(1d0+exp(min(50d0,prevcf*alambd*parj(40))))
63720 ENDIF
63721 IF(pyr(0).LT.prev) ue(3)=-ue(3)
63722 phi=paru(2)*pyr(0)
63723 ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
63724 ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
63725 DO 870 j=1,3
63726 p(n+2,j)=pa*ue(j)
63727 p(n+3,j)=-pa*ue(j)
63728 870 CONTINUE
63729 p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)
63730 p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)
63731
63732C...Third step: move back to event frame and set production vertex.
63733 CALL pyrobo(n+2,n+3,the1,phi1,dpc(1)/dpc(4),dpc(2)/dpc(4),
63734 &dpc(3)/dpc(4))
63735 DO 880 j=1,4
63736 v(n+1,j)=v(ic1,j)
63737 v(n+2,j)=v(ic1,j)
63738 v(n+3,j)=v(ic2,j)
63739 880 CONTINUE
63740 n=n+3
63741 GOTO 1120
63742
63743C...Else form one particle, if possible.
63744 890 nbody=1
63745 k(n+1,5)=n+2
63746 DO 900 j=1,4
63747 v(n+1,j)=v(ic1,j)
63748 v(n+2,j)=v(ic1,j)
63749 900 CONTINUE
63750
63751C...Select hadron flavour from available quark flavours.
63752 910 IF(nq.EQ.2.AND.iabs(kfq(1)).GT.100.AND.iabs(kfq(2)).GT.100) THEN
63753 GOTO 1140
63754 ELSEIF(nq.EQ.2) THEN
63755 CALL pykfdi(kfq(1),kfq(2),kfldmp,k(n+2,2))
63756 ELSE
63757 kfln=1+int((2d0+parj(2))*pyr(0))
63758 CALL pykfdi(kfln,-kfln,kfldmp,k(n+2,2))
63759 ENDIF
63760 IF(k(n+2,2).EQ.0) GOTO 910
63761 p(n+2,5)=pymass(k(n+2,2))
63762
63763C...Use old algorithm for E/p conservation? (EN)
63764 IF (mstj(16).LE.0) GOTO 1080
63765
63766C...Find the string piece closest to the cluster by a loop
63767C...over the undecayed partons not in present cluster. (EN)
63768 dglomi=1d30
63769 ibeg=0
63770 i0=0
63771 njunc=0
63772 DO 940 i1=max(1,ip),n-1
63773 IF(k(i1,1).EQ.1) njunc=0
63774 IF(k(i1,1).EQ.41) njunc=njunc+1
63775 IF(k(i1,1).EQ.41) GOTO 940
63776 IF(i1.GE.ic1-1.AND.i1.LE.ic2) THEN
63777 i0=0
63778 ELSEIF(k(i1,1).EQ.2) THEN
63779 IF(i0.EQ.0) i0=i1
63780 i2=i1
63781 920 i2=i2+1
63782 IF(k(i2,1).EQ.41) GOTO 940
63783 IF(k(i2,1).GT.10) GOTO 920
63784 IF(kchg(pycomp(k(i2,2)),2).EQ.0) GOTO 920
63785 IF(k(i1,2).EQ.21.AND.k(i2,2).NE.21.AND.k(i2,1).NE.1.AND.
63786 & njunc.EQ.0) GOTO 940
63787 IF(k(i1,2).NE.21.AND.k(i2,2).EQ.21.AND.njunc.NE.0) GOTO 940
63788 IF(k(i1,2).NE.21.AND.k(i2,2).NE.21.AND.(i1.GT.i0.OR.
63789 & k(i2,1).NE.1)) GOTO 940
63790
63791C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63792 DO 930 j=1,3
63793 e1(j)=p(i1,j)/p(i1,4)
63794 e2(j)=p(i2,j)/p(i2,4)
63795 ecl(j)=p(n+1,j)/p(n+1,4)
63796 e3(j)=e2(j)-e1(j)
63797 e4(j)=ecl(j)-e1(j)
63798 930 CONTINUE
63799
63800C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63801 e3s=e3(1)**2+e3(2)**2+e3(3)**2
63802 e4s=e4(1)**2+e4(2)**2+e4(3)**2
63803 e34=e3(1)*e4(1)+e3(2)*e4(2)+e3(3)*e4(3)
63804 IF(e34.LE.0d0) THEN
63805 ddmin=e4s
63806 ELSEIF(e34.LT.e3s) THEN
63807 ddmin=e4s-e34**2/e3s
63808 ELSE
63809 ddmin=e4s-2d0*e34+e3s
63810 ENDIF
63811
63812C...Is this the smallest so far?
63813 IF(ddmin.LT.dglomi) THEN
63814 dglomi=ddmin
63815 ibeg=i0
63816 ipcs=i1
63817 ENDIF
63818 ELSEIF(k(i1,1).EQ.1.AND.kchg(pycomp(k(i1,2)),2).NE.0) THEN
63819 i0=0
63820 ENDIF
63821 940 CONTINUE
63822
63823C... Check if there are any strings to connect to the new gluon. (EN)
63824 IF (ibeg.EQ.0) GOTO 1080
63825
63826C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63827 IF (p(n+1,5).GE.p(n+2,5)) THEN
63828
63829C...Construct 'gluon' that is needed to put hadron on the mass shell.
63830 frac=p(n+2,5)/p(n+1,5)
63831 DO 950 j=1,5
63832 p(n+2,j)=frac*p(n+1,j)
63833 pg(j)=(1d0-frac)*p(n+1,j)
63834 950 CONTINUE
63835
63836C... Copy string with new gluon put in.
63837 n=n+2
63838 i=ibeg-1
63839 960 i=i+1
63840 IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 960
63841 IF(kchg(pycomp(k(i,2)),2).EQ.0.AND.k(i,1).NE.41) GOTO 960
63842 n=n+1
63843 DO 970 j=1,5
63844 k(n,j)=k(i,j)
63845 p(n,j)=p(i,j)
63846 v(n,j)=v(i,j)
63847 970 CONTINUE
63848 k(i,1)=k(i,1)+10
63849 k(i,4)=n
63850 k(i,5)=n
63851 k(n,3)=i
63852 IF(i.EQ.ipcs) THEN
63853 n=n+1
63854 DO 980 j=1,5
63855 k(n,j)=k(n-1,j)
63856 p(n,j)=pg(j)
63857 v(n,j)=v(n-1,j)
63858 980 CONTINUE
63859 k(n,2)=21
63860 k(n,3)=nsav+1
63861 ENDIF
63862 IF(k(i,1).EQ.12.OR.k(i,1).EQ.51) GOTO 960
63863 GOTO 1120
63864
63865C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
63866C...from string piece endpoints.
63867 ELSE
63868
63869C...Begin by copying string that should give energy to cluster.
63870 n=n+2
63871 i=ibeg-1
63872 990 i=i+1
63873 IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 990
63874 IF(kchg(pycomp(k(i,2)),2).EQ.0.AND.k(i,1).NE.41) GOTO 990
63875 n=n+1
63876 DO 1000 j=1,5
63877 k(n,j)=k(i,j)
63878 p(n,j)=p(i,j)
63879 v(n,j)=v(i,j)
63880 1000 CONTINUE
63881 k(i,1)=k(i,1)+10
63882 k(i,4)=n
63883 k(i,5)=n
63884 k(n,3)=i
63885 IF(i.EQ.ipcs) i1=n
63886 IF(k(i,1).EQ.12.OR.k(i,1).EQ.51) GOTO 990
63887 i2=i1+1
63888
63889C...Set initial Phad.
63890 DO 1010 j=1,4
63891 p(nsav+2,j)=p(nsav+1,j)
63892 1010 CONTINUE
63893
63894C...Calculate Pg, a part of which will be added to Phad later. (EN)
63895 1020 IF(mstj(16).EQ.1) THEN
63896 alpha=1d0
63897 beta=1d0
63898 ELSE
63899 alpha=four(nsav+1,i2)/four(i1,i2)
63900 beta=four(nsav+1,i1)/four(i1,i2)
63901 ENDIF
63902 DO 1030 j=1,4
63903 pg(j)=alpha*p(i1,j)+beta*p(i2,j)
63904 1030 CONTINUE
63905 pg(5)=sqrt(max(1d-20,pg(4)**2-pg(1)**2-pg(2)**2-pg(3)**2))
63906
63907C..Solve 2nd order equation, use the best (smallest) solution. (EN)
63908 pmscol=p(nsav+2,4)**2-p(nsav+2,1)**2-p(nsav+2,2)**2-
63909 & p(nsav+2,3)**2
63910 pclpg=(p(nsav+2,4)*pg(4)-p(nsav+2,1)*pg(1)-
63911 & p(nsav+2,2)*pg(2)-p(nsav+2,3)*pg(3))/pg(5)**2
63912 delta=sqrt(pclpg**2+(p(nsav+2,5)**2-pmscol)/pg(5)**2)-pclpg
63913
63914C...If all gluon energy eaten, zero it and take a step back.
63915 iter=0
63916 IF(delta*alpha.GT.1d0.AND.i1.GT.nsav+3.AND.k(i1,2).EQ.21) THEN
63917 iter=1
63918 DO 1040 j=1,4
63919 p(nsav+2,j)=p(nsav+2,j)+p(i1,j)
63920 p(i1,j)=0d0
63921 1040 CONTINUE
63922 p(i1,5)=0d0
63923 k(i1,1)=k(i1,1)+10
63924 i1=i1-1
63925 IF(k(i1,1).EQ.41) iter=-1
63926 ENDIF
63927 IF(delta*beta.GT.1d0.AND.i2.LT.n.AND.k(i2,2).EQ.21) THEN
63928 iter=1
63929 DO 1050 j=1,4
63930 p(nsav+2,j)=p(nsav+2,j)+p(i2,j)
63931 p(i2,j)=0d0
63932 1050 CONTINUE
63933 p(i2,5)=0d0
63934 k(i2,1)=k(i2,1)+10
63935 i2=i2+1
63936 IF(k(i2,1).EQ.41) iter=-1
63937 ENDIF
63938 IF(iter.EQ.1) GOTO 1020
63939
63940C...If also all endpoint energy eaten, revert to old procedure.
63941 IF((1d0-delta*alpha)*p(i1,4).LT.p(i1,5).OR.
63942 & (1d0-delta*beta)*p(i2,4).LT.p(i2,5).OR.iter.EQ.-1) THEN
63943 DO 1060 i=nsav+3,n
63944 im=k(i,3)
63945 k(im,1)=k(im,1)-10
63946 k(im,4)=0
63947 k(im,5)=0
63948 1060 CONTINUE
63949 n=nsav
63950 GOTO 1080
63951 ENDIF
63952
63953C... Construct the collapsed hadron and modified string partons.
63954 DO 1070 j=1,4
63955 p(nsav+2,j)=p(nsav+2,j)+delta*pg(j)
63956 p(i1,j)=(1d0-delta*alpha)*p(i1,j)
63957 p(i2,j)=(1d0-delta*beta)*p(i2,j)
63958 1070 CONTINUE
63959 p(i1,5)=(1d0-delta*alpha)*p(i1,5)
63960 p(i2,5)=(1d0-delta*beta)*p(i2,5)
63961
63962C...Finished with string collapse in new scheme.
63963 GOTO 1120
63964 ENDIF
63965
63966C... Use old algorithm; by choice or when in trouble.
63967 1080 CONTINUE
63968C...Find parton/particle which combines to largest extra mass.
63969 ir=0
63970 ha=0d0
63971 hsm=0d0
63972 DO 1100 mcomb=1,3
63973 IF(ir.NE.0) GOTO 1100
63974 DO 1090 i=max(1,ip),n
63975 IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2
63976 & .AND.k(i,1).GE.1.AND.k(i,1).LE.2)) GOTO 1090
63977 IF(mcomb.EQ.1) kci=pycomp(k(i,2))
63978 IF(mcomb.EQ.1.AND.kci.EQ.0) GOTO 1090
63979 IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) GOTO 1090
63980 IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)
63981 & GOTO 1090
63982 hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)
63983 hsr=2d0*hcr+pecm**2-p(n+2,5)**2-2d0*p(n+2,5)*p(i,5)
63984 IF(hsr.GT.hsm) THEN
63985 ir=i
63986 ha=hcr
63987 hsm=hsr
63988 ENDIF
63989 1090 CONTINUE
63990 1100 CONTINUE
63991
63992C...Shuffle energy and momentum to put new particle on mass shell.
63993 IF(ir.NE.0) THEN
63994 hb=pecm**2+ha
63995 hc=p(n+2,5)**2+ha
63996 hd=p(ir,5)**2+ha
63997 hk2=0.5d0*(hb*sqrt(max(0d0,((hb+hc)**2-4d0*(hb+hd)*p(n+2,5)**2)/
63998 & (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)
63999 hk1=(0.5d0*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb
64000 DO 1110 j=1,4
64001 p(n+2,j)=(1d0+hk1)*dpc(j)-hk2*p(ir,j)
64002 p(ir,j)=(1d0+hk2)*p(ir,j)-hk1*dpc(j)
64003 1110 CONTINUE
64004 n=n+2
64005 ELSE
64006 CALL pyerrm(3,'(PYPREP:) no match for collapsing cluster')
64007 RETURN
64008 ENDIF
64009
64010C...Mark collapsed system and store daughter pointers. Iterate.
64011 1120 DO 1130 i=ic1,ic2
64012 IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.
64013 & kchg(pycomp(k(i,2)),2).NE.0) THEN
64014 k(i,1)=k(i,1)+10
64015 IF(mstu(16).NE.2) THEN
64016 k(i,4)=nsav+1
64017 k(i,5)=nsav+1
64018 ELSE
64019 k(i,4)=nsav+2
64020 k(i,5)=nsav+1+nbody
64021 ENDIF
64022 ENDIF
64023 IF(k(i,1).EQ.41) k(i,1)=k(i,1)+10
64024 1130 CONTINUE
64025 IF(n.LT.mstu(4)-mstu(32)-5) GOTO 710
64026
64027C...Check flavours and invariant masses in parton systems.
64028 1140 np=0
64029 kfn=0
64030 kqs=0
64031 nju=0
64032 DO 1150 j=1,5
64033 dps(j)=0d0
64034 1150 CONTINUE
64035 DO 1180 i=max(1,ip),n
64036 IF(k(i,1).EQ.41) nju=nju+1
64037 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 1180
64038 kc=pycomp(k(i,2))
64039 IF(kc.EQ.0) GOTO 1180
64040 kq=kchg(kc,2)*isign(1,k(i,2))
64041 IF(kq.EQ.0) GOTO 1180
64042 np=np+1
64043 IF(kq.NE.2) THEN
64044 kfn=kfn+1
64045 kqs=kqs+kq
64046 mstj(93)=1
64047 dps(5)=dps(5)+pymass(k(i,2))
64048 ENDIF
64049 DO 1160 j=1,4
64050 dps(j)=dps(j)+p(i,j)
64051 1160 CONTINUE
64052 IF(k(i,1).EQ.1) THEN
64053 nferr=0
64054 IF(nju.EQ.0.AND.np.NE.1) THEN
64055 IF(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0) nferr=1
64056 ELSEIF(nju.EQ.1) THEN
64057 IF(kfn.NE.3.OR.iabs(kqs).NE.3) nferr=1
64058 ELSEIF(nju.EQ.2) THEN
64059 IF(kfn.NE.4.OR.kqs.NE.0) nferr=1
64060 ELSEIF(nju.GE.3) THEN
64061 nferr=1
64062 ENDIF
64063 IF(nferr.EQ.1) THEN
64064 CALL pyerrm(2,'(PYPREP:) unphysical flavour combination')
64065 mint(51)=1
64066 RETURN
64067 ENDIF
64068 IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.
64069 & (0.9d0*parj(32)+dps(5))**2) CALL pyerrm(3,
64070 & '(PYPREP:) too small mass in jet system')
64071 np=0
64072 kfn=0
64073 kqs=0
64074 nju=0
64075 DO 1170 j=1,5
64076 dps(j)=0d0
64077 1170 CONTINUE
64078 ENDIF
64079 1180 CONTINUE
64080
64081 RETURN
64082 END
64083
64084C*********************************************************************
64085
64086C...PYSTRF
64087C...Handles the fragmentation of an arbitrary colour singlet
64088C...jet system according to the Lund string fragmentation model.
64089
64090 SUBROUTINE pystrf(IP)
64091
64092C...Double precision and integer declarations.
64093 IMPLICIT DOUBLE PRECISION(a-h, o-z)
64094 IMPLICIT INTEGER(I-N)
64095 INTEGER PYK,PYCHGE,PYCOMP
64096C...Commonblocks.
64097 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
64098 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
64099 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
64100 SAVE /pyjets/,/pydat1/,/pydat2/
64101C...Local arrays. All MOPS variables ends with MO
64102 dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),
64103 &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(6),pju(5,5),
64104 &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8),
64105 &inmo(9),pm2qmo(2),xtmo(2),ejstr(2),ijuori(2),ibarrk(2),
64106 &pbst(3,5),tjuold(5)
64107
64108C...Function: four-product of two vectors.
64109 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)
64110 dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-
64111 &dp(i,3)*dp(j,3)
64112
64113C...Reset counters.
64114 mstj(91)=0
64115 nsav=n
64116 mstu90=mstu(90)
64117 np=0
64118 kqsum=0
64119 DO 100 j=1,5
64120 dps(j)=0d0
64121 100 CONTINUE
64122 mju(1)=0
64123 mju(2)=0
64124 ntryfn=0
64125 ijuori(1)=0
64126 ijuori(2)=0
64127
64128C...Identify parton system.
64129 i=ip-1
64130 110 i=i+1
64131 IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
64132 CALL pyerrm(12,'(PYSTRF:) failed to reconstruct jet system')
64133 IF(mstu(21).GE.1) RETURN
64134 ENDIF
64135 IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) GOTO 110
64136 kc=pycomp(k(i,2))
64137 IF(kc.EQ.0) GOTO 110
64138 kq=kchg(kc,2)*isign(1,k(i,2))
64139 IF(kq.EQ.0.AND.k(i,1).NE.41) GOTO 110
64140 IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN
64141 CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
64142 IF(mstu(21).GE.1) RETURN
64143 ENDIF
64144
64145C...Take copy of partons to be considered. Check flavour sum.
64146 np=np+1
64147 DO 120 j=1,5
64148 k(n+np,j)=k(i,j)
64149 p(n+np,j)=p(i,j)
64150 IF(j.NE.4) dps(j)=dps(j)+p(i,j)
64151 120 CONTINUE
64152 dps(4)=dps(4)+sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
64153 k(n+np,3)=i
64154 IF(kq.NE.2) kqsum=kqsum+kq
64155 IF(k(i,1).EQ.41) THEN
64156 IF(mod(kqsum,2).EQ.0.AND.mju(1).EQ.0) THEN
64157 mju(1)=n+np
64158 ijuori(1)=i
64159 ELSE
64160 mju(2)=n+np
64161 ijuori(2)=i
64162 ENDIF
64163 ENDIF
64164 IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) GOTO 110
64165 IF(mod(kqsum,3).NE.0) THEN
64166 CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')
64167 IF(mstu(21).GE.1) RETURN
64168 ENDIF
64169 IF(mju(1).GT.0.OR.mju(2).GT.0) mstu(29)=1
64170
64171C...Boost copied system to CM frame (for better numerical precision).
64172 IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN
64173 mbst=0
64174 mstu(33)=1
64175 CALL pyrobo(n+1,n+np,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
64176 & -dps(3)/dps(4))
64177 ELSE
64178 mbst=1
64179 hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))
64180 DO 130 i=n+1,n+np
64181 hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
64182 IF(p(i,3).GT.0d0) THEN
64183 hhpez=max(1d-10,(p(i,4)+p(i,3))/hhbz)
64184 p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
64185 p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
64186 ELSE
64187 hhpez=max(1d-10,(p(i,4)-p(i,3))*hhbz)
64188 p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
64189 p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
64190 ENDIF
64191 130 CONTINUE
64192 ENDIF
64193
64194C...Search for very nearby partons that may be recombined.
64195 ntryr=0
64196 ntrywr=0
64197 paru12=paru(12)
64198 paru13=paru(13)
64199 mju(3)=mju(1)
64200 mju(4)=mju(2)
64201 nr=np
64202 nrmin=2
64203 IF(mju(1).GT.0) nrmin=nrmin+2
64204 IF(mju(2).GT.0) nrmin=nrmin+2
64205 140 IF(nr.GT.nrmin) THEN
64206 pdrmin=2d0*paru12
64207 DO 150 i=n+1,n+nr
64208 IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) GOTO 150
64209 i1=i+1
64210 IF(i.EQ.n+nr) i1=n+1
64211 IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) GOTO 150
64212 IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)
64213 & GOTO 150
64214 IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21)
64215 & GOTO 150
64216 pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+
64217 & p(i1,2)**2+p(i1,3)**2))
64218 pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)
64219 pdr=4d0*(pap-pvp)**2/max(1d-6,paru13**2*pap+2d0*(pap-pvp))
64220 IF(pdr.LT.pdrmin) THEN
64221 ir=i
64222 pdrmin=pdr
64223 ENDIF
64224 150 CONTINUE
64225
64226C...Recombine very nearby partons to avoid machine precision problems.
64227 IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN
64228 DO 160 j=1,4
64229 p(n+1,j)=p(n+1,j)+p(n+nr,j)
64230 160 CONTINUE
64231 p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-
64232 & p(n+1,3)**2))
64233 nr=nr-1
64234 GOTO 140
64235 ELSEIF(pdrmin.LT.paru12) THEN
64236 DO 170 j=1,4
64237 p(ir,j)=p(ir,j)+p(ir+1,j)
64238 170 CONTINUE
64239 p(ir,5)=sqrt(max(0d0,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-
64240 & p(ir,3)**2))
64241 IF(mju(2).NE.0.AND.ir.GT.mju(2)) k(ir,2)=k(ir+1,2)
64242 DO 190 i=ir+1,n+nr-1
64243 k(i,1)=k(i+1,1)
64244 k(i,2)=k(i+1,2)
64245 DO 180 j=1,5
64246 p(i,j)=p(i+1,j)
64247 180 CONTINUE
64248 190 CONTINUE
64249 IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)
64250 nr=nr-1
64251 IF(mju(1).GT.ir) mju(1)=mju(1)-1
64252 IF(mju(2).GT.ir) mju(2)=mju(2)-1
64253 GOTO 140
64254 ENDIF
64255 ENDIF
64256 ntryr=ntryr+1
64257
64258C...Reset particle counter. Skip ahead if no junctions are present;
64259C...this is usually the case!
64260 nrs=max(5*nr+11,np)
64261 ntry=0
64262 200 ntry=ntry+1
64263 IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
64264 paru12=4d0*paru12
64265 paru13=2d0*paru13
64266 GOTO 140
64267 ELSEIF(ntry.GT.100.OR.ntryr.GT.100) THEN
64268 CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
64269 IF(mstu(21).GE.1) RETURN
64270 ENDIF
64271 i=n+nrs
64272 mstu(90)=mstu90
64273 IF(mju(1).EQ.0.AND.mju(2).EQ.0) GOTO 650
64274 IF(mstj(12).GE.4) CALL pyerrm(29,'(PYSTRF:) sorry,'//
64275 & ' junction strings not handled by MSTJ(12)>3 options')
64276 DO 640 jt=1,2
64277 njs(jt)=0
64278 IF(mju(jt).EQ.0) GOTO 640
64279 js=3-2*jt
64280
64281C++SKANDS
64282C...Find and sum up momentum on three sides of junction.
64283C...Begin with previous boost = zero.
64284 ijrfit=0
64285 DO 210 ix=1,3
64286 tjuold(ix)=0d0
64287 210 CONTINUE
64288C...Prevent IJU (specifically IJU(5)) from containing junk below
64289 DO 215 iu=1,6
64290 iju(iu)=0
64291 215 CONTINUE
64292 tjuold(4)=1d0
64293 220 iu=0
64294C...Beginning and end of string system in event record.
64295 i1beg=n+1+(jt-1)*(nr-1)
64296 i1end=n+nr+(jt-1)*(1-nr)
64297C...Look for junction string piece end points
64298 DO 230 i1=i1beg,i1end,js
64299 IF(k(i1,2).NE.21.AND.iu.LE.5.AND.ijrfit.EQ.0) THEN
64300C...Store junction string piece end points.
64301C 1-junction systems 2-junction systems
64302C IU : 1 2 3 4 1 2 3 4 5 6
64303C 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
64304 iu=iu+1
64305 iju(iu)=i1
64306 ENDIF
64307C...Sum over momenta, from junction outwards.
64308 230 CONTINUE
64309 DO 280 iu=1,3
64310 pwt=0d0
64311C...Initialize junction drag and string piece 4-vectors.
64312 DO 240 j=1,5
64313 pbst(iu,j)=0d0
64314 pju(iu,j)=0d0
64315 240 CONTINUE
64316C...First two branches. Inwards out means opposite direction to JS.
64317C...(JS is 1 for JT=1, -1 for JT=2)
64318 IF (iu.LT.3) THEN
64319 i1a=iju(iu+1)-js
64320 i1b=iju(iu)
64321 idir=-js
64322C...Last branch (gq or gjgqgq). Direction now reversed.
64323 ELSE
64324 i1a=iju(iu)+js
64325 i1b=i1end
64326 idir=js
64327 ENDIF
64328 DO 270 i1=i1a,i1b,idir
64329C...Sum up momentum directions with exponential suppression
64330C...for use in finding junction rest frame below.
64331 IF (k(i1,2).EQ.88) THEN
64332C...gjgqgq type system encountered. Use current PWT as start
64333C...for both strings.
64334 pwtold=pwt
64335 ELSE
64336 IF (i1.EQ.iju(5)+idir) pwt=pwtold
64337C...Sum up string piece (boosted) 4-momenta.
64338 DO 250 j=1,4
64339 pju(iu,j)=pju(iu,j)+p(i1,j)
64340 250 CONTINUE
64341C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64342C...boost is zero, see above). Skip parton if suppression factor large.
64343 IF (pwt.GT.10d0) GOTO 270
64344C...Compute momentum in current frame:
64345 tdp=tjuold(1)*p(i1,1)+tjuold(2)*p(i1,2)+tjuold(3)*p(i1,3)
64346 bfc=tdp/(1d0+tjuold(4))+p(i1,4)
64347 DO 260 j=1,3
64348 ptmp=p(i1,j)+tjuold(j)*bfc
64349 pbst(iu,j)=pbst(iu,j)+ptmp*exp(-pwt)
64350 260 CONTINUE
64351C...Boosted energy
64352 ptmp=tjuold(4)*p(i1,4)+tdp
64353 pbst(iu,4)=pbst(iu,j)+ptmp*exp(-pwt)
64354 pwt=pwt+ptmp/parj(48)
64355 ENDIF
64356 270 CONTINUE
64357C...Put |p| rather than m in 5th slot.
64358 pbst(iu,5)=sqrt(pbst(iu,1)**2+pbst(iu,2)**2+pbst(iu,3)**2)
64359 pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)
64360 280 CONTINUE
64361
64362C...Calculate boost from present frame to next JRF candidate.
64363 ijrfit=ijrfit+1
64364 CALL pyjurf(pbst,tju)
64365
64366C...After some iterations do not take full step in new direction.
64367 IF(ijrfit.GT.5) THEN
64368 reduce=0.8d0**(ijrfit-5)
64369 tju(1)=reduce*tju(1)
64370 tju(2)=reduce*tju(2)
64371 tju(3)=reduce*tju(3)
64372 tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)
64373 ENDIF
64374
64375C...Combine new boost (TJU) with old boost (TJUOLD)
64376 tmp=tju(1)*tjuold(1)+tju(2)*tjuold(2)+tju(3)*tjuold(3)
64377 DO 290 ix=1,3
64378 tjuold(ix)=tju(ix)+tjuold(ix)*(tmp/(1d0+tjuold(4))+tju(4))
64379 290 CONTINUE
64380 tjuold(4)=sqrt(1d0+tjuold(1)**2+tjuold(2)**2+tjuold(3)**2)
64381
64382C...If last boost small, accept JRF, else iterate.
64383C...Also prevent possibility of infinite loop.
64384 IF (abs((tju(4)-1d0)/tjuold(4)).GT.0.01d0.AND.
64385 & ijrfit.LT.mstj(18)) THEN
64386 GOTO 220
64387 ELSEIF (ijrfit.GE.mstj(18)) THEN
64388 CALL pyerrm(1,'(PYSTRF:) failed to converge on JRF')
64389 ENDIF
64390
64391C...Now store total boost in TJU and change perception.
64392C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64393C...TJU = junction motion vector in string CM, so the sign changes.
64394 DO 300 j=1,3
64395 tju(j)=-tjuold(j)
64396 300 CONTINUE
64397 tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)
64398
64399C--SKANDS
64400
64401C...Calculate string piece energies in junction rest frame.
64402 DO 310 iu=1,3
64403 pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-
64404 & tju(3)*pju(iu,3)
64405 pbst(iu,5)=tju(4)*pbst(iu,4)-tju(1)*pbst(iu,1)-
64406 & tju(2)*pbst(iu,2)-tju(3)*pbst(iu,3)
64407 310 CONTINUE
64408
64409C...Start preparing for fragmentation of two strings from junction.
64410 ista=i
64411 ntryer=0
64412 320 ntryer=ntryer+1
64413 i=ista
64414 DO 620 iu=1,2
64415 ns=iabs(iju(iu+1)-iju(iu))
64416
64417C...Junction strings: find longitudinal string directions.
64418 DO 350 is=1,ns
64419 is1=iju(iu)+js*(is-1)
64420 is2=iju(iu)+js*is
64421 DO 330 j=1,5
64422 dp(1,j)=0.5d0*p(is1,j)
64423 IF(is.EQ.1) dp(1,j)=p(is1,j)
64424 dp(2,j)=0.5d0*p(is2,j)
64425 IF(is.EQ.ns) dp(2,j)=(-pbst(iu,j)+2d0*pbst(iu,5)*tju(j))*
64426 & (pju(iu,5)/pbst(iu,5))
64427 330 CONTINUE
64428 IF(is.EQ.ns) dp(2,5)=sqrt(max(0d0,pju(iu,4)**2-
64429 & pju(iu,1)**2-pju(iu,2)**2-pju(iu,3)**2))
64430 dp(3,5)=dfour(1,1)
64431 dp(4,5)=dfour(2,2)
64432 dhkc=dfour(1,2)
64433 IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN
64434 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
64435 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
64436 dp(3,5)=0d0
64437 dp(4,5)=0d0
64438 dhkc=dfour(1,2)
64439 ENDIF
64440 dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
64441 dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
64442 dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
64443 in1=n+nr+4*is-3
64444 p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
64445 DO 340 j=1,4
64446 p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
64447 p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
64448 340 CONTINUE
64449 350 CONTINUE
64450
64451C...Junction strings: initialize flavour, momentum and starting pos.
64452 isav=i
64453 mstu91=mstu(90)
64454 360 ntry=ntry+1
64455 IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
64456 paru12=4d0*paru12
64457 paru13=2d0*paru13
64458 GOTO 140
64459 ELSEIF(ntry.GT.100) THEN
64460 CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
64461 IF(mstu(21).GE.1) RETURN
64462 ENDIF
64463 i=isav
64464 mstu(90)=mstu91
64465 irankj=0
64466 ie(1)=k(n+1+(jt/2)*(np-1),3)
64467 IF (mod(jt+iu,2).NE.0) THEN
64468 ie(1)=k(iju(iu),3)
64469 IF (np-nr.NE.0) THEN
64470C...If gluons have disappeared. Original IJU must be used.
64471 it=ip
64472 ne=1
64473 370 it=it+1
64474 IF (k(it,2).NE.21) THEN
64475 ne=ne+1
64476 ENDIF
64477 IF (ne.EQ.iu+4*(jt-1)) THEN
64478 ie(1)=it
64479 ELSEIF (it.LE.ip+np) THEN
64480 GOTO 370
64481 ELSE
64482 CALL pyerrm(14,'(PYSTRF:) '//
64483 & 'Original IJU could not be reconstructed!')
64484 ENDIF
64485 ENDIF
64486 ENDIF
64487 in(4)=n+nr+1
64488 in(5)=in(4)+1
64489 in(6)=n+nr+4*ns+1
64490 DO 390 jq=1,2
64491 DO 380 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4
64492 p(in1,1)=2-jq
64493 p(in1,2)=jq-1
64494 p(in1,3)=1d0
64495 380 CONTINUE
64496 390 CONTINUE
64497 kfl(1)=k(iju(iu),2)
64498 px(1)=0d0
64499 py(1)=0d0
64500 gam(1)=0d0
64501 DO 400 j=1,5
64502 pju(iu+3,j)=0d0
64503 400 CONTINUE
64504
64505C...Junction strings: find initial transverse directions.
64506 DO 410 j=1,4
64507 dp(1,j)=p(in(4),j)
64508 dp(2,j)=p(in(4)+1,j)
64509 dp(3,j)=0d0
64510 dp(4,j)=0d0
64511 410 CONTINUE
64512 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
64513 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
64514 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
64515 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
64516 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
64517 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
64518 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
64519 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
64520 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
64521 dhc12=dfour(1,2)
64522 dhcx1=dfour(3,1)/dhc12
64523 dhcx2=dfour(3,2)/dhc12
64524 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
64525 dhcy1=dfour(4,1)/dhc12
64526 dhcy2=dfour(4,2)/dhc12
64527 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
64528 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
64529 DO 420 j=1,4
64530 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
64531 p(in(6),j)=dp(3,j)
64532 p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
64533 & dhcyx*dp(3,j))
64534 420 CONTINUE
64535
64536C...Junction strings: produce new particle, origin.
64537 430 i=i+1
64538 IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
64539 CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
64540 IF(mstu(21).GE.1) RETURN
64541 ENDIF
64542 irankj=irankj+1
64543 k(i,1)=1
64544 k(i,3)=ie(1)
64545 k(i,4)=0
64546 k(i,5)=0
64547
64548C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64549 440 CALL pykfdi(kfl(1),0,kfl(3),k(i,2))
64550 IF(k(i,2).EQ.0) GOTO 360
64551 IF(irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.
64552 & iabs(kfl(3)).GT.10) THEN
64553 IF(pyr(0).GT.parj(19)) GOTO 440
64554 ENDIF
64555 p(i,5)=pymass(k(i,2))
64556 CALL pyptdi(kfl(1),px(3),py(3))
64557 pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2
64558 CALL pyzdis(kfl(1),kfl(3),pr(1),z)
64559 IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.
64560 & mstu(90).LT.8) THEN
64561 mstu(90)=mstu(90)+1
64562 mstu(90+mstu(90))=i
64563 paru(90+mstu(90))=z
64564 ENDIF
64565 gam(3)=(1d0-z)*(gam(1)+pr(1)/z)
64566 DO 450 j=1,3
64567 in(j)=in(3+j)
64568 450 CONTINUE
64569
64570C...Junction strings: stepping within 'low' string region.
64571 IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
64572 & p(in(1),5)**2.GE.pr(1)) THEN
64573 p(in(1)+2,4)=z*p(in(1)+2,3)
64574 p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)
64575 DO 460 j=1,4
64576 p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)
64577 460 CONTINUE
64578 GOTO 560
64579C...Has used up energy of junction string, i.e. no more hadrons in it.
64580 ELSEIF(in(1)+1.EQ.in(2).AND.in(1).EQ.n+nr+4*ns-3) THEN
64581 DO 470 j=1,5
64582 p(i,j)=0d0
64583 470 CONTINUE
64584 GOTO 600
64585C...Stepping from 'low' string region
64586 ELSEIF(in(1)+1.EQ.in(2)) THEN
64587 p(in(2)+2,4)=p(in(2)+2,3)
64588 p(in(2)+2,1)=1d0
64589 in(2)=in(2)+4
64590 IF(in(2).GT.n+nr+4*ns) GOTO 360
64591 IF(four(in(1),in(2)).LE.1d-2) THEN
64592 p(in(1)+2,4)=p(in(1)+2,3)
64593 p(in(1)+2,1)=0d0
64594 in(1)=in(1)+4
64595 ENDIF
64596 ENDIF
64597
64598C...Junction strings: find new transverse directions.
64599 480 IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.
64600 & in(1).GT.in(2)) GOTO 360
64601 IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN
64602 DO 490 j=1,4
64603 dp(1,j)=p(in(1),j)
64604 dp(2,j)=p(in(2),j)
64605 dp(3,j)=0d0
64606 dp(4,j)=0d0
64607 490 CONTINUE
64608 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
64609 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
64610 dhc12=dfour(1,2)
64611 IF(dhc12.LE.1d-2) THEN
64612 p(in(1)+2,4)=p(in(1)+2,3)
64613 p(in(1)+2,1)=0d0
64614 in(1)=in(1)+4
64615 GOTO 480
64616 ENDIF
64617 in(3)=n+nr+4*ns+5
64618 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
64619 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
64620 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
64621 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
64622 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
64623 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
64624 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
64625 dhcx1=dfour(3,1)/dhc12
64626 dhcx2=dfour(3,2)/dhc12
64627 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
64628 dhcy1=dfour(4,1)/dhc12
64629 dhcy2=dfour(4,2)/dhc12
64630 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
64631 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
64632 DO 500 j=1,4
64633 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
64634 p(in(3),j)=dp(3,j)
64635 p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
64636 & dhcyx*dp(3,j))
64637 500 CONTINUE
64638C...Express pT with respect to new axes, if sensible.
64639 pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))
64640 pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))
64641 IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
64642 px(3)=pxp
64643 py(3)=pyp
64644 ENDIF
64645 ENDIF
64646
64647C...Junction strings: sum up known four-momentum, coefficients for m2.
64648 DO 530 j=1,4
64649 dhg(j)=0d0
64650 p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+
64651 & py(3)*p(in(3)+1,j)
64652 DO 510 in1=in(4),in(1)-4,4
64653 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
64654 510 CONTINUE
64655 DO 520 in2=in(5),in(2)-4,4
64656 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
64657 520 CONTINUE
64658 530 CONTINUE
64659 dhm(1)=four(i,i)
64660 dhm(2)=2d0*four(i,in(1))
64661 dhm(3)=2d0*four(i,in(2))
64662 dhm(4)=2d0*four(in(1),in(2))
64663
64664C...Junction strings: find coefficients for Gamma expression.
64665 DO 550 in2=in(1)+1,in(2),4
64666 DO 540 in1=in(1),in2-1,4
64667 dhc=2d0*four(in1,in2)
64668 dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc
64669 IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc
64670 IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc
64671 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
64672 540 CONTINUE
64673 550 CONTINUE
64674
64675C...Junction strings: solve (m2, Gamma) equation system for energies.
64676 dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)
64677 IF(abs(dhs1).LT.1d-4) GOTO 360
64678 dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*
64679 & (p(i,5)**2-dhm(1))+dhg(2)*dhm(3)
64680 dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))
64681 p(in(2)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
64682 & abs(dhs1)-dhs2/dhs1)
64683 IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0d0) GOTO 360
64684 p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/
64685 & (dhm(2)+dhm(4)*p(in(2)+2,4))
64686
64687C...Junction strings: step to new region if necessary.
64688 IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN
64689 p(in(2)+2,4)=p(in(2)+2,3)
64690 p(in(2)+2,1)=1d0
64691 in(2)=in(2)+4
64692 IF(in(2).GT.n+nr+4*ns) GOTO 360
64693 IF(four(in(1),in(2)).LE.1d-2) THEN
64694 p(in(1)+2,4)=p(in(1)+2,3)
64695 p(in(1)+2,1)=0d0
64696 in(1)=in(1)+4
64697 ENDIF
64698 GOTO 480
64699 ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN
64700 p(in(1)+2,4)=p(in(1)+2,3)
64701 p(in(1)+2,1)=0d0
64702 in(1)=in(1)+4
64703 GOTO 480
64704 ENDIF
64705
64706C...Junction strings: particle four-momentum, remainder, loop back.
64707 560 DO 570 j=1,4
64708 p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+
64709 & p(in(2)+2,4)*p(in(2),j)
64710 pju(iu+3,j)=pju(iu+3,j)+p(i,j)
64711 570 CONTINUE
64712 IF(p(i,4).LT.p(i,5)) GOTO 360
64713 pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
64714 & tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
64715 IF(pju(iu+3,5).LT.pju(iu,5)) THEN
64716 kfl(1)=-kfl(3)
64717 px(1)=-px(3)
64718 py(1)=-py(3)
64719 gam(1)=gam(3)
64720 IF(in(3).NE.in(6)) THEN
64721 DO 580 j=1,4
64722 p(in(6),j)=p(in(3),j)
64723 p(in(6)+1,j)=p(in(3)+1,j)
64724 580 CONTINUE
64725 ENDIF
64726 DO 590 jq=1,2
64727 in(3+jq)=in(jq)
64728 p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
64729 p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)
64730 590 CONTINUE
64731 GOTO 430
64732 ENDIF
64733
64734C...Junction strings: save quantities left after each string.
64735 IF(iabs(kfl(1)).GT.10) GOTO 360
64736 600 i=i-1
64737 kfjh(iu)=kfl(1)
64738 DO 610 j=1,4
64739 pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)
64740 610 CONTINUE
64741
64742C...Junction strings: loopback if much unused energy in both strings.
64743 pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-
64744 & tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)
64745 ejstr(iu)=pju(iu,5)-pju(iu+3,5)
64746 620 CONTINUE
64747 IF((min(ejstr(1),ejstr(2)).GT.parj(49).OR.
64748 & ejstr(1).GT.parj(49)+pyr(0)*parj(50).OR.
64749 & ejstr(2).GT.parj(49)+pyr(0)*parj(50))
64750 & .AND.ntryer.LT.10) GOTO 320
64751
64752C...Junction strings: put together to new effective string endpoint.
64753 njs(jt)=i-ista
64754 kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1
64755 IF(kfjh(1).EQ.kfjh(2)) kfls=3
64756 kfjs(jt)=isign(1000*max(iabs(kfjh(1)),iabs(kfjh(2)))+
64757 & 100*min(iabs(kfjh(1)),iabs(kfjh(2)))+kfls,kfjh(1))
64758 DO 630 j=1,4
64759 pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)
64760 pjs(jt+2,j)=pju(4,j)+pju(5,j)
64761 630 CONTINUE
64762 pjs(jt,5)=sqrt(max(0d0,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-
64763 & pjs(jt,3)**2))
64764 pjs(jt+2,5)=0d0
64765 640 CONTINUE
64766
64767C...Open versus closed strings. Choose breakup region for latter.
64768 650 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN
64769 ns=mju(2)-mju(1)
64770 nb=mju(1)-n
64771 ELSEIF(mju(1).NE.0) THEN
64772 ns=n+nr-mju(1)
64773 nb=mju(1)-n
64774 ELSEIF(mju(2).NE.0) THEN
64775 ns=mju(2)-n
64776 nb=1
64777 ELSEIF(iabs(k(n+1,2)).NE.21) THEN
64778 ns=nr-1
64779 nb=1
64780 ELSE
64781 ns=nr+1
64782 w2sum=0d0
64783 DO 660 is=1,nr
64784 p(n+nr+is,1)=0.5d0*four(n+is,n+is+1-nr*(is/nr))
64785 w2sum=w2sum+p(n+nr+is,1)
64786 660 CONTINUE
64787 w2ran=pyr(0)*w2sum
64788 nb=0
64789 670 nb=nb+1
64790 w2sum=w2sum-p(n+nr+nb,1)
64791 IF(w2sum.GT.w2ran.AND.nb.LT.nr) GOTO 670
64792 ENDIF
64793
64794C...Find longitudinal string directions (i.e. lightlike four-vectors).
64795 DO 700 is=1,ns
64796 is1=n+is+nb-1-nr*((is+nb-2)/nr)
64797 is2=n+is+nb-nr*((is+nb-1)/nr)
64798 DO 680 j=1,5
64799 dp(1,j)=p(is1,j)
64800 IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5d0*dp(1,j)
64801 IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)
64802 dp(2,j)=p(is2,j)
64803 IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5d0*dp(2,j)
64804 IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)
64805 680 CONTINUE
64806 IF(is1.EQ.mju(1)) dp(1,5)=sqrt(max(0d0,dp(1,4)**2-dp(1,1)**2-
64807 & dp(1,2)**2-dp(1,3)**2))
64808 IF(is2.EQ.mju(2)) dp(2,5)=sqrt(max(0d0,dp(2,4)**2-dp(2,1)**2-
64809 & dp(2,2)**2-dp(2,3)**2))
64810 dp(3,5)=dfour(1,1)
64811 dp(4,5)=dfour(2,2)
64812 dhkc=dfour(1,2)
64813 IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) GOTO 200
64814 dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))
64815 dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)
64816 dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)
64817 in1=n+nr+4*is-3
64818 p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))
64819 DO 690 j=1,4
64820 p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)
64821 p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)
64822 690 CONTINUE
64823 700 CONTINUE
64824
64825C...Begin initialization: sum up energy, set starting position.
64826 isav=i
64827 mstu91=mstu(90)
64828 710 ntry=ntry+1
64829 IF(ntry.GT.100.AND.ntryr.LE.8.AND.nr.GT.nrmin) THEN
64830 paru12=4d0*paru12
64831 paru13=2d0*paru13
64832 GOTO 140
64833 ELSEIF(ntry.GT.100) THEN
64834 CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')
64835 IF(mstu(21).GE.1) RETURN
64836 ENDIF
64837 i=isav
64838 mstu(90)=mstu91
64839 DO 730 j=1,4
64840 p(n+nrs,j)=0d0
64841 DO 720 is=1,nr
64842 p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)
64843 720 CONTINUE
64844 730 CONTINUE
64845 DO 750 jt=1,2
64846 irank(jt)=0
64847 IF(mju(jt).NE.0) irank(jt)=njs(jt)
64848 IF(ns.GT.nr) irank(jt)=1
64849 ibarrk(jt)=0
64850 ie(jt)=k(n+1+(jt/2)*(np-1),3)
64851 in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)
64852 in(3*jt+2)=in(3*jt+1)+1
64853 in(3*jt+3)=n+nr+4*ns+2*jt-1
64854 DO 740 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4
64855 p(in1,1)=2-jt
64856 p(in1,2)=jt-1
64857 p(in1,3)=1d0
64858 740 CONTINUE
64859 750 CONTINUE
64860
64861C.. MOPS variables and switches
64862 nrvmo=0
64863 xbmo=1d0
64864 mstu(121)=0
64865 mstu(122)=0
64866
64867C...Initialize flavour and pT variables for open string.
64868 IF(ns.LT.nr) THEN
64869 px(1)=0d0
64870 py(1)=0d0
64871 IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL pyptdi(0,px(1),py(1))
64872 px(2)=-px(1)
64873 py(2)=-py(1)
64874 DO 760 jt=1,2
64875 kfl(jt)=k(ie(jt),2)
64876 IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)
64877 IF(mju(jt).NE.0.AND.iabs(kfl(jt)).GT.1000) ibarrk(jt)=1
64878 mstj(93)=1
64879 pmq(jt)=pymass(kfl(jt))
64880 gam(jt)=0d0
64881 760 CONTINUE
64882
64883C...Closed string: random initial breakup flavour, pT and vertex.
64884 ELSE
64885 kfl(3)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
64886 ibmo=0
64887 770 CALL pykfdi(kfl(3),0,kfl(1),kdump)
64888C.. Closed string: first vertex diq attempt => enforced second
64889C.. vertex diq
64890 IF(iabs(kfl(1)).GT.10)THEN
64891 ibmo=1
64892 mstu(121)=0
64893 GOTO 770
64894 ENDIF
64895 IF(ibmo.EQ.1) mstu(121)=-1
64896 kfl(2)=-kfl(1)
64897 CALL pyptdi(kfl(1),px(1),py(1))
64898 px(2)=-px(1)
64899 py(2)=-py(1)
64900 pr3=min(25d0,0.1d0*p(n+nr+1,5)**2)
64901 780 CALL pyzdis(kfl(1),kfl(2),pr3,z)
64902 zr=pr3/(z*p(n+nr+1,5)**2)
64903 IF(zr.GE.1d0) GOTO 780
64904 DO 790 jt=1,2
64905 mstj(93)=1
64906 pmq(jt)=pymass(kfl(jt))
64907 gam(jt)=pr3*(1d0-z)/z
64908 in1=n+nr+3+4*(jt/2)*(ns-1)
64909 p(in1,jt)=1d0-z
64910 p(in1,3-jt)=jt-1
64911 p(in1,3)=(2-jt)*(1d0-z)+(jt-1)*z
64912 p(in1+1,jt)=zr
64913 p(in1+1,3-jt)=2-jt
64914 p(in1+1,3)=(2-jt)*(1d0-zr)+(jt-1)*zr
64915 790 CONTINUE
64916 ENDIF
64917C.. MOPS variables
64918 DO 800 jt=1,2
64919 xtmo(jt)=1d0
64920 pm2qmo(jt)=pmq(jt)**2
64921 IF(iabs(kfl(jt)).GT.10) pm2qmo(jt)=0d0
64922 800 CONTINUE
64923
64924C...Find initial transverse directions (i.e. spacelike four-vectors).
64925 DO 840 jt=1,2
64926 IF(jt.EQ.1.OR.ns.EQ.nr-1.OR.mju(1)+mju(2).NE.0) THEN
64927 in1=in(3*jt+1)
64928 in3=in(3*jt+3)
64929 DO 810 j=1,4
64930 dp(1,j)=p(in1,j)
64931 dp(2,j)=p(in1+1,j)
64932 dp(3,j)=0d0
64933 dp(4,j)=0d0
64934 810 CONTINUE
64935 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
64936 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
64937 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
64938 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
64939 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
64940 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
64941 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
64942 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
64943 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
64944 dhc12=dfour(1,2)
64945 dhcx1=dfour(3,1)/dhc12
64946 dhcx2=dfour(3,2)/dhc12
64947 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
64948 dhcy1=dfour(4,1)/dhc12
64949 dhcy2=dfour(4,2)/dhc12
64950 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
64951 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
64952 DO 820 j=1,4
64953 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
64954 p(in3,j)=dp(3,j)
64955 p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
64956 & dhcyx*dp(3,j))
64957 820 CONTINUE
64958 ELSE
64959 DO 830 j=1,4
64960 p(in3+2,j)=p(in3,j)
64961 p(in3+3,j)=p(in3+1,j)
64962 830 CONTINUE
64963 ENDIF
64964 840 CONTINUE
64965
64966C...Remove energy used up in junction string fragmentation.
64967 IF(mju(1)+mju(2).GT.0) THEN
64968 DO 860 jt=1,2
64969 IF(njs(jt).EQ.0) GOTO 860
64970 DO 850 j=1,4
64971 p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)
64972 850 CONTINUE
64973 860 CONTINUE
64974 parjst=parj(33)
64975 IF(mstj(11).EQ.2) parjst=parj(34)
64976 wmin=parjst+pmq(1)+pmq(2)
64977 wrem2=four(n+nrs,n+nrs)
64978 IF(p(n+nrs,4).LT.0d0.OR.wrem2.LT.wmin**2) THEN
64979 ntrywr=ntrywr+1
64980 IF(mod(ntrywr,20).NE.0) ntryr=ntryr-1
64981 GOTO 140
64982 ENDIF
64983 ENDIF
64984
64985C...Produce new particle: side, origin.
64986 870 i=i+1
64987 IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN
64988 CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')
64989 IF(mstu(21).GE.1) RETURN
64990 ENDIF
64991C.. New side priority for popcorn systems
64992 IF(mstu(121).LE.0)THEN
64993 jt=1.5d0+pyr(0)
64994 IF(iabs(kfl(3-jt)).GT.10) jt=3-jt
64995 IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt
64996 ENDIF
64997 jr=3-jt
64998 js=3-2*jt
64999 irank(jt)=irank(jt)+1
65000 k(i,1)=1
65001 k(i,4)=0
65002 k(i,5)=0
65003
65004C...Generate flavour, hadron and pT.
65005 880 k(i,3)=ie(jt)
65006 CALL pykfdi(kfl(jt),0,kfl(3),k(i,2))
65007 IF(k(i,2).EQ.0) GOTO 710
65008 mu90mo=mstu(90)
65009 IF(mstu(121).EQ.-1) GOTO 910
65010 IF(irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.
65011 &iabs(kfl(3)).GT.10) THEN
65012 IF(pyr(0).GT.parj(19)) GOTO 880
65013 ENDIF
65014 IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
65015 &k(i,3)=ijuori(jt)
65016 p(i,5)=pymass(k(i,2))
65017 CALL pyptdi(kfl(jt),px(3),py(3))
65018 pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2
65019
65020C...Final hadrons for small invariant mass.
65021 mstj(93)=1
65022 pmq(3)=pymass(kfl(3))
65023 parjst=parj(33)
65024 IF(mstj(11).EQ.2) parjst=parj(34)
65025 wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)
65026 IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=
65027 &wmin-0.5d0*parj(36)*pmq(3)
65028 wrem2=four(n+nrs,n+nrs)
65029 IF(wrem2.LT.0.10d0) GOTO 710
65030 IF(wrem2.LT.max(wmin*(1d0+(2d0*pyr(0)-1d0)*parj(37)),
65031 &parj(32)+pmq(1)+pmq(2))**2) GOTO 1080
65032
65033C...Choose z, which gives Gamma. Shift z for heavy flavours.
65034 CALL pyzdis(kfl(jt),kfl(3),pr(jt),z)
65035 IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.
65036 &mstu(90).LT.8) THEN
65037 mstu(90)=mstu(90)+1
65038 mstu(90+mstu(90))=i
65039 paru(90+mstu(90))=z
65040 ENDIF
65041 kfl1a=iabs(kfl(1))
65042 kfl2a=iabs(kfl(2))
65043 IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
65044 &mod(kfl2a/1000,10)).GE.4) THEN
65045 pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
65046 pw12=sqrt(max(0d0,(wrem2-pr(1)-pr(2))**2-4d0*pr(1)*pr(2)))
65047 z=(wrem2+pr(jt)-pr(jr)+pw12*(2d0*z-1d0))/(2d0*wrem2)
65048 pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
65049 IF((1d0-z)*(wrem2-pr(jt)/z).LT.pr(jr)) GOTO 1080
65050 ENDIF
65051 gam(3)=(1d0-z)*(gam(jt)+pr(jt)/z)
65052
65053C.. MOPS baryon model modification
65054 xtmo3=(1d0-z)*xtmo(jt)
65055 IF(iabs(kfl(3)).LE.10) nrvmo=0
65056 IF(iabs(kfl(3)).GT.10.AND.mstj(12).GE.4) THEN
65057 gtstmo=1d0
65058 ptstmo=1d0
65059 rtstmo=pyr(0)
65060 IF(iabs(kfl(jt)).LE.10)THEN
65061 xbmo=min(xtmo3,1d0-(2d-10))
65062 gbmo=gam(3)
65063 pmmo=0d0
65064 pgmo=gbmo+log(1d0-xbmo)*pm2qmo(jt)
65065 gtstmo=1d0-parf(192)**pgmo
65066 ELSE
65067 IF(irank(jt).EQ.1) THEN
65068 gbmo=gam(jt)
65069 pmmo=0d0
65070 xbmo=1d0
65071 ENDIF
65072 IF(xbmo.LT.1d0-(1d-10))THEN
65073 pgnmo=gbmo*xtmo3/xbmo+pm2qmo(jt)*log(1d0-xtmo3)
65074 gtstmo=(1d0-parf(192)**pgnmo)/(1d0-parf(192)**pgmo)
65075 pgmo=pgnmo
65076 ENDIF
65077 IF(mstj(12).GE.5)THEN
65078 pmnmo=sqrt((xbmo-xtmo3)*(gam(3)/xtmo3-gbmo/xbmo))
65079 pmmo=pmmo+pmas(pycomp(k(i,2)),1)-pmas(pycomp(k(i,2)),3)
65080 ptstmo=exp((pmmo-pmnmo)*parf(193))
65081 pmmo=pmnmo
65082 ENDIF
65083 ENDIF
65084
65085C.. MOPS Accepting popcorn system hadron.
65086 IF(ptstmo*gtstmo.GT.rtstmo) THEN
65087 IF(irank(jt).EQ.1.OR.iabs(kfl(jt)).LE.10) THEN
65088 nrvmo=i-n-nr
65089 IF(i+nrvmo.GT.mstu(4)-mstu(32)-5) THEN
65090 CALL pyerrm(11,
65091 & '(PYSTRF:) no more memory left in PYJETS')
65092 IF(mstu(21).GE.1) RETURN
65093 ENDIF
65094 imo=i
65095 kflmo=kfl(jt)
65096 pmqmo=pmq(jt)
65097 pxmo=px(jt)
65098 pymo=py(jt)
65099 gammo=gam(jt)
65100 irmo=irank(jt)
65101 xmo=xtmo(jt)
65102 DO 900 j=1,9
65103 IF(j.LE.5) THEN
65104 DO 890 line=1,i-n-nr
65105 p(mstu(4)-mstu(32)-line,j)=p(n+nr+line,j)
65106 k(mstu(4)-mstu(32)-line,j)=k(n+nr+line,j)
65107 890 CONTINUE
65108 ENDIF
65109 inmo(j)=in(j)
65110 900 CONTINUE
65111 ENDIF
65112 ELSE
65113C..Reject popcorn system, flag=-1 if enforcing new one
65114 mstu(121)=-1
65115 IF(ptstmo.GT.rtstmo) mstu(121)=-2
65116 ENDIF
65117 ENDIF
65118
65119
65120C..Lift restoring string outside MOPS block
65121 910 IF(mstu(121).LT.0) THEN
65122 IF(mstu(121).EQ.-2) mstu(121)=0
65123 mstu(90)=mu90mo
65124 nrvmo=0
65125 IF(irank(jt).EQ.1.OR.iabs(kfl(jt)).LE.10) GOTO 880
65126 i=imo
65127 kfl(jt)=kflmo
65128 pmq(jt)=pmqmo
65129 px(jt)=pxmo
65130 py(jt)=pymo
65131 gam(jt)=gammo
65132 irank(jt)=irmo
65133 xtmo(jt)=xmo
65134 DO 930 j=1,9
65135 IF(j.LE.5) THEN
65136 DO 920 line=1,i-n-nr
65137 p(n+nr+line,j)=p(mstu(4)-mstu(32)-line,j)
65138 k(n+nr+line,j)=k(mstu(4)-mstu(32)-line,j)
65139 920 CONTINUE
65140 ENDIF
65141 in(j)=inmo(j)
65142 930 CONTINUE
65143 GOTO 880
65144 ENDIF
65145 xtmo(jt)=xtmo3
65146C.. MOPS end of modification
65147
65148 DO 940 j=1,3
65149 in(j)=in(3*jt+j)
65150 940 CONTINUE
65151
65152C...Stepping within or from 'low' string region easy.
65153 IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*
65154 &p(in(1),5)**2.GE.pr(jt)) THEN
65155 p(in(jt)+2,4)=z*p(in(jt)+2,3)
65156 p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)
65157 DO 950 j=1,4
65158 p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)
65159 950 CONTINUE
65160 GOTO 1040
65161 ELSEIF(in(1)+1.EQ.in(2)) THEN
65162 p(in(jr)+2,4)=p(in(jr)+2,3)
65163 p(in(jr)+2,jt)=1d0
65164 in(jr)=in(jr)+4*js
65165 IF(js*in(jr).GT.js*in(4*jr)) GOTO 710
65166 IF(four(in(1),in(2)).LE.1d-2) THEN
65167 p(in(jt)+2,4)=p(in(jt)+2,3)
65168 p(in(jt)+2,jt)=0d0
65169 in(jt)=in(jt)+4*js
65170 ENDIF
65171 ENDIF
65172
65173C...Find new transverse directions (i.e. spacelike string vectors).
65174 960 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.
65175 &in(1).GT.in(2)) GOTO 710
65176 IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN
65177 DO 970 j=1,4
65178 dp(1,j)=p(in(1),j)
65179 dp(2,j)=p(in(2),j)
65180 dp(3,j)=0d0
65181 dp(4,j)=0d0
65182 970 CONTINUE
65183 dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)
65184 dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)
65185 dhc12=dfour(1,2)
65186 IF(dhc12.LE.1d-2) THEN
65187 p(in(jt)+2,4)=p(in(jt)+2,3)
65188 p(in(jt)+2,jt)=0d0
65189 in(jt)=in(jt)+4*js
65190 GOTO 960
65191 ENDIF
65192 in(3)=n+nr+4*ns+5
65193 dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)
65194 dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)
65195 dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)
65196 IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0
65197 IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0
65198 IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0
65199 IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0
65200 dhcx1=dfour(3,1)/dhc12
65201 dhcx2=dfour(3,2)/dhc12
65202 dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)
65203 dhcy1=dfour(4,1)/dhc12
65204 dhcy2=dfour(4,2)/dhc12
65205 dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12
65206 dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)
65207 DO 980 j=1,4
65208 dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))
65209 p(in(3),j)=dp(3,j)
65210 p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-
65211 & dhcyx*dp(3,j))
65212 980 CONTINUE
65213C...Express pT with respect to new axes, if sensible.
65214 pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*
65215 & four(in(3*jt+3)+1,in(3)))
65216 pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*
65217 & four(in(3*jt+3)+1,in(3)+1))
65218 IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN
65219 px(3)=pxp
65220 py(3)=pyp
65221 ENDIF
65222 ENDIF
65223
65224C...Sum up known four-momentum. Gives coefficients for m2 expression.
65225 DO 1010 j=1,4
65226 dhg(j)=0d0
65227 p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+
65228 & px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)
65229 DO 990 in1=in(3*jt+1),in(1)-4*js,4*js
65230 p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)
65231 990 CONTINUE
65232 DO 1000 in2=in(3*jt+2),in(2)-4*js,4*js
65233 p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)
65234 1000 CONTINUE
65235 1010 CONTINUE
65236 dhm(1)=four(i,i)
65237 dhm(2)=2d0*four(i,in(1))
65238 dhm(3)=2d0*four(i,in(2))
65239 dhm(4)=2d0*four(in(1),in(2))
65240
65241C...Find coefficients for Gamma expression.
65242 DO 1030 in2=in(1)+1,in(2),4
65243 DO 1020 in1=in(1),in2-1,4
65244 dhc=2d0*four(in1,in2)
65245 dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc
65246 IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc
65247 IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc
65248 IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc
65249 1020 CONTINUE
65250 1030 CONTINUE
65251
65252C...Solve (m2, Gamma) equation system for energies taken.
65253 dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)
65254 IF(abs(dhs1).LT.1d-4) GOTO 710
65255 dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*
65256 &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)
65257 dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))
65258 p(in(jr)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/
65259 &abs(dhs1)-dhs2/dhs1)
65260 IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0d0) GOTO 710
65261 p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/
65262 &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))
65263
65264C...Step to new region if necessary.
65265 IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN
65266 p(in(jr)+2,4)=p(in(jr)+2,3)
65267 p(in(jr)+2,jt)=1d0
65268 in(jr)=in(jr)+4*js
65269 IF(js*in(jr).GT.js*in(4*jr)) GOTO 710
65270 IF(four(in(1),in(2)).LE.1d-2) THEN
65271 p(in(jt)+2,4)=p(in(jt)+2,3)
65272 p(in(jt)+2,jt)=0d0
65273 in(jt)=in(jt)+4*js
65274 ENDIF
65275 GOTO 960
65276 ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN
65277 p(in(jt)+2,4)=p(in(jt)+2,3)
65278 p(in(jt)+2,jt)=0d0
65279 in(jt)=in(jt)+4*js
65280 GOTO 960
65281 ENDIF
65282
65283C...Four-momentum of particle. Remaining quantities. Loop back.
65284 1040 DO 1050 j=1,4
65285 p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)
65286 p(n+nrs,j)=p(n+nrs,j)-p(i,j)
65287 1050 CONTINUE
65288 IF(p(in(1)+2,4).GT.1d0+paru(14).OR.p(in(1)+2,4).LT.-paru(14).OR.
65289 &p(in(2)+2,4).GT.1d0+paru(14).OR.p(in(2)+2,4).LT.-paru(14))
65290 &GOTO 200
65291 IF(p(i,4).LT.p(i,5)) GOTO 710
65292 kfl(jt)=-kfl(3)
65293 pmq(jt)=pmq(3)
65294 px(jt)=-px(3)
65295 py(jt)=-py(3)
65296 gam(jt)=gam(3)
65297 IF(in(3).NE.in(3*jt+3)) THEN
65298 DO 1060 j=1,4
65299 p(in(3*jt+3),j)=p(in(3),j)
65300 p(in(3*jt+3)+1,j)=p(in(3)+1,j)
65301 1060 CONTINUE
65302 ENDIF
65303 DO 1070 jq=1,2
65304 in(3*jt+jq)=in(jq)
65305 p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)
65306 p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)
65307 1070 CONTINUE
65308 IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
65309 &ibarrk(jt)=0
65310 GOTO 870
65311
65312C...Final hadron: side, flavour, hadron, mass.
65313 1080 i=i+1
65314 k(i,1)=1
65315 k(i,3)=ie(jr)
65316 k(i,4)=0
65317 k(i,5)=0
65318 CALL pykfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))
65319 IF(k(i,2).EQ.0) GOTO 710
65320 IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i-1,2)),10000).GT.1000)
65321 &ibarrk(jt)=0
65322 IF(ibarrk(jt).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
65323 &k(i,3)=ijuori(jt)
65324 IF(ibarrk(jr).EQ.1.AND.mod(iabs(k(i,2)),10000).GT.1000)
65325 &k(i,3)=ijuori(jr)
65326 p(i,5)=pymass(k(i,2))
65327 pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2
65328
65329C...Final two hadrons: find common setup of four-vectors.
65330 jq=1
65331 IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.
65332 &p(in(7)+2,3)*p(in(8)+2,3)*four(in(7),in(8))) jq=2
65333 dhc12=four(in(3*jq+1),in(3*jq+2))
65334 dhr1=four(n+nrs,in(3*jq+2))/dhc12
65335 dhr2=four(n+nrs,in(3*jq+1))/dhc12
65336 IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN
65337 px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)
65338 py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)
65339 pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*
65340 & px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2
65341 ENDIF
65342
65343C...Solve kinematics for final two hadrons, if possible.
65344 wrem2=2d0*dhr1*dhr2*dhc12
65345 fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)
65346 IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1d0) GOTO 200
65347 IF(fd.GE.1d0) GOTO 710
65348 fa=wrem2+pr(jt)-pr(jr)
65349 fb=sqrt(max(0d0,fa**2-4d0*wrem2*pr(jt)))
65350 prevcf=parj(42)
65351 IF(mstj(11).EQ.2) prevcf=parj(39)
65352 prev=1d0/(1d0+exp(min(50d0,prevcf*fb*parj(40))))
65353 fb=sign(fb,js*(pyr(0)-prev))
65354 kfl1a=iabs(kfl(1))
65355 kfl2a=iabs(kfl(2))
65356 IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),
65357 &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0d0,fa**2-
65358 &4d0*wrem2*pr(jt))),dble(js))
65359 DO 1090 j=1,4
65360 p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*
65361 & p(in(3*jq+3)+1,j)+0.5d0*(dhr1*(fa+fb)*p(in(3*jq+1),j)+
65362 & dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2
65363 p(i,j)=p(n+nrs,j)-p(i-1,j)
65364 1090 CONTINUE
65365 IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) GOTO 710
65366 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
65367 dm2f2=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2
65368 IF(dm2f1.GT.1d-10*p(i-1,4)**2.OR.dm2f2.GT.1d-10*p(i,4)**2) THEN
65369 ntryfn=ntryfn+1
65370 IF(ntryfn.LT.100) GOTO 140
65371 CALL pyerrm(13,'(PYSTRF:) bad energies for final two hadrons')
65372 ENDIF
65373
65374C...Mark jets as fragmented and give daughter pointers.
65375 n=i-nrs+1
65376 DO 1100 i=nsav+1,nsav+np
65377 im=k(i,3)
65378 k(im,1)=k(im,1)+10
65379 IF(mstu(16).NE.2) THEN
65380 k(im,4)=nsav+1
65381 k(im,5)=nsav+1
65382 ELSE
65383 k(im,4)=nsav+2
65384 k(im,5)=n
65385 ENDIF
65386 1100 CONTINUE
65387
65388C...Document string system. Move up particles.
65389 nsav=nsav+1
65390 k(nsav,1)=11
65391 k(nsav,2)=92
65392 k(nsav,3)=ip
65393 k(nsav,4)=nsav+1
65394 k(nsav,5)=n
65395 DO 1110 j=1,4
65396 p(nsav,j)=dps(j)
65397 v(nsav,j)=v(ip,j)
65398 1110 CONTINUE
65399 p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
65400 v(nsav,5)=0d0
65401 DO 1130 i=nsav+1,n
65402 DO 1120 j=1,5
65403 k(i,j)=k(i+nrs-1,j)
65404 p(i,j)=p(i+nrs-1,j)
65405 v(i,j)=0d0
65406 1120 CONTINUE
65407 1130 CONTINUE
65408 mstu91=mstu(90)
65409 DO 1140 iz=mstu90+1,mstu91
65410 mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n
65411 paru9t(iz)=paru(90+iz)
65412 1140 CONTINUE
65413 mstu(90)=mstu90
65414
65415C...Order particles in rank along the chain. Update mother pointer.
65416 DO 1160 i=nsav+1,n
65417 DO 1150 j=1,5
65418 k(i-nsav+n,j)=k(i,j)
65419 p(i-nsav+n,j)=p(i,j)
65420 1150 CONTINUE
65421 1160 CONTINUE
65422 i1=nsav
65423 DO 1190 i=n+1,2*n-nsav
65424 IF(k(i,3).NE.ie(1).AND.k(i,3).NE.ijuori(1)) GOTO 1190
65425 i1=i1+1
65426 DO 1170 j=1,5
65427 k(i1,j)=k(i,j)
65428 p(i1,j)=p(i,j)
65429 1170 CONTINUE
65430 IF(mstu(16).NE.2) k(i1,3)=nsav
65431 DO 1180 iz=mstu90+1,mstu91
65432 IF(mstu9t(iz).EQ.i) THEN
65433 mstu(90)=mstu(90)+1
65434 mstu(90+mstu(90))=i1
65435 paru(90+mstu(90))=paru9t(iz)
65436 ENDIF
65437 1180 CONTINUE
65438 1190 CONTINUE
65439 DO 1220 i=2*n-nsav,n+1,-1
65440 IF(k(i,3).EQ.ie(1).OR.k(i,3).EQ.ijuori(1)) GOTO 1220
65441 i1=i1+1
65442 DO 1200 j=1,5
65443 k(i1,j)=k(i,j)
65444 p(i1,j)=p(i,j)
65445 1200 CONTINUE
65446 IF(mstu(16).NE.2) k(i1,3)=nsav
65447 DO 1210 iz=mstu90+1,mstu91
65448 IF(mstu9t(iz).EQ.i) THEN
65449 mstu(90)=mstu(90)+1
65450 mstu(90+mstu(90))=i1
65451 paru(90+mstu(90))=paru9t(iz)
65452 ENDIF
65453 1210 CONTINUE
65454 1220 CONTINUE
65455
65456C...Boost back particle system. Set production vertices.
65457 IF(mbst.EQ.0) THEN
65458 mstu(33)=1
65459 CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),
65460 & dps(3)/dps(4))
65461 ELSE
65462 DO 1230 i=nsav+1,n
65463 hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2
65464 IF(p(i,3).GT.0d0) THEN
65465 hhpez=(p(i,4)+p(i,3))*hhbz
65466 p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)
65467 p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
65468 ELSE
65469 hhpez=(p(i,4)-p(i,3))/hhbz
65470 p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)
65471 p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)
65472 ENDIF
65473 1230 CONTINUE
65474 ENDIF
65475 DO 1250 i=nsav+1,n
65476 DO 1240 j=1,4
65477 v(i,j)=v(ip,j)
65478 1240 CONTINUE
65479 1250 CONTINUE
65480
65481 RETURN
65482 END
65483
65484C*********************************************************************
65485
65486C...PYJURF
65487C...From three given input vectors in PJU the boost VJU from
65488C...the "lab frame" to the junction rest frame is constructed.
65489
65490 SUBROUTINE pyjurf(PJU,VJU)
65491
65492C...Double precision and integer declarations.
65493 IMPLICIT DOUBLE PRECISION(a-h, o-z)
65494 IMPLICIT INTEGER(I-N)
65495
65496C...Input, output and local arrays.
65497 dimension pju(3,5),vju(5),psum(5),a(3,3),penew(3),pcm(5,5)
65498 DATA twopi/6.283186d0/
65499
65500C...Calculate masses and other invariants.
65501 DO 100 j=1,4
65502 psum(j)=pju(1,j)+pju(2,j)+pju(3,j)
65503 100 CONTINUE
65504 psum2=psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2
65505 psum(5)=sqrt(psum2)
65506 DO 120 i=1,3
65507 DO 110 j=1,3
65508 a(i,j)=pju(i,4)*pju(j,4)-pju(i,1)*pju(j,1)-
65509 & pju(i,2)*pju(j,2)-pju(i,3)*pju(j,3)
65510 110 CONTINUE
65511 120 CONTINUE
65512
65513C...Pick I to be most massive parton and J to be the one closest to I.
65514 itry=0
65515 i=1
65516 IF(a(2,2).GT.a(1,1)) i=2
65517 IF(a(3,3).GT.max(a(1,1),a(2,2))) i=3
65518 130 itry=itry+1
65519 j=1+mod(i,3)
65520 k=1+mod(j,3)
65521 IF(a(i,k)**2*a(j,j).LT.a(i,j)**2*a(k,k)) THEN
65522 k=1+mod(i,3)
65523 j=1+mod(k,3)
65524 ENDIF
65525 pmi2=a(i,i)
65526 pmj2=a(j,j)
65527 pmk2=a(k,k)
65528 aij=a(i,j)
65529 aik=a(i,k)
65530 ajk=a(j,k)
65531
65532C...Trivial find new parton energies if all three partons are massless.
65533 IF(pmi2.LT.1d-4) THEN
65534 pei=sqrt(2d0*aik*aij/(3d0*ajk))
65535 pej=sqrt(2d0*ajk*aij/(3d0*aik))
65536 pek=sqrt(2d0*aik*ajk/(3d0*aij))
65537
65538C...Else find momentum range for parton I and values at extremes.
65539 ELSE
65540 paimin=0d0
65541 peimin=sqrt(pmi2)
65542 pejmin=aij/peimin
65543 pekmin=aik/peimin
65544 pajmin=sqrt(max(0d0,pejmin**2-pmj2))
65545 pakmin=sqrt(max(0d0,pekmin**2-pmk2))
65546 fmin=pejmin*pekmin+0.5d0*pajmin*pakmin-ajk
65547 peimax=(aij+aik)/sqrt(pmj2+pmk2+2d0*ajk)
65548 IF(pmj2.GT.1d-4) peimax=aij/sqrt(pmj2)
65549 paimax=sqrt(max(0d0,peimax**2-pmi2))
65550 hi=peimax**2-0.25d0*paimax**2
65551 pajmax=(peimax*sqrt(max(0d0,aij**2-pmj2*hi))-
65552 & 0.5d0*paimax*aij)/hi
65553 pakmax=(peimax*sqrt(max(0d0,aik**2-pmk2*hi))-
65554 & 0.5d0*paimax*aik)/hi
65555 pejmax=sqrt(pajmax**2+pmj2)
65556 pekmax=sqrt(pakmax**2+pmk2)
65557 fmax=pejmax*pekmax+0.5d0*pajmax*pakmax-ajk
65558
65559C...If unexpected values at upper endpoint then pick another parton.
65560 IF(fmax.GT.0d0.AND.itry.LE.2) THEN
65561 i1=1+mod(i,3)
65562 IF(a(i1,i1).GE.1d-4) THEN
65563 i=i1
65564 GOTO 130
65565 ENDIF
65566 itry=itry+1
65567 i1=1+mod(i,3)
65568 IF(itry.LE.2.AND.a(i1,i1).GE.1d-4) THEN
65569 i=i1
65570 GOTO 130
65571 ENDIF
65572 ENDIF
65573
65574C..Start binary + linear search to find solution inside range.
65575 iter=0
65576 itmin=0
65577 itmax=0
65578 pai=0.5d0*(paimin+paimax)
65579 140 iter=iter+1
65580
65581C...Derive momentum of other two partons and distance to root.
65582 pei=sqrt(pai**2+pmi2)
65583 hi=pei**2-0.25d0*pai**2
65584 paj=(pei*sqrt(max(0d0,aij**2-pmj2*hi))-0.5d0*pai*aij)/hi
65585 pej=sqrt(paj**2+pmj2)
65586 pak=(pei*sqrt(max(0d0,aik**2-pmk2*hi))-0.5d0*pai*aik)/hi
65587 pek=sqrt(pak**2+pmk2)
65588 fnow=pej*pek+0.5d0*paj*pak-ajk
65589
65590C...Pick next I momentum to explore, hopefully closer to root.
65591 IF(fnow.GT.0d0) THEN
65592 paimin=pai
65593 fmin=fnow
65594 itmin=itmin+1
65595 ELSE
65596 paimax=pai
65597 fmax=fnow
65598 itmax=itmax+1
65599 ENDIF
65600 IF((iter.LT.10.OR.itmin.LE.1.OR.itmax.LE.1).AND.iter.LT.20)
65601 & THEN
65602 pai=0.5d0*(paimin+paimax)
65603 GOTO 140
65604 ELSEIF(iter.LT.40.AND.fmin.GT.0d0.AND.fmax.LT.0d0.AND.
65605 & abs(fnow).GT.1d-12*psum2) THEN
65606 pai=paimin+(paimax-paimin)*fmin/(fmin-fmax)
65607 GOTO 140
65608 ENDIF
65609 ENDIF
65610
65611C...Now know energies in junction rest frame.
65612 penew(i)=pei
65613 penew(j)=pej
65614 penew(k)=pek
65615
65616C...Boost (copy of) partons to their rest frame.
65617 vxcm=-psum(1)/psum(5)
65618 vycm=-psum(2)/psum(5)
65619 vzcm=-psum(3)/psum(5)
65620 gamcm=sqrt(1d0+vxcm**2+vycm**2+vzcm**2)
65621 DO 150 i=1,3
65622 fac1=pju(i,1)*vxcm+pju(i,2)*vycm+pju(i,3)*vzcm
65623 fac2=fac1/(1d0+gamcm)+pju(i,4)
65624 pcm(i,1)=pju(i,1)+fac2*vxcm
65625 pcm(i,2)=pju(i,2)+fac2*vycm
65626 pcm(i,3)=pju(i,3)+fac2*vzcm
65627 pcm(i,4)=pju(i,4)*gamcm+fac1
65628 pcm(i,5)=sqrt(pcm(i,1)**2+pcm(i,2)**2+pcm(i,3)**2)
65629 150 CONTINUE
65630
65631C...Construct difference vectors and boost to junction rest frame.
65632 DO 160 j=1,3
65633 pcm(4,j)=pcm(1,j)/pcm(1,4)-pcm(2,j)/pcm(2,4)
65634 pcm(5,j)=pcm(1,j)/pcm(1,4)-pcm(3,j)/pcm(3,4)
65635 160 CONTINUE
65636 pcm(4,4)=penew(1)/pcm(1,4)-penew(2)/pcm(2,4)
65637 pcm(5,4)=penew(1)/pcm(1,4)-penew(3)/pcm(3,4)
65638 pcm4s=pcm(4,1)**2+pcm(4,2)**2+pcm(4,3)**2
65639 pcm5s=pcm(5,1)**2+pcm(5,2)**2+pcm(5,3)**2
65640 pcm45=pcm(4,1)*pcm(5,1)+pcm(4,2)*pcm(5,2)+pcm(4,3)*pcm(5,3)
65641 c4=(pcm5s*pcm(4,4)-pcm45*pcm(5,4))/(pcm4s*pcm5s-pcm45**2)
65642 c5=(pcm4s*pcm(5,4)-pcm45*pcm(4,4))/(pcm4s*pcm5s-pcm45**2)
65643 vxju=c4*pcm(4,1)+c5*pcm(5,1)
65644 vyju=c4*pcm(4,2)+c5*pcm(5,2)
65645 vzju=c4*pcm(4,3)+c5*pcm(5,3)
65646 gamju=sqrt(1d0+vxju**2+vyju**2+vzju**2)
65647
65648C...Add two boosts, giving final result.
65649 fcm=(vxju*vxcm+vyju*vycm+vzju*vzcm)/(1+gamcm)+gamju
65650 vju(1)=vxju+fcm*vxcm
65651 vju(2)=vyju+fcm*vycm
65652 vju(3)=vzju+fcm*vzcm
65653 vju(4)=sqrt(1d0+vju(1)**2+vju(2)**2+vju(3)**2)
65654 vju(5)=1d0
65655
65656C...In case of error in reconstruction: revert to CM frame of system.
65657 cth12=(pcm(1,1)*pcm(2,1)+pcm(1,2)*pcm(2,2)+pcm(1,3)*pcm(2,3))/
65658 &(pcm(1,5)*pcm(2,5))
65659 cth13=(pcm(1,1)*pcm(3,1)+pcm(1,2)*pcm(3,2)+pcm(1,3)*pcm(3,3))/
65660 &(pcm(1,5)*pcm(3,5))
65661 cth23=(pcm(2,1)*pcm(3,1)+pcm(2,2)*pcm(3,2)+pcm(2,3)*pcm(3,3))/
65662 &(pcm(2,5)*pcm(3,5))
65663 errccm=(cth12+0.5d0)**2+(cth13+0.5d0)**2+(cth23+0.5d0)**2
65664 errtcm=twopi-acos(cth12)-acos(cth13)-acos(cth23)
65665 DO 170 i=1,3
65666 fac1=pju(i,1)*vju(1)+pju(i,2)*vju(2)+pju(i,3)*vju(3)
65667 fac2=fac1/(1d0+vju(4))+pju(i,4)
65668 pcm(i,1)=pju(i,1)+fac2*vju(1)
65669 pcm(i,2)=pju(i,2)+fac2*vju(2)
65670 pcm(i,3)=pju(i,3)+fac2*vju(3)
65671 pcm(i,4)=pju(i,4)*vju(4)+fac1
65672 pcm(i,5)=sqrt(pcm(i,1)**2+pcm(i,2)**2+pcm(i,3)**2)
65673 170 CONTINUE
65674 cth12=(pcm(1,1)*pcm(2,1)+pcm(1,2)*pcm(2,2)+pcm(1,3)*pcm(2,3))/
65675 &(pcm(1,5)*pcm(2,5))
65676 cth13=(pcm(1,1)*pcm(3,1)+pcm(1,2)*pcm(3,2)+pcm(1,3)*pcm(3,3))/
65677 &(pcm(1,5)*pcm(3,5))
65678 cth23=(pcm(2,1)*pcm(3,1)+pcm(2,2)*pcm(3,2)+pcm(2,3)*pcm(3,3))/
65679 &(pcm(2,5)*pcm(3,5))
65680 errcju=(cth12+0.5d0)**2+(cth13+0.5d0)**2+(cth23+0.5d0)**2
65681 errtju=twopi-acos(cth12)-acos(cth13)-acos(cth23)
65682 IF(errcju+errtju.GT.errccm+errtcm) THEN
65683 vju(1)=vxcm
65684 vju(2)=vycm
65685 vju(3)=vzcm
65686 vju(4)=gamcm
65687 ENDIF
65688
65689 RETURN
65690 END
65691
65692C*********************************************************************
65693
65694C...PYINDF
65695C...Handles the fragmentation of a jet system (or a single
65696C...jet) according to independent fragmentation models.
65697
65698 SUBROUTINE pyindf(IP)
65699
65700C...Double precision and integer declarations.
65701 IMPLICIT DOUBLE PRECISION(a-h, o-z)
65702 IMPLICIT INTEGER(I-N)
65703 INTEGER PYK,PYCHGE,PYCOMP
65704C...Commonblocks.
65705 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
65706 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
65707 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
65708 SAVE /pyjets/,/pydat1/,/pydat2/
65709C...Local arrays.
65710 dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),
65711 &kflo(2),pxo(2),pyo(2),wo(2)
65712
65713C.. MOPS error message
65714 IF(mstj(12).GT.3) CALL pyerrm(9,'(PYINDF:) MSTJ(12)>3 options'//
65715 &' are not treated as expected in independent fragmentation')
65716
65717C...Reset counters. Identify parton system and take copy. Check flavour.
65718 nsav=n
65719 mstu90=mstu(90)
65720 njet=0
65721 kqsum=0
65722 DO 100 j=1,5
65723 dps(j)=0d0
65724 100 CONTINUE
65725 i=ip-1
65726 110 i=i+1
65727 IF(i.GT.min(n,mstu(4)-mstu(32))) THEN
65728 CALL pyerrm(12,'(PYINDF:) failed to reconstruct jet system')
65729 IF(mstu(21).GE.1) RETURN
65730 ENDIF
65731 IF(k(i,1).NE.1.AND.k(i,1).NE.2) GOTO 110
65732 kc=pycomp(k(i,2))
65733 IF(kc.EQ.0) GOTO 110
65734 kq=kchg(kc,2)*isign(1,k(i,2))
65735 IF(kq.EQ.0) GOTO 110
65736 njet=njet+1
65737 IF(kq.NE.2) kqsum=kqsum+kq
65738 DO 120 j=1,5
65739 k(nsav+njet,j)=k(i,j)
65740 p(nsav+njet,j)=p(i,j)
65741 dps(j)=dps(j)+p(i,j)
65742 120 CONTINUE
65743 k(nsav+njet,3)=i
65744 IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.
65745 &k(i+1,1).EQ.2)) GOTO 110
65746 IF(njet.NE.1.AND.kqsum.NE.0) THEN
65747 CALL pyerrm(12,'(PYINDF:) unphysical flavour combination')
65748 IF(mstu(21).GE.1) RETURN
65749 ENDIF
65750
65751C...Boost copied system to CM frame. Find CM energy and sum flavours.
65752 IF(njet.NE.1) THEN
65753 mstu(33)=1
65754 CALL pyrobo(nsav+1,nsav+njet,0d0,0d0,-dps(1)/dps(4),
65755 & -dps(2)/dps(4),-dps(3)/dps(4))
65756 ENDIF
65757 pecm=0d0
65758 DO 130 j=1,3
65759 nfi(j)=0
65760 130 CONTINUE
65761 DO 140 i=nsav+1,nsav+njet
65762 pecm=pecm+p(i,4)
65763 kfa=iabs(k(i,2))
65764 IF(kfa.LE.3) THEN
65765 nfi(kfa)=nfi(kfa)+isign(1,k(i,2))
65766 ELSEIF(kfa.GT.1000) THEN
65767 kfla=mod(kfa/1000,10)
65768 kflb=mod(kfa/100,10)
65769 IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))
65770 IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))
65771 ENDIF
65772 140 CONTINUE
65773
65774C...Loop over attempts made. Reset counters.
65775 ntry=0
65776 150 ntry=ntry+1
65777 IF(ntry.GT.200) THEN
65778 CALL pyerrm(14,'(PYINDF:) caught in infinite loop')
65779 IF(mstu(21).GE.1) RETURN
65780 ENDIF
65781 n=nsav+njet
65782 mstu(90)=mstu90
65783 DO 160 j=1,3
65784 nfl(j)=nfi(j)
65785 ifet(j)=0
65786 kflf(j)=0
65787 160 CONTINUE
65788
65789C...Loop over jets to be fragmented.
65790 DO 230 ip1=nsav+1,nsav+njet
65791 mstj(91)=0
65792 nsav1=n
65793 mstu91=mstu(90)
65794
65795C...Initial flavour and momentum values. Jet along +z axis.
65796 kflh=iabs(k(ip1,2))
65797 IF(kflh.GT.10) kflh=mod(kflh/1000,10)
65798 kflo(2)=0
65799 wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)
65800
65801C...Initial values for quark or diquark jet.
65802 170 IF(iabs(k(ip1,2)).NE.21) THEN
65803 nstr=1
65804 kflo(1)=k(ip1,2)
65805 CALL pyptdi(0,pxo(1),pyo(1))
65806 wo(1)=wf
65807
65808C...Initial values for gluon treated like random quark jet.
65809 ELSEIF(mstj(2).LE.2) THEN
65810 nstr=1
65811 IF(mstj(2).EQ.2) mstj(91)=1
65812 kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
65813 CALL pyptdi(0,pxo(1),pyo(1))
65814 wo(1)=wf
65815
65816C...Initial values for gluon treated like quark-antiquark jet pair,
65817C...sharing energy according to Altarelli-Parisi splitting function.
65818 ELSE
65819 nstr=2
65820 IF(mstj(2).EQ.4) mstj(91)=1
65821 kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)
65822 kflo(2)=-kflo(1)
65823 CALL pyptdi(0,pxo(1),pyo(1))
65824 pxo(2)=-pxo(1)
65825 pyo(2)=-pyo(1)
65826 wo(1)=wf*pyr(0)**(1d0/3d0)
65827 wo(2)=wf-wo(1)
65828 ENDIF
65829
65830C...Initial values for rank, flavour, pT and W+.
65831 DO 220 istr=1,nstr
65832 180 i=n
65833 mstu(90)=mstu91
65834 irank=0
65835 kfl1=kflo(istr)
65836 px1=pxo(istr)
65837 py1=pyo(istr)
65838 w=wo(istr)
65839
65840C...New hadron. Generate flavour and hadron species.
65841 190 i=i+1
65842 IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN
65843 CALL pyerrm(11,'(PYINDF:) no more memory left in PYJETS')
65844 IF(mstu(21).GE.1) RETURN
65845 ENDIF
65846 irank=irank+1
65847 k(i,1)=1
65848 k(i,3)=ip1
65849 k(i,4)=0
65850 k(i,5)=0
65851 200 CALL pykfdi(kfl1,0,kfl2,k(i,2))
65852 IF(k(i,2).EQ.0) GOTO 180
65853 IF(irank.EQ.1.AND.iabs(kfl1).LE.10.AND.iabs(kfl2).GT.10) THEN
65854 IF(pyr(0).GT.parj(19)) GOTO 200
65855 ENDIF
65856
65857C...Find hadron mass. Generate four-momentum.
65858 p(i,5)=pymass(k(i,2))
65859 CALL pyptdi(kfl1,px2,py2)
65860 p(i,1)=px1+px2
65861 p(i,2)=py1+py2
65862 pr=p(i,5)**2+p(i,1)**2+p(i,2)**2
65863 CALL pyzdis(kfl1,kfl2,pr,z)
65864 mzsav=0
65865 IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN
65866 mzsav=1
65867 mstu(90)=mstu(90)+1
65868 mstu(90+mstu(90))=i
65869 paru(90+mstu(90))=z
65870 ENDIF
65871 p(i,3)=0.5d0*(z*w-pr/max(1d-4,z*w))
65872 p(i,4)=0.5d0*(z*w+pr/max(1d-4,z*w))
65873 IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.
65874 & p(i,3).LE.0.001d0) THEN
65875 IF(w.GE.p(i,5)+0.5d0*parj(32)) GOTO 180
65876 p(i,3)=0.0001d0
65877 p(i,4)=sqrt(pr)
65878 z=p(i,4)/w
65879 ENDIF
65880
65881C...Remaining flavour and momentum.
65882 kfl1=-kfl2
65883 px1=-px2
65884 py1=-py2
65885 w=(1d0-z)*w
65886 DO 210 j=1,5
65887 v(i,j)=0d0
65888 210 CONTINUE
65889
65890C...Check if pL acceptable. Go back for new hadron if enough energy.
65891 IF(mstj(3).GE.0.AND.p(i,3).LT.0d0) THEN
65892 i=i-1
65893 IF(mzsav.EQ.1) mstu(90)=mstu(90)-1
65894 ENDIF
65895 IF(w.GT.parj(31)) GOTO 190
65896 n=i
65897 220 CONTINUE
65898 IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1d0*parj(32)
65899 IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) GOTO 170
65900
65901C...Rotate jet to new direction.
65902 the=pyangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))
65903 phi=pyangl(p(ip1,1),p(ip1,2))
65904 mstu(33)=1
65905 CALL pyrobo(nsav1+1,n,the,phi,0d0,0d0,0d0)
65906 k(k(ip1,3),4)=nsav1+1
65907 k(k(ip1,3),5)=n
65908
65909C...End of jet generation loop. Skip conservation in some cases.
65910 230 CONTINUE
65911 IF(njet.EQ.1.OR.mstj(3).LE.0) GOTO 490
65912 IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) GOTO 150
65913
65914C...Subtract off produced hadron flavours, finished if zero.
65915 DO 240 i=nsav+njet+1,n
65916 kfa=iabs(k(i,2))
65917 kfla=mod(kfa/1000,10)
65918 kflb=mod(kfa/100,10)
65919 kflc=mod(kfa/10,10)
65920 IF(kfla.EQ.0) THEN
65921 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb
65922 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb
65923 ELSE
65924 IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))
65925 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))
65926 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))
65927 ENDIF
65928 240 CONTINUE
65929 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
65930 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
65931 IF(nreq.EQ.0) GOTO 320
65932
65933C...Take away flavour of low-momentum particles until enough freedom.
65934 nrem=0
65935 250 irem=0
65936 p2min=pecm**2
65937 DO 260 i=nsav+njet+1,n
65938 p2=p(i,1)**2+p(i,2)**2+p(i,3)**2
65939 IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i
65940 IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2
65941 260 CONTINUE
65942 IF(irem.EQ.0) GOTO 150
65943 k(irem,1)=7
65944 kfa=iabs(k(irem,2))
65945 kfla=mod(kfa/1000,10)
65946 kflb=mod(kfa/100,10)
65947 kflc=mod(kfa/10,10)
65948 IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8
65949 IF(k(irem,1).EQ.8) GOTO 250
65950 IF(kfla.EQ.0) THEN
65951 isgn=isign(1,k(irem,2))*(-1)**kflb
65952 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn
65953 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn
65954 ELSE
65955 IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))
65956 IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))
65957 IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))
65958 ENDIF
65959 nrem=nrem+1
65960 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
65961 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
65962 IF(nreq.GT.nrem) GOTO 250
65963 DO 270 i=nsav+njet+1,n
65964 IF(k(i,1).EQ.8) k(i,1)=1
65965 270 CONTINUE
65966
65967C...Find combination of existing and new flavours for hadron.
65968 280 nfet=2
65969 IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3
65970 IF(nreq.LT.nrem) nfet=1
65971 IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0
65972 DO 290 j=1,nfet
65973 ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*pyr(0)
65974 kflf(j)=isign(1,nfl(1))
65975 IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))
65976 IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))
65977 290 CONTINUE
65978 IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))
65979 &GOTO 280
65980 IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.
65981 &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3)
65982 &.LT.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) GOTO 280
65983 IF(nfet.EQ.0) kflf(1)=1+int((2d0+parj(2))*pyr(0))
65984 IF(nfet.EQ.0) kflf(2)=-kflf(1)
65985 IF(nfet.EQ.1) kflf(2)=isign(1+int((2d0+parj(2))*pyr(0)),-kflf(1))
65986 IF(nfet.LE.2) kflf(3)=0
65987 IF(kflf(3).NE.0) THEN
65988 kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+
65989 & 100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))
65990 IF(kflf(1).EQ.kflf(3).OR.(1d0+3d0*parj(4))*pyr(0).GT.1d0)
65991 & kflfc=kflfc+isign(2,kflfc)
65992 ELSE
65993 kflfc=kflf(1)
65994 ENDIF
65995 CALL pykfdi(kflfc,kflf(2),kfldmp,kf)
65996 IF(kf.EQ.0) GOTO 280
65997 DO 300 j=1,max(2,nfet)
65998 nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))
65999 300 CONTINUE
66000
66001C...Store hadron at random among free positions.
66002 npos=min(1+int(pyr(0)*nrem),nrem)
66003 DO 310 i=nsav+njet+1,n
66004 IF(k(i,1).EQ.7) npos=npos-1
66005 IF(k(i,1).EQ.1.OR.npos.NE.0) GOTO 310
66006 k(i,1)=1
66007 k(i,2)=kf
66008 p(i,5)=pymass(k(i,2))
66009 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66010 310 CONTINUE
66011 nrem=nrem-1
66012 nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+
66013 &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3
66014 IF(nrem.GT.0) GOTO 280
66015
66016C...Compensate for missing momentum in global scheme (3 options).
66017 320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN
66018 DO 340 j=1,3
66019 psi(j)=0d0
66020 DO 330 i=nsav+njet+1,n
66021 psi(j)=psi(j)+p(i,j)
66022 330 CONTINUE
66023 340 CONTINUE
66024 psi(4)=psi(1)**2+psi(2)**2+psi(3)**2
66025 pws=0d0
66026 DO 350 i=nsav+njet+1,n
66027 IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)
66028 IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+
66029 & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
66030 IF(mod(mstj(3),5).EQ.3) pws=pws+1d0
66031 350 CONTINUE
66032 DO 370 i=nsav+njet+1,n
66033 IF(mod(mstj(3),5).EQ.1) pw=p(i,4)
66034 IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+
66035 & psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))
66036 IF(mod(mstj(3),5).EQ.3) pw=1d0
66037 DO 360 j=1,3
66038 p(i,j)=p(i,j)-psi(j)*pw/pws
66039 360 CONTINUE
66040 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66041 370 CONTINUE
66042
66043C...Compensate for missing momentum withing each jet separately.
66044 ELSEIF(mod(mstj(3),5).EQ.4) THEN
66045 DO 390 i=n+1,n+njet
66046 k(i,1)=0
66047 DO 380 j=1,5
66048 p(i,j)=0d0
66049 380 CONTINUE
66050 390 CONTINUE
66051 DO 410 i=nsav+njet+1,n
66052 ir1=k(i,3)
66053 ir2=n+ir1-nsav
66054 k(ir2,1)=k(ir2,1)+1
66055 pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
66056 & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
66057 DO 400 j=1,3
66058 p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)
66059 400 CONTINUE
66060 p(ir2,4)=p(ir2,4)+p(i,4)
66061 p(ir2,5)=p(ir2,5)+pls
66062 410 CONTINUE
66063 pss=0d0
66064 DO 420 i=n+1,n+njet
66065 IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8d0*p(i,5)+0.2d0))
66066 420 CONTINUE
66067 DO 440 i=nsav+njet+1,n
66068 ir1=k(i,3)
66069 ir2=n+ir1-nsav
66070 pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/
66071 & (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)
66072 DO 430 j=1,3
66073 p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1d0/(p(ir2,5)*pss)-1d0)*
66074 & pls*p(ir1,j)
66075 430 CONTINUE
66076 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66077 440 CONTINUE
66078 ENDIF
66079
66080C...Scale momenta for energy conservation.
66081 IF(mod(mstj(3),5).NE.0) THEN
66082 pms=0d0
66083 pes=0d0
66084 pqs=0d0
66085 DO 450 i=nsav+njet+1,n
66086 pms=pms+p(i,5)
66087 pes=pes+p(i,4)
66088 pqs=pqs+p(i,5)**2/p(i,4)
66089 450 CONTINUE
66090 IF(pms.GE.pecm) GOTO 150
66091 neco=0
66092 460 neco=neco+1
66093 pfac=(pecm-pqs)/(pes-pqs)
66094 pes=0d0
66095 pqs=0d0
66096 DO 480 i=nsav+njet+1,n
66097 DO 470 j=1,3
66098 p(i,j)=pfac*p(i,j)
66099 470 CONTINUE
66100 p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)
66101 pes=pes+p(i,4)
66102 pqs=pqs+p(i,5)**2/p(i,4)
66103 480 CONTINUE
66104 IF(neco.LT.10.AND.abs(pecm-pes).GT.2d-6*pecm) GOTO 460
66105 ENDIF
66106
66107C...Origin of produced particles and parton daughter pointers.
66108 490 DO 500 i=nsav+njet+1,n
66109 IF(mstu(16).NE.2) k(i,3)=nsav+1
66110 IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)
66111 500 CONTINUE
66112 DO 510 i=nsav+1,nsav+njet
66113 i1=k(i,3)
66114 k(i1,1)=k(i1,1)+10
66115 IF(mstu(16).NE.2) THEN
66116 k(i1,4)=nsav+1
66117 k(i1,5)=nsav+1
66118 ELSE
66119 k(i1,4)=k(i1,4)-njet+1
66120 k(i1,5)=k(i1,5)-njet+1
66121 IF(k(i1,5).LT.k(i1,4)) THEN
66122 k(i1,4)=0
66123 k(i1,5)=0
66124 ENDIF
66125 ENDIF
66126 510 CONTINUE
66127
66128C...Document independent fragmentation system. Remove copy of jets.
66129 nsav=nsav+1
66130 k(nsav,1)=11
66131 k(nsav,2)=93
66132 k(nsav,3)=ip
66133 k(nsav,4)=nsav+1
66134 k(nsav,5)=n-njet+1
66135 DO 520 j=1,4
66136 p(nsav,j)=dps(j)
66137 v(nsav,j)=v(ip,j)
66138 520 CONTINUE
66139 p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))
66140 v(nsav,5)=0d0
66141 DO 540 i=nsav+njet,n
66142 DO 530 j=1,5
66143 k(i-njet+1,j)=k(i,j)
66144 p(i-njet+1,j)=p(i,j)
66145 v(i-njet+1,j)=v(i,j)
66146 530 CONTINUE
66147 540 CONTINUE
66148 n=n-njet+1
66149 DO 550 iz=mstu90+1,mstu(90)
66150 mstu(90+iz)=mstu(90+iz)-njet+1
66151 550 CONTINUE
66152
66153C...Boost back particle system. Set production vertices.
66154 IF(njet.NE.1) CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),
66155 &dps(2)/dps(4),dps(3)/dps(4))
66156 DO 570 i=nsav+1,n
66157 DO 560 j=1,4
66158 v(i,j)=v(ip,j)
66159 560 CONTINUE
66160 570 CONTINUE
66161
66162 RETURN
66163 END
66164
66165C*********************************************************************
66166
66167C...PYDECY
66168C...Handles the decay of unstable particles.
66169
66170 SUBROUTINE pydecy(IP)
66171
66172C...Double precision and integer declarations.
66173 IMPLICIT DOUBLE PRECISION(a-h, o-z)
66174 IMPLICIT INTEGER(I-N)
66175 INTEGER PYK,PYCHGE,PYCOMP
66176C...Commonblocks.
66177 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
66178 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
66179 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
66180 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
66181 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
66182C...Local arrays.
66183 dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),
66184 &wtcor(10),ptau(4),pcmtau(4),dbetau(3)
66185 CHARACTER CIDC*4
66186 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66187
66188C...Functions: momentum in two-particle decays and four-product.
66189 pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2d0*a)
66190 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)
66191
66192C...Initial values.
66193 ntry=0
66194 nsav=n
66195 kfa=iabs(k(ip,2))
66196 kfs=isign(1,k(ip,2))
66197 kc=pycomp(kfa)
66198 mstj(92)=0
66199
66200C...Choose lifetime and determine decay vertex.
66201 IF(k(ip,1).EQ.5) THEN
66202 v(ip,5)=0d0
66203 ELSEIF(k(ip,1).NE.4) THEN
66204 v(ip,5)=-pmas(kc,4)*log(pyr(0))
66205 ENDIF
66206 DO 100 j=1,4
66207 vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)
66208 100 CONTINUE
66209
66210C...Determine whether decay allowed or not.
66211 mout=0
66212 IF(mstj(22).EQ.2) THEN
66213 IF(pmas(kc,4).GT.parj(71)) mout=1
66214 ELSEIF(mstj(22).EQ.3) THEN
66215 IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1
66216 ELSEIF(mstj(22).EQ.4) THEN
66217 IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1
66218 IF(abs(vdcy(3)).GT.parj(74)) mout=1
66219 ENDIF
66220 IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN
66221 k(ip,1)=4
66222 RETURN
66223 ENDIF
66224
66225C...Interface to external tau decay library (for tau polarization).
66226 IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN
66227
66228C...Starting values for pointers and momenta.
66229 itau=ip
66230 DO 110 j=1,4
66231 ptau(j)=p(itau,j)
66232 pcmtau(j)=p(itau,j)
66233 110 CONTINUE
66234
66235C...Iterate to find position and code of mother of tau.
66236 imtau=itau
66237 120 imtau=k(imtau,3)
66238
66239 IF(imtau.EQ.0) THEN
66240C...If no known origin then impossible to do anything further.
66241 kforig=0
66242 iorig=0
66243
66244 ELSEIF(k(imtau,2).EQ.k(itau,2)) THEN
66245C...If tau -> tau + gamma then add gamma energy and loop.
66246 IF(k(k(imtau,4),2).EQ.22) THEN
66247 DO 130 j=1,4
66248 pcmtau(j)=pcmtau(j)+p(k(imtau,4),j)
66249 130 CONTINUE
66250 ELSEIF(k(k(imtau,5),2).EQ.22) THEN
66251 DO 140 j=1,4
66252 pcmtau(j)=pcmtau(j)+p(k(imtau,5),j)
66253 140 CONTINUE
66254 ENDIF
66255 GOTO 120
66256
66257 ELSEIF(iabs(k(imtau,2)).GT.100) THEN
66258C...If coming from weak decay of hadron then W is not stored in record,
66259C...but can be reconstructed by adding neutrino momentum.
66260 kforig=-isign(24,k(itau,2))
66261 iorig=0
66262 DO 160 ii=k(imtau,4),k(imtau,5)
66263 IF(k(ii,2)*isign(1,k(itau,2)).EQ.-16) THEN
66264 DO 150 j=1,4
66265 pcmtau(j)=pcmtau(j)+p(ii,j)
66266 150 CONTINUE
66267 ENDIF
66268 160 CONTINUE
66269
66270 ELSE
66271C...If coming from resonance decay then find latest copy of this
66272C...resonance (may not completely agree).
66273 kforig=k(imtau,2)
66274 iorig=imtau
66275 DO 170 ii=imtau+1,ip-1
66276 IF(k(ii,2).EQ.kforig.AND.k(ii,3).EQ.iorig.AND.
66277 & abs(p(ii,5)-p(iorig,5)).LT.1d-5*p(iorig,5)) iorig=ii
66278 170 CONTINUE
66279 DO 180 j=1,4
66280 pcmtau(j)=p(iorig,j)
66281 180 CONTINUE
66282 ENDIF
66283
66284C...Boost tau to rest frame of production process (where known)
66285C...and rotate it to sit along +z axis.
66286 DO 190 j=1,3
66287 dbetau(j)=pcmtau(j)/pcmtau(4)
66288 190 CONTINUE
66289 IF(kforig.NE.0) CALL pyrobo(itau,itau,0d0,0d0,-dbetau(1),
66290 & -dbetau(2),-dbetau(3))
66291 phitau=pyangl(p(itau,1),p(itau,2))
66292 CALL pyrobo(itau,itau,0d0,-phitau,0d0,0d0,0d0)
66293 thetau=pyangl(p(itau,3),p(itau,1))
66294 CALL pyrobo(itau,itau,-thetau,0d0,0d0,0d0,0d0)
66295
66296C...Call tau decay routine (if meaningful) and fill extra info.
66297 IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
66298 CALL pytaud(itau,iorig,kforig,ndecay)
66299 DO 200 ii=nsav+1,nsav+ndecay
66300 k(ii,1)=1
66301 k(ii,3)=ip
66302 k(ii,4)=0
66303 k(ii,5)=0
66304 200 CONTINUE
66305 n=nsav+ndecay
66306 ENDIF
66307
66308C...Boost back decay tau and decay products.
66309 DO 210 j=1,4
66310 p(itau,j)=ptau(j)
66311 210 CONTINUE
66312 IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN
66313 CALL pyrobo(nsav+1,n,thetau,phitau,0d0,0d0,0d0)
66314 IF(kforig.NE.0) CALL pyrobo(nsav+1,n,0d0,0d0,dbetau(1),
66315 & dbetau(2),dbetau(3))
66316
66317C...Skip past ordinary tau decay treatment.
66318 mmat=0
66319 mbst=0
66320 nd=0
66321 GOTO 630
66322 ENDIF
66323 ENDIF
66324
66325C...B-Bbar mixing: flip sign of meson appropriately.
66326 mmix=0
66327 IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN
66328 xbbmix=parj(76)
66329 IF(kfa.EQ.531) xbbmix=parj(77)
66330 IF(sin(0.5d0*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.pyr(0)) mmix=1
66331 IF(mmix.EQ.1) kfs=-kfs
66332 ENDIF
66333
66334C...Check existence of decay channels. Particle/antiparticle rules.
66335 kca=kc
66336 IF(mdcy(kc,2).GT.0) THEN
66337 mdmdcy=mdme(mdcy(kc,2),2)
66338 IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy
66339 ENDIF
66340 IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN
66341 CALL pyerrm(9,'(PYDECY:) no decay channel defined')
66342 RETURN
66343 ENDIF
66344 IF(mod(kfa/1000,10).EQ.0.AND.kca.EQ.85) kfs=-kfs
66345 IF(kchg(kc,3).EQ.0) THEN
66346 kfsp=1
66347 kfsn=0
66348 IF(pyr(0).GT.0.5d0) kfs=-kfs
66349 ELSEIF(kfs.GT.0) THEN
66350 kfsp=1
66351 kfsn=0
66352 ELSE
66353 kfsp=0
66354 kfsn=1
66355 ENDIF
66356
66357C...Sum branching ratios of allowed decay channels.
66358 220 nope=0
66359 brsu=0d0
66360 DO 230 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1
66361 IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
66362 & kfsn*mdme(idl,1).NE.3) GOTO 230
66363 IF(mdme(idl,2).GT.100) GOTO 230
66364 nope=nope+1
66365 brsu=brsu+brat(idl)
66366 230 CONTINUE
66367 IF(nope.EQ.0) THEN
66368 CALL pyerrm(2,'(PYDECY:) all decay channels closed by user')
66369 RETURN
66370 ENDIF
66371
66372C...Select decay channel among allowed ones.
66373 240 rbr=brsu*pyr(0)
66374 idl=mdcy(kca,2)-1
66375 250 idl=idl+1
66376 IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.
66377 &kfsn*mdme(idl,1).NE.3) THEN
66378 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 250
66379 ELSEIF(mdme(idl,2).GT.100) THEN
66380 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) GOTO 250
66381 ELSE
66382 idc=idl
66383 rbr=rbr-brat(idl)
66384 IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0d0) GOTO 250
66385 ENDIF
66386
66387C...Start readout of decay channel: matrix element, reset counters.
66388 mmat=mdme(idc,2)
66389 260 ntry=ntry+1
66390 IF(mod(ntry,200).EQ.0) THEN
66391 WRITE(cidc,'(I4)') idc
66392C...Do not print warning for some well-known special cases.
66393 IF(kfa.NE.113.AND.kfa.NE.115.AND.kfa.NE.215)
66394 & CALL pyerrm(4,'(PYDECY:) caught in loop for decay channel'//
66395 & cidc)
66396 GOTO 240
66397 ENDIF
66398 IF(ntry.GT.1000) THEN
66399 CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
66400 IF(mstu(21).GE.1) RETURN
66401 ENDIF
66402 i=n
66403 np=0
66404 nq=0
66405 mbst=0
66406 IF(mmat.GE.11.AND.p(ip,4).GT.20d0*p(ip,5)) mbst=1
66407 DO 270 j=1,4
66408 pv(1,j)=0d0
66409 IF(mbst.EQ.0) pv(1,j)=p(ip,j)
66410 270 CONTINUE
66411 IF(mbst.EQ.1) pv(1,4)=p(ip,5)
66412 pv(1,5)=p(ip,5)
66413 ps=0d0
66414 psq=0d0
66415 mrem=0
66416 mhaddy=0
66417 IF(kfa.GT.80) mhaddy=1
66418C.. Random flavour and popcorn system memory.
66419 irndmo=0
66420 jtmo=0
66421 mstu(121)=0
66422 mstu(125)=10
66423
66424C...Read out decay products. Convert to standard flavour code.
66425 jtmax=5
66426 IF(mdme(idc+1,2).EQ.101) jtmax=10
66427 DO 280 jt=1,jtmax
66428 IF(jt.LE.5) kp=kfdp(idc,jt)
66429 IF(jt.GE.6) kp=kfdp(idc+1,jt-5)
66430 IF(kp.EQ.0) GOTO 280
66431 kpa=iabs(kp)
66432 kcp=pycomp(kpa)
66433 IF(kpa.GT.80) mhaddy=1
66434 IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN
66435 kfp=kp
66436 ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN
66437 kfp=kfs*kp
66438 ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN
66439 kfp=-kfs*mod(kfa/10,10)
66440 ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN
66441 kfp=kfs*(100*mod(kfa/10,100)+3)
66442 ELSEIF(kpa.EQ.81) THEN
66443 kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
66444 ELSEIF(kp.EQ.82) THEN
66445 CALL pydcyk(-kfs*int(1d0+(2d0+parj(2))*pyr(0)),0,kfp,kdump)
66446 IF(kfp.EQ.0) GOTO 260
66447 kfp=-kfp
66448 irndmo=1
66449 mstj(93)=1
66450 IF(pv(1,5).LT.parj(32)+2d0*pymass(kfp)) GOTO 260
66451 ELSEIF(kp.EQ.-82) THEN
66452 kfp=mstu(124)
66453 ENDIF
66454 IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=pycomp(kfp)
66455
66456C...Add decay product to event record or to quark flavour list.
66457 kfpa=iabs(kfp)
66458 kqp=kchg(kcp,2)
66459 IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN
66460 nq=nq+1
66461 kflo(nq)=kfp
66462C...set rndmflav popcorn system pointer
66463 IF(kp.EQ.82.AND.mstu(121).GT.0) jtmo=nq
66464 mstj(93)=2
66465 psq=psq+pymass(kflo(nq))
66466 ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.
66467 & mod(nq,2).EQ.1) THEN
66468 nq=nq-1
66469 ps=ps-p(i,5)
66470 k(i,1)=1
66471 kfi=k(i,2)
66472 CALL pykfdi(kfp,kfi,kfldmp,k(i,2))
66473 IF(k(i,2).EQ.0) GOTO 260
66474 mstj(93)=1
66475 p(i,5)=pymass(k(i,2))
66476 ps=ps+p(i,5)
66477 ELSE
66478 i=i+1
66479 np=np+1
66480 IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1
66481 IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1
66482 k(i,1)=1+mod(nq,2)
66483 IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2
66484 IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1
66485 k(i,2)=kfp
66486 k(i,3)=ip
66487 k(i,4)=0
66488 k(i,5)=0
66489 p(i,5)=pymass(kfp)
66490 ps=ps+p(i,5)
66491 ENDIF
66492 280 CONTINUE
66493
66494C...Check masses for resonance decays.
66495 IF(mhaddy.EQ.0) THEN
66496 IF(ps+parj(64).GT.pv(1,5)) GOTO 240
66497 ENDIF
66498
66499C...Choose decay multiplicity in phase space model.
66500 290 IF(mmat.GE.11.AND.mmat.LE.30) THEN
66501 psp=ps
66502 cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1d0))
66503 IF(mmat.EQ.12) cnde=cnde+parj(63)
66504 300 ntry=ntry+1
66505C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66506 IF(irndmo.EQ.0) THEN
66507 mstu(121)=0
66508 jtmo=0
66509 ELSEIF(irndmo.EQ.1) THEN
66510 irndmo=2
66511 ELSE
66512 GOTO 260
66513 ENDIF
66514 IF(ntry.GT.1000) THEN
66515 CALL pyerrm(14,'(PYDECY:) caught in infinite loop')
66516 IF(mstu(21).GE.1) RETURN
66517 ENDIF
66518 IF(mmat.LE.20) THEN
66519 gauss=sqrt(-2d0*cnde*log(max(1d-10,pyr(0))))*
66520 & sin(paru(2)*pyr(0))
66521 nd=0.5d0+0.5d0*np+0.25d0*nq+cnde+gauss
66522 IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) GOTO 300
66523 IF(mmat.EQ.13.AND.nd.EQ.2) GOTO 300
66524 IF(mmat.EQ.14.AND.nd.LE.3) GOTO 300
66525 IF(mmat.EQ.15.AND.nd.LE.4) GOTO 300
66526 ELSE
66527 nd=mmat-20
66528 ENDIF
66529C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66530 mstu(125)=nd-nq/2
66531 IF(mstu(121).GT.mstu(125)) GOTO 300
66532
66533C...Form hadrons from flavour content.
66534 DO 310 jt=1,nq
66535 kfl1(jt)=kflo(jt)
66536 310 CONTINUE
66537 IF(nd.EQ.np+nq/2) GOTO 330
66538 DO 320 i=n+np+1,n+nd-nq/2
66539C.. Stick to started popcorn system, else pick side at random
66540 jt=jtmo
66541 IF(jt.EQ.0) jt=1+int((nq-1)*pyr(0))
66542 CALL pydcyk(kfl1(jt),0,kfl2,k(i,2))
66543 IF(k(i,2).EQ.0) GOTO 300
66544 mstu(125)=mstu(125)-1
66545 jtmo=0
66546 IF(mstu(121).GT.0) jtmo=jt
66547 kfl1(jt)=-kfl2
66548 320 CONTINUE
66549 330 jt=2
66550 jt2=3
66551 jt3=4
66552 IF(nq.EQ.4.AND.pyr(0).LT.parj(66)) jt=4
66553 IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*
66554 & isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3
66555 IF(jt.EQ.3) jt2=2
66556 IF(jt.EQ.4) jt3=2
66557 CALL pydcyk(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))
66558 IF(k(n+nd-nq/2+1,2).EQ.0) GOTO 300
66559 IF(nq.EQ.4) CALL pydcyk(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))
66560 IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) GOTO 300
66561
66562C...Check that sum of decay product masses not too large.
66563 ps=psp
66564 DO 340 i=n+np+1,n+nd
66565 k(i,1)=1
66566 k(i,3)=ip
66567 k(i,4)=0
66568 k(i,5)=0
66569 p(i,5)=pymass(k(i,2))
66570 ps=ps+p(i,5)
66571 340 CONTINUE
66572 IF(ps+parj(64).GT.pv(1,5)) GOTO 300
66573
66574C...Rescale energy to subtract off spectator quark mass.
66575 ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44)
66576 & .AND.np.GE.3) THEN
66577 ps=ps-p(n+np,5)
66578 pqt=(p(n+np,5)+parj(65))/pv(1,5)
66579 DO 350 j=1,5
66580 p(n+np,j)=pqt*pv(1,j)
66581 pv(1,j)=(1d0-pqt)*pv(1,j)
66582 350 CONTINUE
66583 IF(ps+parj(64).GT.pv(1,5)) GOTO 260
66584 nd=np-1
66585 mrem=1
66586
66587C...Fully specified final state: check mass broadening effects.
66588 ELSE
66589 IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) GOTO 260
66590 nd=np
66591 ENDIF
66592
66593C...Determine position of grandmother, number of sisters.
66594 nm=0
66595 kfas=0
66596 msgn=0
66597 IF(mmat.EQ.3) THEN
66598 im=k(ip,3)
66599 IF(im.LT.0.OR.im.GE.ip) im=0
66600 IF(im.NE.0) kfam=iabs(k(im,2))
66601 IF(im.NE.0) THEN
66602 DO 360 il=max(ip-2,im+1),min(ip+2,n)
66603 IF(k(il,3).EQ.im) nm=nm+1
66604 IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il
66605 360 CONTINUE
66606 IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.
66607 & mod(kfam/1000,10).NE.0) nm=0
66608 IF(nm.EQ.2) THEN
66609 kfas=iabs(k(isis,2))
66610 IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.
66611 & mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0
66612 ENDIF
66613 ENDIF
66614 ENDIF
66615
66616C...Kinematics of one-particle decays.
66617 IF(nd.EQ.1) THEN
66618 DO 370 j=1,4
66619 p(n+1,j)=p(ip,j)
66620 370 CONTINUE
66621 GOTO 630
66622 ENDIF
66623
66624C...Calculate maximum weight ND-particle decay.
66625 pv(nd,5)=p(n+nd,5)
66626 IF(nd.GE.3) THEN
66627 wtmax=1d0/wtcor(nd-2)
66628 pmax=pv(1,5)-ps+p(n+nd,5)
66629 pmin=0d0
66630 DO 380 il=nd-1,1,-1
66631 pmax=pmax+p(n+il,5)
66632 pmin=pmin+p(n+il+1,5)
66633 wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))
66634 380 CONTINUE
66635 ENDIF
66636
66637C...Find virtual gamma mass in Dalitz decay.
66638 390 IF(nd.EQ.2) THEN
66639 ELSEIF(mmat.EQ.2) THEN
66640 pmes=4d0*pmas(11,1)**2
66641 pmrho2=pmas(131,1)**2
66642 pgrho2=pmas(131,2)**2
66643 400 pmst=pmes*(p(ip,5)**2/pmes)**pyr(0)
66644 wt=(1+0.5d0*pmes/pmst)*sqrt(max(0d0,1d0-pmes/pmst))*
66645 & (1d0-pmst/p(ip,5)**2)**3*(1d0+pgrho2/pmrho2)/
66646 & ((1d0-pmst/pmrho2)**2+pgrho2/pmrho2)
66647 IF(wt.LT.pyr(0)) GOTO 400
66648 pv(2,5)=max(2.00001d0*pmas(11,1),sqrt(pmst))
66649
66650C...M-generator gives weight. If rejected, try again.
66651 ELSE
66652 410 rord(1)=1d0
66653 DO 440 il1=2,nd-1
66654 rsav=pyr(0)
66655 DO 420 il2=il1-1,1,-1
66656 IF(rsav.LE.rord(il2)) GOTO 430
66657 rord(il2+1)=rord(il2)
66658 420 CONTINUE
66659 430 rord(il2+1)=rsav
66660 440 CONTINUE
66661 rord(nd)=0d0
66662 wt=1d0
66663 DO 450 il=nd-1,1,-1
66664 pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*
66665 & (pv(1,5)-ps)
66666 wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))
66667 450 CONTINUE
66668 IF(wt.LT.pyr(0)*wtmax) GOTO 410
66669 ENDIF
66670
66671C...Perform two-particle decays in respective CM frame.
66672 460 DO 480 il=1,nd-1
66673 pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))
66674 ue(3)=2d0*pyr(0)-1d0
66675 phi=paru(2)*pyr(0)
66676 ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)
66677 ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)
66678 DO 470 j=1,3
66679 p(n+il,j)=pa*ue(j)
66680 pv(il+1,j)=-pa*ue(j)
66681 470 CONTINUE
66682 p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)
66683 pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)
66684 480 CONTINUE
66685
66686C...Lorentz transform decay products to lab frame.
66687 DO 490 j=1,4
66688 p(n+nd,j)=pv(nd,j)
66689 490 CONTINUE
66690 DO 530 il=nd-1,1,-1
66691 DO 500 j=1,3
66692 be(j)=pv(il,j)/pv(il,4)
66693 500 CONTINUE
66694 ga=pv(il,4)/pv(il,5)
66695 DO 520 i=n+il,n+nd
66696 bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
66697 DO 510 j=1,3
66698 p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
66699 510 CONTINUE
66700 p(i,4)=ga*(p(i,4)+bep)
66701 520 CONTINUE
66702 530 CONTINUE
66703
66704C...Check that no infinite loop in matrix element weight.
66705 ntry=ntry+1
66706 IF(ntry.GT.800) GOTO 560
66707
66708C...Matrix elements for omega and phi decays.
66709 IF(mmat.EQ.1) THEN
66710 wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2
66711 & -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2
66712 & +2d0*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)
66713 IF(max(wt*wtcor(9)/p(ip,5)**6,0.001d0).LT.pyr(0)) GOTO 390
66714
66715C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66716 ELSEIF(mmat.EQ.2) THEN
66717 four12=four(n+1,n+2)
66718 four13=four(n+1,n+3)
66719 wt=(pmst-0.5d0*pmes)*(four12**2+four13**2)+
66720 & pmes*(four12*four13+four12**2+four13**2)
66721 IF(wt.LT.pyr(0)*0.25d0*pmst*(p(ip,5)**2-pmst)**2) GOTO 460
66722
66723C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66724C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66725C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66726 ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN
66727 four10=four(ip,im)
66728 four12=four(ip,n+1)
66729 four02=four(im,n+1)
66730 pms1=p(ip,5)**2
66731 pms0=p(im,5)**2
66732 pms2=p(n+1,5)**2
66733 IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2
66734 IF(kfas.EQ.22) hnum=pms1*(2d0*four10*four12*four02-
66735 & pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)
66736 hnum=max(1d-6*pms1**2*pms0*pms2,hnum)
66737 hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)
66738 IF(hnum.LT.pyr(0)*hden) GOTO 460
66739
66740C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66741 ELSEIF(mmat.EQ.4) THEN
66742 hx1=2d0*four(ip,n+1)/p(ip,5)**2
66743 hx2=2d0*four(ip,n+2)/p(ip,5)**2
66744 hx3=2d0*four(ip,n+3)/p(ip,5)**2
66745 wt=((1d0-hx1)/(hx2*hx3))**2+((1d0-hx2)/(hx1*hx3))**2+
66746 & ((1d0-hx3)/(hx1*hx2))**2
66747 IF(wt.LT.2d0*pyr(0)) GOTO 390
66748 IF(k(ip+1,2).EQ.22.AND.(1d0-hx1)*p(ip,5)**2.LT.4d0*parj(32)**2)
66749 & GOTO 390
66750
66751C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66752 ELSEIF(mmat.EQ.41) THEN
66753 IF(mbst.EQ.0) hx1=2d0*four(ip,n+1)/p(ip,5)**2
66754 IF(mbst.EQ.1) hx1=2d0*p(n+1,4)/p(ip,5)
66755 hxm=min(0.75d0,2d0*(1d0-ps/p(ip,5)))
66756 IF(hx1*(3d0-2d0*hx1).LT.pyr(0)*hxm*(3d0-2d0*hxm)) GOTO 390
66757
66758C...Matrix elements for weak decays (only semileptonic for c and b)
66759 ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
66760 & .AND.nd.EQ.3) THEN
66761 IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)
66762 IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)
66763 IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 390
66764 ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN
66765 DO 550 j=1,4
66766 p(n+np+1,j)=0d0
66767 DO 540 is=n+3,n+np
66768 p(n+np+1,j)=p(n+np+1,j)+p(is,j)
66769 540 CONTINUE
66770 550 CONTINUE
66771 IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)
66772 IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)
66773 IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) GOTO 390
66774 ENDIF
66775
66776C...Scale back energy and reattach spectator.
66777 560 IF(mrem.EQ.1) THEN
66778 DO 570 j=1,5
66779 pv(1,j)=pv(1,j)/(1d0-pqt)
66780 570 CONTINUE
66781 nd=nd+1
66782 mrem=0
66783 ENDIF
66784
66785C...Low invariant mass for system with spectator quark gives particle,
66786C...not two jets. Readjust momenta accordingly.
66787 IF(mmat.EQ.31.AND.nd.EQ.3) THEN
66788 mstj(93)=1
66789 pm2=pymass(k(n+2,2))
66790 mstj(93)=1
66791 pm3=pymass(k(n+3,2))
66792 IF(p(n+2,5)**2+p(n+3,5)**2+2d0*four(n+2,n+3).GE.
66793 & (parj(32)+pm2+pm3)**2) GOTO 630
66794 k(n+2,1)=1
66795 kftemp=k(n+2,2)
66796 CALL pykfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))
66797 IF(k(n+2,2).EQ.0) GOTO 260
66798 p(n+2,5)=pymass(k(n+2,2))
66799 ps=p(n+1,5)+p(n+2,5)
66800 pv(2,5)=p(n+2,5)
66801 mmat=0
66802 nd=2
66803 GOTO 460
66804 ELSEIF(mmat.EQ.44) THEN
66805 mstj(93)=1
66806 pm3=pymass(k(n+3,2))
66807 mstj(93)=1
66808 pm4=pymass(k(n+4,2))
66809 IF(p(n+3,5)**2+p(n+4,5)**2+2d0*four(n+3,n+4).GE.
66810 & (parj(32)+pm3+pm4)**2) GOTO 600
66811 k(n+3,1)=1
66812 kftemp=k(n+3,2)
66813 CALL pykfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))
66814 IF(k(n+3,2).EQ.0) GOTO 260
66815 p(n+3,5)=pymass(k(n+3,2))
66816 DO 580 j=1,3
66817 p(n+3,j)=p(n+3,j)+p(n+4,j)
66818 580 CONTINUE
66819 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)
66820 ha=p(n+1,4)**2-p(n+2,4)**2
66821 hb=ha-(p(n+1,5)**2-p(n+2,5)**2)
66822 hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+
66823 & (p(n+1,3)-p(n+2,3))**2
66824 hd=(pv(1,4)-p(n+3,4))**2
66825 he=ha**2-2d0*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2
66826 hf=hd*hc-hb**2
66827 hg=hd*hc-ha*hb
66828 hh=(sqrt(hg**2+he*hf)-hg)/(2d0*hf)
66829 DO 590 j=1,3
66830 pcor=hh*(p(n+1,j)-p(n+2,j))
66831 p(n+1,j)=p(n+1,j)+pcor
66832 p(n+2,j)=p(n+2,j)-pcor
66833 590 CONTINUE
66834 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)
66835 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)
66836 nd=nd-1
66837 ENDIF
66838
66839C...Check invariant mass of W jets. May give one particle or start over.
66840 600 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)
66841 &.AND.iabs(k(n+1,2)).LT.10) THEN
66842 pmr=sqrt(max(0d0,p(n+1,5)**2+p(n+2,5)**2+2d0*four(n+1,n+2)))
66843 mstj(93)=1
66844 pm1=pymass(k(n+1,2))
66845 mstj(93)=1
66846 pm2=pymass(k(n+2,2))
66847 IF(pmr.GT.parj(32)+pm1+pm2) GOTO 610
66848 kfldum=int(1.5d0+pyr(0))
66849 CALL pykfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)
66850 CALL pykfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)
66851 IF(kf1.EQ.0.OR.kf2.EQ.0) GOTO 260
66852 psm=pymass(kf1)+pymass(kf2)
66853 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) GOTO 610
66854 IF(mmat.GE.43.AND.pmr.GT.0.2d0*parj(32)+psm) GOTO 610
66855 IF(mmat.EQ.48) GOTO 390
66856 IF(nd.EQ.4.OR.kfa.EQ.15) GOTO 260
66857 k(n+1,1)=1
66858 kftemp=k(n+1,2)
66859 CALL pykfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))
66860 IF(k(n+1,2).EQ.0) GOTO 260
66861 p(n+1,5)=pymass(k(n+1,2))
66862 k(n+2,2)=k(n+3,2)
66863 p(n+2,5)=p(n+3,5)
66864 ps=p(n+1,5)+p(n+2,5)
66865 IF(ps+parj(64).GT.pv(1,5)) GOTO 260
66866 pv(2,5)=p(n+3,5)
66867 mmat=0
66868 nd=2
66869 GOTO 460
66870 ENDIF
66871
66872C...Phase space decay of partons from W decay.
66873 610 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN
66874 kflo(1)=k(n+1,2)
66875 kflo(2)=k(n+2,2)
66876 k(n+1,1)=k(n+3,1)
66877 k(n+1,2)=k(n+3,2)
66878 DO 620 j=1,5
66879 pv(1,j)=p(n+1,j)+p(n+2,j)
66880 p(n+1,j)=p(n+3,j)
66881 620 CONTINUE
66882 pv(1,5)=pmr
66883 n=n+1
66884 np=0
66885 nq=2
66886 ps=0d0
66887 mstj(93)=2
66888 psq=pymass(kflo(1))
66889 mstj(93)=2
66890 psq=psq+pymass(kflo(2))
66891 mmat=11
66892 GOTO 290
66893 ENDIF
66894
66895C...Boost back for rapidly moving particle.
66896 630 n=n+nd
66897 IF(mbst.EQ.1) THEN
66898 DO 640 j=1,3
66899 be(j)=p(ip,j)/p(ip,4)
66900 640 CONTINUE
66901 ga=p(ip,4)/p(ip,5)
66902 DO 660 i=nsav+1,n
66903 bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)
66904 DO 650 j=1,3
66905 p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)
66906 650 CONTINUE
66907 p(i,4)=ga*(p(i,4)+bep)
66908 660 CONTINUE
66909 ENDIF
66910
66911C...Fill in position of decay vertex.
66912 DO 680 i=nsav+1,n
66913 DO 670 j=1,4
66914 v(i,j)=vdcy(j)
66915 670 CONTINUE
66916 v(i,5)=0d0
66917 680 CONTINUE
66918
66919C...Set up for parton shower evolution from jets.
66920 IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN
66921 k(nsav+1,1)=3
66922 k(nsav+2,1)=3
66923 k(nsav+3,1)=3
66924 k(nsav+1,4)=mstu(5)*(nsav+2)
66925 k(nsav+1,5)=mstu(5)*(nsav+3)
66926 k(nsav+2,4)=mstu(5)*(nsav+3)
66927 k(nsav+2,5)=mstu(5)*(nsav+1)
66928 k(nsav+3,4)=mstu(5)*(nsav+1)
66929 k(nsav+3,5)=mstu(5)*(nsav+2)
66930 mstj(92)=-(nsav+1)
66931 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN
66932 k(nsav+2,1)=3
66933 k(nsav+3,1)=3
66934 k(nsav+2,4)=mstu(5)*(nsav+3)
66935 k(nsav+2,5)=mstu(5)*(nsav+3)
66936 k(nsav+3,4)=mstu(5)*(nsav+2)
66937 k(nsav+3,5)=mstu(5)*(nsav+2)
66938 mstj(92)=nsav+2
66939 ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
66940 & iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN
66941 k(nsav+1,1)=3
66942 k(nsav+2,1)=3
66943 k(nsav+1,4)=mstu(5)*(nsav+2)
66944 k(nsav+1,5)=mstu(5)*(nsav+2)
66945 k(nsav+2,4)=mstu(5)*(nsav+1)
66946 k(nsav+2,5)=mstu(5)*(nsav+1)
66947 mstj(92)=nsav+1
66948 ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.
66949 & iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN
66950 mstj(92)=nsav+1
66951 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)
66952 & THEN
66953 k(nsav+1,1)=3
66954 k(nsav+2,1)=3
66955 k(nsav+3,1)=3
66956 kcp=pycomp(k(nsav+1,2))
66957 kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))
66958 jcon=4
66959 IF(kqp.LT.0) jcon=5
66960 k(nsav+1,jcon)=mstu(5)*(nsav+2)
66961 k(nsav+2,9-jcon)=mstu(5)*(nsav+1)
66962 k(nsav+2,jcon)=mstu(5)*(nsav+3)
66963 k(nsav+3,9-jcon)=mstu(5)*(nsav+2)
66964 mstj(92)=nsav+1
66965 ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN
66966 k(nsav+1,1)=3
66967 k(nsav+3,1)=3
66968 k(nsav+1,4)=mstu(5)*(nsav+3)
66969 k(nsav+1,5)=mstu(5)*(nsav+3)
66970 k(nsav+3,4)=mstu(5)*(nsav+1)
66971 k(nsav+3,5)=mstu(5)*(nsav+1)
66972 mstj(92)=nsav+1
66973 ENDIF
66974
66975C...Mark decayed particle; special option for B-Bbar mixing.
66976 IF(k(ip,1).EQ.5) k(ip,1)=15
66977 IF(k(ip,1).LE.10) k(ip,1)=11
66978 IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12
66979 k(ip,4)=nsav+1
66980 k(ip,5)=n
66981
66982 RETURN
66983 END
66984
66985
66986C*********************************************************************
66987
66988C...PYDCYK
66989C...Handles flavour production in the decay of unstable particles
66990C...and small string clusters.
66991
66992 SUBROUTINE pydcyk(KFL1,KFL2,KFL3,KF)
66993
66994C...Double precision and integer declarations.
66995 IMPLICIT DOUBLE PRECISION(a-h, o-z)
66996 IMPLICIT INTEGER(I-N)
66997 INTEGER PYK,PYCHGE,PYCOMP
66998C...Commonblocks.
66999 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67000 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67001 SAVE /pydat1/,/pydat2/
67002
67003
67004C.. Call PYKFDI directly if no popcorn option is on
67005 IF(mstj(12).LT.2) THEN
67006 CALL pykfdi(kfl1,kfl2,kfl3,kf)
67007 mstu(124)=kfl3
67008 RETURN
67009 ENDIF
67010
67011 kfl3=0
67012 kf=0
67013 IF(kfl1.EQ.0) RETURN
67014 kf1a=iabs(kfl1)
67015 kf2a=iabs(kfl2)
67016
67017 nsto=130
67018 nmax=min(mstu(125),10)
67019
67020C.. Identify rank 0 cluster qq
67021 irank=1
67022 IF(kf1a.GT.10.AND.kf1a.LT.10000) irank=0
67023
67024 IF(kf2a.GT.0)THEN
67025C.. Join jets: Fails if store not empty
67026 IF(mstu(121).GT.0) THEN
67027 mstu(121)=0
67028 RETURN
67029 ENDIF
67030 CALL pykfdi(kfl1,kfl2,kfl3,kf)
67031 ELSEIF(kf1a.GT.10.AND.mstu(121).GT.0)THEN
67032C.. Pick popcorn meson from store, return same qq, decrease store
67033 kf=mstu(nsto+mstu(121))
67034 kfl3=-kfl1
67035 mstu(121)=mstu(121)-1
67036 ELSE
67037C.. Generate new flavour. Then done if no diquark is generated
67038 100 CALL pykfdi(kfl1,0,kfl3,kf)
67039 IF(mstu(121).EQ.-1) GOTO 100
67040 mstu(124)=kfl3
67041 IF(kf.EQ.0.OR.iabs(kfl3).LE.10) RETURN
67042
67043C.. Simple case if no dynamical popcorn suppressions are considered
67044 IF(mstj(12).LT.4) THEN
67045 IF(mstu(121).EQ.0) RETURN
67046 nmes=1
67047 kfprev=-kfl3
67048 CALL pykfdi(kfprev,0,kfl3,kfm)
67049C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67050 IF(iabs(kfl3).LE.10)THEN
67051 kfl3=-kfprev
67052 RETURN
67053 ENDIF
67054 GOTO 120
67055 ENDIF
67056
67057C test output qq against fake Gamma, then return if no popcorn.
67058 gb=2d0
67059 IF(irank.NE.0)THEN
67060 CALL pyzdis(1,2103,5d0,z)
67061 gb=5d0*(1d0-z)/z
67062 IF(1d0-parf(192)**gb.LT.pyr(0)) THEN
67063 mstu(121)=0
67064 GOTO 100
67065 ENDIF
67066 ENDIF
67067 IF(mstu(121).EQ.0) RETURN
67068
67069C..Set store size memory. Pick fake dynamical variables of qq.
67070 nmes=mstu(121)
67071 CALL pyptdi(1,px3,py3)
67072 x=1d0
67073 popm=0d0
67074 g=gb
67075 popg=gb
67076
67077C.. Pick next popcorn meson, test with fake dynamical variables
67078 110 kfprev=-kfl3
67079 px1=-px3
67080 py1=-py3
67081 CALL pykfdi(kfprev,0,kfl3,kfm)
67082 IF(mstu(121).EQ.-1) GOTO 100
67083 CALL pyptdi(kfl3,px3,py3)
67084 pm=pymass(kfm)**2+(px1+px3)**2+(py1+py3)**2
67085 CALL pyzdis(kfprev,kfl3,pm,z)
67086 g=(1d0-z)*(g+pm/z)
67087 x=(1d0-z)*x
67088
67089 ptst=1d0
67090 gtst=1d0
67091 rtst=pyr(0)
67092 IF(mstj(12).GT.4)THEN
67093 popmn=sqrt((1d0-x)*(g/x-gb))
67094 popm=popm+pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
67095 ptst=exp((popm-popmn)*parf(193))
67096 popm=popmn
67097 ENDIF
67098 IF(irank.NE.0)THEN
67099 popgn=x*gb
67100 gtst=(1d0-parf(192)**popgn)/(1d0-parf(192)**popg)
67101 popg=popgn
67102 ENDIF
67103 IF(rtst.GT.ptst*gtst)THEN
67104 mstu(121)=0
67105 IF(rtst.GT.ptst) mstu(121)=-1
67106 GOTO 100
67107 ENDIF
67108
67109C.. Store meson
67110 120 IF(nmes.LE.nmax) mstu(nsto+mstu(121)+1)=kfm
67111 IF(mstu(121).GT.0) GOTO 110
67112
67113C.. Test accepted system size. If OK set global popcorn size variable.
67114 IF(nmes.GT.nmax)THEN
67115 kf=0
67116 kfl3=0
67117 RETURN
67118 ENDIF
67119 mstu(121)=nmes
67120 ENDIF
67121
67122 RETURN
67123 END
67124
67125C********************************************************************
67126
67127C...PYKFDI
67128C...Generates a new flavour pair and combines off a hadron
67129
67130 SUBROUTINE pykfdi(KFL1,KFL2,KFL3,KF)
67131
67132C...Double precision and integer declarations.
67133 IMPLICIT DOUBLE PRECISION(a-h, o-z)
67134 IMPLICIT INTEGER(I-N)
67135 INTEGER PYK,PYCHGE,PYCOMP
67136C...Commonblocks.
67137 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67138 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67139 SAVE /pydat1/,/pydat2/
67140C...Local arrays.
67141 dimension pd(7)
67142
67143 IF(mstu(123).EQ.0.AND.mstj(12).GE.0) CALL pykfin
67144
67145C...Default flavour values. Input consistency checks.
67146 kf1a=iabs(kfl1)
67147 kf2a=iabs(kfl2)
67148 kfl3=0
67149 kf=0
67150 IF(kf1a.EQ.0) RETURN
67151 IF(kf2a.NE.0)THEN
67152 IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN
67153 IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN
67154 IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN
67155 ENDIF
67156
67157C...Check if tabulated flavour probabilities are to be used.
67158 IF(mstj(15).EQ.1) THEN
67159 IF(mstj(12).GE.5) CALL pyerrm(29,
67160 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67161 & ' together with MSTJ(12)>=5 modification')
67162 ktab1=-1
67163 IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a
67164 kfl1a=mod(kf1a/1000,10)
67165 kfl1b=mod(kf1a/100,10)
67166 kfl1s=mod(kf1a,10)
67167 IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)
67168 & ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2
67169 IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1
67170 IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a
67171 ktab2=0
67172 IF(kf2a.NE.0) THEN
67173 ktab2=-1
67174 IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a
67175 kfl2a=mod(kf2a/1000,10)
67176 kfl2b=mod(kf2a/100,10)
67177 kfl2s=mod(kf2a,10)
67178 IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)
67179 & ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2
67180 IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1
67181 ENDIF
67182 IF(ktab1.GE.0.AND.ktab2.GE.0) GOTO 140
67183 ENDIF
67184
67185C.. Recognize rank 0 diquark case
67186 100 irank=1
67187 kfdiq=max(kf1a,kf2a)
67188 IF(kfdiq.GT.10.AND.kfdiq.LT.10000) irank=0
67189
67190C.. Join two flavours to meson or baryon. Test for popcorn.
67191 IF(kf2a.GT.0)THEN
67192 mbary=0
67193 IF(kfdiq.GT.10) THEN
67194 IF(irank.EQ.0.AND.mstj(12).LT.5)
67195 & CALL pynmes(kfdiq)
67196 IF(mstu(121).NE.0) THEN
67197 mstu(121)=0
67198 RETURN
67199 ENDIF
67200 mbary=2
67201 ENDIF
67202 kfqold=kf1a
67203 kfqver=kf2a
67204 GOTO 130
67205 ENDIF
67206
67207C.. Separate incoming flavours, curtain flavour consistency check
67208 kfin=kfl1
67209 kfqold=kf1a
67210 kfqpop=kf1a/10000
67211 IF(kf1a.GT.10)THEN
67212 kfin=-kfl1
67213 kfl1a=mod(kf1a/1000,10)
67214 kfl1b=mod(kf1a/100,10)
67215 IF(irank.EQ.0)THEN
67216 qawt=1d0
67217 IF(kfl1a.GE.3) qawt=parf(136+kfl1a/4)
67218 IF(kfl1b.GE.3) qawt=qawt/parf(136+kfl1b/4)
67219 kfqpop=kfl1a+(kfl1b-kfl1a)*int(1d0/(qawt+1d0)+pyr(0))
67220 ENDIF
67221 IF(kfqpop.NE.kfl1b.AND.kfqpop.NE.kfl1a) THEN
67222 mstu(121)=0
67223 RETURN
67224 ENDIF
67225 kfqold=kfl1a+kfl1b-kfqpop
67226 ENDIF
67227
67228C...Meson/baryon choice. Set number of mesons if starting a popcorn
67229C...system.
67230 110 mbary=0
67231 IF(kf1a.LE.10.AND.mstj(12).GT.0)THEN
67232 IF(mstu(121).EQ.-1.OR.(1d0+parj(1))*pyr(0).GT.1d0)THEN
67233 mbary=1
67234 CALL pynmes(0)
67235 ENDIF
67236 ELSEIF(kf1a.GT.10)THEN
67237 mbary=2
67238 IF(irank.EQ.0) CALL pynmes(kf1a)
67239 IF(mstu(121).GT.0) mbary=-1
67240 ENDIF
67241
67242C..x->H+q: Choose single vertex quark. Jump to form hadron.
67243 IF(mbary.EQ.0.OR.mbary.EQ.2)THEN
67244 kfqver=1+int((2d0+parj(2))*pyr(0))
67245 kfl3=isign(kfqver,-kfin)
67246 GOTO 130
67247 ENDIF
67248
67249C..x->H+qq: (IDW=proper PARF position for diquark weights)
67250 idw=160
67251 IF(mbary.EQ.1)THEN
67252 IF(mstu(121).EQ.0) idw=150
67253 sqwt=parf(idw+1)
67254 IF(mstu(121).GT.0) sqwt=sqwt*parf(135)*parf(138)**mstu(121)
67255 kfqpop=1+int((2d0+sqwt)*pyr(0))
67256C.. Shift to s-curtain parameters if needed
67257 IF(kfqpop.GE.3.AND.mstj(12).GE.5)THEN
67258 parf(194)=parf(138)*parf(139)
67259 parf(193)=parj(8)+parj(9)
67260 ENDIF
67261 ENDIF
67262
67263C.. x->H+qq: Get vertex quark
67264 IF(mbary.EQ.-1.AND.mstj(12).GE.5)THEN
67265 idw=mstu(122)
67266 mstu(121)=mstu(121)-1
67267 IF(idw.EQ.170) THEN
67268 IF(mstu(121).EQ.0)THEN
67269 ipos=3*min(kfqpop-1,2)+min(kfqold-1,2)
67270 ELSE
67271 ipos=3*3+3*max(0,min(kfqpop-2,1))+min(kfqold-1,2)
67272 ENDIF
67273 ELSE
67274 IF(mstu(121).EQ.0)THEN
67275 ipos=3*5+5*min(kfqpop-1,3)+min(kfqold-1,4)
67276 ELSE
67277 ipos=3*5+5*4+min(kfqold-1,4)
67278 ENDIF
67279 ENDIF
67280 ipos=200+30*ipos+1
67281
67282 imes=-1
67283 rmes=pyr(0)*parf(194)
67284 120 imes=imes+1
67285 rmes=rmes-parf(ipos+imes)
67286 IF(imes.EQ.30) THEN
67287 mstu(121)=-1
67288 kf=-111
67289 RETURN
67290 ENDIF
67291 IF(rmes.GT.0d0) GOTO 120
67292 kmul=imes/5
67293 kfj=2*kmul+1
67294 IF(kmul.EQ.2) kfj=10003
67295 IF(kmul.EQ.3) kfj=10001
67296 IF(kmul.EQ.4) kfj=20003
67297 IF(kmul.EQ.5) kfj=5
67298 idiag=0
67299 kfqver=mod(imes,5)+1
67300 IF(kfqver.GE.kfqold) kfqver=kfqver+1
67301 IF(kfqver.GT.3)THEN
67302 idiag=kfqver-3
67303 kfqver=kfqold
67304 ENDIF
67305 ELSE
67306 IF(mbary.EQ.-1) idw=170
67307 sqwt=parf(idw+2)
67308 IF(kfqpop.EQ.3) sqwt=parf(idw+3)
67309 IF(kfqpop.GT.3) sqwt=parf(idw+3)*(1d0/parf(idw+5)+1d0)/2d0
67310 kfqver=min(3,1+int((2d0+sqwt)*pyr(0)))
67311 IF(kfqpop.LT.3.AND.kfqver.LT.3)THEN
67312 kfqver=kfqpop
67313 IF(pyr(0).GT.parf(idw+4)) kfqver=3-kfqpop
67314 ENDIF
67315 ENDIF
67316
67317C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67318 kflds=3
67319 IF(kfqpop.NE.kfqver)THEN
67320 swt=parf(idw+7)
67321 IF(kfqver.EQ.3) swt=parf(idw+6)
67322 IF(kfqpop.GE.3) swt=parf(idw+5)
67323 IF((1d0+swt)*pyr(0).LT.1d0) kflds=1
67324 ENDIF
67325 kfdiq=900*max(kfqver,kfqpop)+100*(kfqver+kfqpop)+kflds
67326 & +10000*kfqpop
67327 kfl3=isign(kfdiq,kfin)
67328
67329C..x->M+y: flavour for meson.
67330 130 IF(mbary.LE.0)THEN
67331 kfla=max(kfqold,kfqver)
67332 kflb=min(kfqold,kfqver)
67333 kfs=isign(1,kfl1)
67334 IF(kfla.NE.kfqold) kfs=-kfs
67335C... Form meson, with spin and flavour mixing for diagonal states.
67336 IF(mbary.EQ.-1.AND.mstj(12).GE.5)THEN
67337 IF(idiag.GT.0) kf=110*idiag+kfj
67338 IF(idiag.EQ.0) kf=(100*kfla+10*kflb+kfj)*kfs*(-1)**kfla
67339 RETURN
67340 ENDIF
67341 IF(kfla.LE.2) kmul=int(parj(11)+pyr(0))
67342 IF(kfla.EQ.3) kmul=int(parj(12)+pyr(0))
67343 IF(kfla.GE.4) kmul=int(parj(13)+pyr(0))
67344 IF(kmul.EQ.0.AND.parj(14).GT.0d0)THEN
67345 IF(pyr(0).LT.parj(14)) kmul=2
67346 ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0d0)THEN
67347 rmul=pyr(0)
67348 IF(rmul.LT.parj(15)) kmul=3
67349 IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4
67350 IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5
67351 ENDIF
67352 kfls=3
67353 IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
67354 IF(kmul.EQ.5) kfls=5
67355 IF(kfla.NE.kflb)THEN
67356 kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla
67357 ELSE
67358 rmix=pyr(0)
67359 imix=2*kfla+10*kmul
67360 IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+
67361 & int(rmix+parf(imix)))+kfls
67362 IF(kfla.GE.4) kf=110*kfla+kfls
67363 ENDIF
67364 IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)
67365 IF(kmul.EQ.4) kf=kf+isign(20000,kf)
67366
67367C..Optional extra suppression of eta and eta'.
67368C..Allow shift to qq->B+q in old version (set IRANK to 0)
67369 IF(kf.EQ.221.OR.kf.EQ.331)THEN
67370 IF(pyr(0).GT.parj(25+kf/300))THEN
67371 IF(kf2a.GT.0) GOTO 130
67372 IF(mstj(12).LT.4) irank=0
67373 GOTO 110
67374 ENDIF
67375 ENDIF
67376 mstu(121)=0
67377
67378C.. x->B+y: Flavour for baryon
67379 ELSE
67380 kfla=kfqver
67381 IF(kf1a.LE.10) kfla=kfqold
67382 kflb=mod(kfdiq/1000,10)
67383 kflc=mod(kfdiq/100,10)
67384 kflds=mod(kfdiq,10)
67385 kfld=max(kfla,kflb,kflc)
67386 kflf=min(kfla,kflb,kflc)
67387 kfle=kfla+kflb+kflc-kfld-kflf
67388
67389C... SU(6) factors for formation of baryon.
67390 kbary=3
67391 kdmax=5
67392 kflg=kflb
67393 IF(kflb.NE.kflc)THEN
67394 kbary=2*kflds-1
67395 kdmax=1+kflds/2
67396 IF(kflb.GT.2) kdmax=kdmax+2
67397 ENDIF
67398 IF(kfla.NE.kflb.AND.kfla.NE.kflc)THEN
67399 kbary=kbary+1
67400 kflg=kfla
67401 ENDIF
67402
67403 su6max=parf(140+kdmax)
67404 su6dec=parj(18)
67405 su6s =parf(146)
67406 IF(mstj(12).GE.5.AND.irank.EQ.0) THEN
67407 su6max=1d0
67408 su6dec=1d0
67409 su6s =1d0
67410 ENDIF
67411 su6oct=parf(60+kbary)
67412 IF(kflg.GT.max(kfla+kflb-kflg,2))THEN
67413 su6oct=su6oct*4*su6s/(3*su6s+1)
67414 IF(kbary.EQ.2) su6oct=parf(60+kbary)*4/(3*su6s+1)
67415 ELSE
67416 IF(kbary.EQ.6) su6oct=su6oct*(3+su6s)/(3*su6s+1)
67417 ENDIF
67418 su6wt=su6oct+su6dec*parf(70+kbary)
67419
67420C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67421 IF(su6wt.LT.pyr(0)*su6max.AND.kf2a.EQ.0)THEN
67422 mstu(121)=0
67423 IF(mstj(12).LE.2.AND.mbary.EQ.1) mstu(121)=-1
67424 GOTO 110
67425 ENDIF
67426
67427C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67428 ksig=1
67429 kfls=2
67430 IF(su6wt*pyr(0).GT.su6oct) kfls=4
67431 IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf)THEN
67432 ksig=kflds/3
67433 IF(kfla.NE.kfld) ksig=int(3*su6s/(3*su6s+kflds**2)+pyr(0))
67434 ENDIF
67435 kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)
67436 IF(ksig.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)
67437 ENDIF
67438 RETURN
67439
67440C...Use tabulated probabilities to select new flavour and hadron.
67441 140 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN
67442 kt3l=1
67443 kt3u=6
67444 ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN
67445 kt3l=1
67446 kt3u=6
67447 ELSEIF(ktab2.EQ.0) THEN
67448 kt3l=1
67449 kt3u=22
67450 ELSE
67451 kt3l=ktab2
67452 kt3u=ktab2
67453 ENDIF
67454 rfl=0d0
67455 DO 160 kts=0,2
67456 DO 150 kt3=kt3l,kt3u
67457 rfl=rfl+parf(120+80*ktab1+25*kts+kt3)
67458 150 CONTINUE
67459 160 CONTINUE
67460 rfl=pyr(0)*rfl
67461 DO 180 kts=0,2
67462 ktabs=kts
67463 DO 170 kt3=kt3l,kt3u
67464 ktab3=kt3
67465 rfl=rfl-parf(120+80*ktab1+25*kts+kt3)
67466 IF(rfl.LE.0d0) GOTO 190
67467 170 CONTINUE
67468 180 CONTINUE
67469 190 CONTINUE
67470
67471C...Reconstruct flavour of produced quark/diquark.
67472 IF(ktab3.LE.6) THEN
67473 kfl3a=ktab3
67474 kfl3b=0
67475 kfl3=isign(kfl3a,kfl1*(2*ktab1-13))
67476 ELSE
67477 kfl3a=1
67478 IF(ktab3.GE.8) kfl3a=2
67479 IF(ktab3.GE.11) kfl3a=3
67480 IF(ktab3.GE.16) kfl3a=4
67481 kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2
67482 kfl3=1000*kfl3a+100*kfl3b+1
67483 IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=
67484 & kfl3+2
67485 kfl3=isign(kfl3,kfl1*(13-2*ktab1))
67486 ENDIF
67487
67488C...Reconstruct meson code.
67489 IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.
67490 &kfl3b.NE.0)) THEN
67491 rfl=pyr(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
67492 & 25*ktabs)+parf(145+80*ktab1+25*ktabs))
67493 kf=110+2*ktabs+1
67494 IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1
67495 IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+
67496 & 25*ktabs)) kf=330+2*ktabs+1
67497 ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN
67498 kfla=max(ktab1,ktab3)
67499 kflb=min(ktab1,ktab3)
67500 kfs=isign(1,kfl1)
67501 IF(kfla.NE.kf1a) kfs=-kfs
67502 kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
67503 ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN
67504 kfs=isign(1,kfl1)
67505 IF(kfl1a.EQ.kfl3a) THEN
67506 kfla=max(kfl1b,kfl3b)
67507 kflb=min(kfl1b,kfl3b)
67508 IF(kfla.NE.kfl1b) kfs=-kfs
67509 ELSEIF(kfl1a.EQ.kfl3b) THEN
67510 kfla=kfl3a
67511 kflb=kfl1b
67512 kfs=-kfs
67513 ELSEIF(kfl1b.EQ.kfl3a) THEN
67514 kfla=kfl1a
67515 kflb=kfl3b
67516 ELSEIF(kfl1b.EQ.kfl3b) THEN
67517 kfla=max(kfl1a,kfl3a)
67518 kflb=min(kfl1a,kfl3a)
67519 IF(kfla.NE.kfl1a) kfs=-kfs
67520 ELSE
67521 CALL pyerrm(2,'(PYKFDI:) no matching flavours for qq -> qq')
67522 GOTO 100
67523 ENDIF
67524 kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla
67525
67526C...Reconstruct baryon code.
67527 ELSE
67528 IF(ktab1.GE.7) THEN
67529 kfla=kfl3a
67530 kflb=kfl1a
67531 kflc=kfl1b
67532 ELSE
67533 kfla=kfl1a
67534 kflb=kfl3a
67535 kflc=kfl3b
67536 ENDIF
67537 kfld=max(kfla,kflb,kflc)
67538 kflf=min(kfla,kflb,kflc)
67539 kfle=kfla+kflb+kflc-kfld-kflf
67540 IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)
67541 IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)
67542 ENDIF
67543
67544C...Check that constructed flavour code is an allowed one.
67545 IF(kfl2.NE.0) kfl3=0
67546 kc=pycomp(kf)
67547 IF(kc.EQ.0) THEN
67548 CALL pyerrm(2,'(PYKFDI:) user-defined flavour probabilities '//
67549 & 'failed')
67550 GOTO 100
67551 ENDIF
67552
67553 RETURN
67554 END
67555
67556C*********************************************************************
67557
67558C...PYNMES
67559C...Generates number of popcorn mesons and stores some relevant
67560C...parameters.
67561
67562 SUBROUTINE pynmes(KFDIQ)
67563
67564C...Double precision and integer declarations.
67565 IMPLICIT DOUBLE PRECISION(a-h, o-z)
67566 IMPLICIT INTEGER(I-N)
67567 INTEGER PYK,PYCHGE,PYCOMP
67568C...Commonblocks.
67569 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67570 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67571 SAVE /pydat1/,/pydat2/
67572
67573 mstu(121)=0
67574 IF(mstj(12).LT.2) RETURN
67575
67576C..Old version: Get 1 or 0 popcorn mesons
67577 IF(mstj(12).LT.5)THEN
67578 popwt=parf(131)
67579 IF(kfdiq.NE.0) THEN
67580 kfdiqa=iabs(kfdiq)
67581 kfa=mod(kfdiqa/1000,10)
67582 kfb=mod(kfdiqa/100,10)
67583 kfs=mod(kfdiqa,10)
67584 popwt=parf(132)
67585 IF(kfa.EQ.3) popwt=parf(133)
67586 IF(kfb.EQ.3) popwt=parf(134)
67587 IF(kfs.EQ.1) popwt=popwt*sqrt(parj(4))
67588 ENDIF
67589 mstu(121)=int(popwt/(1d0+popwt)+pyr(0))
67590 RETURN
67591 ENDIF
67592
67593C..New version: Store popcorn- or rank 0 diquark parameters
67594 mstu(122)=170
67595 parf(193)=parj(8)
67596 parf(194)=parf(139)
67597 IF(kfdiq.NE.0) THEN
67598 mstu(122)=180
67599 parf(193)=parj(10)
67600 parf(194)=parf(140)
67601 ENDIF
67602 IF(parf(194).LT.1d-5.OR.parf(194).GT.1d0-1d-5) THEN
67603 IF(parf(194).GT.1d0-1d-5) CALL pyerrm(9,
67604 & '(PYNMES:) Neglecting too large popcorn possibility')
67605 RETURN
67606 ENDIF
67607
67608C..New version: Get number of popcorn mesons
67609 100 rtst=pyr(0)
67610 mstu(121)=-1
67611 110 mstu(121)=mstu(121)+1
67612 rtst=rtst/parf(194)
67613 IF(rtst.LT.1d0) GOTO 110
67614 IF(kfdiq.EQ.0.AND.pyr(0)*(2d0+parf(135)*parf(161)).GT.
67615 & (2d0+parf(135)*parf(161)*parf(138)**mstu(121))) GOTO 100
67616 RETURN
67617 END
67618
67619C***************************************************************
67620
67621C...PYKFIN
67622C...Precalculates a set of diquark and popcorn weights.
67623
67624 SUBROUTINE pykfin
67625
67626C...Double precision and integer declarations.
67627 IMPLICIT DOUBLE PRECISION(a-h, o-z)
67628 IMPLICIT INTEGER(I-N)
67629 INTEGER PYK,PYCHGE,PYCOMP
67630C...Commonblocks.
67631 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67632 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67633 SAVE /pydat1/,/pydat2/
67634
67635 dimension su6(12),su6m(7),qbb(7),qbm(7),dmb(14)
67636
67637
67638 mstu(123)=1
67639C..Diquark indices for dimensional variables
67640 iud1=1
67641 iuu1=2
67642 ius0=3
67643 isu0=4
67644 ius1=5
67645 isu1=6
67646 iss1=7
67647
67648C.. *** SU(6) factors **
67649C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67650 parf(146)=1d0
67651 IF(mstj(12).GE.5) parf(146)=3d0*parj(18)/(2d0*parj(18)+1d0)
67652 IF(parj(18).LT.1d0-1d-5.AND.mstj(12).LT.5) CALL pyerrm(9,
67653 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67654 DO 100 i=1,6
67655 su6(i)=parf(60+i)
67656 su6(6+i)=su6(i)*4*parf(146)/(3*parf(146)+1)
67657 100 CONTINUE
67658 su6(8)=su6(2)*4/(3*parf(146)+1)
67659 su6(6)=su6(6)*(3+parf(146))/(3*parf(146)+1)
67660 DO 110 i=1,6
67661 su6(i)=su6(i)+parj(18)*parf(70+i)
67662 su6(6+i)=su6(6+i)+parj(18)*parf(70+i)
67663 110 CONTINUE
67664
67665C..SU(6)max q q' s,c,b
67666 su6mud =max(su6(1) , su6(8) )
67667 su6m(iud1)=max(su6(5) , su6(12))
67668 su6m(isu0)=max(su6(7) ,su6(2),su6mud )
67669 su6m(iuu1)=max(su6(3) ,su6(4),su6(10))
67670 su6m(isu1)=max(su6(11),su6(6),su6m(iud1))
67671 su6m(ius0)=su6m(isu0)
67672 su6m(iss1)=su6m(iuu1)
67673 su6m(ius1)=su6m(isu1)
67674
67675C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67676 parf(141)=su6mud
67677 parf(142)=su6m(iud1)
67678 parf(143)=su6m(isu0)
67679 parf(144)=su6m(isu1)
67680 parf(145)=su6m(iss1)
67681
67682C..diquark SU(6) survival =
67683C..sum over quark (quark tunnel weight)*(SU(6)).
67684 pud0=(2d0*su6(1)+parj(2)*su6(8))
67685 dmb(isu0)=(su6(7)+su6(2)+parj(2)*su6(1))/pud0
67686 dmb(ius0)=dmb(isu0)
67687 dmb(iss1)=(2d0*su6(4)+parj(2)*su6(3))/pud0
67688 dmb(iuu1)=(su6(3)+su6(4)+parj(2)*su6(10))/pud0
67689 dmb(isu1)=(su6(11)+su6(6)+parj(2)*su6(5))/pud0
67690 dmb(ius1)=dmb(isu1)
67691 dmb(iud1)=(2d0*su6(5)+parj(2)*su6(12))/pud0
67692
67693C.. *** Tunneling factors for Diquark production***
67694C.. T: half a curtain pair = sqrt(curtain pair factor)
67695 IF(mstj(12).GE.5) THEN
67696 pmud0=pymass(2101)
67697 pmud1=pymass(2103)-pmud0
67698 pmus0=pymass(3201)-pmud0
67699 pmus1=pymass(3203)-pmus0-pmud0
67700 pmss1=pymass(3303)-pmus0-pmud0
67701 qbb(isu0)=exp(-(parj(9)+parj(8))*pmus0-parj(9)*parf(191))
67702 qbb(ius0)=exp(-parj(8)*pmus0)
67703 qbb(iss1)=exp(-(parj(9)+parj(8))*pmss1)*qbb(isu0)
67704 qbb(iuu1)=exp(-parj(8)*pmud1)
67705 qbb(isu1)=exp(-(parj(9)+parj(8))*pmus1)*qbb(isu0)
67706 qbb(ius1)=exp(-parj(8)*pmus1)*qbb(ius0)
67707 qbb(iud1)=qbb(iuu1)
67708 ELSE
67709 par2m=sqrt(parj(2))
67710 par3m=sqrt(parj(3))
67711 par4m=sqrt(parj(4))
67712 qbb(isu0)=par2m*par3m
67713 qbb(ius0)=par3m
67714 qbb(iss1)=par2m*parj(3)*par4m
67715 qbb(iuu1)=par4m
67716 qbb(isu1)=par4m*qbb(isu0)
67717 qbb(ius1)=par4m*qbb(ius0)
67718 qbb(iud1)=par4m
67719 ENDIF
67720
67721C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67722 qbm(isu0)=qbb(isu0)
67723 qbm(ius0)=parj(2)*qbb(ius0)
67724 qbm(iss1)=parj(2)*6d0*qbb(iss1)
67725 qbm(iuu1)=6d0*qbb(iuu1)
67726 qbm(isu1)=3d0*qbb(isu1)
67727 qbm(ius1)=parj(2)*3d0*qbb(ius1)
67728 qbm(iud1)=3d0*qbb(iud1)
67729
67730C.. Combine T and tau to diquark weight for q-> B+B+..
67731 DO 120 i=1,7
67732 qbb(i)=qbb(i)*qbm(i)
67733 120 CONTINUE
67734
67735 IF(mstj(12).GE.5)THEN
67736C..New version: tau for rank 0 diquark.
67737 dmb(7+isu0)=exp(-parj(10)*pmus0)
67738 dmb(7+ius0)=parj(2)*dmb(7+isu0)
67739 dmb(7+iss1)=6d0*parj(2)*exp(-parj(10)*pmss1)*dmb(7+isu0)
67740 dmb(7+iuu1)=6d0*exp(-parj(10)*pmud1)
67741 dmb(7+isu1)=3d0*exp(-parj(10)*pmus1)*dmb(7+isu0)
67742 dmb(7+ius1)=parj(2)*dmb(7+isu1)
67743 dmb(7+iud1)=dmb(7+iuu1)/2d0
67744
67745C..New version: curtain flavour ratios.
67746C.. s/u for q->B+M+...
67747C.. s/u for rank 0 diquark: su -> ...M+B+...
67748C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67749 wu=1d0+qbm(iud1)+qbm(ius0)+qbm(ius1)+qbm(iuu1)
67750 parf(135)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/wu
67751 wu=1d0+dmb(7+iud1)+dmb(7+ius0)+dmb(7+ius1)+dmb(7+iuu1)
67752 parf(136)=(2d0*(dmb(7+isu0)+dmb(7+isu1))+dmb(7+iss1))/wu
67753 parf(137)=(dmb(7+isu0)+dmb(7+isu1))*
67754 & (2d0+dmb(7+iss1)/(2d0*dmb(7+isu1)))/wu
67755 ELSE
67756C..Old version: reset unused rank 0 diquark weights and
67757C.. unused diquark SU(6) survival weights
67758 DO 130 i=1,7
67759 IF(mstj(12).LT.3) dmb(i)=1d0
67760 dmb(7+i)=1d0
67761 130 CONTINUE
67762
67763C..Old version: Shuffle PARJ(7) into tau
67764 qbm(ius0)=qbm(ius0)*parj(7)
67765 qbm(iss1)=qbm(iss1)*parj(7)
67766 qbm(ius1)=qbm(ius1)*parj(7)
67767
67768C..Old version: curtain flavour ratios.
67769C.. s/u for q->B+M+...
67770C.. s/u for rank 0 diquark: su -> ...M+B+...
67771C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67772 wu=1d0+qbm(iud1)+qbm(ius0)+qbm(ius1)+qbm(iuu1)
67773 parf(135)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/wu
67774 parf(136)=parf(135)*parj(6)*qbm(isu0)/qbm(ius0)
67775 parf(137)=(1d0+qbm(iud1))*(2d0+qbm(ius0))/wu
67776 ENDIF
67777
67778C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67779C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67780 DO 140 i=1,7
67781 dmb(7+i)=dmb(7+i)*dmb(i)
67782 dmb(i)=dmb(i)*qbm(i)
67783 qbm(i)=qbm(i)*su6m(i)/su6mud
67784 qbb(i)=qbb(i)*su6m(i)/su6mud
67785 140 CONTINUE
67786
67787C.. *** Popcorn factors ***
67788
67789 IF(mstj(12).LT.5)THEN
67790C.. Old version: Resulting popcorn weights.
67791 parf(138)=parj(6)
67792 ws=parf(135)*parf(138)
67793 wq=wu*parj(5)/3d0
67794 parf(132)=wq*qbm(iud1)/qbb(iud1)
67795 parf(133)=wq*
67796 & (qbm(ius1)/qbb(ius1)+ws*qbm(isu1)/qbb(isu1))/2d0
67797 parf(134)=wq*ws*qbm(iss1)/qbb(iss1)
67798 parf(131)=wq*(1d0+qbm(iud1)+qbm(iuu1)+qbm(ius0)+qbm(ius1)+
67799 & ws*(qbm(isu0)+qbm(isu1)+qbm(iss1)/2d0))/
67800 & (1d0+qbb(iud1)+qbb(iuu1)+
67801 & 2d0*(qbb(ius0)+qbb(ius1))+qbb(iss1)/2d0)
67802 ELSE
67803C..New version: Store weights for popcorn mesons,
67804C..get prel. popcorn weights.
67805 DO 150 ipos=201,1400
67806 parf(ipos)=0d0
67807 150 CONTINUE
67808 DO 160 i=138,140
67809 parf(i)=0d0
67810 160 CONTINUE
67811 ipos=200
67812 parf(193)=parj(8)
67813 DO 240 mr=0,7,7
67814 IF(mr.EQ.7) parf(193)=parj(10)
67815 sqwt=2d0*(dmb(mr+ius0)+dmb(mr+ius1))/
67816 & (1d0+dmb(mr+iud1)+dmb(mr+iuu1))
67817 qqwt=dmb(mr+iuu1)/(1d0+dmb(mr+iud1)+dmb(mr+iuu1))
67818 DO 230 nmes=0,1
67819 IF(nmes.EQ.1) sqwt=parj(2)
67820 DO 220 kfqpop=1,4
67821 IF(mr.EQ.0.AND.kfqpop.GT.3) GOTO 220
67822 IF(nmes.EQ.0.AND.kfqpop.GE.3)THEN
67823 sqwt=dmb(mr+iss1)/(dmb(mr+isu0)+dmb(mr+isu1))
67824 qqwt=0.5d0
67825 IF(mr.EQ.0) parf(193)=parj(8)+parj(9)
67826 IF(kfqpop.EQ.4) sqwt=sqwt*(1d0/dmb(7+isu1)+1d0)/2d0
67827 ENDIF
67828 DO 210 kfqold =1,5
67829 IF(mr.EQ.0.AND.kfqold.GT.3) GOTO 210
67830 IF(nmes.EQ.1) THEN
67831 IF(mr.EQ.0.AND.kfqpop.EQ.1) GOTO 210
67832 IF(mr.EQ.7.AND.kfqpop.NE.1) GOTO 210
67833 ENDIF
67834 wttot=0d0
67835 wtfail=0d0
67836 DO 190 kmul=0,5
67837 pjwt=parj(12+kmul)
67838 IF(kmul.EQ.0) pjwt=1d0-parj(14)
67839 IF(kmul.EQ.1) pjwt=1d0-parj(15)-parj(16)-parj(17)
67840 IF(pjwt.LE.0d0) GOTO 190
67841 IF(pjwt.GT.1d0) pjwt=1d0
67842 imes=5*kmul
67843 imix=2*kfqold+10*kmul
67844 kfj=2*kmul+1
67845 IF(kmul.EQ.2) kfj=10003
67846 IF(kmul.EQ.3) kfj=10001
67847 IF(kmul.EQ.4) kfj=20003
67848 IF(kmul.EQ.5) kfj=5
67849 DO 180 kfqver =1,3
67850 kfla=max(kfqold,kfqver)
67851 kflb=min(kfqold,kfqver)
67852 swt=parj(11+kfla/3+kfla/4)
67853 IF(kmul.EQ.0.OR.kmul.EQ.2) swt=1d0-swt
67854 swt=swt*pjwt
67855 qwt=sqwt/(2d0+sqwt)
67856 IF(kfqver.LT.3)THEN
67857 IF(kfqver.EQ.kfqpop) qwt=(1d0-qwt)*qqwt
67858 IF(kfqver.NE.kfqpop) qwt=(1d0-qwt)*(1d0-qqwt)
67859 ENDIF
67860 IF(kfqver.NE.kfqold)THEN
67861 imes=imes+1
67862 kfm=100*kfla+10*kflb+kfj
67863 pmm=pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
67864 parf(ipos+imes)=qwt*swt*exp(-parf(193)*pmm)
67865 wttot=wttot+parf(ipos+imes)
67866 ELSE
67867 DO 170 id=3,5
67868 IF(id.EQ.3) dwt=1d0-parf(imix-1)
67869 IF(id.EQ.4) dwt=parf(imix-1)-parf(imix)
67870 IF(id.EQ.5) dwt=parf(imix)
67871 kfm=110*(id-2)+kfj
67872 pmm=pmas(pycomp(kfm),1)-pmas(pycomp(kfm),3)
67873 parf(ipos+5*kmul+id)=qwt*swt*dwt*exp(-parf(193)*pmm)
67874 IF(kmul.EQ.0.AND.id.GT.3) THEN
67875 wtfail=wtfail+qwt*swt*dwt*(1d0-parj(21+id))
67876 parf(ipos+5*kmul+id)=
67877 & parf(ipos+5*kmul+id)*parj(21+id)
67878 ENDIF
67879 wttot=wttot+parf(ipos+5*kmul+id)
67880 170 CONTINUE
67881 ENDIF
67882 180 CONTINUE
67883 190 CONTINUE
67884 DO 200 imes=1,30
67885 parf(ipos+imes)=parf(ipos+imes)/(1d0-wtfail)
67886 200 CONTINUE
67887 IF(mr.EQ.7) parf(140)=
67888 & max(parf(140),wttot/(1d0-wtfail))
67889 IF(mr.EQ.0) parf(139-kfqpop/3)=
67890 & max(parf(139-kfqpop/3),wttot/(1d0-wtfail))
67891 ipos=ipos+30
67892 210 CONTINUE
67893 220 CONTINUE
67894 230 CONTINUE
67895 240 CONTINUE
67896 IF(parf(139).GT.1d-10) parf(138)=parf(138)/parf(139)
67897 mstu(121)=0
67898
67899 ENDIF
67900
67901C..Recombine diquark weights to flavour and spin ratios
67902 parf(151)=(2d0*(qbb(isu0)+qbb(isu1))+qbb(iss1))/
67903 & (1d0+qbb(iud1)+qbb(iuu1)+qbb(ius0)+qbb(ius1))
67904 parf(152)=2d0*(qbb(ius0)+qbb(ius1))/(1d0+qbb(iud1)+qbb(iuu1))
67905 parf(153)=qbb(iss1)/(qbb(isu0)+qbb(isu1))
67906 parf(154)=qbb(iuu1)/(1d0+qbb(iud1)+qbb(iuu1))
67907 parf(155)=qbb(isu1)/qbb(isu0)
67908 parf(156)=qbb(ius1)/qbb(ius0)
67909 parf(157)=qbb(iud1)
67910
67911 parf(161)=(2d0*(qbm(isu0)+qbm(isu1))+qbm(iss1))/
67912 & (1d0+qbm(iud1)+qbm(iuu1)+qbm(ius0)+qbm(ius1))
67913 parf(162)=2d0*(qbm(ius0)+qbm(ius1))/(1d0+qbm(iud1)+qbm(iuu1))
67914 parf(163)=qbm(iss1)/(qbm(isu0)+qbm(isu1))
67915 parf(164)=qbm(iuu1)/(1d0+qbm(iud1)+qbm(iuu1))
67916 parf(165)=qbm(isu1)/qbm(isu0)
67917 parf(166)=qbm(ius1)/qbm(ius0)
67918 parf(167)=qbm(iud1)
67919
67920 parf(171)=(2d0*(dmb(isu0)+dmb(isu1))+dmb(iss1))/
67921 & (1d0+dmb(iud1)+dmb(iuu1)+dmb(ius0)+dmb(ius1))
67922 parf(172)=2d0*(dmb(ius0)+dmb(ius1))/(1d0+dmb(iud1)+dmb(iuu1))
67923 parf(173)=dmb(iss1)/(dmb(isu0)+dmb(isu1))
67924 parf(174)=dmb(iuu1)/(1d0+dmb(iud1)+dmb(iuu1))
67925 parf(175)=dmb(isu1)/dmb(isu0)
67926 parf(176)=dmb(ius1)/dmb(ius0)
67927 parf(177)=dmb(iud1)
67928
67929 parf(185)=dmb(7+isu1)/dmb(7+isu0)
67930 parf(186)=dmb(7+ius1)/dmb(7+ius0)
67931 parf(187)=dmb(7+iud1)
67932
67933 RETURN
67934 END
67935
67936
67937C*********************************************************************
67938
67939C...PYPTDI
67940C...Generates transverse momentum according to a Gaussian.
67941
67942 SUBROUTINE pyptdi(KFL,PX,PY)
67943
67944C...Double precision and integer declarations.
67945 IMPLICIT DOUBLE PRECISION(a-h, o-z)
67946 IMPLICIT INTEGER(I-N)
67947 INTEGER PYK,PYCHGE,PYCOMP
67948C...Commonblocks.
67949 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67950 SAVE /pydat1/
67951
67952C...Generate p_T and azimuthal angle, gives p_x and p_y.
67953 kfla=iabs(kfl)
67954 pt=parj(21)*sqrt(-log(max(1d-10,pyr(0))))
67955 IF(parj(23).GT.pyr(0)) pt=parj(24)*pt
67956 IF(mstj(91).EQ.1) pt=parj(22)*pt
67957 IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0d0
67958 phi=paru(2)*pyr(0)
67959 px=pt*cos(phi)
67960 py=pt*sin(phi)
67961
67962 RETURN
67963 END
67964
67965C*********************************************************************
67966
67967C...PYZDIS
67968C...Generates the longitudinal splitting variable z.
67969
67970 SUBROUTINE pyzdis(KFL1,KFL2,PR,Z)
67971
67972C...Double precision and integer declarations.
67973 IMPLICIT DOUBLE PRECISION(a-h, o-z)
67974 IMPLICIT INTEGER(I-N)
67975 INTEGER PYK,PYCHGE,PYCOMP
67976C...Commonblocks.
67977 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
67978 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
67979 SAVE /pydat1/,/pydat2/
67980
67981C...Check if heavy flavour fragmentation.
67982 kfla=iabs(kfl1)
67983 kflb=iabs(kfl2)
67984 kflh=kfla
67985 IF(kfla.GE.10) kflh=mod(kfla/1000,10)
67986
67987C...Lund symmetric scaling function: determine parameters of shape.
67988 IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.
67989 &mstj(11).GE.4) THEN
67990 fa=parj(41)
67991 IF(mstj(91).EQ.1) fa=parj(43)
67992 IF(kflb.GE.10) fa=fa+parj(45)
67993 fbb=parj(42)
67994 IF(mstj(91).EQ.1) fbb=parj(44)
67995 fb=fbb*pr
67996 fc=1d0
67997 IF(kfla.GE.10) fc=fc-parj(45)
67998 IF(kflb.GE.10) fc=fc+parj(45)
67999 IF(mstj(11).GE.4.AND.(kflh.EQ.4.OR.kflh.EQ.5)) THEN
68000 fred=parj(46)
68001 IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)
68002 fc=fc+fred*fbb*parf(100+kflh)**2
68003 ENDIF
68004 mc=1
68005 IF(abs(fc-1d0).GT.0.01d0) mc=2
68006
68007C...Determine position of maximum. Special cases for a = 0 or a = c.
68008 IF(fa.LT.0.02d0) THEN
68009 ma=1
68010 zmax=1d0
68011 IF(fc.GT.fb) zmax=fb/fc
68012 ELSEIF(abs(fc-fa).LT.0.01d0) THEN
68013 ma=2
68014 zmax=fb/(fb+fc)
68015 ELSE
68016 ma=3
68017 zmax=0.5d0*(fb+fc-sqrt((fb-fc)**2+4d0*fa*fb))/(fc-fa)
68018 IF(zmax.GT.0.9999d0.AND.fb.GT.100d0) zmax=min(zmax,1d0-fa/fb)
68019 ENDIF
68020
68021C...Subdivide z range if distribution very peaked near endpoint.
68022 mmax=2
68023 IF(zmax.LT.0.1d0) THEN
68024 mmax=1
68025 zdiv=2.75d0*zmax
68026 IF(mc.EQ.1) THEN
68027 fint=1d0-log(zdiv)
68028 ELSE
68029 zdivc=zdiv**(1d0-fc)
68030 fint=1d0+(1d0-1d0/zdivc)/(fc-1d0)
68031 ENDIF
68032 ELSEIF(zmax.GT.0.85d0.AND.fb.GT.1d0) THEN
68033 mmax=3
68034 fscb=sqrt(4d0+(fc/fb)**2)
68035 zdiv=fscb-1d0/zmax-(fc/fb)*log(zmax*0.5d0*(fscb+fc/fb))
68036 IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1d0-zmax)
68037 zdiv=min(zmax,max(0d0,zdiv))
68038 fint=1d0+fb*(1d0-zdiv)
68039 ENDIF
68040
68041C...Choice of z, preweighted for peaks at low or high z.
68042 100 z=pyr(0)
68043 fpre=1d0
68044 IF(mmax.EQ.1) THEN
68045 IF(fint*pyr(0).LE.1d0) THEN
68046 z=zdiv*z
68047 ELSEIF(mc.EQ.1) THEN
68048 z=zdiv**z
68049 fpre=zdiv/z
68050 ELSE
68051 z=(zdivc+z*(1d0-zdivc))**(1d0/(1d0-fc))
68052 fpre=(zdiv/z)**fc
68053 ENDIF
68054 ELSEIF(mmax.EQ.3) THEN
68055 IF(fint*pyr(0).LE.1d0) THEN
68056 z=zdiv+log(z)/fb
68057 fpre=exp(fb*(z-zdiv))
68058 ELSE
68059 z=zdiv+z*(1d0-zdiv)
68060 ENDIF
68061 ENDIF
68062
68063C...Weighting according to correct formula.
68064 IF(z.LE.0d0.OR.z.GE.1d0) GOTO 100
68065 fexp=fc*log(zmax/z)+fb*(1d0/zmax-1d0/z)
68066 IF(ma.GE.2) fexp=fexp+fa*log((1d0-z)/(1d0-zmax))
68067 fval=exp(max(-50d0,min(50d0,fexp)))
68068 IF(fval.LT.pyr(0)*fpre) GOTO 100
68069
68070C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68071 ELSE
68072 fc=parj(50+max(1,kflh))
68073 IF(mstj(91).EQ.1) fc=parj(59)
68074 110 z=pyr(0)
68075 IF(fc.GE.0d0.AND.fc.LE.1d0) THEN
68076 IF(fc.GT.pyr(0)) z=1d0-z**(1d0/3d0)
68077 ELSEIF(fc.GT.-1.AND.fc.LT.0d0) THEN
68078 IF(-4d0*fc*z*(1d0-z)**2.LT.pyr(0)*((1d0-z)**2-fc*z)**2)
68079 & GOTO 110
68080 ELSE
68081 IF(fc.GT.0d0) z=1d0-z**(1d0/fc)
68082 IF(fc.LT.0d0) z=z**(-1d0/fc)
68083 ENDIF
68084 ENDIF
68085
68086 RETURN
68087 END
68088
68089C*********************************************************************
68090
68091C...PYSHOW
68092C...Generates timelike parton showers from given partons.
68093
68094 SUBROUTINE pyshow(IP1,IP2,QMAX)
68095
68096C...Double precision and integer declarations.
68097 IMPLICIT DOUBLE PRECISION(a-h, o-z)
68098 IMPLICIT INTEGER(I-N)
68099 INTEGER PYK,PYCHGE,PYCOMP
68100C...Parameter statement to help give large particle numbers.
68101 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
68102 &kexcit=4000000,kdimen=5000000)
68103 parameter(maxnur=1000)
68104C...Commonblocks.
68105 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
68106 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
68107 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
68108 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
68109 common/pypars/mstp(200),parp(200),msti(200),pari(200)
68110 common/pyint1/mint(400),vint(400)
68111 SAVE /pypart/,/pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/
68112C...Local arrays.
68113 dimension pmth(5,140),ps(5),pma(100),pmsd(100),iep(100),ipa(100),
68114 &kfla(100),kfld(100),kfl(100),itry(100),isi(100),isl(100),dp(100),
68115 &dpt(5,4),ksh(0:140),kcii(2),niis(2),iiis(2,2),theiis(2,2),
68116 &phiiis(2,2),isii(2),isset(2),iscol(0:140),ischg(0:140),
68117 &iref(1000)
68118
68119C...Check that QMAX not too low.
68120 IF(mstj(41).LE.0) THEN
68121 RETURN
68122 ELSEIF(mstj(41).EQ.1.OR.mstj(41).EQ.11) THEN
68123 IF(qmax.LE.parj(82).AND.ip2.GE.-80) RETURN
68124 ELSE
68125 IF(qmax.LE.min(parj(82),parj(83),parj(90)).AND.ip2.GE.-80)
68126 & RETURN
68127 ENDIF
68128
68129C...Store positions of shower initiating partons.
68130 mpspd=0
68131 IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN
68132 npa=1
68133 ipa(1)=ip1
68134 ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-
68135 & mstu(32))) THEN
68136 npa=2
68137 ipa(1)=ip1
68138 ipa(2)=ip2
68139 ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0
68140 & .AND.ip2.GE.-80) THEN
68141 npa=iabs(ip2)
68142 DO 100 i=1,npa
68143 ipa(i)=ip1+i-1
68144 100 CONTINUE
68145 ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.
68146 &ip2.EQ.-100) THEN
68147 mpspd=1
68148 npa=2
68149 ipa(1)=ip1+6
68150 ipa(2)=ip1+7
68151 ELSE
68152 CALL pyerrm(12,
68153 & '(PYSHOW:) failed to reconstruct showering system')
68154 IF(mstu(21).GE.1) RETURN
68155 ENDIF
68156
68157C...Send off to PYPTFS for pT-ordered evolution if requested,
68158C...if at least 2 partons, and without predefined shower branchings.
68159 IF((mstj(41).EQ.11.OR.mstj(41).EQ.12).AND.npa.GE.2.AND.
68160 &mpspd.EQ.0) THEN
68161 npart=npa
68162 DO 110 ii=1,npart
68163 ipart(ii)=ipa(ii)
68164 ptpart(ii)=0.5d0*qmax
68165 110 CONTINUE
68166 CALL pyptfs(2,0.5d0*qmax,0d0,ptgen)
68167 RETURN
68168 ENDIF
68169
68170C...Initialization of cutoff masses etc.
68171 DO 120 ifl=0,40
68172 iscol(ifl)=0
68173 ischg(ifl)=0
68174 ksh(ifl)=0
68175 120 CONTINUE
68176 iscol(21)=1
68177 ksh(21)=1
68178 pmth(1,21)=pymass(21)
68179 pmth(2,21)=sqrt(pmth(1,21)**2+0.25d0*parj(82)**2)
68180 pmth(3,21)=2d0*pmth(2,21)
68181 pmth(4,21)=pmth(3,21)
68182 pmth(5,21)=pmth(3,21)
68183 pmth(1,22)=pymass(22)
68184 pmth(2,22)=sqrt(pmth(1,22)**2+0.25d0*parj(83)**2)
68185 pmth(3,22)=2d0*pmth(2,22)
68186 pmth(4,22)=pmth(3,22)
68187 pmth(5,22)=pmth(3,22)
68188 pmqth1=parj(82)
68189 IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))
68190 pmqt1e=min(pmqth1,parj(90))
68191 pmqth2=pmth(2,21)
68192 IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))
68193 pmqt2e=min(pmqth2,0.5d0*parj(90))
68194 DO 130 ifl=1,5
68195 iscol(ifl)=1
68196 IF(mstj(41).GE.2) ischg(ifl)=1
68197 ksh(ifl)=1
68198 pmth(1,ifl)=pymass(ifl)
68199 pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*pmqth1**2)
68200 pmth(3,ifl)=pmth(2,ifl)+pmqth2
68201 pmth(4,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(82)**2)+pmth(2,21)
68202 pmth(5,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(83)**2)+pmth(2,22)
68203 130 CONTINUE
68204 DO 140 ifl=11,15,2
68205 IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ischg(ifl)=1
68206 IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ksh(ifl)=1
68207 pmth(1,ifl)=pymass(ifl)
68208 pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(90)**2)
68209 pmth(3,ifl)=pmth(2,ifl)+0.5d0*parj(90)
68210 pmth(4,ifl)=pmth(3,ifl)
68211 pmth(5,ifl)=pmth(3,ifl)
68212 140 CONTINUE
68213 pt2min=max(0.5d0*parj(82),1.1d0*parj(81))**2
68214 alams=parj(81)**2
68215 alfm=log(pt2min/alams)
68216
68217C...Check on phase space available for emission.
68218 irej=0
68219 DO 150 j=1,5
68220 ps(j)=0d0
68221 150 CONTINUE
68222 pm=0d0
68223 kfla(2)=0
68224 DO 170 i=1,npa
68225 kfla(i)=iabs(k(ipa(i),2))
68226 pma(i)=p(ipa(i),5)
68227C...Special cutoff masses for initial partons (may be a heavy quark,
68228C...squark, ..., and need not be on the mass shell).
68229 ir=30+i
68230 IF(npa.LE.1) iref(i)=ir
68231 IF(npa.GE.2) iref(i+1)=ir
68232 iscol(ir)=0
68233 ischg(ir)=0
68234 ksh(ir)=0
68235 IF(kfla(i).LE.8) THEN
68236 iscol(ir)=1
68237 IF(mstj(41).GE.2) ischg(ir)=1
68238 ELSEIF(kfla(i).EQ.11.OR.kfla(i).EQ.13.OR.kfla(i).EQ.15.OR.
68239 & kfla(i).EQ.17) THEN
68240 IF(mstj(41).EQ.2.OR.mstj(41).GE.4) ischg(ir)=1
68241 ELSEIF(kfla(i).EQ.21) THEN
68242 iscol(ir)=1
68243 ELSEIF((kfla(i).GE.ksusy1+1.AND.kfla(i).LE.ksusy1+8).OR.
68244 & (kfla(i).GE.ksusy2+1.AND.kfla(i).LE.ksusy2+8)) THEN
68245 iscol(ir)=1
68246 ELSEIF(kfla(i).EQ.ksusy1+21) THEN
68247 iscol(ir)=1
68248C...QUARKONIA+++
68249C...same for QQ~[3S18]
68250 ELSEIF(mstp(148).GE.1.AND.(kfla(i).EQ.9900443.OR.
68251 & kfla(i).EQ.9900553)) THEN
68252 iscol(ir)=1
68253C...QUARKONIA---
68254 ENDIF
68255
68256C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68257C...(only intended for studying the effects of switching such rad on/off)
68258 IF (mstj(39).GT.0.AND.kfla(i).EQ.mstj(39)) THEN
68259 iscol(ir)=0
68260 ischg(ir)=0
68261 ENDIF
68262
68263 IF(iscol(ir).EQ.1.OR.ischg(ir).EQ.1) ksh(ir)=1
68264 pmth(1,ir)=pma(i)
68265 IF(iscol(ir).EQ.1.AND.ischg(ir).EQ.1) THEN
68266 pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*pmqth1**2)
68267 pmth(3,ir)=pmth(2,ir)+pmqth2
68268 pmth(4,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(82)**2)+pmth(2,21)
68269 pmth(5,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(83)**2)+pmth(2,22)
68270 ELSEIF(iscol(ir).EQ.1) THEN
68271 pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(82)**2)
68272 pmth(3,ir)=pmth(2,ir)+0.5d0*parj(82)
68273 pmth(4,ir)=pmth(3,ir)
68274 pmth(5,ir)=pmth(3,ir)
68275 ELSEIF(ischg(ir).EQ.1) THEN
68276 pmth(2,ir)=sqrt(pmth(1,ir)**2+0.25d0*parj(90)**2)
68277 pmth(3,ir)=pmth(2,ir)+0.5d0*parj(90)
68278 pmth(4,ir)=pmth(3,ir)
68279 pmth(5,ir)=pmth(3,ir)
68280 ENDIF
68281 IF(ksh(ir).EQ.1) pma(i)=pmth(3,ir)
68282 pm=pm+pma(i)
68283 IF(ksh(ir).EQ.0.OR.pma(i).GT.10d0*qmax) irej=irej+1
68284 DO 160 j=1,4
68285 ps(j)=ps(j)+p(ipa(i),j)
68286 160 CONTINUE
68287 170 CONTINUE
68288 IF(irej.EQ.npa.AND.ip2.GE.-7) RETURN
68289 ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
68290 IF(npa.EQ.1) ps(5)=ps(4)
68291 IF(ps(5).LE.pm+pmqt1e) RETURN
68292
68293C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68294 kfsrce=0
68295 IF(ip2.LE.0) THEN
68296 ELSEIF(k(ip1,3).EQ.k(ip2,3).AND.k(ip1,3).GT.0) THEN
68297 kfsrce=iabs(k(k(ip1,3),2))
68298 ELSE
68299 ipar1=max(1,k(ip1,3))
68300 ipar2=max(1,k(ip2,3))
68301 IF(k(ipar1,3).EQ.k(ipar2,3).AND.k(ipar1,3).GT.0)
68302 & kfsrce=iabs(k(k(ipar1,3),2))
68303 ENDIF
68304 itypes=0
68305 IF(kfsrce.GE.1.AND.kfsrce.LE.8) itypes=1
68306 IF(kfsrce.GE.ksusy1+1.AND.kfsrce.LE.ksusy1+8) itypes=2
68307 IF(kfsrce.GE.ksusy2+1.AND.kfsrce.LE.ksusy2+8) itypes=2
68308 IF(kfsrce.GE.21.AND.kfsrce.LE.24) itypes=3
68309 IF(kfsrce.GE.32.AND.kfsrce.LE.34) itypes=3
68310 IF(kfsrce.EQ.25.OR.(kfsrce.GE.35.AND.kfsrce.LE.37)) itypes=4
68311 IF(kfsrce.GE.ksusy1+22.AND.kfsrce.LE.ksusy1+37) itypes=5
68312 IF(kfsrce.EQ.ksusy1+21) itypes=6
68313
68314C...Identify two primary showerers.
68315 itype1=0
68316 IF(kfla(1).GE.1.AND.kfla(1).LE.8) itype1=1
68317 IF(kfla(1).GE.ksusy1+1.AND.kfla(1).LE.ksusy1+8) itype1=2
68318 IF(kfla(1).GE.ksusy2+1.AND.kfla(1).LE.ksusy2+8) itype1=2
68319 IF(kfla(1).GE.21.AND.kfla(1).LE.24) itype1=3
68320 IF(kfla(1).GE.32.AND.kfla(1).LE.34) itype1=3
68321 IF(kfla(1).EQ.25.OR.(kfla(1).GE.35.AND.kfla(1).LE.37)) itype1=4
68322 IF(kfla(1).GE.ksusy1+22.AND.kfla(1).LE.ksusy1+37) itype1=5
68323 IF(kfla(1).EQ.ksusy1+21) itype1=6
68324 itype2=0
68325 IF(kfla(2).GE.1.AND.kfla(2).LE.8) itype2=1
68326 IF(kfla(2).GE.ksusy1+1.AND.kfla(2).LE.ksusy1+8) itype2=2
68327 IF(kfla(2).GE.ksusy2+1.AND.kfla(2).LE.ksusy2+8) itype2=2
68328 IF(kfla(2).GE.21.AND.kfla(2).LE.24) itype2=3
68329 IF(kfla(2).GE.32.AND.kfla(2).LE.34) itype2=3
68330 IF(kfla(2).EQ.25.OR.(kfla(2).GE.35.AND.kfla(2).LE.37)) itype2=4
68331 IF(kfla(2).GE.ksusy1+22.AND.kfla(2).LE.ksusy1+37) itype2=5
68332 IF(kfla(2).EQ.ksusy1+21) itype2=6
68333
68334C...Order of showerers. Presence of gluino.
68335 itypmn=min(itype1,itype2)
68336 itypmx=max(itype1,itype2)
68337 iord=1
68338 IF(itype1.GT.itype2) iord=2
68339 iglui=0
68340 IF(itype1.EQ.6.OR.itype2.EQ.6) iglui=1
68341
68342C...Check if 3-jet matrix elements to be used.
68343 m3jc=0
68344 alpha=0.5d0
68345 IF(npa.EQ.2.AND.mstj(47).GE.1.AND.mpspd.EQ.0) THEN
68346 IF(mstj(38).NE.0) THEN
68347 m3jc=mstj(38)
68348 alpha=parj(80)
68349 mstj(38)=0
68350 ELSEIF(mstj(47).GE.6) THEN
68351 m3jc=mstj(47)
68352 ELSE
68353 iclass=1
68354 icombi=4
68355
68356C...Vector/axial vector -> q + qbar; q -> q + V.
68357 IF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.(itypes.EQ.0.OR.
68358 & itypes.EQ.3)) THEN
68359 iclass=2
68360 IF(kfsrce.EQ.21.OR.kfsrce.EQ.22) THEN
68361 icombi=1
68362 ELSEIF(kfsrce.EQ.23.OR.(kfsrce.EQ.0.AND.
68363 & k(ipa(1),2)+k(ipa(2),2).EQ.0)) THEN
68364C...gamma*/Z0: assume e+e- initial state if unknown.
68365 ei=-1d0
68366 IF(kfsrce.EQ.23) THEN
68367 iannfl=k(k(ip1,3),3)
68368 IF(iannfl.NE.0) THEN
68369 kannfl=iabs(k(iannfl,2))
68370 IF(kannfl.GE.1.AND.kannfl.LE.18) ei=kchg(kannfl,1)/3d0
68371 ENDIF
68372 ENDIF
68373 ai=sign(1d0,ei+0.1d0)
68374 vi=ai-4d0*ei*paru(102)
68375 ef=kchg(kfla(1),1)/3d0
68376 af=sign(1d0,ef+0.1d0)
68377 vf=af-4d0*ef*paru(102)
68378 xwc=1d0/(16d0*paru(102)*(1d0-paru(102)))
68379 sh=ps(5)**2
68380 sqmz=pmas(23,1)**2
68381 sqwz=ps(5)*pmas(23,2)
68382 sbwz=1d0/((sh-sqmz)**2+sqwz**2)
68383 vect=ei**2*ef**2+2d0*ei*vi*ef*vf*xwc*sh*(sh-sqmz)*sbwz+
68384 & (vi**2+ai**2)*vf**2*xwc**2*sh**2*sbwz
68385 axiv=(vi**2+ai**2)*af**2*xwc**2*sh**2*sbwz
68386 icombi=3
68387 alpha=vect/(vect+axiv)
68388 ELSEIF(kfsrce.EQ.24.OR.kfsrce.EQ.0) THEN
68389 icombi=4
68390 ENDIF
68391C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68392 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.5) THEN
68393 iclass=2
68394 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
68395 & itypes.EQ.1)) THEN
68396 iclass=3
68397
68398C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68399 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.4) THEN
68400 iclass=4
68401 IF(kfsrce.EQ.25.OR.kfsrce.EQ.35.OR.kfsrce.EQ.37) THEN
68402 icombi=1
68403 ELSEIF(kfsrce.EQ.36) THEN
68404 icombi=2
68405 ENDIF
68406 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
68407 & itypes.EQ.1)) THEN
68408 iclass=5
68409
68410C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68411 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
68412 & itypes.EQ.3)) THEN
68413 iclass=6
68414 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
68415 & itypes.EQ.2)) THEN
68416 iclass=7
68417 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.itypes.EQ.4) THEN
68418 iclass=8
68419 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
68420 & itypes.EQ.2)) THEN
68421 iclass=9
68422
68423C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68424 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
68425 & itypes.EQ.5)) THEN
68426 iclass=10
68427 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
68428 & itypes.EQ.2)) THEN
68429 iclass=11
68430 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
68431 & itypes.EQ.1)) THEN
68432 iclass=12
68433
68434C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68435 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.itypes.EQ.6) THEN
68436 iclass=13
68437 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
68438 & itypes.EQ.2)) THEN
68439 iclass=14
68440 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
68441 & itypes.EQ.1)) THEN
68442 iclass=15
68443
68444C...g -> ~g + ~g (eikonal approximation).
68445 ELSEIF(itypmn.EQ.6.AND.itypmx.EQ.6.AND.itypes.EQ.0) THEN
68446 iclass=16
68447 ENDIF
68448 m3jc=5*iclass+icombi
68449 ENDIF
68450 ENDIF
68451
68452C...Find if interference with initial state partons.
68453 miis=0
68454 IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2.AND.kfsrce.EQ.0
68455 &.AND.mpspd.EQ.0) miis=mstj(50)
68456 IF(mstj(50).GE.4.AND.mstj(50).LE.6.AND.npa.EQ.2.AND.mpspd.EQ.0)
68457 &miis=mstj(50)-3
68458 IF(miis.NE.0) THEN
68459 DO 190 i=1,2
68460 kcii(i)=0
68461 kca=pycomp(kfla(i))
68462 IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))
68463 niis(i)=0
68464 IF(kcii(i).NE.0) THEN
68465 DO 180 j=1,2
68466 icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))
68467 IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.
68468 & (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN
68469 niis(i)=niis(i)+1
68470 iiis(i,niis(i))=icsi
68471 ENDIF
68472 180 CONTINUE
68473 ENDIF
68474 190 CONTINUE
68475 IF(niis(1)+niis(2).EQ.0) miis=0
68476 ENDIF
68477
68478C...Boost interfering initial partons to rest frame
68479C...and reconstruct their polar and azimuthal angles.
68480 IF(miis.NE.0) THEN
68481 DO 210 i=1,2
68482 DO 200 j=1,5
68483 k(n+i,j)=k(ipa(i),j)
68484 p(n+i,j)=p(ipa(i),j)
68485 v(n+i,j)=0d0
68486 200 CONTINUE
68487 210 CONTINUE
68488 DO 230 i=3,2+niis(1)
68489 DO 220 j=1,5
68490 k(n+i,j)=k(iiis(1,i-2),j)
68491 p(n+i,j)=p(iiis(1,i-2),j)
68492 v(n+i,j)=0d0
68493 220 CONTINUE
68494 230 CONTINUE
68495 DO 250 i=3+niis(1),2+niis(1)+niis(2)
68496 DO 240 j=1,5
68497 k(n+i,j)=k(iiis(2,i-2-niis(1)),j)
68498 p(n+i,j)=p(iiis(2,i-2-niis(1)),j)
68499 v(n+i,j)=0d0
68500 240 CONTINUE
68501 250 CONTINUE
68502 CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,0d0,-ps(1)/ps(4),
68503 & -ps(2)/ps(4),-ps(3)/ps(4))
68504 phi=pyangl(p(n+1,1),p(n+1,2))
68505 CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,-phi,0d0,0d0,0d0)
68506 the=pyangl(p(n+1,3),p(n+1,1))
68507 CALL pyrobo(n+1,n+2+niis(1)+niis(2),-the,0d0,0d0,0d0,0d0)
68508 DO 260 i=3,2+niis(1)
68509 theiis(1,i-2)=pyangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))
68510 phiiis(1,i-2)=pyangl(p(n+i,1),p(n+i,2))
68511 260 CONTINUE
68512 DO 270 i=3+niis(1),2+niis(1)+niis(2)
68513 theiis(2,i-2-niis(1))=paru(1)-pyangl(p(n+i,3),
68514 & sqrt(p(n+i,1)**2+p(n+i,2)**2))
68515 phiiis(2,i-2-niis(1))=pyangl(p(n+i,1),p(n+i,2))
68516 270 CONTINUE
68517 ENDIF
68518
68519C...Boost 3 or more partons to their rest frame.
68520 IF(npa.GE.3) CALL pyrobo(ipa(1),ipa(npa),0d0,0d0,-ps(1)/ps(4),
68521 &-ps(2)/ps(4),-ps(3)/ps(4))
68522
68523C...Define imagined single initiator of shower for parton system.
68524 ns=n
68525 IF(n.GT.mstu(4)-mstu(32)-10) THEN
68526 CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
68527 IF(mstu(21).GE.1) RETURN
68528 ENDIF
68529 280 n=ns
68530 IF(npa.GE.2) THEN
68531 k(n+1,1)=11
68532 k(n+1,2)=21
68533 k(n+1,3)=0
68534 k(n+1,4)=0
68535 k(n+1,5)=0
68536 p(n+1,1)=0d0
68537 p(n+1,2)=0d0
68538 p(n+1,3)=0d0
68539 p(n+1,4)=ps(5)
68540 p(n+1,5)=ps(5)
68541 v(n+1,5)=ps(5)**2
68542 n=n+1
68543 iref(1)=21
68544 ENDIF
68545
68546C...Loop over partons that may branch.
68547 nep=npa
68548 im=ns
68549 IF(npa.EQ.1) im=ns-1
68550 290 im=im+1
68551 IF(n.GT.ns) THEN
68552 IF(im.GT.n) GOTO 600
68553 kflm=iabs(k(im,2))
68554 ir=iref(im-ns)
68555 IF(ksh(ir).EQ.0) GOTO 290
68556 IF(p(im,5).LT.pmth(2,ir)) GOTO 290
68557 igm=k(im,3)
68558 ELSE
68559 igm=-1
68560 ENDIF
68561 IF(n+nep.GT.mstu(4)-mstu(32)-10) THEN
68562 CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
68563 IF(mstu(21).GE.1) RETURN
68564 ENDIF
68565
68566C...Position of aunt (sister to branching parton).
68567C...Origin and flavour of daughters.
68568 iau=0
68569 IF(igm.GT.0) THEN
68570 IF(k(im-1,3).EQ.igm) iau=im-1
68571 IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1
68572 ENDIF
68573 IF(igm.GE.0) THEN
68574 k(im,4)=n+1
68575 DO 300 i=1,nep
68576 k(n+i,3)=im
68577 300 CONTINUE
68578 ELSE
68579 k(n+1,3)=ipa(1)
68580 ENDIF
68581 IF(igm.LE.0) THEN
68582 DO 310 i=1,nep
68583 k(n+i,2)=k(ipa(i),2)
68584 310 CONTINUE
68585 ELSEIF(kflm.NE.21) THEN
68586 k(n+1,2)=k(im,2)
68587 k(n+2,2)=k(im,5)
68588 iref(n+1-ns)=iref(im-ns)
68589 iref(n+2-ns)=iabs(k(n+2,2))
68590 ELSEIF(k(im,5).EQ.21) THEN
68591 k(n+1,2)=21
68592 k(n+2,2)=21
68593 iref(n+1-ns)=21
68594 iref(n+2-ns)=21
68595 ELSE
68596 k(n+1,2)=k(im,5)
68597 k(n+2,2)=-k(im,5)
68598 iref(n+1-ns)=iabs(k(n+1,2))
68599 iref(n+2-ns)=iabs(k(n+2,2))
68600 ENDIF
68601
68602C...Reset flags on daughters and tries made.
68603 DO 320 ip=1,nep
68604 k(n+ip,1)=3
68605 k(n+ip,4)=0
68606 k(n+ip,5)=0
68607 kfld(ip)=iabs(k(n+ip,2))
68608 IF(kchg(pycomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1
68609 itry(ip)=0
68610 isl(ip)=0
68611 isi(ip)=0
68612 IF(ksh(iref(n+ip-ns)).EQ.1) isi(ip)=1
68613 320 CONTINUE
68614 islm=0
68615
68616C...Maximum virtuality of daughters.
68617 IF(igm.LE.0) THEN
68618 DO 330 i=1,npa
68619 IF(npa.GE.3) p(n+i,4)=p(ipa(i),4)
68620 p(n+i,5)=min(qmax,ps(5))
68621 ir=iref(n+i-ns)
68622 IF(ip2.LE.-8) p(n+i,5)=max(p(n+i,5),2d0*pmth(3,ir))
68623 IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)
68624 330 CONTINUE
68625 ELSE
68626 IF(mstj(43).LE.2) pem=v(im,2)
68627 IF(mstj(43).GE.3) pem=p(im,4)
68628 p(n+1,5)=min(p(im,5),v(im,1)*pem)
68629 p(n+2,5)=min(p(im,5),(1d0-v(im,1))*pem)
68630 IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)
68631 ENDIF
68632 DO 340 i=1,nep
68633 pmsd(i)=p(n+i,5)
68634 IF(isi(i).EQ.1) THEN
68635 ir=iref(n+i-ns)
68636 IF(p(n+i,5).LE.pmth(3,ir)) p(n+i,5)=pmth(1,ir)
68637 ENDIF
68638 v(n+i,5)=p(n+i,5)**2
68639 340 CONTINUE
68640
68641C...Choose one of the daughters for evolution.
68642 350 inum=0
68643 IF(nep.EQ.1) inum=1
68644 DO 360 i=1,nep
68645 IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i
68646 360 CONTINUE
68647 DO 370 i=1,nep
68648 IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN
68649 ir=iref(n+i-ns)
68650 IF(p(n+i,5).GE.pmth(2,ir)) inum=i
68651 ENDIF
68652 370 CONTINUE
68653 IF(inum.EQ.0) THEN
68654 rmax=0d0
68655 DO 380 i=1,nep
68656 IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqt2e) THEN
68657 rpm=p(n+i,5)/pmsd(i)
68658 ir=iref(n+i-ns)
68659 IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,ir)) THEN
68660 rmax=rpm
68661 inum=i
68662 ENDIF
68663 ENDIF
68664 380 CONTINUE
68665 ENDIF
68666
68667C...Cancel choice of predetermined daughter already treated.
68668 inum=max(1,inum)
68669 inumt=inum
68670 IF(mpspd.EQ.1.AND.igm.EQ.0.AND.itry(inumt).GE.1) THEN
68671 IF(k(ip1-1+inum,4).GT.0) inum=3-inum
68672 ELSEIF(mpspd.EQ.1.AND.im.EQ.ns+2.AND.itry(inumt).GE.1) THEN
68673 IF(kfld(inumt).NE.21.AND.k(ip1+2,4).GT.0) inum=3-inum
68674 IF(kfld(inumt).EQ.21.AND.k(ip1+3,4).GT.0) inum=3-inum
68675 ENDIF
68676
68677C...Store information on choice of evolving daughter.
68678 iep(1)=n+inum
68679 DO 390 i=2,nep
68680 iep(i)=iep(i-1)+1
68681 IF(iep(i).GT.n+nep) iep(i)=n+1
68682 390 CONTINUE
68683 DO 400 i=1,nep
68684 kfl(i)=iabs(k(iep(i),2))
68685 400 CONTINUE
68686 itry(inum)=itry(inum)+1
68687 IF(itry(inum).GT.200) THEN
68688 CALL pyerrm(14,'(PYSHOW:) caught in infinite loop')
68689 IF(mstu(21).GE.1) RETURN
68690 ENDIF
68691 z=0.5d0
68692 ir=iref(iep(1)-ns)
68693 IF(ksh(ir).EQ.0) GOTO 450
68694 IF(p(iep(1),5).LT.pmth(2,ir)) GOTO 450
68695
68696C...Check if evolution already predetermined for daughter.
68697 ipspd=0
68698 IF(mpspd.EQ.1.AND.igm.EQ.0) THEN
68699 IF(k(ip1-1+inum,4).GT.0) ipspd=ip1-1+inum
68700 ELSEIF(mpspd.EQ.1.AND.im.EQ.ns+2) THEN
68701 IF(kfl(1).NE.21.AND.k(ip1+2,4).GT.0) ipspd=ip1+2
68702 IF(kfl(1).EQ.21.AND.k(ip1+3,4).GT.0) ipspd=ip1+3
68703 ENDIF
68704 IF(inum.EQ.1.OR.inum.EQ.2) THEN
68705 isset(inum)=0
68706 IF(ipspd.NE.0) isset(inum)=1
68707 ENDIF
68708
68709C...Select side for interference with initial state partons.
68710 IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN
68711 iii=iep(1)-ns-1
68712 isii(iii)=0
68713 IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN
68714 isii(iii)=1
68715 ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN
68716 IF(pyr(0).GT.0.5d0) isii(iii)=1
68717 ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN
68718 isii(iii)=1
68719 IF(pyr(0).GT.0.5d0) isii(iii)=2
68720 ENDIF
68721 ENDIF
68722
68723C...Calculate allowed z range.
68724 IF(nep.EQ.1) THEN
68725 pmed=ps(4)
68726 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
68727 pmed=p(im,5)
68728 ELSE
68729 IF(inum.EQ.1) pmed=v(im,1)*pem
68730 IF(inum.EQ.2) pmed=(1d0-v(im,1))*pem
68731 ENDIF
68732 IF(mod(mstj(43),2).EQ.1) THEN
68733 zc=pmth(2,21)/pmed
68734 zce=pmth(2,22)/pmed
68735 IF(iscol(ir).EQ.0) zce=0.5d0*parj(90)/pmed
68736 ELSE
68737 zc=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmth(2,21)/pmed)**2)))
68738 IF(zc.LT.1d-6) zc=(pmth(2,21)/pmed)**2
68739 pmtmpe=pmth(2,22)
68740 IF(iscol(ir).EQ.0) pmtmpe=0.5d0*parj(90)
68741 zce=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmtmpe/pmed)**2)))
68742 IF(zce.LT.1d-6) zce=(pmtmpe/pmed)**2
68743 ENDIF
68744 zc=min(zc,0.491d0)
68745 zce=min(zce,0.49991d0)
68746 IF(((mstj(41).EQ.1.AND.zc.GT.0.49d0).OR.(mstj(41).GE.2.AND.
68747 &min(zc,zce).GT.0.4999d0)).AND.ipspd.EQ.0) THEN
68748 p(iep(1),5)=pmth(1,ir)
68749 v(iep(1),5)=p(iep(1),5)**2
68750 GOTO 450
68751 ENDIF
68752
68753C...Integral of Altarelli-Parisi z kernel for QCD.
68754C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68755 IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN
68756 fbr=6d0*log((1d0-zc)/zc)+mstj(45)*0.5d0
68757C...QUARKONIA+++
68758C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68759 ELSEIF(mstj(49).EQ.0.AND.mstp(149).GE.0.AND.
68760 & (kfl(1).EQ.9900443.OR.kfl(1).EQ.9900553)) THEN
68761 fbr=6d0*log((1d0-zc)/zc)
68762C...QUARKONIA---
68763 ELSEIF(mstj(49).EQ.0) THEN
68764 fbr=(8d0/3d0)*log((1d0-zc)/zc)
68765 IF(iglui.EQ.1.AND.ir.GE.31) fbr=fbr*(9d0/4d0)
68766
68767C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68768 ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN
68769 fbr=(parj(87)+mstj(45)*parj(88))*(1d0-2d0*zc)
68770 ELSEIF(mstj(49).EQ.1) THEN
68771 fbr=(1d0-2d0*zc)/3d0
68772 IF(igm.EQ.0.AND.m3jc.GE.1) fbr=4d0*fbr
68773
68774C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68775 ELSEIF(kfl(1).EQ.21) THEN
68776 fbr=6d0*mstj(45)*(0.5d0-zc)
68777 ELSE
68778 fbr=2d0*log((1d0-zc)/zc)
68779 ENDIF
68780
68781C...Reset QCD probability for colourless.
68782 IF(iscol(ir).EQ.0) fbr=0d0
68783
68784C...Integral of Altarelli-Parisi kernel for photon emission.
68785 fbre=0d0
68786 IF(mstj(41).GE.2.AND.ischg(ir).EQ.1) THEN
68787 IF(kfl(1).LE.18) THEN
68788 fbre=(kchg(kfl(1),1)/3d0)**2*2d0*log((1d0-zce)/zce)
68789 ENDIF
68790 IF(mstj(41).EQ.10) fbre=parj(84)*fbre
68791 ENDIF
68792
68793C...Inner veto algorithm starts. Find maximum mass for evolution.
68794 410 pms=v(iep(1),5)
68795 IF(igm.GE.0) THEN
68796 pm2=0d0
68797 DO 420 i=2,nep
68798 pm=p(iep(i),5)
68799 iri=iref(iep(i)-ns)
68800 IF(ksh(iri).EQ.1) pm=pmth(2,iri)
68801 pm2=pm2+pm
68802 420 CONTINUE
68803 pms=min(pms,(p(im,5)-pm2)**2)
68804 ENDIF
68805
68806C...Select mass for daughter in QCD evolution.
68807 b0=27d0/6d0
68808 DO 430 iff=4,mstj(45)
68809 IF(pms.GT.4d0*pmth(2,iff)**2) b0=(33d0-2d0*iff)/6d0
68810 430 CONTINUE
68811C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68812 pmsc=max(0.5d0*parj(82),pms-pmth(1,ir)**2)
68813C...Already predetermined choice.
68814 IF(ipspd.NE.0) THEN
68815 pmsqcd=p(ipspd,5)**2
68816 ELSEIF(fbr.LT.1d-3) THEN
68817 pmsqcd=0d0
68818 ELSEIF(mstj(44).LE.0) THEN
68819 pmsqcd=pmsc*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(111)*fbr)))
68820 ELSEIF(mstj(44).EQ.1) THEN
68821 pmsqcd=4d0*alams*(0.25d0*pmsc/alams)**(pyr(0)**(b0/fbr))
68822 ELSE
68823 pmsqcd=pmsc*exp(max(-50d0,alfm*b0*log(pyr(0))/fbr))
68824 ENDIF
68825C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68826 IF(ipspd.EQ.0) pmsqcd=pmsqcd+pmth(1,ir)**2
68827 IF(zc.GT.0.49d0.OR.pmsqcd.LE.pmth(4,ir)**2) pmsqcd=pmth(2,ir)**2
68828 v(iep(1),5)=pmsqcd
68829 mce=1
68830
68831C...Select mass for daughter in QED evolution.
68832 IF(mstj(41).GE.2.AND.ischg(ir).EQ.1.AND.ipspd.EQ.0) THEN
68833C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68834 pmse=max(0.5d0*parj(83),pms-pmth(1,ir)**2)
68835 IF(fbre.LT.1d-3) THEN
68836 pmsqed=0d0
68837 ELSE
68838 pmsqed=pmse*exp(max(-50d0,log(pyr(0))*paru(2)/
68839 & (paru(101)*fbre)))
68840 ENDIF
68841C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68842 pmsqed=pmsqed+pmth(1,ir)**2
68843 IF(zce.GT.0.4999d0.OR.pmsqed.LE.pmth(5,ir)**2) pmsqed=
68844 & pmth(2,ir)**2
68845 IF(pmsqed.GT.pmsqcd) THEN
68846 v(iep(1),5)=pmsqed
68847 mce=2
68848 ENDIF
68849 ENDIF
68850
68851C...Check whether daughter mass below cutoff.
68852 p(iep(1),5)=sqrt(v(iep(1),5))
68853 IF(p(iep(1),5).LE.pmth(3,ir)) THEN
68854 p(iep(1),5)=pmth(1,ir)
68855 v(iep(1),5)=p(iep(1),5)**2
68856 GOTO 450
68857 ENDIF
68858
68859C...Already predetermined choice of z, and flavour in g -> qqbar.
68860 IF(ipspd.NE.0) THEN
68861 ipsgd1=k(ipspd,4)
68862 ipsgd2=k(ipspd,5)
68863 pmsgd1=p(ipsgd1,5)**2
68864 pmsgd2=p(ipsgd2,5)**2
68865 alamps=sqrt(max(1d-10,(pmsqcd-pmsgd1-pmsgd2)**2-
68866 & 4d0*pmsgd1*pmsgd2))
68867 z=0.5d0*(pmsqcd*(2d0*p(ipsgd1,4)/p(ipspd,4)-1d0)+alamps-
68868 & pmsgd1+pmsgd2)/alamps
68869 z=max(0.00001d0,min(0.99999d0,z))
68870 IF(kfl(1).NE.21) THEN
68871 k(iep(1),5)=21
68872 ELSE
68873 k(iep(1),5)=iabs(k(ipsgd1,2))
68874 ENDIF
68875
68876C...Select z value of branching: q -> qgamma.
68877 ELSEIF(mce.EQ.2) THEN
68878 z=1d0-(1d0-zce)*(zce/(1d0-zce))**pyr(0)
68879 IF(1d0+z**2.LT.2d0*pyr(0)) GOTO 410
68880 k(iep(1),5)=22
68881
68882C...QUARKONIA+++
68883C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
68884 ELSEIF(mstj(49).EQ.0.AND.
68885 & (kfl(1).EQ.9900443.OR.kfl(1).EQ.9900553)) THEN
68886 z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)
68887C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
68888 IF(mstp(149).LE.0.OR.pyr(0).GT.0.5d0) z=1d0-z
68889 IF((1d0-z*(1d0-z))**2.LT.pyr(0)) GOTO 410
68890 k(iep(1),5)=21
68891C...QUARKONIA---
68892
68893C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
68894 ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN
68895 z=1d0-(1d0-zc)*(zc/(1d0-zc))**pyr(0)
68896C...Only do z weighting when no ME correction afterwards.
68897 IF(m3jc.EQ.0.AND.1d0+z**2.LT.2d0*pyr(0)) GOTO 410
68898 k(iep(1),5)=21
68899 ELSEIF(mstj(49).EQ.0.AND.mstj(45)*0.5d0.LT.pyr(0)*fbr) THEN
68900 z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)
68901 IF(pyr(0).GT.0.5d0) z=1d0-z
68902 IF((1d0-z*(1d0-z))**2.LT.pyr(0)) GOTO 410
68903 k(iep(1),5)=21
68904 ELSEIF(mstj(49).NE.1) THEN
68905 z=pyr(0)
68906 IF(z**2+(1d0-z)**2.LT.pyr(0)) GOTO 410
68907 kflb=1+int(mstj(45)*pyr(0))
68908 pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
68909 IF(pmq.GE.1d0) GOTO 410
68910 IF(mstj(44).LE.2.OR.mstj(44).EQ.4) THEN
68911 IF(z.LT.zc.OR.z.GT.1d0-zc) GOTO 410
68912 pmq0=4d0*pmth(2,21)**2/v(iep(1),5)
68913 IF(mod(mstj(43),2).EQ.0.AND.(1d0+0.5d0*pmq)*sqrt(1d0-pmq)
68914 & .LT.pyr(0)*(1d0+0.5d0*pmq0)*sqrt(1d0-pmq0)) GOTO 410
68915 ELSE
68916 IF((1d0+0.5d0*pmq)*sqrt(1d0-pmq).LT.pyr(0)) GOTO 410
68917 ENDIF
68918 k(iep(1),5)=kflb
68919
68920C...Ditto for scalar gluon model.
68921 ELSEIF(kfl(1).NE.21) THEN
68922 z=1d0-sqrt(zc**2+pyr(0)*(1d0-2d0*zc))
68923 k(iep(1),5)=21
68924 ELSEIF(pyr(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN
68925 z=zc+(1d0-2d0*zc)*pyr(0)
68926 k(iep(1),5)=21
68927 ELSE
68928 z=zc+(1d0-2d0*zc)*pyr(0)
68929 kflb=1+int(mstj(45)*pyr(0))
68930 pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)
68931 IF(pmq.GE.1d0) GOTO 410
68932 k(iep(1),5)=kflb
68933 ENDIF
68934
68935C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
68936 IF(mce.EQ.1.AND.mstj(44).GE.2.AND.ipspd.EQ.0) THEN
68937 IF(kfl(1).EQ.21.AND.k(iep(1),5).LT.10.AND.
68938 & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
68939 IF(alfm/log(v(iep(1),5)*0.25d0/alams).LT.pyr(0)) GOTO 410
68940 ELSE
68941 pt2app=z*(1d0-z)*v(iep(1),5)
68942 IF(mstj(44).GE.4) pt2app=pt2app*
68943 & (1d0-pmth(1,ir)**2/v(iep(1),5))**2
68944 IF(pt2app.LT.pt2min) GOTO 410
68945 IF(alfm/log(pt2app/alams).LT.pyr(0)) GOTO 410
68946 ENDIF
68947 ENDIF
68948
68949C...Check if z consistent with chosen m.
68950 IF(kfl(1).EQ.21) THEN
68951 irgd1=iabs(k(iep(1),5))
68952 irgd2=irgd1
68953 ELSE
68954 irgd1=ir
68955 irgd2=iabs(k(iep(1),5))
68956 ENDIF
68957 IF(nep.EQ.1) THEN
68958 ped=ps(4)
68959 ELSEIF(nep.GE.3) THEN
68960 ped=p(iep(1),4)
68961 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN
68962 ped=0.5d0*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)
68963 ELSE
68964 IF(iep(1).EQ.n+1) ped=v(im,1)*pem
68965 IF(iep(1).EQ.n+2) ped=(1d0-v(im,1))*pem
68966 ENDIF
68967 IF(mod(mstj(43),2).EQ.1) THEN
68968 pmqth3=0.5d0*parj(82)
68969 IF(irgd2.EQ.22) pmqth3=0.5d0*parj(83)
68970 IF(irgd2.EQ.22.AND.iscol(ir).EQ.0) pmqth3=0.5d0*parj(90)
68971 pmq1=(pmth(1,irgd1)**2+pmqth3**2)/v(iep(1),5)
68972 pmq2=(pmth(1,irgd2)**2+pmqth3**2)/v(iep(1),5)
68973 zd=sqrt(max(0d0,(1d0-v(iep(1),5)/ped**2)*((1d0-pmq1-pmq2)**2-
68974 & 4d0*pmq1*pmq2)))
68975 zh=1d0+pmq1-pmq2
68976 ELSE
68977 zd=sqrt(max(0d0,1d0-v(iep(1),5)/ped**2))
68978 zh=1d0
68979 ENDIF
68980 IF(kfl(1).EQ.21.AND.k(iep(1),5).LT.10.AND.
68981 &(mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
68982 ELSEIF(ipspd.NE.0) THEN
68983 ELSE
68984 zl=0.5d0*(zh-zd)
68985 zu=0.5d0*(zh+zd)
68986 IF(z.LT.zl.OR.z.GT.zu) GOTO 410
68987 ENDIF
68988 IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1d0-zl)/max(1d-20,zl*
68989 &(1d0-zu)))
68990 IF(kfl(1).NE.21) v(iep(1),3)=log((1d0-zl)/max(1d-10,1d0-zu))
68991
68992C...Width suppression for q -> q + g.
68993 IF(mstj(40).NE.0.AND.kfl(1).NE.21.AND.ipspd.EQ.0) THEN
68994 IF(igm.EQ.0) THEN
68995 eglu=0.5d0*ps(5)*(1d0-z)*(1d0+v(iep(1),5)/v(ns+1,5))
68996 ELSE
68997 eglu=pmed*(1d0-z)
68998 ENDIF
68999 chi=parj(89)**2/(parj(89)**2+eglu**2)
69000 IF(mstj(40).EQ.1) THEN
69001 IF(chi.LT.pyr(0)) GOTO 410
69002 ELSEIF(mstj(40).EQ.2) THEN
69003 IF(1d0-chi.LT.pyr(0)) GOTO 410
69004 ENDIF
69005 ENDIF
69006
69007C...Three-jet matrix element correction.
69008 IF(m3jc.GE.1) THEN
69009 wme=1d0
69010 wshow=1d0
69011
69012C...QED matrix elements: only for massless case so far.
69013 IF(mce.EQ.2.AND.igm.EQ.0) THEN
69014 x1=z*(1d0+v(iep(1),5)/v(ns+1,5))
69015 x2=1d0-v(iep(1),5)/v(ns+1,5)
69016 x3=(1d0-x1)+(1d0-x2)
69017 ki1=k(ipa(inum),2)
69018 ki2=k(ipa(3-inum),2)
69019 qf1=kchg(pycomp(ki1),1)*isign(1,ki1)/3d0
69020 qf2=kchg(pycomp(ki2),1)*isign(1,ki2)/3d0
69021 wshow=qf1**2*(1d0-x1)/x3*(1d0+(x1/(2d0-x2))**2)+
69022 & qf2**2*(1d0-x2)/x3*(1d0+(x2/(2d0-x1))**2)
69023 wme=(qf1*(1d0-x1)/x3-qf2*(1d0-x2)/x3)**2*(x1**2+x2**2)
69024 ELSEIF(mce.EQ.2) THEN
69025
69026C...QCD matrix elements, including mass effects.
69027 ELSEIF(mstj(49).NE.1.AND.k(iep(1),2).NE.21) THEN
69028 ps1me=v(iep(1),5)
69029 pm1me=pmth(1,ir)
69030 m3jcc=m3jc
69031 IF(ir.GE.31.AND.igm.EQ.0) THEN
69032C...QCD ME: original parton, first branching.
69033 pm2me=pmth(1,63-ir)
69034 ecmme=ps(5)
69035 ELSEIF(ir.GE.31) THEN
69036C...QCD ME: original parton, subsequent branchings.
69037 pm2me=pmth(1,63-ir)
69038 pedme=pem*(v(im,1)+(1d0-v(im,1))*ps1me/v(im,5))
69039 ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
69040 ELSEIF(k(im,2).EQ.21) THEN
69041C...QCD ME: secondary partons, first branching.
69042 pm2me=pm1me
69043 zmme=v(im,1)
69044 IF(iep(1).GT.iep(2)) zmme=1d0-zmme
69045 pmlme=sqrt(max(0d0,(v(im,5)-ps1me-pm2me**2)**2-
69046 & 4d0*ps1me*pm2me**2))
69047 pedme=pem*(0.5d0*(v(im,5)-pmlme+ps1me-pm2me**2)+pmlme*zmme)/
69048 & v(im,5)
69049 ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
69050 m3jcc=66
69051 ELSE
69052C...QCD ME: secondary partons, subsequent branchings.
69053 pm2me=pm1me
69054 pedme=pem*(v(im,1)+(1d0-v(im,1))*ps1me/v(im,5))
69055 ecmme=pedme+sqrt(max(0d0,pedme**2-ps1me+pm2me**2))
69056 m3jcc=66
69057 ENDIF
69058C...Construct ME variables.
69059 r1me=pm1me/ecmme
69060 r2me=pm2me/ecmme
69061 x1=(1d0+ps1me/ecmme**2-r2me**2)*(z+(1d0-z)*pm1me**2/ps1me)
69062 x2=1d0+r2me**2-ps1me/ecmme**2
69063C...Call ME, with right order important for two inequivalent showerers.
69064 IF(ir.EQ.iord+30) THEN
69065 wme=pymael(m3jcc,x1,x2,r1me,r2me,alpha)
69066 ELSE
69067 wme=pymael(m3jcc,x2,x1,r2me,r1me,alpha)
69068 ENDIF
69069C...Split up total ME when two radiating partons.
69070 isprad=1
69071 IF((m3jcc.GE.16.AND.m3jcc.LE.19).OR.
69072 & (m3jcc.GE.26.AND.m3jcc.LE.29).OR.
69073 & (m3jcc.GE.36.AND.m3jcc.LE.39).OR.
69074 & (m3jcc.GE.46.AND.m3jcc.LE.49).OR.
69075 & (m3jcc.GE.56.AND.m3jcc.LE.64)) isprad=0
69076 IF(isprad.EQ.1) wme=wme*max(1d-10,1d0+r1me**2-r2me**2-x1)/
69077 & max(1d-10,2d0-x1-x2)
69078C...Evaluate shower rate to be compared with.
69079 wshow=2d0/(max(1d-10,2d0-x1-x2)*
69080 & max(1d-10,1d0+r2me**2-r1me**2-x2))
69081 IF(iglui.EQ.1.AND.ir.GE.31) wshow=(9d0/4d0)*wshow
69082 ELSEIF(mstj(49).NE.1) THEN
69083
69084C...Toy model scalar theory matrix elements; no mass effects.
69085 ELSE
69086 x1=z*(1d0+v(iep(1),5)/v(ns+1,5))
69087 x2=1d0-v(iep(1),5)/v(ns+1,5)
69088 x3=(1d0-x1)+(1d0-x2)
69089 wshow=4d0*x3*((1d0-x1)/(2d0-x2)**2+(1d0-x2)/(2d0-x1)**2)
69090 wme=x3**2
69091 IF(mstj(102).GE.2) wme=x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*
69092 & parj(171)
69093 ENDIF
69094
69095 IF(wme.LT.pyr(0)*wshow) GOTO 410
69096 ENDIF
69097
69098C...Impose angular ordering by rejection of nonordered emission.
69099 IF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2.AND.ipspd.EQ.0) THEN
69100 pemao=v(im,1)*p(im,4)
69101 IF(iep(1).EQ.n+2) pemao=(1d0-v(im,1))*p(im,4)
69102 IF(ir.GE.31.AND.mstj(42).GE.5) THEN
69103 maod=0
69104 ELSEIF(kfl(1).EQ.21.AND.k(iep(1),5).LE.10.AND.(mstj(42).EQ.4
69105 & .OR.mstj(42).EQ.7)) THEN
69106 maod=0
69107 ELSEIF(kfl(1).EQ.21.AND.k(iep(1),5).LE.10.AND.(mstj(42).EQ.3
69108 & .OR.mstj(42).EQ.6)) THEN
69109 maod=1
69110 pmdao=pmth(2,k(iep(1),5))
69111 the2id=z*(1d0-z)*pemao**2/(v(iep(1),5)-4d0*pmdao**2)
69112 ELSE
69113 maod=1
69114 the2id=z*(1d0-z)*pemao**2/v(iep(1),5)
69115 IF(mstj(42).GE.3.AND.mstj(42).NE.5) the2id=the2id*
69116 & (1d0+pmth(1,ir)**2*(1d0-z)/(v(iep(1),5)*z))**2
69117 ENDIF
69118 maom=1
69119 iaom=im
69120 440 IF(k(iaom,5).EQ.22) THEN
69121 iaom=k(iaom,3)
69122 IF(k(iaom,3).LE.ns) maom=0
69123 IF(maom.EQ.1) GOTO 440
69124 ENDIF
69125 IF(maom.EQ.1.AND.maod.EQ.1) THEN
69126 the2im=v(iaom,1)*(1d0-v(iaom,1))*p(iaom,4)**2/v(iaom,5)
69127 IF(the2id.LT.the2im) GOTO 410
69128 ENDIF
69129 ENDIF
69130
69131C...Impose user-defined maximum angle at first branching.
69132 IF(mstj(48).EQ.1.AND.ipspd.EQ.0) THEN
69133 IF(nep.EQ.1.AND.im.EQ.ns) THEN
69134 the2id=z*(1d0-z)*ps(4)**2/v(iep(1),5)
69135 IF(parj(85)**2*the2id.LT.1d0) GOTO 410
69136 ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN
69137 the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
69138 IF(parj(85)**2*the2id.LT.1d0) GOTO 410
69139 ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN
69140 the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)
69141 IF(parj(86)**2*the2id.LT.1d0) GOTO 410
69142 ENDIF
69143 ENDIF
69144
69145C...Impose angular constraint in first branching from interference
69146C...with initial state partons.
69147 IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN
69148 the2d=max((1d0-z)/z,z/(1d0-z))*v(iep(1),5)/(0.5d0*p(im,4))**2
69149 IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN
69150 IF(the2d.GT.theiis(1,isii(1))**2) GOTO 410
69151 ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN
69152 IF(the2d.GT.theiis(2,isii(2))**2) GOTO 410
69153 ENDIF
69154 ENDIF
69155
69156C...End of inner veto algorithm. Check if only one leg evolved so far.
69157 450 v(iep(1),1)=z
69158 isl(1)=0
69159 isl(2)=0
69160 IF(nep.EQ.1) GOTO 490
69161 IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) GOTO 350
69162 DO 460 i=1,nep
69163 ir=iref(n+i-ns)
69164 IF(itry(i).EQ.0.AND.ksh(ir).EQ.1) THEN
69165 IF(p(n+i,5).GE.pmth(2,ir)) GOTO 350
69166 ENDIF
69167 460 CONTINUE
69168
69169C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69170 IF(nep.GE.3) THEN
69171 pmsum=0d0
69172 DO 470 i=1,nep
69173 pmsum=pmsum+p(n+i,5)
69174 470 CONTINUE
69175 IF(pmsum.GE.ps(5)) GOTO 350
69176 ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN
69177 DO 480 i1=n+1,n+2
69178 irda=iref(i1-ns)
69179 IF(ksh(irda).EQ.0) GOTO 480
69180 IF(p(i1,5).LT.pmth(2,irda)) GOTO 480
69181 IF(irda.EQ.21) THEN
69182 irgd1=iabs(k(i1,5))
69183 irgd2=irgd1
69184 ELSE
69185 irgd1=irda
69186 irgd2=iabs(k(i1,5))
69187 ENDIF
69188 i2=2*n+3-i1
69189 IF(igm.EQ.0.OR.mstj(43).LE.2) THEN
69190 ped=0.5d0*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)
69191 ELSE
69192 IF(i1.EQ.n+1) zm=v(im,1)
69193 IF(i1.EQ.n+2) zm=1d0-v(im,1)
69194 pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-
69195 & 4d0*v(n+1,5)*v(n+2,5))
69196 ped=pem*(0.5d0*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/
69197 & v(im,5)
69198 ENDIF
69199 IF(mod(mstj(43),2).EQ.1) THEN
69200 pmqth3=0.5d0*parj(82)
69201 IF(irgd2.EQ.22) pmqth3=0.5d0*parj(83)
69202 IF(irgd2.EQ.22.AND.iscol(irda).EQ.0) pmqth3=0.5d0*parj(90)
69203 pmq1=(pmth(1,irgd1)**2+pmqth3**2)/v(i1,5)
69204 pmq2=(pmth(1,irgd2)**2+pmqth3**2)/v(i1,5)
69205 zd=sqrt(max(0d0,(1d0-v(i1,5)/ped**2)*((1d0-pmq1-pmq2)**2-
69206 & 4d0*pmq1*pmq2)))
69207 zh=1d0+pmq1-pmq2
69208 ELSE
69209 zd=sqrt(max(0d0,1d0-v(i1,5)/ped**2))
69210 zh=1d0
69211 ENDIF
69212 IF(irda.EQ.21.AND.irgd1.LT.10.AND.
69213 & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
69214 ELSE
69215 zl=0.5d0*(zh-zd)
69216 zu=0.5d0*(zh+zd)
69217 IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu).AND.
69218 & isset(1).EQ.0) THEN
69219 isl(1)=1
69220 ELSEIF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu).AND.
69221 & isset(2).EQ.0) THEN
69222 isl(2)=1
69223 ENDIF
69224 ENDIF
69225 IF(irda.EQ.21) v(i1,4)=log(zu*(1d0-zl)/max(1d-20,
69226 & zl*(1d0-zu)))
69227 IF(irda.NE.21) v(i1,4)=log((1d0-zl)/max(1d-10,1d0-zu))
69228 480 CONTINUE
69229 IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN
69230 isl(3-islm)=0
69231 islm=3-islm
69232 ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN
69233 zdr1=max(0d0,v(n+1,3)/max(1d-6,v(n+1,4))-1d0)
69234 zdr2=max(0d0,v(n+2,3)/max(1d-6,v(n+2,4))-1d0)
69235 IF(zdr2.GT.pyr(0)*(zdr1+zdr2)) isl(1)=0
69236 IF(isl(1).EQ.1) isl(2)=0
69237 IF(isl(1).EQ.0) islm=1
69238 IF(isl(2).EQ.0) islm=2
69239 ENDIF
69240 IF(isl(1).EQ.1.OR.isl(2).EQ.1) GOTO 350
69241 ENDIF
69242 ird1=iref(n+1-ns)
69243 ird2=iref(n+2-ns)
69244 IF(igm.GT.0) THEN
69245 IF(mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.
69246 & pmth(2,ird1).OR.p(n+2,5).GE.pmth(2,ird2))) THEN
69247 pmq1=v(n+1,5)/v(im,5)
69248 pmq2=v(n+2,5)/v(im,5)
69249 zd=sqrt(max(0d0,(1d0-v(im,5)/pem**2)*((1d0-pmq1-pmq2)**2-
69250 & 4d0*pmq1*pmq2)))
69251 zh=1d0+pmq1-pmq2
69252 zl=0.5d0*(zh-zd)
69253 zu=0.5d0*(zh+zd)
69254 IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) GOTO 350
69255 ENDIF
69256 ENDIF
69257
69258C...Accepted branch. Construct four-momentum for initial partons.
69259 490 mazip=0
69260 mazic=0
69261 IF(nep.EQ.1) THEN
69262 p(n+1,1)=0d0
69263 p(n+1,2)=0d0
69264 p(n+1,3)=sqrt(max(0d0,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-
69265 & p(n+1,5))))
69266 p(n+1,4)=p(ipa(1),4)
69267 v(n+1,2)=p(n+1,4)
69268 ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN
69269 ped1=0.5d0*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)
69270 p(n+1,1)=0d0
69271 p(n+1,2)=0d0
69272 p(n+1,3)=sqrt(max(0d0,(ped1+p(n+1,5))*(ped1-p(n+1,5))))
69273 p(n+1,4)=ped1
69274 p(n+2,1)=0d0
69275 p(n+2,2)=0d0
69276 p(n+2,3)=-p(n+1,3)
69277 p(n+2,4)=p(im,5)-ped1
69278 v(n+1,2)=p(n+1,4)
69279 v(n+2,2)=p(n+2,4)
69280 ELSEIF(nep.GE.3) THEN
69281C...Rescale all momenta for energy conservation.
69282 loop=0
69283 pes=0d0
69284 pqs=0d0
69285 DO 510 i=1,nep
69286 DO 500 j=1,4
69287 p(n+i,j)=p(ipa(i),j)
69288 500 CONTINUE
69289 pes=pes+p(n+i,4)
69290 pqs=pqs+p(n+i,5)**2/p(n+i,4)
69291 510 CONTINUE
69292 520 loop=loop+1
69293 fac=(ps(5)-pqs)/(pes-pqs)
69294 pes=0d0
69295 pqs=0d0
69296 DO 540 i=1,nep
69297 DO 530 j=1,3
69298 p(n+i,j)=fac*p(n+i,j)
69299 530 CONTINUE
69300 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)
69301 v(n+i,2)=p(n+i,4)
69302 pes=pes+p(n+i,4)
69303 pqs=pqs+p(n+i,5)**2/p(n+i,4)
69304 540 CONTINUE
69305 IF(loop.LT.10.AND.abs(pes-ps(5)).GT.1d-12*ps(5)) GOTO 520
69306
69307C...Construct transverse momentum for ordinary branching in shower.
69308 ELSE
69309 zm=v(im,1)
69310 looppt=0
69311 550 looppt=looppt+1
69312 pzm=sqrt(max(0d0,(pem+p(im,5))*(pem-p(im,5))))
69313 pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4d0*v(n+1,5)*v(n+2,5)
69314 IF(pzm.LE.0d0) THEN
69315 pts=0d0
69316 ELSEIF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
69317 & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
69318 pts=pmls*zm*(1d0-zm)/v(im,5)
69319 ELSEIF(mod(mstj(43),2).EQ.1) THEN
69320 pts=(pem**2*(zm*(1d0-zm)*v(im,5)-(1d0-zm)*v(n+1,5)-
69321 & zm*v(n+2,5))-0.25d0*pmls)/pzm**2
69322 ELSE
69323 pts=pmls*(zm*(1d0-zm)*pem**2/v(im,5)-0.25d0)/pzm**2
69324 ENDIF
69325 IF(pts.LT.0d0.AND.looppt.LT.10) THEN
69326 zm=0.05d0+0.9d0*zm
69327 GOTO 550
69328 ELSEIF(pts.LT.0d0) THEN
69329 GOTO 280
69330 ENDIF
69331 pt=sqrt(max(0d0,pts))
69332
69333C...Global statistics.
69334 mint(353)=mint(353)+1
69335 vint(353)=vint(353)+pt
69336 IF (mint(353).EQ.1) vint(358)=pt
69337
69338C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69339 hazip=0d0
69340 IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21
69341 & .AND.iau.NE.0) THEN
69342 IF(k(igm,3).NE.0) mazip=1
69343 zau=v(igm,1)
69344 IF(iau.EQ.im+1) zau=1d0-v(igm,1)
69345 IF(mazip.EQ.0) zau=0d0
69346 IF(k(igm,2).NE.21) THEN
69347 hazip=2d0*zau/(1d0+zau**2)
69348 ELSE
69349 hazip=(zau/(1d0-zau*(1d0-zau)))**2
69350 ENDIF
69351 IF(k(n+1,2).NE.21) THEN
69352 hazip=hazip*(-2d0*zm*(1d0-zm))/(1d0-2d0*zm*(1d0-zm))
69353 ELSE
69354 hazip=hazip*(zm*(1d0-zm)/(1d0-zm*(1d0-zm)))**2
69355 ENDIF
69356 ENDIF
69357
69358C...Find coefficient of azimuthal asymmetry due to soft gluon
69359C...interference.
69360 hazic=0d0
69361 IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.
69362 & k(n+2,2).EQ.21).AND.iau.NE.0) THEN
69363 IF(k(igm,3).NE.0) mazic=n+1
69364 IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2
69365 IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
69366 & zm.GT.0.5d0) mazic=n+2
69367 IF(k(iau,2).EQ.22) mazic=0
69368 zs=zm
69369 IF(mazic.EQ.n+2) zs=1d0-zm
69370 zgm=v(igm,1)
69371 IF(iau.EQ.im-1) zgm=1d0-v(igm,1)
69372 IF(mazic.EQ.0) zgm=1d0
69373 IF(mazic.NE.0) hazic=(p(im,5)/p(igm,5))*
69374 & sqrt((1d0-zs)*(1d0-zgm)/(zs*zgm))
69375 hazic=min(0.95d0,hazic)
69376 ENDIF
69377 ENDIF
69378
69379C...Construct energies for ordinary branching in shower.
69380 560 IF(nep.EQ.2.AND.igm.GT.0) THEN
69381 IF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
69382 & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
69383 p(n+1,4)=0.5d0*(pem*(v(im,5)+v(n+1,5)-v(n+2,5))+
69384 & pzm*sqrt(max(0d0,pmls))*(2d0*zm-1d0))/v(im,5)
69385 ELSEIF(mod(mstj(43),2).EQ.1) THEN
69386 p(n+1,4)=pem*v(im,1)
69387 ELSE
69388 p(n+1,4)=pem*(0.5d0*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+
69389 & sqrt(pmls)*zm)/v(im,5)
69390 ENDIF
69391
69392C...Already predetermined choice of phi angle or not
69393 phi=paru(2)*pyr(0)
69394 IF(mpspd.EQ.1.AND.igm.EQ.ns+1) THEN
69395 ipspd=ip1+im-ns-2
69396 IF(k(ipspd,4).GT.0) THEN
69397 ipsgd1=k(ipspd,4)
69398 IF(im.EQ.ns+2) THEN
69399 phi=pyangl(p(ipsgd1,1),p(ipsgd1,2))
69400 ELSE
69401 phi=pyangl(-p(ipsgd1,1),p(ipsgd1,2))
69402 ENDIF
69403 ENDIF
69404 ELSEIF(mpspd.EQ.1.AND.igm.EQ.ns+2) THEN
69405 ipspd=ip1+im-ns-2
69406 IF(k(ipspd,4).GT.0) THEN
69407 ipsgd1=k(ipspd,4)
69408 phipsm=pyangl(p(ipspd,1),p(ipspd,2))
69409 thepsm=pyangl(p(ipspd,3),sqrt(p(ipspd,1)**2+p(ipspd,2)**2))
69410 CALL pyrobo(ipsgd1,ipsgd1,0d0,-phipsm,0d0,0d0,0d0)
69411 CALL pyrobo(ipsgd1,ipsgd1,-thepsm,0d0,0d0,0d0,0d0)
69412 phi=pyangl(p(ipsgd1,1),p(ipsgd1,2))
69413 CALL pyrobo(ipsgd1,ipsgd1,thepsm,phipsm,0d0,0d0,0d0)
69414 ENDIF
69415 ENDIF
69416
69417C...Construct momenta for ordinary branching in shower.
69418 p(n+1,1)=pt*cos(phi)
69419 p(n+1,2)=pt*sin(phi)
69420 IF(k(im,2).EQ.21.AND.iabs(k(n+1,2)).LE.10.AND.
69421 & (mstj(44).EQ.3.OR.mstj(44).EQ.5)) THEN
69422 p(n+1,3)=0.5d0*(pzm*(v(im,5)+v(n+1,5)-v(n+2,5))+
69423 & pem*sqrt(max(0d0,pmls))*(2d0*zm-1d0))/v(im,5)
69424 ELSEIF(pzm.GT.0d0) THEN
69425 p(n+1,3)=0.5d0*(v(n+2,5)-v(n+1,5)-v(im,5)+
69426 & 2d0*pem*p(n+1,4))/pzm
69427 ELSE
69428 p(n+1,3)=0d0
69429 ENDIF
69430 p(n+2,1)=-p(n+1,1)
69431 p(n+2,2)=-p(n+1,2)
69432 p(n+2,3)=pzm-p(n+1,3)
69433 p(n+2,4)=pem-p(n+1,4)
69434 IF(mstj(43).LE.2) THEN
69435 v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)
69436 v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)
69437 ENDIF
69438 ENDIF
69439
69440C...Rotate and boost daughters.
69441 IF(igm.GT.0) THEN
69442 IF(mstj(43).LE.2) THEN
69443 bex=p(igm,1)/p(igm,4)
69444 bey=p(igm,2)/p(igm,4)
69445 bez=p(igm,3)/p(igm,4)
69446 ga=p(igm,4)/p(igm,5)
69447 gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1d0+ga)-
69448 & p(im,4))
69449 ELSE
69450 bex=0d0
69451 bey=0d0
69452 bez=0d0
69453 ga=1d0
69454 gabep=0d0
69455 ENDIF
69456 ptimb=sqrt((p(im,1)+gabep*bex)**2+(p(im,2)+gabep*bey)**2)
69457 the=pyangl(p(im,3)+gabep*bez,ptimb)
69458 IF(ptimb.GT.1d-4) THEN
69459 phi=pyangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)
69460 ELSE
69461 phi=0d0
69462 ENDIF
69463 DO 570 i=n+1,n+2
69464 dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+
69465 & sin(the)*cos(phi)*p(i,3)
69466 dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+
69467 & sin(the)*sin(phi)*p(i,3)
69468 dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)
69469 dp(4)=p(i,4)
69470 dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)
69471 dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))
69472 p(i,1)=dp(1)+dgabp*bex
69473 p(i,2)=dp(2)+dgabp*bey
69474 p(i,3)=dp(3)+dgabp*bez
69475 p(i,4)=ga*(dp(4)+dbp)
69476 570 CONTINUE
69477 ENDIF
69478
69479C...Weight with azimuthal distribution, if required.
69480 IF(mazip.NE.0.OR.mazic.NE.0) THEN
69481 DO 580 j=1,3
69482 dpt(1,j)=p(im,j)
69483 dpt(2,j)=p(iau,j)
69484 dpt(3,j)=p(n+1,j)
69485 580 CONTINUE
69486 dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
69487 dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
69488 dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
69489 DO 590 j=1,3
69490 dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/max(1d-10,dpmm)
69491 dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/max(1d-10,dpmm)
69492 590 CONTINUE
69493 dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
69494 dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
69495 IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN
69496 cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
69497 & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
69498 IF(mazip.NE.0) THEN
69499 IF(1d0+hazip*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(hazip)))
69500 & GOTO 560
69501 ENDIF
69502 IF(mazic.NE.0) THEN
69503 IF(mazic.EQ.n+2) cad=-cad
69504 IF((1d0-hazic)*(1d0-hazic*cad)/(1d0+hazic**2-2d0*hazic*cad)
69505 & .LT.pyr(0)) GOTO 560
69506 ENDIF
69507 ENDIF
69508 ENDIF
69509
69510C...Azimuthal anisotropy due to interference with initial state partons.
69511 IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.
69512 &k(n+2,2).EQ.21)) THEN
69513 iii=im-ns-1
69514 IF(isii(iii).GE.1) THEN
69515 iaziid=n+1
69516 IF(k(n+1,2).NE.21) iaziid=n+2
69517 IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.
69518 & p(n+1,4).GT.p(n+2,4)) iaziid=n+2
69519 theiid=pyangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))
69520 IF(iii.EQ.2) theiid=paru(1)-theiid
69521 phiiid=pyangl(p(iaziid,1),p(iaziid,2))
69522 hazii=min(0.95d0,theiid/theiis(iii,isii(iii)))
69523 cad=cos(phiiid-phiiis(iii,isii(iii)))
69524 phirel=abs(phiiid-phiiis(iii,isii(iii)))
69525 IF(phirel.GT.paru(1)) phirel=paru(2)-phirel
69526 IF((1d0-hazii)*(1d0-hazii*cad)/(1d0+hazii**2-2d0*hazii*cad)
69527 & .LT.pyr(0)) GOTO 560
69528 ENDIF
69529 ENDIF
69530
69531C...Continue loop over partons that may branch, until none left.
69532 IF(igm.GE.0) k(im,1)=14
69533 n=n+nep
69534 nep=2
69535 IF(n.GT.mstu(4)-mstu(32)-10) THEN
69536 CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')
69537 IF(mstu(21).GE.1) n=ns
69538 IF(mstu(21).GE.1) RETURN
69539 ENDIF
69540 GOTO 290
69541
69542C...Set information on imagined shower initiator.
69543 600 IF(npa.GE.2) THEN
69544 k(ns+1,1)=11
69545 k(ns+1,2)=94
69546 k(ns+1,3)=ip1
69547 IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2
69548 k(ns+1,4)=ns+2
69549 k(ns+1,5)=ns+1+npa
69550 iim=1
69551 ELSE
69552 iim=0
69553 ENDIF
69554
69555C...Reconstruct string drawing information.
69556 DO 610 i=ns+1+iim,n
69557 kq=kchg(pycomp(k(i,2)),2)
69558 IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN
69559 k(i,1)=1
69560 ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.
69561 & iabs(k(i,2)).LE.18) THEN
69562 k(i,1)=1
69563 ELSEIF(k(i,1).LE.10) THEN
69564 k(i,4)=mstu(5)*(k(i,4)/mstu(5))
69565 k(i,5)=mstu(5)*(k(i,5)/mstu(5))
69566 ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN
69567 id1=mod(k(i,4),mstu(5))
69568 IF(kq.EQ.1.AND.k(i,2).GT.0) id1=mod(k(i,4),mstu(5))+1
69569 IF(kq.EQ.2.AND.(k(id1,2).EQ.21.OR.k(id1+1,2).EQ.21).AND.
69570 & pyr(0).GT.0.5d0) id1=mod(k(i,4),mstu(5))+1
69571 id2=2*mod(k(i,4),mstu(5))+1-id1
69572 k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
69573 k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2
69574 k(id1,4)=k(id1,4)+mstu(5)*i
69575 k(id1,5)=k(id1,5)+mstu(5)*id2
69576 k(id2,4)=k(id2,4)+mstu(5)*id1
69577 k(id2,5)=k(id2,5)+mstu(5)*i
69578 ELSE
69579 id1=mod(k(i,4),mstu(5))
69580 id2=id1+1
69581 k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1
69582 k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1
69583 IF(kq.EQ.1.OR.k(id1,1).GE.11) THEN
69584 k(id1,4)=k(id1,4)+mstu(5)*i
69585 k(id1,5)=k(id1,5)+mstu(5)*i
69586 ELSE
69587 k(id1,4)=0
69588 k(id1,5)=0
69589 ENDIF
69590 k(id2,4)=0
69591 k(id2,5)=0
69592 ENDIF
69593 610 CONTINUE
69594
69595C...Transformation from CM frame.
69596 IF(npa.EQ.1) THEN
69597 the=pyangl(p(ipa(1),3),sqrt(p(ipa(1),1)**2+p(ipa(1),2)**2))
69598 phi=pyangl(p(ipa(1),1),p(ipa(1),2))
69599 mstu(33)=1
69600 CALL pyrobo(ns+1,n,the,phi,0d0,0d0,0d0)
69601 ELSEIF(npa.EQ.2) THEN
69602 bex=ps(1)/ps(4)
69603 bey=ps(2)/ps(4)
69604 bez=ps(3)/ps(4)
69605 ga=ps(4)/ps(5)
69606 gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))
69607 & /(1d0+ga)-p(ipa(1),4))
69608 the=pyangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)
69609 & +gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))
69610 phi=pyangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)
69611 mstu(33)=1
69612 CALL pyrobo(ns+1,n,the,phi,bex,bey,bez)
69613 ELSE
69614 CALL pyrobo(ipa(1),ipa(npa),0d0,0d0,ps(1)/ps(4),ps(2)/ps(4),
69615 & ps(3)/ps(4))
69616 mstu(33)=1
69617 CALL pyrobo(ns+1,n,0d0,0d0,ps(1)/ps(4),ps(2)/ps(4),ps(3)/ps(4))
69618 ENDIF
69619
69620C...Decay vertex of shower.
69621 DO 630 i=ns+1,n
69622 DO 620 j=1,5
69623 v(i,j)=v(ip1,j)
69624 620 CONTINUE
69625 630 CONTINUE
69626
69627C...Delete trivial shower, else connect initiators.
69628 IF(n.LE.ns+npa+iim) THEN
69629 n=ns
69630 ELSE
69631 DO 640 ip=1,npa
69632 k(ipa(ip),1)=14
69633 k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip
69634 k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip
69635 k(ns+iim+ip,3)=ipa(ip)
69636 IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1
69637 IF(k(ns+iim+ip,1).NE.1) THEN
69638 k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)
69639 k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)
69640 ENDIF
69641 640 CONTINUE
69642 ENDIF
69643
69644 RETURN
69645 END
69646
69647C*********************************************************************
69648
69649C...PYPTFS
69650C...Generates pT-ordered timelike final-state parton showers.
69651
69652C...MODE defines how to find radiators and recoilers.
69653C... = 0 : based on colour flow between undecayed partons.
69654C... = 1 : for IPART <= NPARTD only consider primary partons,
69655C... whether decayed or not; else as above.
69656C... = 2 : based on common history, whether decayed or not.
69657C... = 3 : use (or create) MCT color information to shower partons
69658
69659 SUBROUTINE pyptfs(MODE,PTMAX,PTMIN,PTGEN)
69660
69661C...Double precision and integer declarations.
69662 IMPLICIT DOUBLE PRECISION(a-h, o-z)
69663 IMPLICIT INTEGER(I-N)
69664 INTEGER PYK,PYCHGE,PYCOMP
69665C...Parameter statement to help give large particle numbers.
69666 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
69667 &kexcit=4000000,kdimen=5000000)
69668C...Parameter statement for maximum size of showers.
69669 parameter(maxnur=1000)
69670C...Commonblocks.
69671 common/pypart/npart,npartd,ipart(maxnur),ptpart(maxnur)
69672 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
69673 common/pyctag/nct,mct(4000,2)
69674 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
69675 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
69676 common/pypars/mstp(200),parp(200),msti(200),pari(200)
69677 common/pyint1/mint(400),vint(400)
69678 SAVE /pypart/,/pyjets/,/pyctag/,/pydat1/,/pydat2/,/pypars/,
69679 &/pyint1/
69680C...Local arrays.
69681 dimension ipos(2*maxnur),irec(2*maxnur),iflg(2*maxnur),
69682 &iscol(2*maxnur),ischg(2*maxnur),ptsca(2*maxnur),imesav(2*maxnur),
69683 &pt2sav(2*maxnur),zsav(2*maxnur),shtsav(2*maxnur),
69684 &mesys(maxnur,0:2),psum(5),dpt(5,4)
69685C...Statement functions.
69686 shat(i,j)=(p(i,4)+p(j,4))**2-(p(i,1)+p(j,1))**2-
69687 &(p(i,2)+p(j,2))**2-(p(i,3)+p(j,3))**2
69688
69689C...Initial values. Check that valid system.
69690 ptgen=0d0
69691 IF(mstj(41).NE.1.AND.mstj(41).NE.2.AND.mstj(41).NE.11.AND.
69692 &mstj(41).NE.12) RETURN
69693 IF(npart.LE.0) THEN
69694 CALL pyerrm(2,'(PYPTFS:) showering system too small')
69695 RETURN
69696 ENDIF
69697 pt2cmx=ptmax**2
69698 iord=1
69699
69700C...Mass thresholds and Lambda for QCD evolution.
69701 pmb=pmas(5,1)
69702 pmc=pmas(4,1)
69703 alam5=parj(81)
69704 alam4=alam5*(pmb/alam5)**(2d0/25d0)
69705 alam3=alam4*(pmc/alam4)**(2d0/27d0)
69706 pmbs=pmb**2
69707 pmcs=pmc**2
69708 alam5s=alam5**2
69709 alam4s=alam4**2
69710 alam3s=alam3**2
69711
69712C...Cutoff scale for QCD evolution. Starting pT2.
69713 nflav=max(0,min(5,mstj(45)))
69714 pt0c=0.5d0*parj(82)
69715 pt2cmn=max(ptmin,pt0c,1.1d0*alam3)**2
69716
69717C...Parameters for QED evolution.
69718 aem2pi=paru(101)/paru(2)
69719 pt0eq=0.5d0*parj(83)
69720 pt0el=0.5d0*parj(90)
69721
69722C...Reset. Remove irrelevant colour tags.
69723 nevol=0
69724 DO 100 j=1,4
69725 psum(j)=0d0
69726 100 CONTINUE
69727 DO 110 i=mint(84)+1,n
69728 IF(k(i,2).GT.0.AND.k(i,2).LT.6) THEN
69729 k(i,5)=0
69730 mct(i,2)=0
69731 ENDIF
69732 IF(k(i,2).LT.0.AND.k(i,2).GT.-6) THEN
69733 k(i,4)=0
69734 mct(i,1)=0
69735 ENDIF
69736 110 CONTINUE
69737 nparts=npart
69738
69739C...Begin loop to set up showering partons. Sum four-momenta.
69740 DO 230 ip=1,npart
69741 i=ipart(ip)
69742 IF(mode.NE.1.OR.i.GT.npartd) THEN
69743 IF(k(i,1).GT.10) GOTO 230
69744 ELSEIF(k(i,3).GT.mint(84)) THEN
69745 IF(k(i,3).GT.mint(84)+2) GOTO 230
69746 ELSE
69747 IF(k(k(i,3),3).GT.mint(83)+6) GOTO 230
69748 ENDIF
69749 DO 120 j=1,4
69750 psum(j)=psum(j)+p(i,j)
69751 120 CONTINUE
69752
69753C...Find colour and charge, but skip diquarks.
69754 IF(iabs(k(i,2)).GT.1000.AND.iabs(k(i,2)).LT.10000) GOTO 230
69755 kcol=isign(kchg(pycomp(k(i,2)),2),k(i,2))
69756 kcha=isign(kchg(pycomp(k(i,2)),1),k(i,2))
69757
69758C...QUARKONIA++
69759 IF (iabs(k(i,2)).GE.9900101.AND.iabs(k(i,2)).LE.9910555) THEN
69760 IF (mstp(148).GE.1) THEN
69761C...Temporary: force no radiation from quarkonia since not yet treated
69762 CALL pyerrm(11,'(PYPTFS:) quarkonia showers not yet in'
69763 & //' PYPTFS, switched off')
69764 CALL pygive('MSTP(148)=0')
69765 ENDIF
69766 IF (mstp(148).EQ.0) THEN
69767C...Skip quarkonia if radiation switched off
69768 GOTO 230
69769 ENDIF
69770 ENDIF
69771C...QUARKONIA--
69772
69773C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69774C...(only intended for studying the effects of switching such rad on/off)
69775 IF (mstj(39).GT.0.AND.iabs(k(i,2)).EQ.mstj(39)) THEN
69776 GOTO 230
69777 ENDIF
69778
69779C...Either colour or anticolour charge radiates; for gluon both.
69780 DO 180 jsgcol=1,-1,-2
69781 IF(kcol.EQ.jsgcol.OR.kcol.EQ.2) THEN
69782 jcol=4+(1-jsgcol)/2
69783 jcolr=9-jcol
69784
69785C...Basic info about radiating parton.
69786 nevol=nevol+1
69787 ipos(nevol)=i
69788 iflg(nevol)=0
69789 iscol(nevol)=jsgcol
69790 ischg(nevol)=0
69791 ptsca(nevol)=ptpart(ip)
69792
69793C...Begin search for colour recoiler when MODE = 0 or 1.
69794 IF(mode.LE.1) THEN
69795C...Find sister with matching anticolour to the radiating parton.
69796 irold=i
69797 irnew=k(irold,jcol)/mstu(5)
69798 move=1
69799
69800C...Skip radiation off loose colour ends.
69801 130 IF(irnew.EQ.0) THEN
69802 nevol=nevol-1
69803 GOTO 180
69804
69805C...Optionally skip radiation on dipole to beam remnant.
69806 ELSEIF(mstp(72).LE.1.AND.irnew.GT.mint(53)) THEN
69807 nevol=nevol-1
69808 GOTO 180
69809
69810C...For now always skip radiation on dipole to junction.
69811 ELSEIF(k(irnew,2).EQ.88) THEN
69812 nevol=nevol-1
69813 GOTO 180
69814
69815C...For MODE=1: if reached primary then done.
69816 ELSEIF(mode.EQ.1.AND.irnew.GT.mint(84)+2.AND.
69817 & irnew.LE.npartd) THEN
69818
69819C...If sister stable and points back then done.
69820 ELSEIF(move.EQ.1.AND.k(irnew,jcolr)/mstu(5).EQ.irold)
69821 & THEN
69822 IF(k(irnew,1).LT.10) THEN
69823
69824C...If sister unstable then go to her daughter.
69825 ELSE
69826 irold=irnew
69827 irnew=mod(k(irnew,jcolr),mstu(5))
69828 move=2
69829 GOTO 130
69830 ENDIF
69831
69832C...If found mother then look for aunt.
69833 ELSEIF(move.EQ.1.AND.mod(k(irnew,jcol),mstu(5)).EQ.
69834 & irold) THEN
69835 irold=irnew
69836 irnew=k(irold,jcol)/mstu(5)
69837 GOTO 130
69838
69839C...If daughter stable then done.
69840 ELSEIF(move.EQ.2.AND.k(irnew,jcolr)/mstu(5).EQ.irold)
69841 & THEN
69842 IF(k(irnew,1).LT.10) THEN
69843
69844C...If daughter unstable then go to granddaughter.
69845 ELSE
69846 irold=irnew
69847 irnew=mod(k(irnew,jcolr),mstu(5))
69848 move=2
69849 GOTO 130
69850 ENDIF
69851
69852C...If daughter points to another daughter then done or move up.
69853 ELSEIF(move.EQ.2.AND.mod(k(irnew,jcol),mstu(5)).EQ.
69854 & irold) THEN
69855 IF(k(irnew,1).LT.10) THEN
69856 ELSE
69857 irold=irnew
69858 irnew=k(irnew,jcol)/mstu(5)
69859 move=1
69860 GOTO 130
69861 ENDIF
69862 ENDIF
69863
69864C...Begin search for colour recoiler when MODE = 2.
69865 ELSEIF (mode.EQ.2) THEN
69866 irold=i
69867 irnew=k(irold,jcol)/mstu(5)
69868 140 IF (irnew.LE.0.OR.irnew.GT.n) THEN
69869C...If no color partner found, pick at random among other primaries
69870C...(e.g., when the color line is traced all the way to the beam)
69871 istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
69872 irnew=ipart(1+mod(ip+istep-1,npart))
69873 ELSEIF(k(irnew,jcolr)/mstu(5).NE.irold) THEN
69874C...Step up to mother if radiating parton already branched.
69875 IF(k(irnew,2).EQ.k(irold,2)) THEN
69876 irold=irnew
69877 irnew=k(irold,jcol)/mstu(5)
69878 GOTO 140
69879C...Pick sister by history if no anticolour available.
69880 ELSE
69881 IF(irold.GT.1.AND.k(irold-1,3).EQ.k(irold,3)) THEN
69882 irnew=irold-1
69883 ELSEIF(irold.LT.n.AND.k(irold+1,3).EQ.k(irold,3))
69884 & THEN
69885 irnew=irold+1
69886C...Last resort: pick at random among other primaries.
69887 ELSE
69888 istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
69889 irnew=ipart(1+mod(ip+istep-1,npart))
69890 ENDIF
69891 ENDIF
69892 ENDIF
69893C...Trace down if sister branched.
69894 150 IF(k(irnew,1).GT.10) THEN
69895 irtmp=mod(k(irnew,jcolr),mstu(5))
69896C...If no correct color-daughter found, swap.
69897 IF (irtmp.EQ.0) THEN
69898 jcol=9-jcol
69899 jcolr=9-jcolr
69900 irtmp=mod(k(irnew,jcolr),mstu(5))
69901 ENDIF
69902 irnew=irtmp
69903 GOTO 150
69904 ENDIF
69905 ELSEIF (mode.EQ.3) THEN
69906C...The following will add MCT colour tracing for unprepped events
69907C...If not done, trace Les Houches colour tags for this dipole
69908 jcolsv=jcol
69909 IF (mct(i,jcol-3).EQ.0) THEN
69910C...Special end code -1 : trace to color partner or 0, return in IEND
69911 iend=-1
69912 CALL pycttr(i,jcol,iend)
69913C...Clean up mother/daughter 'read' tags set by PYCTTR
69914 jcol=jcolsv
69915 DO 160 ir=1,n
69916 k(ir,4)=mod(k(ir,4),mstu(5)**2)
69917 k(ir,5)=mod(k(ir,5),mstu(5)**2)
69918 mct(ir,1)=0
69919 mct(ir,2)=0
69920 160 CONTINUE
69921 ELSE
69922 iend=0
69923 DO 170 ir=1,n
69924 IF (k(ir,1).GT.0.AND.mct(ir,6-jcol).EQ.mct(i,jcol-3))
69925 & iend=ir
69926 170 CONTINUE
69927 ENDIF
69928C...If no color partner, then we hit beam
69929 IF (iend.LE.0) THEN
69930C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
69931 IF (mstp(72).LE.1) THEN
69932 nevol=nevol-1
69933 GOTO 180
69934 ELSE
69935C...Else try a random partner
69936 istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
69937 irnew=ipart(1+mod(ip+istep-1,npart))
69938 ENDIF
69939 ELSE
69940C...Else save recoiling colour partner
69941 irnew=iend
69942 ENDIF
69943
69944 ENDIF
69945
69946C...Now found other end of colour dipole.
69947 irec(nevol)=irnew
69948 ENDIF
69949 180 CONTINUE
69950
69951C...Also electrical charge may radiate; so far only quarks and leptons.
69952 IF((mstj(41).EQ.2.OR.mstj(41).EQ.12).AND.kcha.NE.0.AND.
69953 & iabs(k(i,2)).LE.18) THEN
69954
69955C...Basic info about radiating parton.
69956 nevol=nevol+1
69957 ipos(nevol)=i
69958 iflg(nevol)=0
69959 iscol(nevol)=0
69960 ischg(nevol)=kcha
69961 ptsca(nevol)=ptpart(ip)
69962
69963C...Pick nearest (= smallest invariant mass) charged particle
69964C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
69965 IF(mode.LE.1) THEN
69966 irnew=0
69967 pm2min=vint(2)
69968 DO 190 ip2=1,npart+n-mint(53)
69969 IF(ip2.EQ.ip) GOTO 190
69970 IF(ip2.LE.npart) THEN
69971 i2=ipart(ip2)
69972 IF(mode.NE.1.OR.i2.GT.npartd) THEN
69973 IF(k(i2,1).GT.10) GOTO 190
69974 ELSEIF(k(i2,3).GT.mint(84)) THEN
69975 IF(k(i2,3).GT.mint(84)+2) GOTO 190
69976 ELSE
69977 IF(k(k(i2,3),3).GT.mint(83)+6) GOTO 190
69978 ENDIF
69979 ELSE
69980 i2=mint(53)+ip2-npart
69981 ENDIF
69982 IF(kchg(pycomp(k(i2,2)),1).EQ.0) GOTO 190
69983 pm2inv=(p(i,4)+p(i2,4))**2-(p(i,1)+p(i2,1))**2-
69984 & (p(i,2)+p(i2,2))**2-(p(i,3)+p(i2,3))**2
69985 IF(pm2inv.LT.pm2min) THEN
69986 irnew=i2
69987 pm2min=pm2inv
69988 ENDIF
69989 190 CONTINUE
69990 IF(irnew.EQ.0) THEN
69991 nevol=nevol-1
69992 GOTO 230
69993 ENDIF
69994
69995C...Begin search for charge recoiler when MODE = 2.
69996 ELSE
69997 irold=i
69998C...Pick sister by history; step up if parton already branched.
69999 200 IF(k(irold,3).GT.0.AND.k(k(irold,3),2).EQ.k(irold,2)) THEN
70000 irold=k(irold,3)
70001 GOTO 200
70002 ENDIF
70003 IF(irold.GT.1.AND.k(irold-1,3).EQ.k(irold,3)) THEN
70004 irnew=irold-1
70005 ELSEIF(irold.LT.n.AND.k(irold+1,3).EQ.k(irold,3)) THEN
70006 irnew=irold+1
70007C...Last resort: pick at random among other primaries.
70008 ELSE
70009 istep=max(1,min(npart-1,int(1d0+(npart-1)*pyr(0))))
70010 irnew=ipart(1+mod(ip+istep-1,npart))
70011 ENDIF
70012C...Trace down if sister branched.
70013 210 IF(k(irnew,1).GT.10) THEN
70014 DO 220 ir=irnew+1,n
70015 IF(k(ir,3).EQ.irnew.AND.k(ir,2).EQ.k(irnew,2)) THEN
70016 irnew=ir
70017 GOTO 210
70018 ENDIF
70019 220 CONTINUE
70020 ENDIF
70021 ENDIF
70022 irec(nevol)=irnew
70023 ENDIF
70024
70025C...End loop to set up showering partons. System invariant mass.
70026 230 CONTINUE
70027 IF(nevol.LE.0) RETURN
70028 IF (mode.EQ.3.AND.nevol.LE.1) RETURN
70029 psum(5)=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
70030
70031C...Check if 3-jet matrix elements to be used.
70032 m3jc=0
70033 alpha=0.5d0
70034 nmesys=0
70035 IF(mstj(47).GE.1) THEN
70036
70037C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70038 kfsrce=0
70039 ipart1=k(ipart(1),3)
70040 ipart2=k(ipart(2),3)
70041 240 IF(ipart1.EQ.ipart2.AND.ipart1.GT.0) THEN
70042 kfsrce=iabs(k(ipart1,2))
70043 ELSEIF(ipart1.GT.ipart2.AND.ipart2.GT.0) THEN
70044 ipart1=k(ipart1,3)
70045 GOTO 240
70046 ELSEIF(ipart2.GT.ipart1.AND.ipart1.GT.0) THEN
70047 ipart2=k(ipart2,3)
70048 GOTO 240
70049 ENDIF
70050 itypes=0
70051 IF(kfsrce.GE.1.AND.kfsrce.LE.8) itypes=1
70052 IF(kfsrce.GE.ksusy1+1.AND.kfsrce.LE.ksusy1+8) itypes=2
70053 IF(kfsrce.GE.ksusy2+1.AND.kfsrce.LE.ksusy2+8) itypes=2
70054 IF(kfsrce.GE.21.AND.kfsrce.LE.24) itypes=3
70055 IF(kfsrce.GE.32.AND.kfsrce.LE.34) itypes=3
70056 IF(kfsrce.EQ.25.OR.(kfsrce.GE.35.AND.kfsrce.LE.37)) itypes=4
70057 IF(kfsrce.GE.ksusy1+22.AND.kfsrce.LE.ksusy1+37) itypes=5
70058 IF(kfsrce.EQ.ksusy1+21) itypes=6
70059
70060C...Identify two primary showerers.
70061 kfla1=iabs(k(ipart(1),2))
70062 itype1=0
70063 IF(kfla1.GE.1.AND.kfla1.LE.8) itype1=1
70064 IF(kfla1.GE.ksusy1+1.AND.kfla1.LE.ksusy1+8) itype1=2
70065 IF(kfla1.GE.ksusy2+1.AND.kfla1.LE.ksusy2+8) itype1=2
70066 IF(kfla1.GE.21.AND.kfla1.LE.24) itype1=3
70067 IF(kfla1.GE.32.AND.kfla1.LE.34) itype1=3
70068 IF(kfla1.EQ.25.OR.(kfla1.GE.35.AND.kfla1.LE.37)) itype1=4
70069 IF(kfla1.GE.ksusy1+22.AND.kfla1.LE.ksusy1+37) itype1=5
70070 IF(kfla1.EQ.ksusy1+21) itype1=6
70071 kfla2=iabs(k(ipart(2),2))
70072 itype2=0
70073 IF(kfla2.GE.1.AND.kfla2.LE.8) itype2=1
70074 IF(kfla2.GE.ksusy1+1.AND.kfla2.LE.ksusy1+8) itype2=2
70075 IF(kfla2.GE.ksusy2+1.AND.kfla2.LE.ksusy2+8) itype2=2
70076 IF(kfla2.GE.21.AND.kfla2.LE.24) itype2=3
70077 IF(kfla2.GE.32.AND.kfla2.LE.34) itype2=3
70078 IF(kfla2.EQ.25.OR.(kfla2.GE.35.AND.kfla2.LE.37)) itype2=4
70079 IF(kfla2.GE.ksusy1+22.AND.kfla2.LE.ksusy1+37) itype2=5
70080 IF(kfla2.EQ.ksusy1+21) itype2=6
70081
70082C...Order of showerers. Presence of gluino.
70083 itypmn=min(itype1,itype2)
70084 itypmx=max(itype1,itype2)
70085 iord=1
70086 IF(itype1.GT.itype2) iord=2
70087 iglui=0
70088 IF(itype1.EQ.6.OR.itype2.EQ.6) iglui=1
70089
70090C...Require exactly two primary showerers for ME corrections.
70091 nprim=0
70092 IF(ipart1.GT.0) THEN
70093 DO 250 i=1,n
70094 IF(k(i,3).EQ.ipart1.AND.k(i,2).NE.k(ipart1,2)) nprim=nprim+1
70095 250 CONTINUE
70096 ENDIF
70097 IF(nprim.NE.2) THEN
70098
70099C...Predetermined and default matrix element kinds.
70100 ELSEIF(mstj(38).NE.0) THEN
70101 m3jc=mstj(38)
70102 alpha=parj(80)
70103 mstj(38)=0
70104 ELSEIF(mstj(47).GE.6) THEN
70105 m3jc=mstj(47)
70106 ELSE
70107 iclass=1
70108 icombi=4
70109
70110C...Vector/axial vector -> q + qbar; q -> q + V.
70111 IF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.(itypes.EQ.0.OR.
70112 & itypes.EQ.3)) THEN
70113 iclass=2
70114 IF(kfsrce.EQ.21.OR.kfsrce.EQ.22) THEN
70115 icombi=1
70116 ELSEIF(kfsrce.EQ.23.OR.(kfsrce.EQ.0.AND.
70117 & k(ipart(1),2)+k(ipart(2),2).EQ.0)) THEN
70118C...gamma*/Z0: assume e+e- initial state if unknown.
70119 ei=-1d0
70120 IF(kfsrce.EQ.23) THEN
70121 iannfl=ipart1
70122 IF(k(iannfl,2).EQ.23) iannfl=k(iannfl,3)
70123 IF(iannfl.GT.0) THEN
70124 IF(k(iannfl,2).EQ.23) iannfl=k(iannfl,3)
70125 ENDIF
70126 IF(iannfl.NE.0) THEN
70127 kannfl=iabs(k(iannfl,2))
70128 IF(kannfl.GE.1.AND.kannfl.LE.18) ei=kchg(kannfl,1)/3d0
70129 ENDIF
70130 ENDIF
70131 ai=sign(1d0,ei+0.1d0)
70132 vi=ai-4d0*ei*paru(102)
70133 ef=kchg(kfla1,1)/3d0
70134 af=sign(1d0,ef+0.1d0)
70135 vf=af-4d0*ef*paru(102)
70136 xwc=1d0/(16d0*paru(102)*(1d0-paru(102)))
70137 sh=psum(5)**2
70138 sqmz=pmas(23,1)**2
70139 sqwz=psum(5)*pmas(23,2)
70140 sbwz=1d0/((sh-sqmz)**2+sqwz**2)
70141 vect=ei**2*ef**2+2d0*ei*vi*ef*vf*xwc*sh*(sh-sqmz)*sbwz+
70142 & (vi**2+ai**2)*vf**2*xwc**2*sh**2*sbwz
70143 axiv=(vi**2+ai**2)*af**2*xwc**2*sh**2*sbwz
70144 icombi=3
70145 alpha=vect/(vect+axiv)
70146 ELSEIF(kfsrce.EQ.24.OR.kfsrce.EQ.0) THEN
70147 icombi=4
70148 ENDIF
70149C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70150 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.5) THEN
70151 iclass=2
70152 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
70153 & itypes.EQ.1)) THEN
70154 iclass=3
70155
70156C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70157 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.1.AND.itypes.EQ.4) THEN
70158 iclass=4
70159 IF(kfsrce.EQ.25.OR.kfsrce.EQ.35.OR.kfsrce.EQ.37) THEN
70160 icombi=1
70161 ELSEIF(kfsrce.EQ.36) THEN
70162 icombi=2
70163 ENDIF
70164 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
70165 & itypes.EQ.1)) THEN
70166 iclass=5
70167
70168C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70169 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
70170 & itypes.EQ.3)) THEN
70171 iclass=6
70172 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.3.AND.(itypes.EQ.0.OR.
70173 & itypes.EQ.2)) THEN
70174 iclass=7
70175 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.2.AND.itypes.EQ.4) THEN
70176 iclass=8
70177 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.4.AND.(itypes.EQ.0.OR.
70178 & itypes.EQ.2)) THEN
70179 iclass=9
70180
70181C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70182 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.(itypes.EQ.0.OR.
70183 & itypes.EQ.5)) THEN
70184 iclass=10
70185 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
70186 & itypes.EQ.2)) THEN
70187 iclass=11
70188 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.5.AND.(itypes.EQ.0.OR.
70189 & itypes.EQ.1)) THEN
70190 iclass=12
70191
70192C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70193 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.2.AND.itypes.EQ.6) THEN
70194 iclass=13
70195 ELSEIF(itypmn.EQ.1.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
70196 & itypes.EQ.2)) THEN
70197 iclass=14
70198 ELSEIF(itypmn.EQ.2.AND.itypmx.EQ.6.AND.(itypes.EQ.0.OR.
70199 & itypes.EQ.1)) THEN
70200 iclass=15
70201
70202C...g -> ~g + ~g (eikonal approximation).
70203 ELSEIF(itypmn.EQ.6.AND.itypmx.EQ.6.AND.itypes.EQ.0) THEN
70204 iclass=16
70205 ENDIF
70206 m3jc=5*iclass+icombi
70207 ENDIF
70208
70209C...Store pair that together define matrix element treatment.
70210 IF(m3jc.NE.0) THEN
70211 nmesys=1
70212 mesys(nmesys,0)=m3jc
70213 mesys(nmesys,1)=ipart(1)
70214 mesys(nmesys,2)=ipart(2)
70215 ENDIF
70216
70217C...Store qqbar or l+l- pairs for QED radiation.
70218 IF(kfla1.LE.18.AND.kfla2.LE.18) THEN
70219 nmesys=nmesys+1
70220 mesys(nmesys,0)=101
70221 IF(k(ipart(1),2)+k(ipart(2),2).EQ.0) mesys(nmesys,0)=102
70222 mesys(nmesys,1)=ipart(1)
70223 mesys(nmesys,2)=ipart(2)
70224 ENDIF
70225
70226C...Store other qqbar/l+l- pairs from g/gamma branchings.
70227 DO 290 i1=1,n
70228 IF(k(i1,1).GT.10.OR.iabs(k(i1,2)).GT.18) GOTO 290
70229 i1m=k(i1,3)
70230 260 IF(i1m.GT.0.AND.k(i1m,2).EQ.k(i1,2)) THEN
70231 i1m=k(i1m,3)
70232 GOTO 260
70233 ENDIF
70234C...Move up this check to avoid out-of-bounds.
70235 IF(i1m.EQ.0) GOTO 290
70236 IF(k(i1m,2).NE.21.AND.k(i1m,2).NE.22) GOTO 290
70237 DO 280 i2=i1+1,n
70238 IF(k(i2,1).GT.10.OR.k(i2,2)+k(i1,2).NE.0) GOTO 280
70239 i2m=k(i2,3)
70240 270 IF(i2m.GT.0.AND.k(i2m,2).EQ.k(i2,2)) THEN
70241 i2m=k(i2m,3)
70242 GOTO 270
70243 ENDIF
70244 IF(i1m.EQ.i2m.AND.i1m.GT.0) THEN
70245 nmesys=nmesys+1
70246 mesys(nmesys,0)=66
70247 mesys(nmesys,1)=i1
70248 mesys(nmesys,2)=i2
70249 nmesys=nmesys+1
70250 mesys(nmesys,0)=102
70251 mesys(nmesys,1)=i1
70252 mesys(nmesys,2)=i2
70253 ENDIF
70254 280 CONTINUE
70255 290 CONTINUE
70256 ENDIF
70257
70258C..Loopback point for counting number of emissions.
70259 ngen=0
70260 300 ngen=ngen+1
70261
70262C...Begin loop to evolve all existing partons, if required.
70263 310 imx=0
70264 pt2mx=0d0
70265 DO 380 ievol=1,nevol
70266 IF(iflg(ievol).EQ.0) THEN
70267
70268C...Basic info on radiator and recoil.
70269 i=ipos(ievol)
70270 ir=irec(ievol)
70271 sht=shat(i,ir)
70272 pm2i=p(i,5)**2
70273 pm2r=p(ir,5)**2
70274
70275C...Invariant mass of "dipole".Starting value for pT evolution.
70276 shtcor=(sqrt(sht)-p(ir,5))**2-pm2i
70277 pt2=min(pt2cmx,0.25d0*shtcor,ptsca(ievol)**2)
70278
70279C...Case of evolution by QCD branching.
70280 IF(iscol(ievol).NE.0) THEN
70281
70282C...Parton-by-parton maximum scale from initial conditions.
70283 IF(mstp(72).EQ.0) THEN
70284 DO 320 iprt=1,nparts
70285 IF(ir.EQ.ipart(iprt)) pt2=min(pt2,ptpart(iprt)**2)
70286 320 CONTINUE
70287 ENDIF
70288
70289C...If kinematically impossible then do not evolve.
70290 IF(pt2.LT.pt2cmn) THEN
70291 iflg(ievol)=-1
70292 GOTO 380
70293 ENDIF
70294
70295C...Check if part of system for which ME corrections should be applied.
70296 imesys=0
70297 DO 330 ime=1,nmesys
70298 IF((i.EQ.mesys(ime,1).OR.i.EQ.mesys(ime,2)).AND.
70299 & mesys(ime,0).LT.100) imesys=ime
70300 330 CONTINUE
70301
70302C...Special flag for colour octet states.
70303C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70304 moct=0
70305 IF(k(i,2).EQ.21) moct=1
70306C...SUSY gluino
70307 IF(k(i,2).EQ.ksusy1+21) moct=2
70308C...UED KK gluon
70309 IF(k(i,2).EQ.5100021) moct=2
70310C...QUARKONIA++
70311 IF(mstp(148).GE.1.AND.iabs(k(i,2)).EQ.9900101.AND.
70312 & iabs(k(i,2)).LE.9910555) moct=2
70313C...QUARKONIA--
70314
70315
70316C...Upper estimate for matrix element weighting and colour factor.
70317C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70318 wtpsgl=2d0
70319 colfac=4d0/3d0
70320 IF(moct.GE.1) colfac=3d0/2d0
70321 IF(iglui.EQ.1.AND.imesys.EQ.1.AND.moct.EQ.0) colfac=3d0
70322 wtpsqq=0.5d0*0.5d0*nflav
70323
70324C...Determine overestimated z range: switch at c and b masses.
70325 340 izrg=1
70326 pt2mne=pt2cmn
70327 b0=27d0/6d0
70328 alams=alam3s
70329 IF(pt2.GT.1.01d0*pmcs) THEN
70330 izrg=2
70331 pt2mne=pmcs
70332 b0=25d0/6d0
70333 alams=alam4s
70334 ENDIF
70335 IF(pt2.GT.1.01d0*pmbs) THEN
70336 izrg=3
70337 pt2mne=pmbs
70338 b0=23d0/6d0
70339 alams=alam5s
70340 ENDIF
70341 zmncut=0.5d0-sqrt(max(0d0,0.25d0-pt2mne/shtcor))
70342 IF(zmncut.LT.1d-8) zmncut=pt2mne/shtcor
70343
70344C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70345 evemgl=wtpsgl*colfac*log(1d0/zmncut-1d0)/b0
70346 evcoef=evemgl
70347 IF(moct.EQ.1) THEN
70348 evemqq=wtpsqq*(1d0-2d0*zmncut)/b0
70349 evcoef=evcoef+evemqq
70350 ENDIF
70351
70352C...Pick pT2 (in overestimated z range).
70353 350 pt2=alams*(pt2/alams)**(pyr(0)**(1d0/evcoef))
70354
70355C...Loopback if crossed c/b mass thresholds.
70356 IF(izrg.EQ.3.AND.pt2.LT.pmbs) THEN
70357 pt2=pmbs
70358 GOTO 340
70359 ENDIF
70360 IF(izrg.EQ.2.AND.pt2.LT.pmcs) THEN
70361 pt2=pmcs
70362 GOTO 340
70363 ENDIF
70364
70365C...Finish if below lower cutoff.
70366 IF(pt2.LT.pt2cmn) THEN
70367 iflg(ievol)=-1
70368 GOTO 380
70369 ENDIF
70370
70371C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70372C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70373 iflag=1
70374 IF(moct.EQ.1.AND.evemgl.LT.pyr(0)*evcoef) iflag=2
70375
70376C...Pick z: dz/(1-z) or dz.
70377 IF(iflag.EQ.1) THEN
70378 z=1d0-zmncut*(1d0/zmncut-1d0)**pyr(0)
70379 ELSE
70380 z=zmncut+pyr(0)*(1d0-2d0*zmncut)
70381 ENDIF
70382
70383C...Loopback if outside allowed range for given pT2.
70384 zmnnow=0.5d0-sqrt(max(0d0,0.25d0-pt2/shtcor))
70385 IF(zmnnow.LT.1d-8) zmnnow=pt2/shtcor
70386 IF(z.LE.zmnnow.OR.z.GE.1d0-zmnnow) GOTO 350
70387 pm2=pm2i+pt2/(z*(1d0-z))
70388 IF(z*(1d0-z).LE.pm2*sht/(sht+pm2-pm2r)**2) GOTO 350
70389
70390C...No weighting for primary partons; to be done later on.
70391 IF(imesys.GT.0) THEN
70392
70393C...Weighting of q->qg/X->Xg branching.
70394 ELSEIF(iflag.EQ.1.AND.moct.NE.1) THEN
70395 IF(1d0+z**2.LT.wtpsgl*pyr(0)) GOTO 350
70396
70397C...Weighting of g->gg branching.
70398 ELSEIF(iflag.EQ.1) THEN
70399 IF(1d0+z**3.LT.wtpsgl*pyr(0)) GOTO 350
70400
70401C...Flavour choice and weighting of g->qqbar branching.
70402 ELSE
70403 kfq=min(5,1+int(nflav*pyr(0)))
70404 pmq=pmas(kfq,1)
70405 rootqq=sqrt(max(0d0,1d0-4d0*pmq**2/pm2))
70406 wtme=rootqq*(z**2+(1d0-z)**2)
70407 IF(wtme.LT.pyr(0)) GOTO 350
70408 iflag=10+kfq
70409 ENDIF
70410
70411C...Case of evolution by QED branching.
70412 ELSEIF(ischg(ievol).NE.0) THEN
70413
70414C...If kinematically impossible then do not evolve.
70415 pt2emn=pt0eq**2
70416 IF(iabs(k(i,2)).GT.10) pt2emn=pt0el**2
70417 IF(pt2.LT.pt2emn) THEN
70418 iflg(ievol)=-1
70419 GOTO 380
70420 ENDIF
70421
70422C...Check if part of system for which ME corrections should be applied.
70423 imesys=0
70424 DO 360 ime=1,nmesys
70425 IF((i.EQ.mesys(ime,1).OR.i.EQ.mesys(ime,2)).AND.
70426 & mesys(ime,0).GT.100) imesys=ime
70427 360 CONTINUE
70428
70429C...Charge. Matrix element weighting factor.
70430 chg=ischg(ievol)/3d0
70431 wtpsga=2d0
70432
70433C...Determine overestimated z range. Find evolution coefficient.
70434 zmncut=0.5d0-sqrt(max(0d0,0.25d0-pt2emn/shtcor))
70435 IF(zmncut.LT.1d-8) zmncut=pt2emn/shtcor
70436 evcoef=aem2pi*chg**2*wtpsga*log(1d0/zmncut-1d0)
70437
70438C...Pick pT2 (in overestimated z range).
70439 370 pt2=pt2*pyr(0)**(1d0/evcoef)
70440
70441C...Finish if below lower cutoff.
70442 IF(pt2.LT.pt2emn) THEN
70443 iflg(ievol)=-1
70444 GOTO 380
70445 ENDIF
70446
70447C...Pick z: dz/(1-z).
70448 z=1d0-zmncut*(1d0/zmncut-1d0)**pyr(0)
70449
70450C...Loopback if outside allowed range for given pT2.
70451 zmnnow=0.5d0-sqrt(max(0d0,0.25d0-pt2/shtcor))
70452 IF(zmnnow.LT.1d-8) zmnnow=pt2/shtcor
70453 IF(z.LE.zmnnow.OR.z.GE.1d0-zmnnow) GOTO 370
70454 pm2=pm2i+pt2/(z*(1d0-z))
70455 IF(z*(1d0-z).LE.pm2*sht/(sht+pm2-pm2r)**2) GOTO 370
70456
70457C...Weighting by branching kernel, except if ME weighting later.
70458 IF(imesys.EQ.0) THEN
70459 IF(1d0+z**2.LT.wtpsga*pyr(0)) GOTO 370
70460 ENDIF
70461 iflag=3
70462 ENDIF
70463
70464C...Save acceptable branching.
70465 iflg(ievol)=iflag
70466 imesav(ievol)=imesys
70467 pt2sav(ievol)=pt2
70468 zsav(ievol)=z
70469 shtsav(ievol)=sht
70470 ENDIF
70471
70472C...Check if branching has highest pT.
70473 IF(iflg(ievol).GE.1.AND.pt2sav(ievol).GT.pt2mx) THEN
70474 imx=ievol
70475 pt2mx=pt2sav(ievol)
70476 ENDIF
70477 380 CONTINUE
70478
70479C...Finished if no more branchings to be done.
70480 IF(imx.EQ.0) GOTO 500
70481
70482C...Restore info on hardest branching to be processed.
70483 i=ipos(imx)
70484 ir=irec(imx)
70485 kcol=iscol(imx)
70486 kcha=ischg(imx)
70487 imesys=imesav(imx)
70488 pt2=pt2sav(imx)
70489 z=zsav(imx)
70490 sht=shtsav(imx)
70491 pm2i=p(i,5)**2
70492 pm2r=p(ir,5)**2
70493 pm2=pm2i+pt2/(z*(1d0-z))
70494
70495C...Special flag for colour octet states.
70496 moct=0
70497 IF(k(i,2).EQ.21) moct=1
70498 IF(k(i,2).EQ.ksusy1+21) moct=2
70499 IF(k(i,2).EQ.5100021) moct=2
70500C...QUARKONIA++
70501 IF(mstp(148).GE.1.AND.iabs(k(i,2)).GE.9900101.AND.
70502 & iabs(k(i,2)).LE.9910555) moct=2
70503C...QUARKONIA--
70504
70505C...Restore further info for g->qqbar branching.
70506 kfq=0
70507 IF(iflg(imx).GT.10) THEN
70508 kfq=iflg(imx)-10
70509 pmq=pmas(kfq,1)
70510 rootqq=sqrt(max(0d0,1d0-4d0*pmq**2/pm2))
70511 ENDIF
70512
70513C...For branching g include azimuthal asymmetries from polarization.
70514 asypol=0d0
70515 IF(moct.EQ.1.AND.mod(mstj(46),2).EQ.1) THEN
70516C...Trace grandmother via intermediate recoil copies.
70517 kfgm=0
70518 im=i
70519 390 IF(k(im,3).NE.k(im-1,3).AND.k(im,3).NE.k(im+1,3).AND.
70520 & k(im,3).GT.0) THEN
70521 im=k(im,3)
70522 IF(im.GT.mint(84)) GOTO 390
70523 ENDIF
70524 igm=k(im,3)
70525 IF(igm.GT.mint(84).AND.igm.LT.im.AND.im.LE.i)
70526 & kfgm=iabs(k(igm,2))
70527C...Define approximate energy sharing by identifying aunt.
70528 iau=im+1
70529 IF(iau.GT.n-3.OR.k(iau,3).NE.igm) iau=im-1
70530 IF(kfgm.NE.0.AND.(kfgm.LE.6.OR.kfgm.EQ.21)) THEN
70531 zold=p(im,4)/(p(im,4)+p(iau,4))
70532C...Coefficient from gluon production.
70533 IF(kfgm.LE.6) THEN
70534 asypol=2d0*(1d0-zold)/(1d0+(1d0-zold)**2)
70535 ELSE
70536 asypol=((1d0-zold)/(1d0-zold*(1d0-zold)))**2
70537 ENDIF
70538C...Coefficient from gluon decay.
70539 IF(kfq.EQ.0) THEN
70540 asypol=asypol*(z*(1d0-z)/(1d0-z*(1d0-z)))**2
70541 ELSE
70542 asypol=-asypol*2d0*z*(1d0-z)/(1d0-2d0*z*(1d0-z))
70543 ENDIF
70544 ENDIF
70545 ENDIF
70546
70547C...Create new slots for branching products and recoil.
70548 inew=n+1
70549 ignew=n+2
70550 irnew=n+3
70551 n=n+3
70552
70553C...Set status, flavour and mother of new ones.
70554 k(inew,1)=k(i,1)
70555 k(ignew,1)=3
70556 IF(kcha.NE.0) k(ignew,1)=1
70557 k(irnew,1)=k(ir,1)
70558 IF(kfq.EQ.0) THEN
70559 k(inew,2)=k(i,2)
70560 k(ignew,2)=21
70561 IF(kcha.NE.0) k(ignew,2)=22
70562 ELSE
70563 k(inew,2)=-isign(kfq,kcol)
70564 k(ignew,2)=-k(inew,2)
70565 ENDIF
70566 k(irnew,2)=k(ir,2)
70567 k(inew,3)=i
70568 k(ignew,3)=i
70569 k(irnew,3)=ir
70570
70571C...Find rest frame and angles of branching+recoil.
70572 DO 400 j=1,5
70573 p(inew,j)=p(i,j)
70574 p(ignew,j)=0d0
70575 p(irnew,j)=p(ir,j)
70576 400 CONTINUE
70577 betax=(p(inew,1)+p(irnew,1))/(p(inew,4)+p(irnew,4))
70578 betay=(p(inew,2)+p(irnew,2))/(p(inew,4)+p(irnew,4))
70579 betaz=(p(inew,3)+p(irnew,3))/(p(inew,4)+p(irnew,4))
70580 CALL pyrobo(inew,irnew,0d0,0d0,-betax,-betay,-betaz)
70581 phi=pyangl(p(inew,1),p(inew,2))
70582 theta=pyangl(p(inew,3),sqrt(p(inew,1)**2+p(inew,2)**2))
70583
70584C...Derive kinematics of branching: generics (like g->gg).
70585 DO 410 j=1,4
70586 p(inew,j)=0d0
70587 p(irnew,j)=0d0
70588 410 CONTINUE
70589 pem=0.5d0*(sht+pm2-pm2r)/sqrt(sht)
70590 pzm=0.5d0*sqrt(max(0d0,(sht-pm2-pm2r)**2-4d0*pm2*pm2r)/sht)
70591 pt2cor=pm2*(pem**2*z*(1d0-z)-0.25d0*pm2)/pzm**2
70592 ptcor=sqrt(max(0d0,pt2cor))
70593 pzn=(pem**2*z-0.5d0*pm2)/pzm
70594 pzg=(pem**2*(1d0-z)-0.5d0*pm2)/pzm
70595C...Specific kinematics reduction for q->qg with m_q > 0.
70596 IF(moct.NE.1) THEN
70597 ptcor=(1d0-pm2i/pm2)*ptcor
70598 pzn=pzn+pm2i*pzg/pm2
70599 pzg=(1d0-pm2i/pm2)*pzg
70600C...Specific kinematics reduction for g->qqbar with m_q > 0.
70601 ELSEIF(kfq.NE.0) THEN
70602 p(inew,5)=pmq
70603 p(ignew,5)=pmq
70604 ptcor=rootqq*ptcor
70605 pzn=0.5d0*((1d0+rootqq)*pzn+(1d0-rootqq)*pzg)
70606 pzg=pzm-pzn
70607 ENDIF
70608
70609C...Pick phi and construct kinematics of branching.
70610 420 phirot=paru(2)*pyr(0)
70611 p(inew,1)=ptcor*cos(phirot)
70612 p(inew,2)=ptcor*sin(phirot)
70613 p(inew,3)=pzn
70614 p(inew,4)=sqrt(ptcor**2+p(inew,3)**2+p(inew,5)**2)
70615 p(ignew,1)=-p(inew,1)
70616 p(ignew,2)=-p(inew,2)
70617 p(ignew,3)=pzg
70618 p(ignew,4)=sqrt(ptcor**2+p(ignew,3)**2+p(ignew,5)**2)
70619 p(irnew,1)=0d0
70620 p(irnew,2)=0d0
70621 p(irnew,3)=-pzm
70622 p(irnew,4)=0.5d0*(sht+pm2r-pm2)/sqrt(sht)
70623
70624C...Boost branching system to lab frame.
70625 CALL pyrobo(inew,irnew,theta,phi,betax,betay,betaz)
70626
70627C...Renew choice of phi angle according to polarization asymmetry.
70628 IF(abs(asypol).GT.1d-3) THEN
70629 DO 430 j=1,3
70630 dpt(1,j)=p(i,j)
70631 dpt(2,j)=p(iau,j)
70632 dpt(3,j)=p(inew,j)
70633 430 CONTINUE
70634 dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)
70635 dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)
70636 dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2
70637 DO 440 j=1,3
70638 dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/max(1d-10,dpmm)
70639 dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/max(1d-10,dpmm)
70640 440 CONTINUE
70641 dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)
70642 dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)
70643 IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN
70644 cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+
70645 & dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))
70646 IF(1d0+asypol*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(asypol)))
70647 & GOTO 420
70648 ENDIF
70649 ENDIF
70650
70651C...Matrix element corrections for primary partons when requested.
70652 IF(imesys.GT.0) THEN
70653 m3jc=mesys(imesys,0)
70654
70655C...Identify recoiling partner and set up three-body kinematics.
70656 irp=mesys(imesys,1)
70657 IF(irp.EQ.i) irp=mesys(imesys,2)
70658 IF(irp.EQ.ir) irp=irnew
70659 DO 450 j=1,4
70660 psum(j)=p(inew,j)+p(irp,j)+p(ignew,j)
70661 450 CONTINUE
70662 psum(5)=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-
70663 & psum(3)**2))
70664 x1=2d0*(psum(4)*p(inew,4)-psum(1)*p(inew,1)-psum(2)*p(inew,2)-
70665 & psum(3)*p(inew,3))/psum(5)**2
70666 x2=2d0*(psum(4)*p(irp,4)-psum(1)*p(irp,1)-psum(2)*p(irp,2)-
70667 & psum(3)*p(irp,3))/psum(5)**2
70668 x3=2d0-x1-x2
70669 r1me=p(inew,5)/psum(5)
70670 r2me=p(irp,5)/psum(5)
70671
70672C...Matrix elements for gluon emission.
70673 IF(m3jc.LT.100) THEN
70674
70675C...Call ME, with right order important for two inequivalent showerers.
70676 IF(mesys(imesys,iord).EQ.i) THEN
70677 wme=pymael(m3jc,x1,x2,r1me,r2me,alpha)
70678 ELSE
70679 wme=pymael(m3jc,x2,x1,r2me,r1me,alpha)
70680 ENDIF
70681
70682C...Split up total ME when two radiating partons.
70683 isprad=1
70684 IF((m3jc.GE.16.AND.m3jc.LE.19).OR.(m3jc.GE.26.AND.m3jc.LE.29)
70685 & .OR.(m3jc.GE.36.AND.m3jc.LE.39).OR.(m3jc.GE.46.AND.m3jc.LE.49)
70686 & .OR.(m3jc.GE.56.AND.m3jc.LE.64)) isprad=0
70687 IF(isprad.EQ.1) wme=wme*max(1d-10,1d0+r1me**2-r2me**2-x1)/
70688 & max(1d-10,2d0-x1-x2)
70689
70690C...Evaluate shower rate.
70691 wps=2d0/(max(1d-10,2d0-x1-x2)*
70692 & max(1d-10,1d0+r2me**2-r1me**2-x2))
70693 IF(iglui.EQ.1) wps=(9d0/4d0)*wps
70694
70695C...Matrix elements for photon emission: still rather primitive.
70696 ELSE
70697
70698C...For generic charge combination currently only massless expression.
70699 IF(m3jc.EQ.101) THEN
70700 chg1=kchg(pycomp(k(i,2)),1)*isign(1,k(i,2))/3d0
70701 chg2=kchg(pycomp(k(irp,2)),1)*isign(1,k(irp,2))/3d0
70702 wme=(chg1*(1d0-x1)/x3-chg2*(1d0-x2)/x3)**2*(x1**2+x2**2)
70703 wps=2d0*(chg1**2*(1d0-x1)/x3+chg2**2*(1d0-x2)/x3)
70704
70705C...For flavour neutral system assume vector source and include masses.
70706 ELSE
70707 wme=pymael(11,x1,x2,r1me,r2me,0d0)*max(1d-10,
70708 & 1d0+r1me**2-r2me**2-x1)/max(1d-10,2d0-x1-x2)
70709 wps=2d0/(max(1d-10,2d0-x1-x2)*
70710 & max(1d-10,1d0+r2me**2-r1me**2-x2))
70711 ENDIF
70712 ENDIF
70713
70714C...Perform weighting with W_ME/W_PS.
70715 IF(wme.LT.pyr(0)*wps) THEN
70716 n=n-3
70717 iflg(imx)=0
70718 pt2cmx=pt2
70719 GOTO 310
70720 ENDIF
70721 ENDIF
70722
70723C...Now for sure accepted branching. Save highest pT.
70724 IF(ngen.EQ.1) ptgen=sqrt(pt2)
70725
70726C...Update status for obsolete ones. Bookkkep the moved original parton
70727C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70728C...Do not bookkeep radiated photon, since it cannot radiate further.
70729 k(i,1)=k(i,1)+10
70730 k(ir,1)=k(ir,1)+10
70731 DO 460 ip=1,npart
70732 IF(ipart(ip).EQ.i) ipart(ip)=inew
70733 IF(ipart(ip).EQ.ir) ipart(ip)=irnew
70734 460 CONTINUE
70735 IF(kcha.EQ.0) THEN
70736 npart=npart+1
70737 ipart(npart)=ignew
70738 ENDIF
70739
70740C...Initialize colour flow of branching.
70741C...Use both old and new style colour tags for flexibility.
70742 k(inew,4)=0
70743 k(ignew,4)=0
70744 k(inew,5)=0
70745 k(ignew,5)=0
70746 jcolp=4+(1-kcol)/2
70747 jcoln=9-jcolp
70748 mct(inew,1)=0
70749 mct(inew,2)=0
70750 mct(ignew,1)=0
70751 mct(ignew,2)=0
70752 mct(irnew,1)=0
70753 mct(irnew,2)=0
70754
70755C...Trivial colour flow for l->lgamma and q->qgamma.
70756 IF(iabs(kcha).EQ.3) THEN
70757 k(i,4)=inew
70758 k(i,5)=ignew
70759 ELSEIF(kcha.NE.0) THEN
70760 IF(k(i,4).NE.0) THEN
70761 k(i,4)=k(i,4)+inew
70762 k(inew,4)=mstu(5)*i
70763 mct(inew,1)=mct(i,1)
70764 ENDIF
70765 IF(k(i,5).NE.0) THEN
70766 k(i,5)=k(i,5)+inew
70767 k(inew,5)=mstu(5)*i
70768 mct(inew,2)=mct(i,2)
70769 ENDIF
70770
70771C...Set colour flow for q->qg and g->gg.
70772 ELSEIF(kfq.EQ.0) THEN
70773 k(i,jcolp)=k(i,jcolp)+ignew
70774 k(ignew,jcolp)=mstu(5)*i
70775 k(inew,jcolp)=mstu(5)*ignew
70776 k(ignew,jcoln)=mstu(5)*inew
70777 mct(ignew,jcolp-3)=mct(i,jcolp-3)
70778 nct=nct+1
70779 mct(inew,jcolp-3)=nct
70780 mct(ignew,jcoln-3)=nct
70781 IF(moct.GE.1) THEN
70782 k(i,jcoln)=k(i,jcoln)+inew
70783 k(inew,jcoln)=mstu(5)*i
70784 mct(inew,jcoln-3)=mct(i,jcoln-3)
70785 ENDIF
70786
70787C...Set colour flow for g->qqbar.
70788 ELSE
70789 k(i,jcoln)=k(i,jcoln)+inew
70790 k(inew,jcoln)=mstu(5)*i
70791 k(i,jcolp)=k(i,jcolp)+ignew
70792 k(ignew,jcolp)=mstu(5)*i
70793 mct(inew,jcoln-3)=mct(i,jcoln-3)
70794 mct(ignew,jcolp-3)=mct(i,jcolp-3)
70795 ENDIF
70796
70797C...Daughter info for colourless recoiling parton.
70798 IF(k(ir,4).EQ.0.AND.k(ir,5).EQ.0) THEN
70799 k(ir,4)=irnew
70800 k(ir,5)=irnew
70801 k(irnew,4)=0
70802 k(irnew,5)=0
70803
70804C...Colour of recoiling parton sails through unchanged.
70805 ELSE
70806 IF(k(ir,4).NE.0) THEN
70807 k(ir,4)=k(ir,4)+irnew
70808 k(irnew,4)=mstu(5)*ir
70809 mct(irnew,1)=mct(ir,1)
70810 ENDIF
70811 IF(k(ir,5).NE.0) THEN
70812 k(ir,5)=k(ir,5)+irnew
70813 k(irnew,5)=mstu(5)*ir
70814 mct(irnew,2)=mct(ir,2)
70815 ENDIF
70816 ENDIF
70817
70818C...Vertex information trivial.
70819 DO 470 j=1,5
70820 v(inew,j)=v(i,j)
70821 v(ignew,j)=v(i,j)
70822 v(irnew,j)=v(ir,j)
70823 470 CONTINUE
70824
70825C...Update list of old radiators.
70826 DO 480 ievol=1,nevol
70827 IF(ipos(ievol).EQ.i.AND.irec(ievol).EQ.ir) THEN
70828 ipos(ievol)=inew
70829 IF(kcol.NE.0.AND.iscol(ievol).EQ.kcol) ipos(ievol)=ignew
70830 irec(ievol)=irnew
70831 iflg(ievol)=0
70832 ELSEIF(ipos(ievol).EQ.i) THEN
70833 ipos(ievol)=inew
70834 iflg(ievol)=0
70835 ELSEIF(ipos(ievol).EQ.ir.AND.irec(ievol).EQ.i) THEN
70836 ipos(ievol)=irnew
70837 irec(ievol)=inew
70838 IF(kcol.NE.0.AND.iscol(ievol).NE.kcol) irec(ievol)=ignew
70839 iflg(ievol)=0
70840 ELSEIF(ipos(ievol).EQ.ir) THEN
70841 ipos(ievol)=irnew
70842 iflg(ievol)=0
70843 ENDIF
70844C...Update links of old connected partons.
70845 IF(irec(ievol).EQ.i) THEN
70846 irec(ievol)=inew
70847 iflg(ievol)=0
70848 ELSEIF(irec(ievol).EQ.ir) THEN
70849 irec(ievol)=irnew
70850 iflg(ievol)=0
70851 ENDIF
70852 480 CONTINUE
70853
70854C...q->qg or g->gg: create new gluon radiators.
70855 IF(kcol.NE.0.AND.kfq.EQ.0) THEN
70856 nevol=nevol+1
70857 ipos(nevol)=inew
70858 irec(nevol)=ignew
70859 iflg(nevol)=0
70860 iscol(nevol)=kcol
70861 ischg(nevol)=0
70862 ptsca(nevol)=sqrt(pt2)
70863 nevol=nevol+1
70864 ipos(nevol)=ignew
70865 irec(nevol)=inew
70866 iflg(nevol)=0
70867 iscol(nevol)=-kcol
70868 ischg(nevol)=0
70869 ptsca(nevol)=ptsca(nevol-1)
70870 ENDIF
70871
70872C...Update matrix elements parton list and add new for g/gamma->qqbar.
70873 DO 490 ime=1,nmesys
70874 IF(mesys(ime,1).EQ.i) mesys(ime,1)=inew
70875 IF(mesys(ime,2).EQ.i) mesys(ime,2)=inew
70876 IF(mesys(ime,1).EQ.ir) mesys(ime,1)=irnew
70877 IF(mesys(ime,2).EQ.ir) mesys(ime,2)=irnew
70878 490 CONTINUE
70879 IF(kfq.NE.0) THEN
70880 nmesys=nmesys+1
70881 mesys(nmesys,0)=66
70882 mesys(nmesys,1)=inew
70883 mesys(nmesys,2)=ignew
70884 nmesys=nmesys+1
70885 mesys(nmesys,0)=102
70886 mesys(nmesys,1)=inew
70887 mesys(nmesys,2)=ignew
70888 ENDIF
70889
70890C...Global statistics.
70891 mint(353)=mint(353)+1
70892 vint(353)=vint(353)+ptcor
70893 IF (mint(353).EQ.1) vint(358)=ptcor
70894
70895C...Loopback for more emissions if enough space.
70896 pt2cmx=pt2
70897 IF(npart.LT.maxnur-1.AND.nevol.LT.2*maxnur-2.AND.
70898 &nmesys.LT.maxnur-2.AND.n.LT.mstu(4)-mstu(32)-5) THEN
70899 GOTO 300
70900 ELSE
70901 CALL pyerrm(11,'(PYPTFS:) no more memory left for shower')
70902 ENDIF
70903
70904C...Done.
70905 500 CONTINUE
70906
70907 RETURN
70908 END
70909
70910C*********************************************************************
70911
70912C...PYMAEL
70913C...Auxiliary to PYSHOW and PYPTFS.
70914C...Matrix elements for gluon (or photon) emission from
70915C...a two-body state; to be used by the parton shower routine.
70916C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
70917C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
70918C... = (alpha-strong/2 pi) * CF * PYMAEL,
70919C...i.e. normalization is such that one recovers the familiar
70920C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
70921C...Coupling structure:
70922C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
70923C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
70924C... = 16-19 : q -> q V
70925C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
70926C... = 26-29 : q -> q S
70927C... = 31-34 : V -> ~q ~qbar (~q = squark)
70928C... = 36-39 : ~q -> ~q V
70929C... = 41-44 : S -> ~q ~qbar
70930C... = 46-49 : ~q -> ~q S
70931C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
70932C... = 56-59 : ~q -> q chi
70933C... = 61-64 : q -> ~q chi
70934C... = 66-69 : ~g -> q ~qbar
70935C... = 71-74 : ~q -> q ~g
70936C... = 76-79 : q -> ~q ~g
70937C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
70938C...Note that the order of the decay products is important.
70939C...In each set of four, the variants are ordered as:
70940C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
70941C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
70942C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
70943C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
70944
70945 FUNCTION pymael(NI,X1,X2,R1,R2,ALPHA)
70946
70947C...Double precision and integer declarations.
70948 IMPLICIT DOUBLE PRECISION(a-h, o-z)
70949 IMPLICIT INTEGER(I-N)
70950
70951C...Check input values. Return zero outside allowed phase space.
70952 pymael=0d0
70953 IF(x1.LE.2d0*r1.OR.x1.GE.1d0+r1**2-r2**2) RETURN
70954 IF(x2.LE.2d0*r2.OR.x2.GE.1d0+r2**2-r1**2) RETURN
70955 IF(x1+x2.LE.1d0+(r1+r2)**2) RETURN
70956 IF((2d0-2d0*x1-2d0*x2+x1*x2+2d0*r1**2+2d0*r2**2)**2.GE.
70957 &(x1**2-4d0*r1**2)*(x2**2-4d0*r2**2)) RETURN
70958 alpcor=max(0d0,min(1d0,alpha))
70959
70960C...Initial values and flags.
70961 iclass=ni/5
70962 icombi=ni-5*iclass
70963 isset1=0
70964 isset2=0
70965 isset4=0
70966
70967C... Phase space.
70968 ps=sqrt((1d0-(r1+r2)**2)*(1d0-(r1-r2)**2))
70969
70970C...Eikonal expression; also acts as default.
70971 IF(iclass.LE.1.OR.iclass.GE.17.OR.icombi.EQ.0) THEN
70972 rlo=ps
70973 IF(icombi.EQ.0.OR.icombi.EQ.1) THEN
70974 anum=0d0
70975 ELSEIF(icombi.EQ.2) THEN
70976 anum=(2d0-x1-x2)**2
70977 ELSEIF(icombi.EQ.3) THEN
70978 anum=alpcor*(2d0-x1-x2)**2
70979 ELSE
70980 anum=0.5d0*(2d0-x1-x2)**2
70981 ENDIF
70982 rfo=ps*2d0*((x1+x2-1d0+anum-r1**2-r2**2)/
70983 & ((1d0+r1**2-r2**2-x1)*(1d0+r2**2-r1**2-x2))-
70984 & r1**2/(1d0+r2**2-r1**2-x2)**2-
70985 & r2**2/(1d0+r1**2-r2**2-x1)**2)
70986 icombi=0
70987
70988C...V -> q qbar (V = gamma*/Z0/W+-/...).
70989 ELSEIF(iclass.EQ.2) THEN
70990 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
70991 rlo1=ps*(2-r1**2-r1**4+6*r1*r2-r2**2+2*r1**2*r2**2-r2**4)/2.d0
70992 rfo1=-1.d0*(3+6*r1**2+r1**4-6*r1*r2+6*r1**3*r2-2*r2**2
70993 & -6*r1**2*r2**2+6*r1*r2**3+r2**4-3*x1+6*r1*r2*x1
70994 & +2*r2**2*x1+x1**2-2*r1**2*x1**2+3*r1**2*(2-x1-x2)
70995 & +6*r1*r2*(2-x1-x2)-r2**2*(2-x1-x2)-2*x1*(2-x1-x2)
70996 & -5*r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)
70997 & -3*(2-x1-x2)**2-3*r1**2*(2-x1-x2)**2+r2**2*(2-x1-x2)**2
70998 & +2*x1*(2-x1-x2)**2+(2-x1-x2)**3-x2)/
70999 & (-1+r1**2-r2**2+x2)**2
71000 rfo1=rfo1-2*(-3+r1**2-6*r1*r2+6*r1**3*r2+3*r2**2-4*r1**2*r2**2
71001 & +6*r1*r2**3+2*x1+3*r1**2*x1+r2**2*x1-x1**2-r1**2*x1**2
71002 & -r2**2*x1**2+4*(2-x1-x2)+2*r1**2*(2-x1-x2)+3*r1*r2*(2-x1
71003 & -x2)-r2**2*(2-x1-x2)-3*x1*(2-x1-x2)-2*r1**2*x1*(2-x1-x2)
71004 & +x1**2*(2-x1-x2)-(2-x1-x2)**2-r1**2*(2-x1-x2)**2+r1*r2*(2
71005 & -x1-x2)**2+x1*(2-x1-x2)**2)/
71006 & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71007 rfo1=rfo1-1.d0*(-1+2*r1**2+r1**4+6*r1*r2+6*r1**3*r2-2*r2**2
71008 & -6*r1**2*r2**2+6*r1*r2**3+r2**4-x1-2*r1**2*x1-6*r1*r2*x1
71009 & +8*r2**2*x1+x1**2-2*r2**2*x1**2-r1**2*(2-x1-x2)+r2**2*(2
71010 & -x1-x2)-r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*
71011 & (2-x1-x2)+x2)/(-1-r1**2+r2**2+x1)**2
71012 rfo1=rfo1/2.d0
71013 isset1=1
71014 ENDIF
71015 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71016 rlo2=ps*(2-r1**2-r1**4-6*r1*r2-r2**2+2*r1**2*r2**2-r2**4)/2.d0
71017 rfo2=-1*(3+6*r1**2+r1**4+6*r1*r2-6*r1**3*r2-2*r2**2
71018 & -6*r1**2*r2**2-6*r1*r2**3+r2**4-3*x1-6*r1*r2*x1+2*r2**2*x1
71019 & +x1**2-2*r1**2*x1**2+3*r1**2*(2-x1-x2)-6*r1*r2*(2-x1-x2)
71020 & -r2**2*(2-x1-x2)-2*x1*(2-x1-x2)-5*r1**2*x1*(2-x1-x2)
71021 & +r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)-3*(2-x1-x2)**2
71022 & -3*r1**2*(2-x1-x2)**2+r2**2*(2-x1-x2)**2+2*x1*(2-x1-x2)**2
71023 & +(2-x1-x2)**3-x2)/(-1+r1**2-r2**2+x2)**2
71024 rfo2=rfo2-2*(-3+r1**2+6*r1*r2-6*r1**3*r2+3*r2**2-4*r1**2*r2**2
71025 & -6*r1*r2**3+2*x1+3*r1**2*x1+r2**2*x1-x1**2-r1**2*x1**2
71026 & -r2**2*x1**2+4*(2-x1-x2)+2*r1**2*(2-x1-x2)-3*r1*r2*(2-x1
71027 & -x2)-r2**2*(2-x1-x2)-3*x1*(2-x1-x2)-2*r1**2*x1*(2-x1-x2)
71028 & +x1**2*(2-x1-x2)-(2-x1-x2)**2-r1**2*(2-x1-x2)**2-r1*r2*(2
71029 & -x1-x2)**2+x1*(2-x1-x2)**2)/
71030 & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71031 rfo2=rfo2-1*(-1+2*r1**2+r1**4-6*r1*r2-6*r1**3*r2-2*r2**2
71032 & -6*r1**2*r2**2-6*r1*r2**3+r2**4-x1-2*r1**2*x1+6*r1*r2*x1
71033 & +8*r2**2*x1+x1**2-2*r2**2*x1**2-r1**2*(2-x1-x2)+r2**2*(2-x1
71034 & -x2)-r1**2*x1*(2-x1-x2)+r2**2*x1*(2-x1-x2)+x1**2*(2-x1-x2)
71035 & +x2)/(-1-r1**2+r2**2+x1)**2
71036 rfo2=rfo2/2.d0
71037 isset2=1
71038 ENDIF
71039 IF(icombi.EQ.4) THEN
71040 rlo4=ps*(2d0-r1**2-r1**4-r2**2+2d0*r1**2*r2**2-r2**4)/2d0
71041 rfo4=(1-r1**4+6*r1**2*r2**2-r2**4+x1+3*r1**2*x1-9*r2**2*x1
71042 & -3*x1**2-r1**2*x1**2+3*r2**2*x1**2+x1**3-x2-r1**2*x2
71043 & +r2**2*x2-r1**2*x1*x2+r2**2*x1*x2+x1**2*x2)/
71044 & (-1-r1**2+r2**2+x1)**2
71045 rfo4=rfo4
71046 & -2*(1+r1**2+r2**2-4*r1**2*r2**2+r1**2*x1+2*r2**2*x1-x1**2
71047 & -r2**2*x1**2+2*r1**2*x2+r2**2*x2-3*x1*x2+x1**2*x2-x2**2
71048 & -r1**2*x2**2+x1*x2**2)/
71049 & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71050 rfo4=rfo4+(1-r1**4+6*r1**2*r2**2-r2**4-x1+r1**2*x1-r2**2*x1+x2
71051 & -9*r1**2*x2+3*r2**2*x2+r1**2*x1*x2-r2**2*x1*x2-3*x2**2
71052 & +3*r1**2*x2**2-r2**2*x2**2+x1*x2**2+x2**3)/
71053 & (-1+r1**2-r2**2+x2)**2
71054 rfo4=rfo4/2.d0
71055 isset4=1
71056 ENDIF
71057
71058C...q -> q V.
71059 ELSEIF(iclass.EQ.3) THEN
71060 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71061 rlo1=ps*(1d0-2d0*r1**2+r1**4+r2**2-6d0*r1*r2**2
71062 & +r1**2*r2**2-2d0*r2**4)
71063 rfo1=2*(-1+r1-2*r1**2+2*r1**3-r1**4+r1**5-r2**2+r1*r2**2
71064 & -5*r1**2*r2**2+r1**3*r2**2-2*r1*r2**4+2*x1-2*r1*x1
71065 & +2*r1**2*x1-2*r1**3*x1+2*r2**2*x1+5*r1*r2**2*x1
71066 & +r1**2*r2**2*x1+2*r2**4*x1-x1**2+r1*x1**2-r2**2*x1**2+3*x2
71067 & +4*r1**2*x2+r1**4*x2+2*r2**2*x2+2*r1**2*r2**2*x2-4*x1*x2
71068 & -2*r1**2*x1*x2-r2**2*x1*x2+x1**2*x2-2*x2**2
71069 & -2*r1**2*x2**2+x1*x2**2)/(1-r1**2+r2**2-x2)/(-2+x1+x2)
71070 rfo1=rfo1+(2*r2**2+6*r1*r2**2-6*r1**2*r2**2+6*r1**3*r2**2
71071 & +2*r2**4+6*r1*r2**4-r2**2*x1+r1**2*r2**2*x1-r2**4*x1+x2
71072 & -r1**4*x2-3*r2**2*x2-6*r1*r2**2*x2+9*r1**2*r2**2*x2
71073 & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
71074 & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
71075 rfo1=rfo1+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4
71076 & +9*x1+10*r1**2*x1+r1**4*x1-3*r2**2*x1+6*r1*r2**2*x1
71077 & +r1**2*r2**2*x1-2*r2**4*x1-6*x1**2-2*r1**2*x1**2+x1**3
71078 & +7*x2+8*r1**2*x2+r1**4*x2-7*r2**2*x2+6*r1*r2**2*x2
71079 & +r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
71080 & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2
71081 & +2*r2**2*x2**2+x1*x2**2)/(-2+x1+x2)**2
71082 isset1=1
71083 ENDIF
71084 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71085 rlo2=ps*(1d0-2d0*r1**2+r1**4+r2**2+6d0*r1*r2**2
71086 & +r1**2*r2**2-2d0*r2**4)
71087 rfo2=2*(1+r1+2*r1**2+2*r1**3+r1**4+r1**5+r2**2+r1*r2**2
71088 & +5*r1**2*r2**2+r1**3*r2**2-2*r1*r2**4-2*x1-2*r1*x1
71089 & -2*r1**2*x1-2*r1**3*x1-2*r2**2*x1+5*r1*r2**2*x1
71090 & -r1**2*r2**2*x1-2*r2**4*x1+x1**2+r1*x1**2+r2**2*x1**2-3*x2
71091 & -4*r1**2*x2-r1**4*x2-2*r2**2*x2-2*r1**2*r2**2*x2+4*x1*x2
71092 & +2*r1**2*x1*x2+r2**2*x1*x2-x1**2*x2+2*x2**2+2*r1**2*x2**2
71093 & -x1*x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71094 rfo2=rfo2+(2*r2**2-6*r1*r2**2-6*r1**2*r2**2-6*r1**3*r2**2
71095 & +2*r2**4-6*r1*r2**4-r2**2*x1+r1**2*r2**2*x1-r2**4*x1+x2
71096 & -r1**4*x2-3*r2**2*x2+6*r1*r2**2*x2+9*r1**2*r2**2*x2
71097 & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
71098 & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
71099 rfo2=rfo2+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4+9*x1
71100 & +10*r1**2*x1+r1**4*x1-3*r2**2*x1-6*r1*r2**2*x1
71101 & +r1**2*r2**2*x1-2*r2**4*x1-6*x1**2-2*r1**2*x1**2+x1**3
71102 & +7*x2+8*r1**2*x2+r1**4*x2-7*r2**2*x2-6*r1*r2**2*x2
71103 & +r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
71104 & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2+2*r2**2*x2**2
71105 & +x1*x2**2)/(-2+x1+x2)**2
71106 isset2=1
71107 ENDIF
71108 IF(icombi.EQ.4) THEN
71109 rlo4=ps*(1.d0-2.d0*r1**2+r1**4+r2**2+r1**2*r2**2-2.d0*r2**4)
71110 rfo4=2*(1+2*r1**2+r1**4+r2**2+5*r1**2*r2**2-2*x1-2*r1**2*x1
71111 & -2*r2**2*x1-r1**2*r2**2*x1-2*r2**4*x1+x1**2+r2**2*x1**2
71112 & -3*x2-4*r1**2*x2-r1**4*x2-2*r2**2*x2-2*r1**2*r2**2*x2
71113 & +4*x1*x2+2*r1**2*x1*x2+r2**2*x1*x2-x1**2*x2+2*x2**2
71114 & +2*r1**2*x2**2-x1*x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71115 rfo4=rfo4+(2*r2**2-6*r1**2*r2**2+2*r2**4-r2**2*x1+r1**2*r2**2*x1
71116 & -r2**4*x1+x2-r1**4*x2-3*r2**2*x2+9*r1**2*r2**2*x2
71117 & -2*r2**4*x2-x1*x2+r1**2*x1*x2-x2**2-3*r1**2*x2**2
71118 & +2*r2**2*x2**2+x1*x2**2)/(-1+r1**2-r2**2+x2)**2
71119 rfo4=rfo4+(-4-8*r1**2-4*r1**4+4*r2**2-4*r1**2*r2**2+8*r2**4+9*x1
71120 & +10*r1**2*x1+r1**4*x1-3*r2**2*x1+r1**2*r2**2*x1-2*r2**4*x1
71121 & -6*x1**2-2*r1**2*x1**2+x1**3+7*x2+8*r1**2*x2+r1**4*x2
71122 & -7*r2**2*x2+r1**2*r2**2*x2-2*r2**4*x2-9*x1*x2-3*r1**2*x1*x2
71123 & +2*r2**2*x1*x2+2*x1**2*x2-3*x2**2-r1**2*x2**2+2*r2**2*x2**2
71124 & +x1*x2**2)/(2-x1-x2)**2
71125 isset4=1
71126 ENDIF
71127
71128C...S -> q qbar (S = h0/H0/A0/H+-/...).
71129 ELSEIF(iclass.EQ.4) THEN
71130 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71131 rlo1=ps*(1d0-r1**2-r2**2-2d0*r1*r2)
71132 rfo1=-(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71133 & +r2**4+x1-r1**2*x1+2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
71134 & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
71135 & -2*(r1**2+r1**4-2*r1**3*r2+r2**2-6*r1**2*r2**2-2*r1*r2**3
71136 & +r2**4-r1**2*x1+r1*r2*x1+2*r2**2*x1+2*r1**2*x2+r1*r2*x2
71137 & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71138 & -(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71139 & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
71140 & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71141 isset1=1
71142 ENDIF
71143 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71144 rlo2=ps*(1d0-r1**2-r2**2+2d0*r1*r2)
71145 rfo2=-(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
71146 & +r2**4+x1-r1**2*x1-2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
71147 & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
71148 & -(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
71149 & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2
71150 & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71151 & +2*(-r1**2-r1**4-2*r1**3*r2-r2**2+6*r1**2*r2**2
71152 & -2*r1*r2**3-r2**4+r1**2*x1+r1*r2*x1-2*r2**2*x1
71153 & -2*r1**2*x2+r1*r2*x2+r2**2*x2+x1*x2)/
71154 & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71155 isset2=1
71156 ENDIF
71157 IF(icombi.EQ.4) THEN
71158 rlo4=ps*(1d0-r1**2-r2**2)
71159 rfo4=-(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+3*r2**2*x1+x2
71160 & +r1**2*x2-r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
71161 & -2*(r1**2+r1**4+r2**2-6*r1**2*r2**2+r2**4-r1**2*x1
71162 & +2*r2**2*x1+2*r1**2*x2-r2**2*x2-x1*x2)/
71163 & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71164 & -(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1
71165 & +x2+3*r1**2*x2-r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71166 isset4=1
71167 ENDIF
71168
71169C...q -> q S.
71170 ELSEIF(iclass.EQ.5) THEN
71171 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71172 rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
71173 rfo1=(4-4*r1**2+4*r2**2-3*x1-2*r1*x1+r1**2*x1-r2**2*x1-5*x2
71174 & -2*r1*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
71175 & +2*(3-r1-5*r1**2-r1**3+3*r2**2+r1*r2**2-2*x1-r1*x1
71176 & +r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71177 & (1-r1**2+r2**2-x2)/(-2+x1+x2)
71178 & +(2-2*r1-6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1
71179 & -r2**2*x1-3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71180 & (-1+r1**2-r2**2+x2)**2
71181 isset1=1
71182 ENDIF
71183 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71184 rlo2=ps*(1d0+r1**2-r2**2-2d0*r1)
71185 rfo2=(4-4*r1**2+4*r2**2-3*x1+2*r1*x1+r1**2*x1-r2**2*x1-5*x2
71186 & +2*r1*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
71187 & +2*(3+r1-5*r1**2+r1**3+3*r2**2-r1*r2**2-2*x1+r1*x1
71188 & +r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71189 & (1-r1**2+r2**2-x2)/(-2+x1+x2)
71190 & +(2+2*r1-6*r1**2+2*r1**3+2*r2**2+2*r1*r2**2-x1+r1**2*x1
71191 & -r2**2*x1-3*x2-2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71192 & (-1+r1**2-r2**2+x2)**2
71193 isset2=1
71194 ENDIF
71195 IF(icombi.EQ.4) THEN
71196 rlo4=ps*(1d0+r1**2-r2**2)
71197 rfo4=(4-4*r1**2+4*r2**2-3*x1+r1**2*x1-r2**2*x1-5*x2+r1**2*x2
71198 & -r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2
71199 & +2*(3-5*r1**2+3*r2**2-2*x1+r1**2*x1-4*x2+2*r1**2*x2
71200 & -r2**2*x2+x1*x2+x2**2)/(1-r1**2+r2**2-x2)/(-2+x1+x2)
71201 & +(2-6*r1**2+2*r2**2-x1+r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2
71202 & -r2**2*x2+x1*x2+x2**2)/(-1+r1**2-r2**2+x2)**2
71203 isset4=1
71204 ENDIF
71205
71206C...V -> ~q ~qbar (~q = squark).
71207 ELSEIF(iclass.EQ.6) THEN
71208 rlo1=ps*(1d0-2d0*r1**2+r1**4-2d0*r2**2-2d0*r1**2*r2**2+r2**4)
71209 rfo1=2d0*3d0+(1+r1**2+r2**2-x1)*(4*r1**2-x1**2)/
71210 & (-1-r1**2+r2**2+x1)**2
71211 & -2d0*(-1-3*r1**2-r2**2+x1+x1**2/2+x2-x1*x2/2)/
71212 & (-1-r1**2+r2**2+x1)
71213 & +(1+r1**2+r2**2-x2)*(4*r2**2-x2**2)
71214 & /(-1+r1**2-r2**2+x2)**2
71215 & -2d0*(-1-r1**2-3*r2**2+x1+x2-x1*x2/2+x2**2/2)/
71216 & (-1+r1**2-r2**2+x2)
71217 & -(-4*r1**2-4*r1**4-4*r2**2-8*r1**2*r2**2-4*r2**4+2*x1
71218 & +6*r1**2*x1+6*r2**2*x1-2*x1**2+2*x2+6*r1**2*x2+6*r2**2*x2
71219 & -4*x1*x2-2*r1**2*x1*x2-2*r2**2*x1*x2+x1**2*x2-2*x2**2
71220 & +x1*x2**2)/(-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71221 isset1=1
71222
71223C...~q -> ~q V.
71224 ELSEIF(iclass.EQ.7) THEN
71225 rlo1=ps*(1d0-2d0*r1**2+r1**4-2d0*r2**2-2d0*r1**2*r2**2+r2**4)
71226 rfo1=16*r2**2+8*(4*r2**2+2*r2**2*x1+x2+r1**2*x2+r2**2*x2-x1*x2
71227 & -2*x2**2)/(3*(-1+r1**2-r2**2+x2))+8*(1+r1**2+r2**2-x2)*
71228 & (4*r2**2-x2**2)/(3*(-1+r1**2-r2**2+x2)**2)+8*(x1+x2)*
71229 & (-1-2*r1**2-r1**4-2*r2**2+2*r1**2*r2**2-r2**4+2*x1
71230 & +2*r1**2*x1+2*r2**2*x1-x1**2+2*x2+2*r1**2*x2+2*r2**2*x2
71231 & -2*x1*x2-x2**2)/(3*(-2+x1+x2)**2)+8*(-1-r1**2+r2**2-x1)*
71232 & (2*r2**2*x1+x2+r1**2*x2+r2**2*x2-x1*x2-x2**2)/
71233 & (3*(-1+r1**2-r2**2+x2)*(-2+x1+x2))+8*(1+2*r1**2+r1**4
71234 & +2*r2**2-2*r1**2*r2**2+r2**4-2*x1-2*r1**2*x1-4*r2**2*x1
71235 & +x1**2-3*x2-3*r1**2*x2-3*r2**2*x2+3*x1*x2+2*x2**2)/
71236 & (3*(-2+x1+x2))
71237 rfo1=3d0*rfo1/8d0
71238 isset1=1
71239
71240C...S -> ~q ~qbar.
71241 ELSEIF(iclass.EQ.8) THEN
71242 rlo1=ps
71243 rfo1=(-1-2*r1**2-r1**4-2*r2**2+2*r1**2*r2**2-r2**4+2*x1
71244 & +2*r1**2*x1+2*r2**2*x1-x1**2-r2**2*x1**2+2*x2+2*r1**2*x2
71245 & +2*r2**2*x2-3*x1*x2-r1**2*x1*x2-r2**2*x1*x2+x1**2*x2-x2**2
71246 & -r1**2*x2**2+x1*x2**2)/
71247 & (1+r1**2-r2**2-x1)**2/(-1+r1**2-r2**2+x2)**2
71248 rfo1=2d0*rfo1
71249 isset1=1
71250
71251C...~q -> ~q S.
71252 ELSEIF(iclass.EQ.9) THEN
71253 rlo1=ps
71254 rfo1=(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
71255 & +(1+r1**2-r2**2+x1)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71256 & -(x1+x2)/(-2+x1+x2)**2
71257 isset1=1
71258
71259C...chi -> q ~qbar (chi = neutralino/chargino).
71260 ELSEIF(iclass.EQ.10) THEN
71261 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71262 rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
71263 rfo1=(2*r1+x1)*(-1-r1**2-r2**2+x1)/(-1-r1**2+r2**2+x1)**2
71264 & +2*(-1-r1**2-2*r1**3-r2**2-2*r1*r2**2+3*x1/2+r1*x1
71265 & -r1**2*x1/2-r2**2*x1/2+x2+r1*x2+r1**2*x2-x1*x2/2)/
71266 & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71267 & +(2-2*r1-6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1
71268 & -r2**2*x1-3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71269 & (-1+r1**2-r2**2+x2)**2
71270 isset1=1
71271 ENDIF
71272 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71273 rlo2=ps*(1d0-2d0*r1+r1**2-r2**2)
71274 rfo2=(2*r1-x1)*(1+r1**2+r2**2-x1)/(-1-r1**2+r2**2+x1)**2
71275 & +2*(-1-r1**2+2*r1**3-r2**2+2*r1*r2**2+3*x1/2-r1*x1
71276 & -r1**2*x1/2-r2**2*x1/2+x2-r1*x2+r1**2*x2-x1*x2/2)/
71277 & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71278 & +(2+2*r1-6*r1**2+2*r1**3+2*r2**2+2*r1*r2**2-x1+r1**2*x1
71279 & -r2**2*x1-3*x2-2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71280 & (-1+r1**2-r2**2+x2)**2
71281 isset2=1
71282 ENDIF
71283 IF(icombi.EQ.4) THEN
71284 rlo4=ps*(1+r1**2-r2**2)
71285 rfo4=x1*(-1-r1**2-r2**2+x1)/(-1-r1**2+r2**2+x1)**2
71286 & +2d0*(-1-r1**2-r2**2+3*x1/2-r1**2*x1/2-r2**2*x1/2
71287 & +x2+r1**2*x2-x1*x2/2)/
71288 & (-1-r1**2+r2**2+x1)/(-1+r1**2-r2**2+x2)
71289 & +(2-6*r1**2+2*r2**2-x1+r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2
71290 & -r2**2*x2+x1*x2+x2**2)/(-1+r1**2-r2**2+x2)**2
71291 isset4=1
71292 ENDIF
71293
71294C...~q -> q chi.
71295 ELSEIF(iclass.EQ.11) THEN
71296 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71297 rlo1=ps*(1d0-(r1+r2)**2)
71298 rfo1=(1+r1**2+2*r1*r2+r2**2-x1-x2)*(x1+x2)/(-2+x1+x2)**2
71299 & -(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71300 & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
71301 & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71302 & +(-1-2*r1**2-r1**4-2*r1*r2-2*r1**3*r2+2*r1*r2**3+r2**4
71303 & +x1+r1**2*x1-2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
71304 & +x1*x2+x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71305 isset1=1
71306 ENDIF
71307 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71308 rlo2=ps*(1d0-(r1-r2)**2)
71309 rfo2=(1+r1**2-2*r1*r2+r2**2-x1-x2)*(x1+x2)/
71310 & (-2+x1+x2)**2
71311 & -(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
71312 & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2
71313 & -r2**2*x2-x1*x2)/(-1+r1**2-r2**2+x2)**2
71314 & +(-1-2*r1**2-r1**4+2*r1*r2+2*r1**3*r2-2*r1*r2**3+r2**4
71315 & +x1+r1**2*x1+2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
71316 & +x1*x2+x2**2)/(-1+r1**2-r2**2+x2)/(-2+x1+x2)
71317 isset2=1
71318 ENDIF
71319 IF(icombi.EQ.4) THEN
71320 rlo4=ps*(1d0-r1**2-r2**2)
71321 rfo4=(1+r1**2+r2**2-x1-x2)*(x1+x2)/(-2+x1+x2)**2
71322 & -(-1+r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1+x2
71323 & +3*r1**2*x2-r2**2*x2-x1*x2)/
71324 & (-1+r1**2-r2**2+x2)**2
71325 & -(-1-2*r1**2-r1**4+r2**4+x1+r1**2*x1-3*r2**2*x1
71326 & +2*r1**2*x2-2*r2**2*x2+x1*x2+x2**2)/
71327 & (2-x1-x2)/(-1+r1**2-r2**2+x2)
71328 isset4=1
71329 ENDIF
71330
71331C...q -> ~q chi.
71332 ELSEIF(iclass.EQ.12) THEN
71333 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71334 rlo1=ps*(1d0-r1**2+r2**2+2d0*r2)
71335 rfo1=(2*r2+x2)*(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
71336 & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1-2*r2*x1+r2**2*x1+x1**2
71337 & -3*x2-r1**2*x2-2*r2*x2+r2**2*x2+x1*x2)/
71338 & (-2+x1+x2)**2-2*(-1-r1**2+r2+r1**2*r2-r2**2-r2**3+x1
71339 & +r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
71340 & (2-x1-x2)/(-1+r1**2-r2**2+x2)
71341 isset1=1
71342 END IF
71343 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71344 rlo2=ps*(1d0-r1**2+r2**2-2d0*r2)
71345 rfo2=(2*r2-x2)*(1+r1**2+r2**2-x2)/(-1+r1**2-r2**2+x2)**2
71346 & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+2*r2*x1+r2**2*x1+x1**2
71347 & -3*x2-r1**2*x2+2*r2*x2+r2**2*x2+x1*x2)/
71348 & (-2+x1+x2)**2-2*(-1-r1**2-r2-r1**2*r2-r2**2+r2**3+x1
71349 & -r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
71350 & (2-x1-x2)/(-1+r1**2-r2**2+x2)
71351 isset2=1
71352 END IF
71353 IF(icombi.EQ.4) THEN
71354 rlo4=ps*(1d0-r1**2+r2**2)
71355 rfo4=x2*(-1-r1**2-r2**2+x2)/(-1+r1**2-r2**2+x2)**2
71356 & +(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+r2**2*x1+x1**2
71357 & -3*x2-r1**2*x2+r2**2*x2+x1*x2)/
71358 & (-2+x1+x2)**2-2*(-1-r1**2-r2**2+x1+r2**2*x1+2*x2
71359 & +r1**2*x2-x1*x2/2-x2**2/2)/
71360 & (2-x1-x2)/(-1+r1**2-r2**2+x2)
71361 isset4=1
71362 END IF
71363
71364C...~g -> q ~qbar.
71365 ELSEIF(iclass.EQ.13) THEN
71366 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71367 rlo1=ps*(1d0+r1**2-r2**2+2d0*r1)
71368 rfo1=4*(2*r1+x1)*(-1-r1**2-r2**2+x1)/(3*(-1-r1**2+r2**2+x1)**2)
71369 & -(-1-r1**2-2*r1**3-r2**2-2*r1*r2**2+3*x1/2+r1*x1-r1**2*x1/2
71370 & -r2**2*x1/2+x2+r1*x2+r1**2*x2-x1*x2/2)/(3*(-1-r1**2+r2**2
71371 & +x1)*(-1+r1**2-r2**2+x2))-3*(-1+r1-r1**2-r1**3-r2**2
71372 & +r1*r2**2+2*x1+r2**2*x1-x1**2/2+x2+r1*x2+r1**2*x2-x1*x2/2)/
71373 & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+3*(4-4*r1**2+4*r2**2-3*x1
71374 & -2*r1*x1+r1**2*x1-r2**2*x1-5*x2-2*r1*x2+r1**2*x2-r2**2*x2
71375 & +x1*x2+x2**2)/(-2+x1+x2)**2+3*(3-r1-5*r1**2-r1**3+3*r2**2
71376 & +r1*r2**2-2*x1-r1*x1+r1**2*x1-4*x2+2*r1**2*x2-r2**2*x2
71377 & +x1*x2+x2**2)/((1-r1**2+r2**2-x2)*(-2+x1+x2))+4*(2-2*r1
71378 & -6*r1**2-2*r1**3+2*r2**2-2*r1*r2**2-x1+r1**2*x1-r2**2*x1
71379 & -3*x2+2*r1*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71380 & (3*(-1+r1**2-r2**2+x2)**2)
71381 rfo1=3d0*rfo1/4d0
71382 isset1=1
71383 ENDIF
71384 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71385 rlo2=ps*(1d0+r1**2-r2**2-2d0*r1)
71386 rfo2=4*(2*r1-x1)*(1+r1**2+r2**2-x1)/(3*(-1-r1**2+r2**2+x1)**2)
71387 & -3*(-1-r1-r1**2+r1**3-r2**2-r1*r2**2+2*x1+r2**2*x1-x1**2/2
71388 & +x2-r1*x2+r1**2*x2-x1*x2/2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
71389 & +(2+2*r1**2-4*r1**3+2*r2**2-4*r1*r2**2-3*x1+2*r1*x1
71390 & +r1**2*x1+r2**2*x1-2*x2+2*r1*x2-2*r1**2*x2+x1*x2)/
71391 & (6*(-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+3*(4-4*r1**2
71392 & +4*r2**2-3*x1+2*r1*x1+r1**2*x1-r2**2*x1-5*x2+2*r1*x2
71393 & +r1**2*x2-r2**2*x2+x1*x2+x2**2)/(-2+x1+x2)**2+3*(3+r1
71394 & -5*r1**2+r1**3+3*r2**2-r1*r2**2-2*x1+r1*x1+r1**2*x1-4*x2
71395 & +2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71396 & ((1-r1**2+r2**2-x2)*(-2+x1+x2))+4*(2+2*r1-6*r1**2+2*r1**3
71397 & +2*r2**2+2*r1*r2**2-x1+r1**2*x1-r2**2*x1-3*x2-2*r1*x2
71398 & +3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71399 & (3*(-1+r1**2-r2**2+x2)**2)
71400 rfo2=3d0*rfo2/4d0
71401 isset2=1
71402 ENDIF
71403 IF(icombi.EQ.4) THEN
71404 rlo4=ps*(1d0+r1**2-r2**2)
71405 rfo4=8*x1*(-1-r1**2-r2**2+x1)/(3*(-1-r1**2+r2**2+x1)**2)-6*(-1
71406 & -r1**2-r2**2+2*x1+r2**2*x1-x1**2/2+x2+r1**2*x2-x1*x2/2)/
71407 & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+(2+2*r1**2+2*r2**2-3*x1
71408 & +r1**2*x1+r2**2*x1-2*x2-2*r1**2*x2+x1*x2)/(3*(-1-r1**2
71409 & +r2**2+x1)*(-1+r1**2-r2**2+x2))+6*(4-4*r1**2+4*r2**2-3*x1
71410 & +r1**2*x1-r2**2*x1-5*x2+r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71411 & (-2+x1+x2)**2+6*(3-5*r1**2+3*r2**2-2*x1+r1**2*x1-4*x2
71412 & +2*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71413 & ((1-r1**2+r2**2-x2)*(-2+x1+x2))+8*(2-6*r1**2+2*r2**2-x1
71414 & +r1**2*x1-r2**2*x1-3*x2+3*r1**2*x2-r2**2*x2+x1*x2+x2**2)/
71415 & (3*(-1+r1**2-r2**2+x2)**2)
71416 rfo4=3d0*rfo4/8d0
71417 isset4=1
71418 ENDIF
71419
71420C...~q -> q ~g.
71421 ELSEIF(iclass.EQ.14) THEN
71422 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71423 rlo1=ps*(1-r1**2-r2**2-2d0*r1*r2)
71424 rfo1=64*(1+r1**2+2*r1*r2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)
71425 & -16*(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71426 & +r2**4+x1-r1**2*x1+2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
71427 & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2-16*(r1**2+r1**4
71428 & -2*r1**3*r2+r2**2-6*r1**2*r2**2-2*r1*r2**3+r2**4
71429 & -r1**2*x1+r1*r2*x1+2*r2**2*x1+2*r1**2*x2+r1*r2*x2-r2**2*x2
71430 & -x1*x2)/((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))
71431 & -64*(-1+r1**4-2*r1*r2-2*r1**3*r2-6*r1**2*r2**2-2*r1*r2**3
71432 & +r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2+2*r1*r2*x2
71433 & -r2**2*x2-x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)
71434 & +8*(-1+r1**4-2*r1*r2+2*r1**3*r2-2*r2**2-2*r1*r2**3-r2**4
71435 & -2*r1**2*x1+2*r2**2*x1+x1**2+x2-3*r1**2*x2-2*r1*r2*x2
71436 & +r2**2*x2+x1*x2)/((-1-r1**2+r2**2+x1)*(-2+x1+x2))
71437 rfo1=rfo1
71438 & +8*(-1-2*r1**2-r1**4-2*r1*r2-2*r1**3*r2+2*r1*r2**3+r2**4
71439 & +x1+r1**2*x1-2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2-2*r2**2*x2
71440 & +x1*x2+x2**2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71441 rfo1=9d0*rfo1/64d0
71442 isset1=1
71443 ENDIF
71444 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71445 rlo2=ps*(1-r1**2-r2**2+2d0*r1*r2)
71446 rfo2=64*(1+r1**2-2*r1*r2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)
71447 & -16*(-1+r1**4+2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3
71448 & +r2**4+x1-r1**2*x1-2*r1*r2*x1+3*r2**2*x1+x2+r1**2*x2
71449 & -r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2-64*(-1+r1**4
71450 & +2*r1*r2+2*r1**3*r2-6*r1**2*r2**2+2*r1*r2**3+r2**4+x1
71451 & -r1**2*x1+r2**2*x1+x2+3*r1**2*x2-2*r1*r2*x2-r2**2*x2
71452 & -x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)+16*(-r1**2-r1**4
71453 & -2*r1**3*r2-r2**2+6*r1**2*r2**2-2*r1*r2**3-r2**4+r1**2*x1
71454 & +r1*r2*x1-2*r2**2*x1-2*r1**2*x2+r1*r2*x2+r2**2*x2+x1*x2)/
71455 & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))
71456 rfo2=rfo2
71457 & +8*(-1+r1**4+2*r1*r2-2*r1**3*r2-2*r2**2+2*r1*r2**3-r2**4
71458 & -2*r1**2*x1+2*r2**2*x1+x1**2+x2-3*r1**2*x2+2*r1*r2*x2
71459 & +r2**2*x2+x1*x2)/((-1-r1**2+r2**2+x1)*(-2+x1+x2))
71460 & +8*(-1-2*r1**2-r1**4+2*r1*r2+2*r1**3*r2-2*r1*r2**3
71461 & +r2**4+x1+r1**2*x1+2*r1*r2*x1-3*r2**2*x1+2*r1**2*x2
71462 & -2*r2**2*x2+x1*x2+x2**2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71463 rfo2=9d0*rfo2/64d0
71464 isset2=1
71465 ENDIF
71466 IF(icombi.EQ.4) THEN
71467 rlo4=ps*(1-r1**2-r2**2)
71468 rfo4=128*(1+r1**2+r2**2-x1-x2)*(x1+x2)/(9*(-2+x1+x2)**2)-32*(-1
71469 & +r1**4-6*r1**2*r2**2+r2**4+x1-r1**2*x1+3*r2**2*x1+x2
71470 & +r1**2*x2-r2**2*x2-x1*x2)/(-1-r1**2+r2**2+x1)**2
71471 & -32*(r1**2+r1**4+r2**2-6*r1**2*r2**2+r2**4-r1**2*x1
71472 & +2*r2**2*x1+2*r1**2*x2-r2**2*x2-x1*x2)/
71473 & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))-128*(-1+r1**4
71474 & -6*r1**2*r2**2+r2**4+x1-r1**2*x1+r2**2*x1+x2+3*r1**2*x2
71475 & -r2**2*x2-x1*x2)/(9*(-1+r1**2-r2**2+x2)**2)
71476 & +16*(-1+r1**4-2*r2**2-r2**4-2*r1**2*x1+2*r2**2*x1+x1**2
71477 & +x2-3*r1**2*x2+r2**2*x2+x1*x2)/
71478 & ((-1-r1**2+r2**2+x1)*(-2+x1+ x2))
71479 rfo4=rfo4+16*(-1-2*r1**2-r1**4+r2**4+x1+r1**2*x1-3*r2**2*x1
71480 & +2*r1**2*x2-2*r2**2*x2+x1*x2+x2**2)/
71481 & (9*(1-r1**2+r2**2-x2)*(-2+x1+x2))
71482 rfo4=9d0*rfo4/128d0
71483 isset4=1
71484 ENDIF
71485
71486C...q -> ~q ~g.
71487 ELSEIF(iclass.EQ.15) THEN
71488 IF(icombi.EQ.1.OR.icombi.EQ.3) THEN
71489 rlo1=ps*(1d0-r1**2+r2**2+2d0*r2)
71490 rfo1=32*(2*r2+x2)*(-1-r1**2-r2**2+x2)/(9*(-1+r1**2-r2**2+x2)**2)
71491 & +8*(-1-r1**2-2*r1**2*r2-r2**2-2*r2**3+x1+r2*x1+r2**2*x1
71492 & +3*x2/2-r1**2*x2/2+r2*x2-r2**2*x2/2-x1*x2/2)/
71493 & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+8*(2+2*r1**2-2*r2
71494 & -2*r1**2*r2-6*r2**2-2*r2**3-3*x1-r1**2*x1+2*r2*x1
71495 & +3*r2**2*x1+x1**2-x2-r1**2*x2+r2**2*x2+x1*x2)/
71496 & (-1-r1**2+r2**2+x1)**2+32*(4+4*r1**2-4*r2**2-5*x1
71497 & -r1**2*x1-2*r2*x1+r2**2*x1+x1**2-3*x2-r1**2*x2-2*r2*x2
71498 & +r2**2*x2+x1*x2)/(9*(-2+x1+x2)**2)
71499 rfo1=rfo1+8*(3+3*r1**2-r2+r1**2*r2-5*r2**2-r2**3-4*x1-r1**2*x1
71500 & +2*r2**2*x1+x1**2-2*x2-r2*x2+r2**2*x2+x1*x2)/
71501 & ((-1-r1**2+r2**2+x1)*(2-x1-x2))+8*(-1-r1**2+r2+r1**2*r2
71502 & -r2**2-r2**3+x1+r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2
71503 & -x2**2/2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71504 rfo1=9d0*rfo1/32d0
71505 isset1=1
71506 END IF
71507 IF(icombi.EQ.2.OR.icombi.EQ.3) THEN
71508 rlo2=ps*(1d0-r1**2+r2**2-2d0*r2)
71509 rfo2=32*(2*r2-x2)*(1+r1**2+r2**2-x2)/(9*(-1+r1**2-r2**2+x2)**2)
71510 & +8*(-1-r1**2+2*r1**2*r2-r2**2+2*r2**3+x1-r2*x1+r2**2*x1
71511 & +3*x2/2-r1**2*x2/2-r2*x2-r2**2*x2/2-x1*x2/2)/
71512 & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+8*(2+2*r1**2+2*r2
71513 & +2*r1**2*r2-6*r2**2+2*r2**3-3*x1-r1**2*x1-2*r2*x1
71514 & +3*r2**2*x1+x1**2-x2-r1**2*x2+r2**2*x2+x1*x2)/
71515 & (-1-r1**2+r2**2+x1)**2+8*(3+3*r1**2+r2-r1**2*r2-5*r2**2
71516 & +r2**3-4*x1-r1**2*x1+2*r2**2*x1+x1**2-2*x2+r2*x2+r2**2*x2
71517 & +x1*x2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
71518 rfo2=rfo2+32*(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+2*r2*x1+r2**2*x1
71519 & +x1**2-3*x2-r1**2*x2+2*r2*x2+r2**2*x2+x1*x2)/
71520 & (9*(-2+x1+x2)**2)+8*(-1-r1**2-r2-r1**2*r2-r2**2+r2**3+x1
71521 & -r2*x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2-x2**2/2)/
71522 & (9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71523 rfo2=9d0*rfo2/32d0
71524 isset2=1
71525 END IF
71526 IF(icombi.EQ.4) THEN
71527 rlo4=ps*(1d0-r1**2+r2**2)
71528 rfo4=64*x2*(-1-r1**2-r2**2+x2)/(9*(-1+r1**2-r2**2+x2)**2)
71529 & +16*(-1-r1**2-r2**2+x1+r2**2*x1+3*x2/2-r1**2*x2/2
71530 & -r2**2*x2/2-x1*x2/2)/
71531 & ((-1-r1**2+r2**2+x1)*(-1+r1**2-r2**2+x2))+16*(3+3*r1**2
71532 & -5*r2**2-4*x1-r1**2*x1+2*r2**2*x1+x1**2-2*x2+r2**2*x2
71533 & +x1*x2)/((-1-r1**2+r2**2+x1)*(2-x1-x2))
71534 & +64*(4+4*r1**2-4*r2**2-5*x1-r1**2*x1+r2**2*x1+x1**2-3*x2
71535 & -r1**2*x2+r2**2*x2+x1*x2)/(9*(-2+x1+x2)**2)
71536 rfo4=rfo4+16*(2+2*r1**2-6*r2**2-3*x1-r1**2*x1+3*r2**2*x1+x1**2
71537 & -x2-r1**2*x2+r2**2*x2+x1*x2)/(-1-r1**2+r2**2+x1)**2
71538 & +16*(-1-r1**2-r2**2+x1+r2**2*x1+2*x2+r1**2*x2-x1*x2/2
71539 & -x2**2/2)/(9*(2-x1-x2)*(-1+r1**2-r2**2+x2))
71540 rfo4=9d0*rfo4/64d0
71541 isset4=1
71542 END IF
71543
71544C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71545 ELSEIF(iclass.EQ.16) THEN
71546 rlo=ps
71547 IF(icombi.EQ.0.OR.icombi.EQ.1) THEN
71548 anum=0d0
71549 ELSEIF(icombi.EQ.2) THEN
71550 anum=(2d0-x1-x2)**2
71551 ELSEIF(icombi.EQ.3) THEN
71552 anum=alpcor*(2d0-x1-x2)**2
71553 ELSE
71554 anum=0.5d0*(2d0-x1-x2)**2
71555 ENDIF
71556 rfo=ps*2d0*((x1+x2-1d0+anum-r1**2-r2**2)/
71557 & ((1d0+r1**2-r2**2-x1)*(1d0+r2**2-r1**2-x2))-
71558 & r1**2/(1d0+r2**2-r1**2-x2)**2-
71559 & r2**2/(1d0+r1**2-r2**2-x1)**2)
71560 rfo=9d0*rfo/4d0
71561 icombi=0
71562 ENDIF
71563
71564C...Find relevant LO and FO expression.
71565 IF(icombi.EQ.0) THEN
71566 ELSEIF(icombi.EQ.1.AND.isset1.EQ.1) THEN
71567 rlo=rlo1
71568 rfo=rfo1
71569 ELSEIF(icombi.EQ.2.AND.isset2.EQ.1) THEN
71570 rlo=rlo2
71571 rfo=rfo2
71572 ELSEIF(icombi.EQ.3.AND.isset1.EQ.1.AND.isset2.EQ.1) THEN
71573 rlo=alpcor*rlo1+(1d0-alpcor)*rlo2
71574 rfo=alpcor*rfo1+(1d0-alpcor)*rfo2
71575 ELSEIF(isset4.EQ.1) THEN
71576 rlo=rlo4
71577 rfo=rfo4
71578 ELSEIF(icombi.EQ.4.AND.isset1.EQ.1.AND.isset2.EQ.1) THEN
71579 rlo=0.5d0*(rlo1+rlo2)
71580 rfo=0.5d0*(rfo1+rfo2)
71581 ELSEIF(isset1.EQ.1) THEN
71582 rlo=rlo1
71583 rfo=rfo1
71584 ELSE
71585 CALL pyerrm(16,'(PYMAEL:) not implemented ME code')
71586 rlo=1d0
71587 rfo=0d0
71588 ENDIF
71589
71590C...Output.
71591 pymael=rfo/rlo
71592
71593 RETURN
71594 END
71595
71596C*********************************************************************
71597
71598C...PYBOEI
71599C...Modifies an event so as to approximately take into account
71600C...Bose-Einstein effects according to a simple phenomenological
71601C...parametrization.
71602
71603 SUBROUTINE pyboei(NSAV)
71604
71605C...Double precision and integer declarations.
71606 IMPLICIT DOUBLE PRECISION(a-h, o-z)
71607 IMPLICIT INTEGER(I-N)
71608 INTEGER PYK,PYCHGE,PYCOMP
71609C...Parameter statement to help give large particle numbers.
71610 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
71611 &kexcit=4000000,kdimen=5000000)
71612C...Commonblocks.
71613 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
71614 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
71615 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
71616 common/pyint1/mint(400),vint(400)
71617 SAVE /pyjets/,/pydat1/,/pydat2/,/pyint1/
71618C...Local arrays and data.
71619 dimension dps(4),kfbe(9),nbe(0:10),bei(100),bei3(100),
71620 &beiw(100),bei3w(100)
71621 DATA kfbe/211,-211,111,321,-321,130,310,221,331/
71622C...Statement function: squared invariant mass.
71623 sdip(i,j)=((p(i,4)+p(j,4))**2-(p(i,3)+p(j,3))**2-
71624 &(p(i,2)+p(j,2))**2-(p(i,1)+p(j,1))**2)
71625
71626C...Boost event to overall CM frame. Calculate CM energy.
71627 IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN
71628 DO 100 j=1,4
71629 dps(j)=0d0
71630 100 CONTINUE
71631 DO 120 i=1,n
71632 kfa=iabs(k(i,2))
71633 IF(k(i,1).LE.10.AND.((kfa.GT.10.AND.kfa.LE.20).OR.kfa.EQ.22)
71634 & .AND.k(i,3).GT.0) THEN
71635 kfma=iabs(k(k(i,3),2))
71636 IF(kfma.GT.10.AND.kfma.LE.80) k(i,1)=-k(i,1)
71637 ENDIF
71638 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 120
71639 DO 110 j=1,4
71640 dps(j)=dps(j)+p(i,j)
71641 110 CONTINUE
71642 120 CONTINUE
71643 CALL pyrobo(0,0,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),
71644 &-dps(3)/dps(4))
71645 pecm=0d0
71646 DO 130 i=1,n
71647 IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)
71648 130 CONTINUE
71649
71650C...Check if we have separated strings
71651
71652C...Reserve copy of particles by species at end of record.
71653 iwp=0
71654 iwn=0
71655 nbe(0)=n+mstu(3)
71656 nmax=nbe(0)
71657 smmin=pecm
71658 DO 190 ibe=1,min(10,mstj(52)+1)
71659 nbe(ibe)=nbe(ibe-1)
71660 DO 180 i=nsav+1,n
71661 IF(ibe.EQ.min(10,mstj(52)+1)) THEN
71662 DO 140 iibe=1,ibe-1
71663 IF(k(i,2).EQ.kfbe(iibe)) GOTO 180
71664 140 CONTINUE
71665 ELSE
71666 IF(k(i,2).NE.kfbe(ibe)) GOTO 180
71667 ENDIF
71668 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 180
71669 IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN
71670 CALL pyerrm(11,'(PYBOEI:) no more memory left in PYJETS')
71671 RETURN
71672 ENDIF
71673 nbe(ibe)=nbe(ibe)+1
71674 nmax=nbe(ibe)
71675 k(nbe(ibe),1)=i
71676 k(nbe(ibe),2)=0
71677 k(nbe(ibe),3)=0
71678 k(nbe(ibe),4)=0
71679 k(nbe(ibe),5)=0
71680 p(nbe(ibe),1)=0.0d0
71681 p(nbe(ibe),2)=0.0d0
71682 p(nbe(ibe),3)=0.0d0
71683 p(nbe(ibe),4)=0.0d0
71684 p(nbe(ibe),5)=0.0d0
71685 smmin=min(smmin,p(i,5))
71686C...Check if particles comes from different W's or Z's
71687 IF((mstj(53).NE.0.OR.mstj(56).GT.0).AND.mint(32).EQ.0) THEN
71688 im=i
71689 150 IF(k(im,3).GT.0) THEN
71690 im=k(im,3)
71691 IF(abs(k(im,2)).NE.24.AND.k(im,2).NE.23) GOTO 150
71692 k(nbe(ibe),5)=im
71693 IF(iwp.EQ.0.AND.k(im,2).EQ.24) iwp=im
71694 IF(iwn.EQ.0.AND.k(im,2).EQ.-24) iwn=im
71695 IF(iwp.EQ.0.AND.k(im,2).EQ.23) iwp=im
71696 IF(iwn.EQ.0.AND.k(im,2).EQ.23.AND.im.NE.iwp) iwn=im
71697 ENDIF
71698 ENDIF
71699C...Check if particles comes from different strings.
71700 IF(parj(94).GT.0.0d0) THEN
71701 im=i
71702 160 IF(k(im,3).GT.0) THEN
71703 im=k(im,3)
71704 IF(k(im,2).NE.92.AND.k(im,2).NE.91) GOTO 160
71705 k(nbe(ibe),5)=im
71706 ENDIF
71707 ENDIF
71708 DO 170 j=1,3
71709 p(nbe(ibe),j)=0d0
71710 v(nbe(ibe),j)=0d0
71711 170 CONTINUE
71712 p(nbe(ibe),5)=-1.0d0
71713 180 CONTINUE
71714 190 CONTINUE
71715 IF(nbe(min(9,mstj(52)))-nbe(0).LE.1) GOTO 510
71716
71717C...Calculate separation between W+ and W- or between two Z0's.
71718C...No separation if there has been re-connections.
71719 sigw=parj(93)
71720 IF(iwp.GT.0.AND.iwn.GT.0.AND.mstj(56).GT.0.AND.mint(32).EQ.0) THEN
71721 IF(k(iwp,2).EQ.23) THEN
71722 dmw=pmas(23,1)
71723 dgw=pmas(23,2)
71724 ELSE
71725 dmw=pmas(24,1)
71726 dgw=pmas(24,2)
71727 ENDIF
71728 dmp=p(iwp,5)
71729 dmn=p(iwn,5)
71730 taupd=dmp/sqrt((dmp**2-dmw**2)**2+(dgw*(dmp**2)/dmw)**2)
71731 taund=dmn/sqrt((dmn**2-dmw**2)**2+(dgw*(dmn**2)/dmw)**2)
71732 taup=-taupd*log(pyr(idum))
71733 taun=-taund*log(pyr(idum))
71734 dxp=taup*pyp(iwp,8)/dmp
71735 dxn=taun*pyp(iwn,8)/dmn
71736 dx=dxp+dxn
71737 sigw=1.0d0/(1.0d0/parj(93)+real(mstj(56))*dx)
71738 IF(parj(94).LT.0.0d0) sigw=1.0d0/(1.0d0/sigw-1.0d0/parj(94))
71739 ENDIF
71740
71741C...Add separation between strings.
71742 IF(parj(94).GT.0.0d0) THEN
71743 sigw=1.0d0/(1.0d0/sigw+1.0d0/parj(94))
71744 iwp=-1
71745 iwn=-1
71746 ENDIF
71747
71748 IF(mstj(57).EQ.1.AND.mstj(54).LT.0) THEN
71749 DO 220 ibe=1,min(9,mstj(52))
71750 DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)
71751 q2min=pecm**2
71752 i1=k(i1m,1)
71753 DO 200 i2m=nbe(ibe-1)+1,nbe(ibe)
71754 IF(i2m.EQ.i1m) GOTO 200
71755 i2=k(i2m,1)
71756 q2=(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-
71757 & (p(i1,2)+p(i2,2))**2-(p(i1,3)+p(i2,3))**2-
71758 & (p(i1,5)+p(i2,5))**2
71759 IF(q2.GT.0.0d0.AND.q2.LT.q2min) THEN
71760 q2min=q2
71761 ENDIF
71762 200 CONTINUE
71763 p(i1m,5)=q2min
71764 210 CONTINUE
71765 220 CONTINUE
71766 ENDIF
71767
71768C...Tabulate integral for subsequent momentum shift.
71769 DO 400 ibe=1,min(9,mstj(52))
71770 IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) GOTO 270
71771 IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))
71772 & .LE.1) GOTO 270
71773 IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),
71774 & nbe(7)-nbe(6)).LE.1) GOTO 270
71775 IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) GOTO 270
71776 IF(ibe.EQ.1) pmhq=2d0*pymass(211)
71777 IF(ibe.EQ.4) pmhq=2d0*pymass(321)
71778 IF(ibe.EQ.8) pmhq=2d0*pymass(221)
71779 IF(ibe.EQ.9) pmhq=2d0*pymass(331)
71780 qdel=0.1d0*min(pmhq,parj(93))
71781 qdel3=0.1d0*min(pmhq,parj(93)*3.0d0)
71782 qdelw=0.1d0*min(pmhq,sigw)
71783 qdel3w=0.1d0*min(pmhq,sigw*3.0d0)
71784 IF(mstj(51).EQ.1) THEN
71785 nbin=min(100,nint(9d0*parj(93)/qdel))
71786 nbin3=min(100,nint(27d0*parj(93)/qdel3))
71787 nbinw=min(100,nint(9d0*sigw/qdelw))
71788 nbin3w=min(100,nint(27d0*sigw/qdel3w))
71789 beex=exp(0.5d0*qdel/parj(93))
71790 beex3=exp(0.5d0*qdel3/(3.0d0*parj(93)))
71791 beexw=exp(0.5d0*qdelw/sigw)
71792 beex3w=exp(0.5d0*qdel3w/(3.0d0*sigw))
71793 bert=exp(-qdel/parj(93))
71794 bert3=exp(-qdel3/(3.0d0*parj(93)))
71795 bertw=exp(-qdelw/sigw)
71796 bert3w=exp(-qdel3w/(3.0d0*sigw))
71797 ELSE
71798 nbin=min(100,nint(3d0*parj(93)/qdel))
71799 nbin3=min(100,nint(9d0*parj(93)/qdel3))
71800 nbinw=min(100,nint(3d0*sigw/qdelw))
71801 nbin3w=min(100,nint(9d0*sigw/qdel3w))
71802 ENDIF
71803 DO 230 ibin=1,nbin
71804 qbin=qdel*(ibin-0.5d0)
71805 bei(ibin)=qdel*(qbin**2+qdel**2/12d0)/sqrt(qbin**2+pmhq**2)
71806 IF(mstj(51).EQ.1) THEN
71807 beex=beex*bert
71808 bei(ibin)=bei(ibin)*beex
71809 ELSE
71810 bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)
71811 ENDIF
71812 IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)
71813 230 CONTINUE
71814 DO 240 ibin=1,nbin3
71815 qbin=qdel3*(ibin-0.5d0)
71816 bei3(ibin)=qdel3*(qbin**2+qdel3**2/12d0)/sqrt(qbin**2+pmhq**2)
71817 IF(mstj(51).EQ.1) THEN
71818 beex3=beex3*bert3
71819 bei3(ibin)=bei3(ibin)*beex3
71820 ELSE
71821 bei3(ibin)=bei3(ibin)*exp(-(qbin/(3.0d0*parj(93)))**2)
71822 ENDIF
71823 IF(ibin.GE.2) bei3(ibin)=bei3(ibin)+bei3(ibin-1)
71824 240 CONTINUE
71825 DO 250 ibin=1,nbinw
71826 qbin=qdelw*(ibin-0.5d0)
71827 beiw(ibin)=qdelw*(qbin**2+qdelw**2/12d0)/sqrt(qbin**2+pmhq**2)
71828 IF(mstj(51).EQ.1) THEN
71829 beexw=beexw*bertw
71830 beiw(ibin)=beiw(ibin)*beexw
71831 ELSE
71832 beiw(ibin)=beiw(ibin)*exp(-(qbin/sigw)**2)
71833 ENDIF
71834 IF(ibin.GE.2) beiw(ibin)=beiw(ibin)+beiw(ibin-1)
71835 250 CONTINUE
71836 DO 260 ibin=1,nbin3w
71837 qbin=qdel3w*(ibin-0.5d0)
71838 bei3w(ibin)=qdel3w*(qbin**2+qdel3w**2/12d0)/
71839 & sqrt(qbin**2+pmhq**2)
71840 IF(mstj(51).EQ.1) THEN
71841 beex3w=beex3w*bert3w
71842 bei3w(ibin)=bei3w(ibin)*beex3w
71843 ELSE
71844 bei3w(ibin)=bei3w(ibin)*exp(-(qbin/(3.0d0*sigw))**2)
71845 ENDIF
71846 IF(ibin.GE.2) bei3w(ibin)=bei3w(ibin)+bei3w(ibin-1)
71847 260 CONTINUE
71848
71849C...Loop through particle pairs and find old relative momentum.
71850 270 DO 390 i1m=nbe(ibe-1)+1,nbe(ibe)-1
71851 i1=k(i1m,1)
71852 DO 380 i2m=i1m+1,nbe(ibe)
71853 IF(mstj(53).EQ.1.AND.k(i1m,5).NE.k(i2m,5)) GOTO 380
71854 IF(mstj(53).EQ.2.AND.k(i1m,5).EQ.k(i2m,5)) GOTO 380
71855 i2=k(i2m,1)
71856 q2old=(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-(p(i1,2)+
71857 & p(i2,2))**2-(p(i1,3)+p(i2,3))**2-(p(i1,5)+p(i2,5))**2
71858 IF(q2old.LE.0.0d0) GOTO 380
71859 qold=sqrt(q2old)
71860
71861C...Calculate new relative momentum.
71862 qmov=0.0d0
71863 qmov3=0.0d0
71864 qmovw=0.0d0
71865 qmov3w=0.0d0
71866 IF(qold.LT.1d-3*qdel) THEN
71867 GOTO 280
71868 ELSEIF(qold.LE.qdel) THEN
71869 qmov=qold/3d0
71870 ELSEIF(qold.LT.(nbin-0.1d0)*qdel) THEN
71871 rbin=qold/qdel
71872 ibin=rbin
71873 rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)
71874 qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*
71875 & sqrt(q2old+pmhq**2)/q2old
71876 ELSE
71877 qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old
71878 ENDIF
71879 280 q2new=q2old*(qold/(qold+3d0*parj(92)*qmov))**(2d0/3d0)
71880 IF(qold.LT.1d-3*qdel3) THEN
71881 GOTO 290
71882 ELSEIF(qold.LE.qdel3) THEN
71883 qmov3=qold/3d0
71884 ELSEIF(qold.LT.(nbin3-0.1d0)*qdel3) THEN
71885 rbin3=qold/qdel3
71886 ibin3=rbin3
71887 rinp3=(rbin3**3-ibin3**3)/(3*ibin3*(ibin3+1)+1)
71888 qmov3=(bei3(ibin3)+rinp3*(bei3(ibin3+1)-bei3(ibin3)))*
71889 & sqrt(q2old+pmhq**2)/q2old
71890 ELSE
71891 qmov3=bei3(nbin3)*sqrt(q2old+pmhq**2)/q2old
71892 ENDIF
71893 290 q2new3=q2old*(qold/(qold+3d0*parj(92)*qmov3))**(2d0/3d0)
71894 rscale=1.0d0
71895 IF(mstj(54).EQ.2)
71896 & rscale=1.0d0-exp(-(qold/(2d0*parj(93)))**2)
71897 IF((iwp.NE.-1.AND.mstj(56).LE.0).OR.iwp.EQ.0.OR.iwn.EQ.0.OR.
71898 & k(i1m,5).EQ.k(i2m,5)) GOTO 320
71899
71900 IF(qold.LT.1d-3*qdelw) THEN
71901 GOTO 300
71902 ELSEIF(qold.LE.qdelw) THEN
71903 qmovw=qold/3d0
71904 ELSEIF(qold.LT.(nbinw-0.1d0)*qdelw) THEN
71905 rbinw=qold/qdelw
71906 ibinw=rbinw
71907 rinpw=(rbinw**3-ibinw**3)/(3*ibinw*(ibinw+1)+1)
71908 qmovw=(beiw(ibinw)+rinpw*(beiw(ibinw+1)-beiw(ibinw)))*
71909 & sqrt(q2old+pmhq**2)/q2old
71910 ELSE
71911 qmovw=beiw(nbinw)*sqrt(q2old+pmhq**2)/q2old
71912 ENDIF
71913 300 q2new=q2old*(qold/(qold+3d0*parj(92)*qmovw))**(2d0/3d0)
71914 IF(qold.LT.1d-3*qdel3w) THEN
71915 GOTO 310
71916 ELSEIF(qold.LE.qdel3w) THEN
71917 qmov3w=qold/3d0
71918 ELSEIF(qold.LT.(nbin3w-0.1d0)*qdel3w) THEN
71919 rbin3w=qold/qdel3w
71920 ibin3w=rbin3w
71921 rinp3w=(rbin3w**3-ibin3w**3)/(3*ibin3w*(ibin3w+1)+1)
71922 qmov3w=(bei3w(ibin3w)+rinp3w*(bei3w(ibin3w+1)-
71923 & bei3w(ibin3w)))*sqrt(q2old+pmhq**2)/q2old
71924 ELSE
71925 qmov3w=bei3w(nbin3w)*sqrt(q2old+pmhq**2)/q2old
71926 ENDIF
71927 310 q2new3=q2old*(qold/(qold+3d0*parj(92)*qmov3w))**(2d0/3d0)
71928 IF(mstj(54).EQ.2)
71929 & rscale=1.0d0-exp(-(qold/(2d0*sigw))**2)
71930
71931 320 CALL pybesq(i1,i2,nmax,q2old,q2new)
71932 DO 330 j=1,3
71933 p(i1m,j)=p(i1m,j)+p(nmax+1,j)
71934 p(i2m,j)=p(i2m,j)+p(nmax+2,j)
71935 330 CONTINUE
71936 IF(mstj(54).GE.1) THEN
71937 CALL pybesq(i1,i2,nmax,q2old,q2new3)
71938 DO 340 j=1,3
71939 v(i1m,j)=v(i1m,j)+p(nmax+1,j)*rscale
71940 v(i2m,j)=v(i2m,j)+p(nmax+2,j)*rscale
71941 340 CONTINUE
71942 ELSEIF(mstj(54).LE.-1) THEN
71943 edel=p(i1,4)+p(i2,4)-
71944 & sqrt(max(q2new-q2old+(p(i1,4)+p(i2,4))**2,0.0d0))
71945 a2=(p(i1,1)-p(i2,1))**2+(p(i1,2)-p(i2,2))**2+
71946 & (p(i1,3)-p(i2,3))**2
71947 wmax=-1.0d20
71948 mi3=0
71949 mi4=0
71950 s12=sdip(i1,i2)
71951 sm1=(p(i1,5)+smmin)**2
71952 DO 360 i3m=nbe(0)+1,nbe(min(10,mstj(52)+1))
71953 IF(i3m.EQ.i1m.OR.i3m.EQ.i2m) GOTO 360
71954 IF(mstj(53).EQ.1.AND.k(i3m,5).NE.k(i1m,5)) GOTO 360
71955 IF(mstj(53).EQ.-2.AND.k(i1m,5).EQ.k(i2m,5).AND.
71956 & k(i3m,5).NE.k(i1m,5)) GOTO 360
71957 i3=k(i3m,1)
71958 IF(k(i3,2).EQ.k(i1,2)) GOTO 360
71959 s13=sdip(i1,i3)
71960 s23=sdip(i2,i3)
71961 sm3=(p(i3,5)+smmin)**2
71962 IF(mstj(54).EQ.-2) THEN
71963 wi=(min(s12*sm3,s13*min(sm1,sm3),
71964 & s23*min(sm1,sm3))*sm1)
71965 ELSE
71966 wi=((p(i1,4)+p(i2,4)+p(i3,4))**2-
71967 & (p(i1,3)+p(i2,3)+p(i3,3))**2-
71968 & (p(i1,2)+p(i2,2)+p(i3,2))**2-
71969 & (p(i1,1)+p(i2,1)+p(i3,1))**2)
71970 ENDIF
71971 IF(mstj(57).EQ.1.AND.p(i3m,5).GT.0) THEN
71972 IF (wmax*wi.GE.(1.0d0-exp(-p(i3m,5)/(parj(93)**2))))
71973 & GOTO 360
71974 ELSE
71975 IF(wmax*wi.GE.1.0) GOTO 360
71976 ENDIF
71977 DO 350 i4m=i3m+1,nbe(min(10,mstj(52)+1))
71978 IF(i4m.EQ.i1m.OR.i4m.EQ.i2m) GOTO 350
71979 IF(mstj(53).EQ.1.AND.k(i4m,5).NE.k(i1m,5)) GOTO 350
71980 IF(mstj(53).EQ.-2.AND.k(i1m,5).EQ.k(i2m,5).AND.
71981 & k(i4m,5).NE.k(i1m,5)) GOTO 350
71982 i4=k(i4m,1)
71983 IF(k(i3,2).EQ.k(i4,2).OR.k(i4,2).EQ.k(i1,2))
71984 & GOTO 350
71985 IF((p(i3,4)+p(i4,4)+edel)**2.LT.
71986 & (p(i3,1)+p(i4,1))**2+(p(i3,2)+p(i4,2))**2+
71987 & (p(i3,3)+p(i4,3))**2+(p(i3,5)+p(i4,5))**2)
71988 & GOTO 350
71989 IF(mstj(54).EQ.-2) THEN
71990 s14=sdip(i1,i4)
71991 s24=sdip(i2,i4)
71992 s34=sdip(i3,i4)
71993 w=s12*min(min(s23,s24),min(s13,s14))*s34
71994 w=min(w,s13*min(min(s23,s34),s12)*s24)
71995 w=min(w,s14*min(min(s24,s34),s12)*s23)
71996 w=min(w,min(s23,s24)*s13*s14)
71997 w=1.0d0/w
71998 ELSE
71999C...weight=1-cos(theta)/mtot2
72000 s1234=(p(i1,4)+p(i2,4)+p(i3,4)+p(i4,4))**2-
72001 & (p(i1,3)+p(i2,3)+p(i3,3)+p(i4,3))**2-
72002 & (p(i1,2)+p(i2,2)+p(i3,2)+p(i4,2))**2-
72003 & (p(i1,1)+p(i2,1)+p(i3,1)+p(i4,1))**2
72004 w=1.0d0/s1234
72005 IF(w.LE.wmax) GOTO 350
72006 ENDIF
72007 IF(mstj(57).EQ.1.AND.p(i3m,5).GT.0)
72008 & w=w*(1.0d0-exp(-p(i3m,5)/(parj(93)**2)))
72009 IF(mstj(57).EQ.1.AND.p(i4m,5).GT.0)
72010 & w=w*(1.0d0-exp(-p(i4m,5)/(parj(93)**2)))
72011 IF(w.LE.wmax) GOTO 350
72012 mi3=i3m
72013 mi4=i4m
72014 wmax=w
72015 350 CONTINUE
72016 360 CONTINUE
72017 IF(mi4.EQ.0) GOTO 380
72018 i3=k(mi3,1)
72019 i4=k(mi4,1)
72020 eold=p(i3,4)+p(i4,4)
72021 enew=eold+edel
72022 p2=(p(i3,1)+p(i4,1))**2+(p(i3,2)+p(i4,2))**2+
72023 & (p(i3,3)+p(i4,3))**2
72024 q2newp=max(0.0d0,enew**2-p2-(p(i3,5)+p(i4,5))**2)
72025 q2oldp=max(0.0d0,eold**2-p2-(p(i3,5)+p(i4,5))**2)
72026 CALL pybesq(i3,i4,nmax,q2oldp,q2newp)
72027 DO 370 j=1,3
72028 v(mi3,j)=v(mi3,j)+p(nmax+1,j)
72029 v(mi4,j)=v(mi4,j)+p(nmax+2,j)
72030 370 CONTINUE
72031 ENDIF
72032 380 CONTINUE
72033 390 CONTINUE
72034 400 CONTINUE
72035
72036C...Shift momenta and recalculate energies.
72037 esump=0.0d0
72038 esum=0.0d0
72039 prod=0.0d0
72040 DO 430 im=nbe(0)+1,nbe(min(10,mstj(52)+1))
72041 i=k(im,1)
72042 esump=esump+p(i,4)
72043 DO 410 j=1,3
72044 p(i,j)=p(i,j)+p(im,j)
72045 410 CONTINUE
72046 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
72047 esum=esum+p(i,4)
72048 DO 420 j=1,3
72049 prod=prod+v(im,j)*p(i,j)/p(i,4)
72050 420 CONTINUE
72051 430 CONTINUE
72052
72053 parj(96)=0.0d0
72054 IF(mstj(54).NE.0.AND.prod.NE.0.0d0) THEN
72055 440 alpha=(esump-esum)/prod
72056 parj(96)=parj(96)+alpha
72057 prod=0.0d0
72058 esum=0.0d0
72059 DO 470 im=nbe(0)+1,nbe(min(10,mstj(52)+1))
72060 i=k(im,1)
72061 DO 450 j=1,3
72062 p(i,j)=p(i,j)+alpha*v(im,j)
72063 450 CONTINUE
72064 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
72065 esum=esum+p(i,4)
72066 DO 460 j=1,3
72067 prod=prod+v(im,j)*p(i,j)/p(i,4)
72068 460 CONTINUE
72069 470 CONTINUE
72070 IF(prod.NE.0.0d0.AND.abs(esump-esum)/pecm.GT.0.00001d0)
72071 & GOTO 440
72072 ENDIF
72073
72074C...Rescale all momenta for energy conservation.
72075 pes=0d0
72076 pqs=0d0
72077 DO 480 i=1,n
72078 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 480
72079 pes=pes+p(i,4)
72080 pqs=pqs+p(i,5)**2/p(i,4)
72081 480 CONTINUE
72082 parj(95)=pes-pecm
72083 fac=(pecm-pqs)/(pes-pqs)
72084 DO 500 i=1,n
72085 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 500
72086 DO 490 j=1,3
72087 p(i,j)=fac*p(i,j)
72088 490 CONTINUE
72089 p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
72090 500 CONTINUE
72091
72092C...Boost back to correct reference frame.
72093 510 CALL pyrobo(0,0,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))
72094 DO 520 i=1,n
72095 IF(k(i,1).LT.0) k(i,1)=-k(i,1)
72096 520 CONTINUE
72097
72098 RETURN
72099 END
72100
72101C*********************************************************************
72102
72103C...PYBESQ
72104C...Calculates the momentum shift in a system of two particles assuming
72105C...the relative momentum squared should be shifted to Q2NEW. NI is the
72106C...last position occupied in /PYJETS/.
72107
72108 SUBROUTINE pybesq(I1,I2,NI,Q2OLD,Q2NEW)
72109
72110C...Double precision and integer declarations.
72111 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72112 IMPLICIT INTEGER(I-N)
72113 INTEGER PYK,PYCHGE,PYCOMP
72114C...Parameter statement to help give large particle numbers.
72115 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
72116 &kexcit=4000000,kdimen=5000000)
72117C...Commonblocks.
72118 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72119 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72120 SAVE /pyjets/,/pydat1/
72121C...Local arrays and data.
72122 dimension dp(5)
72123 SAVE hc1
72124
72125 IF(mstj(55).EQ.0) THEN
72126 dq2=q2new-q2old
72127 dp2=(p(i1,1)-p(i2,1))**2+(p(i1,2)-p(i2,2))**2+
72128 & (p(i1,3)-p(i2,3))**2
72129 dp12=p(i1,1)**2+p(i1,2)**2+p(i1,3)**2
72130 & -p(i2,1)**2-p(i2,2)**2-p(i2,3)**2
72131 se=p(i1,4)+p(i2,4)
72132 de=p(i1,4)-p(i2,4)
72133 dq2se=dq2+se**2
72134 da=se*de*dp12-dp2*dq2se
72135 db=dp2*dq2se-dp12**2
72136 ha=(da+sqrt(max(da**2+dq2*(dq2+se**2-de**2)*db,0d0)))/(2d0*db)
72137 DO 100 j=1,3
72138 pd=ha*(p(i1,j)-p(i2,j))
72139 p(ni+1,j)=pd
72140 p(ni+2,j)=-pd
72141 100 CONTINUE
72142 RETURN
72143 ENDIF
72144
72145 k(ni+1,1)=1
72146 k(ni+2,1)=1
72147 DO 110 j=1,5
72148 p(ni+1,j)=p(i1,j)
72149 p(ni+2,j)=p(i2,j)
72150 dp(j)=p(i1,j)+p(i2,j)
72151 110 CONTINUE
72152
72153C...Boost to cms and rotate first particle to z-axis
72154 CALL pyrobo(ni+1,ni+2,0.0d0,0.0d0,
72155 &-dp(1)/dp(4),-dp(2)/dp(4),-dp(3)/dp(4))
72156 phi=pyangl(p(ni+1,1),p(ni+1,2))
72157 the=pyangl(p(ni+1,3),sqrt(p(ni+1,1)**2+p(ni+1,2)**2))
72158 s=q2new+(p(i1,5)+p(i2,5))**2
72159 pz=0.5d0*sqrt(q2new*(s-(p(i1,5)-p(i2,5))**2)/s)
72160 p(ni+1,1)=0.0d0
72161 p(ni+1,2)=0.0d0
72162 p(ni+1,3)=pz
72163 p(ni+1,4)=sqrt(pz**2+p(i1,5)**2)
72164 p(ni+2,1)=0.0d0
72165 p(ni+2,2)=0.0d0
72166 p(ni+2,3)=-pz
72167 p(ni+2,4)=sqrt(pz**2+p(i2,5)**2)
72168 dp(4)=sqrt(dp(1)**2+dp(2)**2+dp(3)**2+s)
72169 CALL pyrobo(ni+1,ni+2,the,phi,
72170 &dp(1)/dp(4),dp(2)/dp(4),dp(3)/dp(4))
72171
72172 DO 120 j=1,3
72173 p(ni+1,j)=p(ni+1,j)-p(i1,j)
72174 p(ni+2,j)=p(ni+2,j)-p(i2,j)
72175 120 CONTINUE
72176
72177 RETURN
72178 END
72179
72180C*********************************************************************
72181
72182C...PYMASS
72183C...Gives the mass of a particle/parton.
72184
72185 FUNCTION pymass(KF)
72186
72187C...Double precision and integer declarations.
72188 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72189 IMPLICIT INTEGER(I-N)
72190 INTEGER PYK,PYCHGE,PYCOMP
72191C...Commonblocks.
72192 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72193 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72194 SAVE /pydat1/,/pydat2/
72195
72196C...Reset variables. Compressed code. Special case for popcorn diquarks.
72197 pymass=0d0
72198 kfa=iabs(kf)
72199 kc=pycomp(kf)
72200 IF(kc.EQ.0) THEN
72201 mstj(93)=0
72202 RETURN
72203 ENDIF
72204
72205C...Guarantee use of constituent masses for internal checks.
72206 IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.
72207 &(kfa.LE.10.OR.mod(kfa/10,10).EQ.0)) THEN
72208 IF(kfa.LE.5) THEN
72209 pymass=parf(100+kfa)
72210 IF(mstj(93).EQ.2) pymass=max(0d0,pymass-parf(121))
72211 ELSEIF(kfa.LE.10) THEN
72212 pymass=pmas(kfa,1)
72213 ELSEIF(mstj(93).EQ.1) THEN
72214 pymass=parf(100+mod(kfa/1000,10))+parf(100+mod(kfa/100,10))
72215 ELSE
72216 pymass=max(0d0,pmas(kc,1)-parf(122)-2d0*parf(112)/3d0)
72217 ENDIF
72218
72219C...Other masses can be read directly off table.
72220 ELSE
72221 pymass=pmas(kc,1)
72222 ENDIF
72223
72224C...Optional mass broadening according to truncated Breit-Wigner
72225C...(either in m or in m^2).
72226 IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1d-4) THEN
72227 IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN
72228 pymass=pymass+0.5d0*pmas(kc,2)*tan((2d0*pyr(0)-1d0)*
72229 & atan(2d0*pmas(kc,3)/pmas(kc,2)))
72230 ELSE
72231 pm0=pymass
72232 pmlow=atan((max(0d0,pm0-pmas(kc,3))**2-pm0**2)/
72233 & (pm0*pmas(kc,2)))
72234 pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))
72235 pymass=sqrt(max(0d0,pm0**2+pm0*pmas(kc,2)*tan(pmlow+
72236 & (pmupp-pmlow)*pyr(0))))
72237 ENDIF
72238 ENDIF
72239 mstj(93)=0
72240
72241 RETURN
72242 END
72243
72244C*********************************************************************
72245
72246C...PYMRUN
72247C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72248C...for Higgs couplings. Everything else sent on to PYMASS.
72249
72250 FUNCTION pymrun(KF,Q2)
72251
72252C...Double precision and integer declarations.
72253 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72254 IMPLICIT INTEGER(I-N)
72255 INTEGER PYK,PYCHGE,PYCOMP
72256C...Commonblocks.
72257 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72258 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72259 common/pypars/mstp(200),parp(200),msti(200),pari(200)
72260 SAVE /pydat1/,/pydat2/,/pypars/
72261
72262C...Most masses not handled here.
72263 kfa=iabs(kf)
72264 IF(kfa.EQ.0.OR.kfa.GT.6) THEN
72265 pymrun=pymass(kf)
72266
72267C...Current-algebra masses, but no Q2 dependence.
72268 ELSEIF(mstp(37).NE.1.OR.mstp(2).LE.0) THEN
72269 pymrun=parf(90+kfa)
72270
72271C...Running current-algebra masses.
72272 ELSE
72273 as=pyalps(q2)
72274 pymrun=parf(90+kfa)*
72275 & (log(max(4d0,parp(37)**2*parf(90+kfa)**2/paru(117)**2))/
72276 & log(max(4d0,q2/paru(117)**2)))**(12d0/(33d0-2d0*mstu(118)))
72277 ENDIF
72278
72279 RETURN
72280 END
72281
72282C*********************************************************************
72283
72284C...PYNAME
72285C...Gives the particle/parton name as a character string.
72286
72287 SUBROUTINE pyname(KF,CHAU)
72288
72289C...Double precision and integer declarations.
72290 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72291 IMPLICIT INTEGER(I-N)
72292 INTEGER PYK,PYCHGE,PYCOMP
72293C...Commonblocks.
72294 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72295 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72296 common/pydat4/chaf(500,2)
72297 CHARACTER CHAF*16
72298 SAVE /pydat1/,/pydat2/,/pydat4/
72299C...Local character variable.
72300 CHARACTER CHAU*16
72301
72302C...Read out code with distinction particle/antiparticle.
72303 chau=' '
72304 kc=pycomp(kf)
72305 IF(kc.NE.0) chau=chaf(kc,(3-isign(1,kf))/2)
72306
72307
72308 RETURN
72309 END
72310
72311C*********************************************************************
72312
72313C...PYCHGE
72314C...Gives three times the charge for a particle/parton.
72315
72316 FUNCTION pychge(KF)
72317
72318C...Double precision and integer declarations.
72319 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72320 IMPLICIT INTEGER(I-N)
72321 INTEGER PYK,PYCHGE,PYCOMP
72322C...Commonblocks.
72323 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72324 SAVE /pydat2/
72325
72326C...Read out charge and change sign for antiparticle.
72327 pychge=0
72328 kc=pycomp(kf)
72329 IF(kc.NE.0) pychge=kchg(kc,1)*isign(1,kf)
72330
72331 RETURN
72332 END
72333
72334C*********************************************************************
72335
72336C...PYCOMP
72337C...Compress the standard KF codes for use in mass and decay arrays;
72338C...also checks whether a given code actually is defined.
72339
72340 FUNCTION pycomp(KF)
72341
72342C...Double precision and integer declarations.
72343 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72344 IMPLICIT INTEGER(I-N)
72345 INTEGER PYK,PYCHGE,PYCOMP
72346C...Commonblocks.
72347 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72348 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72349 SAVE /pydat1/,/pydat2/
72350C...Local arrays and saved data.
72351 dimension kford(100:500),kcord(101:500)
72352 SAVE kford,kcord,nford,kflast,kclast
72353
72354C...Whenever necessary reorder codes for faster search.
72355 IF(mstu(20).EQ.0) THEN
72356 nford=100
72357 kford(100)=0
72358 DO 120 i=101,500
72359 kfa=kchg(i,4)
72360 IF(kfa.LE.100) GOTO 120
72361 nford=nford+1
72362 DO 100 i1=nford-1,0,-1
72363 IF(kfa.GE.kford(i1)) GOTO 110
72364 kford(i1+1)=kford(i1)
72365 kcord(i1+1)=kcord(i1)
72366 100 CONTINUE
72367 110 kford(i1+1)=kfa
72368 kcord(i1+1)=i
72369 120 CONTINUE
72370 mstu(20)=1
72371 kflast=0
72372 kclast=0
72373 ENDIF
72374
72375C...Fast action if same code as in latest call.
72376 IF(kf.EQ.kflast) THEN
72377 pycomp=kclast
72378 RETURN
72379 ENDIF
72380
72381C...Starting values. Remove internal diquark flags.
72382 pycomp=0
72383 kfa=iabs(kf)
72384 IF(mod(kfa/10,10).EQ.0.AND.kfa.LT.100000
72385 & .AND.mod(kfa/1000,10).GT.0) kfa=mod(kfa,10000)
72386
72387C...Simple cases: direct translation.
72388 IF(kfa.GT.kford(nford)) THEN
72389 ELSEIF(kfa.LE.100) THEN
72390 pycomp=kfa
72391
72392C...Else binary search.
72393 ELSE
72394 imin=100
72395 imax=nford+1
72396 130 iavg=(imin+imax)/2
72397 IF(kford(iavg).GT.kfa) THEN
72398 imax=iavg
72399 IF(imax.GT.imin+1) GOTO 130
72400 ELSEIF(kford(iavg).LT.kfa) THEN
72401 imin=iavg
72402 IF(imax.GT.imin+1) GOTO 130
72403 ELSE
72404 pycomp=kcord(iavg)
72405 ENDIF
72406 ENDIF
72407
72408C...Check if antiparticle allowed.
72409 IF(pycomp.NE.0.AND.kf.LT.0) THEN
72410 IF(kchg(pycomp,3).EQ.0) pycomp=0
72411 ENDIF
72412
72413C...Save codes for possible future fast action.
72414 kflast=kf
72415 kclast=pycomp
72416
72417 RETURN
72418 END
72419
72420C*********************************************************************
72421
72422C...PYERRM
72423C...Informs user of errors in program execution.
72424
72425 SUBROUTINE pyerrm(MERR,CHMESS)
72426
72427C...Double precision and integer declarations.
72428 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72429 IMPLICIT INTEGER(I-N)
72430 INTEGER PYK,PYCHGE,PYCOMP
72431C...Commonblocks.
72432 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72433 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72434 SAVE /pyjets/,/pydat1/
72435C...Local character variable.
72436 CHARACTER CHMESS*(*)
72437
72438C...Write first few warnings, then be silent.
72439 IF(merr.LE.10) THEN
72440 mstu(27)=mstu(27)+1
72441 mstu(28)=merr
72442 IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)
72443 & merr,mstu(31),chmess
72444
72445C...Write first few errors, then be silent or stop program.
72446 ELSEIF(merr.LE.20) THEN
72447 IF(mstu(29).EQ.0) mstu(23)=mstu(23)+1
72448 mstu(30)=mstu(30)+1
72449 mstu(24)=merr-10
72450 IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)
72451 & merr-10,mstu(31),chmess
72452 IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN
72453 WRITE(mstu(11),5100) merr-10,mstu(31),chmess
72454 WRITE(mstu(11),5200)
72455 IF(merr.NE.17) CALL pylist(2)
72456 CALL pystop(3)
72457 ENDIF
72458
72459C...Stop program in case of irreparable error.
72460 ELSE
72461 WRITE(mstu(11),5300) merr-20,mstu(31),chmess
72462 CALL pystop(3)
72463 ENDIF
72464
72465C...Formats for output.
72466 5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i9,
72467 &' PYEXEC calls:'/5x,a)
72468 5100 FORMAT(/5x,'Error type',i2,' has occured after',i9,
72469 &' PYEXEC calls:'/5x,a)
72470 5200 FORMAT(5x,'Execution will be stopped after listing of last ',
72471 &'event!')
72472 5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i9,
72473 &' PYEXEC calls:'/5x,a/5x,'Execution will now be stopped!')
72474
72475 RETURN
72476 END
72477
72478C*********************************************************************
72479
72480C...PYALEM
72481C...Calculates the running alpha_electromagnetic.
72482
72483 FUNCTION pyalem(Q2)
72484
72485C...Double precision and integer declarations.
72486 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72487 IMPLICIT INTEGER(I-N)
72488 INTEGER PYK,PYCHGE,PYCOMP
72489C...Commonblocks.
72490 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72491 SAVE /pydat1/
72492
72493C...Calculate real part of photon vacuum polarization.
72494C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72495C...For hadrons use parametrization of H. Burkhardt et al.
72496C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72497 aempi=paru(101)/(3d0*paru(1))
72498 IF(mstu(101).LE.0.OR.q2.LT.2d-6) THEN
72499 rpigg=0d0
72500 ELSEIF(mstu(101).EQ.2.AND.q2.LT.paru(104)) THEN
72501 rpigg=0d0
72502 ELSEIF(mstu(101).EQ.2) THEN
72503 rpigg=1d0-paru(101)/paru(103)
72504 ELSEIF(q2.LT.0.09d0) THEN
72505 rpigg=aempi*(13.4916d0+log(q2))+0.00835d0*log(1d0+q2)
72506 ELSEIF(q2.LT.9d0) THEN
72507 rpigg=aempi*(16.3200d0+2d0*log(q2))+
72508 & 0.00238d0*log(1d0+3.927d0*q2)
72509 ELSEIF(q2.LT.1d4) THEN
72510 rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00165d0+
72511 & 0.00299d0*log(1d0+q2)
72512 ELSE
72513 rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00221d0+
72514 & 0.00293d0*log(1d0+q2)
72515 ENDIF
72516
72517C...Calculate running alpha_em.
72518 pyalem=paru(101)/(1d0-rpigg)
72519 paru(108)=pyalem
72520
72521 RETURN
72522 END
72523
72524C*********************************************************************
72525
72526C...PYALPS
72527C...Gives the value of alpha_strong.
72528
72529 FUNCTION pyalps(Q2)
72530
72531C...Double precision and integer declarations.
72532 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72533 IMPLICIT INTEGER(I-N)
72534 INTEGER PYK,PYCHGE,PYCOMP
72535C...Commonblocks.
72536 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72537 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72538 SAVE /pydat1/,/pydat2/
72539C...Coefficients for second-order threshold matching.
72540C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72541 dimension stepdn(6),stepup(6)
72542c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72543c &(2D0*321D0/3703D0),0D0/
72544c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72545c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72546 DATA stepdn/0d0,0d0,0.10568d0,0.13398d0,0.17337d0,0d0/
72547 DATA stepup/0d0,0d0,0d0,-0.11413d0,-0.14563d0,-0.18988d0/
72548
72549C...Constant alpha_strong trivial. Pick artificial Lambda.
72550 IF(mstu(111).LE.0) THEN
72551 pyalps=paru(111)
72552 mstu(118)=mstu(112)
72553 paru(117)=0.2d0
72554 IF(q2.GT.0.04d0) paru(117)=sqrt(q2)*exp(-6d0*paru(1)/
72555 & ((33d0-2d0*mstu(112))*paru(111)))
72556 paru(118)=paru(111)
72557 RETURN
72558 ENDIF
72559
72560C...Find effective Q2, number of flavours and Lambda.
72561 q2eff=q2
72562 IF(mstu(115).GE.2) q2eff=max(q2,paru(114))
72563 nf=mstu(112)
72564 alam2=paru(112)**2
72565 100 IF(nf.GT.max(3,mstu(113))) THEN
72566 q2thr=paru(113)*pmas(nf,1)**2
72567 IF(q2eff.LT.q2thr) THEN
72568 nf=nf-1
72569 q2rat=q2thr/alam2
72570 alam2=alam2*q2rat**(2d0/(33d0-2d0*nf))
72571 IF(mstu(111).EQ.2) alam2=alam2*log(q2rat)**stepdn(nf)
72572 GOTO 100
72573 ENDIF
72574 ENDIF
72575 110 IF(nf.LT.min(6,mstu(114))) THEN
72576 q2thr=paru(113)*pmas(nf+1,1)**2
72577 IF(q2eff.GT.q2thr) THEN
72578 nf=nf+1
72579 q2rat=q2thr/alam2
72580 alam2=alam2*q2rat**(-2d0/(33d0-2d0*nf))
72581 IF(mstu(111).EQ.2) alam2=alam2*log(q2rat)**stepup(nf)
72582 GOTO 110
72583 ENDIF
72584 ENDIF
72585 IF(mstu(115).EQ.1) q2eff=q2eff+alam2
72586 paru(117)=sqrt(alam2)
72587
72588C...Evaluate first or second order alpha_strong.
72589 b0=(33d0-2d0*nf)/6d0
72590 algq=log(max(1.0001d0,q2eff/alam2))
72591 IF(mstu(111).EQ.1) THEN
72592 pyalps=min(paru(115),paru(2)/(b0*algq))
72593 ELSE
72594 b1=(153d0-19d0*nf)/6d0
72595 pyalps=min(paru(115),paru(2)/(b0*algq)*(1d0-b1*log(algq)/
72596 & (b0**2*algq)))
72597 ENDIF
72598 mstu(118)=nf
72599 paru(118)=pyalps
72600
72601 RETURN
72602 END
72603
72604C*********************************************************************
72605
72606C...PYANGL
72607C...Reconstructs an angle from given x and y coordinates.
72608
72609 FUNCTION pyangl(X,Y)
72610
72611C...Double precision and integer declarations.
72612 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72613 IMPLICIT INTEGER(I-N)
72614 INTEGER PYK,PYCHGE,PYCOMP
72615C...Commonblocks.
72616 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72617 SAVE /pydat1/
72618
72619 pyangl=0d0
72620 r=sqrt(x**2+y**2)
72621 IF(r.LT.1d-20) RETURN
72622 IF(abs(x)/r.LT.0.8d0) THEN
72623 pyangl=sign(acos(x/r),y)
72624 ELSE
72625 pyangl=asin(y/r)
72626 IF(x.LT.0d0.AND.pyangl.GE.0d0) THEN
72627 pyangl=paru(1)-pyangl
72628 ELSEIF(x.LT.0d0) THEN
72629 pyangl=-paru(1)-pyangl
72630 ENDIF
72631 ENDIF
72632
72633 RETURN
72634 END
72635
72636C*********************************************************************
72637
72638C...PYR
72639C...Generates random numbers uniformly distributed between
72640C...0 and 1, excluding the endpoints.
72641
72642 FUNCTION pyr(IDUMMY)
72643
72644C...Double precision and integer declarations.
72645 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72646 IMPLICIT INTEGER(I-N)
72647 INTEGER PYK,PYCHGE,PYCOMP
72648C...Commonblocks.
72649 common/pydatr/mrpy(6),rrpy(100)
72650 SAVE /pydatr/
72651C...Equivalence between commonblock and local variables.
72652 equivalence(mrpy1,mrpy(1)),(mrpy2,mrpy(2)),(mrpy3,mrpy(3)),
72653 &(mrpy4,mrpy(4)),(mrpy5,mrpy(5)),(mrpy6,mrpy(6)),
72654 &(rrpy98,rrpy(98)),(rrpy99,rrpy(99)),(rrpy00,rrpy(100))
72655
72656C...Initialize generation from given seed.
72657 IF(mrpy2.EQ.0) THEN
72658 ij=mod(mrpy1/30082,31329)
72659 kl=mod(mrpy1,30082)
72660 i=mod(ij/177,177)+2
72661 j=mod(ij,177)+2
72662 k=mod(kl/169,178)+1
72663 l=mod(kl,169)
72664 DO 110 ii=1,97
72665 s=0d0
72666 t=0.5d0
72667 DO 100 jj=1,48
72668 m=mod(mod(i*j,179)*k,179)
72669 i=j
72670 j=k
72671 k=m
72672 l=mod(53*l+1,169)
72673 IF(mod(l*m,64).GE.32) s=s+t
72674 t=0.5d0*t
72675 100 CONTINUE
72676 rrpy(ii)=s
72677 110 CONTINUE
72678 twom24=1d0
72679 DO 120 i24=1,24
72680 twom24=0.5d0*twom24
72681 120 CONTINUE
72682 rrpy98=362436d0*twom24
72683 rrpy99=7654321d0*twom24
72684 rrpy00=16777213d0*twom24
72685 mrpy2=1
72686 mrpy3=0
72687 mrpy4=97
72688 mrpy5=33
72689 ENDIF
72690
72691C...Generate next random number.
72692 130 runi=rrpy(mrpy4)-rrpy(mrpy5)
72693 IF(runi.LT.0d0) runi=runi+1d0
72694 rrpy(mrpy4)=runi
72695 mrpy4=mrpy4-1
72696 IF(mrpy4.EQ.0) mrpy4=97
72697 mrpy5=mrpy5-1
72698 IF(mrpy5.EQ.0) mrpy5=97
72699 rrpy98=rrpy98-rrpy99
72700 IF(rrpy98.LT.0d0) rrpy98=rrpy98+rrpy00
72701 runi=runi-rrpy98
72702 IF(runi.LT.0d0) runi=runi+1d0
72703 IF(runi.LE.0d0.OR.runi.GE.1d0) GOTO 130
72704
72705C...Update counters. Random number to output.
72706 mrpy3=mrpy3+1
72707 IF(mrpy3.EQ.1000000000) THEN
72708 mrpy2=mrpy2+1
72709 mrpy3=0
72710 ENDIF
72711 pyr=runi
72712
72713 RETURN
72714 END
72715
72716C*********************************************************************
72717
72718C...PYRGET
72719C...Dumps the state of the random number generator on a file
72720C...for subsequent startup from this state onwards.
72721
72722 SUBROUTINE pyrget(LFN,MOVE)
72723
72724C...Double precision and integer declarations.
72725 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72726 IMPLICIT INTEGER(I-N)
72727 INTEGER PYK,PYCHGE,PYCOMP
72728C...Commonblocks.
72729 common/pydatr/mrpy(6),rrpy(100)
72730 SAVE /pydatr/
72731C...Local character variable.
72732 CHARACTER CHERR*8
72733
72734C...Backspace required number of records (or as many as there are).
72735 IF(move.LT.0) THEN
72736 nbck=min(mrpy(6),-move)
72737 DO 100 ibck=1,nbck
72738 backspace(lfn,err=110,iostat=ierr)
72739 100 CONTINUE
72740 mrpy(6)=mrpy(6)-nbck
72741 ENDIF
72742
72743C...Unformatted write on unit LFN.
72744 WRITE(lfn,err=110,iostat=ierr) (mrpy(i1),i1=1,5),
72745 &(rrpy(i2),i2=1,100)
72746 mrpy(6)=mrpy(6)+1
72747 RETURN
72748
72749C...Write error.
72750 110 WRITE(cherr,'(I8)') ierr
72751 CALL pyerrm(18,'(PYRGET:) error when accessing file, IOSTAT ='//
72752 &cherr)
72753
72754 RETURN
72755 END
72756
72757C*********************************************************************
72758
72759C...PYRSET
72760C...Reads a state of the random number generator from a file
72761C...for subsequent generation from this state onwards.
72762
72763 SUBROUTINE pyrset(LFN,MOVE)
72764
72765C...Double precision and integer declarations.
72766 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72767 IMPLICIT INTEGER(I-N)
72768 INTEGER PYK,PYCHGE,PYCOMP
72769C...Commonblocks.
72770 common/pydatr/mrpy(6),rrpy(100)
72771 SAVE /pydatr/
72772C...Local character variable.
72773 CHARACTER CHERR*8
72774
72775C...Backspace required number of records (or as many as there are).
72776 IF(move.LT.0) THEN
72777 nbck=min(mrpy(6),-move)
72778 DO 100 ibck=1,nbck
72779 backspace(lfn,err=120,iostat=ierr)
72780 100 CONTINUE
72781 mrpy(6)=mrpy(6)-nbck
72782 ENDIF
72783
72784C...Unformatted read from unit LFN.
72785 nfor=1+max(0,move)
72786 DO 110 ifor=1,nfor
72787 READ(lfn,err=120,iostat=ierr) (mrpy(i1),i1=1,5),
72788 & (rrpy(i2),i2=1,100)
72789 110 CONTINUE
72790 mrpy(6)=mrpy(6)+nfor
72791 RETURN
72792
72793C...Write error.
72794 120 WRITE(cherr,'(I8)') ierr
72795 CALL pyerrm(18,'(PYRSET:) error when accessing file, IOSTAT ='//
72796 &cherr)
72797
72798 RETURN
72799 END
72800
72801C*********************************************************************
72802
72803C...PYROBO
72804C...Performs rotations and boosts.
72805
72806 SUBROUTINE pyrobo(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72807
72808C...Double precision and integer declarations.
72809 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72810 IMPLICIT INTEGER(I-N)
72811 INTEGER PYK,PYCHGE,PYCOMP
72812C...Commonblocks.
72813 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72814 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72815 SAVE /pyjets/,/pydat1/
72816C...Local arrays.
72817 dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)
72818
72819C...Find and check range of rotation/boost.
72820 imin=imi
72821 IF(imin.LE.0) imin=1
72822 IF(mstu(1).GT.0) imin=mstu(1)
72823 imax=ima
72824 IF(imax.LE.0) imax=n
72825 IF(mstu(2).GT.0) imax=mstu(2)
72826 IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN
72827 CALL pyerrm(11,'(PYROBO:) range outside PYJETS memory')
72828 RETURN
72829 ENDIF
72830
72831C...Optional resetting of V (when not set before.)
72832 IF(mstu(33).NE.0) THEN
72833 DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))
72834 DO 100 j=1,5
72835 v(i,j)=0d0
72836 100 CONTINUE
72837 110 CONTINUE
72838 mstu(33)=0
72839 ENDIF
72840
72841C...Rotate, typically from z axis to direction (theta,phi).
72842 IF(the**2+phi**2.GT.1d-20) THEN
72843 rot(1,1)=cos(the)*cos(phi)
72844 rot(1,2)=-sin(phi)
72845 rot(1,3)=sin(the)*cos(phi)
72846 rot(2,1)=cos(the)*sin(phi)
72847 rot(2,2)=cos(phi)
72848 rot(2,3)=sin(the)*sin(phi)
72849 rot(3,1)=-sin(the)
72850 rot(3,2)=0d0
72851 rot(3,3)=cos(the)
72852 DO 140 i=imin,imax
72853 IF(k(i,1).LE.0) GOTO 140
72854 DO 120 j=1,3
72855 pr(j)=p(i,j)
72856 vr(j)=v(i,j)
72857 120 CONTINUE
72858 DO 130 j=1,3
72859 p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)
72860 v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)
72861 130 CONTINUE
72862 140 CONTINUE
72863 ENDIF
72864
72865C...Boost, typically from rest to momentum/energy=beta.
72866 IF(bex**2+bey**2+bez**2.GT.1d-20) THEN
72867 dbx=bex
72868 dby=bey
72869 dbz=bez
72870 db=sqrt(dbx**2+dby**2+dbz**2)
72871 eps1=1d0-1d-12
72872 IF(db.GT.eps1) THEN
72873C...Rescale boost vector if too close to unity.
72874 CALL pyerrm(3,'(PYROBO:) boost vector too large')
72875 dbx=dbx*(eps1/db)
72876 dby=dby*(eps1/db)
72877 dbz=dbz*(eps1/db)
72878 db=eps1
72879 ENDIF
72880 dga=1d0/sqrt(1d0-db**2)
72881 DO 160 i=imin,imax
72882 IF(k(i,1).LE.0) GOTO 160
72883 DO 150 j=1,4
72884 dp(j)=p(i,j)
72885 dv(j)=v(i,j)
72886 150 CONTINUE
72887 dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)
72888 dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))
72889 p(i,1)=dp(1)+dgabp*dbx
72890 p(i,2)=dp(2)+dgabp*dby
72891 p(i,3)=dp(3)+dgabp*dbz
72892 p(i,4)=dga*(dp(4)+dbp)
72893 dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)
72894 dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))
72895 v(i,1)=dv(1)+dgabv*dbx
72896 v(i,2)=dv(2)+dgabv*dby
72897 v(i,3)=dv(3)+dgabv*dbz
72898 v(i,4)=dga*(dv(4)+dbv)
72899 160 CONTINUE
72900 ENDIF
72901
72902 RETURN
72903 END
72904
72905C*********************************************************************
72906
72907C...PYEDIT
72908C...Performs global manipulations on the event record, in particular
72909C...to exclude unstable or undetectable partons/particles.
72910
72911 SUBROUTINE pyedit(MEDIT)
72912
72913C...Double precision and integer declarations.
72914 IMPLICIT DOUBLE PRECISION(a-h, o-z)
72915 IMPLICIT INTEGER(I-N)
72916 INTEGER PYK,PYCHGE,PYCOMP
72917C...Parameter statement to help give large particle numbers.
72918 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
72919 &kexcit=4000000,kdimen=5000000)
72920C...Commonblocks.
72921 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
72922 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
72923 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
72924 common/pyctag/nct,mct(4000,2)
72925 SAVE /pyjets/,/pydat1/,/pydat2/,/pyctag/
72926C...Local arrays.
72927 dimension ns(2),pts(2),pls(2)
72928
72929C...Remove unwanted partons/particles.
72930 IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN
72931 imax=n
72932 IF(mstu(2).GT.0) imax=mstu(2)
72933 i1=max(1,mstu(1))-1
72934 DO 110 i=max(1,mstu(1)),imax
72935 IF(k(i,1).EQ.0.OR.(k(i,1).GE.21.AND.k(i,1).LE.40)) GOTO 110
72936 IF(medit.EQ.1) THEN
72937 IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) GOTO 110
72938 ELSEIF(medit.EQ.2) THEN
72939 IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) GOTO 110
72940 kc=pycomp(k(i,2))
72941 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
72942 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
72943 & k(i,2).EQ.ksusy1+39) GOTO 110
72944 ELSEIF(medit.EQ.3) THEN
72945 IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42) GOTO 110
72946 kc=pycomp(k(i,2))
72947 IF(kc.EQ.0) GOTO 110
72948 IF(kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0) GOTO 110
72949 ELSEIF(medit.EQ.5) THEN
72950 IF(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.k(i,1).EQ.52) GOTO 110
72951 kc=pycomp(k(i,2))
72952 IF(kc.EQ.0) GOTO 110
72953 IF(k(i,1).GT.10.AND.k(i,1).NE.41.AND.k(i,1).NE.42.AND.
72954 & kchg(kc,2).EQ.0) GOTO 110
72955 ENDIF
72956
72957C...Pack remaining partons/particles. Origin no longer known.
72958 i1=i1+1
72959 DO 100 j=1,5
72960 k(i1,j)=k(i,j)
72961 p(i1,j)=p(i,j)
72962 v(i1,j)=v(i,j)
72963 100 CONTINUE
72964 k(i1,3)=0
72965 110 CONTINUE
72966 IF(i1.LT.n) mstu(3)=0
72967 IF(i1.LT.n) mstu(70)=0
72968 n=i1
72969
72970C...Selective removal of class of entries. New position of retained.
72971 ELSEIF(medit.GE.11.AND.medit.LE.15) THEN
72972 i1=0
72973 DO 120 i=1,n
72974 k(i,3)=mod(k(i,3),mstu(5))
72975 IF(medit.EQ.11.AND.k(i,1).LT.0) GOTO 120
72976 IF(medit.EQ.12.AND.k(i,1).EQ.0) GOTO 120
72977 IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.
72978 & k(i,1).EQ.15.OR.k(i,1).EQ.51).AND.k(i,2).NE.94) GOTO 120
72979 IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.
72980 & k(i,1).EQ.52.OR.k(i,2).EQ.94)) GOTO 120
72981 IF(medit.EQ.15.AND.k(i,1).GE.21.AND.k(i,1).LE.40) GOTO 120
72982 i1=i1+1
72983 k(i,3)=k(i,3)+mstu(5)*i1
72984 120 CONTINUE
72985
72986C...Find new event history information and replace old.
72987 DO 140 i=1,n
72988 IF(k(i,1).LE.0.OR.(k(i,1).GE.21.AND.k(i,1).LE.40).OR.
72989 & k(i,3)/mstu(5).EQ.0) GOTO 140
72990 id=i
72991 130 im=mod(k(id,3),mstu(5))
72992 IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN
72993 IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15.OR.
72994 & k(im,1).EQ.51).AND.k(im,2).NE.94) THEN
72995 id=im
72996 GOTO 130
72997 ENDIF
72998 ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN
72999 IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,1).EQ.52.OR.
73000 & k(im,2).EQ.94) THEN
73001 id=im
73002 GOTO 130
73003 ENDIF
73004 ENDIF
73005 k(i,3)=mstu(5)*(k(i,3)/mstu(5))
73006 IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)
73007 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14.AND.
73008 & k(i,1).NE.42.AND.k(i,1).NE.52) THEN
73009 IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=
73010 & k(k(i,4),3)/mstu(5)
73011 IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=
73012 & k(k(i,5),3)/mstu(5)
73013 ELSE
73014 kcm=mod(k(i,4)/mstu(5),mstu(5))
73015 IF(kcm.GT.0.AND.kcm.LE.mstu(4).AND.k(i,1).NE.42.AND.
73016 & k(i,1).NE.52) kcm=k(kcm,3)/mstu(5)
73017 kcd=mod(k(i,4),mstu(5))
73018 IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
73019 k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd
73020 kcm=mod(k(i,5)/mstu(5),mstu(5))
73021 IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)
73022 kcd=mod(k(i,5),mstu(5))
73023 IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)
73024 k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd
73025 ENDIF
73026 140 CONTINUE
73027
73028C...Pack remaining entries.
73029 i1=0
73030 mstu90=mstu(90)
73031 mstu(90)=0
73032 DO 170 i=1,n
73033 IF(k(i,3)/mstu(5).EQ.0) GOTO 170
73034 i1=i1+1
73035 DO 150 j=1,5
73036 k(i1,j)=k(i,j)
73037 p(i1,j)=p(i,j)
73038 v(i1,j)=v(i,j)
73039 150 CONTINUE
73040C...Also update LHA1 colour tags
73041 mct(i1,1)=mct(i,1)
73042 mct(i1,2)=mct(i,2)
73043 k(i1,3)=mod(k(i1,3),mstu(5))
73044 DO 160 iz=1,mstu90
73045 IF(i.EQ.mstu(90+iz)) THEN
73046 mstu(90)=mstu(90)+1
73047 mstu(90+mstu(90))=i1
73048 paru(90+mstu(90))=paru(90+iz)
73049 ENDIF
73050 160 CONTINUE
73051 170 CONTINUE
73052 IF(i1.LT.n) mstu(3)=0
73053 IF(i1.LT.n) mstu(70)=0
73054 n=i1
73055
73056C...Fill in some missing daughter pointers (lost in colour flow).
73057 ELSEIF(medit.EQ.16) THEN
73058 DO 220 i=1,n
73059 IF(k(i,1).LE.10.OR.(k(i,1).GE.21.AND.k(i,1).LE.50)) GOTO 220
73060 IF(k(i,4).NE.0.OR.k(i,5).NE.0) GOTO 220
73061C...Find daughters who point to mother.
73062 DO 180 i1=i+1,n
73063 IF(k(i1,3).NE.i) THEN
73064 ELSEIF(k(i,4).EQ.0) THEN
73065 k(i,4)=i1
73066 ELSE
73067 k(i,5)=i1
73068 ENDIF
73069 180 CONTINUE
73070 IF(k(i,5).EQ.0) k(i,5)=k(i,4)
73071 IF(k(i,4).NE.0) GOTO 220
73072C...Find daughters who point to documentation version of mother.
73073 im=k(i,3)
73074 IF(im.LE.0.OR.im.GE.i) GOTO 220
73075 IF(k(im,1).LE.20.OR.k(im,1).GT.30) GOTO 220
73076 IF(k(im,2).NE.k(i,2).OR.abs(p(im,5)-p(i,5)).GT.1d-2) GOTO 220
73077 DO 190 i1=i+1,n
73078 IF(k(i1,3).NE.im) THEN
73079 ELSEIF(k(i,4).EQ.0) THEN
73080 k(i,4)=i1
73081 ELSE
73082 k(i,5)=i1
73083 ENDIF
73084 190 CONTINUE
73085 IF(k(i,5).EQ.0) k(i,5)=k(i,4)
73086 IF(k(i,4).NE.0) GOTO 220
73087C...Find daughters who point to documentation daughters who,
73088C...in their turn, point to documentation mother.
73089 id1=im
73090 id2=im
73091 DO 200 i1=im+1,i-1
73092 IF(k(i1,3).EQ.im.AND.k(i1,1).GE.21.AND.k(i1,1).LE.30) THEN
73093 id2=i1
73094 IF(id1.EQ.im) id1=i1
73095 ENDIF
73096 200 CONTINUE
73097 DO 210 i1=i+1,n
73098 IF(k(i1,3).NE.id1.AND.k(i1,3).NE.id2) THEN
73099 ELSEIF(k(i,4).EQ.0) THEN
73100 k(i,4)=i1
73101 ELSE
73102 k(i,5)=i1
73103 ENDIF
73104 210 CONTINUE
73105 IF(k(i,5).EQ.0) k(i,5)=k(i,4)
73106 220 CONTINUE
73107
73108C...Save top entries at bottom of PYJETS commonblock.
73109 ELSEIF(medit.EQ.21) THEN
73110 IF(2*n.GE.mstu(4)) THEN
73111 CALL pyerrm(11,'(PYEDIT:) no more memory left in PYJETS')
73112 RETURN
73113 ENDIF
73114 DO 240 i=1,n
73115 DO 230 j=1,5
73116 k(mstu(4)-i,j)=k(i,j)
73117 p(mstu(4)-i,j)=p(i,j)
73118 v(mstu(4)-i,j)=v(i,j)
73119 230 CONTINUE
73120 240 CONTINUE
73121 mstu(32)=n
73122
73123C...Restore bottom entries of commonblock PYJETS to top.
73124 ELSEIF(medit.EQ.22) THEN
73125 DO 260 i=1,mstu(32)
73126 DO 250 j=1,5
73127 k(i,j)=k(mstu(4)-i,j)
73128 p(i,j)=p(mstu(4)-i,j)
73129 v(i,j)=v(mstu(4)-i,j)
73130 250 CONTINUE
73131 260 CONTINUE
73132 n=mstu(32)
73133
73134C...Mark primary entries at top of commonblock PYJETS as untreated.
73135 ELSEIF(medit.EQ.23) THEN
73136 i1=0
73137 DO 270 i=1,n
73138 kh=k(i,3)
73139 IF(kh.GE.1) THEN
73140 IF(k(kh,1).GE.21.AND.k(kh,1).LE.30) kh=0
73141 ENDIF
73142 IF(kh.NE.0) GOTO 280
73143 i1=i1+1
73144 IF(k(i,1).GE.11.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10
73145 IF(k(i,1).GE.51.AND.k(i,1).LE.60) k(i,1)=k(i,1)-10
73146 270 CONTINUE
73147 280 n=i1
73148
73149C...Place largest axis along z axis and second largest in xy plane.
73150 ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN
73151 CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61),1),
73152 & p(mstu(61),2)),0d0,0d0,0d0)
73153 CALL pyrobo(1,n+mstu(3),-pyangl(p(mstu(61),3),
73154 & p(mstu(61),1)),0d0,0d0,0d0,0d0)
73155 CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61)+1,1),
73156 & p(mstu(61)+1,2)),0d0,0d0,0d0)
73157 IF(medit.EQ.31) RETURN
73158
73159C...Rotate to put slim jet along +z axis.
73160 DO 290 is=1,2
73161 ns(is)=0
73162 pts(is)=0d0
73163 pls(is)=0d0
73164 290 CONTINUE
73165 DO 300 i=1,n
73166 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 300
73167 IF(mstu(41).GE.2) THEN
73168 kc=pycomp(k(i,2))
73169 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
73170 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
73171 & k(i,2).EQ.ksusy1+39) GOTO 300
73172 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
73173 & .EQ.0) GOTO 300
73174 ENDIF
73175 is=2d0-sign(0.5d0,p(i,3))
73176 ns(is)=ns(is)+1
73177 pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)
73178 300 CONTINUE
73179 IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)
73180 & CALL pyrobo(1,n+mstu(3),paru(1),0d0,0d0,0d0,0d0)
73181
73182C...Rotate to put second largest jet into -z,+x quadrant.
73183 DO 310 i=1,n
73184 IF(p(i,3).GE.0d0) GOTO 310
73185 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 310
73186 IF(mstu(41).GE.2) THEN
73187 kc=pycomp(k(i,2))
73188 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
73189 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
73190 & k(i,2).EQ.ksusy1+39) GOTO 310
73191 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))
73192 & .EQ.0) GOTO 310
73193 ENDIF
73194 is=2d0-sign(0.5d0,p(i,1))
73195 pls(is)=pls(is)-p(i,3)
73196 310 CONTINUE
73197 IF(pls(2).GT.pls(1)) CALL pyrobo(1,n+mstu(3),0d0,paru(1),
73198 & 0d0,0d0,0d0)
73199 ENDIF
73200
73201 RETURN
73202 END
73203
73204C*********************************************************************
73205
73206C...PYLIST
73207C...Gives program heading, or lists an event, or particle
73208C...data, or current parameter values.
73209
73210 SUBROUTINE pylist(MLIST)
73211
73212C...Double precision and integer declarations.
73213 IMPLICIT DOUBLE PRECISION(a-h, o-z)
73214 IMPLICIT INTEGER(I-N)
73215 INTEGER PYK,PYCHGE,PYCOMP
73216C...Parameter statement to help give large particle numbers.
73217 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
73218 &kexcit=4000000,kdimen=5000000)
73219
73220C...HEPEVT commonblock.
73221 parameter(nmxhep=4000)
73222 common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
73223 &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
73224 DOUBLE PRECISION PHEP,VHEP
73225 SAVE /hepevt/
73226
73227C...User process event common block.
73228 INTEGER MAXNUP
73229 parameter(maxnup=500)
73230 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73231 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73232 common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
73233 &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
73234 &vtimup(maxnup),spinup(maxnup)
73235 SAVE /hepeup/
73236
73237C...Commonblocks.
73238 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
73239 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
73240 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
73241 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
73242 common/pyctag/nct,mct(4000,2)
73243 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyctag/
73244C...Local arrays, character variables and data.
73245 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73246 dimension ps(6)
73247 DATA chdl/'(())',' ','()','!!','<>','==','(==)'/
73248
73249C...Initialization printout: version number and date of last change.
73250 IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN
73251 CALL pylogo
73252 mstu(12)=12345
73253 IF(mlist.EQ.0) RETURN
73254 ENDIF
73255
73256C...List event data, including additional lines after N.
73257 IF(mlist.GE.1.AND.mlist.LE.4) THEN
73258 IF(mlist.EQ.1) WRITE(mstu(11),5100)
73259 IF(mlist.EQ.2) WRITE(mstu(11),5200)
73260 IF(mlist.EQ.3) WRITE(mstu(11),5300)
73261 IF(mlist.EQ.4) WRITE(mstu(11),5400)
73262 lmx=12
73263 IF(mlist.GE.2) lmx=16
73264 istr=0
73265 imax=n
73266 IF(mstu(2).GT.0) imax=mstu(2)
73267 DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))
73268 IF(i.GT.imax.AND.i.LE.n) GOTO 120
73269 IF(mstu(15).EQ.0.AND.k(i,1).LE.0) GOTO 120
73270 IF(mstu(15).EQ.1.AND.k(i,1).LT.0) GOTO 120
73271
73272C...Get particle name, pad it and check it is not too long.
73273 CALL pyname(k(i,2),chap)
73274 len=0
73275 DO 100 lem=1,16
73276 IF(chap(lem:lem).NE.' ') len=lem
73277 100 CONTINUE
73278 mdl=(k(i,1)+19)/10
73279 ldl=0
73280 IF(mdl.EQ.2.OR.mdl.GE.8) THEN
73281 chac=chap
73282 IF(len.GT.lmx) chac(lmx:lmx)='?'
73283 ELSE
73284 ldl=1
73285 IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2
73286 IF(len.EQ.0) THEN
73287 chac=chdl(mdl)(1:2*ldl)//' '
73288 ELSE
73289 chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//
73290 & chdl(mdl)(ldl+1:2*ldl)//' '
73291 IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'
73292 ENDIF
73293 ENDIF
73294
73295C...Add information on string connection.
73296 IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)
73297 & THEN
73298 kc=pycomp(k(i,2))
73299 kcc=0
73300 IF(kc.NE.0) kcc=kchg(kc,2)
73301 IF(iabs(k(i,2)).EQ.39) THEN
73302 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'
73303 ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN
73304 istr=1
73305 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'
73306 ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN
73307 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'
73308 ELSEIF(kcc.NE.0) THEN
73309 istr=0
73310 IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'
73311 ENDIF
73312 ENDIF
73313 IF((k(i,1).EQ.41.OR.k(i,1).EQ.51).AND.len+2*ldl+3.LE.lmx)
73314 & chac(lmx-1:lmx-1)='I'
73315
73316C...Write data for particle/jet.
73317 IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999d0) THEN
73318 WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),
73319 & (p(i,j2),j2=1,5)
73320 ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999d0) THEN
73321 WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),
73322 & (p(i,j2),j2=1,5)
73323 ELSEIF(mlist.EQ.1) THEN
73324 WRITE(mstu(11),5700) i,chac(1:12),(k(i,j1),j1=1,3),
73325 & (p(i,j2),j2=1,5)
73326 ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.
73327 & k(i,1).EQ.14.OR.k(i,1).EQ.42.OR.k(i,1).EQ.52)) THEN
73328 IF(mlist.NE.4) WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,3),
73329 & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
73330 & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),
73331 & (p(i,j2),j2=1,5)
73332 IF(mlist.EQ.4) WRITE(mstu(11),5900) i,chac,(k(i,j1),j1=1,3),
73333 & k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),
73334 & k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5)
73335 & ,10000),mct(i,1),mct(i,2)
73336 ELSE
73337 IF(mlist.NE.4) WRITE(mstu(11),6000) i,chac,(k(i,j1),j1=1,5),
73338 & (p(i,j2),j2=1,5)
73339 IF(mlist.EQ.4) WRITE(mstu(11),6100) i,chac,(k(i,j1),j1=1,5)
73340 & ,mct(i,1),mct(i,2)
73341 ENDIF
73342 IF(mlist.EQ.3) WRITE(mstu(11),6200) (v(i,j),j=1,5)
73343
73344C...Insert extra separator lines specified by user.
73345 IF(mstu(70).GE.1) THEN
73346 isep=0
73347 DO 110 j=1,min(10,mstu(70))
73348 IF(i.EQ.mstu(70+j)) isep=1
73349 110 CONTINUE
73350 IF(isep.EQ.1) THEN
73351 IF(mlist.EQ.1) WRITE(mstu(11),6300)
73352 IF(mlist.EQ.2.OR.mlist.EQ.3) WRITE(mstu(11),6400)
73353 IF(mlist.EQ.4) WRITE(mstu(11),6500)
73354 ENDIF
73355 ENDIF
73356 120 CONTINUE
73357
73358C...Sum of charges and momenta.
73359 DO 130 j=1,6
73360 ps(j)=pyp(0,j)
73361 130 CONTINUE
73362 IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999d0) THEN
73363 WRITE(mstu(11),6600) ps(6),(ps(j),j=1,5)
73364 ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999d0) THEN
73365 WRITE(mstu(11),6700) ps(6),(ps(j),j=1,5)
73366 ELSEIF(mlist.EQ.1) THEN
73367 WRITE(mstu(11),6800) ps(6),(ps(j),j=1,5)
73368 ELSEIF(mlist.LE.3) THEN
73369 WRITE(mstu(11),6900) ps(6),(ps(j),j=1,5)
73370 ELSE
73371 WRITE(mstu(11),7000) ps(6)
73372 ENDIF
73373
73374C...Simple listing of HEPEVT entries (mainly for test purposes).
73375 ELSEIF(mlist.EQ.5) THEN
73376 WRITE(mstu(11),7100)
73377 DO 140 i=1,nhep
73378 IF(isthep(i).EQ.0) GOTO 140
73379 WRITE(mstu(11),7200) i,isthep(i),idhep(i),jmohep(1,i),
73380 & jmohep(2,i),jdahep(1,i),jdahep(2,i),(phep(j,i),j=1,5)
73381 140 CONTINUE
73382
73383
73384C...Simple listing of user-process entries (mainly for test purposes).
73385 ELSEIF(mlist.EQ.7) THEN
73386 WRITE(mstu(11),7300)
73387 DO 150 i=1,nup
73388 WRITE(mstu(11),7400) i,istup(i),idup(i),mothup(1,i),
73389 & mothup(2,i),icolup(1,i),icolup(2,i),(pup(j,i),j=1,5)
73390 150 CONTINUE
73391
73392C...Give simple list of KF codes defined in program.
73393 ELSEIF(mlist.EQ.11) THEN
73394 WRITE(mstu(11),7500)
73395 DO 160 kf=1,80
73396 CALL pyname(kf,chap)
73397 CALL pyname(-kf,chan)
73398 IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),7600) kf,chap
73399 IF(chan.NE.' ') WRITE(mstu(11),7600) kf,chap,-kf,chan
73400 160 CONTINUE
73401 DO 190 kfls=1,3,2
73402 DO 180 kfla=1,5
73403 DO 170 kflb=1,kfla-(3-kfls)/2
73404 kf=1000*kfla+100*kflb+kfls
73405 CALL pyname(kf,chap)
73406 CALL pyname(-kf,chan)
73407 WRITE(mstu(11),7600) kf,chap,-kf,chan
73408 170 CONTINUE
73409 180 CONTINUE
73410 190 CONTINUE
73411 DO 220 kmul=0,5
73412 kfls=3
73413 IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1
73414 IF(kmul.EQ.5) kfls=5
73415 kflr=0
73416 IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1
73417 IF(kmul.EQ.4) kflr=2
73418 DO 210 kflb=1,5
73419 DO 200 kflc=1,kflb-1
73420 kf=10000*kflr+100*kflb+10*kflc+kfls
73421 CALL pyname(kf,chap)
73422 CALL pyname(-kf,chan)
73423 WRITE(mstu(11),7600) kf,chap,-kf,chan
73424 IF(kf.EQ.311) THEN
73425 kfk=130
73426 CALL pyname(kfk,chap)
73427 WRITE(mstu(11),7600) kfk,chap
73428 kfk=310
73429 CALL pyname(kfk,chap)
73430 WRITE(mstu(11),7600) kfk,chap
73431 ENDIF
73432 200 CONTINUE
73433 kf=10000*kflr+110*kflb+kfls
73434 CALL pyname(kf,chap)
73435 WRITE(mstu(11),7600) kf,chap
73436 210 CONTINUE
73437 220 CONTINUE
73438 kf=100443
73439 CALL pyname(kf,chap)
73440 WRITE(mstu(11),7600) kf,chap
73441 kf=100553
73442 CALL pyname(kf,chap)
73443 WRITE(mstu(11),7600) kf,chap
73444 DO 260 kflsp=1,3
73445 kfls=2+2*(kflsp/3)
73446 DO 250 kfla=1,5
73447 DO 240 kflb=1,kfla
73448 DO 230 kflc=1,kflb
73449 IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc))
73450 & GOTO 230
73451 IF(kflsp.EQ.2.AND.kfla.EQ.kflc) GOTO 230
73452 IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls
73453 IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls
73454 CALL pyname(kf,chap)
73455 CALL pyname(-kf,chan)
73456 WRITE(mstu(11),7600) kf,chap,-kf,chan
73457 230 CONTINUE
73458 240 CONTINUE
73459 250 CONTINUE
73460 260 CONTINUE
73461 DO 270 kc=1,500
73462 kf=kchg(kc,4)
73463 IF(kf.LT.1000000) GOTO 270
73464 CALL pyname(kf,chap)
73465 CALL pyname(-kf,chan)
73466 IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),7600) kf,chap
73467 IF(chan.NE.' ') WRITE(mstu(11),7600) kf,chap,-kf,chan
73468 270 CONTINUE
73469
73470C...List parton/particle data table. Check whether to be listed.
73471 ELSEIF(mlist.EQ.12) THEN
73472 WRITE(mstu(11),7700)
73473 DO 300 kc=1,mstu(6)
73474 kf=kchg(kc,4)
73475 IF(kf.EQ.0) GOTO 300
73476 IF(kf.LT.mstu(1).OR.(mstu(2).GT.0.AND.kf.GT.mstu(2)))
73477 & GOTO 300
73478
73479C...Find particle name and mass. Print information.
73480 CALL pyname(kf,chap)
73481 IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) GOTO 300
73482 CALL pyname(-kf,chan)
73483 WRITE(mstu(11),7800) kf,kc,chap,chan,(kchg(kc,j1),j1=1,3),
73484 & (pmas(kc,j2),j2=1,4),mdcy(kc,1)
73485
73486C...Particle decay: channel number, branching ratios, matrix element,
73487C...decay products.
73488 DO 290 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
73489 DO 280 j=1,5
73490 CALL pyname(kfdp(idc,j),chad(j))
73491 280 CONTINUE
73492 WRITE(mstu(11),7900) idc,mdme(idc,1),mdme(idc,2),brat(idc),
73493 & (chad(j),j=1,5)
73494 290 CONTINUE
73495 300 CONTINUE
73496
73497C...List parameter value table.
73498 ELSEIF(mlist.EQ.13) THEN
73499 WRITE(mstu(11),8000)
73500 DO 310 i=1,200
73501 WRITE(mstu(11),8100) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)
73502 310 CONTINUE
73503 ENDIF
73504
73505C...Format statements for output on unit MSTU(11) (by default 6).
73506 5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',
73507 &5x,'KF orig p_x p_y p_z E m'/)
73508 5200 FORMAT(///28x,'Event listing (standard)'//4x,'I particle/jet',
73509 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73510 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73511 5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I particle/j',
73512 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73513 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73x,
73514 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73515 5400 FORMAT(///28x,'Event listing (no momenta)'//4x,'I particle/jet',
73516 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1x
73517 & ,' C tag AC tag'/)
73518 5500 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.3)
73519 5600 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.2)
73520 5700 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.1)
73521 5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),5f13.5)
73522 5900 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),1x,2i8)
73523 6000 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),5f13.5)
73524 6100 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),1x,2i8)
73525 6200 FORMAT(66x,5(1x,f12.3))
73526 6300 FORMAT(1x,78('='))
73527 6400 FORMAT(1x,130('='))
73528 6500 FORMAT(1x,65('='))
73529 6600 FORMAT(19x,'sum:',f6.2,5x,5f9.3)
73530 6700 FORMAT(19x,'sum:',f6.2,5x,5f9.2)
73531 6800 FORMAT(19x,'sum:',f6.2,5x,5f9.1)
73532 6900 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',
73533 &5f13.5)
73534 7000 FORMAT(19x,'sum charge:',f6.2)
73535 7100 FORMAT(/10x,'Event listing of HEPEVT common block (simplified)'
73536 &//' I IST ID Mothers Daughters p_x p_y p_z',
73537 &' E m')
73538 7200 FORMAT(1x,i4,i2,i8,4i5,5f9.3)
73539 7300 FORMAT(/10x,'Event listing of user process at input (simplified)'
73540 &//' I IST ID Mothers Colours p_x p_y p_z',
73541 &' E m')
73542 7400 FORMAT(1x,i3,i3,i8,2i4,2i5,5f9.3)
73543 7500 FORMAT(///20x,'List of KF codes in program'/)
73544 7600 FORMAT(4x,i9,4x,a16,6x,i9,4x,a16)
73545 7700 FORMAT(///30x,'Particle/parton data table'//8x,'KF',5x,'KC',4x,
73546 &'particle',8x,'antiparticle',6x,'chg col anti',8x,'mass',7x,
73547 &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',
73548 &1x,'ME',3x,'Br.rat.',4x,'decay products')
73549 7800 FORMAT(/1x,i9,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),
73550 &1x,1p,e13.5,3x,i2)
73551 7900 FORMAT(10x,i4,2x,i3,2x,i3,2x,f10.6,4x,5a16)
73552 8000 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',
73553 &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')
73554 8100 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)
73555
73556 RETURN
73557 END
73558
73559C*********************************************************************
73560
73561C...PYLOGO
73562C...Writes a logo for the program.
73563
73564 SUBROUTINE pylogo
73565
73566C...Double precision and integer declarations.
73567 IMPLICIT DOUBLE PRECISION(a-h, o-z)
73568 IMPLICIT INTEGER(I-N)
73569 INTEGER PYK,PYCHGE,PYCOMP
73570C...Parameter for length of information block.
73571 parameter(irefer=21)
73572C...Commonblocks.
73573 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
73574 common/pypars/mstp(200),parp(200),msti(200),pari(200)
73575 SAVE /pydat1/,/pypars/
73576C...Local arrays and character variables.
73577 INTEGER IDATI(6)
73578 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73579 &vers*1, subv*3, date*2, year*4, hour*2, minu*2, seco*2
73580
73581C...Data on months, logo, titles, and references.
73582 DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73583 &'Oct','Nov','Dec'/
73584 DATA (logo(j),j=1,19)/
73585 &' *......* ',
73586 &' *:::!!:::::::::::* ',
73587 &' *::::::!!::::::::::::::* ',
73588 &' *::::::::!!::::::::::::::::* ',
73589 &' *:::::::::!!:::::::::::::::::* ',
73590 &' *:::::::::!!:::::::::::::::::* ',
73591 &' *::::::::!!::::::::::::::::*! ',
73592 &' *::::::!!::::::::::::::* !! ',
73593 &' !! *:::!!:::::::::::* !! ',
73594 &' !! !* -><- * !! ',
73595 &' !! !! !! ',
73596 &' !! !! !! ',
73597 &' !! !! ',
73598 &' !! lh !! ',
73599 &' !! !! ',
73600 &' !! hh !! ',
73601 &' !! ll !! ',
73602 &' !! !! ',
73603 &' !! '/
73604 DATA (logo(j),j=20,38)/
73605 &'Welcome to the Lund Monte Carlo!',
73606 &' ',
73607 &'PPP Y Y TTTTT H H III A ',
73608 &'P P Y Y T H H I A A ',
73609 &'PPP Y T HHHHH I AAAAA',
73610 &'P Y T H H I A A',
73611 &'P Y T H H III A A',
73612 &' ',
73613 &'This is PYTHIA version x.xxx ',
73614 &'Last date of change: xx xxx 200x',
73615 &' ',
73616 &'Now is xx xxx 200x at xx:xx:xx ',
73617 &' ',
73618 &'Disclaimer: this program comes ',
73619 &'without any guarantees. Beware ',
73620 &'of errors and use common sense ',
73621 &'when interpreting results. ',
73622 &' ',
73623 &'Copyright T. Sjostrand (2008) '/
73624 DATA (refer(j),j=1,14)/
73625 &'An archive of program versions and d',
73626 &'ocumentation is found on the web: ',
73627 &'http://www.thep.lu.se/~torbjorn/Pyth',
73628 &'ia.html ',
73629 &' ',
73630 &' ',
73631 &'When you cite this program, the offi',
73632 &'cial reference is to the 6.4 manual:',
73633 &'T. Sjostrand, S. Mrenna and P. Skand',
73634 &'s, JHEP05 (2006) 026 ',
73635 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73636 &'-T) [hep-ph/0603175]. ',
73637 &' ',
73638 &' '/
73639 DATA (refer(j),j=15,32)/
73640 &'Also remember that the program, to a',
73641 &' large extent, represents original ',
73642 &'physics research. Other publications',
73643 &' of special relevance to your ',
73644 &'studies may therefore deserve separa',
73645 &'te mention. ',
73646 &' ',
73647 &' ',
73648 &'Main author: Torbjorn Sjostrand; Dep',
73649 &'artment of Theoretical Physics, ',
73650 &' Lund University, Solvegatan 14A, S',
73651 &'-223 62 Lund, Sweden; ',
73652 &' phone: + 46 - 46 - 222 48 16; e-ma',
73653 &'il: torbjorn@thep.lu.se ',
73654 &'Author: Stephen Mrenna; Computing Di',
73655 &'vision, GDS Group, ',
73656 &' Fermi National Accelerator Laborat',
73657 &'ory, MS 234, Batavia, IL 60510, USA;'/
73658 DATA (refer(j),j=33,2*irefer)/
73659 &' phone: + 1 - 630 - 840 - 2556; e-m',
73660 &'ail: mrenna@fnal.gov ',
73661 &'Author: Peter Skands; Theoretical Ph',
73662 &'ysics Department, ',
73663 &' Fermi National Accelerator Laborat',
73664 &'ory, MS 106, Batavia, IL 60510, USA;',
73665 &' and CERN/PH, CH-1211 Geneva, Switz',
73666 &'erland; ',
73667 &' phone: + 41 - 22 - 767 24 59; e-ma',
73668 &'il: skands@fnal.gov '/
73669
73670C...Check that PYDATA linked.
73671 IF(mstp(183)/10.NE.199.AND.mstp(183)/10.NE.200) THEN
73672 WRITE(*,'(1X,A)')
73673 & 'Error: PYDATA has not been linked.'
73674 WRITE(*,'(1X,A)') 'Execution stopped!'
73675 CALL pystop(8)
73676
73677C...Write current version number and current date+time.
73678 ELSE
73679 WRITE(vers,'(I1)') mstp(181)
73680 logo(28)(24:24)=vers
73681 WRITE(subv,'(I3)') mstp(182)
73682 logo(28)(26:28)=subv
73683 IF(mstp(182).LT.100) logo(28)(26:26)='0'
73684 WRITE(date,'(I2)') mstp(185)
73685 logo(29)(22:23)=date
73686 logo(29)(25:27)=month(mstp(184))
73687 WRITE(year,'(I4)') mstp(183)
73688 logo(29)(29:32)=year
73689 CALL pytime(idati)
73690 IF(idati(1).LE.0) THEN
73691 logo(31)=' '
73692 ELSE
73693 WRITE(date,'(I2)') idati(3)
73694 logo(31)(8:9)=date
73695 logo(31)(11:13)=month(max(1,min(12,idati(2))))
73696 WRITE(year,'(I4)') idati(1)
73697 logo(31)(15:18)=year
73698 WRITE(hour,'(I2)') idati(4)
73699 logo(31)(23:24)=hour
73700 WRITE(minu,'(I2)') idati(5)
73701 logo(31)(26:27)=minu
73702 IF(idati(5).LT.10) logo(31)(26:26)='0'
73703 WRITE(seco,'(I2)') idati(6)
73704 logo(31)(29:30)=seco
73705 IF(idati(6).LT.10) logo(31)(29:29)='0'
73706 ENDIF
73707 ENDIF
73708
73709C...Loop over lines in header. Define page feed and side borders.
73710 DO 100 ilin=1,29+irefer
73711 line=' '
73712 IF(ilin.EQ.1) THEN
73713 line(1:1)='1'
73714 ELSE
73715 line(2:3)='**'
73716 line(78:79)='**'
73717 ENDIF
73718
73719C...Separator lines and logos.
73720 IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.GE.28+irefer) THEN
73721 line(4:77)='***********************************************'//
73722 & '***************************'
73723 ELSEIF(ilin.GE.6.AND.ilin.LE.24) THEN
73724 line(6:37)=logo(ilin-5)
73725 line(44:75)=logo(ilin+14)
73726 ELSEIF(ilin.GE.26.AND.ilin.LE.25+irefer) THEN
73727 line(5:40)=refer(2*ilin-51)
73728 line(41:76)=refer(2*ilin-50)
73729 ENDIF
73730
73731C...Write lines to appropriate unit.
73732 WRITE(mstu(11),'(A79)') line
73733 100 CONTINUE
73734
73735 RETURN
73736 END
73737
73738C*********************************************************************
73739
73740C...PYUPDA
73741C...Facilitates the updating of particle and decay data
73742C...by allowing it to be done in an external file.
73743
73744 SUBROUTINE pyupda(MUPDA,LFN)
73745
73746C...Double precision and integer declarations.
73747 IMPLICIT DOUBLE PRECISION(a-h, o-z)
73748 IMPLICIT INTEGER(I-N)
73749 INTEGER PYK,PYCHGE,PYCOMP
73750C...Commonblocks.
73751 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
73752 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
73753 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
73754 common/pydat4/chaf(500,2)
73755 CHARACTER CHAF*16
73756 common/pyint4/mwid(500),wids(500,5)
73757 SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pyint4/
73758C...Local arrays, character variables and data.
73759 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73760 &chblk(20)*72,chold*16,chtmp*16,chnew*16,chcom*24
73761 DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73762 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73763 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73764 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73765 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73766
73767C...Write header if not yet done.
73768 IF(mstu(12).NE.12345) CALL pylist(0)
73769
73770C...Write information on file for editing.
73771 IF(mupda.EQ.1) THEN
73772 DO 110 kc=1,500
73773 WRITE(lfn,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
73774 & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
73775 & mwid(kc),mdcy(kc,1)
73776 DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
73777 WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),
73778 & (kfdp(idc,j),j=1,5)
73779 100 CONTINUE
73780 110 CONTINUE
73781
73782C...Read complete set of information from edited file or
73783C...read partial set of new or updated information from edited file.
73784 ELSEIF(mupda.EQ.2.OR.mupda.EQ.3) THEN
73785
73786C...Reset counters.
73787 kcc=100
73788 ndc=0
73789 chkf=' '
73790 IF(mupda.EQ.2) THEN
73791 DO 120 i=1,mstu(6)
73792 kchg(i,4)=0
73793 120 CONTINUE
73794 ELSE
73795 DO 130 kc=1,mstu(6)
73796 IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc
73797 ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)
73798 130 CONTINUE
73799 ENDIF
73800
73801C...Begin of loop: read new line; unknown whether particle or
73802C...decay data.
73803 140 READ(lfn,5200,END=190) chinl
73804
73805C...Identify particle code and whether already defined (for MUPDA=3).
73806 IF(chinl(2:10).NE.' ') THEN
73807 chkf=chinl(2:10)
73808 READ(chkf,5300) kf
73809 IF(mupda.EQ.2) THEN
73810 IF(kf.LE.100) THEN
73811 kc=kf
73812 ELSE
73813 kcc=kcc+1
73814 kc=kcc
73815 ENDIF
73816 ELSE
73817 kcrep=0
73818 IF(kf.LE.100) THEN
73819 kcrep=kf
73820 ELSE
73821 DO 150 kcr=101,kcc
73822 IF(kchg(kcr,4).EQ.kf) kcrep=kcr
73823 150 CONTINUE
73824 ENDIF
73825C...Remove duplicate old decay data.
73826 IF(kcrep.NE.0.AND.mdcy(kcrep,3).GT.0) THEN
73827 idcrep=mdcy(kcrep,2)
73828 ndcrep=mdcy(kcrep,3)
73829 DO 160 i=1,kcc
73830 IF(mdcy(i,2).GT.idcrep) mdcy(i,2)=mdcy(i,2)-ndcrep
73831 160 CONTINUE
73832 DO 180 i=idcrep,ndc-ndcrep
73833 mdme(i,1)=mdme(i+ndcrep,1)
73834 mdme(i,2)=mdme(i+ndcrep,2)
73835 brat(i)=brat(i+ndcrep)
73836 DO 170 j=1,5
73837 kfdp(i,j)=kfdp(i+ndcrep,j)
73838 170 CONTINUE
73839 180 CONTINUE
73840 ndc=ndc-ndcrep
73841 kc=kcrep
73842 ELSEIF(kcrep.NE.0) THEN
73843 kc=kcrep
73844 ELSE
73845 kcc=kcc+1
73846 kc=kcc
73847 ENDIF
73848 ENDIF
73849
73850C...Study line with particle data.
73851 IF(kc.GT.mstu(6)) CALL pyerrm(27,
73852 & '(PYUPDA:) Particle arrays full by KF ='//chkf)
73853 READ(chinl,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),
73854 & (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),
73855 & mwid(kc),mdcy(kc,1)
73856 mdcy(kc,2)=0
73857 mdcy(kc,3)=0
73858
73859C...Study line with decay data.
73860 ELSE
73861 ndc=ndc+1
73862 IF(ndc.GT.mstu(7)) CALL pyerrm(27,
73863 & '(PYUPDA:) Decay data arrays full by KF ='//chkf)
73864 IF(mdcy(kc,2).EQ.0) mdcy(kc,2)=ndc
73865 mdcy(kc,3)=mdcy(kc,3)+1
73866 READ(chinl,5100) mdme(ndc,1),mdme(ndc,2),brat(ndc),
73867 & (kfdp(ndc,j),j=1,5)
73868 ENDIF
73869
73870C...End of loop; ensure that PYCOMP tables are updated.
73871 GOTO 140
73872 190 CONTINUE
73873 mstu(20)=0
73874
73875C...Perform possible tests that new information is consistent.
73876 DO 220 kc=1,mstu(6)
73877 kf=kchg(kc,4)
73878 IF(kf.EQ.0) GOTO 220
73879 WRITE(chkf,5300) kf
73880 IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),
73881 & pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0) CALL pyerrm(17,
73882 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//chkf)
73883 brsum=0d0
73884 DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1
73885 IF(mdme(idc,2).GT.80) GOTO 210
73886 kq=kchg(kc,1)
73887 pms=pmas(kc,1)-pmas(kc,3)-parj(64)
73888 merr=0
73889 DO 200 j=1,5
73890 kp=kfdp(idc,j)
73891 IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN
73892 IF(kp.EQ.81) kq=0
73893 ELSEIF(pycomp(kp).EQ.0) THEN
73894 merr=3
73895 ELSE
73896 kq=kq-pychge(kp)
73897 kpc=pycomp(kp)
73898 pms=pms-pmas(kpc,1)
73899 IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),
73900 & pmas(kpc,3))
73901 ENDIF
73902 200 CONTINUE
73903 IF(kq.NE.0) merr=max(2,merr)
73904 IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)
73905 & merr=max(1,merr)
73906 IF(merr.EQ.3) CALL pyerrm(17,
73907 & '(PYUPDA:) Unknown particle code in decay of KF ='//chkf)
73908 IF(merr.EQ.2) CALL pyerrm(17,
73909 & '(PYUPDA:) Charge not conserved in decay of KF ='//chkf)
73910 IF(merr.EQ.1) CALL pyerrm(7,
73911 & '(PYUPDA:) Kinematically unallowed decay of KF ='//chkf)
73912 brsum=brsum+brat(idc)
73913 210 CONTINUE
73914 WRITE(chtmp,5500) brsum
73915 IF(abs(brsum).GT.0.0005d0.AND.abs(brsum-1d0).GT.0.0005d0)
73916 & CALL pyerrm(7,'(PYUPDA:) Sum of branching ratios is '//
73917 & chtmp(9:16)//' for KF ='//chkf)
73918 220 CONTINUE
73919
73920C...Write DATA statements for inclusion in program.
73921 ELSEIF(mupda.EQ.4) THEN
73922
73923C...Find out how many codes and decay channels are actually used.
73924 kcc=0
73925 ndc=0
73926 DO 230 i=1,mstu(6)
73927 IF(kchg(i,4).NE.0) THEN
73928 kcc=i
73929 ndc=max(ndc,mdcy(i,2)+mdcy(i,3)-1)
73930 ENDIF
73931 230 CONTINUE
73932
73933C...Initialize writing of DATA statements for inclusion in program.
73934 DO 300 ivar=1,22
73935 ndim=mstu(6)
73936 IF(ivar.GE.12.AND.ivar.LE.19) ndim=mstu(7)
73937 nlin=1
73938 chlin=' '
73939 chlin(7:35)='DATA ('//chvar(ivar)//',I= 1, )/'
73940 llin=35
73941 chold='START'
73942
73943C...Loop through variables for conversion to characters.
73944 DO 280 idim=1,ndim
73945 IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)
73946 IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)
73947 IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)
73948 IF(ivar.EQ.4) WRITE(chtmp,5400) kchg(idim,4)
73949 IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,1)
73950 IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,2)
73951 IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,3)
73952 IF(ivar.EQ.8) WRITE(chtmp,5500) pmas(idim,4)
73953 IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,1)
73954 IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,2)
73955 IF(ivar.EQ.11) WRITE(chtmp,5400) mdcy(idim,3)
73956 IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,1)
73957 IF(ivar.EQ.13) WRITE(chtmp,5400) mdme(idim,2)
73958 IF(ivar.EQ.14) WRITE(chtmp,5600) brat(idim)
73959 IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,1)
73960 IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,2)
73961 IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,3)
73962 IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,4)
73963 IF(ivar.EQ.19) WRITE(chtmp,5400) kfdp(idim,5)
73964 IF(ivar.EQ.20) chtmp=chaf(idim,1)
73965 IF(ivar.EQ.21) chtmp=chaf(idim,2)
73966 IF(ivar.EQ.22) WRITE(chtmp,5400) mwid(idim)
73967
73968C...Replace variables beyond what is properly defined.
73969 IF(ivar.LE.4) THEN
73970 IF(idim.GT.kcc) chtmp=' 0'
73971 ELSEIF(ivar.LE.8) THEN
73972 IF(idim.GT.kcc) chtmp=' 0.0'
73973 ELSEIF(ivar.LE.11) THEN
73974 IF(idim.GT.kcc) chtmp=' 0'
73975 ELSEIF(ivar.LE.13) THEN
73976 IF(idim.GT.ndc) chtmp=' 0'
73977 ELSEIF(ivar.LE.14) THEN
73978 IF(idim.GT.ndc) chtmp=' 0.0'
73979 ELSEIF(ivar.LE.19) THEN
73980 IF(idim.GT.ndc) chtmp=' 0'
73981 ELSEIF(ivar.LE.21) THEN
73982 IF(idim.GT.kcc) chtmp=' '
73983 ELSE
73984 IF(idim.GT.kcc) chtmp=' 0'
73985 ENDIF
73986
73987C...Length of variable, trailing decimal zeros, quotation marks.
73988 llow=1
73989 lhig=1
73990 DO 240 ll=1,16
73991 IF(chtmp(17-ll:17-ll).NE.' ') llow=17-ll
73992 IF(chtmp(ll:ll).NE.' ') lhig=ll
73993 240 CONTINUE
73994 chnew=chtmp(llow:lhig)//' '
73995 lnew=1+lhig-llow
73996 IF((ivar.GE.5.AND.ivar.LE.8).OR.ivar.EQ.14) THEN
73997 lnew=lnew+1
73998 250 lnew=lnew-1
73999 IF(lnew.GE.2.AND.chnew(lnew:lnew).EQ.'0') GOTO 250
74000 IF(chnew(lnew:lnew).EQ.'.') lnew=lnew-1
74001 IF(lnew.EQ.0) THEN
74002 chnew(1:3)='0D0'
74003 lnew=3
74004 ELSE
74005 chnew(lnew+1:lnew+2)='D0'
74006 lnew=lnew+2
74007 ENDIF
74008 ELSEIF(ivar.EQ.20.OR.ivar.EQ.21) THEN
74009 DO 260 ll=lnew,1,-1
74010 IF(chnew(ll:ll).EQ.'''') THEN
74011 chtmp=chnew
74012 chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)
74013 lnew=lnew+1
74014 ENDIF
74015 260 CONTINUE
74016 lnew=min(14,lnew)
74017 chtmp=chnew
74018 chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''
74019 lnew=lnew+2
74020 ENDIF
74021
74022C...Form composite character string, often including repetition counter.
74023 IF(chnew.NE.chold) THEN
74024 nrpt=1
74025 chold=chnew
74026 chcom=chnew
74027 lcom=lnew
74028 ELSE
74029 lrpt=lnew+1
74030 IF(nrpt.GE.2) lrpt=lnew+3
74031 IF(nrpt.GE.10) lrpt=lnew+4
74032 IF(nrpt.GE.100) lrpt=lnew+5
74033 IF(nrpt.GE.1000) lrpt=lnew+6
74034 llin=llin-lrpt
74035 nrpt=nrpt+1
74036 WRITE(chtmp,5400) nrpt
74037 lrpt=1
74038 IF(nrpt.GE.10) lrpt=2
74039 IF(nrpt.GE.100) lrpt=3
74040 IF(nrpt.GE.1000) lrpt=4
74041 chcom(1:lrpt+1+lnew)=chtmp(17-lrpt:16)//'*'//chnew(1:lnew)
74042 lcom=lrpt+1+lnew
74043 ENDIF
74044
74045C...Add characters to end of line, to new line (after storing old line),
74046C...or to new block of lines (after writing old block).
74047 IF(llin+lcom.LE.70) THEN
74048 chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','
74049 llin=llin+lcom+1
74050 ELSEIF(nlin.LE.19) THEN
74051 chlin(llin+1:72)=' '
74052 chblk(nlin)=chlin
74053 nlin=nlin+1
74054 chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','
74055 llin=6+lcom+1
74056 ELSE
74057 chlin(llin:72)='/'//' '
74058 chblk(nlin)=chlin
74059 WRITE(chtmp,5400) idim-nrpt
74060 chblk(1)(30:33)=chtmp(13:16)
74061 DO 270 ilin=1,nlin
74062 WRITE(lfn,5700) chblk(ilin)
74063 270 CONTINUE
74064 nlin=1
74065 chlin=' '
74066 chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//
74067 & ',I= , )/'//chcom(1:lcom)//','
74068 WRITE(chtmp,5400) idim-nrpt+1
74069 chlin(25:28)=chtmp(13:16)
74070 llin=35+lcom+1
74071 ENDIF
74072 280 CONTINUE
74073
74074C...Write final block of lines.
74075 chlin(llin:72)='/'//' '
74076 chblk(nlin)=chlin
74077 WRITE(chtmp,5400) ndim
74078 chblk(1)(30:33)=chtmp(13:16)
74079 DO 290 ilin=1,nlin
74080 WRITE(lfn,5700) chblk(ilin)
74081 290 CONTINUE
74082 300 CONTINUE
74083 ENDIF
74084
74085C...Formats for reading and writing particle data.
74086 5000 FORMAT(1x,i9,2x,a16,2x,a16,3i3,3f12.5,1p,e13.5,2i3)
74087 5100 FORMAT(10x,2i5,f12.6,5i10)
74088 5200 FORMAT(a120)
74089 5300 FORMAT(i9)
74090 5400 FORMAT(i16)
74091 5500 FORMAT(f16.5)
74092 5600 FORMAT(f16.6)
74093 5700 FORMAT(a72)
74094
74095 RETURN
74096 END
74097
74098C*********************************************************************
74099
74100C...PYK
74101C...Provides various integer-valued event related data.
74102
74103 FUNCTION pyk(I,J)
74104
74105C...Double precision and integer declarations.
74106 IMPLICIT DOUBLE PRECISION(a-h, o-z)
74107 IMPLICIT INTEGER(I-N)
74108 INTEGER PYK,PYCHGE,PYCOMP
74109C...Commonblocks.
74110 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74111 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74112 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74113 SAVE /pyjets/,/pydat1/,/pydat2/
74114
74115C...Default value. For I=0 number of entries, number of stable entries
74116C...or 3 times total charge.
74117 pyk=0
74118 IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
74119 ELSEIF(i.EQ.0.AND.j.EQ.1) THEN
74120 pyk=n
74121 ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN
74122 DO 100 i1=1,n
74123 IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+1
74124 IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+
74125 & pychge(k(i1,2))
74126 100 CONTINUE
74127 ELSEIF(i.EQ.0) THEN
74128
74129C...For I > 0 direct readout of K matrix or charge.
74130 ELSEIF(j.LE.5) THEN
74131 pyk=k(i,j)
74132 ELSEIF(j.EQ.6) THEN
74133 pyk=pychge(k(i,2))
74134
74135C...Status (existing/fragmented/decayed), parton/hadron separation.
74136 ELSEIF(j.LE.8) THEN
74137 IF(k(i,1).GE.1.AND.k(i,1).LE.10) pyk=1
74138 IF(j.EQ.8) pyk=pyk*k(i,2)
74139 ELSEIF(j.LE.12) THEN
74140 kfa=iabs(k(i,2))
74141 kc=pycomp(kfa)
74142 kq=0
74143 IF(kc.NE.0) kq=kchg(kc,2)
74144 IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) pyk=k(i,2)
74145 IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) pyk=k(i,2)
74146 IF(j.EQ.11) pyk=kc
74147 IF(j.EQ.12) pyk=kq*isign(1,k(i,2))
74148
74149C...Heaviest flavour in hadron/diquark.
74150 ELSEIF(j.EQ.13) THEN
74151 kfa=iabs(k(i,2))
74152 pyk=mod(kfa/100,10)*(-1)**mod(kfa/100,10)
74153 IF(kfa.LT.10) pyk=kfa
74154 IF(mod(kfa/1000,10).NE.0) pyk=mod(kfa/1000,10)
74155 pyk=pyk*isign(1,k(i,2))
74156
74157C...Particle history: generation, ancestor, rank.
74158 ELSEIF(j.LE.15) THEN
74159 i2=i
74160 i1=i
74161 110 pyk=pyk+1
74162 i2=i1
74163 i1=k(i1,3)
74164 IF(i1.GT.0) THEN
74165 IF(k(i1,1).GT.0.AND.k(i1,1).LE.20) GOTO 110
74166 ENDIF
74167 IF(j.EQ.15) pyk=i2
74168 ELSEIF(j.EQ.16) THEN
74169 kfa=iabs(k(i,2))
74170 IF(k(i,1).LE.20.AND.((kfa.GE.11.AND.kfa.LE.20).OR.kfa.EQ.22.OR.
74171 & (kfa.GT.100.AND.mod(kfa/10,10).NE.0))) THEN
74172 i1=i
74173 120 i2=i1
74174 i1=k(i1,3)
74175 IF(i1.GT.0) THEN
74176 kfam=iabs(k(i1,2))
74177 ilp=1
74178 IF(kfam.NE.0.AND.kfam.LE.10) ilp=0
74179 IF(kfam.EQ.21.OR.kfam.EQ.91.OR.kfam.EQ.92.OR.kfam.EQ.93)
74180 & ilp=0
74181 IF(kfam.GT.100.AND.mod(kfam/10,10).EQ.0) ilp=0
74182 IF(ilp.EQ.1) GOTO 120
74183 ENDIF
74184 IF(k(i1,1).EQ.12) THEN
74185 DO 130 i3=i1+1,i2
74186 IF(k(i3,3).EQ.k(i2,3).AND.k(i3,2).NE.91.AND.k(i3,2).NE.92
74187 & .AND.k(i3,2).NE.93) pyk=pyk+1
74188 130 CONTINUE
74189 ELSE
74190 i3=i2
74191 140 pyk=pyk+1
74192 i3=i3+1
74193 IF(i3.LT.n.AND.k(i3,3).EQ.k(i2,3)) GOTO 140
74194 ENDIF
74195 ENDIF
74196
74197C...Particle coming from collapsing jet system or not.
74198 ELSEIF(j.EQ.17) THEN
74199 i1=i
74200 150 pyk=pyk+1
74201 i3=i1
74202 i1=k(i1,3)
74203 i0=max(1,i1)
74204 kc=pycomp(k(i0,2))
74205 IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN
74206 IF(pyk.EQ.1) pyk=-1
74207 IF(pyk.GT.1) pyk=0
74208 RETURN
74209 ENDIF
74210 IF(kchg(kc,2).EQ.0) GOTO 150
74211 IF(k(i1,1).NE.12) pyk=0
74212 IF(k(i1,1).NE.12) RETURN
74213 i2=i1
74214 160 i2=i2+1
74215 IF(i2.LT.n.AND.k(i2,1).NE.11) GOTO 160
74216 k3m=k(i3-1,3)
74217 IF(k3m.GE.i1.AND.k3m.LE.i2) pyk=0
74218 k3p=k(i3+1,3)
74219 IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) pyk=0
74220
74221C...Number of decay products. Colour flow.
74222 ELSEIF(j.EQ.18) THEN
74223 IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) pyk=max(0,k(i,5)-k(i,4)+1)
74224 IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) pyk=0
74225 ELSEIF(j.LE.22) THEN
74226 IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN
74227 IF(j.EQ.19) pyk=mod(k(i,4)/mstu(5),mstu(5))
74228 IF(j.EQ.20) pyk=mod(k(i,5)/mstu(5),mstu(5))
74229 IF(j.EQ.21) pyk=mod(k(i,4),mstu(5))
74230 IF(j.EQ.22) pyk=mod(k(i,5),mstu(5))
74231 ELSE
74232 ENDIF
74233
74234 RETURN
74235 END
74236
74237C*********************************************************************
74238
74239C...PYP
74240C...Provides various real-valued event related data.
74241
74242 FUNCTION pyp(I,J)
74243
74244C...Double precision and integer declarations.
74245 IMPLICIT DOUBLE PRECISION(a-h, o-z)
74246 IMPLICIT INTEGER(I-N)
74247 INTEGER PYK,PYCHGE,PYCOMP
74248C...Commonblocks.
74249 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74250 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74251 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74252 SAVE /pyjets/,/pydat1/,/pydat2/
74253C...Local array.
74254 dimension psum(4)
74255
74256C...Set default value. For I = 0 sum of momenta or charges,
74257C...or invariant mass of system.
74258 pyp=0d0
74259 IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN
74260 ELSEIF(i.EQ.0.AND.j.LE.4) THEN
74261 DO 100 i1=1,n
74262 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+p(i1,j)
74263 100 CONTINUE
74264 ELSEIF(i.EQ.0.AND.j.EQ.5) THEN
74265 DO 120 j1=1,4
74266 psum(j1)=0d0
74267 DO 110 i1=1,n
74268 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+
74269 & p(i1,j1)
74270 110 CONTINUE
74271 120 CONTINUE
74272 pyp=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))
74273 ELSEIF(i.EQ.0.AND.j.EQ.6) THEN
74274 DO 130 i1=1,n
74275 IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+pychge(k(i1,2))/3d0
74276 130 CONTINUE
74277 ELSEIF(i.EQ.0) THEN
74278
74279C...Direct readout of P matrix.
74280 ELSEIF(j.LE.5) THEN
74281 pyp=p(i,j)
74282
74283C...Charge, total momentum, transverse momentum, transverse mass.
74284 ELSEIF(j.LE.12) THEN
74285 IF(j.EQ.6) pyp=pychge(k(i,2))/3d0
74286 IF(j.EQ.7.OR.j.EQ.8) pyp=p(i,1)**2+p(i,2)**2+p(i,3)**2
74287 IF(j.EQ.9.OR.j.EQ.10) pyp=p(i,1)**2+p(i,2)**2
74288 IF(j.EQ.11.OR.j.EQ.12) pyp=p(i,5)**2+p(i,1)**2+p(i,2)**2
74289 IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) pyp=sqrt(pyp)
74290
74291C...Theta and phi angle in radians or degrees.
74292 ELSEIF(j.LE.16) THEN
74293 IF(j.LE.14) pyp=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))
74294 IF(j.GE.15) pyp=pyangl(p(i,1),p(i,2))
74295 IF(j.EQ.14.OR.j.EQ.16) pyp=pyp*180d0/paru(1)
74296
74297C...True rapidity, rapidity with pion mass, pseudorapidity.
74298 ELSEIF(j.LE.19) THEN
74299 pmr=0d0
74300 IF(j.EQ.17) pmr=p(i,5)
74301 IF(j.EQ.18) pmr=pymass(211)
74302 pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
74303 pyp=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
74304 & 1d20)),p(i,3))
74305
74306C...Energy and momentum fractions (only to be used in CM frame).
74307 ELSEIF(j.LE.25) THEN
74308 IF(j.EQ.20) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)
74309 IF(j.EQ.21) pyp=2d0*p(i,3)/paru(21)
74310 IF(j.EQ.22) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)
74311 IF(j.EQ.23) pyp=2d0*p(i,4)/paru(21)
74312 IF(j.EQ.24) pyp=(p(i,4)+p(i,3))/paru(21)
74313 IF(j.EQ.25) pyp=(p(i,4)-p(i,3))/paru(21)
74314 ENDIF
74315
74316 RETURN
74317 END
74318
74319C*********************************************************************
74320
74321C...PYSPHE
74322C...Performs sphericity tensor analysis to give sphericity,
74323C...aplanarity and the related event axes.
74324
74325 SUBROUTINE pysphe(SPH,APL)
74326
74327C...Double precision and integer declarations.
74328 IMPLICIT DOUBLE PRECISION(a-h, o-z)
74329 IMPLICIT INTEGER(I-N)
74330 INTEGER PYK,PYCHGE,PYCOMP
74331C...Parameter statement to help give large particle numbers.
74332 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
74333 &kexcit=4000000,kdimen=5000000)
74334C...Commonblocks.
74335 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74336 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74337 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74338 SAVE /pyjets/,/pydat1/,/pydat2/
74339C...Local arrays.
74340 dimension sm(3,3),sv(3,3)
74341
74342C...Calculate matrix to be diagonalized.
74343 np=0
74344 DO 110 j1=1,3
74345 DO 100 j2=j1,3
74346 sm(j1,j2)=0d0
74347 100 CONTINUE
74348 110 CONTINUE
74349 ps=0d0
74350 DO 140 i=1,n
74351 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
74352 IF(mstu(41).GE.2) THEN
74353 kc=pycomp(k(i,2))
74354 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
74355 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
74356 & k(i,2).EQ.ksusy1+39) GOTO 140
74357 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
74358 & GOTO 140
74359 ENDIF
74360 np=np+1
74361 pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74362 pwt=1d0
74363 IF(abs(paru(41)-2d0).GT.0.001d0) pwt=
74364 & max(1d-10,pa)**(paru(41)-2d0)
74365 DO 130 j1=1,3
74366 DO 120 j2=j1,3
74367 sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)
74368 120 CONTINUE
74369 130 CONTINUE
74370 ps=ps+pwt*pa**2
74371 140 CONTINUE
74372
74373C...Very low multiplicities (0 or 1) not considered.
74374 IF(np.LE.1) THEN
74375 CALL pyerrm(8,'(PYSPHE:) too few particles for analysis')
74376 sph=-1d0
74377 apl=-1d0
74378 RETURN
74379 ENDIF
74380 DO 160 j1=1,3
74381 DO 150 j2=j1,3
74382 sm(j1,j2)=sm(j1,j2)/ps
74383 150 CONTINUE
74384 160 CONTINUE
74385
74386C...Find eigenvalues to matrix (third degree equation).
74387 sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
74388 &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
74389 sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
74390 &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
74391 &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
74392 sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
74393 p(n+1,4)=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
74394 p(n+3,4)=1d0/3d0+sqrt(-sq)*min(2d0*sp,-sqrt(3d0*(1d0-sp**2))-sp)
74395 p(n+2,4)=1d0-p(n+1,4)-p(n+3,4)
74396 IF(p(n+2,4).LT.1d-5) THEN
74397 CALL pyerrm(8,'(PYSPHE:) all particles back-to-back')
74398 sph=-1d0
74399 apl=-1d0
74400 RETURN
74401 ENDIF
74402
74403C...Find first and last eigenvector by solving equation system.
74404 DO 240 i=1,3,2
74405 DO 180 j1=1,3
74406 sv(j1,j1)=sm(j1,j1)-p(n+i,4)
74407 DO 170 j2=j1+1,3
74408 sv(j1,j2)=sm(j1,j2)
74409 sv(j2,j1)=sm(j1,j2)
74410 170 CONTINUE
74411 180 CONTINUE
74412 smax=0d0
74413 DO 200 j1=1,3
74414 DO 190 j2=1,3
74415 IF(abs(sv(j1,j2)).LE.smax) GOTO 190
74416 ja=j1
74417 jb=j2
74418 smax=abs(sv(j1,j2))
74419 190 CONTINUE
74420 200 CONTINUE
74421 smax=0d0
74422 DO 220 j3=ja+1,ja+2
74423 j1=j3-3*((j3-1)/3)
74424 rl=sv(j1,jb)/sv(ja,jb)
74425 DO 210 j2=1,3
74426 sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)
74427 IF(abs(sv(j1,j2)).LE.smax) GOTO 210
74428 jc=j1
74429 smax=abs(sv(j1,j2))
74430 210 CONTINUE
74431 220 CONTINUE
74432 jb1=jb+1-3*(jb/3)
74433 jb2=jb+2-3*((jb+1)/3)
74434 p(n+i,jb1)=-sv(jc,jb2)
74435 p(n+i,jb2)=sv(jc,jb1)
74436 p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/
74437 & sv(ja,jb)
74438 pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)
74439 sgn=(-1d0)**int(pyr(0)+0.5d0)
74440 DO 230 j=1,3
74441 p(n+i,j)=sgn*p(n+i,j)/pa
74442 230 CONTINUE
74443 240 CONTINUE
74444
74445C...Middle axis orthogonal to other two. Fill other codes.
74446 sgn=(-1d0)**int(pyr(0)+0.5d0)
74447 p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))
74448 p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))
74449 p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))
74450 DO 260 i=1,3
74451 k(n+i,1)=31
74452 k(n+i,2)=95
74453 k(n+i,3)=i
74454 k(n+i,4)=0
74455 k(n+i,5)=0
74456 p(n+i,5)=0d0
74457 DO 250 j=1,5
74458 v(i,j)=0d0
74459 250 CONTINUE
74460 260 CONTINUE
74461
74462C...Calculate sphericity and aplanarity. Select storing option.
74463 sph=1.5d0*(p(n+2,4)+p(n+3,4))
74464 apl=1.5d0*p(n+3,4)
74465 mstu(61)=n+1
74466 mstu(62)=np
74467 IF(mstu(43).LE.1) mstu(3)=3
74468 IF(mstu(43).GE.2) n=n+3
74469
74470 RETURN
74471 END
74472
74473C*********************************************************************
74474
74475C...PYTHRU
74476C...Performs thrust analysis to give thrust, oblateness
74477C...and the related event axes.
74478
74479 SUBROUTINE pythru(THR,OBL)
74480
74481C...Double precision and integer declarations.
74482 IMPLICIT DOUBLE PRECISION(a-h, o-z)
74483 IMPLICIT INTEGER(I-N)
74484 INTEGER PYK,PYCHGE,PYCOMP
74485C...Parameter statement to help give large particle numbers.
74486 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
74487 &kexcit=4000000,kdimen=5000000)
74488C...Commonblocks.
74489 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74490 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74491 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74492 SAVE /pyjets/,/pydat1/,/pydat2/
74493C...Local arrays.
74494 dimension tdi(3),tpr(3)
74495
74496C...Take copy of particles that are to be considered in thrust analysis.
74497 np=0
74498 ps=0d0
74499 DO 100 i=1,n
74500 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 100
74501 IF(mstu(41).GE.2) THEN
74502 kc=pycomp(k(i,2))
74503 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
74504 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
74505 & k(i,2).EQ.ksusy1+39) GOTO 100
74506 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
74507 & GOTO 100
74508 ENDIF
74509 IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN
74510 CALL pyerrm(11,'(PYTHRU:) no more memory left in PYJETS')
74511 thr=-2d0
74512 obl=-2d0
74513 RETURN
74514 ENDIF
74515 np=np+1
74516 k(n+np,1)=23
74517 p(n+np,1)=p(i,1)
74518 p(n+np,2)=p(i,2)
74519 p(n+np,3)=p(i,3)
74520 p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74521 p(n+np,5)=1d0
74522 IF(abs(paru(42)-1d0).GT.0.001d0) p(n+np,5)=
74523 & p(n+np,4)**(paru(42)-1d0)
74524 ps=ps+p(n+np,4)*p(n+np,5)
74525 100 CONTINUE
74526
74527C...Very low multiplicities (0 or 1) not considered.
74528 IF(np.LE.1) THEN
74529 CALL pyerrm(8,'(PYTHRU:) too few particles for analysis')
74530 thr=-1d0
74531 obl=-1d0
74532 RETURN
74533 ENDIF
74534
74535C...Loop over thrust and major. T axis along z direction in latter case.
74536 DO 320 ild=1,2
74537 IF(ild.EQ.2) THEN
74538 k(n+np+1,1)=31
74539 phi=pyangl(p(n+np+1,1),p(n+np+1,2))
74540 mstu(33)=1
74541 CALL pyrobo(n+1,n+np+1,0d0,-phi,0d0,0d0,0d0)
74542 the=pyangl(p(n+np+1,3),p(n+np+1,1))
74543 CALL pyrobo(n+1,n+np+1,-the,0d0,0d0,0d0,0d0)
74544 ENDIF
74545
74546C...Find and order particles with highest p (pT for major).
74547 DO 110 ilf=n+np+4,n+np+mstu(44)+4
74548 p(ilf,4)=0d0
74549 110 CONTINUE
74550 DO 160 i=n+1,n+np
74551 IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)
74552 DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1
74553 IF(p(i,4).LE.p(ilf,4)) GOTO 140
74554 DO 120 j=1,5
74555 p(ilf+1,j)=p(ilf,j)
74556 120 CONTINUE
74557 130 CONTINUE
74558 ilf=n+np+3
74559 140 DO 150 j=1,5
74560 p(ilf+1,j)=p(i,j)
74561 150 CONTINUE
74562 160 CONTINUE
74563
74564C...Find and order initial axes with highest thrust (major).
74565 DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15
74566 p(ilg,4)=0d0
74567 170 CONTINUE
74568 nc=2**(min(mstu(44),np)-1)
74569 DO 250 ilc=1,nc
74570 DO 180 j=1,3
74571 tdi(j)=0d0
74572 180 CONTINUE
74573 DO 200 ilf=1,min(mstu(44),np)
74574 sgn=p(n+np+ilf+3,5)
74575 IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn
74576 DO 190 j=1,4-ild
74577 tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)
74578 190 CONTINUE
74579 200 CONTINUE
74580 tds=tdi(1)**2+tdi(2)**2+tdi(3)**2
74581 DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1
74582 IF(tds.LE.p(ilg,4)) GOTO 230
74583 DO 210 j=1,4
74584 p(ilg+1,j)=p(ilg,j)
74585 210 CONTINUE
74586 220 CONTINUE
74587 ilg=n+np+mstu(44)+4
74588 230 DO 240 j=1,3
74589 p(ilg+1,j)=tdi(j)
74590 240 CONTINUE
74591 p(ilg+1,4)=tds
74592 250 CONTINUE
74593
74594C...Iterate direction of axis until stable maximum.
74595 p(n+np+ild,4)=0d0
74596 ilg=0
74597 260 ilg=ilg+1
74598 thp=0d0
74599 270 thps=thp
74600 DO 280 j=1,3
74601 IF(thp.LE.1d-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)
74602 IF(thp.GT.1d-10) tdi(j)=tpr(j)
74603 tpr(j)=0d0
74604 280 CONTINUE
74605 DO 300 i=n+1,n+np
74606 sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))
74607 DO 290 j=1,4-ild
74608 tpr(j)=tpr(j)+sgn*p(i,j)
74609 290 CONTINUE
74610 300 CONTINUE
74611 thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps
74612 IF(thp.GE.thps+paru(48)) GOTO 270
74613
74614C...Save good axis. Try new initial axis until a number of tries agree.
74615 IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) GOTO 260
74616 IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN
74617 iagr=0
74618 sgn=(-1d0)**int(pyr(0)+0.5d0)
74619 DO 310 j=1,3
74620 p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)
74621 310 CONTINUE
74622 p(n+np+ild,4)=thp
74623 p(n+np+ild,5)=0d0
74624 ENDIF
74625 iagr=iagr+1
74626 IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) GOTO 260
74627 320 CONTINUE
74628
74629C...Find minor axis and value by orthogonality.
74630 sgn=(-1d0)**int(pyr(0)+0.5d0)
74631 p(n+np+3,1)=-sgn*p(n+np+2,2)
74632 p(n+np+3,2)=sgn*p(n+np+2,1)
74633 p(n+np+3,3)=0d0
74634 thp=0d0
74635 DO 330 i=n+1,n+np
74636 thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))
74637 330 CONTINUE
74638 p(n+np+3,4)=thp/ps
74639 p(n+np+3,5)=0d0
74640
74641C...Fill axis information. Rotate back to original coordinate system.
74642 DO 350 ild=1,3
74643 k(n+ild,1)=31
74644 k(n+ild,2)=96
74645 k(n+ild,3)=ild
74646 k(n+ild,4)=0
74647 k(n+ild,5)=0
74648 DO 340 j=1,5
74649 p(n+ild,j)=p(n+np+ild,j)
74650 v(n+ild,j)=0d0
74651 340 CONTINUE
74652 350 CONTINUE
74653 CALL pyrobo(n+1,n+3,the,phi,0d0,0d0,0d0)
74654
74655C...Calculate thrust and oblateness. Select storing option.
74656 thr=p(n+1,4)
74657 obl=p(n+2,4)-p(n+3,4)
74658 mstu(61)=n+1
74659 mstu(62)=np
74660 IF(mstu(43).LE.1) mstu(3)=3
74661 IF(mstu(43).GE.2) n=n+3
74662
74663 RETURN
74664 END
74665
74666C*********************************************************************
74667
74668C...PYCLUS
74669C...Subdivides the particle content of an event into jets/clusters.
74670
74671 SUBROUTINE pyclus(NJET)
74672
74673C...Double precision and integer declarations.
74674 IMPLICIT DOUBLE PRECISION(a-h, o-z)
74675 IMPLICIT INTEGER(I-N)
74676 INTEGER PYK,PYCHGE,PYCOMP
74677C...Parameter statement to help give large particle numbers.
74678 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
74679 &kexcit=4000000,kdimen=5000000)
74680C...Commonblocks.
74681 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
74682 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
74683 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
74684 SAVE /pyjets/,/pydat1/,/pydat2/
74685C...Local arrays and saved variables.
74686 dimension ps(5)
74687 SAVE nsav,np,ps,pss,rinit,npre,nrem
74688
74689C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74690 r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-
74691 &p(i1,3)*p(i2,3))*2d0*p(i1,5)*p(i2,5)/(0.0001d0+p(i1,5)+p(i2,5))**2
74692 r2m(i1,i2)=2d0*p(i1,4)*p(i2,4)*(1d0-(p(i1,1)*p(i2,1)+p(i1,2)*
74693 &p(i2,2)+p(i1,3)*p(i2,3))/max(1d-10,p(i1,5)*p(i2,5)))
74694 r2d(i1,i2)=2d0*min(p(i1,4),p(i2,4))**2*(1d0-(p(i1,1)*p(i2,1)+
74695 &p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/max(1d-10,p(i1,5)*p(i2,5)))
74696
74697C...If first time, reset. If reentering, skip preliminaries.
74698 IF(mstu(48).LE.0) THEN
74699 np=0
74700 DO 100 j=1,5
74701 ps(j)=0d0
74702 100 CONTINUE
74703 pss=0d0
74704 pimass=pmas(pycomp(211),1)
74705 ELSE
74706 njet=nsav
74707 IF(mstu(43).GE.2) n=n-njet
74708 DO 110 i=n+1,n+njet
74709 p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74710 110 CONTINUE
74711 IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
74712 r2acc=paru(44)**2
74713 ELSE
74714 r2acc=paru(45)*ps(5)**2
74715 ENDIF
74716 nloop=0
74717 GOTO 300
74718 ENDIF
74719
74720C...Find which particles are to be considered in cluster search.
74721 DO 140 i=1,n
74722 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 140
74723 IF(mstu(41).GE.2) THEN
74724 kc=pycomp(k(i,2))
74725 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
74726 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
74727 & k(i,2).EQ.ksusy1+39) GOTO 140
74728 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
74729 & GOTO 140
74730 ENDIF
74731 IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN
74732 CALL pyerrm(11,'(PYCLUS:) no more memory left in PYJETS')
74733 njet=-1
74734 RETURN
74735 ENDIF
74736
74737C...Take copy of these particles, with space left for jets later on.
74738 np=np+1
74739 k(n+np,3)=i
74740 DO 120 j=1,5
74741 p(n+np,j)=p(i,j)
74742 120 CONTINUE
74743 IF(mstu(42).EQ.0) p(n+np,5)=0d0
74744 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
74745 p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
74746 p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74747 DO 130 j=1,4
74748 ps(j)=ps(j)+p(n+np,j)
74749 130 CONTINUE
74750 pss=pss+p(n+np,5)
74751 140 CONTINUE
74752 DO 160 i=n+1,n+np
74753 k(i+np,3)=k(i,3)
74754 DO 150 j=1,5
74755 p(i+np,j)=p(i,j)
74756 150 CONTINUE
74757 160 CONTINUE
74758 ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))
74759
74760C...Very low multiplicities not considered.
74761 IF(np.LT.mstu(47)) THEN
74762 CALL pyerrm(8,'(PYCLUS:) too few particles for analysis')
74763 njet=-1
74764 RETURN
74765 ENDIF
74766
74767C...Find precluster configuration. If too few jets, make harder cuts.
74768 nloop=0
74769 IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN
74770 r2acc=paru(44)**2
74771 ELSE
74772 r2acc=paru(45)*ps(5)**2
74773 ENDIF
74774 rinit=1.25d0*paru(43)
74775 IF(np.LE.mstu(47)+2) rinit=0d0
74776 170 rinit=0.8d0*rinit
74777 npre=0
74778 nrem=np
74779 DO 180 i=n+np+1,n+2*np
74780 k(i,4)=0
74781 180 CONTINUE
74782
74783C...Sum up small momentum region. Jet if enough absolute momentum.
74784 IF(mstu(46).LE.2) THEN
74785 DO 190 j=1,4
74786 p(n+1,j)=0d0
74787 190 CONTINUE
74788 DO 210 i=n+np+1,n+2*np
74789 IF(p(i,5).GT.2d0*rinit) GOTO 210
74790 nrem=nrem-1
74791 k(i,4)=1
74792 DO 200 j=1,4
74793 p(n+1,j)=p(n+1,j)+p(i,j)
74794 200 CONTINUE
74795 210 CONTINUE
74796 p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)
74797 IF(p(n+1,5).GT.2d0*rinit) npre=1
74798 IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 170
74799 IF(nrem.EQ.0) GOTO 170
74800 ENDIF
74801
74802C...Find fastest remaining particle.
74803 220 npre=npre+1
74804 pmax=0d0
74805 DO 230 i=n+np+1,n+2*np
74806 IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) GOTO 230
74807 imax=i
74808 pmax=p(i,5)
74809 230 CONTINUE
74810 DO 240 j=1,5
74811 p(n+npre,j)=p(imax,j)
74812 240 CONTINUE
74813 nrem=nrem-1
74814 k(imax,4)=npre
74815
74816C...Sum up precluster around it according to pT separation.
74817 IF(mstu(46).LE.2) THEN
74818 DO 260 i=n+np+1,n+2*np
74819 IF(k(i,4).NE.0) GOTO 260
74820 r2=r2t(i,imax)
74821 IF(r2.GT.rinit**2) GOTO 260
74822 nrem=nrem-1
74823 k(i,4)=npre
74824 DO 250 j=1,4
74825 p(n+npre,j)=p(n+npre,j)+p(i,j)
74826 250 CONTINUE
74827 260 CONTINUE
74828 p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
74829
74830C...Sum up precluster around it according to mass or
74831C...Durham pT separation.
74832 ELSE
74833 270 imin=0
74834 r2min=rinit**2
74835 DO 280 i=n+np+1,n+2*np
74836 IF(k(i,4).NE.0) GOTO 280
74837 IF(mstu(46).LE.4) THEN
74838 r2=r2m(i,n+npre)
74839 ELSE
74840 r2=r2d(i,n+npre)
74841 ENDIF
74842 IF(r2.GE.r2min) GOTO 280
74843 imin=i
74844 r2min=r2
74845 280 CONTINUE
74846 IF(imin.NE.0) THEN
74847 DO 290 j=1,4
74848 p(n+npre,j)=p(n+npre,j)+p(imin,j)
74849 290 CONTINUE
74850 p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)
74851 nrem=nrem-1
74852 k(imin,4)=npre
74853 GOTO 270
74854 ENDIF
74855 ENDIF
74856
74857C...Check if more preclusters to be found. Start over if too few.
74858 IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) GOTO 170
74859 IF(nrem.GT.0) GOTO 220
74860 njet=npre
74861
74862C...Reassign all particles to nearest jet. Sum up new jet momenta.
74863 300 tsav=0d0
74864 psjt=0d0
74865 310 IF(mstu(46).LE.1) THEN
74866 DO 330 i=n+1,n+njet
74867 DO 320 j=1,4
74868 v(i,j)=0d0
74869 320 CONTINUE
74870 330 CONTINUE
74871 DO 360 i=n+np+1,n+2*np
74872 r2min=pss**2
74873 DO 340 ijet=n+1,n+njet
74874 IF(p(ijet,5).LT.rinit) GOTO 340
74875 r2=r2t(i,ijet)
74876 IF(r2.GE.r2min) GOTO 340
74877 imin=ijet
74878 r2min=r2
74879 340 CONTINUE
74880 k(i,4)=imin-n
74881 DO 350 j=1,4
74882 v(imin,j)=v(imin,j)+p(i,j)
74883 350 CONTINUE
74884 360 CONTINUE
74885 psjt=0d0
74886 DO 380 i=n+1,n+njet
74887 DO 370 j=1,4
74888 p(i,j)=v(i,j)
74889 370 CONTINUE
74890 p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
74891 psjt=psjt+p(i,5)
74892 380 CONTINUE
74893 ENDIF
74894
74895C...Find two closest jets.
74896 r2min=2d0*max(r2acc,ps(5)**2)
74897 DO 400 itry1=n+1,n+njet-1
74898 DO 390 itry2=itry1+1,n+njet
74899 IF(mstu(46).LE.2) THEN
74900 r2=r2t(itry1,itry2)
74901 ELSEIF(mstu(46).LE.4) THEN
74902 r2=r2m(itry1,itry2)
74903 ELSE
74904 r2=r2d(itry1,itry2)
74905 ENDIF
74906 IF(r2.GE.r2min) GOTO 390
74907 imin1=itry1
74908 imin2=itry2
74909 r2min=r2
74910 390 CONTINUE
74911 400 CONTINUE
74912
74913C...If allowed, join two closest jets and start over.
74914 IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN
74915 irec=min(imin1,imin2)
74916 idel=max(imin1,imin2)
74917 DO 410 j=1,4
74918 p(irec,j)=p(imin1,j)+p(imin2,j)
74919 410 CONTINUE
74920 p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)
74921 DO 430 i=idel+1,n+njet
74922 DO 420 j=1,5
74923 p(i-1,j)=p(i,j)
74924 420 CONTINUE
74925 430 CONTINUE
74926 IF(mstu(46).GE.2) THEN
74927 DO 440 i=n+np+1,n+2*np
74928 iori=n+k(i,4)
74929 IF(iori.EQ.idel) k(i,4)=irec-n
74930 IF(iori.GT.idel) k(i,4)=k(i,4)-1
74931 440 CONTINUE
74932 ENDIF
74933 njet=njet-1
74934 GOTO 300
74935
74936C...Divide up broad jet if empty cluster in list of final ones.
74937 ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN
74938 DO 450 i=n+1,n+njet
74939 k(i,5)=0
74940 450 CONTINUE
74941 DO 460 i=n+np+1,n+2*np
74942 k(n+k(i,4),5)=k(n+k(i,4),5)+1
74943 460 CONTINUE
74944 iemp=0
74945 DO 470 i=n+1,n+njet
74946 IF(k(i,5).EQ.0) iemp=i
74947 470 CONTINUE
74948 IF(iemp.NE.0) THEN
74949 nloop=nloop+1
74950 ispl=0
74951 r2max=0d0
74952 DO 480 i=n+np+1,n+2*np
74953 IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) GOTO 480
74954 ijet=n+k(i,4)
74955 r2=r2t(i,ijet)
74956 IF(r2.LE.r2max) GOTO 480
74957 ispl=i
74958 r2max=r2
74959 480 CONTINUE
74960 IF(ispl.NE.0) THEN
74961 ijet=n+k(ispl,4)
74962 DO 490 j=1,4
74963 p(iemp,j)=p(ispl,j)
74964 p(ijet,j)=p(ijet,j)-p(ispl,j)
74965 490 CONTINUE
74966 p(iemp,5)=p(ispl,5)
74967 p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)
74968 IF(nloop.LE.2) GOTO 300
74969 ENDIF
74970 ENDIF
74971 ENDIF
74972
74973C...If generalized thrust has not yet converged, continue iteration.
74974 IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))
74975 &THEN
74976 tsav=psjt/pss
74977 GOTO 310
74978 ENDIF
74979
74980C...Reorder jets according to energy.
74981 DO 510 i=n+1,n+njet
74982 DO 500 j=1,5
74983 v(i,j)=p(i,j)
74984 500 CONTINUE
74985 510 CONTINUE
74986 DO 540 inew=n+1,n+njet
74987 pemax=0d0
74988 DO 520 itry=n+1,n+njet
74989 IF(v(itry,4).LE.pemax) GOTO 520
74990 imax=itry
74991 pemax=v(itry,4)
74992 520 CONTINUE
74993 k(inew,1)=31
74994 k(inew,2)=97
74995 k(inew,3)=inew-n
74996 k(inew,4)=0
74997 DO 530 j=1,5
74998 p(inew,j)=v(imax,j)
74999 530 CONTINUE
75000 v(imax,4)=-1d0
75001 k(imax,5)=inew
75002 540 CONTINUE
75003
75004C...Clean up particle-jet assignments and jet information.
75005 DO 550 i=n+np+1,n+2*np
75006 iori=k(n+k(i,4),5)
75007 k(i,4)=iori-n
75008 IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n
75009 k(iori,4)=k(iori,4)+1
75010 550 CONTINUE
75011 iemp=0
75012 psjt=0d0
75013 DO 570 i=n+1,n+njet
75014 k(i,5)=0
75015 psjt=psjt+p(i,5)
75016 p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0d0))
75017 DO 560 j=1,5
75018 v(i,j)=0d0
75019 560 CONTINUE
75020 IF(k(i,4).EQ.0) iemp=i
75021 570 CONTINUE
75022
75023C...Select storing option. Output variables. Check for failure.
75024 mstu(61)=n+1
75025 mstu(62)=np
75026 mstu(63)=npre
75027 paru(61)=ps(5)
75028 paru(62)=psjt/pss
75029 paru(63)=sqrt(r2min)
75030 IF(njet.LE.1) paru(63)=0d0
75031 IF(iemp.NE.0) THEN
75032 CALL pyerrm(8,'(PYCLUS:) failed to reconstruct as requested')
75033 njet=-1
75034 RETURN
75035 ENDIF
75036 IF(mstu(43).LE.1) mstu(3)=max(0,njet)
75037 IF(mstu(43).GE.2) n=n+max(0,njet)
75038 nsav=njet
75039
75040 RETURN
75041 END
75042
75043C*********************************************************************
75044
75045C...PYCELL
75046C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75047C...as used for calorimeters at hadron colliders.
75048
75049 SUBROUTINE pycell(NJET)
75050
75051C...Double precision and integer declarations.
75052 IMPLICIT DOUBLE PRECISION(a-h, o-z)
75053 IMPLICIT INTEGER(I-N)
75054 INTEGER PYK,PYCHGE,PYCOMP
75055C...Parameter statement to help give large particle numbers.
75056 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75057 &kexcit=4000000,kdimen=5000000)
75058C...Commonblocks.
75059 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75060 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75061 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75062 SAVE /pyjets/,/pydat1/,/pydat2/
75063
75064C...Loop over all particles. Find cell that was hit by given particle.
75065 ptlrat=1d0/sinh(paru(51))**2
75066 np=0
75067 nc=n
75068 DO 110 i=1,n
75069 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
75070 IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) GOTO 110
75071 IF(mstu(41).GE.2) THEN
75072 kc=pycomp(k(i,2))
75073 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75074 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75075 & k(i,2).EQ.ksusy1+39) GOTO 110
75076 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
75077 & GOTO 110
75078 ENDIF
75079 np=np+1
75080 pt=sqrt(p(i,1)**2+p(i,2)**2)
75081 eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))
75082 ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5d0*
75083 & (eta/paru(51)+1d0))))
75084 phi=pyangl(p(i,1),p(i,2))
75085 iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5d0*
75086 & (phi/paru(1)+1d0))))
75087 ietph=mstu(52)*ieta+iphi
75088
75089C...Add to cell already hit, or book new cell.
75090 DO 100 ic=n+1,nc
75091 IF(ietph.EQ.k(ic,3)) THEN
75092 k(ic,4)=k(ic,4)+1
75093 p(ic,5)=p(ic,5)+pt
75094 GOTO 110
75095 ENDIF
75096 100 CONTINUE
75097 IF(nc.GE.mstu(4)-mstu(32)-5) THEN
75098 CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
75099 njet=-2
75100 RETURN
75101 ENDIF
75102 nc=nc+1
75103 k(nc,3)=ietph
75104 k(nc,4)=1
75105 k(nc,5)=2
75106 p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))
75107 p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))
75108 p(nc,5)=pt
75109 110 CONTINUE
75110
75111C...Smear true bin content by calorimeter resolution.
75112 IF(mstu(53).GE.1) THEN
75113 DO 130 ic=n+1,nc
75114 pei=p(ic,5)
75115 IF(mstu(53).EQ.2) pei=p(ic,5)*cosh(p(ic,1))
75116 120 pef=pei+paru(55)*sqrt(-2d0*log(max(1d-10,pyr(0)))*pei)*
75117 & cos(paru(2)*pyr(0))
75118 IF(pef.LT.0d0.OR.pef.GT.paru(56)*pei) GOTO 120
75119 p(ic,5)=pef
75120 IF(mstu(53).EQ.2) p(ic,5)=pef/cosh(p(ic,1))
75121 130 CONTINUE
75122 ENDIF
75123
75124C...Remove cells below threshold.
75125 IF(paru(58).GT.0d0) THEN
75126 ncc=nc
75127 nc=n
75128 DO 140 ic=n+1,ncc
75129 IF(p(ic,5).GT.paru(58)) THEN
75130 nc=nc+1
75131 k(nc,3)=k(ic,3)
75132 k(nc,4)=k(ic,4)
75133 k(nc,5)=k(ic,5)
75134 p(nc,1)=p(ic,1)
75135 p(nc,2)=p(ic,2)
75136 p(nc,5)=p(ic,5)
75137 ENDIF
75138 140 CONTINUE
75139 ENDIF
75140
75141C...Find initiator cell: the one with highest pT of not yet used ones.
75142 nj=nc
75143 150 etmax=0d0
75144 DO 160 ic=n+1,nc
75145 IF(k(ic,5).NE.2) GOTO 160
75146 IF(p(ic,5).LE.etmax) GOTO 160
75147 icmax=ic
75148 eta=p(ic,1)
75149 phi=p(ic,2)
75150 etmax=p(ic,5)
75151 160 CONTINUE
75152 IF(etmax.LT.paru(52)) GOTO 220
75153 IF(nj.GE.mstu(4)-mstu(32)-5) THEN
75154 CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')
75155 njet=-2
75156 RETURN
75157 ENDIF
75158 k(icmax,5)=1
75159 nj=nj+1
75160 k(nj,4)=0
75161 k(nj,5)=1
75162 p(nj,1)=eta
75163 p(nj,2)=phi
75164 p(nj,3)=0d0
75165 p(nj,4)=0d0
75166 p(nj,5)=0d0
75167
75168C...Sum up unused cells within required distance of initiator.
75169 DO 170 ic=n+1,nc
75170 IF(k(ic,5).EQ.0) GOTO 170
75171 IF(abs(p(ic,1)-eta).GT.paru(54)) GOTO 170
75172 dphia=abs(p(ic,2)-phi)
75173 IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) GOTO 170
75174 phic=p(ic,2)
75175 IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)
75176 IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) GOTO 170
75177 k(ic,5)=-k(ic,5)
75178 k(nj,4)=k(nj,4)+k(ic,4)
75179 p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)
75180 p(nj,4)=p(nj,4)+p(ic,5)*phic
75181 p(nj,5)=p(nj,5)+p(ic,5)
75182 170 CONTINUE
75183
75184C...Reject cluster below minimum ET, else accept.
75185 IF(p(nj,5).LT.paru(53)) THEN
75186 nj=nj-1
75187 DO 180 ic=n+1,nc
75188 IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)
75189 180 CONTINUE
75190 ELSEIF(mstu(54).LE.2) THEN
75191 p(nj,3)=p(nj,3)/p(nj,5)
75192 p(nj,4)=p(nj,4)/p(nj,5)
75193 IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),
75194 & p(nj,4))
75195 DO 190 ic=n+1,nc
75196 IF(k(ic,5).LT.0) k(ic,5)=0
75197 190 CONTINUE
75198 ELSE
75199 DO 200 j=1,4
75200 p(nj,j)=0d0
75201 200 CONTINUE
75202 DO 210 ic=n+1,nc
75203 IF(k(ic,5).GE.0) GOTO 210
75204 p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))
75205 p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))
75206 p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))
75207 p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))
75208 k(ic,5)=0
75209 210 CONTINUE
75210 ENDIF
75211 GOTO 150
75212
75213C...Arrange clusters in falling ET sequence.
75214 220 DO 250 i=1,nj-nc
75215 etmax=0d0
75216 DO 230 ij=nc+1,nj
75217 IF(k(ij,5).EQ.0) GOTO 230
75218 IF(p(ij,5).LT.etmax) GOTO 230
75219 ijmax=ij
75220 etmax=p(ij,5)
75221 230 CONTINUE
75222 k(ijmax,5)=0
75223 k(n+i,1)=31
75224 k(n+i,2)=98
75225 k(n+i,3)=i
75226 k(n+i,4)=k(ijmax,4)
75227 k(n+i,5)=0
75228 DO 240 j=1,5
75229 p(n+i,j)=p(ijmax,j)
75230 v(n+i,j)=0d0
75231 240 CONTINUE
75232 250 CONTINUE
75233 njet=nj-nc
75234
75235C...Convert to massless or massive four-vectors.
75236 IF(mstu(54).EQ.2) THEN
75237 DO 260 i=n+1,n+njet
75238 eta=p(i,3)
75239 p(i,1)=p(i,5)*cos(p(i,4))
75240 p(i,2)=p(i,5)*sin(p(i,4))
75241 p(i,3)=p(i,5)*sinh(eta)
75242 p(i,4)=p(i,5)*cosh(eta)
75243 p(i,5)=0d0
75244 260 CONTINUE
75245 ELSEIF(mstu(54).GE.3) THEN
75246 DO 270 i=n+1,n+njet
75247 p(i,5)=sqrt(max(0d0,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))
75248 270 CONTINUE
75249 ENDIF
75250
75251C...Information about storage.
75252 mstu(61)=n+1
75253 mstu(62)=np
75254 mstu(63)=nc-n
75255 IF(mstu(43).LE.1) mstu(3)=max(0,njet)
75256 IF(mstu(43).GE.2) n=n+max(0,njet)
75257
75258 RETURN
75259 END
75260
75261C*********************************************************************
75262
75263C...PYJMAS
75264C...Determines, approximately, the two jet masses that minimize
75265C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75266
75267 SUBROUTINE pyjmas(PMH,PML)
75268
75269C...Double precision and integer declarations.
75270 IMPLICIT DOUBLE PRECISION(a-h, o-z)
75271 IMPLICIT INTEGER(I-N)
75272 INTEGER PYK,PYCHGE,PYCOMP
75273C...Parameter statement to help give large particle numbers.
75274 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75275 &kexcit=4000000,kdimen=5000000)
75276C...Commonblocks.
75277 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75278 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75279 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75280 SAVE /pyjets/,/pydat1/,/pydat2/
75281C...Local arrays.
75282 dimension sm(3,3),sax(3),ps(3,5)
75283
75284C...Reset.
75285 np=0
75286 DO 120 j1=1,3
75287 DO 100 j2=j1,3
75288 sm(j1,j2)=0d0
75289 100 CONTINUE
75290 DO 110 j2=1,4
75291 ps(j1,j2)=0d0
75292 110 CONTINUE
75293 120 CONTINUE
75294 pss=0d0
75295 pimass=pmas(pycomp(211),1)
75296
75297C...Take copy of particles that are to be considered in mass analysis.
75298 DO 170 i=1,n
75299 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 170
75300 IF(mstu(41).GE.2) THEN
75301 kc=pycomp(k(i,2))
75302 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75303 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75304 & k(i,2).EQ.ksusy1+39) GOTO 170
75305 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
75306 & GOTO 170
75307 ENDIF
75308 IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN
75309 CALL pyerrm(11,'(PYJMAS:) no more memory left in PYJETS')
75310 pmh=-2d0
75311 pml=-2d0
75312 RETURN
75313 ENDIF
75314 np=np+1
75315 DO 130 j=1,5
75316 p(n+np,j)=p(i,j)
75317 130 CONTINUE
75318 IF(mstu(42).EQ.0) p(n+np,5)=0d0
75319 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass
75320 p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
75321
75322C...Fill information in sphericity tensor and total momentum vector.
75323 DO 150 j1=1,3
75324 DO 140 j2=j1,3
75325 sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)
75326 140 CONTINUE
75327 150 CONTINUE
75328 pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)
75329 DO 160 j=1,4
75330 ps(3,j)=ps(3,j)+p(n+np,j)
75331 160 CONTINUE
75332 170 CONTINUE
75333
75334C...Very low multiplicities (0 or 1) not considered.
75335 IF(np.LE.1) THEN
75336 CALL pyerrm(8,'(PYJMAS:) too few particles for analysis')
75337 pmh=-1d0
75338 pml=-1d0
75339 RETURN
75340 ENDIF
75341 paru(61)=sqrt(max(0d0,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-
75342 &ps(3,3)**2))
75343
75344C...Find largest eigenvalue to matrix (third degree equation).
75345 DO 190 j1=1,3
75346 DO 180 j2=j1,3
75347 sm(j1,j2)=sm(j1,j2)/pss
75348 180 CONTINUE
75349 190 CONTINUE
75350 sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-
75351 &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0
75352 sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+
75353 &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+
75354 &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0
75355 sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)
75356 sma=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)
75357
75358C...Find largest eigenvector by solving equation system.
75359 DO 210 j1=1,3
75360 sm(j1,j1)=sm(j1,j1)-sma
75361 DO 200 j2=j1+1,3
75362 sm(j2,j1)=sm(j1,j2)
75363 200 CONTINUE
75364 210 CONTINUE
75365 smax=0d0
75366 DO 230 j1=1,3
75367 DO 220 j2=1,3
75368 IF(abs(sm(j1,j2)).LE.smax) GOTO 220
75369 ja=j1
75370 jb=j2
75371 smax=abs(sm(j1,j2))
75372 220 CONTINUE
75373 230 CONTINUE
75374 smax=0d0
75375 DO 250 j3=ja+1,ja+2
75376 j1=j3-3*((j3-1)/3)
75377 rl=sm(j1,jb)/sm(ja,jb)
75378 DO 240 j2=1,3
75379 sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)
75380 IF(abs(sm(j1,j2)).LE.smax) GOTO 240
75381 jc=j1
75382 smax=abs(sm(j1,j2))
75383 240 CONTINUE
75384 250 CONTINUE
75385 jb1=jb+1-3*(jb/3)
75386 jb2=jb+2-3*((jb+1)/3)
75387 sax(jb1)=-sm(jc,jb2)
75388 sax(jb2)=sm(jc,jb1)
75389 sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)
75390
75391C...Divide particles into two initial clusters by hemisphere.
75392 DO 270 i=n+1,n+np
75393 psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)
75394 is=1
75395 IF(psax.LT.0d0) is=2
75396 k(i,3)=is
75397 DO 260 j=1,4
75398 ps(is,j)=ps(is,j)+p(i,j)
75399 260 CONTINUE
75400 270 CONTINUE
75401 pms=max(1d-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+
75402 &max(1d-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)
75403
75404C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75405 280 pmd=0d0
75406 im=0
75407 DO 290 j=1,4
75408 ps(3,j)=ps(1,j)-ps(2,j)
75409 290 CONTINUE
75410 DO 300 i=n+1,n+np
75411 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)
75412 IF(k(i,3).EQ.1) pmdi=2d0*(p(i,5)**2-pps)
75413 IF(k(i,3).EQ.2) pmdi=2d0*(p(i,5)**2+pps)
75414 IF(pmdi.LT.pmd) THEN
75415 pmd=pmdi
75416 im=i
75417 ENDIF
75418 300 CONTINUE
75419
75420C...Loop back if significant reduction in sum of m^2.
75421 IF(pmd.LT.-paru(48)*pms) THEN
75422 pms=pms+pmd
75423 is=k(im,3)
75424 DO 310 j=1,4
75425 ps(is,j)=ps(is,j)-p(im,j)
75426 ps(3-is,j)=ps(3-is,j)+p(im,j)
75427 310 CONTINUE
75428 k(im,3)=3-is
75429 GOTO 280
75430 ENDIF
75431
75432C...Final masses and output.
75433 mstu(61)=n+1
75434 mstu(62)=np
75435 ps(1,5)=sqrt(max(0d0,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))
75436 ps(2,5)=sqrt(max(0d0,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))
75437 pmh=max(ps(1,5),ps(2,5))
75438 pml=min(ps(1,5),ps(2,5))
75439
75440 RETURN
75441 END
75442
75443C*********************************************************************
75444
75445C...PYFOWO
75446C...Calculates the first few Fox-Wolfram moments.
75447
75448 SUBROUTINE pyfowo(H10,H20,H30,H40)
75449
75450C...Double precision and integer declarations.
75451 IMPLICIT DOUBLE PRECISION(a-h, o-z)
75452 IMPLICIT INTEGER(I-N)
75453 INTEGER PYK,PYCHGE,PYCOMP
75454C...Parameter statement to help give large particle numbers.
75455 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75456 &kexcit=4000000,kdimen=5000000)
75457C...Commonblocks.
75458 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75459 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75460 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75461 SAVE /pyjets/,/pydat1/,/pydat2/
75462
75463C...Copy momenta for particles and calculate H0.
75464 np=0
75465 h0=0d0
75466 hd=0d0
75467 DO 110 i=1,n
75468 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 110
75469 IF(mstu(41).GE.2) THEN
75470 kc=pycomp(k(i,2))
75471 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75472 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75473 & k(i,2).EQ.ksusy1+39) GOTO 110
75474 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)
75475 & GOTO 110
75476 ENDIF
75477 IF(n+np.GE.mstu(4)-mstu(32)-5) THEN
75478 CALL pyerrm(11,'(PYFOWO:) no more memory left in PYJETS')
75479 h10=-1d0
75480 h20=-1d0
75481 h30=-1d0
75482 h40=-1d0
75483 RETURN
75484 ENDIF
75485 np=np+1
75486 DO 100 j=1,3
75487 p(n+np,j)=p(i,j)
75488 100 CONTINUE
75489 p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)
75490 h0=h0+p(n+np,4)
75491 hd=hd+p(n+np,4)**2
75492 110 CONTINUE
75493 h0=h0**2
75494
75495C...Very low multiplicities (0 or 1) not considered.
75496 IF(np.LE.1) THEN
75497 CALL pyerrm(8,'(PYFOWO:) too few particles for analysis')
75498 h10=-1d0
75499 h20=-1d0
75500 h30=-1d0
75501 h40=-1d0
75502 RETURN
75503 ENDIF
75504
75505C...Calculate H1 - H4.
75506 h10=0d0
75507 h20=0d0
75508 h30=0d0
75509 h40=0d0
75510 DO 130 i1=n+1,n+np
75511 DO 120 i2=i1+1,n+np
75512 cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
75513 & (p(i1,4)*p(i2,4))
75514 h10=h10+p(i1,4)*p(i2,4)*cthe
75515 h20=h20+p(i1,4)*p(i2,4)*(1.5d0*cthe**2-0.5d0)
75516 h30=h30+p(i1,4)*p(i2,4)*(2.5d0*cthe**3-1.5d0*cthe)
75517 h40=h40+p(i1,4)*p(i2,4)*(4.375d0*cthe**4-3.75d0*cthe**2+
75518 & 0.375d0)
75519 120 CONTINUE
75520 130 CONTINUE
75521
75522C...Calculate H1/H0 - H4/H0. Output.
75523 mstu(61)=n+1
75524 mstu(62)=np
75525 h10=(hd+2d0*h10)/h0
75526 h20=(hd+2d0*h20)/h0
75527 h30=(hd+2d0*h30)/h0
75528 h40=(hd+2d0*h40)/h0
75529
75530 RETURN
75531 END
75532
75533C*********************************************************************
75534
75535C...PYTABU
75536C...Evaluates various properties of an event, with statistics
75537C...accumulated during the course of the run and
75538C...printed at the end.
75539
75540 SUBROUTINE pytabu(MTABU)
75541
75542C...Double precision and integer declarations.
75543 IMPLICIT DOUBLE PRECISION(a-h, o-z)
75544 IMPLICIT INTEGER(I-N)
75545 INTEGER PYK,PYCHGE,PYCOMP
75546C...Parameter statement to help give large particle numbers.
75547 parameter(ksusy1=1000000,ksusy2=2000000,ktechn=3000000,
75548 &kexcit=4000000,kdimen=5000000)
75549C...Commonblocks.
75550 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
75551 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
75552 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
75553 common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
75554 SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/
75555C...Local arrays, character variables, saved variables and data.
75556 dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),
75557 &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),
75558 &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),
75559 &kfdm(8),kfdc(200,0:8),npdc(200)
75560 SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,
75561 &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,
75562 &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc
75563 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75564 DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,
75565 &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0d0/,fm2fm/120*0d0/,
75566 &nevee/0/,fe1ec/50*0d0/,fe2ec/50*0d0/,fe1ea/25*0d0/,fe2ea/25*0d0/,
75567 &nevdc/0/,nkfdc/0/,nredc/0/
75568
75569C...Reset statistics on initial parton state.
75570 IF(mtabu.EQ.10) THEN
75571 nevis=0
75572 nkfis=0
75573
75574C...Identify and order flavour content of initial state.
75575 ELSEIF(mtabu.EQ.11) THEN
75576 nevis=nevis+1
75577 kfm1=2*iabs(mstu(161))
75578 IF(mstu(161).GT.0) kfm1=kfm1-1
75579 kfm2=2*iabs(mstu(162))
75580 IF(mstu(162).GT.0) kfm2=kfm2-1
75581 kfmn=min(kfm1,kfm2)
75582 kfmx=max(kfm1,kfm2)
75583 DO 100 i=1,nkfis
75584 IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN
75585 ikfis=-i
75586 GOTO 110
75587 ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.
75588 & kfmx.LT.kfis(i,2))) THEN
75589 ikfis=i
75590 GOTO 110
75591 ENDIF
75592 100 CONTINUE
75593 ikfis=nkfis+1
75594 110 IF(ikfis.LT.0) THEN
75595 ikfis=-ikfis
75596 ELSE
75597 IF(nkfis.GE.100) RETURN
75598 DO 130 i=nkfis,ikfis,-1
75599 kfis(i+1,1)=kfis(i,1)
75600 kfis(i+1,2)=kfis(i,2)
75601 DO 120 j=0,10
75602 npis(i+1,j)=npis(i,j)
75603 120 CONTINUE
75604 130 CONTINUE
75605 nkfis=nkfis+1
75606 kfis(ikfis,1)=kfmn
75607 kfis(ikfis,2)=kfmx
75608 DO 140 j=0,10
75609 npis(ikfis,j)=0
75610 140 CONTINUE
75611 ENDIF
75612 npis(ikfis,0)=npis(ikfis,0)+1
75613
75614C...Count number of partons in initial state.
75615 np=0
75616 DO 160 i=1,n
75617 IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN
75618 ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN
75619 ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)
75620 & THEN
75621 ELSE
75622 im=i
75623 150 im=k(im,3)
75624 IF(im.LE.0.OR.im.GT.n) THEN
75625 np=np+1
75626 ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
75627 np=np+1
75628 ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN
75629 ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10)
75630 & .NE.0) THEN
75631 ELSE
75632 GOTO 150
75633 ENDIF
75634 ENDIF
75635 160 CONTINUE
75636 npco=max(np,1)
75637 IF(np.GE.6) npco=6
75638 IF(np.GE.8) npco=7
75639 IF(np.GE.11) npco=8
75640 IF(np.GE.16) npco=9
75641 IF(np.GE.26) npco=10
75642 npis(ikfis,npco)=npis(ikfis,npco)+1
75643 mstu(62)=np
75644
75645C...Write statistics on initial parton state.
75646 ELSEIF(mtabu.EQ.12) THEN
75647 fac=1d0/max(1,nevis)
75648 WRITE(mstu(11),5000) nevis
75649 DO 170 i=1,nkfis
75650 kfmn=kfis(i,1)
75651 IF(kfmn.EQ.0) kfmn=kfis(i,2)
75652 kfm1=(kfmn+1)/2
75653 IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
75654 CALL pyname(kfm1,chau)
75655 chis(1)=chau(1:12)
75656 IF(chau(13:13).NE.' ') chis(1)(12:12)='?'
75657 kfmx=kfis(i,2)
75658 IF(kfis(i,1).EQ.0) kfmx=0
75659 kfm2=(kfmx+1)/2
75660 IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
75661 CALL pyname(kfm2,chau)
75662 chis(2)=chau(1:12)
75663 IF(chau(13:13).NE.' ') chis(2)(12:12)='?'
75664 WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),
75665 & (npis(i,j)/dble(npis(i,0)),j=1,10)
75666 170 CONTINUE
75667
75668C...Copy statistics on initial parton state into /PYJETS/.
75669 ELSEIF(mtabu.EQ.13) THEN
75670 fac=1d0/max(1,nevis)
75671 DO 190 i=1,nkfis
75672 kfmn=kfis(i,1)
75673 IF(kfmn.EQ.0) kfmn=kfis(i,2)
75674 kfm1=(kfmn+1)/2
75675 IF(2*kfm1.EQ.kfmn) kfm1=-kfm1
75676 kfmx=kfis(i,2)
75677 IF(kfis(i,1).EQ.0) kfmx=0
75678 kfm2=(kfmx+1)/2
75679 IF(2*kfm2.EQ.kfmx) kfm2=-kfm2
75680 k(i,1)=32
75681 k(i,2)=99
75682 k(i,3)=kfm1
75683 k(i,4)=kfm2
75684 k(i,5)=npis(i,0)
75685 DO 180 j=1,5
75686 p(i,j)=fac*npis(i,j)
75687 v(i,j)=fac*npis(i,j+5)
75688 180 CONTINUE
75689 190 CONTINUE
75690 n=nkfis
75691 DO 200 j=1,5
75692 k(n+1,j)=0
75693 p(n+1,j)=0d0
75694 v(n+1,j)=0d0
75695 200 CONTINUE
75696 k(n+1,1)=32
75697 k(n+1,2)=99
75698 k(n+1,5)=nevis
75699 mstu(3)=1
75700
75701C...Reset statistics on number of particles/partons.
75702 ELSEIF(mtabu.EQ.20) THEN
75703 nevfs=0
75704 nprfs=0
75705 nfifs=0
75706 nchfs=0
75707 nkffs=0
75708
75709C...Identify whether particle/parton is primary or not.
75710 ELSEIF(mtabu.EQ.21) THEN
75711 nevfs=nevfs+1
75712 mstu(62)=0
75713 DO 260 i=1,n
75714 IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) GOTO 260
75715 mstu(62)=mstu(62)+1
75716 kc=pycomp(k(i,2))
75717 mpri=0
75718 IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN
75719 mpri=1
75720 ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN
75721 mpri=1
75722 ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN
75723 mpri=1
75724 ELSEIF(kc.EQ.0) THEN
75725 ELSEIF(k(k(i,3),1).EQ.13) THEN
75726 im=k(k(i,3),3)
75727 IF(im.LE.0.OR.im.GT.n) THEN
75728 mpri=1
75729 ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN
75730 mpri=1
75731 ENDIF
75732 ELSEIF(kchg(kc,2).EQ.0) THEN
75733 kcm=pycomp(k(k(i,3),2))
75734 IF(kcm.NE.0) THEN
75735 IF(kchg(kcm,2).NE.0) mpri=1
75736 ENDIF
75737 ENDIF
75738 IF(kc.NE.0.AND.mpri.EQ.1) THEN
75739 IF(kchg(kc,2).EQ.0) nprfs=nprfs+1
75740 ENDIF
75741 IF(k(i,1).LE.10) THEN
75742 nfifs=nfifs+1
75743 IF(pychge(k(i,2)).NE.0) nchfs=nchfs+1
75744 ENDIF
75745
75746C...Fill statistics on number of particles/partons in event.
75747 kfa=iabs(k(i,2))
75748 kfs=3-isign(1,k(i,2))-mpri
75749 DO 210 ip=1,nkffs
75750 IF(kfa.EQ.kffs(ip)) THEN
75751 ikffs=-ip
75752 GOTO 220
75753 ELSEIF(kfa.LT.kffs(ip)) THEN
75754 ikffs=ip
75755 GOTO 220
75756 ENDIF
75757 210 CONTINUE
75758 ikffs=nkffs+1
75759 220 IF(ikffs.LT.0) THEN
75760 ikffs=-ikffs
75761 ELSE
75762 IF(nkffs.GE.400) RETURN
75763 DO 240 ip=nkffs,ikffs,-1
75764 kffs(ip+1)=kffs(ip)
75765 DO 230 j=1,4
75766 npfs(ip+1,j)=npfs(ip,j)
75767 230 CONTINUE
75768 240 CONTINUE
75769 nkffs=nkffs+1
75770 kffs(ikffs)=kfa
75771 DO 250 j=1,4
75772 npfs(ikffs,j)=0
75773 250 CONTINUE
75774 ENDIF
75775 npfs(ikffs,kfs)=npfs(ikffs,kfs)+1
75776 260 CONTINUE
75777
75778C...Write statistics on particle/parton composition of events.
75779 ELSEIF(mtabu.EQ.22) THEN
75780 fac=1d0/max(1,nevfs)
75781 WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs
75782 DO 270 i=1,nkffs
75783 CALL pyname(kffs(i),chau)
75784 kc=pycomp(kffs(i))
75785 mdcyf=0
75786 IF(kc.NE.0) mdcyf=mdcy(kc,1)
75787 WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),
75788 & fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))
75789 270 CONTINUE
75790
75791C...Copy particle/parton composition information into /PYJETS/.
75792 ELSEIF(mtabu.EQ.23) THEN
75793 fac=1d0/max(1,nevfs)
75794 DO 290 i=1,nkffs
75795 k(i,1)=32
75796 k(i,2)=99
75797 k(i,3)=kffs(i)
75798 k(i,4)=0
75799 k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)
75800 DO 280 j=1,4
75801 p(i,j)=fac*npfs(i,j)
75802 v(i,j)=0d0
75803 280 CONTINUE
75804 p(i,5)=fac*k(i,5)
75805 v(i,5)=0d0
75806 290 CONTINUE
75807 n=nkffs
75808 DO 300 j=1,5
75809 k(n+1,j)=0
75810 p(n+1,j)=0d0
75811 v(n+1,j)=0d0
75812 300 CONTINUE
75813 k(n+1,1)=32
75814 k(n+1,2)=99
75815 k(n+1,5)=nevfs
75816 p(n+1,1)=fac*nprfs
75817 p(n+1,2)=fac*nfifs
75818 p(n+1,3)=fac*nchfs
75819 mstu(3)=1
75820
75821C...Reset factorial moments statistics.
75822 ELSEIF(mtabu.EQ.30) THEN
75823 nevfm=0
75824 nmufm=0
75825 DO 330 im=1,3
75826 DO 320 ib=1,10
75827 DO 310 ip=1,4
75828 fm1fm(im,ib,ip)=0d0
75829 fm2fm(im,ib,ip)=0d0
75830 310 CONTINUE
75831 320 CONTINUE
75832 330 CONTINUE
75833
75834C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75835 ELSEIF(mtabu.EQ.31) THEN
75836 nevfm=nevfm+1
75837 nlow=n+mstu(3)
75838 nupp=nlow
75839 DO 410 i=1,n
75840 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 410
75841 IF(mstu(41).GE.2) THEN
75842 kc=pycomp(k(i,2))
75843 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
75844 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
75845 & k(i,2).EQ.ksusy1+39) GOTO 410
75846 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
75847 & pychge(k(i,2)).EQ.0) GOTO 410
75848 ENDIF
75849 pmr=0d0
75850 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
75851 IF(mstu(42).GE.2) pmr=p(i,5)
75852 pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)
75853 yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),
75854 & 1d20)),p(i,3))
75855 IF(abs(yeta).GT.paru(57)) GOTO 410
75856 phi=pyangl(p(i,1),p(i,2))
75857 iyeta=512d0*(yeta+paru(57))/(2d0*paru(57))
75858 iyeta=max(0,min(511,iyeta))
75859 iphi=512d0*(phi+paru(1))/paru(2)
75860 iphi=max(0,min(511,iphi))
75861 iyep=0
75862 DO 340 ib=0,9
75863 iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))
75864 340 CONTINUE
75865
75866C...Order particles in (pseudo)rapidity and/or azimuth.
75867 IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
75868 CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
75869 RETURN
75870 ENDIF
75871 nupp=nupp+1
75872 IF(nupp.EQ.nlow+1) THEN
75873 k(nupp,1)=iyeta
75874 k(nupp,2)=iphi
75875 k(nupp,3)=iyep
75876 ELSE
75877 DO 350 i1=nupp-1,nlow+1,-1
75878 IF(iyeta.GE.k(i1,1)) GOTO 360
75879 k(i1+1,1)=k(i1,1)
75880 350 CONTINUE
75881 360 k(i1+1,1)=iyeta
75882 DO 370 i1=nupp-1,nlow+1,-1
75883 IF(iphi.GE.k(i1,2)) GOTO 380
75884 k(i1+1,2)=k(i1,2)
75885 370 CONTINUE
75886 380 k(i1+1,2)=iphi
75887 DO 390 i1=nupp-1,nlow+1,-1
75888 IF(iyep.GE.k(i1,3)) GOTO 400
75889 k(i1+1,3)=k(i1,3)
75890 390 CONTINUE
75891 400 k(i1+1,3)=iyep
75892 ENDIF
75893 410 CONTINUE
75894 k(nupp+1,1)=2**10
75895 k(nupp+1,2)=2**10
75896 k(nupp+1,3)=4**10
75897
75898C...Calculate sum of factorial moments in event.
75899 DO 480 im=1,3
75900 DO 430 ib=1,10
75901 DO 420 ip=1,4
75902 fevfm(ib,ip)=0d0
75903 420 CONTINUE
75904 430 CONTINUE
75905 DO 450 ib=1,10
75906 IF(im.LE.2) ibin=2**(10-ib)
75907 IF(im.EQ.3) ibin=4**(10-ib)
75908 iagr=k(nlow+1,im)/ibin
75909 nagr=1
75910 DO 440 i=nlow+2,nupp+1
75911 icut=k(i,im)/ibin
75912 IF(icut.EQ.iagr) THEN
75913 nagr=nagr+1
75914 ELSE
75915 IF(nagr.EQ.1) THEN
75916 ELSEIF(nagr.EQ.2) THEN
75917 fevfm(ib,1)=fevfm(ib,1)+2d0
75918 ELSEIF(nagr.EQ.3) THEN
75919 fevfm(ib,1)=fevfm(ib,1)+6d0
75920 fevfm(ib,2)=fevfm(ib,2)+6d0
75921 ELSEIF(nagr.EQ.4) THEN
75922 fevfm(ib,1)=fevfm(ib,1)+12d0
75923 fevfm(ib,2)=fevfm(ib,2)+24d0
75924 fevfm(ib,3)=fevfm(ib,3)+24d0
75925 ELSE
75926 fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1d0)
75927 fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1d0)*(nagr-2d0)
75928 fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1d0)*(nagr-2d0)*
75929 & (nagr-3d0)
75930 fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1d0)*(nagr-2d0)*
75931 & (nagr-3d0)*(nagr-4d0)
75932 ENDIF
75933 iagr=icut
75934 nagr=1
75935 ENDIF
75936 440 CONTINUE
75937 450 CONTINUE
75938
75939C...Add results to total statistics.
75940 DO 470 ib=10,1,-1
75941 DO 460 ip=1,4
75942 IF(fevfm(1,ip).LT.0.5d0) THEN
75943 fevfm(ib,ip)=0d0
75944 ELSEIF(im.LE.2) THEN
75945 fevfm(ib,ip)=2d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
75946 ELSE
75947 fevfm(ib,ip)=4d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)
75948 ENDIF
75949 fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)
75950 fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2
75951 460 CONTINUE
75952 470 CONTINUE
75953 480 CONTINUE
75954 nmufm=nmufm+(nupp-nlow)
75955 mstu(62)=nupp-nlow
75956
75957C...Write accumulated statistics on factorial moments.
75958 ELSEIF(mtabu.EQ.32) THEN
75959 fac=1d0/max(1,nevfm)
75960 IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'
75961 IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'
75962 IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y '
75963 DO 510 im=1,3
75964 WRITE(mstu(11),5500)
75965 DO 500 ib=1,10
75966 byeta=2d0*paru(57)
75967 IF(im.NE.2) byeta=byeta/2**(ib-1)
75968 bphi=paru(2)
75969 IF(im.NE.1) bphi=bphi/2**(ib-1)
75970 IF(im.LE.2) bnave=fac*nmufm/dble(2**(ib-1))
75971 IF(im.EQ.3) bnave=fac*nmufm/dble(4**(ib-1))
75972 DO 490 ip=1,4
75973 fmoma(ip)=fac*fm1fm(im,ib,ip)
75974 fmoms(ip)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
75975 & fmoma(ip)**2)))
75976 490 CONTINUE
75977 WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),
75978 & ip=1,4)
75979 500 CONTINUE
75980 510 CONTINUE
75981
75982C...Copy statistics on factorial moments into /PYJETS/.
75983 ELSEIF(mtabu.EQ.33) THEN
75984 fac=1d0/max(1,nevfm)
75985 DO 540 im=1,3
75986 DO 530 ib=1,10
75987 i=10*(im-1)+ib
75988 k(i,1)=32
75989 k(i,2)=99
75990 k(i,3)=1
75991 IF(im.NE.2) k(i,3)=2**(ib-1)
75992 k(i,4)=1
75993 IF(im.NE.1) k(i,4)=2**(ib-1)
75994 k(i,5)=0
75995 p(i,1)=2d0*paru(57)/k(i,3)
75996 v(i,1)=paru(2)/k(i,4)
75997 DO 520 ip=1,4
75998 p(i,ip+1)=fac*fm1fm(im,ib,ip)
75999 v(i,ip+1)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-
76000 & p(i,ip+1)**2)))
76001 520 CONTINUE
76002 530 CONTINUE
76003 540 CONTINUE
76004 n=30
76005 DO 550 j=1,5
76006 k(n+1,j)=0
76007 p(n+1,j)=0d0
76008 v(n+1,j)=0d0
76009 550 CONTINUE
76010 k(n+1,1)=32
76011 k(n+1,2)=99
76012 k(n+1,5)=nevfm
76013 mstu(3)=1
76014
76015C...Reset statistics on Energy-Energy Correlation.
76016 ELSEIF(mtabu.EQ.40) THEN
76017 nevee=0
76018 DO 560 j=1,25
76019 fe1ec(j)=0d0
76020 fe2ec(j)=0d0
76021 fe1ec(51-j)=0d0
76022 fe2ec(51-j)=0d0
76023 fe1ea(j)=0d0
76024 fe2ea(j)=0d0
76025 560 CONTINUE
76026
76027C...Find particles to include, with proper assumed mass.
76028 ELSEIF(mtabu.EQ.41) THEN
76029 nevee=nevee+1
76030 nlow=n+mstu(3)
76031 nupp=nlow
76032 ecm=0d0
76033 DO 570 i=1,n
76034 IF(k(i,1).LE.0.OR.k(i,1).GT.10) GOTO 570
76035 IF(mstu(41).GE.2) THEN
76036 kc=pycomp(k(i,2))
76037 IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.
76038 & kc.EQ.18.OR.k(i,2).EQ.ksusy1+22.OR.k(i,2).EQ.39.OR.
76039 & k(i,2).EQ.ksusy1+39) GOTO 570
76040 IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.
76041 & pychge(k(i,2)).EQ.0) GOTO 570
76042 ENDIF
76043 pmr=0d0
76044 IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)
76045 IF(mstu(42).GE.2) pmr=p(i,5)
76046 IF(nupp.GT.mstu(4)-5-mstu(32)) THEN
76047 CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')
76048 RETURN
76049 ENDIF
76050 nupp=nupp+1
76051 p(nupp,1)=p(i,1)
76052 p(nupp,2)=p(i,2)
76053 p(nupp,3)=p(i,3)
76054 p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)
76055 p(nupp,5)=max(1d-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))
76056 ecm=ecm+p(nupp,4)
76057 570 CONTINUE
76058 IF(nupp.EQ.nlow) RETURN
76059
76060C...Analyze Energy-Energy Correlation in event.
76061 fac=(2d0/ecm**2)*50d0/paru(1)
76062 DO 580 j=1,50
76063 fevee(j)=0d0
76064 580 CONTINUE
76065 DO 600 i1=nlow+2,nupp
76066 DO 590 i2=nlow+1,i1-1
76067 cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/
76068 & (p(i1,5)*p(i2,5))
76069 the=acos(max(-1d0,min(1d0,cthe)))
76070 ithe=max(1,min(50,1+int(50d0*the/paru(1))))
76071 fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)
76072 590 CONTINUE
76073 600 CONTINUE
76074 DO 610 j=1,25
76075 fe1ec(j)=fe1ec(j)+fevee(j)
76076 fe2ec(j)=fe2ec(j)+fevee(j)**2
76077 fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)
76078 fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2
76079 fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))
76080 fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2
76081 610 CONTINUE
76082 mstu(62)=nupp-nlow
76083
76084C...Write statistics on Energy-Energy Correlation.
76085 ELSEIF(mtabu.EQ.42) THEN
76086 fac=1d0/max(1,nevee)
76087 WRITE(mstu(11),5700) nevee
76088 DO 620 j=1,25
76089 feec1=fac*fe1ec(j)
76090 fees1=sqrt(max(0d0,fac*(fac*fe2ec(j)-feec1**2)))
76091 feec2=fac*fe1ec(51-j)
76092 fees2=sqrt(max(0d0,fac*(fac*fe2ec(51-j)-feec2**2)))
76093 feeca=fac*fe1ea(j)
76094 feesa=sqrt(max(0d0,fac*(fac*fe2ea(j)-feeca**2)))
76095 WRITE(mstu(11),5800) 3.6d0*(j-1),3.6d0*j,feec1,fees1,
76096 & feec2,fees2,feeca,feesa
76097 620 CONTINUE
76098
76099C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76100 ELSEIF(mtabu.EQ.43) THEN
76101 fac=1d0/max(1,nevee)
76102 DO 630 i=1,25
76103 k(i,1)=32
76104 k(i,2)=99
76105 k(i,3)=0
76106 k(i,4)=0
76107 k(i,5)=0
76108 p(i,1)=fac*fe1ec(i)
76109 v(i,1)=sqrt(max(0d0,fac*(fac*fe2ec(i)-p(i,1)**2)))
76110 p(i,2)=fac*fe1ec(51-i)
76111 v(i,2)=sqrt(max(0d0,fac*(fac*fe2ec(51-i)-p(i,2)**2)))
76112 p(i,3)=fac*fe1ea(i)
76113 v(i,3)=sqrt(max(0d0,fac*(fac*fe2ea(i)-p(i,3)**2)))
76114 p(i,4)=paru(1)*(i-1)/50d0
76115 p(i,5)=paru(1)*i/50d0
76116 v(i,4)=3.6d0*(i-1)
76117 v(i,5)=3.6d0*i
76118 630 CONTINUE
76119 n=25
76120 DO 640 j=1,5
76121 k(n+1,j)=0
76122 p(n+1,j)=0d0
76123 v(n+1,j)=0d0
76124 640 CONTINUE
76125 k(n+1,1)=32
76126 k(n+1,2)=99
76127 k(n+1,5)=nevee
76128 mstu(3)=1
76129
76130C...Reset statistics on decay channels.
76131 ELSEIF(mtabu.EQ.50) THEN
76132 nevdc=0
76133 nkfdc=0
76134 nredc=0
76135
76136C...Identify and order flavour content of final state.
76137 ELSEIF(mtabu.EQ.51) THEN
76138 nevdc=nevdc+1
76139 nds=0
76140 DO 670 i=1,n
76141 IF(k(i,1).LE.0.OR.k(i,1).GE.6) GOTO 670
76142 nds=nds+1
76143 IF(nds.GT.8) THEN
76144 nredc=nredc+1
76145 RETURN
76146 ENDIF
76147 kfm=2*iabs(k(i,2))
76148 IF(k(i,2).LT.0) kfm=kfm-1
76149 DO 650 ids=nds-1,1,-1
76150 iin=ids+1
76151 IF(kfm.LT.kfdm(ids)) GOTO 660
76152 kfdm(ids+1)=kfdm(ids)
76153 650 CONTINUE
76154 iin=1
76155 660 kfdm(iin)=kfm
76156 670 CONTINUE
76157
76158C...Find whether old or new final state.
76159 DO 690 idc=1,nkfdc
76160 IF(nds.LT.kfdc(idc,0)) THEN
76161 ikfdc=idc
76162 GOTO 700
76163 ELSEIF(nds.EQ.kfdc(idc,0)) THEN
76164 DO 680 i=1,nds
76165 IF(kfdm(i).LT.kfdc(idc,i)) THEN
76166 ikfdc=idc
76167 GOTO 700
76168 ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN
76169 GOTO 690
76170 ENDIF
76171 680 CONTINUE
76172 ikfdc=-idc
76173 GOTO 700
76174 ENDIF
76175 690 CONTINUE
76176 ikfdc=nkfdc+1
76177 700 IF(ikfdc.LT.0) THEN
76178 ikfdc=-ikfdc
76179 ELSEIF(nkfdc.GE.200) THEN
76180 nredc=nredc+1
76181 RETURN
76182 ELSE
76183 DO 720 idc=nkfdc,ikfdc,-1
76184 npdc(idc+1)=npdc(idc)
76185 DO 710 i=0,8
76186 kfdc(idc+1,i)=kfdc(idc,i)
76187 710 CONTINUE
76188 720 CONTINUE
76189 nkfdc=nkfdc+1
76190 kfdc(ikfdc,0)=nds
76191 DO 730 i=1,nds
76192 kfdc(ikfdc,i)=kfdm(i)
76193 730 CONTINUE
76194 npdc(ikfdc)=0
76195 ENDIF
76196 npdc(ikfdc)=npdc(ikfdc)+1
76197
76198C...Write statistics on decay channels.
76199 ELSEIF(mtabu.EQ.52) THEN
76200 fac=1d0/max(1,nevdc)
76201 WRITE(mstu(11),5900) nevdc
76202 DO 750 idc=1,nkfdc
76203 DO 740 i=1,kfdc(idc,0)
76204 kfm=kfdc(idc,i)
76205 kf=(kfm+1)/2
76206 IF(2*kf.NE.kfm) kf=-kf
76207 CALL pyname(kf,chau)
76208 chdc(i)=chau(1:12)
76209 IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'
76210 740 CONTINUE
76211 WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))
76212 750 CONTINUE
76213 IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc
76214
76215C...Copy statistics on decay channels into /PYJETS/.
76216 ELSEIF(mtabu.EQ.53) THEN
76217 fac=1d0/max(1,nevdc)
76218 DO 780 idc=1,nkfdc
76219 k(idc,1)=32
76220 k(idc,2)=99
76221 k(idc,3)=0
76222 k(idc,4)=0
76223 k(idc,5)=kfdc(idc,0)
76224 DO 760 j=1,5
76225 p(idc,j)=0d0
76226 v(idc,j)=0d0
76227 760 CONTINUE
76228 DO 770 i=1,kfdc(idc,0)
76229 kfm=kfdc(idc,i)
76230 kf=(kfm+1)/2
76231 IF(2*kf.NE.kfm) kf=-kf
76232 IF(i.LE.5) p(idc,i)=kf
76233 IF(i.GE.6) v(idc,i-5)=kf
76234 770 CONTINUE
76235 v(idc,5)=fac*npdc(idc)
76236 780 CONTINUE
76237 n=nkfdc
76238 DO 790 j=1,5
76239 k(n+1,j)=0
76240 p(n+1,j)=0d0
76241 v(n+1,j)=0d0
76242 790 CONTINUE
76243 k(n+1,1)=32
76244 k(n+1,2)=99
76245 k(n+1,5)=nevdc
76246 v(n+1,5)=fac*nredc
76247 mstu(3)=1
76248 ENDIF
76249
76250C...Format statements for output on unit MSTU(11) (default 6).
76251 5000 FORMAT(///20x,'Event statistics - initial state'/
76252 &20x,'based on an analysis of ',i6,' events'//
76253 &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',
76254 &'according to fragmenting system multiplicity'/
76255 &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',
76256 &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)
76257 5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)
76258 5200 FORMAT(///20x,'Event statistics - final state'/
76259 &20x,'based on an analysis of ',i7,' events'//
76260 &5x,'Mean primary multiplicity =',f10.4/
76261 &5x,'Mean final multiplicity =',f10.4/
76262 &5x,'Mean charged multiplicity =',f10.4//
76263 &5x,'Number of particles produced per event (directly and via ',
76264 &'decays/branchings)'/
76265 &8x,'KF Particle/jet MDCY',10x,'Particles',13x,'Antiparticles',
76266 &8x,'Total'/35x,'prim seco prim seco'/)
76267 5300 FORMAT(1x,i9,4x,a16,i2,5(1x,f11.6))
76268 5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/
76269 &20x,'based on an analysis of ',i6,' events'//
76270 &3x,'delta-',a3,' delta-phi <n>/bin',10x,'<F2>',18x,'<F3>',
76271 &18x,'<F4>',18x,'<F5>'/35x,4(' value error '))
76272 5500 FORMAT(10x)
76273 5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))
76274 5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/
76275 &20x,'based on an analysis of ',i6,' events'//
76276 &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,
76277 &'EECA(theta)'/2x,'in degrees ',3(' value error')/)
76278 5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))
76279 5900 FORMAT(///20x,'Decay channel analysis - final state'/
76280 &20x,'based on an analysis of ',i6,' events'//
76281 &2x,'Probability',10x,'Complete final state'/)
76282 6000 FORMAT(2x,f9.5,5x,8(a12,1x))
76283 6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',
76284 &'or table overflow)')
76285
76286 RETURN
76287 END
76288
76289C*********************************************************************
76290
76291C...PYEEVT
76292C...Handles the generation of an e+e- annihilation jet event.
76293
76294 SUBROUTINE pyeevt(KFL,ECM)
76295
76296C...Double precision and integer declarations.
76297 IMPLICIT DOUBLE PRECISION(a-h, o-z)
76298 IMPLICIT INTEGER(I-N)
76299 INTEGER PYK,PYCHGE,PYCOMP
76300C...Commonblocks.
76301 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
76302 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76303 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76304 SAVE /pyjets/,/pydat1/,/pydat2/
76305
76306C...Check input parameters.
76307 IF(mstu(12).NE.12345) CALL pylist(0)
76308 IF(kfl.LT.0.OR.kfl.GT.8) THEN
76309 CALL pyerrm(16,'(PYEEVT:) called with unknown flavour code')
76310 IF(mstu(21).GE.1) RETURN
76311 ENDIF
76312 IF(kfl.LE.5) ecmmin=parj(127)+2.02d0*parf(100+max(1,kfl))
76313 IF(kfl.GE.6) ecmmin=parj(127)+2.02d0*pmas(kfl,1)
76314 IF(ecm.LT.ecmmin) THEN
76315 CALL pyerrm(16,'(PYEEVT:) called with too small CM energy')
76316 IF(mstu(21).GE.1) RETURN
76317 ENDIF
76318
76319C...Check consistency of MSTJ options set.
76320 IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN
76321 CALL pyerrm(6,
76322 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76323 mstj(110)=1
76324 ENDIF
76325 IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN
76326 CALL pyerrm(6,
76327 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76328 mstj(111)=0
76329 ENDIF
76330
76331C...Initialize alpha_strong and total cross-section.
76332 mstu(111)=mstj(108)
76333 IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
76334 &mstu(111)=1
76335 paru(112)=parj(121)
76336 IF(mstu(111).EQ.2) paru(112)=parj(122)
76337 IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.
76338 &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL pyxtee(kfl,ecm,
76339 &xtot)
76340 IF(mstj(116).GE.3) mstj(116)=1
76341 parj(171)=0d0
76342
76343C...Add initial e+e- to event record (documentation only).
76344 ntry=0
76345 100 ntry=ntry+1
76346 IF(ntry.GT.100) THEN
76347 CALL pyerrm(14,'(PYEEVT:) caught in an infinite loop')
76348 RETURN
76349 ENDIF
76350 mstu(24)=0
76351 nc=0
76352 IF(mstj(115).GE.2) THEN
76353 nc=nc+2
76354 CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
76355 k(nc-1,1)=21
76356 CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
76357 k(nc,1)=21
76358 ENDIF
76359
76360C...Radiative photon (in initial state).
76361 mk=0
76362 ecmc=ecm
76363 IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL pyradk(ecm,mk,pak,
76364 &thek,phik,alpk)
76365 IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2d0*pak))
76366 IF(mstj(115).GE.1.AND.mk.EQ.1) THEN
76367 nc=nc+1
76368 CALL py1ent(nc,22,pak,thek,phik)
76369 k(nc,3)=min(mstj(115)/2,1)
76370 ENDIF
76371
76372C...Virtual exchange boson (gamma or Z0).
76373 IF(mstj(115).GE.3) THEN
76374 nc=nc+1
76375 kf=22
76376 IF(mstj(102).EQ.2) kf=23
76377 mstu10=mstu(10)
76378 mstu(10)=1
76379 p(nc,5)=ecmc
76380 CALL py1ent(nc,kf,ecmc,0d0,0d0)
76381 k(nc,1)=21
76382 k(nc,3)=1
76383 mstu(10)=mstu10
76384 ENDIF
76385
76386C...Choice of flavour and jet configuration.
76387 CALL pyxkfl(kfl,ecm,ecmc,kflc)
76388 IF(kflc.EQ.0) GOTO 100
76389 CALL pyxjet(ecmc,njet,cut)
76390 kfln=21
76391 IF(njet.EQ.4) CALL pyx4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,
76392 &x12,x14)
76393 IF(njet.EQ.3) CALL pyx3jt(njet,cut,kflc,ecmc,x1,x3)
76394 IF(njet.EQ.2) mstj(120)=1
76395
76396C...Fill jet configuration and origin.
76397 IF(njet.EQ.2.AND.mstj(101).NE.5) CALL py2ent(nc+1,kflc,-kflc,ecmc)
76398 IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL py2ent(-(nc+1),kflc,-kflc,
76399 &ecmc)
76400 IF(njet.EQ.3) CALL py3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)
76401 IF(njet.EQ.4.AND.kfln.EQ.21) CALL py4ent(nc+1,kflc,kfln,kfln,
76402 &-kflc,ecmc,x1,x2,x4,x12,x14)
76403 IF(njet.EQ.4.AND.kfln.NE.21) CALL py4ent(nc+1,kflc,-kfln,kfln,
76404 &-kflc,ecmc,x1,x2,x4,x12,x14)
76405 IF(mstu(24).NE.0) GOTO 100
76406 DO 110 ip=nc+1,n
76407 k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)
76408 110 CONTINUE
76409
76410C...Angular orientation according to matrix element.
76411 IF(mstj(106).EQ.1) THEN
76412 CALL pyxdif(nc,njet,kflc,ecmc,chi,the,phi)
76413 CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
76414 CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
76415 ENDIF
76416
76417C...Rotation and boost from radiative photon.
76418 IF(mk.EQ.1) THEN
76419 dbek=-pak/(ecm-pak)
76420 nmin=nc+1-mstj(115)/3
76421 CALL pyrobo(nmin,n,0d0,-phik,0d0,0d0,0d0)
76422 CALL pyrobo(nmin,n,alpk,0d0,dbek*sin(thek),0d0,dbek*cos(thek))
76423 CALL pyrobo(nmin,n,0d0,phik,0d0,0d0,0d0)
76424 ENDIF
76425
76426C...Generate parton shower. Rearrange along strings and check.
76427 IF(mstj(101).EQ.5) THEN
76428 CALL pyshow(n-1,n,ecmc)
76429 mstj14=mstj(14)
76430 IF(mstj(105).EQ.-1) mstj(14)=-1
76431 IF(mstj(105).GE.0) mstu(28)=0
76432 CALL pyprep(0)
76433 mstj(14)=mstj14
76434 IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
76435 ENDIF
76436
76437C...Fragmentation/decay generation. Information for PYTABU.
76438 IF(mstj(105).EQ.1) CALL pyexec
76439 mstu(161)=kflc
76440 mstu(162)=-kflc
76441
76442 RETURN
76443 END
76444
76445C*********************************************************************
76446
76447C...PYXTEE
76448C...Calculates total cross-section, including initial state
76449C...radiation effects.
76450
76451 SUBROUTINE pyxtee(KFL,ECM,XTOT)
76452
76453C...Double precision and integer declarations.
76454 IMPLICIT DOUBLE PRECISION(a-h, o-z)
76455 IMPLICIT INTEGER(I-N)
76456 INTEGER PYK,PYCHGE,PYCOMP
76457C...Commonblocks.
76458 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76459 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76460 SAVE /pydat1/,/pydat2/
76461
76462C...Status, (optimized) Q^2 scale, alpha_strong.
76463 parj(151)=ecm
76464 mstj(119)=10*mstj(102)+kfl
76465 IF(mstj(111).EQ.0) THEN
76466 q2r=ecm**2
76467 ELSEIF(mstu(111).EQ.0) THEN
76468 parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
76469 & ((33d0-2d0*mstu(112))*paru(111)))))
76470 q2r=parj(168)*ecm**2
76471 ELSE
76472 parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
76473 & (2d0*paru(112)/ecm)**2))
76474 q2r=parj(168)*ecm**2
76475 ENDIF
76476 alspi=pyalps(q2r)/paru(1)
76477
76478C...QCD corrections factor in R.
76479 IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN
76480 rqcd=1d0
76481 ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN
76482 rqcd=1d0+alspi
76483 ELSEIF(mstj(109).EQ.0) THEN
76484 rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
76485 IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+(33d0-2d0*mstu(112))/12d0*
76486 & log(parj(168))*alspi**2)
76487 ELSEIF(iabs(mstj(101)).EQ.1) THEN
76488 rqcd=1d0+(3d0/4d0)*alspi
76489 ELSE
76490 rqcd=1d0+(3d0/4d0)*alspi-(3d0/32d0+0.519d0*mstu(118))*alspi**2
76491 ENDIF
76492
76493C...Calculate Z0 width if default value not acceptable.
76494 IF(mstj(102).GE.3) THEN
76495 rva=3d0*(3d0+(4d0*paru(102)-1d0)**2)+6d0*rqcd*(2d0+
76496 & (1d0-8d0*paru(102)/3d0)**2+(4d0*paru(102)/3d0-1d0)**2)
76497 DO 100 kflc=5,6
76498 vq=1d0
76499 IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-
76500 & (2d0*pymass(kflc)/ ecm)**2))
76501 IF(kflc.EQ.5) vf=4d0*paru(102)/3d0-1d0
76502 IF(kflc.EQ.6) vf=1d0-8d0*paru(102)/3d0
76503 rva=rva+3d0*rqcd*(0.5d0*vq*(3d0-vq**2)*vf**2+vq**3)
76504 100 CONTINUE
76505 parj(124)=paru(101)*parj(123)*rva/(48d0*paru(102)*
76506 & (1d0-paru(102)))
76507 ENDIF
76508
76509C...Calculate propagator and related constants for QFD case.
76510 poll=1d0-parj(131)*parj(132)
76511 IF(mstj(102).GE.2) THEN
76512 sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
76513 sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
76514 sfi=sfw*(1d0-(parj(123)/ecm)**2)
76515 ve=4d0*paru(102)-1d0
76516 sf1i=sff*(ve*poll+parj(132)-parj(131))
76517 sf1w=sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
76518 hf1i=sfi*sf1i
76519 hf1w=sfw*sf1w
76520 ENDIF
76521
76522C...Loop over different flavours: charge, velocity.
76523 rtot=0d0
76524 rqq=0d0
76525 rqv=0d0
76526 rva=0d0
76527 DO 110 kflc=1,max(mstj(104),kfl)
76528 IF(kfl.GT.0.AND.kflc.NE.kfl) GOTO 110
76529 mstj(93)=1
76530 pmq=pymass(kflc)
76531 IF(ecm.LT.2d0*pmq+parj(127)) GOTO 110
76532 qf=kchg(kflc,1)/3d0
76533 vq=1d0
76534 IF(mod(mstj(103),2).EQ.1) vq=sqrt(1d0-(2d0*pmq/ecm)**2)
76535
76536C...Calculate R and sum of charges for QED or QFD case.
76537 rqq=rqq+3d0*qf**2*poll
76538 IF(mstj(102).LE.1) THEN
76539 rtot=rtot+3d0*0.5d0*vq*(3d0-vq**2)*qf**2*poll
76540 ELSE
76541 vf=sign(1d0,qf)-4d0*qf*paru(102)
76542 rqv=rqv-6d0*qf*vf*sf1i
76543 rva=rva+3d0*(vf**2+1d0)*sf1w
76544 rtot=rtot+3d0*(0.5d0*vq*(3d0-vq**2)*(qf**2*poll-
76545 & 2d0*qf*vf*hf1i+vf**2*hf1w)+vq**3*hf1w)
76546 ENDIF
76547 110 CONTINUE
76548 rsum=rqq
76549 IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva
76550
76551C...Calculate cross-section, including QCD corrections.
76552 parj(141)=rqq
76553 parj(142)=rtot
76554 parj(143)=rtot*rqcd
76555 parj(144)=parj(143)
76556 parj(145)=parj(141)*86.8d0/ecm**2
76557 parj(146)=parj(142)*86.8d0/ecm**2
76558 parj(147)=parj(143)*86.8d0/ecm**2
76559 parj(148)=parj(147)
76560 parj(157)=rsum*rqcd
76561 parj(158)=0d0
76562 parj(159)=0d0
76563 xtot=parj(147)
76564 IF(mstj(107).LE.0) RETURN
76565
76566C...Virtual cross-section.
76567 xkl=parj(135)
76568 xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
76569 ale=2d0*log(ecm/pymass(11))-1d0
76570 sigv=ale/3d0+2d0*log(ecm**2/(pymass(13)*pymass(15)))/3d0-4d0/3d0+
76571 &1.526d0*log(ecm**2/0.932d0)
76572
76573C...Soft and hard radiative cross-section in QED case.
76574 IF(mstj(102).LE.1) THEN
76575 sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+2d0*sigv
76576 sigs=ale*(2d0*log(xkl)-log(1d0-xkl)-xkl)
76577 sigh=ale*(2d0*log(xku/xkl)-log((1d0-xku)/(1d0-xkl))-(xku-xkl))
76578
76579C...Soft and hard radiative cross-section in QFD case.
76580 ELSE
76581 szm=1d0-(parj(123)/ecm)**2
76582 szw=parj(123)*parj(124)/ecm**2
76583 parj(161)=-rqq/rsum
76584 parj(162)=-(rqq+rqv+rva)/rsum
76585 parj(163)=(rqv*(1d0-0.5d0*szm-sfi)+rva*(1.5d0-szm-sfw))/rsum
76586 parj(164)=(rqv*szw**2*(1d0-2d0*sfw)+rva*(2d0*sfi+szw**2-
76587 & 4d0+3d0*szm-szm**2))/(szw*rsum)
76588 sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+((2d0*rqq+sfi*rqv)/
76589 & rsum)*sigv+(szw*sfw*rqv/rsum)*paru(1)*20d0/9d0
76590 sigs=ale*(2d0*log(xkl)+parj(161)*log(1d0-xkl)+parj(162)*xkl+
76591 & parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+
76592 & parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))
76593 sigh=ale*(2d0*log(xku/xkl)+parj(161)*log((1d0-xku)/
76594 & (1d0-xkl))+parj(162)*(xku-xkl)+parj(163)*
76595 & log(((xku-szm)**2+szw**2)/((xkl-szm)**2+szw**2))+
76596 & parj(164)*(atan((xku-szm)/szw)-atan((xkl-szm)/szw)))
76597 ENDIF
76598
76599C...Total cross-section and fraction of hard photon events.
76600 parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)
76601 parj(157)=rsum*(1d0+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd
76602 parj(144)=parj(157)
76603 parj(148)=parj(144)*86.8d0/ecm**2
76604 xtot=parj(148)
76605
76606 RETURN
76607 END
76608
76609C*********************************************************************
76610
76611C...PYRADK
76612C...Generates initial state photon radiation.
76613
76614 SUBROUTINE pyradk(ECM,MK,PAK,THEK,PHIK,ALPK)
76615
76616C...Double precision and integer declarations.
76617 IMPLICIT DOUBLE PRECISION(a-h, o-z)
76618 IMPLICIT INTEGER(I-N)
76619 INTEGER PYK,PYCHGE,PYCOMP
76620C...Commonblocks.
76621 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76622 SAVE /pydat1/
76623
76624C...Function: cumulative hard photon spectrum in QFD case.
76625 fxk(xx)=2d0*log(xx)+parj(161)*log(1d0-xx)+parj(162)*xx+
76626 &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)
76627
76628C...Determine whether radiative photon or not.
76629 mk=0
76630 pak=0d0
76631 IF(parj(160).LT.pyr(0)) RETURN
76632 mk=1
76633
76634C...Photon energy range. Find photon momentum in QED case.
76635 xkl=parj(135)
76636 xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)
76637 IF(mstj(102).LE.1) THEN
76638 100 xk=1d0/(1d0+(1d0/xkl-1d0)*((1d0/xku-1d0)/(1d0/xkl-1d0))**pyr(0))
76639 IF(1d0+(1d0-xk)**2.LT.2d0*pyr(0)) GOTO 100
76640
76641C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76642 ELSE
76643 szm=1d0-(parj(123)/ecm)**2
76644 szw=parj(123)*parj(124)/ecm**2
76645 fxkl=fxk(xkl)
76646 fxku=fxk(xku)
76647 fxkd=1d-4*(fxku-fxkl)
76648 fxkr=fxkl+pyr(0)*(fxku-fxkl)
76649 nxk=0
76650 110 nxk=nxk+1
76651 xk=0.5d0*(xkl+xku)
76652 fxkv=fxk(xk)
76653 IF(fxkv.GT.fxkr) THEN
76654 xku=xk
76655 fxku=fxkv
76656 ELSE
76657 xkl=xk
76658 fxkl=fxkv
76659 ENDIF
76660 IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) GOTO 110
76661 xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)
76662 ENDIF
76663 pak=0.5d0*ecm*xk
76664
76665C...Photon polar and azimuthal angle.
76666 pme=2d0*(pymass(11)/ecm)**2
76667 120 cthm=pme*(2d0/pme)**pyr(0)
76668 IF(1d0-(xk**2*cthm*(1d0-0.5d0*cthm)+2d0*(1d0-xk)*pme/max(pme,
76669 &cthm*(1d0-0.5d0*cthm)))/(1d0+(1d0-xk)**2).LT.pyr(0)) GOTO 120
76670 cthe=1d0-cthm
76671 IF(pyr(0).GT.0.5d0) cthe=-cthe
76672 sthe=sqrt(max(0d0,(cthm-pme)*(2d0-cthm)))
76673 thek=pyangl(cthe,sthe)
76674 phik=paru(2)*pyr(0)
76675
76676C...Rotation angle for hadronic system.
76677 sgn=1d0
76678 IF(0.5d0*(2d0-xk*(1d0-cthe))**2/((2d0-xk)**2+(xk*cthe)**2).GT.
76679 &pyr(0)) sgn=-1d0
76680 alpk=asin(sgn*sthe*(xk-sgn*(2d0*sqrt(1d0-xk)-2d0+xk)*cthe)/
76681 &(2d0-xk*(1d0-sgn*cthe)))
76682
76683 RETURN
76684 END
76685
76686C*********************************************************************
76687
76688C...PYXKFL
76689C...Selects flavour for produced qqbar pair.
76690
76691 SUBROUTINE pyxkfl(KFL,ECM,ECMC,KFLC)
76692
76693C...Double precision and integer declarations.
76694 IMPLICIT DOUBLE PRECISION(a-h, o-z)
76695 IMPLICIT INTEGER(I-N)
76696 INTEGER PYK,PYCHGE,PYCOMP
76697C...Commonblocks.
76698 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76699 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
76700 SAVE /pydat1/,/pydat2/
76701
76702C...Calculate maximum weight in QED or QFD case.
76703 IF(mstj(102).LE.1) THEN
76704 rfmax=4d0/9d0
76705 ELSE
76706 poll=1d0-parj(131)*parj(132)
76707 sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
76708 sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
76709 sfi=sfw*(1d0-(parj(123)/ecmc)**2)
76710 ve=4d0*paru(102)-1d0
76711 hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))
76712 hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))
76713 rfmax=max(4d0/9d0*poll-4d0/3d0*(1d0-8d0*paru(102)/3d0)*hf1i+
76714 & ((1d0-8d0*paru(102)/3d0)**2+1d0)*hf1w,1d0/9d0*poll+2d0/3d0*
76715 & (-1d0+4d0*paru(102)/3d0)*hf1i+((-1d0+4d0*paru(102)/3d0)**2+
76716 & 1d0)*hf1w)
76717 ENDIF
76718
76719C...Choose flavour. Gives charge and velocity.
76720 ntry=0
76721 100 ntry=ntry+1
76722 IF(ntry.GT.100) THEN
76723 CALL pyerrm(14,'(PYXKFL:) caught in an infinite loop')
76724 kflc=0
76725 RETURN
76726 ENDIF
76727 kflc=kfl
76728 IF(kfl.LE.0) kflc=1+int(mstj(104)*pyr(0))
76729 mstj(93)=1
76730 pmq=pymass(kflc)
76731 IF(ecm.LT.2d0*pmq+parj(127)) GOTO 100
76732 qf=kchg(kflc,1)/3d0
76733 vq=1d0
76734 IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-(2d0*pmq/ecmc)**2))
76735
76736C...Calculate weight in QED or QFD case.
76737 IF(mstj(102).LE.1) THEN
76738 rf=qf**2
76739 rfv=0.5d0*vq*(3d0-vq**2)*qf**2
76740 ELSE
76741 vf=sign(1d0,qf)-4d0*qf*paru(102)
76742 rf=qf**2*poll-2d0*qf*vf*hf1i+(vf**2+1d0)*hf1w
76743 rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+vf**2*hf1w)+
76744 & vq**3*hf1w
76745 IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)
76746 ENDIF
76747
76748C...Weighting or new event (radiative photon). Cross-section update.
76749 IF(kfl.LE.0.AND.rf.LT.pyr(0)*rfmax) GOTO 100
76750 parj(158)=parj(158)+1d0
76751 IF(ecmc.LT.2d0*pmq+parj(127).OR.rfv.LT.pyr(0)*rf) kflc=0
76752 IF(mstj(107).LE.0.AND.kflc.EQ.0) GOTO 100
76753 IF(kflc.NE.0) parj(159)=parj(159)+1d0
76754 parj(144)=parj(157)*parj(159)/parj(158)
76755 parj(148)=parj(144)*86.8d0/ecm**2
76756
76757 RETURN
76758 END
76759
76760C*********************************************************************
76761
76762C...PYXJET
76763C...Selects number of jets in matrix element approach.
76764
76765 SUBROUTINE pyxjet(ECM,NJET,CUT)
76766
76767C...Double precision and integer declarations.
76768 IMPLICIT DOUBLE PRECISION(a-h, o-z)
76769 IMPLICIT INTEGER(I-N)
76770 INTEGER PYK,PYCHGE,PYCOMP
76771C...Commonblocks.
76772 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76773 SAVE /pydat1/
76774C...Local array and data.
76775 dimension zhut(5)
76776 DATA zhut/3.0922d0, 6.2291d0, 7.4782d0, 7.8440d0, 8.2560d0/
76777
76778C...Trivial result for two-jets only, including parton shower.
76779 IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
76780 cut=0d0
76781
76782C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76783 ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN
76784 cf=4d0/3d0
76785 IF(mstj(109).EQ.2) cf=1d0
76786 IF(mstj(111).EQ.0) THEN
76787 q2=ecm**2
76788 q2r=ecm**2
76789 ELSEIF(mstu(111).EQ.0) THEN
76790 parj(169)=min(1d0,parj(129))
76791 q2=parj(169)*ecm**2
76792 parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/
76793 & ((33d0-2d0*mstu(112))*paru(111)))))
76794 q2r=parj(168)*ecm**2
76795 ELSE
76796 parj(169)=min(1d0,max(parj(129),(2d0*paru(112)/ecm)**2))
76797 q2=parj(169)*ecm**2
76798 parj(168)=min(1d0,max(parj(128),paru(112)/ecm,
76799 & (2d0*paru(112)/ecm)**2))
76800 q2r=parj(168)*ecm**2
76801 ENDIF
76802
76803C...alpha_strong for R and R itself.
76804 alspi=(3d0/4d0)*cf*pyalps(q2r)/paru(1)
76805 IF(iabs(mstj(101)).EQ.1) THEN
76806 rqcd=1d0+alspi
76807 ELSEIF(mstj(109).EQ.0) THEN
76808 rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2
76809 IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+
76810 & (33d0-2d0*mstu(112))/12d0*log(parj(168))*alspi**2)
76811 ELSE
76812 rqcd=1d0+alspi-(3d0/32d0+0.519d0*mstu(118))*(4d0*alspi/3d0)**2
76813 ENDIF
76814
76815C...alpha_strong for jet rate. Initial value for y cut.
76816 alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
76817 cut=max(0.001d0,parj(125),(parj(126)/ecm)**2)
76818 IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))
76819 & cut=max(cut,exp(-sqrt(0.75d0/alspi))/2d0)
76820 IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
76821
76822C...Parametrization of first order three-jet cross-section.
76823 100 IF(mstj(101).EQ.0.OR.cut.GE.0.25d0) THEN
76824 parj(152)=0d0
76825 ELSE
76826 parj(152)=(2d0*alspi/3d0)*((3d0-6d0*cut+2d0*log(cut))*
76827 & log(cut/(1d0-2d0*cut))+(2.5d0+1.5d0*cut-6.571d0)*
76828 & (1d0-3d0*cut)+5.833d0*(1d0-3d0*cut)**2-3.894d0*
76829 & (1d0-3d0*cut)**3+1.342d0*(1d0-3d0*cut)**4)/rqcd
76830 IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))
76831 & parj(152)=0d0
76832 ENDIF
76833
76834C...Parametrization of second order three-jet cross-section.
76835 IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.
76836 & cut.GE.0.25d0) THEN
76837 parj(153)=0d0
76838 ELSEIF(mstj(110).LE.1) THEN
76839 ct=log(1d0/cut-2d0)
76840 parj(153)=alspi**2*ct**2*(2.419d0+0.5989d0*ct+0.6782d0*ct**2-
76841 & 0.2661d0*ct**3+0.01159d0*ct**4)/rqcd
76842
76843C...Interpolation in second/first order ratio for Zhu parametrization.
76844 ELSEIF(mstj(110).EQ.2) THEN
76845 iza=0
76846 DO 110 iy=1,5
76847 IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
76848 110 CONTINUE
76849 IF(iza.NE.0) THEN
76850 zhurat=zhut(iza)
76851 ELSE
76852 iz=100d0*cut
76853 zhurat=zhut(iz)+(100d0*cut-iz)*(zhut(iz+1)-zhut(iz))
76854 ENDIF
76855 parj(153)=alspi*parj(152)*zhurat
76856 ENDIF
76857
76858C...Shift in second order three-jet cross-section with optimized Q^2.
76859 IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3
76860 & .AND.cut.LT.0.25d0) parj(153)=parj(153)+
76861 & (33d0-2d0*mstu(112))/12d0*log(parj(169))*alspi*parj(152)
76862
76863C...Parametrization of second order four-jet cross-section.
76864 IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125d0) THEN
76865 parj(154)=0d0
76866 ELSE
76867 ct=log(1d0/cut-5d0)
76868 IF(cut.LE.0.018d0) THEN
76869 xqqgg=6.349d0-4.330d0*ct+0.8304d0*ct**2
76870 IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(3.035d0-2.091d0*ct+
76871 & 0.4059d0*ct**2)
76872 xqqqq=1.25d0*(-0.1080d0+0.01486d0*ct+0.009364d0*ct**2)
76873 IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
76874 ELSE
76875 xqqgg=-0.09773d0+0.2959d0*ct-0.2764d0*ct**2+0.08832d0*ct**3
76876 IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(-0.04079d0+
76877 & 0.1340d0*ct-0.1326d0*ct**2+0.04365d0*ct**3)
76878 xqqqq=1.25d0*(0.003661d0-0.004888d0*ct-0.001081d0*ct**2+
76879 & 0.002093d0*ct**3)
76880 IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq
76881 ENDIF
76882 parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd
76883 parj(155)=xqqqq/(xqqgg+xqqqq)
76884 ENDIF
76885
76886C...If negative three-jet rate, change y' optimization parameter.
76887 IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0d0.AND.
76888 & parj(169).LT.0.99d0) THEN
76889 parj(169)=min(1d0,1.2d0*parj(169))
76890 q2=parj(169)*ecm**2
76891 alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
76892 GOTO 100
76893 ENDIF
76894
76895C...If too high cross-section, use harder cuts, or fail.
76896 IF(parj(152)+parj(153)+parj(154).GE.1) THEN
76897 IF(mstj(110).EQ.2.AND.cut.GT.0.0499d0.AND.mstj(111).EQ.1.AND.
76898 & parj(169).LT.0.99d0) THEN
76899 parj(169)=min(1d0,1.2d0*parj(169))
76900 q2=parj(169)*ecm**2
76901 alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)
76902 GOTO 100
76903 ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499d0) THEN
76904 CALL pyerrm(26,
76905 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76906 ENDIF
76907 cut=0.26d0*(4d0*cut)**(parj(152)+parj(153)+
76908 & parj(154))**(-1d0/3d0)
76909 IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))
76910 GOTO 100
76911 ENDIF
76912
76913C...Scalar gluon (first order only).
76914 ELSE
76915 alspi=pyalps(ecm**2)/paru(1)
76916 cut=max(0.001d0,parj(125),(parj(126)/ecm)**2,exp(-3d0/alspi))
76917 parj(152)=0d0
76918 IF(cut.LT.0.25d0) parj(152)=(alspi/3d0)*((1d0-2d0*cut)*
76919 & log((1d0-2d0*cut)/cut)+0.5d0*(9d0*cut**2-1d0))
76920 parj(153)=0d0
76921 parj(154)=0d0
76922 ENDIF
76923
76924C...Select number of jets.
76925 parj(150)=cut
76926 IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN
76927 njet=2
76928 ELSEIF(mstj(101).LE.0) THEN
76929 njet=min(4,2-mstj(101))
76930 ELSE
76931 rnj=pyr(0)
76932 njet=2
76933 IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3
76934 IF(parj(154).GT.rnj) njet=4
76935 ENDIF
76936
76937 RETURN
76938 END
76939
76940C*********************************************************************
76941
76942C...PYX3JT
76943C...Selects the kinematical variables of three-jet events.
76944
76945 SUBROUTINE pyx3jt(NJET,CUT,KFL,ECM,X1,X2)
76946
76947C...Double precision and integer declarations.
76948 IMPLICIT DOUBLE PRECISION(a-h, o-z)
76949 IMPLICIT INTEGER(I-N)
76950 INTEGER PYK,PYCHGE,PYCOMP
76951C...Commonblocks.
76952 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
76953 SAVE /pydat1/
76954C...Local array.
76955 dimension zhup(5,12)
76956
76957C...Coefficients of Zhu second order parametrization.
76958 DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/
76959 &18.29d0, 89.56d0, 4.541d0, -52.09d0, -109.8d0, 24.90d0,
76960 &11.63d0, 3.683d0, 17.50d0,0.002440d0, -1.362d0,-0.3537d0,
76961 &11.42d0, 6.299d0, -22.55d0, -8.915d0, 59.25d0, -5.855d0,
76962 &-32.85d0, -1.054d0, -16.90d0,0.006489d0,-0.8156d0,0.01095d0,
76963 &7.847d0, -3.964d0, -35.83d0, 1.178d0, 29.39d0, 0.2806d0,
76964 &47.82d0, -12.36d0, -56.72d0, 0.04054d0,-0.4365d0, 0.6062d0,
76965 &5.441d0, -56.89d0, -50.27d0, 15.13d0, 114.3d0, -18.19d0,
76966 &97.05d0, -1.890d0, -139.9d0, 0.08153d0,-0.4984d0, 0.9439d0,
76967 &-17.65d0, 51.44d0, -58.32d0, 70.95d0, -255.7d0, -78.99d0,
76968 &476.9d0, 29.65d0, -239.3d0, 0.4745d0, -1.174d0, 6.081d0/
76969
76970C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76971 dilog(x)=x+x**2/4d0+x**3/9d0+x**4/16d0+x**5/25d0+x**6/36d0+
76972 &x**7/49d0
76973
76974C...Event type. Mass effect factors and other common constants.
76975 mstj(120)=2
76976 mstj(121)=0
76977 pmq=pymass(kfl)
76978 qme=(2d0*pmq/ecm)**2
76979 IF(mstj(109).NE.1) THEN
76980 cutl=log(cut)
76981 cutd=log(1d0/cut-2d0)
76982 IF(mstj(109).EQ.0) THEN
76983 cf=4d0/3d0
76984 cn=3d0
76985 tr=2d0
76986 wtmx=min(20d0,37d0-6d0*cutd)
76987 IF(mstj(110).EQ.2) wtmx=2d0*(7.5d0+80d0*cut)
76988 ELSE
76989 cf=1d0
76990 cn=0d0
76991 tr=12d0
76992 wtmx=0d0
76993 ENDIF
76994
76995C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
76996 als2pi=paru(118)/paru(2)
76997 wtopt=0d0
76998 IF(mstj(111).EQ.1) wtopt=(33d0-2d0*mstu(112))/6d0*
76999 & log(parj(169))*als2pi
77000 wtmax=max(0d0,1d0+wtopt+als2pi*wtmx)
77001
77002C...Choose three-jet events in allowed region.
77003 100 njet=3
77004 110 y13l=cutl+cutd*pyr(0)
77005 y23l=cutl+cutd*pyr(0)
77006 y13=exp(y13l)
77007 y23=exp(y23l)
77008 y12=1d0-y13-y23
77009 IF(y12.LE.cut) GOTO 110
77010 IF(y13**2+y23**2+2d0*y12.LE.2d0*pyr(0)) GOTO 110
77011
77012C...Second order corrections.
77013 IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN
77014 y12l=log(y12)
77015 y13m=log(1d0-y13)
77016 y23m=log(1d0-y23)
77017 y12m=log(1d0-y12)
77018 IF(y13.LE.0.5d0) y13i=dilog(y13)
77019 IF(y13.GE.0.5d0) y13i=1.644934d0-y13l*y13m-dilog(1d0-y13)
77020 IF(y23.LE.0.5d0) y23i=dilog(y23)
77021 IF(y23.GE.0.5d0) y23i=1.644934d0-y23l*y23m-dilog(1d0-y23)
77022 IF(y12.LE.0.5d0) y12i=dilog(y12)
77023 IF(y12.GE.0.5d0) y12i=1.644934d0-y12l*y12m-dilog(1d0-y12)
77024 wt1=(y13**2+y23**2+2d0*y12)/(y13*y23)
77025 wt2=cf*(-2d0*(cutl-y12l)**2-3d0*cutl-1d0+3.289868d0+
77026 & 2d0*(2d0*cutl-y12l)*cut/y12)+
77027 & cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-
77028 & 11d0*cutl/6d0+67d0/18d0+1.644934d0-(2d0*cutl-y12l)*cut/y12+
77029 & (2d0*cutl-y13l)*cut/y13+(2d0*cutl-y23l)*cut/y23)+
77030 & tr*(2d0*cutl/3d0-10d0/9d0)+
77031 & cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+
77032 & y13l*(4d0*y12**2+2d0*y12*y13+4d0*y12*y23+y13*y23)/
77033 & (y12+y23)**2+y23l*(4d0*y12**2+2d0*y12*y23+4d0*y12*y13+
77034 & y13*y23)/(y12+y13)**2)/wt1+
77035 & cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+(cn-2d0*cf)*
77036 & ((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*
77037 & y23m+1.644934d0-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*
77038 & (y12l*y13l-y12l*y12m-y13l*y13m+1.644934d0-y12i-y13i)/
77039 & (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-
77040 & 2d0*y12l*y12**2/(y13+y23)**2-4d0*y12l*y12/(y13+y23))/wt1-
77041 & cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934d0-y13i-y23i)
77042 IF(1d0+wtopt+als2pi*wt2.LE.0d0) mstj(121)=1
77043 IF(1d0+wtopt+als2pi*wt2.LE.wtmax*pyr(0)) GOTO 110
77044 parj(156)=(wtopt+als2pi*wt2)/(1d0+wtopt+als2pi*wt2)
77045
77046 ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN
77047C...Second order corrections; Zhu parametrization of ERT.
77048 zx=(y23-y13)**2
77049 zy=1d0-y12
77050 iza=0
77051 DO 120 iy=1,5
77052 IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy
77053 120 CONTINUE
77054 IF(iza.NE.0) THEN
77055 iz=iza
77056 wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
77057 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
77058 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
77059 & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
77060 ELSE
77061 iz=100d0*cut
77062 wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
77063 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
77064 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
77065 & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
77066 iz=iz+1
77067 wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+
77068 & zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+
77069 & (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+
77070 & zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy
77071 wt2=wtl+(wtu-wtl)*(100d0*cut+1d0-iz)
77072 ENDIF
77073 IF(1d0+wtopt+2d0*als2pi*wt2.LE.0d0) mstj(121)=1
77074 IF(1d0+wtopt+2d0*als2pi*wt2.LE.wtmax*pyr(0)) GOTO 110
77075 parj(156)=(wtopt+2d0*als2pi*wt2)/(1d0+wtopt+2d0*als2pi*wt2)
77076 ENDIF
77077
77078C...Impose mass cuts (gives two jets). For fixed jet number new try.
77079 x1=1d0-y23
77080 x2=1d0-y13
77081 x3=1d0-y12
77082 IF(4d0*y23*y13*y12/x3**2.LE.qme) njet=2
77083 IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+
77084 & 0.5d0*qme**2+(0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/(1d0-x1)+
77085 & (1d0-x1)/(1d0-x2)).GT.(x1**2+x2**2)*pyr(0)) njet=2
77086 IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 100
77087
77088C...Scalar gluon model (first order only, no mass effects).
77089 ELSE
77090 130 njet=3
77091 140 x3=sqrt(4d0*cut**2+pyr(0)*((1d0-cut)**2-4d0*cut**2))
77092 IF(log((x3-cut)/cut).LE.pyr(0)*log((1d0-2d0*cut)/cut)) GOTO 140
77093 yd=sign(2d0*cut*((x3-cut)/cut)**pyr(0)-x3,pyr(0)-0.5d0)
77094 x1=1d0-0.5d0*(x3+yd)
77095 x2=1d0-0.5d0*(x3-yd)
77096 IF(4d0*(1d0-x1)*(1d0-x2)*(1d0-x3)/x3**2.LE.qme) njet=2
77097 IF(mstj(102).GE.2) THEN
77098 IF(x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*parj(171).LT.
77099 & x3**2*pyr(0)) njet=2
77100 ENDIF
77101 IF(mstj(101).EQ.-1.AND.njet.EQ.2) GOTO 130
77102 ENDIF
77103
77104 RETURN
77105 END
77106
77107C*********************************************************************
77108
77109C...PYX4JT
77110C...Selects the kinematical variables of four-jet events.
77111
77112 SUBROUTINE pyx4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77113
77114C...Double precision and integer declarations.
77115 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77116 IMPLICIT INTEGER(I-N)
77117 INTEGER PYK,PYCHGE,PYCOMP
77118C...Commonblocks.
77119 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77120 SAVE /pydat1/
77121C...Local arrays.
77122 dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)
77123
77124C...Common constants. Colour factors for QCD and Abelian gluon theory.
77125 pmq=pymass(kfl)
77126 qme=(2d0*pmq/ecm)**2
77127 ct=log(1d0/cut-5d0)
77128 IF(mstj(109).EQ.0) THEN
77129 cf=4d0/3d0
77130 cn=3d0
77131 tr=2.5d0
77132 ELSE
77133 cf=1d0
77134 cn=0d0
77135 tr=15d0
77136 ENDIF
77137
77138C...Choice of process (qqbargg or qqbarqqbar).
77139 100 njet=4
77140 it=1
77141 IF(parj(155).GT.pyr(0)) it=2
77142 IF(mstj(101).LE.-3) it=-mstj(101)-2
77143 IF(it.EQ.1) wtmx=0.7d0/cut**2
77144 IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6d0/cut**2
77145 IF(it.EQ.2) wtmx=0.1125d0*cf*tr/cut**2
77146 id=1
77147
77148C...Sample the five kinematical variables (for qqgg preweighted in y34).
77149 110 y134=3d0*cut+(1d0-6d0*cut)*pyr(0)
77150 y234=3d0*cut+(1d0-6d0*cut)*pyr(0)
77151 IF(it.EQ.1) y34=(1d0-5d0*cut)*exp(-ct*pyr(0))
77152 IF(it.EQ.2) y34=cut+(1d0-6d0*cut)*pyr(0)
77153 IF(y34.LE.y134+y234-1d0.OR.y34.GE.y134*y234) GOTO 110
77154 vt=pyr(0)
77155 cp=cos(paru(1)*pyr(0))
77156 y14=(y134-y34)*vt
77157 y13=y134-y14-y34
77158 vb=y34*(1d0-y134-y234+y34)/((y134-y34)*(y234-y34))
77159 y24=0.5d0*(y234-y34)*(1d0-4d0*sqrt(max(0d0,vt*(1d0-vt)*
77160 &vb*(1d0-vb)))*cp-(1d0-2d0*vt)*(1d0-2d0*vb))
77161 y23=y234-y34-y24
77162 y12=1d0-y134-y23-y24
77163 IF(min(y12,y13,y14,y23,y24).LE.cut) GOTO 110
77164 y123=y12+y13+y23
77165 y124=y12+y14+y24
77166
77167C...Calculate matrix elements for qqgg or qqqq process.
77168 ic=0
77169 wttot=0d0
77170 120 ic=ic+1
77171 IF(it.EQ.1) THEN
77172 wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3d0*y12*y23*y34+
77173 & 3d0*y12*y14*y34+4d0*y12**2*y34-y13*y23*y24+2d0*y12*y23*y24-
77174 & y13*y14*y24-2d0*y12*y13*y24+2d0*y12**2*y24+y14*y23**2+2d0*y12*
77175 & y23**2+y14**2*y23+4d0*y12*y14*y23+4d0*y12**2*y23+2d0*y12*y14**2+
77176 & 2d0*y12*y13*y14+4d0*y12**2*y14+2d0*y12**2*y13+2d0*y12**3)/
77177 & (2d0*y13*y134*y234*y24)+(y24*y34+y12*y34+y13*y24-
77178 & y14*y23+y12*y13)/(y13*y134**2)+2d0*y23*(1d0-y13)/
77179 & (y13*y134*y24)+y34/(2d0*y13*y24)
77180 wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2d0*y12*
77181 & y14*y24)/(y13*y134*y23*y14)+y12*(1d0+y34)*y124/(y134*y234*y14*
77182 & y24)-(2d0*y13*y24+y14**2+y13*y23+2d0*y12*y13)/(y13*y134*y14)+
77183 & y12*y123*y124/(2d0*y13*y14*y23*y24)
77184 wtc(ic)=-(5d0*y12*y34**2+2d0*y12*y24*y34+2d0*y12*y23*y34+
77185 & 2d0*y12*y14*y34+2d0*y12*y13*y34+4d0*y12**2*y34-y13*y24**2+
77186 & y14*y23*y24+y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-
77187 & 3d0*y12*y13*y24-y14*y23**2-y14**2*y23+y13*y14*y23-
77188 & 3d0*y12*y14*y23-y12*y13*y23)/(4d0*y134*y234*y34**2)+
77189 & (3d0*y12*y34**2-3d0*y13*y24*y34+3d0*y12*y24*y34+
77190 & 3d0*y14*y23*y34-y13*y24**2-y12*y23*y34+6d0*y12*y14*y34+
77191 & 2d0*y12*y13*y34-2d0*y12**2*y34+y14*y23*y24-3d0*y13*y23*y24-
77192 & 2d0*y13*y14*y24+4d0*y12*y14*y24+2d0*y12*y13*y24+
77193 & 3d0*y14*y23**2+2d0*y14**2*y23+2d0*y14**2*y12+
77194 & 2d0*y12**2*y14+6d0*y12*y14*y23-2d0*y12*y13**2-
77195 & 2d0*y12**2*y13)/(4d0*y13*y134*y234*y34)
77196 wtc(ic)=wtc(ic)+(2d0*y12*y34**2-2d0*y13*y24*y34+y12*y24*y34+
77197 & 4d0*y13*y23*y34+4d0*y12*y14*y34+2d0*y12*y13*y34+2d0*y12**2*y34-
77198 & y13*y24**2+3d0*y14*y23*y24+4d0*y13*y23*y24-2d0*y13*y14*y24+
77199 & 4d0*y12*y14*y24+2d0*y12*y13*y24+2d0*y14*y23**2+4d0*y13*y23**2+
77200 & 2d0*y13*y14*y23+2d0*y12*y14*y23+4d0*y12*y13*y23+2d0*y12*y14**2+
77201 & 4d0*y12**2*y13+4d0*y12*y13*y14+2d0*y12**2*y14)/
77202 & (4d0*y13*y134*y24*y34)-(y12*y34**2-2d0*y14*y24*y34-
77203 & 2d0*y13*y24*y34-y14*y23*y34+y13*y23*y34+y12*y14*y34+
77204 & 2d0*y12*y13*y34-2d0*y14**2*y24-4d0*y13*y14*y24-
77205 & 4d0*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-
77206 & y12*y13**2)/(2d0*y13*y34*y134**2)+(y12*y34**2-
77207 & 4d0*y14*y24*y34-2d0*y13*y24*y34-2d0*y14*y23*y34-
77208 & 4d0*y13*y23*y34-4d0*y12*y14*y34-4d0*y12*y13*y34-
77209 & 2d0*y13*y14*y24+2d0*y13**2*y24+2d0*y14**2*y23-
77210 & 2d0*y13*y14*y23-y12*y14**2-6d0*y12*y13*y14-
77211 & y12*y13**2)/(4d0*y34**2*y134**2)
77212 wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5d0*cn)*wtb(ic)+
77213 & cn*wtc(ic))/8d0
77214 ELSE
77215 wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2d0*y12*
77216 & y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*
77217 & y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*
77218 & y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*
77219 & y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+
77220 & y13*y14*y24+2d0*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+
77221 & y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*
77222 & y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-
77223 & y13**2*y24+y23*y14**2)/(y13**2*y134*y123)
77224 wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*
77225 & y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*
77226 & y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*
77227 & y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+
77228 & (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+
77229 & y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*
77230 & y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*
77231 & y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)
77232 wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5d0*cn)*wte(ic))/16d0
77233 ENDIF
77234
77235C...Permutations of momenta in matrix element. Weighting.
77236 130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN
77237 ysav=y13
77238 y13=y14
77239 y14=ysav
77240 ysav=y23
77241 y23=y24
77242 y24=ysav
77243 ysav=y123
77244 y123=y124
77245 y124=ysav
77246 ENDIF
77247 IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN
77248 ysav=y13
77249 y13=y23
77250 y23=ysav
77251 ysav=y14
77252 y14=y24
77253 y24=ysav
77254 ysav=y134
77255 y134=y234
77256 y234=ysav
77257 ENDIF
77258 IF(ic.LE.3) GOTO 120
77259 IF(id.EQ.1.AND.wttot.LT.pyr(0)*wtmx) GOTO 110
77260 ic=5
77261
77262C...qqgg events: string configuration and event type.
77263 IF(it.EQ.1) THEN
77264 IF(mstj(109).EQ.0.AND.id.EQ.1) THEN
77265 parj(156)=y34*(2d0*(wta(1)+wta(2)+wta(3)+wta(4))+4d0*(wtc(1)+
77266 & wtc(2)+wtc(3)+wtc(4)))/(9d0*wttot)
77267 IF(wta(2)+wta(4)+2d0*(wtc(2)+wtc(4)).GT.pyr(0)*(wta(1)+wta(2)+
77268 & wta(3)+wta(4)+2d0*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2
77269 IF(id.EQ.2) GOTO 130
77270 ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN
77271 parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8d0*wttot)
77272 IF(wta(2)+wta(4).GT.pyr(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2
77273 IF(id.EQ.2) GOTO 130
77274 ENDIF
77275 mstj(120)=3
77276 IF(mstj(109).EQ.0.AND.0.5d0*y34*(wtc(1)+wtc(2)+wtc(3)+
77277 & wtc(4)).GT.pyr(0)*wttot) mstj(120)=4
77278 kfln=21
77279
77280C...Mass cuts. Kinematical variables out.
77281 IF(y12.LE.cut+qme) njet=2
77282 IF(njet.EQ.2) GOTO 150
77283 q12=0.5d0*(1d0-sqrt(1d0-qme/y12))
77284 x1=1d0-(1d0-q12)*y234-q12*y134
77285 x4=1d0-(1d0-q12)*y134-q12*y234
77286 x2=1d0-y124
77287 x12=(1d0-q12)*y13+q12*y23
77288 x14=y12-0.5d0*qme
77289 IF(y134*y234/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
77290
77291C...qqbarqqbar events: string configuration, choose new flavour.
77292 ELSE
77293 IF(id.EQ.1) THEN
77294 wtr=pyr(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))
77295 IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2
77296 IF(wtr.LT.wtd(3)+wtd(4)) id=3
77297 IF(wtr.LT.wtd(4)) id=4
77298 IF(id.GE.2) GOTO 130
77299 ENDIF
77300 mstj(120)=5
77301 parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16d0*wttot)
77302 140 kfln=1+int(5d0*pyr(0))
77303 IF(kfln.NE.kfl.AND.0.2d0*parj(156).LE.pyr(0)) GOTO 140
77304 IF(kfln.EQ.kfl.AND.1d0-0.8d0*parj(156).LE.pyr(0)) GOTO 140
77305 IF(kfln.GT.mstj(104)) njet=2
77306 pmqn=pymass(kfln)
77307 qmen=(2d0*pmqn/ecm)**2
77308
77309C...Mass cuts. Kinematical variables out.
77310 IF(y24.LE.cut+qme.OR.y13.LE.1.1d0*qmen) njet=2
77311 IF(njet.EQ.2) GOTO 150
77312 q24=0.5d0*(1d0-sqrt(1d0-qme/y24))
77313 q13=0.5d0*(1d0-sqrt(1d0-qmen/y13))
77314 x1=1d0-(1d0-q24)*y123-q24*y134
77315 x4=1d0-(1d0-q24)*y134-q24*y123
77316 x2=1d0-(1d0-q13)*y234-q13*y124
77317 x12=(1d0-q24)*((1d0-q13)*y14+q13*y34)+q24*((1d0-q13)*y12+
77318 & q13*y23)
77319 x14=y24-0.5d0*qme
77320 x34=(1d0-q24)*((1d0-q13)*y23+q13*y12)+q24*((1d0-q13)*y34+
77321 & q13*y14)
77322 IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.
77323 & (parj(127)+pmq+pmqn)**2) njet=2
77324 IF(y123*y134/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2
77325 ENDIF
77326 150 IF(mstj(101).LE.-2.AND.njet.EQ.2) GOTO 100
77327
77328 RETURN
77329 END
77330
77331C*********************************************************************
77332
77333C...PYXDIF
77334C...Gives the angular orientation of events.
77335
77336 SUBROUTINE pyxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)
77337
77338C...Double precision and integer declarations.
77339 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77340 IMPLICIT INTEGER(I-N)
77341 INTEGER PYK,PYCHGE,PYCOMP
77342C...Commonblocks.
77343 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77344 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77345 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77346 SAVE /pyjets/,/pydat1/,/pydat2/
77347
77348C...Charge. Factors depending on polarization for QED case.
77349 qf=kchg(kfl,1)/3d0
77350 poll=1d0-parj(131)*parj(132)
77351 pold=parj(132)-parj(131)
77352 IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN
77353 hf1=poll
77354 hf2=0d0
77355 hf3=parj(133)**2
77356 hf4=0d0
77357
77358C...Factors depending on flavour, energy and polarization for QFD case.
77359 ELSE
77360 sff=1d0/(16d0*paru(102)*(1d0-paru(102)))
77361 sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)
77362 sfi=sfw*(1d0-(parj(123)/ecm)**2)
77363 ae=-1d0
77364 ve=4d0*paru(102)-1d0
77365 af=sign(1d0,qf)
77366 vf=af-4d0*qf*paru(102)
77367 hf1=qf**2*poll-2d0*qf*vf*sfi*sff*(ve*poll-ae*pold)+
77368 & (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2d0*ve*ae*pold)
77369 hf2=-2d0*qf*af*sfi*sff*(ae*poll-ve*pold)+2d0*vf*af*sfw*sff**2*
77370 & (2d0*ve*ae*poll-(ve**2+ae**2)*pold)
77371 hf3=parj(133)**2*(qf**2-2d0*qf*vf*sfi*sff*ve+(vf**2+af**2)*
77372 & sfw*sff**2*(ve**2-ae**2))
77373 hf4=-parj(133)**2*2d0*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*
77374 & sff*ae
77375 ENDIF
77376
77377C...Mass factor. Differential cross-sections for two-jet events.
77378 sq2=sqrt(2d0)
77379 qme=0d0
77380 IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.
77381 &mstj(109).NE.1) qme=(2d0*pymass(kfl)/ecm)**2
77382 IF(njet.EQ.2) THEN
77383 sigu=4d0*sqrt(1d0-qme)
77384 sigl=2d0*qme*sqrt(1d0-qme)
77385 sigt=0d0
77386 sigi=0d0
77387 siga=0d0
77388 sigp=4d0
77389
77390C...Kinematical variables. Reduce four-jet event to three-jet one.
77391 ELSE
77392 IF(njet.EQ.3) THEN
77393 x1=2d0*p(nc+1,4)/ecm
77394 x2=2d0*p(nc+3,4)/ecm
77395 ELSE
77396 ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+
77397 & (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)
77398 x1=2d0*p(nc+1,4)/ecmr
77399 x2=2d0*p(nc+4,4)/ecmr
77400 ENDIF
77401
77402C...Differential cross-sections for three-jet (or reduced four-jet).
77403 xq=(1d0-x1)/(1d0-x2)
77404 ct12=(x1*x2-2d0*x1-2d0*x2+2d0+qme)/sqrt((x1**2-qme)*(x2**2-qme))
77405 st12=sqrt(1d0-ct12**2)
77406 IF(mstj(109).NE.1) THEN
77407 sigu=2d0*x1**2+x2**2*(1d0+ct12**2)-qme*(3d0+ct12**2-x1-x2)-
77408 & qme*x1/xq+0.5d0*qme*((x2**2-qme)*st12**2-2d0*x2)*xq
77409 sigl=(x2*st12)**2-qme*(3d0-ct12**2-2.5d0*(x1+x2)+x1*x2+qme)+
77410 & 0.5d0*qme*(x1**2-x1-qme)/xq+0.5d0*qme*((x2**2-qme)*ct12**2-
77411 & x2)*xq
77412 sigt=0.5d0*(x2**2-qme-0.5d0*qme*(x2**2-qme)/xq)*st12**2
77413 sigi=((1d0-0.5d0*qme*xq)*(x2**2-qme)*st12*ct12+
77414 & qme*(1d0-x1-x2+0.5d0*x1*x2+0.5d0*qme)*st12/ct12)/sq2
77415 siga=x2**2*st12/sq2
77416 sigp=2d0*(x1**2-x2**2*ct12)
77417
77418C...Differential cross-sect for scalar gluons (no mass effects).
77419 ELSE
77420 x3=2d0-x1-x2
77421 xt=x2*st12
77422 ct13=sqrt(max(0d0,1d0-(xt/x3)**2))
77423 sigu=(1d0-parj(171))*(x3**2-0.5d0*xt**2)+
77424 & parj(171)*(x3**2-0.5d0*xt**2-4d0*(1d0-x1)*(1d0-x2)**2/x1)
77425 sigl=(1d0-parj(171))*0.5d0*xt**2+
77426 & parj(171)*0.5d0*(1d0-x1)**2*xt**2
77427 sigt=(1d0-parj(171))*0.25d0*xt**2+
77428 & parj(171)*0.25d0*xt**2*(1d0-2d0*x1)
77429 sigi=-(0.5d0/sq2)*((1d0-parj(171))*xt*x3*ct13+
77430 & parj(171)*xt*((1d0-2d0*x1)*x3*ct13-x1*(x1-x2)))
77431 siga=(0.25d0/sq2)*xt*(2d0*(1d0-x1)-x1*x3)
77432 sigp=x3**2-2d0*(1d0-x1)*(1d0-x2)/x1
77433 ENDIF
77434 ENDIF
77435
77436C...Upper bounds for differential cross-section.
77437 hf1a=abs(hf1)
77438 hf2a=abs(hf2)
77439 hf3a=abs(hf3)
77440 hf4a=abs(hf4)
77441 sigmax=(2d0*hf1a+hf3a+hf4a)*abs(sigu)+2d0*(hf1a+hf3a+hf4a)*
77442 &abs(sigl)+2d0*(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigt)+2d0*sq2*
77443 &(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigi)+4d0*sq2*hf2a*abs(siga)+
77444 &2d0*hf2a*abs(sigp)
77445
77446C...Generate angular orientation according to differential cross-sect.
77447 100 chi=paru(2)*pyr(0)
77448 cthe=2d0*pyr(0)-1d0
77449 phi=paru(2)*pyr(0)
77450 cchi=cos(chi)
77451 schi=sin(chi)
77452 c2chi=cos(2d0*chi)
77453 s2chi=sin(2d0*chi)
77454 the=acos(cthe)
77455 sthe=sin(the)
77456 c2phi=cos(2d0*(phi-parj(134)))
77457 s2phi=sin(2d0*(phi-parj(134)))
77458 sig=((1d0+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+
77459 &2d0*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+
77460 &2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*c2chi*c2phi-2d0*cthe*s2chi*
77461 &s2phi)*hf3-((1d0+cthe**2)*c2chi*s2phi+2d0*cthe*s2chi*c2phi)*hf4)*
77462 &sigt-2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*(cthe*cchi*c2phi-
77463 &schi*s2phi)*hf3+2d0*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+
77464 &4d0*sq2*sthe*cchi*hf2*siga+2d0*cthe*hf2*sigp
77465 IF(sig.LT.sigmax*pyr(0)) GOTO 100
77466
77467 RETURN
77468 END
77469
77470C*********************************************************************
77471
77472C...PYONIA
77473C...Generates Upsilon and toponium decays into three gluons
77474C...or two gluons and a photon.
77475
77476 SUBROUTINE pyonia(KFL,ECM)
77477
77478C...Double precision and integer declarations.
77479 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77480 IMPLICIT INTEGER(I-N)
77481 INTEGER PYK,PYCHGE,PYCOMP
77482C...Commonblocks.
77483 common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)
77484 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77485 common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)
77486 SAVE /pyjets/,/pydat1/,/pydat2/
77487
77488C...Printout. Check input parameters.
77489 IF(mstu(12).NE.12345) CALL pylist(0)
77490 IF(kfl.LT.0.OR.kfl.GT.8) THEN
77491 CALL pyerrm(16,'(PYONIA:) called with unknown flavour code')
77492 IF(mstu(21).GE.1) RETURN
77493 ENDIF
77494 IF(ecm.LT.parj(127)+2.02d0*parf(101)) THEN
77495 CALL pyerrm(16,'(PYONIA:) called with too small CM energy')
77496 IF(mstu(21).GE.1) RETURN
77497 ENDIF
77498
77499C...Initial e+e- and onium state (optional).
77500 nc=0
77501 IF(mstj(115).GE.2) THEN
77502 nc=nc+2
77503 CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)
77504 k(nc-1,1)=21
77505 CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)
77506 k(nc,1)=21
77507 ENDIF
77508 kflc=iabs(kfl)
77509 IF(mstj(115).GE.3.AND.kflc.GE.5) THEN
77510 nc=nc+1
77511 kf=110*kflc+3
77512 mstu10=mstu(10)
77513 mstu(10)=1
77514 p(nc,5)=ecm
77515 CALL py1ent(nc,kf,ecm,0d0,0d0)
77516 k(nc,1)=21
77517 k(nc,3)=1
77518 mstu(10)=mstu10
77519 ENDIF
77520
77521C...Choose x1 and x2 according to matrix element.
77522 ntry=0
77523 100 x1=pyr(0)
77524 x2=pyr(0)
77525 x3=2d0-x1-x2
77526 IF(x3.GE.1d0.OR.((1d0-x1)/(x2*x3))**2+((1d0-x2)/(x1*x3))**2+
77527 &((1d0-x3)/(x1*x2))**2.LE.2d0*pyr(0)) GOTO 100
77528 ntry=ntry+1
77529 njet=3
77530 IF(mstj(101).LE.4) CALL py3ent(nc+1,21,21,21,ecm,x1,x3)
77531 IF(mstj(101).GE.5) CALL py3ent(-(nc+1),21,21,21,ecm,x1,x3)
77532
77533C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77534 mstu(111)=mstj(108)
77535 IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))
77536 &mstu(111)=1
77537 paru(112)=parj(121)
77538 IF(mstu(111).EQ.2) paru(112)=parj(122)
77539 qf=0d0
77540 IF(kflc.NE.0) qf=kchg(kflc,1)/3d0
77541 rgam=7.2d0*qf**2*paru(101)/pyalps(ecm**2)
77542 mk=0
77543 ecmc=ecm
77544 IF(pyr(0).GT.rgam/(1d0+rgam)) THEN
77545 IF(1d0-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))
77546 & njet=2
77547 IF(njet.EQ.2.AND.mstj(101).LE.4) CALL py2ent(nc+1,21,21,ecm)
77548 IF(njet.EQ.2.AND.mstj(101).GE.5) CALL py2ent(-(nc+1),21,21,ecm)
77549 ELSE
77550 mk=1
77551 ecmc=sqrt(1d0-x1)*ecm
77552 IF(ecmc.LT.2d0*parj(127)) GOTO 100
77553 k(nc+1,1)=1
77554 k(nc+1,2)=22
77555 k(nc+1,4)=0
77556 k(nc+1,5)=0
77557 IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)
77558 IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)
77559 IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)
77560 IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)
77561 njet=2
77562 IF(ecmc.LT.4d0*parj(127)) THEN
77563 mstu10=mstu(10)
77564 mstu(10)=1
77565 p(nc+2,5)=ecmc
77566 CALL py1ent(nc+2,83,0.5d0*(x2+x3)*ecm,paru(1),0d0)
77567 mstu(10)=mstu10
77568 njet=0
77569 ENDIF
77570 ENDIF
77571 DO 110 ip=nc+1,n
77572 k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)
77573 110 CONTINUE
77574
77575C...Differential cross-sections. Upper limit for cross-section.
77576 IF(mstj(106).EQ.1) THEN
77577 sq2=sqrt(2d0)
77578 hf1=1d0-parj(131)*parj(132)
77579 hf3=parj(133)**2
77580 ct13=(x1*x3-2d0*x1-2d0*x3+2d0)/(x1*x3)
77581 st13=sqrt(1d0-ct13**2)
77582 sigl=0.5d0*x3**2*((1d0-x2)**2+(1d0-x3)**2)*st13**2
77583 sigu=(x1*(1d0-x1))**2+(x2*(1d0-x2))**2+(x3*(1d0-x3))**2-sigl
77584 sigt=0.5d0*sigl
77585 sigi=(sigl*ct13/st13+0.5d0*x1*x3*(1d0-x2)**2*st13)/sq2
77586 sigmax=(2d0*hf1+hf3)*abs(sigu)+2d0*(hf1+hf3)*abs(sigl)+2d0*(hf1+
77587 & 2d0*hf3)*abs(sigt)+2d0*sq2*(hf1+2d0*hf3)*abs(sigi)
77588
77589C...Angular orientation of event.
77590 120 chi=paru(2)*pyr(0)
77591 cthe=2d0*pyr(0)-1d0
77592 phi=paru(2)*pyr(0)
77593 cchi=cos(chi)
77594 schi=sin(chi)
77595 c2chi=cos(2d0*chi)
77596 s2chi=sin(2d0*chi)
77597 the=acos(cthe)
77598 sthe=sin(the)
77599 c2phi=cos(2d0*(phi-parj(134)))
77600 s2phi=sin(2d0*(phi-parj(134)))
77601 sig=((1d0+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2d0*(sthe**2*hf1-
77602 & sthe**2*c2phi*hf3)*sigl+2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*
77603 & c2chi*c2phi-2d0*cthe*s2chi*s2phi)*hf3)*sigt-
77604 & 2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*
77605 & (cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi
77606 IF(sig.LT.sigmax*pyr(0)) GOTO 120
77607 CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)
77608 CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)
77609 ENDIF
77610
77611C...Generate parton shower. Rearrange along strings and check.
77612 IF(mstj(101).GE.5.AND.njet.GE.2) THEN
77613 CALL pyshow(nc+mk+1,-njet,ecmc)
77614 mstj14=mstj(14)
77615 IF(mstj(105).EQ.-1) mstj(14)=-1
77616 IF(mstj(105).GE.0) mstu(28)=0
77617 CALL pyprep(0)
77618 mstj(14)=mstj14
77619 IF(mstj(105).GE.0.AND.mstu(28).NE.0) GOTO 100
77620 ENDIF
77621
77622C...Generate fragmentation. Information for PYTABU:
77623 IF(mstj(105).EQ.1) CALL pyexec
77624 mstu(161)=110*kflc+3
77625 mstu(162)=0
77626
77627 RETURN
77628 END
77629
77630C*********************************************************************
77631
77632C...PYBOOK
77633C...Books a histogram.
77634
77635 SUBROUTINE pybook(ID,TITLE,NX,XL,XU)
77636
77637C...Double precision declaration.
77638 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77639 IMPLICIT INTEGER(I-N)
77640C...Commonblock.
77641 common/pybins/ihist(4),indx(1000),bin(20000)
77642 SAVE /pybins/
77643C...Local character variables.
77644 CHARACTER TITLE*(*), TITFX*60
77645
77646C...Check that input is sensible. Find initial address in memory.
77647 IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
77648 &'(PYBOOK:) not allowed histogram number')
77649 IF(nx.LE.0.OR.nx.GT.100) CALL pyerrm(28,
77650 &'(PYBOOK:) not allowed number of bins')
77651 IF(xl.GE.xu) CALL pyerrm(28,
77652 &'(PYBOOK:) x limits in wrong order')
77653 indx(id)=ihist(4)
77654 ihist(4)=ihist(4)+28+nx
77655 IF(ihist(4).GT.ihist(2)) CALL pyerrm(28,
77656 &'(PYBOOK:) out of histogram space')
77657 is=indx(id)
77658
77659C...Store histogram size and reset contents.
77660 bin(is+1)=nx
77661 bin(is+2)=xl
77662 bin(is+3)=xu
77663 bin(is+4)=(xu-xl)/nx
77664 CALL pynull(id)
77665
77666C...Store title by conversion to integer to double precision.
77667 titfx=title//' '
77668 DO 100 it=1,20
77669 bin(is+8+nx+it)=256**2*ichar(titfx(3*it-2:3*it-2))+
77670 & 256*ichar(titfx(3*it-1:3*it-1))+ichar(titfx(3*it:3*it))
77671 100 CONTINUE
77672
77673 RETURN
77674 END
77675
77676C*********************************************************************
77677
77678C...PYFILL
77679C...Fills entry in histogram.
77680
77681 SUBROUTINE pyfill(ID,X,W)
77682
77683C...Double precision declaration.
77684 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77685 IMPLICIT INTEGER(I-N)
77686C...Commonblock.
77687 common/pybins/ihist(4),indx(1000),bin(20000)
77688 SAVE /pybins/
77689
77690C...Find initial address in memory. Increase number of entries.
77691 IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
77692 &'(PYFILL:) not allowed histogram number')
77693 is=indx(id)
77694 IF(is.EQ.0) CALL pyerrm(28,
77695 &'(PYFILL:) filling unbooked histogram')
77696 bin(is+5)=bin(is+5)+1d0
77697
77698C...Find bin in x, including under/overflow, and fill.
77699 IF(x.LT.bin(is+2)) THEN
77700 bin(is+6)=bin(is+6)+w
77701 ELSEIF(x.GE.bin(is+3)) THEN
77702 bin(is+8)=bin(is+8)+w
77703 ELSE
77704 bin(is+7)=bin(is+7)+w
77705 ix=(x-bin(is+2))/bin(is+4)
77706 ix=max(0,min(nint(bin(is+1))-1,ix))
77707 bin(is+9+ix)=bin(is+9+ix)+w
77708 ENDIF
77709
77710 RETURN
77711 END
77712
77713C*********************************************************************
77714
77715C...PYFACT
77716C...Multiplies histogram contents by factor.
77717
77718 SUBROUTINE pyfact(ID,F)
77719
77720C...Double precision declaration.
77721 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77722 IMPLICIT INTEGER(I-N)
77723C...Commonblock.
77724 common/pybins/ihist(4),indx(1000),bin(20000)
77725 SAVE /pybins/
77726
77727C...Find initial address in memory. Multiply all contents bins.
77728 IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,
77729 &'(PYFACT:) not allowed histogram number')
77730 is=indx(id)
77731 IF(is.EQ.0) CALL pyerrm(28,
77732 &'(PYFACT:) scaling unbooked histogram')
77733 DO 100 ix=is+6,is+8+nint(bin(is+1))
77734 bin(ix)=f*bin(ix)
77735 100 CONTINUE
77736
77737 RETURN
77738 END
77739
77740C*********************************************************************
77741
77742C...PYOPER
77743C...Performs operations between histograms.
77744
77745 SUBROUTINE pyoper(ID1,OPER,ID2,ID3,F1,F2)
77746
77747C...Double precision declaration.
77748 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77749 IMPLICIT INTEGER(I-N)
77750C...Commonblock.
77751 common/pybins/ihist(4),indx(1000),bin(20000)
77752 SAVE /pybins/
77753C...Character variable.
77754 CHARACTER OPER*(*)
77755
77756C...Find initial addresses in memory, and histogram size.
77757 IF(id1.LE.0.OR.id1.GT.ihist(1)) CALL pyerrm(28,
77758 &'(PYFACT:) not allowed histogram number')
77759 is1=indx(id1)
77760 is2=indx(min(ihist(1),max(1,id2)))
77761 is3=indx(min(ihist(1),max(1,id3)))
77762 nx=nint(bin(is3+1))
77763 IF(oper.EQ.'M'.AND.id3.EQ.0) nx=nint(bin(is2+1))
77764
77765C...Update info on number of histogram entries.
77766 IF(oper.EQ.'+'.OR.oper.EQ.'-'.OR.oper.EQ.'*'.OR.oper.EQ.'/') THEN
77767 bin(is3+5)=bin(is1+5)+bin(is2+5)
77768 ELSEIF(oper.EQ.'A'.OR.oper.EQ.'S'.OR.oper.EQ.'L') THEN
77769 bin(is3+5)=bin(is1+5)
77770 ENDIF
77771
77772C...Operations on pair of histograms: addition, subtraction,
77773C...multiplication, division.
77774 IF(oper.EQ.'+') THEN
77775 DO 100 ix=6,8+nx
77776 bin(is3+ix)=f1*bin(is1+ix)+f2*bin(is2+ix)
77777 100 CONTINUE
77778 ELSEIF(oper.EQ.'-') THEN
77779 DO 110 ix=6,8+nx
77780 bin(is3+ix)=f1*bin(is1+ix)-f2*bin(is2+ix)
77781 110 CONTINUE
77782 ELSEIF(oper.EQ.'*') THEN
77783 DO 120 ix=6,8+nx
77784 bin(is3+ix)=f1*bin(is1+ix)*f2*bin(is2+ix)
77785 120 CONTINUE
77786 ELSEIF(oper.EQ.'/') THEN
77787 DO 130 ix=6,8+nx
77788 fa2=f2*bin(is2+ix)
77789 IF(abs(fa2).LE.1d-20) THEN
77790 bin(is3+ix)=0d0
77791 ELSE
77792 bin(is3+ix)=f1*bin(is1+ix)/fa2
77793 ENDIF
77794 130 CONTINUE
77795
77796C...Operations on single histogram: multiplication+addition,
77797C...square root+addition, logarithm+addition.
77798 ELSEIF(oper.EQ.'A') THEN
77799 DO 140 ix=6,8+nx
77800 bin(is3+ix)=f1*bin(is1+ix)+f2
77801 140 CONTINUE
77802 ELSEIF(oper.EQ.'S') THEN
77803 DO 150 ix=6,8+nx
77804 bin(is3+ix)=f1*sqrt(max(0d0,bin(is1+ix)))+f2
77805 150 CONTINUE
77806 ELSEIF(oper.EQ.'L') THEN
77807 zmin=1d20
77808 DO 160 ix=9,8+nx
77809 IF(bin(is1+ix).LT.zmin.AND.bin(is1+ix).GT.1d-20)
77810 & zmin=0.8d0*bin(is1+ix)
77811 160 CONTINUE
77812 DO 170 ix=6,8+nx
77813 bin(is3+ix)=f1*log10(max(zmin,bin(is1+ix)))+f2
77814 170 CONTINUE
77815
77816C...Operation on two or three histograms: average and
77817C...standard deviation.
77818 ELSEIF(oper.EQ.'M') THEN
77819 DO 180 ix=6,8+nx
77820 IF(abs(bin(is1+ix)).LE.1d-20) THEN
77821 bin(is2+ix)=0d0
77822 ELSE
77823 bin(is2+ix)=bin(is2+ix)/bin(is1+ix)
77824 ENDIF
77825 IF(id3.NE.0) THEN
77826 IF(abs(bin(is1+ix)).LE.1d-20) THEN
77827 bin(is3+ix)=0d0
77828 ELSE
77829 bin(is3+ix)=sqrt(max(0d0,bin(is3+ix)/bin(is1+ix)-
77830 & bin(is2+ix)**2))
77831 ENDIF
77832 ENDIF
77833 bin(is1+ix)=f1*bin(is1+ix)
77834 180 CONTINUE
77835 ENDIF
77836
77837 RETURN
77838 END
77839
77840C*********************************************************************
77841
77842C...PYHIST
77843C...Prints and resets all histograms.
77844
77845 SUBROUTINE pyhist
77846
77847C...Double precision declaration.
77848 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77849 IMPLICIT INTEGER(I-N)
77850C...Commonblock.
77851 common/pybins/ihist(4),indx(1000),bin(20000)
77852 SAVE /pybins/
77853
77854C...Loop over histograms, print and reset used ones.
77855 DO 100 id=1,ihist(1)
77856 is=indx(id)
77857 IF(is.NE.0.AND.nint(bin(is+5)).GT.0) THEN
77858 CALL pyplot(id)
77859 CALL pynull(id)
77860 ENDIF
77861 100 CONTINUE
77862
77863 RETURN
77864 END
77865
77866C*********************************************************************
77867
77868C...PYPLOT
77869C...Prints a histogram (but does not reset it).
77870
77871 SUBROUTINE pyplot(ID)
77872
77873C...Double precision declaration.
77874 IMPLICIT DOUBLE PRECISION(a-h, o-z)
77875 IMPLICIT INTEGER(I-N)
77876C...Commonblocks.
77877 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
77878 common/pybins/ihist(4),indx(1000),bin(20000)
77879 SAVE /pydat1/,/pybins/
77880C...Local arrays and character variables.
77881 dimension idati(6), irow(100), ifra(100), dyac(10)
77882 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77883
77884C...Steps in histogram scale. Character sequence.
77885 DATA dyac/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77886 DATA cha/'0','1','2','3','4','5','6','7','8','9','X','-'/
77887
77888C...Find initial address in memory; skip if empty histogram.
77889 IF(id.LE.0.OR.id.GT.ihist(1)) RETURN
77890 is=indx(id)
77891 IF(is.EQ.0) RETURN
77892 IF(nint(bin(is+5)).LE.0) THEN
77893 WRITE(mstu(11),5000) id
77894 RETURN
77895 ENDIF
77896
77897C...Number of histogram lines and x bins.
77898 lin=ihist(3)-18
77899 nx=nint(bin(is+1))
77900
77901C...Extract title by conversion from double precision via integer.
77902 DO 100 it=1,20
77903 ieq=nint(bin(is+8+nx+it))
77904 title(3*it-2:3*it)=char(ieq/256**2)//char(mod(ieq,256**2)/256)
77905 & //char(mod(ieq,256))
77906 100 CONTINUE
77907
77908C...Find time; print title.
77909 CALL pytime(idati)
77910 IF(idati(1).GT.0) THEN
77911 WRITE(mstu(11),5100) id, title, (idati(j),j=1,5)
77912 ELSE
77913 WRITE(mstu(11),5200) id, title
77914 ENDIF
77915
77916C...Find minimum and maximum bin content.
77917 ymin=bin(is+9)
77918 ymax=bin(is+9)
77919 DO 110 ix=is+10,is+8+nx
77920 IF(bin(ix).LT.ymin) ymin=bin(ix)
77921 IF(bin(ix).GT.ymax) ymax=bin(ix)
77922 110 CONTINUE
77923
77924C...Determine scale and step size for y axis.
77925 IF(ymax-ymin.GT.lin*dyac(1)*1d-9) THEN
77926 IF(ymin.GT.0d0.AND.ymin.LT.0.1d0*ymax) ymin=0d0
77927 IF(ymax.LT.0d0.AND.ymax.GT.0.1d0*ymin) ymax=0d0
77928 ipot=int(log10(ymax-ymin)+10d0)-10
77929 IF(ymax-ymin.LT.lin*dyac(1)*10d0**ipot) ipot=ipot-1
77930 IF(ymax-ymin.GT.lin*dyac(10)*10d0**ipot) ipot=ipot+1
77931 dely=dyac(1)
77932 DO 120 idel=1,9
77933 IF(ymax-ymin.GE.lin*dyac(idel)*10d0**ipot) dely=dyac(idel+1)
77934 120 CONTINUE
77935 dy=dely*10d0**ipot
77936
77937C...Convert bin contents to integer form; fractional fill in top row.
77938 DO 130 ix=1,nx
77939 cta=abs(bin(is+8+ix))/dy
77940 irow(ix)=sign(cta+0.95d0,bin(is+8+ix))
77941 ifra(ix)=10d0*(cta+1.05d0-dble(int(cta+0.95d0)))
77942 130 CONTINUE
77943 irmi=sign(abs(ymin)/dy+0.95d0,ymin)
77944 irma=sign(abs(ymax)/dy+0.95d0,ymax)
77945
77946C...Print histogram row by row.
77947 DO 150 ir=irma,irmi,-1
77948 IF(ir.EQ.0) GOTO 150
77949 out=' '
77950 DO 140 ix=1,nx
77951 IF(ir.EQ.irow(ix)) out(ix:ix)=cha(ifra(ix))
77952 IF(ir*(irow(ix)-ir).GT.0) out(ix:ix)=cha(10)
77953 140 CONTINUE
77954 WRITE(mstu(11),5300) ir*dely, ipot, out
77955 150 CONTINUE
77956
77957C...Print sign and value of bin contents.
77958 ipot=int(log10(max(ymax,-ymin))+10.0001d0)-10
77959 out=' '
77960 DO 160 ix=1,nx
77961 IF(bin(is+8+ix).LT.-10d0**(ipot-4)) out(ix:ix)=cha(11)
77962 irow(ix)=nint(10d0**(3-ipot)*abs(bin(is+8+ix)))
77963 160 CONTINUE
77964 WRITE(mstu(11),5400) out
77965 DO 180 ir=4,1,-1
77966 DO 170 ix=1,nx
77967 out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
77968 170 CONTINUE
77969 WRITE(mstu(11),5500) ipot+ir-4, out
77970 180 CONTINUE
77971
77972C...Print sign and value of lower bin edge.
77973 ipot=int(log10(max(-bin(is+2),bin(is+3)-bin(is+4)))+
77974 & 10.0001d0)-10
77975 out=' '
77976 DO 190 ix=1,nx
77977 IF(bin(is+2)+(ix-1)*bin(is+4).LT.-10d0**(ipot-3))
77978 & out(ix:ix)=cha(11)
77979 irow(ix)=nint(10d0**(2-ipot)*abs(bin(is+2)+(ix-1)*bin(is+4)))
77980 190 CONTINUE
77981 WRITE(mstu(11),5600) out
77982 DO 210 ir=3,1,-1
77983 DO 200 ix=1,nx
77984 out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))
77985 200 CONTINUE
77986 WRITE(mstu(11),5500) ipot+ir-3, out
77987 210 CONTINUE
77988 ENDIF
77989
77990C...Calculate and print statistics.
77991 csum=0d0
77992 cxsum=0d0
77993 cxxsum=0d0
77994 DO 220 ix=1,nx
77995 cta=abs(bin(is+8+ix))
77996 x=bin(is+2)+(ix-0.5d0)*bin(is+4)
77997 csum=csum+cta
77998 cxsum=cxsum+cta*x
77999 cxxsum=cxxsum+cta*x**2
78000 220 CONTINUE
78001 xmean=cxsum/max(csum,1d-20)
78002 xrms=sqrt(max(0d0,cxxsum/max(csum,1d-20)-xmean**2))
78003 WRITE(mstu(11),5700) nint(bin(is+5)),xmean,bin(is+6),
78004 &bin(is+2),bin(is+7),xrms,bin(is+8),bin(is+3)
78005
78006C...Formats for output.
78007 5000 FORMAT(/5x,'Histogram no',i5,' : no entries')
78008 5100 FORMAT('1'/5x,'Histogram no',i5,6x,a60,5x,i4,'-',i2,'-',i2,1x,
78009 &i2,':',i2/)
78010 5200 FORMAT('1'/5x,'Histogram no',i5,6x,a60/)
78011 5300 FORMAT(2x,f7.2,'*10**',i2,3x,a100)
78012 5400 FORMAT(/8x,'Contents',3x,a100)
78013 5500 FORMAT(9x,'*10**',i2,3x,a100)
78014 5600 FORMAT(/8x,'Low edge',3x,a100)
78015 5700 FORMAT(/5x,'Entries =',i12,1p,6x,'Mean =',d12.4,6x,'Underflow ='
78016 &,d12.4,6x,'Low edge =',d12.4/5x,'All chan =',d12.4,6x,
78017 &'Rms =',d12.4,6x,'Overflow =',d12.4,6x,'High edge =',d12.4)
78018
78019 RETURN
78020 END
78021
78022C*********************************************************************
78023
78024C...PYNULL
78025C...Resets bin contents of a histogram.
78026
78027 SUBROUTINE pynull(ID)
78028
78029C...Double precision declaration.
78030 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78031 IMPLICIT INTEGER(I-N)
78032C...Commonblock.
78033 common/pybins/ihist(4),indx(1000),bin(20000)
78034 SAVE /pybins/
78035
78036 IF(id.LE.0.OR.id.GT.ihist(1)) RETURN
78037 is=indx(id)
78038 IF(is.EQ.0) RETURN
78039 DO 100 ix=is+5,is+8+nint(bin(is+1))
78040 bin(ix)=0d0
78041 100 CONTINUE
78042
78043 RETURN
78044 END
78045
78046C*********************************************************************
78047
78048C...PYDUMP
78049C...Dumps histogram contents on file for reading by other program.
78050C...Can also read back own dump.
78051
78052 SUBROUTINE pydump(MDUMP,LFN,NHI,IHI)
78053
78054C...Double precision declaration.
78055 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78056 IMPLICIT INTEGER(I-N)
78057C...Commonblock.
78058 common/pybins/ihist(4),indx(1000),bin(20000)
78059 SAVE /pybins/
78060C...Local arrays and character variables.
78061 dimension ihi(*),iss(100),val(5)
78062 CHARACTER TITLE*60,FORMAT*13
78063
78064C...Dump all histograms that have been booked,
78065C...including titles and ranges, one after the other.
78066 IF(mdump.EQ.1) THEN
78067
78068C...Loop over histograms and find which are wanted and booked.
78069 IF(nhi.LE.0) THEN
78070 nw=ihist(1)
78071 ELSE
78072 nw=nhi
78073 ENDIF
78074 DO 130 iw=1,nw
78075 IF(nhi.EQ.0) THEN
78076 id=iw
78077 ELSE
78078 id=ihi(iw)
78079 ENDIF
78080 is=indx(id)
78081 IF(is.NE.0) THEN
78082
78083C...Write title, histogram size, filling statistics.
78084 nx=nint(bin(is+1))
78085 DO 100 it=1,20
78086 ieq=nint(bin(is+8+nx+it))
78087 title(3*it-2:3*it)=char(ieq/256**2)//
78088 & char(mod(ieq,256**2)/256)//char(mod(ieq,256))
78089 100 CONTINUE
78090 WRITE(lfn,5100) id,title
78091 WRITE(lfn,5200) nx,bin(is+2),bin(is+3)
78092 WRITE(lfn,5300) nint(bin(is+5)),bin(is+6),bin(is+7),
78093 & bin(is+8)
78094
78095
78096C...Write histogram contents, in groups of five.
78097 DO 120 ixg=1,(nx+4)/5
78098 DO 110 ixv=1,5
78099 ix=5*ixg+ixv-5
78100 IF(ix.LE.nx) THEN
78101 val(ixv)=bin(is+8+ix)
78102 ELSE
78103 val(ixv)=0d0
78104 ENDIF
78105 110 CONTINUE
78106 WRITE(lfn,5400) (val(ixv),ixv=1,5)
78107 120 CONTINUE
78108
78109C...Go to next histogram; finish.
78110 ELSEIF(nhi.GT.0) THEN
78111 CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
78112 ENDIF
78113 130 CONTINUE
78114
78115C...Read back in histograms dumped MDUMP=1.
78116 ELSEIF(mdump.EQ.2) THEN
78117
78118C...Read histogram number, title and range, and book.
78119 140 READ(lfn,5100,END=170) ID,title
78120 READ(lfn,5200) nx,xl,xu
78121 CALL pybook(id,title,nx,xl,xu)
78122 is=indx(id)
78123
78124C...Read filling statistics.
78125 READ(lfn,5300) nentry,bin(is+6),bin(is+7),bin(is+8)
78126 bin(is+5)=dble(nentry)
78127
78128C...Read histogram contents, in groups of five.
78129 DO 160 ixg=1,(nx+4)/5
78130 READ(lfn,5400) (val(ixv),ixv=1,5)
78131 DO 150 ixv=1,5
78132 ix=5*ixg+ixv-5
78133 IF(ix.LE.nx) bin(is+8+ix)=val(ixv)
78134 150 CONTINUE
78135 160 CONTINUE
78136
78137C...Go to next histogram; finish.
78138 GOTO 140
78139 170 CONTINUE
78140
78141C...Write histogram contents in column format,
78142C...convenient e.g. for GNUPLOT input.
78143 ELSEIF(mdump.EQ.3) THEN
78144
78145C...Find addresses to wanted histograms.
78146 nss=0
78147 IF(nhi.LE.0) THEN
78148 nw=ihist(1)
78149 ELSE
78150 nw=nhi
78151 ENDIF
78152 DO 180 iw=1,nw
78153 IF(nhi.EQ.0) THEN
78154 id=iw
78155 ELSE
78156 id=ihi(iw)
78157 ENDIF
78158 is=indx(id)
78159 IF(is.NE.0.AND.nss.LT.100) THEN
78160 nss=nss+1
78161 iss(nss)=is
78162 ELSEIF(nss.GE.100) THEN
78163 CALL pyerrm(8,'(PYDUMP:) too many histograms requested')
78164 ELSEIF(nhi.GT.0) THEN
78165 CALL pyerrm(8,'(PYDUMP:) unknown histogram number')
78166 ENDIF
78167 180 CONTINUE
78168
78169C...Check that they have common number of x bins. Fix format.
78170 nx=nint(bin(iss(1)+1))
78171 DO 190 iw=2,nss
78172 IF(nint(bin(iss(iw)+1)).NE.nx) THEN
78173 CALL pyerrm(8,'(PYDUMP:) different number of bins')
78174 RETURN
78175 ENDIF
78176 190 CONTINUE
78177 format='(1P,000E12.4)'
78178 WRITE(FORMAT(5:7),'(I3)') nss+1
78179
78180C...Write histogram contents; first column x values.
78181 DO 200 ix=1,nx
78182 x=bin(iss(1)+2)+(ix-0.5d0)*bin(iss(1)+4)
78183 WRITE(lfn,format) x, (bin(iss(iw)+8+ix),iw=1,nss)
78184 200 CONTINUE
78185
78186 ENDIF
78187
78188C...Formats for output.
78189 5100 FORMAT(i5,5x,a60)
78190 5200 FORMAT(i5,1p,2d12.4)
78191 5300 FORMAT(i12,1p,3d12.4)
78192 5400 FORMAT(1p,5d12.4)
78193
78194 RETURN
78195 END
78196
78197C*********************************************************************
78198
78199C...PYSTOP
78200C...Allows users to handle STOP statemens
78201
78202 SUBROUTINE pystop(MCOD)
78203
78204C...Double precision and integer declarations.
78205 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78206 IMPLICIT INTEGER(I-N)
78207 INTEGER PYK,PYCHGE,PYCOMP
78208C...Commonblocks.
78209 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78210 SAVE /pydat1/
78211
78212
78213C...Write message, then stop
78214 WRITE(mstu(11),5000) mcod
78215 stop
78216
78217
78218C...Formats for output.
78219 5000 FORMAT(/5x,'PYSTOP called with code: ',i4)
78220 END
78221
78222C*********************************************************************
78223
78224C...PYKCUT
78225C...Dummy routine, which the user can replace in order to make cuts on
78226C...the kinematics on the parton level before the matrix elements are
78227C...evaluated and the event is generated. The cross-section estimates
78228C...will automatically take these cuts into account, so the given
78229C...values are for the allowed phase space region only. MCUT=0 means
78230C...that the event has passed the cuts, MCUT=1 that it has failed.
78231
78232 SUBROUTINE pykcut(MCUT)
78233
78234C...Double precision and integer declarations.
78235 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78236 IMPLICIT INTEGER(I-N)
78237 INTEGER PYK,PYCHGE,PYCOMP
78238C...Commonblocks.
78239 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78240 common/pyint1/mint(400),vint(400)
78241 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
78242 SAVE /pydat1/,/pyint1/,/pyint2/
78243
78244C...Set default value (accepting event) for MCUT.
78245 mcut=0
78246
78247C...Read out subprocess number.
78248 isub=mint(1)
78249 istsb=iset(isub)
78250
78251C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78252 tau=vint(21)
78253 yst=vint(22)
78254 cth=0d0
78255 IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
78256 taup=0d0
78257 IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
78258
78259C...Calculate x_1, x_2, x_F.
78260 IF(istsb.LE.2.OR.istsb.GE.5) THEN
78261 x1=sqrt(tau)*exp(yst)
78262 x2=sqrt(tau)*exp(-yst)
78263 ELSE
78264 x1=sqrt(taup)*exp(yst)
78265 x2=sqrt(taup)*exp(-yst)
78266 ENDIF
78267 xf=x1-x2
78268
78269C...Calculate shat, that, uhat, p_T^2.
78270 shat=tau*vint(2)
78271 sqm3=vint(63)
78272 sqm4=vint(64)
78273 rm3=sqm3/shat
78274 rm4=sqm4/shat
78275 be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))
78276 rpts=4d0*vint(71)**2/shat
78277 be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))
78278 rm34=2d0*rm3*rm4
78279 rsqm=1d0+rm34
78280 rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)
78281 that=-0.5d0*shat*max(rthm,1d0-rm3-rm4-be34*cth)
78282 uhat=-0.5d0*shat*max(rthm,1d0-rm3-rm4+be34*cth)
78283 pt2=max(vint(71)**2,0.25d0*shat*be34**2*(1d0-cth**2))
78284
78285C...Decisions by user to be put here.
78286
78287C...Stop program if this routine is ever called.
78288C...You should not copy these lines to your own routine.
78289 WRITE(mstu(11),5000)
78290 CALL pystop(6)
78291
78292C...Format for error printout.
78293 5000 FORMAT(1x,'Error: you did not link your PYKCUT routine ',
78294 &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
78295 &1x,'Execution stopped!')
78296
78297 RETURN
78298 END
78299
78300C*********************************************************************
78301
78302C...PYEVWT
78303C...Dummy routine, which the user can replace in order to multiply the
78304C...standard PYTHIA differential cross-section by a process- and
78305C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78306C...to generation of weighted events, with weight 1/WTXS, while for
78307C...MSTP(142)=2 it corresponds to a modification of the underlying
78308C...physics.
78309
78310 SUBROUTINE pyevwt(WTXS)
78311
78312C...Double precision and integer declarations.
78313 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78314 IMPLICIT INTEGER(I-N)
78315 INTEGER PYK,PYCHGE,PYCOMP
78316C...Commonblocks.
78317 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78318 common/pyint1/mint(400),vint(400)
78319 common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)
78320 SAVE /pydat1/,/pyint1/,/pyint2/
78321
78322C...Set default weight for WTXS.
78323 wtxs=1d0
78324
78325C...Read out subprocess number.
78326 isub=mint(1)
78327 istsb=iset(isub)
78328
78329C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78330 tau=vint(21)
78331 yst=vint(22)
78332 cth=0d0
78333 IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)
78334 taup=0d0
78335 IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)
78336
78337C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78338 x1=vint(41)
78339 x2=vint(42)
78340 xf=x1-x2
78341 shat=vint(44)
78342 that=vint(45)
78343 uhat=vint(46)
78344 pt2=vint(48)
78345
78346C...Modifications by user to be put here.
78347
78348C...Stop program if this routine is ever called.
78349C...You should not copy these lines to your own routine.
78350 WRITE(mstu(11),5000)
78351 CALL pystop(4)
78352
78353C...Format for error printout.
78354 5000 FORMAT(1x,'Error: you did not link your PYEVWT routine ',
78355 &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
78356 &1x,'Execution stopped!')
78357
78358 RETURN
78359 END
78360
78361C*********************************************************************
78362
78363C...UPINIT
78364C...Dummy routine, to be replaced by a user implementing external
78365C...processes. Is supposed to fill the HEPRUP commonblock with info
78366C...on incoming beams and allowed processes.
78367
78368C...New example: handles a standard Les Houches Events File.
78369
78370 SUBROUTINE upinit
78371
78372C...Double precision and integer declarations.
78373 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78374 IMPLICIT INTEGER(I-N)
78375
78376C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78377 common/pypars/mstp(200),parp(200),msti(200),pari(200)
78378 SAVE /pypars/
78379
78380C...User process initialization commonblock.
78381 INTEGER MAXPUP
78382 parameter(maxpup=100)
78383 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78384 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78385 common/heprup/idbmup(2),ebmup(2),pdfgup(2),pdfsup(2),
78386 &idwtup,nprup,xsecup(maxpup),xerrup(maxpup),xmaxup(maxpup),
78387 &lprup(maxpup)
78388 SAVE /heprup/
78389
78390C...Lines to read in assumed never longer than 200 characters.
78391 parameter(maxlen=200)
78392 CHARACTER*(MAXLEN) STRING
78393
78394C...Format for reading lines.
78395 CHARACTER*6 STRFMT
78396 strfmt='(A000)'
78397 WRITE(strfmt(3:5),'(I3)') maxlen
78398
78399C...Loop until finds line beginning with "<init>" or "<init ".
78400 100 READ(mstp(161),strfmt,END=130,ERR=130) string
78401 ibeg=0
78402 110 ibeg=ibeg+1
78403C...Allow indentation.
78404 IF(string(ibeg:ibeg).EQ.' '.AND.ibeg.LT.maxlen-5) GOTO 110
78405 IF(string(ibeg:ibeg+5).NE.'<init>'.AND.
78406 &string(ibeg:ibeg+5).NE.'<init ') GOTO 100
78407
78408C...Read first line of initialization info.
78409 READ(mstp(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78410 &ebmup(2),pdfgup(1),pdfgup(2),pdfsup(1),pdfsup(2),idwtup,nprup
78411
78412C...Read NPRUP subsequent lines with information on each process.
78413 DO 120 ipr=1,nprup
78414 READ(mstp(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78415 & xmaxup(ipr),lprup(ipr)
78416 120 CONTINUE
78417 RETURN
78418
78419C...Error exit: give up if initalization does not work.
78420 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78421 WRITE(*,*) ' Event generation will be stopped.'
78422 CALL pystop(12)
78423
78424 RETURN
78425 END
78426
78427C...Old example: handles a simple Pythia 6.4 initialization file.
78428
78429c SUBROUTINE UPINIT
78430
78431C...Double precision and integer declarations.
78432c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78433c IMPLICIT INTEGER(I-N)
78434
78435C...Commonblocks.
78436c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78437c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78438c SAVE /PYDAT1/,/PYPARS/
78439
78440C...User process initialization commonblock.
78441c INTEGER MAXPUP
78442c PARAMETER (MAXPUP=100)
78443c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78444c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78445c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78446c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78447c &LPRUP(MAXPUP)
78448c SAVE /HEPRUP/
78449
78450C...Read info from file.
78451c IF(MSTP(161).GT.0) THEN
78452c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78453c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78454c DO 100 IPR=1,NPRUP
78455c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78456c & XMAXUP(IPR),LPRUP(IPR)
78457c 100 CONTINUE
78458c RETURN
78459C...Error or prematurely reached end of file.
78460c 110 WRITE(MSTU(11),5000)
78461c STOP
78462
78463C...Else not implemented.
78464c ELSE
78465c WRITE(MSTU(11),5100)
78466c STOP
78467c ENDIF
78468
78469C...Format for error printout.
78470c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78471c &1X,'Execution stopped!')
78472c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78473c &1X,'Dummy routine in PYTHIA file called instead.'/
78474c &1X,'Execution stopped!')
78475
78476c RETURN
78477c END
78478
78479C*********************************************************************
78480
78481C...UPEVNT
78482C...Dummy routine, to be replaced by a user implementing external
78483C...processes. Depending on cross section model chosen, it either has
78484C...to generate a process of the type IDPRUP requested, or pick a type
78485C...itself and generate this event. The event is to be stored in the
78486C...HEPEUP commonblock, including (often) an event weight.
78487
78488C...New example: handles a standard Les Houches Events File.
78489
78490 SUBROUTINE upevnt
78491
78492C...Double precision and integer declarations.
78493 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78494 IMPLICIT INTEGER(I-N)
78495
78496C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78497 common/pypars/mstp(200),parp(200),msti(200),pari(200)
78498 SAVE /pypars/
78499
78500C...User process event common block.
78501 INTEGER MAXNUP
78502 parameter(maxnup=500)
78503 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78504 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78505 common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
78506 &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
78507 &vtimup(maxnup),spinup(maxnup)
78508 SAVE /hepeup/
78509
78510C...Lines to read in assumed never longer than 200 characters.
78511 parameter(maxlen=200)
78512 CHARACTER*(MAXLEN) STRING
78513
78514C...Format for reading lines.
78515 CHARACTER*6 STRFMT
78516 strfmt='(A000)'
78517 WRITE(strfmt(3:5),'(I3)') maxlen
78518
78519C...Loop until finds line beginning with "<event>" or "<event ".
78520 100 READ(mstp(162),strfmt,END=130,ERR=130) string
78521 ibeg=0
78522 110 ibeg=ibeg+1
78523C...Allow indentation.
78524 IF(string(ibeg:ibeg).EQ.' '.AND.ibeg.LT.maxlen-6) GOTO 110
78525 IF(string(ibeg:ibeg+6).NE.'<event>'.AND.
78526 &string(ibeg:ibeg+6).NE.'<event ') GOTO 100
78527
78528C...Read first line of event info.
78529 READ(mstp(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78530 &aqedup,aqcdup
78531
78532C...Read NUP subsequent lines with information on each particle.
78533 DO 120 i=1,nup
78534 READ(mstp(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78535 & mothup(1,i),mothup(2,i),icolup(1,i),icolup(2,i),
78536 & (pup(j,i),j=1,5),vtimup(i),spinup(i)
78537 120 CONTINUE
78538 RETURN
78539
78540C...Error exit, typically when no more events.
78541 130 WRITE(*,*) ' Failed to read LHEF event information.'
78542 WRITE(*,*) ' Will assume end of file has been reached.'
78543 nup=0
78544 msti(51)=1
78545
78546 RETURN
78547 END
78548
78549C...Old example: handles a simple Pythia 6.4 event file.
78550
78551c SUBROUTINE UPEVNT
78552
78553C...Double precision and integer declarations.
78554c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78555c IMPLICIT INTEGER(I-N)
78556
78557C...Commonblocks.
78558c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78559c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78560c SAVE /PYDAT1/,/PYPARS/
78561
78562C...User process event common block.
78563c INTEGER MAXNUP
78564c PARAMETER (MAXNUP=500)
78565c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78566c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78567c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78568c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78569c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78570c SAVE /HEPEUP/
78571
78572C...Read info from file.
78573c IF(MSTP(162).GT.0) THEN
78574c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78575c & AQEDUP,AQCDUP
78576c DO 100 I=1,NUP
78577c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78578c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78579c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78580c 100 CONTINUE
78581c RETURN
78582C...Special when reached end of file or other error.
78583c 110 NUP=0
78584
78585C...Else not implemented.
78586c ELSE
78587c WRITE(MSTU(11),5000)
78588c STOP
78589c ENDIF
78590
78591C...Format for error printout.
78592c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78593c &1X,'Dummy routine in PYTHIA file called instead.'/
78594c &1X,'Execution stopped!')
78595
78596c RETURN
78597c END
78598
78599C*********************************************************************
78600
78601C...UPVETO
78602C...Dummy routine, to be replaced by user, to veto event generation
78603C...on the parton level, after parton showers but before multiple
78604C...interactions, beam remnants and hadronization is added.
78605C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78606C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78607C...be undecayed at this stage; if decayed their decay products will
78608C...have been allowed to shower.
78609
78610C...All partons at the end of the shower phase are stored in the
78611C...HEPEVT commonblock. The interesting information is
78612C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78613C...IDHEP(I) = the particle ID code according to PDG conventions,
78614C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78615C...All ISTHEP entries are 1, while the rest is zeroed.
78616
78617C...The user decision is to be conveyed by the IVETO value.
78618C...IVETO = 0 : retain current event and generate in full;
78619C... = 1 : abort generation of current event and move to next.
78620
78621 SUBROUTINE upveto(IVETO)
78622
78623C...HEPEVT commonblock.
78624 parameter(nmxhep=4000)
78625 common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),
78626 &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)
78627 DOUBLE PRECISION PHEP,VHEP
78628 SAVE /hepevt/
78629
78630C...Next few lines allow you to see what info PYVETO extracted from
78631C...the full event record for the first two events.
78632C...Delete if you don't want it.
78633 DATA nlist/0/
78634 SAVE nlist
78635 IF(nlist.LE.2) THEN
78636 WRITE(*,*) ' Full event record at time of UPVETO call:'
78637 CALL pylist(1)
78638 WRITE(*,*) ' Part of event record made available to UPVETO:'
78639 CALL pylist(5)
78640 nlist=nlist+1
78641 ENDIF
78642
78643C...Make decision here.
78644 iveto = 0
78645
78646 RETURN
78647 END
78648
78649C*********************************************************************
78650
78651C...PDFSET
78652C...Dummy routine, to be removed when PDFLIB is to be linked.
78653
78654 SUBROUTINE pdfset(PARM,VALUE)
78655
78656C...Double precision and integer declarations.
78657 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78658 IMPLICIT INTEGER(I-N)
78659 INTEGER PYK,PYCHGE,PYCOMP
78660C...Commonblocks.
78661 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78662 SAVE /pydat1/
78663C...Local arrays and character variables.
78664 CHARACTER*20 PARM(20)
78665 DOUBLE PRECISION VALUE(20)
78666
78667C...Stop program if this routine is ever called.
78668 WRITE(mstu(11),5000)
78669 CALL pystop(5)
78670 parm(20)=parm(1)
78671 value(20)=value(1)
78672
78673C...Format for error printout.
78674 5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
78675 &1x,'Dummy routine PDFSET in PYTHIA file called instead.'/
78676 &1x,'Execution stopped!')
78677
78678 RETURN
78679 END
78680
78681C*********************************************************************
78682
78683C...STRUCTM
78684C...Dummy routine, to be removed when PDFLIB is to be linked.
78685
78686 SUBROUTINE structm(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
78687
78688C...Double precision and integer declarations.
78689 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78690 IMPLICIT INTEGER(I-N)
78691 INTEGER PYK,PYCHGE,PYCOMP
78692C...Commonblocks.
78693 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78694 SAVE /pydat1/
78695C...Local variables
78696 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
78697
78698C...Stop program if this routine is ever called.
78699 WRITE(mstu(11),5000)
78700 CALL pystop(5)
78701 upv=xx+qq
78702 dnv=xx+2d0*qq
78703 usea=xx+3d0*qq
78704 dsea=xx+4d0*qq
78705 str=xx+5d0*qq
78706 chm=xx+6d0*qq
78707 bot=xx+7d0*qq
78708 top=xx+8d0*qq
78709 glu=xx+9d0*qq
78710
78711C...Format for error printout.
78712 5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
78713 &1x,'Dummy routine STRUCTM in PYTHIA file called instead.'/
78714 &1x,'Execution stopped!')
78715
78716 RETURN
78717 END
78718
78719C*********************************************************************
78720
78721C...STRUCTP
78722C...Dummy routine, to be removed when PDFLIB is to be linked.
78723
78724 SUBROUTINE structp(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
78725 &BOT,TOP,GLU)
78726
78727C...Double precision and integer declarations.
78728 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78729 IMPLICIT INTEGER(I-N)
78730 INTEGER PYK,PYCHGE,PYCOMP
78731C...Commonblocks.
78732 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78733 SAVE /pydat1/
78734C...Local variables
78735 DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
78736 &TOP,GLU
78737
78738C...Stop program if this routine is ever called.
78739 WRITE(mstu(11),5000)
78740 CALL pystop(5)
78741 upv=xx+qq2
78742 dnv=xx+2d0*qq2
78743 usea=xx+3d0*qq2
78744 dsea=xx+4d0*qq2
78745 str=xx+5d0*qq2
78746 chm=xx+6d0*qq2
78747 bot=xx+7d0*qq2
78748 top=xx+8d0*qq2
78749 glu=xx+9d0*qq2
78750
78751C...Format for error printout.
78752 5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/
78753 &1x,'Dummy routine STRUCTP in PYTHIA file called instead.'/
78754 &1x,'Execution stopped!')
78755
78756 RETURN
78757 END
78758
78759C*********************************************************************
78760
78761C...SUGRA
78762C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78763
78764 SUBROUTINE sugra(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78765 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78766 IMPLICIT INTEGER(I-N)
78767 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78768 INTEGER IMODL
78769C...Commonblocks.
78770 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78771 SAVE /pydat1/
78772
78773C...Stop program if this routine is ever called.
78774 WRITE(mstu(11),5000)
78775 CALL pystop(110)
78776
78777C...Format for error printout.
78778 5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
78779 &1x,'Dummy routine SUGRA in PYTHIA file called instead.'/
78780 &1x,'Execution stopped!')
78781
78782 RETURN
78783 END
78784
78785C*********************************************************************
78786
78787C...VISAJE
78788C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78789
78790 FUNCTION visaje()
78791 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78792 IMPLICIT INTEGER(I-N)
78793 CHARACTER*40 VISAJE
78794
78795C...Commonblocks.
78796 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78797 SAVE /pydat1/
78798
78799C...Assign default value.
78800 visaje='Undefined'
78801
78802C...Stop program if this routine is ever called.
78803 WRITE(mstu(11),5000)
78804 CALL pystop(110)
78805
78806C...Format for error printout.
78807 5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
78808 &1x,'Dummy function VISAJE in PYTHIA file called instead.'/
78809 &1x,'Execution stopped!')
78810
78811 RETURN
78812 END
78813
78814C*********************************************************************
78815
78816C...SSMSSM
78817C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78818
78819 SUBROUTINE ssmssm(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78820 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78821 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78822 &IDUM1,IDUM2)
78823 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78824 IMPLICIT INTEGER(I-N)
78825 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78826 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78827 &rdum19,rdum20,rdum21,rdum22,rdum23,rdum24,rdum25
78828C...Commonblocks.
78829 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78830 SAVE /pydat1/
78831
78832C...Stop program if this routine is ever called.
78833 WRITE(mstu(11),5000)
78834 CALL pystop(110)
78835
78836C...Format for error printout.
78837 5000 FORMAT(1x,'Error: you did not link ISAJET correctly.'/
78838 &1x,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78839 &1x,'Execution stopped!')
78840 RETURN
78841 END
78842
78843C*********************************************************************
78844
78845C...FHSETFLAGS
78846C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78847
78848 SUBROUTINE fhsetflags(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78849 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78850 IMPLICIT INTEGER(I-N)
78851Cmssmpart = 4 # full MSSM [recommended]
78852Cfieldren = 0 # MSbar field ren. [strongly recommended]
78853Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78854Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78855Cp2approx = 0 # no approximation [recommended]
78856Clooplevel= 2 # include 2-loop corrections
78857Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78858Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78859
78860C...Commonblocks.
78861 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78862 SAVE /pydat1/
78863
78864C...Stop program if this routine is ever called.
78865 WRITE(mstu(11),5000)
78866 CALL pystop(103)
78867
78868C...Format for error printout.
78869 5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
78870 &1x,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78871 &1x,'Execution stopped!')
78872 RETURN
78873 END
78874
78875C*********************************************************************
78876
78877C...FHSETPARA
78878C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78879
78880 SUBROUTINE fhsetpara(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78881 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78882 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78883 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78884 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78885 IMPLICIT INTEGER(I-N)
78886
78887 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78888 DOUBLE COMPLEX DMU,
78889 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78890 & DM1, DM2, DM3
78891
78892C...Commonblocks.
78893 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78894 SAVE /pydat1/
78895
78896C...Stop program if this routine is ever called.
78897 WRITE(mstu(11),5000)
78898 CALL pystop(103)
78899
78900C...Format for error printout.
78901 5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
78902 &1x,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78903 &1x,'Execution stopped!')
78904 RETURN
78905 END
78906
78907C*********************************************************************
78908
78909C...FHHIGGSCORR
78910C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78911
78912 SUBROUTINE fhhiggscorr(IERR, RMHIGG, SAEFF, UHIGGS)
78913 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78914 IMPLICIT INTEGER(I-N)
78915
78916C...FeynHiggs variables
78917 DOUBLE PRECISION RMHIGG(4)
78918 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78919 DOUBLE COMPLEX DMU,
78920 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78921 & DM1, DM2, DM3
78922
78923C...Commonblocks.
78924 common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
78925 SAVE /pydat1/
78926
78927C...Stop program if this routine is ever called.
78928 WRITE(mstu(11),5000)
78929 CALL pystop(103)
78930
78931C...Format for error printout.
78932 5000 FORMAT(1x,'Error: you did not link FEYNHIGGS correctly.'/
78933 &1x,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78934 &1x,'Execution stopped!')
78935 RETURN
78936 END
78937
78938C*********************************************************************
78939
78940C...PYTAUD
78941C...Dummy routine, to be replaced by user, to handle the decay of a
78942C...polarized tau lepton.
78943C...Input:
78944C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78945C...IORIG is the position where the mother of the tau is stored;
78946C... is 0 when the mother is not stored.
78947C...KFORIG is the flavour of the mother of the tau;
78948C... is 0 when the mother is not known.
78949C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78950C... e.g. in B hadron semileptonic decays the W propagator
78951C... is not explicitly stored but the W code is still unambiguous.
78952C...Output:
78953C...NDECAY is the number of decay products in the current tau decay.
78954C...These decay products should be added to the /PYJETS/ common block,
78955C...in positions N+1 through N+NDECAY. For each product I you must
78956C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78957C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78958
78959 SUBROUTINE pytaud(ITAU,IORIG,KFORIG,NDECAY)
78960
78961C...Double precision and integer declarations.
78962 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78963 IMPLICIT INTEGER(I-N)
78964 INTEGER PYK,PYCHGE,PYCOMP
78965C...Commonblocks.
78966 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78967 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78968 SAVE /PYJETS/,/PYDAT1/
78969
78970C...Stop program if this routine is ever called.
78971C...You should not copy these lines to your own routine.
78972 ndecay=itau+iorig+kforig
78973 WRITE(mstu(11),5000)
78974 CALL pystop(10)
78975
78976C...Format for error printout.
78977 5000 FORMAT(1x,'Error: you did not link your PYTAUD routine ',
78978 &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/
78979 &1x,'Execution stopped!')
78980
78981 RETURN
78982 END
78983
78984C*********************************************************************
78985
78986C...PYTIME
78987C...Finds current date and time.
78988C...Since this task is not standardized in Fortran 77, the routine
78989C...is dummy, to be replaced by the user. Examples are given for
78990C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78991C...you do not have access to suitable routines.
78992
78993 SUBROUTINE pytime(IDATI)
78994
78995C...Double precision and integer declarations.
78996 IMPLICIT DOUBLE PRECISION(a-h, o-z)
78997 IMPLICIT INTEGER(I-N)
78998 INTEGER PYK,PYCHGE,PYCOMP
78999 CHARACTER*8 ATIME
79000C...Local array.
79001 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
79002
79003C...Example 0: if you do not have suitable routines.
79004 DO 100 j=1,6
79005 idati(j)=0
79006 100 CONTINUE
79007
79008C...Example 1: Fortran 90 routine.
79009C CALL DATE_AND_TIME(VALUES=IVAL)
79010C IDATI(1)=IVAL(1)
79011C IDATI(2)=IVAL(2)
79012C IDATI(3)=IVAL(3)
79013C IDATI(4)=IVAL(5)
79014C IDATI(5)=IVAL(6)
79015C IDATI(6)=IVAL(7)
79016
79017C...Example 2: DEC Fortran 77. AIX.
79018C CALL IDATE(IMON,IDAY,IYEAR)
79019C IDATI(1)=IYEAR
79020C IDATI(2)=IMON
79021C IDATI(3)=IDAY
79022C CALL ITIME(IHOUR,IMIN,ISEC)
79023C IDATI(4)=IHOUR
79024C IDATI(5)=IMIN
79025C IDATI(6)=ISEC
79026
79027C...Example 3: DEC Fortran, IRIX, IRIX64.
79028C CALL IDATE(IMON,IDAY,IYEAR)
79029C IDATI(1)=IYEAR
79030C IDATI(2)=IMON
79031C IDATI(3)=IDAY
79032C CALL TIME(ATIME)
79033C IHOUR=0
79034C IMIN=0
79035C ISEC=0
79036C READ(ATIME(1:2),'(I2)') IHOUR
79037C READ(ATIME(4:5),'(I2)') IMIN
79038C READ(ATIME(7:8),'(I2)') ISEC
79039C IDATI(4)=IHOUR
79040C IDATI(5)=IMIN
79041C IDATI(6)=ISEC
79042
79043C...Example 4: GNU LINUX libU77, SunOS.
79044C CALL IDATE(IDTEMP)
79045C IDATI(1)=IDTEMP(3)
79046C IDATI(2)=IDTEMP(2)
79047C IDATI(3)=IDTEMP(1)
79048C CALL ITIME(IDTEMP)
79049C IDATI(4)=IDTEMP(1)
79050C IDATI(5)=IDTEMP(2)
79051C IDATI(6)=IDTEMP(3)
79052
79053C...Common code to ensure right century.
79054 idati(1)=2000+mod(idati(1),100)
79055
79056 RETURN
79057 END
STL class.