C23456789012345678901234567890123456789012345678901234567890123456789012
C
C ----------------------------
C beowulfsubs.f Version 1.1.1
C ----------------------------
C
C23456789012345678901234567890123456789012345678901234567890123456789012
SUBROUTINE VERSION
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
WRITE(NOUT,*)'beowulf 1.1.1 subroutines 16 August 2001'
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 FUNCTION RANDOM
C SUBROUTINE NEWRAN
C SUBROUTINE CHOOSE3
C SUBROUTINE CHOOSE2TO3D
C SUBROUTINE CHOOSE2TO3E
C SUBROUTINE CHOOSE2TO2T
C SUBROUTINE CHOOSE2TO2S
C SUBROUTINE CHOOSE2TO1
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 FUNCTION CALS0 (*)
C FUNCTION THRUST (*)
C SUBROUTINE GETCUTINFO
C SUBROUTINE DEFORM
C SUBROUTINE FINDA <see below>
C SUBROUTINE CHECKDEFORM
C FUNCTION RNUMERATOR
C SUBROUTINE QPROPR
C SUBROUTINE GPROPR
C SUBROUTINE QPROP
C SUBROUTINE CHECKDEFORM2
C FUNCTION RQQP3AQ
C FUNCTION RQQP3BQ
C FUNCTION RQQP3CQ
C FUNCTION RQQG3AG
C FUNCTION RQQG3BG
C FUNCTION RQQG3CG
C FUNCTION RQQG3AQ
C FUNCTION RQQG3BQ
C FUNCTION RQQG3CQ
C FUNCTION NUMERATOR
C SUBROUTINE QPROP
C SUBROUTINE CHECKDEFORM2
C SUBROUTINE GPROP
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 KN (*)
C FUNCTION CALS3JET (*)
C SUBROUTINE COMBINEJETS (*)
C FUNCTION BETHKE (*)
C FUNCTION KN (*)
C FUNCTION BETHKE (*)
C return
C
C Simple functions called from routines above, with calls
C not listed above:
C
C SUBROUTINE AXES
C FUNCTION XXREAL
C FUNCTION XXIMAG
C FUNCTION COMPLEXSQRT
C FUNCTION FACTORIAL
C FUNCTION SINHINV
C FUNCTION DELTA
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 SELFPROP(P) = True if propagator P is part of a one loop self-energy
C subgraph or attaches to a such a subgraph.
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)
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 = 10)
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 11 August 1999
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
REAL*8 ENERGYSCALE
COMMON /MSCALE/ ENERGYSCALE
REAL*8 BADNESSLIMIT,CANCELLIMIT,THRUSTCUT
COMMON /LIMITS/ BADNESSLIMIT,CANCELLIMIT,THRUSTCUT
REAL*8 TIMELIMIT
COMMON /MAXTIME/ TIMELIMIT
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 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 SELFPROP(3*SIZE-1)
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.
C
GRAPHFOUND = .TRUE.
GRAPHNUMBER = 0
C
DO WHILE (GRAPHFOUND)
CALL NEWGRAPH(VRTX,PROP,SELFPROP,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,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,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,K,ABSK,BADNEWPOINT)
IF (BADNEWPOINT) THEN
CALL HROTHGAR(1,KCUT0,1.0D0,1,'BADPOINT ')
BADPOINTQ = .TRUE.
ENDIF
CALL CHECKPOINT(K,ABSK,PROP,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,SELFPROP,GRAPHNUMBER,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
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,*)' '
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(VRTX,PROP,SELFPROP,GRAPHFOUND)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
C Out:
INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3)
LOGICAL SELFPROP(3*SIZE-1)
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----------
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 SELFPROP(P) = True if propagator P is part of a one loop self-energy
C subgraph or attaches to a such a subgraph.
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 NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
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 (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)
ELSE
CALL NEXTCHOICE(C,COUNT,V,FAIL)
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)) THEN
CALL CHECK(C,NPERMS,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 We also need to report which propagators P connect to a vertex
C that is part of a one loop self-energy subgraph.
C
DO P = 1,NPROPS
SELFPROP(P) = .FALSE.
ENDDO
DO VV = 1,NVERTS
IF ((C(VV,1).EQ.C(VV,2)).OR.(C(VV,2).EQ.C(VV,3))) THEN
DO I = 1,3
SELFPROP(PROP(VV,I)) = .TRUE.
ENDDO
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)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
C
INTEGER C(2*SIZE,3),COUNT(2*SIZE)
INTEGER V
LOGICAL FAIL
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
C
INTEGER VV,K
LOGICAL FOUND
SAVE
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)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
C
INTEGER C(2*SIZE,3),COUNT(2*SIZE)
INTEGER V
LOGICAL FAIL
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
C
INTEGER VV,VVV,V2,V3,I
LOGICAL FOUND
SAVE
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)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
INTEGER CIN(2*SIZE,3)
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 NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
C
LOGICAL LEFT(2*SIZE),CHANGE
INTEGER C(2*SIZE,3)
INTEGER V,I,V1,V2,I1,I2
SAVE
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,OK)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
INTEGER CIN(2*SIZE,3),NPERMS
LOGICAL OK
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
INTEGER C(2*SIZE,3),V(2*SIZE)
INTEGER L,I,VV
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,N,OK).
C If OK = False is returned, the graph C was no good and we exit
C from CHECK immediately.
C
1 CONTINUE
IF (L.EQ.4) THEN
CALL CHECKOUT(C,CIN,NPERMS,OK)
IF (.NOT.OK) RETURN
CALL EXCHANGE(3,4,C)
CALL CHECKOUT(C,CIN,NPERMS,OK)
IF (.NOT.OK) RETURN
CALL EXCHANGE(3,4,C)
C "RETURN"
GO TO 2
ENDIF
C "DO V(L) = L,3,-1"
V(L) = L
3 CONTINUE
CALL EXCHANGE(V(L),L,C)
L = L - 1
C "CALL PERMUTATIONS(L,C)"
GO TO 1
C Return from mock subroutine comes here:
2 CONTINUE
L = L + 1
CALL EXCHANGE(V(L),L,C)
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
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,NPERMS,OK)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
INTEGER C(2*SIZE,3),CIN(2*SIZE,3),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 NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
INTEGER V,I
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)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
INTEGER C(2*SIZE,3)
INTEGER V1,V2
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
INTEGER TEMP1,TEMP2,I,V
LOGICAL CHANGE
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,A,QOK)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
C In:
INTEGER VRTX(0:3*SIZE-1,2),Q(0:SIZE),NQ
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,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
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((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
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
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,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)
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 20 December 2000
C 20 March 2001
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
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
MAPNUMBER = 0
MORENEEDED = .TRUE.
NEWCUTINIT = .TRUE.
DO WHILE (MORENEEDED)
CALL NEWCUT(VRTX,NEWCUTINIT,NCUT,ISIGN,
> CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP,
> NINLOOP,LOOPINDEX,LOOPSIGN,CUTFOUND)
IF (CUTFOUND) 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 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,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
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
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
C
REAL*8 P1(3),P2(3),P3(3),ELL1(3)
INTEGER P,MU
REAL*8 TEMP,KSQ
LOGICAL OK
C
C------------
C
BADPOINT = .FALSE.
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
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
SUBROUTINE CHECKPOINT(K,ABSK,PROP,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)
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 NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
C
REAL*8 SMALLNESSV,SMALLNESS
INTEGER V
REAL*8 KMIN,KMID,KMAX,K1,K2,K3
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,SELFPROP,GRAPHNUMBER,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)
LOGICAL SELFPROP(3*SIZE-1)
INTEGER GRAPHNUMBER
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 = 10)
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
REAL*8 MUOVERRTS
COMMON /RENORMALIZE/ MUOVERRTS
LOGICAL REPORT,DETAILS
COMMON /CALCULOOK/ REPORT,DETAILS
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
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 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
C DEFORM variables:
COMPLEX*16 JACDEFORM
C Functions:
REAL*8 CALS0,SMEAR
REAL*8 XXREAL,XXIMAG
COMPLEX*16 COMPLEXSQRT
C Index variables:
INTEGER P,MU,I,J,CUTNUMBER
C Propagator properties and momenta
LOGICAL INLOOP(3*SIZE-1),CUT(3*SIZE-1)
LOGICAL LOOPCUT(3*SIZE-1)
INTEGER CUTSIGNP(3*SIZE-1)
INTEGER LOOPLABEL(3*SIZE-1)
REAL*8 KSQ
COMPLEX*16 KCSQ
C Results variables:
REAL*8 CALSVAL
REAL*8 WEIGHT,MAXWEIGHT
COMPLEX*16 NUMERATOR,RNUMERATOR,FEYNMAN
COMPLEX*16 LOOPDENOM
REAL*8 PLAINDENOM
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----------------------------------
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)
C
C Loop over cuts.
C
DO CUTNUMBER = 1,NUMBEROFCUTS(GRAPHNUMBER)
CALL GETCUTINFO(GRAPHNUMBER,CUTNUMBER,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
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 three cases.
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 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, with JCUT = 1.
C 3) NINLOOP > 2, with NCUT = CUTMAX - 1
C Then we should loop over JCUT = 1,2,...,NINLOOP and
C set CUTINDEX(CUTMAX) = LOOPINDEX(JCUT). When we are done with this
C we set CALCMORE to .FALSE. .
C
C If we need to renormalize this loop, we will do it
C as part of the JCUT = 1 calculation.
C
C We initialize the weight, then add to it for the renormalization
C counterterm and for each loopcut.
C
WEIGHT = 0.0D0
MAXWEIGHT = 0.0D0
C
JCUT = 0
CALCMORE = .TRUE.
DO WHILE (CALCMORE)
IF (NINLOOP.EQ.0) THEN
CALCMORE = .FALSE.
ELSE
JCUT = JCUT + 1
CUTINDEX(CUTMAX) = LOOPINDEX(JCUT)
CUTSIGN(CUTMAX) = LOOPSIGN(JCUT)
IF ((NINLOOP.EQ.2).OR.(JCUT.EQ.NINLOOP)) THEN
CALCMORE = .FALSE.
ENDIF
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,AE,QOK)
IF (.NOT.QOK) THEN
WRITE(NOUT,*)'AE not found'
STOP
ENDIF
C
C Find which propagators are which. A propagator can be exactly
C on shell even if it isn't cut if it is linked by a self-energy
C correction to a propagator that is cut. The matrix AE(P,I) will
C tell us.
C
C Define logical and sign variables:
C CUT(P) = .TRUE. if propagator P crosses the final state cut.
C CUTSIGNP(P) = CUTSIGN(I) for P = CUTINDEX(I).
C LOOPCUT(P) = .TRUE. propagator P crosses the loopcut.
C INLOOP(P) = .TRUE. if it is in a virtual loop.
C LOOPLABEL(P) = label 1,2,... counting around loop for propagator P in
C loop.
C SELFPROP(P) = .TRUE. if it is part of a one loop self-energy diagram
C or attaches to such a diagram.
C
DO P = 1,NPROPS
CUT(P) = .FALSE.
LOOPCUT(P) = .FALSE.
INLOOP(P) = .FALSE.
CUTSIGNP(P) = 0
LOOPLABEL(P) = 0
ENDDO
DO I = 1,CUTMAX
CUT(CUTINDEX(I)) = .TRUE.
CUTSIGNP(CUTINDEX(I)) = CUTSIGN(I)
ENDDO
IF (NINLOOP.GT.0) THEN
CUT(CUTINDEX(CUTMAX)) = .FALSE.
LOOPCUT(CUTINDEX(CUTMAX)) = .TRUE.
ENDIF
DO J = 1,NINLOOP
INLOOP(LOOPINDEX(J)) = .TRUE.
LOOPLABEL(LOOPINDEX(J)) = J
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) = 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 denominator.
C
C We calculate two denominators: the part from the loop propagators
C (LOOPDENOM) and the part from the other propagators (PLAINDENOM).
C The renormalization counterterm uses only PLAINDENOM.
C
C Propagators that are part of a one loop self-energy subgraph, or
C attached to such a subgraph, do not contribute to the denominator
C factor at all. The functions QPROP and GPROP, called by NUMERATOR,
C take care of the factors associated with these propagators.
C
PLAINDENOM = 1.0D0
LOOPDENOM = (1.0D0,0.0D0)
DO P = 1,NPROPS
C
IF (.NOT.SELFPROP(P)) THEN
IF (INLOOP(P)) THEN
C
C P is in the loop:
C
IF(LOOPCUT(P)) THEN
LOOPDENOM = LOOPDENOM * 2.0D0 * CUTSIGNP(P) * KC(P,0)
ELSE
KCSQ = 0.0D0
DO MU = 0,3
KCSQ = KCSQ + METRIC(MU) * KC(P,MU)**2
ENDDO
CALL CHECKDEFORM(KCSQ,LEFTLOOP,RIGHTLOOP,LOOPLABEL(P),JCUT,
> GRAPHNUMBER,CUT,LOOPCUT)
LOOPDENOM = LOOPDENOM * KCSQ
ENDIF
C
ELSE
C
C P is not in the loop:
C
IF (CUT(P)) THEN
PLAINDENOM = PLAINDENOM * 2.0D0 * CUTSIGNP(P) * K(P,0)
ELSE
KSQ = 0.0D0
DO MU = 0,3
KSQ = KSQ + METRIC(MU) * K(P,MU)**2
ENDDO
PLAINDENOM = PLAINDENOM * KSQ
ENDIF
C
C End IF (INLOOP(P)) ... ELSE ...
C End IF (.NOT.SELFPROP(P)) ...
C
ENDIF
ENDIF
C........
IF (REPORT.AND.DETAILS) THEN
IF (.NOT.SELFPROP(P)) THEN
IF (INLOOP(P)) THEN
IF(LOOPCUT(P)) THEN
WRITE(NOUT,350)P,CUTSIGNP(P) * KC(P,0)
350 FORMAT('Loopcut propagator',I3,' Energy =',2(1P G12.3))
ELSE
WRITE(NOUT,351)P,KCSQ
351 FORMAT('Loop propagator',I3,' KCSQ =',2(1P G12.3))
ENDIF
ELSE
IF (CUT(P)) THEN
WRITE(NOUT,352)P,CUTSIGNP(P) * K(P,0)
352 FORMAT('Cut propagator',I3,' Energy =',(1P G12.3))
ELSE
WRITE(NOUT,353)P,KSQ
353 FORMAT('Tree propagator',I3,' KSQ =',(1P G12.3))
ENDIF
ENDIF
ENDIF
ENDIF
C'''''''
C
C End DO P = 1,NPROPS
C
ENDDO
C
C Calculate graph.
C
C Add to contribution for this point.
C
C If we have a virtual loop with 2 or 3 lines, then we need the
C renormalization counter term. We are in a loop over JCUT. We
C will include the counter term when JCUT = 1.
C
C There is a minus sign because this is the counter term and we
C want to subtract it.
C
IF (((NINLOOP.EQ.2).OR.(NINLOOP.EQ.3)).AND.(JCUT.EQ.1)) THEN
C
FEYNMAN = RNUMERATOR(GRAPHNUMBER,KC,MUMSBAR,CUT)/PLAINDENOM
C
INTEGRAND = - PREFACTOR * JACNEWPOINT * JACDEFORM
> * FEYNMAN * SMEAR(RTS)
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,360)
360 FORMAT('PREFACTOR * JACNEWPOINT * (JACDEFORM-R JACDEFORM-I)',
> ' (FEYNMAN-R FEYNMAN-I) * CALSVAL * SMEAR(RTS)')
WRITE(NOUT,361)PREFACTOR,JACNEWPOINT,JACDEFORM,
> FEYNMAN,CALSVAL,SMEAR(RTS)
361 FORMAT(8(1P G12.3))
ENDIF
WRITE(NOUT,362)INTEGRAND
362 FORMAT('Contribution (CT):',2(1P G18.10))
IF (DETAILS) THEN
WRITE(NOUT,*)' '
ENDIF
ENDIF
C''''
ENDIF
C
C Done with the counter term (if any), now we do the main term.
C
FEYNMAN = NUMERATOR(GRAPHNUMBER,KC,CUT)/LOOPDENOM /PLAINDENOM
INTEGRAND = PREFACTOR * JACNEWPOINT * JACDEFORM
> * FEYNMAN * SMEAR(RTS)
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,
> FEYNMAN,CALSVAL,SMEAR(RTS)
371 FORMAT(8(1P G12.3))
ENDIF
IF (NINLOOP.GT.0) THEN
WRITE(NOUT,373)LOOPINDEX(JCUT),INTEGRAND
373 FORMAT(I3,' Contribution:',2(1P G18.10))
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
CALL
> CHECKCALC(GRAPHNUMBER,CUTINDEX,KC,JACNEWPOINT,JACDEFORM,CHECK)
VALUECHK = VALUECHK + CHECK
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: 24 December 1998
C
C Max number of graphs, cuts, maps for array sizes:
INTEGER MAXGRAPHS,MAXMAPS
PARAMETER (MAXGRAPHS = 10)
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.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
C Here is an infrared sensitive check integral:
CHECK = TEMP1 * (TEMP1 + MM**2)
CHECK = CHECK * TEMP2 * (TEMP2 + MM**2)
CHECK = CHECK * (TEMP3 + MM**2)**3
CHECK = (MM**5/PI**6) /CHECK
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
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)
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
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
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
INTEGER MAXGRAPHS
PARAMETER (MAXGRAPHS = 10)
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
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
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: 22 December 2000.
C
C Array sizes. (We check MAXGRAPHS,MAXCUTS,MAXMAP here.):
INTEGER SIZE,MAXGRAPHS,MAXCUTS,MAXMAPS
PARAMETER (SIZE = 3)
PARAMETER (MAXGRAPHS = 10)
PARAMETER (MAXCUTS = 9)
PARAMETER (MAXMAPS = 64)
C Input and output units.
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
C Graph size variables.
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
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 SELFPROP(3*SIZE-1)
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
C
C---------
C Get a new graph.
C
GRAPHFOUND = .TRUE.
GRAPHNUMBER = 0
C
DO WHILE (GRAPHFOUND)
CALL NEWGRAPH(VRTX,PROP,SELFPROP,GRAPHFOUND)
IF (GRAPHFOUND) THEN
GRAPHNUMBER = GRAPHNUMBER + 1
C
C Get a new cut.
C
CUTFOUND = .TRUE.
NEWCUTINIT = .TRUE.
CUTNUMBER = 0
DO WHILE (CUTFOUND)
CALL NEWCUT(VRTX,NEWCUTINIT,NCUT,ISIGN,
> CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP,
> NINLOOP,LOOPINDEX,LOOPSIGN,CUTFOUND)
IF (CUTFOUND) THEN
CUTNUMBER = CUTNUMBER + 1
C
NCUTINFO(GRAPHNUMBER,CUTNUMBER) = NCUT
DO P = 1,NPROPS
ISIGNINFO(GRAPHNUMBER,CUTNUMBER,P) = ISIGN(P)
ENDDO
DO I = 1,CUTMAX
CUTINDEXINFO(GRAPHNUMBER,CUTNUMBER,I) = CUTINDEX(I)
CUTSIGNINFO(GRAPHNUMBER,CUTNUMBER,I) = CUTSIGN(I)
ENDDO
LEFTLOOPINFO(GRAPHNUMBER,CUTNUMBER) = LEFTLOOP
RIGHTLOOPINFO(GRAPHNUMBER,CUTNUMBER) = RIGHTLOOP
NINLOOPINFO(GRAPHNUMBER,CUTNUMBER) = NINLOOP
DO NP = 1,CUTMAX
LOOPINDEXINFO(GRAPHNUMBER,CUTNUMBER,NP) = LOOPINDEX(NP)
LOOPSIGNINFO(GRAPHNUMBER,CUTNUMBER,NP) = LOOPSIGN(NP)
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,NMAPS,QS,QSIGNS,MAPTYPES)
NUMBEROFMAPS(GRAPHNUMBER) = NMAPS
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
IF (GRAPHNUMBER.GT.MAXGRAPHS) THEN
WRITE(NOUT,*)'More graphs than I thought.'
STOP
ENDIF
NUMBEROFGRAPHS = GRAPHNUMBER
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
SUBROUTINE GETCUTINFO(GRAPHNUMBER,CUTNUMBER,NCUT,ISIGN,
> CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP,
> NINLOOP,LOOPINDEX,LOOPSIGN)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
C Input:
INTEGER GRAPHNUMBER,CUTNUMBER
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 NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
C
C Information on cut structure:
INTEGER MAXGRAPHS,MAXCUTS
PARAMETER (MAXGRAPHS = 10)
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
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,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)
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
C -------------------
C
C-----------------------------------------------------------------------
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
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
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).
C
IF (NEWCUTINIT) THEN
CUTINDEX(1) = CUTMAX - 2
DO I = 2, CUTMAX
CUTINDEX(I) = CUTMAX - I
ENDDO
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
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 set.
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
INTEGER NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
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
SUBROUTINE CHECKDEFORM(KCSQ,LEFTLOOP,RIGHTLOOP,JPROBED,JCUT,
> GRAPHNUMBER,CUT,LOOPCUT)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
C In:
COMPLEX*16 KCSQ
LOGICAL LEFTLOOP,RIGHTLOOP
INTEGER JPROBED,JCUT
INTEGER GRAPHNUMBER
LOGICAL CUT(3*SIZE-1),LOOPCUT(3*SIZE-1)
C Out: None
C
C This subroutine just checks that the contour deformation was in
C the right direction. Here JPROBED is the label 1,2,3... counting
C around of the loop of the probagator whose squared momentum is
C KSCQ, while JCUT is the label of the loopcut propagator.
C Consider a loop to the left of the cut.
C For propagators with JPROBED < JCUT + 1 ,we do not have a singularity
C protected by an i\epsilon, so we do not test. For propagators with
C JPROBED > JCUT + 1, we are deforming around a singularity that is
C protected with an i\epsilon, and we should check that we deformed
C in the right direction.
C For loops to the right of the cut, the situation is the opposite.
C
C 14 February 1996
C 16 March 1996
C 24 October 1996 (Checks also for NINLOOP.eq.2, 21 September 1997)
C 2 January 1998 Simplify, look at all cases.
C 14 March 1998
C 4 August 1998 Check all cases for 3 and 4 point subgraphs.
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
C
REAL*8 XXIMAG,XXREAL
C--
C
IF ( LEFTLOOP ) THEN
C
IF (JPROBED.GT.(JCUT+1)) THEN
IF ( - XXIMAG(KCSQ) .GT. ABS(XXREAL(KCSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign for deformation with an L loop?'
WRITE(NOUT,*) KCSQ
STOP
ENDIF
ELSE IF (JPROBED.EQ.(JCUT+1)) THEN
C
C Check the special cases in which there is a three particle loop
C that contains one of the current vertices. Then there is one
C propagator coming out of the loop that is not cut, but connects
C to two cut propagators. When the loopcut propagator is the one just
C before this one, we need to check the deformation sign. Since this
C is just a check, we find the cases to look at by hand instead of
C writing code to do the logic.
C
IF (GRAPHNUMBER.EQ.5) THEN
IF (LOOPCUT(5)) THEN
IF ( - XXIMAG(KCSQ) .GT. ABS(XXREAL(KCSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 5, L loop?'
WRITE(NOUT,*) KCSQ
STOP
ENDIF
ENDIF
ELSE IF (GRAPHNUMBER.EQ.8) THEN
IF (LOOPCUT(1).AND.CUT(3)) THEN
IF ( - XXIMAG(KCSQ) .GT. ABS(XXREAL(KCSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 8, L loop?'
WRITE(NOUT,*) KCSQ
STOP
ENDIF
ELSE IF (LOOPCUT(5).AND.CUT(4)) THEN
IF ( - XXIMAG(KCSQ) .GT. ABS(XXREAL(KCSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 8, L loop?'
WRITE(NOUT,*) KCSQ
STOP
ENDIF
ENDIF
ENDIF
C Close IF (JPROBED.GT.(JCUT+1)) ... ELSE IF (JPROBED.EQ.(JCUT+1)) ...
ENDIF
C
ELSE IF ( RIGHTLOOP ) THEN
C
IF (JPROBED.LT.(JCUT-1)) THEN
IF ( XXIMAG(KCSQ) .GT. ABS(XXREAL(KCSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign for deformation with an R loop?'
WRITE(NOUT,*) KCSQ
STOP
ENDIF
C
C Special case checks as for left loop.
C
ELSE IF (JPROBED.EQ.(JCUT-1)) THEN
C
IF (GRAPHNUMBER.EQ.6) THEN
IF (LOOPCUT(4)) THEN
IF ( XXIMAG(KCSQ) .GT. ABS(XXREAL(KCSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 6, R loop?'
WRITE(NOUT,*) KCSQ
STOP
ENDIF
ENDIF
ELSE IF (GRAPHNUMBER.EQ.8) THEN
IF (LOOPCUT(8).AND.CUT(1)) THEN
IF ( XXIMAG(KCSQ) .GT. ABS(XXREAL(KCSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 8, R loop?'
WRITE(NOUT,*) KCSQ
STOP
ENDIF
ELSE IF (LOOPCUT(4).AND.CUT(2)) THEN
IF ( XXIMAG(KCSQ) .GT. ABS(XXREAL(KCSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 8, R loop?'
WRITE(NOUT,*) KCSQ
STOP
ENDIF
ENDIF
ENDIF
C Close IF (JPROBED.LT.(JCUT-1)) ... ELSE IF (JPROBED.EQ.(JCUT-1)) ...
ENDIF
C
ELSE
C
WRITE(NOUT,*) 'If there is a loop, it must be L or R.'
STOP
C Close IF (LEFTLOOP) ... ELSE IF (RIGHTLOOP) ... ELSE
ENDIF
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
SUBROUTINE CHECKDEFORM2(QBARSQ,CUT,P1,P2)
C
INTEGER SIZE
PARAMETER (SIZE = 3)
C In:
COMPLEX*16 QBARSQ
LOGICAL CUT(3*SIZE-1)
INTEGER P1,P2
C Out: None
C
C This subroutine just checks that the contour deformation was in
C the right direction in the case of a self-energy virtual correction
C on a quark propagator with q^2 >0. Here QBARSQ is the squared
C four-momentum in the dispersive integral. We want to check that the
C sign of the imaginary part of QBARSQ is negative for a virtual loop
C to the left of the final state cut and positive for a virtual loop
C to the right of the final state cut. We use an ad-hoc method rather
C than programming the logic to distinguish the cases since this is
C just a check.
C
C 4 August 1998
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
C
REAL*8 XXIMAG,XXREAL
C--
C
IF ( CUT(2).AND.CUT(3).AND.CUT(5) ) THEN
C
C This is graph 5, with a virtual self energy to the right of the cut.
C
IF ( - XXIMAG(QBARSQ) .GT. ABS(XXREAL(QBARSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 5, R loop?'
WRITE(NOUT,*) QBARSQ
STOP
ENDIF
C
ELSE IF ( CUT(1).AND.CUT(6).AND.CUT(7) ) THEN
C
C This is graph 2, with a virtual self energy to the left of the cut.
C
IF ( XXIMAG(QBARSQ) .GT. ABS(XXREAL(QBARSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 2, L loop?'
WRITE(NOUT,*) QBARSQ
STOP
ENDIF
C
ELSE IF ( CUT(1).AND.CUT(4).AND.CUT(5) ) THEN
IF( (P1.EQ.2).OR.(P2.EQ.2) ) THEN
C
C This is graph 6, with a virtual self-energy to the left of the cut.
C
IF ( XXIMAG(QBARSQ) .GT. ABS(XXREAL(QBARSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 6, L loop?'
WRITE(NOUT,*) QBARSQ
STOP
ENDIF
C
ELSE IF( (P1.EQ.3).OR.(P2.EQ.3) ) THEN
C
C This is graph 2, with a virtual self energy to the right of the cut.
C
IF ( - XXIMAG(QBARSQ) .GT. ABS(XXREAL(QBARSQ)) ) THEN
WRITE(NOUT,*) 'Wrong sign deformation in graph 2, R loop?'
WRITE(NOUT,*) QBARSQ
STOP
ENDIF
C
ELSE
WRITE(NOUT,*) 'Snafu 2 in CHECKDEFORM2'
STOP
ENDIF
C
ELSE
WRITE(NOUT,*) 'Snafu 1 in CHECKDEFORM2'
STOP
ENDIF
RETURN
END
C
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.
C
C
REAL*8 ENERGYSCALE
COMMON /MSCALE/ ENERGYSCALE
C
REAL*8 SMEARFCTR
INTEGER LOWPWR,HIGHPWR
COMMON /SMEARPARMS/ SMEARFCTR,LOWPWR,HIGHPWR
C
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 Numerator Function C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION NUMERATOR(GRAPHNUMBER,KC,CUT)
C
C In:
INTEGER SIZE
PARAMETER (SIZE = 3)
INTEGER GRAPHNUMBER
COMPLEX*16 KC(0:3*SIZE-1,0:3)
LOGICAL CUT(3*SIZE-1)
C
C Numerator function for graph GRAPHNUMBER, with complex momenta KC,
C including the color factor.
C Early version: 17 July 1994
C This version written by Mathematica code of 4 September 1998 on
C 4 Sep 1998
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/
C
INTEGER MU,NU
C
COMPLEX*16 K12,K12G5678,K13,K13G5678
COMPLEX*16 K14,K14G5678,K15,K16
COMPLEX*16 K17,K18,K1Q2854,K1Q3876
COMPLEX*16 K1Q4687,K1Q5687,K1Q6487,K1Q6587
COMPLEX*16 K1Q8254,K1Q8376,K22,K23
COMPLEX*16 K24,K24G5678,K25,K26
COMPLEX*16 K27,K28,K2Q2854,K2Q3876
COMPLEX*16 K2Q5687,K2Q6587,K2Q8254,K2Q8376
COMPLEX*16 K34,K34G5678,K35,K36
COMPLEX*16 K37,K38,K3Q2876,K3Q8276
COMPLEX*16 K45,K46,K47,K48
COMPLEX*16 K56,K57,K58,K67
COMPLEX*16 K68,K78,Q2487Q3165,Q2854Q8376
COMPLEX*16 Q3876Q8254,TRG5678
COMPLEX*16 Q2487(0:3),Q2854(0:3),Q2876(0:3),Q3165(0:3)
COMPLEX*16 Q3876(0:3),Q4687(0:3),Q5687(0:3),Q6487(0:3)
COMPLEX*16 Q6587(0:3),Q8254(0:3),Q8276(0:3),Q8376(0:3)
COMPLEX*16 G5678(0:3,0:3)
C
NUMERATOR = (0.0D0,0.0D0)
C
IF (GRAPHNUMBER.EQ.1) THEN
C
CALL QPROP(CUT,KC,5,6,8,7,-1,-1,Q5687)
CALL QPROP(CUT,KC,6,5,8,7,-1,1,Q6587)
CALL GPROP(CUT,KC,5,6,7,8,1,1,G5678)
K12 = (0.0D0,0.0D0)
K14 = (0.0D0,0.0D0)
K22 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K1Q5687 = (0.0D0,0.0D0)
K1Q6587 = (0.0D0,0.0D0)
K2Q5687 = (0.0D0,0.0D0)
K2Q6587 = (0.0D0,0.0D0)
TRG5678 = (0.0D0,0.0D0)
K14G5678 = (0.0D0,0.0D0)
K24G5678 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K22 = K22 + KC(2,MU)*KC(2,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K1Q5687 = K1Q5687 + KC(1,MU)*Q5687(MU)*METRIC(MU)
K1Q6587 = K1Q6587 + KC(1,MU)*Q6587(MU)*METRIC(MU)
K2Q5687 = K2Q5687 + KC(2,MU)*Q5687(MU)*METRIC(MU)
K2Q6587 = K2Q6587 + KC(2,MU)*Q6587(MU)*METRIC(MU)
TRG5678 = TRG5678 + G5678(MU,MU)*METRIC(MU)
ENDDO
DO MU = 0,3
DO NU = 0,3
K14G5678 = K14G5678
> + KC(1,MU)*KC(4,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
K24G5678 = K24G5678
> + KC(2,MU)*KC(4,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
ENDDO
ENDDO
NUMERATOR = 8*(-1 + NC)*(1 + NC)*(-2*K14G5678*K22 + K1Q5687*K22
> - K1Q6587*K22 + 4*K12*K24G5678 - 2*K12*K2Q5687 + 2*K12*K2Q6587
> + K14*K22*TRG5678 - 2*K12*K24*TRG5678)
C
ELSE IF (GRAPHNUMBER.EQ.2) THEN
C
CALL QPROP(CUT,KC,2,8,5,4,-1,-1,Q2854)
CALL QPROP(CUT,KC,3,8,7,6,-1,-1,Q3876)
CALL QPROP(CUT,KC,8,2,5,4,1,1,Q8254)
CALL QPROP(CUT,KC,8,3,7,6,-1,1,Q8376)
K12 = (0.0D0,0.0D0)
K1Q2854 = (0.0D0,0.0D0)
K1Q3876 = (0.0D0,0.0D0)
K1Q8254 = (0.0D0,0.0D0)
K1Q8376 = (0.0D0,0.0D0)
K2Q2854 = (0.0D0,0.0D0)
K2Q3876 = (0.0D0,0.0D0)
K2Q8254 = (0.0D0,0.0D0)
K2Q8376 = (0.0D0,0.0D0)
Q2854Q8376 = (0.0D0,0.0D0)
Q3876Q8254 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K1Q2854 = K1Q2854 + KC(1,MU)*Q2854(MU)*METRIC(MU)
K1Q3876 = K1Q3876 + KC(1,MU)*Q3876(MU)*METRIC(MU)
K1Q8254 = K1Q8254 + KC(1,MU)*Q8254(MU)*METRIC(MU)
K1Q8376 = K1Q8376 + KC(1,MU)*Q8376(MU)*METRIC(MU)
K2Q2854 = K2Q2854 + KC(2,MU)*Q2854(MU)*METRIC(MU)
K2Q3876 = K2Q3876 + KC(2,MU)*Q3876(MU)*METRIC(MU)
K2Q8254 = K2Q8254 + KC(2,MU)*Q8254(MU)*METRIC(MU)
K2Q8376 = K2Q8376 + KC(2,MU)*Q8376(MU)*METRIC(MU)
Q2854Q8376 = Q2854Q8376 + Q2854(MU)*Q8376(MU)*METRIC(MU)
Q3876Q8254 = Q3876Q8254 + Q3876(MU)*Q8254(MU)*METRIC(MU)
ENDDO
NUMERATOR = 8*NC*(K1Q8376*K2Q2854 + K1Q8254*K2Q3876
> + K1Q3876*K2Q8254 + K1Q2854*K2Q8376 - K12*Q2854Q8376
> - K12*Q3876Q8254)
C
ELSE IF (GRAPHNUMBER.EQ.3) THEN
C
K12 = (0.0D0,0.0D0)
K14 = (0.0D0,0.0D0)
K15 = (0.0D0,0.0D0)
K16 = (0.0D0,0.0D0)
K17 = (0.0D0,0.0D0)
K18 = (0.0D0,0.0D0)
K22 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K25 = (0.0D0,0.0D0)
K26 = (0.0D0,0.0D0)
K27 = (0.0D0,0.0D0)
K28 = (0.0D0,0.0D0)
K45 = (0.0D0,0.0D0)
K56 = (0.0D0,0.0D0)
K57 = (0.0D0,0.0D0)
K58 = (0.0D0,0.0D0)
K67 = (0.0D0,0.0D0)
K78 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K15 = K15 + KC(1,MU)*KC(5,MU)*METRIC(MU)
K16 = K16 + KC(1,MU)*KC(6,MU)*METRIC(MU)
K17 = K17 + KC(1,MU)*KC(7,MU)*METRIC(MU)
K18 = K18 + KC(1,MU)*KC(8,MU)*METRIC(MU)
K22 = K22 + KC(2,MU)*KC(2,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K25 = K25 + KC(2,MU)*KC(5,MU)*METRIC(MU)
K26 = K26 + KC(2,MU)*KC(6,MU)*METRIC(MU)
K27 = K27 + KC(2,MU)*KC(7,MU)*METRIC(MU)
K28 = K28 + KC(2,MU)*KC(8,MU)*METRIC(MU)
K45 = K45 + KC(4,MU)*KC(5,MU)*METRIC(MU)
K56 = K56 + KC(5,MU)*KC(6,MU)*METRIC(MU)
K57 = K57 + KC(5,MU)*KC(7,MU)*METRIC(MU)
K58 = K58 + KC(5,MU)*KC(8,MU)*METRIC(MU)
K67 = K67 + KC(6,MU)*KC(7,MU)*METRIC(MU)
K78 = K78 + KC(7,MU)*KC(8,MU)*METRIC(MU)
ENDDO
NUMERATOR = (16*(-1 + NC)*(1 + NC)*(-2*K18*K22*K56
> + 4*K12*K28*K56 + K17*K22*K45*NC**2 - 2*K12*K27*K45*NC**2
> - K14*K22*K57*NC**2 + K16*K22*K57*NC**2 + 2*K12*K24*K57*NC**2
> - 2*K12*K26*K57*NC**2 + K17*K22*K58*NC**2 - 2*K12*K27*K58*NC**2
> - K15*K22*K67*NC**2 + 2*K12*K25*K67*NC**2 - K15*K22*K78*NC**2
> + 2*K12*K25*K78*NC**2))/NC
C
ELSE IF (GRAPHNUMBER.EQ.4) THEN
C
CALL GPROP(CUT,KC,5,6,7,8,1,1,G5678)
K12 = (0.0D0,0.0D0)
K13 = (0.0D0,0.0D0)
K14 = (0.0D0,0.0D0)
K23 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K34 = (0.0D0,0.0D0)
TRG5678 = (0.0D0,0.0D0)
K12G5678 = (0.0D0,0.0D0)
K13G5678 = (0.0D0,0.0D0)
K24G5678 = (0.0D0,0.0D0)
K34G5678 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K13 = K13 + KC(1,MU)*KC(3,MU)*METRIC(MU)
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K23 = K23 + KC(2,MU)*KC(3,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K34 = K34 + KC(3,MU)*KC(4,MU)*METRIC(MU)
TRG5678 = TRG5678 + G5678(MU,MU)*METRIC(MU)
ENDDO
DO MU = 0,3
DO NU = 0,3
K12G5678 = K12G5678
> + KC(1,MU)*KC(2,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
K13G5678 = K13G5678
> + KC(1,MU)*KC(3,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
K24G5678 = K24G5678
> + KC(2,MU)*KC(4,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
K34G5678 = K34G5678
> + KC(3,MU)*KC(4,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
ENDDO
ENDDO
NUMERATOR = -4*(-1 + NC)*(1 + NC)*(-2*K13G5678*K24
> - 2*K13*K24G5678 + 2*K12G5678*K34 + 2*K12*K34G5678
> + K14*K23*TRG5678 + K13*K24*TRG5678 - K12*K34*TRG5678)
C
ELSE IF (GRAPHNUMBER.EQ.5) THEN
C
CALL QPROP(CUT,KC,4,6,8,7,-1,-1,Q4687)
CALL QPROP(CUT,KC,6,4,8,7,-1,1,Q6487)
K23 = (0.0D0,0.0D0)
K1Q4687 = (0.0D0,0.0D0)
K1Q6487 = (0.0D0,0.0D0)
DO MU = 0,3
K23 = K23 + KC(2,MU)*KC(3,MU)*METRIC(MU)
K1Q4687 = K1Q4687 + KC(1,MU)*Q4687(MU)*METRIC(MU)
K1Q6487 = K1Q6487 + KC(1,MU)*Q6487(MU)*METRIC(MU)
ENDDO
NUMERATOR = -16*(K1Q4687 - K1Q6487)*K23*(-1 + NC)*(1 + NC)
C
ELSE IF (GRAPHNUMBER.EQ.6) THEN
C
CALL QPROP(CUT,KC,2,8,7,6,-1,-1,Q2876)
CALL QPROP(CUT,KC,8,2,7,6,-1,1,Q8276)
K14 = (0.0D0,0.0D0)
K3Q2876 = (0.0D0,0.0D0)
K3Q8276 = (0.0D0,0.0D0)
DO MU = 0,3
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K3Q2876 = K3Q2876 + KC(3,MU)*Q2876(MU)*METRIC(MU)
K3Q8276 = K3Q8276 + KC(3,MU)*Q8276(MU)*METRIC(MU)
ENDDO
NUMERATOR = -16*K14*(K3Q2876 - K3Q8276)*(-1 + NC)*(1 + NC)
C
ELSE IF (GRAPHNUMBER.EQ.7) THEN
C
K12 = (0.0D0,0.0D0)
K13 = (0.0D0,0.0D0)
K14 = (0.0D0,0.0D0)
K15 = (0.0D0,0.0D0)
K16 = (0.0D0,0.0D0)
K17 = (0.0D0,0.0D0)
K18 = (0.0D0,0.0D0)
K23 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K25 = (0.0D0,0.0D0)
K26 = (0.0D0,0.0D0)
K27 = (0.0D0,0.0D0)
K28 = (0.0D0,0.0D0)
K34 = (0.0D0,0.0D0)
K35 = (0.0D0,0.0D0)
K36 = (0.0D0,0.0D0)
K37 = (0.0D0,0.0D0)
K38 = (0.0D0,0.0D0)
K45 = (0.0D0,0.0D0)
K46 = (0.0D0,0.0D0)
K47 = (0.0D0,0.0D0)
K48 = (0.0D0,0.0D0)
K67 = (0.0D0,0.0D0)
K68 = (0.0D0,0.0D0)
K78 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K13 = K13 + KC(1,MU)*KC(3,MU)*METRIC(MU)
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K15 = K15 + KC(1,MU)*KC(5,MU)*METRIC(MU)
K16 = K16 + KC(1,MU)*KC(6,MU)*METRIC(MU)
K17 = K17 + KC(1,MU)*KC(7,MU)*METRIC(MU)
K18 = K18 + KC(1,MU)*KC(8,MU)*METRIC(MU)
K23 = K23 + KC(2,MU)*KC(3,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K25 = K25 + KC(2,MU)*KC(5,MU)*METRIC(MU)
K26 = K26 + KC(2,MU)*KC(6,MU)*METRIC(MU)
K27 = K27 + KC(2,MU)*KC(7,MU)*METRIC(MU)
K28 = K28 + KC(2,MU)*KC(8,MU)*METRIC(MU)
K34 = K34 + KC(3,MU)*KC(4,MU)*METRIC(MU)
K35 = K35 + KC(3,MU)*KC(5,MU)*METRIC(MU)
K36 = K36 + KC(3,MU)*KC(6,MU)*METRIC(MU)
K37 = K37 + KC(3,MU)*KC(7,MU)*METRIC(MU)
K38 = K38 + KC(3,MU)*KC(8,MU)*METRIC(MU)
K45 = K45 + KC(4,MU)*KC(5,MU)*METRIC(MU)
K46 = K46 + KC(4,MU)*KC(6,MU)*METRIC(MU)
K47 = K47 + KC(4,MU)*KC(7,MU)*METRIC(MU)
K48 = K48 + KC(4,MU)*KC(8,MU)*METRIC(MU)
K67 = K67 + KC(6,MU)*KC(7,MU)*METRIC(MU)
K68 = K68 + KC(6,MU)*KC(8,MU)*METRIC(MU)
K78 = K78 + KC(7,MU)*KC(8,MU)*METRIC(MU)
ENDDO
NUMERATOR = (8*(-1 + NC)*(1 + NC)*(2*K18*K27*K34 + 2*K17*K28*K34
> - 2*K18*K24*K37 - 2*K14*K28*K37 - 2*K17*K24*K38 + 2*K14*K27*K38
> - 2*K18*K23*K47 - 2*K13*K28*K47 + 2*K12*K38*K47 + 2*K17*K23*K48
> - 2*K13*K27*K48 + 2*K12*K37*K48 - 2*K14*K23*K78 + 2*K13*K24*K78
> - 2*K12*K34*K78 + K17*K26*K34*NC**2 - K18*K26*K34*NC**2
> + K16*K27*K34*NC**2 - K16*K28*K34*NC**2 - 2*K14*K26*K35*NC**2
> - K17*K24*K36*NC**2 + K18*K24*K36*NC**2 + 2*K14*K25*K36*NC**2
> - K14*K27*K36*NC**2 - K14*K28*K36*NC**2 - K16*K24*K37*NC**2
> + K14*K26*K37*NC**2 + K16*K24*K38*NC**2 + K14*K26*K38*NC**2
> - 2*K16*K23*K45*NC**2 + 2*K15*K23*K46*NC**2 - K17*K23*K46*NC**2
> - K18*K23*K46*NC**2 - K13*K27*K46*NC**2 + K13*K28*K46*NC**2
> + K12*K37*K46*NC**2 - K12*K38*K46*NC**2 + K16*K23*K47*NC**2
> - K13*K26*K47*NC**2 + K12*K36*K47*NC**2 + K16*K23*K48*NC**2
> + K13*K26*K48*NC**2 - K12*K36*K48*NC**2 + 3*K14*K23*K67*NC**2
> + K13*K24*K67*NC**2 - K12*K34*K67*NC**2 - 3*K14*K23*K68*NC**2
> - K13*K24*K68*NC**2 + K12*K34*K68*NC**2))/NC
C
ELSE IF (GRAPHNUMBER.EQ.8) THEN
C
K12 = (0.0D0,0.0D0)
K13 = (0.0D0,0.0D0)
K14 = (0.0D0,0.0D0)
K16 = (0.0D0,0.0D0)
K17 = (0.0D0,0.0D0)
K23 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K26 = (0.0D0,0.0D0)
K27 = (0.0D0,0.0D0)
K34 = (0.0D0,0.0D0)
K36 = (0.0D0,0.0D0)
K37 = (0.0D0,0.0D0)
K46 = (0.0D0,0.0D0)
K47 = (0.0D0,0.0D0)
K67 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K13 = K13 + KC(1,MU)*KC(3,MU)*METRIC(MU)
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K16 = K16 + KC(1,MU)*KC(6,MU)*METRIC(MU)
K17 = K17 + KC(1,MU)*KC(7,MU)*METRIC(MU)
K23 = K23 + KC(2,MU)*KC(3,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K26 = K26 + KC(2,MU)*KC(6,MU)*METRIC(MU)
K27 = K27 + KC(2,MU)*KC(7,MU)*METRIC(MU)
K34 = K34 + KC(3,MU)*KC(4,MU)*METRIC(MU)
K36 = K36 + KC(3,MU)*KC(6,MU)*METRIC(MU)
K37 = K37 + KC(3,MU)*KC(7,MU)*METRIC(MU)
K46 = K46 + KC(4,MU)*KC(6,MU)*METRIC(MU)
K47 = K47 + KC(4,MU)*KC(7,MU)*METRIC(MU)
K67 = K67 + KC(6,MU)*KC(7,MU)*METRIC(MU)
ENDDO
NUMERATOR = (8*(K17*K26*K34 + K16*K27*K34 - K17*K24*K36
> - K14*K27*K36 - K16*K24*K37 + K14*K26*K37 + K17*K23*K46
> - K13*K27*K46 + K12*K37*K46 - K16*K23*K47 - K13*K26*K47
> + K12*K36*K47 + K14*K23*K67 + K13*K24*K67 - K12*K34*K67)*(-1
> + NC)**2*(1 + NC)**2)/NC
C
ELSE IF (GRAPHNUMBER.EQ.9) THEN
C
CALL QPROP(CUT,KC,2,4,8,7,-1,-1,Q2487)
CALL QPROP(CUT,KC,3,1,6,5,-1,1,Q3165)
Q2487Q3165 = (0.0D0,0.0D0)
DO MU = 0,3
Q2487Q3165 = Q2487Q3165 + Q2487(MU)*Q3165(MU)*METRIC(MU)
ENDDO
NUMERATOR = -8*NC*Q2487Q3165
C
ELSE IF (GRAPHNUMBER.EQ.10) THEN
C
K13 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K67 = (0.0D0,0.0D0)
DO MU = 0,3
K13 = K13 + KC(1,MU)*KC(3,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K67 = K67 + KC(6,MU)*KC(7,MU)*METRIC(MU)
ENDDO
NUMERATOR = (-32*K13*K24*K67*(-1 + NC)*(1 + NC))/NC
C
ENDIF
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C Numerator Function for Renormalization C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RNUMERATOR(GRAPHNUMBER,KC,MUMSBAR,CUT)
C
C In:
INTEGER SIZE
PARAMETER (SIZE = 3)
INTEGER GRAPHNUMBER
COMPLEX*16 KC(0:3*SIZE-1,0:3)
REAL*8 MUMSBAR
LOGICAL CUT(3*SIZE-1)
C
C Numerator function for renormalization of graph GRAPHNUMBER,
C with complex momenta KC, including the color factor.
C
C For input here, we want CUT(P) = .TRUE. for the cut propagators
C but not for a propagator with a loopcut.
C
C First version 28 August 1997.
C This version written by Mathematica code of 4 September 1998 on
C 4 Sep 1998
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/
C
INTEGER MU,NU
C
COMPLEX*16 K12,K12G5678,K13,K13G5678
COMPLEX*16 K14,K14G5678,K15,K16
COMPLEX*16 K17,K1L,K1Q2854,K1Q2876
COMPLEX*16 K1Q3876,K1Q4687,K1Q5687,K1Q6487
COMPLEX*16 K1Q6587,K1Q8254,K1Q8276,K1Q8376
COMPLEX*16 K22,K23,K24,K24G5678
COMPLEX*16 K25,K26,K27,K2L
COMPLEX*16 K2Q2854,K2Q3876,K2Q5687,K2Q6587
COMPLEX*16 K2Q8254,K2Q8376,K34,K34G5678
COMPLEX*16 K36,K37,K3L,K3Q2876
COMPLEX*16 K3Q4687,K3Q6487,K3Q8276,K46
COMPLEX*16 K47,K4L,K5L,K67
COMPLEX*16 K6L,K7L,KLL,KLQ2876
COMPLEX*16 KLQ4687,KLQ6487,KLQ8276,NK1
COMPLEX*16 NK2,NK3,NK4,NK5
COMPLEX*16 NK6,NK7,NQ2876,NQ4687
COMPLEX*16 NQ6487,NQ8276,Q2487Q3165,Q2854Q8376
COMPLEX*16 Q3165Q2487,Q3876Q8254,Q8254Q3876,Q8376Q2854
COMPLEX*16 RQQG3AG,RQQG3AGV,RQQG3AQ,RQQG3AQV
COMPLEX*16 RQQG3BG,RQQG3BGV,RQQG3BQ,RQQG3BQV
COMPLEX*16 RQQG3CG,RQQG3CGV,RQQG3CQ,RQQG3CQV
COMPLEX*16 RQQP3AQ,RQQP3AQV,RQQP3BQ,RQQP3BQV
COMPLEX*16 RQQP3CQ,RQQP3CQV,TRG5678
COMPLEX*16 KLOOP(0:3),Q2487(0:3),Q2854(0:3),Q2876(0:3)
COMPLEX*16 Q3165(0:3),Q3876(0:3),Q4687(0:3),Q5687(0:3)
COMPLEX*16 Q6487(0:3),Q6587(0:3),Q8254(0:3),Q8276(0:3)
COMPLEX*16 Q8376(0:3)
COMPLEX*16 G5678(0:3,0:3)
C
RNUMERATOR = (0.0D0,0.0D0)
C
IF (GRAPHNUMBER.EQ.1) THEN
C
C ***** Divergent one loop subgraph is {7, 8}. *****
C
IF (CUT(7).OR.CUT(8)) THEN
C
C The divergent subgraph is cut.
C
RNUMERATOR = (0.00D0,0.00D0)
C
ELSE
C
C The divergent subgraph {7, 8} is virtual.
C
CALL QPROPR(CUT,MUMSBAR,KC,5,6,8,7,-1,-1,Q5687)
CALL QPROPR(CUT,MUMSBAR,KC,6,5,8,7,-1,1,Q6587)
CALL GPROPR(CUT,MUMSBAR,KC,5,6,7,8,1,1,G5678)
K12 = (0.0D0,0.0D0)
K14 = (0.0D0,0.0D0)
K22 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K1Q5687 = (0.0D0,0.0D0)
K1Q6587 = (0.0D0,0.0D0)
K2Q5687 = (0.0D0,0.0D0)
K2Q6587 = (0.0D0,0.0D0)
TRG5678 = (0.0D0,0.0D0)
K14G5678 = (0.0D0,0.0D0)
K24G5678 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K22 = K22 + KC(2,MU)*KC(2,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K1Q5687 = K1Q5687 + KC(1,MU)*Q5687(MU)*METRIC(MU)
K1Q6587 = K1Q6587 + KC(1,MU)*Q6587(MU)*METRIC(MU)
K2Q5687 = K2Q5687 + KC(2,MU)*Q5687(MU)*METRIC(MU)
K2Q6587 = K2Q6587 + KC(2,MU)*Q6587(MU)*METRIC(MU)
TRG5678 = TRG5678 + G5678(MU,MU)*METRIC(MU)
ENDDO
DO MU = 0,3
DO NU = 0,3
K14G5678 = K14G5678
> + KC(1,MU)*KC(4,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
K24G5678 = K24G5678
> + KC(2,MU)*KC(4,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
ENDDO
ENDDO
RNUMERATOR = 8*(-1 + NC)*(1 + NC)*(-2*K14G5678*K22 + K1Q5687*K22
> - K1Q6587*K22 + 4*K12*K24G5678 - 2*K12*K2Q5687 + 2*K12*K2Q6587
> + K14*K22*TRG5678 - 2*K12*K24*TRG5678)
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.2) THEN
C
C ***** Divergent one loop subgraphs are {{4, 5}, {6, 7}}. *****
C
IF (CUT(4).OR.CUT(5)) THEN
C
C The divergent subgraph {6, 7} is virtual.
C
CALL QPROP(CUT,KC,2,8,5,4,-1,-1,Q2854)
CALL QPROP(CUT,KC,8,2,5,4,1,1,Q8254)
CALL QPROPR(CUT,MUMSBAR,KC,3,8,7,6,-1,-1,Q3876)
CALL QPROPR(CUT,MUMSBAR,KC,8,3,7,6,-1,1,Q8376)
K12 = (0.0D0,0.0D0)
K1Q2854 = (0.0D0,0.0D0)
K1Q3876 = (0.0D0,0.0D0)
K1Q8254 = (0.0D0,0.0D0)
K1Q8376 = (0.0D0,0.0D0)
K2Q2854 = (0.0D0,0.0D0)
K2Q3876 = (0.0D0,0.0D0)
K2Q8254 = (0.0D0,0.0D0)
K2Q8376 = (0.0D0,0.0D0)
Q2854Q8376 = (0.0D0,0.0D0)
Q8254Q3876 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K1Q2854 = K1Q2854 + KC(1,MU)*Q2854(MU)*METRIC(MU)
K1Q3876 = K1Q3876 + KC(1,MU)*Q3876(MU)*METRIC(MU)
K1Q8254 = K1Q8254 + KC(1,MU)*Q8254(MU)*METRIC(MU)
K1Q8376 = K1Q8376 + KC(1,MU)*Q8376(MU)*METRIC(MU)
K2Q2854 = K2Q2854 + KC(2,MU)*Q2854(MU)*METRIC(MU)
K2Q3876 = K2Q3876 + KC(2,MU)*Q3876(MU)*METRIC(MU)
K2Q8254 = K2Q8254 + KC(2,MU)*Q8254(MU)*METRIC(MU)
K2Q8376 = K2Q8376 + KC(2,MU)*Q8376(MU)*METRIC(MU)
Q2854Q8376 = Q2854Q8376 + Q2854(MU)*Q8376(MU)*METRIC(MU)
Q8254Q3876 = Q8254Q3876 + Q8254(MU)*Q3876(MU)*METRIC(MU)
ENDDO
RNUMERATOR = 8*NC*(K1Q8376*K2Q2854 + K1Q8254*K2Q3876
> + K1Q3876*K2Q8254 + K1Q2854*K2Q8376 - K12*Q2854Q8376
> - K12*Q8254Q3876)
C
ELSE
C
C The divergent subgraph {4, 5} is virtual.
C
CALL QPROP(CUT,KC,3,8,7,6,-1,-1,Q3876)
CALL QPROP(CUT,KC,8,3,7,6,-1,1,Q8376)
CALL QPROPR(CUT,MUMSBAR,KC,2,8,5,4,-1,-1,Q2854)
CALL QPROPR(CUT,MUMSBAR,KC,8,2,5,4,1,1,Q8254)
K12 = (0.0D0,0.0D0)
K1Q2854 = (0.0D0,0.0D0)
K1Q3876 = (0.0D0,0.0D0)
K1Q8254 = (0.0D0,0.0D0)
K1Q8376 = (0.0D0,0.0D0)
K2Q2854 = (0.0D0,0.0D0)
K2Q3876 = (0.0D0,0.0D0)
K2Q8254 = (0.0D0,0.0D0)
K2Q8376 = (0.0D0,0.0D0)
Q3876Q8254 = (0.0D0,0.0D0)
Q8376Q2854 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K1Q2854 = K1Q2854 + KC(1,MU)*Q2854(MU)*METRIC(MU)
K1Q3876 = K1Q3876 + KC(1,MU)*Q3876(MU)*METRIC(MU)
K1Q8254 = K1Q8254 + KC(1,MU)*Q8254(MU)*METRIC(MU)
K1Q8376 = K1Q8376 + KC(1,MU)*Q8376(MU)*METRIC(MU)
K2Q2854 = K2Q2854 + KC(2,MU)*Q2854(MU)*METRIC(MU)
K2Q3876 = K2Q3876 + KC(2,MU)*Q3876(MU)*METRIC(MU)
K2Q8254 = K2Q8254 + KC(2,MU)*Q8254(MU)*METRIC(MU)
K2Q8376 = K2Q8376 + KC(2,MU)*Q8376(MU)*METRIC(MU)
Q3876Q8254 = Q3876Q8254 + Q3876(MU)*Q8254(MU)*METRIC(MU)
Q8376Q2854 = Q8376Q2854 + Q8376(MU)*Q2854(MU)*METRIC(MU)
ENDDO
RNUMERATOR = 8*NC*(K1Q8376*K2Q2854 + K1Q8254*K2Q3876
> + K1Q3876*K2Q8254 + K1Q2854*K2Q8376 - K12*Q3876Q8254
> - K12*Q8376Q2854)
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.3) THEN
C
C ***** Divergent one loop subgraphs are {{4, 5, 8}, {6, 7, 8}}. *****
C
IF (CUT(4).OR.CUT(5)) THEN
C
C The divergent subgraph {6, 7, 8} is virtual.
C
NK1 = KC(1,0)
NK2 = KC(2,0)
NK5 = KC(5,0)
K12 = (0.0D0,0.0D0)
K15 = (0.0D0,0.0D0)
K1L = (0.0D0,0.0D0)
K22 = (0.0D0,0.0D0)
K25 = (0.0D0,0.0D0)
K2L = (0.0D0,0.0D0)
K5L = (0.0D0,0.0D0)
KLL = (0.0D0,0.0D0)
KLOOP(0) = (0.0D0,0.0D0)
DO MU = 1,3
KLOOP(MU) = (-KC(6,MU) + KC(7,MU) - KC(8,MU))/3.0D0
ENDDO
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K15 = K15 + KC(1,MU)*KC(5,MU)*METRIC(MU)
K1L = K1L + KC(1,MU)*KLOOP(MU)*METRIC(MU)
K22 = K22 + KC(2,MU)*KC(2,MU)*METRIC(MU)
K25 = K25 + KC(2,MU)*KC(5,MU)*METRIC(MU)
K2L = K2L + KC(2,MU)*KLOOP(MU)*METRIC(MU)
K5L = K5L + KC(5,MU)*KLOOP(MU)*METRIC(MU)
KLL = KLL + KLOOP(MU)*KLOOP(MU)*METRIC(MU)
ENDDO
RQQG3AGV = RQQG3AG(KLOOP, MUMSBAR)
RQQG3AQV = RQQG3AQ(KLOOP, MUMSBAR)
RQQG3BGV = RQQG3BG(KLOOP, MUMSBAR)
RQQG3BQV = RQQG3BQ(KLOOP, MUMSBAR)
RQQG3CGV = RQQG3CG(KLOOP, MUMSBAR)
RQQG3CQV = RQQG3CQ(KLOOP, MUMSBAR)
RNUMERATOR = -8*(-1 + NC)*(1 + NC)*(2*K15*K22*RQQG3AGV
> - 4*K12*K25*RQQG3AGV + 2*K15*K22*RQQG3AQV - 4*K12*K25*RQQG3AQV
> + K15*K22*RQQG3BGV - 2*K12*K25*RQQG3BGV - 2*K22*NK1*NK5*RQQG3BGV
> + 4*K12*NK2*NK5*RQQG3BGV + K15*K22*RQQG3BQV - 2*K12*K25*RQQG3BQV
> - 2*K22*NK1*NK5*RQQG3BQV + 4*K12*NK2*NK5*RQQG3BQV
> - 2*K1L*K22*K5L*RQQG3CGV + 4*K12*K2L*K5L*RQQG3CGV
> + K15*K22*KLL*RQQG3CGV - 2*K12*K25*KLL*RQQG3CGV
> - 2*K1L*K22*K5L*RQQG3CQV + 4*K12*K2L*K5L*RQQG3CQV
> + K15*K22*KLL*RQQG3CQV - 2*K12*K25*KLL*RQQG3CQV)
C
ELSE
C
C The divergent subgraph {4, 5, 8} is virtual.
C
NK1 = KC(1,0)
NK2 = KC(2,0)
NK6 = KC(6,0)
NK7 = KC(7,0)
K12 = (0.0D0,0.0D0)
K16 = (0.0D0,0.0D0)
K17 = (0.0D0,0.0D0)
K1L = (0.0D0,0.0D0)
K22 = (0.0D0,0.0D0)
K26 = (0.0D0,0.0D0)
K27 = (0.0D0,0.0D0)
K2L = (0.0D0,0.0D0)
K6L = (0.0D0,0.0D0)
K7L = (0.0D0,0.0D0)
KLL = (0.0D0,0.0D0)
KLOOP(0) = (0.0D0,0.0D0)
DO MU = 1,3
KLOOP(MU) = (-KC(4,MU) + KC(5,MU) - KC(8,MU))/3.0D0
ENDDO
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K16 = K16 + KC(1,MU)*KC(6,MU)*METRIC(MU)
K17 = K17 + KC(1,MU)*KC(7,MU)*METRIC(MU)
K1L = K1L + KC(1,MU)*KLOOP(MU)*METRIC(MU)
K22 = K22 + KC(2,MU)*KC(2,MU)*METRIC(MU)
K26 = K26 + KC(2,MU)*KC(6,MU)*METRIC(MU)
K27 = K27 + KC(2,MU)*KC(7,MU)*METRIC(MU)
K2L = K2L + KC(2,MU)*KLOOP(MU)*METRIC(MU)
K6L = K6L + KC(6,MU)*KLOOP(MU)*METRIC(MU)
K7L = K7L + KC(7,MU)*KLOOP(MU)*METRIC(MU)
KLL = KLL + KLOOP(MU)*KLOOP(MU)*METRIC(MU)
ENDDO
RQQG3AGV = RQQG3AG(KLOOP, MUMSBAR)
RQQG3AQV = RQQG3AQ(KLOOP, MUMSBAR)
RQQG3BGV = RQQG3BG(KLOOP, MUMSBAR)
RQQG3BQV = RQQG3BQ(KLOOP, MUMSBAR)
RQQG3CGV = RQQG3CG(KLOOP, MUMSBAR)
RQQG3CQV = RQQG3CQ(KLOOP, MUMSBAR)
RNUMERATOR = 8*(-1 + NC)*(1 + NC)*(2*K17*K22*RQQG3AGV
> - 4*K12*K27*RQQG3AGV + 2*K16*K22*RQQG3AQV - 4*K12*K26*RQQG3AQV
> + K17*K22*RQQG3BGV - 2*K12*K27*RQQG3BGV - 2*K22*NK1*NK7*RQQG3BGV
> + 4*K12*NK2*NK7*RQQG3BGV + K16*K22*RQQG3BQV - 2*K12*K26*RQQG3BQV
> - 2*K22*NK1*NK6*RQQG3BQV + 4*K12*NK2*NK6*RQQG3BQV
> - 2*K1L*K22*K7L*RQQG3CGV + 4*K12*K2L*K7L*RQQG3CGV
> + K17*K22*KLL*RQQG3CGV - 2*K12*K27*KLL*RQQG3CGV
> - 2*K1L*K22*K6L*RQQG3CQV + 4*K12*K2L*K6L*RQQG3CQV
> + K16*K22*KLL*RQQG3CQV - 2*K12*K26*KLL*RQQG3CQV)
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.4) THEN
C
C ***** Divergent one loop subgraph is {7, 8}. *****
C
IF (CUT(7).OR.CUT(8)) THEN
C
C The divergent subgraph is cut.
C
RNUMERATOR = (0.00D0,0.00D0)
C
ELSE
C
C The divergent subgraph {7, 8} is virtual.
C
CALL GPROPR(CUT,MUMSBAR,KC,5,6,7,8,1,1,G5678)
K12 = (0.0D0,0.0D0)
K13 = (0.0D0,0.0D0)
K14 = (0.0D0,0.0D0)
K23 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K34 = (0.0D0,0.0D0)
TRG5678 = (0.0D0,0.0D0)
K12G5678 = (0.0D0,0.0D0)
K13G5678 = (0.0D0,0.0D0)
K24G5678 = (0.0D0,0.0D0)
K34G5678 = (0.0D0,0.0D0)
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K13 = K13 + KC(1,MU)*KC(3,MU)*METRIC(MU)
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K23 = K23 + KC(2,MU)*KC(3,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K34 = K34 + KC(3,MU)*KC(4,MU)*METRIC(MU)
TRG5678 = TRG5678 + G5678(MU,MU)*METRIC(MU)
ENDDO
DO MU = 0,3
DO NU = 0,3
K12G5678 = K12G5678
> + KC(1,MU)*KC(2,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
K13G5678 = K13G5678
> + KC(1,MU)*KC(3,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
K24G5678 = K24G5678
> + KC(2,MU)*KC(4,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
K34G5678 = K34G5678
> + KC(3,MU)*KC(4,NU)*G5678(MU,NU)*METRIC(MU)*METRIC(NU)
ENDDO
ENDDO
RNUMERATOR = -4*(-1 + NC)*(1 + NC)*(-2*K13G5678*K24
> - 2*K13*K24G5678 + 2*K12G5678*K34 + 2*K12*K34G5678
> + K14*K23*TRG5678 + K13*K24*TRG5678 - K12*K34*TRG5678)
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.5) THEN
C
C ***** Divergent one loop subgraphs are {{7, 8}, {1, 2, 5}}. *****
C
IF (CUT(7).OR.CUT(8)) THEN
C
C The divergent subgraph {1, 2, 5} is virtual.
C
CALL QPROP(CUT,KC,4,6,8,7,-1,-1,Q4687)
CALL QPROP(CUT,KC,6,4,8,7,-1,1,Q6487)
NK3 = KC(3,0)
NQ4687 = Q4687(0)
NQ6487 = Q6487(0)
K3L = (0.0D0,0.0D0)
KLL = (0.0D0,0.0D0)
K3Q4687 = (0.0D0,0.0D0)
K3Q6487 = (0.0D0,0.0D0)
KLQ4687 = (0.0D0,0.0D0)
KLQ6487 = (0.0D0,0.0D0)
KLOOP(0) = (0.0D0,0.0D0)
DO MU = 1,3
KLOOP(MU) = (-KC(1,MU) + KC(2,MU) - KC(5,MU))/3.0D0
ENDDO
DO MU = 0,3
K3L = K3L + KC(3,MU)*KLOOP(MU)*METRIC(MU)
KLL = KLL + KLOOP(MU)*KLOOP(MU)*METRIC(MU)
K3Q4687 = K3Q4687 + KC(3,MU)*Q4687(MU)*METRIC(MU)
K3Q6487 = K3Q6487 + KC(3,MU)*Q6487(MU)*METRIC(MU)
KLQ4687 = KLQ4687 + KLOOP(MU)*Q4687(MU)*METRIC(MU)
KLQ6487 = KLQ6487 + KLOOP(MU)*Q6487(MU)*METRIC(MU)
ENDDO
RQQP3AQV = RQQP3AQ(KLOOP, MUMSBAR)
RQQP3BQV = RQQP3BQ(KLOOP, MUMSBAR)
RQQP3CQV = RQQP3CQ(KLOOP, MUMSBAR)
RNUMERATOR = -4*NC*(2*K3Q4687*RQQP3AQV - 2*K3Q6487*RQQP3AQV
> + K3Q4687*RQQP3BQV - K3Q6487*RQQP3BQV - 2*NK3*NQ4687*RQQP3BQV
> + 2*NK3*NQ6487*RQQP3BQV + K3Q4687*KLL*RQQP3CQV
> - K3Q6487*KLL*RQQP3CQV - 2*K3L*KLQ4687*RQQP3CQV
> + 2*K3L*KLQ6487*RQQP3CQV)
C
ELSE
C
C The divergent subgraph {7, 8} is virtual.
C
CALL QPROPR(CUT,MUMSBAR,KC,4,6,8,7,-1,-1,Q4687)
CALL QPROPR(CUT,MUMSBAR,KC,6,4,8,7,-1,1,Q6487)
K23 = (0.0D0,0.0D0)
K1Q4687 = (0.0D0,0.0D0)
K1Q6487 = (0.0D0,0.0D0)
DO MU = 0,3
K23 = K23 + KC(2,MU)*KC(3,MU)*METRIC(MU)
K1Q4687 = K1Q4687 + KC(1,MU)*Q4687(MU)*METRIC(MU)
K1Q6487 = K1Q6487 + KC(1,MU)*Q6487(MU)*METRIC(MU)
ENDDO
RNUMERATOR = -16*(K1Q4687 - K1Q6487)*K23*(-1 + NC)*(1 + NC)
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.6) THEN
C
C ***** Divergent one loop subgraphs are {{6, 7}, {3, 4, 5}}. *****
C
IF (CUT(6).OR.CUT(7)) THEN
C
C The divergent subgraph {3, 4, 5} is virtual.
C
CALL QPROP(CUT,KC,2,8,7,6,-1,-1,Q2876)
CALL QPROP(CUT,KC,8,2,7,6,-1,1,Q8276)
NK1 = KC(1,0)
NQ2876 = Q2876(0)
NQ8276 = Q8276(0)
K1L = (0.0D0,0.0D0)
KLL = (0.0D0,0.0D0)
K1Q2876 = (0.0D0,0.0D0)
K1Q8276 = (0.0D0,0.0D0)
KLQ2876 = (0.0D0,0.0D0)
KLQ8276 = (0.0D0,0.0D0)
KLOOP(0) = (0.0D0,0.0D0)
DO MU = 1,3
KLOOP(MU) = (-KC(3,MU) + KC(4,MU) - KC(5,MU))/3.0D0
ENDDO
DO MU = 0,3
K1L = K1L + KC(1,MU)*KLOOP(MU)*METRIC(MU)
KLL = KLL + KLOOP(MU)*KLOOP(MU)*METRIC(MU)
K1Q2876 = K1Q2876 + KC(1,MU)*Q2876(MU)*METRIC(MU)
K1Q8276 = K1Q8276 + KC(1,MU)*Q8276(MU)*METRIC(MU)
KLQ2876 = KLQ2876 + KLOOP(MU)*Q2876(MU)*METRIC(MU)
KLQ8276 = KLQ8276 + KLOOP(MU)*Q8276(MU)*METRIC(MU)
ENDDO
RQQP3AQV = RQQP3AQ(KLOOP, MUMSBAR)
RQQP3BQV = RQQP3BQ(KLOOP, MUMSBAR)
RQQP3CQV = RQQP3CQ(KLOOP, MUMSBAR)
RNUMERATOR = -4*NC*(2*K1Q2876*RQQP3AQV - 2*K1Q8276*RQQP3AQV
> + K1Q2876*RQQP3BQV - K1Q8276*RQQP3BQV - 2*NK1*NQ2876*RQQP3BQV
> + 2*NK1*NQ8276*RQQP3BQV + K1Q2876*KLL*RQQP3CQV
> - K1Q8276*KLL*RQQP3CQV - 2*K1L*KLQ2876*RQQP3CQV
> + 2*K1L*KLQ8276*RQQP3CQV)
C
ELSE
C
C The divergent subgraph {6, 7} is virtual.
C
CALL QPROPR(CUT,MUMSBAR,KC,2,8,7,6,-1,-1,Q2876)
CALL QPROPR(CUT,MUMSBAR,KC,8,2,7,6,-1,1,Q8276)
K14 = (0.0D0,0.0D0)
K3Q2876 = (0.0D0,0.0D0)
K3Q8276 = (0.0D0,0.0D0)
DO MU = 0,3
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K3Q2876 = K3Q2876 + KC(3,MU)*Q2876(MU)*METRIC(MU)
K3Q8276 = K3Q8276 + KC(3,MU)*Q8276(MU)*METRIC(MU)
ENDDO
RNUMERATOR = -16*K14*(K3Q2876 - K3Q8276)*(-1 + NC)*(1 + NC)
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.7) THEN
C
C ***** Divergent one loop subgraph is {6, 7, 8}. *****
C
IF (CUT(6).OR.CUT(7)) THEN
C
C The divergent subgraph is cut.
C
RNUMERATOR = (0.00D0,0.00D0)
C
ELSE
C
C The divergent subgraph {6, 7, 8} is virtual.
C
NK1 = KC(1,0)
NK2 = KC(2,0)
NK3 = KC(3,0)
NK4 = KC(4,0)
K12 = (0.0D0,0.0D0)
K13 = (0.0D0,0.0D0)
K14 = (0.0D0,0.0D0)
K1L = (0.0D0,0.0D0)
K23 = (0.0D0,0.0D0)
K24 = (0.0D0,0.0D0)
K2L = (0.0D0,0.0D0)
K34 = (0.0D0,0.0D0)
K3L = (0.0D0,0.0D0)
K4L = (0.0D0,0.0D0)
KLL = (0.0D0,0.0D0)
KLOOP(0) = (0.0D0,0.0D0)
DO MU = 1,3
KLOOP(MU) = (-KC(6,MU) + KC(7,MU) - KC(8,MU))/3.0D0
ENDDO
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K13 = K13 + KC(1,MU)*KC(3,MU)*METRIC(MU)
K14 = K14 + KC(1,MU)*KC(4,MU)*METRIC(MU)
K1L = K1L + KC(1,MU)*KLOOP(MU)*METRIC(MU)
K23 = K23 + KC(2,MU)*KC(3,MU)*METRIC(MU)
K24 = K24 + KC(2,MU)*KC(4,MU)*METRIC(MU)
K2L = K2L + KC(2,MU)*KLOOP(MU)*METRIC(MU)
K34 = K34 + KC(3,MU)*KC(4,MU)*METRIC(MU)
K3L = K3L + KC(3,MU)*KLOOP(MU)*METRIC(MU)
K4L = K4L + KC(4,MU)*KLOOP(MU)*METRIC(MU)
KLL = KLL + KLOOP(MU)*KLOOP(MU)*METRIC(MU)
ENDDO
RQQG3AGV = RQQG3AG(KLOOP, MUMSBAR)
RQQG3AQV = RQQG3AQ(KLOOP, MUMSBAR)
RQQG3BGV = RQQG3BG(KLOOP, MUMSBAR)
RQQG3BQV = RQQG3BQ(KLOOP, MUMSBAR)
RQQG3CGV = RQQG3CG(KLOOP, MUMSBAR)
RQQG3CQV = RQQG3CQ(KLOOP, MUMSBAR)
RNUMERATOR = 8*(-1 + NC)*(1 + NC)*(4*K14*K23*RQQG3AGV
> + 4*K14*K23*RQQG3AQV + K14*K23*RQQG3BGV + K13*K24*RQQG3BGV
> - K12*K34*RQQG3BGV + 2*K34*NK1*NK2*RQQG3BGV
> - 2*K24*NK1*NK3*RQQG3BGV - 2*K13*NK2*NK4*RQQG3BGV
> + 2*K12*NK3*NK4*RQQG3BGV + K14*K23*RQQG3BQV + K13*K24*RQQG3BQV
> - K12*K34*RQQG3BQV + 2*K34*NK1*NK2*RQQG3BQV
> - 2*K24*NK1*NK3*RQQG3BQV - 2*K13*NK2*NK4*RQQG3BQV
> + 2*K12*NK3*NK4*RQQG3BQV + 2*K1L*K2L*K34*RQQG3CGV
> - 2*K1L*K24*K3L*RQQG3CGV - 2*K13*K2L*K4L*RQQG3CGV
> + 2*K12*K3L*K4L*RQQG3CGV + K14*K23*KLL*RQQG3CGV
> + K13*K24*KLL*RQQG3CGV - K12*K34*KLL*RQQG3CGV
> + 2*K1L*K2L*K34*RQQG3CQV - 2*K1L*K24*K3L*RQQG3CQV
> - 2*K13*K2L*K4L*RQQG3CQV + 2*K12*K3L*K4L*RQQG3CQV
> + K14*K23*KLL*RQQG3CQV + K13*K24*KLL*RQQG3CQV
> - K12*K34*KLL*RQQG3CQV)
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.8) THEN
C
C ***** Divergent one loop subgraphs are {{1, 2, 5}, {3, 4, 8}}. *****
C
IF (CUT(1).OR.CUT(2)) THEN
C
C The divergent subgraph {3, 4, 8} is virtual.
C
NK1 = KC(1,0)
NK2 = KC(2,0)
NK6 = KC(6,0)
NK7 = KC(7,0)
K12 = (0.0D0,0.0D0)
K16 = (0.0D0,0.0D0)
K17 = (0.0D0,0.0D0)
K1L = (0.0D0,0.0D0)
K26 = (0.0D0,0.0D0)
K27 = (0.0D0,0.0D0)
K2L = (0.0D0,0.0D0)
K67 = (0.0D0,0.0D0)
K6L = (0.0D0,0.0D0)
K7L = (0.0D0,0.0D0)
KLL = (0.0D0,0.0D0)
KLOOP(0) = (0.0D0,0.0D0)
DO MU = 1,3
KLOOP(MU) = (-KC(3,MU) + KC(4,MU) - KC(8,MU))/3.0D0
ENDDO
DO MU = 0,3
K12 = K12 + KC(1,MU)*KC(2,MU)*METRIC(MU)
K16 = K16 + KC(1,MU)*KC(6,MU)*METRIC(MU)
K17 = K17 + KC(1,MU)*KC(7,MU)*METRIC(MU)
K1L = K1L + KC(1,MU)*KLOOP(MU)*METRIC(MU)
K26 = K26 + KC(2,MU)*KC(6,MU)*METRIC(MU)
K27 = K27 + KC(2,MU)*KC(7,MU)*METRIC(MU)
K2L = K2L + KC(2,MU)*KLOOP(MU)*METRIC(MU)
K67 = K67 + KC(6,MU)*KC(7,MU)*METRIC(MU)
K6L = K6L + KC(6,MU)*KLOOP(MU)*METRIC(MU)
K7L = K7L + KC(7,MU)*KLOOP(MU)*METRIC(MU)
KLL = KLL + KLOOP(MU)*KLOOP(MU)*METRIC(MU)
ENDDO
RQQP3AQV = RQQP3AQ(KLOOP, MUMSBAR)
RQQP3BQV = RQQP3BQ(KLOOP, MUMSBAR)
RQQP3CQV = RQQP3CQ(KLOOP, MUMSBAR)
RNUMERATOR = 4*(-1 + NC)*(1 + NC)*(4*K17*K26*RQQP3AQV
> + K17*K26*RQQP3BQV - K16*K27*RQQP3BQV + K12*K67*RQQP3BQV
> - 2*K67*NK1*NK2*RQQP3BQV + 2*K27*NK1*NK6*RQQP3BQV
> + 2*K16*NK2*NK7*RQQP3BQV - 2*K12*NK6*NK7*RQQP3BQV
> - 2*K1L*K2L*K67*RQQP3CQV + 2*K1L*K27*K6L*RQQP3CQV
> + 2*K16*K2L*K7L*RQQP3CQV - 2*K12*K6L*K7L*RQQP3CQV
> + K17*K26*KLL*RQQP3CQV - K16*K27*KLL*RQQP3CQV
> + K12*K67*KLL*RQQP3CQV)
C
ELSE
C
C The divergent subgraph {1, 2, 5} is virtual.
C
NK3 = KC(3,0)
NK4 = KC(4,0)
NK6 = KC(6,0)
NK7 = KC(7,0)
K34 = (0.0D0,0.0D0)
K36 = (0.0D0,0.0D0)
K37 = (0.0D0,0.0D0)
K3L = (0.0D0,0.0D0)
K46 = (0.0D0,0.0D0)
K47 = (0.0D0,0.0D0)
K4L = (0.0D0,0.0D0)
K67 = (0.0D0,0.0D0)
K6L = (0.0D0,0.0D0)
K7L = (0.0D0,0.0D0)
KLL = (0.0D0,0.0D0)
KLOOP(0) = (0.0D0,0.0D0)
DO MU = 1,3
KLOOP(MU) = (-KC(1,MU) + KC(2,MU) - KC(5,MU))/3.0D0
ENDDO
DO MU = 0,3
K34 = K34 + KC(3,MU)*KC(4,MU)*METRIC(MU)
K36 = K36 + KC(3,MU)*KC(6,MU)*METRIC(MU)
K37 = K37 + KC(3,MU)*KC(7,MU)*METRIC(MU)
K3L = K3L + KC(3,MU)*KLOOP(MU)*METRIC(MU)
K46 = K46 + KC(4,MU)*KC(6,MU)*METRIC(MU)
K47 = K47 + KC(4,MU)*KC(7,MU)*METRIC(MU)
K4L = K4L + KC(4,MU)*KLOOP(MU)*METRIC(MU)
K67 = K67 + KC(6,MU)*KC(7,MU)*METRIC(MU)
K6L = K6L + KC(6,MU)*KLOOP(MU)*METRIC(MU)
K7L = K7L + KC(7,MU)*KLOOP(MU)*METRIC(MU)
KLL = KLL + KLOOP(MU)*KLOOP(MU)*METRIC(MU)
ENDDO
RQQP3AQV = RQQP3AQ(KLOOP, MUMSBAR)
RQQP3BQV = RQQP3BQ(KLOOP, MUMSBAR)
RQQP3CQV = RQQP3CQ(KLOOP, MUMSBAR)
RNUMERATOR = 4*(-1 + NC)*(1 + NC)*(4*K37*K46*RQQP3AQV
> + K37*K46*RQQP3BQV - K36*K47*RQQP3BQV + K34*K67*RQQP3BQV
> - 2*K67*NK3*NK4*RQQP3BQV + 2*K47*NK3*NK6*RQQP3BQV
> + 2*K36*NK4*NK7*RQQP3BQV - 2*K34*NK6*NK7*RQQP3BQV
> - 2*K3L*K4L*K67*RQQP3CQV + 2*K3L*K47*K6L*RQQP3CQV
> + 2*K36*K4L*K7L*RQQP3CQV - 2*K34*K6L*K7L*RQQP3CQV
> + K37*K46*KLL*RQQP3CQV - K36*K47*KLL*RQQP3CQV
> + K34*K67*KLL*RQQP3CQV)
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.9) THEN
C
C ***** Divergent one loop subgraphs are {{5, 6}, {7, 8}}. *****
C
IF (CUT(5).OR.CUT(6)) THEN
C
C The divergent subgraph {7, 8} is virtual.
C
CALL QPROP(CUT,KC,3,1,6,5,-1,1,Q3165)
CALL QPROPR(CUT,MUMSBAR,KC,2,4,8,7,-1,-1,Q2487)
Q3165Q2487 = (0.0D0,0.0D0)
DO MU = 0,3
Q3165Q2487 = Q3165Q2487 + Q3165(MU)*Q2487(MU)*METRIC(MU)
ENDDO
RNUMERATOR = -8*NC*Q3165Q2487
C
ELSE
C
C The divergent subgraph {5, 6} is virtual.
C
CALL QPROP(CUT,KC,2,4,8,7,-1,-1,Q2487)
CALL QPROPR(CUT,MUMSBAR,KC,3,1,6,5,-1,1,Q3165)
Q2487Q3165 = (0.0D0,0.0D0)
DO MU = 0,3
Q2487Q3165 = Q2487Q3165 + Q2487(MU)*Q3165(MU)*METRIC(MU)
ENDDO
RNUMERATOR = -8*NC*Q2487Q3165
C
ENDIF
C
ELSE IF (GRAPHNUMBER.EQ.10) THEN
C
C ***** There is no divergent one loop subgraph. *****
C
RNUMERATOR = (0.00D0,0.00D0)
C
C
ENDIF
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C Propagator Functions C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
SUBROUTINE QPROP(CUT,KC,P1,P2,PQ,PG,S1,SQ,RESULT)
C In:
INTEGER SIZE
PARAMETER (SIZE = 3)
LOGICAL CUT(3*SIZE-1)
COMPLEX*16 KC(0:3*SIZE-1,0:3)
INTEGER P1,P2,PQ,PG,S1,SQ
C Out:
COMPLEX*16 RESULT(0:3)
C
C A quark self-energy subgraph, together with its adjoining propagator
C factors, becomes
C
C sequark[p1,p2,pq,pg,s1,sq]_mu * gamma^mu
C
C where sequark is a four-vector, the RESULT here, and
C p1 is the label of the outgoing quark line,
C s1 = +1 if this line carries momentum in the quark direction,
C s1 = -1 otherwise;
C p2 is the label of the ingoing quark line;
C pq is the label of the internal quark line,
C sq = +1 if this line carries momentum in the quark direstion,
C sq = -1 otherwise;
C pg is the label of the internal gluon line.
C
C This subroutine calculates the integrand for sequark^mu. There
C are three cases:
C
C 1) self-energy subgraph is cut.
C 2) self-energy subgraph is virtual, an adjoining propagator is cut.
C 3) self-energy subgraph is virtual, adnoining propagators not cut.
C
C We let Q^mu be the incoming quark 3-momentum,
C KQ^mu be the 3-momentum carried by the internal quark line,
C KG^mu be the 3-momentum carried by the internal gluon line.
C
C 4 January 1998
C 4 August 1998 Add call to CHECKDEFORM2
C 4 September 1998 Add color factors
C 21 September 1998 Fix color factors
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 Q(1:3),KQ(1:3),KG(1:3)
COMPLEX*16 QSQ,KQSQ,KGSQ,ABSQ,ABSKQ,ABSKG
COMPLEX*16 EQ,EBAR,QBARSQ,Q4SQ
COMPLEX*16 PREFACTOR,SPECIAL
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
EQ = S1*KC(P1,0)
QSQ = (0.0D0,0.0D0)
KQSQ = (0.0D0,0.0D0)
KGSQ = (0.0D0,0.0D0)
DO MU = 1,3
Q(MU) = S1*KC(P1,MU)
KQ(MU) = SQ*KC(PQ,MU)
KG(MU) = Q(MU) - KQ(MU)
QSQ = QSQ + Q(MU)**2
KQSQ = KQSQ + KQ(MU)**2
KGSQ = KGSQ + KG(MU)**2
ENDDO
C
ABSQ = COMPLEXSQRT(QSQ)
ABSKQ = COMPLEXSQRT(KQSQ)
ABSKG = COMPLEXSQRT(KGSQ)
C
EBAR = ABSKG + ABSKQ
QBARSQ = EBAR**2 - QSQ
PREFACTOR = (NC**2 - 1)/(4*NC*ABSKG*ABSKQ*ABSQ*QBARSQ)
C
C Now we need the proper special factor for each special case.
C The first case is that of a cut self-energy.
C In the second case, the self-energy subgraph is virtual, but
C one of the adjoing propagators is cut. There are two such cuts
C possible. For each of them, we have a factor 1/2 (and a minus sign).
C In the third case, the self-energy subgraph and both of the
C adjoinging propagaators is virtual. Here Q4SQ is the square of the
C four-vector q^mu.
C
IF (CUT(PQ).AND.CUT(PG)) THEN
SPECIAL = ABSQ/EBAR
ELSE IF (CUT(P1).OR.CUT(P2)) THEN
SPECIAL = (-0.5D0,0.0D0)
ELSE
CALL CHECKDEFORM2(QBARSQ,CUT,P1,P2)
Q4SQ = EQ**2 - QSQ
SPECIAL = - 2.0D0*ABSQ*QBARSQ/(Q4SQ*(QBARSQ-Q4SQ))
ENDIF
C
C Finally, we assemble the result.
C
RESULT(0) = SPECIAL*PREFACTOR*EQ*ABSKG
DO MU = 1,3
RESULT(MU) = SPECIAL*PREFACTOR*EBAR*KG(MU)
ENDDO
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
SUBROUTINE QPROPR(CUT,MUMSBAR,KC,P1,P2,PQ,PG,S1,SQ,RESULT)
C In:
INTEGER SIZE
PARAMETER (SIZE = 3)
LOGICAL CUT(3*SIZE-1)
REAL*8 MUMSBAR
COMPLEX*16 KC(0:3*SIZE-1,0:3)
INTEGER P1,P2,PQ,PG,S1,SQ
C Out:
COMPLEX*16 RESULT(0:3)
C
C A quark self-energy subgraph, together with its adjoining propagator
C factors, becomes
C
C sequark[p1,p2,pq,pg,s1,sq]_mu * gamma^mu
C
C where sequark is a four-vector, the RESULT here, and
C p1 is the label of the outgoing quark line,
C s1 = +1 if this line carries momentum in the quark direction,
C s1 = -1 otherwise;
C p2 is the label of the ingoing quark line;
C pq is the label of the internal quark line,
C sq = +1 if this line carries momentum in the quark direstion,
C sq = -1 otherwise;
C pg is the label of the internal gluon line.
C
C This subroutine calculates the integrand for the renormalization
C counterterm sequark^mu. There are three cases:
C
C 1) self-energy subgraph is cut. (QPROPR not called in this case)
C 2) self-energy subgraph is virtual, an adjoining propagator is cut.
C 3) self-energy subgraph is virtual, adjoining propagators not cut.
C
C We let Q^mu be the incoming quark 3-momentum,
C KQ^mu be the 3-momentum carried by the internal quark line,
C KG^mu be the 3-momentum carried by the internal gluon line.
C
C 10 January 1998
C 4 September 1998 Add color factors
C 28 October 1998 Add another subtraction term.
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 Q(1:3),KQ(1:3),ELL(1:3)
COMPLEX*16 QSQ,ELLSQ,ABSQ
COMPLEX*16 EQ,Q4SQ,DOTQL
COMPLEX*16 DENOM,PREFACTOR,SPECIAL
COMPLEX*16 FACTOREQ,FACTORQ,FACTORL
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
EQ = S1*KC(P1,0)
QSQ = (0.0D0,0.0D0)
ELLSQ = (0.0D0,0.0D0)
DOTQL = (0.0D0,0.0D0)
DO MU = 1,3
Q(MU) = S1*KC(P1,MU)
KQ(MU) = SQ*KC(PQ,MU)
ELL(MU) = 0.5D0*Q(MU) - KQ(MU)
QSQ = QSQ + Q(MU)**2
ELLSQ = ELLSQ + ELL(MU)**2
DOTQL = DOTQL + Q(MU)*ELL(MU)
ENDDO
C
ABSQ = COMPLEXSQRT(QSQ)
C
DENOM = ELLSQ + MUMSBAR**2
PREFACTOR = (NC**2 - 1)/(16*NC*ABSQ*COMPLEXSQRT(DENOM)**3)
FACTOREQ = (DOTQL + 3*MUMSBAR**2)/(2*DENOM)
FACTORQ = 3*MUMSBAR**2/(2*DENOM)
FACTORL = (2*EQ**2 - 3*QSQ + 12*MUMSBAR**2)*ELLSQ + 5*DOTQL**2
FACTORL = FACTORL /(4*DENOM**2)
C
C Now we need the proper special factor for each special case.
C The first case is that of a cut self-energy.
C In the second case, the self-energy subgraph is virtual, but
C one of the adjoing propagators is cut. There are two such cuts
C possible. For each of them, we have a factor 1/2 (and a minus sign).
C In the third case, the self-energy subgraph and both of the
C adjoinging propagaators is virtual. Here Q4SQ is the square of the
C four-vector q^mu.
C
IF (CUT(PQ).AND.CUT(PG)) THEN
WRITE(NOUT,*)'Something is rotten in QPROPR.'
STOP
ELSE IF (CUT(P1).OR.CUT(P2)) THEN
SPECIAL = (-0.5D0,0.0D0)
ELSE
Q4SQ = EQ**2 - QSQ
SPECIAL = - 2.0D0*ABSQ/Q4SQ
ENDIF
C
C Finally, we assemble the result.
C
RESULT(0) = SPECIAL*PREFACTOR*(EQ + FACTOREQ*EQ)
DO MU = 1,3
RESULT(MU) = SPECIAL*PREFACTOR*
> (2*ELL(MU) + Q(MU) + FACTORQ*Q(MU) + FACTORL*ELL(MU))
ENDDO
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
SUBROUTINE GPROP(CUT,KC,P1,P2,PG1,PG2,S1,SG1,RESULT)
C In:
INTEGER SIZE
PARAMETER (SIZE = 3)
LOGICAL CUT(3*SIZE-1)
COMPLEX*16 KC(0:3*SIZE-1,0:3)
INTEGER P1,P2,PG1,PG2,S1,SG1
C Out:
COMPLEX*16 RESULT(0:3,0:3)
C
C A gluon self-energy subgraph, together with its adjoining propagator
C factors, becomes
C
C seglue[p1,p2,pg1,pg2,s1,sg1]^{mu,nu}
C
C where seglue is a second rank tensor, the RESULT here, with
C seglue^{0i} = seglue{i,0} = seglue(0,0) = 0 for a virtual
C graph at q^2 = 0, but not for the cut graph. Here
C p1 is the label of the incoming gluon line,
C s1 = +1 if this line carries momentum into the graph,
C s1 = -1 otherwise;
C p2 is the label of the outgoing line;
C pg1 is the label of one of the the internal parton lines,
C sg1 = +1 if this line carries momentum away from the vertex
C at which p1 joins the subgraph,
C sg1 = -1 otherwise;
C pg2 is the label of the other internal parton line.
C
C
C 13 January 1998
C 7 April 1998
C 4 September 1998 Add color factors
C 12 January 2001 Add Result(0,i) term for virtual case.
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
REAL*8 DELTA
COMPLEX*16 QSQ,Q4SQ,ELLSQ,ELL4SQ,KG1SQ,KG2SQ,DOTQELL
COMPLEX*16 ABSQ,ABSKG1,ABSKG2
COMPLEX*16 KG1(3),KG2(3),Q(3),Q0,ELL(3),ELL0
COMPLEX*16 ELLP(0:3),T(0:3,0:3)
COMPLEX*16 PREFACTOR,SPECIAL,TEMP,G0I
COMPLEX*16 COMPLEXSQRT
INTEGER CUTSIGN
REAL*8 XXREAL
INTEGER MU,NU
C
C We define CUTSIGN to be +1 if the self-energy subgraph crosses
C the final state cut with propagator P1 to the left and P2 to
C the right, -1 if it is the other way around. This allows us
C to choose the signs so that q^mu is flowing toward the cut.
C
IF (S1*XXREAL(KC(P1,0)).GT.0.0D0) THEN
CUTSIGN = 1
ELSE
CUTSIGN = -1
ENDIF
C
QSQ = (0.0D0,0.0D0)
ELLSQ = (0.0D0,0.0D0)
KG1SQ = (0.0D0,0.0D0)
KG2SQ = (0.0D0,0.0D0)
DOTQELL = (0.0D0,0.0D0)
DO MU = 1,3
Q(MU) = CUTSIGN*S1*KC(P1,MU)
KG1(MU) = CUTSIGN*SG1*KC(PG1,MU)
KG2(MU) = Q(MU) - KG1(MU)
ELL(MU) = KG1(MU) - 0.5D0*Q(MU)
QSQ = QSQ + Q(MU)**2
ELLSQ = ELLSQ + ELL(MU)**2
DOTQELL = DOTQELL + Q(MU)*ELL(MU)
KG1SQ = KG1SQ + KG1(MU)**2
KG2SQ = KG2SQ + KG2(MU)**2
ENDDO
ABSQ = COMPLEXSQRT(QSQ)
ABSKG1 = COMPLEXSQRT(KG1SQ)
ABSKG2 = COMPLEXSQRT(KG2SQ)
C
Q0 = ABSKG1 + ABSKG2
ELL0 = 0.5D0*(ABSKG1 - ABSKG2)
Q4SQ = Q0**2 - QSQ
ELL4SQ = ELL0**2 - ELLSQ
C
ELLP(0) = ELL0 - Q0*DOTQELL/QSQ
T(0,0) = - Q4SQ/QSQ
DO MU = 1,3
ELLP(MU) = ELL(MU) - Q(MU)*DOTQELL/QSQ
T(0,MU) = 0.0D0
T(MU,0) = 0.0D0
DO NU = 1,3
T(MU,NU) = - DELTA(MU,NU) + Q(MU)*Q(NU)/QSQ
ENDDO
ENDDO
C
C
PREFACTOR = 1.0D0/(4.0D0*ABSKG1*ABSKG2*Q4SQ**2)
C
C Now we need the proper special factor for each special case.
C The first case is that of a cut self-energy.
C In the second case, the self-energy subgraph is virtual, but
C one of the adjoing propagators is cut. There are two such cuts
C possible. For each of them, we have a factor 1/2 (and a minus sign).
C In the third case, the self-energy subgraph and both of the
C adjoining propagators are virtual. This does not happen for gluon
C self energies in three loop graphs. Here Q4SQ is the square of the
C four-vector q^mu.
C
C For the virtual contribution, we would have Result(0,i) = 0. But
C we add a piece whose integral is zero that will cancel the
C corresponding term in the real contribution near the collinear
C singularity.
C
IF (CUT(PG1).AND.CUT(PG2)) THEN
SPECIAL = (1.0D0,0.0D0)
TEMP = (NC + 2*NF)*ELL4SQ + (2.25D0*NC - 0.5D0*NF)*Q4SQ
DO MU = 0,3
DO NU = 0,3
RESULT(MU,NU) = SPECIAL*PREFACTOR*
> ( 4*(NC - NF)*ELLP(MU)*ELLP(NU) + TEMP*T(MU,NU))
ENDDO
ENDDO
ELSE IF (CUT(P1).OR.CUT(P2)) THEN
SPECIAL = - 0.5D0*Q0/ABSQ
TEMP = (NC + 2*NF)*ELL4SQ + (2.25D0*NC - 0.5D0*NF)*Q4SQ
RESULT(0,0) = (0.0D0,0.0D0)
DO MU = 1,3
G0I = - 0.5D0*QSQ/(QSQ + Q4SQ)*PREFACTOR
> *4*(NC - NF)*ELLP(0)*ELLP(MU)
RESULT(0,MU) = G0I
RESULT(MU,0) = G0I
DO NU = 1,3
RESULT(MU,NU) = SPECIAL*PREFACTOR*
> ( 4*(NC - NF)*ELLP(MU)*ELLP(NU) + TEMP*T(MU,NU))
ENDDO
ENDDO
ELSE
WRITE(NOUT,*)'Something is rotten in GPROP.'
STOP
ENDIF
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
SUBROUTINE GPROPR(CUT,MUMSBAR,KC,P1,P2,PG1,PG2,S1,SG1,RESULT)
C In:
INTEGER SIZE
PARAMETER (SIZE = 3)
LOGICAL CUT(3*SIZE-1)
REAL*8 MUMSBAR
COMPLEX*16 KC(0:3*SIZE-1,0:3)
INTEGER P1,P2,PG1,PG2,S1,SG1
C Out:
COMPLEX*16 RESULT(0:3,0:3)
C
C A gluon self-energy subgraph, together with its adjoining propagator
C factors, becomes
C
C seglue[p1,p2,pg1,pg2,s1,sg1]^{mu,nu}
C
C where seglue is a second rank tensor, the RESULT here, with
C seglue^{0i} = seglue{i,0} = seglue(0,0) = 0. Here
C p1 is the label of the incoming gluon line,
C s1 = +1 if this line carries momentum into the graph,
C s1 = -1 otherwise;
C p2 is the label of the outgoing line;
C pg1 is the label of one of the the internal gluon lines,
C sg1 = +1 if this line carries away from the vertex
C at which p1 joins the subgraph,
C sg1 = -1 otherwise;
C pg2 is the label of the other internal gluon line.
C
C This subroutine calculates the integrand for the renormalization
C counterterm for sequark^mu. There are two cases
C
C 1) self-energy subgraph is cut. (Then GPROPR is not called.)
C 2) self-energy subgraph is virtual, an adjoining propagator is cut.
C
C We let Q^mu be the incoming quark 3-momentum,
C KG1^mu be the 3-momentum carried by the first internal line,
C KG2^mu be the 3-momentum carried by the other internal line.
C
C 13 January 1998
C 7 April 1998
C 4 September 1998 Add color factors
C 21 September 1998 Fix color factors
C
INTEGER NIN,NOUT
COMMON /IOUNIT/ NIN,NOUT
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
REAL*8 DELTA
COMPLEX*16 QSQ,ELLSQ,DOTQELL,ABSQ
COMPLEX*16 Q(3),KG1(3),ELL(3),ELLP(3)
COMPLEX*16 T(3,3)
COMPLEX*16 PREFACTOR,SPECIAL,TEMP
COMPLEX*16 COMPLEXSQRT
INTEGER CUTSIGN
REAL*8 XXREAL
INTEGER MU,NU
C
C We define CUTSIGN to be +1 if the self-energy subgraph crosses
C the final state cut with propagator P1 to the left and P2 to
C the right, -1 if it is the other way around. This allows us
C to choose the signs so that q^mu is flowing toward the cut.
C
IF (S1*XXREAL(KC(P1,0)).GT.0.0D0) THEN
CUTSIGN = 1
ELSE
CUTSIGN = -1
ENDIF
C
QSQ = (0.0D0,0.0D0)
ELLSQ = (0.0D0,0.0D0)
DOTQELL = (0.0D0,0.0D0)
DO MU = 1,3
Q(MU) = S1*KC(P1,MU)
KG1(MU) = SG1*KC(PG1,MU)
ELL(MU) = KG1(MU) - 0.5D0*Q(MU)
QSQ = QSQ + Q(MU)**2
ELLSQ = ELLSQ + ELL(MU)**2
DOTQELL = DOTQELL + Q(MU)*ELL(MU)
ENDDO
DO MU = 1,3
ELLP(MU) = ELL(MU) - Q(MU)*DOTQELL/QSQ
DO NU = 1,3
T(MU,NU) = - DELTA(MU,NU) + Q(MU)*Q(NU)/QSQ
ENDDO
ENDDO
C
ABSQ = COMPLEXSQRT(QSQ)
C
PREFACTOR = 1.0D0/(32.0D0*ABSQ*COMPLEXSQRT(ELLSQ + MUMSBAR**2)**5)
C
C Now we need the proper special factor for each special case.
C The first case is that of a cut self-energy, which should not
C happen since this is the subroutine for renormalization.
C In the second case, the self-energy subgraph is virtual, but
C one of the adjoing propagators is cut. There are two such cuts
C possible. For each of them, we have a factor 1/2 (and a minus sign).
C In the third case, the self-energy subgraph and both of the
C adjoining propagators is virtual. Here Q4SQ is the square of the
C four-vector q^mu.
C
IF (CUT(PG1).AND.CUT(PG2)) THEN
WRITE(NOUT,*)'Something is rotten in GPROPR.'
STOP
ELSE IF (CUT(P1).OR.CUT(P2)) THEN
SPECIAL = (-0.5D0,0.0D0)
ELSE
WRITE(NOUT,*)'Something else is rotten in GPROPR.'
STOP
ENDIF
C
C Finally, we assemble the result.
C
TEMP = (8*NC - 4*NF)*ELLSQ + (6*NC - 4*NF)*MUMSBAR**2
RESULT(0,0) = (0.0D0,0.0D0)
DO MU = 1,3
RESULT(0,MU) = (0.0D0,0.0D0)
RESULT(MU,0) = (0.0D0,0.0D0)
DO NU = 1,3
RESULT(MU,NU) = SPECIAL*PREFACTOR*
> ( 4*(NC - NF)*ELLP(MU)*ELLP(NU) + TEMP*T(MU,NU) )
ENDDO
ENDDO
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C Renormalization functions for three point subgraphs.
C 15 September 1997
C 4 September 1998 Add color factors
C 21 September 1998 Fix color factors
C Notation:
C h[index, internal lines, external lines]
C C
C h[a,{gluon,gluon,quark},{gluon,qbar,quark}] = RQQG3AG(KLOOP,MUMSBAR),
C h[a,{gluon,quark,quark},{gluon,qbar,quark}] = RQQG3AQ(KLOOP,MUMSBAR),
C h[b,{gluon,gluon,quark},{gluon,qbar,quark}] = RQQG3BG(KLOOP,MUMSBAR),
C h[b,{gluon,quark,quark},{gluon,qbar,quark}] = RQQG3BQ(KLOOP,MUMSBAR),
C h[c,{gluon,gluon,quark},{gluon,qbar,quark}] = RQQG3CG(KLOOP,MUMSBAR),
C h[c,{gluon,quark,quark},{gluon,qbar,quark}] = RQQG3CQ(KLOOP,MUMSBAR),
C h[a,{gluon,quark,quark}, {phot,qbar,quark}] = RQQP3AQ(KLOOP,MUMSBAR),
C h[b,{gluon,quark,quark}, {phot,qbar,quark}] = RQQP3BQ(KLOOP,MUMSBAR),
C h[c,{gluon,quark,quark}, {phot,qbar,quark}] = RQQP3CQ(KLOOP,MUMSBAR)
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQP3AQ(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gamma vertex, coefficient of gamma[mu]
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQP3AQ = 1 /(2*OMEGA**3) + 3*MUMSBAR**2 /(8*OMEGA**5)
RQQP3AQ = RQQP3AQ * (NC**2 -1)/(2*NC)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQP3BQ(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gamma vertex, coefficient of N[mu] N.gamma
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQP3BQ = - (NC**2 - 1) /(8*NC*OMEGA**3)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQP3CQ(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gamma vertex, coefficient of L3[mu] L3.gamma
C The loop momentum here is just the space part, but the dot products
C are the 4-D Minkowski dot products.
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQP3CQ = 3*(NC**2 - 1) /(8*NC*OMEGA**5)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQG3AG(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gluon vertex, gluon connects to gluon line,
C coefficient of gamma[mu]
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQG3AG = NC /(4*OMEGA**3) + 3*NC*MUMSBAR**2 /(16*OMEGA**5)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQG3BG(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gluon vertex, gluon connects to gluon line,
C coefficient of N[mu] N.gamma
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQG3BG = NC /(8*OMEGA**3)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQG3CG(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gluon vertex, gluon connects to gluon line,
C coefficient of L3[mu] L3.gamma
C The loop momentum here is just the space part, but the dot products
C are the 4-D Minkowski dot products.
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQG3CG = - 3*NC /(8*OMEGA**5)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQG3AQ(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gluon vertex, gluon connects to quark line,
C coefficient of gamma[mu]
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQG3AQ = - 1 /(4*NC*OMEGA**3) - 3*MUMSBAR**2 /(16*NC*OMEGA**5)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQG3BQ(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gluon vertex, gluon connects to quark line,
C coefficient of N[mu] N.gamma
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQG3BQ = 1 /(8*NC*OMEGA**3)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
COMPLEX*16 FUNCTION RQQG3CQ(KLOOP,MUMSBAR)
C
C In:
COMPLEX*16 KLOOP(0:3)
REAL*8 MUMSBAR
C
C q-qbar-gluon vertex, gluon connects to quark line,
C coefficient of L3[mu] L3.gamma
C The loop momentum here is just the space part, but the dot products
C are the 4-D Minkowski dot products.
C
REAL*8 NC,NF
COMMON /COLORFACTORS/ NC,NF
C
COMPLEX*16 LSQ,OMEGA
COMPLEX*16 COMPLEXSQRT
INTEGER MU
C
LSQ = 0.0D0
DO MU = 1,3
LSQ = LSQ + KLOOP(MU)**2
ENDDO
OMEGA = COMPLEXSQRT(LSQ + MUMSBAR**2)
C
RQQG3CQ = - 3 /(8*NC*OMEGA**5)
C
RETURN
END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C
C Miscellaneous Functions
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
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
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
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***********************************************************************
C***********************************************************************
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 NLOOPS,NPROPS,NVERTS,CUTMAX
COMMON /SIZES/ NLOOPS,NPROPS,NVERTS,CUTMAX
C
C NEWGRAPH variables:
INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3)
LOGICAL SELFPROP(3*SIZE-1)
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 -------
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(VRTX,PROP,SELFPROP,GRAPHFOUND)
ENDDO
C
C Now we find the graph we wanted.
C
GRAPHFOUND = .TRUE.
GRAPHNUMBER = 0
DO WHILE (GRAPHFOUND)
CALL NEWGRAPH(VRTX,PROP,SELFPROP,GRAPHFOUND)
IF (GRAPHFOUND) THEN
GRAPHNUMBER = GRAPHNUMBER + 1
ENDIF
IF (GRAPHFOUND.EQV..FALSE.) THEN
WRITE(NOUT,*)'Oops, snafu in DIAGNOSTIC'
ENDIF
IF (GRAPHNUMBER.EQ.BADGRAPHNUMBER) THEN
GRAPHFOUND = .FALSE.
ENDIF
ENDDO
C
C Calculate information associated with the maps.
C
CALL FINDTYPES(VRTX,PROP,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,8
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,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,SELFPROP,GRAPHNUMBER,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
C***********************************************************************
C Random Number Generator
C***********************************************************************
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
C***********************************************************************
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
C***********************************************************************
C
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
C***********************************************************************
C END OF LIBRARY ROUTINES FOR E+E- CALCULATION
C***********************************************************************