Back to home page

sPhenix code displayed by LXR
 
 

    

File indexing completed on 2025-08-03 08:16:23 

0001 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
0002 C++ Copyright (C) 2017 Korinna C. Zapp [Korinna.Zapp@cern.ch]       ++
0003 C++                                                                 ++
0004 C++ This file is part of JEWEL 2.2.0                                ++
0005 C++                                                                 ++
0006 C++ The JEWEL homepage is jewel.hepforge.org                        ++
0007 C++                                                                 ++
0008 C++ The medium model was partly implemented by Jochen Klein.        ++
0009 C++ Raghav Kunnawalkam Elayavalli helped with the implementation    ++
0010 C++ of the V+jet processes.                                         ++
0011 C++                                                                 ++
0012 C++ Please follow the MCnet GUIDELINES and cite Eur.Phys.J. C74     ++
0013 C++ (2014) no.2, 2762 [arXiv:1311.0048] for the code and            ++
0014 C++ JHEP 1303 (2013) 080 [arXiv:1212.1599] and                      ++
0015 C++ optionally EPJC 60 (2009) 617 [arXiv:0804.3568] for the         ++
0016 C++ physics. The reference for V+jet processes is EPJC 76 (2016)    ++
0017 C++ no.12 695 [arXiv:1608.03099] and for recoil effects it is       ++
0018 C++ arXiv:1707.01539.
0019 C++                                                                 ++
0020 C++ JEWEL relies heavily on PYTHIA 6 for the event generation. The  ++
0021 C++ modified version of PYTHIA 6.4.25 that is distributed with      ++
0022 C++ JEWEL is, however, not an official PYTHIA release and must not  ++
0023 C++ be used for anything else. Please refer to results as           ++
0024 C++ "JEWEL+PYTHIA".                                                 ++
0025 C++                                                                 ++
0026 C++ JEWEL also uses code provided by S. Zhang and J. M. Jing        ++
0027 C++ (Computation of Special Functions, John Wiley & Sons, New York, ++
0028 C++ 1996 and http://jin.ece.illinois.edu) for computing the         ++
0029 C++ exponential integral Ei(x).                                     ++
0030 C++                                                                 ++
0031 C++                                                                 ++
0032 C++ JEWEL  is free software; you can redistribute it and/or         ++
0033 C++ modify it under the terms of the GNU General Public License     ++
0034 C++ as published by the Free Software Foundation; either version 2  ++
0035 C++ of the License, or (at your option) any later version.          ++
0036 C++                                                                 ++
0037 C++ JEWEL is distributed in the hope that it will be useful,        ++
0038 C++ but WITHOUT ANY WARRANTY; without even the implied warranty of  ++
0039 C++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the    ++
0040 C++ GNU General Public License for more details.                    ++
0041 C++                                                                 ++
0042 C++ You should have received a copy of the GNU General Public       ++  
0043 C++ License along with this program; if not, write to the Free      ++
0044 C++ Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, ++
0045 C++ MA 02110-1301 USA                                               ++
0046 C++                                                                 ++
0047 C++ Linking JEWEL statically or dynamically with other modules is   ++
0048 C++ making a combined work based on JEWEL. Thus, the terms and      ++
0049 C++ conditions of the GNU General Public License cover the whole    ++
0050 C++ combination.                                                    ++
0051 C++                                                                 ++
0052 C++ In addition, as a special exception, I give you permission to   ++
0053 C++ combine JEWEL with the code for the computation of special      ++
0054 C++ functions provided by S. Zhang and J. M. Jing. You may copy and ++
0055 C++ distribute such a system following the terms of the GNU GPL for ++
0056 C++ JEWEL and the licenses of the other code concerned, provided    ++
0057 C++ that you include the source code of that other code when and as ++
0058 C++ the GNU GPL requires distribution of source code.               ++
0059 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
0060 
0061       PROGRAM JEWEL
0062         IMPLICIT NONE
0063 C--Common block of Pythia
0064       COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
0065         INTEGER N,NPAD,K
0066         DOUBLE PRECISION P,V
0067       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0068         INTEGER MSTU,MSTJ
0069         DOUBLE PRECISION PARU,PARJ
0070       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
0071         INTEGER MDCY,MDME,KFDP
0072         DOUBLE PRECISION BRAT
0073       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
0074         INTEGER MSEL,MSELPD,MSUB,KFIN
0075         DOUBLE PRECISION CKIN 
0076       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
0077         INTEGER MSTP,MSTI
0078         DOUBLE PRECISION PARP,PARI
0079       COMMON/PYDATR/MRPY(6),RRPY(100)
0080         INTEGER MRPY
0081         DOUBLE PRECISION RRPY
0082 C--identifier of file for hepmc output and logfile
0083         common/hepmcid/hpmcfid,logfid
0084         integer hpmcfid,logfid
0085 C--use nuclear pdf?      
0086       COMMON/NPDF/MASS,NSET,EPS09,INITSTR
0087       INTEGER NSET
0088       DOUBLE PRECISION MASS
0089       LOGICAL EPS09
0090       CHARACTER*10 INITSTR
0091 C--number of protons
0092         common/np/nproton
0093         integer nproton
0094 C--organisation of event record
0095         common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
0096      &shorthepmc,channel,isochannel
0097         integer nsim,npart,offset,hadrotype
0098         double precision sqrts
0099         character*4 collider,channel
0100         character*2 isochannel
0101         logical hadro,shorthepmc
0102 C--discard event flag
0103         COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
0104         LOGICAL DISCARD
0105         INTEGER NDISC,NSTRANGE,NGOOD,errcount
0106         double precision wdisc
0107 C--event weight
0108         COMMON/WEIGHT/EVWEIGHT,sumofweights
0109         double precision EVWEIGHT,sumofweights
0110 C--number of scattering events
0111         COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT
0112         DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT
0113 C--number of extrapolations in tables
0114         common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
0115      &ntotxsec,noverxsec,ntotsuda,noversuda
0116         integer ntotspliti,noverspliti,ntotpdf,noverpdf,
0117      &ntotxsec,noverxsec,ntotsuda,noversuda
0118 C--local variables
0119         integer j,i,kk,poissonian
0120       integer nsimpp,nsimpn,nsimnp,nsimnn,nsimsum,nsimchn
0121         double precision sumofweightstot,wdisctot,scalefac
0122         double precision gettemp,r,tau
0123         character*2 b1,b2
0124 
0125         call init()
0126 
0127         SUMOFWEIGHTSTOT=0.d0
0128       WDISCTOT=0.d0
0129 
0130 C--e+ + e- event generation
0131         if (collider.eq.'EEJJ') then
0132           b1 = 'e+'
0133           b2 = 'e-'
0134           write(logfid,*)
0135           write(logfid,*)
0136      &'####################################################'
0137           write(logfid,*)
0138           write(logfid,*)'generating ',nsim,' events in ',b1,' + ',b2,
0139      &' channel'
0140           write(logfid,*)
0141           write(logfid,*)
0142      &'####################################################'
0143           write(logfid,*)
0144           SUMOFWEIGHTS=0.d0
0145         WDISC=0.d0
0146           call initpythia(b1,b2)
0147             write(logfid,*)
0148 C--e+ + e- event loop
0149           DO 100 J=1,NSIM
0150             call genevent(j,b1,b2)
0151  100      CONTINUE
0152           sumofweightstot = sumofweightstot+sumofweights
0153           wdisctot = wdisctot + wdisc
0154           write(logfid,*)
0155           write(logfid,*)'cross section in e+ + e- channel:',PARI(1),'mb'
0156           write(logfid,*)'sum of event weights in e+ + e- channel:',
0157      &  sumofweights-wdisc
0158           write(logfid,*)
0159 
0160         else
0161 C--hadronic event generation
0162           if (isochannel.eq.'PP') then
0163             nsimpp = nsim
0164             nsimpn = 0
0165             nsimnp = 0
0166             nsimnn = 0
0167           elseif (isochannel.eq.'PN') then
0168             nsimpp = 0
0169             nsimpn = nsim
0170             nsimnp = 0
0171             nsimnn = 0
0172           elseif (isochannel.eq.'NP') then
0173             nsimpp = 0
0174             nsimpn = 0
0175             nsimnp = nsim
0176             nsimnn = 0
0177           elseif (isochannel.eq.'NN') then
0178             nsimpp = 0
0179             nsimpn = 0
0180             nsimnp = 0
0181             nsimnn = nsim
0182           else
0183             nsimpp = poissonian(nsim*nproton**2/mass**2)
0184             nsimpn = poissonian(nsim*nproton*(mass-nproton*1.d0)/mass**2)
0185             nsimnp = poissonian(nsim*nproton*(mass-nproton*1.d0)/mass**2)
0186             nsimnn = poissonian(nsim*(mass-nproton*1.d0)**2/mass**2)
0187             nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
0188             scalefac = nsim*1.d0/(nsimsum*1.d0)
0189             nsimpp = int(nsimpp*scalefac)
0190             nsimpn = int(nsimpn*scalefac)
0191             nsimnp = int(nsimnp*scalefac)
0192             nsimnn = int(nsimnn*scalefac)
0193             nsimsum = nsimpp + nsimpn + nsimnp + nsimnn
0194           endif
0195 C--loop over channels
0196           do 101 kk=1,4
0197             if (kk.eq.1) then
0198               b1 = 'p+'
0199               b2 = 'p+'
0200               nsimchn = nsimpp
0201             elseif (kk.eq.2) then
0202               b1 = 'p+'
0203               b2 = 'n0'
0204               nsimchn = nsimpn
0205             elseif (kk.eq.3) then
0206               b1 = 'n0'
0207               b2 = 'p+'
0208               nsimchn = nsimnp
0209             else
0210               b1 = 'n0'
0211               b2 = 'n0'
0212               nsimchn = nsimnn
0213             endif
0214             write(logfid,*)
0215             write(logfid,*)
0216      &'####################################################'
0217             write(logfid,*)
0218             write(logfid,*)'generating ',nsimchn,' events in ',
0219      &b1,' + ',b2,' channel'
0220             write(logfid,*)
0221             write(logfid,*)
0222      &'####################################################'
0223             write(logfid,*)
0224             SUMOFWEIGHTS=0.d0
0225           WDISC=0.d0
0226             call initpythia(b1,b2)
0227             write(logfid,*)
0228 C--event loop
0229             DO 102 J=1,nsimchn
0230               call genevent(j,b1,b2)
0231  102        CONTINUE
0232             sumofweightstot = sumofweightstot+sumofweights
0233             wdisctot = wdisctot + wdisc
0234             write(logfid,*)
0235             write(logfid,*)'cross section in ',b1,' + ',b2,' channel:',
0236      &  PARI(1),'mb'
0237             write(logfid,*)'sum of event weights in ',b1,' + ',b2,
0238      &  ' channel:',sumofweights-wdisc
0239             write(logfid,*)
0240  101      continue
0241         endif
0242  
0243 C--finish
0244         WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-END_EVENT_LISTING'
0245         WRITE(HPMCFID,*)
0246         CLOSE(HPMCFID,status='keep')
0247 
0248         write(logfid,*)
0249         write(logfid,*)'mean number of scatterings:',
0250      &      NSCAT/(SUMOFWEIGHTSTOT-WDISCTOT)
0251         write(logfid,*)'mean number of effective scatterings:',
0252      &      NSCATEFF/(SUMOFWEIGHTSTOT-WDISCTOT)
0253         write(logfid,*)'mean number of splittings:',
0254      &      NSPLIT/(SUMOFWEIGHTSTOT-WDISCTOT)
0255         write(logfid,*)
0256         write(logfid,*)'number of extrapolations in splitting integral: ',
0257      &  noverspliti,' (',(noverspliti*1.d0)/(ntotspliti*1.d0),'%)'
0258         write(logfid,*)
0259      &  'number of extrapolations in splitting partonic PDFs: ',
0260      &  noverpdf,' (',(noverpdf*1.d0)/(ntotpdf*1.d0),'%)'
0261         write(logfid,*)
0262      &  'number of extrapolations in splitting cross sections: ',
0263      &  noverxsec,' (',(noverxsec*1.d0)/(ntotxsec*1.d0),'%)'
0264         write(logfid,*)
0265      &  'number of extrapolations in Sudakov form factor: ',
0266      &  noversuda,' (',(noversuda*1.d0)/(ntotsuda*1.d0),'%)'
0267         write(logfid,*)
0268         write(logfid,*)'number of good events: ',ngood
0269         write(logfid,*)'total number of discarded events: ',NDISC
0270         write(logfid,*)'number of events for which conversion '//
0271      &'to hepmc failed: ',NSTRANGE
0272         call printtime
0273 
0274         close(logfid,status='keep')
0275 
0276         END
0277 
0278 
0279 
0280 ***********************************************************************
0281 ***********************************************************************
0282 ***   END OF MAIN PROGRAM - NOW COME THE SUBROUTINES   ****************
0283 ***********************************************************************
0284 ***********************************************************************
0285 
0286 
0287 ***********************************************************************
0288 ***       subroutine init
0289 ***********************************************************************
0290         subroutine init()
0291         implicit none
0292         INTEGER PYCOMP
0293         INTEGER NMXHEP
0294 C--Common block of Pythia
0295       COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
0296         INTEGER N,NPAD,K
0297         DOUBLE PRECISION P,V
0298       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0299         INTEGER MSTU,MSTJ
0300         DOUBLE PRECISION PARU,PARJ
0301       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
0302         INTEGER MDCY,MDME,KFDP
0303         DOUBLE PRECISION BRAT
0304       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
0305         INTEGER MSEL,MSELPD,MSUB,KFIN
0306         DOUBLE PRECISION CKIN 
0307       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
0308         INTEGER MSTP,MSTI
0309         DOUBLE PRECISION PARP,PARI
0310       COMMON/PYDATR/MRPY(6),RRPY(100)
0311         INTEGER MRPY
0312         DOUBLE PRECISION RRPY
0313 C--use nuclear pdf?      
0314       COMMON/NPDF/MASS,NSET,EPS09,INITSTR
0315       INTEGER NSET
0316       DOUBLE PRECISION MASS
0317       LOGICAL EPS09
0318       CHARACTER*10 INITSTR
0319 C--pdfset
0320         common/pdf/pdfset
0321         integer pdfset
0322 C--number of protons
0323         common/np/nproton
0324         integer nproton
0325 C--Parameter common block
0326         COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL,
0327      &ALLHAD,compress,NF
0328       INTEGER NF
0329         DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM
0330       LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
0331 C--splitting integral
0332       COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000),
0333      &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT
0334       INTEGER NPOINT
0335       DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV,
0336      &QVAL,ZMVAL,QMAX,ZMMIN
0337 C--pdf common block
0338         COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000),
0339      &GINGX(2,1000)
0340         DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX
0341 C--cross secttion common block
0342         COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101),
0343      &INTG1(1001,101),INTG2(1001,101)
0344         DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2
0345 C--Sudakov common block
0346         COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2)
0347      &,SUDAGC(1000,2)
0348         DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC
0349 C--exponential integral for negative arguments
0350       COMMON/EXPINT/EIX(3,1000),VALMAX,NVAL
0351       INTEGER NVAL
0352       DOUBLE PRECISION EIX,VALMAX
0353 C--discard event flag
0354         COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
0355         LOGICAL DISCARD
0356         INTEGER NDISC,NSTRANGE,NGOOD,errcount
0357         double precision wdisc
0358 C--factor in front of formation times
0359         COMMON/FTIMEFAC/FTFAC
0360         DOUBLE PRECISION FTFAC
0361 C--factor in front of alphas argument
0362         COMMON/ALPHASFAC/PTFAC
0363         DOUBLE PRECISION PTFAC
0364 C--number of scattering events
0365         COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT
0366         DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT
0367 C--number of extrapolations in tables
0368         common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf,
0369      &ntotxsec,noverxsec,ntotsuda,noversuda
0370         integer ntotspliti,noverspliti,ntotpdf,noverpdf,
0371      &ntotxsec,noverxsec,ntotsuda,noversuda
0372 C--event weight
0373         COMMON/WEIGHT/EVWEIGHT,sumofweights
0374         double precision EVWEIGHT,sumofweights
0375 C--event weight exponent
0376         COMMON/WEXPO/WEIGHTEX
0377         DOUBLE PRECISION WEIGHTEX
0378 C--identifier of file for hepmc output and logfile
0379         common/hepmcid/hpmcfid,logfid
0380         integer hpmcfid,logfid
0381 C--max rapidity
0382         common/rapmax/etamax
0383         double precision etamax
0384 C--memory for error message from getdeltat
0385         common/errline/errl
0386         integer errl
0387 C--organisation of event record
0388         common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
0389      &shorthepmc,channel,isochannel
0390         integer nsim,npart,offset,hadrotype
0391         double precision sqrts
0392         character*4 collider,channel
0393         character*2 isochannel
0394         logical hadro,shorthepmc
0395 C--extra storage for scattering centres before interactions
0396       common/storescatcen/nscatcen,maxnscatcen,scatflav(10000),
0397      &scatcen(10000,5),writescatcen,writedummies
0398         integer nscatcen,maxnscatcen,scatflav
0399         double precision scatcen
0400         logical writescatcen,writedummies
0401 C--Pythia parameters
0402         common/pythiaparams/PTMIN,PTMAX,weighted
0403         double precision PTMIN,PTMAX
0404         LOGICAL WEIGHTED
0405 
0406 C--Variables local to this program
0407         INTEGER NJOB,ios,pos,i,j,jj,intmass
0408         DOUBLE PRECISION GETLTIMEMAX,EOVEST,r,pyr
0409         character firstchar
0410         CHARACTER*2 SNSET
0411       CHARACTER*80 PDFFILE,XSECFILE,FILEMED,FILESPLIT,buffer,
0412      &label,value
0413       CHARACTER*100 HEPMCFILE,LOGFILE,FILENAME2
0414         CHARACTER(LEN=100) filename
0415         LOGICAL PDFEXIST,SPLITIEXIST,XSECEXIST
0416 
0417         data maxnscatcen/10000/
0418 
0419       HPMCFID = 4
0420         logfid = 3
0421 
0422 C--default settings
0423         nsim = 10
0424         njob = 0
0425         logfile = 'out.log'
0426         hepmcfile = 'out.hepmc'
0427         filesplit = 'splitint.dat'
0428         pdffile = 'pdfs.dat'
0429         xsecfile = 'xsecs.dat'
0430         filemed = 'medium-params.dat'
0431         nf = 3
0432         lqcd = 0.4
0433         q0 = 1.5
0434         ptmin = 5.
0435         ptmax = 350.
0436         etamax = 3.1
0437         collider = 'PPJJ'
0438         isochannel = 'XX'
0439         channel = 'MUON'
0440         sqrts = 2760
0441         pdfset = 10042
0442         nset = 1
0443         mass = 208.
0444       nproton = 82
0445         weighted = .true.
0446         weightex = 5.
0447         angord = .true.
0448         allhad = .false.
0449         hadro = .true.
0450         hadrotype = 0
0451         shorthepmc = .true.
0452         compress = .true.
0453         writescatcen = .false.
0454         writedummies = .false.
0455         
0456         lps = lqcd
0457         scatrecoil = .false.
0458         if (.not.hadro) shorthepmc = .true.
0459 
0460         SCALEFACM=1.
0461         ptfac=1.
0462         ftfac=1.d0
0463 
0464         if (iargc().eq.0) then
0465           write(*,*)'No parameter file given, '// 
0466      &'will run with default settings.'
0467         else
0468           call getarg(1,filename)
0469           write(*,*)'Reading parameters from ',filename
0470           open(unit=1,file=filename,status='old',err=110)
0471           do 120 i=1,1000
0472           read(1, '(A)', iostat=ios) buffer
0473             if(ios.ne.0) goto 130
0474             firstchar = buffer(1:1)
0475             if (firstchar.eq.'#') goto 120
0476           pos=scan(buffer,' ')
0477           label=buffer(1:pos)
0478           value=buffer(pos+1:)
0479           if(label.eq."NEVENT")then
0480             read(value,*,iostat=ios) nsim
0481           elseif(label.eq."NJOB")then
0482             read(value,*,iostat=ios) njob
0483           elseif(label.eq."LOGFILE")then
0484             read(value,'(a)',iostat=ios) logfile
0485           elseif(label.eq."HEPMCFILE")then
0486             read(value,'(a)',iostat=ios) hepmcfile
0487           elseif(label.eq."SPLITINTFILE")then
0488             read(value,'(a)',iostat=ios) filesplit
0489           elseif(label.eq."PDFFILE")then
0490             read(value,'(a)',iostat=ios) pdffile
0491           elseif(label.eq."XSECFILE")then
0492             read(value,'(a)',iostat=ios) xsecfile
0493           elseif(label.eq."MEDIUMPARAMS")then
0494             read(value,'(a)',iostat=ios) filemed
0495           elseif(label.eq."NF")then
0496             read(value,*,iostat=ios) nf
0497           elseif(label.eq."LAMBDAQCD")then
0498             read(value,*,iostat=ios) lqcd
0499           elseif(label.eq."Q0")then
0500             read(value,*,iostat=ios) q0
0501           elseif(label.eq."PTMIN")then
0502             read(value,*,iostat=ios) ptmin
0503           elseif(label.eq."PTMAX")then
0504             read(value,*,iostat=ios) ptmax
0505           elseif(label.eq."ETAMAX")then
0506             read(value,*,iostat=ios) etamax
0507           elseif(label.eq."PROCESS")then
0508             read(value,*,iostat=ios) collider
0509           elseif(label.eq."ISOCHANNEL")then
0510             read(value,*,iostat=ios) isochannel
0511             elseif(label.eq."CHANNEL")then
0512             read(value,*,iostat=ios) channel
0513           elseif(label.eq."SQRTS")then
0514             read(value,*,iostat=ios) sqrts
0515           elseif(label.eq."PDFSET")then
0516             read(value,*,iostat=ios) pdfset
0517           elseif(label.eq."NSET")then
0518             read(value,*,iostat=ios) nset
0519           elseif(label.eq."MASS")then
0520             read(value,*,iostat=ios) mass
0521           elseif(label.eq."NPROTON")then
0522             read(value,*,iostat=ios) nproton
0523           elseif(label.eq."WEIGHTED")then
0524             read(value,*,iostat=ios) weighted
0525           elseif(label.eq."WEXPO")then
0526             read(value,*,iostat=ios) weightex
0527           elseif(label.eq."ANGORD")then
0528             read(value,*,iostat=ios) angord
0529           elseif(label.eq."KEEPRECOILS")then
0530             read(value,*,iostat=ios) allhad
0531           elseif(label.eq."HADRO")then
0532             read(value,*,iostat=ios) hadro
0533           elseif(label.eq."HADROTYPE")then
0534             read(value,*,iostat=ios) hadrotype
0535           elseif(label.eq."SHORTHEPMC")then
0536             read(value,*,iostat=ios) shorthepmc
0537           elseif(label.eq."COMPRESS")then
0538             read(value,*,iostat=ios) compress
0539           elseif(label.eq."WRITESCATCEN")then
0540             read(value,*,iostat=ios) writescatcen
0541           elseif(label.eq."WRITEDUMMIES")then
0542             read(value,*,iostat=ios) writedummies
0543             else
0544               write(*,*)'unknown label ',label
0545             endif
0546  120      continue
0547 
0548 
0549  110      write(*,*)
0550      &          'Unable to open parameter file, will exit the run.'
0551           call exit(1)
0552 
0553  130      close(1,status='keep')
0554           write(*,*)'...done'
0555         endif
0556 
0557         if (ptmin.lt.3.d0) ptmin = 3.d0
0558         if (.not.writescatcen) writedummies = .false.
0559 
0560         OPEN(unit=logfid,file=LOGFILE,status='unknown')
0561         MSTU(11)=logfid
0562 
0563         call printtime
0564         call printlogo(logfid)
0565 
0566 
0567         write(logfid,*)
0568         write(logfid,*)'parameters of the run:'
0569         write(logfid,*)'NEVENT       = ',nsim
0570         write(logfid,*)'NJOB         = ',njob
0571         write(logfid,*)'LOGFILE      = ',logfile
0572         write(logfid,*)'HEPMCFILE    = ',hepmcfile
0573         write(logfid,*)'SPLITINTFILE = ',filesplit
0574         write(logfid,*)'PDFFILE      = ',pdffile
0575         write(logfid,*)'XSECFILE     = ',xsecfile
0576         write(logfid,*)'MEDIUMPARAMS = ',filemed
0577         write(logfid,*)'NF           = ',nf
0578         write(logfid,*)'LAMBDAQCD    = ',lqcd
0579         write(logfid,*)'Q0           = ',q0
0580         write(logfid,*)'PTMIN        = ',ptmin
0581         write(logfid,*)'PTMAX        = ',ptmax
0582         write(logfid,*)'ETAMAX       = ',etamax
0583         write(logfid,*)'PROCESS      = ',collider
0584         write(logfid,*)'ISOCHANNEL   = ',isochannel
0585         write(logfid,*)'CHANNEL      = ',channel
0586         write(logfid,*)'SQRTS        = ',sqrts
0587         write(logfid,*)'PDFSET       = ',pdfset
0588         write(logfid,*)'NSET         = ',nset
0589         write(logfid,*)'MASS         = ',mass
0590         write(logfid,*)'NPROTON      = ',nproton
0591         write(logfid,*)'WEIGHTED     = ',weighted
0592         write(logfid,*)'WEXPO        = ',weightex
0593         write(logfid,*)'ANGORD       = ',angord
0594         write(logfid,*)'KEEPRECOILS  = ',allhad
0595         write(logfid,*)'HADRO        = ',hadro
0596         write(logfid,*)'HADROTYPE    = ',hadrotype
0597         write(logfid,*)'SHORTHEPMC   = ',shorthepmc
0598         write(logfid,*)'COMPRESS     = ',compress
0599         write(logfid,*)'WRITESCATCEN = ',writescatcen
0600         write(logfid,*)'WRITEDUMMIES = ',writedummies
0601         write(logfid,*)
0602         call flush(logfid)
0603 
0604         if ((collider.ne.'PPJJ').and.(collider.ne.'EEJJ')
0605      &  .and.(collider.ne.'PPYJ').and.(collider.ne.'PPYQ')
0606      &  .and.(collider.ne.'PPYG')
0607      &  .and.(collider.ne.'PPZJ').and.(collider.ne.'PPZQ')
0608      &  .and.(collider.ne.'PPZG').and.(collider.ne.'PPWJ')
0609      &  .and.(collider.ne.'PPWQ').and.(collider.ne.'PPWG')
0610      &      .and.(collider.ne.'PPDY')) then
0611           write(logfid,*)'Fatal error: colliding system unknown, '//
0612      &  'will exit now'
0613           call exit(1)
0614         endif
0615 
0616 C--initialize medium
0617         intmass = int(mass)
0618       CALL MEDINIT(FILEMED,logfid,etamax,intmass)
0619       CALL MEDNEXTEVT
0620 
0621         OPEN(unit=HPMCFID,file=HEPMCFILE,status='unknown')
0622         WRITE(HPMCFID,*)
0623         WRITE(HPMCFID,'(A)')'HepMC::Version 2.06.05'
0624         WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-START_EVENT_LISTING'
0625 
0626         NPART=2
0627         
0628         if(ptmax.gt.0.)then
0629           EOVEST=MIN(1.5*(PTMAX+50.)*COSH(ETAMAX),sqrts/2.)
0630         else
0631           EOVEST=sqrts/2.
0632         endif
0633 
0634   
0635         CALL EIXINT
0636         CALL INSUDAINT(EOVEST)
0637 
0638         write(logfid,*)
0639          INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
0640          IF(SPLITIEXIST)THEN
0641           write(logfid,*)'read splitting integrals from ',FILESPLIT
0642           OPEN(unit=10,file=FILESPLIT,status='old')
0643           READ(10,*)QMAX,ZMMIN,NPOINT
0644           DO 893 I=1,NPOINT+1
0645            READ(10,*) QVAL(I),ZMVAL(I)
0646  893    CONTINUE         
0647           DO 891 I=1,NPOINT+1
0648            DO 892 J=1,NPOINT+1
0649             READ(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
0650  892       CONTINUE
0651  891      CONTINUE
0652           CLOSE(10,status='keep')
0653          ELSE
0654           write(logfid,*)'have to integrate splitting functions, '// 
0655      &'this may take some time'
0656           CALL SPLITFNCINT(EOVEST)
0657           INQUIRE(file=FILESPLIT,exist=SPLITIEXIST)
0658           IF(.NOT.SPLITIEXIST)THEN
0659            write(logfid,*)'write splitting integrals to ',FILESPLIT
0660            OPEN(unit=10,file=FILESPLIT,status='new')
0661            WRITE(10,*)QMAX,ZMMIN,NPOINT
0662            DO 896 I=1,NPOINT+1
0663             WRITE(10,*) QVAL(I),ZMVAL(I)
0664  896     CONTINUE        
0665            DO 897 I=1,NPOINT+1
0666             DO 898 J=1,NPOINT+1
0667              WRITE(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J)
0668  898        CONTINUE
0669  897       CONTINUE
0670            CLOSE(10,status='keep')
0671           ENDIF 
0672          ENDIF
0673         write(logfid,*)
0674 
0675         INQUIRE(file=PDFFILE,exist=PDFEXIST)
0676         IF(PDFEXIST)THEN
0677         write(logfid,*)'read pdfs from ',PDFFILE
0678          OPEN(unit=10,file=PDFFILE,status='old')
0679          DO 872 I=1,2
0680           DO 873 J=1,1000
0681            READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
0682  873      CONTINUE
0683  872     CONTINUE
0684          CLOSE(10,status='keep')
0685         ELSE
0686          write(logfid,*)'have to integrate pdfs, this may take some time'
0687          CALL PDFINT(EOVEST)
0688          INQUIRE(file=PDFFILE,exist=PDFEXIST)
0689          IF(.NOT.PDFEXIST)THEN
0690           write(logfid,*)'write pdfs to ',PDFFILE
0691           OPEN(unit=10,file=PDFFILE,status='new')
0692           DO 876 I=1,2
0693            DO 877 J=1,1000
0694             WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J)
0695  877       CONTINUE
0696  876      CONTINUE
0697           CLOSE(10,status='keep')
0698          ENDIF
0699         ENDIF 
0700         write(logfid,*)
0701 
0702         INQUIRE(file=XSECFILE,exist=XSECEXIST)
0703         IF(XSECEXIST)THEN
0704         write(logfid,*)'read cross sections from ',XSECFILE
0705          OPEN(unit=10,file=XSECFILE,status='old')
0706           DO 881 J=1,1001
0707          DO 885 JJ=1,101
0708            READ(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
0709      &INTG1(J,JJ),INTG2(J,JJ)
0710  885     CONTINUE
0711  881      CONTINUE
0712          CLOSE(10,status='keep')
0713         ELSE
0714          write(logfid,*)'have to integrate cross sections, '//
0715      &'this may take some time'
0716          CALL XSECINT(EOVEST)
0717          INQUIRE(file=XSECFILE,exist=XSECEXIST)
0718          IF(.NOT.XSECEXIST)THEN
0719           write(logfid,*)'write cross sections to ',XSECFILE
0720           OPEN(unit=10,file=XSECFILE,status='new')
0721            DO 883 J=1,1001
0722           DO 884 JJ=1,101
0723             WRITE(10,*)INTQ1(J,JJ),INTQ2(J,JJ),
0724      &INTG1(J,JJ),INTG2(J,JJ)
0725  884      CONTINUE
0726  883       CONTINUE
0727           CLOSE(10,status='keep')
0728          ENDIF 
0729         ENDIF
0730         write(logfid,*)
0731         CALL FLUSH(3)
0732 
0733 
0734 
0735 C--initialise random number generator status
0736       IF(NJOB.GT.0)THEN
0737        MRPY(1)=NJOB*1000
0738        MRPY(2)=0
0739       ENDIF
0740 
0741 C--Call PYR once for initialization
0742         R=PYR(0)
0743 
0744         NDISC=0
0745       NGOOD=0
0746       NSTRANGE=0
0747       
0748         ERRCOUNT=0
0749         errl = 0
0750 
0751         NSCAT=0.d0
0752         NSCATEFF=0.d0
0753         NSPLIT=0.d0
0754 
0755         ntotspliti=0
0756         noverspliti=0
0757         ntotpdf=0
0758         noverpdf=0
0759         ntotxsec=0
0760         noverxsec=0
0761         ntotsuda=0
0762         noversuda=0
0763 
0764         IF(NSET.EQ.0)THEN
0765          EPS09=.FALSE.
0766         ELSE
0767          EPS09=.TRUE.
0768          IF(NSET.LT.10)THEN
0769           WRITE(SNSET,'(i1)') NSET
0770          ELSE
0771           WRITE(SNSET,'(i2)') NSET
0772          ENDIF
0773           INITSTR='EPS09LO,'//SNSET
0774         ENDIF 
0775 
0776         end
0777 
0778 
0779 
0780 ***********************************************************************
0781 ***       subroutine initpythia
0782 ***********************************************************************
0783         subroutine initpythia(beam1,beam2)
0784         implicit none
0785         INTEGER PYCOMP
0786         INTEGER NMXHEP
0787 C--Common block of Pythia
0788       COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
0789         INTEGER N,NPAD,K
0790         DOUBLE PRECISION P,V
0791       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0792         INTEGER MSTU,MSTJ
0793         DOUBLE PRECISION PARU,PARJ
0794       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
0795         INTEGER MDCY,MDME,KFDP
0796         DOUBLE PRECISION BRAT
0797       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
0798         INTEGER MSEL,MSELPD,MSUB,KFIN
0799         DOUBLE PRECISION CKIN 
0800       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
0801         INTEGER MSTP,MSTI
0802         DOUBLE PRECISION PARP,PARI
0803       COMMON/PYDATR/MRPY(6),RRPY(100)
0804         INTEGER MRPY
0805         DOUBLE PRECISION RRPY
0806 C--use nuclear pdf?      
0807       COMMON/NPDF/MASS,NSET,EPS09,INITSTR
0808       INTEGER NSET
0809       DOUBLE PRECISION MASS
0810       LOGICAL EPS09
0811       CHARACTER*10 INITSTR
0812 C--pdfset
0813         common/pdf/pdfset
0814         integer pdfset
0815 C--Parameter common block
0816         COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL,
0817      &ALLHAD,compress,NF
0818       INTEGER NF
0819         DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM
0820       LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress
0821 C--discard event flag
0822         COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD
0823         LOGICAL DISCARD
0824         INTEGER NDISC,NSTRANGE,NGOOD,errcount
0825         double precision wdisc
0826 C--event weight
0827         COMMON/WEIGHT/EVWEIGHT,sumofweights
0828         double precision EVWEIGHT,sumofweights
0829 C--event weight exponent
0830         COMMON/WEXPO/WEIGHTEX
0831         DOUBLE PRECISION WEIGHTEX
0832 C--memory for error message from getdeltat
0833         common/errline/errl
0834         integer errl
0835 C--organisation of event record
0836         common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro,
0837      &shorthepmc,channel,isochannel
0838         integer nsim,npart,offset,hadrotype
0839         double precision sqrts
0840         character*4 collider,channel
0841         character*2 isochannel
0842         logical hadro,shorthepmc
0843 C--Pythia parameters
0844         common/pythiaparams/PTMIN,PTMAX,weighted
0845         double precision PTMIN,PTMAX
0846         LOGICAL WEIGHTED
0847 
0848 C--Variables local to this program
0849         character*2 beam1,beam2
0850 
0851 
0852 C--initialise PYTHIA
0853 C--no multiple interactions
0854          MSTP(81) = 0
0855 C--initial state radiation
0856          MSTP(61)=1
0857 C--switch off final state radiation
0858          MSTP(71)=0
0859 C--No hadronisation (yet)
0860        MSTP(111)=0
0861 C--parameter affecting treatment of string corners
0862        PARU(14)=1.
0863 C--Min shat in simulation
0864        CKIN(1)=2.      
0865 C--pT-cut
0866        CKIN(3)=PTMIN
0867        CKIN(4)=PTMAX
0868 C--use LHAPDF
0869          MSTP(52)=2
0870 C--choose pdf: CTEQ6ll (LO fit/LO alphas) - 10042
0871 C                MSTW2008 (LO central) - 21000
0872          MSTP(51)=PDFSET
0873          IF(COLLIDER.EQ.'PPYQ')THEN
0874           MSEL=0
0875           MSUB(29)=1
0876          ELSEIF(COLLIDER.EQ.'PPYG')THEN
0877           MSEL=0
0878           MSUB(14)=1
0879           MSUB(115)=1
0880          ELSEIF(COLLIDER.EQ.'PPYJ')THEN
0881           MSEL=0
0882           MSUB(14)=1
0883           MSUB(29)=1
0884           MSUB(115)=1
0885          ELSEIF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')
0886      &  .or.(COLLIDER.EQ.'PPZG')
0887      &      .or.(collider.eq.'PPDY'))THEN
0888           MSEL=0
0889           IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')) MSUB(30)=1
0890           IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZG')) MSUB(15)=1
0891           IF(COLLIDER.EQ.'PPDY') MSUB(1)=1
0892           MDME(174,1)=0          !Z decay into d dbar', 
0893           MDME(175,1)=0          !Z decay into u ubar', 
0894           MDME(176,1)=0          !Z decay into s sbar', 
0895           MDME(177,1)=0          !Z decay into c cbar', 
0896           MDME(178,1)=0          !Z decay into b bbar', 
0897           MDME(179,1)=0          !Z decay into t tbar', 
0898           MDME(182,1)=0          !Z decay into e- e+', 
0899           MDME(183,1)=0          !Z decay into nu_e nu_ebar', 
0900           MDME(184,1)=0          !Z decay into mu- mu+', 
0901           MDME(185,1)=0          !Z decay into nu_mu nu_mubar', 
0902           MDME(186,1)=0          !Z decay into tau- tau+', 
0903           MDME(187,1)=0          !Z decay into nu_tau nu_taubar',
0904           if (channel.EQ.'ELEC')THEN
0905             MDME(182,1)=1
0906           ELSEIF(channel.EQ.'MUON')THEN
0907             MDME(184,1)=1
0908           ENDIF
0909          ELSEIF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')
0910      &  .or.(COLLIDER.EQ.'PPWG'))THEN
0911           MSEL=0
0912           IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')) MSUB(31)=1
0913           IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWG')) MSUB(16)=1
0914           MDME(190,1)=0          ! W+ decay into dbar u,
0915           MDME(191,1)=0          ! W+ decay into dbar c,
0916           MDME(192,1)=0          ! W+ decay into dbar t,
0917           MDME(194,1)=0          ! W+ decay into sbar u,
0918           MDME(195,1)=0          ! W+ decay into sbar c,
0919           MDME(196,1)=0          ! W+ decay into sbar t,
0920           MDME(198,1)=0          ! W+ decay into bbar u,
0921           MDME(199,1)=0          ! W+ decay into bbar c,
0922           MDME(200,1)=0          ! W+ decay into bbar t,
0923           MDME(202,1)=0          ! W+ decay into b'bar u,
0924           MDME(203,1)=0          ! W+ decay into b'bar c,
0925           MDME(204,1)=0          ! W+ decay into b'bar t,
0926           MDME(206,1)=0          ! W+ decay into e+ nu_e,
0927           MDME(207,1)=0          ! W+ decay into mu+ nu_mu,
0928           MDME(208,1)=0          ! W+ decay into tau+ nu_tau,
0929           MDME(209,1)=0      ! W+ decay into tau'+ nu'_tau,
0930           if (channel.EQ.'ELEC')THEN
0931            MDME(206,1)=1
0932           ELSEIF(channel.EQ.'MUON')THEN
0933            MDME(207,1)=1
0934           ENDIF
0935          ELSE
0936 C--All QCD processes are active
0937         MSEL=1
0938          ENDIF
0939 !        MSEL=0
0940 !        MSUB(11)=1
0941 !        MSUB(12)=1
0942 !        MSUB(53)=1
0943 !        MSUB(13)=1
0944 !        MSUB(68)=1
0945 !        MSUB(28)=1
0946 
0947 C--weighted events
0948        IF(WEIGHTED) MSTP(142)=1
0949 
0950 C--number of errors to be printed
0951          MSTU(22)=MAX(10,INT(5.*NSIM/100.))
0952 
0953 C--number of lines in event record
0954         MSTU(4)=23000
0955         MSTU(5)=23000
0956 
0957 C--switch off pi0 decay
0958       MDCY(PYCOMP(111),1)=0
0959 C--initialisation call
0960          IF(COLLIDER.EQ.'EEJJ')THEN
0961           OFFSET=9
0962           CALL PYINIT('CMS',beam1,beam2,sqrts)
0963          ELSEIF((COLLIDER.EQ.'PPJJ').OR.(COLLIDER.EQ.'PPYJ').OR.
0964      &          (COLLIDER.EQ.'PPYG').OR.(COLLIDER.EQ.'PPYQ'))THEN
0965           OFFSET=8
0966           CALL PYINIT('CMS',beam1,beam2,sqrts)
0967          ELSEIF((COLLIDER.EQ.'PPWJ').OR.(COLLIDER.EQ.'PPZJ').or.
0968      &  (COLLIDER.EQ.'PPWQ').OR.(COLLIDER.EQ.'PPZQ').or.
0969      &  (COLLIDER.EQ.'PPWG').OR.(COLLIDER.EQ.'PPZG'))THEN
0970           OFFSET=10
0971           CALL PYINIT('CMS',beam1,beam2,sqrts)
0972          elseif (collider.eq.'PPDY') then
0973           CALL PYINIT('CMS',beam1,beam2,sqrts)
0974          ENDIF
0975 
0976         end
0977 
0978 
0979 
0980 ***********************************************************************
0981 ***       subroutine genevent
0982 ***********************************************************************
0983         subroutine genevent(j,b1,b2)
0984         implicit none
0985 C--identifier of file for hepmc output and logfile
0986         common/hepmcid/hpmcfid,logfid
0987         integer hpmcfid,logfid
0988         INTEGER PYCOMP
0989         INTEGER NMXHEP
0990 C--Common block of Pythia
0991       COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5)
0992         INTEGER N,NPAD,K
0993         DOUBLE PRECISION P,V
0994       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
0995         INTEGER MSTU,MSTJ
0996         DOUBLE PRECISION PARU,PARJ
0997       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
0998         INTEGER MDCY,MDME,KFDP
0999         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
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated by the 2.3.7 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!