C23456789012345678901234567890123456789012345678901234567890123456789012
C
C                  ----------------------------
C                  beowulfsubs.f  Version 2.0
C                  ----------------------------
C
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE VERSION
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      WRITE(NOUT,*)'beowulf 2.0 subroutines 1 March 2002'
      WRITE(NOUT,*)'Coulomb gauge and Feynman gauge'
      RETURN
      END
C23456789012345678901234567890123456789012345678901234567890123456789012
C
C Subroutines for numerical integration of jet cross sections in
C electron-positron annihilation. -- D. E. Soper
C
C First code: 29 November 1992.
C Latest revision: see Version subroutine above.
C Special note: modified 8 December 1999 to change tabs to spaces
C and to correct the header in line 4 above.
C
C The main program and subroutines that a user might want to modify
C are contained in the companion package, beowulf.f. In particular, a
C user may very well want to modify parameter settings in the main
C program and to change the observables calculated in the subroutine
C HROTHGAR and in the functions CALStype(NCUT,KCUT,index). Subroutines
C that can be modified only at extreme peril to the reliability of
C the results are in this package, beowulfsubs.f.
C
C There are two parallel calculations. Program beowulf calculates a
C sample integral, which by default is the average value of 
C (1 - thrust)^2. These are summed in the variable INTEGRAL and
C reported upon completion of the program. The program also computes
C a simple check integral in order to check on the jacobians etc.
C In the meantime, for each point in loop space and each final
C state cut, the program reports the corresponding point in the space
C of final state momenta along with the corresponding weight (Feynman
C diagram times jacobian factors) to the subroutine HROTHGAR, which
C multiplies by the measurement functions CALS corresponding to the
C measurements desired and accumulates the results.
C 
C In order to control roundoff errors, a point in loop space is rejected
C if the point is too near a singularity or if there is too much
C cancellation in the contribution from that point to INTEGRAL.
C 
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
C                        PROGRAM STRUCTURE
C
C * denotes routines found in beowulf.f. 
C Other routines are in beowulfsubs.f
C
C PROGRAM BEOWULF (*) <setup and final reporting>
C    SUBROUTINE MAKECUTINFO
C       SUBROUTINE NEWGRAPH
C          SUBROUTINE NEWCHOICE
C          SUBROUTINE NEXTCHOICE
C          FUNCTION ONEPI
C          SUBROUTINE CHECK
C             SUBROUTINE CHECKOUT
C             SUBROUTINE EXCHANGE
C       SUBROUTINE NEWCUT
C       SUBROUTINE FINDTYPES
C          SUBROUTINE NEWCUT
C    SUBROUTINE GETCOUNTS (*)
C    SUBROUTINE HROTHGAR (*) <see below>
C    SUBROUTINE RANDOMINIT
C       SUBROUTINE NEWRAN
C    SUBROUTINE DAYTIME (*)
C    SUBROUTINE VERSION
C    SUBROUTINE RENO <see below>
C    SUBROUTINE DIAGNOSTIC
C       SUBROUTINE NEWGRAPH ...
C       SUBROUTINE FINDTYPES ...
C       SUBROUTINE CHECKPOINT
C       SUBROUTINE CALCULATE <see below>
C end
C
C SUBROUTINE RENO <choses graphs and points>
C    SUBROUTINE TIMING (*)
C    SUBROUTINE HROTHGAR (*) <see below>
C    SUBROUTINE NEWGRAPH ...
C    SUBROUTINE FINDTYPES ...
C    SUBROUTINE FINDA <see below>
C       FUNCTION PROPSIGN
C    SUBROUTINE NEWPOINT
C       SUBROUTINE CHOOSE3
C       SUBROUTINE CHOOSE2TO3D
C       SUBROUTINE CHOOSE2TO3E
C       SUBROUTINE CHOOSE2TO2T
C       SUBROUTINE CHOOSE2TO2S
C       SUBROUTINE CHOOSE2TO1
C         Subroutines CHOOSEx above all call
C         FUNCTION RANDOM
C            SUBROUTINE NEWRAN
C    SUBROUTINE CHECKPOINT
C    SUBROUTINE CALCULATE <see below>
C return
C
C SUBROUTINE CALCULATE <the main calculation routines.
C    FUNCTION DENSITY
C       FUNCTION RHO3
C       FUNCTION RHO2TO3D
C       FUNCTION RHO2TO3E
C       FUNCTION RHO2TO2T
C       FUNCTION RHO2TO2S
C       FUNCTION RHO2TO1
C    SUBROUTINE GETCUTINFO
C    FUNCTION CALS0 (*)
C       FUNCTION THRUST (*)
C    SUBROUTINE DEFORM
C    SUBROUTINE FINDA <see below>
C    FUNCTION FEYNMAN0F
C    FUNCTION FEYNMAN0
C    FUNCTION FEYNMANF
C       SUBROUTINE TWOPT2F
C       SUBROUTINE TWOPOINTQF
C       SUBROUTINE TWOPOINTGF
C       SUBROUTINE VERTEXF
C    FUNCTION FEYNMAN
C       SUBROUTINE TWOPT2
C       SUBROUTINE TWOPOINTQ
C       SUBROUTINE TWOPOINTG
C       SUBROUTINE VERTEX
C    FUNCTION SMEAR
C    SUBROUTINE CHECKCALC
C    SUBROUTINE HROTHGAR (*) <see below>
C return
C 
C SUBROUTINE FINDA <finds matrix to get all k's from the loop l's>
C    FUNCTION PROPSIGN
C return
C 
C SUBROUTINE HROTHGAR (*) 
C  Beowulf serves Hothgar, who accepts the points in the space of final
C  state momenta with the corresponding weights, multiplies by
C  desired measurement functions CALS, and accumulates results.
C    FUNCTION CALSTHRUST (*)
C       FUNCTION THRUST (*)
C       FUNCTION THRUSTDIST (*)
C         FUNCTION KN0
C         FUNCTION KN
C    FUNCTION CALSTMOMENTS (*)
C       FUNCTION THRUST (*)
C    FUNCTION CALSYMOMENTS (*)
C       SUBROUTINE COMBINEJETS (*)
C    FUNCTION THRUSTDIST (*)
C return
C
C Simple functions called from routines above, with calls
C not listed above:
C
C FUNCTION ALPI  Alpha_s(mu)/Pi
C 
C SUBROUTINE EPSILONT2
C SUBROUTINE EPSILON4
C SUBROUTINE EPSILON1N
C SUBROUTINE EPSILON2
C SUBROUTINE EPSILON2N
C SUBROUTINE EPSILON3
C SUBROUTINE EPSILONT1
C
C SUBROUTINE AXES
C FUNCTION XXREAL
C FUNCTION XXIMAG
C FUNCTION COMPLEXSQRT
C FUNCTION FACTORIAL
C FUNCTION SINHINV
C FUNCTION DELTA
C FUNCTION EXPM1
C FUNCTION SQRTM1
C FUNCTION LOGSQINT(Y)
C FUNCTION INVLOGSQINT(W)
C
C Subroutine and function arugments
C
C SUBROUTINE AXES(EA,EB,EC)
C
C SUBROUTINE CALCULATE(VRTX,GRAPHNUMBER,ORDER,KIN,ABSKIN,
C >            QS,QSIGNS,MAPTYPES,NMAPS,VALUE,MAXPART,VALUECHK)
C SUBROUTINE CHECK(CIN,NPERMS,ORDER,OK)
C SUBROUTINE CHECKCALC(
C              GRAPHNUMBER,CUTINDEX,KC,JACNEWPOINT,JACDEFORM,CHECK)
C SUBROUTINE CHECKOUT(C,CIN,ORDER,NPERMS,OK)
C SUBROUTINE CHECKPOINT(K,ABSK,PROP,ORDER,BADNESS)
C SUBROUTINE CHOOSE3(P1,P2,P3,OK)
C SUBROUTINE CHOOSE2TO2S(PA,PB,ELL,OK)
C SUBROUTINE CHOOSE2TO2T(PA,PB,ELL,OK)
C SUBROUTINE CHOOSE2TO3D(PA,PB,ELL,OK)
C SUBROUTINE CHOOSE2TO3E(PA,PB,ELL,OK)
C SUBROUTINE CHOOSE2TO1(PA,PB,ELL,OK)
C SUBROUTINE COMBINEJETS(NCUT,KCUT,Y4JET,Y2JET) (*)
C
C SUBROUTINE DAYTIME(DATE) (*)
C SUBROUTINE DEFORM(VRTX,LOOPINDEX,RTS,LEFTLOOP,RIGHTLOOP,
C >            NINLOOP,KINLOOP,NEWKINLOOP,JACDEFORM)
C SUBROUTINE DIAGNOSTIC(K,BADGRAPHNUMBER)
C
C SUBROUTINE EPSILON1N(V4,OUT)
C SUBROUTINE EPSILON2(V3,V4,OUT)
C SUBROUTINE EPSILON2N(V3,V4,OUT)
C SUBROUTINE EPSILON3(V2,V3,V4,OUT)
C SUBROUTINE EPSILON4(V1,V2,V3,V4,OUT)
C SUBROUTINE EPSILONT1(T23,V4,OUT)
C SUBROUTINE EPSILONT2(T12,V3,V4,OUT)
C SUBROUTINE EXCHANGE(V1,V2,C,ORDER)
C
C SUBROUTINE FINDA(VRTX,Q,NQ,ORDER,A,QOK)
C SUBROUTINE FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES)
C
C SUBROUTINE GETCOUNTS(COUNTFACTOR) (*)
C SUBROUTINE GETCOUNTSF(COUNTFACTOR) (*)
C SUBROUTINE GETCUTINFO(GRAPHNUMBER,CUTNUMBER,ORDER,NCUT,ISIGN,
C >            CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP,
C >            NINLOOP,LOOPINDEX,LOOPSIGN)
C
C SUBROUTINE HROTHGAR(NCUT,KCUT,WEIGHT,NRENO,WHATTODO) (*)
C
C SUBROUTINE MAKECUTINFO
C
C SUBROUTINE NEWCUT(XVRTX,ORDER,NEWCUTINIT,XNCUT,XISIGN,
C >            XCUTINDEX,XCUTSIGN,XLEFTLOOP,XRIGHTLOOP,
C >            XNINLOOP,XLOOPINDEX,XLOOPSIGN,CUTFOUND)
C SUBROUTINE NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND)
C SUBROUTINE NEWCHOICE(C,COUNT,V,FAIL,ORDER)
C SUBROUTINE NEWPOINT(A,QSIGN,MAPTYPE,ORDER,K,ABSK,BADPOINT)
C SUBROUTINE NEWRAN
C SUBROUTINE NEXTCHOICE(C,COUNT,V,FAIL,ORDER)
C
C SUBROUTINE RANDOMINIT(IRAN)
C SUBROUTINE RENO(
C >          SUMR,ERRORR,SUMI,ERRORI,
C >          SUMBIS,ERRORBIS,
C >          SUMCHKR,ERRORCHKR,SUMCHKI,ERRORCHKI,FLUCT,
C >          INCLUDED,EXTRACOUNT,OMITTED,
C >          NVALPT,VALPTMAX,KBAD,BADGRAPHNUMBER,BADMAPNUMBER,
C >          NRENO,CPUTIME)
C
C SUBROUTINE TIMING(DELTATIME) (*)
C SUBROUTINE TWOPOINTG(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUT)
C SUBROUTINE TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,OUT)
C SUBROUTINE TWOPOINTGF(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUT)
C SUBROUTINE TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,OUT)
C SUBROUTINE TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,VOUT)
C SUBROUTINE TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,VOUT)
C
C SUBROUTINE VERSION
C SUBROUTINE VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,HV,HA)
C SUBROUTINE VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,HV,HA)
C
C REAL*8 FUNCTION ALPI(MUMSBAR)
C REAL*8 FUNCTION CALSTHRUST(NCUT,KCUT,N) (*)
C REAL*8 FUNCTION CALSTMOMENTS(NCUT,KCUT,N) (*)
C REAL*8 FUNCTION CALSYMOMENTS(NCUT,KCUT,N) (*)
C REAL*8 FUNCTION CALS0(NCUT,KCUT) (*)
C COMPLEX*16 FUNCTION COMPLEXSQRT(Z)
C REAL*8 FUNCTION DELTA(MU,NU)
C REAL*8 FUNCTION DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER)
C REAL*8 FUNCTION EXPM1(X)
C REAL*8 FUNCTION FACTORIAL(N)
C COMPLEX*16 FUNCTION FEYNMAN(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
C COMPLEX*16 FUNCTION FEYNMANF(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
C COMPLEX*16 FUNCTION FEYNMAN0(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
C COMPLEX*16 FUNCTION FEYNMAN0F(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
C REAL*8 FUNCTION INVLOGSQINT(W)
C REAL*8 FUNCTION KN0(T) (*)
C REAL*8 FUNCTION KN(T) (*)
C REAL*8 FUNCTION LOGSQINT(Y)
C LOGICAL FUNCTION ONEPI(CIN,ORDER)
C INTEGER FUNCTION PROPSIGN(VRTX,P,V)
C REAL*8 FUNCTION RANDOM(DUMMY)
C REAL*8 FUNCTION RHO2TO1(PA,PB,ELL)
C REAL*8 FUNCTION RHO2TO2S(PA,PB,ELL)
C REAL*8 FUNCTION RHO2TO2T(PA,PB,ELL)
C REAL*8 FUNCTION RHO2TO3D(PA,PB,ELL)
C REAL*8 FUNCTION RHO2TO3E(PA,PB,ELL)
C REAL*8 FUNCTION RHO3(ABSP1,ABSP2,ABSP3)
C REAL*8 FUNCTION SINHINV(Z)
C REAL*8 FUNCTION SMEAR(RTS)
C REAL*8 FUNCTION SQRTM1(X)
C REAL*8 FUNCTION THRUST(NCUT,KCUT,RTS) (*)
C REAL*8 FUNCTION THRUSTDIST(T) (*)
C REAL*8 FUNCTION XXREAL(Z)
C REAL*8 FUNCTION XXIMAG(Z)
C 
C23456789012345678901234567890123456789012345678901234567890123456789012
C
C A brief introduction to the variables used:
C
C Size of the calculation:
C NLOOPS = number of loops (in cut photon self energy graph).
C NPROPS = number of propagators in graph, = 3 * NLOOPS - 1.
C NVERTS = number of vertices in graph, = 2 * NLOOPS.
C CUTMAX = NLOOPS + 1
C        = maximum number of cut propagators;
C        = number of independent loop momenta needed to determine the
C          propagator momenta, counting the virtual photon momentum.
C The current program is restricted to 0 and 1 virtual loops.
C
C Labels:
C L    = index of loop momenta, L = 0,1,...,NLOOPS.
C        L = 0 normally denontes the virtual photon momentum.
C P    = index of propagator, P = 0,1,...,NPROPS.
C        P = 0 denotes the virtual photon momentum.
C Q(L) = index P of propagator carrying the Lth loop momentum.
C V    = index of vertices, V = 1,...,NVERTS
C
C Momentum variables (MU = 0,1,2,3):
C K(P,MU)       = Momentum of Pth propagator.
C                 For P = 0, this is the virtual photon momentum:
C                 K(0,MU) = 0 for MU = 1, 2, 3 while K(0,0) = RTS.
C ABSK(P)       = Square of the three momentum of Pth propagator.
C KINLOOP(J,MU) = K(LOOPINDEX(J),MU) = momenta of loop propagators.
C KCUT(I,MU)    = K(CUTINDEX(I),MU) = momenta of cut propagators.
C K(Q(L),MU)    = Lth loop momentum, L = 0,...,NLOOPS;
C KC(P,MU)      = complex propagator momenta.
C A(P,L)        = Matrix relating propagator momenta to loop momenta.
C                 K(P,MU) = SUM_{L=0}^{NLOOPS} A(P,L) K(Q(L),MU)
C
C Variables from NEWGRAPH:
C VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of
C              of propagator P. Specifies the supergraph.
C PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3.
C              Also specifies the supergraph.
C
C Variables associated with NEWPOINT and FINDTYPES:
C NMAPS = Number of different maps from random x's to momenta.
C MAPNMUMBER = Number labelling a certain map.
C QS(MAPNUMBER,II) = Label of the IIth propagator that is special
C                   in map number MAPNUMBER.
C QSIGNS(MAPNUMBER,II) = sign needed to relate the conventional 
C       direction of the propagator to that in an elementary scattering
C MAPTYPES(MAPNUMBER) = T2TO3, T2TO2T, T2TO2S, T2TO1.
C
C JACNEWPOINT =1/DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER)
C             = Jacobian for loop momenta L.
C
C Variables from NEWCUT:
C NEWCUTINIT: .TRUE. tells NEWCUT to initialize itself.
C NCUT = Number of cut propagators.
C ISIGN(P) = +1 if propagator P is left of cut, -1 if right, 0 if cut.
C CUTINDEX(I) = Index P of cut propagator I, I = 1,...,CUTMAX.
C CUTSIGN(I) = Sign of cut propagator I I = 1,...,CUTMAX.
C              (+1 if K(P,0) >0 for cut propagator.)
C LEFTLOOP = True iff there is a virtual loop to the left of the cut.
C RIGHTLOOP = True iff there is a virtual loop to the right of the cut.
C NINLOOP = Number of propagators in loop.
C LOOPINDEX(NP) = Index P of NPth propagator around the loop.
C LOOPSIGN(NP) = 1 if propagator direction is same as loop direction.
C               -1 if  direction is opposite to loop direction.
C NP = JCUT: Propagator cut by loopcut.
C CUTFOUND: .TRUE. if NEWCUT found a new cut.
C
C In RENO we use CUTINDEX to define CUT(P) = True if propagator
C    P is cut.
C
C Solving for the propagator energies:
C For NCUT = CUTMAX, cut propagators are P = CUTINDEX(I).
C   with direction of positive energy given by CUTSIGN(I).
C For NCUT = CUTMAX - 1, we define a "loopcut" on the propagator
C   numbered JCUT in order around the loop, 1.LE.JCUT.LE.NINLOOP:
C         CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) and
C         CUTSIGN(CUTMAX) = LOOPSIGN(JCUT).
C Energies of cut propagators are
C   E(I-1) = K(CUTINDEX(I),0) for I = 1,...,CUTMAX.
C and are determined from
C   E(I-1) = CUTSIGN(I) * SQRT( Sum_J [  K(CUTINDEX(I),J)**2 ] ).
C This gives energies E(L) for L = 0,...,NLOOPS. We consider the
C propagators designated by QE(L) = CUTINDEX(L+1) as independent
C and generate the matrix AE(P,L) that gives the propagator energies
C in terms of these independent momenta. This gives the propagator
C energies.
C
C Contour deformation:
C   NEWKINLOOP(MU) =  addition to the momentum going around the loop
C                     caused by deforming the contour. We have
C   Im[ KC(LOOPINDEX(J,MU)) ] = LOOPSIGN(LOOPINDEX(J)) 
C                              * Im[ NEWKINLOOP(J,MU) ] for MU = 1,2,3.
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE RENO(
     >          SUMR,ERRORR,SUMI,ERRORI,
     >          SUMBIS,ERRORBIS,
     >          SUMCHKR,ERRORCHKR,SUMCHKI,ERRORCHKI,FLUCT,
     >          INCLUDED,EXTRACOUNT,OMITTED,
     >          NVALPT,VALPTMAX,KBAD,BADGRAPHNUMBER,BADMAPNUMBER,
     >          NRENO,CPUTIME)
C Array sizes:
      INTEGER SIZE,MAXGRAPHS,MAXMAPS
      PARAMETER (SIZE = 3)
      PARAMETER (MAXGRAPHS = 12)
      PARAMETER (MAXMAPS = 64)
C Out:
      REAL*8 SUMR,ERRORR,SUMI,ERRORI
      REAL*8 SUMBIS,ERRORBIS
      REAL*8 SUMCHKR,ERRORCHKR,SUMCHKI,ERRORCHKI
      REAL*8 FLUCT(MAXGRAPHS,MAXMAPS)
      INTEGER*8 INCLUDED,EXTRACOUNT,OMITTED
      INTEGER NVALPT(-9:6)
      REAL*8 VALPTMAX
      REAL*8 KBAD(0:3*SIZE-1,0:3)
      INTEGER BADGRAPHNUMBER,BADMAPNUMBER
      INTEGER NRENO
      REAL*8 CPUTIME
C
C Computes the cross section integral by Monte Carlo integration.
C
C Latest revision 7 February 2002
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NLOOPS,NPROPS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      REAL*8 BADNESSLIMIT,CANCELLIMIT,THRUSTCUT
      COMMON /LIMITS/ BADNESSLIMIT,CANCELLIMIT,THRUSTCUT
      REAL*8 TIMELIMIT
      COMMON /MAXTIME/ TIMELIMIT
C What the program should do
      CHARACTER*6 MODE
      COMMON /PROGRAMMODE/ MODE
C Graphs to include
      LOGICAL USEGRAPH(MAXGRAPHS)
      COMMON /WHICHGRAPHS/ USEGRAPH
C How many graphs and how many cuts and maps for each:
      INTEGER NUMBEROFGRAPHS
      INTEGER NUMBEROFCUTS(MAXGRAPHS)
      INTEGER NUMBEROFMAPS(MAXGRAPHS)
      COMMON /GRAPHCOUNTS/ NUMBEROFGRAPHS,NUMBEROFCUTS,NUMBEROFMAPS
C Order of perturbation theory
      INTEGER ORDER
C Momenta:
      REAL*8 K(0:3*SIZE-1,0:3),ABSK(0:3*SIZE-1)
C Matrices:
      INTEGER A(0:3*SIZE-1,0:SIZE)
C NEWGRAPH variables:
      INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3)
      LOGICAL GRAPHFOUND
      INTEGER GRAPHNUMBER
C FINDA variable:
      LOGICAL QOK
C MAP variables:
      INTEGER NMAPS,MAPNUMBER
      INTEGER QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE)
      INTEGER Q(0:SIZE),QSIGN(0:SIZE)
      CHARACTER*6 MAPTYPES(MAXMAPS)
      CHARACTER*6 MAPTYPE
C Variable from CHECKPOINT:
      REAL*8 BADNESS
C Problem report from NEWPOINT
      LOGICAL BADNEWPOINT
C Logical variables to tell how to treat point:
      LOGICAL XTRAPOINTQ, BADPOINTQ
C Functions:
      REAL*8 XXREAL,XXIMAG
C Index variables:
      INTEGER L,P,MU
C Hrothgar dummy variables:
      REAL*8 KCUT0(SIZE+1,0:3)
C Reno size and counting variables:
      INTEGER GROUPSIZE(MAXGRAPHS,MAXMAPS)
      INTEGER GROUPSIZEGRAPH(MAXGRAPHS)
      INTEGER GROUPSIZETOTAL
      COMMON /MONTECARLO/GROUPSIZE,GROUPSIZEGRAPH,GROUPSIZETOTAL
      INTEGER POINT
C Reno results variables:
      REAL*8 SQRSUMR,SQRSUMCHKR
      REAL*8 SQRSUMI,SQRSUMCHKI
      REAL*8 SQRSUMBIS
      COMPLEX*16 INTEGRAL,INTEGRALCHK
      REAL*8 INTEGRALBIS
C Calculate variables:
      COMPLEX*16 VALUE,VALUECHK
      REAL*8 MAXPART
      REAL*8 VALPT,LOGVALPT
      LOGICAL REPORT,DETAILS
      COMMON /CALCULOOK/ REPORT,DETAILS
C Timing variables
      REAL*8 DELTATIME
C
C------------------------------ Begin ----------------------------------
C
C Dummy variables for Hrothgar.
C
      DO L = 1,SIZE+1
        DO MU = 0,3
         KCUT0(L,MU) = 1.0D0
        ENDDO
      ENDDO
C
C Initialize CPUTIME and NRENO. Call to TIMING starts the clock.
C
      CPUTIME = 0.0
      NRENO = 0
      CALL TIMING(DELTATIME)
C
C Initialize sums for loop over groups of Reno points. The sums
C will be updated for each group. Within a group, the quantities
C corresponding to SUMxxR + i SUMxxI are complex variables called
C INTEGRALxx.
C
      SUMR = 0.0D0
      SUMI = 0.0D0
      SUMBIS = 0.0D0
      SUMCHKR = 0.0D0
      SUMCHKI = 0.0D0
C
      SQRSUMR = 0.0D0
      SQRSUMI = 0.0D0
      SQRSUMBIS = 0.0D0
      SQRSUMCHKR = 0.0D0
      SQRSUMCHKI = 0.0D0
C
      DO GRAPHNUMBER = 1,NUMBEROFGRAPHS
      DO MAPNUMBER = 1,NUMBEROFMAPS(GRAPHNUMBER)
        FLUCT(GRAPHNUMBER,MAPNUMBER) = 0.0D0
      ENDDO
      ENDDO
C
      DO L = -9,6
        NVALPT(L) = 0
      ENDDO
      VALPTMAX = 0.0D0
      INCLUDED = 0
      EXTRACOUNT = 0
      OMITTED = 0
C
C Tell CALCULATE not to report its findings for each calculation
C
      REPORT = .FALSE.
C
C Initialize integrals for first group.
C
      INTEGRAL = (0.0D0,0.0D0)
      INTEGRALBIS = 0.0D0
      INTEGRALCHK = (0.0D0,0.0D0)
C
C Loop over groups of points.
C
      DO WHILE (CPUTIME.LT.TIMELIMIT)
      NRENO = NRENO + 1
C
C Call Hrothgar to tell him to that we are starting a new group.
C
      CALL HROTHGAR(1,KCUT0,1.0D0,1,'STARTGROUP')
C
C Get a new graph. The starting value for GRAPHNUMBER depends
C on the order we want. Graphs for ORDER = 2 are numbered 1,...,10
C and those for ORDER = 1 are numbered 11,12. For MODE = nlo,
C we will do the ORDER = 2 graphs first, then continue with the
C first order graphs. Thus we wait for NEWGRAPH to return
C GRAPHFOUND = false, then reset it (see ELSE part of IF(GRAPHFOUND)).
C
      GRAPHFOUND = .TRUE.
C
      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
       WRITE(NOUT,*)'Not programmed for this mode.',MODE
       STOP
      ENDIF
C
      DO WHILE (GRAPHFOUND)
      CALL NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND)
      IF (GRAPHFOUND) THEN
      GRAPHNUMBER = GRAPHNUMBER + 1
C
C Calculate number of maps NMAPS, index arrays QS,
C types MAPTYPES, and signs QSIGNS associated with the maps.
C
      CALL FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES)
C
C Check if we were supposed to use this graph (USEGRAPH is
C set in the main program.)
C
      IF (USEGRAPH(GRAPHNUMBER)) THEN
C
C Loop over choices of maps from x's to loop momenta.
C
      DO MAPNUMBER = 1,NMAPS
C
      MAPTYPE = MAPTYPES(MAPNUMBER)
      DO L = 0,NLOOPS
        Q(L) = QS(MAPNUMBER,L)
        QSIGN(L) = QSIGNS(MAPNUMBER,L)
      ENDDO
C
      CALL FINDA(VRTX,Q,NLOOPS,ORDER,A,QOK)
C
C Loop over Reno points within a group.
C
      DO POINT = 1,GROUPSIZE(GRAPHNUMBER,MAPNUMBER)
C
C Call Hrothgar to tell him that we are starting a new point.
C
      CALL HROTHGAR(1,KCUT0,1.0D0,1,'STARTPOINT')
C
C Get a new point. Check on its badness. If it is too bad,
C or if NEWPOINT reported a problem, we omit the point after
C notifying Hrothgar.
C
      BADPOINTQ = .FALSE.
      XTRAPOINTQ = .FALSE.
      CALL NEWPOINT(A,QSIGN,MAPTYPE,ORDER,K,ABSK,BADNEWPOINT)
      IF (BADNEWPOINT) THEN
        CALL HROTHGAR(1,KCUT0,1.0D0,1,'BADPOINT  ')
        BADPOINTQ = .TRUE.
      ENDIF
      CALL CHECKPOINT(K,ABSK,PROP,ORDER,BADNESS)
      IF (BADNESS.GT.100*BADNESSLIMIT) THEN
        CALL HROTHGAR(1,KCUT0,1.0D0,1,'BADPOINT  ')
        BADPOINTQ = .TRUE.
      ELSE IF (BADNESS.GT.BADNESSLIMIT) THEN
        CALL HROTHGAR(1,KCUT0,1.0D0,1,'XTRAPOINT ')
        XTRAPOINTQ = .TRUE.
      ENDIF
C
C If the point is not too bad, we can call CALCULATE.
C The final state momenta found, KCUT, along with the corresponding
C weights, are reported to Hrothgar by CACULATE.
C Then call Hrothgar to tell him that we are done with this point.
C
      IF (.NOT.BADPOINTQ) THEN
      CALL CALCULATE(VRTX,GRAPHNUMBER,ORDER,K,ABSK,
     >               QS,QSIGNS,MAPTYPES,NMAPS,VALUE,MAXPART,VALUECHK)
      ENDIF
C
C Add contribution from this point to integral.
C We count the point if Maxvalue/|Value| < Cancellimit.
C
      IF (.NOT.BADPOINTQ) THEN
        IF ( MAXPART.GT. 100*CANCELLIMIT*ABS(XXREAL(VALUE)) ) THEN
          CALL HROTHGAR(1,KCUT0,1.0D0,1,'BADPOINT  ')
          BADPOINTQ = .TRUE.
        ELSE IF ( MAXPART.GT. CANCELLIMIT*ABS(XXREAL(VALUE)) ) THEN
          CALL HROTHGAR(1,KCUT0,1.0D0,1,'XTRAPOINT ')
          XTRAPOINTQ = .TRUE.
        ENDIF
      ENDIF
C      
      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
C
C For diagnostic purposes, we need VALPT, the contribution to
C the integral being calculated from this point, normalized such
C that the integral is the sum over all points chosen of VALPT
C divided by the total number of points, NRENO * GROUPSIZETOTAL.
C
        VALPT = ABS(XXREAL(VALUE))*GROUPSIZETOTAL
        LOGVALPT = LOG10(VALPT)
        DO L = -9,6
          IF((LOGVALPT.GE.L).AND.(LOGVALPT.LT.(L+1))) THEN
            NVALPT(L) = NVALPT(L) + 1
          ENDIF
        ENDDO
        IF (VALPT.GT.VALPTMAX) THEN
          VALPTMAX = VALPT
          DO P = 1,NPROPS
          DO MU = 1,3
            KBAD(P,MU) = K(P,MU)
          ENDDO
          ENDDO
          BADGRAPHNUMBER = GRAPHNUMBER
          BADMAPNUMBER = MAPNUMBER
        ENDIF
      ELSE IF ((.NOT.BADPOINTQ).AND.(XTRAPOINTQ) ) THEN
C
C For points that are 'extra', we include the value of
C the integrand in the INTEGRALBIS, which will provide an estimate
C or the effect of the cutoffs.
C
        INTEGRALBIS = INTEGRALBIS + XXREAL(VALUE)
        EXTRACOUNT = EXTRACOUNT + 1
C
      ELSE
        OMITTED = OMITTED + 1
      ENDIF
C
C End of loop over POINT.
C
      CALL HROTHGAR(1,KCUT0,1.0D0,1,'POINTDONE ')
      ENDDO
C
C End of loop over MAPNUMBER.
C
      ENDDO
C
C End for IF (USEGRAPH(GRAPHNUMBER)) THEN
C
      ENDIF
C
C End of loop DO WHILE (GRAPHFOUND)/ IF (GRAPHFOUND).
C In the case MODE = nlo, if GRAPHFOUND was false and ORDER = 2,
C we have run out of the second order graphs and we should continue to 
C find the first order (Born) graphs.
C
      ELSE
        IF ((MODE.EQ.'nlo   ').AND.(ORDER.EQ.2)) THEN
          GRAPHFOUND = .TRUE.
          ORDER = 1
          NLOOPS = NLOOPS1
          NPROPS = NPROPS1
        ENDIF
      ENDIF
      ENDDO
C
C Call Hrothgar to tell him that we are done with this group.
C
      CALL HROTHGAR(1,KCUT0,1.0D0,1,'GROUPDONE ')
C
C Add results from this group to the SUM variables. 
C
      SUMR = SUMR + XXREAL(INTEGRAL)
      SUMI = SUMI + XXIMAG(INTEGRAL)
      SUMBIS = SUMBIS + INTEGRALBIS
      SUMCHKR = SUMCHKR + XXREAL(INTEGRALCHK)
      SUMCHKI = SUMCHKI + XXIMAG(INTEGRALCHK)
C
      SQRSUMR = SQRSUMR + XXREAL(INTEGRAL)**2
      SQRSUMI = SQRSUMI + XXIMAG(INTEGRAL)**2
      SQRSUMBIS = SQRSUMBIS + INTEGRALBIS**2
      SQRSUMCHKR = SQRSUMCHKR + XXREAL(INTEGRALCHK)**2
      SQRSUMCHKI = SQRSUMCHKI + XXIMAG(INTEGRALCHK)**2
C
C Reset the INTEGRAL variables for the next group.
C
      INTEGRAL = (0.0D0,0.0D0)
      INTEGRALBIS = 0.0D0
      INTEGRALCHK = (0.0D0,0.0D0)
C
C End of loop DO WHILE (CPUTIME.LT.TIMELIMIT)
C
      CALL TIMING(DELTATIME)
      CPUTIME = CPUTIME + DELTATIME
      ENDDO
C
C Calculate the SUM results.
C
      SUMR = SUMR/NRENO
      SUMI = SUMI/NRENO
      SUMBIS = SUMBIS/NRENO
      SUMCHKR = SUMCHKR/NRENO
      SUMCHKI = SUMCHKI/NRENO
C
      SQRSUMR = SQRSUMR/NRENO
      SQRSUMI = SQRSUMI/NRENO
      SQRSUMBIS = SQRSUMBIS/NRENO
      SQRSUMCHKR = SQRSUMCHKR/NRENO
      SQRSUMCHKI = SQRSUMCHKI/NRENO
C
      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
      ENDIF
      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))
C
      DO GRAPHNUMBER = 1,NUMBEROFGRAPHS
      DO MAPNUMBER = 1,NUMBEROFMAPS(GRAPHNUMBER)
        FLUCT(GRAPHNUMBER,MAPNUMBER) =
     >         FLUCT(GRAPHNUMBER,MAPNUMBER)/NRENO
      ENDDO
      ENDDO
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C                 Subroutines associated with NEWGRAPH                 C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C In:
      INTEGER ORDER
C Out:
      INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3)
      LOGICAL GRAPHFOUND
C
C 8 November 1992 Home fixup of bugs.
C 28 November 1992 Add check that we get each graph only once.
C 13 July 1994
C 13 April 1996
C  1 January 1998 Add output variable SELFPROP. Omit NPERMS as output.
C  7 December 2001 Subtract output variable SELFPROP.
C----------
C Varibles:
C VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of
C             of propagator P. Specifies the supergraph for output.
C PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3.
C              Also specifies the supergraph for output.
C C(V,I) = Index of Ith vertex connected to vertex V.
C        V = 1,...,NVERTS; I =1,2,3; C(V,I) = 1,...,NVERTS and -1,-2.
C        Here C(V,1).LE.C(V,2).LE.C(V,3).
C        This is the fundamental specification of the supergraph.
C N = Number of permutations of the vertices that give same graph.
C GRAPHFOUND = True when the subroutine finds a new graph.
C COUNT(V) = Number of vertices connected to vertex V.
C Vertex 1 is automatically connected to the photon "-1":C(1,1) = -1.
C Vertex 2 is automatically connected to the photon "-2":C(2,1) = -2.
C The freedom to renumber the vertices 3,...,NVERTS is used to choose
C a standard numbering:
C  We choose the numbering with the smallest value of C(1,1);
C  For numberings with equal values of C(1,1) we choose the numbering
C    with the smallest value of C(1,2);
C  For numberings with equal values of C(1,2) we choose the numbering
C    with the smallest value of C(1,3);
C  For numberings with equal values of C(1,3) we choose the numbering
C    with the smallest value of C(2,1); et cetera.
C
C The connections are generated starting with vertex 1.  We make
C a choice of connections for vertex V, then move on to make a choice
C for connections to vertex V + 1.  When we are out of choices for
C connections to vertex V, we step back and try the next choice for
C vertex V - 1.
C
C Connections to the external boson:
C In C(V,I) we assign the first connection of vertex 1 to be vertex "-1"
C while the first connection of vertex 2 is vertex "-2." This numbering
C is convenient for working out C(V,I). In reporting the results, 
C however, we label the external boson with propagator 0, so that
C PROP(1,1) = PROP(2,1) = 0. Then propagator 0 attaches to vertices
C 1 and 2: VERT(0,1) = 2, VERT(0,2) = 1.
C----------
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NPROPS,NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      INTEGER C(2*SIZE,3),COUNT(2*SIZE)
      INTEGER NUSED(2*SIZE),VA,VB
      INTEGER V,VV,I,P,NPERMS
      LOGICAL ONEPI,OK
      LOGICAL FAIL,NEWSTART,UP
      DATA NEWSTART/.TRUE./
      SAVE
C
C Initializations.
C
      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
      ENDIF
C
      IF (NEWSTART) THEN
        DO  VV = 1,NVERTS
          COUNT(VV) = 0
          DO I = 1,3
            C(VV,I) = 0
          ENDDO
        ENDDO
        C(1,1) = -1
        COUNT(1) = 1
        C(2,1) = -2
        COUNT(2) = 1
        V = 1
        UP = .TRUE.
      ENDIF
C
C Move from level to level in tree structure of choices. When UP
C is true, we have moved to a higher V; when UP is false, we have
C moved to a smaller V.
C
      DO WHILE (.TRUE.)
C
      IF (UP) THEN
        CALL NEWCHOICE(C,COUNT,V,FAIL,ORDER)
      ELSE
        CALL NEXTCHOICE(C,COUNT,V,FAIL,ORDER)
      ENDIF
      IF (FAIL) THEN
C
C If we couldn't find connectections for vertex V, then we should
C step back and look for the next connections for vertex V-1.  But if
C V is currently 1, then we can't step back, so we have found all
C the graphs.
C
        IF (V.GT.1) THEN
          V = V - 1
          UP = .FALSE.
        ELSE
          NEWSTART = .TRUE.
          GRAPHFOUND = .FALSE.
          DO P = 0,NPROPS
           DO I = 1,2
            VRTX(P,I) = 0
           ENDDO
          ENDDO
          RETURN
        ENDIF
C
C If we did find connections for vertex V, then we should step onward
C and look for new connections for vertex V+1.  But if V is currently
C equal to NVERTS, then we must have found a graph.  We check for
C validity. If it is valid, we exit with the results, setting V and UP
C so that the next time the subroutine is called we will start looking
C for the next connections for vertex V-1.  If our graph is not valid
C (eg. one particle reducible) then we step back to look for new
C connections for vertex V-1 right away.
C
      ELSE
        IF (V.LT.NVERTS) THEN
          V = V + 1
          UP = .TRUE.
        ELSE
          V = V - 1
          UP = .FALSE.
          IF (ONEPI(C,ORDER)) THEN
          CALL CHECK(C,NPERMS,ORDER,OK)
            IF (OK) THEN
              NEWSTART = .FALSE.
              GRAPHFOUND = .TRUE.
C
C Exit. We translate the results for C(V,I) into VRTX(P,I), I = 1,2,
C and PROP(P,I), I = 1,2,3. Here NUSED(V) denotes how many propagators
C we have so far assigned connecting to vertex V.
C
              DO VV = 1,NVERTS
                NUSED(VV) = 0
              ENDDO
              VRTX(0,1) = 2
              VRTX(0,2) = 1
              PROP(1,1) = 0
              NUSED(1)  = 1
              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)
                  VRTX(P,1) = VA
                  NUSED(VA) = NUSED(VA) + 1
                  PROP(VA,NUSED(VA)) = P
                  VRTX(P,2) = VB
                  NUSED(VB) = NUSED(VB) + 1
                  PROP(VB,NUSED(VB)) = P
                  P = P+1
                ENDIF
              ENDDO
              ENDDO
              IF (P.NE.NPROPS+1) THEN
                WRITE(NOUT,*)'SNAFU in NEWGRAPH',P-1,NPROPS
                STOP
              ENDIF
              DO VV = 1,NVERTS
                IF (NUSED(VV).NE.3) THEN
                  WRITE(NOUT,*)'Problem in NEWWGRAPH',VV,NUSED(VV)
                  STOP
                ENDIF
              ENDDO
C
C OK. We are ready to return.
C
              RETURN
C
            ENDIF
          ENDIF
        ENDIF
      ENDIF
C
C End main loop "DO WHILE (.TRUE.)"
C
      ENDDO
C
      END
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE NEWCHOICE(C,COUNT,V,FAIL,ORDER)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C
      INTEGER C(2*SIZE,3),COUNT(2*SIZE)
      INTEGER V
      LOGICAL FAIL
      INTEGER ORDER
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      INTEGER VV,K
      LOGICAL FOUND
      SAVE
C
      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
      ENDIF
C
C If COUNT(V) = 3, then we don't need any more connections to this
C vertex. If COUNT(V) = 0, then we appear to be starting to make a
C vacuum graph after having completed a graph with too few loops, so
C we should just quit.
C
      IF (COUNT(V).EQ.3) THEN
          FAIL = .FALSE.
          RETURN
      ELSE IF (COUNT(V).EQ.0) THEN
          FAIL = .TRUE.
          RETURN
      ENDIF
C
C Generate starting choice for new vertices to connect to V. We connect
C to the vertices with the smallest possible indices.
C
      FAIL = .FALSE.
      VV = V + 1
      DO K = (COUNT(V) + 1),3
        FOUND = .FALSE.
        DO WHILE (.NOT.FOUND)
          IF (VV.GT.NVERTS) THEN
              FAIL = .TRUE.
              RETURN
          ENDIF
          IF ( COUNT(VV).LT.3) THEN
            COUNT(V) = COUNT(V) + 1
            C(V,K) = VV
            COUNT(VV) = COUNT(VV) + 1
            C(VV,COUNT(VV)) = V
            FOUND = .TRUE.
          ELSE
            VV = VV + 1
          ENDIF
        ENDDO
      ENDDO
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE NEXTCHOICE(C,COUNT,V,FAIL,ORDER)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C
      INTEGER C(2*SIZE,3),COUNT(2*SIZE)
      INTEGER V
      LOGICAL FAIL
      INTEGER ORDER
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      INTEGER VV,VVV,V2,V3,I
      LOGICAL FOUND
      SAVE
C
      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
      ENDIF
C
C First, erase any connections among higher index vertices.
C
      DO VV = V+1,NVERTS
      DO VVV = V+1,NVERTS
      DO I = 1,3
        IF (C(VV,I).EQ.VVV) THEN
          C(VV,I) = 0
          COUNT(VV) = COUNT(VV) - 1
        ENDIF
      ENDDO
      ENDDO
      ENDDO
C
C Next, get the next connection set for vertex V.
C First, we try to find a new third connection for V.
C
      V3 = C(V,3)
C If third connection was to a lower index vertex, we can't change it.
      IF (V3.LE.V) THEN
        FAIL = .TRUE.
        RETURN
      ENDIF
C Erase third connection:
      C(V,3) = 0
      C(V3,COUNT(V3)) = 0
      COUNT(V) = COUNT(V) - 1
      COUNT(V3) = COUNT(V3) - 1
C Look for a new one:
      DO WHILE (V3.LT.NVERTS)
        V3 = V3 + 1
        IF ((COUNT(V3-1).GT.0).AND.(COUNT(V3).LT.3)) THEN
          COUNT(V) = COUNT(V) + 1
          COUNT(V3) = COUNT(V3) + 1
          C(V,3) = V3
          C(V3,COUNT(V3)) = V
          FAIL = .FALSE.
          RETURN
        ENDIF
      ENDDO
C
C We have failed to find a new third connection for V, so
C try for a second connection.  
C
      V2 = C(V,2)
C If second connection was to a lower index vertex, we can't change it.
      IF (V2.LE.V) THEN
        FAIL = .TRUE.
        RETURN
      ENDIF
C Erase second connection:
      C(V,2) = 0
      C(V2,COUNT(V2)) = 0
      COUNT(V) = COUNT(V) - 1
      COUNT(V2) = COUNT(V2) - 1
C Look for a new one:
      DO WHILE (V2.LT.NVERTS)
        V2 = V2 + 1
        IF ((COUNT(V2-1).GT.0).AND.(COUNT(V2).LT.3)) THEN
          COUNT(V) = COUNT(V) + 1
          COUNT(V2) = COUNT(V2) + 1
          C(V,2) = V2
          C(V2,COUNT(V2)) = V
C We found a new second connection.  Now get a third connection.
C---
          V3 = V2
          FOUND = .FALSE.
          DO WHILE (.NOT.FOUND)
            IF ( COUNT(V3).LT.3) THEN
              COUNT(V) = COUNT(V) + 1
              COUNT(V3) = COUNT(V3) + 1
              C(V,3) = V3
              C(V3,COUNT(V3)) = V
              FOUND = .TRUE.
            ELSE
              V3 = V3 + 1
              IF (V3.GT.NVERTS) THEN
                FAIL = .TRUE.
                RETURN
              ENDIF
            ENDIF
          ENDDO
C---
C We have found a good third connection also, so we are done!
          FAIL = .FALSE.
          RETURN
        ENDIF
      ENDDO
C We couldn't find a second connection
C
      FAIL = .TRUE.
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      LOGICAL FUNCTION ONEPI(CIN,ORDER)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
      INTEGER CIN(2*SIZE,3)
      INTEGER ORDER
C
C Checks that the graph is connected and 1 particle irreducible.
C Modified 26 July 1994.
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      LOGICAL LEFT(2*SIZE),CHANGE
      INTEGER C(2*SIZE,3)
      INTEGER V,I,V1,V2,I1,I2
      SAVE
C
      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
      ENDIF
C
C Initialize
C
      ONEPI = .TRUE.
C
      DO V = 1,NVERTS
      DO I = 1,3
        C(V,I) = CIN(V,I)
      ENDDO
      ENDDO
C
C Set up loops to successively erase each propagator.
C
      DO V1 = 1,NVERTS
      DO I1 = 1,3
      V2 = C(V1,I1)
      IF (V2.GT.V1) THEN
      DO I2 = 1,3
      IF (C(V2,I2).EQ.V1) THEN
        C(V1,I1) = 0
        C(V2,I2) = 0
C--We have now erased the propagator from V1 to V2.  Let's see if
C  the remaining graph is connected.
        DO V = 1,NVERTS
         LEFT(V) = .FALSE.
        ENDDO
C Construct Left set.
        LEFT(1) = .TRUE.
        CHANGE = .TRUE.
        DO WHILE (CHANGE)
          CHANGE = .FALSE.
          DO V = 1,NVERTS
          DO I = 1,3
            IF ( (1.LE.C(V,I)).AND.(C(V,I).LE.NVERTS) ) THEN
             IF ( LEFT(V) .AND. (.NOT.LEFT(C(V,I))) ) THEN
              CHANGE = .TRUE.
              LEFT(C(V,I)) = .TRUE.
             ENDIF
            ENDIF
          ENDDO
          ENDDO
        ENDDO
C Check for connectedness
        DO V = 1,NVERTS
         IF ( .NOT.LEFT(V) ) THEN
            ONEPI = .FALSE.
            RETURN
         ENDIF
        ENDDO
C--OK, that remaining graph was OK.  Restore the graph.
        C(V1,I1) = V2
        C(V2,I2) = V1
      ENDIF
      ENDDO
      ENDIF
      ENDDO
      ENDDO
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHECK(CIN,NPERMS,ORDER,OK)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
      INTEGER CIN(2*SIZE,3),NPERMS,ORDER
      LOGICAL OK
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      INTEGER C(2*SIZE,3),V(2*SIZE)
      INTEGER L,I,VV
C
C Modified 15 February 2002.
C
      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
      ENDIF
C
      DO VV = 1,NVERTS
      DO I = 1,3
       C(VV,I) = CIN(VV,I)
      ENDDO
      ENDDO
      L = NVERTS
      NPERMS = 0
      OK = .TRUE.
C
C "CALL PERMUTATIONS(L,C)"
C
C-----
C "SUBROUTINE PERMUTATIONS(L,C)"
C Mock subroutine that generates each element of the permutation
C group S_(L-2), applies it to C, and calls CHECKOUT(C,CIN,ORDER,N,OK).
C If OK = False is returned, the graph C was no good and we exit
C from CHECK immediately. The structure is
C     SUBROUTINE PERMUTATIONS(L,C)
C     IF (L.EQ.4) THEN
C       CALL CHECKOUT(C,CIN,ORDER,NPERMS,OK)
C       IF (.NOT.OK) return from check
C       CALL EXCHANGE(3,4,C,ORDER)
C       CALL CHECKOUT(C,CIN,ORDER,NPERMS,OK)
C       IF (.NOT.OK)  return from check
C       CALL EXCHANGE(3,4,C,ORDER)
C       RETURN
C     ENDIF
C     DO V(L) = L,3,-1
C       CALL EXCHANGE(V(L),L,C,ORDER)
C       CALL PERMUTATIONS(L-1,C)
C       CALL EXCHANGE(V(L),L,C,ORDER)
C     ENDDO
C     RETURN
C     END
C
  1   CONTINUE
      IF (L.EQ.4) THEN
         CALL CHECKOUT(C,CIN,ORDER,NPERMS,OK)
         IF (.NOT.OK) RETURN
         CALL EXCHANGE(3,4,C,ORDER)
         CALL CHECKOUT(C,CIN,ORDER,NPERMS,OK)
         IF (.NOT.OK) RETURN
         CALL EXCHANGE(3,4,C,ORDER)
C "RETURN" Which exit depends on whether we are at the top level.
         IF (L.LT.NVERTS) THEN
           GO TO 2
         ELSE
           GO TO 4
         ENDIF
      ENDIF
C "DO V(L) = L,3,-1"
      V(L) = L
  3   CONTINUE
      CALL EXCHANGE(V(L),L,C,ORDER)
      L = L - 1
C "CALL PERMUTATIONS(L,C)"
      GO TO 1
C Return from mock subroutine comes here for lower levels:
  2   CONTINUE
      L = L + 1
      CALL EXCHANGE(V(L),L,C,ORDER)
      V(L) = V(L) - 1
C "ENDDO"
      IF (V(L).GE.3) THEN
        GO TO 3
      ENDIF
C "RETURN" Executed from level L as long as L<NVERTS, else we are done.
      IF (L.LT.NVERTS) THEN
        GO TO 2
      ENDIF
  4   CONTINUE
C-----
C Come to here if graph CIN was OK, with NPERMS = number of permutations
C that gave a distinct numbering of the vertices.
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHECKOUT(C,CIN,ORDER,NPERMS,OK)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
      INTEGER C(2*SIZE,3),CIN(2*SIZE,3),ORDER,NPERMS
      LOGICAL OK
C
C Test if graph C (with vertices permuted) is "less than," or
C "greater than," or equal to the original graph CIN using
C the standard ordering of graphs.  If C > CIN we leave unchanged the
C count NPERMS of how many vertex interchanges give the same graph and
C return OK = True.  If C = CIN, we add one to NPERMS, and we
C still return OK = True.  If C < CIN, then we should not have
C generated CIN, so we return OK = False.
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      INTEGER V,I
C
      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
      ENDIF
C
      DO V = 1,NVERTS
      DO I = 1,3
       IF (C(V,I).LT.CIN(V,I)) THEN
         OK = .FALSE.
         RETURN
       ELSE IF (C(V,I).GT.CIN(V,I)) THEN
         OK = .TRUE.
         RETURN
       ENDIF
      ENDDO
      ENDDO
C
C Come to here if the new graph C is the same as CIN.
C
      OK = .TRUE.
      NPERMS = NPERMS + 1
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE EXCHANGE(V1,V2,C,ORDER)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
      INTEGER C(2*SIZE,3)
      INTEGER V1,V2,ORDER
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      INTEGER TEMP1,TEMP2,I,V
      LOGICAL CHANGE
C
      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
      ENDIF
C
      DO I = 1,3
        TEMP1 = C(V1,I)
        TEMP2 = C(V2,I)
        C(V1,I) = TEMP2
        C(V2,I) = TEMP1
      ENDDO
C
      DO V = 1,NVERTS
        CHANGE = .FALSE.
        DO I = 1,3
          IF (C(V,I).EQ.V1) THEN
            C(V,I) = V2
            CHANGE = .TRUE.
          ELSE IF (C(V,I).EQ.V2) THEN
            C(V,I) = V1
            CHANGE = .TRUE.
          ENDIF
        ENDDO
        IF (CHANGE) THEN
C
C Put vertices connected to vertex V in order
C--
          IF (C(V,2).LT.C(V,1)) THEN
            TEMP1 = C(V,1)
            TEMP2 = C(V,2)
            C(V,1) = TEMP2
            C(V,2) = TEMP1
          ENDIF
          IF (C(V,3).LT.C(V,1)) THEN
            TEMP1 = C(V,1)
            TEMP2 = C(V,3)
            C(V,1) = TEMP2
            C(V,3) = TEMP1
          ELSE IF (C(V,3).LT.C(V,2)) THEN
            TEMP1 = C(V,2)
            TEMP2 = C(V,3)
            C(V,2) = TEMP2
            C(V,3) = TEMP1
          ENDIF
C--
        ENDIF
      ENDDO
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C            End of subroutines associated with NEWGRAPH               C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE FINDA(VRTX,Q,NQ,ORDER,A,QOK)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C In:
      INTEGER VRTX(0:3*SIZE-1,2),Q(0:SIZE),NQ,ORDER
C Out:
      INTEGER A(0:3*SIZE-1,0:SIZE)
      LOGICAL QOK
C
C Finds matrix A relating propagator momenta to loop momenta.
C
C VRTX(P,N)     specifies the graph considered
C Q(L)           specifies the propagators to be considered independent
C NQ             specifies how many entries of Q should be considered
C   NQ = NLOOPS  all the entries in Q should be considered.
C                If Q(0),Q(1),...,Q(NLOOPS) are independent then
C                FINDA generates the matrix A and sets QOK = .TRUE.
C                Otherwise the generation of A fails and QOK = .FALSE.
C   NQ < NLOOPS  only first NQ entries in Q should be considered.
C                If Q(0),Q(1),...,Q(NQ) are independent then
C                FINDA sets QOK = .TRUE.
C                Otherwise  QOK = .FALSE.
C                In either case, a complete A is not generated.
C
C L              index of loop momenta, L = 0,1,...,NLOOPS.
C                L = 0 normally denontes the virtual photon momentum.
C P              index of propagator, P = 0,1,...,NPROPS.
C                P = 0 denotes the virtual photon momentum.
C V              index of vertices, V = 1,...,NVERTS
C A(P,L)         matrix relating propagator momenta to loop momenta.
C                K(P) = Sum_L A(P,L) K(Q(L)).
C VRTX(P,1) = V means that the vertex connected to the tail of
C                propagator P is V.
C VRTX(P,2) = V means that the vertex connected to the head of
C                propagator P is V.
C Q(L) = P       means that we consider the Lth loop momentum to
C                be that carried by propagator P.
C CONNECTED(V,J) = P means that the Jth propagator connected to
C                vertex V is P.
C FIXED(P) = True means that we have determined the momentum carried
C                by propagator P.
C FINISHED(V) = True means that we have determined the momenta carried
C                by all the propagators connected to vertex V.
C PROPSIGN(VRTX,P,V) is a function that returns +1 if the head of
C                propagator P is at V, -1 if the tail is at V.
C COUNT          is the number of propagators connected to the vertex
C                under consideration such that FIXED(P) = True. If
C                COUNT = 2, then we can fix another propagator momentum.
C 3 July 1994
C 19 December 1995
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NLOOPS,NPROPS,NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      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
C
      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
      ENDIF
C
      IF((NQ.LT.1).OR.(NQ.GT.NLOOPS)) THEN
        WRITE(NOUT,*)'NQ out of range in FINDA'
      ENDIF
C
C First check to see that the same propagator hasn't been
C assigned to two loop variables.
C
      DO L1 = 0,NQ-1
       DO L2 = L1+1,NQ
        IF (Q(L1).EQ.Q(L2)) THEN
          QOK = .FALSE.
          RETURN
        ENDIF
       ENDDO
      ENDDO
C
C Initialization.
C
      QOK = .FALSE.
C
      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
         ENDIF
        ENDDO
      ENDDO
C
      DO P = 0,NPROPS
        DO L = 0,NLOOPS
          A(P,L) = 0
        ENDDO
      ENDDO
      DO L = 0,NQ
        A(Q(L),L) = 1
      ENDDO
C
      DO P = 0,NPROPS
        FIXED(P) = .FALSE.
      ENDDO
      DO L = 0,NQ
        FIXED(Q(L)) = .TRUE.
      ENDDO
C
      DO V = 1,NVERTS
        FINISHED(V) = .FALSE.
      ENDDO
C
      CHANGE = .TRUE.
C
C Start.
C
      DO WHILE (CHANGE)
      CHANGE = .FALSE.
C
      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
         ENDIF
        ENDDO
C
C There are 3 already fixed propagators conencted to this vertex, so
C we must check to see if the momenta coming into the vertex sum to
C zero.
C
        IF (COUNT.EQ.3) THEN
          DO L = 0,NQ
            SUM(L) = 0
          ENDDO
          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)
            ENDDO
          ENDDO
          DO L = 0,NQ
C
C Dependent propagators given to FINDA.
C
            IF (SUM(L).NE.0) THEN
              QOK = .FALSE.
              RETURN
C
            ENDIF
          ENDDO
          FINISHED(V) = .TRUE.
          CHANGE = .TRUE.
C
C There are two already fixed propagators connected to this vertex,
C so we should determine the momentum carried by the remaining,
C unfixed, propagator.
C
        ELSE IF (COUNT.EQ.2) THEN
          DO L = 0,NQ
            SUM(L) = 0
          ENDDO
          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)
              ENDDO
            ELSE
              PTOFIX = P
            ENDIF
          ENDDO
          SIGN = PROPSIGN(VRTX,PTOFIX,V)
          DO L = 0,NQ
            A(PTOFIX,L) =  - SIGN * SUM(L)
          ENDDO
          FIXED(PTOFIX) = .TRUE.
          FINISHED(V) = .TRUE.
          CHANGE = .TRUE.
        ENDIF
C
C Close loop DO V = 1,NVERTS ; IF (.NOT.FINISHED(V)) THEN.
C
      ENDIF
      ENDDO
C
C Close loop DO WHILE (CHANGE)
C
      ENDDO
C
C At this point, we have not found a contradiction with momentum
C conservation, so the Q's must have been OK:
C
      QOK = .TRUE.
C
C If we had been given a complete set of Q's, then we should have
C fixed each propagator at each vertex. Check just to make sure.
C
      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
        ENDIF
      ENDDO
      ENDIF
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      INTEGER FUNCTION PROPSIGN(VRTX,P,V)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C In:
      INTEGER VRTX(0:3*SIZE-1,2)
      INTEGER P,V
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
      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
      ENDIF
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES)
C
      INTEGER SIZE,MAXMAPS
      PARAMETER (SIZE = 3)
      PARAMETER (MAXMAPS = 64)
C In:
      INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3)
      INTEGER ORDER
C Out:
      INTEGER NMAPS,QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE)
      CHARACTER*6 MAPTYPES(MAXMAPS)
C
C Given a graph specified by VRTX and PROP, this
C subroutine finds the characteristics of each map,
C labelled by an index MAPNUMBER. For a given map, it
C finds labels Q of 'special' propagators and
C the corresponding signs QSIGN and the MAPTYPE.
C The subroutine does finds the total number
C of maps, NMAPS, and fills the corresponding
C arrays QS, QSIGNS, and MAPTYPES, each of which
C carries a MAPNUMBER index.
C
C The possibilities for maptypes are as follows:
C 
C 1) T2TO2T used for k1 + k2 -> p1 + p2 with a virtual parton
C with momentum q exchanged, q = k1 - p1. Then P(Q(1)) = q,
C P(Q(2)) = p1, P(Q(3)) = p2. We will generate points with
C CHOOSET2TO2T(p1,p2,q,ok).
C 
C 2) T2TO2S used for k1 + k2 -> p1 + p2 with a *no* virtual
C parton with momentum q = k1 - p1 exchanged. Then P(Q(1)) = k1,
C P(Q(2)) = p1, P(Q(3)) = p2. We will generate points with
C CHOOSE2TO2S(p1,p2,k1,ok).
C 
C 3) T2TO3  used for k1 + k2 -> p1 + p2 + p3 with k2 = - k1.
C Then P(Q(1)) = k1, P(Q(2)) = p1, P(Q(3)) = p2. We will generate
C points with CHOOSET2TO3(p1,p2,k1,ok).
C 
C 4) T2TO1  used for k1 + k2 -> p1 on shell. We will choose points
C with CHOOSEST2TO1(p1,p2,k1,ok).
C
C We also have the possibility of Born graphs, for which the maptype
C is BORN and Q(1) and Q(2) are chosen as two of the cut propagators.
C
C 20 December 2000
C 20 March  2001
C  1 February 2002
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER CUTMAX
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      INTEGER MAPNUMBER
      LOGICAL MORENEEDED
C Newcut variables
      LOGICAL NEWCUTINIT
      INTEGER CUTINDEX(SIZE+1),CUTSIGN(SIZE+1),NCUT
      INTEGER ISIGN(3*SIZE-1)
      LOGICAL LEFTLOOP,RIGHTLOOP
      INTEGER LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1),NINLOOP
      LOGICAL CUTFOUND
C
      INTEGER L,P,KJ,K1,K2,KDIRECT,PTEST,PLEAVING,PP1,PP2
      INTEGER L1,SIGNL1,LTESTA,LTESTB
      INTEGER I,J,JFOUND1,JFOUND2
      INTEGER V1,V2,V3,VOTHER,VV1,VV2
      INTEGER SIGN0,SIGN1,SIGN2
      INTEGER TIMESFOUND1,TIMESFOUND2,TIMESFOUND
      LOGICAL NOTINLOOP
C
C----------------------------------
C
      IF (ORDER.EQ.1) THEN
        CUTMAX = CUTMAX1
      ELSE IF (ORDER.EQ.2) THEN
        CUTMAX = CUTMAX2
      ELSE
        WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER
      ENDIF
C
      MAPNUMBER = 0
      MORENEEDED = .TRUE.
      NEWCUTINIT = .TRUE.
      DO WHILE (MORENEEDED)
      CALL NEWCUT(VRTX,ORDER,NEWCUTINIT,NCUT,ISIGN,
     >            CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP,
     >            NINLOOP,LOOPINDEX,LOOPSIGN,CUTFOUND)
C
      IF (CUTFOUND) THEN
C
      IF (ORDER.EQ.1) THEN
C
C First, we have the code for what to do for Born graphs. There
C is no Q(3) or QSIGN(3) in this case.
C
      MAPNUMBER = MAPNUMBER + 1
      QS(MAPNUMBER,0) = 0
      QSIGNS(MAPNUMBER,0) = +1
      QS(MAPNUMBER,1) = CUTINDEX(1)
      QSIGNS(MAPNUMBER,1) = CUTSIGN(1)
      QS(MAPNUMBER,2) = CUTINDEX(2)
      QSIGNS(MAPNUMBER,2) = CUTSIGN(2)
      QS(MAPNUMBER,3) = 137
      QSIGNS(MAPNUMBER,3) = 137
      MAPTYPES(MAPNUMBER) = 'BORN  '
C
C Alternative for IF (ORDER.EQ.1) THEN
C
      ELSE IF (ORDER.EQ.2) THEN
C
C We want to do something only if there is a virtual loop:
C
      IF (NCUT.EQ.(CUTMAX-1)) THEN
C---
C Case of 4 propagators in the loop
C---
      IF (NINLOOP.EQ.4) THEN
C
C For a 4 propagator loop there are two ellipse maps (T2T02T) and 
C one circle map (T2TO3). We do the two ellipse maps first.
C
      DO L = 2,3
          MAPNUMBER = MAPNUMBER + 1
          P = LOOPINDEX(L)
          V1 = VRTX(P,1)
          V2 = VRTX(P,2)
C
C We find the cut propagators K1 and K2 connected to V1 and V2 along
C with the sign = +1 if the cut propagator Kj is leaving vertex Vj
C and sign = -1 if the cut propagator Kj is entering vertex Vj. Just
C as a check, we define FOUNDJ to see if we find K1 and K2 exactly
C once.
C
          TIMESFOUND1 = 0
          TIMESFOUND2 = 0
          DO J = 1,3
            KJ = CUTINDEX(J)
            IF (VRTX(KJ,1).EQ.V1) THEN
              K1 = KJ
              SIGN1 = +1
              TIMESFOUND1 = TIMESFOUND1+1
            ELSE IF (VRTX(KJ,2).EQ.V1) THEN
              K1 = KJ
              SIGN1 = -1
              TIMESFOUND1 = TIMESFOUND1+1
            ELSE IF (VRTX(KJ,1).EQ.V2) THEN
              K2 = KJ
              SIGN2 = +1
              TIMESFOUND2 = TIMESFOUND2+1
            ELSE IF (VRTX(KJ,2).EQ.V2) THEN
              K2 = KJ
              SIGN2 = -1
              TIMESFOUND2 = TIMESFOUND2+1
            ENDIF
          ENDDO
          IF ((TIMESFOUND1.NE.1).OR.(TIMESFOUND2.NE.1)) THEN
            WRITE(NOUT,*) 'Failure in FINDTYPES'
            STOP
          ENDIF
C
C Now we record this information.
C
          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'
C
C End  DO L = 2,3 for the choice of two ellipse maps.
C
      ENDDO
C
C Now we do the circle map.
C Our definition for the circle map T2TO3E is that Q(1) is
C LOOPINDEX(1) the first propagator in the loop starting from the
C current vertex.  Then Q(2) is the label of the propagator that
C enters the final state and connects to the vertex at the head
C of propagator Q(1).  Then Q(3) is the label of the propagator
C that enters the final state and connects to the propagator with
C label LOOPINDEX(4), the last propagator in the loop.  The sign
C QSIGN(1) = +1 since this propagator always points *from* the
C current vertex. For QSIGN(2) and QSIGN(3) a plus sign indicates
C that the propagator points toward the final state, a minus sign
C indicates the opposite.
C
      IF(LOOPSIGN(1).NE.1) THEN
        WRITE(NOUT,*)'LOOPSIGN(1) not 1 in FINDTYPES'
        STOP
      ELSE IF(LOOPSIGN(4).NE.-1) THEN
        WRITE(NOUT,*)'LOOPSIGN(4) not -1 in FINDTYPES'
        STOP
      ENDIF
C
      V1 = VRTX(LOOPINDEX(1),2)
      V2 = VRTX(LOOPINDEX(4),2)
      TIMESFOUND1 = 0
      TIMESFOUND2 = 0
      DO J = 1,3
        KJ = CUTINDEX(J)
        IF (VRTX(KJ,1).EQ.V1) THEN
          K1 = KJ
          SIGN1 = +1
          TIMESFOUND1 = TIMESFOUND1+1
        ELSE IF (VRTX(KJ,2).EQ.V1) THEN
          K1 = KJ
          SIGN1 = -1
          TIMESFOUND1 = TIMESFOUND1+1
        ELSE IF (VRTX(KJ,1).EQ.V2) THEN
          K2 = KJ
          SIGN2 = +1
          TIMESFOUND2 = TIMESFOUND2+1
        ELSE IF (VRTX(KJ,2).EQ.V2) THEN
          K2 = KJ
          SIGN2 = -1
          TIMESFOUND2 = TIMESFOUND2+1
        ENDIF
      ENDDO
      IF ((TIMESFOUND1.NE.1).OR.(TIMESFOUND2.NE.1)) THEN
        WRITE(NOUT,*) 'Oops, failure in FINDTYPES',
     >                 TIMESFOUND1,TIMESFOUND2
        STOP
      ENDIF
C
      MAPNUMBER = MAPNUMBER + 1
      QS(MAPNUMBER,0) = 0
      QSIGNS(MAPNUMBER,0) = +1
      QS(MAPNUMBER,1) = 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'
C
C---
C Case of 3 propagators in the loop
C---
      ELSE IF (NINLOOP.EQ.3) THEN
C
C We are not sure which of two possibilities we have, but we proceed
C as if we had the case of a virtual loop that connects to two 
C propagators that go into the final state.
C
      MAPNUMBER = MAPNUMBER + 1
      P = LOOPINDEX(2)
      V1 = VRTX(P,1)
      V2 = VRTX(P,2)
C
C We find the cut propagators K1 and K2 connected to V1 and V2 along
C with the sign = +1 if the cut propagator Kj is leaving vertex Vj
C and sign = -1 if the cut propagator Kj is entering vertex Vj. We
C check using FOUNDJ to see if we find K1 and K2 exactly once.
C
      TIMESFOUND1 = 0
      TIMESFOUND2 = 0
      DO J = 1,3
        KJ = CUTINDEX(J)
        IF (VRTX(KJ,1).EQ.V1) THEN
          K1 = KJ
          SIGN1 = +1
          TIMESFOUND1 = TIMESFOUND1+1
        ELSE IF (VRTX(KJ,2).EQ.V1) THEN
          K1 = KJ
          SIGN1 = -1
          TIMESFOUND1 = TIMESFOUND1+1
        ELSE IF (VRTX(KJ,1).EQ.V2) THEN
          K2 = KJ
          SIGN2 = +1
          TIMESFOUND2 = TIMESFOUND2+1
        ELSE IF (VRTX(KJ,2).EQ.V2) THEN
          K2 = KJ
          SIGN2 = -1
          TIMESFOUND2 = TIMESFOUND2+1
        ENDIF
      ENDDO
C
C Now we figure out what to do based on what we found.
C
      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
C
      ELSE IF ((TIMESFOUND1.EQ.1).AND.(TIMESFOUND2.EQ.1)) THEN
C
C This is the case we were looking for. Now we record the information.
C
      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'
C
      ELSE
C
C Either Found1 = 1 and Found2 = 0 or Found2 = 1 and Found1 = 0.
C In these cases our loop does *not* connect to two propagators 
C that go to the final state. The label of the propagator
C that enters the final state will be called Kdirect and the 
C vertex that does not connect to this propagator will be called
C Vother. We take sign0 = +1 if our loop propagator points from
C Kdirect to the s-channel propagator that splits into two
C propagators that go to the final state. Otherwise sign0 = -1.
C
      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
      ENDIF
C
C Now we deal with this case.
C
      IF (CUTINDEX(1).EQ.KDIRECT) THEN
        K1 = CUTINDEX(2)
        K2 = CUTINDEX(3)
      ELSE IF (CUTINDEX(2).EQ.KDIRECT) THEN
        K1 = CUTINDEX(3)
        K2 = CUTINDEX(1)
      ELSE IF (CUTINDEX(3).EQ.KDIRECT) THEN
        K1 = CUTINDEX(1)
        K2 = CUTINDEX(2)
      ELSE
        WRITE(NOUT,*)'We are in real trouble here.'
        STOP
      ENDIF
C
C We have K1 and K2, but we need the corresponding signs.
C Find the index Pleaving of the propagator leaving the loop toward
C the final state.
C
      TIMESFOUND = 0
      DO J = 1,3
        PTEST = PROP(VOTHER,J)
        NOTINLOOP = .TRUE.
        DO I = 1,3
           IF (PTEST.EQ.LOOPINDEX(I)) THEN
              NOTINLOOP = .FALSE.
           ENDIF
        ENDDO
        IF (NOTINLOOP) THEN
           PLEAVING = PTEST
           TIMESFOUND = TIMESFOUND + 1
        ENDIF
      ENDDO
      IF (TIMESFOUND.NE.1) THEN
         WRITE(NOUT,*)'Pleaving not found or found twice.'
         STOP
      ENDIf
C
C Let V3 be the vertex not in the loop at the end of propagator
C Pleaving. Two propagators in the final state must connect to this
C vertex.
C
      V3 = VRTX(PLEAVING,1)
      IF (V3.EQ.VOTHER) THEN
        V3 = VRTX(PLEAVING,2)
      ENDIF
C
C We use V3 to get the proper signs.
C
      IF (VRTX(K1,1).EQ.V3) THEN
          SIGN1 = +1
      ELSE IF (VRTX(K1,2).EQ.V3) THEN
          SIGN1 = -1
      ELSE
        WRITE(NOUT,*)'Yikes, this is bad.'
        STOP
      ENDIF
      IF (VRTX(K2,1).EQ.V3) THEN
          SIGN2 = +1
      ELSE IF (VRTX(K2,2).EQ.V3) THEN
          SIGN2 = -1
      ELSE
        WRITE(NOUT,*)'Yikes, this is also bad.'
        STOP
      ENDIF
C
C Now we record the information.
C Recall that P = LOOPINDEX(2) and that SIGN0 = +1 if propagator P
C points toward propagator Pleaving.
C
      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'
C
C But we are not done, because in this case we need a circle map too.
C Our definition for the circle map T2TO3D is that Q(1) is
C LOOPINDEX(1) or LOOPINDEX(3), one of the two propagators that
C connects to a propagator that connects to the current vertex.
C We take the one that connects to vertex Vother that connects to
C a propagator Pleaving that connects vertex V3 that, finally,
C connects to to two propagators that enter the final state. Then
C Q(3) and Q(3) are these two propagators that enter the final
C state from vertex V3.  For QSIGN(2) and QSIGN(3) a plus sign
C indicates that the propagator points toward the final state, a
C minus sign indicates the opposite.  The sign QSIGN(1) is + 1 if
C this propagator points toward the final state, -1 in the
C opposite circumstance.
C
      IF (LOOPSIGN(1).NE.1) THEN
        WRITE(NOUT,*)'LOOPSIGN not 1 in FINDTYPES'
        STOP
      ENDIF
C
C The loop momentum with label L1 is the one that
C attaches to VOTHER (the vertex that connects to a propagator
C that splits before going to the final state.) We take
C SIGNL1 = +1 if this propagator points towards VOTHER.
C
      LTESTA = LOOPINDEX(1)
      LTESTB = LOOPINDEX(3)
      IF (VRTX(LTESTA,2).EQ.VOTHER) THEN
          L1 = LTESTA
          SIGNL1 = +1
      ELSE IF (VRTX(LTESTA,1).EQ.VOTHER) THEN
          L1 = LTESTA
          SIGNL1 = -1
      ELSE IF (VRTX(LTESTB,2).EQ.VOTHER) THEN
          L1 = LTESTB
          SIGNL1 = +1
      ELSE IF (VRTX(LTESTB,1).EQ.VOTHER) THEN
          L1 = LTESTB
          SIGNL1 = -1
      ELSE
        WRITE(NOUT,*)'Cannot seem to find L1'
        STOP
      ENDIF
C
      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'
C
C Close the IF structure for the case of three particles in the loop,
C IF (FOUND1.GT.1).OR.(FOUND2.GT.1) THEN ...
C
      ENDIF
C---
C Case of 2 propagators in the loop
C---
      ELSE IF (NINLOOP.EQ.2) THEN
C
C We are not sure which of two possibilities we have, but we proceed
C as if we had the case of a virtual loop that connects to two 
C propagators that go into the final state.
C
      MAPNUMBER = MAPNUMBER + 1
      P = LOOPINDEX(1)
      V1 = VRTX(P,1)
      V2 = VRTX(P,2)
C
C We find the cut propagators K1 or K2 connected to V1 or V2 along
C with the sign = +1 if the cut propagator Kj is leaving vertex Vj
C and sign = -1 if the cut propagator Kj is entering vertex Vj. We
C check using FOUNDJ to see if we find K1 or K2 exactly once.
C
      TIMESFOUND1 = 0
      TIMESFOUND2 = 0
      DO J = 1,3
        KJ = CUTINDEX(J)
        IF (VRTX(KJ,1).EQ.V1) THEN
          K1 = KJ
          SIGN1 = +1
          JFOUND1 = J
          TIMESFOUND1 = TIMESFOUND1+1
        ELSE IF (VRTX(KJ,2).EQ.V1) THEN
          K1 = KJ
          SIGN1 = -1
          JFOUND1 = J
          TIMESFOUND1 = TIMESFOUND1+1
        ELSE IF (VRTX(KJ,1).EQ.V2) THEN
          K2 = KJ
          SIGN2 = +1
          JFOUND2 = J
          TIMESFOUND2 = TIMESFOUND2+1
        ELSE IF (VRTX(KJ,2).EQ.V2) THEN
          K2 = KJ
          SIGN2 = -1
          JFOUND2 = J
          TIMESFOUND2 = TIMESFOUND2+1
        ENDIF
      ENDDO
C
C Now we figure out what to do based on what we found.
C
      IF ((TIMESFOUND1.GT.1).OR.(TIMESFOUND2.GT.1)) THEN
         WRITE(NOUT,*) 'Failure in FINDTYPES'
         STOP
C
      ELSE IF ((TIMESFOUND1.EQ.1).AND.(TIMESFOUND2.EQ.0)) THEN
C
C This is one of the cases we were looking for. Now we record the 
C information. The propagator Q(3) is one of the propagators
C in the final state other than that connected to our loop. The
C corresponding sign is +1 if this propagator crosses the final
C state cut in the same direction as the propagator connected to
C our loop.
C
      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 (CUTINDEX(1).NE.K1) THEN
        QS(MAPNUMBER,3) = CUTINDEX(1)
        QSIGNS(MAPNUMBER,3) = CUTSIGN(1)*CUTSIGN(JFOUND1)*SIGN1
      ELSE
        QS(MAPNUMBER,3) = CUTINDEX(2)
        QSIGNS(MAPNUMBER,3) = CUTSIGN(2)*CUTSIGN(JFOUND1)*SIGN1
      ENDIF
      MAPTYPES(MAPNUMBER) = 'T2TO1 '
C
      ELSE IF ((TIMESFOUND1.EQ.0).AND.(TIMESFOUND2.EQ.1)) THEN
C
C This is one of the cases we were looking for. Now we record the 
C information. The propagator Q(3) is one of the propagators
C in the final state other than that connected to our loop. The
C corresponding sign is +1 if this propagator crosses the final
C state cut in the same direction as the propagator connected to
C our loop.
C
      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 (CUTINDEX(1).NE.K2) THEN
        QS(MAPNUMBER,3) = CUTINDEX(1)
        QSIGNS(MAPNUMBER,3) = CUTSIGN(1)*CUTSIGN(JFOUND2)*SIGN2
      ELSE
        QS(MAPNUMBER,3) = CUTINDEX(2)
        QSIGNS(MAPNUMBER,3) = CUTSIGN(2)*CUTSIGN(JFOUND2)*SIGN2
      ENDIF
      MAPTYPES(MAPNUMBER) = 'T2TO1 '
C
      ELSE IF ((TIMESFOUND1.EQ.0).AND.(TIMESFOUND2.EQ.0)) THEN
C
C Here TimesFound1 = 0 and TimesFound2 = 0, so our loop does *not* 
C connect to a propagator that goes to the final state.
C Find the indices PP1 and PP2 of the propagators connected to
C our loop.
C
      TIMESFOUND = 0
      DO J = 1,3
        PTEST = PROP(V1,J)
        NOTINLOOP = .TRUE.
        DO I = 1,2
           IF (PTEST.EQ.LOOPINDEX(I)) THEN
              NOTINLOOP = .FALSE.
           ENDIF
        ENDDO
        IF (NOTINLOOP) THEN
           PP1 = PTEST
           TIMESFOUND = TIMESFOUND + 1
        ENDIF
      ENDDO
      IF (TIMESFOUND.NE.1) THEN
         WRITE(NOUT,*)'PP1 not found or found twice.'
         STOP
      ENDIf
      TIMESFOUND = 0
C
      DO J = 1,3
        PTEST = PROP(V2,J)
        NOTINLOOP = .TRUE.
        DO I = 1,2
           IF (PTEST.EQ.LOOPINDEX(I)) THEN
              NOTINLOOP = .FALSE.
           ENDIF
        ENDDO
        IF (NOTINLOOP) THEN
           PP2 = PTEST
           TIMESFOUND = TIMESFOUND + 1
        ENDIF
      ENDDO
      IF (TIMESFOUND.NE.1) THEN
         WRITE(NOUT,*)'PP2 not found or found twice.'
         STOP
      ENDIf
C
C Let VV1 and VV2 be the vertices not in the loop at the end of
C propagators PP1 and PP2 respectively. Two propagators in the final 
C state must connect to one of these vertices.
C
      VV1 = VRTX(PP1,1)
      IF (VV1.EQ.V1) THEN
        VV1 = VRTX(PP1,2)
      ENDIF
      VV2 = VRTX(PP2,1)
      IF (VV2.EQ.V2) THEN
        VV2 = VRTX(PP2,2)
      ENDIF
C
C We have VV1 and VV2. A slight hitch is that one of them might be
C the vertex 1 or 2 that connect to the photon. In this case, 
C in the next step we do *not* want to find the final state
C propagator that connects to this vertex. A cure is to set the
C vertex number to something impossible.
C
      IF ((VV1.EQ.1).OR.(VV1.EQ.2)) THEN
        VV1 = -17
      ENDIF
      IF ((VV2.EQ.1).OR.(VV2.EQ.2)) THEN
        VV2 = -17
      ENDIF
C
C Now we find two final state propagators connected to VV1 or
C else two final state propagators connected to VV2.
C
      TIMESFOUND = 0
      DO J = 1,3
        KJ = CUTINDEX(J)
        IF (VRTX(KJ,1).EQ.VV1) THEN
          IF(TIMESFOUND.EQ.0) THEN
            K1 = KJ
            SIGN1 = +1
          ELSE
            K2 = KJ
            SIGN2 = +1
          ENDIF
          SIGN0 = -1
          TIMESFOUND = TIMESFOUND+1
        ELSE IF (VRTX(KJ,1).EQ.VV2) THEN
          IF(TIMESFOUND.EQ.0) THEN
            K1 = KJ
            SIGN1 = +1
          ELSE
            K2 = KJ
            SIGN2 = +1
          ENDIF
          SIGN0 = +1
          TIMESFOUND = TIMESFOUND+1
        ELSE IF (VRTX(KJ,2).EQ.VV1) THEN
          IF(TIMESFOUND.EQ.0) THEN
            K1 = KJ
            SIGN1 = -1
          ELSE
            K2 = KJ
            SIGN2 = -1
          ENDIF
          SIGN0 = -1
          TIMESFOUND = TIMESFOUND+1
        ELSE IF (VRTX(KJ,2).EQ.VV2) THEN
          IF(TIMESFOUND.EQ.0) THEN
            K1 = KJ
            SIGN1 = -1
          ELSE
            K2 = KJ
            SIGN2 = -1
          ENDIF
          SIGN0 = +1
          TIMESFOUND = TIMESFOUND+1
        ENDIF
      ENDDO
      IF (TIMESFOUND.NE.2) THEN
         WRITE(NOUT,*)'Where are those tricky propagators?',TIMESFOUND
         STOP
      ENDIf
C
C Now we record the information.
C Recall that P = LOOPINDEX(1) and that SIGN0 = +1 if propagator P
C points toward propagators in the final state.
C
      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'
C
C Close IF ((TIMESFOUND1.GT.1).OR.(TIMESFOUND2.GT.1)) THEN ...
C
      ENDIF
C
C Case of less than 2 propagators in the loop
C
      ELSE
        WRITE(NOUT,*) 'Looped the loop in FINDDQS'
        STOP
C
C End IF (NINLOOP.EQ. n ) series
C
      ENDIF
C
C End IF (there is a virtual loop) THEN ... 
C
      ENDIF
C
C Close IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ...
C
      ELSE
        WRITE(NOUT,*)'ORDER in FINDTYPES needed to be 1 or 2.'
        STOP
      ENDIF
C
C End IF (CUTFOUND) THEN ... If the cut was not found, then we are done.
C
      ELSE
          MORENEEDED = .FALSE.
      ENDIF
C
C End main loop: DO WHILE (MORENEEDED)
C
      ENDDO
C
      NMAPS = MAPNUMBER
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE NEWPOINT(A,QSIGN,MAPTYPE,ORDER,K,ABSK,BADPOINT)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C In:
      INTEGER A(0:3*SIZE-1,0:SIZE),QSIGN(0:SIZE)
      CHARACTER*6 MAPTYPE
      INTEGER ORDER
C Out:
      REAL*8 K(0:3*SIZE-1,0:3),ABSK(0:3*SIZE-1)
      LOGICAL BADPOINT
C
C Chooses a new Monte Carlo point in the space of loop 3-momenta.
C 4 March 1993
C 12 July 1993
C 17 July 1994
C  2 May 1996
C  5 February 1997
C  4 February 1999
C 10 March 1999
C  9 April 1999
C 20 August 1999
C 21 December 2000 <cut based method for choosing points>
C 20 March 2001
C  8 February 2002
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NPROPS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      REAL*8 P1(3),P2(3),P3(3),ELL1(3)
      INTEGER P,MU
      REAL*8 TEMP,KSQ
      LOGICAL OK
C
C------------
C
      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
      ENDIF
C
      BADPOINT = .FALSE.
C
      IF (ORDER.EQ.1) THEN
C
C We deal with the case of a Born graph first.
C
      CALL CHOOSE3(P1,P2,P3,OK)
      IF(.NOT.OK) THEN
        DO P = 1,NPROPS
        DO MU = 0,3
          K(P,MU) = 0.0D0
        ENDDO
        ENDDO
        BADPOINT = .TRUE.
        RETURN
      ENDIF
      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
      ENDDO
        ABSK(P) = SQRT(KSQ)
        K(P,0) = 0.0D0
      ENDDO
      DO MU = 0,3
        K(0,MU) = 0.0D0
      ENDDO
      ABSK(0) = 0.0D0
C
C Alternative for  IF (ORDER.EQ.1) THEN
C
      ELSE IF (ORDER.EQ.2) THEN
C
C Here is what we do for order alpha_s^2 graphs.
C
C Our notation: 
C   special loop momentum, to become QSIGN(1)*ELL(1,mu), is ELL1(mu);
C   first final state parton, to become QSIGN(2)*ELL(2,mu), is P1(mu);
C   second final state parton, to become QSIGN(3)*ELL(3,mu), is P2(mu);
C   third final state parton, not reported, is P3(mu).
C We use {ELL1,P1,P2} directly to generate the K(P,mu).
C
C First, we need to generate a three parton final state.
C Abort if we get a not OK signal.
C
      CALL CHOOSE3(P1,P2,P3,OK)
      IF(.NOT.OK) THEN
        DO P = 1,NPROPS
        DO MU = 0,3
          K(P,MU) = 0.0D0
        ENDDO
        ENDDO
        BADPOINT = .TRUE.
        RETURN
      ENDIF
C
C Then we generate the loop momentum, ell1.
C Abort if we get a not OK signal.
C
      IF (MAPTYPE.EQ.'T2TO3D') THEN
        CALL CHOOSE2TO3D(P1,P2,ELL1,OK)
        IF(.NOT.OK) THEN
          DO P = 1,NPROPS
          DO MU = 0,3
            K(P,MU) = 0.0D0
          ENDDO
          ENDDO
          BADPOINT = .TRUE.
          RETURN
        ENDIF
      ELSE IF (MAPTYPE.EQ.'T2TO3E') THEN
        CALL CHOOSE2TO3E(P1,P2,ELL1,OK)
        IF(.NOT.OK) THEN
          DO P = 1,NPROPS
          DO MU = 0,3
            K(P,MU) = 0.0D0
          ENDDO
          ENDDO
          BADPOINT = .TRUE.
          RETURN
        ENDIF
      ELSE IF (MAPTYPE.EQ.'T2TO2T') THEN
        CALL CHOOSE2TO2T(P1,P2,ELL1,OK)
        IF(.NOT.OK) THEN
          DO P = 1,NPROPS
          DO MU = 0,3
            K(P,MU) = 0.0D0
          ENDDO
          ENDDO
          BADPOINT = .TRUE.
          RETURN
        ENDIF
      ELSE IF (MAPTYPE.EQ.'T2TO2S') THEN
        CALL CHOOSE2TO2S(P1,P2,ELL1,OK)
        IF(.NOT.OK) THEN
          DO P = 1,NPROPS
          DO MU = 0,3
            K(P,MU) = 0.0D0
          ENDDO
          ENDDO
          BADPOINT = .TRUE.
          RETURN
        ENDIF
      ELSE IF (MAPTYPE.EQ.'T2TO1 ') THEN
        CALL CHOOSE2TO1(P1,P2,ELL1,OK)
        IF(.NOT.OK) THEN
          DO P = 1,NPROPS
          DO MU = 0,3
            K(P,MU) = 0.0D0
          ENDDO
          ENDDO
          BADPOINT = .TRUE.
          RETURN
        ENDIF
      ELSE 
        WRITE(NOUT,*)'Bad MAPTYPE in NEWPOINT'
        STOP
      ENDIF
C
C Now we have ELL1(mu), P1(mu), and P2(mu) and we need to translate to 
C the propagator momenta K(P,MU).
C
      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
      ENDDO
        ABSK(P) = SQRT(KSQ)
        K(P,0) = 0.0D0
      ENDDO
      DO MU = 0,3
        K(0,MU) = 0.0D0
      ENDDO
      ABSK(0) = 0.0D0
C
C Close IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ...
C
      ELSE
        WRITE(NOUT,*)'ORDER should have been 1 or 2 in NEWPOINT.'
        STOP
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHECKPOINT(K,ABSK,PROP,ORDER,BADNESS)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C In:
      REAL*8 K(0:3*SIZE-1,0:3),ABSK(0:3*SIZE-1)
      INTEGER PROP(2*SIZE,3)
      INTEGER ORDER
C Out:
      REAL*8 BADNESS
C
C Calculates the BADNESS of a point chosen by NEWPOINT. If there
C are very collinear particles meeting at a vertex or of there is a
C very soft particle, then the badness is big. Specifically, for
C each vertex V we order the momenta entering the vertex Kmin, Kmid
C Kmax in order of |K|. Then
C
C   Kmin (Kmin + Kmid - Kmax )/Kmax^2
C
C is the 1/badness^2 for that vertex. The badness for the point is the 
C largest of the badness values of all the vertices.
C 
C Revised 13 may 1998
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NVERTS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      REAL*8 SMALLNESSV,SMALLNESS
      INTEGER V
      REAL*8 KMIN,KMID,KMAX,K1,K2,K3
C
      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
      ENDIF
C
      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
       ENDIF
       IF (K3.LT.KMIN) THEN
         KMID = KMIN
         KMIN = K3
       ELSE IF (K3.GT.KMAX) THEN
         KMID = KMAX
         KMAX = K3
       ELSE
         KMID = K3
       ENDIF
       SMALLNESSV = KMIN * (KMIN + KMID - KMAX) /KMAX**2
       IF( SMALLNESSV .LT. SMALLNESS ) THEN
         SMALLNESS = SMALLNESSV
       ENDIF
       ENDDO
       IF (SMALLNESS.LT.1.0D-30) THEN
         BADNESS = 1.0D15
       ELSE
         BADNESS = SQRT(1.0D0/SMALLNESS)
       ENDIF
       RETURN
       END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE AXES(EA,EB,EC)
C
C In:
      REAL*8 EA(3)
C Out:
      REAL*8 EB(3),EC(3)
C
C Given a unit vector E_a(mu), generates unit vectors E_b(mu) and
C E_c(mu) such that E_a*E_b = E_b*E_c = E_c*E_a = 0.
C
C The vector E_b will lie in the plane formed by the z-axis and
C E_a unless E_a itself is nearly aligned along the z-axis, in which
C case E_b will lie in the plane formed by the x-axis and E_a.
C
C 18 April 1996
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
      REAL*8 COSTHETASQ,SINTHETAINV
C
C For check
C
      INTEGER MU
      REAL*8 DOTAA,DOTBB,DOTCC,DOTAB,DOTAC,DOTBC
C
      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
      ENDIF
      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) 
C     
C Check:
C
      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)
      ENDDO
      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
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C                 Subroutine to calculate integrand                    C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CALCULATE(VRTX,GRAPHNUMBER,ORDER,KIN,ABSKIN,
     >               QS,QSIGNS,MAPTYPES,NMAPS,VALUE,MAXPART,VALUECHK)
C
      INTEGER SIZE,MAXMAPS
      PARAMETER (SIZE = 3)
      PARAMETER (MAXMAPS = 64)
C In:
      INTEGER VRTX(0:3*SIZE-1,2)
      INTEGER GRAPHNUMBER,ORDER
      REAL*8 KIN(0:3*SIZE-1,0:3),ABSKIN(0:3*SIZE-1)
      INTEGER QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE)
      CHARACTER*6 MAPTYPES(MAXMAPS)
      INTEGER NMAPS
C Out:
      COMPLEX*16 VALUE,VALUECHK
      REAL*8 MAXPART
C
C Calculates the value of the graph specified by VRTX at the point K,
C returning result in VALUE, which includes the division by the density
C of points and the jacobian for deforming the contour. Also reports
C MAXPART, the biggest absolute value of the contributions to Re(VALUE).
C This helps us to keep track of cancellations and thus to abort the 
C calculation if too much cancellation among terms will be required.
C
C*********************
C
C Max number of graphs, for array size:
      INTEGER MAXGRAPHS
      PARAMETER (MAXGRAPHS = 12)
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      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*8 MUOVERRTS
      COMMON /RENORMALIZE/ MUOVERRTS
      LOGICAL REPORT,DETAILS
      COMMON /CALCULOOK/ REPORT,DETAILS
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
      CHARACTER*7 GAUGE
      COMMON /GAUGECHOICE/ GAUGE
C How many graphs and how many cuts and maps for each:
      INTEGER NUMBEROFGRAPHS
      INTEGER NUMBEROFCUTS(MAXGRAPHS)
      INTEGER NUMBEROFMAPS(MAXGRAPHS)
      COMMON /GRAPHCOUNTS/ NUMBEROFGRAPHS,NUMBEROFCUTS,NUMBEROFMAPS
C What the program should do
      CHARACTER*6 MODE
      COMMON /PROGRAMMODE/ MODE
C Physics data
      REAL*8 ALPHASOFMZ,MZ,EXTERNALRTS
      COMMON /PHYSICSDATA/ ALPHASOFMZ,MZ,EXTERNALRTS
C Labels:
      INTEGER QE(0:SIZE)
C Momenta:
      REAL*8 K(0:3*SIZE-1,0:3),ABSK(0:3*SIZE-1)
      REAL*8 KINLOOP(SIZE+1,0:3)
      REAL*8 KCUT(SIZE+1,0:3)
      COMPLEX*16 NEWKINLOOP(0:3)
      COMPLEX*16 KC(0:3*SIZE-1,0:3)
      COMPLEX*16 ELLSQ,ELL
      REAL*8 E(0:SIZE),RTS
C Renormalization:
      REAL*8 MUMSBAR
C Matrices:
      INTEGER AE(0:3*SIZE-1,0:SIZE)
C FINDA variable:
      LOGICAL QOK
C DENSITY variables:
      REAL*8 JACNEWPOINT,DENSITY
C NEWCUT variables:
      INTEGER CUTINDEX(SIZE+1),CUTSIGN(SIZE+1),NCUT
      INTEGER ISIGN(3*SIZE-1)
      LOGICAL LEFTLOOP,RIGHTLOOP
      INTEGER LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1),NINLOOP
C Loopcut variables:
      LOGICAL CALCMORE
      INTEGER JCUT,INDEX,LOOPCUTSIGN
C DEFORM variables:
      COMPLEX*16 JACDEFORM
C Functions:
      REAL*8 CALS0,SMEAR
      REAL*8 XXREAL,XXIMAG
      COMPLEX*16 COMPLEXSQRT
      REAL*8 ALPI
C Index variables:
      INTEGER P,MU,I,J,CUTNUMBER
C Propagator properties
      LOGICAL CUT(3*SIZE-1)
C Flag for feynman function
      CHARACTER*16 FLAG
C Results variables:
      REAL*8 CALSVAL
      REAL*8 WEIGHT,MAXWEIGHT
      COMPLEX*16 FEYNMAN,FEYNMANF,FEYNMAN0,FEYNMAN0F,FEYNMANVAL
      REAL*8 PREFACTOR
      COMPLEX*16 INTEGRAND
      COMPLEX*16 CHECK
C Useful constants:
      REAL*8 METRIC(0:3)
      DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/
      REAL*8 PI
      DATA PI /3.1415926535898D0/
C      
C-----------------------------------------------------------------------
C Latest revision: 11 May 1996
C                  24 October 1996 (call to CHECKDEFORM)
C                  15 November 1996 (remove finite 'i epsilon')
C                  18 November 1996 (add CHECKVALUE)
C                  22 November 1996 Bug fixed.
C                  27 November 1996 (complex checkvalue)
C                  29 November 1996 (branchcut check; better checkvalue)
C                  27 February 1997 renormalization; reporting
C                  25 July     1997 renormalization; self-energy graphs
C                  17 September 1997 more renormalization & self-energy
C                  21 September 1997 finish DEFORM
C                  24 September 1997 fix bugs
C                  19 October 1997 fix cutsign bug
C                  22 October 1997 fix renormalization sign bug
C                   6 November 1997 improvements for deformation
C                  28 November 1997 more work on deformation
C                   2 December 1997 more precision in "report" numbers
C                   4 January  1998 revisions for self-energy graphs
C                  11 January 1998 renormalizaion for self-energy graphs
C                  27 February 1998 use Hrothgar for output
C                   5 March 1998 integrate Hrothgar
C                  14 March 1998 restore checks of deformation direction
C                  24 July 1998 use countfactor(graphnumber)
C                   4 August 1998 better CHECKDEFORM
C                   5 August 1998 change to groupsize(graphnumber)
C                  22 August 1998 add color factors
C                  22 December 1998 precalculate cut structure in RENO
C                  26 April 1999 omit REFLECT except as option
C                  22 December 2000 omit REFLECT entirely
C                  22 December 2000 change method of choosing points
C                  19 December 2001 call FEYNMANF, new organization.
C                  31 December 2001 add Coulomb gauge.
C                  11 February 2002 Add Born calculation.
C----------------------------------
C
      IF (ORDER.EQ.1) THEN
        NLOOPS = NLOOPS1
        NPROPS = NPROPS1
        CUTMAX = CUTMAX1
      ELSE IF (ORDER.EQ.2) THEN
        NLOOPS = NLOOPS2
        NPROPS = NPROPS2
        CUTMAX = CUTMAX2
      ELSE
        WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER
      ENDIF
C
C We do not want to change the value of KIN and ABSKIN, even though
C K and ABSK get changed by the reflection feature of the subroutine.
C
      DO P = 1,NPROPS
        ABSK(P) = ABSKIN(P)
        DO MU = 0,3
          K(P,MU) = KIN(P,MU)
        ENDDO
      ENDDO
C
C Initialize contribution to integral from this point. Also initialize
C BIGGEST, which will be the biggest absolute value of the contributions
C to VALUE. This helps us to keep track of cancellations and thus to
C abort the calculation if too much cancellation among terms will be
C required.
C
      MAXPART = 0.0D0
      VALUE = (0.0D0,0.0D0)
      VALUECHK = (0.0D0,0.0D0)
C
C Calculate jacobian.
C
      JACNEWPOINT = 
     >     1.0D0/DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER)
C
C Loop over cuts.
C
      DO CUTNUMBER = 1,NUMBEROFCUTS(GRAPHNUMBER)
      CALL GETCUTINFO(GRAPHNUMBER,CUTNUMBER,ORDER,NCUT,ISIGN,
     >            CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP,
     >            NINLOOP,LOOPINDEX,LOOPSIGN)
C....
      IF (REPORT) THEN
        WRITE(NOUT,301)NCUT,CUTINDEX(1),CUTINDEX(2),
     >                    CUTINDEX(3),CUTINDEX(4)
301     FORMAT('Ncut =',I2,' CUTINDEX =',4I2)
      ENDIF
C''''
C
C Calculate Sqrt(s) and the renormalization scale MUMSBAR.
C
      RTS = 0.0D0
      DO J=1,NCUT
        RTS = RTS + ABSK(CUTINDEX(J))
      ENDDO
      MUMSBAR = MUOVERRTS * RTS
C
C Calculate final state momenta.
C Then we can also calculate CALSVAL and the PREFACTOR.
C
      DO I = 1,NCUT
        KCUT(I,0) = ABSK(CUTINDEX(I))
        DO MU = 1,3
          KCUT(I,MU) = CUTSIGN(I) * K(CUTINDEX(I),MU)
        ENDDO
      ENDDO
      CALSVAL = CALS0(NCUT,KCUT)
      PREFACTOR = 1.0D0 / (NC * RTS**2 * (2.0D0 * PI)**NLOOPS )
C
      IF (MODE.EQ.'born  ') THEN
        PREFACTOR = PREFACTOR * ALPI(MUOVERRTS*EXTERNALRTS)
      ELSE IF (MODE.EQ.'nlo   ') THEN
        PREFACTOR = PREFACTOR * ALPI(MUOVERRTS*EXTERNALRTS)**ORDER
      ELSE IF (MODE.EQ.'hocoef') THEN
        CONTINUE
      ELSE
       WRITE(NOUT,*)'CALCULATE programmed for this mode.',MODE
       STOP
      ENDIF
C
C Calculate momenta around loop (if any). In case NINLOOP = 0, this
C DO loop is skipped.
C
      DO J = 1,NINLOOP
        DO MU = 1,3
         KINLOOP(J,MU) = LOOPSIGN(J) * K(LOOPINDEX(J),MU)
        ENDDO
      ENDDO
C
C Please note that at this point the energy in the loop, KINLOOP(J,0),
C is not calculated. We have to wait until we have a loop cut to
C do this.
C
C Now KINLOOP(J,MU) gets an imaginary part for MU = 1,2,3.
C DEFORM calculates NEWKINLOOP and the associated jacobian, JACDEFORM.
C In case NINLOOP = 0, this subroutine just returns NEWKINLOOP(MU) = 0
C and JACDEFORM = 1.
C
      CALL DEFORM(VRTX,LOOPINDEX,RTS,LEFTLOOP,RIGHTLOOP,
     >      NINLOOP,KINLOOP,NEWKINLOOP,JACDEFORM)
C
C If there is a loop, we need to go around the loop and generate
C a "loopcut."  There are four cases.
C
C 1) NINLOOP = 0, with NCUT = CUTMAX.  
C Then we are ready to proceed, and we should calculate only once 
C before going back to NEWCUT. Therefore we set CALCMORE to .FALSE. 
C so that we do not enter this code again.
C
C In the other three cases, there is a loop with NINLOOP = 2, 3, or 4.
C We generate a loopcut specified by the index JCUT = 1, 2, ... around
C the loop: CUTINDEX(CUTMAX) = LOOPINDEX(JCUT).
C
C 2) NINLOOP = 2, with NCUT = CUTMAX - 1.
C Then the loop is a self-energy subgraph and, with our dispersive
C treatment of these graphs, there is one term. We need to calculate
C energies, so we put JCUT = 1, but this is just a convention: the
C choice JCUT = 1 or 2 affects only the energy in the loop and the
C two point function depends only on the 3-momentum in the loop.
C
C 3) NINLOOP = 3, with NCUT = CUTMAX - 1.
C Then we have a complicated task. First, we generate the 
C renormalization counter term. We set RENORMTERM3 to true to signify
C this. We need to calculate energies, so we put JCUT = 1, but this is
C just a convention. We also set FLAG to 'renormalize 3 pt'. The
C function FEYNMAN will pass FLAG on to the subroutine VERTEX,
C which will generate the counter term when FLAG has this value. Once we
C are done with the counterterm, we will go around the loop twice
C with JCUT = 1,2,3 and then JCUT = 1,2,3 again. We set
C CUTSIGN(CUTMAX) =  LOOPSIGN(JCUT) the first time and 
C CUTSIGN(CUTMAX) =  - LOOPSIGN(JCUT) the second time. This corresponds
C to doing the energy integral with the contour closed in the upper
C half plane and also in the lower half plane. We *average* over the
C two sign choices, so we will need to multiply FEYNMAN by 1/2 for
C NINLOOP = 3 and RENORMTERM3 = false. When we are done with this
C we set CALCMORE to .FALSE. .
C
C 3) NINLOOP = 4, with NCUT = CUTMAX - 1.
C Then we have an easuer task. We do *not* generate a 
C renormalization counter term. We will go around the loop twice
C with JCUT = 1,2,3,4 and then JCUT = 1,2,3,4 again. We set
C CUTSIGN(CUTMAX) =  LOOPSIGN(JCUT) the first time and 
C CUTSIGN(CUTMAX) =  - LOOPSIGN(JCUT) the second time. This corresponds
C to doing the energy integral with the contour closed in the upper
C half plane and also in the lower half plane. We *average* over the
C two sign choices, so we will need to multiply FEYNMAN by 1/2 for
C NINLOOP = 4. When we are done with this we set CALCMORE to .FALSE. .
C
C We initialize the weight, then add to it the contributions from
C each pass through this loop.
C
      WEIGHT = 0.0D0
      MAXWEIGHT = 0.0D0
      FLAG = '     no flag set'
C
      IF (NINLOOP.EQ.3) THEN
        INDEX = 0
      ELSE
        INDEX = 1
      ENDIF
      CALCMORE = .TRUE.
C
      DO WHILE (CALCMORE)
C
      IF (NINLOOP.EQ.0) THEN
         CALCMORE = .FALSE.
      ELSE IF (NINLOOP.EQ.2) THEN
         JCUT = 1
         CUTINDEX(CUTMAX) = LOOPINDEX(JCUT)
         CUTSIGN(CUTMAX) = LOOPSIGN(JCUT)
         CALCMORE = .FALSE.
      ELSE IF (NINLOOP.EQ.3) THEN
         IF(INDEX.EQ.0) THEN
           FLAG = 'renormalize 3 pt'
           JCUT = 1
           CUTINDEX(CUTMAX) = LOOPINDEX(JCUT)
           CUTSIGN(CUTMAX) = LOOPSIGN(JCUT)
           INDEX = 1
         ELSE
           FLAG = '     no flag set'
           IF (INDEX.LE.3) THEN
             JCUT = INDEX
             CUTINDEX(CUTMAX) = LOOPINDEX(JCUT)
             CUTSIGN(CUTMAX) =  LOOPSIGN(JCUT)
             LOOPCUTSIGN = 1
           ELSE
             JCUT = INDEX - 3
             CUTINDEX(CUTMAX) =  LOOPINDEX(JCUT)
             CUTSIGN(CUTMAX) = - LOOPSIGN(JCUT)
             LOOPCUTSIGN = -1
           ENDIF
           INDEX = INDEX + 1
           IF (INDEX.GT.6) THEN
             CALCMORE = .FALSE.
           ENDIF
         ENDIF
      ELSE IF (NINLOOP.EQ.4) THEN
         IF (INDEX.LE.4) THEN
           JCUT = INDEX
           CUTINDEX(CUTMAX) = LOOPINDEX(JCUT)
           CUTSIGN(CUTMAX) =  LOOPSIGN(JCUT)
           LOOPCUTSIGN = 1
         ELSE
           JCUT = INDEX - 4
           CUTINDEX(CUTMAX) =  LOOPINDEX(JCUT)
           CUTSIGN(CUTMAX) = - LOOPSIGN(JCUT)
           LOOPCUTSIGN = -1
         ENDIF
         INDEX = INDEX + 1
         IF (INDEX.GT.8) THEN
           CALCMORE = .FALSE.
         ENDIF
      ELSE
         WRITE(*,*)'Impossible case in CALCULATE'
         STOP
      ENDIF
C
C Calculate matrix AE(P,I) relating propagator energies to energies of 
C cut lines. NOTE that the index I here is displaced by 1.
C
      DO I = 0,NLOOPS
        QE(I) = CUTINDEX(I+1)
      ENDDO
      CALL FINDA(VRTX,QE,NLOOPS,ORDER,AE,QOK)
      IF (.NOT.QOK) THEN
         WRITE(NOUT,*)'AE not found'
         STOP
      ENDIF
C
C Define logical cut variables:
C CUT(P) = .TRUE. if propagator P crosses the final state cut
C                 OR if it crosses the loopcut.
C
      DO P = 1,NPROPS
         CUT(P) = .FALSE.
      ENDDO
      DO I = 1,CUTMAX
         CUT(CUTINDEX(I)) = .TRUE.
      ENDDO
C
C Calculate part of the energies of cut lines corresponding to the
C real part of the loop three-momenta. NOTE that I is displaced by 1
C in order to work with the matrix AE(P,I).
C
      DO I = 0,NLOOPS
        E(I) = CUTSIGN(I+1) * ABSK(CUTINDEX(I+1))
      ENDDO
C
C Calculate part of the propagator energies corresponding to the
C real part of the loop three-momenta.
C
      DO P = 0,NPROPS
         K(P,0) = 0.0D0
         DO I = 0,NLOOPS
           K(P,0) = K(P,0) + AE(P,I) * E(I)
         ENDDO
      ENDDO
      IF ( ABS(RTS - K(0,0)).GT.1.0D-8 ) THEN
         WRITE(NOUT,*)'Oops, the calculation of RTS did not work'
         STOP
      ENDIF
C
C Calculate the added complex loop energy. Check that we do not
C cross the cut of Sqrt(ELLSQ) by using COMPLEXSQRT(ELLSQ).
C
      IF (NINLOOP.GT.0) THEN
        KINLOOP(JCUT,0) =  LOOPSIGN(JCUT) * K(LOOPINDEX(JCUT),0)
        ELLSQ = (0.0D0,0.0D0)
        DO MU = 1,3
          ELLSQ = ELLSQ + ( KINLOOP(JCUT,MU) + NEWKINLOOP(MU) )**2
        ENDDO
        ELL = COMPLEXSQRT(ELLSQ)
        NEWKINLOOP(0) = LOOPCUTSIGN*ELL - KINLOOP(JCUT,0)
      ELSE
        NEWKINLOOP(0) = (0.0D0,0.0D0)
      ENDIF
C....
      IF (REPORT) THEN
        IF( DETAILS .AND. (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))
        ENDIF
      ENDIF
C''''
C Now we calculate the complex propagator momenta.
C
      DO P = 0,NPROPS
        DO MU = 0,3
         KC(P,MU) = K(P,MU)
        ENDDO
      ENDDO
C
      DO J = 1,NINLOOP
       DO MU = 0,3
         KC(LOOPINDEX(J),MU) = KC(LOOPINDEX(J),MU)
     >       + LOOPSIGN(J) * NEWKINLOOP(MU)
        ENDDO
      ENDDO
C
C Calculate graph.
C
C Add to contribution for this point.
C
C If we have a virtual loop with 3 lines, then we may be computing
C the renormalization counter term. We tell by whether FLAG has been 
C set to 'renormalize 3 pt'. The flag value is simply passed on
C to FEYNMANF or FEYNMAN, but if the flag is set to 'renormalize 3 pt',
C we veto the factor 1/2 described below.
C
C If we don't want the counterterm, we want the main term. If we
C have a 3 or 4 point virtual loop, then we are averaging over
C closing the energy integral contour in the upper and lower
C half planes and we supply a 1/2.
C
      IF (ORDER.EQ.2) THEN
        IF (GAUGE.EQ.'feynman') THEN
          FEYNMANVAL = FEYNMANF(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
        ELSE IF (GAUGE.EQ.'coulomb') THEN
          FEYNMANVAL = FEYNMAN(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
        ELSE
          WRITE(*,*)'That gauge does not exist'
          STOP
        ENDIF
      ELSE IF (ORDER.EQ.1) THEN
        IF (GAUGE.EQ.'feynman') THEN
          FEYNMANVAL = FEYNMAN0F(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
        ELSE IF (GAUGE.EQ.'coulomb') THEN
          FEYNMANVAL = FEYNMAN0(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
        ELSE
          WRITE(*,*)'That gauge does not exist'
          STOP
        ENDIF
      ELSE
        WRITE(NOUT,*)'Order should have been 1 or 2'
        STOP
      ENDIF
      INTEGRAND = PREFACTOR * JACNEWPOINT * JACDEFORM 
     >            * FEYNMANVAL * SMEAR(RTS)
C
      IF ((NINLOOP.GT.2).AND.(FLAG.NE.'renormalize 3 pt')) THEN
        INTEGRAND = 0.5D0*INTEGRAND
      ENDIF
C
      MAXWEIGHT = MAX(MAXWEIGHT,ABS(XXREAL(INTEGRAND)))
      WEIGHT = WEIGHT + XXREAL(INTEGRAND)
C
      INTEGRAND = INTEGRAND * CALSVAL
      MAXPART = MAX(MAXPART,ABS(XXREAL(INTEGRAND)))
      VALUE = VALUE + INTEGRAND
C....
      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(8(1P G12.3))
        ENDIF
        IF (NINLOOP.GT.0) THEN
          IF (FLAG.EQ.'renormalize 3 pt') THEN
            WRITE(NOUT,372)INTEGRAND
372         FORMAT('Contribution (CT):',2(1P G18.10))
          ELSE
            WRITE(NOUT,373)LOOPINDEX(JCUT),INTEGRAND
373         FORMAT(I3,'  Contribution:',2(1P G18.10))
          ENDIF
        ELSE
          WRITE(NOUT,374)INTEGRAND
374       FORMAT('     Contribution:',2(1P G18.10))        
        ENDIF
        IF (DETAILS) THEN
          WRITE(NOUT,*)' '
        ENDIF
      ENDIF
C''''
C
C Compute a known integral to see if we have it right.
C Subroutine CHECKCALC calculates CHECK.
C
      IF (FLAG.NE.'renormalize 3 pt') THEN
        CALL 
     >  CHECKCALC(GRAPHNUMBER,CUTINDEX,KC,JACNEWPOINT,JACDEFORM,CHECK)
        IF (NINLOOP.GT.2) THEN
          CHECK = 0.5D0*CHECK
        ENDIF
      VALUECHK = VALUECHK + CHECK
      ENDIF
C
C End of loop DO WHILE (CALCMORE) that runs over loopcuts.
C
      ENDDO
C
C We are ready to call Hrothgar to process the result for this cut.
C
      CALL HROTHGAR(NCUT,KCUT,WEIGHT,1,'NEWRESULT ')
C
C Close loop DO CUTNUMBER = 1,NUMBEROFCUTS(GRAPHNUMBER)
C
      ENDDO
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C             End of subroutine to calculate integrand                 C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE 
     >  CHECKCALC(GRAPHNUMBER,CUTINDEX,KC,JACNEWPOINT,JACDEFORM,CHECK)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C In:
      INTEGER GRAPHNUMBER,CUTINDEX(SIZE+1)
      COMPLEX*16 KC(0:3*SIZE-1,0:3)
      REAL*8 JACNEWPOINT
      COMPLEX*16 JACDEFORM
C Out:
      COMPLEX*16 CHECK
C
C Compute a known integral to see if we have it right.
C This subroutine calculates the integrand.
C The check is based on 
C   Int d^3 p [p^2 + M^2]^(-3) = Pi^2/ (4 M^3).
C   Int d^3 p [p^2 (p^2 + M^2)]^(-1) = 2 Pi^2 /M
C Note that we look at just one term in the sum over cuts
C and loopcuts: 
C For graph 10, we take Cutindex = (7,5,4,1);
C For graph 8, we take Cutindex = (8,6,4,1), etc.
C
C Latest modification: 11 February 2002.
C
C Max number of graphs, cuts, maps for array sizes:
      INTEGER MAXGRAPHS,MAXMAPS
      PARAMETER (MAXGRAPHS = 12)
      PARAMETER (MAXMAPS = 64)
C Input and output units.
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C How many graphs and how many cuts and maps for each:
      INTEGER NUMBEROFGRAPHS
      INTEGER NUMBEROFCUTS(MAXGRAPHS)
      INTEGER NUMBEROFMAPS(MAXGRAPHS)
      COMMON /GRAPHCOUNTS/ NUMBEROFGRAPHS,NUMBEROFCUTS,NUMBEROFMAPS
C Reno size and counting variables:
      INTEGER GROUPSIZE(MAXGRAPHS,MAXMAPS)
      INTEGER GROUPSIZEGRAPH(MAXGRAPHS)
      INTEGER GROUPSIZETOTAL
      COMMON /MONTECARLO/GROUPSIZE,GROUPSIZEGRAPH,GROUPSIZETOTAL
C
      REAL*8 MM
      DATA MM /3.0D-1/
      REAL*8 PI
      DATA PI /3.1415926535898D0/
      COMPLEX*16 TEMP1,TEMP2,TEMP3
      INTEGER MU
C
C If it is not the right graph and the right cut, this default
C value will be returned.
C
      CHECK = (0.0D0,0.0D0)
C
      TEMP1 = 0.0D0
      TEMP2 = 0.0D0
      TEMP3 = 0.0D0
C
      IF (GRAPHNUMBER.EQ.12) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C
      ELSE IF (GRAPHNUMBER.EQ.11) THEN
C
        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)
          ENDDO
        ELSE
          RETURN
        ENDIF
C
      ELSE IF (GRAPHNUMBER.EQ.10) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C
      ELSE IF (GRAPHNUMBER.EQ.9) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C      
      ELSE IF (GRAPHNUMBER.EQ.8) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C
      ELSE IF (GRAPHNUMBER.EQ.7) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C
      ELSE IF (GRAPHNUMBER.EQ.6) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C 
      ELSE IF (GRAPHNUMBER.EQ.5) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C
      ELSE IF (GRAPHNUMBER.EQ.4) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C 
      ELSE IF (GRAPHNUMBER.EQ.3) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C 
      ELSE IF (GRAPHNUMBER.EQ.2) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C
      ELSE IF (GRAPHNUMBER.EQ.1) THEN
C
        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) 
          ENDDO
        ELSE
          RETURN
        ENDIF
C 
      ELSE
        WRITE(NOUT,*)'Problem with graph number in CHECKCALC'
        STOP
      ENDIF
C
      IF (GRAPHNUMBER.LE.10) THEN
C
C Here is an infrared sensitive check integral:
C
       CHECK =         TEMP1 * (TEMP1 + MM**2)
       CHECK = CHECK * TEMP2 * (TEMP2 + MM**2)
       CHECK = CHECK * (TEMP3 + MM**2)**3
       CHECK = (MM**5/PI**6) /CHECK
C
C Here is a nice smooth check integral:
C       CHECK =         (TEMP1 + MM**2)**3
C       CHECK = CHECK * (TEMP2 + MM**2)**3
C       CHECK = CHECK * (TEMP3 + (2.0D0*MM)**2)**3
C       CHECK = (512.0D0 * MM**9 / PI**6) /CHECK
C
      ELSE IF (GRAPHNUMBER.LE.12) THEN
C
        CHECK =         (TEMP1 + MM**2)**3
        CHECK = CHECK * (TEMP2 + MM**2)**3
        CHECK = (16.0D0 * MM**6 / PI**4) /CHECK
C
      ELSE
        WRITE(NOUT,*)'We were expecting graphnumbers 1,...,12'
        STOP
      ENDIF
C
      CHECK = JACDEFORM * JACNEWPOINT * CHECK
C
C Weight according to the number of points devoted to the current
C graph.
C
      CHECK = CHECK * GROUPSIZEGRAPH(GRAPHNUMBER)/GROUPSIZETOTAL
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION
     >    DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER)
C
      INTEGER SIZE,MAXMAPS
      PARAMETER (SIZE = 3)
      PARAMETER (MAXMAPS = 64)
C In:
      INTEGER GRAPHNUMBER
      REAL*8 K(0:3*SIZE-1,0:3)
      INTEGER QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE)
      CHARACTER*6 MAPTYPES(MAXMAPS)
      INTEGER NMAPS,ORDER
C
C Density of Monte Carlo points as a function of |K(p)|'s.
C 
C 29 June 1993
C 12 July 1993
C 17 July 1994
C  4 May 1996
C 21 November 1996
C  5 December 1996
C  5 February 1997
C 15 December 1998
C 23 December 1998
C  9 February 1999
C 10 March    1999
C 20 August   1999
C 21 December 2000
C 20 March    2001
C  1 February 2002
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NLOOPS
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      INTEGER MAXGRAPHS
      PARAMETER (MAXGRAPHS = 12)
      INTEGER GROUPSIZE(MAXGRAPHS,MAXMAPS)
      INTEGER GROUPSIZEGRAPH(MAXGRAPHS)
      INTEGER GROUPSIZETOTAL
      COMMON /MONTECARLO/GROUPSIZE,GROUPSIZEGRAPH,GROUPSIZETOTAL

C
      INTEGER MAPNUMBER,L,MU
      REAL*8 P1(3),P2(3),ELL1(3),ABSP1,ABSP2,ABSP3
      REAL*8 TEMP1,TEMP2,TEMP3,P1SQ,P2SQ,P3SQ
      CHARACTER*6 MAPTYPE
      INTEGER QSIGN(0:SIZE),Q(0:SIZE)
      REAL*8 RHO3,RHO2TO3D,RHO2TO3E,RHO2TO2T,RHO2TO2S,RHO2TO1
      REAL*8 RHOTHREE,RHOLOOP
C
      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
      ENDIF
C
      IF (ORDER.EQ.1) THEN
C
C We deal with the case of a Born graph first.
C
      DENSITY = 0.0D0
      DO MAPNUMBER = 1,NMAPS
C
      DO L = 0,NLOOPS
       Q(L) = QS(MAPNUMBER,L)
       QSIGN(L) = QSIGNS(MAPNUMBER,L)
      ENDDO
      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
      ENDDO
      ABSP1 = SQRT(P1SQ)
      ABSP2 = SQRT(P2SQ)
      ABSP3 = SQRT(P3SQ)
      RHOTHREE = RHO3(ABSP1,ABSP2,ABSP3)
      DENSITY = DENSITY
     >          + RHOTHREE*GROUPSIZE(GRAPHNUMBER,MAPNUMBER)
C
      ENDDO
C
C Alternative for  IF (ORDER.EQ.1) THEN
C
      ELSE IF (ORDER.EQ.2) THEN
C
C We tackle the case of an order alpha_s^2 graph.
C We construct the density as a sum.
C
      DENSITY = 0.0D0
      DO MAPNUMBER = 1,NMAPS
C
      MAPTYPE = MAPTYPES(MAPNUMBER)
      DO L = 0,NLOOPS
       Q(L) = QS(MAPNUMBER,L)
       QSIGN(L) = QSIGNS(MAPNUMBER,L)
      ENDDO
C
C First, we need the kinematic variables for this map.
C
      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
      ENDDO
      ABSP1 = SQRT(P1SQ)
      ABSP2 = SQRT(P2SQ)
      ABSP3 = SQRT(P3SQ)
C
C Now, there are two factors, one for the 'final state momenta' and
C one for the 'loop momentum.'
C
      RHOTHREE = RHO3(ABSP1,ABSP2,ABSP3)
C
      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.'T2TO1 ') THEN
        RHOLOOP = RHO2TO1(P1,P2,ELL1)
      ELSE 
        WRITE(NOUT,*)'Bad MAPTYPE in DENSITY'
        STOP
      ENDIF
C
      DENSITY = DENSITY
     >          + RHOTHREE*RHOLOOP*GROUPSIZE(GRAPHNUMBER,MAPNUMBER)
C
C Close  DO MAPNUMBER = 1,NMAPS 
C
      ENDDO
C
C Close for  IF (ORDER.EQ.1) THEN ...   ELSE IF (ORDER.EQ.2) THEN
C
      ELSE
        WRITE(NOUT,*)'ORDER should have been 1 or 2 in DENSITY.'
        STOP
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C           Subroutines associated with NEWPOINT and DENSITY           2
C   CHOOSEx and RHOx where x = 3, 2to2T, 2to2S, 2to3D, 2to3E, 2to1     2
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHOOSE3(P1,P2,P3,OK)
C
C Out:
      REAL*8 P1(3),P2(3),P3(3)
      LOGICAL OK
C
C Generates momenta P1(mu),P2(mu),P3(mu) for a three body final 
C state with a distribution in momentum fractions x1,x2,x3 
C proportional to
C
C        [max(1-x1,1-x2,1-x3)]^B/[(1-x1)*(1-x2)*(1-x3)]^B.
C
C 28 December 2000
C 16 January 2001
C
      REAL*8 BADNESSLIMIT,CANCELLIMIT,THRUSTCUT
      COMMON /LIMITS/ BADNESSLIMIT,CANCELLIMIT,THRUSTCUT
      REAL*8 ONETHIRD,TWOTHIRDS,PI
      PARAMETER(ONETHIRD  = 0.3333333333333333333D0)
      PARAMETER(TWOTHIRDS = 0.6666666666666666667D0)
      PARAMETER (PI = 3.141592653589793239D0)
C
C The parameter E3PAR should match between CHOOSE3 and RHO3.
C
      REAL*8 E3PAR
      PARAMETER(E3PAR = 1.5D0)
C
C The parameters A, B, and C need to match between CHOOSE3 and RHO3.
C CHOOSE3 uses A, while RHO3 uses B and C. The relation is
C B = 1 - 1/A and then C is the normalization factor and is
C a rather complicated function of B.
C
C Some soft and collinear points:
C
       REAL*8 A,B,C
       PARAMETER(A = 2.0D0)
       PARAMETER(B = 0.5D0)
       PARAMETER(C = 0.0036376552621307193655D0)
C
C Lots of soft and collinear points:
C
C      REAL*8 A,B,C
C      PARAMETER(A = 4.0D0)
C      PARAMETER(B = 0.75D0)
C      PARAMETER(C = 0.00058417226323428314253D0)
C
      REAL*8 X,RANDOM
      LOGICAL DONE
      INTEGER MU
      REAL*8 EMAX
      REAL*8 X1,X2,X3,Y1,Y2,Y3
      REAL*8 EA(3),EB(3),EC(3),ED(3)
      REAL*8 PHI,COSTHETA,SINTHETA
      REAL*8 K1(3),K2(3),K3(3)
C
C----------
C
      OK = .TRUE.
C
C We will generate vectors K1(mu), K2(mu), K3(mu) with |K1| > |K3| and
C |K2| > |K3|. At the end, we will associate each Ki(mu) with a Pj(mu)
C with the index j of the Pj(mu) that matches K3(mu) chosen at random.
C 
C We choose y1, y2, y3 in 0< y_i < 1 with y1 + y2 + y3 = 1. The y_i are
C related to the momentum fractions x_i by y_i = 1 - x_i. For the y_i,
C we want y3 to be the largest, with no specification about whether y1
C or y2 is larger.  We want to choose y1 and y2 with a 1/sqrt(y1*y2)
C distribution. Then y3 = 1 - y1 - y2.  We must insure that y3 > y1 and
C y3 > y2 for the point to be valid. Note that the allowed region is
C inside the region 0 < y1 < 1/2, 0 < y2 < 1/2. If we choose a random
C variable x in 0 < x < 1 and define y = x**2/2 then the density dx/dy
C is proportional to 1/sqrt(y) and 0 < y < 1/2.
C
C We loop until we are "done" choosing a valid point.
C
      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.
        ENDIF
      ENDDO
      X1 = 1.0D0 - Y1
      X2 = 1.0D0 - Y2
      X3 = Y1 + Y2
C
C If the chosen point is too soft or collinear, we will not be able
C to compute the kinematics for the rest of this subroutine
C or the other CHOOSEx subroutines, so we just abort.
C
      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
        ENDDO
        OK = .FALSE.
        RETURN
      ENDIF
C
C Choose Emax = sum_i |p_i| /2.
C
      X = RANDOM(1)
      EMAX = E3PAR * ( 1.0D0/X - 1.0D0 )**ONETHIRD
C
C Choose a direction EA(mu) at random on the unit sphere.
C
      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
C
C Generate vectors EB and EC that form a right handed basis set with EA.
C
      CALL AXES(EA,EB,EC)
C
C Generate a unit vector ED at a with a random azimuthal angle around
C the EA axis in this basis.
C
      X = RANDOM(1)
      PHI = 2.0D0 * PI * X
      DO MU = 1,3
        ED(MU) = COS(PHI)*EB(MU) + SIN(PHI)*EC(MU)
      ENDDO
C
C Now construct the momenta. P1(mu) is directed in the random direction
C EA(mu) with magnitude determined from Emax and X1. Then P3(mu)
C is in the plane of EA(mu) and ED(mu) with angle THETA to P1(mu) 
C determined from the Xi and magnitude determined by X2.
C
      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)
      ENDDO
C
C Match K3(mu) to one of the Pi(mu) at random.
C
      X = RANDOM(1)
      IF (X.GT.TWOTHIRDS) THEN
        DO MU = 1,3
          P1(MU) = K1(MU)
          P2(MU) = K2(MU)
          P3(MU) = K3(MU)
        ENDDO
      ELSE IF (X.GT.ONETHIRD) THEN
        DO MU = 1,3
          P1(MU) = K2(MU)
          P2(MU) = K3(MU)
          P3(MU) = K1(MU)
        ENDDO
      ELSE
        DO MU = 1,3
          P1(MU) = K3(MU)
          P2(MU) = K1(MU)
          P3(MU) = K2(MU)
        ENDDO
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION RHO3(ABSP1,ABSP2,ABSP3)
C
C In:
      REAL*8 ABSP1,ABSP2,ABSP3
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C Density of points for points chosen with CHOOSE3(p1,p2,p3,ok).
C 16 January 2001
C
      REAL*8 EMAX,X1,X2,X3
      REAL*8 E03,EMAX3,FACTOR,DENOM
C
C The parameter E3PAR should match between CHOOSE3 and RHO3.
C 
      REAL*8 E3PAR
      PARAMETER(E3PAR = 1.5D0)
C
C The parameters A, B, and C need to match between CHOOSE3 and RHO3.
C CHOOSE3 uses A, while RHO3 uses B and C. The relation is
C B = 1 - 1/A and then C is the normalization factor and is
C a rather complicated function of B.
C
C Some soft and collinear points:
C
       REAL*8 A,B,C
       PARAMETER(A = 2.0D0)
       PARAMETER(B = 0.5D0)
       PARAMETER(C = 0.0036376552621307193655D0)
C
C Lots of soft and collinear points:
C
C      REAL*8 A,B,C
C      PARAMETER(A = 4.0D0)
C      PARAMETER(B = 0.75D0)
C      PARAMETER(C = 0.00058417226323428314253D0)
C
      EMAX = 0.5D0*(ABSP1 + ABSP2 + ABSP3)
      X1 = ABSP1/EMAX
      X2 = ABSP2/EMAX
      X3 = ABSP3/EMAX
C
      IF (X1.LT.X2) THEN
        IF (X1.LT.X3) THEN
C         X1 is smallest: X1<X2<X3 or X1<X3<X2
          FACTOR = ((1.0D0-X2)*(1.0D0-X3))**B
        ELSE
C         X3 is smallest: X3<X1<X2
          FACTOR = ((1.0D0-X1)*(1.0D0-X2))**B
        ENDIF
      ELSE
        IF (X2.LT.X3) THEN
C         X2 is smallest: X2<X1<X3 or X2<X3<X1
          FACTOR = ((1.0D0-X3)*(1.0D0-X1))**B
        ELSE
C         X3 is smallest: X3<X2<X1
          FACTOR = ((1.0D0-X1)*(1.0D0-X2))**B
        ENDIF
      ENDIF
      IF(FACTOR.LT.1.0D-15) THEN
        WRITE(NOUT,*)'FACTOR too small in RHO3',X1,X2,X3
        STOP
      ENDIF
C
      E03 = E3PAR**3
      EMAX3 = EMAX**3
      DENOM = E03 * EMAX3 * (EMAX3/E03 + 1.0D0)**2 
      DENOM = DENOM * X1 * X2 * X3 * FACTOR
      RHO3 = C/DENOM
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHOOSE2TO2S(PA,PB,ELL,OK)
C In:
      REAL*8 PA(3),PB(3)
C Out:
      REAL*8 ELL(3)
      LOGICAL OK
C
C Generates a point ell(mu) using an elliptical coordinate system
C based on the vectors p_A(mu) and p_B(mu). The points are concentrated
C near Ell(mu) = 0 and near the ellipse |ell| + |q - el| = |p_A| + |p_B|
C where q = p_A + p_B.
C 15 December 2000
C 14 Maarch 2001
C
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
C Input and output units.
C  
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C Function RANDOM(1) give a random number in the range 0<x<1.
C
      REAL*8 RANDOM,X
C
C Function EXPM1(z) gives exp(z) - 1 while SQRTM1(z) gives sqrt(1+z) -1.
C
      REAL*8 EXPM1,SQRTM1
C
      REAL*8 ABSPA,ABSPB
      REAL*8 SUMAB(3),CROSS(3)
      REAL*8 TWOKAPPA,KAPPA,ABSCROSS
      REAL*8 NZ(3),NY(3),NX(3)
      REAL*8 PHI,AMINUS,APLUS
      REAL*8 SPLUS,TAU,CM1,C,N
      REAL*8 LAMBDA,LOGA,LOGB,SPLUSL,SMINUSL,NORM,CPLUS,TEMP
      REAL*8 LZ,LT,LX,LY
C
C-----------------------------------------------------------------------
C
      OK = .TRUE.
C
C First we calculate the unit vectors n_x, n_y, n_z used to define
C the orientation of the elliptical coordinate system. For later
C use, the variable |p_a + p_b| gets a special name, 2 kappa.
C
      ABSPA = SQRT(PA(1)**2 + PA(2)**2 + PA(3)**2)
      ABSPB = SQRT(PB(1)**2 + PB(2)**2 + PB(3)**2)
C
      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
      ENDIF
      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.
      ENDIF
      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)
C
C Choose phi.
C
      X = RANDOM(1)
      PHI = PI * (2.0D0*X - 1.0D0)
C
C Choose A-.
C Here N is N-/C.
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)
C
C Choose A+.
C
      LAMBDA = (SPLUS - 1.0D0)**2/SPLUS
      LOGA = LOG(SPLUS*(SPLUS - 1.0D0 + LAMBDA)/LAMBDA)
      LOGB = LOG(SPLUS/LAMBDA)
      SPLUSL = SPLUS + LAMBDA
      SMINUSL = SPLUS - LAMBDA
C
      NORM  = 1.0D0/( LOGA/SPLUSL + LOGB/SMINUSL )
      CPLUS = 1.0D0/(1.0D0 + SPLUSL*LOGB/(SMINUSL*LOGA) )
C
      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.
        ENDIF
        APLUS = SMINUSL/TEMP
      ELSE
        TEMP = 1.0D0 + LAMBDA/SPLUS * EXP( SPLUSL*(CPLUS - X)/NORM )
        APLUS = SPLUSL/TEMP
      ENDIF
C
C We now have A+, A-, and phi so we find ell(mu).
C
      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)
      ELL(1) = LX*NX(1) + LY*NY(1) + LZ*NZ(1)
      ELL(2) = LX*NX(2) + LY*NY(2) + LZ*NZ(2)
      ELL(3) = LX*NX(3) + LY*NY(3) + LZ*NZ(3)
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION RHO2TO2S(PA,PB,ELL)
      REAL*8 PA(3),PB(3),ELL(3)
C
C Density function for points ell chosen by CHOOSE2TO2S(p_a,p_b,ell,ok).
C 15 December 2000
C 20 March 2001
C
C Input and output units.
C      
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
C Function SQRTM1(z) gives sqrt(1+z) -1.
C
      REAL*8 SQRTM1
C
      INTEGER MU
      REAL*8 SUMABSQ,ELLSQ,ELLPRIMESQ,PASQ,PBSQ
      REAL*8 TWOKAPPA,KAPPA,ABSELL,ABSELLPRIME,ABSPA,ABSPB
      REAL*8 SPLUS,APLUS,AMINUS
      REAL*8 TAU,CM1,C
      REAL*8 LAMBDA,LOGA,LOGB,SPLUSL,SMINUSL
      REAL*8 TEMP,DENOM
C
C-----------------------------------------------------------------------
C We start with the absolute values of combinations of vectors.
C
      SUMABSQ = 0.0D0
      ELLSQ = 0.0D0
      ELLPRIMESQ = 0.0D0
      PASQ = 0.0D0
      PBSQ = 0.0D0
      DO MU = 1,3
        TEMP = PA(MU) + PB(MU)
        SUMABSQ = SUMABSQ + TEMP**2
        ELLSQ =  ELLSQ + ELL(MU)**2
        ELLPRIMESQ =  ELLPRIMESQ  + (ELL(MU) - TEMP)**2
        PASQ = PASQ + PA(MU)**2
        PBSQ = PBSQ + PB(MU)**2
      ENDDO
      TWOKAPPA = SQRT(SUMABSQ)
      KAPPA = 0.5D0*TWOKAPPA
      ABSELL = SQRT(ELLSQ)
      ABSELLPRIME = SQRT(ELLPRIMESQ)
      ABSPA = SQRT(PASQ)
      ABSPB = SQRT(PBSQ)
C
C Now S+ and S- and A+ and A-.
C
      SPLUS  = (ABSPA + ABSPB)/TWOKAPPA
      APLUS =  (ABSELL + ABSELLPRIME)/TWOKAPPA
      AMINUS = (ABSELL - ABSELLPRIME)/TWOKAPPA
C
C Finally some auxilliary parameters.
C
      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
      ENDIF
C
C RHO is the inverse of the product of several factors.
C Phi factor:
      TEMP = 2.0D0*PI
C A- normalization:
      TEMP = TEMP*LOG((C + 1.0D0)/CM1)/C
C A- factor:
      TEMP = TEMP*(C**2 - AMINUS**2)
C A+ normalization:
      TEMP = TEMP*(LOGA/SPLUSL + LOGB/SMINUSL)
C A+ factor:
      TEMP = TEMP*APLUS*( ABS(APLUS - SPLUS) + LAMBDA )
C Jacobian for k to A+,A-,phi:
      TEMP = TEMP*KAPPA**3*DENOM
C Invert this:
      RHO2TO2S = 1.0D0/TEMP
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHOOSE2TO2T(PA,PB,ELL,OK)
C In:
      REAL*8 PA(3),PB(3)
C Out:
      REAL*8 ELL(3)
      LOGICAL OK
C
C Generates a point ell(mu) using an elliptical coordinate system
C based on the vectors p_A(mu) and p_B(mu). The points are concentrated
C near ell(mu) = 0 and near the ellipse |p_A + ell| + |p_B - ell| =
C |p_A| + |p_B|.
C 28 December 1999
C 13 March 2001
C
C The parameters A2T02T, B2TO2T, C2TO2T 
C must match between CHOOSE2TO2T and RHO2TO2T. 
C
      REAL*8 A2TO2T,B2TO2T,C2TO2T
      PARAMETER (A2TO2T = 0.3D0)
      PARAMETER (B2TO2T = 0.3D0)
      PARAMETER (C2TO2T = 6.0D0)
C
C The parameter CONST is a derived number, equal to 
C (1/g)*(log(1/g)**2 - 2*log(1/g) + 2) where g = C2TO2T. For
C g = 6, this constant is 1.4656534890040852295.
C
      REAL*8 CONST
      PARAMETER (CONST = 1.4656534890040852295D0)
C
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
C Input and output units.
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C Function SQRTM1(x) gives sqrt(1+x) - 1.
C Function EXPM1(x)  gives exp(x) - 1.
C Function INVLOGSQINT(w) = y <==> w = y*(Log(y)**2 - 2*Log(y) + 2).
C Function RANDOM(1) give a random number in the range 0<x<1.
C
      REAL*8 SQRTM1,EXPM1,INVLOGSQINT,RANDOM
C
      REAL*8 SUMAB(3),CROSS(3)
      REAL*8 TWOKAPPA,ABSCROSS
      REAL*8 NZ(3),NY(3),NX(3)
      REAL*8 KAPPA,ABSPA,ABSPB,SPLUS,SMINUS
      REAL*8 X,TWOXM1,W,PHI,PHIPI
      REAL*8 LPHI2,LP2,LM2,NMINUS,CMINUS,ROOT,DAMINUS,DX,AMINUS
      REAL*8 OMEGA,SPLUSM1,BSW,A,B,NPLUS,CPLUS,FACTOR,APLUS
      REAL*8 DAPLUS,TEMP
      REAL*8 UPLUS,UMINUS,VPLUS,VMINUS,LT0,Z0,ZETA,DLT,DZ
      REAL*8 SINPHI,COSPHI,COSPHIM1,LX,LY
C
      REAL*8 TAU,CM1,C,N
      REAL*8 LAMBDA,LOGA,LOGB,SPLUSL,SMINUSL,NORM
      REAL*8 LZ,LT
C
C
C-----------------------------------------------------------------------
C
      OK = .TRUE.
C
C First we calculate the unit vectors n_x, n_y, n_z used to define
C the orientation of the elliptical coordinate system. For later
C use, the variable |p_a + p_b| gets a special name, 2 kappa.
C
      ABSPA = SQRT(PA(1)**2 + PA(2)**2 + PA(3)**2)
      ABSPB = SQRT(PB(1)**2 + PB(2)**2 + PB(3)**2)
C
      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.
      ENDIF
      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.
      ENDIF
      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)
C
C At this point, we have two options. There is a main way to choose
C our point and there is a subsidiary way, which is the same as in
C CHOOSE2TO2S. If a random variable X is greater than A2TO2T, 
C we choose the main way, otherwise we choose the subsidiary way.
C
      IF (RANDOM(1).GT.A2TO2T) THEN
C
C Now some variables that depend on p_a and p_b, namely S+ and S-.
C
      SPLUS  = (ABSPA + ABSPB)/TWOKAPPA
      SMINUS = (ABSPA - ABSPB)/TWOKAPPA
C
C Choose phi.
C The standard function SIGN(xx,X) gives xx with the sign of X.
C For later use, we define PHIPI = |Phi|/Pi.
C
      X = RANDOM(1)
      TWOXM1 = 2.0D0*X - 1.0D0
      W = CONST*ABS(TWOXM1)
      PHIPI = C2TO2T*INVLOGSQINT(W)
      PHI = PI * SIGN(PHIPI,TWOXM1)
C
C Choose A-.
C There are three versions for the same thing, chosen according to
C which one should give the most accurate result, especially if
C |phi| is small.
C
      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)
      ENDIF
      AMINUS = SMINUS + DAMINUS
C
C Choose A+.
C There are three versions for the same thing, chosen according to
C which one should give the most accurate result, especially if
C omega is small. 
C EXPM1(X) gives exp(x) - 1.
C
      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
      ENDIF
C
C We now have A+, A-, and phi so we find ell(mu).
C Use SQRTM1(zeta) = SQRT(1+zeta) - 1.
C
        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
        ENDIF
        LX = DLT*COSPHI + LT0*COSPHIM1
        LY = (LT0 + DLT)*SINPHI
        ELL(1) = LX*NX(1) + LY*NY(1) + DZ*NZ(1)
        ELL(2) = LX*NX(2) + LY*NY(2) + DZ*NZ(2)
        ELL(3) = LX*NX(3) + LY*NY(3) + DZ*NZ(3)
C
      RETURN
C
C Recall, we had two options. There was a main way to choose
C our point and there was a subsidiary way, which is the same as in
C CHOOSE2TO2S. If a random variable X was greater than A2TO2T, 
C we choose the main way, otherwise we get to here and choose the 
C subsidiary way, from CHOOSE2TO2S.
C
      ELSE
C-----
C Choose phi.
C
      X = RANDOM(1)
      PHI = PI * (2.0D0*X - 1.0D0)
C
C Choose A-.
C Here N is N-/C.
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)
C
C Choose A+.
C
      LAMBDA = (SPLUS - 1.0D0)**2/SPLUS
      LOGA = LOG(SPLUS*(SPLUS - 1.0D0 + LAMBDA)/LAMBDA)
      LOGB = LOG(SPLUS/LAMBDA)
      SPLUSL = SPLUS + LAMBDA
      SMINUSL = SPLUS - LAMBDA
C
      NORM  = 1.0D0/( LOGA/SPLUSL + LOGB/SMINUSL )
      CPLUS = 1.0D0/(1.0D0 + SPLUSL*LOGB/(SMINUSL*LOGA) )
C
      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.
        ENDIF
        APLUS = SMINUSL/TEMP
      ELSE
        TEMP = 1.0D0 + LAMBDA/SPLUS * EXP( SPLUSL*(CPLUS - X)/NORM )
        APLUS = SPLUSL/TEMP
      ENDIF
C
C We now have A+, A-, and phi so we find ell(mu).
C
      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)
C-----
C Here we copy the construction of ell from CHOOSE2TO2S except
C that ell_T = ell_S - PA, so we have to subtract PA.
C
      ELL(1) = LX*NX(1) + LY*NY(1) + LZ*NZ(1) - PA(1)
      ELL(2) = LX*NX(2) + LY*NY(2) + LZ*NZ(2) - PA(2)
      ELL(3) = LX*NX(3) + LY*NY(3) + LZ*NZ(3) - PA(3)
C
      RETURN
C
C End of IF (RANDOM(1).GT.A2TO2T) THEN ... ELSE ...
C
      ENDIF

      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION RHO2TO2T(PA,PB,ELL)
      REAL*8 PA(3),PB(3),ELL(3)
C
C Density function for points ell chosen by CHOOSE2TO2T(p_a,p_b,ell,ok).
C 28 December 1999
C 13 March 2001
C
C Input and output units.      
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C The parameters A2TO2T, B2TO2T, C2TO2T
C must match between CHOOSE2TO2T and RHO2TO2T. 
C
      REAL*8 A2TO2T,B2TO2T,C2TO2T
      PARAMETER (A2TO2T = 0.3D0)
      PARAMETER (B2TO2T = 0.3D0)
      PARAMETER (C2TO2T = 6.0D0)
C
C The parameter CNST is a derived number, equal to 
C 1/[2 Pi*(log(1/g)**2 - 2*log(1/g) + 2)] where g = C2TO2T. For
C g = 6, this constant is 0.0180982913407954142662161898.
C
      REAL*8 CNST
      PARAMETER (CNST = 0.0180982913407954142662D0)
C
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
C Function SQRTM1(x) gives sqrt(1+x) - 1.
C
      REAL*8 SQRTM1
C
      REAL*8 SUMAB(3),CROSS(3)
      REAL*8 TWOKAPPA,ABSCROSS
      REAL*8 NZ(3),NY(3),NX(3)
      REAL*8 KAPPA,PASQ,PBSQ,ABSPA,ABSPB,SPLUS,SMINUS
      REAL*8 ELLSQ,DOTAL,DOTBL
      REAL*8 WA,WB,VA,VB,DAPLUS,DAMINUS,APLUS,AMINUS
      REAL*8 DOTLSTARNX,DOTLSTARNY,PHI,PHIPI
      REAL*8 RHO0
      REAL*8 RHOPHI
      REAL*8 TEMP,NMINUS,OMEGA
      REAL*8 RHOMINUS
      REAL*8 SPLUSM1,BSW,A,B,NPLUS,DENOM1,DENOM2
      REAL*8 RHOPLUS
      REAL*8 DENOM
      REAL*8 RHOMAIN,RHOEXTRA
      REAL*8 TAU,CM1,C,LAMBDA,LOGA,LOGB,SPLUSL,SMINUSL
C
C-----------------------------------------------------------------------
C First we calculate the unit vectors n_x, n_y, n_z used to define
C the orientation of the elliptical coordinate system. For later
C use, the variable |p_a + p_b| gets a special name, 2 kappa.
C
      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)
C
      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 RHOELLIPSE',KAPPA
        STOP
      ENDIF
      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
      ENDIF
      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)
C
C Now some further variables that do not depend on ell, namely
C S+ and S-.
C
      SPLUS  = (ABSPA + ABSPB)/TWOKAPPA
      SMINUS = (ABSPA - ABSPB)/TWOKAPPA
C
C Next, the dot products of ell.
C
      ELLSQ = ELL(1)**2 + ELL(2)**2 + ELL(3)**2
      DOTAL = PA(1)*ELL(1) + PA(2)*ELL(2) + PA(3)*ELL(3)
      DOTBL = PB(1)*ELL(1) + PB(2)*ELL(2) + PB(3)*ELL(3)
C
C With these we can calculate A+ and A-. We first calculate
C DA+ = A+ - S+ and DA- = A- - S- since these  variables appear in
C the density functions and they are small when ell
C is small. Thus we want to know these separately from A+ and A-.
C We use the function SQRTM1(x) = sqrt(1+x) - 1 to define 
C V_a = |p_a + ell| - |p_a| and V_b = |p_b - ell| - |p_b|.
C
      WA = (  2.0D0*DOTAL + ELLSQ)/PASQ
      WB = ( -2.0D0*DOTBL + ELLSQ)/PBSQ
      VA = ABSPA*SQRTM1(WA)
      VB = ABSPB*SQRTM1(WB)
      DAPLUS  = (VA + VB)/TWOKAPPA
      DAMINUS = (VA - VB)/TWOKAPPA
      APLUS  = DAPLUS  + SPLUS
      AMINUS = DAMINUS + SMINUS
C
C We can also calculate phi. For this, we need the the dot products of 
C L* with the unit vectors n_x and n_y. Here L* = Pa + Ell. Note that
C NY is orthogonal to Pa so for an accurate calculation in the case
C that Ell is small, we drop Pa from L* when dotting into Ny. For later
C use, we define PHIPI = |Phi|/Pi.

      DOTLSTARNX =  (PA(1) + ELL(1))*NX(1) + (PA(2) + ELL(2))*NX(2)
     >            + (PA(3) + ELL(3))*NX(3)
      DOTLSTARNY = ELL(1)*NY(1) + ELL(2)*NY(2) + ELL(3)*NY(3)
      PHI = ATAN2(DOTLSTARNY,DOTLSTARNX)
      PHIPI = ABS(PHI/PI)
C
C Now we are ready to calculate the density. First the factor rho0
C that gives the jacobian for the change of variables from 
C {ell(1), ell(2), ell(3)} to {A+,A-,phi}.
C
      DENOM = APLUS**2 - AMINUS**2
      IF (DENOM.LT.1.0D0-12) THEN
        WRITE(NOUT,*)'DENOM too small in RHO2TO2T',APLUS,AMINUS
        STOP
      ENDIF
      RHO0 = 1.0D0/(KAPPA**3 * DENOM)
C
C Next the factor for our choice of phi.
C
      RHOPHI = CNST * LOG(PHIPI/C2TO2T)**2
C
C Next the factor for our choice of A-.
C
      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
C
C Finally the factor for our choice of A+.
C
      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)
C
C The net density is the product of the factors just calculated.
C
      RHOMAIN = RHO0*RHOPLUS*RHOMINUS*RHOPHI
C
C Now we calculate a subsidiary rho just as in RHO2TO2S.
C---------
C
      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
      ENDIF
C
C RHO is the inverse of the product of several factors.
C Phi factor:
      TEMP = 2.0D0*PI
C A- normalization:
      TEMP = TEMP*LOG((C + 1.0D0)/CM1)/C
C A- factor:
      TEMP = TEMP*(1.0D0 - AMINUS**2 + TAU)
C A+ normalization:
      TEMP = TEMP*(LOGA/SPLUSL + LOGB/SMINUSL)
C A+ factor:
      TEMP = TEMP*APLUS*( ABS(APLUS - SPLUS) + LAMBDA )
C Jacobian for k to A+,A-,phi:
      TEMP = TEMP*KAPPA**3*DENOM
C Invert this:
      RHOEXTRA = 1.0D0/TEMP
C
C---------
C End of subsidiary rho calculation.
C
      RHO2TO2T = (1.0D0 - A2TO2T)*RHOMAIN + A2TO2T*RHOEXTRA
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHOOSE2TO3D(PA,PB,ELL,OK)
C In:
      REAL*8 PA(3),PB(3)
C Out:
      REAL*8 ELL(3)
      LOGICAL OK
C
C Generates a point ell(mu) using a circular coordinate system
C based on the vectors p_A(mu) and p_B(mu). The points are concentrated
C near the circle |ell| = (|p_A| + |p_B| + |p_A + p_B|)/2. There is
C a special concentration near theta = 0, the direction of the largest
C of p_A and -p_B.
C 
C 18 December 2000
C 21 March 2001
C
C Input and output units.      
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C The parameter A2TO3 needs to match between CHOOSE2TO3D and RHO2TO3D.
C
      REAL*8 A2TO3
      PARAMETER (A2TO3 = 3.0D0)
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
C Function EXPM1(x)  gives exp(x) - 1.
C Function RANDOM(1) give a random number in the range 0<x<1.
C
      REAL*8 EXPM1,RANDOM
C
      REAL*8 PC(3)
      REAL*8 ABSPA,ABSPB,ABSPC,SC
      REAL*8 NZ(3),NY(3),NX(3)
      REAL*8 S,SDIFFSQ
      REAL*8 X
      REAL*8 PHI,ONEMINUSCOS,COSTHETA,SINTHETA,R
      REAL*8 TEMP,DELTASQ,DELTA,A,B,N,X0
      REAL*8 LX,LY,LZ
C
C-----------------------------------------------------------------------
C
      OK = .TRUE.
C
C First we calculate the unit vectors n_x, n_y, n_z used to define
C the orientation of the spherical coordinate system. The z-axis goes 
C along the direction of the largest of PA and - PB.
C
      PC(1) = - PA(1) - PB(1)
      PC(2) = - PA(2) - PB(2)
      PC(3) = - PA(3) - PB(3)
C
      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)
C
      SC = ABSPC
      NZ(1) = -PC(1)/ABSPC
      NZ(2) = -PC(2)/ABSPC
      NZ(3) = -PC(3)/ABSPC
C
      CALL AXES(NZ,NX,NY)
C
C Now some further variables.
C
      S = 0.5D0 *(ABSPA + ABSPB + ABSPC)
      SDIFFSQ = (1.0D0 - SC/S)**2
C
C Choose phi.
C
      PHI = 2.0D0 * PI * RANDOM(1)
C
C Choose theta.
C Use cos(theta) = 1.0D0 - SDIFFSQ * [exp(x*log(1+2/SDIFFSQ)) - 1]
C
      X = RANDOM(1)
      TEMP = LOG(1.0D0 + 2.0D0/SDIFFSQ)
      ONEMINUSCOS = SDIFFSQ * EXPM1(TEMP*X)
      COSTHETA = 1.0D0 - ONEMINUSCOS
C
C Choose r.
C
      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))
C
      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
      ENDIF
C
C We now have r, theta, and phi so we find ell(mu).
C
      SINTHETA = SQRT((1.0D0 + COSTHETA)*ONEMINUSCOS)
      LX = R*SINTHETA*COS(PHI)
      LY = R*SINTHETA*SIN(PHI)
      LZ = R*COSTHETA
      ELL(1) = LX*NX(1) + LY*NY(1) + LZ*NZ(1)
      ELL(2) = LX*NX(2) + LY*NY(2) + LZ*NZ(2)
      ELL(3) = LX*NX(3) + LY*NY(3) + LZ*NZ(3)
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION RHO2TO3D(PA,PB,ELL)
C 
      REAL*8 PA(3),PB(3),ELL(3)
C
C Density function for points ell chosen by CHOOSE2TO3D(p_a,p_b,ell,ok).
C
C 15 November 2000
C 21 March 2001
C
C Input and output units.      
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C The parameter A2TO3 needs to match between CHOOSE2TO3D and RHO2TO3D.
C
      REAL*8 A2TO3
      PARAMETER (A2TO3 = 3.0D0)
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
      REAL*8 PC(3)
      REAL*8 ABSPA,ABSPB,ABSPC,R,SC
      REAL*8 NZ(3),V(3)
      REAL*8 S,SDIFFSQ
      REAL*8 ONEMINUSCOS
      REAL*8 TEMP,PARAMSQ,PARAM,DELTASQ,DELTA,A,B,N,DENOM
      REAL*8 RHOR
C
C-----------------------------------------------------------------------
C First we calculate the unit vectors n_z. The z-axis goes 
C along the direction of the largest of PA and - PB.
C
      PC(1) = - PA(1) - PB(1)
      PC(2) = - PA(2) - PB(2)
      PC(3) = - PA(3) - PB(3)
C
      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(ELL(1)**2 + ELL(2)**2 + ELL(3)**2)
C
      SC = ABSPC
      NZ(1) = -PC(1)/ABSPC
      NZ(2) = -PC(2)/ABSPC
      NZ(3) = -PC(3)/ABSPC
C
C Now some further variables.
C
      S = 0.5D0 *(ABSPA + ABSPB + ABSPC)
      SDIFFSQ = (1.0D0 - SC/S)**2
C
C Density for d^3ell -> dr d costheta d phi
C
      RHO2TO3D = 1.0D0/R**2
C
C Density for phi.
C
      RHO2TO3D = RHO2TO3D/(2.0D0 * PI)
C
C Density for theta.
C We construct 1 - cos(theta) as (HatEll - Nz)^2 /2 since
C that is more accurate than constructing cos(theta) and
C subtracting it from 1.0 if 1 - cos(theta) is small.
C
      V(1) = ELL(1)/R - NZ(1)
      V(2) = ELL(2)/R - NZ(2)
      V(3) = ELL(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
C
C Density for r.
C
      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
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHOOSE2TO3E(PA,PB,ELL,OK)
C In:
      REAL*8 PA(3),PB(3)
C Out:
      REAL*8 ELL(3)
      LOGICAL OK
C
C Generates a point ell(mu) using a circular coordinate system
C based on the vectors p_A(mu) and p_B(mu). The points are concentrated
C near the circle |ell| = (|p_A| + |p_B| + |p_A + p_B|)/2. There is
C a special concentration near theta = 0, the direction of the largest
C of -p_A - p_B.
C 
C 18 December 2000
C 21 March 2001
C
C Input and output units.      
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C The parameter A2TO3 needs to match between CHOOSE2TO3E and RHO2TO3E.
C
      REAL*8 A2TO3
      PARAMETER (A2TO3 = 3.0D0)
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
C Function EXPM1(x)  gives exp(x) - 1.
C Function RANDOM(1) give a random number in the range 0<x<1.
C
      REAL*8 EXPM1,RANDOM
C
      REAL*8 PC(3)
      REAL*8 ABSPA,ABSPB,ABSPC,SC
      REAL*8 NZ(3),NY(3),NX(3)
      REAL*8 S,SDIFFSQ
      REAL*8 X
      REAL*8 PHI,ONEMINUSCOS,COSTHETA,SINTHETA,R
      REAL*8 TEMP,DELTASQ,DELTA,A,B,N,X0
      REAL*8 LX,LY,LZ
C
C-----------------------------------------------------------------------
C
      OK = .TRUE.
C
C First we calculate the unit vectors n_x, n_y, n_z used to define
C the orientation of the spherical coordinate system. The z-axis goes 
C along the direction of the largest of PA and - PB.
C
C
      PC(1) = - PA(1) - PB(1)
      PC(2) = - PA(2) - PB(2)
      PC(3) = - PA(3) - PB(3)
C
      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)
C
      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
      ENDIF
C
      CALL AXES(NZ,NX,NY)
C
C Now some further variables.
C
      S = 0.5D0 *(ABSPA + ABSPB + ABSPC)
      SDIFFSQ = (1.0D0 - SC/S)**2
C
C Choose phi.
C
      PHI = 2.0D0 * PI * RANDOM(1)
C
C Choose theta.
C Use cos(theta) = 1.0D0 - SDIFFSQ * [exp(x*log(1+2/SDIFFSQ)) - 1]
C
      X = RANDOM(1)
      TEMP = LOG(1.0D0 + 2.0D0/SDIFFSQ)
      ONEMINUSCOS = SDIFFSQ * EXPM1(TEMP*X)
      COSTHETA = 1.0D0 - ONEMINUSCOS
C
C Choose r.
C
      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))
C
      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
      ENDIF
C
C We now have r, theta, and phi so we find ell(mu).
C
      SINTHETA = SQRT((1.0D0 + COSTHETA)*ONEMINUSCOS)
      LX = R*SINTHETA*COS(PHI)
      LY = R*SINTHETA*SIN(PHI)
      LZ = R*COSTHETA
      ELL(1) = LX*NX(1) + LY*NY(1) + LZ*NZ(1)
      ELL(2) = LX*NX(2) + LY*NY(2) + LZ*NZ(2)
      ELL(3) = LX*NX(3) + LY*NY(3) + LZ*NZ(3)
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION RHO2TO3E(PA,PB,ELL)
C 
      REAL*8 PA(3),PB(3),ELL(3)
C
C Density function for points ell chosen by CHOOSE2TO3E(p_a,p_b,ell,ok).
C
C 15 November 2000
C 21 March 2001
C
C Input and output units.      
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C The parameter A2TO3 needs to match between CHOOSE2TO3E and RHO2TO3E.
C
      REAL*8 A2TO3
      PARAMETER (A2TO3 = 3.0D0)
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
      REAL*8 PC(3)
      REAL*8 ABSPA,ABSPB,ABSPC,R,SC
      REAL*8 NZ(3),V(3)
      REAL*8 S,SDIFFSQ
      REAL*8 ONEMINUSCOS
      REAL*8 TEMP,PARAMSQ,PARAM,DELTASQ,DELTA,A,B,N,DENOM
      REAL*8 RHOR
C
C-----------------------------------------------------------------------
C First we calculate the unit vectors n_z. The z-axis goes 
C along the direction of the largest of PA and - PB.
C
      PC(1) = - PA(1) - PB(1)
      PC(2) = - PA(2) - PB(2)
      PC(3) = - PA(3) - PB(3)
C
      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(ELL(1)**2 + ELL(2)**2 + ELL(3)**2)
C
      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
      ENDIF
C
C Now some further variables.
C
      S = 0.5D0 *(ABSPA + ABSPB + ABSPC)
      SDIFFSQ = (1.0D0 - SC/S)**2
C
C Density for d^3ell -> dr d costheta d phi
C
      RHO2TO3E = 1.0D0/R**2
C
C Density for phi.
C
      RHO2TO3E = RHO2TO3E/(2.0D0 * PI)
C
C Density for theta.
C We construct 1 - cos(theta) as (HatEll - Nz)^2 /2 since
C that is more accurate than constructing cos(theta) and
C subtracting it from 1.0 if 1 - cos(theta) is small.
C
      V(1) = ELL(1)/R - NZ(1)
      V(2) = ELL(2)/R - NZ(2)
      V(3) = ELL(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
C
C Density for r.
C
      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
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CHOOSE2TO1(PA,PB,ELL,OK)
C In:
      REAL*8 PA(3),PB(3)
C Out:
      REAL*8 ELL(3)
      LOGICAL OK
C
C Generates a point ell(mu) for a self-energy graph that leads to a
C propagator with momemtum Pa(mu) that enters the final state.
C We want a map concentrating points rather collinearly with Pa(mu).
C
C 18 December 2000
C 18 March 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C The parameters B2TO1, C2TO1, A2TO1A and A2TO1B need to match 
C between CHOOSE2TO1 and RHO2TO1.
C
      REAL*8 B2TO1,C2TO1,A2TO1A,A2TO1B
      PARAMETER (B2TO1 = 0.4D0)
      PARAMETER (C2TO1 = 0.4D0)
      PARAMETER (A2TO1A = 0.05D0)
      PARAMETER (A2TO1B = 0.25D0)
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
      INTEGER MU
      REAL*8 PASQ,ABSPA,PBSQ,ABSPB,PCSQ,ABSPC,SCALEABC
      REAL*8 EA(3),EB(3),EC(3)
      REAL*8 RANDOM,XX,XCHOICE
      REAL*8 COSTHETA,SINTHETA,PHI,R
      REAL*8 X,ELLT
C
C---------------
C
      OK = .TRUE.
C
C We need the appropriate unit vectors for the map. We create a unit
C vector EA(mu) in the direction of PA(mu). We also calculate a
C scale factor SCALEABC.
C
      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
      ENDDO
      IF (PASQ.LT.1.0D-30) THEN
        WRITE(NOUT,*)'PASQ too small in CHOOSE2TO1'
        WRITE(NOUT,*)'PA ',PA
        WRITE(NOUT,*)'ELL',ELL
        OK = .FALSE.
      ENDIF  
      ABSPA = SQRT(PASQ)
      ABSPB = SQRT(PBSQ)
      ABSPC = SQRT(PBSQ)
      DO MU = 1,3
        EA(MU) = PA(MU)/ABSPA
      ENDDO
      SCALEABC = (ABSPA + ABSPB + ABSPC)/3.0D0
C
      CALL AXES(EA,EB,EC)
C
C Step 2: Determine which of three methods to use to determine
C the next point.
C
      XCHOICE = RANDOM(1)
C
      IF (XCHOICE.LT.A2TO1A) THEN
C
C We want a map concentrating points near ell = 0.
C
      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
        ELL(MU) = R * ( COSTHETA*EA(MU) + SINTHETA
     >            * ( COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ) )
      ENDDO

C
      ELSE IF (XCHOICE.LT.2.0D0*A2TO1A) THEN
C
C We want a map concentrating points near ell - pa = 0.
C
      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
        ELL(MU) = R * ( COSTHETA*EA(MU) + SINTHETA
     >            * ( COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ) )
     >            + PA(MU)
      ENDDO
C
      ELSE IF (XCHOICE.LT.(2.0D0*A2TO1A+A2TO1B)) THEN
C
C We want a map concentrating points near ell = 0, BUT with 
C scale SCALEABC.
C
      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
        ELL(MU) = R * ( COSTHETA*EA(MU) + SINTHETA
     >            * ( COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ) )
      ENDDO

C
      ELSE IF (XCHOICE.LT.2.0D0*(A2TO1A+A2TO1B)) THEN
C
C We want a map concentrating points near ell - pa = 0, BUT with 
C scale SCALEABC.
C
      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
        ELL(MU) = R * ( COSTHETA*EA(MU) + SINTHETA
     >            * ( COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ) )
     >            + PA(MU)
      ENDDO
C
      ELSE
C
C We want a map concentrating points rather collinearly with PA(mu).
C
      XX = RANDOM(1)
      X = B2TO1 * (XX - 0.5D0)/XX/(1.0D0 - XX) + 0.5D0
C
      ELLT = C2TO1 * ABSPA * SQRT( 1.0D0/RANDOM(1) - 1.0D0 )
C   
      PHI = 2.0D0 * PI * RANDOM(1)
C
C Step 3: Put this together using our unit vectors.
C
      DO MU = 1,3
        ELL(MU) = X * PA(MU) 
     >              + ELLT * ( COS(PHI) * EB(MU) + SIN(PHI) * EC(MU) )
      ENDDO
C
C End IF (XCHOICE.LT.F) ...
C
      ENDIF
C
      RETURN
      END
C       
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION RHO2TO1(PA,PB,ELL)
C In:
      REAL*8 PA(3),PB(3),ELL(3)
C
C Density in ell(mu) for a self-energy graph that leads to a
C propagator with momemtum Pa(mu) that enters the final state.
C The map concentrats points rather collinearly with Pa(mu).
C
C 18 December 2000
C 18 March 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
C The parameters B2TO1, C2TO1, A2TO1A and A2TO1B need to match 
C between CHOOSE2TO1 and RHO2TO1.
C
      REAL*8 B2TO1,C2TO1,A2TO1A,A2TO1B
      PARAMETER (B2TO1 = 0.4D0)
      PARAMETER (C2TO1 = 0.4D0)
      PARAMETER (A2TO1A = 0.05D0)
      PARAMETER (A2TO1B = 0.25D0)
      REAL*8 PI
      PARAMETER (PI = 3.141592653589793239D0)
C
      INTEGER MU
      REAL*8 PASQ,ABSPA,PBSQ,ABSPB,PCSQ,ABSPC,SCALEABC
      REAL*8 EA(3)
      REAL*8 X,ELLSQ,ABSELL,ELLZ,ELLTSQ,ELLPRIMESQ,ABSELLPRIME
      REAL*8 K0SQ,TEMP,DXDXX,J
      REAL*8 RHO1,RHO2,RHO3,RHO4,RHO5
C
C Step 1:
C We need the appropriate unit vectors for the map. We create a unit
C vector EA(mu) in the direction of PA(mu). We also calculate a
C scale factor SCALEABC.
C
      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
      ENDDO
      IF (PASQ.LT.1.0D-30) THEN
        WRITE(NOUT,*)'PASQ too small in RHO2TO1'
        WRITE(NOUT,*)'PA ',PA
        WRITE(NOUT,*)'ELL',ELL
        STOP
      ENDIF  
      ABSPA = SQRT(PASQ)
      ABSPB = SQRT(PBSQ)
      ABSPC = SQRT(PBSQ)
      DO MU = 1,3
        EA(MU) = PA(MU)/ABSPA
      ENDDO
      SCALEABC = (ABSPA + ABSPB + ABSPC)/3.0D0
C
C We also need some other variables. We define ellprime(mu) to be
C ell(mu) - pa(mu).
C
      ELLSQ = 0.0D0
      ELLZ = 0.0D0
      DO MU = 1,3
        ELLSQ = ELLSQ + ELL(MU)**2
        ELLZ = ELLZ + ELL(MU)*EA(MU)
      ENDDO
      ELLTSQ = ELLSQ - ELLZ**2
      ABSELL = SQRT(ELLSQ)
      ELLPRIMESQ = ELLSQ + PASQ - 2.0D0*ELLZ*ABSPA
      ABSELLPRIME = SQRT(ELLPRIMESQ)
C
C Step 2: Construct each of the three densities.
C
C Density 1, for a concentration of points near ell = 0.
C
      TEMP = 4.0D0*PI*ELLSQ*(ABSELL + ABSPA)**2
      RHO1 = ABSPA/TEMP
C
C Density 2, for a concentration of points near ell = 0.
C
      TEMP = 4.0D0*PI*ELLPRIMESQ*(ABSELLPRIME + ABSPA)**2
      RHO2 = ABSPA/TEMP
C
C Density 3, for a concentration of points near ell = 0, BUT with 
C scale SCALEABC.
C
      TEMP = 4.0D0*PI*ELLSQ*(ABSELL + SCALEABC)**2
      RHO3 = SCALEABC/TEMP
C
C Density 4, for a concentration of points near ell = 0, BUT with 
C scale SCALEABC.
C
      TEMP = 4.0D0*PI*ELLPRIMESQ*(ABSELLPRIME + SCALEABC)**2
      RHO4 = SCALEABC/TEMP
C
C Density 5, for a concentration of points rather collinearly
C with PA(mu).
C
C Construct the momentum fraction X
C
      X = ELLZ/ABSPA
C
C Construct the jacobian and its inverse, the density.
C
      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+ELLTSQ)**2
      RHO5 = 1/J
C
C Assemble our five pieces with the right weights.
C
      RHO2TO1 =  A2TO1A*(RHO1 + RHO2) 
     >         + A2TO1B*(RHO3 + RHO4)
     >         + (1.0D0 - 2.0D0*(A2TO1A+A2TO1B))*RHO5
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                  Subroutines associated with NEWCUT                  2
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE MAKECUTINFO
C
C Input: none
C Output: none
C
C This subroutine creates the information about the various cuts
C of each graph and stores it in the common block CUTINFORMATION.
C Also counts the number of graphs, the number of cuts for each
C graph, and the number of maps for each cut and stores this in the
C common block GRAPHCOUNTS.
C
C In early versions, beowulf called NEWCUT to generate the cut
C information each time a new cut was started, but this happens so
C often that some thirty percent of the computer time was devoted to
C NEWCUT. 
C
C Latest revision: 1 February 2002.
C
C Array sizes. (We check MAXGRAPHS,MAXCUTS,MAXMAP here.):
      INTEGER SIZE,MAXGRAPHS,MAXCUTS,MAXMAPS
      PARAMETER (SIZE = 3)
      PARAMETER (MAXGRAPHS = 12)
      PARAMETER (MAXCUTS = 9)
      PARAMETER (MAXMAPS = 64)
C Input and output units.      
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C Graph size variables.
      INTEGER NPROPS,CUTMAX
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C Information on cut structure:
      INTEGER NCUTINFO(MAXGRAPHS,MAXCUTS)
      INTEGER ISIGNINFO(MAXGRAPHS,MAXCUTS,3*SIZE + 1)
      INTEGER CUTINDEXINFO(MAXGRAPHS,MAXCUTS,SIZE + 1)
      INTEGER CUTSIGNINFO(MAXGRAPHS,MAXCUTS,SIZE + 1)
      LOGICAL LEFTLOOPINFO(MAXGRAPHS,MAXCUTS)
      LOGICAL RIGHTLOOPINFO(MAXGRAPHS,MAXCUTS)
      INTEGER NINLOOPINFO(MAXGRAPHS,MAXCUTS)
      INTEGER LOOPINDEXINFO(MAXGRAPHS,MAXCUTS,SIZE+1)
      INTEGER LOOPSIGNINFO(MAXGRAPHS,MAXCUTS,SIZE+1)
      COMMON /CUTINFORMATION/ NCUTINFO,ISIGNINFO,
     >   CUTINDEXINFO,CUTSIGNINFO,LEFTLOOPINFO,RIGHTLOOPINFO,
     >   NINLOOPINFO,LOOPINDEXINFO,LOOPSIGNINFO
C
      INTEGER NUMBEROFGRAPHS
      INTEGER NUMBEROFCUTS(MAXGRAPHS)
      INTEGER NUMBEROFMAPS(MAXGRAPHS)
      COMMON /GRAPHCOUNTS/ NUMBEROFGRAPHS,NUMBEROFCUTS,NUMBEROFMAPS
C
C NEWGRAPH variables:
      INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3)
      LOGICAL GRAPHFOUND
      INTEGER GRAPHNUMBER
C NEWCUT variables:
      INTEGER CUTINDEX(SIZE+1),CUTSIGN(SIZE+1),NCUT
      INTEGER ISIGN(3*SIZE-1)
      LOGICAL LEFTLOOP,RIGHTLOOP
      INTEGER LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1),NINLOOP
C FINDTYPES variables
      INTEGER NMAPS,QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE)
      CHARACTER*6 MAPTYPES(MAXMAPS)
C
      LOGICAL NEWCUTINIT,CUTFOUND
C
      INTEGER P,I,NP
      INTEGER CUTNUMBER
      INTEGER ORDER
      LOGICAL SAYIT
C
C---------
C
      SAYIT = .FALSE.
      IF (SAYIT) THEN
       WRITE(NOUT,*)' '
       WRITE(NOUT,*)'Report from makecutinfo'
      ENDIF
C
C Initialize graph counting.
C
      GRAPHNUMBER = 0
C
      DO ORDER = 2,1,-1
C
      IF (SAYIT) THEN
         WRITE(NOUT,*)' '
         WRITE(NOUT,*)'Order of graphs ',ORDER
      ENDIF
C
      IF (ORDER.EQ.1) THEN
        NPROPS = NPROPS1
        CUTMAX = CUTMAX1
      ELSE IF (ORDER.EQ.2) THEN
        NPROPS = NPROPS2
        CUTMAX = CUTMAX2
      ELSE
        WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER
      ENDIF
C
      GRAPHFOUND = .TRUE.
C
      DO WHILE (GRAPHFOUND)
      CALL NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND)
      IF (GRAPHFOUND) THEN
      GRAPHNUMBER = GRAPHNUMBER + 1
C
      IF (SAYIT) THEN
       WRITE(NOUT,*)' '
       WRITE(NOUT,*)'Graph number ',GRAPHNUMBER
      ENDIF
C
C Get a new cut.
C
      CUTFOUND = .TRUE.
      NEWCUTINIT = .TRUE.
      CUTNUMBER = 0
      DO WHILE (CUTFOUND)
      CALL NEWCUT(VRTX,ORDER,NEWCUTINIT,NCUT,ISIGN,
     >            CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP,
     >            NINLOOP,LOOPINDEX,LOOPSIGN,CUTFOUND)
      IF (CUTFOUND) THEN
      CUTNUMBER = CUTNUMBER + 1
C
      IF (SAYIT) THEN
       WRITE(NOUT,*)' '
       WRITE(NOUT,*)'Cut number ',CUTNUMBER,' NCUT = ',NCUT
      ENDIF    
C
      NCUTINFO(GRAPHNUMBER,CUTNUMBER) = NCUT
      DO P = 1,NPROPS
         ISIGNINFO(GRAPHNUMBER,CUTNUMBER,P) = ISIGN(P)
         IF (SAYIT) THEN
           WRITE(NOUT,*)'ISIGN(',P,') = ',ISIGN(P)
         ENDIF
      ENDDO
      DO I = 1,CUTMAX
         CUTINDEXINFO(GRAPHNUMBER,CUTNUMBER,I) = CUTINDEX(I)
         CUTSIGNINFO(GRAPHNUMBER,CUTNUMBER,I) = CUTSIGN(I)
         IF (SAYIT) THEN
           WRITE(NOUT,*)'CUTINDEX(',I,') = ',CUTINDEX(I)
           WRITE(NOUT,*)'CUTSIGN(',I,') = ',CUTSIGN(I)
         ENDIF
      ENDDO
      LEFTLOOPINFO(GRAPHNUMBER,CUTNUMBER) = LEFTLOOP
      RIGHTLOOPINFO(GRAPHNUMBER,CUTNUMBER) = RIGHTLOOP
      NINLOOPINFO(GRAPHNUMBER,CUTNUMBER) = NINLOOP
      IF (SAYIT) THEN
        WRITE(NOUT,*)'LEFTLOOP = ',LEFTLOOP
        WRITE(NOUT,*)'RIGHTLOOP = ',RIGHTLOOP
        WRITE(NOUT,*)'NINLOOP = ',NINLOOP
      ENDIF 
      DO NP = 1,CUTMAX
         LOOPINDEXINFO(GRAPHNUMBER,CUTNUMBER,NP) = LOOPINDEX(NP) 
         LOOPSIGNINFO(GRAPHNUMBER,CUTNUMBER,NP) = LOOPSIGN(NP)
         IF (SAYIT) THEN
           WRITE(NOUT,*)'LOOPINDEX(',NP,') = ',LOOPINDEX(NP)
           WRITE(NOUT,*)'LOOPSIGN(',NP,') = ',LOOPSIGN(NP)
         ENDIF 
      ENDDO
C
C Close loop  DO WHILE (CUTFOUND), IF (CUTFOUND) THEN
C
      ENDIF
      ENDDO
C
      IF (CUTNUMBER.GT.MAXCUTS) THEN
         WRITE(NOUT,*)'More cuts than I thought.'
         STOP
      ENDIF
      NUMBEROFCUTS(GRAPHNUMBER) = CUTNUMBER
C
C Calculate number of maps NMAPS, index arrays QS,
C signs QSIGNS, and types MAPTYPES associated with the maps.
C All we really want here is NMAPS, but we get the rest at
C a low price.
C
      CALL FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES)
      NUMBEROFMAPS(GRAPHNUMBER) = NMAPS
      IF (SAYIT) THEN
        WRITE(NOUT,*)' '
        WRITE(NOUT,*)'For graph',GRAPHNUMBER,', NUMBEROFMAPS = ',NMAPS
      ENDIF
      IF (NMAPS.GT.MAXMAPS) THEN
        WRITE(NOUT,*)'Ooops, more maps than we anticipated.'
        STOP
      ENDIF
C
C Close loop  DO WHILE (GRAPHFOUND), IF (GRAPHFOUND) THEN
C
      ENDIF
      ENDDO
C
C
C Close DO ORDER = 2,1,-1
C
      ENDDO
C
      IF (GRAPHNUMBER.GT.MAXGRAPHS) THEN
         WRITE(NOUT,*)'More graphs than I thought.'
         STOP
      ENDIF
      NUMBEROFGRAPHS = GRAPHNUMBER
      IF (SAYIT) THEN
         WRITE(NOUT,*)' '
         WRITE(NOUT,*)'NUMBEROFGRAPHS = ',NUMBEROFGRAPHS
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE GETCUTINFO(GRAPHNUMBER,CUTNUMBER,ORDER,NCUT,ISIGN,
     >            CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP,
     >            NINLOOP,LOOPINDEX,LOOPSIGN)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C Input:
      INTEGER GRAPHNUMBER,CUTNUMBER,ORDER
C Output:
      INTEGER NCUT,ISIGN(3*SIZE-1)
      INTEGER CUTINDEX(SIZE+1),CUTSIGN(SIZE+1)
      LOGICAL LEFTLOOP,RIGHTLOOP
      INTEGER NINLOOP,LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1)
C
C This subroutine reads from the information recorded in the common
C CUTINFORMATION and returns the information relevant for
C the current graph,specified by GRAPHNUMBER and the current cut,
C specified by CUTNUMBER. See the subroutine NEWCUT for definition
C of the variables returned.
C
C Latest revision: 5 January 1999.
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NPROPS,CUTMAX
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
C Information on cut structure:
      INTEGER MAXGRAPHS,MAXCUTS
      PARAMETER (MAXGRAPHS = 12)
      PARAMETER (MAXCUTS = 9)
      INTEGER NCUTINFO(MAXGRAPHS,MAXCUTS)
      INTEGER ISIGNINFO(MAXGRAPHS,MAXCUTS,3*SIZE + 1)
      INTEGER CUTINDEXINFO(MAXGRAPHS,MAXCUTS,SIZE + 1)
      INTEGER CUTSIGNINFO(MAXGRAPHS,MAXCUTS,SIZE + 1)
      LOGICAL LEFTLOOPINFO(MAXGRAPHS,MAXCUTS)
      LOGICAL RIGHTLOOPINFO(MAXGRAPHS,MAXCUTS)
      INTEGER NINLOOPINFO(MAXGRAPHS,MAXCUTS)
      INTEGER LOOPINDEXINFO(MAXGRAPHS,MAXCUTS,SIZE+1)
      INTEGER LOOPSIGNINFO(MAXGRAPHS,MAXCUTS,SIZE+1)
      COMMON /CUTINFORMATION/ NCUTINFO,ISIGNINFO,
     >   CUTINDEXINFO,CUTSIGNINFO,LEFTLOOPINFO,RIGHTLOOPINFO,
     >   NINLOOPINFO,LOOPINDEXINFO,LOOPSIGNINFO
C
      INTEGER P,I,NP
C
C--------
C
      IF (ORDER.EQ.1) THEN
        NPROPS = NPROPS1
        CUTMAX = CUTMAX1
      ELSE IF (ORDER.EQ.2) THEN
        NPROPS = NPROPS2
        CUTMAX = CUTMAX2
      ELSE
        WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER
      ENDIF
C
      NCUT = NCUTINFO(GRAPHNUMBER,CUTNUMBER)
      DO P = 1,NPROPS
         ISIGN(P) = ISIGNINFO(GRAPHNUMBER,CUTNUMBER,P)
      ENDDO
      DO I = 1,CUTMAX
         CUTINDEX(I) = CUTINDEXINFO(GRAPHNUMBER,CUTNUMBER,I)
         CUTSIGN(I)  =  CUTSIGNINFO(GRAPHNUMBER,CUTNUMBER,I)
      ENDDO
      LEFTLOOP = LEFTLOOPINFO(GRAPHNUMBER,CUTNUMBER)
      RIGHTLOOP = RIGHTLOOPINFO(GRAPHNUMBER,CUTNUMBER)
      NINLOOP = NINLOOPINFO(GRAPHNUMBER,CUTNUMBER)
      DO NP = 1,CUTMAX
         LOOPINDEX(NP) = LOOPINDEXINFO(GRAPHNUMBER,CUTNUMBER,NP)
         LOOPSIGN(NP)  = LOOPSIGNINFO(GRAPHNUMBER,CUTNUMBER,NP)
      ENDDO
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE  NEWCUT(XVRTX,ORDER,NEWCUTINIT,XNCUT,XISIGN,
     >            XCUTINDEX,XCUTSIGN,XLEFTLOOP,XRIGHTLOOP,
     >            XNINLOOP,XLOOPINDEX,XLOOPSIGN,CUTFOUND)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C Input:
      INTEGER XVRTX(0:3*SIZE-1,2)
      INTEGER ORDER
C Input and output:
      LOGICAL NEWCUTINIT
C Output:
      INTEGER XCUTINDEX(SIZE+1),XCUTSIGN(SIZE+1),XNCUT
      INTEGER XISIGN(3*SIZE-1)
      LOGICAL XLEFTLOOP,XRIGHTLOOP
      INTEGER XLOOPINDEX(SIZE+1),XLOOPSIGN(SIZE+1),XNINLOOP
      LOGICAL CUTFOUND
C
C This subroutine generates valid cuts for a given graph. 
C In its present form, it generates cuts with CUTMAX lines cut
C and with (CUTMAX - 1) lines cut. In the case that (CUTMAX - 1)  
C lines are cut, it also finds the (single) virtual loop.
C
C The action of the subroutine depends on its state when called.  It
C has two possible states. If NEWCUTINIT is true, NEWCUT is ready 
C start generating cuts for a new graph. This is the state when the
C subroutine is called for the first time. If NEWCUTINIT is false, the
C subroutine is ready to generate a new cut for the current graph.
C When NEWCUT is called with NEWCUTINIT = False but it cannot find 
C a new cut, it exits with NEWCUTINIT = True and the output variable
C CUTFOUND = False.  This tells the mainprogram to produce a new graph.
C
C Notation: [X variables are interchanged with the external world.]
C VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of
C             of propagator P. Specifies the supergraph.
C NCUT = Number of cut propagators.
C ISIGN(P) = +1 if propagator P is left of cut, -1 if right, 0 if cut.
C CUTINDEX(I) = Index P of cut propagator I, I = 1,...,NCUT.
C CUTSIGN(I) = Sign of cut propagator I (+1 if from Left to Right).
C    If NCUT = CUTMAX - 1 then there is a virtual loop and
C    we define CUTINDEX(CUTMAX) = 0.
C    But in subroutine LOOPCUT we will let I = CUTMAX designate
C    the loopcut:
C      CUTINDEX(CUTMAX) = LOOPINDEX(JCUT)
C      CUTSIGN(CUTMAX) = LOOPSIGN(CUTMAX)
C LEFTLOOP = True iff there is a virtual loop to the left of the cut.
C RIGHTLOOP = True iff there is a virtual loop to the right of the cut.
C NINLOOP = Number of propagators in loop.
C LOOPINDEX(NP) = Index P of NPth propagator around the loop.
C    The loop begins (with NP = 1) at the starting vertex that is
C    defined as the current vertex if the the loop includes the
C    current vertex or the vertex in the loop that is attached to the 
C    uncut propagator of the lowest index P.
C LOOPSIGN(NP) = 1 if propagator direction is same as loop direction.
C               -1 if  direction is opposite to loop direction.
C CUTFOUND = False if we can't find a next cut.
C
C CUT(P) = True iff propagator P is cut.
C VALIDCUT = True iff the cut is OK.
C LEFT(V) = True iff vertex V is to the left of the cut.
C           Vertex 1, the left hand current, is always in LEFT.
C NLEFT = Number of vertices to the left of the cut.
C RIGHT(V) = True iff vertex V is to the right of the cut.
C            Vertex 2, the right hand current, is always in RIGHT.
C NRIGHT = Number of vertices to the right of the cut.
C
C LOOPVERTEX(V) = True if vertex V is in the loop.
C LOOPPROP(P) = True if propagator P is in the loop.
C NCONNECTED = Number of propagators connected to a vertex.
C STARTVERTEX = Starting vertex in a loop.
C HOTVERTEX =  Vertex to which next loop propagator should be added.
C
C Logical state variables:
C   NEWCUTINIT = True if NEWCUT called for first time with a new graph,
C           else False.
C
C                     ----- Outline -----
C
C Output variables -> default values.
C IF (NEWCUTINIT) THEN
C    Initialize, including NEXTCUT = True.
C ENDIF
C START = .FALSE.
C VALIDCUT = .FALSE.
C DO WHILE (.NOT.VALIDCUT)
C     Generate next cut, specified by CUTINDEX(I).
C     Here CUTINDEX(CUTMAX) = 0 indicates a virtual loop.
C     In this case, set NCUT = CUTMAX - 1.  Else NCUT = CUTMAX.
C     Check cut, setting VALIDCUT to True if cut is OK.
C ENDDO
C IF (NCUT.EQ.CUTMAX) THEN
C     Set LEFTLOOP and RIGHTLOOP to False
C     Normal Return.
C ELSE set LEFTLOOP or RIGHTLOOP to True as appropriate.
C ENDIF
C     Find the loop, determining LOOPINDEX(NP) and LOOPSIGN(NP),
C       where NP = 1 designates the propagator starting at the
C       starting vertex defined above.
C     NINLOOP = number of propagators in loop.
C     Normal Return.
C
C Normal Return:
C  Set output variables to values of internal variables.
C
C 2 November 1992
C 26 January 1992
C 20 June 1993
C 21 August 1993
C 26 June 1994
C 11 July 1994
C 20 March 1996
C  1 February 2001
C
C                     -------------------
C
C-----------------------------------------------------------------------
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      INTEGER NPROPS,NVERTS,CUTMAX
      INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1
      INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
      COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1,
     >               NLOOPS2,NPROPS2,NVERTS2,CUTMAX2
C
      INTEGER V,P
      INTEGER I,II,IP,V1,V2
      LOGICAL LEFT(2*SIZE),RIGHT(2*SIZE)
      LOGICAL CHANGE
      LOGICAL VALIDCUT
      LOGICAL LOOPVERTEX(2*SIZE),LOOPPROP(3*SIZE-1)
      INTEGER NLEFT,NRIGHT,NCONNECTED
      LOGICAL CUT(3*SIZE-1),LEFTLOOP,RIGHTLOOP
      INTEGER CUTSIGN(SIZE+1),NCUT
      INTEGER LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1)
      INTEGER NINLOOP
      LOGICAL LOOKMORE
      INTEGER STARTVERTEX,HOTVERTEX,PREVIOUSPROP
C
C Internal state variables to be saved
C
      INTEGER VRTX(0:3*SIZE-1,2)
      SAVE VRTX
      INTEGER CUTINDEX(SIZE+1)
      SAVE CUTINDEX
C
      IF (ORDER.EQ.1) THEN
        NPROPS = NPROPS1
        NVERTS = NVERTS1
        CUTMAX = CUTMAX1
      ELSE IF (ORDER.EQ.2) THEN
        NPROPS = NPROPS2
        NVERTS = NVERTS2
        CUTMAX = CUTMAX2
      ELSE
        WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER
      ENDIF
C
C Default values for the output variables
C
      XNCUT = 0
      XLEFTLOOP = .FALSE.
      XRIGHTLOOP = .FALSE.
      XNINLOOP = 0
      DO I = 1,CUTMAX
        XCUTINDEX(I) = 0
        XCUTSIGN(I) = 0
        XLOOPINDEX(I) = 0
        XLOOPSIGN(I) = 0
      ENDDO
      CUTFOUND = .FALSE.
C
C If we should start generating cuts anew, we initialize.  Else
C we do some checking (just in case). The initialization depends
C on ORDER.
C
      IF (NEWCUTINIT) THEN
        IF (ORDER.EQ.1) THEN
          CUTINDEX(1) = CUTMAX - 1
          DO I = 2, CUTMAX
           CUTINDEX(I) = CUTMAX + 1 - I
          ENDDO
        ELSE
          CUTINDEX(1) = CUTMAX - 2
          DO I = 2, CUTMAX
           CUTINDEX(I) = CUTMAX - I
          ENDDO
        ENDIF
        DO P = 0,NPROPS
          DO I = 1,2
            VRTX(P,I) = XVRTX(P,I)
          ENDDO
        ENDDO
      ELSE
        DO P = 0,NPROPS
          DO I = 1,2
           IF (.NOT.(VRTX(P,I).EQ.XVRTX(P,I))) THEN
             WRITE(NOUT,*)'SNAFU in NEWCUT. VRTX changed.'
             STOP
           ENDIF
          ENDDO
        ENDDO
      ENDIF
C
      NEWCUTINIT = .FALSE.
C
C Initialization complete.
C
C Loop to find new valid cut.
C
      VALIDCUT = .FALSE.
      DO WHILE (.NOT.VALIDCUT)
C
C Generate a new choice of the CUTINDEX(I).
C We choose CUTINDEX(1),CUTINDEX(2),...,CUTINDEX(CUTMAX)
C with 0 .LE. CUTINDEX(I) .LE. NPROPS and CUTINDEX(I) > CUTINDEX(I+1).
C CUTINDEX(CUTMAX) = 0 indicates that there is a virtual loop.
C Example, for NLOOPS = 3: CUTINDEX(I) is initialized to (2,2,1,0).
C From this, we generate first CUTINDEX(I) = (3,2,1,0). On successive
C runs through this code, we generate (4,2,1,0), (5,2,1,0), (6,2,1,0),
C (7,2,1,0), (8,2,1,0), (4,3,1,0), (5,3,1,0),..., (8,3,1,0), (5,4,1,0),
C (6,4,1,0),..., (8,7,6,0), (4,3,2,1), (5,3,2,1),..., (8,7,6,5).
C In case the choice previously analyzed was the last one, then
C there are no more cuts, we set CUTFOUND to False to abort further
C analysis in the main program, and set NEWCUTINIT to True so that we 
C start over again next time this subroutine is called, and then return.
C
C In the case of ORDER = 1, we want only tree graphs. Therefore we
C change the initialization so that, for NLOOPS = 3: CUTINDEX(I) is
C initialized to (2,2,1). From this, we generate first CUTINDEX(I) = 
C (3,2,1).
C
      I = 1
77    IF( CUTINDEX(I).LT.NPROPS + 1 - I) THEN
        CUTINDEX(I) = CUTINDEX(I) + 1
        DO II = 1,I - 1
         CUTINDEX(II) = CUTINDEX(I) + I - II
        ENDDO
      ELSE
        I = I + 1
        IF (I.LE.CUTMAX) THEN
          GO TO 77
        ELSE
          CUTFOUND = .FALSE.
          NEWCUTINIT = .TRUE.
          RETURN  
        ENDIF
      ENDIF
C
C Now that we have the CUTINDEX(I), set CUT(CUTINDEX(I)) = True.
C CUTINDEX(CUTMAX) = 0 indicates that CUTMAX - 1 propagators were cut.
C
      DO P= 1,NPROPS
        CUT(P) = .FALSE.
      ENDDO
      DO I = 1, CUTMAX - 1
        CUT(CUTINDEX(I)) = .TRUE.
      ENDDO
      IF (CUTINDEX(CUTMAX).EQ.0) THEN
        NCUT = CUTMAX - 1
      ELSE
        NCUT = CUTMAX
        CUT(CUTINDEX(CUTMAX)) = .TRUE.
      ENDIF
C
C Construct Left and Right sets.  Any vertex that is connected to a Left
C vertex by an uncut propagator is in Left.  Similarly for Right.
C Start with vertex 1 in Left and vertex 2 in Right.
C
      DO V = 1,NVERTS
        LEFT(V) = .FALSE.
        RIGHT(V) = .FALSE.
      ENDDO
      LEFT(1) = .TRUE.
      RIGHT(2) = .TRUE.
      NLEFT = 1
      NRIGHT = 1
C
C Now add vertices that are connected to the Left vertices.
C
      CHANGE = .TRUE.
      DO WHILE (CHANGE)
      CHANGE = .FALSE.
       DO P = 1,NPROPS
       IF(.NOT.CUT(P)) THEN
C
        IF(LEFT(VRTX(P,1)).AND.(.NOT.LEFT(VRTX(P,2)))) THEN
           LEFT(VRTX(P,2)) = .TRUE.
           CHANGE = .TRUE.
           NLEFT = NLEFT + 1
        ELSE IF(LEFT(VRTX(P,2)).AND.(.NOT.LEFT(VRTX(P,1)))) THEN
           LEFT(VRTX(P,1)) = .TRUE.
           CHANGE = .TRUE.
           NLEFT = NLEFT + 1
        ENDIF
C
       ENDIF
       ENDDO
      ENDDO
C
C Now add vertices that are connected to the Right vertices.
C
      CHANGE = .TRUE.
      DO WHILE (CHANGE)
      CHANGE = .FALSE.
       DO P = 1,NPROPS
       IF(.NOT.CUT(P)) THEN
C
        IF(RIGHT(VRTX(P,1)).AND.(.NOT.RIGHT(VRTX(P,2)))) THEN
           RIGHT(VRTX(P,2)) = .TRUE.
           CHANGE = .TRUE.
           NRIGHT = NRIGHT + 1
        ELSE IF(RIGHT(VRTX(P,2)).AND.(.NOT.RIGHT(VRTX(P,1)))) THEN
           RIGHT(VRTX(P,1)) = .TRUE.
           CHANGE = .TRUE.
           NRIGHT = NRIGHT + 1
        ENDIF
C
       ENDIF
       ENDDO
      ENDDO
C
C Check for validity of the cut. Cut is not valid unless each vertex is 
C in Left or Right but not both.
C
      VALIDCUT = .TRUE.
      DO V = 1,NVERTS
        IF (.NOT.(LEFT(V).XOR.RIGHT(V))) THEN
            VALIDCUT = .FALSE.
        ENDIF
      ENDDO
C
C Check that each cut propagator divides the Left set from the Right.
C
      DO I = 1,NCUT
        IF(LEFT(VRTX(CUTINDEX(I),1)).AND.
     >     RIGHT(VRTX(CUTINDEX(I),2)) ) THEN
           CUTSIGN(I) = 1
        ELSE IF(LEFT(VRTX(CUTINDEX(I),2)).AND.
     >          RIGHT(VRTX(CUTINDEX(I),1)) ) THEN
           CUTSIGN(I) = -1
        ELSE
           VALIDCUT = .FALSE.
        ENDIF
      ENDDO
C
C End of loop to generate a new cut
C
      ENDDO
C
C Are there virtual loops?  If not, just return (GOTO 1),
C
      IF (NCUT.EQ.CUTMAX) THEN
         LEFTLOOP = .FALSE.
         RIGHTLOOP = .FALSE.
         NINLOOP = 0
         DO I = 1,CUTMAX
          LOOPINDEX(I) = 0
          LOOPSIGN(I) = 0
         ENDDO
         GOTO 1
      ELSE IF (NCUT.EQ.(CUTMAX - 1)) THEN
         IF ((NLEFT - NRIGHT).EQ.2) THEN
           LEFTLOOP = .TRUE.
           RIGHTLOOP = .FALSE.
         ELSE IF ((NRIGHT - NLEFT).EQ.2) THEN
           RIGHTLOOP = .TRUE.
           LEFTLOOP = .FALSE.
         ELSE
           WRITE(NOUT,*)'NRIGHT,NLEFT out of bounds'
           STOP
         ENDIF
      ELSE
         WRITE(NOUT,*)'NCUT out of bounds'
         STOP
      ENDIF
C
C Find the virtual loops.
C
C First, initialize all vertices to the left of the cut to be candidate
C vertices for the left-loop. Alternatively, if we have a right-loop,
C initialize all vertices to the right of the cut to be candidate
C vertices for the right-loop
C
      IF (LEFTLOOP) THEN
         DO V = 1,NVERTS
           IF (LEFT(V)) THEN
             LOOPVERTEX(V) = .TRUE.
           ELSE
             LOOPVERTEX(V) = .FALSE.
           ENDIF
         ENDDO
      ELSE IF (RIGHTLOOP) THEN
         DO V = 1,NVERTS
           IF (RIGHT(V)) THEN
             LOOPVERTEX(V) = .TRUE.
           ELSE
             LOOPVERTEX(V) = .FALSE.
           ENDIF
         ENDDO
      ENDIF
C
C Now we will iteratively remove candidate vertices for the loop if they
C are not properly connected.
C
      CHANGE = .TRUE.
      DO WHILE (CHANGE)
      CHANGE = .FALSE.
C
C A loop propagator is one that joins two loop vertices.
C
      DO P = 1,NPROPS
        IF(LOOPVERTEX(VRTX(P,1)).AND.LOOPVERTEX(VRTX(P,2)))THEN
          LOOPPROP(P) = .TRUE.
        ELSE
          LOOPPROP(P) = .FALSE.
        ENDIF
      ENDDO
C
C Now a loop vertex is one that connects at least two loop propagators.
C If a vertex fails this test, remove it from the loop list.
C
      DO V = 1,NVERTS
        IF (LOOPVERTEX(V)) THEN
C
           NCONNECTED = 0
           DO P = 1,NPROPS
              IF( LOOPPROP(P).AND.
     >          ((VRTX(P,1).EQ.V).OR.(VRTX(P,2).EQ.V)) ) THEN
                NCONNECTED = NCONNECTED + 1
              ENDIF
           ENDDO
C
           IF(NCONNECTED.LT.2) THEN
             LOOPVERTEX(V) = .FALSE.
             CHANGE = .TRUE.
           ENDIF
        ENDIF
      ENDDO
C
C Close loop over removal of loop vertices
C
      ENDDO
C
C We now know which propagators are in the loop. Next we need to
C find the starting vertex in the loop. The STARTVERTEX is either
C vertex 1 or vertex 2 (connected to the external lines) or it is
C a LOOPVERTEX connected connected to a propagator that is not in
C the loop and not cut. We take the first one that we find.
C
      IF (LOOPVERTEX(1)) THEN
         STARTVERTEX = 1
      ELSE IF (LOOPVERTEX(2)) THEN
         STARTVERTEX = 2
      ELSE
         P = 1
         LOOKMORE = .TRUE.
         DO WHILE (LOOKMORE)
          IF (P.GT.NPROPS) THEN
            WRITE(NOUT,*) 'SNAFU 1 in NEWCUT, P too big'
            STOP
          ENDIF
          IF ( (.NOT.LOOPPROP(P)).AND.(.NOT.CUT(P)) ) THEN
            IF ( LOOPVERTEX(VRTX(P,1)) ) THEN
              STARTVERTEX = VRTX(P,1)
              LOOKMORE = .FALSE.
            ELSE IF ( LOOPVERTEX(VRTX(P,2)) ) THEN
              STARTVERTEX = VRTX(P,2)
              LOOKMORE = .FALSE.
            ENDIF
          ENDIF
          P = P + 1
         ENDDO
      ENDIF
C
C Now add first propagator in the loop.
C
      P = 1
      LOOKMORE = .TRUE.
      DO WHILE (LOOKMORE)
        IF (P.GT.NPROPS) THEN
           WRITE(NOUT,*) 'SNAFU 2 in NEWCUT, P too big'
           STOP
        ENDIF
        IF(LOOPPROP(P)) THEN
          IF((VRTX(P,1).EQ.STARTVERTEX)) THEN
            IP = 1
            LOOPINDEX(IP) = P
            PREVIOUSPROP = P
            LOOPSIGN(IP) = 1
            HOTVERTEX = VRTX(P,2)
            LOOKMORE = .FALSE.
          ELSE IF((VRTX(P,2).EQ.STARTVERTEX)) THEN
            IP = 1
            LOOPINDEX(IP) = P
            PREVIOUSPROP = P
            LOOPSIGN(IP) = -1
            HOTVERTEX = VRTX(P,1)
            LOOKMORE = .FALSE.
          ENDIF
        ENDIF
        P = P+1
      ENDDO
C
C Now add propagators around the loop.
C
      DO WHILE (HOTVERTEX.NE.STARTVERTEX)
        P = 1
        LOOKMORE = .TRUE.
        DO WHILE (LOOKMORE)
          IF (P.GT.NPROPS) THEN
             WRITE(NOUT,*) 'SNAFU 3 in NEWCUT, P too big'
             STOP
          ENDIF
          IF(LOOPPROP(P).AND.(.NOT.(PREVIOUSPROP.EQ.P))) THEN
            IF((VRTX(P,1).EQ.HOTVERTEX)) THEN
              IP = IP + 1
              LOOPINDEX(IP) = P
              PREVIOUSPROP = P
              LOOPSIGN(IP) = 1
              HOTVERTEX = VRTX(P,2)
              LOOKMORE = .FALSE.
            ELSE IF((VRTX(P,2).EQ.HOTVERTEX)) THEN
              IP = IP + 1
              LOOPINDEX(IP) = P
              PREVIOUSPROP = P
              LOOPSIGN(IP) = -1
              HOTVERTEX = VRTX(P,1)
              LOOKMORE = .FALSE.
            ENDIF
          ENDIF
          P = P + 1
        ENDDO
      ENDDO
      NINLOOP = IP
C
C Come to here for a normal return.
C
1     CUTFOUND = .TRUE.
      XLEFTLOOP = LEFTLOOP
      XRIGHTLOOP = RIGHTLOOP
      XNINLOOP = NINLOOP
      XNCUT = NCUT
C
      DO I = 1,CUTMAX
        XCUTINDEX(I) = CUTINDEX(I)
        XCUTSIGN(I)  = CUTSIGN(I)
      ENDDO
C
      DO I = 1,NINLOOP
        XLOOPINDEX(I) = LOOPINDEX(I)
        XLOOPSIGN(I)  = LOOPSIGN(I)
      ENDDO
C
      DO P = 1,NPROPS
      V1 = VRTX(P,1)
      V2 = VRTX(P,2)
        IF (LEFT(V1).AND.LEFT(V2)) THEN
          XISIGN(P) = 1
        ELSE IF (RIGHT(V1).AND.RIGHT(V2)) THEN
          XISIGN(P) = -1
        ELSE
          XISIGN(P) = 0
        ENDIF  
      ENDDO
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C               End of subroutines associated with NEWCUT              2
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE DEFORM(VRTX,LOOPINDEX,RTS,LEFTLOOP,RIGHTLOOP,
     >                  NINLOOP,KINLOOP,NEWKINLOOP,JACDEFORM)
C
      INTEGER SIZE
      PARAMETER (SIZE = 3)
C In:
      INTEGER VRTX(0:3*SIZE-1,2)
      INTEGER LOOPINDEX(SIZE+1)
      REAL*8 RTS
      LOGICAL LEFTLOOP,RIGHTLOOP
      INTEGER NINLOOP
      REAL*8 KINLOOP(SIZE+1,0:3)
C Out:
      COMPLEX*16 NEWKINLOOP(0:3)
      COMPLEX*16 JACDEFORM
C
C Contour deformation. Note that this simple algorithm should
C work for NINLOOP = 3 and for NINLOOP = 4 if the sum of the
C three 3-momenta exiting the loop vanishes.
C
C In variables:
C VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of
C              of propagator P. Specifies the supergraph.
C LOOPINDEX(NP) = Index P of NPth propagator around the loop.
C RTS = energy of final state.
C LEFTLOOP = T if there is a loop to the left of the cut.
C RIGHTLOOP = T if there is a loop to the right of the cut.
C NINLOOP = number of propagators in the loop.
C KINLOOP(J,MU) = momentum of Jth propagator in loop (real part)
C Out variables:
C NEWKINLOOP(MU) = added part of loop momentum.
C                  (purely imaginary for MU = 1,2,3)
C JACDEFORM = jacobian associated with contour deformation.
C
C Our notation is
C  vec Q(j) = vec L(j) - vec L(j+1) j = 1,...,Ninloop - 1
C      L(j) = |L(j)|                j = 1,...,Ninloop - 1
C      Q(j) = |Q(j)|                j = 1,...,Ninloop - 1
C
C  27 October 1992 first DEFORM
C  1 February 1998 latest version
C  23 February 1998 minor revision to rename deform variables
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 DEFORMALPHA,DEFORMBETA,DEFORMGAMMA
      COMMON /DEFORMSCALES/DEFORMALPHA,DEFORMBETA,DEFORMGAMMA
C
      REAL*8 S
      INTEGER SIGN
      REAL*8 L(SIZE+1,3)
C
      REAL*8 Q(SIZE,3),QSQ(SIZE),QABS(SIZE)
      REAL*8 LHAT(SIZE,3),LSQ(SIZE),LABS(SIZE)
      REAL*8 W(SIZE,3),WSQ(SIZE),WABS(SIZE)
      REAL*8 ACRIT2,ACRIT3,A2,A3
      REAL*8 DELTA
      REAL*8 M1(3,3),M2(3,3),M3(3,3)
      REAL*8 D1,D2,D3,DSQ,GRADDSQ(3)
      REAL*8 FRACTION,GRADF(3)
      REAL*8 G2,G3,DG2DA2,DG3DA3
      REAL*8 C,DLNCDDSQ
      REAL*8 TERMC,TERMF,TERMG2,TERMG3,TERMW2,TERMW3,TERMS
      COMPLEX*16 A(3,3)
C
      LOGICAL CONNECTSTOCURRENT
      REAL*8 TEMP,TEMP1,TEMP2,TEMP3
      INTEGER J,MU,NU
C
C Calculate s.
C
      S = RTS**2
C
C Initialize with default value.
C
      DO MU = 0,3
        NEWKINLOOP(MU) = (0.0D0,0.0D0)
      ENDDO
C
      JACDEFORM = (1.0D0,0.0D0)
C
C Check to see if we should actually do anything
C
      IF (NINLOOP.LT.2) THEN
        RETURN
      ENDIF
C
C Set
C SIGN = +1 and L(J,MU) = KINLOOP(J,MU) for a left loop,
C SIGN = -1 and L(J,MU) = KINLOOP(NINLOOP-J+1,MU) for a right loop.
C
      IF (LEFTLOOP) THEN
        SIGN = + 1
        DO J = 1,NINLOOP
        DO MU = 1,3
          L(J,MU) = KINLOOP(J,MU)
        ENDDO
        ENDDO
      ELSE IF (RIGHTLOOP) THEN
        SIGN = - 1
        DO J = 1,NINLOOP
        DO MU = 1,3
          L(J,MU) = KINLOOP(NINLOOP-J+1,MU)
        ENDDO
        ENDDO
      ELSE
        WRITE(NOUT,*) 'Snafu in DEFORM'
        STOP
      ENDIF
C
C Two particles in the loop.
C
      IF (NINLOOP.EQ.2) THEN
C
C Calculate Q(3,mu), |L(j)|^2, |Q(3)|^2, |L(j)|, |Q(3)|, hat L(j,mu).
C
      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
      ENDDO
      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
        ENDDO
        LABS(J) = SQRT(LSQ(J))
        DO MU = 1,3
          LHAT(J,MU) = L(J,MU)/LABS(J)
        ENDDO
      ENDDO
C
C Calculate the vector W(3,mu), along with the corresponding
C normalization factor.
C
      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
      ENDDO
      WABS(3) = SQRT(WSQ(3))
C
C The size of the critical ellipse.
C
      ACRIT3 = RTS - 2.0D0*QABS(3)
C
C The size of the ellipse at point L.
C
      A3 = LABS(1) + LABS(2) - QABS(3)
C
C Calculate the matrix d W(3,mu)/ d L(mu) = M3(mu,nu).
C
      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
      ENDDO
      ENDDO
C
C The "distance" to the collinear line.
C
      D3 = LABS(1)*LABS(2)*WABS(3)/QABS(3)
C
C The square of the distance its gradient.
C
      DSQ = D3**2
      DO NU = 1,3
        TEMP = 0.0D0
        DO MU = 1,3
          TEMP = TEMP + W(3,MU)*M3(MU,NU)
        ENDDO
        TEMP = TEMP/WSQ(3)
        TEMP = TEMP + L(1,NU)/LSQ(1) + L(2,NU)/LSQ(2)
        GRADDSQ(NU) = 2.0D0*DSQ*TEMP
      ENDDO
C
C The function G3 and its derivative.
C
      G3 = 1.0D0/(ACRIT3 + DEFORMGAMMA*A3)
      DG3DA3 = - DEFORMGAMMA/(ACRIT3 + DEFORMGAMMA*A3)**2
C
C Calculate the function C(DSQ) and its derivative. Note that we change
C the sign of C in the case of a loop to the right of the cut.
C
C We effectively make DEFORMALPHA smaller by a factor 10 for the two
C point function so as to avoid crossing branch cut of SQRT
C
      C = SIGN*DEFORMALPHA*DSQ /(1.0D0 + DEFORMBETA*DSQ/QSQ(3))
      C = C * ACRIT3/RTS
      DLNCDDSQ = 1.0D0/DSQ/(1.0D0 + DEFORMBETA*DSQ/QSQ(3))
C
C Calculate the imaginary part of the loop momentum L(mu).
C
      DO MU = 1,3
        NEWKINLOOP(MU) = (0.0D0,-1.0D0) * C * G3 * W(3,MU)
      ENDDO 
C
C Calculate the jacobian.
C First, we need the comlex matrix A(mu,nu), the derivative
C of ComplexL(mu) with respecdt to L(nu).
C
      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
      ENDDO
      ENDDO
C
C Finally, the jacobian is the determinant of A
C
      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) ) 
C
C End of Ninloop = 2 calculation
C
C Three particles in the loop.
C
      ELSE IF (NINLOOP.EQ.3) THEN
C
C First we need to determine if our loop connects to the current vertex.
C
        IF (LEFTLOOP) THEN
          IF ((VRTX(LOOPINDEX(1),1).EQ.1)) THEN
            CONNECTSTOCURRENT = .TRUE.
          ELSE
            CONNECTSTOCURRENT = .FALSE.
          ENDIF
        ELSE
          IF ((VRTX(LOOPINDEX(1),1).EQ.2)) THEN
            CONNECTSTOCURRENT = .TRUE.
          ELSE
            CONNECTSTOCURRENT = .FALSE.
          ENDIF
        ENDIF
      IF (CONNECTSTOCURRENT) THEN
C
C Calculation for a three particle loop that connects to the current.
C
C Calculate Q(3,mu), |L(j)|^2, |Q(3)|^2, |L(j)|, |Q(3)|, hat L(j,mu).
C
      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
      ENDDO
      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
        ENDDO
        LABS(J) = SQRT(LSQ(J))
        DO MU = 1,3
          LHAT(J,MU) = L(J,MU)/LABS(J)
        ENDDO
      ENDDO
C
C Calculate the vector W(3,mu), along with the corresponding
C normalization factor.
C
      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
      ENDDO
      WABS(3) = SQRT(WSQ(3))
C
C The size of the critical ellipse.
C
      ACRIT3 = RTS - 2.0D0*QABS(3)
C
C The size of the ellipse at point L.
C
      A3 = LABS(1) + LABS(2) - QABS(3)
C
C Calculate the matrix d W(3,mu)/ d L(mu) = M3(mu,nu).
C
      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
      ENDDO
      ENDDO
C
C The "distance" to the collinear line.
C
      D3 = LABS(1)*LABS(2)*WABS(3)/QABS(3)
C
C The square of the distance its gradient.
C
      DSQ = D3**2
      DO NU = 1,3
        TEMP = 0.0D0
        DO MU = 1,3
          TEMP = TEMP + W(3,MU)*M3(MU,NU)
        ENDDO
        TEMP = TEMP/WSQ(3)
        TEMP = TEMP + L(1,NU)/LSQ(1) + L(2,NU)/LSQ(2)
        GRADDSQ(NU) = 2.0D0*DSQ*TEMP
      ENDDO
C
C The function G3 and its derivative.
C
      G3 = 1.0D0/(ACRIT3 + DEFORMGAMMA*A3)
      DG3DA3 = - DEFORMGAMMA/(ACRIT3 + DEFORMGAMMA*A3)**2
C
C Calculate the function C(DSQ) and its derivative. Note that we change
C the sign of C in the case of a loop to the right of the cut.
C
      C = SIGN*DEFORMALPHA*DSQ /(1.0D0 + DEFORMBETA*DSQ/QSQ(3))
      DLNCDDSQ = 1.0D0/DSQ/(1.0D0 + DEFORMBETA*DSQ/QSQ(3))
C
C Calculate the imaginary part of the loop momentum L(mu).
C
      DO MU = 1,3
        NEWKINLOOP(MU) = (0.0D0,-1.0D0) * C * G3 * W(3,MU)
      ENDDO 
C
C Calculate the jacobian.
C First, we need the comlex matrix A(mu,nu), the derivative
C of ComplexL(mu) with respecdt to L(nu).
C
      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
      ENDDO
      ENDDO
C
C Finally, the jacobian is the determinant of A
C
      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) ) 
C
C End of calculation for Ninloop = 3 for a loop connecting to the
C current ( IF(CONNECTSTOCURRENT) ).
C
      ELSE
C
C Calculation for a three particle loop that does not connect
C to the current.
C
C Calculate Q(j,mu), |L(j)|^2, |Q(j)|^2, |L(j)|, |Q(j)|, hat L(j,mu).
C
      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)
      ENDDO
      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
        ENDDO
        QABS(J) = SQRT(QSQ(J))
        LABS(J) = SQRT(LSQ(J))
        DO MU = 1,3
          LHAT(J,MU) = L(J,MU)/LABS(J)
        ENDDO
      ENDDO
C
C The vectors W(j,mu) and their squares and their absolute values. 
C
      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)
      ENDDO
      DO J = 1,3
        WSQ(J) = 0.0D0
        DO MU = 1,3
          WSQ(J) = WSQ(J) + W(J,MU)**2
        ENDDO
        WABS(J) = SQRT(WSQ(J))
      ENDDO
C
C The size of the critical ellipses.
C
      ACRIT2 = RTS - 2.0D0*QABS(2)
      ACRIT3 = RTS - 2.0D0*QABS(3)
C
C The sizes of the ellipses at point L.
C
      A2 = LABS(3) + LABS(1) - QABS(2)
      A3 = LABS(1) + LABS(2) - QABS(3)
C
C Calculate the matrix d W(j,mu)/ d L(mu) = Mj(mu,nu).
C
      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
      ENDDO
      ENDDO
C
C The "distances" to the collinear lines. In this case we do not need D2.
C
      D1 = LABS(2)*LABS(3)*WABS(1)/QABS(1)
      D3 = LABS(1)*LABS(2)*WABS(3)/QABS(3)
C
C The square of the smaller of D1 and D3 and its gradient.
C
      IF (D1.LT.D3) THEN
C
C D1 is the smaller distance.
C
        DSQ = D1**2
        DO NU = 1,3
          TEMP = 0.0D0
          DO MU = 1,3
            TEMP = TEMP + W(1,MU)*M1(MU,NU)
          ENDDO
          TEMP = TEMP/WSQ(1)
          TEMP = TEMP + L(2,NU)/LSQ(2) + L(3,NU)/LSQ(3)
          GRADDSQ(NU) = 2.0D0*DSQ*TEMP
        ENDDO
C
      ELSE
C
C D3 is the smaller distance.
C
        DSQ = D3**2
        DO NU = 1,3
          TEMP = 0.0D0
          DO MU = 1,3
            TEMP = TEMP + W(3,MU)*M3(MU,NU)
          ENDDO
          TEMP = TEMP/WSQ(3)
          TEMP = TEMP + L(1,NU)/LSQ(1) + L(2,NU)/LSQ(2)
          GRADDSQ(NU) = 2.0D0*DSQ*TEMP
        ENDDO
C
      ENDIF
C
C The function G2 and its derivative.
C
      G2 = 1.0D0/(ACRIT2 + DEFORMGAMMA*A2)
      DG2DA2 = - DEFORMGAMMA/(ACRIT2 + DEFORMGAMMA*A2)**2
C
C Calculate the function C(DSQ) and its derivative. Note that we change
C the sign of C in the case of a loop to the right of the cut.
C
      C = SIGN*DEFORMALPHA*DSQ /(1.0D0 + 4.0D0*DEFORMBETA*DSQ/S)
      DLNCDDSQ = 1.0D0/DSQ/(1.0D0 + 4.0D0*DEFORMBETA*DSQ/S)
C
C Calculate the imaginary part of the loop momentum L(mu).
C
      DO MU = 1,3
        NEWKINLOOP(MU) = (0.0D0,-1.0D0) * C * G2 * W(2,MU)
      ENDDO 
C
C Calculate the jacobian.
C First, we need the comlex matrix A(mu,nu), the derivative
C of ComplexL(mu) with respecdt to L(nu).
C
      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
      ENDDO
      ENDDO
C
C Finally, the jacobian is the determinant of A
C
      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) )
C
C End of calculation for Ninloop = 3 for a loop not connecting to the
C current ( IF(CONNECTSTOCURRENT) ... ELSE ...).
C
      ENDIF
C
C End of Ninloop = 3 calculation
C
C Four particles in the loop.------------
C
      ELSE IF (NINLOOP.EQ.4) THEN
C
C Calculate Q(j,mu), |L(j)|^2, |Q(j)|^2, |L(j)|, |Q(j)|, hat L(j,mu).
C
      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)
      ENDDO
      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
        ENDDO
        QABS(J) = SQRT(QSQ(J))
        LABS(J) = SQRT(LSQ(J))
        DO MU = 1,3
          LHAT(J,MU) = L(J,MU)/LABS(J)
        ENDDO
      ENDDO
C
C The vectors W(j,mu) and their squares and their absolute values. 
C
      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)
      ENDDO
      DO J = 1,3
        WSQ(J) = 0.0D0
        DO MU = 1,3
          WSQ(J) = WSQ(J) + W(J,MU)**2
        ENDDO
        WABS(J) = SQRT(WSQ(J))
      ENDDO
C
C The size of the critical ellipses.
C
      ACRIT2 = RTS - 2.0D0*QABS(2)
      ACRIT3 = RTS - 2.0D0*QABS(3)
C
C The sizes of the ellipses at point L.
C
      A2 = LABS(3) + LABS(1) - QABS(2)
      A3 = LABS(1) + LABS(2) - QABS(3)
C
C Calculate the matrix d W(j,mu)/ d L(mu) = Mj(mu,nu).
C
      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
      ENDDO
      ENDDO
C
C The "distances" to the collinear lines.
C
      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)
C
C The square of the smallest distance its gradient.
C
      IF ((D1.LT.D2).AND.(D1.LT.D3)) THEN
C
C D1 is the smallest distance
C
        DSQ = D1**2
        DO NU = 1,3
          TEMP = 0.0D0
          DO MU = 1,3
            TEMP = TEMP + W(1,MU)*M1(MU,NU)
          ENDDO
          TEMP = TEMP/WSQ(1)
          TEMP = TEMP + L(2,NU)/LSQ(2) + L(3,NU)/LSQ(3)
          GRADDSQ(NU) = 2.0D0*DSQ*TEMP
        ENDDO
C
      ELSE IF (D2.LT.D3) THEN
C
C D2 is the smallest distance
C
        DSQ = D2**2
        DO NU = 1,3
          TEMP = 0.0D0
          DO MU = 1,3
            TEMP = TEMP + W(2,MU)*M2(MU,NU)
          ENDDO
          TEMP = TEMP/WSQ(2)
          TEMP = TEMP + L(3,NU)/LSQ(3) + L(1,NU)/LSQ(1)
          GRADDSQ(NU) = 2.0D0*DSQ*TEMP
        ENDDO
C
      ELSE
C
C D3 is the smallest distance.
C
        DSQ = D3**2
        DO NU = 1,3
          TEMP = 0.0D0
          DO MU = 1,3
            TEMP = TEMP + W(3,MU)*M3(MU,NU)
          ENDDO
          TEMP = TEMP/WSQ(3)
          TEMP = TEMP + L(1,NU)/LSQ(1) + L(2,NU)/LSQ(2)
          GRADDSQ(NU) = 2.0D0*DSQ*TEMP
        ENDDO
C
      ENDIF
C
C The mixing fraction FRACTION and its gradient.
C
      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
      ENDDO
C
C The functions G2 and G3 and their derivatives.
C
      G2 = 1.0D0/(ACRIT2 + DEFORMGAMMA*A2)
      G3 = 1.0D0/(ACRIT3 + DEFORMGAMMA*A3)
      DG2DA2 = - DEFORMGAMMA/(ACRIT2 + DEFORMGAMMA*A2)**2
      DG3DA3 = - DEFORMGAMMA/(ACRIT3 + DEFORMGAMMA*A3)**2
C
C Calculate the function C(DSQ) and its derivative. Note that we change
C the sign of C in the case of a loop to the right of the cut.
C
      C = SIGN*DEFORMALPHA*DSQ /(1.0D0 + 4.0D0*DEFORMBETA*DSQ/S)
      DLNCDDSQ = 1.0D0/DSQ/(1.0D0 + 4.0D0*DEFORMBETA*DSQ/S)
C
C Calculate the imaginary part of the loop momentum L(mu).
C
      DO MU = 1,3
        NEWKINLOOP(MU) = (0.0D0,-1.0D0) * C 
     >         * (FRACTION*G2*W(2,MU) + (1.0D0 - FRACTION)*G3*W(3,MU))
      ENDDO 
C
C Calculate the jacobian.
C First, we need the comlex matrix A(mu,nu), the derivative
C of ComplexL(mu) with respecdt to L(nu).
C
      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
      ENDDO
      ENDDO
C
C Finally, the jacobian is the determinant of A
C
      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) )
C
C End of Ninloop = 4 calculation
C
      ELSE
        WRITE(NOUT,*) 'Not programed for NINLOOP > 4 yet.'
        STOP
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION DELTA(MU,NU)
C
C In:
      INTEGER MU,NU
C
C Kroneker delta.
C
      IF (MU.EQ.NU) THEN
        DELTA = 1.0D0
      ELSE
        DELTA = 0.0D0
      ENDIF
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION SMEAR(RTS)
C
      REAL*8 RTS
C
C A smearing function that may do a good job of optimizing
C the integration accuracy.  It satisfies
C
C   Int_0^\infty dE SMEAR(E)  = 1
C
C We take
C
C  SMEAR(E) = (N-1)!/[M! (N-M-2)!] (A E_0 )**(N-M-1)
C             * E**M / [E + A * E_0]**N
C
C where E_0 = ENERGYSCALE = 1.
C                   
C
      REAL*8 SMEARFCTR
      INTEGER LOWPWR,HIGHPWR
      COMMON /SMEARPARMS/ SMEARFCTR,LOWPWR,HIGHPWR
C
      REAL*8 ENERGYSCALE
      PARAMETER (ENERGYSCALE = 1.0D0)
      REAL*8 FACTORIAL
C
      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
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C                 Feynman integrand in Feynman gauge                   C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      COMPLEX*16 FUNCTION FEYNMANF(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
C
C In:
      INTEGER SIZE
      PARAMETER (SIZE = 3)
      INTEGER GRAPHNUMBER
      COMPLEX*16 KC(0:3*SIZE-1,0:3)
      LOGICAL CUT(3*SIZE-1)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C
C Feynman integrand function for graph GRAPHNUMBER
C with complex momenta KC and cut specified by CUT.
C Early version: 17 July 1994.
C This version written by Mathematica code of 4 January 2002 on
C 4 Jan 2002.
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
C
      REAL*8 METRIC(0:3)
      DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/
      COMPLEX*16 GN(0:3)
      DATA GN /+1.0D0,0.0D0,0.0D0,0.0D0/
C
      REAL*8 CF
      COMPLEX*16 COMPLEXSQRT
      INTEGER MU,NU,TAU
      COMPLEX*16 X(256)
      COMPLEX*16 K1(0:3),K2(0:3),K3(0:3),K4(0:3)
      COMPLEX*16 K5(0:3),K6(0:3),K7(0:3),K8(0:3)
      COMPLEX*16 E1,E2,E3,E4,E5,E6,E7,E8
      COMPLEX*16 K11,K22,K33,K44,K55,K66,K77,K88
      COMPLEX*16 TK11,TK22,TK33,TK44,TK55,TK66,TK77,TK88
      COMPLEX*16 PREFACTOR
      CHARACTER*13 KIND2PT2
      COMPLEX*16 K2PT2(0:5,0:3)
      LOGICAL CUT2PT2(1:5)
      CHARACTER*9 KIND2PT
      COMPLEX*16 K2PT(0:2,0:3)
      LOGICAL CUT2PT(0:3)
      CHARACTER*7 KIND3PT
      COMPLEX*16 K3PT(3,0:3)
      LOGICAL CUT3PT(3)
C
      COMPLEX*16 A1QDA4Q,A1QIK6A4QIK7,A1QIK7A4QIK6,EA1QK3Q47
      COMPLEX*16 EA1QZV4QK6K7,EA2QK3Q67,EA3QK1Q26,EA4QK1Q86
      COMPLEX*16 EA4QZV1QK6K7,EA7AK1IK2K3K4,EA7AK1K2,EA7AK1K3,EA7AK1K4
      COMPLEX*16 EA7AK2IK1K3K4,EA7AK2K3,EA7AK2K4,EA7AK3IK1K2K4,EA7AK3K4
      COMPLEX*16 EA7AK4IK1K2K3,EA8AK1IK2K3K4,EA8AK1K2,EA8AK1K3,EA8AK1K4
      COMPLEX*16 EA8AK2IK1K3K4,EA8AK2K3,EA8AK2K4,EA8AK3IK1K2K4,EA8AK3K4
      COMPLEX*16 EA8AK4IK1K2K3,G7AWK1K2,G7AWK1K3,G7AWK2K4,G7AWK3K4,K1K2
      COMPLEX*16 K1K3,K1K4,K1Q24,K1Q26,K1Q36,K1Q84,K1Q86,K1QQNB45
      COMPLEX*16 K1QQNB46,K1QQNG45,K1QQNG46,K1QQNQ45,K1QQNQ46,K1QQOG57
      COMPLEX*16 K1QQOG75,K1QQOQ57,K1QQOQ64,K2K3,K2K4,K2Q24,K2Q36,K2Q84
      COMPLEX*16 K2Q86,K3K4,K3Q47,K3Q67,K6K7,Q15Q47,Q24Q86,Q36Q84
      COMPLEX*16 TRACEG7A,TRACEV1Q,TRACEV2Q,TRACEV3Q,TRACEV4Q,TRACEV7A
      COMPLEX*16 TRACEV8A,V1QDV4Q,V1QIK6V4QIK7,V1QIK7V4QIK6,V1QWK3Q47
      COMPLEX*16 V1QWQ47K3,V2QWK3Q67,V2QWQ67K3,V3QWK1Q26,V3QWQ26K1
      COMPLEX*16 V4QWK1Q86,V4QWQ86K1,V7AWK1K2,V7AWK1K3,V7AWK1K4
      COMPLEX*16 V7AWK2K1,V7AWK2K3,V7AWK2K4,V7AWK3K1,V7AWK3K2,V7AWK3K4
      COMPLEX*16 V7AWK4K1,V7AWK4K2,V7AWK4K3,V8AWK1K2,V8AWK1K3,V8AWK1K4
      COMPLEX*16 V8AWK2K1,V8AWK2K3,V8AWK2K4,V8AWK3K1,V8AWK3K2,V8AWK3K4
      COMPLEX*16 V8AWK4K1,V8AWK4K2,V8AWK4K3,A1QIK6(0:3),A1QIK7(0:3)
      COMPLEX*16 A4QIK6(0:3),A4QIK7(0:3),A7AK1I(0:3),A7AK2I(0:3)
      COMPLEX*16 A7AK3I(0:3),A7AK4I(0:3),A8AK1I(0:3),A8AK2I(0:3)
      COMPLEX*16 A8AK3I(0:3),A8AK4I(0:3),Q15(0:3),Q24(0:3),Q26(0:3)
      COMPLEX*16 Q36(0:3),Q47(0:3),Q67(0:3),Q84(0:3),Q86(0:3)
      COMPLEX*16 QQNB45(0:3),QQNB46(0:3),QQNG45(0:3),QQNG46(0:3)
      COMPLEX*16 QQNQ45(0:3),QQNQ46(0:3),QQOG57(0:3),QQOG75(0:3)
      COMPLEX*16 QQOQ57(0:3),QQOQ64(0:3),V1QIK6(0:3),V1QIK7(0:3)
      COMPLEX*16 V4QIK6(0:3),V4QIK7(0:3),A1Q(0:3,0:3),A1QZV4Q(0:3,0:3)
      COMPLEX*16 A2Q(0:3,0:3),A3Q(0:3,0:3),A4Q(0:3,0:3)
      COMPLEX*16 A4QZV1Q(0:3,0:3),A7A(0:3,0:3),A8A(0:3,0:3)
      COMPLEX*16 G7A(0:3,0:3),V1Q(0:3,0:3),V2Q(0:3,0:3),V3Q(0:3,0:3)
      COMPLEX*16 V4Q(0:3,0:3),V7A(0:3,0:3),V8A(0:3,0:3)
C
      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)
      ENDDO
      CF = (NC**2 - 1.0D0)/2.0D0/NC
      FEYNMANF = 0.0D0
C
C------
C
      IF (GRAPHNUMBER .EQ. 1) THEN
C
      PREFACTOR = 1.0D0
      E1 = K1(0)
      TK11 = 0.0D0
      DO MU = 1,3
        TK11 = TK11 - K1(MU)**2
      ENDDO
      K11 = E1**2 + TK11
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      FEYNMANF = -8*(K1QQNB45 - K1QQNB46 + K1QQNG45 - K1QQNG46
     > + K1QQNQ45 - K1QQNQ46)*NC
      FEYNMANF = FEYNMANF*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 2) THEN
C
      PREFACTOR = 1.0D0
      E1 = K1(0)
      TK11 = 0.0D0
      DO MU = 1,3
        TK11 = TK11 - K1(MU)**2
      ENDDO
      K11 = E1**2 + TK11
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      DO MU = 0,3
        K2PT(0,MU) = K2(MU)
        K2PT(1,MU) = K4(MU)
        K2PT(2,MU) = K5(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      FEYNMANF = 8*NC*(K1Q86*K2Q24 + K1Q84*K2Q36 + K1Q36*K2Q84
     > + K1Q24*K2Q86 - K1K2*Q24Q86 - K1K2*Q36Q84)
      FEYNMANF = FEYNMANF*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 3) THEN
C
      PREFACTOR = 1.0D0
      E1 = K1(0)
      TK11 = 0.0D0
      DO MU = 1,3
        TK11 = TK11 - K1(MU)**2
      ENDDO
      K11 = E1**2 + TK11
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      FEYNMANF = 8*(K1QQOG57 - K1QQOG75 + K1QQOQ57 - K1QQOQ64)*NC
      FEYNMANF = FEYNMANF*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 4) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      DO MU = 0,3
        K2PT(0,MU) = K5(MU)
        K2PT(1,MU) = K7(MU)
        K2PT(2,MU) = K8(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      ELSE IF (GRAPHNUMBER .EQ. 5) THEN
C
      PREFACTOR = 1.0D0
      E3 = K3(0)
      TK33 = 0.0D0
      DO MU = 1,3
        TK33 = TK33 - K3(MU)**2
      ENDDO
      K33 = E3**2 + TK33
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K1(MU)
        K3PT(2,MU) = K2(MU)
        K3PT(3,MU) = -K5(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      ELSE IF (GRAPHNUMBER .EQ. 6) THEN
C
      PREFACTOR = 1.0D0
      E1 = K1(0)
      TK11 = 0.0D0
      DO MU = 1,3
        TK11 = TK11 - K1(MU)**2
      ENDDO
      K11 = E1**2 + TK11
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K3(MU)
        K3PT(2,MU) = K4(MU)
        K3PT(3,MU) = -K5(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      ELSE IF (GRAPHNUMBER .EQ. 7) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      IF (CUT(5)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55)
      ELSE
        PREFACTOR = PREFACTOR/K55
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = K7(MU)
        K3PT(2,MU) = -K8(MU)
        K3PT(3,MU) = -K6(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      ELSE IF (GRAPHNUMBER .EQ. 8) THEN
C
      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
      ENDDO
      K66 = E6**2 + TK66
      K77 = E7**2 + TK77
      IF (CUT(6)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK66)
      ELSE
        PREFACTOR = PREFACTOR/K66
      ENDIF
      IF (CUT(7)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK77)
      ELSE
        PREFACTOR = PREFACTOR/K77
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K1(MU)
        K3PT(2,MU) = K2(MU)
        K3PT(3,MU) = -K5(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ENDDO
      DO MU = 0,3
      DO NU = 0,3
        A1QZV4Q(MU,NU) = 0.0D0
        A4QZV1Q(MU,NU) = 0.0D0
      ENDDO
      ENDDO
      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)
      ENDDO
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      ELSE IF (GRAPHNUMBER .EQ. 9) THEN
C
      PREFACTOR = 1.0D0
      DO MU = 0,3
        K2PT(0,MU) = K1(MU)
        K2PT(1,MU) = K5(MU)
        K2PT(2,MU) = K6(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      FEYNMANF = -8*NC*Q15Q47
      FEYNMANF = FEYNMANF*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 10) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      IF (CUT(5)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55)
      ELSE
        PREFACTOR = PREFACTOR/K55
      ENDIF
      IF (CUT(6)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK66)
      ELSE
        PREFACTOR = PREFACTOR/K66
      ENDIF
      IF (CUT(7)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK77)
      ELSE
        PREFACTOR = PREFACTOR/K77
      ENDIF
      IF (CUT(8)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK88)
      ELSE
        PREFACTOR = PREFACTOR/K88
      ENDIF
      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)
      ENDDO
      FEYNMANF = -64*CF*K1K3*K2K4*K6K7
      FEYNMANF = FEYNMANF*PREFACTOR
C
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C           Feynman integrand in Feynman gauge, Born level             C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      COMPLEX*16 FUNCTION FEYNMAN0F(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
C
C In:
      INTEGER SIZE
      PARAMETER (SIZE = 3)
      INTEGER GRAPHNUMBER
      COMPLEX*16 KC(0:3*SIZE-1,0:3)
      LOGICAL CUT(3*SIZE-1)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C
C Feynman integrand function for graph GRAPHNUMBER
C with complex momenta KC and cut specified by CUT.
C Early version: 17 July 1994.
C This version written by Mathematica code of 7 February 2002 on
C 8 Feb 2002.
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
C
      REAL*8 METRIC(0:3)
      DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/
      REAL*8 GN(0:3)
      DATA GN /+1.0D0,0.0D0,0.0D0,0.0D0/
C
      REAL*8 CF
      COMPLEX*16 COMPLEXSQRT
      INTEGER MU
      COMPLEX*16 K1(0:3),K2(0:3),K3(0:3),K4(0:3),K5(0:3)
      COMPLEX*16 E1,E2,E3,E4,E5
      COMPLEX*16 K11,K22,K33,K44,K55
      COMPLEX*16 TK11,TK22,TK33,TK44,TK55
      COMPLEX*16 PREFACTOR
C
      COMPLEX*16 K1K2,K1K4,K1K5,K2K3,K2K5
C
      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)
      ENDDO
      CF = (NC**2 - 1.0D0)/2.0D0/NC
      FEYNMAN0F = 0.0D0
C
C------
C
      IF (GRAPHNUMBER .EQ. 11) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      IF (CUT(5)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55)
      ELSE
        PREFACTOR = PREFACTOR/K55
      ENDIF
      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)
      ENDDO
      FEYNMAN0F = -32*CF*(K1K5*K22 - 2*K1K2*K2K5)*NC
      FEYNMAN0F = FEYNMAN0F*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 12) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      IF (CUT(5)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55)
      ELSE
        PREFACTOR = PREFACTOR/K55
      ENDIF
      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)
      ENDDO
      FEYNMAN0F = 32*CF*K1K4*K2K3*NC
      FEYNMAN0F = FEYNMAN0F*PREFACTOR
C
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C             Vertex and propagator functions in Feynman gauge         C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE TWOPOINTGF(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUT)
C In:
      CHARACTER*9 KIND2PT
      COMPLEX*16 K2PT(0:2,0:3)
      LOGICAL CUT2PT(0:3)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C Out:
      COMPLEX*16 OUT(0:3,0:3)
C
C Calculates the one loop gluon two-point function, including the
C adjoining propagators *in Feynman gauge* with the modification that
C it is multiplied by a Coulomb gauge projection matrix on the left
C and on the right.
C
C kind2pt:
C   GLUONLOOP gluon self-energy with a gluon (including ghost) loop
C   QUARKLOOP gluon self-energy with a quark loop
C   BOTHLOOPS the sum of these
C
C k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part)
C k2pt(1,mu): 1st momentum in loop (kplus for the space part)
C k2pt(2,mu): 2nd momentum in loop (kminus for the space part)
C
C cut2pt(0): whether incoming line is cut
C cut2pt(1): whether 1st internal line is cut
C cut2pt(2): whether 2nd internal line is cut
C cut2pt(3): whether outgoing line is cut
C
C mumsbar is the MSbar renormalization scale.
C
C The result is the two  point function out(mu,nu) with a certain
C normalization. Specifically, for the cut gluon self-energy
C graph, out(mu,nu) is {\cal M}_g^{\mu\nu}
C divided by (\alpha_s/(4\pi)) * 1/(1+\Delta) and divided
C by 2\omega_+ * 2\omega_- *\bar q^2. The factor by which we divide
C consists of
C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
C   one (2\pi)^{-3} for each loop that is factored out of each
C   graph in our program.
C * (d\vec l)/(d\bar q^2 dx d\phi)
C    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
C * 4 \pi {\cal Q} \bar q^2 included in the relation between
C   {\cal I}[real] and {\cal M}_g^{\mu\nu}
C
C In the case of the virtual gluon self-energy graphs
C with an adjacent propagator cut, out(mu,nu) is {\cal W}_g^{\mu\nu}
C divided by the same factors.
C
C 16 December 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
      INTEGER MU,NU
      COMPLEX*16 COMPLEXSQRT
      COMPLEX*16 KPLUS(1:3),KMINUS(1:3),ELL(1:3),Q(1:3)
      COMPLEX*16 CALQSQ, OMEGAPLUSSQ,OMEGAMINUSSQ
      COMPLEX*16 CALQ,OMEGAPLUS,OMEGAMINUS,Q0
      COMPLEX*16 DELTAP1,DELTA,TWOXM1,X1MX,QBARSQ
      COMPLEX*16 ELLT(1:3)
      COMPLEX*16 ELLTSQ,ONEM2X1MX
      COMPLEX*16 TEMP
      COMPLEX*16 BAREPROP(1:3,1:3)
      COMPLEX*16 NTT,NLL,NEE,NEL
      COMPLEX*16 PREFACTOR
      COMPLEX*16 TERMTT,TERMLL
      COMPLEX*16 AT0
      COMPLEX*16 NTT0
      COMPLEX*16 NET0
      COMPLEX*16 UTT,NET
C 
C Some auxilliary variables, including
C CALQ = {\cal Q}
C OMEGAPLUS = \omega_+
C OMEGAMINUS = \omega_-
C DELTAP1 = \Delta + 1
C TWOXM1 = 2 x - 1
C X1MX = x (1-x)
C ELLT(mu) = l_T^\mu
C ELLTSQ = (\vec l_T)^2
C Q(mu) = the incoming *three*-momentum
C Q0 = the incoming energy
C
      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)
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ELLTSQ = QBARSQ*X1MX
      ONEM2X1MX = 1.0D0 - 2.0D0*X1MX
C
C The gluon propagator in Coulomb gauge for an on-shell gluon
C with three-momentum Q(mu). This is the space components only.
C
      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
      ENDDO
      ENDDO
C
      IF (CUT2PT(1).AND.CUT2PT(2)) THEN
C
C We have the contribution from a cut self-energy diagram.
C We compute the coefficients for, alternatively, the gluon loop
C or the quark loop. We use the name NLL for Ntt and NEL for NEt.
C
      IF (KIND2PT.EQ.'GLUONLOOP') THEN
C 
      NTT =  2.0D0*NC*( - 1.0D0 + X1MX)
      NLL =  4.0D0*NC*X1MX
      NEE = - NC*(1.0D0 + 4.0D0*X1MX)
      NEL = - 2.0D0*NC*TWOXM1
C
      ELSE IF (KIND2PT.EQ.'QUARKLOOP') THEN
C
      NTT = NF*ONEM2X1MX
      NLL = - 4.0D0*NF*X1MX
      NEE = 4.0D0*NF*X1MX
      NEL = 2.0D0*NF*TWOXM1
C
      ELSE IF (KIND2PT.EQ.'BOTHLOOPS') THEN
C
      NTT =  2.0D0*NC*( - 1.0D0 + X1MX)
      NLL =  4.0D0*NC*X1MX
      NEE = - NC*(1.0D0 + 4.0D0*X1MX)
      NEL = - 2.0D0*NC*TWOXM1
C
      NTT = NTT + NF*ONEM2X1MX
      NLL = NLL - 4.0D0*NF*X1MX
      NEE = NEE + 4.0D0*NF*X1MX
      NEL = NEL + 2.0D0*NF*TWOXM1
C
      ELSE
        WRITE(NOUT,*)'Unrecognized type in subroutine twopointg.'
        STOP
      ENDIF
C
C With the coefficients in hand, we compute the result.
C
      PREFACTOR = 1.0D0/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ)
C
      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
      ENDDO
      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)
      ENDDO
      ENDDO
C
C Alternative for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....
C
      ELSE IF (CUT2PT(0).OR.CUT2PT(3)) THEN
C
C We have the contribution from a virtual self-energy diagram
C with one of the neighboring propagators cut.
C We compute the coefficients for, alternatively, the gluon loop
C or the quark loop.
C
      IF (KIND2PT.EQ.'GLUONLOOP') THEN
C
        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
C
        UTT = AT0
        NTT = NTT0
        NET = NET0
C
      ELSE IF (KIND2PT.EQ.'QUARKLOOP') THEN
C
C Here AT1 = AT2 = NTT1 = NTT2 = NET1 = NET2 = 0.
C
        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
C
        UTT = AT0
        NTT = NTT0
        NET = NET0
C
      ELSE IF (KIND2PT.EQ.'BOTHLOOPS') THEN
C
        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
C
        UTT = AT0
        NTT = NTT0
        NET = NET0
C
        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
C
        UTT = UTT + AT0
        NTT = NTT + NTT0
        NET = NET + NET0
C
      ELSE
        WRITE(NOUT,*)'Unrecognized type in subroutine twopointg.'
        STOP
      ENDIF
C
C With the coefficients in hand, we compute the result. There is
C an extra factor 1 + \Delta  compared to the real self-energy
C graphs because {\cal W} lacks the factor 1/(1 + \Delta) that
C appears in {\cal M}.
C
C Also, we divide by 2 because we will get this contribution
C twice, once when one adjacent propagator is cut and onece
C when the other adjacent propagator is cut.
C
      PREFACTOR = - DELTAP1/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ)
      PREFACTOR = 0.5D0*PREFACTOR
C
      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
      ENDDO
      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)
      ENDDO
      ENDDO
C
C Closing for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....ELSEIF ...
C
      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
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,OUT)
C In:
      COMPLEX*16 K2PT(0:2,0:3)
      LOGICAL CUT2PT(0:3)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C Out:
      COMPLEX*16 OUT(0:3)
C
C Calculates the one loop quark two-point function, including the
C adjoining propagators.
C
C k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part)
C k2pt(1,mu): 1st momentum in loop (kplus for the space part)
C k2pt(2,mu): 2nd momentum in loop (kminus for the space part)
C
C cut2pt(0): whether incoming line is cut
C cut2pt(1): whether 1st internal line is cut
C cut2pt(2): whether 2nd internal line is cut
C cut2pt(3): whether outgoing line is cut
C
C mumsbar is the MSbar renormalization scale.
C
C The two  point function, with a certain normalization, 
C is represented as out^mu gamma_mu. 

C For the real quark self-energy graphs, out^{\mu} gamma_{\mu} 
C is {\cal M}_q divided by 
C (\alpha_s/(4\pi)) * 1/(1+\Delta) 
C and divided by 
C 4 * \omega_+ * \omega_- * \bar q^2. 
C The factor by which we divide consists of
C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
C   one (2\pi)^{-3} for each loop that is factored out of each
C   graph in our program.
C * (d\vec l)/(d\bar q^2 dx d\phi)
C    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
C * 4 \pi {\cal Q} \bar q^2 included in the relation between
C   {\cal I}[real] and {\cal M}_q.
C
C In the case of the virtual quark self-energy graphs with
C one of the adjacent propagators cut, OUT^{\mu} gamma_{\mu} 
C is {\cal W}_q divided by the same factors.
C
C In the case of the virtual quark self-energy graphs with
C the adjacent propagators *not* cut, OUT^{\mu} gamma_{\mu} 
C is W_q divided by 
C (\alpha_s/(4\pi)) * 1/(1+\Delta)
C and divided by 
C 2 * \omega_+ * \omega_- * (\bar q^2 - q^2) * q^2/{\cal Q}.
C The factor by which we divide consists of
C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
C   one (2\pi)^{-3} for each loop that is factored out of each
C   graph in our program.
C * (d\vec l)/(d\bar q^2 dx d\phi)
C    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
C * 2 \pi q^2 (\bar q^2 - q^2) included in the relation between
C   {\cal I}[all uncut] and W_q. 
C
C 16 December 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF,CF
      COMMON /COLORFACTORS/ NC,NF
      COMPLEX*16 COMPLEXSQRT
      INTEGER MU
      COMPLEX*16 KPLUS(1:3),KMINUS(1:3),ELL(1:3),Q(1:3)
      COMPLEX*16 CALQSQ,OMEGAPLUSSQ,OMEGAMINUSSQ
      COMPLEX*16 CALQ,OMEGAPLUS,OMEGAMINUS
      COMPLEX*16 DELTAP1,DELTA,TWOXM1,X1MX,QBARSQ
      COMPLEX*16 ELLT(1:3)
      COMPLEX*16 ELLTSQ,ONEM2X1MX,X
      COMPLEX*16 TEMP,TEMPSQ
      COMPLEX*16 NL,NE,NT,PREFACTOR
      COMPLEX*16 BL0
      COMPLEX*16 NL0
      COMPLEX*16 NT0
      COMPLEX*16 UL,VL,VT
      COMPLEX*16 Q0,QSQ
      COMPLEX*16 BE0
      COMPLEX*16 UE
C
      CF = (NC**2 - 1.0D0)/(2.0D0*NC)
C 
C Some auxilliary variables, including
C CALQ = {\cal Q}
C OMEGAPLUS = \omega_+
C OMEGAMINUS = \omega_-
C DELTAP1 = \Delta + 1
C TWOXM1 = 2 x - 1
C X1MX = x (1-x)
C ELLT(mu) = l_T^\mu
C ELLTSQ = (\vec l_T)^2
C Q(mu) = the incoming *three*-momentum
C Q0 = the incoming energy
C
      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)
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ELLTSQ = QBARSQ*X1MX
      ONEM2X1MX = 1.0D0 - 2.0D0*X1MX
      X = (TWOXM1 + 1.0D0)/2.0D0
C
C Now we will go through these possible cut structures and
C calculate the terms contributing to out(mu).
C
      IF ( CUT2PT(1).AND.CUT2PT(2) ) THEN
C
C First possibility for cut structure: a cut self-energy diagram.
C Here TEMP = 2 x + Delta.
C
      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
C
      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))
      ENDDO
C
      ELSE IF ( CUT2PT(0).OR.CUT2PT(3) ) THEN
C
C Second possibility for cut structure: a virtual self-energy
C with an adjacent propagator cut.
C
      TEMP = MUMSBAR**2 * EXP(1.0D0)
      BL0 = CF*TEMP/(QBARSQ + TEMP) 
      NL0 = CF*TWOXM1
      NT0 = 2.0D0*CF
      UL = BL0
      VL = NL0
      VT = NT0
C
C We divide by 2 because we will get this contribution
C twice, once when one adjacent propagator is cut and once
C when the other adjacent propagator is cut.
C
      PREFACTOR = DELTAP1/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ)
      PREFACTOR = 0.5D0*PREFACTOR
C
      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))
      ENDDO
C 
      ELSE
C
C Third possibility for cut structure: a virtual self-energy
C with *no* adjacent propagator cut.
C
      QSQ = Q0**2 - CALQSQ
C
      TEMP = MUMSBAR**2 * EXP(1.0D0)
      BL0 = (QSQ + TEMP)/(QBARSQ + TEMP)
      BL0 = CF*BL0
      BE0 = 0.0D0
      UL = BL0
      UE = BE0
C
      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
      ENDDO
C
C Completion of IF ... block for cut structure.
C
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,HV,HA)
C In:
      CHARACTER*7 KIND3PT
      COMPLEX*16 K3PT(3,0:3)
      LOGICAL CUT3PT(3)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C Out:
      COMPLEX*16 HV(0:3,0:3),HA(0:3,0:3)
C
C The unintegrated quark-antiquark-gluon three point function
C for the graph with flavors labelled by KIND3PT. 
C
C KIND3PT has the form abc/def where a,...,f are chosen from 
C Q,G,P. Here Q denotes "quark" or "antiquark", G denotes "gluon",
C and P denotes "photon. The external lines have flavors a,b,c
C and the internal lines have flavors d,e,f. The possibilities
C are QQG/QQG, QQG/GGQ, and QQP/QQG. There is also QQG/ALL, which
C gives the sum of the results for QQG/QQG and QQG/GGQ.
C
C The unintegrated three-point function \Gamma^\mu can be decomposed
C into a function HV^\mu_\nu \gamma^\mu plus a function 
C HA^\mu_\nu I \gamma^\mu \gamma_5 (all times a t^a color matrix or a
C unit color matrix in the case of a QQP vertex). This subroutine
C calculates the functions HV^{\mu\nu} and HA^{\mu\nu}.  The arguments
C are the momenta k3pt(1,mu), k3pt(2,mu), k3pt(3,mu), of the propagators
C around the loop. 
C
C The variable cut3pt(j) is .true. if line j is cut, .false. otherwise.
C If the line is cut, the corresponding energy is set by the calling
C programs to be k0 = + |\vec k| or else k0 = - |\vec k|. (Here
C |\vec k| is a shorthand for sqrt(\vec k^2), not the square root of 
C \vec k dotted into its complex conjugate.) This subroutine supplies a
C factor k(j)^2 for uncut propagators and 2 sqrt(\vec k^2) for a cut
C propagator.  For a virtual loop, subroutine vertex will be called six
C times, once with each of the three propagators cut and k0 = + |\vec k|
C and once with each of the three propagators cut and k0 = - |\vec k|.
C Then it will be called with no propagator cut, which implies that it
C should supply the renormalization counter term.
C
C This version in Feynman gauge.
C 31 December 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
      COMPLEX*16 COMPLEXSQRT
C
      REAL*8 CF
      COMPLEX*16 NVEC(0:3)
      DATA NVEC /1,0,0,0/
      REAL*8 G(0:3,0:3)
      DATA G /1, 0, 0, 0,
     >        0,-1, 0, 0,
     >        0, 0,-1, 0,
     >        0, 0, 0,-1/
C
      COMPLEX*16 TK11,TK22,TK33,TK12,TK23,TK13
      COMPLEX*16 K11,K22,K33,K12,K23,K13
      COMPLEX*16 E1,E2,E3
      COMPLEX*16 C1,C2,C3,C4,C5,C6,C7,C8,C9
      COMPLEX*16 C10,C11,C12,C13,C14,C15,C16,C17
      COMPLEX*16 TEMP,PREFACTOR
      INTEGER MU,NU
      COMPLEX*16 K1(0:3),K2(0:3),K3(0:3)
      COMPLEX*16 EPSN1(0:3,0:3),EPSN2(0:3,0:3),EPSN3(0:3,0:3)
      COMPLEX*16 EPS12(0:3,0:3),EPS13(0:3,0:3),EPS23(0:3,0:3)
      COMPLEX*16 EPSN12(0:3),EPSN13(0:3),EPSN23(0:3),EPS123(0:3)
      COMPLEX*16 TL(0:3),OMEGASQ,OMEGA,CR1,CR2,CR3
      INTEGER NCUT,P
C
C-----
C
      CF = (NC**2 - 1.0D0)/(2.0D0*NC)
      NCUT = 0
      DO P=1,3
         IF (CUT3PT(P)) THEN
           NCUT = NCUT + 1
         ENDIF
      ENDDO
C
      IF ((NCUT.GT.1).OR.(FLAG.NE.'renormalize 3 pt')) THEN
C
C If NCUT = 1, we have a virtual loop. In this case, one of the
C possibilities is the renormalization counter term, for which
C FLAG would have been set to 'renormalize 3 pt'. Thus we get
C here is we do *not* have the the renormalization counter term.
C (Note that we could have NCUT = 2 but FLAG = 'renormalize 3 pt'
C in the case that there are two three point functions and ours
C is cut but the other one is virtual and needs to be renormalized.) 
C
C First, dot products and energies. The dot products between vectors
C omitting their mu = 0 parts (\tilde vector) are denoted TKij.
C
      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)
      ENDDO
      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
C
C We need the factor equal to 1/k^2 for an uncut propagator
C and 1/ 2|E| for a cut propagator.
C
      PREFACTOR = (1.0D0,0.0D0)
      IF (.NOT.CUT3PT(1)) THEN
        PREFACTOR = PREFACTOR/K11
      ELSE
        PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK11))
      ENDIF
      IF (.NOT.CUT3PT(2)) THEN
        PREFACTOR = PREFACTOR/K22
      ELSE
        PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK22))
      ENDIF
      IF (.NOT.CUT3PT(3)) THEN
        PREFACTOR = PREFACTOR/K33
      ELSE
        PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK33))
      ENDIF
C
C------------------------
C First, we calculate hv.
C------------------------
C Generate the coefficients for the hv, depending on KIND3PT.
C
      IF (KIND3PT.EQ."QQG/QQG") THEN
C
      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
C
      ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN
C
      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
C
      ELSE IF (KIND3PT.EQ."QQG/ALL") THEN
C
      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
C
      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
C
      ELSE IF (KIND3PT.EQ."QQP/QQG") THEN
C
      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
C
      ELSE
        WRITE(NOUT,*)'Wrong kind in subroutine vertex'
        STOP
      ENDIF
C
C Now we have the coefficients, so we can calculate hv.
C
      DO MU = 0,3
      DO NU = 0,3
C
       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)
C
       HV(MU,NU) = PREFACTOR * TEMP
C
      ENDDO
      ENDDO
C
C------------------------
C Next, we calculate ha.
C------------------------
C
C We need certain vectors and tensors made by dotting vectors
C into the epsilon tensor.
C
      DO MU = 0,3
        K1(MU) = K3PT(1,MU)
        K2(MU) = K3PT(2,MU)
        K3(MU) = K3PT(3,MU)
      ENDDO
      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)
C
C Generate the coefficients for the hv, depending on KIND3PT.
C
      IF (KIND3PT.EQ."QQG/QQG") THEN
C
      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
C
      ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN
C
      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
C
      ELSE IF (KIND3PT.EQ."QQG/ALL") THEN
C
      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
C
      C5 = C5 + (3.0D0*NC)/2.0D0
      C6 = C6 - 3.0D0*NC/2.0D0
C
      ELSE IF (KIND3PT.EQ."QQP/QQG") THEN
C
      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
C
      ELSE
        WRITE(NOUT,*)'Wrong kind in subroutine vertex'
        STOP
      ENDIF
C
C Now we have the coefficients, so we can calculate ha.
C
      DO MU = 0,3
      DO NU = 0,3
C
       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)
C
       HA(MU,NU) = PREFACTOR * TEMP
C
      ENDDO
      ENDDO
C
C-----------------------------
C Now, we have both hv and ha.
C-----------------------------
C
C Alternative for IF (FLAG.NE.'renormalize 3 pt') THEN
C
      ELSE
C
C We need the renormalization counter term.
C
      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
      ENDDO
      OMEGASQ = OMEGASQ + MUMSBAR**2
      OMEGA = COMPLEXSQRT(OMEGASQ)
C
C Generate the coefficients for the hv counter term, 
C depending on KIND3PT.
C
      IF (KIND3PT.EQ."QQG/QQG") THEN
C
      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)
C
      ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN
C
      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)
C
      ELSE IF (KIND3PT.EQ."QQG/ALL") THEN
C
      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)
C
      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)
C
      ELSE IF (KIND3PT.EQ."QQP/QQG") THEN
C
      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)
C
      ELSE
        WRITE(NOUT,*)'Wrong kind in subroutine vertex'
        STOP
      ENDIF
C
C Now we have the coefficients, so we can calculate the hv counter term.
C The ha counter term is zero.
C
      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
      ENDDO
      ENDDO
      RETURN
C
C End  IF (CUT3PT(1).OR.CUT3PT(2).OR.CUT3PT(3)) THEN ... ELSE ...
C
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012   C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,VOUT)
C In:
      CHARACTER*13 KIND2PT2
      COMPLEX*16 K2PT2(0:5,0:3)
      LOGICAL CUT2PT2(1:5)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C Out:
      COMPLEX*16 VOUT(0:3)
C
C *Feynman gauge*.
C
C The two-loop contribution to the quark propagator. The function is 
C a dot product of a four-vector VOUT(mu) with gamma(mu), times a
C unit color matrix. This subroutine calculates VOUT(mu). (There is
C another contribution proportional to gamma(mu) gamma(5), but this
C contribution is not needed at our level of perturbation theory.) The
C contribution includes the self-energy diagram and the adjoining bare
C quark propagators. The calculation includes the denominator factors.
C Some of the internal propagators may be cut, as specified by cut2pt2,
C where cut2pt2(j) = .true. indicates that the corresponding line is 
C cut.
C
C The variable kind2pt2 tells what sort of graph we have.
C
C 1) There are graphs with two overlapping three point functions,
C incicated by kind2pt2 = OVERLAP/abcde where  a,...,e are chosen from 
C Q,G. Here Q denotes "quark" or "antiquark" while G denotes "gluon.
C These characters indicate the flavors on the internal lines. There
C are two possibilities: OVERLAP/QGGQQ and OVERLAP/QGQGG. (The first
C of these has all qqg vertices, while the second has two qqg vertices
C and one ggg vertex.) 
C
C 2) There are graphs with a one loop two point function nested inside
C the two loop two point function. These are indicated by
C kind2pt2 = NESTED /abcde, where, again,  a,...,e are chosen from 
C Q,G. There are three possibilities: 
C    NESTED /QGGGG gluon self-enegy with a gluon loop
C    NESTED /QGGQQ gluon self-enegy with a quark loop
C    NESTED /GQQGQ quark self-enegy
C
C Numbering for graphs of type OVERLAP:
C vrtx1 attaches to the incoming quark line
C vrtx2 attaches to the outgoing quark line
C vrtx3 is the internal vertex attached to a quark line from vrtx1
C vrtx4 is the other internal vertex
C k0(mu) is the momentum of the quark line entering vrtx1
C k1(mu) is the momentum of the internal line from vrtx1 to vrtx3
C k2(mu) is the momentum of the internal line from vrtx1 to vrtx4
C k3(mu) is the momentum of the internal line from vrtx3 to vrtx2
C k4(mu) is the momentum of the internal line from vrtx4 to vrtx2
C k5(mu) is the momentum of the internal line from vrtx3 to vrtx4
C
C Numbering for graphs of type NESTED:
C vrtx1 attaches to the incoming quark line
C vrtx2 attaches to the outgoing quark line
C vrtx3 is the internal vertex attached to a line from vrtx1
C vrtx4 is the other internal vertex
C k0(mu) is the momentum of the quark line entering vrtx1
C k1(mu) is the momentum of the internal line from vrtx1 to vrtx2
C k2(mu) is the momentum of the internal line from vrtx1 to vrtx3
C k3(mu) is the momentum of the internal line from vrtx4 to vrtx2
C k4(mu) ane k5(mu) are the momentum of the internal lines 
C        from vrtx3 to vrtx4. For a quark internal self-energy,
C        4 is the gluon and 5 is the quark line.
C 
C 31 December 2001
C
C For testing purposes only:
C     LOGICAL OVERRIDE,LEFTOVERRIDE
C     COMMON /TESTING/ OVERRIDE,LEFTOVERRIDE
C ---
C
      COMPLEX*16 COMPLEXSQRT
      COMPLEX*16 TK00,TK11,TK22,TK33,TK44
      COMPLEX*16 K00,K11,K22,K33,K44
      COMPLEX*16 TEMP,PREFACTOR
      COMPLEX*16 K0(0:3),K1(0:3),K2(0:3),K3(0:3),K4(0:3),K5(0:3)
      COMPLEX*16 E0,E1,E2,E3,E4
      LOGICAL CUT(1:5)
C
      COMPLEX*16 EA4GK0K1,EA4QK0K1,EA5GK0K3,EA5QK0K4,K0K1,K0K3,K0K4
      COMPLEX*16 TRACEV4G,TRACEV4Q,TRACEV5G,TRACEV5Q,V4GWK0K1,V4GWK1K0
      COMPLEX*16 V4QWK0K1,V4QWK1K0,V5GWK0K3,V5GWK3K0,V5QWK0K4,V5QWK4K0
      COMPLEX*16 EA4GK1(0:3),EA4QK1(0:3),EA5GK3(0:3),EA5QK4(0:3)
      COMPLEX*16 V4GIK1(0:3),V4GK1I(0:3),V4QIK1(0:3),V4QK1I(0:3)
      COMPLEX*16 V5GIK3(0:3),V5GK3I(0:3),V5QIK4(0:3),V5QK4I(0:3)
      COMPLEX*16 A4G(0:3,0:3),A4Q(0:3,0:3),A5G(0:3,0:3),A5Q(0:3,0:3)
      COMPLEX*16 V4G(0:3,0:3),V4Q(0:3,0:3),V5G(0:3,0:3),V5Q(0:3,0:3)
C
      CHARACTER*7 KIND3PT
      LOGICAL OVERLAP,QQGVERTS,TRIPLEGLUE
      LOGICAL NESTED,NESTEDGLUE,NESTEDQUARK,GLUELOOP,QUARKLOOP
      COMPLEX*16 K2PT(0:2,0:3),Q(0:3)
      COMPLEX*16 OMEGASQ,QSQ
      CHARACTER*9 KIND2PT
      LOGICAL CUT2PT(0:3)
      COMPLEX*16 OUTG(0:3,0:3)
      COMPLEX*16 MK1(0:3),TRACEM,DOTQK1,MQK1
      COMPLEX*16 OUTQ(0:3)
      COMPLEX*16 OMEGA1SQ,BAREPROP(0:3,0:3),DM(0:3),QM,DQM
      COMPLEX*16 TRACEBAREPROP
C
      COMPLEX*16 GN(0:3)
      DATA GN /(1.0D0,0.0D0),(0.0D0,0.0D0),
     >           (0.0D0,0.0D0),(0.0D0,0.0D0)/ 
      REAL*8 METRIC(0:3)
      DATA METRIC / 1.0D0,-1.0D0,-1.0D0,-1.0D0 /
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
      REAL*8 CF
      INTEGER MU,NU,ALPHA
      LOGICAL LEFT,RIGHT
C
      COMPLEX*16 K3PT(3,0:3)
      LOGICAL CUT3PT(3)
C
      CF = (NC**2 - 1.0D0)/(2.0D0*NC)
C
C Set logical variables according to what case we have.
C
      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
      ENDIF
C
      IF (OVERLAP) THEN
C
C Short form of momentum variables and rename cut variables
C for overlap graphs.
C
      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)
      ENDDO
      CUT(1) = CUT2PT2(1)
      CUT(2) = CUT2PT2(2)
      CUT(3) = CUT2PT2(3)
      CUT(4) = CUT2PT2(4)
      CUT(5) = CUT2PT2(5)
C
C We have an OVERLAP type graph. We can treat it two different
C ways: either the left=hand three point graph is calculated
C using subroutine VERTEX or else the right-hand three point
C graph is calculated with subroutine VERTEX. We choose according
C to which lines are cut. Generally, we take the "left" choice,
C but if the right-hand loop is virtual, we take the "right" choice.
C
      LEFT = .TRUE.
      RIGHT = .FALSE.
      IF (CUT2PT2(1).AND.CUT2PT2(2)) THEN
        LEFT = .FALSE.
        RIGHT = .TRUE.
      ENDIF
C
C For testing purposes, we include code to override this choice.
C
C     IF (OVERRIDE) THEN
C       LEFT = LEFTOVERRIDE
C       RIGHT = .NOT.LEFT
C     ENDIF
C
C Calculate according to case, with logic
C     IF (QQGVERTS.AND.RIGHT) THEN
C     ELSE IF (QQGVERTS.AND.LEFT) THEN
C     ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN
C     ELSE IF (TRIPLEGLUE.AND.LEFT) THEN
C     ELSE <error>
C     ENDIF
C
      IF (QQGVERTS.AND.RIGHT) THEN
C
C---
      TK00 = 0.0D0
      DO MU = 1,3
        TK00 = TK00 - K0(MU)**2
      ENDDO
      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
      ENDDO
      K11 = E1**2 + TK11
      K22 = E2**2 + TK22
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K4(MU)
        K3PT(2,MU) = -K5(MU)
        K3PT(3,MU) = K3(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      DO MU = 0,3
        V4QIK1(MU) = 0.0D0
        V4QK1I(MU) = 0.0D0
      ENDDO
      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)
      ENDDO
      ENDDO
      K0K1 = 0.0D0
      DO MU = 0,3
        K0K1 = K0K1 + K0(MU)*K1(MU)*METRIC(MU)
      ENDDO
      CALL EPSILONT2(A4Q,K0,K1,EA4QK0K1)
      CALL EPSILONT1(A4Q,K1,EA4QK1)
      DO NU = 0,3
C
      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
C
      ENDDO
C
      ELSE IF (QQGVERTS.AND.LEFT) THEN
C
C---
      TK00 = 0.0D0
      DO MU = 1,3
        TK00 = TK00 - K0(MU)**2
      ENDDO
      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
      ENDDO
      K33 = E3**2 + TK33
      K44 = E4**2 + TK44
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K5(MU)
        K3PT(2,MU) = -K1(MU)
        K3PT(3,MU) = K2(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      DO MU = 0,3
        V5QIK4(MU) = 0.0D0
        V5QK4I(MU) = 0.0D0
      ENDDO
      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)
      ENDDO
      ENDDO
      K0K4 = 0.0D0
      DO MU = 0,3
        K0K4 = K0K4 + K0(MU)*K4(MU)*METRIC(MU)
      ENDDO
      CALL EPSILONT2(A5Q,K0,K4,EA5QK0K4)
      CALL EPSILONT1(A5Q,K4,EA5QK4)
      DO NU = 0,3
C
      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
C
      ENDDO
C
      ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN
C
C---
      TK00 = 0.0D0
      DO MU = 1,3
        TK00 = TK00 - K0(MU)**2
      ENDDO
      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
      ENDDO
      K11 = E1**2 + TK11
      K22 = E2**2 + TK22
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K4(MU)
        K3PT(2,MU) = -K5(MU)
        K3PT(3,MU) = K3(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      DO MU = 0,3
        V4GIK1(MU) = 0.0D0
        V4GK1I(MU) = 0.0D0
      ENDDO
      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)
      ENDDO
      ENDDO
      K0K1 = 0.0D0
      DO MU = 0,3
        K0K1 = K0K1 + K0(MU)*K1(MU)*METRIC(MU)
      ENDDO
      CALL EPSILONT2(A4G,K0,K1,EA4GK0K1)
      CALL EPSILONT1(A4G,K1,EA4GK1)
      DO NU = 0,3
C
      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
C
      ENDDO
C
      ELSE IF (TRIPLEGLUE.AND.LEFT) THEN
C
C---
      TK00 = 0.0D0
      DO MU = 1,3
        TK00 = TK00 - K0(MU)**2
      ENDDO
      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
      ENDDO
      K33 = E3**2 + TK33
      K44 = E4**2 + TK44
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = K5(MU)
        K3PT(2,MU) = -K2(MU)
        K3PT(3,MU) = K1(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      DO MU = 0,3
        V5GIK3(MU) = 0.0D0
        V5GK3I(MU) = 0.0D0
      ENDDO
      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)
      ENDDO
      ENDDO
      K0K3 = 0.0D0
      DO MU = 0,3
        K0K3 = K0K3 + K0(MU)*K3(MU)*METRIC(MU)
      ENDDO
      CALL EPSILONT2(A5G,K0,K3,EA5GK0K3)
      CALL EPSILONT1(A5G,K3,EA5GK3)
      DO NU = 0,3
C
      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
C
      ENDDO
      ELSE
        WRITE(*,*)'Not programmed for that'
        STOP
      ENDIF
C
C-------------
C
C Alternative for IF (OVERLAP) THEN.
C
      ELSE IF (NESTED) THEN      
C
C We have a nested graph.
C
      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)
      ENDDO
      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
C
      CUT2PT(0) = CUT2PT2(2)
      CUT2PT(1) = CUT2PT2(4)
      CUT2PT(2) = CUT2PT2(5)
      CUT2PT(3) = CUT2PT2(3)
C
C We need the factor equal to 1/k^2 for an uncut propagator
C and 1/ 2|\vec k| for a cut propagator. BUT line 1 is always
C cut, propagator 0 never cut, and the one-loop two point function 
C that is nested inside has the factor for propagators 2,3,4,5.
C   
      PREFACTOR = CF/(QSQ**2*2.0D0*COMPLEXSQRT(OMEGA1SQ))
C
      IF (NESTEDGLUE) THEN
C
C Our nested graph has a gluon self-energy insertion.
C Calculate OUTG according to what kind of self-energy insertion it is.
C
      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)
      ENDIF
C
C Now comlete the calculation for a gluon self-energy insertion.
C
      DO ALPHA = 0,3
        TEMP = 0.0D0
        DO NU = 0,3
          TEMP = TEMP + OUTG(ALPHA,NU)*K1(NU)*METRIC(NU)
        ENDDO
        MK1(ALPHA) = TEMP
      ENDDO
C
      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)
      ENDDO
C
      MQK1 = 0.0D0
      DO MU = 0,3
      DO NU = 0,3
        MQK1 = MQK1 + OUTG(MU,NU)*Q(MU)*K1(NU)*METRIC(MU)*METRIC(NU) 
      ENDDO
      ENDDO
C
      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
      ENDDO
C
C Alternative for IF (NESTEDGLUE) THEN
C
      ELSE IF (NESTEDQUARK) THEN
C
C Our nested graph has a quark self-energy insertion.
C Calculate OUTQ.
C
      CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,OUTQ)
C
C Now comlete the calculation for a quark self-energy insertion.
C
C The gluon propagator in *FEYNMAN* gauge for an on-shell gluon
C with three-momentum K1(mu).
C
      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
      ENDDO
      ENDDO
      TRACEBAREPROP = -4.0D0
C
      DO ALPHA = 0,3
        DM(ALPHA) = 0.0D0
        DO NU = 0,3
         DM(ALPHA) = DM(ALPHA) + BAREPROP(ALPHA,NU)*OUTQ(NU)*METRIC(NU)
        ENDDO
      ENDDO
C
      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)
      ENDDO
      ENDDO
C
      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
      ENDDO
C
C Close IF (NESTEDGLUE) THEN ... ELSEIF (NESTEDQUARK) THEN
C
      ELSE
        WRITE(NOUT,*)'Oops, something must have gone wrong.'
        STOP
      ENDIF
C
C Close  IF (OVERLAP) THEN ... ELSE IF (NESTED) THEN      
C
      ELSE
        WRITE(NOUT,*)'Oops, something has gone wrong.'
        STOP
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C                 Feynman integrand in Coulomb gauge                   C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      COMPLEX*16 FUNCTION FEYNMAN(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
C
C In:
      INTEGER SIZE
      PARAMETER (SIZE = 3)
      INTEGER GRAPHNUMBER
      COMPLEX*16 KC(0:3*SIZE-1,0:3)
      LOGICAL CUT(3*SIZE-1)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C
C Feynman integrand function for graph GRAPHNUMBER
C with complex momenta KC and cut specified by CUT.
C Early version: 17 July 1994.
C This version written by Mathematica code of 4 January 2002 on
C 4 Jan 2002.
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
C
      REAL*8 METRIC(0:3)
      DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/
      COMPLEX*16 GN(0:3)
      DATA GN /+1.0D0,0.0D0,0.0D0,0.0D0/
C
      REAL*8 CF
      COMPLEX*16 COMPLEXSQRT
      INTEGER MU,NU,TAU
      COMPLEX*16 X(256)
      COMPLEX*16 K1(0:3),K2(0:3),K3(0:3),K4(0:3)
      COMPLEX*16 K5(0:3),K6(0:3),K7(0:3),K8(0:3)
      COMPLEX*16 E1,E2,E3,E4,E5,E6,E7,E8
      COMPLEX*16 K11,K22,K33,K44,K55,K66,K77,K88
      COMPLEX*16 TK11,TK22,TK33,TK44,TK55,TK66,TK77,TK88
      COMPLEX*16 PREFACTOR
      CHARACTER*13 KIND2PT2
      COMPLEX*16 K2PT2(0:5,0:3)
      LOGICAL CUT2PT2(1:5)
      CHARACTER*9 KIND2PT
      COMPLEX*16 K2PT(0:2,0:3)
      LOGICAL CUT2PT(0:3)
      CHARACTER*7 KIND3PT
      COMPLEX*16 K3PT(3,0:3)
      LOGICAL CUT3PT(3)
C
      COMPLEX*16 A1QDA4Q,A1QIK6A4QIK7,A1QIK7A4QIK6,EA1QK3Q47
      COMPLEX*16 EA1QZV4QK6K7,EA2QK3Q67,EA3QK1Q26,EA4QK1Q86
      COMPLEX*16 EA4QZV1QK6K7,EA7AGNIK1K2K4,EA7AGNIK2K3K4,EA7AK1IK2K3K4
      COMPLEX*16 EA7AK1K2,EA7AK1K3,EA7AK1K4,EA7AK2IK1K3K4,EA7AK2K3
      COMPLEX*16 EA7AK2K4,EA7AK3IK1K2K4,EA7AK3K4,EA7AK4IK1K2K3
      COMPLEX*16 EA7AK5IGNK1K2,EA7AK5IGNK1K3,EA7AK5IGNK1K4
      COMPLEX*16 EA7AK5IGNK2K3,EA7AK5IGNK2K4,EA7AK5IGNK3K4
      COMPLEX*16 EA7AK5IK1K2K3,EA7AK5IK1K2K4,EA7AK5IK1K3K4
      COMPLEX*16 EA7AK5IK2K3K4,EA8AGNIK1K2K4,EA8AGNIK2K3K4
      COMPLEX*16 EA8AK1IK2K3K4,EA8AK1K2,EA8AK1K3,EA8AK1K4,EA8AK2IK1K3K4
      COMPLEX*16 EA8AK2K3,EA8AK2K4,EA8AK3IK1K2K4,EA8AK3K4,EA8AK4IK1K2K3
      COMPLEX*16 EA8AK5IGNK1K2,EA8AK5IGNK1K3,EA8AK5IGNK1K4
      COMPLEX*16 EA8AK5IGNK2K3,EA8AK5IGNK2K4,EA8AK5IGNK3K4
      COMPLEX*16 EA8AK5IK1K2K3,EA8AK5IK1K2K4,EA8AK5IK1K3K4
      COMPLEX*16 EA8AK5IK2K3K4,G7AWK1K2,G7AWK1K3,G7AWK2K4,G7AWK3K4,K1K2
      COMPLEX*16 K1K3,K1K4,K1K6,K1K7,K1Q24,K1Q26,K1Q36,K1Q84,K1Q86
      COMPLEX*16 K1QQNB45,K1QQNB46,K1QQNG45,K1QQNG46,K1QQNQ45,K1QQNQ46
      COMPLEX*16 K1QQOG57,K1QQOG75,K1QQOQ57,K1QQOQ64,K2K3,K2K4,K2K6
      COMPLEX*16 K2K7,K2Q24,K2Q36,K2Q84,K2Q86,K3K4,K3K6,K3K7,K3Q47
      COMPLEX*16 K3Q67,K4K6,K4K7,K6K7,Q15Q47,Q24Q86,Q36Q84,TRACEG7A
      COMPLEX*16 TRACEV1Q,TRACEV2Q,TRACEV3Q,TRACEV4Q,TRACEV7A,TRACEV8A
      COMPLEX*16 V1QDV4Q,V1QIK6V4QIK7,V1QIK7V4QIK6,V1QWK3Q47,V1QWQ47K3
      COMPLEX*16 V2QWK3Q67,V2QWQ67K3,V3QWK1Q26,V3QWQ26K1,V4QWK1Q86
      COMPLEX*16 V4QWQ86K1,V7AWGNK1,V7AWGNK2,V7AWGNK3,V7AWGNK4,V7AWK1K2
      COMPLEX*16 V7AWK1K3,V7AWK1K4,V7AWK2K1,V7AWK2K3,V7AWK2K4,V7AWK3K1
      COMPLEX*16 V7AWK3K2,V7AWK3K4,V7AWK4K1,V7AWK4K2,V7AWK4K3,V7AWK5GN
      COMPLEX*16 V7AWK5K1,V7AWK5K2,V7AWK5K3,V7AWK5K4,V8AWGNK1,V8AWGNK2
      COMPLEX*16 V8AWGNK3,V8AWGNK4,V8AWK1K2,V8AWK1K3,V8AWK1K4,V8AWK2K1
      COMPLEX*16 V8AWK2K3,V8AWK2K4,V8AWK3K1,V8AWK3K2,V8AWK3K4,V8AWK4K1
      COMPLEX*16 V8AWK4K2,V8AWK4K3,V8AWK5GN,V8AWK5K1,V8AWK5K2,V8AWK5K3
      COMPLEX*16 V8AWK5K4,A1QIK6(0:3),A1QIK7(0:3),A4QIK6(0:3)
      COMPLEX*16 A4QIK7(0:3),A7AGNI(0:3),A7AK1I(0:3),A7AK2I(0:3)
      COMPLEX*16 A7AK3I(0:3),A7AK4I(0:3),A7AK5I(0:3),A8AGNI(0:3)
      COMPLEX*16 A8AK1I(0:3),A8AK2I(0:3),A8AK3I(0:3),A8AK4I(0:3)
      COMPLEX*16 A8AK5I(0:3),Q15(0:3),Q24(0:3),Q26(0:3),Q36(0:3)
      COMPLEX*16 Q47(0:3),Q67(0:3),Q84(0:3),Q86(0:3),QQNB45(0:3)
      COMPLEX*16 QQNB46(0:3),QQNG45(0:3),QQNG46(0:3),QQNQ45(0:3)
      COMPLEX*16 QQNQ46(0:3),QQOG57(0:3),QQOG75(0:3),QQOQ57(0:3)
      COMPLEX*16 QQOQ64(0:3),V1QIK6(0:3),V1QIK7(0:3),V4QIK6(0:3)
      COMPLEX*16 V4QIK7(0:3),A1Q(0:3,0:3),A1QZV4Q(0:3,0:3),A2Q(0:3,0:3)
      COMPLEX*16 A3Q(0:3,0:3),A4Q(0:3,0:3),A4QZV1Q(0:3,0:3)
      COMPLEX*16 A7A(0:3,0:3),A8A(0:3,0:3),G7A(0:3,0:3),V1Q(0:3,0:3)
      COMPLEX*16 V2Q(0:3,0:3),V3Q(0:3,0:3),V4Q(0:3,0:3),V7A(0:3,0:3)
      COMPLEX*16 V8A(0:3,0:3)
C
      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)
      ENDDO
      CF = (NC**2 - 1.0D0)/2.0D0/NC
      FEYNMAN = 0.0D0
C
C------
C
      IF (GRAPHNUMBER .EQ. 1) THEN
C
      PREFACTOR = 1.0D0
      E1 = K1(0)
      TK11 = 0.0D0
      DO MU = 1,3
        TK11 = TK11 - K1(MU)**2
      ENDDO
      K11 = E1**2 + TK11
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      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)
      ENDDO
      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)
      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)
      ENDDO
      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)
      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)
      ENDDO
      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)
      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)
      ENDDO
      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)
      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)
      ENDDO
      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)
      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)
      ENDDO
      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)
      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)
      ENDDO
      FEYNMAN = -8*(K1QQNB45 - K1QQNB46 + K1QQNG45 - K1QQNG46
     > + K1QQNQ45 - K1QQNQ46)*NC
      FEYNMAN = FEYNMAN*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 2) THEN
C
      PREFACTOR = 1.0D0
      E1 = K1(0)
      TK11 = 0.0D0
      DO MU = 1,3
        TK11 = TK11 - K1(MU)**2
      ENDDO
      K11 = E1**2 + TK11
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      DO MU = 0,3
        K2PT(0,MU) = K2(MU)
        K2PT(1,MU) = K4(MU)
        K2PT(2,MU) = K5(MU)
      ENDDO
      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) = K3(MU)
        K2PT(1,MU) = K6(MU)
        K2PT(2,MU) = K7(MU)
      ENDDO
      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)
      ENDDO
      CUT2PT(0) = CUT(8)
      CUT2PT(1) = CUT(4)
      CUT2PT(2) = CUT(5)
      CUT2PT(3) = CUT(2)
      CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q84)
      DO MU = 0,3
        K2PT(0,MU) = K8(MU)
        K2PT(1,MU) = -K6(MU)
        K2PT(2,MU) = -K7(MU)
      ENDDO
      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
      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)
      ENDDO
      FEYNMAN = 8*NC*(K1Q86*K2Q24 + K1Q84*K2Q36 + K1Q36*K2Q84
     > + K1Q24*K2Q86 - K1K2*Q24Q86 - K1K2*Q36Q84)
      FEYNMAN = FEYNMAN*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 3) THEN
C
      PREFACTOR = 1.0D0
      E1 = K1(0)
      TK11 = 0.0D0
      DO MU = 1,3
        TK11 = TK11 - K1(MU)**2
      ENDDO
      K11 = E1**2 + TK11
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      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)
      ENDDO
      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)
      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)
      ENDDO
      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)
      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)
      ENDDO
      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)
      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)
      ENDDO
      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)
      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)
      ENDDO
      FEYNMAN = 8*(K1QQOG57 - K1QQOG75 + K1QQOQ57 - K1QQOQ64)*NC
      FEYNMAN = FEYNMAN*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 4) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      DO MU = 0,3
        K2PT(0,MU) = K5(MU)
        K2PT(1,MU) = K7(MU)
        K2PT(2,MU) = K8(MU)
      ENDDO
      CUT2PT(0) = CUT(5)
      CUT2PT(1) = CUT(7)
      CUT2PT(2) = CUT(8)
      CUT2PT(3) = CUT(6)
      KIND2PT = 'BOTHLOOPS'
      CALL TWOPOINTG(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,G7A)
      TRACEG7A = 0.0D0
      DO MU = 0,3
        TRACEG7A = TRACEG7A + G7A(MU,MU)*METRIC(MU)
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      FEYNMAN = -8*CF*NC*(2*G7AWK3K4*K1K2 - 2*G7AWK2K4*K1K3
     > - 2*G7AWK1K3*K2K4 + 2*G7AWK1K2*K3K4 + K1K4*K2K3*TRACEG7A
     > + K1K3*K2K4*TRACEG7A - K1K2*K3K4*TRACEG7A)
      FEYNMAN = FEYNMAN*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 5) THEN
C
      PREFACTOR = 1.0D0
      E3 = K3(0)
      TK33 = 0.0D0
      DO MU = 1,3
        TK33 = TK33 - K3(MU)**2
      ENDDO
      K33 = E3**2 + TK33
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K1(MU)
        K3PT(2,MU) = K2(MU)
        K3PT(3,MU) = -K5(MU)
      ENDDO
      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) = -K2(MU)
        K3PT(2,MU) = K1(MU)
        K3PT(3,MU) = K5(MU)
      ENDDO
      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) = K4(MU)
        K2PT(1,MU) = K7(MU)
        K2PT(2,MU) = K8(MU)
      ENDDO
      CUT2PT(0) = CUT(4)
      CUT2PT(1) = CUT(7)
      CUT2PT(2) = CUT(8)
      CUT2PT(3) = CUT(6)
      CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q47)
      DO MU = 0,3
        K2PT(0,MU) = K6(MU)
        K2PT(1,MU) = -K7(MU)
        K2PT(2,MU) = -K8(MU)
      ENDDO
      CUT2PT(0) = CUT(6)
      CUT2PT(1) = CUT(7)
      CUT2PT(2) = CUT(8)
      CUT2PT(3) = CUT(4)
      CALL TWOPOINTQ(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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      CALL EPSILONT2(A1Q,K3,Q47,EA1QK3Q47)
      CALL EPSILONT2(A2Q,K3,Q67,EA2QK3Q67)
      FEYNMAN = -4*NC*(EA1QK3Q47 + EA2QK3Q67 - K3Q47*TRACEV1Q
     > + K3Q67*TRACEV2Q + V1QWK3Q47 + V1QWQ47K3 - V2QWK3Q67 - V2QWQ67K3)
      FEYNMAN = FEYNMAN*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 6) THEN
C
      PREFACTOR = 1.0D0
      E1 = K1(0)
      TK11 = 0.0D0
      DO MU = 1,3
        TK11 = TK11 - K1(MU)**2
      ENDDO
      K11 = E1**2 + TK11
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K3(MU)
        K3PT(2,MU) = K4(MU)
        K3PT(3,MU) = -K5(MU)
      ENDDO
      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
        K3PT(1,MU) = -K4(MU)
        K3PT(2,MU) = K3(MU)
        K3PT(3,MU) = K5(MU)
      ENDDO
      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) = K2(MU)
        K2PT(1,MU) = K6(MU)
        K2PT(2,MU) = K7(MU)
      ENDDO
      CUT2PT(0) = CUT(2)
      CUT2PT(1) = CUT(6)
      CUT2PT(2) = CUT(7)
      CUT2PT(3) = CUT(8)
      CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q26)
      DO MU = 0,3
        K2PT(0,MU) = K8(MU)
        K2PT(1,MU) = -K6(MU)
        K2PT(2,MU) = -K7(MU)
      ENDDO
      CUT2PT(0) = CUT(8)
      CUT2PT(1) = CUT(6)
      CUT2PT(2) = CUT(7)
      CUT2PT(3) = CUT(2)
      CALL TWOPOINTQ(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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      CALL EPSILONT2(A3Q,K1,Q26,EA3QK1Q26)
      CALL EPSILONT2(A4Q,K1,Q86,EA4QK1Q86)
      FEYNMAN = -4*NC*(EA3QK1Q26 + EA4QK1Q86 - K1Q26*TRACEV3Q
     > + K1Q86*TRACEV4Q + V3QWK1Q26 + V3QWQ26K1 - V4QWK1Q86 - V4QWQ86K1)
      FEYNMAN = FEYNMAN*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 7) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      IF (CUT(5)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55)
      ELSE
        PREFACTOR = PREFACTOR/K55
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = K7(MU)
        K3PT(2,MU) = -K8(MU)
        K3PT(3,MU) = -K6(MU)
      ENDDO
      CUT3PT(1) = CUT(7)
      CUT3PT(2) = CUT(8)
      CUT3PT(3) = CUT(6)
      KIND3PT = 'QQG/ALL'
      CALL VERTEX(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)
      ENDDO
      CUT3PT(1) = CUT(8)
      CUT3PT(2) = CUT(7)
      CUT3PT(3) = CUT(6)
      KIND3PT = 'QQG/ALL'
      CALL VERTEX(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)
      ENDDO
      V7AWGNK1 = 0.0D0
      V7AWGNK2 = 0.0D0
      V7AWGNK3 = 0.0D0
      V7AWGNK4 = 0.0D0
      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
      V7AWK5GN = 0.0D0
      V7AWK5K1 = 0.0D0
      V7AWK5K2 = 0.0D0
      V7AWK5K3 = 0.0D0
      V7AWK5K4 = 0.0D0
      V8AWGNK1 = 0.0D0
      V8AWGNK2 = 0.0D0
      V8AWGNK3 = 0.0D0
      V8AWGNK4 = 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
      V8AWK5GN = 0.0D0
      V8AWK5K1 = 0.0D0
      V8AWK5K2 = 0.0D0
      V8AWK5K3 = 0.0D0
      V8AWK5K4 = 0.0D0
      DO MU = 0,3
      DO NU = 0,3
        V7AWGNK1 = V7AWGNK1
     >         + V7A(MU,NU)*GN(MU)*K1(NU)*METRIC(MU)*METRIC(NU)
        V7AWGNK2 = V7AWGNK2
     >         + V7A(MU,NU)*GN(MU)*K2(NU)*METRIC(MU)*METRIC(NU)
        V7AWGNK3 = V7AWGNK3
     >         + V7A(MU,NU)*GN(MU)*K3(NU)*METRIC(MU)*METRIC(NU)
        V7AWGNK4 = V7AWGNK4
     >         + V7A(MU,NU)*GN(MU)*K4(NU)*METRIC(MU)*METRIC(NU)
        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)
        V7AWK5GN = V7AWK5GN
     >         + V7A(MU,NU)*K5(MU)*GN(NU)*METRIC(MU)*METRIC(NU)
        V7AWK5K1 = V7AWK5K1
     >         + V7A(MU,NU)*K5(MU)*K1(NU)*METRIC(MU)*METRIC(NU)
        V7AWK5K2 = V7AWK5K2
     >         + V7A(MU,NU)*K5(MU)*K2(NU)*METRIC(MU)*METRIC(NU)
        V7AWK5K3 = V7AWK5K3
     >         + V7A(MU,NU)*K5(MU)*K3(NU)*METRIC(MU)*METRIC(NU)
        V7AWK5K4 = V7AWK5K4
     >         + V7A(MU,NU)*K5(MU)*K4(NU)*METRIC(MU)*METRIC(NU)
        V8AWGNK1 = V8AWGNK1
     >         + V8A(MU,NU)*GN(MU)*K1(NU)*METRIC(MU)*METRIC(NU)
        V8AWGNK2 = V8AWGNK2
     >         + V8A(MU,NU)*GN(MU)*K2(NU)*METRIC(MU)*METRIC(NU)
        V8AWGNK3 = V8AWGNK3
     >         + V8A(MU,NU)*GN(MU)*K3(NU)*METRIC(MU)*METRIC(NU)
        V8AWGNK4 = V8AWGNK4
     >         + V8A(MU,NU)*GN(MU)*K4(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)
        V8AWK5GN = V8AWK5GN
     >         + V8A(MU,NU)*K5(MU)*GN(NU)*METRIC(MU)*METRIC(NU)
        V8AWK5K1 = V8AWK5K1
     >         + V8A(MU,NU)*K5(MU)*K1(NU)*METRIC(MU)*METRIC(NU)
        V8AWK5K2 = V8AWK5K2
     >         + V8A(MU,NU)*K5(MU)*K2(NU)*METRIC(MU)*METRIC(NU)
        V8AWK5K3 = V8AWK5K3
     >         + V8A(MU,NU)*K5(MU)*K3(NU)*METRIC(MU)*METRIC(NU)
        V8AWK5K4 = V8AWK5K4
     >         + V8A(MU,NU)*K5(MU)*K4(NU)*METRIC(MU)*METRIC(NU)
      ENDDO
      ENDDO
      DO MU = 0,3
        A7AGNI(MU) = 0.0D0
        A7AK1I(MU) = 0.0D0
        A7AK2I(MU) = 0.0D0
        A7AK3I(MU) = 0.0D0
        A7AK4I(MU) = 0.0D0
        A7AK5I(MU) = 0.0D0
        A8AGNI(MU) = 0.0D0
        A8AK1I(MU) = 0.0D0
        A8AK2I(MU) = 0.0D0
        A8AK3I(MU) = 0.0D0
        A8AK4I(MU) = 0.0D0
        A8AK5I(MU) = 0.0D0
      ENDDO
      DO MU = 0,3
      DO NU = 0,3
        A7AGNI(MU) = A7AGNI(MU) + A7A(NU,MU)*GN(NU)*METRIC(NU)
        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)
        A7AK5I(MU) = A7AK5I(MU) + A7A(NU,MU)*K5(NU)*METRIC(NU)
        A8AGNI(MU) = A8AGNI(MU) + A8A(NU,MU)*GN(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)
        A8AK5I(MU) = A8AK5I(MU) + A8A(NU,MU)*K5(NU)*METRIC(NU)
      ENDDO
      ENDDO
      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)
      ENDDO
      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(A7AGNI,K1,K2,K4,EA7AGNIK1K2K4)
      CALL EPSILON4(A7AGNI,K2,K3,K4,EA7AGNIK2K3K4)
      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(A7AK5I,GN,K1,K2,EA7AK5IGNK1K2)
      CALL EPSILON4(A7AK5I,GN,K1,K3,EA7AK5IGNK1K3)
      CALL EPSILON4(A7AK5I,GN,K1,K4,EA7AK5IGNK1K4)
      CALL EPSILON4(A7AK5I,GN,K2,K3,EA7AK5IGNK2K3)
      CALL EPSILON4(A7AK5I,GN,K2,K4,EA7AK5IGNK2K4)
      CALL EPSILON4(A7AK5I,GN,K3,K4,EA7AK5IGNK3K4)
      CALL EPSILON4(A7AK5I,K1,K2,K3,EA7AK5IK1K2K3)
      CALL EPSILON4(A7AK5I,K1,K2,K4,EA7AK5IK1K2K4)
      CALL EPSILON4(A7AK5I,K1,K3,K4,EA7AK5IK1K3K4)
      CALL EPSILON4(A7AK5I,K2,K3,K4,EA7AK5IK2K3K4)
      CALL EPSILON4(A8AGNI,K1,K2,K4,EA8AGNIK1K2K4)
      CALL EPSILON4(A8AGNI,K2,K3,K4,EA8AGNIK2K3K4)
      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)
      CALL EPSILON4(A8AK5I,GN,K1,K2,EA8AK5IGNK1K2)
      CALL EPSILON4(A8AK5I,GN,K1,K3,EA8AK5IGNK1K3)
      CALL EPSILON4(A8AK5I,GN,K1,K4,EA8AK5IGNK1K4)
      CALL EPSILON4(A8AK5I,GN,K2,K3,EA8AK5IGNK2K3)
      CALL EPSILON4(A8AK5I,GN,K2,K4,EA8AK5IGNK2K4)
      CALL EPSILON4(A8AK5I,GN,K3,K4,EA8AK5IGNK3K4)
      CALL EPSILON4(A8AK5I,K1,K2,K3,EA8AK5IK1K2K3)
      CALL EPSILON4(A8AK5I,K1,K2,K4,EA8AK5IK1K2K4)
      CALL EPSILON4(A8AK5I,K1,K3,K4,EA8AK5IK1K3K4)
      CALL EPSILON4(A8AK5I,K2,K3,K4,EA8AK5IK2K3K4)
      X(1) = K11*(-EA7AK5IK2K3K4 + EA8AK5IK2K3K4 + K3K4*(-V7AWK5K2
     > - V8AWK5K2) + K2K4*(V7AWK5K3 + V8AWK5K3) + K2K3*(-V7AWK5K4
     > - V8AWK5K4))
      X(2) = EA7AK5IK1K2K4 - EA8AK5IK1K2K4 + K2K4*(V7AWK5K1 + V8AWK5K1)
     > + K1K4*(-V7AWK5K2 - V8AWK5K2) + K1K2*(-V7AWK5K4 - V8AWK5K4)
      X(3) = X(1) + K33*X(2)
      X(4) = EA7AK1IK2K3K4 + EA7AK2IK1K3K4 - EA7AK3IK1K2K4
     > - EA7AK4IK1K2K3 - EA8AK1IK2K3K4 - EA8AK2IK1K3K4 + EA8AK3IK1K2K4
     > + EA8AK4IK1K2K3
      X(5) = EA7AK3K4 - EA8AK3K4 + V7AWK3K4 + V7AWK4K3 + V8AWK3K4
     > + V8AWK4K3
      X(6) = X(4) + K1K2*X(5)
      X(7) = -EA7AK2K4 + EA8AK2K4 - V7AWK2K4 - V7AWK4K2 - V8AWK2K4
     > - V8AWK4K2
      X(8) = X(6) + K1K3*X(7)
      X(9) = -EA7AK2K3 + EA8AK2K3 - V7AWK2K3 + V7AWK3K2 - V8AWK2K3
     > + V8AWK3K2
      X(10) = X(8) + K1K4*X(9)
      X(11) = -EA7AK1K4 + EA8AK1K4 + K1K4*(TRACEV7A + TRACEV8A)
     > + V7AWK1K4 - V7AWK4K1 + V8AWK1K4 - V8AWK4K1
      X(12) = X(10) + K2K3*X(11)
      X(13) = EA7AK1K3 - EA8AK1K3 + K1K3*(TRACEV7A + TRACEV8A)
     > - V7AWK1K3 - V7AWK3K1 - V8AWK1K3 - V8AWK3K1
      X(14) = X(12) + K2K4*X(13)
      X(15) = -EA7AK1K2 + EA8AK1K2 + K1K2*(-TRACEV7A - TRACEV8A)
     > + V7AWK1K2 + V7AWK2K1 + V8AWK1K2 + V8AWK2K1
      X(16) = X(14) + K3K4*X(15)
      X(17) = X(3) + TK55*X(16)
      X(18) = E4*(-EA7AK5IK1K2K3 + EA8AK5IK1K2K3) + E3*(-EA7AK5IK1K2K4
     > + EA8AK5IK1K2K4) + E2*(EA7AK5IK1K3K4 - EA8AK5IK1K3K4) + E1
     >*(EA7AK5IK2K3K4 - EA8AK5IK2K3K4)
      X(19) = EA7AGNIK2K3K4 - EA8AGNIK2K3K4
      X(20) = X(18) + K11*X(19)
      X(21) = -EA7AGNIK1K2K4 + EA8AGNIK1K2K4
      X(22) = X(20) + K33*X(21)
      X(23) = EA7AK5IGNK2K4 - EA8AK5IGNK2K4 + E4*(-V7AWK5K2 - V8AWK5K2)
     > + E2*(-V7AWK5K4 - V8AWK5K4)
      X(24) = X(22) + K1K3*X(23)
      X(25) = -EA7AK5IGNK3K4 + EA8AK5IGNK3K4 + K33*(V7AWGNK4
     > + V8AWGNK4) + E4*(V7AWK5K3 + V8AWK5K3) + E3*(V7AWK5K4 + V8AWK5K4)
      X(26) = X(24) + K1K2*X(25)
      X(27) = EA7AK5IGNK2K3 - EA8AK5IGNK2K3 + K33*(V7AWGNK2 + V8AWGNK2)
     > + E3*(V7AWK5K2 + V8AWK5K2) + E2*(-V7AWK5K3 - V8AWK5K3)
      X(28) = X(26) + K1K4*X(27)
      X(29) = EA7AK5IGNK1K4 - EA8AK5IGNK1K4 + K11*(V7AWGNK4 + V8AWGNK4)
     > + E4*(-V7AWK5K1 - V8AWK5K1) + E1*(V7AWK5K4 + V8AWK5K4)
      X(30) = V7AWK5GN + V8AWK5GN
      X(31) = X(29) + K1K4*X(30)
      X(32) = X(28) + K2K3*X(31)
      X(33) = EA7AK5IGNK1K2 - EA8AK5IGNK1K2 + K11*(V7AWGNK2 + V8AWGNK2)
     > + E2*(V7AWK5K1 + V8AWK5K1) + E1*(V7AWK5K2 + V8AWK5K2)
      X(34) = -V7AWK5GN - V8AWK5GN
      X(35) = X(33) + K1K2*X(34)
      X(36) = X(32) + K3K4*X(35)
      X(37) = -EA7AK5IGNK1K3 + EA8AK5IGNK1K3 + K11*(-V7AWGNK3
     > - V8AWGNK3) + E3*(-V7AWK5K1 - V8AWK5K1) + E1*(-V7AWK5K3
     > - V8AWK5K3)
      X(38) = V7AWK5GN + V8AWK5GN
      X(39) = X(37) + K1K3*X(38)
      X(40) = -V7AWGNK1 - V8AWGNK1
      X(41) = X(39) + K33*X(40)
      X(42) = X(36) + K2K4*X(41)
      X(43) = X(17) + E5*X(42)
      FEYNMAN = (8*CF*NC*X(43))/TK55
      FEYNMAN = FEYNMAN*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 8) THEN
C
      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
      ENDDO
      K66 = E6**2 + TK66
      K77 = E7**2 + TK77
      IF (CUT(6)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK66)
      ELSE
        PREFACTOR = PREFACTOR/K66
      ENDIF
      IF (CUT(7)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK77)
      ELSE
        PREFACTOR = PREFACTOR/K77
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K1(MU)
        K3PT(2,MU) = K2(MU)
        K3PT(3,MU) = -K5(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ENDDO
      DO MU = 0,3
      DO NU = 0,3
        A1QZV4Q(MU,NU) = 0.0D0
        A4QZV1Q(MU,NU) = 0.0D0
      ENDDO
      ENDDO
      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)
      ENDDO
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      ELSE IF (GRAPHNUMBER .EQ. 9) THEN
C
      PREFACTOR = 1.0D0
      DO MU = 0,3
        K2PT(0,MU) = K1(MU)
        K2PT(1,MU) = K5(MU)
        K2PT(2,MU) = K6(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      FEYNMAN = -8*NC*Q15Q47
      FEYNMAN = FEYNMAN*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 10) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      IF (CUT(5)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55)
      ELSE
        PREFACTOR = PREFACTOR/K55
      ENDIF
      IF (CUT(6)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK66)
      ELSE
        PREFACTOR = PREFACTOR/K66
      ENDIF
      IF (CUT(7)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK77)
      ELSE
        PREFACTOR = PREFACTOR/K77
      ENDIF
      IF (CUT(8)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK88)
      ELSE
        PREFACTOR = PREFACTOR/K88
      ENDIF
      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)
      ENDDO
      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
C
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C          Feynman integrand in Coulomb gauge, BORN level              C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      COMPLEX*16 FUNCTION FEYNMAN0(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG)
C
C In:
      INTEGER SIZE
      PARAMETER (SIZE = 3)
      INTEGER GRAPHNUMBER
      COMPLEX*16 KC(0:3*SIZE-1,0:3)
      LOGICAL CUT(3*SIZE-1)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C
C Feynman integrand function for graph GRAPHNUMBER
C with complex momenta KC and cut specified by CUT.
C Early version: 17 July 1994.
C This version written by Mathematica code of 4 January 2002 on
C 7 Feb 2002.
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
C
      REAL*8 METRIC(0:3)
      DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/
      REAL*8 GN(0:3)
      DATA GN /+1.0D0,0.0D0,0.0D0,0.0D0/
C
      REAL*8 CF
      COMPLEX*16 COMPLEXSQRT
      INTEGER MU
      COMPLEX*16 X(256)
      COMPLEX*16 K1(0:3),K2(0:3),K3(0:3),K4(0:3),K5(0:3)
      COMPLEX*16 E1,E2,E3,E4,E5
      COMPLEX*16 K11,K22,K33,K44,K55
      COMPLEX*16 TK11,TK22,TK33,TK44,TK55
      COMPLEX*16 PREFACTOR
C
      COMPLEX*16 K1K2,K1K3,K1K4,K1K5,K2K3,K2K4,K2K5,K3K4,K3K5
C
      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)
      ENDDO
      CF = (NC**2 - 1.0D0)/2.0D0/NC
      FEYNMAN0 = 0.0D0
C
C------
C
      IF (GRAPHNUMBER .EQ. 11) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      IF (CUT(5)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55)
      ELSE
        PREFACTOR = PREFACTOR/K55
      ENDIF
      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)
      ENDDO
      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)
      FEYNMAN0 = (-16*CF*NC*X(5))/TK44
      FEYNMAN0 = FEYNMAN0*PREFACTOR
C
      ELSE IF (GRAPHNUMBER .EQ. 12) THEN
C
      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
      ENDDO
      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
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      IF (CUT(5)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55)
      ELSE
        PREFACTOR = PREFACTOR/K55
      ENDIF
      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)
      ENDDO
      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)
      FEYNMAN0 = (8*CF*NC*X(5))/TK55
      FEYNMAN0 = FEYNMAN0*PREFACTOR
C
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C             Vertex and propagator functions in Coulomb gauge         C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE TWOPOINTG(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUT)
C In:
      CHARACTER*9 KIND2PT
      COMPLEX*16 K2PT(0:2,0:3)
      LOGICAL CUT2PT(0:3)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C Out:
      COMPLEX*16 OUT(0:3,0:3)
C
C Calculates the one loop gluon two-point function, including the
C adjoining propagators.
C
C kind2pt:
C   GLUONLOOP gluon self-energy with a gluon (including ghost) loop
C   QUARKLOOP gluon self-energy with a quark loop
C   BOTHLOOPS the sum of these
C
C k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part)
C k2pt(1,mu): 1st momentum in loop (kplus for the space part)
C k2pt(2,mu): 2nd momentum in loop (kminus for the space part)
C
C cut2pt(0): whether incoming line is cut
C cut2pt(1): whether 1st internal line is cut
C cut2pt(2): whether 2nd internal line is cut
C cut2pt(3): whether outgoing line is cut
C
C mumsbar is the MSbar renormalization scale.
C
C The result is the two  point function out(mu,nu) with a certain
C normalization. Specifically, for the cut gluon self-energy
C graph, out(mu,nu) is {\cal M}_g^{\mu\nu}
C divided by (\alpha_s/(4\pi)) * 1/(1+\Delta) and divided
C by 2\omega_+ * 2\omega_- *\bar q^2. The factor by which we divide
C consists of
C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
C   one (2\pi)^{-3} for each loop that is factored out of each
C   graph in our program.
C * (d\vec l)/(d\bar q^2 dx d\phi)
C    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
C * 4 \pi {\cal Q} \bar q^2 included in the relation between
C   {\cal I}[real] and {\cal M}_g^{\mu\nu}
C
C In the case of the virtual gluon self-energy graphs
C with an adjacent propagator cut, out(mu,nu) is {\cal W}_g^{\mu\nu}
C divided by the same factors.
C
C 16 December 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
      INTEGER MU,NU
      COMPLEX*16 COMPLEXSQRT
      COMPLEX*16 KPLUS(1:3),KMINUS(1:3),ELL(1:3),Q(1:3)
      COMPLEX*16 CALQSQ, OMEGAPLUSSQ,OMEGAMINUSSQ
      COMPLEX*16 CALQ,OMEGAPLUS,OMEGAMINUS,Q0
      COMPLEX*16 DELTAP1,DELTA,TWOXM1,X1MX,QBARSQ
      COMPLEX*16 ELLT(1:3)
      COMPLEX*16 ELLTSQ,DENOM,ONEM2X1MX,ONEM4X1MX
      COMPLEX*16 TEMP
      COMPLEX*16 BAREPROP(1:3,1:3)
      COMPLEX*16 NTT,NLL,NEE,NEL
      COMPLEX*16 PREFACTOR
      COMPLEX*16 TERMTT,TERMLL
      COMPLEX*16 AT0,AT1,AT2
      COMPLEX*16 NTT0,NTT1,NTT2
      COMPLEX*16 NET0,NET1,NET2
      COMPLEX*16 UTT,NET
C 
C Some auxilliary variables, including
C CALQ = {\cal Q}
C OMEGAPLUS = \omega_+
C OMEGAMINUS = \omega_-
C DELTAP1 = \Delta + 1
C TWOXM1 = 2 x - 1
C X1MX = x (1-x)
C ELLT(mu) = l_T^\mu
C ELLTSQ = (\vec l_T)^2
C Q(mu) = the incoming *three*-momentum
C Q0 = the incoming energy
C
      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)
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ELLTSQ = QBARSQ*X1MX
      DENOM = QBARSQ/CALQSQ + 4.0D0*X1MX
      ONEM2X1MX = 1.0D0 - 2.0D0*X1MX
      ONEM4X1MX = 1.0D0 - 4.0D0*X1MX
C
C The gluon propagator in Coulomb gauge for an on-shell gluon
C with three-momentum Q(mu). This is the space components only.
C
      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
      ENDDO
      ENDDO
C
      IF (CUT2PT(1).AND.CUT2PT(2)) THEN
C
C We have the contribution from a cut self-energy diagram.
C We compute the coefficients for, alternatively, the gluon loop
C or the quark loop. We use the name NLL for Ntt and NEL for NEt.
C
      IF (KIND2PT.EQ.'GLUONLOOP') THEN
C
      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
C
      ELSE IF (KIND2PT.EQ.'QUARKLOOP') THEN
C
      NTT = NF*ONEM2X1MX
      NLL = - 4.0D0*NF*X1MX
      NEE = 4.0D0*NF*X1MX
      NEL = 2.0D0*NF*TWOXM1
C
      ELSE IF (KIND2PT.EQ.'BOTHLOOPS') THEN
C
      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
C
      NTT = NTT + NF*ONEM2X1MX
      NLL = NLL - 4.0D0*NF*X1MX
      NEE = NEE + 4.0D0*NF*X1MX
      NEL = NEL + 2.0D0*NF*TWOXM1
C
      ELSE
        WRITE(NOUT,*)'Unrecognized type in subroutine twopointg.'
        STOP
      ENDIF
C
C With the coefficients in hand, we compute the result.
C
      PREFACTOR = 1.0D0/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ)
C
      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
      ENDDO
      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)
      ENDDO
      ENDDO
C
C Alternative for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....
C
      ELSE IF (CUT2PT(0).OR.CUT2PT(3)) THEN
C
C We have the contribution from a virtual self-energy diagram
C with one of the neighboring propagators cut.
C We compute the coefficients for, alternatively, the gluon loop
C or the quark loop.
C
      IF (KIND2PT.EQ.'GLUONLOOP') THEN
C
        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
C
        UTT = AT0 + AT1/DENOM + AT2/DENOM**2
        NTT = NTT0 + NTT1/DENOM + NTT2/DENOM**2
        NET = NET0 + NET1/DENOM + NET2/DENOM**2
C
      ELSE IF (KIND2PT.EQ.'QUARKLOOP') THEN
C
C Here AT1 = AT2 = NTT1 = NTT2 = NET1 = NET2 = 0.
C
        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
C
        UTT = AT0
        NTT = NTT0
        NET = NET0
C
      ELSE IF (KIND2PT.EQ.'BOTHLOOPS') THEN
C
        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
C
        UTT = AT0 + AT1/DENOM + AT2/DENOM**2
        NTT = NTT0 + NTT1/DENOM + NTT2/DENOM**2
        NET = NET0 + NET1/DENOM + NET2/DENOM**2
C
        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
C
        UTT = UTT + AT0
        NTT = NTT + NTT0
        NET = NET + NET0
C
      ELSE
        WRITE(NOUT,*)'Unrecognized type in subroutine twopointg.'
        STOP
      ENDIF
C
C With the coefficients in hand, we compute the result. There is
C an extra factor 1 + \Delta  compared to the real self-energy
C graphs because {\cal W} lacks the factor 1/(1 + \Delta) that
C appears in {\cal M}.
C
C Also, we divide by 2 because we will get this contribution
C twice, once when one adjacent propagator is cut and onece
C when the other adjacent propagator is cut.
C
      PREFACTOR = - DELTAP1/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ)
      PREFACTOR = 0.5D0*PREFACTOR
C
      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
      ENDDO
      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)
      ENDDO
      ENDDO
C
C Closing for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....ELSEIF ...
C
      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
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,OUT)
C In:
      COMPLEX*16 K2PT(0:2,0:3)
      LOGICAL CUT2PT(0:3)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C Out:
      COMPLEX*16 OUT(0:3)
C
C Calculates the one loop quark two-point function, including the
C adjoining propagators.
C
C k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part)
C k2pt(1,mu): 1st momentum in loop (kplus for the space part)
C k2pt(2,mu): 2nd momentum in loop (kminus for the space part)
C
C cut2pt(0): whether incoming line is cut
C cut2pt(1): whether 1st internal line is cut
C cut2pt(2): whether 2nd internal line is cut
C cut2pt(3): whether outgoing line is cut
C
C mumsbar is the MSbar renormalization scale.
C
C The two  point function, with a certain normalization, 
C is represented as out^mu gamma_mu. 

C For the real quark self-energy graphs, out^{\mu} gamma_{\mu} 
C is {\cal M}_q divided by 
C (\alpha_s/(4\pi)) * 1/(1+\Delta) 
C and divided by 
C 4 * \omega_+ * \omega_- * \bar q^2. 
C The factor by which we divide consists of
C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
C   one (2\pi)^{-3} for each loop that is factored out of each
C   graph in our program.
C * (d\vec l)/(d\bar q^2 dx d\phi)
C    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
C * 4 \pi {\cal Q} \bar q^2 included in the relation between
C   {\cal I}[real] and {\cal M}_q.
C
C In the case of the virtual quark self-energy graphs with
C one of the adjacent propagators cut, OUT^{\mu} gamma_{\mu} 
C is {\cal W}_q divided by the same factors.
C
C In the case of the virtual quark self-energy graphs with
C the adjacent propagators *not* cut, OUT^{\mu} gamma_{\mu} 
C is W_q divided by 
C (\alpha_s/(4\pi)) * 1/(1+\Delta)
C and divided by 
C 2 * \omega_+ * \omega_- * (\bar q^2 - q^2) * q^2/{\cal Q}.
C The factor by which we divide consists of
C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and
C   one (2\pi)^{-3} for each loop that is factored out of each
C   graph in our program.
C * (d\vec l)/(d\bar q^2 dx d\phi)
C    = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta))
C * 2 \pi q^2 (\bar q^2 - q^2) included in the relation between
C   {\cal I}[all uncut] and W_q. 
C
C 2 January 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF,CF
      COMMON /COLORFACTORS/ NC,NF
      COMPLEX*16 COMPLEXSQRT
      INTEGER MU
      COMPLEX*16 KPLUS(1:3),KMINUS(1:3),ELL(1:3),Q(1:3)
      COMPLEX*16 CALQSQ,OMEGAPLUSSQ,OMEGAMINUSSQ
      COMPLEX*16 CALQ,OMEGAPLUS,OMEGAMINUS
      COMPLEX*16 DELTAP1,DELTA,TWOXM1,X1MX,QBARSQ
      COMPLEX*16 ELLT(1:3)
      COMPLEX*16 ELLTSQ,DENOM,ONEM2X1MX,ONEM4X1MX,X
      COMPLEX*16 TEMP,TEMPSQ
      COMPLEX*16 NL,NE,NT,PREFACTOR
      COMPLEX*16 BL0,BL1,BL2
      COMPLEX*16 NL0,NL1,NL2
      COMPLEX*16 NT0,NT1,NT2
      COMPLEX*16 UL,VL,VT
      COMPLEX*16 Q0,QSQ
      COMPLEX*16 BE0,BE1,BE2
      COMPLEX*16 UE
C
      CF = (NC**2 - 1.0D0)/(2.0D0*NC)
C 
C Some auxilliary variables, including
C CALQ = {\cal Q}
C OMEGAPLUS = \omega_+
C OMEGAMINUS = \omega_-
C DELTAP1 = \Delta + 1
C TWOXM1 = 2 x - 1
C X1MX = x (1-x)
C ELLT(mu) = l_T^\mu
C ELLTSQ = (\vec l_T)^2
C Q(mu) = the incoming *three*-momentum
C Q0 = the incoming energy
C
      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)
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      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
C
C Now we will go through these possible cut structures and
C calculate the terms contributing to out(mu).
C
      IF ( CUT2PT(1).AND.CUT2PT(2) ) THEN
C
C First possibility for cut structure: a cut self-energy diagram.
C Here TEMP = 2 x + Delta.
C
      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
C
      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))
      ENDDO
C
      ELSE IF ( CUT2PT(0).OR.CUT2PT(3) ) THEN
C
C Second possibility for cut structure: a virtual self-energy
C with an adjacent propagator cut.
C
      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
C
C We divide by 2 because we will get this contribution
C twice, once when one adjacent propagator is cut and once
C when the other adjacent propagator is cut.
C
      PREFACTOR = DELTAP1/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ)
      PREFACTOR = 0.5D0*PREFACTOR
C
      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))
      ENDDO
C 
      ELSE
C
C Third possibility for cut structure: a virtual self-energy
C with *no* adjacent propagator cut.
C
      QSQ = Q0**2 - CALQSQ
C
      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
C
      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
      ENDDO
C
C Completion of IF ... block for cut structure.
C
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,HV,HA)
C In:
      CHARACTER*7 KIND3PT
      COMPLEX*16 K3PT(3,0:3)
      LOGICAL CUT3PT(3)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C Out:
      COMPLEX*16 HV(0:3,0:3),HA(0:3,0:3)
C
C The unintegrated quark-antiquark-gluon three point function
C for the graph with flavors labelled by KIND3PT. 
C
C KIND3PT has the form abc/def where a,...,f are chosen from 
C Q,G,P. Here Q denotes "quark" or "antiquark", G denotes "gluon",
C and P denotes "photon. The external lines have flavors a,b,c
C and the internal lines have flavors d,e,f. The possibilities
C are QQG/QQG, QQG/GGQ, and QQP/QQG. There is also QQG/ALL, which
C gives the sum of the results for QQG/QQG and QQG/GGQ.
C
C The unintegrated three-point function \Gamma^\mu can be decomposed
C into a function HV^\mu_\nu \gamma^\mu plus a function 
C HA^\mu_\nu I \gamma^\mu \gamma_5 (all times a t^a color matrix or a
C unit color matrix in the case of a QQP vertex). This subroutine
C calculates the functions HV^{\mu\nu} and HA^{\mu\nu}.  The arguments
C are the momenta k3pt(1,mu), k3pt(2,mu), k3pt(3,mu), of the propagators
C around the loop. 
C
C The variable cut3pt(j) is .true. if line j is cut, .false. otherwise.
C If the line is cut, the corresponding energy is set by the calling
C programs to be k0 = + |\vec k| or else k0 = - |\vec k|. (Here
C |\vec k| is a shorthand for sqrt(\vec k^2), not the square root of 
C \vec k dotted into its complex conjugate.) This subroutine supplies a
C factor k(j)^2 for uncut propagators and 2 sqrt(\vec k^2) for a cut
C propagator.  For a virtual loop, subroutine vertex will be called six
C times, once with each of the three propagators cut and k0 = + |\vec k|
C and once with each of the three propagators cut and k0 = - |\vec k|.
C Then it will be called with no propagator cut, which implies that it
C should supply the renormalization counter term.
C
C 31 December 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
      COMPLEX*16 COMPLEXSQRT
C
      REAL*8 CF
      COMPLEX*16 NVEC(0:3)
      DATA NVEC /1,0,0,0/
      REAL*8 G(0:3,0:3)
      DATA G /1, 0, 0, 0,
     >        0,-1, 0, 0,
     >        0, 0,-1, 0,
     >        0, 0, 0,-1/
C
      COMPLEX*16 TK11,TK22,TK33,TK12,TK23,TK13
      COMPLEX*16 K11,K22,K33,K12,K23,K13
      COMPLEX*16 E1,E2,E3
      COMPLEX*16 C1,C2,C3,C4,C5,C6,C7,C8,C9
      COMPLEX*16 C10,C11,C12,C13,C14,C15,C16,C17
      COMPLEX*16 TEMP,PREFACTOR
      INTEGER MU,NU
      COMPLEX*16 K1(0:3),K2(0:3),K3(0:3)
      COMPLEX*16 EPSN1(0:3,0:3),EPSN2(0:3,0:3),EPSN3(0:3,0:3)
      COMPLEX*16 EPS12(0:3,0:3),EPS13(0:3,0:3),EPS23(0:3,0:3)
      COMPLEX*16 EPSN12(0:3),EPSN13(0:3),EPSN23(0:3),EPS123(0:3)
      COMPLEX*16 TL(0:3),OMEGASQ,OMEGA,CR1,CR2,CR3
      INTEGER NCUT,P
C
C-----
C
      CF = (NC**2 - 1.0D0)/(2.0D0*NC)
      NCUT = 0
      DO P=1,3
         IF (CUT3PT(P)) THEN
           NCUT = NCUT + 1
         ENDIF
      ENDDO
C
      IF ((NCUT.GT.1).OR.(FLAG.NE.'renormalize 3 pt')) THEN
C
C If NCUT = 1, we have a virtual loop. In this case, one of the
C possibilities is the renormalization counter term, for which
C FLAG would have been set to 'renormalize 3 pt'. Thus we get
C here is we do *not* have the the renormalization counter term.
C (Note that we could have NCUT = 2 but FLAG = 'renormalize 3 pt'
C in the case that there are two three point functions and ours
C is cut but the other one is virtual and needs to be renormalized.)
C
C First, dot products and energies. The dot products between vectors
C omitting their mu = 0 parts (\tilde vector) are denoted TKij.
C
      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)
      ENDDO
      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
C
C We need the factor equal to 1/k^2 for an uncut propagator
C and 1/ 2|E| for a cut propagator.
C
      PREFACTOR = (1.0D0,0.0D0)
      IF (.NOT.CUT3PT(1)) THEN
        PREFACTOR = PREFACTOR/K11
      ELSE
        PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK11))
      ENDIF
      IF (.NOT.CUT3PT(2)) THEN
        PREFACTOR = PREFACTOR/K22
      ELSE
        PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK22))
      ENDIF
      IF (.NOT.CUT3PT(3)) THEN
        PREFACTOR = PREFACTOR/K33
      ELSE
        PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK33))
      ENDIF
C
C------------------------
C First, we calculate hv.
C------------------------
C Generate the coefficients for the hv, depending on KIND3PT.
C
      IF (KIND3PT.EQ."QQG/QQG") THEN
C
      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)
C
      ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN
C
      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
C
      ELSE IF (KIND3PT.EQ."QQG/ALL") THEN
C
      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
C
      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)
C
      ELSE IF (KIND3PT.EQ."QQP/QQG") THEN
C
      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
C
      ELSE
        WRITE(NOUT,*)'Wrong kind in subroutine vertex'
        STOP
      ENDIF
C
C Now we have the coefficients, so we can calculate hv.
C
      DO MU = 0,3
      DO NU = 0,3
C
       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)
C
       HV(MU,NU) = PREFACTOR * TEMP
C
      ENDDO
      ENDDO
C
C------------------------
C Next, we calculate ha.
C------------------------
C
C We need certain vectors and tensors made by dotting vectors
C into the epsilon tensor.
C
      DO MU = 0,3
        K1(MU) = K3PT(1,MU)
        K2(MU) = K3PT(2,MU)
        K3(MU) = K3PT(3,MU)
      ENDDO
      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)
C
C Generate the coefficients for the hv, depending on KIND3PT.
C
      IF (KIND3PT.EQ."QQG/QQG") THEN
C
      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))
C
      ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN
C
      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
C
      ELSE IF (KIND3PT.EQ."QQG/ALL") THEN
C
      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
C
      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))
C
      ELSE IF (KIND3PT.EQ."QQP/QQG") THEN
C
      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
C
      ELSE
        WRITE(NOUT,*)'Wrong kind in subroutine vertex'
        STOP
      ENDIF
C
C Now we have the coefficients, so we can calculate ha.
C
      DO MU = 0,3
      DO NU = 0,3
C
       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)
C
       HA(MU,NU) = PREFACTOR * TEMP
C
      ENDDO
      ENDDO
C
C-----------------------------
C Now, we have both hv and ha.
C-----------------------------
C
C Alternative for IF (FLAG.NE.'renormalize 3 pt') THEN
C
      ELSE
C
C We need the renormalization counter term.
C
      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
      ENDDO
      OMEGASQ = OMEGASQ + MUMSBAR**2
      OMEGA = COMPLEXSQRT(OMEGASQ)
C
C Generate the coefficients for the hv counter term, 
C depending on KIND3PT.
C
      IF (KIND3PT.EQ."QQG/QQG") THEN
C
      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)
C
      ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN
C
      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)
C
      ELSE IF (KIND3PT.EQ."QQG/ALL") THEN
C
      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)
C
      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)
C
      ELSE IF (KIND3PT.EQ."QQP/QQG") THEN
C
      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)
C
      ELSE
        WRITE(NOUT,*)'Wrong kind in subroutine vertex'
        STOP
      ENDIF
C
C Now we have the coefficients, so we can calculate the hv counter term.
C The ha counter term is zero.
C
      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
      ENDDO
      ENDDO
      RETURN
C
C End  IF (CUT3PT(1).OR.CUT3PT(2).OR.CUT3PT(3)) THEN ... ELSE ...
C
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012   C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,VOUT)
C In:
      CHARACTER*13 KIND2PT2
      COMPLEX*16 K2PT2(0:5,0:3)
      LOGICAL CUT2PT2(1:5)
      REAL*8 MUMSBAR
      CHARACTER*16 FLAG
C Out:
      COMPLEX*16 VOUT(0:3)
C
C The two-loop contribution to the quark propagator. The function is 
C a dot product of a four-vector VOUT(mu) with gamma(mu), times a
C unit color matrix. This subroutine calculates VOUT(mu). (There is
C another contribution proportional to gamma(mu) gamma(5), but this
C contribution is not needed at our level of perturbation theory.) The
C contribution includes the self-energy diagram and the adjoining bare
C quark propagators. The calculation includes the denominator factors.
C Some of the internal propagators may be cut, as specified by cut2pt2,
C where cut2pt2(j) = .true. indicates that the corresponding line is 
C cut.
C
C The variable kind2pt2 tells what sort of graph we have.
C
C 1) There are graphs with two overlapping three point functions,
C incicated by kind2pt2 = OVERLAP/abcde where  a,...,e are chosen from 
C Q,G. Here Q denotes "quark" or "antiquark" while G denotes "gluon.
C These characters indicate the flavors on the internal lines. There
C are two possibilities: OVERLAP/QGGQQ and OVERLAP/QGQGG. (The first
C of these has all qqg vertices, while the second has two qqg vertices
C and one ggg vertex.) 
C
C 2) There are graphs with a one loop two point function nested inside
C the two loop two point function. These are indicated by
C kind2pt2 = NESTED /abcde, where, again,  a,...,e are chosen from 
C Q,G. There are three possibilities: 
C    NESTED /QGGGG gluon self-enegy with a gluon loop
C    NESTED /QGGQQ gluon self-enegy with a quark loop
C    NESTED /GQQGQ quark self-enegy
C
C Numbering for graphs of type OVERLAP:
C vrtx1 attaches to the incoming quark line
C vrtx2 attaches to the outgoing quark line
C vrtx3 is the internal vertex attached to a quark line from vrtx1
C vrtx4 is the other internal vertex
C k0(mu) is the momentum of the quark line entering vrtx1
C k1(mu) is the momentum of the internal line from vrtx1 to vrtx3
C k2(mu) is the momentum of the internal line from vrtx1 to vrtx4
C k3(mu) is the momentum of the internal line from vrtx3 to vrtx2
C k4(mu) is the momentum of the internal line from vrtx4 to vrtx2
C k5(mu) is the momentum of the internal line from vrtx3 to vrtx4
C
C Numbering for graphs of type NESTED:
C vrtx1 attaches to the incoming quark line
C vrtx2 attaches to the outgoing quark line
C vrtx3 is the internal vertex attached to a line from vrtx1
C vrtx4 is the other internal vertex
C k0(mu) is the momentum of the quark line entering vrtx1
C k1(mu) is the momentum of the internal line from vrtx1 to vrtx2
C k2(mu) is the momentum of the internal line from vrtx1 to vrtx3
C k3(mu) is the momentum of the internal line from vrtx4 to vrtx2
C k4(mu) ane k5(mu) are the momentum of the internal lines 
C        from vrtx3 to vrtx4. For a quark internal self-energy,
C        4 is the gluon and 5 is the quark line.
C
C The FLAG variable passed on to lower level subroutines.
C
C 31 December 2001
C
C For testing purposes only:
C     LOGICAL OVERRIDE,LEFTOVERRIDE
C     COMMON /TESTING/ OVERRIDE,LEFTOVERRIDE
C ---
C
      COMPLEX*16 COMPLEXSQRT
      COMPLEX*16 TK00,TK11,TK22,TK33,TK44
      COMPLEX*16 K00,K11,K22,K33,K44
      COMPLEX*16 TEMP,PREFACTOR
      COMPLEX*16 K0(0:3),K1(0:3),K2(0:3),K3(0:3),K4(0:3),K5(0:3)
      COMPLEX*16 E0,E1,E2,E3,E4
      LOGICAL CUT(1:5)
      COMPLEX*16 X(9)
C
      COMPLEX*16 EA4GGNIK0K1K2,EA4GK0K1,EA4GK2IGNK0K1,EA4GK2IK0K1K2
      COMPLEX*16 EA4QGNIK0K1K2,EA4QK0K1,EA4QK2IGNK0K1,EA4QK2IK0K1K2
      COMPLEX*16 EA5GGNIK0K3K4,EA5GK0K3,EA5GK4IGNK0K3,EA5GK4IK0K3K4
      COMPLEX*16 EA5QGNIK0K3K4,EA5QK0K4,EA5QK3IGNK0K4,EA5QK3IK0K3K4
      COMPLEX*16 K0K1,K0K2,K0K3,K0K4,K1K2,K3K4,TRACEV4G,TRACEV4Q
      COMPLEX*16 TRACEV5G,TRACEV5Q,V4GWGNK0,V4GWGNK1,V4GWGNK2,V4GWK0K1
      COMPLEX*16 V4GWK1K0,V4GWK2GN,V4GWK2K0,V4GWK2K1,V4GWK2K2,V4QWGNK0
      COMPLEX*16 V4QWGNK1,V4QWGNK2,V4QWK0K1,V4QWK1K0,V4QWK2GN,V4QWK2K0
      COMPLEX*16 V4QWK2K1,V4QWK2K2,V5GWGNK0,V5GWGNK3,V5GWGNK4,V5GWK0K3
      COMPLEX*16 V5GWK3K0,V5GWK4GN,V5GWK4K0,V5GWK4K3,V5GWK4K4,V5QWGNK0
      COMPLEX*16 V5QWGNK3,V5QWGNK4,V5QWK0K4,V5QWK3GN,V5QWK3K0,V5QWK3K3
      COMPLEX*16 V5QWK3K4,V5QWK4K0,A4GGNI(0:3),A4GK2I(0:3),A4QGNI(0:3)
      COMPLEX*16 A4QK2I(0:3),A5GGNI(0:3),A5GK4I(0:3),A5QGNI(0:3)
      COMPLEX*16 A5QK3I(0:3),EA4GGNIK1K2(0:3),EA4GK1(0:3)
      COMPLEX*16 EA4GK2IGNK1(0:3),EA4GK2IK1K2(0:3),EA4QGNIK1K2(0:3)
      COMPLEX*16 EA4QK1(0:3),EA4QK2IGNK1(0:3),EA4QK2IK1K2(0:3)
      COMPLEX*16 EA5GGNIK3K4(0:3),EA5GK3(0:3),EA5GK4IGNK3(0:3)
      COMPLEX*16 EA5GK4IK3K4(0:3),EA5QGNIK3K4(0:3),EA5QK3IGNK4(0:3)
      COMPLEX*16 EA5QK3IK3K4(0:3),EA5QK4(0:3),V4GGNI(0:3),V4GIK1(0:3)
      COMPLEX*16 V4GK1I(0:3),V4GK2I(0:3),V4QGNI(0:3),V4QIK1(0:3)
      COMPLEX*16 V4QK1I(0:3),V4QK2I(0:3),V5GGNI(0:3),V5GIK3(0:3)
      COMPLEX*16 V5GK3I(0:3),V5GK4I(0:3),V5QGNI(0:3),V5QIK4(0:3)
      COMPLEX*16 V5QK3I(0:3),V5QK4I(0:3),A4G(0:3,0:3),A4Q(0:3,0:3)
      COMPLEX*16 A5G(0:3,0:3),A5Q(0:3,0:3),V4G(0:3,0:3),V4Q(0:3,0:3)
      COMPLEX*16 V5G(0:3,0:3),V5Q(0:3,0:3)
C
      CHARACTER*7 KIND3PT
      LOGICAL OVERLAP,QQGVERTS,TRIPLEGLUE
      LOGICAL NESTED,NESTEDGLUE,NESTEDQUARK,GLUELOOP,QUARKLOOP
      COMPLEX*16 K2PT(0:2,0:3),Q(0:3)
      COMPLEX*16 OMEGASQ,QSQ
      CHARACTER*9 KIND2PT
      LOGICAL CUT2PT(0:3)
      COMPLEX*16 OUTG(0:3,0:3)
      COMPLEX*16 MK1(0:3),TRACEM,DOTQK1,MQK1
      COMPLEX*16 OUTQ(0:3)
      COMPLEX*16 OMEGA1SQ,BAREPROP(0:3,0:3),DM(0:3),QM,DQM
      COMPLEX*16 TRACEBAREPROP
C
      COMPLEX*16 GN(0:3)
      DATA GN /(1.0D0,0.0D0),(0.0D0,0.0D0),
     >           (0.0D0,0.0D0),(0.0D0,0.0D0)/ 
      REAL*8 METRIC(0:3)
      DATA METRIC / 1.0D0,-1.0D0,-1.0D0,-1.0D0 /
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
      REAL*8 CF
      INTEGER MU,NU,ALPHA
      LOGICAL LEFT,RIGHT
C
      COMPLEX*16 K3PT(3,0:3)
      LOGICAL CUT3PT(3)
C
      CF = (NC**2 - 1.0D0)/(2.0D0*NC)
C
C Set logical variables according to what case we have.
C
      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
      ENDIF
C
      IF (OVERLAP) THEN
C
C Short form of momentum variables and rename cut variables
C for overlap graphs.
C
      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)
      ENDDO
      CUT(1) = CUT2PT2(1)
      CUT(2) = CUT2PT2(2)
      CUT(3) = CUT2PT2(3)
      CUT(4) = CUT2PT2(4)
      CUT(5) = CUT2PT2(5)
C
C We have an OVERLAP type graph. We can treat it two different
C ways: either the left=hand three point graph is calculated
C using subroutine VERTEX or else the right-hand three point
C graph is calculated with subroutine VERTEX. We choose according
C to which lines are cut. Generally, we take the "left" choice,
C but if the right-hand loop is virtual, we take the "right" choice.
C
      LEFT = .TRUE.
      RIGHT = .FALSE.
      IF (CUT2PT2(1).AND.CUT2PT2(2)) THEN
        LEFT = .FALSE.
        RIGHT = .TRUE.
      ENDIF
C
C For testing purposes, we include code to override this choice.
C
C     IF (OVERRIDE) THEN
C       LEFT = LEFTOVERRIDE
C       RIGHT = .NOT.LEFT
C     ENDIF
C
C Calculate according to case, with logic
C     IF (QQGVERTS.AND.RIGHT) THEN
C     ELSE IF (QQGVERTS.AND.LEFT) THEN
C     ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN
C     ELSE IF (TRIPLEGLUE.AND.LEFT) THEN
C     ELSE <error>
C     ENDIF
C
C
C---
C
      IF (QQGVERTS.AND.RIGHT) THEN
C
C---
      TK00 = 0.0D0
      DO MU = 1,3
        TK00 = TK00 - K0(MU)**2
      ENDDO
      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
      ENDDO
      K11 = E1**2 + TK11
      K22 = E2**2 + TK22
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K4(MU)
        K3PT(2,MU) = -K5(MU)
        K3PT(3,MU) = K3(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      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
C
      ENDDO
C
      ELSE IF (QQGVERTS.AND.LEFT) THEN
C
C---
      TK00 = 0.0D0
      DO MU = 1,3
        TK00 = TK00 - K0(MU)**2
      ENDDO
      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
      ENDDO
      K33 = E3**2 + TK33
      K44 = E4**2 + TK44
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K5(MU)
        K3PT(2,MU) = -K1(MU)
        K3PT(3,MU) = K2(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      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
C
      ENDDO
C
      ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN
C
C---
      TK00 = 0.0D0
      DO MU = 1,3
        TK00 = TK00 - K0(MU)**2
      ENDDO
      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
      ENDDO
      K11 = E1**2 + TK11
      K22 = E2**2 + TK22
      IF (CUT(1)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11)
      ELSE
        PREFACTOR = PREFACTOR/K11
      ENDIF
      IF (CUT(2)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22)
      ELSE
        PREFACTOR = PREFACTOR/K22
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = -K4(MU)
        K3PT(2,MU) = -K5(MU)
        K3PT(3,MU) = K3(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      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
C
      ENDDO
C
      ELSE IF (TRIPLEGLUE.AND.LEFT) THEN
C
C---
      TK00 = 0.0D0
      DO MU = 1,3
        TK00 = TK00 - K0(MU)**2
      ENDDO
      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
      ENDDO
      K33 = E3**2 + TK33
      K44 = E4**2 + TK44
      IF (CUT(3)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33)
      ELSE
        PREFACTOR = PREFACTOR/K33
      ENDIF
      IF (CUT(4)) THEN
        PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44)
      ELSE
        PREFACTOR = PREFACTOR/K44
      ENDIF
      DO MU = 0,3
        K3PT(1,MU) = K5(MU)
        K3PT(2,MU) = -K2(MU)
        K3PT(3,MU) = K1(MU)
      ENDDO
      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)
      ENDDO
      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)
      ENDDO
      ENDDO
      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
      ENDDO
      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)
      ENDDO
      ENDDO
      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)
      ENDDO
      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
C
      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
C
      ENDDO
      ELSE
        WRITE(*,*)'Not programmed for that'
        STOP
      ENDIF
C
C-------------
C
C Alternative for IF (OVERLAP) THEN.
C
      ELSE IF (NESTED) THEN      
C
C We have a nested graph.
C
      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)
      ENDDO
      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
C
      CUT2PT(0) = CUT2PT2(2)
      CUT2PT(1) = CUT2PT2(4)
      CUT2PT(2) = CUT2PT2(5)
      CUT2PT(3) = CUT2PT2(3)
C
C We need the factor equal to 1/k^2 for an uncut propagator
C and 1/ 2|\vec k| for a cut propagator. BUT line 1 is always
C cut, propagator 0 never cut, and the one-loop two point function 
C that is nested inside has the factor for propagators 2,3,4,5.
C   
      PREFACTOR = CF/(QSQ**2*2.0D0*COMPLEXSQRT(OMEGA1SQ))
C
      IF (NESTEDGLUE) THEN
C
C Our nested graph has a gluon self-energy insertion.
C Calculate OUTG according to what kind of self-energy insertion it is.
C
      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)
      ENDIF
C
C Now comlete the calculation for a gluon self-energy insertion.
C
      DO ALPHA = 0,3
        TEMP = 0.0D0
        DO NU = 0,3
          TEMP = TEMP + OUTG(ALPHA,NU)*K1(NU)*METRIC(NU)
        ENDDO
        MK1(ALPHA) = TEMP
      ENDDO
C
      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)
      ENDDO
C
      MQK1 = 0.0D0
      DO MU = 0,3
      DO NU = 0,3
        MQK1 = MQK1 + OUTG(MU,NU)*Q(MU)*K1(NU)*METRIC(MU)*METRIC(NU) 
      ENDDO
      ENDDO
C
      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
      ENDDO
C
C Alternative for IF (NESTEDGLUE) THEN
C
      ELSE IF (NESTEDQUARK) THEN
C
C Our nested graph has a quark self-energy insertion.
C Calculate OUTQ.
C
      CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,OUTQ)
C
C Now comlete the calculation for a quark self-energy insertion.
C
C The gluon propagator in Coulomb gauge for an on-shell gluon
C with three-momentum K1(mu).
C
      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
      ENDDO
      ENDDO
      TRACEBAREPROP = -2.0D0
C
      DO ALPHA = 0,3
        DM(ALPHA) = 0.0D0
        DO NU = 0,3
         DM(ALPHA) = DM(ALPHA) + BAREPROP(ALPHA,NU)*OUTQ(NU)*METRIC(NU)
        ENDDO
      ENDDO
C
      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)
      ENDDO
      ENDDO
C
      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
      ENDDO
C
C Close IF (NESTEDGLUE) THEN ... ELSEIF (NESTEDQUARK) THEN
C
      ELSE
        WRITE(NOUT,*)'Oops, something must have gone wrong.'
        STOP
      ENDIF
C
C Close  IF (OVERLAP) THEN ... ELSE IF (NESTED) THEN      
C
      ELSE
        WRITE(NOUT,*)'Oops, something has gone wrong.'
        STOP
      ENDIF
C
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C           Dotting the epsilon tensor into vectors and tensors        C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE EPSILON4(V1,V2,V3,V4,OUT)
C In:
      COMPLEX*16 V1(0:3),V2(0:3),V3(0:3),V4(0:3)
C Out:
      COMPLEX*16 OUT
C
C Computes the contraction of the epsilon tensor with four four-vectors,
C giving a scalar result, OUT. The four vectors have upper indices.
C The epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1.
C
C 5 June 2001
C
      INTEGER N
      INTEGER MU(24,4),SIGN(24)
C
C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
C define the contributions to epsilon and J = 1,...,4 labelling
C the four indices of epsilon.
C
      DATA MU /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/
C
C Sign(N) is minus the signature of the permutation.
C
      DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,
     >           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/
C
      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))
      ENDDO
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE EPSILON3(V2,V3,V4,OUT)
C In:
      COMPLEX*16 V2(0:3),V3(0:3),V4(0:3)
C Out:
      COMPLEX*16 OUT(0:3)
C
C Computes the contraction of the epsilon tensor with three
C four-vectors, giving a vector result, OUT(mu1). The vectors have
C upper indices. The epsilon tensor has lower indices, so
C epsilon(0,1,2,3) = -1, and in addition we need a metric tensor to
C raise the index of OUT. We calculate
C
C   Out(mu1) = epsilon(mu1,mu2,mu3,mu4)  v2(mu2) v3(mu3) v4(mu4)
C
C 5 June 2001
C
      INTEGER N,NU
      INTEGER MU(24,4),SIGN(24)
C
C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
C define the contributions to epsilon and J = 1,...,4 labelling
C the four indices of epsilon.
C
      DATA MU /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/
C
C Sign(N) is minus the signature of the permutation.
C
      DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,
     >           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/
C
      REAL*8 METRIC(0:3)
      DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/
C
      DO NU = 0,3
        OUT(NU) = (0.0D0,0.0D0)
      ENDDO
      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))
      ENDDO
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE EPSILON2(V3,V4,OUT)
C In:
      COMPLEX*16 V3(0:3),V4(0:3)
C Out:
      COMPLEX*16 OUT(0:3,0:3)
C
C Computes the contraction of the epsilon tensor with two
C four-vectors, giving a second rank tensor result, OUT(mu1,mu2). The
C vectors have upper indices. The epsilon tensor has lower
C indices, so epsilon(0,1,2,3) = -1, and in addition we need a metric
C tensor to raise the indices of OUT. We calculate
C
C   Out(mu1,mu2) = epsilon(mu1,mu2,mu3,mu4) v3(mu3) v4(mu4)
C
C 5 June 2001
C
      INTEGER N,NU1,NU2
      INTEGER MU(24,4),SIGN(24)
C
C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
C define the contributions to epsilon and J = 1,...,4 labelling
C the four indices of epsilon.
C
      DATA MU /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/
C
C Sign(N) is minus the signature of the permutation.
C
      DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,
     >           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/
C
      REAL*8 METRIC(0:3)
      DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/
C
      DO NU1 = 0,3
      DO NU2 = 0,3
        OUT(NU1,NU2) = (0.0D0,0.0D0)
      ENDDO
      ENDDO
      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))
      ENDDO
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE EPSILON2N(V3,V4,OUT)
C In:
      COMPLEX*16 V3(0:3),V4(0:3)
C Out:
      COMPLEX*16 OUT(0:3)
C
C Computes the contraction of the epsilon tensor with two
C four-vectors and the unit vector n in the 0 direction, giving a 
C four-vector result, OUT(mu1). The vectors have upper indices. The
C epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1, and in
C addition we need a metric tensor to raise the index of OUT. However
C the metric contributes a factor (-1) in each case. We
C calculate
C
C   Out(mu1) = epsilon(mu1,mu2,mu3,mu4) n(mu2) v3(mu3) v4(mu4)
C
C 5 June 2001
C
      INTEGER N,NU
      INTEGER MU(6,4),SIGN(6)
C
C Mu is Mu(N,J) with N = 1,...,6 labelling the permutations that
C define the contributions to epsilon that have 0 for the second
C index and J = 1,...,4 labelling the four indices of epsilon.
C
      DATA MU /1,1,2,2,3,3,
     >         0,0,0,0,0,0,
     >         2,3,1,3,1,2,
     >         3,2,3,1,2,1/
C
C Sign(N) is minus the signature of the permutation.
C
      DATA SIGN /1,-1,-1,1,1,-1/
C
C Our result would have a factor METRIC(NU), but this factor is
C always -1.
C
      DO NU = 0,3
        OUT(NU) = (0.0D0,0.0D0)
      ENDDO
      DO N = 1,6
        NU = MU(N,1)
        OUT(NU) = OUT(NU) - SIGN(N)*V3(MU(N,3))*V4(MU(N,4))
      ENDDO
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE EPSILON1N(V4,OUT)
C In:
      COMPLEX*16 V4(0:3)
C Out:
      COMPLEX*16 OUT(0:3,0:3)
C
C Computes the contraction of the epsilon tensor with one
C four-vector and the unit vector n in the 0 direction, giving a 
C tensor result, OUT(mu1,mu2). The vectors have upper indices. The
C epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1, and in
C addition we need a metric tensor to raise the index of OUT.
C However, the metric tensor in each case contributes (-1)^2 = 1. We
C calculate
C
C   Out(mu1,mu2) = epsilon(mu1,mu2,mu3,mu4) n(mu3) v4(mu4)
C
C 7 December 2001
C
      INTEGER N,MU1,MU2
      INTEGER MU(6,4),SIGN(6)
C
C Mu is Mu(N,J) with N = 1,...,6 labelling the permutations that
C define the contributions to epsilon that have 0 for the third
C index and J = 1,...,4 labelling the four indices of epsilon.
C
      DATA MU /1,1,2,2,3,3,
     >         2,3,1,3,1,2,
     >         0,0,0,0,0,0,
     >         3,2,3,1,2,1/
C
C Sign(N) is minus the signature of the permutation.
C
      DATA SIGN /-1,1,1,-1,-1,1/
C
C Our result would have a factor METRIC(MU1)*METRIC(MU2), 
C but this factor is always +1.
C
      DO MU1 = 0,3
      DO MU2 = 0,3
        OUT(MU1,MU2) = (0.0D0,0.0D0)
      ENDDO
      ENDDO
      DO N = 1,6
        MU1 = MU(N,1)
        MU2 = MU(N,2)
        OUT(MU1,MU2) = OUT(MU1,MU2) + SIGN(N)*V4(MU(N,4))
      ENDDO
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE EPSILONT2(T12,V3,V4,OUT)
C In:
      COMPLEX*16 T12(0:3,0:3),V3(0:3),V4(0:3)
C Out:
      COMPLEX*16 OUT
C
C Computes the contraction of the epsilon tensor with a second rank
C tensor and two four-vectors, giving a scalar result, OUT. 
C The tensor and the four vectors have upper indices.
C The epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1.
C
C 4 August 2001
C
      INTEGER N
      INTEGER MU(24,4),SIGN(24)
C
C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
C define the contributions to epsilon and J = 1,...,4 labelling
C the four indices of epsilon.
C
      DATA MU /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/
C
C Sign(N) is minus the signature of the permutation.
C
      DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,
     >           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/
C
      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))
      ENDDO
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE EPSILONT1(T23,V4,OUT)
C In:
      COMPLEX*16 T23(0:3,0:3),V4(0:3)
C Out:
      COMPLEX*16 OUT(0:3)
C
C Computes the contraction of the epsilon tensor with a second
C rank tensor and a four-vector, giving a vector result, OUT(mu1). 
C The tensor and the vector have upper indices. The epsilon tensor has 
C lower indices, so epsilon(0,1,2,3) = -1, and in addition we need
C a metric tensor to raise the index of OUT. We calculate
C
C   Out(mu1) = epsilon(mu1,mu2,mu3,mu4)  t23(mu2,mu3) v4(mu4)
C
C 4 August 2001
C
      INTEGER N,NU
      INTEGER MU(24,4),SIGN(24)
C
C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that
C define the contributions to epsilon and J = 1,...,4 labelling
C the four indices of epsilon.
C
      DATA MU /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/
C
C Sign(N) is minus the signature of the permutation.
C
      DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1,
     >           -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/
C
      REAL*8 METRIC(0:3)
      DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/
C
      DO NU = 0,3
        OUT(NU) = (0.0D0,0.0D0)
      ENDDO
      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))
      ENDDO
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE DIAGNOSTIC(K,BADGRAPHNUMBER)
      INTEGER SIZE,MAXMAPS
      PARAMETER (SIZE = 3)
      PARAMETER (MAXMAPS = 64)
C In:
      REAL*8 K(0:3*SIZE-1,0:3)
      INTEGER BADGRAPHNUMBER
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      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
C
C NEWGRAPH variables:
      INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3)
      LOGICAL GRAPHFOUND
      INTEGER GRAPHNUMBER
C MAP variables:
      INTEGER NMAPS,QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE)
      CHARACTER*6 MAPTYPES(MAXMAPS)
C Calculate variables:
      LOGICAL REPORT,DETAILS
      COMMON /CALCULOOK/ REPORT,DETAILS
      COMPLEX*16 VALUE
      COMPLEX*16 VALUECHK
      REAL*8 MAXPART
C
      REAL*8 ABSK(0:3*SIZE-1)
      INTEGER P,MU,V
      REAL*8 COS12,COS23,COS31,SIN12,SIN23,SIN31
      REAL*8 BADNESS
C
C This finds data for the kind of graph with the worst value
C Latest revision: 4 January 1999
C Variable ORDER added 8 February 2002.
C -------
C
      ORDER = 2
      IF (BADGRAPHNUMBER.GT.10) THEN
        ORDER = 1
      ENDIF
      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
      ENDIF
C
C First we have to run NEWGRAPH through all the graphs so that it
C initializes itself.
C
      GRAPHFOUND = .TRUE.
      DO WHILE (GRAPHFOUND)
      CALL NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND)
      ENDDO
C
C Now we find the graph we wanted.
C
      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
      ENDIF
      DO WHILE (GRAPHFOUND)
      CALL NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND)
      IF (GRAPHFOUND) THEN
      GRAPHNUMBER = GRAPHNUMBER + 1
      ENDIF
      IF (GRAPHFOUND.EQV..FALSE.) THEN
        WRITE(NOUT,*)'Oops, snafu in DIAGNOSTIC'
        STOP
      ENDIF
      IF (GRAPHNUMBER.EQ.BADGRAPHNUMBER) THEN
        GRAPHFOUND = .FALSE.
      ENDIF
      ENDDO
C
C Calculate information associated with the maps.
C
      CALL FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES)
C
      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))
      ENDDO
C
      WRITE(NOUT,*)' '
      WRITE(NOUT,*)'Softness:'
      DO P = 1,NPROPS
        ABSK(P) = 0.0D0
        DO MU = 1,3
          ABSK(P) = ABSK(P) + K(P,MU)**2
        ENDDO
        ABSK(P) = SQRT(ABSK(P))
        WRITE(NOUT,704) P,ABSK(P)
704     FORMAT('P =',I2,'  |K| = ',1P G12.3)
      ENDDO
C
      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(PROP(V,1),MU) * K(PROP(V,2),MU)
        COS23 = COS23 + K(PROP(V,2),MU) * K(PROP(V,3),MU)
        COS31 = COS31 + K(PROP(V,3),MU) * K(PROP(V,1),MU)
       ENDDO
       COS12 = COS12 /ABSK(PROP(V,1))/ABSK(PROP(V,2))
       COS23 = COS23 /ABSK(PROP(V,2))/ABSK(PROP(V,3))
       COS31 = COS31 /ABSK(PROP(V,3))/ABSK(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,PROP(V,1),PROP(V,2),PROP(V,3),
     >       SIN12,SIN23,SIN31
705    FORMAT('V =',I2,' Ps =',3I2,'  sines =', 3F10.5)
      ENDDO
C
      WRITE(NOUT,*)' '
      CALL CHECKPOINT(K,ABSK,PROP,ORDER,BADNESS)
      WRITE(NOUT,706)BADNESS
706   FORMAT('Badness of this point is',1P G10.2)
C
      WRITE(NOUT,*)' '
      WRITE(NOUT,*)'CALCULATE finds the folowing:'
      REPORT = .TRUE.
C
      CALL CALCULATE(VRTX,GRAPHNUMBER,ORDER,K,ABSK,
     >               QS,QSIGNS,MAPTYPES,NMAPS,VALUE,MAXPART,VALUECHK)
C
      WRITE(NOUT,707)VALUE, ABS(VALUE),MAXPART
707   FORMAT('VALUE =',2(1P G12.4),' ABS(VALUE) = ',1P G12.4,/,
     >       'BIGGEST contribution was ',1P G12.4)
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C                      Miscellaneous Functions                         C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION ALPI(MUMSBAR)
      REAL*8 MUMSBAR
C
C Alpha_s/pi as a function of the MSbar scale. See 
C D.~E.~Soper and L.~R.~Surguladze,
C %``On the QCD perturbative expansion for e~+ e~- $\to$ hadrons,''
C Phys.\ Rev.\ D {\bf 54}, 4566 (1996)
C [arXiv:hep-ph/9511258].
C 21 February 2002
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 NC,NF
      COMMON /COLORFACTORS/ NC,NF
      REAL*8 ALPHASOFMZ,MZ,EXTERNALRTS
      COMMON /PHYSICSDATA/ ALPHASOFMZ,MZ,EXTERNALRTS
      REAL*8 B0,B1,B2
      REAL*8 T,X,ALPI0,ALPIINV,TEMP,ONEPX,LN1PX
      REAL*8 PI
      DATA PI /3.1415926535898D0/
C
C The beta function coefficients.
C
      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
C
      ALPI0 = ALPHASOFMZ/PI
      T = 2.0D0*LOG(MUMSBAR/MZ)
      X = B0*T*ALPI0
      ONEPX = 1.0D0 + X
      IF(ONEPX.LT.0.01D0)THEN
        WRITE(NOUT,*)'MUMSBAR too small in ALPI. ',MUMSBAR
        STOP
      ENDIF
      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
      ALPI = 1.0D0/ALPIINV
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION XXREAL(Z)
C     
      COMPLEX*16 Z
C
      XXREAL = DBLE(Z)
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION XXIMAG(Z)
C     
      COMPLEX*16 Z
C
      COMPLEX*16 ZZ
C
      ZZ = (0.0D0,-1.0D0) * Z
      XXIMAG = DBLE(ZZ)
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      COMPLEX*16 FUNCTION COMPLEXSQRT(Z)
      COMPLEX*16 Z
C
C Square root for complex numbers with error checking.
C 1 February 1998
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
      REAL*8 XXREAL,XXIMAG
C
      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
         ENDIF
      ENDIF
      COMPLEXSQRT = SQRT(Z)
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION FACTORIAL(N)
C
      INTEGER N
C
      INTEGER J
C
      FACTORIAL = 1.0D0
      DO J = 1,N
        FACTORIAL = FACTORIAL * J
      ENDDO
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION SINHINV(Z)
C     
      REAL*8 Z
      REAL*8 Z2,Z3,Z5,Z7
C
C Evaluate arcsinh(z) = log( z + Sqrt(1+z^2) ).
C For small z, we use the first four terms in the power
C series expansion of this function so that we do not
C lose precision in evaluating log(1 + z + z^2/2 + ...).
C At z = 0.03, the series evaluation is accurate to a
C fractional error of 2E-14. At this same point, the
C precision of the Log form of the function should be
C about that for representing 1.03 - 1.00, or 14 digits
C minus 1.5 digits, or 3E-12.
C
      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))
      ENDIF
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION EXPM1(X)
      REAL*8 X
C
C Returns exp(x) -1.
C 15 December 1999
C
      REAL*8 INV2,INV3,INV4,INV5,INV6,INV7,INV8
      PARAMETER(INV2 = 0.5D0)
      PARAMETER(INV3 = 0.333333333333333333D0)
      PARAMETER(INV4 = 0.25D0)
      PARAMETER(INV5 = 0.2D0)
      PARAMETER(INV6 = 0.166666666666666667D0)
      PARAMETER(INV7 = 0.142857142857142857D0)
      PARAMETER(INV8 = 0.125D0)
C
      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
      ENDIF
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION SQRTM1(X)
      REAL*8 X
C
C Returns sqrt(1+x) -1.
C The coefficients are 1/2,1/4,3/6,5/8,7/10,9/12,11/14,13/16,15/18.
C 15 December 1999
C
      REAL*8 C1,C2,C3,C4,C5,C6,C7,C8,C9
      PARAMETER(C1 = 0.5D0 )
      PARAMETER(C2 = 0.25D0 )
      PARAMETER(C3 = 0.5D0 )
      PARAMETER(C4 = 0.625D0 )
      PARAMETER(C5 = 0.7D0 )
      PARAMETER(C6 = 0.75D0 )
      PARAMETER(C7 = 0.785714285714285714D0 )
      PARAMETER(C8 = 0.8125D0 )
      PARAMETER(C9 = 0.833333333333333333D0 ) 
C
      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
      ENDIF
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION LOGSQINT(Y)
      REAL*8 Y
C
C The integral from 0 to Y of Log^2(y').
C 20 February 2001
C
      REAL*8 L
C
      L = LOG(Y)
      LOGSQINT = Y * (L**2 - 2.0D0*L + 2.0D0)
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      REAL*8 FUNCTION INVLOGSQINT(W)
      REAL*8 W
C
C Y = INVLOGSQINT(W) iff W = LOGSQINT(Y) where
C LOGSQINT(Y) is the integral from 0 to Y of Log^2(y'),
C namely LOGSQINT(Y) = Y * (Log(Y)**2 - 2.0D0*Log(Y) + 2.0D0).
C 20 February 2001
C
      INTEGER NIN,NOUT
      COMMON /IOUNIT/ NIN,NOUT
C
      REAL*8 U,Z,ZSQ,TEMP,UCALC,DELTAU
      LOGICAL MORENEEDED
      INTEGER N
C
C We use variables Z = Log(Y) and U = Log(W). Thus we want to solve
C U = Z + Log( Z** - 2*Z + 2 ). We iteratively use 
C Z_(n+1) = Z_n + (U - U_n)/ (dU/dZ) where 
C dU/dZ = Z**2/( Z** - 2*Z + 2 ).
C
      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.
        ENDIF
        IF (N.GT.10) THEN
          WRITE(NOUT,*)'Failed convergence in INVLOGSQINT'
          STOP
        ENDIF
      ENDDO
      INVLOGSQINT = EXP(Z)
      RETURN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C                      Random Number Generator
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE RANDOMINIT(IRAN)
      INTEGER IRAN
C
C  Code from CERN, 1991.
C  Modified to replace .AND. by IAND() and .OR. by IOR().
C
C  Initialize the shift-register random number generator from a random
C  seed  IRAN, 0 <= IRAN < 259200, with the help of a portable "quick 
C  and dirty" generator.
C
      INTEGER LBIT
      REAL*8 FAC
      PARAMETER(LBIT=31,FAC= 2.0D0**(-LBIT))
C  Here LBIT is the number of bits used in the shift register generator
      INTEGER J,IR(250)
      REAL*8 RR(250)
      COMMON/RANDO/ RR,J,IR
      SAVE /RANDO/
      INTEGER I,LB,JRAN,IFAC1,ISK,IDI,I1S
C  Configuration of the shift register generator
      INTEGER IM,IA,IC
      DATA IM,IA,IC /259200,7141,54773/
C
C
      IF(IRAN.LT.0.OR.IRAN.GE.IM)STOP
     > 'RINI: IRAN OUT OF RANGE'
      JRAN=IRAN
C  Warm up the auxiliary generator a little
      DO I=1,10
       JRAN=MOD(JRAN*IA+IC,IM)
      ENDDO
      IFAC1=((2**(LBIT-1)-1)*2+1)/IM
      DO I=2,250
       JRAN=MOD(JRAN*IA+IC,IM)
       IR(I)=IFAC1*JRAN
      ENDDO
C  Guarantee LBIT linearly independent (over the field of 2 el.)
C  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)
      ENDDO
      CALL NEWRAN
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE NEWRAN
C
C  Code from CERN, 1991.
C  Modified to replace .XOR. by IEOR().
C
C  Fills IR(I),RR(I) with 250 new random numbers, resets J=0.
C  Increment J before use!
C
      INTEGER LBIT
      REAL*8 FAC
      PARAMETER(LBIT=31,FAC= 2.0D0**(-LBIT))
      INTEGER J,IR(250)
      REAL*8 RR(250)
      COMMON/RANDO/ RR,J,IR
      SAVE /RANDO/
C
      INTEGER N
C
      DO N=1,103
       IR(N)=IEOR(IR(N+147),IR(N))
       RR(N)=FAC*(DBLE(IR(N)) + 0.5D0)
      ENDDO
C
      DO N=104,250
       IR(N)=IEOR(IR(N-103),IR(N))
       RR(N)=FAC*(DBLE(IR(N)) + 0.5D0)
      ENDDO
C
      J=0
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012C
      REAL*8 FUNCTION RANDOM(DUMMY)
      INTEGER DUMMY
C
C  Code from CERN, 1991.
C
C  Random number between 2**(-32) and 1 - 2**(-32):
C
      INTEGER J,IR(250)
      REAL*8 RR(250)
      COMMON/RANDO/ RR,J,IR
      SAVE /RANDO/
C
      IF(J.GE.250)CALL NEWRAN
      J=J+1
      RANDOM = RR(J)
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C             END OF LIBRARY ROUTINES FOR E+E- CALCULATION
C23456789012345678901234567890123456789012345678901234567890123456789012