C23456789012345678901234567890123456789012345678901234567890123456789012 C C ---------------------------- C beowulfsubs.f Version 2.0 C ---------------------------- C C23456789012345678901234567890123456789012345678901234567890123456789012 SUBROUTINE VERSION INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT WRITE(NOUT,*)'beowulf 2.0 subroutines 1 March 2002' WRITE(NOUT,*)'Coulomb gauge and Feynman gauge' RETURN END C23456789012345678901234567890123456789012345678901234567890123456789012 C C Subroutines for numerical integration of jet cross sections in C electron-positron annihilation. -- D. E. Soper C C First code: 29 November 1992. C Latest revision: see Version subroutine above. C Special note: modified 8 December 1999 to change tabs to spaces C and to correct the header in line 4 above. C C The main program and subroutines that a user might want to modify C are contained in the companion package, beowulf.f. In particular, a C user may very well want to modify parameter settings in the main C program and to change the observables calculated in the subroutine C HROTHGAR and in the functions CALStype(NCUT,KCUT,index). Subroutines C that can be modified only at extreme peril to the reliability of C the results are in this package, beowulfsubs.f. C C There are two parallel calculations. Program beowulf calculates a C sample integral, which by default is the average value of C (1 - thrust)^2. These are summed in the variable INTEGRAL and C reported upon completion of the program. The program also computes C a simple check integral in order to check on the jacobians etc. C In the meantime, for each point in loop space and each final C state cut, the program reports the corresponding point in the space C of final state momenta along with the corresponding weight (Feynman C diagram times jacobian factors) to the subroutine HROTHGAR, which C multiplies by the measurement functions CALS corresponding to the C measurements desired and accumulates the results. C C In order to control roundoff errors, a point in loop space is rejected C if the point is too near a singularity or if there is too much C cancellation in the contribution from that point to INTEGRAL. C C C23456789012345678901234567890123456789012345678901234567890123456789012 C C PROGRAM STRUCTURE C C * denotes routines found in beowulf.f. C Other routines are in beowulfsubs.f C C PROGRAM BEOWULF (*) 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 (*) C SUBROUTINE RANDOMINIT C SUBROUTINE NEWRAN C SUBROUTINE DAYTIME (*) C SUBROUTINE VERSION C SUBROUTINE RENO C SUBROUTINE DIAGNOSTIC C SUBROUTINE NEWGRAPH ... C SUBROUTINE FINDTYPES ... C SUBROUTINE CHECKPOINT C SUBROUTINE CALCULATE C end C C SUBROUTINE RENO C SUBROUTINE TIMING (*) C SUBROUTINE HROTHGAR (*) C SUBROUTINE NEWGRAPH ... C SUBROUTINE FINDTYPES ... C SUBROUTINE FINDA C FUNCTION PROPSIGN C SUBROUTINE NEWPOINT C SUBROUTINE CHOOSE3 C SUBROUTINE CHOOSE2TO3D C SUBROUTINE CHOOSE2TO3E C SUBROUTINE CHOOSE2TO2T C SUBROUTINE CHOOSE2TO2S C SUBROUTINE CHOOSE2TO1 C Subroutines CHOOSEx above all call C FUNCTION RANDOM C SUBROUTINE NEWRAN C SUBROUTINE CHECKPOINT C SUBROUTINE CALCULATE C return C C SUBROUTINE CALCULATE C FUNCTION FEYNMAN0F C FUNCTION FEYNMAN0 C FUNCTION FEYNMANF C SUBROUTINE TWOPT2F C SUBROUTINE TWOPOINTQF C SUBROUTINE TWOPOINTGF C SUBROUTINE VERTEXF C FUNCTION FEYNMAN C SUBROUTINE TWOPT2 C SUBROUTINE TWOPOINTQ C SUBROUTINE TWOPOINTG C SUBROUTINE VERTEX C FUNCTION SMEAR C SUBROUTINE CHECKCALC C SUBROUTINE HROTHGAR (*) C return C C SUBROUTINE FINDA C FUNCTION PROPSIGN C return C C SUBROUTINE HROTHGAR (*) C Beowulf serves Hothgar, who accepts the points in the space of final C state momenta with the corresponding weights, multiplies by C desired measurement functions CALS, and accumulates results. C FUNCTION CALSTHRUST (*) C FUNCTION THRUST (*) C FUNCTION THRUSTDIST (*) C FUNCTION KN0 C FUNCTION KN C FUNCTION CALSTMOMENTS (*) C FUNCTION THRUST (*) C FUNCTION CALSYMOMENTS (*) C SUBROUTINE COMBINEJETS (*) C FUNCTION THRUSTDIST (*) C return C C Simple functions called from routines above, with calls C not listed above: C C FUNCTION ALPI Alpha_s(mu)/Pi C C SUBROUTINE EPSILONT2 C SUBROUTINE EPSILON4 C SUBROUTINE EPSILON1N C SUBROUTINE EPSILON2 C SUBROUTINE EPSILON2N C SUBROUTINE EPSILON3 C SUBROUTINE EPSILONT1 C C SUBROUTINE AXES C FUNCTION XXREAL C FUNCTION XXIMAG C FUNCTION COMPLEXSQRT C FUNCTION FACTORIAL C FUNCTION SINHINV C FUNCTION DELTA C FUNCTION EXPM1 C FUNCTION SQRTM1 C FUNCTION LOGSQINT(Y) C FUNCTION INVLOGSQINT(W) C C Subroutine and function arugments C C SUBROUTINE AXES(EA,EB,EC) C C SUBROUTINE CALCULATE(VRTX,GRAPHNUMBER,ORDER,KIN,ABSKIN, C > QS,QSIGNS,MAPTYPES,NMAPS,VALUE,MAXPART,VALUECHK) C SUBROUTINE CHECK(CIN,NPERMS,ORDER,OK) C SUBROUTINE CHECKCALC( C GRAPHNUMBER,CUTINDEX,KC,JACNEWPOINT,JACDEFORM,CHECK) C SUBROUTINE CHECKOUT(C,CIN,ORDER,NPERMS,OK) C SUBROUTINE CHECKPOINT(K,ABSK,PROP,ORDER,BADNESS) C SUBROUTINE CHOOSE3(P1,P2,P3,OK) C SUBROUTINE CHOOSE2TO2S(PA,PB,ELL,OK) C SUBROUTINE CHOOSE2TO2T(PA,PB,ELL,OK) C SUBROUTINE CHOOSE2TO3D(PA,PB,ELL,OK) C SUBROUTINE CHOOSE2TO3E(PA,PB,ELL,OK) C SUBROUTINE CHOOSE2TO1(PA,PB,ELL,OK) C SUBROUTINE COMBINEJETS(NCUT,KCUT,Y4JET,Y2JET) (*) C C SUBROUTINE DAYTIME(DATE) (*) C SUBROUTINE DEFORM(VRTX,LOOPINDEX,RTS,LEFTLOOP,RIGHTLOOP, C > NINLOOP,KINLOOP,NEWKINLOOP,JACDEFORM) C SUBROUTINE DIAGNOSTIC(K,BADGRAPHNUMBER) C C SUBROUTINE EPSILON1N(V4,OUT) C SUBROUTINE EPSILON2(V3,V4,OUT) C SUBROUTINE EPSILON2N(V3,V4,OUT) C SUBROUTINE EPSILON3(V2,V3,V4,OUT) C SUBROUTINE EPSILON4(V1,V2,V3,V4,OUT) C SUBROUTINE EPSILONT1(T23,V4,OUT) C SUBROUTINE EPSILONT2(T12,V3,V4,OUT) C SUBROUTINE EXCHANGE(V1,V2,C,ORDER) C C SUBROUTINE FINDA(VRTX,Q,NQ,ORDER,A,QOK) C SUBROUTINE FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES) C C SUBROUTINE GETCOUNTS(COUNTFACTOR) (*) C SUBROUTINE GETCOUNTSF(COUNTFACTOR) (*) C SUBROUTINE GETCUTINFO(GRAPHNUMBER,CUTNUMBER,ORDER,NCUT,ISIGN, C > CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP, C > NINLOOP,LOOPINDEX,LOOPSIGN) C C SUBROUTINE HROTHGAR(NCUT,KCUT,WEIGHT,NRENO,WHATTODO) (*) C C SUBROUTINE MAKECUTINFO C C SUBROUTINE NEWCUT(XVRTX,ORDER,NEWCUTINIT,XNCUT,XISIGN, C > XCUTINDEX,XCUTSIGN,XLEFTLOOP,XRIGHTLOOP, C > XNINLOOP,XLOOPINDEX,XLOOPSIGN,CUTFOUND) C SUBROUTINE NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND) C SUBROUTINE NEWCHOICE(C,COUNT,V,FAIL,ORDER) C SUBROUTINE NEWPOINT(A,QSIGN,MAPTYPE,ORDER,K,ABSK,BADPOINT) C SUBROUTINE NEWRAN C SUBROUTINE NEXTCHOICE(C,COUNT,V,FAIL,ORDER) C C SUBROUTINE RANDOMINIT(IRAN) C SUBROUTINE RENO( C > SUMR,ERRORR,SUMI,ERRORI, C > SUMBIS,ERRORBIS, C > SUMCHKR,ERRORCHKR,SUMCHKI,ERRORCHKI,FLUCT, C > INCLUDED,EXTRACOUNT,OMITTED, C > NVALPT,VALPTMAX,KBAD,BADGRAPHNUMBER,BADMAPNUMBER, C > NRENO,CPUTIME) C C SUBROUTINE TIMING(DELTATIME) (*) C SUBROUTINE TWOPOINTG(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUT) C SUBROUTINE TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,OUT) C SUBROUTINE TWOPOINTGF(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUT) C SUBROUTINE TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,OUT) C SUBROUTINE TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,VOUT) C SUBROUTINE TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,VOUT) C C SUBROUTINE VERSION C SUBROUTINE VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,HV,HA) C SUBROUTINE VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,HV,HA) C C REAL*8 FUNCTION ALPI(MUMSBAR) C REAL*8 FUNCTION CALSTHRUST(NCUT,KCUT,N) (*) C REAL*8 FUNCTION CALSTMOMENTS(NCUT,KCUT,N) (*) C REAL*8 FUNCTION CALSYMOMENTS(NCUT,KCUT,N) (*) C REAL*8 FUNCTION CALS0(NCUT,KCUT) (*) C COMPLEX*16 FUNCTION COMPLEXSQRT(Z) C REAL*8 FUNCTION DELTA(MU,NU) C REAL*8 FUNCTION DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER) C REAL*8 FUNCTION EXPM1(X) C REAL*8 FUNCTION FACTORIAL(N) C COMPLEX*16 FUNCTION FEYNMAN(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) C COMPLEX*16 FUNCTION FEYNMANF(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) C COMPLEX*16 FUNCTION FEYNMAN0(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) C COMPLEX*16 FUNCTION FEYNMAN0F(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) C REAL*8 FUNCTION INVLOGSQINT(W) C REAL*8 FUNCTION KN0(T) (*) C REAL*8 FUNCTION KN(T) (*) C REAL*8 FUNCTION LOGSQINT(Y) C LOGICAL FUNCTION ONEPI(CIN,ORDER) C INTEGER FUNCTION PROPSIGN(VRTX,P,V) C REAL*8 FUNCTION RANDOM(DUMMY) C REAL*8 FUNCTION RHO2TO1(PA,PB,ELL) C REAL*8 FUNCTION RHO2TO2S(PA,PB,ELL) C REAL*8 FUNCTION RHO2TO2T(PA,PB,ELL) C REAL*8 FUNCTION RHO2TO3D(PA,PB,ELL) C REAL*8 FUNCTION RHO2TO3E(PA,PB,ELL) C REAL*8 FUNCTION RHO3(ABSP1,ABSP2,ABSP3) C REAL*8 FUNCTION SINHINV(Z) C REAL*8 FUNCTION SMEAR(RTS) C REAL*8 FUNCTION SQRTM1(X) C REAL*8 FUNCTION THRUST(NCUT,KCUT,RTS) (*) C REAL*8 FUNCTION THRUSTDIST(T) (*) C REAL*8 FUNCTION XXREAL(Z) C REAL*8 FUNCTION XXIMAG(Z) C C23456789012345678901234567890123456789012345678901234567890123456789012 C C A brief introduction to the variables used: C C Size of the calculation: C NLOOPS = number of loops (in cut photon self energy graph). C NPROPS = number of propagators in graph, = 3 * NLOOPS - 1. C NVERTS = number of vertices in graph, = 2 * NLOOPS. C CUTMAX = NLOOPS + 1 C = maximum number of cut propagators; C = number of independent loop momenta needed to determine the C propagator momenta, counting the virtual photon momentum. C The current program is restricted to 0 and 1 virtual loops. C C Labels: C L = index of loop momenta, L = 0,1,...,NLOOPS. C L = 0 normally denontes the virtual photon momentum. C P = index of propagator, P = 0,1,...,NPROPS. C P = 0 denotes the virtual photon momentum. C Q(L) = index P of propagator carrying the Lth loop momentum. C V = index of vertices, V = 1,...,NVERTS C C Momentum variables (MU = 0,1,2,3): C K(P,MU) = Momentum of Pth propagator. C For P = 0, this is the virtual photon momentum: C K(0,MU) = 0 for MU = 1, 2, 3 while K(0,0) = RTS. C ABSK(P) = Square of the three momentum of Pth propagator. C KINLOOP(J,MU) = K(LOOPINDEX(J),MU) = momenta of loop propagators. C KCUT(I,MU) = K(CUTINDEX(I),MU) = momenta of cut propagators. C K(Q(L),MU) = Lth loop momentum, L = 0,...,NLOOPS; C KC(P,MU) = complex propagator momenta. C A(P,L) = Matrix relating propagator momenta to loop momenta. C K(P,MU) = SUM_{L=0}^{NLOOPS} A(P,L) K(Q(L),MU) C C Variables from NEWGRAPH: C VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of C of propagator P. Specifies the supergraph. C PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3. C Also specifies the supergraph. C C Variables associated with NEWPOINT and FINDTYPES: C NMAPS = Number of different maps from random x's to momenta. C MAPNMUMBER = Number labelling a certain map. C QS(MAPNUMBER,II) = Label of the IIth propagator that is special C in map number MAPNUMBER. C QSIGNS(MAPNUMBER,II) = sign needed to relate the conventional C direction of the propagator to that in an elementary scattering C MAPTYPES(MAPNUMBER) = T2TO3, T2TO2T, T2TO2S, T2TO1. C C JACNEWPOINT =1/DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER) C = Jacobian for loop momenta L. C C Variables from NEWCUT: C NEWCUTINIT: .TRUE. tells NEWCUT to initialize itself. C NCUT = Number of cut propagators. C ISIGN(P) = +1 if propagator P is left of cut, -1 if right, 0 if cut. C CUTINDEX(I) = Index P of cut propagator I, I = 1,...,CUTMAX. C CUTSIGN(I) = Sign of cut propagator I I = 1,...,CUTMAX. C (+1 if K(P,0) >0 for cut propagator.) C LEFTLOOP = True iff there is a virtual loop to the left of the cut. C RIGHTLOOP = True iff there is a virtual loop to the right of the cut. C NINLOOP = Number of propagators in loop. C LOOPINDEX(NP) = Index P of NPth propagator around the loop. C LOOPSIGN(NP) = 1 if propagator direction is same as loop direction. C -1 if direction is opposite to loop direction. C NP = JCUT: Propagator cut by loopcut. C CUTFOUND: .TRUE. if NEWCUT found a new cut. C C In RENO we use CUTINDEX to define CUT(P) = True if propagator C P is cut. C C Solving for the propagator energies: C For NCUT = CUTMAX, cut propagators are P = CUTINDEX(I). C with direction of positive energy given by CUTSIGN(I). C For NCUT = CUTMAX - 1, we define a "loopcut" on the propagator C numbered JCUT in order around the loop, 1.LE.JCUT.LE.NINLOOP: C CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) and C CUTSIGN(CUTMAX) = LOOPSIGN(JCUT). C Energies of cut propagators are C E(I-1) = K(CUTINDEX(I),0) for I = 1,...,CUTMAX. C and are determined from C E(I-1) = CUTSIGN(I) * SQRT( Sum_J [ K(CUTINDEX(I),J)**2 ] ). C This gives energies E(L) for L = 0,...,NLOOPS. We consider the C propagators designated by QE(L) = CUTINDEX(L+1) as independent C and generate the matrix AE(P,L) that gives the propagator energies C in terms of these independent momenta. This gives the propagator C energies. C C Contour deformation: C NEWKINLOOP(MU) = addition to the momentum going around the loop C caused by deforming the contour. We have C Im[ KC(LOOPINDEX(J,MU)) ] = LOOPSIGN(LOOPINDEX(J)) C * Im[ NEWKINLOOP(J,MU) ] for MU = 1,2,3. C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE RENO( > SUMR,ERRORR,SUMI,ERRORI, > SUMBIS,ERRORBIS, > SUMCHKR,ERRORCHKR,SUMCHKI,ERRORCHKI,FLUCT, > INCLUDED,EXTRACOUNT,OMITTED, > NVALPT,VALPTMAX,KBAD,BADGRAPHNUMBER,BADMAPNUMBER, > NRENO,CPUTIME) C Array sizes: INTEGER SIZE,MAXGRAPHS,MAXMAPS PARAMETER (SIZE = 3) PARAMETER (MAXGRAPHS = 12) PARAMETER (MAXMAPS = 64) C Out: REAL*8 SUMR,ERRORR,SUMI,ERRORI REAL*8 SUMBIS,ERRORBIS REAL*8 SUMCHKR,ERRORCHKR,SUMCHKI,ERRORCHKI REAL*8 FLUCT(MAXGRAPHS,MAXMAPS) INTEGER*8 INCLUDED,EXTRACOUNT,OMITTED INTEGER NVALPT(-9:6) REAL*8 VALPTMAX REAL*8 KBAD(0:3*SIZE-1,0:3) INTEGER BADGRAPHNUMBER,BADMAPNUMBER INTEGER NRENO REAL*8 CPUTIME C C Computes the cross section integral by Monte Carlo integration. C C Latest revision 7 February 2002 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NLOOPS,NPROPS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 REAL*8 BADNESSLIMIT,CANCELLIMIT,THRUSTCUT COMMON /LIMITS/ BADNESSLIMIT,CANCELLIMIT,THRUSTCUT REAL*8 TIMELIMIT COMMON /MAXTIME/ TIMELIMIT C What the program should do CHARACTER*6 MODE COMMON /PROGRAMMODE/ MODE C Graphs to include LOGICAL USEGRAPH(MAXGRAPHS) COMMON /WHICHGRAPHS/ USEGRAPH C How many graphs and how many cuts and maps for each: INTEGER NUMBEROFGRAPHS INTEGER NUMBEROFCUTS(MAXGRAPHS) INTEGER NUMBEROFMAPS(MAXGRAPHS) COMMON /GRAPHCOUNTS/ NUMBEROFGRAPHS,NUMBEROFCUTS,NUMBEROFMAPS C Order of perturbation theory INTEGER ORDER C Momenta: REAL*8 K(0:3*SIZE-1,0:3),ABSK(0:3*SIZE-1) C Matrices: INTEGER A(0:3*SIZE-1,0:SIZE) C NEWGRAPH variables: INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3) LOGICAL GRAPHFOUND INTEGER GRAPHNUMBER C FINDA variable: LOGICAL QOK C MAP variables: INTEGER NMAPS,MAPNUMBER INTEGER QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE) INTEGER Q(0:SIZE),QSIGN(0:SIZE) CHARACTER*6 MAPTYPES(MAXMAPS) CHARACTER*6 MAPTYPE C Variable from CHECKPOINT: REAL*8 BADNESS C Problem report from NEWPOINT LOGICAL BADNEWPOINT C Logical variables to tell how to treat point: LOGICAL XTRAPOINTQ, BADPOINTQ C Functions: REAL*8 XXREAL,XXIMAG C Index variables: INTEGER L,P,MU C Hrothgar dummy variables: REAL*8 KCUT0(SIZE+1,0:3) C Reno size and counting variables: INTEGER GROUPSIZE(MAXGRAPHS,MAXMAPS) INTEGER GROUPSIZEGRAPH(MAXGRAPHS) INTEGER GROUPSIZETOTAL COMMON /MONTECARLO/GROUPSIZE,GROUPSIZEGRAPH,GROUPSIZETOTAL INTEGER POINT C Reno results variables: REAL*8 SQRSUMR,SQRSUMCHKR REAL*8 SQRSUMI,SQRSUMCHKI REAL*8 SQRSUMBIS COMPLEX*16 INTEGRAL,INTEGRALCHK REAL*8 INTEGRALBIS C Calculate variables: COMPLEX*16 VALUE,VALUECHK REAL*8 MAXPART REAL*8 VALPT,LOGVALPT LOGICAL REPORT,DETAILS COMMON /CALCULOOK/ REPORT,DETAILS C Timing variables REAL*8 DELTATIME C C------------------------------ Begin ---------------------------------- C C Dummy variables for Hrothgar. C DO L = 1,SIZE+1 DO MU = 0,3 KCUT0(L,MU) = 1.0D0 ENDDO ENDDO C C Initialize CPUTIME and NRENO. Call to TIMING starts the clock. C CPUTIME = 0.0 NRENO = 0 CALL TIMING(DELTATIME) C C Initialize sums for loop over groups of Reno points. The sums C will be updated for each group. Within a group, the quantities C corresponding to SUMxxR + i SUMxxI are complex variables called C INTEGRALxx. C SUMR = 0.0D0 SUMI = 0.0D0 SUMBIS = 0.0D0 SUMCHKR = 0.0D0 SUMCHKI = 0.0D0 C SQRSUMR = 0.0D0 SQRSUMI = 0.0D0 SQRSUMBIS = 0.0D0 SQRSUMCHKR = 0.0D0 SQRSUMCHKI = 0.0D0 C DO GRAPHNUMBER = 1,NUMBEROFGRAPHS DO MAPNUMBER = 1,NUMBEROFMAPS(GRAPHNUMBER) FLUCT(GRAPHNUMBER,MAPNUMBER) = 0.0D0 ENDDO ENDDO C DO L = -9,6 NVALPT(L) = 0 ENDDO VALPTMAX = 0.0D0 INCLUDED = 0 EXTRACOUNT = 0 OMITTED = 0 C C Tell CALCULATE not to report its findings for each calculation C REPORT = .FALSE. C C Initialize integrals for first group. C INTEGRAL = (0.0D0,0.0D0) INTEGRALBIS = 0.0D0 INTEGRALCHK = (0.0D0,0.0D0) C C Loop over groups of points. C DO WHILE (CPUTIME.LT.TIMELIMIT) NRENO = NRENO + 1 C C Call Hrothgar to tell him to that we are starting a new group. C CALL HROTHGAR(1,KCUT0,1.0D0,1,'STARTGROUP') C C Get a new graph. The starting value for GRAPHNUMBER depends C on the order we want. Graphs for ORDER = 2 are numbered 1,...,10 C and those for ORDER = 1 are numbered 11,12. For MODE = nlo, C we will do the ORDER = 2 graphs first, then continue with the C first order graphs. Thus we wait for NEWGRAPH to return C GRAPHFOUND = false, then reset it (see ELSE part of IF(GRAPHFOUND)). C GRAPHFOUND = .TRUE. C IF (MODE.EQ.'born ') THEN ORDER = 1 NLOOPS = NLOOPS1 NPROPS = NPROPS1 GRAPHNUMBER = 10 ELSE IF (MODE.EQ.'hocoef') THEN ORDER = 2 NLOOPS = NLOOPS2 NPROPS = NPROPS2 GRAPHNUMBER = 0 ELSE IF (MODE.EQ.'nlo ') THEN ORDER = 2 NLOOPS = NLOOPS2 NPROPS = NPROPS2 GRAPHNUMBER = 0 ELSE WRITE(NOUT,*)'Not programmed for this mode.',MODE STOP ENDIF C DO WHILE (GRAPHFOUND) CALL NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND) IF (GRAPHFOUND) THEN GRAPHNUMBER = GRAPHNUMBER + 1 C C Calculate number of maps NMAPS, index arrays QS, C types MAPTYPES, and signs QSIGNS associated with the maps. C CALL FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES) C C Check if we were supposed to use this graph (USEGRAPH is C set in the main program.) C IF (USEGRAPH(GRAPHNUMBER)) THEN C C Loop over choices of maps from x's to loop momenta. C DO MAPNUMBER = 1,NMAPS C MAPTYPE = MAPTYPES(MAPNUMBER) DO L = 0,NLOOPS Q(L) = QS(MAPNUMBER,L) QSIGN(L) = QSIGNS(MAPNUMBER,L) ENDDO C CALL FINDA(VRTX,Q,NLOOPS,ORDER,A,QOK) C C Loop over Reno points within a group. C DO POINT = 1,GROUPSIZE(GRAPHNUMBER,MAPNUMBER) C C Call Hrothgar to tell him that we are starting a new point. C CALL HROTHGAR(1,KCUT0,1.0D0,1,'STARTPOINT') C C Get a new point. Check on its badness. If it is too bad, C or if NEWPOINT reported a problem, we omit the point after C notifying Hrothgar. C BADPOINTQ = .FALSE. XTRAPOINTQ = .FALSE. CALL NEWPOINT(A,QSIGN,MAPTYPE,ORDER,K,ABSK,BADNEWPOINT) IF (BADNEWPOINT) THEN CALL HROTHGAR(1,KCUT0,1.0D0,1,'BADPOINT ') BADPOINTQ = .TRUE. ENDIF CALL CHECKPOINT(K,ABSK,PROP,ORDER,BADNESS) IF (BADNESS.GT.100*BADNESSLIMIT) THEN CALL HROTHGAR(1,KCUT0,1.0D0,1,'BADPOINT ') BADPOINTQ = .TRUE. ELSE IF (BADNESS.GT.BADNESSLIMIT) THEN CALL HROTHGAR(1,KCUT0,1.0D0,1,'XTRAPOINT ') XTRAPOINTQ = .TRUE. ENDIF C C If the point is not too bad, we can call CALCULATE. C The final state momenta found, KCUT, along with the corresponding C weights, are reported to Hrothgar by CACULATE. C Then call Hrothgar to tell him that we are done with this point. C IF (.NOT.BADPOINTQ) THEN CALL CALCULATE(VRTX,GRAPHNUMBER,ORDER,K,ABSK, > QS,QSIGNS,MAPTYPES,NMAPS,VALUE,MAXPART,VALUECHK) ENDIF C C Add contribution from this point to integral. C We count the point if Maxvalue/|Value| < Cancellimit. C IF (.NOT.BADPOINTQ) THEN IF ( MAXPART.GT. 100*CANCELLIMIT*ABS(XXREAL(VALUE)) ) THEN CALL HROTHGAR(1,KCUT0,1.0D0,1,'BADPOINT ') BADPOINTQ = .TRUE. ELSE IF ( MAXPART.GT. CANCELLIMIT*ABS(XXREAL(VALUE)) ) THEN CALL HROTHGAR(1,KCUT0,1.0D0,1,'XTRAPOINT ') XTRAPOINTQ = .TRUE. ENDIF ENDIF C IF ( (.NOT.BADPOINTQ).AND.(.NOT.XTRAPOINTQ) ) THEN INTEGRAL = INTEGRAL + VALUE FLUCT(GRAPHNUMBER,MAPNUMBER) = FLUCT(GRAPHNUMBER,MAPNUMBER) > + XXREAL(VALUE)**2/GROUPSIZE(GRAPHNUMBER,MAPNUMBER) INTEGRALCHK = INTEGRALCHK + VALUECHK INCLUDED = INCLUDED + 1 C C For diagnostic purposes, we need VALPT, the contribution to C the integral being calculated from this point, normalized such C that the integral is the sum over all points chosen of VALPT C divided by the total number of points, NRENO * GROUPSIZETOTAL. C VALPT = ABS(XXREAL(VALUE))*GROUPSIZETOTAL LOGVALPT = LOG10(VALPT) DO L = -9,6 IF((LOGVALPT.GE.L).AND.(LOGVALPT.LT.(L+1))) THEN NVALPT(L) = NVALPT(L) + 1 ENDIF ENDDO IF (VALPT.GT.VALPTMAX) THEN VALPTMAX = VALPT DO P = 1,NPROPS DO MU = 1,3 KBAD(P,MU) = K(P,MU) ENDDO ENDDO BADGRAPHNUMBER = GRAPHNUMBER BADMAPNUMBER = MAPNUMBER ENDIF ELSE IF ((.NOT.BADPOINTQ).AND.(XTRAPOINTQ) ) THEN C C For points that are 'extra', we include the value of C the integrand in the INTEGRALBIS, which will provide an estimate C or the effect of the cutoffs. C INTEGRALBIS = INTEGRALBIS + XXREAL(VALUE) EXTRACOUNT = EXTRACOUNT + 1 C ELSE OMITTED = OMITTED + 1 ENDIF C C End of loop over POINT. C CALL HROTHGAR(1,KCUT0,1.0D0,1,'POINTDONE ') ENDDO C C End of loop over MAPNUMBER. C ENDDO C C End for IF (USEGRAPH(GRAPHNUMBER)) THEN C ENDIF C C End of loop DO WHILE (GRAPHFOUND)/ IF (GRAPHFOUND). C In the case MODE = nlo, if GRAPHFOUND was false and ORDER = 2, C we have run out of the second order graphs and we should continue to C find the first order (Born) graphs. C ELSE IF ((MODE.EQ.'nlo ').AND.(ORDER.EQ.2)) THEN GRAPHFOUND = .TRUE. ORDER = 1 NLOOPS = NLOOPS1 NPROPS = NPROPS1 ENDIF ENDIF ENDDO C C Call Hrothgar to tell him that we are done with this group. C CALL HROTHGAR(1,KCUT0,1.0D0,1,'GROUPDONE ') C C Add results from this group to the SUM variables. C SUMR = SUMR + XXREAL(INTEGRAL) SUMI = SUMI + XXIMAG(INTEGRAL) SUMBIS = SUMBIS + INTEGRALBIS SUMCHKR = SUMCHKR + XXREAL(INTEGRALCHK) SUMCHKI = SUMCHKI + XXIMAG(INTEGRALCHK) C SQRSUMR = SQRSUMR + XXREAL(INTEGRAL)**2 SQRSUMI = SQRSUMI + XXIMAG(INTEGRAL)**2 SQRSUMBIS = SQRSUMBIS + INTEGRALBIS**2 SQRSUMCHKR = SQRSUMCHKR + XXREAL(INTEGRALCHK)**2 SQRSUMCHKI = SQRSUMCHKI + XXIMAG(INTEGRALCHK)**2 C C Reset the INTEGRAL variables for the next group. C INTEGRAL = (0.0D0,0.0D0) INTEGRALBIS = 0.0D0 INTEGRALCHK = (0.0D0,0.0D0) C C End of loop DO WHILE (CPUTIME.LT.TIMELIMIT) C CALL TIMING(DELTATIME) CPUTIME = CPUTIME + DELTATIME ENDDO C C Calculate the SUM results. C SUMR = SUMR/NRENO SUMI = SUMI/NRENO SUMBIS = SUMBIS/NRENO SUMCHKR = SUMCHKR/NRENO SUMCHKI = SUMCHKI/NRENO C SQRSUMR = SQRSUMR/NRENO SQRSUMI = SQRSUMI/NRENO SQRSUMBIS = SQRSUMBIS/NRENO SQRSUMCHKR = SQRSUMCHKR/NRENO SQRSUMCHKI = SQRSUMCHKI/NRENO C IF (NRENO.EQ.1) THEN WRITE(NOUT,*)'NRENO = 1 changed to 2 to avoid 1/0.' WRITE(NOUT,*)'Results will be finite but wrong.' WRITE(NOUT,*)' ' NRENO = 2 ENDIF ERRORR = SQRT((SQRSUMR - SUMR**2)/(NRENO - 1)) ERRORI = SQRT((SQRSUMI - SUMI**2)/(NRENO - 1)) ERRORBIS = SQRT((SQRSUMBIS - SUMBIS**2)/(NRENO - 1)) ERRORCHKR = SQRT((SQRSUMCHKR - SUMCHKR**2)/(NRENO-1)) ERRORCHKI = SQRT((SQRSUMCHKI - SUMCHKI**2)/(NRENO-1)) C DO GRAPHNUMBER = 1,NUMBEROFGRAPHS DO MAPNUMBER = 1,NUMBEROFMAPS(GRAPHNUMBER) FLUCT(GRAPHNUMBER,MAPNUMBER) = > FLUCT(GRAPHNUMBER,MAPNUMBER)/NRENO ENDDO ENDDO C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C Subroutines associated with NEWGRAPH C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND) C INTEGER SIZE PARAMETER (SIZE = 3) C In: INTEGER ORDER C Out: INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3) LOGICAL GRAPHFOUND C C 8 November 1992 Home fixup of bugs. C 28 November 1992 Add check that we get each graph only once. C 13 July 1994 C 13 April 1996 C 1 January 1998 Add output variable SELFPROP. Omit NPERMS as output. C 7 December 2001 Subtract output variable SELFPROP. C---------- C Varibles: C VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of C of propagator P. Specifies the supergraph for output. C PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3. C Also specifies the supergraph for output. C C(V,I) = Index of Ith vertex connected to vertex V. C V = 1,...,NVERTS; I =1,2,3; C(V,I) = 1,...,NVERTS and -1,-2. C Here C(V,1).LE.C(V,2).LE.C(V,3). C This is the fundamental specification of the supergraph. C N = Number of permutations of the vertices that give same graph. C GRAPHFOUND = True when the subroutine finds a new graph. C COUNT(V) = Number of vertices connected to vertex V. C Vertex 1 is automatically connected to the photon "-1":C(1,1) = -1. C Vertex 2 is automatically connected to the photon "-2":C(2,1) = -2. C The freedom to renumber the vertices 3,...,NVERTS is used to choose C a standard numbering: C We choose the numbering with the smallest value of C(1,1); C For numberings with equal values of C(1,1) we choose the numbering C with the smallest value of C(1,2); C For numberings with equal values of C(1,2) we choose the numbering C with the smallest value of C(1,3); C For numberings with equal values of C(1,3) we choose the numbering C with the smallest value of C(2,1); et cetera. C C The connections are generated starting with vertex 1. We make C a choice of connections for vertex V, then move on to make a choice C for connections to vertex V + 1. When we are out of choices for C connections to vertex V, we step back and try the next choice for C vertex V - 1. C C Connections to the external boson: C In C(V,I) we assign the first connection of vertex 1 to be vertex "-1" C while the first connection of vertex 2 is vertex "-2." This numbering C is convenient for working out C(V,I). In reporting the results, C however, we label the external boson with propagator 0, so that C PROP(1,1) = PROP(2,1) = 0. Then propagator 0 attaches to vertices C 1 and 2: VERT(0,1) = 2, VERT(0,2) = 1. C---------- C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NPROPS,NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C INTEGER C(2*SIZE,3),COUNT(2*SIZE) INTEGER NUSED(2*SIZE),VA,VB INTEGER V,VV,I,P,NPERMS LOGICAL ONEPI,OK LOGICAL FAIL,NEWSTART,UP DATA NEWSTART/.TRUE./ SAVE C C Initializations. C IF (ORDER.EQ.1) THEN NPROPS = NPROPS1 NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NPROPS = NPROPS2 NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C IF (NEWSTART) THEN DO VV = 1,NVERTS COUNT(VV) = 0 DO I = 1,3 C(VV,I) = 0 ENDDO ENDDO C(1,1) = -1 COUNT(1) = 1 C(2,1) = -2 COUNT(2) = 1 V = 1 UP = .TRUE. ENDIF C C Move from level to level in tree structure of choices. When UP C is true, we have moved to a higher V; when UP is false, we have C moved to a smaller V. C DO WHILE (.TRUE.) C IF (UP) THEN CALL NEWCHOICE(C,COUNT,V,FAIL,ORDER) ELSE CALL NEXTCHOICE(C,COUNT,V,FAIL,ORDER) ENDIF IF (FAIL) THEN C C If we couldn't find connectections for vertex V, then we should C step back and look for the next connections for vertex V-1. But if C V is currently 1, then we can't step back, so we have found all C the graphs. C IF (V.GT.1) THEN V = V - 1 UP = .FALSE. ELSE NEWSTART = .TRUE. GRAPHFOUND = .FALSE. DO P = 0,NPROPS DO I = 1,2 VRTX(P,I) = 0 ENDDO ENDDO RETURN ENDIF C C If we did find connections for vertex V, then we should step onward C and look for new connections for vertex V+1. But if V is currently C equal to NVERTS, then we must have found a graph. We check for C validity. If it is valid, we exit with the results, setting V and UP C so that the next time the subroutine is called we will start looking C for the next connections for vertex V-1. If our graph is not valid C (eg. one particle reducible) then we step back to look for new C connections for vertex V-1 right away. C ELSE IF (V.LT.NVERTS) THEN V = V + 1 UP = .TRUE. ELSE V = V - 1 UP = .FALSE. IF (ONEPI(C,ORDER)) THEN CALL CHECK(C,NPERMS,ORDER,OK) IF (OK) THEN NEWSTART = .FALSE. GRAPHFOUND = .TRUE. C C Exit. We translate the results for C(V,I) into VRTX(P,I), I = 1,2, C and PROP(P,I), I = 1,2,3. Here NUSED(V) denotes how many propagators C we have so far assigned connecting to vertex V. C DO VV = 1,NVERTS NUSED(VV) = 0 ENDDO VRTX(0,1) = 2 VRTX(0,2) = 1 PROP(1,1) = 0 NUSED(1) = 1 PROP(2,1) = 0 NUSED(2) = 1 P = 1 DO VV = 1,NVERTS DO I = 1,3 IF (C(VV,I).GT.VV) THEN VA = VV VB = C(VV,I) VRTX(P,1) = VA NUSED(VA) = NUSED(VA) + 1 PROP(VA,NUSED(VA)) = P VRTX(P,2) = VB NUSED(VB) = NUSED(VB) + 1 PROP(VB,NUSED(VB)) = P P = P+1 ENDIF ENDDO ENDDO IF (P.NE.NPROPS+1) THEN WRITE(NOUT,*)'SNAFU in NEWGRAPH',P-1,NPROPS STOP ENDIF DO VV = 1,NVERTS IF (NUSED(VV).NE.3) THEN WRITE(NOUT,*)'Problem in NEWWGRAPH',VV,NUSED(VV) STOP ENDIF ENDDO C C OK. We are ready to return. C RETURN C ENDIF ENDIF ENDIF ENDIF C C End main loop "DO WHILE (.TRUE.)" C ENDDO C END C C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE NEWCHOICE(C,COUNT,V,FAIL,ORDER) C INTEGER SIZE PARAMETER (SIZE = 3) C INTEGER C(2*SIZE,3),COUNT(2*SIZE) INTEGER V LOGICAL FAIL INTEGER ORDER C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C INTEGER VV,K LOGICAL FOUND SAVE C IF (ORDER.EQ.1) THEN NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C C If COUNT(V) = 3, then we don't need any more connections to this C vertex. If COUNT(V) = 0, then we appear to be starting to make a C vacuum graph after having completed a graph with too few loops, so C we should just quit. C IF (COUNT(V).EQ.3) THEN FAIL = .FALSE. RETURN ELSE IF (COUNT(V).EQ.0) THEN FAIL = .TRUE. RETURN ENDIF C C Generate starting choice for new vertices to connect to V. We connect C to the vertices with the smallest possible indices. C FAIL = .FALSE. VV = V + 1 DO K = (COUNT(V) + 1),3 FOUND = .FALSE. DO WHILE (.NOT.FOUND) IF (VV.GT.NVERTS) THEN FAIL = .TRUE. RETURN ENDIF IF ( COUNT(VV).LT.3) THEN COUNT(V) = COUNT(V) + 1 C(V,K) = VV COUNT(VV) = COUNT(VV) + 1 C(VV,COUNT(VV)) = V FOUND = .TRUE. ELSE VV = VV + 1 ENDIF ENDDO ENDDO C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE NEXTCHOICE(C,COUNT,V,FAIL,ORDER) C INTEGER SIZE PARAMETER (SIZE = 3) C INTEGER C(2*SIZE,3),COUNT(2*SIZE) INTEGER V LOGICAL FAIL INTEGER ORDER C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C INTEGER VV,VVV,V2,V3,I LOGICAL FOUND SAVE C IF (ORDER.EQ.1) THEN NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C C First, erase any connections among higher index vertices. C DO VV = V+1,NVERTS DO VVV = V+1,NVERTS DO I = 1,3 IF (C(VV,I).EQ.VVV) THEN C(VV,I) = 0 COUNT(VV) = COUNT(VV) - 1 ENDIF ENDDO ENDDO ENDDO C C Next, get the next connection set for vertex V. C First, we try to find a new third connection for V. C V3 = C(V,3) C If third connection was to a lower index vertex, we can't change it. IF (V3.LE.V) THEN FAIL = .TRUE. RETURN ENDIF C Erase third connection: C(V,3) = 0 C(V3,COUNT(V3)) = 0 COUNT(V) = COUNT(V) - 1 COUNT(V3) = COUNT(V3) - 1 C Look for a new one: DO WHILE (V3.LT.NVERTS) V3 = V3 + 1 IF ((COUNT(V3-1).GT.0).AND.(COUNT(V3).LT.3)) THEN COUNT(V) = COUNT(V) + 1 COUNT(V3) = COUNT(V3) + 1 C(V,3) = V3 C(V3,COUNT(V3)) = V FAIL = .FALSE. RETURN ENDIF ENDDO C C We have failed to find a new third connection for V, so C try for a second connection. C V2 = C(V,2) C If second connection was to a lower index vertex, we can't change it. IF (V2.LE.V) THEN FAIL = .TRUE. RETURN ENDIF C Erase second connection: C(V,2) = 0 C(V2,COUNT(V2)) = 0 COUNT(V) = COUNT(V) - 1 COUNT(V2) = COUNT(V2) - 1 C Look for a new one: DO WHILE (V2.LT.NVERTS) V2 = V2 + 1 IF ((COUNT(V2-1).GT.0).AND.(COUNT(V2).LT.3)) THEN COUNT(V) = COUNT(V) + 1 COUNT(V2) = COUNT(V2) + 1 C(V,2) = V2 C(V2,COUNT(V2)) = V C We found a new second connection. Now get a third connection. C--- V3 = V2 FOUND = .FALSE. DO WHILE (.NOT.FOUND) IF ( COUNT(V3).LT.3) THEN COUNT(V) = COUNT(V) + 1 COUNT(V3) = COUNT(V3) + 1 C(V,3) = V3 C(V3,COUNT(V3)) = V FOUND = .TRUE. ELSE V3 = V3 + 1 IF (V3.GT.NVERTS) THEN FAIL = .TRUE. RETURN ENDIF ENDIF ENDDO C--- C We have found a good third connection also, so we are done! FAIL = .FALSE. RETURN ENDIF ENDDO C We couldn't find a second connection C FAIL = .TRUE. RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C LOGICAL FUNCTION ONEPI(CIN,ORDER) C INTEGER SIZE PARAMETER (SIZE = 3) INTEGER CIN(2*SIZE,3) INTEGER ORDER C C Checks that the graph is connected and 1 particle irreducible. C Modified 26 July 1994. C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C LOGICAL LEFT(2*SIZE),CHANGE INTEGER C(2*SIZE,3) INTEGER V,I,V1,V2,I1,I2 SAVE C IF (ORDER.EQ.1) THEN NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C C Initialize C ONEPI = .TRUE. C DO V = 1,NVERTS DO I = 1,3 C(V,I) = CIN(V,I) ENDDO ENDDO C C Set up loops to successively erase each propagator. C DO V1 = 1,NVERTS DO I1 = 1,3 V2 = C(V1,I1) IF (V2.GT.V1) THEN DO I2 = 1,3 IF (C(V2,I2).EQ.V1) THEN C(V1,I1) = 0 C(V2,I2) = 0 C--We have now erased the propagator from V1 to V2. Let's see if C the remaining graph is connected. DO V = 1,NVERTS LEFT(V) = .FALSE. ENDDO C Construct Left set. LEFT(1) = .TRUE. CHANGE = .TRUE. DO WHILE (CHANGE) CHANGE = .FALSE. DO V = 1,NVERTS DO I = 1,3 IF ( (1.LE.C(V,I)).AND.(C(V,I).LE.NVERTS) ) THEN IF ( LEFT(V) .AND. (.NOT.LEFT(C(V,I))) ) THEN CHANGE = .TRUE. LEFT(C(V,I)) = .TRUE. ENDIF ENDIF ENDDO ENDDO ENDDO C Check for connectedness DO V = 1,NVERTS IF ( .NOT.LEFT(V) ) THEN ONEPI = .FALSE. RETURN ENDIF ENDDO C--OK, that remaining graph was OK. Restore the graph. C(V1,I1) = V2 C(V2,I2) = V1 ENDIF ENDDO ENDIF ENDDO ENDDO C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE CHECK(CIN,NPERMS,ORDER,OK) C INTEGER SIZE PARAMETER (SIZE = 3) INTEGER CIN(2*SIZE,3),NPERMS,ORDER LOGICAL OK C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 INTEGER C(2*SIZE,3),V(2*SIZE) INTEGER L,I,VV C C Modified 15 February 2002. C IF (ORDER.EQ.1) THEN NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C DO VV = 1,NVERTS DO I = 1,3 C(VV,I) = CIN(VV,I) ENDDO ENDDO L = NVERTS NPERMS = 0 OK = .TRUE. C C "CALL PERMUTATIONS(L,C)" C C----- C "SUBROUTINE PERMUTATIONS(L,C)" C Mock subroutine that generates each element of the permutation C group S_(L-2), applies it to C, and calls CHECKOUT(C,CIN,ORDER,N,OK). C If OK = False is returned, the graph C was no good and we exit C from CHECK immediately. The structure is C SUBROUTINE PERMUTATIONS(L,C) C IF (L.EQ.4) THEN C CALL CHECKOUT(C,CIN,ORDER,NPERMS,OK) C IF (.NOT.OK) return from check C CALL EXCHANGE(3,4,C,ORDER) C CALL CHECKOUT(C,CIN,ORDER,NPERMS,OK) C IF (.NOT.OK) return from check C CALL EXCHANGE(3,4,C,ORDER) C RETURN C ENDIF C DO V(L) = L,3,-1 C CALL EXCHANGE(V(L),L,C,ORDER) C CALL PERMUTATIONS(L-1,C) C CALL EXCHANGE(V(L),L,C,ORDER) C ENDDO C RETURN C END C 1 CONTINUE IF (L.EQ.4) THEN CALL CHECKOUT(C,CIN,ORDER,NPERMS,OK) IF (.NOT.OK) RETURN CALL EXCHANGE(3,4,C,ORDER) CALL CHECKOUT(C,CIN,ORDER,NPERMS,OK) IF (.NOT.OK) RETURN CALL EXCHANGE(3,4,C,ORDER) C "RETURN" Which exit depends on whether we are at the top level. IF (L.LT.NVERTS) THEN GO TO 2 ELSE GO TO 4 ENDIF ENDIF C "DO V(L) = L,3,-1" V(L) = L 3 CONTINUE CALL EXCHANGE(V(L),L,C,ORDER) L = L - 1 C "CALL PERMUTATIONS(L,C)" GO TO 1 C Return from mock subroutine comes here for lower levels: 2 CONTINUE L = L + 1 CALL EXCHANGE(V(L),L,C,ORDER) V(L) = V(L) - 1 C "ENDDO" IF (V(L).GE.3) THEN GO TO 3 ENDIF C "RETURN" Executed from level L as long as L CIN we leave unchanged the C count NPERMS of how many vertex interchanges give the same graph and C return OK = True. If C = CIN, we add one to NPERMS, and we C still return OK = True. If C < CIN, then we should not have C generated CIN, so we return OK = False. C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 INTEGER V,I C IF (ORDER.EQ.1) THEN NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C DO V = 1,NVERTS DO I = 1,3 IF (C(V,I).LT.CIN(V,I)) THEN OK = .FALSE. RETURN ELSE IF (C(V,I).GT.CIN(V,I)) THEN OK = .TRUE. RETURN ENDIF ENDDO ENDDO C C Come to here if the new graph C is the same as CIN. C OK = .TRUE. NPERMS = NPERMS + 1 RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE EXCHANGE(V1,V2,C,ORDER) C INTEGER SIZE PARAMETER (SIZE = 3) INTEGER C(2*SIZE,3) INTEGER V1,V2,ORDER C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 INTEGER TEMP1,TEMP2,I,V LOGICAL CHANGE C IF (ORDER.EQ.1) THEN NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C DO I = 1,3 TEMP1 = C(V1,I) TEMP2 = C(V2,I) C(V1,I) = TEMP2 C(V2,I) = TEMP1 ENDDO C DO V = 1,NVERTS CHANGE = .FALSE. DO I = 1,3 IF (C(V,I).EQ.V1) THEN C(V,I) = V2 CHANGE = .TRUE. ELSE IF (C(V,I).EQ.V2) THEN C(V,I) = V1 CHANGE = .TRUE. ENDIF ENDDO IF (CHANGE) THEN C C Put vertices connected to vertex V in order C-- IF (C(V,2).LT.C(V,1)) THEN TEMP1 = C(V,1) TEMP2 = C(V,2) C(V,1) = TEMP2 C(V,2) = TEMP1 ENDIF IF (C(V,3).LT.C(V,1)) THEN TEMP1 = C(V,1) TEMP2 = C(V,3) C(V,1) = TEMP2 C(V,3) = TEMP1 ELSE IF (C(V,3).LT.C(V,2)) THEN TEMP1 = C(V,2) TEMP2 = C(V,3) C(V,2) = TEMP2 C(V,3) = TEMP1 ENDIF C-- ENDIF ENDDO C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C End of subroutines associated with NEWGRAPH C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE FINDA(VRTX,Q,NQ,ORDER,A,QOK) C INTEGER SIZE PARAMETER (SIZE = 3) C In: INTEGER VRTX(0:3*SIZE-1,2),Q(0:SIZE),NQ,ORDER C Out: INTEGER A(0:3*SIZE-1,0:SIZE) LOGICAL QOK C C Finds matrix A relating propagator momenta to loop momenta. C C VRTX(P,N) specifies the graph considered C Q(L) specifies the propagators to be considered independent C NQ specifies how many entries of Q should be considered C NQ = NLOOPS all the entries in Q should be considered. C If Q(0),Q(1),...,Q(NLOOPS) are independent then C FINDA generates the matrix A and sets QOK = .TRUE. C Otherwise the generation of A fails and QOK = .FALSE. C NQ < NLOOPS only first NQ entries in Q should be considered. C If Q(0),Q(1),...,Q(NQ) are independent then C FINDA sets QOK = .TRUE. C Otherwise QOK = .FALSE. C In either case, a complete A is not generated. C C L index of loop momenta, L = 0,1,...,NLOOPS. C L = 0 normally denontes the virtual photon momentum. C P index of propagator, P = 0,1,...,NPROPS. C P = 0 denotes the virtual photon momentum. C V index of vertices, V = 1,...,NVERTS C A(P,L) matrix relating propagator momenta to loop momenta. C K(P) = Sum_L A(P,L) K(Q(L)). C VRTX(P,1) = V means that the vertex connected to the tail of C propagator P is V. C VRTX(P,2) = V means that the vertex connected to the head of C propagator P is V. C Q(L) = P means that we consider the Lth loop momentum to C be that carried by propagator P. C CONNECTED(V,J) = P means that the Jth propagator connected to C vertex V is P. C FIXED(P) = True means that we have determined the momentum carried C by propagator P. C FINISHED(V) = True means that we have determined the momenta carried C by all the propagators connected to vertex V. C PROPSIGN(VRTX,P,V) is a function that returns +1 if the head of C propagator P is at V, -1 if the tail is at V. C COUNT is the number of propagators connected to the vertex C under consideration such that FIXED(P) = True. If C COUNT = 2, then we can fix another propagator momentum. C 3 July 1994 C 19 December 1995 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NLOOPS,NPROPS,NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C INTEGER L,P,V,J,L1,L2 INTEGER CONNECTED(2*SIZE,3) LOGICAL FIXED(0:3*SIZE-1),FINISHED(2*SIZE) LOGICAL CHANGE INTEGER PROPSIGN,SIGN INTEGER SUM(0:SIZE) INTEGER COUNT INTEGER PTOFIX C IF (ORDER.EQ.1) THEN NLOOPS = NLOOPS1 NPROPS = NPROPS1 NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NLOOPS = NLOOPS2 NPROPS = NPROPS2 NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C IF((NQ.LT.1).OR.(NQ.GT.NLOOPS)) THEN WRITE(NOUT,*)'NQ out of range in FINDA' ENDIF C C First check to see that the same propagator hasn't been C assigned to two loop variables. C DO L1 = 0,NQ-1 DO L2 = L1+1,NQ IF (Q(L1).EQ.Q(L2)) THEN QOK = .FALSE. RETURN ENDIF ENDDO ENDDO C C Initialization. C QOK = .FALSE. C DO V = 1,NVERTS J = 1 DO P = 0,NPROPS IF( (VRTX(P,1).EQ.V).OR.(VRTX(P,2).EQ.V) ) THEN CONNECTED(V,J) = P J = J+1 ENDIF ENDDO ENDDO C DO P = 0,NPROPS DO L = 0,NLOOPS A(P,L) = 0 ENDDO ENDDO DO L = 0,NQ A(Q(L),L) = 1 ENDDO C DO P = 0,NPROPS FIXED(P) = .FALSE. ENDDO DO L = 0,NQ FIXED(Q(L)) = .TRUE. ENDDO C DO V = 1,NVERTS FINISHED(V) = .FALSE. ENDDO C CHANGE = .TRUE. C C Start. C DO WHILE (CHANGE) CHANGE = .FALSE. C DO V = 1,NVERTS IF (.NOT.FINISHED(V)) THEN COUNT = 0 DO J = 1,3 P = CONNECTED(V,J) IF ( FIXED(P) ) THEN COUNT = COUNT + 1 ENDIF ENDDO C C There are 3 already fixed propagators conencted to this vertex, so C we must check to see if the momenta coming into the vertex sum to C zero. C IF (COUNT.EQ.3) THEN DO L = 0,NQ SUM(L) = 0 ENDDO DO J = 1,3 P = CONNECTED(V,J) SIGN = PROPSIGN(VRTX,P,V) DO L = 0,NQ SUM(L) = SUM(L) + SIGN * A(P,L) ENDDO ENDDO DO L = 0,NQ C C Dependent propagators given to FINDA. C IF (SUM(L).NE.0) THEN QOK = .FALSE. RETURN C ENDIF ENDDO FINISHED(V) = .TRUE. CHANGE = .TRUE. C C There are two already fixed propagators connected to this vertex, C so we should determine the momentum carried by the remaining, C unfixed, propagator. C ELSE IF (COUNT.EQ.2) THEN DO L = 0,NQ SUM(L) = 0 ENDDO DO J = 1,3 P = CONNECTED(V,J) IF ( FIXED(P) ) THEN SIGN = PROPSIGN(VRTX,P,V) DO L = 0,NQ SUM(L) = SUM(L) + SIGN * A(P,L) ENDDO ELSE PTOFIX = P ENDIF ENDDO SIGN = PROPSIGN(VRTX,PTOFIX,V) DO L = 0,NQ A(PTOFIX,L) = - SIGN * SUM(L) ENDDO FIXED(PTOFIX) = .TRUE. FINISHED(V) = .TRUE. CHANGE = .TRUE. ENDIF C C Close loop DO V = 1,NVERTS ; IF (.NOT.FINISHED(V)) THEN. C ENDIF ENDDO C C Close loop DO WHILE (CHANGE) C ENDDO C C At this point, we have not found a contradiction with momentum C conservation, so the Q's must have been OK: C QOK = .TRUE. C C If we had been given a complete set of Q's, then we should have C fixed each propagator at each vertex. Check just to make sure. C IF (NQ.EQ.NLOOPS) THEN DO V = 1,NVERTS IF (.NOT.FINISHED(V) ) THEN WRITE(NOUT,*)'SNAFU in FINDA' write(nout,*)'v = ',v,' nq =',nq write(nout,*)'q =',q(0),q(1),q(2),q(3) STOP ENDIF ENDDO ENDIF C RETURN C END C C23456789012345678901234567890123456789012345678901234567890123456789012 C INTEGER FUNCTION PROPSIGN(VRTX,P,V) C INTEGER SIZE PARAMETER (SIZE = 3) C In: INTEGER VRTX(0:3*SIZE-1,2) INTEGER P,V C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT C IF ( VRTX(P,1).EQ.V ) THEN PROPSIGN = -1 RETURN ELSE IF ( VRTX(P,2).EQ.V ) THEN PROPSIGN = 1 RETURN ELSE WRITE(NOUT,*)'PROPSIGN called for P not connected to V.' STOP ENDIF END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES) C INTEGER SIZE,MAXMAPS PARAMETER (SIZE = 3) PARAMETER (MAXMAPS = 64) C In: INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3) INTEGER ORDER C Out: INTEGER NMAPS,QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE) CHARACTER*6 MAPTYPES(MAXMAPS) C C Given a graph specified by VRTX and PROP, this C subroutine finds the characteristics of each map, C labelled by an index MAPNUMBER. For a given map, it C finds labels Q of 'special' propagators and C the corresponding signs QSIGN and the MAPTYPE. C The subroutine does finds the total number C of maps, NMAPS, and fills the corresponding C arrays QS, QSIGNS, and MAPTYPES, each of which C carries a MAPNUMBER index. C C The possibilities for maptypes are as follows: C C 1) T2TO2T used for k1 + k2 -> p1 + p2 with a virtual parton C with momentum q exchanged, q = k1 - p1. Then P(Q(1)) = q, C P(Q(2)) = p1, P(Q(3)) = p2. We will generate points with C CHOOSET2TO2T(p1,p2,q,ok). C C 2) T2TO2S used for k1 + k2 -> p1 + p2 with a *no* virtual C parton with momentum q = k1 - p1 exchanged. Then P(Q(1)) = k1, C P(Q(2)) = p1, P(Q(3)) = p2. We will generate points with C CHOOSE2TO2S(p1,p2,k1,ok). C C 3) T2TO3 used for k1 + k2 -> p1 + p2 + p3 with k2 = - k1. C Then P(Q(1)) = k1, P(Q(2)) = p1, P(Q(3)) = p2. We will generate C points with CHOOSET2TO3(p1,p2,k1,ok). C C 4) T2TO1 used for k1 + k2 -> p1 on shell. We will choose points C with CHOOSEST2TO1(p1,p2,k1,ok). C C We also have the possibility of Born graphs, for which the maptype C is BORN and Q(1) and Q(2) are chosen as two of the cut propagators. C C 20 December 2000 C 20 March 2001 C 1 February 2002 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER CUTMAX INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C INTEGER MAPNUMBER LOGICAL MORENEEDED C Newcut variables LOGICAL NEWCUTINIT INTEGER CUTINDEX(SIZE+1),CUTSIGN(SIZE+1),NCUT INTEGER ISIGN(3*SIZE-1) LOGICAL LEFTLOOP,RIGHTLOOP INTEGER LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1),NINLOOP LOGICAL CUTFOUND C INTEGER L,P,KJ,K1,K2,KDIRECT,PTEST,PLEAVING,PP1,PP2 INTEGER L1,SIGNL1,LTESTA,LTESTB INTEGER I,J,JFOUND1,JFOUND2 INTEGER V1,V2,V3,VOTHER,VV1,VV2 INTEGER SIGN0,SIGN1,SIGN2 INTEGER TIMESFOUND1,TIMESFOUND2,TIMESFOUND LOGICAL NOTINLOOP C C---------------------------------- C IF (ORDER.EQ.1) THEN CUTMAX = CUTMAX1 ELSE IF (ORDER.EQ.2) THEN CUTMAX = CUTMAX2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C MAPNUMBER = 0 MORENEEDED = .TRUE. NEWCUTINIT = .TRUE. DO WHILE (MORENEEDED) CALL NEWCUT(VRTX,ORDER,NEWCUTINIT,NCUT,ISIGN, > CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP, > NINLOOP,LOOPINDEX,LOOPSIGN,CUTFOUND) C IF (CUTFOUND) THEN C IF (ORDER.EQ.1) THEN C C First, we have the code for what to do for Born graphs. There C is no Q(3) or QSIGN(3) in this case. C MAPNUMBER = MAPNUMBER + 1 QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = CUTINDEX(1) QSIGNS(MAPNUMBER,1) = CUTSIGN(1) QS(MAPNUMBER,2) = CUTINDEX(2) QSIGNS(MAPNUMBER,2) = CUTSIGN(2) QS(MAPNUMBER,3) = 137 QSIGNS(MAPNUMBER,3) = 137 MAPTYPES(MAPNUMBER) = 'BORN ' C C Alternative for IF (ORDER.EQ.1) THEN C ELSE IF (ORDER.EQ.2) THEN C C We want to do something only if there is a virtual loop: C IF (NCUT.EQ.(CUTMAX-1)) THEN C--- C Case of 4 propagators in the loop C--- IF (NINLOOP.EQ.4) THEN C C For a 4 propagator loop there are two ellipse maps (T2T02T) and C one circle map (T2TO3). We do the two ellipse maps first. C DO L = 2,3 MAPNUMBER = MAPNUMBER + 1 P = LOOPINDEX(L) V1 = VRTX(P,1) V2 = VRTX(P,2) C C We find the cut propagators K1 and K2 connected to V1 and V2 along C with the sign = +1 if the cut propagator Kj is leaving vertex Vj C and sign = -1 if the cut propagator Kj is entering vertex Vj. Just C as a check, we define FOUNDJ to see if we find K1 and K2 exactly C once. C TIMESFOUND1 = 0 TIMESFOUND2 = 0 DO J = 1,3 KJ = CUTINDEX(J) IF (VRTX(KJ,1).EQ.V1) THEN K1 = KJ SIGN1 = +1 TIMESFOUND1 = TIMESFOUND1+1 ELSE IF (VRTX(KJ,2).EQ.V1) THEN K1 = KJ SIGN1 = -1 TIMESFOUND1 = TIMESFOUND1+1 ELSE IF (VRTX(KJ,1).EQ.V2) THEN K2 = KJ SIGN2 = +1 TIMESFOUND2 = TIMESFOUND2+1 ELSE IF (VRTX(KJ,2).EQ.V2) THEN K2 = KJ SIGN2 = -1 TIMESFOUND2 = TIMESFOUND2+1 ENDIF ENDDO IF ((TIMESFOUND1.NE.1).OR.(TIMESFOUND2.NE.1)) THEN WRITE(NOUT,*) 'Failure in FINDTYPES' STOP ENDIF C C Now we record this information. C QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = P QSIGNS(MAPNUMBER,1) = +1 QS(MAPNUMBER,2) = K1 QSIGNS(MAPNUMBER,2) = SIGN1 QS(MAPNUMBER,3) = K2 QSIGNS(MAPNUMBER,3) = SIGN2 MAPTYPES(MAPNUMBER) = 'T2TO2T' C C End DO L = 2,3 for the choice of two ellipse maps. C ENDDO C C Now we do the circle map. C Our definition for the circle map T2TO3E is that Q(1) is C LOOPINDEX(1) the first propagator in the loop starting from the C current vertex. Then Q(2) is the label of the propagator that C enters the final state and connects to the vertex at the head C of propagator Q(1). Then Q(3) is the label of the propagator C that enters the final state and connects to the propagator with C label LOOPINDEX(4), the last propagator in the loop. The sign C QSIGN(1) = +1 since this propagator always points *from* the C current vertex. For QSIGN(2) and QSIGN(3) a plus sign indicates C that the propagator points toward the final state, a minus sign C indicates the opposite. C IF(LOOPSIGN(1).NE.1) THEN WRITE(NOUT,*)'LOOPSIGN(1) not 1 in FINDTYPES' STOP ELSE IF(LOOPSIGN(4).NE.-1) THEN WRITE(NOUT,*)'LOOPSIGN(4) not -1 in FINDTYPES' STOP ENDIF C V1 = VRTX(LOOPINDEX(1),2) V2 = VRTX(LOOPINDEX(4),2) TIMESFOUND1 = 0 TIMESFOUND2 = 0 DO J = 1,3 KJ = CUTINDEX(J) IF (VRTX(KJ,1).EQ.V1) THEN K1 = KJ SIGN1 = +1 TIMESFOUND1 = TIMESFOUND1+1 ELSE IF (VRTX(KJ,2).EQ.V1) THEN K1 = KJ SIGN1 = -1 TIMESFOUND1 = TIMESFOUND1+1 ELSE IF (VRTX(KJ,1).EQ.V2) THEN K2 = KJ SIGN2 = +1 TIMESFOUND2 = TIMESFOUND2+1 ELSE IF (VRTX(KJ,2).EQ.V2) THEN K2 = KJ SIGN2 = -1 TIMESFOUND2 = TIMESFOUND2+1 ENDIF ENDDO IF ((TIMESFOUND1.NE.1).OR.(TIMESFOUND2.NE.1)) THEN WRITE(NOUT,*) 'Oops, failure in FINDTYPES', > TIMESFOUND1,TIMESFOUND2 STOP ENDIF C MAPNUMBER = MAPNUMBER + 1 QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = LOOPINDEX(1) QSIGNS(MAPNUMBER,1) = +1 QS(MAPNUMBER,2) = K1 QSIGNS(MAPNUMBER,2) = SIGN1 QS(MAPNUMBER,3) = K2 QSIGNS(MAPNUMBER,3) = SIGN2 MAPTYPES(MAPNUMBER) = 'T2TO3E' C C--- C Case of 3 propagators in the loop C--- ELSE IF (NINLOOP.EQ.3) THEN C C We are not sure which of two possibilities we have, but we proceed C as if we had the case of a virtual loop that connects to two C propagators that go into the final state. C MAPNUMBER = MAPNUMBER + 1 P = LOOPINDEX(2) V1 = VRTX(P,1) V2 = VRTX(P,2) C C We find the cut propagators K1 and K2 connected to V1 and V2 along C with the sign = +1 if the cut propagator Kj is leaving vertex Vj C and sign = -1 if the cut propagator Kj is entering vertex Vj. We C check using FOUNDJ to see if we find K1 and K2 exactly once. C TIMESFOUND1 = 0 TIMESFOUND2 = 0 DO J = 1,3 KJ = CUTINDEX(J) IF (VRTX(KJ,1).EQ.V1) THEN K1 = KJ SIGN1 = +1 TIMESFOUND1 = TIMESFOUND1+1 ELSE IF (VRTX(KJ,2).EQ.V1) THEN K1 = KJ SIGN1 = -1 TIMESFOUND1 = TIMESFOUND1+1 ELSE IF (VRTX(KJ,1).EQ.V2) THEN K2 = KJ SIGN2 = +1 TIMESFOUND2 = TIMESFOUND2+1 ELSE IF (VRTX(KJ,2).EQ.V2) THEN K2 = KJ SIGN2 = -1 TIMESFOUND2 = TIMESFOUND2+1 ENDIF ENDDO C C Now we figure out what to do based on what we found. C IF ((TIMESFOUND1.GT.1).OR.(TIMESFOUND2.GT.1)) THEN WRITE(NOUT,*) 'Failure in FINDTYPES' STOP ELSE IF ((TIMESFOUND1.LT.1).AND.(TIMESFOUND2.LT.1)) THEN WRITE(NOUT,*) 'Failure in FINDTYPES' STOP C ELSE IF ((TIMESFOUND1.EQ.1).AND.(TIMESFOUND2.EQ.1)) THEN C C This is the case we were looking for. Now we record the information. C QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = P QSIGNS(MAPNUMBER,1) = +1 QS(MAPNUMBER,2) = K1 QSIGNS(MAPNUMBER,2) = SIGN1 QS(MAPNUMBER,3) = K2 QSIGNS(MAPNUMBER,3) = SIGN2 MAPTYPES(MAPNUMBER) = 'T2TO2T' C ELSE C C Either Found1 = 1 and Found2 = 0 or Found2 = 1 and Found1 = 0. C In these cases our loop does *not* connect to two propagators C that go to the final state. The label of the propagator C that enters the final state will be called Kdirect and the C vertex that does not connect to this propagator will be called C Vother. We take sign0 = +1 if our loop propagator points from C Kdirect to the s-channel propagator that splits into two C propagators that go to the final state. Otherwise sign0 = -1. C IF ((TIMESFOUND1.EQ.1).AND.(TIMESFOUND2.EQ.0)) THEN KDIRECT = K1 VOTHER = V2 SIGN0 = +1 ELSE IF ((TIMESFOUND1.EQ.0).AND.(TIMESFOUND2.EQ.1)) THEN KDIRECT = K2 VOTHER = V1 SIGN0 = -1 ENDIF C C Now we deal with this case. C IF (CUTINDEX(1).EQ.KDIRECT) THEN K1 = CUTINDEX(2) K2 = CUTINDEX(3) ELSE IF (CUTINDEX(2).EQ.KDIRECT) THEN K1 = CUTINDEX(3) K2 = CUTINDEX(1) ELSE IF (CUTINDEX(3).EQ.KDIRECT) THEN K1 = CUTINDEX(1) K2 = CUTINDEX(2) ELSE WRITE(NOUT,*)'We are in real trouble here.' STOP ENDIF C C We have K1 and K2, but we need the corresponding signs. C Find the index Pleaving of the propagator leaving the loop toward C the final state. C TIMESFOUND = 0 DO J = 1,3 PTEST = PROP(VOTHER,J) NOTINLOOP = .TRUE. DO I = 1,3 IF (PTEST.EQ.LOOPINDEX(I)) THEN NOTINLOOP = .FALSE. ENDIF ENDDO IF (NOTINLOOP) THEN PLEAVING = PTEST TIMESFOUND = TIMESFOUND + 1 ENDIF ENDDO IF (TIMESFOUND.NE.1) THEN WRITE(NOUT,*)'Pleaving not found or found twice.' STOP ENDIf C C Let V3 be the vertex not in the loop at the end of propagator C Pleaving. Two propagators in the final state must connect to this C vertex. C V3 = VRTX(PLEAVING,1) IF (V3.EQ.VOTHER) THEN V3 = VRTX(PLEAVING,2) ENDIF C C We use V3 to get the proper signs. C IF (VRTX(K1,1).EQ.V3) THEN SIGN1 = +1 ELSE IF (VRTX(K1,2).EQ.V3) THEN SIGN1 = -1 ELSE WRITE(NOUT,*)'Yikes, this is bad.' STOP ENDIF IF (VRTX(K2,1).EQ.V3) THEN SIGN2 = +1 ELSE IF (VRTX(K2,2).EQ.V3) THEN SIGN2 = -1 ELSE WRITE(NOUT,*)'Yikes, this is also bad.' STOP ENDIF C C Now we record the information. C Recall that P = LOOPINDEX(2) and that SIGN0 = +1 if propagator P C points toward propagator Pleaving. C QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = P QSIGNS(MAPNUMBER,1) = SIGN0 QS(MAPNUMBER,2) = K1 QSIGNS(MAPNUMBER,2) = SIGN1 QS(MAPNUMBER,3) = K2 QSIGNS(MAPNUMBER,3) = SIGN2 MAPTYPES(MAPNUMBER) = 'T2TO2S' C C But we are not done, because in this case we need a circle map too. C Our definition for the circle map T2TO3D is that Q(1) is C LOOPINDEX(1) or LOOPINDEX(3), one of the two propagators that C connects to a propagator that connects to the current vertex. C We take the one that connects to vertex Vother that connects to C a propagator Pleaving that connects vertex V3 that, finally, C connects to to two propagators that enter the final state. Then C Q(3) and Q(3) are these two propagators that enter the final C state from vertex V3. For QSIGN(2) and QSIGN(3) a plus sign C indicates that the propagator points toward the final state, a C minus sign indicates the opposite. The sign QSIGN(1) is + 1 if C this propagator points toward the final state, -1 in the C opposite circumstance. C IF (LOOPSIGN(1).NE.1) THEN WRITE(NOUT,*)'LOOPSIGN not 1 in FINDTYPES' STOP ENDIF C C The loop momentum with label L1 is the one that C attaches to VOTHER (the vertex that connects to a propagator C that splits before going to the final state.) We take C SIGNL1 = +1 if this propagator points towards VOTHER. C LTESTA = LOOPINDEX(1) LTESTB = LOOPINDEX(3) IF (VRTX(LTESTA,2).EQ.VOTHER) THEN L1 = LTESTA SIGNL1 = +1 ELSE IF (VRTX(LTESTA,1).EQ.VOTHER) THEN L1 = LTESTA SIGNL1 = -1 ELSE IF (VRTX(LTESTB,2).EQ.VOTHER) THEN L1 = LTESTB SIGNL1 = +1 ELSE IF (VRTX(LTESTB,1).EQ.VOTHER) THEN L1 = LTESTB SIGNL1 = -1 ELSE WRITE(NOUT,*)'Cannot seem to find L1' STOP ENDIF C MAPNUMBER = MAPNUMBER + 1 QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = L1 QSIGNS(MAPNUMBER,1) = SIGNL1 QS(MAPNUMBER,2) = K1 QSIGNS(MAPNUMBER,2) = SIGN1 QS(MAPNUMBER,3) = K2 QSIGNS(MAPNUMBER,3) = SIGN2 MAPTYPES(MAPNUMBER) = 'T2TO3D' C C Close the IF structure for the case of three particles in the loop, C IF (FOUND1.GT.1).OR.(FOUND2.GT.1) THEN ... C ENDIF C--- C Case of 2 propagators in the loop C--- ELSE IF (NINLOOP.EQ.2) THEN C C We are not sure which of two possibilities we have, but we proceed C as if we had the case of a virtual loop that connects to two C propagators that go into the final state. C MAPNUMBER = MAPNUMBER + 1 P = LOOPINDEX(1) V1 = VRTX(P,1) V2 = VRTX(P,2) C C We find the cut propagators K1 or K2 connected to V1 or V2 along C with the sign = +1 if the cut propagator Kj is leaving vertex Vj C and sign = -1 if the cut propagator Kj is entering vertex Vj. We C check using FOUNDJ to see if we find K1 or K2 exactly once. C TIMESFOUND1 = 0 TIMESFOUND2 = 0 DO J = 1,3 KJ = CUTINDEX(J) IF (VRTX(KJ,1).EQ.V1) THEN K1 = KJ SIGN1 = +1 JFOUND1 = J TIMESFOUND1 = TIMESFOUND1+1 ELSE IF (VRTX(KJ,2).EQ.V1) THEN K1 = KJ SIGN1 = -1 JFOUND1 = J TIMESFOUND1 = TIMESFOUND1+1 ELSE IF (VRTX(KJ,1).EQ.V2) THEN K2 = KJ SIGN2 = +1 JFOUND2 = J TIMESFOUND2 = TIMESFOUND2+1 ELSE IF (VRTX(KJ,2).EQ.V2) THEN K2 = KJ SIGN2 = -1 JFOUND2 = J TIMESFOUND2 = TIMESFOUND2+1 ENDIF ENDDO C C Now we figure out what to do based on what we found. C IF ((TIMESFOUND1.GT.1).OR.(TIMESFOUND2.GT.1)) THEN WRITE(NOUT,*) 'Failure in FINDTYPES' STOP C ELSE IF ((TIMESFOUND1.EQ.1).AND.(TIMESFOUND2.EQ.0)) THEN C C This is one of the cases we were looking for. Now we record the C information. The propagator Q(3) is one of the propagators C in the final state other than that connected to our loop. The C corresponding sign is +1 if this propagator crosses the final C state cut in the same direction as the propagator connected to C our loop. C QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = P QSIGNS(MAPNUMBER,1) = -1 QS(MAPNUMBER,2) = K1 QSIGNS(MAPNUMBER,2) = SIGN1 IF (CUTINDEX(1).NE.K1) THEN QS(MAPNUMBER,3) = CUTINDEX(1) QSIGNS(MAPNUMBER,3) = CUTSIGN(1)*CUTSIGN(JFOUND1)*SIGN1 ELSE QS(MAPNUMBER,3) = CUTINDEX(2) QSIGNS(MAPNUMBER,3) = CUTSIGN(2)*CUTSIGN(JFOUND1)*SIGN1 ENDIF MAPTYPES(MAPNUMBER) = 'T2TO1 ' C ELSE IF ((TIMESFOUND1.EQ.0).AND.(TIMESFOUND2.EQ.1)) THEN C C This is one of the cases we were looking for. Now we record the C information. The propagator Q(3) is one of the propagators C in the final state other than that connected to our loop. The C corresponding sign is +1 if this propagator crosses the final C state cut in the same direction as the propagator connected to C our loop. C QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = P QSIGNS(MAPNUMBER,1) = +1 QS(MAPNUMBER,2) = K2 QSIGNS(MAPNUMBER,2) = SIGN2 IF (CUTINDEX(1).NE.K2) THEN QS(MAPNUMBER,3) = CUTINDEX(1) QSIGNS(MAPNUMBER,3) = CUTSIGN(1)*CUTSIGN(JFOUND2)*SIGN2 ELSE QS(MAPNUMBER,3) = CUTINDEX(2) QSIGNS(MAPNUMBER,3) = CUTSIGN(2)*CUTSIGN(JFOUND2)*SIGN2 ENDIF MAPTYPES(MAPNUMBER) = 'T2TO1 ' C ELSE IF ((TIMESFOUND1.EQ.0).AND.(TIMESFOUND2.EQ.0)) THEN C C Here TimesFound1 = 0 and TimesFound2 = 0, so our loop does *not* C connect to a propagator that goes to the final state. C Find the indices PP1 and PP2 of the propagators connected to C our loop. C TIMESFOUND = 0 DO J = 1,3 PTEST = PROP(V1,J) NOTINLOOP = .TRUE. DO I = 1,2 IF (PTEST.EQ.LOOPINDEX(I)) THEN NOTINLOOP = .FALSE. ENDIF ENDDO IF (NOTINLOOP) THEN PP1 = PTEST TIMESFOUND = TIMESFOUND + 1 ENDIF ENDDO IF (TIMESFOUND.NE.1) THEN WRITE(NOUT,*)'PP1 not found or found twice.' STOP ENDIf TIMESFOUND = 0 C DO J = 1,3 PTEST = PROP(V2,J) NOTINLOOP = .TRUE. DO I = 1,2 IF (PTEST.EQ.LOOPINDEX(I)) THEN NOTINLOOP = .FALSE. ENDIF ENDDO IF (NOTINLOOP) THEN PP2 = PTEST TIMESFOUND = TIMESFOUND + 1 ENDIF ENDDO IF (TIMESFOUND.NE.1) THEN WRITE(NOUT,*)'PP2 not found or found twice.' STOP ENDIf C C Let VV1 and VV2 be the vertices not in the loop at the end of C propagators PP1 and PP2 respectively. Two propagators in the final C state must connect to one of these vertices. C VV1 = VRTX(PP1,1) IF (VV1.EQ.V1) THEN VV1 = VRTX(PP1,2) ENDIF VV2 = VRTX(PP2,1) IF (VV2.EQ.V2) THEN VV2 = VRTX(PP2,2) ENDIF C C We have VV1 and VV2. A slight hitch is that one of them might be C the vertex 1 or 2 that connect to the photon. In this case, C in the next step we do *not* want to find the final state C propagator that connects to this vertex. A cure is to set the C vertex number to something impossible. C IF ((VV1.EQ.1).OR.(VV1.EQ.2)) THEN VV1 = -17 ENDIF IF ((VV2.EQ.1).OR.(VV2.EQ.2)) THEN VV2 = -17 ENDIF C C Now we find two final state propagators connected to VV1 or C else two final state propagators connected to VV2. C TIMESFOUND = 0 DO J = 1,3 KJ = CUTINDEX(J) IF (VRTX(KJ,1).EQ.VV1) THEN IF(TIMESFOUND.EQ.0) THEN K1 = KJ SIGN1 = +1 ELSE K2 = KJ SIGN2 = +1 ENDIF SIGN0 = -1 TIMESFOUND = TIMESFOUND+1 ELSE IF (VRTX(KJ,1).EQ.VV2) THEN IF(TIMESFOUND.EQ.0) THEN K1 = KJ SIGN1 = +1 ELSE K2 = KJ SIGN2 = +1 ENDIF SIGN0 = +1 TIMESFOUND = TIMESFOUND+1 ELSE IF (VRTX(KJ,2).EQ.VV1) THEN IF(TIMESFOUND.EQ.0) THEN K1 = KJ SIGN1 = -1 ELSE K2 = KJ SIGN2 = -1 ENDIF SIGN0 = -1 TIMESFOUND = TIMESFOUND+1 ELSE IF (VRTX(KJ,2).EQ.VV2) THEN IF(TIMESFOUND.EQ.0) THEN K1 = KJ SIGN1 = -1 ELSE K2 = KJ SIGN2 = -1 ENDIF SIGN0 = +1 TIMESFOUND = TIMESFOUND+1 ENDIF ENDDO IF (TIMESFOUND.NE.2) THEN WRITE(NOUT,*)'Where are those tricky propagators?',TIMESFOUND STOP ENDIf C C Now we record the information. C Recall that P = LOOPINDEX(1) and that SIGN0 = +1 if propagator P C points toward propagators in the final state. C QS(MAPNUMBER,0) = 0 QSIGNS(MAPNUMBER,0) = +1 QS(MAPNUMBER,1) = P QSIGNS(MAPNUMBER,1) = SIGN0 QS(MAPNUMBER,2) = K1 QSIGNS(MAPNUMBER,2) = SIGN1 QS(MAPNUMBER,3) = K2 QSIGNS(MAPNUMBER,3) = SIGN2 MAPTYPES(MAPNUMBER) = 'T2TO2S' C C Close IF ((TIMESFOUND1.GT.1).OR.(TIMESFOUND2.GT.1)) THEN ... C ENDIF C C Case of less than 2 propagators in the loop C ELSE WRITE(NOUT,*) 'Looped the loop in FINDDQS' STOP C C End IF (NINLOOP.EQ. n ) series C ENDIF C C End IF (there is a virtual loop) THEN ... C ENDIF C C Close IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ... C ELSE WRITE(NOUT,*)'ORDER in FINDTYPES needed to be 1 or 2.' STOP ENDIF C C End IF (CUTFOUND) THEN ... If the cut was not found, then we are done. C ELSE MORENEEDED = .FALSE. ENDIF C C End main loop: DO WHILE (MORENEEDED) C ENDDO C NMAPS = MAPNUMBER RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE NEWPOINT(A,QSIGN,MAPTYPE,ORDER,K,ABSK,BADPOINT) C INTEGER SIZE PARAMETER (SIZE = 3) C In: INTEGER A(0:3*SIZE-1,0:SIZE),QSIGN(0:SIZE) CHARACTER*6 MAPTYPE INTEGER ORDER C Out: REAL*8 K(0:3*SIZE-1,0:3),ABSK(0:3*SIZE-1) LOGICAL BADPOINT C C Chooses a new Monte Carlo point in the space of loop 3-momenta. C 4 March 1993 C 12 July 1993 C 17 July 1994 C 2 May 1996 C 5 February 1997 C 4 February 1999 C 10 March 1999 C 9 April 1999 C 20 August 1999 C 21 December 2000 C 20 March 2001 C 8 February 2002 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NPROPS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C REAL*8 P1(3),P2(3),P3(3),ELL1(3) INTEGER P,MU REAL*8 TEMP,KSQ LOGICAL OK C C------------ C IF (ORDER.EQ.1) THEN NPROPS = NPROPS1 ELSE IF (ORDER.EQ.2) THEN NPROPS = NPROPS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C BADPOINT = .FALSE. C IF (ORDER.EQ.1) THEN C C We deal with the case of a Born graph first. C CALL CHOOSE3(P1,P2,P3,OK) IF(.NOT.OK) THEN DO P = 1,NPROPS DO MU = 0,3 K(P,MU) = 0.0D0 ENDDO ENDDO BADPOINT = .TRUE. RETURN ENDIF DO P = 1,NPROPS KSQ = 0.0D0 DO MU = 1,3 TEMP = A(P,1)*QSIGN(1)*P1(MU) > + A(P,2)*QSIGN(2)*P2(MU) K(P,MU) = TEMP KSQ = KSQ + TEMP**2 ENDDO ABSK(P) = SQRT(KSQ) K(P,0) = 0.0D0 ENDDO DO MU = 0,3 K(0,MU) = 0.0D0 ENDDO ABSK(0) = 0.0D0 C C Alternative for IF (ORDER.EQ.1) THEN C ELSE IF (ORDER.EQ.2) THEN C C Here is what we do for order alpha_s^2 graphs. C C Our notation: C special loop momentum, to become QSIGN(1)*ELL(1,mu), is ELL1(mu); C first final state parton, to become QSIGN(2)*ELL(2,mu), is P1(mu); C second final state parton, to become QSIGN(3)*ELL(3,mu), is P2(mu); C third final state parton, not reported, is P3(mu). C We use {ELL1,P1,P2} directly to generate the K(P,mu). C C First, we need to generate a three parton final state. C Abort if we get a not OK signal. C CALL CHOOSE3(P1,P2,P3,OK) IF(.NOT.OK) THEN DO P = 1,NPROPS DO MU = 0,3 K(P,MU) = 0.0D0 ENDDO ENDDO BADPOINT = .TRUE. RETURN ENDIF C C Then we generate the loop momentum, ell1. C Abort if we get a not OK signal. C IF (MAPTYPE.EQ.'T2TO3D') THEN CALL CHOOSE2TO3D(P1,P2,ELL1,OK) IF(.NOT.OK) THEN DO P = 1,NPROPS DO MU = 0,3 K(P,MU) = 0.0D0 ENDDO ENDDO BADPOINT = .TRUE. RETURN ENDIF ELSE IF (MAPTYPE.EQ.'T2TO3E') THEN CALL CHOOSE2TO3E(P1,P2,ELL1,OK) IF(.NOT.OK) THEN DO P = 1,NPROPS DO MU = 0,3 K(P,MU) = 0.0D0 ENDDO ENDDO BADPOINT = .TRUE. RETURN ENDIF ELSE IF (MAPTYPE.EQ.'T2TO2T') THEN CALL CHOOSE2TO2T(P1,P2,ELL1,OK) IF(.NOT.OK) THEN DO P = 1,NPROPS DO MU = 0,3 K(P,MU) = 0.0D0 ENDDO ENDDO BADPOINT = .TRUE. RETURN ENDIF ELSE IF (MAPTYPE.EQ.'T2TO2S') THEN CALL CHOOSE2TO2S(P1,P2,ELL1,OK) IF(.NOT.OK) THEN DO P = 1,NPROPS DO MU = 0,3 K(P,MU) = 0.0D0 ENDDO ENDDO BADPOINT = .TRUE. RETURN ENDIF ELSE IF (MAPTYPE.EQ.'T2TO1 ') THEN CALL CHOOSE2TO1(P1,P2,ELL1,OK) IF(.NOT.OK) THEN DO P = 1,NPROPS DO MU = 0,3 K(P,MU) = 0.0D0 ENDDO ENDDO BADPOINT = .TRUE. RETURN ENDIF ELSE WRITE(NOUT,*)'Bad MAPTYPE in NEWPOINT' STOP ENDIF C C Now we have ELL1(mu), P1(mu), and P2(mu) and we need to translate to C the propagator momenta K(P,MU). C DO P = 1,NPROPS KSQ = 0.0D0 DO MU = 1,3 TEMP = A(P,1)*QSIGN(1)*ELL1(MU) > + A(P,2)*QSIGN(2)*P1(MU) > + A(P,3)*QSIGN(3)*P2(MU) K(P,MU) = TEMP KSQ = KSQ + TEMP**2 ENDDO ABSK(P) = SQRT(KSQ) K(P,0) = 0.0D0 ENDDO DO MU = 0,3 K(0,MU) = 0.0D0 ENDDO ABSK(0) = 0.0D0 C C Close IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ... C ELSE WRITE(NOUT,*)'ORDER should have been 1 or 2 in NEWPOINT.' STOP ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE CHECKPOINT(K,ABSK,PROP,ORDER,BADNESS) C INTEGER SIZE PARAMETER (SIZE = 3) C In: REAL*8 K(0:3*SIZE-1,0:3),ABSK(0:3*SIZE-1) INTEGER PROP(2*SIZE,3) INTEGER ORDER C Out: REAL*8 BADNESS C C Calculates the BADNESS of a point chosen by NEWPOINT. If there C are very collinear particles meeting at a vertex or of there is a C very soft particle, then the badness is big. Specifically, for C each vertex V we order the momenta entering the vertex Kmin, Kmid C Kmax in order of |K|. Then C C Kmin (Kmin + Kmid - Kmax )/Kmax^2 C C is the 1/badness^2 for that vertex. The badness for the point is the C largest of the badness values of all the vertices. C C Revised 13 may 1998 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NVERTS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C REAL*8 SMALLNESSV,SMALLNESS INTEGER V REAL*8 KMIN,KMID,KMAX,K1,K2,K3 C IF (ORDER.EQ.1) THEN NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C SMALLNESS = 1.0D0 DO V = 3,NVERTS K1 = ABSK(PROP(V,1)) K2 = ABSK(PROP(V,2)) K3 = ABSK(PROP(V,3)) IF (K1.LT.K2) THEN KMIN = K1 KMAX = K2 ELSE KMIN = K2 KMAX = K1 ENDIF IF (K3.LT.KMIN) THEN KMID = KMIN KMIN = K3 ELSE IF (K3.GT.KMAX) THEN KMID = KMAX KMAX = K3 ELSE KMID = K3 ENDIF SMALLNESSV = KMIN * (KMIN + KMID - KMAX) /KMAX**2 IF( SMALLNESSV .LT. SMALLNESS ) THEN SMALLNESS = SMALLNESSV ENDIF ENDDO IF (SMALLNESS.LT.1.0D-30) THEN BADNESS = 1.0D15 ELSE BADNESS = SQRT(1.0D0/SMALLNESS) ENDIF RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE AXES(EA,EB,EC) C C In: REAL*8 EA(3) C Out: REAL*8 EB(3),EC(3) C C Given a unit vector E_a(mu), generates unit vectors E_b(mu) and C E_c(mu) such that E_a*E_b = E_b*E_c = E_c*E_a = 0. C C The vector E_b will lie in the plane formed by the z-axis and C E_a unless E_a itself is nearly aligned along the z-axis, in which C case E_b will lie in the plane formed by the x-axis and E_a. C C 18 April 1996 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT C REAL*8 COSTHETASQ,SINTHETAINV C C For check C INTEGER MU REAL*8 DOTAA,DOTBB,DOTCC,DOTAB,DOTAC,DOTBC C COSTHETASQ = EA(3)**2 IF(COSTHETASQ.LT.0.9D0) THEN SINTHETAINV = 1.0D0/SQRT(1.0D0 - COSTHETASQ) EC(1) = - EA(2)*SINTHETAINV EC(2) = EA(1)*SINTHETAINV EC(3) = 0.0D0 ELSE COSTHETASQ = EA(1)**2 SINTHETAINV = 1.0D0/SQRT(1.0D0 - COSTHETASQ) EC(1) = 0.0D0 EC(2) = - EA(3)*SINTHETAINV EC(3) = EA(2)*SINTHETAINV ENDIF EB(1) = EC(2)*EA(3) - EC(3)*EA(2) EB(2) = EC(3)*EA(1) - EC(1)*EA(3) EB(3) = EC(1)*EA(2) - EC(2)*EA(1) C C Check: C DOTAA = 0.0D0 DOTBB = 0.0D0 DOTCC = 0.0D0 DOTAB = 0.0D0 DOTAC = 0.0D0 DOTBC = 0.0D0 DO MU = 1,3 DOTAA = DOTAA + EA(MU)*EA(MU) DOTBB = DOTBB + EB(MU)*EB(MU) DOTCC = DOTCC + EC(MU)*EC(MU) DOTAB = DOTAB + EA(MU)*EB(MU) DOTAC = DOTAC + EA(MU)*EC(MU) DOTBC = DOTBC + EB(MU)*EC(MU) ENDDO IF (ABS(DOTAA - 1.0D0).GT.1.0D20) THEN WRITE(NOUT,*)'DOTAA messed up in AXES' STOP ELSE IF (ABS(DOTBB - 1.0D0).GT.1.0D20) THEN WRITE(NOUT,*)'DOTBB messed up in AXES' STOP ELSE IF (ABS(DOTCC - 1.0D0).GT.1.0D20) THEN WRITE(NOUT,*)'DOTCC messed up in AXES' STOP ELSE IF (ABS(DOTAB).GT.1.0D20) THEN WRITE(NOUT,*)'DOTAB messed up in AXES' STOP ELSE IF (ABS(DOTAC).GT.1.0D20) THEN WRITE(NOUT,*)'DOTAC messed up in AXES' STOP ELSE IF (ABS(DOTBC).GT.1.0D20) THEN WRITE(NOUT,*)'DOTBC messed up in AXES' STOP ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C Subroutine to calculate integrand C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE CALCULATE(VRTX,GRAPHNUMBER,ORDER,KIN,ABSKIN, > QS,QSIGNS,MAPTYPES,NMAPS,VALUE,MAXPART,VALUECHK) C INTEGER SIZE,MAXMAPS PARAMETER (SIZE = 3) PARAMETER (MAXMAPS = 64) C In: INTEGER VRTX(0:3*SIZE-1,2) INTEGER GRAPHNUMBER,ORDER REAL*8 KIN(0:3*SIZE-1,0:3),ABSKIN(0:3*SIZE-1) INTEGER QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE) CHARACTER*6 MAPTYPES(MAXMAPS) INTEGER NMAPS C Out: COMPLEX*16 VALUE,VALUECHK REAL*8 MAXPART C C Calculates the value of the graph specified by VRTX at the point K, C returning result in VALUE, which includes the division by the density C of points and the jacobian for deforming the contour. Also reports C MAXPART, the biggest absolute value of the contributions to Re(VALUE). C This helps us to keep track of cancellations and thus to abort the C calculation if too much cancellation among terms will be required. C C********************* C C Max number of graphs, for array size: INTEGER MAXGRAPHS PARAMETER (MAXGRAPHS = 12) C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NLOOPS,NPROPS,CUTMAX INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 REAL*8 MUOVERRTS COMMON /RENORMALIZE/ MUOVERRTS LOGICAL REPORT,DETAILS COMMON /CALCULOOK/ REPORT,DETAILS REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF CHARACTER*7 GAUGE COMMON /GAUGECHOICE/ GAUGE C How many graphs and how many cuts and maps for each: INTEGER NUMBEROFGRAPHS INTEGER NUMBEROFCUTS(MAXGRAPHS) INTEGER NUMBEROFMAPS(MAXGRAPHS) COMMON /GRAPHCOUNTS/ NUMBEROFGRAPHS,NUMBEROFCUTS,NUMBEROFMAPS C What the program should do CHARACTER*6 MODE COMMON /PROGRAMMODE/ MODE C Physics data REAL*8 ALPHASOFMZ,MZ,EXTERNALRTS COMMON /PHYSICSDATA/ ALPHASOFMZ,MZ,EXTERNALRTS C Labels: INTEGER QE(0:SIZE) C Momenta: REAL*8 K(0:3*SIZE-1,0:3),ABSK(0:3*SIZE-1) REAL*8 KINLOOP(SIZE+1,0:3) REAL*8 KCUT(SIZE+1,0:3) COMPLEX*16 NEWKINLOOP(0:3) COMPLEX*16 KC(0:3*SIZE-1,0:3) COMPLEX*16 ELLSQ,ELL REAL*8 E(0:SIZE),RTS C Renormalization: REAL*8 MUMSBAR C Matrices: INTEGER AE(0:3*SIZE-1,0:SIZE) C FINDA variable: LOGICAL QOK C DENSITY variables: REAL*8 JACNEWPOINT,DENSITY C NEWCUT variables: INTEGER CUTINDEX(SIZE+1),CUTSIGN(SIZE+1),NCUT INTEGER ISIGN(3*SIZE-1) LOGICAL LEFTLOOP,RIGHTLOOP INTEGER LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1),NINLOOP C Loopcut variables: LOGICAL CALCMORE INTEGER JCUT,INDEX,LOOPCUTSIGN C DEFORM variables: COMPLEX*16 JACDEFORM C Functions: REAL*8 CALS0,SMEAR REAL*8 XXREAL,XXIMAG COMPLEX*16 COMPLEXSQRT REAL*8 ALPI C Index variables: INTEGER P,MU,I,J,CUTNUMBER C Propagator properties LOGICAL CUT(3*SIZE-1) C Flag for feynman function CHARACTER*16 FLAG C Results variables: REAL*8 CALSVAL REAL*8 WEIGHT,MAXWEIGHT COMPLEX*16 FEYNMAN,FEYNMANF,FEYNMAN0,FEYNMAN0F,FEYNMANVAL REAL*8 PREFACTOR COMPLEX*16 INTEGRAND COMPLEX*16 CHECK C Useful constants: REAL*8 METRIC(0:3) DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/ REAL*8 PI DATA PI /3.1415926535898D0/ C C----------------------------------------------------------------------- C Latest revision: 11 May 1996 C 24 October 1996 (call to CHECKDEFORM) C 15 November 1996 (remove finite 'i epsilon') C 18 November 1996 (add CHECKVALUE) C 22 November 1996 Bug fixed. C 27 November 1996 (complex checkvalue) C 29 November 1996 (branchcut check; better checkvalue) C 27 February 1997 renormalization; reporting C 25 July 1997 renormalization; self-energy graphs C 17 September 1997 more renormalization & self-energy C 21 September 1997 finish DEFORM C 24 September 1997 fix bugs C 19 October 1997 fix cutsign bug C 22 October 1997 fix renormalization sign bug C 6 November 1997 improvements for deformation C 28 November 1997 more work on deformation C 2 December 1997 more precision in "report" numbers C 4 January 1998 revisions for self-energy graphs C 11 January 1998 renormalizaion for self-energy graphs C 27 February 1998 use Hrothgar for output C 5 March 1998 integrate Hrothgar C 14 March 1998 restore checks of deformation direction C 24 July 1998 use countfactor(graphnumber) C 4 August 1998 better CHECKDEFORM C 5 August 1998 change to groupsize(graphnumber) C 22 August 1998 add color factors C 22 December 1998 precalculate cut structure in RENO C 26 April 1999 omit REFLECT except as option C 22 December 2000 omit REFLECT entirely C 22 December 2000 change method of choosing points C 19 December 2001 call FEYNMANF, new organization. C 31 December 2001 add Coulomb gauge. C 11 February 2002 Add Born calculation. C---------------------------------- C IF (ORDER.EQ.1) THEN NLOOPS = NLOOPS1 NPROPS = NPROPS1 CUTMAX = CUTMAX1 ELSE IF (ORDER.EQ.2) THEN NLOOPS = NLOOPS2 NPROPS = NPROPS2 CUTMAX = CUTMAX2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C C We do not want to change the value of KIN and ABSKIN, even though C K and ABSK get changed by the reflection feature of the subroutine. C DO P = 1,NPROPS ABSK(P) = ABSKIN(P) DO MU = 0,3 K(P,MU) = KIN(P,MU) ENDDO ENDDO C C Initialize contribution to integral from this point. Also initialize C BIGGEST, which will be the biggest absolute value of the contributions C to VALUE. This helps us to keep track of cancellations and thus to C abort the calculation if too much cancellation among terms will be C required. C MAXPART = 0.0D0 VALUE = (0.0D0,0.0D0) VALUECHK = (0.0D0,0.0D0) C C Calculate jacobian. C JACNEWPOINT = > 1.0D0/DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER) C C Loop over cuts. C DO CUTNUMBER = 1,NUMBEROFCUTS(GRAPHNUMBER) CALL GETCUTINFO(GRAPHNUMBER,CUTNUMBER,ORDER,NCUT,ISIGN, > CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP, > NINLOOP,LOOPINDEX,LOOPSIGN) C.... IF (REPORT) THEN WRITE(NOUT,301)NCUT,CUTINDEX(1),CUTINDEX(2), > CUTINDEX(3),CUTINDEX(4) 301 FORMAT('Ncut =',I2,' CUTINDEX =',4I2) ENDIF C'''' C C Calculate Sqrt(s) and the renormalization scale MUMSBAR. C RTS = 0.0D0 DO J=1,NCUT RTS = RTS + ABSK(CUTINDEX(J)) ENDDO MUMSBAR = MUOVERRTS * RTS C C Calculate final state momenta. C Then we can also calculate CALSVAL and the PREFACTOR. C DO I = 1,NCUT KCUT(I,0) = ABSK(CUTINDEX(I)) DO MU = 1,3 KCUT(I,MU) = CUTSIGN(I) * K(CUTINDEX(I),MU) ENDDO ENDDO CALSVAL = CALS0(NCUT,KCUT) PREFACTOR = 1.0D0 / (NC * RTS**2 * (2.0D0 * PI)**NLOOPS ) C IF (MODE.EQ.'born ') THEN PREFACTOR = PREFACTOR * ALPI(MUOVERRTS*EXTERNALRTS) ELSE IF (MODE.EQ.'nlo ') THEN PREFACTOR = PREFACTOR * ALPI(MUOVERRTS*EXTERNALRTS)**ORDER ELSE IF (MODE.EQ.'hocoef') THEN CONTINUE ELSE WRITE(NOUT,*)'CALCULATE programmed for this mode.',MODE STOP ENDIF C C Calculate momenta around loop (if any). In case NINLOOP = 0, this C DO loop is skipped. C DO J = 1,NINLOOP DO MU = 1,3 KINLOOP(J,MU) = LOOPSIGN(J) * K(LOOPINDEX(J),MU) ENDDO ENDDO C C Please note that at this point the energy in the loop, KINLOOP(J,0), C is not calculated. We have to wait until we have a loop cut to C do this. C C Now KINLOOP(J,MU) gets an imaginary part for MU = 1,2,3. C DEFORM calculates NEWKINLOOP and the associated jacobian, JACDEFORM. C In case NINLOOP = 0, this subroutine just returns NEWKINLOOP(MU) = 0 C and JACDEFORM = 1. C CALL DEFORM(VRTX,LOOPINDEX,RTS,LEFTLOOP,RIGHTLOOP, > NINLOOP,KINLOOP,NEWKINLOOP,JACDEFORM) C C If there is a loop, we need to go around the loop and generate C a "loopcut." There are four cases. C C 1) NINLOOP = 0, with NCUT = CUTMAX. C Then we are ready to proceed, and we should calculate only once C before going back to NEWCUT. Therefore we set CALCMORE to .FALSE. C so that we do not enter this code again. C C In the other three cases, there is a loop with NINLOOP = 2, 3, or 4. C We generate a loopcut specified by the index JCUT = 1, 2, ... around C the loop: CUTINDEX(CUTMAX) = LOOPINDEX(JCUT). C C 2) NINLOOP = 2, with NCUT = CUTMAX - 1. C Then the loop is a self-energy subgraph and, with our dispersive C treatment of these graphs, there is one term. We need to calculate C energies, so we put JCUT = 1, but this is just a convention: the C choice JCUT = 1 or 2 affects only the energy in the loop and the C two point function depends only on the 3-momentum in the loop. C C 3) NINLOOP = 3, with NCUT = CUTMAX - 1. C Then we have a complicated task. First, we generate the C renormalization counter term. We set RENORMTERM3 to true to signify C this. We need to calculate energies, so we put JCUT = 1, but this is C just a convention. We also set FLAG to 'renormalize 3 pt'. The C function FEYNMAN will pass FLAG on to the subroutine VERTEX, C which will generate the counter term when FLAG has this value. Once we C are done with the counterterm, we will go around the loop twice C with JCUT = 1,2,3 and then JCUT = 1,2,3 again. We set C CUTSIGN(CUTMAX) = LOOPSIGN(JCUT) the first time and C CUTSIGN(CUTMAX) = - LOOPSIGN(JCUT) the second time. This corresponds C to doing the energy integral with the contour closed in the upper C half plane and also in the lower half plane. We *average* over the C two sign choices, so we will need to multiply FEYNMAN by 1/2 for C NINLOOP = 3 and RENORMTERM3 = false. When we are done with this C we set CALCMORE to .FALSE. . C C 3) NINLOOP = 4, with NCUT = CUTMAX - 1. C Then we have an easuer task. We do *not* generate a C renormalization counter term. We will go around the loop twice C with JCUT = 1,2,3,4 and then JCUT = 1,2,3,4 again. We set C CUTSIGN(CUTMAX) = LOOPSIGN(JCUT) the first time and C CUTSIGN(CUTMAX) = - LOOPSIGN(JCUT) the second time. This corresponds C to doing the energy integral with the contour closed in the upper C half plane and also in the lower half plane. We *average* over the C two sign choices, so we will need to multiply FEYNMAN by 1/2 for C NINLOOP = 4. When we are done with this we set CALCMORE to .FALSE. . C C We initialize the weight, then add to it the contributions from C each pass through this loop. C WEIGHT = 0.0D0 MAXWEIGHT = 0.0D0 FLAG = ' no flag set' C IF (NINLOOP.EQ.3) THEN INDEX = 0 ELSE INDEX = 1 ENDIF CALCMORE = .TRUE. C DO WHILE (CALCMORE) C IF (NINLOOP.EQ.0) THEN CALCMORE = .FALSE. ELSE IF (NINLOOP.EQ.2) THEN JCUT = 1 CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) CUTSIGN(CUTMAX) = LOOPSIGN(JCUT) CALCMORE = .FALSE. ELSE IF (NINLOOP.EQ.3) THEN IF(INDEX.EQ.0) THEN FLAG = 'renormalize 3 pt' JCUT = 1 CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) CUTSIGN(CUTMAX) = LOOPSIGN(JCUT) INDEX = 1 ELSE FLAG = ' no flag set' IF (INDEX.LE.3) THEN JCUT = INDEX CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) CUTSIGN(CUTMAX) = LOOPSIGN(JCUT) LOOPCUTSIGN = 1 ELSE JCUT = INDEX - 3 CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) CUTSIGN(CUTMAX) = - LOOPSIGN(JCUT) LOOPCUTSIGN = -1 ENDIF INDEX = INDEX + 1 IF (INDEX.GT.6) THEN CALCMORE = .FALSE. ENDIF ENDIF ELSE IF (NINLOOP.EQ.4) THEN IF (INDEX.LE.4) THEN JCUT = INDEX CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) CUTSIGN(CUTMAX) = LOOPSIGN(JCUT) LOOPCUTSIGN = 1 ELSE JCUT = INDEX - 4 CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) CUTSIGN(CUTMAX) = - LOOPSIGN(JCUT) LOOPCUTSIGN = -1 ENDIF INDEX = INDEX + 1 IF (INDEX.GT.8) THEN CALCMORE = .FALSE. ENDIF ELSE WRITE(*,*)'Impossible case in CALCULATE' STOP ENDIF C C Calculate matrix AE(P,I) relating propagator energies to energies of C cut lines. NOTE that the index I here is displaced by 1. C DO I = 0,NLOOPS QE(I) = CUTINDEX(I+1) ENDDO CALL FINDA(VRTX,QE,NLOOPS,ORDER,AE,QOK) IF (.NOT.QOK) THEN WRITE(NOUT,*)'AE not found' STOP ENDIF C C Define logical cut variables: C CUT(P) = .TRUE. if propagator P crosses the final state cut C OR if it crosses the loopcut. C DO P = 1,NPROPS CUT(P) = .FALSE. ENDDO DO I = 1,CUTMAX CUT(CUTINDEX(I)) = .TRUE. ENDDO C C Calculate part of the energies of cut lines corresponding to the C real part of the loop three-momenta. NOTE that I is displaced by 1 C in order to work with the matrix AE(P,I). C DO I = 0,NLOOPS E(I) = CUTSIGN(I+1) * ABSK(CUTINDEX(I+1)) ENDDO C C Calculate part of the propagator energies corresponding to the C real part of the loop three-momenta. C DO P = 0,NPROPS K(P,0) = 0.0D0 DO I = 0,NLOOPS K(P,0) = K(P,0) + AE(P,I) * E(I) ENDDO ENDDO IF ( ABS(RTS - K(0,0)).GT.1.0D-8 ) THEN WRITE(NOUT,*)'Oops, the calculation of RTS did not work' STOP ENDIF C C Calculate the added complex loop energy. Check that we do not C cross the cut of Sqrt(ELLSQ) by using COMPLEXSQRT(ELLSQ). C IF (NINLOOP.GT.0) THEN KINLOOP(JCUT,0) = LOOPSIGN(JCUT) * K(LOOPINDEX(JCUT),0) ELLSQ = (0.0D0,0.0D0) DO MU = 1,3 ELLSQ = ELLSQ + ( KINLOOP(JCUT,MU) + NEWKINLOOP(MU) )**2 ENDDO ELL = COMPLEXSQRT(ELLSQ) NEWKINLOOP(0) = LOOPCUTSIGN*ELL - KINLOOP(JCUT,0) ELSE NEWKINLOOP(0) = (0.0D0,0.0D0) ENDIF C.... IF (REPORT) THEN IF( DETAILS .AND. (NINLOOP.GT.0) ) THEN WRITE(NOUT,340)NEWKINLOOP(0),XXIMAG(NEWKINLOOP(1)), > XXIMAG(NEWKINLOOP(2)),XXIMAG(NEWKINLOOP(3)) 340 FORMAT('NEWKINLOOP =',2(1P G12.3),' AND',3(1P G12.3)) ENDIF ENDIF C'''' C Now we calculate the complex propagator momenta. C DO P = 0,NPROPS DO MU = 0,3 KC(P,MU) = K(P,MU) ENDDO ENDDO C DO J = 1,NINLOOP DO MU = 0,3 KC(LOOPINDEX(J),MU) = KC(LOOPINDEX(J),MU) > + LOOPSIGN(J) * NEWKINLOOP(MU) ENDDO ENDDO C C Calculate graph. C C Add to contribution for this point. C C If we have a virtual loop with 3 lines, then we may be computing C the renormalization counter term. We tell by whether FLAG has been C set to 'renormalize 3 pt'. The flag value is simply passed on C to FEYNMANF or FEYNMAN, but if the flag is set to 'renormalize 3 pt', C we veto the factor 1/2 described below. C C If we don't want the counterterm, we want the main term. If we C have a 3 or 4 point virtual loop, then we are averaging over C closing the energy integral contour in the upper and lower C half planes and we supply a 1/2. C IF (ORDER.EQ.2) THEN IF (GAUGE.EQ.'feynman') THEN FEYNMANVAL = FEYNMANF(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) ELSE IF (GAUGE.EQ.'coulomb') THEN FEYNMANVAL = FEYNMAN(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) ELSE WRITE(*,*)'That gauge does not exist' STOP ENDIF ELSE IF (ORDER.EQ.1) THEN IF (GAUGE.EQ.'feynman') THEN FEYNMANVAL = FEYNMAN0F(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) ELSE IF (GAUGE.EQ.'coulomb') THEN FEYNMANVAL = FEYNMAN0(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) ELSE WRITE(*,*)'That gauge does not exist' STOP ENDIF ELSE WRITE(NOUT,*)'Order should have been 1 or 2' STOP ENDIF INTEGRAND = PREFACTOR * JACNEWPOINT * JACDEFORM > * FEYNMANVAL * SMEAR(RTS) C IF ((NINLOOP.GT.2).AND.(FLAG.NE.'renormalize 3 pt')) THEN INTEGRAND = 0.5D0*INTEGRAND ENDIF C MAXWEIGHT = MAX(MAXWEIGHT,ABS(XXREAL(INTEGRAND))) WEIGHT = WEIGHT + XXREAL(INTEGRAND) C INTEGRAND = INTEGRAND * CALSVAL MAXPART = MAX(MAXPART,ABS(XXREAL(INTEGRAND))) VALUE = VALUE + INTEGRAND C.... IF (REPORT) THEN IF (DETAILS) THEN WRITE(NOUT,370) 370 FORMAT('PREFACTOR * JACNEWPOINT * (JACDEFORM-R JACDEFORM-I)', > ' (FEYNMAN-R FEYNMAN-I) * CALSVAL * SMEAR(RTS)') WRITE(NOUT,371)PREFACTOR,JACNEWPOINT,JACDEFORM, > FEYNMANVAL,CALSVAL,SMEAR(RTS) 371 FORMAT(8(1P G12.3)) ENDIF IF (NINLOOP.GT.0) THEN IF (FLAG.EQ.'renormalize 3 pt') THEN WRITE(NOUT,372)INTEGRAND 372 FORMAT('Contribution (CT):',2(1P G18.10)) ELSE WRITE(NOUT,373)LOOPINDEX(JCUT),INTEGRAND 373 FORMAT(I3,' Contribution:',2(1P G18.10)) ENDIF ELSE WRITE(NOUT,374)INTEGRAND 374 FORMAT(' Contribution:',2(1P G18.10)) ENDIF IF (DETAILS) THEN WRITE(NOUT,*)' ' ENDIF ENDIF C'''' C C Compute a known integral to see if we have it right. C Subroutine CHECKCALC calculates CHECK. C IF (FLAG.NE.'renormalize 3 pt') THEN CALL > CHECKCALC(GRAPHNUMBER,CUTINDEX,KC,JACNEWPOINT,JACDEFORM,CHECK) IF (NINLOOP.GT.2) THEN CHECK = 0.5D0*CHECK ENDIF VALUECHK = VALUECHK + CHECK ENDIF C C End of loop DO WHILE (CALCMORE) that runs over loopcuts. C ENDDO C C We are ready to call Hrothgar to process the result for this cut. C CALL HROTHGAR(NCUT,KCUT,WEIGHT,1,'NEWRESULT ') C C Close loop DO CUTNUMBER = 1,NUMBEROFCUTS(GRAPHNUMBER) C ENDDO C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C End of subroutine to calculate integrand C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE > CHECKCALC(GRAPHNUMBER,CUTINDEX,KC,JACNEWPOINT,JACDEFORM,CHECK) C INTEGER SIZE PARAMETER (SIZE = 3) C In: INTEGER GRAPHNUMBER,CUTINDEX(SIZE+1) COMPLEX*16 KC(0:3*SIZE-1,0:3) REAL*8 JACNEWPOINT COMPLEX*16 JACDEFORM C Out: COMPLEX*16 CHECK C C Compute a known integral to see if we have it right. C This subroutine calculates the integrand. C The check is based on C Int d^3 p [p^2 + M^2]^(-3) = Pi^2/ (4 M^3). C Int d^3 p [p^2 (p^2 + M^2)]^(-1) = 2 Pi^2 /M C Note that we look at just one term in the sum over cuts C and loopcuts: C For graph 10, we take Cutindex = (7,5,4,1); C For graph 8, we take Cutindex = (8,6,4,1), etc. C C Latest modification: 11 February 2002. C C Max number of graphs, cuts, maps for array sizes: INTEGER MAXGRAPHS,MAXMAPS PARAMETER (MAXGRAPHS = 12) PARAMETER (MAXMAPS = 64) C Input and output units. INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT C How many graphs and how many cuts and maps for each: INTEGER NUMBEROFGRAPHS INTEGER NUMBEROFCUTS(MAXGRAPHS) INTEGER NUMBEROFMAPS(MAXGRAPHS) COMMON /GRAPHCOUNTS/ NUMBEROFGRAPHS,NUMBEROFCUTS,NUMBEROFMAPS C Reno size and counting variables: INTEGER GROUPSIZE(MAXGRAPHS,MAXMAPS) INTEGER GROUPSIZEGRAPH(MAXGRAPHS) INTEGER GROUPSIZETOTAL COMMON /MONTECARLO/GROUPSIZE,GROUPSIZEGRAPH,GROUPSIZETOTAL C REAL*8 MM DATA MM /3.0D-1/ REAL*8 PI DATA PI /3.1415926535898D0/ COMPLEX*16 TEMP1,TEMP2,TEMP3 INTEGER MU C C If it is not the right graph and the right cut, this default C value will be returned. C CHECK = (0.0D0,0.0D0) C TEMP1 = 0.0D0 TEMP2 = 0.0D0 TEMP3 = 0.0D0 C IF (GRAPHNUMBER.EQ.12) THEN C IF ( (CUTINDEX(1).EQ.5).AND.(CUTINDEX(2).EQ.4) > .AND.(CUTINDEX(3).EQ.1) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(5,MU)*KC(5,MU) TEMP2 = TEMP2 + KC(4,MU)*KC(4,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.11) THEN C IF ( (CUTINDEX(1).EQ.5).AND.(CUTINDEX(2).EQ.4) > .AND.(CUTINDEX(3).EQ.1) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(5,MU)*KC(5,MU) TEMP2 = TEMP2 + KC(4,MU)*KC(4,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.10) THEN C IF ( (CUTINDEX(1).EQ.7).AND.(CUTINDEX(2).EQ.5) > .AND.(CUTINDEX(3).EQ.4).AND.(CUTINDEX(4).EQ.1) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(7,MU)*KC(7,MU) TEMP2 = TEMP2 + KC(6,MU)*KC(6,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.9) THEN C IF ( (CUTINDEX(1).EQ.8).AND.(CUTINDEX(2).EQ.7) > .AND.(CUTINDEX(3).EQ.3).AND.(CUTINDEX(4).EQ.5) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(8,MU)*KC(8,MU) TEMP2 = TEMP2 + KC(6,MU)*KC(6,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.8) THEN C IF ( (CUTINDEX(1).EQ.8).AND.(CUTINDEX(2).EQ.6) > .AND.(CUTINDEX(3).EQ.4).AND.(CUTINDEX(4).EQ.1) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(5,MU)*KC(5,MU) TEMP2 = TEMP2 + KC(8,MU)*KC(8,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.7) THEN C IF ( (CUTINDEX(1).EQ.5).AND.(CUTINDEX(2).EQ.4) > .AND.(CUTINDEX(3).EQ.1).AND.(CUTINDEX(4).EQ.6) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(5,MU)*KC(5,MU) TEMP2 = TEMP2 + KC(7,MU)*KC(7,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.6) THEN C IF ( (CUTINDEX(1).EQ.8).AND.(CUTINDEX(2).EQ.5) > .AND.(CUTINDEX(3).EQ.3).AND.(CUTINDEX(4).EQ.6) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(5,MU)*KC(5,MU) TEMP2 = TEMP2 + KC(7,MU)*KC(7,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.5) THEN C IF ( (CUTINDEX(1).EQ.8).AND.(CUTINDEX(2).EQ.7) > .AND.(CUTINDEX(3).EQ.3).AND.(CUTINDEX(4).EQ.1) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(5,MU)*KC(5,MU) TEMP2 = TEMP2 + KC(8,MU)*KC(8,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.4) THEN C IF ( (CUTINDEX(1).EQ.6).AND.(CUTINDEX(2).EQ.4) > .AND.(CUTINDEX(3).EQ.1).AND.(CUTINDEX(4).EQ.7) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(7,MU)*KC(7,MU) TEMP2 = TEMP2 + KC(5,MU)*KC(5,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.3) THEN C IF ( (CUTINDEX(1).EQ.5).AND.(CUTINDEX(2).EQ.4) > .AND.(CUTINDEX(3).EQ.1).AND.(CUTINDEX(4).EQ.6) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(7,MU)*KC(7,MU) TEMP2 = TEMP2 + KC(5,MU)*KC(5,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.2) THEN C IF ( (CUTINDEX(1).EQ.7).AND.(CUTINDEX(2).EQ.6) > .AND.(CUTINDEX(3).EQ.1).AND.(CUTINDEX(4).EQ.4) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(7,MU)*KC(7,MU) TEMP2 = TEMP2 + KC(5,MU)*KC(5,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE IF (GRAPHNUMBER.EQ.1) THEN C IF ( (CUTINDEX(1).EQ.5).AND.(CUTINDEX(2).EQ.4) > .AND.(CUTINDEX(3).EQ.1).AND.(CUTINDEX(4).EQ.7) ) THEN DO MU = 1,3 TEMP1 = TEMP1 + KC(7,MU)*KC(7,MU) TEMP2 = TEMP2 + KC(5,MU)*KC(5,MU) TEMP3 = TEMP3 + KC(1,MU)*KC(1,MU) ENDDO ELSE RETURN ENDIF C ELSE WRITE(NOUT,*)'Problem with graph number in CHECKCALC' STOP ENDIF C IF (GRAPHNUMBER.LE.10) THEN C C Here is an infrared sensitive check integral: C CHECK = TEMP1 * (TEMP1 + MM**2) CHECK = CHECK * TEMP2 * (TEMP2 + MM**2) CHECK = CHECK * (TEMP3 + MM**2)**3 CHECK = (MM**5/PI**6) /CHECK C C Here is a nice smooth check integral: C CHECK = (TEMP1 + MM**2)**3 C CHECK = CHECK * (TEMP2 + MM**2)**3 C CHECK = CHECK * (TEMP3 + (2.0D0*MM)**2)**3 C CHECK = (512.0D0 * MM**9 / PI**6) /CHECK C ELSE IF (GRAPHNUMBER.LE.12) THEN C CHECK = (TEMP1 + MM**2)**3 CHECK = CHECK * (TEMP2 + MM**2)**3 CHECK = (16.0D0 * MM**6 / PI**4) /CHECK C ELSE WRITE(NOUT,*)'We were expecting graphnumbers 1,...,12' STOP ENDIF C CHECK = JACDEFORM * JACNEWPOINT * CHECK C C Weight according to the number of points devoted to the current C graph. C CHECK = CHECK * GROUPSIZEGRAPH(GRAPHNUMBER)/GROUPSIZETOTAL C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION > DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER) C INTEGER SIZE,MAXMAPS PARAMETER (SIZE = 3) PARAMETER (MAXMAPS = 64) C In: INTEGER GRAPHNUMBER REAL*8 K(0:3*SIZE-1,0:3) INTEGER QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE) CHARACTER*6 MAPTYPES(MAXMAPS) INTEGER NMAPS,ORDER C C Density of Monte Carlo points as a function of |K(p)|'s. C C 29 June 1993 C 12 July 1993 C 17 July 1994 C 4 May 1996 C 21 November 1996 C 5 December 1996 C 5 February 1997 C 15 December 1998 C 23 December 1998 C 9 February 1999 C 10 March 1999 C 20 August 1999 C 21 December 2000 C 20 March 2001 C 1 February 2002 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NLOOPS INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 INTEGER MAXGRAPHS PARAMETER (MAXGRAPHS = 12) INTEGER GROUPSIZE(MAXGRAPHS,MAXMAPS) INTEGER GROUPSIZEGRAPH(MAXGRAPHS) INTEGER GROUPSIZETOTAL COMMON /MONTECARLO/GROUPSIZE,GROUPSIZEGRAPH,GROUPSIZETOTAL C INTEGER MAPNUMBER,L,MU REAL*8 P1(3),P2(3),ELL1(3),ABSP1,ABSP2,ABSP3 REAL*8 TEMP1,TEMP2,TEMP3,P1SQ,P2SQ,P3SQ CHARACTER*6 MAPTYPE INTEGER QSIGN(0:SIZE),Q(0:SIZE) REAL*8 RHO3,RHO2TO3D,RHO2TO3E,RHO2TO2T,RHO2TO2S,RHO2TO1 REAL*8 RHOTHREE,RHOLOOP C IF (ORDER.EQ.1) THEN NLOOPS = NLOOPS1 ELSE IF (ORDER.EQ.2) THEN NLOOPS = NLOOPS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C IF (ORDER.EQ.1) THEN C C We deal with the case of a Born graph first. C DENSITY = 0.0D0 DO MAPNUMBER = 1,NMAPS C DO L = 0,NLOOPS Q(L) = QS(MAPNUMBER,L) QSIGN(L) = QSIGNS(MAPNUMBER,L) ENDDO P1SQ = 0.0D0 P2SQ = 0.0D0 P3SQ = 0.0D0 DO MU = 1,3 TEMP1 = QSIGN(1)*K(Q(1),MU) TEMP2 = QSIGN(2)*K(Q(2),MU) TEMP3 = - TEMP1 - TEMP2 P1SQ = P1SQ + TEMP1**2 P2SQ = P2SQ + TEMP2**2 P3SQ = P3SQ + TEMP3**2 ENDDO ABSP1 = SQRT(P1SQ) ABSP2 = SQRT(P2SQ) ABSP3 = SQRT(P3SQ) RHOTHREE = RHO3(ABSP1,ABSP2,ABSP3) DENSITY = DENSITY > + RHOTHREE*GROUPSIZE(GRAPHNUMBER,MAPNUMBER) C ENDDO C C Alternative for IF (ORDER.EQ.1) THEN C ELSE IF (ORDER.EQ.2) THEN C C We tackle the case of an order alpha_s^2 graph. C We construct the density as a sum. C DENSITY = 0.0D0 DO MAPNUMBER = 1,NMAPS C MAPTYPE = MAPTYPES(MAPNUMBER) DO L = 0,NLOOPS Q(L) = QS(MAPNUMBER,L) QSIGN(L) = QSIGNS(MAPNUMBER,L) ENDDO C C First, we need the kinematic variables for this map. C P1SQ = 0.0D0 P2SQ = 0.0D0 P3SQ = 0.0D0 DO MU = 1,3 ELL1(MU) = QSIGN(1)*K(Q(1),MU) TEMP1 = QSIGN(2)*K(Q(2),MU) TEMP2 = QSIGN(3)*K(Q(3),MU) TEMP3 = - TEMP1 - TEMP2 P1(MU) = TEMP1 P1SQ = P1SQ + TEMP1**2 P2(MU) = TEMP2 P2SQ = P2SQ + TEMP2**2 P3SQ = P3SQ + TEMP3**2 ENDDO ABSP1 = SQRT(P1SQ) ABSP2 = SQRT(P2SQ) ABSP3 = SQRT(P3SQ) C C Now, there are two factors, one for the 'final state momenta' and C one for the 'loop momentum.' C RHOTHREE = RHO3(ABSP1,ABSP2,ABSP3) C IF (MAPTYPE.EQ.'T2TO3D') THEN RHOLOOP = RHO2TO3D(P1,P2,ELL1) ELSE IF (MAPTYPE.EQ.'T2TO3E') THEN RHOLOOP = RHO2TO3E(P1,P2,ELL1) ELSE IF (MAPTYPE.EQ.'T2TO2T') THEN RHOLOOP = RHO2TO2T(P1,P2,ELL1) ELSE IF (MAPTYPE.EQ.'T2TO2S') THEN RHOLOOP = RHO2TO2S(P1,P2,ELL1) ELSE IF (MAPTYPE.EQ.'T2TO1 ') THEN RHOLOOP = RHO2TO1(P1,P2,ELL1) ELSE WRITE(NOUT,*)'Bad MAPTYPE in DENSITY' STOP ENDIF C DENSITY = DENSITY > + RHOTHREE*RHOLOOP*GROUPSIZE(GRAPHNUMBER,MAPNUMBER) C C Close DO MAPNUMBER = 1,NMAPS C ENDDO C C Close for IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN C ELSE WRITE(NOUT,*)'ORDER should have been 1 or 2 in DENSITY.' STOP ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C Subroutines associated with NEWPOINT and DENSITY 2 C CHOOSEx and RHOx where x = 3, 2to2T, 2to2S, 2to3D, 2to3E, 2to1 2 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE CHOOSE3(P1,P2,P3,OK) C C Out: REAL*8 P1(3),P2(3),P3(3) LOGICAL OK C C Generates momenta P1(mu),P2(mu),P3(mu) for a three body final C state with a distribution in momentum fractions x1,x2,x3 C proportional to C C [max(1-x1,1-x2,1-x3)]^B/[(1-x1)*(1-x2)*(1-x3)]^B. C C 28 December 2000 C 16 January 2001 C REAL*8 BADNESSLIMIT,CANCELLIMIT,THRUSTCUT COMMON /LIMITS/ BADNESSLIMIT,CANCELLIMIT,THRUSTCUT REAL*8 ONETHIRD,TWOTHIRDS,PI PARAMETER(ONETHIRD = 0.3333333333333333333D0) PARAMETER(TWOTHIRDS = 0.6666666666666666667D0) PARAMETER (PI = 3.141592653589793239D0) C C The parameter E3PAR should match between CHOOSE3 and RHO3. C REAL*8 E3PAR PARAMETER(E3PAR = 1.5D0) C C The parameters A, B, and C need to match between CHOOSE3 and RHO3. C CHOOSE3 uses A, while RHO3 uses B and C. The relation is C B = 1 - 1/A and then C is the normalization factor and is C a rather complicated function of B. C C Some soft and collinear points: C REAL*8 A,B,C PARAMETER(A = 2.0D0) PARAMETER(B = 0.5D0) PARAMETER(C = 0.0036376552621307193655D0) C C Lots of soft and collinear points: C C REAL*8 A,B,C C PARAMETER(A = 4.0D0) C PARAMETER(B = 0.75D0) C PARAMETER(C = 0.00058417226323428314253D0) C REAL*8 X,RANDOM LOGICAL DONE INTEGER MU REAL*8 EMAX REAL*8 X1,X2,X3,Y1,Y2,Y3 REAL*8 EA(3),EB(3),EC(3),ED(3) REAL*8 PHI,COSTHETA,SINTHETA REAL*8 K1(3),K2(3),K3(3) C C---------- C OK = .TRUE. C C We will generate vectors K1(mu), K2(mu), K3(mu) with |K1| > |K3| and C |K2| > |K3|. At the end, we will associate each Ki(mu) with a Pj(mu) C with the index j of the Pj(mu) that matches K3(mu) chosen at random. C C We choose y1, y2, y3 in 0< y_i < 1 with y1 + y2 + y3 = 1. The y_i are C related to the momentum fractions x_i by y_i = 1 - x_i. For the y_i, C we want y3 to be the largest, with no specification about whether y1 C or y2 is larger. We want to choose y1 and y2 with a 1/sqrt(y1*y2) C distribution. Then y3 = 1 - y1 - y2. We must insure that y3 > y1 and C y3 > y2 for the point to be valid. Note that the allowed region is C inside the region 0 < y1 < 1/2, 0 < y2 < 1/2. If we choose a random C variable x in 0 < x < 1 and define y = x**2/2 then the density dx/dy C is proportional to 1/sqrt(y) and 0 < y < 1/2. C C We loop until we are "done" choosing a valid point. C DONE = .FALSE. DO WHILE (.NOT.DONE) X = RANDOM(1) Y1 = 0.5D0 * X**A X = RANDOM(1) Y2 = 0.5D0 * X**A Y3 = 1.0D0 - Y1 - Y2 IF ((Y1 .LT. Y3).AND.(Y2.LT.Y3)) THEN DONE = .TRUE. ENDIF ENDDO X1 = 1.0D0 - Y1 X2 = 1.0D0 - Y2 X3 = Y1 + Y2 C C If the chosen point is too soft or collinear, we will not be able C to compute the kinematics for the rest of this subroutine C or the other CHOOSEx subroutines, so we just abort. C IF ( Y1*Y2.LT.(100.0D0*BADNESSLIMIT)**(-2) ) THEN DO MU = 1,3 P1(MU) = 0.0D0 P2(MU) = 0.0D0 P3(MU) = 0.0D0 ENDDO OK = .FALSE. RETURN ENDIF C C Choose Emax = sum_i |p_i| /2. C X = RANDOM(1) EMAX = E3PAR * ( 1.0D0/X - 1.0D0 )**ONETHIRD C C Choose a direction EA(mu) at random on the unit sphere. C X = RANDOM(1) COSTHETA = 2.0D0*X - 1.0D0 SINTHETA = SQRT(1.0D0 - COSTHETA**2) X = RANDOM(1) PHI = 2.0D0 * PI * X EA(1) = SINTHETA * COS(PHI) EA(2) = SINTHETA * SIN(PHI) EA(3) = COSTHETA C C Generate vectors EB and EC that form a right handed basis set with EA. C CALL AXES(EA,EB,EC) C C Generate a unit vector ED at a with a random azimuthal angle around C the EA axis in this basis. C X = RANDOM(1) PHI = 2.0D0 * PI * X DO MU = 1,3 ED(MU) = COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ENDDO C C Now construct the momenta. P1(mu) is directed in the random direction C EA(mu) with magnitude determined from Emax and X1. Then P3(mu) C is in the plane of EA(mu) and ED(mu) with angle THETA to P1(mu) C determined from the Xi and magnitude determined by X2. C COSTHETA = 1.0D0 - 2.0D0*Y2/X1/X3 SINTHETA = 2.0D0*SQRT(Y1*Y2*Y3)/X1/X3 DO MU = 1,3 K1(MU) = X1*EMAX*EA(MU) K3(MU) = X3*EMAX*(COSTHETA*EA(MU) + SINTHETA*ED(MU)) K2(MU) = - K1(MU) - K3(MU) ENDDO C C Match K3(mu) to one of the Pi(mu) at random. C X = RANDOM(1) IF (X.GT.TWOTHIRDS) THEN DO MU = 1,3 P1(MU) = K1(MU) P2(MU) = K2(MU) P3(MU) = K3(MU) ENDDO ELSE IF (X.GT.ONETHIRD) THEN DO MU = 1,3 P1(MU) = K2(MU) P2(MU) = K3(MU) P3(MU) = K1(MU) ENDDO ELSE DO MU = 1,3 P1(MU) = K3(MU) P2(MU) = K1(MU) P3(MU) = K2(MU) ENDDO ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION RHO3(ABSP1,ABSP2,ABSP3) C C In: REAL*8 ABSP1,ABSP2,ABSP3 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT C C Density of points for points chosen with CHOOSE3(p1,p2,p3,ok). C 16 January 2001 C REAL*8 EMAX,X1,X2,X3 REAL*8 E03,EMAX3,FACTOR,DENOM C C The parameter E3PAR should match between CHOOSE3 and RHO3. C REAL*8 E3PAR PARAMETER(E3PAR = 1.5D0) C C The parameters A, B, and C need to match between CHOOSE3 and RHO3. C CHOOSE3 uses A, while RHO3 uses B and C. The relation is C B = 1 - 1/A and then C is the normalization factor and is C a rather complicated function of B. C C Some soft and collinear points: C REAL*8 A,B,C PARAMETER(A = 2.0D0) PARAMETER(B = 0.5D0) PARAMETER(C = 0.0036376552621307193655D0) C C Lots of soft and collinear points: C C REAL*8 A,B,C C PARAMETER(A = 4.0D0) C PARAMETER(B = 0.75D0) C PARAMETER(C = 0.00058417226323428314253D0) C EMAX = 0.5D0*(ABSP1 + ABSP2 + ABSP3) X1 = ABSP1/EMAX X2 = ABSP2/EMAX X3 = ABSP3/EMAX C IF (X1.LT.X2) THEN IF (X1.LT.X3) THEN C X1 is smallest: X1 w = y*(Log(y)**2 - 2*Log(y) + 2). C Function RANDOM(1) give a random number in the range 0 + 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 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 dr d costheta d phi C RHO2TO3E = 1.0D0/R**2 C C Density for phi. C RHO2TO3E = RHO2TO3E/(2.0D0 * PI) C C Density for theta. C We construct 1 - cos(theta) as (HatEll - Nz)^2 /2 since C that is more accurate than constructing cos(theta) and C subtracting it from 1.0 if 1 - cos(theta) is small. C V(1) = ELL(1)/R - NZ(1) V(2) = ELL(2)/R - NZ(2) V(3) = ELL(3)/R - NZ(3) ONEMINUSCOS = 0.5D0*(V(1)**2 + V(2)**2 + V(3)**2) N = 1.0D0/LOG(1.0D0 + 2.0D0/SDIFFSQ) PARAMSQ = ONEMINUSCOS + SDIFFSQ RHO2TO3E = RHO2TO3E * N/PARAMSQ C C Density for r. C DELTASQ = PARAMSQ/9.0D0 PARAM = SQRT(PARAMSQ) DELTA = PARAM/3.0D0 A = 1.0D0 + A2TO3*DELTASQ B = 1.0D0 + A2TO3*DELTA N = 1.0D0/LOG(A/(B*DELTASQ)) TEMP = ABS(R/S - 1.0D0) DENOM = S*(TEMP + A2TO3*DELTASQ)*(TEMP + A2TO3*DELTA) RHOR = A2TO3*N*DELTA*(1.0D0 - DELTA)/DENOM RHO2TO3E = RHO2TO3E * RHOR C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE CHOOSE2TO1(PA,PB,ELL,OK) C In: REAL*8 PA(3),PB(3) C Out: REAL*8 ELL(3) LOGICAL OK C C Generates a point ell(mu) for a self-energy graph that leads to a C propagator with momemtum Pa(mu) that enters the final state. C We want a map concentrating points rather collinearly with Pa(mu). C C 18 December 2000 C 18 March 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT C C The parameters B2TO1, C2TO1, A2TO1A and A2TO1B need to match C between CHOOSE2TO1 and RHO2TO1. C REAL*8 B2TO1,C2TO1,A2TO1A,A2TO1B PARAMETER (B2TO1 = 0.4D0) PARAMETER (C2TO1 = 0.4D0) PARAMETER (A2TO1A = 0.05D0) PARAMETER (A2TO1B = 0.25D0) REAL*8 PI PARAMETER (PI = 3.141592653589793239D0) C INTEGER MU REAL*8 PASQ,ABSPA,PBSQ,ABSPB,PCSQ,ABSPC,SCALEABC REAL*8 EA(3),EB(3),EC(3) REAL*8 RANDOM,XX,XCHOICE REAL*8 COSTHETA,SINTHETA,PHI,R REAL*8 X,ELLT C C--------------- C OK = .TRUE. C C We need the appropriate unit vectors for the map. We create a unit C vector EA(mu) in the direction of PA(mu). We also calculate a C scale factor SCALEABC. C PASQ = 0.0D0 PBSQ = 0.0D0 PCSQ = 0.0D0 DO MU = 1,3 PASQ = PASQ + PA(MU)**2 PBSQ = PBSQ + PB(MU)**2 PCSQ = PCSQ + (PA(MU) + PB(MU))**2 ENDDO IF (PASQ.LT.1.0D-30) THEN WRITE(NOUT,*)'PASQ too small in CHOOSE2TO1' WRITE(NOUT,*)'PA ',PA WRITE(NOUT,*)'ELL',ELL OK = .FALSE. ENDIF ABSPA = SQRT(PASQ) ABSPB = SQRT(PBSQ) ABSPC = SQRT(PBSQ) DO MU = 1,3 EA(MU) = PA(MU)/ABSPA ENDDO SCALEABC = (ABSPA + ABSPB + ABSPC)/3.0D0 C CALL AXES(EA,EB,EC) C C Step 2: Determine which of three methods to use to determine C the next point. C XCHOICE = RANDOM(1) C IF (XCHOICE.LT.A2TO1A) THEN C C We want a map concentrating points near ell = 0. C PHI = 2*PI*RANDOM(1) COSTHETA = 2.0D0*RANDOM(1) - 1.0D0 SINTHETA = SQRT(1.0D0 - COSTHETA**2) R = ABSPA*( 1/RANDOM(1) - 1.0D0 ) DO MU = 1,3 ELL(MU) = R * ( COSTHETA*EA(MU) + SINTHETA > * ( COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ) ) ENDDO C ELSE IF (XCHOICE.LT.2.0D0*A2TO1A) THEN C C We want a map concentrating points near ell - pa = 0. C PHI = 2*PI*RANDOM(1) COSTHETA = 2.0D0*RANDOM(1) - 1.0D0 SINTHETA = SQRT(1.0D0 - COSTHETA**2) R = ABSPA*( 1/RANDOM(1) - 1.0D0 ) DO MU = 1,3 ELL(MU) = R * ( COSTHETA*EA(MU) + SINTHETA > * ( COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ) ) > + PA(MU) ENDDO C ELSE IF (XCHOICE.LT.(2.0D0*A2TO1A+A2TO1B)) THEN C C We want a map concentrating points near ell = 0, BUT with C scale SCALEABC. C PHI = 2*PI*RANDOM(1) COSTHETA = 2.0D0*RANDOM(1) - 1.0D0 SINTHETA = SQRT(1.0D0 - COSTHETA**2) R = SCALEABC*( 1/RANDOM(1) - 1.0D0 ) DO MU = 1,3 ELL(MU) = R * ( COSTHETA*EA(MU) + SINTHETA > * ( COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ) ) ENDDO C ELSE IF (XCHOICE.LT.2.0D0*(A2TO1A+A2TO1B)) THEN C C We want a map concentrating points near ell - pa = 0, BUT with C scale SCALEABC. C PHI = 2*PI*RANDOM(1) COSTHETA = 2.0D0*RANDOM(1) - 1.0D0 SINTHETA = SQRT(1.0D0 - COSTHETA**2) R = SCALEABC*( 1/RANDOM(1) - 1.0D0 ) DO MU = 1,3 ELL(MU) = R * ( COSTHETA*EA(MU) + SINTHETA > * ( COS(PHI)*EB(MU) + SIN(PHI)*EC(MU) ) ) > + PA(MU) ENDDO C ELSE C C We want a map concentrating points rather collinearly with PA(mu). C XX = RANDOM(1) X = B2TO1 * (XX - 0.5D0)/XX/(1.0D0 - XX) + 0.5D0 C ELLT = C2TO1 * ABSPA * SQRT( 1.0D0/RANDOM(1) - 1.0D0 ) C PHI = 2.0D0 * PI * RANDOM(1) C C Step 3: Put this together using our unit vectors. C DO MU = 1,3 ELL(MU) = X * PA(MU) > + ELLT * ( COS(PHI) * EB(MU) + SIN(PHI) * EC(MU) ) ENDDO C C End IF (XCHOICE.LT.F) ... C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION RHO2TO1(PA,PB,ELL) C In: REAL*8 PA(3),PB(3),ELL(3) C C Density in ell(mu) for a self-energy graph that leads to a C propagator with momemtum Pa(mu) that enters the final state. C The map concentrats points rather collinearly with Pa(mu). C C 18 December 2000 C 18 March 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT C C The parameters B2TO1, C2TO1, A2TO1A and A2TO1B need to match C between CHOOSE2TO1 and RHO2TO1. C REAL*8 B2TO1,C2TO1,A2TO1A,A2TO1B PARAMETER (B2TO1 = 0.4D0) PARAMETER (C2TO1 = 0.4D0) PARAMETER (A2TO1A = 0.05D0) PARAMETER (A2TO1B = 0.25D0) REAL*8 PI PARAMETER (PI = 3.141592653589793239D0) C INTEGER MU REAL*8 PASQ,ABSPA,PBSQ,ABSPB,PCSQ,ABSPC,SCALEABC REAL*8 EA(3) REAL*8 X,ELLSQ,ABSELL,ELLZ,ELLTSQ,ELLPRIMESQ,ABSELLPRIME REAL*8 K0SQ,TEMP,DXDXX,J REAL*8 RHO1,RHO2,RHO3,RHO4,RHO5 C C Step 1: C We need the appropriate unit vectors for the map. We create a unit C vector EA(mu) in the direction of PA(mu). We also calculate a C scale factor SCALEABC. C PASQ = 0.0D0 PBSQ = 0.0D0 PCSQ = 0.0D0 DO MU = 1,3 PASQ = PASQ + PA(MU)**2 PBSQ = PBSQ + PB(MU)**2 PCSQ = PCSQ + (PA(MU) + PB(MU))**2 ENDDO IF (PASQ.LT.1.0D-30) THEN WRITE(NOUT,*)'PASQ too small in RHO2TO1' WRITE(NOUT,*)'PA ',PA WRITE(NOUT,*)'ELL',ELL STOP ENDIF ABSPA = SQRT(PASQ) ABSPB = SQRT(PBSQ) ABSPC = SQRT(PBSQ) DO MU = 1,3 EA(MU) = PA(MU)/ABSPA ENDDO SCALEABC = (ABSPA + ABSPB + ABSPC)/3.0D0 C C We also need some other variables. We define ellprime(mu) to be C ell(mu) - pa(mu). C ELLSQ = 0.0D0 ELLZ = 0.0D0 DO MU = 1,3 ELLSQ = ELLSQ + ELL(MU)**2 ELLZ = ELLZ + ELL(MU)*EA(MU) ENDDO ELLTSQ = ELLSQ - ELLZ**2 ABSELL = SQRT(ELLSQ) ELLPRIMESQ = ELLSQ + PASQ - 2.0D0*ELLZ*ABSPA ABSELLPRIME = SQRT(ELLPRIMESQ) C C Step 2: Construct each of the three densities. C C Density 1, for a concentration of points near ell = 0. C TEMP = 4.0D0*PI*ELLSQ*(ABSELL + ABSPA)**2 RHO1 = ABSPA/TEMP C C Density 2, for a concentration of points near ell = 0. C TEMP = 4.0D0*PI*ELLPRIMESQ*(ABSELLPRIME + ABSPA)**2 RHO2 = ABSPA/TEMP C C Density 3, for a concentration of points near ell = 0, BUT with C scale SCALEABC. C TEMP = 4.0D0*PI*ELLSQ*(ABSELL + SCALEABC)**2 RHO3 = SCALEABC/TEMP C C Density 4, for a concentration of points near ell = 0, BUT with C scale SCALEABC. C TEMP = 4.0D0*PI*ELLPRIMESQ*(ABSELLPRIME + SCALEABC)**2 RHO4 = SCALEABC/TEMP C C Density 5, for a concentration of points rather collinearly C with PA(mu). C C Construct the momentum fraction X C X = ELLZ/ABSPA C C Construct the jacobian and its inverse, the density. C K0SQ = C2TO1**2 * PASQ TEMP = SQRT((X-0.5D0)**2 + B2TO1**2) DXDXX = 2.0D0*(TEMP + B2TO1)*TEMP/B2TO1 J = ABSPA*DXDXX*PI/K0SQ*(K0SQ+ELLTSQ)**2 RHO5 = 1/J C C Assemble our five pieces with the right weights. C RHO2TO1 = A2TO1A*(RHO1 + RHO2) > + A2TO1B*(RHO3 + RHO4) > + (1.0D0 - 2.0D0*(A2TO1A+A2TO1B))*RHO5 C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C Subroutines associated with NEWCUT 2 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE MAKECUTINFO C C Input: none C Output: none C C This subroutine creates the information about the various cuts C of each graph and stores it in the common block CUTINFORMATION. C Also counts the number of graphs, the number of cuts for each C graph, and the number of maps for each cut and stores this in the C common block GRAPHCOUNTS. C C In early versions, beowulf called NEWCUT to generate the cut C information each time a new cut was started, but this happens so C often that some thirty percent of the computer time was devoted to C NEWCUT. C C Latest revision: 1 February 2002. C C Array sizes. (We check MAXGRAPHS,MAXCUTS,MAXMAP here.): INTEGER SIZE,MAXGRAPHS,MAXCUTS,MAXMAPS PARAMETER (SIZE = 3) PARAMETER (MAXGRAPHS = 12) PARAMETER (MAXCUTS = 9) PARAMETER (MAXMAPS = 64) C Input and output units. INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT C Graph size variables. INTEGER NPROPS,CUTMAX INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C Information on cut structure: INTEGER NCUTINFO(MAXGRAPHS,MAXCUTS) INTEGER ISIGNINFO(MAXGRAPHS,MAXCUTS,3*SIZE + 1) INTEGER CUTINDEXINFO(MAXGRAPHS,MAXCUTS,SIZE + 1) INTEGER CUTSIGNINFO(MAXGRAPHS,MAXCUTS,SIZE + 1) LOGICAL LEFTLOOPINFO(MAXGRAPHS,MAXCUTS) LOGICAL RIGHTLOOPINFO(MAXGRAPHS,MAXCUTS) INTEGER NINLOOPINFO(MAXGRAPHS,MAXCUTS) INTEGER LOOPINDEXINFO(MAXGRAPHS,MAXCUTS,SIZE+1) INTEGER LOOPSIGNINFO(MAXGRAPHS,MAXCUTS,SIZE+1) COMMON /CUTINFORMATION/ NCUTINFO,ISIGNINFO, > CUTINDEXINFO,CUTSIGNINFO,LEFTLOOPINFO,RIGHTLOOPINFO, > NINLOOPINFO,LOOPINDEXINFO,LOOPSIGNINFO C INTEGER NUMBEROFGRAPHS INTEGER NUMBEROFCUTS(MAXGRAPHS) INTEGER NUMBEROFMAPS(MAXGRAPHS) COMMON /GRAPHCOUNTS/ NUMBEROFGRAPHS,NUMBEROFCUTS,NUMBEROFMAPS C C NEWGRAPH variables: INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3) LOGICAL GRAPHFOUND INTEGER GRAPHNUMBER C NEWCUT variables: INTEGER CUTINDEX(SIZE+1),CUTSIGN(SIZE+1),NCUT INTEGER ISIGN(3*SIZE-1) LOGICAL LEFTLOOP,RIGHTLOOP INTEGER LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1),NINLOOP C FINDTYPES variables INTEGER NMAPS,QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE) CHARACTER*6 MAPTYPES(MAXMAPS) C LOGICAL NEWCUTINIT,CUTFOUND C INTEGER P,I,NP INTEGER CUTNUMBER INTEGER ORDER LOGICAL SAYIT C C--------- C SAYIT = .FALSE. IF (SAYIT) THEN WRITE(NOUT,*)' ' WRITE(NOUT,*)'Report from makecutinfo' ENDIF C C Initialize graph counting. C GRAPHNUMBER = 0 C DO ORDER = 2,1,-1 C IF (SAYIT) THEN WRITE(NOUT,*)' ' WRITE(NOUT,*)'Order of graphs ',ORDER ENDIF C IF (ORDER.EQ.1) THEN NPROPS = NPROPS1 CUTMAX = CUTMAX1 ELSE IF (ORDER.EQ.2) THEN NPROPS = NPROPS2 CUTMAX = CUTMAX2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C GRAPHFOUND = .TRUE. C DO WHILE (GRAPHFOUND) CALL NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND) IF (GRAPHFOUND) THEN GRAPHNUMBER = GRAPHNUMBER + 1 C IF (SAYIT) THEN WRITE(NOUT,*)' ' WRITE(NOUT,*)'Graph number ',GRAPHNUMBER ENDIF C C Get a new cut. C CUTFOUND = .TRUE. NEWCUTINIT = .TRUE. CUTNUMBER = 0 DO WHILE (CUTFOUND) CALL NEWCUT(VRTX,ORDER,NEWCUTINIT,NCUT,ISIGN, > CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP, > NINLOOP,LOOPINDEX,LOOPSIGN,CUTFOUND) IF (CUTFOUND) THEN CUTNUMBER = CUTNUMBER + 1 C IF (SAYIT) THEN WRITE(NOUT,*)' ' WRITE(NOUT,*)'Cut number ',CUTNUMBER,' NCUT = ',NCUT ENDIF C NCUTINFO(GRAPHNUMBER,CUTNUMBER) = NCUT DO P = 1,NPROPS ISIGNINFO(GRAPHNUMBER,CUTNUMBER,P) = ISIGN(P) IF (SAYIT) THEN WRITE(NOUT,*)'ISIGN(',P,') = ',ISIGN(P) ENDIF ENDDO DO I = 1,CUTMAX CUTINDEXINFO(GRAPHNUMBER,CUTNUMBER,I) = CUTINDEX(I) CUTSIGNINFO(GRAPHNUMBER,CUTNUMBER,I) = CUTSIGN(I) IF (SAYIT) THEN WRITE(NOUT,*)'CUTINDEX(',I,') = ',CUTINDEX(I) WRITE(NOUT,*)'CUTSIGN(',I,') = ',CUTSIGN(I) ENDIF ENDDO LEFTLOOPINFO(GRAPHNUMBER,CUTNUMBER) = LEFTLOOP RIGHTLOOPINFO(GRAPHNUMBER,CUTNUMBER) = RIGHTLOOP NINLOOPINFO(GRAPHNUMBER,CUTNUMBER) = NINLOOP IF (SAYIT) THEN WRITE(NOUT,*)'LEFTLOOP = ',LEFTLOOP WRITE(NOUT,*)'RIGHTLOOP = ',RIGHTLOOP WRITE(NOUT,*)'NINLOOP = ',NINLOOP ENDIF DO NP = 1,CUTMAX LOOPINDEXINFO(GRAPHNUMBER,CUTNUMBER,NP) = LOOPINDEX(NP) LOOPSIGNINFO(GRAPHNUMBER,CUTNUMBER,NP) = LOOPSIGN(NP) IF (SAYIT) THEN WRITE(NOUT,*)'LOOPINDEX(',NP,') = ',LOOPINDEX(NP) WRITE(NOUT,*)'LOOPSIGN(',NP,') = ',LOOPSIGN(NP) ENDIF ENDDO C C Close loop DO WHILE (CUTFOUND), IF (CUTFOUND) THEN C ENDIF ENDDO C IF (CUTNUMBER.GT.MAXCUTS) THEN WRITE(NOUT,*)'More cuts than I thought.' STOP ENDIF NUMBEROFCUTS(GRAPHNUMBER) = CUTNUMBER C C Calculate number of maps NMAPS, index arrays QS, C signs QSIGNS, and types MAPTYPES associated with the maps. C All we really want here is NMAPS, but we get the rest at C a low price. C CALL FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES) NUMBEROFMAPS(GRAPHNUMBER) = NMAPS IF (SAYIT) THEN WRITE(NOUT,*)' ' WRITE(NOUT,*)'For graph',GRAPHNUMBER,', NUMBEROFMAPS = ',NMAPS ENDIF IF (NMAPS.GT.MAXMAPS) THEN WRITE(NOUT,*)'Ooops, more maps than we anticipated.' STOP ENDIF C C Close loop DO WHILE (GRAPHFOUND), IF (GRAPHFOUND) THEN C ENDIF ENDDO C C C Close DO ORDER = 2,1,-1 C ENDDO C IF (GRAPHNUMBER.GT.MAXGRAPHS) THEN WRITE(NOUT,*)'More graphs than I thought.' STOP ENDIF NUMBEROFGRAPHS = GRAPHNUMBER IF (SAYIT) THEN WRITE(NOUT,*)' ' WRITE(NOUT,*)'NUMBEROFGRAPHS = ',NUMBEROFGRAPHS ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE GETCUTINFO(GRAPHNUMBER,CUTNUMBER,ORDER,NCUT,ISIGN, > CUTINDEX,CUTSIGN,LEFTLOOP,RIGHTLOOP, > NINLOOP,LOOPINDEX,LOOPSIGN) C INTEGER SIZE PARAMETER (SIZE = 3) C Input: INTEGER GRAPHNUMBER,CUTNUMBER,ORDER C Output: INTEGER NCUT,ISIGN(3*SIZE-1) INTEGER CUTINDEX(SIZE+1),CUTSIGN(SIZE+1) LOGICAL LEFTLOOP,RIGHTLOOP INTEGER NINLOOP,LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1) C C This subroutine reads from the information recorded in the common C CUTINFORMATION and returns the information relevant for C the current graph,specified by GRAPHNUMBER and the current cut, C specified by CUTNUMBER. See the subroutine NEWCUT for definition C of the variables returned. C C Latest revision: 5 January 1999. C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NPROPS,CUTMAX INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C C Information on cut structure: INTEGER MAXGRAPHS,MAXCUTS PARAMETER (MAXGRAPHS = 12) PARAMETER (MAXCUTS = 9) INTEGER NCUTINFO(MAXGRAPHS,MAXCUTS) INTEGER ISIGNINFO(MAXGRAPHS,MAXCUTS,3*SIZE + 1) INTEGER CUTINDEXINFO(MAXGRAPHS,MAXCUTS,SIZE + 1) INTEGER CUTSIGNINFO(MAXGRAPHS,MAXCUTS,SIZE + 1) LOGICAL LEFTLOOPINFO(MAXGRAPHS,MAXCUTS) LOGICAL RIGHTLOOPINFO(MAXGRAPHS,MAXCUTS) INTEGER NINLOOPINFO(MAXGRAPHS,MAXCUTS) INTEGER LOOPINDEXINFO(MAXGRAPHS,MAXCUTS,SIZE+1) INTEGER LOOPSIGNINFO(MAXGRAPHS,MAXCUTS,SIZE+1) COMMON /CUTINFORMATION/ NCUTINFO,ISIGNINFO, > CUTINDEXINFO,CUTSIGNINFO,LEFTLOOPINFO,RIGHTLOOPINFO, > NINLOOPINFO,LOOPINDEXINFO,LOOPSIGNINFO C INTEGER P,I,NP C C-------- C IF (ORDER.EQ.1) THEN NPROPS = NPROPS1 CUTMAX = CUTMAX1 ELSE IF (ORDER.EQ.2) THEN NPROPS = NPROPS2 CUTMAX = CUTMAX2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C NCUT = NCUTINFO(GRAPHNUMBER,CUTNUMBER) DO P = 1,NPROPS ISIGN(P) = ISIGNINFO(GRAPHNUMBER,CUTNUMBER,P) ENDDO DO I = 1,CUTMAX CUTINDEX(I) = CUTINDEXINFO(GRAPHNUMBER,CUTNUMBER,I) CUTSIGN(I) = CUTSIGNINFO(GRAPHNUMBER,CUTNUMBER,I) ENDDO LEFTLOOP = LEFTLOOPINFO(GRAPHNUMBER,CUTNUMBER) RIGHTLOOP = RIGHTLOOPINFO(GRAPHNUMBER,CUTNUMBER) NINLOOP = NINLOOPINFO(GRAPHNUMBER,CUTNUMBER) DO NP = 1,CUTMAX LOOPINDEX(NP) = LOOPINDEXINFO(GRAPHNUMBER,CUTNUMBER,NP) LOOPSIGN(NP) = LOOPSIGNINFO(GRAPHNUMBER,CUTNUMBER,NP) ENDDO C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE NEWCUT(XVRTX,ORDER,NEWCUTINIT,XNCUT,XISIGN, > XCUTINDEX,XCUTSIGN,XLEFTLOOP,XRIGHTLOOP, > XNINLOOP,XLOOPINDEX,XLOOPSIGN,CUTFOUND) C INTEGER SIZE PARAMETER (SIZE = 3) C Input: INTEGER XVRTX(0:3*SIZE-1,2) INTEGER ORDER C Input and output: LOGICAL NEWCUTINIT C Output: INTEGER XCUTINDEX(SIZE+1),XCUTSIGN(SIZE+1),XNCUT INTEGER XISIGN(3*SIZE-1) LOGICAL XLEFTLOOP,XRIGHTLOOP INTEGER XLOOPINDEX(SIZE+1),XLOOPSIGN(SIZE+1),XNINLOOP LOGICAL CUTFOUND C C This subroutine generates valid cuts for a given graph. C In its present form, it generates cuts with CUTMAX lines cut C and with (CUTMAX - 1) lines cut. In the case that (CUTMAX - 1) C lines are cut, it also finds the (single) virtual loop. C C The action of the subroutine depends on its state when called. It C has two possible states. If NEWCUTINIT is true, NEWCUT is ready C start generating cuts for a new graph. This is the state when the C subroutine is called for the first time. If NEWCUTINIT is false, the C subroutine is ready to generate a new cut for the current graph. C When NEWCUT is called with NEWCUTINIT = False but it cannot find C a new cut, it exits with NEWCUTINIT = True and the output variable C CUTFOUND = False. This tells the mainprogram to produce a new graph. C C Notation: [X variables are interchanged with the external world.] C VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of C of propagator P. Specifies the supergraph. C NCUT = Number of cut propagators. C ISIGN(P) = +1 if propagator P is left of cut, -1 if right, 0 if cut. C CUTINDEX(I) = Index P of cut propagator I, I = 1,...,NCUT. C CUTSIGN(I) = Sign of cut propagator I (+1 if from Left to Right). C If NCUT = CUTMAX - 1 then there is a virtual loop and C we define CUTINDEX(CUTMAX) = 0. C But in subroutine LOOPCUT we will let I = CUTMAX designate C the loopcut: C CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) C CUTSIGN(CUTMAX) = LOOPSIGN(CUTMAX) C LEFTLOOP = True iff there is a virtual loop to the left of the cut. C RIGHTLOOP = True iff there is a virtual loop to the right of the cut. C NINLOOP = Number of propagators in loop. C LOOPINDEX(NP) = Index P of NPth propagator around the loop. C The loop begins (with NP = 1) at the starting vertex that is C defined as the current vertex if the the loop includes the C current vertex or the vertex in the loop that is attached to the C uncut propagator of the lowest index P. C LOOPSIGN(NP) = 1 if propagator direction is same as loop direction. C -1 if direction is opposite to loop direction. C CUTFOUND = False if we can't find a next cut. C C CUT(P) = True iff propagator P is cut. C VALIDCUT = True iff the cut is OK. C LEFT(V) = True iff vertex V is to the left of the cut. C Vertex 1, the left hand current, is always in LEFT. C NLEFT = Number of vertices to the left of the cut. C RIGHT(V) = True iff vertex V is to the right of the cut. C Vertex 2, the right hand current, is always in RIGHT. C NRIGHT = Number of vertices to the right of the cut. C C LOOPVERTEX(V) = True if vertex V is in the loop. C LOOPPROP(P) = True if propagator P is in the loop. C NCONNECTED = Number of propagators connected to a vertex. C STARTVERTEX = Starting vertex in a loop. C HOTVERTEX = Vertex to which next loop propagator should be added. C C Logical state variables: C NEWCUTINIT = True if NEWCUT called for first time with a new graph, C else False. C C ----- Outline ----- C C Output variables -> default values. C IF (NEWCUTINIT) THEN C Initialize, including NEXTCUT = True. C ENDIF C START = .FALSE. C VALIDCUT = .FALSE. C DO WHILE (.NOT.VALIDCUT) C Generate next cut, specified by CUTINDEX(I). C Here CUTINDEX(CUTMAX) = 0 indicates a virtual loop. C In this case, set NCUT = CUTMAX - 1. Else NCUT = CUTMAX. C Check cut, setting VALIDCUT to True if cut is OK. C ENDDO C IF (NCUT.EQ.CUTMAX) THEN C Set LEFTLOOP and RIGHTLOOP to False C Normal Return. C ELSE set LEFTLOOP or RIGHTLOOP to True as appropriate. C ENDIF C Find the loop, determining LOOPINDEX(NP) and LOOPSIGN(NP), C where NP = 1 designates the propagator starting at the C starting vertex defined above. C NINLOOP = number of propagators in loop. C Normal Return. C C Normal Return: C Set output variables to values of internal variables. C C 2 November 1992 C 26 January 1992 C 20 June 1993 C 21 August 1993 C 26 June 1994 C 11 July 1994 C 20 March 1996 C 1 February 2001 C C ------------------- C C----------------------------------------------------------------------- C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NPROPS,NVERTS,CUTMAX INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C INTEGER V,P INTEGER I,II,IP,V1,V2 LOGICAL LEFT(2*SIZE),RIGHT(2*SIZE) LOGICAL CHANGE LOGICAL VALIDCUT LOGICAL LOOPVERTEX(2*SIZE),LOOPPROP(3*SIZE-1) INTEGER NLEFT,NRIGHT,NCONNECTED LOGICAL CUT(3*SIZE-1),LEFTLOOP,RIGHTLOOP INTEGER CUTSIGN(SIZE+1),NCUT INTEGER LOOPINDEX(SIZE+1),LOOPSIGN(SIZE+1) INTEGER NINLOOP LOGICAL LOOKMORE INTEGER STARTVERTEX,HOTVERTEX,PREVIOUSPROP C C Internal state variables to be saved C INTEGER VRTX(0:3*SIZE-1,2) SAVE VRTX INTEGER CUTINDEX(SIZE+1) SAVE CUTINDEX C IF (ORDER.EQ.1) THEN NPROPS = NPROPS1 NVERTS = NVERTS1 CUTMAX = CUTMAX1 ELSE IF (ORDER.EQ.2) THEN NPROPS = NPROPS2 NVERTS = NVERTS2 CUTMAX = CUTMAX2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C C Default values for the output variables C XNCUT = 0 XLEFTLOOP = .FALSE. XRIGHTLOOP = .FALSE. XNINLOOP = 0 DO I = 1,CUTMAX XCUTINDEX(I) = 0 XCUTSIGN(I) = 0 XLOOPINDEX(I) = 0 XLOOPSIGN(I) = 0 ENDDO CUTFOUND = .FALSE. C C If we should start generating cuts anew, we initialize. Else C we do some checking (just in case). The initialization depends C on ORDER. C IF (NEWCUTINIT) THEN IF (ORDER.EQ.1) THEN CUTINDEX(1) = CUTMAX - 1 DO I = 2, CUTMAX CUTINDEX(I) = CUTMAX + 1 - I ENDDO ELSE CUTINDEX(1) = CUTMAX - 2 DO I = 2, CUTMAX CUTINDEX(I) = CUTMAX - I ENDDO ENDIF DO P = 0,NPROPS DO I = 1,2 VRTX(P,I) = XVRTX(P,I) ENDDO ENDDO ELSE DO P = 0,NPROPS DO I = 1,2 IF (.NOT.(VRTX(P,I).EQ.XVRTX(P,I))) THEN WRITE(NOUT,*)'SNAFU in NEWCUT. VRTX changed.' STOP ENDIF ENDDO ENDDO ENDIF C NEWCUTINIT = .FALSE. C C Initialization complete. C C Loop to find new valid cut. C VALIDCUT = .FALSE. DO WHILE (.NOT.VALIDCUT) C C Generate a new choice of the CUTINDEX(I). C We choose CUTINDEX(1),CUTINDEX(2),...,CUTINDEX(CUTMAX) C with 0 .LE. CUTINDEX(I) .LE. NPROPS and CUTINDEX(I) > CUTINDEX(I+1). C CUTINDEX(CUTMAX) = 0 indicates that there is a virtual loop. C Example, for NLOOPS = 3: CUTINDEX(I) is initialized to (2,2,1,0). C From this, we generate first CUTINDEX(I) = (3,2,1,0). On successive C runs through this code, we generate (4,2,1,0), (5,2,1,0), (6,2,1,0), C (7,2,1,0), (8,2,1,0), (4,3,1,0), (5,3,1,0),..., (8,3,1,0), (5,4,1,0), C (6,4,1,0),..., (8,7,6,0), (4,3,2,1), (5,3,2,1),..., (8,7,6,5). C In case the choice previously analyzed was the last one, then C there are no more cuts, we set CUTFOUND to False to abort further C analysis in the main program, and set NEWCUTINIT to True so that we C start over again next time this subroutine is called, and then return. C C In the case of ORDER = 1, we want only tree graphs. Therefore we C change the initialization so that, for NLOOPS = 3: CUTINDEX(I) is C initialized to (2,2,1). From this, we generate first CUTINDEX(I) = C (3,2,1). C I = 1 77 IF( CUTINDEX(I).LT.NPROPS + 1 - I) THEN CUTINDEX(I) = CUTINDEX(I) + 1 DO II = 1,I - 1 CUTINDEX(II) = CUTINDEX(I) + I - II ENDDO ELSE I = I + 1 IF (I.LE.CUTMAX) THEN GO TO 77 ELSE CUTFOUND = .FALSE. NEWCUTINIT = .TRUE. RETURN ENDIF ENDIF C C Now that we have the CUTINDEX(I), set CUT(CUTINDEX(I)) = True. C CUTINDEX(CUTMAX) = 0 indicates that CUTMAX - 1 propagators were cut. C DO P= 1,NPROPS CUT(P) = .FALSE. ENDDO DO I = 1, CUTMAX - 1 CUT(CUTINDEX(I)) = .TRUE. ENDDO IF (CUTINDEX(CUTMAX).EQ.0) THEN NCUT = CUTMAX - 1 ELSE NCUT = CUTMAX CUT(CUTINDEX(CUTMAX)) = .TRUE. ENDIF C C Construct Left and Right sets. Any vertex that is connected to a Left C vertex by an uncut propagator is in Left. Similarly for Right. C Start with vertex 1 in Left and vertex 2 in Right. C DO V = 1,NVERTS LEFT(V) = .FALSE. RIGHT(V) = .FALSE. ENDDO LEFT(1) = .TRUE. RIGHT(2) = .TRUE. NLEFT = 1 NRIGHT = 1 C C Now add vertices that are connected to the Left vertices. C CHANGE = .TRUE. DO WHILE (CHANGE) CHANGE = .FALSE. DO P = 1,NPROPS IF(.NOT.CUT(P)) THEN C IF(LEFT(VRTX(P,1)).AND.(.NOT.LEFT(VRTX(P,2)))) THEN LEFT(VRTX(P,2)) = .TRUE. CHANGE = .TRUE. NLEFT = NLEFT + 1 ELSE IF(LEFT(VRTX(P,2)).AND.(.NOT.LEFT(VRTX(P,1)))) THEN LEFT(VRTX(P,1)) = .TRUE. CHANGE = .TRUE. NLEFT = NLEFT + 1 ENDIF C ENDIF ENDDO ENDDO C C Now add vertices that are connected to the Right vertices. C CHANGE = .TRUE. DO WHILE (CHANGE) CHANGE = .FALSE. DO P = 1,NPROPS IF(.NOT.CUT(P)) THEN C IF(RIGHT(VRTX(P,1)).AND.(.NOT.RIGHT(VRTX(P,2)))) THEN RIGHT(VRTX(P,2)) = .TRUE. CHANGE = .TRUE. NRIGHT = NRIGHT + 1 ELSE IF(RIGHT(VRTX(P,2)).AND.(.NOT.RIGHT(VRTX(P,1)))) THEN RIGHT(VRTX(P,1)) = .TRUE. CHANGE = .TRUE. NRIGHT = NRIGHT + 1 ENDIF C ENDIF ENDDO ENDDO C C Check for validity of the cut. Cut is not valid unless each vertex is C in Left or Right but not both. C VALIDCUT = .TRUE. DO V = 1,NVERTS IF (.NOT.(LEFT(V).XOR.RIGHT(V))) THEN VALIDCUT = .FALSE. ENDIF ENDDO C C Check that each cut propagator divides the Left set from the Right. C DO I = 1,NCUT IF(LEFT(VRTX(CUTINDEX(I),1)).AND. > RIGHT(VRTX(CUTINDEX(I),2)) ) THEN CUTSIGN(I) = 1 ELSE IF(LEFT(VRTX(CUTINDEX(I),2)).AND. > RIGHT(VRTX(CUTINDEX(I),1)) ) THEN CUTSIGN(I) = -1 ELSE VALIDCUT = .FALSE. ENDIF ENDDO C C End of loop to generate a new cut C ENDDO C C Are there virtual loops? If not, just return (GOTO 1), C IF (NCUT.EQ.CUTMAX) THEN LEFTLOOP = .FALSE. RIGHTLOOP = .FALSE. NINLOOP = 0 DO I = 1,CUTMAX LOOPINDEX(I) = 0 LOOPSIGN(I) = 0 ENDDO GOTO 1 ELSE IF (NCUT.EQ.(CUTMAX - 1)) THEN IF ((NLEFT - NRIGHT).EQ.2) THEN LEFTLOOP = .TRUE. RIGHTLOOP = .FALSE. ELSE IF ((NRIGHT - NLEFT).EQ.2) THEN RIGHTLOOP = .TRUE. LEFTLOOP = .FALSE. ELSE WRITE(NOUT,*)'NRIGHT,NLEFT out of bounds' STOP ENDIF ELSE WRITE(NOUT,*)'NCUT out of bounds' STOP ENDIF C C Find the virtual loops. C C First, initialize all vertices to the left of the cut to be candidate C vertices for the left-loop. Alternatively, if we have a right-loop, C initialize all vertices to the right of the cut to be candidate C vertices for the right-loop C IF (LEFTLOOP) THEN DO V = 1,NVERTS IF (LEFT(V)) THEN LOOPVERTEX(V) = .TRUE. ELSE LOOPVERTEX(V) = .FALSE. ENDIF ENDDO ELSE IF (RIGHTLOOP) THEN DO V = 1,NVERTS IF (RIGHT(V)) THEN LOOPVERTEX(V) = .TRUE. ELSE LOOPVERTEX(V) = .FALSE. ENDIF ENDDO ENDIF C C Now we will iteratively remove candidate vertices for the loop if they C are not properly connected. C CHANGE = .TRUE. DO WHILE (CHANGE) CHANGE = .FALSE. C C A loop propagator is one that joins two loop vertices. C DO P = 1,NPROPS IF(LOOPVERTEX(VRTX(P,1)).AND.LOOPVERTEX(VRTX(P,2)))THEN LOOPPROP(P) = .TRUE. ELSE LOOPPROP(P) = .FALSE. ENDIF ENDDO C C Now a loop vertex is one that connects at least two loop propagators. C If a vertex fails this test, remove it from the loop list. C DO V = 1,NVERTS IF (LOOPVERTEX(V)) THEN C NCONNECTED = 0 DO P = 1,NPROPS IF( LOOPPROP(P).AND. > ((VRTX(P,1).EQ.V).OR.(VRTX(P,2).EQ.V)) ) THEN NCONNECTED = NCONNECTED + 1 ENDIF ENDDO C IF(NCONNECTED.LT.2) THEN LOOPVERTEX(V) = .FALSE. CHANGE = .TRUE. ENDIF ENDIF ENDDO C C Close loop over removal of loop vertices C ENDDO C C We now know which propagators are in the loop. Next we need to C find the starting vertex in the loop. The STARTVERTEX is either C vertex 1 or vertex 2 (connected to the external lines) or it is C a LOOPVERTEX connected connected to a propagator that is not in C the loop and not cut. We take the first one that we find. C IF (LOOPVERTEX(1)) THEN STARTVERTEX = 1 ELSE IF (LOOPVERTEX(2)) THEN STARTVERTEX = 2 ELSE P = 1 LOOKMORE = .TRUE. DO WHILE (LOOKMORE) IF (P.GT.NPROPS) THEN WRITE(NOUT,*) 'SNAFU 1 in NEWCUT, P too big' STOP ENDIF IF ( (.NOT.LOOPPROP(P)).AND.(.NOT.CUT(P)) ) THEN IF ( LOOPVERTEX(VRTX(P,1)) ) THEN STARTVERTEX = VRTX(P,1) LOOKMORE = .FALSE. ELSE IF ( LOOPVERTEX(VRTX(P,2)) ) THEN STARTVERTEX = VRTX(P,2) LOOKMORE = .FALSE. ENDIF ENDIF P = P + 1 ENDDO ENDIF C C Now add first propagator in the loop. C P = 1 LOOKMORE = .TRUE. DO WHILE (LOOKMORE) IF (P.GT.NPROPS) THEN WRITE(NOUT,*) 'SNAFU 2 in NEWCUT, P too big' STOP ENDIF IF(LOOPPROP(P)) THEN IF((VRTX(P,1).EQ.STARTVERTEX)) THEN IP = 1 LOOPINDEX(IP) = P PREVIOUSPROP = P LOOPSIGN(IP) = 1 HOTVERTEX = VRTX(P,2) LOOKMORE = .FALSE. ELSE IF((VRTX(P,2).EQ.STARTVERTEX)) THEN IP = 1 LOOPINDEX(IP) = P PREVIOUSPROP = P LOOPSIGN(IP) = -1 HOTVERTEX = VRTX(P,1) LOOKMORE = .FALSE. ENDIF ENDIF P = P+1 ENDDO C C Now add propagators around the loop. C DO WHILE (HOTVERTEX.NE.STARTVERTEX) P = 1 LOOKMORE = .TRUE. DO WHILE (LOOKMORE) IF (P.GT.NPROPS) THEN WRITE(NOUT,*) 'SNAFU 3 in NEWCUT, P too big' STOP ENDIF IF(LOOPPROP(P).AND.(.NOT.(PREVIOUSPROP.EQ.P))) THEN IF((VRTX(P,1).EQ.HOTVERTEX)) THEN IP = IP + 1 LOOPINDEX(IP) = P PREVIOUSPROP = P LOOPSIGN(IP) = 1 HOTVERTEX = VRTX(P,2) LOOKMORE = .FALSE. ELSE IF((VRTX(P,2).EQ.HOTVERTEX)) THEN IP = IP + 1 LOOPINDEX(IP) = P PREVIOUSPROP = P LOOPSIGN(IP) = -1 HOTVERTEX = VRTX(P,1) LOOKMORE = .FALSE. ENDIF ENDIF P = P + 1 ENDDO ENDDO NINLOOP = IP C C Come to here for a normal return. C 1 CUTFOUND = .TRUE. XLEFTLOOP = LEFTLOOP XRIGHTLOOP = RIGHTLOOP XNINLOOP = NINLOOP XNCUT = NCUT C DO I = 1,CUTMAX XCUTINDEX(I) = CUTINDEX(I) XCUTSIGN(I) = CUTSIGN(I) ENDDO C DO I = 1,NINLOOP XLOOPINDEX(I) = LOOPINDEX(I) XLOOPSIGN(I) = LOOPSIGN(I) ENDDO C DO P = 1,NPROPS V1 = VRTX(P,1) V2 = VRTX(P,2) IF (LEFT(V1).AND.LEFT(V2)) THEN XISIGN(P) = 1 ELSE IF (RIGHT(V1).AND.RIGHT(V2)) THEN XISIGN(P) = -1 ELSE XISIGN(P) = 0 ENDIF ENDDO C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C End of subroutines associated with NEWCUT 2 C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE DEFORM(VRTX,LOOPINDEX,RTS,LEFTLOOP,RIGHTLOOP, > NINLOOP,KINLOOP,NEWKINLOOP,JACDEFORM) C INTEGER SIZE PARAMETER (SIZE = 3) C In: INTEGER VRTX(0:3*SIZE-1,2) INTEGER LOOPINDEX(SIZE+1) REAL*8 RTS LOGICAL LEFTLOOP,RIGHTLOOP INTEGER NINLOOP REAL*8 KINLOOP(SIZE+1,0:3) C Out: COMPLEX*16 NEWKINLOOP(0:3) COMPLEX*16 JACDEFORM C C Contour deformation. Note that this simple algorithm should C work for NINLOOP = 3 and for NINLOOP = 4 if the sum of the C three 3-momenta exiting the loop vanishes. C C In variables: C VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of C of propagator P. Specifies the supergraph. C LOOPINDEX(NP) = Index P of NPth propagator around the loop. C RTS = energy of final state. C LEFTLOOP = T if there is a loop to the left of the cut. C RIGHTLOOP = T if there is a loop to the right of the cut. C NINLOOP = number of propagators in the loop. C KINLOOP(J,MU) = momentum of Jth propagator in loop (real part) C Out variables: C NEWKINLOOP(MU) = added part of loop momentum. C (purely imaginary for MU = 1,2,3) C JACDEFORM = jacobian associated with contour deformation. C C Our notation is C vec Q(j) = vec L(j) - vec L(j+1) j = 1,...,Ninloop - 1 C L(j) = |L(j)| j = 1,...,Ninloop - 1 C Q(j) = |Q(j)| j = 1,...,Ninloop - 1 C C 27 October 1992 first DEFORM C 1 February 1998 latest version C 23 February 1998 minor revision to rename deform variables C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 DEFORMALPHA,DEFORMBETA,DEFORMGAMMA COMMON /DEFORMSCALES/DEFORMALPHA,DEFORMBETA,DEFORMGAMMA C REAL*8 S INTEGER SIGN REAL*8 L(SIZE+1,3) C REAL*8 Q(SIZE,3),QSQ(SIZE),QABS(SIZE) REAL*8 LHAT(SIZE,3),LSQ(SIZE),LABS(SIZE) REAL*8 W(SIZE,3),WSQ(SIZE),WABS(SIZE) REAL*8 ACRIT2,ACRIT3,A2,A3 REAL*8 DELTA REAL*8 M1(3,3),M2(3,3),M3(3,3) REAL*8 D1,D2,D3,DSQ,GRADDSQ(3) REAL*8 FRACTION,GRADF(3) REAL*8 G2,G3,DG2DA2,DG3DA3 REAL*8 C,DLNCDDSQ REAL*8 TERMC,TERMF,TERMG2,TERMG3,TERMW2,TERMW3,TERMS COMPLEX*16 A(3,3) C LOGICAL CONNECTSTOCURRENT REAL*8 TEMP,TEMP1,TEMP2,TEMP3 INTEGER J,MU,NU C C Calculate s. C S = RTS**2 C C Initialize with default value. C DO MU = 0,3 NEWKINLOOP(MU) = (0.0D0,0.0D0) ENDDO C JACDEFORM = (1.0D0,0.0D0) C C Check to see if we should actually do anything C IF (NINLOOP.LT.2) THEN RETURN ENDIF C C Set C SIGN = +1 and L(J,MU) = KINLOOP(J,MU) for a left loop, C SIGN = -1 and L(J,MU) = KINLOOP(NINLOOP-J+1,MU) for a right loop. C IF (LEFTLOOP) THEN SIGN = + 1 DO J = 1,NINLOOP DO MU = 1,3 L(J,MU) = KINLOOP(J,MU) ENDDO ENDDO ELSE IF (RIGHTLOOP) THEN SIGN = - 1 DO J = 1,NINLOOP DO MU = 1,3 L(J,MU) = KINLOOP(NINLOOP-J+1,MU) ENDDO ENDDO ELSE WRITE(NOUT,*) 'Snafu in DEFORM' STOP ENDIF C C Two particles in the loop. C IF (NINLOOP.EQ.2) THEN C C Calculate Q(3,mu), |L(j)|^2, |Q(3)|^2, |L(j)|, |Q(3)|, hat L(j,mu). C QSQ(3) = 0.0D0 DO MU = 1,3 Q(3,MU) = L(1,MU) - L(2,MU) QSQ(3) = QSQ(3) + Q(3,MU)**2 ENDDO QABS(3) = SQRT(QSQ(3)) DO J = 1,2 LSQ(J) = 0.0D0 DO MU = 1,3 LSQ(J) = LSQ(J) + L(J,MU)**2 ENDDO LABS(J) = SQRT(LSQ(J)) DO MU = 1,3 LHAT(J,MU) = L(J,MU)/LABS(J) ENDDO ENDDO C C Calculate the vector W(3,mu), along with the corresponding C normalization factor. C WSQ(3) = 0.0D0 DO MU = 1,3 W(3,MU) = LHAT(1,MU) + LHAT(2,MU) WSQ(3) = WSQ(3) + W(3,MU)**2 ENDDO WABS(3) = SQRT(WSQ(3)) C C The size of the critical ellipse. C ACRIT3 = RTS - 2.0D0*QABS(3) C C The size of the ellipse at point L. C A3 = LABS(1) + LABS(2) - QABS(3) C C Calculate the matrix d W(3,mu)/ d L(mu) = M3(mu,nu). C DO MU = 1,3 DO NU = 1,3 TEMP = DELTA(MU,NU) TEMP1 = (TEMP - LHAT(1,MU)*LHAT(1,NU))/LABS(1) TEMP2 = (TEMP - LHAT(2,MU)*LHAT(2,NU))/LABS(2) M3(MU,NU) = TEMP1 + TEMP2 ENDDO ENDDO C C The "distance" to the collinear line. C D3 = LABS(1)*LABS(2)*WABS(3)/QABS(3) C C The square of the distance its gradient. C DSQ = D3**2 DO NU = 1,3 TEMP = 0.0D0 DO MU = 1,3 TEMP = TEMP + W(3,MU)*M3(MU,NU) ENDDO TEMP = TEMP/WSQ(3) TEMP = TEMP + L(1,NU)/LSQ(1) + L(2,NU)/LSQ(2) GRADDSQ(NU) = 2.0D0*DSQ*TEMP ENDDO C C The function G3 and its derivative. C G3 = 1.0D0/(ACRIT3 + DEFORMGAMMA*A3) DG3DA3 = - DEFORMGAMMA/(ACRIT3 + DEFORMGAMMA*A3)**2 C C Calculate the function C(DSQ) and its derivative. Note that we change C the sign of C in the case of a loop to the right of the cut. C C We effectively make DEFORMALPHA smaller by a factor 10 for the two C point function so as to avoid crossing branch cut of SQRT C C = SIGN*DEFORMALPHA*DSQ /(1.0D0 + DEFORMBETA*DSQ/QSQ(3)) C = C * ACRIT3/RTS DLNCDDSQ = 1.0D0/DSQ/(1.0D0 + DEFORMBETA*DSQ/QSQ(3)) C C Calculate the imaginary part of the loop momentum L(mu). C DO MU = 1,3 NEWKINLOOP(MU) = (0.0D0,-1.0D0) * C * G3 * W(3,MU) ENDDO C C Calculate the jacobian. C First, we need the comlex matrix A(mu,nu), the derivative C of ComplexL(mu) with respecdt to L(nu). C DO MU = 1,3 DO NU = 1,3 TERMC = G3*W(3,MU)*DLNCDDSQ*GRADDSQ(NU) TERMG3 = DG3DA3*W(3,MU)*W(3,NU) TERMW3 = G3*M3(MU,NU) TERMS = TERMC + TERMG3 + TERMW3 A(MU,NU) = DELTA(MU,NU) + (0.0D0,-1.0D0) * C * TERMS ENDDO ENDDO C C Finally, the jacobian is the determinant of A C JACDEFORM = A(1,1) * ( A(2,2) * A(3,3) - A(2,3) * A(3,2) ) > + A(1,2) * ( A(2,3) * A(3,1) - A(2,1) * A(3,3) ) > + A(1,3) * ( A(2,1) * A(3,2) - A(2,2) * A(3,1) ) C C End of Ninloop = 2 calculation C C Three particles in the loop. C ELSE IF (NINLOOP.EQ.3) THEN C C First we need to determine if our loop connects to the current vertex. C IF (LEFTLOOP) THEN IF ((VRTX(LOOPINDEX(1),1).EQ.1)) THEN CONNECTSTOCURRENT = .TRUE. ELSE CONNECTSTOCURRENT = .FALSE. ENDIF ELSE IF ((VRTX(LOOPINDEX(1),1).EQ.2)) THEN CONNECTSTOCURRENT = .TRUE. ELSE CONNECTSTOCURRENT = .FALSE. ENDIF ENDIF IF (CONNECTSTOCURRENT) THEN C C Calculation for a three particle loop that connects to the current. C C Calculate Q(3,mu), |L(j)|^2, |Q(3)|^2, |L(j)|, |Q(3)|, hat L(j,mu). C QSQ(3) = 0.0D0 DO MU = 1,3 Q(3,MU) = L(1,MU) - L(2,MU) QSQ(3) = QSQ(3) + Q(3,MU)**2 ENDDO QABS(3) = SQRT(QSQ(3)) DO J = 1,2 LSQ(J) = 0.0D0 DO MU = 1,3 LSQ(J) = LSQ(J) + L(J,MU)**2 ENDDO LABS(J) = SQRT(LSQ(J)) DO MU = 1,3 LHAT(J,MU) = L(J,MU)/LABS(J) ENDDO ENDDO C C Calculate the vector W(3,mu), along with the corresponding C normalization factor. C WSQ(3) = 0.0D0 DO MU = 1,3 W(3,MU) = LHAT(1,MU) + LHAT(2,MU) WSQ(3) = WSQ(3) + W(3,MU)**2 ENDDO WABS(3) = SQRT(WSQ(3)) C C The size of the critical ellipse. C ACRIT3 = RTS - 2.0D0*QABS(3) C C The size of the ellipse at point L. C A3 = LABS(1) + LABS(2) - QABS(3) C C Calculate the matrix d W(3,mu)/ d L(mu) = M3(mu,nu). C DO MU = 1,3 DO NU = 1,3 TEMP = DELTA(MU,NU) TEMP1 = (TEMP - LHAT(1,MU)*LHAT(1,NU))/LABS(1) TEMP2 = (TEMP - LHAT(2,MU)*LHAT(2,NU))/LABS(2) M3(MU,NU) = TEMP1 + TEMP2 ENDDO ENDDO C C The "distance" to the collinear line. C D3 = LABS(1)*LABS(2)*WABS(3)/QABS(3) C C The square of the distance its gradient. C DSQ = D3**2 DO NU = 1,3 TEMP = 0.0D0 DO MU = 1,3 TEMP = TEMP + W(3,MU)*M3(MU,NU) ENDDO TEMP = TEMP/WSQ(3) TEMP = TEMP + L(1,NU)/LSQ(1) + L(2,NU)/LSQ(2) GRADDSQ(NU) = 2.0D0*DSQ*TEMP ENDDO C C The function G3 and its derivative. C G3 = 1.0D0/(ACRIT3 + DEFORMGAMMA*A3) DG3DA3 = - DEFORMGAMMA/(ACRIT3 + DEFORMGAMMA*A3)**2 C C Calculate the function C(DSQ) and its derivative. Note that we change C the sign of C in the case of a loop to the right of the cut. C C = SIGN*DEFORMALPHA*DSQ /(1.0D0 + DEFORMBETA*DSQ/QSQ(3)) DLNCDDSQ = 1.0D0/DSQ/(1.0D0 + DEFORMBETA*DSQ/QSQ(3)) C C Calculate the imaginary part of the loop momentum L(mu). C DO MU = 1,3 NEWKINLOOP(MU) = (0.0D0,-1.0D0) * C * G3 * W(3,MU) ENDDO C C Calculate the jacobian. C First, we need the comlex matrix A(mu,nu), the derivative C of ComplexL(mu) with respecdt to L(nu). C DO MU = 1,3 DO NU = 1,3 TERMC = G3*W(3,MU)*DLNCDDSQ*GRADDSQ(NU) TERMG3 = DG3DA3*W(3,MU)*W(3,NU) TERMW3 = G3*M3(MU,NU) TERMS = TERMC + TERMG3 + TERMW3 A(MU,NU) = DELTA(MU,NU) + (0.0D0,-1.0D0) * C * TERMS ENDDO ENDDO C C Finally, the jacobian is the determinant of A C JACDEFORM = A(1,1) * ( A(2,2) * A(3,3) - A(2,3) * A(3,2) ) > + A(1,2) * ( A(2,3) * A(3,1) - A(2,1) * A(3,3) ) > + A(1,3) * ( A(2,1) * A(3,2) - A(2,2) * A(3,1) ) C C End of calculation for Ninloop = 3 for a loop connecting to the C current ( IF(CONNECTSTOCURRENT) ). C ELSE C C Calculation for a three particle loop that does not connect C to the current. C C Calculate Q(j,mu), |L(j)|^2, |Q(j)|^2, |L(j)|, |Q(j)|, hat L(j,mu). C DO MU = 1,3 Q(1,MU) = L(2,MU) - L(3,MU) Q(2,MU) = L(3,MU) - L(1,MU) Q(3,MU) = L(1,MU) - L(2,MU) ENDDO DO J = 1,3 LSQ(J) = 0.0D0 QSQ(J) = 0.0D0 DO MU = 1,3 LSQ(J) = LSQ(J) + L(J,MU)**2 QSQ(J) = QSQ(J) + Q(J,MU)**2 ENDDO QABS(J) = SQRT(QSQ(J)) LABS(J) = SQRT(LSQ(J)) DO MU = 1,3 LHAT(J,MU) = L(J,MU)/LABS(J) ENDDO ENDDO C C The vectors W(j,mu) and their squares and their absolute values. C DO MU = 1,3 W(1,MU) = LHAT(2,MU) + LHAT(3,MU) W(2,MU) = LHAT(3,MU) + LHAT(1,MU) W(3,MU) = LHAT(1,MU) + LHAT(2,MU) ENDDO DO J = 1,3 WSQ(J) = 0.0D0 DO MU = 1,3 WSQ(J) = WSQ(J) + W(J,MU)**2 ENDDO WABS(J) = SQRT(WSQ(J)) ENDDO C C The size of the critical ellipses. C ACRIT2 = RTS - 2.0D0*QABS(2) ACRIT3 = RTS - 2.0D0*QABS(3) C C The sizes of the ellipses at point L. C A2 = LABS(3) + LABS(1) - QABS(2) A3 = LABS(1) + LABS(2) - QABS(3) C C Calculate the matrix d W(j,mu)/ d L(mu) = Mj(mu,nu). C DO MU = 1,3 DO NU = 1,3 TEMP = DELTA(MU,NU) TEMP1 = (TEMP - LHAT(1,MU)*LHAT(1,NU))/LABS(1) TEMP2 = (TEMP - LHAT(2,MU)*LHAT(2,NU))/LABS(2) TEMP3 = (TEMP - LHAT(3,MU)*LHAT(3,NU))/LABS(3) M1(MU,NU) = TEMP2 + TEMP3 M2(MU,NU) = TEMP3 + TEMP1 M3(MU,NU) = TEMP1 + TEMP2 ENDDO ENDDO C C The "distances" to the collinear lines. In this case we do not need D2. C D1 = LABS(2)*LABS(3)*WABS(1)/QABS(1) D3 = LABS(1)*LABS(2)*WABS(3)/QABS(3) C C The square of the smaller of D1 and D3 and its gradient. C IF (D1.LT.D3) THEN C C D1 is the smaller distance. C DSQ = D1**2 DO NU = 1,3 TEMP = 0.0D0 DO MU = 1,3 TEMP = TEMP + W(1,MU)*M1(MU,NU) ENDDO TEMP = TEMP/WSQ(1) TEMP = TEMP + L(2,NU)/LSQ(2) + L(3,NU)/LSQ(3) GRADDSQ(NU) = 2.0D0*DSQ*TEMP ENDDO C ELSE C C D3 is the smaller distance. C DSQ = D3**2 DO NU = 1,3 TEMP = 0.0D0 DO MU = 1,3 TEMP = TEMP + W(3,MU)*M3(MU,NU) ENDDO TEMP = TEMP/WSQ(3) TEMP = TEMP + L(1,NU)/LSQ(1) + L(2,NU)/LSQ(2) GRADDSQ(NU) = 2.0D0*DSQ*TEMP ENDDO C ENDIF C C The function G2 and its derivative. C G2 = 1.0D0/(ACRIT2 + DEFORMGAMMA*A2) DG2DA2 = - DEFORMGAMMA/(ACRIT2 + DEFORMGAMMA*A2)**2 C C Calculate the function C(DSQ) and its derivative. Note that we change C the sign of C in the case of a loop to the right of the cut. C C = SIGN*DEFORMALPHA*DSQ /(1.0D0 + 4.0D0*DEFORMBETA*DSQ/S) DLNCDDSQ = 1.0D0/DSQ/(1.0D0 + 4.0D0*DEFORMBETA*DSQ/S) C C Calculate the imaginary part of the loop momentum L(mu). C DO MU = 1,3 NEWKINLOOP(MU) = (0.0D0,-1.0D0) * C * G2 * W(2,MU) ENDDO C C Calculate the jacobian. C First, we need the comlex matrix A(mu,nu), the derivative C of ComplexL(mu) with respecdt to L(nu). C DO MU = 1,3 DO NU = 1,3 TERMC = G2*W(2,MU)*DLNCDDSQ*GRADDSQ(NU) TERMG2 = DG2DA2*W(2,MU)*W(2,NU) TERMW2 = G2*M2(MU,NU) TERMS = TERMC + TERMG2 + TERMW2 A(MU,NU) = DELTA(MU,NU) + (0.0D0,-1.0D0) * C * TERMS ENDDO ENDDO C C Finally, the jacobian is the determinant of A C JACDEFORM = A(1,1) * ( A(2,2) * A(3,3) - A(2,3) * A(3,2) ) > + A(1,2) * ( A(2,3) * A(3,1) - A(2,1) * A(3,3) ) > + A(1,3) * ( A(2,1) * A(3,2) - A(2,2) * A(3,1) ) C C End of calculation for Ninloop = 3 for a loop not connecting to the C current ( IF(CONNECTSTOCURRENT) ... ELSE ...). C ENDIF C C End of Ninloop = 3 calculation C C Four particles in the loop.------------ C ELSE IF (NINLOOP.EQ.4) THEN C C Calculate Q(j,mu), |L(j)|^2, |Q(j)|^2, |L(j)|, |Q(j)|, hat L(j,mu). C DO MU = 1,3 Q(1,MU) = L(2,MU) - L(3,MU) Q(2,MU) = L(3,MU) - L(1,MU) Q(3,MU) = L(1,MU) - L(2,MU) ENDDO DO J = 1,3 LSQ(J) = 0.0D0 QSQ(J) = 0.0D0 DO MU = 1,3 LSQ(J) = LSQ(J) + L(J,MU)**2 QSQ(J) = QSQ(J) + Q(J,MU)**2 ENDDO QABS(J) = SQRT(QSQ(J)) LABS(J) = SQRT(LSQ(J)) DO MU = 1,3 LHAT(J,MU) = L(J,MU)/LABS(J) ENDDO ENDDO C C The vectors W(j,mu) and their squares and their absolute values. C DO MU = 1,3 W(1,MU) = LHAT(2,MU) + LHAT(3,MU) W(2,MU) = LHAT(3,MU) + LHAT(1,MU) W(3,MU) = LHAT(1,MU) + LHAT(2,MU) ENDDO DO J = 1,3 WSQ(J) = 0.0D0 DO MU = 1,3 WSQ(J) = WSQ(J) + W(J,MU)**2 ENDDO WABS(J) = SQRT(WSQ(J)) ENDDO C C The size of the critical ellipses. C ACRIT2 = RTS - 2.0D0*QABS(2) ACRIT3 = RTS - 2.0D0*QABS(3) C C The sizes of the ellipses at point L. C A2 = LABS(3) + LABS(1) - QABS(2) A3 = LABS(1) + LABS(2) - QABS(3) C C Calculate the matrix d W(j,mu)/ d L(mu) = Mj(mu,nu). C DO MU = 1,3 DO NU = 1,3 TEMP = DELTA(MU,NU) TEMP1 = (TEMP - LHAT(1,MU)*LHAT(1,NU))/LABS(1) TEMP2 = (TEMP - LHAT(2,MU)*LHAT(2,NU))/LABS(2) TEMP3 = (TEMP - LHAT(3,MU)*LHAT(3,NU))/LABS(3) M1(MU,NU) = TEMP2 + TEMP3 M2(MU,NU) = TEMP3 + TEMP1 M3(MU,NU) = TEMP1 + TEMP2 ENDDO ENDDO C C The "distances" to the collinear lines. C D1 = LABS(2)*LABS(3)*WABS(1)/QABS(1) D2 = LABS(3)*LABS(1)*WABS(2)/QABS(2) D3 = LABS(1)*LABS(2)*WABS(3)/QABS(3) C C The square of the smallest distance its gradient. C IF ((D1.LT.D2).AND.(D1.LT.D3)) THEN C C D1 is the smallest distance C DSQ = D1**2 DO NU = 1,3 TEMP = 0.0D0 DO MU = 1,3 TEMP = TEMP + W(1,MU)*M1(MU,NU) ENDDO TEMP = TEMP/WSQ(1) TEMP = TEMP + L(2,NU)/LSQ(2) + L(3,NU)/LSQ(3) GRADDSQ(NU) = 2.0D0*DSQ*TEMP ENDDO C ELSE IF (D2.LT.D3) THEN C C D2 is the smallest distance C DSQ = D2**2 DO NU = 1,3 TEMP = 0.0D0 DO MU = 1,3 TEMP = TEMP + W(2,MU)*M2(MU,NU) ENDDO TEMP = TEMP/WSQ(2) TEMP = TEMP + L(3,NU)/LSQ(3) + L(1,NU)/LSQ(1) GRADDSQ(NU) = 2.0D0*DSQ*TEMP ENDDO C ELSE C C D3 is the smallest distance. C DSQ = D3**2 DO NU = 1,3 TEMP = 0.0D0 DO MU = 1,3 TEMP = TEMP + W(3,MU)*M3(MU,NU) ENDDO TEMP = TEMP/WSQ(3) TEMP = TEMP + L(1,NU)/LSQ(1) + L(2,NU)/LSQ(2) GRADDSQ(NU) = 2.0D0*DSQ*TEMP ENDDO C ENDIF C C The mixing fraction FRACTION and its gradient. C FRACTION = LSQ(3) /(LSQ(2) + LSQ(3)) DO NU = 1,3 TEMP = LSQ(2)*L(3,NU) - LSQ(3)*L(2,NU) GRADF(NU) = 2.0D0*TEMP/(LSQ(2) + LSQ(3))**2 ENDDO C C The functions G2 and G3 and their derivatives. C G2 = 1.0D0/(ACRIT2 + DEFORMGAMMA*A2) G3 = 1.0D0/(ACRIT3 + DEFORMGAMMA*A3) DG2DA2 = - DEFORMGAMMA/(ACRIT2 + DEFORMGAMMA*A2)**2 DG3DA3 = - DEFORMGAMMA/(ACRIT3 + DEFORMGAMMA*A3)**2 C C Calculate the function C(DSQ) and its derivative. Note that we change C the sign of C in the case of a loop to the right of the cut. C C = SIGN*DEFORMALPHA*DSQ /(1.0D0 + 4.0D0*DEFORMBETA*DSQ/S) DLNCDDSQ = 1.0D0/DSQ/(1.0D0 + 4.0D0*DEFORMBETA*DSQ/S) C C Calculate the imaginary part of the loop momentum L(mu). C DO MU = 1,3 NEWKINLOOP(MU) = (0.0D0,-1.0D0) * C > * (FRACTION*G2*W(2,MU) + (1.0D0 - FRACTION)*G3*W(3,MU)) ENDDO C C Calculate the jacobian. C First, we need the comlex matrix A(mu,nu), the derivative C of ComplexL(mu) with respecdt to L(nu). C DO MU = 1,3 DO NU = 1,3 TERMC = FRACTION*G2*W(2,MU) + (1.0D0 - FRACTION)*G3*W(3,MU) TERMC = TERMC * DLNCDDSQ*GRADDSQ(NU) TERMF = ( G2*W(2,MU) - G3*W(3,MU) )*GRADF(NU) TERMG2 = FRACTION *DG2DA2*W(2,MU)*W(2,NU) TERMG3 = (1.0D0 - FRACTION)*DG3DA3*W(3,MU)*W(3,NU) TERMW2 = FRACTION *G2*M2(MU,NU) TERMW3 = (1.0D0 - FRACTION)*G3*M3(MU,NU) TERMS = TERMC + TERMF + TERMG2 + TERMG3 + TERMW2 + TERMW3 A(MU,NU) = DELTA(MU,NU) + (0.0D0,-1.0D0) * C * TERMS ENDDO ENDDO C C Finally, the jacobian is the determinant of A C JACDEFORM = A(1,1) * ( A(2,2) * A(3,3) - A(2,3) * A(3,2) ) > + A(1,2) * ( A(2,3) * A(3,1) - A(2,1) * A(3,3) ) > + A(1,3) * ( A(2,1) * A(3,2) - A(2,2) * A(3,1) ) C C End of Ninloop = 4 calculation C ELSE WRITE(NOUT,*) 'Not programed for NINLOOP > 4 yet.' STOP ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION DELTA(MU,NU) C C In: INTEGER MU,NU C C Kroneker delta. C IF (MU.EQ.NU) THEN DELTA = 1.0D0 ELSE DELTA = 0.0D0 ENDIF RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION SMEAR(RTS) C REAL*8 RTS C C A smearing function that may do a good job of optimizing C the integration accuracy. It satisfies C C Int_0^\infty dE SMEAR(E) = 1 C C We take C C SMEAR(E) = (N-1)!/[M! (N-M-2)!] (A E_0 )**(N-M-1) C * E**M / [E + A * E_0]**N C C where E_0 = ENERGYSCALE = 1. C C REAL*8 SMEARFCTR INTEGER LOWPWR,HIGHPWR COMMON /SMEARPARMS/ SMEARFCTR,LOWPWR,HIGHPWR C REAL*8 ENERGYSCALE PARAMETER (ENERGYSCALE = 1.0D0) REAL*8 FACTORIAL C SMEAR = FACTORIAL(HIGHPWR-1) > /(FACTORIAL(LOWPWR) * FACTORIAL(HIGHPWR-LOWPWR-2)) SMEAR = SMEAR * (SMEARFCTR * ENERGYSCALE)**(HIGHPWR-LOWPWR-1) SMEAR = SMEAR * RTS**LOWPWR > /( RTS + SMEARFCTR*ENERGYSCALE )**HIGHPWR RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C C C Feynman integrand in Feynman gauge C C C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C COMPLEX*16 FUNCTION FEYNMANF(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) C C In: INTEGER SIZE PARAMETER (SIZE = 3) INTEGER GRAPHNUMBER COMPLEX*16 KC(0:3*SIZE-1,0:3) LOGICAL CUT(3*SIZE-1) REAL*8 MUMSBAR CHARACTER*16 FLAG C C Feynman integrand function for graph GRAPHNUMBER C with complex momenta KC and cut specified by CUT. C Early version: 17 July 1994. C This version written by Mathematica code of 4 January 2002 on C 4 Jan 2002. C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF C REAL*8 METRIC(0:3) DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/ COMPLEX*16 GN(0:3) DATA GN /+1.0D0,0.0D0,0.0D0,0.0D0/ C REAL*8 CF COMPLEX*16 COMPLEXSQRT INTEGER MU,NU,TAU COMPLEX*16 X(256) COMPLEX*16 K1(0:3),K2(0:3),K3(0:3),K4(0:3) COMPLEX*16 K5(0:3),K6(0:3),K7(0:3),K8(0:3) COMPLEX*16 E1,E2,E3,E4,E5,E6,E7,E8 COMPLEX*16 K11,K22,K33,K44,K55,K66,K77,K88 COMPLEX*16 TK11,TK22,TK33,TK44,TK55,TK66,TK77,TK88 COMPLEX*16 PREFACTOR CHARACTER*13 KIND2PT2 COMPLEX*16 K2PT2(0:5,0:3) LOGICAL CUT2PT2(1:5) CHARACTER*9 KIND2PT COMPLEX*16 K2PT(0:2,0:3) LOGICAL CUT2PT(0:3) CHARACTER*7 KIND3PT COMPLEX*16 K3PT(3,0:3) LOGICAL CUT3PT(3) C COMPLEX*16 A1QDA4Q,A1QIK6A4QIK7,A1QIK7A4QIK6,EA1QK3Q47 COMPLEX*16 EA1QZV4QK6K7,EA2QK3Q67,EA3QK1Q26,EA4QK1Q86 COMPLEX*16 EA4QZV1QK6K7,EA7AK1IK2K3K4,EA7AK1K2,EA7AK1K3,EA7AK1K4 COMPLEX*16 EA7AK2IK1K3K4,EA7AK2K3,EA7AK2K4,EA7AK3IK1K2K4,EA7AK3K4 COMPLEX*16 EA7AK4IK1K2K3,EA8AK1IK2K3K4,EA8AK1K2,EA8AK1K3,EA8AK1K4 COMPLEX*16 EA8AK2IK1K3K4,EA8AK2K3,EA8AK2K4,EA8AK3IK1K2K4,EA8AK3K4 COMPLEX*16 EA8AK4IK1K2K3,G7AWK1K2,G7AWK1K3,G7AWK2K4,G7AWK3K4,K1K2 COMPLEX*16 K1K3,K1K4,K1Q24,K1Q26,K1Q36,K1Q84,K1Q86,K1QQNB45 COMPLEX*16 K1QQNB46,K1QQNG45,K1QQNG46,K1QQNQ45,K1QQNQ46,K1QQOG57 COMPLEX*16 K1QQOG75,K1QQOQ57,K1QQOQ64,K2K3,K2K4,K2Q24,K2Q36,K2Q84 COMPLEX*16 K2Q86,K3K4,K3Q47,K3Q67,K6K7,Q15Q47,Q24Q86,Q36Q84 COMPLEX*16 TRACEG7A,TRACEV1Q,TRACEV2Q,TRACEV3Q,TRACEV4Q,TRACEV7A COMPLEX*16 TRACEV8A,V1QDV4Q,V1QIK6V4QIK7,V1QIK7V4QIK6,V1QWK3Q47 COMPLEX*16 V1QWQ47K3,V2QWK3Q67,V2QWQ67K3,V3QWK1Q26,V3QWQ26K1 COMPLEX*16 V4QWK1Q86,V4QWQ86K1,V7AWK1K2,V7AWK1K3,V7AWK1K4 COMPLEX*16 V7AWK2K1,V7AWK2K3,V7AWK2K4,V7AWK3K1,V7AWK3K2,V7AWK3K4 COMPLEX*16 V7AWK4K1,V7AWK4K2,V7AWK4K3,V8AWK1K2,V8AWK1K3,V8AWK1K4 COMPLEX*16 V8AWK2K1,V8AWK2K3,V8AWK2K4,V8AWK3K1,V8AWK3K2,V8AWK3K4 COMPLEX*16 V8AWK4K1,V8AWK4K2,V8AWK4K3,A1QIK6(0:3),A1QIK7(0:3) COMPLEX*16 A4QIK6(0:3),A4QIK7(0:3),A7AK1I(0:3),A7AK2I(0:3) COMPLEX*16 A7AK3I(0:3),A7AK4I(0:3),A8AK1I(0:3),A8AK2I(0:3) COMPLEX*16 A8AK3I(0:3),A8AK4I(0:3),Q15(0:3),Q24(0:3),Q26(0:3) COMPLEX*16 Q36(0:3),Q47(0:3),Q67(0:3),Q84(0:3),Q86(0:3) COMPLEX*16 QQNB45(0:3),QQNB46(0:3),QQNG45(0:3),QQNG46(0:3) COMPLEX*16 QQNQ45(0:3),QQNQ46(0:3),QQOG57(0:3),QQOG75(0:3) COMPLEX*16 QQOQ57(0:3),QQOQ64(0:3),V1QIK6(0:3),V1QIK7(0:3) COMPLEX*16 V4QIK6(0:3),V4QIK7(0:3),A1Q(0:3,0:3),A1QZV4Q(0:3,0:3) COMPLEX*16 A2Q(0:3,0:3),A3Q(0:3,0:3),A4Q(0:3,0:3) COMPLEX*16 A4QZV1Q(0:3,0:3),A7A(0:3,0:3),A8A(0:3,0:3) COMPLEX*16 G7A(0:3,0:3),V1Q(0:3,0:3),V2Q(0:3,0:3),V3Q(0:3,0:3) COMPLEX*16 V4Q(0:3,0:3),V7A(0:3,0:3),V8A(0:3,0:3) C DO MU = 0,3 K1(MU) = KC(1,MU) K2(MU) = KC(2,MU) K3(MU) = KC(3,MU) K4(MU) = KC(4,MU) K5(MU) = KC(5,MU) K6(MU) = KC(6,MU) K7(MU) = KC(7,MU) K8(MU) = KC(8,MU) ENDDO CF = (NC**2 - 1.0D0)/2.0D0/NC FEYNMANF = 0.0D0 C C------ C IF (GRAPHNUMBER .EQ. 1) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 ENDDO K11 = E1**2 + TK11 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K4(MU) K2PT2(2,MU) = K5(MU) K2PT2(3,MU) = -K6(MU) K2PT2(4,MU) = K7(MU) K2PT2(5,MU) = K8(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(5) CUT2PT2(3) = CUT(6) CUT2PT2(4) = CUT(7) CUT2PT2(5) = CUT(8) KIND2PT2 = 'NESTED /GQQGQ' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNB46) DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K4(MU) K2PT2(2,MU) = K5(MU) K2PT2(3,MU) = -K6(MU) K2PT2(4,MU) = K7(MU) K2PT2(5,MU) = K8(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(5) CUT2PT2(3) = CUT(6) CUT2PT2(4) = CUT(7) CUT2PT2(5) = CUT(8) KIND2PT2 = 'NESTED /QGGGG' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNG46) DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K4(MU) K2PT2(2,MU) = K5(MU) K2PT2(3,MU) = -K6(MU) K2PT2(4,MU) = K8(MU) K2PT2(5,MU) = K7(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(5) CUT2PT2(3) = CUT(6) CUT2PT2(4) = CUT(8) CUT2PT2(5) = CUT(7) KIND2PT2 = 'NESTED /QGGQQ' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNQ46) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = -K4(MU) K2PT2(2,MU) = K6(MU) K2PT2(3,MU) = -K5(MU) K2PT2(4,MU) = -K7(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(6) CUT2PT2(3) = CUT(5) CUT2PT2(4) = CUT(7) CUT2PT2(5) = CUT(8) KIND2PT2 = 'NESTED /GQQGQ' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNB45) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = -K4(MU) K2PT2(2,MU) = K6(MU) K2PT2(3,MU) = -K5(MU) K2PT2(4,MU) = -K7(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(6) CUT2PT2(3) = CUT(5) CUT2PT2(4) = CUT(7) CUT2PT2(5) = CUT(8) KIND2PT2 = 'NESTED /QGGQQ' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNQ45) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = -K4(MU) K2PT2(2,MU) = K6(MU) K2PT2(3,MU) = -K5(MU) K2PT2(4,MU) = -K8(MU) K2PT2(5,MU) = -K7(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(6) CUT2PT2(3) = CUT(5) CUT2PT2(4) = CUT(8) CUT2PT2(5) = CUT(7) KIND2PT2 = 'NESTED /QGGGG' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNG45) K1QQNB45 = 0.0D0 K1QQNB46 = 0.0D0 K1QQNG45 = 0.0D0 K1QQNG46 = 0.0D0 K1QQNQ45 = 0.0D0 K1QQNQ46 = 0.0D0 DO MU = 0,3 K1QQNB45 = K1QQNB45 + K1(MU)*QQNB45(MU)*METRIC(MU) K1QQNB46 = K1QQNB46 + K1(MU)*QQNB46(MU)*METRIC(MU) K1QQNG45 = K1QQNG45 + K1(MU)*QQNG45(MU)*METRIC(MU) K1QQNG46 = K1QQNG46 + K1(MU)*QQNG46(MU)*METRIC(MU) K1QQNQ45 = K1QQNQ45 + K1(MU)*QQNQ45(MU)*METRIC(MU) K1QQNQ46 = K1QQNQ46 + K1(MU)*QQNQ46(MU)*METRIC(MU) ENDDO FEYNMANF = -8*(K1QQNB45 - K1QQNB46 + K1QQNG45 - K1QQNG46 > + K1QQNQ45 - K1QQNQ46)*NC FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 2) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 ENDDO K11 = E1**2 + TK11 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF DO MU = 0,3 K2PT(0,MU) = K2(MU) K2PT(1,MU) = K4(MU) K2PT(2,MU) = K5(MU) ENDDO CUT2PT(0) = CUT(2) CUT2PT(1) = CUT(4) CUT2PT(2) = CUT(5) CUT2PT(3) = CUT(8) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q24) DO MU = 0,3 K2PT(0,MU) = K3(MU) K2PT(1,MU) = K6(MU) K2PT(2,MU) = K7(MU) ENDDO CUT2PT(0) = CUT(3) CUT2PT(1) = CUT(6) CUT2PT(2) = CUT(7) CUT2PT(3) = CUT(8) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q36) DO MU = 0,3 K2PT(0,MU) = -K8(MU) K2PT(1,MU) = -K4(MU) K2PT(2,MU) = -K5(MU) ENDDO CUT2PT(0) = CUT(8) CUT2PT(1) = CUT(4) CUT2PT(2) = CUT(5) CUT2PT(3) = CUT(2) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q84) DO MU = 0,3 K2PT(0,MU) = K8(MU) K2PT(1,MU) = -K6(MU) K2PT(2,MU) = -K7(MU) ENDDO CUT2PT(0) = CUT(8) CUT2PT(1) = CUT(6) CUT2PT(2) = CUT(7) CUT2PT(3) = CUT(3) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q86) K1K2 = 0.0D0 K1Q24 = 0.0D0 K1Q36 = 0.0D0 K1Q84 = 0.0D0 K1Q86 = 0.0D0 K2Q24 = 0.0D0 K2Q36 = 0.0D0 K2Q84 = 0.0D0 K2Q86 = 0.0D0 Q24Q86 = 0.0D0 Q36Q84 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1Q24 = K1Q24 + K1(MU)*Q24(MU)*METRIC(MU) K1Q36 = K1Q36 + K1(MU)*Q36(MU)*METRIC(MU) K1Q84 = K1Q84 + K1(MU)*Q84(MU)*METRIC(MU) K1Q86 = K1Q86 + K1(MU)*Q86(MU)*METRIC(MU) K2Q24 = K2Q24 + K2(MU)*Q24(MU)*METRIC(MU) K2Q36 = K2Q36 + K2(MU)*Q36(MU)*METRIC(MU) K2Q84 = K2Q84 + K2(MU)*Q84(MU)*METRIC(MU) K2Q86 = K2Q86 + K2(MU)*Q86(MU)*METRIC(MU) Q24Q86 = Q24Q86 + Q24(MU)*Q86(MU)*METRIC(MU) Q36Q84 = Q36Q84 + Q36(MU)*Q84(MU)*METRIC(MU) ENDDO FEYNMANF = 8*NC*(K1Q86*K2Q24 + K1Q84*K2Q36 + K1Q36*K2Q84 > + K1Q24*K2Q86 - K1K2*Q24Q86 - K1K2*Q36Q84) FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 3) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 ENDDO K11 = E1**2 + TK11 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K5(MU) K2PT2(2,MU) = K4(MU) K2PT2(3,MU) = -K7(MU) K2PT2(4,MU) = -K6(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(5) CUT2PT2(2) = CUT(4) CUT2PT2(3) = CUT(7) CUT2PT2(4) = CUT(6) CUT2PT2(5) = CUT(8) KIND2PT2 = 'OVERLAP/QGGQQ' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQOQ57) DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K5(MU) K2PT2(2,MU) = K4(MU) K2PT2(3,MU) = -K7(MU) K2PT2(4,MU) = -K6(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(5) CUT2PT2(2) = CUT(4) CUT2PT2(3) = CUT(7) CUT2PT2(4) = CUT(6) CUT2PT2(5) = CUT(8) KIND2PT2 = 'OVERLAP/QGQGG' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQOG57) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = K6(MU) K2PT2(2,MU) = K7(MU) K2PT2(3,MU) = -K4(MU) K2PT2(4,MU) = -K5(MU) K2PT2(5,MU) = K8(MU) ENDDO CUT2PT2(1) = CUT(6) CUT2PT2(2) = CUT(7) CUT2PT2(3) = CUT(4) CUT2PT2(4) = CUT(5) CUT2PT2(5) = CUT(8) KIND2PT2 = 'OVERLAP/QGGQQ' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQOQ64) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = K7(MU) K2PT2(2,MU) = K6(MU) K2PT2(3,MU) = -K5(MU) K2PT2(4,MU) = -K4(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(7) CUT2PT2(2) = CUT(6) CUT2PT2(3) = CUT(5) CUT2PT2(4) = CUT(4) CUT2PT2(5) = CUT(8) KIND2PT2 = 'OVERLAP/QGQGG' CALL TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQOG75) K1QQOG57 = 0.0D0 K1QQOG75 = 0.0D0 K1QQOQ57 = 0.0D0 K1QQOQ64 = 0.0D0 DO MU = 0,3 K1QQOG57 = K1QQOG57 + K1(MU)*QQOG57(MU)*METRIC(MU) K1QQOG75 = K1QQOG75 + K1(MU)*QQOG75(MU)*METRIC(MU) K1QQOQ57 = K1QQOQ57 + K1(MU)*QQOQ57(MU)*METRIC(MU) K1QQOQ64 = K1QQOQ64 + K1(MU)*QQOQ64(MU)*METRIC(MU) ENDDO FEYNMANF = 8*(K1QQOG57 - K1QQOG75 + K1QQOQ57 - K1QQOQ64)*NC FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 4) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF DO MU = 0,3 K2PT(0,MU) = K5(MU) K2PT(1,MU) = K7(MU) K2PT(2,MU) = K8(MU) ENDDO CUT2PT(0) = CUT(5) CUT2PT(1) = CUT(7) CUT2PT(2) = CUT(8) CUT2PT(3) = CUT(6) KIND2PT = 'BOTHLOOPS' CALL TWOPOINTGF(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,G7A) TRACEG7A = 0.0D0 DO MU = 0,3 TRACEG7A = TRACEG7A + G7A(MU,MU)*METRIC(MU) ENDDO G7AWK1K2 = 0.0D0 G7AWK1K3 = 0.0D0 G7AWK2K4 = 0.0D0 G7AWK3K4 = 0.0D0 DO MU = 0,3 DO NU = 0,3 G7AWK1K2 = G7AWK1K2 > + G7A(MU,NU)*K1(MU)*K2(NU)*METRIC(MU)*METRIC(NU) G7AWK1K3 = G7AWK1K3 > + G7A(MU,NU)*K1(MU)*K3(NU)*METRIC(MU)*METRIC(NU) G7AWK2K4 = G7AWK2K4 > + G7A(MU,NU)*K2(MU)*K4(NU)*METRIC(MU)*METRIC(NU) G7AWK3K4 = G7AWK3K4 > + G7A(MU,NU)*K3(MU)*K4(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO K1K2 = 0.0D0 K1K3 = 0.0D0 K1K4 = 0.0D0 K2K3 = 0.0D0 K2K4 = 0.0D0 K3K4 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1K3 = K1K3 + K1(MU)*K3(MU)*METRIC(MU) K1K4 = K1K4 + K1(MU)*K4(MU)*METRIC(MU) K2K3 = K2K3 + K2(MU)*K3(MU)*METRIC(MU) K2K4 = K2K4 + K2(MU)*K4(MU)*METRIC(MU) K3K4 = K3K4 + K3(MU)*K4(MU)*METRIC(MU) ENDDO FEYNMANF = -8*CF*NC*(2*G7AWK3K4*K1K2 - 2*G7AWK2K4*K1K3 > - 2*G7AWK1K3*K2K4 + 2*G7AWK1K2*K3K4 + K1K4*K2K3*TRACEG7A > + K1K3*K2K4*TRACEG7A - K1K2*K3K4*TRACEG7A) FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 5) THEN C PREFACTOR = 1.0D0 E3 = K3(0) TK33 = 0.0D0 DO MU = 1,3 TK33 = TK33 - K3(MU)**2 ENDDO K33 = E3**2 + TK33 IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF DO MU = 0,3 K3PT(1,MU) = -K1(MU) K3PT(2,MU) = K2(MU) K3PT(3,MU) = -K5(MU) ENDDO CUT3PT(1) = CUT(1) CUT3PT(2) = CUT(2) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V1Q,A1Q) DO MU = 0,3 K3PT(1,MU) = -K2(MU) K3PT(2,MU) = K1(MU) K3PT(3,MU) = K5(MU) ENDDO CUT3PT(1) = CUT(2) CUT3PT(2) = CUT(1) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V2Q,A2Q) DO MU = 0,3 K2PT(0,MU) = K4(MU) K2PT(1,MU) = K7(MU) K2PT(2,MU) = K8(MU) ENDDO CUT2PT(0) = CUT(4) CUT2PT(1) = CUT(7) CUT2PT(2) = CUT(8) CUT2PT(3) = CUT(6) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q47) DO MU = 0,3 K2PT(0,MU) = K6(MU) K2PT(1,MU) = -K7(MU) K2PT(2,MU) = -K8(MU) ENDDO CUT2PT(0) = CUT(6) CUT2PT(1) = CUT(7) CUT2PT(2) = CUT(8) CUT2PT(3) = CUT(4) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q67) TRACEV1Q = 0.0D0 TRACEV2Q = 0.0D0 DO MU = 0,3 TRACEV1Q = TRACEV1Q + V1Q(MU,MU)*METRIC(MU) TRACEV2Q = TRACEV2Q + V2Q(MU,MU)*METRIC(MU) ENDDO V1QWK3Q47 = 0.0D0 V1QWQ47K3 = 0.0D0 V2QWK3Q67 = 0.0D0 V2QWQ67K3 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V1QWK3Q47 = V1QWK3Q47 > + V1Q(MU,NU)*K3(MU)*Q47(NU)*METRIC(MU)*METRIC(NU) V1QWQ47K3 = V1QWQ47K3 > + V1Q(MU,NU)*Q47(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V2QWK3Q67 = V2QWK3Q67 > + V2Q(MU,NU)*K3(MU)*Q67(NU)*METRIC(MU)*METRIC(NU) V2QWQ67K3 = V2QWQ67K3 > + V2Q(MU,NU)*Q67(MU)*K3(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO K3Q47 = 0.0D0 K3Q67 = 0.0D0 DO MU = 0,3 K3Q47 = K3Q47 + K3(MU)*Q47(MU)*METRIC(MU) K3Q67 = K3Q67 + K3(MU)*Q67(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A1Q,K3,Q47,EA1QK3Q47) CALL EPSILONT2(A2Q,K3,Q67,EA2QK3Q67) FEYNMANF = -4*NC*(EA1QK3Q47 + EA2QK3Q67 - K3Q47*TRACEV1Q > + K3Q67*TRACEV2Q + V1QWK3Q47 + V1QWQ47K3 - V2QWK3Q67 - V2QWQ67K3) FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 6) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 ENDDO K11 = E1**2 + TK11 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF DO MU = 0,3 K3PT(1,MU) = -K3(MU) K3PT(2,MU) = K4(MU) K3PT(3,MU) = -K5(MU) ENDDO CUT3PT(1) = CUT(3) CUT3PT(2) = CUT(4) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V3Q,A3Q) DO MU = 0,3 K3PT(1,MU) = -K4(MU) K3PT(2,MU) = K3(MU) K3PT(3,MU) = K5(MU) ENDDO CUT3PT(1) = CUT(4) CUT3PT(2) = CUT(3) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V4Q,A4Q) DO MU = 0,3 K2PT(0,MU) = K2(MU) K2PT(1,MU) = K6(MU) K2PT(2,MU) = K7(MU) ENDDO CUT2PT(0) = CUT(2) CUT2PT(1) = CUT(6) CUT2PT(2) = CUT(7) CUT2PT(3) = CUT(8) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q26) DO MU = 0,3 K2PT(0,MU) = K8(MU) K2PT(1,MU) = -K6(MU) K2PT(2,MU) = -K7(MU) ENDDO CUT2PT(0) = CUT(8) CUT2PT(1) = CUT(6) CUT2PT(2) = CUT(7) CUT2PT(3) = CUT(2) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q86) TRACEV3Q = 0.0D0 TRACEV4Q = 0.0D0 DO MU = 0,3 TRACEV3Q = TRACEV3Q + V3Q(MU,MU)*METRIC(MU) TRACEV4Q = TRACEV4Q + V4Q(MU,MU)*METRIC(MU) ENDDO V3QWK1Q26 = 0.0D0 V3QWQ26K1 = 0.0D0 V4QWK1Q86 = 0.0D0 V4QWQ86K1 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V3QWK1Q26 = V3QWK1Q26 > + V3Q(MU,NU)*K1(MU)*Q26(NU)*METRIC(MU)*METRIC(NU) V3QWQ26K1 = V3QWQ26K1 > + V3Q(MU,NU)*Q26(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4QWK1Q86 = V4QWK1Q86 > + V4Q(MU,NU)*K1(MU)*Q86(NU)*METRIC(MU)*METRIC(NU) V4QWQ86K1 = V4QWQ86K1 > + V4Q(MU,NU)*Q86(MU)*K1(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO K1Q26 = 0.0D0 K1Q86 = 0.0D0 DO MU = 0,3 K1Q26 = K1Q26 + K1(MU)*Q26(MU)*METRIC(MU) K1Q86 = K1Q86 + K1(MU)*Q86(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A3Q,K1,Q26,EA3QK1Q26) CALL EPSILONT2(A4Q,K1,Q86,EA4QK1Q86) FEYNMANF = -4*NC*(EA3QK1Q26 + EA4QK1Q86 - K1Q26*TRACEV3Q > + K1Q86*TRACEV4Q + V3QWK1Q26 + V3QWQ26K1 - V4QWK1Q86 - V4QWQ86K1) FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 7) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 E5 = K5(0) TK55 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 TK55 = TK55 - K5(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 K55 = E5**2 + TK55 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF IF (CUT(5)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55) ELSE PREFACTOR = PREFACTOR/K55 ENDIF DO MU = 0,3 K3PT(1,MU) = K7(MU) K3PT(2,MU) = -K8(MU) K3PT(3,MU) = -K6(MU) ENDDO CUT3PT(1) = CUT(7) CUT3PT(2) = CUT(8) CUT3PT(3) = CUT(6) KIND3PT = 'QQG/ALL' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V7A,A7A) DO MU = 0,3 K3PT(1,MU) = K8(MU) K3PT(2,MU) = -K7(MU) K3PT(3,MU) = K6(MU) ENDDO CUT3PT(1) = CUT(8) CUT3PT(2) = CUT(7) CUT3PT(3) = CUT(6) KIND3PT = 'QQG/ALL' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V8A,A8A) TRACEV7A = 0.0D0 TRACEV8A = 0.0D0 DO MU = 0,3 TRACEV7A = TRACEV7A + V7A(MU,MU)*METRIC(MU) TRACEV8A = TRACEV8A + V8A(MU,MU)*METRIC(MU) ENDDO V7AWK1K2 = 0.0D0 V7AWK1K3 = 0.0D0 V7AWK1K4 = 0.0D0 V7AWK2K1 = 0.0D0 V7AWK2K3 = 0.0D0 V7AWK2K4 = 0.0D0 V7AWK3K1 = 0.0D0 V7AWK3K2 = 0.0D0 V7AWK3K4 = 0.0D0 V7AWK4K1 = 0.0D0 V7AWK4K2 = 0.0D0 V7AWK4K3 = 0.0D0 V8AWK1K2 = 0.0D0 V8AWK1K3 = 0.0D0 V8AWK1K4 = 0.0D0 V8AWK2K1 = 0.0D0 V8AWK2K3 = 0.0D0 V8AWK2K4 = 0.0D0 V8AWK3K1 = 0.0D0 V8AWK3K2 = 0.0D0 V8AWK3K4 = 0.0D0 V8AWK4K1 = 0.0D0 V8AWK4K2 = 0.0D0 V8AWK4K3 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V7AWK1K2 = V7AWK1K2 > + V7A(MU,NU)*K1(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V7AWK1K3 = V7AWK1K3 > + V7A(MU,NU)*K1(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V7AWK1K4 = V7AWK1K4 > + V7A(MU,NU)*K1(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V7AWK2K1 = V7AWK2K1 > + V7A(MU,NU)*K2(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V7AWK2K3 = V7AWK2K3 > + V7A(MU,NU)*K2(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V7AWK2K4 = V7AWK2K4 > + V7A(MU,NU)*K2(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V7AWK3K1 = V7AWK3K1 > + V7A(MU,NU)*K3(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V7AWK3K2 = V7AWK3K2 > + V7A(MU,NU)*K3(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V7AWK3K4 = V7AWK3K4 > + V7A(MU,NU)*K3(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V7AWK4K1 = V7AWK4K1 > + V7A(MU,NU)*K4(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V7AWK4K2 = V7AWK4K2 > + V7A(MU,NU)*K4(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V7AWK4K3 = V7AWK4K3 > + V7A(MU,NU)*K4(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V8AWK1K2 = V8AWK1K2 > + V8A(MU,NU)*K1(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V8AWK1K3 = V8AWK1K3 > + V8A(MU,NU)*K1(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V8AWK1K4 = V8AWK1K4 > + V8A(MU,NU)*K1(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V8AWK2K1 = V8AWK2K1 > + V8A(MU,NU)*K2(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V8AWK2K3 = V8AWK2K3 > + V8A(MU,NU)*K2(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V8AWK2K4 = V8AWK2K4 > + V8A(MU,NU)*K2(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V8AWK3K1 = V8AWK3K1 > + V8A(MU,NU)*K3(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V8AWK3K2 = V8AWK3K2 > + V8A(MU,NU)*K3(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V8AWK3K4 = V8AWK3K4 > + V8A(MU,NU)*K3(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V8AWK4K1 = V8AWK4K1 > + V8A(MU,NU)*K4(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V8AWK4K2 = V8AWK4K2 > + V8A(MU,NU)*K4(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V8AWK4K3 = V8AWK4K3 > + V8A(MU,NU)*K4(MU)*K3(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 A7AK1I(MU) = 0.0D0 A7AK2I(MU) = 0.0D0 A7AK3I(MU) = 0.0D0 A7AK4I(MU) = 0.0D0 A8AK1I(MU) = 0.0D0 A8AK2I(MU) = 0.0D0 A8AK3I(MU) = 0.0D0 A8AK4I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 A7AK1I(MU) = A7AK1I(MU) + A7A(NU,MU)*K1(NU)*METRIC(NU) A7AK2I(MU) = A7AK2I(MU) + A7A(NU,MU)*K2(NU)*METRIC(NU) A7AK3I(MU) = A7AK3I(MU) + A7A(NU,MU)*K3(NU)*METRIC(NU) A7AK4I(MU) = A7AK4I(MU) + A7A(NU,MU)*K4(NU)*METRIC(NU) A8AK1I(MU) = A8AK1I(MU) + A8A(NU,MU)*K1(NU)*METRIC(NU) A8AK2I(MU) = A8AK2I(MU) + A8A(NU,MU)*K2(NU)*METRIC(NU) A8AK3I(MU) = A8AK3I(MU) + A8A(NU,MU)*K3(NU)*METRIC(NU) A8AK4I(MU) = A8AK4I(MU) + A8A(NU,MU)*K4(NU)*METRIC(NU) ENDDO ENDDO K1K2 = 0.0D0 K1K3 = 0.0D0 K1K4 = 0.0D0 K2K3 = 0.0D0 K2K4 = 0.0D0 K3K4 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1K3 = K1K3 + K1(MU)*K3(MU)*METRIC(MU) K1K4 = K1K4 + K1(MU)*K4(MU)*METRIC(MU) K2K3 = K2K3 + K2(MU)*K3(MU)*METRIC(MU) K2K4 = K2K4 + K2(MU)*K4(MU)*METRIC(MU) K3K4 = K3K4 + K3(MU)*K4(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A7A,K1,K2,EA7AK1K2) CALL EPSILONT2(A7A,K1,K3,EA7AK1K3) CALL EPSILONT2(A7A,K1,K4,EA7AK1K4) CALL EPSILONT2(A7A,K2,K3,EA7AK2K3) CALL EPSILONT2(A7A,K2,K4,EA7AK2K4) CALL EPSILONT2(A7A,K3,K4,EA7AK3K4) CALL EPSILONT2(A8A,K1,K2,EA8AK1K2) CALL EPSILONT2(A8A,K1,K3,EA8AK1K3) CALL EPSILONT2(A8A,K1,K4,EA8AK1K4) CALL EPSILONT2(A8A,K2,K3,EA8AK2K3) CALL EPSILONT2(A8A,K2,K4,EA8AK2K4) CALL EPSILONT2(A8A,K3,K4,EA8AK3K4) CALL EPSILON4(A7AK1I,K2,K3,K4,EA7AK1IK2K3K4) CALL EPSILON4(A7AK2I,K1,K3,K4,EA7AK2IK1K3K4) CALL EPSILON4(A7AK3I,K1,K2,K4,EA7AK3IK1K2K4) CALL EPSILON4(A7AK4I,K1,K2,K3,EA7AK4IK1K2K3) CALL EPSILON4(A8AK1I,K2,K3,K4,EA8AK1IK2K3K4) CALL EPSILON4(A8AK2I,K1,K3,K4,EA8AK2IK1K3K4) CALL EPSILON4(A8AK3I,K1,K2,K4,EA8AK3IK1K2K4) CALL EPSILON4(A8AK4I,K1,K2,K3,EA8AK4IK1K2K3) X(1) = EA7AK1IK2K3K4 + EA7AK2IK1K3K4 - EA7AK3IK1K2K4 > - EA7AK4IK1K2K3 - EA8AK1IK2K3K4 - EA8AK2IK1K3K4 + EA8AK3IK1K2K4 > + EA8AK4IK1K2K3 X(2) = EA7AK3K4 - EA8AK3K4 + V7AWK3K4 + V7AWK4K3 + V8AWK3K4 > + V8AWK4K3 X(3) = X(1) + K1K2*X(2) X(4) = -EA7AK2K4 + EA8AK2K4 - V7AWK2K4 - V7AWK4K2 - V8AWK2K4 > - V8AWK4K2 X(5) = X(3) + K1K3*X(4) X(6) = -EA7AK2K3 + EA8AK2K3 - V7AWK2K3 + V7AWK3K2 - V8AWK2K3 > + V8AWK3K2 X(7) = X(5) + K1K4*X(6) X(8) = -EA7AK1K4 + EA8AK1K4 + K1K4*(TRACEV7A + TRACEV8A) > + V7AWK1K4 - V7AWK4K1 + V8AWK1K4 - V8AWK4K1 X(9) = X(7) + K2K3*X(8) X(10) = EA7AK1K3 - EA8AK1K3 + K1K3*(TRACEV7A + TRACEV8A) > - V7AWK1K3 - V7AWK3K1 - V8AWK1K3 - V8AWK3K1 X(11) = X(9) + K2K4*X(10) X(12) = -EA7AK1K2 + EA8AK1K2 + K1K2*(-TRACEV7A - TRACEV8A) > + V7AWK1K2 + V7AWK2K1 + V8AWK1K2 + V8AWK2K1 X(13) = X(11) + K3K4*X(12) FEYNMANF = 8*CF*NC*X(13) FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 8) THEN C PREFACTOR = 1.0D0 E6 = K6(0) TK66 = 0.0D0 E7 = K7(0) TK77 = 0.0D0 DO MU = 1,3 TK66 = TK66 - K6(MU)**2 TK77 = TK77 - K7(MU)**2 ENDDO K66 = E6**2 + TK66 K77 = E7**2 + TK77 IF (CUT(6)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK66) ELSE PREFACTOR = PREFACTOR/K66 ENDIF IF (CUT(7)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK77) ELSE PREFACTOR = PREFACTOR/K77 ENDIF DO MU = 0,3 K3PT(1,MU) = -K1(MU) K3PT(2,MU) = K2(MU) K3PT(3,MU) = -K5(MU) ENDDO CUT3PT(1) = CUT(1) CUT3PT(2) = CUT(2) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V1Q,A1Q) DO MU = 0,3 K3PT(1,MU) = -K4(MU) K3PT(2,MU) = K3(MU) K3PT(3,MU) = K8(MU) ENDDO CUT3PT(1) = CUT(4) CUT3PT(2) = CUT(3) CUT3PT(3) = CUT(8) KIND3PT = 'QQP/QQG' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V4Q,A4Q) A1QDA4Q = 0.0D0 V1QDV4Q = 0.0D0 DO MU = 0,3 DO NU = 0,3 A1QDA4Q = A1QDA4Q + A1Q(MU,NU)*A4Q(MU,NU)*METRIC(MU)*METRIC(NU) V1QDV4Q = V1QDV4Q + V1Q(MU,NU)*V4Q(MU,NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 A1QIK6(MU) = 0.0D0 A1QIK7(MU) = 0.0D0 A4QIK6(MU) = 0.0D0 A4QIK7(MU) = 0.0D0 V1QIK6(MU) = 0.0D0 V1QIK7(MU) = 0.0D0 V4QIK6(MU) = 0.0D0 V4QIK7(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 A1QIK6(MU) = A1QIK6(MU) + A1Q(MU,NU)*K6(NU)*METRIC(NU) A1QIK7(MU) = A1QIK7(MU) + A1Q(MU,NU)*K7(NU)*METRIC(NU) A4QIK6(MU) = A4QIK6(MU) + A4Q(MU,NU)*K6(NU)*METRIC(NU) A4QIK7(MU) = A4QIK7(MU) + A4Q(MU,NU)*K7(NU)*METRIC(NU) V1QIK6(MU) = V1QIK6(MU) + V1Q(MU,NU)*K6(NU)*METRIC(NU) V1QIK7(MU) = V1QIK7(MU) + V1Q(MU,NU)*K7(NU)*METRIC(NU) V4QIK6(MU) = V4QIK6(MU) + V4Q(MU,NU)*K6(NU)*METRIC(NU) V4QIK7(MU) = V4QIK7(MU) + V4Q(MU,NU)*K7(NU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 DO NU = 0,3 A1QZV4Q(MU,NU) = 0.0D0 A4QZV1Q(MU,NU) = 0.0D0 ENDDO ENDDO DO MU = 0,3 DO NU = 0,3 DO TAU = 0,3 A1QZV4Q(MU,NU) = A1QZV4Q(MU,NU) > + A1Q(TAU,MU)*V4Q(TAU,NU)*METRIC(TAU) A4QZV1Q(MU,NU) = A4QZV1Q(MU,NU) > + A4Q(TAU,MU)*V1Q(TAU,NU)*METRIC(TAU) ENDDO ENDDO ENDDO A1QIK6A4QIK7 = 0.0D0 A1QIK7A4QIK6 = 0.0D0 K6K7 = 0.0D0 V1QIK6V4QIK7 = 0.0D0 V1QIK7V4QIK6 = 0.0D0 DO MU = 0,3 A1QIK6A4QIK7 = A1QIK6A4QIK7 + A1QIK6(MU)*A4QIK7(MU)*METRIC(MU) A1QIK7A4QIK6 = A1QIK7A4QIK6 + A1QIK7(MU)*A4QIK6(MU)*METRIC(MU) K6K7 = K6K7 + K6(MU)*K7(MU)*METRIC(MU) V1QIK6V4QIK7 = V1QIK6V4QIK7 + V1QIK6(MU)*V4QIK7(MU)*METRIC(MU) V1QIK7V4QIK6 = V1QIK7V4QIK6 + V1QIK7(MU)*V4QIK6(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A1QZV4Q,K6,K7,EA1QZV4QK6K7) CALL EPSILONT2(A4QZV1Q,K6,K7,EA4QZV1QK6K7) FEYNMANF = 4*NC*(A1QIK6A4QIK7 + A1QIK7A4QIK6 + EA1QZV4QK6K7 > - EA4QZV1QK6K7 - A1QDA4Q*K6K7 + K6K7*V1QDV4Q - V1QIK6V4QIK7 > - V1QIK7V4QIK6) FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 9) THEN C PREFACTOR = 1.0D0 DO MU = 0,3 K2PT(0,MU) = K1(MU) K2PT(1,MU) = K5(MU) K2PT(2,MU) = K6(MU) ENDDO CUT2PT(0) = CUT(1) CUT2PT(1) = CUT(5) CUT2PT(2) = CUT(6) CUT2PT(3) = CUT(3) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q15) DO MU = 0,3 K2PT(0,MU) = K4(MU) K2PT(1,MU) = -K7(MU) K2PT(2,MU) = -K8(MU) ENDDO CUT2PT(0) = CUT(4) CUT2PT(1) = CUT(7) CUT2PT(2) = CUT(8) CUT2PT(3) = CUT(2) CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,Q47) Q15Q47 = 0.0D0 DO MU = 0,3 Q15Q47 = Q15Q47 + Q15(MU)*Q47(MU)*METRIC(MU) ENDDO FEYNMANF = -8*NC*Q15Q47 FEYNMANF = FEYNMANF*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 10) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 E5 = K5(0) TK55 = 0.0D0 E6 = K6(0) TK66 = 0.0D0 E7 = K7(0) TK77 = 0.0D0 E8 = K8(0) TK88 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 TK55 = TK55 - K5(MU)**2 TK66 = TK66 - K6(MU)**2 TK77 = TK77 - K7(MU)**2 TK88 = TK88 - K8(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 K55 = E5**2 + TK55 K66 = E6**2 + TK66 K77 = E7**2 + TK77 K88 = E8**2 + TK88 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF IF (CUT(5)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55) ELSE PREFACTOR = PREFACTOR/K55 ENDIF IF (CUT(6)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK66) ELSE PREFACTOR = PREFACTOR/K66 ENDIF IF (CUT(7)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK77) ELSE PREFACTOR = PREFACTOR/K77 ENDIF IF (CUT(8)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK88) ELSE PREFACTOR = PREFACTOR/K88 ENDIF K1K3 = 0.0D0 K2K4 = 0.0D0 K6K7 = 0.0D0 DO MU = 0,3 K1K3 = K1K3 + K1(MU)*K3(MU)*METRIC(MU) K2K4 = K2K4 + K2(MU)*K4(MU)*METRIC(MU) K6K7 = K6K7 + K6(MU)*K7(MU)*METRIC(MU) ENDDO FEYNMANF = -64*CF*K1K3*K2K4*K6K7 FEYNMANF = FEYNMANF*PREFACTOR C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C C C Feynman integrand in Feynman gauge, Born level C C C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C COMPLEX*16 FUNCTION FEYNMAN0F(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) C C In: INTEGER SIZE PARAMETER (SIZE = 3) INTEGER GRAPHNUMBER COMPLEX*16 KC(0:3*SIZE-1,0:3) LOGICAL CUT(3*SIZE-1) REAL*8 MUMSBAR CHARACTER*16 FLAG C C Feynman integrand function for graph GRAPHNUMBER C with complex momenta KC and cut specified by CUT. C Early version: 17 July 1994. C This version written by Mathematica code of 7 February 2002 on C 8 Feb 2002. C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF C REAL*8 METRIC(0:3) DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/ REAL*8 GN(0:3) DATA GN /+1.0D0,0.0D0,0.0D0,0.0D0/ C REAL*8 CF COMPLEX*16 COMPLEXSQRT INTEGER MU COMPLEX*16 K1(0:3),K2(0:3),K3(0:3),K4(0:3),K5(0:3) COMPLEX*16 E1,E2,E3,E4,E5 COMPLEX*16 K11,K22,K33,K44,K55 COMPLEX*16 TK11,TK22,TK33,TK44,TK55 COMPLEX*16 PREFACTOR C COMPLEX*16 K1K2,K1K4,K1K5,K2K3,K2K5 C DO MU = 0,3 K1(MU) = KC(1,MU) K2(MU) = KC(2,MU) K3(MU) = KC(3,MU) K4(MU) = KC(4,MU) K5(MU) = KC(5,MU) ENDDO CF = (NC**2 - 1.0D0)/2.0D0/NC FEYNMAN0F = 0.0D0 C C------ C IF (GRAPHNUMBER .EQ. 11) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 E5 = K5(0) TK55 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 TK55 = TK55 - K5(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 K55 = E5**2 + TK55 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF IF (CUT(5)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55) ELSE PREFACTOR = PREFACTOR/K55 ENDIF K1K2 = 0.0D0 K1K5 = 0.0D0 K2K5 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1K5 = K1K5 + K1(MU)*K5(MU)*METRIC(MU) K2K5 = K2K5 + K2(MU)*K5(MU)*METRIC(MU) ENDDO FEYNMAN0F = -32*CF*(K1K5*K22 - 2*K1K2*K2K5)*NC FEYNMAN0F = FEYNMAN0F*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 12) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 E5 = K5(0) TK55 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 TK55 = TK55 - K5(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 K55 = E5**2 + TK55 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF IF (CUT(5)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55) ELSE PREFACTOR = PREFACTOR/K55 ENDIF K1K4 = 0.0D0 K2K3 = 0.0D0 DO MU = 0,3 K1K4 = K1K4 + K1(MU)*K4(MU)*METRIC(MU) K2K3 = K2K3 + K2(MU)*K3(MU)*METRIC(MU) ENDDO FEYNMAN0F = 32*CF*K1K4*K2K3*NC FEYNMAN0F = FEYNMAN0F*PREFACTOR C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C C C Vertex and propagator functions in Feynman gauge C C C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE TWOPOINTGF(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUT) C In: CHARACTER*9 KIND2PT COMPLEX*16 K2PT(0:2,0:3) LOGICAL CUT2PT(0:3) REAL*8 MUMSBAR CHARACTER*16 FLAG C Out: COMPLEX*16 OUT(0:3,0:3) C C Calculates the one loop gluon two-point function, including the C adjoining propagators *in Feynman gauge* with the modification that C it is multiplied by a Coulomb gauge projection matrix on the left C and on the right. C C kind2pt: C GLUONLOOP gluon self-energy with a gluon (including ghost) loop C QUARKLOOP gluon self-energy with a quark loop C BOTHLOOPS the sum of these C C k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part) C k2pt(1,mu): 1st momentum in loop (kplus for the space part) C k2pt(2,mu): 2nd momentum in loop (kminus for the space part) C C cut2pt(0): whether incoming line is cut C cut2pt(1): whether 1st internal line is cut C cut2pt(2): whether 2nd internal line is cut C cut2pt(3): whether outgoing line is cut C C mumsbar is the MSbar renormalization scale. C C The result is the two point function out(mu,nu) with a certain C normalization. Specifically, for the cut gluon self-energy C graph, out(mu,nu) is {\cal M}_g^{\mu\nu} C divided by (\alpha_s/(4\pi)) * 1/(1+\Delta) and divided C by 2\omega_+ * 2\omega_- *\bar q^2. The factor by which we divide C consists of C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and C one (2\pi)^{-3} for each loop that is factored out of each C graph in our program. C * (d\vec l)/(d\bar q^2 dx d\phi) C = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) C * 4 \pi {\cal Q} \bar q^2 included in the relation between C {\cal I}[real] and {\cal M}_g^{\mu\nu} C C In the case of the virtual gluon self-energy graphs C with an adjacent propagator cut, out(mu,nu) is {\cal W}_g^{\mu\nu} C divided by the same factors. C C 16 December 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF INTEGER MU,NU COMPLEX*16 COMPLEXSQRT COMPLEX*16 KPLUS(1:3),KMINUS(1:3),ELL(1:3),Q(1:3) COMPLEX*16 CALQSQ, OMEGAPLUSSQ,OMEGAMINUSSQ COMPLEX*16 CALQ,OMEGAPLUS,OMEGAMINUS,Q0 COMPLEX*16 DELTAP1,DELTA,TWOXM1,X1MX,QBARSQ COMPLEX*16 ELLT(1:3) COMPLEX*16 ELLTSQ,ONEM2X1MX COMPLEX*16 TEMP COMPLEX*16 BAREPROP(1:3,1:3) COMPLEX*16 NTT,NLL,NEE,NEL COMPLEX*16 PREFACTOR COMPLEX*16 TERMTT,TERMLL COMPLEX*16 AT0 COMPLEX*16 NTT0 COMPLEX*16 NET0 COMPLEX*16 UTT,NET C C Some auxilliary variables, including C CALQ = {\cal Q} C OMEGAPLUS = \omega_+ C OMEGAMINUS = \omega_- C DELTAP1 = \Delta + 1 C TWOXM1 = 2 x - 1 C X1MX = x (1-x) C ELLT(mu) = l_T^\mu C ELLTSQ = (\vec l_T)^2 C Q(mu) = the incoming *three*-momentum C Q0 = the incoming energy C DO MU = 1,3 KPLUS(MU) = K2PT(1,MU) KMINUS(MU) = K2PT(2,MU) ELL(MU) = (KPLUS(MU) - KMINUS(MU))/2.0D0 Q(MU) = K2PT(0,MU) ENDDO Q0 = K2PT(0,0) CALQSQ = 0.0D0 OMEGAPLUSSQ = 0.0D0 OMEGAMINUSSQ = 0.0D0 DO MU = 1,3 CALQSQ = CALQSQ + Q(MU)**2 OMEGAPLUSSQ = OMEGAPLUSSQ + KPLUS(MU)**2 OMEGAMINUSSQ = OMEGAMINUSSQ + KMINUS(MU)**2 ENDDO CALQ = COMPLEXSQRT(CALQSQ) OMEGAPLUS = COMPLEXSQRT(OMEGAPLUSSQ) OMEGAMINUS = COMPLEXSQRT(OMEGAMINUSSQ) DELTAP1 = (OMEGAPLUS + OMEGAMINUS)/CALQ DELTA = DELTAP1 - 1.0D0 TWOXM1 = (OMEGAPLUS - OMEGAMINUS)/CALQ X1MX = (1.0D0 - TWOXM1**2)/4.0D0 QBARSQ = CALQSQ * DELTA * (DELTA + 2.0D0) DO MU = 1,3 ELLT(MU) = ELL(MU) - 0.5D0*DELTAP1*TWOXM1*Q(MU) ENDDO ELLTSQ = QBARSQ*X1MX ONEM2X1MX = 1.0D0 - 2.0D0*X1MX C C The gluon propagator in Coulomb gauge for an on-shell gluon C with three-momentum Q(mu). This is the space components only. C DO MU = 1,3 BAREPROP(MU,MU) = 1.0D0 - Q(MU)**2/CALQSQ DO NU = MU+1,3 TEMP = - Q(MU)*Q(NU)/CALQSQ BAREPROP(MU,NU) = TEMP BAREPROP(NU,MU) = TEMP ENDDO ENDDO C IF (CUT2PT(1).AND.CUT2PT(2)) THEN C C We have the contribution from a cut self-energy diagram. C We compute the coefficients for, alternatively, the gluon loop C or the quark loop. We use the name NLL for Ntt and NEL for NEt. C IF (KIND2PT.EQ.'GLUONLOOP') THEN C NTT = 2.0D0*NC*( - 1.0D0 + X1MX) NLL = 4.0D0*NC*X1MX NEE = - NC*(1.0D0 + 4.0D0*X1MX) NEL = - 2.0D0*NC*TWOXM1 C ELSE IF (KIND2PT.EQ.'QUARKLOOP') THEN C NTT = NF*ONEM2X1MX NLL = - 4.0D0*NF*X1MX NEE = 4.0D0*NF*X1MX NEL = 2.0D0*NF*TWOXM1 C ELSE IF (KIND2PT.EQ.'BOTHLOOPS') THEN C NTT = 2.0D0*NC*( - 1.0D0 + X1MX) NLL = 4.0D0*NC*X1MX NEE = - NC*(1.0D0 + 4.0D0*X1MX) NEL = - 2.0D0*NC*TWOXM1 C NTT = NTT + NF*ONEM2X1MX NLL = NLL - 4.0D0*NF*X1MX NEE = NEE + 4.0D0*NF*X1MX NEL = NEL + 2.0D0*NF*TWOXM1 C ELSE WRITE(NOUT,*)'Unrecognized type in subroutine twopointg.' STOP ENDIF C C With the coefficients in hand, we compute the result. C PREFACTOR = 1.0D0/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ) C OUT(0,0) = PREFACTOR*QBARSQ/CALQSQ*NEE DO MU = 1,3 TEMP = PREFACTOR*Q0/DELTAP1/CALQSQ*NEL*ELLT(MU) OUT(0,MU) = TEMP OUT(MU,0) = TEMP ENDDO DO MU = 1,3 DO NU = 1,3 TERMTT = NTT*BAREPROP(MU,NU) TERMLL = NLL*(ELLT(MU)*ELLT(NU)/ELLTSQ - 0.5D0*BAREPROP(MU,NU)) OUT(MU,NU) = PREFACTOR*(TERMTT + TERMLL) ENDDO ENDDO C C Alternative for IF (CUT2PT(1).AND.CUT2PT(2)) THEN .... C ELSE IF (CUT2PT(0).OR.CUT2PT(3)) THEN C C We have the contribution from a virtual self-energy diagram C with one of the neighboring propagators cut. C We compute the coefficients for, alternatively, the gluon loop C or the quark loop. C IF (KIND2PT.EQ.'GLUONLOOP') THEN C TEMP = MUMSBAR**2*EXP(2.0D0) AT0 = - 2.0D0*NC*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(5.0D0/3.0D0) AT0 = AT0 + 2.0D0*NC*X1MX*TEMP/(QBARSQ + TEMP) NTT0 = 4.0D0*NC*X1MX NET0 = - 2.0D0*NC*TWOXM1 C UTT = AT0 NTT = NTT0 NET = NET0 C ELSE IF (KIND2PT.EQ.'QUARKLOOP') THEN C C Here AT1 = AT2 = NTT1 = NTT2 = NET1 = NET2 = 0. C TEMP = MUMSBAR**2*EXP(2.0D0) AT0 = NF*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(8.0D0/3.0D0) AT0 = AT0 - 2.0D0*NF*X1MX*TEMP/(QBARSQ + TEMP) NTT0 = - 4.0D0*NF*X1MX NET0 = 2.0D0*NF*TWOXM1 C UTT = AT0 NTT = NTT0 NET = NET0 C ELSE IF (KIND2PT.EQ.'BOTHLOOPS') THEN C TEMP = MUMSBAR**2*EXP(2.0D0) AT0 = - 2.0D0*NC*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(5.0D0/3.0D0) AT0 = AT0 + 2.0D0*NC*X1MX*TEMP/(QBARSQ + TEMP) NTT0 = 4.0D0*NC*X1MX NET0 = - 2.0D0*NC*TWOXM1 C UTT = AT0 NTT = NTT0 NET = NET0 C TEMP = MUMSBAR**2*EXP(2.0D0) AT0 = NF*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(8.0D0/3.0D0) AT0 = AT0 - 2.0D0*NF*X1MX*TEMP/(QBARSQ + TEMP) NTT0 = - 4.0D0*NF*X1MX NET0 = 2.0D0*NF*TWOXM1 C UTT = UTT + AT0 NTT = NTT + NTT0 NET = NET + NET0 C ELSE WRITE(NOUT,*)'Unrecognized type in subroutine twopointg.' STOP ENDIF C C With the coefficients in hand, we compute the result. There is C an extra factor 1 + \Delta compared to the real self-energy C graphs because {\cal W} lacks the factor 1/(1 + \Delta) that C appears in {\cal M}. C C Also, we divide by 2 because we will get this contribution C twice, once when one adjacent propagator is cut and onece C when the other adjacent propagator is cut. C PREFACTOR = - DELTAP1/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ) PREFACTOR = 0.5D0*PREFACTOR C OUT(0,0) = 0.0D0 DO MU = 1,3 TEMP = PREFACTOR*Q0/DELTAP1/CALQSQ/(1 + QBARSQ/CALQSQ) TEMP = TEMP*NET*ELLT(MU) OUT(0,MU) = TEMP OUT(MU,0) = TEMP ENDDO DO MU = 1,3 DO NU = 1,3 TERMTT = UTT*BAREPROP(MU,NU) TEMP = ELLT(MU)*ELLT(NU)/ELLTSQ - 0.5D0*BAREPROP(MU,NU) TERMLL = NTT/(1 + QBARSQ/CALQSQ)*TEMP OUT(MU,NU) = PREFACTOR*(TERMTT + TERMLL) ENDDO ENDDO C C Closing for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....ELSEIF ... C ELSE WRITE(NOUT,*)'For a gluon two point function,' WRITE(NOUT,*)'either the self-energy graph must be cut' WRITE(NOUT,*)'or one of the neighboring propagators' WRITE(NOUT,*)'must be cut.' STOP ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,OUT) C In: COMPLEX*16 K2PT(0:2,0:3) LOGICAL CUT2PT(0:3) REAL*8 MUMSBAR CHARACTER*16 FLAG C Out: COMPLEX*16 OUT(0:3) C C Calculates the one loop quark two-point function, including the C adjoining propagators. C C k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part) C k2pt(1,mu): 1st momentum in loop (kplus for the space part) C k2pt(2,mu): 2nd momentum in loop (kminus for the space part) C C cut2pt(0): whether incoming line is cut C cut2pt(1): whether 1st internal line is cut C cut2pt(2): whether 2nd internal line is cut C cut2pt(3): whether outgoing line is cut C C mumsbar is the MSbar renormalization scale. C C The two point function, with a certain normalization, C is represented as out^mu gamma_mu. C For the real quark self-energy graphs, out^{\mu} gamma_{\mu} C is {\cal M}_q divided by C (\alpha_s/(4\pi)) * 1/(1+\Delta) C and divided by C 4 * \omega_+ * \omega_- * \bar q^2. C The factor by which we divide consists of C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and C one (2\pi)^{-3} for each loop that is factored out of each C graph in our program. C * (d\vec l)/(d\bar q^2 dx d\phi) C = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) C * 4 \pi {\cal Q} \bar q^2 included in the relation between C {\cal I}[real] and {\cal M}_q. C C In the case of the virtual quark self-energy graphs with C one of the adjacent propagators cut, OUT^{\mu} gamma_{\mu} C is {\cal W}_q divided by the same factors. C C In the case of the virtual quark self-energy graphs with C the adjacent propagators *not* cut, OUT^{\mu} gamma_{\mu} C is W_q divided by C (\alpha_s/(4\pi)) * 1/(1+\Delta) C and divided by C 2 * \omega_+ * \omega_- * (\bar q^2 - q^2) * q^2/{\cal Q}. C The factor by which we divide consists of C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and C one (2\pi)^{-3} for each loop that is factored out of each C graph in our program. C * (d\vec l)/(d\bar q^2 dx d\phi) C = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) C * 2 \pi q^2 (\bar q^2 - q^2) included in the relation between C {\cal I}[all uncut] and W_q. C C 16 December 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF,CF COMMON /COLORFACTORS/ NC,NF COMPLEX*16 COMPLEXSQRT INTEGER MU COMPLEX*16 KPLUS(1:3),KMINUS(1:3),ELL(1:3),Q(1:3) COMPLEX*16 CALQSQ,OMEGAPLUSSQ,OMEGAMINUSSQ COMPLEX*16 CALQ,OMEGAPLUS,OMEGAMINUS COMPLEX*16 DELTAP1,DELTA,TWOXM1,X1MX,QBARSQ COMPLEX*16 ELLT(1:3) COMPLEX*16 ELLTSQ,ONEM2X1MX,X COMPLEX*16 TEMP,TEMPSQ COMPLEX*16 NL,NE,NT,PREFACTOR COMPLEX*16 BL0 COMPLEX*16 NL0 COMPLEX*16 NT0 COMPLEX*16 UL,VL,VT COMPLEX*16 Q0,QSQ COMPLEX*16 BE0 COMPLEX*16 UE C CF = (NC**2 - 1.0D0)/(2.0D0*NC) C C Some auxilliary variables, including C CALQ = {\cal Q} C OMEGAPLUS = \omega_+ C OMEGAMINUS = \omega_- C DELTAP1 = \Delta + 1 C TWOXM1 = 2 x - 1 C X1MX = x (1-x) C ELLT(mu) = l_T^\mu C ELLTSQ = (\vec l_T)^2 C Q(mu) = the incoming *three*-momentum C Q0 = the incoming energy C DO MU = 1,3 KPLUS(MU) = K2PT(1,MU) KMINUS(MU) = K2PT(2,MU) ELL(MU) = (KPLUS(MU) - KMINUS(MU))/2.0D0 Q(MU) = K2PT(0,MU) ENDDO Q0 = K2PT(0,0) CALQSQ = 0.0D0 OMEGAPLUSSQ = 0.0D0 OMEGAMINUSSQ = 0.0D0 DO MU = 1,3 CALQSQ = CALQSQ + Q(MU)**2 OMEGAPLUSSQ = OMEGAPLUSSQ + KPLUS(MU)**2 OMEGAMINUSSQ = OMEGAMINUSSQ + KMINUS(MU)**2 ENDDO CALQ = COMPLEXSQRT(CALQSQ) OMEGAPLUS = COMPLEXSQRT(OMEGAPLUSSQ) OMEGAMINUS = COMPLEXSQRT(OMEGAMINUSSQ) DELTAP1 = (OMEGAPLUS + OMEGAMINUS)/CALQ DELTA = DELTAP1 - 1.0D0 TWOXM1 = (OMEGAPLUS - OMEGAMINUS)/CALQ X1MX = (1.0D0 - TWOXM1**2)/4.0D0 QBARSQ = CALQSQ * DELTA * (DELTA + 2.0D0) DO MU = 1,3 ELLT(MU) = ELL(MU) - 0.5D0*DELTAP1*TWOXM1*Q(MU) ENDDO ELLTSQ = QBARSQ*X1MX ONEM2X1MX = 1.0D0 - 2.0D0*X1MX X = (TWOXM1 + 1.0D0)/2.0D0 C C Now we will go through these possible cut structures and C calculate the terms contributing to out(mu). C IF ( CUT2PT(1).AND.CUT2PT(2) ) THEN C C First possibility for cut structure: a cut self-energy diagram. C Here TEMP = 2 x + Delta. C TEMP = TWOXM1 + DELTAP1 TEMPSQ = TEMP**2 NL = 4.0D0*X1MX + TWOXM1*TEMP NL = CF*NL NE = 2.0D0*CF*(1.0D0 - X) NT = 2.0D0*CF C PREFACTOR = 1.0D0/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ) OUT(0) = PREFACTOR*Q0/DELTAP1*(NL + DELTA*NE) DO MU = 1,3 OUT(MU) = PREFACTOR*(NL*Q(MU) + NT*ELLT(MU)) ENDDO C ELSE IF ( CUT2PT(0).OR.CUT2PT(3) ) THEN C C Second possibility for cut structure: a virtual self-energy C with an adjacent propagator cut. C TEMP = MUMSBAR**2 * EXP(1.0D0) BL0 = CF*TEMP/(QBARSQ + TEMP) NL0 = CF*TWOXM1 NT0 = 2.0D0*CF UL = BL0 VL = NL0 VT = NT0 C C We divide by 2 because we will get this contribution C twice, once when one adjacent propagator is cut and once C when the other adjacent propagator is cut. C PREFACTOR = DELTAP1/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ) PREFACTOR = 0.5D0*PREFACTOR C TEMP = UL + VL/(1.0D0 + QBARSQ/CALQSQ) OUT(0) = - PREFACTOR*Q0*TEMP DO MU = 1,3 OUT(MU) = - PREFACTOR*(TEMP*Q(MU) > + VT*ELLT(MU)/(1.0D0 + QBARSQ/CALQSQ)) ENDDO C ELSE C C Third possibility for cut structure: a virtual self-energy C with *no* adjacent propagator cut. C QSQ = Q0**2 - CALQSQ C TEMP = MUMSBAR**2 * EXP(1.0D0) BL0 = (QSQ + TEMP)/(QBARSQ + TEMP) BL0 = CF*BL0 BE0 = 0.0D0 UL = BL0 UE = BE0 C PREFACTOR = 2.0D0*OMEGAPLUS*OMEGAMINUS*QSQ*(QBARSQ - QSQ) PREFACTOR = DELTAP1*CALQ/PREFACTOR OUT(0) = - PREFACTOR*Q0*(UL + QSQ/CALQSQ*UE) DO MU = 1,3 OUT(MU) = - PREFACTOR*Q(MU)*UL ENDDO C C Completion of IF ... block for cut structure. C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,HV,HA) C In: CHARACTER*7 KIND3PT COMPLEX*16 K3PT(3,0:3) LOGICAL CUT3PT(3) REAL*8 MUMSBAR CHARACTER*16 FLAG C Out: COMPLEX*16 HV(0:3,0:3),HA(0:3,0:3) C C The unintegrated quark-antiquark-gluon three point function C for the graph with flavors labelled by KIND3PT. C C KIND3PT has the form abc/def where a,...,f are chosen from C Q,G,P. Here Q denotes "quark" or "antiquark", G denotes "gluon", C and P denotes "photon. The external lines have flavors a,b,c C and the internal lines have flavors d,e,f. The possibilities C are QQG/QQG, QQG/GGQ, and QQP/QQG. There is also QQG/ALL, which C gives the sum of the results for QQG/QQG and QQG/GGQ. C C The unintegrated three-point function \Gamma^\mu can be decomposed C into a function HV^\mu_\nu \gamma^\mu plus a function C HA^\mu_\nu I \gamma^\mu \gamma_5 (all times a t^a color matrix or a C unit color matrix in the case of a QQP vertex). This subroutine C calculates the functions HV^{\mu\nu} and HA^{\mu\nu}. The arguments C are the momenta k3pt(1,mu), k3pt(2,mu), k3pt(3,mu), of the propagators C around the loop. C C The variable cut3pt(j) is .true. if line j is cut, .false. otherwise. C If the line is cut, the corresponding energy is set by the calling C programs to be k0 = + |\vec k| or else k0 = - |\vec k|. (Here C |\vec k| is a shorthand for sqrt(\vec k^2), not the square root of C \vec k dotted into its complex conjugate.) This subroutine supplies a C factor k(j)^2 for uncut propagators and 2 sqrt(\vec k^2) for a cut C propagator. For a virtual loop, subroutine vertex will be called six C times, once with each of the three propagators cut and k0 = + |\vec k| C and once with each of the three propagators cut and k0 = - |\vec k|. C Then it will be called with no propagator cut, which implies that it C should supply the renormalization counter term. C C This version in Feynman gauge. C 31 December 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF COMPLEX*16 COMPLEXSQRT C REAL*8 CF COMPLEX*16 NVEC(0:3) DATA NVEC /1,0,0,0/ REAL*8 G(0:3,0:3) DATA G /1, 0, 0, 0, > 0,-1, 0, 0, > 0, 0,-1, 0, > 0, 0, 0,-1/ C COMPLEX*16 TK11,TK22,TK33,TK12,TK23,TK13 COMPLEX*16 K11,K22,K33,K12,K23,K13 COMPLEX*16 E1,E2,E3 COMPLEX*16 C1,C2,C3,C4,C5,C6,C7,C8,C9 COMPLEX*16 C10,C11,C12,C13,C14,C15,C16,C17 COMPLEX*16 TEMP,PREFACTOR INTEGER MU,NU COMPLEX*16 K1(0:3),K2(0:3),K3(0:3) COMPLEX*16 EPSN1(0:3,0:3),EPSN2(0:3,0:3),EPSN3(0:3,0:3) COMPLEX*16 EPS12(0:3,0:3),EPS13(0:3,0:3),EPS23(0:3,0:3) COMPLEX*16 EPSN12(0:3),EPSN13(0:3),EPSN23(0:3),EPS123(0:3) COMPLEX*16 TL(0:3),OMEGASQ,OMEGA,CR1,CR2,CR3 INTEGER NCUT,P C C----- C CF = (NC**2 - 1.0D0)/(2.0D0*NC) NCUT = 0 DO P=1,3 IF (CUT3PT(P)) THEN NCUT = NCUT + 1 ENDIF ENDDO C IF ((NCUT.GT.1).OR.(FLAG.NE.'renormalize 3 pt')) THEN C C If NCUT = 1, we have a virtual loop. In this case, one of the C possibilities is the renormalization counter term, for which C FLAG would have been set to 'renormalize 3 pt'. Thus we get C here is we do *not* have the the renormalization counter term. C (Note that we could have NCUT = 2 but FLAG = 'renormalize 3 pt' C in the case that there are two three point functions and ours C is cut but the other one is virtual and needs to be renormalized.) C C First, dot products and energies. The dot products between vectors C omitting their mu = 0 parts (\tilde vector) are denoted TKij. C TK11 = (0.0D0,0.0D0) TK22 = (0.0D0,0.0D0) TK33 = (0.0D0,0.0D0) TK12 = (0.0D0,0.0D0) TK23 = (0.0D0,0.0D0) TK13 = (0.0D0,0.0D0) DO MU = 1,3 TK11 = TK11 - K3PT(1,MU)*K3PT(1,MU) TK22 = TK22 - K3PT(2,MU)*K3PT(2,MU) TK33 = TK33 - K3PT(3,MU)*K3PT(3,MU) TK12 = TK12 - K3PT(1,MU)*K3PT(2,MU) TK23 = TK23 - K3PT(2,MU)*K3PT(3,MU) TK13 = TK13 - K3PT(1,MU)*K3PT(3,MU) ENDDO E1 = K3PT(1,0) E2 = K3PT(2,0) E3 = K3PT(3,0) K11 = E1*E1 + TK11 K22 = E2*E2 + TK22 K33 = E3*E3 + TK33 K12 = E1*E2 + TK12 K23 = E2*E3 + TK23 K13 = E1*E3 + TK13 C C We need the factor equal to 1/k^2 for an uncut propagator C and 1/ 2|E| for a cut propagator. C PREFACTOR = (1.0D0,0.0D0) IF (.NOT.CUT3PT(1)) THEN PREFACTOR = PREFACTOR/K11 ELSE PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK11)) ENDIF IF (.NOT.CUT3PT(2)) THEN PREFACTOR = PREFACTOR/K22 ELSE PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK22)) ENDIF IF (.NOT.CUT3PT(3)) THEN PREFACTOR = PREFACTOR/K33 ELSE PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK33)) ENDIF C C------------------------ C First, we calculate hv. C------------------------ C Generate the coefficients for the hv, depending on KIND3PT. C IF (KIND3PT.EQ."QQG/QQG") THEN C C1 = K12/NC C2 = 0.0D0 C3 = 0.0D0 C4 = 0.0D0 C5 = 0.0D0 C6 = 0.0D0 C7 = 0.0D0 C8 = 0.0D0 C9 = 0.0D0 C10 = -(1.0D0/NC) C11 = 0.0D0 C12 = -(1.0D0/NC) C13 = 0.0D0 C14 = 0.0D0 C15 = 0.0D0 C16 = 0.0D0 C17 = 0.0D0 C ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN C C1 = -((K13 + K23)*NC)/2.0D0 C2 = 0.0D0 C3 = 0.0D0 C4 = 0.0D0 C5 = 0.0D0 C6 = 0.0D0 C7 = 0.0D0 C8 = 0.0D0 C9 = 0.0D0 C10 = 0.0D0 C11 = -NC/2.0D0 C12 = 0.0D0 C13 = 0.0D0 C14 = -NC/2.0D0 C15 = -NC/2.0D0 C16 = -NC/2.0D0 C17 = 0.0D0 C ELSE IF (KIND3PT.EQ."QQG/ALL") THEN C C1 = K12/NC C2 = 0.0D0 C3 = 0.0D0 C4 = 0.0D0 C5 = 0.0D0 C6 = 0.0D0 C7 = 0.0D0 C8 = 0.0D0 C9 = 0.0D0 C10 = -(1.0D0/NC) C11 = 0.0D0 C12 = -(1.0D0/NC) C13 = 0.0D0 C14 = 0.0D0 C15 = 0.0D0 C16 = 0.0D0 C17 = 0.0D0 C C1 = C1 - ((K13 + K23)*NC)/2.0D0 C11 = C11 - NC/2.0D0 C14 = C14 - NC/2.0D0 C15 = C15 - NC/2.0D0 C16 = C16 - NC/2.0D0 C ELSE IF (KIND3PT.EQ."QQP/QQG") THEN C C1 = -2.0D0*CF*K12 C2 = 0.0D0 C3 = 0.0D0 C4 = 0.0D0 C5 = 0.0D0 C6 = 0.0D0 C7 = 0.0D0 C8 = 0.0D0 C9 = 0.0D0 C10 = 2.0D0*CF C11 = 0.0D0 C12 = 2.0D0*CF C13 = 0.0D0 C14 = 0.0D0 C15 = 0.0D0 C16 = 0.0D0 C17 = 0.0D0 C ELSE WRITE(NOUT,*)'Wrong kind in subroutine vertex' STOP ENDIF C C Now we have the coefficients, so we can calculate hv. C DO MU = 0,3 DO NU = 0,3 C TEMP = C1*G(MU,NU) > + C2*NVEC(MU)*NVEC(NU) > + C3*NVEC(MU)*K3PT(1,NU) > + C4*NVEC(MU)*K3PT(2,NU) > + C5*NVEC(MU)*K3PT(3,NU) > + C6*K3PT(1,MU)*NVEC(NU) > + C7*K3PT(2,MU)*NVEC(NU) > + C8*K3PT(3,MU)*NVEC(NU) > + C9*K3PT(1,MU)*K3PT(1,NU) > + C10*K3PT(1,MU)*K3PT(2,NU) > + C11*K3PT(1,MU)*K3PT(3,NU) > + C12*K3PT(2,MU)*K3PT(1,NU) > + C13*K3PT(2,MU)*K3PT(2,NU) > + C14*K3PT(2,MU)*K3PT(3,NU) > + C15*K3PT(3,MU)*K3PT(1,NU) > + C16*K3PT(3,MU)*K3PT(2,NU) > + C17*K3PT(3,MU)*K3PT(3,NU) C HV(MU,NU) = PREFACTOR * TEMP C ENDDO ENDDO C C------------------------ C Next, we calculate ha. C------------------------ C C We need certain vectors and tensors made by dotting vectors C into the epsilon tensor. C DO MU = 0,3 K1(MU) = K3PT(1,MU) K2(MU) = K3PT(2,MU) K3(MU) = K3PT(3,MU) ENDDO CALL EPSILON1N(K1,EPSN1) CALL EPSILON1N(K2,EPSN2) CALL EPSILON1N(K3,EPSN3) CALL EPSILON2(K1,K2,EPS12) CALL EPSILON2(K1,K3,EPS13) CALL EPSILON2(K2,K3,EPS23) CALL EPSILON2N(K1,K2,EPSN12) CALL EPSILON2N(K1,K3,EPSN13) CALL EPSILON2N(K2,K3,EPSN23) CALL EPSILON3(K1,K2,K3,EPS123) C C Generate the coefficients for the hv, depending on KIND3PT. C IF (KIND3PT.EQ."QQG/QQG") THEN C C1 = 0.0D0 C2 = 0.0D0 C3 = 0.0D0 C4 = -(1.0D0/NC) C5 = 0.0D0 C6 = 0.0D0 C7 = 0.0D0 C8 = 0.0D0 C9 = 0.0D0 C10 = 0.0D0 C11 = 0.0D0 C12 = 0.0D0 C13 = 0.0D0 C14 = 0.0D0 C15 = 0.0D0 C16 = 0.0D0 C17 = 0.0D0 C ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN C C1 = 0.0D0 C2 = 0.0D0 C3 = 0.0D0 C4 = 0.0D0 C5 = (3.0D0*NC)/2.0D0 C6 = (-3.0D0*NC)/2.0D0 C7 = 0.0D0 C8 = 0.0D0 C9 = 0.0D0 C10 = 0.0D0 C11 = 0.0D0 C12 = 0.0D0 C13 = 0.0D0 C14 = 0.0D0 C15 = 0.0D0 C16 = 0.0D0 C17 = 0.0D0 C ELSE IF (KIND3PT.EQ."QQG/ALL") THEN C C1 = 0.0D0 C2 = 0.0D0 C3 = 0.0D0 C4 = -(1.0D0/NC) C5 = 0.0D0 C6 = 0.0D0 C7 = 0.0D0 C8 = 0.0D0 C9 = 0.0D0 C10 = 0.0D0 C11 = 0.0D0 C12 = 0.0D0 C13 = 0.0D0 C14 = 0.0D0 C15 = 0.0D0 C16 = 0.0D0 C17 = 0.0D0 C C5 = C5 + (3.0D0*NC)/2.0D0 C6 = C6 - 3.0D0*NC/2.0D0 C ELSE IF (KIND3PT.EQ."QQP/QQG") THEN C C1 = 0 C2 = 0 C3 = 0 C4 = 2.0D0*CF C5 = 0 C6 = 0 C7 = 0 C8 = 0 C9 = 0 C10 = 0 C11 = 0 C12 = 0 C13 = 0 C14 = 0 C15 = 0 C16 = 0 C17 = 0 C ELSE WRITE(NOUT,*)'Wrong kind in subroutine vertex' STOP ENDIF C C Now we have the coefficients, so we can calculate ha. C DO MU = 0,3 DO NU = 0,3 C TEMP = C1*EPSN1(MU,NU) > + C2*EPSN2(MU,NU) > + C3*EPSN3(MU,NU) > + C4*EPS12(MU,NU) > + C5*EPS13(MU,NU) > + C6*EPS23(MU,NU) > + C7*K3PT(3,MU)*EPSN12(NU) > + C8*NVEC(MU)*EPSN13(NU) > + C9*K3PT(1,MU)*EPSN13(NU) > + C10*K3PT(2,MU)*EPSN13(NU) > + C11*NVEC(MU)*EPSN23(NU) > + C12*K3PT(1,MU)*EPSN23(NU) > + C13*K3PT(2,MU)*EPSN23(NU) > + C14*NVEC(MU)*EPS123(NU) > + C15*K3PT(1,MU)*EPS123(NU) > + C16*K3PT(2,MU)*EPS123(NU) > + C17*K3PT(3,MU)*EPS123(NU) C HA(MU,NU) = PREFACTOR * TEMP C ENDDO ENDDO C C----------------------------- C Now, we have both hv and ha. C----------------------------- C C Alternative for IF (FLAG.NE.'renormalize 3 pt') THEN C ELSE C C We need the renormalization counter term. C TL(0) = 0.0D0 OMEGASQ = 0.0D0 DO MU = 1,3 TL(MU) =(K3PT(1,MU) + K3PT(2,MU) + K3PT(3,MU))/3.0D0 OMEGASQ = OMEGASQ + TL(MU)**2 ENDDO OMEGASQ = OMEGASQ + MUMSBAR**2 OMEGA = COMPLEXSQRT(OMEGASQ) C C Generate the coefficients for the hv counter term, C depending on KIND3PT. C IF (KIND3PT.EQ."QQG/QQG") THEN C CR1 = - 1.0D0/(4.0D0*NC*OMEGA**3) > - 3.0D0*MUMSBAR**2/(16.0D0*NC*OMEGA**5) CR2 = - 3.0D0/(8.0D0*NC*OMEGA**5) CR3 = 1.0D0/(8.0D0*NC*OMEGA**3) C ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN C CR1 = NC/(4.0D0*OMEGA**3) > + 3.0D0*NC*MUMSBAR**2/(16.0D0*OMEGA**5) CR2 = - 3.0D0*NC/(8.0D0*OMEGA**5) CR3 = NC/(8.0D0*OMEGA**3) C ELSE IF (KIND3PT.EQ."QQG/ALL") THEN C CR1 = NC/(4.0D0*OMEGA**3) > + 3.0D0*NC*MUMSBAR**2/(16.0D0*OMEGA**5) CR2 = - 3.0D0*NC/(8.0D0*OMEGA**5) CR3 = NC/(8.0D0*OMEGA**3) C CR1 = CR1 - 1.0D0/(4.0D0*NC*OMEGA**3) > - 3.0D0*MUMSBAR**2/(16.0D0*NC*OMEGA**5) CR2 = CR2 - 3.0D0/(8.0D0*NC*OMEGA**5) CR3 = CR3 + 1.0D0/(8.0D0*NC*OMEGA**3) C ELSE IF (KIND3PT.EQ."QQP/QQG") THEN C CR1 = CF/(2.0D0*OMEGA**3) > + 3.0D0*CF*MUMSBAR**2/(8.0D0*OMEGA**5) CR2 = 3.0D0*CF/(4.0D0*OMEGA**5) CR3 = - CF/(4.0D0*OMEGA**3) C ELSE WRITE(NOUT,*)'Wrong kind in subroutine vertex' STOP ENDIF C C Now we have the coefficients, so we can calculate the hv counter term. C The ha counter term is zero. C DO MU = 0,3 DO NU = 0,3 HV(MU,NU) = - CR1*G(MU,NU) > - CR2*TL(MU)*TL(NU) > - CR3*NVEC(MU)*NVEC(NU) HA(MU,NU) = 0.0D0 ENDDO ENDDO RETURN C C End IF (CUT3PT(1).OR.CUT3PT(2).OR.CUT3PT(3)) THEN ... ELSE ... C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE TWOPT2F(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,VOUT) C In: CHARACTER*13 KIND2PT2 COMPLEX*16 K2PT2(0:5,0:3) LOGICAL CUT2PT2(1:5) REAL*8 MUMSBAR CHARACTER*16 FLAG C Out: COMPLEX*16 VOUT(0:3) C C *Feynman gauge*. C C The two-loop contribution to the quark propagator. The function is C a dot product of a four-vector VOUT(mu) with gamma(mu), times a C unit color matrix. This subroutine calculates VOUT(mu). (There is C another contribution proportional to gamma(mu) gamma(5), but this C contribution is not needed at our level of perturbation theory.) The C contribution includes the self-energy diagram and the adjoining bare C quark propagators. The calculation includes the denominator factors. C Some of the internal propagators may be cut, as specified by cut2pt2, C where cut2pt2(j) = .true. indicates that the corresponding line is C cut. C C The variable kind2pt2 tells what sort of graph we have. C C 1) There are graphs with two overlapping three point functions, C incicated by kind2pt2 = OVERLAP/abcde where a,...,e are chosen from C Q,G. Here Q denotes "quark" or "antiquark" while G denotes "gluon. C These characters indicate the flavors on the internal lines. There C are two possibilities: OVERLAP/QGGQQ and OVERLAP/QGQGG. (The first C of these has all qqg vertices, while the second has two qqg vertices C and one ggg vertex.) C C 2) There are graphs with a one loop two point function nested inside C the two loop two point function. These are indicated by C kind2pt2 = NESTED /abcde, where, again, a,...,e are chosen from C Q,G. There are three possibilities: C NESTED /QGGGG gluon self-enegy with a gluon loop C NESTED /QGGQQ gluon self-enegy with a quark loop C NESTED /GQQGQ quark self-enegy C C Numbering for graphs of type OVERLAP: C vrtx1 attaches to the incoming quark line C vrtx2 attaches to the outgoing quark line C vrtx3 is the internal vertex attached to a quark line from vrtx1 C vrtx4 is the other internal vertex C k0(mu) is the momentum of the quark line entering vrtx1 C k1(mu) is the momentum of the internal line from vrtx1 to vrtx3 C k2(mu) is the momentum of the internal line from vrtx1 to vrtx4 C k3(mu) is the momentum of the internal line from vrtx3 to vrtx2 C k4(mu) is the momentum of the internal line from vrtx4 to vrtx2 C k5(mu) is the momentum of the internal line from vrtx3 to vrtx4 C C Numbering for graphs of type NESTED: C vrtx1 attaches to the incoming quark line C vrtx2 attaches to the outgoing quark line C vrtx3 is the internal vertex attached to a line from vrtx1 C vrtx4 is the other internal vertex C k0(mu) is the momentum of the quark line entering vrtx1 C k1(mu) is the momentum of the internal line from vrtx1 to vrtx2 C k2(mu) is the momentum of the internal line from vrtx1 to vrtx3 C k3(mu) is the momentum of the internal line from vrtx4 to vrtx2 C k4(mu) ane k5(mu) are the momentum of the internal lines C from vrtx3 to vrtx4. For a quark internal self-energy, C 4 is the gluon and 5 is the quark line. C C 31 December 2001 C C For testing purposes only: C LOGICAL OVERRIDE,LEFTOVERRIDE C COMMON /TESTING/ OVERRIDE,LEFTOVERRIDE C --- C COMPLEX*16 COMPLEXSQRT COMPLEX*16 TK00,TK11,TK22,TK33,TK44 COMPLEX*16 K00,K11,K22,K33,K44 COMPLEX*16 TEMP,PREFACTOR COMPLEX*16 K0(0:3),K1(0:3),K2(0:3),K3(0:3),K4(0:3),K5(0:3) COMPLEX*16 E0,E1,E2,E3,E4 LOGICAL CUT(1:5) C COMPLEX*16 EA4GK0K1,EA4QK0K1,EA5GK0K3,EA5QK0K4,K0K1,K0K3,K0K4 COMPLEX*16 TRACEV4G,TRACEV4Q,TRACEV5G,TRACEV5Q,V4GWK0K1,V4GWK1K0 COMPLEX*16 V4QWK0K1,V4QWK1K0,V5GWK0K3,V5GWK3K0,V5QWK0K4,V5QWK4K0 COMPLEX*16 EA4GK1(0:3),EA4QK1(0:3),EA5GK3(0:3),EA5QK4(0:3) COMPLEX*16 V4GIK1(0:3),V4GK1I(0:3),V4QIK1(0:3),V4QK1I(0:3) COMPLEX*16 V5GIK3(0:3),V5GK3I(0:3),V5QIK4(0:3),V5QK4I(0:3) COMPLEX*16 A4G(0:3,0:3),A4Q(0:3,0:3),A5G(0:3,0:3),A5Q(0:3,0:3) COMPLEX*16 V4G(0:3,0:3),V4Q(0:3,0:3),V5G(0:3,0:3),V5Q(0:3,0:3) C CHARACTER*7 KIND3PT LOGICAL OVERLAP,QQGVERTS,TRIPLEGLUE LOGICAL NESTED,NESTEDGLUE,NESTEDQUARK,GLUELOOP,QUARKLOOP COMPLEX*16 K2PT(0:2,0:3),Q(0:3) COMPLEX*16 OMEGASQ,QSQ CHARACTER*9 KIND2PT LOGICAL CUT2PT(0:3) COMPLEX*16 OUTG(0:3,0:3) COMPLEX*16 MK1(0:3),TRACEM,DOTQK1,MQK1 COMPLEX*16 OUTQ(0:3) COMPLEX*16 OMEGA1SQ,BAREPROP(0:3,0:3),DM(0:3),QM,DQM COMPLEX*16 TRACEBAREPROP C COMPLEX*16 GN(0:3) DATA GN /(1.0D0,0.0D0),(0.0D0,0.0D0), > (0.0D0,0.0D0),(0.0D0,0.0D0)/ REAL*8 METRIC(0:3) DATA METRIC / 1.0D0,-1.0D0,-1.0D0,-1.0D0 / INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF REAL*8 CF INTEGER MU,NU,ALPHA LOGICAL LEFT,RIGHT C COMPLEX*16 K3PT(3,0:3) LOGICAL CUT3PT(3) C CF = (NC**2 - 1.0D0)/(2.0D0*NC) C C Set logical variables according to what case we have. C OVERLAP = .FALSE. QQGVERTS = .FALSE. TRIPLEGLUE = .FALSE. NESTED = .FALSE. NESTEDGLUE = .FALSE. NESTEDQUARK = .FALSE. GLUELOOP = .FALSE. QUARKLOOP = .FALSE. IF (KIND2PT2.EQ.'OVERLAP/QGGQQ') THEN OVERLAP = .TRUE. QQGVERTS = .TRUE. ELSE IF (KIND2PT2.EQ.'OVERLAP/QGQGG') THEN OVERLAP = .TRUE. TRIPLEGLUE = .TRUE. ELSE IF (KIND2PT2.EQ.'NESTED /QGGGG') THEN NESTED = .TRUE. NESTEDGLUE = .TRUE. GLUELOOP = .TRUE. ELSE IF (KIND2PT2.EQ.'NESTED /QGGQQ') THEN NESTED = .TRUE. NESTEDGLUE = .TRUE. QUARKLOOP = .TRUE. ELSE IF (KIND2PT2.EQ.'NESTED /GQQGQ') THEN NESTED = .TRUE. NESTEDQUARK = .TRUE. ELSE WRITE(NOUT,*)'Not programmed for that.' STOP ENDIF C IF (OVERLAP) THEN C C Short form of momentum variables and rename cut variables C for overlap graphs. C DO MU = 0,3 K0(MU) = K2PT2(0,MU) K1(MU) = K2PT2(1,MU) K2(MU) = K2PT2(2,MU) K3(MU) = K2PT2(3,MU) K4(MU) = K2PT2(4,MU) K5(MU) = K2PT2(5,MU) ENDDO CUT(1) = CUT2PT2(1) CUT(2) = CUT2PT2(2) CUT(3) = CUT2PT2(3) CUT(4) = CUT2PT2(4) CUT(5) = CUT2PT2(5) C C We have an OVERLAP type graph. We can treat it two different C ways: either the left=hand three point graph is calculated C using subroutine VERTEX or else the right-hand three point C graph is calculated with subroutine VERTEX. We choose according C to which lines are cut. Generally, we take the "left" choice, C but if the right-hand loop is virtual, we take the "right" choice. C LEFT = .TRUE. RIGHT = .FALSE. IF (CUT2PT2(1).AND.CUT2PT2(2)) THEN LEFT = .FALSE. RIGHT = .TRUE. ENDIF C C For testing purposes, we include code to override this choice. C C IF (OVERRIDE) THEN C LEFT = LEFTOVERRIDE C RIGHT = .NOT.LEFT C ENDIF C C Calculate according to case, with logic C IF (QQGVERTS.AND.RIGHT) THEN C ELSE IF (QQGVERTS.AND.LEFT) THEN C ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN C ELSE IF (TRIPLEGLUE.AND.LEFT) THEN C ELSE C ENDIF C IF (QQGVERTS.AND.RIGHT) THEN C C--- TK00 = 0.0D0 DO MU = 1,3 TK00 = TK00 - K0(MU)**2 ENDDO E0 = K0(0) K00 = E0**2 + TK00 PREFACTOR = 1.0D0/K00**2 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF DO MU = 0,3 K3PT(1,MU) = -K4(MU) K3PT(2,MU) = -K5(MU) K3PT(3,MU) = K3(MU) ENDDO CUT3PT(1) = CUT(4) CUT3PT(2) = CUT(5) CUT3PT(3) = CUT(3) KIND3PT = 'QQG/QQG' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V4Q,A4Q) TRACEV4Q = 0.0D0 DO MU = 0,3 TRACEV4Q = TRACEV4Q + V4Q(MU,MU)*METRIC(MU) ENDDO V4QWK0K1 = 0.0D0 V4QWK1K0 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V4QWK0K1 = V4QWK0K1 > + V4Q(MU,NU)*K0(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4QWK1K0 = V4QWK1K0 > + V4Q(MU,NU)*K1(MU)*K0(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 V4QIK1(MU) = 0.0D0 V4QK1I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 V4QIK1(MU) = V4QIK1(MU) + V4Q(MU,NU)*K1(NU)*METRIC(NU) V4QK1I(MU) = V4QK1I(MU) + V4Q(NU,MU)*K1(NU)*METRIC(NU) ENDDO ENDDO K0K1 = 0.0D0 DO MU = 0,3 K0K1 = K0K1 + K0(MU)*K1(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A4Q,K0,K1,EA4QK0K1) CALL EPSILONT1(A4Q,K1,EA4QK1) DO NU = 0,3 C VOUT(NU) = CF*(K00*EA4QK1(NU) - 2*EA4QK0K1*K0(NU) > + 2*K0K1*TRACEV4Q*K0(NU) - 2*V4QWK0K1*K0(NU) - 2*V4QWK1K0*K0(NU) > - K00*TRACEV4Q*K1(NU) + K00*V4QIK1(NU) + K00*V4QK1I(NU)) VOUT(NU) = VOUT(NU)*PREFACTOR C ENDDO C ELSE IF (QQGVERTS.AND.LEFT) THEN C C--- TK00 = 0.0D0 DO MU = 1,3 TK00 = TK00 - K0(MU)**2 ENDDO E0 = K0(0) K00 = E0**2 + TK00 PREFACTOR = 1.0D0/K00**2 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 DO MU = 1,3 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 ENDDO K33 = E3**2 + TK33 K44 = E4**2 + TK44 IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF DO MU = 0,3 K3PT(1,MU) = -K5(MU) K3PT(2,MU) = -K1(MU) K3PT(3,MU) = K2(MU) ENDDO CUT3PT(1) = CUT(5) CUT3PT(2) = CUT(1) CUT3PT(3) = CUT(2) KIND3PT = 'QQG/QQG' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V5Q,A5Q) TRACEV5Q = 0.0D0 DO MU = 0,3 TRACEV5Q = TRACEV5Q + V5Q(MU,MU)*METRIC(MU) ENDDO V5QWK0K4 = 0.0D0 V5QWK4K0 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V5QWK0K4 = V5QWK0K4 > + V5Q(MU,NU)*K0(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V5QWK4K0 = V5QWK4K0 > + V5Q(MU,NU)*K4(MU)*K0(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 V5QIK4(MU) = 0.0D0 V5QK4I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 V5QIK4(MU) = V5QIK4(MU) + V5Q(MU,NU)*K4(NU)*METRIC(NU) V5QK4I(MU) = V5QK4I(MU) + V5Q(NU,MU)*K4(NU)*METRIC(NU) ENDDO ENDDO K0K4 = 0.0D0 DO MU = 0,3 K0K4 = K0K4 + K0(MU)*K4(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A5Q,K0,K4,EA5QK0K4) CALL EPSILONT1(A5Q,K4,EA5QK4) DO NU = 0,3 C VOUT(NU) = -(CF*(K00*EA5QK4(NU) - 2*EA5QK0K4*K0(NU) > - 2*K0K4*TRACEV5Q*K0(NU) + 2*V5QWK0K4*K0(NU) + 2*V5QWK4K0*K0(NU) > + K00*TRACEV5Q*K4(NU) - K00*V5QIK4(NU) - K00*V5QK4I(NU))) VOUT(NU) = VOUT(NU)*PREFACTOR C ENDDO C ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN C C--- TK00 = 0.0D0 DO MU = 1,3 TK00 = TK00 - K0(MU)**2 ENDDO E0 = K0(0) K00 = E0**2 + TK00 PREFACTOR = 1.0D0/K00**2 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF DO MU = 0,3 K3PT(1,MU) = -K4(MU) K3PT(2,MU) = -K5(MU) K3PT(3,MU) = K3(MU) ENDDO CUT3PT(1) = CUT(4) CUT3PT(2) = CUT(5) CUT3PT(3) = CUT(3) KIND3PT = 'QQG/GGQ' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V4G,A4G) TRACEV4G = 0.0D0 DO MU = 0,3 TRACEV4G = TRACEV4G + V4G(MU,MU)*METRIC(MU) ENDDO V4GWK0K1 = 0.0D0 V4GWK1K0 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V4GWK0K1 = V4GWK0K1 > + V4G(MU,NU)*K0(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4GWK1K0 = V4GWK1K0 > + V4G(MU,NU)*K1(MU)*K0(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 V4GIK1(MU) = 0.0D0 V4GK1I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 V4GIK1(MU) = V4GIK1(MU) + V4G(MU,NU)*K1(NU)*METRIC(NU) V4GK1I(MU) = V4GK1I(MU) + V4G(NU,MU)*K1(NU)*METRIC(NU) ENDDO ENDDO K0K1 = 0.0D0 DO MU = 0,3 K0K1 = K0K1 + K0(MU)*K1(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A4G,K0,K1,EA4GK0K1) CALL EPSILONT1(A4G,K1,EA4GK1) DO NU = 0,3 C VOUT(NU) = CF*(K00*EA4GK1(NU) - 2*EA4GK0K1*K0(NU) > + 2*K0K1*TRACEV4G*K0(NU) - 2*V4GWK0K1*K0(NU) - 2*V4GWK1K0*K0(NU) > - K00*TRACEV4G*K1(NU) + K00*V4GIK1(NU) + K00*V4GK1I(NU)) VOUT(NU) = VOUT(NU)*PREFACTOR C ENDDO C ELSE IF (TRIPLEGLUE.AND.LEFT) THEN C C--- TK00 = 0.0D0 DO MU = 1,3 TK00 = TK00 - K0(MU)**2 ENDDO E0 = K0(0) K00 = E0**2 + TK00 PREFACTOR = 1.0D0/K00**2 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 DO MU = 1,3 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 ENDDO K33 = E3**2 + TK33 K44 = E4**2 + TK44 IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF DO MU = 0,3 K3PT(1,MU) = K5(MU) K3PT(2,MU) = -K2(MU) K3PT(3,MU) = K1(MU) ENDDO CUT3PT(1) = CUT(5) CUT3PT(2) = CUT(2) CUT3PT(3) = CUT(1) KIND3PT = 'QQG/GGQ' CALL VERTEXF(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V5G,A5G) TRACEV5G = 0.0D0 DO MU = 0,3 TRACEV5G = TRACEV5G + V5G(MU,MU)*METRIC(MU) ENDDO V5GWK0K3 = 0.0D0 V5GWK3K0 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V5GWK0K3 = V5GWK0K3 > + V5G(MU,NU)*K0(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V5GWK3K0 = V5GWK3K0 > + V5G(MU,NU)*K3(MU)*K0(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 V5GIK3(MU) = 0.0D0 V5GK3I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 V5GIK3(MU) = V5GIK3(MU) + V5G(MU,NU)*K3(NU)*METRIC(NU) V5GK3I(MU) = V5GK3I(MU) + V5G(NU,MU)*K3(NU)*METRIC(NU) ENDDO ENDDO K0K3 = 0.0D0 DO MU = 0,3 K0K3 = K0K3 + K0(MU)*K3(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A5G,K0,K3,EA5GK0K3) CALL EPSILONT1(A5G,K3,EA5GK3) DO NU = 0,3 C VOUT(NU) = -(CF*(K00*EA5GK3(NU) - 2*EA5GK0K3*K0(NU) > - 2*K0K3*TRACEV5G*K0(NU) + 2*V5GWK0K3*K0(NU) + 2*V5GWK3K0*K0(NU) > + K00*TRACEV5G*K3(NU) - K00*V5GIK3(NU) - K00*V5GK3I(NU))) VOUT(NU) = VOUT(NU)*PREFACTOR C ENDDO ELSE WRITE(*,*)'Not programmed for that' STOP ENDIF C C------------- C C Alternative for IF (OVERLAP) THEN. C ELSE IF (NESTED) THEN C C We have a nested graph. C DO MU = 0,3 K2PT(0,MU) = K2PT2(2,MU) K2PT(1,MU) = K2PT2(4,MU) K2PT(2,MU) = K2PT2(5,MU) Q(MU) = K2PT2(0,MU) K1(MU) = K2PT2(1,MU) ENDDO OMEGASQ = Q(1)**2 + Q(2)**2 + Q(3)**2 QSQ = Q(0)**2 - OMEGASQ OMEGA1SQ = K1(1)**2 + K1(2)**2 + K1(3)**2 C CUT2PT(0) = CUT2PT2(2) CUT2PT(1) = CUT2PT2(4) CUT2PT(2) = CUT2PT2(5) CUT2PT(3) = CUT2PT2(3) C C We need the factor equal to 1/k^2 for an uncut propagator C and 1/ 2|\vec k| for a cut propagator. BUT line 1 is always C cut, propagator 0 never cut, and the one-loop two point function C that is nested inside has the factor for propagators 2,3,4,5. C PREFACTOR = CF/(QSQ**2*2.0D0*COMPLEXSQRT(OMEGA1SQ)) C IF (NESTEDGLUE) THEN C C Our nested graph has a gluon self-energy insertion. C Calculate OUTG according to what kind of self-energy insertion it is. C IF (GLUELOOP) THEN KIND2PT = 'GLUONLOOP' CALL TWOPOINTGF(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUTG) ELSE IF (QUARKLOOP) THEN KIND2PT = 'QUARKLOOP' CALL TWOPOINTGF(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUTG) ENDIF C C Now comlete the calculation for a gluon self-energy insertion. C DO ALPHA = 0,3 TEMP = 0.0D0 DO NU = 0,3 TEMP = TEMP + OUTG(ALPHA,NU)*K1(NU)*METRIC(NU) ENDDO MK1(ALPHA) = TEMP ENDDO C TRACEM = 0.0D0 DOTQK1 = 0.0D0 DO MU = 0,3 TRACEM = TRACEM + OUTG(MU,MU)*METRIC(MU) DOTQK1 = DOTQK1 + Q(MU)*K1(MU)*METRIC(MU) ENDDO C MQK1 = 0.0D0 DO MU = 0,3 DO NU = 0,3 MQK1 = MQK1 + OUTG(MU,NU)*Q(MU)*K1(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO C DO ALPHA = 0,3 TEMP = - 2.0D0*QSQ*MK1(ALPHA) TEMP = TEMP + 4.0D0*Q(ALPHA)*MQK1 TEMP = TEMP + (QSQ*K1(ALPHA) - 2.0D0*Q(ALPHA)*DOTQK1)*TRACEM VOUT(ALPHA) = PREFACTOR*TEMP ENDDO C C Alternative for IF (NESTEDGLUE) THEN C ELSE IF (NESTEDQUARK) THEN C C Our nested graph has a quark self-energy insertion. C Calculate OUTQ. C CALL TWOPOINTQF(K2PT,CUT2PT,MUMSBAR,FLAG,OUTQ) C C Now comlete the calculation for a quark self-energy insertion. C C The gluon propagator in *FEYNMAN* gauge for an on-shell gluon C with three-momentum K1(mu). C BAREPROP(0,0) = -1.0D0 DO MU = 1,3 BAREPROP(0,MU) = 0.0D0 BAREPROP(MU,0) = 0.0D0 BAREPROP(MU,MU) = 1.0D0 DO NU = MU+1,3 TEMP =0.0D0 BAREPROP(MU,NU) = TEMP BAREPROP(NU,MU) = TEMP ENDDO ENDDO TRACEBAREPROP = -4.0D0 C DO ALPHA = 0,3 DM(ALPHA) = 0.0D0 DO NU = 0,3 DM(ALPHA) = DM(ALPHA) + BAREPROP(ALPHA,NU)*OUTQ(NU)*METRIC(NU) ENDDO ENDDO C DQM = 0.0D0 QM = 0.0D0 DO MU = 0,3 QM = QM + Q(MU)*OUTQ(MU)*METRIC(MU) DO NU = 0,3 DQM = DQM + BAREPROP(MU,NU)*Q(MU)*OUTQ(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO C DO ALPHA = 0,3 TEMP = - 2.0D0*QSQ*DM(ALPHA) TEMP = TEMP + 4.0D0*Q(ALPHA)*DQM TEMP = TEMP > + (QSQ*OUTQ(ALPHA) - 2.0D0*Q(ALPHA)*QM)*TRACEBAREPROP VOUT(ALPHA) = PREFACTOR*TEMP ENDDO C C Close IF (NESTEDGLUE) THEN ... ELSEIF (NESTEDQUARK) THEN C ELSE WRITE(NOUT,*)'Oops, something must have gone wrong.' STOP ENDIF C C Close IF (OVERLAP) THEN ... ELSE IF (NESTED) THEN C ELSE WRITE(NOUT,*)'Oops, something has gone wrong.' STOP ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C C C Feynman integrand in Coulomb gauge C C C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C COMPLEX*16 FUNCTION FEYNMAN(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) C C In: INTEGER SIZE PARAMETER (SIZE = 3) INTEGER GRAPHNUMBER COMPLEX*16 KC(0:3*SIZE-1,0:3) LOGICAL CUT(3*SIZE-1) REAL*8 MUMSBAR CHARACTER*16 FLAG C C Feynman integrand function for graph GRAPHNUMBER C with complex momenta KC and cut specified by CUT. C Early version: 17 July 1994. C This version written by Mathematica code of 4 January 2002 on C 4 Jan 2002. C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF C REAL*8 METRIC(0:3) DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/ COMPLEX*16 GN(0:3) DATA GN /+1.0D0,0.0D0,0.0D0,0.0D0/ C REAL*8 CF COMPLEX*16 COMPLEXSQRT INTEGER MU,NU,TAU COMPLEX*16 X(256) COMPLEX*16 K1(0:3),K2(0:3),K3(0:3),K4(0:3) COMPLEX*16 K5(0:3),K6(0:3),K7(0:3),K8(0:3) COMPLEX*16 E1,E2,E3,E4,E5,E6,E7,E8 COMPLEX*16 K11,K22,K33,K44,K55,K66,K77,K88 COMPLEX*16 TK11,TK22,TK33,TK44,TK55,TK66,TK77,TK88 COMPLEX*16 PREFACTOR CHARACTER*13 KIND2PT2 COMPLEX*16 K2PT2(0:5,0:3) LOGICAL CUT2PT2(1:5) CHARACTER*9 KIND2PT COMPLEX*16 K2PT(0:2,0:3) LOGICAL CUT2PT(0:3) CHARACTER*7 KIND3PT COMPLEX*16 K3PT(3,0:3) LOGICAL CUT3PT(3) C COMPLEX*16 A1QDA4Q,A1QIK6A4QIK7,A1QIK7A4QIK6,EA1QK3Q47 COMPLEX*16 EA1QZV4QK6K7,EA2QK3Q67,EA3QK1Q26,EA4QK1Q86 COMPLEX*16 EA4QZV1QK6K7,EA7AGNIK1K2K4,EA7AGNIK2K3K4,EA7AK1IK2K3K4 COMPLEX*16 EA7AK1K2,EA7AK1K3,EA7AK1K4,EA7AK2IK1K3K4,EA7AK2K3 COMPLEX*16 EA7AK2K4,EA7AK3IK1K2K4,EA7AK3K4,EA7AK4IK1K2K3 COMPLEX*16 EA7AK5IGNK1K2,EA7AK5IGNK1K3,EA7AK5IGNK1K4 COMPLEX*16 EA7AK5IGNK2K3,EA7AK5IGNK2K4,EA7AK5IGNK3K4 COMPLEX*16 EA7AK5IK1K2K3,EA7AK5IK1K2K4,EA7AK5IK1K3K4 COMPLEX*16 EA7AK5IK2K3K4,EA8AGNIK1K2K4,EA8AGNIK2K3K4 COMPLEX*16 EA8AK1IK2K3K4,EA8AK1K2,EA8AK1K3,EA8AK1K4,EA8AK2IK1K3K4 COMPLEX*16 EA8AK2K3,EA8AK2K4,EA8AK3IK1K2K4,EA8AK3K4,EA8AK4IK1K2K3 COMPLEX*16 EA8AK5IGNK1K2,EA8AK5IGNK1K3,EA8AK5IGNK1K4 COMPLEX*16 EA8AK5IGNK2K3,EA8AK5IGNK2K4,EA8AK5IGNK3K4 COMPLEX*16 EA8AK5IK1K2K3,EA8AK5IK1K2K4,EA8AK5IK1K3K4 COMPLEX*16 EA8AK5IK2K3K4,G7AWK1K2,G7AWK1K3,G7AWK2K4,G7AWK3K4,K1K2 COMPLEX*16 K1K3,K1K4,K1K6,K1K7,K1Q24,K1Q26,K1Q36,K1Q84,K1Q86 COMPLEX*16 K1QQNB45,K1QQNB46,K1QQNG45,K1QQNG46,K1QQNQ45,K1QQNQ46 COMPLEX*16 K1QQOG57,K1QQOG75,K1QQOQ57,K1QQOQ64,K2K3,K2K4,K2K6 COMPLEX*16 K2K7,K2Q24,K2Q36,K2Q84,K2Q86,K3K4,K3K6,K3K7,K3Q47 COMPLEX*16 K3Q67,K4K6,K4K7,K6K7,Q15Q47,Q24Q86,Q36Q84,TRACEG7A COMPLEX*16 TRACEV1Q,TRACEV2Q,TRACEV3Q,TRACEV4Q,TRACEV7A,TRACEV8A COMPLEX*16 V1QDV4Q,V1QIK6V4QIK7,V1QIK7V4QIK6,V1QWK3Q47,V1QWQ47K3 COMPLEX*16 V2QWK3Q67,V2QWQ67K3,V3QWK1Q26,V3QWQ26K1,V4QWK1Q86 COMPLEX*16 V4QWQ86K1,V7AWGNK1,V7AWGNK2,V7AWGNK3,V7AWGNK4,V7AWK1K2 COMPLEX*16 V7AWK1K3,V7AWK1K4,V7AWK2K1,V7AWK2K3,V7AWK2K4,V7AWK3K1 COMPLEX*16 V7AWK3K2,V7AWK3K4,V7AWK4K1,V7AWK4K2,V7AWK4K3,V7AWK5GN COMPLEX*16 V7AWK5K1,V7AWK5K2,V7AWK5K3,V7AWK5K4,V8AWGNK1,V8AWGNK2 COMPLEX*16 V8AWGNK3,V8AWGNK4,V8AWK1K2,V8AWK1K3,V8AWK1K4,V8AWK2K1 COMPLEX*16 V8AWK2K3,V8AWK2K4,V8AWK3K1,V8AWK3K2,V8AWK3K4,V8AWK4K1 COMPLEX*16 V8AWK4K2,V8AWK4K3,V8AWK5GN,V8AWK5K1,V8AWK5K2,V8AWK5K3 COMPLEX*16 V8AWK5K4,A1QIK6(0:3),A1QIK7(0:3),A4QIK6(0:3) COMPLEX*16 A4QIK7(0:3),A7AGNI(0:3),A7AK1I(0:3),A7AK2I(0:3) COMPLEX*16 A7AK3I(0:3),A7AK4I(0:3),A7AK5I(0:3),A8AGNI(0:3) COMPLEX*16 A8AK1I(0:3),A8AK2I(0:3),A8AK3I(0:3),A8AK4I(0:3) COMPLEX*16 A8AK5I(0:3),Q15(0:3),Q24(0:3),Q26(0:3),Q36(0:3) COMPLEX*16 Q47(0:3),Q67(0:3),Q84(0:3),Q86(0:3),QQNB45(0:3) COMPLEX*16 QQNB46(0:3),QQNG45(0:3),QQNG46(0:3),QQNQ45(0:3) COMPLEX*16 QQNQ46(0:3),QQOG57(0:3),QQOG75(0:3),QQOQ57(0:3) COMPLEX*16 QQOQ64(0:3),V1QIK6(0:3),V1QIK7(0:3),V4QIK6(0:3) COMPLEX*16 V4QIK7(0:3),A1Q(0:3,0:3),A1QZV4Q(0:3,0:3),A2Q(0:3,0:3) COMPLEX*16 A3Q(0:3,0:3),A4Q(0:3,0:3),A4QZV1Q(0:3,0:3) COMPLEX*16 A7A(0:3,0:3),A8A(0:3,0:3),G7A(0:3,0:3),V1Q(0:3,0:3) COMPLEX*16 V2Q(0:3,0:3),V3Q(0:3,0:3),V4Q(0:3,0:3),V7A(0:3,0:3) COMPLEX*16 V8A(0:3,0:3) C DO MU = 0,3 K1(MU) = KC(1,MU) K2(MU) = KC(2,MU) K3(MU) = KC(3,MU) K4(MU) = KC(4,MU) K5(MU) = KC(5,MU) K6(MU) = KC(6,MU) K7(MU) = KC(7,MU) K8(MU) = KC(8,MU) ENDDO CF = (NC**2 - 1.0D0)/2.0D0/NC FEYNMAN = 0.0D0 C C------ C IF (GRAPHNUMBER .EQ. 1) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 ENDDO K11 = E1**2 + TK11 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K4(MU) K2PT2(2,MU) = K5(MU) K2PT2(3,MU) = -K6(MU) K2PT2(4,MU) = K7(MU) K2PT2(5,MU) = K8(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(5) CUT2PT2(3) = CUT(6) CUT2PT2(4) = CUT(7) CUT2PT2(5) = CUT(8) KIND2PT2 = 'NESTED /GQQGQ' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNB46) DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K4(MU) K2PT2(2,MU) = K5(MU) K2PT2(3,MU) = -K6(MU) K2PT2(4,MU) = K7(MU) K2PT2(5,MU) = K8(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(5) CUT2PT2(3) = CUT(6) CUT2PT2(4) = CUT(7) CUT2PT2(5) = CUT(8) KIND2PT2 = 'NESTED /QGGGG' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNG46) DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K4(MU) K2PT2(2,MU) = K5(MU) K2PT2(3,MU) = -K6(MU) K2PT2(4,MU) = K8(MU) K2PT2(5,MU) = K7(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(5) CUT2PT2(3) = CUT(6) CUT2PT2(4) = CUT(8) CUT2PT2(5) = CUT(7) KIND2PT2 = 'NESTED /QGGQQ' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNQ46) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = -K4(MU) K2PT2(2,MU) = K6(MU) K2PT2(3,MU) = -K5(MU) K2PT2(4,MU) = -K7(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(6) CUT2PT2(3) = CUT(5) CUT2PT2(4) = CUT(7) CUT2PT2(5) = CUT(8) KIND2PT2 = 'NESTED /GQQGQ' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNB45) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = -K4(MU) K2PT2(2,MU) = K6(MU) K2PT2(3,MU) = -K5(MU) K2PT2(4,MU) = -K7(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(6) CUT2PT2(3) = CUT(5) CUT2PT2(4) = CUT(7) CUT2PT2(5) = CUT(8) KIND2PT2 = 'NESTED /QGGQQ' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNQ45) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = -K4(MU) K2PT2(2,MU) = K6(MU) K2PT2(3,MU) = -K5(MU) K2PT2(4,MU) = -K8(MU) K2PT2(5,MU) = -K7(MU) ENDDO CUT2PT2(1) = CUT(4) CUT2PT2(2) = CUT(6) CUT2PT2(3) = CUT(5) CUT2PT2(4) = CUT(8) CUT2PT2(5) = CUT(7) KIND2PT2 = 'NESTED /QGGGG' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQNG45) K1QQNB45 = 0.0D0 K1QQNB46 = 0.0D0 K1QQNG45 = 0.0D0 K1QQNG46 = 0.0D0 K1QQNQ45 = 0.0D0 K1QQNQ46 = 0.0D0 DO MU = 0,3 K1QQNB45 = K1QQNB45 + K1(MU)*QQNB45(MU)*METRIC(MU) K1QQNB46 = K1QQNB46 + K1(MU)*QQNB46(MU)*METRIC(MU) K1QQNG45 = K1QQNG45 + K1(MU)*QQNG45(MU)*METRIC(MU) K1QQNG46 = K1QQNG46 + K1(MU)*QQNG46(MU)*METRIC(MU) K1QQNQ45 = K1QQNQ45 + K1(MU)*QQNQ45(MU)*METRIC(MU) K1QQNQ46 = K1QQNQ46 + K1(MU)*QQNQ46(MU)*METRIC(MU) ENDDO FEYNMAN = -8*(K1QQNB45 - K1QQNB46 + K1QQNG45 - K1QQNG46 > + K1QQNQ45 - K1QQNQ46)*NC FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 2) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 ENDDO K11 = E1**2 + TK11 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF DO MU = 0,3 K2PT(0,MU) = K2(MU) K2PT(1,MU) = K4(MU) K2PT(2,MU) = K5(MU) ENDDO CUT2PT(0) = CUT(2) CUT2PT(1) = CUT(4) CUT2PT(2) = CUT(5) CUT2PT(3) = CUT(8) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q24) DO MU = 0,3 K2PT(0,MU) = K3(MU) K2PT(1,MU) = K6(MU) K2PT(2,MU) = K7(MU) ENDDO CUT2PT(0) = CUT(3) CUT2PT(1) = CUT(6) CUT2PT(2) = CUT(7) CUT2PT(3) = CUT(8) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q36) DO MU = 0,3 K2PT(0,MU) = -K8(MU) K2PT(1,MU) = -K4(MU) K2PT(2,MU) = -K5(MU) ENDDO CUT2PT(0) = CUT(8) CUT2PT(1) = CUT(4) CUT2PT(2) = CUT(5) CUT2PT(3) = CUT(2) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q84) DO MU = 0,3 K2PT(0,MU) = K8(MU) K2PT(1,MU) = -K6(MU) K2PT(2,MU) = -K7(MU) ENDDO CUT2PT(0) = CUT(8) CUT2PT(1) = CUT(6) CUT2PT(2) = CUT(7) CUT2PT(3) = CUT(3) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q86) K1K2 = 0.0D0 K1Q24 = 0.0D0 K1Q36 = 0.0D0 K1Q84 = 0.0D0 K1Q86 = 0.0D0 K2Q24 = 0.0D0 K2Q36 = 0.0D0 K2Q84 = 0.0D0 K2Q86 = 0.0D0 Q24Q86 = 0.0D0 Q36Q84 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1Q24 = K1Q24 + K1(MU)*Q24(MU)*METRIC(MU) K1Q36 = K1Q36 + K1(MU)*Q36(MU)*METRIC(MU) K1Q84 = K1Q84 + K1(MU)*Q84(MU)*METRIC(MU) K1Q86 = K1Q86 + K1(MU)*Q86(MU)*METRIC(MU) K2Q24 = K2Q24 + K2(MU)*Q24(MU)*METRIC(MU) K2Q36 = K2Q36 + K2(MU)*Q36(MU)*METRIC(MU) K2Q84 = K2Q84 + K2(MU)*Q84(MU)*METRIC(MU) K2Q86 = K2Q86 + K2(MU)*Q86(MU)*METRIC(MU) Q24Q86 = Q24Q86 + Q24(MU)*Q86(MU)*METRIC(MU) Q36Q84 = Q36Q84 + Q36(MU)*Q84(MU)*METRIC(MU) ENDDO FEYNMAN = 8*NC*(K1Q86*K2Q24 + K1Q84*K2Q36 + K1Q36*K2Q84 > + K1Q24*K2Q86 - K1K2*Q24Q86 - K1K2*Q36Q84) FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 3) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 ENDDO K11 = E1**2 + TK11 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K5(MU) K2PT2(2,MU) = K4(MU) K2PT2(3,MU) = -K7(MU) K2PT2(4,MU) = -K6(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(5) CUT2PT2(2) = CUT(4) CUT2PT2(3) = CUT(7) CUT2PT2(4) = CUT(6) CUT2PT2(5) = CUT(8) KIND2PT2 = 'OVERLAP/QGGQQ' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQOQ57) DO MU = 0,3 K2PT2(0,MU) = K2(MU) K2PT2(1,MU) = K5(MU) K2PT2(2,MU) = K4(MU) K2PT2(3,MU) = -K7(MU) K2PT2(4,MU) = -K6(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(5) CUT2PT2(2) = CUT(4) CUT2PT2(3) = CUT(7) CUT2PT2(4) = CUT(6) CUT2PT2(5) = CUT(8) KIND2PT2 = 'OVERLAP/QGQGG' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQOG57) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = K6(MU) K2PT2(2,MU) = K7(MU) K2PT2(3,MU) = -K4(MU) K2PT2(4,MU) = -K5(MU) K2PT2(5,MU) = K8(MU) ENDDO CUT2PT2(1) = CUT(6) CUT2PT2(2) = CUT(7) CUT2PT2(3) = CUT(4) CUT2PT2(4) = CUT(5) CUT2PT2(5) = CUT(8) KIND2PT2 = 'OVERLAP/QGGQQ' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQOQ64) DO MU = 0,3 K2PT2(0,MU) = K3(MU) K2PT2(1,MU) = K7(MU) K2PT2(2,MU) = K6(MU) K2PT2(3,MU) = -K5(MU) K2PT2(4,MU) = -K4(MU) K2PT2(5,MU) = -K8(MU) ENDDO CUT2PT2(1) = CUT(7) CUT2PT2(2) = CUT(6) CUT2PT2(3) = CUT(5) CUT2PT2(4) = CUT(4) CUT2PT2(5) = CUT(8) KIND2PT2 = 'OVERLAP/QGQGG' CALL TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,QQOG75) K1QQOG57 = 0.0D0 K1QQOG75 = 0.0D0 K1QQOQ57 = 0.0D0 K1QQOQ64 = 0.0D0 DO MU = 0,3 K1QQOG57 = K1QQOG57 + K1(MU)*QQOG57(MU)*METRIC(MU) K1QQOG75 = K1QQOG75 + K1(MU)*QQOG75(MU)*METRIC(MU) K1QQOQ57 = K1QQOQ57 + K1(MU)*QQOQ57(MU)*METRIC(MU) K1QQOQ64 = K1QQOQ64 + K1(MU)*QQOQ64(MU)*METRIC(MU) ENDDO FEYNMAN = 8*(K1QQOG57 - K1QQOG75 + K1QQOQ57 - K1QQOQ64)*NC FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 4) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF DO MU = 0,3 K2PT(0,MU) = K5(MU) K2PT(1,MU) = K7(MU) K2PT(2,MU) = K8(MU) ENDDO CUT2PT(0) = CUT(5) CUT2PT(1) = CUT(7) CUT2PT(2) = CUT(8) CUT2PT(3) = CUT(6) KIND2PT = 'BOTHLOOPS' CALL TWOPOINTG(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,G7A) TRACEG7A = 0.0D0 DO MU = 0,3 TRACEG7A = TRACEG7A + G7A(MU,MU)*METRIC(MU) ENDDO G7AWK1K2 = 0.0D0 G7AWK1K3 = 0.0D0 G7AWK2K4 = 0.0D0 G7AWK3K4 = 0.0D0 DO MU = 0,3 DO NU = 0,3 G7AWK1K2 = G7AWK1K2 > + G7A(MU,NU)*K1(MU)*K2(NU)*METRIC(MU)*METRIC(NU) G7AWK1K3 = G7AWK1K3 > + G7A(MU,NU)*K1(MU)*K3(NU)*METRIC(MU)*METRIC(NU) G7AWK2K4 = G7AWK2K4 > + G7A(MU,NU)*K2(MU)*K4(NU)*METRIC(MU)*METRIC(NU) G7AWK3K4 = G7AWK3K4 > + G7A(MU,NU)*K3(MU)*K4(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO K1K2 = 0.0D0 K1K3 = 0.0D0 K1K4 = 0.0D0 K2K3 = 0.0D0 K2K4 = 0.0D0 K3K4 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1K3 = K1K3 + K1(MU)*K3(MU)*METRIC(MU) K1K4 = K1K4 + K1(MU)*K4(MU)*METRIC(MU) K2K3 = K2K3 + K2(MU)*K3(MU)*METRIC(MU) K2K4 = K2K4 + K2(MU)*K4(MU)*METRIC(MU) K3K4 = K3K4 + K3(MU)*K4(MU)*METRIC(MU) ENDDO FEYNMAN = -8*CF*NC*(2*G7AWK3K4*K1K2 - 2*G7AWK2K4*K1K3 > - 2*G7AWK1K3*K2K4 + 2*G7AWK1K2*K3K4 + K1K4*K2K3*TRACEG7A > + K1K3*K2K4*TRACEG7A - K1K2*K3K4*TRACEG7A) FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 5) THEN C PREFACTOR = 1.0D0 E3 = K3(0) TK33 = 0.0D0 DO MU = 1,3 TK33 = TK33 - K3(MU)**2 ENDDO K33 = E3**2 + TK33 IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF DO MU = 0,3 K3PT(1,MU) = -K1(MU) K3PT(2,MU) = K2(MU) K3PT(3,MU) = -K5(MU) ENDDO CUT3PT(1) = CUT(1) CUT3PT(2) = CUT(2) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V1Q,A1Q) DO MU = 0,3 K3PT(1,MU) = -K2(MU) K3PT(2,MU) = K1(MU) K3PT(3,MU) = K5(MU) ENDDO CUT3PT(1) = CUT(2) CUT3PT(2) = CUT(1) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V2Q,A2Q) DO MU = 0,3 K2PT(0,MU) = K4(MU) K2PT(1,MU) = K7(MU) K2PT(2,MU) = K8(MU) ENDDO CUT2PT(0) = CUT(4) CUT2PT(1) = CUT(7) CUT2PT(2) = CUT(8) CUT2PT(3) = CUT(6) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q47) DO MU = 0,3 K2PT(0,MU) = K6(MU) K2PT(1,MU) = -K7(MU) K2PT(2,MU) = -K8(MU) ENDDO CUT2PT(0) = CUT(6) CUT2PT(1) = CUT(7) CUT2PT(2) = CUT(8) CUT2PT(3) = CUT(4) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q67) TRACEV1Q = 0.0D0 TRACEV2Q = 0.0D0 DO MU = 0,3 TRACEV1Q = TRACEV1Q + V1Q(MU,MU)*METRIC(MU) TRACEV2Q = TRACEV2Q + V2Q(MU,MU)*METRIC(MU) ENDDO V1QWK3Q47 = 0.0D0 V1QWQ47K3 = 0.0D0 V2QWK3Q67 = 0.0D0 V2QWQ67K3 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V1QWK3Q47 = V1QWK3Q47 > + V1Q(MU,NU)*K3(MU)*Q47(NU)*METRIC(MU)*METRIC(NU) V1QWQ47K3 = V1QWQ47K3 > + V1Q(MU,NU)*Q47(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V2QWK3Q67 = V2QWK3Q67 > + V2Q(MU,NU)*K3(MU)*Q67(NU)*METRIC(MU)*METRIC(NU) V2QWQ67K3 = V2QWQ67K3 > + V2Q(MU,NU)*Q67(MU)*K3(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO K3Q47 = 0.0D0 K3Q67 = 0.0D0 DO MU = 0,3 K3Q47 = K3Q47 + K3(MU)*Q47(MU)*METRIC(MU) K3Q67 = K3Q67 + K3(MU)*Q67(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A1Q,K3,Q47,EA1QK3Q47) CALL EPSILONT2(A2Q,K3,Q67,EA2QK3Q67) FEYNMAN = -4*NC*(EA1QK3Q47 + EA2QK3Q67 - K3Q47*TRACEV1Q > + K3Q67*TRACEV2Q + V1QWK3Q47 + V1QWQ47K3 - V2QWK3Q67 - V2QWQ67K3) FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 6) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 ENDDO K11 = E1**2 + TK11 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF DO MU = 0,3 K3PT(1,MU) = -K3(MU) K3PT(2,MU) = K4(MU) K3PT(3,MU) = -K5(MU) ENDDO CUT3PT(1) = CUT(3) CUT3PT(2) = CUT(4) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V3Q,A3Q) DO MU = 0,3 K3PT(1,MU) = -K4(MU) K3PT(2,MU) = K3(MU) K3PT(3,MU) = K5(MU) ENDDO CUT3PT(1) = CUT(4) CUT3PT(2) = CUT(3) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V4Q,A4Q) DO MU = 0,3 K2PT(0,MU) = K2(MU) K2PT(1,MU) = K6(MU) K2PT(2,MU) = K7(MU) ENDDO CUT2PT(0) = CUT(2) CUT2PT(1) = CUT(6) CUT2PT(2) = CUT(7) CUT2PT(3) = CUT(8) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q26) DO MU = 0,3 K2PT(0,MU) = K8(MU) K2PT(1,MU) = -K6(MU) K2PT(2,MU) = -K7(MU) ENDDO CUT2PT(0) = CUT(8) CUT2PT(1) = CUT(6) CUT2PT(2) = CUT(7) CUT2PT(3) = CUT(2) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q86) TRACEV3Q = 0.0D0 TRACEV4Q = 0.0D0 DO MU = 0,3 TRACEV3Q = TRACEV3Q + V3Q(MU,MU)*METRIC(MU) TRACEV4Q = TRACEV4Q + V4Q(MU,MU)*METRIC(MU) ENDDO V3QWK1Q26 = 0.0D0 V3QWQ26K1 = 0.0D0 V4QWK1Q86 = 0.0D0 V4QWQ86K1 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V3QWK1Q26 = V3QWK1Q26 > + V3Q(MU,NU)*K1(MU)*Q26(NU)*METRIC(MU)*METRIC(NU) V3QWQ26K1 = V3QWQ26K1 > + V3Q(MU,NU)*Q26(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4QWK1Q86 = V4QWK1Q86 > + V4Q(MU,NU)*K1(MU)*Q86(NU)*METRIC(MU)*METRIC(NU) V4QWQ86K1 = V4QWQ86K1 > + V4Q(MU,NU)*Q86(MU)*K1(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO K1Q26 = 0.0D0 K1Q86 = 0.0D0 DO MU = 0,3 K1Q26 = K1Q26 + K1(MU)*Q26(MU)*METRIC(MU) K1Q86 = K1Q86 + K1(MU)*Q86(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A3Q,K1,Q26,EA3QK1Q26) CALL EPSILONT2(A4Q,K1,Q86,EA4QK1Q86) FEYNMAN = -4*NC*(EA3QK1Q26 + EA4QK1Q86 - K1Q26*TRACEV3Q > + K1Q86*TRACEV4Q + V3QWK1Q26 + V3QWQ26K1 - V4QWK1Q86 - V4QWQ86K1) FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 7) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 E5 = K5(0) TK55 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 TK55 = TK55 - K5(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 K55 = E5**2 + TK55 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF IF (CUT(5)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55) ELSE PREFACTOR = PREFACTOR/K55 ENDIF DO MU = 0,3 K3PT(1,MU) = K7(MU) K3PT(2,MU) = -K8(MU) K3PT(3,MU) = -K6(MU) ENDDO CUT3PT(1) = CUT(7) CUT3PT(2) = CUT(8) CUT3PT(3) = CUT(6) KIND3PT = 'QQG/ALL' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V7A,A7A) DO MU = 0,3 K3PT(1,MU) = K8(MU) K3PT(2,MU) = -K7(MU) K3PT(3,MU) = K6(MU) ENDDO CUT3PT(1) = CUT(8) CUT3PT(2) = CUT(7) CUT3PT(3) = CUT(6) KIND3PT = 'QQG/ALL' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V8A,A8A) TRACEV7A = 0.0D0 TRACEV8A = 0.0D0 DO MU = 0,3 TRACEV7A = TRACEV7A + V7A(MU,MU)*METRIC(MU) TRACEV8A = TRACEV8A + V8A(MU,MU)*METRIC(MU) ENDDO V7AWGNK1 = 0.0D0 V7AWGNK2 = 0.0D0 V7AWGNK3 = 0.0D0 V7AWGNK4 = 0.0D0 V7AWK1K2 = 0.0D0 V7AWK1K3 = 0.0D0 V7AWK1K4 = 0.0D0 V7AWK2K1 = 0.0D0 V7AWK2K3 = 0.0D0 V7AWK2K4 = 0.0D0 V7AWK3K1 = 0.0D0 V7AWK3K2 = 0.0D0 V7AWK3K4 = 0.0D0 V7AWK4K1 = 0.0D0 V7AWK4K2 = 0.0D0 V7AWK4K3 = 0.0D0 V7AWK5GN = 0.0D0 V7AWK5K1 = 0.0D0 V7AWK5K2 = 0.0D0 V7AWK5K3 = 0.0D0 V7AWK5K4 = 0.0D0 V8AWGNK1 = 0.0D0 V8AWGNK2 = 0.0D0 V8AWGNK3 = 0.0D0 V8AWGNK4 = 0.0D0 V8AWK1K2 = 0.0D0 V8AWK1K3 = 0.0D0 V8AWK1K4 = 0.0D0 V8AWK2K1 = 0.0D0 V8AWK2K3 = 0.0D0 V8AWK2K4 = 0.0D0 V8AWK3K1 = 0.0D0 V8AWK3K2 = 0.0D0 V8AWK3K4 = 0.0D0 V8AWK4K1 = 0.0D0 V8AWK4K2 = 0.0D0 V8AWK4K3 = 0.0D0 V8AWK5GN = 0.0D0 V8AWK5K1 = 0.0D0 V8AWK5K2 = 0.0D0 V8AWK5K3 = 0.0D0 V8AWK5K4 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V7AWGNK1 = V7AWGNK1 > + V7A(MU,NU)*GN(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V7AWGNK2 = V7AWGNK2 > + V7A(MU,NU)*GN(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V7AWGNK3 = V7AWGNK3 > + V7A(MU,NU)*GN(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V7AWGNK4 = V7AWGNK4 > + V7A(MU,NU)*GN(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V7AWK1K2 = V7AWK1K2 > + V7A(MU,NU)*K1(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V7AWK1K3 = V7AWK1K3 > + V7A(MU,NU)*K1(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V7AWK1K4 = V7AWK1K4 > + V7A(MU,NU)*K1(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V7AWK2K1 = V7AWK2K1 > + V7A(MU,NU)*K2(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V7AWK2K3 = V7AWK2K3 > + V7A(MU,NU)*K2(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V7AWK2K4 = V7AWK2K4 > + V7A(MU,NU)*K2(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V7AWK3K1 = V7AWK3K1 > + V7A(MU,NU)*K3(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V7AWK3K2 = V7AWK3K2 > + V7A(MU,NU)*K3(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V7AWK3K4 = V7AWK3K4 > + V7A(MU,NU)*K3(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V7AWK4K1 = V7AWK4K1 > + V7A(MU,NU)*K4(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V7AWK4K2 = V7AWK4K2 > + V7A(MU,NU)*K4(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V7AWK4K3 = V7AWK4K3 > + V7A(MU,NU)*K4(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V7AWK5GN = V7AWK5GN > + V7A(MU,NU)*K5(MU)*GN(NU)*METRIC(MU)*METRIC(NU) V7AWK5K1 = V7AWK5K1 > + V7A(MU,NU)*K5(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V7AWK5K2 = V7AWK5K2 > + V7A(MU,NU)*K5(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V7AWK5K3 = V7AWK5K3 > + V7A(MU,NU)*K5(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V7AWK5K4 = V7AWK5K4 > + V7A(MU,NU)*K5(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V8AWGNK1 = V8AWGNK1 > + V8A(MU,NU)*GN(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V8AWGNK2 = V8AWGNK2 > + V8A(MU,NU)*GN(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V8AWGNK3 = V8AWGNK3 > + V8A(MU,NU)*GN(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V8AWGNK4 = V8AWGNK4 > + V8A(MU,NU)*GN(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V8AWK1K2 = V8AWK1K2 > + V8A(MU,NU)*K1(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V8AWK1K3 = V8AWK1K3 > + V8A(MU,NU)*K1(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V8AWK1K4 = V8AWK1K4 > + V8A(MU,NU)*K1(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V8AWK2K1 = V8AWK2K1 > + V8A(MU,NU)*K2(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V8AWK2K3 = V8AWK2K3 > + V8A(MU,NU)*K2(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V8AWK2K4 = V8AWK2K4 > + V8A(MU,NU)*K2(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V8AWK3K1 = V8AWK3K1 > + V8A(MU,NU)*K3(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V8AWK3K2 = V8AWK3K2 > + V8A(MU,NU)*K3(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V8AWK3K4 = V8AWK3K4 > + V8A(MU,NU)*K3(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V8AWK4K1 = V8AWK4K1 > + V8A(MU,NU)*K4(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V8AWK4K2 = V8AWK4K2 > + V8A(MU,NU)*K4(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V8AWK4K3 = V8AWK4K3 > + V8A(MU,NU)*K4(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V8AWK5GN = V8AWK5GN > + V8A(MU,NU)*K5(MU)*GN(NU)*METRIC(MU)*METRIC(NU) V8AWK5K1 = V8AWK5K1 > + V8A(MU,NU)*K5(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V8AWK5K2 = V8AWK5K2 > + V8A(MU,NU)*K5(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V8AWK5K3 = V8AWK5K3 > + V8A(MU,NU)*K5(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V8AWK5K4 = V8AWK5K4 > + V8A(MU,NU)*K5(MU)*K4(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 A7AGNI(MU) = 0.0D0 A7AK1I(MU) = 0.0D0 A7AK2I(MU) = 0.0D0 A7AK3I(MU) = 0.0D0 A7AK4I(MU) = 0.0D0 A7AK5I(MU) = 0.0D0 A8AGNI(MU) = 0.0D0 A8AK1I(MU) = 0.0D0 A8AK2I(MU) = 0.0D0 A8AK3I(MU) = 0.0D0 A8AK4I(MU) = 0.0D0 A8AK5I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 A7AGNI(MU) = A7AGNI(MU) + A7A(NU,MU)*GN(NU)*METRIC(NU) A7AK1I(MU) = A7AK1I(MU) + A7A(NU,MU)*K1(NU)*METRIC(NU) A7AK2I(MU) = A7AK2I(MU) + A7A(NU,MU)*K2(NU)*METRIC(NU) A7AK3I(MU) = A7AK3I(MU) + A7A(NU,MU)*K3(NU)*METRIC(NU) A7AK4I(MU) = A7AK4I(MU) + A7A(NU,MU)*K4(NU)*METRIC(NU) A7AK5I(MU) = A7AK5I(MU) + A7A(NU,MU)*K5(NU)*METRIC(NU) A8AGNI(MU) = A8AGNI(MU) + A8A(NU,MU)*GN(NU)*METRIC(NU) A8AK1I(MU) = A8AK1I(MU) + A8A(NU,MU)*K1(NU)*METRIC(NU) A8AK2I(MU) = A8AK2I(MU) + A8A(NU,MU)*K2(NU)*METRIC(NU) A8AK3I(MU) = A8AK3I(MU) + A8A(NU,MU)*K3(NU)*METRIC(NU) A8AK4I(MU) = A8AK4I(MU) + A8A(NU,MU)*K4(NU)*METRIC(NU) A8AK5I(MU) = A8AK5I(MU) + A8A(NU,MU)*K5(NU)*METRIC(NU) ENDDO ENDDO K1K2 = 0.0D0 K1K3 = 0.0D0 K1K4 = 0.0D0 K2K3 = 0.0D0 K2K4 = 0.0D0 K3K4 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1K3 = K1K3 + K1(MU)*K3(MU)*METRIC(MU) K1K4 = K1K4 + K1(MU)*K4(MU)*METRIC(MU) K2K3 = K2K3 + K2(MU)*K3(MU)*METRIC(MU) K2K4 = K2K4 + K2(MU)*K4(MU)*METRIC(MU) K3K4 = K3K4 + K3(MU)*K4(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A7A,K1,K2,EA7AK1K2) CALL EPSILONT2(A7A,K1,K3,EA7AK1K3) CALL EPSILONT2(A7A,K1,K4,EA7AK1K4) CALL EPSILONT2(A7A,K2,K3,EA7AK2K3) CALL EPSILONT2(A7A,K2,K4,EA7AK2K4) CALL EPSILONT2(A7A,K3,K4,EA7AK3K4) CALL EPSILONT2(A8A,K1,K2,EA8AK1K2) CALL EPSILONT2(A8A,K1,K3,EA8AK1K3) CALL EPSILONT2(A8A,K1,K4,EA8AK1K4) CALL EPSILONT2(A8A,K2,K3,EA8AK2K3) CALL EPSILONT2(A8A,K2,K4,EA8AK2K4) CALL EPSILONT2(A8A,K3,K4,EA8AK3K4) CALL EPSILON4(A7AGNI,K1,K2,K4,EA7AGNIK1K2K4) CALL EPSILON4(A7AGNI,K2,K3,K4,EA7AGNIK2K3K4) CALL EPSILON4(A7AK1I,K2,K3,K4,EA7AK1IK2K3K4) CALL EPSILON4(A7AK2I,K1,K3,K4,EA7AK2IK1K3K4) CALL EPSILON4(A7AK3I,K1,K2,K4,EA7AK3IK1K2K4) CALL EPSILON4(A7AK4I,K1,K2,K3,EA7AK4IK1K2K3) CALL EPSILON4(A7AK5I,GN,K1,K2,EA7AK5IGNK1K2) CALL EPSILON4(A7AK5I,GN,K1,K3,EA7AK5IGNK1K3) CALL EPSILON4(A7AK5I,GN,K1,K4,EA7AK5IGNK1K4) CALL EPSILON4(A7AK5I,GN,K2,K3,EA7AK5IGNK2K3) CALL EPSILON4(A7AK5I,GN,K2,K4,EA7AK5IGNK2K4) CALL EPSILON4(A7AK5I,GN,K3,K4,EA7AK5IGNK3K4) CALL EPSILON4(A7AK5I,K1,K2,K3,EA7AK5IK1K2K3) CALL EPSILON4(A7AK5I,K1,K2,K4,EA7AK5IK1K2K4) CALL EPSILON4(A7AK5I,K1,K3,K4,EA7AK5IK1K3K4) CALL EPSILON4(A7AK5I,K2,K3,K4,EA7AK5IK2K3K4) CALL EPSILON4(A8AGNI,K1,K2,K4,EA8AGNIK1K2K4) CALL EPSILON4(A8AGNI,K2,K3,K4,EA8AGNIK2K3K4) CALL EPSILON4(A8AK1I,K2,K3,K4,EA8AK1IK2K3K4) CALL EPSILON4(A8AK2I,K1,K3,K4,EA8AK2IK1K3K4) CALL EPSILON4(A8AK3I,K1,K2,K4,EA8AK3IK1K2K4) CALL EPSILON4(A8AK4I,K1,K2,K3,EA8AK4IK1K2K3) CALL EPSILON4(A8AK5I,GN,K1,K2,EA8AK5IGNK1K2) CALL EPSILON4(A8AK5I,GN,K1,K3,EA8AK5IGNK1K3) CALL EPSILON4(A8AK5I,GN,K1,K4,EA8AK5IGNK1K4) CALL EPSILON4(A8AK5I,GN,K2,K3,EA8AK5IGNK2K3) CALL EPSILON4(A8AK5I,GN,K2,K4,EA8AK5IGNK2K4) CALL EPSILON4(A8AK5I,GN,K3,K4,EA8AK5IGNK3K4) CALL EPSILON4(A8AK5I,K1,K2,K3,EA8AK5IK1K2K3) CALL EPSILON4(A8AK5I,K1,K2,K4,EA8AK5IK1K2K4) CALL EPSILON4(A8AK5I,K1,K3,K4,EA8AK5IK1K3K4) CALL EPSILON4(A8AK5I,K2,K3,K4,EA8AK5IK2K3K4) X(1) = K11*(-EA7AK5IK2K3K4 + EA8AK5IK2K3K4 + K3K4*(-V7AWK5K2 > - V8AWK5K2) + K2K4*(V7AWK5K3 + V8AWK5K3) + K2K3*(-V7AWK5K4 > - V8AWK5K4)) X(2) = EA7AK5IK1K2K4 - EA8AK5IK1K2K4 + K2K4*(V7AWK5K1 + V8AWK5K1) > + K1K4*(-V7AWK5K2 - V8AWK5K2) + K1K2*(-V7AWK5K4 - V8AWK5K4) X(3) = X(1) + K33*X(2) X(4) = EA7AK1IK2K3K4 + EA7AK2IK1K3K4 - EA7AK3IK1K2K4 > - EA7AK4IK1K2K3 - EA8AK1IK2K3K4 - EA8AK2IK1K3K4 + EA8AK3IK1K2K4 > + EA8AK4IK1K2K3 X(5) = EA7AK3K4 - EA8AK3K4 + V7AWK3K4 + V7AWK4K3 + V8AWK3K4 > + V8AWK4K3 X(6) = X(4) + K1K2*X(5) X(7) = -EA7AK2K4 + EA8AK2K4 - V7AWK2K4 - V7AWK4K2 - V8AWK2K4 > - V8AWK4K2 X(8) = X(6) + K1K3*X(7) X(9) = -EA7AK2K3 + EA8AK2K3 - V7AWK2K3 + V7AWK3K2 - V8AWK2K3 > + V8AWK3K2 X(10) = X(8) + K1K4*X(9) X(11) = -EA7AK1K4 + EA8AK1K4 + K1K4*(TRACEV7A + TRACEV8A) > + V7AWK1K4 - V7AWK4K1 + V8AWK1K4 - V8AWK4K1 X(12) = X(10) + K2K3*X(11) X(13) = EA7AK1K3 - EA8AK1K3 + K1K3*(TRACEV7A + TRACEV8A) > - V7AWK1K3 - V7AWK3K1 - V8AWK1K3 - V8AWK3K1 X(14) = X(12) + K2K4*X(13) X(15) = -EA7AK1K2 + EA8AK1K2 + K1K2*(-TRACEV7A - TRACEV8A) > + V7AWK1K2 + V7AWK2K1 + V8AWK1K2 + V8AWK2K1 X(16) = X(14) + K3K4*X(15) X(17) = X(3) + TK55*X(16) X(18) = E4*(-EA7AK5IK1K2K3 + EA8AK5IK1K2K3) + E3*(-EA7AK5IK1K2K4 > + EA8AK5IK1K2K4) + E2*(EA7AK5IK1K3K4 - EA8AK5IK1K3K4) + E1 >*(EA7AK5IK2K3K4 - EA8AK5IK2K3K4) X(19) = EA7AGNIK2K3K4 - EA8AGNIK2K3K4 X(20) = X(18) + K11*X(19) X(21) = -EA7AGNIK1K2K4 + EA8AGNIK1K2K4 X(22) = X(20) + K33*X(21) X(23) = EA7AK5IGNK2K4 - EA8AK5IGNK2K4 + E4*(-V7AWK5K2 - V8AWK5K2) > + E2*(-V7AWK5K4 - V8AWK5K4) X(24) = X(22) + K1K3*X(23) X(25) = -EA7AK5IGNK3K4 + EA8AK5IGNK3K4 + K33*(V7AWGNK4 > + V8AWGNK4) + E4*(V7AWK5K3 + V8AWK5K3) + E3*(V7AWK5K4 + V8AWK5K4) X(26) = X(24) + K1K2*X(25) X(27) = EA7AK5IGNK2K3 - EA8AK5IGNK2K3 + K33*(V7AWGNK2 + V8AWGNK2) > + E3*(V7AWK5K2 + V8AWK5K2) + E2*(-V7AWK5K3 - V8AWK5K3) X(28) = X(26) + K1K4*X(27) X(29) = EA7AK5IGNK1K4 - EA8AK5IGNK1K4 + K11*(V7AWGNK4 + V8AWGNK4) > + E4*(-V7AWK5K1 - V8AWK5K1) + E1*(V7AWK5K4 + V8AWK5K4) X(30) = V7AWK5GN + V8AWK5GN X(31) = X(29) + K1K4*X(30) X(32) = X(28) + K2K3*X(31) X(33) = EA7AK5IGNK1K2 - EA8AK5IGNK1K2 + K11*(V7AWGNK2 + V8AWGNK2) > + E2*(V7AWK5K1 + V8AWK5K1) + E1*(V7AWK5K2 + V8AWK5K2) X(34) = -V7AWK5GN - V8AWK5GN X(35) = X(33) + K1K2*X(34) X(36) = X(32) + K3K4*X(35) X(37) = -EA7AK5IGNK1K3 + EA8AK5IGNK1K3 + K11*(-V7AWGNK3 > - V8AWGNK3) + E3*(-V7AWK5K1 - V8AWK5K1) + E1*(-V7AWK5K3 > - V8AWK5K3) X(38) = V7AWK5GN + V8AWK5GN X(39) = X(37) + K1K3*X(38) X(40) = -V7AWGNK1 - V8AWGNK1 X(41) = X(39) + K33*X(40) X(42) = X(36) + K2K4*X(41) X(43) = X(17) + E5*X(42) FEYNMAN = (8*CF*NC*X(43))/TK55 FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 8) THEN C PREFACTOR = 1.0D0 E6 = K6(0) TK66 = 0.0D0 E7 = K7(0) TK77 = 0.0D0 DO MU = 1,3 TK66 = TK66 - K6(MU)**2 TK77 = TK77 - K7(MU)**2 ENDDO K66 = E6**2 + TK66 K77 = E7**2 + TK77 IF (CUT(6)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK66) ELSE PREFACTOR = PREFACTOR/K66 ENDIF IF (CUT(7)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK77) ELSE PREFACTOR = PREFACTOR/K77 ENDIF DO MU = 0,3 K3PT(1,MU) = -K1(MU) K3PT(2,MU) = K2(MU) K3PT(3,MU) = -K5(MU) ENDDO CUT3PT(1) = CUT(1) CUT3PT(2) = CUT(2) CUT3PT(3) = CUT(5) KIND3PT = 'QQP/QQG' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V1Q,A1Q) DO MU = 0,3 K3PT(1,MU) = -K4(MU) K3PT(2,MU) = K3(MU) K3PT(3,MU) = K8(MU) ENDDO CUT3PT(1) = CUT(4) CUT3PT(2) = CUT(3) CUT3PT(3) = CUT(8) KIND3PT = 'QQP/QQG' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V4Q,A4Q) A1QDA4Q = 0.0D0 V1QDV4Q = 0.0D0 DO MU = 0,3 DO NU = 0,3 A1QDA4Q = A1QDA4Q + A1Q(MU,NU)*A4Q(MU,NU)*METRIC(MU)*METRIC(NU) V1QDV4Q = V1QDV4Q + V1Q(MU,NU)*V4Q(MU,NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 A1QIK6(MU) = 0.0D0 A1QIK7(MU) = 0.0D0 A4QIK6(MU) = 0.0D0 A4QIK7(MU) = 0.0D0 V1QIK6(MU) = 0.0D0 V1QIK7(MU) = 0.0D0 V4QIK6(MU) = 0.0D0 V4QIK7(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 A1QIK6(MU) = A1QIK6(MU) + A1Q(MU,NU)*K6(NU)*METRIC(NU) A1QIK7(MU) = A1QIK7(MU) + A1Q(MU,NU)*K7(NU)*METRIC(NU) A4QIK6(MU) = A4QIK6(MU) + A4Q(MU,NU)*K6(NU)*METRIC(NU) A4QIK7(MU) = A4QIK7(MU) + A4Q(MU,NU)*K7(NU)*METRIC(NU) V1QIK6(MU) = V1QIK6(MU) + V1Q(MU,NU)*K6(NU)*METRIC(NU) V1QIK7(MU) = V1QIK7(MU) + V1Q(MU,NU)*K7(NU)*METRIC(NU) V4QIK6(MU) = V4QIK6(MU) + V4Q(MU,NU)*K6(NU)*METRIC(NU) V4QIK7(MU) = V4QIK7(MU) + V4Q(MU,NU)*K7(NU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 DO NU = 0,3 A1QZV4Q(MU,NU) = 0.0D0 A4QZV1Q(MU,NU) = 0.0D0 ENDDO ENDDO DO MU = 0,3 DO NU = 0,3 DO TAU = 0,3 A1QZV4Q(MU,NU) = A1QZV4Q(MU,NU) > + A1Q(TAU,MU)*V4Q(TAU,NU)*METRIC(TAU) A4QZV1Q(MU,NU) = A4QZV1Q(MU,NU) > + A4Q(TAU,MU)*V1Q(TAU,NU)*METRIC(TAU) ENDDO ENDDO ENDDO A1QIK6A4QIK7 = 0.0D0 A1QIK7A4QIK6 = 0.0D0 K6K7 = 0.0D0 V1QIK6V4QIK7 = 0.0D0 V1QIK7V4QIK6 = 0.0D0 DO MU = 0,3 A1QIK6A4QIK7 = A1QIK6A4QIK7 + A1QIK6(MU)*A4QIK7(MU)*METRIC(MU) A1QIK7A4QIK6 = A1QIK7A4QIK6 + A1QIK7(MU)*A4QIK6(MU)*METRIC(MU) K6K7 = K6K7 + K6(MU)*K7(MU)*METRIC(MU) V1QIK6V4QIK7 = V1QIK6V4QIK7 + V1QIK6(MU)*V4QIK7(MU)*METRIC(MU) V1QIK7V4QIK6 = V1QIK7V4QIK6 + V1QIK7(MU)*V4QIK6(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A1QZV4Q,K6,K7,EA1QZV4QK6K7) CALL EPSILONT2(A4QZV1Q,K6,K7,EA4QZV1QK6K7) FEYNMAN = 4*NC*(A1QIK6A4QIK7 + A1QIK7A4QIK6 + EA1QZV4QK6K7 > - EA4QZV1QK6K7 - A1QDA4Q*K6K7 + K6K7*V1QDV4Q - V1QIK6V4QIK7 > - V1QIK7V4QIK6) FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 9) THEN C PREFACTOR = 1.0D0 DO MU = 0,3 K2PT(0,MU) = K1(MU) K2PT(1,MU) = K5(MU) K2PT(2,MU) = K6(MU) ENDDO CUT2PT(0) = CUT(1) CUT2PT(1) = CUT(5) CUT2PT(2) = CUT(6) CUT2PT(3) = CUT(3) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q15) DO MU = 0,3 K2PT(0,MU) = K4(MU) K2PT(1,MU) = -K7(MU) K2PT(2,MU) = -K8(MU) ENDDO CUT2PT(0) = CUT(4) CUT2PT(1) = CUT(7) CUT2PT(2) = CUT(8) CUT2PT(3) = CUT(2) CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,Q47) Q15Q47 = 0.0D0 DO MU = 0,3 Q15Q47 = Q15Q47 + Q15(MU)*Q47(MU)*METRIC(MU) ENDDO FEYNMAN = -8*NC*Q15Q47 FEYNMAN = FEYNMAN*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 10) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 E5 = K5(0) TK55 = 0.0D0 E6 = K6(0) TK66 = 0.0D0 E7 = K7(0) TK77 = 0.0D0 E8 = K8(0) TK88 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 TK55 = TK55 - K5(MU)**2 TK66 = TK66 - K6(MU)**2 TK77 = TK77 - K7(MU)**2 TK88 = TK88 - K8(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 K55 = E5**2 + TK55 K66 = E6**2 + TK66 K77 = E7**2 + TK77 K88 = E8**2 + TK88 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF IF (CUT(5)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55) ELSE PREFACTOR = PREFACTOR/K55 ENDIF IF (CUT(6)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK66) ELSE PREFACTOR = PREFACTOR/K66 ENDIF IF (CUT(7)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK77) ELSE PREFACTOR = PREFACTOR/K77 ENDIF IF (CUT(8)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK88) ELSE PREFACTOR = PREFACTOR/K88 ENDIF K1K2 = 0.0D0 K1K3 = 0.0D0 K1K4 = 0.0D0 K1K6 = 0.0D0 K1K7 = 0.0D0 K2K3 = 0.0D0 K2K4 = 0.0D0 K2K6 = 0.0D0 K2K7 = 0.0D0 K3K4 = 0.0D0 K3K6 = 0.0D0 K3K7 = 0.0D0 K4K6 = 0.0D0 K4K7 = 0.0D0 K6K7 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1K3 = K1K3 + K1(MU)*K3(MU)*METRIC(MU) K1K4 = K1K4 + K1(MU)*K4(MU)*METRIC(MU) K1K6 = K1K6 + K1(MU)*K6(MU)*METRIC(MU) K1K7 = K1K7 + K1(MU)*K7(MU)*METRIC(MU) K2K3 = K2K3 + K2(MU)*K3(MU)*METRIC(MU) K2K4 = K2K4 + K2(MU)*K4(MU)*METRIC(MU) K2K6 = K2K6 + K2(MU)*K6(MU)*METRIC(MU) K2K7 = K2K7 + K2(MU)*K7(MU)*METRIC(MU) K3K4 = K3K4 + K3(MU)*K4(MU)*METRIC(MU) K3K6 = K3K6 + K3(MU)*K6(MU)*METRIC(MU) K3K7 = K3K7 + K3(MU)*K7(MU)*METRIC(MU) K4K6 = K4K6 + K4(MU)*K6(MU)*METRIC(MU) K4K7 = K4K7 + K4(MU)*K7(MU)*METRIC(MU) K6K7 = K6K7 + K6(MU)*K7(MU)*METRIC(MU) ENDDO X(1) = K1K3*TK55*(-4*K22*K4K7*K66 + K6K7*(-4*K22*K44 > - 16*K2K4*TK88)) X(2) = -(K11*K22*K44*K6K7) - 4*K11*K2K4*K6K7*TK88 + K66*(K22 >*(K1K7*(K44 + K4K6) - K11*K4K7 + K1K6*K4K7 - K1K4*K6K7) > + 4*K1K7*K2K4*TK88) X(3) = X(1) + K33*X(2) X(4) = K2K4*((4*E7*K1K3 + 4*E3*K1K7 - 4*E1*K3K7)*K66 + K33 >*(-4*E7*K1K6 + 4*E6*K1K7 + 4*E1*K6K7) + K11*(-4*E7*K3K6 > + 4*E6*K3K7 - 4*E3*K6K7))*TK88 X(5) = K44*(K33*(-(E7*K1K6) + E6*K1K7 + E1*K6K7) + K11 >*(-(E7*K3K6) + E6*K3K7 - E3*K6K7)) X(6) = K1K7*(-(E6*K3K4) + E4*(K33 + K3K6) + E3*(K44 + K4K6)) > + (-(E4*K1K3) - E3*K1K4 + E1*K3K4)*K6K7 X(7) = E6*K1K4 + E4*(K11 - K1K6) + E1*(-K44 - K4K6) X(8) = X(6) + K3K7*X(7) X(9) = E6*K1K3 + E3*(-K11 + K1K6) + E1*(K33 - K3K6) X(10) = X(8) + K4K7*X(9) X(11) = (-K11 + K1K6)*K3K4 + K1K4*(-K33 - K3K6) + K1K3*(K44 > + K4K6) X(12) = X(10) + E7*X(11) X(13) = X(5) + K66*X(12) X(14) = X(4) + K22*X(13) X(15) = X(3) + E5*X(14) X(16) = K2K4*(-4*K11*K3K6 + E5*(4*E6*K1K3 - 4*E3*K1K6 > + 4*E1*K3K6))*TK88 X(17) = K11*((-K22 + K2K7)*K3K6 + K2K6*(K33 + K3K7) - K2K3*K6K7) > + 4*K1K3*K2K6*TK55 X(18) = K1K6*(-(E7*K2K3) + E3*(-K22 + K2K7) + E2*(K33 + K3K7)) > + (-(E3*K1K2) + E2*K1K3 + E1*K2K3)*K6K7 X(19) = -(E7*K1K3) + E3*(K11 + K1K7) + E1*(-K33 - K3K7) X(20) = X(18) + K2K6*X(19) X(21) = E7*K1K2 + E2*(K11 - K1K7) + E1*(K22 - K2K7) X(22) = X(20) + K3K6*X(21) X(23) = (-K11 + K1K7)*K2K3 + K1K3*(K22 - K2K7) + K1K2*(-K33 > - K3K7) X(24) = X(22) + E6*X(23) X(25) = X(17) + E5*X(24) X(26) = X(16) + K44*X(25) X(27) = ((-K11 + K1K6)*K2K3 + K1K3*K2K6 - K1K2*K3K6)*K4K7 + K1K4 >*((-K22 + K2K7)*K3K6 + K2K6*(K33 + K3K7) - K2K3*K6K7) X(28) = K1K7*K2K3 + K1K3*(K22 - K2K7) + K1K2*(-K33 - K3K7) X(29) = X(27) + K44*X(28) X(30) = K1K7*K2K3 + K1K3*(K22 - K2K7) + K1K2*(-K33 - K3K7) X(31) = X(29) + K4K6*X(30) X(32) = (-K11 + K1K6)*K22 - K1K7*K2K6 + (K11 - K1K6)*K2K7 > + K1K2*K6K7 X(33) = X(31) + K3K4*X(32) X(34) = (K11 - K1K6)*K33 + K1K7*K3K6 + (K11 - K1K6)*K3K7 + K1K3 >*(-K6K7 + 4*TK55 + 4*TK88) X(35) = X(33) + K2K4*X(34) X(36) = E6*(-(K1K4*K2K3) - K1K3*K2K4 + K1K2*K3K4) + E7 >*(-(K1K4*K2K3) - K1K3*K2K4 + K1K2*K3K4) X(37) = (K22 - K2K6 - K2K7)*K3K4 + K2K4*(-K33 + K3K6 - K3K7) > + K2K3*(K44 + K4K6 + K4K7) X(38) = X(36) + E1*X(37) X(39) = (K11 - K1K6 - K1K7)*K3K4 + K1K4*(K33 + K3K6 + K3K7) > + K1K3*(-K44 - K4K6 + K4K7) X(40) = X(38) + E2*X(39) X(41) = (K11 - K1K6 + K1K7)*K2K4 + K1K4*(-K22 + K2K6 + K2K7) > + K1K2*(-K44 - K4K6 - K4K7) X(42) = X(40) + E3*X(41) X(43) = (-K11 + K1K6 + K1K7)*K2K3 + K1K3*(K22 + K2K6 - K2K7) > + K1K2*(-K33 - K3K6 - K3K7) X(44) = X(42) + E4*X(43) X(45) = X(35) + E5*X(44) X(46) = X(26) + K66*X(45) X(47) = X(15) + K77*X(46) X(48) = K1K3*((4*E7*K2K4 - 4*E4*K2K7 + 4*E2*K4K7)*K66 + K44 >*(4*E7*K2K6 - 4*E6*K2K7 + 4*E2*K6K7) + K22*(4*E7*K4K6 - 4*E6*K4K7 > - 4*E4*K6K7))*TK55 X(49) = K11*(K44*(E7*K2K6 - E6*K2K7 + E2*K6K7) + K22*(E7*K4K6 > - E6*K4K7 - E4*K6K7)) X(50) = K1K7*(-(E6*K2K4) + E4*(K22 + K2K6) + E2*(-K44 - K4K6)) > + (-(E4*K1K2) + E2*K1K4 + E1*K2K4)*K6K7 X(51) = -(E6*K1K4) + E4*(-K11 + K1K6) + E1*(K44 + K4K6) X(52) = X(50) + K2K7*X(51) X(53) = E6*K1K2 + E2*(K11 - K1K6) + E1*(K22 - K2K6) X(54) = X(52) + K4K7*X(53) X(55) = (K11 - K1K6)*K2K4 + K1K4*(-K22 + K2K6) + K1K2*(-K44 > - K4K6) X(56) = X(54) + E7*X(55) X(57) = X(49) + K66*X(56) X(58) = X(48) + K33*X(57) X(59) = K1K3*(4*E6*K2K4 + 4*E4*K2K6 - 4*E2*K4K6)*TK55 X(60) = K2K6*(-(E7*K3K4) + E4*(K33 + K3K7) + E3*(K44 + K4K7)) > + (-(E4*K2K3) - E3*K2K4 + E2*K3K4)*K6K7 X(61) = E7*K2K4 + E4*(-K22 + K2K7) + E2*(K44 - K4K7) X(62) = X(60) + K3K6*X(61) X(63) = E7*K2K3 + E3*(K22 - K2K7) + E2*(-K33 - K3K7) X(64) = X(62) + K4K6*X(63) X(65) = (-K22 + K2K7)*K3K4 + K2K4*(K33 + K3K7) + K2K3*(-K44 > - K4K7) X(66) = X(64) + E6*X(65) X(67) = X(59) + K11*X(66) X(68) = E6*(-(K1K4*K2K3) - K1K3*K2K4 + K1K2*K3K4) + E7 >*(-(K1K4*K2K3) - K1K3*K2K4 + K1K2*K3K4) X(69) = (K22 - K2K6 - K2K7)*K3K4 + K2K4*(-K33 + K3K6 - K3K7) > + K2K3*(K44 + K4K6 + K4K7) X(70) = X(68) + E1*X(69) X(71) = (K11 - K1K6 - K1K7)*K3K4 + K1K4*(K33 + K3K6 + K3K7) > + K1K3*(-K44 - K4K6 + K4K7) X(72) = X(70) + E2*X(71) X(73) = (K11 - K1K6 + K1K7)*K2K4 + K1K4*(-K22 + K2K6 + K2K7) > + K1K2*(-K44 - K4K6 - K4K7) X(74) = X(72) + E3*X(73) X(75) = (-K11 + K1K6 + K1K7)*K2K3 + K1K3*(K22 + K2K6 - K2K7) > + K1K2*(-K33 - K3K6 - K3K7) X(76) = X(74) + E4*X(75) X(77) = X(67) + K66*X(76) X(78) = X(58) + K77*X(77) X(79) = 0 X(80) = K33*(-(K1K7*K4K6) - K1K6*K4K7 + E6*(-2*E7*K1K4 > + 2*E4*K1K7 + 2*E1*K4K7) + K1K4*K6K7) X(81) = -2*E6*E7*K3K4 + 2*E4*E6*K3K7 + (2*E3*E7 - K3K7)*K4K6 > - K3K6*K4K7 + (-2*E3*E4 + K3K4)*K6K7 X(82) = X(80) + K11*X(81) X(83) = X(79) + K22*X(82) X(84) = K11*(-(K2K7*K3K6) + E7*(-2*E6*K2K3 + 2*E3*K2K6 > + 2*E2*K3K6) - K2K6*K3K7 + K2K3*K6K7) X(85) = -2*E6*E7*K1K2 + 2*E2*E7*K1K6 - K1K7*K2K6 + (2*E1*E6 > - K1K6)*K2K7 + (-2*E1*E2 + K1K2)*K6K7 X(86) = X(84) + K33*X(85) X(87) = X(83) + K44*X(86) X(88) = (K1K4*K2K3 + K1K3*K2K4 - K1K2*K3K4)*K6K7 X(89) = 2*E3*E4*K22 + (-K22 + K2K6)*K3K4 + K2K4*(-K33 - K3K6) > + K2K3*(-K44 - K4K6) X(90) = X(88) + K1K7*X(89) X(91) = (2*E1*E4 - K1K4)*K33 + (-K11 + K1K6)*K3K4 - K1K4*K3K6 > + K1K3*(K44 + K4K6) X(92) = X(90) + K2K7*X(91) X(93) = (-2*E1*E4 + K1K4)*K22 + (-K11 + K1K6)*K2K4 - K1K4*K2K6 > + K1K2*(K44 + K4K6) X(94) = X(92) + K3K7*X(93) X(95) = (K11 - K1K6)*K2K3 + K1K3*(K22 - K2K6) + (-2*E1*E2 > + K1K2)*K33 + K1K2*K3K6 X(96) = X(94) + K4K7*X(95) X(97) = -2*E6*K1K3*K2K4 + 2*E4*K1K3*K2K6 + (2*E6*K1K2 + E1*(2*K22 > - 2*K2K6))*K3K4 + E4*K1K2*(-2*K33 - 2*K3K6) + 2*E1*K2K4*K3K6 X(98) = -2*E6*K1K4 + E4*(-2*K11 + 2*K1K6) + E1*(2*K44 + 2*K4K6) X(99) = X(97) + K2K3*X(98) X(100) = (2*K11 - 2*K1K6)*K3K4 + K1K4*(2*K33 + 2*K3K6) + K1K3 >*(-2*K44 - 2*K4K6) X(101) = X(99) + E2*X(100) X(102) = (2*K11 - 2*K1K6)*K2K4 + K1K4*(-2*K22 + 2*K2K6) + K1K2 >*(-2*K44 - 2*K4K6) X(103) = X(101) + E3*X(102) X(104) = X(96) + E7*X(103) X(105) = X(87) + K66*X(104) X(106) = (K1K4*K2K3 + K1K3*K2K4 - K1K2*K3K4)*K6K7 X(107) = (-K22 + K2K7)*K3K4 + K2K4*(K33 + K3K7) + (2*E2*E3 > - K2K3)*K44 - K2K3*K4K7 X(108) = X(106) + K1K6*X(107) X(109) = 2*E3*E4*K11 + (-K11 + K1K7)*K3K4 + K1K4*(-K33 - K3K7) > + K1K3*(-K44 - K4K7) X(110) = X(108) + K2K6*X(109) X(111) = (K11 - K1K7)*K2K4 + K1K4*(K22 - K2K7) + (-2*E1*E2 > + K1K2)*K44 + K1K2*K4K7 X(112) = X(110) + K3K6*X(111) X(113) = -2*E2*E3*K11 + (K11 - K1K7)*K2K3 + K1K3*(-K22 + K2K7) > + K1K2*(K33 + K3K7) X(114) = X(112) + K4K6*X(113) X(115) = -4*E3*E4*K1K2 + 4*E2*E3*K1K4 + (4*E1*E4 - 2*K1K4)*K2K3 > - 2*K1K3*K2K4 + (-4*E1*E2 + 2*K1K2)*K3K4 X(116) = X(114) + K66*X(115) X(117) = -2*E7*K1K3*K2K4 + 2*E3*K1K7*K2K4 + (2*E7*K1K2 + E2 >*(2*K11 - 2*K1K7))*K3K4 + E3*K1K2*(-2*K44 - 2*K4K7) > + 2*E2*K1K3*K4K7 X(118) = -2*E7*K2K3 + E3*(-2*K22 + 2*K2K7) + E2*(2*K33 + 2*K3K7) X(119) = X(117) + K1K4*X(118) X(120) = (2*K22 - 2*K2K7)*K3K4 + K2K4*(-2*K33 - 2*K3K7) + K2K3 >*(2*K44 + 2*K4K7) X(121) = X(119) + E1*X(120) X(122) = (-2*K11 + 2*K1K7)*K2K3 + K1K3*(2*K22 - 2*K2K7) + K1K2 >*(-2*K33 - 2*K3K7) X(123) = X(121) + E4*X(122) X(124) = X(116) + E6*X(123) X(125) = X(105) + K77*X(124) X(126) = X(78) + E5*X(125) X(127) = X(47) + E8*X(126) FEYNMAN = (4*CF*X(127))/(TK55*TK88) FEYNMAN = FEYNMAN*PREFACTOR C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C C C Feynman integrand in Coulomb gauge, BORN level C C C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C COMPLEX*16 FUNCTION FEYNMAN0(GRAPHNUMBER,KC,CUT,MUMSBAR,FLAG) C C In: INTEGER SIZE PARAMETER (SIZE = 3) INTEGER GRAPHNUMBER COMPLEX*16 KC(0:3*SIZE-1,0:3) LOGICAL CUT(3*SIZE-1) REAL*8 MUMSBAR CHARACTER*16 FLAG C C Feynman integrand function for graph GRAPHNUMBER C with complex momenta KC and cut specified by CUT. C Early version: 17 July 1994. C This version written by Mathematica code of 4 January 2002 on C 7 Feb 2002. C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF C REAL*8 METRIC(0:3) DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/ REAL*8 GN(0:3) DATA GN /+1.0D0,0.0D0,0.0D0,0.0D0/ C REAL*8 CF COMPLEX*16 COMPLEXSQRT INTEGER MU COMPLEX*16 X(256) COMPLEX*16 K1(0:3),K2(0:3),K3(0:3),K4(0:3),K5(0:3) COMPLEX*16 E1,E2,E3,E4,E5 COMPLEX*16 K11,K22,K33,K44,K55 COMPLEX*16 TK11,TK22,TK33,TK44,TK55 COMPLEX*16 PREFACTOR C COMPLEX*16 K1K2,K1K3,K1K4,K1K5,K2K3,K2K4,K2K5,K3K4,K3K5 C DO MU = 0,3 K1(MU) = KC(1,MU) K2(MU) = KC(2,MU) K3(MU) = KC(3,MU) K4(MU) = KC(4,MU) K5(MU) = KC(5,MU) ENDDO CF = (NC**2 - 1.0D0)/2.0D0/NC FEYNMAN0 = 0.0D0 C C------ C IF (GRAPHNUMBER .EQ. 11) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 E5 = K5(0) TK55 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 TK55 = TK55 - K5(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 K55 = E5**2 + TK55 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF IF (CUT(5)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55) ELSE PREFACTOR = PREFACTOR/K55 ENDIF K1K2 = 0.0D0 K1K3 = 0.0D0 K1K5 = 0.0D0 K2K3 = 0.0D0 K2K5 = 0.0D0 K3K5 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1K3 = K1K3 + K1(MU)*K3(MU)*METRIC(MU) K1K5 = K1K5 + K1(MU)*K5(MU)*METRIC(MU) K2K3 = K2K3 + K2(MU)*K3(MU)*METRIC(MU) K2K5 = K2K5 + K2(MU)*K5(MU)*METRIC(MU) K3K5 = K3K5 + K3(MU)*K5(MU)*METRIC(MU) ENDDO X(1) = K1K2*((-2*K2K3 - 2*K2K5)*K55 + E4*(-2*E5*K2K3 + 2*E3*K2K5 > - 2*E2*K3K5 - 4*E2*K55) - 4*K2K5*TK44) X(2) = -(K1K3*K2K5) + K1K2*K3K5 + (K1K2 + K1K3 + K1K5)*K55 + K1K5 >*(K2K3 + 2*TK44) X(3) = E5*(K1K2 + K1K3) + (E2 - E3)*K1K5 + E1*(-K2K5 + K3K5 > + 2*K55) X(4) = X(2) + E4*X(3) X(5) = X(1) + K22*X(4) FEYNMAN0 = (-16*CF*NC*X(5))/TK44 FEYNMAN0 = FEYNMAN0*PREFACTOR C ELSE IF (GRAPHNUMBER .EQ. 12) THEN C PREFACTOR = 1.0D0 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 E5 = K5(0) TK55 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 TK55 = TK55 - K5(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 K33 = E3**2 + TK33 K44 = E4**2 + TK44 K55 = E5**2 + TK55 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF IF (CUT(5)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK55) ELSE PREFACTOR = PREFACTOR/K55 ENDIF K1K2 = 0.0D0 K1K3 = 0.0D0 K1K4 = 0.0D0 K2K3 = 0.0D0 K2K4 = 0.0D0 K3K4 = 0.0D0 DO MU = 0,3 K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) K1K3 = K1K3 + K1(MU)*K3(MU)*METRIC(MU) K1K4 = K1K4 + K1(MU)*K4(MU)*METRIC(MU) K2K3 = K2K3 + K2(MU)*K3(MU)*METRIC(MU) K2K4 = K2K4 + K2(MU)*K4(MU)*METRIC(MU) K3K4 = K3K4 + K3(MU)*K4(MU)*METRIC(MU) ENDDO X(1) = K1K4*K22*K33 + K11*K22*K3K4 + (K11*K2K3 + K1K2*K33)*K44 > + 4*K1K4*K2K3*TK55 X(2) = (E4*K1K2 + E2*K1K4 - E1*K2K4)*K33 + K22*(E4*K1K3 - E3*K1K4 > - E1*K3K4) + K11*(E4*K2K3 - E3*K2K4 + E2*K3K4) X(3) = -(E3*K1K2) + E2*K1K3 - E1*K2K3 X(4) = X(2) + K44*X(3) X(5) = X(1) + E5*X(4) FEYNMAN0 = (8*CF*NC*X(5))/TK55 FEYNMAN0 = FEYNMAN0*PREFACTOR C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C C C Vertex and propagator functions in Coulomb gauge C C C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE TWOPOINTG(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUT) C In: CHARACTER*9 KIND2PT COMPLEX*16 K2PT(0:2,0:3) LOGICAL CUT2PT(0:3) REAL*8 MUMSBAR CHARACTER*16 FLAG C Out: COMPLEX*16 OUT(0:3,0:3) C C Calculates the one loop gluon two-point function, including the C adjoining propagators. C C kind2pt: C GLUONLOOP gluon self-energy with a gluon (including ghost) loop C QUARKLOOP gluon self-energy with a quark loop C BOTHLOOPS the sum of these C C k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part) C k2pt(1,mu): 1st momentum in loop (kplus for the space part) C k2pt(2,mu): 2nd momentum in loop (kminus for the space part) C C cut2pt(0): whether incoming line is cut C cut2pt(1): whether 1st internal line is cut C cut2pt(2): whether 2nd internal line is cut C cut2pt(3): whether outgoing line is cut C C mumsbar is the MSbar renormalization scale. C C The result is the two point function out(mu,nu) with a certain C normalization. Specifically, for the cut gluon self-energy C graph, out(mu,nu) is {\cal M}_g^{\mu\nu} C divided by (\alpha_s/(4\pi)) * 1/(1+\Delta) and divided C by 2\omega_+ * 2\omega_- *\bar q^2. The factor by which we divide C consists of C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and C one (2\pi)^{-3} for each loop that is factored out of each C graph in our program. C * (d\vec l)/(d\bar q^2 dx d\phi) C = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) C * 4 \pi {\cal Q} \bar q^2 included in the relation between C {\cal I}[real] and {\cal M}_g^{\mu\nu} C C In the case of the virtual gluon self-energy graphs C with an adjacent propagator cut, out(mu,nu) is {\cal W}_g^{\mu\nu} C divided by the same factors. C C 16 December 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF INTEGER MU,NU COMPLEX*16 COMPLEXSQRT COMPLEX*16 KPLUS(1:3),KMINUS(1:3),ELL(1:3),Q(1:3) COMPLEX*16 CALQSQ, OMEGAPLUSSQ,OMEGAMINUSSQ COMPLEX*16 CALQ,OMEGAPLUS,OMEGAMINUS,Q0 COMPLEX*16 DELTAP1,DELTA,TWOXM1,X1MX,QBARSQ COMPLEX*16 ELLT(1:3) COMPLEX*16 ELLTSQ,DENOM,ONEM2X1MX,ONEM4X1MX COMPLEX*16 TEMP COMPLEX*16 BAREPROP(1:3,1:3) COMPLEX*16 NTT,NLL,NEE,NEL COMPLEX*16 PREFACTOR COMPLEX*16 TERMTT,TERMLL COMPLEX*16 AT0,AT1,AT2 COMPLEX*16 NTT0,NTT1,NTT2 COMPLEX*16 NET0,NET1,NET2 COMPLEX*16 UTT,NET C C Some auxilliary variables, including C CALQ = {\cal Q} C OMEGAPLUS = \omega_+ C OMEGAMINUS = \omega_- C DELTAP1 = \Delta + 1 C TWOXM1 = 2 x - 1 C X1MX = x (1-x) C ELLT(mu) = l_T^\mu C ELLTSQ = (\vec l_T)^2 C Q(mu) = the incoming *three*-momentum C Q0 = the incoming energy C DO MU = 1,3 KPLUS(MU) = K2PT(1,MU) KMINUS(MU) = K2PT(2,MU) ELL(MU) = (KPLUS(MU) - KMINUS(MU))/2.0D0 Q(MU) = K2PT(0,MU) ENDDO Q0 = K2PT(0,0) CALQSQ = 0.0D0 OMEGAPLUSSQ = 0.0D0 OMEGAMINUSSQ = 0.0D0 DO MU = 1,3 CALQSQ = CALQSQ + Q(MU)**2 OMEGAPLUSSQ = OMEGAPLUSSQ + KPLUS(MU)**2 OMEGAMINUSSQ = OMEGAMINUSSQ + KMINUS(MU)**2 ENDDO CALQ = COMPLEXSQRT(CALQSQ) OMEGAPLUS = COMPLEXSQRT(OMEGAPLUSSQ) OMEGAMINUS = COMPLEXSQRT(OMEGAMINUSSQ) DELTAP1 = (OMEGAPLUS + OMEGAMINUS)/CALQ DELTA = DELTAP1 - 1.0D0 TWOXM1 = (OMEGAPLUS - OMEGAMINUS)/CALQ X1MX = (1.0D0 - TWOXM1**2)/4.0D0 QBARSQ = CALQSQ * DELTA * (DELTA + 2.0D0) DO MU = 1,3 ELLT(MU) = ELL(MU) - 0.5D0*DELTAP1*TWOXM1*Q(MU) ENDDO ELLTSQ = QBARSQ*X1MX DENOM = QBARSQ/CALQSQ + 4.0D0*X1MX ONEM2X1MX = 1.0D0 - 2.0D0*X1MX ONEM4X1MX = 1.0D0 - 4.0D0*X1MX C C The gluon propagator in Coulomb gauge for an on-shell gluon C with three-momentum Q(mu). This is the space components only. C DO MU = 1,3 BAREPROP(MU,MU) = 1.0D0 - Q(MU)**2/CALQSQ DO NU = MU+1,3 TEMP = - Q(MU)*Q(NU)/CALQSQ BAREPROP(MU,NU) = TEMP BAREPROP(NU,MU) = TEMP ENDDO ENDDO C IF (CUT2PT(1).AND.CUT2PT(2)) THEN C C We have the contribution from a cut self-energy diagram. C We compute the coefficients for, alternatively, the gluon loop C or the quark loop. We use the name NLL for Ntt and NEL for NEt. C IF (KIND2PT.EQ.'GLUONLOOP') THEN C NTT = X1MX NTT = NTT + 8.0D0*X1MX*(1.0D0 - X1MX)/DENOM NTT = NTT + 16.0D0*X1MX*(ONEM4X1MX + 2.0D0*X1MX**2)/DENOM**2 NTT = NTT * 2.0D0 * NC NLL = X1MX NLL = NLL - 8.0D0*X1MX**2/DENOM NLL = NLL + 32.0D0*X1MX**3/DENOM**2 NLL = NLL * 4.0D0 * NC NEE = ONEM4X1MX NEE = NEE - 8.0D0*X1MX*ONEM4X1MX/DENOM NEE = NEE + 32.0D0*X1MX**2*ONEM4X1MX/DENOM**2 NEE = NEE * NC NEL = -1.0D0 NEL = NEL - 2.0D0*ONEM4X1MX/DENOM NEL = NEL + 16.0D0*X1MX*ONEM2X1MX/DENOM**2 NEL = NEL * 2.0D0 * NC * TWOXM1 C ELSE IF (KIND2PT.EQ.'QUARKLOOP') THEN C NTT = NF*ONEM2X1MX NLL = - 4.0D0*NF*X1MX NEE = 4.0D0*NF*X1MX NEL = 2.0D0*NF*TWOXM1 C ELSE IF (KIND2PT.EQ.'BOTHLOOPS') THEN C NTT = X1MX NTT = NTT + 8.0D0*X1MX*(1.0D0 - X1MX)/DENOM NTT = NTT + 16.0D0*X1MX*(ONEM4X1MX + 2.0D0*X1MX**2)/DENOM**2 NTT = NTT * 2.0D0 * NC NLL = X1MX NLL = NLL - 8.0D0*X1MX**2/DENOM NLL = NLL + 32.0D0*X1MX**3/DENOM**2 NLL = NLL * 4.0D0 * NC NEE = ONEM4X1MX NEE = NEE - 8.0D0*X1MX*ONEM4X1MX/DENOM NEE = NEE + 32.0D0*X1MX**2*ONEM4X1MX/DENOM**2 NEE = NEE * NC NEL = -1.0D0 NEL = NEL - 2.0D0*ONEM4X1MX/DENOM NEL = NEL + 16.0D0*X1MX*ONEM2X1MX/DENOM**2 NEL = NEL * 2.0D0 * NC * TWOXM1 C NTT = NTT + NF*ONEM2X1MX NLL = NLL - 4.0D0*NF*X1MX NEE = NEE + 4.0D0*NF*X1MX NEL = NEL + 2.0D0*NF*TWOXM1 C ELSE WRITE(NOUT,*)'Unrecognized type in subroutine twopointg.' STOP ENDIF C C With the coefficients in hand, we compute the result. C PREFACTOR = 1.0D0/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ) C OUT(0,0) = PREFACTOR*QBARSQ/CALQSQ*NEE DO MU = 1,3 TEMP = PREFACTOR*Q0/DELTAP1/CALQSQ*NEL*ELLT(MU) OUT(0,MU) = TEMP OUT(MU,0) = TEMP ENDDO DO MU = 1,3 DO NU = 1,3 TERMTT = NTT*BAREPROP(MU,NU) TERMLL = NLL*(ELLT(MU)*ELLT(NU)/ELLTSQ - 0.5D0*BAREPROP(MU,NU)) OUT(MU,NU) = PREFACTOR*(TERMTT + TERMLL) ENDDO ENDDO C C Alternative for IF (CUT2PT(1).AND.CUT2PT(2)) THEN .... C ELSE IF (CUT2PT(0).OR.CUT2PT(3)) THEN C C We have the contribution from a virtual self-energy diagram C with one of the neighboring propagators cut. C We compute the coefficients for, alternatively, the gluon loop C or the quark loop. C IF (KIND2PT.EQ.'GLUONLOOP') THEN C TEMP = MUMSBAR**2*EXP(2.0D0) AT0 = - 2.0D0*NC*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(5.0D0/3.0D0) AT0 = AT0 + 2.0D0*NC*X1MX*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(8.0D0/3.0D0) AT0 = AT0 + 4.0D0*NC*X1MX*TEMP/(QBARSQ + TEMP) AT1 = 24.0D0*NC*X1MX*ONEM2X1MX AT2 = 32.0D0*NC*X1MX*(ONEM4X1MX + 4.0D0*X1MX**2) NTT0 = 4.0D0*NC*X1MX NTT1 = - 32.0D0*NC*X1MX**2 NTT2 = 128.0D0*NC*X1MX**3 NET0 = - 2.0D0*NC*TWOXM1 NET1 = - 4.0D0*NC*TWOXM1*ONEM4X1MX NET2 = 32.0D0*NC*TWOXM1*X1MX*ONEM2X1MX C UTT = AT0 + AT1/DENOM + AT2/DENOM**2 NTT = NTT0 + NTT1/DENOM + NTT2/DENOM**2 NET = NET0 + NET1/DENOM + NET2/DENOM**2 C ELSE IF (KIND2PT.EQ.'QUARKLOOP') THEN C C Here AT1 = AT2 = NTT1 = NTT2 = NET1 = NET2 = 0. C TEMP = MUMSBAR**2*EXP(2.0D0) AT0 = NF*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(8.0D0/3.0D0) AT0 = AT0 - 2.0D0*NF*X1MX*TEMP/(QBARSQ + TEMP) AT1 = 0.0D0 AT2 = 0.0D0 NTT0 = - 4.0D0*NF*X1MX NET0 = 2.0D0*NF*TWOXM1 C UTT = AT0 NTT = NTT0 NET = NET0 C ELSE IF (KIND2PT.EQ.'BOTHLOOPS') THEN C TEMP = MUMSBAR**2*EXP(2.0D0) AT0 = - 2.0D0*NC*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(5.0D0/3.0D0) AT0 = AT0 + 2.0D0*NC*X1MX*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(8.0D0/3.0D0) AT0 = AT0 + 4.0D0*NC*X1MX*TEMP/(QBARSQ + TEMP) AT1 = 24.0D0*NC*X1MX*ONEM2X1MX AT2 = 32.0D0*NC*X1MX*(ONEM4X1MX + 4.0D0*X1MX**2) NTT0 = 4.0D0*NC*X1MX NTT1 = - 32.0D0*NC*X1MX**2 NTT2 = 128.0D0*NC*X1MX**3 NET0 = - 2.0D0*NC*TWOXM1 NET1 = - 4.0D0*NC*TWOXM1*ONEM4X1MX NET2 = 32.0D0*NC*TWOXM1*X1MX*ONEM2X1MX C UTT = AT0 + AT1/DENOM + AT2/DENOM**2 NTT = NTT0 + NTT1/DENOM + NTT2/DENOM**2 NET = NET0 + NET1/DENOM + NET2/DENOM**2 C TEMP = MUMSBAR**2*EXP(2.0D0) AT0 = NF*TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2*EXP(8.0D0/3.0D0) AT0 = AT0 - 2.0D0*NF*X1MX*TEMP/(QBARSQ + TEMP) AT1 = 0.0D0 AT2 = 0.0D0 NTT0 = - 4.0D0*NF*X1MX NET0 = 2.0D0*NF*TWOXM1 C UTT = UTT + AT0 NTT = NTT + NTT0 NET = NET + NET0 C ELSE WRITE(NOUT,*)'Unrecognized type in subroutine twopointg.' STOP ENDIF C C With the coefficients in hand, we compute the result. There is C an extra factor 1 + \Delta compared to the real self-energy C graphs because {\cal W} lacks the factor 1/(1 + \Delta) that C appears in {\cal M}. C C Also, we divide by 2 because we will get this contribution C twice, once when one adjacent propagator is cut and onece C when the other adjacent propagator is cut. C PREFACTOR = - DELTAP1/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ) PREFACTOR = 0.5D0*PREFACTOR C OUT(0,0) = 0.0D0 DO MU = 1,3 TEMP = PREFACTOR*Q0/DELTAP1/CALQSQ/(1 + QBARSQ/CALQSQ) TEMP = TEMP*NET*ELLT(MU) OUT(0,MU) = TEMP OUT(MU,0) = TEMP ENDDO DO MU = 1,3 DO NU = 1,3 TERMTT = UTT*BAREPROP(MU,NU) TEMP = ELLT(MU)*ELLT(NU)/ELLTSQ - 0.5D0*BAREPROP(MU,NU) TERMLL = NTT/(1 + QBARSQ/CALQSQ)*TEMP OUT(MU,NU) = PREFACTOR*(TERMTT + TERMLL) ENDDO ENDDO C C Closing for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....ELSEIF ... C ELSE WRITE(NOUT,*)'For a gluon two point function,' WRITE(NOUT,*)'either the self-energy graph must be cut' WRITE(NOUT,*)'or one of the neighboring propagators' WRITE(NOUT,*)'must be cut.' STOP ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,OUT) C In: COMPLEX*16 K2PT(0:2,0:3) LOGICAL CUT2PT(0:3) REAL*8 MUMSBAR CHARACTER*16 FLAG C Out: COMPLEX*16 OUT(0:3) C C Calculates the one loop quark two-point function, including the C adjoining propagators. C C k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part) C k2pt(1,mu): 1st momentum in loop (kplus for the space part) C k2pt(2,mu): 2nd momentum in loop (kminus for the space part) C C cut2pt(0): whether incoming line is cut C cut2pt(1): whether 1st internal line is cut C cut2pt(2): whether 2nd internal line is cut C cut2pt(3): whether outgoing line is cut C C mumsbar is the MSbar renormalization scale. C C The two point function, with a certain normalization, C is represented as out^mu gamma_mu. C For the real quark self-energy graphs, out^{\mu} gamma_{\mu} C is {\cal M}_q divided by C (\alpha_s/(4\pi)) * 1/(1+\Delta) C and divided by C 4 * \omega_+ * \omega_- * \bar q^2. C The factor by which we divide consists of C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and C one (2\pi)^{-3} for each loop that is factored out of each C graph in our program. C * (d\vec l)/(d\bar q^2 dx d\phi) C = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) C * 4 \pi {\cal Q} \bar q^2 included in the relation between C {\cal I}[real] and {\cal M}_q. C C In the case of the virtual quark self-energy graphs with C one of the adjacent propagators cut, OUT^{\mu} gamma_{\mu} C is {\cal W}_q divided by the same factors. C C In the case of the virtual quark self-energy graphs with C the adjacent propagators *not* cut, OUT^{\mu} gamma_{\mu} C is W_q divided by C (\alpha_s/(4\pi)) * 1/(1+\Delta) C and divided by C 2 * \omega_+ * \omega_- * (\bar q^2 - q^2) * q^2/{\cal Q}. C The factor by which we divide consists of C * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and C one (2\pi)^{-3} for each loop that is factored out of each C graph in our program. C * (d\vec l)/(d\bar q^2 dx d\phi) C = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) C * 2 \pi q^2 (\bar q^2 - q^2) included in the relation between C {\cal I}[all uncut] and W_q. C C 2 January 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF,CF COMMON /COLORFACTORS/ NC,NF COMPLEX*16 COMPLEXSQRT INTEGER MU COMPLEX*16 KPLUS(1:3),KMINUS(1:3),ELL(1:3),Q(1:3) COMPLEX*16 CALQSQ,OMEGAPLUSSQ,OMEGAMINUSSQ COMPLEX*16 CALQ,OMEGAPLUS,OMEGAMINUS COMPLEX*16 DELTAP1,DELTA,TWOXM1,X1MX,QBARSQ COMPLEX*16 ELLT(1:3) COMPLEX*16 ELLTSQ,DENOM,ONEM2X1MX,ONEM4X1MX,X COMPLEX*16 TEMP,TEMPSQ COMPLEX*16 NL,NE,NT,PREFACTOR COMPLEX*16 BL0,BL1,BL2 COMPLEX*16 NL0,NL1,NL2 COMPLEX*16 NT0,NT1,NT2 COMPLEX*16 UL,VL,VT COMPLEX*16 Q0,QSQ COMPLEX*16 BE0,BE1,BE2 COMPLEX*16 UE C CF = (NC**2 - 1.0D0)/(2.0D0*NC) C C Some auxilliary variables, including C CALQ = {\cal Q} C OMEGAPLUS = \omega_+ C OMEGAMINUS = \omega_- C DELTAP1 = \Delta + 1 C TWOXM1 = 2 x - 1 C X1MX = x (1-x) C ELLT(mu) = l_T^\mu C ELLTSQ = (\vec l_T)^2 C Q(mu) = the incoming *three*-momentum C Q0 = the incoming energy C DO MU = 1,3 KPLUS(MU) = K2PT(1,MU) KMINUS(MU) = K2PT(2,MU) ELL(MU) = (KPLUS(MU) - KMINUS(MU))/2.0D0 Q(MU) = K2PT(0,MU) ENDDO Q0 = K2PT(0,0) CALQSQ = 0.0D0 OMEGAPLUSSQ = 0.0D0 OMEGAMINUSSQ = 0.0D0 DO MU = 1,3 CALQSQ = CALQSQ + Q(MU)**2 OMEGAPLUSSQ = OMEGAPLUSSQ + KPLUS(MU)**2 OMEGAMINUSSQ = OMEGAMINUSSQ + KMINUS(MU)**2 ENDDO CALQ = COMPLEXSQRT(CALQSQ) OMEGAPLUS = COMPLEXSQRT(OMEGAPLUSSQ) OMEGAMINUS = COMPLEXSQRT(OMEGAMINUSSQ) DELTAP1 = (OMEGAPLUS + OMEGAMINUS)/CALQ DELTA = DELTAP1 - 1.0D0 TWOXM1 = (OMEGAPLUS - OMEGAMINUS)/CALQ X1MX = (1.0D0 - TWOXM1**2)/4.0D0 QBARSQ = CALQSQ * DELTA * (DELTA + 2.0D0) DO MU = 1,3 ELLT(MU) = ELL(MU) - 0.5D0*DELTAP1*TWOXM1*Q(MU) ENDDO ELLTSQ = QBARSQ*X1MX DENOM = QBARSQ/CALQSQ + 4.0D0*X1MX ONEM2X1MX = 1.0D0 - 2.0D0*X1MX ONEM4X1MX = 1.0D0 - 4.0D0*X1MX X = (TWOXM1 + 1.0D0)/2.0D0 C C Now we will go through these possible cut structures and C calculate the terms contributing to out(mu). C IF ( CUT2PT(1).AND.CUT2PT(2) ) THEN C C First possibility for cut structure: a cut self-energy diagram. C Here TEMP = 2 x + Delta. C TEMP = TWOXM1 + DELTAP1 TEMPSQ = TEMP**2 NL = 12.0D0*X1MX + TWOXM1*TEMP NL = NL - 16.0D0*X1MX*TWOXM1/TEMP + 16.0D0*X1MX*ONEM2X1MX/TEMPSQ NL = CF*NL NE = 2.0D0*CF*(1.0D0 - X)*(4.0D0*X**2 + DELTA**2)/TEMPSQ NT = 1.0D0 - 2.0D0*TWOXM1/TEMP - 8.0D0*X1MX/TEMPSQ NT = 2.0D0*CF*NT C PREFACTOR = 1.0D0/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ) OUT(0) = PREFACTOR*Q0/DELTAP1*(NL + DELTA*NE) DO MU = 1,3 OUT(MU) = PREFACTOR*(NL*Q(MU) + NT*ELLT(MU)) ENDDO C ELSE IF ( CUT2PT(0).OR.CUT2PT(3) ) THEN C C Second possibility for cut structure: a virtual self-energy C with an adjacent propagator cut. C TEMP = MUMSBAR**2 * EXP(3.0D0) BL0 = - TEMP/(QBARSQ + TEMP) TEMP = MUMSBAR**2 * EXP(5.0D0/3.0D0) BL0 = BL0 + 12.0D0*X1MX*TEMP/(QBARSQ + TEMP) BL0 = CF*BL0 BL1 = 8.0D0*CF*X1MX*(5.0D0 - 14.0D0*X1MX) BL2 = 32.0D0*CF*X1MX*(1.0D0 - 6.0D0*X1MX + 8.0D0*X1MX**2) NL0 = CF*TWOXM1 NL1 = - 16.0D0*CF*TWOXM1*X1MX NL2 = - 32.0D0*CF*TWOXM1*X1MX*ONEM2X1MX NT0 = 2.0D0*CF NT1 = - 4.0D0*CF*TWOXM1 NT2 = - 16.0D0*CF*X1MX UL = BL0 + BL1/DENOM + BL2/DENOM**2 VL = NL0 + NL1/DENOM + NL2/DENOM**2 TEMP = DELTA + 2.0D0*X VT = NT0 + NT1/TEMP + NT2/TEMP**2 C C We divide by 2 because we will get this contribution C twice, once when one adjacent propagator is cut and once C when the other adjacent propagator is cut. C PREFACTOR = DELTAP1/(4.0D0*OMEGAPLUS*OMEGAMINUS*QBARSQ) PREFACTOR = 0.5D0*PREFACTOR C TEMP = UL + VL/(1.0D0 + QBARSQ/CALQSQ) OUT(0) = - PREFACTOR*Q0*TEMP DO MU = 1,3 OUT(MU) = - PREFACTOR*(TEMP*Q(MU) > + VT*ELLT(MU)/(1.0D0 + QBARSQ/CALQSQ)) ENDDO C ELSE C C Third possibility for cut structure: a virtual self-energy C with *no* adjacent propagator cut. C QSQ = Q0**2 - CALQSQ C TEMP = MUMSBAR**2 * EXP(3.0D0) BL0 = - (QSQ + TEMP)/(QBARSQ + TEMP) TEMP = MUMSBAR**2 * EXP(5.0D0/3.0D0) BL0 = BL0 + 12.0D0*X1MX*(QSQ + TEMP)/(QBARSQ + TEMP) BL0 = CF*BL0 BL1 = 20.0D0*X1MX - 56.0D0*X1MX**2 + QSQ/CALQSQ*ONEM2X1MX BL1 = 2.0D0*CF*BL1 BL2 = 32.0D0*CF*X1MX*(1.0D0 - 6.0D0*X1MX + 8.0D0*X1MX**2) BE0 = 0.0D0 BE1 = -8.0D0*CF*X1MX BE2 = -16.0D0*CF*X1MX*ONEM4X1MX UL = BL0 + BL1/DENOM + BL2/DENOM**2 UE = BE0 + BE1/DENOM + BE2/DENOM**2 C PREFACTOR = 2.0D0*OMEGAPLUS*OMEGAMINUS*QSQ*(QBARSQ - QSQ) PREFACTOR = DELTAP1*CALQ/PREFACTOR OUT(0) = - PREFACTOR*Q0*(UL + QSQ/CALQSQ*UE) DO MU = 1,3 OUT(MU) = - PREFACTOR*Q(MU)*UL ENDDO C C Completion of IF ... block for cut structure. C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,HV,HA) C In: CHARACTER*7 KIND3PT COMPLEX*16 K3PT(3,0:3) LOGICAL CUT3PT(3) REAL*8 MUMSBAR CHARACTER*16 FLAG C Out: COMPLEX*16 HV(0:3,0:3),HA(0:3,0:3) C C The unintegrated quark-antiquark-gluon three point function C for the graph with flavors labelled by KIND3PT. C C KIND3PT has the form abc/def where a,...,f are chosen from C Q,G,P. Here Q denotes "quark" or "antiquark", G denotes "gluon", C and P denotes "photon. The external lines have flavors a,b,c C and the internal lines have flavors d,e,f. The possibilities C are QQG/QQG, QQG/GGQ, and QQP/QQG. There is also QQG/ALL, which C gives the sum of the results for QQG/QQG and QQG/GGQ. C C The unintegrated three-point function \Gamma^\mu can be decomposed C into a function HV^\mu_\nu \gamma^\mu plus a function C HA^\mu_\nu I \gamma^\mu \gamma_5 (all times a t^a color matrix or a C unit color matrix in the case of a QQP vertex). This subroutine C calculates the functions HV^{\mu\nu} and HA^{\mu\nu}. The arguments C are the momenta k3pt(1,mu), k3pt(2,mu), k3pt(3,mu), of the propagators C around the loop. C C The variable cut3pt(j) is .true. if line j is cut, .false. otherwise. C If the line is cut, the corresponding energy is set by the calling C programs to be k0 = + |\vec k| or else k0 = - |\vec k|. (Here C |\vec k| is a shorthand for sqrt(\vec k^2), not the square root of C \vec k dotted into its complex conjugate.) This subroutine supplies a C factor k(j)^2 for uncut propagators and 2 sqrt(\vec k^2) for a cut C propagator. For a virtual loop, subroutine vertex will be called six C times, once with each of the three propagators cut and k0 = + |\vec k| C and once with each of the three propagators cut and k0 = - |\vec k|. C Then it will be called with no propagator cut, which implies that it C should supply the renormalization counter term. C C 31 December 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF COMPLEX*16 COMPLEXSQRT C REAL*8 CF COMPLEX*16 NVEC(0:3) DATA NVEC /1,0,0,0/ REAL*8 G(0:3,0:3) DATA G /1, 0, 0, 0, > 0,-1, 0, 0, > 0, 0,-1, 0, > 0, 0, 0,-1/ C COMPLEX*16 TK11,TK22,TK33,TK12,TK23,TK13 COMPLEX*16 K11,K22,K33,K12,K23,K13 COMPLEX*16 E1,E2,E3 COMPLEX*16 C1,C2,C3,C4,C5,C6,C7,C8,C9 COMPLEX*16 C10,C11,C12,C13,C14,C15,C16,C17 COMPLEX*16 TEMP,PREFACTOR INTEGER MU,NU COMPLEX*16 K1(0:3),K2(0:3),K3(0:3) COMPLEX*16 EPSN1(0:3,0:3),EPSN2(0:3,0:3),EPSN3(0:3,0:3) COMPLEX*16 EPS12(0:3,0:3),EPS13(0:3,0:3),EPS23(0:3,0:3) COMPLEX*16 EPSN12(0:3),EPSN13(0:3),EPSN23(0:3),EPS123(0:3) COMPLEX*16 TL(0:3),OMEGASQ,OMEGA,CR1,CR2,CR3 INTEGER NCUT,P C C----- C CF = (NC**2 - 1.0D0)/(2.0D0*NC) NCUT = 0 DO P=1,3 IF (CUT3PT(P)) THEN NCUT = NCUT + 1 ENDIF ENDDO C IF ((NCUT.GT.1).OR.(FLAG.NE.'renormalize 3 pt')) THEN C C If NCUT = 1, we have a virtual loop. In this case, one of the C possibilities is the renormalization counter term, for which C FLAG would have been set to 'renormalize 3 pt'. Thus we get C here is we do *not* have the the renormalization counter term. C (Note that we could have NCUT = 2 but FLAG = 'renormalize 3 pt' C in the case that there are two three point functions and ours C is cut but the other one is virtual and needs to be renormalized.) C C First, dot products and energies. The dot products between vectors C omitting their mu = 0 parts (\tilde vector) are denoted TKij. C TK11 = (0.0D0,0.0D0) TK22 = (0.0D0,0.0D0) TK33 = (0.0D0,0.0D0) TK12 = (0.0D0,0.0D0) TK23 = (0.0D0,0.0D0) TK13 = (0.0D0,0.0D0) DO MU = 1,3 TK11 = TK11 - K3PT(1,MU)*K3PT(1,MU) TK22 = TK22 - K3PT(2,MU)*K3PT(2,MU) TK33 = TK33 - K3PT(3,MU)*K3PT(3,MU) TK12 = TK12 - K3PT(1,MU)*K3PT(2,MU) TK23 = TK23 - K3PT(2,MU)*K3PT(3,MU) TK13 = TK13 - K3PT(1,MU)*K3PT(3,MU) ENDDO E1 = K3PT(1,0) E2 = K3PT(2,0) E3 = K3PT(3,0) K11 = E1*E1 + TK11 K22 = E2*E2 + TK22 K33 = E3*E3 + TK33 K12 = E1*E2 + TK12 K23 = E2*E3 + TK23 K13 = E1*E3 + TK13 C C We need the factor equal to 1/k^2 for an uncut propagator C and 1/ 2|E| for a cut propagator. C PREFACTOR = (1.0D0,0.0D0) IF (.NOT.CUT3PT(1)) THEN PREFACTOR = PREFACTOR/K11 ELSE PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK11)) ENDIF IF (.NOT.CUT3PT(2)) THEN PREFACTOR = PREFACTOR/K22 ELSE PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK22)) ENDIF IF (.NOT.CUT3PT(3)) THEN PREFACTOR = PREFACTOR/K33 ELSE PREFACTOR = PREFACTOR/(2.0D0*COMPLEXSQRT(-TK33)) ENDIF C C------------------------ C First, we calculate hv. C------------------------ C Generate the coefficients for the hv, depending on KIND3PT. C IF (KIND3PT.EQ."QQG/QQG") THEN C C1 = -(K12*(-2*E3**2 + K33 - 2*TK33))/(2.0D0*NC*TK33) C2 = 0.0D0 C3 = 0.0D0 C4 = 0.0D0 C5 = -((E3*K12)/(NC*TK33)) C6 = (E3*K23)/(NC*TK33) C7 = (E3*K13)/(NC*TK33) C8 = -((E3*K12)/(NC*TK33)) C9 = 0.0D0 C10 = (-2*E3**2 + K33 - 2*TK33)/(2.0D0*NC*TK33) C11 = -((-(E2*E3) + K23)/(NC*TK33)) C12 = (-2*E3**2 + K33 - 2*TK33)/(2.0D0*NC*TK33) C13 = 0.0D0 C14 = -((-(E1*E3) + K13)/(NC*TK33)) C15 = 0.0D0 C16 = 0.0D0 C17 = K12/(NC*TK33) C ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN C C1 = -(NC*((-(E2**2*K23) + (-2*K12 + K22)*K23 + E2*(E3*(2*K12 > - K22) + 2*E1*K23))*TK11 + (E1*E3*(-K11 + 2*K12) - E1**2*K13 > + 2*E1*E2*K13 + (K11 - 2*K12)*K13 + (K13 > + K23)*TK11)*TK22))/(2.0D0*TK11*TK22) C2 = -(E1*E2*(2*K12*K13 - K13*K22 - K11*K23 > + 2*K12*K23)*NC)/(2.0D0*TK11*TK22) C3 = -(NC*(E1**2*E2*K23 + E2*K23*(K11 - 2*K12 - TK11) + E1*(E2 >*(2*E3*K12 - E3*K22) + K23*(E2**2 - 2*K12 + K22 - TK22) > + 4*K13*TK22)))/(2.0D0*TK11*TK22) C4 = (NC*(-(E1*E2**2*K13) + E2*(E1*(E3*K11 - 2*E3*K12) > - 4*K23*TK11 + K13*(-E1**2 - K11 + 2*K12 + TK11)) + E1*K13*(2*K12 > - K22 + TK22)))/(2.0D0*TK11*TK22) C5 = (NC*(E1*E2**2*(-K11 + 3*K12) + E2*(-2*K12**2 + E1**2*(3*K12 > - K22) + K22*TK11 + K12*(K11 + TK11)) + E1*(-2*K12**2 + K11*TK22 > + K12*(K22 + TK22))))/(2.0D0*TK11*TK22) C6 = (NC*(E1*E2**2*(K13 + K23) + E2*(K12*K13 - K13*K22 + E1 >*(-2*E3*K12 + 2*E3*K22) - E1**2*K23 + 2*K23*TK11) + E1*K23*(K12 > - K22 + TK22)))/(2.0D0*TK11*TK22) C7 = (NC*(-(E1*E2**2*K13) + E2*(E1*(2*E3*K11 - 2*E3*K12) + E1**2 >*(K13 + K23) + K13*(-K11 + K12 + TK11)) + E1*((-K11 + K12)*K23 > + 2*K13*TK22)))/(2.0D0*TK11*TK22) C8 = (NC*(-2*E2*K12*TK11 + E2*K22*TK11 + E1*K11*TK22 > - 2*E1*K12*TK22))/(2.0D0*TK11*TK22) C9 = (NC*(E1*E2**2*E3 + E2*E3*K12 - E2*E3*K22 + E1*E2*K23 > - E2**2*K23 - K12*K23 + K22*K23 + 2*K13*TK22 > - K23*TK22))/(2.0D0*TK11*TK22) C10 = -(NC*(-(E1*E2*K13) + E2**2*K13 + 2*K23*TK11 + E3*(E1**2*E2 > - 2*E2*TK11 + E1*(-E2**2 - K12 + K22 - TK22)) + K13*(K12 - K22 > + TK22)))/(2.0D0*TK11*TK22) C11 = (NC*(-(E1*E2**3) + K12**2 + E2**2*(K12 - 2*TK11) + K22*TK11 > + K12*(-K22 - TK22) - E1**2*TK22 - TK11*TK22 + E1*E2*(-2*K12 > + K22 + TK22)))/(2.0D0*TK11*TK22) C12 = -(NC*(E1**2*K23 - E1*E2*K23 + K23*(-K11 + K12 + TK11) > + 2*K13*TK22 + E3*(E1*E2**2 + E2*(-E1**2 + K11 - K12 - TK11) > - 2*E1*TK22)))/(2.0D0*TK11*TK22) C13 = (NC*(E1**2*E2*E3 - E1*E3*K11 + E1*E3*K12 - E1**2*K13 > + E1*E2*K13 + K11*K13 - K12*K13 - K13*TK11 > + 2*K23*TK11))/(2.0D0*TK11*TK22) C14 = -(NC*(E1**3*E2 - K12**2 + E1*E2*(-K11 + 2*K12 - TK11) > + E2**2*TK11 + K12*(K11 + TK11) - K11*TK22 + TK11*TK22 + E1**2 >*(-K12 + 2*TK22)))/(2.0D0*TK11*TK22) C15 = -(NC*(-E1**2 + 2*E1*E2 + K11 - 2*K12 + TK11))/(2.0D0*TK11) C16 = (NC*(-2*E1*E2 + E2**2 + 2*K12 - K22 - TK22))/(2.0D0*TK22) C17 = 0.0D0 C ELSE IF (KIND3PT.EQ."QQG/ALL") THEN C C1 = -(NC*((-(E2**2*K23) + (-2*K12 + K22)*K23 + E2*(E3*(2*K12 > - K22) + 2*E1*K23))*TK11 + (E1*E3*(-K11 + 2*K12) - E1**2*K13 > + 2*E1*E2*K13 + (K11 - 2*K12)*K13 + (K13 > + K23)*TK11)*TK22))/(2.0D0*TK11*TK22) C2 = -(E1*E2*(2*K12*K13 - K13*K22 - K11*K23 > + 2*K12*K23)*NC)/(2.0D0*TK11*TK22) C3 = -(NC*(E1**2*E2*K23 + E2*K23*(K11 - 2*K12 - TK11) + E1*(E2 >*(2*E3*K12 - E3*K22) + K23*(E2**2 - 2*K12 + K22 - TK22) > + 4*K13*TK22)))/(2.0D0*TK11*TK22) C4 = (NC*(-(E1*E2**2*K13) + E2*(E1*(E3*K11 - 2*E3*K12) > - 4*K23*TK11 + K13*(-E1**2 - K11 + 2*K12 + TK11)) + E1*K13*(2*K12 > - K22 + TK22)))/(2.0D0*TK11*TK22) C5 = (NC*(E1*E2**2*(-K11 + 3*K12) + E2*(-2*K12**2 + E1**2*(3*K12 > - K22) + K22*TK11 + K12*(K11 + TK11)) + E1*(-2*K12**2 + K11*TK22 > + K12*(K22 + TK22))))/(2.0D0*TK11*TK22) C6 = (NC*(E1*E2**2*(K13 + K23) + E2*(K12*K13 - K13*K22 + E1 >*(-2*E3*K12 + 2*E3*K22) - E1**2*K23 + 2*K23*TK11) + E1*K23*(K12 > - K22 + TK22)))/(2.0D0*TK11*TK22) C7 = (NC*(-(E1*E2**2*K13) + E2*(E1*(2*E3*K11 - 2*E3*K12) + E1**2 >*(K13 + K23) + K13*(-K11 + K12 + TK11)) + E1*((-K11 + K12)*K23 > + 2*K13*TK22)))/(2.0D0*TK11*TK22) C8 = (NC*(-2*E2*K12*TK11 + E2*K22*TK11 + E1*K11*TK22 > - 2*E1*K12*TK22))/(2.0D0*TK11*TK22) C9 = (NC*(E1*E2**2*E3 + E2*E3*K12 - E2*E3*K22 + E1*E2*K23 > - E2**2*K23 - K12*K23 + K22*K23 + 2*K13*TK22 > - K23*TK22))/(2.0D0*TK11*TK22) C10 = -(NC*(-(E1*E2*K13) + E2**2*K13 + 2*K23*TK11 + E3*(E1**2*E2 > - 2*E2*TK11 + E1*(-E2**2 - K12 + K22 - TK22)) + K13*(K12 - K22 > + TK22)))/(2.0D0*TK11*TK22) C11 = (NC*(-(E1*E2**3) + K12**2 + E2**2*(K12 - 2*TK11) + K22*TK11 > + K12*(-K22 - TK22) - E1**2*TK22 - TK11*TK22 + E1*E2*(-2*K12 > + K22 + TK22)))/(2.0D0*TK11*TK22) C12 = -(NC*(E1**2*K23 - E1*E2*K23 + K23*(-K11 + K12 + TK11) > + 2*K13*TK22 + E3*(E1*E2**2 + E2*(-E1**2 + K11 - K12 - TK11) > - 2*E1*TK22)))/(2.0D0*TK11*TK22) C13 = (NC*(E1**2*E2*E3 - E1*E3*K11 + E1*E3*K12 - E1**2*K13 > + E1*E2*K13 + K11*K13 - K12*K13 - K13*TK11 > + 2*K23*TK11))/(2.0D0*TK11*TK22) C14 = -(NC*(E1**3*E2 - K12**2 + E1*E2*(-K11 + 2*K12 - TK11) > + E2**2*TK11 + K12*(K11 + TK11) - K11*TK22 + TK11*TK22 + E1**2 >*(-K12 + 2*TK22)))/(2.0D0*TK11*TK22) C15 = -(NC*(-E1**2 + 2*E1*E2 + K11 - 2*K12 + TK11))/(2.0D0*TK11) C16 = (NC*(-2*E1*E2 + E2**2 + 2*K12 - K22 - TK22))/(2.0D0*TK22) C17 = 0.0D0 C C1 = C1 - (K12*(-2*E3**2 + K33 - 2*TK33))/(2.0D0*NC*TK33) C5 = C5 - ((E3*K12)/(NC*TK33)) C6 = C6 + (E3*K23)/(NC*TK33) C7 = C7 + (E3*K13)/(NC*TK33) C8 = C8 - ((E3*K12)/(NC*TK33)) C10 = C10 + (-2*E3**2 + K33 - 2*TK33)/(2.0D0*NC*TK33) C11 = C11 - ((-(E2*E3) + K23)/(NC*TK33)) C12 = C12 + (-2*E3**2 + K33 - 2*TK33)/(2.0D0*NC*TK33) C14 = C14 - ((-(E1*E3) + K13)/(NC*TK33)) C17 = C17 + K12/(NC*TK33) C ELSE IF (KIND3PT.EQ."QQP/QQG") THEN C C1 = (CF*K12*(-2*E3**2 + K33 - 2*TK33))/TK33 C2 = 0.0D0 C3 = 0.0D0 C4 = 0.0D0 C5 = (2*CF*E3*K12)/TK33 C6 = (-2*CF*E3*K23)/TK33 C7 = (-2*CF*E3*K13)/TK33 C8 = (2*CF*E3*K12)/TK33 C9 = 0.0D0 C10 = -((CF*(-2*E3**2 + K33 - 2*TK33))/TK33) C11 = (2*CF*(-(E2*E3) + K23))/TK33 C12 = -((CF*(-2*E3**2 + K33 - 2*TK33))/TK33) C13 = 0.0D0 C14 = (2*CF*(-(E1*E3) + K13))/TK33 C15 = 0.0D0 C16 = 0.0D0 C17 = (-2*CF*K12)/TK33 C ELSE WRITE(NOUT,*)'Wrong kind in subroutine vertex' STOP ENDIF C C Now we have the coefficients, so we can calculate hv. C DO MU = 0,3 DO NU = 0,3 C TEMP = C1*G(MU,NU) > + C2*NVEC(MU)*NVEC(NU) > + C3*NVEC(MU)*K3PT(1,NU) > + C4*NVEC(MU)*K3PT(2,NU) > + C5*NVEC(MU)*K3PT(3,NU) > + C6*K3PT(1,MU)*NVEC(NU) > + C7*K3PT(2,MU)*NVEC(NU) > + C8*K3PT(3,MU)*NVEC(NU) > + C9*K3PT(1,MU)*K3PT(1,NU) > + C10*K3PT(1,MU)*K3PT(2,NU) > + C11*K3PT(1,MU)*K3PT(3,NU) > + C12*K3PT(2,MU)*K3PT(1,NU) > + C13*K3PT(2,MU)*K3PT(2,NU) > + C14*K3PT(2,MU)*K3PT(3,NU) > + C15*K3PT(3,MU)*K3PT(1,NU) > + C16*K3PT(3,MU)*K3PT(2,NU) > + C17*K3PT(3,MU)*K3PT(3,NU) C HV(MU,NU) = PREFACTOR * TEMP C ENDDO ENDDO C C------------------------ C Next, we calculate ha. C------------------------ C C We need certain vectors and tensors made by dotting vectors C into the epsilon tensor. C DO MU = 0,3 K1(MU) = K3PT(1,MU) K2(MU) = K3PT(2,MU) K3(MU) = K3PT(3,MU) ENDDO CALL EPSILON1N(K1,EPSN1) CALL EPSILON1N(K2,EPSN2) CALL EPSILON1N(K3,EPSN3) CALL EPSILON2(K1,K2,EPS12) CALL EPSILON2(K1,K3,EPS13) CALL EPSILON2(K2,K3,EPS23) CALL EPSILON2N(K1,K2,EPSN12) CALL EPSILON2N(K1,K3,EPSN13) CALL EPSILON2N(K2,K3,EPSN23) CALL EPSILON3(K1,K2,K3,EPS123) C C Generate the coefficients for the hv, depending on KIND3PT. C IF (KIND3PT.EQ."QQG/QQG") THEN C C1 = (E3*K23)/(NC*TK33) C2 = -((E3*K13)/(NC*TK33)) C3 = 0.0D0 C4 = -(-2*E3**2 + K33 + 2*TK33)/(2.0D0*NC*TK33) C5 = (-(E2*E3) + K23)/(NC*TK33) C6 = -((-(E1*E3) + K13)/(NC*TK33)) C7 = E3/(NC*TK33) C8 = 0.0D0 C9 = 0.0D0 C10 = 0.0D0 C11 = 0.0D0 C12 = 0.0D0 C13 = 0.0D0 C14 = E3/(NC*TK33) C15 = 0.0D0 C16 = 0.0D0 C17 = -(1/(NC*TK33)) C ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN C C1 = 0.0D0 C2 = 0.0D0 C3 = (NC*(2*E2*K12*TK11 - E2*K22*TK11 + E1*K11*TK22 > - 2*E1*K12*TK22))/(2.0D0*TK11*TK22) C4 = 0 C5 = -(NC*(-E1**2 + 2*E1*E2 + K11 - 2*K12 - 3*TK11))/(2.0D0*TK11) C6 = -(NC*(-2*E1*E2 + E2**2 + 2*K12 - K22 + 3*TK22))/(2.0D0*TK22) C7 = 0.0D0 C8 = (E1*E2*(2*K12 - K22)*NC)/(2.0D0*TK11*TK22) C9 = -(NC*(E1*E2**2 + E2*K12 - E2*K22 > + 2*E1*TK22))/(2.0D0*TK11*TK22) C10 = (E2*NC*(-E1**2 + E1*E2 + K11 - K12 > - TK11))/(2.0D0*TK11*TK22) C11 = (E1*E2*(K11 - 2*K12)*NC)/(2.0D0*TK11*TK22) C12 = -(E1*NC*(E1*E2 - E2**2 - K12 + K22 > - TK22))/(2.0D0*TK11*TK22) C13 = -(NC*(-(E1**2*E2) + E1*K11 - E1*K12 > - 2*E2*TK11))/(2.0D0*TK11*TK22) C14 = (NC*(-(E1**2*E2) - E1*E2**2 - E2*K11 + 2*E1*K12 + 2*E2*K12 > - E1*K22 + E2*TK11 + E1*TK22))/(2.0D0*TK11*TK22) C15 = -(NC*(-(E1*E2) + E2**2 + K12 - K22 > + TK22))/(2.0D0*TK11*TK22) C16 = (NC*(-E1**2 + E1*E2 + K11 - K12 - TK11))/(2.0D0*TK11*TK22) C17 = 0.0D0 C ELSE IF (KIND3PT.EQ."QQG/ALL") THEN C C1 = 0.0D0 C2 = 0.0D0 C3 = (NC*(2*E2*K12*TK11 - E2*K22*TK11 + E1*K11*TK22 > - 2*E1*K12*TK22))/(2.0D0*TK11*TK22) C4 = 0 C5 = -(NC*(-E1**2 + 2*E1*E2 + K11 - 2*K12 - 3*TK11))/(2.0D0*TK11) C6 = -(NC*(-2*E1*E2 + E2**2 + 2*K12 - K22 + 3*TK22))/(2.0D0*TK22) C7 = 0.0D0 C8 = (E1*E2*(2*K12 - K22)*NC)/(2.0D0*TK11*TK22) C9 = -(NC*(E1*E2**2 + E2*K12 - E2*K22 > + 2*E1*TK22))/(2.0D0*TK11*TK22) C10 = (E2*NC*(-E1**2 + E1*E2 + K11 - K12 > - TK11))/(2.0D0*TK11*TK22) C11 = (E1*E2*(K11 - 2*K12)*NC)/(2.0D0*TK11*TK22) C12 = -(E1*NC*(E1*E2 - E2**2 - K12 + K22 > - TK22))/(2.0D0*TK11*TK22) C13 = -(NC*(-(E1**2*E2) + E1*K11 - E1*K12 > - 2*E2*TK11))/(2.0D0*TK11*TK22) C14 = (NC*(-(E1**2*E2) - E1*E2**2 - E2*K11 + 2*E1*K12 + 2*E2*K12 > - E1*K22 + E2*TK11 + E1*TK22))/(2.0D0*TK11*TK22) C15 = -(NC*(-(E1*E2) + E2**2 + K12 - K22 > + TK22))/(2.0D0*TK11*TK22) C16 = (NC*(-E1**2 + E1*E2 + K11 - K12 - TK11))/(2.0D0*TK11*TK22) C17 = 0.0D0 C C1 = C1 + (E3*K23)/(NC*TK33) C2 = C2 - ((E3*K13)/(NC*TK33)) C4 = C4 - (-2*E3**2 + K33 + 2*TK33)/(2.0D0*NC*TK33) C5 = C5 + (-(E2*E3) + K23)/(NC*TK33) C6 = C6 - ((-(E1*E3) + K13)/(NC*TK33)) C7 = C7 + E3/(NC*TK33) C14 = C14 + E3/(NC*TK33) C17 = C17 - (1/(NC*TK33)) C ELSE IF (KIND3PT.EQ."QQP/QQG") THEN C C1 = (-2*CF*E3*K23)/TK33 C2 = (2*CF*E3*K13)/TK33 C3 = 0.0D0 C4 = (CF*(-2*E3**2 + K33 + 2*TK33))/TK33 C5 = (-2*CF*(-(E2*E3) + K23))/TK33 C6 = (2*CF*(-(E1*E3) + K13))/TK33 C7 = (-2*CF*E3)/TK33 C8 = 0.0D0 C9 = 0.0D0 C10 = 0.0D0 C11 = 0.0D0 C12 = 0.0D0 C13 = 0.0D0 C14 = (-2*CF*E3)/TK33 C15 = 0.0D0 C16 = 0.0D0 C17 = (2*CF)/TK33 C ELSE WRITE(NOUT,*)'Wrong kind in subroutine vertex' STOP ENDIF C C Now we have the coefficients, so we can calculate ha. C DO MU = 0,3 DO NU = 0,3 C TEMP = C1*EPSN1(MU,NU) > + C2*EPSN2(MU,NU) > + C3*EPSN3(MU,NU) > + C4*EPS12(MU,NU) > + C5*EPS13(MU,NU) > + C6*EPS23(MU,NU) > + C7*K3PT(3,MU)*EPSN12(NU) > + C8*NVEC(MU)*EPSN13(NU) > + C9*K3PT(1,MU)*EPSN13(NU) > + C10*K3PT(2,MU)*EPSN13(NU) > + C11*NVEC(MU)*EPSN23(NU) > + C12*K3PT(1,MU)*EPSN23(NU) > + C13*K3PT(2,MU)*EPSN23(NU) > + C14*NVEC(MU)*EPS123(NU) > + C15*K3PT(1,MU)*EPS123(NU) > + C16*K3PT(2,MU)*EPS123(NU) > + C17*K3PT(3,MU)*EPS123(NU) C HA(MU,NU) = PREFACTOR * TEMP C ENDDO ENDDO C C----------------------------- C Now, we have both hv and ha. C----------------------------- C C Alternative for IF (FLAG.NE.'renormalize 3 pt') THEN C ELSE C C We need the renormalization counter term. C TL(0) = 0.0D0 OMEGASQ = 0.0D0 DO MU = 1,3 TL(MU) =(K3PT(1,MU) + K3PT(2,MU) + K3PT(3,MU))/3.0D0 OMEGASQ = OMEGASQ + TL(MU)**2 ENDDO OMEGASQ = OMEGASQ + MUMSBAR**2 OMEGA = COMPLEXSQRT(OMEGASQ) C C Generate the coefficients for the hv counter term, C depending on KIND3PT. C IF (KIND3PT.EQ."QQG/QQG") THEN C CR1 = - 1.0D0/(4.0D0*NC*OMEGA**3) > - 3.0D0*MUMSBAR**2/(16.0D0*NC*OMEGA**5) CR2 = - 3.0D0/(8.0D0*NC*OMEGA**5) CR3 = 1.0D0/(8.0D0*NC*OMEGA**3) C ELSE IF (KIND3PT.EQ."QQG/GGQ") THEN C CR1 = NC/(4.0D0*OMEGA**3) > + 3.0D0*NC*MUMSBAR**2/(16.0D0*OMEGA**5) CR2 = - 5.0D0*NC/(8.0D0*OMEGA**5) CR3 = - NC/(8.0D0*OMEGA**3) C ELSE IF (KIND3PT.EQ."QQG/ALL") THEN C CR1 = NC/(4.0D0*OMEGA**3) > + 3.0D0*NC*MUMSBAR**2/(16.0D0*OMEGA**5) CR2 = - 5.0D0*NC/(8.0D0*OMEGA**5) CR3 = - NC/(8.0D0*OMEGA**3) C CR1 = CR1 - 1.0D0/(4.0D0*NC*OMEGA**3) > - 3.0D0*MUMSBAR**2/(16.0D0*NC*OMEGA**5) CR2 = CR2 - 3.0D0/(8.0D0*NC*OMEGA**5) CR3 = CR3 + 1.0D0/(8.0D0*NC*OMEGA**3) C ELSE IF (KIND3PT.EQ."QQP/QQG") THEN C CR1 = CF/(2.0D0*OMEGA**3) > + 3.0D0*CF*MUMSBAR**2/(8.0D0*OMEGA**5) CR2 = 3.0D0*CF/(4.0D0*OMEGA**5) CR3 = - CF/(4.0D0*OMEGA**3) C ELSE WRITE(NOUT,*)'Wrong kind in subroutine vertex' STOP ENDIF C C Now we have the coefficients, so we can calculate the hv counter term. C The ha counter term is zero. C DO MU = 0,3 DO NU = 0,3 HV(MU,NU) = - CR1*G(MU,NU) > - CR2*TL(MU)*TL(NU) > - CR3*NVEC(MU)*NVEC(NU) HA(MU,NU) = 0.0D0 ENDDO ENDDO RETURN C C End IF (CUT3PT(1).OR.CUT3PT(2).OR.CUT3PT(3)) THEN ... ELSE ... C ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE TWOPT2(KIND2PT2,K2PT2,CUT2PT2,MUMSBAR,FLAG,VOUT) C In: CHARACTER*13 KIND2PT2 COMPLEX*16 K2PT2(0:5,0:3) LOGICAL CUT2PT2(1:5) REAL*8 MUMSBAR CHARACTER*16 FLAG C Out: COMPLEX*16 VOUT(0:3) C C The two-loop contribution to the quark propagator. The function is C a dot product of a four-vector VOUT(mu) with gamma(mu), times a C unit color matrix. This subroutine calculates VOUT(mu). (There is C another contribution proportional to gamma(mu) gamma(5), but this C contribution is not needed at our level of perturbation theory.) The C contribution includes the self-energy diagram and the adjoining bare C quark propagators. The calculation includes the denominator factors. C Some of the internal propagators may be cut, as specified by cut2pt2, C where cut2pt2(j) = .true. indicates that the corresponding line is C cut. C C The variable kind2pt2 tells what sort of graph we have. C C 1) There are graphs with two overlapping three point functions, C incicated by kind2pt2 = OVERLAP/abcde where a,...,e are chosen from C Q,G. Here Q denotes "quark" or "antiquark" while G denotes "gluon. C These characters indicate the flavors on the internal lines. There C are two possibilities: OVERLAP/QGGQQ and OVERLAP/QGQGG. (The first C of these has all qqg vertices, while the second has two qqg vertices C and one ggg vertex.) C C 2) There are graphs with a one loop two point function nested inside C the two loop two point function. These are indicated by C kind2pt2 = NESTED /abcde, where, again, a,...,e are chosen from C Q,G. There are three possibilities: C NESTED /QGGGG gluon self-enegy with a gluon loop C NESTED /QGGQQ gluon self-enegy with a quark loop C NESTED /GQQGQ quark self-enegy C C Numbering for graphs of type OVERLAP: C vrtx1 attaches to the incoming quark line C vrtx2 attaches to the outgoing quark line C vrtx3 is the internal vertex attached to a quark line from vrtx1 C vrtx4 is the other internal vertex C k0(mu) is the momentum of the quark line entering vrtx1 C k1(mu) is the momentum of the internal line from vrtx1 to vrtx3 C k2(mu) is the momentum of the internal line from vrtx1 to vrtx4 C k3(mu) is the momentum of the internal line from vrtx3 to vrtx2 C k4(mu) is the momentum of the internal line from vrtx4 to vrtx2 C k5(mu) is the momentum of the internal line from vrtx3 to vrtx4 C C Numbering for graphs of type NESTED: C vrtx1 attaches to the incoming quark line C vrtx2 attaches to the outgoing quark line C vrtx3 is the internal vertex attached to a line from vrtx1 C vrtx4 is the other internal vertex C k0(mu) is the momentum of the quark line entering vrtx1 C k1(mu) is the momentum of the internal line from vrtx1 to vrtx2 C k2(mu) is the momentum of the internal line from vrtx1 to vrtx3 C k3(mu) is the momentum of the internal line from vrtx4 to vrtx2 C k4(mu) ane k5(mu) are the momentum of the internal lines C from vrtx3 to vrtx4. For a quark internal self-energy, C 4 is the gluon and 5 is the quark line. C C The FLAG variable passed on to lower level subroutines. C C 31 December 2001 C C For testing purposes only: C LOGICAL OVERRIDE,LEFTOVERRIDE C COMMON /TESTING/ OVERRIDE,LEFTOVERRIDE C --- C COMPLEX*16 COMPLEXSQRT COMPLEX*16 TK00,TK11,TK22,TK33,TK44 COMPLEX*16 K00,K11,K22,K33,K44 COMPLEX*16 TEMP,PREFACTOR COMPLEX*16 K0(0:3),K1(0:3),K2(0:3),K3(0:3),K4(0:3),K5(0:3) COMPLEX*16 E0,E1,E2,E3,E4 LOGICAL CUT(1:5) COMPLEX*16 X(9) C COMPLEX*16 EA4GGNIK0K1K2,EA4GK0K1,EA4GK2IGNK0K1,EA4GK2IK0K1K2 COMPLEX*16 EA4QGNIK0K1K2,EA4QK0K1,EA4QK2IGNK0K1,EA4QK2IK0K1K2 COMPLEX*16 EA5GGNIK0K3K4,EA5GK0K3,EA5GK4IGNK0K3,EA5GK4IK0K3K4 COMPLEX*16 EA5QGNIK0K3K4,EA5QK0K4,EA5QK3IGNK0K4,EA5QK3IK0K3K4 COMPLEX*16 K0K1,K0K2,K0K3,K0K4,K1K2,K3K4,TRACEV4G,TRACEV4Q COMPLEX*16 TRACEV5G,TRACEV5Q,V4GWGNK0,V4GWGNK1,V4GWGNK2,V4GWK0K1 COMPLEX*16 V4GWK1K0,V4GWK2GN,V4GWK2K0,V4GWK2K1,V4GWK2K2,V4QWGNK0 COMPLEX*16 V4QWGNK1,V4QWGNK2,V4QWK0K1,V4QWK1K0,V4QWK2GN,V4QWK2K0 COMPLEX*16 V4QWK2K1,V4QWK2K2,V5GWGNK0,V5GWGNK3,V5GWGNK4,V5GWK0K3 COMPLEX*16 V5GWK3K0,V5GWK4GN,V5GWK4K0,V5GWK4K3,V5GWK4K4,V5QWGNK0 COMPLEX*16 V5QWGNK3,V5QWGNK4,V5QWK0K4,V5QWK3GN,V5QWK3K0,V5QWK3K3 COMPLEX*16 V5QWK3K4,V5QWK4K0,A4GGNI(0:3),A4GK2I(0:3),A4QGNI(0:3) COMPLEX*16 A4QK2I(0:3),A5GGNI(0:3),A5GK4I(0:3),A5QGNI(0:3) COMPLEX*16 A5QK3I(0:3),EA4GGNIK1K2(0:3),EA4GK1(0:3) COMPLEX*16 EA4GK2IGNK1(0:3),EA4GK2IK1K2(0:3),EA4QGNIK1K2(0:3) COMPLEX*16 EA4QK1(0:3),EA4QK2IGNK1(0:3),EA4QK2IK1K2(0:3) COMPLEX*16 EA5GGNIK3K4(0:3),EA5GK3(0:3),EA5GK4IGNK3(0:3) COMPLEX*16 EA5GK4IK3K4(0:3),EA5QGNIK3K4(0:3),EA5QK3IGNK4(0:3) COMPLEX*16 EA5QK3IK3K4(0:3),EA5QK4(0:3),V4GGNI(0:3),V4GIK1(0:3) COMPLEX*16 V4GK1I(0:3),V4GK2I(0:3),V4QGNI(0:3),V4QIK1(0:3) COMPLEX*16 V4QK1I(0:3),V4QK2I(0:3),V5GGNI(0:3),V5GIK3(0:3) COMPLEX*16 V5GK3I(0:3),V5GK4I(0:3),V5QGNI(0:3),V5QIK4(0:3) COMPLEX*16 V5QK3I(0:3),V5QK4I(0:3),A4G(0:3,0:3),A4Q(0:3,0:3) COMPLEX*16 A5G(0:3,0:3),A5Q(0:3,0:3),V4G(0:3,0:3),V4Q(0:3,0:3) COMPLEX*16 V5G(0:3,0:3),V5Q(0:3,0:3) C CHARACTER*7 KIND3PT LOGICAL OVERLAP,QQGVERTS,TRIPLEGLUE LOGICAL NESTED,NESTEDGLUE,NESTEDQUARK,GLUELOOP,QUARKLOOP COMPLEX*16 K2PT(0:2,0:3),Q(0:3) COMPLEX*16 OMEGASQ,QSQ CHARACTER*9 KIND2PT LOGICAL CUT2PT(0:3) COMPLEX*16 OUTG(0:3,0:3) COMPLEX*16 MK1(0:3),TRACEM,DOTQK1,MQK1 COMPLEX*16 OUTQ(0:3) COMPLEX*16 OMEGA1SQ,BAREPROP(0:3,0:3),DM(0:3),QM,DQM COMPLEX*16 TRACEBAREPROP C COMPLEX*16 GN(0:3) DATA GN /(1.0D0,0.0D0),(0.0D0,0.0D0), > (0.0D0,0.0D0),(0.0D0,0.0D0)/ REAL*8 METRIC(0:3) DATA METRIC / 1.0D0,-1.0D0,-1.0D0,-1.0D0 / INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF REAL*8 CF INTEGER MU,NU,ALPHA LOGICAL LEFT,RIGHT C COMPLEX*16 K3PT(3,0:3) LOGICAL CUT3PT(3) C CF = (NC**2 - 1.0D0)/(2.0D0*NC) C C Set logical variables according to what case we have. C OVERLAP = .FALSE. QQGVERTS = .FALSE. TRIPLEGLUE = .FALSE. NESTED = .FALSE. NESTEDGLUE = .FALSE. NESTEDQUARK = .FALSE. GLUELOOP = .FALSE. QUARKLOOP = .FALSE. IF (KIND2PT2.EQ.'OVERLAP/QGGQQ') THEN OVERLAP = .TRUE. QQGVERTS = .TRUE. ELSE IF (KIND2PT2.EQ.'OVERLAP/QGQGG') THEN OVERLAP = .TRUE. TRIPLEGLUE = .TRUE. ELSE IF (KIND2PT2.EQ.'NESTED /QGGGG') THEN NESTED = .TRUE. NESTEDGLUE = .TRUE. GLUELOOP = .TRUE. ELSE IF (KIND2PT2.EQ.'NESTED /QGGQQ') THEN NESTED = .TRUE. NESTEDGLUE = .TRUE. QUARKLOOP = .TRUE. ELSE IF (KIND2PT2.EQ.'NESTED /GQQGQ') THEN NESTED = .TRUE. NESTEDQUARK = .TRUE. ELSE WRITE(NOUT,*)'Not programmed for that.' STOP ENDIF C IF (OVERLAP) THEN C C Short form of momentum variables and rename cut variables C for overlap graphs. C DO MU = 0,3 K0(MU) = K2PT2(0,MU) K1(MU) = K2PT2(1,MU) K2(MU) = K2PT2(2,MU) K3(MU) = K2PT2(3,MU) K4(MU) = K2PT2(4,MU) K5(MU) = K2PT2(5,MU) ENDDO CUT(1) = CUT2PT2(1) CUT(2) = CUT2PT2(2) CUT(3) = CUT2PT2(3) CUT(4) = CUT2PT2(4) CUT(5) = CUT2PT2(5) C C We have an OVERLAP type graph. We can treat it two different C ways: either the left=hand three point graph is calculated C using subroutine VERTEX or else the right-hand three point C graph is calculated with subroutine VERTEX. We choose according C to which lines are cut. Generally, we take the "left" choice, C but if the right-hand loop is virtual, we take the "right" choice. C LEFT = .TRUE. RIGHT = .FALSE. IF (CUT2PT2(1).AND.CUT2PT2(2)) THEN LEFT = .FALSE. RIGHT = .TRUE. ENDIF C C For testing purposes, we include code to override this choice. C C IF (OVERRIDE) THEN C LEFT = LEFTOVERRIDE C RIGHT = .NOT.LEFT C ENDIF C C Calculate according to case, with logic C IF (QQGVERTS.AND.RIGHT) THEN C ELSE IF (QQGVERTS.AND.LEFT) THEN C ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN C ELSE IF (TRIPLEGLUE.AND.LEFT) THEN C ELSE C ENDIF C C C--- C IF (QQGVERTS.AND.RIGHT) THEN C C--- TK00 = 0.0D0 DO MU = 1,3 TK00 = TK00 - K0(MU)**2 ENDDO E0 = K0(0) K00 = E0**2 + TK00 PREFACTOR = 1.0D0/K00**2 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF DO MU = 0,3 K3PT(1,MU) = -K4(MU) K3PT(2,MU) = -K5(MU) K3PT(3,MU) = K3(MU) ENDDO CUT3PT(1) = CUT(4) CUT3PT(2) = CUT(5) CUT3PT(3) = CUT(3) KIND3PT = 'QQG/QQG' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V4Q,A4Q) TRACEV4Q = 0.0D0 DO MU = 0,3 TRACEV4Q = TRACEV4Q + V4Q(MU,MU)*METRIC(MU) ENDDO V4QWGNK0 = 0.0D0 V4QWGNK1 = 0.0D0 V4QWGNK2 = 0.0D0 V4QWK0K1 = 0.0D0 V4QWK1K0 = 0.0D0 V4QWK2GN = 0.0D0 V4QWK2K0 = 0.0D0 V4QWK2K1 = 0.0D0 V4QWK2K2 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V4QWGNK0 = V4QWGNK0 > + V4Q(MU,NU)*GN(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V4QWGNK1 = V4QWGNK1 > + V4Q(MU,NU)*GN(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4QWGNK2 = V4QWGNK2 > + V4Q(MU,NU)*GN(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V4QWK0K1 = V4QWK0K1 > + V4Q(MU,NU)*K0(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4QWK1K0 = V4QWK1K0 > + V4Q(MU,NU)*K1(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V4QWK2GN = V4QWK2GN > + V4Q(MU,NU)*K2(MU)*GN(NU)*METRIC(MU)*METRIC(NU) V4QWK2K0 = V4QWK2K0 > + V4Q(MU,NU)*K2(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V4QWK2K1 = V4QWK2K1 > + V4Q(MU,NU)*K2(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4QWK2K2 = V4QWK2K2 > + V4Q(MU,NU)*K2(MU)*K2(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 A4QGNI(MU) = 0.0D0 A4QK2I(MU) = 0.0D0 V4QGNI(MU) = 0.0D0 V4QIK1(MU) = 0.0D0 V4QK1I(MU) = 0.0D0 V4QK2I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 A4QGNI(MU) = A4QGNI(MU) + A4Q(NU,MU)*GN(NU)*METRIC(NU) A4QK2I(MU) = A4QK2I(MU) + A4Q(NU,MU)*K2(NU)*METRIC(NU) V4QGNI(MU) = V4QGNI(MU) + V4Q(NU,MU)*GN(NU)*METRIC(NU) V4QIK1(MU) = V4QIK1(MU) + V4Q(MU,NU)*K1(NU)*METRIC(NU) V4QK1I(MU) = V4QK1I(MU) + V4Q(NU,MU)*K1(NU)*METRIC(NU) V4QK2I(MU) = V4QK2I(MU) + V4Q(NU,MU)*K2(NU)*METRIC(NU) ENDDO ENDDO K0K1 = 0.0D0 K0K2 = 0.0D0 K1K2 = 0.0D0 DO MU = 0,3 K0K1 = K0K1 + K0(MU)*K1(MU)*METRIC(MU) K0K2 = K0K2 + K0(MU)*K2(MU)*METRIC(MU) K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A4Q,K0,K1,EA4QK0K1) CALL EPSILON4(A4QGNI,K0,K1,K2,EA4QGNIK0K1K2) CALL EPSILON4(A4QK2I,GN,K0,K1,EA4QK2IGNK0K1) CALL EPSILON4(A4QK2I,K0,K1,K2,EA4QK2IK0K1K2) CALL EPSILON3(A4QGNI,K1,K2,EA4QGNIK1K2) CALL EPSILON3(A4QK2I,GN,K1,EA4QK2IGNK1) CALL EPSILON3(A4QK2I,K1,K2,EA4QK2IK1K2) CALL EPSILONT1(A4Q,K1,EA4QK1) DO NU = 0,3 C X(1) = 0 X(2) = -EA4QK2IK1K2(NU) + V4QWK2K2*K1(NU) - V4QWK2K1*K2(NU) > + TK22*(EA4QK1(NU) - TRACEV4Q*K1(NU) + V4QIK1(NU) + V4QK1I(NU)) > - K1K2*V4QK2I(NU) X(3) = EA4QGNIK1K2(NU) - EA4QK2IGNK1(NU) + V4QWK2K1*GN(NU) > + (-V4QWGNK2 - V4QWK2GN)*K1(NU) + V4QWGNK1*K2(NU) > + K1K2*V4QGNI(NU) + E1*V4QK2I(NU) X(4) = X(2) + E2*X(3) X(5) = X(1) + K00*X(4) X(6) = -2*EA4QK2IK0K1K2 + TK22*(-2*EA4QK0K1 + 2*K0K1*TRACEV4Q > - 2*V4QWK0K1 - 2*V4QWK1K0) + 2*K1K2*V4QWK2K0 + 2*K0K2*V4QWK2K1 > - 2*K0K1*V4QWK2K2 X(7) = 2*EA4QGNIK0K1K2 + 2*EA4QK2IGNK0K1 - 2*K1K2*V4QWGNK0 > - 2*K0K2*V4QWGNK1 + K0K1*(2*V4QWGNK2 + 2*V4QWK2GN) > - 2*E1*V4QWK2K0 - 2*E0*V4QWK2K1 X(8) = X(6) + E2*X(7) X(9) = X(5) + K0(NU)*X(8) VOUT(NU) = (CF*X(9))/TK22 VOUT(NU) = VOUT(NU)*PREFACTOR C ENDDO C ELSE IF (QQGVERTS.AND.LEFT) THEN C C--- TK00 = 0.0D0 DO MU = 1,3 TK00 = TK00 - K0(MU)**2 ENDDO E0 = K0(0) K00 = E0**2 + TK00 PREFACTOR = 1.0D0/K00**2 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 DO MU = 1,3 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 ENDDO K33 = E3**2 + TK33 K44 = E4**2 + TK44 IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF DO MU = 0,3 K3PT(1,MU) = -K5(MU) K3PT(2,MU) = -K1(MU) K3PT(3,MU) = K2(MU) ENDDO CUT3PT(1) = CUT(5) CUT3PT(2) = CUT(1) CUT3PT(3) = CUT(2) KIND3PT = 'QQG/QQG' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V5Q,A5Q) TRACEV5Q = 0.0D0 DO MU = 0,3 TRACEV5Q = TRACEV5Q + V5Q(MU,MU)*METRIC(MU) ENDDO V5QWGNK0 = 0.0D0 V5QWGNK3 = 0.0D0 V5QWGNK4 = 0.0D0 V5QWK0K4 = 0.0D0 V5QWK3GN = 0.0D0 V5QWK3K0 = 0.0D0 V5QWK3K3 = 0.0D0 V5QWK3K4 = 0.0D0 V5QWK4K0 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V5QWGNK0 = V5QWGNK0 > + V5Q(MU,NU)*GN(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V5QWGNK3 = V5QWGNK3 > + V5Q(MU,NU)*GN(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V5QWGNK4 = V5QWGNK4 > + V5Q(MU,NU)*GN(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V5QWK0K4 = V5QWK0K4 > + V5Q(MU,NU)*K0(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V5QWK3GN = V5QWK3GN > + V5Q(MU,NU)*K3(MU)*GN(NU)*METRIC(MU)*METRIC(NU) V5QWK3K0 = V5QWK3K0 > + V5Q(MU,NU)*K3(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V5QWK3K3 = V5QWK3K3 > + V5Q(MU,NU)*K3(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V5QWK3K4 = V5QWK3K4 > + V5Q(MU,NU)*K3(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V5QWK4K0 = V5QWK4K0 > + V5Q(MU,NU)*K4(MU)*K0(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 A5QGNI(MU) = 0.0D0 A5QK3I(MU) = 0.0D0 V5QGNI(MU) = 0.0D0 V5QIK4(MU) = 0.0D0 V5QK3I(MU) = 0.0D0 V5QK4I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 A5QGNI(MU) = A5QGNI(MU) + A5Q(NU,MU)*GN(NU)*METRIC(NU) A5QK3I(MU) = A5QK3I(MU) + A5Q(NU,MU)*K3(NU)*METRIC(NU) V5QGNI(MU) = V5QGNI(MU) + V5Q(NU,MU)*GN(NU)*METRIC(NU) V5QIK4(MU) = V5QIK4(MU) + V5Q(MU,NU)*K4(NU)*METRIC(NU) V5QK3I(MU) = V5QK3I(MU) + V5Q(NU,MU)*K3(NU)*METRIC(NU) V5QK4I(MU) = V5QK4I(MU) + V5Q(NU,MU)*K4(NU)*METRIC(NU) ENDDO ENDDO K0K3 = 0.0D0 K0K4 = 0.0D0 K3K4 = 0.0D0 DO MU = 0,3 K0K3 = K0K3 + K0(MU)*K3(MU)*METRIC(MU) K0K4 = K0K4 + K0(MU)*K4(MU)*METRIC(MU) K3K4 = K3K4 + K3(MU)*K4(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A5Q,K0,K4,EA5QK0K4) CALL EPSILON4(A5QGNI,K0,K3,K4,EA5QGNIK0K3K4) CALL EPSILON4(A5QK3I,GN,K0,K4,EA5QK3IGNK0K4) CALL EPSILON4(A5QK3I,K0,K3,K4,EA5QK3IK0K3K4) CALL EPSILON3(A5QGNI,K3,K4,EA5QGNIK3K4) CALL EPSILON3(A5QK3I,GN,K4,EA5QK3IGNK4) CALL EPSILON3(A5QK3I,K3,K4,EA5QK3IK3K4) CALL EPSILONT1(A5Q,K4,EA5QK4) DO NU = 0,3 C X(1) = 0 X(2) = -EA5QK3IK3K4(NU) - V5QWK3K4*K3(NU) + V5QWK3K3*K4(NU) > - K3K4*V5QK3I(NU) + TK33*(-EA5QK4(NU) - TRACEV5Q*K4(NU) > + V5QIK4(NU) + V5QK4I(NU)) X(3) = EA5QGNIK3K4(NU) + EA5QK3IGNK4(NU) + V5QWK3K4*GN(NU) > + V5QWGNK4*K3(NU) + (-V5QWGNK3 - V5QWK3GN)*K4(NU) > + K3K4*V5QGNI(NU) + E4*V5QK3I(NU) X(4) = X(2) + E3*X(3) X(5) = X(1) + K00*X(4) X(6) = -2*EA5QK3IK0K3K4 + 2*K3K4*V5QWK3K0 - 2*K0K4*V5QWK3K3 > + 2*K0K3*V5QWK3K4 + TK33*(2*EA5QK0K4 + 2*K0K4*TRACEV5Q > - 2*V5QWK0K4 - 2*V5QWK4K0) X(7) = 2*EA5QGNIK0K3K4 - 2*EA5QK3IGNK0K4 - 2*K3K4*V5QWGNK0 > - 2*K0K3*V5QWGNK4 + K0K4*(2*V5QWGNK3 + 2*V5QWK3GN) > - 2*E4*V5QWK3K0 - 2*E0*V5QWK3K4 X(8) = X(6) + E3*X(7) X(9) = X(5) + K0(NU)*X(8) VOUT(NU) = (CF*X(9))/TK33 VOUT(NU) = VOUT(NU)*PREFACTOR C ENDDO C ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN C C--- TK00 = 0.0D0 DO MU = 1,3 TK00 = TK00 - K0(MU)**2 ENDDO E0 = K0(0) K00 = E0**2 + TK00 PREFACTOR = 1.0D0/K00**2 E1 = K1(0) TK11 = 0.0D0 E2 = K2(0) TK22 = 0.0D0 DO MU = 1,3 TK11 = TK11 - K1(MU)**2 TK22 = TK22 - K2(MU)**2 ENDDO K11 = E1**2 + TK11 K22 = E2**2 + TK22 IF (CUT(1)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK11) ELSE PREFACTOR = PREFACTOR/K11 ENDIF IF (CUT(2)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK22) ELSE PREFACTOR = PREFACTOR/K22 ENDIF DO MU = 0,3 K3PT(1,MU) = -K4(MU) K3PT(2,MU) = -K5(MU) K3PT(3,MU) = K3(MU) ENDDO CUT3PT(1) = CUT(4) CUT3PT(2) = CUT(5) CUT3PT(3) = CUT(3) KIND3PT = 'QQG/GGQ' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V4G,A4G) TRACEV4G = 0.0D0 DO MU = 0,3 TRACEV4G = TRACEV4G + V4G(MU,MU)*METRIC(MU) ENDDO V4GWGNK0 = 0.0D0 V4GWGNK1 = 0.0D0 V4GWGNK2 = 0.0D0 V4GWK0K1 = 0.0D0 V4GWK1K0 = 0.0D0 V4GWK2GN = 0.0D0 V4GWK2K0 = 0.0D0 V4GWK2K1 = 0.0D0 V4GWK2K2 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V4GWGNK0 = V4GWGNK0 > + V4G(MU,NU)*GN(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V4GWGNK1 = V4GWGNK1 > + V4G(MU,NU)*GN(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4GWGNK2 = V4GWGNK2 > + V4G(MU,NU)*GN(MU)*K2(NU)*METRIC(MU)*METRIC(NU) V4GWK0K1 = V4GWK0K1 > + V4G(MU,NU)*K0(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4GWK1K0 = V4GWK1K0 > + V4G(MU,NU)*K1(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V4GWK2GN = V4GWK2GN > + V4G(MU,NU)*K2(MU)*GN(NU)*METRIC(MU)*METRIC(NU) V4GWK2K0 = V4GWK2K0 > + V4G(MU,NU)*K2(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V4GWK2K1 = V4GWK2K1 > + V4G(MU,NU)*K2(MU)*K1(NU)*METRIC(MU)*METRIC(NU) V4GWK2K2 = V4GWK2K2 > + V4G(MU,NU)*K2(MU)*K2(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 A4GGNI(MU) = 0.0D0 A4GK2I(MU) = 0.0D0 V4GGNI(MU) = 0.0D0 V4GIK1(MU) = 0.0D0 V4GK1I(MU) = 0.0D0 V4GK2I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 A4GGNI(MU) = A4GGNI(MU) + A4G(NU,MU)*GN(NU)*METRIC(NU) A4GK2I(MU) = A4GK2I(MU) + A4G(NU,MU)*K2(NU)*METRIC(NU) V4GGNI(MU) = V4GGNI(MU) + V4G(NU,MU)*GN(NU)*METRIC(NU) V4GIK1(MU) = V4GIK1(MU) + V4G(MU,NU)*K1(NU)*METRIC(NU) V4GK1I(MU) = V4GK1I(MU) + V4G(NU,MU)*K1(NU)*METRIC(NU) V4GK2I(MU) = V4GK2I(MU) + V4G(NU,MU)*K2(NU)*METRIC(NU) ENDDO ENDDO K0K1 = 0.0D0 K0K2 = 0.0D0 K1K2 = 0.0D0 DO MU = 0,3 K0K1 = K0K1 + K0(MU)*K1(MU)*METRIC(MU) K0K2 = K0K2 + K0(MU)*K2(MU)*METRIC(MU) K1K2 = K1K2 + K1(MU)*K2(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A4G,K0,K1,EA4GK0K1) CALL EPSILON4(A4GGNI,K0,K1,K2,EA4GGNIK0K1K2) CALL EPSILON4(A4GK2I,GN,K0,K1,EA4GK2IGNK0K1) CALL EPSILON4(A4GK2I,K0,K1,K2,EA4GK2IK0K1K2) CALL EPSILON3(A4GGNI,K1,K2,EA4GGNIK1K2) CALL EPSILON3(A4GK2I,GN,K1,EA4GK2IGNK1) CALL EPSILON3(A4GK2I,K1,K2,EA4GK2IK1K2) CALL EPSILONT1(A4G,K1,EA4GK1) DO NU = 0,3 C X(1) = 0 X(2) = -EA4GK2IK1K2(NU) + V4GWK2K2*K1(NU) - V4GWK2K1*K2(NU) > + TK22*(EA4GK1(NU) - TRACEV4G*K1(NU) + V4GIK1(NU) + V4GK1I(NU)) > - K1K2*V4GK2I(NU) X(3) = EA4GGNIK1K2(NU) - EA4GK2IGNK1(NU) + V4GWK2K1*GN(NU) > + (-V4GWGNK2 - V4GWK2GN)*K1(NU) + V4GWGNK1*K2(NU) > + K1K2*V4GGNI(NU) + E1*V4GK2I(NU) X(4) = X(2) + E2*X(3) X(5) = X(1) + K00*X(4) X(6) = -2*EA4GK2IK0K1K2 + TK22*(-2*EA4GK0K1 + 2*K0K1*TRACEV4G > - 2*V4GWK0K1 - 2*V4GWK1K0) + 2*K1K2*V4GWK2K0 + 2*K0K2*V4GWK2K1 > - 2*K0K1*V4GWK2K2 X(7) = 2*EA4GGNIK0K1K2 + 2*EA4GK2IGNK0K1 - 2*K1K2*V4GWGNK0 > - 2*K0K2*V4GWGNK1 + K0K1*(2*V4GWGNK2 + 2*V4GWK2GN) > - 2*E1*V4GWK2K0 - 2*E0*V4GWK2K1 X(8) = X(6) + E2*X(7) X(9) = X(5) + K0(NU)*X(8) VOUT(NU) = (CF*X(9))/TK22 VOUT(NU) = VOUT(NU)*PREFACTOR C ENDDO C ELSE IF (TRIPLEGLUE.AND.LEFT) THEN C C--- TK00 = 0.0D0 DO MU = 1,3 TK00 = TK00 - K0(MU)**2 ENDDO E0 = K0(0) K00 = E0**2 + TK00 PREFACTOR = 1.0D0/K00**2 E3 = K3(0) TK33 = 0.0D0 E4 = K4(0) TK44 = 0.0D0 DO MU = 1,3 TK33 = TK33 - K3(MU)**2 TK44 = TK44 - K4(MU)**2 ENDDO K33 = E3**2 + TK33 K44 = E4**2 + TK44 IF (CUT(3)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK33) ELSE PREFACTOR = PREFACTOR/K33 ENDIF IF (CUT(4)) THEN PREFACTOR = PREFACTOR/2.0D0/COMPLEXSQRT(-TK44) ELSE PREFACTOR = PREFACTOR/K44 ENDIF DO MU = 0,3 K3PT(1,MU) = K5(MU) K3PT(2,MU) = -K2(MU) K3PT(3,MU) = K1(MU) ENDDO CUT3PT(1) = CUT(5) CUT3PT(2) = CUT(2) CUT3PT(3) = CUT(1) KIND3PT = 'QQG/GGQ' CALL VERTEX(KIND3PT,K3PT,CUT3PT,MUMSBAR,FLAG,V5G,A5G) TRACEV5G = 0.0D0 DO MU = 0,3 TRACEV5G = TRACEV5G + V5G(MU,MU)*METRIC(MU) ENDDO V5GWGNK0 = 0.0D0 V5GWGNK3 = 0.0D0 V5GWGNK4 = 0.0D0 V5GWK0K3 = 0.0D0 V5GWK3K0 = 0.0D0 V5GWK4GN = 0.0D0 V5GWK4K0 = 0.0D0 V5GWK4K3 = 0.0D0 V5GWK4K4 = 0.0D0 DO MU = 0,3 DO NU = 0,3 V5GWGNK0 = V5GWGNK0 > + V5G(MU,NU)*GN(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V5GWGNK3 = V5GWGNK3 > + V5G(MU,NU)*GN(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V5GWGNK4 = V5GWGNK4 > + V5G(MU,NU)*GN(MU)*K4(NU)*METRIC(MU)*METRIC(NU) V5GWK0K3 = V5GWK0K3 > + V5G(MU,NU)*K0(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V5GWK3K0 = V5GWK3K0 > + V5G(MU,NU)*K3(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V5GWK4GN = V5GWK4GN > + V5G(MU,NU)*K4(MU)*GN(NU)*METRIC(MU)*METRIC(NU) V5GWK4K0 = V5GWK4K0 > + V5G(MU,NU)*K4(MU)*K0(NU)*METRIC(MU)*METRIC(NU) V5GWK4K3 = V5GWK4K3 > + V5G(MU,NU)*K4(MU)*K3(NU)*METRIC(MU)*METRIC(NU) V5GWK4K4 = V5GWK4K4 > + V5G(MU,NU)*K4(MU)*K4(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO DO MU = 0,3 A5GGNI(MU) = 0.0D0 A5GK4I(MU) = 0.0D0 V5GGNI(MU) = 0.0D0 V5GIK3(MU) = 0.0D0 V5GK3I(MU) = 0.0D0 V5GK4I(MU) = 0.0D0 ENDDO DO MU = 0,3 DO NU = 0,3 A5GGNI(MU) = A5GGNI(MU) + A5G(NU,MU)*GN(NU)*METRIC(NU) A5GK4I(MU) = A5GK4I(MU) + A5G(NU,MU)*K4(NU)*METRIC(NU) V5GGNI(MU) = V5GGNI(MU) + V5G(NU,MU)*GN(NU)*METRIC(NU) V5GIK3(MU) = V5GIK3(MU) + V5G(MU,NU)*K3(NU)*METRIC(NU) V5GK3I(MU) = V5GK3I(MU) + V5G(NU,MU)*K3(NU)*METRIC(NU) V5GK4I(MU) = V5GK4I(MU) + V5G(NU,MU)*K4(NU)*METRIC(NU) ENDDO ENDDO K0K3 = 0.0D0 K0K4 = 0.0D0 K3K4 = 0.0D0 DO MU = 0,3 K0K3 = K0K3 + K0(MU)*K3(MU)*METRIC(MU) K0K4 = K0K4 + K0(MU)*K4(MU)*METRIC(MU) K3K4 = K3K4 + K3(MU)*K4(MU)*METRIC(MU) ENDDO CALL EPSILONT2(A5G,K0,K3,EA5GK0K3) CALL EPSILON4(A5GGNI,K0,K3,K4,EA5GGNIK0K3K4) CALL EPSILON4(A5GK4I,GN,K0,K3,EA5GK4IGNK0K3) CALL EPSILON4(A5GK4I,K0,K3,K4,EA5GK4IK0K3K4) CALL EPSILON3(A5GGNI,K3,K4,EA5GGNIK3K4) CALL EPSILON3(A5GK4I,GN,K3,EA5GK4IGNK3) CALL EPSILON3(A5GK4I,K3,K4,EA5GK4IK3K4) CALL EPSILONT1(A5G,K3,EA5GK3) DO NU = 0,3 C X(1) = 0 X(2) = -EA5GK4IK3K4(NU) - V5GWK4K4*K3(NU) + V5GWK4K3*K4(NU) > + TK44*(EA5GK3(NU) + TRACEV5G*K3(NU) - V5GIK3(NU) - V5GK3I(NU)) > + K3K4*V5GK4I(NU) X(3) = EA5GGNIK3K4(NU) - EA5GK4IGNK3(NU) - V5GWK4K3*GN(NU) > + (V5GWGNK4 + V5GWK4GN)*K3(NU) - V5GWGNK3*K4(NU) > - K3K4*V5GGNI(NU) - E3*V5GK4I(NU) X(4) = X(2) + E4*X(3) X(5) = X(1) + K00*X(4) X(6) = -2*EA5GK4IK0K3K4 + TK44*(-2*EA5GK0K3 - 2*K0K3*TRACEV5G > + 2*V5GWK0K3 + 2*V5GWK3K0) - 2*K3K4*V5GWK4K0 - 2*K0K4*V5GWK4K3 > + 2*K0K3*V5GWK4K4 X(7) = 2*EA5GGNIK0K3K4 + 2*EA5GK4IGNK0K3 + 2*K3K4*V5GWGNK0 > + 2*K0K4*V5GWGNK3 + K0K3*(-2*V5GWGNK4 - 2*V5GWK4GN) > + 2*E3*V5GWK4K0 + 2*E0*V5GWK4K3 X(8) = X(6) + E4*X(7) X(9) = X(5) + K0(NU)*X(8) VOUT(NU) = -((CF*X(9))/TK44) VOUT(NU) = VOUT(NU)*PREFACTOR C ENDDO ELSE WRITE(*,*)'Not programmed for that' STOP ENDIF C C------------- C C Alternative for IF (OVERLAP) THEN. C ELSE IF (NESTED) THEN C C We have a nested graph. C DO MU = 0,3 K2PT(0,MU) = K2PT2(2,MU) K2PT(1,MU) = K2PT2(4,MU) K2PT(2,MU) = K2PT2(5,MU) Q(MU) = K2PT2(0,MU) K1(MU) = K2PT2(1,MU) ENDDO OMEGASQ = Q(1)**2 + Q(2)**2 + Q(3)**2 QSQ = Q(0)**2 - OMEGASQ OMEGA1SQ = K1(1)**2 + K1(2)**2 + K1(3)**2 C CUT2PT(0) = CUT2PT2(2) CUT2PT(1) = CUT2PT2(4) CUT2PT(2) = CUT2PT2(5) CUT2PT(3) = CUT2PT2(3) C C We need the factor equal to 1/k^2 for an uncut propagator C and 1/ 2|\vec k| for a cut propagator. BUT line 1 is always C cut, propagator 0 never cut, and the one-loop two point function C that is nested inside has the factor for propagators 2,3,4,5. C PREFACTOR = CF/(QSQ**2*2.0D0*COMPLEXSQRT(OMEGA1SQ)) C IF (NESTEDGLUE) THEN C C Our nested graph has a gluon self-energy insertion. C Calculate OUTG according to what kind of self-energy insertion it is. C IF (GLUELOOP) THEN KIND2PT = 'GLUONLOOP' CALL TWOPOINTG(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUTG) ELSE IF (QUARKLOOP) THEN KIND2PT = 'QUARKLOOP' CALL TWOPOINTG(KIND2PT,K2PT,CUT2PT,MUMSBAR,FLAG,OUTG) ENDIF C C Now comlete the calculation for a gluon self-energy insertion. C DO ALPHA = 0,3 TEMP = 0.0D0 DO NU = 0,3 TEMP = TEMP + OUTG(ALPHA,NU)*K1(NU)*METRIC(NU) ENDDO MK1(ALPHA) = TEMP ENDDO C TRACEM = 0.0D0 DOTQK1 = 0.0D0 DO MU = 0,3 TRACEM = TRACEM + OUTG(MU,MU)*METRIC(MU) DOTQK1 = DOTQK1 + Q(MU)*K1(MU)*METRIC(MU) ENDDO C MQK1 = 0.0D0 DO MU = 0,3 DO NU = 0,3 MQK1 = MQK1 + OUTG(MU,NU)*Q(MU)*K1(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO C DO ALPHA = 0,3 TEMP = - 2.0D0*QSQ*MK1(ALPHA) TEMP = TEMP + 4.0D0*Q(ALPHA)*MQK1 TEMP = TEMP + (QSQ*K1(ALPHA) - 2.0D0*Q(ALPHA)*DOTQK1)*TRACEM VOUT(ALPHA) = PREFACTOR*TEMP ENDDO C C Alternative for IF (NESTEDGLUE) THEN C ELSE IF (NESTEDQUARK) THEN C C Our nested graph has a quark self-energy insertion. C Calculate OUTQ. C CALL TWOPOINTQ(K2PT,CUT2PT,MUMSBAR,FLAG,OUTQ) C C Now comlete the calculation for a quark self-energy insertion. C C The gluon propagator in Coulomb gauge for an on-shell gluon C with three-momentum K1(mu). C BAREPROP(0,0) = 0.0D0 DO MU = 1,3 BAREPROP(0,MU) = 0.0D0 BAREPROP(MU,0) = 0.0D0 BAREPROP(MU,MU) = 1.0D0 - K1(MU)**2/OMEGA1SQ DO NU = MU+1,3 TEMP = - K1(MU)*K1(NU)/OMEGA1SQ BAREPROP(MU,NU) = TEMP BAREPROP(NU,MU) = TEMP ENDDO ENDDO TRACEBAREPROP = -2.0D0 C DO ALPHA = 0,3 DM(ALPHA) = 0.0D0 DO NU = 0,3 DM(ALPHA) = DM(ALPHA) + BAREPROP(ALPHA,NU)*OUTQ(NU)*METRIC(NU) ENDDO ENDDO C DQM = 0.0D0 QM = 0.0D0 DO MU = 0,3 QM = QM + Q(MU)*OUTQ(MU)*METRIC(MU) DO NU = 0,3 DQM = DQM + BAREPROP(MU,NU)*Q(MU)*OUTQ(NU)*METRIC(MU)*METRIC(NU) ENDDO ENDDO C DO ALPHA = 0,3 TEMP = - 2.0D0*QSQ*DM(ALPHA) TEMP = TEMP + 4.0D0*Q(ALPHA)*DQM TEMP = TEMP > + (QSQ*OUTQ(ALPHA) - 2.0D0*Q(ALPHA)*QM)*TRACEBAREPROP VOUT(ALPHA) = PREFACTOR*TEMP ENDDO C C Close IF (NESTEDGLUE) THEN ... ELSEIF (NESTEDQUARK) THEN C ELSE WRITE(NOUT,*)'Oops, something must have gone wrong.' STOP ENDIF C C Close IF (OVERLAP) THEN ... ELSE IF (NESTED) THEN C ELSE WRITE(NOUT,*)'Oops, something has gone wrong.' STOP ENDIF C RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C C C Dotting the epsilon tensor into vectors and tensors C C C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE EPSILON4(V1,V2,V3,V4,OUT) C In: COMPLEX*16 V1(0:3),V2(0:3),V3(0:3),V4(0:3) C Out: COMPLEX*16 OUT C C Computes the contraction of the epsilon tensor with four four-vectors, C giving a scalar result, OUT. The four vectors have upper indices. C The epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1. C C 5 June 2001 C INTEGER N INTEGER MU(24,4),SIGN(24) C C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that C define the contributions to epsilon and J = 1,...,4 labelling C the four indices of epsilon. C DATA MU /0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, > 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, > 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, > 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/ C C Sign(N) is minus the signature of the permutation. C DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, > -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/ C OUT = (0.0D0,0.0D0) DO N = 1,24 OUT = OUT > + SIGN(N)*V1(MU(N,1))*V2(MU(N,2))*V3(MU(N,3))*V4(MU(N,4)) ENDDO RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE EPSILON3(V2,V3,V4,OUT) C In: COMPLEX*16 V2(0:3),V3(0:3),V4(0:3) C Out: COMPLEX*16 OUT(0:3) C C Computes the contraction of the epsilon tensor with three C four-vectors, giving a vector result, OUT(mu1). The vectors have C upper indices. The epsilon tensor has lower indices, so C epsilon(0,1,2,3) = -1, and in addition we need a metric tensor to C raise the index of OUT. We calculate C C Out(mu1) = epsilon(mu1,mu2,mu3,mu4) v2(mu2) v3(mu3) v4(mu4) C C 5 June 2001 C INTEGER N,NU INTEGER MU(24,4),SIGN(24) C C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that C define the contributions to epsilon and J = 1,...,4 labelling C the four indices of epsilon. C DATA MU /0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, > 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, > 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, > 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/ C C Sign(N) is minus the signature of the permutation. C DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, > -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/ C REAL*8 METRIC(0:3) DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/ C DO NU = 0,3 OUT(NU) = (0.0D0,0.0D0) ENDDO DO N = 1,24 NU = MU(N,1) OUT(NU) = OUT(NU) > + METRIC(NU)*SIGN(N)*V2(MU(N,2))*V3(MU(N,3))*V4(MU(N,4)) ENDDO RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE EPSILON2(V3,V4,OUT) C In: COMPLEX*16 V3(0:3),V4(0:3) C Out: COMPLEX*16 OUT(0:3,0:3) C C Computes the contraction of the epsilon tensor with two C four-vectors, giving a second rank tensor result, OUT(mu1,mu2). The C vectors have upper indices. The epsilon tensor has lower C indices, so epsilon(0,1,2,3) = -1, and in addition we need a metric C tensor to raise the indices of OUT. We calculate C C Out(mu1,mu2) = epsilon(mu1,mu2,mu3,mu4) v3(mu3) v4(mu4) C C 5 June 2001 C INTEGER N,NU1,NU2 INTEGER MU(24,4),SIGN(24) C C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that C define the contributions to epsilon and J = 1,...,4 labelling C the four indices of epsilon. C DATA MU /0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, > 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, > 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, > 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/ C C Sign(N) is minus the signature of the permutation. C DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, > -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/ C REAL*8 METRIC(0:3) DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/ C DO NU1 = 0,3 DO NU2 = 0,3 OUT(NU1,NU2) = (0.0D0,0.0D0) ENDDO ENDDO DO N = 1,24 NU1 = MU(N,1) NU2 = MU(N,2) OUT(NU1,NU2) = OUT(NU1,NU2) > + METRIC(NU1)*METRIC(NU2)*SIGN(N)*V3(MU(N,3))*V4(MU(N,4)) ENDDO RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE EPSILON2N(V3,V4,OUT) C In: COMPLEX*16 V3(0:3),V4(0:3) C Out: COMPLEX*16 OUT(0:3) C C Computes the contraction of the epsilon tensor with two C four-vectors and the unit vector n in the 0 direction, giving a C four-vector result, OUT(mu1). The vectors have upper indices. The C epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1, and in C addition we need a metric tensor to raise the index of OUT. However C the metric contributes a factor (-1) in each case. We C calculate C C Out(mu1) = epsilon(mu1,mu2,mu3,mu4) n(mu2) v3(mu3) v4(mu4) C C 5 June 2001 C INTEGER N,NU INTEGER MU(6,4),SIGN(6) C C Mu is Mu(N,J) with N = 1,...,6 labelling the permutations that C define the contributions to epsilon that have 0 for the second C index and J = 1,...,4 labelling the four indices of epsilon. C DATA MU /1,1,2,2,3,3, > 0,0,0,0,0,0, > 2,3,1,3,1,2, > 3,2,3,1,2,1/ C C Sign(N) is minus the signature of the permutation. C DATA SIGN /1,-1,-1,1,1,-1/ C C Our result would have a factor METRIC(NU), but this factor is C always -1. C DO NU = 0,3 OUT(NU) = (0.0D0,0.0D0) ENDDO DO N = 1,6 NU = MU(N,1) OUT(NU) = OUT(NU) - SIGN(N)*V3(MU(N,3))*V4(MU(N,4)) ENDDO RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE EPSILON1N(V4,OUT) C In: COMPLEX*16 V4(0:3) C Out: COMPLEX*16 OUT(0:3,0:3) C C Computes the contraction of the epsilon tensor with one C four-vector and the unit vector n in the 0 direction, giving a C tensor result, OUT(mu1,mu2). The vectors have upper indices. The C epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1, and in C addition we need a metric tensor to raise the index of OUT. C However, the metric tensor in each case contributes (-1)^2 = 1. We C calculate C C Out(mu1,mu2) = epsilon(mu1,mu2,mu3,mu4) n(mu3) v4(mu4) C C 7 December 2001 C INTEGER N,MU1,MU2 INTEGER MU(6,4),SIGN(6) C C Mu is Mu(N,J) with N = 1,...,6 labelling the permutations that C define the contributions to epsilon that have 0 for the third C index and J = 1,...,4 labelling the four indices of epsilon. C DATA MU /1,1,2,2,3,3, > 2,3,1,3,1,2, > 0,0,0,0,0,0, > 3,2,3,1,2,1/ C C Sign(N) is minus the signature of the permutation. C DATA SIGN /-1,1,1,-1,-1,1/ C C Our result would have a factor METRIC(MU1)*METRIC(MU2), C but this factor is always +1. C DO MU1 = 0,3 DO MU2 = 0,3 OUT(MU1,MU2) = (0.0D0,0.0D0) ENDDO ENDDO DO N = 1,6 MU1 = MU(N,1) MU2 = MU(N,2) OUT(MU1,MU2) = OUT(MU1,MU2) + SIGN(N)*V4(MU(N,4)) ENDDO RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE EPSILONT2(T12,V3,V4,OUT) C In: COMPLEX*16 T12(0:3,0:3),V3(0:3),V4(0:3) C Out: COMPLEX*16 OUT C C Computes the contraction of the epsilon tensor with a second rank C tensor and two four-vectors, giving a scalar result, OUT. C The tensor and the four vectors have upper indices. C The epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1. C C 4 August 2001 C INTEGER N INTEGER MU(24,4),SIGN(24) C C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that C define the contributions to epsilon and J = 1,...,4 labelling C the four indices of epsilon. C DATA MU /0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, > 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, > 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, > 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/ C C Sign(N) is minus the signature of the permutation. C DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, > -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/ C OUT = (0.0D0,0.0D0) DO N = 1,24 OUT = OUT > + SIGN(N)*T12(MU(N,1),MU(N,2))*V3(MU(N,3))*V4(MU(N,4)) ENDDO RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE EPSILONT1(T23,V4,OUT) C In: COMPLEX*16 T23(0:3,0:3),V4(0:3) C Out: COMPLEX*16 OUT(0:3) C C Computes the contraction of the epsilon tensor with a second C rank tensor and a four-vector, giving a vector result, OUT(mu1). C The tensor and the vector have upper indices. The epsilon tensor has C lower indices, so epsilon(0,1,2,3) = -1, and in addition we need C a metric tensor to raise the index of OUT. We calculate C C Out(mu1) = epsilon(mu1,mu2,mu3,mu4) t23(mu2,mu3) v4(mu4) C C 4 August 2001 C INTEGER N,NU INTEGER MU(24,4),SIGN(24) C C Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that C define the contributions to epsilon and J = 1,...,4 labelling C the four indices of epsilon. C DATA MU /0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, > 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, > 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, > 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/ C C Sign(N) is minus the signature of the permutation. C DATA SIGN /-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, > -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/ C REAL*8 METRIC(0:3) DATA METRIC /+1.0D0,-1.0D0,-1.0D0,-1.0D0/ C DO NU = 0,3 OUT(NU) = (0.0D0,0.0D0) ENDDO DO N = 1,24 NU = MU(N,1) OUT(NU) = OUT(NU) > + METRIC(NU)*SIGN(N)*T23(MU(N,2),MU(N,3))*V4(MU(N,4)) ENDDO RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE DIAGNOSTIC(K,BADGRAPHNUMBER) INTEGER SIZE,MAXMAPS PARAMETER (SIZE = 3) PARAMETER (MAXMAPS = 64) C In: REAL*8 K(0:3*SIZE-1,0:3) INTEGER BADGRAPHNUMBER C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT INTEGER NPROPS,NVERTS INTEGER ORDER INTEGER NLOOPS1,NPROPS1,NVERTS1,CUTMAX1 INTEGER NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 COMMON /SIZES/ NLOOPS1,NPROPS1,NVERTS1,CUTMAX1, > NLOOPS2,NPROPS2,NVERTS2,CUTMAX2 C C NEWGRAPH variables: INTEGER VRTX(0:3*SIZE-1,2),PROP(2*SIZE,3) LOGICAL GRAPHFOUND INTEGER GRAPHNUMBER C MAP variables: INTEGER NMAPS,QS(MAXMAPS,0:SIZE),QSIGNS(MAXMAPS,0:SIZE) CHARACTER*6 MAPTYPES(MAXMAPS) C Calculate variables: LOGICAL REPORT,DETAILS COMMON /CALCULOOK/ REPORT,DETAILS COMPLEX*16 VALUE COMPLEX*16 VALUECHK REAL*8 MAXPART C REAL*8 ABSK(0:3*SIZE-1) INTEGER P,MU,V REAL*8 COS12,COS23,COS31,SIN12,SIN23,SIN31 REAL*8 BADNESS C C This finds data for the kind of graph with the worst value C Latest revision: 4 January 1999 C Variable ORDER added 8 February 2002. C ------- C ORDER = 2 IF (BADGRAPHNUMBER.GT.10) THEN ORDER = 1 ENDIF IF (ORDER.EQ.1) THEN NPROPS = NPROPS1 NVERTS = NVERTS1 ELSE IF (ORDER.EQ.2) THEN NPROPS = NPROPS2 NVERTS = NVERTS2 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER ENDIF C C First we have to run NEWGRAPH through all the graphs so that it C initializes itself. C GRAPHFOUND = .TRUE. DO WHILE (GRAPHFOUND) CALL NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND) ENDDO C C Now we find the graph we wanted. C GRAPHFOUND = .TRUE. IF (ORDER.EQ.2) THEN GRAPHNUMBER = 0 ELSE IF (ORDER.EQ.1) THEN GRAPHNUMBER = 10 ELSE WRITE(NOUT,*)'ORDER must be 1 or 2',ORDER STOP ENDIF DO WHILE (GRAPHFOUND) CALL NEWGRAPH(ORDER,VRTX,PROP,GRAPHFOUND) IF (GRAPHFOUND) THEN GRAPHNUMBER = GRAPHNUMBER + 1 ENDIF IF (GRAPHFOUND.EQV..FALSE.) THEN WRITE(NOUT,*)'Oops, snafu in DIAGNOSTIC' STOP ENDIF IF (GRAPHNUMBER.EQ.BADGRAPHNUMBER) THEN GRAPHFOUND = .FALSE. ENDIF ENDDO C C Calculate information associated with the maps. C CALL FINDTYPES(VRTX,PROP,ORDER,NMAPS,QS,QSIGNS,MAPTYPES) C WRITE(NOUT,*)' ' WRITE(NOUT,*)'Analysis by subroutine DIAGNOSTIC' WRITE(NOUT,*)' ' WRITE(NOUT,702)GRAPHNUMBER 702 FORMAT('Graph number ',I3) WRITE(NOUT,*)'Point:' DO P=1,NPROPS WRITE(NOUT,703) P,K(P,1),K(P,2),K(P,3) 703 FORMAT('P =',I2,' K = ',3(1P G12.3)) ENDDO C WRITE(NOUT,*)' ' WRITE(NOUT,*)'Softness:' DO P = 1,NPROPS ABSK(P) = 0.0D0 DO MU = 1,3 ABSK(P) = ABSK(P) + K(P,MU)**2 ENDDO ABSK(P) = SQRT(ABSK(P)) WRITE(NOUT,704) P,ABSK(P) 704 FORMAT('P =',I2,' |K| = ',1P G12.3) ENDDO C WRITE(NOUT,*)' ' WRITE(NOUT,*)'Collinearity:' DO V = 3,NVERTS COS12 = 0.0D0 COS23 = 0.0D0 COS31 = 0.0D0 DO MU = 1,3 COS12 = COS12 + K(PROP(V,1),MU) * K(PROP(V,2),MU) COS23 = COS23 + K(PROP(V,2),MU) * K(PROP(V,3),MU) COS31 = COS31 + K(PROP(V,3),MU) * K(PROP(V,1),MU) ENDDO COS12 = COS12 /ABSK(PROP(V,1))/ABSK(PROP(V,2)) COS23 = COS23 /ABSK(PROP(V,2))/ABSK(PROP(V,3)) COS31 = COS31 /ABSK(PROP(V,3))/ABSK(PROP(V,1)) SIN12 = SQRT(1.0D0 - COS12**2) SIN23 = SQRT(1.0D0 - COS23**2) SIN31 = SQRT(1.0D0 - COS31**2) WRITE(NOUT,705)V,PROP(V,1),PROP(V,2),PROP(V,3), > SIN12,SIN23,SIN31 705 FORMAT('V =',I2,' Ps =',3I2,' sines =', 3F10.5) ENDDO C WRITE(NOUT,*)' ' CALL CHECKPOINT(K,ABSK,PROP,ORDER,BADNESS) WRITE(NOUT,706)BADNESS 706 FORMAT('Badness of this point is',1P G10.2) C WRITE(NOUT,*)' ' WRITE(NOUT,*)'CALCULATE finds the folowing:' REPORT = .TRUE. C CALL CALCULATE(VRTX,GRAPHNUMBER,ORDER,K,ABSK, > QS,QSIGNS,MAPTYPES,NMAPS,VALUE,MAXPART,VALUECHK) C WRITE(NOUT,707)VALUE, ABS(VALUE),MAXPART 707 FORMAT('VALUE =',2(1P G12.4),' ABS(VALUE) = ',1P G12.4,/, > 'BIGGEST contribution was ',1P G12.4) RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C C C Miscellaneous Functions C C C C23456789012345678901234567890123456789012345678901234567890123456789012 C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION ALPI(MUMSBAR) REAL*8 MUMSBAR C C Alpha_s/pi as a function of the MSbar scale. See C D.~E.~Soper and L.~R.~Surguladze, C %``On the QCD perturbative expansion for e~+ e~- $\to$ hadrons,'' C Phys.\ Rev.\ D {\bf 54}, 4566 (1996) C [arXiv:hep-ph/9511258]. C 21 February 2002 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 NC,NF COMMON /COLORFACTORS/ NC,NF REAL*8 ALPHASOFMZ,MZ,EXTERNALRTS COMMON /PHYSICSDATA/ ALPHASOFMZ,MZ,EXTERNALRTS REAL*8 B0,B1,B2 REAL*8 T,X,ALPI0,ALPIINV,TEMP,ONEPX,LN1PX REAL*8 PI DATA PI /3.1415926535898D0/ C C The beta function coefficients. C B0 = (33.0D0 - 2.0D0*NF)/12.0D0 B1 = (306.0D0 - 38.0D0*NF)/48.0D0 B2 = (77139.0D0 - 15099.0D0*NF + 325.0D0*NF**2)/3456.0D0 C ALPI0 = ALPHASOFMZ/PI T = 2.0D0*LOG(MUMSBAR/MZ) X = B0*T*ALPI0 ONEPX = 1.0D0 + X IF(ONEPX.LT.0.01D0)THEN WRITE(NOUT,*)'MUMSBAR too small in ALPI. ',MUMSBAR STOP ENDIF LN1PX = LOG(ONEPX) ALPIINV = ONEPX/ALPI0 ALPIINV = ALPIINV + LN1PX*B1/B0 TEMP = (B0*B2 - B1**2)/B0**2 * X/ONEPX TEMP = TEMP + B1**2/B0**2 * LN1PX/ONEPX TEMP = ALPI0 * TEMP ALPIINV = ALPIINV + TEMP ALPI = 1.0D0/ALPIINV RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION XXREAL(Z) C COMPLEX*16 Z C XXREAL = DBLE(Z) RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION XXIMAG(Z) C COMPLEX*16 Z C COMPLEX*16 ZZ C ZZ = (0.0D0,-1.0D0) * Z XXIMAG = DBLE(ZZ) RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C COMPLEX*16 FUNCTION COMPLEXSQRT(Z) COMPLEX*16 Z C C Square root for complex numbers with error checking. C 1 February 1998 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT REAL*8 XXREAL,XXIMAG C IF (XXREAL(Z).LT.0.0D0) THEN IF(ABS(XXIMAG(Z)).LT. (1.0D-1 * ABS(XXREAL(Z))) ) THEN WRITE(NOUT,*)'Too near cut of Sqrt(Z) in COMPLEXSQRT(Z)' WRITE(NOUT,*) Z STOP ENDIF ENDIF COMPLEXSQRT = SQRT(Z) RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION FACTORIAL(N) C INTEGER N C INTEGER J C FACTORIAL = 1.0D0 DO J = 1,N FACTORIAL = FACTORIAL * J ENDDO RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION SINHINV(Z) C REAL*8 Z REAL*8 Z2,Z3,Z5,Z7 C C Evaluate arcsinh(z) = log( z + Sqrt(1+z^2) ). C For small z, we use the first four terms in the power C series expansion of this function so that we do not C lose precision in evaluating log(1 + z + z^2/2 + ...). C At z = 0.03, the series evaluation is accurate to a C fractional error of 2E-14. At this same point, the C precision of the Log form of the function should be C about that for representing 1.03 - 1.00, or 14 digits C minus 1.5 digits, or 3E-12. C IF (Z.LT.3.0D-2) THEN Z2 = Z**2 Z3 = Z * Z2 Z5 = Z3 * Z2 Z7 = Z5 * Z2 SINHINV = Z - 1.66666666667D-1 * Z3 > + 7.5D-2 * Z5 - 4.46428571429D-2 * Z7 ELSE SINHINV = LOG(Z + SQRT(1.0D0 + Z**2)) ENDIF RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION EXPM1(X) REAL*8 X C C Returns exp(x) -1. C 15 December 1999 C REAL*8 INV2,INV3,INV4,INV5,INV6,INV7,INV8 PARAMETER(INV2 = 0.5D0) PARAMETER(INV3 = 0.333333333333333333D0) PARAMETER(INV4 = 0.25D0) PARAMETER(INV5 = 0.2D0) PARAMETER(INV6 = 0.166666666666666667D0) PARAMETER(INV7 = 0.142857142857142857D0) PARAMETER(INV8 = 0.125D0) C IF (ABS(X) .GT. 0.1D0) THEN EXPM1 = EXP(X) - 1.0D0 ELSE EXPM1 = 1.0D0 + INV8*X EXPM1 = 1.0D0 + INV7*X*EXPM1 EXPM1 = 1.0D0 + INV6*X*EXPM1 EXPM1 = 1.0D0 + INV5*X*EXPM1 EXPM1 = 1.0D0 + INV4*X*EXPM1 EXPM1 = 1.0D0 + INV3*X*EXPM1 EXPM1 = 1.0D0 + INV2*X*EXPM1 EXPM1 = X*EXPM1 ENDIF RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION SQRTM1(X) REAL*8 X C C Returns sqrt(1+x) -1. C The coefficients are 1/2,1/4,3/6,5/8,7/10,9/12,11/14,13/16,15/18. C 15 December 1999 C REAL*8 C1,C2,C3,C4,C5,C6,C7,C8,C9 PARAMETER(C1 = 0.5D0 ) PARAMETER(C2 = 0.25D0 ) PARAMETER(C3 = 0.5D0 ) PARAMETER(C4 = 0.625D0 ) PARAMETER(C5 = 0.7D0 ) PARAMETER(C6 = 0.75D0 ) PARAMETER(C7 = 0.785714285714285714D0 ) PARAMETER(C8 = 0.8125D0 ) PARAMETER(C9 = 0.833333333333333333D0 ) C IF (ABS(X) .GT. 0.03D0) THEN SQRTM1 = SQRT(1 + X) - 1.0D0 ELSE SQRTM1 = 1.0D0 - C9*X SQRTM1 = 1.0D0 - C8*X*SQRTM1 SQRTM1 = 1.0D0 - C7*X*SQRTM1 SQRTM1 = 1.0D0 - C6*X*SQRTM1 SQRTM1 = 1.0D0 - C5*X*SQRTM1 SQRTM1 = 1.0D0 - C4*X*SQRTM1 SQRTM1 = 1.0D0 - C3*X*SQRTM1 SQRTM1 = 1.0D0 - C2*X*SQRTM1 SQRTM1 = C1*X*SQRTM1 ENDIF RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION LOGSQINT(Y) REAL*8 Y C C The integral from 0 to Y of Log^2(y'). C 20 February 2001 C REAL*8 L C L = LOG(Y) LOGSQINT = Y * (L**2 - 2.0D0*L + 2.0D0) RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C REAL*8 FUNCTION INVLOGSQINT(W) REAL*8 W C C Y = INVLOGSQINT(W) iff W = LOGSQINT(Y) where C LOGSQINT(Y) is the integral from 0 to Y of Log^2(y'), C namely LOGSQINT(Y) = Y * (Log(Y)**2 - 2.0D0*Log(Y) + 2.0D0). C 20 February 2001 C INTEGER NIN,NOUT COMMON /IOUNIT/ NIN,NOUT C REAL*8 U,Z,ZSQ,TEMP,UCALC,DELTAU LOGICAL MORENEEDED INTEGER N C C We use variables Z = Log(Y) and U = Log(W). Thus we want to solve C U = Z + Log( Z** - 2*Z + 2 ). We iteratively use C Z_(n+1) = Z_n + (U - U_n)/ (dU/dZ) where C dU/dZ = Z**2/( Z** - 2*Z + 2 ). C U = LOG(W) Z = 1.2D0*U - 2.0D0 MORENEEDED = .TRUE. N = 0 DO WHILE (MORENEEDED) N = N + 1 ZSQ = Z**2 TEMP = ZSQ - 2.0D0*Z + 2.0D0 UCALC = Z + LOG(TEMP) DELTAU = U - UCALC Z = Z + DELTAU*TEMP/ZSQ IF (ABS(DELTAU).LT.1.0D-8) THEN MORENEEDED = .FALSE. ENDIF IF (N.GT.10) THEN WRITE(NOUT,*)'Failed convergence in INVLOGSQINT' STOP ENDIF ENDDO INVLOGSQINT = EXP(Z) RETURN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C Random Number Generator C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE RANDOMINIT(IRAN) INTEGER IRAN C C Code from CERN, 1991. C Modified to replace .AND. by IAND() and .OR. by IOR(). C C Initialize the shift-register random number generator from a random C seed IRAN, 0 <= IRAN < 259200, with the help of a portable "quick C and dirty" generator. C INTEGER LBIT REAL*8 FAC PARAMETER(LBIT=31,FAC= 2.0D0**(-LBIT)) C Here LBIT is the number of bits used in the shift register generator INTEGER J,IR(250) REAL*8 RR(250) COMMON/RANDO/ RR,J,IR SAVE /RANDO/ INTEGER I,LB,JRAN,IFAC1,ISK,IDI,I1S C Configuration of the shift register generator INTEGER IM,IA,IC DATA IM,IA,IC /259200,7141,54773/ C C IF(IRAN.LT.0.OR.IRAN.GE.IM)STOP > 'RINI: IRAN OUT OF RANGE' JRAN=IRAN C Warm up the auxiliary generator a little DO I=1,10 JRAN=MOD(JRAN*IA+IC,IM) ENDDO IFAC1=((2**(LBIT-1)-1)*2+1)/IM DO I=2,250 JRAN=MOD(JRAN*IA+IC,IM) IR(I)=IFAC1*JRAN ENDDO C Guarantee LBIT linearly independent (over the field of 2 el.) C elements in IR(I): IR(1)=1 I=1 ISK=250/LBIT IDI=1 I1S=1 DO LB=1,LBIT-1 I=I+ISK IDI=IDI*2 I1S=I1S+IDI IR(I)=IOR(IR(I),IDI) IR(I)=IAND(IR(I),I1S) ENDDO CALL NEWRAN END C C23456789012345678901234567890123456789012345678901234567890123456789012 C SUBROUTINE NEWRAN C C Code from CERN, 1991. C Modified to replace .XOR. by IEOR(). C C Fills IR(I),RR(I) with 250 new random numbers, resets J=0. C Increment J before use! C INTEGER LBIT REAL*8 FAC PARAMETER(LBIT=31,FAC= 2.0D0**(-LBIT)) INTEGER J,IR(250) REAL*8 RR(250) COMMON/RANDO/ RR,J,IR SAVE /RANDO/ C INTEGER N C DO N=1,103 IR(N)=IEOR(IR(N+147),IR(N)) RR(N)=FAC*(DBLE(IR(N)) + 0.5D0) ENDDO C DO N=104,250 IR(N)=IEOR(IR(N-103),IR(N)) RR(N)=FAC*(DBLE(IR(N)) + 0.5D0) ENDDO C J=0 END C C23456789012345678901234567890123456789012345678901234567890123456789012C REAL*8 FUNCTION RANDOM(DUMMY) INTEGER DUMMY C C Code from CERN, 1991. C C Random number between 2**(-32) and 1 - 2**(-32): C INTEGER J,IR(250) REAL*8 RR(250) COMMON/RANDO/ RR,J,IR SAVE /RANDO/ C IF(J.GE.250)CALL NEWRAN J=J+1 RANDOM = RR(J) END C C23456789012345678901234567890123456789012345678901234567890123456789012 C END OF LIBRARY ROUTINES FOR E+E- CALCULATION C23456789012345678901234567890123456789012345678901234567890123456789012