      subroutine LesHouches(p_born,born_wgt,virt_wgt)
c
c Given the Born momenta, this is the Binoth-Les Houches interface file
c that calls the OLP and returns the virtual weights. For convenience
c also the born_wgt is passed to this subroutine.
c
C************************************************************************
c WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING
C************************************************************************
c The Born in MadFKS -- and therefore also the virtual!-- should have a
c slightly adapted identical particle symmetry factor. The normal
c virtual weight as coming from the OLP should be divided by the number
c of gluons in the corresponding real-emission process (i.e.  the number
c of gluons in the Born plus one). This factor is passed to this
c subroutine in /numberofparticles/ common block, as "ngluons". So,
c divided virt_wgt by dble(ngluons) to get the correct virtual to be
c used in MadFKS. The born_wgt that is passed to this subroutine has
c already been divided by this factor.
C************************************************************************
c
      implicit none
      include "nexternal.inc"
      include "coupl.inc"
      double precision pi
      parameter (pi=3.1415926535897932385d0)
      double precision p_born(0:3,nexternal-1)
      double precision virt_wgt,born_wgt,double,single,virt_wgts(3)
      double precision mu2,ao2pi,conversion,alpha_S
      save conversion
      double precision fkssymmetryfactor,fkssymmetryfactorBorn,
     &     fkssymmetryfactorDeg
      integer ngluons,nquarks(-6:6)
      common/numberofparticles/fkssymmetryfactor,fkssymmetryfactorBorn,
     &                         fkssymmetryfactorDeg,ngluons,nquarks
      logical firsttime,firsttime_conversion
      data firsttime,firsttime_conversion /.true.,.true./
      integer           isum_hel
      logical                   multi_channel
      common/to_matrix/isum_hel, multi_channel
      double precision qes2
      common /coupl_es/ qes2
      integer nvtozero
      logical doVirtTest 
      common/cvirt2test/nvtozero,doVirtTest
      integer ivirtpoints,ivirtpointsExcept
      double precision  virtmax,virtmin,virtsum
      common/cvirt3test/virtmax,virtmin,virtsum,ivirtpoints,
     &     ivirtpointsExcept
      logical fksprefact
      parameter (fksprefact=.true.)
      double precision tolerance, madfks_single, madfks_double
      parameter (tolerance = 1d-8)
      integer nbad, nbadmax
      parameter (nbadmax = 5)
      data nbad / 0 /
      integer id1,id2
      save id1,id2
      integer fks_j_from_i(nexternal,0:nexternal)
     &     ,particle_type(nexternal),pdg_type(nexternal)
      common /c_fks_inc/fks_j_from_i,particle_type,pdg_type
      if (isum_hel.ne.0) then
         write (*,*) 'Can only do explicit helicity sum'//
     &        ' for Virtual corrections',
     &        isum_hel
      endif
      virt_wgt=0d0
c update the ren_scale for MadLoop and the couplings (should be the
c Ellis-Sexton scale)
      mu_r = sqrt(QES2)
      call update_as_param()
      alpha_S=g**2/(4d0*PI)
      ao2pi= alpha_S/(2d0*PI)

      if (firsttime) then
         id1=pdg_type(1)
         id2=pdg_type(2)
      endif
      if (pdg_type(1).ne.id1 .or. pdg_type(2).ne.id2) then
         write (*,*) 'Error in the interface to the virtuals',id1,id2
     &        ,pdg_type(1),pdg_type(2)
         stop
      endif

      mu2=mu_r**2

      if((id1.eq.21).and.(id2.eq.21))
     &                                call gg_hg_v(p_born,virt_wgt,mu2)
      if((id1.eq.21).and.(abs(id2).le.6))
     &                                call gq_hq_v(p_born,virt_wgt,mu2)
      if((abs(id1).le.6).and.(id2.eq.21))
     &                                call qg_hq_v(p_born,virt_wgt,mu2)
      if((abs(id1).le.6).and.(abs(id2).le.6).and.(id2.lt.0))
     &                                call qqx_hg_v(p_born,virt_wgt,mu2)
      if((abs(id1).le.6).and.(abs(id2).le.6).and.(id1.lt.0))
     &                                call qxq_hg_v(p_born,virt_wgt,mu2)
      
      virt_wgt=virt_wgt/dble(ngluons)

c======================================================================
c Replace the following line with the call to the one-loop code you 
c wish to use. virt_wgts contains finite part, single and double pole
c To understand why we need to divide them by ngluons, read the warning
c message at the beginning of this subroutine
c      
c      call sloopmatrix(p, virt_wgts)
c      virt_wgt= virt_wgts(1)/dble(ngluons)
c      single  = virt_wgts(2)/dble(ngluons)
c      double  = virt_wgts(3)/dble(ngluons)
c
c======================================================================

c======================================================================
c If the Virtuals are in the Dimensional Reduction scheme, convert them
c to the CDR scheme with the following factor (not needed for MadLoop,
c because they are already in the CDR scheme format)
c      if (firsttime_conversion) then
c         call DRtoCDR(conversion)
c         firsttime_conversion=.false.
c      endif
c      virt_wgt=virt_wgt+conversion*born_wgt*ao2pi
c======================================================================

c======================================================================
c example for checking the cancelation of the poles
c      if (firsttime) then
c          call getpoles(p,QES2,madfks_double,madfks_single,fksprefact)
c          if (dabs(single - madfks_single).lt.tolerance .and.
c     &        dabs(double - madfks_double).lt.tolerance) then
c              write(*,*) "---- POLES CANCELLED ----"
c              firsttime = .false.
c          else
c              write(*,*) "POLES MISCANCELLATION, DIFFERENCE > ",
c     &         tolerance
c              write(*,*) " COEFFICIENT DOUBLE POLE:"
c              write(*,*) "       MadFKS: ", madfks_double,
c     &                   "          OLP: ", double
c              write(*,*) " COEFFICIENT SINGLE POLE:"
c              write(*,*) "       MadFKS: ",madfks_single,
c     &                   "          OLP: ",single
c              write(*,*) " FINITE:"
c              write(*,*) "          OLP: ",virt_wgt
c              if (nbad .lt. nbadmax) then
c                  nbad = nbad + 1
c                  write(*,*) " Trying another PS point"
c              else
c                  write(*,*) " TOO MANY FAILURES, QUITTING"
c                  stop
c              endif
c          endif
c      endif
c======================================================================
      if(doVirtTest.and.born_wgt.ne.0d0)then
         virtmax=max(virtmax,virt_wgt/born_wgt/ao2pi)
         virtmin=min(virtmin,virt_wgt/born_wgt/ao2pi)
         virtsum=virtsum+virt_wgt/born_wgt/ao2pi
      endif
      return
      end

      subroutine LesHouchesInit(filename)
      implicit none
      include "nexternal.inc"
      include "coupl.inc"
      integer status,procnum
      double precision s,mu,sumdot
      external sumdot
      double precision p_born(0:3,nexternal-1)
      common/pborn/p_born
      character*13 filename
      common /LH_procnum /procnum

c Rocket:
c      call get_procnum(filename,procnum)
c      call Init(filename,status)
c      if (status.ne.1) then
c         write (*,*) 'Something wrong with Rocket Les Houches '//
c     &        'initialization',status
c$$$         stop
c      endif
c BlackHat:
c      call get_procnum(filename,procnum)
c      if(procnum.ne.1) then
c         write (*,*) 'Error in LesHouchesInit', procnum
c         stop
c       endif
c      call OLE_Init(filename//Char(0))
      return
      end


      subroutine DRtoCDR(conversion)
c This subroutine computes the sum in Eq. B.3 of the MadFKS paper
c for the conversion from dimensional reduction to conventional
c dimension regularization.
      implicit none
      double precision conversion
      double precision CA,CF
      parameter (CA=3d0,CF=4d0/3d0)
      integer i,triplet,octet
      integer i_fks,j_fks
      common/fks_indices/i_fks,j_fks
      include "nexternal.inc"
c      include "fks.inc"
      integer fks_j_from_i(nexternal,0:nexternal)
     &     ,particle_type(nexternal),pdg_type(nexternal)
      common /c_fks_inc/fks_j_from_i,particle_type,pdg_type
      include "coupl.inc"

c Particle types (=color) of i_fks, j_fks and fks_mother
      integer i_type,j_type,m_type
      common/cparticle_types/i_type,j_type,m_type

      double precision pmass(nexternal),zero
      parameter (zero=0d0)
      include "pmass.inc"

      triplet=0
      octet=0
      conversion = 0d0
      do i=1,nexternal
         if (i.ne.i_fks .and. i.ne.j_fks) then
            if (pmass(i).eq.0d0) then
               if (abs(particle_type(i)).eq.3) then
                  conversion=conversion-CF/2d0
                  triplet=triplet+1
               elseif (particle_type(i).eq.8) then
                  conversion=conversion-CA/6d0
                  octet=octet+1
               endif
            endif
         elseif(i.eq.min(i_fks,j_fks)) then
            if (pmass(j_fks).eq.0d0 .and. pmass(i_fks).eq.0d0) then
               if (m_type.eq.8) then
                  conversion=conversion-CA/6d0
                  octet=octet+1
               elseif (abs(m_type).eq.3)then
                  conversion=conversion-CF/2d0
                  triplet=triplet+1
               else
                  write (*,*)'Error in DRtoCDR, fks_mother must be'//
     &                 'triplet or octet',i,m_type
                  stop
               endif
            endif
         endif
      enddo
      write (*,*) 'From DR to CDR conversion: ',octet,' octets and ',
     &     triplet,' triplets in Born (both massless), sum =',conversion
      return
      
      end


      subroutine get_procnum(filename,procnum)
      implicit none
      integer procnum,lookhere,procsize
      character*13 filename
      character*176 buff
      logical done

      open (unit=68,file=filename,status='old')
      done=.false.
      do while (.not.done)
         read (68,'(a)',end=889)buff
         if (index(buff,'->').ne.0) then
c Rocket
c            lookhere=index(buff,'process')+7
c BlackHat
c            lookhere=index(buff,'|')
            if (lookhere.ne.0 .and. lookhere.lt.170) then
c Rocket
c               read (buff(lookhere+1:176),*) procnum
c BlackHat
c               read (buff(lookhere+1:176),*) procsize,procnum
c               if (procsize.ne.1) then
c                  write (*,*)
c     &                 'Can only deal with 1 procnum per (sub)process',
c     &                 procsize
c               else
                  write (*,*)'Read process number from contract file',
     &                 procnum
                  close(68)
                  return
c               endif
               done=.true.
            else
               write (*,*) 'syntax contract file not understandable',
     &              lookhere
               stop
            endif
         endif
      enddo
      stop

      close(68)

      return

 889  write (*,*) 'Error in contract file'
      stop
      end




      subroutine gg_hg_v(p,msq,musq)
      implicit none
      include'coupl.inc'
      include'nexternal.inc'
C     (Taken from Ravindran, Smith, van Neerven hep-ph/0201114)
C     Modified by overall factors
      integer iglue,j,k
      double precision p(0:3,nexternal-1),msq
      double precision s(nexternal-1,nexternal-1)
      double precision ss,tt,uu,s34,
     . virtgg,virtqa,virtaq,virtqg,virtgq,hdecay,Asq,fac
      parameter(iglue=4)
      double precision musq
      double precision gsq,pi
      double precision xn,v,vevsq,as,avegg,aveqg,aveqq
      double precision dot
      double precision mhsq,ason2pi

c      WARNING!!!
c      scheme='tH-V'

      xn=3d0
      pi=4d0*datan(1d0)
      avegg=1d0/256d0
      aveqg=1d0/96d0
      aveqq=1d0/36d0

c----define scalar products (MZ)
      do j=1,nexternal-1
      do k=1,nexternal-1
      s(j,k)=2d0*dot( p(0,j),p(0,k))
      enddo
      enddo


      ss=s(1,2)
      tt=-s(1,iglue)
      uu=-s(2,iglue)


      mhsq=ss+tt+uu

      ason2pi=g*g/8d0/pi**2
      gsq=g*g
      V=8d0

      Asq=abs(gc_8)**2

C   Deal with Higgs decay to b-bbar
c      s34=s(3,4)+2d0*lmass**2
c      hdecay=gw**2*lmass**2/(4d0*wmass**2)*2d0*(s34-4d0*lmass**2)
c      hdecay=hdecay/((s34-hmass**2)**2+(hmass*hwidth)**2)

      fac=ason2pi*Asq*gsq!*hdecay
      call hjetfill(musq,ss,tt,uu,virtgg,virtqa,virtaq,virtqg,virtgq)

      msq=avegg*fac*virtgg


c      do j=-nf,nf
c      do k=-nf,nf
c      msq(j,k)=0d0
c      if ((j.eq.0).and.(k.eq.0)) msq(j,k)=avegg*fac*virtgg
c      if ((j.gt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtqa
c      if ((j.lt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtaq
c      if ((j.eq.0).and.(k.ne.0)) msq(j,k)=aveqg*fac*virtgq
c      if ((j.ne.0).and.(k.eq.0)) msq(j,k)=aveqg*fac*virtqg
c      enddo
c      enddo

      return
      end


      subroutine gq_hq_v(p,msq,musq)
      implicit none
      include'coupl.inc'
      include'nexternal.inc'
C     (Taken from Ravindran, Smith, van Neerven hep-ph/0201114)
C     Modified by overall factors
      integer iglue,j,k
      double precision p(0:3,nexternal-1),msq
      double precision s(nexternal-1,nexternal-1)
      double precision ss,tt,uu,s34,
     . virtgg,virtqa,virtaq,virtqg,virtgq,hdecay,Asq,fac
      parameter(iglue=4)
      double precision musq
      double precision gsq,pi
      double precision xn,v,vevsq,as,avegg,aveqg,aveqq
      double precision dot
      double precision mhsq,ason2pi

c      WARNING!!!
c      scheme='tH-V'

      xn=3d0
      pi=4d0*datan(1d0)
      avegg=1d0/256d0
      aveqg=1d0/96d0
      aveqq=1d0/36d0

c----define scalar products (MZ)
      do j=1,nexternal-1
      do k=1,nexternal-1
      s(j,k)=2d0*dot( p(0,j),p(0,k))
      enddo
      enddo


      ss=s(1,2)
      tt=-s(1,iglue)
      uu=-s(2,iglue)


      mhsq=ss+tt+uu

      ason2pi=g*g/8d0/pi**2
      gsq=g*g
      V=8d0

      Asq=abs(gc_8)**2

C   Deal with Higgs decay to b-bbar
c      s34=s(3,4)+2d0*lmass**2
c      hdecay=gw**2*lmass**2/(4d0*wmass**2)*2d0*(s34-4d0*lmass**2)
c      hdecay=hdecay/((s34-hmass**2)**2+(hmass*hwidth)**2)

      fac=ason2pi*Asq*gsq!*hdecay
      call hjetfill(musq,ss,tt,uu,virtgg,virtqa,virtaq,virtqg,virtgq)

      msq=aveqg*fac*virtgq


c      do j=-nf,nf
c      do k=-nf,nf
c      msq(j,k)=0d0
c      if ((j.eq.0).and.(k.eq.0)) msq(j,k)=avegg*fac*virtgg
c      if ((j.gt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtqa
c      if ((j.lt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtaq
c      if ((j.eq.0).and.(k.ne.0)) msq(j,k)=aveqg*fac*virtgq
c      if ((j.ne.0).and.(k.eq.0)) msq(j,k)=aveqg*fac*virtqg
c      enddo
c      enddo

      return
      end


      subroutine qg_hq_v(p,msq,musq)
      implicit none
      include'coupl.inc'
      include'nexternal.inc'
C     (Taken from Ravindran, Smith, van Neerven hep-ph/0201114)
C     Modified by overall factors
      integer iglue,j,k
      double precision p(0:3,nexternal-1),msq
      double precision s(nexternal-1,nexternal-1)
      double precision ss,tt,uu,s34,
     . virtgg,virtqa,virtaq,virtqg,virtgq,hdecay,Asq,fac
      parameter(iglue=4)
      double precision musq
      double precision gsq,pi
      double precision xn,v,vevsq,as,avegg,aveqg,aveqq
      double precision dot
      double precision mhsq,ason2pi

c      WARNING!!!
c      scheme='tH-V'

      xn=3d0
      pi=4d0*datan(1d0)
      avegg=1d0/256d0
      aveqg=1d0/96d0
      aveqq=1d0/36d0

c----define scalar products (MZ)
      do j=1,nexternal-1
      do k=1,nexternal-1
      s(j,k)=2d0*dot( p(0,j),p(0,k))
      enddo
      enddo


      ss=s(1,2)
      tt=-s(1,iglue)
      uu=-s(2,iglue)


      mhsq=ss+tt+uu

      ason2pi=g*g/8d0/pi**2
      gsq=g*g
      V=8d0

      Asq=abs(gc_8)**2

C   Deal with Higgs decay to b-bbar
c      s34=s(3,4)+2d0*lmass**2
c      hdecay=gw**2*lmass**2/(4d0*wmass**2)*2d0*(s34-4d0*lmass**2)
c      hdecay=hdecay/((s34-hmass**2)**2+(hmass*hwidth)**2)

      fac=ason2pi*Asq*gsq!*hdecay
      call hjetfill(musq,ss,tt,uu,virtgg,virtqa,virtaq,virtqg,virtgq)

      msq=aveqg*fac*virtqg


c      do j=-nf,nf
c      do k=-nf,nf
c      msq(j,k)=0d0
c      if ((j.eq.0).and.(k.eq.0)) msq(j,k)=avegg*fac*virtgg
c      if ((j.gt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtqa
c      if ((j.lt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtaq
c      if ((j.eq.0).and.(k.ne.0)) msq(j,k)=aveqg*fac*virtgq
c      if ((j.ne.0).and.(k.eq.0)) msq(j,k)=aveqg*fac*virtqg
c      enddo
c      enddo

      return
      end


      subroutine qqx_hg_v(p,msq,musq)
      implicit none
      include'coupl.inc'
      include'nexternal.inc'
C     (Taken from Ravindran, Smith, van Neerven hep-ph/0201114)
C     Modified by overall factors
      integer iglue,j,k
      double precision p(0:3,nexternal-1),msq
      double precision s(nexternal-1,nexternal-1)
      double precision ss,tt,uu,s34,
     . virtgg,virtqa,virtaq,virtqg,virtgq,hdecay,Asq,fac
      parameter(iglue=4)
      double precision musq
      double precision gsq,pi
      double precision xn,v,vevsq,as,avegg,aveqg,aveqq
      double precision dot
      double precision mhsq,ason2pi

c      WARNING!!!
c      scheme='tH-V'

      xn=3d0
      pi=4d0*datan(1d0)
      avegg=1d0/256d0
      aveqg=1d0/96d0
      aveqq=1d0/36d0

c----define scalar products (MZ)
      do j=1,nexternal-1
      do k=1,nexternal-1
      s(j,k)=2d0*dot( p(0,j),p(0,k))
      enddo
      enddo


      ss=s(1,2)
      tt=-s(1,iglue)
      uu=-s(2,iglue)


      mhsq=ss+tt+uu

      ason2pi=g*g/8d0/pi**2
      gsq=g*g
      V=8d0

      Asq=abs(gc_8)**2

C   Deal with Higgs decay to b-bbar
c      s34=s(3,4)+2d0*lmass**2
c      hdecay=gw**2*lmass**2/(4d0*wmass**2)*2d0*(s34-4d0*lmass**2)
c      hdecay=hdecay/((s34-hmass**2)**2+(hmass*hwidth)**2)

      fac=ason2pi*Asq*gsq!*hdecay
      call hjetfill(musq,ss,tt,uu,virtgg,virtqa,virtaq,virtqg,virtgq)

      msq=aveqq*fac*virtqa


c      do j=-nf,nf
c      do k=-nf,nf
c      msq(j,k)=0d0
c      if ((j.eq.0).and.(k.eq.0)) msq(j,k)=avegg*fac*virtgg
c      if ((j.gt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtqa
c      if ((j.lt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtaq
c      if ((j.eq.0).and.(k.ne.0)) msq(j,k)=aveqg*fac*virtgq
c      if ((j.ne.0).and.(k.eq.0)) msq(j,k)=aveqg*fac*virtqg
c      enddo
c      enddo

      return
      end


      subroutine qxq_hg_v(p,msq,musq)
      implicit none
      include'coupl.inc'
      include'nexternal.inc'
C     (Taken from Ravindran, Smith, van Neerven hep-ph/0201114)
C     Modified by overall factors
      integer iglue,j,k
      double precision p(0:3,nexternal-1),msq
      double precision s(nexternal-1,nexternal-1)
      double precision ss,tt,uu,s34,
     . virtgg,virtqa,virtaq,virtqg,virtgq,hdecay,Asq,fac
      parameter(iglue=4)
      double precision musq
      double precision gsq,pi
      double precision xn,v,vevsq,as,avegg,aveqg,aveqq
      double precision dot
      double precision mhsq,ason2pi

c      WARNING!!!
c      scheme='tH-V'

      xn=3d0
      pi=4d0*datan(1d0)
      avegg=1d0/256d0
      aveqg=1d0/96d0
      aveqq=1d0/36d0

c----define scalar products (MZ)
      do j=1,nexternal-1
      do k=1,nexternal-1
      s(j,k)=2d0*dot( p(0,j),p(0,k))
      enddo
      enddo


      ss=s(1,2)
      tt=-s(1,iglue)
      uu=-s(2,iglue)


      mhsq=ss+tt+uu

      ason2pi=g*g/8d0/pi**2
      gsq=g*g
      V=8d0

      Asq=abs(gc_8)**2

C   Deal with Higgs decay to b-bbar
c      s34=s(3,4)+2d0*lmass**2
c      hdecay=gw**2*lmass**2/(4d0*wmass**2)*2d0*(s34-4d0*lmass**2)
c      hdecay=hdecay/((s34-hmass**2)**2+(hmass*hwidth)**2)

      fac=ason2pi*Asq*gsq!*hdecay
      call hjetfill(musq,ss,tt,uu,virtgg,virtqa,virtaq,virtqg,virtgq)

      msq=aveqq*fac*virtaq


c      do j=-nf,nf
c      do k=-nf,nf
c      msq(j,k)=0d0
c      if ((j.eq.0).and.(k.eq.0)) msq(j,k)=avegg*fac*virtgg
c      if ((j.gt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtqa
c      if ((j.lt.0).and.(k.eq.-j)) msq(j,k)=aveqq*fac*virtaq
c      if ((j.eq.0).and.(k.ne.0)) msq(j,k)=aveqg*fac*virtgq
c      if ((j.ne.0).and.(k.eq.0)) msq(j,k)=aveqg*fac*virtqg
c      enddo
c      enddo

      return
      end


      subroutine hjetfill(musq,s,t,u,virtgg,virtqa,virtaq,virtqg,virtgq)
      implicit none
c      include 'constants.f'
c      include 'b0.f'
      double precision virtgg,virtqa,virtaq,virtqg,virtgq,
     . logg,loqa,loaq,loqg,logq,ddilog,Li2s,Li2t,Li2u,
     . lnm,lns,lnt,lnu,ln2t,ln2u,mhsq,s,t,u,xlf,subuv,Delta
      double precision epinv,musq
      double precision v, xn,cf
      integer nf
      double precision pi, pisq,b0
      epinv=0d0
      v=8d0
      xn=3d0
      cf=4d0/3d0
      nf=4
      pi=4d0*datan(1d0)
      pisq=pi*pi


      b0=(xn*11d0-2d0*nf)/6d0

      
      mhsq=s+t+u

      xlf=dfloat(nf)
      Li2t=ddilog(t/mhsq)
      Li2u=ddilog(u/mhsq)
      Li2s=ddilog((s-mhsq)/s)
      lns=dlog(s/mhsq)
      lnt=dlog(-t/mhsq)
      lnu=dlog(-u/mhsq)
      lnm=dlog(musq/mhsq)
      ln2t=dlog((mhsq-t)/mhsq)
      ln2u=dlog((mhsq-u)/mhsq)

      logg=+V*xn*(mhsq**4+s**4+t**4+u**4)/(s*t*u)
      loqa=xn*cf/s*(t**2+u**2)
      loaq=loqa
      logq=-xn*cf/u*(s**2+t**2)
      loqg=-xn*cf/t*(s**2+u**2)

c--- UV counterterm in MS bar scheme. 
      subuv=-epinv*b0
      Delta=11d0
c--- See C.R.Schmidt, PLB (413) 391, eq. (16),(17)
c--- Factor of ason2pi included in gg_hg_v.f
C--- Three powers of as in Born --> 3      
      subuv=3d0*subuv+Delta
  
      virtgg=-3d0*epinv**2*xn*logg 
     . +epinv*xn*logg*(lns+lnt+lnu-3d0*lnm )
     . +xn*logg
     . *(2d0*(Li2t+Li2u+Li2s)
     . +lnm*(lns+lnt+lnu)-lns*lnt-lns*lnu-lnt*lnu
     . +0.5d0*(lns**2-lnt**2-lnu**2)-1.5d0*lnm**2
     . +2d0*(lnu*ln2u+lnt*ln2t)+4d0/3d0*pisq)
     . +V*xn*(xn-xlf)/3d0*mhsq*(1d0+mhsq/s+mhsq/t+mhsq/u)
     . +subuv*logg
 
      virtqa=+(-2d0*xn+1d0/xn)*loqa*epinv**2
     . -2d0/3d0*xlf*epinv*loqa
     . +epinv*xn*loqa*(13d0/6d0-2d0*lnm+lnt+lnu)
     . +epinv/xn*loqa*(1.5d0-lns+lnm)
     . +loqa*xlf*(-10d0/9d0+2d0/3d0*lns-2d0/3d0*lnm)
     . +xn*loqa* (40d0/9d0+Li2t+Li2u+2d0*Li2s-13d0/6d0*(lns-lnm)
     . +(lnm-lns)*(lnt+lnu)+lns**2-lnm**2-0.5d0*lnt**2-0.5d0*lnu**2
     . +lnt*ln2t+lnu*ln2u)
     . +loqa/xn
     . *(4d0-Li2t-Li2u-1.5d0*(lns-lnm)+0.5d0*(lns-lnm)**2
     . +lnt*lnu-lnt*ln2t-lnu*ln2u)
     . -4d0/3d0*pi**2/xn*loqa
     . -0.25d0*(xn**3-1d0/xn)*(t+u)
     . +subuv*loqa

      virtaq=(-2d0*xn+1d0/xn)*loaq*epinv**2
     . -2d0/3d0*xlf*epinv*loaq
     . +epinv*xn*loaq*(13d0/6d0-2d0*lnm+lnu+lnt)
     . +epinv/xn*loaq*(1.5d0-lns+lnm)
     . +loaq*xlf*(-10d0/9d0+2d0/3d0*lns-2d0/3d0*lnm)
     . +xn*loaq* (40d0/9d0+Li2u+Li2t+2d0*Li2s-13d0/6d0*(lns-lnm)
     . +(lnm-lns)*(lnu+lnt)+lns**2-lnm**2-0.5d0*lnu**2-0.5d0*lnt**2
     . +lnu*ln2u+lnt*ln2t)
     . +loaq/xn
     . *(4d0-Li2u-Li2t-1.5d0*(lns-lnm)+0.5d0*(lns-lnm)**2
     . +lnu*lnt-lnu*ln2u-lnt*ln2t)
     . -4d0/3d0*pi**2/xn*loaq
     . -0.25d0*(xn**3-1d0/xn)*(u+t)
     . +subuv*loaq
 

      virtgq=(-2d0*xn+1d0/xn)*epinv**2*logq
     . -2d0/3d0*xlf*epinv*logq
     . +epinv*xn*logq*(13d0/6d0+lns-2d0*lnm+lnt)
     . +epinv/xn*logq*(3d0/2d0+lnm-lnu)
     . +logq*xlf*(-10d0/9d0-2d0/3d0*lnm+2d0/3d0*lnu)
     . +xn*logq*(40d0/9d0+Li2t+2d0*Li2u+Li2s
     . +lns*lnm-lns*lnu-13d0/6d0*(lnu-lnm)
     . +lnm*lnt-lnm**2-lnt*lnu-0.5d0*lnt**2
     . +2d0*lnu*ln2u+lnt*ln2t)
     . +logq/xn*(4d0-Li2t-Li2s+lns*lnt+0.5d0*lnu**2-0.5d0*lns**2
     . -lnm*lnu+0.5d0*lnm**2-lnt*ln2t-1.5d0*(lnu-lnm))
     . +4d0/3d0*pi**2*xn*logq
     . +0.25d0*(xn**3-1d0/xn)*(t+s)
     . +subuv*logq

      virtqg=(-2d0*xn+1d0/xn)*epinv**2*loqg
     . -2d0/3d0*xlf*epinv*loqg
     . +epinv*xn*loqg*(13d0/6d0+lns-2d0*lnm+lnu)
     . +epinv/xn*loqg*(3d0/2d0+lnm-lnt)
     . +loqg*xlf*(-10d0/9d0-2d0/3d0*lnm+2d0/3d0*lnt)
     . +xn*loqg*(40d0/9d0+Li2u+2d0*Li2t+Li2s
     . +lns*lnm-lns*lnt-13d0/6d0*(lnt-lnm)
     . +lnm*lnu-lnm**2-lnu*lnt-0.5d0*lnu**2
     . +2d0*lnt*ln2t+lnu*ln2u)
     . +loqg/xn*(4d0-Li2u-Li2s+lns*lnu+0.5d0*lnt**2-0.5d0*lns**2
     . -lnm*lnt+0.5d0*lnm**2-lnu*ln2u-1.5d0*(lnt-lnm))
     . +4d0/3d0*pi**2*xn*loqg
     . +0.25d0*(xn**3-1d0/xn)*(u+s)
     . +subuv*loqg

      return
      end
