c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine prediatom(vi,ji,rguess,mm,nsurf,symb,
     &    tau,rin,rout)

c Precompute some information for the atom-diatom initial conditions
c (INITx = 4).

      implicit none
      include 'param.f'

      integer nsurf,arri
      double precision mm(mnat),escat,rguess,
     & einti,eroti,evibi,eelec,rmin,rin,rout,ecoli,rmass,term,
     & mdum,ppreli,bmax,bmin,tau,etmp,
     & ji,vi
      character*2 symb(mnat)

      write(6,*)"Asymptotic analysis"
      write(6,*)"   Emin (eV)      Rmin (A)"
      call diamin2(rmin,etmp,-1.d0,mm,nsurf,symb,rguess)
      write(6,50)etmp*autoev,rmin*autoang
 50   format(2f15.5)

      write(6,*)"Preparing the diatom ",
     &  "with v = ",vi," j = ",ji," surface = ",nsurf
      write(6,*)
      eelec = etmp
      write(6,*)"Energetics (relative to zero of E)"
      write(6,*)"At the classical minimum:"
      write(6,100)"Re    = ",rmin*autoang," A"
      write(6,100)"Eelec = ",eelec*autoev," eV"
      call ewkb2(0.d0,vi,mm,evibi,rin,rout,nsurf,symb,rmin)
      call ewkb2(ji,vi,mm,einti,rin,rout,nsurf,symb,rmin)
      eroti = einti-evibi

      write(6,102)"Eint  = E(v=",vi,",j=",ji,") =",einti*autoev," eV"
      write(6,102)"Evib  = E(v=",vi,",j=",0.,") =",evibi*autoev," eV"
c     & ,2.d0*evibi*autocmi," cm-1"
      write(6,103)"Erot  = Eint  - Evib   = ",eroti*autoev," eV"
      write(6,101)"Turning points = ",rin*autoang," and ",
     & rout*autoang," A"
 100  format(1x,a,20x,f13.5,a)
 101  format(1x,a,f13.5,a,f13.5,a)
 102  format(1x,a,f6.2,a,f6.2,a,4x,f13.5,a,f13.5,a)
 103  format(1x,a,3x,f13.5,a)

      call period2(einti,ji,mm,rin,rout,tau,nsurf,symb)
      write(6,103)"Period for the vibration = ",tau*autofs," fs"
      write(6,*)

      return

      end


      subroutine pjibt (neq, y, yh, nyh, ewt, rtem, savr, s, wm, iwm,
     1   res, jac, adda)
clll. optimize
      external res, jac, adda
      integer neq, nyh, iwm
      integer iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter,
     2   maxord, maxcor, msbp, mxncf, n, nq, nst, nre, nje, nqu
      integer i, ier, iia, iib, iic, ipa, ipb, ipc, ires, j, j1, j2,
     1   k, k1, lenp, lblox, lpb, lpc, mb, mbsq, mwid, nb
      double precision y, yh, ewt, rtem, savr, s, wm
      double precision rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      double precision con, fac, hl0, r, srur
      dimension neq(1), y(1), yh(nyh,1), ewt(1), rtem(1),
     1   s(1), savr(1), wm(*), iwm(*)
      common /ls0001/ rowns(209),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(14), iowns(6),
     4   icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nre, nje, nqu
c-----------------------------------------------------------------------
c pjibt is called by stodi to compute and process the matrix
c p = a - h*el(1)*j , where j is an approximation to the jacobian dr/dy,
c and r = g(t,y) - a(t,y)*s.  here j is computed by the user-supplied
c routine jac if miter = 1, or by finite differencing if miter = 2.
c j is stored in wm, rescaled, and adda is called to generate p.
c p is then subjected to lu decomposition by decbt in preparation
c for later solution of linear systems with p as coefficient matrix.
c
c in addition to variables described previously, communication
c with pjibt uses the following..
c y     = array containing predicted values on entry.
c rtem  = work array of length n (acor in stodi).
c savr  = array used for output only.  on output it contains the
c         residual evaluated at current values of t and y.
c s     = array containing predicted values of dy/dt (savf in stodi).
c wm    = real work space for matrices.  on output it contains the
c         lu decomposition of p.
c         storage of matrix elements starts at wm(3).
c         wm also contains the following matrix-related data..
c         wm(1) = dsqrt(uround), used in numerical jacobian increments.
c iwm   = integer work space containing pivot information, starting at
c         iwm(21).  iwm also contains block structure parameters
c         mb = iwm(1) and nb = iwm(2).
c el0   = el(1) (input).
c ierpj = output error flag.
c         = 0 if no trouble occurred,
c         = 1 if the p matrix was found to be unfactorable,
c         = ires (= 2 or 3) if res returned ires = 2 or 3.
c jcur  = output flag = 1 to indicate that the jacobian matrix
c         (or approximation) is now current.
c this routine also uses the common variables el0, h, tn, uround,
c miter, n, nre, and nje.
c-----------------------------------------------------------------------
      nje = nje + 1
      hl0 = h*el0
      ierpj = 0
      jcur = 1
      mb = iwm(1)
      nb = iwm(2)
      mbsq = mb*mb
      lblox = mbsq*nb
      lpb = 3 + lblox
      lpc = lpb + lblox
      lenp = 3*lblox
      go to (100, 200), miter
c if miter = 1, call res, then jac, and multiply by scalar. ------------
 100  ires = 1
      call res (neq, tn, y, s, savr, ires)
      nre = nre + 1
      if (ires .gt. 1) go to 600
      do 110 i = 1,lenp
 110    wm(i+2) = 0.0d0
      call jac (neq, tn, y, s, mb, nb, wm(3), wm(lpb), wm(lpc))
      con = -hl0
      do 120 i = 1,lenp
 120    wm(i+2) = wm(i+2)*con
      go to 260
c
c if miter = 2, make 3*mb + 1 calls to res to approximate j. -----------
 200  continue
      ires = -1
      call res (neq, tn, y, s, savr, ires)
      nre = nre + 1
      if (ires .gt. 1) go to 600
      mwid = 3*mb
      srur = wm(1)
      do 205 i = 1,lenp
 205    wm(2+i) = 0.0d0
      do 250 k = 1,3
        do 240 j = 1,mb
c         increment y(i) for group of column indices, and call res. ----
          j1 = j+(k-1)*mb
          do 210 i = j1,n,mwid
            r = dmax1(srur*dabs(y(i)),0.01d0/ewt(i))
            y(i) = y(i) + r
 210      continue
          call res (neq, tn, y, s, rtem, ires)
          nre = nre + 1
          if (ires .gt. 1) go to 600
          do 215 i = 1,n
 215        rtem(i) = rtem(i) - savr(i)
          k1 = k
          do 230 i = j1,n,mwid
c           get jacobian elements in column i (block-column k1). -------
            y(i) = yh(i,1)
            r = dmax1(srur*dabs(y(i)),0.01d0/ewt(i))
            fac = -hl0/r
c           compute and load elements pa(*,j,k1). ----------------------
            iia = i - j
            ipa = 2 + (j-1)*mb + (k1-1)*mbsq
            do 221 j2 = 1,mb
 221          wm(ipa+j2) = rtem(iia+j2)*fac
            if (k1 .le. 1) go to 223
c           compute and load elements pb(*,j,k1-1). --------------------
            iib = iia - mb
            ipb = ipa + lblox - mbsq
            do 222 j2 = 1,mb
 222          wm(ipb+j2) = rtem(iib+j2)*fac
 223        continue
            if (k1 .ge. nb) go to 225
c           compute and load elements pc(*,j,k1+1). --------------------
            iic = iia + mb
            ipc = ipa + 2*lblox + mbsq
            do 224 j2 = 1,mb
 224          wm(ipc+j2) = rtem(iic+j2)*fac
 225        continue
            if (k1 .ne. 3) go to 227
c           compute and load elements pc(*,j,1). -----------------------
            ipc = ipa - 2*mbsq + 2*lblox
            do 226 j2 = 1,mb
 226          wm(ipc+j2) = rtem(j2)*fac
 227        continue
            if (k1 .ne. nb-2) go to 229
c           compute and load elements pb(*,j,nb). ----------------------
            iib = n - mb
            ipb = ipa + 2*mbsq + lblox
            do 228 j2 = 1,mb
 228          wm(ipb+j2) = rtem(iib+j2)*fac
 229      k1 = k1 + 3
 230      continue
 240    continue
 250  continue
c res call for first corrector iteration. ------------------------------
      ires = 1
      call res (neq, tn, y, s, savr, ires)
      nre = nre + 1
      if (ires .gt. 1) go to 600
c add matrix a. --------------------------------------------------------
 260  continue
      call adda (neq, tn, y, mb, nb, wm(3), wm(lpb), wm(lpc))
c do lu decomposition on p. --------------------------------------------
      call decbt (mb, nb, wm(3), wm(lpb), wm(lpc), iwm(21), ier)
      if (ier .ne. 0) ierpj = 1
      return
c error return for ires = 2 or ires = 3 return from res. ---------------
 600  ierpj = ires
      return
c----------------------- end of subroutine pjibt -----------------------
      end


      SUBROUTINE PW92XC( IREL, NSPIN, DENS, EPSX, EPSC, VX, VC )

C ********************************************************************
C Implements the Perdew-Wang'92 LDA/LSD exchange correlation
C Ref: J.P.Perdew & Y.Wang, PRB, 45, 13244 (1992)
C Written by L.C.Balbas and J.M.Soler. Dec'96. Version 0.5.
C ********* INPUT ****************************************************
C INTEGER IREL        : Relativistic-exchange switch (0=No, 1=Yes)
C INTEGER NSPIN       : Number of spin polarizations (1 or 2)
C REAL*8  DENS(NSPIN) : Local (spin) density
C ********* OUTPUT ***************************************************
C REAL*8  EPSX       : Exchange energy density
C REAL*8  EPSC       : Correlation energy density
C REAL*8  VX(NSPIN)  : Exchange (spin) potential
C REAL*8  VC(NSPIN)  : Correlation (spin) potential
C ********* UNITS ****************************************************
C Densities in electrons per Bohr**3
C Energies in Hartrees
C ********* ROUTINES CALLED ******************************************
C EXCHNG, PW92C
C ********************************************************************

      IMPLICIT          NONE
      INTEGER           IREL, NSPIN
      DOUBLE PRECISION  DENS(NSPIN), EPSX, EPSC, VC(NSPIN), VX(NSPIN)

      CALL EXCHNG( IREL, NSPIN, DENS, EPSX, VX )
      CALL PW92C( NSPIN, DENS, EPSC, VC )
      END


      subroutine genclust_hqrk(q,Rmin,qfinal,isub)
c--- performs the appropriate clustering with cones for the
c--- W+b+jet processes
c--- This is a much simpler version than the full routines, but
c--- the logic is much easier to follow
c--- To reject an event, return jets=-1
      implicit none
      include 'constants.f'
      include 'npart.f'
      include 'jetcuts.f'
      include 'jetlabel.f'
      include 'plabel.f'
      include 'first.f'
      include 'nproc.f'
      double precision q(mxpart,4),qjet(mxpart,4),qfinal(mxpart,4)
      double precision pt,Rmin,R,Ry,Rbbmin,aetarap,ayrap
      double precision rtest,rab,raptest
      integer isub,i,j,k,nu,icandj,maxjet,jetindex(mxpart),ia,ib
      logical jetmerge,verbalg,pseudo,bjetmerge,is_hadronic
      common/Rbbmin/Rbbmin
      common/jetmerge/jetmerge
!$omp threadprivate(/jetmerge/)

      verbalg=.false.

      pseudo=.true.

      if (first) then
        if (pseudo) then
      write(6,*) 'Heavy quark clustering routine using pseudorapidity'
      else
      write(6,*) 'Heavy quark clustering routine using rapidity'
      endif
      write(6,*) '     (for both cuts and definition of Delta-R)'
      first=.false.
      endif

c--- transfer incoming and lepton momenta to the final array
      do j=1,4
        do nu=1,4
          qfinal(j,nu)=q(j,nu)
        enddo
      enddo

c--- simple clustering algorithm designed for WQj and ZQj
      jetmerge=.false.
      bjetmerge=.false.
      maxjet=0
c--- pick out jets: note that we search to npart+2-isub, to get the
c--- number of particles right. Note that isub=0 for all calls except
c--- the dipole contributions, where isub=1.
      do i=3,npart+2-isub
      if (is_hadronic(i)) then
        maxjet=maxjet+1
        jetindex(maxjet)=i
        jetlabel(maxjet)=plabel(i)
        do nu=1,4
          qjet(maxjet,nu)=q(i,nu)
        enddo
      endif
      enddo

c--- for the WQj(+Q) and ZQj(+Q) processes, the dipole subtraction
c--- terms contain just a b-quark and an untagged jet
      if ( (nproc .eq. 312) .or. (nproc .eq. 317)
     . .or.(nproc .eq. 322) .or. (nproc .eq. 327)
     . .or.(nproc .eq. 342) .or. (nproc .eq. 352) ) then
        if (isub .eq. 1)  jetlabel(2)='pp'
      endif

************************************************************************
c--- To check the ALPGEN total inclusive number
c      jets=-1
c      if ((pt(3,qjet) .lt. ptjetmin).or.(ayrap(3,qjet) .gt. etajetmax))
c     .  return
c      if ((Ry(qjet,1,3) .gt. Rmin) .and.
c     . (pt(1,qjet) .gt. ptjetmin).and.(ayrap(1,qjet) .lt. etajetmax))
c     . jets=2
c      if ((Ry(qjet,2,3) .gt. Rmin) .and.
c     . (pt(2,qjet) .gt. ptjetmin).and.(ayrap(2,qjet) .lt. etajetmax))
c     . jets=2
c      if (Ry(qjet,1,2) .gt. Rbbmin) return
c      do nu=1,4
c        qjet(4,nu)=qjet(1,nu)+qjet(2,nu)
c      enddo
c      if ((Ry(qjet,4,3) .gt. Rmin) .and.
c     . (pt(4,qjet) .gt. ptjetmin).and.(ayrap(4,qjet) .lt. etajetmax))
c     . jets=2
c      return
************************************************************************

c--- this is the number of candidate jets in the array qjet
      icandj=maxjet
c--- skip clustering if there are less than 2 jets
      if (icandj .lt. 2) then
        goto 77
c        write(6,*) 'Error in genclust_wbjt.f - icandj too small'
c        pause
      endif

      if (verbalg) write(6,*) 'Rmin=',Rmin
      if (verbalg) write(6,*) 'Rbbmin=',Rbbmin

c--- start another iteration
   66 continue

      if (verbalg) write(6,*) 'Starting iteration, # of cands =',icandj

c--- find the jet pair that meets the merging requirements and has
c--- the minimum separation in R
      rab=999d0
      ia=0
      ib=0
      jetmerge=.false.
      do j=1,icandj
      do k=j+1,icandj
        if (pseudo) then
          rtest=R(qjet,j,k)   ! Uses pseudorapidity
      else
          rtest=Ry(qjet,j,k)  ! Uses rapidity
      endif
        if (verbalg) write(6,*) jetlabel(j),',',jetlabel(k),' R =',rtest
c--- check to see if this pair should be merged - pair of b quarks
        if ( ((jetlabel(j).eq.'bq') .and. (jetlabel(k).eq.'ba'))
     .   .or.((jetlabel(j).eq.'ba') .and. (jetlabel(k).eq.'bq')) ) then
          if (rtest .lt. Rbbmin) then
            jetmerge=.true.
c--- ...... reset minimum separation if necessary
            if (rtest .lt. rab) then
              rab=rtest
              ia=j
              ib=k
            endif
          endif
c--- check to see if this pair should be merged - non b quarks
        else
          if (rtest .lt. Rmin) then
            jetmerge=.true.
          endif
c--- ...... reset minimum separation if necessary
          if (rtest .lt. rab) then
            rab=rtest
            ia=j
            ib=k
          endif
        endif
      enddo
      enddo

c--- if no jets need to be merged, we're done here
      if (jetmerge .eqv. .false.) goto 77

c--- check for an error
      if ((ia .eq. 0) .or. (ib .eq. 0)) then
        write(6,*) 'Error in genclust_wbjt: one of ia and ib is 0'
        stop
      endif

c--- if two b's will be merged, set the flag
      if ( ((jetlabel(ia).eq.'bq') .and. (jetlabel(ib).eq.'ba'))
     . .or.((jetlabel(ia).eq.'ba'). and. (jetlabel(ib).eq.'bq')) ) then
            bjetmerge=.true.
      endif
c--- do merging
c--- ...... set label for merged jet
      if     ((jetlabel(ia) .eq. 'bq').or.(jetlabel(ib) .eq. 'bq')) then
        jetlabel(ia)='bq'
      elseif ((jetlabel(ia) .eq. 'ba').or.(jetlabel(ib) .eq. 'ba')) then
        jetlabel(ia)='ba'
      else
        jetlabel(ia)='pp'
      endif
c--- ...... merge momenta for merged jet
      do nu=1,4
        qjet(ia,nu)=qjet(ia,nu)+qjet(ib,nu)
      enddo
c--- ...... shuffle down the other jets
      do j=ib,icandj-1
        jetlabel(ib)=jetlabel(ib+1)
        do nu=1,4
          qjet(j,nu)=qjet(j+1,nu)
        enddo
      enddo
c--- ...... remove a jet from the end
      do nu=1,4
        qjet(icandj,nu)=0d0
      enddo
      icandj=icandj-1

c--- return to the next iteration if there is more than one jet left
      if (icandj .gt. 1) goto 66

c--- done with the clustering - just need to check pt and y now
   77 continue

      if (verbalg) write(6,*) 'After merging # of jets =',icandj

c--- set the "jetmerge" flag properly now
      if (icandj .lt. maxjet) then
        jetmerge=.true.
      else
        jetmerge=.false.
      endif

c--- now check jet pt and rapidity
      do i=1,icandj
        if (pseudo) then
        raptest=aetarap(i,qjet)
      else
        raptest=ayrap(i,qjet)
      endif
c--- .... for b-quarks
        if ((jetlabel(i) .eq. 'bq') .or. (jetlabel(i) .eq. 'ba')) then
          if ( (pt(i,qjet) .lt. ptbjetmin)
     .    .or. (raptest .gt. etabjetmax)) jetlabel(i)='ff'
c--- .... for generic jets
        else
          if ( (pt(i,qjet) .lt. ptjetmin)
     .    .or. (raptest .gt. etajetmax)) jetlabel(i)='ff'
        endif
        if (verbalg) write(6,*) jetlabel(i),pt(i,qjet),raptest
      enddo

c--- the final reckoning: transfer to qfinal
      jets=0
      do i=1,icandj
        if (jetlabel(i) .ne. 'ff') then
          jets=jets+1
          do nu=1,4
            qfinal(jetindex(i),nu)=qjet(i,nu)
          enddo
        endif
      enddo

c--- shuffle down jetlabel
      i=1
   88 continue
      if (jetlabel(i) .eq. 'ff') then
        do j=i,icandj-1
          jetlabel(j)=jetlabel(j+1)
        enddo
      endif
      if (i .lt. jets) then
        i=i+1
        goto 88
      endif

      if (verbalg) write(6,*) 'After pt and y # of jets =',jets
c      if (verbalg) pause

c--- now we have to do process-specific cuts

************************************************************************
c--- W(QQ) for inclusive Wb
************************************************************************
      if ((nproc .eq. 301) .or. (nproc .eq. 306)) then
c--- In this category, there should be just one jet, formed by merging
        if ((jets .ne. 1) .or. (jetmerge .eqv. .false.)) then
          jets=-1
        endif
        return
      endif

************************************************************************
c--- WQ(+Q) for inclusive Wb
************************************************************************
      if ((nproc .eq. 302) .or. (nproc .eq. 307)) then
c--- In this category, there should be just one jet, formed by merging
        if ((jets .ne. 1) .or. (jetmerge)) then
          jets=-1
        endif
        return
      endif

************************************************************************
c--- WQQ/ZQQ + extra jet in real
************************************************************************
      if ((nproc .eq. 21) .or. (nproc .eq. 26)
     ..or.(nproc .eq. 51) .or. (nproc .eq. 56)) then
c--- In this category, there should be at least two jets, both b-quarks
        if (jets .lt. 2) then
          jets=-1
        endif
c--- only need to check jet identities if there are just 2 jets
        if (jets .eq. 2) then
        if (((jetlabel(1) .eq. 'bq').and.(jetlabel(2) .eq. 'ba'))
     . .or. ((jetlabel(1) .eq. 'ba').and.(jetlabel(2) .eq. 'bq'))) then
          continue
        else
          jets=-1
        endif
        endif
        return
      endif

************************************************************************
c--- WQQj/ZQjj/ZQQj
************************************************************************
      if ( (nproc .eq.  24) .or. (nproc .eq.  29)
     . .or.(nproc .eq. 346) .or. (nproc .eq. 347)
     . .or.(nproc .eq. 356) .or. (nproc .eq. 357)) then
c--- In this category, there should be three jets
        if (jets .lt. 3) then
          jets=-1
        endif
        return
      endif

************************************************************************
c--- WQj/ZQj - basic LO process + extra jet in real
************************************************************************
      if ( (nproc .eq. 311) .or. (nproc .eq. 316)
     . .or.(nproc .eq. 321) .or. (nproc .eq. 326)
     . .or.(nproc .eq. 341) .or. (nproc .eq. 351) ) then
c--- In this category, there should be two jets, one of which is a b
        if (jets .lt. 2) then
          jets=-1
        endif
c--- only need to check jet identities if there are just 2 jets
        if (jets .eq. 2) then
        if (((jetlabel(1) .eq. 'bq').and.(jetlabel(2) .eq. 'pp'))
     . .or. ((jetlabel(1) .eq. 'ba').and.(jetlabel(2) .eq. 'pp'))
     . .or. ((jetlabel(1) .eq. 'pp').and.(jetlabel(2) .eq. 'bq'))
     . .or. ((jetlabel(1) .eq. 'pp').and.(jetlabel(2) .eq. 'ba'))) then
          continue
        else
          jets=-1
        endif
        endif
        return
      endif

************************************************************************
c--- WQj/ZQj - basic LO process + extra Q in real
************************************************************************
      if ( (nproc .eq. 312) .or. (nproc .eq. 317)
     . .or.(nproc .eq. 322) .or. (nproc .eq. 327)
     . .or.(nproc .eq. 342) .or. (nproc .eq. 352) ) then
c--- In this category, there should be two jets, one of which is a b
c--- The cut on the Delta_R of the original b-bbar, to split the PS,
c--- is performed in "realint.f", so that neither the real contribution
c--- nor the counterterms are included in that case
c        if ((Ry(q,5,6) .lt. Rbbmin) .and. (isub .eq. 0)) then
c          jets=-1
c        endif
        if (jets .lt. 2) then
          jets=-1
        endif
c--- only need to check jet identities if there are just 2 jets
        if (jets .eq. 2) then
        if (((jetlabel(1) .eq. 'bq').and.(jetlabel(2) .eq. 'pp'))
     . .or. ((jetlabel(1) .eq. 'ba').and.(jetlabel(2) .eq. 'pp'))
     . .or. ((jetlabel(1) .eq. 'pp').and.(jetlabel(2) .eq. 'bq'))
     . .or. ((jetlabel(1) .eq. 'pp').and.(jetlabel(2) .eq. 'ba'))) then
          continue
        else
          jets=-1
        endif
        endif
        return
      endif

************************************************************************
c--- To check the ALPGEN approach to producing WQj
************************************************************************
c      if ((nproc .eq. 313) .or. (nproc .eq. 318)) then
c--- In this category, there should be two jets, one of which is a b
c--- jets should not have been merged
c        if ((jets .ne. 2) .or. (jetmerge .eqv. .true.)) then
c          jets=-1
c        endif
c        if (((jetlabel(1) .eq. 'bq').and.(jetlabel(2) .eq. 'ba'))
c     . .or. ((jetlabel(1) .eq. 'ba').and.(jetlabel(2) .eq. 'bq'))) then
c          jets=-1
c        endif
c        return
c      endif

************************************************************************
c--- W(QQ)j
************************************************************************
      if ((nproc .eq. 313) .or. (nproc .eq. 318)) then
c--- In this category, there should be two jets, one of which is a b
c--- also, jets should have been merged, not missed because of pt or y
        if ((jets .ne. 2) .or. (jetmerge .eqv. .false.)) then
          jets=-1
        endif
        if (((jetlabel(1) .eq. 'bq').and.(jetlabel(2) .eq. 'ba'))
     . .or. ((jetlabel(1) .eq. 'ba').and.(jetlabel(2) .eq. 'bq'))) then
          jets=-1
        endif
        return
      endif

************************************************************************
c--- WQjj
************************************************************************
      if ( (nproc .eq. 314) .or. (nproc .eq. 319)
     . .or.(nproc .eq. 324) .or. (nproc .eq. 329) ) then
c--- In this category, there should be three jets
        if (jets .lt. 3) then
          jets=-1
        endif
        return
      endif

      return
      end

      double precision function ry(p,i,j)
c---- calculate the jets separation between p(i) and p(j)
c--- Modification of "r.f" to use rapidity rather than pseudorapidity
      implicit none
      include 'constants.f'
      double precision p(mxpart,4),r1,r2,dely,delphi,ei,ej
      integer i,j

      ei=p(i,4)
      ej=p(j,4)

      r1= (ei+p(i,3))*(ej-p(j,3))/
     .   ((ej+p(j,3))*(ei-p(i,3)))
      dely=0.5d0*dlog(r1)

      r2= (p(i,1)*p(j,1)+p(i,2)*p(j,2))
     .   /dsqrt((p(i,1)**2+p(i,2)**2)*(p(j,1)**2+p(j,2)**2))
      if (r2 .gt. +0.999999999D0) r2=+1D0
      if (r2 .lt. -0.999999999D0) r2=-1D0
      delphi=dacos(r2)

      ry=dsqrt(dely**2+delphi**2)

      return
      end


      subroutine pot(symb,x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)

      implicit real*8(a-h,o-z)
      dimension x(maxatom),y(maxatom),z(maxatom)
      dimension x2(maxatom),y2(maxatom),z2(maxatom)
      dimension x3(maxatom),y3(maxatom),z3(maxatom)
      dimension dvdx(maxatom),dvdy(maxatom),dvdz(maxatom)
      dimension dvdx2(maxatom),dvdy2(maxatom),dvdz2(maxatom)
      dimension dvdx3(maxatom),dvdy3(maxatom),dvdz3(maxatom)
      parameter(autoev=27.2113961d0)
      parameter(autocmi=219474.63067d0)
      parameter(autoang=0.529177249d0)
      character*2 symb(maxatom),symb2(maxatom),symb3(maxatom)
      integer at(maxatom),at2(maxatom),at3(maxatom)

      dimension tmpprint(50)
      common/tmp/tmpprint

      v=0.d0
      v2=0.d0
      v3=0.d0
      do i=1,natom
      symb2(i)="xx"
      symb3(i)="xx"
      x2(i)=0.d0
      y2(i)=0.d0
      z2(i)=0.d0
      x3(i)=0.d0
      y3(i)=0.d0
      z3(i)=0.d0
      dvdz2(i)=0.d0
      dvdy2(i)=0.d0
      dvdx2(i)=0.d0
      dvdz3(i)=0.d0
      dvdy3(i)=0.d0
      dvdx3(i)=0.d0
      dvdz(i)=0.d0
      dvdy(i)=0.d0
      dvdx(i)=0.d0
      enddo

      do i=1,natom
      at(i)=0
      if ((symb(i).eq."H").or.
     &    (symb(i).eq."h"))  at(i)=1       ! hydrogen
      if ((symb(i).eq."C").or.
     &    (symb(i).eq."c"))  at(i)=2       ! carbon
      if ((symb(i).eq."O").or.
     &    (symb(i).eq."o"))  at(i)=4       ! oxygen
      if ((symb(i).eq."HO").or.
     &    (symb(i).eq."Ho"))  at(i)=5       ! OH H
      if ((symb(i).eq."Oh").or.
     &    (symb(i).eq."oh"))  at(i)=6       ! R-O-O*-H ; *this one
      if ((symb(i).eq."He").or.
     &    (symb(i).eq."he").or.
     &    (symb(i).eq."HE")) at(i)=21      ! helium
      if ((symb(i).eq."Ar").or.
     &    (symb(i).eq."ar").or.
     &    (symb(i).eq."AR")) at(i)=23      ! argon
      if (at(i).eq.0) then ! atom not found
           write(6,*)"Atom # ",i," (",symb(i),") not found"
           stop
      endif
      enddo

      natom2=0
      natom3=0
      do i=1,natom
        if (at(i).le.20) then ! collect target atoms
          natom2=natom2+1
          x2(natom2)=x(i)
          y2(natom2)=y(i)
          z2(natom2)=z(i)
          symb2(natom2)=symb(i)
          at2(natom2)=at(i)
        else ! collect bath atoms
          natom3=natom3+1
          x3(natom3)=x(i)
          y3(natom3)=y(i)
          z3(natom3)=z(i)
          symb3(natom3)=symb(i)
          at3(natom3)=at(i)
        endif
      enddo
c      print *,natom,natom2,natom3
c      if (natom3.ne.0)
c     &   call bath(at3,x3,y3,z3,v3,dvdx3,dvdy3,dvdz3,natom3,maxatom)
c      if (natom2.ne.0)
c     &   call tinkerpot(symb2,x2,y2,z2,v2,dvdx2,dvdy2,dvdz2,
c     &          natom2,maxatom)
      if (natom3.ne.0)
     &   call rgexp(at,x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)

      tmpprint(1)=v    ! interaction

      v=v+v2+v3

      natom2=0
      natom3=0
      do i=1,natom
        if (at(i).le.20) then
        natom2=natom2+1
c        print *,i,dvdx2(i),dvdy2(i),dvdz2(i)
        dvdx(i)=dvdx(i)+dvdx2(natom2)
        dvdy(i)=dvdy(i)+dvdy2(natom2)
        dvdz(i)=dvdz(i)+dvdz2(natom2)
        else
        natom3=natom3+1
        dvdx(i)=dvdx(i)+dvdx3(natom3)
        dvdy(i)=dvdy(i)+dvdy3(natom3)
        dvdz(i)=dvdz(i)+dvdz3(natom3)
        endif
      enddo

      return

      end

      subroutine bath(at,x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)

      implicit real*8(a-h,o-z)
      parameter(autoev=27.2113961d0)
      parameter(autocmi=219474.63067d0)
      dimension x(maxatom),y(maxatom),z(maxatom)
      dimension dvdx(maxatom),dvdy(maxatom),dvdz(maxatom)
      integer at(maxatom)

      v=0.
      do i=1,natom
        dvdx(i)=0.d0
        dvdy(i)=0.d0
        dvdz(i)=0.d0
      enddo

      if (natom.eq.1) return

      if (natom.gt.2) then
         print *,"Can't handle more than 2 bath atoms"
         stop
      endif

      if (natom.eq.2) then
      dx=x(1)-x(2)
      dy=y(1)-y(2)
      dz=z(1)-z(2)
      rr=dsqrt(dx*dx+dy*dy+dz*dz)  ! au

        if (at(1).eq.25.and.at(2).eq.25) then
!       H2 bath
!       From Hack's fit (eq 8 in Hack, Truhlar, JCP 110, 4315 (1999))
!                        to Kolos and Wolniewicz JCP 43, 2429 (1965)
!       Rmin = 1.40121 au, Vmin = -4.74772265 eV relative to H+H
        c1=139.7160d0        ! eV
        c2=-123.8978d0       ! eV / bohr
        c3=3.4031d0          ! 1 / bohr
        c4=-6.8725d0         ! eV / bohr**2
        c5=-23.0440d0        ! eV / bohr**3
        c6=2.032d0           ! 1 / bohr

        v=(c1+c2*rr)*dexp(-c3*rr)
     &   +(c4+c5*rr)*dexp(-c6*rr)*rr**2
c       move zero from asymptote to minimum
        v=v+4.74772265
c        print *,rr,v
        v=v/autoev

        dvdr=((c1+c2*rr)*(-c3)+c2)*dexp(-c3*rr)
     &      +((c4+c5*rr)*(-c6)+c5)*dexp(-c6*rr)*rr**2
     &       +(c4+c5*rr)*dexp(-c6*rr)*rr*2.d0
        dvdr=dvdr/autoev

        elseif (at(1).eq.26.and.at(2).eq.26) then
!       N2 bath
!       fit to MRCI+Q/CBS(AQZ,A5Z) full valence
!       agrees reasonably well with more complicated form of LeRoy (JCP 125, 164310 (2006))
!       Jasper June 9, 2010
        de=79845.d0 ! exp De in cm-1 (Ronin, Luanay, Larzillier, PRL 53, 159 (1984), as quoted by LeRoy)
        re=1.097679d0 ! exp
        c1=2.68872341 ! my fit
        c2=0.240070803
        c3=0.472261727

        yy=rr*autoang-re
        beta = c1+c2*yy+c3*yy**2
        v = de*(1.d0-dexp(-beta*yy))**2-de    ! A and cm-1
        v=v/autocmi  ! convert to au

        dvdr = 2.d0*de*(1.d0-dexp(-beta*yy))*dexp(-beta*yy)*beta
        dvdr=dvdr*autocmi/autocmi  ! convert to au

!       elseif (at(1).eq.??.and.at(2).eq.??) then
!       OTHER DIATOMIC BATHS HERE
        else
        print *,"Don't know this diatomic bath"
        stop
        endif

      dvdx(1) =  dvdr*dx/rr
      dvdx(2) = -dvdr*dx/rr
      dvdy(1) =  dvdr*dy/rr
      dvdy(2) = -dvdr*dy/rr
      dvdz(1) =  dvdr*dz/rr
      dvdz(2) = -dvdr*dz/rr

      endif

      return
      end

      subroutine rgexp(at,x,y,z,v,dvdx,dvdy,dvdz,natom,maxatom)
c Rare Gas exp6 potential subroutine
c loops over geometry and looks for Rg-X interactions
c returns the full Rg-target intermolecular potential and its derivatives

      implicit real*8(a-h,o-z)
      dimension x(maxatom),y(maxatom),z(maxatom)
      dimension dvdx(maxatom),dvdy(maxatom),dvdz(maxatom)
      parameter(autoev=27.2113961d0)
      parameter(autocmi=219474.63067d0)
      parameter(autokcal=627.509d0)
      parameter(autoang=0.529177249d0)
      integer at(maxatom)
      logical troya,cutoff

      v1=0.d0
      v=0.d0
      do i=1,natom
      dvdz(i)=0.d0
      dvdy(i)=0.d0
      dvdx(i)=0.d0
      enddo

      do 1 i=1,natom
      do 2 j=i+1,natom

      m1=min(at(i),at(j))
      m2=max(at(i),at(j))
      troya=.false.   ! do or don't use Troya's form
      cutoff=.false.   ! do or don't use cutoff

      if (m1.ge.21) then ! two rare gases, skip this pair
         go to 2
      endif
      if (m2.le.20) then ! no rare gas, skip this pair
         go to 2
      endif

      if (m2.eq.21) then      ! He-
        if     (m1.eq.1) then !    H
      aa =   6.1097750785851623
      bb =  0.24355296487319558
      cc =  0.57130649739066741
      rrc =   4.9487899410992764
          cutoff=.true.
          aa=(10.d0**aa)
        elseif (m1.eq.2) then !    C
      aa =   7.7760856959746087
      bb =  0.18836634418774989
      cc =   6.9083529160435804
      rrc =   3.2519913327433088
          cutoff=.true.
          aa=(10.d0**aa)
        elseif (m1.eq.4) then !    O
      aa =   6.9354838709677420
      bb =  0.23257240516373182
      cc =   5.4971160008545183
      rrc =   3.2503433332316050
          cutoff=.true.
          aa=(10.d0**aa)
        elseif (m1.eq.5) then !    Ho
      aa=   6.5426496169927058
      bb =  0.21896114993743707
      cc =   2.6139103366191594
      rrc =   19.737327188940093
          cutoff=.true.
          aa=(10.d0**aa)
        elseif (m1.eq.6) then !    Oh
      aa =   6.9999389629810480
      bb =  0.23460798974578081
      cc =   6.2474440748313853
      rrc =   3.3750724814600055
          cutoff=.true.
          aa=(10.d0**aa)
        else
          write(6,*)"Cant find a He-? interaction"
          stop
        endif
      elseif (m2.eq.23) then  ! Ar-
        if     (m1.eq.1) then !    H
      aa=   6.4882045960875274
      bb=  0.28126468703268531
      cc=   7.3052156132694481
      rrc=   3.3750724814600055
          aa=(10.d0**aa)
          cutoff=.true.
        elseif (m1.eq.2) then !    C
      aa=   9.0000000000000000
      bb=  0.19531235694448684
      cc=   7.7499313333536790
      rrc=   3.2500686666463210
          aa=(10.d0**aa)
          cutoff=.true.
        elseif (m1.eq.4) then !    O
      aa=   8.4999847407452620
      bb=  0.21405987731559192
      cc=   8.0056459242530593
      rrc=   3.2506179998168889
          aa=(10.d0**aa)
          cutoff=.true.
        elseif (m1.eq.5) then !    Ho
      aa=   6.4882045960875274
      bb=  0.28126468703268531
      cc=   7.3052156132694481
      rrc=   3.3750724814600055
          cutoff=.true.
          aa=(10.d0**aa)
        elseif (m1.eq.6) then !    Oh
      aa=   8.4999847407452620
      bb=  0.21405987731559192
      cc=   8.0056459242530593
      rrc=   3.2506179998168889
          cutoff=.true.
          aa=(10.d0**aa)
        else
          write(6,*)"Cant find a Ar-? interaction"
          stop
        endif
      else
          write(6,*)"Cant find a ?-? interaction"
          stop
      endif

      dx=x(i)-x(j)
      dy=y(i)-y(j)
      dz=z(i)-z(j)
      rr=dsqrt(dx*dx+dy*dy+dz*dz)
      rra=rr*autoang

! NOTE CANNOT HAVE BOTH TROYA FORM AND CUTOFF FORM

      if (troya) then   ! Troya uses different form & units
        v=aa*dexp(-rra*bb)+cc/rra**6
        v=v/autokcal
        dvdr = -aa*bb*dexp(-rra*bb)-6.d0*cc/rra**7
        dvdr=dvdr/autokcal*autoang
      elseif (cutoff) then  ! cutoff 1/R**-6 at short distances
        v=aa*dexp(-rra/bb)-(cc**6/(rra**6+rrc**6))
        v=v/autocmi
        dvdr = -aa/bb*dexp(-rra/bb)
     &      +6.d0*(cc**6)*(rra**5)/(rra**6+rrc**6)**2
        dvdr=dvdr/autocmi*autoang
      else
        v=aa*dexp(-rra/bb)-(cc/rra)**6
        v=v/autocmi
        dvdr = -aa/bb*dexp(-rra/bb)+(6.d0/rra)*(cc/rra)**6
        dvdr=dvdr/autocmi*autoang
      endif
        v1=v1+v

c      print *,m1,m2,rra,v*autocmi,v1*autocmi

c derivs = sum over all bonds (DV/DRij * DRij/DXi = DV/DRij * (Xi-Xj)/Rij)
      dvdx(i) = dvdx(i) + dvdr*dx/rr
      dvdx(j) = dvdx(j) - dvdr*dx/rr
      dvdy(i) = dvdy(i) + dvdr*dy/rr
      dvdy(j) = dvdy(j) - dvdr*dy/rr
      dvdz(i) = dvdz(i) + dvdr*dz/rr
      dvdz(j) = dvdz(j) - dvdr*dz/rr

    2 continue
    1 continue
      v=v1
c      print *,'rgexp',v1
      return
      end


C Collects all of the Les Houches interface routines, plus utilities
C for colour codes
C Should be backward compatible with v3.1 and v3.2 (thanks to B. Kersevan)
C
C----------------------------------------------------------------------
      SUBROUTINE MCATNLOUPEVNT(IPROC,EXITCODE,IHPRO)
C----------------------------------------------------------------------
C  Reads MC@NLO input files and fills Les Houches event common HEPEUP
C----------------------------------------------------------------------

C----------------------------------------------------------------------
CCC MOFIFICATIONS FOR CMSSW, FST
C      INCLUDE 'HERWIG65.INC'
C---Les Houches Event Common Block
      IMPLICIT NONE
      INTEGER IPROC, IERROR, EXITCODE
      DOUBLE PRECISION ZERO,ONE,TWO,THREE,FOUR,HALF
      PARAMETER (ZERO =0.D0, ONE =1.D0, TWO =2.D0,
     &           THREE=3.D0, FOUR=4.D0, HALF=0.5D0)
      INTEGER ICHRG(5)
C*********  TO TAKE CARE OF
      DOUBLE PRECISION RMASS(1000)
      INTEGER IHPRO
C----------------------------------------------------------------------

      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP,
     & XMP2,XMA2,XMB2,BETA,VA,VB,SIGMA,DELTA,S2,XKA,XKB,PTF,E,PL,
     & XSCALE,XEPHO
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,
     &              IDUP(MAXNUP),ISTUP(MAXNUP),MOTHUP(2,MAXNUP),
     &              ICOLUP(2,MAXNUP),PUP(5,MAXNUP),VTIMUP(MAXNUP),
     &              SPINUP(MAXNUP)
      DOUBLE PRECISION PCM(5),PTR,XMTR,HWVDOT,HWULDO,PDB(5)
      INTEGER I,J,IC,JPR,MQQ,NQQ,IUNIT,ISCALE,I1HPRO,IBOS,NP,IG,IP,
     & ILEP,ID,IA,IB,ICOL4(4,5),ICOL5(5,18),ICOP5(5,4),ICOST(4,20),
     & IVBF4(4,4),IVBF5(5,8,2),JJPROC,IVHVEC,IVHLEP,MUP,JC
      PARAMETER (IUNIT=61)
      LOGICAL BOPRO,NODEC,REMIT
      COMMON/NQQCOM/MQQ,NQQ
      COMMON/VHLIN/IVHVEC,IVHLEP
      COMMON/PHOCOM/XEPHO

C-------------------- FIX FOR CHARGE CORRECTIONS (only for 1497)
      DATA ICHRG/
     & -1, 2, -1, 2, -1/
C-------------------------------------------------------------------

C---Colour flows for heavy quark pair production
      DATA ICOL4/
     & 10,02,10,02,01,20,20,01,12,23,10,03,12,31,30,02,00,12,10,02/
      DATA ICOL5/
     & 10,02,13,30,02, 10,02,32,10,03,
     & 10,21,30,20,03, 10,23,20,10,03,
     & 01,20,23,30,01, 01,20,31,20,03,
     & 01,23,03,20,01, 01,12,03,30,02,
     & 12,20,30,10,03, 12,30,10,30,02,
     & 12,03,02,10,03, 12,01,03,30,02,
     & 12,23,14,40,03, 12,34,32,10,04,
     & 12,23,43,10,04, 12,31,34,40,02,
     & 12,34,14,30,02, 12,31,42,30,04/
C---Colour flows for heavy quark pair photoproduction
      DATA ICOP5/
     & 00,12,32,10,03, 00,12,13,30,02,
     & 00,10,20,10,02, 00,01,02,20,01/
C---Colour flows for single top production
      DATA ICOST/
     & 20,12,00,10, 12,20,00,10, 10,02,02,10, 02,10,02,10,
     & 20,10,20,10, 20,02,01,10, 10,20,20,10, 02,20,01,10,
     & 20,02,01,10, 10,02,02,10, 02,20,01,10, 02,10,02,10,
     & 20,10,20,10, 10,20,20,10, 12,23,03,10, 23,12,03,10,
     & 30,12,32,10, 30,23,21,10, 12,30,32,10, 23,30,21,10/
C---Colour flows for vector boson fusion
      DATA IVBF4/
     & 10,20,10,20, 10,02,10,02, 01,20,01,20, 01,02,01,02/
      DATA IVBF5/
     & 10,20,13,30,20, 10,02,13,30,02, 01,20,31,03,20, 01,02,31,03,02,
     & 12,30,10,02,30, 12,03,10,02,03, 10,23,20,10,03, 01,23,20,01,03,
     & 10,20,23,10,30, 10,02,32,10,03, 01,20,23,01,30, 01,02,32,01,03,
     & 12,30,02,10,30, 12,03,02,10,03, 10,23,03,10,20, 01,23,03,01,20/

C----- SANITY FOR CMSSW
      EXITCODE=0
      IERROR=0
      ID=0
      IG=0
      ISCALE=0
      IF (IERROR.NE.0) RETURN
C---CHECK PROCESS CODE
      JJPROC=MOD(ABS(IPROC),10000)
      JPR=JJPROC/100

C---READ AN EVENT
C      IF(NQQ.GE.MQQ)CALL HWWARN('UPEVNT',201)

C---------------------------------------------------------------
C*** changed for CMSSW: IF ALL EVENTS ARE READ IN, RETURN 0
      IF(NQQ.GE.MQQ) THEN
         EXITCODE=1
         RETURN
      ENDIF
C---------------------------------------------------------------

      READ(IUNIT,901) I1HPRO,IC,NP
      READ(IUNIT,902) (IDUP(I),I=1,NP)
      IF (JPR.EQ.51) THEN
         READ(IUNIT,903) XWGTUP,XSCALE,XEPHO
      ELSE
         READ(IUNIT,903) XWGTUP,XSCALE
      ENDIF
C---Les Houches expects mean weight to be the cross section in pb
      XWGTUP= XWGTUP*MQQ
      READ(IUNIT,904) ((PUP(J,I),J=1,4),I=1,NP)
      NQQ=NQQ+1
C---Input format is now (px,py,pz,m)
      DO I=1,NP
         E=SQRT(HWVDOT(4,PUP(1,I),PUP(1,I)))
         PUP(5,I)=PUP(4,I)
         PUP(4,I)=E
      ENDDO
      CALL HWVSUM(4,PUP(1,1),PUP(1,2),PCM)
      CALL HWUMAS(PCM)
C---REMIT MEANS A REAL PARTON EMISSION OCCURRED
      REMIT=PUP(4,3).NE.ZERO
C---NODEC MEANS DECAYS NOT YET DONE
      NODEC=NP.EQ.5
      NUP=NP
      BOPRO=JPR.EQ.13.OR.JPR.EQ.14.OR.JPR.EQ.16.OR.JPR.EQ.36
      IF (BOPRO) THEN
C----------------------------------------------------------------------
C   SINGLE GAUGE OR HIGGS BOSON PRODUCTION
C   B = Z/gamma, W or H (SM or any MSSM neutral Higgs)
C-----------------------------------------------------------------------
C I1HPRO IDENTIFIES THE PARTONIC SUBPROCESS, WITH THE FOLLOWING CONVENTIONS:
C   I1HPRO         PROCESS
C    401        q qbar -> g B
C    402        q g    -> q B
C    403        qbar q -> g B
C    404        qbar g -> qbar B
C    405        g q    -> q B
C    406        g qbar -> qbar B
C    407        g g    -> g B
C-----------------------------------------------------------------------
C---NODEC=.TRUE. FOR HIGGS AND UNDECAYED EW BOSON
         NODEC=NP.EQ.4
         IHPRO=I1HPRO-400
         ISCALE=0
         IF(JPR.EQ.16)ISCALE=2
      ELSEIF (JPR.EQ.17.OR.JPR.EQ.20.OR.JPR.EQ.51) THEN
C----------------------------------------------------------------------
C   HEAVY Q and/or QBAR PRODUCTION
C   IPROC=-1705,-1706 for Q=b,t
C   IPROC=-5105,-5106 for Q=b,t photoproduction
C   IPROC=-2000,-2030/1/4 for single top, Wt+Wtb/Wtb/Wt
C-----------------------------------------------------------------------
C I1HPRO IDENTIFIES THE PARTONIC SUBPROCESS, WITH THE FOLLOWING CONVENTIONS:
C   I1HPRO         PROCESS
C    401        q qbar -> g Q Qbar
C    402        q g    -> q Q Qbar
C    403        qbar q -> g Q Qbar
C    404        qbar g -> qbar Q Qbar
C    405        g q    -> q Q Qbar
C    406        g qbar -> qbar Q Qbar
C    407        g g    -> g Q Qbar
C    408        q q    -> g t q
C    409        qbar qbar -> g tbar qbar
C-----------------------------------------------------------------------
C    505        gamma q    -> q Q Qbar
C    506        gamma qbar -> qbar Q Qbar
C    507        gamma g    -> g Q Qbar
C-----------------------------------------------------------------------
C IC SPECIFIES THE COLOUR CONNECTION (NOW IN INPUT FILE)
C-----------------------------------------------------------------------
C---SET IHPRO AS FOR DIRECT PHOTON (IPROC=1800)
         IHPRO=I1HPRO-360
         ISCALE=0
         IF(ABS(IPROC).EQ.1705.OR.ABS(IPROC).EQ.11705)ISCALE=5
      ELSEIF (JPR.EQ.19) THEN
C----------------------------------------------------------------------
C   Higgs production by vector boson fusion
C   IPROC=-1900-ID where ID controls Higgs decay
C-----------------------------------------------------------------------
C I1HPRO IDENTIFIES THE PARTONIC SUBPROCESS, WITH THE FOLLOWING CONVENTIONS:
C   I1HPRO         PROCESS
C    401        q q    -> g q q h
C    402        q qbar -> g q qbar h
C    403        qbar q -> g qbar q h
C    404        qbar qbar -> g qbar qbar h
C    405        g q    -> q qbar q h OR qbar q q h
C    406        g qbar -> q qbar qbar h OR qbar q qbar h
C    407        q g    -> q q qbar h OR qbar q q h
C    408        qbar g -> q qbar qbar h OR qbar qbar q h
C-----------------------------------------------------------------------
C IC SPECIFIES THE COLOUR CONNECTION (NOW IN INPUT FILE)
C For processes 401-4, IC = 1,2 for gluon (3) connection to parton IC
C For processes 405-8, IC = 1,2 for 'emitted' parton (3) = q,qbar
C-----------------------------------------------------------------------
         IHPRO=I1HPRO-400
C--Scale??
         ISCALE=0
      ELSEIF (JPR.EQ.28) THEN
C----------------------------------------------------------------------
C   GAUGE BOSON PAIR PRODUCTION
C   VV=WW,ZZ,ZW+,ZW- FOR IPROC=-2850,-2860,-2870,-2880
C-----------------------------------------------------------------------
C I1HPRO IDENTIFIES THE PARTONIC SUBPROCESS, WITH THE FOLLOWING CONVENTIONS:
C   I1HPRO         PROCESS
C    401        q qbar -> g V V
C    402        q g    -> q V V
C    403        qbar q -> g V V
C    404        qbar g -> qbar V V
C    405        g q    -> q V V
C    406        g qbar -> qbar V V
C-----------------------------------------------------------------------
         IHPRO=I1HPRO-400
         ISCALE=0
      ELSEIF (JPR.EQ.26.OR.JPR.EQ.27) THEN
C----------------------------------------------------------------------
C   GAUGE BOSON PLUS HIGGS PRODUCTION
C   VH=WH,ZH FOR IPROC=-2600-ID,-2700-ID
C   WHERE ID CONTROLS HIGGS DECAY AS IN STANDARD HERWIG
C-----------------------------------------------------------------------
         IHPRO=I1HPRO-400
         ISCALE=0
      ELSEIF (JPR.EQ.1) THEN
C----------------------------------------------------------------------
C   E+E- ANNIHILATION
C----------------------------------------------------------------------
         ISCALE=1
      ELSE
         CALL HWWARN('UPEVNT',202)
      ENDIF
C---HARD SCALE
      SCALUP=PCM(5)
      IF (XSCALE.GT.0D0.AND.XSCALE.LT.PCM(5)) SCALUP=XSCALE
      IF (REMIT) THEN
         IF (ISCALE.EQ.0) THEN
            PTR=SQRT(PUP(1,3)**2+PUP(2,3)**2)
            SCALUP=PCM(5)-2.*PTR
         ELSEIF(ISCALE.EQ.1)THEN
            SCALUP=PCM(5)
         ELSEIF (ISCALE.EQ.2) THEN
            SCALUP=SQRT(PUP(1,3)**2+PUP(2,3)**2)
         ELSEIF (ISCALE.EQ.3.OR.ISCALE.EQ.4.OR.ISCALE.EQ.5) THEN
            PTR=SQRT(PUP(1,3)**2+PUP(2,3)**2)
            IA=4
            IB=5
            XMP2=PUP(5,3)**2
            XMA2=PUP(5,IA)**2
            XMB2=PUP(5,IB)**2
            S2=XMA2+XMB2+2*HWULDO(PUP(1,IA),PUP(1,IB))
            SIGMA=XMA2+XMB2
            DELTA=XMA2-XMB2
            BETA=SQRT(1-2*SIGMA/S2+(DELTA/S2)**2)
            VA=BETA/(1+DELTA/S2)
            VB=BETA/(1-DELTA/S2)
            XKA=HWULDO(PUP(1,3),PUP(1,IA))
            XKB=HWULDO(PUP(1,3),PUP(1,IB))
            E=(XKA+XKB)/SQRT(S2)
            PL=-2.0/((VA+VB)*BETA*SQRT(S2))*(VA*XKA-VB*XKB)
            PTF=E**2-PL**2-XMP2
            IF (PTF.LE.ZERO) THEN
               CALL HWWARN('UPEVNT',103)
               GOTO 999
            ENDIF
            PTF=SQRT(PTF)
            IF(ISCALE.EQ.3)THEN
              SCALUP=PCM(5)-2.*MIN(PTR,PTF)
            ELSEIF(ISCALE.EQ.4)THEN
              SCALUP=MIN(PTR,PTF)
            ELSE
              SCALUP=(MIN(PTR,PTF))**2+(XMA2+XMB2)/2.D0
              SCALUP=SQRT(SCALUP)
            ENDIF
            IF (SCALUP.LE.ZERO) THEN
               CALL HWWARN('UPEVNT',100)
               GOTO 999
            ENDIF
         ELSEIF (ISCALE.EQ.6) THEN
            XMTR=SQRT(PUP(5,4)**2+PUP(1,4)**2+PUP(2,4)**2)
            PTR=SQRT(PUP(1,3)**2+PUP(2,3)**2)
            SCALUP=PCM(5)-PTR-XMTR
            IF (SCALUP.LE.ZERO) THEN
               CALL HWWARN('UPEVNT',100)
               GOTO 999
            ENDIF
         ELSEIF (ISCALE.EQ.7) THEN
            SCALUP=SQRT(PUP(5,4)**2+PUP(1,4)**2+PUP(2,4)**2)
         ELSE
            CALL HWWARN('UPEVNT',501)
         ENDIF
      ELSE
         NUP=NUP-1
      ENDIF
C---INITIAL STATE
      DO I=1,2
         ISTUP(I)=-1
         MOTHUP(1,I)=0
         MOTHUP(2,I)=0
      ENDDO
C---FINAL STATE
      DO I=3,NUP
         ISTUP(I)=1
         MOTHUP(1,I)=1
         MOTHUP(2,I)=2
      ENDDO
      IF (BOPRO.AND.NODEC) THEN
C---SINGLE BOSON (UNDECAYED)
         IF (REMIT) THEN
C---SET COLOUR CONNECTIONS
            DO I=1,3
               ICOLUP(1,I)=501
               ICOLUP(2,I)=502
            ENDDO
            IF (IHPRO.EQ.1) THEN
               ICOLUP(2,1)=0
               ICOLUP(1,2)=0
            ELSEIF (IHPRO.EQ.2) THEN
               ICOLUP(1,1)=502
               ICOLUP(2,1)=0
               ICOLUP(2,3)=0
            ELSEIF (IHPRO.EQ.3) THEN
               ICOLUP(1,1)=0
               ICOLUP(2,2)=0
            ELSEIF (IHPRO.EQ.4) THEN
               ICOLUP(1,1)=0
               ICOLUP(2,1)=501
               ICOLUP(1,3)=0
            ELSEIF (IHPRO.EQ.5) THEN
               ICOLUP(1,2)=502
               ICOLUP(2,2)=0
               ICOLUP(2,3)=0
            ELSEIF (IHPRO.EQ.6) THEN
               ICOLUP(1,2)=0
               ICOLUP(2,2)=501
               ICOLUP(1,3)=0
            ELSEIF (IHPRO.EQ.7) THEN
               ICOLUP(1,2)=502
               ICOLUP(2,2)=503
               ICOLUP(2,3)=503
            ELSE
               CALL HWWARN('UPEVNT',101)
               GOTO 999
            ENDIF
         ELSE
            CALL HWVEQU(5,PUP(1,4),PUP(1,3))
C---SET COLOUR CONNECTIONS
            DO I=1,2
               ICOLUP(1,I)=0
               ICOLUP(2,I)=0
            ENDDO
            IF (IDUP(1).GT.0) THEN
               ICOLUP(1,1)=501
               ICOLUP(2,2)=501
               IF (IDUP(1).GT.0) THEN
C---GG FUSION
                  ICOLUP(2,1)=502
                  ICOLUP(1,2)=502
               ENDIF
            ELSE
C---QBAR Q
               ICOLUP(2,1)=501
               ICOLUP(1,2)=501
            ENDIF
         ENDIF
         ICOLUP(1,NUP)=0
         ICOLUP(2,NUP)=0
C---LOAD BOSON ID
         IF (JPR.EQ.13) THEN
            IDUP(NUP)=23
         ELSEIF (JPR.EQ.16) THEN
            IDUP(NUP)=25
         ELSEIF (JPR.EQ.36) THEN
            IBOS=MOD(JJPROC,100)
            IF (IBOS.EQ.10) THEN
               IDUP(NUP)=26
            ELSEIF (IBOS.EQ.20) THEN
               IDUP(NUP)=35
            ELSEIF (IBOS.EQ.30) THEN
               IDUP(NUP)=36
            ELSE
               CALL HWWARN('UPEVNT',502)
            ENDIF
         ELSEIF (JPR.EQ.14) THEN
            IBOS=0
            DO I=1,NUP-1
               ID=IDUP(I)
C----------- SANITY CHECK DUE TO A HACK (FST, 21.3.2008)
               IF((ABS(ID).GT.5).AND.(ID.NE.21)) THEN
                  WRITE(*,*) 'FATAL ERROR IN UPEVNT'
                  STOP
C----------- END OF SANITY CHECK
               ENDIF
               IF (ID.EQ.21) THEN
                  IC=0
               ELSEIF (ID.GT.0) THEN
                  IC=ICHRG(ID)
               ELSE
C                  IC=ICHRG(6-ID)
                  IC=-ICHRG(ID)
               ENDIF
               IBOS=IBOS+IC
            ENDDO
            IF (REMIT) IBOS=IBOS-2*IC
            IF (ABS(IBOS).NE.3) CALL  HWWARN('UPEVNT',503)
            IDUP(NUP)=8*IBOS
         ENDIF
      ELSEIF (JPR.EQ.51.AND.IDUP(1).EQ.22) THEN
C---HEAVY QUARK DIRECT PHOTOPRODUCTION
         IF (REMIT) THEN
C---3-BODY FINAL STATE
C---SET COLOUR CONNECTIONS
            IF (IC.GE.4.AND.IC.LE.7) THEN
               JC=IC-3
               DO I=1,5
                  CALL UPCODE(ICOP5(I,JC),ICOLUP(1,I))
               ENDDO
            ELSE
               CALL HWWARN('UPEVNT',105)
               GOTO 999
            ENDIF
         ELSE
C---2-BODY FINAL STATE
            DO IP=3,NUP
               IDUP(IP)=IDUP(IP+1)
               CALL HWVEQU(5,PUP(1,IP+1),PUP(1,IP))
            ENDDO
C---SET COLOUR CONNECTIONS
            IF (IC.GE.1.AND.IC.LE.3) THEN
               JC=IC
               IF (IC.EQ.3) JC=5
               DO I=1,4
                  CALL UPCODE(ICOL4(I,JC),ICOLUP(1,I))
               ENDDO
            ELSE
               CALL HWWARN('UPEVNT',104)
               GOTO 999
            ENDIF
         ENDIF
      ELSEIF (JPR.EQ.19) THEN
C---HIGGS VIA VBF
         IF (REMIT) THEN
C---4-BODY FINAL STATE
C---SET COLOUR CONNECTIONS
            IF (IHPRO.GE.5) THEN
               IC=1
               IF (IDUP(3).LT.0) IC=2
            ENDIF
            IF (IHPRO.LE.8.AND.IC.LE.2) THEN
               DO I=1,5
                  CALL UPCODE(IVBF5(I,IHPRO,IC),ICOLUP(1,I))
               ENDDO
            ELSE
               CALL HWWARN('UPEVNT',105)
               GOTO 999
            ENDIF
         ELSE
C---3-BODY FINAL STATE
            DO IP=3,NUP
               IDUP(IP)=IDUP(IP+1)
               CALL HWVEQU(5,PUP(1,IP+1),PUP(1,IP))
            ENDDO
C---SET COLOUR CONNECTIONS
            IF (IHPRO.LE.4) THEN
               DO I=1,4
                  CALL UPCODE(IVBF4(I,IHPRO),ICOLUP(1,I))
               ENDDO
            ELSE
               CALL HWWARN('UPEVNT',104)
               GOTO 999
            ENDIF
         ENDIF
         ICOLUP(1,NUP)=0
         ICOLUP(2,NUP)=0
      ELSEIF (JPR.EQ.17.OR.(JPR.EQ.51.AND.IDUP(1).NE.22)) THEN
C---HEAVY QUARKS
         IF (REMIT) THEN
C---3-BODY FINAL STATE
C---SET COLOUR CONNECTIONS
            IF (IC.LE.18) THEN
               DO I=1,5
                  CALL UPCODE(ICOL5(I,IC),ICOLUP(1,I))
               ENDDO
            ELSE
               CALL HWWARN('UPEVNT',105)
               GOTO 999
            ENDIF
         ELSE
C---2-BODY FINAL STATE
            DO IP=3,NUP
               IDUP(IP)=IDUP(IP+1)
               CALL HWVEQU(5,PUP(1,IP+1),PUP(1,IP))
            ENDDO
C---SET COLOUR CONNECTIONS
            IF (IC.LE.4) THEN
               DO I=1,4
                  CALL UPCODE(ICOL4(I,IC),ICOLUP(1,I))
               ENDDO
            ELSE
               CALL HWWARN('UPEVNT',104)
               GOTO 999
            ENDIF
         ENDIF
         IF (.NOT.NODEC) THEN
C---T-TBAR WITH DECAYS
C   LES HOUCHES COMMON IS FILLED AS FOLLOWS:
C
C  1 INCOMING PARTON
C  2 INCOMING PARTON
C  3 OUTGOING LIGHT PARTON (IF ANY, OTHERWISE 4-13 BECOME 3-12)
C  4 TOP
C  5 ANTITOP
C  6 QUARK FROM TOP
C  7 W+ FROM TOP
C  8 ANTIQUARK FROM ANTITOP
C  9 W- FROM ANTITOP
C 10 DECAY PRODUCT FROM W+ FROM TOP
C 11 DECAY PRODUCT FROM W+ FROM TOP
C 12 DECAY PRODUCT FROM W- FROM ANTITOP
C 13 DECAY PRODUCT FROM W- FROM ANTITOP
C
C---RECONSTRUCT TOP DECAYS
            IF (MOD(JJPROC,10).NE.6) THEN
               CALL HWWARN('UPEVNT',210)
               GOTO 999
            ENDIF
            NP=NUP
C--W DECAYS
            IDUP(NP+1)=IDUP(NP-5)
            IDUP(NP+2)=IDUP(NP-4)
            IDUP(NP+3)=IDUP(NP-2)
            IDUP(NP+4)=IDUP(NP-1)
            IDUP(NP-1)=IDUP(NP)
            CALL HWVEQU(5,PUP(1,NP-5),PUP(1,NP+1))
            CALL HWVEQU(5,PUP(1,NP-4),PUP(1,NP+2))
            CALL HWVEQU(5,PUP(1,NP-2),PUP(1,NP+3))
            CALL HWVEQU(5,PUP(1,NP-1),PUP(1,NP+4))
            CALL HWVEQU(5,PUP(1,NP  ),PUP(1,NP-1))
            CALL HWVSUM(4,PUP(1,NP+1),PUP(1,NP+2),PUP(1,NP-2))
            CALL HWVSUM(4,PUP(1,NP+3),PUP(1,NP+4),PUP(1,NP))
            CALL HWUMAS(PUP(1,NP-2))
            CALL HWUMAS(PUP(1,NP))
            IDUP(NP-2)=-24*(MOD(IDUP(NP+1),2)+MOD(IDUP(NP+2),2))
            IDUP(NP)=-IDUP(NP-2)
            DO IP=NP-3,NP+4
               ISTUP(IP)=1
            ENDDO
            ISTUP(NP-2)=2
            ISTUP(NP)=2
C--TOP DECAYS
            CALL HWVSUM(4,PUP(1,NP-3),PUP(1,NP-2),PUP(1,NP-5))
            CALL HWVSUM(4,PUP(1,NP-1),PUP(1,NP  ),PUP(1,NP-4))
            CALL HWUMAS(PUP(1,NP-5))
            CALL HWUMAS(PUP(1,NP-4))
            IDUP(NP-5)=IDUP(NP-2)/4
            IDUP(NP-4)=-IDUP(NP-5)
            ISTUP(NP-5)=2
            ISTUP(NP-4)=2
            MOTHUP(1,NP-5)=1
            MOTHUP(2,NP-5)=2
            MOTHUP(1,NP-4)=1
            MOTHUP(2,NP-4)=2
            MOTHUP(1,NP-3)=NP-5
            MOTHUP(1,NP-2)=NP-5
            MOTHUP(1,NP-1)=NP-4
            MOTHUP(1,NP  )=NP-4
            MOTHUP(1,NP+1)=NP-2
            MOTHUP(1,NP+2)=NP-2
            MOTHUP(1,NP+3)=NP
            MOTHUP(1,NP+4)=NP
            DO IP=NP-3,NP+4
               MOTHUP(2,IP)=MOTHUP(1,IP)
               ICOLUP(1,IP)=0
               ICOLUP(2,IP)=0
            ENDDO
            ICOLUP(1,NP-3)=ICOLUP(1,NP-5)
            ICOLUP(2,NP-3)=ICOLUP(2,NP-5)
            ICOLUP(1,NP-1)=ICOLUP(1,NP-4)
            ICOLUP(2,NP-1)=ICOLUP(2,NP-4)
            IF (IDUP(NP+1).GT.0) THEN
               ICOLUP(1,NP+1)=505
               ICOLUP(2,NP+2)=505
            ELSE
               ICOLUP(2,NP+1)=505
               ICOLUP(1,NP+2)=505
            ENDIF
            IF (IDUP(NP+3).GT.0) THEN
               ICOLUP(1,NP+3)=506
               ICOLUP(2,NP+4)=506
            ELSE
               ICOLUP(2,NP+3)=506
               ICOLUP(1,NP+4)=506
            ENDIF
            NUP=NP+4
         ENDIF
      ELSEIF (JPR.EQ.20) THEN
         IF (JJPROC.GE.2030) THEN
C---TOP+W FINAL STATE
C---SET COLOUR CONNECTIONS
            IF (IC.GT.20) THEN
               CALL HWWARN('UPEVNT',111)
               GOTO 999
            ENDIF
            DO I=1,4
               CALL UPCODE(ICOST(I,IC),ICOLUP(1,I))
            ENDDO
            ICOLUP(1,5)=0
            ICOLUP(2,5)=0
            IF (.NOT.REMIT) THEN
C---2-BODY FINAL STATE
               DO IP=3,NUP
                  IDUP(IP)=IDUP(IP+1)
                  ICOLUP(1,IP)=ICOLUP(1,IP+1)
                  ICOLUP(2,IP)=ICOLUP(2,IP+1)
                  CALL HWVEQU(5,PUP(1,IP+1),PUP(1,IP))
               ENDDO
            ENDIF
            IF (NODEC) THEN
               IP=NUP-1
            ELSE
               IP=NUP-2
C---T W (OR TBAR W) WITH DECAYS
C   LES HOUCHES COMMON IS FILLED AS FOLLOWS:
C
C  1 INCOMING PARTON
C  2 INCOMING PARTON
C  3 OUTGOING LIGHT PARTON (IF ANY, OTHERWISE 4-11 BECOME 3-10)
C  4 TOP
C  5 W FROM TOP
C  6 QUARK FROM TOP
C  7 DECAY PRODUCT FROM W FROM TOP
C  8 DECAY PRODUCT FROM W FROM TOP
C  9 W NOT FROM TOP
C 10 DECAY PRODUCT FROM W NOT FROM TOP
C 11 DECAY PRODUCT FROM W NOT FROM TOP
C
C---RECONSTRUCT W DECAY
               NP=NUP
               IDUP(NP+1)=-24*(MOD(IDUP(NP-1),2)+MOD(IDUP(NP),2))
               IDUP(NP+2)=IDUP(NP-1)
               IDUP(NP+3)=IDUP(NP)
               CALL HWVEQU(5,PUP(1,NP-1),PUP(1,NP+2))
               CALL HWVEQU(5,PUP(1,NP),PUP(1,NP+3))
               CALL HWVSUM(4,PUP(1,NP-1),PUP(1,NP),PUP(1,NP+1))
               CALL HWUMAS(PUP(1,NP+1))
               ISTUP(NP+1)=2
               ISTUP(NP+2)=1
               ISTUP(NP+3)=1
               MOTHUP(1,NP+1)=1
               MOTHUP(2,NP+1)=2
               MOTHUP(1,NP+2)=NP+1
               MOTHUP(2,NP+2)=NP+1
               MOTHUP(1,NP+3)=NP+1
               MOTHUP(2,NP+3)=NP+1
               ICOLUP(1,NP+1)=0
               ICOLUP(2,NP+1)=0
               ICOLUP(1,NP+2)=505
               ICOLUP(2,NP+2)=0
               ICOLUP(1,NP+3)=0
               ICOLUP(2,NP+3)=505
               NUP=NP+3
            ENDIF
            IF (IDUP(IP).LT.0) THEN
C---CHARGE CONJUGATE PROCESS
               DO I=1,NUP
                  IA=ICOLUP(1,I)
                  ICOLUP(1,I)=ICOLUP(2,I)
                  ICOLUP(2,I)=IA
               ENDDO
            ENDIF
         ELSE
C---SINGLE TOP: IA,IB ARE THE QUARKS THAT ARE COLOUR CONNECTED
C   I.E. (FOR H EVENTS) THOSE THAT ARE NOT CONNECTED TO GLUON
            IA=IC/10
            IB=IC-10*IA
            IF (IA.LT.1.OR.IA.GT.5) THEN
               CALL HWWARN('UPEVNT',108)
            ELSEIF (IB.LT.1.OR.IB.GT.5) THEN
               CALL HWWARN('UPEVNT',109)
            ELSEIF (IA.EQ.IB) THEN
               CALL HWWARN('UPEVNT',110)
            ENDIF
            IF (IERROR.NE.0) GOTO 999
            IF (.NOT.NODEC) THEN
               ID=IDUP(5)
               IDUP(5)=IDUP(7)
            ENDIF
            DO I=1,5
               IF (I.EQ.IA.OR.I.EQ.IB) THEN
                  IF (IDUP(I).GT.0) THEN
                     ICOLUP(1,I)=501
                     ICOLUP(2,I)=0
                  ELSE
                     ICOLUP(1,I)=0
                     ICOLUP(2,I)=501
                  ENDIF
               ELSEIF (IDUP(I).EQ.21) THEN
                  IG=I
                  ICOLUP(1,I)=502
                  ICOLUP(2,I)=503
               ELSEIF (IDUP(I).GT.0) THEN
                  ICOLUP(1,I)=502
                  ICOLUP(2,I)=0
               ELSE
                  ICOLUP(1,I)=0
                  ICOLUP(2,I)=502
               ENDIF
            ENDDO
            IF (.NOT.NODEC) IDUP(5)=ID
            IF (REMIT) THEN
C---3-BODY FINAL STATE
C---COMPLETE GLUON COLOUR CONNECTIONS
               IF (.NOT.NODEC) THEN
                  ID=IDUP(5)
                  IDUP(5)=IDUP(7)
               ENDIF
               DO I=1,5
                  IF (I.NE.IA.AND.I.NE.IB.AND.I.NE.IG) THEN
                     IF (IDUP(I).GT.0) THEN
                        IF((I.LT.3.AND.IG.LT.3)
     &                       .OR.(I.GT.2.AND.IG.GT.2)) ICOLUP(1,I)=503
                     ELSE
                        IF((I.LT.3.AND.IG.GT.2)
     &                       .OR.(I.GT.2.AND.IG.LT.3)) ICOLUP(2,I)=503
                     ENDIF
                  ENDIF
               ENDDO
               IF (.NOT.NODEC) IDUP(5)=ID
            ELSE
C---2-BODY FINAL STATE
               DO IP=3,NUP
                  IDUP(IP)=IDUP(IP+1)
                  CALL HWVEQU(5,PUP(1,IP+1),PUP(1,IP))
               ENDDO
C---SET COLOUR CONNECTIONS
               ICOLUP(1,3)=ICOLUP(1,4)
               ICOLUP(2,3)=ICOLUP(2,4)
               ICOLUP(1,4)=ICOLUP(1,5)
               ICOLUP(2,4)=ICOLUP(2,5)
            ENDIF
         ENDIF
         IF (.NOT.NODEC) THEN
            IF (JJPROC.GE.2030) THEN
               NP=NUP-5
            ELSE
               NP=NUP
C---SINGLE TOP WITH DECAYS
C   LES HOUCHES COMMON IS FILLED AS FOLLOWS:
C
C  1 INCOMING PARTON
C  2 INCOMING PARTON
C  3 OUTGOING LIGHT PARTON (IF ANY, OTHERWISE 4-9 BECOME 3-8)
C  4 OUTGOING BBAR-TYPE QUARK
C  5 TOP
C  6 W FROM TOP
C  7 QUARK FROM TOP
C  8 DECAY PRODUCT FROM W FROM TOP
C  9 DECAY PRODUCT FROM W FROM TOP
C
C---RECONSTRUCT TOP DECAY
            ENDIF
            IDUP(NP+1)=IDUP(NP-2)
            IDUP(NP+2)=IDUP(NP-1)
            IDUP(NP-1)=-24*(MOD(IDUP(NP+1),2)+MOD(IDUP(NP+2),2))
            IDUP(NP-2)=IDUP(NP-1)/4
            CALL HWVEQU(5,PUP(1,NP-2),PUP(1,NP+1))
            CALL HWVEQU(5,PUP(1,NP-1),PUP(1,NP+2))
            CALL HWVSUM(4,PUP(1,NP+1),PUP(1,NP+2),PUP(1,NP-1))
            CALL HWVSUM(4,PUP(1,NP-1),PUP(1,NP  ),PUP(1,NP-2))
            CALL HWUMAS(PUP(1,NP-1))
            CALL HWUMAS(PUP(1,NP-2))
            DO IP=NP-3,NP+2
               ISTUP(IP)=1
            ENDDO
            ISTUP(2)=-1
            ISTUP(NP-1)=2
            ISTUP(NP-2)=2
            MOTHUP(1,NP-3)=1
            MOTHUP(2,NP-3)=2
            MOTHUP(1,NP-2)=1
            MOTHUP(2,NP-2)=2
            MOTHUP(1,NP-1)=NP-2
            MOTHUP(1,NP  )=NP-2
            MOTHUP(1,NP+1)=NP-1
            MOTHUP(1,NP+2)=NP-1
            DO IP=NP-1,NP+2
               MOTHUP(2,IP)=MOTHUP(1,IP)
               ICOLUP(1,IP)=0
               ICOLUP(2,IP)=0
            ENDDO
            ICOLUP(1,NP)=ICOLUP(1,NP-2)
            ICOLUP(2,NP)=ICOLUP(2,NP-2)
            IF (IDUP(NP+1).GT.0) THEN
               ICOLUP(1,NP+1)=504
               ICOLUP(2,NP+2)=504
            ELSE
               ICOLUP(2,NP+1)=504
               ICOLUP(1,NP+2)=504
            ENDIF
            IF (JJPROC.LT.2030) NUP=NP+2
         ENDIF
       ELSEIF (JPR.EQ.1) THEN

C-------- SAFTY CHECK FOR CMSSW, WE REMOVE ee collisions
          WRITE(*,*) 'EE COLLSIONS NOT SUPPORTED FOR CMSSW'
          STOP

C---E+E- ANNIHILATION
         DO I=1,NUP
            ICOLUP(1,I)=0
            ICOLUP(2,I)=0
         ENDDO
C---RESCALE 3-MOMENTA TO PUT PARTONS ON-SHELL
         PUP(5,1)=RMASS(121)
         PUP(5,2)=PUP(5,1)
         CALL HWURSC(2,PUP)
         PUP(5,3)=RMASS(13)
         PUP(5,4)=RMASS(ABS(IDUP(4)))
         PUP(5,5)=PUP(5,4)
         IF (REMIT) THEN
            CALL HWURSC(3,PUP(1,3))
            ICOLUP(1,3)=501
            ICOLUP(2,3)=502
            IF (IDUP(4).GT.0) THEN
               ICOLUP(1,4)=502
               ICOLUP(2,5)=501
            ELSE
               ICOLUP(2,4)=501
               ICOLUP(1,5)=502
            ENDIF
         ELSE
            CALL HWURSC(2,PUP(1,4))
            DO I=3,4
               CALL HWVEQU(5,PUP(1,I+1),PUP(1,I))
               IDUP(I)=IDUP(I+1)
               ISTUP(I)=1
            ENDDO
            IF (IDUP(3).GT.0) THEN
               ICOLUP(1,3)=501
               ICOLUP(2,4)=501
            ELSE
               ICOLUP(2,3)=501
               ICOLUP(1,4)=501
            ENDIF
         ENDIF
      ELSE
C---BOSON PAIR OR LEPTON PAIR
         IF (BOPRO.OR.NODEC) THEN
            NUP=6
            DO I=6,5,-1
               CALL HWVEQU(5,PUP(1,I-1),PUP(1,I))
               IDUP(I)=IDUP(I-1)
               ISTUP(I)=1
            ENDDO
         ELSE
C---BOSON PAIR: ONE OR BOTH DECAYED
C---ADD BOSON(S) TO EVENT RECORD
            IF (ABS(IDUP(6)).LT.20) THEN
               NUP=8
               I=2
               IF (ABS(IDUP(4)).LT.20) THEN
                  NUP=10
                  I=3
               ENDIF
               MUP=NUP-1
               CALL HWVEQU(5,PUP(1,MUP-I),PUP(1,MUP))
               CALL HWVEQU(5,PUP(1,NUP-I),PUP(1,NUP))
               CALL HWVSUM(4,PUP(1,MUP),PUP(1,NUP),PUP(1,6))
               CALL HWUMAS(PUP(1,6))
               IDUP(MUP)=IDUP(MUP-I)
               IDUP(NUP)=IDUP(NUP-I)
               ISTUP(MUP)=1
               ISTUP(NUP)=1
               MOTHUP(1,MUP)=6
               MOTHUP(2,MUP)=6
               MOTHUP(1,NUP)=6
               MOTHUP(2,NUP)=6
               ISTUP(6)=2
               ID=MOD(IDUP(MUP),2)+MOD(IDUP(NUP),2)
               IF (ID.EQ.0) THEN
                  IDUP(6)=23
               ELSEIF (ABS(ID).EQ.1) THEN
                  IDUP(6)=-24*ID
               ELSE
                  CALL HWWARN('UPEVNT',106)
                  GOTO 999
               ENDIF
            ENDIF
            IF (ABS(IDUP(4)).LT.20) THEN
               CALL HWVZRO(4,PDB)
               DO I=8,7,-1
                  CALL HWVEQU(5,PUP(1,I-3),PUP(1,I))
                  CALL HWVSUM(4,PUP(1,I),PDB,PDB)
                  IDUP(I)=IDUP(I-3)
                  ISTUP(I)=1
                  MOTHUP(1,I)=5
                  MOTHUP(2,I)=5
               ENDDO
               CALL HWUMAS(PDB)
               CALL HWVEQU(5,PDB,PUP(1,5))
               ISTUP(5)=2
               ID=MOD(IDUP(7),2)+MOD(IDUP(8),2)
               IF (ID.EQ.0) THEN
                  IDUP(5)=23
               ELSEIF (ABS(ID).EQ.1) THEN
                  IDUP(5)=-24*ID
               ELSE
                  CALL HWWARN('UPEVNT',107)
                  GOTO 999
               ENDIF
            ELSE
               CALL HWVEQU(5,PUP(1,4),PUP(1,5))
               IDUP(5)=IDUP(4)
               ISTUP(5)=1
               MOTHUP(1,5)=4
               MOTHUP(2,5)=4
            ENDIF
         ENDIF
C---ADD DIBOSON OR DILEPTON TO EVENT RECORD (TO FIX ITS MASS)
         CALL HWVZRO(4,PDB)
         DO I=6,5,-1
            CALL HWVSUM(4,PUP(1,I),PDB,PDB)
            MOTHUP(1,I)=4
            MOTHUP(2,I)=4
         ENDDO
         CALL HWUMAS(PDB)
         CALL HWVEQU(5,PDB,PUP(1,4))
         ISTUP(4)=2
         IDUP(4)=0
         IF (REMIT) THEN
C---SET COLOUR CONNECTIONS
            DO I=1,3
               ICOLUP(1,I)=501
               ICOLUP(2,I)=502
            ENDDO
            IF (IHPRO.EQ.1) THEN
               ICOLUP(2,1)=0
               ICOLUP(1,2)=0
            ELSEIF (IHPRO.EQ.2) THEN
               ICOLUP(1,1)=502
               ICOLUP(2,1)=0
               ICOLUP(2,3)=0
            ELSEIF (IHPRO.EQ.3) THEN
               ICOLUP(1,1)=0
               ICOLUP(2,2)=0
            ELSEIF (IHPRO.EQ.4) THEN
               ICOLUP(1,1)=0
               ICOLUP(2,1)=501
               ICOLUP(1,3)=0
            ELSEIF (IHPRO.EQ.5) THEN
               ICOLUP(1,2)=502
               ICOLUP(2,2)=0
               ICOLUP(2,3)=0
            ELSEIF (IHPRO.EQ.6) THEN
               ICOLUP(1,2)=0
               ICOLUP(2,2)=501
               ICOLUP(1,3)=0
            ELSE
               CALL HWWARN('UPEVNT',102)
               GOTO 999
            ENDIF
            DO I=4,NUP
               ICOLUP(1,I)=0
               ICOLUP(2,I)=0
            ENDDO
         ELSE
            DO I=5,NUP
               CALL HWVEQU(5,PUP(1,I),PUP(1,I-2))
               IDUP(I-2)=IDUP(I)
               ISTUP(I-2)=ISTUP(I)
               MOTHUP(1,I-2)=MOTHUP(1,I)-2
               MOTHUP(2,I-2)=MOTHUP(1,I)-2
            ENDDO
            MOTHUP(1,3)=1
            MOTHUP(1,4)=1
            NUP=NUP-2
C---SET COLOUR CONNECTIONS
            DO I=1,NUP
               ICOLUP(1,I)=0
               ICOLUP(2,I)=0
            ENDDO
            IF (IDUP(1).GT.0) THEN
               ICOLUP(1,1)=501
               ICOLUP(2,2)=501
            ELSE
               ICOLUP(2,1)=501
               ICOLUP(1,2)=501
            ENDIF
         ENDIF
         IF (BOPRO) THEN
C---DILEPTON PRODUCTION
            IBOS=MOD(JJPROC,100)
            ILEP=MOD(JJPROC,10)
            IBOS=IBOS-ILEP
C---LOAD LEPTON AND BOSON ID
            I=NUP-1
            J=NUP
            IF ( IBOS.EQ.50 .OR.
     #          (IBOS.EQ.60.AND.JPR.EQ.13) .OR.
     #          (IBOS.EQ.70.AND.JPR.EQ.13) ) THEN
               IDUP(I)=-ILEP-10
               IDUP(J)=-IDUP(I)
               IF (REMIT) IDUP(4)=23
            ELSEIF (IBOS.EQ.60.AND.JPR.EQ.14) THEN
               IDUP(I)=-9-2*ILEP
               IDUP(J)=1-IDUP(I)
               IF (REMIT) IDUP(4)=24
            ELSEIF (IBOS.EQ.70.AND.JPR.EQ.14) THEN
               IDUP(I)=-10-2*ILEP
               IDUP(J)=-1-IDUP(I)
               IF (REMIT) IDUP(4)=-24
            ELSE
               CALL HWWARN('UPEVNT',504)
            ENDIF
         ENDIF
      ENDIF
 999  CONTINUE
      IF(IERROR.LT.100) RETURN
      PRINT *
      DO I=1,NUP
         PRINT '(4I4,5F8.2)',IDUP(I),ISTUP(I),(ICOLUP(J,I),J=1,2),
     &        (PUP(J,I),J=1,5)
      ENDDO
c       IPR, IC, NP
 901  FORMAT(1X,I3,2(1X,I2))
c      (ID(I),I=1,NP)
 902  FORMAT(9(1X,I3))
c       XEVWGT,EMSCA
 903  FORMAT(3(1X,D14.8))
c      ((P(J,I),J=1,4),I=1,NP)
 904  FORMAT(36(1X,D14.8))
c 901  FORMAT(1X,I3,4(1X,I2))
c 902  FORMAT(1X,D14.8)
c 903  FORMAT(16(1X,D14.8))
      END
C----------------------------------------------------------------------
      SUBROUTINE UPCODE(ICODE,ICOL)
C--DECODES COLOUR CONNECTIONS
C----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER ICODE,ICOL(2)
      ICOL(1)=ICODE/10
      IF (ICOL(1).NE.0) ICOL(1)=ICOL(1)+500
      ICOL(2)=MOD(ICODE,10)
      IF (ICOL(2).NE.0) ICOL(2)=ICOL(2)+500
      END