Analysis Software
Documentation for sPHENIX simulation software
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
jewel-2.2.0.f
Go to the documentation of this file. Or view the newest version in sPHENIX GitHub for file jewel-2.2.0.f
1 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 C++ Copyright (C) 2017 Korinna C. Zapp [Korinna.Zapp@cern.ch] ++
3 C++ ++
4 C++ This file is part of JEWEL 2.2.0 ++
5 C++ ++
6 C++ The JEWEL homepage is jewel.hepforge.org ++
7 C++ ++
8 C++ The medium model was partly implemented by Jochen Klein. ++
9 C++ Raghav Kunnawalkam Elayavalli helped with the implementation ++
10 C++ of the V+jet processes. ++
11 C++ ++
12 C++ Please follow the MCnet GUIDELINES and cite Eur.Phys.J. C74 ++
13 C++ (2014) no.2, 2762 [arXiv:1311.0048] for the code and ++
14 C++ JHEP 1303 (2013) 080 [arXiv:1212.1599] and ++
15 C++ optionally EPJC 60 (2009) 617 [arXiv:0804.3568] for the ++
16 C++ physics. The reference for V+jet processes is EPJC 76 (2016) ++
17 C++ no.12 695 [arXiv:1608.03099] and for recoil effects it is ++
18 C++ arXiv:1707.01539.
19 C++ ++
20 C++ JEWEL relies heavily on PYTHIA 6 for the event generation. The ++
21 C++ modified version of PYTHIA 6.4.25 that is distributed with ++
22 C++ JEWEL is, however, not an official PYTHIA release and must not ++
23 C++ be used for anything else. Please refer to results as ++
24 C++ "JEWEL+PYTHIA". ++
25 C++ ++
26 C++ JEWEL also uses code provided by S. Zhang and J. M. Jing ++
27 C++ (Computation of Special Functions, John Wiley & Sons, New York, ++
28 C++ 1996 and http://jin.ece.illinois.edu) for computing the ++
29 C++ exponential integral Ei(x). ++
30 C++ ++
31 C++ ++
32 C++ JEWEL is free software; you can redistribute it and/or ++
33 C++ modify it under the terms of the GNU General Public License ++
34 C++ as published by the Free Software Foundation; either version 2 ++
35 C++ of the License, or (at your option) any later version. ++
36 C++ ++
37 C++ JEWEL is distributed in the hope that it will be useful, ++
38 C++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++
39 C++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++
40 C++ GNU General Public License for more details. ++
41 C++ ++
42 C++ You should have received a copy of the GNU General Public ++
43 C++ License along with this program; if not, write to the Free ++
44 C++ Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, ++
45 C++ MA 02110-1301 USA ++
46 C++ ++
47 C++ Linking JEWEL statically or dynamically with other modules is ++
48 C++ making a combined work based on JEWEL. Thus, the terms and ++
49 C++ conditions of the GNU General Public License cover the whole ++
50 C++ combination. ++
51 C++ ++
52 C++ In addition, as a special exception, I give you permission to ++
53 C++ combine JEWEL with the code for the computation of special ++
54 C++ functions provided by S. Zhang and J. M. Jing. You may copy and ++
55 C++ distribute such a system following the terms of the GNU GPL for ++
56 C++ JEWEL and the licenses of the other code concerned, provided ++
57 C++ that you include the source code of that other code when and as ++
58 C++ the GNU GPL requires distribution of source code. ++
59 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
60 
61  PROGRAM jewel
62  IMPLICIT NONE
63 C--Common block of Pythia
64  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
65  INTEGER n,npad,k
66  DOUBLE PRECISION p,v
67  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
68  INTEGER mstu,mstj
69  DOUBLE PRECISION paru,parj
70  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
71  INTEGER mdcy,mdme,kfdp
72  DOUBLE PRECISION brat
73  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
74  INTEGER msel,mselpd,msub,kfin
75  DOUBLE PRECISION ckin
76  common/pypars/mstp(200),parp(200),msti(200),pari(200)
77  INTEGER mstp,msti
78  DOUBLE PRECISION parp,pari
79  common/pydatr/mrpy(6),rrpy(100)
80  INTEGER mrpy
81  DOUBLE PRECISION rrpy
82 C--identifier of file for hepmc output and logfile
83  common/hepmcid/hpmcfid,logfid
84  integer hpmcfid,logfid
85 C--use nuclear pdf?
86  common/npdf/mass,nset,eps09,initstr
87  INTEGER nset
88  DOUBLE PRECISION mass
89  LOGICAL eps09
90  CHARACTER*10 initstr
91 C--number of protons
92  common/np/nproton
93  integer nproton
94 C--organisation of event record
95  common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
96  &shorthepmc,channel,isochannel
97  integer nsim,npart,offset,hadrotype
98  double precision sqrts
99  character*4 collider,channel
100  character*2 isochannel
101  logical hadro,shorthepmc
102 C--discard event flag
103  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
104  LOGICAL discard
105  INTEGER ndisc,nstrange,ngood,errcount
106  double precision wdisc
107 C--event weight
108  common/weight/evweight,sumofweights
109  double precision evweight,sumofweights
110 C--number of scattering events
111  common/check/nscat,nscateff,nsplit
112  DOUBLE PRECISION nscat,nscateff,nsplit
113 C--number of extrapolations in tables
114  common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
115  &ntotxsec,noverxsec,ntotsuda,noversuda
116  integer ntotspliti,noverspliti,ntotpdf,noverpdf,
117  &ntotxsec,noverxsec,ntotsuda,noversuda
118 C--local variables
119  integer j,i,kk,poissonian
120  integer nsimpp,nsimpn,nsimnp,nsimnn,nsimsum,nsimchn
121  double precision sumofweightstot,wdisctot,scalefac
122  double precision gettemp,r,tau
123  character*2 b1,b2
124 
125  call init()
126 
127  sumofweightstot=0.d0
128  wdisctot=0.d0
129 
130 C--e+ + e- event generation
131  if (collider.eq.'EEJJ') then
132  b1 = 'e+'
133  b2 = 'e-'
134  write(logfid,*)
135  write(logfid,*)
136  &'####################################################'
137  write(logfid,*)
138  write(logfid,*)'generating ',nsim,' events in ',b1,' + ',b2,
139  &' channel'
140  write(logfid,*)
141  write(logfid,*)
142  &'####################################################'
143  write(logfid,*)
144  sumofweights=0.d0
145  wdisc=0.d0
146  call initpythia(b1,b2)
147  write(logfid,*)
148 C--e+ + e- event loop
149  DO 100 j=1,nsim
150  call genevent(j,b1,b2)
151  100 CONTINUE
152  sumofweightstot = sumofweightstot+sumofweights
153  wdisctot = wdisctot + wdisc
154  write(logfid,*)
155  write(logfid,*)'cross section in e+ + e- channel:',pari(1),'mb'
156  write(logfid,*)'sum of event weights in e+ + e- channel:',
157  & sumofweights-wdisc
158  write(logfid,*)
159 
160  else
161 C--hadronic event generation
162  if (isochannel.eq.'PP') then
163  nsimpp = nsim
164  nsimpn = 0
165  nsimnp = 0
166  nsimnn = 0
167  elseif (isochannel.eq.'PN') then
168  nsimpp = 0
169  nsimpn = nsim
170  nsimnp = 0
171  nsimnn = 0
172  elseif (isochannel.eq.'NP') then
173  nsimpp = 0
174  nsimpn = 0
175  nsimnp = nsim
176  nsimnn = 0
177  elseif (isochannel.eq.'NN') then
178  nsimpp = 0
179  nsimpn = 0
180  nsimnp = 0
181  nsimnn = nsim
182  else
183  nsimpp = poissonian(nsim*nproton**2/mass**2)
184  nsimpn = poissonian(nsim*nproton*(mass-nproton*1.d0)/mass**2)
185  nsimnp = poissonian(nsim*nproton*(mass-nproton*1.d0)/mass**2)
186  nsimnn = poissonian(nsim*(mass-nproton*1.d0)**2/mass**2)
187  nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
188  scalefac = nsim*1.d0/(nsimsum*1.d0)
189  nsimpp = int(nsimpp*scalefac)
190  nsimpn = int(nsimpn*scalefac)
191  nsimnp = int(nsimnp*scalefac)
192  nsimnn = int(nsimnn*scalefac)
193  nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
194  endif
195 C--loop over channels
196  do 101 kk=1,4
197  if (kk.eq.1) then
198  b1 = 'p+'
199  b2 = 'p+'
200  nsimchn = nsimpp
201  elseif (kk.eq.2) then
202  b1 = 'p+'
203  b2 = 'n0'
204  nsimchn = nsimpn
205  elseif (kk.eq.3) then
206  b1 = 'n0'
207  b2 = 'p+'
208  nsimchn = nsimnp
209  else
210  b1 = 'n0'
211  b2 = 'n0'
212  nsimchn = nsimnn
213  endif
214  write(logfid,*)
215  write(logfid,*)
216  &'####################################################'
217  write(logfid,*)
218  write(logfid,*)'generating ',nsimchn,' events in ',
219  &b1,' + ',b2,' channel'
220  write(logfid,*)
221  write(logfid,*)
222  &'####################################################'
223  write(logfid,*)
224  sumofweights=0.d0
225  wdisc=0.d0
226  call initpythia(b1,b2)
227  write(logfid,*)
228 C--event loop
229  DO 102 j=1,nsimchn
230  call genevent(j,b1,b2)
231  102 CONTINUE
232  sumofweightstot = sumofweightstot+sumofweights
233  wdisctot = wdisctot + wdisc
234  write(logfid,*)
235  write(logfid,*)'cross section in ',b1,' + ',b2,' channel:',
236  & pari(1),'mb'
237  write(logfid,*)'sum of event weights in ',b1,' + ',b2,
238  & ' channel:',sumofweights-wdisc
239  write(logfid,*)
240  101 continue
241  endif
242 
243 C--finish
244  WRITE(hpmcfid,'(A)')'HepMC::IO_GenEvent-END_EVENT_LISTING'
245  WRITE(hpmcfid,*)
246  CLOSE(hpmcfid,status='keep')
247 
248  write(logfid,*)
249  write(logfid,*)'mean number of scatterings:',
250  & nscat/(sumofweightstot-wdisctot)
251  write(logfid,*)'mean number of effective scatterings:',
252  & nscateff/(sumofweightstot-wdisctot)
253  write(logfid,*)'mean number of splittings:',
254  & nsplit/(sumofweightstot-wdisctot)
255  write(logfid,*)
256  write(logfid,*)'number of extrapolations in splitting integral: ',
257  & noverspliti,' (',(noverspliti*1.d0)/(ntotspliti*1.d0),'%)'
258  write(logfid,*)
259  & 'number of extrapolations in splitting partonic PDFs: ',
260  & noverpdf,' (',(noverpdf*1.d0)/(ntotpdf*1.d0),'%)'
261  write(logfid,*)
262  & 'number of extrapolations in splitting cross sections: ',
263  & noverxsec,' (',(noverxsec*1.d0)/(ntotxsec*1.d0),'%)'
264  write(logfid,*)
265  & 'number of extrapolations in Sudakov form factor: ',
266  & noversuda,' (',(noversuda*1.d0)/(ntotsuda*1.d0),'%)'
267  write(logfid,*)
268  write(logfid,*)'number of good events: ',ngood
269  write(logfid,*)'total number of discarded events: ',ndisc
270  write(logfid,*)'number of events for which conversion '//
271  &'to hepmc failed: ',nstrange
272  call printtime
273 
274  close(logfid,status='keep')
275 
276  END
277 
278 
279 
280 ***********************************************************************
281 ***********************************************************************
282 *** END OF MAIN PROGRAM - NOW COME THE SUBROUTINES ****************
283 ***********************************************************************
284 ***********************************************************************
285 
286 
287 ***********************************************************************
288 *** subroutine init
289 ***********************************************************************
290  subroutine init()
291  implicit none
292  INTEGER pycomp
293  INTEGER nmxhep
294 C--Common block of Pythia
295  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
296  INTEGER n,npad,k
297  DOUBLE PRECISION p,v
298  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
299  INTEGER mstu,mstj
300  DOUBLE PRECISION paru,parj
301  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
302  INTEGER mdcy,mdme,kfdp
303  DOUBLE PRECISION brat
304  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
305  INTEGER msel,mselpd,msub,kfin
306  DOUBLE PRECISION ckin
307  common/pypars/mstp(200),parp(200),msti(200),pari(200)
308  INTEGER mstp,msti
309  DOUBLE PRECISION parp,pari
310  common/pydatr/mrpy(6),rrpy(100)
311  INTEGER mrpy
312  DOUBLE PRECISION rrpy
313 C--use nuclear pdf?
314  common/npdf/mass,nset,eps09,initstr
315  INTEGER nset
316  DOUBLE PRECISION mass
317  LOGICAL eps09
318  CHARACTER*10 initstr
319 C--pdfset
320  common/pdf/pdfset
321  integer pdfset
322 C--number of protons
323  common/np/nproton
324  integer nproton
325 C--Parameter common block
326  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
327  &allhad,compress,nf
328  INTEGER nf
329  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
330  LOGICAL angord,scatrecoil,allhad,compress
331 C--splitting integral
332  common/splitint/splitiggv(1000,1000),splitiqqv(1000,1000),
333  &splitiqgv(1000,1000),qval(1000),zmval(1000),qmax,zmmin,npoint
334  INTEGER npoint
335  DOUBLE PRECISION splitiggv,splitiqqv,splitiqgv,
336  &qval,zmval,qmax,zmmin
337 C--pdf common block
338  common/pdfs/qinqx(2,1000),ginqx(2,1000),qingx(2,1000),
339  &gingx(2,1000)
340  DOUBLE PRECISION qinqx,ginqx,qingx,gingx
341 C--cross secttion common block
342  common/xsecs/intq1(1001,101),intq2(1001,101),
343  &intg1(1001,101),intg2(1001,101)
344  DOUBLE PRECISION intq1,intq2,intg1,intg2
345 C--Sudakov common block
346  common/insuda/sudaqq(1000,2),sudaqg(1000,2),sudagg(1000,2)
347  &,sudagc(1000,2)
348  DOUBLE PRECISION sudaqq,sudaqg,sudagg,sudagc
349 C--exponential integral for negative arguments
350  common/expint/eix(3,1000),valmax,nval
351  INTEGER nval
352  DOUBLE PRECISION eix,valmax
353 C--discard event flag
354  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
355  LOGICAL discard
356  INTEGER ndisc,nstrange,ngood,errcount
357  double precision wdisc
358 C--factor in front of formation times
359  common/ftimefac/ftfac
360  DOUBLE PRECISION ftfac
361 C--factor in front of alphas argument
362  common/alphasfac/ptfac
363  DOUBLE PRECISION ptfac
364 C--number of scattering events
365  common/check/nscat,nscateff,nsplit
366  DOUBLE PRECISION nscat,nscateff,nsplit
367 C--number of extrapolations in tables
368  common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
369  &ntotxsec,noverxsec,ntotsuda,noversuda
370  integer ntotspliti,noverspliti,ntotpdf,noverpdf,
371  &ntotxsec,noverxsec,ntotsuda,noversuda
372 C--event weight
373  common/weight/evweight,sumofweights
374  double precision evweight,sumofweights
375 C--event weight exponent
376  common/wexpo/weightex
377  DOUBLE PRECISION weightex
378 C--identifier of file for hepmc output and logfile
379  common/hepmcid/hpmcfid,logfid
380  integer hpmcfid,logfid
381 C--max rapidity
382  common/rapmax/etamax
383  double precision etamax
384 C--memory for error message from getdeltat
385  common/errline/errl
386  integer errl
387 C--organisation of event record
388  common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
389  &shorthepmc,channel,isochannel
390  integer nsim,npart,offset,hadrotype
391  double precision sqrts
392  character*4 collider,channel
393  character*2 isochannel
394  logical hadro,shorthepmc
395 C--extra storage for scattering centres before interactions
396  common/storescatcen/nscatcen,maxnscatcen,scatflav(10000),
397  &scatcen(10000,5),writescatcen,writedummies
398  integer nscatcen,maxnscatcen,scatflav
399  double precision scatcen
400  logical writescatcen,writedummies
401 C--Pythia parameters
402  common/pythiaparams/ptmin,ptmax,weighted
403  double precision ptmin,ptmax
404  LOGICAL weighted
405 
406 C--Variables local to this program
407  INTEGER njob,ios,pos,i,j,jj,intmass
408  DOUBLE PRECISION getltimemax,eovest,r,pyr
409  character firstchar
410  CHARACTER*2 snset
411  CHARACTER*80 pdffile,xsecfile,filemed,filesplit,buffer,
412  &label,value
413  CHARACTER*100 hepmcfile,logfile,filename2
414  CHARACTER(LEN=100) filename
415  LOGICAL pdfexist,splitiexist,xsecexist
416 
417  data maxnscatcen/10000/
418 
419  hpmcfid = 4
420  logfid = 3
421 
422 C--default settings
423  nsim = 10
424  njob = 0
425  logfile = 'out.log'
426  hepmcfile = 'out.hepmc'
427  filesplit = 'splitint.dat'
428  pdffile = 'pdfs.dat'
429  xsecfile = 'xsecs.dat'
430  filemed = 'medium-params.dat'
431  nf = 3
432  lqcd = 0.4
433  q0 = 1.5
434  ptmin = 5.
435  ptmax = 350.
436  etamax = 3.1
437  collider = 'PPJJ'
438  isochannel = 'XX'
439  channel = 'MUON'
440  sqrts = 2760
441  pdfset = 10042
442  nset = 1
443  mass = 208.
444  nproton = 82
445  weighted = .true.
446  weightex = 5.
447  angord = .true.
448  allhad = .false.
449  hadro = .true.
450  hadrotype = 0
451  shorthepmc = .true.
452  compress = .true.
453  writescatcen = .false.
454  writedummies = .false.
455 
456  lps = lqcd
457  scatrecoil = .false.
458  if (.not.hadro) shorthepmc = .true.
459 
460  scalefacm=1.
461  ptfac=1.
462  ftfac=1.d0
463 
464  if (iargc().eq.0) then
465  write(*,*)'No parameter file given, '//
466  &'will run with default settings.'
467  else
468  call getarg(1,filename)
469  write(*,*)'Reading parameters from ',filename
470  open(unit=1,file=filename,status='old',err=110)
471  do 120 i=1,1000
472  read(1, '(A)', iostat=ios) buffer
473  if(ios.ne.0) goto 130
474  firstchar = buffer(1:1)
475  if (firstchar.eq.'#') goto 120
476  pos=scan(buffer,' ')
477  label=buffer(1:pos)
478  value=buffer(pos+1:)
479  if(label.eq."NEVENT")then
480  read(value,*,iostat=ios) nsim
481  elseif(label.eq."NJOB")then
482  read(value,*,iostat=ios) njob
483  elseif(label.eq."LOGFILE")then
484  read(value,'(a)',iostat=ios) logfile
485  elseif(label.eq."HEPMCFILE")then
486  read(value,'(a)',iostat=ios) hepmcfile
487  elseif(label.eq."SPLITINTFILE")then
488  read(value,'(a)',iostat=ios) filesplit
489  elseif(label.eq."PDFFILE")then
490  read(value,'(a)',iostat=ios) pdffile
491  elseif(label.eq."XSECFILE")then
492  read(value,'(a)',iostat=ios) xsecfile
493  elseif(label.eq."MEDIUMPARAMS")then
494  read(value,'(a)',iostat=ios) filemed
495  elseif(label.eq."NF")then
496  read(value,*,iostat=ios) nf
497  elseif(label.eq."LAMBDAQCD")then
498  read(value,*,iostat=ios) lqcd
499  elseif(label.eq."Q0")then
500  read(value,*,iostat=ios) q0
501  elseif(label.eq."PTMIN")then
502  read(value,*,iostat=ios) ptmin
503  elseif(label.eq."PTMAX")then
504  read(value,*,iostat=ios) ptmax
505  elseif(label.eq."ETAMAX")then
506  read(value,*,iostat=ios) etamax
507  elseif(label.eq."PROCESS")then
508  read(value,*,iostat=ios) collider
509  elseif(label.eq."ISOCHANNEL")then
510  read(value,*,iostat=ios) isochannel
511  elseif(label.eq."CHANNEL")then
512  read(value,*,iostat=ios) channel
513  elseif(label.eq."SQRTS")then
514  read(value,*,iostat=ios) sqrts
515  elseif(label.eq."PDFSET")then
516  read(value,*,iostat=ios) pdfset
517  elseif(label.eq."NSET")then
518  read(value,*,iostat=ios) nset
519  elseif(label.eq."MASS")then
520  read(value,*,iostat=ios) mass
521  elseif(label.eq."NPROTON")then
522  read(value,*,iostat=ios) nproton
523  elseif(label.eq."WEIGHTED")then
524  read(value,*,iostat=ios) weighted
525  elseif(label.eq."WEXPO")then
526  read(value,*,iostat=ios) weightex
527  elseif(label.eq."ANGORD")then
528  read(value,*,iostat=ios) angord
529  elseif(label.eq."KEEPRECOILS")then
530  read(value,*,iostat=ios) allhad
531  elseif(label.eq."HADRO")then
532  read(value,*,iostat=ios) hadro
533  elseif(label.eq."HADROTYPE")then
534  read(value,*,iostat=ios) hadrotype
535  elseif(label.eq."SHORTHEPMC")then
536  read(value,*,iostat=ios) shorthepmc
537  elseif(label.eq."COMPRESS")then
538  read(value,*,iostat=ios) compress
539  elseif(label.eq."WRITESCATCEN")then
540  read(value,*,iostat=ios) writescatcen
541  elseif(label.eq."WRITEDUMMIES")then
542  read(value,*,iostat=ios) writedummies
543  else
544  write(*,*)'unknown label ',label
545  endif
546  120 continue
547 
548 
549  110 write(*,*)
550  & 'Unable to open parameter file, will exit the run.'
551  call exit(1)
552 
553  130 close(1,status='keep')
554  write(*,*)'...done'
555  endif
556 
557  if (ptmin.lt.3.d0) ptmin = 3.d0
558  if (.not.writescatcen) writedummies = .false.
559 
560  OPEN(unit=logfid,file=logfile,status='unknown')
561  mstu(11)=logfid
562 
563  call printtime
564  call printlogo(logfid)
565 
566 
567  write(logfid,*)
568  write(logfid,*)'parameters of the run:'
569  write(logfid,*)'NEVENT = ',nsim
570  write(logfid,*)'NJOB = ',njob
571  write(logfid,*)'LOGFILE = ',logfile
572  write(logfid,*)'HEPMCFILE = ',hepmcfile
573  write(logfid,*)'SPLITINTFILE = ',filesplit
574  write(logfid,*)'PDFFILE = ',pdffile
575  write(logfid,*)'XSECFILE = ',xsecfile
576  write(logfid,*)'MEDIUMPARAMS = ',filemed
577  write(logfid,*)'NF = ',nf
578  write(logfid,*)'LAMBDAQCD = ',lqcd
579  write(logfid,*)'Q0 = ',q0
580  write(logfid,*)'PTMIN = ',ptmin
581  write(logfid,*)'PTMAX = ',ptmax
582  write(logfid,*)'ETAMAX = ',etamax
583  write(logfid,*)'PROCESS = ',collider
584  write(logfid,*)'ISOCHANNEL = ',isochannel
585  write(logfid,*)'CHANNEL = ',channel
586  write(logfid,*)'SQRTS = ',sqrts
587  write(logfid,*)'PDFSET = ',pdfset
588  write(logfid,*)'NSET = ',nset
589  write(logfid,*)'MASS = ',mass
590  write(logfid,*)'NPROTON = ',nproton
591  write(logfid,*)'WEIGHTED = ',weighted
592  write(logfid,*)'WEXPO = ',weightex
593  write(logfid,*)'ANGORD = ',angord
594  write(logfid,*)'KEEPRECOILS = ',allhad
595  write(logfid,*)'HADRO = ',hadro
596  write(logfid,*)'HADROTYPE = ',hadrotype
597  write(logfid,*)'SHORTHEPMC = ',shorthepmc
598  write(logfid,*)'COMPRESS = ',compress
599  write(logfid,*)'WRITESCATCEN = ',writescatcen
600  write(logfid,*)'WRITEDUMMIES = ',writedummies
601  write(logfid,*)
602  call flush(logfid)
603 
604  if ((collider.ne.'PPJJ').and.(collider.ne.'EEJJ')
605  & .and.(collider.ne.'PPYJ').and.(collider.ne.'PPYQ')
606  & .and.(collider.ne.'PPYG')
607  & .and.(collider.ne.'PPZJ').and.(collider.ne.'PPZQ')
608  & .and.(collider.ne.'PPZG').and.(collider.ne.'PPWJ')
609  & .and.(collider.ne.'PPWQ').and.(collider.ne.'PPWG')
610  & .and.(collider.ne.'PPDY')) then
611  write(logfid,*)'Fatal error: colliding system unknown, '//
612  & 'will exit now'
613  call exit(1)
614  endif
615 
616 C--initialize medium
617  intmass = int(mass)
618  CALL medinit(filemed,logfid,etamax,intmass)
619  CALL mednextevt
620 
621  OPEN(unit=hpmcfid,file=hepmcfile,status='unknown')
622  WRITE(hpmcfid,*)
623  WRITE(hpmcfid,'(A)')'HepMC::Version 2.06.05'
624  WRITE(hpmcfid,'(A)')'HepMC::IO_GenEvent-START_EVENT_LISTING'
625 
626  npart=2
627 
628  if(ptmax.gt.0.)then
629  eovest=min(1.5*(ptmax+50.)*cosh(etamax),sqrts/2.)
630  else
631  eovest=sqrts/2.
632  endif
633 
634 
635  CALL eixint
636  CALL insudaint(eovest)
637 
638  write(logfid,*)
639  INQUIRE(file=filesplit,exist=splitiexist)
640  IF(splitiexist)THEN
641  write(logfid,*)'read splitting integrals from ',filesplit
642  OPEN(unit=10,file=filesplit,status='old')
643  READ(10,*)qmax,zmmin,npoint
644  DO 893 i=1,npoint+1
645  READ(10,*) qval(i),zmval(i)
646  893 CONTINUE
647  DO 891 i=1,npoint+1
648  DO 892 j=1,npoint+1
649  READ(10,*)splitiggv(i,j),splitiqqv(i,j),splitiqgv(i,j)
650  892 CONTINUE
651  891 CONTINUE
652  CLOSE(10,status='keep')
653  ELSE
654  write(logfid,*)'have to integrate splitting functions, '//
655  &'this may take some time'
656  CALL splitfncint(eovest)
657  INQUIRE(file=filesplit,exist=splitiexist)
658  IF(.NOT.splitiexist)THEN
659  write(logfid,*)'write splitting integrals to ',filesplit
660  OPEN(unit=10,file=filesplit,status='new')
661  WRITE(10,*)qmax,zmmin,npoint
662  DO 896 i=1,npoint+1
663  WRITE(10,*) qval(i),zmval(i)
664  896 CONTINUE
665  DO 897 i=1,npoint+1
666  DO 898 j=1,npoint+1
667  WRITE(10,*)splitiggv(i,j),splitiqqv(i,j),splitiqgv(i,j)
668  898 CONTINUE
669  897 CONTINUE
670  CLOSE(10,status='keep')
671  ENDIF
672  ENDIF
673  write(logfid,*)
674 
675  INQUIRE(file=pdffile,exist=pdfexist)
676  IF(pdfexist)THEN
677  write(logfid,*)'read pdfs from ',pdffile
678  OPEN(unit=10,file=pdffile,status='old')
679  DO 872 i=1,2
680  DO 873 j=1,1000
681  READ(10,*)qinqx(i,j),ginqx(i,j),qingx(i,j),gingx(i,j)
682  873 CONTINUE
683  872 CONTINUE
684  CLOSE(10,status='keep')
685  ELSE
686  write(logfid,*)'have to integrate pdfs, this may take some time'
687  CALL pdfint(eovest)
688  INQUIRE(file=pdffile,exist=pdfexist)
689  IF(.NOT.pdfexist)THEN
690  write(logfid,*)'write pdfs to ',pdffile
691  OPEN(unit=10,file=pdffile,status='new')
692  DO 876 i=1,2
693  DO 877 j=1,1000
694  WRITE(10,*)qinqx(i,j),ginqx(i,j),qingx(i,j),gingx(i,j)
695  877 CONTINUE
696  876 CONTINUE
697  CLOSE(10,status='keep')
698  ENDIF
699  ENDIF
700  write(logfid,*)
701 
702  INQUIRE(file=xsecfile,exist=xsecexist)
703  IF(xsecexist)THEN
704  write(logfid,*)'read cross sections from ',xsecfile
705  OPEN(unit=10,file=xsecfile,status='old')
706  DO 881 j=1,1001
707  DO 885 jj=1,101
708  READ(10,*)intq1(j,jj),intq2(j,jj),
709  &intg1(j,jj),intg2(j,jj)
710  885 CONTINUE
711  881 CONTINUE
712  CLOSE(10,status='keep')
713  ELSE
714  write(logfid,*)'have to integrate cross sections, '//
715  &'this may take some time'
716  CALL xsecint(eovest)
717  INQUIRE(file=xsecfile,exist=xsecexist)
718  IF(.NOT.xsecexist)THEN
719  write(logfid,*)'write cross sections to ',xsecfile
720  OPEN(unit=10,file=xsecfile,status='new')
721  DO 883 j=1,1001
722  DO 884 jj=1,101
723  WRITE(10,*)intq1(j,jj),intq2(j,jj),
724  &intg1(j,jj),intg2(j,jj)
725  884 CONTINUE
726  883 CONTINUE
727  CLOSE(10,status='keep')
728  ENDIF
729  ENDIF
730  write(logfid,*)
731  CALL flush(3)
732 
733 
734 
735 C--initialise random number generator status
736  IF(njob.GT.0)THEN
737  mrpy(1)=njob*1000
738  mrpy(2)=0
739  ENDIF
740 
741 C--Call PYR once for initialization
742  r=pyr(0)
743 
744  ndisc=0
745  ngood=0
746  nstrange=0
747 
748  errcount=0
749  errl = 0
750 
751  nscat=0.d0
752  nscateff=0.d0
753  nsplit=0.d0
754 
755  ntotspliti=0
756  noverspliti=0
757  ntotpdf=0
758  noverpdf=0
759  ntotxsec=0
760  noverxsec=0
761  ntotsuda=0
762  noversuda=0
763 
764  IF(nset.EQ.0)THEN
765  eps09=.false.
766  ELSE
767  eps09=.true.
768  IF(nset.LT.10)THEN
769  WRITE(snset,'(i1)') nset
770  ELSE
771  WRITE(snset,'(i2)') nset
772  ENDIF
773  initstr='EPS09LO,'//snset
774  ENDIF
775 
776  end
777 
778 
779 
780 ***********************************************************************
781 *** subroutine initpythia
782 ***********************************************************************
783  subroutine initpythia(beam1,beam2)
784  implicit none
785  INTEGER pycomp
786  INTEGER nmxhep
787 C--Common block of Pythia
788  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
789  INTEGER n,npad,k
790  DOUBLE PRECISION p,v
791  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
792  INTEGER mstu,mstj
793  DOUBLE PRECISION paru,parj
794  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
795  INTEGER mdcy,mdme,kfdp
796  DOUBLE PRECISION brat
797  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
798  INTEGER msel,mselpd,msub,kfin
799  DOUBLE PRECISION ckin
800  common/pypars/mstp(200),parp(200),msti(200),pari(200)
801  INTEGER mstp,msti
802  DOUBLE PRECISION parp,pari
803  common/pydatr/mrpy(6),rrpy(100)
804  INTEGER mrpy
805  DOUBLE PRECISION rrpy
806 C--use nuclear pdf?
807  common/npdf/mass,nset,eps09,initstr
808  INTEGER nset
809  DOUBLE PRECISION mass
810  LOGICAL eps09
811  CHARACTER*10 initstr
812 C--pdfset
813  common/pdf/pdfset
814  integer pdfset
815 C--Parameter common block
816  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
817  &allhad,compress,nf
818  INTEGER nf
819  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
820  LOGICAL angord,scatrecoil,allhad,compress
821 C--discard event flag
822  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
823  LOGICAL discard
824  INTEGER ndisc,nstrange,ngood,errcount
825  double precision wdisc
826 C--event weight
827  common/weight/evweight,sumofweights
828  double precision evweight,sumofweights
829 C--event weight exponent
830  common/wexpo/weightex
831  DOUBLE PRECISION weightex
832 C--memory for error message from getdeltat
833  common/errline/errl
834  integer errl
835 C--organisation of event record
836  common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
837  &shorthepmc,channel,isochannel
838  integer nsim,npart,offset,hadrotype
839  double precision sqrts
840  character*4 collider,channel
841  character*2 isochannel
842  logical hadro,shorthepmc
843 C--Pythia parameters
844  common/pythiaparams/ptmin,ptmax,weighted
845  double precision ptmin,ptmax
846  LOGICAL weighted
847 
848 C--Variables local to this program
849  character*2 beam1,beam2
850 
851 
852 C--initialise PYTHIA
853 C--no multiple interactions
854  mstp(81) = 0
855 C--initial state radiation
856  mstp(61)=1
857 C--switch off final state radiation
858  mstp(71)=0
859 C--No hadronisation (yet)
860  mstp(111)=0
861 C--parameter affecting treatment of string corners
862  paru(14)=1.
863 C--Min shat in simulation
864  ckin(1)=2.
865 C--pT-cut
866  ckin(3)=ptmin
867  ckin(4)=ptmax
868 C--use LHAPDF
869  mstp(52)=2
870 C--choose pdf: CTEQ6ll (LO fit/LO alphas) - 10042
871 C MSTW2008 (LO central) - 21000
872  mstp(51)=pdfset
873  IF(collider.EQ.'PPYQ')THEN
874  msel=0
875  msub(29)=1
876  ELSEIF(collider.EQ.'PPYG')THEN
877  msel=0
878  msub(14)=1
879  msub(115)=1
880  ELSEIF(collider.EQ.'PPYJ')THEN
881  msel=0
882  msub(14)=1
883  msub(29)=1
884  msub(115)=1
885  ELSEIF((collider.EQ.'PPZJ').or.(collider.EQ.'PPZQ')
886  & .or.(collider.EQ.'PPZG')
887  & .or.(collider.eq.'PPDY'))THEN
888  msel=0
889  IF((collider.EQ.'PPZJ').or.(collider.EQ.'PPZQ')) msub(30)=1
890  IF((collider.EQ.'PPZJ').or.(collider.EQ.'PPZG')) msub(15)=1
891  IF(collider.EQ.'PPDY') msub(1)=1
892  mdme(174,1)=0 !Z decay into d dbar',
893  mdme(175,1)=0 !Z decay into u ubar',
894  mdme(176,1)=0 !Z decay into s sbar',
895  mdme(177,1)=0 !Z decay into c cbar',
896  mdme(178,1)=0 !Z decay into b bbar',
897  mdme(179,1)=0 !Z decay into t tbar',
898  mdme(182,1)=0 !Z decay into e- e+',
899  mdme(183,1)=0 !Z decay into nu_e nu_ebar',
900  mdme(184,1)=0 !Z decay into mu- mu+',
901  mdme(185,1)=0 !Z decay into nu_mu nu_mubar',
902  mdme(186,1)=0 !Z decay into tau- tau+',
903  mdme(187,1)=0 !Z decay into nu_tau nu_taubar',
904  if (channel.EQ.'ELEC')THEN
905  mdme(182,1)=1
906  ELSEIF(channel.EQ.'MUON')THEN
907  mdme(184,1)=1
908  ENDIF
909  ELSEIF((collider.EQ.'PPWJ').or.(collider.EQ.'PPWQ')
910  & .or.(collider.EQ.'PPWG'))THEN
911  msel=0
912  IF((collider.EQ.'PPWJ').or.(collider.EQ.'PPWQ')) msub(31)=1
913  IF((collider.EQ.'PPWJ').or.(collider.EQ.'PPWG')) msub(16)=1
914  mdme(190,1)=0 ! W+ decay into dbar u,
915  mdme(191,1)=0 ! W+ decay into dbar c,
916  mdme(192,1)=0 ! W+ decay into dbar t,
917  mdme(194,1)=0 ! W+ decay into sbar u,
918  mdme(195,1)=0 ! W+ decay into sbar c,
919  mdme(196,1)=0 ! W+ decay into sbar t,
920  mdme(198,1)=0 ! W+ decay into bbar u,
921  mdme(199,1)=0 ! W+ decay into bbar c,
922  mdme(200,1)=0 ! W+ decay into bbar t,
923  mdme(202,1)=0 ! W+ decay into b'bar u,
924  mdme(203,1)=0 ! W+ decay into b'bar c,
925  mdme(204,1)=0 ! W+ decay into b'bar t,
926  mdme(206,1)=0 ! W+ decay into e+ nu_e,
927  mdme(207,1)=0 ! W+ decay into mu+ nu_mu,
928  mdme(208,1)=0 ! W+ decay into tau+ nu_tau,
929  mdme(209,1)=0 ! W+ decay into tau'+ nu'_tau,
930  if (channel.EQ.'ELEC')THEN
931  mdme(206,1)=1
932  ELSEIF(channel.EQ.'MUON')THEN
933  mdme(207,1)=1
934  ENDIF
935  ELSE
936 C--All QCD processes are active
937  msel=1
938  ENDIF
939 ! MSEL=0
940 ! MSUB(11)=1
941 ! MSUB(12)=1
942 ! MSUB(53)=1
943 ! MSUB(13)=1
944 ! MSUB(68)=1
945 ! MSUB(28)=1
946 
947 C--weighted events
948  IF(weighted) mstp(142)=1
949 
950 C--number of errors to be printed
951  mstu(22)=max(10,int(5.*nsim/100.))
952 
953 C--number of lines in event record
954  mstu(4)=23000
955  mstu(5)=23000
956 
957 C--switch off pi0 decay
958  mdcy(pycomp(111),1)=0
959 C--initialisation call
960  IF(collider.EQ.'EEJJ')THEN
961  offset=9
962  CALL pyinit('CMS',beam1,beam2,sqrts)
963  ELSEIF((collider.EQ.'PPJJ').OR.(collider.EQ.'PPYJ').OR.
964  & (collider.EQ.'PPYG').OR.(collider.EQ.'PPYQ'))THEN
965  offset=8
966  CALL pyinit('CMS',beam1,beam2,sqrts)
967  ELSEIF((collider.EQ.'PPWJ').OR.(collider.EQ.'PPZJ').or.
968  & (collider.EQ.'PPWQ').OR.(collider.EQ.'PPZQ').or.
969  & (collider.EQ.'PPWG').OR.(collider.EQ.'PPZG'))THEN
970  offset=10
971  CALL pyinit('CMS',beam1,beam2,sqrts)
972  elseif (collider.eq.'PPDY') then
973  CALL pyinit('CMS',beam1,beam2,sqrts)
974  ENDIF
975 
976  end
977 
978 
979 
980 ***********************************************************************
981 *** subroutine genevent
982 ***********************************************************************
983  subroutine genevent(j,b1,b2)
984  implicit none
985 C--identifier of file for hepmc output and logfile
986  common/hepmcid/hpmcfid,logfid
987  integer hpmcfid,logfid
988  INTEGER pycomp
989  INTEGER nmxhep
990 C--Common block of Pythia
991  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
992  INTEGER n,npad,k
993  DOUBLE PRECISION p,v
994  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
995  INTEGER mstu,mstj
996  DOUBLE PRECISION paru,parj
997  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
998  INTEGER mdcy,mdme,kfdp
999  DOUBLE PRECISION brat
1000  common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)
1001  INTEGER msel,mselpd,msub,kfin
1002  DOUBLE PRECISION ckin
1003  common/pypars/mstp(200),parp(200),msti(200),pari(200)
1004  INTEGER mstp,msti
1005  DOUBLE PRECISION parp,pari
1006  common/pydatr/mrpy(6),rrpy(100)
1007  INTEGER mrpy
1008  DOUBLE PRECISION rrpy
1009 C--Parameter common block
1010  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
1011  &allhad,compress,nf
1012  INTEGER nf
1013  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
1014  LOGICAL angord,scatrecoil,allhad,compress
1015 C--discard event flag
1016  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
1017  LOGICAL discard
1018  INTEGER ndisc,nstrange,ngood,errcount
1019  double precision wdisc
1020 C--variables for angular ordering
1021  common/angor/za(23000),zd(23000),thetaa(23000),qqbard(23000)
1022  DOUBLE PRECISION za,zd,thetaa
1023  LOGICAL qqbard
1024 C--factor in front of formation times
1025  common/ftimefac/ftfac
1026  DOUBLE PRECISION ftfac
1027 C--time common block
1028  common/time/mv(23000,5)
1029  DOUBLE PRECISION mv
1030 C--colour index common block
1031  common/colour/trip(23000),anti(23000),colmax
1032  INTEGER trip,anti,colmax
1033 C--number of scattering events
1034  common/check/nscat,nscateff,nsplit
1035  DOUBLE PRECISION nscat,nscateff,nsplit
1036 C--event weight
1037  common/weight/evweight,sumofweights
1038  double precision evweight,sumofweights
1039 C--event weight exponent
1040  common/wexpo/weightex
1041  DOUBLE PRECISION weightex
1042 C--max rapidity
1043  common/rapmax/etamax
1044  double precision etamax
1045 C--production point
1046  common/jetpoint/x0,y0
1047  double precision x0,y0
1048 C--organisation of event record
1049  common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
1050  &shorthepmc,channel,isochannel
1051  integer nsim,npart,offset,hadrotype
1052  double precision sqrts
1053  character*4 collider,channel
1054  character*2 isochannel
1055  logical hadro,shorthepmc
1056 C--extra storage for scattering centres before interactions
1057  common/storescatcen/nscatcen,maxnscatcen,scatflav(10000),
1058  &scatcen(10000,5),writescatcen,writedummies
1059  integer nscatcen,maxnscatcen,scatflav
1060  double precision scatcen
1061  logical writescatcen,writedummies
1062 
1063 C--Variables local to this program
1064  INTEGER nold,pid,ipart,lme1,lme2,j,i,lme1orig,lme2orig,llep1,
1065  &llep2,lv
1066  DOUBLE PRECISION pyr,eni,qmax1,r,getmass,pyp,q1,q2,p21,p22,etot,
1067  &qmax2,pold,en1,en2,beta(3),enew1,enew2,emax,lambda,x1,x2,x3,
1068  &meweight,psweight,weight,eps1,eps2,theta1,theta2,z1,z2,
1069  &getltimemax,pi,m1,m2
1070  character*2 b1,b2
1071  CHARACTER*2 type1,type2
1072  LOGICAL firsttrip,which1,which2,isdiquark
1073  DATA pi/3.141592653589793d0/
1074 
1075  n=0
1076  colmax=600
1077  discard=.false.
1078  DO 91 i=1,23000
1079  mv(i,1)=0.d0
1080  mv(i,2)=0.d0
1081  mv(i,3)=0.d0
1082  mv(i,4)=0.d0
1083  mv(i,5)=0.d0
1084  91 CONTINUE
1085  nscatcen = 0
1086 
1087  CALL mednextevt
1088 
1089 C--initialisation with matrix element
1090 C--production vertex
1091  CALL pickvtx(x0,y0)
1092  ltime=getltimemax()
1093 
1094  99 CALL pyevnt
1095  npart=n-offset
1096  evweight=pari(10)
1097  sumofweights=sumofweights+evweight
1098  IF((collider.EQ.'EEJJ').AND.(abs(k(8,2)).GT.6))THEN
1099  wdisc=wdisc+evweight
1100  ndisc=ndisc+1
1101  goto 102
1102  ELSE
1103  ngood=ngood+1
1104  ENDIF
1105 
1106 C--DY: don't have to do anything
1107  if (collider.eq.'PPDY') then
1108  CALL pyexec
1109  call converttohepmc(hpmcfid,ngood,pid,b1,b2)
1110  goto 102
1111  endif
1112 
1113 
1114 C-- prepare event record
1115  if((collider.EQ.'PPZJ').OR.(collider.EQ.'PPZQ').or.
1116  & (collider.EQ.'PPZG').or.(collider.EQ.'PPWJ').or.
1117  & (collider.EQ.'PPWQ').or.(collider.EQ.'PPWG'))THEN
1118  lme1orig=7
1119  lme2orig=8
1120  if(abs(k(7,2)).gt.21) then
1121  lv=7
1122  else
1123  lv=8
1124  endif
1125  ELSE
1126  lme1orig=offset-1
1127  lme2orig=offset
1128  ENDIF
1129  DO 180 ipart=offset+1, offset+npart
1130 C--find decay leptons in V+jet events
1131  if((collider.EQ.'PPZJ').OR.(collider.EQ.'PPZQ').or.
1132  & (collider.EQ.'PPZG').or.(collider.EQ.'PPWJ').or.
1133  & (collider.EQ.'PPWQ').or.(collider.EQ.'PPWG'))THEN
1134  if(k(ipart,3).eq.offset-1) llep1=ipart
1135  if(k(ipart,3).eq.offset) llep2=ipart
1136  endif
1137  IF(k(ipart,3).EQ.(lme1orig))THEN
1138  lme1=ipart
1139  IF(k(ipart,2).EQ.21)THEN
1140  type1='GC'
1141  ELSE
1142  type1='QQ'
1143  ENDIF
1144  ELSEIF(k(ipart,3).EQ.lme2orig)THEN
1145  lme2=ipart
1146  IF(k(ipart,2).EQ.21)THEN
1147  type2='GC'
1148  ELSE
1149  type2='QQ'
1150  ENDIF
1151  ELSE
1152  trip(ipart)=0
1153  anti(ipart)=0
1154  zd(ipart)=0.d0
1155  thetaa(ipart)=0.d0
1156  ENDIF
1157 C--assign colour indices
1158  IF(k(ipart,1).EQ.2)THEN
1159  IF(k(ipart-1,1).EQ.2)THEN
1160 C--in middle of colour singlet
1161  IF(firsttrip)THEN
1162  trip(ipart)=colmax+1
1163  anti(ipart)=trip(ipart-1)
1164  ELSE
1165  trip(ipart)=anti(ipart-1)
1166  anti(ipart)=colmax+1
1167  ENDIF
1168  colmax=colmax+1
1169  ELSE
1170 C--beginning of colour singlet
1171  IF(((abs(k(ipart,2)).LT.10).AND.(k(ipart,2).GT.0))
1172  & .OR.(isdiquark(k(ipart,2)).AND.(k(ipart,2).LT.0)))THEN
1173  trip(ipart)=colmax+1
1174  anti(ipart)=0
1175  firsttrip=.true.
1176  ELSE
1177  trip(ipart)=0
1178  anti(ipart)=colmax+1
1179  firsttrip=.false.
1180  ENDIF
1181  colmax=colmax+1
1182  ENDIF
1183  ENDIF
1184  IF(k(ipart,1).EQ.1)THEN
1185 C--end of colour singlet
1186  IF(firsttrip)THEN
1187  trip(ipart)=0
1188  anti(ipart)=trip(ipart-1)
1189  ELSE
1190  trip(ipart)=anti(ipart-1)
1191  anti(ipart)=0
1192  ENDIF
1193  ENDIF
1194  180 CONTINUE
1195  if (k(lme1,1).lt.11) k(lme1,1)=1
1196  if (k(lme2,1).lt.11) k(lme2,1)=1
1197  pid=k(lme1,2)
1198  eni=max(p(lme1,4),p(lme2,4))
1199  DO 183 ipart=offset+1, offset+npart
1200  IF((ipart.NE.lme1).AND.(ipart.NE.lme2).AND.(k(ipart,1).LT.11))
1201  & k(ipart,1)=4
1202  if (k(ipart,2).eq.22) k(ipart,1)=4
1203  183 CONTINUE
1204 
1205 C--find virtualities and adapt four-vectors
1206  if((collider.EQ.'PPZJ').OR.(collider.EQ.'PPZQ').or.
1207  & (collider.EQ.'PPZG').or.(collider.EQ.'PPWJ').or.
1208  & (collider.EQ.'PPWQ').or.(collider.EQ.'PPWG'))THEN
1209  if (abs(k(lme1,2)).gt.21) then
1210  qmax1=0.d0
1211  qmax2=sqrt(pari(18)+p(lme1,5)**2)
1212  else
1213  qmax1=sqrt(pari(18)+p(lme2,5)**2)
1214  qmax2=0.d0
1215  endif
1216  emax=p(lme1,4)+p(lme2,4)
1217  theta1=-1.d0
1218  theta2=-1.d0
1219  ELSEIF(collider.EQ.'PPJJ'.OR.collider.EQ.'PPYJ'
1220  & .OR.collider.EQ.'PPYQ'.OR.collider.EQ.'PPYG')THEN
1221  if (k(lme1,1).eq.4) then
1222  qmax1 = 0.d0
1223  else
1224  qmax1=pari(17)
1225  endif
1226  if (k(lme2,1).eq.4) then
1227  qmax2 = 0.d0
1228  else
1229  qmax2=pari(17)
1230  endif
1231 ! QMAX1=PYP(LME1,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2.
1232 ! QMAX2=PYP(LME2,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2.
1233  emax=p(lme1,4)+p(lme2,4)
1234  theta1=-1.d0
1235  theta2=-1.d0
1236  ENDIF
1237  en1=p(lme1,4)
1238  en2=p(lme2,4)
1239  beta(1)=(p(lme1,1)+p(lme2,1))/(p(lme1,4)+p(lme2,4))
1240  beta(2)=(p(lme1,2)+p(lme2,2))/(p(lme1,4)+p(lme2,4))
1241  beta(3)=(p(lme1,3)+p(lme2,3))/(p(lme1,4)+p(lme2,4))
1242  CALL pyrobo(lme1,lme1,0d0,0d0,-beta(1),-beta(2),-beta(3))
1243  CALL pyrobo(lme2,lme2,0d0,0d0,-beta(1),-beta(2),-beta(3))
1244  etot=p(lme1,4)+p(lme2,4)
1245  IF(collider.EQ.'EEJJ')THEN
1246  qmax1=etot
1247  qmax2=etot
1248  emax=p(lme1,4)+p(lme2,4)
1249  theta1=-1.d0
1250  theta2=-1.d0
1251  ENDIF
1252 C-- find virtuality
1253  q1=getmass(0.d0,qmax1,theta1,emax,type1,emax,.false.,
1254  & z1,which1)
1255  q2=getmass(0.d0,qmax2,theta2,emax,type2,emax,.false.,
1256  & z2,which2)
1257  182 if (abs(k(lme1,2)).gt.21) then
1258  m1=p(lme1,5)
1259  else
1260  m1=q1
1261  endif
1262  if (abs(k(lme2,2)).gt.21) then
1263  m2=p(lme2,5)
1264  else
1265  m2=q2
1266  endif
1267  enew1=etot/2.d0 + (m1**2-m2**2)/(2.*etot)
1268  enew2=etot/2.d0 - (m1**2-m2**2)/(2.*etot)
1269  p21 = (etot/2.d0 + (m1**2-m2**2)/(2.*etot))**2 - m1**2
1270  p22 = (etot/2.d0 - (m1**2-m2**2)/(2.*etot))**2 - m2**2
1271  weight=1.d0
1272  IF((pyr(0).GT.weight).OR.(p21.LT.0.d0).OR.(p22.LT.0.d0)
1273  & .OR.(enew1.LT.0.d0).OR.(enew2.LT.0.d0)
1274  & )THEN
1275  IF(q1.GT.q2)THEN
1276  q1=getmass(0.d0,q1,theta1,emax,type1,emax,.false.,
1277  & z1,which1)
1278  ELSE
1279  q2=getmass(0.d0,q2,theta2,emax,type2,emax,.false.,
1280  & z2,which2)
1281  ENDIF
1282  goto 182
1283  ENDIF
1284  pold=pyp(lme1,8)
1285  p(lme1,1)=p(lme1,1)*sqrt(p21)/pold
1286  p(lme1,2)=p(lme1,2)*sqrt(p21)/pold
1287  p(lme1,3)=p(lme1,3)*sqrt(p21)/pold
1288  p(lme1,4)=enew1
1289  p(lme1,5)=m1
1290  pold=pyp(lme2,8)
1291  p(lme2,1)=p(lme2,1)*sqrt(p22)/pold
1292  p(lme2,2)=p(lme2,2)*sqrt(p22)/pold
1293  p(lme2,3)=p(lme2,3)*sqrt(p22)/pold
1294  p(lme2,4)=enew2
1295  p(lme2,5)=m2
1296  CALL pyrobo(lme1,lme1,0d0,0d0,beta(1),beta(2),beta(3))
1297  CALL pyrobo(lme2,lme2,0d0,0d0,beta(1),beta(2),beta(3))
1298 C--correct for overestimated energy
1299  IF(q1.GT.0.d0)THEN
1300  eps1=0.5-0.5*sqrt(1.-q0**2/q1**2)
1301  & *sqrt(1.-q1**2/p(lme1,4)**2)
1302  IF((z1.LT.eps1).OR.(z1.GT.(1.-eps1)))THEN
1303  q1=getmass(0.d0,q1,theta1,emax,type1,emax,.false.,
1304  & z1,which1)
1305  CALL pyrobo(lme1,lme1,0d0,0d0,-beta(1),-beta(2),-beta(3))
1306  CALL pyrobo(lme2,lme2,0d0,0d0,-beta(1),-beta(2),-beta(3))
1307  goto 182
1308  ENDIF
1309  ENDIF
1310  IF(q2.GT.0.d0)THEN
1311  eps2=0.5-0.5*sqrt(1.-q0**2/q2**2)
1312  & *sqrt(1.-q2**2/p(lme2,4)**2)
1313  IF((z2.LT.eps2).OR.(z2.GT.(1.-eps2)))THEN
1314  q2=getmass(0.d0,q2,theta2,emax,type2,emax,.false.,
1315  & z2,which2)
1316  CALL pyrobo(lme1,lme1,0d0,0d0,-beta(1),-beta(2),-beta(3))
1317  CALL pyrobo(lme2,lme2,0d0,0d0,-beta(1),-beta(2),-beta(3))
1318  goto 182
1319  ENDIF
1320  ENDIF
1321 
1322 C--correct to ME for first parton
1323  IF(collider.EQ.'EEJJ')THEN
1324  beta(1)=(p(lme1,1)+p(lme2,1))/(p(lme1,4)+p(lme2,4))
1325  beta(2)=(p(lme1,2)+p(lme2,2))/(p(lme1,4)+p(lme2,4))
1326  beta(3)=(p(lme1,3)+p(lme2,3))/(p(lme1,4)+p(lme2,4))
1327  CALL pyrobo(lme1,lme1,0d0,0d0,-beta(1),-beta(2),-beta(3))
1328  CALL pyrobo(lme2,lme2,0d0,0d0,-beta(1),-beta(2),-beta(3))
1329  IF(q1.GT.0.d0)THEN
1330 C--generate z value
1331  x1=z1*(etot**2+q1**2)/etot**2
1332  x2=(etot**2-q1**2)/etot**2
1333  x3=(1.-z1)*(etot**2+q1**2)/etot**2
1334  psweight=(1.-x1)*(1.+(x1/(2.-x2))**2)/x3
1335  & + (1.-x2)*(1.+(x2/(2.-x1))**2)/x3
1336  meweight=x1**2+x2**2
1337  weight=meweight/psweight
1338  IF(pyr(0).GT.weight)THEN
1339  184 q1=getmass(0.d0,q1,theta1,emax,type1,emax,.false.,
1340  & z1,which1)
1341  ENDIF
1342  ENDIF
1343 C--correct to ME for second parton
1344  IF(q2.GT.0.d0)THEN
1345 C--generate z value
1346  x1=(etot**2-q2**2)/etot**2
1347  x2=z2*(etot**2+q2**2)/etot**2
1348  x3=(1.-z2)*(etot**2+q2**2)/etot**2
1349  psweight=(1.-x1)*(1.+(x1/(2.-x2))**2)/x3
1350  & + (1.-x2)*(1.+(x2/(2.-x1))**2)/x3
1351  meweight=x1**2+x2**2
1352  weight=meweight/psweight
1353  IF(pyr(0).GT.weight)THEN
1354  185 q2=getmass(0.d0,q2,theta2,emax,type2,emax,.false.,
1355  & z2,which2)
1356  ENDIF
1357  ENDIF
1358  186 enew1=etot/2.d0 + (q1**2-q2**2)/(2.*etot)
1359  enew2=etot/2.d0 - (q1**2-q2**2)/(2.*etot)
1360  p21 = (etot/2.d0 + (q1**2-q2**2)/(2.*etot))**2 - q1**2
1361  p22 = (etot/2.d0 - (q1**2-q2**2)/(2.*etot))**2 - q2**2
1362  pold=pyp(lme1,8)
1363  p(lme1,1)=p(lme1,1)*sqrt(p21)/pold
1364  p(lme1,2)=p(lme1,2)*sqrt(p21)/pold
1365  p(lme1,3)=p(lme1,3)*sqrt(p21)/pold
1366  p(lme1,4)=enew1
1367  p(lme1,5)=q1
1368  pold=pyp(lme2,8)
1369  p(lme2,1)=p(lme2,1)*sqrt(p22)/pold
1370  p(lme2,2)=p(lme2,2)*sqrt(p22)/pold
1371  p(lme2,3)=p(lme2,3)*sqrt(p22)/pold
1372  p(lme2,4)=enew2
1373  p(lme2,5)=q2
1374  CALL pyrobo(lme1,lme1,0d0,0d0,beta(1),beta(2),beta(3))
1375  CALL pyrobo(lme2,lme2,0d0,0d0,beta(1),beta(2),beta(3))
1376 C--correct for overestimated energy
1377  IF(q1.GT.0.d0)THEN
1378  eps1=0.5-0.5*sqrt(1.-q0**2/q1**2)
1379  & *sqrt(1.-q1**2/p(lme1,4)**2)
1380  IF((z1.LT.eps1).OR.(z1.GT.(1.-eps1)))THEN
1381  q1=getmass(0.d0,q1,theta1,emax,type1,emax,.false.,
1382  & z1,which1)
1383  CALL pyrobo(lme1,lme1,0d0,0d0,-beta(1),-beta(2),-beta(3))
1384  CALL pyrobo(lme2,lme2,0d0,0d0,-beta(1),-beta(2),-beta(3))
1385  goto 186
1386  ENDIF
1387  ENDIF
1388  IF(q2.GT.0.d0)THEN
1389  eps2=0.5-0.5*sqrt(1.-q0**2/q2**2)
1390  & *sqrt(1.-q2**2/p(lme2,4)**2)
1391  IF((z2.LT.eps2).OR.(z2.GT.(1.-eps2)))THEN
1392  q2=getmass(0.d0,q2,theta2,emax,type2,emax,.false.,
1393  & z2,which2)
1394  CALL pyrobo(lme1,lme1,0d0,0d0,-beta(1),-beta(2),-beta(3))
1395  CALL pyrobo(lme2,lme2,0d0,0d0,-beta(1),-beta(2),-beta(3))
1396  goto 186
1397  ENDIF
1398  ENDIF
1399  ENDIF
1400 
1401 C--transfer recoil to decay leptons in V+jet
1402  if((collider.EQ.'PPZJ').OR.(collider.EQ.'PPZQ').or.
1403  & (collider.EQ.'PPZG').or.(collider.EQ.'PPWJ').or.
1404  & (collider.EQ.'PPWQ').or.(collider.EQ.'PPWG'))THEN
1405  beta(1)=p(lv,1)/p(lv,4)
1406  beta(2)=p(lv,2)/p(lv,4)
1407  beta(3)=p(lv,3)/p(lv,4)
1408  CALL pyrobo(llep1,llep1,0d0,0d0,-beta(1),-beta(2),-beta(3))
1409  CALL pyrobo(llep2,llep2,0d0,0d0,-beta(1),-beta(2),-beta(3))
1410  if (abs(k(lme1,2)).gt.21) then
1411  beta(1)=p(lme1,1)/p(lme1,4)
1412  beta(2)=p(lme1,2)/p(lme1,4)
1413  beta(3)=p(lme1,3)/p(lme1,4)
1414  else
1415  beta(1)=p(lme2,1)/p(lme2,4)
1416  beta(2)=p(lme2,2)/p(lme2,4)
1417  beta(3)=p(lme2,3)/p(lme2,4)
1418  endif
1419  CALL pyrobo(llep1,llep1,0d0,0d0,beta(1),beta(2),beta(3))
1420  CALL pyrobo(llep2,llep2,0d0,0d0,beta(1),beta(2),beta(3))
1421  endif
1422 
1423 
1424  za(lme1)=1.d0
1425  za(lme2)=1.d0
1426  thetaa(lme1)=p(lme1,5)/(sqrt(z1*(1.-z1))*p(lme1,4))
1427  thetaa(lme2)=p(lme2,5)/(sqrt(z2*(1.-z2))*p(lme2,4))
1428  zd(lme1)=z1
1429  zd(lme2)=z2
1430  qqbard(lme1)=which1
1431  qqbard(lme2)=which2
1432 
1433  mv(lme1,1)=x0
1434  mv(lme1,2)=y0
1435  mv(lme1,3)=0.d0
1436  mv(lme1,4)=0.d0
1437  IF(p(lme1,5).GT.0.d0)THEN
1438  lambda=1.d0/(ftfac*p(lme1,4)*0.2/q1**2)
1439  mv(lme1,5)=-log(1.d0-pyr(0))/lambda
1440  ELSE
1441  mv(lme1,5)=ltime
1442  ENDIF
1443 
1444  mv(lme2,1)=x0
1445  mv(lme2,2)=y0
1446  mv(lme2,3)=0.d0
1447  mv(lme2,4)=0.d0
1448  IF(p(lme2,5).GT.0.d0)THEN
1449  lambda=1.d0/(ftfac*p(lme2,4)*0.2/q2**2)
1450  mv(lme2,5)=-log(1.d0-pyr(0))/lambda
1451  ELSE
1452  mv(lme2,5)=ltime
1453  ENDIF
1454 
1455 C--develop parton shower
1456  CALL makecascade
1457  IF(discard) THEN
1458  ngood=ngood-1
1459  wdisc=wdisc+evweight
1460  ndisc=ndisc+1
1461  write(logfid,*)'discard event',j
1462  goto 102
1463  ENDIF
1464 
1465  IF(.NOT.allhad)THEN
1466  DO 86 i=1,n
1467  IF(k(i,1).EQ.3) k(i,1)=22
1468  86 CONTINUE
1469  ENDIF
1470  IF(hadro)THEN
1471  CALL makestrings(hadrotype)
1472  IF(discard) THEN
1473  write(logfid,*)'discard event',j
1474  wdisc=wdisc+evweight
1475  ndisc=ndisc+1
1476  ngood=ngood-1
1477  goto 102
1478  ENDIF
1479  CALL pyexec
1480  IF(mstu(30).NE.errcount)THEN
1481  write(logfid,*)'PYTHIA discards event',j,
1482  & ' (error number',mstu(30),')'
1483  errcount=mstu(30)
1484  wdisc=wdisc+evweight
1485  ndisc=ndisc+1
1486  ngood=ngood-1
1487  goto 102
1488  ENDIF
1489  ENDIF
1490 
1491  IF(mstu(30).NE.errcount)THEN
1492  errcount=mstu(30)
1493  ELSE
1494  CALL converttohepmc(hpmcfid,ngood,pid,b1,b2)
1495  ENDIF
1496 
1497 C--write message to log-file
1498  102 IF(nsim.GT.100)THEN
1499  IF(mod(j,nsim/100).EQ.0)THEN
1500  write(logfid,*) 'done with event number ',j
1501  ENDIF
1502  else
1503  write(logfid,*) 'done with event number ',j
1504  ENDIF
1505  call flush(logfid)
1506  end
1507 
1508 
1509 
1510 ***********************************************************************
1511 *** subroutine makestrings
1512 ***********************************************************************
1513  SUBROUTINE makestrings(WHICH)
1514  IMPLICIT NONE
1515 C--identifier of file for hepmc output and logfile
1516  common/hepmcid/hpmcfid,logfid
1517  integer hpmcfid,logfid
1518  INTEGER which
1519  IF(which.EQ.0)THEN
1520  CALL makestrings_vac
1521  ELSEIF(which.EQ.1)THEN
1522  CALL makestrings_minl
1523  ELSE
1524  WRITE(logfid,*)'error: unknown hadronisation type in MAKESTRINGS'
1525  ENDIF
1526  END
1527 
1528 
1529 ***********************************************************************
1530 *** subroutine makestrings_vac
1531 ***********************************************************************
1532  SUBROUTINE makestrings_vac
1533  IMPLICIT NONE
1534 C--identifier of file for hepmc output and logfile
1535  common/hepmcid/hpmcfid,logfid
1536  integer hpmcfid,logfid
1537 C--Common block of Pythia
1538  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
1539  INTEGER n,npad,k
1540  DOUBLE PRECISION p,v
1541 C--Parameter common block
1542  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
1543  &allhad,compress,nf
1544  INTEGER nf
1545  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
1546  LOGICAL angord,scatrecoil,allhad,compress
1547 C--colour index common block
1548  common/colour/trip(23000),anti(23000),colmax
1549  INTEGER trip,anti,colmax
1550 C--discard event flag
1551  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
1552  LOGICAL discard
1553  INTEGER ndisc,nstrange,ngood,errcount
1554  double precision wdisc
1555 C--local variables
1556  INTEGER nold,i,j,lquark,lmatch,lloose,nold1
1557  DOUBLE PRECISION eaddend,pyr,dir
1558  LOGICAL isdiquark,compressevent,roomleft
1559  DATA eaddend/10.d0/
1560 
1561  i = 0
1562  if (compress) roomleft = compressevent(i)
1563  nold1=n
1564 C--remove all active lines that are leptons, gammas, hadrons etc.
1565  DO 52 i=1,nold1
1566  IF((k(i,1).EQ.4).AND.(trip(i).EQ.0).AND.(anti(i).EQ.0))THEN
1567 C--copy line to end of event record
1568  n=n+1
1569  IF(n.GT.22990) THEN
1570  write(logfid,*)'event too long for event record'
1571  discard=.true.
1572  RETURN
1573  ENDIF
1574  k(n,1)=11
1575  k(n,2)=k(i,2)
1576  k(n,3)=i
1577  k(n,4)=0
1578  k(n,5)=0
1579  p(n,1)=p(i,1)
1580  p(n,2)=p(i,2)
1581  p(n,3)=p(i,3)
1582  p(n,4)=p(i,4)
1583  p(n,5)=p(i,5)
1584  k(i,1)=17
1585  k(i,4)=n
1586  k(i,5)=n
1587  trip(n)=trip(i)
1588  anti(n)=anti(i)
1589  ENDIF
1590  52 CONTINUE
1591  nold=n
1592 C--first do strings with existing (anti)triplets
1593 C--find string end (=quark or antiquark)
1594  43 lquark=0
1595  DO 40 i=1,nold
1596  IF((k(i,1).EQ.11).OR.(k(i,1).EQ.12).OR.(k(i,1).EQ.13)
1597  & .OR.(k(i,1).EQ.14)) k(i,1)=17
1598  IF(((k(i,1).EQ.1).OR.(k(i,1).EQ.3).OR.(k(i,1).EQ.4).OR.
1599  & (k(i,1).EQ.5)).AND.((k(i,2).LT.6).OR.isdiquark(k(i,2))))THEN
1600  lquark=i
1601  goto 41
1602  ENDIF
1603  40 CONTINUE
1604  goto 50
1605  41 CONTINUE
1606 C--copy string end to end of event record
1607  n=n+1
1608  IF(n.GT.22990) THEN
1609  write(logfid,*)'event too long for event record'
1610  discard=.true.
1611  RETURN
1612  ENDIF
1613  k(n,1)=2
1614  k(n,2)=k(lquark,2)
1615  k(n,3)=lquark
1616  k(n,4)=0
1617  k(n,5)=0
1618  p(n,1)=p(lquark,1)
1619  p(n,2)=p(lquark,2)
1620  p(n,3)=p(lquark,3)
1621  p(n,4)=p(lquark,4)
1622  p(n,5)=p(lquark,5)
1623  k(lquark,1)=16
1624  k(lquark,4)=n
1625  k(lquark,5)=n
1626  trip(n)=trip(lquark)
1627  anti(n)=anti(lquark)
1628 C--append matching colour partner
1629  lmatch=0
1630  DO 44 j=1,10000000
1631  DO 42 i=1,nold
1632  IF(((k(i,1).EQ.1).OR.(k(i,1).EQ.3).OR.(k(i,1).EQ.4)
1633  & .OR.(k(i,1).EQ.5))
1634  & .AND.(((trip(i).EQ.anti(n)).AND.(trip(i).NE.0))
1635  & .OR.((anti(i).EQ.trip(n)).AND.(anti(i).NE.0))))THEN
1636  n=n+1
1637  IF(n.GT.22990) THEN
1638  write(logfid,*)'event too long for event record'
1639  discard=.true.
1640  RETURN
1641  ENDIF
1642  k(n,2)=k(i,2)
1643  k(n,3)=i
1644  k(n,4)=0
1645  k(n,5)=0
1646  p(n,1)=p(i,1)
1647  p(n,2)=p(i,2)
1648  p(n,3)=p(i,3)
1649  p(n,4)=p(i,4)
1650  p(n,5)=p(i,5)
1651  trip(n)=trip(i)
1652  anti(n)=anti(i)
1653  k(i,1)=16
1654  k(i,4)=n
1655  k(i,5)=n
1656  IF(k(i,2).EQ.21)THEN
1657  k(n,1)=2
1658  goto 44
1659  ELSE
1660  k(n,1)=1
1661  goto 43
1662  ENDIF
1663  ENDIF
1664  42 CONTINUE
1665 C--no matching colour partner found
1666  write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
1667  &'colour singlet system, will discard event'
1668  discard = .true.
1669  return
1670  44 CONTINUE
1671 C--now take care of purely gluonic remainder system
1672 C-----------------------------------------
1673 C--find gluon where anti-triplet is not matched
1674  50 lloose=0
1675  DO 45 i=1,nold
1676  IF(((k(i,1).EQ.1).OR.(k(i,1).EQ.3).OR.(k(i,1).EQ.4)
1677  & .OR.(k(i,1).EQ.5)))THEN
1678  DO 46 j=1,nold
1679  IF(((k(i,1).EQ.1).OR.(k(i,1).EQ.3).OR.(k(i,1).EQ.4)
1680  & .OR.(k(i,1).EQ.5)))THEN
1681  IF(anti(i).EQ.trip(j)) goto 45
1682  ENDIF
1683  46 CONTINUE
1684  lloose=i
1685  goto 47
1686  ENDIF
1687  45 CONTINUE
1688  goto 51
1689  47 CONTINUE
1690 C--generate artificial triplet end
1691  write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
1692  &'colour singlet system, will discard event'
1693  discard = .true.
1694  return
1695 C--copy loose gluon to end of event record
1696  n=n+1
1697  IF(n.GT.22990) THEN
1698  write(logfid,*)'event too long for event record'
1699  discard=.true.
1700  RETURN
1701  ENDIF
1702  k(n,1)=2
1703  k(n,2)=k(lloose,2)
1704  k(n,3)=lloose
1705  k(n,4)=0
1706  k(n,5)=0
1707  p(n,1)=p(lloose,1)
1708  p(n,2)=p(lloose,2)
1709  p(n,3)=p(lloose,3)
1710  p(n,4)=p(lloose,4)
1711  p(n,5)=p(lloose,5)
1712  k(lloose,1)=16
1713  k(lloose,4)=n
1714  k(lloose,5)=n
1715  trip(n)=trip(lloose)
1716  anti(n)=anti(lloose)
1717 C--append matching colour partner
1718  lmatch=0
1719  DO 48 j=1,10000000
1720  DO 49 i=1,nold
1721  IF(((k(i,1).EQ.1).OR.(k(i,1).EQ.3).OR.(k(i,1).EQ.4)
1722  & .OR.(k(i,1).EQ.5))
1723  & .AND.(anti(i).EQ.trip(n)))THEN
1724  n=n+1
1725  IF(n.GT.22990) THEN
1726  write(logfid,*)'event too long for event record'
1727  discard=.true.
1728  RETURN
1729  ENDIF
1730  k(n,2)=k(i,2)
1731  k(n,3)=i
1732  k(n,4)=0
1733  k(n,5)=0
1734  p(n,1)=p(i,1)
1735  p(n,2)=p(i,2)
1736  p(n,3)=p(i,3)
1737  p(n,4)=p(i,4)
1738  p(n,5)=p(i,5)
1739  trip(n)=trip(i)
1740  anti(n)=anti(i)
1741  k(i,1)=16
1742  k(i,4)=n
1743  k(i,5)=n
1744  k(n,1)=2
1745  goto 48
1746  ENDIF
1747  49 CONTINUE
1748 C--no matching colour partner found, add artificial end point
1749  write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '//
1750  &'colour singlet system, will discard event'
1751  discard = .true.
1752  return
1753  48 CONTINUE
1754  51 CONTINUE
1755  CALL cleanup(nold1)
1756  END
1757 
1758 
1759 ***********************************************************************
1760 *** subroutine makestrings_minl
1761 ***********************************************************************
1762  SUBROUTINE makestrings_minl
1763  IMPLICIT NONE
1764 C--Common block of Pythia
1765  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
1766  INTEGER n,npad,k
1767  DOUBLE PRECISION p,v
1768 C--Parameter common block
1769  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
1770  &allhad,compress,nf
1771  INTEGER nf
1772  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
1773  LOGICAL angord,scatrecoil,allhad,compress
1774 C--colour index common block
1775  common/colour/trip(23000),anti(23000),colmax
1776  INTEGER trip,anti,colmax
1777 C--local variables
1778  INTEGER nold,i,j,lmax,lmin,lend,nold1
1779  DOUBLE PRECISION emax,minv,mmin,z,generatez,mcut,eaddend,pyr,dir,
1780  &pyp
1781  DATA mcut/1.d8/
1782  DATA eaddend/10.d0/
1783 C--identifier of file for hepmc output and logfile
1784  common/hepmcid/hpmcfid,logfid
1785  integer hpmcfid,logfid
1786 C--discard event flag
1787  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
1788  LOGICAL discard
1789  INTEGER ndisc,nstrange,ngood,errcount
1790  double precision wdisc
1791  logical compressevent,roomleft
1792 
1793  i = 0
1794  if (compress) roomleft = compressevent(i)
1795  nold1=n
1796 C--remove all active lines that are leptons, gammas, hadrons etc.
1797  DO 52 i=1,nold1
1798  IF((k(i,1).EQ.4).AND.(trip(i).EQ.0).AND.(anti(i).EQ.0))THEN
1799 C--copy line to end of event record
1800  n=n+1
1801  IF(n.GT.22990) THEN
1802  write(logfid,*)'event too long for event record'
1803  discard=.true.
1804  RETURN
1805  ENDIF
1806  k(n,1)=11
1807  k(n,2)=k(i,2)
1808  k(n,3)=i
1809  k(n,4)=0
1810  k(n,5)=0
1811  p(n,1)=p(i,1)
1812  p(n,2)=p(i,2)
1813  p(n,3)=p(i,3)
1814  p(n,4)=p(i,4)
1815  p(n,5)=p(i,5)
1816  k(i,1)=17
1817  k(i,4)=n
1818  k(i,5)=n
1819  trip(n)=trip(i)
1820  anti(n)=anti(i)
1821  ENDIF
1822  52 CONTINUE
1823  nold=n
1824 C--find most energetic unfragmented parton in event
1825  43 emax=0
1826  lmax=0
1827  DO 40 i=1,nold
1828  IF((k(i,1).EQ.11).OR.(k(i,1).EQ.12).OR.(k(i,1).EQ.13)
1829  & .OR.(k(i,1).EQ.14)) k(i,1)=17
1830  if (abs(pyp(i,17)).gt.4.d0) k(i,1)=17
1831  IF(((k(i,1).EQ.1).OR.(k(i,1).EQ.3).OR.(k(i,1).EQ.4)
1832  & .OR.(k(i,1).EQ.5)).AND.(p(i,4).GT.emax))THEN
1833  emax=p(i,4)
1834  lmax=i
1835  ENDIF
1836  40 CONTINUE
1837 C--if there is non, we are done
1838  IF(lmax.EQ.0) goto 50
1839 C--check if highest energy parton is (anti)quark or gluon
1840  IF(k(lmax,2).EQ.21)THEN
1841 C--split gluon in qqbar pair and store one temporarily in line 1
1842 C--make new line in event record for string end
1843  n=n+2
1844  IF(n.GT.22990) THEN
1845  write(logfid,*)'event too long for event record'
1846  discard=.true.
1847  RETURN
1848  ENDIF
1849  IF((n-2).GT.nold)THEN
1850  DO 47 j=nold,n-3
1851  k(n+nold-j,1)=k(n+nold-j-2,1)
1852  k(n+nold-j,2)=k(n+nold-j-2,2)
1853  IF(k(n+nold-j-2,3).GT.nold) THEN
1854  k(n+nold-j,3)=k(n+nold-j-2,3)+2
1855  ELSE
1856  k(n+nold-j,3)=k(n+nold-j-2,3)
1857  ENDIF
1858  k(n+nold-j,4)=0
1859  k(n+nold-j,5)=0
1860  p(n+nold-j,1)=p(n+nold-j-2,1)
1861  p(n+nold-j,2)=p(n+nold-j-2,2)
1862  p(n+nold-j,3)=p(n+nold-j-2,3)
1863  p(n+nold-j,4)=p(n+nold-j-2,4)
1864  p(n+nold-j,5)=p(n+nold-j-2,5)
1865  k(k(n+nold-j-2,3),4)=k(k(n+nold-j-2,3),4)+2
1866  k(k(n+nold-j-2,3),5)=k(k(n+nold-j-2,3),5)+2
1867  47 CONTINUE
1868  ENDIF
1869  nold=nold+2
1870  k(lmax,1)=18
1871  z=generatez(0.d0,0.d0,1.d-3,'QG')
1872  IF(z.GT.0.5)THEN
1873  k(nold-1,2)=1
1874  k(nold,2)=-1
1875  ELSE
1876  z=1.-z
1877  k(nold-1,2)=-1
1878  k(nold,2)=1
1879  ENDIF
1880  k(nold-1,1)=1
1881  k(nold-1,3)=lmax
1882  k(nold-1,4)=0
1883  k(nold-1,5)=0
1884  p(nold-1,1)=(1.-z)*p(lmax,1)
1885  p(nold-1,2)=(1.-z)*p(lmax,2)
1886  p(nold-1,3)=(1.-z)*p(lmax,3)
1887  p(nold-1,4)=(1.-z)*p(lmax,4)
1888  p(nold-1,5)=p(lmax,5)
1889  k(nold,1)=1
1890  k(nold,3)=lmax
1891  k(nold,4)=0
1892  k(nold,5)=0
1893  p(nold,1)=z*p(lmax,1)
1894  p(nold,2)=z*p(lmax,2)
1895  p(nold,3)=z*p(lmax,3)
1896  p(nold,4)=z*p(lmax,4)
1897  p(nold,5)=p(lmax,5)
1898  k(lmax,1)=18
1899  k(lmax,4)=nold-1
1900  k(lmax,5)=nold
1901  lmax=nold
1902  ENDIF
1903  n=n+1
1904  IF(n.GT.22990) THEN
1905  write(logfid,*)'event too long for event record'
1906  discard=.true.
1907  RETURN
1908  ENDIF
1909  k(n,1)=2
1910  k(n,2)=k(lmax,2)
1911  k(n,3)=lmax
1912  k(n,4)=0
1913  k(n,5)=0
1914  p(n,1)=p(lmax,1)
1915  p(n,2)=p(lmax,2)
1916  p(n,3)=p(lmax,3)
1917  p(n,4)=p(lmax,4)
1918  p(n,5)=p(lmax,5)
1919  k(lmax,1)=16
1920  k(lmax,4)=n
1921  k(lmax,5)=n
1922  lend=lmax
1923 C--find closest partner
1924  42 mmin=1.d10
1925  lmin=0
1926  DO 41 i=1,nold
1927  IF(((k(i,1).EQ.1).OR.(k(i,1).EQ.3).OR.(k(i,1)
1928  & .EQ.4).OR.(k(i,1).EQ.5))
1929  & .AND.((k(i,2).EQ.21).OR.((k(i,2)*k(lend,2).LT.0.d0).AND.
1930  & (k(i,3).NE.k(lend,3))))
1931  & .AND.(p(i,1)*p(lend,1).GT.0.d0))THEN
1932  minv=p(i,4)*p(lmax,4)-p(i,1)*p(lmax,1)-p(i,2)*p(lmax,2)
1933  & -p(i,3)*p(lmax,3)
1934  IF((minv.LT.mmin).AND.(minv.GT.0.d0).AND.(minv.LT.mcut))THEN
1935  mmin=minv
1936  lmin=i
1937  ENDIF
1938  ENDIF
1939  41 CONTINUE
1940 C--if no closest partner can be found, generate artificial end point for string
1941  IF(lmin.EQ.0)THEN
1942  n=n+1
1943  IF(n.GT.22990) THEN
1944  write(logfid,*)'event too long for event record'
1945  discard=.true.
1946  RETURN
1947  ENDIF
1948  k(n,1)=1
1949  k(n,2)=-k(lend,2)
1950  k(n,3)=0
1951  k(n,4)=0
1952  k(n,5)=0
1953  p(n,1)=0.d0
1954  p(n,2)=0.d0
1955  IF(pyr(0).LT.0.5)THEN
1956  dir=1.d0
1957  ELSE
1958  dir=-1.d0
1959  ENDIF
1960  p(n,3)=dir*eaddend
1961  p(n,4)=eaddend
1962  p(n,5)=0.d0
1963  goto 43
1964  ELSE
1965 C--else build closest partner in string
1966  n=n+1
1967  IF(n.GT.22990) THEN
1968  write(logfid,*)'event too long for event record'
1969  discard=.true.
1970  RETURN
1971  ENDIF
1972  k(n,2)=k(lmin,2)
1973  k(n,3)=lmin
1974  k(n,4)=0
1975  k(n,5)=0
1976  p(n,1)=p(lmin,1)
1977  p(n,2)=p(lmin,2)
1978  p(n,3)=p(lmin,3)
1979  p(n,4)=p(lmin,4)
1980  p(n,5)=p(lmin,5)
1981  k(lmin,1)=16
1982  k(lmin,4)=n
1983  k(lmin,5)=n
1984  IF(k(lmin,2).EQ.21)THEN
1985  k(n,1)=2
1986  lmax=lmin
1987  goto 42
1988  ELSE
1989  k(n,1)=1
1990  goto 43
1991  ENDIF
1992  ENDIF
1993  50 CONTINUE
1994  CALL cleanup(nold)
1995  END
1996 
1997 
1998 ***********************************************************************
1999 *** subroutine cleanup
2000 ***********************************************************************
2001  SUBROUTINE cleanup(NFIRST)
2002  IMPLICIT NONE
2003 C--Common block of Pythia
2004  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
2005  INTEGER n,npad,k
2006  DOUBLE PRECISION p,v
2007 C--local variables
2008  INTEGER nfirst,nlast,i,j
2009 
2010  nlast=n
2011  DO 21 i=1,nlast-nfirst
2012  DO 22 j=1,5
2013  k(i,j)=k(nfirst+i,j)
2014  p(i,j)=p(nfirst+i,j)
2015  v(i,j)=v(nfirst+i,j)
2016  22 CONTINUE
2017  k(i,3)=0
2018  21 CONTINUE
2019  n=nlast-nfirst
2020  END
2021 
2022 
2023 ***********************************************************************
2024 *** subroutine makecascade
2025 ***********************************************************************
2026  SUBROUTINE makecascade
2027  IMPLICIT NONE
2028 C--Common block of Pythia
2029  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
2030  INTEGER n,npad,k
2031  DOUBLE PRECISION p,v
2032 C--time common block
2033  common/time/mv(23000,5)
2034  DOUBLE PRECISION mv
2035 C--Parameter common block
2036  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
2037  &allhad,compress,nf
2038  INTEGER nf
2039  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
2040  LOGICAL angord,scatrecoil,allhad,compress
2041 C--discard event flag
2042  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
2043  LOGICAL discard
2044  INTEGER ndisc,nstrange,ngood,errcount
2045  double precision wdisc
2046 
2047 C--local variables
2048  INTEGER nold,i
2049  LOGICAL cont
2050 
2051  10 nold=n
2052  cont=.false.
2053  DO 11 i=2,nold
2054  if (i.gt.n) goto 10
2055 C--check if parton may evolve, i.e. do splitting or scattering
2056  IF((k(i,1).EQ.1).OR.(k(i,1).EQ.2))THEN
2057  cont=.true.
2058  CALL makebranch(i)
2059  IF(discard) goto 12
2060  ENDIF
2061  11 CONTINUE
2062  IF(cont) goto 10
2063  12 END
2064 
2065 
2066 ***********************************************************************
2067 *** subroutine makebranch
2068 ***********************************************************************
2069  SUBROUTINE makebranch(L)
2070  IMPLICIT NONE
2071 C--Common block of Pythia
2072  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
2073  INTEGER n,npad,k
2074  DOUBLE PRECISION p,v
2075 C--time common block
2076  common/time/mv(23000,5)
2077  DOUBLE PRECISION mv
2078 C--Parameter common block
2079  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
2080  &allhad,compress,nf
2081  INTEGER nf
2082  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
2083  LOGICAL angord,scatrecoil,allhad,compress
2084 C--discard event flag
2085  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
2086  LOGICAL discard
2087  INTEGER ndisc,nstrange,ngood,errcount
2088  double precision wdisc
2089 C--variables for angular ordering
2090  common/angor/za(23000),zd(23000),thetaa(23000),qqbard(23000)
2091  DOUBLE PRECISION za,zd,thetaa
2092  LOGICAL qqbard
2093 C--number of scattering events
2094  common/check/nscat,nscateff,nsplit
2095  DOUBLE PRECISION nscat,nscateff,nsplit
2096 C--variables for coherent scattering
2097  common/coherent/nstart,nend,allqs(10000,6),scatcentres(10000,10),
2098  &qsumvec(4),qsum2
2099  INTEGER nstart,nend
2100  DOUBLE PRECISION allqs,scatcentres,qsumvec,qsum2
2101 C--event weight
2102  common/weight/evweight,sumofweights
2103  double precision evweight,sumofweights
2104 C--identifier of file for hepmc output and logfile
2105  common/hepmcid/hpmcfid,logfid
2106  integer hpmcfid,logfid
2107 C--extra storage for scattering centres before interactions
2108  common/storescatcen/nscatcen,maxnscatcen,scatflav(10000),
2109  & scatcen(10000,5),writescatcen,writedummies
2110  integer nscatcen,maxnscatcen,scatflav
2111  double precision scatcen
2112  logical writescatcen,writedummies
2113 C--local variables
2114  INTEGER l,line,nold,typi,lineold,lkine,nendold,nscatcenold
2115  DOUBLE PRECISION theta,phi,pyp,formtime,starttime,tleft,
2116  &tsum,deltat,newmass,getmass,q,getms,zdec,x,dtcorr
2117  LOGICAL overq0,qqbardec
2118  CHARACTER typ
2119  LOGICAL radiation,retrysplit,medind,roomleft,compressevent
2120 
2121  line=l
2122  nstart=0
2123  nend=0
2124  starttime=mv(line,4)
2125  tsum=0.d0
2126  qsum2=0.d0
2127  qsumvec(1)=0.d0
2128  qsumvec(2)=0.d0
2129  qsumvec(3)=0.d0
2130  qsumvec(4)=0.d0
2131  retrysplit=.false.
2132  medind=.false.
2133  x=0.d0
2134  q=0.d0
2135  typi=0
2136 
2137  IF ((n.GT.20000).and.compress) roomleft = compressevent(line)
2138 
2139 20 IF(discard) RETURN
2140  IF(((k(line,1).EQ.1).AND.(p(line,5).GT.0.d0))
2141  & .OR.((k(line,1).EQ.2).AND.(zd(line).gt.0.d0)))THEN
2142  IF(medind)THEN
2143  formtime=starttime
2144  ELSE
2145  formtime=min(mv(line,5),ltime)
2146  ENDIF
2147  radiation=.true.
2148  ELSE
2149  formtime=ltime
2150  radiation=.false.
2151  ENDIF
2152  tleft=formtime-starttime
2153  IF(k(line,2).EQ.21)THEN
2154  typ='G'
2155  ELSE
2156  typ='Q'
2157  ENDIF
2158  medind=.false.
2159 
2160  IF(tleft.LE.1.d-10)THEN
2161 C--no scattering
2162  IF(radiation)THEN
2163 C--if there is radiation associated with the parton then form it now
2164 C--rotate such that momentum points in z-direction
2165  nold=n
2166  nscatcenold=nscatcen
2167  theta=pyp(line,13)
2168  phi=pyp(line,15)
2169  CALL pyrobo(line,line,0d0,-phi,0d0,0d0,0d0)
2170  CALL pyrobo(line,line,-theta,0d0,0d0,0d0,0d0)
2171  CALL makesplitting(line)
2172 C--rotate back
2173  CALL pyrobo(line,line,theta,0d0,0d0,0d0,0d0)
2174  CALL pyrobo(line,line,0d0,phi,0d0,0d0,0d0)
2175  IF(discard) RETURN
2176  CALL pyrobo(n-1,n,theta,0d0,0d0,0d0,0d0)
2177  CALL pyrobo(n-1,n,0d0,phi,0d0,0d0,0d0)
2178 C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
2179  mv(n-1,1)=mv(line,1)
2180  & +(mv(n-1,4)-mv(line,4))*p(line,1)/max(pyp(line,8),p(line,4))
2181  mv(n-1,2)=mv(line,2)
2182  & +(mv(n-1,4)-mv(line,4))*p(line,2)/max(pyp(line,8),p(line,4))
2183  mv(n-1,3)=mv(line,3)
2184  & +(mv(n-1,4)-mv(line,4))*p(line,3)/max(pyp(line,8),p(line,4))
2185  mv(n, 1)=mv(line,1)
2186  & +(mv(n, 4)-mv(line,4))*p(line,1)/max(pyp(line,8),p(line,4))
2187  mv(n, 2)=mv(line,2)
2188  & +(mv(n, 4)-mv(line,4))*p(line,2)/max(pyp(line,8),p(line,4))
2189  mv(n, 3)=mv(line,3)
2190  & +(mv(n, 4)-mv(line,4))*p(line,3)/max(pyp(line,8),p(line,4))
2191 
2192  line=n
2193  nstart=0
2194  nend=0
2195  starttime=mv(n,4)
2196  qsumvec(1)=0.d0
2197  qsumvec(2)=0.d0
2198  qsumvec(3)=0.d0
2199  qsumvec(4)=0.d0
2200  qsum2=0.d0
2201  tsum=0.d0
2202  goto 21
2203  ELSE
2204  nstart=0
2205  nend=0
2206  starttime=formtime
2207  qsumvec(1)=0.d0
2208  qsumvec(2)=0.d0
2209  qsumvec(3)=0.d0
2210  qsumvec(4)=0.d0
2211  qsum2=0.d0
2212  tsum=0.d0
2213  goto 21
2214  ENDIF
2215  ELSE
2216 C--do scattering
2217 C--find delta t for the scattering
2218  deltat=tleft
2219  overq0=.false.
2220  CALL doinstatescat(line,x,typi,q,starttime+tsum,deltat,
2221  & overq0,.false.)
2222  tsum=tsum+deltat
2223  tleft=tleft-deltat
2224 C--do initial state splitting if there is one
2225  nold=n
2226  lineold=line
2227  zdec=zd(line)
2228  qqbardec=qqbard(line)
2229  nscatcenold=nscatcen
2230  25 IF(x.LT.1.d0) THEN
2231  CALL makeinsplit(line,x,qsum2,q,typi,starttime+tsum,deltat)
2232  IF(discard) RETURN
2233  IF(x.LT.1.d0)THEN
2234  line=n
2235  lkine=n
2236  IF(k(line,2).EQ.21)THEN
2237  newmass=getmass(0.d0,scalefacm*sqrt(-qsum2),-1.d0,p(line,4),
2238  & 'GC',sqrt(-qsum2),.false.,zdec,qqbardec)
2239  IF(zdec.GT.0.d0)THEN
2240  thetaa(line)=newmass/(sqrt(zdec*(1.-zdec))*p(line,4))
2241  ELSE
2242  thetaa(line)=0.d0
2243  ENDIF
2244  zd(line)=zdec
2245  qqbard(line)=qqbardec
2246  ELSE
2247  newmass=getmass(0.d0,scalefacm*sqrt(-qsum2),-1.d0,p(line,4),
2248  & 'QQ',sqrt(-qsum2),.false.,zdec,qqbardec)
2249  IF(zdec.GT.0.d0)THEN
2250  thetaa(line)=newmass/(sqrt(zdec*(1.-zdec))*p(line,4))
2251  ELSE
2252  thetaa(line)=0.d0
2253  ENDIF
2254  zd(line)=zdec
2255  qqbard(line)=qqbardec
2256  ENDIF
2257  zdec=zd(line)
2258  qqbardec=qqbard(line)
2259  ELSE
2260  lkine=line
2261  nend=nstart
2262  qsum2=allqs(nend,1)
2263  qsumvec(1)=allqs(nend,2)
2264  qsumvec(2)=allqs(nend,3)
2265  qsumvec(3)=allqs(nend,4)
2266  qsumvec(4)=allqs(nend,5)
2267  IF(-allqs(nend,1).GT.q0**2/scalefacm**2)THEN
2268  overq0=.true.
2269  ELSE
2270  overq0=.false.
2271  ENDIF
2272  tleft = starttime+tsum+tleft-allqs(1,6)
2273  tsum = allqs(1,6)-starttime
2274  ENDIF
2275  ENDIF
2276  IF(x.EQ.1.d0)THEN
2277  newmass=0.d0
2278  IF(nend.GT.0)THEN
2279  CALL dofistatescat(line,starttime+tsum,tleft,deltat,
2280  & newmass,overq0,zdec,qqbardec)
2281  IF(newmass.GT.(p(line,5)*(1.d0+1.d-6)))THEN
2282  medind=.true.
2283  ELSE
2284  medind=.false.
2285  zdec=zd(line)
2286  qqbardec=qqbard(line)
2287  ENDIF
2288  tsum=tsum+deltat
2289  tleft=tleft-deltat
2290  lkine=line
2291  ENDIF
2292  ENDIF
2293 C--do kinematics
2294  retrysplit=.false.
2295  IF(nend.GT.0) THEN
2296  nendold=nend
2297  CALL dokinematics(lkine,lineold,nstart,nend,newmass,retrysplit,
2298  & starttime+tsum,x,zdec,qqbardec)
2299  IF(retrysplit) THEN
2300  tleft = starttime+tsum+tleft-allqs(1,6)
2301  tsum = allqs(1,6)-starttime
2302  if (x.lt.1.d0) then
2303  nend=nstart
2304  qsum2=allqs(nend,1)
2305  qsumvec(1)=allqs(nend,2)
2306  qsumvec(2)=allqs(nend,3)
2307  qsumvec(3)=allqs(nend,4)
2308  qsumvec(4)=allqs(nend,5)
2309  typi=k(l,2)
2310  IF(-allqs(nend,1).GT.q0**2/scalefacm**2)THEN
2311  overq0=.true.
2312  ELSE
2313  overq0=.false.
2314  ENDIF
2315  n=nold
2316  line=lineold
2317  x=1.d0
2318  k(line,1)=1
2319  nscatcen=nscatcenold
2320  nsplit=nsplit-evweight
2321  goto 25
2322  else
2323  line=n
2324  starttime=starttime+tsum
2325  tsum=0.d0
2326  endif
2327  ELSE
2328  line=n
2329  starttime=starttime+tsum
2330  tsum=0.d0
2331  ENDIF
2332  ELSE
2333  starttime=starttime+tsum
2334  tsum=0.d0
2335  ENDIF
2336  IF(p(line,5).GT.0.d0) radiation=.true.
2337  ENDIF
2338 
2339  21 IF(((k(line,1).EQ.1).AND.(p(line,5).GT.0.d0))
2340  & .OR.((k(line,1).EQ.2).AND.(zd(line).gt.0.d0))
2341  & .OR.(starttime.LT.ltime))THEN
2342  goto 20
2343  ENDIF
2344  IF((k(line,1).EQ.1).AND.(p(line,5).EQ.0.d0)) k(line,1)=4
2345  IF((k(line,1).EQ.2).AND.(zd(line).lt.0.d0)) k(line,1)=5
2346  END
2347 
2348 
2349 
2350 ***********************************************************************
2351 *** subroutine makesplitting
2352 ***********************************************************************
2353  SUBROUTINE makesplitting(L)
2354  IMPLICIT NONE
2355 C--identifier of file for hepmc output and logfile
2356  common/hepmcid/hpmcfid,logfid
2357  integer hpmcfid,logfid
2358 C--Common block of Pythia
2359  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
2360  INTEGER n,npad,k
2361  DOUBLE PRECISION p,v
2362 C--time common block
2363  common/time/mv(23000,5)
2364  DOUBLE PRECISION mv
2365 C--factor in front of formation times
2366  common/ftimefac/ftfac
2367  DOUBLE PRECISION ftfac
2368 C--colour index common block
2369  common/colour/trip(23000),anti(23000),colmax
2370  INTEGER trip,anti,colmax
2371 C--Parameter common block
2372  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
2373  &allhad,compress,nf
2374  INTEGER nf
2375  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
2376  LOGICAL angord,scatrecoil,allhad,compress
2377 C--discard event flag
2378  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
2379  LOGICAL discard
2380  INTEGER ndisc,nstrange,ngood,errcount
2381  double precision wdisc
2382 C--variables for angular ordering
2383  common/angor/za(23000),zd(23000),thetaa(23000),qqbard(23000)
2384  DOUBLE PRECISION za,zd,thetaa
2385  LOGICAL qqbard
2386 C--number of scattering events
2387  common/check/nscat,nscateff,nsplit
2388  DOUBLE PRECISION nscat,nscateff,nsplit
2389 C--event weight
2390  common/weight/evweight,sumofweights
2391  double precision evweight,sumofweights
2392 
2393 C--local variables
2394  INTEGER l,dir
2395  DOUBLE PRECISION phiq,pyr,pi,generatez,bmax1,cmax1,pts,mb,mc,
2396  &getmass,pz,eps,qh,z,r,lambda,weight,zdecb,zdecc,xdec(3),theta,
2397  &gettemp
2398  LOGICAL quark,qqbar,qqbardecb,qqbardecc
2399  integer bin
2400  DATA pi/3.141592653589793d0/
2401 
2402  IF((n+2).GT.22990) THEN
2403  write(logfid,*)'event too long for event record'
2404  discard=.true.
2405  RETURN
2406  ENDIF
2407 
2408  xdec(1)=mv(l,1)+(mv(l,5)-mv(l,4))*p(l,1)/p(l,4)
2409  xdec(2)=mv(l,2)+(mv(l,5)-mv(l,4))*p(l,2)/p(l,4)
2410  xdec(3)=mv(l,3)+(mv(l,5)-mv(l,4))*p(l,3)/p(l,4)
2411  IF(gettemp(xdec(1),xdec(2),xdec(3),mv(l,5)).GT.0.d0)THEN
2412  theta=-1.d0
2413  ELSE
2414  theta=thetaa(l)
2415  ENDIF
2416 
2417 C--on-shell partons cannot split
2418  IF((p(l,5).EQ.0d0).OR.(k(l,1).EQ.11).OR.(k(l,1).EQ.12)
2419  & .OR.(k(l,1).EQ.13).OR.(k(l,1).EQ.14).OR.(k(l,1).EQ.3)
2420  & .or.(zd(l).lt.0.d0)) goto 31
2421 C--quark or gluon?
2422  IF(k(l,2).EQ.21)THEN
2423  quark=.false.
2424  ELSE
2425  quark=.true.
2426  qqbar=.false.
2427  ENDIF
2428 C--if gluon decide on kind of splitting
2429  qqbar=qqbard(l)
2430 C--if g->gg splitting decide on colour order
2431  IF(quark.OR.qqbar)THEN
2432  dir=0
2433  ELSE
2434  IF(pyr(0).LT.0.5)THEN
2435  dir=1
2436  ELSE
2437  dir=-1
2438  ENDIF
2439  ENDIF
2440  z=zd(l)
2441  IF(z.EQ.0.d0)THEN
2442  write(logfid,*)'makesplitting: z=0',l
2443  goto 36
2444  ENDIF
2445  goto 35
2446 C--generate z value
2447  36 IF(angord.AND.(za(l).NE.1.d0))THEN
2448 C--additional z constraint due to angular ordering
2449  qh=4.*p(l,5)**2*(1.-za(l))/(za(l)*p(k(l,3),5)**2)
2450  IF(qh.GT.1)THEN
2451  write(logfid,*)l,': reject event: angular ordering
2452  & conflict in medium'
2453  CALL pylist(3)
2454  discard=.true.
2455  goto 31
2456  ENDIF
2457  eps=0.5-0.5*sqrt(1.-qh)
2458  ELSE
2459  eps=0d0
2460  ENDIF
2461  IF(quark)THEN
2462  z=generatez(p(l,5)**2,p(l,4),eps,'QQ')
2463  ELSE
2464  IF(qqbar)THEN
2465  z=generatez(p(l,5)**2,p(l,4),eps,'QG')
2466  ELSE
2467  z=generatez(p(l,5)**2,p(l,4),eps,'GG')
2468  ENDIF
2469  ENDIF
2470  35 CONTINUE
2471 C--maximum virtualities for daughters
2472  bmax1=min(p(l,5),z*p(l,4))
2473  cmax1=min(p(l,5),(1.-z)*p(l,4))
2474 C--generate mass of quark or gluon (particle b) from Sudakov FF
2475  30 IF(quark.OR.qqbar)THEN
2476  mb=getmass(0.d0,bmax1,theta,z*p(l,4),'QQ',
2477  & bmax1,.false.,zdecb,qqbardecb)
2478  ELSE
2479  mb=getmass(0.d0,bmax1,theta,z*p(l,4),'GC',
2480  & bmax1,.false.,zdecb,qqbardecb)
2481  ENDIF
2482 C--generate mass gluon (particle c) from Sudakov FF
2483  IF(quark.OR.(.NOT.qqbar))THEN
2484  mc=getmass(0.d0,cmax1,theta,(1.-z)*p(l,4),'GC',
2485  & cmax1,.false.,zdecc,qqbardecc)
2486  ELSE
2487  mc=getmass(0.d0,cmax1,theta,(1.-z)*p(l,4),'QQ',
2488  & cmax1,.false.,zdecc,qqbardecc)
2489  ENDIF
2490 C--quark (parton b) momentum
2491  182 pz=(2.*z*p(l,4)**2-p(l,5)**2-mb**2+mc**2)/(2.*p(l,3))
2492  pts=z**2*(p(l,4)**2)-pz**2-mb**2
2493 C--if kinematics doesn't work out, generate new virtualities
2494 C for daughters
2495 C--massive phase space weight
2496  IF((mb.EQ.0.d0).AND.(mc.EQ.0.d0).AND.(pts.LT.0.d0)) goto 36
2497  weight=1.d0
2498  IF((pyr(0).GT.weight).OR.(pts.LT.0.d0)
2499  & .OR.((mb+mc).GT.p(l,5)))THEN
2500  IF(mb.GT.mc)THEN
2501  IF(quark.OR.qqbar)THEN
2502  mb=getmass(0.d0,mb,theta,z*p(l,4),'QQ',
2503  & bmax1,.false.,zdecb,qqbardecb)
2504  ELSE
2505  mb=getmass(0.d0,mb,theta,z*p(l,4),'GC',
2506  & bmax1,.false.,zdecb,qqbardecb)
2507  ENDIF
2508  ELSE
2509  IF(quark.OR.(.NOT.qqbar))THEN
2510  mc=getmass(0.d0,mc,theta,(1.-z)*p(l,4),'GC',
2511  & cmax1,.false.,zdecc,qqbardecc)
2512  ELSE
2513  mc=getmass(0.d0,mc,theta,(1.-z)*p(l,4),'QQ',
2514  & cmax1,.false.,zdecc,qqbardecc)
2515  ENDIF
2516  ENDIF
2517  goto 182
2518  ENDIF
2519  n=n+2
2520 C--take care of first daughter (radiated gluon or antiquark)
2521  k(n-1,1)=k(l,1)
2522  IF(qqbar)THEN
2523  k(n-1,2)=-1
2524  trip(n-1)=0
2525  anti(n-1)=anti(l)
2526  ELSE
2527  k(n-1,2)=21
2528  IF((k(l,2).GT.0).AND.(dir.GE.0))THEN
2529  trip(n-1)=trip(l)
2530  anti(n-1)=colmax+1
2531  ELSE
2532  trip(n-1)=colmax+1
2533  anti(n-1)=anti(l)
2534  ENDIF
2535  colmax=colmax+1
2536  ENDIF
2537  k(n-1,3)=l
2538  k(n-1,4)=0
2539  k(n-1,5)=0
2540  p(n-1,4)=(1-z)*p(l,4)
2541  p(n-1,5)=mc
2542  za(n-1)=1.-z
2543  IF(zdecc.GT.0.d0)THEN
2544  thetaa(n-1)=p(n-1,5)/(sqrt(zdecc*(1.-zdecc))*p(n-1,4))
2545  ELSE
2546  thetaa(n-1)=0.d0
2547  ENDIF
2548  zd(n-1)=zdecc
2549  qqbard(n-1)=qqbardecc
2550 C--take care of second daughter (final quark or gluon or quark from
2551 C gluon splitting)
2552  k(n,1)=k(l,1)
2553  IF(quark)THEN
2554  k(n,2)=k(l,2)
2555  IF(k(n,2).GT.0)THEN
2556  trip(n)=anti(n-1)
2557  anti(n)=0
2558  ELSE
2559  trip(n)=0
2560  anti(n)=trip(n-1)
2561  ENDIF
2562  ELSEIF(qqbar)THEN
2563  k(n,2)=1
2564  trip(n)=trip(l)
2565  anti(n)=0
2566  ELSE
2567  k(n,2)=21
2568  IF(dir.EQ.1)THEN
2569  trip(n)=anti(n-1)
2570  anti(n)=anti(l)
2571  ELSE
2572  trip(n)=trip(l)
2573  anti(n)=trip(n-1)
2574  ENDIF
2575  ENDIF
2576  k(n,3)=l
2577  k(n,4)=0
2578  k(n,5)=0
2579  p(n,3)=pz
2580  p(n,4)=z*p(l,4)
2581  p(n,5)=mb
2582  za(n)=z
2583  IF(zdecb.GT.0.d0)THEN
2584  thetaa(n)=p(n,5)/(sqrt(zdecb*(1.-zdecb))*p(n,4))
2585  ELSE
2586  thetaa(n)=0.d0
2587  ENDIF
2588  zd(n)=zdecb
2589  qqbard(n)=qqbardecb
2590 C--azimuthal angle
2591  phiq=2*pi*pyr(0)
2592  p(n,1)=sqrt(pts)*cos(phiq)
2593  p(n,2)=sqrt(pts)*sin(phiq)
2594 C--gluon momentum
2595  p(n-1,1)=p(l,1)-p(n,1)
2596  p(n-1,2)=p(l,2)-p(n,2)
2597  p(n-1,3)=p(l,3)-p(n,3)
2598  mv(n-1,4)=mv(l,5)
2599  IF(p(n-1,5).GT.0.d0)THEN
2600  lambda=1.d0/(ftfac*p(n-1,4)*0.2/p(n-1,5)**2)
2601  mv(n-1,5)=mv(l,5)-log(1.d0-pyr(0))/lambda
2602  ELSE
2603  mv(n-1,5)=0.d0
2604  ENDIF
2605  mv(n,4)=mv(l,5)
2606  IF(p(n,5).GT.0.d0)THEN
2607  lambda=1.d0/(ftfac*p(n,4)*0.2/p(n,5)**2)
2608  mv(n,5)=mv(l,5)-log(1.d0-pyr(0))/lambda
2609  ELSE
2610  mv(n,5)=0.d0
2611  ENDIF
2612 C--take care of initial quark (or gluon)
2613  IF(k(l,1).EQ.2)THEN
2614  k(l,1)=13
2615  ELSE
2616  k(l,1)=11
2617  ENDIF
2618  k(l,4)=n-1
2619  k(l,5)=n
2620  nsplit=nsplit+evweight
2621  31 CONTINUE
2622  END
2623 
2624 
2625 ***********************************************************************
2626 *** subroutine makeinsplit
2627 ***********************************************************************
2628  SUBROUTINE makeinsplit(L,X,TSUM,VIRT,TYPI,TIME,TAURAD)
2629  IMPLICIT NONE
2630 C--identifier of file for hepmc output and logfile
2631  common/hepmcid/hpmcfid,logfid
2632  integer hpmcfid,logfid
2633 C--Common block of Pythia
2634  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
2635  INTEGER n,npad,k
2636  DOUBLE PRECISION p,v
2637 C--time common block
2638  common/time/mv(23000,5)
2639  DOUBLE PRECISION mv
2640 C--factor in front of formation times
2641  common/ftimefac/ftfac
2642  DOUBLE PRECISION ftfac
2643 C--colour index common block
2644  common/colour/trip(23000),anti(23000),colmax
2645  INTEGER trip,anti,colmax
2646 C--variables for angular ordering
2647  common/angor/za(23000),zd(23000),thetaa(23000),qqbard(23000)
2648  DOUBLE PRECISION za,zd,thetaa
2649  LOGICAL qqbard
2650 C--discard event flag
2651  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
2652  LOGICAL discard
2653  INTEGER ndisc,nstrange,ngood,errcount
2654  double precision wdisc
2655 C--Parameter common block
2656  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
2657  &allhad,compress,nf
2658  INTEGER nf
2659  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
2660  LOGICAL angord,scatrecoil,allhad,compress
2661 C--number of scattering events
2662  common/check/nscat,nscateff,nsplit
2663  DOUBLE PRECISION nscat,nscateff,nsplit
2664 C--event weight
2665  common/weight/evweight,sumofweights
2666  double precision evweight,sumofweights
2667 
2668 C--local variables
2669  INTEGER l,typi,nold,dir
2670  DOUBLE PRECISION x,virt,mb2,mc2,getmass,pz,kt2,theta,phi,pi,
2671  &phiq,pyp,pyr,r,time,tsum,taurad,lambda,zdec
2672  LOGICAL qqbardec
2673  CHARACTER*2 typ2,typc
2674  integer bin
2675  DATA pi/3.141592653589793d0/
2676 
2677  IF((n+2).GT.22990) THEN
2678  write(logfid,*)'event too long for event record'
2679  discard=.true.
2680  RETURN
2681  ENDIF
2682 
2683  IF(k(l,2).EQ.21)THEN
2684  IF(typi.EQ.21)THEN
2685  typ2='GG'
2686  typc='GC'
2687  ELSE
2688  typ2='QG'
2689  typc='QQ'
2690  ENDIF
2691  ELSE
2692  IF(typi.EQ.21)THEN
2693  typ2='GQ'
2694  typc='QQ'
2695  ELSE
2696  typ2='QQ'
2697  typc='GC'
2698  ENDIF
2699  ENDIF
2700 
2701 C--if g->gg decide on colour configuration
2702  IF(typ2.EQ.'GG')THEN
2703  IF(pyr(0).LT.0.5)THEN
2704  dir=1
2705  ELSE
2706  dir=-1
2707  ENDIF
2708  ELSE
2709  dir=0
2710  ENDIF
2711 
2712  mb2=virt**2
2713  mb2=p(l,5)**2-mb2
2714  mc2=getmass(0.d0,scalefacm*sqrt(-tsum),-1.d0,
2715  & (1.-x)*p(l,4),typc,(1.-x)*p(l,4),
2716  & .false.,zdec,qqbardec)**2
2717 
2718 C--rotate such that momentum points in z-direction
2719  nold=n
2720  theta=pyp(l,13)
2721  phi=pyp(l,15)
2722  CALL pyrobo(l,l,0d0,-phi,0d0,0d0,0d0)
2723  CALL pyrobo(l,l,-theta,0d0,0d0,0d0,0d0)
2724  pz=(2*x*p(l,4)**2-p(l,5)**2-mb2+mc2)/(2*p(l,3))
2725  kt2=x**2*(p(l,4)**2)-pz**2-mb2
2726  IF(kt2.LT.0.d0)THEN
2727  mc2=0.d0
2728  pz=(2*x*p(l,4)**2-p(l,5)**2-mb2+mc2)/(2*p(l,3))
2729  kt2=x**2*(p(l,4)**2)-pz**2-mb2
2730  IF(kt2.LT.0.d0)THEN
2731  CALL pyrobo(l,l,theta,0d0,0d0,0d0,0d0)
2732  CALL pyrobo(l,l,0d0,phi,0d0,0d0,0d0)
2733  x=1.d0
2734  RETURN
2735  ENDIF
2736  ENDIF
2737  n=n+2
2738 C--take care of first daughter (radiated gluon or antiquark)
2739  k(n-1,1)=k(l,1)
2740  IF(typ2.EQ.'QG')THEN
2741  k(n-1,2)=-typi
2742  IF(k(n-1,2).GT.0)THEN
2743  trip(n-1)=trip(l)
2744  anti(n-1)=0
2745  ELSE
2746  trip(n-1)=0
2747  anti(n-1)=anti(l)
2748  ENDIF
2749  ELSEIF(typ2.EQ.'GQ')THEN
2750  k(n-1,2)=k(l,2)
2751  IF(k(n-1,2).GT.0)THEN
2752  trip(n-1)=colmax+1
2753  anti(n-1)=0
2754  ELSE
2755  trip(n-1)=0
2756  anti(n-1)=colmax+1
2757  ENDIF
2758  colmax=colmax+1
2759  ELSE
2760  k(n-1,2)=21
2761  IF((k(l,2).GT.0).AND.(dir.GE.0))THEN
2762  trip(n-1)=trip(l)
2763  anti(n-1)=colmax+1
2764  ELSE
2765  trip(n-1)=colmax+1
2766  anti(n-1)=anti(l)
2767  ENDIF
2768  colmax=colmax+1
2769  ENDIF
2770  k(n-1,3)=l
2771  k(n-1,4)=0
2772  k(n-1,5)=0
2773  p(n-1,4)=(1.-x)*p(l,4)
2774  p(n-1,5)=sqrt(mc2)
2775 C--take care of second daughter (final quark or gluon or quark from
2776 C gluon splitting)
2777  k(n,1)=k(l,1)
2778  IF(typ2.EQ.'QG')THEN
2779  k(n,2)=typi
2780  IF(k(n,2).GT.0)THEN
2781  trip(n)=trip(l)
2782  anti(n)=0
2783  ELSE
2784  trip(n)=0
2785  anti(n)=anti(l)
2786  ENDIF
2787  ELSEIF(typi.NE.21)THEN
2788  k(n,2)=k(l,2)
2789  IF(k(n,2).GT.0)THEN
2790  trip(n)=anti(n-1)
2791  anti(n)=0
2792  ELSE
2793  trip(n)=0
2794  anti(n)=trip(n-1)
2795  ENDIF
2796  ELSE
2797  k(n,2)=21
2798  IF(k(n-1,2).EQ.21)THEN
2799  IF(dir.EQ.1)THEN
2800  trip(n)=anti(n-1)
2801  anti(n)=anti(l)
2802  ELSE
2803  trip(n)=trip(l)
2804  anti(n)=trip(n-1)
2805  ENDIF
2806  ELSEIF(k(n-1,2).GT.0)THEN
2807  trip(n)=trip(l)
2808  anti(n)=trip(n-1)
2809  ELSE
2810  trip(n)=anti(n-1)
2811  anti(n)=anti(l)
2812  ENDIF
2813  ENDIF
2814  k(n,3)=l
2815  k(n,4)=0
2816  k(n,5)=0
2817  p(n,3)=pz
2818  p(n,4)=x*p(l,4)
2819  IF(mb2.LT.0.d0)THEN
2820  p(n,5)=-sqrt(-mb2)
2821  ELSE
2822  p(n,5)=sqrt(mb2)
2823  ENDIF
2824 C--azimuthal angle
2825  phiq=2*pi*pyr(0)
2826  p(n,1)=sqrt(kt2)*cos(phiq)
2827  p(n,2)=sqrt(kt2)*sin(phiq)
2828 C--gluon momentum
2829  p(n-1,1)=p(l,1)-p(n,1)
2830  p(n-1,2)=p(l,2)-p(n,2)
2831  p(n-1,3)=p(l,3)-p(n,3)
2832  mv(l,5)=time-taurad
2833  mv(n-1,4)=mv(l,5)
2834  IF(p(n-1,5).GT.0.d0)THEN
2835  lambda=1.d0/(ftfac*p(n-1,4)*0.2/p(n-1,5)**2)
2836  mv(n-1,5)=mv(l,5)-log(1.d0-pyr(0))/lambda
2837  ELSE
2838  mv(n-1,5)=0.d0
2839  ENDIF
2840  mv(n,4)=mv(l,5)
2841  IF(p(n,5).GT.0.d0)THEN
2842  mv(n,5)=time
2843  ELSE
2844  mv(n,5)=0.d0
2845  ENDIF
2846  za(n-1)=1.d0
2847  thetaa(n-1)=-1.d0
2848  zd(n-1)=zdec
2849  qqbard(n-1)=qqbardec
2850  za(n)=1.d0
2851  thetaa(n)=-1.d0
2852  zd(n)=0.d0
2853  qqbard(n)=.false.
2854 C--take care of initial quark (or gluon)
2855  IF(k(l,1).EQ.2)THEN
2856  k(l,1)=13
2857  ELSE
2858  k(l,1)=11
2859  ENDIF
2860  k(l,4)=n-1
2861  k(l,5)=n
2862  nsplit=nsplit+evweight
2863  CALL pyrobo(l,l,theta,0d0,0d0,0d0,0d0)
2864  CALL pyrobo(n-1,n,theta,0d0,0d0,0d0,0d0)
2865  CALL pyrobo(l,l,0d0,phi,0d0,0d0,0d0)
2866  CALL pyrobo(n-1,n,0d0,phi,0d0,0d0,0d0)
2867 
2868 C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
2869  mv(n-1,1)=mv(l,1)+(mv(n-1,4)-mv(l,4))*p(l,1)/max(pyp(l,8),p(l,4))
2870  mv(n-1,2)=mv(l,2)+(mv(n-1,4)-mv(l,4))*p(l,2)/max(pyp(l,8),p(l,4))
2871  mv(n-1,3)=mv(l,3)+(mv(n-1,4)-mv(l,4))*p(l,3)/max(pyp(l,8),p(l,4))
2872  mv(n, 1)=mv(l,1)+(mv(n, 4)-mv(l,4))*p(l,1)/max(pyp(l,8),p(l,4))
2873  mv(n, 2)=mv(l,2)+(mv(n, 4)-mv(l,4))*p(l,2)/max(pyp(l,8),p(l,4))
2874  mv(n, 3)=mv(l,3)+(mv(n, 4)-mv(l,4))*p(l,3)/max(pyp(l,8),p(l,4))
2875 
2876  END
2877 
2878 
2879 ***********************************************************************
2880 *** subroutine doinstatescat
2881 ***********************************************************************
2882  SUBROUTINE doinstatescat(L,X,TYPI,Q,TSTART,DELTAT,OVERQ0,
2883  & retrysplit)
2884  IMPLICIT NONE
2885 C--Common block of Pythia
2886  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
2887  INTEGER n,npad,k
2888  DOUBLE PRECISION p,v
2889 C--time common block
2890  common/time/mv(23000,5)
2891  DOUBLE PRECISION mv
2892 C--factor in front of formation times
2893  common/ftimefac/ftfac
2894  DOUBLE PRECISION ftfac
2895 C--Parameter common block
2896  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
2897  &allhad,compress,nf
2898  INTEGER nf
2899  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
2900  LOGICAL angord,scatrecoil,allhad,compress
2901 C--discard event flag
2902  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
2903  LOGICAL discard
2904  INTEGER ndisc,nstrange,ngood,errcount
2905  double precision wdisc
2906 C--variables for coherent scattering
2907  common/coherent/nstart,nend,allqs(10000,6),scatcentres(10000,10),
2908  &qsumvec(4),qsum2
2909  INTEGER nstart,nend
2910  DOUBLE PRECISION allqs,scatcentres,qsumvec,qsum2
2911 C--identifier of file for hepmc output and logfile
2912  common/hepmcid/hpmcfid,logfid
2913  integer hpmcfid,logfid
2914 C--local variables
2915  INTEGER l,typi,counter,countmax,count2
2916  DOUBLE PRECISION x,deltat,deltal,pyr,r,pnorad,getpnorad1,getnoscat,
2917  &weight,low,fmax,getpdf,sigmatot,getsscat,pfchange,pi,tnow,tleft,
2918  &xmax,pqq,pqg,pgq,pgg,alphas,tstart,tsum,q,qold,q2old,getnewmass,
2919  &generatez,tmax,tmaxnew,dt,xsc,ysc,zsc,tsc,ms1,md1,getms,getmd,
2920  &gettemp,getneff,lambda,rtau,phi,tauest,qsumvecold(4),zdum,weight,
2921  &pyp
2922  LOGICAL fchange,norad,overq0,noscat,getdeltat,retrysplit,
2923  &qqbardum
2924  CHARACTER typ
2925  CHARACTER*2 typ2
2926  DATA pi/3.141592653589793d0/
2927  DATA countmax/10000/
2928 
2929  counter=0
2930 
2931  xsc=mv(l,1)+(tstart-mv(l,4))*p(l,1)/p(l,4)
2932  ysc=mv(l,2)+(tstart-mv(l,4))*p(l,2)/p(l,4)
2933  zsc=mv(l,3)+(tstart-mv(l,4))*p(l,3)/p(l,4)
2934  tsc=tstart
2935  md1=getmd(xsc,ysc,zsc,tsc)
2936  ms1=getms(xsc,ysc,zsc,tsc)
2937 
2938  IF(md1.LE.1.d-4.OR.ms1.LE.1.d-4)THEN
2939  write(logfid,*)'problem!',gettemp(xsc,ysc,zsc,tsc),
2940  &getneff(xsc,ysc,zsc,tsc)
2941  ENDIF
2942 
2943 C--check for scattering
2944  noscat=.NOT.getdeltat(l,tstart,deltat,dt)
2945  IF(noscat.AND.(.NOT.retrysplit)) goto 116
2946 
2947 C--decide whether there will be radiation
2948  pnorad=getpnorad1(l,xsc,ysc,zsc,tsc)
2949  IF((pyr(0).LT.pnorad).OR.(p(l,4).LT.1.001*q0))THEN
2950  norad=.true.
2951  ELSE
2952  norad=.false.
2953  ENDIF
2954 
2955 C--decide whether q or g is to be scattered
2956  IF(k(l,2).EQ.21)THEN
2957  typ='G'
2958  typ2='GC'
2959  sigmatot=getsscat(p(l,4),p(l,1),p(l,2),p(l,3),p(l,5),
2960  & q0,'G','C',xsc,ysc,zsc,tsc,0)
2961  IF((sigmatot.EQ.0.d0).OR.(pnorad.EQ.1.d0))THEN
2962  pfchange=0.d0
2963  ELSE
2964  pfchange=getsscat(p(l,4),p(l,1),p(l,2),p(l,3),p(l,5),
2965  & q0,'G','Q',xsc,ysc,zsc,tsc,0)
2966  & /sigmatot
2967  ENDIF
2968  sigmatot=getsscat(p(l,4),p(l,1),p(l,2),p(l,3),p(l,5),
2969  & 0.d0,'G','C',xsc,ysc,zsc,tsc,0)
2970  ELSE
2971  typ='Q'
2972  typ2='QQ'
2973  sigmatot=getsscat(p(l,4),p(l,1),p(l,2),p(l,3),p(l,5),
2974  & q0,'Q','C',xsc,ysc,zsc,tsc,0)
2975  IF((sigmatot.EQ.0.d0).OR.(pnorad.EQ.1.d0))THEN
2976  pfchange=0.d0
2977  ELSE
2978  pfchange=getsscat(p(l,4),p(l,1),p(l,2),p(l,3),p(l,5),
2979  & q0,'Q','G',xsc,ysc,zsc,tsc,0)
2980  & /sigmatot
2981  ENDIF
2982  sigmatot=getsscat(p(l,4),p(l,1),p(l,2),p(l,3),p(l,5),
2983  & 0.d0,'Q','C',xsc,ysc,zsc,tsc,0)
2984  ENDIF
2985  IF((pfchange.LT.-1.d-4).OR.(pfchange.GT.1.d0+1.d-4)) THEN
2986  write(logfid,*)'error: flavour change probability=',
2987  & pfchange,'for ',typ
2988  ENDIF
2989  IF(pyr(0).LT.pfchange)THEN
2990  fchange=.true.
2991  ELSE
2992  fchange=.false.
2993  ENDIF
2994  IF (norad) fchange=.false.
2995 C--set TYPI
2996  IF(typ.EQ.'G')THEN
2997  IF(fchange)THEN
2998  typi=int(sign(2.d0,pyr(0)-0.5))
2999  ELSE
3000  typi=k(l,2)
3001  ENDIF
3002  ELSE
3003  IF(fchange)THEN
3004  typi=21
3005  ELSE
3006  typi=k(l,2)
3007  ENDIF
3008  ENDIF
3009  low=q0**2/scalefacm**2
3010  tmax=4.*(p(l,4)**2-p(l,5)**2)
3011  xmax=1.-q0**2/(scalefacm**2*4.*tmax)
3012 
3013  IF(sigmatot.EQ.0.d0) goto 116
3014 
3015  rtau=pyr(0)
3016 
3017 C--generate a trial emission
3018 C--pick a x value from splitting function
3019  112 counter=counter+1
3020  IF(typ.EQ.'G')THEN
3021  IF(fchange)THEN
3022  x=generatez(0.d0,0.d0,1.-xmax,'QG')
3023  ELSE
3024  x=generatez(0.d0,0.d0,1.-xmax,'GG')
3025  ENDIF
3026  ELSE
3027  IF(fchange)THEN
3028  x=1.-generatez(0.d0,0.d0,1.-xmax,'QQ')
3029  ELSE
3030  x=generatez(0.d0,0.d0,1.-xmax,'QQ')
3031  ENDIF
3032  ENDIF
3033  IF(norad) x=1.d0
3034 C--initialisation
3035  tmaxnew=(x*p(l,4))**2
3036  phi=0.d0
3037  tleft=deltat
3038  tnow=tstart
3039  qsumvec(1)=0.d0
3040  qsumvec(2)=0.d0
3041  qsumvec(3)=0.d0
3042  qsumvec(4)=0.d0
3043  qsum2=-1.d-10
3044  overq0=.false.
3045  q=p(l,5)
3046  qold=p(l,5)
3047  tauest=deltat
3048 C--generate first momentum transfer
3049  deltal=dt
3050  nstart=1
3051  nend=1
3052  tnow=tnow+deltal
3053  tsum=deltal
3054  tleft=tleft-deltal
3055  allqs(nend,6)=tnow
3056  q2old=qsum2
3057 C--get new momentum transfer
3058  count2=0
3059  118 CALL getqvec(l,nend,tnow-mv(l,4),x)
3060  IF(-qsum2.GT.p(l,4)**2)THEN
3061  qsumvec(1)=0.d0
3062  qsumvec(2)=0.d0
3063  qsumvec(3)=0.d0
3064  qsumvec(4)=0.d0
3065  qsum2=q2old
3066  IF(count2.LT.100)THEN
3067  count2=count2+1
3068  goto 118
3069  ELSE
3070  allqs(nend,1)=0.d0
3071  allqs(nend,2)=0.d0
3072  allqs(nend,3)=0.d0
3073  allqs(nend,4)=0.d0
3074  allqs(nend,5)=0.d0
3075  ENDIF
3076  ENDIF
3077 C--update OVERQ0
3078  IF(-allqs(nend,1).GT.low) overq0=.true.
3079 C--get new virtuality
3080  IF(overq0.AND.(.NOT.norad))THEN
3081  q=getnewmass(l,scalefacm**2*qsum2,scalefacm**2*q2old,0.d0,
3082  & .true.,x,zdum,qqbardum)
3083  ELSE
3084  q=0.d0
3085  ENDIF
3086 
3087 C--estimate formation time
3088  111 IF((q.EQ.0.d0).OR.(q.EQ.p(l,5)))THEN
3089  tauest=deltat
3090  ELSE
3091  tauest=ftfac*(1.-phi)*0.2*x*p(l,4)/q**2
3092  ENDIF
3093  lambda=1.d0/tauest
3094  tauest=-log(1.d0-rtau)/lambda
3095 
3096 C--find number, position and momentum transfers of further scatterings
3097  noscat=.NOT.getdeltat(l,tnow,min(tleft,tauest),deltal)
3098  IF((.NOT.noscat).AND.(.NOT.norad))THEN
3099 C--add a momentum transfer
3100  nend=nend+1
3101  IF(nend.GE.100)THEN
3102  nend=nend-1
3103  goto 114
3104  ENDIF
3105  tnow=tnow+deltal
3106  tsum=tsum+deltal
3107  tleft=tleft-deltal
3108 C--update phase
3109  IF((q.NE.0.d0).AND.(q.NE.p(l,5)))THEN
3110  phi=phi+5.*deltal*q**2/(1.*x*p(l,4))
3111  ENDIF
3112 C--get new momentum transfer
3113  allqs(nend,6)=tnow
3114  q2old=qsum2
3115  qsumvecold(1)=qsumvec(1)
3116  qsumvecold(2)=qsumvec(2)
3117  qsumvecold(3)=qsumvec(3)
3118  qsumvecold(4)=qsumvec(4)
3119  count2=0
3120  119 CALL getqvec(l,nend,tnow-mv(l,4),x)
3121  IF(-qsum2.GT.p(l,4)**2)THEN
3122  qsumvec(1)=qsumvecold(1)
3123  qsumvec(2)=qsumvecold(2)
3124  qsumvec(3)=qsumvecold(3)
3125  qsumvec(4)=qsumvecold(4)
3126  qsum2=q2old
3127  IF(count2.LT.100)THEN
3128  count2=count2+1
3129  goto 119
3130  ELSE
3131  allqs(nend,1)=0.d0
3132  allqs(nend,2)=0.d0
3133  allqs(nend,3)=0.d0
3134  allqs(nend,4)=0.d0
3135  allqs(nend,5)=0.d0
3136  ENDIF
3137  ENDIF
3138 C--update OVERQ0
3139  IF((-qsum2.GT.low)
3140  & .OR.(-allqs(nend,1).GT.low)) overq0=.true.
3141 C--get new virtuality
3142  qold=q
3143  IF(overq0.AND.(.NOT.norad))THEN
3144  q=getnewmass(l,scalefacm**2*qsum2,scalefacm**2*q2old,0.d0,
3145  & .true.,x,zdum,qqbardum)
3146  ELSE
3147  q=0.d0
3148  ENDIF
3149  goto 111
3150  ENDIF
3151 
3152 C--do reweighting
3153  114 tmaxnew=x**2*p(l,4)**2
3154  IF(norad)THEN
3155  weight=1.d0
3156  q=0.d0
3157  x=1.d0
3158  ELSEIF((-qsum2.LT.low).OR.(q.EQ.0.d0))THEN
3159  weight=0.d0
3160  ELSEIF(-qsum2.GT.p(l,4)**2)THEN
3161  weight=0.d0
3162  ELSE
3163  IF(typ.EQ.'G')THEN
3164  fmax=2.*log(-scalefacm**2*qsum2/q0**2)
3165  & *alphas(q0**2/4.,lps)/(2.*pi)
3166  IF(qsum2.EQ.0.d0)THEN
3167  weight=0.d0
3168  norad=.true.
3169  ELSE
3170  IF(fchange)THEN
3171  weight=2.*getpdf(x,scalefacm*sqrt(-qsum2),'QG')/(pqg(x)*fmax)
3172  IF((weight.GT.1.d0+1.d-4).OR.(weight.LT.-1.d-4))THEN
3173  write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',x,
3174  & sqrt(-qsum2),getpdf(x,scalefacm*sqrt(-qsum2),'QG'),'qg',
3175  & fmax
3176  ENDIF
3177  ELSE
3178  weight=getpdf(x,scalefacm*sqrt(-qsum2),'GG')/(pgg(x)*fmax)
3179  IF((weight.GT.1.d0+1.d-4).OR.(weight.LT.-1.d-4))THEN
3180  write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',x,
3181  & sqrt(-qsum2),getpdf(x,scalefacm*sqrt(-qsum2),'GG'),'gg',
3182  & fmax
3183  ENDIF
3184  ENDIF
3185  ENDIF
3186  ELSE
3187  fmax=log(-scalefacm**2*qsum2/q0**2)
3188  & *alphas(q0**2/4.,lps)/(2.*pi)
3189  IF(qsum2.EQ.0.d0)THEN
3190  weight=0.d0
3191  norad=.true.
3192  ELSE
3193  IF(fchange)THEN
3194  weight=getpdf(x,scalefacm*sqrt(-qsum2),'GQ')/(pgq(x)*fmax)
3195  IF((weight.GT.1.d0+1.d-4).OR.(weight.LT.-1.d-4))THEN
3196  write(logfid,*)'x,sqrt(qsum^2),getpdf:,fmax',x,
3197  & sqrt(-qsum2),getpdf(x,scalefacm*sqrt(-qsum2),'GQ'),'gq',
3198  & fmax
3199  ENDIF
3200  ELSE
3201  weight=getpdf(x,scalefacm*sqrt(-qsum2),'QQ')/(pqq(x)*fmax)
3202  IF((weight.GT.1.d0+1.d-4).OR.(weight.LT.-1.d-4))THEN
3203  write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',x,
3204  & sqrt(-qsum2),getpdf(x,scalefacm*sqrt(-qsum2),'QQ'),'qq',
3205  & fmax
3206  ENDIF
3207  ENDIF
3208  ENDIF
3209  ENDIF
3210  ENDIF
3211  IF((weight.GT.1.d0+1.d-4).OR.(weight.LT.-1.d-4))
3212  & write(logfid,*)'error: weight=',weight
3213  115 IF(pyr(0).GT.weight)THEN
3214  IF(counter.LT.countmax)THEN
3215  goto 112
3216  ELSE
3217  q=0.d0
3218  x=1.d0
3219  nend=nstart
3220  qsum2=allqs(nend,1)
3221  qsumvec(1)=allqs(nend,2)
3222  qsumvec(2)=allqs(nend,3)
3223  qsumvec(3)=allqs(nend,4)
3224  qsumvec(4)=allqs(nend,5)
3225  typi=k(l,2)
3226  IF(-allqs(nend,1).GT.low)THEN
3227  overq0=.true.
3228  ELSE
3229  overq0=.false.
3230  ENDIF
3231  deltat=allqs(nend,6)-tstart
3232  tnow=allqs(1,6)
3233  RETURN
3234  ENDIF
3235  ENDIF
3236 C--found meaningful configuration, now do final checks
3237 C--check if phase is unity and weight with 1/Nscat
3238  IF(((tleft.LT.tauest).OR.(pyr(0).GT.1.d0/(nend*1.d0)))
3239  & .AND.(.NOT.norad))THEN
3240  q=0.d0
3241  x=1.d0
3242  nend=nstart
3243  qsum2=allqs(nend,1)
3244  qsumvec(1)=allqs(nend,2)
3245  qsumvec(2)=allqs(nend,3)
3246  qsumvec(3)=allqs(nend,4)
3247  qsumvec(4)=allqs(nend,5)
3248  typi=k(l,2)
3249  IF(-allqs(nend,1).GT.low)THEN
3250  overq0=.true.
3251  ELSE
3252  overq0=.false.
3253  ENDIF
3254  deltat=allqs(nend,6)-tstart
3255  tnow=allqs(1,6)
3256  ELSE
3257  IF(.NOT.norad)THEN
3258  tleft=tleft-tauest
3259  tnow=tnow+tauest
3260  tsum=tsum+tauest
3261  ENDIF
3262  deltat=tsum
3263  ENDIF
3264  RETURN
3265 C--exit in case of failure
3266  116 q=0.d0
3267  x=1.d0
3268  nstart=0
3269  nend=0
3270  qsumvec(1)=0.d0
3271  qsumvec(2)=0.d0
3272  qsumvec(3)=0.d0
3273  qsumvec(4)=0.d0
3274  qsum2=0.d0
3275  overq0=.false.
3276  typi=k(l,2)
3277  RETURN
3278  END
3279 
3280 
3281 ***********************************************************************
3282 *** subroutine dofistatescat
3283 ***********************************************************************
3284  SUBROUTINE dofistatescat(L,TNOW,DTLEFT,DELTAT,NEWMASS,
3285  & overq0,z,qqbar)
3286  IMPLICIT NONE
3287 C--identifier of file for hepmc output and logfile
3288  common/hepmcid/hpmcfid,logfid
3289  integer hpmcfid,logfid
3290 C--Common block of Pythia
3291  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
3292  INTEGER n,npad,k
3293  DOUBLE PRECISION p,v
3294 C--time common block
3295  common/time/mv(23000,5)
3296  DOUBLE PRECISION mv
3297 C--factor in front of formation times
3298  common/ftimefac/ftfac
3299  DOUBLE PRECISION ftfac
3300 C--Parameter common block
3301  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
3302  &allhad,compress,nf
3303  INTEGER nf
3304  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
3305  LOGICAL angord,scatrecoil,allhad,compress
3306 C--discard event flag
3307  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
3308  LOGICAL discard
3309  INTEGER ndisc,nstrange,ngood,errcount
3310  double precision wdisc
3311 C--variables for coherent scattering
3312  common/coherent/nstart,nend,allqs(10000,6),scatcentres(10000,10),
3313  &qsumvec(4),qsum2
3314  INTEGER nstart,nend
3315  DOUBLE PRECISION allqs,scatcentres,qsumvec,qsum2
3316 C--local variables
3317  INTEGER l,counter,countmax,count2
3318  DOUBLE PRECISION tnow,deltat,newmass,tleft,deltal,q2old,
3319  &getnewmass,pyr,tsum,qsumvecold(4),rtau,lambda,dtleft,phi,
3320  &tauest,low,z,pyp
3321  LOGICAL overq0,noscat,getdeltat,qqbar
3322  CHARACTER typ
3323  DATA countmax/100/
3324  deltal=0.d0
3325 
3326  IF(-qsum2.GT.p(l,4)**2)
3327  & write(logfid,*) 'DOFISTATESCAT has a problem:',-qsum2,p(l,4)**2
3328 
3329  IF(k(l,2).EQ.21)THEN
3330  typ='G'
3331  ELSE
3332  typ='Q'
3333  ENDIF
3334  low=q0**2/scalefacm**2
3335 
3336  tsum=0.d0
3337  phi=0.d0
3338  deltat=0.d0
3339 
3340 C--check for radiation with first (given) momentum transfer
3341  q2old=0.d0
3342  IF(overq0.OR.(-qsum2.GT.low))THEN
3343  newmass=getnewmass(l,scalefacm**2*qsum2,scalefacm**2*q2old,
3344  & newmass,.false.,1.d0,z,qqbar)
3345  overq0=.true.
3346  ELSE
3347  newmass=p(l,5)
3348  ENDIF
3349 
3350  rtau=pyr(0)
3351 
3352  tleft=dtleft
3353  222 IF((newmass.EQ.0.d0).OR.(newmass.EQ.p(l,5)))THEN
3354  tauest=tleft
3355  ELSE
3356  tauest=ftfac*(1.-phi)*0.2*p(l,4)/newmass**2
3357  ENDIF
3358  lambda=1.d0/tauest
3359  tauest=-log(1.d0-rtau)/lambda
3360  noscat=.NOT.getdeltat(l,tnow+tsum,min(tauest,tleft),deltal)
3361  IF(.NOT.noscat)THEN
3362 C--do scattering
3363  nend=nend+1
3364  IF(nend.gt.countmax)THEN
3365  nend=nend-1
3366  goto 218
3367  ENDIF
3368  IF(nstart.EQ.0) nstart=1
3369  tsum=tsum+deltal
3370  tleft=tleft-deltal
3371  IF((newmass.NE.0.d0).AND.(newmass.NE.p(l,5)))THEN
3372  phi=phi+5.*deltal*newmass**2/(1.*p(l,4))
3373  ENDIF
3374  allqs(nend,6)=tnow+tsum
3375  qsumvecold(1)=qsumvec(1)
3376  qsumvecold(2)=qsumvec(2)
3377  qsumvecold(3)=qsumvec(3)
3378  qsumvecold(4)=qsumvec(4)
3379  q2old=qsum2
3380 C--get new momentum transfer
3381  count2=0
3382  219 CALL getqvec(l,nend,tnow+tsum-mv(l,4),1.d0)
3383  IF(-qsum2.GT.p(l,4)**2)THEN
3384  qsumvec(1)=qsumvecold(1)
3385  qsumvec(2)=qsumvecold(2)
3386  qsumvec(3)=qsumvecold(3)
3387  qsumvec(4)=qsumvecold(4)
3388  qsum2=q2old
3389  IF(count2.LT.100)THEN
3390  count2=count2+1
3391  goto 219
3392  ELSE
3393  allqs(nend,1)=0.d0
3394  allqs(nend,2)=0.d0
3395  allqs(nend,3)=0.d0
3396  allqs(nend,4)=0.d0
3397  allqs(nend,5)=0.d0
3398  ENDIF
3399  ENDIF
3400 C--figure out new virtuality
3401  IF(overq0.OR.(-qsum2.GT.low))THEN
3402  newmass=getnewmass(l,scalefacm**2*qsum2,scalefacm**2*q2old,
3403  & newmass,.false.,1.d0,z,qqbar)
3404  overq0=.true.
3405  ENDIF
3406  goto 222
3407  ENDIF
3408 C--no more scattering
3409  218 if ((newmass**2.gt.low).and.(newmass.ne.p(l,5))) then
3410  if ((tleft.LT.tauest).OR.(pyr(0).GT.1.d0/(nend*1.d0))) then
3411  if (nend.eq.countmax) then
3412  deltat=tsum
3413  else if (tleft.LT.tauest) then
3414  deltat=tsum+tleft
3415  else
3416  deltat=tsum+tauest
3417  endif
3418  newmass=p(l,5)
3419  ELSE
3420  deltat=tsum+tauest
3421  ENDIF
3422  else
3423  deltat=0.d0
3424  nstart=1
3425  nend=1
3426  qsum2=allqs(nend,1)
3427  qsumvec(1)=allqs(nend,2)
3428  qsumvec(2)=allqs(nend,3)
3429  qsumvec(3)=allqs(nend,4)
3430  qsumvec(4)=allqs(nend,5)
3431  IF(-allqs(nend,1).GT.low)THEN
3432  overq0=.true.
3433  ELSE
3434  overq0=.false.
3435  ENDIF
3436  newmass=p(l,5)
3437  endif
3438  return
3439  END
3440 
3441 
3442 ***********************************************************************
3443 *** function getnewmass
3444 ***********************************************************************
3445  DOUBLE PRECISION FUNCTION getnewmass(L,Q2,QOLD2,MASS,IN,X,
3446  & zdec,qqbardec)
3447  IMPLICIT NONE
3448 C--Common block of Pythia
3449  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
3450  INTEGER n,npad,k
3451  DOUBLE PRECISION p,v
3452 C--time common block
3453  common/time/mv(23000,5)
3454  DOUBLE PRECISION mv
3455 C--variables for angular ordering
3456  common/angor/za(23000),zd(23000),thetaa(23000),qqbard(23000)
3457  DOUBLE PRECISION za,zd,thetaa
3458  LOGICAL qqbard
3459 C--Parameter common block
3460  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
3461  &allhad,compress,nf
3462  INTEGER nf
3463  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
3464  LOGICAL angord,scatrecoil,allhad,compress
3465 C--local variables
3466  INTEGER l
3467  DOUBLE PRECISION q2,qold2,r,pyr,pnosplit1,pnosplit2,z,qa,
3468  &getsudakov,getmass,pkeep,x,mass,zdec,qtmp,zold
3469  LOGICAL in,qqbardec,qqbarold
3470  CHARACTER*2 typ
3471 
3472  IF(x*p(l,4).LT.q0)THEN
3473  getnewmass=0.d0
3474  zdec=0.d0
3475  qqbardec=.false.
3476  RETURN
3477  ENDIF
3478  IF (-q2.LT.q0**2)THEN
3479  getnewmass=0.d0
3480  RETURN
3481  ENDIF
3482  IF(k(l,2).EQ.21)THEN
3483  typ='GC'
3484  ELSE
3485  typ='QQ'
3486  ENDIF
3487  IF(sqrt(-qold2).LE.q0)THEN
3488  IF(in)THEN
3489  getnewmass=getmass(0.d0,sqrt(-q2),-1.d0,
3490  & x*p(l,4),typ,x*p(l,4),in,zdec,qqbardec)
3491  ELSE
3492  getnewmass=getmass(0.d0,sqrt(-q2),-1.d0,p(l,4),typ,
3493  & sqrt(-q2),in,zdec,qqbardec)
3494  ENDIF
3495  getnewmass=min(getnewmass,x*p(l,4))
3496  RETURN
3497  ENDIF
3498  z=1.d0
3499  qa=1.d0
3500  IF(max(p(l,5),mass).GT.0.d0)THEN
3501  IF(-q2.GT.-qold2)THEN
3502  zold=zdec
3503  qqbarold=qqbardec
3504  qtmp=getmass(0.d0,sqrt(-q2),-1.d0,x*p(l,4),typ,
3505  & sqrt(-q2),in,zdec,qqbardec)
3506  IF(qtmp.LT.sqrt(-qold2))THEN
3507  getnewmass=mass
3508  zdec=zold
3509  qqbardec=qqbarold
3510  ELSE
3511  getnewmass=qtmp
3512  ENDIF
3513  ELSE
3514  pnosplit1=getsudakov(sqrt(-qold2),qa,q0,z,x*p(l,4),
3515  & typ,mv(l,4),in)
3516  pnosplit2=getsudakov(sqrt(-q2),qa,q0,z,x*p(l,4),
3517  & typ,mv(l,4),in)
3518  pkeep=(1.-pnosplit2)/(1.-pnosplit1)
3519  IF(pyr(0).LT.pkeep)THEN
3520  IF(p(l,5).LT.sqrt(-q2))THEN
3521  getnewmass=mass
3522  ELSE
3523  55 getnewmass=getmass(q0,sqrt(-q2),-1.d0,x*p(l,4),typ,
3524  & sqrt(-q2),in,zdec,qqbardec)
3525  IF((getnewmass.EQ.0.d0).AND.(x*p(l,4).GT.q0)) goto 55
3526  ENDIF
3527  ELSE
3528  getnewmass=0.d0
3529  zdec=0.d0
3530  qqbardec=.false.
3531  ENDIF
3532  ENDIF
3533  ELSE
3534  IF(-q2.GT.-qold2)THEN
3535  getnewmass=getmass(0.d0,sqrt(-q2),-1.d0,
3536  & x*p(l,4),typ,x*p(l,4),in,zdec,qqbardec)
3537  if(getnewmass.lt.sqrt(-qold2))then
3538  getnewmass=0.d0
3539  zdec=0.d0
3540  qqbardec=.false.
3541  endif
3542  ELSE
3543  getnewmass=0.d0
3544  zdec=0.d0
3545  qqbardec=.false.
3546  ENDIF
3547  ENDIF
3548  getnewmass=min(getnewmass,x*p(l,4))
3549  END
3550 
3551 
3552 ***********************************************************************
3553 *** function getpnorad1
3554 ***********************************************************************
3555  DOUBLE PRECISION FUNCTION getpnorad1(LINE,x,y,z,t)
3556  IMPLICIT NONE
3557 C--identifier of file for hepmc output and logfile
3558  common/hepmcid/hpmcfid,logfid
3559  integer hpmcfid,logfid
3560 C--Common block of Pythia
3561  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
3562  INTEGER n,npad,k
3563  DOUBLE PRECISION p,v
3564 C--Parameter common block
3565  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
3566  &allhad,compress,nf
3567  INTEGER nf
3568  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
3569  LOGICAL angord,scatrecoil,allhad,compress
3570 C--local variables
3571  INTEGER line
3572  DOUBLE PRECISION up,low,ccol,sigmatot,getsscat,getxsecint,
3573  &scatprimfunc,ms1,md1,shat,pcms2,avmom(5),x,y,z,t,getmd
3574 
3575  md1 = getmd(x,y,z,t)
3576  call avscatcen(x,y,z,t,
3577  &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
3578  ms1 = avmom(5)
3579  shat = avmom(5)**2 + p(line,5)**2 + 2.*(avmom(4)*p(line,4)
3580  & -avmom(1)*p(line,1)-avmom(2)*p(line,2)-avmom(3)*p(line,3))
3581  pcms2 = (shat+p(line,5)**2-ms1**2)**2/(4.*shat)-p(line,5)**2
3582  up = 4.*pcms2
3583  low=q0**2/scalefacm**2
3584  IF((up.LE.low).OR.(p(line,4).LT.q0/scalefacm))THEN
3585  getpnorad1=1.d0
3586  RETURN
3587  ENDIF
3588  IF(k(line,2).EQ.21)THEN
3589  ccol=3./2.
3590 C--probability for no initial state radiation
3591  sigmatot=getsscat(p(line,4),p(line,1),p(line,2),p(line,3),
3592  & p(line,5),0.d0,'G','C',x,y,z,t,0)
3593  IF(sigmatot.EQ.0.d0)THEN
3594  getpnorad1=-1.d0
3595  RETURN
3596  ENDIF
3597  getpnorad1=(ccol*(scatprimfunc(low,md1)-
3598  &scatprimfunc(0.d0,md1))
3599  & + getxsecint(up,md1,'GB'))/sigmatot
3600  ELSE
3601  ccol=2./3.
3602 C--probability for no initial state radiation
3603  sigmatot=getsscat(p(line,4),p(line,1),p(line,2),p(line,3),
3604  & p(line,5),0.d0,'Q','C',x,y,z,t,0)
3605  IF(sigmatot.EQ.0.d0)THEN
3606  getpnorad1=1.d0
3607  RETURN
3608  ENDIF
3609  getpnorad1=(ccol*(scatprimfunc(low,md1)-
3610  &scatprimfunc(0.d0,md1))
3611  & + getxsecint(up,md1,'QB'))/sigmatot
3612  ENDIF
3613  IF((getpnorad1.LT.-1.d-4).OR.(getpnorad1.GT.1.d0+1.d-4))THEN
3614  write(logfid,*)'error: P_norad=',getpnorad1,
3615  & p(line,4),p(line,5),low,up,k(line,2),md1
3616  ENDIF
3617  END
3618 
3619 
3620 ***********************************************************************
3621 *** subroutine getqvec
3622 ***********************************************************************
3623  SUBROUTINE getqvec(L,J,DT,X)
3624  IMPLICIT NONE
3625 C--identifier of file for hepmc output and logfile
3626  common/hepmcid/hpmcfid,logfid
3627  integer hpmcfid,logfid
3628 C--Common block of Pythia
3629  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
3630  INTEGER n,npad,k
3631  DOUBLE PRECISION p,v
3632 C--time common block
3633  common/time/mv(23000,5)
3634  DOUBLE PRECISION mv
3635 C--variables for coherent scattering
3636  common/coherent/nstart,nend,allqs(10000,6),scatcentres(10000,10),
3637  &qsumvec(4),qsum2
3638  INTEGER nstart,nend
3639  DOUBLE PRECISION allqs,scatcentres,qsumvec,qsum2
3640 C--discard event flag
3641  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
3642  LOGICAL discard
3643  INTEGER ndisc,nstrange,ngood,errcount
3644  double precision wdisc
3645 C--Parameter common block
3646  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
3647  &allhad,compress,nf
3648  INTEGER nf
3649  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
3650  LOGICAL angord,scatrecoil,allhad,compress
3651 C--local variables
3652  INTEGER l,j,counter,countmax,count2,i
3653  DOUBLE PRECISION xsc,ysc,zsc,tsc,getmd,gettemp,dt,x,pyr,newmom(4),
3654  &t,pt,maxt,phi2,beta(3),phi,theta,gett,pyp,pi,pt2,getms,
3655  &savemom(5),theta2,mb2,pz,kt2,phiq,maxt2,xi,md,shat,pcms2,
3656  &avmom(5)
3657  CHARACTER typs
3658  DATA pi/3.141592653589793d0/
3659  DATA countmax/1000/
3660 
3661  IF (j.GT.10000)THEN
3662  discard = .true.
3663  return
3664  ENDIF
3665 
3666  counter=0
3667  count2=0
3668 
3669  xsc=mv(l,1)+dt*p(l,1)/p(l,4)
3670  ysc=mv(l,2)+dt*p(l,2)/p(l,4)
3671  zsc=mv(l,3)+dt*p(l,3)/p(l,4)
3672  tsc=mv(l,4)+dt
3673  md = getmd(xsc,ysc,zsc,tsc)
3674 
3675  call avscatcen(xsc,ysc,zsc,tsc,
3676  &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
3677 
3678  do 210 i=1,5
3679  savemom(i) = p(l,i)
3680  210 continue
3681 
3682  xi = sqrt(max(x**2*p(l,4)**2,p(l,5)**2) - p(l,5)**2)/pyp(l,8)
3683  p(l,1) = xi*p(l,1)
3684  p(l,2) = xi*p(l,2)
3685  p(l,3) = xi*p(l,3)
3686  p(l,4) = max(x*p(l,4),p(l,5))
3687 
3688 
3689  444 CALL getscatterer(xsc,ysc,zsc,tsc,
3690  &k(1,2),p(1,1),p(1,2),p(1,3),p(1,4),p(1,5))
3691  mv(1,1)=xsc
3692  mv(1,2)=ysc
3693  mv(1,3)=zsc
3694  mv(1,4)=tsc
3695  typs='Q'
3696  IF(k(1,2).EQ.21)typs='G'
3697 
3698  shat = avmom(5)**2 + savemom(5)**2 + 2.*(avmom(4)*savemom(4)
3699  & -avmom(1)*savemom(1)-avmom(2)*savemom(2)-avmom(3)*savemom(3))
3700  pcms2 = (shat+savemom(5)**2-avmom(5)**2)**2/(4.*shat)
3701  & -savemom(5)**2
3702  maxt = 4.*pcms2
3703 
3704  k(1,1)=13
3705  scatcentres(j,1)=k(1,2)
3706  scatcentres(j,2)=p(1,1)
3707  scatcentres(j,3)=p(1,2)
3708  scatcentres(j,4)=p(1,3)
3709  scatcentres(j,5)=p(1,4)
3710  scatcentres(j,6)=p(1,5)
3711  scatcentres(j,7)=mv(1,1)
3712  scatcentres(j,8)=mv(1,2)
3713  scatcentres(j,9)=mv(1,3)
3714  scatcentres(j,10)=mv(1,4)
3715 C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction
3716  beta(1)=p(1,1)/p(1,4)
3717  beta(2)=p(1,2)/p(1,4)
3718  beta(3)=p(1,3)/p(1,4)
3719  CALL pyrobo(l,l,0d0,0d0,-beta(1),-beta(2),-beta(3))
3720  CALL pyrobo(1,1,0d0,0d0,-beta(1),-beta(2),-beta(3))
3721  theta=pyp(l,13)
3722  phi=pyp(l,15)
3723  CALL pyrobo(l,l,0d0,-phi,0d0,0d0,0d0)
3724  CALL pyrobo(1,1,0d0,-phi,0d0,0d0,0d0)
3725  CALL pyrobo(l,l,-theta,0d0,0d0,0d0,0d0)
3726  CALL pyrobo(1,1,-theta,0d0,0d0,0d0,0d0)
3727 C--pick a t from differential scattering cross section
3728  204 t=-gett(0.d0,maxt,md)
3729  202 newmom(4)=p(l,4)+t/(2.*p(1,5))
3730  newmom(3)=(t-2.*p(l,5)**2+2.*p(l,4)*newmom(4))/(2.*p(l,3))
3731  pt2=newmom(4)**2-newmom(3)**2-p(l,5)**2
3732  IF(dabs(pt2).LT.1.d-10) pt2=0.d0
3733  IF(t.EQ.0.d0) pt2=0.d0
3734  IF(pt2.LT.0.d0)THEN
3735  t=0.d0
3736  goto 202
3737  ENDIF
3738  pt=sqrt(pt2)
3739  phi2=pyr(0)*2*pi
3740  newmom(1)=pt*cos(phi2)
3741  newmom(2)=pt*sin(phi2)
3742  p(1,1)=newmom(1)-p(l,1)
3743  p(1,2)=newmom(2)-p(l,2)
3744  p(1,3)=newmom(3)-p(l,3)
3745  p(1,4)=newmom(4)-p(l,4)
3746  p(1,5)=0.d0
3747 C--transformation to lab
3748  CALL pyrobo(l,l,theta,0d0,0d0,0d0,0d0)
3749  CALL pyrobo(1,1,theta,0d0,0d0,0d0,0d0)
3750  CALL pyrobo(l,l,0d0,phi,0d0,0d0,0d0)
3751  CALL pyrobo(1,1,0d0,phi,0d0,0d0,0d0)
3752  CALL pyrobo(l,l,0d0,0d0,beta(1),beta(2),beta(3))
3753  CALL pyrobo(1,1,0d0,0d0,beta(1),beta(2),beta(3))
3754  allqs(j,1)=t
3755  allqs(j,2)=p(1,1)
3756  allqs(j,3)=p(1,2)
3757  allqs(j,4)=p(1,3)
3758  allqs(j,5)=p(1,4)
3759  qsumvec(1)=qsumvec(1)+allqs(nend,2)
3760  qsumvec(2)=qsumvec(2)+allqs(nend,3)
3761  qsumvec(3)=qsumvec(3)+allqs(nend,4)
3762  qsumvec(4)=qsumvec(4)+allqs(nend,5)
3763  qsum2=qsumvec(4)**2-qsumvec(1)**2-qsumvec(2)**2-qsumvec(3)**2
3764  IF(qsum2.GT.0.d0)THEN
3765  qsumvec(1)=qsumvec(1)-allqs(nend,2)
3766  qsumvec(2)=qsumvec(2)-allqs(nend,3)
3767  qsumvec(3)=qsumvec(3)-allqs(nend,4)
3768  qsumvec(4)=qsumvec(4)-allqs(nend,5)
3769  qsum2=qsumvec(4)**2-qsumvec(1)**2-qsumvec(2)**2-qsumvec(3)**2
3770  IF(counter.GT.countmax)THEN
3771  write(logfid,*)'GETQVEC unable to find q vector'
3772  allqs(j,1)=0.d0
3773  allqs(j,2)=0.d0
3774  allqs(j,3)=0.d0
3775  allqs(j,4)=0.d0
3776  allqs(j,5)=0.d0
3777  ELSE
3778  counter=counter+1
3779  goto 444
3780  ENDIF
3781  ENDIF
3782  do 211 i=1,5
3783  p(l,i) = savemom(i)
3784  211 continue
3785  END
3786 
3787 ***********************************************************************
3788 *** subroutine dokinematics
3789 ***********************************************************************
3790  SUBROUTINE dokinematics(L,lold,N1,N2,NEWM,RETRYSPLIT,
3791  & time,x,z,qqbar)
3792  IMPLICIT NONE
3793 C--identifier of file for hepmc output and logfile
3794  common/hepmcid/hpmcfid,logfid
3795  integer hpmcfid,logfid
3796 C--Common block of Pythia
3797  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
3798  INTEGER n,npad,k
3799  DOUBLE PRECISION p,v
3800 C--time common block
3801  common/time/mv(23000,5)
3802  DOUBLE PRECISION mv
3803 C--factor in front of formation times
3804  common/ftimefac/ftfac
3805  DOUBLE PRECISION ftfac
3806 C--colour index common block
3807  common/colour/trip(23000),anti(23000),colmax
3808  INTEGER trip,anti,colmax
3809 C--Parameter common block
3810  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
3811  &allhad,compress,nf
3812  INTEGER nf
3813  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
3814  LOGICAL angord,scatrecoil,allhad,compress
3815 C--discard event flag
3816  common/disc/ndisc,nstrange,ngood,errcount,wdisc,discard
3817  LOGICAL discard
3818  INTEGER ndisc,nstrange,ngood,errcount
3819  double precision wdisc
3820 C--variables for angular ordering
3821  common/angor/za(23000),zd(23000),thetaa(23000),qqbard(23000)
3822  DOUBLE PRECISION za,zd,thetaa
3823  LOGICAL qqbard
3824 C--variables for coherent scattering
3825  common/coherent/nstart,nend,allqs(10000,6),scatcentres(10000,10),
3826  &qsumvec(4),qsum2
3827  INTEGER nstart,nend
3828  DOUBLE PRECISION allqs,scatcentres,qsumvec,qsum2
3829 C--number of scattering events
3830  common/check/nscat,nscateff,nsplit
3831  DOUBLE PRECISION nscat,nscateff,nsplit
3832 C--event weight
3833  common/weight/evweight,sumofweights
3834  double precision evweight,sumofweights
3835 C--extra storage for scattering centres before interactions
3836  common/storescatcen/nscatcen,maxnscatcen,scatflav(10000),
3837  &scatcen(10000,5),writescatcen,writedummies
3838  integer nscatcen,maxnscatcen,scatflav
3839  double precision scatcen
3840  logical writescatcen,writedummies
3841 C--local variables
3842  INTEGER l,line,n1,n2,j,dir,lold,nold,colmaxold,statold,nscatcenold
3843  DOUBLE PRECISION pyr,pi,beta(3),theta,phi,pyp,phi2,maxt,t,
3844  &newmass,deltam,dm,ttot,dmleft,lambda,time,endtime,x,tmp,
3845  &m32,newm2,shat,theta2,z,gettemp,e3new,e4new,p32,p42,p3old,
3846  &newm,mass2,enew,pt2,pt,pl,m12,firsttime,pcms2
3847  CHARACTER*2 typ
3848  LOGICAL retrysplit,qqbar,qqbardec,rejectt,redokin,reshuffle
3849  DATA pi/3.141592653589793d0/
3850 
3851  IF((n+2*(n2-n1+1)).GT.22990)THEN
3852  write(logfid,*)'event too long for event record'
3853  discard=.true.
3854  RETURN
3855  ENDIF
3856 
3857  firsttime = mv(l,5)
3858 
3859  redokin = .false.
3860 
3861  newm2=newm
3862  nold=n
3863  colmaxold=colmax
3864  statold=k(l,1)
3865  204 deltam=newm2-p(l,5)
3866  dmleft=deltam
3867 
3868  ttot=0.d0
3869  DO 220 j=n1,n2
3870  ttot=ttot+allqs(j,1)
3871  220 CONTINUE
3872 
3873  line=l
3874 
3875  DO 222 j=n1,n2
3876 
3877 C--projectile type
3878  IF(k(line,2).EQ.21)THEN
3879  typ='GC'
3880  IF(pyr(0).LT.0.5)THEN
3881  dir=1
3882  ELSE
3883  dir=-1
3884  ENDIF
3885  ELSE
3886  typ='QQ'
3887  dir=0
3888  ENDIF
3889  k(1,1)=6
3890  k(1,2)=scatcentres(j,1)
3891  p(1,1)=scatcentres(j,2)
3892  p(1,2)=scatcentres(j,3)
3893  p(1,3)=scatcentres(j,4)
3894  p(1,4)=scatcentres(j,5)
3895  p(1,5)=scatcentres(j,6)
3896  mv(1,1)=scatcentres(j,7)
3897  mv(1,2)=scatcentres(j,8)
3898  mv(1,3)=scatcentres(j,9)
3899  mv(1,4)=scatcentres(j,10)
3900  t=allqs(j,1)
3901  if (t.eq.0.d0) then
3902  rejectt = .true.
3903  else
3904  rejectt = .false.
3905  endif
3906 
3907 C--transform to c.m.s. and rotate such that parton momentum is in z-direction
3908  beta(1)=(p(1,1)+p(line,1))/(p(1,4)+p(line,4))
3909  beta(2)=(p(1,2)+p(line,2))/(p(1,4)+p(line,4))
3910  beta(3)=(p(1,3)+p(line,3))/(p(1,4)+p(line,4))
3911  IF ((beta(1).GT.1.d0).OR.(beta(2).GT.1.d0).OR.(beta(3).GT.1.d0)
3912  & .or.(sqrt(beta(1)**2+beta(2)**2+beta(3)**2).gt.1.d0))THEN
3913  reshuffle = .false.
3914  else
3915  reshuffle = .true.
3916  endif
3917  205 if (.not.reshuffle) then
3918  beta(1)=p(1,1)/p(1,4)
3919  beta(2)=p(1,2)/p(1,4)
3920  beta(3)=p(1,3)/p(1,4)
3921  CALL pyrobo(line,line,0d0,0d0,-beta(1),-beta(2),-beta(3))
3922  CALL pyrobo(1,1,0d0,0d0,-beta(1),-beta(2),-beta(3))
3923  theta=pyp(line,13)
3924  phi=pyp(line,15)
3925  CALL pyrobo(line,line,0d0,-phi,0d0,0d0,0d0)
3926  CALL pyrobo(1,1,0d0,-phi,0d0,0d0,0d0)
3927  CALL pyrobo(line,line,-theta,0d0,0d0,0d0,0d0)
3928  CALL pyrobo(1,1,-theta,0d0,0d0,0d0,0d0)
3929 
3930  maxt = -2.*p(1,5)*p(line,4)
3931  if (t.lt.maxt) then
3932  t=0.d0
3933  rejectt = .true.
3934  endif
3935  m12 = -p(line,5)**2
3936  203 enew = p(line,4)+t/(2.*p(1,5))
3937  pl = (t+2.*p(line,4)*enew-2.*m12)/(2.*p(line,3))
3938  pt2 = enew**2-pl**2-m12
3939  if (t.eq.0.d0) pt2 = 0.d0
3940  if (dabs(pt2).lt.1.d-8) pt2 = 0.d0
3941  if (pt2.lt.0.d0) then
3942  write(logfid,*)' This should not have happened: pt^2<0!'
3943  write(logfid,*)t,enew,pl,pt2
3944  t = 0.d0
3945  rejectt = .true.
3946  goto 203
3947  endif
3948  pt = sqrt(pt2)
3949  phi2 = pyr(0)*2.*pi
3950  n=n+2
3951  p(n,1)=pt*cos(phi2)
3952  p(n,2)=pt*sin(phi2)
3953  p(n,3)=pl
3954  p(n,4)=enew
3955  p(n,5)=p(line,5)
3956 !---------------------------------
3957  p(n-1,1)=p(1,1)+p(line,1)-p(n,1)
3958  p(n-1,2)=p(1,2)+p(line,2)-p(n,2)
3959  p(n-1,3)=p(1,3)+p(line,3)-p(n,3)
3960  p(n-1,4)=p(1,4)+p(line,4)-p(n,4)
3961  mass2 = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2
3962  if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
3963  if (mass2.lt.0.d0)
3964  & write(logfid,*)'messed up scattering centres mass^2: ',
3965  & mass2,p(1,5)**2
3966  p(n-1,5)=sqrt(mass2)
3967  if (abs(p(n-1,5)-p(1,5)).gt.1.d-6)
3968  & write(logfid,*)'messed up scattering centres mass: ',
3969  & p(n-1,5),p(1,5),p(l,5)
3970  call flush(logfid)
3971 !---------------------------------
3972 ! P(N-1,1)=P(1,1)
3973 ! P(N-1,2)=P(1,2)
3974 ! P(N-1,3)=P(1,3)
3975 ! P(N-1,4)=P(1,4)
3976 ! P(N-1,5)=P(1,5)
3977 !---------------------------------
3978  else
3979  CALL pyrobo(line,line,0d0,0d0,-beta(1),-beta(2),-beta(3))
3980  CALL pyrobo(1,1,0d0,0d0,-beta(1),-beta(2),-beta(3))
3981  if ((p(1,4).lt.0.d0).or.(p(line,4).lt.0.d0)) then
3982  CALL pyrobo(1,1,0d0,0d0,beta(1),beta(2),beta(3))
3983  CALL pyrobo(line,line,0d0,0d0,beta(1),beta(2),beta(3))
3984  reshuffle = .false.
3985  goto 205
3986  endif
3987  theta=pyp(line,13)
3988  phi=pyp(line,15)
3989  CALL pyrobo(line,line,0d0,-phi,0d0,0d0,0d0)
3990  CALL pyrobo(1,1,0d0,-phi,0d0,0d0,0d0)
3991  CALL pyrobo(line,line,-theta,0d0,0d0,0d0,0d0)
3992  CALL pyrobo(1,1,-theta,0d0,0d0,0d0,0d0)
3993  shat = (p(1,4)+p(line,4))**2
3994  p3old = p(line,3)
3995 
3996  maxt = -4.*p(line,3)**2
3997  if (t.lt.maxt) then
3998  t=0.d0
3999  rejectt = .true.
4000  endif
4001  theta2 = acos(1.d0+t/(2.*p(line,3)**2))
4002  phi2 = pyr(0)*2.*pi
4003  n=n+2
4004  p(n,1)=p(line,3)*sin(theta2)*cos(phi2)
4005  p(n,2)=p(line,3)*sin(theta2)*sin(phi2)
4006  p(n,3)=p(line,3)*cos(theta2)
4007  p(n,4)=p(line,4)
4008  p(n,5)=p(line,5)
4009 !---------------------------------
4010  p(n-1,1)=p(1,1)+p(line,1)-p(n,1)
4011  p(n-1,2)=p(1,2)+p(line,2)-p(n,2)
4012  p(n-1,3)=p(1,3)+p(line,3)-p(n,3)
4013  p(n-1,4)=p(1,4)+p(line,4)-p(n,4)
4014  mass2 = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2
4015  if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0
4016  if (mass2.lt.0.d0)
4017  & write(logfid,*)'messed up scattering centres mass^2: ',
4018  & mass2,p(1,5)**2
4019  p(n-1,5)=sqrt(mass2)
4020  if (abs(p(n-1,5)-p(1,5)).gt.1.d-6)
4021  & write(logfid,*)'messed up scattering centres mass: ',
4022  & p(n-1,5),p(1,5),p(l,5)
4023  call flush(logfid)
4024 !---------------------------------
4025 ! P(N-1,1)=P(1,1)
4026 ! P(N-1,2)=P(1,2)
4027 ! P(N-1,3)=P(1,3)
4028 ! P(N-1,4)=P(1,4)
4029 ! P(N-1,5)=P(1,5)
4030 !---------------------------------
4031  endif
4032 C--outgoing projectile
4033  za(n)=1.d0
4034  thetaa(n)=-1.d0
4035  zd(n)=z
4036  qqbard(n)=qqbar
4037  k(n,1)=k(line,1)
4038  k(n,2)=k(line,2)
4039  k(n,3)=l
4040  k(n,4)=0
4041  k(n,5)=0
4042  IF(allhad.and.(.not.rejectt))THEN
4043  IF(k(n,2).EQ.21)THEN
4044  IF(dir.EQ.1)THEN
4045  trip(n)=colmax+1
4046  anti(n)=anti(line)
4047  ELSE
4048  trip(n)=trip(line)
4049  anti(n)=colmax+1
4050  ENDIF
4051  ELSEIF(k(n,2).GT.0)THEN
4052  trip(n)=colmax+1
4053  anti(n)=0
4054  ELSE
4055  trip(n)=0
4056  anti(n)=colmax+1
4057  ENDIF
4058  colmax=colmax+1
4059  ELSE
4060  trip(n)=trip(line)
4061  anti(n)=anti(line)
4062  ENDIF
4063 C--take care of incoming projectile
4064  IF(k(line,1).EQ.1)THEN
4065  k(line,1)=12
4066  ELSE
4067  k(line,1)=14
4068  ENDIF
4069  k(line,4)=n-1
4070  k(line,5)=n
4071 C--outgoing scattering centre
4072  za(n-1)=1.d0
4073  thetaa(n-1)=-1.d0
4074  zd(n-1)=-1.d0
4075  qqbard(n-1)=.false.
4076 C--temporary status code, will be overwritten later
4077  k(n-1,1)=3
4078  k(n-1,2)=21
4079  k(n-1,3)=0
4080  k(n-1,4)=0
4081  k(n-1,5)=0
4082  IF(allhad.and.(.not.rejectt))THEN
4083  IF((k(n,2).GT.0).AND.(dir.GE.0))THEN
4084  trip(n-1)=trip(line)
4085  anti(n-1)=trip(n)
4086  ELSE
4087  trip(n-1)=anti(n)
4088  anti(n-1)=anti(line)
4089  ENDIF
4090  ELSE
4091  trip(n-1)=0
4092  anti(n-1)=0
4093  ENDIF
4094 
4095  if (reshuffle.and.(dm.gt.0.d0)) then
4096 C--adjust mass and re-shuffle momenta
4097 
4098  IF(ttot.EQ.0.d0)THEN
4099  dm=0.d0
4100  ELSE
4101  if (dmleft.lt.0.d0) then
4102  dm=max(dmleft*t/ttot*1.5d0,dmleft)
4103  else
4104  dm=min(dmleft*t/ttot*1.5d0,dmleft)
4105  endif
4106  ENDIF
4107  ttot=ttot-allqs(j,1)
4108 
4109  newmass = p(n,5)+dm
4110  if (newmass.lt.0.d0) then
4111  m32 = -newmass**2
4112  else
4113  m32 = newmass**2
4114  endif
4115  e3new = (shat + m32 - p(1,5)**2)/(2.d0*sqrt(shat))
4116  e4new = (shat - m32 + p(1,5)**2)/(2.d0*sqrt(shat))
4117  p32 = e3new**2 - m32
4118  p42 = e4new**2 - p(1,5)**2
4119  if ((p32.lt.0.d0).or.(p42.lt.0.d0).or.
4120  & (e3new.lt.0.d0).or.(e4new.lt.0.d0)) then
4121  p32 = 0.d0
4122  p42 = 0.d0
4123  e4new = p(n-1,5)
4124  e3new = sqrt(shat) - e4new
4125  m32 = e3new**2
4126  if ((e3new.lt.0.d0).or.(e4new.lt.0.d0)) then
4127  e3new = p(n,4)
4128  e4new = p(n-1,4)
4129  p32 = p3old**2
4130  p42 = p3old**2
4131  if (p(n,5).lt.0.d0) then
4132  m32 = -p(n,5)**2
4133  else
4134  m32 = p(n,5)**2
4135  endif
4136  endif
4137  endif
4138  p(n,1) = sqrt(p32)*p(n,1)/p3old
4139  p(n,2) = sqrt(p32)*p(n,2)/p3old
4140  p(n,3) = sqrt(p32)*p(n,3)/p3old
4141  p(n,4) = e3new
4142  p(n,5) = sign(sqrt(abs(m32)),newmass)
4143  tmp = p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2
4144  if (abs(tmp-m32).gt.1.d-6)
4145  & write(logfid,*) 'Oups, messed up projectiles mass:',
4146  & tmp,m32,p(n,5)
4147 !---------------------------------
4148  p(n-1,1) = sqrt(p42)*p(n-1,1)/p3old
4149  p(n-1,2) = sqrt(p42)*p(n-1,2)/p3old
4150  p(n-1,3) = sqrt(p42)*p(n-1,3)/p3old
4151  p(n-1,4) = e4new
4152  tmp = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2
4153  & -p(n-1,5)**2
4154  if (abs(tmp).gt.1.d-6)
4155  & write(logfid,*) 'Oups, messed up scattering centres mass:',
4156  & tmp,p3old,p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
4157  if ((abs(p(n,1)+p(n-1,1)).gt.1.d-6).or.
4158  & (abs(p(n,2)+p(n-1,2)).gt.1.d-6).or.
4159  & (abs(p(n,3)+p(n-1,3)).gt.1.d-6))
4160  & write(logfid,*) 'Oups, momentum not conserved',
4161  & p(n,1)+p(n-1,1),p(n,2)+p(n-1,2),p(n,3)+p(n-1,3)
4162 !---------------------------------
4163 ! P(N-1,1)=P(1,1)
4164 ! P(N-1,2)=P(1,2)
4165 ! P(N-1,3)=P(1,3)
4166 ! P(N-1,4)=P(1,4)
4167 ! P(N-1,5)=P(1,5)
4168 !---------------------------------
4169  endif
4170 
4171 C--transformation to lab
4172  CALL pyrobo(n-1,n,theta,0d0,0d0,0d0,0d0)
4173  CALL pyrobo(line,line,theta,0d0,0d0,0d0,0d0)
4174  CALL pyrobo(n-1,n,0d0,phi,0d0,0d0,0d0)
4175  CALL pyrobo(line,line,0d0,phi,0d0,0d0,0d0)
4176  CALL pyrobo(n-1,n,0d0,0d0,beta(1),beta(2),beta(3))
4177  CALL pyrobo(line,line,0d0,0d0,beta(1),beta(2),beta(3))
4178  CALL pyrobo(1,1,theta,0d0,0d0,0d0,0d0)
4179  CALL pyrobo(1,1,0d0,phi,0d0,0d0,0d0)
4180  CALL pyrobo(1,1,0d0,0d0,beta(1),beta(2),beta(3))
4181  if (.not.allhad) then
4182  k(n-1,1)=13
4183  else
4184  IF(scatrecoil.AND.(p(n-1,4).GT.(10.*3.*
4185  &gettemp(mv(1,1),mv(1,2),mv(1,3),mv(1,4)))))THEN
4186  k(n-1,1)=2
4187  ELSE
4188  k(n-1,1)=3
4189  ENDIF
4190  endif
4191  if (rejectt) k(n-1,1)=11
4192  mv(n,4)=mv(1,4)
4193  mv(n-1,4)=mv(1,4)
4194 C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother
4195  mv(n-1,1)=mv(line,1)
4196  & +(mv(n-1,4)-mv(line,4))*p(line,1)/max(pyp(line,8),p(line,4))
4197  mv(n-1,2)=mv(line,2)
4198  & +(mv(n-1,4)-mv(line,4))*p(line,2)/max(pyp(line,8),p(line,4))
4199  mv(n-1,3)=mv(line,3)
4200  & +(mv(n-1,4)-mv(line,4))*p(line,3)/max(pyp(line,8),p(line,4))
4201  mv(n, 1)=mv(line,1)
4202  & +(mv(n, 4)-mv(line,4))*p(line,1)/max(pyp(line,8),p(line,4))
4203  mv(n, 2)=mv(line,2)
4204  & +(mv(n, 4)-mv(line,4))*p(line,2)/max(pyp(line,8),p(line,4))
4205  mv(n, 3)=mv(line,3)
4206  & +(mv(n, 4)-mv(line,4))*p(line,3)/max(pyp(line,8),p(line,4))
4207  IF(p(n-1,5).GT.p(1,5))THEN
4208  lambda=1.d0/(ftfac*0.2*p(n-1,4)/p(n-1,5)**2)
4209  mv(n-1,5)=mv(n-1,4)-log(1.d0-pyr(0))/lambda
4210  ELSE
4211  mv(n-1,5)=0.d0
4212  ENDIF
4213  IF(j.LT.n2)THEN
4214  mv(n,5)=scatcentres(j+1,10)
4215  ELSE
4216  IF(p(n,5).GT.0.d0)THEN
4217  IF(deltam.EQ.0.d0)THEN
4218  endtime=firsttime
4219  ELSE
4220  IF(x.LT.1.d0)THEN
4221  lambda=1.d0/(ftfac*p(n,4)*0.2/p(n,5)**2)
4222  endtime=scatcentres(j,10)-log(1.d0-pyr(0))/lambda
4223  ELSE
4224  endtime=time
4225  ENDIF
4226  ENDIF
4227  mv(n,5)=endtime
4228  ELSE
4229  mv(n,5)=0.d0
4230  ENDIF
4231  ENDIF
4232  mv(line,5)=allqs(j,6)
4233 
4234 
4235 C--store scattering centre before interaction in separate common block
4236  if (writescatcen.and.(.not.rejectt).and.
4237  & (nscatcen.lt.maxnscatcen)) then
4238  nscatcen = nscatcen+1
4239  if (nscatcen.le.maxnscatcen) then
4240  scatflav(nscatcen) = k(1,2)
4241  scatcen(nscatcen,1) = p(1,1)
4242  scatcen(nscatcen,2) = p(1,2)
4243  scatcen(nscatcen,3) = p(1,3)
4244  scatcen(nscatcen,4) = p(1,4)
4245  scatcen(nscatcen,5) = p(1,5)
4246  else
4247  write(logfid,*)
4248  &'WARNING: no room left to store further scattering centres'
4249  endif
4250  endif
4251 
4252 ! if ((p(line,4).gt.100.d0).and.(p(n,4)-p(line,4).gt.1.d0)) then
4253 ! write(*,*)p(line,1),p(line,2),p(line,3),p(line,4),p(line,5)
4254 ! write(*,*)p(n,1),p(n,2),p(n,3),p(n,4),p(n,5)
4255 ! write(*,*)p(1,1),p(1,2),p(1,3),p(1,4),p(1,5)
4256 ! write(*,*)p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5)
4257 ! write(*,*)t
4258 ! write(*,*)GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))
4259 ! write(*,*)
4260 ! endif
4261 
4262  dmleft=dmleft-(p(n,5)-p(line,5))
4263  line=n
4264  tmp = abs(p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2)-p(n,5)**2
4265  if (abs(tmp).ge.1.d-6)
4266  & write(logfid,*)tmp,j,p(l,5),p(line,5),p(n,5)
4267  222 CONTINUE
4268  if (p(n,5).lt.0.d0) then
4269  retrysplit=.true.
4270  return
4271  endif
4272  if (p(n,5).ne.newm2) then
4273  retrysplit=.true.
4274  redokin = .true.
4275  n=nold
4276  colmax=colmaxold
4277  k(l,1)=statold
4278  if (p(l,5).le.0.d0) then
4279  newm2 = 0.d0
4280  else
4281  if (p(l,5).lt.q0) then
4282  if ((newm2.eq.newm).and.(newm.ne.q0+1.d-6)) then
4283  newm2=q0+1.d-6
4284  else
4285  retrysplit=.true.
4286  return
4287  endif
4288  else
4289  newm2=p(l,5)
4290  endif
4291  n2=n1
4292  endif
4293  goto 204
4294  endif
4295  if ((k(n,1).eq.1).and.
4296  & ((p(n,5).lt.0.d0).or.((p(n,5).gt.0.d0).and.(p(n,5).lt.q0))))
4297  &write(logfid,*)'dokinematics did not reach sensible mass: ',
4298  &p(n,5),newm,p(l,5),newm2
4299  nscateff=nscateff+evweight
4300  END
4301 
4302 
4303 
4304 ***********************************************************************
4305 *** function getproba
4306 ***********************************************************************
4307  DOUBLE PRECISION FUNCTION getproba(QI,QF,QAA,ZAA,EBB,TYPE,
4308  & t1,ins2)
4309  IMPLICIT NONE
4310 C--variables for Sudakov integration
4311  common/sudaint/qa,za2,eb,t,instate,typ
4312  DOUBLE PRECISION qa,za2,eb,t
4313  CHARACTER*2 typ
4314  LOGICAL instate
4315 C--local variables
4316  DOUBLE PRECISION qi,qf,qaa,zaa,ebb,getsudakov,deriv,t1
4317  CHARACTER*2 type
4318  LOGICAL ins2
4319 
4320  qa=qaa
4321  za2=zaa
4322  eb=ebb
4323  typ=TYPE
4324  t=t1
4325  instate=ins2
4326  getproba=getsudakov(qi,qaa,qf,zaa,ebb,type,t1,ins2)
4327  & *deriv(qf,1)
4328  END
4329 
4330 
4331 ***********************************************************************
4332 *** function getsudakov
4333 ***********************************************************************
4334  DOUBLE PRECISION FUNCTION getsudakov(QMAX1,QA1,QB1,ZA1,EB1,
4335  & type3,t2,ins)
4336  IMPLICIT NONE
4337 C--identifier of file for hepmc output and logfile
4338  common/hepmcid/hpmcfid,logfid
4339  integer hpmcfid,logfid
4340 C--Parameter common block
4341  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
4342  &allhad,compress,nf
4343  INTEGER nf
4344  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
4345  LOGICAL angord,scatrecoil,allhad,compress
4346 C--variables for Sudakov integration
4347  common/sudaint/qa,za2,eb,t,instate,typ
4348  DOUBLE PRECISION qa,za2,eb,t
4349  CHARACTER*2 typ
4350  LOGICAL instate
4351 C--local variables
4352  DOUBLE PRECISION qmax1,qa1,qb1,za1,eb1,tmax,tb,ystart,epsi,
4353  &hfirst,t2,getinsudafast,qb2
4354  CHARACTER*2 type3
4355  LOGICAL ins
4356  DATA epsi/1.d-4/
4357 
4358  qb2=qb1
4359  IF(ins)THEN
4360  IF(qb2.LT.q0) write(logfid,*) 'error: Q < Q0',qb2,qmax1
4361  IF(qb2.LT.(q0+1.d-10)) qb2=qb2+1.d-10
4362  ELSE
4363  IF(qb2.LT.q0) write(logfid,*) 'error: Q < min',qb2,qmax1
4364  IF(qb2.LT.(q0+1.d-10)) qb2=qb2+1.d-10
4365  ENDIF
4366  IF(qb2.GE.(qmax1-1.d-10)) THEN
4367  getsudakov=1.d0
4368  ELSE
4369  IF(ins)THEN
4370  getsudakov=getinsudafast(qb1,qmax1,type3)
4371  ELSE
4372  qa=qa1
4373  za2=za1
4374  eb=eb1
4375  typ=type3
4376  t=t2
4377  instate=.false.
4378  hfirst=0.01*(qmax1-qb1)
4379  ystart=0.d0
4380  CALL odeint(ystart,qb2,qmax1,epsi,hfirst,0.d0,1)
4381  getsudakov=exp(-ystart)
4382  ENDIF
4383  ENDIF
4384  END
4385 
4386 
4387 ***********************************************************************
4388 *** function getinsudakov
4389 ***********************************************************************
4390  DOUBLE PRECISION FUNCTION getinsudakov(QB,QMAX1,TYPE3)
4391  IMPLICIT NONE
4392 C--identifier of file for hepmc output and logfile
4393  common/hepmcid/hpmcfid,logfid
4394  integer hpmcfid,logfid
4395 C--Parameter common block
4396  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
4397  &allhad,compress,nf
4398  INTEGER nf
4399  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
4400  LOGICAL angord,scatrecoil,allhad,compress
4401 C--variables for Sudakov integration
4402  common/sudaint/qa,za2,eb,t,instate,typ
4403  DOUBLE PRECISION qa,za2,eb,t
4404  CHARACTER*2 typ
4405  LOGICAL instate
4406 C--local variables
4407  DOUBLE PRECISION qmax1,qb,qb1,za1,ea1,ystart,epsi,
4408  &hfirst
4409  CHARACTER*2 type3
4410  DATA epsi/1.d-4/
4411 
4412  qb1=qb
4413  IF(qb1.LT.q0) write(logfid,*) 'error: Q < Q0',qb1,qmax1
4414  IF(qb1.LT.(q0+1.d-12)) qb1=qb1+1.d-12
4415  IF(qb1.GE.(qmax1-1.d-12)) THEN
4416  getinsudakov=1.d0
4417  ELSE
4418  typ=type3
4419  hfirst=0.01*(qmax1-qb1)
4420  ystart=0.d0
4421  CALL odeint(ystart,qb1,qmax1,epsi,hfirst,0.d0,6)
4422  getinsudakov=exp(-ystart)
4423  ENDIF
4424  END
4425 
4426 
4427 ***********************************************************************
4428 *** function deriv
4429 ***********************************************************************
4430  DOUBLE PRECISION FUNCTION deriv(XVAL,W4)
4431  IMPLICIT NONE
4432 C--Parameter common block
4433  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
4434  &allhad,compress,nf
4435  INTEGER nf
4436  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
4437  LOGICAL angord,scatrecoil,allhad,compress
4438 C--variables for splitting function integration
4439  common/intsplitf/qquad,fm
4440  DOUBLE PRECISION qquad,fm
4441 C--variables for Sudakov integration
4442  common/sudaint/qa,za2,eb,t,instate,typ
4443  DOUBLE PRECISION qa,za2,eb,t
4444  CHARACTER*2 typ
4445  LOGICAL instate
4446 C--variables for pdf integration
4447  common/pdfintv/xmax,z
4448  DOUBLE PRECISION xmax,z
4449 C--variables for cross section integration
4450  common/xsecv/qlow,mdx
4451  DOUBLE PRECISION qlow,mdx
4452 C--local variables
4453  INTEGER w4
4454  DOUBLE PRECISION xval,getspliti,pi,alphas,getinspliti,
4455  &getinsudafast,scatprimfunc,pqq,pqg,pgg,pgq,
4456  &medderiv
4457  DATA pi/3.141592653589793d0/
4458 
4459  IF(w4.EQ.1)THEN
4460 C--Sudakov integration
4461  IF(instate)THEN
4462  deriv=2.*getinspliti(xval,typ)/xval
4463  ELSE
4464  deriv=2.*getspliti(qa,xval,za2,eb,typ)/xval
4465  ENDIF
4466  ELSEIF(w4.EQ.2)THEN
4467 C--P(q->qg) integration
4468  deriv=(1.+fm)*alphas(xval*(1.-xval)*qquad/1.,lps)*
4469  & pqq(xval)/(2.*pi)
4470  ELSEIF(w4.EQ.3)THEN
4471 C--P(g->gg) integration
4472  deriv=(1.+fm)*alphas(xval*(1.-xval)*qquad/1.,lps)
4473  & *pgg(xval)/(2.*pi)
4474  ELSEIF(w4.EQ.4)THEN
4475 C--P(g->qq) integration
4476  deriv=(1.+fm)*alphas(xval*(1-xval)*qquad/1.,lps)*
4477  & pqg(xval)/(2.*pi)
4478  ELSEIF(w4.EQ.5)THEN
4479  deriv=exp(-xval)/xval
4480  ELSEIF(w4.EQ.6)THEN
4481  deriv=2.*getinspliti(xval,typ)/xval
4482  ELSEIF(w4.EQ.7)THEN
4483  deriv=2.*getinsudafast(xval,xmax,'QQ')
4484  & *alphas((1.-z)*xval**2/1.,lps)
4485  & *pqq(z)/(2.*pi*xval)
4486  ELSEIF(w4.EQ.8)THEN
4487  deriv=2.*getinsudafast(xval,xmax,'GC')
4488  & *alphas((1.-z)*xval**2/1.,lps)
4489  & *pgq(z)/(2.*pi*xval)
4490  ELSEIF(w4.EQ.9)THEN
4491  deriv=2.*getinsudafast(xval,xmax,'QQ')
4492  & *alphas((1.-z)*xval**2/1.,lps)
4493  & *pqg(z)/(2.*pi*xval)
4494  ELSEIF(w4.EQ.10)THEN
4495  deriv=2.*getinsudafast(xval,xmax,'GC')
4496  & *alphas((1.-z)*xval**2/1.,lps)*
4497  & *2.*pgg(z)/(2.*pi*xval)
4498  ELSEIF(w4.EQ.11)THEN
4499  deriv=3.*getinspliti(scalefacm*sqrt(xval),'GQ')
4500  & *scatprimfunc(xval,mdx)/(2.*xval)
4501  ELSEIF(w4.EQ.12)THEN
4502  deriv=2.*getinspliti(scalefacm*sqrt(xval),'QG')
4503  & *scatprimfunc(xval,mdx)/(3.*xval)
4504  ELSEIF(w4.EQ.13)THEN
4505  deriv=getinsudafast(qlow,scalefacm*sqrt(xval),'GC')
4506  & *3.*2.*pi*alphas(xval+mdx**2,lqcd)**2/(2.*(xval+mdx**2)**2)
4507  ELSEIF(w4.EQ.14)THEN
4508  deriv=getinsudafast(qlow,scalefacm*sqrt(xval),'QQ')
4509  & *2.*2.*pi*alphas(xval+mdx**2,lqcd)**2/(3.*(xval+mdx**2)**2)
4510  ELSEIF(w4.EQ.21)THEN
4511  deriv=2.*getinsudafast(xval,xmax,'QQ')*getinspliti(xval,'QQ')
4512  & /xval
4513  ELSEIF(w4.EQ.22)THEN
4514  deriv=2.*getinsudafast(xval,xmax,'GC')*getinspliti(xval,'GQ')
4515  & /xval
4516  ELSEIF(w4.EQ.23)THEN
4517  deriv=2.*getinsudafast(xval,xmax,'QQ')*getinspliti(xval,'QG')
4518  & /xval
4519  ELSEIF(w4.EQ.24)THEN
4520  deriv=2.*getinsudafast(xval,xmax,'GC')*2.
4521  & *getinspliti(xval,'GG')/xval
4522  ELSE
4523  deriv=medderiv(xval,w4-100)
4524  ENDIF
4525  END
4526 
4527 
4528 ***********************************************************************
4529 *** function getspliti
4530 ***********************************************************************
4531  DOUBLE PRECISION FUNCTION getspliti(QA,QB,ZETA,EB,TYPE1)
4532  IMPLICIT NONE
4533 C--identifier of file for hepmc output and logfile
4534  common/hepmcid/hpmcfid,logfid
4535  integer hpmcfid,logfid
4536 C--Parameter common block
4537  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
4538  &allhad,compress,nf
4539  INTEGER nf
4540  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
4541  LOGICAL angord,scatrecoil,allhad,compress
4542 C--splitting integral
4543  common/splitint/splitiggv(1000,1000),splitiqqv(1000,1000),
4544  &splitiqgv(1000,1000),qval(1000),zmval(1000),qmax,zmmin,npoint
4545  INTEGER npoint
4546  DOUBLE PRECISION splitiggv,splitiqqv,splitiqgv,
4547  &qval,zmval,qmax,zmmin
4548 C--variables for splitting function integration
4549  common/intsplitf/qquad,fm
4550  DOUBLE PRECISION qquad,fm
4551 C--number of extrapolations in tables
4552  common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
4553  &ntotxsec,noverxsec,ntotsuda,noversuda
4554  integer ntotspliti,noverspliti,ntotpdf,noverpdf,
4555  &ntotxsec,noverxsec,ntotsuda,noversuda
4556 C--local variables
4557  INTEGER i,j,lt,qlmax,zlmax,qline,zline
4558  DOUBLE PRECISION qa,qb,zeta,eb,low,x1a(2),x2a(2),ya(2,2),y,
4559  &splitintgg,splitintqg,a,b,yb(2)
4560  CHARACTER*2 type1
4561 
4562  ntotspliti=ntotspliti+1
4563  if (qb.gt.qmax) then
4564  noverspliti=noverspliti+1
4565  if (noverspliti.le.25)
4566  & write(logfid,*)'WARNING in getspliti: need to extrapolate: ',
4567  & qb,qmax
4568  endif
4569 
4570 C--find boundaries for z integration
4571  IF(angord.AND.(zeta.NE.1.d0))THEN
4572  low=max(0.5-0.5*sqrt(1.-q0**2/qb**2)
4573  & *sqrt(1.-qb**2/eb**2),
4574  & 0.5-0.5*sqrt(1.-4.*qb**2*(1.-zeta)/(zeta*qa**2)))
4575  ELSE
4576  low=0.5-0.5*sqrt(1.-q0**2/qb**2)
4577  & *sqrt(1.-qb**2/eb**2)
4578  ENDIF
4579 C--find values in array
4580  qlmax=int((qb-qval(1))*npoint/(qval(1000)-qval(1))+1)
4581  qline=max(qlmax,1)
4582  qline=min(qline,npoint)
4583  zlmax=int((log(low)-log(zmval(1)))*npoint/
4584  & (log(zmval(1000))-log(zmval(1)))+1)
4585  zline=max(zlmax,1)
4586  zline=min(zline,npoint)
4587  IF((qline.GT.999).OR.(zline.GT.999).OR.
4588  & (qline.LT.1).OR.(zline.LT.1))THEN
4589  write(logfid,*)'ERROR in GETSPLITI: line number out of bound',
4590  & qline,zline
4591  ENDIF
4592  IF((type1.EQ.'GG').OR.(type1.EQ.'GC'))THEN
4593  DO 17 i=1,2
4594  x1a(i)=qval(qline-1+i)
4595  x2a(i)=zmval(zline-1+i)
4596  DO 16 j=1,2
4597  ya(i,j)=splitiggv(qline-1+i,zline-1+j)
4598  16 CONTINUE
4599  17 CONTINUE
4600  DO 30 i=1,2
4601  a=(ya(i,2)-ya(i,1))/(x2a(2)-x2a(1))
4602  b=ya(i,1)-a*x2a(1)
4603  yb(i)=a*low+b
4604  30 CONTINUE
4605  IF(x1a(1).EQ.x1a(2))THEN
4606  y=(yb(1)+yb(2))/2.
4607  ELSE
4608  a=(yb(2)-yb(1))/(x1a(2)-x1a(1))
4609  b=yb(1)-a*x1a(1)
4610  y=a*qb+b
4611  ENDIF
4612  IF(type1.EQ.'GG')THEN
4613  getspliti=min(y,10.d0)
4614  ELSE
4615  splitintgg=min(y,10.d0)
4616  ENDIF
4617  ENDIF
4618  IF((type1.EQ.'QG').OR.(type1.EQ.'GC'))THEN
4619  DO 19 i=1,2
4620  x1a(i)=qval(qline-1+i)
4621  x2a(i)=zmval(zline-1+i)
4622  DO 18 j=1,2
4623  ya(i,j)=splitiqgv(qline-1+i,zline-1+j)
4624  18 CONTINUE
4625  19 CONTINUE
4626  DO 31 i=1,2
4627  a=(ya(i,2)-ya(i,1))/(x2a(2)-x2a(1))
4628  b=ya(i,1)-a*x2a(1)
4629  yb(i)=a*low+b
4630  31 CONTINUE
4631  IF(x1a(1).EQ.x1a(2))THEN
4632  y=(yb(1)+yb(2))/2.
4633  ELSE
4634  a=(yb(2)-yb(1))/(x1a(2)-x1a(1))
4635  b=yb(1)-a*x1a(1)
4636  y=a*qb+b
4637  ENDIF
4638  IF(type1.EQ.'QG')THEN
4639  getspliti=nf*min(y,10.d0)
4640  ELSE
4641  splitintqg=nf*min(y,10.d0)
4642  ENDIF
4643  ENDIF
4644  IF(type1.EQ.'QQ')THEN
4645  DO 21 i=1,2
4646  x1a(i)=qval(qline-1+i)
4647  x2a(i)=zmval(zline-1+i)
4648  DO 20 j=1,2
4649  ya(i,j)=splitiqqv(qline-1+i,zline-1+j)
4650  20 CONTINUE
4651  21 CONTINUE
4652  DO 32 i=1,2
4653  a=(ya(i,2)-ya(i,1))/(x2a(2)-x2a(1))
4654  b=ya(i,1)-a*x2a(1)
4655  yb(i)=a*low+b
4656  32 CONTINUE
4657  IF(x1a(1).EQ.x1a(2))THEN
4658  y=(yb(1)+yb(2))/2.
4659  ELSE
4660  a=(yb(2)-yb(1))/(x1a(2)-x1a(1))
4661  b=yb(1)-a*x1a(1)
4662  y=a*qb+b
4663  ENDIF
4664  getspliti=min(y,10.d0)
4665  ENDIF
4666  IF(type1.EQ.'GC') getspliti=splitintgg+splitintqg
4667  END
4668 
4669 
4670 ***********************************************************************
4671 *** function getinspliti
4672 ***********************************************************************
4673  DOUBLE PRECISION FUNCTION getinspliti(QB,TYPE1)
4674  IMPLICIT NONE
4675 C--Parameter common block
4676  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
4677  &allhad,compress,nf
4678  INTEGER nf
4679  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
4680  LOGICAL angord,scatrecoil,allhad,compress
4681 C--local variables
4682  DOUBLE PRECISION qb,low,pi,y,splitintgg,splitintqg,up,ei
4683  CHARACTER*2 type1
4684  DATA pi/3.141592653589793d0/
4685 
4686 C--find boundaries for z integration
4687  up = 1. - q0**2/(4.*qb**2)
4688  IF((type1.EQ.'GG').OR.(type1.EQ.'GC'))THEN
4689  low=1.d0-up
4690  IF (up.LE.low) THEN
4691  getinspliti=0.d0
4692  RETURN
4693  ENDIF
4694  y = 2.* ( log(log((1.-low)*qb**2/lps**2))
4695  & - lps**2*ei(log((1.-low)*qb**2/lps**2))/qb**2
4696  & + lps**4*ei(2.*log((1.-low)*qb**2/lps**2))/qb**4
4697  & - lps**6*ei(3.*log((1.-low)*qb**2/lps**2))/qb**6
4698  & - log(log((1.-up)*qb**2/lps**2))
4699  & + lps**2*ei(log((1.-up)*qb**2/lps**2))/qb**2
4700  & - lps**4*ei(2.*log((1.-up)*qb**2/lps**2))/qb**4
4701  & + lps**6*ei(3.*log((1.-up)*qb**2/lps**2))/qb**6
4702  & + low - log(low) - up + log(up) )
4703  & *3.*12.*pi/(2.*pi*(33.-2.*nf))
4704  IF(type1.EQ.'GG')THEN
4705  getinspliti=y
4706  ELSE
4707  splitintgg=y
4708  ENDIF
4709  ENDIF
4710  IF((type1.EQ.'QG').OR.(type1.EQ.'GC'))THEN
4711  low=0.d0
4712  IF (up.LE.low) THEN
4713  getinspliti=0.d0
4714  RETURN
4715  ENDIF
4716  y = ( 2.*lps**6*ei(3.*log((1.-low)*qb**2/lps**2))/qb**6
4717  & - 2.*lps**4*ei(2.*log((1.-low)*qb**2/lps**2))/qb**4
4718  & + 2.*lps**2*ei(log((1.-low)*qb**2/lps**2))/qb**2
4719  & - 2.*lps**6*ei(3.*log((1.-up)*qb**2/lps**2))/qb**6
4720  & + 2.*lps**4*ei(2.*log((1.-up)*qb**2/lps**2))/qb**4
4721  & - 2.*lps**2*ei(log((1.-up)*qb**2/lps**2))/qb**2 )
4722  & *12.*pi/(2.*2.*pi*(33.-2.*nf))
4723  IF(type1.EQ.'QG')THEN
4724  getinspliti=nf*y
4725  ELSE
4726  splitintqg=nf*y
4727  ENDIF
4728  ENDIF
4729  IF(type1.EQ.'QQ')THEN
4730  low=0.d0
4731  IF (up.LE.low) THEN
4732  getinspliti=0.d0
4733  RETURN
4734  ENDIF
4735  y = ( 2.*log(log((1.-low)*qb**2/lps**2))
4736  & - 2.*lps**2*ei(log((1.-low)*qb**2/lps**2))/qb**2
4737  & + lps**4*ei(2.*log((1.-low)*qb**2/lps**2))/qb**4
4738  & - 2.*log(log((1.-up)*qb**2/lps**2))
4739  & + 2.*lps**2*ei(log((1.-up)*qb**2/lps**2))/qb**2
4740  & - lps**4*ei(2.*log((1.-up)*qb**2/lps**2))/qb**4 )
4741  & *4.*12.*pi/(3.*2.*pi*(33.-2.*nf))
4742  getinspliti=y
4743  ENDIF
4744  IF(type1.EQ.'GQ')THEN
4745  low=1.d0-up
4746  IF (up.LE.low) THEN
4747  getinspliti=0.d0
4748  RETURN
4749  ENDIF
4750  y = (up**2/2.-2.*up+2.*log(up)-low**2/2.+2.*low- 2.*log(low))
4751  & *4.*12.*pi/(3.*2.*pi*(33.-2.*nf)*log(qb**2/lps**2))
4752  getinspliti=y
4753  ENDIF
4754  IF(type1.EQ.'GC') getinspliti=splitintgg+splitintqg
4755  END
4756 
4757 
4758 ***********************************************************************
4759 *** function getpdf
4760 ***********************************************************************
4761  DOUBLE PRECISION FUNCTION getpdf(X,Q,TYP)
4762  IMPLICIT NONE
4763 C--identifier of file for hepmc output and logfile
4764  common/hepmcid/hpmcfid,logfid
4765  integer hpmcfid,logfid
4766 C--pdf common block
4767  common/pdfs/qinqx(2,1000),ginqx(2,1000),qingx(2,1000),
4768  &gingx(2,1000)
4769  DOUBLE PRECISION qinqx,ginqx,qingx,gingx
4770 C--Parameter common block
4771  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
4772  &allhad,compress,nf
4773  INTEGER nf
4774  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
4775  LOGICAL angord,scatrecoil,allhad,compress
4776 C--variables for pdf integration
4777  common/pdfintv/xmax,z
4778  DOUBLE PRECISION xmax,z
4779 C--local variables
4780  DOUBLE PRECISION x,q,qlow,qhigh,ystart,epsi,hfirst
4781  CHARACTER*2 typ
4782  DATA epsi/1.d-4/
4783 
4784  IF((x.LT.0.d0).OR.(x.GT.1.d0).OR.(q.LT.q0))THEN
4785  write(logfid,*)'error in GETPDF: parameter out of bound',x,q
4786  getpdf=0.d0
4787  RETURN
4788  ENDIF
4789 
4790  IF(typ.EQ.'QQ')THEN
4791  z=x
4792  xmax=q
4793 C--f_q^q
4794  qlow=max(q0,q0/(2.*sqrt(1.-x)))
4795  qhigh=q
4796  IF((qlow.GE.qhigh*(1.d0-1.d-10)).OR.(x.GT.1.d0-1.d-10))THEN
4797  ystart=0.d0
4798  ELSE
4799  hfirst=0.01*(qhigh-qlow)
4800  ystart=0.d0
4801  CALL odeint(ystart,qlow,qhigh,epsi,hfirst,0.d0,7)
4802  ENDIF
4803  getpdf=ystart
4804  ELSEIF(typ.EQ.'GQ')THEN
4805  z=x
4806  xmax=q
4807 C--f_q^g
4808  qlow=max(q0,max(q0/(2.*sqrt(x)),q0/(2.*sqrt(1.-x))))
4809  qhigh=q
4810  IF((qlow.GE.qhigh*(1.d0-1.d-10)).OR.(x.LT.0.d0+1.d-10)
4811  & .OR.(x.GT.1.d0-1.d-10))THEN
4812  ystart=0.d0
4813  ELSE
4814  hfirst=0.01*(qhigh-qlow)
4815  ystart=0.d0
4816  CALL odeint(ystart,qlow,qhigh,epsi,hfirst,0.d0,8)
4817  ENDIF
4818  getpdf=ystart
4819  ELSEIF(typ.EQ.'QG')THEN
4820  z=x
4821  xmax=q
4822 C--f_q^g
4823  qlow=max(q0,q0/(2.*sqrt(1.-x)))
4824  qhigh=q
4825  IF((qlow.GE.qhigh*(1.d0-1.d-10)).OR.(x.GT.1.d0-1.d-10))THEN
4826  ystart=0.d0
4827  ELSE
4828  hfirst=0.01*(qhigh-qlow)
4829  ystart=0.d0
4830  CALL odeint(ystart,qlow,qhigh,epsi,hfirst,0.d0,9)
4831  ENDIF
4832  getpdf=ystart
4833  ELSEIF(typ.EQ.'GG')THEN
4834  z=x
4835  xmax=q
4836 C--f_q^q
4837  qlow=max(q0,max(q0/(2.*sqrt(x)),q0/(2.*sqrt(1.-x))))
4838  qhigh=q
4839  IF((qlow.GE.qhigh*(1.d0-1.d-10)).OR.(x.LT.0.d0+1.d-10)
4840  & .OR.(x.GT.1.d0-1d-10))THEN
4841  ystart=0.d0
4842  ELSE
4843  hfirst=0.01*(qhigh-qlow)
4844  ystart=0.d0
4845  CALL odeint(ystart,qlow,qhigh,epsi,hfirst,0.d0,10)
4846  ENDIF
4847  getpdf=ystart
4848  ELSE
4849  write(logfid,*)'error: pdf-type ',typ,' does not exist'
4850  getpdf=0.d0
4851  ENDIF
4852  END
4853 
4854 ***********************************************************************
4855 *** function getpdfxint
4856 ***********************************************************************
4857  DOUBLE PRECISION FUNCTION getpdfxint(Q,TYP)
4858  IMPLICIT NONE
4859 C--identifier of file for hepmc output and logfile
4860  common/hepmcid/hpmcfid,logfid
4861  integer hpmcfid,logfid
4862 C--pdf common block
4863  common/pdfs/qinqx(2,1000),ginqx(2,1000),qingx(2,1000),
4864  &gingx(2,1000)
4865  DOUBLE PRECISION qinqx,ginqx,qingx,gingx
4866 C--number of extrapolations in tables
4867  common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
4868  &ntotxsec,noverxsec,ntotsuda,noversuda
4869  integer ntotspliti,noverspliti,ntotpdf,noverpdf,
4870  &ntotxsec,noverxsec,ntotsuda,noversuda
4871 C--local variables
4872  INTEGER j,q2close,q2line
4873  DOUBLE PRECISION q,xa(2),ya(2),y,a,b
4874  CHARACTER*2 typ
4875 
4876  ntotpdf=ntotpdf+1
4877  if (q**2.gt.qinqx(1,1000)) then
4878  noverpdf=noverpdf+1
4879  if (noverpdf.le.25)
4880  & write(logfid,*)'WARNING in getpdfxint: need to extrapolate: ',
4881  & q**2,qinqx(1,1000)
4882  endif
4883 
4884  q2close=int((log(q**2)-log(qinqx(1,1)))*999.d0/
4885  & (log(qinqx(1,1000))-log(qinqx(1,1)))+1)
4886  q2line=max(q2close,1)
4887  q2line=min(q2line,999)
4888  IF((q2line.GT.999).OR.(q2line.LT.1))THEN
4889  write(logfid,*)'ERROR in GETPDFXINT: line number out of bound',
4890  & q2line
4891  ENDIF
4892 
4893  IF(typ.EQ.'QQ')THEN
4894  DO 11 j=1,2
4895  xa(j)=qinqx(1,q2line-1+j)
4896  ya(j)=qinqx(2,q2line-1+j)
4897  11 CONTINUE
4898  ELSEIF(typ.EQ.'GQ')THEN
4899  DO 13 j=1,2
4900  xa(j)=ginqx(1,q2line-1+j)
4901  ya(j)=ginqx(2,q2line-1+j)
4902  13 CONTINUE
4903  ELSEIF(typ.EQ.'QG')THEN
4904  DO 15 j=1,2
4905  xa(j)=qingx(1,q2line-1+j)
4906  ya(j)=qingx(2,q2line-1+j)
4907  15 CONTINUE
4908  ELSEIF(typ.EQ.'GG')THEN
4909  DO 17 j=1,2
4910  xa(j)=gingx(1,q2line-1+j)
4911  ya(j)=gingx(2,q2line-1+j)
4912  17 CONTINUE
4913  ELSE
4914  write(logfid,*)'error in GETPDFXINT: unknown integral type ',typ
4915  ENDIF
4916  a=(ya(2)-ya(1))/(xa(2)-xa(1))
4917  b=ya(1)-a*xa(1)
4918  y=a*q**2+b
4919  getpdfxint=y
4920  END
4921 
4922 
4923 ***********************************************************************
4924 *** subroutine getpdfxintexact
4925 ***********************************************************************
4926  DOUBLE PRECISION FUNCTION getpdfxintexact(Q,TYP)
4927  IMPLICIT NONE
4928 C--Parameter common block
4929  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
4930  &allhad,compress,nf
4931  INTEGER nf
4932  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
4933  LOGICAL angord,scatrecoil,allhad,compress
4934 C--variables for pdf integration
4935  common/pdfintv/xmax,z
4936  DOUBLE PRECISION xmax,z
4937 C--local variables
4938  DOUBLE PRECISION q,epsi,ystart,hfirst
4939  CHARACTER*2 typ
4940  DATA epsi/1.d-4/
4941 
4942  hfirst=0.01d0
4943  ystart=0.d0
4944  xmax=q
4945  z=0.d0
4946  IF(typ.EQ.'QQ')THEN
4947  CALL odeint(ystart,q0,q,epsi,hfirst,0.d0,21)
4948  ELSEIF(typ.EQ.'QG')THEN
4949  CALL odeint(ystart,q0,q,epsi,hfirst,0.d0,23)
4950  ELSEIF(typ.EQ.'GQ')THEN
4951  CALL odeint(ystart,q0,q,epsi,hfirst,0.d0,22)
4952  ELSEIF(typ.EQ.'GG')THEN
4953  CALL odeint(ystart,q0,q,epsi,hfirst,0.d0,24)
4954  ENDIF
4955  getpdfxintexact=ystart
4956  END
4957 
4958 
4959 ***********************************************************************
4960 *** function getxsecint
4961 ***********************************************************************
4962  DOUBLE PRECISION FUNCTION getxsecint(TM,MD,TYP2)
4963  IMPLICIT NONE
4964 C--identifier of file for hepmc output and logfile
4965  common/hepmcid/hpmcfid,logfid
4966  integer hpmcfid,logfid
4967 C--Parameter common block
4968  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
4969  &allhad,compress,nf
4970  INTEGER nf
4971  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
4972  LOGICAL angord,scatrecoil,allhad,compress
4973 C--cross secttion common block
4974  common/xsecs/intq1(1001,101),intq2(1001,101),
4975  &intg1(1001,101),intg2(1001,101)
4976  DOUBLE PRECISION intq1,intq2,intg1,intg2
4977 C--variables for cross section integration
4978  common/xsecv/qlow,mdx
4979  DOUBLE PRECISION qlow,mdx
4980 C--number of extrapolations in tables
4981  common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
4982  &ntotxsec,noverxsec,ntotsuda,noversuda
4983  integer ntotspliti,noverspliti,ntotpdf,noverpdf,
4984  &ntotxsec,noverxsec,ntotsuda,noversuda
4985 C--local variables
4986  INTEGER tline,tclose,mdclose,mdline,i,j
4987  DOUBLE PRECISION tm,x1a(2),x2a(2),ya(2,2),y,md,yb(2),a,b
4988  CHARACTER*2 typ2
4989 
4990  ntotxsec=ntotxsec+1
4991  if (tm.gt.intq1(1000,101)) then
4992  noverxsec=noverxsec+1
4993  if (noverpdf.le.25)
4994  & write(logfid,*)'WARNING in getxsecint: need to extrapolate: ',
4995  & tm,intq1(1000,101)
4996  endif
4997 
4998  tclose=int((log(tm)-log(intq1(1,101)))*999.d0/
4999  & (log(intq1(1000,101))-log(intq1(1,101)))+1)
5000  tline=max(tclose,1)
5001  tline=min(tline,999)
5002  mdclose=int((md-intq1(1001,1))*99.d0/
5003  &(intq1(1001,100)-intq1(1001,1))+1)
5004  mdline=max(mdclose,1)
5005  mdline=min(mdline,99)
5006  IF((tline.GT.999).OR.(mdline.GT.99)
5007  & .OR.(tline.LT.1).OR.(mdline.LT.1)) THEN
5008  write(logfid,*)'ERROR in GETXSECINT: line number out of bound',
5009  & tline,mdline
5010  ENDIF
5011 
5012  IF(typ2.EQ.'QA')THEN
5013 C--first quark integral
5014  DO 12 i=1,2
5015  x1a(i)=intq1(1001,mdline-1+i)
5016  x2a(i)=intq1(tline-1+i,101)
5017  DO 11 j=1,2
5018  ya(i,j)=intq1(tline-1+j,mdline-1+i)
5019  11 CONTINUE
5020  12 CONTINUE
5021  ELSEIF(typ2.EQ.'QB')THEN
5022 C--second quark integral
5023  DO 18 i=1,2
5024  x1a(i)=intq2(1001,mdline-1+i)
5025  x2a(i)=intq2(tline-1+i,101)
5026  DO 17 j=1,2
5027  ya(i,j)=intq2(tline-1+j,mdline-1+i)
5028  17 CONTINUE
5029  18 CONTINUE
5030  ELSEIF(typ2.EQ.'GA')THEN
5031 C--first gluon integral
5032  DO 14 i=1,2
5033  x1a(i)=intg1(1001,mdline-1+i)
5034  x2a(i)=intg1(tline-1+i,101)
5035  DO 13 j=1,2
5036  ya(i,j)=intg1(tline-1+j,mdline-1+i)
5037  13 CONTINUE
5038  14 CONTINUE
5039  ELSEIF(typ2.EQ.'GB')THEN
5040 C--second gluon integral
5041  DO 16 i=1,2
5042  x1a(i)=intg2(1001,mdline-1+i)
5043  x2a(i)=intg2(tline-1+i,101)
5044  DO 15 j=1,2
5045  ya(i,j)=intg2(tline-1+j,mdline-1+i)
5046  15 CONTINUE
5047  16 CONTINUE
5048  ELSE
5049  write(logfid,*)'error in GETXSECINT: unknown integral type ',
5050  & typ2
5051  ENDIF
5052  DO 19 i=1,2
5053  a=(ya(i,2)-ya(i,1))/(x2a(2)-x2a(1))
5054  b=ya(i,1)-a*x2a(1)
5055  yb(i)=a*tm+b
5056  19 CONTINUE
5057  IF(x1a(1).EQ.x1a(2))THEN
5058  y=yb(1)
5059  ELSE
5060  a=(yb(2)-yb(1))/(x1a(2)-x1a(1))
5061  b=yb(1)-a*x1a(1)
5062  y=a*md+b
5063  ENDIF
5064  getxsecint=y
5065  END
5066 
5067 
5068 ***********************************************************************
5069 *** function getinsudafast
5070 ***********************************************************************
5071  DOUBLE PRECISION FUNCTION getinsudafast(Q1,Q2,TYP)
5072  IMPLICIT NONE
5073 C--identifier of file for hepmc output and logfile
5074  common/hepmcid/hpmcfid,logfid
5075  integer hpmcfid,logfid
5076 C--Parameter common block
5077  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5078  &allhad,compress,nf
5079  INTEGER nf
5080  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5081  LOGICAL angord,scatrecoil,allhad,compress
5082 C--local variables
5083  DOUBLE PRECISION q1,q2,getinsudared
5084  CHARACTER*2 typ
5085 
5086  IF(q2.LE.q1)THEN
5087  getinsudafast=1.d0
5088  ELSEIF(q1.LE.q0)THEN
5089  getinsudafast=getinsudared(q2,typ)
5090  ELSE
5091  getinsudafast=getinsudared(q2,typ)/getinsudared(q1,typ)
5092  ENDIF
5093  IF(getinsudafast.GT.1.d0) getinsudafast=1.d0
5094  IF(getinsudafast.LT.(-1.d-10))THEN
5095  write(logfid,*)'ERROR: GETINSUDAFAST < 0:',
5096  & getinsudafast,' for',q1,' ',q2,' ',typ
5097  ENDIF
5098  if (getinsudafast.lt.0.d0) getinsudafast = 0.d0
5099  END
5100 
5101 
5102 ***********************************************************************
5103 *** function getinsudared
5104 ***********************************************************************
5105  DOUBLE PRECISION FUNCTION getinsudared(Q,TYP2)
5106  IMPLICIT NONE
5107 C--identifier of file for hepmc output and logfile
5108  common/hepmcid/hpmcfid,logfid
5109  integer hpmcfid,logfid
5110 C--Parameter common block
5111  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5112  &allhad,compress,nf
5113  INTEGER nf
5114  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5115  LOGICAL angord,scatrecoil,allhad,compress
5116 C--Sudakov common block
5117  common/insuda/sudaqq(1000,2),sudaqg(1000,2),sudagg(1000,2),
5118  &sudagc(1000,2)
5119  DOUBLE PRECISION sudaqq,sudaqg,sudagg,sudagc
5120 C--number of extrapolations in tables
5121  common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
5122  &ntotxsec,noverxsec,ntotsuda,noversuda
5123  integer ntotspliti,noverspliti,ntotpdf,noverpdf,
5124  &ntotxsec,noverxsec,ntotsuda,noversuda
5125 C--local variables
5126  INTEGER qclose,qbin,i
5127  DOUBLE PRECISION q,xa(2),ya(2),y,a,b
5128  CHARACTER*2 typ2
5129 
5130  ntotsuda=ntotsuda+1
5131  if (q.gt.sudaqq(1000,1)) then
5132  noversuda=noversuda+1
5133  if (noversuda.le.25)
5134  & write(logfid,*)'WARNING in getinsudared: need to extrapolate: ',
5135  & q,sudaqq(1000,1)
5136  endif
5137 
5138  qclose=int((log(q)-log(sudaqq(1,1)))*999.d0
5139  & /(log(sudaqq(1000,1))-log(sudaqq(1,1)))+1)
5140  qbin=max(qclose,1)
5141  qbin=min(qbin,999)
5142  IF((qbin.GT.999).OR.(qbin.LT.1)) THEN
5143  write(logfid,*)
5144  & 'ERROR in GETINSUDARED: line number out of bound',qbin
5145  ENDIF
5146  IF(typ2.EQ.'QQ')THEN
5147  DO 16 i=1,2
5148  xa(i)=sudaqq(qbin-1+i,1)
5149  ya(i)=sudaqq(qbin-1+i,2)
5150  16 CONTINUE
5151  ELSEIF(typ2.EQ.'QG')THEN
5152  DO 17 i=1,2
5153  xa(i)=sudaqg(qbin-1+i,1)
5154  ya(i)=sudaqg(qbin-1+i,2)
5155  17 CONTINUE
5156  ELSEIF(typ2.EQ.'GG')THEN
5157  DO 18 i=1,2
5158  xa(i)=sudagg(qbin-1+i,1)
5159  ya(i)=sudagg(qbin-1+i,2)
5160  18 CONTINUE
5161  ELSEIF(typ2.EQ.'GC')THEN
5162  DO 19 i=1,2
5163  xa(i)=sudagc(qbin-1+i,1)
5164  ya(i)=sudagc(qbin-1+i,2)
5165  19 CONTINUE
5166  ELSE
5167  write(logfid,*)'error in GETINSUDARED: unknown type ',typ2
5168  ENDIF
5169  a=(ya(2)-ya(1))/(xa(2)-xa(1))
5170  b=ya(1)-a*xa(1)
5171  y=a*q+b
5172  getinsudared=y
5173  IF(getinsudared.LT.(-1.d-10))THEN
5174  write(logfid,*) 'ERROR: GETINSUDARED < 0:',getinsudared,q,typ2
5175  ENDIF
5176  if (getinsudared.lt.0.d0) getinsudared = 0.d0
5177  END
5178 
5179 
5180 ***********************************************************************
5181 *** function getsscat
5182 ***********************************************************************
5183  DOUBLE PRECISION FUNCTION getsscat(EN,px,py,PZ,MP,LW,TYPE1,TYPE2,
5184  & x,y,z,t,mode)
5185  IMPLICIT NONE
5186 C--identifier of file for hepmc output and logfile
5187  common/hepmcid/hpmcfid,logfid
5188  integer hpmcfid,logfid
5189 C--Parameter common block
5190  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5191  &allhad,compress,nf
5192  INTEGER nf
5193  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5194  LOGICAL angord,scatrecoil,allhad,compress
5195 C--variables for cross section integration
5196  common/xsecv/qlow,mdx
5197  DOUBLE PRECISION qlow,mdx
5198 C--local variables
5199  integer mode
5200  DOUBLE PRECISION up,en,lw,scatprimfunc,ccol,mp,
5201  &low,getpdfxint,getxsecint,mdeb,pz,pcms2,shat,gettemp,
5202  &x,y,z,t,getmd,avmom(5),px,py,getmdmin,getmdmax,pproj,psct
5203  CHARACTER type1,type2
5204 
5205  IF(type1.EQ.'Q')THEN
5206  ccol=2./3.
5207  ELSE
5208  ccol=3./2.
5209  ENDIF
5210  if (mode.eq.0) then
5211  mdeb = getmd(x,y,z,t)
5212  call avscatcen(x,y,z,t,
5213  & avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
5214  shat = avmom(5)**2 + mp**2 +
5215  & 2.*(avmom(4)*en - avmom(1)*px - avmom(2)*py - avmom(3)*pz)
5216  pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
5217  up = 4.*pcms2
5218  else
5219  if (mode.eq.1) then
5220  mdeb = getmdmin()
5221  else
5222  mdeb = getmdmax()
5223  endif
5224  call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
5225  psct = sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)
5226  pproj = sqrt(px**2+py**2+pz**2)
5227  shat = avmom(5)**2 + mp**2 + 2.*(en*avmom(4) + pproj*psct)
5228  pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2
5229  up = 4.*pcms2
5230  endif
5231  low=lw**2
5232  IF(low.GT.up)THEN
5233  getsscat=0.d0
5234  RETURN
5235  ENDIF
5236  IF((type2.EQ.'C').OR.
5237  & ((type1.EQ.'Q').AND.(type2.EQ.'Q')).OR.
5238  & ((type1.EQ.'G').AND.(type2.EQ.'G')))THEN
5239  getsscat=ccol*(scatprimfunc(up,mdeb)-scatprimfunc(low,mdeb))
5240  ELSE
5241  getsscat=0.d0
5242  ENDIF
5243  low=q0**2/scalefacm**2
5244  IF(up.GT.low)THEN
5245  IF(type1.EQ.'Q')THEN
5246  IF((type2.EQ.'C').OR.(type2.EQ.'G'))THEN
5247  getsscat=getsscat+getpdfxint(scalefacm*sqrt(up),'GQ')
5248  & *3.*scatprimfunc(up,mdeb)/2.
5249  getsscat=getsscat-getxsecint(up,mdeb,'QA')
5250  ENDIF
5251  ELSE
5252  IF((type2.EQ.'C').OR.(type2.EQ.'G'))THEN
5253  getsscat=getsscat+ccol*(scatprimfunc(up,mdeb)-
5254  & scatprimfunc(low,mdeb))
5255  & - getxsecint(up,mdeb,'GB')
5256  ENDIF
5257  IF((type2.EQ.'C').OR.(type2.EQ.'Q'))THEN
5258  getsscat=getsscat+2.*getpdfxint(scalefacm*sqrt(up),'QG')
5259  & *2.*scatprimfunc(up,mdeb)/3.
5260  getsscat=getsscat-2.*getxsecint(up,mdeb,'GA')
5261  ENDIF
5262  ENDIF
5263  ENDIF
5264  IF(getsscat.LT.-1.d-4)
5265  & write(logfid,*) 'error: cross section < 0',getsscat,'for',
5266  & en,mp,lw,type1,type2,lw**2,up
5267  getsscat=max(getsscat,0.d0)
5268  END
5269 
5270 
5271 
5272 ***********************************************************************
5273 *** function getmass
5274 ***********************************************************************
5275  DOUBLE PRECISION FUNCTION getmass(QBMIN,QBMAX,THETA,EP,TYPE,
5276  & max2,ins,zdec,qqbardec)
5277  IMPLICIT NONE
5278 C--identifier of file for hepmc output and logfile
5279  common/hepmcid/hpmcfid,logfid
5280  integer hpmcfid,logfid
5281 C--Common block of Pythia
5282  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
5283  INTEGER n,npad,k
5284  DOUBLE PRECISION p,v
5285  common/pydat1/mstu(200),paru(200),mstj(200),parj(200)
5286  INTEGER mstu,mstj
5287  DOUBLE PRECISION paru,parj
5288  common/pydat3/mdcy(500,3),mdme(8000,2),brat(8000),kfdp(8000,5)
5289  INTEGER mdcy,mdme,kfdp
5290  DOUBLE PRECISION brat
5291 C--Parameter common block
5292  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5293  &allhad,compress,nf
5294  INTEGER nf
5295  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5296  LOGICAL angord,scatrecoil,allhad,compress
5297 C--time common block
5298  common/time/mv(23000,5)
5299  DOUBLE PRECISION mv
5300 C--factor in front of alphas argument
5301  common/alphasfac/ptfac
5302  DOUBLE PRECISION ptfac
5303 C--local variables
5304  DOUBLE PRECISION qbmin,qbmax,theta,ep,max2,zdec,
5305  &q2min,alphmax,alphas,log14,pref,q2max,sudaover,gmin,
5306  &gmax,arg,cand,eps,trueeps,trueval,oest,weight,getinspliti,
5307  &r,pyr,z,rz,thetanew,r2,pi,pqq,pgg,pqg,rmin
5308  CHARACTER*2 type
5309  LOGICAL ins,qqbardec
5310  DATA pi/3.141592653589793d0/
5311 
5312  q2min = q0**2
5313 
5314  alphmax = alphas(3.*ptfac*q2min/16.,lps)
5315  log14 = log(0.25)
5316 
5317  IF(type.EQ.'QQ')THEN
5318  pref=4.*alphmax/(3.*2.*pi)
5319  ELSE
5320  pref=29.*alphmax/(8.*2.*pi)
5321  ENDIF
5322 
5323 C--check if phase space available, return 0.d0 otherwise
5324  IF((qbmax.LE.qbmin).OR.(ep.LT.qbmin)) THEN
5325  getmass=0.d0
5326  zdec=0.d0
5327  qqbardec=.false.
5328  RETURN
5329  ENDIF
5330 
5331  q2max = qbmax**2
5332 ! 21 sudaover = exp(-pref*(log(q2min/(4.*q2max))**2 - log14**2))
5333 ! IF(pyr(0).LE.sudaover)THEN
5334  21 if (q2max-qbmin**2.lt.1e-4)then
5335  getmass=qbmin
5336  zdec=0.5
5337  IF(type.EQ.'QQ')THEN
5338  qqbardec=.false.
5339  ELSE
5340  IF(pyr(0).LT.pqg(0.5d0)/(pqg(0.5d0)+pgg(0.5d0)))THEN
5341  qqbardec=.true.
5342  ELSE
5343  qqbardec=.false.
5344  ENDIF
5345  endif
5346  return
5347  endif
5348  gmax = pref*log(q2min/(4.*q2max))**2
5349  if (qbmin.gt.0.d0) then
5350  rmin = exp(pref*log(q2min/(4.*qbmin**2))**2-gmax)
5351  else
5352  rmin = 0.d0
5353  endif
5354 
5355  r=pyr(0)*(1.d0-rmin)+rmin
5356  arg=gmax+log(r)
5357  if(arg.lt.0.d0)then
5358  getmass=0.d0
5359  zdec=0.d0
5360  qqbardec=.false.
5361  RETURN
5362  endif
5363 ! r=pyr(0)
5364 ! gmin = pref*log14**2
5365 ! gmax = pref*log(q2min/(4.*q2max))**2
5366 ! arg = log(r*exp(gmax)+(1.-r)*exp(gmin))
5367  cand = q2min*exp(sqrt(arg/pref))/4.
5368  eps = q2min/(4.*cand)
5369 
5370  if ((cand.lt.q2min).or.(cand.lt.qbmin**2)) then
5371  getmass=0.d0
5372  zdec=0.d0
5373  qqbardec=.false.
5374  RETURN
5375  endif
5376 
5377  IF((cand.GT.max2**2).OR.(cand.GT.ep**2))THEN
5378  q2max=cand
5379  goto 21
5380  ENDIF
5381 
5382  if (ins) then
5383  trueval=getinspliti(sqrt(cand),type)
5384  oest = -2.*pref*log(eps)
5385  weight = trueval/oest
5386  else
5387 C--find true z interval
5388  trueeps=0.5-0.5*sqrt(1.-q2min/cand)
5389  & *sqrt(1.-cand/ep**2)
5390  IF(trueeps.LT.eps)
5391  & WRITE(logfid,*)'error in getmass: true eps < eps',trueeps,eps
5392  rz=pyr(0)
5393  z = 1.-eps**rz
5394  if ((z.lt.trueeps).or.(z.gt.(1.-trueeps))) then
5395  weight = 0.
5396  else
5397  if (type.eq.'QQ')then
5398 ! if (ins) then
5399 ! trueval = alphas(ptfac*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
5400 ! else
5401  trueval = alphas(ptfac*z*(1.-z)*cand,lps)*pqq(z)/(2.*pi)
5402 ! endif
5403  oest = 2.*pref/(1.-z)
5404  weight = trueval/oest
5405  else
5406  if (pyr(0).lt.(17./29.)) z = 1.-z
5407 ! if (ins)then
5408 ! trueval = alphas(ptfac*(1.-z)*cand,lps)
5409 ! & *(pgg(z)+pqg(z))/(2.*pi)
5410 ! else
5411  trueval = alphas(ptfac*z*(1.-z)*cand,lps)
5412  & *(pgg(z)+pqg(z))/(2.*pi)
5413 ! endif
5414  oest = alphmax*(17./(4.*z)+3./(1.-z))/(2.*pi)
5415  weight = trueval/oest
5416  endif
5417  thetanew = sqrt(cand/(z*(1.-z)))/ep
5418  if (angord.and.(theta.gt.0.).and.(thetanew.gt.theta))
5419  & weight = 0.d0
5420  endif
5421  endif
5422  IF (weight.GT.1.d0) WRITE(logfid,*)
5423  & 'problem in getmass: weight> 1',
5424  & weight,type,eps,trueeps,z,cand
5425  r2=pyr(0)
5426  IF(r2.GT.weight)THEN
5427  q2max=cand
5428  goto 21
5429  ELSE
5430  getmass=sqrt(cand)
5431  if (.not.ins) then
5432  zdec=z
5433  IF(type.EQ.'QQ')THEN
5434  qqbardec=.false.
5435  ELSE
5436  IF(pyr(0).LT.pqg(z)/(pqg(z)+pgg(z)))THEN
5437  qqbardec=.true.
5438  ELSE
5439  qqbardec=.false.
5440  ENDIF
5441  ENDIF
5442  endif
5443  ENDIF
5444  END
5445 
5446 
5447 
5448 ***********************************************************************
5449 *** function generatez
5450 ***********************************************************************
5451  DOUBLE PRECISION FUNCTION generatez(TI,EA,EPSI,TYPE)
5452  IMPLICIT NONE
5453 C--Parameter common block
5454  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5455  &allhad,compress,nf
5456  INTEGER nf
5457  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5458  LOGICAL angord,scatrecoil,allhad,compress
5459 C--local variables
5460  DOUBLE PRECISION ti,ea,eps,pyr,x,r,help,r1,epsi
5461  CHARACTER*2 type
5462 
5463  IF(ti.EQ.0.d0)THEN
5464  eps=epsi
5465  ELSE
5466  eps=max(0.5-0.5*sqrt(1.-q0**2/ti)
5467  & *sqrt(1.-ti/ea**2),epsi)
5468  ENDIF
5469  IF(eps.GT.0.5)THEN
5470  generatez=0.5
5471  goto 61
5472  ENDIF
5473  60 r=pyr(0)
5474  IF(type.EQ.'QQ')THEN
5475  x=1.-(1.-eps)*(eps/(1.-eps))**r
5476  r=pyr(0)
5477  IF(r.LT.((1.+x**2)/2.))THEN
5478  generatez=x
5479  ELSE
5480  goto 60
5481  ENDIF
5482  ELSEIF(type.EQ.'GG')THEN
5483  x=1./(1.+((1.-eps)/eps)**(1.-2.*r))
5484  r=pyr(0)
5485  help=((1.-x)/x+x/(1.-x)+x*(1.-x))/(1./(1.-x)+1./x)
5486  IF(r.LT.help)THEN
5487  generatez=x
5488  ELSE
5489  goto 60
5490  ENDIF
5491  ELSE
5492  r=pyr(0)*(1.-2.*eps)+eps
5493  r1=pyr(0)/2.
5494  help=0.5*(r**2+(1.-r)**2)
5495  IF(r1.LT.help)THEN
5496  generatez=r
5497  ELSE
5498  goto 60
5499  ENDIF
5500  ENDIF
5501  61 END
5502 
5503 
5504 
5505 ***********************************************************************
5506 *** function scatprimfunc
5507 ***********************************************************************
5508  DOUBLE PRECISION FUNCTION scatprimfunc(T,MDEB)
5509  IMPLICIT NONE
5510 C--Parameter common block
5511  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5512  &allhad,compress,nf
5513  INTEGER nf
5514  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5515  LOGICAL angord,scatrecoil,allhad,compress
5516 C--local variables
5517  DOUBLE PRECISION t,pi,s,ei,alphas,t1,mdeb
5518  DATA pi/3.141592653589793d0/
5519 
5520  scatprimfunc = 2.*pi*(12.*pi)**2*(
5521  & - ei(-log((t+mdeb**2)/lqcd**2))/lqcd**2
5522  & - 1./((t+mdeb**2)*log((t+mdeb**2)/lqcd**2)))/(33.-2.*nf)**2
5523  END
5524 
5525 
5526 
5527 ***********************************************************************
5528 *** function intpqq
5529 ***********************************************************************
5530  DOUBLE PRECISION FUNCTION intpqq(Z,Q)
5531  IMPLICIT NONE
5532 C--Parameter common block
5533  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5534  &allhad,compress,nf
5535  INTEGER nf
5536  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5537  LOGICAL angord,scatrecoil,allhad,compress
5538 C--local variables
5539  DOUBLE PRECISION z,q
5540 
5541  intpqq=6.*4.*(-2.*log(log(q**2/lps**2)
5542  & +log(1.-z)))/((33.-2.*nf)*3.)
5543  END
5544 
5545 
5546 
5547 ***********************************************************************
5548 *** function intpgglow
5549 ***********************************************************************
5550  DOUBLE PRECISION FUNCTION intpgglow(Z,Q)
5551  IMPLICIT NONE
5552 C--Parameter common block
5553  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5554  &allhad,compress,nf
5555  INTEGER nf
5556  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5557  LOGICAL angord,scatrecoil,allhad,compress
5558 C--local variables
5559  DOUBLE PRECISION z,q
5560 
5561  intpgglow=6.*3.*(log(log(q**2/lps**2)+log(z)))/(33.-2.*nf)
5562  END
5563 
5564 
5565 
5566 ***********************************************************************
5567 *** function intpgghigh
5568 ***********************************************************************
5569  DOUBLE PRECISION FUNCTION intpgghigh(Z,Q)
5570  IMPLICIT NONE
5571 C--Parameter common block
5572  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5573  &allhad,compress,nf
5574  INTEGER nf
5575  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5576  LOGICAL angord,scatrecoil,allhad,compress
5577 C--local variables
5578  DOUBLE PRECISION z,q
5579 
5580  intpgghigh=-6.*3.*(log(log(q**2/lps**2)+log(1.-z)))/(33.-2.*nf)
5581  END
5582 
5583 
5584 
5585 ***********************************************************************
5586 *** function intpqglow
5587 ***********************************************************************
5588  DOUBLE PRECISION FUNCTION intpqglow(Z,Q)
5589  IMPLICIT NONE
5590 C--Parameter common block
5591  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5592  &allhad,compress,nf
5593  INTEGER nf
5594  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5595  LOGICAL angord,scatrecoil,allhad,compress
5596 C--local variables
5597  DOUBLE PRECISION z,q,ei
5598 
5599  intpqglow=6.*(lps**2*ei(log(q**2/lps**2)+log(z))/q**2
5600  & - 2.*lps**4*ei(2.*(log(q**2/lps**2)+log(z)))/q**4
5601  & + 2.*lps**6*ei(3.*(log(q**2/lps**2)+log(z)))/q**6)/
5602  &((33.-2.*nf)*2.)
5603  END
5604 
5605 
5606 
5607 ***********************************************************************
5608 *** function intpqghigh
5609 ***********************************************************************
5610  DOUBLE PRECISION FUNCTION intpqghigh(Z,Q)
5611  IMPLICIT NONE
5612 C--Parameter common block
5613  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5614  &allhad,compress,nf
5615  INTEGER nf
5616  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5617  LOGICAL angord,scatrecoil,allhad,compress
5618 C--local variables
5619  DOUBLE PRECISION z,q,ei
5620 
5621  intpqghigh=-6.*(lps**2*ei(log(q**2/lps**2)+log(1.-z))/q**2
5622  & - 2.*lps**4*ei(2.*(log(q**2/lps**2)+log(1.-z)))/q**4
5623  & + 2.*lps**6*ei(3.*(log(q**2/lps**2)+log(1.-z)))/q**6)/
5624  &((33.-2.*nf)*2.)
5625  END
5626 
5627 
5628 
5629 ***********************************************************************
5630 *** function gett
5631 ***********************************************************************
5632  DOUBLE PRECISION FUNCTION gett(MINT,MAXT,MDEB)
5633  IMPLICIT NONE
5634 C--Parameter common block
5635  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5636  &allhad,compress,nf
5637  INTEGER nf
5638  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5639  LOGICAL angord,scatrecoil,allhad,compress
5640 C--local variables
5641  DOUBLE PRECISION tmin,tmax,maxi,pyr,r1,r2,alphas,pi,y,maxt,
5642  &mdeb,mint,t
5643  DATA pi/3.141592653589793d0/
5644 
5645  tmax=maxt+mdeb**2
5646  tmin=mint+mdeb**2
5647  IF(tmin.GT.tmax) THEN
5648  gett=0.d0
5649  RETURN
5650  ENDIF
5651  20 r1=pyr(0)
5652  t=tmax*tmin/(tmax+r1*(tmin-tmax))
5653  r2=pyr(0)
5654  IF(r2.LT.alphas(t,lqcd)**2/alphas(tmin,lqcd)**2)THEN
5655  gett=t-mdeb**2
5656  ELSE
5657  goto 20
5658  ENDIF
5659 
5660  END
5661 
5662 
5663 
5664 ***********************************************************************
5665 *** function ei
5666 ***********************************************************************
5667  DOUBLE PRECISION FUNCTION ei(X)
5668  IMPLICIT NONE
5669 C--identifier of file for hepmc output and logfile
5670  common/hepmcid/hpmcfid,logfid
5671  integer hpmcfid,logfid
5672 C--exponential integral for negative arguments
5673  common/expint/eixs(3,1000),valmax,nval
5674  INTEGER nval
5675  DOUBLE PRECISION eixs,valmax
5676 C--local variables
5677  INTEGER k,line,lmax
5678  DOUBLE PRECISION x,r,ga,xa(2),ya(2),y,dy,a,b
5679  DOUBLE PRECISION ystart,epsi,hfirst
5680  DATA epsi/1.e-5/
5681 
5682  IF(dabs(x).GT.valmax)
5683  & write(logfid,*)'warning: value out of array in Ei(x)',x,valmax
5684 
5685  IF(x.GE.0.d0)THEN
5686  lmax=int(x*nval/valmax)
5687  line=max(lmax,1)
5688  line=min(line,999)
5689  IF((line.GT.999).OR.(line.LT.1)) THEN
5690  write(logfid,*)'ERROR in EI: line number out of bound',line
5691  ENDIF
5692  DO 26 k=1,2
5693  xa(k)=eixs(1,line-1+k)
5694  ya(k)=eixs(3,line-1+k)
5695  26 CONTINUE
5696  a=(ya(2)-ya(1))/(xa(2)-xa(1))
5697  b=ya(1)-a*xa(1)
5698  y=a*x+b
5699  ELSE
5700  lmax=int(-x*nval/valmax)
5701  line=max(lmax,1)
5702  line=min(line,999)
5703  IF((line.GT.999).OR.(line.LT.1)) THEN
5704  write(logfid,*)'ERROR in EI: line number out of bound',line
5705  ENDIF
5706  DO 27 k=1,2
5707  xa(k)=eixs(1,line-1+k)
5708  ya(k)=eixs(2,line-1+k)
5709  27 CONTINUE
5710  a=(ya(2)-ya(1))/(xa(2)-xa(1))
5711  b=ya(1)-a*xa(1)
5712  y=-a*x+b
5713  ENDIF
5714  ei=y
5715  END
5716 
5717 
5718 
5719 ***********************************************************************
5720 *** function pqq
5721 ***********************************************************************
5722  DOUBLE PRECISION FUNCTION pqq(Z)
5723  IMPLICIT NONE
5724  DOUBLE PRECISION z
5725  pqq=4.*(1.+z**2)/(3.*(1.-z))
5726  END
5727 
5728 
5729 
5730 ***********************************************************************
5731 *** function pgq
5732 ***********************************************************************
5733  DOUBLE PRECISION FUNCTION pgq(Z)
5734  IMPLICIT NONE
5735  DOUBLE PRECISION z
5736  pgq=4.*(1.+(1.-z)**2)/(3.*z)
5737  END
5738 
5739 
5740 
5741 ***********************************************************************
5742 *** function pgg
5743 ***********************************************************************
5744  DOUBLE PRECISION FUNCTION pgg(Z)
5745  IMPLICIT NONE
5746  DOUBLE PRECISION z
5747  pgg=3.*((1.-z)/z + z/(1.-z) + z*(1.-z))
5748  END
5749 
5750 
5751 
5752 ***********************************************************************
5753 *** function pqg
5754 ***********************************************************************
5755  DOUBLE PRECISION FUNCTION pqg(Z)
5756  IMPLICIT NONE
5757  DOUBLE PRECISION z
5758  pqg=0.5*(z**2 + (1.-z)**2)
5759  END
5760 
5761 
5762 
5763 ***********************************************************************
5764 *** function alphas
5765 ***********************************************************************
5766  DOUBLE PRECISION FUNCTION alphas(T,LAMBDA)
5767  IMPLICIT NONE
5768 C--Parameter common block
5769  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5770  &allhad,compress,nf
5771  INTEGER nf
5772  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5773  LOGICAL angord,scatrecoil,allhad,compress
5774 C--local variables
5775  DOUBLE PRECISION t,l0,pi,lambda
5776  DATA pi/3.141592653589793d0/
5777 
5778  alphas=4.*pi/((11.-2.*nf/3.)*log(t/lambda**2))
5779  END
5780 
5781 
5782 
5783 ***********************************************************************
5784 *** subroutine splitfncint
5785 ***********************************************************************
5786  SUBROUTINE splitfncint(EMAX)
5787  IMPLICIT NONE
5788 C--Parameter common block
5789  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5790  &allhad,compress,nf
5791  INTEGER nf
5792  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5793  LOGICAL angord,scatrecoil,allhad,compress
5794 C--splitting integral
5795  common/splitint/splitiggv(1000,1000),splitiqqv(1000,1000),
5796  &splitiqgv(1000,1000),qval(1000),zmval(1000),qmax,zmmin,npoint
5797  INTEGER npoint
5798  DOUBLE PRECISION splitiggv,splitiqqv,splitiqgv,
5799  &qval,zmval,qmax,zmmin
5800 C--variables for splitting function integration
5801  common/intsplitf/qquad,fm
5802  DOUBLE PRECISION qquad,fm
5803 C--max rapidity
5804  common/rapmax/etamax
5805  double precision etamax
5806 C--local variables
5807  INTEGER nstep,i,j
5808  DOUBLE PRECISION emax,zmmax,epsi,hfirst,ystart,lnzmmin,
5809  &lnzmmax,zm,zm2,q,getmsmax,avmom(5),shat,pcms2
5810  DATA zmmax/0.5/
5811  DATA nstep/999/
5812  DATA epsi/1.d-5/
5813 
5814  call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
5815  shat = avmom(5)**2 +
5816  & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
5817  pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
5818  qmax = sqrt(scalefacm*4.*pcms2)
5819 
5820  zmmin=q0/emax
5821 
5822  lnzmmin=log(zmmin)
5823  lnzmmax=log(zmmax)
5824 
5825  npoint=nstep
5826 
5827  DO 100 i=1,nstep+1
5828  q=(i-1)*(qmax-q0)/nstep+q0
5829  qval(i)=q
5830  qquad=q**2
5831  DO 110 j=1,nstep+1
5832  zm=exp((j-1)*(lnzmmax-lnzmmin)/nstep+lnzmmin)
5833  zmval(j)=zm
5834  IF(q**2.LT.q0**2)THEN
5835  zm2=0.5
5836  ELSE
5837  zm2=0.5-0.5*sqrt(1.-q0**2/q**2)
5838  ENDIF
5839  zm=max(zm,zm2)
5840  IF(zm.EQ.0.5)THEN
5841  splitiqqv(i,j)=0.d0
5842  splitiggv(i,j)=0.d0
5843  splitiqgv(i,j)=0.d0
5844  ELSE
5845  ystart=0d0
5846  hfirst=0.01
5847  fm=0.d0
5848  CALL odeint(ystart,zm,1.-zm,epsi,hfirst,0d0,2)
5849  splitiqqv(i,j)=ystart
5850  ystart=0d0
5851  hfirst=0.01
5852  fm=0.d0
5853  CALL odeint(ystart,zm,1.-zm,epsi,hfirst,0d0,3)
5854  splitiggv(i,j)=ystart
5855  ystart=0d0
5856  hfirst=0.01
5857  fm=0.d0
5858  CALL odeint(ystart,zm,1.-zm,epsi,hfirst,0d0,4)
5859  splitiqgv(i,j)=ystart
5860  ENDIF
5861  110 CONTINUE
5862  100 CONTINUE
5863 
5864  END
5865 
5866 
5867 
5868 ***********************************************************************
5869 *** subroutine pdfint
5870 ***********************************************************************
5871  SUBROUTINE pdfint(EMAX)
5872  IMPLICIT NONE
5873 C--Parameter common block
5874  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5875  &allhad,compress,nf
5876  INTEGER nf
5877  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5878  LOGICAL angord,scatrecoil,allhad,compress
5879 C--pdf common block
5880  common/pdfs/qinqx(2,1000),ginqx(2,1000),qingx(2,1000),
5881  &gingx(2,1000)
5882  DOUBLE PRECISION qinqx,ginqx,qingx,gingx
5883 C--variables for pdf integration
5884  common/pdfintv/xmax,z
5885  DOUBLE PRECISION xmax,z
5886 C--max rapidity
5887  common/rapmax/etamax
5888  double precision etamax
5889 C--local variables
5890  INTEGER i,j
5891  DOUBLE PRECISION emax,q2,getpdfxintexact,ystart,hfirst,epsi,
5892  &q2max,deltaq2,avmom(5),shat,pcms2
5893  DATA epsi/1.d-4/
5894 
5895  call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
5896  shat = avmom(5)**2 +
5897  & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
5898  pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
5899  q2max = scalefacm*4.*pcms2
5900 
5901  deltaq2=log(q2max)-log(q0**2)
5902  qinqx(1,1)=q0**2
5903  ginqx(1,1)=q0**2
5904  qingx(1,1)=q0**2
5905  gingx(1,1)=q0**2
5906  qinqx(2,1)=0.d0
5907  ginqx(2,1)=0.d0
5908  qingx(2,1)=0.d0
5909  gingx(2,1)=0.d0
5910  DO 12 j=2,1000
5911  q2 = exp((j-1)*deltaq2/999.d0 + log(q0**2))
5912  qinqx(1,j)=q2
5913  ginqx(1,j)=q2
5914  qingx(1,j)=q2
5915  gingx(1,j)=q2
5916  qinqx(2,j)=getpdfxintexact(sqrt(q2),'QQ')
5917  ginqx(2,j)=getpdfxintexact(sqrt(q2),'GQ')
5918  qingx(2,j)=getpdfxintexact(sqrt(q2),'QG')
5919  gingx(2,j)=getpdfxintexact(sqrt(q2),'GG')
5920  12 CONTINUE
5921  END
5922 
5923 
5924 
5925 ***********************************************************************
5926 *** subroutine xsecint
5927 ***********************************************************************
5928  SUBROUTINE xsecint(EMAX)
5929  IMPLICIT NONE
5930 C--Parameter common block
5931  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
5932  &allhad,compress,nf
5933  INTEGER nf
5934  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
5935  LOGICAL angord,scatrecoil,allhad,compress
5936 C--cross secttion common block
5937  common/xsecs/intq1(1001,101),intq2(1001,101),
5938  &intg1(1001,101),intg2(1001,101)
5939  DOUBLE PRECISION intq1,intq2,intg1,intg2
5940 C--variables for cross section integration
5941  common/xsecv/qlow,mdx
5942  DOUBLE PRECISION qlow,mdx
5943 C--max rapidity
5944  common/rapmax/etamax
5945  double precision etamax
5946 C--local variables
5947  INTEGER j,k
5948  DOUBLE PRECISION emax,tmax,tmaxmax,deltatmax,ystart,hfirst,epsi,
5949  &getmsmax,getmdmax,mdmin,mdmax,deltamd,getmdmin,avmom(5),shat,pcms2
5950  DATA epsi/1.d-4/
5951 
5952  call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
5953  shat = avmom(5)**2 +
5954  & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
5955  pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
5956  tmaxmax = scalefacm*4.*pcms2
5957  deltatmax=(log(tmaxmax)-
5958  & log(q0**2*(1.d0+1.d-6)/scalefacm**2))/999.d0
5959  mdmin=getmdmin()
5960  mdmax=max(mdmin,getmdmax())
5961  deltamd=(mdmax-mdmin)/99.d0
5962 
5963  DO 12 j=1,1000
5964  tmax = exp((j-1)*deltatmax
5965  & + log(q0**2*(1.d0+1.d-6)/scalefacm**2))
5966  intq1(j,101)=tmax
5967  intq2(j,101)=tmax
5968  intg1(j,101)=tmax
5969  intg2(j,101)=tmax
5970  DO 13 k=1,100
5971  mdx=mdmin+(k-1)*deltamd
5972  intq1(1001,k)=mdx
5973  intq2(1001,k)=mdx
5974  intg1(1001,k)=mdx
5975  intg2(1001,k)=mdx
5976  IF(tmax.LT.q0**2/scalefacm**2)THEN
5977  intq1(j,k)=0.d0
5978  intq2(j,k)=0.d0
5979  intg1(j,k)=0.d0
5980  intg2(j,k)=0.d0
5981  ELSE
5982 C--first quark integral
5983  qlow=q0
5984  hfirst=0.01*(tmax-q0**2/scalefacm**2)
5985  ystart=0.d0
5986  CALL odeint(ystart,q0**2/scalefacm**2,tmax,epsi,hfirst
5987  & ,0.d0,11)
5988  intq1(j,k)=ystart
5989 C--second quark integral
5990  qlow=q0
5991  hfirst=0.01*(tmax-q0**2/scalefacm**2)
5992  ystart=0.d0
5993  CALL odeint(ystart,q0**2/scalefacm**2,tmax,epsi,hfirst
5994  & ,0.d0,14)
5995  intq2(j,k)=ystart
5996 C--first gluon integral
5997  qlow=q0
5998  ystart=0.d0
5999  CALL odeint(ystart,q0**2/scalefacm**2,tmax,epsi,hfirst
6000  & ,0.d0,12)
6001  intg1(j,k)=ystart
6002 C--second gluon integral
6003  qlow=q0
6004  ystart=0.d0
6005  CALL odeint(ystart,q0**2/scalefacm**2,tmax,epsi,hfirst
6006  & ,0.d0,13)
6007  intg2(j,k)=ystart
6008  ENDIF
6009  13 CONTINUE
6010  12 CONTINUE
6011  END
6012 
6013 
6014 
6015 ***********************************************************************
6016 *** function insudaint
6017 ***********************************************************************
6018  SUBROUTINE insudaint(EMAX)
6019  IMPLICIT NONE
6020 C--Parameter common block
6021  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
6022  &allhad,compress,nf
6023  INTEGER nf
6024  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
6025  LOGICAL angord,scatrecoil,allhad,compress
6026 C--Sudakov common block
6027  common/insuda/sudaqq(1000,2),sudaqg(1000,2),sudagg(1000,2),
6028  &sudagc(1000,2)
6029  DOUBLE PRECISION sudaqq,sudaqg,sudagg,sudagc
6030 C--max rapidity
6031  common/rapmax/etamax
6032  double precision etamax
6033 C--local variables
6034  INTEGER i
6035  DOUBLE PRECISION qmax,q,getinsudakov,delta,emax,avmom(5),
6036  &shat,pcms2
6037 
6038  call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5))
6039  shat = avmom(5)**2 +
6040  & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2))
6041  pcms2 = (shat-avmom(5)**2)**2/(4.*shat)
6042  qmax = sqrt(scalefacm*4.*pcms2)
6043  delta=(log(3.*qmax)-log(q0**2*(1.d0+1.d-6)))/999.d0
6044  DO 22 i=1,1000
6045  q = exp((i-1)*delta + log(q0**2*(1.d0+1.d-6)))
6046  sudaqq(i,1)=q
6047  sudaqg(i,1)=q
6048  sudagg(i,1)=q
6049  sudagc(i,1)=q
6050  sudaqq(i,2)=getinsudakov(q0,q,'QQ')
6051  sudaqg(i,2)=getinsudakov(q0,q,'QG')
6052  sudagg(i,2)=getinsudakov(q0,q,'GG')
6053  sudagc(i,2)=getinsudakov(q0,q,'GC')
6054  22 CONTINUE
6055  END
6056 
6057 
6058 
6059 ***********************************************************************
6060 *** function eixint
6061 ***********************************************************************
6062  SUBROUTINE eixint
6063  IMPLICIT NONE
6064 C--exponential integral for negative arguments
6065  common/expint/eixs(3,1000),valmax,nval
6066  INTEGER nval
6067  DOUBLE PRECISION eixs,valmax
6068 C-local variables
6069  INTEGER i,k
6070  DOUBLE PRECISION x,epsi,hfirst,ystart,ei,ga,r
6071  DATA epsi/1.d-5/
6072 
6073  nval=1000
6074  valmax=55.
6075 
6076  DO 10 i=1,nval
6077  x=i*valmax/(nval*1.d0)
6078  eixs(1,i)=x
6079 C--do negative arguments first
6080  ystart=0d0
6081  hfirst=0.01
6082  CALL odeint(ystart,x,1000.d0,epsi,hfirst,0.d0,5)
6083  eixs(2,i)=-ystart
6084 C--now do the positive arguments
6085  IF (x.EQ.0.0) THEN
6086  ei=-1.0d+300
6087  ELSE IF (x.LE.40.0) THEN
6088  ei=1.0d0
6089  r=1.0d0
6090  DO 15 k=1,100
6091  r=r*k*x/(k+1.0d0)**2
6092  ei=ei+r
6093  IF (dabs(r/ei).LE.1.0d-15) go to 20
6094 15 CONTINUE
6095 20 ga=0.5772156649015328d0
6096  ei=ga+dlog(x)+x*ei
6097  ELSE
6098  ei=1.0d0
6099  r=1.0d0
6100  DO 25 k=1,20
6101  r=r*k/x
6102 25 ei=ei+r
6103  ei=dexp(x)/x*ei
6104  ENDIF
6105  eixs(3,i)=ei
6106  10 CONTINUE
6107  END
6108 
6109 
6110 
6111 ***********************************************************************
6112 *** function odeint
6113 ***********************************************************************
6114  subroutine odeint(ystart,a,b,eps,h1,hmin,w1)
6115  implicit none
6116 C--identifier of file for hepmc output and logfile
6117  common/hepmcid/hpmcfid,logfid
6118  integer hpmcfid,logfid
6119 C--local variables
6120  integer nmax,nstep,w1
6121  double precision ystart,a,b,eps,h1,hmin,x,h,y,dydx,
6122  &deriv,yscale,hdid,hnew
6123  data nmax/100000/
6124 
6125  x = a
6126  y = ystart
6127  h = sign(h1,b-a)
6128  do 20 nstep=1,nmax
6129  dydx = deriv(x,w1)
6130  yscale = abs(y) + abs(h*dydx) + 1.e-25
6131  if (((x + h - b)*h).gt.0.) h = b-x
6132  call rkstepper(x,y,dydx,h,hdid,hnew,yscale,eps,w1)
6133  if ((x - b)*h.ge.0) then
6134  ystart = y
6135  return
6136  endif
6137  h = hnew
6138  if (abs(h).lt.abs(hmin)) then
6139  write(logfid,*)'Error in odeint: stepsize too small',w1
6140  & ,ystart,a,b,h1
6141  return
6142  endif
6143  20 continue
6144  write(logfid,*)'Error in odeint: too many steps',w1
6145  & ,ystart,a,b,h1
6146  end
6147 
6148 
6149 
6150 ***********************************************************************
6151 *** function rkstepper
6152 ***********************************************************************
6153  subroutine rkstepper(x,y,dydx,htest,hdid,hnew,yscale,eps,w1)
6154  implicit none
6155 C--identifier of file for hepmc output and logfile
6156  common/hepmcid/hpmcfid,logfid
6157  integer hpmcfid,logfid
6158 C--local variables
6159  integer w1
6160  double precision x,y,dydx,htest,hdid,hnew,yscale,eps,
6161  &yhalf,y1,y2,rk4step,dydxhalf,xnew,delta,err,h,safety, powerdown,
6162  &powerup,maxup,maxdown,deriv,fac
6163  logical reject
6164  data powerdown/0.25/
6165  data powerup/0.2/
6166  data safety/0.9/
6167  data maxdown/10./
6168  data maxup/5./
6169 
6170  reject = .false.
6171  h = htest
6172  10 xnew = x + h
6173  if (x.eq.xnew) then
6174  write(logfid,*)'Error in rkstepper: step size not significant'
6175  return
6176  endif
6177  yhalf = rk4step(x,y,dydx,h/2.,w1)
6178  dydxhalf = deriv(x+h/2.,w1)
6179  y2 = rk4step(x+h/2.,yhalf,dydxhalf,h/2.,w1)
6180  y1 = rk4step(x,y,dydx,h,w1)
6181  delta = y2-y1
6182  err = abs(delta)/(yscale*eps)
6183  if (err.gt.1.) then
6184  reject = .true.
6185  fac = max(1./maxdown,safety/err**powerdown)
6186  h = h*fac
6187  goto 10
6188  else
6189  if (reject) then
6190  hnew = h
6191  else
6192  fac = min(maxup,safety/err**powerup)
6193  hnew = fac*h
6194  endif
6195  x = xnew
6196  y = y2 + delta/15.
6197  hdid = h
6198  endif
6199  end
6200 
6201 
6202 
6203 ***********************************************************************
6204 *** function rk4step
6205 ***********************************************************************
6206  double precision function rk4step(x,y,dydx,h,w1)
6207  implicit none
6208  integer w1
6209  double precision x,y,dydx,h,k1,k2,k4,yout,deriv
6210  k1 = h*dydx
6211  k2 = h*deriv(x+h/2.,w1)
6212  k4 = h*deriv(x+h,w1)
6213  yout = y+k1/6.+2.*k2/3.+k4/6.
6214  rk4step = yout
6215  end
6216 
6217 
6218 
6219 ***********************************************************************
6220 *** function getdeltat
6221 ***********************************************************************
6222  LOGICAL FUNCTION getdeltat(LINE,TSTART,DTMAX1,DELTAT)
6223  IMPLICIT NONE
6224 C--identifier of file for hepmc output and logfile
6225  common/hepmcid/hpmcfid,logfid
6226  integer hpmcfid,logfid
6227 C--pythia common block
6228  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
6229  INTEGER n,npad,k
6230  DOUBLE PRECISION p,v
6231 C--Parameter common block
6232  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
6233  &allhad,compress,nf
6234  INTEGER nf
6235  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
6236  LOGICAL angord,scatrecoil,allhad,compress
6237 C--time common block
6238  common/time/mv(23000,5)
6239  DOUBLE PRECISION mv
6240 C--max rapidity
6241  common/rapmax/etamax
6242  double precision etamax
6243 C--memory for error message from getdeltat
6244  common/errline/errl
6245  integer errl
6246 C--local variables
6247  INTEGER line,i,nnull
6248  DOUBLE PRECISION dtmax,sigmamax,neffmax,linvmax,pyr,
6249  &r,toff,xs,ys,zs,ts,getsscat,getmsmax,getmdmin,msmax,mdmin,
6250  &xstart,ystart,zstart,weight,ms,md,neff,sigma,getneff,
6251  &getneffmax,getms,getmd,tau,mdmax,getmdmax,getnatmdmin,
6252  &sigmamin,neffmin,tstart,dtmax1,deltat
6253  CHARACTER ptype
6254  LOGICAL stopnow
6255 
6256 C--initialization
6257  getdeltat=.false.
6258  deltat=0.d0
6259  dtmax=dtmax1
6260  IF(k(line,2).EQ.21)THEN
6261  ptype='G'
6262  ELSE
6263  ptype='Q'
6264  ENDIF
6265 
6266  nnull=0
6267  stopnow=.false.
6268 
6269 C--check for upper bound from plasma lifetime
6270  IF((tstart+dtmax).GE.ltime)dtmax=ltime-tstart
6271  IF(dtmax.LT.0.d0) RETURN
6272 
6273 C--calculate time relative to production of the considered parton
6274  toff=tstart-mv(line,4)
6275  xstart=mv(line,1)+toff*p(line,1)/p(line,4)
6276  ystart=mv(line,2)+toff*p(line,2)/p(line,4)
6277  zstart=mv(line,3)+toff*p(line,3)/p(line,4)
6278 
6279 C--calculate upper limit for density*cross section
6280  sigmamax=getsscat(p(line,4),p(line,1),p(line,2),p(line,3),
6281 ! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
6282  & p(line,5),0.d0,ptype,'C',xstart,ystart,zstart,tstart,1)
6283  sigmamin=getsscat(p(line,4),p(line,1),p(line,2),p(line,3),
6284 ! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6)
6285  & p(line,5),0.d0,ptype,'C',xstart,ystart,zstart,tstart,2)
6286  neffmax=getneffmax()
6287  neffmin=getnatmdmin()
6288  linvmax=5.d0*max(neffmin*sigmamax,neffmax*sigmamin)
6289  if(linvmax.eq.0.d0) return
6290 
6291  DO 333 i=1,1000000
6292  deltat=deltat-log(pyr(0))/linvmax
6293  xs=xstart+deltat*p(line,1)/p(line,4)
6294  ys=ystart+deltat*p(line,2)/p(line,4)
6295  zs=zstart+deltat*p(line,3)/p(line,4)
6296  ts=tstart+deltat
6297  IF(ts.LT.zs)THEN
6298  tau=-1.d0
6299  ELSE
6300  tau=sqrt(ts**2-zs**2)
6301  ENDIF
6302  neff=getneff(xs,ys,zs,ts)
6303  IF((tau.GT.1.d0).AND.(neff.EQ.0.d0))THEN
6304  IF(nnull.GT.4)THEN
6305  stopnow=.true.
6306  ELSE
6307  nnull=nnull+1
6308  ENDIF
6309  ELSE
6310  nnull=0
6311  ENDIF
6312  IF((deltat.GT.dtmax).OR.stopnow) THEN
6313  deltat=dtmax
6314  RETURN
6315  ENDIF
6316  IF(neff.GT.0.d0)THEN
6317  sigma=getsscat(p(line,4),p(line,1),p(line,2),p(line,3),
6318  & p(line,5),0.d0,ptype,'C',xs,ys,zs,ts,0)
6319  ELSE
6320  sigma=0.d0
6321  ENDIF
6322  weight=5.d0*neff*sigma/linvmax
6323  IF(weight.GT.1.d0+1d-6) then
6324  if (line.ne.errl) then
6325  write(logfid,*)'error in GETDELTAT: weight > 1',weight,
6326  & neff*sigma/(neffmax*sigmamin),neff*sigma/(neffmin*sigmamax),
6327  & p(line,4)
6328  errl=line
6329  endif
6330  endif
6331  r=pyr(0)
6332  IF(r.LT.weight)THEN
6333  getdeltat=.true.
6334  RETURN
6335  ENDIF
6336  333 CONTINUE
6337  END
6338 
6339 
6340  integer function poissonian(lambda)
6341  implicit none
6342  integer n
6343  double precision lambda,disc,p,pyr,u,v,pi
6344  data pi/3.141592653589793d0/
6345 
6346  if (lambda.gt.745.d0) then
6347  u = pyr(0);
6348  v = pyr(0);
6349  poissonian =
6350  & int(sqrt(lambda)*sqrt(-2.*log(u))*cos(2.*pi*v)+lambda)
6351  else
6352  disc=exp(-lambda)
6353  p=1.d0
6354  n=0
6355  800 p = p*pyr(0)
6356  if (p.gt.disc) then
6357  n = n+1
6358  goto 800
6359  endif
6360  poissonian=n
6361  endif
6362  end
6363 
6364 
6365 ***********************************************************************
6366 *** function ishadron
6367 ***********************************************************************
6368  LOGICAL FUNCTION ishadron(ID)
6369  IMPLICIT NONE
6370 C--local variables
6371  INTEGER id
6372  IF(abs(id).LT.100) THEN
6373  ishadron=.false.
6374  ELSE
6375  IF(mod(int(abs(id)/10.),10).EQ.0) THEN
6376  ishadron = .false.
6377  ELSE
6378  ishadron = .true.
6379  ENDIF
6380  ENDIF
6381  END
6382 
6383 
6384 
6385 ***********************************************************************
6386 *** function isdiquark
6387 ***********************************************************************
6388  LOGICAL FUNCTION isdiquark(ID)
6389  IMPLICIT NONE
6390 C--local variables
6391  INTEGER id
6392  IF(abs(id).LT.1000) THEN
6393  isdiquark=.false.
6394  ELSE
6395  IF(mod(int(id/10),10).EQ.0) THEN
6396  isdiquark = .true.
6397  ELSE
6398  isdiquark = .false.
6399  ENDIF
6400  ENDIF
6401  END
6402 
6403 ***********************************************************************
6404 *** function islepton
6405 ***********************************************************************
6406  LOGICAL FUNCTION islepton(ID)
6407  IMPLICIT NONE
6408 C-- local variables
6409  INTEGER id
6410  IF((abs(id).EQ.11).OR.(abs(id).EQ.13).OR.(abs(id).EQ.15)) THEN
6411  islepton=.true.
6412  ELSE
6413  islepton=.false.
6414  ENDIF
6415  END
6416 
6417 ***********************************************************************
6418 *** function isparton
6419 ***********************************************************************
6420  LOGICAL FUNCTION isparton(ID)
6421  IMPLICIT NONE
6422 C--local variables
6423  INTEGER id
6424  LOGICAL isdiquark
6425  IF((abs(id).LT.6).OR.(id.EQ.21).OR.isdiquark(id)) THEN
6426  isparton=.true.
6427  ELSE
6428  isparton=.false.
6429  ENDIF
6430  END
6431 
6432 
6433 
6434 ***********************************************************************
6435 *** function isprimstring
6436 ***********************************************************************
6437  logical function isprimstring(l)
6438  implicit none
6439  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
6440  INTEGER n,npad,k
6441  DOUBLE PRECISION p,v
6442 C--local variables
6443  integer l
6444  logical isparton
6445  if ((k(l,2).ne.91).and.(k(l,2).ne.92)) then
6446  isprimstring=.false.
6447  return
6448  endif
6449  if ((k(k(l,3),3).eq.0).or.(isparton(k(k(k(l,3),3),2)))) then
6450  isprimstring=.true.
6451  else
6452  isprimstring=.false.
6453  endif
6454  end
6455 
6456 
6457 
6458 ***********************************************************************
6459 *** function issecstring
6460 ***********************************************************************
6461  logical function issecstring(l)
6462  implicit none
6463  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
6464  INTEGER n,npad,k
6465  DOUBLE PRECISION p,v
6466 C--local variables
6467  integer l
6468  logical isparton,isprimstring
6469  if ((k(l,2).ne.91).and.(k(l,2).ne.92)) then
6470  issecstring = .false.
6471  return
6472  endif
6473  if (isprimstring(l)) then
6474  issecstring = .false.
6475  return
6476  endif
6477  if (isparton(k(k(k(l,3),3),2))) then
6478  issecstring = .false.
6479  else
6480  issecstring = .true.
6481  endif
6482  end
6483 
6484 
6485 
6486 ***********************************************************************
6487 *** function isprimhadron
6488 ***********************************************************************
6489  logical function isprimhadron(l)
6490  implicit none
6491  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
6492  INTEGER n,npad,k
6493  DOUBLE PRECISION p,v
6494 C--local variables
6495  integer l
6496  logical isprimstring,isparton
6497  if (((k(k(l,3),2).EQ.91).OR.(k(k(l,3),2).EQ.92))
6498  & .and.isprimstring(k(l,3))
6499  & .and.(.not.isparton(k(l,2)))) then
6500  isprimhadron=.true.
6501  else
6502  isprimhadron=.false.
6503  endif
6504  if (k(l,1).eq.17) isprimhadron=.true.
6505  end
6506 
6507 
6508 
6509 ***********************************************************************
6510 *** function compressevent
6511 ***********************************************************************
6512  logical function compressevent(l1)
6513  implicit none
6514 C--identifier of file for hepmc output and logfile
6515  common/hepmcid/hpmcfid,logfid
6516  integer hpmcfid,logfid
6517  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
6518  INTEGER n,npad,k
6519  DOUBLE PRECISION p,v
6520 C--variables for angular ordering
6521  common/angor/za(23000),zd(23000),thetaa(23000),qqbard(23000)
6522  DOUBLE PRECISION za,zd,thetaa
6523  LOGICAL qqbard
6524 C--time common block
6525  common/time/mv(23000,5)
6526  DOUBLE PRECISION mv
6527 C--colour index common block
6528  common/colour/trip(23000),anti(23000),colmax
6529  INTEGER trip,anti,colmax
6530 C--local variables
6531  integer l1,i,j,nold,nnew,nstart
6532 
6533  nold = n
6534 
6535  do 777 i=2,nold
6536  if (((k(i,1).eq.11).or.(k(i,1).eq.12).or.(k(i,1).eq.13)).and.
6537  & (i.ne.l1)) then
6538  nnew = i
6539  goto 778
6540  endif
6541  777 continue
6542  compressevent = .false.
6543  return
6544  778 continue
6545  nstart = nnew
6546  do 779 i=nstart,nold
6547  if (((k(i,1).ne.11).and.(k(i,1).ne.12).and.(k(i,1).ne.13)).or.
6548  & (i.eq.l1)) then
6549  do 780 j=1,5
6550  p(nnew,j)=p(i,j)
6551  v(nnew,j)=v(i,j)
6552  mv(nnew,j)=mv(i,j)
6553  780 continue
6554  trip(nnew)=trip(i)
6555  anti(nnew)=anti(i)
6556  za(nnew)=za(i)
6557  zd(nnew)=zd(i)
6558  thetaa(nnew)=thetaa(i)
6559  qqbard(nnew)=qqbard(i)
6560  k(nnew,1)=k(i,1)
6561  k(nnew,2)=k(i,2)
6562  k(nnew,3)=0
6563  k(nnew,4)=0
6564  k(nnew,5)=0
6565  if (l1.eq.i) l1=nnew
6566  nnew=nnew+1
6567  endif
6568  779 continue
6569  n=nnew-1
6570  if ((nold-n).le.10) then
6571  compressevent = .false.
6572  else
6573  compressevent = .true.
6574  endif
6575  do 781 i=nnew,nold
6576  do 782 j=1,5
6577  k(i,j)=0
6578  p(i,j)=0.d0
6579  v(i,j)=0.d0
6580  mv(i,j)=0.d0
6581  782 continue
6582  trip(i)=0
6583  anti(i)=0
6584  za(i)=0.d0
6585  zd(i)=0.d0
6586  thetaa(i)=0.d0
6587  qqbard(i)=.false.
6588  781 continue
6589  if (n.gt.23000) write(logfid,*)'Error in compressevent: n = ',n
6590  if (l1.gt.n) write(logfid,*)'Error in compressevent: l1 = ',l1
6591  call flush(logfid)
6592  return
6593  end
6594 
6595 
6596 
6597 ***********************************************************************
6598 *** subroutine pevrec
6599 ***********************************************************************
6600  SUBROUTINE pevrec(NUM,COL)
6601 C--identifier of file for hepmc output and logfile
6602  implicit none
6603  common/hepmcid/hpmcfid,logfid
6604  integer hpmcfid,logfid
6605  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
6606  INTEGER n,npad,k
6607  DOUBLE PRECISION p,v
6608 C--variables for angular ordering
6609  common/angor/za(23000),zd(23000),thetaa(23000),qqbard(23000)
6610  DOUBLE PRECISION za,zd,thetaa
6611  LOGICAL qqbard
6612 C--time common block
6613  common/time/mv(23000,5)
6614  DOUBLE PRECISION mv
6615 C--colour index common block
6616  common/colour/trip(23000),anti(23000),colmax
6617  INTEGER trip,anti,colmax
6618  INTEGER num,i
6619  LOGICAL col
6620 
6621  DO 202 i=1,n
6622  v(i,1)=mv(i,1)
6623  v(i,2)=mv(i,2)
6624  v(i,3)=mv(i,3)
6625  v(i,4)=mv(i,4)
6626  v(i,5)=mv(i,5)
6627  IF(col) write(logfid,*)i,' (',trip(i),',',anti(i),') [',
6628  &k(i,3),k(i,4),k(i,5),' ] {',k(i,2),k(i,1),' } ',
6629  &zd(i),thetaa(i)
6630  202 CONTINUE
6631  CALL pylist(num)
6632 
6633  END
6634 
6635 
6636 
6637 ***********************************************************************
6638 *** subroutine converttohepmc
6639 ***********************************************************************
6640  SUBROUTINE converttohepmc(J,EVNUM,PID,beam1,beam2)
6641  IMPLICIT NONE
6642  common/pyjets/n,npad,k(23000,5),p(23000,5),v(23000,5)
6643  INTEGER n,npad,k
6644  DOUBLE PRECISION p,v
6645  common/pypars/mstp(200),parp(200),msti(200),pari(200)
6646  INTEGER mstp,msti
6647  DOUBLE PRECISION parp,pari
6648 C--Parameter common block
6649  common/param/q0,lps,lqcd,ltime,scalefacm,angord,scatrecoil,
6650  &allhad,compress,nf
6651  INTEGER nf
6652  DOUBLE PRECISION q0,lqcd,ltime,lps,scalefacm
6653  LOGICAL angord,scatrecoil,allhad,compress
6654 C--organisation of event record
6655  common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
6656  &shorthepmc,channel,isochannel
6657  integer nsim,npart,offset,hadrotype
6658  double precision sqrts
6659  character*4 collider,channel
6660  character*2 isochannel
6661  logical hadro,shorthepmc
6662 C--extra storage for scattering centres before interactions
6663  common/storescatcen/nscatcen,maxnscatcen,scatflav(10000),
6664  &scatcen(10000,5),writescatcen,writedummies
6665  integer nscatcen,maxnscatcen,scatflav
6666  double precision scatcen
6667  logical writescatcen,writedummies
6668 C--local variables
6669  INTEGER evnum,pbarcode,vbarcode,codelist(25000),i,pid,nstart,
6670  &nfirst,nvertex,ntot,j,codefirst
6671  DOUBLE PRECISION mproton,mneutron,pdummy,pscatcen
6672  LOGICAL ishadron,isdiquark,isparton,isprimhadron,isprimstring,
6673  &issecstring
6674  character*2 beam1,beam2
6675  data mproton/0.9383/
6676  data mneutron/0.9396/
6677  data pdummy/1.d-6/
6678 
6679  5000 FORMAT(a2,i10,i3,3e14.6,2i2,i6,4i2,e14.6)
6680  5100 FORMAT(a2,2e14.6)
6681  5200 FORMAT(a2,6i7,2i2,1i7,4e14.6)
6682  5300 FORMAT(a2,2i2,5e14.6,2i2)
6683  5400 FORMAT(a2,i6,6i2,i6,i2)
6684  5500 FORMAT(a2,i6,i6,5e14.6,3i2,i6,i2)
6685 
6686  pbarcode=0
6687  vbarcode=0
6688 
6689  if (shorthepmc) then
6690 C--short output
6691  IF(collider.EQ.'EEJJ')THEN
6692  nvertex=3
6693  pbarcode=5
6694  ELSE
6695  nvertex=1
6696  pbarcode=2
6697  ENDIF
6698  nfirst = 0
6699  do 131 i=1,n
6700  if (((k(i,1).lt.6).or.(k(i,1).eq.17)))
6701  & nfirst = nfirst+1
6702  131 continue
6703  if(writescatcen) nfirst=nfirst+nscatcen
6704  if(writedummies) nfirst=nfirst+nscatcen
6705 
6706  WRITE(j,5000)'E ',evnum,-1,0.d0,0.d0,0.d0,0,0,nvertex,1,2,0,1,
6707  &pari(10)
6708  WRITE(j,'(A2,I2,A5)')'N ',1,'"0"'
6709  WRITE(j,'(A)')'U GEV MM'
6710  WRITE(j,5100)'C ',pari(1)*1.d9,0.d0
6711  WRITE(j,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0
6712  WRITE(j,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
6713 C--write out vertex line
6714  IF(collider.EQ.'EEJJ')THEN
6715  WRITE(j,5400)'V ',-1,0,0,0,0,0,2,1,0
6716  WRITE(j,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
6717  & 0.00051,2,0,0,-1,0
6718  WRITE(j,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
6719  & 0.00051,2,0,0,-1,0
6720  WRITE(j,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
6721  & 91.2,2,0,0,-2,0
6722  WRITE(j,5400)'V ',-2,0,0,0,0,0,0,2,0
6723  WRITE(j,5500)'P ',4,pid,sqrts/2.,0.d0,0.d0,sqrts/2.,
6724  & 0.000,2,0,0,-3,0
6725  WRITE(j,5500)'P ',5,-pid,-sqrts/2.,0.d0,0.d0,sqrts/2.,
6726  & 0.000,2,0,0,-3,0
6727  WRITE(j,5400)'V ',-3,0,0,0,0,0,0,nfirst,0
6728  ELSE
6729  WRITE(j,5400)'V ',-1,0,0,0,0,0,2,nfirst,0
6730  if (beam1.eq.'p+') then
6731  WRITE(j,5500)'P ',1,2212,0.d0,0.d0,
6732  & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
6733  else
6734  WRITE(j,5500)'P ',1,2112,0.d0,0.d0,
6735  & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
6736  endif
6737  if (beam2.eq.'p+') then
6738  WRITE(j,5500)'P ',2,2212,0.d0,0.d0,
6739  & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
6740  else
6741  WRITE(j,5500)'P ',2,2112,0.d0,0.d0,
6742  & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
6743  endif
6744  ENDIF
6745 C--write out scattering centres
6746  if(writescatcen) then
6747  do 133 i=1,nscatcen
6748  pbarcode=pbarcode+1
6749  WRITE(j,5500)'P ',pbarcode,scatflav(i),scatcen(i,1),
6750  & scatcen(i,2),scatcen(i,3),scatcen(i,4),scatcen(i,5),
6751  & 3,0,0,0,0
6752  133 continue
6753  endif
6754 C--write out dummy particles
6755  if(writedummies) then
6756  do 135 i=1,nscatcen
6757  pbarcode=pbarcode+1
6758  pscatcen=sqrt(scatcen(i,1)**2+scatcen(i,2)**2+
6759  & scatcen(i,3)**2)
6760  WRITE(j,5500)'P ',pbarcode,111,pdummy*scatcen(i,1)/pscatcen,
6761  & pdummy*scatcen(i,2)/pscatcen,pdummy*scatcen(i,3)/pscatcen,
6762  & pdummy,0.d0,1,0,0,0,0
6763  135 continue
6764  endif
6765 C--write out particle lines
6766  do 132 i=1,n
6767  if(((k(i,1).lt.6).or.(k(i,1).eq.17))) then
6768  pbarcode=pbarcode+1
6769  if((k(i,1).eq.3).or.(k(i,1).eq.5)) then
6770  WRITE(j,5500)'P ',pbarcode,k(i,2),p(i,1),p(i,2),p(i,3),
6771  & p(i,4),p(i,5),4,0,0,0,0
6772  else
6773  WRITE(j,5500)'P ',pbarcode,k(i,2),p(i,1),p(i,2),p(i,3),
6774  & p(i,4),p(i,5),1,0,0,0,0
6775  endif
6776  endif
6777  132 continue
6778 
6779  else
6780 C--long output
6781  if (hadro) then
6782 C--hadronised events
6783  nfirst=0
6784  IF(collider.EQ.'EEJJ')THEN
6785  nvertex=3
6786  ELSE
6787  nvertex=1
6788  ENDIF
6789  DO 123 i=1,n
6790  IF(k(i,3).ne.0)THEN
6791  nstart=i
6792  goto 124
6793  ENDIF
6794  123 CONTINUE
6795  124 CONTINUE
6796  nstart=0
6797 
6798  DO 126 i=nstart+1,n
6799  IF(isprimhadron(i)) nfirst=nfirst+1
6800  IF((ishadron(k(i,2)).OR.(abs(k(i,2)).EQ.15))
6801  & .AND.(k(i,4).NE.0)) nvertex=nvertex+1
6802  126 CONTINUE
6803  127 CONTINUE
6804 
6805  if(writescatcen) nfirst=nfirst+nscatcen
6806  if(writedummies) nfirst=nfirst+nscatcen
6807 
6808  WRITE(j,5000)'E ',evnum,-1,0.d0,0.d0,0.d0,0,0,nvertex,
6809  &1,2,0,1,pari(10)
6810  WRITE(j,'(A2,I2,A5)')'N ',1,'"0"'
6811  WRITE(j,'(A)')'U GEV MM'
6812  WRITE(j,5100)'C ',pari(1)*1.d9,0.d0
6813  WRITE(j,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0
6814  WRITE(j,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0
6815 
6816 C--write out vertex line
6817  IF(collider.EQ.'EEJJ')THEN
6818  vbarcode=-3
6819  pbarcode=5
6820  ELSE
6821  vbarcode=-1
6822  pbarcode=2
6823  ENDIF
6824  IF(collider.EQ.'EEJJ')THEN
6825  WRITE(j,5400)'V ',-1,0,0,0,0,0,2,1,0
6826  WRITE(j,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2.,
6827  & 0.00051,2,0,0,-1,0
6828  WRITE(j,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2.,
6829  & 0.00051,2,0,0,-1,0
6830  WRITE(j,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts,
6831  & 91.2,2,0,0,-2,0
6832  WRITE(j,5400)'V ',-2,0,0,0,0,0,0,2,0
6833  WRITE(j,5500)'P ',4,pid,sqrts/2.,0.d0,0.d0,sqrts/2.,
6834  & 0.000,2,0,0,-3,0
6835  WRITE(j,5500)'P ',5,-pid,-sqrts/2.,0.d0,0.d0,sqrts/2.,
6836  & 0.000,2,0,0,-3,0
6837  WRITE(j,5400)'V ',vbarcode,0,0,0,0,0,0,nfirst,0
6838  ELSE
6839  WRITE(j,5400)'V ',-1,0,0,0,0,0,2,nfirst,0
6840  if (beam1.eq.'p+') then
6841  WRITE(j,5500)'P ',1,2212,0.d0,0.d0,
6842  & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
6843  else
6844  WRITE(j,5500)'P ',1,2112,0.d0,0.d0,
6845  & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
6846  endif
6847  if (beam2.eq.'p+') then
6848  WRITE(j,5500)'P ',2,2212,0.d0,0.d0,
6849  & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0
6850  else
6851  WRITE(j,5500)'P ',2,2112,0.d0,0.d0,
6852  & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0
6853  endif
6854  ENDIF
6855 
6856  codefirst=nfirst+pbarcode
6857 
6858 C--write out scattering centres
6859  if(writescatcen) then
6860  do 134 i=1,nscatcen
6861  pbarcode=pbarcode+1
6862  WRITE(j,5500)'P ',pbarcode,scatflav(i),scatcen(i,1),
6863  & scatcen(i,2),scatcen(i,3),scatcen(i,4),scatcen(i,5),
6864  & 3,0,0,0,0
6865  134 continue
6866  endif
6867 C--write out dummy particles
6868  if(writedummies) then
6869  do 136 i=1,nscatcen
6870  pbarcode=pbarcode+1
6871  pscatcen=sqrt(scatcen(i,1)**2+scatcen(i,2)**2+
6872  & scatcen(i,3)**2)
6873  WRITE(j,5500)'P ',pbarcode,111,pdummy*scatcen(i,1)/pscatcen,
6874  & pdummy*scatcen(i,2)/pscatcen,pdummy*scatcen(i,3)/pscatcen,
6875  & pdummy,0.d0,1,0,0,0,0
6876  136 continue
6877  endif
6878 
6879 C--first write out all particles coming directly from string or cluster decays
6880  DO 125 i=nstart+1,n
6881  IF(.not.isprimhadron(i))THEN
6882  goto 125
6883  ELSE
6884  IF (pbarcode.EQ.codefirst) goto 130
6885  pbarcode=pbarcode+1
6886 C--write out particle line
6887  IF(k(i,4).GT.0)THEN
6888  vbarcode=vbarcode-1
6889  codelist(i)=vbarcode
6890  WRITE(j,5500)'P ',pbarcode,k(i,2),p(i,1),p(i,2),p(i,3),
6891  & p(i,4),p(i,5),2,0,0,vbarcode,0
6892  ELSE
6893  WRITE(j,5500)'P ',pbarcode,k(i,2),p(i,1),p(i,2),p(i,3),
6894  & p(i,4),p(i,5),1,0,0,0,0
6895  ENDIF
6896  ENDIF
6897  125 CONTINUE
6898  130 CONTINUE
6899 C--now write out all other particles and vertices
6900  DO 129 i=nstart+1,n
6901  if (isprimhadron(i).or.isprimstring(i)) goto 129
6902  if (isparton(k(i,2))) then
6903  if (ishadron(k(k(i,3),2))) codelist(i)=codelist(k(i,3))
6904  goto 129
6905  endif
6906  if (issecstring(i)) then
6907  codelist(i)=codelist(k(i,3))
6908  goto 129
6909  endif
6910  pbarcode=pbarcode+1
6911  IF((k(i,3).NE.k(i-1,3)))THEN
6912 C--write out vertex line
6913  WRITE(j,5400)'V ',codelist(k(i,3)),0,0,0,0,0,0,
6914  & k(k(i,3),5)-k(k(i,3),4)+1,0
6915  ENDIF
6916 C--write out particle line
6917  IF(k(i,4).GT.0)THEN
6918  vbarcode=vbarcode-1
6919  codelist(i)=vbarcode
6920  WRITE(j,5500)'P ',pbarcode,k(i,2),p(i,1),p(i,2),p(i,3),
6921  & p(i,4),p(i,5),2,0,0,vbarcode,0
6922  ELSE
6923  WRITE(j,5500)'P ',pbarcode,k(i,2),p(i,1),p(i,2),p(i,3),
6924  & p(i,4),p(i,5),1,0,0,0,0
6925  ENDIF
6926  129 CONTINUE
6927 
6928  else
6929 C--partonic events
6930  endif
6931  endif
6932  call flush(j)
6933  END
6934 
6935 
6936 
6937 ***********************************************************************
6938 *** subroutine printlogo
6939 ***********************************************************************
6940  subroutine printlogo(fid)
6941  implicit none
6942  integer fid
6943 
6944  write(fid,*)
6945  write(fid,*)' _______________'//
6946  &'__________________________ '
6947  write(fid,*)' | '//
6948  &' | '
6949  write(fid,*)' | JJJJJ EEEEE '//
6950  &' W W EEEEE L | '
6951  write(fid,*)' | J E '//
6952  &' W W E L | '
6953  write(fid,*)' _________________| J EEE '//
6954  &' W W W EEE L |_________________ '
6955  write(fid,*)'| | J J E '//
6956  &' W W W W E L | |'
6957  write(fid,*)'| | JJJ EEEEE '//
6958  &' W W EEEEE LLLLL | |'
6959  write(fid,*)'| |_______________'//
6960  &'__________________________| |'
6961  write(fid,*)'| '//
6962  &' |'
6963  write(fid,*)'| '//
6964  &'this is JEWEL 2.1.0 |'
6965  write(fid,*)'| '//
6966  &' |'
6967  write(fid,*)'| Copyright Korinna C. Zapp (2016)'//
6968  &' [Korinna.Zapp@cern.ch] |'
6969  write(fid,*)'| '//
6970  &' |'
6971  write(fid,*)'| The JEWEL homepage is jewel.hepforge.org '//
6972  &' |'
6973  write(fid,*)'| '//
6974  &' |'
6975  write(fid,*)'| The medium model was partly '//
6976  &'implemented by Jochen Klein |'
6977  write(fid,*)'| [Jochen.Klein@cern.ch]. Raghav '//
6978  &'Kunnawalkam Elayavalli helped with the |'
6979  write(fid,*)'| implementation of the V+jet processes '//
6980  &'[raghav.k.e@cern.ch]. |'
6981  write(fid,*)'| '//
6982  &' |'
6983  write(fid,*)'| Please cite JHEP 1303 (2013) '//
6984  &'080 [arXiv:1212.1599] and optionally |'
6985  write(fid,*)'| EPJC C60 (2009) 617 [arXiv:0804.3568] '//
6986  &'for the physics and arXiv:1311.0048 |'
6987  write(fid,*)'| for the code. The reference for '//
6988  &'V+jet processes is EPJC 76 (2016) no.12 695 |'
6989  write(fid,*)'| [arXiv:1608.03099] and for recoil effects'//
6990  &' it is arXiv:1707.01539. |'
6991  write(fid,*)'| '//
6992  &' |'
6993  write(fid,*)'| JEWEL contains code provided by '//
6994  &'S. Zhang and J. M. Jing |'
6995  write(fid,*)'| (Computation of Special Functions, '//
6996  &'John Wiley & Sons, New York, 1996 and |'
6997  write(fid,*)'| http://jin.ece.illinois.edu) for '//
6998  &'computing the exponential integral Ei(x). |'
6999  write(fid,*)'| '//
7000  &' |'
7001  write(fid,*)'| JEWEL relies heavily on PYTHIA 6'//
7002  &' for the event generation. The modified |'
7003  write(fid,*)'| version of PYTHIA 6.4.25 that is'//
7004  &' shipped with JEWEL is, however, not an |'
7005  write(fid,*)'| official PYTHIA release and must'//
7006  &' not be used for anything else. Please |'
7007  write(fid,*)'| refer to results as "JEWEL+PYTHIA".'//
7008  &' |'
7009  write(fid,*)'| '//
7010  &' |'
7011  write(fid,*)'|_________________________________'//
7012  &'____________________________________________|'
7013  write(fid,*)
7014  write(fid,*)
7015  end
7016 
7017 
7018 ***********************************************************************
7019 *** subroutine printtime
7020 ***********************************************************************
7021  subroutine printtime
7022  implicit none
7023 C--identifier of file for hepmc output and logfile
7024  common/hepmcid/hpmcfid,logfid
7025  integer hpmcfid,logfid
7026 C--local variables
7027  integer*4 date(3),time(3)
7028 
7029  1000 format (i2.2, '.', i2.2, '.', i4.4, ', ',
7030  & i2.2, ':', i2.2, ':', i2.2 )
7031  call idate(date)
7032  call itime(time)
7033  write(logfid,1000)date,time
7034  end
7035