!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!                      ----------------------------
!                      beowulfsubs.f  Version 2.1
!                      ----------------------------
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine version
!
use beowulf_helpers
implicit none
write(nout,*)'beowulf 3.01 subroutines 26 June 2003'
write(nout,*)'Coulomb gauge and Feynman gauge'
RETURN
END subroutine version
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
! Subroutines for numerical integration of jet cross sections in
! electron-positron annihilation. -- D. E. Soper
!
! First code: 29 November 1992.
! Latest revision: see Version subroutine above.
!
! The main program and subroutines that a user might want to modify
! are contained in the companion package, beowulf.f. In particular, a
! user may very well want to modify parameter settings in the main
! program and to change the observables calculated in the subroutine
! HROTHGAR and in the functions CALStype(nparticles,kf,index). Subroutines
! that can be modified only at extreme peril to the reliability of
! the results are in this package, beowulfsubs.f.
!
! There are two parallel calculations. Program beowulf calculates a
! sample integral, which by default is the average value of 
! (1 - thrust)^2. These are summed in the variable INTEGRAL and
! reported upon completion of the program. The program also computes
! a simple check integral in order to check on the jacobians etc.
! In the meantime, for each point in loop space and each final
! state cut, the program reports the corresponding point in the space
! of final state momenta along with the corresponding weight (Feynman
! diagram times jacobian factors) to the subroutine HROTHGAR, which
! multiplies by the measurement functions CALS corresponding to the
! measurements desired and accumulates the results.
! 
! In order to control roundoff errors, a point in loop space is rejected
! if the point is too near a singularity or if there is too much
! cancellation in the contribution from that point to INTEGRAL.
! 
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!                        PROGRAM STRUCTURE
!main program beowulf
!  graphcountinit
!  getcounts and getcountsf
!  hrothgar... (interface)
!  randominit
!  daytime
!  version
!  reno... (main calculation)
!  diagnostic
!
!subroutine reno
!  timing
!  hrothgar
!  getnewgraph
!  findtypes  (maptypes for chosing points)
!    getnewcut
!  finda (matrix to get propagator momenta from loop momenta)
!  newpoint
!  checkpoint
!  calculate... (calculate at chosen point)
!
!subroutine calculate
!  function density
!  getnewcut
!  deform
!  finda (matrix propagator energies from final state energies)
!  checkcalc (the known integral)
!  hrothgar
!  functions feynmanf, feynman, feynman0f, feynman0
!
! Common blocks (used for data that does not change):
! 
! Set in main program beowulf:
! common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
!                nloops2,nprops2,nverts2,cutmax2
! common /limits/ badnesslimit,cancellimit,thrustcut
! common /maxtime/ timelimit
! common /programmode/ mode
! common /whichgraphs/ usegraph
! common /montecarlo/groupsize,groupsizegraph,groupsizetotal
! common /calculook/ report,details
! common /colorfactors/ nc,nf,cf
! common /gaugechoice/ gauge
! common /physicsdata/ alphasofmz,mz,externalrts
! common /deformscales/deformalpha,deformbeta,deformgamma
! common /smearparms/ smearfctr,lowpwr,highpwr
! common /renormalize/ muoverrts
! 
! Set in graphcountinit (called from main program beowulf):
! common /graphcounts/ numberofgraphs,numberofcuts,numberofmaps
!
! Here is a listing of the subroutines and functions included.
!
! Subroutines and functions in beowulf file:
! module beowulf_helpers
! program beowulf
! subroutine hrothgar
! function calsthrust
! function calstmoments
! function thrust
! function thrustdist
! function kn0
! function kn
! function calsymoments
! subroutine combinejets
! function cals0
! subroutine daytime
! subroutine timing
! subroutine getcounts
! subroutine getcountsf
!
! Subroutines and functions in beowulfsubs file:
! subroutine version
! subroutine reno
! subroutine getnewgraph
! subroutine getnewflavorset
! subroutine finda
! function propsign
! subroutine findtypes
! subroutine newpoint
! subroutine checkpoint
! subroutine axes
! subroutine calculate
! subroutine checkcalc
! function density
! subroutine choose3
! function rho3
! subroutine choose2to2s
! function rho2to2s
! subroutine choose2to2t
! function rho2to2t
! subroutine choose2to3d
! function rho2to3d
! subroutine choose2to3e
! function rho2to3e
! subroutine choose2to1
! function rho2to1
! subroutine graphcountinit
! subroutine getnewcut
! subroutine deform
! function delta
! function smear
! function feynmanf
! function feynman0f
! subroutine twopointgf
! subroutine twopointqf
! subroutine vertexf
! subroutine twopt2f
! function feynman
! function feynman0
! subroutine twopointg
! subroutine twopointq
! subroutine vertex
! subroutine twopt2
! subroutine epsilon4
! subroutine epsilon3
! subroutine epsilon2
! subroutine epsilon2n
! subroutine epsilon1n
! subroutine epsilont2
! subroutine epsilont1
! subroutine diagnostic
! function alpi
! function xxreal
! function xximag
! function complexsqrt
! function factorial
! function sinhinv
! function expm1
! function sqrtm1
! function logsqint
! function invlogsqint
! subroutine randominit
! subroutine newran
! function random
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
! A brief introduction to the variables used:
!
! Size of the calculation:
! NLOOPS = number of loops (in cut photon self energy graph).
! NPROPS = number of propagators in graph, = 3 * NLOOPS - 1.
! NVERTS = number of vertices in graph, = 2 * NLOOPS.
! CUTMAX = NLOOPS + 1
!        = maximum number of cut propagators;
!        = number of independent loop momenta needed to determine the
!          propagator momenta, counting the virtual photon momentum.
! The current program is restricted to 0 and 1 virtual loops.
!
! Labels:
! L    = index of loop momenta, L = 0,1,...,NLOOPS.
!        L = 0 normally denontes the virtual photon momentum.
! P    = index of propagator, P = 0,1,...,NPROPS.
!        P = 0 denotes the virtual photon momentum.
! Q(L) = index P of propagator carrying the Lth loop momentum.
! V    = index of vertices, V = 1,...,NVERTS
!
! Momentum variables (MU = 0,1,2,3):
! K(P,MU)       = Momentum of Pth propagator.
!                 For P = 0, this is the virtual photon momentum:
!                 K(0,MU) = 0 for MU = 1, 2, 3 while K(0,0) = RTS.
! ABSK(P)       = Square of the three momentum of Pth propagator.
! KINLOOP(J,MU) = K(LOOPINDEX(J),MU) = momenta of loop propagators.
! KCUT(I,MU)    = K(CUTINDEX(I),MU) = momenta of cut propagators.
! K(Q(L),MU)    = Lth loop momentum, L = 0,...,NLOOPS;
! KC(P,MU)      = complex propagator momenta.
! A(P,L)        = Matrix relating propagator momenta to loop momenta.
!                 K(P,MU) = SUM_{L=0}^{NLOOPS} A(P,L) K(Q(L),MU)
! kf(i,mu)      = momenta of final state particles, i = 1,nparticles
!                 equal to the kcut(i,mu) if no showering.
!
! Variables from NEWGRAPH:
! VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of
!              of propagator P. Specifies the supergraph.
! PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3.
!              Also specifies the supergraph.
!
! Variables associated with NEWPOINT and FINDTYPES:
! NMAPS = Number of different maps from random x's to momenta.
! MAPNMUMBER = Number labelling a certain map.
! QS(MAPNUMBER,II) = Label of the IIth propagator that is special
!                   in map number MAPNUMBER.
! QSIGNS(MAPNUMBER,II) = sign needed to relate the conventional 
!       direction of the propagator to that in an elementary scattering
! MAPTYPES(MAPNUMBER) = T2TO3, T2TO2T, T2TO2S, T2TO1.
!
! JACNEWPOINT =1/DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER)
!             = Jacobian for loop momenta L.
!
! Variables from NEWCUT:
! NEWCUTINIT: .TRUE. tells NEWCUT to initialize itself.
! NCUT = Number of cut propagators.
! ISIGN(P) = +1 if propagator P is left of cut, -1 if right, 0 if cut.
! CUTINDEX(I) = Index P of cut propagator I, I = 1,...,CUTMAX.
! CUTSIGN(I) = Sign of cut propagator I I = 1,...,CUTMAX.
!              (+1 if K(P,0) >0 for cut propagator.)
! LEFTLOOP = True iff there is a virtual loop to the left of the cut.
! RIGHTLOOP = True iff there is a virtual loop to the right of the cut.
! NINLOOP = Number of propagators in loop.
! LOOPINDEX(NP) = Index P of NPth propagator around the loop.
! LOOPSIGN(NP) = 1 if propagator direction is same as loop direction.
!               -1 if  direction is opposite to loop direction.
! NP = JCUT: Propagator cut by loopcut.
! CUTFOUND: .TRUE. if NEWCUT found a new cut.
!
! In RENO we use CUTINDEX to define CUT(P) = True if propagator
!    P is cut.
!
! Solving for the propagator energies:
! For NCUT = CUTMAX, cut propagators are P = CUTINDEX(I).
!   with direction of positive energy given by CUTSIGN(I).
! For NCUT = CUTMAX - 1, we define a "loopcut" on the propagator
!   numbered JCUT in order around the loop, 1.LE.JCUT.LE.NINLOOP:
!         CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) and
!         CUTSIGN(CUTMAX) = LOOPSIGN(JCUT).
! Energies of cut propagators are
!   E(I-1) = K(CUTINDEX(I),0) for I = 1,...,CUTMAX.
! and are determined from
!   E(I-1) = CUTSIGN(I) * SQRT( Sum_J [  K(CUTINDEX(I),J)**2 ] ).
! This gives energies E(L) for L = 0,...,NLOOPS. We consider the
! propagators designated by QE(L) = CUTINDEX(L+1) as independent
! and generate the matrix AE(P,L) that gives the propagator energies
! in terms of these independent momenta. This gives the propagator
! energies.
!
! Contour deformation:
!   NEWKINLOOP(MU) =  addition to the momentum going around the loop
!                     caused by deforming the contour. We have
!   Im[ KC(LOOPINDEX(J,MU)) ] = LOOPSIGN(LOOPINDEX(J)) 
!                              * Im[ NEWKINLOOP(J,MU) ] for MU = 1,2,3.
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine reno( &
          sumr,errorr,sumi,errori, &
          sumbis,errorbis, &
          sumchkr,errorchkr,sumchki,errorchki,fluct, &
          included,extracount,omitted, &
          nvalpt,valptmax,badpointinfo, &
          nreno,cputime)
!
use beowulf_helpers
implicit none
! Out:
real(kind=dbl) :: sumr,errorr,sumi,errori
real(kind=dbl) :: sumbis,errorbis
real(kind=dbl) :: sumchkr,errorchkr,sumchki,errorchki
real(kind=dbl) :: fluct(maxgraphs,maxmaps)
integer(kind=long) :: included,extracount,omitted
integer :: nvalpt(-9:6)
real(kind=dbl) :: valptmax
type badpointstate
  integer        :: jr
  integer        :: ir(250)
  real(kind=dbl) :: rr(250)
  integer        :: graphnumber
  integer        :: mapnumber
  real(kind=dbl) :: k(0:3*size-1,0:3)
end type badpointstate
type(badpointstate) :: badpointinfo
integer :: nreno
real(kind=dbl) :: cputime
!
! Computes the cross section integral by Monte Carlo integration.
!
! Latest revision 9 May 2003
!
integer :: nloops,nprops
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
real(kind=dbl) :: badnesslimit,cancellimit,thrustcut
common /limits/ badnesslimit,cancellimit,thrustcut
real(kind=dbl) :: timelimit
common /maxtime/ timelimit
! What the program should do
character(len=6) :: mode
common /programmode/ mode
! Graphs to include
logical :: usegraph(maxgraphs)
common /whichgraphs/ usegraph
! How many graphs and how many maps for each:
integer :: numberofgraphs
integer :: numberofmaps(maxgraphs)   
common /graphcounts/ numberofgraphs,numberofmaps
! Order of perturbation theory
integer :: order
! Momenta:
real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1)
! Matrices:
integer :: a(0:3*size-1,0:size)
! NEWGRAPH variables:
type graphstructure
  integer                          :: graphnumber
  integer                          :: order
  integer, dimension(0:3*size-1,2) :: vrtx
  integer, dimension(2*size,3)     :: prop
end type graphstructure
! VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of prop P.
! PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3.
type(graphstructure) :: graph
logical :: graphfound
integer :: graphnumber
! FINDA variable:
logical :: qok
! MAP variables:
integer :: nmaps,mapnumber
integer :: qs(maxmaps,0:size),qsigns(maxmaps,0:size)
integer :: q(0:size),qsign(0:size)
character(len=6) :: maptypes(maxmaps)
character(len=6) :: maptype
! Variable from CHECKPOINT:
real(kind=dbl) :: badness
! Problem report from NEWPOINT
logical :: badnewpoint
! Logical variables to tell how to treat point:
logical :: xtrapointq, badpointq
! Functions:
real(kind=dbl) :: xxreal,xximag
! Index variables:
integer :: l,p,mu
! Hrothgar dummy variables:
real(kind=dbl) :: kf0(maxparticles,0:3)
! Reno size and counting variables:
integer :: groupsize(maxgraphs,maxmaps)
integer :: groupsizegraph(maxgraphs)
integer :: groupsizetotal
common /montecarlo/groupsize,groupsizegraph,groupsizetotal
integer :: point
! Reno results variables:
real(kind=dbl) :: sqrsumr,sqrsumchkr
real(kind=dbl) :: sqrsumi,sqrsumchki
real(kind=dbl) :: sqrsumbis
complex(kind=dbl) :: integral,integralchk
real(kind=dbl) :: integralbis
! Calculate variables:
complex(kind=dbl) :: value,valuechk
real(kind=dbl) :: maxpart
real(kind=dbl) :: valpt,logvalpt
! Timing variables
real(kind=dbl) :: deltatime
! This gives us access to the random number generator's internal workings.
! We do not change these numbers in subroutine reno! But we save the 
! information needed to set the random number generator properly in
! subroutine diagnostic.
integer :: jrandom,irandom(250)
real(kind=dbl) :: rrandom(250)
common/rando/ rrandom,jrandom,irandom
real(kind=dbl) :: temp
integer :: tempjr,tempir(250)
real(kind=dbl) :: temprr(250)
real(kind=dbl) :: random
!
!------------------------------ Begin ----------------------------------
!
! Dummy variables for Hrothgar.
!
DO l = 1,maxparticles
  DO mu = 0,3
   kf0(l,mu) = 0.0d0
  END DO
END DO
!
! Initialize CPUTIME and NRENO. Call to TIMING starts the clock.
!
cputime = 0.0
nreno = 0
call timing(deltatime)
!
! Initialize sums for loop over groups of Reno points. The sums
! will be updated for each group. Within a group, the quantities
! corresponding to SUMxxR + i SUMxxI are complex variables called
! INTEGRALxx.
!
sumr = 0.0d0
sumi = 0.0d0
sumbis = 0.0d0
sumchkr = 0.0d0
sumchki = 0.0d0
!
sqrsumr = 0.0d0
sqrsumi = 0.0d0
sqrsumbis = 0.0d0
sqrsumchkr = 0.0d0
sqrsumchki = 0.0d0
!
DO graphnumber = 1,numberofgraphs
DO mapnumber = 1,numberofmaps(graphnumber)
  fluct(graphnumber,mapnumber) = 0.0d0
END DO
END DO
!
DO l = -9,6
  nvalpt(l) = 0
END DO
valptmax = 0.0d0
included = 0
extracount = 0
omitted = 0
!
! Initialize integrals for first group.
!
integral = (0.0d0,0.0d0)
integralbis = 0.0d0
integralchk = (0.0d0,0.0d0)
!
! Loop over groups of points.
!
DO WHILE (cputime.LT.timelimit)
nreno = nreno + 1
!
! Call Hrothgar to tell him to that we are starting a new group.
!
call hrothgar(1,kf0,1.0d0,1,'startgroup')
!
! Get a new graph. The starting value for GRAPHNUMBER depends
! on the order we want. Graphs for ORDER = 2 are numbered 1,...,10
! and those for ORDER = 1 are numbered 11,12. For MODE = nlo,
! we will do the ORDER = 2 graphs first, then continue with the
! first order graphs. Thus we wait for NEWGRAPH to return
! GRAPHFOUND = false, then reset it (see ELSE part of IF(GRAPHFOUND)).
!
graphfound = .true.
!
IF (mode.EQ.'born  ') THEN
  order = 1
  nloops = nloops1
  nprops = nprops1
  graphnumber = 10
ELSE IF (mode.EQ.'hocoef') THEN
  order = 2
  nloops = nloops2
  nprops = nprops2
  graphnumber = 0
ELSE IF (mode.EQ.'nlo   ') THEN
  order = 2
  nloops = nloops2
  nprops = nprops2
  graphnumber = 0
ELSE IF (mode.EQ.'shower') THEN
  order = 2
  nloops = nloops2
  nprops = nprops2
  graphnumber = 0
ELSE
 write(nout,*)'Not programmed for this mode. ',mode
 stop
END IF
!
DO
call getnewgraph(order,graph,graphfound)
IF (.NOT.graphfound) THEN
  IF (((mode.EQ.'nlo   ').OR.(mode.EQ.'shower')).AND.(order.EQ.2)) THEN
    ! We have finished with the order 2 graphs and should do order 1.
    graphfound = .true.
    order = 1
    nloops = nloops1
    nprops = nprops1
    call getnewgraph(order,graph,graphfound)
    IF (.NOT.graphfound) THEN
      write(nout,*)'What, graph 11 disappeared?'
      STOP
    END IF
  ELSE
    EXIT    ! We have finished with all of the graphs.
  END IF
END IF
! We have a graph to work with.
graphnumber = graphnumber + 1
IF (.NOT.(graphnumber.EQ.graph%graphnumber)) THEN
  write(nout,*)'Oops, we lost track of graphnumber.'
  STOP
END IF
!
! Check if we were supposed to use this graph (USEGRAPH is
! set in the main program.)
!
IF (usegraph(graphnumber)) THEN
!
! Calculate number of maps NMAPS, index arrays QS,
! types MAPTYPES, and signs QSIGNS associated with the maps.
!
call findtypes(graph,nmaps,qs,qsigns,maptypes)
!
! Loop over choices of maps from x's to loop momenta.
!
DO mapnumber = 1,nmaps
!
maptype = maptypes(mapnumber)
DO l = 0,nloops
  q(l) = qs(mapnumber,l)
  qsign(l) = qsigns(mapnumber,l)
END DO
!
call finda(graph%vrtx,q,nloops,order,a,qok)
!
! Loop over Reno points within a group.
!
DO point = 1,groupsize(graphnumber,mapnumber)
!
! Call Hrothgar to tell him that we are starting a new point.
!
call hrothgar(1,kf0,1.0d0,1,'startpoint')
!
! Get a new point. Check on its badness. If it is too bad,
! or if NEWPOINT reported a problem, we omit the point after
! notifying Hrothgar.
!
badpointq = .false.
xtrapointq = .false.
call newpoint(a,qsign,maptype,order,k,absk,badnewpoint)
IF (badnewpoint) THEN
  call hrothgar(1,kf0,1.0d0,1,'badpoint  ')
  badpointq = .true.
END IF
call checkpoint(k,absk,graph%prop,order,badness)
IF (badness.GT.100*badnesslimit) THEN
  call hrothgar(1,kf0,1.0d0,1,'badpoint  ')
  badpointq = .true.
ELSE IF (badness.GT.badnesslimit) THEN
  call hrothgar(1,kf0,1.0d0,1,'xtrapoint ')
  xtrapointq = .true.
END IF
!
! If the point is not too bad, we can call CALCULATE.
! The final state momenta found, along with the corresponding
! weights, are reported to Hrothgar by CACULATE.
! Then call Hrothgar to tell him that we are done with this point.
!
IF (.NOT.badpointq) THEN
temp = random(1)
tempjr = jrandom  ! This saves the state of the random
temprr = rrandom  ! number generator just before
tempir = irandom  ! calculate was called.
call calculate(graph,k,absk, &
               qs,qsigns,maptypes,nmaps,value,maxpart,valuechk)
END IF
!
! Add contribution from this point to integral.
! We count the point if Maxvalue/|Value| < Cancellimit.
!
IF (.NOT.badpointq) THEN
  IF ( maxpart .GT. 100*cancellimit*abs(xxreal(value)) ) THEN
    call hrothgar(1,kf0,1.0d0,1,'badpoint  ')
    badpointq = .true.
  ELSE IF ( maxpart .GT. cancellimit*abs(xxreal(value)) ) THEN
    call hrothgar(1,kf0,1.0d0,1,'xtrapoint ')
    xtrapointq = .true.
  END IF
END IF
!      
IF ( (.NOT.badpointq).AND.(.NOT.xtrapointq) ) THEN
  integral = integral + value
  fluct(graphnumber,mapnumber) = fluct(graphnumber,mapnumber) &
    + xxreal(value)**2/groupsize(graphnumber,mapnumber)
  integralchk = integralchk + valuechk
  included = included + 1
!
! For diagnostic purposes, we need VALPT, the contribution to
! the integral being calculated from this point, normalized such
! that the integral is the sum over all points chosen of VALPT
! divided by the total number of points, NRENO * GROUPSIZETOTAL.
!
  valpt = abs(xxreal(value))*groupsizetotal
  IF (valpt .GT. 0.0d0) then
    logvalpt = log10(valpt)
  ELSE
    logvalpt = -100.0d0
  END IF
  DO l = -9,6
    IF((logvalpt.GE.l).AND.(logvalpt.LT.(l+1))) THEN
      nvalpt(l) = nvalpt(l) + 1
    END IF
  END DO
  IF (valpt.GT.valptmax) THEN
!
! We save the information about the worst point for later analysis.
!
    valptmax = valpt
    DO mu = 0,3
      badpointinfo%k(0,mu) = 0.0d0
    END DO
    DO p = 1,nprops
      badpointinfo%k(p,0) = 0.0d0
    DO mu = 1,3
      badpointinfo%k(p,mu) = k(p,mu)
    END DO
    END DO
    badpointinfo%graphnumber = graphnumber
    badpointinfo%mapnumber = mapnumber
    badpointinfo%jr = tempjr  ! This saves the state of the random
    badpointinfo%rr = temprr  ! number generator just before calculate
    badpointinfo%ir = tempir  ! was called for the bad point.
!
  END IF
ELSE IF ((.NOT.badpointq).AND.(xtrapointq) ) THEN
!
! For points that are 'extra', we include the value of
! the integrand in the INTEGRALBIS, which will provide an estimate
! or the effect of the cutoffs.
!
  integralbis = integralbis + xxreal(value)
  extracount = extracount + 1
!
ELSE
  omitted = omitted + 1
END IF
!
! End of loop over POINT.
!
call hrothgar(1,kf0,1.0d0,1,'pointdone ')
END DO
!
! End of loop over MAPNUMBER.
!
END DO
!
! End for IF (USEGRAPH(GRAPHNUMBER)) THEN
!
END IF
!
! End of loop DO ... call getnewgraph() with EXIT if we ran out of graphs.
!
END DO
!
! Call Hrothgar to tell him that we are done with this group.
!
call hrothgar(1,kf0,1.0d0,1,'groupdone ')
!
! Add results from this group to the SUM variables. 
!
sumr = sumr + xxreal(integral)
sumi = sumi + xximag(integral)
sumbis = sumbis + integralbis
sumchkr = sumchkr + xxreal(integralchk)
sumchki = sumchki + xximag(integralchk)
!
sqrsumr = sqrsumr + xxreal(integral)**2
sqrsumi = sqrsumi + xximag(integral)**2
sqrsumbis = sqrsumbis + integralbis**2
sqrsumchkr = sqrsumchkr + xxreal(integralchk)**2
sqrsumchki = sqrsumchki + xximag(integralchk)**2
!
! Reset the INTEGRAL variables for the next group.
!
integral = (0.0d0,0.0d0)
integralbis = 0.0d0
integralchk = (0.0d0,0.0d0)
!
! End of loop DO WHILE (CPUTIME.LT.TIMELIMIT)
!
call timing(deltatime)
cputime = cputime + deltatime
END DO
!
! Calculate the SUM results.
!
sumr = sumr/nreno
sumi = sumi/nreno
sumbis = sumbis/nreno
sumchkr = sumchkr/nreno
sumchki = sumchki/nreno
!
sqrsumr = sqrsumr/nreno
sqrsumi = sqrsumi/nreno
sqrsumbis = sqrsumbis/nreno
sqrsumchkr = sqrsumchkr/nreno
sqrsumchki = sqrsumchki/nreno
!
IF (nreno.EQ.1) THEN
  write(nout,*)'nreno = 1 changed to 2 to avoid 1/0.'
  write(nout,*)'Results will be finite but wrong.'
  write(nout,*)' '
  nreno = 2
END IF
errorr = sqrt((sqrsumr - sumr**2)/(nreno - 1))
errori = sqrt((sqrsumi - sumi**2)/(nreno - 1))
errorbis = sqrt((sqrsumbis - sumbis**2)/(nreno - 1))
errorchkr = sqrt((sqrsumchkr - sumchkr**2)/(nreno-1))
errorchki = sqrt((sqrsumchki - sumchki**2)/(nreno-1))
!
DO graphnumber = 1,numberofgraphs
DO mapnumber = 1,numberofmaps(graphnumber)
  fluct(graphnumber,mapnumber) = &
         fluct(graphnumber,mapnumber)/nreno
END DO
END DO
!
RETURN
END subroutine reno
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!                           Subroutine GETNEWGRAPH
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine getnewgraph(orderwanted,graph,graphfound)
!
use beowulf_helpers
implicit none
!
! In:
integer :: orderwanted
! Out:
type graphstructure
  integer                          :: graphnumber
  integer                          :: order
  integer, dimension(0:3*size-1,2) :: vrtx
  integer, dimension(2*size,3)     :: prop
end type graphstructure
type(graphstructure) :: graph
logical :: graphfound
!
! VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of
!              of propagator P. Specifies the supergraph.
! PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3.
!              Also specifies the supergraph.
! Use
! C(V,I) = Index of Ith vertex connected to vertex V.
!        V = 1,...,NVERTS; I =1,2,3; C(V,I) = 1,...,NVERTS and -1,-2.
!        Here C(V,1).LE.C(V,2).LE.C(V,3).
!        This is the fundamental specification of the supergraph.
! Vertex 1 is automatically connected to the photon "-1":C(1,1) = -1.
! Vertex 2 is automatically connected to the photon "-2":C(2,1) = -2.
! Connections to the external boson:
! In C(V,I) we assign the first connection of vertex 1 to be vertex "-1"
! while the first connection of vertex 2 is vertex "-2." This numbering
! is convenient for working out C(V,I). In reporting the results, 
! however, we label the external boson with propagator 0, so that
! PROP(1,1) = PROP(2,1) = 0. Then propagator 0 attaches to vertices
! 1 and 2: VERT(0,1) = 2, VERT(0,2) = 1.
!
! 13 June 2002
!
integer, dimension(2*size,3) :: c
!
integer :: nprops,nverts
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
integer, save :: graphnumber = 0
integer :: vv,p,i,va,vb
integer, dimension(2*size) :: nused
!
! Initializations.
!
IF (orderwanted.EQ.2) THEN
  IF (graphnumber.GE.10) THEN
    graphfound = .false.
    graphnumber = 0
    RETURN
  END IF
  nprops = nprops2
  nverts = nverts2
ELSE IF (orderwanted.EQ.1) THEN
  IF (graphnumber.GE.12) THEN
    graphfound = .false.
    graphnumber = 0
    RETURN
  ELSE IF (graphnumber.LT.10) THEN
    graphnumber = 10          ! Starting value for order = 1.
  END IF
  nprops = nprops1
  nverts = nverts1
ELSE
  write(nout,*)'Order must be 1 or 2.',orderwanted
END IF
graphnumber = graphnumber + 1
!
! We know which graph, and everything is OK, so we proceed.
!
graphfound = .true.
graph%graphnumber = graphnumber
graph%order = orderwanted
!
! Data are from getnewgraph.nb
!
IF (graphnumber.EQ.1) THEN
  c(1,:) = (/-1,2,3/)
  c(2,:) = (/-2,1,4/)
  c(3,:) = (/1,4,5/)
  c(4,:) = (/2,3,6/)
  c(5,:) = (/3,6,6/)
  c(6,:) = (/4,5,5/)
ELSE IF (graphnumber.EQ.2) THEN
  c(1,:) = (/-1,2,3/)
  c(2,:) = (/-2,1,4/)
  c(3,:) = (/1,5,5/)
  c(4,:) = (/2,6,6/)
  c(5,:) = (/3,3,6/)
  c(6,:) = (/4,4,5/)
ELSE IF (graphnumber.EQ.3) THEN
  c(1,:) = (/-1,2,3/)
  c(2,:) = (/-2,1,4/)
  c(3,:) = (/1,5,6/)
  c(4,:) = (/2,5,6/)
  c(5,:) = (/3,4,6/)
  c(6,:) = (/3,4,5/)
ELSE IF (graphnumber.EQ.4) THEN
  c(1,:) = (/-1,3,4/)
  c(2,:) = (/-2,3,4/)
  c(3,:) = (/1,2,5/)
  c(4,:) = (/1,2,6/)
  c(5,:) = (/3,6,6/)
  c(6,:) = (/4,5,5/)
ELSE IF (graphnumber.EQ.5) THEN
  c(1,:) = (/-1,3,4/)
  c(2,:) = (/-2,3,5/)
  c(3,:) = (/1,2,4/)
  c(4,:) = (/1,3,6/)
  c(5,:) = (/2,6,6/)
  c(6,:) = (/4,5,5/)
ELSE IF (graphnumber.EQ.6) THEN
  c(1,:) = (/-1,3,4/)
  c(2,:) = (/-2,3,5/)
  c(3,:) = (/1,2,5/)
  c(4,:) = (/1,6,6/)
  c(5,:) = (/2,3,6/)
  c(6,:) = (/4,4,5/)
ELSE IF (graphnumber.EQ.7) THEN
  c(1,:) = (/-1,3,4/)
  c(2,:) = (/-2,3,5/)
  c(3,:) = (/1,2,6/)
  c(4,:) = (/1,5,6/)
  c(5,:) = (/2,4,6/)
  c(6,:) = (/3,4,5/)
ELSE IF (graphnumber.EQ.8) THEN
  c(1,:) = (/-1,3,4/)
  c(2,:) = (/-2,5,6/)
  c(3,:) = (/1,4,5/)
  c(4,:) = (/1,3,6/)
  c(5,:) = (/2,3,6/)
  c(6,:) = (/2,4,5/)
ELSE IF (graphnumber.EQ.9) THEN
  c(1,:) = (/-1,3,4/)
  c(2,:) = (/-2,5,6/)
  c(3,:) = (/1,5,5/)
  c(4,:) = (/1,6,6/)
  c(5,:) = (/2,3,3/)
  c(6,:) = (/2,4,4/)
ELSE IF (graphnumber.EQ.10) THEN
  c(1,:) = (/-1,3,4/)
  c(2,:) = (/-2,5,6/)
  c(3,:) = (/1,5,6/)
  c(4,:) = (/1,5,6/)
  c(5,:) = (/2,3,4/)
  c(6,:) = (/2,3,4/)
ELSE IF (graphnumber.EQ.11) THEN
  c(1,:) = (/-1,2,3/)
  c(2,:) = (/-2,1,4/)
  c(3,:) = (/1,4,4/)
  c(4,:) = (/2,3,3/)
ELSE IF (graphnumber.EQ.12) THEN
  c(1,:) = (/-1,3,4/)
  c(2,:) = (/-2,3,4/)
  c(3,:) = (/1,2,4/)
  c(4,:) = (/1,2,3/)
END IF
!
! Exit. We translate the results for C(V,I) into VRTX(P,I), I = 1,2,
! and PROP(P,I), I = 1,2,3. Here NUSED(V) denotes how many propagators
! we have so far assigned connecting to vertex V.
!
        DO vv = 1,nverts
          nused(vv) = 0
        END DO
        graph%vrtx(0,1) = 2
        graph%vrtx(0,2) = 1
        graph%prop(1,1) = 0
        nused(1)  = 1
        graph%prop(2,1) = 0
        nused(2)  = 1
        p = 1
        DO vv = 1,nverts
        DO i = 1,3
          IF (c(vv,i).GT.vv) THEN
            va = vv
            vb = c(vv,i)
            graph%vrtx(p,1) = va
            nused(va) = nused(va) + 1
            graph%prop(va,nused(va)) = p
            graph%vrtx(p,2) = vb
            nused(vb) = nused(vb) + 1
            graph%prop(vb,nused(vb)) = p
            p = p+1
          END IF
        END DO
        END DO
        IF (p.NE.nprops+1) THEN
          write(nout,*)'Snafu in getnewgraph.',p-1,nprops
          write(nout,*)'Graphnumber',graph%graphnumber
          stop
        END IF
        DO vv = 1,nverts
          IF (nused(vv).NE.3) THEN
            write(nout,*)'Problem in getnewwgraph.',vv,nused(vv)
            write(nout,*)'Graphnumber',graph%graphnumber
            stop
          END IF
        END DO
!
! OK. We are ready to return.
!
RETURN
END subroutine getnewgraph
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine getnewflavorset(graphnumber,flavorset,flavorsetfound)
!
use beowulf_helpers
implicit none
!
! In:
integer :: graphnumber
! Out:
type flavorstructure
  integer                               :: setnumber 
  character(len=5), dimension(3*size-1) :: flavor    ! flavor of propagator P
end type flavorstructure
type (flavorstructure) flavorset
logical :: flavorsetfound
!
! Latest revision: 28 June 2002.
!
integer, save :: flavorsetnumber = 0
!
character(len=6), parameter :: gluon  = 'gluon'
character(len=6), parameter :: quark  = 'quark'
character(len=6), parameter :: qbar   = 'qbar '
character(len=6), parameter :: none   = 'none '
flavorsetfound = .false.
flavorsetnumber = flavorsetnumber + 1
!
IF (graphnumber.EQ.1) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,qbar,gluon,gluon,qbar,quark/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,qbar,gluon,gluon,gluon,gluon/)
  ELSE IF(flavorsetnumber.EQ.3) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,gluon,qbar,quark,gluon,qbar/)
  ELSE IF(flavorsetnumber.EQ.4) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,qbar,quark,gluon,gluon,qbar,quark/)
  ELSE IF(flavorsetnumber.EQ.5) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,qbar,quark,gluon,gluon,gluon,gluon/)
  ELSE IF(flavorsetnumber.EQ.6) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,qbar,gluon,quark,qbar,gluon,quark/)
  END IF
ELSE IF(graphnumber.EQ.2) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,gluon,qbar,gluon,quark,qbar/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,qbar,gluon,quark,gluon,qbar,quark/)
  END IF
ELSE IF(graphnumber.EQ.3) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,gluon,qbar,quark,gluon,quark/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,gluon,qbar,gluon,quark,gluon/)
  ELSE IF(flavorsetnumber.EQ.3) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,qbar,gluon,quark,qbar,gluon,qbar/)
  ELSE IF(flavorsetnumber.EQ.4) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,qbar,gluon,quark,gluon,qbar,gluon/)
  END IF
ELSE IF(graphnumber.EQ.4) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,gluon,qbar,quark/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,gluon,gluon,gluon/)
  END IF
ELSE IF(graphnumber.EQ.5) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,qbar,gluon,quark/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,quark,qbar,gluon,quark,gluon,qbar/)
  END IF
ELSE IF(graphnumber.EQ.6) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,gluon,qbar,quark/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,quark,qbar,gluon,gluon,quark,qbar/)
  END IF
ELSE IF(graphnumber.EQ.7) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,qbar,gluon,gluon/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,gluon,qbar,quark/)
  ELSE IF(flavorsetnumber.EQ.3) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,quark,qbar,gluon,quark,gluon,gluon/)
  ELSE IF(flavorsetnumber.EQ.4) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,quark,qbar,gluon,gluon,quark,qbar/)
  END IF
ELSE IF(graphnumber.EQ.8) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,qbar,quark,gluon,gluon,quark/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,quark,gluon,gluon,qbar/)
  ELSE IF(flavorsetnumber.EQ.3) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,quark,qbar,gluon/)
  END IF
ELSE IF(graphnumber.EQ.9) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,quark,gluon,qbar/)
  END IF
ELSE IF(graphnumber.EQ.10) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,qbar,gluon,quark,qbar,gluon/)
  END IF
ELSE IF(graphnumber.EQ.11) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,quark,gluon,qbar,none,none,none/)
  ELSE IF(flavorsetnumber.EQ.2) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/qbar,quark,qbar,gluon,quark,none,none,none/)
  END IF
ELSE IF(graphnumber.EQ.12) THEN
  IF (flavorsetnumber.EQ.1) THEN
   flavorsetfound = .true.
   flavorset%flavor = &
   (/quark,qbar,qbar,quark,gluon,none,none,none/)
  END IF
ELSE
  write(nout,*)'Bad graphnumber in getnewflavorset.'
  STOP
END IF
!
IF (flavorsetfound) THEN
  flavorset%setnumber = flavorsetnumber
ELSE
  flavorsetnumber = 0
END IF
!
RETURN
END subroutine getnewflavorset
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine finda(vrtx,q,nq,order,a,qok)
!
use beowulf_helpers
implicit none
! In:
integer :: vrtx(0:3*size-1,2),q(0:size),nq,order
! Out:
integer :: a(0:3*size-1,0:size)
logical :: qok
!
! Finds matrix A relating propagator momenta to loop momenta.
!
! VRTX(P,N)     specifies the graph considered
! Q(L)           specifies the propagators to be considered independent
! NQ             specifies how many entries of Q should be considered
!   NQ = NLOOPS  all the entries in Q should be considered.
!                If Q(0),Q(1),...,Q(NLOOPS) are independent then
!                FINDA generates the matrix A and sets QOK = .TRUE.
!                Otherwise the generation of A fails and QOK = .FALSE.
!   NQ < NLOOPS  only first NQ entries in Q should be considered.
!                If Q(0),Q(1),...,Q(NQ) are independent then
!                FINDA sets QOK = .TRUE.
!                Otherwise  QOK = .FALSE.
!                In either case, a complete A is not generated.
!
! L              index of loop momenta, L = 0,1,...,NLOOPS.
!                L = 0 normally denontes the virtual photon momentum.
! P              index of propagator, P = 0,1,...,NPROPS.
!                P = 0 denotes the virtual photon momentum.
! V              index of vertices, V = 1,...,NVERTS
! A(P,L)         matrix relating propagator momenta to loop momenta.
!                K(P) = Sum_L A(P,L) K(Q(L)).
! VRTX(P,1) = V means that the vertex connected to the tail of
!                propagator P is V.
! VRTX(P,2) = V means that the vertex connected to the head of
!                propagator P is V.
! Q(L) = P       means that we consider the Lth loop momentum to
!                be that carried by propagator P.
! CONNECTED(V,J) = P means that the Jth propagator connected to
!                vertex V is P.
! FIXED(P) = True means that we have determined the momentum carried
!                by propagator P.
! FINISHED(V) = True means that we have determined the momenta carried
!                by all the propagators connected to vertex V.
! PROPSIGN(VRTX,P,V) is a function that returns +1 if the head of
!                propagator P is at V, -1 if the tail is at V.
! COUNT          is the number of propagators connected to the vertex
!                under consideration such that FIXED(P) = True. If
!                COUNT = 2, then we can fix another propagator momentum.
! 3 July 1994
! 19 December 1995
!
integer :: nloops,nprops,nverts
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
!
integer :: l,p,v,j,l1,l2
integer :: connected(2*size,3)
logical :: fixed(0:3*size-1),finished(2*size)
logical :: change
integer :: propsign,sign
integer :: sum(0:size)
integer :: count
integer :: ptofix
!
IF (order.EQ.1) THEN
  nloops = nloops1
  nprops = nprops1
  nverts = nverts1
ELSE IF (order.EQ.2) THEN
  nloops = nloops2
  nprops = nprops2
  nverts = nverts2
ELSE
  write(nout,*)'Order must be 1 or 2.',order
END IF
!
IF((nq.LT.1).OR.(nq.GT.nloops)) THEN
  write(nout,*)'Nq out of range in finda.'
END IF
!
! First check to see that the same propagator hasn't been
! assigned to two loop variables.
!
DO l1 = 0,nq-1
 DO l2 = l1+1,nq
  IF (q(l1).EQ.q(l2)) THEN
    qok = .false.
    RETURN
  END IF
 END DO
END DO
!
! Initialization.
!
qok = .false.
!
DO v = 1,nverts
  j = 1
  DO p = 0,nprops
   IF( (vrtx(p,1).EQ.v).OR.(vrtx(p,2).EQ.v) ) THEN
    connected(v,j) = p
    j = j+1
   END IF
  END DO
END DO
!
DO p = 0,nprops
  DO l = 0,nloops
    a(p,l) = 0
  END DO
END DO
DO l = 0,nq
  a(q(l),l) = 1
END DO
!
DO p = 0,nprops
  fixed(p) = .false.
END DO
DO l = 0,nq
  fixed(q(l)) = .true.
END DO
!
DO v = 1,nverts
  finished(v) = .false.
END DO
!
change = .true.
!
! Start.
!
DO WHILE (change)
change = .false.
!
DO v = 1,nverts
IF (.NOT.finished(v)) THEN
  count = 0
  DO j = 1,3
   p = connected(v,j)
   IF ( fixed(p) ) THEN
     count = count + 1
   END IF
  END DO
!
! There are 3 already fixed propagators conencted to this vertex, so
! we must check to see if the momenta coming into the vertex sum to
! zero.
!
  IF (count.EQ.3) THEN
    DO l = 0,nq
      sum(l) = 0
    END DO
    DO j = 1,3
      p = connected(v,j)
      sign = propsign(vrtx,p,v)
      DO l = 0,nq
        sum(l) = sum(l) + sign * a(p,l)
      END DO
    END DO
    DO l = 0,nq
!
! Dependent propagators given to FINDA.
!
      IF (sum(l).NE.0) THEN
        qok = .false.
        RETURN
!
      END IF
    END DO
    finished(v) = .true.
    change = .true.
!
! There are two already fixed propagators connected to this vertex,
! so we should determine the momentum carried by the remaining,
! unfixed, propagator.
!
  ELSE IF (count.EQ.2) THEN
    DO l = 0,nq
      sum(l) = 0
    END DO
    DO j = 1,3
      p = connected(v,j)
      IF ( fixed(p) ) THEN
        sign = propsign(vrtx,p,v)
        DO l = 0,nq
          sum(l) = sum(l) + sign * a(p,l)
        END DO
      ELSE
        ptofix = p
      END IF
    END DO
    sign = propsign(vrtx,ptofix,v)
    DO l = 0,nq
      a(ptofix,l) =  - sign * sum(l)
    END DO
    fixed(ptofix) = .true.
    finished(v) = .true.
    change = .true.
  END IF
!
! Close loop DO V = 1,NVERTS ; IF (.NOT.FINISHED(V)) THEN.
!
END IF
END DO
!
! Close loop DO WHILE (CHANGE)
!
END DO
!
! At this point, we have not found a contradiction with momentum
! conservation, so the Q's must have been OK:
!
qok = .true.
!
! If we had been given a complete set of Q's, then we should have
! fixed each propagator at each vertex. Check just to make sure.
!
IF (nq.EQ.nloops) THEN
DO v = 1,nverts
  IF (.NOT.finished(v) ) THEN
    write(nout,*)'Snafu in finda.'
    write(nout,*)'v = ',v,'  nq =',nq
    write(nout,*)'q =',q(0),q(1),q(2),q(3)
    stop
  END IF
END DO
END IF
!
RETURN
!
END subroutine finda
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function propsign(vrtx,p,v)
!
use beowulf_helpers
implicit none
! In:
integer :: vrtx(0:3*size-1,2)
integer :: p,v
! Out:
integer :: propsign
!
!
IF ( vrtx(p,1).EQ.v ) THEN
    propsign = -1
    RETURN
ELSE IF ( vrtx(p,2).EQ.v ) THEN
    propsign = 1
    RETURN
ELSE
    write(nout,*)'Propsign called for p not connected to v.'
    stop
END IF
END function propsign
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine findtypes(graph,nmaps,qs,qsigns,maptypes)
!
use beowulf_helpers
implicit none
! In:
type graphstructure
  integer                          :: graphnumber
  integer                          :: order
  integer, dimension(0:3*size-1,2) :: vrtx
  integer, dimension(2*size,3)     :: prop
end type graphstructure
type(graphstructure) :: graph
! Out:
integer :: nmaps,qs(maxmaps,0:size),qsigns(maxmaps,0:size)
character(len=6) :: maptypes(maxmaps)
!
! Given a graph specified by VRTX and PROP, this subroutine finds the 
! characteristics of each map, labelled by an index MAPNUMBER. For a given map,
! it finds labels Q of 'special' propagators and the corresponding signs QSIGN 
! and the MAPTYPE. The subroutine does finds the total number of maps, NMAPS, 
! and fills the corresponding arrays QS, QSIGNS, and MAPTYPES, each of which
! carries a MAPNUMBER index. The definition is that the loop momenta are
!
!   ELL(L,mu) = K(Q(L),mu)   for L = 1,2,3.
!
! The other K(P,mu) are related to these by K(P,mu) = Sum A_{P,L} ELL(L,mu). 
! Following the paper "Choosing integration points for QCD calculations by
! numerical integration" (Phys. Rev. D 64, 034018 (2001)), we also define 
! vectors ELL1(mu), ELL2(mu) = P1(mu), and ELL3(mu) = P2(mu) which equal the 
! respective ELL(L,mu) up to signs:
!
!   ELL(1,mu) = QSIGN(1)*ELL1(mu)
!   ELL(2,mu) = QSIGN(2)*ELL2(mu)
!   ELL(3,mu) = QSIGN(3)*ELL3(mu)
!
! The paper does not, unfortunately, take note of these signs. The momentum
! flow directions shown in the paper are those of {ELL1(mu),ELL2(mu),ELL3(mu)}.
! The signs arise because the momentum flow directions for the propagator
! momenta K(P,mu) have independent definitions. 
!
! The possibilities for maptypes are as follows:
! 
! 1) T2TO2T used for k1 + k2 -> p1 + p2 with a virtual parton
! with momentum q exchanged, q = k1 - p1. Then P(Q(1)) = q,
! P(Q(2)) = p1, P(Q(3)) = p2. We will generate points with
! CHOOSET2TO2T(p1,p2,ell1,ok).
! 
! 2) T2TO2S used for k1 + k2 -> p1 + p2 with a *no* virtual
! parton with momentum q = k1 - p1 exchanged. Then P(Q(1)) = k1,
! P(Q(2)) = p1, P(Q(3)) = p2. We will generate points with
! CHOOSE2TO2S(p1,p2,ell1,ok).
! 
! 3) T2TO3  used for k1 + k2 -> p1 + p2 + p3 with k2 = - k1.
! Then P(Q(1)) = k1, P(Q(2)) = p1, P(Q(3)) = p2. We will generate
! points with CHOOSET2TO3(p1,p2,ell1,ok).
! 
! 4) T2TO1A  used for k1 + k2 -> p1 on shell for a virtual self-energy
! diagram. We will choose points with CHOOSEST2TO1A(p1,p2,ell1,ok).
!
! 4) T2TO1B  used for k1 + k2 -> p1 on shell for a virtual three or four
! point function. We will choose points with CHOOSEST2TO1B(p1,p2,ell1,ok).
! This case is not discussed in the paper "Choosing integration points
! for QCD calculations by numerical integration." It is designed for
! the weak 1/\theta collinear singularities that occur in diagrams other
! than self energy diagrams in Coulomb gauge before real-virtual cancellations.
!
! We also have the possibility of Born graphs, for which the maptype
! is BORN and Q(1) and Q(2) are chosen as two of the cut propagators.
!
! 20 December 2000
! 20 March  2001
!  1 February 2002
! 13 June 2002
!  7 December 2002
!
integer :: cutmax
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
!
integer :: mapnumber
! Newcut variables
type cutstructure
  integer                        :: cutnumber ! identifies the cut
  integer                        :: ncut      ! number of cut propagators
  integer, dimension(size+1)     :: cutindex  ! index of cut propagator
  integer, dimension(size+1)     :: cutsign   ! direction of cut propagator
  logical                        :: leftloop  !there is a loop to left
  logical                        :: rightloop !there is a loop to right
  integer                        :: ninloop   ! number of props in loop
  integer, dimension(size+1)     :: loopindex ! indices around loop
  integer, dimension(size+1)     :: loopsign  ! propagator directions
end type cutstructure
type (cutstructure) :: cut
logical :: cutfound
!
integer :: l,p,kj,k1,k2,kdirect,ptest,pleaving,pp1,pp2
integer :: l1,signl1,ltesta,ltestb
integer :: i,j,jfound1,jfound2,jfound
integer :: v1,v2,v3,vother,vv1,vv2
integer :: sign0,sign1,sign2
integer :: timesfound1,timesfound2,timesfound
integer :: pl,signl,vl,kl,signkl
logical :: notinloop
!
!----------------------------------
!
IF (graph%order.EQ.1) THEN
  cutmax = cutmax1
ELSE IF (graph%order.EQ.2) THEN
  cutmax = cutmax2
ELSE
  write(nout,*)'Order must be 1 or 2.',graph%order
END IF
!
mapnumber = 0
DO
call getnewcut(graph%graphnumber,cut,cutfound)
!
IF (cutfound) THEN
!
IF (graph%order.EQ.1) THEN
!
! First, we have the code for what to do for Born graphs. There
! is no Q(3) or QSIGN(3) in this case.
!
mapnumber = mapnumber + 1
qs(mapnumber,0) = 0
qsigns(mapnumber,0) = +1
qs(mapnumber,1) = cut%cutindex(1)
qsigns(mapnumber,1) = cut%cutsign(1)
qs(mapnumber,2) = cut%cutindex(2)
qsigns(mapnumber,2) = cut%cutsign(2)
qs(mapnumber,3) = 137
qsigns(mapnumber,3) = 137
maptypes(mapnumber) = 'born  '
!
! Alternative for IF (ORDER.EQ.1) THEN
!
ELSE IF (graph%order.EQ.2) THEN
!
! We want to do something only if there is a virtual loop:
!
IF (cut%ncut.EQ.(cutmax-1)) THEN
!---
! Case of 4 propagators in the loop
!---
IF (cut%ninloop.EQ.4) THEN
!
! For a 4 propagator loop there are three 2 to 1 maps.
!
DO l = 1,3
  mapnumber = mapnumber + 1
!
! We let pl be the lth propagator around the loop and vl be the lth
! vertex around the loop. Also, signl = +1 if propagator pl is directed
! in the positive loop direction.
!
  pl = cut%loopindex(l)
  signl = cut%loopsign(l)
  IF (signl.EQ.1) THEN
    vl = graph%vrtx(pl,2)
  ELSE
    vl = graph%vrtx(pl,1)
  END IF
!
! We find the cut propagator kl connected to vl along
! with signkl = +1 if the cut propagator kl is leaving vertex vl
! and signkl = -1 if the cut propagator kl is entering vertex vl. Just
! as a check, we define TIMESFOUND to see if we find kl exactly
! once.
!
  timesfound = 0
  DO j = 1,3
    kj = cut%cutindex(j)
    IF (graph%vrtx(kj,1).EQ.vl) THEN
      kl = kj
      signkl = +1
      jfound = j
      timesfound = timesfound + 1
    ELSE IF (graph%vrtx(kj,2).EQ.vl) THEN
      kl = kj
      signkl = -1
      jfound = j
      timesfound = timesfound + 1
    END IF
  END DO
  IF (timesfound.NE.1) THEN
    write(nout,*) 'Failure in findtypes.'
    stop
  END IF
!
! Now we record this information. The propagator Q(3) is one of the 
! propagators in the final state other than that connected to vl. The
! corresponding sign is +1 if this propagator crosses the final
! state cut in the same direction as the propagator connected to vl.
!
  qs(mapnumber,0) = 0
  qsigns(mapnumber,0) = +1
  qs(mapnumber,1) = pl
  qsigns(mapnumber,1) = signl
  qs(mapnumber,2) = kl
  qsigns(mapnumber,2) = signkl
  IF (cut%cutindex(1).NE.kl) THEN
    qs(mapnumber,3) = cut%cutindex(1)
    qsigns(mapnumber,3) = cut%cutsign(1)*cut%cutsign(jfound)*signkl
  ELSE
    qs(mapnumber,3) = cut%cutindex(2)
    qsigns(mapnumber,3) = cut%cutsign(2)*cut%cutsign(jfound)*signkl
  END IF
  maptypes(mapnumber) = 't2to1b'
!
! Close DO l = 1,3
END DO
!
! For a 4 propagator loop there are two ellipse maps (T2T02T) and 
! one circle map (T2TO3). We do the two ellipse maps first.
!
DO l = 2,3
    mapnumber = mapnumber + 1
    p = cut%loopindex(l)
    v1 = graph%vrtx(p,1)
    v2 = graph%vrtx(p,2)
!
! We find the cut propagators K1 and K2 connected to V1 and V2 along
! with the sign = +1 if the cut propagator Kj is leaving vertex Vj
! and sign = -1 if the cut propagator Kj is entering vertex Vj. Just
! as a check, we define FOUNDJ to see if we find K1 and K2 exactly
! once.
!
    timesfound1 = 0
    timesfound2 = 0
    DO j = 1,3
      kj = cut%cutindex(j)
      IF (graph%vrtx(kj,1).EQ.v1) THEN
        k1 = kj
        sign1 = +1
        timesfound1 = timesfound1+1
      ELSE IF (graph%vrtx(kj,2).EQ.v1) THEN
        k1 = kj
        sign1 = -1
        timesfound1 = timesfound1+1
      ELSE IF (graph%vrtx(kj,1).EQ.v2) THEN
        k2 = kj
        sign2 = +1
        timesfound2 = timesfound2+1
      ELSE IF (graph%vrtx(kj,2).EQ.v2) THEN
        k2 = kj
        sign2 = -1
        timesfound2 = timesfound2+1
      END IF
    END DO
    IF ((timesfound1.NE.1).OR.(timesfound2.NE.1)) THEN
      write(nout,*) 'Failure in findtypes.'
      stop
    END IF
!
! Now we record this information.
!
    qs(mapnumber,0) = 0
    qsigns(mapnumber,0) = +1
    qs(mapnumber,1) = p
    qsigns(mapnumber,1) = +1
    qs(mapnumber,2) = k1
    qsigns(mapnumber,2) = sign1
    qs(mapnumber,3) = k2
    qsigns(mapnumber,3) = sign2
    maptypes(mapnumber) = 't2to2t'
!
! End  DO L = 2,3 for the choice of two ellipse maps.
!
END DO
!
! Now we do the circle map.
! Our definition for the circle map T2TO3E is that Q(1) is
! LOOPINDEX(1) the first propagator in the loop starting from the
! current vertex.  Then Q(2) is the label of the propagator that
! enters the final state and connects to the vertex at the head
! of propagator Q(1).  Then Q(3) is the label of the propagator
! that enters the final state and connects to the propagator with
! label LOOPINDEX(4), the last propagator in the loop.  The sign
! QSIGN(1) = +1 since this propagator always points *from* the
! current vertex. For QSIGN(2) and QSIGN(3) a plus sign indicates
! that the propagator points toward the final state, a minus sign
! indicates the opposite.
!
IF(cut%loopsign(1).NE.1) THEN
  write(nout,*)'loopsign(1) not 1 in findtypes.'
  stop
ELSE IF(cut%loopsign(4).NE.-1) THEN
  write(nout,*)'loopsign(4) not -1 in findtypes.'
  stop
END IF
!
v1 = graph%vrtx(cut%loopindex(1),2)
v2 = graph%vrtx(cut%loopindex(4),2)
timesfound1 = 0
timesfound2 = 0
DO j = 1,3
  kj = cut%cutindex(j)
  IF (graph%vrtx(kj,1).EQ.v1) THEN
    k1 = kj
    sign1 = +1
    timesfound1 = timesfound1+1
  ELSE IF (graph%vrtx(kj,2).EQ.v1) THEN
    k1 = kj
    sign1 = -1
    timesfound1 = timesfound1+1
  ELSE IF (graph%vrtx(kj,1).EQ.v2) THEN
    k2 = kj
    sign2 = +1
    timesfound2 = timesfound2+1
  ELSE IF (graph%vrtx(kj,2).EQ.v2) THEN
    k2 = kj
    sign2 = -1
    timesfound2 = timesfound2+1
  END IF
END DO
IF ((timesfound1.NE.1).OR.(timesfound2.NE.1)) THEN
  write(nout,*) 'Oops, failure in findtypes.', &
                 timesfound1,timesfound2
  stop
END IF
!
mapnumber = mapnumber + 1
qs(mapnumber,0) = 0
qsigns(mapnumber,0) = +1
qs(mapnumber,1) = cut%loopindex(1)
qsigns(mapnumber,1) = +1
qs(mapnumber,2) = k1
qsigns(mapnumber,2) = sign1
qs(mapnumber,3) = k2
qsigns(mapnumber,3) = sign2
maptypes(mapnumber) = 't2to3e'
!
!---
! Case of 3 propagators in the loop
!---
ELSE IF (cut%ninloop.EQ.3) THEN
!
! With three propagators in the loop there are one or two 2 to 1 maps.
!
DO l = 1,2
!
! We let pl be the lth propagator around the loop and vl be the lth
! vertex around the loop. Also, signl = +1 if propagator pl is directed
! in the positive loop direction.
!
  pl = cut%loopindex(l)
  signl = cut%loopsign(l)
  IF (signl.EQ.1) THEN
    vl = graph%vrtx(pl,2)
  ELSE
    vl = graph%vrtx(pl,1)
  END IF
!
! We find the cut propagator kl connected to vl along
! with signkl = +1 if the cut propagator kl is leaving vertex vl
! and signkl = -1 if the cut propagator kl is entering vertex vl. 
! We define TIMESFOUND to see if we find kl exactly once. It can
! happen that we will not find final state propagator that connects
! to vl. Then we do not record a 2 to 1 map.
!
  timesfound = 0
  DO j = 1,3
    kj = cut%cutindex(j)
    IF (graph%vrtx(kj,1).EQ.vl) THEN
      kl = kj
      signkl = +1
      jfound = j
      timesfound = timesfound + 1
    ELSE IF (graph%vrtx(kj,2).EQ.vl) THEN
      kl = kj
      signkl = -1
      jfound = j
      timesfound = timesfound + 1
    END IF
  END DO
  IF (timesfound.GT.1) THEN
    write(nout,*) 'Failure in findtypes.'
    stop
  ELSE IF (timesfound.EQ.1) THEN
!
! We have a 2 to 1 map and we need to record this information.
! The propagator Q(3) is one of the propagators in the final state other
! than that connected to vl. The corresponding sign is +1 if this propagator 
! crosses the final state cut in the same direction as the propagator 
! connected to vl.
!
  mapnumber = mapnumber + 1
  qs(mapnumber,0) = 0
  qsigns(mapnumber,0) = +1
  qs(mapnumber,1) = pl
  qsigns(mapnumber,1) = signl
  qs(mapnumber,2) = kl
  qsigns(mapnumber,2) = signkl
  IF (cut%cutindex(1).NE.kl) THEN
    qs(mapnumber,3) = cut%cutindex(1)
    qsigns(mapnumber,3) = cut%cutsign(1)*cut%cutsign(jfound)*signkl
  ELSE
    qs(mapnumber,3) = cut%cutindex(2)
    qsigns(mapnumber,3) = cut%cutsign(2)*cut%cutsign(jfound)*signkl
  END IF
  maptypes(mapnumber) = 't2to1b'
!
! Close ELSE IF (timesfound.EQ.1) THEN
  END IF
! Close DO l = 1,3
END DO
!
! Now continuing with the virtual three point function, we will need
! either a 2to2(t) map or a 2to2(s) map and a 2to3 map.
! We are not sure which of two possibilities we have, but we proceed
! as if we had the case of a virtual loop that connects to two 
! propagators that go into the final state.
!
mapnumber = mapnumber + 1
p = cut%loopindex(2)
v1 = graph%vrtx(p,1)
v2 = graph%vrtx(p,2)
!
! We find the cut propagators K1 and K2 connected to V1 and V2 along
! with the sign = +1 if the cut propagator Kj is leaving vertex Vj
! and sign = -1 if the cut propagator Kj is entering vertex Vj. We
! check using FOUNDJ to see if we find K1 and K2 exactly once.
!
timesfound1 = 0
timesfound2 = 0
DO j = 1,3
  kj = cut%cutindex(j)
  IF (graph%vrtx(kj,1).EQ.v1) THEN
    k1 = kj
    sign1 = +1
    timesfound1 = timesfound1+1
  ELSE IF (graph%vrtx(kj,2).EQ.v1) THEN
    k1 = kj
    sign1 = -1
    timesfound1 = timesfound1+1
  ELSE IF (graph%vrtx(kj,1).EQ.v2) THEN
    k2 = kj
    sign2 = +1
    timesfound2 = timesfound2+1
  ELSE IF (graph%vrtx(kj,2).EQ.v2) THEN
    k2 = kj
    sign2 = -1
    timesfound2 = timesfound2+1
  END IF
END DO
!
! Now we figure out what to do based on what we found.
!
IF ((timesfound1.GT.1).OR.(timesfound2.GT.1)) THEN
   write(nout,*) 'Failure in findtypes.'
   stop
ELSE IF ((timesfound1.LT.1).AND.(timesfound2.LT.1)) THEN
   write(nout,*) 'Failure in findtypes.'
   stop
!
ELSE IF ((timesfound1.EQ.1).AND.(timesfound2.EQ.1)) THEN
!
! This is the case we were looking for. Now we record the information.
!
qs(mapnumber,0) = 0
qsigns(mapnumber,0) = +1
qs(mapnumber,1) = p
qsigns(mapnumber,1) = +1
qs(mapnumber,2) = k1
qsigns(mapnumber,2) = sign1
qs(mapnumber,3) = k2
qsigns(mapnumber,3) = sign2
maptypes(mapnumber) = 't2to2t'
!
ELSE
!
! Either Found1 = 1 and Found2 = 0 or Found2 = 1 and Found1 = 0.
! In these cases our loop does *not* connect to two propagators 
! that go to the final state. The label of the propagator
! that enters the final state will be called Kdirect and the 
! vertex that does not connect to this propagator will be called
! Vother. We take sign0 = +1 if our loop propagator points from
! Kdirect to the s-channel propagator that splits into two
! propagators that go to the final state. Otherwise sign0 = -1.
!
IF ((timesfound1.EQ.1).AND.(timesfound2.EQ.0)) THEN
  kdirect = k1
  vother = v2
  sign0 = +1
ELSE IF ((timesfound1.EQ.0).AND.(timesfound2.EQ.1)) THEN
  kdirect = k2
  vother = v1
  sign0 = -1
END IF
!
! Now we deal with this case.
!
IF (cut%cutindex(1).EQ.kdirect) THEN
  k1 = cut%cutindex(2)
  k2 = cut%cutindex(3)
ELSE IF (cut%cutindex(2).EQ.kdirect) THEN
  k1 = cut%cutindex(3)
  k2 = cut%cutindex(1)
ELSE IF (cut%cutindex(3).EQ.kdirect) THEN
  k1 = cut%cutindex(1)
  k2 = cut%cutindex(2)
ELSE
  write(nout,*)'We are in real trouble here.'
  stop
END IF
!
! We have K1 and K2, but we need the corresponding signs.
! Find the index Pleaving of the propagator leaving the loop toward
! the final state.
!
timesfound = 0
DO j = 1,3
  ptest = graph%prop(vother,j)
  notinloop = .true.
  DO i = 1,3
     IF (ptest.EQ.cut%loopindex(i)) THEN
        notinloop = .false.
     END IF
  END DO
  IF (notinloop) THEN
     pleaving = ptest
     timesfound = timesfound + 1
  END IF
END DO
IF (timesfound.NE.1) THEN
   write(nout,*)'pleaving not found or found twice.'
   stop
END IF
!
! Let V3 be the vertex not in the loop at the end of propagator
! Pleaving. Two propagators in the final state must connect to this
! vertex.
!
v3 = graph%vrtx(pleaving,1)
IF (v3.EQ.vother) THEN
  v3 = graph%vrtx(pleaving,2)
END IF
!
! We use V3 to get the proper signs.
!
IF (graph%vrtx(k1,1).EQ.v3) THEN
    sign1 = +1
ELSE IF (graph%vrtx(k1,2).EQ.v3) THEN
    sign1 = -1
ELSE
  write(nout,*)'Yikes, this is bad.'
  stop
END IF
IF (graph%vrtx(k2,1).EQ.v3) THEN
    sign2 = +1
ELSE IF (graph%vrtx(k2,2).EQ.v3) THEN
    sign2 = -1
ELSE
  write(nout,*)'Yikes, this is also bad.'
  stop
END IF
!
! Now we record the information.
! Recall that P = LOOPINDEX(2) and that SIGN0 = +1 if propagator P
! points toward propagator Pleaving.
!
qs(mapnumber,0) = 0
qsigns(mapnumber,0) = +1
qs(mapnumber,1) = p
qsigns(mapnumber,1) = sign0
qs(mapnumber,2) = k1
qsigns(mapnumber,2) = sign1
qs(mapnumber,3) = k2
qsigns(mapnumber,3) = sign2
maptypes(mapnumber) = 't2to2s'
!
! But we are not done, because in this case we need a circle map too.
! Our definition for the circle map T2TO3D is that Q(1) is
! LOOPINDEX(1) or LOOPINDEX(3), one of the two propagators that
! connects to a propagator that connects to the current vertex.
! We take the one that connects to vertex Vother that connects to
! a propagator Pleaving that connects vertex V3 that, finally,
! connects to to two propagators that enter the final state. Then
! Q(3) and Q(3) are these two propagators that enter the final
! state from vertex V3.  For QSIGN(2) and QSIGN(3) a plus sign
! indicates that the propagator points toward the final state, a
! minus sign indicates the opposite.  The sign QSIGN(1) is + 1 if
! this propagator points toward the final state, -1 in the
! opposite circumstance.
!
IF (cut%loopsign(1).NE.1) THEN
  write(nout,*)'loopsign not 1 in findtypes.'
  stop
END IF
!
! The loop momentum with label L1 is the one that
! attaches to VOTHER (the vertex that connects to a propagator
! that splits before going to the final state.) We take
! SIGNL1 = +1 if this propagator points towards VOTHER.
!
ltesta = cut%loopindex(1)
ltestb = cut%loopindex(3)
IF (graph%vrtx(ltesta,2).EQ.vother) THEN
    l1 = ltesta
    signl1 = +1
ELSE IF (graph%vrtx(ltesta,1).EQ.vother) THEN
    l1 = ltesta
    signl1 = -1
ELSE IF (graph%vrtx(ltestb,2).EQ.vother) THEN
    l1 = ltestb
    signl1 = +1
ELSE IF (graph%vrtx(ltestb,1).EQ.vother) THEN
    l1 = ltestb
    signl1 = -1
ELSE
  write(nout,*)'Cannot seem to find l1.'
  stop
END IF
!
mapnumber = mapnumber + 1
qs(mapnumber,0) = 0
qsigns(mapnumber,0) = +1
qs(mapnumber,1) = l1
qsigns(mapnumber,1) = signl1
qs(mapnumber,2) = k1
qsigns(mapnumber,2) = sign1
qs(mapnumber,3) = k2
qsigns(mapnumber,3) = sign2
maptypes(mapnumber) = 't2to3d'
!
! Close the IF structure for the case of three particles in the loop,
! IF (FOUND1.GT.1).OR.(FOUND2.GT.1) THEN ...
!
END IF
!---
! Case of 2 propagators in the loop
!---
ELSE IF (cut%ninloop.EQ.2) THEN
!
! We are not sure which of two possibilities we have, but we proceed
! as if we had the case of a virtual loop that connects to two 
! propagators that go into the final state.
!
mapnumber = mapnumber + 1
p = cut%loopindex(1)
v1 = graph%vrtx(p,1)
v2 = graph%vrtx(p,2)
!
! We find the cut propagators K1 or K2 connected to V1 or V2 along
! with the sign = +1 if the cut propagator Kj is leaving vertex Vj
! and sign = -1 if the cut propagator Kj is entering vertex Vj. We
! check using FOUNDJ to see if we find K1 or K2 exactly once.
!
timesfound1 = 0
timesfound2 = 0
DO j = 1,3
  kj = cut%cutindex(j)
  IF (graph%vrtx(kj,1).EQ.v1) THEN
    k1 = kj
    sign1 = +1
    jfound1 = j
    timesfound1 = timesfound1+1
  ELSE IF (graph%vrtx(kj,2).EQ.v1) THEN
    k1 = kj
    sign1 = -1
    jfound1 = j
    timesfound1 = timesfound1+1
  ELSE IF (graph%vrtx(kj,1).EQ.v2) THEN
    k2 = kj
    sign2 = +1
    jfound2 = j
    timesfound2 = timesfound2+1
  ELSE IF (graph%vrtx(kj,2).EQ.v2) THEN
    k2 = kj
    sign2 = -1
    jfound2 = j
    timesfound2 = timesfound2+1
  END IF
END DO
!
! Now we figure out what to do based on what we found.
!
IF ((timesfound1.GT.1).OR.(timesfound2.GT.1)) THEN
   write(nout,*) 'Failure in findtypes.'
   stop
!
ELSE IF ((timesfound1.EQ.1).AND.(timesfound2.EQ.0)) THEN
!
! This is one of the cases we were looking for. Now we record the 
! information. The propagator Q(3) is one of the propagators
! in the final state other than that connected to our loop. The
! corresponding sign is +1 if this propagator crosses the final
! state cut in the same direction as the propagator connected to
! our loop.
!
qs(mapnumber,0) = 0
qsigns(mapnumber,0) = +1
qs(mapnumber,1) = p
qsigns(mapnumber,1) = -1
qs(mapnumber,2) = k1
qsigns(mapnumber,2) = sign1
IF (cut%cutindex(1).NE.k1) THEN
  qs(mapnumber,3) = cut%cutindex(1)
  qsigns(mapnumber,3) = cut%cutsign(1)*cut%cutsign(jfound1)*sign1
ELSE
  qs(mapnumber,3) = cut%cutindex(2)
  qsigns(mapnumber,3) = cut%cutsign(2)*cut%cutsign(jfound1)*sign1
END IF
maptypes(mapnumber) = 't2to1a'
!
ELSE IF ((timesfound1.EQ.0).AND.(timesfound2.EQ.1)) THEN
!
! This is one of the cases we were looking for. Now we record the 
! information. The propagator Q(3) is one of the propagators
! in the final state other than that connected to our loop. The
! corresponding sign is +1 if this propagator crosses the final
! state cut in the same direction as the propagator connected to
! our loop.
!
qs(mapnumber,0) = 0
qsigns(mapnumber,0) = +1
qs(mapnumber,1) = p
qsigns(mapnumber,1) = +1
qs(mapnumber,2) = k2
qsigns(mapnumber,2) = sign2
IF (cut%cutindex(1).NE.k2) THEN
  qs(mapnumber,3) = cut%cutindex(1)
  qsigns(mapnumber,3) = cut%cutsign(1)*cut%cutsign(jfound2)*sign2
ELSE
  qs(mapnumber,3) = cut%cutindex(2)
  qsigns(mapnumber,3) = cut%cutsign(2)*cut%cutsign(jfound2)*sign2
END IF
maptypes(mapnumber) = 't2to1a'
!
ELSE IF ((timesfound1.EQ.0).AND.(timesfound2.EQ.0)) THEN
!
! Here TimesFound1 = 0 and TimesFound2 = 0, so our loop does *not* 
! connect to a propagator that goes to the final state.
! Find the indices PP1 and PP2 of the propagators connected to
! our loop.
!
timesfound = 0
DO j = 1,3
  ptest = graph%prop(v1,j)
  notinloop = .true.
  DO i = 1,2
     IF (ptest.EQ.cut%loopindex(i)) THEN
        notinloop = .false.
     END IF
  END DO
  IF (notinloop) THEN
     pp1 = ptest
     timesfound = timesfound + 1
  END IF
END DO
IF (timesfound.NE.1) THEN
   write(nout,*)'pp1 not found or found twice.'
   stop
END IF
timesfound = 0
!
DO j = 1,3
  ptest = graph%prop(v2,j)
  notinloop = .true.
  DO i = 1,2
     IF (ptest.EQ.cut%loopindex(i)) THEN
        notinloop = .false.
     END IF
  END DO
  IF (notinloop) THEN
     pp2 = ptest
     timesfound = timesfound + 1
  END IF
END DO
IF (timesfound.NE.1) THEN
   write(nout,*)'pp2 not found or found twice.'
   stop
END IF
!
! Let VV1 and VV2 be the vertices not in the loop at the end of
! propagators PP1 and PP2 respectively. Two propagators in the final 
! state must connect to one of these vertices.
!
vv1 = graph%vrtx(pp1,1)
IF (vv1.EQ.v1) THEN
  vv1 = graph%vrtx(pp1,2)
END IF
vv2 = graph%vrtx(pp2,1)
IF (vv2.EQ.v2) THEN
  vv2 = graph%vrtx(pp2,2)
END IF
!
! We have VV1 and VV2. A slight hitch is that one of them might be
! the vertex 1 or 2 that connect to the photon. In this case, 
! in the next step we do *not* want to find the final state
! propagator that connects to this vertex. A cure is to set the
! vertex number to something impossible.
!
IF ((vv1.EQ.1).OR.(vv1.EQ.2)) THEN
  vv1 = -17
END IF
IF ((vv2.EQ.1).OR.(vv2.EQ.2)) THEN
  vv2 = -17
END IF
!
! Now we find two final state propagators connected to VV1 or
! else two final state propagators connected to VV2.
!
timesfound = 0
DO j = 1,3
  kj = cut%cutindex(j)
  IF (graph%vrtx(kj,1).EQ.vv1) THEN
    IF(timesfound.EQ.0) THEN
      k1 = kj
      sign1 = +1
    ELSE
      k2 = kj
      sign2 = +1
    END IF
    sign0 = -1
    timesfound = timesfound+1
  ELSE IF (graph%vrtx(kj,1).EQ.vv2) THEN
    IF(timesfound.EQ.0) THEN
      k1 = kj
      sign1 = +1
    ELSE
      k2 = kj
      sign2 = +1
    END IF
    sign0 = +1
    timesfound = timesfound+1
  ELSE IF (graph%vrtx(kj,2).EQ.vv1) THEN
    IF(timesfound.EQ.0) THEN
      k1 = kj
      sign1 = -1
    ELSE
      k2 = kj
      sign2 = -1
    END IF
    sign0 = -1
    timesfound = timesfound+1
  ELSE IF (graph%vrtx(kj,2).EQ.vv2) THEN
    IF(timesfound.EQ.0) THEN
      k1 = kj
      sign1 = -1
    ELSE
      k2 = kj
      sign2 = -1
    END IF
    sign0 = +1
    timesfound = timesfound+1
  END IF
END DO
IF (timesfound.NE.2) THEN
   write(nout,*)'Where are those tricky propagators?',timesfound
   stop
END IF
!
! Now we record the information.
! Recall that P = LOOPINDEX(1) and that SIGN0 = +1 if propagator P
! points toward propagators in the final state.
!
qs(mapnumber,0) = 0
qsigns(mapnumber,0) = +1
qs(mapnumber,1) = p
qsigns(mapnumber,1) = sign0
qs(mapnumber,2) = k1
qsigns(mapnumber,2) = sign1
qs(mapnumber,3) = k2
qsigns(mapnumber,3) = sign2
maptypes(mapnumber) = 't2to2s'
!
! Close IF ((TIMESFOUND1.GT.1).OR.(TIMESFOUND2.GT.1)) THEN ...
!
END IF
!
! Case of less than 2 propagators in the loop
!
ELSE
  write(nout,*) 'Looped the loop in finddqs.'
  stop
!
! End IF (NINLOOP.EQ. n ) series
!
END IF
!
! End IF (there is a virtual loop) THEN ... 
!
END IF
!
! Close IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ...
!
ELSE
  write(nout,*)'Order in findtypes needed to be 1 or 2.'
  stop
END IF
!
! End IF (CUTFOUND) THEN ... If the cut was not found, then we are done.
!
ELSE
    EXIT
END IF
!
! End main loop: DO call getnewcut()
!
END DO
!
nmaps = mapnumber
RETURN
END subroutine findtypes
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine newpoint(a,qsign,maptype,order,k,absk,badpoint)
!
use beowulf_helpers
implicit none
! In:
integer :: a(0:3*size-1,0:size),qsign(0:size)
character(len=6) :: maptype
integer :: order
! Out:
real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1)
logical :: badpoint
!
! Chooses a new Monte Carlo point in the space of loop 3-momenta.
! 4 March 1993
! 12 July 1993
! 17 July 1994
!  2 May 1996
!  5 February 1997
!  4 February 1999
! 10 March 1999
!  9 April 1999
! 20 August 1999
! 21 December 2000 <cut based method for choosing points>
! 20 March 2001
!  8 February 2002
!  7 December 2002
!
integer :: nprops
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
!
real(kind=dbl) :: p1(3),p2(3),p3(3),ell1(3)
integer :: p,mu
real(kind=dbl) :: temp,ksq
logical :: ok
!
!------------
!
IF (order.EQ.1) THEN
  nprops = nprops1
ELSE IF (order.EQ.2) THEN
  nprops = nprops2
ELSE
  write(nout,*)'Order must be 1 or 2.',order
END IF
!
badpoint = .false.
!
IF (order.EQ.1) THEN
!
! We deal with the case of a Born graph first.
!
call choose3(p1,p2,p3,ok)
IF(.NOT.ok) THEN
  DO p = 1,nprops
  DO mu = 0,3
    k(p,mu) = 0.0d0
  END DO
  END DO
  badpoint = .true.
  RETURN
END IF
DO p = 1,nprops
  ksq = 0.0d0
  DO mu = 1,3
    temp =  a(p,1)*qsign(1)*p1(mu)  &
          + a(p,2)*qsign(2)*p2(mu)
    k(p,mu) = temp
    ksq = ksq + temp**2
END DO
  absk(p) = sqrt(ksq)
  k(p,0) = 0.0d0
END DO
DO mu = 0,3
  k(0,mu) = 0.0d0
END DO
absk(0) = 0.0d0
!
! Alternative for  IF (ORDER.EQ.1) THEN
!
ELSE IF (order.EQ.2) THEN
!
! Here is what we do for order alpha_s^2 graphs.
!
! Our notation: The definition is that the loop momenta are
!
!   ELL(L,mu) = K(Q(L),mu)   for L = 1,2,3.
!
! The other K(P,mu) are related to these by K(P,mu) = Sum A_{P,L} ELL(L,mu). 
! Following the paper "Choosing integration points for QCD calculations by
! numerical integration" (Phys. Rev. D 64, 034018 (2001)), we also define 
! vectors ELL1(mu), ELL2(mu) = P1(mu), and ELL3(mu) = P2(mu) which equal the 
! respective ELL(L,mu) up to signs:
!
!   ELL(1,mu) = QSIGN(1)*ELL1(mu)
!   ELL(2,mu) = QSIGN(2)*ELL2(mu)
!   ELL(3,mu) = QSIGN(3)*ELL3(mu)
!
! The paper does not, unfortunately, take note of these signs. The momentum
! flow directions shown in the paper are those of {ELL1(mu),ELL2(mu),ELL3(mu)}.
! The signs arise because the momentum flow directions for the propagator
! momenta K(P,mu) have independent definitions.  We use {ELL1,P1,P2} in this 
! subroutine directly to generate the K(P,mu).
!
! First, we need to generate a three parton final state.
! Abort if we get a not OK signal.
!
call choose3(p1,p2,p3,ok)
IF(.NOT.ok) THEN
  DO p = 1,nprops
  DO mu = 0,3
    k(p,mu) = 0.0d0
  END DO
  END DO
  badpoint = .true.
  RETURN
END IF
!
! Then we generate the loop momentum, ell1.
! Abort if we get a not OK signal.
!
IF (maptype.EQ.'t2to3d') THEN
  call choose2to3d(p1,p2,ell1,ok)
ELSE IF (maptype.EQ.'t2to3e') THEN
  call choose2to3e(p1,p2,ell1,ok)
ELSE IF (maptype.EQ.'t2to2t') THEN
  call choose2to2t(p1,p2,ell1,ok)
ELSE IF (maptype.EQ.'t2to2s') THEN
  call choose2to2s(p1,p2,ell1,ok)
ELSE IF (maptype.EQ.'t2to1a') THEN
  call choose2to1a(p1,p2,ell1,ok)
ELSE IF (maptype.EQ.'t2to1b') THEN
  call choose2to1b(p1,p2,ell1,ok)
ELSE 
  write(nout,*)'Bad maptype in newpoint.'
  stop
END IF
IF (.NOT.ok) THEN
  DO p = 1,nprops
  DO mu = 0,3
    k(p,mu) = 0.0d0
  END DO
  END DO
  badpoint = .true.
  RETURN
END IF
!
! Now we have ELL1(mu), P1(mu), and P2(mu) and we need to translate to 
! the propagator momenta K(P,MU).
!
DO p = 1,nprops
  ksq = 0.0d0
  DO mu = 1,3
    temp =  a(p,1)*qsign(1)*ell1(mu)  &
          + a(p,2)*qsign(2)*p1(mu)  &
          + a(p,3)*qsign(3)*p2(mu)
    k(p,mu) = temp
    ksq = ksq + temp**2
END DO
  absk(p) = sqrt(ksq)
  k(p,0) = 0.0d0
END DO
DO mu = 0,3
  k(0,mu) = 0.0d0
END DO
absk(0) = 0.0d0
!
! Close IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ...
!
ELSE
  write(nout,*)'Order should have been 1 or 2 in newpoint.'
  stop
END IF
!
RETURN
END subroutine newpoint
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine checkpoint(k,absk,prop,order,badness)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1)
integer :: prop(2*size,3)
integer :: order
! Out:
real(kind=dbl) :: badness
!
! Calculates the BADNESS of a point chosen by NEWPOINT. If there
! are very collinear particles meeting at a vertex or of there is a
! very soft particle, then the badness is big. Specifically, for
! each vertex V we order the momenta entering the vertex Kmin, Kmid
! Kmax in order of |K|. Then
!
!   Kmin (Kmin + Kmid - Kmax )/Kmax^2
!
! is the 1/badness^2 for that vertex. The badness for the point is the 
! largest of the badness values of all the vertices.
! 
! Revised 13 may 1998
!
integer :: nverts
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
!
real(kind=dbl) :: smallnessv,smallness
integer :: v
real(kind=dbl) :: kmin,kmid,kmax,k1,k2,k3
!
IF (order.EQ.1) THEN
  nverts = nverts1
ELSE IF (order.EQ.2) THEN
  nverts = nverts2
ELSE
  write(nout,*)'Order must be 1 or 2.',order
END IF
!
smallness = 1.0d0
DO v = 3,nverts
 k1 = absk(prop(v,1))
 k2 = absk(prop(v,2))
 k3 = absk(prop(v,3))
 IF (k1.LT.k2) THEN
   kmin = k1
   kmax = k2
 ELSE  
   kmin = k2
   kmax = k1
 END IF
 IF (k3.LT.kmin) THEN
   kmid = kmin
   kmin = k3
 ELSE IF (k3.GT.kmax) THEN
   kmid = kmax
   kmax = k3
 ELSE
   kmid = k3
 END IF
 smallnessv = kmin * (kmin + kmid - kmax) /kmax**2
 IF( smallnessv .LT. smallness ) THEN
   smallness = smallnessv
 END IF
 END DO
 IF (smallness.LT.1.0d-30) THEN
   badness = 1.0d15
 ELSE
   badness = sqrt(1.0d0/smallness)
 END IF
 RETURN
 END subroutine checkpoint
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine axes(ea,eb,ec)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: ea(3)
! Out:
real(kind=dbl) :: eb(3),ec(3)
!
! Given a unit vector E_a(mu), generates unit vectors E_b(mu) and
! E_c(mu) such that E_a*E_b = E_b*E_c = E_c*E_a = 0.
!
! The vector E_b will lie in the plane formed by the z-axis and
! E_a unless E_a itself is nearly aligned along the z-axis, in which
! case E_b will lie in the plane formed by the x-axis and E_a.
!
! 18 April 1996
!
!
real(kind=dbl) :: costhetasq,sinthetainv
!
! For check
!
integer :: mu
real(kind=dbl) :: dotaa,dotbb,dotcc,dotab,dotac,dotbc
!
costhetasq = ea(3)**2
IF(costhetasq.LT.0.9d0) THEN
  sinthetainv = 1.0d0/sqrt(1.0d0 - costhetasq)
  ec(1) = - ea(2)*sinthetainv
  ec(2) =   ea(1)*sinthetainv
  ec(3) =   0.0d0
ELSE
  costhetasq = ea(1)**2
  sinthetainv = 1.0d0/sqrt(1.0d0 - costhetasq)
  ec(1) =   0.0d0
  ec(2) = - ea(3)*sinthetainv
  ec(3) =   ea(2)*sinthetainv
END IF
eb(1) = ec(2)*ea(3) - ec(3)*ea(2)
eb(2) = ec(3)*ea(1) - ec(1)*ea(3)
eb(3) = ec(1)*ea(2) - ec(2)*ea(1) 
!     
! Check:
!
dotaa = 0.0d0
dotbb = 0.0d0
dotcc = 0.0d0
dotab = 0.0d0
dotac = 0.0d0
dotbc = 0.0d0
DO mu = 1,3
  dotaa = dotaa + ea(mu)*ea(mu)
  dotbb = dotbb + eb(mu)*eb(mu)
  dotcc = dotcc + ec(mu)*ec(mu)
  dotab = dotab + ea(mu)*eb(mu)
  dotac = dotac + ea(mu)*ec(mu)
  dotbc = dotbc + eb(mu)*ec(mu)
END DO
IF (abs(dotaa - 1.0d0).GT.1.0d20) THEN
  write(nout,*)'dotaa messed up in axes.'
  stop
ELSE IF (abs(dotbb - 1.0d0).GT.1.0d20) THEN
  write(nout,*)'dotbb messed up in axes.'
  stop
ELSE IF (abs(dotcc - 1.0d0).GT.1.0d20) THEN
  write(nout,*)'dotcc messed up in axes.'
  stop
ELSE IF (abs(dotab).GT.1.0d20) THEN
  write(nout,*)'dotab messed up in axes.'
  stop
ELSE IF (abs(dotac).GT.1.0d20) THEN
  write(nout,*)'dotac messed up in axes.'
  stop
ELSE IF (abs(dotbc).GT.1.0d20) THEN
  write(nout,*)'dotbc messed up in axes.'
  stop
END IF
!
RETURN
END subroutine axes
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!                     Subroutine to calculate integrand
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine calculate(graph,kin,abskin, &
               qs,qsigns,maptypes,nmaps,value,maxpart,valuechk)
!
use beowulf_helpers
implicit none
! In:
type graphstructure
  integer                          :: graphnumber
  integer                          :: order
  integer, dimension(0:3*size-1,2) :: vrtx
  integer, dimension(2*size,3)     :: prop
end type graphstructure
type(graphstructure) :: graph
real(kind=dbl) :: kin(0:3*size-1,0:3),abskin(0:3*size-1)
integer :: qs(maxmaps,0:size),qsigns(maxmaps,0:size)
character(len=6) :: maptypes(maxmaps)
integer :: nmaps
! Out:
complex(kind=dbl) :: value,valuechk
real(kind=dbl) :: maxpart
!
! Calculates the value of the graph specified by VRTX at the point K,
! returning result in VALUE, which includes the division by the density
! of points and the jacobian for deforming the contour. Also reports
! MAXPART, the biggest absolute value of the contributions to Re(VALUE).
! This helps us to keep track of cancellations and thus to abort the 
! calculation if too much cancellation among terms will be required.
!
! Latest revision: 11 May 1996
!                  24 October 1996 (call to CHECKDEFORM)
!                  15 November 1996 (remove finite 'i epsilon')
!                  18 November 1996 (add CHECKVALUE)
!                  22 November 1996 Bug fixed.
!                  27 November 1996 (complex checkvalue)
!                  29 November 1996 (branchcut check; better checkvalue)
!                  27 February 1997 renormalization; reporting
!                  25 July     1997 renormalization; self-energy graphs
!                  17 September 1997 more renormalization & self-energy
!                  21 September 1997 finish DEFORM
!                  24 September 1997 fix bugs
!                  19 October 1997 fix cutsign bug
!                  22 October 1997 fix renormalization sign bug
!                   6 November 1997 improvements for deformation
!                  28 November 1997 more work on deformation
!                   2 December 1997 more precision in "report" numbers
!                   4 January  1998 revisions for self-energy graphs
!                  11 January 1998 renormalizaion for self-energy graphs
!                  27 February 1998 use Hrothgar for output
!                   5 March 1998 integrate Hrothgar
!                  14 March 1998 restore checks of deformation direction
!                  24 July 1998 use countfactor(graphnumber)
!                   4 August 1998 better CHECKDEFORM
!                   5 August 1998 change to groupsize(graphnumber)
!                  22 August 1998 add color factors
!                  22 December 1998 precalculate cut structure in RENO
!                  26 April 1999 omit REFLECT except as option
!                  22 December 2000 omit REFLECT entirely
!                  22 December 2000 change method of choosing points
!                  19 December 2001 call FEYNMANF, new organization.
!                  31 December 2001 add Coulomb gauge.
!                  11 February 2002 Add Born calculation.
!                  14 June 2002 Revisions for f95
!                  30 June 2002 Calculate separately for each flavor set.
!                  30 October 2002 Add showers.
!                  16 May 2003 Showers with soft gluon radiation.
!----------------------------------
!
integer :: nloops,nprops,cutmax
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
real(kind=dbl) :: muoverrts
common /renormalize/ muoverrts
logical :: report,details
common /calculook/ report,details
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
character(len=7) :: gauge
common /gaugechoice/ gauge
logical :: dosoft
common /softswitch/ dosoft
real(kind=dbl) :: badnesslimit,cancellimit,thrustcut
common /limits/ badnesslimit,cancellimit,thrustcut
! Information on the current cut.
type cutstructure
  integer                        :: cutnumber ! identifies the cut
  integer                        :: ncut      ! number of cut propagators
  integer, dimension(size+1)     :: cutindex  ! index of cut propagator
  integer, dimension(size+1)     :: cutsign   ! direction of cut propagator
  logical                        :: leftloop  ! there is a loop to left
  logical                        :: rightloop ! there is a loop to right
  integer                        :: ninloop   ! number of props in loop
  integer, dimension(size+1)     :: loopindex ! indices around loop
  integer, dimension(size+1)     :: loopsign  ! propagator directions
end type cutstructure
type (cutstructure) :: cut
logical :: cutfound
logical :: keepcut
! Information on the current flavor set.
type flavorstructure
  integer                               :: setnumber 
  character(len=5), dimension(3*size-1) :: flavor    ! flavor of propagator P
end type flavorstructure
type (flavorstructure) flavorset
logical :: flavorsetfound
character(len=5) :: theflavor
! Showers variables
type parton
  character(len=5) :: flavor   ! quark, qbar, gluon
  integer :: self              ! index of this parton
  integer :: parent            ! index of parton's parent
  integer :: ancestor          ! starting parton
  integer :: child1            ! index of parton's first daughter
  integer :: child2            ! index of parton's second daughter
  logical :: childless         ! no children (yet)
  logical :: done              ! .true. means don't split this parton
  real(kind=dbl), dimension(3) :: momentum
  real(kind=dbl) :: kappasq
end type parton
!
! Below, theshower%multfactor is the factor that will multiply the
! Born graph. From subroutine softradiate, we start with 
! fijk/(4 Pi * softintegral)/density when we add the soft 
! gluon to the shower; then we further divide by the densities 
! of points {qbarsq,x,phi} for each splitting in the first 
! level splittings of the hard partons from a Born graph.
! The Sudakov factor is not included, nor are 1/qbarsq/(2 pi).
!
type showerlist
  integer :: length            ! length of the shower list
  real(kind=dbl) :: rts0       ! sqrt(s) of the starting graph
  real(kind=dbl) :: onemthrust ! 1 - thrust of the starting graph
  real(kind=dbl) :: msoftsq    ! the soft scale
  real(kind=dbl) :: multfactor ! factor to multiply |matrix element|^2
  integer :: pii,pjj           ! partons emitting and absorbing soft gluon
  type(parton), dimension(maxparticles) :: ptn
end type showerlist
type(showerlist) :: theshower
!
real(kind=dbl) :: onemthrust,msoftsq
real(kind=dbl), parameter :: msoftfactor = 0.3333333333333333333d0
real(kind=dbl), parameter :: onemthrustcrit = 0.05d0
!
! What the program should do
character(len=6) :: mode
common /programmode/ mode
! Physics data
real(kind=dbl) :: alphasofmz,mz,externalrts
common /physicsdata/ alphasofmz,mz,externalrts
! Labels:
integer :: qe(0:size)
! Momenta:
real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1)
real(kind=dbl) :: koff(0:3*size-1,0:3)
real(kind=dbl) :: kinloop(size+1,0:3)
real(kind=dbl) :: kcut(size+1,0:3)
complex(kind=dbl) :: newkinloop(0:3)
complex(kind=dbl) :: kc(0:3*size-1,0:3)
complex(kind=dbl) :: ellsq,ell
real(kind=dbl) :: e(0:size),rts,rts0
! Squared momenta for factors F_j for showers
real(kind=dbl) :: k1sq,k2sq,k3sq,k4sq
! Factors F_j for graph 9.
real(kind=dbl) :: graph9factor
! Number of final state particles and their momenta
integer :: nparticles
real(kind=dbl) :: kf(maxparticles,0:3)
! Renormalization:
real(kind=dbl) :: mumsbar
! Matrices:
integer :: ae(0:3*size-1,0:size)
! FINDA variable:
logical :: qok
! DENSITY variables:
real(kind=dbl) :: jacnewpoint,density
! Loopcut variables:
logical :: calcmore
integer :: jcut,index,loopcutsign
! DEFORM variables:
complex(kind=dbl) :: jacdeform
! Functions:
real(kind=dbl) :: cals0,smear
real(kind=dbl) :: xxreal,xximag
complex(kind=dbl) :: complexsqrt
real(kind=dbl) :: alpi
! Index variables:
integer :: p,mu,nu,i,j,n
! Propagator properties
logical :: cutQ(3*size-1)
! Flag for feynman function
character(len=16) :: flag
! Results variables:
real(kind=dbl) :: calsval,thrust
real(kind=dbl) :: weight,maxweight
complex(kind=dbl) :: feynman,feynmanf,feynman0,feynman0f,feynmanval
complex(kind=dbl) :: softsubtraction
real(kind=dbl) :: prefactor,prefactor0
complex(kind=dbl) :: integrand
complex(kind=dbl) :: check
! Useful constants:
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
real(kind=dbl) :: temp
! For calculating matrix element square for shower from Born graph.
integer :: nfound
real(kind=dbl), dimension(3) :: qvec,kplusvec,kminusvec
real(kind=dbl), dimension(0:3) :: vquark,vqbar
real(kind=dbl), dimension(0:3,0:3) :: tglue
integer :: n0,n1,n2
character(len=5) :: f1,f2
character(len=9) :: kind2pt
complex(kind=dbl) :: feynmanSH0
! Reno size and counting variables:
integer :: groupsize(maxgraphs,maxmaps)
integer :: groupsizegraph(maxgraphs)
integer :: groupsizetotal
common /montecarlo/groupsize,groupsizegraph,groupsizetotal
!
type softinformation
  character(len=5) :: flavor0   ! quark, qbar, gluon
  character(len=5) :: flavor1   ! quark, qbar, gluon
  character(len=5) :: flavor2   ! quark, qbar, gluon
  real(kind=dbl) :: cos1
  real(kind=dbl) :: cos2
  real(kind=dbl) :: msoftsq
end type softinformation
type(softinformation), dimension(3) :: softinfos  ! For makeshowerI
type(softinformation) :: softinfo                 ! For shower...prop
real(kind=dbl) :: cosine(3,3)
integer :: j1,j2
!
!-------------------------------------------------------------------------------
!
IF (graph%order.EQ.1) THEN
  nloops = nloops1
  nprops = nprops1
  cutmax = cutmax1
ELSE IF (graph%order.EQ.2) THEN
  nloops = nloops2
  nprops = nprops2
  cutmax = cutmax2
ELSE
  write(nout,*)'Order must be 1 or 2.',graph%order
END IF
!
! We do not want to change the value of KIN and ABSKIN. (Actually,
! all that we change in the current version in k(p,0), so this step
! is not really necessary).
!
DO p = 1,nprops
  absk(p) = abskin(p)
  DO mu = 0,3
    k(p,mu) = kin(p,mu)
  END DO
END DO
!
! Initialize contribution to integral from this point. Also initialize
! BIGGEST, which will be the biggest absolute value of the contributions
! to VALUE. This helps us to keep track of cancellations and thus to
! abort the calculation if too much cancellation among terms will be
! required.
!
maxpart = 0.0d0
value = (0.0d0,0.0d0)
valuechk = (0.0d0,0.0d0)
!
! Calculate jacobian.
!
jacnewpoint =  &
  1.0d0/density(graph%graphnumber,k,qs,qsigns,maptypes,nmaps,graph%order)
!
! Loop over flavorsets.
!
DO
IF (gauge.EQ.'feynman') THEN
  ! In the case of Feynman gauge, we exit at the end of the first pass.
  flavorset%setnumber = 1
  flavorset%flavor = &
   (/'none ','none ','none ','none ','none ','none ','none ','none '/)
ELSE IF (gauge.EQ.'coulomb') THEN
  call getnewflavorset(graph%graphnumber,flavorset,flavorsetfound)
  IF (.not.flavorsetfound) EXIT
ELSE
    write(nout,*)'That gauge does not exist.'
    stop
END IF
!
! Loop over cuts.
!
DO
IF (mode.NE.'shower') THEN
  call getnewcut(graph%graphnumber,cut,cutfound)
ELSE
!
! In the case of 'shower' mode, for certain cuts of certain graphs
! we keep only the wide angle splitting part, while other cuts are
! omitted entirely. Subroutine checknewcut finds out for us, and
! also calculates the factor F_1 or F_2 needed for graph 9.
!
  DO
    call getnewcut(graph%graphnumber,cut,cutfound)
    IF (.not.cutfound) EXIT
    call checknewcut(graph%graphnumber,cut,k,absk,keepcut,graph9factor)
    IF (keepcut) EXIT
  END DO
!
END IF  ! (mode.NE.'shower')
IF (.not.cutfound) EXIT
!....
IF (report) THEN
  IF (graph%order.EQ.2) THEN
     write(nout,301)cut%ncut,cut%cutindex(1),cut%cutindex(2), &
                    cut%cutindex(3),cut%cutindex(4)
  ELSE
     write(nout,301)cut%ncut,cut%cutindex(1),cut%cutindex(2), &
                    cut%cutindex(3)
  END IF
301     format('ncut =',i2,' cutindex =',4i2)
END IF
!''''
!
! Calculate final state momenta.
! Then we can also calculate CALSVAL and the PREFACTOR.
!
DO i = 1,cut%ncut
  kcut(i,0) = 0.0d0  !We calculate the energy later.
  DO mu = 1,3
    kcut(i,mu) = cut%cutsign(i) * k(cut%cutindex(i),mu)
  END DO
END DO
!
! Set final state energies kcut(i,0) to their on-shell values and define
! final state momenta kf(i,mu) to be kcut(i,mu). Define rts to be the sum
! of these final state energies. Also, nparticles is the number of these
! final state particles. We define rts0 to be this "before showers" version
! of rts. If we later generate showers, we will overide these values.
! Look for "! Here we redefine rts, kcut(i,0), kf(i,mu), and nparticles."
! 
DO i = 1,cut%ncut
  kcut(i,0) = absk(cut%cutindex(i))
END DO
nparticles = cut%ncut
rts = 0.0d0
DO i = 1,nparticles
  DO mu = 0,3
    kf(i,mu) = kcut(i,mu)
  END DO
  rts = rts + kf(i,0)
END DO
rts0 = rts
mumsbar = muoverrts * rts0       ! The renormalization scale.
!
IF (mode.EQ.'shower') THEN
!
! The mode is 'shower'.
! Starting values of the shower list. Here onemthrust 
! controls the width of showers generated by makeshowerII from
! graph%order.EQ.2 graphs and also the limit on 'soft' gluons in makeshowerI.
! Also, we need the soft scale and (1 - thrust). Here is where msoftsq 
! is set, with a standard parameter msoftfactor set above.
!
  onemthrust = (1.0d0 - thrust(kf,nparticles))
  IF (report) then
    write(nout,*)"1 - thrust before showering is ",onemthrust
  END IF
  msoftsq = (msoftfactor*rts0*onemthrust)**2
!
  theshower%length = cut%ncut
  theshower%rts0 = rts0
  theshower%onemthrust = onemthrust
  theshower%msoftsq = msoftsq
  theshower%multfactor = 1.0d0  ! This will be changed.
  theshower%pii = 0             ! This will be changed.
  theshower%pjj = 0             ! This will be changed.
  DO n = 1,theshower%length
    theflavor = flavorset%flavor(cut%cutindex(n))
    IF (cut%cutsign(n).EQ.-1) THEN
      IF (theflavor.EQ.'quark') THEN
        theflavor = 'qbar '
      ELSE IF (theflavor.EQ.'qbar ') THEN
        theflavor = 'quark'
      END IF
    END IF
    theshower%ptn(n)%flavor = theflavor
    theshower%ptn(n)%self = n
    theshower%ptn(n)%parent = 0
    theshower%ptn(n)%ancestor = n
    theshower%ptn(n)%child1 = -1
    theshower%ptn(n)%child2 = -1
    theshower%ptn(n)%childless = .true.
    theshower%ptn(n)%done = .false.
    DO mu = 1,3
      theshower%ptn(n)%momentum(mu) = kcut(n,mu)
    END DO
    IF (onemthrust.LT.onemthrustcrit) THEN
      ! default is onemthrustcrit = 0.05
      theshower%ptn(n)%kappasq = kcut(n,0)**2 * onemthrust**2/onemthrustcrit
    ELSE
      theshower%ptn(n)%kappasq = kcut(n,0)**2 * onemthrust
    ENDIF
  END DO
!
  IF (graph%order.EQ.1) THEN
!
! We will create showering.
!
! For each of the final hard state partons i = 1,2,3, we need its flavor,
! which we call softinfos(i)%flavor0. We also need the flavors of 
! the other two, which we call softinfos(i)%flavor1 and softinfos(i)%flavor2
! and we need the cosine of the angle from the direction of parton i to the 
! directions of these two other partons, which we call softinfos(i)%cos1
! and softinfo(i)s%cos2. This information will be used for the soft gluon 
! subtractions. We use the starting values of the final state momenta for
! this, with exact three body kinematics.
!
    DO i = 1,3
    DO j = i+1,3
      cosine(i,j) = 0.0d0
      DO mu = 1,3
       cosine(i,j) = cosine(i,j) + kcut(i,mu) * kcut(j,mu)
      END DO
      cosine(i,j) = cosine(i,j)/kcut(i,0)/kcut(j,0)
      cosine(j,i) = cosine(i,j)
    END DO
    END DO
!
    DO i = 1,3
      j1 = mod(i,3) + 1      ! 1 -> 2, 2 -> 3, 3 -> 1
      j2 = mod(i+1,3) + 1    ! 1 -> 3, 2 -> 1, 3 -> 2
      softinfos(i)%cos1 = cosine(i,j1)
      softinfos(i)%cos2 = cosine(i,j2)
      softinfos(i)%flavor0 = theshower%ptn(i)%flavor
      softinfos(i)%flavor1 = theshower%ptn(j1)%flavor
      softinfos(i)%flavor2 = theshower%ptn(j2)%flavor
      softinfos(i)%msoftsq = theshower%msoftsq
    END DO
!
    call softradiate(theshower)           ! Radiate a soft gluon
    ! Note that subroutine softradiate has shifted the parton momenta
    ! so we modify kcut accordingly.
    DO i = 1,4
      DO mu = 1,3
        kcut(i,mu) = theshower%ptn(i)%momentum(mu)
      END DO
    END DO
    call makeshowerI(theshower,softinfos) ! First splittings.
    call makeshowerII(theshower)     ! Shower with small angle approx.
  ELSE
    ! Order is 2. We make a shower from the final state particles, but
    ! only if we have enabled soft gluon subtractions, or else cancellations
    ! will fail.
    IF (dosoft) THEN
      call makeshowerII(theshower)   ! Shower with small angle approx.
    END IF
  END IF
!
! Now we have a complete shower. We need to find the final state partons.
! kf(i,mu) is the four-momentum of the ith final state parton. We
! compute rts as the sum of the energies of all the final state partons.
! Also, we compute the energy, kcut(j,0) of the jth original cut 
! parton as sum of the energies of its descendants in the final state.
! Here we redefine rts, kcut(i,0), kf(i,mu), and nparticles.
!
  rts = 0.0d0
  DO i = 1,cut%ncut
    kcut(i,0) = 0.0d0
  END DO
  IF (graph%order.EQ.1) THEN
    kcut(4,0) = 0.0d0    ! initialization also for the extra soft gluon.
  END IF
  i = 0
  DO n = 1,theshower%length
  IF (theshower%ptn(n)%childless) THEN
    i = i+1
    temp = 0.0d0
    DO mu = 1,3
      kf(i,mu) = theshower%ptn(n)%momentum(mu)
      temp = temp +  kf(i,mu)**2
    END DO
    temp = sqrt(temp)
    kf(i,0) = temp
    rts = rts + temp
    j = theshower%ptn(n)%ancestor
    kcut(j,0) = kcut(j,0) + temp
  END IF
  END DO
  nparticles = i
!
  IF (report) then
    write(nout,*)"1 - thrust after showering is ", &
                 (1.0d0 - thrust(kf,nparticles))
  END IF
!
! We also calculate momenta koff(p,mu), which is like k(p,mu) except that
! the final state particles are given energies equal to the total energy
! of the shower that originates from that particle and the momentum of
! the soft gluon shower is appropriately routed. This is only for the 
! Born graphs.
!
  IF (graph%order.EQ.1) THEN
    call findkoff(graph%graphnumber,cut,kcut,theshower%pii,theshower%pjj,koff)
    DO mu = 1,3
      IF (abs(koff(0,mu)).GT.1.0d-12) THEN
        write(nout,*)'Something is rotten in findkoff.', &
                   graph%graphnumber,cut%cutindex,theshower%pii,theshower%pjj
        stop
      END IF
    END DO
    IF ( abs(rts - koff(0,0)).GT.1.0d-8 ) THEN
      write(nout,*)'Oops, the calculation of rts did not work.',rts,koff(0,0)
      stop
    END IF
  END IF ! (graph%order.EQ.1)
!
END IF  ! (mode.NE.'shower') ... ELSE ... the mode is 'shower'
!
calsval = cals0(nparticles,kf)
prefactor = 1.0d0 / (nc * rts**2 * (2.0d0 * pi)**nloops )
!
IF (mode.EQ.'born  ') THEN
  prefactor = prefactor * alpi(muoverrts*externalrts)
ELSE IF (mode.EQ.'nlo   ') THEN
  prefactor = prefactor * alpi(muoverrts*externalrts)**graph%order
ELSE IF (mode.EQ.'hocoef') THEN
  continue
ELSE IF (mode.EQ.'shower') THEN
  prefactor = prefactor * alpi(muoverrts*externalrts)**graph%order
  IF (graph%graphnumber.EQ.9) THEN
    prefactor = prefactor * graph9factor
  END IF
  IF (graph%order.EQ.1) THEN
    prefactor = prefactor*theshower%multfactor
    prefactor0 = prefactor ! Use this to modify prefactor for graph 11.
  END IF
ELSE
 write(nout,*)'calculate not programmed for this mode. ',mode
 stop
END IF
!
! Calculate momenta around loop (if any). In case NINLOOP = 0, this
! DO loop is skipped.
!
DO j = 1,cut%ninloop
  DO mu = 1,3
   kinloop(j,mu) = cut%loopsign(j) * k(cut%loopindex(j),mu)
  END DO
END DO
!
! Please note that at this point the energy in the loop, KINLOOP(J,0),
! is not calculated. We have to wait until we have a loop cut to
! do this.
!
! Now KINLOOP(J,MU) gets an imaginary part for MU = 1,2,3.
! DEFORM calculates NEWKINLOOP and the associated jacobian, JACDEFORM.
! In case NINLOOP = 0, this subroutine just returns NEWKINLOOP(MU) = 0
! and JACDEFORM = 1.
!
call deform(graph%vrtx,cut%loopindex,rts,cut%leftloop,cut%rightloop, &
            cut%ninloop,kinloop,newkinloop,jacdeform)
!
! If there is a loop, we need to go around the loop and generate
! a "loopcut."  There are four cases.
!
! 1) NINLOOP = 0, with NCUT = CUTMAX.  
! Then we are ready to proceed, and we should calculate only once 
! before going back to NEWCUT. Therefore we set CALCMORE to .FALSE. 
! so that we do not enter this code again.
!
! In the other three cases, there is a loop with NINLOOP = 2, 3, or 4.
! We generate a loopcut specified by the index JCUT = 1, 2, ... around
! the loop: CUTINDEX(CUTMAX) = LOOPINDEX(JCUT).
!
! 2) NINLOOP = 2, with NCUT = CUTMAX - 1.
! Then the loop is a self-energy subgraph and, with our dispersive
! treatment of these graphs, there is one term. We need to calculate
! energies, so we put JCUT = 1, but this is just a convention: the
! choice JCUT = 1 or 2 affects only the energy in the loop and the
! two point function depends only on the 3-momentum in the loop.
!
! 3) NINLOOP = 3, with NCUT = CUTMAX - 1.
! We will go around the loop twice with JCUT = 1,2,3 and then 
! with JCUT = 1,2,3 again. We set CUTSIGN(CUTMAX) =  LOOPSIGN(JCUT) 
! the first time and CUTSIGN(CUTMAX) =  - LOOPSIGN(JCUT) the second time.
! This corresponds to doing the energy integral with the contour closed in 
! the upper half plane and also in the lower half plane. We *average* over 
! the two sign choices, so we will need to multiply FEYNMAN by 1/2 for
! NINLOOP = 3. When we are done with this we set CALCMORE to .FALSE. .
! We will also need the renormaliztion counter term. This is done at the
! end. Before the IF(calcmore)... loop is closed, we test for calcmore
! and if it is false we check whether graph%order is 2 and cut%ninloop
! is 3. If so, we calculate and add the counter term. There is a flag
! for this purpose: if flag = '     no flag set', then the functions
! fenyman and feynmanf calculate the normal terms, but if 
! flag = 'renormalize 3 pt', these functions calculate the counter terms.
!
! 3) NINLOOP = 4, with NCUT = CUTMAX - 1.
! We will go around the loop twice with JCUT = 1,2,3,4 and then with
! JCUT = 1,2,3,4 again. We set CUTSIGN(CUTMAX) =  LOOPSIGN(JCUT) the first 
! time and CUTSIGN(CUTMAX) =  - LOOPSIGN(JCUT) the second time. This 
! corresponds to doing the energy integral with the contour closed in the 
! upper half plane and also in the lower half plane. We *average* over the
! two sign choices, so we will need to multiply FEYNMAN by 1/2 for
! NINLOOP = 4. When we are done with this we set CALCMORE to .FALSE. .
!
! We initialize the weight, then add to it the contributions from
! each pass through this loop. In the last pass, we also add the
! renormalization counter term to the weight, if appropriate.
!
weight = 0.0d0
maxweight = 0.0d0
!
index = 1  ! to count where we are
calcmore = .true.
!
DO WHILE (calcmore)
!
IF (cut%ninloop.EQ.0) THEN
   calcmore = .false.
ELSE IF (cut%ninloop.EQ.2) THEN
   jcut = 1
   cut%cutindex(cutmax) = cut%loopindex(jcut)
   cut%cutsign(cutmax) = cut%loopsign(jcut)
   calcmore = .false.
ELSE IF (cut%ninloop.EQ.3) THEN
   IF (index.LE.3) THEN
     jcut = index
     cut%cutindex(cutmax) = cut%loopindex(jcut)
     cut%cutsign(cutmax) =  cut%loopsign(jcut)
     loopcutsign = 1
   ELSE
     jcut = index - 3
     cut%cutindex(cutmax) =  cut%loopindex(jcut)
     cut%cutsign(cutmax) = - cut%loopsign(jcut)
     loopcutsign = -1
   END IF
   index = index + 1
   IF (index.GT.6) THEN
     calcmore = .false.
   END IF
ELSE IF (cut%ninloop.EQ.4) THEN
   IF (index.LE.4) THEN
     jcut = index
     cut%cutindex(cutmax) = cut%loopindex(jcut)
     cut%cutsign(cutmax) =  cut%loopsign(jcut)
     loopcutsign = 1
   ELSE
     jcut = index - 4
     cut%cutindex(cutmax) =  cut%loopindex(jcut)
     cut%cutsign(cutmax) = - cut%loopsign(jcut)
     loopcutsign = -1
   END IF
   index = index + 1
   IF (index.GT.8) THEN
     calcmore = .false.
   END IF
ELSE
   write(nout,*)'Impossible case in calculate.'
   stop
END IF
!
! Calculate matrix AE(P,I) relating propagator energies to energies of 
! cut lines. NOTE that the index I here is displaced by 1.
!
DO i = 0,nloops
  qe(i) = cut%cutindex(i+1)
END DO
call finda(graph%vrtx,qe,nloops,graph%order,ae,qok)
IF (.NOT.qok) THEN
   write(nout,*)'ae not found.'
   write(nout,*)'Graph number',graph%graphnumber,' cut number',cut%cutnumber
   write(nout,*) qe
   stop
END IF
!
! Define logical cut variables:
! cutQ(P) = .TRUE. if propagator P crosses the final state cut
!                 OR if it crosses the loopcut.
!
DO p = 1,nprops
   cutQ(p) = .false.
END DO
DO i = 1,cutmax
   cutQ(cut%cutindex(i)) = .true.
END DO
!
! Calculate part of the propagator energies corresponding to the
! real part of the loop three-momenta. Here we calculate for with the
! energy of each final state particle from the original graph set
! equal to the absolute value of its momentum. That is, the mass of
! the shower originating from this particle (if any) is neglected.
!
! Note that i is displaced by 1 in the e(i) array in order to work with
! the matrix AE(p,i), for which i should run from 0 to cutmax - 1.
!
DO i = 1,cutmax
  e(i-1) = cut%cutsign(i) * absk(cut%cutindex(i))
END DO
!
DO p = 0,nprops
   k(p,0) = 0.0d0
   DO i = 0,nloops
     k(p,0) = k(p,0) + ae(p,i) * e(i)
   END DO
END DO
IF ( abs(rts0 - k(0,0)).GT.1.0d-8 ) THEN
   write(nout,*)'Oops, the calculation of rts0 did not work.',rts0,k(0,0)
   stop
END IF
!
! Calculate the added complex loop energy. Check that we do not
! cross the cut of Sqrt(ELLSQ) by using COMPLEXSQRT(ELLSQ).
!
IF (cut%ninloop.GT.0) THEN
  kinloop(jcut,0) =  cut%loopsign(jcut) * k(cut%loopindex(jcut),0)
  ellsq = (0.0d0,0.0d0)
  DO mu = 1,3
    ellsq = ellsq + ( kinloop(jcut,mu) + newkinloop(mu) )**2
  END DO
  ell = complexsqrt(ellsq)
  newkinloop(0) = loopcutsign*ell - kinloop(jcut,0)
ELSE
  newkinloop(0) = (0.0d0,0.0d0)
END IF
!....
IF (report) THEN
  IF( details .AND. (cut%ninloop.GT.0) ) THEN
    write(nout,340)newkinloop(0),xximag(newkinloop(1)), &
                 xximag(newkinloop(2)),xximag(newkinloop(3))
340       format('newkinloop =',2(1p g12.3),' and',3(1p g12.3))
  END IF
END IF
!''''
! Now we calculate the complex propagator momenta, kc(p,mu). These are
! based on k(p,mu) for which the energy of each final state particle 
! from the original graph is set equal to the absolute value of its 
! momentum. 
!
DO p = 0,nprops
  DO mu = 0,3
   kc(p,mu) = k(p,mu)
  END DO
END DO
!
DO j = 1,cut%ninloop
 DO mu = 0,3
   kc(cut%loopindex(j),mu) = kc(cut%loopindex(j),mu) &
       + cut%loopsign(j) * newkinloop(mu)
  END DO
END DO
!
IF (mode.EQ.'shower') THEN
!
! There are some preliminary calculations for the case of shower mode.
!
! First, we multiply by factor F_j for showers for the first Born
! graph, graphnumber 11. To compute F_j, we use momenta kcut(i,mu), 
! which represent the momenta of the final state particles 1,2,3,4
! including the showers that develop from them. The graph structure
! for graph 11 is that particles 1 and 2 form a self cut energy
! subdiagram, particle 3 is the third hard parton in the Born graph
! and particle 4 is the soft gluon. We use the momentum of particle 4
! in the calculation of F_j if it forms a self-energy subdiagram.
! Then we add it as a soft parton and subtract the same diagram
! from the splitting, so we want to treat it kinematically just
! like a splitting.
!
  IF (graph%graphnumber.EQ.11) THEN
    IF ((cut%cutindex(1).NE.5).OR.  &
        (cut%cutindex(2).NE.4).OR.  &
        (cut%cutindex(3).NE.1))  THEN
       write(nout,*)'Bad labelling in F_j calculation'
       stop
    END IF
    k1sq = 0.0d0
    k2sq = 0.0d0
    IF ( (theshower%pii.EQ.1).AND.(theshower%pjj.EQ.1) ) THEN
      DO mu = 0,3
        k1sq = k1sq + kcut(3,mu)**2 * metric(mu)
        k2sq = k2sq + (kcut(1,mu) + kcut(2,mu) + kcut(4,mu))**2 * metric(mu)
      END DO
    ELSE IF ( (theshower%pii.EQ.2).AND.(theshower%pjj.EQ.2) ) THEN
      DO mu = 0,3
        k1sq = k1sq + kcut(3,mu)**2 * metric(mu)
        k2sq = k2sq + (kcut(1,mu) + kcut(2,mu) + kcut(4,mu))**2 * metric(mu)
      END DO
    ELSE IF ( (theshower%pii.EQ.3).AND.(theshower%pjj.EQ.3) ) THEN
      DO mu = 0,3
        k1sq = k1sq + (kcut(3,mu) + kcut(4,mu))**2 * metric(mu)
        k2sq = k2sq + (kcut(1,mu) + kcut(2,mu))**2 * metric(mu)
      END DO
    ELSE
      DO mu = 0,3
        k1sq = k1sq + kcut(3,mu)**2 * metric(mu)
        k2sq = k2sq + (kcut(1,mu) + kcut(2,mu))**2 * metric(mu)
      END DO
    END IF
    prefactor = prefactor0 * k2sq**2/(k1sq**2 + k2sq**2)
  END IF
!
  IF (graph%order.EQ.1) THEN
!
! Calculate tglue, vquark, vqbar, which are needed for the first
! level of showering from a Born graph.
!
    DO n0=1,3          ! We want the three hard partons.
      qvec = theshower%ptn(n0)%momentum
      n1 = theshower%ptn(n0)%child1
      n2 = theshower%ptn(n0)%child2
      f1 = theshower%ptn(n1)%flavor
      f2 = theshower%ptn(n2)%flavor
      kplusvec = theshower%ptn(n1)%momentum
      kminusvec = theshower%ptn(n2)%momentum
      ! We need the softinfo for parton n0. We can tell by its flavor.
      nfound = 0
      DO j = 1,3
        IF (softinfos(j)%flavor0.EQ.theshower%ptn(n0)%flavor) THEN
          nfound = nfound + 1
          softinfo = softinfos(j)
        END IF
      END DO
      IF (nfound.NE.1) THEN
        write(nout,*) 'Oops, flavors messed up in the shower'
        STOP
      END IF
      IF (theshower%ptn(n0)%flavor.EQ.'gluon') THEN
        IF ((f1.EQ.'quark').AND.(f2.EQ.'qbar ')) THEN
          kind2pt = 'quarkloop'
        ELSE IF ((f1.EQ.'gluon').AND.(f2.EQ.'gluon')) THEN
          kind2pt = 'gluonloop'
        ELSE
          write(nout,*)'Oops, that flavor combination should not exist.'
          STOP
        END IF
        call showerglueprop(kind2pt,softinfo,qvec,kplusvec,kminusvec,tglue)
      ELSE IF (theshower%ptn(n0)%flavor.EQ.'quark') THEN
        IF (.NOT.(f1.EQ.'gluon').AND.(f2.EQ.'quark')) THEN
          write(nout,*)'Oops, that flavor combination should not exist.'
          STOP
        END IF
        call showerquarkprop(softinfo,qvec,kplusvec,kminusvec,vquark)
      ELSE IF (theshower%ptn(n0)%flavor.EQ.'qbar ') THEN
        IF (.NOT.(f1.EQ.'gluon').AND.(f2.EQ.'qbar ')) THEN
          write(nout,*)'Oops, that flavor combination should not exist.'
          STOP
        END IF
        call showerquarkprop(softinfo,qvec,kplusvec,kminusvec,vqbar)
        DO mu = 0,3
          vqbar(mu) = - vqbar(mu)
        END DO
      ELSE
        write(nout,*)'The flavor must be gluon, quark, or qbar.'
        STOP
      END IF
    END DO   ! Close DO n0=1,3
!
  END IF  ! (graph%order.EQ.1)
END IF  ! (mode.EQ.'shower')
!
! Calculate graph and add to contribution for this point.
!
IF (graph%order.EQ.2) THEN
  flag = '     no flag set'    ! This is not a counter-term.
  IF (gauge.EQ.'feynman') THEN
    feynmanval = feynmanf(graph%graphnumber,kc,cutQ,mumsbar,flag)
  ELSE IF (gauge.EQ.'coulomb') THEN
    feynmanval = &
       feynman(graph%graphnumber,flavorset%setnumber,kc,cutQ,mumsbar,flag)
  ELSE
    write(nout,*)'That gauge does not exist.'
    stop
  END IF
ELSE IF (graph%order.EQ.1) THEN
!
! There are a lot of alternatives in the case of a Born graph.
!
  IF (gauge.EQ.'feynman') THEN
!
!   This gets the Feynman gauge matrix element squared.
!
    feynmanval = feynman0f(graph%graphnumber,k,cutQ)
!
  ELSE IF (gauge.EQ.'coulomb') THEN
!
    IF (mode.EQ.'shower') THEN
!
!     We have previously calculated vquark,vqbar, and tglue. 
!     Here we use koff(p,mu) which is like k(p,mu) except that
!     the final state particles are given energies equal to the total
!     energy of the shower that originates from that particle.
!     This gets the appropriate matrix element squared with a one
!     level shower.
!
      feynmanval = feynmanSH0(graph%graphnumber,flavorset%setnumber, &
                              koff,cutQ,vquark,vqbar,tglue)
    ELSE
!
!   We have Coulomb gauge but not mode .EQ. 'shower'.
!   This gets the Coulomb gauge matrix element squared.
!
    feynmanval = &
       feynman0(graph%graphnumber,flavorset%setnumber,k,cutQ)
!
! Close  IF (mode.EQ.'shower') THEN ... ELSE ...
!
    END IF
!
  ELSE 
    write(nout,*)'That gauge does not exist.'
    stop
!
! Close 
! IF (gauge.EQ.'feynman') THEN ...
! ELSE IF (gauge.EQ.'coulomb') THEN ...
! ELSE ...
  END IF
ELSE
  write(nout,*)'Order should have been 1 or 2.'
  stop
!
! Close 
!IF (graph%order.EQ.2) THEN ...
!ELSE IF (graph%order.EQ.1) THEN ...
!ELSE
END IF
!
integrand = prefactor * jacnewpoint * jacdeform * feynmanval * smear(rts)
!
! If we have a 3 or 4 point virtual loop, then we are averaging over
! closing the energy integral contour in the upper and lower
! half planes and we supply a 1/2.
!
IF (cut%ninloop.GT.2) THEN
  integrand = 0.5d0*integrand
END IF
!
maxweight = max(maxweight,abs(xxreal(integrand)))
weight = weight + xxreal(integrand)
!
integrand = integrand * calsval
maxpart = max(maxpart,abs(xxreal(integrand)))
value = value + integrand
!....
IF (report) THEN
  IF (details) THEN
    write(nout,370)
370       format('prefactor * jacnewpoint * (jacdeform-r jacdeform-i) * ', &
           ' (feynman-r feynman-i) * calsval * smear(rts)')
    write(nout,371)prefactor,jacnewpoint,jacdeform,  &
                 feynmanval,calsval,smear(rts)
371       format(9(1p g12.3))
  END IF
  IF (cut%ninloop.GT.0) THEN
      write(nout,372)cut%loopindex(jcut),integrand*groupsizetotal
372   format(i3,'  contribution:',2(1p g18.10))
  ELSE
    write(nout,373)integrand*groupsizetotal
373       format('     contribution:',2(1p g18.10))        
  END IF
  IF (details) THEN
    write(nout,*)' '
  END IF
END IF
!''''
!
! Compute a known integral to see if we have it right.
! Subroutine CHECKCALC calculates CHECK.
!
IF (flavorset%setnumber.EQ.1) THEN
  IF (flag.NE.'renormalize 3 pt') THEN
    call  &
    checkcalc(graph%graphnumber,cut%cutindex,kc,jacnewpoint,jacdeform,check)
    IF (cut%ninloop.GT.2) THEN
      check = 0.5d0*check
    END IF
  valuechk = valuechk + check
  END IF
END IF
!
!
IF(.NOT.calcmore) THEN
!
! We are almost done with this cut. However, there may be a renormalization
! counter term and/or a soft subtraction needed.
!
!....
  IF (report) THEN
    write(nout,341)weight*calsval*groupsizetotal
341 format(' cut total so far:',1p g18.10)
    IF (graph%order.EQ.1) THEN
      write(nout,*)'Point:'
      DO p=1,nprops
        write(nout,1703) p,koff(p,0),koff(p,1),koff(p,2),koff(p,3)
1703    format('p =',i2,'  koff = ',4(1p g12.3))
      END DO
      write(nout,*)'pii = ',theshower%pii,' pjj = ',theshower%pjj
      write(nout,1704) kcut(4,0),kcut(4,1),kcut(4,2),kcut(4,3)
1704  format('kcut(4,mu) = ',4(1p g12.3))
    END IF
  END IF
!....
!
  IF (graph%order.EQ.2) THEN
    IF (cut%ninloop.EQ.3) THEN
! 
! We need the renormalization counter term:
!
      flag = 'renormalize 3 pt'
      IF (gauge.EQ.'feynman') THEN
        feynmanval = feynmanf(graph%graphnumber,kc,cutQ,mumsbar,flag)
      ELSE IF (gauge.EQ.'coulomb') THEN
        feynmanval = &
         feynman(graph%graphnumber,flavorset%setnumber,kc,cutQ,mumsbar,flag)
      ELSE
        write(nout,*)'That gauge does not exist.'
        stop
      END IF
      integrand = prefactor * jacnewpoint * jacdeform * feynmanval * smear(rts)
      maxweight = max(maxweight,abs(xxreal(integrand)))
      weight = weight + xxreal(integrand)
      integrand = integrand * calsval
      maxpart = max(maxpart,abs(xxreal(integrand)))
      value = value + integrand
!....
      IF (report) THEN
        IF (details) THEN
          write(nout,370)
          write(nout,371)prefactor,jacnewpoint,jacdeform, &
                         feynmanval,calsval,smear(rts)
        END IF
        write(nout,374)integrand*groupsizetotal
374     format('  uv counter term:',2(1p g18.10))
        write(nout,341)weight*calsval*groupsizetotal
      END IF
!''''
!
    END IF  ! (cut%ninloop.EQ.3)
!
    IF (mode.EQ.'shower'.AND.dosoft) THEN
! 
! We need the soft subtraction:
!
      feynmanval = softsubtraction(k,absk,kc, &
                   graph%graphnumber,flavorset%setnumber,cut%cutnumber)
      integrand = prefactor * jacnewpoint * feynmanval * smear(rts)
      maxweight = max(maxweight,abs(xxreal(integrand)))
      weight = weight + xxreal(integrand)
      integrand = integrand * calsval
      maxpart = max(maxpart,abs(xxreal(integrand)))
      value = value + integrand
!....
      IF (report) THEN
        IF (details) THEN
          write(nout,416)
416       format('prefactor * jacnewpoint *', &
           ' (feynman-r feynman-i) * calsval * smear(rts)')
          write(nout,417)prefactor,jacnewpoint,feynmanval,calsval,smear(rts)
417       format(7(1p g12.3))
        END IF
          write(nout,375)integrand*groupsizetotal
375       format(' soft subtraction:',2(1p g18.10))
          write(nout,341)weight*calsval*groupsizetotal
      END IF
!....
    END IF  ! (mode.EQ.'shower'.AND.dosoft)
!
  END IF  ! (graph%order.EQ.2)
!
END IF  ! (.NOT.calcmore)
!
! End of loop DO WHILE (CALCMORE) that runs over loopcuts.
!
END DO
!
! If the mode is shower and 1 - thrust was too small, we cancel part of
! the work just done.
!
IF (mode.EQ.'shower') THEN
  IF (onemthrust .LT. thrustcut) THEN
    value = onemthrust/thrustcut*value
    weight = onemthrust/thrustcut*weight
  END IF
END IF
!
! We are ready to call Hrothgar to process the result for this cut.
!
call hrothgar(nparticles,kf,weight,1,'newresult ')
!
! Close loop DO ... call getnewcut(); IF (.NOT.cutfound) EXIT
!
END DO
!
! Close loop DO with call getnewflavorset(); IF (.NOT.flavorsetfound) EXIT
! for Coulomb gauge.
!
IF (gauge.EQ.'feynman') EXIT
END DO
!
RETURN
END subroutine calculate
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!                  End of subroutine to calculate integrand
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine  &
  checkcalc(graphnumber,cutindex,kc,jacnewpoint,jacdeform,check)
!
use beowulf_helpers
implicit none
! In:
integer :: graphnumber,cutindex(size+1)
complex(kind=dbl) :: kc(0:3*size-1,0:3)
real(kind=dbl) :: jacnewpoint
complex(kind=dbl) :: jacdeform
! Out:
complex(kind=dbl) :: check
!
! Compute a known integral to see if we have it right.
! This subroutine calculates the integrand.
! The check is based on 
!   Int d^3 p [p^2 + M^2]^(-3) = Pi^2/ (4 M^3).
!   Int d^3 p [p^2 (p^2 + M^2)]^(-1) = 2 Pi^2 /M
! Note that we look at just one term in the sum over cuts
! and loopcuts: 
! For graph 10, we take Cutindex = (7,5,4,1);
! For graph 8, we take Cutindex = (8,6,4,1), etc.
!
! Latest modification: 11 February 2002.
!
! Reno size and counting variables:
integer :: groupsize(maxgraphs,maxmaps)
integer :: groupsizegraph(maxgraphs)
integer :: groupsizetotal
common /montecarlo/groupsize,groupsizegraph,groupsizetotal
!
real(kind=dbl), parameter :: mm = 3.0d-1
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
complex(kind=dbl) :: temp1,temp2,temp3
integer :: mu
!
! If it is not the right graph and the right cut, this default
! value will be returned.
!
check = (0.0d0,0.0d0)
!
temp1 = 0.0d0
temp2 = 0.0d0
temp3 = 0.0d0
!
IF (graphnumber.EQ.12) THEN
!
  IF (   (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) &
    .AND.(cutindex(3).EQ.1) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(5,mu)*kc(5,mu)
      temp2 = temp2 + kc(4,mu)*kc(4,mu) 
    END DO
  ELSE
    RETURN
  END IF
!
ELSE IF (graphnumber.EQ.11) THEN
!
  IF (   (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) &
    .AND.(cutindex(3).EQ.1) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(5,mu)*kc(5,mu)
      temp2 = temp2 + kc(4,mu)*kc(4,mu)
    END DO
  ELSE
    RETURN
  END IF
!
ELSE IF (graphnumber.EQ.10) THEN
!
  IF (   (cutindex(1).EQ.7).AND.(cutindex(2).EQ.5) &
    .AND.(cutindex(3).EQ.4).AND.(cutindex(4).EQ.1) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(7,mu)*kc(7,mu)
      temp2 = temp2 + kc(6,mu)*kc(6,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
!
ELSE IF (graphnumber.EQ.9) THEN
!
  IF (   (cutindex(1).EQ.8).AND.(cutindex(2).EQ.7) &
    .AND.(cutindex(3).EQ.3).AND.(cutindex(4).EQ.5) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(8,mu)*kc(8,mu)
      temp2 = temp2 + kc(6,mu)*kc(6,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
!      
ELSE IF (graphnumber.EQ.8) THEN
!
  IF (   (cutindex(1).EQ.8).AND.(cutindex(2).EQ.6) &
    .AND.(cutindex(3).EQ.4).AND.(cutindex(4).EQ.1) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(5,mu)*kc(5,mu)
      temp2 = temp2 + kc(8,mu)*kc(8,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
!
ELSE IF (graphnumber.EQ.7) THEN
!
  IF (   (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) &
    .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.6) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(5,mu)*kc(5,mu)
      temp2 = temp2 + kc(7,mu)*kc(7,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
!
ELSE IF (graphnumber.EQ.6) THEN
!
  IF (   (cutindex(1).EQ.8).AND.(cutindex(2).EQ.5) &
    .AND.(cutindex(3).EQ.3).AND.(cutindex(4).EQ.6) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(5,mu)*kc(5,mu)
      temp2 = temp2 + kc(7,mu)*kc(7,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
! 
ELSE IF (graphnumber.EQ.5) THEN
!
  IF (   (cutindex(1).EQ.8).AND.(cutindex(2).EQ.7) &
    .AND.(cutindex(3).EQ.3).AND.(cutindex(4).EQ.1) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(5,mu)*kc(5,mu)
      temp2 = temp2 + kc(8,mu)*kc(8,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
!
ELSE IF (graphnumber.EQ.4) THEN
!
  IF (   (cutindex(1).EQ.6).AND.(cutindex(2).EQ.4) &
    .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.7) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(7,mu)*kc(7,mu)
      temp2 = temp2 + kc(5,mu)*kc(5,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
! 
ELSE IF (graphnumber.EQ.3) THEN
!
  IF (   (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) &
    .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.6) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(7,mu)*kc(7,mu)
      temp2 = temp2 + kc(5,mu)*kc(5,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
! 
ELSE IF (graphnumber.EQ.2) THEN
!
  IF (   (cutindex(1).EQ.7).AND.(cutindex(2).EQ.6) &
    .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.4) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(7,mu)*kc(7,mu)
      temp2 = temp2 + kc(5,mu)*kc(5,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
!
ELSE IF (graphnumber.EQ.1) THEN
!
  IF (   (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) &
    .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.7) ) THEN
    DO mu = 1,3
      temp1 = temp1 + kc(7,mu)*kc(7,mu)
      temp2 = temp2 + kc(5,mu)*kc(5,mu)
      temp3 = temp3 + kc(1,mu)*kc(1,mu) 
    END DO
  ELSE
    RETURN
  END IF
! 
ELSE
  write(nout,*)'Problem with graph number in checkcalc.'
  stop
END IF
!
IF (graphnumber.LE.10) THEN
!
! Here is an infrared sensitive check integral:
!
 check =         temp1 * (temp1 + mm**2)
 check = check * temp2 * (temp2 + mm**2)
 check = check * (temp3 + mm**2)**3
 check = (mm**5/pi**6) /check
!
! Here is a nice smooth check integral:
!       CHECK =         (TEMP1 + MM**2)**3
!       CHECK = CHECK * (TEMP2 + MM**2)**3
!       CHECK = CHECK * (TEMP3 + (2.0D0*MM)**2)**3
!       CHECK = (512.0D0 * MM**9 / PI**6) /CHECK
!
ELSE IF (graphnumber.LE.12) THEN
!
  check =         (temp1 + mm**2)**3
  check = check * (temp2 + mm**2)**3
  check = (16.0d0 * mm**6 / pi**4) /check
!
ELSE
  write(nout,*)'We were expecting graphnumbers 1,...,12.'
  stop
END IF
!
check = jacdeform * jacnewpoint * check
!
! Weight according to the number of points devoted to the current
! graph.
!
check = check * groupsizegraph(graphnumber)/groupsizetotal
!
RETURN
END subroutine checkcalc
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function density(graphnumber,k,qs,qsigns,maptypes,nmaps,order)
!
use beowulf_helpers
implicit none
! In:
integer :: graphnumber
real(kind=dbl) :: k(0:3*size-1,0:3)
integer :: qs(maxmaps,0:size),qsigns(maxmaps,0:size)
character(len=6) :: maptypes(maxmaps)
integer :: nmaps,order
! Out:
real(kind=dbl) :: density
!
! Density of Monte Carlo points as a function of |K(p)|'s.
! 
! 29 June 1993
! 12 July 1993
! 17 July 1994
!  4 May 1996
! 21 November 1996
!  5 December 1996
!  5 February 1997
! 15 December 1998
! 23 December 1998
!  9 February 1999
! 10 March    1999
! 20 August   1999
! 21 December 2000
! 20 March    2001
!  1 February 2002
!  7 December 2002
!
integer :: nloops
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
integer :: groupsize(maxgraphs,maxmaps)
integer :: groupsizegraph(maxgraphs)
integer :: groupsizetotal
common /montecarlo/groupsize,groupsizegraph,groupsizetotal
!
integer :: mapnumber,l,mu
real(kind=dbl) :: p1(3),p2(3),ell1(3),absp1,absp2,absp3
real(kind=dbl) :: temp1,temp2,temp3,p1sq,p2sq,p3sq
character(len=6) :: maptype
integer :: qsign(0:size),q(0:size)
real(kind=dbl) :: rho3,rho2to3d,rho2to3e,rho2to2t,rho2to2s,rho2to1a,rho2to1b
real(kind=dbl) :: rhothree,rholoop
!
IF (order.EQ.1) THEN
  nloops = nloops1
ELSE IF (order.EQ.2) THEN
  nloops = nloops2
ELSE
  write(nout,*)'Order must be 1 or 2.',order
END IF
!
IF (order.EQ.1) THEN
!
! We deal with the case of a Born graph first.
!
density = 0.0d0
DO mapnumber = 1,nmaps
!
DO l = 0,nloops
 q(l) = qs(mapnumber,l)
 qsign(l) = qsigns(mapnumber,l)
END DO
p1sq = 0.0d0
p2sq = 0.0d0
p3sq = 0.0d0
DO mu = 1,3
  temp1 = qsign(1)*k(q(1),mu)
  temp2 = qsign(2)*k(q(2),mu)
  temp3 = - temp1 - temp2
  p1sq = p1sq + temp1**2
  p2sq = p2sq + temp2**2
  p3sq = p3sq + temp3**2
END DO
absp1 = sqrt(p1sq)
absp2 = sqrt(p2sq)
absp3 = sqrt(p3sq)
rhothree = rho3(absp1,absp2,absp3)
density = density &
          + rhothree*groupsize(graphnumber,mapnumber)
!
END DO
!
! Alternative for  IF (ORDER.EQ.1) THEN
!
ELSE IF (order.EQ.2) THEN
!
! We tackle the case of an order alpha_s^2 graph.
! We construct the density as a sum.
!
density = 0.0d0
DO mapnumber = 1,nmaps
!
maptype = maptypes(mapnumber)
DO l = 0,nloops
 q(l) = qs(mapnumber,l)
 qsign(l) = qsigns(mapnumber,l)
END DO
!
! First, we need the kinematic variables for this map.
!
p1sq = 0.0d0
p2sq = 0.0d0
p3sq = 0.0d0
DO mu = 1,3
  ell1(mu) = qsign(1)*k(q(1),mu)
  temp1 = qsign(2)*k(q(2),mu)
  temp2 = qsign(3)*k(q(3),mu)
  temp3 = - temp1 - temp2
  p1(mu) = temp1
  p1sq = p1sq + temp1**2
  p2(mu) = temp2
  p2sq = p2sq + temp2**2
  p3sq = p3sq + temp3**2
END DO
absp1 = sqrt(p1sq)
absp2 = sqrt(p2sq)
absp3 = sqrt(p3sq)
!
! Now, there are two factors, one for the 'final state momenta' and
! one for the 'loop momentum.'
!
rhothree = rho3(absp1,absp2,absp3)
!
IF (maptype.EQ.'t2to3d') THEN
  rholoop = rho2to3d(p1,p2,ell1)
ELSE IF (maptype.EQ.'t2to3e') THEN
  rholoop = rho2to3e(p1,p2,ell1)
ELSE IF (maptype.EQ.'t2to2t') THEN
  rholoop = rho2to2t(p1,p2,ell1)
ELSE IF (maptype.EQ.'t2to2s') THEN
  rholoop = rho2to2s(p1,p2,ell1)
ELSE IF (maptype.EQ.'t2to1a') THEN
  rholoop = rho2to1a(p1,p2,ell1)
ELSE IF (maptype.EQ.'t2to1b') THEN
  rholoop = rho2to1b(p1,p2,ell1)
ELSE 
  write(nout,*)'Bad maptype in density.'
  stop
END IF
!
density = density &
          + rhothree*rholoop*groupsize(graphnumber,mapnumber)
!
! Close  DO MAPNUMBER = 1,NMAPS 
!
END DO
!
! Close for  IF (ORDER.EQ.1) THEN ...   ELSE IF (ORDER.EQ.2) THEN
!
ELSE
  write(nout,*)'Order should have been 1 or 2 in density.'
  stop
END IF
!
RETURN
END function density
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!              Subroutines associated with NEWPOINT and DENSITY
!     CHOOSEx and RHOx where x = 3, 2to2T, 2to2S, 2to3D, 2to3E, 2to1A,2to1B
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine choose3(p1,p2,p3,ok)
!
use beowulf_helpers
implicit none
! Out:
real(kind=dbl) :: p1(3),p2(3),p3(3)
logical :: ok
!
! Generates momenta P1(mu),P2(mu),P3(mu) for a three body final 
! state with a distribution in momentum fractions x1,x2,x3 
! proportional to
!
!        [max(1-x1,1-x2,1-x3)]^B/[(1-x1)*(1-x2)*(1-x3)]^B.
!
! 28 December 2000
! 16 January 2001
!
real(kind=dbl) :: badnesslimit,cancellimit,thrustcut
common /limits/ badnesslimit,cancellimit,thrustcut
real(kind=dbl), parameter :: onethird = 0.3333333333333333333d0
real(kind=dbl), parameter :: twothirds = 0.6666666666666666667d0
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
! The parameter E3PAR should match between CHOOSE3 and RHO3.
!
real(kind=dbl), parameter :: e3par = 1.5d0
!
! The parameters A, B, and C need to match between CHOOSE3 and RHO3.
! CHOOSE3 uses A, while RHO3 uses B and C. The relation is
! B = 1 - 1/A and then C is the normalization factor and is
! a rather complicated function of B.
!
! Some soft and collinear points:
!
real(kind=dbl), parameter :: a = 2.0d0
real(kind=dbl), parameter :: b = 0.5d0
real(kind=dbl), parameter :: c = 0.0036376552621307193655d0
!
! Lots of soft and collinear points:
!
!      REAL*8 A,B,C
!      PARAMETER(A = 4.0D0)
!      PARAMETER(B = 0.75D0)
!      PARAMETER(C = 0.00058417226323428314253D0)
!
real(kind=dbl) :: x,random
logical :: done
integer :: mu
real(kind=dbl) :: emax
real(kind=dbl) :: x1,x2,x3,y1,y2,y3
real(kind=dbl) :: ea(3),eb(3),ec(3),ed(3)
real(kind=dbl) :: phi,costheta,sintheta
real(kind=dbl) :: k1(3),k2(3),k3(3)
!
!----------
!
ok = .true.
!
! We will generate vectors K1(mu), K2(mu), K3(mu) with |K1| > |K3| and
! |K2| > |K3|. At the end, we will associate each Ki(mu) with a Pj(mu)
! with the index j of the Pj(mu) that matches K3(mu) chosen at random.
! 
! We choose y1, y2, y3 in 0< y_i < 1 with y1 + y2 + y3 = 1. The y_i are
! related to the momentum fractions x_i by y_i = 1 - x_i. For the y_i,
! we want y3 to be the largest, with no specification about whether y1
! or y2 is larger.  We want to choose y1 and y2 with a 1/sqrt(y1*y2)
! distribution. Then y3 = 1 - y1 - y2.  We must insure that y3 > y1 and
! y3 > y2 for the point to be valid. Note that the allowed region is
! inside the region 0 < y1 < 1/2, 0 < y2 < 1/2. If we choose a random
! variable x in 0 < x < 1 and define y = x**2/2 then the density dx/dy
! is proportional to 1/sqrt(y) and 0 < y < 1/2.
!
! We loop until we are "done" choosing a valid point.
!
done = .false.
DO WHILE (.NOT.done)
  x = random(1)
  y1 = 0.5d0 * x**a
  x = random(1)
  y2 = 0.5d0 * x**a
  y3 = 1.0d0 - y1 - y2
  IF ((y1 .LT. y3).AND.(y2.LT.y3)) THEN
    done = .true.
  END IF
END DO
x1 = 1.0d0 - y1
x2 = 1.0d0 - y2
x3 = y1 + y2
!
! If the chosen point is too soft or collinear, we will not be able
! to compute the kinematics for the rest of this subroutine
! or the other CHOOSEx subroutines, so we just abort.
!
IF ( y1*y2.LT.(100.0d0*badnesslimit)**(-2) ) THEN
  DO mu = 1,3
    p1(mu) = 0.0d0
    p2(mu) = 0.0d0
    p3(mu) = 0.0d0
  END DO
  ok = .false.
  RETURN
END IF
!
! Choose Emax = sum_i |p_i| /2.
!
x = random(1)
emax = e3par * ( 1.0d0/x - 1.0d0 )**onethird
!
! Choose a direction EA(mu) at random on the unit sphere.
!
x = random(1)
costheta = 2.0d0*x - 1.0d0
sintheta = sqrt(1.0d0 - costheta**2)
x = random(1)
phi = 2.0d0 * pi * x
ea(1) = sintheta * cos(phi)
ea(2) = sintheta * sin(phi)
ea(3) = costheta
!
! Generate vectors EB and EC that form a right handed basis set with EA.
!
call axes(ea,eb,ec)
!
! Generate a unit vector ED at a with a random azimuthal angle around
! the EA axis in this basis.
!
x = random(1)
phi = 2.0d0 * pi * x
DO mu = 1,3
  ed(mu) = cos(phi)*eb(mu) + sin(phi)*ec(mu)
END DO
!
! Now construct the momenta. P1(mu) is directed in the random direction
! EA(mu) with magnitude determined from Emax and X1. Then P3(mu)
! is in the plane of EA(mu) and ED(mu) with angle THETA to P1(mu) 
! determined from the Xi and magnitude determined by X2.
!
costheta = 1.0d0 - 2.0d0*y2/x1/x3
sintheta = 2.0d0*sqrt(y1*y2*y3)/x1/x3
DO mu = 1,3
  k1(mu) = x1*emax*ea(mu)
  k3(mu) = x3*emax*(costheta*ea(mu) + sintheta*ed(mu))
  k2(mu) = - k1(mu) - k3(mu)
END DO
!
! Match K3(mu) to one of the Pi(mu) at random.
!
x = random(1)
IF (x.GT.twothirds) THEN
  DO mu = 1,3
    p1(mu) = k1(mu)
    p2(mu) = k2(mu)
    p3(mu) = k3(mu)
  END DO
ELSE IF (x.GT.onethird) THEN
  DO mu = 1,3
    p1(mu) = k2(mu)
    p2(mu) = k3(mu)
    p3(mu) = k1(mu)
  END DO
ELSE
  DO mu = 1,3
    p1(mu) = k3(mu)
    p2(mu) = k1(mu)
    p3(mu) = k2(mu)
  END DO
END IF
!
RETURN
END subroutine choose3
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function rho3(absp1,absp2,absp3)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: absp1,absp2,absp3
! Out:
real(kind=dbl) :: rho3
!
!
! Density of points for points chosen with CHOOSE3(p1,p2,p3,ok).
! 16 January 2001
!
real(kind=dbl) :: emax,x1,x2,x3
real(kind=dbl) :: e03,emax3,factor,denom
!
! The parameter E3PAR should match between CHOOSE3 and RHO3.
! 
real(kind=dbl), parameter :: e3par = 1.5d0
!
! The parameters A, B, and C need to match between CHOOSE3 and RHO3.
! CHOOSE3 uses A, while RHO3 uses B and C. The relation is
! B = 1 - 1/A and then C is the normalization factor and is
! a rather complicated function of B.
!
! Some soft and collinear points:
!
real(kind=dbl), parameter :: a = 2.0d0
real(kind=dbl), parameter :: b = 0.5d0
real(kind=dbl), parameter :: c = 0.0036376552621307193655d0
!
! Lots of soft and collinear points:
!
!      REAL*8 A,B,C
!      PARAMETER(A = 4.0D0)
!      PARAMETER(B = 0.75D0)
!      PARAMETER(C = 0.00058417226323428314253D0)
!
emax = 0.5d0*(absp1 + absp2 + absp3)
x1 = absp1/emax
x2 = absp2/emax
x3 = absp3/emax
!
IF (x1.LT.x2) THEN
  IF (x1.LT.x3) THEN
!         X1 is smallest: X1<X2<X3 or X1<X3<X2
    factor = ((1.0d0-x2)*(1.0d0-x3))**b
  ELSE
!         X3 is smallest: X3<X1<X2
    factor = ((1.0d0-x1)*(1.0d0-x2))**b
  END IF
ELSE
  IF (x2.LT.x3) THEN
!         X2 is smallest: X2<X1<X3 or X2<X3<X1
    factor = ((1.0d0-x3)*(1.0d0-x1))**b
  ELSE
!         X3 is smallest: X3<X2<X1
    factor = ((1.0d0-x1)*(1.0d0-x2))**b
  END IF
END IF
IF(factor.LT.1.0d-15) THEN
  write(nout,*)'Factor too small in rho3.',x1,x2,x3
  stop
END IF
!
e03 = e3par**3
emax3 = emax**3
denom = e03 * emax3 * (emax3/e03 + 1.0d0)**2 
denom = denom * x1 * x2 * x3 * factor
rho3 = c/denom
!
RETURN
END function rho3
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine choose2to2s(pa,pb,ell1,ok)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3)
! Out:
real(kind=dbl) :: ell1(3)
logical :: ok
!
! Generates a point ell1(mu) using an elliptical coordinate system
! based on the vectors p_A(mu) and p_B(mu). The points are concentrated
! near ell1(mu) = 0 and near the ellipse |ell1| + |q - ell1| = |p_A| + |p_B|
! where q = p_A + p_B.
! 15 December 2000
! 14 Maarch 2001
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
!  
!
! Function RANDOM(1) give a random number in the range 0<x<1.
!
real(kind=dbl) :: random,x
!
! Function EXPM1(z) gives exp(z) - 1 while SQRTM1(z) gives sqrt(1+z) -1.
!
real(kind=dbl) :: expm1,sqrtm1
!
real(kind=dbl) :: abspa,abspb
real(kind=dbl) :: sumab(3),cross(3)
real(kind=dbl) :: twokappa,kappa,abscross
real(kind=dbl) :: nz(3),ny(3),nx(3)
real(kind=dbl) :: phi,aminus,aplus
real(kind=dbl) :: splus,tau,cm1,c,n
real(kind=dbl) :: lambda,loga,logb,splusl,sminusl,norm,cplus,temp
real(kind=dbl) :: lz,lt,lx,ly
!
!-----------------------------------------------------------------------
!
ok = .true.
!
! First we calculate the unit vectors n_x, n_y, n_z used to define
! the orientation of the elliptical coordinate system. For later
! use, the variable |p_a + p_b| gets a special name, 2 kappa.
!
abspa = sqrt(pa(1)**2 + pa(2)**2 + pa(3)**2)
abspb = sqrt(pb(1)**2 + pb(2)**2 + pb(3)**2)
!
sumab(1) = pa(1) + pb(1)
sumab(2) = pa(2) + pb(2)
sumab(3) = pa(3) + pb(3)
twokappa = sqrt(sumab(1)**2 + sumab(2)**2 + sumab(3)**2)
kappa = 0.5d0*twokappa
cross(1) = pb(2)*pa(3) - pb(3)*pa(2)
cross(2) = pb(3)*pa(1) - pb(1)*pa(3)
cross(3) = pb(1)*pa(2) - pb(2)*pa(1) 
abscross = sqrt(cross(1)**2 + cross(2)**2 + cross(3)**2)
IF (twokappa**2 .LT. 1d-16 * abspa * abspb) THEN
  write(nout,*) 'twokappa too small in choose2to2s.',kappa
  stop
END IF
IF (abscross .LT. 1d-8 * abspa * abspb) THEN
  write(nout,*) 'abscross too small in choose2to2s.',abscross
  write(nout,*) 'pa is    ',pa
  write(nout,*) 'pb is    ',pb
  write(nout,*) 'cross is ',cross
  ok = .false.
END IF
nz(1) = sumab(1)/twokappa
nz(2) = sumab(2)/twokappa
nz(3) = sumab(3)/twokappa
ny(1) = cross(1)/abscross
ny(2) = cross(2)/abscross
ny(3) = cross(3)/abscross
nx(1) = ny(2)*nz(3) - ny(3)*nz(2)
nx(2) = ny(3)*nz(1) - ny(1)*nz(3)
nx(3) = ny(1)*nz(2) - ny(2)*nz(1)
!
! Choose phi.
!
x = random(1)
phi = pi * (2.0d0*x - 1.0d0)
!
! Choose A-.
! Here N is N-/C.
!
splus  = (abspa + abspb)/twokappa
tau = (splus - 1.0d0)/splus
cm1 = sqrtm1(tau)
c = cm1 + 1.0d0
n = 1.0d0/log((c + 1.0d0)/cm1)
x = random(1)
temp = expm1((2.0d0*x - 1.0d0)/n)
aminus = c * temp/(temp + 2.0d0)
!
! Choose A+.
!
lambda = (splus - 1.0d0)**2/splus
loga = log(splus*(splus - 1.0d0 + lambda)/lambda)
logb = log(splus/lambda)
splusl = splus + lambda
sminusl = splus - lambda
!
norm  = 1.0d0/( loga/splusl + logb/sminusl )
cplus = 1.0d0/(1.0d0 + splusl*logb/(sminusl*loga) )
!
x = random(1)
IF (x .GT. cplus) THEN
  temp = 1.0d0 - lambda/splus * exp( sminusl*(x - cplus)/norm )
  IF (temp.LT.1.0d-15) THEN
    write(nout,*)'There could be a problem in choose2to2s.'
    ok = .false.
  END IF
  aplus = sminusl/temp
ELSE
  temp = 1.0d0 + lambda/splus * exp( splusl*(cplus - x)/norm )
  aplus = splusl/temp
END IF
!
! We now have A+, A-, and phi so we find ell1(mu).
!
lz = kappa*(1.0d0 + aplus*aminus)
lt = kappa*sqrt((aplus**2 - 1.0d0)*(1.0d0 - aminus**2))
lx = lt*cos(phi)
ly = lt*sin(phi)
ell1(1) = lx*nx(1) + ly*ny(1) + lz*nz(1)
ell1(2) = lx*nx(2) + ly*ny(2) + lz*nz(2)
ell1(3) = lx*nx(3) + ly*ny(3) + lz*nz(3)
!
RETURN
END subroutine choose2to2s
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function rho2to2s(pa,pb,ell1)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3),ell1(3)
! Out:
real(kind=dbl) :: rho2to2s
!
! Density function for points ell1 chosen by CHOOSE2TO2S(p_a,p_b,ell1,ok).
! 15 December 2000
! 20 March 2001
!
!      
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
! Function SQRTM1(z) gives sqrt(1+z) -1.
!
real(kind=dbl) :: sqrtm1
!
integer :: mu
real(kind=dbl) :: sumabsq,ell1sq,ell1primesq,pasq,pbsq
real(kind=dbl) :: twokappa,kappa,absell1,absell1prime,abspa,abspb
real(kind=dbl) :: splus,aplus,aminus
real(kind=dbl) :: tau,cm1,c
real(kind=dbl) :: lambda,loga,logb,splusl,sminusl
real(kind=dbl) :: temp,denom
!
!-----------------------------------------------------------------------
! We start with the absolute values of combinations of vectors.
!
sumabsq = 0.0d0
ell1sq = 0.0d0
ell1primesq = 0.0d0
pasq = 0.0d0
pbsq = 0.0d0
DO mu = 1,3
  temp = pa(mu) + pb(mu)
  sumabsq = sumabsq + temp**2
  ell1sq =  ell1sq + ell1(mu)**2
  ell1primesq =  ell1primesq  + (ell1(mu) - temp)**2
  pasq = pasq + pa(mu)**2
  pbsq = pbsq + pb(mu)**2
END DO
twokappa = sqrt(sumabsq)
kappa = 0.5d0*twokappa
absell1 = sqrt(ell1sq)
absell1prime = sqrt(ell1primesq)
abspa = sqrt(pasq)
abspb = sqrt(pbsq)
!
! Now S+ and S- and A+ and A-.
!
splus  = (abspa + abspb)/twokappa
aplus =  (absell1 + absell1prime)/twokappa
aminus = (absell1 - absell1prime)/twokappa
!
! Finally some auxilliary parameters.
!
tau = (splus - 1.0d0)/splus
cm1 = sqrtm1(tau)
c = cm1 + 1.0d0
lambda = (splus - 1.0d0)**2/splus
loga = log(splus*(splus - 1.0d0 + lambda)/lambda)
logb = log(splus/lambda)
splusl = splus + lambda
sminusl = splus - lambda
denom = aplus**2 - aminus**2
IF (denom.LT.1.0d0-12) THEN
  write(nout,*)'denom too small in rho2to2s.',aplus,aminus
  stop
END IF
!
! RHO is the inverse of the product of several factors.
! Phi factor:
temp = 2.0d0*pi
! A- normalization:
temp = temp*log((c + 1.0d0)/cm1)/c
! A- factor:
temp = temp*(c**2 - aminus**2)
! A+ normalization:
temp = temp*(loga/splusl + logb/sminusl)
! A+ factor:
temp = temp*aplus*( abs(aplus - splus) + lambda )
! Jacobian for k to A+,A-,phi:
temp = temp*kappa**3*denom
! Invert this:
rho2to2s = 1.0d0/temp
!
RETURN
END function rho2to2s
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine choose2to2t(pa,pb,ell1,ok)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3)
! Out:
real(kind=dbl) :: ell1(3)
logical :: ok
!
! Generates a point ell1(mu) using an elliptical coordinate system
! based on the vectors p_A(mu) and p_B(mu). The points are concentrated
! near ell1(mu) = 0 and near the ellipse |p_A + ell1| + |p_B - ell1| =
! |p_A| + |p_B|.
! 28 December 1999
! 13 March 2001
!
! The parameters A2T02T, B2TO2T, C2TO2T 
! must match between CHOOSE2TO2T and RHO2TO2T. 
!
real(kind=dbl), parameter :: a2to2t = 0.3d0
real(kind=dbl), parameter :: b2to2t = 0.3d0
real(kind=dbl), parameter :: c2to2t = 6.0d0
!
! The parameter CONST is a derived number, equal to 
! (1/g)*(log(1/g)**2 - 2*log(1/g) + 2) where g = C2TO2T. For
! g = 6, this constant is 1.4656534890040852295.
!
real(kind=dbl), parameter :: const = 1.4656534890040852295d0
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
! Function SQRTM1(x) gives sqrt(1+x) - 1.
! Function EXPM1(x)  gives exp(x) - 1.
! Function INVLOGSQINT(w) = y <==> w = y*(Log(y)**2 - 2*Log(y) + 2).
! Function RANDOM(1) give a random number in the range 0<x<1.
!
real(kind=dbl) :: sqrtm1,expm1,invlogsqint,random
!
real(kind=dbl) :: sumab(3),cross(3)
real(kind=dbl) :: twokappa,abscross
real(kind=dbl) :: nz(3),ny(3),nx(3)
real(kind=dbl) :: kappa,abspa,abspb,splus,sminus
real(kind=dbl) :: x,twoxm1,w,phi,phipi
real(kind=dbl) :: lphi2,lp2,lm2,nminus,cminus,root,daminus,dx,aminus
real(kind=dbl) :: omega,splusm1,bsw,a,b,nplus,cplus,factor,aplus
real(kind=dbl) :: daplus,temp
real(kind=dbl) :: uplus,uminus,vplus,vminus,lt0,z0,zeta,dlt,dz
real(kind=dbl) :: sinphi,cosphi,cosphim1,lx,ly
!
real(kind=dbl) :: tau,cm1,c,n
real(kind=dbl) :: lambda,loga,logb,splusl,sminusl,norm
real(kind=dbl) :: lz,lt
!
!
!-----------------------------------------------------------------------
!
ok = .true.
!
! First we calculate the unit vectors n_x, n_y, n_z used to define
! the orientation of the elliptical coordinate system. For later
! use, the variable |p_a + p_b| gets a special name, 2 kappa.
!
abspa = sqrt(pa(1)**2 + pa(2)**2 + pa(3)**2)
abspb = sqrt(pb(1)**2 + pb(2)**2 + pb(3)**2)
!
sumab(1) = pa(1) + pb(1)
sumab(2) = pa(2) + pb(2)
sumab(3) = pa(3) + pb(3)
twokappa = sqrt(sumab(1)**2 + sumab(2)**2 + sumab(3)**2)
kappa = 0.5d0*twokappa
cross(1) = pb(2)*pa(3) - pb(3)*pa(2)
cross(2) = pb(3)*pa(1) - pb(1)*pa(3)
cross(3) = pb(1)*pa(2) - pb(2)*pa(1) 
abscross = sqrt(cross(1)**2 + cross(2)**2 + cross(3)**2)
IF (twokappa**2 .LT. 1d-16 * abspa * abspb) THEN
  write(nout,*) 'twokappa too small in choose2to2t.',kappa
  ok = .false.
END IF
IF (abscross .LT. 1d-8 * abspa * abspb) THEN
  write(nout,*) 'abscross too small in choose2to2t.',abscross
  write(nout,*) 'pa is    ',pa
  write(nout,*) 'pb is    ',pb
  write(nout,*) 'cross is ',cross
  ok = .false.
END IF
nz(1) = sumab(1)/twokappa
nz(2) = sumab(2)/twokappa
nz(3) = sumab(3)/twokappa
ny(1) = cross(1)/abscross
ny(2) = cross(2)/abscross
ny(3) = cross(3)/abscross
nx(1) = ny(2)*nz(3) - ny(3)*nz(2)
nx(2) = ny(3)*nz(1) - ny(1)*nz(3)
nx(3) = ny(1)*nz(2) - ny(2)*nz(1)
!
! At this point, we have two options. There is a main way to choose
! our point and there is a subsidiary way, which is the same as in
! CHOOSE2TO2S. If a random variable X is greater than A2TO2T, 
! we choose the main way, otherwise we choose the subsidiary way.
!
IF (random(1).GT.a2to2t) THEN
!
! Now some variables that depend on p_a and p_b, namely S+ and S-.
!
splus  = (abspa + abspb)/twokappa
sminus = (abspa - abspb)/twokappa
!
! Choose phi.
! The standard function SIGN(xx,X) gives xx with the sign of X.
! For later use, we define PHIPI = |Phi|/Pi.
!
x = random(1)
twoxm1 = 2.0d0*x - 1.0d0
w = const*abs(twoxm1)
phipi = c2to2t*invlogsqint(w)
phi = pi * sign(phipi,twoxm1)
!
! Choose A-.
! There are three versions for the same thing, chosen according to
! which one should give the most accurate result, especially if
! |phi| is small.
!
x = random(1)
lphi2 = log(c2to2t/phipi)**2
lp2   = log(c2to2t/(1.0d0 + sminus + phipi))**2
lm2   = log(c2to2t/(1.0d0 - sminus + phipi))**2
nminus = 1.0d0/(lphi2 - 0.5d0 *(lp2 + lm2))
cminus = 0.5d0 * nminus * (lphi2 - lp2)
IF (x .LT. 0.5d0*cminus) THEN
  root = sqrt( 2.0d0*x/nminus + lp2 )
  daminus =  - c2to2t * exp(- root) + phipi
ELSE IF ((1.0d0 - x) .LT. 0.5d0*(1.0d0 - cminus)) THEN
  root = sqrt( 2.0d0*(1.0d0 - x)/nminus + lm2 )
  daminus =  c2to2t * exp(- root) - phipi
ELSE
  dx = x - cminus
  root = sqrt( lphi2 - 2.0d0*abs(dx)/nminus )
  daminus = sign( c2to2t*exp(-root) - phipi, dx)
END IF
aminus = sminus + daminus
!
! Choose A+.
! There are three versions for the same thing, chosen according to
! which one should give the most accurate result, especially if
! omega is small. 
! EXPM1(X) gives exp(x) - 1.
!
x = random(1)
omega = abs(daminus) + phipi
splusm1 = splus - 1.0d0
bsw = b2to2t*splus*omega
a = splusm1 + bsw*omega
b = splusm1 + c2to2t*bsw
nplus = 1.0d0 /log( c2to2t**2 * a /(omega**2 * b) )
cplus = nplus * log( c2to2t * a /(omega * b) )
IF (x .LT. 0.5d0*cplus) THEN
  factor = - expm1( - x/nplus)
  aplus = 1.0d0  &
      + a*b*factor/(bsw*(c2to2t - omega) + a*factor)
  daplus = aplus - splus
ELSE IF ((1.0d0 - x) .LT. 0.5d0*(1.0d0 - cplus)) THEN
  factor = - expm1((x - 1.0d0)/nplus)
  daplus = bsw &
     *(c2to2t - omega  - c2to2t*factor)/factor
  aplus = splus + daplus
ELSE
  dx = x - cplus
  factor = expm1( abs(dx)/nplus )
  temp = bsw*omega*factor
  temp = temp/(1.0d0 - omega/c2to2t*(factor + 1.0d0))
  daplus = sign(temp,dx)
  aplus = splus + daplus
END IF
!
! We now have A+, A-, and phi so we find ell1(mu).
! Use SQRTM1(zeta) = SQRT(1+zeta) - 1.
!
  uplus  = splus**2 -1.0d0
  uminus = 1.0d0 - sminus**2
  vplus  = daplus *(2.0d0*splus  + daplus) /uplus
  vminus = daminus*(2.0d0*sminus + daminus)/uminus
  lt0 = kappa * sqrt( uplus*uminus )
  z0 = kappa * splus * sminus
  zeta = vplus - vminus - vplus*vminus
  dlt = lt0*sqrtm1(zeta)
  dz = kappa*(daplus*sminus + daminus*splus + daplus*daminus)
  sinphi = sin(phi)
  cosphi = cos(phi)
  IF (cosphi .GT. 0.9 ) THEN
    cosphim1 = sqrtm1(-sinphi**2)
  ELSE
    cosphim1 = cosphi - 1.0d0
  END IF
  lx = dlt*cosphi + lt0*cosphim1
  ly = (lt0 + dlt)*sinphi
  ell1(1) = lx*nx(1) + ly*ny(1) + dz*nz(1)
  ell1(2) = lx*nx(2) + ly*ny(2) + dz*nz(2)
  ell1(3) = lx*nx(3) + ly*ny(3) + dz*nz(3)
!
RETURN
!
! Recall, we had two options. There was a main way to choose
! our point and there was a subsidiary way, which is the same as in
! CHOOSE2TO2S. If a random variable X was greater than A2TO2T, 
! we choose the main way, otherwise we get to here and choose the 
! subsidiary way, from CHOOSE2TO2S.
!
ELSE
!-----
! Choose phi.
!
x = random(1)
phi = pi * (2.0d0*x - 1.0d0)
!
! Choose A-.
! Here N is N-/C.
!
splus  = (abspa + abspb)/twokappa
tau = (splus - 1.0d0)/splus
cm1 = sqrtm1(tau)
c = cm1 + 1.0d0
n = 1.0d0/log((c + 1.0d0)/cm1)
x = random(1)
temp = expm1((2.0d0*x - 1.0d0)/n)
aminus = c * temp/(temp + 2.0d0)
!
! Choose A+.
!
lambda = (splus - 1.0d0)**2/splus
loga = log(splus*(splus - 1.0d0 + lambda)/lambda)
logb = log(splus/lambda)
splusl = splus + lambda
sminusl = splus - lambda
!
norm  = 1.0d0/( loga/splusl + logb/sminusl )
cplus = 1.0d0/(1.0d0 + splusl*logb/(sminusl*loga) )
!
x = random(1)
IF (x .GT. cplus) THEN
  temp = 1.0d0 - lambda/splus * exp( sminusl*(x - cplus)/norm )
  IF (temp.LT.1.0d-15) THEN
    write(nout,*)'There could be a problem in choose2to2t.'
    ok = .false.
  END IF
  aplus = sminusl/temp
ELSE
  temp = 1.0d0 + lambda/splus * exp( splusl*(cplus - x)/norm )
  aplus = splusl/temp
END IF
!
! We now have A+, A-, and phi so we find ell1(mu).
!
lz = kappa*(1.0d0 + aplus*aminus)
lt = kappa*sqrt((aplus**2 - 1.0d0)*(1.0d0 - aminus**2))
lx = lt*cos(phi)
ly = lt*sin(phi)
!-----
! Here we copy the construction of ell1 from CHOOSE2TO2S except
! that ell1_T = ell1_S - PA, so we have to subtract PA.
!
ell1(1) = lx*nx(1) + ly*ny(1) + lz*nz(1) - pa(1)
ell1(2) = lx*nx(2) + ly*ny(2) + lz*nz(2) - pa(2)
ell1(3) = lx*nx(3) + ly*ny(3) + lz*nz(3) - pa(3)
!
RETURN
!
! End of IF (RANDOM(1).GT.A2TO2T) THEN ... ELSE ...
!
END IF
END subroutine choose2to2t
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function rho2to2t(pa,pb,ell1)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3),ell1(3)
! Out:
real(kind=dbl) :: rho2to2t
!
! Density function for points ell1 chosen by CHOOSE2TO2T(p_a,p_b,ell1,ok).
! 28 December 1999
! 13 March 2001
!  8 May 2003
!
!
! The parameters A2TO2T, B2TO2T, C2TO2T
! must match between CHOOSE2TO2T and RHO2TO2T. 
!
real(kind=dbl), parameter :: a2to2t = 0.3d0
real(kind=dbl), parameter :: b2to2t = 0.3d0
real(kind=dbl), parameter :: c2to2t = 6.0d0
!
! The parameter CNST is a derived number, equal to 
! 1/[2 Pi*(log(1/g)**2 - 2*log(1/g) + 2)] where g = C2TO2T. For
! g = 6, this constant is 0.0180982913407954142662161898.
!
real(kind=dbl), parameter :: cnst = 0.0180982913407954142662d0
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
! Function SQRTM1(x) gives sqrt(1+x) - 1.
!
real(kind=dbl) :: sqrtm1
!
real(kind=dbl) :: sumab(3),cross(3)
real(kind=dbl) :: twokappa,abscross
real(kind=dbl) :: nz(3),ny(3),nx(3)
real(kind=dbl) :: kappa,pasq,pbsq,abspa,abspb,splus,sminus
real(kind=dbl) :: ell1sq,dotal,dotbl
real(kind=dbl) :: wa,wb,va,vb,daplus,daminus,aplus,aminus
real(kind=dbl) :: dotlstarnx,dotlstarny,phi,phipi
real(kind=dbl) :: rho0
real(kind=dbl) :: rhophi
real(kind=dbl) :: temp,nminus,omega
real(kind=dbl) :: rhominus
real(kind=dbl) :: splusm1,bsw,a,b,nplus,denom1,denom2
real(kind=dbl) :: rhoplus
real(kind=dbl) :: denom
real(kind=dbl) :: rhomain,rhoextra
real(kind=dbl) :: tau,cm1,c,lambda,loga,logb,splusl,sminusl
!
!-----------------------------------------------------------------------
! First we calculate the unit vectors n_x, n_y, n_z used to define
! the orientation of the ell1iptical coordinate system. For later
! use, the variable |p_a + p_b| gets a special name, 2 kappa.
!
pasq  = pa(1)**2  + pa(2)**2  + pa(3)**2
pbsq  = pb(1)**2  + pb(2)**2  + pb(3)**2
abspa = sqrt(pasq)
abspb = sqrt(pbsq)
!
sumab(1) = pa(1) + pb(1)
sumab(2) = pa(2) + pb(2)
sumab(3) = pa(3) + pb(3)
twokappa = sqrt(sumab(1)**2 + sumab(2)**2 + sumab(3)**2)
kappa = 0.5d0*twokappa
cross(1) = pb(2)*pa(3) - pb(3)*pa(2)
cross(2) = pb(3)*pa(1) - pb(1)*pa(3)
cross(3) = pb(1)*pa(2) - pb(2)*pa(1) 
abscross = sqrt(cross(1)**2 + cross(2)**2 + cross(3)**2)
IF (twokappa**2 .LT. 1d-16 * abspa * abspb) THEN
  write(nout,*) 'Twokappa too small in rho2to2t.',kappa
  stop
END IF
IF (abscross .LT. 1d-9 * abspa * abspb) THEN
  write(nout,*) 'abscross too small in rho2to2t.',abscross
  write(nout,*) 'pa is    ',pa
  write(nout,*) 'pb is    ',pb
  write(nout,*) 'cross is ',cross
  stop
END IF
nz(1) = sumab(1)/twokappa
nz(2) = sumab(2)/twokappa
nz(3) = sumab(3)/twokappa
ny(1) = cross(1)/abscross
ny(2) = cross(2)/abscross
ny(3) = cross(3)/abscross
nx(1) = ny(2)*nz(3) - ny(3)*nz(2)
nx(2) = ny(3)*nz(1) - ny(1)*nz(3)
nx(3) = ny(1)*nz(2) - ny(2)*nz(1)
!
! Now some further variables that do not depend on ell1, namely
! S+ and S-.
!
splus  = (abspa + abspb)/twokappa
sminus = (abspa - abspb)/twokappa
!
! Next, the dot products of ell1.
!
ell1sq = ell1(1)**2 + ell1(2)**2 + ell1(3)**2
dotal = pa(1)*ell1(1) + pa(2)*ell1(2) + pa(3)*ell1(3)
dotbl = pb(1)*ell1(1) + pb(2)*ell1(2) + pb(3)*ell1(3)
!
! With these we can calculate A+ and A-. We first calculate
! DA+ = A+ - S+ and DA- = A- - S- since these  variables appear in
! the density functions and they are small when ell1
! is small. Thus we want to know these separately from A+ and A-.
! We use the function SQRTM1(x) = sqrt(1+x) - 1 to define 
! V_a = |p_a + ell1| - |p_a| and V_b = |p_b - ell1| - |p_b|.
!
wa = (  2.0d0*dotal + ell1sq)/pasq
wb = ( -2.0d0*dotbl + ell1sq)/pbsq
va = abspa*sqrtm1(wa)
vb = abspb*sqrtm1(wb)
daplus  = (va + vb)/twokappa
daminus = (va - vb)/twokappa
aplus  = daplus  + splus
aminus = daminus + sminus
!
! We can also calculate phi. For this, we need the the dot products of 
! L* with the unit vectors n_x and n_y. Here L* = Pa + ell1. Note that
! NY is orthogonal to Pa so for an accurate calculation in the case
! that ell1 is small, we drop Pa from L* when dotting into Ny. For later
! use, we define PHIPI = |Phi|/Pi.
      dotlstarnx =  (pa(1) + ell1(1))*nx(1) + (pa(2) + ell1(2))*nx(2) &
            + (pa(3) + ell1(3))*nx(3)
dotlstarny = ell1(1)*ny(1) + ell1(2)*ny(2) + ell1(3)*ny(3)
phi = atan2(dotlstarny,dotlstarnx)
phipi = abs(phi/pi)
!
! Now we are ready to calculate the density. First the factor rho0
! that gives the jacobian for the change of variables from 
! {ell1(1), ell1(2), ell1(3)} to {A+,A-,phi}.
!
denom = aplus**2 - aminus**2
IF (denom.LT.1.0d0-12) THEN
  write(nout,*)'denom too small in rho2to2t.',aplus,aminus
  stop
END IF
rho0 = 1.0d0/(kappa**3 * denom)
!
! Next the factor for our choice of phi.
!
rhophi = cnst * log(phipi/c2to2t)**2
!
! Next the factor for our choice of A-.
!
temp = log(c2to2t/phipi)**2  &
      -0.5d0*( log(c2to2t/(1.0d0 + sminus + phipi))**2 &
             + log(c2to2t/(1.0d0 - sminus + phipi))**2 )
nminus = 1.0d0/temp
omega = abs(daminus) + phipi
rhominus = nminus * log(c2to2t/omega)/omega
!
! Finally the factor for our choice of A+.
!
splusm1 = splus - 1.0d0
bsw = b2to2t*splus*omega
a = splusm1 + bsw*omega
b = splusm1 + c2to2t*bsw
nplus = 1.0d0/log( c2to2t**2 * a /(omega**2 * b) )
temp = abs(daplus)
denom1 = temp + bsw*omega
denom2 = temp + c2to2t*bsw
rhoplus = nplus*bsw*(c2to2t - omega) /(denom1*denom2)
!
! The net density is the product of the factors just calculated.
!
rhomain = rho0*rhoplus*rhominus*rhophi
!
! Now we calculate a subsidiary rho just as in RHO2TO2S.
!---------
!
tau = (splus - 1.0d0)/splus
cm1 = sqrtm1(tau)
c = cm1 + 1.0d0
lambda = (splus - 1.0d0)**2/splus
loga = log(splus*(splus - 1.0d0 + lambda)/lambda)
logb = log(splus/lambda)
splusl = splus + lambda
sminusl = splus - lambda
denom = aplus**2 - aminus**2
IF (denom.LT.1.0d0-12) THEN
  write(nout,*)'denom too small in rho2to2t.',aplus,aminus
  stop
END IF
!
! RHO is the inverse of the product of several factors.
! Phi factor:
temp = 2.0d0*pi
! A- normalization:
temp = temp*log((c + 1.0d0)/cm1)/c
! A- factor:
temp = temp*(1.0d0 - aminus**2 + tau)
! A+ normalization:
temp = temp*(loga/splusl + logb/sminusl)
! A+ factor:
temp = temp*aplus*( abs(aplus - splus) + lambda )
! Jacobian for k to A+,A-,phi:
temp = temp*kappa**3*denom
! Invert this:
rhoextra = 1.0d0/temp
!
!---------
! End of subsidiary rho calculation.
!
rho2to2t = (1.0d0 - a2to2t)*rhomain + a2to2t*rhoextra
RETURN
END function rho2to2t
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine choose2to3d(pa,pb,ell1,ok)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3)
! Out:
real(kind=dbl) :: ell1(3)
logical :: ok
!
! Generates a point ell1(mu) using a circular coordinate system
! based on the vectors p_A(mu) and p_B(mu). The points are concentrated
! near the circle |ell1| = (|p_A| + |p_B| + |p_A + p_B|)/2. There is
! a special concentration near theta = 0, the direction of the largest
! of p_A and -p_B.
! 
! 18 December 2000
! 21 March 2001
!
!
! The parameter A2TO3 needs to match between CHOOSE2TO3D and RHO2TO3D.
!
real(kind=dbl), parameter :: a2to3 = 3.0d0
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
! Function EXPM1(x)  gives exp(x) - 1.
! Function RANDOM(1) give a random number in the range 0<x<1.
!
real(kind=dbl) :: expm1,random
!
real(kind=dbl) :: pc(3)
real(kind=dbl) :: abspa,abspb,abspc,sc
real(kind=dbl) :: nz(3),ny(3),nx(3)
real(kind=dbl) :: s,sdiffsq
real(kind=dbl) :: x
real(kind=dbl) :: phi,oneminuscos,costheta,sintheta,r
real(kind=dbl) :: temp,deltasq,delta,a,b,n,x0
real(kind=dbl) :: lx,ly,lz
!
!-----------------------------------------------------------------------
!
ok = .true.
!
! First we calculate the unit vectors n_x, n_y, n_z used to define
! the orientation of the spherical coordinate system. The z-axis goes 
! along the direction of the largest of PA and - PB.
!
pc(1) = - pa(1) - pb(1)
pc(2) = - pa(2) - pb(2)
pc(3) = - pa(3) - pb(3)
!
abspa = sqrt(pa(1)**2 + pa(2)**2 + pa(3)**2)
abspb = sqrt(pb(1)**2 + pb(2)**2 + pb(3)**2)
abspc = sqrt(pc(1)**2 + pc(2)**2 + pc(3)**2)
!
sc = abspc
nz(1) = -pc(1)/abspc
nz(2) = -pc(2)/abspc
nz(3) = -pc(3)/abspc
!
call axes(nz,nx,ny)
!
! Now some further variables.
!
s = 0.5d0 *(abspa + abspb + abspc)
sdiffsq = (1.0d0 - sc/s)**2
!
! Choose phi.
!
phi = 2.0d0 * pi * random(1)
!
! Choose theta.
! Use cos(theta) = 1.0D0 - SDIFFSQ * [exp(x*log(1+2/SDIFFSQ)) - 1]
!
x = random(1)
temp = log(1.0d0 + 2.0d0/sdiffsq)
oneminuscos = sdiffsq * expm1(temp*x)
costheta = 1.0d0 - oneminuscos
!
! Choose r.
!
deltasq = (sdiffsq + oneminuscos)/9.0d0
delta   = sqrt(deltasq)
a = 1.0d0 + a2to3*deltasq
b = 1.0d0 + a2to3*delta
n = 1.0d0/log(a/(b*deltasq))
x0 =  n * log(a/(b*delta))
!
x = random(1)
IF (x.GT.x0) THEN
  temp = expm1((x - x0)/n)
  temp = s*a2to3*deltasq*temp/(1.0d0 - delta*(temp + 1.0d0))
  r = s + temp
ELSE
  temp = expm1((x0 - x)/n)
  temp = s*a2to3*deltasq*temp/(1.0d0 - delta*(temp + 1.0d0))
  r = s - temp
END IF
!
! We now have r, theta, and phi so we find ell1(mu).
!
sintheta = sqrt((1.0d0 + costheta)*oneminuscos)
lx = r*sintheta*cos(phi)
ly = r*sintheta*sin(phi)
lz = r*costheta
ell1(1) = lx*nx(1) + ly*ny(1) + lz*nz(1)
ell1(2) = lx*nx(2) + ly*ny(2) + lz*nz(2)
ell1(3) = lx*nx(3) + ly*ny(3) + lz*nz(3)
!
RETURN
END subroutine choose2to3d
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function rho2to3d(pa,pb,ell1)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3),ell1(3)
! Out:
real(kind=dbl) :: rho2to3d
!
! Density function for points ell1 chosen by CHOOSE2TO3D(p_a,p_b,ell1,ok).
!
! 15 November 2000
! 21 March 2001
!
!
! The parameter A2TO3 needs to match between CHOOSE2TO3D and RHO2TO3D.
!
real(kind=dbl), parameter :: a2to3 = 3.0d0
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
real(kind=dbl) :: pc(3)
real(kind=dbl) :: abspa,abspb,abspc,r,sc
real(kind=dbl) :: nz(3),v(3)
real(kind=dbl) :: s,sdiffsq
real(kind=dbl) :: oneminuscos
real(kind=dbl) :: temp,paramsq,param,deltasq,delta,a,b,n,denom
real(kind=dbl) :: rhor
!
!-----------------------------------------------------------------------
! First we calculate the unit vectors n_z. The z-axis goes 
! along the direction of the largest of PA and - PB.
!
pc(1) = - pa(1) - pb(1)
pc(2) = - pa(2) - pb(2)
pc(3) = - pa(3) - pb(3)
!
abspa = sqrt(pa(1)**2 + pa(2)**2 + pa(3)**2)
abspb = sqrt(pb(1)**2 + pb(2)**2 + pb(3)**2)
abspc = sqrt(pc(1)**2 + pc(2)**2 + pc(3)**2)
r = sqrt(ell1(1)**2 + ell1(2)**2 + ell1(3)**2)
!
sc = abspc
nz(1) = -pc(1)/abspc
nz(2) = -pc(2)/abspc
nz(3) = -pc(3)/abspc
!
! Now some further variables.
!
s = 0.5d0 *(abspa + abspb + abspc)
sdiffsq = (1.0d0 - sc/s)**2
!
! Density for d^3ell1 -> dr d costheta d phi
!
rho2to3d = 1.0d0/r**2
!
! Density for phi.
!
rho2to3d = rho2to3d/(2.0d0 * pi)
!
! Density for theta.
! We construct 1 - cos(theta) as (Hatell1 - Nz)^2 /2 since
! that is more accurate than constructing cos(theta) and
! subtracting it from 1.0 if 1 - cos(theta) is small.
!
v(1) = ell1(1)/r - nz(1)
v(2) = ell1(2)/r - nz(2)
v(3) = ell1(3)/r - nz(3)
oneminuscos = 0.5d0*(v(1)**2 + v(2)**2 + v(3)**2)
n = 1.0d0/log(1.0d0 + 2.0d0/sdiffsq)
paramsq = oneminuscos + sdiffsq
rho2to3d = rho2to3d * n/paramsq
!
! Density for r.
!
deltasq = paramsq/9.0d0
param = sqrt(paramsq)
delta   = param/3.0d0
a = 1.0d0 + a2to3*deltasq
b = 1.0d0 + a2to3*delta
n = 1.0d0/log(a/(b*deltasq))
temp = abs(r/s - 1.0d0)
denom = s*(temp + a2to3*deltasq)*(temp + a2to3*delta)
rhor =  a2to3*n*delta*(1.0d0 - delta)/denom
rho2to3d = rho2to3d * rhor
!
RETURN
END function rho2to3d
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine choose2to3e(pa,pb,ell1,ok)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3)
! Out:
real(kind=dbl) :: ell1(3)
logical :: ok
!
! Generates a point ell1(mu) using a circular coordinate system
! based on the vectors p_A(mu) and p_B(mu). The points are concentrated
! near the circle |ell1| = (|p_A| + |p_B| + |p_A + p_B|)/2. There is
! a special concentration near theta = 0, the direction of the largest
! of -p_A - p_B.
! 
! 18 December 2000
! 21 March 2001
!
!
! The parameter A2TO3 needs to match between CHOOSE2TO3E and RHO2TO3E.
!
real(kind=dbl), parameter :: a2to3 = 3.0d0
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
! Function EXPM1(x)  gives exp(x) - 1.
! Function RANDOM(1) give a random number in the range 0<x<1.
!
real(kind=dbl) :: expm1,random
!
real(kind=dbl) :: pc(3)
real(kind=dbl) :: abspa,abspb,abspc,sc
real(kind=dbl) :: nz(3),ny(3),nx(3)
real(kind=dbl) :: s,sdiffsq
real(kind=dbl) :: x
real(kind=dbl) :: phi,oneminuscos,costheta,sintheta,r
real(kind=dbl) :: temp,deltasq,delta,a,b,n,x0
real(kind=dbl) :: lx,ly,lz
!
!-----------------------------------------------------------------------
!
ok = .true.
!
! First we calculate the unit vectors n_x, n_y, n_z used to define
! the orientation of the spherical coordinate system. The z-axis goes 
! along the direction of the largest of PA and - PB.
!
!
pc(1) = - pa(1) - pb(1)
pc(2) = - pa(2) - pb(2)
pc(3) = - pa(3) - pb(3)
!
abspa = sqrt(pa(1)**2 + pa(2)**2 + pa(3)**2)
abspb = sqrt(pb(1)**2 + pb(2)**2 + pb(3)**2)
abspc = sqrt(pc(1)**2 + pc(2)**2 + pc(3)**2)
!
IF (abspa.GT.abspb) THEN
  sc = abspa
  nz(1) = pa(1)/abspa
  nz(2) = pa(2)/abspa
  nz(3) = pa(3)/abspa
ELSE
  sc = abspb
  nz(1) = - pb(1)/abspb
  nz(2) = - pb(2)/abspb
  nz(3) = - pb(3)/abspb
END IF
!
call axes(nz,nx,ny)
!
! Now some further variables.
!
s = 0.5d0 *(abspa + abspb + abspc)
sdiffsq = (1.0d0 - sc/s)**2
!
! Choose phi.
!
phi = 2.0d0 * pi * random(1)
!
! Choose theta.
! Use cos(theta) = 1.0D0 - SDIFFSQ * [exp(x*log(1+2/SDIFFSQ)) - 1]
!
x = random(1)
temp = log(1.0d0 + 2.0d0/sdiffsq)
oneminuscos = sdiffsq * expm1(temp*x)
costheta = 1.0d0 - oneminuscos
!
! Choose r.
!
deltasq = (sdiffsq + oneminuscos)/9.0d0
delta   = sqrt(deltasq)
a = 1.0d0 + a2to3*deltasq
b = 1.0d0 + a2to3*delta
n = 1.0d0/log(a/(b*deltasq))
x0 =  n * log(a/(b*delta))
!
x = random(1)
IF (x.GT.x0) THEN
  temp = expm1((x - x0)/n)
  temp = s*a2to3*deltasq*temp/(1.0d0 - delta*(temp + 1.0d0))
  r = s + temp
ELSE
  temp = expm1((x0 - x)/n)
  temp = s*a2to3*deltasq*temp/(1.0d0 - delta*(temp + 1.0d0))
  r = s - temp
END IF
!
! We now have r, theta, and phi so we find ell1(mu).
!
sintheta = sqrt((1.0d0 + costheta)*oneminuscos)
lx = r*sintheta*cos(phi)
ly = r*sintheta*sin(phi)
lz = r*costheta
ell1(1) = lx*nx(1) + ly*ny(1) + lz*nz(1)
ell1(2) = lx*nx(2) + ly*ny(2) + lz*nz(2)
ell1(3) = lx*nx(3) + ly*ny(3) + lz*nz(3)
!
RETURN
END subroutine choose2to3e
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function rho2to3e(pa,pb,ell1)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3),ell1(3)
! Out:
real(kind=dbl) :: rho2to3e
!
! Density function for points ell1 chosen by CHOOSE2TO3E(p_a,p_b,ell1,ok).
!
! 15 November 2000
! 21 March 2001
!
!
! The parameter A2TO3 needs to match between CHOOSE2TO3E and RHO2TO3E.
!
real(kind=dbl), parameter :: a2to3 = 3.0d0
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
real(kind=dbl) :: pc(3)
real(kind=dbl) :: abspa,abspb,abspc,r,sc
real(kind=dbl) :: nz(3),v(3)
real(kind=dbl) :: s,sdiffsq
real(kind=dbl) :: oneminuscos
real(kind=dbl) :: temp,paramsq,param,deltasq,delta,a,b,n,denom
real(kind=dbl) :: rhor
!
!-----------------------------------------------------------------------
! First we calculate the unit vectors n_z. The z-axis goes 
! along the direction of the largest of PA and - PB.
!
pc(1) = - pa(1) - pb(1)
pc(2) = - pa(2) - pb(2)
pc(3) = - pa(3) - pb(3)
!
abspa = sqrt(pa(1)**2 + pa(2)**2 + pa(3)**2)
abspb = sqrt(pb(1)**2 + pb(2)**2 + pb(3)**2)
abspc = sqrt(pc(1)**2 + pc(2)**2 + pc(3)**2)
r = sqrt(ell1(1)**2 + ell1(2)**2 + ell1(3)**2)
!
IF (abspa.GT.abspb) THEN
  sc = abspa
  nz(1) = pa(1)/abspa
  nz(2) = pa(2)/abspa
  nz(3) = pa(3)/abspa
ELSE
  sc = abspb
  nz(1) = - pb(1)/abspb
  nz(2) = - pb(2)/abspb
  nz(3) = - pb(3)/abspb
END IF
!
! Now some further variables.
!
s = 0.5d0 *(abspa + abspb + abspc)
sdiffsq = (1.0d0 - sc/s)**2
!
! Density for d^3ell1 -> dr d costheta d phi
!
rho2to3e = 1.0d0/r**2
!
! Density for phi.
!
rho2to3e = rho2to3e/(2.0d0 * pi)
!
! Density for theta.
! We construct 1 - cos(theta) as (Hatell1 - Nz)^2 /2 since
! that is more accurate than constructing cos(theta) and
! subtracting it from 1.0 if 1 - cos(theta) is small.
!
v(1) = ell1(1)/r - nz(1)
v(2) = ell1(2)/r - nz(2)
v(3) = ell1(3)/r - nz(3)
oneminuscos = 0.5d0*(v(1)**2 + v(2)**2 + v(3)**2)
n = 1.0d0/log(1.0d0 + 2.0d0/sdiffsq)
paramsq = oneminuscos + sdiffsq
rho2to3e = rho2to3e * n/paramsq
!
! Density for r.
!
deltasq = paramsq/9.0d0
param = sqrt(paramsq)
delta   = param/3.0d0
a = 1.0d0 + a2to3*deltasq
b = 1.0d0 + a2to3*delta
n = 1.0d0/log(a/(b*deltasq))
temp = abs(r/s - 1.0d0)
denom = s*(temp + a2to3*deltasq)*(temp + a2to3*delta)
rhor =  a2to3*n*delta*(1.0d0 - delta)/denom
rho2to3e = rho2to3e * rhor
!
RETURN
END function rho2to3e
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine choose2to1a(pa,pb,ell1,ok)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3)
! Out:
real(kind=dbl) :: ell1(3)
logical :: ok
!
! Generates a point ell1(mu) for a self-energy graph that leads to a
! propagator with momemtum Pa(mu) that enters the final state.
! We want a map concentrating points rather collinearly with Pa(mu).
!
! 18 December 2000
! 18 March 2001
!
!
! The parameters B2TO1, C2TO1, A2TO1A and A2TO1B need to match 
! between CHOOSE2TO1A and RHO2TO1A.
!
real(kind=dbl), parameter :: b2to1 = 0.4d0
real(kind=dbl), parameter :: c2to1 = 0.4d0
real(kind=dbl), parameter :: a2to1a = 0.05d0
real(kind=dbl), parameter :: a2to1b = 0.25d0
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
integer :: mu
real(kind=dbl) :: pasq,abspa,pbsq,abspb,pcsq,abspc,scaleabc
real(kind=dbl) :: ea(3),eb(3),ec(3)
real(kind=dbl) :: random,xx,xchoice
real(kind=dbl) :: costheta,sintheta,phi,r
real(kind=dbl) :: x,ell1t
!
!---------------
!
ok = .true.
!
! We need the appropriate unit vectors for the map. We create a unit
! vector EA(mu) in the direction of PA(mu). We also calculate a
! scale factor SCALEABC.
!
pasq = 0.0d0
pbsq = 0.0d0
pcsq = 0.0d0
DO mu = 1,3
  pasq = pasq + pa(mu)**2
  pbsq = pbsq + pb(mu)**2
  pcsq = pcsq + (pa(mu) + pb(mu))**2
END DO
IF (pasq.LT.1.0d-30) THEN
  write(nout,*)'pasq too small in choose2to1.'
  write(nout,*)'pa ',pa
  write(nout,*)'ell1',ell1
  ok = .false.
END IF  
abspa = sqrt(pasq)
abspb = sqrt(pbsq)
abspc = sqrt(pbsq)
DO mu = 1,3
  ea(mu) = pa(mu)/abspa
END DO
scaleabc = (abspa + abspb + abspc)/3.0d0
!
call axes(ea,eb,ec)
!
! Step 2: Determine which of three methods to use to determine
! the next point.
!
xchoice = random(1)
!
IF (xchoice.LT.a2to1a) THEN
!
! We want a map concentrating points near ell1 = 0.
!
phi = 2*pi*random(1)
costheta = 2.0d0*random(1) - 1.0d0
sintheta = sqrt(1.0d0 - costheta**2)
r = abspa*( 1/random(1) - 1.0d0 )
DO mu = 1,3
  ell1(mu) = r * ( costheta*ea(mu) + sintheta &
            * ( cos(phi)*eb(mu) + sin(phi)*ec(mu) ) )
END DO
!
ELSE IF (xchoice.LT.2.0d0*a2to1a) THEN
!
! We want a map concentrating points near ell1 - pa = 0.
!
phi = 2*pi*random(1)
costheta = 2.0d0*random(1) - 1.0d0
sintheta = sqrt(1.0d0 - costheta**2)
r = abspa*( 1/random(1) - 1.0d0 )
DO mu = 1,3
  ell1(mu) = r * ( costheta*ea(mu) + sintheta &
            * ( cos(phi)*eb(mu) + sin(phi)*ec(mu) ) ) &
            + pa(mu)
END DO
!
ELSE IF (xchoice.LT.(2.0d0*a2to1a+a2to1b)) THEN
!
! We want a map concentrating points near ell1 = 0, BUT with 
! scale SCALEABC.
!
phi = 2*pi*random(1)
costheta = 2.0d0*random(1) - 1.0d0
sintheta = sqrt(1.0d0 - costheta**2)
r = scaleabc*( 1/random(1) - 1.0d0 )
DO mu = 1,3
  ell1(mu) = r * ( costheta*ea(mu) + sintheta &
            * ( cos(phi)*eb(mu) + sin(phi)*ec(mu) ) )
END DO
!
ELSE IF (xchoice.LT.2.0d0*(a2to1a+a2to1b)) THEN
!
! We want a map concentrating points near ell1 - pa = 0, BUT with 
! scale SCALEABC.
!
phi = 2*pi*random(1)
costheta = 2.0d0*random(1) - 1.0d0
sintheta = sqrt(1.0d0 - costheta**2)
r = scaleabc*( 1/random(1) - 1.0d0 )
DO mu = 1,3
  ell1(mu) = r * ( costheta*ea(mu) + sintheta &
            * ( cos(phi)*eb(mu) + sin(phi)*ec(mu) ) ) &
            + pa(mu)
END DO
!
ELSE
!
! We want a map concentrating points rather collinearly with PA(mu).
!
xx = random(1)
x = b2to1 * (xx - 0.5d0)/xx/(1.0d0 - xx) + 0.5d0
!
ell1t = c2to1 * abspa * sqrt( 1.0d0/random(1) - 1.0d0 )
!   
phi = 2.0d0 * pi * random(1)
!
! Step 3: Put this together using our unit vectors.
!
DO mu = 1,3
  ell1(mu) = x * pa(mu)  &
              + ell1t * ( cos(phi) * eb(mu) + sin(phi) * ec(mu) )
END DO
!
! End IF (XCHOICE.LT.F) ...
!
END IF
!
RETURN
END subroutine choose2to1a
!       
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function rho2to1a(pa,pb,ell1)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3),ell1(3)
! Out:
real(kind=dbl) :: rho2to1a
!
! Density in ell1(mu) for a self-energy graph that leads to a
! propagator with momemtum Pa(mu) that enters the final state.
! The map concentrats points rather collinearly with Pa(mu).
!
! 18 December 2000
! 18 March 2001
!
!
! The parameters B2TO1, C2TO1, A2TO1A and A2TO1B need to match 
! between CHOOSE2TO1A and RHO2TO1A.
!
real(kind=dbl), parameter :: b2to1 = 0.4d0
real(kind=dbl), parameter :: c2to1 = 0.4d0
real(kind=dbl), parameter :: a2to1a = 0.05d0
real(kind=dbl), parameter :: a2to1b = 0.25d0
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
integer :: mu
real(kind=dbl) :: pasq,abspa,pbsq,abspb,pcsq,abspc,scaleabc
real(kind=dbl) :: ea(3)
real(kind=dbl) :: x,ell1sq,absell1,ell1z,ell1tsq,ell1primesq,absell1prime
real(kind=dbl) :: k0sq,temp,dxdxx,j
real(kind=dbl) :: rho1,rho2,rho3,rho4,rho5
!
! Step 1:
! We need the appropriate unit vectors for the map. We create a unit
! vector EA(mu) in the direction of PA(mu). We also calculate a
! scale factor SCALEABC.
!
pasq = 0.0d0
pbsq = 0.0d0
pcsq = 0.0d0
DO mu = 1,3
  pasq = pasq + pa(mu)**2
  pbsq = pbsq + pb(mu)**2
  pcsq = pcsq + (pa(mu) + pb(mu))**2
END DO
IF (pasq.LT.1.0d-30) THEN
  write(nout,*)'pasq too small in rho2to1.'
  write(nout,*)'pa ',pa
  write(nout,*)'ell1',ell1
  stop
END IF  
abspa = sqrt(pasq)
abspb = sqrt(pbsq)
abspc = sqrt(pbsq)
DO mu = 1,3
  ea(mu) = pa(mu)/abspa
END DO
scaleabc = (abspa + abspb + abspc)/3.0d0
!
! We also need some other variables. We define ell1prime(mu) to be
! ell1(mu) - pa(mu).
!
ell1sq = 0.0d0
ell1z = 0.0d0
DO mu = 1,3
  ell1sq = ell1sq + ell1(mu)**2
  ell1z = ell1z + ell1(mu)*ea(mu)
END DO
ell1tsq = ell1sq - ell1z**2
absell1 = sqrt(ell1sq)
ell1primesq = ell1sq + pasq - 2.0d0*ell1z*abspa
absell1prime = sqrt(ell1primesq)
!
! Step 2: Construct each of the three densities.
!
! Density 1, for a concentration of points near ell1 = 0.
!
temp = 4.0d0*pi*ell1sq*(absell1 + abspa)**2
rho1 = abspa/temp
!
! Density 2, for a concentration of points near ell1 = 0.
!
temp = 4.0d0*pi*ell1primesq*(absell1prime + abspa)**2
rho2 = abspa/temp
!
! Density 3, for a concentration of points near ell1 = 0, BUT with 
! scale SCALEABC.
!
temp = 4.0d0*pi*ell1sq*(absell1 + scaleabc)**2
rho3 = scaleabc/temp
!
! Density 4, for a concentration of points near ell1 = 0, BUT with 
! scale SCALEABC.
!
temp = 4.0d0*pi*ell1primesq*(absell1prime + scaleabc)**2
rho4 = scaleabc/temp
!
! Density 5, for a concentration of points rather collinearly
! with PA(mu).
!
! Construct the momentum fraction X
!
x = ell1z/abspa
!
! Construct the jacobian and its inverse, the density.
!
k0sq = c2to1**2 * pasq
temp = sqrt((x-0.5d0)**2 + b2to1**2)
dxdxx = 2.0d0*(temp + b2to1)*temp/b2to1
j = abspa*dxdxx*pi/k0sq*(k0sq+ell1tsq)**2
rho5 = 1/j
!
! Assemble our five pieces with the right weights.
!
rho2to1a =  a2to1a*(rho1 + rho2)  &
         + a2to1b*(rho3 + rho4) &
         + (1.0d0 - 2.0d0*(a2to1a+a2to1b))*rho5
!
RETURN
END function rho2to1a
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine choose2to1b(pa,pb,ell1,ok)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3)
! Out:
real(kind=dbl) :: ell1(3)
logical :: ok
!
! Generates a point ell1(mu) using an elliptical coordinate system
! based on the vectors p_A(mu) and p_B(mu). The points are concentrated
! near ell1(mu) = parallel to P_A(mu).
! 
! 7 December 2002
! 8 May 2003
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
! Function RANDOM(1) give a random number in the range 0<x<1.
!
real(kind=dbl) :: random,x
!
real(kind=dbl) :: abspa,abspb
real(kind=dbl) :: cross(3)
real(kind=dbl) :: kappa,abscross
real(kind=dbl) :: nz(3),ny(3),nx(3)
real(kind=dbl) :: phi,aminus,aplus
real(kind=dbl) :: lz,lt,lx,ly
!
!-----------------------------------------------------------------------
!
ok = .true.
!
! First we calculate the unit vectors n_x, n_y, n_z used to define
! the orientation of the elliptical coordinate system. For later
! use, the variable |p_a| gets a special name, 2 kappa.
!
abspa = sqrt(pa(1)**2 + pa(2)**2 + pa(3)**2)
abspb = sqrt(pb(1)**2 + pb(2)**2 + pb(3)**2)
kappa = 0.5d0*abspa
!
cross(1) = pb(2)*pa(3) - pb(3)*pa(2)
cross(2) = pb(3)*pa(1) - pb(1)*pa(3)
cross(3) = pb(1)*pa(2) - pb(2)*pa(1) 
abscross = sqrt(cross(1)**2 + cross(2)**2 + cross(3)**2)
IF (abscross .LT. 1d-8 * abspa * abspb) THEN
  write(nout,*) 'abscross too small in choose2to1b.',abscross
  write(nout,*) 'pa is    ',pa
  write(nout,*) 'pb is    ',pb
  write(nout,*) 'cross is ',cross
  ok = .false.
END IF
nz(1) = pa(1)/abspa
nz(2) = pa(2)/abspa
nz(3) = pa(3)/abspa
ny(1) = cross(1)/abscross
ny(2) = cross(2)/abscross
ny(3) = cross(3)/abscross
nx(1) = ny(2)*nz(3) - ny(3)*nz(2)
nx(2) = ny(3)*nz(1) - ny(1)*nz(3)
nx(3) = ny(1)*nz(2) - ny(2)*nz(1)
!
! Choose phi.
!
x = random(1)
phi = pi * (2.0d0*x - 1.0d0)
!
! Choose A-.
!
x = random(1)
aminus = 2.0d0*x - 1.0d0
!
! Choose A+.
!
x = random(1)
aplus = x**2/(1.0d0 - x)**2 + 1.0d0
!
! We now have A+, A-, and phi so we find ell1(mu).
!
lz = kappa*(1.0d0 + aplus*aminus)
lt = kappa*sqrt((aplus**2 - 1.0d0)*(1.0d0 - aminus**2))
lx = lt*cos(phi)
ly = lt*sin(phi)
ell1(1) = lx*nx(1) + ly*ny(1) + lz*nz(1)
ell1(2) = lx*nx(2) + ly*ny(2) + lz*nz(2)
ell1(3) = lx*nx(3) + ly*ny(3) + lz*nz(3)
!
RETURN
END subroutine choose2to1b
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function rho2to1b(pa,pb,ell1)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: pa(3),pb(3),ell1(3)
! Out:
real(kind=dbl) :: rho2to1b
!
! Density function for points ell1 chosen by CHOOSE2TO1B(p_a,p_b,ell1,ok).
!
! 7 December 2002     
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
integer :: mu
real(kind=dbl) :: ell1sq,ell1primesq,pasq
real(kind=dbl) :: twokappa,kappa,absell1,absell1prime
real(kind=dbl) :: aplus,aminus
real(kind=dbl) :: temp,root
!
!-----------------------------------------------------------------------
! We start with the absolute values of combinations of vectors.
!
pasq = 0.0d0
ell1sq = 0.0d0
ell1primesq = 0.0d0
DO mu = 1,3
  pasq = pasq + pa(mu)**2
  ell1sq =  ell1sq + ell1(mu)**2
  ell1primesq =  ell1primesq  + (ell1(mu) - pa(mu))**2
END DO
twokappa = sqrt(pasq)
kappa = 0.5d0*twokappa
absell1 = sqrt(ell1sq)
absell1prime = sqrt(ell1primesq)
!
! Now A+ and A-.
!
aplus =  (absell1 + absell1prime)/twokappa
aminus = (absell1 - absell1prime)/twokappa
!
! RHO is the inverse of the product of several factors.
! Phi factor:
temp = 2.0d0*pi
! A- factor:
temp = temp*2.0d0
! A+ factor:
root = sqrt(aplus - 1.0d0)
temp = temp*2.0d0*root*(root + 1.0d0)**2
! Jacobian for k to A+,A-,phi:
temp = temp*kappa**3*(aplus**2 - aminus**2)
! Invert this:
rho2to1b = 1.0d0/temp
!
RETURN
END function rho2to1b
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine graphcountinit
use beowulf_helpers
implicit none
! Initialize how many graphs and how many maps for each:
integer :: numberofgraphs
integer :: numberofmaps(maxgraphs)   
common /graphcounts/ numberofgraphs,numberofmaps
!
! Rather than just list the numbers, we use getnewgraph() and findtypes().
! Then if we were to change the map types in findtypes(), the variables
! numberofmaps(graph) would adjust automatically.
!
! 15 June 2002
!
integer :: graphnumber,order
type graphstructure
  integer                          :: graphnumber
  integer                          :: order
  integer, dimension(0:3*size-1,2) :: vrtx
  integer, dimension(2*size,3)     :: prop
end type graphstructure
type(graphstructure) :: graph
logical :: graphfound
integer :: nmaps,qs(maxmaps,0:size),qsigns(maxmaps,0:size)
character(len=6) :: maptypes(maxmaps)
!
order = 2
graphnumber = 0
DO
call getnewgraph(order,graph,graphfound)
IF (.not.graphfound) EXIT
graphnumber = graphnumber + 1
call findtypes(graph,nmaps,qs,qsigns,maptypes)
numberofmaps(graph%graphnumber) = nmaps
END DO
order = 1
DO
call getnewgraph(order,graph,graphfound)
IF (.not.graphfound) EXIT
graphnumber = graphnumber + 1
call findtypes(graph,nmaps,qs,qsigns,maptypes)
numberofmaps(graph%graphnumber) = nmaps
END DO
numberofgraphs = graphnumber
END subroutine graphcountinit
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine getnewcut(graphnumber,cut,cutfound)
!
use beowulf_helpers
implicit none
! Input:
integer :: graphnumber
! Output:
type cutstructure
  integer                        :: cutnumber ! identifies the cut
  integer                        :: ncut      ! number of cut propagators
  integer, dimension(size+1)     :: cutindex  ! index of cut propagator
  integer, dimension(size+1)     :: cutsign   ! direction of cut propagator
  logical                        :: leftloop  !there is a loop to left
  logical                        :: rightloop !there is a loop to right
  integer                        :: ninloop   ! number of props in loop
  integer, dimension(size+1)     :: loopindex ! indices around loop
  integer, dimension(size+1)     :: loopsign  ! propagator directions
end type cutstructure
type (cutstructure) :: cut
logical :: cutfound
!
! This subroutine reads from the information recorded here
! as parameters and returns the information relevant for
! the current graph, specified by GRAPHNUMBER and the current cut,
! specified by CUTNUMBER.
!
! Latest revision: 12 June 2002.
!
integer, save :: cutnumber = 0
!
cutfound = .false.
cutnumber = cutnumber + 1
!
! Data from subroutine makecutinfo, 10 June 2002.
!
! Graphs of order  2
!
IF (graphnumber.EQ.  1 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =  -1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   6
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  2 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   6
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   7
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   4
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  3 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   6
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   7
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   4
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   5
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  4 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   5
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  4 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =  -1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   6
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   3
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =  -1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  4 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   6
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   3
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  5 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  6 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   2
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  5 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =  -1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   6
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   3
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  4 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   1
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   2
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  5 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   5
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  6 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   6
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   7
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   3
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   4
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   3
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   6
   cut%loopsign(  1 )  =  -1
   cut%loopindex(  2 ) =   7
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  4 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   6
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   7
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  5 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   5
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   3
   cut%cutsign(  4 )  =  -1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  7 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   6
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   7
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   4
   cut%loopindex(  1 ) =   3
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   8
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   4
   cut%loopsign(  4 )  =  -1
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   3
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   6
   cut%loopsign(  1 )  =  -1
   cut%loopindex(  2 ) =   7
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   8
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  4 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   4
   cut%loopindex(  1 ) =   1
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   7
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   2
   cut%loopsign(  4 )  =  -1
ELSE IF (cutnumber.EQ.  5 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  6 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   5
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  7 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   2
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  8 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   5
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   3
   cut%cutsign(  4 )  =  -1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  8 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   3
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   4
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   6
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   3
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   4
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   1
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   2
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  4 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   3
   cut%loopindex(  1 ) =   1
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   2
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  5 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  6 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   2
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  9 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   5
   cut%loopsign(  1 )  =  -1
   cut%loopindex(  2 ) =   6
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   6
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =  -1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   5
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   6
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  4 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   6
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   2
   cut%loopindex(  1 ) =   7
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   8
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  5 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   6
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   5
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  10 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   4
   cut%loopindex(  1 ) =   3
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   6
   cut%loopsign(  3 )  =   1
   cut%loopindex(  4 ) =   4
   cut%loopsign(  4 )  =  -1
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   6
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .false.
   cut%rightloop = .true.
   cut%ninloop =   4
   cut%loopindex(  1 ) =   3
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   7
   cut%loopsign(  2 )  =  -1
   cut%loopindex(  3 ) =   8
   cut%loopsign(  3 )  =   1
   cut%loopindex(  4 ) =   4
   cut%loopsign(  4 )  =  -1
ELSE IF (cutnumber.EQ.  3 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   4
   cut%loopindex(  1 ) =   1
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   5
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   7
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   2
   cut%loopsign(  4 )  =  -1
ELSE IF (cutnumber.EQ.  4 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   0
   cut%cutsign(  4 )  =   0
   cut%leftloop = .true.
   cut%rightloop = .false.
   cut%ninloop =   4
   cut%loopindex(  1 ) =   1
   cut%loopsign(  1 )  =   1
   cut%loopindex(  2 ) =   6
   cut%loopsign(  2 )  =   1
   cut%loopindex(  3 ) =   8
   cut%loopsign(  3 )  =  -1
   cut%loopindex(  4 ) =   2
   cut%loopsign(  4 )  =  -1
ELSE IF (cutnumber.EQ.  5 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  6 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   1
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  7 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   7
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   6
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   3
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   2
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  8 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   5
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   4
   cut%cutsign(  3 )  =  -1
   cut%cutindex(  4 ) =   2
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
ELSE IF (cutnumber.EQ.  9 ) THEN
   cutfound = .true.
   cut%ncut =  4
   cut%cutindex(  1 ) =   8
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   7
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   6
   cut%cutsign(  3 )  =   1
   cut%cutindex(  4 ) =   5
   cut%cutsign(  4 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
   cut%loopindex(  4 ) =   0
   cut%loopsign(  4 )  =   0
 END IF
!
! Graphs of order  1
!
ELSE IF (graphnumber.EQ.  11 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =   1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
 END IF
!
ELSE IF (graphnumber.EQ.  12 ) THEN
IF (cutnumber.EQ.  1 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =  -1
   cut%cutindex(  2 ) =   4
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   1
   cut%cutsign(  3 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
ELSE IF (cutnumber.EQ.  2 ) THEN
   cutfound = .true.
   cut%ncut =  3
   cut%cutindex(  1 ) =   5
   cut%cutsign(  1 )  =   1
   cut%cutindex(  2 ) =   3
   cut%cutsign(  2 )  =  -1
   cut%cutindex(  3 ) =   2
   cut%cutsign(  3 )  =   1
   cut%leftloop = .false.
   cut%rightloop = .false.
   cut%ninloop =   0
   cut%loopindex(  1 ) =   0
   cut%loopsign(  1 )  =   0
   cut%loopindex(  2 ) =   0
   cut%loopsign(  2 )  =   0
   cut%loopindex(  3 ) =   0
   cut%loopsign(  3 )  =   0
 END IF
 END IF
!
! Done with all of the IF statements. Were we successful?
!
IF (cutfound) THEN
  cut%cutnumber = cutnumber
ELSE
  cutnumber = 0
END IF
!
RETURN
END subroutine getnewcut
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine checknewcut(graphnumber,cut,k,absk,keepcut,graph9factor)
!
use beowulf_helpers
implicit none
!
! In:
! Information on the current cut.
integer :: graphnumber
type cutstructure
  integer                        :: cutnumber ! identifies the cut
  integer                        :: ncut      ! number of cut propagators
  integer, dimension(size+1)     :: cutindex  ! index of cut propagator
  integer, dimension(size+1)     :: cutsign   ! direction of cut propagator
  logical                        :: leftloop  ! there is a loop to left
  logical                        :: rightloop ! there is a loop to right
  integer                        :: ninloop   ! number of props in loop
  integer, dimension(size+1)     :: loopindex ! indices around loop
  integer, dimension(size+1)     :: loopsign  ! propagator directions
end type cutstructure
type (cutstructure) :: cut
real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1)
! Out:
logical :: keepcut
real(kind=dbl) :: graph9factor
!
! In the case of 'shower' mode, for certain cuts of certain graphs
! we keep only the wide angle splitting part, while other cuts are
! omitted entirely. This subroutine returns keepcut = .true. if the
! graph and cut are to be kept, and additionally calculates a factor
! to be included in the case of graph 9, namely the factor F_1 or
! F_2 that was introduced to break the symmetry between the 'top'
! and the 'bottom' of the graph. The cut
! IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN
! is equivalent to
! IF ( qbarsq.GT.(showercut*momentumsq) ) THEN
! where momentumsq is what we elsewhere call calqsq. Thus we are
! including the high virtuality part of parton --> parton + parton
! as a NLO contribution rather than as part of a shower. 
!
!  5 April 2003
!
real(kind=dbl) :: showercut
common /showercutinfo/ showercut
!
real(kind=dbl) :: energysq,energysq1,energysq2
real(kind=dbl) :: momentumsq,momentumsq1,momentumsq2
integer :: i,mu
!
graph9factor = 1.0d0
keepcut = .true.
IF (graphnumber.EQ.1) THEN
  keepcut = .false.
  IF (cut%ncut.EQ.4) THEN
    energysq = (absk(7) + absk(8))**2
    momentumsq = 0.0d0
    DO mu = 1,3
      momentumsq = momentumsq + (k(7,mu) + k(8,mu))**2
    END DO
    IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN
       keepcut = .true.
    END IF
  END IF
ELSE IF (graphnumber.EQ.4) THEN
  keepcut = .false.
  IF (cut%ncut.EQ.4) THEN
    energysq = (absk(7) + absk(8))**2
    momentumsq = 0.0d0
    DO mu = 1,3
      momentumsq = momentumsq + (k(7,mu) + k(8,mu))**2
    END DO
    IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN
       keepcut = .true.
    END IF
  END IF
ELSE IF (graphnumber.EQ.5) THEN
  keepcut = .false.
  IF (cut%ncut.EQ.4) THEN
    energysq = (absk(7) + absk(8))**2
    momentumsq = 0.0d0
    DO mu = 1,3
      momentumsq = momentumsq + (k(7,mu) + k(8,mu))**2
    END DO
    IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN
       keepcut = .true.
    END IF
  ELSE  ! ncut is 3 and we will use this cut if propagator 3 is cut.
    DO i = 1,cut%ncut
      IF (cut%cutindex(i).EQ.3) THEN
         keepcut = .true.
      END IF
    END DO
  END IF
ELSE IF (graphnumber.EQ.6) THEN
  keepcut = .false.
  IF (cut%ncut.EQ.4) THEN
    energysq = (absk(6) + absk(7))**2
    momentumsq = 0.0d0
    DO mu = 1,3
      momentumsq = momentumsq + (k(6,mu) + k(7,mu))**2
    END DO
    IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN
       keepcut = .true.
    END IF
  ELSE  ! ncut is 3 and we will use this cut if propagator 1 is cut.
    DO i = 1,cut%ncut
      IF (cut%cutindex(i).EQ.1) THEN
         keepcut = .true.
      END IF
    END DO
  END IF
ELSE IF (graphnumber.EQ.9) THEN
  keepcut = .false.
  ! This gets reversed only if the four propagators 5,6,7,8 are cut and
  ! one or both of 5-6 and 7-8 represents a wide angle splitting.
  IF (cut%ncut.EQ.4) THEN
    energysq1 = (absk(5) + absk(6))**2
    energysq2 = (absk(7) + absk(8))**2
    momentumsq1 = 0.0d0
    momentumsq2 = 0.0d0
    DO mu = 1,3
      momentumsq1 = momentumsq1 + (k(5,mu) + k(6,mu))**2
      momentumsq2 = momentumsq2 + (k(7,mu) + k(8,mu))**2
    END DO
    IF ( energysq1.GT.(1.0d0 + showercut)*momentumsq1 ) THEN
      keepcut = .true.
      IF ( energysq2.GT.(1.0d0 + showercut)*momentumsq2 ) THEN
        ! Both 5-6 and 7-8 are wide angle.
        graph9factor = 1.0d0
      ELSE
        ! Just 5-6 is wide angle.
        graph9factor = (energysq2 - momentumsq2)  &
            /(energysq1 - momentumsq1 + energysq2 - momentumsq2)
      END IF 
    ELSE IF ( energysq2.GT.(1.0d0 + showercut)*momentumsq2 ) THEN
      ! Just 7-8 is wide angle.
      keepcut = .true.
      graph9factor = (energysq1 - momentumsq1)  &
            /(energysq1 - momentumsq1 + energysq2 - momentumsq2) 
    END IF
  END IF
END IF ! (graphnumber.EQ.1) et cetera.
!
END subroutine checknewcut
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine deform(vrtx,loopindex,rts,leftloop,rightloop, &
                  ninloop,kinloop,newkinloop,jacdeform)
!
use beowulf_helpers
implicit none
! In:
integer :: vrtx(0:3*size-1,2)
integer :: loopindex(size+1)
real(kind=dbl) :: rts
logical :: leftloop,rightloop
integer :: ninloop
real(kind=dbl) :: kinloop(size+1,0:3)
! Out:
complex(kind=dbl) :: newkinloop(0:3)
complex(kind=dbl) :: jacdeform
!
! Contour deformation. Note that this simple algorithm should
! work for NINLOOP = 3 and for NINLOOP = 4 if the sum of the
! three 3-momenta exiting the loop vanishes.
!
! In variables:
! VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of
!              of propagator P. Specifies the supergraph.
! LOOPINDEX(NP) = Index P of NPth propagator around the loop.
! RTS = energy of final state.
! LEFTLOOP = T if there is a loop to the left of the cut.
! RIGHTLOOP = T if there is a loop to the right of the cut.
! NINLOOP = number of propagators in the loop.
! KINLOOP(J,MU) = momentum of Jth propagator in loop (real part)
! Out variables:
! NEWKINLOOP(MU) = added part of loop momentum.
!                  (purely imaginary for MU = 1,2,3)
! JACDEFORM = jacobian associated with contour deformation.
!
! Our notation is
!  vec Q(j) = vec L(j) - vec L(j+1) j = 1,...,Ninloop - 1
!      L(j) = |L(j)|                j = 1,...,Ninloop - 1
!      Q(j) = |Q(j)|                j = 1,...,Ninloop - 1
!
!  27 October 1992 first DEFORM
!   1 February 1998 latest version
!  23 February 1998 minor revision to rename deform variables
!
real(kind=dbl) :: deformalpha,deformbeta,deformgamma
common /deformscales/deformalpha,deformbeta,deformgamma
!
real(kind=dbl) :: s
integer :: sign
real(kind=dbl) :: l(size+1,3)
!
real(kind=dbl) :: q(size,3),qsq(size),qabs(size)
real(kind=dbl) :: lhat(size,3),lsq(size),labs(size)
real(kind=dbl) :: w(size,3),wsq(size),wabs(size)
real(kind=dbl) :: acrit2,acrit3,a2,a3
real(kind=dbl) :: delta
real(kind=dbl) :: m1(3,3),m2(3,3),m3(3,3)
real(kind=dbl) :: d1,d2,d3,dsq,graddsq(3)
real(kind=dbl) :: fraction,gradf(3)
real(kind=dbl) :: g2,g3,dg2da2,dg3da3
real(kind=dbl) :: c,dlncddsq
real(kind=dbl) :: termc,termf,termg2,termg3,termw2,termw3,terms
complex(kind=dbl) :: a(3,3)
!
logical :: connectstocurrent
real(kind=dbl) :: temp,temp1,temp2,temp3
integer :: j,mu,nu
!
! Calculate s.
!
s = rts**2
!
! Initialize with default value.
!
DO mu = 0,3
  newkinloop(mu) = (0.0d0,0.0d0)
END DO
!
jacdeform = (1.0d0,0.0d0)
!
! Check to see if we should actually do anything
!
IF (ninloop.LT.2) THEN
  RETURN
END IF
!
! Set
! SIGN = +1 and L(J,MU) = KINLOOP(J,MU) for a left loop,
! SIGN = -1 and L(J,MU) = KINLOOP(NINLOOP-J+1,MU) for a right loop.
!
IF (leftloop) THEN
  sign = + 1
  DO j = 1,ninloop
  DO mu = 1,3
    l(j,mu) = kinloop(j,mu)
  END DO
  END DO
ELSE IF (rightloop) THEN
  sign = - 1
  DO j = 1,ninloop
  DO mu = 1,3
    l(j,mu) = kinloop(ninloop-j+1,mu)
  END DO
  END DO
ELSE
  write(nout,*) 'Snafu in deform.'
  stop
END IF
!
! Two particles in the loop.
!
IF (ninloop.EQ.2) THEN
!
! Calculate Q(3,mu), |L(j)|^2, |Q(3)|^2, |L(j)|, |Q(3)|, hat L(j,mu).
!
qsq(3) = 0.0d0
DO mu = 1,3
  q(3,mu) = l(1,mu) - l(2,mu)
  qsq(3) = qsq(3) + q(3,mu)**2
END DO
qabs(3) = sqrt(qsq(3))
DO j = 1,2
  lsq(j) = 0.0d0
  DO mu = 1,3
    lsq(j) = lsq(j) + l(j,mu)**2
  END DO
  labs(j) = sqrt(lsq(j))
  DO mu = 1,3
    lhat(j,mu) = l(j,mu)/labs(j)
  END DO
END DO
!
! Calculate the vector W(3,mu), along with the corresponding
! normalization factor.
!
wsq(3) = 0.0d0
DO mu = 1,3
  w(3,mu) = lhat(1,mu) + lhat(2,mu)
  wsq(3) = wsq(3) + w(3,mu)**2
END DO
wabs(3) = sqrt(wsq(3))
!
! The size of the critical ellipse.
!
acrit3 = rts - 2.0d0*qabs(3)
!
! The size of the ellipse at point L.
!
a3 = labs(1) + labs(2) - qabs(3)
!
! Calculate the matrix d W(3,mu)/ d L(mu) = M3(mu,nu).
!
DO mu = 1,3
DO nu = 1,3
  temp = delta(mu,nu)
  temp1 = (temp - lhat(1,mu)*lhat(1,nu))/labs(1)
  temp2 = (temp - lhat(2,mu)*lhat(2,nu))/labs(2)
  m3(mu,nu) = temp1 + temp2
END DO
END DO
!
! The "distance" to the collinear line.
!
d3 = labs(1)*labs(2)*wabs(3)/qabs(3)
!
! The square of the distance its gradient.
!
dsq = d3**2
DO nu = 1,3
  temp = 0.0d0
  DO mu = 1,3
    temp = temp + w(3,mu)*m3(mu,nu)
  END DO
  temp = temp/wsq(3)
  temp = temp + l(1,nu)/lsq(1) + l(2,nu)/lsq(2)
  graddsq(nu) = 2.0d0*dsq*temp
END DO
!
! The function G3 and its derivative.
!
g3 = 1.0d0/(acrit3 + deformgamma*a3)
dg3da3 = - deformgamma/(acrit3 + deformgamma*a3)**2
!
! Calculate the function C(DSQ) and its derivative. Note that we change
! the sign of C in the case of a loop to the right of the cut.
!
! We effectively make DEFORMALPHA smaller by a factor 10 for the two
! point function so as to avoid crossing branch cut of SQRT
!
c = sign*deformalpha*dsq /(1.0d0 + deformbeta*dsq/qsq(3))
c = c * acrit3/rts
dlncddsq = 1.0d0/dsq/(1.0d0 + deformbeta*dsq/qsq(3))
!
! Calculate the imaginary part of the loop momentum L(mu).
!
DO mu = 1,3
  newkinloop(mu) = (0.0d0,-1.0d0) * c * g3 * w(3,mu)
END DO 
!
! Calculate the jacobian.
! First, we need the comlex matrix A(mu,nu), the derivative
! of ComplexL(mu) with respecdt to L(nu).
!
DO mu = 1,3
DO nu = 1,3
  termc  = g3*w(3,mu)*dlncddsq*graddsq(nu)
  termg3 = dg3da3*w(3,mu)*w(3,nu)
  termw3 = g3*m3(mu,nu)
  terms = termc + termg3 + termw3
  a(mu,nu) = delta(mu,nu) + (0.0d0,-1.0d0) * c * terms
END DO
END DO
!
! Finally, the jacobian is the determinant of A
!
jacdeform =  a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) &
           + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) &
           + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) 
!
! End of Ninloop = 2 calculation
!
! Three particles in the loop.
!
ELSE IF (ninloop.EQ.3) THEN
!
! First we need to determine if our loop connects to the current vertex.
!
  IF (leftloop) THEN
    IF ((vrtx(loopindex(1),1).EQ.1)) THEN
      connectstocurrent = .true.
    ELSE
      connectstocurrent = .false.
    END IF
  ELSE
    IF ((vrtx(loopindex(1),1).EQ.2)) THEN
      connectstocurrent = .true.
    ELSE
      connectstocurrent = .false.
    END IF
  END IF
IF (connectstocurrent) THEN
!
! Calculation for a three particle loop that connects to the current.
!
! Calculate Q(3,mu), |L(j)|^2, |Q(3)|^2, |L(j)|, |Q(3)|, hat L(j,mu).
!
qsq(3) = 0.0d0
DO mu = 1,3
  q(3,mu) = l(1,mu) - l(2,mu)
  qsq(3) = qsq(3) + q(3,mu)**2
END DO
qabs(3) = sqrt(qsq(3))
DO j = 1,2
  lsq(j) = 0.0d0
  DO mu = 1,3
    lsq(j) = lsq(j) + l(j,mu)**2
  END DO
  labs(j) = sqrt(lsq(j))
  DO mu = 1,3
    lhat(j,mu) = l(j,mu)/labs(j)
  END DO
END DO
!
! Calculate the vector W(3,mu), along with the corresponding
! normalization factor.
!
wsq(3) = 0.0d0
DO mu = 1,3
  w(3,mu) = lhat(1,mu) + lhat(2,mu)
  wsq(3) = wsq(3) + w(3,mu)**2
END DO
wabs(3) = sqrt(wsq(3))
!
! The size of the critical ellipse.
!
acrit3 = rts - 2.0d0*qabs(3)
!
! The size of the ellipse at point L.
!
a3 = labs(1) + labs(2) - qabs(3)
!
! Calculate the matrix d W(3,mu)/ d L(mu) = M3(mu,nu).
!
DO mu = 1,3
DO nu = 1,3
  temp = delta(mu,nu)
  temp1 = (temp - lhat(1,mu)*lhat(1,nu))/labs(1)
  temp2 = (temp - lhat(2,mu)*lhat(2,nu))/labs(2)
  m3(mu,nu) = temp1 + temp2
END DO
END DO
!
! The "distance" to the collinear line.
!
d3 = labs(1)*labs(2)*wabs(3)/qabs(3)
!
! The square of the distance its gradient.
!
dsq = d3**2
DO nu = 1,3
  temp = 0.0d0
  DO mu = 1,3
    temp = temp + w(3,mu)*m3(mu,nu)
  END DO
  temp = temp/wsq(3)
  temp = temp + l(1,nu)/lsq(1) + l(2,nu)/lsq(2)
  graddsq(nu) = 2.0d0*dsq*temp
END DO
!
! The function G3 and its derivative.
!
g3 = 1.0d0/(acrit3 + deformgamma*a3)
dg3da3 = - deformgamma/(acrit3 + deformgamma*a3)**2
!
! Calculate the function C(DSQ) and its derivative. Note that we change
! the sign of C in the case of a loop to the right of the cut.
!
c = sign*deformalpha*dsq /(1.0d0 + deformbeta*dsq/qsq(3))
dlncddsq = 1.0d0/dsq/(1.0d0 + deformbeta*dsq/qsq(3))
!
! Calculate the imaginary part of the loop momentum L(mu).
!
DO mu = 1,3
  newkinloop(mu) = (0.0d0,-1.0d0) * c * g3 * w(3,mu)
END DO 
!
! Calculate the jacobian.
! First, we need the comlex matrix A(mu,nu), the derivative
! of ComplexL(mu) with respecdt to L(nu).
!
DO mu = 1,3
DO nu = 1,3
  termc  = g3*w(3,mu)*dlncddsq*graddsq(nu)
  termg3 = dg3da3*w(3,mu)*w(3,nu)
  termw3 = g3*m3(mu,nu)
  terms = termc + termg3 + termw3
  a(mu,nu) = delta(mu,nu) + (0.0d0,-1.0d0) * c * terms
END DO
END DO
!
! Finally, the jacobian is the determinant of A
!
jacdeform =  a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) &
           + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) &
           + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) 
!
! End of calculation for Ninloop = 3 for a loop connecting to the
! current ( IF(CONNECTSTOCURRENT) ).
!
ELSE
!
! Calculation for a three particle loop that does not connect
! to the current.
!
! Calculate Q(j,mu), |L(j)|^2, |Q(j)|^2, |L(j)|, |Q(j)|, hat L(j,mu).
!
DO mu = 1,3
  q(1,mu) = l(2,mu) - l(3,mu)
  q(2,mu) = l(3,mu) - l(1,mu)
  q(3,mu) = l(1,mu) - l(2,mu)
END DO
DO j = 1,3
  lsq(j) = 0.0d0
  qsq(j) = 0.0d0
  DO mu = 1,3
    lsq(j) = lsq(j) + l(j,mu)**2
    qsq(j) = qsq(j) + q(j,mu)**2
  END DO
  qabs(j) = sqrt(qsq(j))
  labs(j) = sqrt(lsq(j))
  DO mu = 1,3
    lhat(j,mu) = l(j,mu)/labs(j)
  END DO
END DO
!
! The vectors W(j,mu) and their squares and their absolute values. 
!
DO mu = 1,3
  w(1,mu) = lhat(2,mu) + lhat(3,mu)
  w(2,mu) = lhat(3,mu) + lhat(1,mu)
  w(3,mu) = lhat(1,mu) + lhat(2,mu)
END DO
DO j = 1,3
  wsq(j) = 0.0d0
  DO mu = 1,3
    wsq(j) = wsq(j) + w(j,mu)**2
  END DO
  wabs(j) = sqrt(wsq(j))
END DO
!
! The size of the critical ellipses.
!
acrit2 = rts - 2.0d0*qabs(2)
acrit3 = rts - 2.0d0*qabs(3)
!
! The sizes of the ellipses at point L.
!
a2 = labs(3) + labs(1) - qabs(2)
a3 = labs(1) + labs(2) - qabs(3)
!
! Calculate the matrix d W(j,mu)/ d L(mu) = Mj(mu,nu).
!
DO mu = 1,3
DO nu = 1,3
  temp = delta(mu,nu)
  temp1 = (temp - lhat(1,mu)*lhat(1,nu))/labs(1)
  temp2 = (temp - lhat(2,mu)*lhat(2,nu))/labs(2)
  temp3 = (temp - lhat(3,mu)*lhat(3,nu))/labs(3)
  m1(mu,nu) = temp2 + temp3
  m2(mu,nu) = temp3 + temp1
  m3(mu,nu) = temp1 + temp2
END DO
END DO
!
! The "distances" to the collinear lines. In this case we do not need D2.
!
d1 = labs(2)*labs(3)*wabs(1)/qabs(1)
d3 = labs(1)*labs(2)*wabs(3)/qabs(3)
!
! The square of the smaller of D1 and D3 and its gradient.
!
IF (d1.LT.d3) THEN
!
! D1 is the smaller distance.
!
  dsq = d1**2
  DO nu = 1,3
    temp = 0.0d0
    DO mu = 1,3
      temp = temp + w(1,mu)*m1(mu,nu)
    END DO
    temp = temp/wsq(1)
    temp = temp + l(2,nu)/lsq(2) + l(3,nu)/lsq(3)
    graddsq(nu) = 2.0d0*dsq*temp
  END DO
!
ELSE
!
! D3 is the smaller distance.
!
  dsq = d3**2
  DO nu = 1,3
    temp = 0.0d0
    DO mu = 1,3
      temp = temp + w(3,mu)*m3(mu,nu)
    END DO
    temp = temp/wsq(3)
    temp = temp + l(1,nu)/lsq(1) + l(2,nu)/lsq(2)
    graddsq(nu) = 2.0d0*dsq*temp
  END DO
!
END IF
!
! The function G2 and its derivative.
!
g2 = 1.0d0/(acrit2 + deformgamma*a2)
dg2da2 = - deformgamma/(acrit2 + deformgamma*a2)**2
!
! Calculate the function C(DSQ) and its derivative. Note that we change
! the sign of C in the case of a loop to the right of the cut.
!
c = sign*deformalpha*dsq /(1.0d0 + 4.0d0*deformbeta*dsq/s)
dlncddsq = 1.0d0/dsq/(1.0d0 + 4.0d0*deformbeta*dsq/s)
!
! Calculate the imaginary part of the loop momentum L(mu).
!
DO mu = 1,3
  newkinloop(mu) = (0.0d0,-1.0d0) * c * g2 * w(2,mu)
END DO 
!
! Calculate the jacobian.
! First, we need the comlex matrix A(mu,nu), the derivative
! of ComplexL(mu) with respecdt to L(nu).
!
DO mu = 1,3
DO nu = 1,3
  termc  = g2*w(2,mu)*dlncddsq*graddsq(nu)
  termg2 = dg2da2*w(2,mu)*w(2,nu)
  termw2 = g2*m2(mu,nu)
  terms = termc + termg2 + termw2
  a(mu,nu) = delta(mu,nu) + (0.0d0,-1.0d0) * c * terms
END DO
END DO
!
! Finally, the jacobian is the determinant of A
!
jacdeform =  a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) &
           + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) &
           + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) )
!
! End of calculation for Ninloop = 3 for a loop not connecting to the
! current ( IF(CONNECTSTOCURRENT) ... ELSE ...).
!
END IF
!
! End of Ninloop = 3 calculation
!
! Four particles in the loop.------------
!
ELSE IF (ninloop.EQ.4) THEN
!
! Calculate Q(j,mu), |L(j)|^2, |Q(j)|^2, |L(j)|, |Q(j)|, hat L(j,mu).
!
DO mu = 1,3
  q(1,mu) = l(2,mu) - l(3,mu)
  q(2,mu) = l(3,mu) - l(1,mu)
  q(3,mu) = l(1,mu) - l(2,mu)
END DO
DO j = 1,3
  lsq(j) = 0.0d0
  qsq(j) = 0.0d0
  DO mu = 1,3
    lsq(j) = lsq(j) + l(j,mu)**2
    qsq(j) = qsq(j) + q(j,mu)**2
  END DO
  qabs(j) = sqrt(qsq(j))
  labs(j) = sqrt(lsq(j))
  DO mu = 1,3
    lhat(j,mu) = l(j,mu)/labs(j)
  END DO
END DO
!
! The vectors W(j,mu) and their squares and their absolute values. 
!
DO mu = 1,3
  w(1,mu) = lhat(2,mu) + lhat(3,mu)
  w(2,mu) = lhat(3,mu) + lhat(1,mu)
  w(3,mu) = lhat(1,mu) + lhat(2,mu)
END DO
DO j = 1,3
  wsq(j) = 0.0d0
  DO mu = 1,3
    wsq(j) = wsq(j) + w(j,mu)**2
  END DO
  wabs(j) = sqrt(wsq(j))
END DO
!
! The size of the critical ellipses.
!
acrit2 = rts - 2.0d0*qabs(2)
acrit3 = rts - 2.0d0*qabs(3)
!
! The sizes of the ellipses at point L.
!
a2 = labs(3) + labs(1) - qabs(2)
a3 = labs(1) + labs(2) - qabs(3)
!
! Calculate the matrix d W(j,mu)/ d L(mu) = Mj(mu,nu).
!
DO mu = 1,3
DO nu = 1,3
  temp = delta(mu,nu)
  temp1 = (temp - lhat(1,mu)*lhat(1,nu))/labs(1)
  temp2 = (temp - lhat(2,mu)*lhat(2,nu))/labs(2)
  temp3 = (temp - lhat(3,mu)*lhat(3,nu))/labs(3)
  m1(mu,nu) = temp2 + temp3
  m2(mu,nu) = temp3 + temp1
  m3(mu,nu) = temp1 + temp2
END DO
END DO
!
! The "distances" to the collinear lines.
!
d1 = labs(2)*labs(3)*wabs(1)/qabs(1)
d2 = labs(3)*labs(1)*wabs(2)/qabs(2)
d3 = labs(1)*labs(2)*wabs(3)/qabs(3)
!
! The square of the smallest distance its gradient.
!
IF ((d1.LT.d2).AND.(d1.LT.d3)) THEN
!
! D1 is the smallest distance
!
  dsq = d1**2
  DO nu = 1,3
    temp = 0.0d0
    DO mu = 1,3
      temp = temp + w(1,mu)*m1(mu,nu)
    END DO
    temp = temp/wsq(1)
    temp = temp + l(2,nu)/lsq(2) + l(3,nu)/lsq(3)
    graddsq(nu) = 2.0d0*dsq*temp
  END DO
!
ELSE IF (d2.LT.d3) THEN
!
! D2 is the smallest distance
!
  dsq = d2**2
  DO nu = 1,3
    temp = 0.0d0
    DO mu = 1,3
      temp = temp + w(2,mu)*m2(mu,nu)
    END DO
    temp = temp/wsq(2)
    temp = temp + l(3,nu)/lsq(3) + l(1,nu)/lsq(1)
    graddsq(nu) = 2.0d0*dsq*temp
  END DO
!
ELSE
!
! D3 is the smallest distance.
!
  dsq = d3**2
  DO nu = 1,3
    temp = 0.0d0
    DO mu = 1,3
      temp = temp + w(3,mu)*m3(mu,nu)
    END DO
    temp = temp/wsq(3)
    temp = temp + l(1,nu)/lsq(1) + l(2,nu)/lsq(2)
    graddsq(nu) = 2.0d0*dsq*temp
  END DO
!
END IF
!
! The mixing fraction FRACTION and its gradient.
!
fraction = lsq(3) /(lsq(2) + lsq(3))
DO nu = 1,3
  temp = lsq(2)*l(3,nu) - lsq(3)*l(2,nu)
  gradf(nu) = 2.0d0*temp/(lsq(2) + lsq(3))**2
END DO
!
! The functions G2 and G3 and their derivatives.
!
g2 = 1.0d0/(acrit2 + deformgamma*a2)
g3 = 1.0d0/(acrit3 + deformgamma*a3)
dg2da2 = - deformgamma/(acrit2 + deformgamma*a2)**2
dg3da3 = - deformgamma/(acrit3 + deformgamma*a3)**2
!
! Calculate the function C(DSQ) and its derivative. Note that we change
! the sign of C in the case of a loop to the right of the cut.
!
c = sign*deformalpha*dsq /(1.0d0 + 4.0d0*deformbeta*dsq/s)
dlncddsq = 1.0d0/dsq/(1.0d0 + 4.0d0*deformbeta*dsq/s)
!
! Calculate the imaginary part of the loop momentum L(mu).
!
DO mu = 1,3
  newkinloop(mu) = (0.0d0,-1.0d0) * c  &
         * (fraction*g2*w(2,mu) + (1.0d0 - fraction)*g3*w(3,mu))
END DO 
!
! Calculate the jacobian.
! First, we need the comlex matrix A(mu,nu), the derivative
! of ComplexL(mu) with respecdt to L(nu).
!
DO mu = 1,3
DO nu = 1,3
  termc  = fraction*g2*w(2,mu) + (1.0d0 - fraction)*g3*w(3,mu)
  termc  = termc * dlncddsq*graddsq(nu)
  termf  = ( g2*w(2,mu) - g3*w(3,mu) )*gradf(nu)
  termg2 =      fraction     *dg2da2*w(2,mu)*w(2,nu)
  termg3 = (1.0d0 - fraction)*dg3da3*w(3,mu)*w(3,nu)
  termw2 =      fraction     *g2*m2(mu,nu)
  termw3 = (1.0d0 - fraction)*g3*m3(mu,nu)
  terms = termc + termf + termg2 + termg3 + termw2 + termw3
  a(mu,nu) = delta(mu,nu) + (0.0d0,-1.0d0) * c * terms
END DO
END DO
!
! Finally, the jacobian is the determinant of A
!
jacdeform =  a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) &
           + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) &
           + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) )
!
! End of Ninloop = 4 calculation
!
ELSE
  write(nout,*) 'Not programed for ninloop > 4 yet.'
  stop
END IF
!
RETURN
END subroutine deform
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function delta(mu,nu)
!
use beowulf_helpers
implicit none
! In:
integer :: mu,nu
! Out:
real(kind=dbl) :: delta
!
! Kroneker delta.
!
IF (mu.EQ.nu) THEN
  delta = 1.0d0
ELSE
  delta = 0.0d0
END IF
RETURN
END function delta
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function smear(rts)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: rts
! Out:
real(kind=dbl) :: smear
!
! A smearing function that may do a good job of optimizing
! the integration accuracy.  It satisfies
!
!   Int_0^\infty dE SMEAR(E)  = 1
!
! We take
!
!  SMEAR(E) = (N-1)!/[M! (N-M-2)!] (A E_0 )**(N-M-1)
!             * E**M / [E + A * E_0]**N
!
! where E_0 = ENERGYSCALE = 1.
!                   
!
real(kind=dbl) :: smearfctr
integer :: lowpwr,highpwr
common /smearparms/ smearfctr,lowpwr,highpwr
!
real(kind=dbl), parameter :: energyscale = 1.0d0
!
real(kind=dbl) :: factorial
!
smear = factorial(highpwr-1) &
      /(factorial(lowpwr) * factorial(highpwr-lowpwr-2))
smear = smear * (smearfctr * energyscale)**(highpwr-lowpwr-1)
smear = smear * rts**lowpwr  &
               /( rts + smearfctr*energyscale )**highpwr
RETURN
END function smear
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!                     Feynman integrand in Feynman gauge
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function feynmanf(graphnumber,kc,cut,mumsbar,flag)
!
use beowulf_helpers
implicit none
! In:
integer :: graphnumber
complex(kind=dbl) :: kc(0:3*size-1,0:3)
logical :: cut(3*size-1)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: feynmanf
!
! Feynman integrand function for graph GRAPHNUMBER
! with complex momenta KC and cut specified by CUT.
! Early version: 17 July 1994.
! This version written by Mathematica code of 4 January 2002 on
! 4 Jan 2002.
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
complex(kind=dbl), parameter :: gn(0:3) = &
         (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/)
!
complex(kind=dbl) :: complexsqrt
integer :: mu,nu,tau
complex(kind=dbl) :: x(256)
complex(kind=dbl) :: k1(0:3),k2(0:3),k3(0:3),k4(0:3)
complex(kind=dbl) :: k5(0:3),k6(0:3),k7(0:3),k8(0:3)
complex(kind=dbl) :: e1,e2,e3,e4,e5,e6,e7,e8
complex(kind=dbl) :: k11,k22,k33,k44,k55,k66,k77,k88
complex(kind=dbl) :: tk11,tk22,tk33,tk44,tk55,tk66,tk77,tk88
complex(kind=dbl) :: prefactor
character(len=13) :: kind2pt2
complex(kind=dbl) :: k2pt2(0:5,0:3)
logical :: cut2pt2(1:5)
character(len=9) :: kind2pt
complex(kind=dbl) :: k2pt(0:2,0:3)
logical :: cut2pt(0:3)
character(len=7) :: kind3pt
complex(kind=dbl) :: k3pt(3,0:3)
logical :: cut3pt(3)
!
complex(kind=dbl) :: a1qda4q,a1qik6a4qik7,a1qik7a4qik6,ea1qk3q47
complex(kind=dbl) :: ea1qzv4qk6k7,ea2qk3q67,ea3qk1q26,ea4qk1q86
complex(kind=dbl) :: ea4qzv1qk6k7,ea7ak1ik2k3k4,ea7ak1k2,ea7ak1k3,ea7ak1k4
complex(kind=dbl) :: ea7ak2ik1k3k4,ea7ak2k3,ea7ak2k4,ea7ak3ik1k2k4,ea7ak3k4
complex(kind=dbl) :: ea7ak4ik1k2k3,ea8ak1ik2k3k4,ea8ak1k2,ea8ak1k3,ea8ak1k4
complex(kind=dbl) :: ea8ak2ik1k3k4,ea8ak2k3,ea8ak2k4,ea8ak3ik1k2k4,ea8ak3k4
complex(kind=dbl) :: ea8ak4ik1k2k3,g7awk1k2,g7awk1k3,g7awk2k4,g7awk3k4,k1k2
complex(kind=dbl) :: k1k3,k1k4,k1q24,k1q26,k1q36,k1q84,k1q86,k1qqnb45
complex(kind=dbl) :: k1qqnb46,k1qqng45,k1qqng46,k1qqnq45,k1qqnq46,k1qqog57
complex(kind=dbl) :: k1qqog75,k1qqoq57,k1qqoq64,k2k3,k2k4,k2q24,k2q36,k2q84
complex(kind=dbl) :: k2q86,k3k4,k3q47,k3q67,k6k7,q15q47,q24q86,q36q84
complex(kind=dbl) :: traceg7a,tracev1q,tracev2q,tracev3q,tracev4q,tracev7a
complex(kind=dbl) :: tracev8a,v1qdv4q,v1qik6v4qik7,v1qik7v4qik6,v1qwk3q47
complex(kind=dbl) :: v1qwq47k3,v2qwk3q67,v2qwq67k3,v3qwk1q26,v3qwq26k1
complex(kind=dbl) :: v4qwk1q86,v4qwq86k1,v7awk1k2,v7awk1k3,v7awk1k4
complex(kind=dbl) :: v7awk2k1,v7awk2k3,v7awk2k4,v7awk3k1,v7awk3k2,v7awk3k4
complex(kind=dbl) :: v7awk4k1,v7awk4k2,v7awk4k3,v8awk1k2,v8awk1k3,v8awk1k4
complex(kind=dbl) :: v8awk2k1,v8awk2k3,v8awk2k4,v8awk3k1,v8awk3k2,v8awk3k4
complex(kind=dbl) :: v8awk4k1,v8awk4k2,v8awk4k3,a1qik6(0:3),a1qik7(0:3)
complex(kind=dbl) :: a4qik6(0:3),a4qik7(0:3),a7ak1i(0:3),a7ak2i(0:3)
complex(kind=dbl) :: a7ak3i(0:3),a7ak4i(0:3),a8ak1i(0:3),a8ak2i(0:3)
complex(kind=dbl) :: a8ak3i(0:3),a8ak4i(0:3),q15(0:3),q24(0:3),q26(0:3)
complex(kind=dbl) :: q36(0:3),q47(0:3),q67(0:3),q84(0:3),q86(0:3)
complex(kind=dbl) :: qqnb45(0:3),qqnb46(0:3),qqng45(0:3),qqng46(0:3)
complex(kind=dbl) :: qqnq45(0:3),qqnq46(0:3),qqog57(0:3),qqog75(0:3)
complex(kind=dbl) :: qqoq57(0:3),qqoq64(0:3),v1qik6(0:3),v1qik7(0:3)
complex(kind=dbl) :: v4qik6(0:3),v4qik7(0:3),a1q(0:3,0:3),a1qzv4q(0:3,0:3)
complex(kind=dbl) :: a2q(0:3,0:3),a3q(0:3,0:3),a4q(0:3,0:3)
complex(kind=dbl) :: a4qzv1q(0:3,0:3),a7a(0:3,0:3),a8a(0:3,0:3)
complex(kind=dbl) :: g7a(0:3,0:3),v1q(0:3,0:3),v2q(0:3,0:3),v3q(0:3,0:3)
complex(kind=dbl) :: v4q(0:3,0:3),v7a(0:3,0:3),v8a(0:3,0:3)
!
DO mu = 0,3
  k1(mu) = kc(1,mu)
  k2(mu) = kc(2,mu)
  k3(mu) = kc(3,mu)
  k4(mu) = kc(4,mu)
  k5(mu) = kc(5,mu)
  k6(mu) = kc(6,mu)
  k7(mu) = kc(7,mu)
  k8(mu) = kc(8,mu)
END DO
feynmanf = 0.0d0
!
!------
!
IF (graphnumber .EQ. 1) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k4(mu)
  k2pt2(2,mu) = k5(mu)
  k2pt2(3,mu) = -k6(mu)
  k2pt2(4,mu) = k7(mu)
  k2pt2(5,mu) = k8(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(5)
cut2pt2(3) = cut(6)
cut2pt2(4) = cut(7)
cut2pt2(5) = cut(8)
kind2pt2 = 'nested /gqqgq'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnb46)
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k4(mu)
  k2pt2(2,mu) = k5(mu)
  k2pt2(3,mu) = -k6(mu)
  k2pt2(4,mu) = k7(mu)
  k2pt2(5,mu) = k8(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(5)
cut2pt2(3) = cut(6)
cut2pt2(4) = cut(7)
cut2pt2(5) = cut(8)
kind2pt2 = 'nested /qgggg'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqng46)
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k4(mu)
  k2pt2(2,mu) = k5(mu)
  k2pt2(3,mu) = -k6(mu)
  k2pt2(4,mu) = k8(mu)
  k2pt2(5,mu) = k7(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(5)
cut2pt2(3) = cut(6)
cut2pt2(4) = cut(8)
cut2pt2(5) = cut(7)
kind2pt2 = 'nested /qggqq'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnq46)
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = -k4(mu)
  k2pt2(2,mu) = k6(mu)
  k2pt2(3,mu) = -k5(mu)
  k2pt2(4,mu) = -k7(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(6)
cut2pt2(3) = cut(5)
cut2pt2(4) = cut(7)
cut2pt2(5) = cut(8)
kind2pt2 = 'nested /gqqgq'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnb45)
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = -k4(mu)
  k2pt2(2,mu) = k6(mu)
  k2pt2(3,mu) = -k5(mu)
  k2pt2(4,mu) = -k7(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(6)
cut2pt2(3) = cut(5)
cut2pt2(4) = cut(7)
cut2pt2(5) = cut(8)
kind2pt2 = 'nested /qggqq'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnq45)
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = -k4(mu)
  k2pt2(2,mu) = k6(mu)
  k2pt2(3,mu) = -k5(mu)
  k2pt2(4,mu) = -k8(mu)
  k2pt2(5,mu) = -k7(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(6)
cut2pt2(3) = cut(5)
cut2pt2(4) = cut(8)
cut2pt2(5) = cut(7)
kind2pt2 = 'nested /qgggg'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqng45)
k1qqnb45 = 0.0d0
k1qqnb46 = 0.0d0
k1qqng45 = 0.0d0
k1qqng46 = 0.0d0
k1qqnq45 = 0.0d0
k1qqnq46 = 0.0d0
DO mu = 0,3
  k1qqnb45 = k1qqnb45 + k1(mu)*qqnb45(mu)*metric(mu)
  k1qqnb46 = k1qqnb46 + k1(mu)*qqnb46(mu)*metric(mu)
  k1qqng45 = k1qqng45 + k1(mu)*qqng45(mu)*metric(mu)
  k1qqng46 = k1qqng46 + k1(mu)*qqng46(mu)*metric(mu)
  k1qqnq45 = k1qqnq45 + k1(mu)*qqnq45(mu)*metric(mu)
  k1qqnq46 = k1qqnq46 + k1(mu)*qqnq46(mu)*metric(mu)
END DO
feynmanf = -8*(k1qqnb45 - k1qqnb46 + k1qqng45 - k1qqng46 &
 + k1qqnq45 - k1qqnq46)*nc
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 2) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt(0,mu) = k2(mu)
  k2pt(1,mu) = k4(mu)
  k2pt(2,mu) = k5(mu)
END DO
cut2pt(0) = cut(2)
cut2pt(1) = cut(4)
cut2pt(2) = cut(5)
cut2pt(3) = cut(8)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q24)
DO mu = 0,3
  k2pt(0,mu) = k3(mu)
  k2pt(1,mu) = k6(mu)
  k2pt(2,mu) = k7(mu)
END DO
cut2pt(0) = cut(3)
cut2pt(1) = cut(6)
cut2pt(2) = cut(7)
cut2pt(3) = cut(8)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q36)
DO mu = 0,3
  k2pt(0,mu) = -k8(mu)
  k2pt(1,mu) = -k4(mu)
  k2pt(2,mu) = -k5(mu)
END DO
cut2pt(0) = cut(8)
cut2pt(1) = cut(4)
cut2pt(2) = cut(5)
cut2pt(3) = cut(2)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q84)
DO mu = 0,3
  k2pt(0,mu) = k8(mu)
  k2pt(1,mu) = -k6(mu)
  k2pt(2,mu) = -k7(mu)
END DO
cut2pt(0) = cut(8)
cut2pt(1) = cut(6)
cut2pt(2) = cut(7)
cut2pt(3) = cut(3)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q86)
k1k2 = 0.0d0
k1q24 = 0.0d0
k1q36 = 0.0d0
k1q84 = 0.0d0
k1q86 = 0.0d0
k2q24 = 0.0d0
k2q36 = 0.0d0
k2q84 = 0.0d0
k2q86 = 0.0d0
q24q86 = 0.0d0
q36q84 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1q24 = k1q24 + k1(mu)*q24(mu)*metric(mu)
  k1q36 = k1q36 + k1(mu)*q36(mu)*metric(mu)
  k1q84 = k1q84 + k1(mu)*q84(mu)*metric(mu)
  k1q86 = k1q86 + k1(mu)*q86(mu)*metric(mu)
  k2q24 = k2q24 + k2(mu)*q24(mu)*metric(mu)
  k2q36 = k2q36 + k2(mu)*q36(mu)*metric(mu)
  k2q84 = k2q84 + k2(mu)*q84(mu)*metric(mu)
  k2q86 = k2q86 + k2(mu)*q86(mu)*metric(mu)
  q24q86 = q24q86 + q24(mu)*q86(mu)*metric(mu)
  q36q84 = q36q84 + q36(mu)*q84(mu)*metric(mu)
END DO
feynmanf = 8*nc*(k1q86*k2q24 + k1q84*k2q36 + k1q36*k2q84 &
 + k1q24*k2q86 - k1k2*q24q86 - k1k2*q36q84)
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 3) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k5(mu)
  k2pt2(2,mu) = k4(mu)
  k2pt2(3,mu) = -k7(mu)
  k2pt2(4,mu) = -k6(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(5)
cut2pt2(2) = cut(4)
cut2pt2(3) = cut(7)
cut2pt2(4) = cut(6)
cut2pt2(5) = cut(8)
kind2pt2 = 'overlap/qggqq'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqoq57)
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k5(mu)
  k2pt2(2,mu) = k4(mu)
  k2pt2(3,mu) = -k7(mu)
  k2pt2(4,mu) = -k6(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(5)
cut2pt2(2) = cut(4)
cut2pt2(3) = cut(7)
cut2pt2(4) = cut(6)
cut2pt2(5) = cut(8)
kind2pt2 = 'overlap/qgqgg'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqog57)
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = k6(mu)
  k2pt2(2,mu) = k7(mu)
  k2pt2(3,mu) = -k4(mu)
  k2pt2(4,mu) = -k5(mu)
  k2pt2(5,mu) = k8(mu)
END DO
cut2pt2(1) = cut(6)
cut2pt2(2) = cut(7)
cut2pt2(3) = cut(4)
cut2pt2(4) = cut(5)
cut2pt2(5) = cut(8)
kind2pt2 = 'overlap/qggqq'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqoq64)
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = k7(mu)
  k2pt2(2,mu) = k6(mu)
  k2pt2(3,mu) = -k5(mu)
  k2pt2(4,mu) = -k4(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(7)
cut2pt2(2) = cut(6)
cut2pt2(3) = cut(5)
cut2pt2(4) = cut(4)
cut2pt2(5) = cut(8)
kind2pt2 = 'overlap/qgqgg'
call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqog75)
k1qqog57 = 0.0d0
k1qqog75 = 0.0d0
k1qqoq57 = 0.0d0
k1qqoq64 = 0.0d0
DO mu = 0,3
  k1qqog57 = k1qqog57 + k1(mu)*qqog57(mu)*metric(mu)
  k1qqog75 = k1qqog75 + k1(mu)*qqog75(mu)*metric(mu)
  k1qqoq57 = k1qqoq57 + k1(mu)*qqoq57(mu)*metric(mu)
  k1qqoq64 = k1qqoq64 + k1(mu)*qqoq64(mu)*metric(mu)
END DO
feynmanf = 8*(k1qqog57 - k1qqog75 + k1qqoq57 - k1qqoq64)*nc
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 4) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
DO mu = 0,3
  k2pt(0,mu) = k5(mu)
  k2pt(1,mu) = k7(mu)
  k2pt(2,mu) = k8(mu)
END DO
cut2pt(0) = cut(5)
cut2pt(1) = cut(7)
cut2pt(2) = cut(8)
cut2pt(3) = cut(6)
kind2pt = 'bothloops'
call twopointgf(kind2pt,k2pt,cut2pt,mumsbar,flag,g7a)
traceg7a = 0.0d0
DO mu = 0,3
  traceg7a = traceg7a + g7a(mu,mu)*metric(mu)
END DO
g7awk1k2 = 0.0d0
g7awk1k3 = 0.0d0
g7awk2k4 = 0.0d0
g7awk3k4 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  g7awk1k2 = g7awk1k2 &
         + g7a(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  g7awk1k3 = g7awk1k3 &
         + g7a(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  g7awk2k4 = g7awk2k4 &
         + g7a(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  g7awk3k4 = g7awk3k4 &
         + g7a(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
END DO
END DO
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
feynmanf = -8*cf*nc*(2*g7awk3k4*k1k2 - 2*g7awk2k4*k1k3 &
 - 2*g7awk1k3*k2k4 + 2*g7awk1k2*k3k4 + k1k4*k2k3*traceg7a &
 + k1k3*k2k4*traceg7a - k1k2*k3k4*traceg7a)
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 5) THEN
!
prefactor = 1.0d0
e3 = k3(0)
tk33 = 0.0d0
DO mu = 1,3
  tk33 = tk33 - k3(mu)**2
END DO
k33 = e3**2 + tk33
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
DO mu = 0,3
  k3pt(1,mu) = -k1(mu)
  k3pt(2,mu) = k2(mu)
  k3pt(3,mu) = -k5(mu)
END DO
cut3pt(1) = cut(1)
cut3pt(2) = cut(2)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v1q,a1q)
DO mu = 0,3
  k3pt(1,mu) = -k2(mu)
  k3pt(2,mu) = k1(mu)
  k3pt(3,mu) = k5(mu)
END DO
cut3pt(1) = cut(2)
cut3pt(2) = cut(1)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v2q,a2q)
DO mu = 0,3
  k2pt(0,mu) = k4(mu)
  k2pt(1,mu) = k7(mu)
  k2pt(2,mu) = k8(mu)
END DO
cut2pt(0) = cut(4)
cut2pt(1) = cut(7)
cut2pt(2) = cut(8)
cut2pt(3) = cut(6)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q47)
DO mu = 0,3
  k2pt(0,mu) = k6(mu)
  k2pt(1,mu) = -k7(mu)
  k2pt(2,mu) = -k8(mu)
END DO
cut2pt(0) = cut(6)
cut2pt(1) = cut(7)
cut2pt(2) = cut(8)
cut2pt(3) = cut(4)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q67)
tracev1q = 0.0d0
tracev2q = 0.0d0
DO mu = 0,3
  tracev1q = tracev1q + v1q(mu,mu)*metric(mu)
  tracev2q = tracev2q + v2q(mu,mu)*metric(mu)
END DO
v1qwk3q47 = 0.0d0
v1qwq47k3 = 0.0d0
v2qwk3q67 = 0.0d0
v2qwq67k3 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v1qwk3q47 = v1qwk3q47 &
         + v1q(mu,nu)*k3(mu)*q47(nu)*metric(mu)*metric(nu)
  v1qwq47k3 = v1qwq47k3 &
         + v1q(mu,nu)*q47(mu)*k3(nu)*metric(mu)*metric(nu)
  v2qwk3q67 = v2qwk3q67 &
         + v2q(mu,nu)*k3(mu)*q67(nu)*metric(mu)*metric(nu)
  v2qwq67k3 = v2qwq67k3 &
         + v2q(mu,nu)*q67(mu)*k3(nu)*metric(mu)*metric(nu)
END DO
END DO
k3q47 = 0.0d0
k3q67 = 0.0d0
DO mu = 0,3
  k3q47 = k3q47 + k3(mu)*q47(mu)*metric(mu)
  k3q67 = k3q67 + k3(mu)*q67(mu)*metric(mu)
END DO
call epsilont2(a1q,k3,q47,ea1qk3q47)
call epsilont2(a2q,k3,q67,ea2qk3q67)
feynmanf = -4*nc*(ea1qk3q47 + ea2qk3q67 - k3q47*tracev1q &
 + k3q67*tracev2q + v1qwk3q47 + v1qwq47k3 - v2qwk3q67 - v2qwq67k3)
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 6) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k3pt(1,mu) = -k3(mu)
  k3pt(2,mu) = k4(mu)
  k3pt(3,mu) = -k5(mu)
END DO
cut3pt(1) = cut(3)
cut3pt(2) = cut(4)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v3q,a3q)
DO mu = 0,3
  k3pt(1,mu) = -k4(mu)
  k3pt(2,mu) = k3(mu)
  k3pt(3,mu) = k5(mu)
END DO
cut3pt(1) = cut(4)
cut3pt(2) = cut(3)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q)
DO mu = 0,3
  k2pt(0,mu) = k2(mu)
  k2pt(1,mu) = k6(mu)
  k2pt(2,mu) = k7(mu)
END DO
cut2pt(0) = cut(2)
cut2pt(1) = cut(6)
cut2pt(2) = cut(7)
cut2pt(3) = cut(8)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q26)
DO mu = 0,3
  k2pt(0,mu) = k8(mu)
  k2pt(1,mu) = -k6(mu)
  k2pt(2,mu) = -k7(mu)
END DO
cut2pt(0) = cut(8)
cut2pt(1) = cut(6)
cut2pt(2) = cut(7)
cut2pt(3) = cut(2)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q86)
tracev3q = 0.0d0
tracev4q = 0.0d0
DO mu = 0,3
  tracev3q = tracev3q + v3q(mu,mu)*metric(mu)
  tracev4q = tracev4q + v4q(mu,mu)*metric(mu)
END DO
v3qwk1q26 = 0.0d0
v3qwq26k1 = 0.0d0
v4qwk1q86 = 0.0d0
v4qwq86k1 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v3qwk1q26 = v3qwk1q26 &
         + v3q(mu,nu)*k1(mu)*q26(nu)*metric(mu)*metric(nu)
  v3qwq26k1 = v3qwq26k1 &
         + v3q(mu,nu)*q26(mu)*k1(nu)*metric(mu)*metric(nu)
  v4qwk1q86 = v4qwk1q86 &
         + v4q(mu,nu)*k1(mu)*q86(nu)*metric(mu)*metric(nu)
  v4qwq86k1 = v4qwq86k1 &
         + v4q(mu,nu)*q86(mu)*k1(nu)*metric(mu)*metric(nu)
END DO
END DO
k1q26 = 0.0d0
k1q86 = 0.0d0
DO mu = 0,3
  k1q26 = k1q26 + k1(mu)*q26(mu)*metric(mu)
  k1q86 = k1q86 + k1(mu)*q86(mu)*metric(mu)
END DO
call epsilont2(a3q,k1,q26,ea3qk1q26)
call epsilont2(a4q,k1,q86,ea4qk1q86)
feynmanf = -4*nc*(ea3qk1q26 + ea4qk1q86 - k1q26*tracev3q &
 + k1q86*tracev4q + v3qwk1q26 + v3qwq26k1 - v4qwk1q86 - v4qwq86k1)
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 7) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
DO mu = 0,3
  k3pt(1,mu) = k7(mu)
  k3pt(2,mu) = -k8(mu)
  k3pt(3,mu) = -k6(mu)
END DO
cut3pt(1) = cut(7)
cut3pt(2) = cut(8)
cut3pt(3) = cut(6)
kind3pt = 'qqg/all'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v7a,a7a)
DO mu = 0,3
  k3pt(1,mu) = k8(mu)
  k3pt(2,mu) = -k7(mu)
  k3pt(3,mu) = k6(mu)
END DO
cut3pt(1) = cut(8)
cut3pt(2) = cut(7)
cut3pt(3) = cut(6)
kind3pt = 'qqg/all'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v8a,a8a)
tracev7a = 0.0d0
tracev8a = 0.0d0
DO mu = 0,3
  tracev7a = tracev7a + v7a(mu,mu)*metric(mu)
  tracev8a = tracev8a + v8a(mu,mu)*metric(mu)
END DO
v7awk1k2 = 0.0d0
v7awk1k3 = 0.0d0
v7awk1k4 = 0.0d0
v7awk2k1 = 0.0d0
v7awk2k3 = 0.0d0
v7awk2k4 = 0.0d0
v7awk3k1 = 0.0d0
v7awk3k2 = 0.0d0
v7awk3k4 = 0.0d0
v7awk4k1 = 0.0d0
v7awk4k2 = 0.0d0
v7awk4k3 = 0.0d0
v8awk1k2 = 0.0d0
v8awk1k3 = 0.0d0
v8awk1k4 = 0.0d0
v8awk2k1 = 0.0d0
v8awk2k3 = 0.0d0
v8awk2k4 = 0.0d0
v8awk3k1 = 0.0d0
v8awk3k2 = 0.0d0
v8awk3k4 = 0.0d0
v8awk4k1 = 0.0d0
v8awk4k2 = 0.0d0
v8awk4k3 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v7awk1k2 = v7awk1k2 &
         + v7a(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  v7awk1k3 = v7awk1k3 &
         + v7a(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  v7awk1k4 = v7awk1k4 &
         + v7a(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu)
  v7awk2k1 = v7awk2k1 &
         + v7a(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu)
  v7awk2k3 = v7awk2k3 &
         + v7a(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu)
  v7awk2k4 = v7awk2k4 &
         + v7a(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  v7awk3k1 = v7awk3k1 &
         + v7a(mu,nu)*k3(mu)*k1(nu)*metric(mu)*metric(nu)
  v7awk3k2 = v7awk3k2 &
         + v7a(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu)
  v7awk3k4 = v7awk3k4 &
         + v7a(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
  v7awk4k1 = v7awk4k1 &
         + v7a(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu)
  v7awk4k2 = v7awk4k2 &
         + v7a(mu,nu)*k4(mu)*k2(nu)*metric(mu)*metric(nu)
  v7awk4k3 = v7awk4k3 &
         + v7a(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu)
  v8awk1k2 = v8awk1k2 &
         + v8a(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  v8awk1k3 = v8awk1k3 &
         + v8a(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  v8awk1k4 = v8awk1k4 &
         + v8a(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu)
  v8awk2k1 = v8awk2k1 &
         + v8a(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu)
  v8awk2k3 = v8awk2k3 &
         + v8a(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu)
  v8awk2k4 = v8awk2k4 &
         + v8a(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  v8awk3k1 = v8awk3k1 &
         + v8a(mu,nu)*k3(mu)*k1(nu)*metric(mu)*metric(nu)
  v8awk3k2 = v8awk3k2 &
         + v8a(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu)
  v8awk3k4 = v8awk3k4 &
         + v8a(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
  v8awk4k1 = v8awk4k1 &
         + v8a(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu)
  v8awk4k2 = v8awk4k2 &
         + v8a(mu,nu)*k4(mu)*k2(nu)*metric(mu)*metric(nu)
  v8awk4k3 = v8awk4k3 &
         + v8a(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  a7ak1i(mu) = 0.0d0
  a7ak2i(mu) = 0.0d0
  a7ak3i(mu) = 0.0d0
  a7ak4i(mu) = 0.0d0
  a8ak1i(mu) = 0.0d0
  a8ak2i(mu) = 0.0d0
  a8ak3i(mu) = 0.0d0
  a8ak4i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a7ak1i(mu) = a7ak1i(mu) + a7a(nu,mu)*k1(nu)*metric(nu)
  a7ak2i(mu) = a7ak2i(mu) + a7a(nu,mu)*k2(nu)*metric(nu)
  a7ak3i(mu) = a7ak3i(mu) + a7a(nu,mu)*k3(nu)*metric(nu)
  a7ak4i(mu) = a7ak4i(mu) + a7a(nu,mu)*k4(nu)*metric(nu)
  a8ak1i(mu) = a8ak1i(mu) + a8a(nu,mu)*k1(nu)*metric(nu)
  a8ak2i(mu) = a8ak2i(mu) + a8a(nu,mu)*k2(nu)*metric(nu)
  a8ak3i(mu) = a8ak3i(mu) + a8a(nu,mu)*k3(nu)*metric(nu)
  a8ak4i(mu) = a8ak4i(mu) + a8a(nu,mu)*k4(nu)*metric(nu)
END DO
END DO
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
call epsilont2(a7a,k1,k2,ea7ak1k2)
call epsilont2(a7a,k1,k3,ea7ak1k3)
call epsilont2(a7a,k1,k4,ea7ak1k4)
call epsilont2(a7a,k2,k3,ea7ak2k3)
call epsilont2(a7a,k2,k4,ea7ak2k4)
call epsilont2(a7a,k3,k4,ea7ak3k4)
call epsilont2(a8a,k1,k2,ea8ak1k2)
call epsilont2(a8a,k1,k3,ea8ak1k3)
call epsilont2(a8a,k1,k4,ea8ak1k4)
call epsilont2(a8a,k2,k3,ea8ak2k3)
call epsilont2(a8a,k2,k4,ea8ak2k4)
call epsilont2(a8a,k3,k4,ea8ak3k4)
call epsilon4(a7ak1i,k2,k3,k4,ea7ak1ik2k3k4)
call epsilon4(a7ak2i,k1,k3,k4,ea7ak2ik1k3k4)
call epsilon4(a7ak3i,k1,k2,k4,ea7ak3ik1k2k4)
call epsilon4(a7ak4i,k1,k2,k3,ea7ak4ik1k2k3)
call epsilon4(a8ak1i,k2,k3,k4,ea8ak1ik2k3k4)
call epsilon4(a8ak2i,k1,k3,k4,ea8ak2ik1k3k4)
call epsilon4(a8ak3i,k1,k2,k4,ea8ak3ik1k2k4)
call epsilon4(a8ak4i,k1,k2,k3,ea8ak4ik1k2k3)
x(1) = ea7ak1ik2k3k4 + ea7ak2ik1k3k4 - ea7ak3ik1k2k4 &
 - ea7ak4ik1k2k3 - ea8ak1ik2k3k4 - ea8ak2ik1k3k4 + ea8ak3ik1k2k4 &
 + ea8ak4ik1k2k3
x(2) = ea7ak3k4 - ea8ak3k4 + v7awk3k4 + v7awk4k3 + v8awk3k4 &
 + v8awk4k3
x(3) = x(1) + k1k2*x(2)
x(4) = -ea7ak2k4 + ea8ak2k4 - v7awk2k4 - v7awk4k2 - v8awk2k4 &
 - v8awk4k2
x(5) = x(3) + k1k3*x(4)
x(6) = -ea7ak2k3 + ea8ak2k3 - v7awk2k3 + v7awk3k2 - v8awk2k3 &
 + v8awk3k2
x(7) = x(5) + k1k4*x(6)
x(8) = -ea7ak1k4 + ea8ak1k4 + k1k4*(tracev7a + tracev8a) &
 + v7awk1k4 - v7awk4k1 + v8awk1k4 - v8awk4k1
x(9) = x(7) + k2k3*x(8)
x(10) = ea7ak1k3 - ea8ak1k3 + k1k3*(tracev7a + tracev8a) &
 - v7awk1k3 - v7awk3k1 - v8awk1k3 - v8awk3k1
x(11) = x(9) + k2k4*x(10)
x(12) = -ea7ak1k2 + ea8ak1k2 + k1k2*(-tracev7a - tracev8a) &
 + v7awk1k2 + v7awk2k1 + v8awk1k2 + v8awk2k1
x(13) = x(11) + k3k4*x(12)
feynmanf = 8*cf*nc*x(13)
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 8) THEN
!
prefactor = 1.0d0
e6 = k6(0)
tk66 = 0.0d0
e7 = k7(0)
tk77 = 0.0d0
DO mu = 1,3
  tk66 = tk66 - k6(mu)**2
  tk77 = tk77 - k7(mu)**2
END DO
k66 = e6**2 + tk66
k77 = e7**2 + tk77
IF (cut(6)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk66)
ELSE
  prefactor = prefactor/k66
END IF
IF (cut(7)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk77)
ELSE
  prefactor = prefactor/k77
END IF
DO mu = 0,3
  k3pt(1,mu) = -k1(mu)
  k3pt(2,mu) = k2(mu)
  k3pt(3,mu) = -k5(mu)
END DO
cut3pt(1) = cut(1)
cut3pt(2) = cut(2)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v1q,a1q)
DO mu = 0,3
  k3pt(1,mu) = -k4(mu)
  k3pt(2,mu) = k3(mu)
  k3pt(3,mu) = k8(mu)
END DO
cut3pt(1) = cut(4)
cut3pt(2) = cut(3)
cut3pt(3) = cut(8)
kind3pt = 'qqp/qqg'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q)
a1qda4q = 0.0d0
v1qdv4q = 0.0d0
DO mu = 0,3
DO nu = 0,3
  a1qda4q = a1qda4q + a1q(mu,nu)*a4q(mu,nu)*metric(mu)*metric(nu)
  v1qdv4q = v1qdv4q + v1q(mu,nu)*v4q(mu,nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  a1qik6(mu) = 0.0d0
  a1qik7(mu) = 0.0d0
  a4qik6(mu) = 0.0d0
  a4qik7(mu) = 0.0d0
  v1qik6(mu) = 0.0d0
  v1qik7(mu) = 0.0d0
  v4qik6(mu) = 0.0d0
  v4qik7(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a1qik6(mu) = a1qik6(mu) + a1q(mu,nu)*k6(nu)*metric(nu)
  a1qik7(mu) = a1qik7(mu) + a1q(mu,nu)*k7(nu)*metric(nu)
  a4qik6(mu) = a4qik6(mu) + a4q(mu,nu)*k6(nu)*metric(nu)
  a4qik7(mu) = a4qik7(mu) + a4q(mu,nu)*k7(nu)*metric(nu)
  v1qik6(mu) = v1qik6(mu) + v1q(mu,nu)*k6(nu)*metric(nu)
  v1qik7(mu) = v1qik7(mu) + v1q(mu,nu)*k7(nu)*metric(nu)
  v4qik6(mu) = v4qik6(mu) + v4q(mu,nu)*k6(nu)*metric(nu)
  v4qik7(mu) = v4qik7(mu) + v4q(mu,nu)*k7(nu)*metric(nu)
END DO
END DO
DO mu = 0,3
DO nu = 0,3
  a1qzv4q(mu,nu) = 0.0d0
  a4qzv1q(mu,nu) = 0.0d0
END DO
END DO
DO mu = 0,3
DO nu = 0,3
DO tau = 0,3
  a1qzv4q(mu,nu) = a1qzv4q(mu,nu) &
         + a1q(tau,mu)*v4q(tau,nu)*metric(tau)
  a4qzv1q(mu,nu) = a4qzv1q(mu,nu) &
         + a4q(tau,mu)*v1q(tau,nu)*metric(tau)
END DO
END DO
END DO
a1qik6a4qik7 = 0.0d0
a1qik7a4qik6 = 0.0d0
k6k7 = 0.0d0
v1qik6v4qik7 = 0.0d0
v1qik7v4qik6 = 0.0d0
DO mu = 0,3
  a1qik6a4qik7 = a1qik6a4qik7 + a1qik6(mu)*a4qik7(mu)*metric(mu)
  a1qik7a4qik6 = a1qik7a4qik6 + a1qik7(mu)*a4qik6(mu)*metric(mu)
  k6k7 = k6k7 + k6(mu)*k7(mu)*metric(mu)
  v1qik6v4qik7 = v1qik6v4qik7 + v1qik6(mu)*v4qik7(mu)*metric(mu)
  v1qik7v4qik6 = v1qik7v4qik6 + v1qik7(mu)*v4qik6(mu)*metric(mu)
END DO
call epsilont2(a1qzv4q,k6,k7,ea1qzv4qk6k7)
call epsilont2(a4qzv1q,k6,k7,ea4qzv1qk6k7)
feynmanf = 4*nc*(a1qik6a4qik7 + a1qik7a4qik6 + ea1qzv4qk6k7 &
 - ea4qzv1qk6k7 - a1qda4q*k6k7 + k6k7*v1qdv4q - v1qik6v4qik7 &
 - v1qik7v4qik6)
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 9) THEN
!
prefactor = 1.0d0
DO mu = 0,3
  k2pt(0,mu) = k1(mu)
  k2pt(1,mu) = k5(mu)
  k2pt(2,mu) = k6(mu)
END DO
cut2pt(0) = cut(1)
cut2pt(1) = cut(5)
cut2pt(2) = cut(6)
cut2pt(3) = cut(3)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q15)
DO mu = 0,3
  k2pt(0,mu) = k4(mu)
  k2pt(1,mu) = -k7(mu)
  k2pt(2,mu) = -k8(mu)
END DO
cut2pt(0) = cut(4)
cut2pt(1) = cut(7)
cut2pt(2) = cut(8)
cut2pt(3) = cut(2)
call twopointqf(k2pt,cut2pt,mumsbar,flag,q47)
q15q47 = 0.0d0
DO mu = 0,3
  q15q47 = q15q47 + q15(mu)*q47(mu)*metric(mu)
END DO
feynmanf = -8*nc*q15q47
feynmanf = feynmanf*prefactor
!
ELSE IF (graphnumber .EQ. 10) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
e6 = k6(0)
tk66 = 0.0d0
e7 = k7(0)
tk77 = 0.0d0
e8 = k8(0)
tk88 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
  tk66 = tk66 - k6(mu)**2
  tk77 = tk77 - k7(mu)**2
  tk88 = tk88 - k8(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
k66 = e6**2 + tk66
k77 = e7**2 + tk77
k88 = e8**2 + tk88
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
IF (cut(6)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk66)
ELSE
  prefactor = prefactor/k66
END IF
IF (cut(7)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk77)
ELSE
  prefactor = prefactor/k77
END IF
IF (cut(8)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk88)
ELSE
  prefactor = prefactor/k88
END IF
k1k3 = 0.0d0
k2k4 = 0.0d0
k6k7 = 0.0d0
DO mu = 0,3
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k6k7 = k6k7 + k6(mu)*k7(mu)*metric(mu)
END DO
feynmanf = -64*cf*k1k3*k2k4*k6k7
feynmanf = feynmanf*prefactor
!
END IF
!
RETURN
END function feynmanf
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!                Feynman integrand in Feynman gauge, Born level
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function feynman0f(graphnumber,kin,cut)
!
use beowulf_helpers
implicit none
! In:
integer :: graphnumber
real(kind=dbl) :: kin(0:3*size-1,0:3)
logical :: cut(3*size-1)
! Out:
complex(kind=dbl) :: feynman0f
!
! Feynman integrand function for graph GRAPHNUMBER
! with momenta KIN and cut specified by CUT. This subroutine
! is for the Born graphs in Feynman gauge.
! Early version: 17 July 1994.
! This version written by Mathematica code of 7 February 2002 on
! 8 Feb 2002.
! Input variables mumsbar and flag removed 1 September 2002, DES.
! Calculation changed to real, 3 January 2003.
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
real(kind=dbl), parameter :: gn(0:3) = (/1.0d0,0.0d0,0.0d0,0.0d0/)
!
integer :: mu
real(kind=dbl) :: k1(0:3),k2(0:3),k3(0:3),k4(0:3),k5(0:3)
real(kind=dbl) :: e1,e2,e3,e4,e5
real(kind=dbl) :: k11,k22,k33,k44,k55
real(kind=dbl) :: tk11,tk22,tk33,tk44,tk55
real(kind=dbl) :: prefactor
real(kind=dbl) :: result
!
real(kind=dbl) :: k1k2,k1k4,k1k5,k2k3,k2k5
!
DO mu = 0,3
  k1(mu) = kin(1,mu)
  k2(mu) = kin(2,mu)
  k3(mu) = kin(3,mu)
  k4(mu) = kin(4,mu)
  k5(mu) = kin(5,mu)
END DO
result = 0.0d0
!
!------
!
IF (graphnumber .EQ. 11) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
k1k2 = 0.0d0
k1k5 = 0.0d0
k2k5 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k5 = k1k5 + k1(mu)*k5(mu)*metric(mu)
  k2k5 = k2k5 + k2(mu)*k5(mu)*metric(mu)
END DO
result = -32*cf*(k1k5*k22 - 2*k1k2*k2k5)*nc
result = result*prefactor
!
ELSE IF (graphnumber .EQ. 12) THEN
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
k1k4 = 0.0d0
k2k3 = 0.0d0
DO mu = 0,3
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
END DO
result = 32*cf*k1k4*k2k3*nc
result = result*prefactor
!
END IF
!
feynman0f = result
RETURN
END function feynman0f
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!               Vertex and propagator functions in Feynman gauge
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine twopointgf(kind2pt,k2pt,cut2pt,mumsbar,flag,out)
!
use beowulf_helpers
implicit none
! In:
character(len=9) :: kind2pt
complex(kind=dbl) :: k2pt(0:2,0:3)
logical :: cut2pt(0:3)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: out(0:3,0:3)
!
! Calculates the one loop gluon two-point function, including the
! adjoining propagators *in Feynman gauge* with the modification that
! it is multiplied by a Coulomb gauge projection matrix on the left
! and on the right.
!
! kind2pt:
!   GLUONLOOP gluon self-energy with a gluon (including ghost) loop
!   QUARKLOOP gluon self-energy with a quark loop
!   BOTHLOOPS the sum of these
!
! k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part)
! k2pt(1,mu): 1st momentum in loop (kplus for the space part)
! k2pt(2,mu): 2nd momentum in loop (kminus for the space part)
!
! cut2pt(0): whether incoming line is cut
! cut2pt(1): whether 1st internal line is cut
! cut2pt(2): whether 2nd internal line is cut
! cut2pt(3): whether outgoing line is cut
!
! mumsbar is the MSbar renormalization scale.
!
! The result is the two  point function out(mu,nu) with a certain
! normalization. Specifically, for the cut gluon self-energy
! graph, out(mu,nu) is {\cal M}_g^{\mu\nu}
! divided by (\alpha_s/(4\pi)) * 1/(1+\Delta) and divided
! by 2\omega_+ * 2\omega_- *\bar q^2. The factor by which we divide
! consists of
! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
!   one (2\pi)^{-3} for each loop that is factored out of each
!   graph in our program.
! * (d\vec l)/(d\bar q^2 dx d\phi)
!    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
! * 4 \pi {\cal Q} \bar q^2 included in the relation between
!   {\cal I}[real] and {\cal M}_g^{\mu\nu}
!
! In the case of the virtual gluon self-energy graphs
! with an adjacent propagator cut, out(mu,nu) is {\cal W}_g^{\mu\nu}
! divided by the same factors.
!
! 16 December 2001
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
integer :: mu,nu
complex(kind=dbl) :: complexsqrt
complex(kind=dbl) :: kplus(1:3),kminus(1:3),ell(1:3),q(1:3)
complex(kind=dbl) :: calqsq, omegaplussq,omegaminussq
complex(kind=dbl) :: calq,omegaplus,omegaminus,q0
complex(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq
complex(kind=dbl) :: ellt(1:3)
complex(kind=dbl) :: elltsq,onem2x1mx
complex(kind=dbl) :: temp
complex(kind=dbl) :: bareprop(1:3,1:3)
complex(kind=dbl) :: ntt,nll,nee,nel
complex(kind=dbl) :: prefactor
complex(kind=dbl) :: termtt,termll
complex(kind=dbl) :: at0
complex(kind=dbl) :: ntt0
complex(kind=dbl) :: net0
complex(kind=dbl) :: utt,net
! 
! Some auxilliary variables, including
! CALQ = {\cal Q}
! OMEGAPLUS = \omega_+
! OMEGAMINUS = \omega_-
! DELTAP1 = \Delta + 1
! TWOXM1 = 2 x - 1
! X1MX = x (1-x)
! ELLT(mu) = l_T^\mu
! ELLTSQ = (\vec l_T)^2
! Q(mu) = the incoming *three*-momentum
! Q0 = the incoming energy
!
DO mu = 1,3
  kplus(mu) = k2pt(1,mu)
  kminus(mu) = k2pt(2,mu)
  ell(mu) = (kplus(mu) - kminus(mu))/2.0d0
  q(mu) = k2pt(0,mu)
END DO
q0 = k2pt(0,0)
calqsq = 0.0d0
omegaplussq = 0.0d0
omegaminussq = 0.0d0
DO mu = 1,3
  calqsq = calqsq + q(mu)**2
  omegaplussq = omegaplussq + kplus(mu)**2
  omegaminussq = omegaminussq + kminus(mu)**2
END DO
calq = complexsqrt(calqsq)
omegaplus  = complexsqrt(omegaplussq)
omegaminus = complexsqrt(omegaminussq)
deltap1 = (omegaplus + omegaminus)/calq
delta = deltap1 - 1.0d0
twoxm1 = (omegaplus - omegaminus)/calq
x1mx = (1.0d0 - twoxm1**2)/4.0d0
qbarsq = calqsq * delta * (delta + 2.0d0)
DO mu = 1,3
  ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu)
END DO
elltsq = qbarsq*x1mx
onem2x1mx = 1.0d0 - 2.0d0*x1mx
!
! The gluon propagator in Coulomb gauge for an on-shell gluon
! with three-momentum Q(mu). This is the space components only.
!
DO mu = 1,3
  bareprop(mu,mu) = 1.0d0 - q(mu)**2/calqsq
DO nu = mu+1,3
  temp = - q(mu)*q(nu)/calqsq
  bareprop(mu,nu) = temp
  bareprop(nu,mu) = temp
END DO
END DO
!
IF (cut2pt(1).AND.cut2pt(2)) THEN
!
! We have the contribution from a cut self-energy diagram.
! We compute the coefficients for, alternatively, the gluon loop
! or the quark loop. We use the name NLL for Ntt and NEL for NEt.
!
IF (kind2pt.EQ.'gluonloop') THEN
! 
ntt =  2.0d0*nc*( - 1.0d0 + x1mx)
nll =  4.0d0*nc*x1mx
nee = - nc*(1.0d0 + 4.0d0*x1mx)
nel = - 2.0d0*nc*twoxm1
!
ELSE IF (kind2pt.EQ.'quarkloop') THEN
!
ntt = nf*onem2x1mx
nll = - 4.0d0*nf*x1mx
nee = 4.0d0*nf*x1mx
nel = 2.0d0*nf*twoxm1
!
ELSE IF (kind2pt.EQ.'bothloops') THEN
!
ntt =  2.0d0*nc*( - 1.0d0 + x1mx)
nll =  4.0d0*nc*x1mx
nee = - nc*(1.0d0 + 4.0d0*x1mx)
nel = - 2.0d0*nc*twoxm1
!
ntt = ntt + nf*onem2x1mx
nll = nll - 4.0d0*nf*x1mx
nee = nee + 4.0d0*nf*x1mx
nel = nel + 2.0d0*nf*twoxm1
!
ELSE
  write(nout,*)'Unrecognized type in subroutine twopointg.'
  stop
END IF
!
! With the coefficients in hand, we compute the result.
!
prefactor = 1.0d0/(4.0d0*omegaplus*omegaminus*qbarsq)
!
out(0,0) = prefactor*qbarsq/calqsq*nee
DO mu = 1,3
  temp = prefactor*q0/deltap1/calqsq*nel*ellt(mu)
  out(0,mu) = temp
  out(mu,0) = temp
END DO
DO mu = 1,3
DO nu = 1,3
  termtt = ntt*bareprop(mu,nu)
  termll = nll*(ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu))
  out(mu,nu) = prefactor*(termtt + termll)
END DO
END DO
!
! Alternative for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....
!
ELSE IF (cut2pt(0).OR.cut2pt(3)) THEN
!
! We have the contribution from a virtual self-energy diagram
! with one of the neighboring propagators cut.
! We compute the coefficients for, alternatively, the gluon loop
! or the quark loop.
!
IF (kind2pt.EQ.'gluonloop') THEN
!
  temp = mumsbar**2*exp(2.0d0)
  at0 = - 2.0d0*nc*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(5.0d0/3.0d0)
  at0 = at0 + 2.0d0*nc*x1mx*temp/(qbarsq + temp)
  ntt0 = 4.0d0*nc*x1mx
  net0 = - 2.0d0*nc*twoxm1
!
  utt = at0
  ntt = ntt0
  net = net0
!
ELSE IF (kind2pt.EQ.'quarkloop') THEN
!
! Here AT1 = AT2 = NTT1 = NTT2 = NET1 = NET2 = 0.
!
  temp = mumsbar**2*exp(2.0d0)
  at0 = nf*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(8.0d0/3.0d0)
  at0 = at0 - 2.0d0*nf*x1mx*temp/(qbarsq + temp)
  ntt0 = - 4.0d0*nf*x1mx
  net0 = 2.0d0*nf*twoxm1
!
  utt = at0
  ntt = ntt0
  net = net0
!
ELSE IF (kind2pt.EQ.'bothloops') THEN
!
  temp = mumsbar**2*exp(2.0d0)
  at0 = - 2.0d0*nc*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(5.0d0/3.0d0)
  at0 = at0 + 2.0d0*nc*x1mx*temp/(qbarsq + temp)
  ntt0 = 4.0d0*nc*x1mx
  net0 = - 2.0d0*nc*twoxm1
!
  utt = at0
  ntt = ntt0
  net = net0
!
  temp = mumsbar**2*exp(2.0d0)
  at0 = nf*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(8.0d0/3.0d0)
  at0 = at0 - 2.0d0*nf*x1mx*temp/(qbarsq + temp)
  ntt0 = - 4.0d0*nf*x1mx
  net0 = 2.0d0*nf*twoxm1
!
  utt = utt + at0
  ntt = ntt + ntt0
  net = net + net0
!
ELSE
  write(nout,*)'Unrecognized type in subroutine twopointg.'
  stop
END IF
!
! With the coefficients in hand, we compute the result. There is
! an extra factor 1 + \Delta  compared to the real self-energy
! graphs because {\cal W} lacks the factor 1/(1 + \Delta) that
! appears in {\cal M}.
!
! Also, we divide by 2 because we will get this contribution
! twice, once when one adjacent propagator is cut and onece
! when the other adjacent propagator is cut.
!
prefactor = - deltap1/(4.0d0*omegaplus*omegaminus*qbarsq)
prefactor = 0.5d0*prefactor
!
out(0,0) = 0.0d0
DO mu = 1,3
   temp = prefactor*q0/deltap1/calqsq/(1 + qbarsq/calqsq)
   temp = temp*net*ellt(mu)
   out(0,mu) = temp
   out(mu,0) = temp
END DO
DO mu = 1,3
DO nu = 1,3
  termtt = utt*bareprop(mu,nu)
  temp = ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu)
  termll = ntt/(1 + qbarsq/calqsq)*temp
  out(mu,nu) = prefactor*(termtt + termll)
END DO
END DO
!
! Closing for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....ELSE IF ...
!
ELSE
  write(nout,*)'For a gluon two point function,'
  write(nout,*)'either the self-energy graph must be cut'
  write(nout,*)'or one of the neighboring propagators'
  write(nout,*)'must be cut.'
  stop
END IF
!
RETURN
END subroutine twopointgf
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine twopointqf(k2pt,cut2pt,mumsbar,flag,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: k2pt(0:2,0:3)
logical :: cut2pt(0:3)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: out(0:3)
!
! Calculates the one loop quark two-point function, including the
! adjoining propagators.
!
! k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part)
! k2pt(1,mu): 1st momentum in loop (kplus for the space part)
! k2pt(2,mu): 2nd momentum in loop (kminus for the space part)
!
! cut2pt(0): whether incoming line is cut
! cut2pt(1): whether 1st internal line is cut
! cut2pt(2): whether 2nd internal line is cut
! cut2pt(3): whether outgoing line is cut
!
! mumsbar is the MSbar renormalization scale.
!
! The two  point function, with a certain normalization, 
! is represented as out^mu gamma_mu. 
! For the real quark self-energy graphs, out^{\mu} gamma_{\mu} 
! is {\cal M}_q divided by 
! (\alpha_s/(4\pi)) * 1/(1+\Delta) 
! and divided by 
! 4 * \omega_+ * \omega_- * \bar q^2. 
! The factor by which we divide consists of
! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
!   one (2\pi)^{-3} for each loop that is factored out of each
!   graph in our program.
! * (d\vec l)/(d\bar q^2 dx d\phi)
!    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
! * 4 \pi {\cal Q} \bar q^2 included in the relation between
!   {\cal I}[real] and {\cal M}_q.
!
! In the case of the virtual quark self-energy graphs with
! one of the adjacent propagators cut, OUT^{\mu} gamma_{\mu} 
! is {\cal W}_q divided by the same factors.
!
! In the case of the virtual quark self-energy graphs with
! the adjacent propagators *not* cut, OUT^{\mu} gamma_{\mu} 
! is W_q divided by 
! (\alpha_s/(4\pi)) * 1/(1+\Delta)
! and divided by 
! 2 * \omega_+ * \omega_- * (\bar q^2 - q^2) * q^2/{\cal Q}.
! The factor by which we divide consists of
! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
!   one (2\pi)^{-3} for each loop that is factored out of each
!   graph in our program.
! * (d\vec l)/(d\bar q^2 dx d\phi)
!    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
! * 2 \pi q^2 (\bar q^2 - q^2) included in the relation between
!   {\cal I}[all uncut] and W_q. 
!
! 16 December 2001
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
complex(kind=dbl) :: complexsqrt
integer :: mu
complex(kind=dbl) :: kplus(1:3),kminus(1:3),ell(1:3),q(1:3)
complex(kind=dbl) :: calqsq,omegaplussq,omegaminussq
complex(kind=dbl) :: calq,omegaplus,omegaminus
complex(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq
complex(kind=dbl) :: ellt(1:3)
complex(kind=dbl) :: elltsq,onem2x1mx,x
complex(kind=dbl) :: temp,tempsq
complex(kind=dbl) :: nl,ne,nt,prefactor
complex(kind=dbl) :: bl0
complex(kind=dbl) :: nl0
complex(kind=dbl) :: nt0
complex(kind=dbl) :: ul,vl,vt
complex(kind=dbl) :: q0,qsq
complex(kind=dbl) :: be0
complex(kind=dbl) :: ue
! 
! Some auxilliary variables, including
! CALQ = {\cal Q}
! OMEGAPLUS = \omega_+
! OMEGAMINUS = \omega_-
! DELTAP1 = \Delta + 1
! TWOXM1 = 2 x - 1
! X1MX = x (1-x)
! ELLT(mu) = l_T^\mu
! ELLTSQ = (\vec l_T)^2
! Q(mu) = the incoming *three*-momentum
! Q0 = the incoming energy
!
DO mu = 1,3
  kplus(mu) = k2pt(1,mu)
  kminus(mu) = k2pt(2,mu)
  ell(mu) = (kplus(mu) - kminus(mu))/2.0d0
  q(mu) = k2pt(0,mu)
END DO
q0 = k2pt(0,0)
calqsq = 0.0d0
omegaplussq = 0.0d0
omegaminussq = 0.0d0
DO mu = 1,3
  calqsq = calqsq + q(mu)**2
  omegaplussq = omegaplussq + kplus(mu)**2
  omegaminussq = omegaminussq + kminus(mu)**2
END DO
calq = complexsqrt(calqsq)
omegaplus  = complexsqrt(omegaplussq)
omegaminus = complexsqrt(omegaminussq)
deltap1 = (omegaplus + omegaminus)/calq
delta = deltap1 - 1.0d0
twoxm1 = (omegaplus - omegaminus)/calq
x1mx = (1.0d0 - twoxm1**2)/4.0d0
qbarsq = calqsq * delta * (delta + 2.0d0)
DO mu = 1,3
  ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu)
END DO
elltsq = qbarsq*x1mx
onem2x1mx = 1.0d0 - 2.0d0*x1mx
x = (twoxm1 + 1.0d0)/2.0d0
!
! Now we will go through these possible cut structures and
! calculate the terms contributing to out(mu).
!
IF ( cut2pt(1).AND.cut2pt(2) ) THEN
!
! First possibility for cut structure: a cut self-energy diagram.
! Here TEMP = 2 x + Delta.
!
temp = twoxm1 + deltap1
tempsq = temp**2
nl = 4.0d0*x1mx + twoxm1*temp
nl = cf*nl
ne = 2.0d0*cf*(1.0d0 - x)
nt = 2.0d0*cf
!
prefactor = 1.0d0/(4.0d0*omegaplus*omegaminus*qbarsq)
out(0) = prefactor*q0/deltap1*(nl + delta*ne)
DO mu = 1,3
  out(mu) = prefactor*(nl*q(mu) + nt*ellt(mu))
END DO
!
ELSE IF ( cut2pt(0).OR.cut2pt(3) ) THEN
!
! Second possibility for cut structure: a virtual self-energy
! with an adjacent propagator cut.
!
temp = mumsbar**2 * exp(1.0d0)
bl0 = cf*temp/(qbarsq + temp) 
nl0 = cf*twoxm1
nt0 = 2.0d0*cf
ul = bl0
vl = nl0
vt = nt0
!
! We divide by 2 because we will get this contribution
! twice, once when one adjacent propagator is cut and once
! when the other adjacent propagator is cut.
!
prefactor = deltap1/(4.0d0*omegaplus*omegaminus*qbarsq)
prefactor = 0.5d0*prefactor
!
temp = ul + vl/(1.0d0 + qbarsq/calqsq)
out(0) = - prefactor*q0*temp
DO mu = 1,3
  out(mu) = - prefactor*(temp*q(mu)  &
            + vt*ellt(mu)/(1.0d0 + qbarsq/calqsq))
END DO
! 
ELSE
!
! Third possibility for cut structure: a virtual self-energy
! with *no* adjacent propagator cut.
!
qsq = q0**2 - calqsq
!
temp = mumsbar**2 * exp(1.0d0)
bl0 = (qsq + temp)/(qbarsq + temp)
bl0 = cf*bl0
be0 = 0.0d0
ul = bl0
ue = be0
!
prefactor = 2.0d0*omegaplus*omegaminus*qsq*(qbarsq - qsq)
prefactor = deltap1*calq/prefactor
out(0) = - prefactor*q0*(ul + qsq/calqsq*ue)
DO mu = 1,3
  out(mu) = - prefactor*q(mu)*ul
END DO
!
! Completion of IF ... block for cut structure.
!
END IF
!
RETURN
END subroutine twopointqf
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,hv,ha)
!
use beowulf_helpers
implicit none
! In:
character(len=7) :: kind3pt
complex(kind=dbl) :: k3pt(3,0:3)
logical :: cut3pt(3)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: hv(0:3,0:3),ha(0:3,0:3)
!
! The unintegrated quark-antiquark-gluon three point function
! for the graph with flavors labelled by KIND3PT. 
!
! KIND3PT has the form abc/def where a,...,f are chosen from 
! Q,G,P. Here Q denotes "quark" or "antiquark", G denotes "gluon",
! and P denotes "photon". The external lines have flavors a,b,c
! and the internal lines have flavors d,e,f. The possibilities
! are QQG/QQG, QQG/GGQ, and QQP/QQG. There is also QQG/ALL, which
! gives the sum of the results for QQG/QQG and QQG/GGQ.
!
! The unintegrated three-point function \Gamma^\mu can be decomposed
! into a function HV^\mu_\nu \gamma^\mu plus a function 
! HA^\mu_\nu I \gamma^\mu \gamma_5 (all times a t^a color matrix or a
! unit color matrix in the case of a QQP vertex). This subroutine
! calculates the functions HV^{\mu\nu} and HA^{\mu\nu}.  The arguments
! are the momenta k3pt(1,mu), k3pt(2,mu), k3pt(3,mu), of the propagators
! around the loop. 
!
! The variable cut3pt(j) is .true. if line j is cut, .false. otherwise.
! If the line is cut, the corresponding energy is set by the calling
! programs to be k0 = + |\vec k| or else k0 = - |\vec k|. (Here
! |\vec k| is a shorthand for sqrt(\vec k^2), not the square root of 
! \vec k dotted into its complex conjugate.) This subroutine supplies a
! factor k(j)^2 for uncut propagators and 2 sqrt(\vec k^2) for a cut
! propagator.  For a virtual loop, subroutine vertex will be called six
! times, once with each of the three propagators cut and k0 = + |\vec k|
! and once with each of the three propagators cut and k0 = - |\vec k|.
! Then it will be called with no propagator cut, which implies that it
! should supply the renormalization counter term.
!
! This version in Feynman gauge.
! 31 December 2001
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
complex(kind=dbl) :: complexsqrt
!
complex(kind=dbl), parameter :: nvec(0:3) = &
  (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/)
real(kind=dbl), parameter :: g(0:3,0:3) =  reshape(  &
       (/1.0d0, 0.0d0, 0.0d0, 0.0d0, &
         0.0d0,-1.0d0, 0.0d0, 0.0d0, &
         0.0d0, 0.0d0,-1.0d0, 0.0d0, &
         0.0d0, 0.0d0, 0.0d0,-1.0d0/)&
      ,(/4,4/))
!
complex(kind=dbl) :: tk11,tk22,tk33,tk12,tk23,tk13
complex(kind=dbl) :: k11,k22,k33,k12,k23,k13
complex(kind=dbl) :: e1,e2,e3
complex(kind=dbl) :: c1,c2,c3,c4,c5,c6,c7,c8,c9
complex(kind=dbl) :: c10,c11,c12,c13,c14,c15,c16,c17
complex(kind=dbl) :: temp,prefactor
integer :: mu,nu
complex(kind=dbl) :: k1(0:3),k2(0:3),k3(0:3)
complex(kind=dbl) :: epsn1(0:3,0:3),epsn2(0:3,0:3),epsn3(0:3,0:3)
complex(kind=dbl) :: eps12(0:3,0:3),eps13(0:3,0:3),eps23(0:3,0:3)
complex(kind=dbl) :: epsn12(0:3),epsn13(0:3),epsn23(0:3),eps123(0:3)
complex(kind=dbl) :: tl(0:3),omegasq,omega,cr1,cr2,cr3
integer :: ncut,p
!
!-----
!
ncut = 0
DO p=1,3
   IF (cut3pt(p)) THEN
     ncut = ncut + 1
   END IF
END DO
!
IF ((ncut.GT.1).OR.(flag.NE.'renormalize 3 pt')) THEN
!
! If NCUT = 1, we have a virtual loop. In this case, one of the
! possibilities is the renormalization counter term, for which
! FLAG would have been set to 'renormalize 3 pt'. Thus we get
! here is we do *not* have the the renormalization counter term.
! (Note that we could have NCUT = 2 but FLAG = 'renormalize 3 pt'
! in the case that there are two three point functions and ours
! is cut but the other one is virtual and needs to be renormalized.) 
!
! First, dot products and energies. The dot products between vectors
! omitting their mu = 0 parts (\tilde vector) are denoted TKij.
!
tk11 = (0.0d0,0.0d0)
tk22 = (0.0d0,0.0d0)
tk33 = (0.0d0,0.0d0)
tk12 = (0.0d0,0.0d0)
tk23 = (0.0d0,0.0d0)
tk13 = (0.0d0,0.0d0)
DO mu = 1,3
  tk11 = tk11 - k3pt(1,mu)*k3pt(1,mu)
  tk22 = tk22 - k3pt(2,mu)*k3pt(2,mu)
  tk33 = tk33 - k3pt(3,mu)*k3pt(3,mu)
  tk12 = tk12 - k3pt(1,mu)*k3pt(2,mu)
  tk23 = tk23 - k3pt(2,mu)*k3pt(3,mu)
  tk13 = tk13 - k3pt(1,mu)*k3pt(3,mu)
END DO
e1 = k3pt(1,0)
e2 = k3pt(2,0)
e3 = k3pt(3,0)
k11 = e1*e1 + tk11
k22 = e2*e2 + tk22
k33 = e3*e3 + tk33
k12 = e1*e2 + tk12
k23 = e2*e3 + tk23
k13 = e1*e3 + tk13
!
! We need the factor equal to 1/k^2 for an uncut propagator
! and 1/ 2|E| for a cut propagator.
!
prefactor = (1.0d0,0.0d0)
IF (.NOT.cut3pt(1)) THEN
  prefactor = prefactor/k11
ELSE
  prefactor = prefactor/(2.0d0*complexsqrt(-tk11))
END IF
IF (.NOT.cut3pt(2)) THEN
  prefactor = prefactor/k22
ELSE
  prefactor = prefactor/(2.0d0*complexsqrt(-tk22))
END IF
IF (.NOT.cut3pt(3)) THEN
  prefactor = prefactor/k33
ELSE
  prefactor = prefactor/(2.0d0*complexsqrt(-tk33))
END IF
!
!------------------------
! First, we calculate hv.
!------------------------
! Generate the coefficients for the hv, depending on KIND3PT.
!
IF (kind3pt.EQ.'qqg/qqg') THEN
!
c1 = k12/nc
c2 = 0.0d0
c3 = 0.0d0
c4 = 0.0d0
c5 = 0.0d0
c6 = 0.0d0
c7 = 0.0d0
c8 = 0.0d0
c9 = 0.0d0
c10 = -(1.0d0/nc)
c11 = 0.0d0
c12 = -(1.0d0/nc)
c13 = 0.0d0
c14 = 0.0d0
c15 = 0.0d0
c16 = 0.0d0
c17 = 0.0d0
!
ELSE IF (kind3pt.EQ.'qqg/ggq') THEN
!
c1 = -((k13 + k23)*nc)/2.0d0
c2 = 0.0d0
c3 = 0.0d0
c4 = 0.0d0
c5 = 0.0d0
c6 = 0.0d0
c7 = 0.0d0
c8 = 0.0d0
c9 = 0.0d0
c10 = 0.0d0
c11 = -nc/2.0d0
c12 = 0.0d0
c13 = 0.0d0
c14 = -nc/2.0d0
c15 = -nc/2.0d0
c16 = -nc/2.0d0
c17 = 0.0d0
!
ELSE IF (kind3pt.EQ.'qqg/all') THEN
!
c1 = k12/nc
c2 = 0.0d0
c3 = 0.0d0
c4 = 0.0d0
c5 = 0.0d0
c6 = 0.0d0
c7 = 0.0d0
c8 = 0.0d0
c9 = 0.0d0
c10 = -(1.0d0/nc)
c11 = 0.0d0
c12 = -(1.0d0/nc)
c13 = 0.0d0
c14 = 0.0d0
c15 = 0.0d0
c16 = 0.0d0
c17 = 0.0d0
!
c1 = c1 - ((k13 + k23)*nc)/2.0d0
c11 = c11 - nc/2.0d0
c14 = c14 - nc/2.0d0
c15 = c15 - nc/2.0d0
c16 = c16 - nc/2.0d0
!
ELSE IF (kind3pt.EQ.'qqp/qqg') THEN
!
c1 = -2.0d0*cf*k12
c2 = 0.0d0
c3 = 0.0d0
c4 = 0.0d0
c5 = 0.0d0
c6 = 0.0d0
c7 = 0.0d0
c8 = 0.0d0
c9 = 0.0d0
c10 = 2.0d0*cf
c11 = 0.0d0
c12 = 2.0d0*cf
c13 = 0.0d0
c14 = 0.0d0
c15 = 0.0d0
c16 = 0.0d0
c17 = 0.0d0
!
ELSE
  write(nout,*)'Wrong kind in subroutine vertex.'
  stop
END IF
!
! Now we have the coefficients, so we can calculate hv.
!
DO mu = 0,3
DO nu = 0,3
!
 temp  = c1*g(mu,nu) &
 + c2*nvec(mu)*nvec(nu) &
 + c3*nvec(mu)*k3pt(1,nu) &
 + c4*nvec(mu)*k3pt(2,nu) &
 + c5*nvec(mu)*k3pt(3,nu) &
 + c6*k3pt(1,mu)*nvec(nu) &
 + c7*k3pt(2,mu)*nvec(nu) &
 + c8*k3pt(3,mu)*nvec(nu) &
 + c9*k3pt(1,mu)*k3pt(1,nu) &
 + c10*k3pt(1,mu)*k3pt(2,nu) &
 + c11*k3pt(1,mu)*k3pt(3,nu) &
 + c12*k3pt(2,mu)*k3pt(1,nu) &
 + c13*k3pt(2,mu)*k3pt(2,nu) &
 + c14*k3pt(2,mu)*k3pt(3,nu) &
 + c15*k3pt(3,mu)*k3pt(1,nu) &
 + c16*k3pt(3,mu)*k3pt(2,nu) &
 + c17*k3pt(3,mu)*k3pt(3,nu)
!
 hv(mu,nu) = prefactor * temp
!
END DO
END DO
!
!------------------------
! Next, we calculate ha.
!------------------------
!
! We need certain vectors and tensors made by dotting vectors
! into the epsilon tensor.
!
DO mu = 0,3
  k1(mu) = k3pt(1,mu)
  k2(mu) = k3pt(2,mu)
  k3(mu) = k3pt(3,mu)
END DO
call epsilon1n(k1,epsn1)
call epsilon1n(k2,epsn2)
call epsilon1n(k3,epsn3)
call epsilon2(k1,k2,eps12)
call epsilon2(k1,k3,eps13)
call epsilon2(k2,k3,eps23)
call epsilon2n(k1,k2,epsn12)
call epsilon2n(k1,k3,epsn13)
call epsilon2n(k2,k3,epsn23)
call epsilon3(k1,k2,k3,eps123)
!
! Generate the coefficients for the hv, depending on KIND3PT.
!
IF (kind3pt.EQ.'qqg/qqg') THEN
!
c1 = 0.0d0
c2 = 0.0d0
c3 = 0.0d0
c4 = -(1.0d0/nc)
c5 = 0.0d0
c6 = 0.0d0
c7 = 0.0d0
c8 = 0.0d0
c9 = 0.0d0
c10 = 0.0d0
c11 = 0.0d0
c12 = 0.0d0
c13 = 0.0d0
c14 = 0.0d0
c15 = 0.0d0
c16 = 0.0d0
c17 = 0.0d0
!
ELSE IF (kind3pt.EQ.'qqg/ggq') THEN
!
c1 = 0.0d0
c2 = 0.0d0
c3 = 0.0d0
c4 = 0.0d0
c5 = (3.0d0*nc)/2.0d0
c6 = (-3.0d0*nc)/2.0d0
c7 = 0.0d0
c8 = 0.0d0
c9 = 0.0d0
c10 = 0.0d0
c11 = 0.0d0
c12 = 0.0d0
c13 = 0.0d0
c14 = 0.0d0
c15 = 0.0d0
c16 = 0.0d0
c17 = 0.0d0
!
ELSE IF (kind3pt.EQ.'qqg/all') THEN
!
c1 = 0.0d0
c2 = 0.0d0
c3 = 0.0d0
c4 = -(1.0d0/nc)
c5 = 0.0d0
c6 = 0.0d0
c7 = 0.0d0
c8 = 0.0d0
c9 = 0.0d0
c10 = 0.0d0
c11 = 0.0d0
c12 = 0.0d0
c13 = 0.0d0
c14 = 0.0d0
c15 = 0.0d0
c16 = 0.0d0
c17 = 0.0d0
!
c5 = c5 + (3.0d0*nc)/2.0d0
c6 = c6 - 3.0d0*nc/2.0d0
!
ELSE IF (kind3pt.EQ.'qqp/qqg') THEN
!
c1 = 0
c2 = 0
c3 = 0
c4 = 2.0d0*cf
c5 = 0
c6 = 0
c7 = 0
c8 = 0
c9 = 0
c10 = 0
c11 = 0
c12 = 0
c13 = 0
c14 = 0
c15 = 0
c16 = 0
c17 = 0
!
ELSE
  write(nout,*)'Wrong kind in subroutine vertex.'
  stop
END IF
!
! Now we have the coefficients, so we can calculate ha.
!
DO mu = 0,3
DO nu = 0,3
!
 temp = c1*epsn1(mu,nu) &
 + c2*epsn2(mu,nu) &
 + c3*epsn3(mu,nu) &
 + c4*eps12(mu,nu) &
 + c5*eps13(mu,nu) &
 + c6*eps23(mu,nu) &
 + c7*k3pt(3,mu)*epsn12(nu) &
 + c8*nvec(mu)*epsn13(nu) &
 + c9*k3pt(1,mu)*epsn13(nu) &
 + c10*k3pt(2,mu)*epsn13(nu) &
 + c11*nvec(mu)*epsn23(nu) &
 + c12*k3pt(1,mu)*epsn23(nu) &
 + c13*k3pt(2,mu)*epsn23(nu) &
 + c14*nvec(mu)*eps123(nu) &
 + c15*k3pt(1,mu)*eps123(nu) &
 + c16*k3pt(2,mu)*eps123(nu) &
 + c17*k3pt(3,mu)*eps123(nu)
!
 ha(mu,nu) = prefactor * temp
!
END DO
END DO
!
!-----------------------------
! Now, we have both hv and ha.
!-----------------------------
!
! Alternative for IF (FLAG.NE.'renormalize 3 pt') THEN
!
ELSE
!
! We need the renormalization counter term.
!
tl(0) = 0.0d0
omegasq = 0.0d0
DO mu = 1,3
  tl(mu) =(k3pt(1,mu) + k3pt(2,mu) + k3pt(3,mu))/3.0d0
  omegasq = omegasq + tl(mu)**2
END DO
omegasq = omegasq + mumsbar**2
omega = complexsqrt(omegasq)
!
! Generate the coefficients for the hv counter term, 
! depending on KIND3PT.
!
IF (kind3pt.EQ.'qqg/qqg') THEN
!
cr1 = - 1.0d0/(4.0d0*nc*omega**3)  &
      - 3.0d0*mumsbar**2/(16.0d0*nc*omega**5)
cr2 = - 3.0d0/(8.0d0*nc*omega**5)
cr3 = 1.0d0/(8.0d0*nc*omega**3)
!
ELSE IF (kind3pt.EQ.'qqg/ggq') THEN
!
cr1 = nc/(4.0d0*omega**3)  &
     + 3.0d0*nc*mumsbar**2/(16.0d0*omega**5)
cr2 = - 3.0d0*nc/(8.0d0*omega**5)
cr3 = nc/(8.0d0*omega**3)
!
ELSE IF (kind3pt.EQ.'qqg/all') THEN
!
cr1 = nc/(4.0d0*omega**3)  &
     + 3.0d0*nc*mumsbar**2/(16.0d0*omega**5)
cr2 = - 3.0d0*nc/(8.0d0*omega**5)
cr3 = nc/(8.0d0*omega**3)
!
cr1 = cr1 - 1.0d0/(4.0d0*nc*omega**3)  &
      - 3.0d0*mumsbar**2/(16.0d0*nc*omega**5)
cr2 = cr2 - 3.0d0/(8.0d0*nc*omega**5)
cr3 = cr3 + 1.0d0/(8.0d0*nc*omega**3)
!
ELSE IF (kind3pt.EQ.'qqp/qqg') THEN
!
cr1 =  cf/(2.0d0*omega**3)  &
      + 3.0d0*cf*mumsbar**2/(8.0d0*omega**5)
cr2 = 3.0d0*cf/(4.0d0*omega**5)
cr3 = - cf/(4.0d0*omega**3)
!
ELSE
  write(nout,*)'Wrong kind in subroutine vertex.'
  stop
END IF
!
! Now we have the coefficients, so we can calculate the hv counter term.
! The ha counter term is zero.
!
DO mu = 0,3
DO nu = 0,3
  hv(mu,nu) = - cr1*g(mu,nu) &
   - cr2*tl(mu)*tl(nu) &
   - cr3*nvec(mu)*nvec(nu)
  ha(mu,nu) = 0.0d0
END DO
END DO
RETURN
!
! End  IF (CUT3PT(1).OR.CUT3PT(2).OR.CUT3PT(3)) THEN ... ELSE ...
!
END IF
!
RETURN
END subroutine vertexf
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890   !2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,vout)
!
use beowulf_helpers
implicit none
! In:
character(len=13) :: kind2pt2
complex(kind=dbl) :: k2pt2(0:5,0:3)
logical :: cut2pt2(1:5)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: vout(0:3)
!
! *Feynman gauge*.
!
! The two-loop contribution to the quark propagator. The function is 
! a dot product of a four-vector VOUT(mu) with gamma(mu), times a
! unit color matrix. This subroutine calculates VOUT(mu). (There is
! another contribution proportional to gamma(mu) gamma(5), but this
! contribution is not needed at our level of perturbation theory.) The
! contribution includes the self-energy diagram and the adjoining bare
! quark propagators. The calculation includes the denominator factors.
! Some of the internal propagators may be cut, as specified by cut2pt2,
! where cut2pt2(j) = .true. indicates that the corresponding line is 
! cut.
!
! The variable kind2pt2 tells what sort of graph we have.
!
! 1) There are graphs with two overlapping three point functions,
! incicated by kind2pt2 = OVERLAP/abcde where  a,...,e are chosen from 
! Q,G. Here Q denotes "quark" or "antiquark" while G denotes "gluon".
! These characters indicate the flavors on the internal lines. There
! are two possibilities: OVERLAP/QGGQQ and OVERLAP/QGQGG. (The first
! of these has all qqg vertices, while the second has two qqg vertices
! and one ggg vertex.) 
!
! 2) There are graphs with a one loop two point function nested inside
! the two loop two point function. These are indicated by
! kind2pt2 = NESTED /abcde, where, again,  a,...,e are chosen from 
! Q,G. There are three possibilities: 
!    NESTED /QGGGG gluon self-enegy with a gluon loop
!    NESTED /QGGQQ gluon self-enegy with a quark loop
!    NESTED /GQQGQ quark self-enegy
!
! Numbering for graphs of type OVERLAP:
! vrtx1 attaches to the incoming quark line
! vrtx2 attaches to the outgoing quark line
! vrtx3 is the internal vertex attached to a quark line from vrtx1
! vrtx4 is the other internal vertex
! k0(mu) is the momentum of the quark line entering vrtx1
! k1(mu) is the momentum of the internal line from vrtx1 to vrtx3
! k2(mu) is the momentum of the internal line from vrtx1 to vrtx4
! k3(mu) is the momentum of the internal line from vrtx3 to vrtx2
! k4(mu) is the momentum of the internal line from vrtx4 to vrtx2
! k5(mu) is the momentum of the internal line from vrtx3 to vrtx4
!
! Numbering for graphs of type NESTED:
! vrtx1 attaches to the incoming quark line
! vrtx2 attaches to the outgoing quark line
! vrtx3 is the internal vertex attached to a line from vrtx1
! vrtx4 is the other internal vertex
! k0(mu) is the momentum of the quark line entering vrtx1
! k1(mu) is the momentum of the internal line from vrtx1 to vrtx2
! k2(mu) is the momentum of the internal line from vrtx1 to vrtx3
! k3(mu) is the momentum of the internal line from vrtx4 to vrtx2
! k4(mu) ane k5(mu) are the momentum of the internal lines 
!        from vrtx3 to vrtx4. For a quark internal self-energy,
!        4 is the gluon and 5 is the quark line.
! 
! 31 December 2001
!
! For testing purposes only:
!     LOGICAL OVERRIDE,LEFTOVERRIDE
!     COMMON /TESTING/ OVERRIDE,LEFTOVERRIDE
! ---
!
complex(kind=dbl) :: complexsqrt
complex(kind=dbl) :: tk00,tk11,tk22,tk33,tk44
complex(kind=dbl) :: k00,k11,k22,k33,k44
complex(kind=dbl) :: temp,prefactor
complex(kind=dbl) :: k0(0:3),k1(0:3),k2(0:3),k3(0:3),k4(0:3),k5(0:3)
complex(kind=dbl) :: e0,e1,e2,e3,e4
logical :: cut(1:5)
!
complex(kind=dbl) :: ea4gk0k1,ea4qk0k1,ea5gk0k3,ea5qk0k4,k0k1,k0k3,k0k4
complex(kind=dbl) :: tracev4g,tracev4q,tracev5g,tracev5q,v4gwk0k1,v4gwk1k0
complex(kind=dbl) :: v4qwk0k1,v4qwk1k0,v5gwk0k3,v5gwk3k0,v5qwk0k4,v5qwk4k0
complex(kind=dbl) :: ea4gk1(0:3),ea4qk1(0:3),ea5gk3(0:3),ea5qk4(0:3)
complex(kind=dbl) :: v4gik1(0:3),v4gk1i(0:3),v4qik1(0:3),v4qk1i(0:3)
complex(kind=dbl) :: v5gik3(0:3),v5gk3i(0:3),v5qik4(0:3),v5qk4i(0:3)
complex(kind=dbl) :: a4g(0:3,0:3),a4q(0:3,0:3),a5g(0:3,0:3),a5q(0:3,0:3)
complex(kind=dbl) :: v4g(0:3,0:3),v4q(0:3,0:3),v5g(0:3,0:3),v5q(0:3,0:3)
!
character(len=7) :: kind3pt
logical :: overlap,qqgverts,tripleglue
logical :: nested,nestedglue,nestedquark,glueloop,quarkloop
complex(kind=dbl) :: k2pt(0:2,0:3),q(0:3)
complex(kind=dbl) :: omegasq,qsq
character(len=9) :: kind2pt
logical :: cut2pt(0:3)
complex(kind=dbl) :: outg(0:3,0:3)
complex(kind=dbl) :: mk1(0:3),tracem,dotqk1,mqk1
complex(kind=dbl) :: outq(0:3)
complex(kind=dbl) :: omega1sq,bareprop(0:3,0:3),dm(0:3),qm,dqm
complex(kind=dbl) :: tracebareprop
!
complex(kind=dbl), parameter :: gn(0:3) = &
         (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) 
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
integer :: mu,nu,alpha
logical :: left,right
!
complex(kind=dbl) :: k3pt(3,0:3)
logical :: cut3pt(3)
!
! Set logical variables according to what case we have.
!
overlap = .false.
qqgverts = .false.
tripleglue = .false.
nested = .false.
nestedglue = .false.
nestedquark = .false.
glueloop = .false.
quarkloop = .false.
IF (kind2pt2.EQ.'overlap/qggqq') THEN
  overlap = .true.
  qqgverts = .true.
ELSE IF (kind2pt2.EQ.'overlap/qgqgg') THEN
  overlap = .true.
  tripleglue = .true.
ELSE IF (kind2pt2.EQ.'nested /qgggg') THEN
  nested = .true.
  nestedglue = .true.
  glueloop = .true.
ELSE IF (kind2pt2.EQ.'nested /qggqq') THEN
  nested = .true.
  nestedglue = .true.
  quarkloop = .true.
ELSE IF (kind2pt2.EQ.'nested /gqqgq') THEN
  nested = .true.
  nestedquark = .true.
ELSE
  write(nout,*)'Not programmed for that.'
  stop
END IF
!
IF (overlap) THEN
!
! Short form of momentum variables and rename cut variables
! for overlap graphs.
!
DO mu = 0,3
  k0(mu) = k2pt2(0,mu)
  k1(mu) = k2pt2(1,mu)
  k2(mu) = k2pt2(2,mu)
  k3(mu) = k2pt2(3,mu)
  k4(mu) = k2pt2(4,mu)
  k5(mu) = k2pt2(5,mu)
END DO
cut(1) = cut2pt2(1)
cut(2) = cut2pt2(2)
cut(3) = cut2pt2(3)
cut(4) = cut2pt2(4)
cut(5) = cut2pt2(5)
!
! We have an OVERLAP type graph. We can treat it two different
! ways: either the left=hand three point graph is calculated
! using subroutine VERTEX or else the right-hand three point
! graph is calculated with subroutine VERTEX. We choose according
! to which lines are cut. Generally, we take the "left" choice,
! but if the right-hand loop is virtual, we take the "right" choice.
!
left = .true.
right = .false.
IF (cut2pt2(1).AND.cut2pt2(2)) THEN
  left = .false.
  right = .true.
END IF
!
! For testing purposes, we include code to override this choice.
!
!     IF (OVERRIDE) THEN
!       LEFT = LEFTOVERRIDE
!       RIGHT = .NOT.LEFT
!     END IF
!
! Calculate according to case, with logic
!     IF (QQGVERTS.AND.RIGHT) THEN
!     ELSE IF (QQGVERTS.AND.LEFT) THEN
!     ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN
!     ELSE IF (TRIPLEGLUE.AND.LEFT) THEN
!     ELSE <error>
!     END IF
!
IF (qqgverts.AND.right) THEN
!
!---
tk00 = 0.0d0
DO mu = 1,3
  tk00 = tk00 - k0(mu)**2
END DO
e0 = k0(0)
k00 = e0**2 + tk00
prefactor = 1.0d0/k00**2
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
DO mu = 0,3
  k3pt(1,mu) = -k4(mu)
  k3pt(2,mu) = -k5(mu)
  k3pt(3,mu) = k3(mu)
END DO
cut3pt(1) = cut(4)
cut3pt(2) = cut(5)
cut3pt(3) = cut(3)
kind3pt = 'qqg/qqg'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q)
tracev4q = 0.0d0
DO mu = 0,3
  tracev4q = tracev4q + v4q(mu,mu)*metric(mu)
END DO
v4qwk0k1 = 0.0d0
v4qwk1k0 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v4qwk0k1 = v4qwk0k1 &
         + v4q(mu,nu)*k0(mu)*k1(nu)*metric(mu)*metric(nu)
  v4qwk1k0 = v4qwk1k0 &
         + v4q(mu,nu)*k1(mu)*k0(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  v4qik1(mu) = 0.0d0
  v4qk1i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  v4qik1(mu) = v4qik1(mu) + v4q(mu,nu)*k1(nu)*metric(nu)
  v4qk1i(mu) = v4qk1i(mu) + v4q(nu,mu)*k1(nu)*metric(nu)
END DO
END DO
k0k1 = 0.0d0
DO mu = 0,3
  k0k1 = k0k1 + k0(mu)*k1(mu)*metric(mu)
END DO
call epsilont2(a4q,k0,k1,ea4qk0k1)
call epsilont1(a4q,k1,ea4qk1)
DO nu = 0,3
!
vout(nu) = cf*(k00*ea4qk1(nu) - 2*ea4qk0k1*k0(nu) &
 + 2*k0k1*tracev4q*k0(nu) - 2*v4qwk0k1*k0(nu) - 2*v4qwk1k0*k0(nu) &
 - k00*tracev4q*k1(nu) + k00*v4qik1(nu) + k00*v4qk1i(nu))
vout(nu) = vout(nu)*prefactor
!
END DO
!
ELSE IF (qqgverts.AND.left) THEN
!
!---
tk00 = 0.0d0
DO mu = 1,3
  tk00 = tk00 - k0(mu)**2
END DO
e0 = k0(0)
k00 = e0**2 + tk00
prefactor = 1.0d0/k00**2
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
DO mu = 1,3
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
END DO
k33 = e3**2 + tk33
k44 = e4**2 + tk44
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
DO mu = 0,3
  k3pt(1,mu) = -k5(mu)
  k3pt(2,mu) = -k1(mu)
  k3pt(3,mu) = k2(mu)
END DO
cut3pt(1) = cut(5)
cut3pt(2) = cut(1)
cut3pt(3) = cut(2)
kind3pt = 'qqg/qqg'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v5q,a5q)
tracev5q = 0.0d0
DO mu = 0,3
  tracev5q = tracev5q + v5q(mu,mu)*metric(mu)
END DO
v5qwk0k4 = 0.0d0
v5qwk4k0 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v5qwk0k4 = v5qwk0k4 &
         + v5q(mu,nu)*k0(mu)*k4(nu)*metric(mu)*metric(nu)
  v5qwk4k0 = v5qwk4k0 &
         + v5q(mu,nu)*k4(mu)*k0(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  v5qik4(mu) = 0.0d0
  v5qk4i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  v5qik4(mu) = v5qik4(mu) + v5q(mu,nu)*k4(nu)*metric(nu)
  v5qk4i(mu) = v5qk4i(mu) + v5q(nu,mu)*k4(nu)*metric(nu)
END DO
END DO
k0k4 = 0.0d0
DO mu = 0,3
  k0k4 = k0k4 + k0(mu)*k4(mu)*metric(mu)
END DO
call epsilont2(a5q,k0,k4,ea5qk0k4)
call epsilont1(a5q,k4,ea5qk4)
DO nu = 0,3
!
vout(nu) = -(cf*(k00*ea5qk4(nu) - 2*ea5qk0k4*k0(nu) &
 - 2*k0k4*tracev5q*k0(nu) + 2*v5qwk0k4*k0(nu) + 2*v5qwk4k0*k0(nu) &
 + k00*tracev5q*k4(nu) - k00*v5qik4(nu) - k00*v5qk4i(nu)))
vout(nu) = vout(nu)*prefactor
!
END DO
!
ELSE IF (tripleglue.AND.right) THEN
!
!---
tk00 = 0.0d0
DO mu = 1,3
  tk00 = tk00 - k0(mu)**2
END DO
e0 = k0(0)
k00 = e0**2 + tk00
prefactor = 1.0d0/k00**2
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
DO mu = 0,3
  k3pt(1,mu) = -k4(mu)
  k3pt(2,mu) = -k5(mu)
  k3pt(3,mu) = k3(mu)
END DO
cut3pt(1) = cut(4)
cut3pt(2) = cut(5)
cut3pt(3) = cut(3)
kind3pt = 'qqg/ggq'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v4g,a4g)
tracev4g = 0.0d0
DO mu = 0,3
  tracev4g = tracev4g + v4g(mu,mu)*metric(mu)
END DO
v4gwk0k1 = 0.0d0
v4gwk1k0 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v4gwk0k1 = v4gwk0k1 &
         + v4g(mu,nu)*k0(mu)*k1(nu)*metric(mu)*metric(nu)
  v4gwk1k0 = v4gwk1k0 &
         + v4g(mu,nu)*k1(mu)*k0(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  v4gik1(mu) = 0.0d0
  v4gk1i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  v4gik1(mu) = v4gik1(mu) + v4g(mu,nu)*k1(nu)*metric(nu)
  v4gk1i(mu) = v4gk1i(mu) + v4g(nu,mu)*k1(nu)*metric(nu)
END DO
END DO
k0k1 = 0.0d0
DO mu = 0,3
  k0k1 = k0k1 + k0(mu)*k1(mu)*metric(mu)
END DO
call epsilont2(a4g,k0,k1,ea4gk0k1)
call epsilont1(a4g,k1,ea4gk1)
DO nu = 0,3
!
vout(nu) = cf*(k00*ea4gk1(nu) - 2*ea4gk0k1*k0(nu) &
 + 2*k0k1*tracev4g*k0(nu) - 2*v4gwk0k1*k0(nu) - 2*v4gwk1k0*k0(nu) &
 - k00*tracev4g*k1(nu) + k00*v4gik1(nu) + k00*v4gk1i(nu))
vout(nu) = vout(nu)*prefactor
!
END DO
!
ELSE IF (tripleglue.AND.left) THEN
!
!---
tk00 = 0.0d0
DO mu = 1,3
  tk00 = tk00 - k0(mu)**2
END DO
e0 = k0(0)
k00 = e0**2 + tk00
prefactor = 1.0d0/k00**2
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
DO mu = 1,3
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
END DO
k33 = e3**2 + tk33
k44 = e4**2 + tk44
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
DO mu = 0,3
  k3pt(1,mu) = k5(mu)
  k3pt(2,mu) = -k2(mu)
  k3pt(3,mu) = k1(mu)
END DO
cut3pt(1) = cut(5)
cut3pt(2) = cut(2)
cut3pt(3) = cut(1)
kind3pt = 'qqg/ggq'
call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v5g,a5g)
tracev5g = 0.0d0
DO mu = 0,3
  tracev5g = tracev5g + v5g(mu,mu)*metric(mu)
END DO
v5gwk0k3 = 0.0d0
v5gwk3k0 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v5gwk0k3 = v5gwk0k3 &
         + v5g(mu,nu)*k0(mu)*k3(nu)*metric(mu)*metric(nu)
  v5gwk3k0 = v5gwk3k0 &
         + v5g(mu,nu)*k3(mu)*k0(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  v5gik3(mu) = 0.0d0
  v5gk3i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  v5gik3(mu) = v5gik3(mu) + v5g(mu,nu)*k3(nu)*metric(nu)
  v5gk3i(mu) = v5gk3i(mu) + v5g(nu,mu)*k3(nu)*metric(nu)
END DO
END DO
k0k3 = 0.0d0
DO mu = 0,3
  k0k3 = k0k3 + k0(mu)*k3(mu)*metric(mu)
END DO
call epsilont2(a5g,k0,k3,ea5gk0k3)
call epsilont1(a5g,k3,ea5gk3)
DO nu = 0,3
!
vout(nu) = -(cf*(k00*ea5gk3(nu) - 2*ea5gk0k3*k0(nu) &
 - 2*k0k3*tracev5g*k0(nu) + 2*v5gwk0k3*k0(nu) + 2*v5gwk3k0*k0(nu) &
 + k00*tracev5g*k3(nu) - k00*v5gik3(nu) - k00*v5gk3i(nu)))
vout(nu) = vout(nu)*prefactor
!
END DO
ELSE
  write(nout,*)'Not programmed for that.'
  stop
END IF
!
!-------------
!
! Alternative for IF (OVERLAP) THEN.
!
ELSE IF (nested) THEN      
!
! We have a nested graph.
!
DO mu = 0,3
  k2pt(0,mu) = k2pt2(2,mu)
  k2pt(1,mu) = k2pt2(4,mu)
  k2pt(2,mu) = k2pt2(5,mu)
  q(mu) = k2pt2(0,mu)
  k1(mu) = k2pt2(1,mu)
END DO
omegasq = q(1)**2 + q(2)**2 + q(3)**2
qsq = q(0)**2 - omegasq
omega1sq = k1(1)**2 + k1(2)**2 + k1(3)**2
!
cut2pt(0) = cut2pt2(2)
cut2pt(1) = cut2pt2(4)
cut2pt(2) = cut2pt2(5)
cut2pt(3) = cut2pt2(3)
!
! We need the factor equal to 1/k^2 for an uncut propagator
! and 1/ 2|\vec k| for a cut propagator. BUT line 1 is always
! cut, propagator 0 never cut, and the one-loop two point function 
! that is nested inside has the factor for propagators 2,3,4,5.
!   
prefactor = cf/(qsq**2*2.0d0*complexsqrt(omega1sq))
!
IF (nestedglue) THEN
!
! Our nested graph has a gluon self-energy insertion.
! Calculate OUTG according to what kind of self-energy insertion it is.
!
IF (glueloop) THEN
  kind2pt = 'gluonloop'
  call twopointgf(kind2pt,k2pt,cut2pt,mumsbar,flag,outg)
ELSE IF (quarkloop) THEN
  kind2pt = 'quarkloop'
  call twopointgf(kind2pt,k2pt,cut2pt,mumsbar,flag,outg)
END IF
!
! Now comlete the calculation for a gluon self-energy insertion.
!
DO alpha = 0,3
  temp = 0.0d0
  DO nu = 0,3
    temp = temp + outg(alpha,nu)*k1(nu)*metric(nu)
  END DO
  mk1(alpha) = temp
END DO
!
tracem = 0.0d0
dotqk1 = 0.0d0
DO mu = 0,3
  tracem = tracem + outg(mu,mu)*metric(mu)
  dotqk1 = dotqk1 + q(mu)*k1(mu)*metric(mu)
END DO
!
mqk1 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  mqk1 = mqk1 + outg(mu,nu)*q(mu)*k1(nu)*metric(mu)*metric(nu) 
END DO
END DO
!
DO alpha = 0,3
  temp = - 2.0d0*qsq*mk1(alpha)
  temp = temp + 4.0d0*q(alpha)*mqk1
  temp = temp + (qsq*k1(alpha) - 2.0d0*q(alpha)*dotqk1)*tracem
  vout(alpha) = prefactor*temp
END DO
!
! Alternative for IF (NESTEDGLUE) THEN
!
ELSE IF (nestedquark) THEN
!
! Our nested graph has a quark self-energy insertion.
! Calculate OUTQ.
!
call twopointqf(k2pt,cut2pt,mumsbar,flag,outq)
!
! Now comlete the calculation for a quark self-energy insertion.
!
! The gluon propagator in *FEYNMAN* gauge for an on-shell gluon
! with three-momentum K1(mu).
!
bareprop(0,0) = -1.0d0
DO mu = 1,3
  bareprop(0,mu) = 0.0d0
  bareprop(mu,0) = 0.0d0
  bareprop(mu,mu) = 1.0d0
DO nu = mu+1,3
  temp =0.0d0
  bareprop(mu,nu) = temp
  bareprop(nu,mu) = temp
END DO
END DO
tracebareprop = -4.0d0
!
DO alpha = 0,3
  dm(alpha) = 0.0d0
  DO nu = 0,3
   dm(alpha) = dm(alpha) + bareprop(alpha,nu)*outq(nu)*metric(nu)
  END DO
END DO
!
dqm = 0.0d0
  qm = 0.0d0
DO mu = 0,3
  qm = qm + q(mu)*outq(mu)*metric(mu)
DO nu = 0,3
 dqm = dqm + bareprop(mu,nu)*q(mu)*outq(nu)*metric(mu)*metric(nu)
END DO
END DO
!
DO alpha = 0,3
  temp = - 2.0d0*qsq*dm(alpha)
  temp = temp + 4.0d0*q(alpha)*dqm
  temp = temp  &
         + (qsq*outq(alpha) - 2.0d0*q(alpha)*qm)*tracebareprop
  vout(alpha) = prefactor*temp
END DO
!
! Close IF (NESTEDGLUE) THEN ... ELSE IF (NESTEDQUARK) THEN
!
ELSE
  write(nout,*)'Oops, something must have gone wrong.'
  stop
END IF
!
! Close  IF (OVERLAP) THEN ... ELSE IF (NESTED) THEN      
!
ELSE
  write(nout,*)'Oops, something has gone wrong.'
  stop
END IF
!
RETURN
END subroutine twopt2f
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!                     Feynman integrand in Coulomb gauge
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function feynman(graphnumber,flavorsetnumber,kc,cut,mumsbar,flag)
!
use beowulf_helpers
implicit none
! In:
integer :: graphnumber,flavorsetnumber
complex(kind=dbl), dimension(0:3*size-1,0:3) :: kc
logical, dimension(3*size-1) :: cut
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: feynman
!
! Feynman integrand function for graph GRAPHNUMBER
! with complex momenta KC and cut specified by CUT.
! Early version: 17 July 1994.
! This version written by Mathematica code of 2 July 2002 on
! 2 Jul 2002.
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
complex(kind=dbl), parameter :: gn(0:3) = &
         (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) 
!
complex(kind=dbl) :: complexsqrt
integer :: mu,nu,tau
complex(kind=dbl),dimension(256) :: x
complex(kind=dbl),dimension(0:3) :: k1,k2,k3,k4,k5,k6,k7,k8
complex(kind=dbl) :: e1,e2,e3,e4,e5,e6,e7,e8
complex(kind=dbl) :: k11,k22,k33,k44,k55,k66,k77,k88
complex(kind=dbl) :: tk11,tk22,tk33,tk44,tk55,tk66,tk77,tk88
complex(kind=dbl) :: prefactor
character(len=13) :: kind2pt2
complex(kind=dbl),dimension(0:5,0:3) :: k2pt2
logical,dimension(1:5) :: cut2pt2
character(len=9) :: kind2pt
complex(kind=dbl),dimension(0:2,0:3) :: k2pt
logical,dimension(0:3) :: cut2pt
character(len=7) :: kind3pt
complex(kind=dbl),dimension(3,0:3) :: k3pt
logical,dimension(3) :: cut3pt
!
complex(kind=dbl) :: a1qda4q,a1qik6a4qik7,a1qik7a4qik6,ea1qk3q47
complex(kind=dbl) :: ea1qzv4qk6k7,ea2qk3q67,ea3qk1q26,ea4qk1q86
complex(kind=dbl) :: ea4qzv1qk6k7,ea7ggnik1k2k4,ea7ggnik2k3k4,ea7gk1ik2k3k4
complex(kind=dbl) :: ea7gk1k2,ea7gk1k3,ea7gk1k4,ea7gk2ik1k3k4,ea7gk2k3
complex(kind=dbl) :: ea7gk2k4,ea7gk3ik1k2k4,ea7gk3k4,ea7gk4ik1k2k3
complex(kind=dbl) :: ea7gk5ignk1k2,ea7gk5ignk1k3,ea7gk5ignk1k4
complex(kind=dbl) :: ea7gk5ignk2k3,ea7gk5ignk2k4,ea7gk5ignk3k4
complex(kind=dbl) :: ea7gk5ik1k2k3,ea7gk5ik1k2k4,ea7gk5ik1k3k4
complex(kind=dbl) :: ea7gk5ik2k3k4,ea7qgnik1k2k4,ea7qgnik2k3k4
complex(kind=dbl) :: ea7qk1ik2k3k4,ea7qk1k2,ea7qk1k3,ea7qk1k4,ea7qk2ik1k3k4
complex(kind=dbl) :: ea7qk2k3,ea7qk2k4,ea7qk3ik1k2k4,ea7qk3k4,ea7qk4ik1k2k3
complex(kind=dbl) :: ea7qk5ignk1k2,ea7qk5ignk1k3,ea7qk5ignk1k4
complex(kind=dbl) :: ea7qk5ignk2k3,ea7qk5ignk2k4,ea7qk5ignk3k4
complex(kind=dbl) :: ea7qk5ik1k2k3,ea7qk5ik1k2k4,ea7qk5ik1k3k4
complex(kind=dbl) :: ea7qk5ik2k3k4,ea8ggnik1k2k4,ea8ggnik2k3k4
complex(kind=dbl) :: ea8gk1ik2k3k4,ea8gk1k2,ea8gk1k3,ea8gk1k4,ea8gk2ik1k3k4
complex(kind=dbl) :: ea8gk2k3,ea8gk2k4,ea8gk3ik1k2k4,ea8gk3k4,ea8gk4ik1k2k3
complex(kind=dbl) :: ea8gk5ignk1k2,ea8gk5ignk1k3,ea8gk5ignk1k4
complex(kind=dbl) :: ea8gk5ignk2k3,ea8gk5ignk2k4,ea8gk5ignk3k4
complex(kind=dbl) :: ea8gk5ik1k2k3,ea8gk5ik1k2k4,ea8gk5ik1k3k4
complex(kind=dbl) :: ea8gk5ik2k3k4,ea8qgnik1k2k4,ea8qgnik2k3k4
complex(kind=dbl) :: ea8qk1ik2k3k4,ea8qk1k2,ea8qk1k3,ea8qk1k4,ea8qk2ik1k3k4
complex(kind=dbl) :: ea8qk2k3,ea8qk2k4,ea8qk3ik1k2k4,ea8qk3k4,ea8qk4ik1k2k3
complex(kind=dbl) :: ea8qk5ignk1k2,ea8qk5ignk1k3,ea8qk5ignk1k4
complex(kind=dbl) :: ea8qk5ignk2k3,ea8qk5ignk2k4,ea8qk5ignk3k4
complex(kind=dbl) :: ea8qk5ik1k2k3,ea8qk5ik1k2k4,ea8qk5ik1k3k4
complex(kind=dbl) :: ea8qk5ik2k3k4,g7gwk1k2,g7gwk1k3,g7gwk2k4,g7gwk3k4
complex(kind=dbl) :: g8qwk1k2,g8qwk1k3,g8qwk2k4,g8qwk3k4,k1k2,k1k3,k1k4
complex(kind=dbl) :: k1k6,k1k7,k1q24,k1q26,k1q36,k1q84,k1q86,k1qqnb45
complex(kind=dbl) :: k1qqnb46,k1qqng45,k1qqng46,k1qqnq45,k1qqnq46,k1qqog57
complex(kind=dbl) :: k1qqog75,k1qqoq57,k1qqoq64,k2k3,k2k4,k2k6,k2k7,k2q24
complex(kind=dbl) :: k2q36,k2q84,k2q86,k3k4,k3k6,k3k7,k3q47,k3q67,k4k6,k4k7
complex(kind=dbl) :: k6k7,q15q47,q24q86,q36q84,traceg7g,traceg8q,tracev1q
complex(kind=dbl) :: tracev2q,tracev3q,tracev4q,tracev7g,tracev7q,tracev8g
complex(kind=dbl) :: tracev8q,v1qdv4q,v1qik6v4qik7,v1qik7v4qik6,v1qwk3q47
complex(kind=dbl) :: v1qwq47k3,v2qwk3q67,v2qwq67k3,v3qwk1q26,v3qwq26k1
complex(kind=dbl) :: v4qwk1q86,v4qwq86k1,v7gwgnk1,v7gwgnk2,v7gwgnk3
complex(kind=dbl) :: v7gwgnk4,v7gwk1k2,v7gwk1k3,v7gwk1k4,v7gwk2k1,v7gwk2k3
complex(kind=dbl) :: v7gwk2k4,v7gwk3k1,v7gwk3k2,v7gwk3k4,v7gwk4k1,v7gwk4k2
complex(kind=dbl) :: v7gwk4k3,v7gwk5gn,v7gwk5k1,v7gwk5k2,v7gwk5k3,v7gwk5k4
complex(kind=dbl) :: v7qwgnk1,v7qwgnk2,v7qwgnk3,v7qwgnk4,v7qwk1k2,v7qwk1k3
complex(kind=dbl) :: v7qwk1k4,v7qwk2k1,v7qwk2k3,v7qwk2k4,v7qwk3k1,v7qwk3k2
complex(kind=dbl) :: v7qwk3k4,v7qwk4k1,v7qwk4k2,v7qwk4k3,v7qwk5gn,v7qwk5k1
complex(kind=dbl) :: v7qwk5k2,v7qwk5k3,v7qwk5k4,v8gwgnk1,v8gwgnk2,v8gwgnk3
complex(kind=dbl) :: v8gwgnk4,v8gwk1k2,v8gwk1k3,v8gwk1k4,v8gwk2k1,v8gwk2k3
complex(kind=dbl) :: v8gwk2k4,v8gwk3k1,v8gwk3k2,v8gwk3k4,v8gwk4k1,v8gwk4k2
complex(kind=dbl) :: v8gwk4k3,v8gwk5gn,v8gwk5k1,v8gwk5k2,v8gwk5k3,v8gwk5k4
complex(kind=dbl) :: v8qwgnk1,v8qwgnk2,v8qwgnk3,v8qwgnk4,v8qwk1k2,v8qwk1k3
complex(kind=dbl) :: v8qwk1k4,v8qwk2k1,v8qwk2k3,v8qwk2k4,v8qwk3k1,v8qwk3k2
complex(kind=dbl) :: v8qwk3k4,v8qwk4k1,v8qwk4k2,v8qwk4k3,v8qwk5gn,v8qwk5k1
complex(kind=dbl) :: v8qwk5k2,v8qwk5k3,v8qwk5k4,a1qik6(0:3),a1qik7(0:3)
complex(kind=dbl) :: a4qik6(0:3),a4qik7(0:3),a7ggni(0:3),a7gk1i(0:3)
complex(kind=dbl) :: a7gk2i(0:3),a7gk3i(0:3),a7gk4i(0:3),a7gk5i(0:3)
complex(kind=dbl) :: a7qgni(0:3),a7qk1i(0:3),a7qk2i(0:3),a7qk3i(0:3)
complex(kind=dbl) :: a7qk4i(0:3),a7qk5i(0:3),a8ggni(0:3),a8gk1i(0:3)
complex(kind=dbl) :: a8gk2i(0:3),a8gk3i(0:3),a8gk4i(0:3),a8gk5i(0:3)
complex(kind=dbl) :: a8qgni(0:3),a8qk1i(0:3),a8qk2i(0:3),a8qk3i(0:3)
complex(kind=dbl) :: a8qk4i(0:3),a8qk5i(0:3),q15(0:3),q24(0:3),q26(0:3)
complex(kind=dbl) :: q36(0:3),q47(0:3),q67(0:3),q84(0:3),q86(0:3)
complex(kind=dbl) :: qqnb45(0:3),qqnb46(0:3),qqng45(0:3),qqng46(0:3)
complex(kind=dbl) :: qqnq45(0:3),qqnq46(0:3),qqog57(0:3),qqog75(0:3)
complex(kind=dbl) :: qqoq57(0:3),qqoq64(0:3),v1qik6(0:3),v1qik7(0:3)
complex(kind=dbl) :: v4qik6(0:3),v4qik7(0:3),a1q(0:3,0:3),a1qzv4q(0:3,0:3)
complex(kind=dbl) :: a2q(0:3,0:3),a3q(0:3,0:3),a4q(0:3,0:3)
complex(kind=dbl) :: a4qzv1q(0:3,0:3),a7g(0:3,0:3),a7q(0:3,0:3)
complex(kind=dbl) :: a8g(0:3,0:3),a8q(0:3,0:3),g7g(0:3,0:3),g8q(0:3,0:3)
complex(kind=dbl) :: v1q(0:3,0:3),v2q(0:3,0:3),v3q(0:3,0:3),v4q(0:3,0:3)
complex(kind=dbl) :: v7g(0:3,0:3),v7q(0:3,0:3),v8g(0:3,0:3),v8q(0:3,0:3)
!
DO mu = 0,3
  k1(mu) = kc(1,mu)
  k2(mu) = kc(2,mu)
  k3(mu) = kc(3,mu)
  k4(mu) = kc(4,mu)
  k5(mu) = kc(5,mu)
  k6(mu) = kc(6,mu)
  k7(mu) = kc(7,mu)
  k8(mu) = kc(8,mu)
END DO
feynman = 0.0d0
!
!------
!
IF (graphnumber .EQ. 1) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,quark,qbar,gluon,gluon,qbar,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = -k4(mu)
  k2pt2(2,mu) = k6(mu)
  k2pt2(3,mu) = -k5(mu)
  k2pt2(4,mu) = -k7(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(6)
cut2pt2(3) = cut(5)
cut2pt2(4) = cut(7)
cut2pt2(5) = cut(8)
kind2pt2 = 'nested /qggqq'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnq45)
k1qqnq45 = 0.0d0
DO mu = 0,3
  k1qqnq45 = k1qqnq45 + k1(mu)*qqnq45(mu)*metric(mu)
END DO
feynman = -8*k1qqnq45*nc
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {quark,qbar,quark,qbar,gluon,gluon,gluon,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = -k4(mu)
  k2pt2(2,mu) = k6(mu)
  k2pt2(3,mu) = -k5(mu)
  k2pt2(4,mu) = -k8(mu)
  k2pt2(5,mu) = -k7(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(6)
cut2pt2(3) = cut(5)
cut2pt2(4) = cut(8)
cut2pt2(5) = cut(7)
kind2pt2 = 'nested /qgggg'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqng45)
k1qqng45 = 0.0d0
DO mu = 0,3
  k1qqng45 = k1qqng45 + k1(mu)*qqng45(mu)*metric(mu)
END DO
feynman = -8*k1qqng45*nc
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 3) THEN
!        flavors = {quark,qbar,quark,gluon,qbar,quark,gluon,qbar}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = -k4(mu)
  k2pt2(2,mu) = k6(mu)
  k2pt2(3,mu) = -k5(mu)
  k2pt2(4,mu) = -k7(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(6)
cut2pt2(3) = cut(5)
cut2pt2(4) = cut(7)
cut2pt2(5) = cut(8)
kind2pt2 = 'nested /gqqgq'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnb45)
k1qqnb45 = 0.0d0
DO mu = 0,3
  k1qqnb45 = k1qqnb45 + k1(mu)*qqnb45(mu)*metric(mu)
END DO
feynman = -8*k1qqnb45*nc
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 4) THEN
!        flavors = {qbar,quark,qbar,quark,gluon,gluon,qbar,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k4(mu)
  k2pt2(2,mu) = k5(mu)
  k2pt2(3,mu) = -k6(mu)
  k2pt2(4,mu) = k8(mu)
  k2pt2(5,mu) = k7(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(5)
cut2pt2(3) = cut(6)
cut2pt2(4) = cut(8)
cut2pt2(5) = cut(7)
kind2pt2 = 'nested /qggqq'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnq46)
k1qqnq46 = 0.0d0
DO mu = 0,3
  k1qqnq46 = k1qqnq46 + k1(mu)*qqnq46(mu)*metric(mu)
END DO
feynman = 8*k1qqnq46*nc
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 5) THEN
!        flavors = {qbar,quark,qbar,quark,gluon,gluon,gluon,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k4(mu)
  k2pt2(2,mu) = k5(mu)
  k2pt2(3,mu) = -k6(mu)
  k2pt2(4,mu) = k7(mu)
  k2pt2(5,mu) = k8(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(5)
cut2pt2(3) = cut(6)
cut2pt2(4) = cut(7)
cut2pt2(5) = cut(8)
kind2pt2 = 'nested /qgggg'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqng46)
k1qqng46 = 0.0d0
DO mu = 0,3
  k1qqng46 = k1qqng46 + k1(mu)*qqng46(mu)*metric(mu)
END DO
feynman = 8*k1qqng46*nc
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 6) THEN
!        flavors = {qbar,quark,qbar,gluon,quark,qbar,gluon,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k4(mu)
  k2pt2(2,mu) = k5(mu)
  k2pt2(3,mu) = -k6(mu)
  k2pt2(4,mu) = k7(mu)
  k2pt2(5,mu) = k8(mu)
END DO
cut2pt2(1) = cut(4)
cut2pt2(2) = cut(5)
cut2pt2(3) = cut(6)
cut2pt2(4) = cut(7)
cut2pt2(5) = cut(8)
kind2pt2 = 'nested /gqqgq'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnb46)
k1qqnb46 = 0.0d0
DO mu = 0,3
  k1qqnb46 = k1qqnb46 + k1(mu)*qqnb46(mu)*metric(mu)
END DO
feynman = 8*k1qqnb46*nc
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 2) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,quark,gluon,qbar,gluon,quark,qbar}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt(0,mu) = k3(mu)
  k2pt(1,mu) = k6(mu)
  k2pt(2,mu) = k7(mu)
END DO
cut2pt(0) = cut(3)
cut2pt(1) = cut(6)
cut2pt(2) = cut(7)
cut2pt(3) = cut(8)
call twopointq(k2pt,cut2pt,mumsbar,flag,q36)
DO mu = 0,3
  k2pt(0,mu) = -k8(mu)
  k2pt(1,mu) = -k4(mu)
  k2pt(2,mu) = -k5(mu)
END DO
cut2pt(0) = cut(8)
cut2pt(1) = cut(4)
cut2pt(2) = cut(5)
cut2pt(3) = cut(2)
call twopointq(k2pt,cut2pt,mumsbar,flag,q84)
k1k2 = 0.0d0
k1q36 = 0.0d0
k1q84 = 0.0d0
k2q36 = 0.0d0
k2q84 = 0.0d0
q36q84 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1q36 = k1q36 + k1(mu)*q36(mu)*metric(mu)
  k1q84 = k1q84 + k1(mu)*q84(mu)*metric(mu)
  k2q36 = k2q36 + k2(mu)*q36(mu)*metric(mu)
  k2q84 = k2q84 + k2(mu)*q84(mu)*metric(mu)
  q36q84 = q36q84 + q36(mu)*q84(mu)*metric(mu)
END DO
feynman = 8*nc*(k1q84*k2q36 + k1q36*k2q84 - k1k2*q36q84)
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {qbar,quark,qbar,gluon,quark,gluon,qbar,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt(0,mu) = k2(mu)
  k2pt(1,mu) = k4(mu)
  k2pt(2,mu) = k5(mu)
END DO
cut2pt(0) = cut(2)
cut2pt(1) = cut(4)
cut2pt(2) = cut(5)
cut2pt(3) = cut(8)
call twopointq(k2pt,cut2pt,mumsbar,flag,q24)
DO mu = 0,3
  k2pt(0,mu) = k8(mu)
  k2pt(1,mu) = -k6(mu)
  k2pt(2,mu) = -k7(mu)
END DO
cut2pt(0) = cut(8)
cut2pt(1) = cut(6)
cut2pt(2) = cut(7)
cut2pt(3) = cut(3)
call twopointq(k2pt,cut2pt,mumsbar,flag,q86)
k1k2 = 0.0d0
k1q24 = 0.0d0
k1q86 = 0.0d0
k2q24 = 0.0d0
k2q86 = 0.0d0
q24q86 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1q24 = k1q24 + k1(mu)*q24(mu)*metric(mu)
  k1q86 = k1q86 + k1(mu)*q86(mu)*metric(mu)
  k2q24 = k2q24 + k2(mu)*q24(mu)*metric(mu)
  k2q86 = k2q86 + k2(mu)*q86(mu)*metric(mu)
  q24q86 = q24q86 + q24(mu)*q86(mu)*metric(mu)
END DO
feynman = 8*nc*(k1q86*k2q24 + k1q24*k2q86 - k1k2*q24q86)
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 3) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,quark,gluon,qbar,quark,gluon,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = k6(mu)
  k2pt2(2,mu) = k7(mu)
  k2pt2(3,mu) = -k4(mu)
  k2pt2(4,mu) = -k5(mu)
  k2pt2(5,mu) = k8(mu)
END DO
cut2pt2(1) = cut(6)
cut2pt2(2) = cut(7)
cut2pt2(3) = cut(4)
cut2pt2(4) = cut(5)
cut2pt2(5) = cut(8)
kind2pt2 = 'overlap/qggqq'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqoq64)
k1qqoq64 = 0.0d0
DO mu = 0,3
  k1qqoq64 = k1qqoq64 + k1(mu)*qqoq64(mu)*metric(mu)
END DO
feynman = -8*k1qqoq64*nc
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {quark,qbar,quark,gluon,qbar,gluon,quark,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k3(mu)
  k2pt2(1,mu) = k7(mu)
  k2pt2(2,mu) = k6(mu)
  k2pt2(3,mu) = -k5(mu)
  k2pt2(4,mu) = -k4(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(7)
cut2pt2(2) = cut(6)
cut2pt2(3) = cut(5)
cut2pt2(4) = cut(4)
cut2pt2(5) = cut(8)
kind2pt2 = 'overlap/qgqgg'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqog75)
k1qqog75 = 0.0d0
DO mu = 0,3
  k1qqog75 = k1qqog75 + k1(mu)*qqog75(mu)*metric(mu)
END DO
feynman = -8*k1qqog75*nc
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 3) THEN
!        flavors = {qbar,quark,qbar,gluon,quark,qbar,gluon,qbar}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k5(mu)
  k2pt2(2,mu) = k4(mu)
  k2pt2(3,mu) = -k7(mu)
  k2pt2(4,mu) = -k6(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(5)
cut2pt2(2) = cut(4)
cut2pt2(3) = cut(7)
cut2pt2(4) = cut(6)
cut2pt2(5) = cut(8)
kind2pt2 = 'overlap/qggqq'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqoq57)
k1qqoq57 = 0.0d0
DO mu = 0,3
  k1qqoq57 = k1qqoq57 + k1(mu)*qqoq57(mu)*metric(mu)
END DO
feynman = 8*k1qqoq57*nc
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 4) THEN
!        flavors = {qbar,quark,qbar,gluon,quark,gluon,qbar,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k2pt2(0,mu) = k2(mu)
  k2pt2(1,mu) = k5(mu)
  k2pt2(2,mu) = k4(mu)
  k2pt2(3,mu) = -k7(mu)
  k2pt2(4,mu) = -k6(mu)
  k2pt2(5,mu) = -k8(mu)
END DO
cut2pt2(1) = cut(5)
cut2pt2(2) = cut(4)
cut2pt2(3) = cut(7)
cut2pt2(4) = cut(6)
cut2pt2(5) = cut(8)
kind2pt2 = 'overlap/qgqgg'
call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqog57)
k1qqog57 = 0.0d0
DO mu = 0,3
  k1qqog57 = k1qqog57 + k1(mu)*qqog57(mu)*metric(mu)
END DO
feynman = 8*k1qqog57*nc
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 4) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,qbar,quark,gluon,gluon,qbar,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
DO mu = 0,3
  k2pt(0,mu) = k5(mu)
  k2pt(1,mu) = k8(mu)
  k2pt(2,mu) = k7(mu)
END DO
cut2pt(0) = cut(5)
cut2pt(1) = cut(8)
cut2pt(2) = cut(7)
cut2pt(3) = cut(6)
kind2pt = 'quarkloop'
call twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,g8q)
traceg8q = 0.0d0
DO mu = 0,3
  traceg8q = traceg8q + g8q(mu,mu)*metric(mu)
END DO
g8qwk1k2 = 0.0d0
g8qwk1k3 = 0.0d0
g8qwk2k4 = 0.0d0
g8qwk3k4 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  g8qwk1k2 = g8qwk1k2  &
    + g8q(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  g8qwk1k3 = g8qwk1k3  &
    + g8q(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  g8qwk2k4 = g8qwk2k4  &
    + g8q(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  g8qwk3k4 = g8qwk3k4  &
    + g8q(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
END DO
END DO
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
feynman = -8*cf*nc*(2*g8qwk3k4*k1k2 - 2*g8qwk2k4*k1k3 &
  - 2*g8qwk1k3*k2k4 + 2*g8qwk1k2*k3k4 + k1k4*k2k3*traceg8q &
  + k1k3*k2k4*traceg8q - k1k2*k3k4*traceg8q)
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {quark,qbar,qbar,quark,gluon,gluon,gluon,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
DO mu = 0,3
  k2pt(0,mu) = k5(mu)
  k2pt(1,mu) = k7(mu)
  k2pt(2,mu) = k8(mu)
END DO
cut2pt(0) = cut(5)
cut2pt(1) = cut(7)
cut2pt(2) = cut(8)
cut2pt(3) = cut(6)
kind2pt = 'gluonloop'
call twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,g7g)
traceg7g = 0.0d0
DO mu = 0,3
  traceg7g = traceg7g + g7g(mu,mu)*metric(mu)
END DO
g7gwk1k2 = 0.0d0
g7gwk1k3 = 0.0d0
g7gwk2k4 = 0.0d0
g7gwk3k4 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  g7gwk1k2 = g7gwk1k2  &
    + g7g(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  g7gwk1k3 = g7gwk1k3  &
    + g7g(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  g7gwk2k4 = g7gwk2k4  &
    + g7g(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  g7gwk3k4 = g7gwk3k4  &
    + g7g(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
END DO
END DO
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
feynman = -8*cf*nc*(2*g7gwk3k4*k1k2 - 2*g7gwk2k4*k1k3 &
  - 2*g7gwk1k3*k2k4 + 2*g7gwk1k2*k3k4 + k1k4*k2k3*traceg7g &
  + k1k3*k2k4*traceg7g - k1k2*k3k4*traceg7g)
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 5) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,qbar,quark,gluon,qbar,gluon,quark}
!
prefactor = 1.0d0
e3 = k3(0)
tk33 = 0.0d0
DO mu = 1,3
  tk33 = tk33 - k3(mu)**2
END DO
k33 = e3**2 + tk33
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
DO mu = 0,3
  k3pt(1,mu) = -k1(mu)
  k3pt(2,mu) = k2(mu)
  k3pt(3,mu) = -k5(mu)
END DO
cut3pt(1) = cut(1)
cut3pt(2) = cut(2)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v1q,a1q)
DO mu = 0,3
  k2pt(0,mu) = k4(mu)
  k2pt(1,mu) = k7(mu)
  k2pt(2,mu) = k8(mu)
END DO
cut2pt(0) = cut(4)
cut2pt(1) = cut(7)
cut2pt(2) = cut(8)
cut2pt(3) = cut(6)
call twopointq(k2pt,cut2pt,mumsbar,flag,q47)
tracev1q = 0.0d0
DO mu = 0,3
  tracev1q = tracev1q + v1q(mu,mu)*metric(mu)
END DO
v1qwk3q47 = 0.0d0
v1qwq47k3 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v1qwk3q47 = v1qwk3q47  &
    + v1q(mu,nu)*k3(mu)*q47(nu)*metric(mu)*metric(nu)
  v1qwq47k3 = v1qwq47k3  &
    + v1q(mu,nu)*q47(mu)*k3(nu)*metric(mu)*metric(nu)
END DO
END DO
k3q47 = 0.0d0
DO mu = 0,3
  k3q47 = k3q47 + k3(mu)*q47(mu)*metric(mu)
END DO
call epsilont2(a1q,k3,q47,ea1qk3q47)
feynman = -4*nc*(ea1qk3q47 - k3q47*tracev1q + v1qwk3q47 &
  + v1qwq47k3)
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {qbar,quark,quark,qbar,gluon,quark,gluon,qbar}
!
prefactor = 1.0d0
e3 = k3(0)
tk33 = 0.0d0
DO mu = 1,3
  tk33 = tk33 - k3(mu)**2
END DO
k33 = e3**2 + tk33
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
DO mu = 0,3
  k3pt(1,mu) = -k2(mu)
  k3pt(2,mu) = k1(mu)
  k3pt(3,mu) = k5(mu)
END DO
cut3pt(1) = cut(2)
cut3pt(2) = cut(1)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v2q,a2q)
DO mu = 0,3
  k2pt(0,mu) = k6(mu)
  k2pt(1,mu) = -k7(mu)
  k2pt(2,mu) = -k8(mu)
END DO
cut2pt(0) = cut(6)
cut2pt(1) = cut(7)
cut2pt(2) = cut(8)
cut2pt(3) = cut(4)
call twopointq(k2pt,cut2pt,mumsbar,flag,q67)
tracev2q = 0.0d0
DO mu = 0,3
  tracev2q = tracev2q + v2q(mu,mu)*metric(mu)
END DO
v2qwk3q67 = 0.0d0
v2qwq67k3 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v2qwk3q67 = v2qwk3q67  &
    + v2q(mu,nu)*k3(mu)*q67(nu)*metric(mu)*metric(nu)
  v2qwq67k3 = v2qwq67k3  &
    + v2q(mu,nu)*q67(mu)*k3(nu)*metric(mu)*metric(nu)
END DO
END DO
k3q67 = 0.0d0
DO mu = 0,3
  k3q67 = k3q67 + k3(mu)*q67(mu)*metric(mu)
END DO
call epsilont2(a2q,k3,q67,ea2qk3q67)
feynman = -4*nc*(ea2qk3q67 + k3q67*tracev2q - v2qwk3q67 &
  - v2qwq67k3)
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 6) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,qbar,quark,gluon,gluon,qbar,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k3pt(1,mu) = -k4(mu)
  k3pt(2,mu) = k3(mu)
  k3pt(3,mu) = k5(mu)
END DO
cut3pt(1) = cut(4)
cut3pt(2) = cut(3)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q)
DO mu = 0,3
  k2pt(0,mu) = k8(mu)
  k2pt(1,mu) = -k6(mu)
  k2pt(2,mu) = -k7(mu)
END DO
cut2pt(0) = cut(8)
cut2pt(1) = cut(6)
cut2pt(2) = cut(7)
cut2pt(3) = cut(2)
call twopointq(k2pt,cut2pt,mumsbar,flag,q86)
tracev4q = 0.0d0
DO mu = 0,3
  tracev4q = tracev4q + v4q(mu,mu)*metric(mu)
END DO
v4qwk1q86 = 0.0d0
v4qwq86k1 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v4qwk1q86 = v4qwk1q86  &
    + v4q(mu,nu)*k1(mu)*q86(nu)*metric(mu)*metric(nu)
  v4qwq86k1 = v4qwq86k1  &
    + v4q(mu,nu)*q86(mu)*k1(nu)*metric(mu)*metric(nu)
END DO
END DO
k1q86 = 0.0d0
DO mu = 0,3
  k1q86 = k1q86 + k1(mu)*q86(mu)*metric(mu)
END DO
call epsilont2(a4q,k1,q86,ea4qk1q86)
feynman = -4*nc*(ea4qk1q86 + k1q86*tracev4q - v4qwk1q86 &
  - v4qwq86k1)
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {qbar,quark,quark,qbar,gluon,gluon,quark,qbar}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
END DO
k11 = e1**2 + tk11
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
DO mu = 0,3
  k3pt(1,mu) = -k3(mu)
  k3pt(2,mu) = k4(mu)
  k3pt(3,mu) = -k5(mu)
END DO
cut3pt(1) = cut(3)
cut3pt(2) = cut(4)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v3q,a3q)
DO mu = 0,3
  k2pt(0,mu) = k2(mu)
  k2pt(1,mu) = k6(mu)
  k2pt(2,mu) = k7(mu)
END DO
cut2pt(0) = cut(2)
cut2pt(1) = cut(6)
cut2pt(2) = cut(7)
cut2pt(3) = cut(8)
call twopointq(k2pt,cut2pt,mumsbar,flag,q26)
tracev3q = 0.0d0
DO mu = 0,3
  tracev3q = tracev3q + v3q(mu,mu)*metric(mu)
END DO
v3qwk1q26 = 0.0d0
v3qwq26k1 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v3qwk1q26 = v3qwk1q26  &
    + v3q(mu,nu)*k1(mu)*q26(nu)*metric(mu)*metric(nu)
  v3qwq26k1 = v3qwq26k1  &
    + v3q(mu,nu)*q26(mu)*k1(nu)*metric(mu)*metric(nu)
END DO
END DO
k1q26 = 0.0d0
DO mu = 0,3
  k1q26 = k1q26 + k1(mu)*q26(mu)*metric(mu)
END DO
call epsilont2(a3q,k1,q26,ea3qk1q26)
feynman = -4*nc*(ea3qk1q26 - k1q26*tracev3q + v3qwk1q26 &
  + v3qwq26k1)
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 7) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,qbar,quark,gluon,qbar,gluon,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
DO mu = 0,3
  k3pt(1,mu) = k7(mu)
  k3pt(2,mu) = -k8(mu)
  k3pt(3,mu) = -k6(mu)
END DO
cut3pt(1) = cut(7)
cut3pt(2) = cut(8)
cut3pt(3) = cut(6)
kind3pt = 'qqg/ggq'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v7g,a7g)
tracev7g = 0.0d0
DO mu = 0,3
  tracev7g = tracev7g + v7g(mu,mu)*metric(mu)
END DO
v7gwgnk1 = 0.0d0
v7gwgnk2 = 0.0d0
v7gwgnk3 = 0.0d0
v7gwgnk4 = 0.0d0
v7gwk1k2 = 0.0d0
v7gwk1k3 = 0.0d0
v7gwk1k4 = 0.0d0
v7gwk2k1 = 0.0d0
v7gwk2k3 = 0.0d0
v7gwk2k4 = 0.0d0
v7gwk3k1 = 0.0d0
v7gwk3k2 = 0.0d0
v7gwk3k4 = 0.0d0
v7gwk4k1 = 0.0d0
v7gwk4k2 = 0.0d0
v7gwk4k3 = 0.0d0
v7gwk5gn = 0.0d0
v7gwk5k1 = 0.0d0
v7gwk5k2 = 0.0d0
v7gwk5k3 = 0.0d0
v7gwk5k4 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v7gwgnk1 = v7gwgnk1  &
    + v7g(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu)
  v7gwgnk2 = v7gwgnk2  &
    + v7g(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu)
  v7gwgnk3 = v7gwgnk3  &
    + v7g(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu)
  v7gwgnk4 = v7gwgnk4  &
    + v7g(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu)
  v7gwk1k2 = v7gwk1k2  &
    + v7g(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  v7gwk1k3 = v7gwk1k3  &
    + v7g(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  v7gwk1k4 = v7gwk1k4  &
    + v7g(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu)
  v7gwk2k1 = v7gwk2k1  &
    + v7g(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu)
  v7gwk2k3 = v7gwk2k3  &
    + v7g(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu)
  v7gwk2k4 = v7gwk2k4  &
    + v7g(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  v7gwk3k1 = v7gwk3k1  &
    + v7g(mu,nu)*k3(mu)*k1(nu)*metric(mu)*metric(nu)
  v7gwk3k2 = v7gwk3k2  &
    + v7g(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu)
  v7gwk3k4 = v7gwk3k4  &
    + v7g(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
  v7gwk4k1 = v7gwk4k1  &
    + v7g(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu)
  v7gwk4k2 = v7gwk4k2  &
    + v7g(mu,nu)*k4(mu)*k2(nu)*metric(mu)*metric(nu)
  v7gwk4k3 = v7gwk4k3  &
    + v7g(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu)
  v7gwk5gn = v7gwk5gn  &
    + v7g(mu,nu)*k5(mu)*gn(nu)*metric(mu)*metric(nu)
  v7gwk5k1 = v7gwk5k1  &
    + v7g(mu,nu)*k5(mu)*k1(nu)*metric(mu)*metric(nu)
  v7gwk5k2 = v7gwk5k2  &
    + v7g(mu,nu)*k5(mu)*k2(nu)*metric(mu)*metric(nu)
  v7gwk5k3 = v7gwk5k3  &
    + v7g(mu,nu)*k5(mu)*k3(nu)*metric(mu)*metric(nu)
  v7gwk5k4 = v7gwk5k4  &
    + v7g(mu,nu)*k5(mu)*k4(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
a7ggni(mu) = 0.0d0
a7gk1i(mu) = 0.0d0
a7gk2i(mu) = 0.0d0
a7gk3i(mu) = 0.0d0
a7gk4i(mu) = 0.0d0
a7gk5i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a7ggni(mu) = a7ggni(mu) + a7g(nu,mu)*gn(nu)*metric(nu)
  a7gk1i(mu) = a7gk1i(mu) + a7g(nu,mu)*k1(nu)*metric(nu)
  a7gk2i(mu) = a7gk2i(mu) + a7g(nu,mu)*k2(nu)*metric(nu)
  a7gk3i(mu) = a7gk3i(mu) + a7g(nu,mu)*k3(nu)*metric(nu)
  a7gk4i(mu) = a7gk4i(mu) + a7g(nu,mu)*k4(nu)*metric(nu)
  a7gk5i(mu) = a7gk5i(mu) + a7g(nu,mu)*k5(nu)*metric(nu)
END DO
END DO
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
call epsilont2(a7g,k1,k2,ea7gk1k2)
call epsilont2(a7g,k1,k3,ea7gk1k3)
call epsilont2(a7g,k1,k4,ea7gk1k4)
call epsilont2(a7g,k2,k3,ea7gk2k3)
call epsilont2(a7g,k2,k4,ea7gk2k4)
call epsilont2(a7g,k3,k4,ea7gk3k4)
call epsilon4(a7ggni,k1,k2,k4,ea7ggnik1k2k4)
call epsilon4(a7ggni,k2,k3,k4,ea7ggnik2k3k4)
call epsilon4(a7gk1i,k2,k3,k4,ea7gk1ik2k3k4)
call epsilon4(a7gk2i,k1,k3,k4,ea7gk2ik1k3k4)
call epsilon4(a7gk3i,k1,k2,k4,ea7gk3ik1k2k4)
call epsilon4(a7gk4i,k1,k2,k3,ea7gk4ik1k2k3)
call epsilon4(a7gk5i,gn,k1,k2,ea7gk5ignk1k2)
call epsilon4(a7gk5i,gn,k1,k3,ea7gk5ignk1k3)
call epsilon4(a7gk5i,gn,k1,k4,ea7gk5ignk1k4)
call epsilon4(a7gk5i,gn,k2,k3,ea7gk5ignk2k3)
call epsilon4(a7gk5i,gn,k2,k4,ea7gk5ignk2k4)
call epsilon4(a7gk5i,gn,k3,k4,ea7gk5ignk3k4)
call epsilon4(a7gk5i,k1,k2,k3,ea7gk5ik1k2k3)
call epsilon4(a7gk5i,k1,k2,k4,ea7gk5ik1k2k4)
call epsilon4(a7gk5i,k1,k3,k4,ea7gk5ik1k3k4)
call epsilon4(a7gk5i,k2,k3,k4,ea7gk5ik2k3k4)
x(1) = k33*(ea7gk5ik1k2k4 + k2k4*v7gwk5k1 - k1k4*v7gwk5k2 &
  - k1k2*v7gwk5k4) + k11*(-ea7gk5ik2k3k4 - k3k4*v7gwk5k2 &
  + k2k4*v7gwk5k3 - k2k3*v7gwk5k4)
x(2) = ea7gk1ik2k3k4 + ea7gk2ik1k3k4 - ea7gk3ik1k2k4 &
  - ea7gk4ik1k2k3 + k1k2*(ea7gk3k4 + v7gwk3k4 + v7gwk4k3)
x(3) = -ea7gk2k4 - v7gwk2k4 - v7gwk4k2
x(4) = x(2) + k1k3*x(3)
x(5) = -ea7gk2k3 - v7gwk2k3 + v7gwk3k2
x(6) = x(4) + k1k4*x(5)
x(7) = -ea7gk1k4 + k1k4*tracev7g + v7gwk1k4 - v7gwk4k1
x(8) = x(6) + k2k3*x(7)
x(9) = ea7gk1k3 + k1k3*tracev7g - v7gwk1k3 - v7gwk3k1
x(10) = x(8) + k2k4*x(9)
x(11) = -ea7gk1k2 - k1k2*tracev7g + v7gwk1k2 + v7gwk2k1
x(12) = x(10) + k3k4*x(11)
x(13) = x(1) + tk55*x(12)
x(14) = -(e4*ea7gk5ik1k2k3) - e3*ea7gk5ik1k2k4 + e2*ea7gk5ik1k3k4 &
  + e1*ea7gk5ik2k3k4 + ea7ggnik2k3k4*k11 - ea7ggnik1k2k4*k33 + k1k3 &
 *(ea7gk5ignk2k4 - e4*v7gwk5k2 - e2*v7gwk5k4)
x(15) = -ea7gk5ignk3k4 + k33*v7gwgnk4 + e4*v7gwk5k3 + e3*v7gwk5k4
x(16) = x(14) + k1k2*x(15)
x(17) = ea7gk5ignk2k3 + k33*v7gwgnk2 + e3*v7gwk5k2 - e2*v7gwk5k3
x(18) = x(16) + k1k4*x(17)
x(19) = ea7gk5ignk1k4 + k11*v7gwgnk4 + k1k4*v7gwk5gn &
  - e4*v7gwk5k1 + e1*v7gwk5k4
x(20) = x(18) + k2k3*x(19)
x(21) = ea7gk5ignk1k2 + k11*v7gwgnk2 - k1k2*v7gwk5gn &
  + e2*v7gwk5k1 + e1*v7gwk5k2
x(22) = x(20) + k3k4*x(21)
x(23) = -ea7gk5ignk1k3 - k33*v7gwgnk1 - k11*v7gwgnk3 &
  + k1k3*v7gwk5gn - e3*v7gwk5k1 - e1*v7gwk5k3
x(24) = x(22) + k2k4*x(23)
x(25) = x(13) + e5*x(24)
feynman = (8*cf*nc*x(25))/tk55
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {quark,qbar,qbar,quark,gluon,gluon,qbar,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
DO mu = 0,3
  k3pt(1,mu) = k7(mu)
  k3pt(2,mu) = -k8(mu)
  k3pt(3,mu) = -k6(mu)
END DO
cut3pt(1) = cut(7)
cut3pt(2) = cut(8)
cut3pt(3) = cut(6)
kind3pt = 'qqg/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v7q,a7q)
tracev7q = 0.0d0
DO mu = 0,3
  tracev7q = tracev7q + v7q(mu,mu)*metric(mu)
END DO
v7qwgnk1 = 0.0d0
v7qwgnk2 = 0.0d0
v7qwgnk3 = 0.0d0
v7qwgnk4 = 0.0d0
v7qwk1k2 = 0.0d0
v7qwk1k3 = 0.0d0
v7qwk1k4 = 0.0d0
v7qwk2k1 = 0.0d0
v7qwk2k3 = 0.0d0
v7qwk2k4 = 0.0d0
v7qwk3k1 = 0.0d0
v7qwk3k2 = 0.0d0
v7qwk3k4 = 0.0d0
v7qwk4k1 = 0.0d0
v7qwk4k2 = 0.0d0
v7qwk4k3 = 0.0d0
v7qwk5gn = 0.0d0
v7qwk5k1 = 0.0d0
v7qwk5k2 = 0.0d0
v7qwk5k3 = 0.0d0
v7qwk5k4 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v7qwgnk1 = v7qwgnk1  &
    + v7q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu)
  v7qwgnk2 = v7qwgnk2  &
    + v7q(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu)
  v7qwgnk3 = v7qwgnk3  &
    + v7q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu)
  v7qwgnk4 = v7qwgnk4  &
    + v7q(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu)
  v7qwk1k2 = v7qwk1k2  &
    + v7q(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  v7qwk1k3 = v7qwk1k3  &
    + v7q(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  v7qwk1k4 = v7qwk1k4  &
    + v7q(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu)
  v7qwk2k1 = v7qwk2k1  &
    + v7q(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu)
  v7qwk2k3 = v7qwk2k3  &
    + v7q(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu)
  v7qwk2k4 = v7qwk2k4  &
    + v7q(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  v7qwk3k1 = v7qwk3k1  &
    + v7q(mu,nu)*k3(mu)*k1(nu)*metric(mu)*metric(nu)
  v7qwk3k2 = v7qwk3k2  &
    + v7q(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu)
  v7qwk3k4 = v7qwk3k4  &
    + v7q(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
  v7qwk4k1 = v7qwk4k1  &
    + v7q(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu)
  v7qwk4k2 = v7qwk4k2  &
    + v7q(mu,nu)*k4(mu)*k2(nu)*metric(mu)*metric(nu)
  v7qwk4k3 = v7qwk4k3  &
    + v7q(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu)
  v7qwk5gn = v7qwk5gn  &
    + v7q(mu,nu)*k5(mu)*gn(nu)*metric(mu)*metric(nu)
  v7qwk5k1 = v7qwk5k1  &
    + v7q(mu,nu)*k5(mu)*k1(nu)*metric(mu)*metric(nu)
  v7qwk5k2 = v7qwk5k2  &
    + v7q(mu,nu)*k5(mu)*k2(nu)*metric(mu)*metric(nu)
  v7qwk5k3 = v7qwk5k3  &
    + v7q(mu,nu)*k5(mu)*k3(nu)*metric(mu)*metric(nu)
  v7qwk5k4 = v7qwk5k4  &
    + v7q(mu,nu)*k5(mu)*k4(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
a7qgni(mu) = 0.0d0
a7qk1i(mu) = 0.0d0
a7qk2i(mu) = 0.0d0
a7qk3i(mu) = 0.0d0
a7qk4i(mu) = 0.0d0
a7qk5i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a7qgni(mu) = a7qgni(mu) + a7q(nu,mu)*gn(nu)*metric(nu)
  a7qk1i(mu) = a7qk1i(mu) + a7q(nu,mu)*k1(nu)*metric(nu)
  a7qk2i(mu) = a7qk2i(mu) + a7q(nu,mu)*k2(nu)*metric(nu)
  a7qk3i(mu) = a7qk3i(mu) + a7q(nu,mu)*k3(nu)*metric(nu)
  a7qk4i(mu) = a7qk4i(mu) + a7q(nu,mu)*k4(nu)*metric(nu)
  a7qk5i(mu) = a7qk5i(mu) + a7q(nu,mu)*k5(nu)*metric(nu)
END DO
END DO
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
call epsilont2(a7q,k1,k2,ea7qk1k2)
call epsilont2(a7q,k1,k3,ea7qk1k3)
call epsilont2(a7q,k1,k4,ea7qk1k4)
call epsilont2(a7q,k2,k3,ea7qk2k3)
call epsilont2(a7q,k2,k4,ea7qk2k4)
call epsilont2(a7q,k3,k4,ea7qk3k4)
call epsilon4(a7qgni,k1,k2,k4,ea7qgnik1k2k4)
call epsilon4(a7qgni,k2,k3,k4,ea7qgnik2k3k4)
call epsilon4(a7qk1i,k2,k3,k4,ea7qk1ik2k3k4)
call epsilon4(a7qk2i,k1,k3,k4,ea7qk2ik1k3k4)
call epsilon4(a7qk3i,k1,k2,k4,ea7qk3ik1k2k4)
call epsilon4(a7qk4i,k1,k2,k3,ea7qk4ik1k2k3)
call epsilon4(a7qk5i,gn,k1,k2,ea7qk5ignk1k2)
call epsilon4(a7qk5i,gn,k1,k3,ea7qk5ignk1k3)
call epsilon4(a7qk5i,gn,k1,k4,ea7qk5ignk1k4)
call epsilon4(a7qk5i,gn,k2,k3,ea7qk5ignk2k3)
call epsilon4(a7qk5i,gn,k2,k4,ea7qk5ignk2k4)
call epsilon4(a7qk5i,gn,k3,k4,ea7qk5ignk3k4)
call epsilon4(a7qk5i,k1,k2,k3,ea7qk5ik1k2k3)
call epsilon4(a7qk5i,k1,k2,k4,ea7qk5ik1k2k4)
call epsilon4(a7qk5i,k1,k3,k4,ea7qk5ik1k3k4)
call epsilon4(a7qk5i,k2,k3,k4,ea7qk5ik2k3k4)
x(1) = k33*(ea7qk5ik1k2k4 + k2k4*v7qwk5k1 - k1k4*v7qwk5k2 &
  - k1k2*v7qwk5k4) + k11*(-ea7qk5ik2k3k4 - k3k4*v7qwk5k2 &
  + k2k4*v7qwk5k3 - k2k3*v7qwk5k4)
x(2) = ea7qk1ik2k3k4 + ea7qk2ik1k3k4 - ea7qk3ik1k2k4 &
  - ea7qk4ik1k2k3 + k1k2*(ea7qk3k4 + v7qwk3k4 + v7qwk4k3)
x(3) = -ea7qk2k4 - v7qwk2k4 - v7qwk4k2
x(4) = x(2) + k1k3*x(3)
x(5) = -ea7qk2k3 - v7qwk2k3 + v7qwk3k2
x(6) = x(4) + k1k4*x(5)
x(7) = -ea7qk1k4 + k1k4*tracev7q + v7qwk1k4 - v7qwk4k1
x(8) = x(6) + k2k3*x(7)
x(9) = ea7qk1k3 + k1k3*tracev7q - v7qwk1k3 - v7qwk3k1
x(10) = x(8) + k2k4*x(9)
x(11) = -ea7qk1k2 - k1k2*tracev7q + v7qwk1k2 + v7qwk2k1
x(12) = x(10) + k3k4*x(11)
x(13) = x(1) + tk55*x(12)
x(14) = -(e4*ea7qk5ik1k2k3) - e3*ea7qk5ik1k2k4 + e2*ea7qk5ik1k3k4 &
  + e1*ea7qk5ik2k3k4 + ea7qgnik2k3k4*k11 - ea7qgnik1k2k4*k33 + k1k3 &
 *(ea7qk5ignk2k4 - e4*v7qwk5k2 - e2*v7qwk5k4)
x(15) = -ea7qk5ignk3k4 + k33*v7qwgnk4 + e4*v7qwk5k3 + e3*v7qwk5k4
x(16) = x(14) + k1k2*x(15)
x(17) = ea7qk5ignk2k3 + k33*v7qwgnk2 + e3*v7qwk5k2 - e2*v7qwk5k3
x(18) = x(16) + k1k4*x(17)
x(19) = ea7qk5ignk1k4 + k11*v7qwgnk4 + k1k4*v7qwk5gn &
  - e4*v7qwk5k1 + e1*v7qwk5k4
x(20) = x(18) + k2k3*x(19)
x(21) = ea7qk5ignk1k2 + k11*v7qwgnk2 - k1k2*v7qwk5gn &
  + e2*v7qwk5k1 + e1*v7qwk5k2
x(22) = x(20) + k3k4*x(21)
x(23) = -ea7qk5ignk1k3 - k33*v7qwgnk1 - k11*v7qwgnk3 &
  + k1k3*v7qwk5gn - e3*v7qwk5k1 - e1*v7qwk5k3
x(24) = x(22) + k2k4*x(23)
x(25) = x(13) + e5*x(24)
feynman = (8*cf*nc*x(25))/tk55
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 3) THEN
!        flavors = {qbar,quark,quark,qbar,gluon,quark,gluon,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
DO mu = 0,3
  k3pt(1,mu) = k8(mu)
  k3pt(2,mu) = -k7(mu)
  k3pt(3,mu) = k6(mu)
END DO
cut3pt(1) = cut(8)
cut3pt(2) = cut(7)
cut3pt(3) = cut(6)
kind3pt = 'qqg/ggq'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v8g,a8g)
tracev8g = 0.0d0
DO mu = 0,3
  tracev8g = tracev8g + v8g(mu,mu)*metric(mu)
END DO
v8gwgnk1 = 0.0d0
v8gwgnk2 = 0.0d0
v8gwgnk3 = 0.0d0
v8gwgnk4 = 0.0d0
v8gwk1k2 = 0.0d0
v8gwk1k3 = 0.0d0
v8gwk1k4 = 0.0d0
v8gwk2k1 = 0.0d0
v8gwk2k3 = 0.0d0
v8gwk2k4 = 0.0d0
v8gwk3k1 = 0.0d0
v8gwk3k2 = 0.0d0
v8gwk3k4 = 0.0d0
v8gwk4k1 = 0.0d0
v8gwk4k2 = 0.0d0
v8gwk4k3 = 0.0d0
v8gwk5gn = 0.0d0
v8gwk5k1 = 0.0d0
v8gwk5k2 = 0.0d0
v8gwk5k3 = 0.0d0
v8gwk5k4 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v8gwgnk1 = v8gwgnk1  &
    + v8g(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu)
  v8gwgnk2 = v8gwgnk2  &
    + v8g(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu)
  v8gwgnk3 = v8gwgnk3  &
    + v8g(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu)
  v8gwgnk4 = v8gwgnk4  &
    + v8g(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu)
  v8gwk1k2 = v8gwk1k2  &
    + v8g(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  v8gwk1k3 = v8gwk1k3  &
    + v8g(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  v8gwk1k4 = v8gwk1k4  &
    + v8g(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu)
  v8gwk2k1 = v8gwk2k1  &
    + v8g(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu)
  v8gwk2k3 = v8gwk2k3  &
    + v8g(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu)
  v8gwk2k4 = v8gwk2k4  &
    + v8g(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  v8gwk3k1 = v8gwk3k1  &
    + v8g(mu,nu)*k3(mu)*k1(nu)*metric(mu)*metric(nu)
  v8gwk3k2 = v8gwk3k2  &
    + v8g(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu)
  v8gwk3k4 = v8gwk3k4  &
    + v8g(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
  v8gwk4k1 = v8gwk4k1  &
    + v8g(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu)
  v8gwk4k2 = v8gwk4k2  &
    + v8g(mu,nu)*k4(mu)*k2(nu)*metric(mu)*metric(nu)
  v8gwk4k3 = v8gwk4k3  &
    + v8g(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu)
  v8gwk5gn = v8gwk5gn  &
    + v8g(mu,nu)*k5(mu)*gn(nu)*metric(mu)*metric(nu)
  v8gwk5k1 = v8gwk5k1  &
    + v8g(mu,nu)*k5(mu)*k1(nu)*metric(mu)*metric(nu)
  v8gwk5k2 = v8gwk5k2  &
    + v8g(mu,nu)*k5(mu)*k2(nu)*metric(mu)*metric(nu)
  v8gwk5k3 = v8gwk5k3  &
    + v8g(mu,nu)*k5(mu)*k3(nu)*metric(mu)*metric(nu)
  v8gwk5k4 = v8gwk5k4  &
    + v8g(mu,nu)*k5(mu)*k4(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
a8ggni(mu) = 0.0d0
a8gk1i(mu) = 0.0d0
a8gk2i(mu) = 0.0d0
a8gk3i(mu) = 0.0d0
a8gk4i(mu) = 0.0d0
a8gk5i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a8ggni(mu) = a8ggni(mu) + a8g(nu,mu)*gn(nu)*metric(nu)
  a8gk1i(mu) = a8gk1i(mu) + a8g(nu,mu)*k1(nu)*metric(nu)
  a8gk2i(mu) = a8gk2i(mu) + a8g(nu,mu)*k2(nu)*metric(nu)
  a8gk3i(mu) = a8gk3i(mu) + a8g(nu,mu)*k3(nu)*metric(nu)
  a8gk4i(mu) = a8gk4i(mu) + a8g(nu,mu)*k4(nu)*metric(nu)
  a8gk5i(mu) = a8gk5i(mu) + a8g(nu,mu)*k5(nu)*metric(nu)
END DO
END DO
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
call epsilont2(a8g,k1,k2,ea8gk1k2)
call epsilont2(a8g,k1,k3,ea8gk1k3)
call epsilont2(a8g,k1,k4,ea8gk1k4)
call epsilont2(a8g,k2,k3,ea8gk2k3)
call epsilont2(a8g,k2,k4,ea8gk2k4)
call epsilont2(a8g,k3,k4,ea8gk3k4)
call epsilon4(a8ggni,k1,k2,k4,ea8ggnik1k2k4)
call epsilon4(a8ggni,k2,k3,k4,ea8ggnik2k3k4)
call epsilon4(a8gk1i,k2,k3,k4,ea8gk1ik2k3k4)
call epsilon4(a8gk2i,k1,k3,k4,ea8gk2ik1k3k4)
call epsilon4(a8gk3i,k1,k2,k4,ea8gk3ik1k2k4)
call epsilon4(a8gk4i,k1,k2,k3,ea8gk4ik1k2k3)
call epsilon4(a8gk5i,gn,k1,k2,ea8gk5ignk1k2)
call epsilon4(a8gk5i,gn,k1,k3,ea8gk5ignk1k3)
call epsilon4(a8gk5i,gn,k1,k4,ea8gk5ignk1k4)
call epsilon4(a8gk5i,gn,k2,k3,ea8gk5ignk2k3)
call epsilon4(a8gk5i,gn,k2,k4,ea8gk5ignk2k4)
call epsilon4(a8gk5i,gn,k3,k4,ea8gk5ignk3k4)
call epsilon4(a8gk5i,k1,k2,k3,ea8gk5ik1k2k3)
call epsilon4(a8gk5i,k1,k2,k4,ea8gk5ik1k2k4)
call epsilon4(a8gk5i,k1,k3,k4,ea8gk5ik1k3k4)
call epsilon4(a8gk5i,k2,k3,k4,ea8gk5ik2k3k4)
x(1) = k33*(ea8gk5ik1k2k4 - k2k4*v8gwk5k1 + k1k4*v8gwk5k2 &
  + k1k2*v8gwk5k4) + k11*(-ea8gk5ik2k3k4 + k3k4*v8gwk5k2 &
  - k2k4*v8gwk5k3 + k2k3*v8gwk5k4)
x(2) = ea8gk1ik2k3k4 + ea8gk2ik1k3k4 - ea8gk3ik1k2k4 &
  - ea8gk4ik1k2k3 + k1k2*(ea8gk3k4 - v8gwk3k4 - v8gwk4k3)
x(3) = -ea8gk2k4 + v8gwk2k4 + v8gwk4k2
x(4) = x(2) + k1k3*x(3)
x(5) = -ea8gk2k3 + v8gwk2k3 - v8gwk3k2
x(6) = x(4) + k1k4*x(5)
x(7) = -ea8gk1k4 - k1k4*tracev8g - v8gwk1k4 + v8gwk4k1
x(8) = x(6) + k2k3*x(7)
x(9) = ea8gk1k3 - k1k3*tracev8g + v8gwk1k3 + v8gwk3k1
x(10) = x(8) + k2k4*x(9)
x(11) = -ea8gk1k2 + k1k2*tracev8g - v8gwk1k2 - v8gwk2k1
x(12) = x(10) + k3k4*x(11)
x(13) = x(1) + tk55*x(12)
x(14) = -(e4*ea8gk5ik1k2k3) - e3*ea8gk5ik1k2k4 + e2*ea8gk5ik1k3k4 &
  + e1*ea8gk5ik2k3k4 + ea8ggnik2k3k4*k11 - ea8ggnik1k2k4*k33 + k1k3 &
 *(ea8gk5ignk2k4 + e4*v8gwk5k2 + e2*v8gwk5k4)
x(15) = -ea8gk5ignk3k4 - k33*v8gwgnk4 - e4*v8gwk5k3 - e3*v8gwk5k4
x(16) = x(14) + k1k2*x(15)
x(17) = ea8gk5ignk2k3 - k33*v8gwgnk2 - e3*v8gwk5k2 + e2*v8gwk5k3
x(18) = x(16) + k1k4*x(17)
x(19) = ea8gk5ignk1k4 - k11*v8gwgnk4 - k1k4*v8gwk5gn &
  + e4*v8gwk5k1 - e1*v8gwk5k4
x(20) = x(18) + k2k3*x(19)
x(21) = ea8gk5ignk1k2 - k11*v8gwgnk2 + k1k2*v8gwk5gn &
  - e2*v8gwk5k1 - e1*v8gwk5k2
x(22) = x(20) + k3k4*x(21)
x(23) = -ea8gk5ignk1k3 + k33*v8gwgnk1 + k11*v8gwgnk3 &
  - k1k3*v8gwk5gn + e3*v8gwk5k1 + e1*v8gwk5k3
x(24) = x(22) + k2k4*x(23)
x(25) = x(13) + e5*x(24)
feynman = (-8*cf*nc*x(25))/tk55
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 4) THEN
!        flavors = {qbar,quark,quark,qbar,gluon,gluon,quark,qbar}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
DO mu = 0,3
  k3pt(1,mu) = k8(mu)
  k3pt(2,mu) = -k7(mu)
  k3pt(3,mu) = k6(mu)
END DO
cut3pt(1) = cut(8)
cut3pt(2) = cut(7)
cut3pt(3) = cut(6)
kind3pt = 'qqg/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v8q,a8q)
tracev8q = 0.0d0
DO mu = 0,3
  tracev8q = tracev8q + v8q(mu,mu)*metric(mu)
END DO
v8qwgnk1 = 0.0d0
v8qwgnk2 = 0.0d0
v8qwgnk3 = 0.0d0
v8qwgnk4 = 0.0d0
v8qwk1k2 = 0.0d0
v8qwk1k3 = 0.0d0
v8qwk1k4 = 0.0d0
v8qwk2k1 = 0.0d0
v8qwk2k3 = 0.0d0
v8qwk2k4 = 0.0d0
v8qwk3k1 = 0.0d0
v8qwk3k2 = 0.0d0
v8qwk3k4 = 0.0d0
v8qwk4k1 = 0.0d0
v8qwk4k2 = 0.0d0
v8qwk4k3 = 0.0d0
v8qwk5gn = 0.0d0
v8qwk5k1 = 0.0d0
v8qwk5k2 = 0.0d0
v8qwk5k3 = 0.0d0
v8qwk5k4 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v8qwgnk1 = v8qwgnk1  &
    + v8q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu)
  v8qwgnk2 = v8qwgnk2  &
    + v8q(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu)
  v8qwgnk3 = v8qwgnk3  &
    + v8q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu)
  v8qwgnk4 = v8qwgnk4  &
    + v8q(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu)
  v8qwk1k2 = v8qwk1k2  &
    + v8q(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu)
  v8qwk1k3 = v8qwk1k3  &
    + v8q(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu)
  v8qwk1k4 = v8qwk1k4  &
    + v8q(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu)
  v8qwk2k1 = v8qwk2k1  &
    + v8q(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu)
  v8qwk2k3 = v8qwk2k3  &
    + v8q(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu)
  v8qwk2k4 = v8qwk2k4  &
    + v8q(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu)
  v8qwk3k1 = v8qwk3k1  &
    + v8q(mu,nu)*k3(mu)*k1(nu)*metric(mu)*metric(nu)
  v8qwk3k2 = v8qwk3k2  &
    + v8q(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu)
  v8qwk3k4 = v8qwk3k4  &
    + v8q(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
  v8qwk4k1 = v8qwk4k1  &
    + v8q(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu)
  v8qwk4k2 = v8qwk4k2  &
    + v8q(mu,nu)*k4(mu)*k2(nu)*metric(mu)*metric(nu)
  v8qwk4k3 = v8qwk4k3  &
    + v8q(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu)
  v8qwk5gn = v8qwk5gn  &
    + v8q(mu,nu)*k5(mu)*gn(nu)*metric(mu)*metric(nu)
  v8qwk5k1 = v8qwk5k1  &
    + v8q(mu,nu)*k5(mu)*k1(nu)*metric(mu)*metric(nu)
  v8qwk5k2 = v8qwk5k2  &
    + v8q(mu,nu)*k5(mu)*k2(nu)*metric(mu)*metric(nu)
  v8qwk5k3 = v8qwk5k3  &
    + v8q(mu,nu)*k5(mu)*k3(nu)*metric(mu)*metric(nu)
  v8qwk5k4 = v8qwk5k4  &
    + v8q(mu,nu)*k5(mu)*k4(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
a8qgni(mu) = 0.0d0
a8qk1i(mu) = 0.0d0
a8qk2i(mu) = 0.0d0
a8qk3i(mu) = 0.0d0
a8qk4i(mu) = 0.0d0
a8qk5i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a8qgni(mu) = a8qgni(mu) + a8q(nu,mu)*gn(nu)*metric(nu)
  a8qk1i(mu) = a8qk1i(mu) + a8q(nu,mu)*k1(nu)*metric(nu)
  a8qk2i(mu) = a8qk2i(mu) + a8q(nu,mu)*k2(nu)*metric(nu)
  a8qk3i(mu) = a8qk3i(mu) + a8q(nu,mu)*k3(nu)*metric(nu)
  a8qk4i(mu) = a8qk4i(mu) + a8q(nu,mu)*k4(nu)*metric(nu)
  a8qk5i(mu) = a8qk5i(mu) + a8q(nu,mu)*k5(nu)*metric(nu)
END DO
END DO
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
call epsilont2(a8q,k1,k2,ea8qk1k2)
call epsilont2(a8q,k1,k3,ea8qk1k3)
call epsilont2(a8q,k1,k4,ea8qk1k4)
call epsilont2(a8q,k2,k3,ea8qk2k3)
call epsilont2(a8q,k2,k4,ea8qk2k4)
call epsilont2(a8q,k3,k4,ea8qk3k4)
call epsilon4(a8qgni,k1,k2,k4,ea8qgnik1k2k4)
call epsilon4(a8qgni,k2,k3,k4,ea8qgnik2k3k4)
call epsilon4(a8qk1i,k2,k3,k4,ea8qk1ik2k3k4)
call epsilon4(a8qk2i,k1,k3,k4,ea8qk2ik1k3k4)
call epsilon4(a8qk3i,k1,k2,k4,ea8qk3ik1k2k4)
call epsilon4(a8qk4i,k1,k2,k3,ea8qk4ik1k2k3)
call epsilon4(a8qk5i,gn,k1,k2,ea8qk5ignk1k2)
call epsilon4(a8qk5i,gn,k1,k3,ea8qk5ignk1k3)
call epsilon4(a8qk5i,gn,k1,k4,ea8qk5ignk1k4)
call epsilon4(a8qk5i,gn,k2,k3,ea8qk5ignk2k3)
call epsilon4(a8qk5i,gn,k2,k4,ea8qk5ignk2k4)
call epsilon4(a8qk5i,gn,k3,k4,ea8qk5ignk3k4)
call epsilon4(a8qk5i,k1,k2,k3,ea8qk5ik1k2k3)
call epsilon4(a8qk5i,k1,k2,k4,ea8qk5ik1k2k4)
call epsilon4(a8qk5i,k1,k3,k4,ea8qk5ik1k3k4)
call epsilon4(a8qk5i,k2,k3,k4,ea8qk5ik2k3k4)
x(1) = k33*(ea8qk5ik1k2k4 - k2k4*v8qwk5k1 + k1k4*v8qwk5k2 &
  + k1k2*v8qwk5k4) + k11*(-ea8qk5ik2k3k4 + k3k4*v8qwk5k2 &
  - k2k4*v8qwk5k3 + k2k3*v8qwk5k4)
x(2) = ea8qk1ik2k3k4 + ea8qk2ik1k3k4 - ea8qk3ik1k2k4 &
  - ea8qk4ik1k2k3 + k1k2*(ea8qk3k4 - v8qwk3k4 - v8qwk4k3)
x(3) = -ea8qk2k4 + v8qwk2k4 + v8qwk4k2
x(4) = x(2) + k1k3*x(3)
x(5) = -ea8qk2k3 + v8qwk2k3 - v8qwk3k2
x(6) = x(4) + k1k4*x(5)
x(7) = -ea8qk1k4 - k1k4*tracev8q - v8qwk1k4 + v8qwk4k1
x(8) = x(6) + k2k3*x(7)
x(9) = ea8qk1k3 - k1k3*tracev8q + v8qwk1k3 + v8qwk3k1
x(10) = x(8) + k2k4*x(9)
x(11) = -ea8qk1k2 + k1k2*tracev8q - v8qwk1k2 - v8qwk2k1
x(12) = x(10) + k3k4*x(11)
x(13) = x(1) + tk55*x(12)
x(14) = -(e4*ea8qk5ik1k2k3) - e3*ea8qk5ik1k2k4 + e2*ea8qk5ik1k3k4 &
  + e1*ea8qk5ik2k3k4 + ea8qgnik2k3k4*k11 - ea8qgnik1k2k4*k33 + k1k3 &
 *(ea8qk5ignk2k4 + e4*v8qwk5k2 + e2*v8qwk5k4)
x(15) = -ea8qk5ignk3k4 - k33*v8qwgnk4 - e4*v8qwk5k3 - e3*v8qwk5k4
x(16) = x(14) + k1k2*x(15)
x(17) = ea8qk5ignk2k3 - k33*v8qwgnk2 - e3*v8qwk5k2 + e2*v8qwk5k3
x(18) = x(16) + k1k4*x(17)
x(19) = ea8qk5ignk1k4 - k11*v8qwgnk4 - k1k4*v8qwk5gn &
  + e4*v8qwk5k1 - e1*v8qwk5k4
x(20) = x(18) + k2k3*x(19)
x(21) = ea8qk5ignk1k2 - k11*v8qwgnk2 + k1k2*v8qwk5gn &
  - e2*v8qwk5k1 - e1*v8qwk5k2
x(22) = x(20) + k3k4*x(21)
x(23) = -ea8qk5ignk1k3 + k33*v8qwgnk1 + k11*v8qwgnk3 &
  - k1k3*v8qwk5gn + e3*v8qwk5k1 + e1*v8qwk5k3
x(24) = x(22) + k2k4*x(23)
x(25) = x(13) + e5*x(24)
feynman = (-8*cf*nc*x(25))/tk55
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 8) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,quark,qbar,quark,gluon,gluon,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
e6 = k6(0)
tk66 = 0.0d0
e7 = k7(0)
tk77 = 0.0d0
e8 = k8(0)
tk88 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
  tk66 = tk66 - k6(mu)**2
  tk77 = tk77 - k7(mu)**2
  tk88 = tk88 - k8(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
k66 = e6**2 + tk66
k77 = e7**2 + tk77
k88 = e8**2 + tk88
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
IF (cut(6)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk66)
ELSE
  prefactor = prefactor/k66
END IF
IF (cut(7)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk77)
ELSE
  prefactor = prefactor/k77
END IF
IF (cut(8)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk88)
ELSE
  prefactor = prefactor/k88
END IF
feynman = 0
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {quark,qbar,qbar,quark,quark,gluon,gluon,qbar}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
e6 = k6(0)
tk66 = 0.0d0
e7 = k7(0)
tk77 = 0.0d0
e8 = k8(0)
tk88 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
  tk66 = tk66 - k6(mu)**2
  tk77 = tk77 - k7(mu)**2
  tk88 = tk88 - k8(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
k66 = e6**2 + tk66
k77 = e7**2 + tk77
k88 = e8**2 + tk88
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
IF (cut(6)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk66)
ELSE
  prefactor = prefactor/k66
END IF
IF (cut(7)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk77)
ELSE
  prefactor = prefactor/k77
END IF
IF (cut(8)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk88)
ELSE
  prefactor = prefactor/k88
END IF
feynman = 0
feynman = feynman*prefactor
!
ELSE IF (flavorsetnumber .EQ. 3) THEN
!        flavors = {quark,qbar,qbar,quark,gluon,quark,qbar,gluon}
!
prefactor = 1.0d0
e6 = k6(0)
tk66 = 0.0d0
e7 = k7(0)
tk77 = 0.0d0
DO mu = 1,3
  tk66 = tk66 - k6(mu)**2
  tk77 = tk77 - k7(mu)**2
END DO
k66 = e6**2 + tk66
k77 = e7**2 + tk77
IF (cut(6)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk66)
ELSE
  prefactor = prefactor/k66
END IF
IF (cut(7)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk77)
ELSE
  prefactor = prefactor/k77
END IF
DO mu = 0,3
  k3pt(1,mu) = -k1(mu)
  k3pt(2,mu) = k2(mu)
  k3pt(3,mu) = -k5(mu)
END DO
cut3pt(1) = cut(1)
cut3pt(2) = cut(2)
cut3pt(3) = cut(5)
kind3pt = 'qqp/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v1q,a1q)
DO mu = 0,3
  k3pt(1,mu) = -k4(mu)
  k3pt(2,mu) = k3(mu)
  k3pt(3,mu) = k8(mu)
END DO
cut3pt(1) = cut(4)
cut3pt(2) = cut(3)
cut3pt(3) = cut(8)
kind3pt = 'qqp/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q)
a1qda4q = 0.0d0
v1qdv4q = 0.0d0
DO mu = 0,3
DO nu = 0,3
  a1qda4q = a1qda4q + a1q(mu,nu)*a4q(mu,nu)*metric(mu)*metric(nu)
  v1qdv4q = v1qdv4q + v1q(mu,nu)*v4q(mu,nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
a1qik6(mu) = 0.0d0
a1qik7(mu) = 0.0d0
a4qik6(mu) = 0.0d0
a4qik7(mu) = 0.0d0
v1qik6(mu) = 0.0d0
v1qik7(mu) = 0.0d0
v4qik6(mu) = 0.0d0
v4qik7(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a1qik6(mu) = a1qik6(mu) + a1q(mu,nu)*k6(nu)*metric(nu)
  a1qik7(mu) = a1qik7(mu) + a1q(mu,nu)*k7(nu)*metric(nu)
  a4qik6(mu) = a4qik6(mu) + a4q(mu,nu)*k6(nu)*metric(nu)
  a4qik7(mu) = a4qik7(mu) + a4q(mu,nu)*k7(nu)*metric(nu)
  v1qik6(mu) = v1qik6(mu) + v1q(mu,nu)*k6(nu)*metric(nu)
  v1qik7(mu) = v1qik7(mu) + v1q(mu,nu)*k7(nu)*metric(nu)
  v4qik6(mu) = v4qik6(mu) + v4q(mu,nu)*k6(nu)*metric(nu)
  v4qik7(mu) = v4qik7(mu) + v4q(mu,nu)*k7(nu)*metric(nu)
END DO
END DO
DO mu = 0,3
DO nu = 0,3
a1qzv4q(mu,nu) = 0.0d0
a4qzv1q(mu,nu) = 0.0d0
END DO
END DO
DO mu = 0,3
DO nu = 0,3
DO tau = 0,3
  a1qzv4q(mu,nu) = a1qzv4q(mu,nu)  &
     + a1q(tau,mu)*v4q(tau,nu)*metric(tau)
  a4qzv1q(mu,nu) = a4qzv1q(mu,nu)  &
     + a4q(tau,mu)*v1q(tau,nu)*metric(tau)
END DO
END DO
END DO
a1qik6a4qik7 = 0.0d0
a1qik7a4qik6 = 0.0d0
k6k7 = 0.0d0
v1qik6v4qik7 = 0.0d0
v1qik7v4qik6 = 0.0d0
DO mu = 0,3
  a1qik6a4qik7 = a1qik6a4qik7 + a1qik6(mu)*a4qik7(mu)*metric(mu)
  a1qik7a4qik6 = a1qik7a4qik6 + a1qik7(mu)*a4qik6(mu)*metric(mu)
  k6k7 = k6k7 + k6(mu)*k7(mu)*metric(mu)
  v1qik6v4qik7 = v1qik6v4qik7 + v1qik6(mu)*v4qik7(mu)*metric(mu)
  v1qik7v4qik6 = v1qik7v4qik6 + v1qik7(mu)*v4qik6(mu)*metric(mu)
END DO
call epsilont2(a1qzv4q,k6,k7,ea1qzv4qk6k7)
call epsilont2(a4qzv1q,k6,k7,ea4qzv1qk6k7)
feynman = 4*nc*(a1qik6a4qik7 + a1qik7a4qik6 + ea1qzv4qk6k7 &
  - ea4qzv1qk6k7 - a1qda4q*k6k7 + k6k7*v1qdv4q - v1qik6v4qik7 &
  - v1qik7v4qik6)
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 9) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,qbar,quark,gluon,quark,gluon,qbar}
!
prefactor = 1.0d0
DO mu = 0,3
  k2pt(0,mu) = k1(mu)
  k2pt(1,mu) = k5(mu)
  k2pt(2,mu) = k6(mu)
END DO
cut2pt(0) = cut(1)
cut2pt(1) = cut(5)
cut2pt(2) = cut(6)
cut2pt(3) = cut(3)
call twopointq(k2pt,cut2pt,mumsbar,flag,q15)
DO mu = 0,3
  k2pt(0,mu) = k4(mu)
  k2pt(1,mu) = -k7(mu)
  k2pt(2,mu) = -k8(mu)
END DO
cut2pt(0) = cut(4)
cut2pt(1) = cut(7)
cut2pt(2) = cut(8)
cut2pt(3) = cut(2)
call twopointq(k2pt,cut2pt,mumsbar,flag,q47)
q15q47 = 0.0d0
DO mu = 0,3
  q15q47 = q15q47 + q15(mu)*q47(mu)*metric(mu)
END DO
feynman = -8*nc*q15q47
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 10) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,quark,qbar,gluon,quark,qbar,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
e6 = k6(0)
tk66 = 0.0d0
e7 = k7(0)
tk77 = 0.0d0
e8 = k8(0)
tk88 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
  tk66 = tk66 - k6(mu)**2
  tk77 = tk77 - k7(mu)**2
  tk88 = tk88 - k8(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
k66 = e6**2 + tk66
k77 = e7**2 + tk77
k88 = e8**2 + tk88
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
IF (cut(6)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk66)
ELSE
  prefactor = prefactor/k66
END IF
IF (cut(7)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk77)
ELSE
  prefactor = prefactor/k77
END IF
IF (cut(8)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk88)
ELSE
  prefactor = prefactor/k88
END IF
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k1k6 = 0.0d0
k1k7 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k2k6 = 0.0d0
k2k7 = 0.0d0
k3k4 = 0.0d0
k3k6 = 0.0d0
k3k7 = 0.0d0
k4k6 = 0.0d0
k4k7 = 0.0d0
k6k7 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k1k6 = k1k6 + k1(mu)*k6(mu)*metric(mu)
  k1k7 = k1k7 + k1(mu)*k7(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k2k6 = k2k6 + k2(mu)*k6(mu)*metric(mu)
  k2k7 = k2k7 + k2(mu)*k7(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
  k3k6 = k3k6 + k3(mu)*k6(mu)*metric(mu)
  k3k7 = k3k7 + k3(mu)*k7(mu)*metric(mu)
  k4k6 = k4k6 + k4(mu)*k6(mu)*metric(mu)
  k4k7 = k4k7 + k4(mu)*k7(mu)*metric(mu)
  k6k7 = k6k7 + k6(mu)*k7(mu)*metric(mu)
END DO
x(1) = k1k3*tk55*(-4*k22*k4k7*k66 + k6k7*(-4*k22*k44 &
  - 16*k2k4*tk88))
x(2) = -(k11*k22*k44*k6k7) - 4*k11*k2k4*k6k7*tk88 + k66*(k22 &
 *(k1k7*(k44 + k4k6) - k11*k4k7 + k1k6*k4k7 - k1k4*k6k7) &
  + 4*k1k7*k2k4*tk88)
x(3) = x(1) + k33*x(2)
x(4) = k2k4*((4*e7*k1k3 + 4*e3*k1k7 - 4*e1*k3k7)*k66 + k33 &
 *(-4*e7*k1k6 + 4*e6*k1k7 + 4*e1*k6k7) + k11*(-4*e7*k3k6 &
  + 4*e6*k3k7 - 4*e3*k6k7))*tk88
x(5) = k44*(k33*(-(e7*k1k6) + e6*k1k7 + e1*k6k7) + k11 &
 *(-(e7*k3k6) + e6*k3k7 - e3*k6k7))
x(6) = k1k7*(-(e6*k3k4) + e4*(k33 + k3k6) + e3*(k44 + k4k6)) &
  + (-(e4*k1k3) - e3*k1k4 + e1*k3k4)*k6k7
x(7) = e6*k1k4 + e4*(k11 - k1k6) + e1*(-k44 - k4k6)
x(8) = x(6) + k3k7*x(7)
x(9) = e6*k1k3 + e3*(-k11 + k1k6) + e1*(k33 - k3k6)
x(10) = x(8) + k4k7*x(9)
x(11) = (-k11 + k1k6)*k3k4 + k1k4*(-k33 - k3k6) + k1k3*(k44 &
  + k4k6)
x(12) = x(10) + e7*x(11)
x(13) = x(5) + k66*x(12)
x(14) = x(4) + k22*x(13)
x(15) = x(3) + e5*x(14)
x(16) = k2k4*(-4*k11*k3k6 + e5*(4*e6*k1k3 - 4*e3*k1k6 &
  + 4*e1*k3k6))*tk88
x(17) = k11*((-k22 + k2k7)*k3k6 + k2k6*(k33 + k3k7) - k2k3*k6k7) &
  + 4*k1k3*k2k6*tk55
x(18) = k1k6*(-(e7*k2k3) + e3*(-k22 + k2k7) + e2*(k33 + k3k7)) &
  + (-(e3*k1k2) + e2*k1k3 + e1*k2k3)*k6k7
x(19) = -(e7*k1k3) + e3*(k11 + k1k7) + e1*(-k33 - k3k7)
x(20) = x(18) + k2k6*x(19)
x(21) = e7*k1k2 + e2*(k11 - k1k7) + e1*(k22 - k2k7)
x(22) = x(20) + k3k6*x(21)
x(23) = (-k11 + k1k7)*k2k3 + k1k3*(k22 - k2k7) + k1k2*(-k33 &
  - k3k7)
x(24) = x(22) + e6*x(23)
x(25) = x(17) + e5*x(24)
x(26) = x(16) + k44*x(25)
x(27) = ((-k11 + k1k6)*k2k3 + k1k3*k2k6 - k1k2*k3k6)*k4k7 + k1k4 &
 *((-k22 + k2k7)*k3k6 + k2k6*(k33 + k3k7) - k2k3*k6k7)
x(28) = k1k7*k2k3 + k1k3*(k22 - k2k7) + k1k2*(-k33 - k3k7)
x(29) = x(27) + k44*x(28)
x(30) = k1k7*k2k3 + k1k3*(k22 - k2k7) + k1k2*(-k33 - k3k7)
x(31) = x(29) + k4k6*x(30)
x(32) = (-k11 + k1k6)*k22 - k1k7*k2k6 + (k11 - k1k6)*k2k7 &
  + k1k2*k6k7
x(33) = x(31) + k3k4*x(32)
x(34) = (k11 - k1k6)*k33 + k1k7*k3k6 + (k11 - k1k6)*k3k7 + k1k3 &
 *(-k6k7 + 4*tk55 + 4*tk88)
x(35) = x(33) + k2k4*x(34)
x(36) = e6*(-(k1k4*k2k3) - k1k3*k2k4 + k1k2*k3k4) + e7 &
 *(-(k1k4*k2k3) - k1k3*k2k4 + k1k2*k3k4)
x(37) = (k22 - k2k6 - k2k7)*k3k4 + k2k4*(-k33 + k3k6 - k3k7) &
  + k2k3*(k44 + k4k6 + k4k7)
x(38) = x(36) + e1*x(37)
x(39) = (k11 - k1k6 - k1k7)*k3k4 + k1k4*(k33 + k3k6 + k3k7) &
  + k1k3*(-k44 - k4k6 + k4k7)
x(40) = x(38) + e2*x(39)
x(41) = (k11 - k1k6 + k1k7)*k2k4 + k1k4*(-k22 + k2k6 + k2k7) &
  + k1k2*(-k44 - k4k6 - k4k7)
x(42) = x(40) + e3*x(41)
x(43) = (-k11 + k1k6 + k1k7)*k2k3 + k1k3*(k22 + k2k6 - k2k7) &
  + k1k2*(-k33 - k3k6 - k3k7)
x(44) = x(42) + e4*x(43)
x(45) = x(35) + e5*x(44)
x(46) = x(26) + k66*x(45)
x(47) = x(15) + k77*x(46)
x(48) = k1k3*((4*e7*k2k4 - 4*e4*k2k7 + 4*e2*k4k7)*k66 + k44 &
 *(4*e7*k2k6 - 4*e6*k2k7 + 4*e2*k6k7) + k22*(4*e7*k4k6 - 4*e6*k4k7 &
  - 4*e4*k6k7))*tk55
x(49) = k11*(k44*(e7*k2k6 - e6*k2k7 + e2*k6k7) + k22*(e7*k4k6 &
  - e6*k4k7 - e4*k6k7))
x(50) = k1k7*(-(e6*k2k4) + e4*(k22 + k2k6) + e2*(-k44 - k4k6)) &
  + (-(e4*k1k2) + e2*k1k4 + e1*k2k4)*k6k7
x(51) = -(e6*k1k4) + e4*(-k11 + k1k6) + e1*(k44 + k4k6)
x(52) = x(50) + k2k7*x(51)
x(53) = e6*k1k2 + e2*(k11 - k1k6) + e1*(k22 - k2k6)
x(54) = x(52) + k4k7*x(53)
x(55) = (k11 - k1k6)*k2k4 + k1k4*(-k22 + k2k6) + k1k2*(-k44 &
  - k4k6)
x(56) = x(54) + e7*x(55)
x(57) = x(49) + k66*x(56)
x(58) = x(48) + k33*x(57)
x(59) = k1k3*(4*e6*k2k4 + 4*e4*k2k6 - 4*e2*k4k6)*tk55
x(60) = k2k6*(-(e7*k3k4) + e4*(k33 + k3k7) + e3*(k44 + k4k7)) &
  + (-(e4*k2k3) - e3*k2k4 + e2*k3k4)*k6k7
x(61) = e7*k2k4 + e4*(-k22 + k2k7) + e2*(k44 - k4k7)
x(62) = x(60) + k3k6*x(61)
x(63) = e7*k2k3 + e3*(k22 - k2k7) + e2*(-k33 - k3k7)
x(64) = x(62) + k4k6*x(63)
x(65) = (-k22 + k2k7)*k3k4 + k2k4*(k33 + k3k7) + k2k3*(-k44 &
  - k4k7)
x(66) = x(64) + e6*x(65)
x(67) = x(59) + k11*x(66)
x(68) = e6*(-(k1k4*k2k3) - k1k3*k2k4 + k1k2*k3k4) + e7 &
 *(-(k1k4*k2k3) - k1k3*k2k4 + k1k2*k3k4)
x(69) = (k22 - k2k6 - k2k7)*k3k4 + k2k4*(-k33 + k3k6 - k3k7) &
  + k2k3*(k44 + k4k6 + k4k7)
x(70) = x(68) + e1*x(69)
x(71) = (k11 - k1k6 - k1k7)*k3k4 + k1k4*(k33 + k3k6 + k3k7) &
  + k1k3*(-k44 - k4k6 + k4k7)
x(72) = x(70) + e2*x(71)
x(73) = (k11 - k1k6 + k1k7)*k2k4 + k1k4*(-k22 + k2k6 + k2k7) &
  + k1k2*(-k44 - k4k6 - k4k7)
x(74) = x(72) + e3*x(73)
x(75) = (-k11 + k1k6 + k1k7)*k2k3 + k1k3*(k22 + k2k6 - k2k7) &
  + k1k2*(-k33 - k3k6 - k3k7)
x(76) = x(74) + e4*x(75)
x(77) = x(67) + k66*x(76)
x(78) = x(58) + k77*x(77)
x(79) = 0
x(80) = k33*(-(k1k7*k4k6) - k1k6*k4k7 + e6*(-2*e7*k1k4 &
  + 2*e4*k1k7 + 2*e1*k4k7) + k1k4*k6k7)
x(81) = -2*e6*e7*k3k4 + 2*e4*e6*k3k7 + (2*e3*e7 - k3k7)*k4k6 &
  - k3k6*k4k7 + (-2*e3*e4 + k3k4)*k6k7
x(82) = x(80) + k11*x(81)
x(83) = x(79) + k22*x(82)
x(84) = k11*(-(k2k7*k3k6) + e7*(-2*e6*k2k3 + 2*e3*k2k6 &
  + 2*e2*k3k6) - k2k6*k3k7 + k2k3*k6k7)
x(85) = -2*e6*e7*k1k2 + 2*e2*e7*k1k6 - k1k7*k2k6 + (2*e1*e6 &
  - k1k6)*k2k7 + (-2*e1*e2 + k1k2)*k6k7
x(86) = x(84) + k33*x(85)
x(87) = x(83) + k44*x(86)
x(88) = (k1k4*k2k3 + k1k3*k2k4 - k1k2*k3k4)*k6k7
x(89) = 2*e3*e4*k22 + (-k22 + k2k6)*k3k4 + k2k4*(-k33 - k3k6) &
  + k2k3*(-k44 - k4k6)
x(90) = x(88) + k1k7*x(89)
x(91) = (2*e1*e4 - k1k4)*k33 + (-k11 + k1k6)*k3k4 - k1k4*k3k6 &
  + k1k3*(k44 + k4k6)
x(92) = x(90) + k2k7*x(91)
x(93) = (-2*e1*e4 + k1k4)*k22 + (-k11 + k1k6)*k2k4 - k1k4*k2k6 &
  + k1k2*(k44 + k4k6)
x(94) = x(92) + k3k7*x(93)
x(95) = (k11 - k1k6)*k2k3 + k1k3*(k22 - k2k6) + (-2*e1*e2 &
  + k1k2)*k33 + k1k2*k3k6
x(96) = x(94) + k4k7*x(95)
x(97) = -2*e6*k1k3*k2k4 + 2*e4*k1k3*k2k6 + (2*e6*k1k2 + e1*(2*k22 &
  - 2*k2k6))*k3k4 + e4*k1k2*(-2*k33 - 2*k3k6) + 2*e1*k2k4*k3k6
x(98) = -2*e6*k1k4 + e4*(-2*k11 + 2*k1k6) + e1*(2*k44 + 2*k4k6)
x(99) = x(97) + k2k3*x(98)
x(100) = (2*k11 - 2*k1k6)*k3k4 + k1k4*(2*k33 + 2*k3k6) + k1k3 &
 *(-2*k44 - 2*k4k6)
x(101) = x(99) + e2*x(100)
x(102) = (2*k11 - 2*k1k6)*k2k4 + k1k4*(-2*k22 + 2*k2k6) + k1k2 &
 *(-2*k44 - 2*k4k6)
x(103) = x(101) + e3*x(102)
x(104) = x(96) + e7*x(103)
x(105) = x(87) + k66*x(104)
x(106) = (k1k4*k2k3 + k1k3*k2k4 - k1k2*k3k4)*k6k7
x(107) = (-k22 + k2k7)*k3k4 + k2k4*(k33 + k3k7) + (2*e2*e3 &
  - k2k3)*k44 - k2k3*k4k7
x(108) = x(106) + k1k6*x(107)
x(109) = 2*e3*e4*k11 + (-k11 + k1k7)*k3k4 + k1k4*(-k33 - k3k7) &
  + k1k3*(-k44 - k4k7)
x(110) = x(108) + k2k6*x(109)
x(111) = (k11 - k1k7)*k2k4 + k1k4*(k22 - k2k7) + (-2*e1*e2 &
  + k1k2)*k44 + k1k2*k4k7
x(112) = x(110) + k3k6*x(111)
x(113) = -2*e2*e3*k11 + (k11 - k1k7)*k2k3 + k1k3*(-k22 + k2k7) &
  + k1k2*(k33 + k3k7)
x(114) = x(112) + k4k6*x(113)
x(115) = -4*e3*e4*k1k2 + 4*e2*e3*k1k4 + (4*e1*e4 - 2*k1k4)*k2k3 &
  - 2*k1k3*k2k4 + (-4*e1*e2 + 2*k1k2)*k3k4
x(116) = x(114) + k66*x(115)
x(117) = -2*e7*k1k3*k2k4 + 2*e3*k1k7*k2k4 + (2*e7*k1k2 + e2 &
 *(2*k11 - 2*k1k7))*k3k4 + e3*k1k2*(-2*k44 - 2*k4k7) &
  + 2*e2*k1k3*k4k7
x(118) = -2*e7*k2k3 + e3*(-2*k22 + 2*k2k7) + e2*(2*k33 + 2*k3k7)
x(119) = x(117) + k1k4*x(118)
x(120) = (2*k22 - 2*k2k7)*k3k4 + k2k4*(-2*k33 - 2*k3k7) + k2k3 &
 *(2*k44 + 2*k4k7)
x(121) = x(119) + e1*x(120)
x(122) = (-2*k11 + 2*k1k7)*k2k3 + k1k3*(2*k22 - 2*k2k7) + k1k2 &
 *(-2*k33 - 2*k3k7)
x(123) = x(121) + e4*x(122)
x(124) = x(116) + e6*x(123)
x(125) = x(105) + k77*x(124)
x(126) = x(78) + e5*x(125)
x(127) = x(47) + e8*x(126)
feynman = (4*cf*x(127))/(tk55*tk88)
feynman = feynman*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
END IF
!
RETURN
END function feynman
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!     Feynman integrand in Coulomb gauge, soft subtraction for shower calc.
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function softsubtraction(k,absk,kc, &
             graphnumber,flavorsetnumber,cutnumber)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1)
complex(kind=dbl) :: kc(0:3*size-1,0:3)
integer :: graphnumber,flavorsetnumber,cutnumber
! Out:
complex(kind=dbl) :: softsubtraction
!
! Calculates the soft subtraction for NLO graphs.
! Used for calculations with showers, in Coulomb gauge.
! This version written by Mathematica code of 17 December 2002 on
! 30 Jan 2003.
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
complex(kind=dbl), parameter :: zero = (0.0d0,0.0d0)
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
integer           :: mu,nu
complex(kind=dbl) :: result
real(kind=dbl)    :: qi(3),qj(3),l(3)
real(kind=dbl)    :: absqi,absqj,absqk,absl
real(kind=dbl)    :: lrsign
real(kind=dbl)    :: colorfactor
complex(kind=dbl) :: softfactor
complex(kind=dbl) :: q12,q13,q23,tq22
real(kind=dbl) :: e1,e2,e3,e4,e5,e6,e7,e8
real(kind=dbl) :: tk44,tk55,tk66,tk77,tk88
real(kind=dbl) :: k11,k12,k13,k14,k15,k16,k17,k18
real(kind=dbl) :: k22,k23,k24,k25,k26,k27,k28,k33
real(kind=dbl) :: k34,k35,k36,k37,k38,k44,k45,k46
real(kind=dbl) :: k47,k48,k56,k57,k67,k68,k78
!
softsubtraction = zero
!
IF (graphnumber.EQ.1) THEN
! Code for graph 1, with connections
! {{2, 3}, {1, 4}, {1, 4, 5}, {2, 3, 6}, {3, 6, 6}, {4, 5, 5}}.
!
softsubtraction = zero
!
ELSE IF (graphnumber.EQ.2) THEN
! Code for graph 2, with connections
! {{2, 3}, {1, 4}, {1, 5, 5}, {2, 6, 6}, {3, 3, 6}, {4, 4, 5}}.
!
softsubtraction = zero
!
ELSE IF (graphnumber.EQ.3) THEN
! Code for graph 3, with connections
! {{2, 3}, {1, 4}, {1, 5, 6}, {2, 5, 6}, {3, 4, 6}, {3, 4, 5}}.
!
IF (flavorsetnumber.EQ.1) THEN
! Flavors = {quark, qbar, quark, gluon, qbar, quark, gluon, quark}
!
softsubtraction = zero
!
ELSE IF (flavorsetnumber.EQ.2) THEN
! Flavors = {quark, qbar, quark, gluon, qbar, gluon, quark, gluon}
!
IF (cutnumber.EQ.1) THEN
! cut = {5, 4, 1, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(4,mu)
  qj(mu) = k(5,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(4)
absqj = absk(5)
absqk = absk(1)
absl = absk(8)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(1)
e2 =  absk(4)
e3 =  absk(5)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(1,mu)*k(4,mu)*metric(mu)
  q13 = q13 + k(1,mu)*k(5,mu)*metric(mu)
  q23 = q23 + k(4,mu)*k(5,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(-(e2*e3*q12) - e2**2*q13 - 2*e2*e3*q13 &
  + e1*e2*q23 + q13*q23 + q12*tq22))/(e1*e2*e3*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.2) THEN
! cut = {7, 6, 1, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = - k(6,mu)
  qj(mu) = - k(7,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(6)
absqj = absk(7)
absqk = absk(1)
absl = absk(8)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(1)
e2 =  absk(6)
e3 =  absk(7)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 - k(1,mu)*k(6,mu)*metric(mu)
  q13 = q13 - k(1,mu)*k(7,mu)*metric(mu)
  q23 = q23 + k(6,mu)*k(7,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(-(e2*e3*q12) - e2**2*q13 - 2*e2*e3*q13 &
  + e1*e2*q23 + q13*q23 + q12*tq22))/(e1*e2*e3*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.3) THEN
! cut = {8, 7, 4, 1}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(7,mu) + k(5,mu))
  qj(mu) = 0.5d0*( k(4,mu) - k(6,mu))
  l(mu) = - k(8,mu)
END DO
absl = absk(8)
absqk = absk(1)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e4 =  k(4,0)
e7 =  k(7,0)
k12 = 0.0d0
k14 = 0.0d0
k17 = 0.0d0
k22 = 0.0d0
k24 = 0.0d0
k27 = 0.0d0
k47 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k17 = k17 + k(1,mu)*k(7,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
END DO
tk44 = 0.0d0
DO mu = 1,3
  tk44 = tk44 - k(4,mu)**2
END DO
!
result = (-2*cf*nc*(-(e4*e7*k14*k22) + e4**2*k17*k22 &
  + 2*e4*e7*k12*k24 - 2*e4**2*k12*k27 + 2*e2*e4*k12*k47 &
  - e1*e4*k22*k47 + k14*k22*k47 - 2*k12*k24*k47 + k17*k22*tk44 &
  - 2*k12*k27*tk44))/(e1*e4*e7*k22**2*tk44)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.4) THEN
! cut = {8, 6, 5, 1}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(6,mu) + k(4,mu))
  qj(mu) = 0.5d0*( k(5,mu) - k(7,mu))
  l(mu) =  k(8,mu)
END DO
absl = absk(8)
absqk = absk(1)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e5 =  k(5,0)
e6 =  k(6,0)
k12 = 0.0d0
k15 = 0.0d0
k16 = 0.0d0
k22 = 0.0d0
k25 = 0.0d0
k26 = 0.0d0
k56 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k15 = k15 + k(1,mu)*k(5,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k25 = k25 + k(2,mu)*k(5,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k56 = k56 + k(5,mu)*k(6,mu)*metric(mu)
END DO
tk66 = 0.0d0
DO mu = 1,3
  tk66 = tk66 - k(6,mu)**2
END DO
!
result = (2*cf*nc*(e6**2*k15*k22 - e5*e6*k16*k22 &
  - 2*e6**2*k12*k25 + 2*e5*e6*k12*k26 + 2*e2*e6*k12*k56 &
  - e1*e6*k22*k56 + k16*k22*k56 - 2*k12*k26*k56 + k15*k22*tk66 &
  - 2*k12*k25*tk66))/(e1*e5*e6*k22**2*tk66)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! Close IF (cutnumber.EQ....) THEN
!
END IF
!
ELSE IF (flavorsetnumber.EQ.3) THEN
! Flavors = {qbar, quark, qbar, gluon, quark, qbar, gluon, qbar}
!
softsubtraction = zero
!
ELSE IF (flavorsetnumber.EQ.4) THEN
! Flavors = {qbar, quark, qbar, gluon, quark, gluon, qbar, gluon}
!
IF (cutnumber.EQ.1) THEN
! cut = {5, 4, 1, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(4,mu)
  qj(mu) = k(5,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(4)
absqj = absk(5)
absqk = absk(1)
absl = absk(8)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(5)
e2 =  absk(4)
e3 =  absk(1)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(5,mu)*k(4,mu)*metric(mu)
  q13 = q13 + k(5,mu)*k(1,mu)*metric(mu)
  q23 = q23 + k(4,mu)*k(1,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12 - 2*e1*e2*q13 - e2**2*q13 + q12*q13 &
  - e1*e2*q23 + q23*tq22))/(e1*e2*e3*q12*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.2) THEN
! cut = {7, 6, 1, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = - k(6,mu)
  qj(mu) = - k(7,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(6)
absqj = absk(7)
absqk = absk(1)
absl = absk(8)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(7)
e2 =  absk(6)
e3 =  absk(1)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(7,mu)*k(6,mu)*metric(mu)
  q13 = q13 - k(7,mu)*k(1,mu)*metric(mu)
  q23 = q23 - k(6,mu)*k(1,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12 - 2*e1*e2*q13 - e2**2*q13 + q12*q13 &
  - e1*e2*q23 + q23*tq22))/(e1*e2*e3*q12*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.3) THEN
! cut = {8, 7, 4, 1}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(7,mu) + k(5,mu))
  qj(mu) = 0.5d0*( k(4,mu) - k(6,mu))
  l(mu) = - k(8,mu)
END DO
absl = absk(8)
absqk = absk(1)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e4 =  k(4,0)
e7 =  k(7,0)
k12 = 0.0d0
k14 = 0.0d0
k17 = 0.0d0
k22 = 0.0d0
k24 = 0.0d0
k27 = 0.0d0
k47 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k17 = k17 + k(1,mu)*k(7,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
END DO
tk44 = 0.0d0
DO mu = 1,3
  tk44 = tk44 - k(4,mu)**2
END DO
!
result = (-2*cf*nc*(-(e4*e7*k14*k22) + e4**2*k17*k22 &
  + 2*e4*e7*k12*k24 - 2*e4**2*k12*k27 + 2*e2*e4*k12*k47 &
  - e1*e4*k22*k47 + k14*k22*k47 - 2*k12*k24*k47 + k17*k22*tk44 &
  - 2*k12*k27*tk44))/(e1*e4*e7*k22**2*tk44)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.4) THEN
! cut = {8, 6, 5, 1}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(6,mu) + k(4,mu))
  qj(mu) = 0.5d0*( k(5,mu) - k(7,mu))
  l(mu) =  k(8,mu)
END DO
absl = absk(8)
absqk = absk(1)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e5 =  k(5,0)
e6 =  k(6,0)
k12 = 0.0d0
k15 = 0.0d0
k16 = 0.0d0
k22 = 0.0d0
k25 = 0.0d0
k26 = 0.0d0
k56 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k15 = k15 + k(1,mu)*k(5,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k25 = k25 + k(2,mu)*k(5,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k56 = k56 + k(5,mu)*k(6,mu)*metric(mu)
END DO
tk66 = 0.0d0
DO mu = 1,3
  tk66 = tk66 - k(6,mu)**2
END DO
!
result = (2*cf*nc*(e6**2*k15*k22 - e5*e6*k16*k22 &
  - 2*e6**2*k12*k25 + 2*e5*e6*k12*k26 + 2*e2*e6*k12*k56 &
  - e1*e6*k22*k56 + k16*k22*k56 - 2*k12*k26*k56 + k15*k22*tk66 &
  - 2*k12*k25*tk66))/(e1*e5*e6*k22**2*tk66)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! Close IF (cutnumber.EQ....) THEN
!
END IF
!
! Close IF (flavorsetnumber.EQ.1) THEN ...
!
END IF
ELSE IF (graphnumber.EQ.4) THEN
! Code for graph 4, with connections
! {{3, 4}, {3, 4}, {1, 2, 5}, {1, 2, 6}, {3, 6, 6}, {4, 5, 5}}.
!
softsubtraction = zero
!
ELSE IF (graphnumber.EQ.5) THEN
! Code for graph 5, with connections
! {{3, 4}, {3, 5}, {1, 2, 4}, {1, 3, 6}, {2, 6, 6}, {4, 5, 5}}.
!
softsubtraction = zero
!
ELSE IF (graphnumber.EQ.6) THEN
! Code for graph 6, with connections
! {{3, 4}, {3, 5}, {1, 2, 5}, {1, 6, 6}, {2, 3, 6}, {4, 4, 5}}.
!
softsubtraction = zero
!
ELSE IF (graphnumber.EQ.7) THEN
! Code for graph 7, with connections
! {{3, 4}, {3, 5}, {1, 2, 6}, {1, 5, 6}, {2, 4, 6}, {3, 4, 5}}.
!
IF (flavorsetnumber.EQ.1) THEN
! Flavors = {quark, qbar, qbar, quark, gluon, qbar, gluon, gluon}
!
IF (cutnumber.EQ.1) THEN
! cut = {5, 4, 1, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = - k(4,mu)
  qj(mu) = - k(5,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(4)
absqj = absk(5)
absqk = absk(1)
absl = absk(8)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(1)
e2 =  absk(5)
e3 =  absk(4)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 - k(1,mu)*k(5,mu)*metric(mu)
  q13 = q13 - k(1,mu)*k(4,mu)*metric(mu)
  q23 = q23 + k(5,mu)*k(4,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.2) THEN
! cut = {7, 6, 1, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(1,mu)
  qj(mu) = k(7,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(1)
absqj = absk(7)
absqk = absk(6)
absl = absk(5)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(1)
e2 =  absk(7)
e3 =  absk(6)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(1,mu)*k(7,mu)*metric(mu)
  q13 = q13 + k(1,mu)*k(6,mu)*metric(mu)
  q23 = q23 + k(7,mu)*k(6,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(-(e2*e3*q12) - e2**2*q13 - 2*e2*e3*q13 &
  + e1*e2*q23 + q13*q23 + q12*tq22))/(e1*e2*e3*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {7, 6, 1, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(6,mu)
  qj(mu) = k(7,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(6)
absqj = absk(7)
absqk = absk(1)
absl = absk(8)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(1)
e2 =  absk(7)
e3 =  absk(6)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(1,mu)*k(7,mu)*metric(mu)
  q13 = q13 + k(1,mu)*k(6,mu)*metric(mu)
  q23 = q23 + k(7,mu)*k(6,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.3) THEN
! cut = {5, 3, 2, 0}, psoft = 7
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(2,mu)
  qj(mu) = k(5,mu)
  l(mu) = k(7,mu)
END DO
absqi = absk(2)
absqj = absk(5)
absqk = absk(3)
absl = absk(7)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(3)
e2 =  absk(5)
e3 =  absk(2)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 - k(3,mu)*k(5,mu)*metric(mu)
  q13 = q13 - k(3,mu)*k(2,mu)*metric(mu)
  q23 = q23 + k(5,mu)*k(2,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.4) THEN
! cut = {8, 6, 3, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = - k(3,mu)
  qj(mu) = - k(8,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(3)
absqj = absk(8)
absqk = absk(6)
absl = absk(5)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(3)
e2 =  absk(8)
e3 =  absk(6)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(3,mu)*k(8,mu)*metric(mu)
  q13 = q13 - k(3,mu)*k(6,mu)*metric(mu)
  q23 = q23 - k(8,mu)*k(6,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(-(e2*e3*q12) - e2**2*q13 - 2*e2*e3*q13 &
  + e1*e2*q23 + q13*q23 + q12*tq22))/(e1*e2*e3*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {8, 6, 3, 0}, psoft = 7
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(6,mu)
  qj(mu) = - k(8,mu)
  l(mu) = k(7,mu)
END DO
absqi = absk(6)
absqj = absk(8)
absqk = absk(3)
absl = absk(7)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(3)
e2 =  absk(8)
e3 =  absk(6)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(3,mu)*k(8,mu)*metric(mu)
  q13 = q13 - k(3,mu)*k(6,mu)*metric(mu)
  q23 = q23 - k(8,mu)*k(6,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.5) THEN
! cut = {8, 7, 4, 1}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(4,mu) + k(6,mu))
  qj(mu) = 0.5d0*( k(7,mu) - k(5,mu))
  l(mu) =  k(8,mu)
END DO
absl = absk(8)
absqk = absk(1)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e7 =  k(7,0)
k12 = 0.0d0
k13 = 0.0d0
k14 = 0.0d0
k17 = 0.0d0
k22 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k27 = 0.0d0
k33 = 0.0d0
k34 = 0.0d0
k37 = 0.0d0
k47 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k17 = k17 + k(1,mu)*k(7,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k33 = k33 + k(3,mu)*k(3,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k37 = k37 + k(3,mu)*k(7,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
END DO
tk77 = 0.0d0
DO mu = 1,3
  tk77 = tk77 - k(7,mu)**2
END DO
!
result = (2*cf*nc*(-(e7**2*k14*k23) - e7**2*k13*k24 &
  + e3*e7*k17*k24 + e4*e7*k13*k27 + e7**2*k12*k34 - e2*e7*k17*k34 &
  - e1*e7*k27*k34 + k17*k27*k34 - e4*e7*k12*k37 + e1*e7*k24*k37 &
  - k17*k24*k37 - e3*e7*k12*k47 + e2*e7*k13*k47 - k13*k27*k47 &
  + k12*k37*k47 - 2*k14*k23*tk77))/(e1*e4*e7*k22*k33*tk77)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.6) THEN
! cut = {8, 6, 5, 1}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(5,mu) + k(7,mu))
  qj(mu) = 0.5d0*( k(6,mu) - k(4,mu))
  l(mu) = - k(8,mu)
END DO
absl = absk(8)
absqk = absk(1)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e3 =  k(3,0)
e5 =  k(5,0)
e6 =  k(6,0)
k12 = 0.0d0
k13 = 0.0d0
k15 = 0.0d0
k16 = 0.0d0
k22 = 0.0d0
k23 = 0.0d0
k25 = 0.0d0
k26 = 0.0d0
k33 = 0.0d0
k35 = 0.0d0
k36 = 0.0d0
k56 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k15 = k15 + k(1,mu)*k(5,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k25 = k25 + k(2,mu)*k(5,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k33 = k33 + k(3,mu)*k(3,mu)*metric(mu)
  k35 = k35 + k(3,mu)*k(5,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k56 = k56 + k(5,mu)*k(6,mu)*metric(mu)
END DO
tk55 = 0.0d0
DO mu = 1,3
  tk55 = tk55 - k(5,mu)**2
END DO
!
result = (-2*cf*nc*(-(e5**2*k16*k23) + e5*e6*k13*k25 &
  - e5**2*k13*k26 + e3*e5*k15*k26 - e5*e6*k12*k35 + e1*e5*k26*k35 &
  - k15*k26*k35 + e5**2*k12*k36 - e2*e5*k15*k36 - e1*e5*k25*k36 &
  + k15*k25*k36 - e3*e5*k12*k56 + e2*e5*k13*k56 - k13*k25*k56 &
  + k12*k35*k56 - 2*k16*k23*tk55))/(e1*e5*e6*k22*k33*tk55)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {8, 6, 5, 1}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(8,mu) + k(7,mu))
  qj(mu) = 0.5d0*( k(1,mu) - k(3,mu))
  l(mu) = - k(5,mu)
END DO
absl = absk(5)
absqk = absk(6)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e4 =  k(4,0)
e6 =  k(6,0)
e8 =  k(8,0)
k12 = 0.0d0
k14 = 0.0d0
k16 = 0.0d0
k18 = 0.0d0
k22 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k28 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k48 = 0.0d0
k68 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k18 = k18 + k(1,mu)*k(8,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k28 = k28 + k(2,mu)*k(8,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k48 = k48 + k(4,mu)*k(8,mu)*metric(mu)
  k68 = k68 + k(6,mu)*k(8,mu)*metric(mu)
END DO
tk88 = 0.0d0
DO mu = 1,3
  tk88 = tk88 - k(8,mu)**2
END DO
!
result = (-2*cf*nc*(e8**2*k16*k24 - e6*e8*k18*k24 - e8**2*k14*k26 &
  + e6*e8*k14*k28 - e8**2*k12*k46 + e6*e8*k12*k48 + e4*e8*k12*k68 &
  + e2*e8*k14*k68 - e1*e8*k24*k68 + k18*k24*k68 - k14*k28*k68 &
  - k12*k48*k68 + k16*k24*tk88 - k14*k26*tk88 &
  - k12*k46*tk88))/(e1*e6*e8*k22*k44*tk88)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.7) THEN
! cut = {8, 7, 3, 2}, psoft = 7
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(8,mu) + k(5,mu))
  qj(mu) = 0.5d0*( k(2,mu) + k(6,mu))
  l(mu) = - k(7,mu)
END DO
absl = absk(7)
absqk = absk(3)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e8 =  k(8,0)
k11 = 0.0d0
k12 = 0.0d0
k13 = 0.0d0
k14 = 0.0d0
k18 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k28 = 0.0d0
k34 = 0.0d0
k38 = 0.0d0
k44 = 0.0d0
k48 = 0.0d0
DO mu = 0,3
  k11 = k11 + k(1,mu)*k(1,mu)*metric(mu)
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k18 = k18 + k(1,mu)*k(8,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k28 = k28 + k(2,mu)*k(8,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k38 = k38 + k(3,mu)*k(8,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k48 = k48 + k(4,mu)*k(8,mu)*metric(mu)
END DO
tk88 = 0.0d0
DO mu = 1,3
  tk88 = tk88 - k(8,mu)**2
END DO
!
result = (-2*cf*nc*(-(e8**2*k14*k23) - e8**2*k13*k24 &
  + e3*e8*k18*k24 + e4*e8*k13*k28 + e8**2*k12*k34 - e2*e8*k18*k34 &
  - e1*e8*k28*k34 + k18*k28*k34 - e4*e8*k12*k38 + e1*e8*k24*k38 &
  - k18*k24*k38 - e3*e8*k12*k48 + e2*e8*k13*k48 - k13*k28*k48 &
  + k12*k38*k48 - 2*k14*k23*tk88))/(e2*e3*e8*k11*k44*tk88)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.8) THEN
! cut = {7, 6, 5, 3}, psoft = 7
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*(k(6,mu) + k(2,mu))
  qj(mu) = 0.5d0*( k(5,mu) - k(8,mu))
  l(mu) =  k(7,mu)
END DO
absl = absk(7)
absqk = absk(3)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e3 =  k(3,0)
e4 =  k(4,0)
e5 =  k(5,0)
e6 =  k(6,0)
k11 = 0.0d0
k13 = 0.0d0
k14 = 0.0d0
k15 = 0.0d0
k16 = 0.0d0
k34 = 0.0d0
k35 = 0.0d0
k36 = 0.0d0
k44 = 0.0d0
k45 = 0.0d0
k46 = 0.0d0
k56 = 0.0d0
DO mu = 0,3
  k11 = k11 + k(1,mu)*k(1,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k15 = k15 + k(1,mu)*k(5,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k35 = k35 + k(3,mu)*k(5,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k45 = k45 + k(4,mu)*k(5,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k56 = k56 + k(5,mu)*k(6,mu)*metric(mu)
END DO
tk55 = 0.0d0
DO mu = 1,3
  tk55 = tk55 - k(5,mu)**2
END DO
!
result = (-2*cf*nc*(e5*e6*k15*k34 - e5**2*k16*k34 + e4*e5*k16*k35 &
  + e5**2*k14*k36 - e5*e6*k13*k45 + e3*e5*k16*k45 - k16*k35*k45 &
  + e5**2*k13*k46 - e3*e5*k15*k46 - e1*e5*k35*k46 + k15*k35*k46 &
  - e4*e5*k13*k56 + e1*e5*k34*k56 - k15*k34*k56 + k13*k45*k56 &
  + 2*k14*k36*tk55))/(e3*e5*e6*k11*k44*tk55)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {7, 6, 5, 3}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(3,mu) + k(1,mu))
  qj(mu) = 0.5d0*( k(7,mu) - k(8,mu))
  l(mu) =  k(5,mu)
END DO
absl = absk(5)
absqk = absk(6)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e6 =  k(6,0)
e7 =  k(7,0)
k22 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k27 = 0.0d0
k34 = 0.0d0
k36 = 0.0d0
k37 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k47 = 0.0d0
k67 = 0.0d0
DO mu = 0,3
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k37 = k37 + k(3,mu)*k(7,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
  k67 = k67 + k(6,mu)*k(7,mu)*metric(mu)
END DO
tk77 = 0.0d0
DO mu = 1,3
  tk77 = tk77 - k(7,mu)**2
END DO
!
result = (-2*cf*nc*(e7**2*k26*k34 - e6*e7*k27*k34 - e7**2*k24*k36 &
  + e6*e7*k24*k37 + e7**2*k23*k46 - e6*e7*k23*k47 - e4*e7*k23*k67 &
  + e3*e7*k24*k67 - e2*e7*k34*k67 + k27*k34*k67 - k24*k37*k67 &
  + k23*k47*k67 + k26*k34*tk77 - k24*k36*tk77 &
  + k23*k46*tk77))/(e3*e6*e7*k22*k44*tk77)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! Close IF (cutnumber.EQ....) THEN
!
END IF
!
ELSE IF (flavorsetnumber.EQ.2) THEN
! Flavors = {quark, qbar, qbar, quark, gluon, gluon, qbar, quark}
!
IF (cutnumber.EQ.2) THEN
! cut = {7, 6, 1, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(1,mu)
  qj(mu) = k(7,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(1)
absqj = absk(7)
absqk = absk(6)
absl = absk(5)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = 0.5d0/nc   ! for q-barq
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(1)
e2 =  absk(6)
e3 =  absk(7)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(1,mu)*k(6,mu)*metric(mu)
  q13 = q13 + k(1,mu)*k(7,mu)*metric(mu)
  q23 = q23 + k(6,mu)*k(7,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(-(e2*e3*q12) - e2**2*q13 - 2*e2*e3*q13 &
  + e1*e2*q23 + q13*q23 + q12*tq22))/(e1*e2*e3*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.4) THEN
! cut = {8, 6, 3, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = - k(3,mu)
  qj(mu) = - k(8,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(3)
absqj = absk(8)
absqk = absk(6)
absl = absk(5)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = 0.5d0/nc   ! for q-barq
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(3)
e2 =  absk(6)
e3 =  absk(8)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 - k(3,mu)*k(6,mu)*metric(mu)
  q13 = q13 + k(3,mu)*k(8,mu)*metric(mu)
  q23 = q23 - k(6,mu)*k(8,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(-(e2*e3*q12) - e2**2*q13 - 2*e2*e3*q13 &
  + e1*e2*q23 + q13*q23 + q12*tq22))/(e1*e2*e3*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.6) THEN
! cut = {8, 6, 5, 1}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(8,mu) + k(7,mu))
  qj(mu) = 0.5d0*( k(1,mu) - k(3,mu))
  l(mu) = - k(5,mu)
END DO
absl = absk(5)
absqk = absk(6)
colorfactor = 0.5d0/nc   ! for q-barq
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e4 =  k(4,0)
e6 =  k(6,0)
e8 =  k(8,0)
k12 = 0.0d0
k14 = 0.0d0
k16 = 0.0d0
k18 = 0.0d0
k22 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k28 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k48 = 0.0d0
k68 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k18 = k18 + k(1,mu)*k(8,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k28 = k28 + k(2,mu)*k(8,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k48 = k48 + k(4,mu)*k(8,mu)*metric(mu)
  k68 = k68 + k(6,mu)*k(8,mu)*metric(mu)
END DO
tk66 = 0.0d0
DO mu = 1,3
  tk66 = tk66 - k(6,mu)**2
END DO
!
result = (2*cf*nc*(-(e6*e8*k16*k24) + e6**2*k18*k24 &
  + e6*e8*k14*k26 - e6**2*k14*k28 + e6*e8*k12*k46 - e6**2*k12*k48 &
  + e4*e6*k12*k68 + e2*e6*k14*k68 - e1*e6*k24*k68 + k16*k24*k68 &
  - k14*k26*k68 - k12*k46*k68 + k18*k24*tk66 - k14*k28*tk66 &
  - k12*k48*tk66))/(e1*e6*e8*k22*k44*tk66)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.8) THEN
! cut = {7, 6, 5, 3}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(3,mu) + k(1,mu))
  qj(mu) = 0.5d0*( k(7,mu) - k(8,mu))
  l(mu) =  k(5,mu)
END DO
absl = absk(5)
absqk = absk(6)
colorfactor = 0.5d0/nc   ! for q-barq
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e6 =  k(6,0)
e7 =  k(7,0)
k22 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k27 = 0.0d0
k34 = 0.0d0
k36 = 0.0d0
k37 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k47 = 0.0d0
k67 = 0.0d0
DO mu = 0,3
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k37 = k37 + k(3,mu)*k(7,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
  k67 = k67 + k(6,mu)*k(7,mu)*metric(mu)
END DO
tk66 = 0.0d0
DO mu = 1,3
  tk66 = tk66 - k(6,mu)**2
END DO
!
result = (-2*cf*nc*(-(e6*e7*k26*k34) + e6**2*k27*k34 &
  + e6*e7*k24*k36 - e6**2*k24*k37 - e6*e7*k23*k46 + e6**2*k23*k47 &
  - e4*e6*k23*k67 + e3*e6*k24*k67 - e2*e6*k34*k67 + k26*k34*k67 &
  - k24*k36*k67 + k23*k46*k67 + k27*k34*tk66 - k24*k37*tk66 &
  + k23*k47*tk66))/(e3*e6*e7*k22*k44*tk66)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! Close IF (cutnumber.EQ....) THEN
!
END IF
!
ELSE IF (flavorsetnumber.EQ.3) THEN
! Flavors = {qbar, quark, quark, qbar, gluon, quark, gluon, gluon}
!
IF (cutnumber.EQ.1) THEN
! cut = {5, 4, 1, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = - k(4,mu)
  qj(mu) = - k(5,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(4)
absqj = absk(5)
absqk = absk(1)
absl = absk(8)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(4)
e2 =  absk(5)
e3 =  absk(1)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(4,mu)*k(5,mu)*metric(mu)
  q13 = q13 - k(4,mu)*k(1,mu)*metric(mu)
  q23 = q23 - k(5,mu)*k(1,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.2) THEN
! cut = {7, 6, 1, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(1,mu)
  qj(mu) = k(7,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(1)
absqj = absk(7)
absqk = absk(6)
absl = absk(5)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(6)
e2 =  absk(7)
e3 =  absk(1)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(6,mu)*k(7,mu)*metric(mu)
  q13 = q13 + k(6,mu)*k(1,mu)*metric(mu)
  q23 = q23 + k(7,mu)*k(1,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12 - 2*e1*e2*q13 - e2**2*q13 + q12*q13 &
  - e1*e2*q23 + q23*tq22))/(e1*e2*e3*q12*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {7, 6, 1, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(6,mu)
  qj(mu) = k(7,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(6)
absqj = absk(7)
absqk = absk(1)
absl = absk(8)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(6)
e2 =  absk(7)
e3 =  absk(1)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(6,mu)*k(7,mu)*metric(mu)
  q13 = q13 + k(6,mu)*k(1,mu)*metric(mu)
  q23 = q23 + k(7,mu)*k(1,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.3) THEN
! cut = {5, 3, 2, 0}, psoft = 7
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(2,mu)
  qj(mu) = k(5,mu)
  l(mu) = k(7,mu)
END DO
absqi = absk(2)
absqj = absk(5)
absqk = absk(3)
absl = absk(7)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(2)
e2 =  absk(5)
e3 =  absk(3)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(2,mu)*k(5,mu)*metric(mu)
  q13 = q13 - k(2,mu)*k(3,mu)*metric(mu)
  q23 = q23 - k(5,mu)*k(3,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.4) THEN
! cut = {8, 6, 3, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = - k(3,mu)
  qj(mu) = - k(8,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(3)
absqj = absk(8)
absqk = absk(6)
absl = absk(5)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(6)
e2 =  absk(8)
e3 =  absk(3)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 - k(6,mu)*k(8,mu)*metric(mu)
  q13 = q13 - k(6,mu)*k(3,mu)*metric(mu)
  q23 = q23 + k(8,mu)*k(3,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12 - 2*e1*e2*q13 - e2**2*q13 + q12*q13 &
  - e1*e2*q23 + q23*tq22))/(e1*e2*e3*q12*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {8, 6, 3, 0}, psoft = 7
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(6,mu)
  qj(mu) = - k(8,mu)
  l(mu) = k(7,mu)
END DO
absqi = absk(6)
absqj = absk(8)
absqk = absk(3)
absl = absk(7)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(6)
e2 =  absk(8)
e3 =  absk(3)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 - k(6,mu)*k(8,mu)*metric(mu)
  q13 = q13 - k(6,mu)*k(3,mu)*metric(mu)
  q23 = q23 + k(8,mu)*k(3,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.5) THEN
! cut = {8, 7, 4, 1}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(4,mu) + k(6,mu))
  qj(mu) = 0.5d0*( k(7,mu) - k(5,mu))
  l(mu) =  k(8,mu)
END DO
absl = absk(8)
absqk = absk(1)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e7 =  k(7,0)
k12 = 0.0d0
k13 = 0.0d0
k14 = 0.0d0
k17 = 0.0d0
k22 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k27 = 0.0d0
k33 = 0.0d0
k34 = 0.0d0
k37 = 0.0d0
k47 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k17 = k17 + k(1,mu)*k(7,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k33 = k33 + k(3,mu)*k(3,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k37 = k37 + k(3,mu)*k(7,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
END DO
tk77 = 0.0d0
DO mu = 1,3
  tk77 = tk77 - k(7,mu)**2
END DO
!
result = (2*cf*nc*(-(e7**2*k14*k23) - e7**2*k13*k24 &
  + e3*e7*k17*k24 + e4*e7*k13*k27 + e7**2*k12*k34 - e2*e7*k17*k34 &
  - e1*e7*k27*k34 + k17*k27*k34 - e4*e7*k12*k37 + e1*e7*k24*k37 &
  - k17*k24*k37 - e3*e7*k12*k47 + e2*e7*k13*k47 - k13*k27*k47 &
  + k12*k37*k47 - 2*k14*k23*tk77))/(e1*e4*e7*k22*k33*tk77)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.6) THEN
! cut = {8, 6, 5, 1}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(5,mu) + k(7,mu))
  qj(mu) = 0.5d0*( k(6,mu) - k(4,mu))
  l(mu) = - k(8,mu)
END DO
absl = absk(8)
absqk = absk(1)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e3 =  k(3,0)
e5 =  k(5,0)
e6 =  k(6,0)
k12 = 0.0d0
k13 = 0.0d0
k15 = 0.0d0
k16 = 0.0d0
k22 = 0.0d0
k23 = 0.0d0
k25 = 0.0d0
k26 = 0.0d0
k33 = 0.0d0
k35 = 0.0d0
k36 = 0.0d0
k56 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k15 = k15 + k(1,mu)*k(5,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k25 = k25 + k(2,mu)*k(5,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k33 = k33 + k(3,mu)*k(3,mu)*metric(mu)
  k35 = k35 + k(3,mu)*k(5,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k56 = k56 + k(5,mu)*k(6,mu)*metric(mu)
END DO
tk55 = 0.0d0
DO mu = 1,3
  tk55 = tk55 - k(5,mu)**2
END DO
!
result = (-2*cf*nc*(-(e5**2*k16*k23) + e5*e6*k13*k25 &
  - e5**2*k13*k26 + e3*e5*k15*k26 - e5*e6*k12*k35 + e1*e5*k26*k35 &
  - k15*k26*k35 + e5**2*k12*k36 - e2*e5*k15*k36 - e1*e5*k25*k36 &
  + k15*k25*k36 - e3*e5*k12*k56 + e2*e5*k13*k56 - k13*k25*k56 &
  + k12*k35*k56 - 2*k16*k23*tk55))/(e1*e5*e6*k22*k33*tk55)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {8, 6, 5, 1}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(8,mu) + k(7,mu))
  qj(mu) = 0.5d0*( k(1,mu) - k(3,mu))
  l(mu) = - k(5,mu)
END DO
absl = absk(5)
absqk = absk(6)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e4 =  k(4,0)
e6 =  k(6,0)
e8 =  k(8,0)
k12 = 0.0d0
k14 = 0.0d0
k16 = 0.0d0
k18 = 0.0d0
k22 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k28 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k48 = 0.0d0
k68 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k18 = k18 + k(1,mu)*k(8,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k28 = k28 + k(2,mu)*k(8,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k48 = k48 + k(4,mu)*k(8,mu)*metric(mu)
  k68 = k68 + k(6,mu)*k(8,mu)*metric(mu)
END DO
tk88 = 0.0d0
DO mu = 1,3
  tk88 = tk88 - k(8,mu)**2
END DO
!
result = (-2*cf*nc*(e8**2*k16*k24 - e6*e8*k18*k24 - e8**2*k14*k26 &
  + e6*e8*k14*k28 - e8**2*k12*k46 + e6*e8*k12*k48 + e4*e8*k12*k68 &
  + e2*e8*k14*k68 - e1*e8*k24*k68 + k18*k24*k68 - k14*k28*k68 &
  - k12*k48*k68 + k16*k24*tk88 - k14*k26*tk88 &
  - k12*k46*tk88))/(e1*e6*e8*k22*k44*tk88)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.7) THEN
! cut = {8, 7, 3, 2}, psoft = 7
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(8,mu) + k(5,mu))
  qj(mu) = 0.5d0*( k(2,mu) + k(6,mu))
  l(mu) = - k(7,mu)
END DO
absl = absk(7)
absqk = absk(3)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e8 =  k(8,0)
k11 = 0.0d0
k12 = 0.0d0
k13 = 0.0d0
k14 = 0.0d0
k18 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k28 = 0.0d0
k34 = 0.0d0
k38 = 0.0d0
k44 = 0.0d0
k48 = 0.0d0
DO mu = 0,3
  k11 = k11 + k(1,mu)*k(1,mu)*metric(mu)
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k18 = k18 + k(1,mu)*k(8,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k28 = k28 + k(2,mu)*k(8,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k38 = k38 + k(3,mu)*k(8,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k48 = k48 + k(4,mu)*k(8,mu)*metric(mu)
END DO
tk88 = 0.0d0
DO mu = 1,3
  tk88 = tk88 - k(8,mu)**2
END DO
!
result = (-2*cf*nc*(-(e8**2*k14*k23) - e8**2*k13*k24 &
  + e3*e8*k18*k24 + e4*e8*k13*k28 + e8**2*k12*k34 - e2*e8*k18*k34 &
  - e1*e8*k28*k34 + k18*k28*k34 - e4*e8*k12*k38 + e1*e8*k24*k38 &
  - k18*k24*k38 - e3*e8*k12*k48 + e2*e8*k13*k48 - k13*k28*k48 &
  + k12*k38*k48 - 2*k14*k23*tk88))/(e2*e3*e8*k11*k44*tk88)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.8) THEN
! cut = {7, 6, 5, 3}, psoft = 7
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*(k(6,mu) + k(2,mu))
  qj(mu) = 0.5d0*( k(5,mu) - k(8,mu))
  l(mu) =  k(7,mu)
END DO
absl = absk(7)
absqk = absk(3)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e3 =  k(3,0)
e4 =  k(4,0)
e5 =  k(5,0)
e6 =  k(6,0)
k11 = 0.0d0
k13 = 0.0d0
k14 = 0.0d0
k15 = 0.0d0
k16 = 0.0d0
k34 = 0.0d0
k35 = 0.0d0
k36 = 0.0d0
k44 = 0.0d0
k45 = 0.0d0
k46 = 0.0d0
k56 = 0.0d0
DO mu = 0,3
  k11 = k11 + k(1,mu)*k(1,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k15 = k15 + k(1,mu)*k(5,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k35 = k35 + k(3,mu)*k(5,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k45 = k45 + k(4,mu)*k(5,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k56 = k56 + k(5,mu)*k(6,mu)*metric(mu)
END DO
tk55 = 0.0d0
DO mu = 1,3
  tk55 = tk55 - k(5,mu)**2
END DO
!
result = (-2*cf*nc*(e5*e6*k15*k34 - e5**2*k16*k34 + e4*e5*k16*k35 &
  + e5**2*k14*k36 - e5*e6*k13*k45 + e3*e5*k16*k45 - k16*k35*k45 &
  + e5**2*k13*k46 - e3*e5*k15*k46 - e1*e5*k35*k46 + k15*k35*k46 &
  - e4*e5*k13*k56 + e1*e5*k34*k56 - k15*k34*k56 + k13*k45*k56 &
  + 2*k14*k36*tk55))/(e3*e5*e6*k11*k44*tk55)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {7, 6, 5, 3}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(3,mu) + k(1,mu))
  qj(mu) = 0.5d0*( k(7,mu) - k(8,mu))
  l(mu) =  k(5,mu)
END DO
absl = absk(5)
absqk = absk(6)
colorfactor = - 0.5d0*nc  ! for q-g or qbar-g
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e6 =  k(6,0)
e7 =  k(7,0)
k22 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k27 = 0.0d0
k34 = 0.0d0
k36 = 0.0d0
k37 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k47 = 0.0d0
k67 = 0.0d0
DO mu = 0,3
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k37 = k37 + k(3,mu)*k(7,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
  k67 = k67 + k(6,mu)*k(7,mu)*metric(mu)
END DO
tk77 = 0.0d0
DO mu = 1,3
  tk77 = tk77 - k(7,mu)**2
END DO
!
result = (-2*cf*nc*(e7**2*k26*k34 - e6*e7*k27*k34 - e7**2*k24*k36 &
  + e6*e7*k24*k37 + e7**2*k23*k46 - e6*e7*k23*k47 - e4*e7*k23*k67 &
  + e3*e7*k24*k67 - e2*e7*k34*k67 + k27*k34*k67 - k24*k37*k67 &
  + k23*k47*k67 + k26*k34*tk77 - k24*k36*tk77 &
  + k23*k46*tk77))/(e3*e6*e7*k22*k44*tk77)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! Close IF (cutnumber.EQ....) THEN
!
END IF
!
ELSE IF (flavorsetnumber.EQ.4) THEN
! Flavors = {qbar, quark, quark, qbar, gluon, gluon, quark, qbar}
!
IF (cutnumber.EQ.2) THEN
! cut = {7, 6, 1, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(1,mu)
  qj(mu) = k(7,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(1)
absqj = absk(7)
absqk = absk(6)
absl = absk(5)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = 0.5d0/nc   ! for q-barq
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(7)
e2 =  absk(6)
e3 =  absk(1)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(7,mu)*k(6,mu)*metric(mu)
  q13 = q13 + k(7,mu)*k(1,mu)*metric(mu)
  q23 = q23 + k(6,mu)*k(1,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12 - 2*e1*e2*q13 - e2**2*q13 + q12*q13 &
  - e1*e2*q23 + q23*tq22))/(e1*e2*e3*q12*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.4) THEN
! cut = {8, 6, 3, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = - k(3,mu)
  qj(mu) = - k(8,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(3)
absqj = absk(8)
absqk = absk(6)
absl = absk(5)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = 0.5d0/nc   ! for q-barq
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(8)
e2 =  absk(6)
e3 =  absk(3)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 - k(8,mu)*k(6,mu)*metric(mu)
  q13 = q13 + k(8,mu)*k(3,mu)*metric(mu)
  q23 = q23 - k(6,mu)*k(3,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12 - 2*e1*e2*q13 - e2**2*q13 + q12*q13 &
  - e1*e2*q23 + q23*tq22))/(e1*e2*e3*q12*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.6) THEN
! cut = {8, 6, 5, 1}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(8,mu) + k(7,mu))
  qj(mu) = 0.5d0*( k(1,mu) - k(3,mu))
  l(mu) = - k(5,mu)
END DO
absl = absk(5)
absqk = absk(6)
colorfactor = 0.5d0/nc   ! for q-barq
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e4 =  k(4,0)
e6 =  k(6,0)
e8 =  k(8,0)
k12 = 0.0d0
k14 = 0.0d0
k16 = 0.0d0
k18 = 0.0d0
k22 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k28 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k48 = 0.0d0
k68 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k18 = k18 + k(1,mu)*k(8,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k28 = k28 + k(2,mu)*k(8,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k48 = k48 + k(4,mu)*k(8,mu)*metric(mu)
  k68 = k68 + k(6,mu)*k(8,mu)*metric(mu)
END DO
tk66 = 0.0d0
DO mu = 1,3
  tk66 = tk66 - k(6,mu)**2
END DO
!
result = (2*cf*nc*(-(e6*e8*k16*k24) + e6**2*k18*k24 &
  + e6*e8*k14*k26 - e6**2*k14*k28 + e6*e8*k12*k46 - e6**2*k12*k48 &
  + e4*e6*k12*k68 + e2*e6*k14*k68 - e1*e6*k24*k68 + k16*k24*k68 &
  - k14*k26*k68 - k12*k46*k68 + k18*k24*tk66 - k14*k28*tk66 &
  - k12*k48*tk66))/(e1*e6*e8*k22*k44*tk66)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.8) THEN
! cut = {7, 6, 5, 3}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(3,mu) + k(1,mu))
  qj(mu) = 0.5d0*( k(7,mu) - k(8,mu))
  l(mu) =  k(5,mu)
END DO
absl = absk(5)
absqk = absk(6)
colorfactor = 0.5d0/nc   ! for q-barq
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e6 =  k(6,0)
e7 =  k(7,0)
k22 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k27 = 0.0d0
k34 = 0.0d0
k36 = 0.0d0
k37 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k47 = 0.0d0
k67 = 0.0d0
DO mu = 0,3
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k37 = k37 + k(3,mu)*k(7,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
  k67 = k67 + k(6,mu)*k(7,mu)*metric(mu)
END DO
tk66 = 0.0d0
DO mu = 1,3
  tk66 = tk66 - k(6,mu)**2
END DO
!
result = (-2*cf*nc*(-(e6*e7*k26*k34) + e6**2*k27*k34 &
  + e6*e7*k24*k36 - e6**2*k24*k37 - e6*e7*k23*k46 + e6**2*k23*k47 &
  - e4*e6*k23*k67 + e3*e6*k24*k67 - e2*e6*k34*k67 + k26*k34*k67 &
  - k24*k36*k67 + k23*k46*k67 + k27*k34*tk66 - k24*k37*tk66 &
  + k23*k47*tk66))/(e3*e6*e7*k22*k44*tk66)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! Close IF (cutnumber.EQ....) THEN
!
END IF
!
! Close IF (flavorsetnumber.EQ.1) THEN ...
!
END IF
ELSE IF (graphnumber.EQ.8) THEN
! Code for graph 8, with connections
! {{3, 4}, {5, 6}, {1, 4, 5}, {1, 3, 6}, {2, 3, 6}, {2, 4, 5}}.
!
softsubtraction = zero
!
ELSE IF (graphnumber.EQ.9) THEN
! Code for graph 9, with connections
! {{3, 4}, {5, 6}, {1, 5, 5}, {1, 6, 6}, {2, 3, 3}, {2, 4, 4}}.
!
softsubtraction = zero
!
ELSE IF (graphnumber.EQ.10) THEN
! Code for graph 10, with connections
! {{3, 4}, {5, 6}, {1, 5, 6}, {1, 5, 6}, {2, 3, 4}, {2, 3, 4}}.
!
IF (flavorsetnumber.EQ.1) THEN
! Flavors = {quark, qbar, quark, qbar, gluon, quark, qbar, gluon}
!
IF (cutnumber.EQ.1) THEN
! cut = {8, 7, 1, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(1,mu)
  qj(mu) = k(7,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(1)
absqj = absk(7)
absqk = absk(8)
absl = absk(5)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = 0.5d0/nc   ! for q-barq
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(1)
e2 =  absk(8)
e3 =  absk(7)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(1,mu)*k(8,mu)*metric(mu)
  q13 = q13 + k(1,mu)*k(7,mu)*metric(mu)
  q23 = q23 + k(8,mu)*k(7,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.2) THEN
! cut = {6, 5, 2, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(2,mu)
  qj(mu) = k(6,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(2)
absqj = absk(6)
absqk = absk(5)
absl = absk(8)
lrsign = -1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = 0.5d0/nc   ! for q-barq
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(6)
e2 =  absk(5)
e3 =  absk(2)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(6,mu)*k(5,mu)*metric(mu)
  q13 = q13 + k(6,mu)*k(2,mu)*metric(mu)
  q23 = q23 + k(5,mu)*k(2,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.3) THEN
! cut = {8, 6, 3, 0}, psoft = 5
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(6,mu)
  qj(mu) = - k(3,mu)
  l(mu) = k(5,mu)
END DO
absqi = absk(6)
absqj = absk(3)
absqk = absk(8)
absl = absk(5)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = 0.5d0/nc   ! for q-barq
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(6)
e2 =  absk(8)
e3 =  absk(3)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 + k(6,mu)*k(8,mu)*metric(mu)
  q13 = q13 - k(6,mu)*k(3,mu)*metric(mu)
  q23 = q23 - k(8,mu)*k(3,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.4) THEN
! cut = {7, 5, 4, 0}, psoft = 8
! Calculate for exchange of a virtual soft gluon.
!
DO mu = 1,3
  qi(mu) = k(7,mu)
  qj(mu) = - k(4,mu)
  l(mu) = k(8,mu)
END DO
absqi = absk(7)
absqj = absk(4)
absqk = absk(5)
absl = absk(8)
lrsign = 1    ! +1 for a leftloop, -1 for a rightloop
colorfactor = 0.5d0/nc   ! for q-barq
call &
  getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  absk(4)
e2 =  absk(5)
e3 =  absk(7)
q12 = 0.0d0
q13 = 0.0d0
q23 = 0.0d0
DO mu = 0,3
  q12 = q12 - k(4,mu)*k(5,mu)*metric(mu)
  q13 = q13 - k(4,mu)*k(7,mu)*metric(mu)
  q23 = q23 + k(5,mu)*k(7,mu)*metric(mu)
END DO
tq22 = - e2**2
!
result = (cf*nc*(e2*e3*q12**2 + e2**2*q12*q13 + 2*e2*e3*q12*q13 &
  - e1*e2*q12*q23 - e2*e3*q12*q23 + 2*e1*e2*q13*q23 + e2**2*q13*q23 &
  - 2*q12*q13*q23 + e1*e2*q23**2 + 2*q12*q13*tq22 + 2*q13**2*tq22 &
  + 2*q13*q23*tq22))/(2.0d0*e1*e2*e3*q12*q23*tq22)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.5) THEN
! cut = {8, 5, 3, 1}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(3,mu) + k(7,mu))
  qj(mu) = 0.5d0*( k(1,mu) + k(6,mu))
  l(mu) = - k(5,mu)
END DO
absl = absk(5)
absqk = absk(8)
colorfactor = 0.5d0/nc   ! for q-barq
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e8 =  k(8,0)
k12 = 0.0d0
k13 = 0.0d0
k14 = 0.0d0
k18 = 0.0d0
k22 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k28 = 0.0d0
k34 = 0.0d0
k38 = 0.0d0
k44 = 0.0d0
k48 = 0.0d0
DO mu = 0,3
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k18 = k18 + k(1,mu)*k(8,mu)*metric(mu)
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k28 = k28 + k(2,mu)*k(8,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k38 = k38 + k(3,mu)*k(8,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k48 = k48 + k(4,mu)*k(8,mu)*metric(mu)
END DO
tk88 = 0.0d0
DO mu = 1,3
  tk88 = tk88 - k(8,mu)**2
END DO
!
result = (2*cf*nc*(-(e8**2*k14*k23) + e4*e8*k18*k23 &
  - e8**2*k13*k24 + e3*e8*k14*k28 + e8**2*k12*k34 - e2*e8*k18*k34 &
  - e1*e8*k28*k34 + k18*k28*k34 - e4*e8*k12*k38 + e2*e8*k14*k38 &
  - k14*k28*k38 - e3*e8*k12*k48 + e1*e8*k23*k48 - k18*k23*k48 &
  + k12*k38*k48 - 2*k13*k24*tk88))/(e1*e3*e8*k22*k44*tk88)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.8) THEN
! cut = {8, 5, 4, 2}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*( - k(4,mu) + k(6,mu))
  qj(mu) = 0.5d0*( k(2,mu) + k(7,mu))
  l(mu) = - k(8,mu)
END DO
absl = absk(8)
absqk = absk(5)
colorfactor = 0.5d0/nc   ! for q-barq
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e2 =  k(2,0)
e3 =  k(3,0)
e4 =  k(4,0)
e5 =  k(5,0)
k11 = 0.0d0
k12 = 0.0d0
k13 = 0.0d0
k14 = 0.0d0
k15 = 0.0d0
k23 = 0.0d0
k24 = 0.0d0
k25 = 0.0d0
k33 = 0.0d0
k34 = 0.0d0
k35 = 0.0d0
k45 = 0.0d0
DO mu = 0,3
  k11 = k11 + k(1,mu)*k(1,mu)*metric(mu)
  k12 = k12 + k(1,mu)*k(2,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k14 = k14 + k(1,mu)*k(4,mu)*metric(mu)
  k15 = k15 + k(1,mu)*k(5,mu)*metric(mu)
  k23 = k23 + k(2,mu)*k(3,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k25 = k25 + k(2,mu)*k(5,mu)*metric(mu)
  k33 = k33 + k(3,mu)*k(3,mu)*metric(mu)
  k34 = k34 + k(3,mu)*k(4,mu)*metric(mu)
  k35 = k35 + k(3,mu)*k(5,mu)*metric(mu)
  k45 = k45 + k(4,mu)*k(5,mu)*metric(mu)
END DO
tk55 = 0.0d0
DO mu = 1,3
  tk55 = tk55 - k(5,mu)**2
END DO
!
result = (2*cf*nc*(-(e5**2*k14*k23) + e4*e5*k15*k23 &
  - e5**2*k13*k24 + e3*e5*k14*k25 + e5**2*k12*k34 - e2*e5*k15*k34 &
  - e1*e5*k25*k34 + k15*k25*k34 - e4*e5*k12*k35 + e2*e5*k14*k35 &
  - k14*k25*k35 - e3*e5*k12*k45 + e1*e5*k23*k45 - k15*k23*k45 &
  + k12*k35*k45 - 2*k13*k24*tk55))/(e2*e4*e5*k11*k33*tk55)
result = result*softfactor
softsubtraction = softsubtraction - result
!
ELSE IF (cutnumber.EQ.9) THEN
! cut = {8, 7, 6, 5}, psoft = 8
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*(k(7,mu) + k(2,mu))
  qj(mu) = 0.5d0*( k(6,mu) - k(4,mu))
  l(mu) =  k(8,mu)
END DO
absl = absk(8)
absqk = absk(5)
colorfactor = 0.5d0/nc   ! for q-barq
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e1 =  k(1,0)
e3 =  k(3,0)
e5 =  k(5,0)
e6 =  k(6,0)
e7 =  k(7,0)
k11 = 0.0d0
k13 = 0.0d0
k15 = 0.0d0
k16 = 0.0d0
k17 = 0.0d0
k33 = 0.0d0
k35 = 0.0d0
k36 = 0.0d0
k37 = 0.0d0
k56 = 0.0d0
k57 = 0.0d0
k67 = 0.0d0
DO mu = 0,3
  k11 = k11 + k(1,mu)*k(1,mu)*metric(mu)
  k13 = k13 + k(1,mu)*k(3,mu)*metric(mu)
  k15 = k15 + k(1,mu)*k(5,mu)*metric(mu)
  k16 = k16 + k(1,mu)*k(6,mu)*metric(mu)
  k17 = k17 + k(1,mu)*k(7,mu)*metric(mu)
  k33 = k33 + k(3,mu)*k(3,mu)*metric(mu)
  k35 = k35 + k(3,mu)*k(5,mu)*metric(mu)
  k36 = k36 + k(3,mu)*k(6,mu)*metric(mu)
  k37 = k37 + k(3,mu)*k(7,mu)*metric(mu)
  k56 = k56 + k(5,mu)*k(6,mu)*metric(mu)
  k57 = k57 + k(5,mu)*k(7,mu)*metric(mu)
  k67 = k67 + k(6,mu)*k(7,mu)*metric(mu)
END DO
tk55 = 0.0d0
DO mu = 1,3
  tk55 = tk55 - k(5,mu)**2
END DO
!
result = (2*cf*nc*(e5*e7*k16*k35 - e5*e6*k17*k35 - e5*e7*k15*k36 &
  + e5**2*k17*k36 + e5*e6*k15*k37 - e5**2*k16*k37 - e3*e5*k17*k56 &
  + k17*k35*k56 + e1*e5*k37*k56 - k15*k37*k56 + e3*e5*k16*k57 &
  - k16*k35*k57 - e1*e5*k36*k57 + k15*k36*k57 - e5**2*k13*k67 &
  - 2*k13*k67*tk55))/(e5*e6*e7*k11*k33*tk55)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! cut = {8, 7, 6, 5}, psoft = 5
! Calculate for exchange of a real soft gluon.
!
DO mu = 1,3
  qi(mu) = 0.5d0*(k(6,mu) + k(1,mu))
  qj(mu) = 0.5d0*( k(7,mu) - k(3,mu))
  l(mu) =  k(5,mu)
END DO
absl = absk(5)
absqk = absk(8)
colorfactor = 0.5d0/nc   ! for q-barq
call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
! Now we calculate the remaining Born graph.
!
e2 =  k(2,0)
e4 =  k(4,0)
e6 =  k(6,0)
e7 =  k(7,0)
e8 =  k(8,0)
k22 = 0.0d0
k24 = 0.0d0
k26 = 0.0d0
k27 = 0.0d0
k28 = 0.0d0
k44 = 0.0d0
k46 = 0.0d0
k47 = 0.0d0
k48 = 0.0d0
k67 = 0.0d0
k68 = 0.0d0
k78 = 0.0d0
DO mu = 0,3
  k22 = k22 + k(2,mu)*k(2,mu)*metric(mu)
  k24 = k24 + k(2,mu)*k(4,mu)*metric(mu)
  k26 = k26 + k(2,mu)*k(6,mu)*metric(mu)
  k27 = k27 + k(2,mu)*k(7,mu)*metric(mu)
  k28 = k28 + k(2,mu)*k(8,mu)*metric(mu)
  k44 = k44 + k(4,mu)*k(4,mu)*metric(mu)
  k46 = k46 + k(4,mu)*k(6,mu)*metric(mu)
  k47 = k47 + k(4,mu)*k(7,mu)*metric(mu)
  k48 = k48 + k(4,mu)*k(8,mu)*metric(mu)
  k67 = k67 + k(6,mu)*k(7,mu)*metric(mu)
  k68 = k68 + k(6,mu)*k(8,mu)*metric(mu)
  k78 = k78 + k(7,mu)*k(8,mu)*metric(mu)
END DO
tk88 = 0.0d0
DO mu = 1,3
  tk88 = tk88 - k(8,mu)**2
END DO
!
result = (2*cf*nc*(-(e8**2*k27*k46) + e7*e8*k28*k46 &
  + e8**2*k26*k47 - e6*e8*k28*k47 - e7*e8*k26*k48 + e6*e8*k27*k48 &
  - e8**2*k24*k67 + e4*e8*k27*k68 - e2*e8*k47*k68 + k28*k47*k68 &
  - k27*k48*k68 - e4*e8*k26*k78 + e2*e8*k46*k78 - k28*k46*k78 &
  + k26*k48*k78 - 2*k24*k67*tk88))/(e6*e7*e8*k22*k44*tk88)
result = result*softfactor
softsubtraction = softsubtraction - result
!
! Close IF (cutnumber.EQ....) THEN
!
END IF
!
! Close IF (flavorsetnumber.EQ.1) THEN ...
!
END IF
!
! Close IF (graphnumber.EQ.1) THEN
!
END IF
!
end function softsubtraction
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine &
getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: qi(3),qj(3),l(3)
real(kind=dbl) :: absqi,absqj,absqk,absl
real(kind=dbl) :: colorfactor,lrsign
! Out:
complex(kind=dbl) :: softfactor
!
! Calculates softfactor, the integrand for the virtual soft subtraction.
! Here softfactor includes the factor F_{ij}, the factor
! theta(l_{ij}^2 < Msoft^2), the jacobian, and a factor 1/(2*|s_{ij}|^3).
!
!  6 February 2003
! 14 June 2003
!
real(kind=dbl), parameter :: lambdasoft = 0.333333333333333333d0
complex(kind=dbl), parameter :: zero = (0.0d0,0.0d0)
complex(kind=dbl), parameter ::  one = (1.0d0,0.0d0)
complex(kind=dbl), parameter ::    i = (0.0d0,1.0d0)
real(kind=dbl) :: deformalpha,deformbeta,deformgamma
common /deformscales/deformalpha,deformbeta,deformgamma
integer :: mu,nu
real(kind=dbl) :: cosli,coslj,cosij
real(kind=dbl) :: hatqi(3),hatqj(3),hatl(3)
real(kind=dbl) :: lsq
real(kind=dbl) :: temp,temp1,temp2,temp3
real(kind=dbl) :: tempi(3),tempj(3),tempa(3),tempb(3)
real(kind=dbl) :: czeta,dampingfactor
real(kind=dbl) :: xi(3),zeta(3)
complex(kind=dbl) :: s(3),hats(3)
complex(kind=dbl) :: complexsqrt
complex(kind=dbl) :: ssq,abss,cosis,cosjs
complex(kind=dbl) :: fijV
real(kind=dbl) :: delta
real(kind=dbl) :: gradxi(3,3),gradzeta(3,3)
real(kind=dbl) :: msoftsq
complex(kind=dbl) :: b(3,3)
complex(kind=dbl) :: jacobian
real(kind=dbl) :: rts0,thrust0
real(kind=dbl) :: n(3)
complex(kind=dbl) :: eta(3)
real(kind=dbl) :: x,x0,y
complex(kind=dbl) :: z,c
complex(kind=dbl) :: ctemp1,ctemp2
real(kind=dbl) :: gradx(3),grady(3)
complex(kind=dbl) :: gradz(3),gradc(3),tempc(3)
complex(kind=dbl) :: gradeta(3,3)
!
! Return 0 if absl is out of range. We first calculate lsq and msoftsq.
!
lsq = absl**2
rts0 = absqi + absqj + absqk
thrust0 = 2.0d0 * max(absqi,absqj,absqk) /rts0
msoftsq = ( lambdasoft * rts0 *(1.0d0 - thrust0) )**2
IF (lsq.GT.msoftsq) THEN
  softfactor = zero
  RETURN
END IF
!
cosli = 0.0d0
coslj = 0.0d0
cosij = 0.0d0
DO mu = 1,3
  hatqi(mu) = qi(mu)/absqi
  hatqj(mu) = qj(mu)/absqj
  hatl(mu)  = l(mu)/absl
  cosli = cosli + hatl(mu)*hatqi(mu)
  coslj = coslj + hatl(mu)*hatqj(mu)
  cosij = cosij + hatqi(mu)*hatqj(mu)
END DO
temp = sqrt(2.0d0*(1.0d0 - cosij))
x0 = 0.5d0*temp
x = 0.0d0
DO mu = 1,3
  n(mu) = (hatqj(mu) - hatqi(mu))/temp
  x = x + n(mu)*hatl(mu)
END DO
IF (x**2.GT.x0**2) THEN
  DO mu = 1,3
    eta(mu) = zero
  END DO
ELSE
  y = lsq/msoftsq*(x0**2 - x**2)**2
  z = x + i*y
  c = complexsqrt((one - z**2)/(1.0d0 - x**2))
  ctemp1 = c - one
  ctemp2 = (z - c*x)*absl
  DO mu = 1,3
    eta(mu) = ctemp1*l(mu) + ctemp2*n(mu)
  END DO
END IF
!
temp = lrsign*lsq/2.0d0/absqi/absqj/(1.0d0 - cosij)
temp1 = 1.0d0 - coslj**2
temp2 = 1.0d0 - cosli**2
czeta = 2.0d0*deformalpha/(1.0d0 + deformgamma)
czeta = czeta/(absqi + absqj - absqk)
temp3 = czeta * lsq * min(1.0d0 + lrsign*cosli,1.0d0 - lrsign*coslj)
dampingfactor = (1.0d0 - lsq/msoftsq)
ssq = zero
DO mu = 1,3
  xi(mu) = temp*(temp1*qi(mu) - temp2*qj(mu))
  zeta(mu) = temp3*(hatqj(mu) - hatqi(mu))
  s(mu) = l(mu) + dampingfactor*( xi(mu) + i*zeta(mu) ) + eta(mu)
  ssq = ssq + s(mu)**2
END DO
abss = complexsqrt(ssq)
cosis = zero
cosjs = zero
DO mu = 1,3
  hats(mu) = s(mu)/abss
  cosis = cosis + hatqi(mu)*hats(mu)
  cosjs = cosjs + hatqj(mu)*hats(mu)
END DO
fijV = one/(one + lrsign*cosis) + one/(one - lrsign*cosjs)
fijV = -fijV*(cosij - cosis*cosjs)
fijV = fijV + 2.0d0
fijV = colorfactor*lrsign*fijV/(cosjs - cosis)
!
! Calculate the jacobian.
! Start with grad xi.
!
temp = lrsign*absqi*absqj*(1.0d0 - cosij)
DO mu = 1,3
tempj(mu) = l(mu) - absl*coslj*hatqj(mu)
tempi(mu) = l(mu) - absl*cosli*hatqi(mu)
END DO
DO mu = 1,3
DO nu = 1,3
  gradxi(mu,nu) = ( qi(mu)*tempj(nu) - qj(mu)*tempi(nu) )/temp
END DO
END DO
!
! Now try grad zeta. There are four cases.
!
IF ((cosli + coslj).LT.0.0d0) THEN
  DO mu = 1,3
    tempa(mu) = czeta*( hatqj(mu) - hatqi(mu) )
    IF (lrsign.GT.0.0d0) THEN    ! left loop
      tempb(mu) = (2.0d0 + cosli)*l(mu) + absl*hatqi(mu)
    ELSE                         ! right loop
      tempb(mu) = (2.0d0 + coslj)*l(mu) + absl*hatqj(mu)
    END IF
  END DO
  DO mu = 1,3
  DO nu = 1,3
    gradzeta(mu,nu) = tempa(mu)*tempb(nu)
  END DO
  END DO
ELSE         ! (cosli + coslj.GT.0.0d0)
  DO mu = 1,3
    tempa(mu) = czeta*( hatqj(mu) - hatqi(mu) )
    IF (lrsign.GT.0.0d0) THEN    ! left loop
      tempb(mu) = (2.0d0 - coslj)*l(mu) - absl*hatqj(mu)
    ELSE                         ! right loop
      tempb(mu) = (2.0d0 - cosli)*l(mu) - absl*hatqi(mu)
    END IF
  END DO
  DO mu = 1,3
  DO nu = 1,3
    gradzeta(mu,nu) = tempa(mu)*tempb(nu)
  END DO
  END DO
END IF
!
! Now we need gradeta(mu,nu).
!
IF (x**2.GT.x0**2) THEN  ! In this case, eta(mu) = 0.
  DO mu = 1,3
  DO nu = 1,3
    gradeta(mu,nu) = zero
  END DO
  END DO
ELSE
  DO mu = 1,3
    gradx(mu) = (n(mu) - x*hatl(mu))/absl
    grady(mu) = 2.0d0*y/absl*hatl(mu) - 4.0d0*x*y/(x0**2 - x**2)*gradx(mu)
    gradz(mu) = gradx(mu) + i*grady(mu)
    gradc(mu) = c*(x/(1.0d0 - x**2)*gradx(mu) - z/(one - z**2)*gradz(mu))
    tempc(mu) = (gradz(mu) - gradx(mu)*c - x*gradc(mu))*absl &
               + (z - x*c)*hatl(mu)
  END DO
  DO mu = 1,3
  DO nu = 1,3
    gradeta(mu,nu) = tempc(nu)*n(mu) + gradc(nu)*l(mu)
  END DO
    gradeta(mu,mu) = gradeta(mu,mu) + c - one
  END DO
END IF  ! x**2.GT.x0**2
!
! Now assemble the matrix B.
!
temp1 = (1.0d0 - lsq/msoftsq)
temp2 = 2.0d0/msoftsq
DO mu = 1,3
DO nu = 1,3
  b(mu,nu) = delta(mu,nu) &
     + temp1*( gradxi(mu,nu) + i*gradzeta(mu,nu) )  &
     - temp2*l(mu)*( xi(nu) + i*zeta(nu) )                      &
     + gradeta(mu,nu)
END DO
END DO
!
! The jacobian is the deteminant of the matrix B.
!
jacobian =  b(1,1)*(b(2,2)*b(3,3) - b(2,3)*b(3,2)) &
          + b(1,2)*(b(2,3)*b(3,1) - b(2,1)*b(3,3)) &
          + b(1,3)*(b(2,1)*b(3,2) - b(2,2)*b(3,1))
!
! Now we can assemble everything.
!
softfactor = jacobian*fijV/2.0d0/abss**3
!
END subroutine getsoftfactorV
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine &
getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: qi(3),qj(3),l(3)
real(kind=dbl) :: absl,absqk,colorfactor
! Out:
complex(kind=dbl) :: softfactor
!
! Calculates softfactor, the integrand for the real soft subtraction.
! Here softfactor includes the factor F_{ij}, a factor 1/(2*|l_{ij}|^3),
! and a theta function theta(l_{ij}^2 < Msoft^2).
!
!  1 February 2003
! 15 June 2003
!
real(kind=dbl), parameter :: lambdasoft = 0.333333333333333333d0
integer :: mu,nu
real(kind=dbl) :: qisq,qjsq,absqi,absqj
real(kind=dbl) :: hatqi(3),hatqj(3),hatl(3)
real(kind=dbl) :: cosli,coslj,cosij
real(kind=dbl) :: msoftsq,fijR
real(kind=dbl) :: rts0,thrust0
!
qisq = 0.0d0
qjsq = 0.0d0
DO mu = 1,3
  qisq = qisq + qi(mu)**2
  qjsq = qjsq + qj(mu)**2
END DO
absqi = sqrt(qisq)
absqj = sqrt(qjsq)
!
! We need msoftsq, the square of lambdasoft * rts0 * (1 - thrust).
!
rts0 = absqi + absqj + absqk
thrust0 = 2.0d0 * max(absqi,absqj,absqk) /rts0
msoftsq = ( lambdasoft * rts0 *(1.0d0 - thrust0) )**2
!
! Now we can implement the theta(l_{ij}^2 < Msoft^2).
!
IF (absl**2.GT.msoftsq) THEN
  softfactor = (0.0d0,0.0d0)
  RETURN
END IF
!
DO mu = 1,3
  hatqi(mu) = qi(mu)/absqi
  hatqj(mu) = qj(mu)/absqj
  hatl(mu) = l(mu)/absl
END DO
cosli = 0.0d0
coslj = 0.0d0
cosij = 0.0d0
DO mu = 1,3
  cosli = cosli + hatl(mu)*hatqi(mu)
  coslj = coslj + hatl(mu)*hatqj(mu)
  cosij = cosij + hatqi(mu)*hatqj(mu)
END DO
fijR = (cosij - cosli*coslj)/(1.0d0 - cosli)/(1.0d0 - coslj)
fijR = colorfactor*fijR
softfactor = fijR/2.0d0/absl**3
!
END subroutine getsoftfactorR
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!             Feynman integrand in Coulomb gauge, BORN level
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function feynman0(graphnumber,flavorsetnumber,kin,cut)
!
use beowulf_helpers
implicit none
! In:
integer :: graphnumber,flavorsetnumber
real(kind=dbl), dimension(0:3*size-1,0:3) :: kin
logical, dimension(3*size-1) :: cut
! Out:
complex(kind=dbl) :: feynman0
!
! Feynman integrand function for graph GRAPHNUMBER
! with momenta KIN and cut specified by CUT. This subroutine
! is for the Born graphs in Coulomb gauge.
! Early version: 17 July 1994.
! This version written by Mathematica code of 2 July 2002 on
! 2 Jul 2002.
! Input variables mumsbar and flag removed 1 September 2002, DES.
! Calculation changed to real, 3 January 2003, DES.
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
real(kind=dbl), parameter :: gn(0:3) =  (/1.0d0,0.0d0,0.0d0,0.0d0/) 
!
integer :: mu,nu,tau
real(kind=dbl),dimension(256) :: x
real(kind=dbl),dimension(0:3) :: k1,k2,k3,k4,k5
real(kind=dbl) :: e1,e2,e3,e4,e5
real(kind=dbl) :: k11,k22,k33,k44,k55
real(kind=dbl) :: tk11,tk22,tk33,tk44,tk55
real(kind=dbl) :: prefactor
real(kind=dbl) :: result
!
real(kind=dbl) :: k1k2,k1k3,k1k4,k1k5,k2k3,k2k4,k2k5,k3k4,k3k5
!
DO mu = 0,3
  k1(mu) = kin(1,mu)
  k2(mu) = kin(2,mu)
  k3(mu) = kin(3,mu)
  k4(mu) = kin(4,mu)
  k5(mu) = kin(5,mu)
END DO
result = 0.0d0
!
!------
!
IF (graphnumber .EQ. 11) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,quark,gluon,qbar}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k5 = 0.0d0
k2k3 = 0.0d0
k2k5 = 0.0d0
k3k5 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k5 = k1k5 + k1(mu)*k5(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k5 = k2k5 + k2(mu)*k5(mu)*metric(mu)
  k3k5 = k3k5 + k3(mu)*k5(mu)*metric(mu)
END DO
x(1) = k1k2*((-2*k2k3 - 2*k2k5)*k55 + e4*(-2*e5*k2k3 + 2*e3*k2k5 &
  - 2*e2*k3k5 - 4*e2*k55) - 4*k2k5*tk44)
x(2) = -(k1k3*k2k5) + k1k2*k3k5 + (k1k2 + k1k3 + k1k5)*k55 + k1k5 &
 *(k2k3 + 2*tk44)
x(3) = e5*(k1k2 + k1k3) + (e2 - e3)*k1k5 + e1*(-k2k5 + k3k5 &
  + 2*k55)
x(4) = x(2) + e4*x(3)
x(5) = x(1) + k22*x(4)
result = (-8*cf*nc*x(5))/tk44
result = result*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {qbar,quark,qbar,gluon,quark}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k5 = 0.0d0
k2k3 = 0.0d0
k2k5 = 0.0d0
k3k5 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k5 = k1k5 + k1(mu)*k5(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k5 = k2k5 + k2(mu)*k5(mu)*metric(mu)
  k3k5 = k3k5 + k3(mu)*k5(mu)*metric(mu)
END DO
x(1) = k1k2*((-2*k2k3 - 2*k2k5)*k55 + e4*(-2*e5*k2k3 + 2*e3*k2k5 &
  - 2*e2*k3k5 - 4*e2*k55) - 4*k2k5*tk44)
x(2) = -(k1k3*k2k5) + k1k2*k3k5 + (k1k2 + k1k3 + k1k5)*k55 + k1k5 &
 *(k2k3 + 2*tk44)
x(3) = e5*(k1k2 + k1k3) + (e2 - e3)*k1k5 + e1*(-k2k5 + k3k5 &
  + 2*k55)
x(4) = x(2) + e4*x(3)
x(5) = x(1) + k22*x(4)
result = (-8*cf*nc*x(5))/tk44
result = result*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 12) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,qbar,quark,gluon}
!
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
k1k2 = 0.0d0
k1k3 = 0.0d0
k1k4 = 0.0d0
k2k3 = 0.0d0
k2k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
  k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu)
  k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu)
  k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu)
  k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
x(1) = k1k4*k22*k33 + k11*k22*k3k4 + (k11*k2k3 + k1k2*k33)*k44 &
  + 4*k1k4*k2k3*tk55
x(2) = (e4*k1k2 + e2*k1k4 - e1*k2k4)*k33 + k22*(e4*k1k3 - e3*k1k4 &
  - e1*k3k4) + k11*(e4*k2k3 - e3*k2k4 + e2*k3k4)
x(3) = -(e3*k1k2) + e2*k1k3 - e1*k2k3
x(4) = x(2) + k44*x(3)
x(5) = x(1) + e5*x(4)
result = (8*cf*nc*x(5))/tk55
result = result*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
END IF
!
feynman0 = result
RETURN
END function feynman0
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!                Vertex and propagator functions in Coulomb gauge
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,out)
!
use beowulf_helpers
implicit none
! In:
character(len=9) :: kind2pt
complex(kind=dbl) :: k2pt(0:2,0:3)
logical :: cut2pt(0:3)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: out(0:3,0:3)
!
! Calculates the one loop gluon two-point function, including the
! adjoining propagators.
!
! kind2pt:
!   GLUONLOOP gluon self-energy with a gluon (including ghost) loop
!   QUARKLOOP gluon self-energy with a quark loop
!   BOTHLOOPS the sum of these
!
! k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part)
! k2pt(1,mu): 1st momentum in loop (kplus for the space part)
! k2pt(2,mu): 2nd momentum in loop (kminus for the space part)
!
! cut2pt(0): whether incoming line is cut
! cut2pt(1): whether 1st internal line is cut
! cut2pt(2): whether 2nd internal line is cut
! cut2pt(3): whether outgoing line is cut
!
! mumsbar is the MSbar renormalization scale.
!
! The result is the two  point function out(mu,nu) with a certain
! normalization. Specifically, for the cut gluon self-energy
! graph, out(mu,nu) is {\cal M}_g^{\mu\nu}
! divided by (\alpha_s/(4\pi)) * 1/(1+\Delta) and divided
! by 2\omega_+ * 2\omega_- *\bar q^2. The factor by which we divide
! consists of
! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
!   one (2\pi)^{-3} for each loop that is factored out of each
!   graph in our program.
! * (d\vec l)/(d\bar q^2 dx d\phi)
!    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
! * 4 \pi {\cal Q} \bar q^2 included in the relation between
!   {\cal I}[real] and {\cal M}_g^{\mu\nu}
!
! In the case of the virtual gluon self-energy graphs
! with an adjacent propagator cut, out(mu,nu) is {\cal W}_g^{\mu\nu}
! divided by the same factors.
!
! 16 December 2001
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
integer :: mu,nu
complex(kind=dbl) :: complexsqrt
complex(kind=dbl) :: kplus(1:3),kminus(1:3),ell(1:3),q(1:3)
complex(kind=dbl) :: calqsq, omegaplussq,omegaminussq
complex(kind=dbl) :: calq,omegaplus,omegaminus,q0
complex(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq
complex(kind=dbl) :: ellt(1:3)
complex(kind=dbl) :: elltsq,denom,onem2x1mx,onem4x1mx
complex(kind=dbl) :: temp
complex(kind=dbl) :: bareprop(1:3,1:3)
complex(kind=dbl) :: ntt,nll,nee,nel
complex(kind=dbl) :: prefactor
complex(kind=dbl) :: termtt,termll
complex(kind=dbl) :: at0,at1,at2
complex(kind=dbl) :: ntt0,ntt1,ntt2
complex(kind=dbl) :: net0,net1,net2
complex(kind=dbl) :: utt,net
! 
! Some auxilliary variables, including
! CALQ = {\cal Q}
! OMEGAPLUS = \omega_+
! OMEGAMINUS = \omega_-
! DELTAP1 = \Delta + 1
! TWOXM1 = 2 x - 1
! X1MX = x (1-x)
! ELLT(mu) = l_T^\mu
! ELLTSQ = (\vec l_T)^2
! Q(mu) = the incoming *three*-momentum
! Q0 = the incoming energy
!
DO mu = 1,3
  kplus(mu) = k2pt(1,mu)
  kminus(mu) = k2pt(2,mu)
  ell(mu) = (kplus(mu) - kminus(mu))/2.0d0
  q(mu) = k2pt(0,mu)
END DO
q0 = k2pt(0,0)
calqsq = 0.0d0
omegaplussq = 0.0d0
omegaminussq = 0.0d0
DO mu = 1,3
  calqsq = calqsq + q(mu)**2
  omegaplussq = omegaplussq + kplus(mu)**2
  omegaminussq = omegaminussq + kminus(mu)**2
END DO
calq = complexsqrt(calqsq)
omegaplus  = complexsqrt(omegaplussq)
omegaminus = complexsqrt(omegaminussq)
deltap1 = (omegaplus + omegaminus)/calq
delta = deltap1 - 1.0d0
twoxm1 = (omegaplus - omegaminus)/calq
x1mx = (1.0d0 - twoxm1**2)/4.0d0
qbarsq = calqsq * delta * (delta + 2.0d0)
DO mu = 1,3
  ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu)
END DO
elltsq = qbarsq*x1mx
denom = qbarsq/calqsq + 4.0d0*x1mx
onem2x1mx = 1.0d0 - 2.0d0*x1mx
onem4x1mx = 1.0d0 - 4.0d0*x1mx
!
! The gluon propagator in Coulomb gauge for an on-shell gluon
! with three-momentum Q(mu). This is the space components only.
!
DO mu = 1,3
  bareprop(mu,mu) = 1.0d0 - q(mu)**2/calqsq
DO nu = mu+1,3
  temp = - q(mu)*q(nu)/calqsq
  bareprop(mu,nu) = temp
  bareprop(nu,mu) = temp
END DO
END DO
!
IF (cut2pt(1).AND.cut2pt(2)) THEN
!
! We have the contribution from a cut self-energy diagram.
! We compute the coefficients for, alternatively, the gluon loop
! or the quark loop. We use the name NLL for Ntt and NEL for NEt.
!
IF (kind2pt.EQ.'gluonloop') THEN
!
ntt = x1mx
ntt = ntt + 8.0d0*x1mx*(1.0d0 - x1mx)/denom
ntt = ntt + 16.0d0*x1mx*(onem4x1mx + 2.0d0*x1mx**2)/denom**2
ntt = ntt * 2.0d0 * nc
nll = x1mx
nll = nll - 8.0d0*x1mx**2/denom
nll = nll + 32.0d0*x1mx**3/denom**2
nll = nll * 4.0d0 * nc
nee = onem4x1mx
nee = nee - 8.0d0*x1mx*onem4x1mx/denom
nee = nee + 32.0d0*x1mx**2*onem4x1mx/denom**2
nee = nee * nc
nel = -1.0d0
nel = nel - 2.0d0*onem4x1mx/denom
nel = nel + 16.0d0*x1mx*onem2x1mx/denom**2
nel = nel * 2.0d0 * nc * twoxm1
!
ELSE IF (kind2pt.EQ.'quarkloop') THEN
!
ntt = nf*onem2x1mx
nll = - 4.0d0*nf*x1mx
nee = 4.0d0*nf*x1mx
nel = 2.0d0*nf*twoxm1
!
ELSE IF (kind2pt.EQ.'bothloops') THEN
!
ntt = x1mx
ntt = ntt + 8.0d0*x1mx*(1.0d0 - x1mx)/denom
ntt = ntt + 16.0d0*x1mx*(onem4x1mx + 2.0d0*x1mx**2)/denom**2
ntt = ntt * 2.0d0 * nc
nll = x1mx
nll = nll - 8.0d0*x1mx**2/denom
nll = nll + 32.0d0*x1mx**3/denom**2
nll = nll * 4.0d0 * nc
nee = onem4x1mx
nee = nee - 8.0d0*x1mx*onem4x1mx/denom
nee = nee + 32.0d0*x1mx**2*onem4x1mx/denom**2
nee = nee * nc
nel = -1.0d0
nel = nel - 2.0d0*onem4x1mx/denom
nel = nel + 16.0d0*x1mx*onem2x1mx/denom**2
nel = nel * 2.0d0 * nc * twoxm1
!
ntt = ntt + nf*onem2x1mx
nll = nll - 4.0d0*nf*x1mx
nee = nee + 4.0d0*nf*x1mx
nel = nel + 2.0d0*nf*twoxm1
!
ELSE
  write(nout,*)'Unrecognized type in subroutine twopointg.'
  stop
END IF
!
! With the coefficients in hand, we compute the result.
!
prefactor = 1.0d0/(4.0d0*omegaplus*omegaminus*qbarsq)
!
out(0,0) = prefactor*qbarsq/calqsq*nee
DO mu = 1,3
  temp = prefactor*q0/deltap1/calqsq*nel*ellt(mu)
  out(0,mu) = temp
  out(mu,0) = temp
END DO
DO mu = 1,3
DO nu = 1,3
  termtt = ntt*bareprop(mu,nu)
  termll = nll*(ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu))
  out(mu,nu) = prefactor*(termtt + termll)
END DO
END DO
!
! Alternative for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....
!
ELSE IF (cut2pt(0).OR.cut2pt(3)) THEN
!
! We have the contribution from a virtual self-energy diagram
! with one of the neighboring propagators cut.
! We compute the coefficients for, alternatively, the gluon loop
! or the quark loop.
!
IF (kind2pt.EQ.'gluonloop') THEN
!
  temp = mumsbar**2*exp(2.0d0)
  at0 = - 2.0d0*nc*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(5.0d0/3.0d0)
  at0 = at0 + 2.0d0*nc*x1mx*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(8.0d0/3.0d0)
  at0 = at0 + 4.0d0*nc*x1mx*temp/(qbarsq + temp)
  at1 = 24.0d0*nc*x1mx*onem2x1mx
  at2 = 32.0d0*nc*x1mx*(onem4x1mx + 4.0d0*x1mx**2)
  ntt0 = 4.0d0*nc*x1mx
  ntt1 = - 32.0d0*nc*x1mx**2
  ntt2 = 128.0d0*nc*x1mx**3
  net0 = - 2.0d0*nc*twoxm1
  net1 = - 4.0d0*nc*twoxm1*onem4x1mx
  net2 = 32.0d0*nc*twoxm1*x1mx*onem2x1mx
!
  utt = at0 + at1/denom + at2/denom**2
  ntt = ntt0 + ntt1/denom + ntt2/denom**2
  net = net0 + net1/denom + net2/denom**2
!
ELSE IF (kind2pt.EQ.'quarkloop') THEN
!
! Here AT1 = AT2 = NTT1 = NTT2 = NET1 = NET2 = 0.
!
  temp = mumsbar**2*exp(2.0d0)
  at0 = nf*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(8.0d0/3.0d0)
  at0 = at0 - 2.0d0*nf*x1mx*temp/(qbarsq + temp)
  at1 = 0.0d0
  at2 = 0.0d0
  ntt0 = - 4.0d0*nf*x1mx
  net0 = 2.0d0*nf*twoxm1
!
  utt = at0
  ntt = ntt0
  net = net0
!
ELSE IF (kind2pt.EQ.'bothloops') THEN
!
  temp = mumsbar**2*exp(2.0d0)
  at0 = - 2.0d0*nc*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(5.0d0/3.0d0)
  at0 = at0 + 2.0d0*nc*x1mx*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(8.0d0/3.0d0)
  at0 = at0 + 4.0d0*nc*x1mx*temp/(qbarsq + temp)
  at1 = 24.0d0*nc*x1mx*onem2x1mx
  at2 = 32.0d0*nc*x1mx*(onem4x1mx + 4.0d0*x1mx**2)
  ntt0 = 4.0d0*nc*x1mx
  ntt1 = - 32.0d0*nc*x1mx**2
  ntt2 = 128.0d0*nc*x1mx**3
  net0 = - 2.0d0*nc*twoxm1
  net1 = - 4.0d0*nc*twoxm1*onem4x1mx
  net2 = 32.0d0*nc*twoxm1*x1mx*onem2x1mx
!
  utt = at0 + at1/denom + at2/denom**2
  ntt = ntt0 + ntt1/denom + ntt2/denom**2
  net = net0 + net1/denom + net2/denom**2
!
  temp = mumsbar**2*exp(2.0d0)
  at0 = nf*temp/(qbarsq + temp)
  temp = mumsbar**2*exp(8.0d0/3.0d0)
  at0 = at0 - 2.0d0*nf*x1mx*temp/(qbarsq + temp)
  at1 = 0.0d0
  at2 = 0.0d0
  ntt0 = - 4.0d0*nf*x1mx
  net0 = 2.0d0*nf*twoxm1
!
  utt = utt + at0
  ntt = ntt + ntt0
  net = net + net0
!
ELSE
  write(nout,*)'Unrecognized type in subroutine twopointg.'
  stop
END IF
!
! With the coefficients in hand, we compute the result. There is
! an extra factor 1 + \Delta  compared to the real self-energy
! graphs because {\cal W} lacks the factor 1/(1 + \Delta) that
! appears in {\cal M}.
!
! Also, we divide by 2 because we will get this contribution
! twice, once when one adjacent propagator is cut and onece
! when the other adjacent propagator is cut.
!
prefactor = - deltap1/(4.0d0*omegaplus*omegaminus*qbarsq)
prefactor = 0.5d0*prefactor
!
out(0,0) = 0.0d0
DO mu = 1,3
   temp = prefactor*q0/deltap1/calqsq/(1 + qbarsq/calqsq)
   temp = temp*net*ellt(mu)
   out(0,mu) = temp
   out(mu,0) = temp
END DO
DO mu = 1,3
DO nu = 1,3
  termtt = utt*bareprop(mu,nu)
  temp = ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu)
  termll = ntt/(1 + qbarsq/calqsq)*temp
  out(mu,nu) = prefactor*(termtt + termll)
END DO
END DO
!
! Closing for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....ELSE IF ...
!
ELSE
  write(nout,*)'For a gluon two point function,'
  write(nout,*)'either the self-energy graph must be cut'
  write(nout,*)'or one of the neighboring propagators'
  write(nout,*)'must be cut.'
  stop
END IF
!
RETURN
END subroutine twopointg
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine twopointq(k2pt,cut2pt,mumsbar,flag,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: k2pt(0:2,0:3)
logical :: cut2pt(0:3)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: out(0:3)
!
! Calculates the one loop quark two-point function, including the
! adjoining propagators.
!
! k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part)
! k2pt(1,mu): 1st momentum in loop (kplus for the space part)
! k2pt(2,mu): 2nd momentum in loop (kminus for the space part)
!
! cut2pt(0): whether incoming line is cut
! cut2pt(1): whether 1st internal line is cut
! cut2pt(2): whether 2nd internal line is cut
! cut2pt(3): whether outgoing line is cut
!
! mumsbar is the MSbar renormalization scale.
!
! The two  point function, with a certain normalization, 
! is represented as out^mu gamma_mu. 
! For the real quark self-energy graphs, out^{\mu} gamma_{\mu} 
! is {\cal M}_q divided by 
! (\alpha_s/(4\pi)) * 1/(1+\Delta) 
! and divided by 
! 4 * \omega_+ * \omega_- * \bar q^2. 
! The factor by which we divide consists of
! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
!   one (2\pi)^{-3} for each loop that is factored out of each
!   graph in our program.
! * (d\vec l)/(d\bar q^2 dx d\phi)
!    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
! * 4 \pi {\cal Q} \bar q^2 included in the relation between
!   {\cal I}[real] and {\cal M}_q.
!
! In the case of the virtual quark self-energy graphs with
! one of the adjacent propagators cut, OUT^{\mu} gamma_{\mu} 
! is {\cal W}_q divided by the same factors.
!
! In the case of the virtual quark self-energy graphs with
! the adjacent propagators *not* cut, OUT^{\mu} gamma_{\mu} 
! is W_q divided by 
! (\alpha_s/(4\pi)) * 1/(1+\Delta)
! and divided by 
! 2 * \omega_+ * \omega_- * (\bar q^2 - q^2) * q^2/{\cal Q}.
! The factor by which we divide consists of
! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
!   one (2\pi)^{-3} for each loop that is factored out of each
!   graph in our program.
! * (d\vec l)/(d\bar q^2 dx d\phi)
!    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
! * 2 \pi q^2 (\bar q^2 - q^2) included in the relation between
!   {\cal I}[all uncut] and W_q. 
!
! 2 January 2001
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
complex(kind=dbl) :: complexsqrt
integer :: mu
complex(kind=dbl) :: kplus(1:3),kminus(1:3),ell(1:3),q(1:3)
complex(kind=dbl) :: calqsq,omegaplussq,omegaminussq
complex(kind=dbl) :: calq,omegaplus,omegaminus
complex(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq
complex(kind=dbl) :: ellt(1:3)
complex(kind=dbl) :: elltsq,denom,onem2x1mx,onem4x1mx,x
complex(kind=dbl) :: temp,tempsq
complex(kind=dbl) :: nl,ne,nt,prefactor
complex(kind=dbl) :: bl0,bl1,bl2
complex(kind=dbl) :: nl0,nl1,nl2
complex(kind=dbl) :: nt0,nt1,nt2
complex(kind=dbl) :: ul,vl,vt
complex(kind=dbl) :: q0,qsq
complex(kind=dbl) :: be0,be1,be2
complex(kind=dbl) :: ue
! 
! Some auxilliary variables, including
! CALQ = {\cal Q}
! OMEGAPLUS = \omega_+
! OMEGAMINUS = \omega_-
! DELTAP1 = \Delta + 1
! TWOXM1 = 2 x - 1
! X1MX = x (1-x)
! ELLT(mu) = l_T^\mu
! ELLTSQ = (\vec l_T)^2
! Q(mu) = the incoming *three*-momentum
! Q0 = the incoming energy
!
DO mu = 1,3
  kplus(mu) = k2pt(1,mu)
  kminus(mu) = k2pt(2,mu)
  ell(mu) = (kplus(mu) - kminus(mu))/2.0d0
  q(mu) = k2pt(0,mu)
END DO
q0 = k2pt(0,0)
calqsq = 0.0d0
omegaplussq = 0.0d0
omegaminussq = 0.0d0
DO mu = 1,3
  calqsq = calqsq + q(mu)**2
  omegaplussq = omegaplussq + kplus(mu)**2
  omegaminussq = omegaminussq + kminus(mu)**2
END DO
calq = complexsqrt(calqsq)
omegaplus  = complexsqrt(omegaplussq)
omegaminus = complexsqrt(omegaminussq)
deltap1 = (omegaplus + omegaminus)/calq
delta = deltap1 - 1.0d0
twoxm1 = (omegaplus - omegaminus)/calq
x1mx = (1.0d0 - twoxm1**2)/4.0d0
qbarsq = calqsq * delta * (delta + 2.0d0)
DO mu = 1,3
  ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu)
END DO
elltsq = qbarsq*x1mx
denom = qbarsq/calqsq + 4.0d0*x1mx
onem2x1mx = 1.0d0 - 2.0d0*x1mx
onem4x1mx = 1.0d0 - 4.0d0*x1mx
x = (twoxm1 + 1.0d0)/2.0d0
!
! Now we will go through these possible cut structures and
! calculate the terms contributing to out(mu).
!
IF ( cut2pt(1).AND.cut2pt(2) ) THEN
!
! First possibility for cut structure: a cut self-energy diagram.
! Here TEMP = 2 x + Delta.
!
temp = twoxm1 + deltap1
tempsq = temp**2
nl = 12.0d0*x1mx + twoxm1*temp
nl = nl - 16.0d0*x1mx*twoxm1/temp + 16.0d0*x1mx*onem2x1mx/tempsq
nl = cf*nl
ne = 2.0d0*cf*(1.0d0 - x)*(4.0d0*x**2 + delta**2)/tempsq
nt = 1.0d0 - 2.0d0*twoxm1/temp - 8.0d0*x1mx/tempsq
nt = 2.0d0*cf*nt
!
prefactor = 1.0d0/(4.0d0*omegaplus*omegaminus*qbarsq)
out(0) = prefactor*q0/deltap1*(nl + delta*ne)
DO mu = 1,3
  out(mu) = prefactor*(nl*q(mu) + nt*ellt(mu))
END DO
!
ELSE IF ( cut2pt(0).OR.cut2pt(3) ) THEN
!
! Second possibility for cut structure: a virtual self-energy
! with an adjacent propagator cut.
!
temp = mumsbar**2 * exp(3.0d0)
bl0 = - temp/(qbarsq + temp) 
temp = mumsbar**2 * exp(5.0d0/3.0d0)
bl0 = bl0 + 12.0d0*x1mx*temp/(qbarsq + temp)
bl0 = cf*bl0
bl1 = 8.0d0*cf*x1mx*(5.0d0 - 14.0d0*x1mx)
bl2 = 32.0d0*cf*x1mx*(1.0d0 - 6.0d0*x1mx + 8.0d0*x1mx**2)
nl0 = cf*twoxm1
nl1 = - 16.0d0*cf*twoxm1*x1mx
nl2 = - 32.0d0*cf*twoxm1*x1mx*onem2x1mx
nt0 = 2.0d0*cf
nt1 = - 4.0d0*cf*twoxm1
nt2 = - 16.0d0*cf*x1mx
ul = bl0 + bl1/denom + bl2/denom**2
vl = nl0 + nl1/denom + nl2/denom**2
temp = delta + 2.0d0*x
vt = nt0 + nt1/temp + nt2/temp**2
!
! We divide by 2 because we will get this contribution
! twice, once when one adjacent propagator is cut and once
! when the other adjacent propagator is cut.
!
prefactor = deltap1/(4.0d0*omegaplus*omegaminus*qbarsq)
prefactor = 0.5d0*prefactor
!
temp = ul + vl/(1.0d0 + qbarsq/calqsq)
out(0) = - prefactor*q0*temp
DO mu = 1,3
  out(mu) = - prefactor*(temp*q(mu)  &
            + vt*ellt(mu)/(1.0d0 + qbarsq/calqsq))
END DO
! 
ELSE
!
! Third possibility for cut structure: a virtual self-energy
! with *no* adjacent propagator cut.
!
qsq = q0**2 - calqsq
!
temp = mumsbar**2 * exp(3.0d0)
bl0 = - (qsq + temp)/(qbarsq + temp) 
temp = mumsbar**2 * exp(5.0d0/3.0d0)
bl0 = bl0 + 12.0d0*x1mx*(qsq + temp)/(qbarsq + temp)
bl0 = cf*bl0
bl1 = 20.0d0*x1mx - 56.0d0*x1mx**2 + qsq/calqsq*onem2x1mx
bl1 = 2.0d0*cf*bl1
bl2 = 32.0d0*cf*x1mx*(1.0d0 - 6.0d0*x1mx + 8.0d0*x1mx**2)
be0 = 0.0d0
be1 = -8.0d0*cf*x1mx
be2 = -16.0d0*cf*x1mx*onem4x1mx
ul = bl0 + bl1/denom + bl2/denom**2
ue = be0 + be1/denom + be2/denom**2
!
prefactor = 2.0d0*omegaplus*omegaminus*qsq*(qbarsq - qsq)
prefactor = deltap1*calq/prefactor
out(0) = - prefactor*q0*(ul + qsq/calqsq*ue)
DO mu = 1,3
  out(mu) = - prefactor*q(mu)*ul
END DO
!
! Completion of IF ... block for cut structure.
!
END IF
!
RETURN
END subroutine twopointq
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,hv,ha)
!
use beowulf_helpers
implicit none
! In:
character(len=7) :: kind3pt
complex(kind=dbl) :: k3pt(3,0:3)
logical :: cut3pt(3)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: hv(0:3,0:3),ha(0:3,0:3)
!
! The unintegrated quark-antiquark-gluon three point function
! for the graph with flavors labelled by KIND3PT. 
!
! KIND3PT has the form abc/def where a,...,f are chosen from 
! Q,G,P. Here Q denotes "quark" or "antiquark", G denotes "gluon",
! and P denotes "photon". The external lines have flavors a,b,c
! and the internal lines have flavors d,e,f. The possibilities
! are QQG/QQG, QQG/GGQ, and QQP/QQG. There is also QQG/ALL, which
! gives the sum of the results for QQG/QQG and QQG/GGQ.
!
! The unintegrated three-point function \Gamma^\mu can be decomposed
! into a function HV^\mu_\nu \gamma^\mu plus a function 
! HA^\mu_\nu I \gamma^\mu \gamma_5 (all times a t^a color matrix or a
! unit color matrix in the case of a QQP vertex). This subroutine
! calculates the functions HV^{\mu\nu} and HA^{\mu\nu}.  The arguments
! are the momenta k3pt(1,mu), k3pt(2,mu), k3pt(3,mu), of the propagators
! around the loop. 
!
! The variable cut3pt(j) is .true. if line j is cut, .false. otherwise.
! If the line is cut, the corresponding energy is set by the calling
! programs to be k0 = + |\vec k| or else k0 = - |\vec k|. (Here
! |\vec k| is a shorthand for sqrt(\vec k^2), not the square root of 
! \vec k dotted into its complex conjugate.) This subroutine supplies a
! factor k(j)^2 for uncut propagators and 2 sqrt(\vec k^2) for a cut
! propagator.  For a virtual loop, subroutine vertex will be called six
! times, once with each of the three propagators cut and k0 = + |\vec k|
! and once with each of the three propagators cut and k0 = - |\vec k|.
! Then it will be called with no propagator cut, which implies that it
! should supply the renormalization counter term.
!
! 31 December 2001
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
complex(kind=dbl) :: complexsqrt
!
complex(kind=dbl), parameter :: nvec(0:3) = &
         (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) 
real(kind=dbl), parameter :: g(0:3,0:3) =  reshape(  &
       (/1.0d0, 0.0d0, 0.0d0, 0.0d0, &
         0.0d0,-1.0d0, 0.0d0, 0.0d0, &
         0.0d0, 0.0d0,-1.0d0, 0.0d0, &
         0.0d0, 0.0d0, 0.0d0,-1.0d0/)&
      ,(/4,4/))
!
complex(kind=dbl) :: tk11,tk22,tk33,tk12,tk23,tk13
complex(kind=dbl) :: k11,k22,k33,k12,k23,k13
complex(kind=dbl) :: e1,e2,e3
complex(kind=dbl) :: c1,c2,c3,c4,c5,c6,c7,c8,c9
complex(kind=dbl) :: c10,c11,c12,c13,c14,c15,c16,c17
complex(kind=dbl) :: temp,prefactor
integer :: mu,nu
complex(kind=dbl) :: k1(0:3),k2(0:3),k3(0:3)
complex(kind=dbl) :: epsn1(0:3,0:3),epsn2(0:3,0:3),epsn3(0:3,0:3)
complex(kind=dbl) :: eps12(0:3,0:3),eps13(0:3,0:3),eps23(0:3,0:3)
complex(kind=dbl) :: epsn12(0:3),epsn13(0:3),epsn23(0:3),eps123(0:3)
complex(kind=dbl) :: tl(0:3),omegasq,omega,cr1,cr2,cr3
integer :: ncut,p
!
!-----
!
ncut = 0
DO p=1,3
   IF (cut3pt(p)) THEN
     ncut = ncut + 1
   END IF
END DO
!
IF ((ncut.GT.1).OR.(flag.NE.'renormalize 3 pt')) THEN
!
! If NCUT = 1, we have a virtual loop. In this case, one of the
! possibilities is the renormalization counter term, for which
! FLAG would have been set to 'renormalize 3 pt'. Thus we get
! here is we do *not* have the the renormalization counter term.
! (Note that we could have NCUT = 2 but FLAG = 'renormalize 3 pt'
! in the case that there are two three point functions and ours
! is cut but the other one is virtual and needs to be renormalized.)
!
! First, dot products and energies. The dot products between vectors
! omitting their mu = 0 parts (\tilde vector) are denoted TKij.
!
tk11 = (0.0d0,0.0d0)
tk22 = (0.0d0,0.0d0)
tk33 = (0.0d0,0.0d0)
tk12 = (0.0d0,0.0d0)
tk23 = (0.0d0,0.0d0)
tk13 = (0.0d0,0.0d0)
DO mu = 1,3
  tk11 = tk11 - k3pt(1,mu)*k3pt(1,mu)
  tk22 = tk22 - k3pt(2,mu)*k3pt(2,mu)
  tk33 = tk33 - k3pt(3,mu)*k3pt(3,mu)
  tk12 = tk12 - k3pt(1,mu)*k3pt(2,mu)
  tk23 = tk23 - k3pt(2,mu)*k3pt(3,mu)
  tk13 = tk13 - k3pt(1,mu)*k3pt(3,mu)
END DO
e1 = k3pt(1,0)
e2 = k3pt(2,0)
e3 = k3pt(3,0)
k11 = e1*e1 + tk11
k22 = e2*e2 + tk22
k33 = e3*e3 + tk33
k12 = e1*e2 + tk12
k23 = e2*e3 + tk23
k13 = e1*e3 + tk13
!
! We need the factor equal to 1/k^2 for an uncut propagator
! and 1/ 2|E| for a cut propagator.
!
prefactor = (1.0d0,0.0d0)
IF (.NOT.cut3pt(1)) THEN
  prefactor = prefactor/k11
ELSE
  prefactor = prefactor/(2.0d0*complexsqrt(-tk11))
END IF
IF (.NOT.cut3pt(2)) THEN
  prefactor = prefactor/k22
ELSE
  prefactor = prefactor/(2.0d0*complexsqrt(-tk22))
END IF
IF (.NOT.cut3pt(3)) THEN
  prefactor = prefactor/k33
ELSE
  prefactor = prefactor/(2.0d0*complexsqrt(-tk33))
END IF
!
!------------------------
! First, we calculate hv.
!------------------------
! Generate the coefficients for the hv, depending on KIND3PT.
!
IF (kind3pt.EQ.'qqg/qqg') THEN
!
c1 = -(k12*(-2*e3**2 + k33 - 2*tk33))/(2.0d0*nc*tk33)
c2 = 0.0d0
c3 = 0.0d0
c4 = 0.0d0
c5 = -((e3*k12)/(nc*tk33))
c6 = (e3*k23)/(nc*tk33)
c7 = (e3*k13)/(nc*tk33)
c8 = -((e3*k12)/(nc*tk33))
c9 = 0.0d0
c10 = (-2*e3**2 + k33 - 2*tk33)/(2.0d0*nc*tk33)
c11 = -((-(e2*e3) + k23)/(nc*tk33))
c12 = (-2*e3**2 + k33 - 2*tk33)/(2.0d0*nc*tk33)
c13 = 0.0d0
c14 = -((-(e1*e3) + k13)/(nc*tk33))
c15 = 0.0d0
c16 = 0.0d0
c17 = k12/(nc*tk33)
!
ELSE IF (kind3pt.EQ.'qqg/ggq') THEN
!
c1 = -(nc*((-(e2**2*k23) + (-2*k12 + k22)*k23 + e2*(e3*(2*k12 &
 - k22) + 2*e1*k23))*tk11 + (e1*e3*(-k11 + 2*k12) - e1**2*k13 &
 + 2*e1*e2*k13 + (k11 - 2*k12)*k13 + (k13 &
 + k23)*tk11)*tk22))/(2.0d0*tk11*tk22)
c2 = -(e1*e2*(2*k12*k13 - k13*k22 - k11*k23 &
 + 2*k12*k23)*nc)/(2.0d0*tk11*tk22)
c3 = -(nc*(e1**2*e2*k23 + e2*k23*(k11 - 2*k12 - tk11) + e1*(e2 &
*(2*e3*k12 - e3*k22) + k23*(e2**2 - 2*k12 + k22 - tk22) &
 + 4*k13*tk22)))/(2.0d0*tk11*tk22)
c4 = (nc*(-(e1*e2**2*k13) + e2*(e1*(e3*k11 - 2*e3*k12) &
 - 4*k23*tk11 + k13*(-e1**2 - k11 + 2*k12 + tk11)) + e1*k13*(2*k12 &
 - k22 + tk22)))/(2.0d0*tk11*tk22)
c5 = (nc*(e1*e2**2*(-k11 + 3*k12) + e2*(-2*k12**2 + e1**2*(3*k12 &
 - k22) + k22*tk11 + k12*(k11 + tk11)) + e1*(-2*k12**2 + k11*tk22 &
 + k12*(k22 + tk22))))/(2.0d0*tk11*tk22)
c6 = (nc*(e1*e2**2*(k13 + k23) + e2*(k12*k13 - k13*k22 + e1 &
*(-2*e3*k12 + 2*e3*k22) - e1**2*k23 + 2*k23*tk11) + e1*k23*(k12 &
 - k22 + tk22)))/(2.0d0*tk11*tk22)
c7 = (nc*(-(e1*e2**2*k13) + e2*(e1*(2*e3*k11 - 2*e3*k12) + e1**2 &
*(k13 + k23) + k13*(-k11 + k12 + tk11)) + e1*((-k11 + k12)*k23 &
 + 2*k13*tk22)))/(2.0d0*tk11*tk22)
c8 = (nc*(-2*e2*k12*tk11 + e2*k22*tk11 + e1*k11*tk22 &
 - 2*e1*k12*tk22))/(2.0d0*tk11*tk22)
c9 = (nc*(e1*e2**2*e3 + e2*e3*k12 - e2*e3*k22 + e1*e2*k23 &
 - e2**2*k23 - k12*k23 + k22*k23 + 2*k13*tk22 &
 - k23*tk22))/(2.0d0*tk11*tk22)
c10 = -(nc*(-(e1*e2*k13) + e2**2*k13 + 2*k23*tk11 + e3*(e1**2*e2 &
 - 2*e2*tk11 + e1*(-e2**2 - k12 + k22 - tk22)) + k13*(k12 - k22 &
 + tk22)))/(2.0d0*tk11*tk22)
c11 = (nc*(-(e1*e2**3) + k12**2 + e2**2*(k12 - 2*tk11) + k22*tk11 &
 + k12*(-k22 - tk22) - e1**2*tk22 - tk11*tk22 + e1*e2*(-2*k12 &
 + k22 + tk22)))/(2.0d0*tk11*tk22)
c12 = -(nc*(e1**2*k23 - e1*e2*k23 + k23*(-k11 + k12 + tk11) &
 + 2*k13*tk22 + e3*(e1*e2**2 + e2*(-e1**2 + k11 - k12 - tk11) &
 - 2*e1*tk22)))/(2.0d0*tk11*tk22)
c13 = (nc*(e1**2*e2*e3 - e1*e3*k11 + e1*e3*k12 - e1**2*k13 &
 + e1*e2*k13 + k11*k13 - k12*k13 - k13*tk11 &
 + 2*k23*tk11))/(2.0d0*tk11*tk22)
c14 = -(nc*(e1**3*e2 - k12**2 + e1*e2*(-k11 + 2*k12 - tk11) &
 + e2**2*tk11 + k12*(k11 + tk11) - k11*tk22 + tk11*tk22 + e1**2 &
*(-k12 + 2*tk22)))/(2.0d0*tk11*tk22)
c15 = -(nc*(-e1**2 + 2*e1*e2 + k11 - 2*k12 + tk11))/(2.0d0*tk11)
c16 = (nc*(-2*e1*e2 + e2**2 + 2*k12 - k22 - tk22))/(2.0d0*tk22)
c17 = 0.0d0
!
ELSE IF (kind3pt.EQ.'qqg/all') THEN
!
c1 = -(nc*((-(e2**2*k23) + (-2*k12 + k22)*k23 + e2*(e3*(2*k12 &
 - k22) + 2*e1*k23))*tk11 + (e1*e3*(-k11 + 2*k12) - e1**2*k13 &
 + 2*e1*e2*k13 + (k11 - 2*k12)*k13 + (k13 &
 + k23)*tk11)*tk22))/(2.0d0*tk11*tk22)
c2 = -(e1*e2*(2*k12*k13 - k13*k22 - k11*k23 &
 + 2*k12*k23)*nc)/(2.0d0*tk11*tk22)
c3 = -(nc*(e1**2*e2*k23 + e2*k23*(k11 - 2*k12 - tk11) + e1*(e2 &
*(2*e3*k12 - e3*k22) + k23*(e2**2 - 2*k12 + k22 - tk22) &
 + 4*k13*tk22)))/(2.0d0*tk11*tk22)
c4 = (nc*(-(e1*e2**2*k13) + e2*(e1*(e3*k11 - 2*e3*k12) &
 - 4*k23*tk11 + k13*(-e1**2 - k11 + 2*k12 + tk11)) + e1*k13*(2*k12 &
 - k22 + tk22)))/(2.0d0*tk11*tk22)
c5 = (nc*(e1*e2**2*(-k11 + 3*k12) + e2*(-2*k12**2 + e1**2*(3*k12 &
 - k22) + k22*tk11 + k12*(k11 + tk11)) + e1*(-2*k12**2 + k11*tk22 &
 + k12*(k22 + tk22))))/(2.0d0*tk11*tk22)
c6 = (nc*(e1*e2**2*(k13 + k23) + e2*(k12*k13 - k13*k22 + e1 &
*(-2*e3*k12 + 2*e3*k22) - e1**2*k23 + 2*k23*tk11) + e1*k23*(k12 &
 - k22 + tk22)))/(2.0d0*tk11*tk22)
c7 = (nc*(-(e1*e2**2*k13) + e2*(e1*(2*e3*k11 - 2*e3*k12) + e1**2 &
*(k13 + k23) + k13*(-k11 + k12 + tk11)) + e1*((-k11 + k12)*k23 &
 + 2*k13*tk22)))/(2.0d0*tk11*tk22)
c8 = (nc*(-2*e2*k12*tk11 + e2*k22*tk11 + e1*k11*tk22 &
 - 2*e1*k12*tk22))/(2.0d0*tk11*tk22)
c9 = (nc*(e1*e2**2*e3 + e2*e3*k12 - e2*e3*k22 + e1*e2*k23 &
 - e2**2*k23 - k12*k23 + k22*k23 + 2*k13*tk22 &
 - k23*tk22))/(2.0d0*tk11*tk22)
c10 = -(nc*(-(e1*e2*k13) + e2**2*k13 + 2*k23*tk11 + e3*(e1**2*e2 &
 - 2*e2*tk11 + e1*(-e2**2 - k12 + k22 - tk22)) + k13*(k12 - k22 &
 + tk22)))/(2.0d0*tk11*tk22)
c11 = (nc*(-(e1*e2**3) + k12**2 + e2**2*(k12 - 2*tk11) + k22*tk11 &
 + k12*(-k22 - tk22) - e1**2*tk22 - tk11*tk22 + e1*e2*(-2*k12 &
 + k22 + tk22)))/(2.0d0*tk11*tk22)
c12 = -(nc*(e1**2*k23 - e1*e2*k23 + k23*(-k11 + k12 + tk11) &
 + 2*k13*tk22 + e3*(e1*e2**2 + e2*(-e1**2 + k11 - k12 - tk11) &
 - 2*e1*tk22)))/(2.0d0*tk11*tk22)
c13 = (nc*(e1**2*e2*e3 - e1*e3*k11 + e1*e3*k12 - e1**2*k13 &
 + e1*e2*k13 + k11*k13 - k12*k13 - k13*tk11 &
 + 2*k23*tk11))/(2.0d0*tk11*tk22)
c14 = -(nc*(e1**3*e2 - k12**2 + e1*e2*(-k11 + 2*k12 - tk11) &
 + e2**2*tk11 + k12*(k11 + tk11) - k11*tk22 + tk11*tk22 + e1**2 &
*(-k12 + 2*tk22)))/(2.0d0*tk11*tk22)
c15 = -(nc*(-e1**2 + 2*e1*e2 + k11 - 2*k12 + tk11))/(2.0d0*tk11)
c16 = (nc*(-2*e1*e2 + e2**2 + 2*k12 - k22 - tk22))/(2.0d0*tk22)
c17 = 0.0d0
!
c1 = c1 - (k12*(-2*e3**2 + k33 - 2*tk33))/(2.0d0*nc*tk33)
c5 = c5 - ((e3*k12)/(nc*tk33))
c6 = c6 + (e3*k23)/(nc*tk33)
c7 = c7 + (e3*k13)/(nc*tk33)
c8 = c8 - ((e3*k12)/(nc*tk33))
c10 = c10 + (-2*e3**2 + k33 - 2*tk33)/(2.0d0*nc*tk33)
c11 = c11 - ((-(e2*e3) + k23)/(nc*tk33))
c12 = c12 + (-2*e3**2 + k33 - 2*tk33)/(2.0d0*nc*tk33)
c14 = c14 - ((-(e1*e3) + k13)/(nc*tk33))
c17 = c17 + k12/(nc*tk33)
!
ELSE IF (kind3pt.EQ.'qqp/qqg') THEN
!
c1 = (cf*k12*(-2*e3**2 + k33 - 2*tk33))/tk33
c2 = 0.0d0
c3 = 0.0d0
c4 = 0.0d0
c5 = (2*cf*e3*k12)/tk33
c6 = (-2*cf*e3*k23)/tk33
c7 = (-2*cf*e3*k13)/tk33
c8 = (2*cf*e3*k12)/tk33
c9 = 0.0d0
c10 = -((cf*(-2*e3**2 + k33 - 2*tk33))/tk33)
c11 = (2*cf*(-(e2*e3) + k23))/tk33
c12 = -((cf*(-2*e3**2 + k33 - 2*tk33))/tk33)
c13 = 0.0d0
c14 = (2*cf*(-(e1*e3) + k13))/tk33
c15 = 0.0d0
c16 = 0.0d0
c17 = (-2*cf*k12)/tk33
!
ELSE
  write(nout,*)'Wrong kind in subroutine vertex.'
  stop
END IF
!
! Now we have the coefficients, so we can calculate hv.
!
DO mu = 0,3
DO nu = 0,3
!
 temp  = c1*g(mu,nu) &
 + c2*nvec(mu)*nvec(nu) &
 + c3*nvec(mu)*k3pt(1,nu) &
 + c4*nvec(mu)*k3pt(2,nu) &
 + c5*nvec(mu)*k3pt(3,nu) &
 + c6*k3pt(1,mu)*nvec(nu) &
 + c7*k3pt(2,mu)*nvec(nu) &
 + c8*k3pt(3,mu)*nvec(nu) &
 + c9*k3pt(1,mu)*k3pt(1,nu) &
 + c10*k3pt(1,mu)*k3pt(2,nu) &
 + c11*k3pt(1,mu)*k3pt(3,nu) &
 + c12*k3pt(2,mu)*k3pt(1,nu) &
 + c13*k3pt(2,mu)*k3pt(2,nu) &
 + c14*k3pt(2,mu)*k3pt(3,nu) &
 + c15*k3pt(3,mu)*k3pt(1,nu) &
 + c16*k3pt(3,mu)*k3pt(2,nu) &
 + c17*k3pt(3,mu)*k3pt(3,nu)
!
 hv(mu,nu) = prefactor * temp
!
END DO
END DO
!
!------------------------
! Next, we calculate ha.
!------------------------
!
! We need certain vectors and tensors made by dotting vectors
! into the epsilon tensor.
!
DO mu = 0,3
  k1(mu) = k3pt(1,mu)
  k2(mu) = k3pt(2,mu)
  k3(mu) = k3pt(3,mu)
END DO
call epsilon1n(k1,epsn1)
call epsilon1n(k2,epsn2)
call epsilon1n(k3,epsn3)
call epsilon2(k1,k2,eps12)
call epsilon2(k1,k3,eps13)
call epsilon2(k2,k3,eps23)
call epsilon2n(k1,k2,epsn12)
call epsilon2n(k1,k3,epsn13)
call epsilon2n(k2,k3,epsn23)
call epsilon3(k1,k2,k3,eps123)
!
! Generate the coefficients for the hv, depending on KIND3PT.
!
IF (kind3pt.EQ.'qqg/qqg') THEN
!
c1 = (e3*k23)/(nc*tk33)
c2 = -((e3*k13)/(nc*tk33))
c3 = 0.0d0
c4 = -(-2*e3**2 + k33 + 2*tk33)/(2.0d0*nc*tk33)
c5 = (-(e2*e3) + k23)/(nc*tk33)
c6 = -((-(e1*e3) + k13)/(nc*tk33))
c7 = e3/(nc*tk33)
c8 = 0.0d0
c9 = 0.0d0
c10 = 0.0d0
c11 = 0.0d0
c12 = 0.0d0
c13 = 0.0d0
c14 = e3/(nc*tk33)
c15 = 0.0d0
c16 = 0.0d0
c17 = -(1/(nc*tk33))
!
ELSE IF (kind3pt.EQ.'qqg/ggq') THEN
!
c1 = 0.0d0
c2 = 0.0d0
c3 = (nc*(2*e2*k12*tk11 - e2*k22*tk11 + e1*k11*tk22 &
 - 2*e1*k12*tk22))/(2.0d0*tk11*tk22)
c4 = 0
c5 = -(nc*(-e1**2 + 2*e1*e2 + k11 - 2*k12 - 3*tk11))/(2.0d0*tk11)
c6 = -(nc*(-2*e1*e2 + e2**2 + 2*k12 - k22 + 3*tk22))/(2.0d0*tk22)
c7 = 0.0d0
c8 = (e1*e2*(2*k12 - k22)*nc)/(2.0d0*tk11*tk22)
c9 = -(nc*(e1*e2**2 + e2*k12 - e2*k22 &
 + 2*e1*tk22))/(2.0d0*tk11*tk22)
c10 = (e2*nc*(-e1**2 + e1*e2 + k11 - k12 &
 - tk11))/(2.0d0*tk11*tk22)
c11 = (e1*e2*(k11 - 2*k12)*nc)/(2.0d0*tk11*tk22)
c12 = -(e1*nc*(e1*e2 - e2**2 - k12 + k22 &
 - tk22))/(2.0d0*tk11*tk22)
c13 = -(nc*(-(e1**2*e2) + e1*k11 - e1*k12 &
 - 2*e2*tk11))/(2.0d0*tk11*tk22)
c14 = (nc*(-(e1**2*e2) - e1*e2**2 - e2*k11 + 2*e1*k12 + 2*e2*k12 &
 - e1*k22 + e2*tk11 + e1*tk22))/(2.0d0*tk11*tk22)
c15 = -(nc*(-(e1*e2) + e2**2 + k12 - k22 &
 + tk22))/(2.0d0*tk11*tk22)
c16 = (nc*(-e1**2 + e1*e2 + k11 - k12 - tk11))/(2.0d0*tk11*tk22)
c17 = 0.0d0
!
ELSE IF (kind3pt.EQ.'qqg/all') THEN
!
c1 = 0.0d0
c2 = 0.0d0
c3 = (nc*(2*e2*k12*tk11 - e2*k22*tk11 + e1*k11*tk22 &
 - 2*e1*k12*tk22))/(2.0d0*tk11*tk22)
c4 = 0
c5 = -(nc*(-e1**2 + 2*e1*e2 + k11 - 2*k12 - 3*tk11))/(2.0d0*tk11)
c6 = -(nc*(-2*e1*e2 + e2**2 + 2*k12 - k22 + 3*tk22))/(2.0d0*tk22)
c7 = 0.0d0
c8 = (e1*e2*(2*k12 - k22)*nc)/(2.0d0*tk11*tk22)
c9 = -(nc*(e1*e2**2 + e2*k12 - e2*k22 &
 + 2*e1*tk22))/(2.0d0*tk11*tk22)
c10 = (e2*nc*(-e1**2 + e1*e2 + k11 - k12 &
 - tk11))/(2.0d0*tk11*tk22)
c11 = (e1*e2*(k11 - 2*k12)*nc)/(2.0d0*tk11*tk22)
c12 = -(e1*nc*(e1*e2 - e2**2 - k12 + k22 &
 - tk22))/(2.0d0*tk11*tk22)
c13 = -(nc*(-(e1**2*e2) + e1*k11 - e1*k12 &
 - 2*e2*tk11))/(2.0d0*tk11*tk22)
c14 = (nc*(-(e1**2*e2) - e1*e2**2 - e2*k11 + 2*e1*k12 + 2*e2*k12 &
 - e1*k22 + e2*tk11 + e1*tk22))/(2.0d0*tk11*tk22)
c15 = -(nc*(-(e1*e2) + e2**2 + k12 - k22 &
 + tk22))/(2.0d0*tk11*tk22)
c16 = (nc*(-e1**2 + e1*e2 + k11 - k12 - tk11))/(2.0d0*tk11*tk22)
c17 = 0.0d0
!
c1 = c1 + (e3*k23)/(nc*tk33)
c2 = c2 - ((e3*k13)/(nc*tk33))
c4 = c4 - (-2*e3**2 + k33 + 2*tk33)/(2.0d0*nc*tk33)
c5 = c5 + (-(e2*e3) + k23)/(nc*tk33)
c6 = c6 - ((-(e1*e3) + k13)/(nc*tk33))
c7 = c7 + e3/(nc*tk33)
c14 = c14 + e3/(nc*tk33)
c17 = c17 - (1/(nc*tk33))
!
ELSE IF (kind3pt.EQ.'qqp/qqg') THEN
!
c1 = (-2*cf*e3*k23)/tk33
c2 = (2*cf*e3*k13)/tk33
c3 = 0.0d0
c4 = (cf*(-2*e3**2 + k33 + 2*tk33))/tk33
c5 = (-2*cf*(-(e2*e3) + k23))/tk33
c6 = (2*cf*(-(e1*e3) + k13))/tk33
c7 = (-2*cf*e3)/tk33
c8 = 0.0d0
c9 = 0.0d0
c10 = 0.0d0
c11 = 0.0d0
c12 = 0.0d0
c13 = 0.0d0
c14 = (-2*cf*e3)/tk33
c15 = 0.0d0
c16 = 0.0d0
c17 = (2*cf)/tk33
!
ELSE
  write(nout,*)'Wrong kind in subroutine vertex.'
  stop
END IF
!
! Now we have the coefficients, so we can calculate ha.
!
DO mu = 0,3
DO nu = 0,3
!
 temp = c1*epsn1(mu,nu) &
 + c2*epsn2(mu,nu) &
 + c3*epsn3(mu,nu) &
 + c4*eps12(mu,nu) &
 + c5*eps13(mu,nu) &
 + c6*eps23(mu,nu) &
 + c7*k3pt(3,mu)*epsn12(nu) &
 + c8*nvec(mu)*epsn13(nu) &
 + c9*k3pt(1,mu)*epsn13(nu) &
 + c10*k3pt(2,mu)*epsn13(nu) &
 + c11*nvec(mu)*epsn23(nu) &
 + c12*k3pt(1,mu)*epsn23(nu) &
 + c13*k3pt(2,mu)*epsn23(nu) &
 + c14*nvec(mu)*eps123(nu) &
 + c15*k3pt(1,mu)*eps123(nu) &
 + c16*k3pt(2,mu)*eps123(nu) &
 + c17*k3pt(3,mu)*eps123(nu)
!
 ha(mu,nu) = prefactor * temp
!
END DO
END DO
!
!-----------------------------
! Now, we have both hv and ha.
!-----------------------------
!
! Alternative for IF (FLAG.NE.'renormalize 3 pt') THEN
!
ELSE
!
! We need the renormalization counter term.
!
tl(0) = 0.0d0
omegasq = 0.0d0
DO mu = 1,3
  tl(mu) =(k3pt(1,mu) + k3pt(2,mu) + k3pt(3,mu))/3.0d0
  omegasq = omegasq + tl(mu)**2
END DO
omegasq = omegasq + mumsbar**2
omega = complexsqrt(omegasq)
!
! Generate the coefficients for the hv counter term, 
! depending on KIND3PT.
!
IF (kind3pt.EQ.'qqg/qqg') THEN
!
cr1 = - 1.0d0/(4.0d0*nc*omega**3)  &
      - 3.0d0*mumsbar**2/(16.0d0*nc*omega**5)
cr2 = - 3.0d0/(8.0d0*nc*omega**5)
cr3 = 1.0d0/(8.0d0*nc*omega**3)
!
ELSE IF (kind3pt.EQ.'qqg/ggq') THEN
!
cr1 = nc/(4.0d0*omega**3)  &
     + 3.0d0*nc*mumsbar**2/(16.0d0*omega**5)
cr2 = - 5.0d0*nc/(8.0d0*omega**5)
cr3 = - nc/(8.0d0*omega**3)
!
ELSE IF (kind3pt.EQ.'qqg/all') THEN
!
cr1 = nc/(4.0d0*omega**3)  &
     + 3.0d0*nc*mumsbar**2/(16.0d0*omega**5)
cr2 = - 5.0d0*nc/(8.0d0*omega**5)
cr3 = - nc/(8.0d0*omega**3)
!
cr1 = cr1 - 1.0d0/(4.0d0*nc*omega**3)  &
      - 3.0d0*mumsbar**2/(16.0d0*nc*omega**5)
cr2 = cr2 - 3.0d0/(8.0d0*nc*omega**5)
cr3 = cr3 + 1.0d0/(8.0d0*nc*omega**3)
!
ELSE IF (kind3pt.EQ.'qqp/qqg') THEN
!
cr1 =  cf/(2.0d0*omega**3)  &
      + 3.0d0*cf*mumsbar**2/(8.0d0*omega**5)
cr2 = 3.0d0*cf/(4.0d0*omega**5)
cr3 = - cf/(4.0d0*omega**3)
!
ELSE
  write(nout,*)'Wrong kind in subroutine vertex.'
  stop
END IF
!
! Now we have the coefficients, so we can calculate the hv counter term.
! The ha counter term is zero.
!
DO mu = 0,3
DO nu = 0,3
  hv(mu,nu) = - cr1*g(mu,nu) &
   - cr2*tl(mu)*tl(nu) &
   - cr3*nvec(mu)*nvec(nu)
  ha(mu,nu) = 0.0d0
END DO
END DO
RETURN
!
! End  IF (CUT3PT(1).OR.CUT3PT(2).OR.CUT3PT(3)) THEN ... ELSE ...
!
END IF
!
RETURN
END subroutine vertex
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890   !2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,vout)
!
use beowulf_helpers
implicit none
! In:
character(len=13) :: kind2pt2
complex(kind=dbl) :: k2pt2(0:5,0:3)
logical :: cut2pt2(1:5)
real(kind=dbl) :: mumsbar
character(len=16) :: flag
! Out:
complex(kind=dbl) :: vout(0:3)
!
! The two-loop contribution to the quark propagator. The function is 
! a dot product of a four-vector VOUT(mu) with gamma(mu), times a
! unit color matrix. This subroutine calculates VOUT(mu). (There is
! another contribution proportional to gamma(mu) gamma(5), but this
! contribution is not needed at our level of perturbation theory.) The
! contribution includes the self-energy diagram and the adjoining bare
! quark propagators. The calculation includes the denominator factors.
! Some of the internal propagators may be cut, as specified by cut2pt2,
! where cut2pt2(j) = .true. indicates that the corresponding line is 
! cut.
!
! The variable kind2pt2 tells what sort of graph we have.
!
! 1) There are graphs with two overlapping three point functions,
! incicated by kind2pt2 = OVERLAP/abcde where  a,...,e are chosen from 
! Q,G. Here Q denotes "quark" or "antiquark" while G denotes "gluon".
! These characters indicate the flavors on the internal lines. There
! are two possibilities: OVERLAP/QGGQQ and OVERLAP/QGQGG. (The first
! of these has all qqg vertices, while the second has two qqg vertices
! and one ggg vertex.) 
!
! 2) There are graphs with a one loop two point function nested inside
! the two loop two point function. These are indicated by
! kind2pt2 = NESTED /abcde, where, again,  a,...,e are chosen from 
! Q,G. There are three possibilities: 
!    NESTED /QGGGG gluon self-enegy with a gluon loop
!    NESTED /QGGQQ gluon self-enegy with a quark loop
!    NESTED /GQQGQ quark self-enegy
!
! Numbering for graphs of type OVERLAP:
! vrtx1 attaches to the incoming quark line
! vrtx2 attaches to the outgoing quark line
! vrtx3 is the internal vertex attached to a quark line from vrtx1
! vrtx4 is the other internal vertex
! k0(mu) is the momentum of the quark line entering vrtx1
! k1(mu) is the momentum of the internal line from vrtx1 to vrtx3
! k2(mu) is the momentum of the internal line from vrtx1 to vrtx4
! k3(mu) is the momentum of the internal line from vrtx3 to vrtx2
! k4(mu) is the momentum of the internal line from vrtx4 to vrtx2
! k5(mu) is the momentum of the internal line from vrtx3 to vrtx4
!
! Numbering for graphs of type NESTED:
! vrtx1 attaches to the incoming quark line
! vrtx2 attaches to the outgoing quark line
! vrtx3 is the internal vertex attached to a line from vrtx1
! vrtx4 is the other internal vertex
! k0(mu) is the momentum of the quark line entering vrtx1
! k1(mu) is the momentum of the internal line from vrtx1 to vrtx2
! k2(mu) is the momentum of the internal line from vrtx1 to vrtx3
! k3(mu) is the momentum of the internal line from vrtx4 to vrtx2
! k4(mu) ane k5(mu) are the momentum of the internal lines 
!        from vrtx3 to vrtx4. For a quark internal self-energy,
!        4 is the gluon and 5 is the quark line.
!
! The FLAG variable passed on to lower level subroutines.
!
! 31 December 2001
!
! For testing purposes only:
!     LOGICAL OVERRIDE,LEFTOVERRIDE
!     COMMON /TESTING/ OVERRIDE,LEFTOVERRIDE
! ---
!
complex(kind=dbl) :: complexsqrt
complex(kind=dbl) :: tk00,tk11,tk22,tk33,tk44
complex(kind=dbl) :: k00,k11,k22,k33,k44
complex(kind=dbl) :: temp,prefactor
complex(kind=dbl) :: k0(0:3),k1(0:3),k2(0:3),k3(0:3),k4(0:3),k5(0:3)
complex(kind=dbl) :: e0,e1,e2,e3,e4
logical :: cut(1:5)
complex(kind=dbl) :: x(9)
!
complex(kind=dbl) :: ea4ggnik0k1k2,ea4gk0k1,ea4gk2ignk0k1,ea4gk2ik0k1k2
complex(kind=dbl) :: ea4qgnik0k1k2,ea4qk0k1,ea4qk2ignk0k1,ea4qk2ik0k1k2
complex(kind=dbl) :: ea5ggnik0k3k4,ea5gk0k3,ea5gk4ignk0k3,ea5gk4ik0k3k4
complex(kind=dbl) :: ea5qgnik0k3k4,ea5qk0k4,ea5qk3ignk0k4,ea5qk3ik0k3k4
complex(kind=dbl) :: k0k1,k0k2,k0k3,k0k4,k1k2,k3k4,tracev4g,tracev4q
complex(kind=dbl) :: tracev5g,tracev5q,v4gwgnk0,v4gwgnk1,v4gwgnk2,v4gwk0k1
complex(kind=dbl) :: v4gwk1k0,v4gwk2gn,v4gwk2k0,v4gwk2k1,v4gwk2k2,v4qwgnk0
complex(kind=dbl) :: v4qwgnk1,v4qwgnk2,v4qwk0k1,v4qwk1k0,v4qwk2gn,v4qwk2k0
complex(kind=dbl) :: v4qwk2k1,v4qwk2k2,v5gwgnk0,v5gwgnk3,v5gwgnk4,v5gwk0k3
complex(kind=dbl) :: v5gwk3k0,v5gwk4gn,v5gwk4k0,v5gwk4k3,v5gwk4k4,v5qwgnk0
complex(kind=dbl) :: v5qwgnk3,v5qwgnk4,v5qwk0k4,v5qwk3gn,v5qwk3k0,v5qwk3k3
complex(kind=dbl) :: v5qwk3k4,v5qwk4k0,a4ggni(0:3),a4gk2i(0:3),a4qgni(0:3)
complex(kind=dbl) :: a4qk2i(0:3),a5ggni(0:3),a5gk4i(0:3),a5qgni(0:3)
complex(kind=dbl) :: a5qk3i(0:3),ea4ggnik1k2(0:3),ea4gk1(0:3)
complex(kind=dbl) :: ea4gk2ignk1(0:3),ea4gk2ik1k2(0:3),ea4qgnik1k2(0:3)
complex(kind=dbl) :: ea4qk1(0:3),ea4qk2ignk1(0:3),ea4qk2ik1k2(0:3)
complex(kind=dbl) :: ea5ggnik3k4(0:3),ea5gk3(0:3),ea5gk4ignk3(0:3)
complex(kind=dbl) :: ea5gk4ik3k4(0:3),ea5qgnik3k4(0:3),ea5qk3ignk4(0:3)
complex(kind=dbl) :: ea5qk3ik3k4(0:3),ea5qk4(0:3),v4ggni(0:3),v4gik1(0:3)
complex(kind=dbl) :: v4gk1i(0:3),v4gk2i(0:3),v4qgni(0:3),v4qik1(0:3)
complex(kind=dbl) :: v4qk1i(0:3),v4qk2i(0:3),v5ggni(0:3),v5gik3(0:3)
complex(kind=dbl) :: v5gk3i(0:3),v5gk4i(0:3),v5qgni(0:3),v5qik4(0:3)
complex(kind=dbl) :: v5qk3i(0:3),v5qk4i(0:3),a4g(0:3,0:3),a4q(0:3,0:3)
complex(kind=dbl) :: a5g(0:3,0:3),a5q(0:3,0:3),v4g(0:3,0:3),v4q(0:3,0:3)
complex(kind=dbl) :: v5g(0:3,0:3),v5q(0:3,0:3)
!
character(len=7) :: kind3pt
logical :: overlap,qqgverts,tripleglue
logical :: nested,nestedglue,nestedquark,glueloop,quarkloop
complex(kind=dbl) :: k2pt(0:2,0:3),q(0:3)
complex(kind=dbl) :: omegasq,qsq
character(len=9) :: kind2pt
logical :: cut2pt(0:3)
complex(kind=dbl) :: outg(0:3,0:3)
complex(kind=dbl) :: mk1(0:3),tracem,dotqk1,mqk1
complex(kind=dbl) :: outq(0:3)
complex(kind=dbl) :: omega1sq,bareprop(0:3,0:3),dm(0:3),qm,dqm
complex(kind=dbl) :: tracebareprop
!
complex(kind=dbl), parameter :: gn(0:3) = &
         (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) 
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
integer :: mu,nu,alpha
logical :: left,right
!
complex(kind=dbl) :: k3pt(3,0:3)
logical :: cut3pt(3)
!
! Set logical variables according to what case we have.
!
overlap = .false.
qqgverts = .false.
tripleglue = .false.
nested = .false.
nestedglue = .false.
nestedquark = .false.
glueloop = .false.
quarkloop = .false.
IF (kind2pt2.EQ.'overlap/qggqq') THEN
  overlap = .true.
  qqgverts = .true.
ELSE IF (kind2pt2.EQ.'overlap/qgqgg') THEN
  overlap = .true.
  tripleglue = .true.
ELSE IF (kind2pt2.EQ.'nested /qgggg') THEN
  nested = .true.
  nestedglue = .true.
  glueloop = .true.
ELSE IF (kind2pt2.EQ.'nested /qggqq') THEN
  nested = .true.
  nestedglue = .true.
  quarkloop = .true.
ELSE IF (kind2pt2.EQ.'nested /gqqgq') THEN
  nested = .true.
  nestedquark = .true.
ELSE
  write(nout,*)'Not programmed for that.'
  stop
END IF
!
IF (overlap) THEN
!
! Short form of momentum variables and rename cut variables
! for overlap graphs.
!
DO mu = 0,3
  k0(mu) = k2pt2(0,mu)
  k1(mu) = k2pt2(1,mu)
  k2(mu) = k2pt2(2,mu)
  k3(mu) = k2pt2(3,mu)
  k4(mu) = k2pt2(4,mu)
  k5(mu) = k2pt2(5,mu)
END DO
cut(1) = cut2pt2(1)
cut(2) = cut2pt2(2)
cut(3) = cut2pt2(3)
cut(4) = cut2pt2(4)
cut(5) = cut2pt2(5)
!
! We have an OVERLAP type graph. We can treat it two different
! ways: either the left=hand three point graph is calculated
! using subroutine VERTEX or else the right-hand three point
! graph is calculated with subroutine VERTEX. We choose according
! to which lines are cut. Generally, we take the "left" choice,
! but if the right-hand loop is virtual, we take the "right" choice.
!
left = .true.
right = .false.
IF (cut2pt2(1).AND.cut2pt2(2)) THEN
  left = .false.
  right = .true.
END IF
!
! For testing purposes, we include code to override this choice.
!
!     IF (OVERRIDE) THEN
!       LEFT = LEFTOVERRIDE
!       RIGHT = .NOT.LEFT
!     END IF
!
! Calculate according to case, with logic
!     IF (QQGVERTS.AND.RIGHT) THEN
!     ELSE IF (QQGVERTS.AND.LEFT) THEN
!     ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN
!     ELSE IF (TRIPLEGLUE.AND.LEFT) THEN
!     ELSE <error>
!     END IF
!
!
!---
!
IF (qqgverts.AND.right) THEN
!
!---
tk00 = 0.0d0
DO mu = 1,3
  tk00 = tk00 - k0(mu)**2
END DO
e0 = k0(0)
k00 = e0**2 + tk00
prefactor = 1.0d0/k00**2
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
DO mu = 0,3
  k3pt(1,mu) = -k4(mu)
  k3pt(2,mu) = -k5(mu)
  k3pt(3,mu) = k3(mu)
END DO
cut3pt(1) = cut(4)
cut3pt(2) = cut(5)
cut3pt(3) = cut(3)
kind3pt = 'qqg/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q)
tracev4q = 0.0d0
DO mu = 0,3
  tracev4q = tracev4q + v4q(mu,mu)*metric(mu)
END DO
v4qwgnk0 = 0.0d0
v4qwgnk1 = 0.0d0
v4qwgnk2 = 0.0d0
v4qwk0k1 = 0.0d0
v4qwk1k0 = 0.0d0
v4qwk2gn = 0.0d0
v4qwk2k0 = 0.0d0
v4qwk2k1 = 0.0d0
v4qwk2k2 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v4qwgnk0 = v4qwgnk0 &
         + v4q(mu,nu)*gn(mu)*k0(nu)*metric(mu)*metric(nu)
  v4qwgnk1 = v4qwgnk1 &
         + v4q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu)
  v4qwgnk2 = v4qwgnk2 &
         + v4q(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu)
  v4qwk0k1 = v4qwk0k1 &
         + v4q(mu,nu)*k0(mu)*k1(nu)*metric(mu)*metric(nu)
  v4qwk1k0 = v4qwk1k0 &
         + v4q(mu,nu)*k1(mu)*k0(nu)*metric(mu)*metric(nu)
  v4qwk2gn = v4qwk2gn &
         + v4q(mu,nu)*k2(mu)*gn(nu)*metric(mu)*metric(nu)
  v4qwk2k0 = v4qwk2k0 &
         + v4q(mu,nu)*k2(mu)*k0(nu)*metric(mu)*metric(nu)
  v4qwk2k1 = v4qwk2k1 &
         + v4q(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu)
  v4qwk2k2 = v4qwk2k2 &
         + v4q(mu,nu)*k2(mu)*k2(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  a4qgni(mu) = 0.0d0
  a4qk2i(mu) = 0.0d0
  v4qgni(mu) = 0.0d0
  v4qik1(mu) = 0.0d0
  v4qk1i(mu) = 0.0d0
  v4qk2i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a4qgni(mu) = a4qgni(mu) + a4q(nu,mu)*gn(nu)*metric(nu)
  a4qk2i(mu) = a4qk2i(mu) + a4q(nu,mu)*k2(nu)*metric(nu)
  v4qgni(mu) = v4qgni(mu) + v4q(nu,mu)*gn(nu)*metric(nu)
  v4qik1(mu) = v4qik1(mu) + v4q(mu,nu)*k1(nu)*metric(nu)
  v4qk1i(mu) = v4qk1i(mu) + v4q(nu,mu)*k1(nu)*metric(nu)
  v4qk2i(mu) = v4qk2i(mu) + v4q(nu,mu)*k2(nu)*metric(nu)
END DO
END DO
k0k1 = 0.0d0
k0k2 = 0.0d0
k1k2 = 0.0d0
DO mu = 0,3
  k0k1 = k0k1 + k0(mu)*k1(mu)*metric(mu)
  k0k2 = k0k2 + k0(mu)*k2(mu)*metric(mu)
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
END DO
call epsilont2(a4q,k0,k1,ea4qk0k1)
call epsilon4(a4qgni,k0,k1,k2,ea4qgnik0k1k2)
call epsilon4(a4qk2i,gn,k0,k1,ea4qk2ignk0k1)
call epsilon4(a4qk2i,k0,k1,k2,ea4qk2ik0k1k2)
call epsilon3(a4qgni,k1,k2,ea4qgnik1k2)
call epsilon3(a4qk2i,gn,k1,ea4qk2ignk1)
call epsilon3(a4qk2i,k1,k2,ea4qk2ik1k2)
call epsilont1(a4q,k1,ea4qk1)
DO nu = 0,3
!
x(1) = 0
x(2) = -ea4qk2ik1k2(nu) + v4qwk2k2*k1(nu) - v4qwk2k1*k2(nu) &
 + tk22*(ea4qk1(nu) - tracev4q*k1(nu) + v4qik1(nu) + v4qk1i(nu)) &
 - k1k2*v4qk2i(nu)
x(3) = ea4qgnik1k2(nu) - ea4qk2ignk1(nu) + v4qwk2k1*gn(nu) &
 + (-v4qwgnk2 - v4qwk2gn)*k1(nu) + v4qwgnk1*k2(nu) &
 + k1k2*v4qgni(nu) + e1*v4qk2i(nu)
x(4) = x(2) + e2*x(3)
x(5) = x(1) + k00*x(4)
x(6) = -2*ea4qk2ik0k1k2 + tk22*(-2*ea4qk0k1 + 2*k0k1*tracev4q &
 - 2*v4qwk0k1 - 2*v4qwk1k0) + 2*k1k2*v4qwk2k0 + 2*k0k2*v4qwk2k1 &
 - 2*k0k1*v4qwk2k2
x(7) = 2*ea4qgnik0k1k2 + 2*ea4qk2ignk0k1 - 2*k1k2*v4qwgnk0 &
 - 2*k0k2*v4qwgnk1 + k0k1*(2*v4qwgnk2 + 2*v4qwk2gn) &
 - 2*e1*v4qwk2k0 - 2*e0*v4qwk2k1
x(8) = x(6) + e2*x(7)
x(9) = x(5) + k0(nu)*x(8)
vout(nu) = (cf*x(9))/tk22
vout(nu) = vout(nu)*prefactor
!
END DO
!
ELSE IF (qqgverts.AND.left) THEN
!
!---
tk00 = 0.0d0
DO mu = 1,3
  tk00 = tk00 - k0(mu)**2
END DO
e0 = k0(0)
k00 = e0**2 + tk00
prefactor = 1.0d0/k00**2
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
DO mu = 1,3
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
END DO
k33 = e3**2 + tk33
k44 = e4**2 + tk44
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
DO mu = 0,3
  k3pt(1,mu) = -k5(mu)
  k3pt(2,mu) = -k1(mu)
  k3pt(3,mu) = k2(mu)
END DO
cut3pt(1) = cut(5)
cut3pt(2) = cut(1)
cut3pt(3) = cut(2)
kind3pt = 'qqg/qqg'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v5q,a5q)
tracev5q = 0.0d0
DO mu = 0,3
  tracev5q = tracev5q + v5q(mu,mu)*metric(mu)
END DO
v5qwgnk0 = 0.0d0
v5qwgnk3 = 0.0d0
v5qwgnk4 = 0.0d0
v5qwk0k4 = 0.0d0
v5qwk3gn = 0.0d0
v5qwk3k0 = 0.0d0
v5qwk3k3 = 0.0d0
v5qwk3k4 = 0.0d0
v5qwk4k0 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v5qwgnk0 = v5qwgnk0 &
         + v5q(mu,nu)*gn(mu)*k0(nu)*metric(mu)*metric(nu)
  v5qwgnk3 = v5qwgnk3 &
         + v5q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu)
  v5qwgnk4 = v5qwgnk4 &
         + v5q(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu)
  v5qwk0k4 = v5qwk0k4 &
         + v5q(mu,nu)*k0(mu)*k4(nu)*metric(mu)*metric(nu)
  v5qwk3gn = v5qwk3gn &
         + v5q(mu,nu)*k3(mu)*gn(nu)*metric(mu)*metric(nu)
  v5qwk3k0 = v5qwk3k0 &
         + v5q(mu,nu)*k3(mu)*k0(nu)*metric(mu)*metric(nu)
  v5qwk3k3 = v5qwk3k3 &
         + v5q(mu,nu)*k3(mu)*k3(nu)*metric(mu)*metric(nu)
  v5qwk3k4 = v5qwk3k4 &
         + v5q(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu)
  v5qwk4k0 = v5qwk4k0 &
         + v5q(mu,nu)*k4(mu)*k0(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  a5qgni(mu) = 0.0d0
  a5qk3i(mu) = 0.0d0
  v5qgni(mu) = 0.0d0
  v5qik4(mu) = 0.0d0
  v5qk3i(mu) = 0.0d0
  v5qk4i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a5qgni(mu) = a5qgni(mu) + a5q(nu,mu)*gn(nu)*metric(nu)
  a5qk3i(mu) = a5qk3i(mu) + a5q(nu,mu)*k3(nu)*metric(nu)
  v5qgni(mu) = v5qgni(mu) + v5q(nu,mu)*gn(nu)*metric(nu)
  v5qik4(mu) = v5qik4(mu) + v5q(mu,nu)*k4(nu)*metric(nu)
  v5qk3i(mu) = v5qk3i(mu) + v5q(nu,mu)*k3(nu)*metric(nu)
  v5qk4i(mu) = v5qk4i(mu) + v5q(nu,mu)*k4(nu)*metric(nu)
END DO
END DO
k0k3 = 0.0d0
k0k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k0k3 = k0k3 + k0(mu)*k3(mu)*metric(mu)
  k0k4 = k0k4 + k0(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
call epsilont2(a5q,k0,k4,ea5qk0k4)
call epsilon4(a5qgni,k0,k3,k4,ea5qgnik0k3k4)
call epsilon4(a5qk3i,gn,k0,k4,ea5qk3ignk0k4)
call epsilon4(a5qk3i,k0,k3,k4,ea5qk3ik0k3k4)
call epsilon3(a5qgni,k3,k4,ea5qgnik3k4)
call epsilon3(a5qk3i,gn,k4,ea5qk3ignk4)
call epsilon3(a5qk3i,k3,k4,ea5qk3ik3k4)
call epsilont1(a5q,k4,ea5qk4)
DO nu = 0,3
!
x(1) = 0
x(2) = -ea5qk3ik3k4(nu) - v5qwk3k4*k3(nu) + v5qwk3k3*k4(nu) &
 - k3k4*v5qk3i(nu) + tk33*(-ea5qk4(nu) - tracev5q*k4(nu) &
 + v5qik4(nu) + v5qk4i(nu))
x(3) = ea5qgnik3k4(nu) + ea5qk3ignk4(nu) + v5qwk3k4*gn(nu) &
 + v5qwgnk4*k3(nu) + (-v5qwgnk3 - v5qwk3gn)*k4(nu) &
 + k3k4*v5qgni(nu) + e4*v5qk3i(nu)
x(4) = x(2) + e3*x(3)
x(5) = x(1) + k00*x(4)
x(6) = -2*ea5qk3ik0k3k4 + 2*k3k4*v5qwk3k0 - 2*k0k4*v5qwk3k3 &
 + 2*k0k3*v5qwk3k4 + tk33*(2*ea5qk0k4 + 2*k0k4*tracev5q &
 - 2*v5qwk0k4 - 2*v5qwk4k0)
x(7) = 2*ea5qgnik0k3k4 - 2*ea5qk3ignk0k4 - 2*k3k4*v5qwgnk0 &
 - 2*k0k3*v5qwgnk4 + k0k4*(2*v5qwgnk3 + 2*v5qwk3gn) &
 - 2*e4*v5qwk3k0 - 2*e0*v5qwk3k4
x(8) = x(6) + e3*x(7)
x(9) = x(5) + k0(nu)*x(8)
vout(nu) = (cf*x(9))/tk33
vout(nu) = vout(nu)*prefactor
!
END DO
!
ELSE IF (tripleglue.AND.right) THEN
!
!---
tk00 = 0.0d0
DO mu = 1,3
  tk00 = tk00 - k0(mu)**2
END DO
e0 = k0(0)
k00 = e0**2 + tk00
prefactor = 1.0d0/k00**2
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
DO mu = 0,3
  k3pt(1,mu) = -k4(mu)
  k3pt(2,mu) = -k5(mu)
  k3pt(3,mu) = k3(mu)
END DO
cut3pt(1) = cut(4)
cut3pt(2) = cut(5)
cut3pt(3) = cut(3)
kind3pt = 'qqg/ggq'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v4g,a4g)
tracev4g = 0.0d0
DO mu = 0,3
  tracev4g = tracev4g + v4g(mu,mu)*metric(mu)
END DO
v4gwgnk0 = 0.0d0
v4gwgnk1 = 0.0d0
v4gwgnk2 = 0.0d0
v4gwk0k1 = 0.0d0
v4gwk1k0 = 0.0d0
v4gwk2gn = 0.0d0
v4gwk2k0 = 0.0d0
v4gwk2k1 = 0.0d0
v4gwk2k2 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v4gwgnk0 = v4gwgnk0 &
         + v4g(mu,nu)*gn(mu)*k0(nu)*metric(mu)*metric(nu)
  v4gwgnk1 = v4gwgnk1 &
         + v4g(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu)
  v4gwgnk2 = v4gwgnk2 &
         + v4g(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu)
  v4gwk0k1 = v4gwk0k1 &
         + v4g(mu,nu)*k0(mu)*k1(nu)*metric(mu)*metric(nu)
  v4gwk1k0 = v4gwk1k0 &
         + v4g(mu,nu)*k1(mu)*k0(nu)*metric(mu)*metric(nu)
  v4gwk2gn = v4gwk2gn &
         + v4g(mu,nu)*k2(mu)*gn(nu)*metric(mu)*metric(nu)
  v4gwk2k0 = v4gwk2k0 &
         + v4g(mu,nu)*k2(mu)*k0(nu)*metric(mu)*metric(nu)
  v4gwk2k1 = v4gwk2k1 &
         + v4g(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu)
  v4gwk2k2 = v4gwk2k2 &
         + v4g(mu,nu)*k2(mu)*k2(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  a4ggni(mu) = 0.0d0
  a4gk2i(mu) = 0.0d0
  v4ggni(mu) = 0.0d0
  v4gik1(mu) = 0.0d0
  v4gk1i(mu) = 0.0d0
  v4gk2i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a4ggni(mu) = a4ggni(mu) + a4g(nu,mu)*gn(nu)*metric(nu)
  a4gk2i(mu) = a4gk2i(mu) + a4g(nu,mu)*k2(nu)*metric(nu)
  v4ggni(mu) = v4ggni(mu) + v4g(nu,mu)*gn(nu)*metric(nu)
  v4gik1(mu) = v4gik1(mu) + v4g(mu,nu)*k1(nu)*metric(nu)
  v4gk1i(mu) = v4gk1i(mu) + v4g(nu,mu)*k1(nu)*metric(nu)
  v4gk2i(mu) = v4gk2i(mu) + v4g(nu,mu)*k2(nu)*metric(nu)
END DO
END DO
k0k1 = 0.0d0
k0k2 = 0.0d0
k1k2 = 0.0d0
DO mu = 0,3
  k0k1 = k0k1 + k0(mu)*k1(mu)*metric(mu)
  k0k2 = k0k2 + k0(mu)*k2(mu)*metric(mu)
  k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu)
END DO
call epsilont2(a4g,k0,k1,ea4gk0k1)
call epsilon4(a4ggni,k0,k1,k2,ea4ggnik0k1k2)
call epsilon4(a4gk2i,gn,k0,k1,ea4gk2ignk0k1)
call epsilon4(a4gk2i,k0,k1,k2,ea4gk2ik0k1k2)
call epsilon3(a4ggni,k1,k2,ea4ggnik1k2)
call epsilon3(a4gk2i,gn,k1,ea4gk2ignk1)
call epsilon3(a4gk2i,k1,k2,ea4gk2ik1k2)
call epsilont1(a4g,k1,ea4gk1)
DO nu = 0,3
!
x(1) = 0
x(2) = -ea4gk2ik1k2(nu) + v4gwk2k2*k1(nu) - v4gwk2k1*k2(nu) &
 + tk22*(ea4gk1(nu) - tracev4g*k1(nu) + v4gik1(nu) + v4gk1i(nu)) &
 - k1k2*v4gk2i(nu)
x(3) = ea4ggnik1k2(nu) - ea4gk2ignk1(nu) + v4gwk2k1*gn(nu) &
 + (-v4gwgnk2 - v4gwk2gn)*k1(nu) + v4gwgnk1*k2(nu) &
 + k1k2*v4ggni(nu) + e1*v4gk2i(nu)
x(4) = x(2) + e2*x(3)
x(5) = x(1) + k00*x(4)
x(6) = -2*ea4gk2ik0k1k2 + tk22*(-2*ea4gk0k1 + 2*k0k1*tracev4g &
 - 2*v4gwk0k1 - 2*v4gwk1k0) + 2*k1k2*v4gwk2k0 + 2*k0k2*v4gwk2k1 &
 - 2*k0k1*v4gwk2k2
x(7) = 2*ea4ggnik0k1k2 + 2*ea4gk2ignk0k1 - 2*k1k2*v4gwgnk0 &
 - 2*k0k2*v4gwgnk1 + k0k1*(2*v4gwgnk2 + 2*v4gwk2gn) &
 - 2*e1*v4gwk2k0 - 2*e0*v4gwk2k1
x(8) = x(6) + e2*x(7)
x(9) = x(5) + k0(nu)*x(8)
vout(nu) = (cf*x(9))/tk22
vout(nu) = vout(nu)*prefactor
!
END DO
!
ELSE IF (tripleglue.AND.left) THEN
!
!---
tk00 = 0.0d0
DO mu = 1,3
  tk00 = tk00 - k0(mu)**2
END DO
e0 = k0(0)
k00 = e0**2 + tk00
prefactor = 1.0d0/k00**2
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
DO mu = 1,3
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
END DO
k33 = e3**2 + tk33
k44 = e4**2 + tk44
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/complexsqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
DO mu = 0,3
  k3pt(1,mu) = k5(mu)
  k3pt(2,mu) = -k2(mu)
  k3pt(3,mu) = k1(mu)
END DO
cut3pt(1) = cut(5)
cut3pt(2) = cut(2)
cut3pt(3) = cut(1)
kind3pt = 'qqg/ggq'
call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v5g,a5g)
tracev5g = 0.0d0
DO mu = 0,3
  tracev5g = tracev5g + v5g(mu,mu)*metric(mu)
END DO
v5gwgnk0 = 0.0d0
v5gwgnk3 = 0.0d0
v5gwgnk4 = 0.0d0
v5gwk0k3 = 0.0d0
v5gwk3k0 = 0.0d0
v5gwk4gn = 0.0d0
v5gwk4k0 = 0.0d0
v5gwk4k3 = 0.0d0
v5gwk4k4 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  v5gwgnk0 = v5gwgnk0 &
         + v5g(mu,nu)*gn(mu)*k0(nu)*metric(mu)*metric(nu)
  v5gwgnk3 = v5gwgnk3 &
         + v5g(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu)
  v5gwgnk4 = v5gwgnk4 &
         + v5g(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu)
  v5gwk0k3 = v5gwk0k3 &
         + v5g(mu,nu)*k0(mu)*k3(nu)*metric(mu)*metric(nu)
  v5gwk3k0 = v5gwk3k0 &
         + v5g(mu,nu)*k3(mu)*k0(nu)*metric(mu)*metric(nu)
  v5gwk4gn = v5gwk4gn &
         + v5g(mu,nu)*k4(mu)*gn(nu)*metric(mu)*metric(nu)
  v5gwk4k0 = v5gwk4k0 &
         + v5g(mu,nu)*k4(mu)*k0(nu)*metric(mu)*metric(nu)
  v5gwk4k3 = v5gwk4k3 &
         + v5g(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu)
  v5gwk4k4 = v5gwk4k4 &
         + v5g(mu,nu)*k4(mu)*k4(nu)*metric(mu)*metric(nu)
END DO
END DO
DO mu = 0,3
  a5ggni(mu) = 0.0d0
  a5gk4i(mu) = 0.0d0
  v5ggni(mu) = 0.0d0
  v5gik3(mu) = 0.0d0
  v5gk3i(mu) = 0.0d0
  v5gk4i(mu) = 0.0d0
END DO
DO mu = 0,3
DO nu = 0,3
  a5ggni(mu) = a5ggni(mu) + a5g(nu,mu)*gn(nu)*metric(nu)
  a5gk4i(mu) = a5gk4i(mu) + a5g(nu,mu)*k4(nu)*metric(nu)
  v5ggni(mu) = v5ggni(mu) + v5g(nu,mu)*gn(nu)*metric(nu)
  v5gik3(mu) = v5gik3(mu) + v5g(mu,nu)*k3(nu)*metric(nu)
  v5gk3i(mu) = v5gk3i(mu) + v5g(nu,mu)*k3(nu)*metric(nu)
  v5gk4i(mu) = v5gk4i(mu) + v5g(nu,mu)*k4(nu)*metric(nu)
END DO
END DO
k0k3 = 0.0d0
k0k4 = 0.0d0
k3k4 = 0.0d0
DO mu = 0,3
  k0k3 = k0k3 + k0(mu)*k3(mu)*metric(mu)
  k0k4 = k0k4 + k0(mu)*k4(mu)*metric(mu)
  k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu)
END DO
call epsilont2(a5g,k0,k3,ea5gk0k3)
call epsilon4(a5ggni,k0,k3,k4,ea5ggnik0k3k4)
call epsilon4(a5gk4i,gn,k0,k3,ea5gk4ignk0k3)
call epsilon4(a5gk4i,k0,k3,k4,ea5gk4ik0k3k4)
call epsilon3(a5ggni,k3,k4,ea5ggnik3k4)
call epsilon3(a5gk4i,gn,k3,ea5gk4ignk3)
call epsilon3(a5gk4i,k3,k4,ea5gk4ik3k4)
call epsilont1(a5g,k3,ea5gk3)
DO nu = 0,3
!
x(1) = 0
x(2) = -ea5gk4ik3k4(nu) - v5gwk4k4*k3(nu) + v5gwk4k3*k4(nu) &
 + tk44*(ea5gk3(nu) + tracev5g*k3(nu) - v5gik3(nu) - v5gk3i(nu)) &
 + k3k4*v5gk4i(nu)
x(3) = ea5ggnik3k4(nu) - ea5gk4ignk3(nu) - v5gwk4k3*gn(nu) &
 + (v5gwgnk4 + v5gwk4gn)*k3(nu) - v5gwgnk3*k4(nu) &
 - k3k4*v5ggni(nu) - e3*v5gk4i(nu)
x(4) = x(2) + e4*x(3)
x(5) = x(1) + k00*x(4)
x(6) = -2*ea5gk4ik0k3k4 + tk44*(-2*ea5gk0k3 - 2*k0k3*tracev5g &
 + 2*v5gwk0k3 + 2*v5gwk3k0) - 2*k3k4*v5gwk4k0 - 2*k0k4*v5gwk4k3 &
 + 2*k0k3*v5gwk4k4
x(7) = 2*ea5ggnik0k3k4 + 2*ea5gk4ignk0k3 + 2*k3k4*v5gwgnk0 &
 + 2*k0k4*v5gwgnk3 + k0k3*(-2*v5gwgnk4 - 2*v5gwk4gn) &
 + 2*e3*v5gwk4k0 + 2*e0*v5gwk4k3
x(8) = x(6) + e4*x(7)
x(9) = x(5) + k0(nu)*x(8)
vout(nu) = -((cf*x(9))/tk44)
vout(nu) = vout(nu)*prefactor
!
END DO
ELSE
  write(nout,*)'Not programmed for that.'
  stop
END IF
!
!-------------
!
! Alternative for IF (OVERLAP) THEN.
!
ELSE IF (nested) THEN      
!
! We have a nested graph.
!
DO mu = 0,3
  k2pt(0,mu) = k2pt2(2,mu)
  k2pt(1,mu) = k2pt2(4,mu)
  k2pt(2,mu) = k2pt2(5,mu)
  q(mu) = k2pt2(0,mu)
  k1(mu) = k2pt2(1,mu)
END DO
omegasq = q(1)**2 + q(2)**2 + q(3)**2
qsq = q(0)**2 - omegasq
omega1sq = k1(1)**2 + k1(2)**2 + k1(3)**2
!
cut2pt(0) = cut2pt2(2)
cut2pt(1) = cut2pt2(4)
cut2pt(2) = cut2pt2(5)
cut2pt(3) = cut2pt2(3)
!
! We need the factor equal to 1/k^2 for an uncut propagator
! and 1/ 2|\vec k| for a cut propagator. BUT line 1 is always
! cut, propagator 0 never cut, and the one-loop two point function 
! that is nested inside has the factor for propagators 2,3,4,5.
!   
prefactor = cf/(qsq**2*2.0d0*complexsqrt(omega1sq))
!
IF (nestedglue) THEN
!
! Our nested graph has a gluon self-energy insertion.
! Calculate OUTG according to what kind of self-energy insertion it is.
!
IF (glueloop) THEN
  kind2pt = 'gluonloop'
  call twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,outg)
ELSE IF (quarkloop) THEN
  kind2pt = 'quarkloop'
  call twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,outg)
END IF
!
! Now comlete the calculation for a gluon self-energy insertion.
!
DO alpha = 0,3
  temp = 0.0d0
  DO nu = 0,3
    temp = temp + outg(alpha,nu)*k1(nu)*metric(nu)
  END DO
  mk1(alpha) = temp
END DO
!
tracem = 0.0d0
dotqk1 = 0.0d0
DO mu = 0,3
  tracem = tracem + outg(mu,mu)*metric(mu)
  dotqk1 = dotqk1 + q(mu)*k1(mu)*metric(mu)
END DO
!
mqk1 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  mqk1 = mqk1 + outg(mu,nu)*q(mu)*k1(nu)*metric(mu)*metric(nu) 
END DO
END DO
!
DO alpha = 0,3
  temp = - 2.0d0*qsq*mk1(alpha)
  temp = temp + 4.0d0*q(alpha)*mqk1
  temp = temp + (qsq*k1(alpha) - 2.0d0*q(alpha)*dotqk1)*tracem
  vout(alpha) = prefactor*temp
END DO
!
! Alternative for IF (NESTEDGLUE) THEN
!
ELSE IF (nestedquark) THEN
!
! Our nested graph has a quark self-energy insertion.
! Calculate OUTQ.
!
call twopointq(k2pt,cut2pt,mumsbar,flag,outq)
!
! Now comlete the calculation for a quark self-energy insertion.
!
! The gluon propagator in Coulomb gauge for an on-shell gluon
! with three-momentum K1(mu).
!
bareprop(0,0) = 0.0d0
DO mu = 1,3
  bareprop(0,mu) = 0.0d0
  bareprop(mu,0) = 0.0d0
  bareprop(mu,mu) = 1.0d0 - k1(mu)**2/omega1sq
DO nu = mu+1,3
  temp = - k1(mu)*k1(nu)/omega1sq
  bareprop(mu,nu) = temp
  bareprop(nu,mu) = temp
END DO
END DO
tracebareprop = -2.0d0
!
DO alpha = 0,3
  dm(alpha) = 0.0d0
  DO nu = 0,3
   dm(alpha) = dm(alpha) + bareprop(alpha,nu)*outq(nu)*metric(nu)
  END DO
END DO
!
dqm = 0.0d0
  qm = 0.0d0
DO mu = 0,3
  qm = qm + q(mu)*outq(mu)*metric(mu)
DO nu = 0,3
 dqm = dqm + bareprop(mu,nu)*q(mu)*outq(nu)*metric(mu)*metric(nu)
END DO
END DO
!
DO alpha = 0,3
  temp = - 2.0d0*qsq*dm(alpha)
  temp = temp + 4.0d0*q(alpha)*dqm
  temp = temp  &
         + (qsq*outq(alpha) - 2.0d0*q(alpha)*qm)*tracebareprop
  vout(alpha) = prefactor*temp
END DO
!
! Close IF (NESTEDGLUE) THEN ... ELSE IF (NESTEDQUARK) THEN
!
ELSE
  write(nout,*)'Oops, something must have gone wrong.'
  stop
END IF
!
! Close  IF (OVERLAP) THEN ... ELSE IF (NESTED) THEN      
!
ELSE
  write(nout,*)'Oops, something has gone wrong.'
  stop
END IF
!
RETURN
END subroutine twopt2
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!             Dotting the epsilon tensor into vectors and tensors
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine epsilon4(v1,v2,v3,v4,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: v1(0:3),v2(0:3),v3(0:3),v4(0:3)
! Out:
complex(kind=dbl) :: out
!
! Computes the contraction of the epsilon tensor with four four-vectors,
! giving a scalar result, OUT. The four vectors have upper indices.
! The epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1.
!
! 5 June 2001
!
integer :: n
!
! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
! define the contributions to epsilon and J = 1,...,4 labelling
! the four indices of epsilon.
!
integer, parameter :: mu(24,4) = reshape( &
       (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, &
         1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, &
         2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, &
         3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)&
        ,(/24,4/) )
!
! Sign(N) is minus the signature of the permutation.
!
integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, &
           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/)
!
out = (0.0d0,0.0d0)
DO n = 1,24
  out = out &
        + sign(n)*v1(mu(n,1))*v2(mu(n,2))*v3(mu(n,3))*v4(mu(n,4))
END DO
RETURN
END subroutine epsilon4
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine epsilon3(v2,v3,v4,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: v2(0:3),v3(0:3),v4(0:3)
! Out:
complex(kind=dbl) :: out(0:3)
!
! Computes the contraction of the epsilon tensor with three
! four-vectors, giving a vector result, OUT(mu1). The vectors have
! upper indices. The epsilon tensor has lower indices, so
! epsilon(0,1,2,3) = -1, and in addition we need a metric tensor to
! raise the index of OUT. We calculate
!
!   Out(mu1) = epsilon(mu1,mu2,mu3,mu4)  v2(mu2) v3(mu3) v4(mu4)
!
! 5 June 2001
!
integer :: n,nu
!
! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
! define the contributions to epsilon and J = 1,...,4 labelling
! the four indices of epsilon.
!
integer, parameter :: mu(24,4) = reshape( &
       (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, &
         1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, &
         2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, &
         3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)&
        ,(/24,4/) )
!
! Sign(N) is minus the signature of the permutation.
!
integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, &
           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/)
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
!
DO nu = 0,3
  out(nu) = (0.0d0,0.0d0)
END DO
DO n = 1,24
  nu = mu(n,1)
  out(nu) = out(nu) &
       + metric(nu)*sign(n)*v2(mu(n,2))*v3(mu(n,3))*v4(mu(n,4))
END DO
RETURN
END subroutine epsilon3
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine epsilon2(v3,v4,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: v3(0:3),v4(0:3)
! Out:
complex(kind=dbl) :: out(0:3,0:3)
!
! Computes the contraction of the epsilon tensor with two
! four-vectors, giving a second rank tensor result, OUT(mu1,mu2). The
! vectors have upper indices. The epsilon tensor has lower
! indices, so epsilon(0,1,2,3) = -1, and in addition we need a metric
! tensor to raise the indices of OUT. We calculate
!
!   Out(mu1,mu2) = epsilon(mu1,mu2,mu3,mu4) v3(mu3) v4(mu4)
!
! 5 June 2001
!
integer :: n,nu1,nu2
!
! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
! define the contributions to epsilon and J = 1,...,4 labelling
! the four indices of epsilon.
!
integer, parameter :: mu(24,4) = reshape( &
       (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, &
         1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, &
         2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, &
         3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)&
        ,(/24,4/) )
!
! Sign(N) is minus the signature of the permutation.
!
integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, &
           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/)
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
!
DO nu1 = 0,3
DO nu2 = 0,3
  out(nu1,nu2) = (0.0d0,0.0d0)
END DO
END DO
DO n = 1,24
  nu1 = mu(n,1)
  nu2 = mu(n,2)
  out(nu1,nu2) = out(nu1,nu2) &
    + metric(nu1)*metric(nu2)*sign(n)*v3(mu(n,3))*v4(mu(n,4))
END DO
RETURN
END subroutine epsilon2
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine epsilon2n(v3,v4,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: v3(0:3),v4(0:3)
! Out:
complex(kind=dbl) :: out(0:3)
!
! Computes the contraction of the epsilon tensor with two
! four-vectors and the unit vector n in the 0 direction, giving a 
! four-vector result, OUT(mu1). The vectors have upper indices. The
! epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1, and in
! addition we need a metric tensor to raise the index of OUT. However
! the metric contributes a factor (-1) in each case. We
! calculate
!
!   Out(mu1) = epsilon(mu1,mu2,mu3,mu4) n(mu2) v3(mu3) v4(mu4)
!
! 5 June 2001
!
integer :: n,nu
!
! Mu is Mu(N,J) with N = 1,...,6 labelling the permutations that
! define the contributions to epsilon that have 0 for the second
! index and J = 1,...,4 labelling the four indices of epsilon.
!
integer, parameter :: mu(6,4) = reshape( &
       (/1,1,2,2,3,3, &
         0,0,0,0,0,0, &
         2,3,1,3,1,2, &
         3,2,3,1,2,1/)&
        ,(/6,4/) )
!
! Sign(N) is minus the signature of the permutation.
!
integer, parameter :: sign(6) = (/1,-1,-1,1,1,-1/)
!
! Our result would have a factor METRIC(NU), but this factor is
! always -1.
!
DO nu = 0,3
  out(nu) = (0.0d0,0.0d0)
END DO
DO n = 1,6
  nu = mu(n,1)
  out(nu) = out(nu) - sign(n)*v3(mu(n,3))*v4(mu(n,4))
END DO
RETURN
END subroutine epsilon2n
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine epsilon1n(v4,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: v4(0:3)
! Out:
complex(kind=dbl) :: out(0:3,0:3)
!
! Computes the contraction of the epsilon tensor with one
! four-vector and the unit vector n in the 0 direction, giving a 
! tensor result, OUT(mu1,mu2). The vectors have upper indices. The
! epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1, and in
! addition we need a metric tensor to raise the index of OUT.
! However, the metric tensor in each case contributes (-1)^2 = 1. We
! calculate
!
!   Out(mu1,mu2) = epsilon(mu1,mu2,mu3,mu4) n(mu3) v4(mu4)
!
! 7 December 2001
!
integer :: n,mu1,mu2
!
! Mu is Mu(N,J) with N = 1,...,6 labelling the permutations that
! define the contributions to epsilon that have 0 for the third
! index and J = 1,...,4 labelling the four indices of epsilon.
!
integer, parameter :: mu(6,4) = reshape( &
       (/1,1,2,2,3,3, &
         2,3,1,3,1,2, &
         0,0,0,0,0,0, &
         3,2,3,1,2,1/)&
        ,(/6,4/) )
!
! Sign(N) is minus the signature of the permutation.
!
integer, parameter :: sign(6) = (/-1,1,1,-1,-1,1/)
!
! Our result would have a factor METRIC(MU1)*METRIC(MU2), 
! but this factor is always +1.
!
DO mu1 = 0,3
DO mu2 = 0,3
  out(mu1,mu2) = (0.0d0,0.0d0)
END DO
END DO
DO n = 1,6
  mu1 = mu(n,1)
  mu2 = mu(n,2)
  out(mu1,mu2) = out(mu1,mu2) + sign(n)*v4(mu(n,4))
END DO
RETURN
END subroutine epsilon1n
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine epsilont2(t12,v3,v4,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: t12(0:3,0:3),v3(0:3),v4(0:3)
! Out:
complex(kind=dbl) :: out
!
! Computes the contraction of the epsilon tensor with a second rank
! tensor and two four-vectors, giving a scalar result, OUT. 
! The tensor and the four vectors have upper indices.
! The epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1.
!
! 4 August 2001
!
integer :: n
!
! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
! define the contributions to epsilon and J = 1,...,4 labelling
! the four indices of epsilon.
!
integer, parameter :: mu(24,4) = reshape( &
       (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, &
         1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, &
         2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, &
         3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)&
        ,(/24,4/) )
!
! Sign(N) is minus the signature of the permutation.
!
integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, &
           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/)
!
out = (0.0d0,0.0d0)
DO n = 1,24
  out = out &
        + sign(n)*t12(mu(n,1),mu(n,2))*v3(mu(n,3))*v4(mu(n,4))
END DO
RETURN
END subroutine epsilont2
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine epsilont1(t23,v4,out)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: t23(0:3,0:3),v4(0:3)
! Out:
complex(kind=dbl) :: out(0:3)
!
! Computes the contraction of the epsilon tensor with a second
! rank tensor and a four-vector, giving a vector result, OUT(mu1). 
! The tensor and the vector have upper indices. The epsilon tensor has 
! lower indices, so epsilon(0,1,2,3) = -1, and in addition we need
! a metric tensor to raise the index of OUT. We calculate
!
!   Out(mu1) = epsilon(mu1,mu2,mu3,mu4)  t23(mu2,mu3) v4(mu4)
!
! 4 August 2001
!
integer :: n,nu
!
! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
! define the contributions to epsilon and J = 1,...,4 labelling
! the four indices of epsilon.
!
integer, parameter :: mu(24,4) = reshape( &
       (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, &
         1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, &
         2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, &
         3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)&
        ,(/24,4/) )
!
! Sign(N) is minus the signature of the permutation.
!
integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, &
           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/)
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
!
DO nu = 0,3
  out(nu) = (0.0d0,0.0d0)
END DO
DO n = 1,24
  nu = mu(n,1)
  out(nu) = out(nu) &
       + metric(nu)*sign(n)*t23(mu(n,2),mu(n,3))*v4(mu(n,4))
END DO
RETURN
END subroutine epsilont1
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine diagnostic(badpointinfo)
!
use beowulf_helpers
implicit none
! In:
type badpointstate
  integer        :: jr
  integer        :: ir(250)
  real(kind=dbl) :: rr(250)
  integer        :: graphnumber
  integer        :: mapnumber
  real(kind=dbl) :: k(0:3*size-1,0:3)
end type badpointstate
type(badpointstate) :: badpointinfo
!
integer :: nprops,nverts
integer :: order
integer :: nloops1,nprops1,nverts1,cutmax1
integer :: nloops2,nprops2,nverts2,cutmax2
common /sizes/ nloops1,nprops1,nverts1,cutmax1, &
               nloops2,nprops2,nverts2,cutmax2
!
! NEWGRAPH variables:
type graphstructure
  integer                          :: graphnumber
  integer                          :: order
  integer, dimension(0:3*size-1,2) :: vrtx
  integer, dimension(2*size,3)     :: prop
end type graphstructure
type(graphstructure) :: graph
logical :: graphfound
integer :: graphnumber
! MAP variables:
integer :: nmaps,qs(maxmaps,0:size),qsigns(maxmaps,0:size)
character(len=6) :: maptypes(maxmaps)
! Calculate variables:
logical :: report,details
common /calculook/ report,details
complex(kind=dbl) :: value
complex(kind=dbl) :: valuechk
real(kind=dbl) :: maxpart
!
real(kind=dbl) :: k(0:3*size-1,0:3)
real(kind=dbl) :: absk(0:3*size-1)
integer :: p,mu,v
real(kind=dbl) :: cos12,cos23,cos31,sin12,sin23,sin31
real(kind=dbl) :: badness
! Reno size and counting variables:
integer :: groupsize(maxgraphs,maxmaps)
integer :: groupsizegraph(maxgraphs)
integer :: groupsizetotal
common /montecarlo/groupsize,groupsizegraph,groupsizetotal
!
! State of the random number generator. For its diagnostic purposes,
! subroutine diagnostic sets the state of the random number generator
! to what it was just before subroutine calculate was called for the
! bad point, then subroutine diagnostic calls subroutine calculate.
!
integer :: jrandom,irandom(250)
real(kind=dbl) :: rrandom(250)
common/rando/ rrandom,jrandom,irandom
!
! This finds data for the kind of graph with the worst value
! Latest revision: 9 February 2003
! -------
!
order = 2
IF (badpointinfo%graphnumber.GT.10) THEN
  order = 1
END IF
IF (order.EQ.1) THEN
  nprops = nprops1
  nverts = nverts1
ELSE IF (order.EQ.2) THEN
  nprops = nprops2
  nverts = nverts2
ELSE
  write(nout,*)'Order must be 1 or 2.',order
END IF
!
! First we have to run NEWGRAPH through all the graphs so that it
! initializes itself.
!
graphfound = .true.
DO WHILE (graphfound)
call getnewgraph(order,graph,graphfound)
END DO
!
! Now we find the graph we wanted.
!
graphfound = .true.
IF (order.EQ.2) THEN
  graphnumber = 0
ELSE IF (order.EQ.1) THEN
  graphnumber = 10
ELSE
  write(nout,*)'Order must be 1 or 2.',order
  stop
END IF
DO WHILE (graphfound)
call getnewgraph(order,graph,graphfound)
IF (graphfound) THEN
graphnumber = graphnumber + 1
END IF
IF (graphfound.eqv..false.) THEN
  write(nout,*)'Oops, snafu in diagnostic.'
  stop
END IF
IF (graphnumber.EQ.badpointinfo%graphnumber) THEN
  graphfound = .false.
END IF
END DO
!
! Calculate information associated with the maps.
!
call findtypes(graph,nmaps,qs,qsigns,maptypes)
!
! We are ready to go.
!
!
DO p = 0,nprops
DO mu = 0,3
  k(p,mu) = badpointinfo%k(p,mu)
END DO
END DO
!
DO p = 1,nprops
  absk(p) = 0.0d0
  DO mu = 1,3
    absk(p) = absk(p) + k(p,mu)**2
  END DO
  absk(p) = sqrt(absk(p))
END DO
!
write(nout,*)' '
write(nout,*)'Analysis by subroutine diagnostic'
write(nout,*)' '
write(nout,702)graphnumber
702   format('graph number ',i3)
write(nout,*)'Point:'
DO p=1,nprops
  write(nout,703) p,k(p,1),k(p,2),k(p,3)
703     format('p =',i2,'  k = ',3(1p g12.3))
END DO
!
write(nout,*)' '
write(nout,*)'Softness:'
DO p = 1,nprops
  write(nout,704) p,absk(p)
704     format('p =',i2,'  |k| = ',1p g12.3)
END DO
!
write(nout,*)' '
write(nout,*)'Collinearity:'
DO v = 3,nverts
 cos12 = 0.0d0
 cos23 = 0.0d0
 cos31 = 0.0d0
 DO mu = 1,3
  cos12 = cos12 + k(graph%prop(v,1),mu) * k(graph%prop(v,2),mu)
  cos23 = cos23 + k(graph%prop(v,2),mu) * k(graph%prop(v,3),mu)
  cos31 = cos31 + k(graph%prop(v,3),mu) * k(graph%prop(v,1),mu)
 END DO
 cos12 = cos12 /absk(graph%prop(v,1))/absk(graph%prop(v,2))
 cos23 = cos23 /absk(graph%prop(v,2))/absk(graph%prop(v,3))
 cos31 = cos31 /absk(graph%prop(v,3))/absk(graph%prop(v,1))
 sin12 = sqrt(1.0d0 - cos12**2)
 sin23 = sqrt(1.0d0 - cos23**2)
 sin31 = sqrt(1.0d0 - cos31**2)
 write(nout,705)v,graph%prop(v,1),graph%prop(v,2),graph%prop(v,3), &
       sin12,sin23,sin31
705    format('v =',i2,' ps =',3i2,'  sines =', 3f10.5)
END DO
!
write(nout,*)' '
call checkpoint(k,absk,graph%prop,order,badness)
write(nout,706)badness
706   format('Badness of this point is',1p g10.2)
!
write(nout,*)' '
write(nout,*)'Calculate finds the folowing:'
! report = .true.  !! Use this if you want to see the contributions.
! details = .true. !! Use this if you want to see even more.
!
jrandom = badpointinfo%jr ! This sets the state of the random number
irandom = badpointinfo%ir ! generator to what it was just before
rrandom = badpointinfo%rr ! calculate was called for the bad point.
call calculate(graph,k,absk, &
               qs,qsigns,maptypes,nmaps,value,maxpart,valuechk)
!
write(nout,707)value*groupsizetotal, abs(value)*groupsizetotal, &
               maxpart*groupsizetotal
707   format('valuept =',2(1p g12.4),' abs(valuept) = ',1p g12.4,/, &
       'biggest contribution was ',1p g12.4)
RETURN
END subroutine diagnostic
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!                              Shower Subroutines
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine softradiate(theshower)
!
use beowulf_helpers
implicit none
! Define input and output structure, theshower
type parton
  character(len=5) :: flavor   ! quark, qbar, gluon
  integer :: self              ! index of this parton
  integer :: parent            ! index of parton's parent
  integer :: ancestor          ! starting parton
  integer :: child1            ! index of parton's first daughter
  integer :: child2            ! index of parton's second daughter
  logical :: childless         ! no children (yet)
  logical :: done              ! .true. means don't split this parton
  real(kind=dbl), dimension(3) :: momentum
  real(kind=dbl) :: kappasq
end type parton
!
type showerlist
  integer :: length            ! length of the shower list
  real(kind=dbl) :: rts0       ! sqrt(s) of the starting graph
  real(kind=dbl) :: onemthrust ! 1 - thrust of the starting graph
  real(kind=dbl) :: msoftsq    ! the soft scale
  real(kind=dbl) :: multfactor ! factor to multiply |matrix element|^2
  integer :: pii,pjj           ! partons emitting and absorbing soft gluon
  type(parton), dimension(maxparticles) :: ptn
end type showerlist
! In and Out:
type(showerlist) :: theshower
!
! Starting with three final state partons from a Born graph, this subroutine
! radiates one soft gluon and adds it to the shower. It also adjusts the
! momenta of the emitting and absorbing parton by half of the soft gluon
! momentum so that the momenta still sum to zero and it calculates the
! factor by which the |matrix element|^2 should be multiplied to account
! for the soft gluon emission. The indices pii and pjj of the partons that
! emit and absorb the soft gluon are also recorded for use in calculating
! the |matrix element|^2.
!
! 5 April 2003
! 16 June 2003
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl) :: muoverrts
common /renormalize/ muoverrts
real(kind=dbl) :: alphasofmz,mz,externalrts
common /physicsdata/ alphasofmz,mz,externalrts
logical :: dosoft
common /softswitch/ dosoft
integer :: mu,n,i,j,ii,jj,kk
real(kind=dbl) :: musq,alpival,alpi
integer :: ptnindex(3)
real(kind=dbl) :: qsq,absq,q(3,3),qhat(3,3)
real(kind=dbl) :: cosqq(3,3)
real(kind=dbl) :: random,x
real(kind=dbl) :: costheta,phi
real(kind=dbl) :: ea(3),eb(3),ec(3)
real(kind=dbl) :: lhat(3)
real(kind=dbl) :: norm
real(kind=dbl) :: coslq(3)
real(kind=dbl) :: colorfactor,fijk,density,softintegral
real(kind=dbl) :: lsq,labs,l(3)
real(kind=dbl) :: sinhinv
real(kind=dbl) :: y,y0,x0
!
! For testing,
integer,save :: count=0
real(kind=dbl),save :: test=0.0d0
!
! We need alpha_s/pi
!
musq = (muoverrts*theshower%rts0)**2
alpival = alpi(muoverrts*externalrts)
!
! Find which parton is which.
!
IF (theshower%length.NE.3) THEN
  write(nout,*)'Oops, softradiate called wrongly.'
  stop
END IF
DO n = 1,3
  IF (theshower%ptn(n)%flavor.EQ.'quark') THEN
    ptnindex(1) = n
  ELSE IF (theshower%ptn(n)%flavor.EQ.'gluon') THEN
    ptnindex(2) = n
  ELSE IF (theshower%ptn(n)%flavor.EQ.'qbar ') THEN
    ptnindex(3) = n
  ELSE
    write(nout,*)'Flavor not found in softradiate.'
    stop
  END IF
END DO
!
! Define momenta q, unit vectors qhat, and their dot products.
!
DO n = 1,3
  qsq = 0.0d0
  DO mu = 1,3
    q(n,mu) = theshower%ptn(ptnindex(n))%momentum(mu)
    qsq = qsq + q(n,mu)**2
  END DO
  absq = sqrt(qsq)
  DO mu = 1,3
    qhat(n,mu) = q(n,mu)/absq
  END DO
END DO
DO i = 1,2
DO j = i+1,3
  cosqq(i,j) = 0.0d0
  DO mu = 1,3
    cosqq(i,j) = cosqq(i,j) + qhat(i,mu)*qhat(j,mu)
  END DO
  cosqq(j,i) = cosqq(i,j)
END DO
END DO
cosqq(1,1) = 1.0d0
cosqq(2,2) = 1.0d0
cosqq(3,3) = 1.0d0
!
! Choose emitting (ii) and absorbing (jj) partons at random.
!
x = random(1)
IF (x.LT.0.111111111111111111d0) THEN
  ii = 1
  jj = 2
ELSE IF (x.LT.0.222222222222222222d0) THEN
  ii = 2
  jj = 1
ELSE IF (x.LT.0.333333333333333333d0) THEN
  ii = 2
  jj = 3
ELSE IF (x.LT.0.444444444444444444d0) THEN
  ii = 3
  jj = 2
ELSE IF (x.LT.0.555555555555555556d0) THEN
  ii = 3
  jj = 1
ELSE IF (x.LT.0.666666666666666667d0) THEN
  ii = 1
  jj = 3
ELSE IF (x.LT.0.777777777777777778d0) THEN
  ii = 1
  jj = 1
ELSE IF (x.LT.0.888888888888888889d0) THEN
  ii = 2
  jj = 2
ELSE
  ii = 3
  jj = 3
END IF
!
! We want to choose lhat(mu).
! There are two cases: first is for the interference terms, with
! emittingparton.ne.absorbingparton; then the second is for
! emittingparton.eq.absorbingparton.
!
IF (ii.NE.jj) THEN
!
! Choose theta and phi, uniformly in phi, but with a density
! d N/d costheta = 1/[4 sqrt(y0) arcsinh(sqrt(1/y0))]/sqrt(y)/sqrt(1+y/y0)
! where y = (1 - costheta)/2 and we take y0 = (1 - cosqq(i,j))/8.
!
x = random(1)
y0 = (1 - cosqq(ii,jj))/8.0d0
x0 = 1/sinhinv(sqrt(1/y0))
y = y0*sinh(x/x0)**2
costheta = 1.0d0 - 2.0d0 * y
x = random(1)
phi = 2.0d0*pi*x
!
! Generate lhat with a distribution in theta and phi as above,
! where theta is the angle between lhat and either the emitting parton
! direction (with probability 1/2) or the absorbing parton direction
! (with probability 1/2).
!
x = random(1)
IF (x.LT.0.5d0) THEN
  DO mu = 1,3
    ea(mu) = qhat(ii,mu)
  END DO
ELSE
  DO mu = 1,3
    ea(mu) = qhat(jj,mu)
  END DO
END IF
!
call axes(ea,eb,ec)
DO mu = 1,3
  lhat(mu) = costheta*ea(mu) &
            + sqrt(1.0d0 - costheta**2)*(cos(phi)*eb(mu) + sin(phi)*ec(mu))
END DO
!
ELSE   ! ii.EQ.jj
!
x = random(1)
IF (x.lt.0.5d0) THEN
  kk = mod(ii,3) + 1      ! 1 -> 2, 2 -> 3, 3 -> 1
ELSE
  kk = mod(ii + 1,3) + 1  ! 1 -> 3, 2 -> 1, 3 -> 2
END IF
!
! Choose theta and phi, uniformly in phi, but with a density
! d N/d costheta = 1/(1 - costheta)/log(2/(1-costhetamax))
!
norm = log( 2.0d0/(1.0d0 - cosqq(ii,kk)) )
x = random(1)
costheta = 1.0d0 - 2.0d0*exp(-norm*x)
x = random(1)
phi = 2.0d0*pi*x
DO mu = 1,3
  ea(mu) = qhat(ii,mu)
END DO
call axes(ea,eb,ec)
DO mu = 1,3
  lhat(mu) = costheta*ea(mu) &
          + sqrt(1.0d0 - costheta**2)*(cos(phi)*eb(mu) + sin(phi)*ec(mu))
END DO
!
END IF  ! (ii.NE.jj)...ELSE...
!
! We have chosen lhat(mu). Now calculate fijk. (This is called F_{ij} in 
! the notes, but for j=i there are two terms depending on another index
! called a there and k here. Each term is then denoted fijk here.
!
DO i = 1,3
  coslq(i) = 0.0d0
  DO mu = 1,3
    coslq(i) = coslq(i) + lhat(mu)*qhat(i,mu)
  END DO
END DO
!
IF (ii.NE.jj) THEN
!
IF ((ii.EQ.2).OR.(jj.EQ.2)) THEN
  colorfactor = - 0.5d0*nc
ELSE
  colorfactor = 0.5d0/nc
END IF
fijk = colorfactor*(cosqq(ii,jj) - coslq(ii)*coslq(jj))  &
        /(1.0d0 - coslq(ii))/(1.0d0 - coslq(jj))
!
ELSE   ! ii.EQ.jj
!
IF ((ii.EQ.2).OR.(kk.EQ.2)) THEN
  colorfactor = 0.5d0*nc
ELSE
  colorfactor = - 0.5d0/nc
END IF
fijk = colorfactor*(1.0d0 + coslq(ii))/(1.0d0 - coslq(ii))
!
END IF   ! (ii.NE.jj)...ELSE...
!
! We have chosen points hatl(mu). Now we need the density of points
! in {lhat,ii,jj,kk}. Recall that x0 = 1/sinhinv(sqrt(1/y0))
! and y0 = (1 - cosqq(ii,jj))/8.0d0 for ii.ne.jj or
! norm = log( 2.0d0/(1.0d0 - cosqq(ii,kk)) ) for ii.eq.jj.
!
IF (ii.ne.jj) THEN
  y = 0.5d0*(1.0d0 - coslq(ii))
  IF (y.GT.0.0d0) THEN
    density =  1.0d0/sqrt(y)/sqrt(1.0d0 + y/y0)
  ELSE
    density = 1.0d8  ! In case coslq(ii) = 1.
  END IF
  y = 0.5d0*(1.0d0 - coslq(jj))
  IF (y.GT.0.0d0) THEN
    density =  density + 1.0d0/sqrt(y)/sqrt(1.0d0 + y/y0)
  ELSE
    density = 1.0d8  ! In case coslq(jj) = 1.
  END IF
  density = density*x0/sqrt(y0)/16.0d0/pi
! This includes 1/(2 pi) for the phi integral and 1/2 for the
! random choice of alignment with qii or qjj.
ELSE   ! ii.eq.jj
  IF (coslq(ii).LT.1.0d0) THEN
    density = 1.0d0/(1.0d0 - coslq(ii))/norm
  ELSE
    density = 1.0d15
  END IF
  density = density/2.0d0/pi  ! 1/(2 pi) for the phi integral
  density = density/2.0d0     ! For the random choice of k
END IF
density = density/9.0d0   ! For random choice of i,j
!
! Calculate the soft angular integral,
! \sum_{ij} \int d^2\hat l/(4\pi) F_{ij}(\hat l,\hat q_1,\hat q_2,\hat q_2)
! = (nc/2)(1 - \hat q_1\cdot \hatq_2) + (nc/2)(1 - \hat q_3\cdot \hatq_2)
!   - (1/2/nc)(1 - \hat q_1\cdot \hatq_3)
!
softintegral =   0.5d0*nc*(2.0d0 - cosqq(1,2) - cosqq(2,3)) &
               - 0.5d0/nc*(1.0d0 - cosqq(1,3))
!
! We now have lhat and the density of points lhat. We need the absolute
! value of l.
!
x = random(1)
lsq = theshower%msoftsq*x**(2.0d0/alpival/softintegral)
labs = sqrt(lsq)
!
! If the switch dosoft is false, we should undo our good work. We do,
! however, put parton 4 on our list since other parts of beowulf
! assume that it is there. Setting labs to zero results in no shift
! in the momenta of partons 1,2,3 and in the momentum of the 'soft'
! parton 4 being zero.
!
IF (.NOT.dosoft) THEN
  labs = 0.0d0
END IF
!
! We form l(mu) and adjust the final state parton momenta.
!
DO mu = 1,3
  l(mu) = labs*lhat(mu)
  theshower%ptn(ptnindex(ii))%momentum(mu) = &
     theshower%ptn(ptnindex(ii))%momentum(mu) - 0.5d0*l(mu)
  theshower%ptn(ptnindex(jj))%momentum(mu) = &
     theshower%ptn(ptnindex(jj))%momentum(mu) - 0.5d0*l(mu)
END DO
!
! Finally, we record the original parton labels corresponding
! to ii and jj, we record the factor that will multiply 
! the Born graph, which is fijk/(4 Pi * softintegral)/density,
! and we add the soft gluon to the shower.
!
theshower%multfactor = fijk/4.0d0/pi/softintegral/density
theshower%pii = ptnindex(ii)
theshower%pjj = ptnindex(jj)
theshower%length = 4
theshower%ptn(4)%flavor = 'gluon'
theshower%ptn(4)%self = 4
theshower%ptn(4)%parent = 0
theshower%ptn(4)%ancestor = 4
theshower%ptn(4)%child1 = -1
theshower%ptn(4)%child2 = -1
theshower%ptn(4)%childless = .true.
theshower%ptn(4)%done = .false.
DO mu = 1,3
  theshower%ptn(4)%momentum(mu) = l(mu)
END DO
theshower%ptn(4)%kappasq = lsq * theshower%onemthrust
!
! If the switch dosoft is false, we should undo our good work. We leave
! parton 4 on our list, but we just multiply the graph by 1.0 and set
! parton 4 not to shower. It has zero momentum.
!
IF (.NOT.dosoft) THEN
  theshower%multfactor = 1.0d0
  theshower%ptn(4)%done = .true.
END IF
!
! Uncomment this if you want to see if the soft integration works.
! count = count + 1
! test = test + fijk/4.0d0/pi/softintegral/density
! IF (mod(count,10000).EQ.0) THEN
!   write(nout,*)'For count = ',count,'soft test integral = ',test/count
! END IF 
!
end subroutine softradiate
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine makeshowerI(theshower,softinfos)
!
use beowulf_helpers
implicit none
! Define structures parton, showerlist, softinformation
type parton
  character(len=5) :: flavor   ! quark, qbar, gluon
  integer :: self              ! index of this parton
  integer :: parent            ! index of parton's parent
  integer :: ancestor          ! starting parton
  integer :: child1            ! index of parton's first daughter
  integer :: child2            ! index of parton's second daughter
  logical :: childless         ! no children (yet)
  logical :: done              ! .true. means don't split this parton
  real(kind=dbl), dimension(3) :: momentum
  real(kind=dbl) :: kappasq
end type parton
!
type showerlist
  integer :: length            ! length of the shower list
  real(kind=dbl) :: rts0       ! sqrt(s) of the starting graph
  real(kind=dbl) :: onemthrust ! 1 - thrust of the starting graph
  real(kind=dbl) :: msoftsq    ! the soft scale
  real(kind=dbl) :: multfactor ! factor to multiply |matrix element|^2
  integer :: pii,pjj           ! partons emitting and absorbing soft gluon
  type(parton), dimension(maxparticles) :: ptn
end type showerlist
!
type softinformation
  character(len=5) :: flavor0   ! quark, qbar, gluon
  character(len=5) :: flavor1   ! quark, qbar, gluon
  character(len=5) :: flavor2   ! quark, qbar, gluon
  real(kind=dbl) :: cos1
  real(kind=dbl) :: cos2
  real(kind=dbl) :: msoftsq
end type softinformation
!
! In:
type(softinformation), dimension(3) :: softinfos
! In and Out:
type(showerlist) :: theshower
!
! This subroutine creates the beginnings of a shower starting from three 
! hard partons emerging from a Born graph, whose parton information is 
! initially found in 'theshower'. (One soft gluon has also been created
! by subroutine softradiate, but is not touched here.) Each hard parton
! splits once, with the subroutine splitI, which is based on the exact 
! one loop self-energy function in Coulomb gauge.
!
! Note:
! theshower%multfactor is divided by the densities of points {qbarsq,x,phi}
! for each splitting in the first level splittings from a Born graph.
! The Sudakov factor is not included, nor are 1/qbarsq/(2 pi).
!
! 10 November 2002
! 13 March 2003
!
integer :: n,currentN
type(parton) :: mother,daughter1,daughter2
real(kind=dbl) :: splitdensityval
!
DO n = 1,3
  mother = theshower%ptn(n)
  currentN = theshower%length
  call splitI(currentN,theshower%rts0,mother,softinfos(n), &
              daughter1,daughter2,splitdensityval)
  theshower%ptn(n) = mother               !mother has been modified
  theshower%ptn(currentN + 1) = daughter1
  theshower%ptn(currentN + 2) = daughter2
  theshower%length = currentN + 2
  theshower%multfactor = theshower%multfactor/splitdensityval
END DO
!
END subroutine makeshowerI
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine splitI(currentN,rts0,mother,softinfo,   &
                  daughter1,daughter2,splitdensityval)
!
use beowulf_helpers
implicit none
! Define structures parton and softinformation.
type parton
  character(len=5) :: flavor   ! quark, qbar, gluon
  integer :: self              ! index of this parton
  integer :: parent            ! index of parton's parent
  integer :: ancestor          ! starting parton
  integer :: child1            ! index of parton's first daughter
  integer :: child2            ! index of parton's second daughter
  logical :: childless         ! no children (yet)
  logical :: done              ! .true. means don't split this parton
  real(kind=dbl), dimension(3) :: momentum
  real(kind=dbl) :: kappasq
end type parton
!
type softinformation
  character(len=5) :: flavor0   ! quark, qbar, gluon
  character(len=5) :: flavor1   ! quark, qbar, gluon
  character(len=5) :: flavor2   ! quark, qbar, gluon
  real(kind=dbl) :: cos1
  real(kind=dbl) :: cos2
  real(kind=dbl) :: msoftsq
end type softinformation
! In:
integer :: currentN
real(kind=dbl) :: rts0
type(parton) :: mother
type(softinformation) :: softinfo
! Out:
type(parton) :: daughter1, daughter2
real(kind=dbl) :: splitdensityval
!
! This subroutine 'splits' a mother parton into two daughters
! using the exact one-loop self-energy function in Coulomb gauge
! minus a soft gluon subtraction that removes soft wide angle splitting.
! That is, given the information stored in 'mother', it creates
! information for 'daughter1' and 'daughter2' according to
! this probability distribution.
!
! 28 October 2002
! 22 May 2003
!
! Physics data:
real(kind=dbl) :: alphasofmz,mz,externalrts
common /physicsdata/ alphasofmz,mz,externalrts
! Color factors:
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
real(kind=dbl), parameter :: tiny = 1.0d-10
logical, save :: writetinymessage = .true.
!
! For diagnosis:
logical :: showercheck
common /showercheckinfo/ showercheck
integer :: count
integer,save :: countg = 0, countq = 0, countgg = 0, countgq = 0
real(kind=dbl),save :: testgg=0.0d0, testgq=0.0d0, testq=0.0d0
real(kind=dbl),save :: triesgg=0.0d0,triesgq=0.0d0,triesq=0.0d0
!
integer :: mu
real(kind=dbl) :: qbarsq,x,phi
character(len=5) :: flavor0,flavor1,flavor2
real(kind=dbl) :: random,r,fraction
real(kind=dbl) :: calqsq,calq
real(kind=dbl), dimension(3) :: nx,ny,nz,ell
real(kind=dbl) :: lt,lq,cosphi,sinphi,calQ1,calQ2
real(kind=dbl) :: approxcalpval,approxcalp,truecalpval,truecalp
real(kind=dbl) :: splitdensity0
real(kind=dbl) :: pbarsqinv
!
! Start by supplying straightforward information.
!
daughter1%self = currentN + 1
daughter2%self = currentN + 2
daughter1%parent = mother%self
daughter2%parent = mother%self
daughter1%ancestor = mother%ancestor
daughter2%ancestor = mother%ancestor
daughter1%child1 = -1
daughter2%child1 = -1
daughter1%child2 = -1
daughter2%child2 = -1
mother%child1 = daughter1%self
mother%child2 = daughter2%self
mother%childless = .false.
daughter1%childless = .true.
daughter2%childless = .true.
daughter1%done = .false.
daughter2%done = .false.
!
! The momentum scale is provided by {\cal Q}, the absolute value of the
! mother parton's momentum.
!
calqsq = 0.0d0
DO mu = 1,3
  calqsq = calqsq + mother%momentum(mu)**2
END DO
calq = sqrt(calqsq)
!
! Now, we generage qbarsq. getqbarsq0 gives a qbarsq according to the
! distribution approxcalp. We  keep the selected point with probability 
! truecalp/approxcalp.
!
flavor0 = mother%flavor
pbarsqinv = 0.0d0
count = 1
DO
  call getqbarsq0(rts0,calqsq,pbarsqinv,flavor0,qbarsq)
  IF (qbarsq/calqsq .LT. tiny) THEN
    IF (writetinymessage) THEN
      write(nout,*)'Primary splitting in splitI aborted because of'
      write(nout,*)'small qbarsq/calqsq,',qbarsq/calqsq
      write(nout,*)'Further such messages will be suppressed.'
      writetinymessage = .false.
    END IF
    qbarsq = tiny * calqsq
    exit
  END IF
  approxcalpval = approxcalp(rts0,calqsq,flavor0,qbarsq)
  truecalpval = truecalp(rts0,calqsq,flavor0,softinfo,qbarsq)
  fraction = truecalpval/approxcalpval
  IF (fraction.GT.1.0d0) THEN
      write(nout,*)'Oops, truecalp > approxcalp in splitI.'
      write(nout,*)'truecalp = ',truecalpval,' approxcalp =',approxcalpval
      write(nout,*)'truecalp/approxcalp = ',fraction
      write(nout,*)'mother parton flavor was ',mother%flavor
      write(nout,*)'rts0sq = ',rts0**2,'calQsq =',calqsq,' qbarsq',qbarsq
      write(nout,*)'sister1 is ',softinfo%flavor1, &
                   ' with cos1 = ',softinfo%cos1
      write(nout,*)'sister2 is ',softinfo%flavor2, &
                   ' with cos2 = ',softinfo%cos2
      write(nout,*)'soft scale is msoftsq =',softinfo%msoftsq
      STOP
  END IF
  IF (fraction.LT.0.0d0) THEN
      write(nout,*)'Oops, c was supposed to positive.', qbarsq
      STOP
  END IF
  r = random(1)
  IF (fraction .GT. r) EXIT
  pbarsqinv = 1/qbarsq
  count = count + 1
END DO
!
! We have qbarsq, but we need flavors, x, and phi.
!
call getflavorxphi0(qbarsq,calqsq,flavor0,x,phi,flavor1,flavor2)
!
! Also, we need the density of points, excluding the Sudakov factor.
!
splitdensityval = &
     splitdensity0(qbarsq,x,phi,flavor0,flavor1,flavor2,rts0,calqsq,softinfo)
!
!------------------------------------
! We use {qbarsq, x, phi} to generate the daughter momenta and
! the value of kappasq to be used later for splitting the daughters.
!
! First we calculate the unit vectors n_x, n_y, n_z used to define
! the orientation of the elliptical coordinate system. 
!
DO mu = 1,3
  nz(mu) = mother%momentum(mu)/calq
END DO
call axes(nz,ny,nx)
!
! Now we find l(mu).
!
lt = sqrt(x*(1.0d0 - x)*qbarsq)
lq = 0.5d0*calq*sqrt(1.0d0 + qbarsq/calqsq)*(2.0d0*x - 1.0d0)
cosphi = cos(phi)
sinphi = sin(phi)
DO mu = 1,3
 ell(mu) = lt*cosphi*nx(mu) + lt*sinphi*ny(mu) + lq*nz(mu)
END DO
!
! This gives the daughter flavor, momenta and kappasq values.
!
daughter1%flavor = flavor1
daughter2%flavor = flavor2
DO mu = 1,3
  daughter1%momentum(mu) = 0.5d0*mother%momentum(mu) + ell(mu)
  daughter2%momentum(mu) = 0.5d0*mother%momentum(mu) - ell(mu)
END DO
calQ1 = sqrt((0.5d0*calQ + lq)**2 + lt**2)
calQ2 = sqrt((0.5d0*calQ - lq)**2 + lt**2)
daughter1%kappasq = min(x*qbarsq/(1.0d0 - x),calQ1**2,mother%kappasq)
daughter2%kappasq = min((1.0d0-x)*qbarsq/x,calQ2**2,mother%kappasq)
!
!------------------------------------
!
! Diagnostics
!
IF (showercheck) THEN
  IF (flavor0.EQ.'gluon') THEN
    countg = countg + 1
    IF (flavor1.EQ.'gluon') THEN
      countgg = countgg + 1
      testgg = testgg + truecalpval/splitdensityval
      triesgg = triesgg + count
    ELSE
      countgq = countgq + 1
      testgq = testgq + truecalpval/splitdensityval
      triesgq = triesgq + count
    END IF
  ELSE
    countq = countq + 1
    testq = testq + truecalpval/splitdensityval
    triesq = triesq + count
  END IF
  IF (mod(countg+countq,10000).EQ.0) THEN
    write(nout,*)'For count gg = ',countgg, &
                 'collinear test integral gg = ',testgg/countg
    write(nout,*)'For count gq = ',countgq, &
                 'collinear test integral gq = ',testgq/countg
    write(nout,*)'For countq = ',countq, &
                 'collinear test integral q = ',testq/countq
    write(nout,*)'Average numbers of tries are', &
                  triesgg/countgg,triesgq/countgq,triesq/countq
  END IF 
END IF ! showercheck
!
END subroutine splitI
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine getqbarsq0(rts0,calqsq,pbarsqinv,flavor0,qbarsq)
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: rts0,calqsq,pbarsqinv
character(len=5) :: flavor0             ! quark, qbar, gluon
! Out:
real(kind=dbl) :: qbarsq
!
! Produces qbarsq distributed according to a simple function approxc0(qbarsq):
!
! density = approxc0(qbarsq)
!            x exp[ - int_qbarsq^pbarsq d lbarsq  approxc0(lbarsq) ]
!           d qbarsq
! where
!
! approxc0(qbarsq) = alpha_s/(2 Pi)/qbarsq * approxcalP(qbarsq)
!
! The subroutine getqbarsq0 matches the function approxcalP.
! 19 October 2002
! 22 March 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl) :: muoverrts
common /renormalize/ muoverrts
real(kind=dbl) :: alphasofmz,mz,externalrts
common /physicsdata/ alphasofmz,mz,externalrts
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
real(kind=dbl) :: random,r
real(kind=dbl) :: b,musq,musqmod,alpi,alpival,colorfactor
real(kind=dbl) :: ip,iq,temp,root,thelog
!
!---
!
musq = (muoverrts*rts0)**2
musqmod = min(musq,calqsq)
alpival = alpi(muoverrts*externalrts)
!
IF (flavor0.EQ.'gluon') THEN
  b = 6.0d0*nc*calqsq/5.0d0
  b = b + (2.0d0*nf - 3.0d0*nc)*musqmod/18.0d0*(8.0d0 + 3.0d0*log(musq/musqmod))
  b = 1.1d0*b  ! This makes approxcalP just a little bigger.
  colorfactor = nc
ELSE IF ((flavor0.EQ.'quark').OR.(flavor0.EQ.'qbar ')) THEN   
  b = 22.0d0*cf*calqsq/15.0d0
  b = b + cf*musqmod/6.0d0*(4.0d0 + 3.0d0*log(musq/musqmod))
  b = 1.1d0*b  ! This makes approxcalP just a little bigger.
  colorfactor = cf
ELSE
  write(nout,*)'Unknown flavor in getqbarsq0.'
  stop
END IF
IF (musqmod*pbarsqinv.GT.1.0d0) THEN
  temp = log(musqmod*pbarsqinv)
  ip = colorfactor*temp**2 + b/musqmod*(temp + 1)
ELSE
  ip = b*pbarsqinv
END IF
r = random(1)
iq = ip + log(1/r)*2.0d0/alpival
IF (iq.LT.b/musqmod) THEN
  qbarsq = b/iq
ELSE
  temp = b/musqmod
  root = sqrt(temp**2 + 4.0d0*colorfactor*(iq - temp))
  thelog = (root - temp)/2.0d0/colorfactor
  qbarsq = musqmod*exp(-thelog)
END IF
!
END subroutine getqbarsq0
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function approxcalp(rts0,calqsq,flavor0,qbarsq)
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: rts0,calqsq
character(len=5) :: flavor0             ! quark, qbar, gluon
real(kind=dbl) :: qbarsq
! Out:
real(kind=dbl) :: approxcalp
!
! The function approxcalP(qbarsq) used for approximate splitting:
!
! density = approxc0(qbarsq)
!            x exp[ - int_qbarsq^pbarsq d lbarsq  approxc0(lbarsq) ]
!           d qbarsq
!
! where
!
! approxc0(qbarsq) = alpha_s/(2 Pi)/qbarsq * approxcalP(qbarsq)
!
! The function approxcalP(qbarsq) matches getqbarsq0.
! 22 March 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl) :: muoverrts
common /renormalize/ muoverrts
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
real(kind=dbl) :: musq,musqmod
real(kind=dbl) :: b,colorfactor
!
musq = (muoverrts*rts0)**2
musqmod = min(musq,calqsq)
!
IF (flavor0.EQ.'gluon') THEN
  b = 6.0d0*nc*calqsq/5.0d0
  b = b + (2.0d0*nf - 3.0d0*nc)*musqmod/18.0d0*(8.0d0 + 3.0d0*log(musq/musqmod))
  b = 1.1d0*b  ! This makes approxcalP just a little bigger.
  colorfactor = nc
ELSE IF ((flavor0.EQ.'quark').OR.(flavor0.EQ.'qbar ')) THEN   
  b = 22.0d0*cf*calqsq/15.0d0
  b = b + cf*musqmod/6.0d0*(4.0d0 + 3.0d0*log(musq/musqmod))
  b = 1.1d0*b  ! This makes approxcalP just a little bigger.
  colorfactor = cf
ELSE
  write(nout,*)'Unknown flavor in approxcalp.'
  stop
END IF
IF (qbarsq.LT.musqmod) THEN
  approxcalp = 2.0d0*colorfactor*log(musqmod/qbarsq) + b/musqmod
ELSE
  approxcalp = b/qbarsq
END IF
!
END function approxcalp
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function truecalp(rts0,calqsq,flavor0,softinfo,qbarsq)
use beowulf_helpers
implicit none
! Define type softinformation
type softinformation
  character(len=5) :: flavor0   ! quark, qbar, gluon
  character(len=5) :: flavor1   ! quark, qbar, gluon
  character(len=5) :: flavor2   ! quark, qbar, gluon
  real(kind=dbl) :: cos1
  real(kind=dbl) :: cos2
  real(kind=dbl) :: msoftsq
end type softinformation
! In:
real(kind=dbl) :: rts0,calqsq
character(len=5) :: flavor0             ! quark, qbar, gluon
real(kind=dbl) :: qbarsq
type(softinformation) :: softinfo
! Out:
real(kind=dbl) :: truecalp
!
! The function truecalP(qbarsq) used for Born level splitting:
!
! density = truec0(qbarsq)
!            x exp[ - int_qbarsq^pbarsq d lbarsq  truec0(lbarsq) ]
!           d qbarsq
!
! where
!
! truec0(qbarsq) = alpha_s/(2 Pi)/qbarsq * truecalP(qbarsq)
! 19 October 2002
! 24 June 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl) :: muoverrts
common /renormalize/ muoverrts
logical :: dosoft
common /softswitch/ dosoft
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
real(kind=dbl) :: musq,musqmod,qoq,qom,denomm,denomq,thelog
real(kind=dbl) :: temp
real(kind=dbl) :: delta,sqrtm1,xmax,isoft,xmaxsoft
real(kind=dbl) :: colorfactor1,colorfactor2
real(kind=dbl) :: softp1,softp2
!
musq = (muoverrts*rts0)**2
musqmod = min(musq,calqsq)
qoq = qbarsq/calqsq
qom = qbarsq/musqmod
denomm = 1.0d0 + qom
denomq = 1.0d0 + qoq
thelog = log( (sqrt(denomq) + 1.0d0)/(sqrt(denomq) - 1.0d0) )
!
IF (flavor0.EQ.'gluon') THEN
  IF (qoq.LT.1.0d2) THEN
    temp = (2.0d0*nf - 3.0d0*nc)
    temp = temp*(3.0d0 + 8.0d0*qom + 3.0d0*qom*log(musq/musqmod))
    temp = temp/18.0d0/denomm**2
    truecalp = temp
    temp = nc*(5.0d0 + 2.0d0*qoq)*(4.0d0 + 3.0d0*qoq)
    temp = temp/6.0d0/denomq
    truecalp = truecalp - temp
    temp = nc*(2.0d0 + qoq)*(4.0d0 + 5.0d0*qoq + 2.0d0*qoq**2)*thelog
    temp = temp/4.0d0/denomq**1.5d0
    truecalp = truecalp + temp
  ELSE  ! We need an expansion in powers of 1/q0q.
    temp = (2.0d0*nf - 3.0d0*nc)
    temp = temp*(3.0d0 + 8.0d0*qom + 3.0d0*qom*log(musq/musqmod))
    temp = temp/18.0d0/denomm**2
    truecalp = temp
    temp = nc*(6.0d0/5.0d0/qoq + 8.0d0/105.0d0/qoq**2 &
          - 208.0d0/315.0d0/qoq**3 + 1216.0d0/1155.0d0/qoq**4 &
          - 61184.0d0/45045.0d0/qoq**5 + 72704.0d0/45045.0d0/qoq**6)
    truecalp = truecalp + temp
  END IF
  IF (dosoft) THEN             ! Do soft subtraction (if delta is in range).
    delta = sqrtm1(qbarsq/calqsq)       ! sqrtm1(x) = sqrt(1 + x) - 1
    xmaxsoft = sqrt(softinfo%msoftsq/calqsq) - 0.5d0*delta
    IF (xmaxsoft.GT.0.0d0) THEN
      colorfactor1 = 0.5d0*nc
      colorfactor2 = 0.5d0*nc
      xmax = 0.5d0*delta*(1.0d0 + softinfo%cos1)/(1.0d0 + delta - softinfo%cos1)
      xmax = min(xmax,xmaxsoft)
      softp1 = colorfactor1/(1.0d0 + delta)  &  ! first subtraction term
             *isoft(xmax,delta)       
      xmax = 0.5d0*delta*(1.0d0 + softinfo%cos2)/(1.0d0 + delta - softinfo%cos2)
      xmax = min(xmax,xmaxsoft)
      softp2 = colorfactor2/(1.0d0 + delta)  &  ! second subtraction term
             *isoft(xmax,delta)
      truecalp = truecalp - softp1 - softp2    
    END IF  ! xmaxsoft > 0
  END IF  ! dosoft
ELSE IF ((flavor0.EQ.'quark').OR.(flavor0.EQ.'qbar ')) THEN
  IF (qoq.LT.1.0d2) THEN
    temp = cf*(3.0d0 + 4.0d0*qom + 3.0d0*qom*log(musq/musqmod))
    temp = temp/6.0d0/denomm**2
    truecalp = temp
    temp = 0.5d0*cf*(8.0d0 + 3.0d0*qoq)
    truecalp = truecalp - temp
    temp = cf*(2.0d0 + qoq)*(4.0d0 + 3.0d0*qoq)*thelog
    temp = temp/4.0d0/denomq**0.5d0
    truecalp = truecalp + temp
  ELSE  ! We need an expansion in powers of 1/q0q.
    temp = cf*(3.0d0 + 4.0d0*qom + 3.0d0*qom*log(musq/musqmod))
    temp = temp/6.0d0/denomm**2
    truecalp = temp
    temp = cf*(22.0d0/15.0d0/qoq - 24.0d0/35.0d0/qoq**2 &
           + 16.0d0/35.0d0/qoq**3 - 1216.0d0/3465.0d0/qoq**4 &
           + 4352.0d0/15015.0d0/qoq**5 - 1024.0d0/4095.0d0/qoq**6)
    truecalp = truecalp + temp
  END IF
  IF (dosoft) THEN                   ! Do soft subtraction.
    delta = sqrtm1(qbarsq/calqsq)       ! sqrtm1(x) = sqrt(1 + x) - 1
    xmaxsoft = sqrt(softinfo%msoftsq/calqsq) - 0.5d0*delta
    IF (xmaxsoft.GT.0.0d0) THEN
      IF (softinfo%flavor1.EQ.'gluon') then
        colorfactor1 = 0.5d0*nc
        colorfactor2 = - 0.5d0/nc
      ELSE IF (softinfo%flavor2.EQ.'gluon') then
        colorfactor2 = 0.5d0*nc
        colorfactor1 = - 0.5d0/nc
      ELSE
        write(nout,*)'Flavors messed up in truecalp.'
        STOP
      END IF
      xmax = 0.5d0*delta*(1.0d0 + softinfo%cos1)/(1.0d0 + delta - softinfo%cos1)
      xmax = min(xmax,xmaxsoft)
      softp1 = colorfactor1/(1.0d0 + delta)  &  ! first subtraction term
             *isoft(xmax,delta)       
      xmax = 0.5d0*delta*(1.0d0 + softinfo%cos2)/(1.0d0 + delta - softinfo%cos2)
      xmax = min(xmax,xmaxsoft)
      softp2 = colorfactor2/(1.0d0 + delta)  &  ! second subtraction term
             *isoft(xmax,delta)
      truecalp = truecalp - softp1 - softp2    
    END IF  ! xmaxsoft > 0
  END IF  ! dosoft
ELSE
  write(nout,*)'Unknown flavor in truecalp.'
  stop
END IF
IF (truecalp.LT.0.0d0) THEN
  write(nout,*)'Houston, we have a problem.'
  write(nout,*)'plaincalp = ',truecalp+softp1+softp2
  write(nout,*)'   softp1 = ',softp1
  write(nout,*)'   softp2 = ',softp2
  write(nout,*)' truecalp = ',truecalp,' for'
  write(nout,*)'qbarsq = ',qbarsq,'  with'
  write(nout,*)'            rts0 = ',rts0
  write(nout,*)'          calqsq = ',calqsq
  write(nout,*)'         flavor0 = ',flavor0
  write(nout,*)'softinfo%flavor0 = ',softinfo%flavor0
  write(nout,*)'softinfo%flavor1 = ',softinfo%flavor1
  write(nout,*)'softinfo%flavor2 = ',softinfo%flavor2
  write(nout,*)'   softinfo%cos1 = ',softinfo%cos1
  write(nout,*)'   softinfo%cos2 = ',softinfo%cos2
  write(nout,*)'softinfo%msoftsq = ',softinfo%msoftsq
  stop
END IF
!
END function truecalp
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function isoft(xmax,delta)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: xmax,delta
! Out:
real(kind=dbl) :: isoft
!
! The integral over x of P_i^{soft}(x, qbarsq) is the sum over a = 1,2,3
! not a = i of color factors -c_{ia} times this integral, with choices
! x^a_{max} for the maximum x in the integral.
!
! 18 March 2003
! 14 June 2003
!
real(kind=dbl) :: b
real(kind=dbl) :: c1,c2,c3
real(kind=dbl) :: f1,f2,f3
real(kind=dbl) :: y,dy
real(kind=dbl) :: log1px
!
b = 2.0d0 + delta
!
c1 = 2.0d0
c2 = - 2.0d0
c3 = b*delta
!
y = delta
dy = 2.0d0*xmax
!
! log1px(x) = log(1.0d0 + x)
!
f1 = log1px(dy/y)
f2 = log1px(-dy/(b-y))
f3 = - dy/y/(y + dy)
!
isoft = c1*f1 + c2*f2 + c3*f3
!
IF (isoft.LT.-1.0d-10) THEN
  write(nout,*)'isoft<-1.0d-10',xmax,delta
  stop
END IF
!
RETURN
END function isoft
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine getflavorxphi0(qbarsq,calqsq,flavor0,x,phi,flavor1,flavor2)
use beowulf_helpers
implicit none
!In:
real(kind=dbl) :: qbarsq,calqsq
character(len=5) :: flavor0             ! quark, qbar, gluon
!Out:
real(kind=dbl) :: x,phi
character(len=5) :: flavor1,flavor2     ! quark, qbar, gluon
!
! Produces x,phi,flavor1,flavor2 distributed according to a simple function.
! 20 October 2002
!  5 April 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
real(kind=dbl) :: random,r
real(kind=dbl) :: integralq,integralg,temp
!
!---
!
IF (flavor0.EQ.'gluon') THEN
  integralq = 0.5d0
  integralg = nc*(1.0d0 + qbarsq/calqsq)*log(1.0d0 + calqsq/qbarsq)
  r = random(1)
  IF ( integralg/(integralg + nf*integralq).GT.r) THEN
    flavor1 = 'gluon'
    flavor2 = 'gluon'
    r = random(1)
    temp = 1.0d0 + calqsq/qbarsq
    IF (r.LT.0.5d0) THEN
      x = 0.5d0*qbarsq/calqsq*(temp**(2*r) - 1.0d0)
    ELSE
      r = 1.0d0 - r
      x = 0.5d0*qbarsq/calqsq*(temp**(2*r) - 1.0d0)
      x = 1.0d0 - x
    END IF
  ELSE
    flavor1 = 'quark'
    flavor2 = 'qbar '
    r = random(1)
    x = r
  END IF
ELSE IF ((flavor0.EQ.'quark').OR.(flavor0.EQ.'qbar ')) THEN
   flavor1 = 'gluon'
   flavor2 = flavor0
   r = random(1)   
   temp = 1.0d0 + calqsq/qbarsq
   x = qbarsq/calqsq*(temp**r - 1.0d0)
ELSE
  write(nout,*)'Unknown flavor in getflavorxphi0.'
  stop
END IF
r = random(1)
phi = (2.0d0*r - 1.0d0)*pi
!
END subroutine getflavorxphi0
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function &
   splitdensity0(qbarsq,x,phi,flavor0,flavor1,flavor2,rts0,calqsq,softinfo)
use beowulf_helpers
implicit none
! Define structure softinformation.
type softinformation
  character(len=5) :: flavor0   ! quark, qbar, gluon
  character(len=5) :: flavor1   ! quark, qbar, gluon
  character(len=5) :: flavor2   ! quark, qbar, gluon
  real(kind=dbl) :: cos1
  real(kind=dbl) :: cos2
  real(kind=dbl) :: msoftsq
end type softinformation
!In:
real(kind=dbl) :: qbarsq,x,phi,rts0,calqsq
character(len=5) :: flavor0,flavor1,flavor2    ! quark, qbar, gluon
type(softinformation) :: softinfo
!Out:
real(kind=dbl) :: splitdensity0
!
! Density of points {qbarsq,x,phi} for each splitting in the first level 
! splittings from a Born graph. The Sudakov factor is not included, nor 
! are 1/qbarsq/(2 pi) and 1/(alpha_s/2/pi). 
!
! 20 October 2002
! 22 March 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl) :: integral,h,n,pg,pq,truecalp
!
IF (flavor0.EQ.'gluon') THEN
  integral = nc*(1.0d0 + qbarsq/calqsq)*log(1.0d0 + calqsq/qbarsq) + 0.5d0*nf
  IF (flavor1.EQ.'gluon') THEN
    h = nc*(1.0d0 + qbarsq/calqsq)/(2.0d0*min(x,1.0d0-x) + qbarsq/calqsq)
    n = 1.0d0
  ELSE IF (flavor1.EQ.'quark') THEN
    h = 0.5d0
    n = nf
  ELSE
    write(nout,*)'Unknown flavor1 in splitdensity0.'
    stop
  END IF
  pg = truecalp(rts0,calqsq,flavor0,softinfo,qbarsq)
  splitdensity0 = n*h*pg/integral
ELSE IF ((flavor0.EQ.'quark').OR.(flavor0.EQ.'qbar ')) THEN
  integral = cf*log(1.0d0 + calqsq/qbarsq)
  h = cf/(x + qbarsq/calqsq)
  pq = truecalp(rts0,calqsq,flavor0,softinfo,qbarsq)
  splitdensity0 = h*pq/integral
ELSE
  write(nout,*)'Unknown flavor0 in splitdensity0.'
  stop
END IF
!
END function splitdensity0
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine makeshowerII(theshower)
!
use beowulf_helpers
implicit none
! Define input and output structure, theshower
type parton
  character(len=5) :: flavor   ! quark, qbar, gluon
  integer :: self              ! index of this parton
  integer :: parent            ! index of parton's parent
  integer :: ancestor          ! starting parton
  integer :: child1            ! index of parton's first daughter
  integer :: child2            ! index of parton's second daughter
  logical :: childless         ! no children (yet)
  logical :: done              ! .true. means don't split this parton
  real(kind=dbl), dimension(3) :: momentum
  real(kind=dbl) :: kappasq
end type parton
!
type showerlist
  integer :: length            ! length of the shower list
  real(kind=dbl) :: rts0       ! sqrt(s) of the starting graph
  real(kind=dbl) :: onemthrust ! 1 - thrust of the starting graph
  real(kind=dbl) :: msoftsq    ! the soft scale
  real(kind=dbl) :: multfactor ! factor to multiply |matrix element|^2
  integer :: pii,pjj           ! partons emitting and absorbing soft gluon
  type(parton), dimension(maxparticles) :: ptn
end type showerlist
!
! In and Out:
type(showerlist) :: theshower
!
! This subroutine creates a shower starting from three or more partons,
! whose parton information is initially found in 'theshower'. The splitting
! uses the function splitII, which is based on small angle approximations.
! 10 November 2002
! 22 April 2003
!
integer :: mu,n,currentN,nmax
logical showermore
type(parton) :: mother,daughter1,daughter2
!
DO
!
  showermore = .false.    ! We will exit unless showermore -> .true.
  nmax = theshower%length
  DO n = 1,nmax
  IF ((theshower%ptn(n)%childless).and.&
      (.not.theshower%ptn(n)%done)) THEN
    mother = theshower%ptn(n)
    currentN = theshower%length
    call splitII(currentN,theshower%rts0,mother,daughter1,daughter2)
    theshower%ptn(n) = mother               !mother has been modified
    IF (.not.mother%done) THEN
      theshower%ptn(currentN + 1) = daughter1
      theshower%ptn(currentN + 2) = daughter2
      theshower%length = currentN + 2
      showermore = .true.
    END IF
  END IF
  END DO
  IF (.not.showermore) EXIT
!
END DO
!
END subroutine makeshowerII
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine splitII(currentN,rts0,mother,daughter1,daughter2)
!
use beowulf_helpers
implicit none
! Define structure, parton.
type parton
  character(len=5) :: flavor   ! quark, qbar, gluon
  integer :: self              ! index of this parton
  integer :: parent            ! index of parton's parent
  integer :: ancestor          ! starting parton
  integer :: child1            ! index of parton's first daughter
  integer :: child2            ! index of parton's second daughter
  logical :: childless         ! no children (yet)
  logical :: done              ! .true. means don't split this parton
  real(kind=dbl), dimension(3) :: momentum
  real(kind=dbl) :: kappasq
end type parton
! In:
integer :: currentN
real(kind=dbl) :: rts0
type(parton) :: mother
! Out:
type(parton) :: daughter1, daughter2
!
! This subroutine 'splits' a mother parton into two daughters
! using probability distributions based on small angle approximations.
! That is, given the information stored in 'mother', it creates
! information for 'daughter1' and 'daughter2' according to
! these probability distributions.
!
! 28 October 2002
!  1 May 2003
!
! Physics data:
real(kind=dbl) :: alphasofmz,mz,externalrts
common /physicsdata/ alphasofmz,mz,externalrts
! Color factors:
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
! When to stop:
real(kind=dbl) :: showerendratio
common /showerend/ showerendratio
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
! For diagnosis:
logical :: showercheck
common /showercheckinfo/ showercheck
integer :: count
integer, save :: showernumber = 0
real(kind=dbl), save :: sum = 0.0d0
!
integer :: mu
real(kind=dbl) :: qbarsq,x,phi
character(len=5) :: flavor0,flavor1,flavor2
real(kind=dbl) :: random,r,fraction
real(kind=dbl) :: calqsq,calq,kappasq
real(kind=dbl), dimension(3) :: nx,ny,nz,ell
real(kind=dbl) :: lt,lq,cosphi,sinphi,calQ1,calQ2
real(kind=dbl) :: approxcval,approxc,truecval,truec
real(kind=dbl) :: pbarsqinv
!
! Check whether we have filled up the parton space.
!
IF (currentN.GT.(maxparticles-2)) THEN
  mother%done = .true.
  RETURN
END IF
!
! Start by supplying straightforward information.
!
daughter1%self = currentN + 1
daughter2%self = currentN + 2
daughter1%parent = mother%self
daughter2%parent = mother%self
daughter1%ancestor = mother%ancestor
daughter2%ancestor = mother%ancestor
daughter1%child1 = -1
daughter2%child1 = -1
daughter1%child2 = -1
daughter2%child2 = -1
daughter1%childless = .true.
daughter2%childless = .true.
daughter1%done = .false.
daughter2%done = .false.
!
! The momentum scale is provided by {\cal Q}, the absolute value of the
! mother parton's momentum.
!
calqsq = 0.0d0
DO mu = 1,3
  calqsq = calqsq + mother%momentum(mu)**2
END DO
calq = sqrt(calqsq)
!------------------------------------
!
! Now, we generate {qbarsq,x,phi,flavor1,flavor2}. The subroutine
! getsplitvars generates {qbarsq,x,phi,flavor1,flavor2} according to the
! distribution \tilde c. We  keep the selected pointwith probability 
! with probability c/(\tilde c). 
!
flavor0 = mother%flavor
kappasq = mother%kappasq
pbarsqinv = 4.0d0/kappasq
count = 1
DO
  call getsplitvars(rts0,kappasq,pbarsqinv,flavor0, &
                      qbarsq,x,phi,flavor1,flavor2)
  IF (qbarsq.LT.showerendratio*rts0**2) THEN
    mother%done = .true.
    RETURN
  END IF
  approxcval = &
             approxc(rts0,kappasq,flavor0,qbarsq,x,phi,flavor1,flavor2)
  truecval = truec(rts0,kappasq,flavor0,qbarsq,x,phi,flavor1,flavor2)
  fraction = truecval/approxcval
  IF (fraction.GT.1.0d0) THEN
      write(nout,*)'Oops, c was supposed to be smaller than \tilde c.'
      STOP
  END IF
  r = random(1)
  IF (fraction .GT. r) EXIT
  pbarsqinv = 1/qbarsq
  count = count + 1
  IF (count.GT.1000000) THEN
    write(nout,*)'Subroutine splitII running too long.'
    STOP
  END IF
END DO
!
! We have a splitting. Record new information for mother.
!
mother%child1 = daughter1%self
mother%child2 = daughter2%self
mother%childless = .false.
!------------------------------------
! We use {qbarsq, x, phi} to generate the daughter momenta and
! the value of kappasq to be used later for splitting the daughters.
!
! First we calculate the unit vectors n_x, n_y, n_z used to define
! the orientation of the elliptical coordinate system. 
!
DO mu = 1,3
  nz(mu) = mother%momentum(mu)/calq
END DO
call axes(nz,ny,nx)
!
! Now we find l(mu).
!
lt = sqrt(x*(1.0d0 - x)*qbarsq)
lq = 0.5d0*calq*sqrt(1.0d0 + qbarsq/calqsq)*(2.0d0*x - 1.0d0)
cosphi = cos(phi)
sinphi = sin(phi)
DO mu = 1,3
 ell(mu) = lt*cosphi*nx(mu) + lt*sinphi*ny(mu) + lq*nz(mu)
END DO
!
! This gives the daughter flavor, momenta and kappasq values.
!
daughter1%flavor = flavor1
daughter2%flavor = flavor2
DO mu = 1,3
  daughter1%momentum(mu) = 0.5d0*mother%momentum(mu) + ell(mu)
  daughter2%momentum(mu) = 0.5d0*mother%momentum(mu) - ell(mu)
END DO
calQ1 = sqrt((0.5d0*calQ + lq)**2 + lt**2)
calQ2 = sqrt((0.5d0*calQ - lq)**2 + lt**2)
daughter1%kappasq = min(x*qbarsq/(1.0d0 - x),calQ1**2,mother%kappasq)
daughter2%kappasq = min((1.0d0 - x)*qbarsq/x,calQ2**2,mother%kappasq)
!
!------------------------------------
!
! Diagnostics
!
IF (showercheck) THEN
  showernumber = showernumber + 1
  sum = sum + count
  IF ( mod(showernumber,10000).EQ.0 ) THEN
    write(nout,*)'ShowerII average number of tries is', &
                  sum/showernumber
  END IF
END IF
!
END subroutine splitII
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine getsplitvars(rts0,kappasq,pbarsqinv,flavor0, &
                        qbarsq,x,phi,flavor1,flavor2)
use beowulf_helpers
implicit none
!In:
real(kind=dbl) :: rts0,kappasq,pbarsqinv
character(len=5) :: flavor0             ! quark, qbar, gluon
!Out:
real(kind=dbl) :: qbarsq,x,phi
character(len=5) :: flavor1,flavor2    ! quark, qbar, gluon
!
! Produces {qbarsq,x,phi,flavor1,flavor2} distributed according
! to a simple function approxc(qbarsq,x,flavor1,flavor2):
!
! density = approxc(qbarsq,x,flavor1,flavor2)
!            x exp[ - int_qbarsq^infinity d lbarsq int_0^1 dz sum_flavors
!                    approxc(lbarsq,z,flavors) ]
!           d qbarsq d x  d phi /(2 pi)
!
! This version, getsplitvars, is for the secondary parton splittings
! (not directly from a Born graph) and matches the function approxc.
! 16 September 2002
!  1 May 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
!
real(kind=dbl) :: random,r
real(kind=dbl) :: temp,temp1
!
!---
!
IF ((flavor0.EQ.'quark').OR.(flavor0.EQ.'qbar ')) THEN
  flavor1 = 'gluon'
  flavor2 = flavor0
  r = random(1)
  temp = log(kappasq*pbarsqinv)**2 + (2.0d0*pi/cf)*log(1/r)
  temp = sqrt(temp)
  qbarsq = kappasq*exp(-temp) 
  r = random(1)
  x = (kappasq/qbarsq)**(r-1)
  r = random(1)
  phi = (2.0d0*r - 1.0d0)*pi
!
ELSE IF (flavor0 == 'gluon') THEN
!
  r = random(1)
  temp1 = 2.0d0*nf/9.0d0/nc
  temp = log(0.5d0*kappasq*pbarsqinv + temp1)**2 &
         + (16.0d0*pi/9.0d0/nc)*log(1/r)
  temp = sqrt(temp) - temp1
  qbarsq =0.5d0*kappasq*exp(-temp) 
!
  r = random(1)
  IF (r < 1.0d0/(1.0d0 + temp/temp1)) THEN
    flavor1 = 'quark'  
    flavor2 = 'qbar '
    r = random(1)
    x = r
  ELSE
    flavor1 = 'gluon'  
    flavor2 = 'gluon'
    r = random(1)
    IF (r.LT.0.5d0) THEN
      x = 0.5d0*exp((2.0d0*r - 1.0d0)*temp)
    ELSE
      x = 0.5d0*exp((1.0d0 - 2.0d0*r)*temp)
      x = 1.0d0 - x
    END IF
    IF (qbarsq.GT.min(x,1.0d0-x)*kappasq) THEN
      write(nout,*)'That is impossible, error in getsplitvars'
      write(nout,*)x,qbarsq,min(x,1.0d0-x)*kappasq
      stop
    END IF
  END IF
!
  r = random(1)
  phi = (2.0d0*r - 1.0d0)*pi
END IF
!
END subroutine getsplitvars
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function approxc(rts0,kappasq,flavor0,qbarsq,x,phi,flavor1,flavor2)
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: rts0,kappasq
character(len=5) :: flavor0             ! quark, qbar, gluon
real(kind=dbl) :: qbarsq,x,phi
character(len=5) :: flavor1,flavor2     ! quark, qbar, gluon
! Out:
real(kind=dbl) :: approxc
!
! The function approxc(qbarsq,x,flavor1,flavor2) used for approximate splitting:
!
! density = approxc(qbarsq,x,flavor1,flavor2)
!            x exp[ - int_qbarsq^infinity d lbarsq int_0^1 dz sum_flavors
!                    approxc(lbarsq,z,flavors) ]
!           d qbarsq d x  d phi /(2 pi)
!
! This version, approxc, is for secondary parton splittings and matches 
! getsplitvars.
! 16 September 2002
!  1 May 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl), parameter :: twopi = 6.28318530717959d0
real(kind=dbl) :: temp
!
IF (flavor0.EQ.'gluon') THEN
  IF (flavor1.EQ.'quark') THEN
    temp = 0.5d0*nf
  ELSE IF (flavor1.EQ.'gluon') THEN
    temp = (9.0d0*nc/8.0d0)/min(x,1.0d0-x)
  ELSE
    write(nout,*)'Wrong flavors in approxc.',flavor0,flavor1,flavor2
    STOP
  END IF
ELSE IF ((flavor0.EQ.'quark').OR.(flavor0.EQ.'qbar ')) THEN
  temp = 2.0d0*cf/x
ELSE
  write(nout,*)'Wrong flavors in approxc.'
  STOP
END IF
approxc = temp/twopi/qbarsq
!
END function approxc
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function truec(rts0,kappasq,flavor0,qbarsq,x,phi,flavor1,flavor2)
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: rts0,kappasq
character(len=5) :: flavor0             ! quark, qbar, gluon
real(kind=dbl) :: qbarsq,x,phi
character(len=5) :: flavor1,flavor2     ! quark, qbar, gluon
! Out:
real(kind=dbl) :: truec
!
! The function truec(qbarsq,x,flavor1,flavor2) to be produced by the splitting
! routine:
!
! density = truec(qbarsq,x,flavor1,flavor2)
!            x exp[ - int_qbarsq^infinity d lbarsq int_0^1 dz sum_flavors
!                    truec(lbarsq,z,flavors) ]
!           d qbarsq d x  d phi /(2 pi)
!
! This version, truec rather thant truec0, is for the *other than* the first 
! parton splitting from a Born graph.
!
! 31 August 2002
!  1 May 2003
!
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl) :: alphasofmz,mz,externalrts
common /physicsdata/ alphasofmz,mz,externalrts
!
real(kind=dbl) x1mx,altarelli,externalmumsbar,alpi
!
x1mx = x*(1.0d0 - x)
IF (qbarsq .GT. x1mx*kappasq) THEN
  truec = 0.0d0
  RETURN
END IF
!
! We need the effective Altarelli-Parisi splitting functions 
! times appropriate counting factors.
!
IF (flavor0.EQ.'gluon') THEN
  IF ((flavor1.EQ.'gluon').AND.(flavor2.EQ.'gluon')) THEN
    altarelli = nc * (1.0d0 - x1mx)**2 /x1mx        ! half of Pgg
  ELSE IF ((flavor1.EQ.'quark').AND.(flavor2.EQ.'qbar ')) THEN
    altarelli = nf * 0.5d0 * (1.0d0 - 2.0d0*x1mx)   ! Nf times Pqg
  ELSE
    write(nout,*)'We should not have generated this flavor combination.'
    STOP
  END IF
ELSE IF ((flavor0.EQ.'quark').OR.(flavor0.EQ.'qbar ')) THEN
  IF ((flavor1.EQ.'gluon').AND.(flavor2.EQ.flavor0)) THEN
    altarelli = cf*(1.0d0 + (1.0d0 - x)**2)/x       ! Pgq
  ELSE
    write(nout,*)'We should not have generated this flavor combination.'
    STOP
  END IF
ELSE
  write(nout,*)'We should not have generated this flavor combination.'
  STOP
END IF
!
externalmumsbar = sqrt(x1mx*qbarsq) * externalrts/rts0
truec = 0.5d0*alpi(externalmumsbar)/qbarsq*altarelli
!
END function truec
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine findkoff(graphnumber,cut,kcut,pii,pjj,koff)
!
use beowulf_helpers
implicit none
!
type cutstructure
  integer                        :: cutnumber ! identifies the cut
  integer                        :: ncut      ! number of cut propagators
  integer, dimension(size+1)     :: cutindex  ! index of cut propagator
  integer, dimension(size+1)     :: cutsign   ! direction of cut propagator
  logical                        :: leftloop  ! there is a loop to left
  logical                        :: rightloop ! there is a loop to right
  integer                        :: ninloop   ! number of props in loop
  integer, dimension(size+1)     :: loopindex ! indices around loop
  integer, dimension(size+1)     :: loopsign  ! propagator directions
end type cutstructure
!
! In:
integer :: graphnumber
type(cutstructure) :: cut
real(kind=dbl) :: kcut(size+1,0:3)
integer :: pii,pjj
! Out:
real(kind=dbl) :: koff(0:3*size-1,0:3)
!
! Calculates momenta koff(p,mu), which is like k(p,mu) except that
! the final state particles are given energies equal to the total energy
! of the shower that originates from that particle and the momentum of
! the soft gluon shower is appropriately routed. This is only for the 
! Born graphs.
!
! 2 February 2003
!
integer :: i,mu
!
! The momenta for the propagators that enter the final state are simple.
!
    DO i = 1,3
      DO mu = 0,3
        koff(cut%cutindex(i),mu) = cut%cutsign(i)*kcut(i,mu)
      END DO
    END DO
!
! For the other two propagators, we use the structure of the graph and
! our information on where the soft gluon attached. Since the graphs are
! so simple, we just do it by hand.
!
   IF (graphnumber.EQ.11) THEN
     IF (cut%cutindex(pii).EQ.1) THEN
       DO mu = 0,3
         koff(2,mu) = koff(4,mu) + koff(5,mu)
         koff(0,mu) = koff(1,mu) + koff(2,mu) + kcut(4,mu)
       END DO
     ELSE
       DO mu = 0,3
         koff(2,mu) = koff(4,mu) + koff(5,mu) + kcut(4,mu)
         koff(0,mu) = koff(1,mu) + koff(2,mu)
       END DO
     END IF
     IF (cut%cutindex(pjj).EQ.1) THEN
       DO mu = 0,3
         koff(3,mu) = -koff(4,mu) - koff(5,mu)
       END DO
     ELSE
       DO mu = 0,3
         koff(3,mu) = -koff(4,mu) - koff(5,mu) - kcut(4,mu)
       END DO
     END IF
   ELSE IF (graphnumber.EQ.12) THEN
     IF (cut%cutindex(3).EQ.1) THEN
       IF (cut%cutindex(pii).EQ.1) THEN
         DO mu = 0,3
           koff(2,mu) = - koff(4,mu) - koff(5,mu)
           koff(0,mu) = koff(1,mu) + koff(2,mu) + kcut(4,mu)
         END DO
       ELSE
         DO mu = 0,3
           koff(2,mu) = - koff(4,mu) - koff(5,mu) + kcut(4,mu)
           koff(0,mu) = koff(1,mu) + koff(2,mu)
         END DO
       END IF
       IF (cut%cutindex(pjj).EQ.4) THEN
         DO mu = 0,3
           koff(3,mu) = - koff(1,mu) + koff(5,mu)
         END DO
       ELSE
         DO mu = 0,3
           koff(3,mu) = - koff(1,mu) + koff(5,mu) - kcut(4,mu)
         END DO
       END IF
     ELSE IF (cut%cutindex(3).EQ.2) THEN
       IF (cut%cutindex(pii).EQ.2) THEN
         DO mu = 0,3
           koff(1,mu) = - koff(3,mu) + koff(5,mu)
           koff(0,mu) = koff(1,mu) + koff(2,mu) + kcut(4,mu)
         END DO
       ELSE
         DO mu = 0,3
           koff(1,mu) = - koff(3,mu) + koff(5,mu) + kcut(4,mu)
           koff(0,mu) = koff(1,mu) + koff(2,mu)
         END DO
       END IF
       IF (cut%cutindex(pjj).EQ.3) THEN
         DO mu = 0,3
           koff(4,mu) = - koff(2,mu) - koff(5,mu)
         END DO
       ELSE
         DO mu = 0,3
           koff(4,mu) = - koff(2,mu) - koff(5,mu) - kcut(4,mu)
         END DO
       END IF
     ELSE
       write(nout,*)'Cut propagator 3 for graph 12 should be 1 or 2.'
       stop
     END IF
   ELSE
    write(nout,*)'We should have been working on graph number 11 or 12.'
    stop
   END IF
!
end subroutine findkoff
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine showerglueprop(kind2pt,softinfo,q,kplus,kminus,out)
!
use beowulf_helpers
implicit none
! Define type softinformation
type softinformation
  character(len=5) :: flavor0   ! quark, qbar, gluon
  character(len=5) :: flavor1   ! quark, qbar, gluon
  character(len=5) :: flavor2   ! quark, qbar, gluon
  real(kind=dbl) :: cos1
  real(kind=dbl) :: cos2
  real(kind=dbl) :: msoftsq
end type softinformation
! In:
character(len=9) :: kind2pt
type(softinformation) :: softinfo
real(kind=dbl) :: q(1:3),kplus(1:3),kminus(1:3)
! Out:
real(kind=dbl) :: out(0:3,0:3)
!
! Calculates the one loop cut gluon two-point function.
!
! kind2pt:
!   GLUONLOOP gluon self-energy with a gluon (including ghost) loop
!   QUARKLOOP gluon self-energy with a quark loop
!
! q(mu): incoming momentum (q = kplus + kminus)
! kplus(mu): 1st momentum in loop
! kminus(mu): 2nd momentum in loop
!
! The result is the two  point function out(mu,nu) with a certain
! normalization. Specifically, for the cut gluon self-energy
! graph, out(mu,nu) is {\cal M}_{g -> g g}^{\mu\nu} divided by 
! (\alpha_s/(2\pi)) or else out(mu,nu) is {\cal M}_{g -> q barq}^{\mu\nu} 
! divided by (\alpha_s/(2\pi)), depending on the value of kind2pt.
!
! We also include the soft gluon subtraction in the case of g -> g g.
!
! 20 October 2002
! 15 June 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl) :: showercut
common /showercutinfo/ showercut
logical :: dosoft
common /softswitch/ dosoft
!
real(kind=dbl), parameter :: esq = 7.38905609893065d0
real(kind=dbl), parameter :: e5thirds = 5.29449005047003d0
real(kind=dbl), parameter :: e8thirds = 14.3919160951499d0
!
integer :: mu,nu
real(kind=dbl) :: calqsq,omegaplussq,omegaminussq
real(kind=dbl) :: calq,omegaplus,omegaminus,q0
real(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq
real(kind=dbl), dimension(3) :: ell,ellt
real(kind=dbl) :: elltsq,denom,onem2x1mx,onem4x1mx
real(kind=dbl) :: temp
real(kind=dbl), dimension(0:3,0:3) :: bareprop
real(kind=dbl) :: ntt,nll,nee,nel,at0,at1,at2
real(kind=dbl) :: calp,prefactor
real(kind=dbl) :: termtt,termll
real(kind=dbl) :: cosqkplus,cosqkminus,psoft
! 
! Some auxilliary variables, include
! CALQ = {\cal Q}
! OMEGAPLUS = \omega_+
! OMEGAMINUS = \omega_-
! DELTAP1 = \Delta + 1
! TWOXM1 = 2 x - 1
! X1MX = x (1-x)
! ELLT(mu) = l_T^\mu
! ELLTSQ = (\vec l_T)^2
! Q(mu) = the incoming *three*-momentum
! Q0 = the incoming energy
!
calqsq = 0.0d0
omegaplussq = 0.0d0
omegaminussq = 0.0d0
DO mu = 1,3
  calqsq = calqsq + q(mu)**2
  omegaplussq = omegaplussq + kplus(mu)**2
  omegaminussq = omegaminussq + kminus(mu)**2
END DO
calq = sqrt(calqsq)
omegaplus  = sqrt(omegaplussq)
omegaminus = sqrt(omegaminussq)
q0 = omegaplus + omegaminus
deltap1 = (omegaplus + omegaminus)/calq
delta = deltap1 - 1.0d0
twoxm1 = (omegaplus - omegaminus)/calq
x1mx = (1.0d0 - twoxm1**2)/4.0d0
qbarsq = calqsq * delta * (delta + 2.0d0)
!
IF ( qbarsq.GT.(showercut*calqsq) ) THEN
  ! We have a wide angle splitting and we don't count it as a shower.
  DO mu = 0,3
  DO nu = 0,3
    out(mu,nu) = 0.0d0
  END DO
  END DO
ELSE
!
! Proceed with the calculation.
!
DO mu = 1,3
  ell(mu) = (kplus(mu) - kminus(mu))/2.0d0
  ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu)
END DO
elltsq = qbarsq*x1mx
denom = qbarsq/calqsq + 4.0d0*x1mx
onem2x1mx = 1.0d0 - 2.0d0*x1mx
onem4x1mx = 1.0d0 - 4.0d0*x1mx
!
! The gluon propagator in Coulomb gauge for an on-shell gluon
! with three-momentum q(mu). This is the space components only.
!
DO mu = 1,3
  bareprop(mu,mu) = 1.0d0 - q(mu)**2/calqsq
DO nu = mu+1,3
  temp = - q(mu)*q(nu)/calqsq
  bareprop(mu,nu) = temp
  bareprop(nu,mu) = temp
END DO
END DO
!
! We compute the coefficients for, alternatively, the gluon loop
! or the quark loop. We use the name NLL for Ntt and NEL for NEt.
!
IF (kind2pt.EQ.'gluonloop') THEN
!
ntt = x1mx
ntt = ntt + 8.0d0*x1mx*(1.0d0 - x1mx)/denom
ntt = ntt + 16.0d0*x1mx*(onem4x1mx + 2.0d0*x1mx**2)/denom**2
ntt = ntt * 2.0d0*nc
nll = x1mx
nll = nll - 8.0d0*x1mx**2/denom
nll = nll + 32.0d0*x1mx**3/denom**2
nll = nll * 4.0d0*nc
nee = onem4x1mx
nee = nee - 8.0d0*x1mx*onem4x1mx/denom
nee = nee + 32.0d0*x1mx**2*onem4x1mx/denom**2
nee = nee * nc
nel = -1.0d0
nel = nel - 2.0d0*onem4x1mx/denom
nel = nel + 16.0d0*x1mx*onem2x1mx/denom**2
nel = nel * 2.0d0*nc*twoxm1
!
ELSE IF (kind2pt.EQ.'quarkloop') THEN
!
ntt = nf*onem2x1mx
nll = - nf*4.0d0*x1mx
nee = 4.0d0*nf*x1mx
nel = 2.0d0*nf*twoxm1
!
ELSE
write(nout,*)'Unrecognized type in subroutine showerglueprop.'
stop
END IF
!
! With the coefficients in hand, we compute the result.
!
prefactor = 1.0d0/(2.0d0*deltap1)
!
out(0,0) = prefactor*qbarsq/calqsq*nee
DO mu = 1,3
  temp = prefactor*q0/deltap1/calqsq*nel*ellt(mu)
  out(0,mu) = temp
  out(mu,0) = temp
END DO
DO mu = 1,3
DO nu = 1,3
  termtt = ntt*bareprop(mu,nu)
  termll = nll*(ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu))
  out(mu,nu) = prefactor*(termtt + termll)
END DO
END DO
!
! Close IF(qbarsq.GT.calqsq) THEN out(mu,nu) = 0 ELSE calculate it.
!
END IF
!
IF (dosoft) THEN        ! Do soft subtraction.
IF (kind2pt.EQ.'gluonloop') THEN
!
! Soft subtraction, symmetrized between kplus(mu) and kminus(mu).
!
IF (omegaplussq.LT.softinfo%msoftsq) THEN  ! theta(omega_+^2 < msoft^2)
  cosqkplus = 0.0d0
  DO mu = 1,3
    cosqkplus = cosqkplus + q(mu)*kplus(mu)/calq/omegaplus
  END DO
  IF ((cosqkplus.LT.softinfo%cos1).OR.(cosqkplus.LT.softinfo%cos2)) THEN
    psoft = 0.0d0
    IF (cosqkplus.LT.softinfo%cos1) THEN
      psoft = psoft + 0.5d0*nc
    END IF
    IF (cosqkplus.LT.softinfo%cos2) THEN
      psoft = psoft + 0.5d0*nc
    END IF
    psoft = psoft*0.5d0*qbarsq/deltap1
    psoft = psoft/omegaplussq
    psoft = psoft*(1.0d0 + cosqkplus)/(1.0d0 - cosqkplus)
!
    DO mu = 1,3
      bareprop(mu,mu) = 1.0d0 - kminus(mu)**2/omegaminussq
    DO nu = mu+1,3
      temp = - kminus(mu)*kminus(nu)/omegaminussq
      bareprop(mu,nu) = temp
      bareprop(nu,mu) = temp
    END DO
    END DO
!
    DO mu = 1,3
    DO nu = 1,3
      out(mu,nu) = out(mu,nu) - 0.5d0*psoft*bareprop(mu,nu)
    END DO
    END DO
  END IF   ! (cosqkplus.LT.cos1).OR.(cosqkplus.LT.cos2)
END IF   ! omegaplussq.LT.softinfo%msoftsq
!
! Now the same with kplus(mu) <-> kminus(mu).
!
IF (omegaminussq.LT.softinfo%msoftsq) THEN  ! theta(omega_-^2 < msoft^2)
  cosqkminus = 0.0d0
  DO mu = 1,3
    cosqkminus = cosqkminus + q(mu)*kminus(mu)/calq/omegaminus
  END DO
  IF ((cosqkminus.LT.softinfo%cos1).OR.(cosqkminus.LT.softinfo%cos2)) THEN
    psoft = 0.0d0
    IF (cosqkminus.LT.softinfo%cos1) THEN
      psoft = psoft + 0.5d0*nc
    END IF
    IF (cosqkminus.LT.softinfo%cos2) THEN
      psoft = psoft + 0.5d0*nc
    END IF
    psoft = psoft*0.5d0*qbarsq/deltap1
    psoft = psoft/omegaminussq
    psoft = psoft*(1.0d0 + cosqkminus)/(1.0d0 - cosqkminus)
!
    DO mu = 1,3
      bareprop(mu,mu) = 1.0d0 - kplus(mu)**2/omegaplussq
    DO nu = mu+1,3
      temp = - kplus(mu)*kplus(nu)/omegaplussq
      bareprop(mu,nu) = temp
      bareprop(nu,mu) = temp
    END DO
    END DO
!
    DO mu = 1,3
    DO nu = 1,3
      out(mu,nu) = out(mu,nu) - 0.5d0*psoft*bareprop(mu,nu)
    END DO
    END DO
  END IF   ! (cosqkminus.LT.cos1).OR.(cosqkminus.LT.cos2)
END IF   ! omegaminussq.LT.softinfo%msoftsq
!
END IF   ! kind2pt.EQ.'gluonloop'
END IF   ! dosoft
!
END subroutine showerglueprop
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine showerquarkprop(softinfo,q,kplus,kminus,out)
!
use beowulf_helpers
implicit none
! Define type softinformation
type softinformation
  character(len=5) :: flavor0   ! quark, qbar, gluon
  character(len=5) :: flavor1   ! quark, qbar, gluon
  character(len=5) :: flavor2   ! quark, qbar, gluon
  real(kind=dbl) :: cos1
  real(kind=dbl) :: cos2
  real(kind=dbl) :: msoftsq
end type softinformation
! In:
type(softinformation) :: softinfo
real(kind=dbl) :: q(1:3),kplus(1:3),kminus(1:3)
! Out:
real(kind=dbl) :: out(0:3)
!
! Calculates the one loop cut quark two-point function.
!
! q(mu): incoming momentum (q = kplus + kminus)
! kplus(mu): 1st momentum in loop
! kminus(mu): 2nd momentum in loop
!
! The quark cut two  point function, with a certain normalization, 
! is represented as out^mu gamma_mu. Specifically, for the cut quark
! self-energy graph, out^mu gamma_mu is {\cal M}_{q -> g q} divided by 
! (\alpha_s/(2\pi)).
!
! 20 October 2002
! 15 June 2003
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl) :: showercut
common /showercutinfo/ showercut
logical :: dosoft
common /softswitch/ dosoft
!
real(kind=dbl) :: ecube = 20.0855369231877d0
real(kind=dbl) :: e5thirds = 5.29449005047003d0
!
integer :: mu
real(kind=dbl) :: calqsq,omegaplussq,omegaminussq
real(kind=dbl) :: calq,omegaplus,omegaminus,q0
real(kind=dbl) :: deltap1,delta,twoxm1,x1mx,x,qbarsq
real(kind=dbl), dimension(3) :: ellt
real(kind=dbl) :: elltsq,denom,onem2x1mx,onem4x1mx
real(kind=dbl) :: temp,tempsq,nl,ne,nt
real(kind=dbl) :: bl0,bl1,bl2
real(kind=dbl) :: nl0,nl1,nl2
real(kind=dbl) :: calp,prefactor
real(kind=dbl) :: cosqkplus,psoft
! 
! Auxilliary variables include
! calq = {\cal Q}
! omegaplus = \omega_+
! omegaminus = \omega_-
! deltap1 = \Delta + 1
! twoxm1 = 2 x - 1
! x1mx = x (1-x)
! ellt(mu) = l_T^\mu
! elltsq = (\vec l_T)^2
! q(mu) = the incoming *three*-momentum
! q0 = the incoming energy
!
calqsq = 0.0d0
omegaplussq = 0.0d0
omegaminussq = 0.0d0
DO mu = 1,3
  calqsq = calqsq + q(mu)**2
  omegaplussq = omegaplussq + kplus(mu)**2
  omegaminussq = omegaminussq + kminus(mu)**2
END DO
calq = sqrt(calqsq)
omegaplus  = sqrt(omegaplussq)
omegaminus = sqrt(omegaminussq)
q0 = omegaplus + omegaminus
deltap1 = (omegaplus + omegaminus)/calq
delta = deltap1 - 1.0d0
twoxm1 = (omegaplus - omegaminus)/calq
x1mx = (1.0d0 - twoxm1**2)/4.0d0
x = 0.5d0*(twoxm1 + 1.0d0)
qbarsq = calqsq * delta * (delta + 2.0d0)
!
IF ( qbarsq.GT.(showercut*calqsq) ) THEN
  ! We have a wide angle splitting and we don't count it as a shower.
  DO mu = 0,3
    out(mu) = 0.0d0
  END DO
ELSE
!
! Proceed with the calculation.
!
DO mu = 1,3
  ellt(mu) = (kplus(mu) - kminus(mu))/2.0d0 - 0.5d0*deltap1*twoxm1*q(mu)
END DO
elltsq = qbarsq*x1mx
denom = qbarsq/calqsq + 4.0d0*x1mx
onem2x1mx = 1.0d0 - 2.0d0*x1mx
onem4x1mx = 1.0d0 - 4.0d0*x1mx
!
! Here temp = 2 x + Delta.
!
temp = twoxm1 + deltap1
tempsq = temp**2
nl = 12.0d0*x1mx + twoxm1*temp
nl = nl - 16.0d0*x1mx*twoxm1/temp + 16.0d0*x1mx*onem2x1mx/tempsq
nl = nl * cf
ne = 2.0d0*cf*(1.0d0 - x)*(4.0d0*x**2 + delta**2)/tempsq
nt = 1.0d0 - 2.0d0*twoxm1/temp - 8.0d0*x1mx/tempsq
nt = 2.0d0*cf*nt
!
! Now we costruct out(mu),
!
prefactor = 1.0d0/(2.0d0*deltap1)
out(0) = prefactor*q0/deltap1*(nl + delta*ne)
DO mu = 1,3
  out(mu) = prefactor*(nl*q(mu) + nt*ellt(mu))
END DO
!
! Close IF(qbarsq.GT.calqsq) THEN out(mu) = 0 ELSE calculate it.
!
END IF
!
IF (dosoft) THEN      ! Do soft subtraction.
IF (omegaplussq.LT.softinfo%msoftsq) THEN  ! theta(omega_+^2 < msoft^2)
  cosqkplus = 0.0d0
  DO mu = 1,3
    cosqkplus = cosqkplus + q(mu)*kplus(mu)/calq/omegaplus
  END DO
  IF ((cosqkplus.LT.softinfo%cos1).OR.(cosqkplus.LT.softinfo%cos2)) THEN
    psoft = 0.0d0
    IF (cosqkplus.LT.softinfo%cos1) THEN
      IF (softinfo%flavor1.EQ.'gluon') THEN
        psoft = psoft + 0.5d0*nc
      ELSE
        psoft = psoft - 0.5d0/nc
      END IF
    END IF
    IF (cosqkplus.LT.softinfo%cos2) THEN
      IF (softinfo%flavor1.EQ.'gluon') THEN
        psoft = psoft + 0.5d0*nc
      ELSE
        psoft = psoft - 0.5d0/nc
      END IF
    END IF
    psoft = psoft*0.5d0*qbarsq/deltap1
    psoft = psoft/omegaplussq
    psoft = psoft*(1.0d0 + cosqkplus)/(1.0d0 - cosqkplus)
    out(0) = out(0) - psoft*omegaminus
    DO mu = 1,3
      out(mu) = out(mu) - psoft*kminus(mu)
    END DO
  END IF  ! (cosqkplus.LT.softinfo%cos1).OR.(cosqkplus.LT.softinfo%cos2)
END IF  ! omegaplussq.LT.softinfo%msoftsq
END IF  ! dosoft
!
END subroutine showerquarkprop
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function feynmanSH0(graphnumber,flavorsetnumber,kin,cut, &
                    vquark,vqbar,tglue)
!
use beowulf_helpers
implicit none
! In:
integer :: graphnumber,flavorsetnumber
real(kind=dbl), dimension(0:3*size-1,0:3) :: kin
logical, dimension(3*size-1) :: cut
real(kind=dbl), dimension(0:3)     :: vquark,vqbar
real(kind=dbl), dimension(0:3,0:3) :: tglue
! Out:
complex(kind=dbl) :: feynmanSH0
!
! Feynman integrand function for graph GRAPHNUMBER
! with momenta KIN and cut specified by CUT.  This subroutine 
! is for Born graphs with level-1 parton splitting,
! that is SHower-zero.
! Early version: 17 July 1994.
! This version written by Mathematica code of 14 July 2002 on
! 14 Jul 2002.
! Input variable mumsbar removed 1 September 2002, DES.
! Fixed by hand 2 September 2002, DES.
! Calculation changed to real, 3 January 2003, DES.
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
!
real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/)
!
integer :: mu,nu,tau
real(kind=dbl),dimension(256) :: x
real(kind=dbl),dimension(0:3) :: k1,k2,k3,k4,k5
real(kind=dbl) :: e1,e2,e3,e4,e5
real(kind=dbl) :: k11,k22,k33,k44,k55
real(kind=dbl) :: tk11,tk22,tk33,tk44,tk55
real(kind=dbl) :: prefactor
real(kind=dbl) :: result
!
real(kind=dbl) :: tg4wva1vb5,tg4wva2va5,tg4wva3vb5,tg4wva5vb1,tg4wva5vb3
real(kind=dbl) :: tg4wvb2vb5,tg5wva1vb2,tg5wva1vb3,tg5wva4vb2,tg5wva4vb3
real(kind=dbl) :: tracetg4,tracetg5,va1va3,va1va4,va1vb2,va1vb3,va1vb5
real(kind=dbl) :: va2va5,va2vb1,va2vb3,va3vb2,va3vb5,va4vb2,va4vb3
real(kind=dbl) :: va5vb1,va5vb3,vb1vb3,vb2vb3,vb2vb5,va1(0:3),va2(0:3)
real(kind=dbl) :: va3(0:3),va4(0:3),va5(0:3),vb1(0:3),vb2(0:3),vb3(0:3)
real(kind=dbl) :: vb5(0:3),tg4(0:3,0:3),tg5(0:3,0:3)
!
DO mu = 0,3
  k1(mu) = kin(1,mu)
  k2(mu) = kin(2,mu)
  k3(mu) = kin(3,mu)
  k4(mu) = kin(4,mu)
  k5(mu) = kin(5,mu)
END DO
result = 0.0d0
!
!------
!
IF (graphnumber .EQ. 11) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,quark,gluon,qbar}
!
IF (cut(1)) THEN
  DO mu = 0,3
    va1(mu) = vquark(mu)
  END DO
ELSE
  DO mu = 0,3
    va1(mu) = kin(1,mu)
  END DO
END IF
IF (cut(2)) THEN
  write(nout,*) 'This propagator should not be cut.'  ! Fixed
  STOP
ELSE
  DO mu = 0,3
    vb2(mu) = -kin(2,mu)
  END DO
END IF
IF (cut(3)) THEN
  write(nout,*) 'This propagator should not be cut.'  ! Fixed
  STOP
ELSE
  DO mu = 0,3
    va3(mu) = kin(3,mu)
  END DO
END IF
IF (cut(4)) THEN
  DO mu = 0,3
  DO nu = 0,3
    tg4(mu,nu) = tglue(mu,nu)
  END DO
  END DO
ELSE
  write(nout,*) 'This propagator should have been cut.'
  STOP
END IF
IF (cut(5)) THEN
  DO mu = 0,3
    vb5(mu) = vqbar(mu)
  END DO
ELSE
  write(nout,*) 'This propagator should have been cut.'  ! Fixed
  STOP
END IF
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
tracetg4 = 0.0d0
DO mu = 0,3
  tracetg4 = tracetg4 + tg4(mu,mu)*metric(mu)
END DO
tg4wva1vb5 = 0.0d0
tg4wva3vb5 = 0.0d0
tg4wvb2vb5 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  tg4wva1vb5 = tg4wva1vb5  &
    + tg4(mu,nu)*va1(mu)*vb5(nu)*metric(mu)*metric(nu)
  tg4wva3vb5 = tg4wva3vb5  &
    + tg4(mu,nu)*va3(mu)*vb5(nu)*metric(mu)*metric(nu)
  tg4wvb2vb5 = tg4wvb2vb5  &
    + tg4(mu,nu)*vb2(mu)*vb5(nu)*metric(mu)*metric(nu)
END DO
END DO
va1va3 = 0.0d0
va1vb2 = 0.0d0
va1vb5 = 0.0d0
va3vb2 = 0.0d0
va3vb5 = 0.0d0
vb2vb5 = 0.0d0
DO mu = 0,3
  va1va3 = va1va3 + va1(mu)*va3(mu)*metric(mu)
  va1vb2 = va1vb2 + va1(mu)*vb2(mu)*metric(mu)
  va1vb5 = va1vb5 + va1(mu)*vb5(mu)*metric(mu)
  va3vb2 = va3vb2 + va3(mu)*vb2(mu)*metric(mu)
  va3vb5 = va3vb5 + va3(mu)*vb5(mu)*metric(mu)
  vb2vb5 = vb2vb5 + vb2(mu)*vb5(mu)*metric(mu)
END DO
result = -8*cf*nc*(2*tg4wvb2vb5*va1va3 + 2*tg4wva3vb5*va1vb2 &
  - 2*tg4wva1vb5*va3vb2 + tracetg4*va1vb5*va3vb2 &
  - tracetg4*va1vb2*va3vb5 - tracetg4*va1va3*vb2vb5)
result = result*prefactor
!
ELSE IF (flavorsetnumber .EQ. 2) THEN
!        flavors = {qbar,quark,qbar,gluon,quark}
!
IF (cut(1)) THEN
  DO mu = 0,3
    vb1(mu) = vqbar(mu)
  END DO
ELSE
  DO mu = 0,3
    vb1(mu) = -kin(1,mu)
  END DO
END IF
IF (cut(2)) THEN
  write(nout,*) 'This propagator should not be cut.'  ! Fixed
  STOP
ELSE
  DO mu = 0,3
    va2(mu) = kin(2,mu)
  END DO
END IF
IF (cut(3)) THEN
  write(nout,*) 'This propagator should not be cut.'  ! Fixed
  STOP
ELSE
  DO mu = 0,3
    vb3(mu) = -kin(3,mu)
  END DO
END IF
IF (cut(4)) THEN
  DO mu = 0,3
  DO nu = 0,3
    tg4(mu,nu) = tglue(mu,nu)
  END DO
  END DO
ELSE
  write(nout,*) 'This propagator should have been cut.'
  STOP
END IF
IF (cut(5)) THEN
  DO mu = 0,3
    va5(mu) = vquark(mu)
  END DO
ELSE
  write(nout,*) 'This propagator should have been cut.'  ! Fixed
  STOP
END IF
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
tracetg4 = 0.0d0
DO mu = 0,3
  tracetg4 = tracetg4 + tg4(mu,mu)*metric(mu)
END DO
tg4wva2va5 = 0.0d0
tg4wva5vb1 = 0.0d0
tg4wva5vb3 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  tg4wva2va5 = tg4wva2va5  &
    + tg4(mu,nu)*va2(mu)*va5(nu)*metric(mu)*metric(nu)
  tg4wva5vb1 = tg4wva5vb1  &
    + tg4(mu,nu)*va5(mu)*vb1(nu)*metric(mu)*metric(nu)
  tg4wva5vb3 = tg4wva5vb3  &
    + tg4(mu,nu)*va5(mu)*vb3(nu)*metric(mu)*metric(nu)
END DO
END DO
va2va5 = 0.0d0
va2vb1 = 0.0d0
va2vb3 = 0.0d0
va5vb1 = 0.0d0
va5vb3 = 0.0d0
vb1vb3 = 0.0d0
DO mu = 0,3
  va2va5 = va2va5 + va2(mu)*va5(mu)*metric(mu)
  va2vb1 = va2vb1 + va2(mu)*vb1(mu)*metric(mu)
  va2vb3 = va2vb3 + va2(mu)*vb3(mu)*metric(mu)
  va5vb1 = va5vb1 + va5(mu)*vb1(mu)*metric(mu)
  va5vb3 = va5vb3 + va5(mu)*vb3(mu)*metric(mu)
  vb1vb3 = vb1vb3 + vb1(mu)*vb3(mu)*metric(mu)
END DO
result = -8*cf*nc*(2*tg4wva5vb3*va2vb1 - 2*tg4wva5vb1*va2vb3 &
  + tracetg4*va2vb3*va5vb1 - tracetg4*va2vb1*va5vb3 &
  + 2*tg4wva2va5*vb1vb3 - tracetg4*va2va5*vb1vb3)
result = result*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
ELSE IF (graphnumber .EQ. 12) THEN
!
IF (flavorsetnumber .EQ. 1) THEN
!        flavors = {quark,qbar,qbar,quark,gluon}
!
IF (cut(1)) THEN
  DO mu = 0,3
    va1(mu) = vquark(mu)
  END DO
ELSE
  DO mu = 0,3
    va1(mu) = kin(1,mu)
  END DO
END IF
IF (cut(2)) THEN
  DO mu = 0,3
    vb2(mu) = vqbar(mu)
  END DO
ELSE
  DO mu = 0,3
    vb2(mu) = -kin(2,mu)
  END DO
END IF
IF (cut(3)) THEN
  DO mu = 0,3
    vb3(mu) = vquark(mu)   ! This has been fixed.
  END DO
ELSE
  DO mu = 0,3
    vb3(mu) = -kin(3,mu)
  END DO
END IF
IF (cut(4)) THEN
  DO mu = 0,3
    va4(mu) = vqbar(mu)    ! This has been fixed.
  END DO
ELSE
  DO mu = 0,3
    va4(mu) = kin(4,mu)
  END DO
END IF
IF (cut(5)) THEN
  DO mu = 0,3
  DO nu = 0,3
    tg5(mu,nu) = tglue(mu,nu)
  END DO
  END DO
ELSE
  write(nout,*)'Oops, this line should have been cut'
  STOP
END IF
prefactor = 1.0d0
e1 = k1(0)
tk11 = 0.0d0
e2 = k2(0)
tk22 = 0.0d0
e3 = k3(0)
tk33 = 0.0d0
e4 = k4(0)
tk44 = 0.0d0
e5 = k5(0)
tk55 = 0.0d0
DO mu = 1,3
  tk11 = tk11 - k1(mu)**2
  tk22 = tk22 - k2(mu)**2
  tk33 = tk33 - k3(mu)**2
  tk44 = tk44 - k4(mu)**2
  tk55 = tk55 - k5(mu)**2
END DO
k11 = e1**2 + tk11
k22 = e2**2 + tk22
k33 = e3**2 + tk33
k44 = e4**2 + tk44
k55 = e5**2 + tk55
IF (cut(1)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk11)
ELSE
  prefactor = prefactor/k11
END IF
IF (cut(2)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk22)
ELSE
  prefactor = prefactor/k22
END IF
IF (cut(3)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk33)
ELSE
  prefactor = prefactor/k33
END IF
IF (cut(4)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk44)
ELSE
  prefactor = prefactor/k44
END IF
IF (cut(5)) THEN
  prefactor = prefactor/2.0d0/sqrt(-tk55)
ELSE
  prefactor = prefactor/k55
END IF
tracetg5 = 0.0d0
DO mu = 0,3
  tracetg5 = tracetg5 + tg5(mu,mu)*metric(mu)
END DO
tg5wva1vb2 = 0.0d0
tg5wva1vb3 = 0.0d0
tg5wva4vb2 = 0.0d0
tg5wva4vb3 = 0.0d0
DO mu = 0,3
DO nu = 0,3
  tg5wva1vb2 = tg5wva1vb2  &
    + tg5(mu,nu)*va1(mu)*vb2(nu)*metric(mu)*metric(nu)
  tg5wva1vb3 = tg5wva1vb3  &
    + tg5(mu,nu)*va1(mu)*vb3(nu)*metric(mu)*metric(nu)
  tg5wva4vb2 = tg5wva4vb2  &
    + tg5(mu,nu)*va4(mu)*vb2(nu)*metric(mu)*metric(nu)
  tg5wva4vb3 = tg5wva4vb3  &
    + tg5(mu,nu)*va4(mu)*vb3(nu)*metric(mu)*metric(nu)
END DO
END DO
va1va4 = 0.0d0
va1vb2 = 0.0d0
va1vb3 = 0.0d0
va4vb2 = 0.0d0
va4vb3 = 0.0d0
vb2vb3 = 0.0d0
DO mu = 0,3
  va1va4 = va1va4 + va1(mu)*va4(mu)*metric(mu)
  va1vb2 = va1vb2 + va1(mu)*vb2(mu)*metric(mu)
  va1vb3 = va1vb3 + va1(mu)*vb3(mu)*metric(mu)
  va4vb2 = va4vb2 + va4(mu)*vb2(mu)*metric(mu)
  va4vb3 = va4vb3 + va4(mu)*vb3(mu)*metric(mu)
  vb2vb3 = vb2vb3 + vb2(mu)*vb3(mu)*metric(mu)
END DO
result = -8*cf*nc*(2*tg5wva4vb3*va1vb2 - 2*tg5wva4vb2*va1vb3 &
  - 2*tg5wva1vb3*va4vb2 + tracetg5*va1vb3*va4vb2 &
  + 2*tg5wva1vb2*va4vb3 - tracetg5*va1vb2*va4vb3 &
  + tracetg5*va1va4*vb2vb3)
result = result*prefactor
!
! (End flavorset query.)
!
END IF
!------
!
END IF
!
feynmanSH0 = result
RETURN
END function feynmanSH0
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
!                           Miscellaneous Functions
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function alpi(mumsbar)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: mumsbar
! Out:
real(kind=dbl) :: alpi
!
! Alpha_s/pi as a function of the MSbar scale, frozen at alpimax = 1/pi.
! See D.~E.~Soper and L.~R.~Surguladze,
! %``On the QCD perturbative expansion for e~+ e~- $\to$ hadrons,''
! Phys.\ Rev.\ D {\bf 54}, 4566 (1996)
! [arXiv:hep-ph/9511258].
! 21 February 2002
! 17 September 2002 : add freezing at alphamax.
!
real(kind=dbl) :: nc,nf,cf
common /colorfactors/ nc,nf,cf
real(kind=dbl) :: alphasofmz,mz,externalrts
common /physicsdata/ alphasofmz,mz,externalrts
real(kind=dbl) :: b0,b1,b2
real(kind=dbl) :: t,x,alpi0,alpiinv,temp,onepx,ln1px
real(kind=dbl), parameter :: pi = 3.141592653589793239d0
real(kind=dbl), parameter :: alpimax = 0.31830988618379d0   ! 1/pi
!
real(kind=dbl) :: mumin = 0.0d0    ! This gets adjusted and saved.
!
IF (mumsbar.LT.mumin) THEN
  alpi = alpimax
  RETURN
END IF
!
! The beta function coefficients.
!
b0 = (33.0d0 - 2.0d0*nf)/12.0d0
b1 = (306.0d0 - 38.0d0*nf)/48.0d0
b2 = (77139.0d0 - 15099.0d0*nf + 325.0d0*nf**2)/3456.0d0
!
alpi0 = alphasofmz/pi
t = 2.0d0*log(mumsbar/mz)
x = b0*t*alpi0
onepx = 1.0d0 + x
IF (onepx.LT.0.0d0) THEN
  mumin = mumsbar
  alpi = alpimax
  RETURN
END IF
ln1px = log(onepx)
alpiinv = onepx/alpi0
alpiinv = alpiinv + ln1px*b1/b0
temp =  (b0*b2 - b1**2)/b0**2 * x/onepx
temp = temp + b1**2/b0**2 * ln1px/onepx
temp = alpi0 * temp
alpiinv = alpiinv + temp
IF (alpiinv.LE.0.0d0) THEN
  mumin = mumsbar
  alpi = alpimax
  RETURN
END IF
alpi = 1.0d0/alpiinv
IF (alpi.GT.alpimax) THEN
  mumin = mumsbar
  alpi = alpimax
  RETURN
END IF
END function alpi
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function xxreal(z)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: z
! Out:
real(kind=dbl) :: xxreal
!
xxreal = dble(z)
RETURN
END function xxreal
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function xximag(z)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: z
! Out:
real(kind=dbl) :: xximag
!
complex(kind=dbl) :: zz
!
zz = (0.0d0,-1.0d0) * z
xximag = dble(zz)
RETURN
END function xximag
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function complexsqrt(z)
!
use beowulf_helpers
implicit none
! In:
complex(kind=dbl) :: z
! Out:
complex(kind=dbl) :: complexsqrt
!
! Square root for complex numbers with error checking.
! 1 February 1998
!
real(kind=dbl) :: xxreal,xximag
!
IF (xxreal(z).LT.0.0d0) THEN
   IF(abs(xximag(z)).LT. (1.0d-1 * abs(xxreal(z))) ) THEN
     write(nout,*)'Too near cut of sqrt(z) in complexsqrt(z).'
     write(nout,*) z
     stop
   END IF
END IF
complexsqrt = sqrt(z)
RETURN
END function complexsqrt
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function factorial(n)
!
use beowulf_helpers
implicit none
! In:
integer :: n
! Out:
real(kind=dbl) :: factorial
!
integer :: j
!
factorial = 1.0d0
DO j = 1,n
  factorial = factorial * j
END DO
RETURN
END function factorial
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function sinhinv(z)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: z
! Out:
real(kind=dbl) :: sinhinv
!
! Evaluate arcsinh(z) = log( z + Sqrt(1+z^2) ).
! For small z, we use the first four terms in the power
! series expansion of this function so that we do not
! lose precision in evaluating log(1 + z + z^2/2 + ...).
! At z = 0.03, the series evaluation is accurate to a
! fractional error of 2E-14. At this same point, the
! precision of the Log form of the function should be
! about that for representing 1.03 - 1.00, or 14 digits
! minus 1.5 digits, or 3E-12.
!
real(kind=dbl) :: z2,z3,z5,z7
!
IF (z.LT.3.0d-2) THEN
  z2 = z**2
  z3 = z * z2
  z5 = z3 * z2
  z7 = z5 * z2
  sinhinv =  z           - 1.66666666667d-1 * z3  &
           + 7.5d-2 * z5 - 4.46428571429d-2 * z7
ELSE
  sinhinv = log(z + sqrt(1.0d0 + z**2))
END IF
RETURN
END function sinhinv
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function log1px(x)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: x
! Out:
real(kind=dbl) :: log1px
!
! Returns log(1+x).
! 17 March 2003
!
IF (abs(x).gt.1d-2) THEN
  log1px = log(1.0d0 + x)
ELSE
!
! log1px = x - x^2/2 + x^3/3 + ... + x^7/7.
!
  log1px = (0.1666666666666667d0 - 0.1428571428571429d0*x)
  log1px = 0.2d0 - x*log1px
  log1px = 0.25d0 - x*log1px
  log1px = 0.3333333333333333d0 - x*log1px
  log1px = 0.5d0 - x*log1px
  log1px = 1.0d0 - x*log1px
  log1px = x*log1px
END IF
!
end function log1px
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function expm1(x)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: x
! Out:
real(kind=dbl) :: expm1
!
! Returns exp(x) - 1.
! 15 December 1999
!
real(kind=dbl), parameter :: inv2 = 0.5d0
real(kind=dbl), parameter :: inv3 = 0.333333333333333333d0
real(kind=dbl), parameter :: inv4 = 0.25d0
real(kind=dbl), parameter :: inv5 = 0.2d0
real(kind=dbl), parameter :: inv6 = 0.166666666666666667d0
real(kind=dbl), parameter :: inv7 = 0.142857142857142857d0
real(kind=dbl), parameter :: inv8 = 0.125d0
!
IF (abs(x) .GT. 0.1d0) THEN
  expm1 = exp(x) - 1.0d0
ELSE
  expm1 = 1.0d0 + inv8*x
  expm1 = 1.0d0 + inv7*x*expm1
  expm1 = 1.0d0 + inv6*x*expm1
  expm1 = 1.0d0 + inv5*x*expm1
  expm1 = 1.0d0 + inv4*x*expm1
  expm1 = 1.0d0 + inv3*x*expm1
  expm1 = 1.0d0 + inv2*x*expm1
  expm1 = x*expm1
END IF
RETURN
END function expm1
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function sqrtm1(x)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: x
! Out:
real(kind=dbl) :: sqrtm1
!
! Returns sqrt(1+x) -1.
! The coefficients are 1/2,1/4,3/6,5/8,7/10,9/12,11/14,13/16,15/18.
! 15 December 1999
!
real(kind=dbl), parameter :: c1 = 0.5d0
real(kind=dbl), parameter :: c2 = 0.25d0
real(kind=dbl), parameter :: c3 = 0.5d0
real(kind=dbl), parameter :: c4 = 0.625d0
real(kind=dbl), parameter :: c5 = 0.7d0
real(kind=dbl), parameter :: c6 = 0.75d0
real(kind=dbl), parameter :: c7 = 0.785714285714285714d0
real(kind=dbl), parameter :: c8 = 0.8125d0
real(kind=dbl), parameter :: c9 = 0.833333333333333333d0
!
IF (abs(x) .GT. 0.03d0) THEN
  sqrtm1 = sqrt(1 + x) - 1.0d0
ELSE
  sqrtm1 = 1.0d0 - c9*x
  sqrtm1 = 1.0d0 - c8*x*sqrtm1
  sqrtm1 = 1.0d0 - c7*x*sqrtm1
  sqrtm1 = 1.0d0 - c6*x*sqrtm1
  sqrtm1 = 1.0d0 - c5*x*sqrtm1
  sqrtm1 = 1.0d0 - c4*x*sqrtm1
  sqrtm1 = 1.0d0 - c3*x*sqrtm1
  sqrtm1 = 1.0d0 - c2*x*sqrtm1
  sqrtm1 = c1*x*sqrtm1
END IF
RETURN
END function sqrtm1
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function logsqint(y)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: y
! Out:
real(kind=dbl) :: logsqint
!
! The integral from 0 to Y of Log^2(y').
! 20 February 2001
!
real(kind=dbl) :: l
!
l = log(y)
logsqint = y * (l**2 - 2.0d0*l + 2.0d0)
RETURN
END function logsqint
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function invlogsqint(w)
!
use beowulf_helpers
implicit none
! In:
real(kind=dbl) :: w
! Out:
real(kind=dbl) :: invlogsqint
!
! Y = INVLOGSQINT(W) iff W = LOGSQINT(Y) where
! LOGSQINT(Y) is the integral from 0 to Y of Log^2(y'),
! namely LOGSQINT(Y) = Y * (Log(Y)**2 - 2.0D0*Log(Y) + 2.0D0).
! 20 February 2001
!
!
real(kind=dbl) :: u,z,zsq,temp,ucalc,deltau
logical :: moreneeded
integer :: n
!
! We use variables Z = Log(Y) and U = Log(W). Thus we want to solve
! U = Z + Log( Z** - 2*Z + 2 ). We iteratively use 
! Z_(n+1) = Z_n + (U - U_n)/ (dU/dZ) where 
! dU/dZ = Z**2/( Z** - 2*Z + 2 ).
!
u = log(w)
z = 1.2d0*u - 2.0d0
moreneeded = .true.
n = 0
DO WHILE (moreneeded)
  n = n + 1
  zsq = z**2
  temp = zsq - 2.0d0*z + 2.0d0
  ucalc = z + log(temp)
  deltau = u - ucalc
  z = z + deltau*temp/zsq
  IF (abs(deltau).LT.1.0d-8) THEN
     moreneeded = .false.
  END IF
  IF (n.GT.10) THEN
    write(nout,*)'Failed convergence in invlogsqint.'
    stop
  END IF
END DO
invlogsqint = exp(z)
RETURN
END function invlogsqint
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!                          Random Number Generator
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine randominit(iran)
!
use beowulf_helpers
implicit none
! In:
integer :: iran
!
!  Code from CERN, 1991.
!  Modified to replace .AND. by IAND() and .OR. by IOR().
!
!  Initialize the shift-register random number generator from a random
!  seed  IRAN, 0 <= IRAN < 259200, with the help of a portable "quick 
!  and dirty" generator.
!
integer, parameter :: lbit=31
real(kind=dbl), parameter :: fac= 2.0d0**(-lbit)
!  Here LBIT is the number of bits used in the shift register generator
integer :: j,ir(250)
real(kind=dbl) :: rr(250)
common/rando/ rr,j,ir
save /rando/
integer :: i,lb,jran,ifac1,isk,idi,i1s
!  Configuration of the shift register generator
integer, parameter :: im = 259200
integer, parameter :: ia = 7141
integer, parameter :: ic = 54773
!
!
IF(iran.LT.0.OR.iran.GE.im)STOP &
 'rini: iran out of range'
jran=iran
!  Warm up the auxiliary generator a little
DO i=1,10
 jran=mod(jran*ia+ic,im)
END DO
ifac1=((2**(lbit-1)-1)*2+1)/im
DO i=2,250
 jran=mod(jran*ia+ic,im)
 ir(i)=ifac1*jran
END DO
!  Guarantee LBIT linearly independent (over the field of 2 el.)
!  elements in IR(I):
ir(1)=1
i=1
isk=250/lbit
idi=1
i1s=1
DO lb=1,lbit-1
 i=i+isk
 idi=idi*2
 i1s=i1s+idi
 ir(i)=ior(ir(i),idi)
 ir(i)=iand(ir(i),i1s)
END DO
call newran
END subroutine randominit
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
subroutine newran
!
use beowulf_helpers
implicit none
!
!  Code from CERN, 1991.
!  Modified to replace .XOR. by IEOR().
!
!  Fills IR(I),RR(I) with 250 new random numbers, resets J=0.
!  Increment J before use!
!
integer, parameter :: lbit=31
real(kind=dbl), parameter :: fac= 2.0d0**(-lbit)
integer :: j,ir(250)
real(kind=dbl) :: rr(250)
common/rando/ rr,j,ir
save /rando/
!
integer :: n
!
DO n=1,103
 ir(n)=ieor(ir(n+147),ir(n))
 rr(n)=fac*(dble(ir(n)) + 0.5d0)
END DO
!
DO n=104,250
 ir(n)=ieor(ir(n-103),ir(n))
 rr(n)=fac*(dble(ir(n)) + 0.5d0)
END DO
!
j=0
END subroutine newran
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!
function random(dummy)
!
use beowulf_helpers
implicit none
! In:
integer :: dummy
! Out:
real(kind=dbl) :: random
!
!  Code from CERN, 1991.
!
!  Random number between 2**(-32) and 1 - 2**(-32):
!
integer :: j,ir(250)
real(kind=dbl) :: rr(250)
common/rando/ rr,j,ir
save /rando/
!
IF(j.GE.250)call newran
j=j+1
random = rr(j)
END function random
!
!2345678901234567890123456789012345678901234567890123456789012345678901234567890
!             END OF LIBRARY ROUTINES FOR E+E- CALCULATION
!2345678901234567890123456789012345678901234567890123456789012345678901234567890