!2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! ---------------------------- ! beowulfsubs.f Version 4.0 ! ---------------------------- ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine version ! use beowulf_parameters implicit none write(nout,*)'beowulf 4.0 subroutines 4 September 2005' write(nout,*)'These subroutines are unchanged from' write(nout,*)'beowulf 3.3 subroutines 23 December 2004' write(nout,*)'Coulomb gauge and Feynman gauge plus showers' RETURN END subroutine version ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Subroutines for numerical integration of jet cross sections in ! electron-positron annihilation. -- D. E. Soper ! ! First code: 29 November 1992. ! Latest revision: see Version subroutine above. ! ! The main program and subroutines that a user might want to modify ! are contained in the companion package, beowulf.f. In particular, a ! user may very well want to modify parameter settings in the main ! program and to change the observables calculated in the subroutine ! HROTHGAR and in the functions CALStype(nparticles,kf,index). Subroutines ! that can be modified only at extreme peril to the reliability of ! the results are in this package, beowulfsubs.f. ! ! There are two parallel calculations. Program beowulf calculates a ! sample integral, which by default is the average value of ! (1 - thrust)^2. These are summed in the variable INTEGRAL and ! reported upon completion of the program. The program also computes ! a simple check integral in order to check on the jacobians etc. ! In the meantime, for each point in loop space and each final ! state cut, the program reports the corresponding point in the space ! of final state momenta along with the corresponding weight (Feynman ! diagram times jacobian factors) to the subroutine HROTHGAR, which ! multiplies by the measurement functions CALS corresponding to the ! measurements desired and accumulates the results. ! ! There are four function subroutines representing the Feynman graphs ! that are generated by Mathematica routines. These are ! ! function feynman(graphnumber,flavorsetnumber,kc,cut,mumsbar,flag) ! function feynman0(graphnumber,flavorsetnumber,kin,cut) ! function feynmanSH0(graphnumber,flavorsetnumber,kin,cut, & ! vquark,vqbar,tglue) ! function softsubtraction(k,absk, & ! graphnumber,flavorsetnumber,cutnumber) ! ! In order to control roundoff errors, a point in loop space is rejected ! if the point is too near a singularity or if there is too much ! cancellation in the contribution from that point to INTEGRAL. ! ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! PROGRAM STRUCTURE !main program beowulf ! graphcountinit ! getcounts and getcountsf ! hrothgar... (interface) ! randominit ! daytime ! version ! reno... (main calculation) ! diagnostic ! !subroutine reno ! timing ! hrothgar ! getnewgraph ! findtypes (maptypes for chosing points) ! getnewcut ! finda (matrix to get propagator momenta from loop momenta) ! newpoint ! checkpoint ! calculate... (calculate at chosen point) ! !subroutine calculate ! function density ! getnewcut ! deform ! finda (matrix propagator energies from final state energies) ! checkcalc (the known integral) ! hrothgar ! functions feynmanf, feynman, feynman0f, feynman0 ! ! Common blocks (used for data that does not change): ! ! Set in main program beowulf: ! common /sizes/ nloops1,nprops1,nverts1,cutmax1, & ! nloops2,nprops2,nverts2,cutmax2 ! common /limits/ badnesslimit,cancellimit,thrustcut ! common /maxtime/ timelimit ! common /programmode/ mode ! common /whichgraphs/ usegraph ! common /montecarlo/groupsize,groupsizegraph,groupsizetotal ! common /calculook/ report,details ! common /colorfactors/ nc,nf,cf ! common /gaugechoice/ gauge ! common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! common /deformscales/deformalpha,deformbeta,deformgamma ! common /smearparms/ smearfctr,lowpwr,highpwr ! common /renormalize/ muoverrts ! ! Set in graphcountinit (called from main program beowulf): ! common /graphcounts/ numberofgraphs,numberofcuts,numberofmaps ! ! Here is a listing of the subroutines and functions included. ! ! Subroutines and functions in beowulf file: ! module beowulf_parameters ! program beowulf ! subroutine hrothgar ! function calsthrust ! function calstmoments ! function thrust ! function thrustdist ! function kn0 ! function kn ! function calsymoments ! subroutine combinejets ! function cals0 ! subroutine daytime ! subroutine timing ! subroutine getcounts ! subroutine getcountsf ! ! Subroutines and functions in beowulfsubs file: ! subroutine version ! subroutine reno ! subroutine getnewgraph ! subroutine getnewflavorset ! subroutine finda ! function propsign ! subroutine findtypes ! subroutine newpoint ! subroutine checkpoint ! subroutine axes ! subroutine calculate ! subroutine checkcalc ! function density ! subroutine choose3 ! function rho3 ! subroutine choose2to2s ! function rho2to2s ! subroutine choose2to2t ! function rho2to2t ! subroutine choose2to3d ! function rho2to3d ! subroutine choose2to3e ! function rho2to3e ! subroutine choose2to1 ! function rho2to1 ! subroutine graphcountinit ! subroutine getnewcut ! subroutine deform ! function delta ! function smear ! function feynmanf ! function feynman0f ! subroutine twopointgf ! subroutine twopointqf ! subroutine vertexf ! subroutine twopt2f ! function feynman ! function feynman0 ! subroutine twopointg ! subroutine twopointq ! subroutine vertex ! subroutine twopt2 ! subroutine epsilon4 ! subroutine epsilon3 ! subroutine epsilon2 ! subroutine epsilon2n ! subroutine epsilon1n ! subroutine epsilont2 ! subroutine epsilont1 ! subroutine diagnostic ! function alpi ! function xxreal ! function xximag ! function complexsqrt ! function factorial ! function sinhinv ! function expm1 ! function sqrtm1 ! function logsqint ! function invlogsqint ! subroutine randominit ! subroutine newran ! function random ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! A brief introduction to the variables used: ! ! Size of the calculation: ! NLOOPS = number of loops (in cut photon self energy graph). ! NPROPS = number of propagators in graph, = 3 * NLOOPS - 1. ! NVERTS = number of vertices in graph, = 2 * NLOOPS. ! CUTMAX = NLOOPS + 1 ! = maximum number of cut propagators; ! = number of independent loop momenta needed to determine the ! propagator momenta, counting the virtual photon momentum. ! The current program is restricted to 0 and 1 virtual loops. ! ! Labels: ! L = index of loop momenta, L = 0,1,...,NLOOPS. ! L = 0 normally denontes the virtual photon momentum. ! P = index of propagator, P = 0,1,...,NPROPS. ! P = 0 denotes the virtual photon momentum. ! Q(L) = index P of propagator carrying the Lth loop momentum. ! V = index of vertices, V = 1,...,NVERTS ! ! Momentum variables (MU = 0,1,2,3): ! K(P,MU) = Momentum of Pth propagator. ! For P = 0, this is the virtual photon momentum: ! K(0,MU) = 0 for MU = 1, 2, 3 while K(0,0) = RTS. ! ABSK(P) = Square of the three momentum of Pth propagator. ! KINLOOP(J,MU) = K(LOOPINDEX(J),MU) = momenta of loop propagators. ! KCUT(I,MU) = K(CUTINDEX(I),MU) = momenta of cut propagators. ! K(Q(L),MU) = Lth loop momentum, L = 0,...,NLOOPS; ! KC(P,MU) = complex propagator momenta. ! A(P,L) = Matrix relating propagator momenta to loop momenta. ! K(P,MU) = SUM_{L=0}^{NLOOPS} A(P,L) K(Q(L),MU) ! kf(i,mu) = momenta of final state particles, i = 1,nparticles ! equal to the kcut(i,mu) if no showering. ! ! Variables from NEWGRAPH: ! VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of ! of propagator P. Specifies the supergraph. ! PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3. ! Also specifies the supergraph. ! ! Variables associated with NEWPOINT and FINDTYPES: ! NMAPS = Number of different maps from random x's to momenta. ! MAPNMUMBER = Number labelling a certain map. ! QS(MAPNUMBER,II) = Label of the IIth propagator that is special ! in map number MAPNUMBER. ! QSIGNS(MAPNUMBER,II) = sign needed to relate the conventional ! direction of the propagator to that in an elementary scattering ! MAPTYPES(MAPNUMBER) = T2TO3, T2TO2T, T2TO2S, T2TO1. ! ! JACNEWPOINT =1/DENSITY(GRAPHNUMBER,K,QS,QSIGNS,MAPTYPES,NMAPS,ORDER) ! = Jacobian for loop momenta L. ! ! Variables from NEWCUT: ! NEWCUTINIT: .TRUE. tells NEWCUT to initialize itself. ! NCUT = Number of cut propagators. ! ISIGN(P) = +1 if propagator P is left of cut, -1 if right, 0 if cut. ! CUTINDEX(I) = Index P of cut propagator I, I = 1,...,CUTMAX. ! CUTSIGN(I) = Sign of cut propagator I I = 1,...,CUTMAX. ! (+1 if K(P,0) >0 for cut propagator.) ! LEFTLOOP = True iff there is a virtual loop to the left of the cut. ! RIGHTLOOP = True iff there is a virtual loop to the right of the cut. ! NINLOOP = Number of propagators in loop. ! LOOPINDEX(NP) = Index P of NPth propagator around the loop. ! LOOPSIGN(NP) = 1 if propagator direction is same as loop direction. ! -1 if direction is opposite to loop direction. ! NP = JCUT: Propagator cut by loopcut. ! CUTFOUND: .TRUE. if NEWCUT found a new cut. ! ! In RENO we use CUTINDEX to define CUT(P) = True if propagator ! P is cut. ! ! Solving for the propagator energies: ! For NCUT = CUTMAX, cut propagators are P = CUTINDEX(I). ! with direction of positive energy given by CUTSIGN(I). ! For NCUT = CUTMAX - 1, we define a "loopcut" on the propagator ! numbered JCUT in order around the loop, 1.LE.JCUT.LE.NINLOOP: ! CUTINDEX(CUTMAX) = LOOPINDEX(JCUT) and ! CUTSIGN(CUTMAX) = LOOPSIGN(JCUT). ! Energies of cut propagators are ! E(I-1) = K(CUTINDEX(I),0) for I = 1,...,CUTMAX. ! and are determined from ! E(I-1) = CUTSIGN(I) * SQRT( Sum_J [ K(CUTINDEX(I),J)**2 ] ). ! This gives energies E(L) for L = 0,...,NLOOPS. We consider the ! propagators designated by QE(L) = CUTINDEX(L+1) as independent ! and generate the matrix AE(P,L) that gives the propagator energies ! in terms of these independent momenta. This gives the propagator ! energies. ! ! Contour deformation: ! NEWKINLOOP(MU) = addition to the momentum going around the loop ! caused by deforming the contour. We have ! Im[ KC(LOOPINDEX(J,MU)) ] = LOOPSIGN(LOOPINDEX(J)) ! * Im[ NEWKINLOOP(J,MU) ] for MU = 1,2,3. ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine renoinit(sums) use beowulf_parameters use beowulf_structures implicit none ! Out: type(renoresults) :: sums ! integer :: i ! sums%i = 0.0d0 sums%r = 0.0d0 sums%bis = 0.0d0 sums%chkr = 0.0d0 sums%chki = 0.0d0 sums%rsq = 0.0d0 sums%isq = 0.0d0 sums%bissq = 0.0d0 sums%chkrsq = 0.0d0 sums%chkisq = 0.0d0 sums%included = 0 sums%extracount = 0 sums%omitted = 0.0d0 sums%nvalpt = (/(0,i = -9,6)/) sums%valptmax = 0.0d0 sums%fluct = reshape((/(0,i=1,maxgraphs*maxmaps)/),(/maxgraphs,maxmaps/)) ! sums%badpointinfo does not need to be initialized ! end subroutine renoinit ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine reno(sums) ! use beowulf_parameters use beowulf_structures implicit none ! In and Out: type(renoresults) :: sums ! ! When called many times, computes the cross section integral ! by Monte Carlo integration. ! ! Latest revision 16 November 2003 ! integer :: nloops,nprops integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 real(kind=dbl) :: badnesslimit,cancellimit,thrustcut common /limits/ badnesslimit,cancellimit,thrustcut real(kind=dbl) :: timelimit common /maxtime/ timelimit ! What the program should do character(len=8) :: mode common /programmode/ mode ! Graphs to include logical :: usegraph(maxgraphs) common /whichgraphs/ usegraph ! How many graphs and how many maps for each: integer :: numberofgraphs integer :: numberofmaps(maxgraphs) common /graphcounts/ numberofgraphs,numberofmaps ! Order of perturbation theory integer :: order ! Momenta: real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1) ! Matrices: integer :: a(0:3*size-1,0:size) ! A blank shower for hrothgar: type(showerlist) :: blankshower ! NEWGRAPH variables: type(graphstructure) :: graph logical :: graphfound integer :: graphnumber ! FINDA variable: logical :: qok ! MAP variables: integer :: nmaps,mapnumber integer :: qs(maxmaps,0:size),qsigns(maxmaps,0:size) integer :: q(0:size),qsign(0:size) character(len=6) :: maptypes(maxmaps) character(len=6) :: maptype ! Variable from CHECKPOINT: real(kind=dbl) :: badness ! Problem report from NEWPOINT logical :: badnewpoint ! Logical variables to tell how to treat point: logical :: xtrapointq, badpointq ! Functions: real(kind=dbl) :: xxreal,xximag ! Index variables: integer :: l,p,mu ! Reno size and counting variables: integer :: groupsize(maxgraphs,maxmaps) integer :: groupsizegraph(maxgraphs) integer :: groupsizetotal common /montecarlo/groupsize,groupsizegraph,groupsizetotal integer :: point ! The standard integrals to be calculated complex(kind=dbl) :: integral,integralchk real(kind=dbl) :: integralbis ! Calculate variables: complex(kind=dbl) :: value,valuechk real(kind=dbl) :: maxpart real(kind=dbl) :: valpt,logvalpt ! This gives us access to the random number generator's internal workings. ! We do not change these numbers in subroutine reno! But we save the ! information needed to set the random number generator properly in ! subroutine diagnostic. integer :: jrandom,irandom(250) real(kind=dbl) :: rrandom(250) common/rando/ rrandom,jrandom,irandom real(kind=dbl) :: temp integer :: tempjr,tempir(250) real(kind=dbl) :: temprr(250) real(kind=dbl) :: random ! save ! Save everything ! !------------------------------ Begin ---------------------------------- ! ! Initialize integrals for this reno group. ! integral = (0.0d0,0.0d0) integralbis = 0.0d0 integralchk = (0.0d0,0.0d0) ! ! Call Hrothgar to tell him to that we are starting a new group. ! call hrothgar(blankshower,1.0d0,1,'startgroup') ! ! Get a new graph. The starting value for GRAPHNUMBER depends ! on the order we want. Graphs for ORDER = 2 are numbered 1,...,10 ! and those for ORDER = 1 are numbered 11,12. For MODE = nlo, ! we will do the ORDER = 2 graphs first, then continue with the ! first order graphs. Thus we wait for NEWGRAPH to return ! GRAPHFOUND = false, then reset it (see ELSE part of IF(GRAPHFOUND)). ! graphfound = .true. ! IF (mode.EQ.'born ') THEN order = 1 nloops = nloops1 nprops = nprops1 graphnumber = 10 ELSE IF (mode.EQ.'hocoef ') THEN order = 2 nloops = nloops2 nprops = nprops2 graphnumber = 0 ELSE IF (mode.EQ.'nlo ') THEN order = 2 nloops = nloops2 nprops = nprops2 graphnumber = 0 ELSE IF ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) THEN order = 2 nloops = nloops2 nprops = nprops2 graphnumber = 0 ELSE write(nout,*)'Not programmed for this mode. ',mode stop END IF ! DO call getnewgraph(order,graph,graphfound) IF (.NOT.graphfound) THEN IF (((mode.EQ.'nlo ').OR.(mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) & .AND.(order.EQ.2)) THEN ! We have finished with the order 2 graphs and should do order 1. graphfound = .true. order = 1 nloops = nloops1 nprops = nprops1 call getnewgraph(order,graph,graphfound) IF (.NOT.graphfound) THEN write(nout,*)'What, graph 11 disappeared?' STOP END IF ELSE EXIT ! We have finished with all of the graphs. END IF END IF ! We have a graph to work with. graphnumber = graphnumber + 1 IF (.NOT.(graphnumber.EQ.graph%graphnumber)) THEN write(nout,*)'Oops, we lost track of graphnumber.' STOP END IF ! ! Check if we were supposed to use this graph (USEGRAPH is ! set in the main program.) ! IF (usegraph(graphnumber)) THEN ! ! Calculate number of maps NMAPS, index arrays QS, ! types MAPTYPES, and signs QSIGNS associated with the maps. ! call findtypes(graph,nmaps,qs,qsigns,maptypes) ! ! Loop over choices of maps from x's to loop momenta. ! DO mapnumber = 1,nmaps ! maptype = maptypes(mapnumber) DO l = 0,nloops q(l) = qs(mapnumber,l) qsign(l) = qsigns(mapnumber,l) END DO ! call finda(graph%vrtx,q,nloops,order,a,qok) ! ! Loop over Reno points within a group. ! DO point = 1,groupsize(graphnumber,mapnumber) ! ! Call Hrothgar to tell him that we are starting a new point. ! call hrothgar(blankshower,1.0d0,1,'startpoint') ! ! Get a new point. Check on its badness. If it is too bad, ! or if NEWPOINT reported a problem, we omit the point after ! notifying Hrothgar. ! badpointq = .false. xtrapointq = .false. call newpoint(a,qsign,maptype,order,k,absk,badnewpoint) IF (badnewpoint) THEN call hrothgar(blankshower,1.0d0,1,'badpoint ') badpointq = .true. END IF call checkpoint(k,absk,graph%prop,order,badness) IF (badness.GT.100*badnesslimit) THEN call hrothgar(blankshower,1.0d0,1,'badpoint ') badpointq = .true. ELSE IF (badness.GT.badnesslimit) THEN call hrothgar(blankshower,1.0d0,1,'xtrapoint ') xtrapointq = .true. END IF ! ! If the point is not too bad, we can call CALCULATE. ! The final state momenta found, along with the corresponding ! weights, are reported to Hrothgar by CACULATE. ! Then call Hrothgar to tell him that we are done with this point. ! IF (.NOT.badpointq) THEN temp = random(1) tempjr = jrandom ! This saves the state of the random temprr = rrandom ! number generator just before tempir = irandom ! calculate was called. call calculate(graph,k,absk, & qs,qsigns,maptypes,nmaps,value,maxpart,valuechk) END IF ! ! Add contribution from this point to integral. ! We count the point if Maxvalue/|Value| < Cancellimit. ! IF (.NOT.badpointq) THEN IF ( maxpart .GT. 100*cancellimit*abs(xxreal(value)) ) THEN call hrothgar(blankshower,1.0d0,1,'badpoint ') badpointq = .true. ELSE IF ( maxpart .GT. cancellimit*abs(xxreal(value)) ) THEN call hrothgar(blankshower,1.0d0,1,'xtrapoint ') xtrapointq = .true. END IF END IF ! IF ( (.NOT.badpointq).AND.(.NOT.xtrapointq) ) THEN integral = integral + value sums%fluct(graphnumber,mapnumber) = sums%fluct(graphnumber,mapnumber) & + xxreal(value)**2/groupsize(graphnumber,mapnumber) integralchk = integralchk + valuechk sums%included = sums%included + 1 ! ! For diagnostic purposes, we need VALPT, the contribution to ! the integral being calculated from this point, normalized such ! that the integral is the sum over all points chosen of VALPT ! divided by the total number of points, NRENO * GROUPSIZETOTAL. ! valpt = abs(xxreal(value))*groupsizetotal IF (valpt .GT. 0.0d0) then logvalpt = log10(valpt) ELSE logvalpt = -100.0d0 END IF DO l = -9,6 IF((logvalpt.GE.l).AND.(logvalpt.LT.(l+1))) THEN sums%nvalpt(l) = sums%nvalpt(l) + 1 END IF END DO IF (valpt.GT.sums%valptmax) THEN ! ! We save the information about the worst point for later analysis. ! sums%valptmax = valpt DO mu = 0,3 sums%badpointinfo%k(0,mu) = 0.0d0 END DO DO p = 1,nprops sums%badpointinfo%k(p,0) = 0.0d0 DO mu = 1,3 sums%badpointinfo%k(p,mu) = k(p,mu) END DO END DO sums%badpointinfo%graphnumber = graphnumber sums%badpointinfo%mapnumber = mapnumber sums%badpointinfo%jr = tempjr ! This saves the state of the random sums%badpointinfo%rr = temprr ! number generator just before calculate sums%badpointinfo%ir = tempir ! was called for the bad point. ! END IF ELSE IF ((.NOT.badpointq).AND.(xtrapointq) ) THEN ! ! For points that are 'extra', we include the value of ! the integrand in the INTEGRALBIS, which will provide an estimate ! or the effect of the cutoffs. ! integralbis = integralbis + xxreal(value) sums%extracount = sums%extracount + 1 ! ELSE sums%omitted = sums%omitted + 1 END IF ! ! End of loop over POINT. ! call hrothgar(blankshower,1.0d0,1,'pointdone ') END DO ! ! End of loop over MAPNUMBER. ! END DO ! ! End for IF (USEGRAPH(GRAPHNUMBER)) THEN ! END IF ! ! End of loop DO ... call getnewgraph() with EXIT if we ran out of graphs. ! END DO ! ! Call Hrothgar to tell him that we are done with this reno group. ! call hrothgar(blankshower,1.0d0,1,'groupdone ') ! ! Add results from this group to the SUM variables. ! sums%r = sums%r + xxreal(integral) sums%i = sums%i + xximag(integral) sums%bis = sums%bis + integralbis sums%chkr = sums%chkr + xxreal(integralchk) sums%chki = sums%chki + xximag(integralchk) ! sums%rsq = sums%rsq + xxreal(integral)**2 sums%isq = sums%isq + xximag(integral)**2 sums%bissq = sums%bissq + integralbis**2 sums%chkrsq = sums%chkrsq + xxreal(integralchk)**2 sums%chkisq = sums%chkisq + xximag(integralchk)**2 ! RETURN END subroutine reno ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! Subroutine GETNEWGRAPH !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine getnewgraph(orderwanted,graph,graphfound) ! use beowulf_parameters use beowulf_structures implicit none ! In: integer :: orderwanted ! Out: type(graphstructure) :: graph logical :: graphfound ! ! VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of ! of propagator P. Specifies the supergraph. ! PROP(V,I) = Index of Ith propagator attached to vertex V, I = 1,2,3. ! Also specifies the supergraph. ! Use ! C(V,I) = Index of Ith vertex connected to vertex V. ! V = 1,...,NVERTS; I =1,2,3; C(V,I) = 1,...,NVERTS and -1,-2. ! Here C(V,1).LE.C(V,2).LE.C(V,3). ! This is the fundamental specification of the supergraph. ! Vertex 1 is automatically connected to the photon "-1":C(1,1) = -1. ! Vertex 2 is automatically connected to the photon "-2":C(2,1) = -2. ! Connections to the external boson: ! In C(V,I) we assign the first connection of vertex 1 to be vertex "-1" ! while the first connection of vertex 2 is vertex "-2." This numbering ! is convenient for working out C(V,I). In reporting the results, ! however, we label the external boson with propagator 0, so that ! PROP(1,1) = PROP(2,1) = 0. Then propagator 0 attaches to vertices ! 1 and 2: VERT(0,1) = 2, VERT(0,2) = 1. ! ! 13 June 2002 ! integer, dimension(2*size,3) :: c ! integer :: nprops,nverts integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 integer, save :: graphnumber = 0 integer :: vv,p,i,va,vb integer, dimension(2*size) :: nused ! ! Initializations. ! IF (orderwanted.EQ.2) THEN IF (graphnumber.GE.10) THEN graphfound = .false. graphnumber = 0 RETURN END IF nprops = nprops2 nverts = nverts2 ELSE IF (orderwanted.EQ.1) THEN IF (graphnumber.GE.12) THEN graphfound = .false. graphnumber = 0 RETURN ELSE IF (graphnumber.LT.10) THEN graphnumber = 10 ! Starting value for order = 1. END IF nprops = nprops1 nverts = nverts1 ELSE write(nout,*)'Order must be 1 or 2.',orderwanted END IF graphnumber = graphnumber + 1 ! ! We know which graph, and everything is OK, so we proceed. ! graphfound = .true. graph%graphnumber = graphnumber graph%order = orderwanted ! ! Data are from getnewgraph.nb ! IF (graphnumber.EQ.1) THEN c(1,:) = (/-1,2,3/) c(2,:) = (/-2,1,4/) c(3,:) = (/1,4,5/) c(4,:) = (/2,3,6/) c(5,:) = (/3,6,6/) c(6,:) = (/4,5,5/) ELSE IF (graphnumber.EQ.2) THEN c(1,:) = (/-1,2,3/) c(2,:) = (/-2,1,4/) c(3,:) = (/1,5,5/) c(4,:) = (/2,6,6/) c(5,:) = (/3,3,6/) c(6,:) = (/4,4,5/) ELSE IF (graphnumber.EQ.3) THEN c(1,:) = (/-1,2,3/) c(2,:) = (/-2,1,4/) c(3,:) = (/1,5,6/) c(4,:) = (/2,5,6/) c(5,:) = (/3,4,6/) c(6,:) = (/3,4,5/) ELSE IF (graphnumber.EQ.4) THEN c(1,:) = (/-1,3,4/) c(2,:) = (/-2,3,4/) c(3,:) = (/1,2,5/) c(4,:) = (/1,2,6/) c(5,:) = (/3,6,6/) c(6,:) = (/4,5,5/) ELSE IF (graphnumber.EQ.5) THEN c(1,:) = (/-1,3,4/) c(2,:) = (/-2,3,5/) c(3,:) = (/1,2,4/) c(4,:) = (/1,3,6/) c(5,:) = (/2,6,6/) c(6,:) = (/4,5,5/) ELSE IF (graphnumber.EQ.6) THEN c(1,:) = (/-1,3,4/) c(2,:) = (/-2,3,5/) c(3,:) = (/1,2,5/) c(4,:) = (/1,6,6/) c(5,:) = (/2,3,6/) c(6,:) = (/4,4,5/) ELSE IF (graphnumber.EQ.7) THEN c(1,:) = (/-1,3,4/) c(2,:) = (/-2,3,5/) c(3,:) = (/1,2,6/) c(4,:) = (/1,5,6/) c(5,:) = (/2,4,6/) c(6,:) = (/3,4,5/) ELSE IF (graphnumber.EQ.8) THEN c(1,:) = (/-1,3,4/) c(2,:) = (/-2,5,6/) c(3,:) = (/1,4,5/) c(4,:) = (/1,3,6/) c(5,:) = (/2,3,6/) c(6,:) = (/2,4,5/) ELSE IF (graphnumber.EQ.9) THEN c(1,:) = (/-1,3,4/) c(2,:) = (/-2,5,6/) c(3,:) = (/1,5,5/) c(4,:) = (/1,6,6/) c(5,:) = (/2,3,3/) c(6,:) = (/2,4,4/) ELSE IF (graphnumber.EQ.10) THEN c(1,:) = (/-1,3,4/) c(2,:) = (/-2,5,6/) c(3,:) = (/1,5,6/) c(4,:) = (/1,5,6/) c(5,:) = (/2,3,4/) c(6,:) = (/2,3,4/) ELSE IF (graphnumber.EQ.11) THEN c(1,:) = (/-1,2,3/) c(2,:) = (/-2,1,4/) c(3,:) = (/1,4,4/) c(4,:) = (/2,3,3/) ELSE IF (graphnumber.EQ.12) THEN c(1,:) = (/-1,3,4/) c(2,:) = (/-2,3,4/) c(3,:) = (/1,2,4/) c(4,:) = (/1,2,3/) END IF ! ! Exit. We translate the results for C(V,I) into VRTX(P,I), I = 1,2, ! and PROP(P,I), I = 1,2,3. Here NUSED(V) denotes how many propagators ! we have so far assigned connecting to vertex V. ! DO vv = 1,nverts nused(vv) = 0 END DO graph%vrtx(0,1) = 2 graph%vrtx(0,2) = 1 graph%prop(1,1) = 0 nused(1) = 1 graph%prop(2,1) = 0 nused(2) = 1 p = 1 DO vv = 1,nverts DO i = 1,3 IF (c(vv,i).GT.vv) THEN va = vv vb = c(vv,i) graph%vrtx(p,1) = va nused(va) = nused(va) + 1 graph%prop(va,nused(va)) = p graph%vrtx(p,2) = vb nused(vb) = nused(vb) + 1 graph%prop(vb,nused(vb)) = p p = p+1 END IF END DO END DO IF (p.NE.nprops+1) THEN write(nout,*)'Snafu in getnewgraph.',p-1,nprops write(nout,*)'Graphnumber',graph%graphnumber stop END IF DO vv = 1,nverts IF (nused(vv).NE.3) THEN write(nout,*)'Problem in getnewwgraph.',vv,nused(vv) write(nout,*)'Graphnumber',graph%graphnumber stop END IF END DO ! ! OK. We are ready to return. ! RETURN END subroutine getnewgraph ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine getnewflavorset(graphnumber,flavorset,flavorsetfound) ! use beowulf_parameters use beowulf_structures implicit none ! In: integer :: graphnumber ! Out: type (flavorstructure) :: flavorset logical :: flavorsetfound ! ! Latest revisions: ! 28 June 2002 ! 8 November 2003 ! 27 August 2004 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! Physics data: real(kind=dbl) :: alphasofmz,sinsqthetaw,mz,widthz,externalrts common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! integer, save :: flavorsetnumber = 0 ! character(len=6), parameter :: gluon = 'gluon' character(len=6), parameter :: quark = 'quark' character(len=6), parameter :: qbar = 'qbar ' character(len=6), parameter :: none = 'none ' ! real(kind=dbl), dimension(6), parameter :: & charge = (/0.666666666666667d0,-0.333333333333333d0, & -0.333333333333333d0,0.666666666666667d0, & -0.333333333333333d0,0.666666666666667d0/) real(kind=dbl), dimension(6), parameter :: & t3 = (/ 0.5d0,-0.5d0, & -0.5d0, 0.5d0, & -0.5d0, 0.5d0/) real(kind=dbl) :: s,cossqthetaw,denomz,kappaz,ve,ae real(kind=dbl) :: effchrgsqtot,a,v,q real(kind=dbl), dimension(6) :: effchrgsq ! logical, save :: initialize = .true. integer, save :: nflavors integer :: p,i,flavorindex real(kind=dbl) :: temp,r,random real(kind=dbl), dimension(6), save :: probabilitysum integer :: quarkflavor character(len=5) :: thetype ! flavorsetfound = .false. flavorsetnumber = flavorsetnumber + 1 ! IF (graphnumber.EQ.1) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,qbar,gluon,gluon,qbar,quark/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,qbar,gluon,gluon,gluon,gluon/) ELSE IF(flavorsetnumber.EQ.3) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,gluon,qbar,quark,gluon,qbar/) ELSE IF(flavorsetnumber.EQ.4) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,qbar,quark,gluon,gluon,qbar,quark/) ELSE IF(flavorsetnumber.EQ.5) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,qbar,quark,gluon,gluon,gluon,gluon/) ELSE IF(flavorsetnumber.EQ.6) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,qbar,gluon,quark,qbar,gluon,quark/) END IF ELSE IF(graphnumber.EQ.2) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,gluon,qbar,gluon,quark,qbar/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,qbar,gluon,quark,gluon,qbar,quark/) END IF ELSE IF(graphnumber.EQ.3) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,gluon,qbar,quark,gluon,quark/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,gluon,qbar,gluon,quark,gluon/) ELSE IF(flavorsetnumber.EQ.3) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,qbar,gluon,quark,qbar,gluon,qbar/) ELSE IF(flavorsetnumber.EQ.4) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,qbar,gluon,quark,gluon,qbar,gluon/) END IF ELSE IF(graphnumber.EQ.4) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,gluon,qbar,quark/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,gluon,gluon,gluon/) END IF ELSE IF(graphnumber.EQ.5) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,qbar,gluon,quark/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,quark,qbar,gluon,quark,gluon,qbar/) END IF ELSE IF(graphnumber.EQ.6) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,gluon,qbar,quark/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,quark,qbar,gluon,gluon,quark,qbar/) END IF ELSE IF(graphnumber.EQ.7) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,qbar,gluon,gluon/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,gluon,qbar,quark/) ELSE IF(flavorsetnumber.EQ.3) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,quark,qbar,gluon,quark,gluon,gluon/) ELSE IF(flavorsetnumber.EQ.4) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,quark,qbar,gluon,gluon,quark,qbar/) END IF ELSE IF(graphnumber.EQ.8) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,qbar,quark,gluon,gluon,quark/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,quark,gluon,gluon,qbar/) ELSE IF(flavorsetnumber.EQ.3) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,quark,qbar,gluon/) END IF ELSE IF(graphnumber.EQ.9) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,quark,gluon,qbar/) END IF ELSE IF(graphnumber.EQ.10) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,qbar,gluon,quark,qbar,gluon/) END IF ELSE IF(graphnumber.EQ.11) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,quark,gluon,qbar,none,none,none/) ELSE IF(flavorsetnumber.EQ.2) THEN flavorsetfound = .true. flavorset%type = & (/qbar,quark,qbar,gluon,quark,none,none,none/) END IF ELSE IF(graphnumber.EQ.12) THEN IF (flavorsetnumber.EQ.1) THEN flavorsetfound = .true. flavorset%type = & (/quark,qbar,qbar,quark,gluon,none,none,none/) END IF ELSE write(nout,*)'Bad graphnumber in getnewflavorset.' STOP END IF ! IF (flavorsetfound) THEN flavorset%setnumber = flavorsetnumber ELSE flavorsetnumber = 0 END IF ! IF (flavorsetfound) THEN ! ! Choose flavors for the quarks. ! IF (initialize) THEN initialize = .false. s = externalrts**2 cossqthetaw = 1.0d0 - sinsqthetaw denomz = (s - mz**2)**2 + mz**2 * widthz**2 kappaz = 1/4.0d0/sinsqthetaw/cossqthetaw ve = -0.5d0 + 2.0d0 * sinsqthetaw ae = -0.5d0 nflavors = nint(nf) effchrgsqtot = 0.0d0 DO i = 1,nflavors a = t3(i) v = t3(i) - 2.0d0*charge(i)*sinsqthetaw q = charge(i) effchrgsq(i) = & denomz*q**2 & + kappaz**2 * s**2 * (ve**2 + ae**2)*(v**2 + a**2) & - 2.0d0*kappaz*s*(s-mz**2)*ve*q*v effchrgsqtot = effchrgsqtot + effchrgsq(i) END DO temp = 0.0d0 DO i = 1,nflavors temp = temp + effchrgsq(i)/effchrgsqtot probabilitysum(i) = temp ! we save this END DO END IF ! r = random(1) quarkflavor = 1 DO i = 1,nflavors - 1 IF (r.GT.probabilitysum(i)) THEN quarkflavor = quarkflavor + 1 END IF END DO DO p = 1,8 thetype = flavorset%type(p) IF (thetype.EQ.gluon) THEN flavorset%flavor(p) = 0 ELSE IF (thetype.EQ.quark) THEN flavorset%flavor(p) = quarkflavor ELSE IF (thetype.EQ.qbar) THEN flavorset%flavor(p) = - quarkflavor ELSE IF (thetype.EQ.none) THEN flavorset%flavor(p) = - 777 ! For p = 6,7,8 for Born graphs. ELSE write(nout,*)'Problem with parton type in getnewflavorset. ',thetype STOP END IF END DO ! ! For graphs 1 and 4, we have a separate quark loop comprising propagators ! 7 and 8, for which the flavor should be chosen at random. ! IF ((graphnumber.EQ.1).OR.(graphnumber.EQ.4)) THEN r = random(1) flavorindex = ceiling(random(1)*nf) ! choose the flavor at random DO p = 7,8 thetype = flavorset%type(p) IF (thetype.EQ.gluon) THEN flavorset%flavor(p) = 0 ELSE IF (thetype.EQ.quark) THEN flavorset%flavor(p) = flavorindex ELSE IF (thetype.EQ.qbar) THEN flavorset%flavor(p) = - flavorindex ELSE write(nout,*)'Problem with parton type in getnewflavorset. ',thetype STOP END IF END DO END IF END IF ! (flavorsetfound) ! RETURN END subroutine getnewflavorset ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 subroutine getcolors(graphnumber,flavorsetnumber,cutnumber,strings) use beowulf_parameters implicit none ! In: integer :: graphnumber,flavorsetnumber,cutnumber ! Out: integer, dimension(8) :: strings ! ! For a given graphnumber,flavorsetnumber,cutnumber with the cut such that there ! are four particles in the final state, finds a color structure for the final ! state. The output is an eight component array of integers, strings, with ! index of string connected to quark index of parton 1 = strings(1) ! index of string connected to qbar index of parton 1 = strings(2) ! index of string connected to quark index of parton 2 = strings(3) ! index of string connected to qbar index of parton 2 = strings(4) ! index of string connected to quark index of parton 3 = strings(5) ! index of string connected to qbar index of parton 3 = strings(6) ! index of string connected to quark index of parton 4 = strings(7) ! index of string connected to qbar index of parton 4 = strings(8) ! ! 21 November 2003 ! type colorstructure integer :: n integer, dimension(8) :: cnct1 integer, dimension(8) :: cnct2 end type colorstructure type(colorstructure), dimension(10,6,3:9), save :: color ! indices denote color(graphnumber,flavorsetnumber,cutnumber) logical, save :: init = .true. real(kind=dbl) :: random integer :: x = -500 ! IF (init) THEN color(1,1,3)%n = 1 color(1,1,3)%cnct1 = (/1,x,x,2,x,1,2,x/) color(1,2,3)%n = 2 color(1,2,3)%cnct1 = (/2,1,3,2,x,3,1,x/) color(1,2,3)%cnct2 = (/3,2,2,1,x,3,1,x/) color(1,3,3)%n = 1 color(1,3,3)%cnct1 = (/x,3,3,2,2,1,1,x/) color(1,4,3)%n = 1 color(1,4,3)%cnct1 = (/1,x,x,2,2,x,x,1/) color(1,5,3)%n = 2 color(1,5,3)%cnct1 = (/2,1,3,2,1,x,x,3/) color(1,5,3)%cnct2 = (/3,2,2,1,1,x,x,3/) color(1,6,3)%n = 1 color(1,6,3)%cnct1 = (/1,x,2,1,3,2,x,3/) color(3,1,3)%n = 2 color(3,1,3)%cnct1 = (/x,3,2,1,3,2,1,x/) color(3,1,3)%cnct2 = (/x,3,3,2,2,1,1,x/) color(3,1,4)%n = 2 color(3,1,4)%cnct1 = (/1,x,x,1,x,2,2,x/) color(3,1,4)%cnct2 = (/1,x,x,2,x,1,2,x/) color(3,2,3)%n = 1 color(3,2,3)%cnct1 = (/3,2,x,3,2,1,1,x/) color(3,2,4)%n = 1 color(3,2,4)%cnct1 = (/3,2,2,1,x,3,1,x/) color(3,3,3)%n = 2 color(3,3,3)%cnct1 = (/1,x,2,1,3,2,x,3/) color(3,3,3)%cnct2 = (/1,x,3,2,2,1,x,3/) color(3,3,4)%n = 2 color(3,3,4)%cnct1 = (/x,1,1,x,2,x,x,2/) color(3,3,4)%cnct2 = (/x,2,1,x,2,x,x,1/) color(3,4,3)%n = 1 color(3,4,3)%cnct1 = (/2,1,1,x,3,2,x,3/) color(3,4,4)%n = 1 color(3,4,4)%cnct1 = (/2,1,3,2,1,x,x,3/) color(4,1,5)%n = 1 color(4,1,5)%cnct1 = (/x,2,1,x,x,1,2,x/) color(4,1,6)%n = 1 color(4,1,6)%cnct1 = (/1,x,x,2,2,x,x,1/) color(4,2,5)%n = 2 color(4,2,5)%cnct1 = (/2,1,3,2,x,3,1,x/) color(4,2,5)%cnct2 = (/3,2,2,1,x,3,1,x/) color(4,2,6)%n = 2 color(4,2,6)%cnct1 = (/2,1,3,2,1,x,x,3/) color(4,2,6)%cnct2 = (/3,2,2,1,1,x,x,3/) color(5,1,5)%n = 1 color(5,1,5)%cnct1 = (/x,3,3,2,2,1,1,x/) color(5,2,5)%n = 1 color(5,2,5)%cnct1 = (/1,x,2,1,3,2,x,3/) color(6,1,5)%n = 1 color(6,1,5)%cnct1 = (/x,3,3,2,2,1,1,x/) color(6,2,5)%n = 1 color(6,2,5)%cnct1 = (/1,x,2,1,3,2,x,3/) color(7,1,5)%n = 1 color(7,1,5)%cnct1 = (/3,2,2,1,x,3,1,x/) color(7,1,6)%n = 1 color(7,1,6)%cnct1 = (/3,2,x,3,2,1,1,x/) color(7,1,7)%n = 1 color(7,1,7)%cnct1 = (/2,1,3,2,1,x,x,3/) color(7,1,8)%n = 1 color(7,1,8)%cnct1 = (/3,2,x,3,2,1,1,x/) color(7,2,5)%n = 2 color(7,2,5)%cnct1 = (/1,x,x,1,x,2,2,x/) color(7,2,5)%cnct2 = (/1,x,x,2,x,1,2,x/) color(7,2,6)%n = 2 color(7,2,6)%cnct1 = (/x,3,2,1,3,2,1,x/) color(7,2,6)%cnct2 = (/x,3,3,2,2,1,1,x/) color(7,2,7)%n = 2 color(7,2,7)%cnct1 = (/x,1,1,x,2,x,x,2/) color(7,2,7)%cnct2 = (/x,2,1,x,2,x,x,1/) color(7,2,8)%n = 2 color(7,2,8)%cnct1 = (/x,3,2,1,3,2,1,x/) color(7,2,8)%cnct2 = (/x,3,3,2,2,1,1,x/) color(7,3,5)%n = 1 color(7,3,5)%cnct1 = (/2,1,3,2,1,x,x,3/) color(7,3,6)%n = 1 color(7,3,6)%cnct1 = (/2,1,1,x,3,2,x,3/) color(7,3,7)%n = 1 color(7,3,7)%cnct1 = (/3,2,2,1,x,3,1,x/) color(7,3,8)%n = 1 color(7,3,8)%cnct1 = (/2,1,1,x,3,2,x,3/) color(7,4,5)%n = 2 color(7,4,5)%cnct1 = (/x,1,1,x,2,x,x,2/) color(7,4,5)%cnct2 = (/x,2,1,x,2,x,x,1/) color(7,4,6)%n = 2 color(7,4,6)%cnct1 = (/1,x,2,1,3,2,x,3/) color(7,4,6)%cnct2 = (/1,x,3,2,2,1,x,3/) color(7,4,7)%n = 2 color(7,4,7)%cnct1 = (/1,x,x,1,x,2,2,x/) color(7,4,7)%cnct2 = (/1,x,x,2,x,1,2,x/) color(7,4,8)%n = 2 color(7,4,8)%cnct1 = (/1,x,2,1,3,2,x,3/) color(7,4,8)%cnct2 = (/1,x,3,2,2,1,x,3/) color(8,1,5)%n = 1 color(8,1,5)%cnct1 = (/x,2,x,1,1,x,2,x/) color(8,1,6)%n = 1 color(8,1,6)%cnct1 = (/1,x,2,x,x,2,x,1/) color(8,2,5)%n = 1 color(8,2,5)%cnct1 = (/1,x,x,1,x,2,2,x/) color(8,2,6)%n = 1 color(8,2,6)%cnct1 = (/x,1,1,x,2,x,x,2/) color(8,3,5)%n = 1 color(8,3,5)%cnct1 = (/3,2,2,1,x,3,1,x/) color(8,3,6)%n = 1 color(8,3,6)%cnct1 = (/2,1,3,2,1,x,x,3/) color(9,1,5)%n = 1 color(9,1,5)%cnct1 = (/x,3,3,2,1,x,2,1/) color(10,1,5)%n = 2 color(10,1,5)%cnct1 = (/2,1,3,2,x,3,1,x/) color(10,1,5)%cnct2 = (/3,2,2,1,x,3,1,x/) color(10,1,6)%n = 2 color(10,1,6)%cnct1 = (/x,1,x,2,1,x,2,x/) color(10,1,6)%cnct2 = (/x,2,x,1,1,x,2,x/) color(10,1,7)%n = 2 color(10,1,7)%cnct1 = (/1,x,2,x,x,1,x,2/) color(10,1,7)%cnct2 = (/1,x,2,x,x,2,x,1/) color(10,1,8)%n = 2 color(10,1,8)%cnct1 = (/2,1,3,2,1,x,x,3/) color(10,1,8)%cnct2 = (/3,2,2,1,1,x,x,3/) color(10,1,9)%n = 2 color(10,1,9)%cnct1 = (/2,1,x,3,1,x,3,2/) color(10,1,9)%cnct2 = (/3,2,x,3,1,x,2,1/) END IF ! (init) ! IF (color(graphnumber,flavorsetnumber,cutnumber)%n.EQ.2) THEN IF (random(1).GT.0.5d0) THEN strings = color(graphnumber,flavorsetnumber,cutnumber)%cnct1 + 500 ELSE strings = color(graphnumber,flavorsetnumber,cutnumber)%cnct2 + 500 END IF ELSE strings = color(graphnumber,flavorsetnumber,cutnumber)%cnct1 + 500 END IF RETURN END ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine finda(vrtx,q,nq,order,a,qok) ! use beowulf_parameters implicit none ! In: integer :: vrtx(0:3*size-1,2),q(0:size),nq,order ! Out: integer :: a(0:3*size-1,0:size) logical :: qok ! ! Finds matrix A relating propagator momenta to loop momenta. ! ! VRTX(P,N) specifies the graph considered ! Q(L) specifies the propagators to be considered independent ! NQ specifies how many entries of Q should be considered ! NQ = NLOOPS all the entries in Q should be considered. ! If Q(0),Q(1),...,Q(NLOOPS) are independent then ! FINDA generates the matrix A and sets QOK = .TRUE. ! Otherwise the generation of A fails and QOK = .FALSE. ! NQ < NLOOPS only first NQ entries in Q should be considered. ! If Q(0),Q(1),...,Q(NQ) are independent then ! FINDA sets QOK = .TRUE. ! Otherwise QOK = .FALSE. ! In either case, a complete A is not generated. ! ! L index of loop momenta, L = 0,1,...,NLOOPS. ! L = 0 normally denontes the virtual photon momentum. ! P index of propagator, P = 0,1,...,NPROPS. ! P = 0 denotes the virtual photon momentum. ! V index of vertices, V = 1,...,NVERTS ! A(P,L) matrix relating propagator momenta to loop momenta. ! K(P) = Sum_L A(P,L) K(Q(L)). ! VRTX(P,1) = V means that the vertex connected to the tail of ! propagator P is V. ! VRTX(P,2) = V means that the vertex connected to the head of ! propagator P is V. ! Q(L) = P means that we consider the Lth loop momentum to ! be that carried by propagator P. ! CONNECTED(V,J) = P means that the Jth propagator connected to ! vertex V is P. ! FIXED(P) = True means that we have determined the momentum carried ! by propagator P. ! FINISHED(V) = True means that we have determined the momenta carried ! by all the propagators connected to vertex V. ! PROPSIGN(VRTX,P,V) is a function that returns +1 if the head of ! propagator P is at V, -1 if the tail is at V. ! COUNT is the number of propagators connected to the vertex ! under consideration such that FIXED(P) = True. If ! COUNT = 2, then we can fix another propagator momentum. ! 3 July 1994 ! 19 December 1995 ! integer :: nloops,nprops,nverts integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 ! integer :: l,p,v,j,l1,l2 integer :: connected(2*size,3) logical :: fixed(0:3*size-1),finished(2*size) logical :: change integer :: propsign,sign integer :: sum(0:size) integer :: count integer :: ptofix ! IF (order.EQ.1) THEN nloops = nloops1 nprops = nprops1 nverts = nverts1 ELSE IF (order.EQ.2) THEN nloops = nloops2 nprops = nprops2 nverts = nverts2 ELSE write(nout,*)'Order must be 1 or 2.',order END IF ! IF((nq.LT.1).OR.(nq.GT.nloops)) THEN write(nout,*)'Nq out of range in finda.' END IF ! ! First check to see that the same propagator hasn't been ! assigned to two loop variables. ! DO l1 = 0,nq-1 DO l2 = l1+1,nq IF (q(l1).EQ.q(l2)) THEN qok = .false. RETURN END IF END DO END DO ! ! Initialization. ! qok = .false. ! DO v = 1,nverts j = 1 DO p = 0,nprops IF( (vrtx(p,1).EQ.v).OR.(vrtx(p,2).EQ.v) ) THEN connected(v,j) = p j = j+1 END IF END DO END DO ! DO p = 0,nprops DO l = 0,nloops a(p,l) = 0 END DO END DO DO l = 0,nq a(q(l),l) = 1 END DO ! DO p = 0,nprops fixed(p) = .false. END DO DO l = 0,nq fixed(q(l)) = .true. END DO ! DO v = 1,nverts finished(v) = .false. END DO ! change = .true. ! ! Start. ! DO WHILE (change) change = .false. ! DO v = 1,nverts IF (.NOT.finished(v)) THEN count = 0 DO j = 1,3 p = connected(v,j) IF ( fixed(p) ) THEN count = count + 1 END IF END DO ! ! There are 3 already fixed propagators conencted to this vertex, so ! we must check to see if the momenta coming into the vertex sum to ! zero. ! IF (count.EQ.3) THEN DO l = 0,nq sum(l) = 0 END DO DO j = 1,3 p = connected(v,j) sign = propsign(vrtx,p,v) DO l = 0,nq sum(l) = sum(l) + sign * a(p,l) END DO END DO DO l = 0,nq ! ! Dependent propagators given to FINDA. ! IF (sum(l).NE.0) THEN qok = .false. RETURN ! END IF END DO finished(v) = .true. change = .true. ! ! There are two already fixed propagators connected to this vertex, ! so we should determine the momentum carried by the remaining, ! unfixed, propagator. ! ELSE IF (count.EQ.2) THEN DO l = 0,nq sum(l) = 0 END DO DO j = 1,3 p = connected(v,j) IF ( fixed(p) ) THEN sign = propsign(vrtx,p,v) DO l = 0,nq sum(l) = sum(l) + sign * a(p,l) END DO ELSE ptofix = p END IF END DO sign = propsign(vrtx,ptofix,v) DO l = 0,nq a(ptofix,l) = - sign * sum(l) END DO fixed(ptofix) = .true. finished(v) = .true. change = .true. END IF ! ! Close loop DO V = 1,NVERTS ; IF (.NOT.FINISHED(V)) THEN. ! END IF END DO ! ! Close loop DO WHILE (CHANGE) ! END DO ! ! At this point, we have not found a contradiction with momentum ! conservation, so the Q's must have been OK: ! qok = .true. ! ! If we had been given a complete set of Q's, then we should have ! fixed each propagator at each vertex. Check just to make sure. ! IF (nq.EQ.nloops) THEN DO v = 1,nverts IF (.NOT.finished(v) ) THEN write(nout,*)'Snafu in finda.' write(nout,*)'v = ',v,' nq =',nq write(nout,*)'q =',q(0),q(1),q(2),q(3) stop END IF END DO END IF ! RETURN ! END subroutine finda ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function propsign(vrtx,p,v) ! use beowulf_parameters implicit none ! In: integer :: vrtx(0:3*size-1,2) integer :: p,v ! Out: integer :: propsign ! ! IF ( vrtx(p,1).EQ.v ) THEN propsign = -1 RETURN ELSE IF ( vrtx(p,2).EQ.v ) THEN propsign = 1 RETURN ELSE write(nout,*)'Propsign called for p not connected to v.' stop END IF END function propsign ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine findtypes(graph,nmaps,qs,qsigns,maptypes) ! use beowulf_parameters use beowulf_structures implicit none ! In: type(graphstructure) :: graph ! Out: integer :: nmaps,qs(maxmaps,0:size),qsigns(maxmaps,0:size) character(len=6) :: maptypes(maxmaps) ! ! Given a graph specified by VRTX and PROP, this subroutine finds the ! characteristics of each map, labelled by an index MAPNUMBER. For a given map, ! it finds labels Q of 'special' propagators and the corresponding signs QSIGN ! and the MAPTYPE. The subroutine does finds the total number of maps, NMAPS, ! and fills the corresponding arrays QS, QSIGNS, and MAPTYPES, each of which ! carries a MAPNUMBER index. The definition is that the loop momenta are ! ! ELL(L,mu) = K(Q(L),mu) for L = 1,2,3. ! ! The other K(P,mu) are related to these by K(P,mu) = Sum A_{P,L} ELL(L,mu). ! Following the paper "Choosing integration points for QCD calculations by ! numerical integration" (Phys. Rev. D 64, 034018 (2001)), we also define ! vectors ELL1(mu), ELL2(mu) = P1(mu), and ELL3(mu) = P2(mu) which equal the ! respective ELL(L,mu) up to signs: ! ! ELL(1,mu) = QSIGN(1)*ELL1(mu) ! ELL(2,mu) = QSIGN(2)*ELL2(mu) ! ELL(3,mu) = QSIGN(3)*ELL3(mu) ! ! The paper does not, unfortunately, take note of these signs. The momentum ! flow directions shown in the paper are those of {ELL1(mu),ELL2(mu),ELL3(mu)}. ! The signs arise because the momentum flow directions for the propagator ! momenta K(P,mu) have independent definitions. ! ! The possibilities for maptypes are as follows: ! ! 1) T2TO2T used for k1 + k2 -> p1 + p2 with a virtual parton ! with momentum q exchanged, q = k1 - p1. Then P(Q(1)) = q, ! P(Q(2)) = p1, P(Q(3)) = p2. We will generate points with ! CHOOSET2TO2T(p1,p2,ell1,ok). ! ! 2) T2TO2S used for k1 + k2 -> p1 + p2 with a *no* virtual ! parton with momentum q = k1 - p1 exchanged. Then P(Q(1)) = k1, ! P(Q(2)) = p1, P(Q(3)) = p2. We will generate points with ! CHOOSE2TO2S(p1,p2,ell1,ok). ! ! 3) T2TO3 used for k1 + k2 -> p1 + p2 + p3 with k2 = - k1. ! Then P(Q(1)) = k1, P(Q(2)) = p1, P(Q(3)) = p2. We will generate ! points with CHOOSET2TO3(p1,p2,ell1,ok). ! ! 4) T2TO1A used for k1 + k2 -> p1 on shell for a virtual self-energy ! diagram. We will choose points with CHOOSEST2TO1A(p1,p2,ell1,ok). ! ! 4) T2TO1B used for k1 + k2 -> p1 on shell for a virtual three or four ! point function. We will choose points with CHOOSEST2TO1B(p1,p2,ell1,ok). ! This case is not discussed in the paper "Choosing integration points ! for QCD calculations by numerical integration." It is designed for ! the weak 1/\theta collinear singularities that occur in diagrams other ! than self energy diagrams in Coulomb gauge before real-virtual cancellations. ! ! We also have the possibility of Born graphs, for which the maptype ! is BORN and Q(1) and Q(2) are chosen as two of the cut propagators. ! ! 20 December 2000 ! 20 March 2001 ! 1 February 2002 ! 13 June 2002 ! 7 December 2002 ! integer :: cutmax integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 ! integer :: mapnumber ! Newcut variables type (cutstructure) :: cut logical :: cutfound ! integer :: l,p,kj,k1,k2,kdirect,ptest,pleaving,pp1,pp2 integer :: l1,signl1,ltesta,ltestb integer :: i,j,jfound1,jfound2,jfound integer :: v1,v2,v3,vother,vv1,vv2 integer :: sign0,sign1,sign2 integer :: timesfound1,timesfound2,timesfound integer :: pl,signl,vl,kl,signkl logical :: notinloop ! !---------------------------------- ! IF (graph%order.EQ.1) THEN cutmax = cutmax1 ELSE IF (graph%order.EQ.2) THEN cutmax = cutmax2 ELSE write(nout,*)'Order must be 1 or 2.',graph%order END IF ! mapnumber = 0 DO call getnewcut(graph%graphnumber,cut,cutfound) ! IF (cutfound) THEN ! IF (graph%order.EQ.1) THEN ! ! First, we have the code for what to do for Born graphs. There ! is no Q(3) or QSIGN(3) in this case. ! mapnumber = mapnumber + 1 qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = cut%cutindex(1) qsigns(mapnumber,1) = cut%cutsign(1) qs(mapnumber,2) = cut%cutindex(2) qsigns(mapnumber,2) = cut%cutsign(2) qs(mapnumber,3) = 137 qsigns(mapnumber,3) = 137 maptypes(mapnumber) = 'born ' ! ! Alternative for IF (ORDER.EQ.1) THEN ! ELSE IF (graph%order.EQ.2) THEN ! ! We want to do something only if there is a virtual loop: ! IF (cut%ncut.EQ.(cutmax-1)) THEN !--- ! Case of 4 propagators in the loop !--- IF (cut%ninloop.EQ.4) THEN ! ! For a 4 propagator loop there are three 2 to 1 maps. ! DO l = 1,3 mapnumber = mapnumber + 1 ! ! We let pl be the lth propagator around the loop and vl be the lth ! vertex around the loop. Also, signl = +1 if propagator pl is directed ! in the positive loop direction. ! pl = cut%loopindex(l) signl = cut%loopsign(l) IF (signl.EQ.1) THEN vl = graph%vrtx(pl,2) ELSE vl = graph%vrtx(pl,1) END IF ! ! We find the cut propagator kl connected to vl along ! with signkl = +1 if the cut propagator kl is leaving vertex vl ! and signkl = -1 if the cut propagator kl is entering vertex vl. Just ! as a check, we define TIMESFOUND to see if we find kl exactly ! once. ! timesfound = 0 DO j = 1,3 kj = cut%cutindex(j) IF (graph%vrtx(kj,1).EQ.vl) THEN kl = kj signkl = +1 jfound = j timesfound = timesfound + 1 ELSE IF (graph%vrtx(kj,2).EQ.vl) THEN kl = kj signkl = -1 jfound = j timesfound = timesfound + 1 END IF END DO IF (timesfound.NE.1) THEN write(nout,*) 'Failure in findtypes.' stop END IF ! ! Now we record this information. The propagator Q(3) is one of the ! propagators in the final state other than that connected to vl. The ! corresponding sign is +1 if this propagator crosses the final ! state cut in the same direction as the propagator connected to vl. ! qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = pl qsigns(mapnumber,1) = signl qs(mapnumber,2) = kl qsigns(mapnumber,2) = signkl IF (cut%cutindex(1).NE.kl) THEN qs(mapnumber,3) = cut%cutindex(1) qsigns(mapnumber,3) = cut%cutsign(1)*cut%cutsign(jfound)*signkl ELSE qs(mapnumber,3) = cut%cutindex(2) qsigns(mapnumber,3) = cut%cutsign(2)*cut%cutsign(jfound)*signkl END IF maptypes(mapnumber) = 't2to1b' ! ! Close DO l = 1,3 END DO ! ! For a 4 propagator loop there are two ellipse maps (T2T02T) and ! one circle map (T2TO3). We do the two ellipse maps first. ! DO l = 2,3 mapnumber = mapnumber + 1 p = cut%loopindex(l) v1 = graph%vrtx(p,1) v2 = graph%vrtx(p,2) ! ! We find the cut propagators K1 and K2 connected to V1 and V2 along ! with the sign = +1 if the cut propagator Kj is leaving vertex Vj ! and sign = -1 if the cut propagator Kj is entering vertex Vj. Just ! as a check, we define FOUNDJ to see if we find K1 and K2 exactly ! once. ! timesfound1 = 0 timesfound2 = 0 DO j = 1,3 kj = cut%cutindex(j) IF (graph%vrtx(kj,1).EQ.v1) THEN k1 = kj sign1 = +1 timesfound1 = timesfound1+1 ELSE IF (graph%vrtx(kj,2).EQ.v1) THEN k1 = kj sign1 = -1 timesfound1 = timesfound1+1 ELSE IF (graph%vrtx(kj,1).EQ.v2) THEN k2 = kj sign2 = +1 timesfound2 = timesfound2+1 ELSE IF (graph%vrtx(kj,2).EQ.v2) THEN k2 = kj sign2 = -1 timesfound2 = timesfound2+1 END IF END DO IF ((timesfound1.NE.1).OR.(timesfound2.NE.1)) THEN write(nout,*) 'Failure in findtypes.' stop END IF ! ! Now we record this information. ! qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = p qsigns(mapnumber,1) = +1 qs(mapnumber,2) = k1 qsigns(mapnumber,2) = sign1 qs(mapnumber,3) = k2 qsigns(mapnumber,3) = sign2 maptypes(mapnumber) = 't2to2t' ! ! End DO L = 2,3 for the choice of two ellipse maps. ! END DO ! ! Now we do the circle map. ! Our definition for the circle map T2TO3E is that Q(1) is ! LOOPINDEX(1) the first propagator in the loop starting from the ! current vertex. Then Q(2) is the label of the propagator that ! enters the final state and connects to the vertex at the head ! of propagator Q(1). Then Q(3) is the label of the propagator ! that enters the final state and connects to the propagator with ! label LOOPINDEX(4), the last propagator in the loop. The sign ! QSIGN(1) = +1 since this propagator always points *from* the ! current vertex. For QSIGN(2) and QSIGN(3) a plus sign indicates ! that the propagator points toward the final state, a minus sign ! indicates the opposite. ! IF(cut%loopsign(1).NE.1) THEN write(nout,*)'loopsign(1) not 1 in findtypes.' stop ELSE IF(cut%loopsign(4).NE.-1) THEN write(nout,*)'loopsign(4) not -1 in findtypes.' stop END IF ! v1 = graph%vrtx(cut%loopindex(1),2) v2 = graph%vrtx(cut%loopindex(4),2) timesfound1 = 0 timesfound2 = 0 DO j = 1,3 kj = cut%cutindex(j) IF (graph%vrtx(kj,1).EQ.v1) THEN k1 = kj sign1 = +1 timesfound1 = timesfound1+1 ELSE IF (graph%vrtx(kj,2).EQ.v1) THEN k1 = kj sign1 = -1 timesfound1 = timesfound1+1 ELSE IF (graph%vrtx(kj,1).EQ.v2) THEN k2 = kj sign2 = +1 timesfound2 = timesfound2+1 ELSE IF (graph%vrtx(kj,2).EQ.v2) THEN k2 = kj sign2 = -1 timesfound2 = timesfound2+1 END IF END DO IF ((timesfound1.NE.1).OR.(timesfound2.NE.1)) THEN write(nout,*) 'Oops, failure in findtypes.', & timesfound1,timesfound2 stop END IF ! mapnumber = mapnumber + 1 qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = cut%loopindex(1) qsigns(mapnumber,1) = +1 qs(mapnumber,2) = k1 qsigns(mapnumber,2) = sign1 qs(mapnumber,3) = k2 qsigns(mapnumber,3) = sign2 maptypes(mapnumber) = 't2to3e' ! !--- ! Case of 3 propagators in the loop !--- ELSE IF (cut%ninloop.EQ.3) THEN ! ! With three propagators in the loop there are one or two 2 to 1 maps. ! DO l = 1,2 ! ! We let pl be the lth propagator around the loop and vl be the lth ! vertex around the loop. Also, signl = +1 if propagator pl is directed ! in the positive loop direction. ! pl = cut%loopindex(l) signl = cut%loopsign(l) IF (signl.EQ.1) THEN vl = graph%vrtx(pl,2) ELSE vl = graph%vrtx(pl,1) END IF ! ! We find the cut propagator kl connected to vl along ! with signkl = +1 if the cut propagator kl is leaving vertex vl ! and signkl = -1 if the cut propagator kl is entering vertex vl. ! We define TIMESFOUND to see if we find kl exactly once. It can ! happen that we will not find final state propagator that connects ! to vl. Then we do not record a 2 to 1 map. ! timesfound = 0 DO j = 1,3 kj = cut%cutindex(j) IF (graph%vrtx(kj,1).EQ.vl) THEN kl = kj signkl = +1 jfound = j timesfound = timesfound + 1 ELSE IF (graph%vrtx(kj,2).EQ.vl) THEN kl = kj signkl = -1 jfound = j timesfound = timesfound + 1 END IF END DO IF (timesfound.GT.1) THEN write(nout,*) 'Failure in findtypes.' stop ELSE IF (timesfound.EQ.1) THEN ! ! We have a 2 to 1 map and we need to record this information. ! The propagator Q(3) is one of the propagators in the final state other ! than that connected to vl. The corresponding sign is +1 if this propagator ! crosses the final state cut in the same direction as the propagator ! connected to vl. ! mapnumber = mapnumber + 1 qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = pl qsigns(mapnumber,1) = signl qs(mapnumber,2) = kl qsigns(mapnumber,2) = signkl IF (cut%cutindex(1).NE.kl) THEN qs(mapnumber,3) = cut%cutindex(1) qsigns(mapnumber,3) = cut%cutsign(1)*cut%cutsign(jfound)*signkl ELSE qs(mapnumber,3) = cut%cutindex(2) qsigns(mapnumber,3) = cut%cutsign(2)*cut%cutsign(jfound)*signkl END IF maptypes(mapnumber) = 't2to1b' ! ! Close ELSE IF (timesfound.EQ.1) THEN END IF ! Close DO l = 1,3 END DO ! ! Now continuing with the virtual three point function, we will need ! either a 2to2(t) map or a 2to2(s) map and a 2to3 map. ! We are not sure which of two possibilities we have, but we proceed ! as if we had the case of a virtual loop that connects to two ! propagators that go into the final state. ! mapnumber = mapnumber + 1 p = cut%loopindex(2) v1 = graph%vrtx(p,1) v2 = graph%vrtx(p,2) ! ! We find the cut propagators K1 and K2 connected to V1 and V2 along ! with the sign = +1 if the cut propagator Kj is leaving vertex Vj ! and sign = -1 if the cut propagator Kj is entering vertex Vj. We ! check using FOUNDJ to see if we find K1 and K2 exactly once. ! timesfound1 = 0 timesfound2 = 0 DO j = 1,3 kj = cut%cutindex(j) IF (graph%vrtx(kj,1).EQ.v1) THEN k1 = kj sign1 = +1 timesfound1 = timesfound1+1 ELSE IF (graph%vrtx(kj,2).EQ.v1) THEN k1 = kj sign1 = -1 timesfound1 = timesfound1+1 ELSE IF (graph%vrtx(kj,1).EQ.v2) THEN k2 = kj sign2 = +1 timesfound2 = timesfound2+1 ELSE IF (graph%vrtx(kj,2).EQ.v2) THEN k2 = kj sign2 = -1 timesfound2 = timesfound2+1 END IF END DO ! ! Now we figure out what to do based on what we found. ! IF ((timesfound1.GT.1).OR.(timesfound2.GT.1)) THEN write(nout,*) 'Failure in findtypes.' stop ELSE IF ((timesfound1.LT.1).AND.(timesfound2.LT.1)) THEN write(nout,*) 'Failure in findtypes.' stop ! ELSE IF ((timesfound1.EQ.1).AND.(timesfound2.EQ.1)) THEN ! ! This is the case we were looking for. Now we record the information. ! qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = p qsigns(mapnumber,1) = +1 qs(mapnumber,2) = k1 qsigns(mapnumber,2) = sign1 qs(mapnumber,3) = k2 qsigns(mapnumber,3) = sign2 maptypes(mapnumber) = 't2to2t' ! ELSE ! ! Either Found1 = 1 and Found2 = 0 or Found2 = 1 and Found1 = 0. ! In these cases our loop does *not* connect to two propagators ! that go to the final state. The label of the propagator ! that enters the final state will be called Kdirect and the ! vertex that does not connect to this propagator will be called ! Vother. We take sign0 = +1 if our loop propagator points from ! Kdirect to the s-channel propagator that splits into two ! propagators that go to the final state. Otherwise sign0 = -1. ! IF ((timesfound1.EQ.1).AND.(timesfound2.EQ.0)) THEN kdirect = k1 vother = v2 sign0 = +1 ELSE IF ((timesfound1.EQ.0).AND.(timesfound2.EQ.1)) THEN kdirect = k2 vother = v1 sign0 = -1 END IF ! ! Now we deal with this case. ! IF (cut%cutindex(1).EQ.kdirect) THEN k1 = cut%cutindex(2) k2 = cut%cutindex(3) ELSE IF (cut%cutindex(2).EQ.kdirect) THEN k1 = cut%cutindex(3) k2 = cut%cutindex(1) ELSE IF (cut%cutindex(3).EQ.kdirect) THEN k1 = cut%cutindex(1) k2 = cut%cutindex(2) ELSE write(nout,*)'We are in real trouble here.' stop END IF ! ! We have K1 and K2, but we need the corresponding signs. ! Find the index Pleaving of the propagator leaving the loop toward ! the final state. ! timesfound = 0 DO j = 1,3 ptest = graph%prop(vother,j) notinloop = .true. DO i = 1,3 IF (ptest.EQ.cut%loopindex(i)) THEN notinloop = .false. END IF END DO IF (notinloop) THEN pleaving = ptest timesfound = timesfound + 1 END IF END DO IF (timesfound.NE.1) THEN write(nout,*)'pleaving not found or found twice.' stop END IF ! ! Let V3 be the vertex not in the loop at the end of propagator ! Pleaving. Two propagators in the final state must connect to this ! vertex. ! v3 = graph%vrtx(pleaving,1) IF (v3.EQ.vother) THEN v3 = graph%vrtx(pleaving,2) END IF ! ! We use V3 to get the proper signs. ! IF (graph%vrtx(k1,1).EQ.v3) THEN sign1 = +1 ELSE IF (graph%vrtx(k1,2).EQ.v3) THEN sign1 = -1 ELSE write(nout,*)'Yikes, this is bad.' stop END IF IF (graph%vrtx(k2,1).EQ.v3) THEN sign2 = +1 ELSE IF (graph%vrtx(k2,2).EQ.v3) THEN sign2 = -1 ELSE write(nout,*)'Yikes, this is also bad.' stop END IF ! ! Now we record the information. ! Recall that P = LOOPINDEX(2) and that SIGN0 = +1 if propagator P ! points toward propagator Pleaving. ! qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = p qsigns(mapnumber,1) = sign0 qs(mapnumber,2) = k1 qsigns(mapnumber,2) = sign1 qs(mapnumber,3) = k2 qsigns(mapnumber,3) = sign2 maptypes(mapnumber) = 't2to2s' ! ! But we are not done, because in this case we need a circle map too. ! Our definition for the circle map T2TO3D is that Q(1) is ! LOOPINDEX(1) or LOOPINDEX(3), one of the two propagators that ! connects to a propagator that connects to the current vertex. ! We take the one that connects to vertex Vother that connects to ! a propagator Pleaving that connects vertex V3 that, finally, ! connects to to two propagators that enter the final state. Then ! Q(3) and Q(3) are these two propagators that enter the final ! state from vertex V3. For QSIGN(2) and QSIGN(3) a plus sign ! indicates that the propagator points toward the final state, a ! minus sign indicates the opposite. The sign QSIGN(1) is + 1 if ! this propagator points toward the final state, -1 in the ! opposite circumstance. ! IF (cut%loopsign(1).NE.1) THEN write(nout,*)'loopsign not 1 in findtypes.' stop END IF ! ! The loop momentum with label L1 is the one that ! attaches to VOTHER (the vertex that connects to a propagator ! that splits before going to the final state.) We take ! SIGNL1 = +1 if this propagator points towards VOTHER. ! ltesta = cut%loopindex(1) ltestb = cut%loopindex(3) IF (graph%vrtx(ltesta,2).EQ.vother) THEN l1 = ltesta signl1 = +1 ELSE IF (graph%vrtx(ltesta,1).EQ.vother) THEN l1 = ltesta signl1 = -1 ELSE IF (graph%vrtx(ltestb,2).EQ.vother) THEN l1 = ltestb signl1 = +1 ELSE IF (graph%vrtx(ltestb,1).EQ.vother) THEN l1 = ltestb signl1 = -1 ELSE write(nout,*)'Cannot seem to find l1.' stop END IF ! mapnumber = mapnumber + 1 qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = l1 qsigns(mapnumber,1) = signl1 qs(mapnumber,2) = k1 qsigns(mapnumber,2) = sign1 qs(mapnumber,3) = k2 qsigns(mapnumber,3) = sign2 maptypes(mapnumber) = 't2to3d' ! ! Close the IF structure for the case of three particles in the loop, ! IF (FOUND1.GT.1).OR.(FOUND2.GT.1) THEN ... ! END IF !--- ! Case of 2 propagators in the loop !--- ELSE IF (cut%ninloop.EQ.2) THEN ! ! We are not sure which of two possibilities we have, but we proceed ! as if we had the case of a virtual loop that connects to two ! propagators that go into the final state. ! mapnumber = mapnumber + 1 p = cut%loopindex(1) v1 = graph%vrtx(p,1) v2 = graph%vrtx(p,2) ! ! We find the cut propagators K1 or K2 connected to V1 or V2 along ! with the sign = +1 if the cut propagator Kj is leaving vertex Vj ! and sign = -1 if the cut propagator Kj is entering vertex Vj. We ! check using FOUNDJ to see if we find K1 or K2 exactly once. ! timesfound1 = 0 timesfound2 = 0 DO j = 1,3 kj = cut%cutindex(j) IF (graph%vrtx(kj,1).EQ.v1) THEN k1 = kj sign1 = +1 jfound1 = j timesfound1 = timesfound1+1 ELSE IF (graph%vrtx(kj,2).EQ.v1) THEN k1 = kj sign1 = -1 jfound1 = j timesfound1 = timesfound1+1 ELSE IF (graph%vrtx(kj,1).EQ.v2) THEN k2 = kj sign2 = +1 jfound2 = j timesfound2 = timesfound2+1 ELSE IF (graph%vrtx(kj,2).EQ.v2) THEN k2 = kj sign2 = -1 jfound2 = j timesfound2 = timesfound2+1 END IF END DO ! ! Now we figure out what to do based on what we found. ! IF ((timesfound1.GT.1).OR.(timesfound2.GT.1)) THEN write(nout,*) 'Failure in findtypes.' stop ! ELSE IF ((timesfound1.EQ.1).AND.(timesfound2.EQ.0)) THEN ! ! This is one of the cases we were looking for. Now we record the ! information. The propagator Q(3) is one of the propagators ! in the final state other than that connected to our loop. The ! corresponding sign is +1 if this propagator crosses the final ! state cut in the same direction as the propagator connected to ! our loop. ! qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = p qsigns(mapnumber,1) = -1 qs(mapnumber,2) = k1 qsigns(mapnumber,2) = sign1 IF (cut%cutindex(1).NE.k1) THEN qs(mapnumber,3) = cut%cutindex(1) qsigns(mapnumber,3) = cut%cutsign(1)*cut%cutsign(jfound1)*sign1 ELSE qs(mapnumber,3) = cut%cutindex(2) qsigns(mapnumber,3) = cut%cutsign(2)*cut%cutsign(jfound1)*sign1 END IF maptypes(mapnumber) = 't2to1a' ! ELSE IF ((timesfound1.EQ.0).AND.(timesfound2.EQ.1)) THEN ! ! This is one of the cases we were looking for. Now we record the ! information. The propagator Q(3) is one of the propagators ! in the final state other than that connected to our loop. The ! corresponding sign is +1 if this propagator crosses the final ! state cut in the same direction as the propagator connected to ! our loop. ! qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = p qsigns(mapnumber,1) = +1 qs(mapnumber,2) = k2 qsigns(mapnumber,2) = sign2 IF (cut%cutindex(1).NE.k2) THEN qs(mapnumber,3) = cut%cutindex(1) qsigns(mapnumber,3) = cut%cutsign(1)*cut%cutsign(jfound2)*sign2 ELSE qs(mapnumber,3) = cut%cutindex(2) qsigns(mapnumber,3) = cut%cutsign(2)*cut%cutsign(jfound2)*sign2 END IF maptypes(mapnumber) = 't2to1a' ! ELSE IF ((timesfound1.EQ.0).AND.(timesfound2.EQ.0)) THEN ! ! Here TimesFound1 = 0 and TimesFound2 = 0, so our loop does *not* ! connect to a propagator that goes to the final state. ! Find the indices PP1 and PP2 of the propagators connected to ! our loop. ! timesfound = 0 DO j = 1,3 ptest = graph%prop(v1,j) notinloop = .true. DO i = 1,2 IF (ptest.EQ.cut%loopindex(i)) THEN notinloop = .false. END IF END DO IF (notinloop) THEN pp1 = ptest timesfound = timesfound + 1 END IF END DO IF (timesfound.NE.1) THEN write(nout,*)'pp1 not found or found twice.' stop END IF timesfound = 0 ! DO j = 1,3 ptest = graph%prop(v2,j) notinloop = .true. DO i = 1,2 IF (ptest.EQ.cut%loopindex(i)) THEN notinloop = .false. END IF END DO IF (notinloop) THEN pp2 = ptest timesfound = timesfound + 1 END IF END DO IF (timesfound.NE.1) THEN write(nout,*)'pp2 not found or found twice.' stop END IF ! ! Let VV1 and VV2 be the vertices not in the loop at the end of ! propagators PP1 and PP2 respectively. Two propagators in the final ! state must connect to one of these vertices. ! vv1 = graph%vrtx(pp1,1) IF (vv1.EQ.v1) THEN vv1 = graph%vrtx(pp1,2) END IF vv2 = graph%vrtx(pp2,1) IF (vv2.EQ.v2) THEN vv2 = graph%vrtx(pp2,2) END IF ! ! We have VV1 and VV2. A slight hitch is that one of them might be ! the vertex 1 or 2 that connect to the photon. In this case, ! in the next step we do *not* want to find the final state ! propagator that connects to this vertex. A cure is to set the ! vertex number to something impossible. ! IF ((vv1.EQ.1).OR.(vv1.EQ.2)) THEN vv1 = -17 END IF IF ((vv2.EQ.1).OR.(vv2.EQ.2)) THEN vv2 = -17 END IF ! ! Now we find two final state propagators connected to VV1 or ! else two final state propagators connected to VV2. ! timesfound = 0 DO j = 1,3 kj = cut%cutindex(j) IF (graph%vrtx(kj,1).EQ.vv1) THEN IF(timesfound.EQ.0) THEN k1 = kj sign1 = +1 ELSE k2 = kj sign2 = +1 END IF sign0 = -1 timesfound = timesfound+1 ELSE IF (graph%vrtx(kj,1).EQ.vv2) THEN IF(timesfound.EQ.0) THEN k1 = kj sign1 = +1 ELSE k2 = kj sign2 = +1 END IF sign0 = +1 timesfound = timesfound+1 ELSE IF (graph%vrtx(kj,2).EQ.vv1) THEN IF(timesfound.EQ.0) THEN k1 = kj sign1 = -1 ELSE k2 = kj sign2 = -1 END IF sign0 = -1 timesfound = timesfound+1 ELSE IF (graph%vrtx(kj,2).EQ.vv2) THEN IF(timesfound.EQ.0) THEN k1 = kj sign1 = -1 ELSE k2 = kj sign2 = -1 END IF sign0 = +1 timesfound = timesfound+1 END IF END DO IF (timesfound.NE.2) THEN write(nout,*)'Where are those tricky propagators?',timesfound stop END IF ! ! Now we record the information. ! Recall that P = LOOPINDEX(1) and that SIGN0 = +1 if propagator P ! points toward propagators in the final state. ! qs(mapnumber,0) = 0 qsigns(mapnumber,0) = +1 qs(mapnumber,1) = p qsigns(mapnumber,1) = sign0 qs(mapnumber,2) = k1 qsigns(mapnumber,2) = sign1 qs(mapnumber,3) = k2 qsigns(mapnumber,3) = sign2 maptypes(mapnumber) = 't2to2s' ! ! Close IF ((TIMESFOUND1.GT.1).OR.(TIMESFOUND2.GT.1)) THEN ... ! END IF ! ! Case of less than 2 propagators in the loop ! ELSE write(nout,*) 'Looped the loop in finddqs.' stop ! ! End IF (NINLOOP.EQ. n ) series ! END IF ! ! End IF (there is a virtual loop) THEN ... ! END IF ! ! Close IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ... ! ELSE write(nout,*)'Order in findtypes needed to be 1 or 2.' stop END IF ! ! End IF (CUTFOUND) THEN ... If the cut was not found, then we are done. ! ELSE EXIT END IF ! ! End main loop: DO call getnewcut() ! END DO ! nmaps = mapnumber RETURN END subroutine findtypes ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890!2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine newpoint(a,qsign,maptype,order,k,absk,badpoint) ! use beowulf_parameters implicit none ! In: integer :: a(0:3*size-1,0:size),qsign(0:size) character(len=6) :: maptype integer :: order ! Out: real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1) logical :: badpoint ! ! Chooses a new Monte Carlo point in the space of loop 3-momenta. ! 4 March 1993 ! 12 July 1993 ! 17 July 1994 ! 2 May 1996 ! 5 February 1997 ! 4 February 1999 ! 10 March 1999 ! 9 April 1999 ! 20 August 1999 ! 21 December 2000 ! 20 March 2001 ! 8 February 2002 ! 7 December 2002 ! integer :: nprops integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 ! real(kind=dbl) :: p1(3),p2(3),p3(3),ell1(3) integer :: p,mu real(kind=dbl) :: temp,ksq logical :: ok ! !------------ ! IF (order.EQ.1) THEN nprops = nprops1 ELSE IF (order.EQ.2) THEN nprops = nprops2 ELSE write(nout,*)'Order must be 1 or 2.',order END IF ! badpoint = .false. ! IF (order.EQ.1) THEN ! ! We deal with the case of a Born graph first. ! call choose3(p1,p2,p3,ok) IF(.NOT.ok) THEN DO p = 1,nprops DO mu = 0,3 k(p,mu) = 0.0d0 END DO END DO badpoint = .true. RETURN END IF DO p = 1,nprops ksq = 0.0d0 DO mu = 1,3 temp = a(p,1)*qsign(1)*p1(mu) & + a(p,2)*qsign(2)*p2(mu) k(p,mu) = temp ksq = ksq + temp**2 END DO absk(p) = sqrt(ksq) k(p,0) = 0.0d0 END DO DO mu = 0,3 k(0,mu) = 0.0d0 END DO absk(0) = 0.0d0 ! ! Alternative for IF (ORDER.EQ.1) THEN ! ELSE IF (order.EQ.2) THEN ! ! Here is what we do for order alpha_s^2 graphs. ! ! Our notation: The definition is that the loop momenta are ! ! ELL(L,mu) = K(Q(L),mu) for L = 1,2,3. ! ! The other K(P,mu) are related to these by K(P,mu) = Sum A_{P,L} ELL(L,mu). ! Following the paper "Choosing integration points for QCD calculations by ! numerical integration" (Phys. Rev. D 64, 034018 (2001)), we also define ! vectors ELL1(mu), ELL2(mu) = P1(mu), and ELL3(mu) = P2(mu) which equal the ! respective ELL(L,mu) up to signs: ! ! ELL(1,mu) = QSIGN(1)*ELL1(mu) ! ELL(2,mu) = QSIGN(2)*ELL2(mu) ! ELL(3,mu) = QSIGN(3)*ELL3(mu) ! ! The paper does not, unfortunately, take note of these signs. The momentum ! flow directions shown in the paper are those of {ELL1(mu),ELL2(mu),ELL3(mu)}. ! The signs arise because the momentum flow directions for the propagator ! momenta K(P,mu) have independent definitions. We use {ELL1,P1,P2} in this ! subroutine directly to generate the K(P,mu). ! ! First, we need to generate a three parton final state. ! Abort if we get a not OK signal. ! call choose3(p1,p2,p3,ok) IF(.NOT.ok) THEN DO p = 1,nprops DO mu = 0,3 k(p,mu) = 0.0d0 END DO END DO badpoint = .true. RETURN END IF ! ! Then we generate the loop momentum, ell1. ! Abort if we get a not OK signal. ! IF (maptype.EQ.'t2to3d') THEN call choose2to3d(p1,p2,ell1,ok) ELSE IF (maptype.EQ.'t2to3e') THEN call choose2to3e(p1,p2,ell1,ok) ELSE IF (maptype.EQ.'t2to2t') THEN call choose2to2t(p1,p2,ell1,ok) ELSE IF (maptype.EQ.'t2to2s') THEN call choose2to2s(p1,p2,ell1,ok) ELSE IF (maptype.EQ.'t2to1a') THEN call choose2to1a(p1,p2,ell1,ok) ELSE IF (maptype.EQ.'t2to1b') THEN call choose2to1b(p1,p2,ell1,ok) ELSE write(nout,*)'Bad maptype in newpoint.' stop END IF IF (.NOT.ok) THEN DO p = 1,nprops DO mu = 0,3 k(p,mu) = 0.0d0 END DO END DO badpoint = .true. RETURN END IF ! ! Now we have ELL1(mu), P1(mu), and P2(mu) and we need to translate to ! the propagator momenta K(P,MU). ! DO p = 1,nprops ksq = 0.0d0 DO mu = 1,3 temp = a(p,1)*qsign(1)*ell1(mu) & + a(p,2)*qsign(2)*p1(mu) & + a(p,3)*qsign(3)*p2(mu) k(p,mu) = temp ksq = ksq + temp**2 END DO absk(p) = sqrt(ksq) k(p,0) = 0.0d0 END DO DO mu = 0,3 k(0,mu) = 0.0d0 END DO absk(0) = 0.0d0 ! ! Close IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ... ! ELSE write(nout,*)'Order should have been 1 or 2 in newpoint.' stop END IF ! RETURN END subroutine newpoint ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine checkpoint(k,absk,prop,order,badness) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1) integer :: prop(2*size,3) integer :: order ! Out: real(kind=dbl) :: badness ! ! Calculates the BADNESS of a point chosen by NEWPOINT. If there ! are very collinear particles meeting at a vertex or of there is a ! very soft particle, then the badness is big. Specifically, for ! each vertex V we order the momenta entering the vertex Kmin, Kmid ! Kmax in order of |K|. Then ! ! Kmin (Kmin + Kmid - Kmax )/Kmax^2 ! ! is the 1/badness^2 for that vertex. The badness for the point is the ! largest of the badness values of all the vertices. ! ! Revised 13 may 1998 ! integer :: nverts integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 ! real(kind=dbl) :: smallnessv,smallness integer :: v real(kind=dbl) :: kmin,kmid,kmax,k1,k2,k3 ! IF (order.EQ.1) THEN nverts = nverts1 ELSE IF (order.EQ.2) THEN nverts = nverts2 ELSE write(nout,*)'Order must be 1 or 2.',order END IF ! smallness = 1.0d0 DO v = 3,nverts k1 = absk(prop(v,1)) k2 = absk(prop(v,2)) k3 = absk(prop(v,3)) IF (k1.LT.k2) THEN kmin = k1 kmax = k2 ELSE kmin = k2 kmax = k1 END IF IF (k3.LT.kmin) THEN kmid = kmin kmin = k3 ELSE IF (k3.GT.kmax) THEN kmid = kmax kmax = k3 ELSE kmid = k3 END IF smallnessv = kmin * (kmin + kmid - kmax) /kmax**2 IF( smallnessv .LT. smallness ) THEN smallness = smallnessv END IF END DO IF (smallness.LT.1.0d-30) THEN badness = 1.0d15 ELSE badness = sqrt(1.0d0/smallness) END IF RETURN END subroutine checkpoint ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine axes(ea,eb,ec) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: ea(3) ! Out: real(kind=dbl) :: eb(3),ec(3) ! ! Given a unit vector E_a(mu), generates unit vectors E_b(mu) and ! E_c(mu) such that E_a*E_b = E_b*E_c = E_c*E_a = 0. ! ! The vector E_b will lie in the plane formed by the z-axis and ! E_a unless E_a itself is nearly aligned along the z-axis, in which ! case E_b will lie in the plane formed by the x-axis and E_a. ! ! 18 April 1996 ! ! real(kind=dbl) :: costhetasq,sinthetainv ! ! For check ! integer :: mu real(kind=dbl) :: dotaa,dotbb,dotcc,dotab,dotac,dotbc ! costhetasq = ea(3)**2 IF(costhetasq.LT.0.9d0) THEN sinthetainv = 1.0d0/sqrt(1.0d0 - costhetasq) ec(1) = - ea(2)*sinthetainv ec(2) = ea(1)*sinthetainv ec(3) = 0.0d0 ELSE costhetasq = ea(1)**2 sinthetainv = 1.0d0/sqrt(1.0d0 - costhetasq) ec(1) = 0.0d0 ec(2) = - ea(3)*sinthetainv ec(3) = ea(2)*sinthetainv END IF eb(1) = ec(2)*ea(3) - ec(3)*ea(2) eb(2) = ec(3)*ea(1) - ec(1)*ea(3) eb(3) = ec(1)*ea(2) - ec(2)*ea(1) ! ! Check: ! dotaa = 0.0d0 dotbb = 0.0d0 dotcc = 0.0d0 dotab = 0.0d0 dotac = 0.0d0 dotbc = 0.0d0 DO mu = 1,3 dotaa = dotaa + ea(mu)*ea(mu) dotbb = dotbb + eb(mu)*eb(mu) dotcc = dotcc + ec(mu)*ec(mu) dotab = dotab + ea(mu)*eb(mu) dotac = dotac + ea(mu)*ec(mu) dotbc = dotbc + eb(mu)*ec(mu) END DO IF (abs(dotaa - 1.0d0).GT.1.0d20) THEN write(nout,*)'dotaa messed up in axes.' stop ELSE IF (abs(dotbb - 1.0d0).GT.1.0d20) THEN write(nout,*)'dotbb messed up in axes.' stop ELSE IF (abs(dotcc - 1.0d0).GT.1.0d20) THEN write(nout,*)'dotcc messed up in axes.' stop ELSE IF (abs(dotab).GT.1.0d20) THEN write(nout,*)'dotab messed up in axes.' stop ELSE IF (abs(dotac).GT.1.0d20) THEN write(nout,*)'dotac messed up in axes.' stop ELSE IF (abs(dotbc).GT.1.0d20) THEN write(nout,*)'dotbc messed up in axes.' stop END IF ! RETURN END subroutine axes ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! Subroutine to calculate integrand !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine calculate(graph,kin,abskin, & qs,qsigns,maptypes,nmaps,value,maxpart,valuechk) ! use beowulf_parameters use beowulf_structures implicit none ! In: type(graphstructure) :: graph real(kind=dbl) :: kin(0:3*size-1,0:3),abskin(0:3*size-1) integer :: qs(maxmaps,0:size),qsigns(maxmaps,0:size) character(len=6) :: maptypes(maxmaps) integer :: nmaps ! Out: complex(kind=dbl) :: value,valuechk real(kind=dbl) :: maxpart ! ! Calculates the value of the graph specified by VRTX at the point K, ! returning result in VALUE, which includes the division by the density ! of points and the jacobian for deforming the contour. Also reports ! MAXPART, the biggest absolute value of the contributions to Re(VALUE). ! This helps us to keep track of cancellations and thus to abort the ! calculation if too much cancellation among terms will be required. ! ! Latest revision: 11 May 1996 ! 24 October 1996 (call to CHECKDEFORM) ! 15 November 1996 (remove finite 'i epsilon') ! 18 November 1996 (add CHECKVALUE) ! 22 November 1996 Bug fixed. ! 27 November 1996 (complex checkvalue) ! 29 November 1996 (branchcut check; better checkvalue) ! 27 February 1997 renormalization; reporting ! 25 July 1997 renormalization; self-energy graphs ! 17 September 1997 more renormalization & self-energy ! 21 September 1997 finish DEFORM ! 24 September 1997 fix bugs ! 19 October 1997 fix cutsign bug ! 22 October 1997 fix renormalization sign bug ! 6 November 1997 improvements for deformation ! 28 November 1997 more work on deformation ! 2 December 1997 more precision in "report" numbers ! 4 January 1998 revisions for self-energy graphs ! 11 January 1998 renormalizaion for self-energy graphs ! 27 February 1998 use Hrothgar for output ! 5 March 1998 integrate Hrothgar ! 14 March 1998 restore checks of deformation direction ! 24 July 1998 use countfactor(graphnumber) ! 4 August 1998 better CHECKDEFORM ! 5 August 1998 change to groupsize(graphnumber) ! 22 August 1998 add color factors ! 22 December 1998 precalculate cut structure in RENO ! 26 April 1999 omit REFLECT except as option ! 22 December 2000 omit REFLECT entirely ! 22 December 2000 change method of choosing points ! 19 December 2001 call FEYNMANF, new organization. ! 31 December 2001 add Coulomb gauge. ! 11 February 2002 Add Born calculation. ! 14 June 2002 Revisions for f95 ! 30 June 2002 Calculate separately for each flavor set. ! 30 October 2002 Add showers. ! 16 May 2003 Showers with soft gluon radiation. ! 22 November 2003 Work on interface to Pythia ! 20 February 2004 more on interface with Pythia ! 1 October 2004 correlation with beam direction etc !---------------------------------- ! integer :: nloops,nprops,cutmax integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 real(kind=dbl) :: muoverrts common /renormalize/ muoverrts logical :: report,details logical :: pythia character(len=10):: filename common /pythiainfo/ pythia,filename ! For pythia information common /calculook/ report,details real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf character(len=7) :: gauge common /gaugechoice/ gauge ! Information on the current cut. type (cutstructure) :: cut logical :: cutfound logical :: keepcut ! Information on the current flavor set. type (flavorstructure) flavorset logical :: flavorsetfound character(len=5) :: partontype integer :: partonflavor ! Showers variables ! ! Below, theshower%multfactor is the factor that will multiply the ! Born graph. From subroutine softradiate, we start with ! fijk/(4 Pi * softintegral)/density when we add the soft ! gluon to the shower; then we further divide by the densities ! of points {qbarsq,x,phi} for each splitting in the first ! level splittings of the hard partons from a Born graph. ! The Sudakov factor is not included, nor are 1/qbarsq/(2 pi). ! type(showerlist) :: theshower ! real(kind=dbl) :: onemthrust,msoftsq ! Factor in msoftsq =(msoftfactor*rts0*onemthrust)**2 real(kind=dbl) :: msoftfactor common /softcutoff/ msoftfactor ! Factor for relating kappasq to onemthrust for small onemthrust real(kind=dbl) :: onemthrustcrit common /thrustfactor/ onemthrustcrit ! ! What the program should do character(len=8) :: mode common /programmode/ mode ! Physics data: real(kind=dbl) :: alphasofmz,sinsqthetaw,mz,widthz,externalrts common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! ! Labels: integer :: qe(0:size) ! Momenta: real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1) real(kind=dbl) :: koff(0:3*size-1,0:3) real(kind=dbl) :: kinloop(size+1,0:3) real(kind=dbl) :: kcut(size+1,0:3) complex(kind=dbl) :: newkinloop(0:3) complex(kind=dbl) :: kc(0:3*size-1,0:3) complex(kind=dbl) :: ellsq,ell real(kind=dbl) :: e(0:size),rts,rts0 ! Squared momenta for factors F_j for showers real(kind=dbl) :: k1sq,k2sq ! Factors F_j for graph 9. real(kind=dbl) :: graph9factor ! Number of final state particles and their momenta integer :: nparticles real(kind=dbl) :: kf(maxparticles,0:3) ! Renormalization: real(kind=dbl) :: mumsbar ! Matrices: integer :: ae(0:3*size-1,0:size) ! FINDA variable: logical :: qok ! DENSITY variables: real(kind=dbl) :: jacnewpoint,density ! Loopcut variables: logical :: calcmore integer :: jcut,index,loopcutsign ! DEFORM variables: complex(kind=dbl) :: jacdeform ! Color connection information for final state integer, dimension(8) :: strings ! Functions: real(kind=dbl) :: cals0,smear real(kind=dbl) :: xxreal,xximag complex(kind=dbl) :: complexsqrt real(kind=dbl) :: alpi ! Index variables: integer :: p,mu,i,j,n ! Propagator properties logical :: cutQ(3*size-1) ! Flag for feynman function character(len=16) :: flag ! Results variables: real(kind=dbl) :: calsval,thrust real(kind=dbl) :: weight,maxweight complex(kind=dbl) :: feynman,feynmanf,feynman0,feynman0f,feynmanval complex(kind=dbl) :: softsubtraction real(kind=dbl) :: prefactor,prefactor0 complex(kind=dbl) :: integrand complex(kind=dbl) :: check ! Useful constants: real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) real(kind=dbl), parameter :: pi = 3.141592653589793239d0 real(kind=dbl) :: temp ! For calculating matrix element square for shower from Born graph. integer :: nfound real(kind=dbl), dimension(3) :: qvec,kplusvec,kminusvec real(kind=dbl), dimension(0:3) :: vquark,vqbar real(kind=dbl), dimension(0:3,0:3) :: tglue integer :: n0,n1,n2 character(len=5) :: f1,f2 character(len=9) :: kind2pt complex(kind=dbl) :: feynmanSH0 ! Reno size and counting variables: integer :: groupsize(maxgraphs,maxmaps) integer :: groupsizegraph(maxgraphs) integer :: groupsizetotal common /montecarlo/groupsize,groupsizegraph,groupsizetotal ! type(softinformation), dimension(3) :: softinfos ! For makeshowerI type(softinformation) :: softinfo ! For shower...prop real(kind=dbl) :: cosine(3,3) integer :: j1,j2 ! !------------------------------------------------------------------------------- ! IF (graph%order.EQ.1) THEN nloops = nloops1 nprops = nprops1 cutmax = cutmax1 ELSE IF (graph%order.EQ.2) THEN nloops = nloops2 nprops = nprops2 cutmax = cutmax2 ELSE write(nout,*)'Order must be 1 or 2.',graph%order END IF ! ! We do not want to change the value of KIN and ABSKIN. (Actually, ! all that we change in the current version in k(p,0), so this step ! is not really necessary). ! DO p = 1,nprops absk(p) = abskin(p) DO mu = 0,3 k(p,mu) = kin(p,mu) END DO END DO ! ! Initialize contribution to integral from this point. Also initialize ! BIGGEST, which will be the biggest absolute value of the contributions ! to VALUE. This helps us to keep track of cancellations and thus to ! abort the calculation if too much cancellation among terms will be ! required. ! maxpart = 0.0d0 value = (0.0d0,0.0d0) valuechk = (0.0d0,0.0d0) ! ! Calculate jacobian. ! jacnewpoint = & 1.0d0/density(graph%graphnumber,k,qs,qsigns,maptypes,nmaps,graph%order) ! ! Loop over flavorsets. ! DO IF (gauge.EQ.'feynman') THEN ! In the case of Feynman gauge, we exit at the end of the first pass. flavorset%setnumber = 1 flavorset%type = & (/'none ','none ','none ','none ','none ','none ','none ','none '/) flavorset%flavor = & (/-777,-777,-777,-777,-777,-777,-777,-777/) ELSE IF (gauge.EQ.'coulomb') THEN call getnewflavorset(graph%graphnumber,flavorset,flavorsetfound) IF (.not.flavorsetfound) EXIT ELSE write(nout,*)'That gauge does not exist.' stop END IF ! ! Loop over cuts. ! DO IF ((mode.NE.'showerI ').AND.(mode.NE.'showerII')) THEN call getnewcut(graph%graphnumber,cut,cutfound) ELSE ! ! In the case of a shower mode, for certain cuts of certain graphs ! we keep only the wide angle splitting part, while other cuts are ! omitted entirely. Subroutine checknewcut finds out for us, and ! also calculates the factor F_1 or F_2 needed for graph 9. ! DO call getnewcut(graph%graphnumber,cut,cutfound) IF (.not.cutfound) EXIT call checknewcut(graph%graphnumber,cut,k,absk,keepcut,graph9factor) IF (keepcut) EXIT END DO ! END IF ! (mode.NE.'showerI ').AND.(mode.NE.'showerII') IF (.not.cutfound) EXIT !.... IF (report) THEN IF (graph%order.EQ.2) THEN write(nout,301)cut%ncut,cut%cutindex(1),cut%cutindex(2), & cut%cutindex(3),cut%cutindex(4) ELSE write(nout,301)cut%ncut,cut%cutindex(1),cut%cutindex(2), & cut%cutindex(3) END IF 301 format('ncut =',i2,' cutindex =',4i2) END IF !'''' ! ! Calculate final state momenta. ! Then we can also calculate CALSVAL and the PREFACTOR. ! DO i = 1,cut%ncut kcut(i,0) = 0.0d0 !We calculate the energy later. DO mu = 1,3 kcut(i,mu) = cut%cutsign(i) * k(cut%cutindex(i),mu) END DO END DO ! ! Set final state energies kcut(i,0) to their on-shell values and define ! final state momenta kf(i,mu) to be kcut(i,mu). Define rts to be the sum ! of these final state energies. Also, nparticles is the number of these ! final state particles. We define rts0 to be this "before showers" version ! of rts. If we later generate showers, we will overide these values. ! Look for "! Here we redefine rts, kcut(i,0), kf(i,mu), and nparticles." ! DO i = 1,cut%ncut kcut(i,0) = absk(cut%cutindex(i)) END DO nparticles = cut%ncut rts = 0.0d0 DO i = 1,nparticles DO mu = 0,3 kf(i,mu) = kcut(i,mu) END DO rts = rts + kf(i,0) END DO rts0 = rts mumsbar = muoverrts * rts0 ! The renormalization scale. ! ! Record starting values for the shower list. If we are not doing showering, ! just a plain purturbative calculation, then hrothgar will get this ! shower list as the representation of the final state. ! ! If we do generate showers, the variable onemthrust ! controls the width of showers generated by makeshowerII from ! graph%order.EQ.2 graphs and also the limit on 'soft' gluons in makeshowerI. ! Also, we need the soft scale and (1 - thrust). Here is where msoftsq ! is set, with a standard parameter msoftfactor set above. ! onemthrust = (1.0d0 - thrust(kf,nparticles)) IF (report) then write(nout,*)"1 - thrust before showering is ",onemthrust END IF msoftsq = (msoftfactor*rts0*onemthrust)**2 ! theshower%length = cut%ncut theshower%nstrings = 7777 ! This will be changed. theshower%rts0 = rts0 theshower%onemthrust = onemthrust theshower%msoftsq = msoftsq theshower%multfactor = 1.0d0 ! This will be changed. theshower%pii = 0 ! This will be changed. theshower%pjj = 0 ! This will be changed. DO n = 1,theshower%length partontype = flavorset%type(cut%cutindex(n)) partonflavor = flavorset%flavor(cut%cutindex(n)) IF (cut%cutsign(n).EQ.-1) THEN partonflavor = - partonflavor IF (partontype.EQ.'quark') THEN partontype = 'qbar ' ELSE IF (partontype.EQ.'qbar ') THEN partontype = 'quark' END IF END IF theshower%ptn(n)%type = partontype theshower%ptn(n)%flavor = partonflavor theshower%ptn(n)%stringquark = 500 ! If we make showers, this will change. theshower%ptn(n)%stringqbar = 500 ! If we make showers, this will change. ! theshower%ptn(n)%self = n theshower%ptn(n)%parent = 0 theshower%ptn(n)%ancestor = n theshower%ptn(n)%child1 = -1 theshower%ptn(n)%child2 = -1 theshower%ptn(n)%childless = .true. theshower%ptn(n)%done = .false. DO mu = 1,3 theshower%ptn(n)%momentum(mu) = kcut(n,mu) END DO IF (onemthrust.LT.onemthrustcrit) THEN ! default is onemthrustcrit = 0.05 ! for graph%order.EQ.1, theshower%ptn(n)%kappasq, n=1,2,3, is not used. theshower%ptn(n)%kappasq = kcut(n,0)**2 * onemthrust**2/onemthrustcrit ELSE theshower%ptn(n)%kappasq = kcut(n,0)**2 * onemthrust ENDIF END DO ! IF ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) THEN ! ! Firt, string analysis for three parton final states. ! IF (theshower%length.EQ.3) THEN theshower%nstrings = 2 + 500 ! The 500 is to give strings labels 500 + n. DO n = 1,3 IF (theshower%ptn(n)%type.EQ.'gluon') THEN theshower%ptn(n)%stringquark = 502 theshower%ptn(n)%stringqbar = 501 ELSE IF (theshower%ptn(n)%type.EQ.'quark') THEN theshower%ptn(n)%stringquark = 501 theshower%ptn(n)%stringqbar = 0 ELSE IF (theshower%ptn(n)%type.EQ.'qbar ') THEN theshower%ptn(n)%stringquark = 0 theshower%ptn(n)%stringqbar = 502 ELSE write(nout,*)'Confused about parton type in calculate. ',partontype STOP END IF END DO END IF ! (theshower%length.EQ.3) ! ! String analysis for four parton final states. ! IF (theshower%length.EQ.4) THEN theshower%nstrings = 3 + 500 ! The 500 is to give strings labels 500 + n. call getcolors(graph%graphnumber,flavorset%setnumber, & cut%cutnumber,strings) theshower%ptn(1)%stringquark = strings(1) theshower%ptn(1)%stringqbar = strings(2) theshower%ptn(2)%stringquark = strings(3) theshower%ptn(2)%stringqbar = strings(4) theshower%ptn(3)%stringquark = strings(5) theshower%ptn(3)%stringqbar = strings(6) theshower%ptn(4)%stringquark = strings(7) theshower%ptn(4)%stringqbar = strings(8) END IF ! (theshower%length.EQ.4) ! IF (graph%order.EQ.1) THEN ! ! We will create showering. ! ! For each of the final hard state partons i = 1,2,3, we need its parton type, ! which we call softinfos(i)%type0. We also need the types of ! the other two, which we call softinfos(i)%type1 and softinfos(i)%type2 ! and we need the cosine of the angle from the direction of parton i to the ! directions of these two other partons, which we call softinfos(i)%cos1 ! and softinfo(i)s%cos2. This information will be used for the soft gluon ! subtractions. We use the starting values of the final state momenta for ! this, with exact three body kinematics. ! DO i = 1,3 DO j = i+1,3 cosine(i,j) = 0.0d0 DO mu = 1,3 cosine(i,j) = cosine(i,j) + kcut(i,mu) * kcut(j,mu) END DO cosine(i,j) = cosine(i,j)/kcut(i,0)/kcut(j,0) cosine(j,i) = cosine(i,j) END DO END DO ! DO i = 1,3 j1 = mod(i,3) + 1 ! 1 -> 2, 2 -> 3, 3 -> 1 j2 = mod(i+1,3) + 1 ! 1 -> 3, 2 -> 1, 3 -> 2 softinfos(i)%cos1 = cosine(i,j1) softinfos(i)%cos2 = cosine(i,j2) softinfos(i)%type0 = theshower%ptn(i)%type softinfos(i)%type1 = theshower%ptn(j1)%type softinfos(i)%type2 = theshower%ptn(j2)%type softinfos(i)%msoftsq = theshower%msoftsq END DO ! call softradiate(theshower) ! Radiate a soft gluon ! Note that subroutine softradiate has shifted the parton momenta ! so we modify kcut accordingly. DO i = 1,4 DO mu = 1,3 kcut(i,mu) = theshower%ptn(i)%momentum(mu) END DO END DO ! call makeshowerI(theshower,softinfos) ! First splittings. IF (mode.EQ.'showerII') THEN call makeshowerII(theshower) ! Shower with small angle approx. END IF ELSE ! Order is 2. We make a shower from the final state particles, but ! only if we have enabled soft gluon subtractions, or else cancellations ! will fail. IF (mode.EQ.'showerII') THEN call makeshowerII(theshower) ! Shower with small angle approx. END IF END IF ! ! Now we have a primary shower if the graph was first order plus a ! secondary shower if desired. We need to find the final state partons. ! kf(i,mu) is the four-momentum of the ith final state parton. We ! compute rts as the sum of the energies of all the final state partons. ! Also, we compute the energy, kcut(j,0) of the jth original cut ! parton as sum of the energies of its descendants in the final state. ! Here we redefine rts, kcut(i,0), kf(i,mu), and nparticles. ! rts = 0.0d0 DO i = 1,cut%ncut kcut(i,0) = 0.0d0 END DO IF (graph%order.EQ.1) THEN kcut(4,0) = 0.0d0 ! initialization also for the extra soft gluon. END IF i = 0 DO n = 1,theshower%length IF (theshower%ptn(n)%childless) THEN i = i+1 temp = 0.0d0 DO mu = 1,3 kf(i,mu) = theshower%ptn(n)%momentum(mu) temp = temp + kf(i,mu)**2 END DO temp = sqrt(temp) kf(i,0) = temp rts = rts + temp j = theshower%ptn(n)%ancestor kcut(j,0) = kcut(j,0) + temp END IF END DO nparticles = i ! IF (report) then write(nout,*)"1 - thrust after showering is ", & (1.0d0 - thrust(kf,nparticles)) END IF ! ! We also calculate momenta koff(p,mu), which is like k(p,mu) except that ! the final state particles are given energies equal to the total energy ! of the shower that originates from that particle and the momentum of ! the soft gluon shower is appropriately routed. This is only for the ! Born graphs. ! IF (graph%order.EQ.1) THEN call findkoff(graph%graphnumber,cut,kcut,theshower%pii,theshower%pjj,koff) DO mu = 1,3 IF (abs(koff(0,mu)).GT.1.0d-12) THEN write(nout,*)'Something is rotten in findkoff.', & graph%graphnumber,cut%cutindex,theshower%pii,theshower%pjj stop END IF END DO IF ( abs(rts - koff(0,0)).GT.1.0d-8 ) THEN write(nout,*)'Oops, the calculation of rts did not work.',rts,koff(0,0) stop END IF END IF ! (graph%order.EQ.1) ! END IF ! ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) ! calsval = cals0(nparticles,kf) prefactor = 1.0d0 / (nc * rts**2 * (2.0d0 * pi)**nloops ) ! IF (mode.EQ.'born ') THEN prefactor = prefactor * alpi(muoverrts*externalrts) ELSE IF (mode.EQ.'nlo ') THEN prefactor = prefactor * alpi(muoverrts*externalrts)**graph%order ELSE IF (mode.EQ.'hocoef ') THEN continue ELSE IF ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) THEN prefactor = prefactor * alpi(muoverrts*externalrts)**graph%order IF (graph%graphnumber.EQ.9) THEN prefactor = prefactor * graph9factor END IF IF (graph%order.EQ.1) THEN prefactor = prefactor*theshower%multfactor prefactor0 = prefactor ! Use this to modify prefactor for graph 11. END IF ELSE write(nout,*)'calculate not programmed for this mode. ',mode stop END IF ! ! Calculate momenta around loop (if any). In case NINLOOP = 0, this ! DO loop is skipped. ! DO j = 1,cut%ninloop DO mu = 1,3 kinloop(j,mu) = cut%loopsign(j) * k(cut%loopindex(j),mu) END DO END DO ! ! Please note that at this point the energy in the loop, KINLOOP(J,0), ! is not calculated. We have to wait until we have a loop cut to ! do this. ! ! Now KINLOOP(J,MU) gets an imaginary part for MU = 1,2,3. ! DEFORM calculates NEWKINLOOP and the associated jacobian, JACDEFORM. ! In case NINLOOP = 0, this subroutine just returns NEWKINLOOP(MU) = 0 ! and JACDEFORM = 1. ! call deform(graph%vrtx,cut%loopindex,rts,cut%leftloop,cut%rightloop, & cut%ninloop,kinloop,newkinloop,jacdeform) ! ! If there is a loop, we need to go around the loop and generate ! a "loopcut." There are four cases. ! ! 1) NINLOOP = 0, with NCUT = CUTMAX. ! Then we are ready to proceed, and we should calculate only once ! before going back to NEWCUT. Therefore we set CALCMORE to .FALSE. ! so that we do not enter this code again. ! ! In the other three cases, there is a loop with NINLOOP = 2, 3, or 4. ! We generate a loopcut specified by the index JCUT = 1, 2, ... around ! the loop: CUTINDEX(CUTMAX) = LOOPINDEX(JCUT). ! ! 2) NINLOOP = 2, with NCUT = CUTMAX - 1. ! Then the loop is a self-energy subgraph and, with our dispersive ! treatment of these graphs, there is one term. We need to calculate ! energies, so we put JCUT = 1, but this is just a convention: the ! choice JCUT = 1 or 2 affects only the energy in the loop and the ! two point function depends only on the 3-momentum in the loop. ! ! 3) NINLOOP = 3, with NCUT = CUTMAX - 1. ! We will go around the loop twice with JCUT = 1,2,3 and then ! with JCUT = 1,2,3 again. We set CUTSIGN(CUTMAX) = LOOPSIGN(JCUT) ! the first time and CUTSIGN(CUTMAX) = - LOOPSIGN(JCUT) the second time. ! This corresponds to doing the energy integral with the contour closed in ! the upper half plane and also in the lower half plane. We *average* over ! the two sign choices, so we will need to multiply FEYNMAN by 1/2 for ! NINLOOP = 3. When we are done with this we set CALCMORE to .FALSE. . ! We will also need the renormaliztion counter term. This is done at the ! end. Before the IF(calcmore)... loop is closed, we test for calcmore ! and if it is false we check whether graph%order is 2 and cut%ninloop ! is 3. If so, we calculate and add the counter term. There is a flag ! for this purpose: if flag = ' no flag set', then the functions ! fenyman and feynmanf calculate the normal terms, but if ! flag = 'renormalize 3 pt', these functions calculate the counter terms. ! ! 3) NINLOOP = 4, with NCUT = CUTMAX - 1. ! We will go around the loop twice with JCUT = 1,2,3,4 and then with ! JCUT = 1,2,3,4 again. We set CUTSIGN(CUTMAX) = LOOPSIGN(JCUT) the first ! time and CUTSIGN(CUTMAX) = - LOOPSIGN(JCUT) the second time. This ! corresponds to doing the energy integral with the contour closed in the ! upper half plane and also in the lower half plane. We *average* over the ! two sign choices, so we will need to multiply FEYNMAN by 1/2 for ! NINLOOP = 4. When we are done with this we set CALCMORE to .FALSE. . ! ! We initialize the weight, then add to it the contributions from ! each pass through this loop. In the last pass, we also add the ! renormalization counter term to the weight, if appropriate. ! weight = 0.0d0 maxweight = 0.0d0 ! index = 1 ! to count where we are calcmore = .true. ! DO WHILE (calcmore) ! IF (cut%ninloop.EQ.0) THEN calcmore = .false. ELSE IF (cut%ninloop.EQ.2) THEN jcut = 1 cut%cutindex(cutmax) = cut%loopindex(jcut) cut%cutsign(cutmax) = cut%loopsign(jcut) loopcutsign = 1 calcmore = .false. ELSE IF (cut%ninloop.EQ.3) THEN IF (index.LE.3) THEN jcut = index cut%cutindex(cutmax) = cut%loopindex(jcut) cut%cutsign(cutmax) = cut%loopsign(jcut) loopcutsign = 1 ELSE jcut = index - 3 cut%cutindex(cutmax) = cut%loopindex(jcut) cut%cutsign(cutmax) = - cut%loopsign(jcut) loopcutsign = -1 END IF index = index + 1 IF (index.GT.6) THEN calcmore = .false. END IF ELSE IF (cut%ninloop.EQ.4) THEN IF (index.LE.4) THEN jcut = index cut%cutindex(cutmax) = cut%loopindex(jcut) cut%cutsign(cutmax) = cut%loopsign(jcut) loopcutsign = 1 ELSE jcut = index - 4 cut%cutindex(cutmax) = cut%loopindex(jcut) cut%cutsign(cutmax) = - cut%loopsign(jcut) loopcutsign = -1 END IF index = index + 1 IF (index.GT.8) THEN calcmore = .false. END IF ELSE write(nout,*)'Impossible case in calculate.' stop END IF ! ! Calculate matrix AE(P,I) relating propagator energies to energies of ! cut lines. NOTE that the index I here is displaced by 1. ! DO i = 0,nloops qe(i) = cut%cutindex(i+1) END DO call finda(graph%vrtx,qe,nloops,graph%order,ae,qok) IF (.NOT.qok) THEN write(nout,*)'ae not found.' write(nout,*)'Graph number',graph%graphnumber,' cut number',cut%cutnumber write(nout,*) qe stop END IF ! ! Define logical cut variables: ! cutQ(P) = .TRUE. if propagator P crosses the final state cut ! OR if it crosses the loopcut. ! DO p = 1,nprops cutQ(p) = .false. END DO DO i = 1,cutmax cutQ(cut%cutindex(i)) = .true. END DO ! ! Calculate part of the propagator energies corresponding to the ! real part of the loop three-momenta. Here we calculate for with the ! energy of each final state particle from the original graph set ! equal to the absolute value of its momentum. That is, the mass of ! the shower originating from this particle (if any) is neglected. ! ! Note that i is displaced by 1 in the e(i) array in order to work with ! the matrix AE(p,i), for which i should run from 0 to cutmax - 1. ! DO i = 1,cutmax e(i-1) = cut%cutsign(i) * absk(cut%cutindex(i)) END DO ! DO p = 0,nprops k(p,0) = 0.0d0 DO i = 0,nloops k(p,0) = k(p,0) + ae(p,i) * e(i) END DO END DO IF ( abs(rts0 - k(0,0)).GT.1.0d-8 ) THEN write(nout,*)'Oops, the calculation of rts0 did not work.',rts0,k(0,0) stop END IF ! ! Calculate the added complex loop energy. Check that we do not ! cross the cut of Sqrt(ELLSQ) by using COMPLEXSQRT(ELLSQ). ! IF (cut%ninloop.GT.0) THEN kinloop(jcut,0) = cut%loopsign(jcut) * k(cut%loopindex(jcut),0) ellsq = (0.0d0,0.0d0) DO mu = 1,3 ellsq = ellsq + ( kinloop(jcut,mu) + newkinloop(mu) )**2 END DO ell = complexsqrt(ellsq) newkinloop(0) = loopcutsign*ell - kinloop(jcut,0) ELSE newkinloop(0) = (0.0d0,0.0d0) END IF !.... IF (report) THEN IF( details .AND. (cut%ninloop.GT.0) ) THEN write(nout,340)newkinloop(0),xximag(newkinloop(1)), & xximag(newkinloop(2)),xximag(newkinloop(3)) 340 format('newkinloop =',2(1p g12.3),' and',3(1p g12.3)) END IF END IF !'''' ! Now we calculate the complex propagator momenta, kc(p,mu). These are ! based on k(p,mu) for which the energy of each final state particle ! from the original graph is set equal to the absolute value of its ! momentum. ! DO p = 0,nprops DO mu = 0,3 kc(p,mu) = k(p,mu) END DO END DO ! DO j = 1,cut%ninloop DO mu = 0,3 kc(cut%loopindex(j),mu) = kc(cut%loopindex(j),mu) & + cut%loopsign(j) * newkinloop(mu) END DO END DO ! IF ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) THEN ! ! There are some preliminary calculations for the case of shower mode. ! ! First, we multiply by factor F_j for showers for the first Born ! graph, graphnumber 11. To compute F_j, we use momenta kcut(i,mu), ! which represent the momenta of the final state particles 1,2,3,4 ! including the showers that develop from them. The graph structure ! for graph 11 is that particles 1 and 2 form a self cut energy ! subdiagram, particle 3 is the third hard parton in the Born graph ! and particle 4 is the soft gluon. We use the momentum of particle 4 ! in the calculation of F_j if it forms a self-energy subdiagram. ! Then we add it as a soft parton and subtract the same diagram ! from the splitting, so we want to treat it kinematically just ! like a splitting. ! IF (graph%graphnumber.EQ.11) THEN IF ((cut%cutindex(1).NE.5).OR. & (cut%cutindex(2).NE.4).OR. & (cut%cutindex(3).NE.1)) THEN write(nout,*)'Bad labelling in F_j calculation' stop END IF k1sq = 0.0d0 k2sq = 0.0d0 IF ( (theshower%pii.EQ.1).AND.(theshower%pjj.EQ.1) ) THEN DO mu = 0,3 k1sq = k1sq + kcut(3,mu)**2 * metric(mu) k2sq = k2sq + (kcut(1,mu) + kcut(2,mu) + kcut(4,mu))**2 * metric(mu) END DO ELSE IF ( (theshower%pii.EQ.2).AND.(theshower%pjj.EQ.2) ) THEN DO mu = 0,3 k1sq = k1sq + kcut(3,mu)**2 * metric(mu) k2sq = k2sq + (kcut(1,mu) + kcut(2,mu) + kcut(4,mu))**2 * metric(mu) END DO ELSE IF ( (theshower%pii.EQ.3).AND.(theshower%pjj.EQ.3) ) THEN DO mu = 0,3 k1sq = k1sq + (kcut(3,mu) + kcut(4,mu))**2 * metric(mu) k2sq = k2sq + (kcut(1,mu) + kcut(2,mu))**2 * metric(mu) END DO ELSE DO mu = 0,3 k1sq = k1sq + kcut(3,mu)**2 * metric(mu) k2sq = k2sq + (kcut(1,mu) + kcut(2,mu))**2 * metric(mu) END DO END IF prefactor = prefactor0 * k2sq**2/(k1sq**2 + k2sq**2) END IF ! IF (graph%order.EQ.1) THEN ! ! Calculate tglue, vquark, vqbar, which are needed for the first ! level of showering from a Born graph. ! DO n0=1,3 ! We want the three hard partons. qvec = theshower%ptn(n0)%momentum n1 = theshower%ptn(n0)%child1 n2 = theshower%ptn(n0)%child2 f1 = theshower%ptn(n1)%type f2 = theshower%ptn(n2)%type kplusvec = theshower%ptn(n1)%momentum kminusvec = theshower%ptn(n2)%momentum ! We need the softinfo for parton n0. We can tell by its type. nfound = 0 DO j = 1,3 IF (softinfos(j)%type0.EQ.theshower%ptn(n0)%type) THEN nfound = nfound + 1 softinfo = softinfos(j) END IF END DO IF (nfound.NE.1) THEN write(nout,*) 'Oops, types messed up in the shower' STOP END IF IF (theshower%ptn(n0)%type.EQ.'gluon') THEN IF ((f1.EQ.'quark').AND.(f2.EQ.'qbar ')) THEN kind2pt = 'quarkloop' ELSE IF ((f1.EQ.'gluon').AND.(f2.EQ.'gluon')) THEN kind2pt = 'gluonloop' ELSE write(nout,*)'Oops, that parton type combination should not exist.' STOP END IF call showerglueprop(kind2pt,softinfo,qvec,kplusvec,kminusvec,tglue) ELSE IF (theshower%ptn(n0)%type.EQ.'quark') THEN IF (.NOT.(f1.EQ.'gluon').AND.(f2.EQ.'quark')) THEN write(nout,*)'Oops, that parton type combination should not exist.' STOP END IF call showerquarkprop(softinfo,qvec,kplusvec,kminusvec,vquark) ELSE IF (theshower%ptn(n0)%type.EQ.'qbar ') THEN IF (.NOT.(f1.EQ.'gluon').AND.(f2.EQ.'qbar ')) THEN write(nout,*)'Oops, that parton type combination should not exist.' STOP END IF call showerquarkprop(softinfo,qvec,kplusvec,kminusvec,vqbar) DO mu = 0,3 vqbar(mu) = - vqbar(mu) END DO ELSE write(nout,*)'The parton type must be gluon, quark, or qbar.' STOP END IF END DO ! Close DO n0=1,3 ! END IF ! (graph%order.EQ.1) END IF ! ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) ! ! Calculate graph and add to contribution for this point. ! IF (graph%order.EQ.2) THEN flag = ' no flag set' ! This is not a counter-term. IF (gauge.EQ.'feynman') THEN feynmanval = feynmanf(graph%graphnumber,kc,cutQ,mumsbar,flag) ELSE IF (gauge.EQ.'coulomb') THEN feynmanval = & feynman(graph%graphnumber,flavorset%setnumber,kc,cutQ,mumsbar,flag) ELSE write(nout,*)'That gauge does not exist.' stop END IF ELSE IF (graph%order.EQ.1) THEN ! ! There are a lot of alternatives in the case of a Born graph. ! IF (gauge.EQ.'feynman') THEN ! ! This gets the Feynman gauge matrix element squared. ! feynmanval = feynman0f(graph%graphnumber,k,cutQ) ! ELSE IF (gauge.EQ.'coulomb') THEN ! IF ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) THEN ! ! We have previously calculated vquark,vqbar, and tglue. ! Here we use koff(p,mu) which is like k(p,mu) except that ! the final state particles are given energies equal to the total ! energy of the shower that originates from that particle. ! This gets the appropriate matrix element squared with a one ! level shower. ! feynmanval = feynmanSH0(graph%graphnumber,flavorset%setnumber, & koff,cutQ,vquark,vqbar,tglue) ELSE ! ! We have Coulomb gauge but not mode .EQ. 'showerI' or 'showerII'. ! This gets the Coulomb gauge matrix element squared. ! feynmanval = & feynman0(graph%graphnumber,flavorset%setnumber,k,cutQ) ! ! Close IF ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) THEN ... ELSE ... ! END IF ! ELSE write(nout,*)'That gauge does not exist.' stop ! ! Close ! IF (gauge.EQ.'feynman') THEN ... ! ELSE IF (gauge.EQ.'coulomb') THEN ... ! ELSE ... END IF ELSE write(nout,*)'Order should have been 1 or 2.' stop ! ! Close !IF (graph%order.EQ.2) THEN ... !ELSE IF (graph%order.EQ.1) THEN ... !ELSE END IF ! integrand = prefactor * jacnewpoint * jacdeform * feynmanval * smear(rts) ! ! If we have a 3 or 4 point virtual loop, then we are averaging over ! closing the energy integral contour in the upper and lower ! half planes and we supply a 1/2. ! IF (cut%ninloop.GT.2) THEN integrand = 0.5d0*integrand END IF ! maxweight = max(maxweight,abs(xxreal(integrand))) weight = weight + xxreal(integrand) ! integrand = integrand * calsval maxpart = max(maxpart,abs(xxreal(integrand))) value = value + integrand !.... IF (report) THEN IF (details) THEN write(nout,370) 370 format('prefactor * jacnewpoint * (jacdeform-r jacdeform-i) * ', & ' (feynman-r feynman-i) * calsval * smear(rts)') write(nout,371)prefactor,jacnewpoint,jacdeform, & feynmanval,calsval,smear(rts) 371 format(9(1p g12.3)) END IF IF (cut%ninloop.GT.0) THEN write(nout,372)cut%loopindex(jcut),integrand*groupsizetotal 372 format(i3,' contribution:',2(1p g18.10)) ELSE write(nout,373)integrand*groupsizetotal 373 format(' contribution:',2(1p g18.10)) END IF IF (details) THEN write(nout,*)' ' END IF END IF !'''' ! ! Compute a known integral to see if we have it right. ! Subroutine CHECKCALC calculates CHECK. ! IF (flavorset%setnumber.EQ.1) THEN IF (flag.NE.'renormalize 3 pt') THEN call & checkcalc(graph%graphnumber,cut%cutindex,kc,jacnewpoint,jacdeform,check) IF (cut%ninloop.GT.2) THEN check = 0.5d0*check END IF valuechk = valuechk + check END IF END IF ! ! IF(.NOT.calcmore) THEN ! ! We are almost done with this cut. However, there may be a renormalization ! counter term and/or a soft subtraction needed. ! !.... IF (report) THEN write(nout,341)weight*calsval*groupsizetotal 341 format(' cut total so far:',1p g18.10) IF (graph%order.EQ.1) THEN write(nout,*)'Point:' DO p=1,nprops write(nout,1703) p,koff(p,0),koff(p,1),koff(p,2),koff(p,3) 1703 format('p =',i2,' koff = ',4(1p g12.3)) END DO write(nout,*)'pii = ',theshower%pii,' pjj = ',theshower%pjj write(nout,1704) kcut(4,0),kcut(4,1),kcut(4,2),kcut(4,3) 1704 format('kcut(4,mu) = ',4(1p g12.3)) END IF END IF !.... ! IF (graph%order.EQ.2) THEN IF (cut%ninloop.EQ.3) THEN ! ! We need the renormalization counter term: ! flag = 'renormalize 3 pt' IF (gauge.EQ.'feynman') THEN feynmanval = feynmanf(graph%graphnumber,kc,cutQ,mumsbar,flag) ELSE IF (gauge.EQ.'coulomb') THEN feynmanval = & feynman(graph%graphnumber,flavorset%setnumber,kc,cutQ,mumsbar,flag) ELSE write(nout,*)'That gauge does not exist.' stop END IF integrand = prefactor * jacnewpoint * jacdeform * feynmanval * smear(rts) maxweight = max(maxweight,abs(xxreal(integrand))) weight = weight + xxreal(integrand) integrand = integrand * calsval maxpart = max(maxpart,abs(xxreal(integrand))) value = value + integrand !.... IF (report) THEN IF (details) THEN write(nout,370) write(nout,371)prefactor,jacnewpoint,jacdeform, & feynmanval,calsval,smear(rts) END IF write(nout,374)integrand*groupsizetotal 374 format(' uv counter term:',2(1p g18.10)) write(nout,341)weight*calsval*groupsizetotal END IF !'''' ! END IF ! (cut%ninloop.EQ.3) ! IF ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) THEN ! ! We need the soft subtraction: ! feynmanval = softsubtraction(k,absk, & graph%graphnumber,flavorset%setnumber,cut%cutnumber) integrand = prefactor * jacnewpoint * feynmanval * smear(rts) maxweight = max(maxweight,abs(xxreal(integrand))) weight = weight + xxreal(integrand) integrand = integrand * calsval maxpart = max(maxpart,abs(xxreal(integrand))) value = value + integrand !.... IF (report) THEN IF (details) THEN write(nout,416) 416 format('prefactor * jacnewpoint *', & ' (feynman-r feynman-i) * calsval * smear(rts)') write(nout,417)prefactor,jacnewpoint,feynmanval,calsval,smear(rts) 417 format(7(1p g12.3)) END IF write(nout,375)integrand*groupsizetotal 375 format(' soft subtraction:',2(1p g18.10)) write(nout,341)weight*calsval*groupsizetotal END IF !.... END IF ! ((mode.EQ.'showerI ').OR.(mode.EQ.'showerII')) ! END IF ! (graph%order.EQ.2) ! END IF ! (.NOT.calcmore) ! ! End of loop DO WHILE (CALCMORE) that runs over loopcuts. ! END DO ! ! We are ready to call Hrothgar to process the result for this cut. ! call hrothgar(theshower,weight,1,'newresult ') ! ! Close loop DO ... call getnewcut(); IF (.NOT.cutfound) EXIT ! END DO ! ! Close loop DO with call getnewflavorset(); IF (.NOT.flavorsetfound) EXIT ! for Coulomb gauge. ! IF (gauge.EQ.'feynman') EXIT END DO ! RETURN END subroutine calculate ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! End of subroutine to calculate integrand !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine & checkcalc(graphnumber,cutindex,kc,jacnewpoint,jacdeform,check) ! use beowulf_parameters implicit none ! In: integer :: graphnumber,cutindex(size+1) complex(kind=dbl) :: kc(0:3*size-1,0:3) real(kind=dbl) :: jacnewpoint complex(kind=dbl) :: jacdeform ! Out: complex(kind=dbl) :: check ! ! Compute a known integral to see if we have it right. ! This subroutine calculates the integrand. ! The check is based on ! Int d^3 p [p^2 + M^2]^(-3) = Pi^2/ (4 M^3). ! Int d^3 p [p^2 (p^2 + M^2)]^(-1) = 2 Pi^2 /M ! Note that we look at just one term in the sum over cuts ! and loopcuts: ! For graph 10, we take Cutindex = (7,5,4,1); ! For graph 8, we take Cutindex = (8,6,4,1), etc. ! ! Latest modification: 11 February 2002. ! ! Reno size and counting variables: integer :: groupsize(maxgraphs,maxmaps) integer :: groupsizegraph(maxgraphs) integer :: groupsizetotal common /montecarlo/groupsize,groupsizegraph,groupsizetotal ! real(kind=dbl), parameter :: mm = 3.0d-1 real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! complex(kind=dbl) :: temp1,temp2,temp3 integer :: mu ! ! If it is not the right graph and the right cut, this default ! value will be returned. ! check = (0.0d0,0.0d0) ! temp1 = 0.0d0 temp2 = 0.0d0 temp3 = 0.0d0 ! IF (graphnumber.EQ.12) THEN ! IF ( (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) & .AND.(cutindex(3).EQ.1) ) THEN DO mu = 1,3 temp1 = temp1 + kc(5,mu)*kc(5,mu) temp2 = temp2 + kc(4,mu)*kc(4,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.11) THEN ! IF ( (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) & .AND.(cutindex(3).EQ.1) ) THEN DO mu = 1,3 temp1 = temp1 + kc(5,mu)*kc(5,mu) temp2 = temp2 + kc(4,mu)*kc(4,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.10) THEN ! IF ( (cutindex(1).EQ.7).AND.(cutindex(2).EQ.5) & .AND.(cutindex(3).EQ.4).AND.(cutindex(4).EQ.1) ) THEN DO mu = 1,3 temp1 = temp1 + kc(7,mu)*kc(7,mu) temp2 = temp2 + kc(6,mu)*kc(6,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.9) THEN ! IF ( (cutindex(1).EQ.8).AND.(cutindex(2).EQ.7) & .AND.(cutindex(3).EQ.3).AND.(cutindex(4).EQ.5) ) THEN DO mu = 1,3 temp1 = temp1 + kc(8,mu)*kc(8,mu) temp2 = temp2 + kc(6,mu)*kc(6,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.8) THEN ! IF ( (cutindex(1).EQ.8).AND.(cutindex(2).EQ.6) & .AND.(cutindex(3).EQ.4).AND.(cutindex(4).EQ.1) ) THEN DO mu = 1,3 temp1 = temp1 + kc(5,mu)*kc(5,mu) temp2 = temp2 + kc(8,mu)*kc(8,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.7) THEN ! IF ( (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) & .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.6) ) THEN DO mu = 1,3 temp1 = temp1 + kc(5,mu)*kc(5,mu) temp2 = temp2 + kc(7,mu)*kc(7,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.6) THEN ! IF ( (cutindex(1).EQ.8).AND.(cutindex(2).EQ.5) & .AND.(cutindex(3).EQ.3).AND.(cutindex(4).EQ.6) ) THEN DO mu = 1,3 temp1 = temp1 + kc(5,mu)*kc(5,mu) temp2 = temp2 + kc(7,mu)*kc(7,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.5) THEN ! IF ( (cutindex(1).EQ.8).AND.(cutindex(2).EQ.7) & .AND.(cutindex(3).EQ.3).AND.(cutindex(4).EQ.1) ) THEN DO mu = 1,3 temp1 = temp1 + kc(5,mu)*kc(5,mu) temp2 = temp2 + kc(8,mu)*kc(8,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.4) THEN ! IF ( (cutindex(1).EQ.6).AND.(cutindex(2).EQ.4) & .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.7) ) THEN DO mu = 1,3 temp1 = temp1 + kc(7,mu)*kc(7,mu) temp2 = temp2 + kc(5,mu)*kc(5,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.3) THEN ! IF ( (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) & .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.6) ) THEN DO mu = 1,3 temp1 = temp1 + kc(7,mu)*kc(7,mu) temp2 = temp2 + kc(5,mu)*kc(5,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.2) THEN ! IF ( (cutindex(1).EQ.7).AND.(cutindex(2).EQ.6) & .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.4) ) THEN DO mu = 1,3 temp1 = temp1 + kc(7,mu)*kc(7,mu) temp2 = temp2 + kc(5,mu)*kc(5,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE IF (graphnumber.EQ.1) THEN ! IF ( (cutindex(1).EQ.5).AND.(cutindex(2).EQ.4) & .AND.(cutindex(3).EQ.1).AND.(cutindex(4).EQ.7) ) THEN DO mu = 1,3 temp1 = temp1 + kc(7,mu)*kc(7,mu) temp2 = temp2 + kc(5,mu)*kc(5,mu) temp3 = temp3 + kc(1,mu)*kc(1,mu) END DO ELSE RETURN END IF ! ELSE write(nout,*)'Problem with graph number in checkcalc.' stop END IF ! IF (graphnumber.LE.10) THEN ! ! Here is an infrared sensitive check integral: ! check = temp1 * (temp1 + mm**2) check = check * temp2 * (temp2 + mm**2) check = check * (temp3 + mm**2)**3 check = (mm**5/pi**6) /check ! ! Here is a nice smooth check integral: ! CHECK = (TEMP1 + MM**2)**3 ! CHECK = CHECK * (TEMP2 + MM**2)**3 ! CHECK = CHECK * (TEMP3 + (2.0D0*MM)**2)**3 ! CHECK = (512.0D0 * MM**9 / PI**6) /CHECK ! ELSE IF (graphnumber.LE.12) THEN ! check = (temp1 + mm**2)**3 check = check * (temp2 + mm**2)**3 check = (16.0d0 * mm**6 / pi**4) /check ! ELSE write(nout,*)'We were expecting graphnumbers 1,...,12.' stop END IF ! check = jacdeform * jacnewpoint * check ! ! Weight according to the number of points devoted to the current ! graph. ! check = check * groupsizegraph(graphnumber)/groupsizetotal ! RETURN END subroutine checkcalc ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function density(graphnumber,k,qs,qsigns,maptypes,nmaps,order) ! use beowulf_parameters implicit none ! In: integer :: graphnumber real(kind=dbl) :: k(0:3*size-1,0:3) integer :: qs(maxmaps,0:size),qsigns(maxmaps,0:size) character(len=6) :: maptypes(maxmaps) integer :: nmaps,order ! Out: real(kind=dbl) :: density ! ! Density of Monte Carlo points as a function of |K(p)|'s. ! ! 29 June 1993 ! 12 July 1993 ! 17 July 1994 ! 4 May 1996 ! 21 November 1996 ! 5 December 1996 ! 5 February 1997 ! 15 December 1998 ! 23 December 1998 ! 9 February 1999 ! 10 March 1999 ! 20 August 1999 ! 21 December 2000 ! 20 March 2001 ! 1 February 2002 ! 7 December 2002 ! integer :: nloops integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 integer :: groupsize(maxgraphs,maxmaps) integer :: groupsizegraph(maxgraphs) integer :: groupsizetotal common /montecarlo/groupsize,groupsizegraph,groupsizetotal ! integer :: mapnumber,l,mu real(kind=dbl) :: p1(3),p2(3),ell1(3),absp1,absp2,absp3 real(kind=dbl) :: temp1,temp2,temp3,p1sq,p2sq,p3sq character(len=6) :: maptype integer :: qsign(0:size),q(0:size) real(kind=dbl) :: rho3,rho2to3d,rho2to3e,rho2to2t,rho2to2s,rho2to1a,rho2to1b real(kind=dbl) :: rhothree,rholoop ! IF (order.EQ.1) THEN nloops = nloops1 ELSE IF (order.EQ.2) THEN nloops = nloops2 ELSE write(nout,*)'Order must be 1 or 2.',order END IF ! IF (order.EQ.1) THEN ! ! We deal with the case of a Born graph first. ! density = 0.0d0 DO mapnumber = 1,nmaps ! DO l = 0,nloops q(l) = qs(mapnumber,l) qsign(l) = qsigns(mapnumber,l) END DO p1sq = 0.0d0 p2sq = 0.0d0 p3sq = 0.0d0 DO mu = 1,3 temp1 = qsign(1)*k(q(1),mu) temp2 = qsign(2)*k(q(2),mu) temp3 = - temp1 - temp2 p1sq = p1sq + temp1**2 p2sq = p2sq + temp2**2 p3sq = p3sq + temp3**2 END DO absp1 = sqrt(p1sq) absp2 = sqrt(p2sq) absp3 = sqrt(p3sq) rhothree = rho3(absp1,absp2,absp3) density = density & + rhothree*groupsize(graphnumber,mapnumber) ! END DO ! ! Alternative for IF (ORDER.EQ.1) THEN ! ELSE IF (order.EQ.2) THEN ! ! We tackle the case of an order alpha_s^2 graph. ! We construct the density as a sum. ! density = 0.0d0 DO mapnumber = 1,nmaps ! maptype = maptypes(mapnumber) DO l = 0,nloops q(l) = qs(mapnumber,l) qsign(l) = qsigns(mapnumber,l) END DO ! ! First, we need the kinematic variables for this map. ! p1sq = 0.0d0 p2sq = 0.0d0 p3sq = 0.0d0 DO mu = 1,3 ell1(mu) = qsign(1)*k(q(1),mu) temp1 = qsign(2)*k(q(2),mu) temp2 = qsign(3)*k(q(3),mu) temp3 = - temp1 - temp2 p1(mu) = temp1 p1sq = p1sq + temp1**2 p2(mu) = temp2 p2sq = p2sq + temp2**2 p3sq = p3sq + temp3**2 END DO absp1 = sqrt(p1sq) absp2 = sqrt(p2sq) absp3 = sqrt(p3sq) ! ! Now, there are two factors, one for the 'final state momenta' and ! one for the 'loop momentum.' ! rhothree = rho3(absp1,absp2,absp3) ! IF (maptype.EQ.'t2to3d') THEN rholoop = rho2to3d(p1,p2,ell1) ELSE IF (maptype.EQ.'t2to3e') THEN rholoop = rho2to3e(p1,p2,ell1) ELSE IF (maptype.EQ.'t2to2t') THEN rholoop = rho2to2t(p1,p2,ell1) ELSE IF (maptype.EQ.'t2to2s') THEN rholoop = rho2to2s(p1,p2,ell1) ELSE IF (maptype.EQ.'t2to1a') THEN rholoop = rho2to1a(p1,p2,ell1) ELSE IF (maptype.EQ.'t2to1b') THEN rholoop = rho2to1b(p1,p2,ell1) ELSE write(nout,*)'Bad maptype in density.' stop END IF ! density = density & + rhothree*rholoop*groupsize(graphnumber,mapnumber) ! ! Close DO MAPNUMBER = 1,NMAPS ! END DO ! ! Close for IF (ORDER.EQ.1) THEN ... ELSE IF (ORDER.EQ.2) THEN ! ELSE write(nout,*)'Order should have been 1 or 2 in density.' stop END IF ! RETURN END function density ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! Subroutines associated with NEWPOINT and DENSITY ! CHOOSEx and RHOx where x = 3, 2to2T, 2to2S, 2to3D, 2to3E, 2to1A,2to1B !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine choose3(p1,p2,p3,ok) ! use beowulf_parameters implicit none ! Out: real(kind=dbl) :: p1(3),p2(3),p3(3) logical :: ok ! ! Generates momenta P1(mu),P2(mu),P3(mu) for a three body final ! state with a distribution in momentum fractions x1,x2,x3 ! proportional to ! ! [max(1-x1,1-x2,1-x3)]^B/[(1-x1)*(1-x2)*(1-x3)]^B. ! ! 28 December 2000 ! 16 January 2001 ! real(kind=dbl) :: badnesslimit,cancellimit,thrustcut common /limits/ badnesslimit,cancellimit,thrustcut real(kind=dbl), parameter :: onethird = 0.3333333333333333333d0 real(kind=dbl), parameter :: twothirds = 0.6666666666666666667d0 real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! ! The parameter E3PAR should match between CHOOSE3 and RHO3. ! real(kind=dbl), parameter :: e3par = 1.5d0 ! ! The parameters A, B, and C need to match between CHOOSE3 and RHO3. ! CHOOSE3 uses A, while RHO3 uses B and C. The relation is ! B = 1 - 1/A and then C is the normalization factor and is ! a rather complicated function of B. ! ! Some soft and collinear points: ! real(kind=dbl), parameter :: a = 2.0d0 real(kind=dbl), parameter :: b = 0.5d0 real(kind=dbl), parameter :: c = 0.0036376552621307193655d0 ! ! Lots of soft and collinear points: ! ! REAL*8 A,B,C ! PARAMETER(A = 4.0D0) ! PARAMETER(B = 0.75D0) ! PARAMETER(C = 0.00058417226323428314253D0) ! real(kind=dbl) :: x,random logical :: done integer :: mu real(kind=dbl) :: emax real(kind=dbl) :: x1,x2,x3,y1,y2,y3 real(kind=dbl) :: ea(3),eb(3),ec(3),ed(3) real(kind=dbl) :: phi,costheta,sintheta real(kind=dbl) :: k1(3),k2(3),k3(3) ! !---------- ! ok = .true. ! ! We will generate vectors K1(mu), K2(mu), K3(mu) with |K1| > |K3| and ! |K2| > |K3|. At the end, we will associate each Ki(mu) with a Pj(mu) ! with the index j of the Pj(mu) that matches K3(mu) chosen at random. ! ! We choose y1, y2, y3 in 0< y_i < 1 with y1 + y2 + y3 = 1. The y_i are ! related to the momentum fractions x_i by y_i = 1 - x_i. For the y_i, ! we want y3 to be the largest, with no specification about whether y1 ! or y2 is larger. We want to choose y1 and y2 with a 1/sqrt(y1*y2) ! distribution. Then y3 = 1 - y1 - y2. We must insure that y3 > y1 and ! y3 > y2 for the point to be valid. Note that the allowed region is ! inside the region 0 < y1 < 1/2, 0 < y2 < 1/2. If we choose a random ! variable x in 0 < x < 1 and define y = x**2/2 then the density dx/dy ! is proportional to 1/sqrt(y) and 0 < y < 1/2. ! ! We loop until we are "done" choosing a valid point. ! done = .false. DO WHILE (.NOT.done) x = random(1) y1 = 0.5d0 * x**a x = random(1) y2 = 0.5d0 * x**a y3 = 1.0d0 - y1 - y2 IF ((y1 .LT. y3).AND.(y2.LT.y3)) THEN done = .true. END IF END DO x1 = 1.0d0 - y1 x2 = 1.0d0 - y2 x3 = y1 + y2 ! ! If the chosen point is too soft or collinear, we will not be able ! to compute the kinematics for the rest of this subroutine ! or the other CHOOSEx subroutines, so we just abort. ! IF ( y1*y2.LT.(100.0d0*badnesslimit)**(-2) ) THEN DO mu = 1,3 p1(mu) = 0.0d0 p2(mu) = 0.0d0 p3(mu) = 0.0d0 END DO ok = .false. RETURN END IF ! ! Choose Emax = sum_i |p_i| /2. ! x = random(1) emax = e3par * ( 1.0d0/x - 1.0d0 )**onethird ! ! Choose a direction EA(mu) at random on the unit sphere. ! x = random(1) costheta = 2.0d0*x - 1.0d0 sintheta = sqrt(1.0d0 - costheta**2) x = random(1) phi = 2.0d0 * pi * x ea(1) = sintheta * cos(phi) ea(2) = sintheta * sin(phi) ea(3) = costheta ! ! Generate vectors EB and EC that form a right handed basis set with EA. ! call axes(ea,eb,ec) ! ! Generate a unit vector ED at a with a random azimuthal angle around ! the EA axis in this basis. ! x = random(1) phi = 2.0d0 * pi * x DO mu = 1,3 ed(mu) = cos(phi)*eb(mu) + sin(phi)*ec(mu) END DO ! ! Now construct the momenta. P1(mu) is directed in the random direction ! EA(mu) with magnitude determined from Emax and X1. Then P3(mu) ! is in the plane of EA(mu) and ED(mu) with angle THETA to P1(mu) ! determined from the Xi and magnitude determined by X2. ! costheta = 1.0d0 - 2.0d0*y2/x1/x3 sintheta = 2.0d0*sqrt(y1*y2*y3)/x1/x3 DO mu = 1,3 k1(mu) = x1*emax*ea(mu) k3(mu) = x3*emax*(costheta*ea(mu) + sintheta*ed(mu)) k2(mu) = - k1(mu) - k3(mu) END DO ! ! Match K3(mu) to one of the Pi(mu) at random. ! x = random(1) IF (x.GT.twothirds) THEN DO mu = 1,3 p1(mu) = k1(mu) p2(mu) = k2(mu) p3(mu) = k3(mu) END DO ELSE IF (x.GT.onethird) THEN DO mu = 1,3 p1(mu) = k2(mu) p2(mu) = k3(mu) p3(mu) = k1(mu) END DO ELSE DO mu = 1,3 p1(mu) = k3(mu) p2(mu) = k1(mu) p3(mu) = k2(mu) END DO END IF ! RETURN END subroutine choose3 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function rho3(absp1,absp2,absp3) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: absp1,absp2,absp3 ! Out: real(kind=dbl) :: rho3 ! ! ! Density of points for points chosen with CHOOSE3(p1,p2,p3,ok). ! 16 January 2001 ! real(kind=dbl) :: emax,x1,x2,x3 real(kind=dbl) :: e03,emax3,factor,denom ! ! The parameter E3PAR should match between CHOOSE3 and RHO3. ! real(kind=dbl), parameter :: e3par = 1.5d0 ! ! The parameters A, B, and C need to match between CHOOSE3 and RHO3. ! CHOOSE3 uses A, while RHO3 uses B and C. The relation is ! B = 1 - 1/A and then C is the normalization factor and is ! a rather complicated function of B. ! ! Some soft and collinear points: ! real(kind=dbl), parameter :: a = 2.0d0 real(kind=dbl), parameter :: b = 0.5d0 real(kind=dbl), parameter :: c = 0.0036376552621307193655d0 ! ! Lots of soft and collinear points: ! ! REAL*8 A,B,C ! PARAMETER(A = 4.0D0) ! PARAMETER(B = 0.75D0) ! PARAMETER(C = 0.00058417226323428314253D0) ! emax = 0.5d0*(absp1 + absp2 + absp3) x1 = absp1/emax x2 = absp2/emax x3 = absp3/emax ! IF (x1.LT.x2) THEN IF (x1.LT.x3) THEN ! X1 is smallest: X1 w = y*(Log(y)**2 - 2*Log(y) + 2). ! Function RANDOM(1) give a random number in the range 0 dr d costheta d phi ! rho2to3d = 1.0d0/r**2 ! ! Density for phi. ! rho2to3d = rho2to3d/(2.0d0 * pi) ! ! Density for theta. ! We construct 1 - cos(theta) as (Hatell1 - Nz)^2 /2 since ! that is more accurate than constructing cos(theta) and ! subtracting it from 1.0 if 1 - cos(theta) is small. ! v(1) = ell1(1)/r - nz(1) v(2) = ell1(2)/r - nz(2) v(3) = ell1(3)/r - nz(3) oneminuscos = 0.5d0*(v(1)**2 + v(2)**2 + v(3)**2) n = 1.0d0/log(1.0d0 + 2.0d0/sdiffsq) paramsq = oneminuscos + sdiffsq rho2to3d = rho2to3d * n/paramsq ! ! Density for r. ! deltasq = paramsq/9.0d0 param = sqrt(paramsq) delta = param/3.0d0 a = 1.0d0 + a2to3*deltasq b = 1.0d0 + a2to3*delta n = 1.0d0/log(a/(b*deltasq)) temp = abs(r/s - 1.0d0) denom = s*(temp + a2to3*deltasq)*(temp + a2to3*delta) rhor = a2to3*n*delta*(1.0d0 - delta)/denom rho2to3d = rho2to3d * rhor ! RETURN END function rho2to3d ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine choose2to3e(pa,pb,ell1,ok) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: pa(3),pb(3) ! Out: real(kind=dbl) :: ell1(3) logical :: ok ! ! Generates a point ell1(mu) using a circular coordinate system ! based on the vectors p_A(mu) and p_B(mu). The points are concentrated ! near the circle |ell1| = (|p_A| + |p_B| + |p_A + p_B|)/2. There is ! a special concentration near theta = 0, the direction of the largest ! of -p_A - p_B. ! ! 18 December 2000 ! 21 March 2001 ! ! ! The parameter A2TO3 needs to match between CHOOSE2TO3E and RHO2TO3E. ! real(kind=dbl), parameter :: a2to3 = 3.0d0 ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! ! Function EXPM1(x) gives exp(x) - 1. ! Function RANDOM(1) give a random number in the range 0 dr d costheta d phi ! rho2to3e = 1.0d0/r**2 ! ! Density for phi. ! rho2to3e = rho2to3e/(2.0d0 * pi) ! ! Density for theta. ! We construct 1 - cos(theta) as (Hatell1 - Nz)^2 /2 since ! that is more accurate than constructing cos(theta) and ! subtracting it from 1.0 if 1 - cos(theta) is small. ! v(1) = ell1(1)/r - nz(1) v(2) = ell1(2)/r - nz(2) v(3) = ell1(3)/r - nz(3) oneminuscos = 0.5d0*(v(1)**2 + v(2)**2 + v(3)**2) n = 1.0d0/log(1.0d0 + 2.0d0/sdiffsq) paramsq = oneminuscos + sdiffsq rho2to3e = rho2to3e * n/paramsq ! ! Density for r. ! deltasq = paramsq/9.0d0 param = sqrt(paramsq) delta = param/3.0d0 a = 1.0d0 + a2to3*deltasq b = 1.0d0 + a2to3*delta n = 1.0d0/log(a/(b*deltasq)) temp = abs(r/s - 1.0d0) denom = s*(temp + a2to3*deltasq)*(temp + a2to3*delta) rhor = a2to3*n*delta*(1.0d0 - delta)/denom rho2to3e = rho2to3e * rhor ! RETURN END function rho2to3e ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine choose2to1a(pa,pb,ell1,ok) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: pa(3),pb(3) ! Out: real(kind=dbl) :: ell1(3) logical :: ok ! ! Generates a point ell1(mu) for a self-energy graph that leads to a ! propagator with momemtum Pa(mu) that enters the final state. ! We want a map concentrating points rather collinearly with Pa(mu). ! ! 18 December 2000 ! 18 March 2001 ! ! ! The parameters B2TO1, C2TO1, A2TO1A and A2TO1B need to match ! between CHOOSE2TO1A and RHO2TO1A. ! real(kind=dbl), parameter :: b2to1 = 0.4d0 real(kind=dbl), parameter :: c2to1 = 0.4d0 real(kind=dbl), parameter :: a2to1a = 0.05d0 real(kind=dbl), parameter :: a2to1b = 0.25d0 ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! integer :: mu real(kind=dbl) :: pasq,abspa,pbsq,abspb,pcsq,abspc,scaleabc real(kind=dbl) :: ea(3),eb(3),ec(3) real(kind=dbl) :: random,xx,xchoice real(kind=dbl) :: costheta,sintheta,phi,r real(kind=dbl) :: x,ell1t ! !--------------- ! ok = .true. ! ! We need the appropriate unit vectors for the map. We create a unit ! vector EA(mu) in the direction of PA(mu). We also calculate a ! scale factor SCALEABC. ! pasq = 0.0d0 pbsq = 0.0d0 pcsq = 0.0d0 DO mu = 1,3 pasq = pasq + pa(mu)**2 pbsq = pbsq + pb(mu)**2 pcsq = pcsq + (pa(mu) + pb(mu))**2 END DO IF (pasq.LT.1.0d-30) THEN write(nout,*)'pasq too small in choose2to1.' write(nout,*)'pa ',pa write(nout,*)'ell1',ell1 ok = .false. END IF abspa = sqrt(pasq) abspb = sqrt(pbsq) abspc = sqrt(pbsq) DO mu = 1,3 ea(mu) = pa(mu)/abspa END DO scaleabc = (abspa + abspb + abspc)/3.0d0 ! call axes(ea,eb,ec) ! ! Step 2: Determine which of three methods to use to determine ! the next point. ! xchoice = random(1) ! IF (xchoice.LT.a2to1a) THEN ! ! We want a map concentrating points near ell1 = 0. ! phi = 2*pi*random(1) costheta = 2.0d0*random(1) - 1.0d0 sintheta = sqrt(1.0d0 - costheta**2) r = abspa*( 1/random(1) - 1.0d0 ) DO mu = 1,3 ell1(mu) = r * ( costheta*ea(mu) + sintheta & * ( cos(phi)*eb(mu) + sin(phi)*ec(mu) ) ) END DO ! ELSE IF (xchoice.LT.2.0d0*a2to1a) THEN ! ! We want a map concentrating points near ell1 - pa = 0. ! phi = 2*pi*random(1) costheta = 2.0d0*random(1) - 1.0d0 sintheta = sqrt(1.0d0 - costheta**2) r = abspa*( 1/random(1) - 1.0d0 ) DO mu = 1,3 ell1(mu) = r * ( costheta*ea(mu) + sintheta & * ( cos(phi)*eb(mu) + sin(phi)*ec(mu) ) ) & + pa(mu) END DO ! ELSE IF (xchoice.LT.(2.0d0*a2to1a+a2to1b)) THEN ! ! We want a map concentrating points near ell1 = 0, BUT with ! scale SCALEABC. ! phi = 2*pi*random(1) costheta = 2.0d0*random(1) - 1.0d0 sintheta = sqrt(1.0d0 - costheta**2) r = scaleabc*( 1/random(1) - 1.0d0 ) DO mu = 1,3 ell1(mu) = r * ( costheta*ea(mu) + sintheta & * ( cos(phi)*eb(mu) + sin(phi)*ec(mu) ) ) END DO ! ELSE IF (xchoice.LT.2.0d0*(a2to1a+a2to1b)) THEN ! ! We want a map concentrating points near ell1 - pa = 0, BUT with ! scale SCALEABC. ! phi = 2*pi*random(1) costheta = 2.0d0*random(1) - 1.0d0 sintheta = sqrt(1.0d0 - costheta**2) r = scaleabc*( 1/random(1) - 1.0d0 ) DO mu = 1,3 ell1(mu) = r * ( costheta*ea(mu) + sintheta & * ( cos(phi)*eb(mu) + sin(phi)*ec(mu) ) ) & + pa(mu) END DO ! ELSE ! ! We want a map concentrating points rather collinearly with PA(mu). ! xx = random(1) x = b2to1 * (xx - 0.5d0)/xx/(1.0d0 - xx) + 0.5d0 ! ell1t = c2to1 * abspa * sqrt( 1.0d0/random(1) - 1.0d0 ) ! phi = 2.0d0 * pi * random(1) ! ! Step 3: Put this together using our unit vectors. ! DO mu = 1,3 ell1(mu) = x * pa(mu) & + ell1t * ( cos(phi) * eb(mu) + sin(phi) * ec(mu) ) END DO ! ! End IF (XCHOICE.LT.F) ... ! END IF ! RETURN END subroutine choose2to1a ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function rho2to1a(pa,pb,ell1) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: pa(3),pb(3),ell1(3) ! Out: real(kind=dbl) :: rho2to1a ! ! Density in ell1(mu) for a self-energy graph that leads to a ! propagator with momemtum Pa(mu) that enters the final state. ! The map concentrats points rather collinearly with Pa(mu). ! ! 18 December 2000 ! 18 March 2001 ! ! ! The parameters B2TO1, C2TO1, A2TO1A and A2TO1B need to match ! between CHOOSE2TO1A and RHO2TO1A. ! real(kind=dbl), parameter :: b2to1 = 0.4d0 real(kind=dbl), parameter :: c2to1 = 0.4d0 real(kind=dbl), parameter :: a2to1a = 0.05d0 real(kind=dbl), parameter :: a2to1b = 0.25d0 ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! integer :: mu real(kind=dbl) :: pasq,abspa,pbsq,abspb,pcsq,abspc,scaleabc real(kind=dbl) :: ea(3) real(kind=dbl) :: x,ell1sq,absell1,ell1z,ell1tsq,ell1primesq,absell1prime real(kind=dbl) :: k0sq,temp,dxdxx,j real(kind=dbl) :: rho1,rho2,rho3,rho4,rho5 ! ! Step 1: ! We need the appropriate unit vectors for the map. We create a unit ! vector EA(mu) in the direction of PA(mu). We also calculate a ! scale factor SCALEABC. ! pasq = 0.0d0 pbsq = 0.0d0 pcsq = 0.0d0 DO mu = 1,3 pasq = pasq + pa(mu)**2 pbsq = pbsq + pb(mu)**2 pcsq = pcsq + (pa(mu) + pb(mu))**2 END DO IF (pasq.LT.1.0d-30) THEN write(nout,*)'pasq too small in rho2to1.' write(nout,*)'pa ',pa write(nout,*)'ell1',ell1 stop END IF abspa = sqrt(pasq) abspb = sqrt(pbsq) abspc = sqrt(pbsq) DO mu = 1,3 ea(mu) = pa(mu)/abspa END DO scaleabc = (abspa + abspb + abspc)/3.0d0 ! ! We also need some other variables. We define ell1prime(mu) to be ! ell1(mu) - pa(mu). ! ell1sq = 0.0d0 ell1z = 0.0d0 DO mu = 1,3 ell1sq = ell1sq + ell1(mu)**2 ell1z = ell1z + ell1(mu)*ea(mu) END DO ell1tsq = ell1sq - ell1z**2 absell1 = sqrt(ell1sq) ell1primesq = ell1sq + pasq - 2.0d0*ell1z*abspa absell1prime = sqrt(ell1primesq) ! ! Step 2: Construct each of the three densities. ! ! Density 1, for a concentration of points near ell1 = 0. ! temp = 4.0d0*pi*ell1sq*(absell1 + abspa)**2 rho1 = abspa/temp ! ! Density 2, for a concentration of points near ell1 = 0. ! temp = 4.0d0*pi*ell1primesq*(absell1prime + abspa)**2 rho2 = abspa/temp ! ! Density 3, for a concentration of points near ell1 = 0, BUT with ! scale SCALEABC. ! temp = 4.0d0*pi*ell1sq*(absell1 + scaleabc)**2 rho3 = scaleabc/temp ! ! Density 4, for a concentration of points near ell1 = 0, BUT with ! scale SCALEABC. ! temp = 4.0d0*pi*ell1primesq*(absell1prime + scaleabc)**2 rho4 = scaleabc/temp ! ! Density 5, for a concentration of points rather collinearly ! with PA(mu). ! ! Construct the momentum fraction X ! x = ell1z/abspa ! ! Construct the jacobian and its inverse, the density. ! k0sq = c2to1**2 * pasq temp = sqrt((x-0.5d0)**2 + b2to1**2) dxdxx = 2.0d0*(temp + b2to1)*temp/b2to1 j = abspa*dxdxx*pi/k0sq*(k0sq+ell1tsq)**2 rho5 = 1/j ! ! Assemble our five pieces with the right weights. ! rho2to1a = a2to1a*(rho1 + rho2) & + a2to1b*(rho3 + rho4) & + (1.0d0 - 2.0d0*(a2to1a+a2to1b))*rho5 ! RETURN END function rho2to1a ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine choose2to1b(pa,pb,ell1,ok) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: pa(3),pb(3) ! Out: real(kind=dbl) :: ell1(3) logical :: ok ! ! Generates a point ell1(mu) using an elliptical coordinate system ! based on the vectors p_A(mu) and p_B(mu). The points are concentrated ! near ell1(mu) = parallel to P_A(mu). ! ! 7 December 2002 ! 8 May 2003 ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! ! Function RANDOM(1) give a random number in the range 0 parton + parton ! as a NLO contribution rather than as part of a shower. ! ! 5 April 2003 ! real(kind=dbl) :: showercut common /showercutinfo/ showercut ! real(kind=dbl) :: energysq,energysq1,energysq2 real(kind=dbl) :: momentumsq,momentumsq1,momentumsq2 integer :: i,mu ! graph9factor = 1.0d0 keepcut = .true. IF (graphnumber.EQ.1) THEN keepcut = .false. IF (cut%ncut.EQ.4) THEN energysq = (absk(7) + absk(8))**2 momentumsq = 0.0d0 DO mu = 1,3 momentumsq = momentumsq + (k(7,mu) + k(8,mu))**2 END DO IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN keepcut = .true. END IF END IF ELSE IF (graphnumber.EQ.4) THEN keepcut = .false. IF (cut%ncut.EQ.4) THEN energysq = (absk(7) + absk(8))**2 momentumsq = 0.0d0 DO mu = 1,3 momentumsq = momentumsq + (k(7,mu) + k(8,mu))**2 END DO IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN keepcut = .true. END IF END IF ELSE IF (graphnumber.EQ.5) THEN keepcut = .false. IF (cut%ncut.EQ.4) THEN energysq = (absk(7) + absk(8))**2 momentumsq = 0.0d0 DO mu = 1,3 momentumsq = momentumsq + (k(7,mu) + k(8,mu))**2 END DO IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN keepcut = .true. END IF ELSE ! ncut is 3 and we will use this cut if propagator 3 is cut. DO i = 1,cut%ncut IF (cut%cutindex(i).EQ.3) THEN keepcut = .true. END IF END DO END IF ELSE IF (graphnumber.EQ.6) THEN keepcut = .false. IF (cut%ncut.EQ.4) THEN energysq = (absk(6) + absk(7))**2 momentumsq = 0.0d0 DO mu = 1,3 momentumsq = momentumsq + (k(6,mu) + k(7,mu))**2 END DO IF ( energysq.GT.(1.0d0 + showercut)*momentumsq ) THEN keepcut = .true. END IF ELSE ! ncut is 3 and we will use this cut if propagator 1 is cut. DO i = 1,cut%ncut IF (cut%cutindex(i).EQ.1) THEN keepcut = .true. END IF END DO END IF ELSE IF (graphnumber.EQ.9) THEN keepcut = .false. ! This gets reversed only if the four propagators 5,6,7,8 are cut and ! one or both of 5-6 and 7-8 represents a wide angle splitting. IF (cut%ncut.EQ.4) THEN energysq1 = (absk(5) + absk(6))**2 energysq2 = (absk(7) + absk(8))**2 momentumsq1 = 0.0d0 momentumsq2 = 0.0d0 DO mu = 1,3 momentumsq1 = momentumsq1 + (k(5,mu) + k(6,mu))**2 momentumsq2 = momentumsq2 + (k(7,mu) + k(8,mu))**2 END DO IF ( energysq1.GT.(1.0d0 + showercut)*momentumsq1 ) THEN keepcut = .true. IF ( energysq2.GT.(1.0d0 + showercut)*momentumsq2 ) THEN ! Both 5-6 and 7-8 are wide angle. graph9factor = 1.0d0 ELSE ! Just 5-6 is wide angle. graph9factor = (energysq2 - momentumsq2) & /(energysq1 - momentumsq1 + energysq2 - momentumsq2) END IF ELSE IF ( energysq2.GT.(1.0d0 + showercut)*momentumsq2 ) THEN ! Just 7-8 is wide angle. keepcut = .true. graph9factor = (energysq1 - momentumsq1) & /(energysq1 - momentumsq1 + energysq2 - momentumsq2) END IF END IF END IF ! (graphnumber.EQ.1) et cetera. ! END subroutine checknewcut ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine deform(vrtx,loopindex,rts,leftloop,rightloop, & ninloop,kinloop,newkinloop,jacdeform) ! use beowulf_parameters implicit none ! In: integer :: vrtx(0:3*size-1,2) integer :: loopindex(size+1) real(kind=dbl) :: rts logical :: leftloop,rightloop integer :: ninloop real(kind=dbl) :: kinloop(size+1,0:3) ! Out: complex(kind=dbl) :: newkinloop(0:3) complex(kind=dbl) :: jacdeform ! ! Contour deformation. Note that this simple algorithm should ! work for NINLOOP = 3 and for NINLOOP = 4 if the sum of the ! three 3-momenta exiting the loop vanishes. ! ! In variables: ! VRTX(P,I) = Index of vertex at beginning (i= 1) and end (I = 2) of ! of propagator P. Specifies the supergraph. ! LOOPINDEX(NP) = Index P of NPth propagator around the loop. ! RTS = energy of final state. ! LEFTLOOP = T if there is a loop to the left of the cut. ! RIGHTLOOP = T if there is a loop to the right of the cut. ! NINLOOP = number of propagators in the loop. ! KINLOOP(J,MU) = momentum of Jth propagator in loop (real part) ! Out variables: ! NEWKINLOOP(MU) = added part of loop momentum. ! (purely imaginary for MU = 1,2,3) ! JACDEFORM = jacobian associated with contour deformation. ! ! Our notation is ! vec Q(j) = vec L(j) - vec L(j+1) j = 1,...,Ninloop - 1 ! L(j) = |L(j)| j = 1,...,Ninloop - 1 ! Q(j) = |Q(j)| j = 1,...,Ninloop - 1 ! ! 27 October 1992 first DEFORM ! 1 February 1998 latest version ! 23 February 1998 minor revision to rename deform variables ! real(kind=dbl) :: deformalpha,deformbeta,deformgamma common /deformscales/deformalpha,deformbeta,deformgamma ! real(kind=dbl) :: s integer :: sign real(kind=dbl) :: l(size+1,3) ! real(kind=dbl) :: q(size,3),qsq(size),qabs(size) real(kind=dbl) :: lhat(size,3),lsq(size),labs(size) real(kind=dbl) :: w(size,3),wsq(size),wabs(size) real(kind=dbl) :: acrit2,acrit3,a2,a3 real(kind=dbl) :: delta real(kind=dbl) :: m1(3,3),m2(3,3),m3(3,3) real(kind=dbl) :: d1,d2,d3,dsq,graddsq(3) real(kind=dbl) :: fraction,gradf(3) real(kind=dbl) :: g2,g3,dg2da2,dg3da3 real(kind=dbl) :: c,dlncddsq real(kind=dbl) :: termc,termf,termg2,termg3,termw2,termw3,terms complex(kind=dbl) :: a(3,3) ! logical :: connectstocurrent real(kind=dbl) :: temp,temp1,temp2,temp3 integer :: j,mu,nu ! ! Calculate s. ! s = rts**2 ! ! Initialize with default value. ! DO mu = 0,3 newkinloop(mu) = (0.0d0,0.0d0) END DO ! jacdeform = (1.0d0,0.0d0) ! ! Check to see if we should actually do anything ! IF (ninloop.LT.2) THEN RETURN END IF ! ! Set ! SIGN = +1 and L(J,MU) = KINLOOP(J,MU) for a left loop, ! SIGN = -1 and L(J,MU) = KINLOOP(NINLOOP-J+1,MU) for a right loop. ! IF (leftloop) THEN sign = + 1 DO j = 1,ninloop DO mu = 1,3 l(j,mu) = kinloop(j,mu) END DO END DO ELSE IF (rightloop) THEN sign = - 1 DO j = 1,ninloop DO mu = 1,3 l(j,mu) = kinloop(ninloop-j+1,mu) END DO END DO ELSE write(nout,*) 'Snafu in deform.' stop END IF ! ! Two particles in the loop. ! IF (ninloop.EQ.2) THEN ! ! Calculate Q(3,mu), |L(j)|^2, |Q(3)|^2, |L(j)|, |Q(3)|, hat L(j,mu). ! qsq(3) = 0.0d0 DO mu = 1,3 q(3,mu) = l(1,mu) - l(2,mu) qsq(3) = qsq(3) + q(3,mu)**2 END DO qabs(3) = sqrt(qsq(3)) DO j = 1,2 lsq(j) = 0.0d0 DO mu = 1,3 lsq(j) = lsq(j) + l(j,mu)**2 END DO labs(j) = sqrt(lsq(j)) DO mu = 1,3 lhat(j,mu) = l(j,mu)/labs(j) END DO END DO ! ! Calculate the vector W(3,mu), along with the corresponding ! normalization factor. ! wsq(3) = 0.0d0 DO mu = 1,3 w(3,mu) = lhat(1,mu) + lhat(2,mu) wsq(3) = wsq(3) + w(3,mu)**2 END DO wabs(3) = sqrt(wsq(3)) ! ! The size of the critical ellipse. ! acrit3 = rts - 2.0d0*qabs(3) ! ! The size of the ellipse at point L. ! a3 = labs(1) + labs(2) - qabs(3) ! ! Calculate the matrix d W(3,mu)/ d L(mu) = M3(mu,nu). ! DO mu = 1,3 DO nu = 1,3 temp = delta(mu,nu) temp1 = (temp - lhat(1,mu)*lhat(1,nu))/labs(1) temp2 = (temp - lhat(2,mu)*lhat(2,nu))/labs(2) m3(mu,nu) = temp1 + temp2 END DO END DO ! ! The "distance" to the collinear line. ! d3 = labs(1)*labs(2)*wabs(3)/qabs(3) ! ! The square of the distance its gradient. ! dsq = d3**2 DO nu = 1,3 temp = 0.0d0 DO mu = 1,3 temp = temp + w(3,mu)*m3(mu,nu) END DO temp = temp/wsq(3) temp = temp + l(1,nu)/lsq(1) + l(2,nu)/lsq(2) graddsq(nu) = 2.0d0*dsq*temp END DO ! ! The function G3 and its derivative. ! g3 = 1.0d0/(acrit3 + deformgamma*a3) dg3da3 = - deformgamma/(acrit3 + deformgamma*a3)**2 ! ! Calculate the function C(DSQ) and its derivative. Note that we change ! the sign of C in the case of a loop to the right of the cut. ! ! We effectively make DEFORMALPHA smaller by a factor 10 for the two ! point function so as to avoid crossing branch cut of SQRT ! c = sign*deformalpha*dsq /(1.0d0 + deformbeta*dsq/qsq(3)) c = c * acrit3/rts dlncddsq = 1.0d0/dsq/(1.0d0 + deformbeta*dsq/qsq(3)) ! ! Calculate the imaginary part of the loop momentum L(mu). ! DO mu = 1,3 newkinloop(mu) = (0.0d0,-1.0d0) * c * g3 * w(3,mu) END DO ! ! Calculate the jacobian. ! First, we need the comlex matrix A(mu,nu), the derivative ! of ComplexL(mu) with respecdt to L(nu). ! DO mu = 1,3 DO nu = 1,3 termc = g3*w(3,mu)*dlncddsq*graddsq(nu) termg3 = dg3da3*w(3,mu)*w(3,nu) termw3 = g3*m3(mu,nu) terms = termc + termg3 + termw3 a(mu,nu) = delta(mu,nu) + (0.0d0,-1.0d0) * c * terms END DO END DO ! ! Finally, the jacobian is the determinant of A ! jacdeform = a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) & + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) & + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) ! ! End of Ninloop = 2 calculation ! ! Three particles in the loop. ! ELSE IF (ninloop.EQ.3) THEN ! ! First we need to determine if our loop connects to the current vertex. ! IF (leftloop) THEN IF ((vrtx(loopindex(1),1).EQ.1)) THEN connectstocurrent = .true. ELSE connectstocurrent = .false. END IF ELSE IF ((vrtx(loopindex(1),1).EQ.2)) THEN connectstocurrent = .true. ELSE connectstocurrent = .false. END IF END IF IF (connectstocurrent) THEN ! ! Calculation for a three particle loop that connects to the current. ! ! Calculate Q(3,mu), |L(j)|^2, |Q(3)|^2, |L(j)|, |Q(3)|, hat L(j,mu). ! qsq(3) = 0.0d0 DO mu = 1,3 q(3,mu) = l(1,mu) - l(2,mu) qsq(3) = qsq(3) + q(3,mu)**2 END DO qabs(3) = sqrt(qsq(3)) DO j = 1,2 lsq(j) = 0.0d0 DO mu = 1,3 lsq(j) = lsq(j) + l(j,mu)**2 END DO labs(j) = sqrt(lsq(j)) DO mu = 1,3 lhat(j,mu) = l(j,mu)/labs(j) END DO END DO ! ! Calculate the vector W(3,mu), along with the corresponding ! normalization factor. ! wsq(3) = 0.0d0 DO mu = 1,3 w(3,mu) = lhat(1,mu) + lhat(2,mu) wsq(3) = wsq(3) + w(3,mu)**2 END DO wabs(3) = sqrt(wsq(3)) ! ! The size of the critical ellipse. ! acrit3 = rts - 2.0d0*qabs(3) ! ! The size of the ellipse at point L. ! a3 = labs(1) + labs(2) - qabs(3) ! ! Calculate the matrix d W(3,mu)/ d L(mu) = M3(mu,nu). ! DO mu = 1,3 DO nu = 1,3 temp = delta(mu,nu) temp1 = (temp - lhat(1,mu)*lhat(1,nu))/labs(1) temp2 = (temp - lhat(2,mu)*lhat(2,nu))/labs(2) m3(mu,nu) = temp1 + temp2 END DO END DO ! ! The "distance" to the collinear line. ! d3 = labs(1)*labs(2)*wabs(3)/qabs(3) ! ! The square of the distance its gradient. ! dsq = d3**2 DO nu = 1,3 temp = 0.0d0 DO mu = 1,3 temp = temp + w(3,mu)*m3(mu,nu) END DO temp = temp/wsq(3) temp = temp + l(1,nu)/lsq(1) + l(2,nu)/lsq(2) graddsq(nu) = 2.0d0*dsq*temp END DO ! ! The function G3 and its derivative. ! g3 = 1.0d0/(acrit3 + deformgamma*a3) dg3da3 = - deformgamma/(acrit3 + deformgamma*a3)**2 ! ! Calculate the function C(DSQ) and its derivative. Note that we change ! the sign of C in the case of a loop to the right of the cut. ! c = sign*deformalpha*dsq /(1.0d0 + deformbeta*dsq/qsq(3)) dlncddsq = 1.0d0/dsq/(1.0d0 + deformbeta*dsq/qsq(3)) ! ! Calculate the imaginary part of the loop momentum L(mu). ! DO mu = 1,3 newkinloop(mu) = (0.0d0,-1.0d0) * c * g3 * w(3,mu) END DO ! ! Calculate the jacobian. ! First, we need the comlex matrix A(mu,nu), the derivative ! of ComplexL(mu) with respecdt to L(nu). ! DO mu = 1,3 DO nu = 1,3 termc = g3*w(3,mu)*dlncddsq*graddsq(nu) termg3 = dg3da3*w(3,mu)*w(3,nu) termw3 = g3*m3(mu,nu) terms = termc + termg3 + termw3 a(mu,nu) = delta(mu,nu) + (0.0d0,-1.0d0) * c * terms END DO END DO ! ! Finally, the jacobian is the determinant of A ! jacdeform = a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) & + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) & + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) ! ! End of calculation for Ninloop = 3 for a loop connecting to the ! current ( IF(CONNECTSTOCURRENT) ). ! ELSE ! ! Calculation for a three particle loop that does not connect ! to the current. ! ! Calculate Q(j,mu), |L(j)|^2, |Q(j)|^2, |L(j)|, |Q(j)|, hat L(j,mu). ! DO mu = 1,3 q(1,mu) = l(2,mu) - l(3,mu) q(2,mu) = l(3,mu) - l(1,mu) q(3,mu) = l(1,mu) - l(2,mu) END DO DO j = 1,3 lsq(j) = 0.0d0 qsq(j) = 0.0d0 DO mu = 1,3 lsq(j) = lsq(j) + l(j,mu)**2 qsq(j) = qsq(j) + q(j,mu)**2 END DO qabs(j) = sqrt(qsq(j)) labs(j) = sqrt(lsq(j)) DO mu = 1,3 lhat(j,mu) = l(j,mu)/labs(j) END DO END DO ! ! The vectors W(j,mu) and their squares and their absolute values. ! DO mu = 1,3 w(1,mu) = lhat(2,mu) + lhat(3,mu) w(2,mu) = lhat(3,mu) + lhat(1,mu) w(3,mu) = lhat(1,mu) + lhat(2,mu) END DO DO j = 1,3 wsq(j) = 0.0d0 DO mu = 1,3 wsq(j) = wsq(j) + w(j,mu)**2 END DO wabs(j) = sqrt(wsq(j)) END DO ! ! The size of the critical ellipses. ! acrit2 = rts - 2.0d0*qabs(2) acrit3 = rts - 2.0d0*qabs(3) ! ! The sizes of the ellipses at point L. ! a2 = labs(3) + labs(1) - qabs(2) a3 = labs(1) + labs(2) - qabs(3) ! ! Calculate the matrix d W(j,mu)/ d L(mu) = Mj(mu,nu). ! DO mu = 1,3 DO nu = 1,3 temp = delta(mu,nu) temp1 = (temp - lhat(1,mu)*lhat(1,nu))/labs(1) temp2 = (temp - lhat(2,mu)*lhat(2,nu))/labs(2) temp3 = (temp - lhat(3,mu)*lhat(3,nu))/labs(3) m1(mu,nu) = temp2 + temp3 m2(mu,nu) = temp3 + temp1 m3(mu,nu) = temp1 + temp2 END DO END DO ! ! The "distances" to the collinear lines. In this case we do not need D2. ! d1 = labs(2)*labs(3)*wabs(1)/qabs(1) d3 = labs(1)*labs(2)*wabs(3)/qabs(3) ! ! The square of the smaller of D1 and D3 and its gradient. ! IF (d1.LT.d3) THEN ! ! D1 is the smaller distance. ! dsq = d1**2 DO nu = 1,3 temp = 0.0d0 DO mu = 1,3 temp = temp + w(1,mu)*m1(mu,nu) END DO temp = temp/wsq(1) temp = temp + l(2,nu)/lsq(2) + l(3,nu)/lsq(3) graddsq(nu) = 2.0d0*dsq*temp END DO ! ELSE ! ! D3 is the smaller distance. ! dsq = d3**2 DO nu = 1,3 temp = 0.0d0 DO mu = 1,3 temp = temp + w(3,mu)*m3(mu,nu) END DO temp = temp/wsq(3) temp = temp + l(1,nu)/lsq(1) + l(2,nu)/lsq(2) graddsq(nu) = 2.0d0*dsq*temp END DO ! END IF ! ! The function G2 and its derivative. ! g2 = 1.0d0/(acrit2 + deformgamma*a2) dg2da2 = - deformgamma/(acrit2 + deformgamma*a2)**2 ! ! Calculate the function C(DSQ) and its derivative. Note that we change ! the sign of C in the case of a loop to the right of the cut. ! c = sign*deformalpha*dsq /(1.0d0 + 4.0d0*deformbeta*dsq/s) dlncddsq = 1.0d0/dsq/(1.0d0 + 4.0d0*deformbeta*dsq/s) ! ! Calculate the imaginary part of the loop momentum L(mu). ! DO mu = 1,3 newkinloop(mu) = (0.0d0,-1.0d0) * c * g2 * w(2,mu) END DO ! ! Calculate the jacobian. ! First, we need the comlex matrix A(mu,nu), the derivative ! of ComplexL(mu) with respecdt to L(nu). ! DO mu = 1,3 DO nu = 1,3 termc = g2*w(2,mu)*dlncddsq*graddsq(nu) termg2 = dg2da2*w(2,mu)*w(2,nu) termw2 = g2*m2(mu,nu) terms = termc + termg2 + termw2 a(mu,nu) = delta(mu,nu) + (0.0d0,-1.0d0) * c * terms END DO END DO ! ! Finally, the jacobian is the determinant of A ! jacdeform = a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) & + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) & + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) ! ! End of calculation for Ninloop = 3 for a loop not connecting to the ! current ( IF(CONNECTSTOCURRENT) ... ELSE ...). ! END IF ! ! End of Ninloop = 3 calculation ! ! Four particles in the loop.------------ ! ELSE IF (ninloop.EQ.4) THEN ! ! Calculate Q(j,mu), |L(j)|^2, |Q(j)|^2, |L(j)|, |Q(j)|, hat L(j,mu). ! DO mu = 1,3 q(1,mu) = l(2,mu) - l(3,mu) q(2,mu) = l(3,mu) - l(1,mu) q(3,mu) = l(1,mu) - l(2,mu) END DO DO j = 1,3 lsq(j) = 0.0d0 qsq(j) = 0.0d0 DO mu = 1,3 lsq(j) = lsq(j) + l(j,mu)**2 qsq(j) = qsq(j) + q(j,mu)**2 END DO qabs(j) = sqrt(qsq(j)) labs(j) = sqrt(lsq(j)) DO mu = 1,3 lhat(j,mu) = l(j,mu)/labs(j) END DO END DO ! ! The vectors W(j,mu) and their squares and their absolute values. ! DO mu = 1,3 w(1,mu) = lhat(2,mu) + lhat(3,mu) w(2,mu) = lhat(3,mu) + lhat(1,mu) w(3,mu) = lhat(1,mu) + lhat(2,mu) END DO DO j = 1,3 wsq(j) = 0.0d0 DO mu = 1,3 wsq(j) = wsq(j) + w(j,mu)**2 END DO wabs(j) = sqrt(wsq(j)) END DO ! ! The size of the critical ellipses. ! acrit2 = rts - 2.0d0*qabs(2) acrit3 = rts - 2.0d0*qabs(3) ! ! The sizes of the ellipses at point L. ! a2 = labs(3) + labs(1) - qabs(2) a3 = labs(1) + labs(2) - qabs(3) ! ! Calculate the matrix d W(j,mu)/ d L(mu) = Mj(mu,nu). ! DO mu = 1,3 DO nu = 1,3 temp = delta(mu,nu) temp1 = (temp - lhat(1,mu)*lhat(1,nu))/labs(1) temp2 = (temp - lhat(2,mu)*lhat(2,nu))/labs(2) temp3 = (temp - lhat(3,mu)*lhat(3,nu))/labs(3) m1(mu,nu) = temp2 + temp3 m2(mu,nu) = temp3 + temp1 m3(mu,nu) = temp1 + temp2 END DO END DO ! ! The "distances" to the collinear lines. ! d1 = labs(2)*labs(3)*wabs(1)/qabs(1) d2 = labs(3)*labs(1)*wabs(2)/qabs(2) d3 = labs(1)*labs(2)*wabs(3)/qabs(3) ! ! The square of the smallest distance its gradient. ! IF ((d1.LT.d2).AND.(d1.LT.d3)) THEN ! ! D1 is the smallest distance ! dsq = d1**2 DO nu = 1,3 temp = 0.0d0 DO mu = 1,3 temp = temp + w(1,mu)*m1(mu,nu) END DO temp = temp/wsq(1) temp = temp + l(2,nu)/lsq(2) + l(3,nu)/lsq(3) graddsq(nu) = 2.0d0*dsq*temp END DO ! ELSE IF (d2.LT.d3) THEN ! ! D2 is the smallest distance ! dsq = d2**2 DO nu = 1,3 temp = 0.0d0 DO mu = 1,3 temp = temp + w(2,mu)*m2(mu,nu) END DO temp = temp/wsq(2) temp = temp + l(3,nu)/lsq(3) + l(1,nu)/lsq(1) graddsq(nu) = 2.0d0*dsq*temp END DO ! ELSE ! ! D3 is the smallest distance. ! dsq = d3**2 DO nu = 1,3 temp = 0.0d0 DO mu = 1,3 temp = temp + w(3,mu)*m3(mu,nu) END DO temp = temp/wsq(3) temp = temp + l(1,nu)/lsq(1) + l(2,nu)/lsq(2) graddsq(nu) = 2.0d0*dsq*temp END DO ! END IF ! ! The mixing fraction FRACTION and its gradient. ! fraction = lsq(3) /(lsq(2) + lsq(3)) DO nu = 1,3 temp = lsq(2)*l(3,nu) - lsq(3)*l(2,nu) gradf(nu) = 2.0d0*temp/(lsq(2) + lsq(3))**2 END DO ! ! The functions G2 and G3 and their derivatives. ! g2 = 1.0d0/(acrit2 + deformgamma*a2) g3 = 1.0d0/(acrit3 + deformgamma*a3) dg2da2 = - deformgamma/(acrit2 + deformgamma*a2)**2 dg3da3 = - deformgamma/(acrit3 + deformgamma*a3)**2 ! ! Calculate the function C(DSQ) and its derivative. Note that we change ! the sign of C in the case of a loop to the right of the cut. ! c = sign*deformalpha*dsq /(1.0d0 + 4.0d0*deformbeta*dsq/s) dlncddsq = 1.0d0/dsq/(1.0d0 + 4.0d0*deformbeta*dsq/s) ! ! Calculate the imaginary part of the loop momentum L(mu). ! DO mu = 1,3 newkinloop(mu) = (0.0d0,-1.0d0) * c & * (fraction*g2*w(2,mu) + (1.0d0 - fraction)*g3*w(3,mu)) END DO ! ! Calculate the jacobian. ! First, we need the comlex matrix A(mu,nu), the derivative ! of ComplexL(mu) with respecdt to L(nu). ! DO mu = 1,3 DO nu = 1,3 termc = fraction*g2*w(2,mu) + (1.0d0 - fraction)*g3*w(3,mu) termc = termc * dlncddsq*graddsq(nu) termf = ( g2*w(2,mu) - g3*w(3,mu) )*gradf(nu) termg2 = fraction *dg2da2*w(2,mu)*w(2,nu) termg3 = (1.0d0 - fraction)*dg3da3*w(3,mu)*w(3,nu) termw2 = fraction *g2*m2(mu,nu) termw3 = (1.0d0 - fraction)*g3*m3(mu,nu) terms = termc + termf + termg2 + termg3 + termw2 + termw3 a(mu,nu) = delta(mu,nu) + (0.0d0,-1.0d0) * c * terms END DO END DO ! ! Finally, the jacobian is the determinant of A ! jacdeform = a(1,1) * ( a(2,2) * a(3,3) - a(2,3) * a(3,2) ) & + a(1,2) * ( a(2,3) * a(3,1) - a(2,1) * a(3,3) ) & + a(1,3) * ( a(2,1) * a(3,2) - a(2,2) * a(3,1) ) ! ! End of Ninloop = 4 calculation ! ELSE write(nout,*) 'Not programed for ninloop > 4 yet.' stop END IF ! RETURN END subroutine deform ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function delta(mu,nu) ! use beowulf_parameters implicit none ! In: integer :: mu,nu ! Out: real(kind=dbl) :: delta ! ! Kroneker delta. ! IF (mu.EQ.nu) THEN delta = 1.0d0 ELSE delta = 0.0d0 END IF RETURN END function delta ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function smear(rts) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: rts ! Out: real(kind=dbl) :: smear ! ! A smearing function that may do a good job of optimizing ! the integration accuracy. It satisfies ! ! Int_0^\infty dE SMEAR(E) = 1 ! ! We take ! ! SMEAR(E) = (N-1)!/[M! (N-M-2)!] (A E_0 )**(N-M-1) ! * E**M / [E + A * E_0]**N ! ! where E_0 = ENERGYSCALE = 1. ! ! real(kind=dbl) :: smearfctr integer :: lowpwr,highpwr common /smearparms/ smearfctr,lowpwr,highpwr ! real(kind=dbl), parameter :: energyscale = 1.0d0 ! real(kind=dbl) :: factorial ! smear = factorial(highpwr-1) & /(factorial(lowpwr) * factorial(highpwr-lowpwr-2)) smear = smear * (smearfctr * energyscale)**(highpwr-lowpwr-1) smear = smear * rts**lowpwr & /( rts + smearfctr*energyscale )**highpwr RETURN END function smear ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Feynman integrand in Feynman gauge ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function feynmanf(graphnumber,kc,cut,mumsbar,flag) ! use beowulf_parameters implicit none ! In: integer :: graphnumber complex(kind=dbl) :: kc(0:3*size-1,0:3) logical :: cut(3*size-1) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: feynmanf ! ! Feynman integrand function for graph GRAPHNUMBER ! with complex momenta KC and cut specified by CUT. ! Early version: 17 July 1994. ! This version written by Mathematica code of 4 January 2002 on ! 4 Jan 2002. ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) complex(kind=dbl), parameter :: gn(0:3) = & (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) ! complex(kind=dbl) :: complexsqrt integer :: mu,nu,tau complex(kind=dbl) :: x(256) complex(kind=dbl) :: k1(0:3),k2(0:3),k3(0:3),k4(0:3) complex(kind=dbl) :: k5(0:3),k6(0:3),k7(0:3),k8(0:3) complex(kind=dbl) :: e1,e2,e3,e4,e5,e6,e7,e8 complex(kind=dbl) :: k11,k22,k33,k44,k55,k66,k77,k88 complex(kind=dbl) :: tk11,tk22,tk33,tk44,tk55,tk66,tk77,tk88 complex(kind=dbl) :: prefactor character(len=13) :: kind2pt2 complex(kind=dbl) :: k2pt2(0:5,0:3) logical :: cut2pt2(1:5) character(len=9) :: kind2pt complex(kind=dbl) :: k2pt(0:2,0:3) logical :: cut2pt(0:3) character(len=7) :: kind3pt complex(kind=dbl) :: k3pt(3,0:3) logical :: cut3pt(3) ! complex(kind=dbl) :: a1qda4q,a1qik6a4qik7,a1qik7a4qik6,ea1qk3q47 complex(kind=dbl) :: ea1qzv4qk6k7,ea2qk3q67,ea3qk1q26,ea4qk1q86 complex(kind=dbl) :: ea4qzv1qk6k7,ea7ak1ik2k3k4,ea7ak1k2,ea7ak1k3,ea7ak1k4 complex(kind=dbl) :: ea7ak2ik1k3k4,ea7ak2k3,ea7ak2k4,ea7ak3ik1k2k4,ea7ak3k4 complex(kind=dbl) :: ea7ak4ik1k2k3,ea8ak1ik2k3k4,ea8ak1k2,ea8ak1k3,ea8ak1k4 complex(kind=dbl) :: ea8ak2ik1k3k4,ea8ak2k3,ea8ak2k4,ea8ak3ik1k2k4,ea8ak3k4 complex(kind=dbl) :: ea8ak4ik1k2k3,g7awk1k2,g7awk1k3,g7awk2k4,g7awk3k4,k1k2 complex(kind=dbl) :: k1k3,k1k4,k1q24,k1q26,k1q36,k1q84,k1q86,k1qqnb45 complex(kind=dbl) :: k1qqnb46,k1qqng45,k1qqng46,k1qqnq45,k1qqnq46,k1qqog57 complex(kind=dbl) :: k1qqog75,k1qqoq57,k1qqoq64,k2k3,k2k4,k2q24,k2q36,k2q84 complex(kind=dbl) :: k2q86,k3k4,k3q47,k3q67,k6k7,q15q47,q24q86,q36q84 complex(kind=dbl) :: traceg7a,tracev1q,tracev2q,tracev3q,tracev4q,tracev7a complex(kind=dbl) :: tracev8a,v1qdv4q,v1qik6v4qik7,v1qik7v4qik6,v1qwk3q47 complex(kind=dbl) :: v1qwq47k3,v2qwk3q67,v2qwq67k3,v3qwk1q26,v3qwq26k1 complex(kind=dbl) :: v4qwk1q86,v4qwq86k1,v7awk1k2,v7awk1k3,v7awk1k4 complex(kind=dbl) :: v7awk2k1,v7awk2k3,v7awk2k4,v7awk3k1,v7awk3k2,v7awk3k4 complex(kind=dbl) :: v7awk4k1,v7awk4k2,v7awk4k3,v8awk1k2,v8awk1k3,v8awk1k4 complex(kind=dbl) :: v8awk2k1,v8awk2k3,v8awk2k4,v8awk3k1,v8awk3k2,v8awk3k4 complex(kind=dbl) :: v8awk4k1,v8awk4k2,v8awk4k3,a1qik6(0:3),a1qik7(0:3) complex(kind=dbl) :: a4qik6(0:3),a4qik7(0:3),a7ak1i(0:3),a7ak2i(0:3) complex(kind=dbl) :: a7ak3i(0:3),a7ak4i(0:3),a8ak1i(0:3),a8ak2i(0:3) complex(kind=dbl) :: a8ak3i(0:3),a8ak4i(0:3),q15(0:3),q24(0:3),q26(0:3) complex(kind=dbl) :: q36(0:3),q47(0:3),q67(0:3),q84(0:3),q86(0:3) complex(kind=dbl) :: qqnb45(0:3),qqnb46(0:3),qqng45(0:3),qqng46(0:3) complex(kind=dbl) :: qqnq45(0:3),qqnq46(0:3),qqog57(0:3),qqog75(0:3) complex(kind=dbl) :: qqoq57(0:3),qqoq64(0:3),v1qik6(0:3),v1qik7(0:3) complex(kind=dbl) :: v4qik6(0:3),v4qik7(0:3),a1q(0:3,0:3),a1qzv4q(0:3,0:3) complex(kind=dbl) :: a2q(0:3,0:3),a3q(0:3,0:3),a4q(0:3,0:3) complex(kind=dbl) :: a4qzv1q(0:3,0:3),a7a(0:3,0:3),a8a(0:3,0:3) complex(kind=dbl) :: g7a(0:3,0:3),v1q(0:3,0:3),v2q(0:3,0:3),v3q(0:3,0:3) complex(kind=dbl) :: v4q(0:3,0:3),v7a(0:3,0:3),v8a(0:3,0:3) ! DO mu = 0,3 k1(mu) = kc(1,mu) k2(mu) = kc(2,mu) k3(mu) = kc(3,mu) k4(mu) = kc(4,mu) k5(mu) = kc(5,mu) k6(mu) = kc(6,mu) k7(mu) = kc(7,mu) k8(mu) = kc(8,mu) END DO feynmanf = 0.0d0 ! !------ ! IF (graphnumber .EQ. 1) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k4(mu) k2pt2(2,mu) = k5(mu) k2pt2(3,mu) = -k6(mu) k2pt2(4,mu) = k7(mu) k2pt2(5,mu) = k8(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(5) cut2pt2(3) = cut(6) cut2pt2(4) = cut(7) cut2pt2(5) = cut(8) kind2pt2 = 'nested /gqqgq' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnb46) DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k4(mu) k2pt2(2,mu) = k5(mu) k2pt2(3,mu) = -k6(mu) k2pt2(4,mu) = k7(mu) k2pt2(5,mu) = k8(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(5) cut2pt2(3) = cut(6) cut2pt2(4) = cut(7) cut2pt2(5) = cut(8) kind2pt2 = 'nested /qgggg' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqng46) DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k4(mu) k2pt2(2,mu) = k5(mu) k2pt2(3,mu) = -k6(mu) k2pt2(4,mu) = k8(mu) k2pt2(5,mu) = k7(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(5) cut2pt2(3) = cut(6) cut2pt2(4) = cut(8) cut2pt2(5) = cut(7) kind2pt2 = 'nested /qggqq' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnq46) DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = -k4(mu) k2pt2(2,mu) = k6(mu) k2pt2(3,mu) = -k5(mu) k2pt2(4,mu) = -k7(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(6) cut2pt2(3) = cut(5) cut2pt2(4) = cut(7) cut2pt2(5) = cut(8) kind2pt2 = 'nested /gqqgq' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnb45) DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = -k4(mu) k2pt2(2,mu) = k6(mu) k2pt2(3,mu) = -k5(mu) k2pt2(4,mu) = -k7(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(6) cut2pt2(3) = cut(5) cut2pt2(4) = cut(7) cut2pt2(5) = cut(8) kind2pt2 = 'nested /qggqq' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnq45) DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = -k4(mu) k2pt2(2,mu) = k6(mu) k2pt2(3,mu) = -k5(mu) k2pt2(4,mu) = -k8(mu) k2pt2(5,mu) = -k7(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(6) cut2pt2(3) = cut(5) cut2pt2(4) = cut(8) cut2pt2(5) = cut(7) kind2pt2 = 'nested /qgggg' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqng45) k1qqnb45 = 0.0d0 k1qqnb46 = 0.0d0 k1qqng45 = 0.0d0 k1qqng46 = 0.0d0 k1qqnq45 = 0.0d0 k1qqnq46 = 0.0d0 DO mu = 0,3 k1qqnb45 = k1qqnb45 + k1(mu)*qqnb45(mu)*metric(mu) k1qqnb46 = k1qqnb46 + k1(mu)*qqnb46(mu)*metric(mu) k1qqng45 = k1qqng45 + k1(mu)*qqng45(mu)*metric(mu) k1qqng46 = k1qqng46 + k1(mu)*qqng46(mu)*metric(mu) k1qqnq45 = k1qqnq45 + k1(mu)*qqnq45(mu)*metric(mu) k1qqnq46 = k1qqnq46 + k1(mu)*qqnq46(mu)*metric(mu) END DO feynmanf = -8*(k1qqnb45 - k1qqnb46 + k1qqng45 - k1qqng46 & + k1qqnq45 - k1qqnq46)*nc feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 2) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt(0,mu) = k2(mu) k2pt(1,mu) = k4(mu) k2pt(2,mu) = k5(mu) END DO cut2pt(0) = cut(2) cut2pt(1) = cut(4) cut2pt(2) = cut(5) cut2pt(3) = cut(8) call twopointqf(k2pt,cut2pt,mumsbar,flag,q24) DO mu = 0,3 k2pt(0,mu) = k3(mu) k2pt(1,mu) = k6(mu) k2pt(2,mu) = k7(mu) END DO cut2pt(0) = cut(3) cut2pt(1) = cut(6) cut2pt(2) = cut(7) cut2pt(3) = cut(8) call twopointqf(k2pt,cut2pt,mumsbar,flag,q36) DO mu = 0,3 k2pt(0,mu) = -k8(mu) k2pt(1,mu) = -k4(mu) k2pt(2,mu) = -k5(mu) END DO cut2pt(0) = cut(8) cut2pt(1) = cut(4) cut2pt(2) = cut(5) cut2pt(3) = cut(2) call twopointqf(k2pt,cut2pt,mumsbar,flag,q84) DO mu = 0,3 k2pt(0,mu) = k8(mu) k2pt(1,mu) = -k6(mu) k2pt(2,mu) = -k7(mu) END DO cut2pt(0) = cut(8) cut2pt(1) = cut(6) cut2pt(2) = cut(7) cut2pt(3) = cut(3) call twopointqf(k2pt,cut2pt,mumsbar,flag,q86) k1k2 = 0.0d0 k1q24 = 0.0d0 k1q36 = 0.0d0 k1q84 = 0.0d0 k1q86 = 0.0d0 k2q24 = 0.0d0 k2q36 = 0.0d0 k2q84 = 0.0d0 k2q86 = 0.0d0 q24q86 = 0.0d0 q36q84 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1q24 = k1q24 + k1(mu)*q24(mu)*metric(mu) k1q36 = k1q36 + k1(mu)*q36(mu)*metric(mu) k1q84 = k1q84 + k1(mu)*q84(mu)*metric(mu) k1q86 = k1q86 + k1(mu)*q86(mu)*metric(mu) k2q24 = k2q24 + k2(mu)*q24(mu)*metric(mu) k2q36 = k2q36 + k2(mu)*q36(mu)*metric(mu) k2q84 = k2q84 + k2(mu)*q84(mu)*metric(mu) k2q86 = k2q86 + k2(mu)*q86(mu)*metric(mu) q24q86 = q24q86 + q24(mu)*q86(mu)*metric(mu) q36q84 = q36q84 + q36(mu)*q84(mu)*metric(mu) END DO feynmanf = 8*nc*(k1q86*k2q24 + k1q84*k2q36 + k1q36*k2q84 & + k1q24*k2q86 - k1k2*q24q86 - k1k2*q36q84) feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 3) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k5(mu) k2pt2(2,mu) = k4(mu) k2pt2(3,mu) = -k7(mu) k2pt2(4,mu) = -k6(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(5) cut2pt2(2) = cut(4) cut2pt2(3) = cut(7) cut2pt2(4) = cut(6) cut2pt2(5) = cut(8) kind2pt2 = 'overlap/qggqq' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqoq57) DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k5(mu) k2pt2(2,mu) = k4(mu) k2pt2(3,mu) = -k7(mu) k2pt2(4,mu) = -k6(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(5) cut2pt2(2) = cut(4) cut2pt2(3) = cut(7) cut2pt2(4) = cut(6) cut2pt2(5) = cut(8) kind2pt2 = 'overlap/qgqgg' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqog57) DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = k6(mu) k2pt2(2,mu) = k7(mu) k2pt2(3,mu) = -k4(mu) k2pt2(4,mu) = -k5(mu) k2pt2(5,mu) = k8(mu) END DO cut2pt2(1) = cut(6) cut2pt2(2) = cut(7) cut2pt2(3) = cut(4) cut2pt2(4) = cut(5) cut2pt2(5) = cut(8) kind2pt2 = 'overlap/qggqq' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqoq64) DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = k7(mu) k2pt2(2,mu) = k6(mu) k2pt2(3,mu) = -k5(mu) k2pt2(4,mu) = -k4(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(7) cut2pt2(2) = cut(6) cut2pt2(3) = cut(5) cut2pt2(4) = cut(4) cut2pt2(5) = cut(8) kind2pt2 = 'overlap/qgqgg' call twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqog75) k1qqog57 = 0.0d0 k1qqog75 = 0.0d0 k1qqoq57 = 0.0d0 k1qqoq64 = 0.0d0 DO mu = 0,3 k1qqog57 = k1qqog57 + k1(mu)*qqog57(mu)*metric(mu) k1qqog75 = k1qqog75 + k1(mu)*qqog75(mu)*metric(mu) k1qqoq57 = k1qqoq57 + k1(mu)*qqoq57(mu)*metric(mu) k1qqoq64 = k1qqoq64 + k1(mu)*qqoq64(mu)*metric(mu) END DO feynmanf = 8*(k1qqog57 - k1qqog75 + k1qqoq57 - k1qqoq64)*nc feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 4) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF DO mu = 0,3 k2pt(0,mu) = k5(mu) k2pt(1,mu) = k7(mu) k2pt(2,mu) = k8(mu) END DO cut2pt(0) = cut(5) cut2pt(1) = cut(7) cut2pt(2) = cut(8) cut2pt(3) = cut(6) kind2pt = 'bothloops' call twopointgf(kind2pt,k2pt,cut2pt,mumsbar,flag,g7a) traceg7a = 0.0d0 DO mu = 0,3 traceg7a = traceg7a + g7a(mu,mu)*metric(mu) END DO g7awk1k2 = 0.0d0 g7awk1k3 = 0.0d0 g7awk2k4 = 0.0d0 g7awk3k4 = 0.0d0 DO mu = 0,3 DO nu = 0,3 g7awk1k2 = g7awk1k2 & + g7a(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) g7awk1k3 = g7awk1k3 & + g7a(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu) g7awk2k4 = g7awk2k4 & + g7a(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu) g7awk3k4 = g7awk3k4 & + g7a(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) END DO END DO k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO feynmanf = -8*cf*nc*(2*g7awk3k4*k1k2 - 2*g7awk2k4*k1k3 & - 2*g7awk1k3*k2k4 + 2*g7awk1k2*k3k4 + k1k4*k2k3*traceg7a & + k1k3*k2k4*traceg7a - k1k2*k3k4*traceg7a) feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 5) THEN ! prefactor = 1.0d0 e3 = k3(0) tk33 = 0.0d0 DO mu = 1,3 tk33 = tk33 - k3(mu)**2 END DO k33 = e3**2 + tk33 IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF DO mu = 0,3 k3pt(1,mu) = -k1(mu) k3pt(2,mu) = k2(mu) k3pt(3,mu) = -k5(mu) END DO cut3pt(1) = cut(1) cut3pt(2) = cut(2) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v1q,a1q) DO mu = 0,3 k3pt(1,mu) = -k2(mu) k3pt(2,mu) = k1(mu) k3pt(3,mu) = k5(mu) END DO cut3pt(1) = cut(2) cut3pt(2) = cut(1) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v2q,a2q) DO mu = 0,3 k2pt(0,mu) = k4(mu) k2pt(1,mu) = k7(mu) k2pt(2,mu) = k8(mu) END DO cut2pt(0) = cut(4) cut2pt(1) = cut(7) cut2pt(2) = cut(8) cut2pt(3) = cut(6) call twopointqf(k2pt,cut2pt,mumsbar,flag,q47) DO mu = 0,3 k2pt(0,mu) = k6(mu) k2pt(1,mu) = -k7(mu) k2pt(2,mu) = -k8(mu) END DO cut2pt(0) = cut(6) cut2pt(1) = cut(7) cut2pt(2) = cut(8) cut2pt(3) = cut(4) call twopointqf(k2pt,cut2pt,mumsbar,flag,q67) tracev1q = 0.0d0 tracev2q = 0.0d0 DO mu = 0,3 tracev1q = tracev1q + v1q(mu,mu)*metric(mu) tracev2q = tracev2q + v2q(mu,mu)*metric(mu) END DO v1qwk3q47 = 0.0d0 v1qwq47k3 = 0.0d0 v2qwk3q67 = 0.0d0 v2qwq67k3 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v1qwk3q47 = v1qwk3q47 & + v1q(mu,nu)*k3(mu)*q47(nu)*metric(mu)*metric(nu) v1qwq47k3 = v1qwq47k3 & + v1q(mu,nu)*q47(mu)*k3(nu)*metric(mu)*metric(nu) v2qwk3q67 = v2qwk3q67 & + v2q(mu,nu)*k3(mu)*q67(nu)*metric(mu)*metric(nu) v2qwq67k3 = v2qwq67k3 & + v2q(mu,nu)*q67(mu)*k3(nu)*metric(mu)*metric(nu) END DO END DO k3q47 = 0.0d0 k3q67 = 0.0d0 DO mu = 0,3 k3q47 = k3q47 + k3(mu)*q47(mu)*metric(mu) k3q67 = k3q67 + k3(mu)*q67(mu)*metric(mu) END DO call epsilont2(a1q,k3,q47,ea1qk3q47) call epsilont2(a2q,k3,q67,ea2qk3q67) feynmanf = -4*nc*(ea1qk3q47 + ea2qk3q67 - k3q47*tracev1q & + k3q67*tracev2q + v1qwk3q47 + v1qwq47k3 - v2qwk3q67 - v2qwq67k3) feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 6) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k3pt(1,mu) = -k3(mu) k3pt(2,mu) = k4(mu) k3pt(3,mu) = -k5(mu) END DO cut3pt(1) = cut(3) cut3pt(2) = cut(4) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v3q,a3q) DO mu = 0,3 k3pt(1,mu) = -k4(mu) k3pt(2,mu) = k3(mu) k3pt(3,mu) = k5(mu) END DO cut3pt(1) = cut(4) cut3pt(2) = cut(3) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q) DO mu = 0,3 k2pt(0,mu) = k2(mu) k2pt(1,mu) = k6(mu) k2pt(2,mu) = k7(mu) END DO cut2pt(0) = cut(2) cut2pt(1) = cut(6) cut2pt(2) = cut(7) cut2pt(3) = cut(8) call twopointqf(k2pt,cut2pt,mumsbar,flag,q26) DO mu = 0,3 k2pt(0,mu) = k8(mu) k2pt(1,mu) = -k6(mu) k2pt(2,mu) = -k7(mu) END DO cut2pt(0) = cut(8) cut2pt(1) = cut(6) cut2pt(2) = cut(7) cut2pt(3) = cut(2) call twopointqf(k2pt,cut2pt,mumsbar,flag,q86) tracev3q = 0.0d0 tracev4q = 0.0d0 DO mu = 0,3 tracev3q = tracev3q + v3q(mu,mu)*metric(mu) tracev4q = tracev4q + v4q(mu,mu)*metric(mu) END DO v3qwk1q26 = 0.0d0 v3qwq26k1 = 0.0d0 v4qwk1q86 = 0.0d0 v4qwq86k1 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v3qwk1q26 = v3qwk1q26 & + v3q(mu,nu)*k1(mu)*q26(nu)*metric(mu)*metric(nu) v3qwq26k1 = v3qwq26k1 & + v3q(mu,nu)*q26(mu)*k1(nu)*metric(mu)*metric(nu) v4qwk1q86 = v4qwk1q86 & + v4q(mu,nu)*k1(mu)*q86(nu)*metric(mu)*metric(nu) v4qwq86k1 = v4qwq86k1 & + v4q(mu,nu)*q86(mu)*k1(nu)*metric(mu)*metric(nu) END DO END DO k1q26 = 0.0d0 k1q86 = 0.0d0 DO mu = 0,3 k1q26 = k1q26 + k1(mu)*q26(mu)*metric(mu) k1q86 = k1q86 + k1(mu)*q86(mu)*metric(mu) END DO call epsilont2(a3q,k1,q26,ea3qk1q26) call epsilont2(a4q,k1,q86,ea4qk1q86) feynmanf = -4*nc*(ea3qk1q26 + ea4qk1q86 - k1q26*tracev3q & + k1q86*tracev4q + v3qwk1q26 + v3qwq26k1 - v4qwk1q86 - v4qwq86k1) feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 7) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 e5 = k5(0) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF DO mu = 0,3 k3pt(1,mu) = k7(mu) k3pt(2,mu) = -k8(mu) k3pt(3,mu) = -k6(mu) END DO cut3pt(1) = cut(7) cut3pt(2) = cut(8) cut3pt(3) = cut(6) kind3pt = 'qqg/all' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v7a,a7a) DO mu = 0,3 k3pt(1,mu) = k8(mu) k3pt(2,mu) = -k7(mu) k3pt(3,mu) = k6(mu) END DO cut3pt(1) = cut(8) cut3pt(2) = cut(7) cut3pt(3) = cut(6) kind3pt = 'qqg/all' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v8a,a8a) tracev7a = 0.0d0 tracev8a = 0.0d0 DO mu = 0,3 tracev7a = tracev7a + v7a(mu,mu)*metric(mu) tracev8a = tracev8a + v8a(mu,mu)*metric(mu) END DO v7awk1k2 = 0.0d0 v7awk1k3 = 0.0d0 v7awk1k4 = 0.0d0 v7awk2k1 = 0.0d0 v7awk2k3 = 0.0d0 v7awk2k4 = 0.0d0 v7awk3k1 = 0.0d0 v7awk3k2 = 0.0d0 v7awk3k4 = 0.0d0 v7awk4k1 = 0.0d0 v7awk4k2 = 0.0d0 v7awk4k3 = 0.0d0 v8awk1k2 = 0.0d0 v8awk1k3 = 0.0d0 v8awk1k4 = 0.0d0 v8awk2k1 = 0.0d0 v8awk2k3 = 0.0d0 v8awk2k4 = 0.0d0 v8awk3k1 = 0.0d0 v8awk3k2 = 0.0d0 v8awk3k4 = 0.0d0 v8awk4k1 = 0.0d0 v8awk4k2 = 0.0d0 v8awk4k3 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v7awk1k2 = v7awk1k2 & + v7a(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) v7awk1k3 = v7awk1k3 & + v7a(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu) v7awk1k4 = v7awk1k4 & + v7a(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu) v7awk2k1 = v7awk2k1 & + v7a(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu) v7awk2k3 = v7awk2k3 & + v7a(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu) v7awk2k4 = v7awk2k4 & + v7a(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu) v7awk3k1 = v7awk3k1 & + v7a(mu,nu)*k3(mu)*k1(nu)*metric(mu)*metric(nu) v7awk3k2 = v7awk3k2 & + v7a(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu) v7awk3k4 = v7awk3k4 & + v7a(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) v7awk4k1 = v7awk4k1 & + v7a(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu) v7awk4k2 = v7awk4k2 & + v7a(mu,nu)*k4(mu)*k2(nu)*metric(mu)*metric(nu) v7awk4k3 = v7awk4k3 & + v7a(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu) v8awk1k2 = v8awk1k2 & + v8a(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) v8awk1k3 = v8awk1k3 & + v8a(mu,nu)*k1(mu)*k3(nu)*metric(mu)*metric(nu) v8awk1k4 = v8awk1k4 & + v8a(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu) v8awk2k1 = v8awk2k1 & + v8a(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu) v8awk2k3 = v8awk2k3 & + v8a(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu) v8awk2k4 = v8awk2k4 & + v8a(mu,nu)*k2(mu)*k4(nu)*metric(mu)*metric(nu) v8awk3k1 = v8awk3k1 & + v8a(mu,nu)*k3(mu)*k1(nu)*metric(mu)*metric(nu) v8awk3k2 = v8awk3k2 & + v8a(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu) v8awk3k4 = v8awk3k4 & + v8a(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) v8awk4k1 = v8awk4k1 & + v8a(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu) v8awk4k2 = v8awk4k2 & + v8a(mu,nu)*k4(mu)*k2(nu)*metric(mu)*metric(nu) v8awk4k3 = v8awk4k3 & + v8a(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a7ak1i(mu) = 0.0d0 a7ak2i(mu) = 0.0d0 a7ak3i(mu) = 0.0d0 a7ak4i(mu) = 0.0d0 a8ak1i(mu) = 0.0d0 a8ak2i(mu) = 0.0d0 a8ak3i(mu) = 0.0d0 a8ak4i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a7ak1i(mu) = a7ak1i(mu) + a7a(nu,mu)*k1(nu)*metric(nu) a7ak2i(mu) = a7ak2i(mu) + a7a(nu,mu)*k2(nu)*metric(nu) a7ak3i(mu) = a7ak3i(mu) + a7a(nu,mu)*k3(nu)*metric(nu) a7ak4i(mu) = a7ak4i(mu) + a7a(nu,mu)*k4(nu)*metric(nu) a8ak1i(mu) = a8ak1i(mu) + a8a(nu,mu)*k1(nu)*metric(nu) a8ak2i(mu) = a8ak2i(mu) + a8a(nu,mu)*k2(nu)*metric(nu) a8ak3i(mu) = a8ak3i(mu) + a8a(nu,mu)*k3(nu)*metric(nu) a8ak4i(mu) = a8ak4i(mu) + a8a(nu,mu)*k4(nu)*metric(nu) END DO END DO k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO call epsilont2(a7a,k1,k2,ea7ak1k2) call epsilont2(a7a,k1,k3,ea7ak1k3) call epsilont2(a7a,k1,k4,ea7ak1k4) call epsilont2(a7a,k2,k3,ea7ak2k3) call epsilont2(a7a,k2,k4,ea7ak2k4) call epsilont2(a7a,k3,k4,ea7ak3k4) call epsilont2(a8a,k1,k2,ea8ak1k2) call epsilont2(a8a,k1,k3,ea8ak1k3) call epsilont2(a8a,k1,k4,ea8ak1k4) call epsilont2(a8a,k2,k3,ea8ak2k3) call epsilont2(a8a,k2,k4,ea8ak2k4) call epsilont2(a8a,k3,k4,ea8ak3k4) call epsilon4(a7ak1i,k2,k3,k4,ea7ak1ik2k3k4) call epsilon4(a7ak2i,k1,k3,k4,ea7ak2ik1k3k4) call epsilon4(a7ak3i,k1,k2,k4,ea7ak3ik1k2k4) call epsilon4(a7ak4i,k1,k2,k3,ea7ak4ik1k2k3) call epsilon4(a8ak1i,k2,k3,k4,ea8ak1ik2k3k4) call epsilon4(a8ak2i,k1,k3,k4,ea8ak2ik1k3k4) call epsilon4(a8ak3i,k1,k2,k4,ea8ak3ik1k2k4) call epsilon4(a8ak4i,k1,k2,k3,ea8ak4ik1k2k3) x(1) = ea7ak1ik2k3k4 + ea7ak2ik1k3k4 - ea7ak3ik1k2k4 & - ea7ak4ik1k2k3 - ea8ak1ik2k3k4 - ea8ak2ik1k3k4 + ea8ak3ik1k2k4 & + ea8ak4ik1k2k3 x(2) = ea7ak3k4 - ea8ak3k4 + v7awk3k4 + v7awk4k3 + v8awk3k4 & + v8awk4k3 x(3) = x(1) + k1k2*x(2) x(4) = -ea7ak2k4 + ea8ak2k4 - v7awk2k4 - v7awk4k2 - v8awk2k4 & - v8awk4k2 x(5) = x(3) + k1k3*x(4) x(6) = -ea7ak2k3 + ea8ak2k3 - v7awk2k3 + v7awk3k2 - v8awk2k3 & + v8awk3k2 x(7) = x(5) + k1k4*x(6) x(8) = -ea7ak1k4 + ea8ak1k4 + k1k4*(tracev7a + tracev8a) & + v7awk1k4 - v7awk4k1 + v8awk1k4 - v8awk4k1 x(9) = x(7) + k2k3*x(8) x(10) = ea7ak1k3 - ea8ak1k3 + k1k3*(tracev7a + tracev8a) & - v7awk1k3 - v7awk3k1 - v8awk1k3 - v8awk3k1 x(11) = x(9) + k2k4*x(10) x(12) = -ea7ak1k2 + ea8ak1k2 + k1k2*(-tracev7a - tracev8a) & + v7awk1k2 + v7awk2k1 + v8awk1k2 + v8awk2k1 x(13) = x(11) + k3k4*x(12) feynmanf = 8*cf*nc*x(13) feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 8) THEN ! prefactor = 1.0d0 e6 = k6(0) tk66 = 0.0d0 e7 = k7(0) tk77 = 0.0d0 DO mu = 1,3 tk66 = tk66 - k6(mu)**2 tk77 = tk77 - k7(mu)**2 END DO k66 = e6**2 + tk66 k77 = e7**2 + tk77 IF (cut(6)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk66) ELSE prefactor = prefactor/k66 END IF IF (cut(7)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk77) ELSE prefactor = prefactor/k77 END IF DO mu = 0,3 k3pt(1,mu) = -k1(mu) k3pt(2,mu) = k2(mu) k3pt(3,mu) = -k5(mu) END DO cut3pt(1) = cut(1) cut3pt(2) = cut(2) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v1q,a1q) DO mu = 0,3 k3pt(1,mu) = -k4(mu) k3pt(2,mu) = k3(mu) k3pt(3,mu) = k8(mu) END DO cut3pt(1) = cut(4) cut3pt(2) = cut(3) cut3pt(3) = cut(8) kind3pt = 'qqp/qqg' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q) a1qda4q = 0.0d0 v1qdv4q = 0.0d0 DO mu = 0,3 DO nu = 0,3 a1qda4q = a1qda4q + a1q(mu,nu)*a4q(mu,nu)*metric(mu)*metric(nu) v1qdv4q = v1qdv4q + v1q(mu,nu)*v4q(mu,nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a1qik6(mu) = 0.0d0 a1qik7(mu) = 0.0d0 a4qik6(mu) = 0.0d0 a4qik7(mu) = 0.0d0 v1qik6(mu) = 0.0d0 v1qik7(mu) = 0.0d0 v4qik6(mu) = 0.0d0 v4qik7(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a1qik6(mu) = a1qik6(mu) + a1q(mu,nu)*k6(nu)*metric(nu) a1qik7(mu) = a1qik7(mu) + a1q(mu,nu)*k7(nu)*metric(nu) a4qik6(mu) = a4qik6(mu) + a4q(mu,nu)*k6(nu)*metric(nu) a4qik7(mu) = a4qik7(mu) + a4q(mu,nu)*k7(nu)*metric(nu) v1qik6(mu) = v1qik6(mu) + v1q(mu,nu)*k6(nu)*metric(nu) v1qik7(mu) = v1qik7(mu) + v1q(mu,nu)*k7(nu)*metric(nu) v4qik6(mu) = v4qik6(mu) + v4q(mu,nu)*k6(nu)*metric(nu) v4qik7(mu) = v4qik7(mu) + v4q(mu,nu)*k7(nu)*metric(nu) END DO END DO DO mu = 0,3 DO nu = 0,3 a1qzv4q(mu,nu) = 0.0d0 a4qzv1q(mu,nu) = 0.0d0 END DO END DO DO mu = 0,3 DO nu = 0,3 DO tau = 0,3 a1qzv4q(mu,nu) = a1qzv4q(mu,nu) & + a1q(tau,mu)*v4q(tau,nu)*metric(tau) a4qzv1q(mu,nu) = a4qzv1q(mu,nu) & + a4q(tau,mu)*v1q(tau,nu)*metric(tau) END DO END DO END DO a1qik6a4qik7 = 0.0d0 a1qik7a4qik6 = 0.0d0 k6k7 = 0.0d0 v1qik6v4qik7 = 0.0d0 v1qik7v4qik6 = 0.0d0 DO mu = 0,3 a1qik6a4qik7 = a1qik6a4qik7 + a1qik6(mu)*a4qik7(mu)*metric(mu) a1qik7a4qik6 = a1qik7a4qik6 + a1qik7(mu)*a4qik6(mu)*metric(mu) k6k7 = k6k7 + k6(mu)*k7(mu)*metric(mu) v1qik6v4qik7 = v1qik6v4qik7 + v1qik6(mu)*v4qik7(mu)*metric(mu) v1qik7v4qik6 = v1qik7v4qik6 + v1qik7(mu)*v4qik6(mu)*metric(mu) END DO call epsilont2(a1qzv4q,k6,k7,ea1qzv4qk6k7) call epsilont2(a4qzv1q,k6,k7,ea4qzv1qk6k7) feynmanf = 4*nc*(a1qik6a4qik7 + a1qik7a4qik6 + ea1qzv4qk6k7 & - ea4qzv1qk6k7 - a1qda4q*k6k7 + k6k7*v1qdv4q - v1qik6v4qik7 & - v1qik7v4qik6) feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 9) THEN ! prefactor = 1.0d0 DO mu = 0,3 k2pt(0,mu) = k1(mu) k2pt(1,mu) = k5(mu) k2pt(2,mu) = k6(mu) END DO cut2pt(0) = cut(1) cut2pt(1) = cut(5) cut2pt(2) = cut(6) cut2pt(3) = cut(3) call twopointqf(k2pt,cut2pt,mumsbar,flag,q15) DO mu = 0,3 k2pt(0,mu) = k4(mu) k2pt(1,mu) = -k7(mu) k2pt(2,mu) = -k8(mu) END DO cut2pt(0) = cut(4) cut2pt(1) = cut(7) cut2pt(2) = cut(8) cut2pt(3) = cut(2) call twopointqf(k2pt,cut2pt,mumsbar,flag,q47) q15q47 = 0.0d0 DO mu = 0,3 q15q47 = q15q47 + q15(mu)*q47(mu)*metric(mu) END DO feynmanf = -8*nc*q15q47 feynmanf = feynmanf*prefactor ! ELSE IF (graphnumber .EQ. 10) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 e5 = k5(0) tk55 = 0.0d0 e6 = k6(0) tk66 = 0.0d0 e7 = k7(0) tk77 = 0.0d0 e8 = k8(0) tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 tk66 = tk66 - k6(mu)**2 tk77 = tk77 - k7(mu)**2 tk88 = tk88 - k8(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 k66 = e6**2 + tk66 k77 = e7**2 + tk77 k88 = e8**2 + tk88 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF IF (cut(6)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk66) ELSE prefactor = prefactor/k66 END IF IF (cut(7)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk77) ELSE prefactor = prefactor/k77 END IF IF (cut(8)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk88) ELSE prefactor = prefactor/k88 END IF k1k3 = 0.0d0 k2k4 = 0.0d0 k6k7 = 0.0d0 DO mu = 0,3 k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k6k7 = k6k7 + k6(mu)*k7(mu)*metric(mu) END DO feynmanf = -64*cf*k1k3*k2k4*k6k7 feynmanf = feynmanf*prefactor ! END IF ! RETURN END function feynmanf ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Feynman integrand in Feynman gauge, Born level ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function feynman0f(graphnumber,kin,cut) ! use beowulf_parameters implicit none ! In: integer :: graphnumber real(kind=dbl) :: kin(0:3*size-1,0:3) logical :: cut(3*size-1) ! Out: complex(kind=dbl) :: feynman0f ! ! Feynman integrand function for graph GRAPHNUMBER ! with momenta KIN and cut specified by CUT. This subroutine ! is for the Born graphs in Feynman gauge. ! Early version: 17 July 1994. ! This version written by Mathematica code of 7 February 2002 on ! 8 Feb 2002. ! Input variables mumsbar and flag removed 1 September 2002, DES. ! Calculation changed to real, 3 January 2003. ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) real(kind=dbl), parameter :: gn(0:3) = (/1.0d0,0.0d0,0.0d0,0.0d0/) ! integer :: mu real(kind=dbl) :: k1(0:3),k2(0:3),k3(0:3),k4(0:3),k5(0:3) real(kind=dbl) :: e1,e2,e3,e4,e5 real(kind=dbl) :: k11,k22,k33,k44,k55 real(kind=dbl) :: tk11,tk22,tk33,tk44,tk55 real(kind=dbl) :: prefactor real(kind=dbl) :: result ! real(kind=dbl) :: k1k2,k1k4,k1k5,k2k3,k2k5 ! DO mu = 0,3 k1(mu) = kin(1,mu) k2(mu) = kin(2,mu) k3(mu) = kin(3,mu) k4(mu) = kin(4,mu) k5(mu) = kin(5,mu) END DO result = 0.0d0 ! !------ ! IF (graphnumber .EQ. 11) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 e5 = k5(0) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/sqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/sqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/sqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/sqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/sqrt(-tk55) ELSE prefactor = prefactor/k55 END IF k1k2 = 0.0d0 k1k5 = 0.0d0 k2k5 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k5 = k1k5 + k1(mu)*k5(mu)*metric(mu) k2k5 = k2k5 + k2(mu)*k5(mu)*metric(mu) END DO result = -32*cf*(k1k5*k22 - 2*k1k2*k2k5)*nc result = result*prefactor ! ELSE IF (graphnumber .EQ. 12) THEN ! prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 e5 = k5(0) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/sqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/sqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/sqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/sqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/sqrt(-tk55) ELSE prefactor = prefactor/k55 END IF k1k4 = 0.0d0 k2k3 = 0.0d0 DO mu = 0,3 k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) END DO result = 32*cf*k1k4*k2k3*nc result = result*prefactor ! END IF ! feynman0f = result RETURN END function feynman0f ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Vertex and propagator functions in Feynman gauge ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine twopointgf(kind2pt,k2pt,cut2pt,mumsbar,flag,out) ! use beowulf_parameters implicit none ! In: character(len=9) :: kind2pt complex(kind=dbl) :: k2pt(0:2,0:3) logical :: cut2pt(0:3) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: out(0:3,0:3) ! ! Calculates the one loop gluon two-point function, including the ! adjoining propagators *in Feynman gauge* with the modification that ! it is multiplied by a Coulomb gauge projection matrix on the left ! and on the right. ! ! kind2pt: ! GLUONLOOP gluon self-energy with a gluon (including ghost) loop ! QUARKLOOP gluon self-energy with a quark loop ! BOTHLOOPS the sum of these ! ! k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part) ! k2pt(1,mu): 1st momentum in loop (kplus for the space part) ! k2pt(2,mu): 2nd momentum in loop (kminus for the space part) ! ! cut2pt(0): whether incoming line is cut ! cut2pt(1): whether 1st internal line is cut ! cut2pt(2): whether 2nd internal line is cut ! cut2pt(3): whether outgoing line is cut ! ! mumsbar is the MSbar renormalization scale. ! ! The result is the two point function out(mu,nu) with a certain ! normalization. Specifically, for the cut gluon self-energy ! graph, out(mu,nu) is {\cal M}_g^{\mu\nu} ! divided by (\alpha_s/(4\pi)) * 1/(1+\Delta) and divided ! by 2\omega_+ * 2\omega_- *\bar q^2. The factor by which we divide ! consists of ! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and ! one (2\pi)^{-3} for each loop that is factored out of each ! graph in our program. ! * (d\vec l)/(d\bar q^2 dx d\phi) ! = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) ! * 4 \pi {\cal Q} \bar q^2 included in the relation between ! {\cal I}[real] and {\cal M}_g^{\mu\nu} ! ! In the case of the virtual gluon self-energy graphs ! with an adjacent propagator cut, out(mu,nu) is {\cal W}_g^{\mu\nu} ! divided by the same factors. ! ! 16 December 2001 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf integer :: mu,nu complex(kind=dbl) :: complexsqrt complex(kind=dbl) :: kplus(1:3),kminus(1:3),ell(1:3),q(1:3) complex(kind=dbl) :: calqsq, omegaplussq,omegaminussq complex(kind=dbl) :: calq,omegaplus,omegaminus,q0 complex(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq complex(kind=dbl) :: ellt(1:3) complex(kind=dbl) :: elltsq,onem2x1mx complex(kind=dbl) :: temp complex(kind=dbl) :: bareprop(1:3,1:3) complex(kind=dbl) :: ntt,nll,nee,nel complex(kind=dbl) :: prefactor complex(kind=dbl) :: termtt,termll complex(kind=dbl) :: at0 complex(kind=dbl) :: ntt0 complex(kind=dbl) :: net0 complex(kind=dbl) :: utt,net ! ! Some auxilliary variables, including ! CALQ = {\cal Q} ! OMEGAPLUS = \omega_+ ! OMEGAMINUS = \omega_- ! DELTAP1 = \Delta + 1 ! TWOXM1 = 2 x - 1 ! X1MX = x (1-x) ! ELLT(mu) = l_T^\mu ! ELLTSQ = (\vec l_T)^2 ! Q(mu) = the incoming *three*-momentum ! Q0 = the incoming energy ! DO mu = 1,3 kplus(mu) = k2pt(1,mu) kminus(mu) = k2pt(2,mu) ell(mu) = (kplus(mu) - kminus(mu))/2.0d0 q(mu) = k2pt(0,mu) END DO q0 = k2pt(0,0) calqsq = 0.0d0 omegaplussq = 0.0d0 omegaminussq = 0.0d0 DO mu = 1,3 calqsq = calqsq + q(mu)**2 omegaplussq = omegaplussq + kplus(mu)**2 omegaminussq = omegaminussq + kminus(mu)**2 END DO calq = complexsqrt(calqsq) omegaplus = complexsqrt(omegaplussq) omegaminus = complexsqrt(omegaminussq) deltap1 = (omegaplus + omegaminus)/calq delta = deltap1 - 1.0d0 twoxm1 = (omegaplus - omegaminus)/calq x1mx = (1.0d0 - twoxm1**2)/4.0d0 qbarsq = calqsq * delta * (delta + 2.0d0) DO mu = 1,3 ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu) END DO elltsq = qbarsq*x1mx onem2x1mx = 1.0d0 - 2.0d0*x1mx ! ! The gluon propagator in Coulomb gauge for an on-shell gluon ! with three-momentum Q(mu). This is the space components only. ! DO mu = 1,3 bareprop(mu,mu) = 1.0d0 - q(mu)**2/calqsq DO nu = mu+1,3 temp = - q(mu)*q(nu)/calqsq bareprop(mu,nu) = temp bareprop(nu,mu) = temp END DO END DO ! IF (cut2pt(1).AND.cut2pt(2)) THEN ! ! We have the contribution from a cut self-energy diagram. ! We compute the coefficients for, alternatively, the gluon loop ! or the quark loop. We use the name NLL for Ntt and NEL for NEt. ! IF (kind2pt.EQ.'gluonloop') THEN ! ntt = 2.0d0*nc*( - 1.0d0 + x1mx) nll = 4.0d0*nc*x1mx nee = - nc*(1.0d0 + 4.0d0*x1mx) nel = - 2.0d0*nc*twoxm1 ! ELSE IF (kind2pt.EQ.'quarkloop') THEN ! ntt = nf*onem2x1mx nll = - 4.0d0*nf*x1mx nee = 4.0d0*nf*x1mx nel = 2.0d0*nf*twoxm1 ! ELSE IF (kind2pt.EQ.'bothloops') THEN ! ntt = 2.0d0*nc*( - 1.0d0 + x1mx) nll = 4.0d0*nc*x1mx nee = - nc*(1.0d0 + 4.0d0*x1mx) nel = - 2.0d0*nc*twoxm1 ! ntt = ntt + nf*onem2x1mx nll = nll - 4.0d0*nf*x1mx nee = nee + 4.0d0*nf*x1mx nel = nel + 2.0d0*nf*twoxm1 ! ELSE write(nout,*)'Unrecognized type in subroutine twopointg.' stop END IF ! ! With the coefficients in hand, we compute the result. ! prefactor = 1.0d0/(4.0d0*omegaplus*omegaminus*qbarsq) ! out(0,0) = prefactor*qbarsq/calqsq*nee DO mu = 1,3 temp = prefactor*q0/deltap1/calqsq*nel*ellt(mu) out(0,mu) = temp out(mu,0) = temp END DO DO mu = 1,3 DO nu = 1,3 termtt = ntt*bareprop(mu,nu) termll = nll*(ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu)) out(mu,nu) = prefactor*(termtt + termll) END DO END DO ! ! Alternative for IF (CUT2PT(1).AND.CUT2PT(2)) THEN .... ! ELSE IF (cut2pt(0).OR.cut2pt(3)) THEN ! ! We have the contribution from a virtual self-energy diagram ! with one of the neighboring propagators cut. ! We compute the coefficients for, alternatively, the gluon loop ! or the quark loop. ! IF (kind2pt.EQ.'gluonloop') THEN ! temp = mumsbar**2*exp(2.0d0) at0 = - 2.0d0*nc*temp/(qbarsq + temp) temp = mumsbar**2*exp(5.0d0/3.0d0) at0 = at0 + 2.0d0*nc*x1mx*temp/(qbarsq + temp) ntt0 = 4.0d0*nc*x1mx net0 = - 2.0d0*nc*twoxm1 ! utt = at0 ntt = ntt0 net = net0 ! ELSE IF (kind2pt.EQ.'quarkloop') THEN ! ! Here AT1 = AT2 = NTT1 = NTT2 = NET1 = NET2 = 0. ! temp = mumsbar**2*exp(2.0d0) at0 = nf*temp/(qbarsq + temp) temp = mumsbar**2*exp(8.0d0/3.0d0) at0 = at0 - 2.0d0*nf*x1mx*temp/(qbarsq + temp) ntt0 = - 4.0d0*nf*x1mx net0 = 2.0d0*nf*twoxm1 ! utt = at0 ntt = ntt0 net = net0 ! ELSE IF (kind2pt.EQ.'bothloops') THEN ! temp = mumsbar**2*exp(2.0d0) at0 = - 2.0d0*nc*temp/(qbarsq + temp) temp = mumsbar**2*exp(5.0d0/3.0d0) at0 = at0 + 2.0d0*nc*x1mx*temp/(qbarsq + temp) ntt0 = 4.0d0*nc*x1mx net0 = - 2.0d0*nc*twoxm1 ! utt = at0 ntt = ntt0 net = net0 ! temp = mumsbar**2*exp(2.0d0) at0 = nf*temp/(qbarsq + temp) temp = mumsbar**2*exp(8.0d0/3.0d0) at0 = at0 - 2.0d0*nf*x1mx*temp/(qbarsq + temp) ntt0 = - 4.0d0*nf*x1mx net0 = 2.0d0*nf*twoxm1 ! utt = utt + at0 ntt = ntt + ntt0 net = net + net0 ! ELSE write(nout,*)'Unrecognized type in subroutine twopointg.' stop END IF ! ! With the coefficients in hand, we compute the result. There is ! an extra factor 1 + \Delta compared to the real self-energy ! graphs because {\cal W} lacks the factor 1/(1 + \Delta) that ! appears in {\cal M}. ! ! Also, we divide by 2 because we will get this contribution ! twice, once when one adjacent propagator is cut and onece ! when the other adjacent propagator is cut. ! prefactor = - deltap1/(4.0d0*omegaplus*omegaminus*qbarsq) prefactor = 0.5d0*prefactor ! out(0,0) = 0.0d0 DO mu = 1,3 temp = prefactor*q0/deltap1/calqsq/(1 + qbarsq/calqsq) temp = temp*net*ellt(mu) out(0,mu) = temp out(mu,0) = temp END DO DO mu = 1,3 DO nu = 1,3 termtt = utt*bareprop(mu,nu) temp = ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu) termll = ntt/(1 + qbarsq/calqsq)*temp out(mu,nu) = prefactor*(termtt + termll) END DO END DO ! ! Closing for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....ELSE IF ... ! ELSE write(nout,*)'For a gluon two point function,' write(nout,*)'either the self-energy graph must be cut' write(nout,*)'or one of the neighboring propagators' write(nout,*)'must be cut.' stop END IF ! RETURN END subroutine twopointgf ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine twopointqf(k2pt,cut2pt,mumsbar,flag,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: k2pt(0:2,0:3) logical :: cut2pt(0:3) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: out(0:3) ! ! Calculates the one loop quark two-point function, including the ! adjoining propagators. ! ! k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part) ! k2pt(1,mu): 1st momentum in loop (kplus for the space part) ! k2pt(2,mu): 2nd momentum in loop (kminus for the space part) ! ! cut2pt(0): whether incoming line is cut ! cut2pt(1): whether 1st internal line is cut ! cut2pt(2): whether 2nd internal line is cut ! cut2pt(3): whether outgoing line is cut ! ! mumsbar is the MSbar renormalization scale. ! ! The two point function, with a certain normalization, ! is represented as out^mu gamma_mu. ! For the real quark self-energy graphs, out^{\mu} gamma_{\mu} ! is {\cal M}_q divided by ! (\alpha_s/(4\pi)) * 1/(1+\Delta) ! and divided by ! 4 * \omega_+ * \omega_- * \bar q^2. ! The factor by which we divide consists of ! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and ! one (2\pi)^{-3} for each loop that is factored out of each ! graph in our program. ! * (d\vec l)/(d\bar q^2 dx d\phi) ! = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) ! * 4 \pi {\cal Q} \bar q^2 included in the relation between ! {\cal I}[real] and {\cal M}_q. ! ! In the case of the virtual quark self-energy graphs with ! one of the adjacent propagators cut, OUT^{\mu} gamma_{\mu} ! is {\cal W}_q divided by the same factors. ! ! In the case of the virtual quark self-energy graphs with ! the adjacent propagators *not* cut, OUT^{\mu} gamma_{\mu} ! is W_q divided by ! (\alpha_s/(4\pi)) * 1/(1+\Delta) ! and divided by ! 2 * \omega_+ * \omega_- * (\bar q^2 - q^2) * q^2/{\cal Q}. ! The factor by which we divide consists of ! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and ! one (2\pi)^{-3} for each loop that is factored out of each ! graph in our program. ! * (d\vec l)/(d\bar q^2 dx d\phi) ! = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) ! * 2 \pi q^2 (\bar q^2 - q^2) included in the relation between ! {\cal I}[all uncut] and W_q. ! ! 16 December 2001 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf complex(kind=dbl) :: complexsqrt integer :: mu complex(kind=dbl) :: kplus(1:3),kminus(1:3),ell(1:3),q(1:3) complex(kind=dbl) :: calqsq,omegaplussq,omegaminussq complex(kind=dbl) :: calq,omegaplus,omegaminus complex(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq complex(kind=dbl) :: ellt(1:3) complex(kind=dbl) :: elltsq,onem2x1mx,x complex(kind=dbl) :: temp,tempsq complex(kind=dbl) :: nl,ne,nt,prefactor complex(kind=dbl) :: bl0 complex(kind=dbl) :: nl0 complex(kind=dbl) :: nt0 complex(kind=dbl) :: ul,vl,vt complex(kind=dbl) :: q0,qsq complex(kind=dbl) :: be0 complex(kind=dbl) :: ue ! ! Some auxilliary variables, including ! CALQ = {\cal Q} ! OMEGAPLUS = \omega_+ ! OMEGAMINUS = \omega_- ! DELTAP1 = \Delta + 1 ! TWOXM1 = 2 x - 1 ! X1MX = x (1-x) ! ELLT(mu) = l_T^\mu ! ELLTSQ = (\vec l_T)^2 ! Q(mu) = the incoming *three*-momentum ! Q0 = the incoming energy ! DO mu = 1,3 kplus(mu) = k2pt(1,mu) kminus(mu) = k2pt(2,mu) ell(mu) = (kplus(mu) - kminus(mu))/2.0d0 q(mu) = k2pt(0,mu) END DO q0 = k2pt(0,0) calqsq = 0.0d0 omegaplussq = 0.0d0 omegaminussq = 0.0d0 DO mu = 1,3 calqsq = calqsq + q(mu)**2 omegaplussq = omegaplussq + kplus(mu)**2 omegaminussq = omegaminussq + kminus(mu)**2 END DO calq = complexsqrt(calqsq) omegaplus = complexsqrt(omegaplussq) omegaminus = complexsqrt(omegaminussq) deltap1 = (omegaplus + omegaminus)/calq delta = deltap1 - 1.0d0 twoxm1 = (omegaplus - omegaminus)/calq x1mx = (1.0d0 - twoxm1**2)/4.0d0 qbarsq = calqsq * delta * (delta + 2.0d0) DO mu = 1,3 ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu) END DO elltsq = qbarsq*x1mx onem2x1mx = 1.0d0 - 2.0d0*x1mx x = (twoxm1 + 1.0d0)/2.0d0 ! ! Now we will go through these possible cut structures and ! calculate the terms contributing to out(mu). ! IF ( cut2pt(1).AND.cut2pt(2) ) THEN ! ! First possibility for cut structure: a cut self-energy diagram. ! Here TEMP = 2 x + Delta. ! temp = twoxm1 + deltap1 tempsq = temp**2 nl = 4.0d0*x1mx + twoxm1*temp nl = cf*nl ne = 2.0d0*cf*(1.0d0 - x) nt = 2.0d0*cf ! prefactor = 1.0d0/(4.0d0*omegaplus*omegaminus*qbarsq) out(0) = prefactor*q0/deltap1*(nl + delta*ne) DO mu = 1,3 out(mu) = prefactor*(nl*q(mu) + nt*ellt(mu)) END DO ! ELSE IF ( cut2pt(0).OR.cut2pt(3) ) THEN ! ! Second possibility for cut structure: a virtual self-energy ! with an adjacent propagator cut. ! temp = mumsbar**2 * exp(1.0d0) bl0 = cf*temp/(qbarsq + temp) nl0 = cf*twoxm1 nt0 = 2.0d0*cf ul = bl0 vl = nl0 vt = nt0 ! ! We divide by 2 because we will get this contribution ! twice, once when one adjacent propagator is cut and once ! when the other adjacent propagator is cut. ! prefactor = deltap1/(4.0d0*omegaplus*omegaminus*qbarsq) prefactor = 0.5d0*prefactor ! temp = ul + vl/(1.0d0 + qbarsq/calqsq) out(0) = - prefactor*q0*temp DO mu = 1,3 out(mu) = - prefactor*(temp*q(mu) & + vt*ellt(mu)/(1.0d0 + qbarsq/calqsq)) END DO ! ELSE ! ! Third possibility for cut structure: a virtual self-energy ! with *no* adjacent propagator cut. ! qsq = q0**2 - calqsq ! temp = mumsbar**2 * exp(1.0d0) bl0 = (qsq + temp)/(qbarsq + temp) bl0 = cf*bl0 be0 = 0.0d0 ul = bl0 ue = be0 ! prefactor = 2.0d0*omegaplus*omegaminus*qsq*(qbarsq - qsq) prefactor = deltap1*calq/prefactor out(0) = - prefactor*q0*(ul + qsq/calqsq*ue) DO mu = 1,3 out(mu) = - prefactor*q(mu)*ul END DO ! ! Completion of IF ... block for cut structure. ! END IF ! RETURN END subroutine twopointqf ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,hv,ha) ! use beowulf_parameters implicit none ! In: character(len=7) :: kind3pt complex(kind=dbl) :: k3pt(3,0:3) logical :: cut3pt(3) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: hv(0:3,0:3),ha(0:3,0:3) ! ! The unintegrated quark-antiquark-gluon three point function ! for the graph with flavors labelled by KIND3PT. ! ! KIND3PT has the form abc/def where a,...,f are chosen from ! Q,G,P. Here Q denotes "quark" or "antiquark", G denotes "gluon", ! and P denotes "photon". The external lines have flavors a,b,c ! and the internal lines have flavors d,e,f. The possibilities ! are QQG/QQG, QQG/GGQ, and QQP/QQG. There is also QQG/ALL, which ! gives the sum of the results for QQG/QQG and QQG/GGQ. ! ! The unintegrated three-point function \Gamma^\mu can be decomposed ! into a function HV^\mu_\nu \gamma^\mu plus a function ! HA^\mu_\nu I \gamma^\mu \gamma_5 (all times a t^a color matrix or a ! unit color matrix in the case of a QQP vertex). This subroutine ! calculates the functions HV^{\mu\nu} and HA^{\mu\nu}. The arguments ! are the momenta k3pt(1,mu), k3pt(2,mu), k3pt(3,mu), of the propagators ! around the loop. ! ! The variable cut3pt(j) is .true. if line j is cut, .false. otherwise. ! If the line is cut, the corresponding energy is set by the calling ! programs to be k0 = + |\vec k| or else k0 = - |\vec k|. (Here ! |\vec k| is a shorthand for sqrt(\vec k^2), not the square root of ! \vec k dotted into its complex conjugate.) This subroutine supplies a ! factor k(j)^2 for uncut propagators and 2 sqrt(\vec k^2) for a cut ! propagator. For a virtual loop, subroutine vertex will be called six ! times, once with each of the three propagators cut and k0 = + |\vec k| ! and once with each of the three propagators cut and k0 = - |\vec k|. ! Then it will be called with no propagator cut, which implies that it ! should supply the renormalization counter term. ! ! This version in Feynman gauge. ! 31 December 2001 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf complex(kind=dbl) :: complexsqrt ! complex(kind=dbl), parameter :: nvec(0:3) = & (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) real(kind=dbl), parameter :: g(0:3,0:3) = reshape( & (/1.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0,-1.0d0, 0.0d0, 0.0d0, & 0.0d0, 0.0d0,-1.0d0, 0.0d0, & 0.0d0, 0.0d0, 0.0d0,-1.0d0/)& ,(/4,4/)) ! complex(kind=dbl) :: tk11,tk22,tk33,tk12,tk23,tk13 complex(kind=dbl) :: k11,k22,k33,k12,k23,k13 complex(kind=dbl) :: e1,e2,e3 complex(kind=dbl) :: c1,c2,c3,c4,c5,c6,c7,c8,c9 complex(kind=dbl) :: c10,c11,c12,c13,c14,c15,c16,c17 complex(kind=dbl) :: temp,prefactor integer :: mu,nu complex(kind=dbl) :: k1(0:3),k2(0:3),k3(0:3) complex(kind=dbl) :: epsn1(0:3,0:3),epsn2(0:3,0:3),epsn3(0:3,0:3) complex(kind=dbl) :: eps12(0:3,0:3),eps13(0:3,0:3),eps23(0:3,0:3) complex(kind=dbl) :: epsn12(0:3),epsn13(0:3),epsn23(0:3),eps123(0:3) complex(kind=dbl) :: tl(0:3),omegasq,omega,cr1,cr2,cr3 integer :: ncut,p ! !----- ! ncut = 0 DO p=1,3 IF (cut3pt(p)) THEN ncut = ncut + 1 END IF END DO ! IF ((ncut.GT.1).OR.(flag.NE.'renormalize 3 pt')) THEN ! ! If NCUT = 1, we have a virtual loop. In this case, one of the ! possibilities is the renormalization counter term, for which ! FLAG would have been set to 'renormalize 3 pt'. Thus we get ! here is we do *not* have the the renormalization counter term. ! (Note that we could have NCUT = 2 but FLAG = 'renormalize 3 pt' ! in the case that there are two three point functions and ours ! is cut but the other one is virtual and needs to be renormalized.) ! ! First, dot products and energies. The dot products between vectors ! omitting their mu = 0 parts (\tilde vector) are denoted TKij. ! tk11 = (0.0d0,0.0d0) tk22 = (0.0d0,0.0d0) tk33 = (0.0d0,0.0d0) tk12 = (0.0d0,0.0d0) tk23 = (0.0d0,0.0d0) tk13 = (0.0d0,0.0d0) DO mu = 1,3 tk11 = tk11 - k3pt(1,mu)*k3pt(1,mu) tk22 = tk22 - k3pt(2,mu)*k3pt(2,mu) tk33 = tk33 - k3pt(3,mu)*k3pt(3,mu) tk12 = tk12 - k3pt(1,mu)*k3pt(2,mu) tk23 = tk23 - k3pt(2,mu)*k3pt(3,mu) tk13 = tk13 - k3pt(1,mu)*k3pt(3,mu) END DO e1 = k3pt(1,0) e2 = k3pt(2,0) e3 = k3pt(3,0) k11 = e1*e1 + tk11 k22 = e2*e2 + tk22 k33 = e3*e3 + tk33 k12 = e1*e2 + tk12 k23 = e2*e3 + tk23 k13 = e1*e3 + tk13 ! ! We need the factor equal to 1/k^2 for an uncut propagator ! and 1/ 2|E| for a cut propagator. ! prefactor = (1.0d0,0.0d0) IF (.NOT.cut3pt(1)) THEN prefactor = prefactor/k11 ELSE prefactor = prefactor/(2.0d0*complexsqrt(-tk11)) END IF IF (.NOT.cut3pt(2)) THEN prefactor = prefactor/k22 ELSE prefactor = prefactor/(2.0d0*complexsqrt(-tk22)) END IF IF (.NOT.cut3pt(3)) THEN prefactor = prefactor/k33 ELSE prefactor = prefactor/(2.0d0*complexsqrt(-tk33)) END IF ! !------------------------ ! First, we calculate hv. !------------------------ ! Generate the coefficients for the hv, depending on KIND3PT. ! IF (kind3pt.EQ.'qqg/qqg') THEN ! c1 = k12/nc c2 = 0.0d0 c3 = 0.0d0 c4 = 0.0d0 c5 = 0.0d0 c6 = 0.0d0 c7 = 0.0d0 c8 = 0.0d0 c9 = 0.0d0 c10 = -(1.0d0/nc) c11 = 0.0d0 c12 = -(1.0d0/nc) c13 = 0.0d0 c14 = 0.0d0 c15 = 0.0d0 c16 = 0.0d0 c17 = 0.0d0 ! ELSE IF (kind3pt.EQ.'qqg/ggq') THEN ! c1 = -((k13 + k23)*nc)/2.0d0 c2 = 0.0d0 c3 = 0.0d0 c4 = 0.0d0 c5 = 0.0d0 c6 = 0.0d0 c7 = 0.0d0 c8 = 0.0d0 c9 = 0.0d0 c10 = 0.0d0 c11 = -nc/2.0d0 c12 = 0.0d0 c13 = 0.0d0 c14 = -nc/2.0d0 c15 = -nc/2.0d0 c16 = -nc/2.0d0 c17 = 0.0d0 ! ELSE IF (kind3pt.EQ.'qqg/all') THEN ! c1 = k12/nc c2 = 0.0d0 c3 = 0.0d0 c4 = 0.0d0 c5 = 0.0d0 c6 = 0.0d0 c7 = 0.0d0 c8 = 0.0d0 c9 = 0.0d0 c10 = -(1.0d0/nc) c11 = 0.0d0 c12 = -(1.0d0/nc) c13 = 0.0d0 c14 = 0.0d0 c15 = 0.0d0 c16 = 0.0d0 c17 = 0.0d0 ! c1 = c1 - ((k13 + k23)*nc)/2.0d0 c11 = c11 - nc/2.0d0 c14 = c14 - nc/2.0d0 c15 = c15 - nc/2.0d0 c16 = c16 - nc/2.0d0 ! ELSE IF (kind3pt.EQ.'qqp/qqg') THEN ! c1 = -2.0d0*cf*k12 c2 = 0.0d0 c3 = 0.0d0 c4 = 0.0d0 c5 = 0.0d0 c6 = 0.0d0 c7 = 0.0d0 c8 = 0.0d0 c9 = 0.0d0 c10 = 2.0d0*cf c11 = 0.0d0 c12 = 2.0d0*cf c13 = 0.0d0 c14 = 0.0d0 c15 = 0.0d0 c16 = 0.0d0 c17 = 0.0d0 ! ELSE write(nout,*)'Wrong kind in subroutine vertex.' stop END IF ! ! Now we have the coefficients, so we can calculate hv. ! DO mu = 0,3 DO nu = 0,3 ! temp = c1*g(mu,nu) & + c2*nvec(mu)*nvec(nu) & + c3*nvec(mu)*k3pt(1,nu) & + c4*nvec(mu)*k3pt(2,nu) & + c5*nvec(mu)*k3pt(3,nu) & + c6*k3pt(1,mu)*nvec(nu) & + c7*k3pt(2,mu)*nvec(nu) & + c8*k3pt(3,mu)*nvec(nu) & + c9*k3pt(1,mu)*k3pt(1,nu) & + c10*k3pt(1,mu)*k3pt(2,nu) & + c11*k3pt(1,mu)*k3pt(3,nu) & + c12*k3pt(2,mu)*k3pt(1,nu) & + c13*k3pt(2,mu)*k3pt(2,nu) & + c14*k3pt(2,mu)*k3pt(3,nu) & + c15*k3pt(3,mu)*k3pt(1,nu) & + c16*k3pt(3,mu)*k3pt(2,nu) & + c17*k3pt(3,mu)*k3pt(3,nu) ! hv(mu,nu) = prefactor * temp ! END DO END DO ! !------------------------ ! Next, we calculate ha. !------------------------ ! ! We need certain vectors and tensors made by dotting vectors ! into the epsilon tensor. ! DO mu = 0,3 k1(mu) = k3pt(1,mu) k2(mu) = k3pt(2,mu) k3(mu) = k3pt(3,mu) END DO call epsilon1n(k1,epsn1) call epsilon1n(k2,epsn2) call epsilon1n(k3,epsn3) call epsilon2(k1,k2,eps12) call epsilon2(k1,k3,eps13) call epsilon2(k2,k3,eps23) call epsilon2n(k1,k2,epsn12) call epsilon2n(k1,k3,epsn13) call epsilon2n(k2,k3,epsn23) call epsilon3(k1,k2,k3,eps123) ! ! Generate the coefficients for the hv, depending on KIND3PT. ! IF (kind3pt.EQ.'qqg/qqg') THEN ! c1 = 0.0d0 c2 = 0.0d0 c3 = 0.0d0 c4 = -(1.0d0/nc) c5 = 0.0d0 c6 = 0.0d0 c7 = 0.0d0 c8 = 0.0d0 c9 = 0.0d0 c10 = 0.0d0 c11 = 0.0d0 c12 = 0.0d0 c13 = 0.0d0 c14 = 0.0d0 c15 = 0.0d0 c16 = 0.0d0 c17 = 0.0d0 ! ELSE IF (kind3pt.EQ.'qqg/ggq') THEN ! c1 = 0.0d0 c2 = 0.0d0 c3 = 0.0d0 c4 = 0.0d0 c5 = (3.0d0*nc)/2.0d0 c6 = (-3.0d0*nc)/2.0d0 c7 = 0.0d0 c8 = 0.0d0 c9 = 0.0d0 c10 = 0.0d0 c11 = 0.0d0 c12 = 0.0d0 c13 = 0.0d0 c14 = 0.0d0 c15 = 0.0d0 c16 = 0.0d0 c17 = 0.0d0 ! ELSE IF (kind3pt.EQ.'qqg/all') THEN ! c1 = 0.0d0 c2 = 0.0d0 c3 = 0.0d0 c4 = -(1.0d0/nc) c5 = 0.0d0 c6 = 0.0d0 c7 = 0.0d0 c8 = 0.0d0 c9 = 0.0d0 c10 = 0.0d0 c11 = 0.0d0 c12 = 0.0d0 c13 = 0.0d0 c14 = 0.0d0 c15 = 0.0d0 c16 = 0.0d0 c17 = 0.0d0 ! c5 = c5 + (3.0d0*nc)/2.0d0 c6 = c6 - 3.0d0*nc/2.0d0 ! ELSE IF (kind3pt.EQ.'qqp/qqg') THEN ! c1 = 0 c2 = 0 c3 = 0 c4 = 2.0d0*cf c5 = 0 c6 = 0 c7 = 0 c8 = 0 c9 = 0 c10 = 0 c11 = 0 c12 = 0 c13 = 0 c14 = 0 c15 = 0 c16 = 0 c17 = 0 ! ELSE write(nout,*)'Wrong kind in subroutine vertex.' stop END IF ! ! Now we have the coefficients, so we can calculate ha. ! DO mu = 0,3 DO nu = 0,3 ! temp = c1*epsn1(mu,nu) & + c2*epsn2(mu,nu) & + c3*epsn3(mu,nu) & + c4*eps12(mu,nu) & + c5*eps13(mu,nu) & + c6*eps23(mu,nu) & + c7*k3pt(3,mu)*epsn12(nu) & + c8*nvec(mu)*epsn13(nu) & + c9*k3pt(1,mu)*epsn13(nu) & + c10*k3pt(2,mu)*epsn13(nu) & + c11*nvec(mu)*epsn23(nu) & + c12*k3pt(1,mu)*epsn23(nu) & + c13*k3pt(2,mu)*epsn23(nu) & + c14*nvec(mu)*eps123(nu) & + c15*k3pt(1,mu)*eps123(nu) & + c16*k3pt(2,mu)*eps123(nu) & + c17*k3pt(3,mu)*eps123(nu) ! ha(mu,nu) = prefactor * temp ! END DO END DO ! !----------------------------- ! Now, we have both hv and ha. !----------------------------- ! ! Alternative for IF (FLAG.NE.'renormalize 3 pt') THEN ! ELSE ! ! We need the renormalization counter term. ! tl(0) = 0.0d0 omegasq = 0.0d0 DO mu = 1,3 tl(mu) =(k3pt(1,mu) + k3pt(2,mu) + k3pt(3,mu))/3.0d0 omegasq = omegasq + tl(mu)**2 END DO omegasq = omegasq + mumsbar**2 omega = complexsqrt(omegasq) ! ! Generate the coefficients for the hv counter term, ! depending on KIND3PT. ! IF (kind3pt.EQ.'qqg/qqg') THEN ! cr1 = - 1.0d0/(4.0d0*nc*omega**3) & - 3.0d0*mumsbar**2/(16.0d0*nc*omega**5) cr2 = - 3.0d0/(8.0d0*nc*omega**5) cr3 = 1.0d0/(8.0d0*nc*omega**3) ! ELSE IF (kind3pt.EQ.'qqg/ggq') THEN ! cr1 = nc/(4.0d0*omega**3) & + 3.0d0*nc*mumsbar**2/(16.0d0*omega**5) cr2 = - 3.0d0*nc/(8.0d0*omega**5) cr3 = nc/(8.0d0*omega**3) ! ELSE IF (kind3pt.EQ.'qqg/all') THEN ! cr1 = nc/(4.0d0*omega**3) & + 3.0d0*nc*mumsbar**2/(16.0d0*omega**5) cr2 = - 3.0d0*nc/(8.0d0*omega**5) cr3 = nc/(8.0d0*omega**3) ! cr1 = cr1 - 1.0d0/(4.0d0*nc*omega**3) & - 3.0d0*mumsbar**2/(16.0d0*nc*omega**5) cr2 = cr2 - 3.0d0/(8.0d0*nc*omega**5) cr3 = cr3 + 1.0d0/(8.0d0*nc*omega**3) ! ELSE IF (kind3pt.EQ.'qqp/qqg') THEN ! cr1 = cf/(2.0d0*omega**3) & + 3.0d0*cf*mumsbar**2/(8.0d0*omega**5) cr2 = 3.0d0*cf/(4.0d0*omega**5) cr3 = - cf/(4.0d0*omega**3) ! ELSE write(nout,*)'Wrong kind in subroutine vertex.' stop END IF ! ! Now we have the coefficients, so we can calculate the hv counter term. ! The ha counter term is zero. ! DO mu = 0,3 DO nu = 0,3 hv(mu,nu) = - cr1*g(mu,nu) & - cr2*tl(mu)*tl(nu) & - cr3*nvec(mu)*nvec(nu) ha(mu,nu) = 0.0d0 END DO END DO RETURN ! ! End IF (CUT3PT(1).OR.CUT3PT(2).OR.CUT3PT(3)) THEN ... ELSE ... ! END IF ! RETURN END subroutine vertexf ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine twopt2f(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,vout) ! use beowulf_parameters implicit none ! In: character(len=13) :: kind2pt2 complex(kind=dbl) :: k2pt2(0:5,0:3) logical :: cut2pt2(1:5) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: vout(0:3) ! ! *Feynman gauge*. ! ! The two-loop contribution to the quark propagator. The function is ! a dot product of a four-vector VOUT(mu) with gamma(mu), times a ! unit color matrix. This subroutine calculates VOUT(mu). (There is ! another contribution proportional to gamma(mu) gamma(5), but this ! contribution is not needed at our level of perturbation theory.) The ! contribution includes the self-energy diagram and the adjoining bare ! quark propagators. The calculation includes the denominator factors. ! Some of the internal propagators may be cut, as specified by cut2pt2, ! where cut2pt2(j) = .true. indicates that the corresponding line is ! cut. ! ! The variable kind2pt2 tells what sort of graph we have. ! ! 1) There are graphs with two overlapping three point functions, ! incicated by kind2pt2 = OVERLAP/abcde where a,...,e are chosen from ! Q,G. Here Q denotes "quark" or "antiquark" while G denotes "gluon". ! These characters indicate the flavors on the internal lines. There ! are two possibilities: OVERLAP/QGGQQ and OVERLAP/QGQGG. (The first ! of these has all qqg vertices, while the second has two qqg vertices ! and one ggg vertex.) ! ! 2) There are graphs with a one loop two point function nested inside ! the two loop two point function. These are indicated by ! kind2pt2 = NESTED /abcde, where, again, a,...,e are chosen from ! Q,G. There are three possibilities: ! NESTED /QGGGG gluon self-enegy with a gluon loop ! NESTED /QGGQQ gluon self-enegy with a quark loop ! NESTED /GQQGQ quark self-enegy ! ! Numbering for graphs of type OVERLAP: ! vrtx1 attaches to the incoming quark line ! vrtx2 attaches to the outgoing quark line ! vrtx3 is the internal vertex attached to a quark line from vrtx1 ! vrtx4 is the other internal vertex ! k0(mu) is the momentum of the quark line entering vrtx1 ! k1(mu) is the momentum of the internal line from vrtx1 to vrtx3 ! k2(mu) is the momentum of the internal line from vrtx1 to vrtx4 ! k3(mu) is the momentum of the internal line from vrtx3 to vrtx2 ! k4(mu) is the momentum of the internal line from vrtx4 to vrtx2 ! k5(mu) is the momentum of the internal line from vrtx3 to vrtx4 ! ! Numbering for graphs of type NESTED: ! vrtx1 attaches to the incoming quark line ! vrtx2 attaches to the outgoing quark line ! vrtx3 is the internal vertex attached to a line from vrtx1 ! vrtx4 is the other internal vertex ! k0(mu) is the momentum of the quark line entering vrtx1 ! k1(mu) is the momentum of the internal line from vrtx1 to vrtx2 ! k2(mu) is the momentum of the internal line from vrtx1 to vrtx3 ! k3(mu) is the momentum of the internal line from vrtx4 to vrtx2 ! k4(mu) ane k5(mu) are the momentum of the internal lines ! from vrtx3 to vrtx4. For a quark internal self-energy, ! 4 is the gluon and 5 is the quark line. ! ! 31 December 2001 ! ! For testing purposes only: ! LOGICAL OVERRIDE,LEFTOVERRIDE ! COMMON /TESTING/ OVERRIDE,LEFTOVERRIDE ! --- ! complex(kind=dbl) :: complexsqrt complex(kind=dbl) :: tk00,tk11,tk22,tk33,tk44 complex(kind=dbl) :: k00,k11,k22,k33,k44 complex(kind=dbl) :: temp,prefactor complex(kind=dbl) :: k0(0:3),k1(0:3),k2(0:3),k3(0:3),k4(0:3),k5(0:3) complex(kind=dbl) :: e0,e1,e2,e3,e4 logical :: cut(1:5) ! complex(kind=dbl) :: ea4gk0k1,ea4qk0k1,ea5gk0k3,ea5qk0k4,k0k1,k0k3,k0k4 complex(kind=dbl) :: tracev4g,tracev4q,tracev5g,tracev5q,v4gwk0k1,v4gwk1k0 complex(kind=dbl) :: v4qwk0k1,v4qwk1k0,v5gwk0k3,v5gwk3k0,v5qwk0k4,v5qwk4k0 complex(kind=dbl) :: ea4gk1(0:3),ea4qk1(0:3),ea5gk3(0:3),ea5qk4(0:3) complex(kind=dbl) :: v4gik1(0:3),v4gk1i(0:3),v4qik1(0:3),v4qk1i(0:3) complex(kind=dbl) :: v5gik3(0:3),v5gk3i(0:3),v5qik4(0:3),v5qk4i(0:3) complex(kind=dbl) :: a4g(0:3,0:3),a4q(0:3,0:3),a5g(0:3,0:3),a5q(0:3,0:3) complex(kind=dbl) :: v4g(0:3,0:3),v4q(0:3,0:3),v5g(0:3,0:3),v5q(0:3,0:3) ! character(len=7) :: kind3pt logical :: overlap,qqgverts,tripleglue logical :: nested,nestedglue,nestedquark,glueloop,quarkloop complex(kind=dbl) :: k2pt(0:2,0:3),q(0:3) complex(kind=dbl) :: omegasq,qsq character(len=9) :: kind2pt logical :: cut2pt(0:3) complex(kind=dbl) :: outg(0:3,0:3) complex(kind=dbl) :: mk1(0:3),tracem,dotqk1,mqk1 complex(kind=dbl) :: outq(0:3) complex(kind=dbl) :: omega1sq,bareprop(0:3,0:3),dm(0:3),qm,dqm complex(kind=dbl) :: tracebareprop ! complex(kind=dbl), parameter :: gn(0:3) = & (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf integer :: mu,nu,alpha logical :: left,right ! complex(kind=dbl) :: k3pt(3,0:3) logical :: cut3pt(3) ! ! Set logical variables according to what case we have. ! overlap = .false. qqgverts = .false. tripleglue = .false. nested = .false. nestedglue = .false. nestedquark = .false. glueloop = .false. quarkloop = .false. IF (kind2pt2.EQ.'overlap/qggqq') THEN overlap = .true. qqgverts = .true. ELSE IF (kind2pt2.EQ.'overlap/qgqgg') THEN overlap = .true. tripleglue = .true. ELSE IF (kind2pt2.EQ.'nested /qgggg') THEN nested = .true. nestedglue = .true. glueloop = .true. ELSE IF (kind2pt2.EQ.'nested /qggqq') THEN nested = .true. nestedglue = .true. quarkloop = .true. ELSE IF (kind2pt2.EQ.'nested /gqqgq') THEN nested = .true. nestedquark = .true. ELSE write(nout,*)'Not programmed for that.' stop END IF ! IF (overlap) THEN ! ! Short form of momentum variables and rename cut variables ! for overlap graphs. ! DO mu = 0,3 k0(mu) = k2pt2(0,mu) k1(mu) = k2pt2(1,mu) k2(mu) = k2pt2(2,mu) k3(mu) = k2pt2(3,mu) k4(mu) = k2pt2(4,mu) k5(mu) = k2pt2(5,mu) END DO cut(1) = cut2pt2(1) cut(2) = cut2pt2(2) cut(3) = cut2pt2(3) cut(4) = cut2pt2(4) cut(5) = cut2pt2(5) ! ! We have an OVERLAP type graph. We can treat it two different ! ways: either the left=hand three point graph is calculated ! using subroutine VERTEX or else the right-hand three point ! graph is calculated with subroutine VERTEX. We choose according ! to which lines are cut. Generally, we take the "left" choice, ! but if the right-hand loop is virtual, we take the "right" choice. ! left = .true. right = .false. IF (cut2pt2(1).AND.cut2pt2(2)) THEN left = .false. right = .true. END IF ! ! For testing purposes, we include code to override this choice. ! ! IF (OVERRIDE) THEN ! LEFT = LEFTOVERRIDE ! RIGHT = .NOT.LEFT ! END IF ! ! Calculate according to case, with logic ! IF (QQGVERTS.AND.RIGHT) THEN ! ELSE IF (QQGVERTS.AND.LEFT) THEN ! ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN ! ELSE IF (TRIPLEGLUE.AND.LEFT) THEN ! ELSE ! END IF ! IF (qqgverts.AND.right) THEN ! !--- tk00 = 0.0d0 DO mu = 1,3 tk00 = tk00 - k0(mu)**2 END DO e0 = k0(0) k00 = e0**2 + tk00 prefactor = 1.0d0/k00**2 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF DO mu = 0,3 k3pt(1,mu) = -k4(mu) k3pt(2,mu) = -k5(mu) k3pt(3,mu) = k3(mu) END DO cut3pt(1) = cut(4) cut3pt(2) = cut(5) cut3pt(3) = cut(3) kind3pt = 'qqg/qqg' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q) tracev4q = 0.0d0 DO mu = 0,3 tracev4q = tracev4q + v4q(mu,mu)*metric(mu) END DO v4qwk0k1 = 0.0d0 v4qwk1k0 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v4qwk0k1 = v4qwk0k1 & + v4q(mu,nu)*k0(mu)*k1(nu)*metric(mu)*metric(nu) v4qwk1k0 = v4qwk1k0 & + v4q(mu,nu)*k1(mu)*k0(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 v4qik1(mu) = 0.0d0 v4qk1i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 v4qik1(mu) = v4qik1(mu) + v4q(mu,nu)*k1(nu)*metric(nu) v4qk1i(mu) = v4qk1i(mu) + v4q(nu,mu)*k1(nu)*metric(nu) END DO END DO k0k1 = 0.0d0 DO mu = 0,3 k0k1 = k0k1 + k0(mu)*k1(mu)*metric(mu) END DO call epsilont2(a4q,k0,k1,ea4qk0k1) call epsilont1(a4q,k1,ea4qk1) DO nu = 0,3 ! vout(nu) = cf*(k00*ea4qk1(nu) - 2*ea4qk0k1*k0(nu) & + 2*k0k1*tracev4q*k0(nu) - 2*v4qwk0k1*k0(nu) - 2*v4qwk1k0*k0(nu) & - k00*tracev4q*k1(nu) + k00*v4qik1(nu) + k00*v4qk1i(nu)) vout(nu) = vout(nu)*prefactor ! END DO ! ELSE IF (qqgverts.AND.left) THEN ! !--- tk00 = 0.0d0 DO mu = 1,3 tk00 = tk00 - k0(mu)**2 END DO e0 = k0(0) k00 = e0**2 + tk00 prefactor = 1.0d0/k00**2 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 DO mu = 1,3 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 END DO k33 = e3**2 + tk33 k44 = e4**2 + tk44 IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF DO mu = 0,3 k3pt(1,mu) = -k5(mu) k3pt(2,mu) = -k1(mu) k3pt(3,mu) = k2(mu) END DO cut3pt(1) = cut(5) cut3pt(2) = cut(1) cut3pt(3) = cut(2) kind3pt = 'qqg/qqg' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v5q,a5q) tracev5q = 0.0d0 DO mu = 0,3 tracev5q = tracev5q + v5q(mu,mu)*metric(mu) END DO v5qwk0k4 = 0.0d0 v5qwk4k0 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v5qwk0k4 = v5qwk0k4 & + v5q(mu,nu)*k0(mu)*k4(nu)*metric(mu)*metric(nu) v5qwk4k0 = v5qwk4k0 & + v5q(mu,nu)*k4(mu)*k0(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 v5qik4(mu) = 0.0d0 v5qk4i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 v5qik4(mu) = v5qik4(mu) + v5q(mu,nu)*k4(nu)*metric(nu) v5qk4i(mu) = v5qk4i(mu) + v5q(nu,mu)*k4(nu)*metric(nu) END DO END DO k0k4 = 0.0d0 DO mu = 0,3 k0k4 = k0k4 + k0(mu)*k4(mu)*metric(mu) END DO call epsilont2(a5q,k0,k4,ea5qk0k4) call epsilont1(a5q,k4,ea5qk4) DO nu = 0,3 ! vout(nu) = -(cf*(k00*ea5qk4(nu) - 2*ea5qk0k4*k0(nu) & - 2*k0k4*tracev5q*k0(nu) + 2*v5qwk0k4*k0(nu) + 2*v5qwk4k0*k0(nu) & + k00*tracev5q*k4(nu) - k00*v5qik4(nu) - k00*v5qk4i(nu))) vout(nu) = vout(nu)*prefactor ! END DO ! ELSE IF (tripleglue.AND.right) THEN ! !--- tk00 = 0.0d0 DO mu = 1,3 tk00 = tk00 - k0(mu)**2 END DO e0 = k0(0) k00 = e0**2 + tk00 prefactor = 1.0d0/k00**2 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF DO mu = 0,3 k3pt(1,mu) = -k4(mu) k3pt(2,mu) = -k5(mu) k3pt(3,mu) = k3(mu) END DO cut3pt(1) = cut(4) cut3pt(2) = cut(5) cut3pt(3) = cut(3) kind3pt = 'qqg/ggq' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v4g,a4g) tracev4g = 0.0d0 DO mu = 0,3 tracev4g = tracev4g + v4g(mu,mu)*metric(mu) END DO v4gwk0k1 = 0.0d0 v4gwk1k0 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v4gwk0k1 = v4gwk0k1 & + v4g(mu,nu)*k0(mu)*k1(nu)*metric(mu)*metric(nu) v4gwk1k0 = v4gwk1k0 & + v4g(mu,nu)*k1(mu)*k0(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 v4gik1(mu) = 0.0d0 v4gk1i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 v4gik1(mu) = v4gik1(mu) + v4g(mu,nu)*k1(nu)*metric(nu) v4gk1i(mu) = v4gk1i(mu) + v4g(nu,mu)*k1(nu)*metric(nu) END DO END DO k0k1 = 0.0d0 DO mu = 0,3 k0k1 = k0k1 + k0(mu)*k1(mu)*metric(mu) END DO call epsilont2(a4g,k0,k1,ea4gk0k1) call epsilont1(a4g,k1,ea4gk1) DO nu = 0,3 ! vout(nu) = cf*(k00*ea4gk1(nu) - 2*ea4gk0k1*k0(nu) & + 2*k0k1*tracev4g*k0(nu) - 2*v4gwk0k1*k0(nu) - 2*v4gwk1k0*k0(nu) & - k00*tracev4g*k1(nu) + k00*v4gik1(nu) + k00*v4gk1i(nu)) vout(nu) = vout(nu)*prefactor ! END DO ! ELSE IF (tripleglue.AND.left) THEN ! !--- tk00 = 0.0d0 DO mu = 1,3 tk00 = tk00 - k0(mu)**2 END DO e0 = k0(0) k00 = e0**2 + tk00 prefactor = 1.0d0/k00**2 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 DO mu = 1,3 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 END DO k33 = e3**2 + tk33 k44 = e4**2 + tk44 IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF DO mu = 0,3 k3pt(1,mu) = k5(mu) k3pt(2,mu) = -k2(mu) k3pt(3,mu) = k1(mu) END DO cut3pt(1) = cut(5) cut3pt(2) = cut(2) cut3pt(3) = cut(1) kind3pt = 'qqg/ggq' call vertexf(kind3pt,k3pt,cut3pt,mumsbar,flag,v5g,a5g) tracev5g = 0.0d0 DO mu = 0,3 tracev5g = tracev5g + v5g(mu,mu)*metric(mu) END DO v5gwk0k3 = 0.0d0 v5gwk3k0 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v5gwk0k3 = v5gwk0k3 & + v5g(mu,nu)*k0(mu)*k3(nu)*metric(mu)*metric(nu) v5gwk3k0 = v5gwk3k0 & + v5g(mu,nu)*k3(mu)*k0(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 v5gik3(mu) = 0.0d0 v5gk3i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 v5gik3(mu) = v5gik3(mu) + v5g(mu,nu)*k3(nu)*metric(nu) v5gk3i(mu) = v5gk3i(mu) + v5g(nu,mu)*k3(nu)*metric(nu) END DO END DO k0k3 = 0.0d0 DO mu = 0,3 k0k3 = k0k3 + k0(mu)*k3(mu)*metric(mu) END DO call epsilont2(a5g,k0,k3,ea5gk0k3) call epsilont1(a5g,k3,ea5gk3) DO nu = 0,3 ! vout(nu) = -(cf*(k00*ea5gk3(nu) - 2*ea5gk0k3*k0(nu) & - 2*k0k3*tracev5g*k0(nu) + 2*v5gwk0k3*k0(nu) + 2*v5gwk3k0*k0(nu) & + k00*tracev5g*k3(nu) - k00*v5gik3(nu) - k00*v5gk3i(nu))) vout(nu) = vout(nu)*prefactor ! END DO ELSE write(nout,*)'Not programmed for that.' stop END IF ! !------------- ! ! Alternative for IF (OVERLAP) THEN. ! ELSE IF (nested) THEN ! ! We have a nested graph. ! DO mu = 0,3 k2pt(0,mu) = k2pt2(2,mu) k2pt(1,mu) = k2pt2(4,mu) k2pt(2,mu) = k2pt2(5,mu) q(mu) = k2pt2(0,mu) k1(mu) = k2pt2(1,mu) END DO omegasq = q(1)**2 + q(2)**2 + q(3)**2 qsq = q(0)**2 - omegasq omega1sq = k1(1)**2 + k1(2)**2 + k1(3)**2 ! cut2pt(0) = cut2pt2(2) cut2pt(1) = cut2pt2(4) cut2pt(2) = cut2pt2(5) cut2pt(3) = cut2pt2(3) ! ! We need the factor equal to 1/k^2 for an uncut propagator ! and 1/ 2|\vec k| for a cut propagator. BUT line 1 is always ! cut, propagator 0 never cut, and the one-loop two point function ! that is nested inside has the factor for propagators 2,3,4,5. ! prefactor = cf/(qsq**2*2.0d0*complexsqrt(omega1sq)) ! IF (nestedglue) THEN ! ! Our nested graph has a gluon self-energy insertion. ! Calculate OUTG according to what kind of self-energy insertion it is. ! IF (glueloop) THEN kind2pt = 'gluonloop' call twopointgf(kind2pt,k2pt,cut2pt,mumsbar,flag,outg) ELSE IF (quarkloop) THEN kind2pt = 'quarkloop' call twopointgf(kind2pt,k2pt,cut2pt,mumsbar,flag,outg) END IF ! ! Now comlete the calculation for a gluon self-energy insertion. ! DO alpha = 0,3 temp = 0.0d0 DO nu = 0,3 temp = temp + outg(alpha,nu)*k1(nu)*metric(nu) END DO mk1(alpha) = temp END DO ! tracem = 0.0d0 dotqk1 = 0.0d0 DO mu = 0,3 tracem = tracem + outg(mu,mu)*metric(mu) dotqk1 = dotqk1 + q(mu)*k1(mu)*metric(mu) END DO ! mqk1 = 0.0d0 DO mu = 0,3 DO nu = 0,3 mqk1 = mqk1 + outg(mu,nu)*q(mu)*k1(nu)*metric(mu)*metric(nu) END DO END DO ! DO alpha = 0,3 temp = - 2.0d0*qsq*mk1(alpha) temp = temp + 4.0d0*q(alpha)*mqk1 temp = temp + (qsq*k1(alpha) - 2.0d0*q(alpha)*dotqk1)*tracem vout(alpha) = prefactor*temp END DO ! ! Alternative for IF (NESTEDGLUE) THEN ! ELSE IF (nestedquark) THEN ! ! Our nested graph has a quark self-energy insertion. ! Calculate OUTQ. ! call twopointqf(k2pt,cut2pt,mumsbar,flag,outq) ! ! Now comlete the calculation for a quark self-energy insertion. ! ! The gluon propagator in *FEYNMAN* gauge for an on-shell gluon ! with three-momentum K1(mu). ! bareprop(0,0) = -1.0d0 DO mu = 1,3 bareprop(0,mu) = 0.0d0 bareprop(mu,0) = 0.0d0 bareprop(mu,mu) = 1.0d0 DO nu = mu+1,3 temp =0.0d0 bareprop(mu,nu) = temp bareprop(nu,mu) = temp END DO END DO tracebareprop = -4.0d0 ! DO alpha = 0,3 dm(alpha) = 0.0d0 DO nu = 0,3 dm(alpha) = dm(alpha) + bareprop(alpha,nu)*outq(nu)*metric(nu) END DO END DO ! dqm = 0.0d0 qm = 0.0d0 DO mu = 0,3 qm = qm + q(mu)*outq(mu)*metric(mu) DO nu = 0,3 dqm = dqm + bareprop(mu,nu)*q(mu)*outq(nu)*metric(mu)*metric(nu) END DO END DO ! DO alpha = 0,3 temp = - 2.0d0*qsq*dm(alpha) temp = temp + 4.0d0*q(alpha)*dqm temp = temp & + (qsq*outq(alpha) - 2.0d0*q(alpha)*qm)*tracebareprop vout(alpha) = prefactor*temp END DO ! ! Close IF (NESTEDGLUE) THEN ... ELSE IF (NESTEDQUARK) THEN ! ELSE write(nout,*)'Oops, something must have gone wrong.' stop END IF ! ! Close IF (OVERLAP) THEN ... ELSE IF (NESTED) THEN ! ELSE write(nout,*)'Oops, something has gone wrong.' stop END IF ! RETURN END subroutine twopt2f ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Feynman integrand in Coulomb gauge ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function feynman(graphnumber,flavorsetnumber,kc,cut,mumsbar,flag) ! use beowulf_parameters implicit none ! In: integer :: graphnumber,flavorsetnumber complex(kind=dbl), dimension(0:3*size-1,0:3) :: kc logical, dimension(3*size-1) :: cut real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: feynman ! ! Feynman integrand function for graph GRAPHNUMBER ! with complex momenta KC and cut specified by CUT. ! Early version: 17 July 1994. ! This version written by Mathematica code of 2 October 2004 on ! 2 Oct 2004. ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) complex(kind=dbl), parameter :: gn(0:3) = & (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) complex(kind=dbl), parameter :: gz(0:3) = & (/(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(-1.0d0,0.0d0)/) ! complex(kind=dbl) :: complexsqrt integer :: mu,nu,tau complex(kind=dbl),dimension(512) :: x complex(kind=dbl),dimension(0:3) :: k1,k2,k3,k4,k5,k6,k7,k8 complex(kind=dbl) :: e1,e2,e3,e4,e5,e6,e7,e8 complex(kind=dbl) :: kz1,kz2,kz3,kz4,kz5,kz6,kz7,kz8 complex(kind=dbl) :: k11,k22,k33,k44,k55,k66,k77,k88 complex(kind=dbl) :: tk11,tk22,tk33,tk44,tk55,tk66,tk77,tk88 complex(kind=dbl) :: prefactor character(len=13) :: kind2pt2 complex(kind=dbl),dimension(0:5,0:3) :: k2pt2 logical,dimension(1:5) :: cut2pt2 character(len=9) :: kind2pt complex(kind=dbl),dimension(0:2,0:3) :: k2pt logical,dimension(0:3) :: cut2pt character(len=7) :: kind3pt complex(kind=dbl),dimension(3,0:3) :: k3pt logical,dimension(3) :: cut3pt ! complex(kind=dbl) :: a1qda4q,a1qgnia4qgni,a1qgzia4qgzi,a1qik6a4qik7 complex(kind=dbl) :: a1qik7a4qik6,a1qwgnk6,a1qwgnk7,a1qwgzk6,a1qwgzk7 complex(kind=dbl) :: a4qwgnk6,a4qwgnk7,a4qwgzk6,a4qwgzk7,ea1qgnignk3q47 complex(kind=dbl) :: ea1qgnik6k7v4qgni,ea1qgzigzk3q47,ea1qgzik6k7v4qgzi complex(kind=dbl) :: ea1qk3q47,ea1qzv4qk6k7,ea2qgnignk3q67,ea2qgzigzk3q67 complex(kind=dbl) :: ea2qk3q67,ea3qgnignk1q26,ea3qgzigzk1q26,ea3qk1q26 complex(kind=dbl) :: ea4qgnignk1q86,ea4qgnik6k7v1qgni,ea4qgzigzk1q86 complex(kind=dbl) :: ea4qgzik6k7v1qgzi,ea4qk1q86,ea4qzv1qk6k7,ea7ggnignk1k2 complex(kind=dbl) :: ea7ggnignk1k3,ea7ggnignk1k4,ea7ggnignk2k3 complex(kind=dbl) :: ea7ggnignk2k4,ea7ggnignk3k4,ea7ggnigzk2k4 complex(kind=dbl) :: ea7ggnik1k2k3,ea7ggnik1k3k4,ea7ggnk1,ea7ggnk2,ea7ggnk3 complex(kind=dbl) :: ea7ggnk4,ea7ggzigzk1k2,ea7ggzigzk1k3,ea7ggzigzk1k4 complex(kind=dbl) :: ea7ggzigzk2k3,ea7ggzigzk2k4,ea7ggzigzk3k4 complex(kind=dbl) :: ea7ggzik1k2k3,ea7ggzik1k3k4,ea7ggzk1,ea7ggzk2,ea7ggzk3 complex(kind=dbl) :: ea7ggzk4,ea7gk1ignk2k4,ea7gk1igzk2k4,ea7gk1k2,ea7gk1k3 complex(kind=dbl) :: ea7gk1k4,ea7gk2ignk1k4,ea7gk2ignk3k4,ea7gk2igzk1k4 complex(kind=dbl) :: ea7gk2igzk3k4,ea7gk2ik1k3k4,ea7gk2k3,ea7gk3ignk2k4 complex(kind=dbl) :: ea7gk3igzk2k4,ea7gk3k4,ea7gk4ignk1k2,ea7gk4ignk2k3 complex(kind=dbl) :: ea7gk4igzk1k2,ea7gk4igzk2k3,ea7gk4ik1k2k3 complex(kind=dbl) :: ea7gk5igngzk1,ea7gk5igngzk2,ea7gk5igngzk3 complex(kind=dbl) :: ea7gk5igngzk4,ea7gk5ignk1k2,ea7gk5ignk1k3 complex(kind=dbl) :: ea7gk5ignk1k4,ea7gk5ignk2k3,ea7gk5ignk2k4 complex(kind=dbl) :: ea7gk5ignk3k4,ea7gk5igzk1k2,ea7gk5igzk1k4 complex(kind=dbl) :: ea7gk5igzk2k3,ea7gk5igzk2k4,ea7gk5igzk3k4 complex(kind=dbl) :: ea7gk5ik1k2k3,ea7gk5ik1k3k4,ea7qgnignk1k2 complex(kind=dbl) :: ea7qgnignk1k3,ea7qgnignk1k4,ea7qgnignk2k3 complex(kind=dbl) :: ea7qgnignk2k4,ea7qgnignk3k4,ea7qgnigzk2k4 complex(kind=dbl) :: ea7qgnik1k2k3,ea7qgnik1k3k4,ea7qgnk1,ea7qgnk2,ea7qgnk3 complex(kind=dbl) :: ea7qgnk4,ea7qgzigzk1k2,ea7qgzigzk1k3,ea7qgzigzk1k4 complex(kind=dbl) :: ea7qgzigzk2k3,ea7qgzigzk2k4,ea7qgzigzk3k4 complex(kind=dbl) :: ea7qgzik1k2k3,ea7qgzik1k3k4,ea7qgzk1,ea7qgzk2,ea7qgzk3 complex(kind=dbl) :: ea7qgzk4,ea7qk1ignk2k4,ea7qk1igzk2k4,ea7qk1k2,ea7qk1k3 complex(kind=dbl) :: ea7qk1k4,ea7qk2ignk1k4,ea7qk2ignk3k4,ea7qk2igzk1k4 complex(kind=dbl) :: ea7qk2igzk3k4,ea7qk2ik1k3k4,ea7qk2k3,ea7qk3ignk2k4 complex(kind=dbl) :: ea7qk3igzk2k4,ea7qk3k4,ea7qk4ignk1k2,ea7qk4ignk2k3 complex(kind=dbl) :: ea7qk4igzk1k2,ea7qk4igzk2k3,ea7qk4ik1k2k3 complex(kind=dbl) :: ea7qk5igngzk1,ea7qk5igngzk2,ea7qk5igngzk3 complex(kind=dbl) :: ea7qk5igngzk4,ea7qk5ignk1k2,ea7qk5ignk1k3 complex(kind=dbl) :: ea7qk5ignk1k4,ea7qk5ignk2k3,ea7qk5ignk2k4 complex(kind=dbl) :: ea7qk5ignk3k4,ea7qk5igzk1k2,ea7qk5igzk1k4 complex(kind=dbl) :: ea7qk5igzk2k3,ea7qk5igzk2k4,ea7qk5igzk3k4 complex(kind=dbl) :: ea7qk5ik1k2k3,ea7qk5ik1k3k4,ea8ggnignk1k2 complex(kind=dbl) :: ea8ggnignk1k3,ea8ggnignk1k4,ea8ggnignk2k3 complex(kind=dbl) :: ea8ggnignk2k4,ea8ggnignk3k4,ea8ggnigzk2k4 complex(kind=dbl) :: ea8ggnik1k2k3,ea8ggnik1k3k4,ea8ggnk1,ea8ggnk2,ea8ggnk3 complex(kind=dbl) :: ea8ggnk4,ea8ggzigzk1k2,ea8ggzigzk1k3,ea8ggzigzk1k4 complex(kind=dbl) :: ea8ggzigzk2k3,ea8ggzigzk2k4,ea8ggzigzk3k4 complex(kind=dbl) :: ea8ggzik1k2k3,ea8ggzik1k3k4,ea8ggzk1,ea8ggzk2,ea8ggzk3 complex(kind=dbl) :: ea8ggzk4,ea8gk1ignk2k4,ea8gk1igzk2k4,ea8gk1k2,ea8gk1k3 complex(kind=dbl) :: ea8gk1k4,ea8gk2ignk1k4,ea8gk2ignk3k4,ea8gk2igzk1k4 complex(kind=dbl) :: ea8gk2igzk3k4,ea8gk2ik1k3k4,ea8gk2k3,ea8gk3ignk2k4 complex(kind=dbl) :: ea8gk3igzk2k4,ea8gk3k4,ea8gk4ignk1k2,ea8gk4ignk2k3 complex(kind=dbl) :: ea8gk4igzk1k2,ea8gk4igzk2k3,ea8gk4ik1k2k3 complex(kind=dbl) :: ea8gk5igngzk1,ea8gk5igngzk2,ea8gk5igngzk3 complex(kind=dbl) :: ea8gk5igngzk4,ea8gk5ignk1k2,ea8gk5ignk1k3 complex(kind=dbl) :: ea8gk5ignk1k4,ea8gk5ignk2k3,ea8gk5ignk2k4 complex(kind=dbl) :: ea8gk5ignk3k4,ea8gk5igzk1k2,ea8gk5igzk1k4 complex(kind=dbl) :: ea8gk5igzk2k3,ea8gk5igzk2k4,ea8gk5igzk3k4 complex(kind=dbl) :: ea8gk5ik1k2k3,ea8gk5ik1k3k4,ea8qgnignk1k2 complex(kind=dbl) :: ea8qgnignk1k3,ea8qgnignk1k4,ea8qgnignk2k3 complex(kind=dbl) :: ea8qgnignk2k4,ea8qgnignk3k4,ea8qgnigzk2k4 complex(kind=dbl) :: ea8qgnik1k2k3,ea8qgnik1k3k4,ea8qgnk1,ea8qgnk2,ea8qgnk3 complex(kind=dbl) :: ea8qgnk4,ea8qgzigzk1k2,ea8qgzigzk1k3,ea8qgzigzk1k4 complex(kind=dbl) :: ea8qgzigzk2k3,ea8qgzigzk2k4,ea8qgzigzk3k4 complex(kind=dbl) :: ea8qgzik1k2k3,ea8qgzik1k3k4,ea8qgzk1,ea8qgzk2,ea8qgzk3 complex(kind=dbl) :: ea8qgzk4,ea8qk1ignk2k4,ea8qk1igzk2k4,ea8qk1k2,ea8qk1k3 complex(kind=dbl) :: ea8qk1k4,ea8qk2ignk1k4,ea8qk2ignk3k4,ea8qk2igzk1k4 complex(kind=dbl) :: ea8qk2igzk3k4,ea8qk2ik1k3k4,ea8qk2k3,ea8qk3ignk2k4 complex(kind=dbl) :: ea8qk3igzk2k4,ea8qk3k4,ea8qk4ignk1k2,ea8qk4ignk2k3 complex(kind=dbl) :: ea8qk4igzk1k2,ea8qk4igzk2k3,ea8qk4ik1k2k3 complex(kind=dbl) :: ea8qk5igngzk1,ea8qk5igngzk2,ea8qk5igngzk3 complex(kind=dbl) :: ea8qk5igngzk4,ea8qk5ignk1k2,ea8qk5ignk1k3 complex(kind=dbl) :: ea8qk5ignk1k4,ea8qk5ignk2k3,ea8qk5ignk2k4 complex(kind=dbl) :: ea8qk5ignk3k4,ea8qk5igzk1k2,ea8qk5igzk1k4 complex(kind=dbl) :: ea8qk5igzk2k3,ea8qk5igzk2k4,ea8qk5igzk3k4 complex(kind=dbl) :: ea8qk5ik1k2k3,ea8qk5ik1k3k4,g7gwgngn,g7gwgnk1,g7gwgnk2 complex(kind=dbl) :: g7gwgnk3,g7gwgnk4,g7gwgzgz,g7gwgzk1,g7gwgzk2,g7gwgzk3 complex(kind=dbl) :: g7gwgzk4,g7gwk1k2,g7gwk1k4,g7gwk2k3,g7gwk3k4,g8qwgngn complex(kind=dbl) :: g8qwgnk1,g8qwgnk2,g8qwgnk3,g8qwgnk4,g8qwgzgz,g8qwgzk1 complex(kind=dbl) :: g8qwgzk2,g8qwgzk3,g8qwgzk4,g8qwk1k2,g8qwk1k4,g8qwk2k3 complex(kind=dbl) :: g8qwk3k4,gnq15,gnq24,gnq26,gnq36,gnq47,gnq67,gnq84 complex(kind=dbl) :: gnq86,gnqqnb45,gnqqnb46,gnqqng45,gnqqng46,gnqqnq45 complex(kind=dbl) :: gnqqnq46,gnqqog57,gnqqog75,gnqqoq57,gnqqoq64,gzq15 complex(kind=dbl) :: gzq24,gzq26,gzq36,gzq47,gzq67,gzq84,gzq86,gzqqnb45 complex(kind=dbl) :: gzqqnb46,gzqqng45,gzqqng46,gzqqnq45,gzqqnq46,gzqqog57 complex(kind=dbl) :: gzqqog75,gzqqoq57,gzqqoq64,k1k2,k1k3,k1k4,k1k6,k1k7 complex(kind=dbl) :: k1q26,k1q86,k2k3,k2k4,k2k6,k2k7,k2q24,k2q36,k2q84 complex(kind=dbl) :: k2q86,k3k4,k3k6,k3k7,k3q47,k3q67,k4k6,k4k7,k6k7,q24q86 complex(kind=dbl) :: q36q84,traceg7g,traceg8q,tracev1q,tracev2q,tracev3q complex(kind=dbl) :: tracev4q,tracev7g,tracev7q,tracev8g,tracev8q,v1qdv4q complex(kind=dbl) :: v1qgniv4qgni,v1qgziv4qgzi,v1qik6v4qik7,v1qik7v4qik6 complex(kind=dbl) :: v1qwgngn,v1qwgnk3,v1qwgnk6,v1qwgnk7,v1qwgnq47,v1qwgzgz complex(kind=dbl) :: v1qwgzk3,v1qwgzk6,v1qwgzk7,v1qwgzq47,v1qwk3q47 complex(kind=dbl) :: v1qwq47k3,v2qwgngn,v2qwgnk3,v2qwgnq67,v2qwgzgz complex(kind=dbl) :: v2qwgzk3,v2qwgzq67,v2qwk3q67,v2qwq67k3,v3qwgngn complex(kind=dbl) :: v3qwgnk1,v3qwgnq26,v3qwgzgz,v3qwgzk1,v3qwgzq26 complex(kind=dbl) :: v3qwk1q26,v3qwq26k1,v4qwgngn,v4qwgnk1,v4qwgnk6 complex(kind=dbl) :: v4qwgnk7,v4qwgnq86,v4qwgzgz,v4qwgzk1,v4qwgzk6,v4qwgzk7 complex(kind=dbl) :: v4qwgzq86,v4qwk1q86,v4qwq86k1,v7gwgngn,v7gwgngz complex(kind=dbl) :: v7gwgnk1,v7gwgnk2,v7gwgnk3,v7gwgnk4,v7gwgzgz,v7gwgzk1 complex(kind=dbl) :: v7gwgzk2,v7gwgzk3,v7gwgzk4,v7gwk1gn,v7gwk1gz,v7gwk1k2 complex(kind=dbl) :: v7gwk1k4,v7gwk2gn,v7gwk2gz,v7gwk2k1,v7gwk2k3,v7gwk3gn complex(kind=dbl) :: v7gwk3gz,v7gwk3k2,v7gwk3k4,v7gwk4gn,v7gwk4gz,v7gwk4k1 complex(kind=dbl) :: v7gwk4k3,v7gwk5gn,v7gwk5gz,v7gwk5k1,v7gwk5k2,v7gwk5k3 complex(kind=dbl) :: v7gwk5k4,v7qwgngn,v7qwgngz,v7qwgnk1,v7qwgnk2,v7qwgnk3 complex(kind=dbl) :: v7qwgnk4,v7qwgzgz,v7qwgzk1,v7qwgzk2,v7qwgzk3,v7qwgzk4 complex(kind=dbl) :: v7qwk1gn,v7qwk1gz,v7qwk1k2,v7qwk1k4,v7qwk2gn,v7qwk2gz complex(kind=dbl) :: v7qwk2k1,v7qwk2k3,v7qwk3gn,v7qwk3gz,v7qwk3k2,v7qwk3k4 complex(kind=dbl) :: v7qwk4gn,v7qwk4gz,v7qwk4k1,v7qwk4k3,v7qwk5gn,v7qwk5gz complex(kind=dbl) :: v7qwk5k1,v7qwk5k2,v7qwk5k3,v7qwk5k4,v8gwgngn,v8gwgngz complex(kind=dbl) :: v8gwgnk1,v8gwgnk2,v8gwgnk3,v8gwgnk4,v8gwgzgz,v8gwgzk1 complex(kind=dbl) :: v8gwgzk2,v8gwgzk3,v8gwgzk4,v8gwk1gn,v8gwk1gz,v8gwk1k2 complex(kind=dbl) :: v8gwk1k4,v8gwk2gn,v8gwk2gz,v8gwk2k1,v8gwk2k3,v8gwk3gn complex(kind=dbl) :: v8gwk3gz,v8gwk3k2,v8gwk3k4,v8gwk4gn,v8gwk4gz,v8gwk4k1 complex(kind=dbl) :: v8gwk4k3,v8gwk5gn,v8gwk5gz,v8gwk5k1,v8gwk5k2,v8gwk5k3 complex(kind=dbl) :: v8gwk5k4,v8qwgngn,v8qwgngz,v8qwgnk1,v8qwgnk2,v8qwgnk3 complex(kind=dbl) :: v8qwgnk4,v8qwgzgz,v8qwgzk1,v8qwgzk2,v8qwgzk3,v8qwgzk4 complex(kind=dbl) :: v8qwk1gn,v8qwk1gz,v8qwk1k2,v8qwk1k4,v8qwk2gn,v8qwk2gz complex(kind=dbl) :: v8qwk2k1,v8qwk2k3,v8qwk3gn,v8qwk3gz,v8qwk3k2,v8qwk3k4 complex(kind=dbl) :: v8qwk4gn,v8qwk4gz,v8qwk4k1,v8qwk4k3,v8qwk5gn,v8qwk5gz complex(kind=dbl) :: v8qwk5k1,v8qwk5k2,v8qwk5k3,v8qwk5k4,a1qgni(0:3) complex(kind=dbl) :: a1qgzi(0:3),a1qik6(0:3),a1qik7(0:3),a2qgni(0:3) complex(kind=dbl) :: a2qgzi(0:3),a3qgni(0:3),a3qgzi(0:3),a4qgni(0:3) complex(kind=dbl) :: a4qgzi(0:3),a4qik6(0:3),a4qik7(0:3),a7ggni(0:3) complex(kind=dbl) :: a7ggzi(0:3),a7gk1i(0:3),a7gk2i(0:3),a7gk3i(0:3) complex(kind=dbl) :: a7gk4i(0:3),a7gk5i(0:3),a7qgni(0:3),a7qgzi(0:3) complex(kind=dbl) :: a7qk1i(0:3),a7qk2i(0:3),a7qk3i(0:3),a7qk4i(0:3) complex(kind=dbl) :: a7qk5i(0:3),a8ggni(0:3),a8ggzi(0:3),a8gk1i(0:3) complex(kind=dbl) :: a8gk2i(0:3),a8gk3i(0:3),a8gk4i(0:3),a8gk5i(0:3) complex(kind=dbl) :: a8qgni(0:3),a8qgzi(0:3),a8qk1i(0:3),a8qk2i(0:3) complex(kind=dbl) :: a8qk3i(0:3),a8qk4i(0:3),a8qk5i(0:3),q15(0:3),q24(0:3) complex(kind=dbl) :: q26(0:3),q36(0:3),q47(0:3),q67(0:3),q84(0:3),q86(0:3) complex(kind=dbl) :: qqnb45(0:3),qqnb46(0:3),qqng45(0:3),qqng46(0:3) complex(kind=dbl) :: qqnq45(0:3),qqnq46(0:3),qqog57(0:3),qqog75(0:3) complex(kind=dbl) :: qqoq57(0:3),qqoq64(0:3),v1qgni(0:3),v1qgzi(0:3) complex(kind=dbl) :: v1qik6(0:3),v1qik7(0:3),v4qgni(0:3),v4qgzi(0:3) complex(kind=dbl) :: v4qik6(0:3),v4qik7(0:3),a1q(0:3,0:3),a1qzv4q(0:3,0:3) complex(kind=dbl) :: a2q(0:3,0:3),a3q(0:3,0:3),a4q(0:3,0:3) complex(kind=dbl) :: a4qzv1q(0:3,0:3),a7g(0:3,0:3),a7q(0:3,0:3) complex(kind=dbl) :: a8g(0:3,0:3),a8q(0:3,0:3),g7g(0:3,0:3),g8q(0:3,0:3) complex(kind=dbl) :: v1q(0:3,0:3),v2q(0:3,0:3),v3q(0:3,0:3),v4q(0:3,0:3) complex(kind=dbl) :: v7g(0:3,0:3),v7q(0:3,0:3),v8g(0:3,0:3),v8q(0:3,0:3) ! DO mu = 0,3 k1(mu) = kc(1,mu) k2(mu) = kc(2,mu) k3(mu) = kc(3,mu) k4(mu) = kc(4,mu) k5(mu) = kc(5,mu) k6(mu) = kc(6,mu) k7(mu) = kc(7,mu) k8(mu) = kc(8,mu) END DO e1 = k1(0) e2 = k2(0) e3 = k3(0) e4 = k4(0) e5 = k5(0) e6 = k6(0) e7 = k7(0) e8 = k8(0) kz1 = k1(3) kz2 = k2(3) kz3 = k3(3) kz4 = k4(3) kz5 = k5(3) kz6 = k6(3) kz7 = k7(3) kz8 = k8(3) feynman = 0.0d0 ! !------ ! IF (graphnumber .EQ. 1) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,quark,qbar,gluon,gluon,qbar,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = -k4(mu) k2pt2(2,mu) = k6(mu) k2pt2(3,mu) = -k5(mu) k2pt2(4,mu) = -k7(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(6) cut2pt2(3) = cut(5) cut2pt2(4) = cut(7) cut2pt2(5) = cut(8) kind2pt2 = 'nested /qggqq' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnq45) gnqqnq45 = 0.0d0 gzqqnq45 = 0.0d0 DO mu = 0,3 gnqqnq45 = gnqqnq45 + gn(mu)*qqnq45(mu)*metric(mu) gzqqnq45 = gzqqnq45 + gz(mu)*qqnq45(mu)*metric(mu) END DO feynman = -12*(e1*gnqqnq45 - gzqqnq45*kz1)*nc feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {quark,qbar,quark,qbar,gluon,gluon,gluon,gluon} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = -k4(mu) k2pt2(2,mu) = k6(mu) k2pt2(3,mu) = -k5(mu) k2pt2(4,mu) = -k8(mu) k2pt2(5,mu) = -k7(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(6) cut2pt2(3) = cut(5) cut2pt2(4) = cut(8) cut2pt2(5) = cut(7) kind2pt2 = 'nested /qgggg' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqng45) gnqqng45 = 0.0d0 gzqqng45 = 0.0d0 DO mu = 0,3 gnqqng45 = gnqqng45 + gn(mu)*qqng45(mu)*metric(mu) gzqqng45 = gzqqng45 + gz(mu)*qqng45(mu)*metric(mu) END DO feynman = -12*(e1*gnqqng45 - gzqqng45*kz1)*nc feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 3) THEN ! types = {quark,qbar,quark,gluon,qbar,quark,gluon,qbar} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = -k4(mu) k2pt2(2,mu) = k6(mu) k2pt2(3,mu) = -k5(mu) k2pt2(4,mu) = -k7(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(6) cut2pt2(3) = cut(5) cut2pt2(4) = cut(7) cut2pt2(5) = cut(8) kind2pt2 = 'nested /gqqgq' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnb45) gnqqnb45 = 0.0d0 gzqqnb45 = 0.0d0 DO mu = 0,3 gnqqnb45 = gnqqnb45 + gn(mu)*qqnb45(mu)*metric(mu) gzqqnb45 = gzqqnb45 + gz(mu)*qqnb45(mu)*metric(mu) END DO feynman = -12*(e1*gnqqnb45 - gzqqnb45*kz1)*nc feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 4) THEN ! types = {qbar,quark,qbar,quark,gluon,gluon,qbar,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k4(mu) k2pt2(2,mu) = k5(mu) k2pt2(3,mu) = -k6(mu) k2pt2(4,mu) = k8(mu) k2pt2(5,mu) = k7(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(5) cut2pt2(3) = cut(6) cut2pt2(4) = cut(8) cut2pt2(5) = cut(7) kind2pt2 = 'nested /qggqq' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnq46) gnqqnq46 = 0.0d0 gzqqnq46 = 0.0d0 DO mu = 0,3 gnqqnq46 = gnqqnq46 + gn(mu)*qqnq46(mu)*metric(mu) gzqqnq46 = gzqqnq46 + gz(mu)*qqnq46(mu)*metric(mu) END DO feynman = 12*(e1*gnqqnq46 - gzqqnq46*kz1)*nc feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 5) THEN ! types = {qbar,quark,qbar,quark,gluon,gluon,gluon,gluon} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k4(mu) k2pt2(2,mu) = k5(mu) k2pt2(3,mu) = -k6(mu) k2pt2(4,mu) = k7(mu) k2pt2(5,mu) = k8(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(5) cut2pt2(3) = cut(6) cut2pt2(4) = cut(7) cut2pt2(5) = cut(8) kind2pt2 = 'nested /qgggg' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqng46) gnqqng46 = 0.0d0 gzqqng46 = 0.0d0 DO mu = 0,3 gnqqng46 = gnqqng46 + gn(mu)*qqng46(mu)*metric(mu) gzqqng46 = gzqqng46 + gz(mu)*qqng46(mu)*metric(mu) END DO feynman = 12*(e1*gnqqng46 - gzqqng46*kz1)*nc feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 6) THEN ! types = {qbar,quark,qbar,gluon,quark,qbar,gluon,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k4(mu) k2pt2(2,mu) = k5(mu) k2pt2(3,mu) = -k6(mu) k2pt2(4,mu) = k7(mu) k2pt2(5,mu) = k8(mu) END DO cut2pt2(1) = cut(4) cut2pt2(2) = cut(5) cut2pt2(3) = cut(6) cut2pt2(4) = cut(7) cut2pt2(5) = cut(8) kind2pt2 = 'nested /gqqgq' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqnb46) gnqqnb46 = 0.0d0 gzqqnb46 = 0.0d0 DO mu = 0,3 gnqqnb46 = gnqqnb46 + gn(mu)*qqnb46(mu)*metric(mu) gzqqnb46 = gzqqnb46 + gz(mu)*qqnb46(mu)*metric(mu) END DO feynman = 12*(e1*gnqqnb46 - gzqqnb46*kz1)*nc feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 2) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,quark,gluon,qbar,gluon,quark,qbar} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt(0,mu) = k3(mu) k2pt(1,mu) = k6(mu) k2pt(2,mu) = k7(mu) END DO cut2pt(0) = cut(3) cut2pt(1) = cut(6) cut2pt(2) = cut(7) cut2pt(3) = cut(8) call twopointq(k2pt,cut2pt,mumsbar,flag,q36) DO mu = 0,3 k2pt(0,mu) = -k8(mu) k2pt(1,mu) = -k4(mu) k2pt(2,mu) = -k5(mu) END DO cut2pt(0) = cut(8) cut2pt(1) = cut(4) cut2pt(2) = cut(5) cut2pt(3) = cut(2) call twopointq(k2pt,cut2pt,mumsbar,flag,q84) gnq36 = 0.0d0 gnq84 = 0.0d0 gzq36 = 0.0d0 gzq84 = 0.0d0 k2q36 = 0.0d0 k2q84 = 0.0d0 q36q84 = 0.0d0 DO mu = 0,3 gnq36 = gnq36 + gn(mu)*q36(mu)*metric(mu) gnq84 = gnq84 + gn(mu)*q84(mu)*metric(mu) gzq36 = gzq36 + gz(mu)*q36(mu)*metric(mu) gzq84 = gzq84 + gz(mu)*q84(mu)*metric(mu) k2q36 = k2q36 + k2(mu)*q36(mu)*metric(mu) k2q84 = k2q84 + k2(mu)*q84(mu)*metric(mu) q36q84 = q36q84 + q36(mu)*q84(mu)*metric(mu) END DO feynman = 12*nc*(e1*gnq84*k2q36 + e1*gnq36*k2q84 & - gzq84*k2q36*kz1 - gzq36*k2q84*kz1 - e1*e2*q36q84 & - kz1**2*q36q84) feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {qbar,quark,qbar,gluon,quark,gluon,qbar,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt(0,mu) = k2(mu) k2pt(1,mu) = k4(mu) k2pt(2,mu) = k5(mu) END DO cut2pt(0) = cut(2) cut2pt(1) = cut(4) cut2pt(2) = cut(5) cut2pt(3) = cut(8) call twopointq(k2pt,cut2pt,mumsbar,flag,q24) DO mu = 0,3 k2pt(0,mu) = k8(mu) k2pt(1,mu) = -k6(mu) k2pt(2,mu) = -k7(mu) END DO cut2pt(0) = cut(8) cut2pt(1) = cut(6) cut2pt(2) = cut(7) cut2pt(3) = cut(3) call twopointq(k2pt,cut2pt,mumsbar,flag,q86) gnq24 = 0.0d0 gnq86 = 0.0d0 gzq24 = 0.0d0 gzq86 = 0.0d0 k2q24 = 0.0d0 k2q86 = 0.0d0 q24q86 = 0.0d0 DO mu = 0,3 gnq24 = gnq24 + gn(mu)*q24(mu)*metric(mu) gnq86 = gnq86 + gn(mu)*q86(mu)*metric(mu) gzq24 = gzq24 + gz(mu)*q24(mu)*metric(mu) gzq86 = gzq86 + gz(mu)*q86(mu)*metric(mu) k2q24 = k2q24 + k2(mu)*q24(mu)*metric(mu) k2q86 = k2q86 + k2(mu)*q86(mu)*metric(mu) q24q86 = q24q86 + q24(mu)*q86(mu)*metric(mu) END DO feynman = 12*nc*(e1*gnq86*k2q24 + e1*gnq24*k2q86 & - gzq86*k2q24*kz1 - gzq24*k2q86*kz1 - e1*e2*q24q86 & - kz1**2*q24q86) feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 3) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,quark,gluon,qbar,quark,gluon,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = k6(mu) k2pt2(2,mu) = k7(mu) k2pt2(3,mu) = -k4(mu) k2pt2(4,mu) = -k5(mu) k2pt2(5,mu) = k8(mu) END DO cut2pt2(1) = cut(6) cut2pt2(2) = cut(7) cut2pt2(3) = cut(4) cut2pt2(4) = cut(5) cut2pt2(5) = cut(8) kind2pt2 = 'overlap/qggqq' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqoq64) gnqqoq64 = 0.0d0 gzqqoq64 = 0.0d0 DO mu = 0,3 gnqqoq64 = gnqqoq64 + gn(mu)*qqoq64(mu)*metric(mu) gzqqoq64 = gzqqoq64 + gz(mu)*qqoq64(mu)*metric(mu) END DO feynman = -12*(e1*gnqqoq64 - gzqqoq64*kz1)*nc feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {quark,qbar,quark,gluon,qbar,gluon,quark,gluon} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k3(mu) k2pt2(1,mu) = k7(mu) k2pt2(2,mu) = k6(mu) k2pt2(3,mu) = -k5(mu) k2pt2(4,mu) = -k4(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(7) cut2pt2(2) = cut(6) cut2pt2(3) = cut(5) cut2pt2(4) = cut(4) cut2pt2(5) = cut(8) kind2pt2 = 'overlap/qgqgg' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqog75) gnqqog75 = 0.0d0 gzqqog75 = 0.0d0 DO mu = 0,3 gnqqog75 = gnqqog75 + gn(mu)*qqog75(mu)*metric(mu) gzqqog75 = gzqqog75 + gz(mu)*qqog75(mu)*metric(mu) END DO feynman = -12*(e1*gnqqog75 - gzqqog75*kz1)*nc feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 3) THEN ! types = {qbar,quark,qbar,gluon,quark,qbar,gluon,qbar} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k5(mu) k2pt2(2,mu) = k4(mu) k2pt2(3,mu) = -k7(mu) k2pt2(4,mu) = -k6(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(5) cut2pt2(2) = cut(4) cut2pt2(3) = cut(7) cut2pt2(4) = cut(6) cut2pt2(5) = cut(8) kind2pt2 = 'overlap/qggqq' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqoq57) gnqqoq57 = 0.0d0 gzqqoq57 = 0.0d0 DO mu = 0,3 gnqqoq57 = gnqqoq57 + gn(mu)*qqoq57(mu)*metric(mu) gzqqoq57 = gzqqoq57 + gz(mu)*qqoq57(mu)*metric(mu) END DO feynman = 12*(e1*gnqqoq57 - gzqqoq57*kz1)*nc feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 4) THEN ! types = {qbar,quark,qbar,gluon,quark,gluon,qbar,gluon} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k2pt2(0,mu) = k2(mu) k2pt2(1,mu) = k5(mu) k2pt2(2,mu) = k4(mu) k2pt2(3,mu) = -k7(mu) k2pt2(4,mu) = -k6(mu) k2pt2(5,mu) = -k8(mu) END DO cut2pt2(1) = cut(5) cut2pt2(2) = cut(4) cut2pt2(3) = cut(7) cut2pt2(4) = cut(6) cut2pt2(5) = cut(8) kind2pt2 = 'overlap/qgqgg' call twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,qqog57) gnqqog57 = 0.0d0 gzqqog57 = 0.0d0 DO mu = 0,3 gnqqog57 = gnqqog57 + gn(mu)*qqog57(mu)*metric(mu) gzqqog57 = gzqqog57 + gz(mu)*qqog57(mu)*metric(mu) END DO feynman = 12*(e1*gnqqog57 - gzqqog57*kz1)*nc feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 4) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,qbar,quark,gluon,gluon,qbar,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF DO mu = 0,3 k2pt(0,mu) = k5(mu) k2pt(1,mu) = k8(mu) k2pt(2,mu) = k7(mu) END DO cut2pt(0) = cut(5) cut2pt(1) = cut(8) cut2pt(2) = cut(7) cut2pt(3) = cut(6) kind2pt = 'quarkloop' call twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,g8q) traceg8q = 0.0d0 DO mu = 0,3 traceg8q = traceg8q + g8q(mu,mu)*metric(mu) END DO g8qwgngn = 0.0d0 g8qwgnk1 = 0.0d0 g8qwgnk2 = 0.0d0 g8qwgnk3 = 0.0d0 g8qwgnk4 = 0.0d0 g8qwgzgz = 0.0d0 g8qwgzk1 = 0.0d0 g8qwgzk2 = 0.0d0 g8qwgzk3 = 0.0d0 g8qwgzk4 = 0.0d0 g8qwk1k2 = 0.0d0 g8qwk1k4 = 0.0d0 g8qwk2k3 = 0.0d0 g8qwk3k4 = 0.0d0 DO mu = 0,3 DO nu = 0,3 g8qwgngn = g8qwgngn & + g8q(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) g8qwgnk1 = g8qwgnk1 & + g8q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) g8qwgnk2 = g8qwgnk2 & + g8q(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu) g8qwgnk3 = g8qwgnk3 & + g8q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) g8qwgnk4 = g8qwgnk4 & + g8q(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu) g8qwgzgz = g8qwgzgz & + g8q(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) g8qwgzk1 = g8qwgzk1 & + g8q(mu,nu)*gz(mu)*k1(nu)*metric(mu)*metric(nu) g8qwgzk2 = g8qwgzk2 & + g8q(mu,nu)*gz(mu)*k2(nu)*metric(mu)*metric(nu) g8qwgzk3 = g8qwgzk3 & + g8q(mu,nu)*gz(mu)*k3(nu)*metric(mu)*metric(nu) g8qwgzk4 = g8qwgzk4 & + g8q(mu,nu)*gz(mu)*k4(nu)*metric(mu)*metric(nu) g8qwk1k2 = g8qwk1k2 & + g8q(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) g8qwk1k4 = g8qwk1k4 & + g8q(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu) g8qwk2k3 = g8qwk2k3 & + g8q(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu) g8qwk3k4 = g8qwk3k4 & + g8q(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) END DO END DO k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO x(1) = 2*e1*e4*g8qwk2k3 + 2*g8qwk3k4*k1k2 + g8qwgnk3*(-(e4*k1k2) & - e1*k2k4) + g8qwgzk3*k2k4*kz1 + k1k4*(e2*g8qwgnk3 - 2*g8qwk2k3 & + g8qwgzk3*kz1) x(2) = -(e4*g8qwgnk2) - e2*g8qwgnk4 + (g8qwgngn - g8qwgzgz)*k2k4 & - g8qwgzk4*kz1 x(3) = x(1) + k1k3*x(2) x(4) = 2*e2*g8qwk1k4 - g8qwgnk4*k1k2 + g8qwgnk2*k1k4 & - g8qwgnk1*k2k4 + (e4*k1k2 - e2*k1k4)*traceg8q x(5) = x(3) + e3*x(4) x(6) = e4*g8qwgnk1 + e1*g8qwgnk4 - 2*g8qwk1k4 - g8qwgzk4*kz1 & - e1*e4*traceg8q + k1k4*(-g8qwgngn + g8qwgzgz + 2*traceg8q) x(7) = x(5) + k2k3*x(6) x(8) = -(e2*g8qwgnk1) - e1*g8qwgnk2 + 2*g8qwk1k2 + (g8qwgngn & - g8qwgzgz)*k1k2 + (-g8qwgzk1 + g8qwgzk2)*kz1 x(9) = e1*e2 - 2*k1k2 + kz1**2 x(10) = x(8) + traceg8q*x(9) x(11) = x(7) + k3k4*x(10) x(12) = (-g8qwgzk3 + g8qwgzk4)*k1k2 + g8qwgzk2*(-k1k3 - k1k4) & + g8qwgzk1*(k2k3 + k2k4) x(13) = 2*g8qwk1k4 + 2*g8qwk2k3 + (-k1k4 - k2k3)*traceg8q x(14) = x(12) + kz1*x(13) x(15) = k1k2*traceg8q x(16) = x(11) + kz3*x(14) + kz3**2*x(15) feynman = -12*cf*nc*x(16) feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {quark,qbar,qbar,quark,gluon,gluon,gluon,gluon} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF DO mu = 0,3 k2pt(0,mu) = k5(mu) k2pt(1,mu) = k7(mu) k2pt(2,mu) = k8(mu) END DO cut2pt(0) = cut(5) cut2pt(1) = cut(7) cut2pt(2) = cut(8) cut2pt(3) = cut(6) kind2pt = 'gluonloop' call twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,g7g) traceg7g = 0.0d0 DO mu = 0,3 traceg7g = traceg7g + g7g(mu,mu)*metric(mu) END DO g7gwgngn = 0.0d0 g7gwgnk1 = 0.0d0 g7gwgnk2 = 0.0d0 g7gwgnk3 = 0.0d0 g7gwgnk4 = 0.0d0 g7gwgzgz = 0.0d0 g7gwgzk1 = 0.0d0 g7gwgzk2 = 0.0d0 g7gwgzk3 = 0.0d0 g7gwgzk4 = 0.0d0 g7gwk1k2 = 0.0d0 g7gwk1k4 = 0.0d0 g7gwk2k3 = 0.0d0 g7gwk3k4 = 0.0d0 DO mu = 0,3 DO nu = 0,3 g7gwgngn = g7gwgngn & + g7g(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) g7gwgnk1 = g7gwgnk1 & + g7g(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) g7gwgnk2 = g7gwgnk2 & + g7g(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu) g7gwgnk3 = g7gwgnk3 & + g7g(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) g7gwgnk4 = g7gwgnk4 & + g7g(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu) g7gwgzgz = g7gwgzgz & + g7g(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) g7gwgzk1 = g7gwgzk1 & + g7g(mu,nu)*gz(mu)*k1(nu)*metric(mu)*metric(nu) g7gwgzk2 = g7gwgzk2 & + g7g(mu,nu)*gz(mu)*k2(nu)*metric(mu)*metric(nu) g7gwgzk3 = g7gwgzk3 & + g7g(mu,nu)*gz(mu)*k3(nu)*metric(mu)*metric(nu) g7gwgzk4 = g7gwgzk4 & + g7g(mu,nu)*gz(mu)*k4(nu)*metric(mu)*metric(nu) g7gwk1k2 = g7gwk1k2 & + g7g(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) g7gwk1k4 = g7gwk1k4 & + g7g(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu) g7gwk2k3 = g7gwk2k3 & + g7g(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu) g7gwk3k4 = g7gwk3k4 & + g7g(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) END DO END DO k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO x(1) = 2*e1*e4*g7gwk2k3 + 2*g7gwk3k4*k1k2 + g7gwgnk3*(-(e4*k1k2) & - e1*k2k4) + g7gwgzk3*k2k4*kz1 + k1k4*(e2*g7gwgnk3 - 2*g7gwk2k3 & + g7gwgzk3*kz1) x(2) = -(e4*g7gwgnk2) - e2*g7gwgnk4 + (g7gwgngn - g7gwgzgz)*k2k4 & - g7gwgzk4*kz1 x(3) = x(1) + k1k3*x(2) x(4) = 2*e2*g7gwk1k4 - g7gwgnk4*k1k2 + g7gwgnk2*k1k4 & - g7gwgnk1*k2k4 + (e4*k1k2 - e2*k1k4)*traceg7g x(5) = x(3) + e3*x(4) x(6) = e4*g7gwgnk1 + e1*g7gwgnk4 - 2*g7gwk1k4 - g7gwgzk4*kz1 & - e1*e4*traceg7g + k1k4*(-g7gwgngn + g7gwgzgz + 2*traceg7g) x(7) = x(5) + k2k3*x(6) x(8) = -(e2*g7gwgnk1) - e1*g7gwgnk2 + 2*g7gwk1k2 + (g7gwgngn & - g7gwgzgz)*k1k2 + (-g7gwgzk1 + g7gwgzk2)*kz1 x(9) = e1*e2 - 2*k1k2 + kz1**2 x(10) = x(8) + traceg7g*x(9) x(11) = x(7) + k3k4*x(10) x(12) = (-g7gwgzk3 + g7gwgzk4)*k1k2 + g7gwgzk2*(-k1k3 - k1k4) & + g7gwgzk1*(k2k3 + k2k4) x(13) = 2*g7gwk1k4 + 2*g7gwk2k3 + (-k1k4 - k2k3)*traceg7g x(14) = x(12) + kz1*x(13) x(15) = k1k2*traceg7g x(16) = x(11) + kz3*x(14) + kz3**2*x(15) feynman = -12*cf*nc*x(16) feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 5) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,qbar,quark,gluon,qbar,gluon,quark} ! prefactor = 1.0d0 tk33 = 0.0d0 DO mu = 1,3 tk33 = tk33 - k3(mu)**2 END DO k33 = e3**2 + tk33 IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF DO mu = 0,3 k3pt(1,mu) = -k1(mu) k3pt(2,mu) = k2(mu) k3pt(3,mu) = -k5(mu) END DO cut3pt(1) = cut(1) cut3pt(2) = cut(2) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v1q,a1q) DO mu = 0,3 k2pt(0,mu) = k4(mu) k2pt(1,mu) = k7(mu) k2pt(2,mu) = k8(mu) END DO cut2pt(0) = cut(4) cut2pt(1) = cut(7) cut2pt(2) = cut(8) cut2pt(3) = cut(6) call twopointq(k2pt,cut2pt,mumsbar,flag,q47) tracev1q = 0.0d0 DO mu = 0,3 tracev1q = tracev1q + v1q(mu,mu)*metric(mu) END DO v1qwgngn = 0.0d0 v1qwgnk3 = 0.0d0 v1qwgnq47 = 0.0d0 v1qwgzgz = 0.0d0 v1qwgzk3 = 0.0d0 v1qwgzq47 = 0.0d0 v1qwk3q47 = 0.0d0 v1qwq47k3 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v1qwgngn = v1qwgngn & + v1q(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) v1qwgnk3 = v1qwgnk3 & + v1q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) v1qwgnq47 = v1qwgnq47 & + v1q(mu,nu)*gn(mu)*q47(nu)*metric(mu)*metric(nu) v1qwgzgz = v1qwgzgz & + v1q(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) v1qwgzk3 = v1qwgzk3 & + v1q(mu,nu)*gz(mu)*k3(nu)*metric(mu)*metric(nu) v1qwgzq47 = v1qwgzq47 & + v1q(mu,nu)*gz(mu)*q47(nu)*metric(mu)*metric(nu) v1qwk3q47 = v1qwk3q47 & + v1q(mu,nu)*k3(mu)*q47(nu)*metric(mu)*metric(nu) v1qwq47k3 = v1qwq47k3 & + v1q(mu,nu)*q47(mu)*k3(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a1qgni(mu) = 0.0d0 a1qgzi(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a1qgni(mu) = a1qgni(mu) + a1q(nu,mu)*gn(nu)*metric(nu) a1qgzi(mu) = a1qgzi(mu) + a1q(nu,mu)*gz(nu)*metric(nu) END DO END DO gnq47 = 0.0d0 gzq47 = 0.0d0 k3q47 = 0.0d0 DO mu = 0,3 gnq47 = gnq47 + gn(mu)*q47(mu)*metric(mu) gzq47 = gzq47 + gz(mu)*q47(mu)*metric(mu) k3q47 = k3q47 + k3(mu)*q47(mu)*metric(mu) END DO call epsilont2(a1q,k3,q47,ea1qk3q47) call epsilon4(a1qgni,gn,k3,q47,ea1qgnignk3q47) call epsilon4(a1qgzi,gz,k3,q47,ea1qgzigzk3q47) x(1) = ea1qgnignk3q47 - ea1qgzigzk3q47 + ea1qk3q47 & - gnq47*v1qwgnk3 - e3*v1qwgnq47 + gzq47*v1qwgzk3 + kz3*v1qwgzq47 & + v1qwk3q47 + v1qwq47k3 x(2) = -tracev1q + v1qwgngn - v1qwgzgz x(3) = x(1) + k3q47*x(2) feynman = -6*nc*x(3) feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {qbar,quark,quark,qbar,gluon,quark,gluon,qbar} ! prefactor = 1.0d0 tk33 = 0.0d0 DO mu = 1,3 tk33 = tk33 - k3(mu)**2 END DO k33 = e3**2 + tk33 IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF DO mu = 0,3 k3pt(1,mu) = -k2(mu) k3pt(2,mu) = k1(mu) k3pt(3,mu) = k5(mu) END DO cut3pt(1) = cut(2) cut3pt(2) = cut(1) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v2q,a2q) DO mu = 0,3 k2pt(0,mu) = k6(mu) k2pt(1,mu) = -k7(mu) k2pt(2,mu) = -k8(mu) END DO cut2pt(0) = cut(6) cut2pt(1) = cut(7) cut2pt(2) = cut(8) cut2pt(3) = cut(4) call twopointq(k2pt,cut2pt,mumsbar,flag,q67) tracev2q = 0.0d0 DO mu = 0,3 tracev2q = tracev2q + v2q(mu,mu)*metric(mu) END DO v2qwgngn = 0.0d0 v2qwgnk3 = 0.0d0 v2qwgnq67 = 0.0d0 v2qwgzgz = 0.0d0 v2qwgzk3 = 0.0d0 v2qwgzq67 = 0.0d0 v2qwk3q67 = 0.0d0 v2qwq67k3 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v2qwgngn = v2qwgngn & + v2q(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) v2qwgnk3 = v2qwgnk3 & + v2q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) v2qwgnq67 = v2qwgnq67 & + v2q(mu,nu)*gn(mu)*q67(nu)*metric(mu)*metric(nu) v2qwgzgz = v2qwgzgz & + v2q(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) v2qwgzk3 = v2qwgzk3 & + v2q(mu,nu)*gz(mu)*k3(nu)*metric(mu)*metric(nu) v2qwgzq67 = v2qwgzq67 & + v2q(mu,nu)*gz(mu)*q67(nu)*metric(mu)*metric(nu) v2qwk3q67 = v2qwk3q67 & + v2q(mu,nu)*k3(mu)*q67(nu)*metric(mu)*metric(nu) v2qwq67k3 = v2qwq67k3 & + v2q(mu,nu)*q67(mu)*k3(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a2qgni(mu) = 0.0d0 a2qgzi(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a2qgni(mu) = a2qgni(mu) + a2q(nu,mu)*gn(nu)*metric(nu) a2qgzi(mu) = a2qgzi(mu) + a2q(nu,mu)*gz(nu)*metric(nu) END DO END DO gnq67 = 0.0d0 gzq67 = 0.0d0 k3q67 = 0.0d0 DO mu = 0,3 gnq67 = gnq67 + gn(mu)*q67(mu)*metric(mu) gzq67 = gzq67 + gz(mu)*q67(mu)*metric(mu) k3q67 = k3q67 + k3(mu)*q67(mu)*metric(mu) END DO call epsilont2(a2q,k3,q67,ea2qk3q67) call epsilon4(a2qgni,gn,k3,q67,ea2qgnignk3q67) call epsilon4(a2qgzi,gz,k3,q67,ea2qgzigzk3q67) x(1) = ea2qgnignk3q67 - ea2qgzigzk3q67 + ea2qk3q67 & + gnq67*v2qwgnk3 + e3*v2qwgnq67 - gzq67*v2qwgzk3 - kz3*v2qwgzq67 & - v2qwk3q67 - v2qwq67k3 x(2) = tracev2q - v2qwgngn + v2qwgzgz x(3) = x(1) + k3q67*x(2) feynman = -6*nc*x(3) feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 6) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,qbar,quark,gluon,gluon,qbar,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k3pt(1,mu) = -k4(mu) k3pt(2,mu) = k3(mu) k3pt(3,mu) = k5(mu) END DO cut3pt(1) = cut(4) cut3pt(2) = cut(3) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q) DO mu = 0,3 k2pt(0,mu) = k8(mu) k2pt(1,mu) = -k6(mu) k2pt(2,mu) = -k7(mu) END DO cut2pt(0) = cut(8) cut2pt(1) = cut(6) cut2pt(2) = cut(7) cut2pt(3) = cut(2) call twopointq(k2pt,cut2pt,mumsbar,flag,q86) tracev4q = 0.0d0 DO mu = 0,3 tracev4q = tracev4q + v4q(mu,mu)*metric(mu) END DO v4qwgngn = 0.0d0 v4qwgnk1 = 0.0d0 v4qwgnq86 = 0.0d0 v4qwgzgz = 0.0d0 v4qwgzk1 = 0.0d0 v4qwgzq86 = 0.0d0 v4qwk1q86 = 0.0d0 v4qwq86k1 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v4qwgngn = v4qwgngn & + v4q(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) v4qwgnk1 = v4qwgnk1 & + v4q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) v4qwgnq86 = v4qwgnq86 & + v4q(mu,nu)*gn(mu)*q86(nu)*metric(mu)*metric(nu) v4qwgzgz = v4qwgzgz & + v4q(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) v4qwgzk1 = v4qwgzk1 & + v4q(mu,nu)*gz(mu)*k1(nu)*metric(mu)*metric(nu) v4qwgzq86 = v4qwgzq86 & + v4q(mu,nu)*gz(mu)*q86(nu)*metric(mu)*metric(nu) v4qwk1q86 = v4qwk1q86 & + v4q(mu,nu)*k1(mu)*q86(nu)*metric(mu)*metric(nu) v4qwq86k1 = v4qwq86k1 & + v4q(mu,nu)*q86(mu)*k1(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a4qgni(mu) = 0.0d0 a4qgzi(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a4qgni(mu) = a4qgni(mu) + a4q(nu,mu)*gn(nu)*metric(nu) a4qgzi(mu) = a4qgzi(mu) + a4q(nu,mu)*gz(nu)*metric(nu) END DO END DO gnq86 = 0.0d0 gzq86 = 0.0d0 k1q86 = 0.0d0 DO mu = 0,3 gnq86 = gnq86 + gn(mu)*q86(mu)*metric(mu) gzq86 = gzq86 + gz(mu)*q86(mu)*metric(mu) k1q86 = k1q86 + k1(mu)*q86(mu)*metric(mu) END DO call epsilont2(a4q,k1,q86,ea4qk1q86) call epsilon4(a4qgni,gn,k1,q86,ea4qgnignk1q86) call epsilon4(a4qgzi,gz,k1,q86,ea4qgzigzk1q86) x(1) = ea4qgnignk1q86 - ea4qgzigzk1q86 + ea4qk1q86 & + gnq86*v4qwgnk1 + e1*v4qwgnq86 - gzq86*v4qwgzk1 - kz1*v4qwgzq86 & - v4qwk1q86 - v4qwq86k1 x(2) = tracev4q - v4qwgngn + v4qwgzgz x(3) = x(1) + k1q86*x(2) feynman = -6*nc*x(3) feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {qbar,quark,quark,qbar,gluon,gluon,quark,qbar} ! prefactor = 1.0d0 tk11 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 END DO k11 = e1**2 + tk11 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF DO mu = 0,3 k3pt(1,mu) = -k3(mu) k3pt(2,mu) = k4(mu) k3pt(3,mu) = -k5(mu) END DO cut3pt(1) = cut(3) cut3pt(2) = cut(4) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v3q,a3q) DO mu = 0,3 k2pt(0,mu) = k2(mu) k2pt(1,mu) = k6(mu) k2pt(2,mu) = k7(mu) END DO cut2pt(0) = cut(2) cut2pt(1) = cut(6) cut2pt(2) = cut(7) cut2pt(3) = cut(8) call twopointq(k2pt,cut2pt,mumsbar,flag,q26) tracev3q = 0.0d0 DO mu = 0,3 tracev3q = tracev3q + v3q(mu,mu)*metric(mu) END DO v3qwgngn = 0.0d0 v3qwgnk1 = 0.0d0 v3qwgnq26 = 0.0d0 v3qwgzgz = 0.0d0 v3qwgzk1 = 0.0d0 v3qwgzq26 = 0.0d0 v3qwk1q26 = 0.0d0 v3qwq26k1 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v3qwgngn = v3qwgngn & + v3q(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) v3qwgnk1 = v3qwgnk1 & + v3q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) v3qwgnq26 = v3qwgnq26 & + v3q(mu,nu)*gn(mu)*q26(nu)*metric(mu)*metric(nu) v3qwgzgz = v3qwgzgz & + v3q(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) v3qwgzk1 = v3qwgzk1 & + v3q(mu,nu)*gz(mu)*k1(nu)*metric(mu)*metric(nu) v3qwgzq26 = v3qwgzq26 & + v3q(mu,nu)*gz(mu)*q26(nu)*metric(mu)*metric(nu) v3qwk1q26 = v3qwk1q26 & + v3q(mu,nu)*k1(mu)*q26(nu)*metric(mu)*metric(nu) v3qwq26k1 = v3qwq26k1 & + v3q(mu,nu)*q26(mu)*k1(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a3qgni(mu) = 0.0d0 a3qgzi(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a3qgni(mu) = a3qgni(mu) + a3q(nu,mu)*gn(nu)*metric(nu) a3qgzi(mu) = a3qgzi(mu) + a3q(nu,mu)*gz(nu)*metric(nu) END DO END DO gnq26 = 0.0d0 gzq26 = 0.0d0 k1q26 = 0.0d0 DO mu = 0,3 gnq26 = gnq26 + gn(mu)*q26(mu)*metric(mu) gzq26 = gzq26 + gz(mu)*q26(mu)*metric(mu) k1q26 = k1q26 + k1(mu)*q26(mu)*metric(mu) END DO call epsilont2(a3q,k1,q26,ea3qk1q26) call epsilon4(a3qgni,gn,k1,q26,ea3qgnignk1q26) call epsilon4(a3qgzi,gz,k1,q26,ea3qgzigzk1q26) x(1) = ea3qgnignk1q26 - ea3qgzigzk1q26 + ea3qk1q26 & - gnq26*v3qwgnk1 - e1*v3qwgnq26 + gzq26*v3qwgzk1 + kz1*v3qwgzq26 & + v3qwk1q26 + v3qwq26k1 x(2) = -tracev3q + v3qwgngn - v3qwgzgz x(3) = x(1) + k1q26*x(2) feynman = -6*nc*x(3) feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 7) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,qbar,quark,gluon,qbar,gluon,gluon} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF DO mu = 0,3 k3pt(1,mu) = k7(mu) k3pt(2,mu) = -k8(mu) k3pt(3,mu) = -k6(mu) END DO cut3pt(1) = cut(7) cut3pt(2) = cut(8) cut3pt(3) = cut(6) kind3pt = 'qqg/ggq' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v7g,a7g) tracev7g = 0.0d0 DO mu = 0,3 tracev7g = tracev7g + v7g(mu,mu)*metric(mu) END DO v7gwgngn = 0.0d0 v7gwgngz = 0.0d0 v7gwgnk1 = 0.0d0 v7gwgnk2 = 0.0d0 v7gwgnk3 = 0.0d0 v7gwgnk4 = 0.0d0 v7gwgzgz = 0.0d0 v7gwgzk1 = 0.0d0 v7gwgzk2 = 0.0d0 v7gwgzk3 = 0.0d0 v7gwgzk4 = 0.0d0 v7gwk1gn = 0.0d0 v7gwk1gz = 0.0d0 v7gwk1k2 = 0.0d0 v7gwk1k4 = 0.0d0 v7gwk2gn = 0.0d0 v7gwk2gz = 0.0d0 v7gwk2k1 = 0.0d0 v7gwk2k3 = 0.0d0 v7gwk3gn = 0.0d0 v7gwk3gz = 0.0d0 v7gwk3k2 = 0.0d0 v7gwk3k4 = 0.0d0 v7gwk4gn = 0.0d0 v7gwk4gz = 0.0d0 v7gwk4k1 = 0.0d0 v7gwk4k3 = 0.0d0 v7gwk5gn = 0.0d0 v7gwk5gz = 0.0d0 v7gwk5k1 = 0.0d0 v7gwk5k2 = 0.0d0 v7gwk5k3 = 0.0d0 v7gwk5k4 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v7gwgngn = v7gwgngn & + v7g(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) v7gwgngz = v7gwgngz & + v7g(mu,nu)*gn(mu)*gz(nu)*metric(mu)*metric(nu) v7gwgnk1 = v7gwgnk1 & + v7g(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) v7gwgnk2 = v7gwgnk2 & + v7g(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu) v7gwgnk3 = v7gwgnk3 & + v7g(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) v7gwgnk4 = v7gwgnk4 & + v7g(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu) v7gwgzgz = v7gwgzgz & + v7g(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) v7gwgzk1 = v7gwgzk1 & + v7g(mu,nu)*gz(mu)*k1(nu)*metric(mu)*metric(nu) v7gwgzk2 = v7gwgzk2 & + v7g(mu,nu)*gz(mu)*k2(nu)*metric(mu)*metric(nu) v7gwgzk3 = v7gwgzk3 & + v7g(mu,nu)*gz(mu)*k3(nu)*metric(mu)*metric(nu) v7gwgzk4 = v7gwgzk4 & + v7g(mu,nu)*gz(mu)*k4(nu)*metric(mu)*metric(nu) v7gwk1gn = v7gwk1gn & + v7g(mu,nu)*k1(mu)*gn(nu)*metric(mu)*metric(nu) v7gwk1gz = v7gwk1gz & + v7g(mu,nu)*k1(mu)*gz(nu)*metric(mu)*metric(nu) v7gwk1k2 = v7gwk1k2 & + v7g(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) v7gwk1k4 = v7gwk1k4 & + v7g(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu) v7gwk2gn = v7gwk2gn & + v7g(mu,nu)*k2(mu)*gn(nu)*metric(mu)*metric(nu) v7gwk2gz = v7gwk2gz & + v7g(mu,nu)*k2(mu)*gz(nu)*metric(mu)*metric(nu) v7gwk2k1 = v7gwk2k1 & + v7g(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu) v7gwk2k3 = v7gwk2k3 & + v7g(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu) v7gwk3gn = v7gwk3gn & + v7g(mu,nu)*k3(mu)*gn(nu)*metric(mu)*metric(nu) v7gwk3gz = v7gwk3gz & + v7g(mu,nu)*k3(mu)*gz(nu)*metric(mu)*metric(nu) v7gwk3k2 = v7gwk3k2 & + v7g(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu) v7gwk3k4 = v7gwk3k4 & + v7g(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) v7gwk4gn = v7gwk4gn & + v7g(mu,nu)*k4(mu)*gn(nu)*metric(mu)*metric(nu) v7gwk4gz = v7gwk4gz & + v7g(mu,nu)*k4(mu)*gz(nu)*metric(mu)*metric(nu) v7gwk4k1 = v7gwk4k1 & + v7g(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu) v7gwk4k3 = v7gwk4k3 & + v7g(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu) v7gwk5gn = v7gwk5gn & + v7g(mu,nu)*k5(mu)*gn(nu)*metric(mu)*metric(nu) v7gwk5gz = v7gwk5gz & + v7g(mu,nu)*k5(mu)*gz(nu)*metric(mu)*metric(nu) v7gwk5k1 = v7gwk5k1 & + v7g(mu,nu)*k5(mu)*k1(nu)*metric(mu)*metric(nu) v7gwk5k2 = v7gwk5k2 & + v7g(mu,nu)*k5(mu)*k2(nu)*metric(mu)*metric(nu) v7gwk5k3 = v7gwk5k3 & + v7g(mu,nu)*k5(mu)*k3(nu)*metric(mu)*metric(nu) v7gwk5k4 = v7gwk5k4 & + v7g(mu,nu)*k5(mu)*k4(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a7ggni(mu) = 0.0d0 a7ggzi(mu) = 0.0d0 a7gk1i(mu) = 0.0d0 a7gk2i(mu) = 0.0d0 a7gk3i(mu) = 0.0d0 a7gk4i(mu) = 0.0d0 a7gk5i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a7ggni(mu) = a7ggni(mu) + a7g(nu,mu)*gn(nu)*metric(nu) a7ggzi(mu) = a7ggzi(mu) + a7g(nu,mu)*gz(nu)*metric(nu) a7gk1i(mu) = a7gk1i(mu) + a7g(nu,mu)*k1(nu)*metric(nu) a7gk2i(mu) = a7gk2i(mu) + a7g(nu,mu)*k2(nu)*metric(nu) a7gk3i(mu) = a7gk3i(mu) + a7g(nu,mu)*k3(nu)*metric(nu) a7gk4i(mu) = a7gk4i(mu) + a7g(nu,mu)*k4(nu)*metric(nu) a7gk5i(mu) = a7gk5i(mu) + a7g(nu,mu)*k5(nu)*metric(nu) END DO END DO k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO call epsilont2(a7g,gn,k1,ea7ggnk1) call epsilont2(a7g,gn,k2,ea7ggnk2) call epsilont2(a7g,gn,k3,ea7ggnk3) call epsilont2(a7g,gn,k4,ea7ggnk4) call epsilont2(a7g,gz,k1,ea7ggzk1) call epsilont2(a7g,gz,k2,ea7ggzk2) call epsilont2(a7g,gz,k3,ea7ggzk3) call epsilont2(a7g,gz,k4,ea7ggzk4) call epsilont2(a7g,k1,k2,ea7gk1k2) call epsilont2(a7g,k1,k3,ea7gk1k3) call epsilont2(a7g,k1,k4,ea7gk1k4) call epsilont2(a7g,k2,k3,ea7gk2k3) call epsilont2(a7g,k3,k4,ea7gk3k4) call epsilon4(a7ggni,gn,k1,k2,ea7ggnignk1k2) call epsilon4(a7ggni,gn,k1,k3,ea7ggnignk1k3) call epsilon4(a7ggni,gn,k1,k4,ea7ggnignk1k4) call epsilon4(a7ggni,gn,k2,k3,ea7ggnignk2k3) call epsilon4(a7ggni,gn,k2,k4,ea7ggnignk2k4) call epsilon4(a7ggni,gn,k3,k4,ea7ggnignk3k4) call epsilon4(a7ggni,gz,k2,k4,ea7ggnigzk2k4) call epsilon4(a7ggni,k1,k2,k3,ea7ggnik1k2k3) call epsilon4(a7ggni,k1,k3,k4,ea7ggnik1k3k4) call epsilon4(a7ggzi,gz,k1,k2,ea7ggzigzk1k2) call epsilon4(a7ggzi,gz,k1,k3,ea7ggzigzk1k3) call epsilon4(a7ggzi,gz,k1,k4,ea7ggzigzk1k4) call epsilon4(a7ggzi,gz,k2,k3,ea7ggzigzk2k3) call epsilon4(a7ggzi,gz,k2,k4,ea7ggzigzk2k4) call epsilon4(a7ggzi,gz,k3,k4,ea7ggzigzk3k4) call epsilon4(a7ggzi,k1,k2,k3,ea7ggzik1k2k3) call epsilon4(a7ggzi,k1,k3,k4,ea7ggzik1k3k4) call epsilon4(a7gk1i,gn,k2,k4,ea7gk1ignk2k4) call epsilon4(a7gk1i,gz,k2,k4,ea7gk1igzk2k4) call epsilon4(a7gk2i,gn,k1,k4,ea7gk2ignk1k4) call epsilon4(a7gk2i,gn,k3,k4,ea7gk2ignk3k4) call epsilon4(a7gk2i,gz,k1,k4,ea7gk2igzk1k4) call epsilon4(a7gk2i,gz,k3,k4,ea7gk2igzk3k4) call epsilon4(a7gk2i,k1,k3,k4,ea7gk2ik1k3k4) call epsilon4(a7gk3i,gn,k2,k4,ea7gk3ignk2k4) call epsilon4(a7gk3i,gz,k2,k4,ea7gk3igzk2k4) call epsilon4(a7gk4i,gn,k1,k2,ea7gk4ignk1k2) call epsilon4(a7gk4i,gn,k2,k3,ea7gk4ignk2k3) call epsilon4(a7gk4i,gz,k1,k2,ea7gk4igzk1k2) call epsilon4(a7gk4i,gz,k2,k3,ea7gk4igzk2k3) call epsilon4(a7gk4i,k1,k2,k3,ea7gk4ik1k2k3) call epsilon4(a7gk5i,gn,gz,k1,ea7gk5igngzk1) call epsilon4(a7gk5i,gn,gz,k2,ea7gk5igngzk2) call epsilon4(a7gk5i,gn,gz,k3,ea7gk5igngzk3) call epsilon4(a7gk5i,gn,gz,k4,ea7gk5igngzk4) call epsilon4(a7gk5i,gn,k1,k2,ea7gk5ignk1k2) call epsilon4(a7gk5i,gn,k1,k3,ea7gk5ignk1k3) call epsilon4(a7gk5i,gn,k1,k4,ea7gk5ignk1k4) call epsilon4(a7gk5i,gn,k2,k3,ea7gk5ignk2k3) call epsilon4(a7gk5i,gn,k2,k4,ea7gk5ignk2k4) call epsilon4(a7gk5i,gn,k3,k4,ea7gk5ignk3k4) call epsilon4(a7gk5i,gz,k1,k2,ea7gk5igzk1k2) call epsilon4(a7gk5i,gz,k1,k4,ea7gk5igzk1k4) call epsilon4(a7gk5i,gz,k2,k3,ea7gk5igzk2k3) call epsilon4(a7gk5i,gz,k2,k4,ea7gk5igzk2k4) call epsilon4(a7gk5i,gz,k3,k4,ea7gk5igzk3k4) call epsilon4(a7gk5i,k1,k2,k3,ea7gk5ik1k2k3) call epsilon4(a7gk5i,k1,k3,k4,ea7gk5ik1k3k4) x(1) = k11*(-(kz3**2*v7gwk5k2) + e3*(ea7gk5ignk2k4 & + k2k4*v7gwk5gn - e4*v7gwk5k2 - e2*v7gwk5k4) + kz3 & *(-ea7gk5igzk2k4 - k2k4*v7gwk5gz - kz1*v7gwk5k4)) x(2) = kz1*(-ea7gk5igzk2k4 - k2k4*v7gwk5gz - kz3*v7gwk5k2) & - kz1**2*v7gwk5k4 + e1*(ea7gk5ignk2k4 + k2k4*v7gwk5gn & - e4*v7gwk5k2 - e2*v7gwk5k4) x(3) = x(1) + k33*x(2) x(4) = -(ea7gk5ignk3k4*k1k2) + ea7gk5ignk2k4*k1k3 & + ea7gk5ignk2k3*k1k4 + ea7gk5ignk1k4*k2k3 - ea7gk5ignk1k3*k2k4 & + ea7gk5ignk1k2*k3k4 + k33*(-(e1*ea7ggnignk2k4) & - e1*k2k4*v7gwgngn) x(5) = k1k4*k2k3 + k1k3*k2k4 - k1k2*k3k4 x(6) = x(4) + v7gwk5gn*x(5) x(7) = ea7gk5ik1k3k4 + e1*k33*v7gwgnk4 + k3k4*v7gwk5k1 & - k1k4*v7gwk5k3 - k1k3*v7gwk5k4 x(8) = x(6) + e2*x(7) x(9) = -ea7gk5ik1k2k3 + e1*k33*v7gwgnk2 - k2k3*v7gwk5k1 & - k1k3*v7gwk5k2 + k1k2*v7gwk5k3 x(10) = x(8) + e4*x(9) x(11) = k11*(-ea7ggnignk2k4 - k2k4*v7gwgngn + e4*v7gwgnk2 & + e2*v7gwgnk4) + e1*(-2*ea7gk5ignk2k4 - 2*k2k4*v7gwk5gn & + 2*e4*v7gwk5k2 + 2*e2*v7gwk5k4) x(12) = x(10) + e3*x(11) x(13) = -(e4*ea7gk5igzk2k3) + e3*ea7gk5igzk2k4 + e2*ea7gk5igzk3k4 & + ea7gk5igngzk4*k2k3 - ea7gk5igngzk3*k2k4 + ea7gk5igngzk2*k3k4 & + k33*(ea7ggnigzk2k4 + k2k4*v7gwgngz) x(14) = -(e4*k2k3) + e3*k2k4 + e2*k3k4 x(15) = x(13) + v7gwk5gz*x(14) x(16) = ea7gk5ignk3k4 + k33*v7gwgnk4 + k3k4*v7gwk5gn & - e4*v7gwk5k3 + e3*v7gwk5k4 x(17) = x(12) + kz1*x(15) + kz1**2*x(16) x(18) = -(e4*ea7gk5igzk1k2) - e2*ea7gk5igzk1k4 + e1*ea7gk5igzk2k4 & + ea7ggnigzk2k4*k11 - ea7gk5igngzk4*k1k2 - ea7gk5igngzk2*k1k4 & + k2k4*(ea7gk5igngzk1 + k11*v7gwgngz) x(19) = e4*k1k2 - e2*k1k4 + e1*k2k4 x(20) = x(18) + v7gwk5gz*x(19) x(21) = -ea7gk5ignk1k4 - ea7gk5ignk2k3 + k33*v7gwgnk2 & + k11*v7gwgnk4 + e4*v7gwk5k1 + e3*v7gwk5k2 + e2*v7gwk5k3 & + e1*v7gwk5k4 x(22) = -k1k4 - k2k3 x(23) = x(21) + v7gwk5gn*x(22) x(24) = x(20) + kz1*x(23) x(25) = -ea7gk5ignk1k2 + k11*v7gwgnk2 + k1k2*v7gwk5gn & - e2*v7gwk5k1 + e1*v7gwk5k2 x(26) = x(17) + kz3*x(24) + kz3**2*x(25) x(27) = x(3) + e5*x(26) x(28) = e4*ea7ggnik1k2k3 - e2*ea7ggnik1k3k4 + 2*ea7gk2ik1k3k4 & - 2*ea7gk4ik1k2k3 + (ea7ggnignk1k3 - ea7ggzigzk1k3 & + 2*ea7gk1k3)*k2k4 x(29) = ea7ggnignk3k4 - ea7ggzigzk3k4 + 2*ea7gk3k4 - e4*v7gwgnk3 & + 2*v7gwk4k3 x(30) = x(28) + k1k2*x(29) x(31) = -ea7ggnignk2k3 + ea7ggzigzk2k3 - 2*ea7gk2k3 + e2*v7gwgnk3 & - 2*v7gwk2k3 x(32) = x(30) + k1k4*x(31) x(33) = ea7ggnignk2k4 - ea7ggzigzk2k4 - e4*v7gwgnk2 - e2*v7gwgnk4 & + k2k4*(v7gwgngn - v7gwgzgz) x(34) = x(32) + k1k3*x(33) x(35) = -ea7ggnignk1k4 + ea7ggzigzk1k4 - 2*ea7gk1k4 + e4*v7gwgnk1 & + k1k4*(2*tracev7g - v7gwgngn + v7gwgzgz) - 2*v7gwk4k1 x(36) = x(34) + k2k3*x(35) x(37) = -ea7ggnignk1k2 + ea7ggzigzk1k2 - 2*ea7gk1k2 - e2*v7gwgnk1 & + k1k2*(-2*tracev7g + v7gwgngn - v7gwgzgz) + 2*v7gwk2k1 x(38) = x(36) + k3k4*x(37) x(39) = -ea7gk2ignk3k4 - ea7gk3ignk2k4 + ea7gk4ignk2k3 + k3k4 & *(ea7ggnk2 - v7gwk2gn) + k2k4*(-ea7ggnk3 - v7gwk3gn) + k2k3 & *(ea7ggnk4 + v7gwk4gn) x(40) = -ea7gk3k4 + k3k4*tracev7g + v7gwk3k4 - v7gwk4k3 x(41) = x(39) + e2*x(40) x(42) = ea7gk2k3 - k2k3*tracev7g + v7gwk2k3 + v7gwk3k2 x(43) = x(41) + e4*x(42) x(44) = x(38) + e1*x(43) x(45) = -ea7gk1ignk2k4 + ea7gk2ignk1k4 + ea7gk4ignk1k2 + k2k4 & *(ea7ggnk1 - v7gwk1gn) + k1k4*(-ea7ggnk2 + v7gwk2gn) + k1k2 & *(-ea7ggnk4 - v7gwk4gn) x(46) = ea7gk1k4 - k1k4*tracev7g + v7gwk1k4 + v7gwk4k1 x(47) = x(45) + e2*x(46) x(48) = ea7gk1k2 + k1k2*tracev7g + v7gwk1k2 - v7gwk2k1 x(49) = x(47) + e4*x(48) x(50) = x(44) + e3*x(49) x(51) = -ea7ggzik1k3k4 + ea7gk2igzk3k4 + ea7gk3igzk2k4 & - ea7gk4igzk2k3 + k1k4*v7gwgzk3 - k1k3*v7gwgzk4 + k2k3*(-ea7ggzk4 & - v7gwk4gz) x(52) = ea7ggzk3 + v7gwk3gz x(53) = x(51) + k2k4*x(52) x(54) = -ea7ggzk2 - v7gwgzk1 + v7gwk2gz x(55) = x(53) + k3k4*x(54) x(56) = -ea7gk3k4 + k3k4*tracev7g + v7gwk3k4 - v7gwk4k3 x(57) = x(50) + kz1*x(55) + kz1**2*x(56) x(58) = ea7ggzik1k2k3 + ea7gk1igzk2k4 - ea7gk2igzk1k4 & - ea7gk4igzk1k2 + k2k3*v7gwgzk1 - k1k3*v7gwgzk2 + k1k4*(ea7ggzk2 & - v7gwk2gz) x(59) = -ea7ggzk1 + v7gwk1gz x(60) = x(58) + k2k4*x(59) x(61) = ea7ggzk4 - v7gwgzk3 + v7gwk4gz x(62) = x(60) + k1k2*x(61) x(63) = ea7gk1k4 + ea7gk2k3 + (-k1k4 - k2k3)*tracev7g + v7gwk1k4 & + v7gwk2k3 + v7gwk3k2 + v7gwk4k1 x(64) = x(62) + kz1*x(63) x(65) = ea7gk1k2 + k1k2*tracev7g + v7gwk1k2 - v7gwk2k1 x(66) = x(57) + kz3*x(64) + kz3**2*x(65) x(67) = x(27) + tk55*x(66) feynman = (12*cf*nc*x(67))/tk55 feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {quark,qbar,qbar,quark,gluon,gluon,qbar,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF DO mu = 0,3 k3pt(1,mu) = k7(mu) k3pt(2,mu) = -k8(mu) k3pt(3,mu) = -k6(mu) END DO cut3pt(1) = cut(7) cut3pt(2) = cut(8) cut3pt(3) = cut(6) kind3pt = 'qqg/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v7q,a7q) tracev7q = 0.0d0 DO mu = 0,3 tracev7q = tracev7q + v7q(mu,mu)*metric(mu) END DO v7qwgngn = 0.0d0 v7qwgngz = 0.0d0 v7qwgnk1 = 0.0d0 v7qwgnk2 = 0.0d0 v7qwgnk3 = 0.0d0 v7qwgnk4 = 0.0d0 v7qwgzgz = 0.0d0 v7qwgzk1 = 0.0d0 v7qwgzk2 = 0.0d0 v7qwgzk3 = 0.0d0 v7qwgzk4 = 0.0d0 v7qwk1gn = 0.0d0 v7qwk1gz = 0.0d0 v7qwk1k2 = 0.0d0 v7qwk1k4 = 0.0d0 v7qwk2gn = 0.0d0 v7qwk2gz = 0.0d0 v7qwk2k1 = 0.0d0 v7qwk2k3 = 0.0d0 v7qwk3gn = 0.0d0 v7qwk3gz = 0.0d0 v7qwk3k2 = 0.0d0 v7qwk3k4 = 0.0d0 v7qwk4gn = 0.0d0 v7qwk4gz = 0.0d0 v7qwk4k1 = 0.0d0 v7qwk4k3 = 0.0d0 v7qwk5gn = 0.0d0 v7qwk5gz = 0.0d0 v7qwk5k1 = 0.0d0 v7qwk5k2 = 0.0d0 v7qwk5k3 = 0.0d0 v7qwk5k4 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v7qwgngn = v7qwgngn & + v7q(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) v7qwgngz = v7qwgngz & + v7q(mu,nu)*gn(mu)*gz(nu)*metric(mu)*metric(nu) v7qwgnk1 = v7qwgnk1 & + v7q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) v7qwgnk2 = v7qwgnk2 & + v7q(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu) v7qwgnk3 = v7qwgnk3 & + v7q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) v7qwgnk4 = v7qwgnk4 & + v7q(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu) v7qwgzgz = v7qwgzgz & + v7q(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) v7qwgzk1 = v7qwgzk1 & + v7q(mu,nu)*gz(mu)*k1(nu)*metric(mu)*metric(nu) v7qwgzk2 = v7qwgzk2 & + v7q(mu,nu)*gz(mu)*k2(nu)*metric(mu)*metric(nu) v7qwgzk3 = v7qwgzk3 & + v7q(mu,nu)*gz(mu)*k3(nu)*metric(mu)*metric(nu) v7qwgzk4 = v7qwgzk4 & + v7q(mu,nu)*gz(mu)*k4(nu)*metric(mu)*metric(nu) v7qwk1gn = v7qwk1gn & + v7q(mu,nu)*k1(mu)*gn(nu)*metric(mu)*metric(nu) v7qwk1gz = v7qwk1gz & + v7q(mu,nu)*k1(mu)*gz(nu)*metric(mu)*metric(nu) v7qwk1k2 = v7qwk1k2 & + v7q(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) v7qwk1k4 = v7qwk1k4 & + v7q(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu) v7qwk2gn = v7qwk2gn & + v7q(mu,nu)*k2(mu)*gn(nu)*metric(mu)*metric(nu) v7qwk2gz = v7qwk2gz & + v7q(mu,nu)*k2(mu)*gz(nu)*metric(mu)*metric(nu) v7qwk2k1 = v7qwk2k1 & + v7q(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu) v7qwk2k3 = v7qwk2k3 & + v7q(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu) v7qwk3gn = v7qwk3gn & + v7q(mu,nu)*k3(mu)*gn(nu)*metric(mu)*metric(nu) v7qwk3gz = v7qwk3gz & + v7q(mu,nu)*k3(mu)*gz(nu)*metric(mu)*metric(nu) v7qwk3k2 = v7qwk3k2 & + v7q(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu) v7qwk3k4 = v7qwk3k4 & + v7q(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) v7qwk4gn = v7qwk4gn & + v7q(mu,nu)*k4(mu)*gn(nu)*metric(mu)*metric(nu) v7qwk4gz = v7qwk4gz & + v7q(mu,nu)*k4(mu)*gz(nu)*metric(mu)*metric(nu) v7qwk4k1 = v7qwk4k1 & + v7q(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu) v7qwk4k3 = v7qwk4k3 & + v7q(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu) v7qwk5gn = v7qwk5gn & + v7q(mu,nu)*k5(mu)*gn(nu)*metric(mu)*metric(nu) v7qwk5gz = v7qwk5gz & + v7q(mu,nu)*k5(mu)*gz(nu)*metric(mu)*metric(nu) v7qwk5k1 = v7qwk5k1 & + v7q(mu,nu)*k5(mu)*k1(nu)*metric(mu)*metric(nu) v7qwk5k2 = v7qwk5k2 & + v7q(mu,nu)*k5(mu)*k2(nu)*metric(mu)*metric(nu) v7qwk5k3 = v7qwk5k3 & + v7q(mu,nu)*k5(mu)*k3(nu)*metric(mu)*metric(nu) v7qwk5k4 = v7qwk5k4 & + v7q(mu,nu)*k5(mu)*k4(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a7qgni(mu) = 0.0d0 a7qgzi(mu) = 0.0d0 a7qk1i(mu) = 0.0d0 a7qk2i(mu) = 0.0d0 a7qk3i(mu) = 0.0d0 a7qk4i(mu) = 0.0d0 a7qk5i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a7qgni(mu) = a7qgni(mu) + a7q(nu,mu)*gn(nu)*metric(nu) a7qgzi(mu) = a7qgzi(mu) + a7q(nu,mu)*gz(nu)*metric(nu) a7qk1i(mu) = a7qk1i(mu) + a7q(nu,mu)*k1(nu)*metric(nu) a7qk2i(mu) = a7qk2i(mu) + a7q(nu,mu)*k2(nu)*metric(nu) a7qk3i(mu) = a7qk3i(mu) + a7q(nu,mu)*k3(nu)*metric(nu) a7qk4i(mu) = a7qk4i(mu) + a7q(nu,mu)*k4(nu)*metric(nu) a7qk5i(mu) = a7qk5i(mu) + a7q(nu,mu)*k5(nu)*metric(nu) END DO END DO k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO call epsilont2(a7q,gn,k1,ea7qgnk1) call epsilont2(a7q,gn,k2,ea7qgnk2) call epsilont2(a7q,gn,k3,ea7qgnk3) call epsilont2(a7q,gn,k4,ea7qgnk4) call epsilont2(a7q,gz,k1,ea7qgzk1) call epsilont2(a7q,gz,k2,ea7qgzk2) call epsilont2(a7q,gz,k3,ea7qgzk3) call epsilont2(a7q,gz,k4,ea7qgzk4) call epsilont2(a7q,k1,k2,ea7qk1k2) call epsilont2(a7q,k1,k3,ea7qk1k3) call epsilont2(a7q,k1,k4,ea7qk1k4) call epsilont2(a7q,k2,k3,ea7qk2k3) call epsilont2(a7q,k3,k4,ea7qk3k4) call epsilon4(a7qgni,gn,k1,k2,ea7qgnignk1k2) call epsilon4(a7qgni,gn,k1,k3,ea7qgnignk1k3) call epsilon4(a7qgni,gn,k1,k4,ea7qgnignk1k4) call epsilon4(a7qgni,gn,k2,k3,ea7qgnignk2k3) call epsilon4(a7qgni,gn,k2,k4,ea7qgnignk2k4) call epsilon4(a7qgni,gn,k3,k4,ea7qgnignk3k4) call epsilon4(a7qgni,gz,k2,k4,ea7qgnigzk2k4) call epsilon4(a7qgni,k1,k2,k3,ea7qgnik1k2k3) call epsilon4(a7qgni,k1,k3,k4,ea7qgnik1k3k4) call epsilon4(a7qgzi,gz,k1,k2,ea7qgzigzk1k2) call epsilon4(a7qgzi,gz,k1,k3,ea7qgzigzk1k3) call epsilon4(a7qgzi,gz,k1,k4,ea7qgzigzk1k4) call epsilon4(a7qgzi,gz,k2,k3,ea7qgzigzk2k3) call epsilon4(a7qgzi,gz,k2,k4,ea7qgzigzk2k4) call epsilon4(a7qgzi,gz,k3,k4,ea7qgzigzk3k4) call epsilon4(a7qgzi,k1,k2,k3,ea7qgzik1k2k3) call epsilon4(a7qgzi,k1,k3,k4,ea7qgzik1k3k4) call epsilon4(a7qk1i,gn,k2,k4,ea7qk1ignk2k4) call epsilon4(a7qk1i,gz,k2,k4,ea7qk1igzk2k4) call epsilon4(a7qk2i,gn,k1,k4,ea7qk2ignk1k4) call epsilon4(a7qk2i,gn,k3,k4,ea7qk2ignk3k4) call epsilon4(a7qk2i,gz,k1,k4,ea7qk2igzk1k4) call epsilon4(a7qk2i,gz,k3,k4,ea7qk2igzk3k4) call epsilon4(a7qk2i,k1,k3,k4,ea7qk2ik1k3k4) call epsilon4(a7qk3i,gn,k2,k4,ea7qk3ignk2k4) call epsilon4(a7qk3i,gz,k2,k4,ea7qk3igzk2k4) call epsilon4(a7qk4i,gn,k1,k2,ea7qk4ignk1k2) call epsilon4(a7qk4i,gn,k2,k3,ea7qk4ignk2k3) call epsilon4(a7qk4i,gz,k1,k2,ea7qk4igzk1k2) call epsilon4(a7qk4i,gz,k2,k3,ea7qk4igzk2k3) call epsilon4(a7qk4i,k1,k2,k3,ea7qk4ik1k2k3) call epsilon4(a7qk5i,gn,gz,k1,ea7qk5igngzk1) call epsilon4(a7qk5i,gn,gz,k2,ea7qk5igngzk2) call epsilon4(a7qk5i,gn,gz,k3,ea7qk5igngzk3) call epsilon4(a7qk5i,gn,gz,k4,ea7qk5igngzk4) call epsilon4(a7qk5i,gn,k1,k2,ea7qk5ignk1k2) call epsilon4(a7qk5i,gn,k1,k3,ea7qk5ignk1k3) call epsilon4(a7qk5i,gn,k1,k4,ea7qk5ignk1k4) call epsilon4(a7qk5i,gn,k2,k3,ea7qk5ignk2k3) call epsilon4(a7qk5i,gn,k2,k4,ea7qk5ignk2k4) call epsilon4(a7qk5i,gn,k3,k4,ea7qk5ignk3k4) call epsilon4(a7qk5i,gz,k1,k2,ea7qk5igzk1k2) call epsilon4(a7qk5i,gz,k1,k4,ea7qk5igzk1k4) call epsilon4(a7qk5i,gz,k2,k3,ea7qk5igzk2k3) call epsilon4(a7qk5i,gz,k2,k4,ea7qk5igzk2k4) call epsilon4(a7qk5i,gz,k3,k4,ea7qk5igzk3k4) call epsilon4(a7qk5i,k1,k2,k3,ea7qk5ik1k2k3) call epsilon4(a7qk5i,k1,k3,k4,ea7qk5ik1k3k4) x(1) = k11*(-(kz3**2*v7qwk5k2) + e3*(ea7qk5ignk2k4 & + k2k4*v7qwk5gn - e4*v7qwk5k2 - e2*v7qwk5k4) + kz3 & *(-ea7qk5igzk2k4 - k2k4*v7qwk5gz - kz1*v7qwk5k4)) x(2) = kz1*(-ea7qk5igzk2k4 - k2k4*v7qwk5gz - kz3*v7qwk5k2) & - kz1**2*v7qwk5k4 + e1*(ea7qk5ignk2k4 + k2k4*v7qwk5gn & - e4*v7qwk5k2 - e2*v7qwk5k4) x(3) = x(1) + k33*x(2) x(4) = -(ea7qk5ignk3k4*k1k2) + ea7qk5ignk2k4*k1k3 & + ea7qk5ignk2k3*k1k4 + ea7qk5ignk1k4*k2k3 - ea7qk5ignk1k3*k2k4 & + ea7qk5ignk1k2*k3k4 + k33*(-(e1*ea7qgnignk2k4) & - e1*k2k4*v7qwgngn) x(5) = k1k4*k2k3 + k1k3*k2k4 - k1k2*k3k4 x(6) = x(4) + v7qwk5gn*x(5) x(7) = ea7qk5ik1k3k4 + e1*k33*v7qwgnk4 + k3k4*v7qwk5k1 & - k1k4*v7qwk5k3 - k1k3*v7qwk5k4 x(8) = x(6) + e2*x(7) x(9) = -ea7qk5ik1k2k3 + e1*k33*v7qwgnk2 - k2k3*v7qwk5k1 & - k1k3*v7qwk5k2 + k1k2*v7qwk5k3 x(10) = x(8) + e4*x(9) x(11) = k11*(-ea7qgnignk2k4 - k2k4*v7qwgngn + e4*v7qwgnk2 & + e2*v7qwgnk4) + e1*(-2*ea7qk5ignk2k4 - 2*k2k4*v7qwk5gn & + 2*e4*v7qwk5k2 + 2*e2*v7qwk5k4) x(12) = x(10) + e3*x(11) x(13) = -(e4*ea7qk5igzk2k3) + e3*ea7qk5igzk2k4 + e2*ea7qk5igzk3k4 & + ea7qk5igngzk4*k2k3 - ea7qk5igngzk3*k2k4 + ea7qk5igngzk2*k3k4 & + k33*(ea7qgnigzk2k4 + k2k4*v7qwgngz) x(14) = -(e4*k2k3) + e3*k2k4 + e2*k3k4 x(15) = x(13) + v7qwk5gz*x(14) x(16) = ea7qk5ignk3k4 + k33*v7qwgnk4 + k3k4*v7qwk5gn & - e4*v7qwk5k3 + e3*v7qwk5k4 x(17) = x(12) + kz1*x(15) + kz1**2*x(16) x(18) = -(e4*ea7qk5igzk1k2) - e2*ea7qk5igzk1k4 + e1*ea7qk5igzk2k4 & + ea7qgnigzk2k4*k11 - ea7qk5igngzk4*k1k2 - ea7qk5igngzk2*k1k4 & + k2k4*(ea7qk5igngzk1 + k11*v7qwgngz) x(19) = e4*k1k2 - e2*k1k4 + e1*k2k4 x(20) = x(18) + v7qwk5gz*x(19) x(21) = -ea7qk5ignk1k4 - ea7qk5ignk2k3 + k33*v7qwgnk2 & + k11*v7qwgnk4 + e4*v7qwk5k1 + e3*v7qwk5k2 + e2*v7qwk5k3 & + e1*v7qwk5k4 x(22) = -k1k4 - k2k3 x(23) = x(21) + v7qwk5gn*x(22) x(24) = x(20) + kz1*x(23) x(25) = -ea7qk5ignk1k2 + k11*v7qwgnk2 + k1k2*v7qwk5gn & - e2*v7qwk5k1 + e1*v7qwk5k2 x(26) = x(17) + kz3*x(24) + kz3**2*x(25) x(27) = x(3) + e5*x(26) x(28) = e4*ea7qgnik1k2k3 - e2*ea7qgnik1k3k4 + 2*ea7qk2ik1k3k4 & - 2*ea7qk4ik1k2k3 + (ea7qgnignk1k3 - ea7qgzigzk1k3 & + 2*ea7qk1k3)*k2k4 x(29) = ea7qgnignk3k4 - ea7qgzigzk3k4 + 2*ea7qk3k4 - e4*v7qwgnk3 & + 2*v7qwk4k3 x(30) = x(28) + k1k2*x(29) x(31) = -ea7qgnignk2k3 + ea7qgzigzk2k3 - 2*ea7qk2k3 + e2*v7qwgnk3 & - 2*v7qwk2k3 x(32) = x(30) + k1k4*x(31) x(33) = ea7qgnignk2k4 - ea7qgzigzk2k4 - e4*v7qwgnk2 - e2*v7qwgnk4 & + k2k4*(v7qwgngn - v7qwgzgz) x(34) = x(32) + k1k3*x(33) x(35) = -ea7qgnignk1k4 + ea7qgzigzk1k4 - 2*ea7qk1k4 + e4*v7qwgnk1 & + k1k4*(2*tracev7q - v7qwgngn + v7qwgzgz) - 2*v7qwk4k1 x(36) = x(34) + k2k3*x(35) x(37) = -ea7qgnignk1k2 + ea7qgzigzk1k2 - 2*ea7qk1k2 - e2*v7qwgnk1 & + k1k2*(-2*tracev7q + v7qwgngn - v7qwgzgz) + 2*v7qwk2k1 x(38) = x(36) + k3k4*x(37) x(39) = -ea7qk2ignk3k4 - ea7qk3ignk2k4 + ea7qk4ignk2k3 + k3k4 & *(ea7qgnk2 - v7qwk2gn) + k2k4*(-ea7qgnk3 - v7qwk3gn) + k2k3 & *(ea7qgnk4 + v7qwk4gn) x(40) = -ea7qk3k4 + k3k4*tracev7q + v7qwk3k4 - v7qwk4k3 x(41) = x(39) + e2*x(40) x(42) = ea7qk2k3 - k2k3*tracev7q + v7qwk2k3 + v7qwk3k2 x(43) = x(41) + e4*x(42) x(44) = x(38) + e1*x(43) x(45) = -ea7qk1ignk2k4 + ea7qk2ignk1k4 + ea7qk4ignk1k2 + k2k4 & *(ea7qgnk1 - v7qwk1gn) + k1k4*(-ea7qgnk2 + v7qwk2gn) + k1k2 & *(-ea7qgnk4 - v7qwk4gn) x(46) = ea7qk1k4 - k1k4*tracev7q + v7qwk1k4 + v7qwk4k1 x(47) = x(45) + e2*x(46) x(48) = ea7qk1k2 + k1k2*tracev7q + v7qwk1k2 - v7qwk2k1 x(49) = x(47) + e4*x(48) x(50) = x(44) + e3*x(49) x(51) = -ea7qgzik1k3k4 + ea7qk2igzk3k4 + ea7qk3igzk2k4 & - ea7qk4igzk2k3 + k1k4*v7qwgzk3 - k1k3*v7qwgzk4 + k2k3*(-ea7qgzk4 & - v7qwk4gz) x(52) = ea7qgzk3 + v7qwk3gz x(53) = x(51) + k2k4*x(52) x(54) = -ea7qgzk2 - v7qwgzk1 + v7qwk2gz x(55) = x(53) + k3k4*x(54) x(56) = -ea7qk3k4 + k3k4*tracev7q + v7qwk3k4 - v7qwk4k3 x(57) = x(50) + kz1*x(55) + kz1**2*x(56) x(58) = ea7qgzik1k2k3 + ea7qk1igzk2k4 - ea7qk2igzk1k4 & - ea7qk4igzk1k2 + k2k3*v7qwgzk1 - k1k3*v7qwgzk2 + k1k4*(ea7qgzk2 & - v7qwk2gz) x(59) = -ea7qgzk1 + v7qwk1gz x(60) = x(58) + k2k4*x(59) x(61) = ea7qgzk4 - v7qwgzk3 + v7qwk4gz x(62) = x(60) + k1k2*x(61) x(63) = ea7qk1k4 + ea7qk2k3 + (-k1k4 - k2k3)*tracev7q + v7qwk1k4 & + v7qwk2k3 + v7qwk3k2 + v7qwk4k1 x(64) = x(62) + kz1*x(63) x(65) = ea7qk1k2 + k1k2*tracev7q + v7qwk1k2 - v7qwk2k1 x(66) = x(57) + kz3*x(64) + kz3**2*x(65) x(67) = x(27) + tk55*x(66) feynman = (12*cf*nc*x(67))/tk55 feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 3) THEN ! types = {qbar,quark,quark,qbar,gluon,quark,gluon,gluon} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF DO mu = 0,3 k3pt(1,mu) = k8(mu) k3pt(2,mu) = -k7(mu) k3pt(3,mu) = k6(mu) END DO cut3pt(1) = cut(8) cut3pt(2) = cut(7) cut3pt(3) = cut(6) kind3pt = 'qqg/ggq' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v8g,a8g) tracev8g = 0.0d0 DO mu = 0,3 tracev8g = tracev8g + v8g(mu,mu)*metric(mu) END DO v8gwgngn = 0.0d0 v8gwgngz = 0.0d0 v8gwgnk1 = 0.0d0 v8gwgnk2 = 0.0d0 v8gwgnk3 = 0.0d0 v8gwgnk4 = 0.0d0 v8gwgzgz = 0.0d0 v8gwgzk1 = 0.0d0 v8gwgzk2 = 0.0d0 v8gwgzk3 = 0.0d0 v8gwgzk4 = 0.0d0 v8gwk1gn = 0.0d0 v8gwk1gz = 0.0d0 v8gwk1k2 = 0.0d0 v8gwk1k4 = 0.0d0 v8gwk2gn = 0.0d0 v8gwk2gz = 0.0d0 v8gwk2k1 = 0.0d0 v8gwk2k3 = 0.0d0 v8gwk3gn = 0.0d0 v8gwk3gz = 0.0d0 v8gwk3k2 = 0.0d0 v8gwk3k4 = 0.0d0 v8gwk4gn = 0.0d0 v8gwk4gz = 0.0d0 v8gwk4k1 = 0.0d0 v8gwk4k3 = 0.0d0 v8gwk5gn = 0.0d0 v8gwk5gz = 0.0d0 v8gwk5k1 = 0.0d0 v8gwk5k2 = 0.0d0 v8gwk5k3 = 0.0d0 v8gwk5k4 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v8gwgngn = v8gwgngn & + v8g(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) v8gwgngz = v8gwgngz & + v8g(mu,nu)*gn(mu)*gz(nu)*metric(mu)*metric(nu) v8gwgnk1 = v8gwgnk1 & + v8g(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) v8gwgnk2 = v8gwgnk2 & + v8g(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu) v8gwgnk3 = v8gwgnk3 & + v8g(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) v8gwgnk4 = v8gwgnk4 & + v8g(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu) v8gwgzgz = v8gwgzgz & + v8g(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) v8gwgzk1 = v8gwgzk1 & + v8g(mu,nu)*gz(mu)*k1(nu)*metric(mu)*metric(nu) v8gwgzk2 = v8gwgzk2 & + v8g(mu,nu)*gz(mu)*k2(nu)*metric(mu)*metric(nu) v8gwgzk3 = v8gwgzk3 & + v8g(mu,nu)*gz(mu)*k3(nu)*metric(mu)*metric(nu) v8gwgzk4 = v8gwgzk4 & + v8g(mu,nu)*gz(mu)*k4(nu)*metric(mu)*metric(nu) v8gwk1gn = v8gwk1gn & + v8g(mu,nu)*k1(mu)*gn(nu)*metric(mu)*metric(nu) v8gwk1gz = v8gwk1gz & + v8g(mu,nu)*k1(mu)*gz(nu)*metric(mu)*metric(nu) v8gwk1k2 = v8gwk1k2 & + v8g(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) v8gwk1k4 = v8gwk1k4 & + v8g(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu) v8gwk2gn = v8gwk2gn & + v8g(mu,nu)*k2(mu)*gn(nu)*metric(mu)*metric(nu) v8gwk2gz = v8gwk2gz & + v8g(mu,nu)*k2(mu)*gz(nu)*metric(mu)*metric(nu) v8gwk2k1 = v8gwk2k1 & + v8g(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu) v8gwk2k3 = v8gwk2k3 & + v8g(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu) v8gwk3gn = v8gwk3gn & + v8g(mu,nu)*k3(mu)*gn(nu)*metric(mu)*metric(nu) v8gwk3gz = v8gwk3gz & + v8g(mu,nu)*k3(mu)*gz(nu)*metric(mu)*metric(nu) v8gwk3k2 = v8gwk3k2 & + v8g(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu) v8gwk3k4 = v8gwk3k4 & + v8g(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) v8gwk4gn = v8gwk4gn & + v8g(mu,nu)*k4(mu)*gn(nu)*metric(mu)*metric(nu) v8gwk4gz = v8gwk4gz & + v8g(mu,nu)*k4(mu)*gz(nu)*metric(mu)*metric(nu) v8gwk4k1 = v8gwk4k1 & + v8g(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu) v8gwk4k3 = v8gwk4k3 & + v8g(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu) v8gwk5gn = v8gwk5gn & + v8g(mu,nu)*k5(mu)*gn(nu)*metric(mu)*metric(nu) v8gwk5gz = v8gwk5gz & + v8g(mu,nu)*k5(mu)*gz(nu)*metric(mu)*metric(nu) v8gwk5k1 = v8gwk5k1 & + v8g(mu,nu)*k5(mu)*k1(nu)*metric(mu)*metric(nu) v8gwk5k2 = v8gwk5k2 & + v8g(mu,nu)*k5(mu)*k2(nu)*metric(mu)*metric(nu) v8gwk5k3 = v8gwk5k3 & + v8g(mu,nu)*k5(mu)*k3(nu)*metric(mu)*metric(nu) v8gwk5k4 = v8gwk5k4 & + v8g(mu,nu)*k5(mu)*k4(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a8ggni(mu) = 0.0d0 a8ggzi(mu) = 0.0d0 a8gk1i(mu) = 0.0d0 a8gk2i(mu) = 0.0d0 a8gk3i(mu) = 0.0d0 a8gk4i(mu) = 0.0d0 a8gk5i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a8ggni(mu) = a8ggni(mu) + a8g(nu,mu)*gn(nu)*metric(nu) a8ggzi(mu) = a8ggzi(mu) + a8g(nu,mu)*gz(nu)*metric(nu) a8gk1i(mu) = a8gk1i(mu) + a8g(nu,mu)*k1(nu)*metric(nu) a8gk2i(mu) = a8gk2i(mu) + a8g(nu,mu)*k2(nu)*metric(nu) a8gk3i(mu) = a8gk3i(mu) + a8g(nu,mu)*k3(nu)*metric(nu) a8gk4i(mu) = a8gk4i(mu) + a8g(nu,mu)*k4(nu)*metric(nu) a8gk5i(mu) = a8gk5i(mu) + a8g(nu,mu)*k5(nu)*metric(nu) END DO END DO k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO call epsilont2(a8g,gn,k1,ea8ggnk1) call epsilont2(a8g,gn,k2,ea8ggnk2) call epsilont2(a8g,gn,k3,ea8ggnk3) call epsilont2(a8g,gn,k4,ea8ggnk4) call epsilont2(a8g,gz,k1,ea8ggzk1) call epsilont2(a8g,gz,k2,ea8ggzk2) call epsilont2(a8g,gz,k3,ea8ggzk3) call epsilont2(a8g,gz,k4,ea8ggzk4) call epsilont2(a8g,k1,k2,ea8gk1k2) call epsilont2(a8g,k1,k3,ea8gk1k3) call epsilont2(a8g,k1,k4,ea8gk1k4) call epsilont2(a8g,k2,k3,ea8gk2k3) call epsilont2(a8g,k3,k4,ea8gk3k4) call epsilon4(a8ggni,gn,k1,k2,ea8ggnignk1k2) call epsilon4(a8ggni,gn,k1,k3,ea8ggnignk1k3) call epsilon4(a8ggni,gn,k1,k4,ea8ggnignk1k4) call epsilon4(a8ggni,gn,k2,k3,ea8ggnignk2k3) call epsilon4(a8ggni,gn,k2,k4,ea8ggnignk2k4) call epsilon4(a8ggni,gn,k3,k4,ea8ggnignk3k4) call epsilon4(a8ggni,gz,k2,k4,ea8ggnigzk2k4) call epsilon4(a8ggni,k1,k2,k3,ea8ggnik1k2k3) call epsilon4(a8ggni,k1,k3,k4,ea8ggnik1k3k4) call epsilon4(a8ggzi,gz,k1,k2,ea8ggzigzk1k2) call epsilon4(a8ggzi,gz,k1,k3,ea8ggzigzk1k3) call epsilon4(a8ggzi,gz,k1,k4,ea8ggzigzk1k4) call epsilon4(a8ggzi,gz,k2,k3,ea8ggzigzk2k3) call epsilon4(a8ggzi,gz,k2,k4,ea8ggzigzk2k4) call epsilon4(a8ggzi,gz,k3,k4,ea8ggzigzk3k4) call epsilon4(a8ggzi,k1,k2,k3,ea8ggzik1k2k3) call epsilon4(a8ggzi,k1,k3,k4,ea8ggzik1k3k4) call epsilon4(a8gk1i,gn,k2,k4,ea8gk1ignk2k4) call epsilon4(a8gk1i,gz,k2,k4,ea8gk1igzk2k4) call epsilon4(a8gk2i,gn,k1,k4,ea8gk2ignk1k4) call epsilon4(a8gk2i,gn,k3,k4,ea8gk2ignk3k4) call epsilon4(a8gk2i,gz,k1,k4,ea8gk2igzk1k4) call epsilon4(a8gk2i,gz,k3,k4,ea8gk2igzk3k4) call epsilon4(a8gk2i,k1,k3,k4,ea8gk2ik1k3k4) call epsilon4(a8gk3i,gn,k2,k4,ea8gk3ignk2k4) call epsilon4(a8gk3i,gz,k2,k4,ea8gk3igzk2k4) call epsilon4(a8gk4i,gn,k1,k2,ea8gk4ignk1k2) call epsilon4(a8gk4i,gn,k2,k3,ea8gk4ignk2k3) call epsilon4(a8gk4i,gz,k1,k2,ea8gk4igzk1k2) call epsilon4(a8gk4i,gz,k2,k3,ea8gk4igzk2k3) call epsilon4(a8gk4i,k1,k2,k3,ea8gk4ik1k2k3) call epsilon4(a8gk5i,gn,gz,k1,ea8gk5igngzk1) call epsilon4(a8gk5i,gn,gz,k2,ea8gk5igngzk2) call epsilon4(a8gk5i,gn,gz,k3,ea8gk5igngzk3) call epsilon4(a8gk5i,gn,gz,k4,ea8gk5igngzk4) call epsilon4(a8gk5i,gn,k1,k2,ea8gk5ignk1k2) call epsilon4(a8gk5i,gn,k1,k3,ea8gk5ignk1k3) call epsilon4(a8gk5i,gn,k1,k4,ea8gk5ignk1k4) call epsilon4(a8gk5i,gn,k2,k3,ea8gk5ignk2k3) call epsilon4(a8gk5i,gn,k2,k4,ea8gk5ignk2k4) call epsilon4(a8gk5i,gn,k3,k4,ea8gk5ignk3k4) call epsilon4(a8gk5i,gz,k1,k2,ea8gk5igzk1k2) call epsilon4(a8gk5i,gz,k1,k4,ea8gk5igzk1k4) call epsilon4(a8gk5i,gz,k2,k3,ea8gk5igzk2k3) call epsilon4(a8gk5i,gz,k2,k4,ea8gk5igzk2k4) call epsilon4(a8gk5i,gz,k3,k4,ea8gk5igzk3k4) call epsilon4(a8gk5i,k1,k2,k3,ea8gk5ik1k2k3) call epsilon4(a8gk5i,k1,k3,k4,ea8gk5ik1k3k4) x(1) = k11*(kz3**2*v8gwk5k2 + e3*(ea8gk5ignk2k4 - k2k4*v8gwk5gn & + e4*v8gwk5k2 + e2*v8gwk5k4) + kz3*(-ea8gk5igzk2k4 & + k2k4*v8gwk5gz + kz1*v8gwk5k4)) x(2) = kz1*(-ea8gk5igzk2k4 + k2k4*v8gwk5gz + kz3*v8gwk5k2) & + kz1**2*v8gwk5k4 + e1*(ea8gk5ignk2k4 - k2k4*v8gwk5gn & + e4*v8gwk5k2 + e2*v8gwk5k4) x(3) = x(1) + k33*x(2) x(4) = -(ea8gk5ignk3k4*k1k2) + ea8gk5ignk2k4*k1k3 & + ea8gk5ignk2k3*k1k4 + ea8gk5ignk1k4*k2k3 - ea8gk5ignk1k3*k2k4 & + ea8gk5ignk1k2*k3k4 + k33*(-(e1*ea8ggnignk2k4) & + e1*k2k4*v8gwgngn) x(5) = -(k1k4*k2k3) - k1k3*k2k4 + k1k2*k3k4 x(6) = x(4) + v8gwk5gn*x(5) x(7) = ea8gk5ik1k3k4 - e1*k33*v8gwgnk4 - k3k4*v8gwk5k1 & + k1k4*v8gwk5k3 + k1k3*v8gwk5k4 x(8) = x(6) + e2*x(7) x(9) = -ea8gk5ik1k2k3 - e1*k33*v8gwgnk2 + k2k3*v8gwk5k1 & + k1k3*v8gwk5k2 - k1k2*v8gwk5k3 x(10) = x(8) + e4*x(9) x(11) = k11*(-ea8ggnignk2k4 + k2k4*v8gwgngn - e4*v8gwgnk2 & - e2*v8gwgnk4) + e1*(-2*ea8gk5ignk2k4 + 2*k2k4*v8gwk5gn & - 2*e4*v8gwk5k2 - 2*e2*v8gwk5k4) x(12) = x(10) + e3*x(11) x(13) = -(e4*ea8gk5igzk2k3) + e3*ea8gk5igzk2k4 + e2*ea8gk5igzk3k4 & + ea8gk5igngzk4*k2k3 - ea8gk5igngzk3*k2k4 + ea8gk5igngzk2*k3k4 & + k33*(ea8ggnigzk2k4 - k2k4*v8gwgngz) x(14) = e4*k2k3 - e3*k2k4 - e2*k3k4 x(15) = x(13) + v8gwk5gz*x(14) x(16) = ea8gk5ignk3k4 - k33*v8gwgnk4 - k3k4*v8gwk5gn & + e4*v8gwk5k3 - e3*v8gwk5k4 x(17) = x(12) + kz1*x(15) + kz1**2*x(16) x(18) = -(e4*ea8gk5igzk1k2) - e2*ea8gk5igzk1k4 + e1*ea8gk5igzk2k4 & + ea8ggnigzk2k4*k11 - ea8gk5igngzk4*k1k2 - ea8gk5igngzk2*k1k4 & + k2k4*(ea8gk5igngzk1 - k11*v8gwgngz) x(19) = -(e4*k1k2) + e2*k1k4 - e1*k2k4 x(20) = x(18) + v8gwk5gz*x(19) x(21) = -ea8gk5ignk1k4 - ea8gk5ignk2k3 - k33*v8gwgnk2 & - k11*v8gwgnk4 - e4*v8gwk5k1 - e3*v8gwk5k2 - e2*v8gwk5k3 & - e1*v8gwk5k4 x(22) = k1k4 + k2k3 x(23) = x(21) + v8gwk5gn*x(22) x(24) = x(20) + kz1*x(23) x(25) = -ea8gk5ignk1k2 - k11*v8gwgnk2 - k1k2*v8gwk5gn & + e2*v8gwk5k1 - e1*v8gwk5k2 x(26) = x(17) + kz3*x(24) + kz3**2*x(25) x(27) = x(3) + e5*x(26) x(28) = e4*ea8ggnik1k2k3 - e2*ea8ggnik1k3k4 + 2*ea8gk2ik1k3k4 & - 2*ea8gk4ik1k2k3 + (ea8ggnignk1k3 - ea8ggzigzk1k3 & + 2*ea8gk1k3)*k2k4 x(29) = ea8ggnignk3k4 - ea8ggzigzk3k4 + 2*ea8gk3k4 + e4*v8gwgnk3 & - 2*v8gwk4k3 x(30) = x(28) + k1k2*x(29) x(31) = -ea8ggnignk2k3 + ea8ggzigzk2k3 - 2*ea8gk2k3 - e2*v8gwgnk3 & + 2*v8gwk2k3 x(32) = x(30) + k1k4*x(31) x(33) = ea8ggnignk2k4 - ea8ggzigzk2k4 + e4*v8gwgnk2 + e2*v8gwgnk4 & + k2k4*(-v8gwgngn + v8gwgzgz) x(34) = x(32) + k1k3*x(33) x(35) = -ea8ggnignk1k4 + ea8ggzigzk1k4 - 2*ea8gk1k4 - e4*v8gwgnk1 & + k1k4*(-2*tracev8g + v8gwgngn - v8gwgzgz) + 2*v8gwk4k1 x(36) = x(34) + k2k3*x(35) x(37) = -ea8ggnignk1k2 + ea8ggzigzk1k2 - 2*ea8gk1k2 + e2*v8gwgnk1 & + k1k2*(2*tracev8g - v8gwgngn + v8gwgzgz) - 2*v8gwk2k1 x(38) = x(36) + k3k4*x(37) x(39) = -ea8gk2ignk3k4 - ea8gk3ignk2k4 + ea8gk4ignk2k3 + k3k4 & *(ea8ggnk2 + v8gwk2gn) + k2k4*(-ea8ggnk3 + v8gwk3gn) + k2k3 & *(ea8ggnk4 - v8gwk4gn) x(40) = -ea8gk3k4 - k3k4*tracev8g - v8gwk3k4 + v8gwk4k3 x(41) = x(39) + e2*x(40) x(42) = ea8gk2k3 + k2k3*tracev8g - v8gwk2k3 - v8gwk3k2 x(43) = x(41) + e4*x(42) x(44) = x(38) + e1*x(43) x(45) = -ea8gk1ignk2k4 + ea8gk2ignk1k4 + ea8gk4ignk1k2 + k2k4 & *(ea8ggnk1 + v8gwk1gn) + k1k4*(-ea8ggnk2 - v8gwk2gn) + k1k2 & *(-ea8ggnk4 + v8gwk4gn) x(46) = ea8gk1k4 + k1k4*tracev8g - v8gwk1k4 - v8gwk4k1 x(47) = x(45) + e2*x(46) x(48) = ea8gk1k2 - k1k2*tracev8g - v8gwk1k2 + v8gwk2k1 x(49) = x(47) + e4*x(48) x(50) = x(44) + e3*x(49) x(51) = -ea8ggzik1k3k4 + ea8gk2igzk3k4 + ea8gk3igzk2k4 & - ea8gk4igzk2k3 - k1k4*v8gwgzk3 + k1k3*v8gwgzk4 + k2k3*(-ea8ggzk4 & + v8gwk4gz) x(52) = ea8ggzk3 - v8gwk3gz x(53) = x(51) + k2k4*x(52) x(54) = -ea8ggzk2 + v8gwgzk1 - v8gwk2gz x(55) = x(53) + k3k4*x(54) x(56) = -ea8gk3k4 - k3k4*tracev8g - v8gwk3k4 + v8gwk4k3 x(57) = x(50) + kz1*x(55) + kz1**2*x(56) x(58) = ea8ggzik1k2k3 + ea8gk1igzk2k4 - ea8gk2igzk1k4 & - ea8gk4igzk1k2 - k2k3*v8gwgzk1 + k1k3*v8gwgzk2 + k1k4*(ea8ggzk2 & + v8gwk2gz) x(59) = -ea8ggzk1 - v8gwk1gz x(60) = x(58) + k2k4*x(59) x(61) = ea8ggzk4 + v8gwgzk3 - v8gwk4gz x(62) = x(60) + k1k2*x(61) x(63) = ea8gk1k4 + ea8gk2k3 + (k1k4 + k2k3)*tracev8g - v8gwk1k4 & - v8gwk2k3 - v8gwk3k2 - v8gwk4k1 x(64) = x(62) + kz1*x(63) x(65) = ea8gk1k2 - k1k2*tracev8g - v8gwk1k2 + v8gwk2k1 x(66) = x(57) + kz3*x(64) + kz3**2*x(65) x(67) = x(27) + tk55*x(66) feynman = (-12*cf*nc*x(67))/tk55 feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 4) THEN ! types = {qbar,quark,quark,qbar,gluon,gluon,quark,qbar} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF DO mu = 0,3 k3pt(1,mu) = k8(mu) k3pt(2,mu) = -k7(mu) k3pt(3,mu) = k6(mu) END DO cut3pt(1) = cut(8) cut3pt(2) = cut(7) cut3pt(3) = cut(6) kind3pt = 'qqg/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v8q,a8q) tracev8q = 0.0d0 DO mu = 0,3 tracev8q = tracev8q + v8q(mu,mu)*metric(mu) END DO v8qwgngn = 0.0d0 v8qwgngz = 0.0d0 v8qwgnk1 = 0.0d0 v8qwgnk2 = 0.0d0 v8qwgnk3 = 0.0d0 v8qwgnk4 = 0.0d0 v8qwgzgz = 0.0d0 v8qwgzk1 = 0.0d0 v8qwgzk2 = 0.0d0 v8qwgzk3 = 0.0d0 v8qwgzk4 = 0.0d0 v8qwk1gn = 0.0d0 v8qwk1gz = 0.0d0 v8qwk1k2 = 0.0d0 v8qwk1k4 = 0.0d0 v8qwk2gn = 0.0d0 v8qwk2gz = 0.0d0 v8qwk2k1 = 0.0d0 v8qwk2k3 = 0.0d0 v8qwk3gn = 0.0d0 v8qwk3gz = 0.0d0 v8qwk3k2 = 0.0d0 v8qwk3k4 = 0.0d0 v8qwk4gn = 0.0d0 v8qwk4gz = 0.0d0 v8qwk4k1 = 0.0d0 v8qwk4k3 = 0.0d0 v8qwk5gn = 0.0d0 v8qwk5gz = 0.0d0 v8qwk5k1 = 0.0d0 v8qwk5k2 = 0.0d0 v8qwk5k3 = 0.0d0 v8qwk5k4 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v8qwgngn = v8qwgngn & + v8q(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) v8qwgngz = v8qwgngz & + v8q(mu,nu)*gn(mu)*gz(nu)*metric(mu)*metric(nu) v8qwgnk1 = v8qwgnk1 & + v8q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) v8qwgnk2 = v8qwgnk2 & + v8q(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu) v8qwgnk3 = v8qwgnk3 & + v8q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) v8qwgnk4 = v8qwgnk4 & + v8q(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu) v8qwgzgz = v8qwgzgz & + v8q(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) v8qwgzk1 = v8qwgzk1 & + v8q(mu,nu)*gz(mu)*k1(nu)*metric(mu)*metric(nu) v8qwgzk2 = v8qwgzk2 & + v8q(mu,nu)*gz(mu)*k2(nu)*metric(mu)*metric(nu) v8qwgzk3 = v8qwgzk3 & + v8q(mu,nu)*gz(mu)*k3(nu)*metric(mu)*metric(nu) v8qwgzk4 = v8qwgzk4 & + v8q(mu,nu)*gz(mu)*k4(nu)*metric(mu)*metric(nu) v8qwk1gn = v8qwk1gn & + v8q(mu,nu)*k1(mu)*gn(nu)*metric(mu)*metric(nu) v8qwk1gz = v8qwk1gz & + v8q(mu,nu)*k1(mu)*gz(nu)*metric(mu)*metric(nu) v8qwk1k2 = v8qwk1k2 & + v8q(mu,nu)*k1(mu)*k2(nu)*metric(mu)*metric(nu) v8qwk1k4 = v8qwk1k4 & + v8q(mu,nu)*k1(mu)*k4(nu)*metric(mu)*metric(nu) v8qwk2gn = v8qwk2gn & + v8q(mu,nu)*k2(mu)*gn(nu)*metric(mu)*metric(nu) v8qwk2gz = v8qwk2gz & + v8q(mu,nu)*k2(mu)*gz(nu)*metric(mu)*metric(nu) v8qwk2k1 = v8qwk2k1 & + v8q(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu) v8qwk2k3 = v8qwk2k3 & + v8q(mu,nu)*k2(mu)*k3(nu)*metric(mu)*metric(nu) v8qwk3gn = v8qwk3gn & + v8q(mu,nu)*k3(mu)*gn(nu)*metric(mu)*metric(nu) v8qwk3gz = v8qwk3gz & + v8q(mu,nu)*k3(mu)*gz(nu)*metric(mu)*metric(nu) v8qwk3k2 = v8qwk3k2 & + v8q(mu,nu)*k3(mu)*k2(nu)*metric(mu)*metric(nu) v8qwk3k4 = v8qwk3k4 & + v8q(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) v8qwk4gn = v8qwk4gn & + v8q(mu,nu)*k4(mu)*gn(nu)*metric(mu)*metric(nu) v8qwk4gz = v8qwk4gz & + v8q(mu,nu)*k4(mu)*gz(nu)*metric(mu)*metric(nu) v8qwk4k1 = v8qwk4k1 & + v8q(mu,nu)*k4(mu)*k1(nu)*metric(mu)*metric(nu) v8qwk4k3 = v8qwk4k3 & + v8q(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu) v8qwk5gn = v8qwk5gn & + v8q(mu,nu)*k5(mu)*gn(nu)*metric(mu)*metric(nu) v8qwk5gz = v8qwk5gz & + v8q(mu,nu)*k5(mu)*gz(nu)*metric(mu)*metric(nu) v8qwk5k1 = v8qwk5k1 & + v8q(mu,nu)*k5(mu)*k1(nu)*metric(mu)*metric(nu) v8qwk5k2 = v8qwk5k2 & + v8q(mu,nu)*k5(mu)*k2(nu)*metric(mu)*metric(nu) v8qwk5k3 = v8qwk5k3 & + v8q(mu,nu)*k5(mu)*k3(nu)*metric(mu)*metric(nu) v8qwk5k4 = v8qwk5k4 & + v8q(mu,nu)*k5(mu)*k4(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a8qgni(mu) = 0.0d0 a8qgzi(mu) = 0.0d0 a8qk1i(mu) = 0.0d0 a8qk2i(mu) = 0.0d0 a8qk3i(mu) = 0.0d0 a8qk4i(mu) = 0.0d0 a8qk5i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a8qgni(mu) = a8qgni(mu) + a8q(nu,mu)*gn(nu)*metric(nu) a8qgzi(mu) = a8qgzi(mu) + a8q(nu,mu)*gz(nu)*metric(nu) a8qk1i(mu) = a8qk1i(mu) + a8q(nu,mu)*k1(nu)*metric(nu) a8qk2i(mu) = a8qk2i(mu) + a8q(nu,mu)*k2(nu)*metric(nu) a8qk3i(mu) = a8qk3i(mu) + a8q(nu,mu)*k3(nu)*metric(nu) a8qk4i(mu) = a8qk4i(mu) + a8q(nu,mu)*k4(nu)*metric(nu) a8qk5i(mu) = a8qk5i(mu) + a8q(nu,mu)*k5(nu)*metric(nu) END DO END DO k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO call epsilont2(a8q,gn,k1,ea8qgnk1) call epsilont2(a8q,gn,k2,ea8qgnk2) call epsilont2(a8q,gn,k3,ea8qgnk3) call epsilont2(a8q,gn,k4,ea8qgnk4) call epsilont2(a8q,gz,k1,ea8qgzk1) call epsilont2(a8q,gz,k2,ea8qgzk2) call epsilont2(a8q,gz,k3,ea8qgzk3) call epsilont2(a8q,gz,k4,ea8qgzk4) call epsilont2(a8q,k1,k2,ea8qk1k2) call epsilont2(a8q,k1,k3,ea8qk1k3) call epsilont2(a8q,k1,k4,ea8qk1k4) call epsilont2(a8q,k2,k3,ea8qk2k3) call epsilont2(a8q,k3,k4,ea8qk3k4) call epsilon4(a8qgni,gn,k1,k2,ea8qgnignk1k2) call epsilon4(a8qgni,gn,k1,k3,ea8qgnignk1k3) call epsilon4(a8qgni,gn,k1,k4,ea8qgnignk1k4) call epsilon4(a8qgni,gn,k2,k3,ea8qgnignk2k3) call epsilon4(a8qgni,gn,k2,k4,ea8qgnignk2k4) call epsilon4(a8qgni,gn,k3,k4,ea8qgnignk3k4) call epsilon4(a8qgni,gz,k2,k4,ea8qgnigzk2k4) call epsilon4(a8qgni,k1,k2,k3,ea8qgnik1k2k3) call epsilon4(a8qgni,k1,k3,k4,ea8qgnik1k3k4) call epsilon4(a8qgzi,gz,k1,k2,ea8qgzigzk1k2) call epsilon4(a8qgzi,gz,k1,k3,ea8qgzigzk1k3) call epsilon4(a8qgzi,gz,k1,k4,ea8qgzigzk1k4) call epsilon4(a8qgzi,gz,k2,k3,ea8qgzigzk2k3) call epsilon4(a8qgzi,gz,k2,k4,ea8qgzigzk2k4) call epsilon4(a8qgzi,gz,k3,k4,ea8qgzigzk3k4) call epsilon4(a8qgzi,k1,k2,k3,ea8qgzik1k2k3) call epsilon4(a8qgzi,k1,k3,k4,ea8qgzik1k3k4) call epsilon4(a8qk1i,gn,k2,k4,ea8qk1ignk2k4) call epsilon4(a8qk1i,gz,k2,k4,ea8qk1igzk2k4) call epsilon4(a8qk2i,gn,k1,k4,ea8qk2ignk1k4) call epsilon4(a8qk2i,gn,k3,k4,ea8qk2ignk3k4) call epsilon4(a8qk2i,gz,k1,k4,ea8qk2igzk1k4) call epsilon4(a8qk2i,gz,k3,k4,ea8qk2igzk3k4) call epsilon4(a8qk2i,k1,k3,k4,ea8qk2ik1k3k4) call epsilon4(a8qk3i,gn,k2,k4,ea8qk3ignk2k4) call epsilon4(a8qk3i,gz,k2,k4,ea8qk3igzk2k4) call epsilon4(a8qk4i,gn,k1,k2,ea8qk4ignk1k2) call epsilon4(a8qk4i,gn,k2,k3,ea8qk4ignk2k3) call epsilon4(a8qk4i,gz,k1,k2,ea8qk4igzk1k2) call epsilon4(a8qk4i,gz,k2,k3,ea8qk4igzk2k3) call epsilon4(a8qk4i,k1,k2,k3,ea8qk4ik1k2k3) call epsilon4(a8qk5i,gn,gz,k1,ea8qk5igngzk1) call epsilon4(a8qk5i,gn,gz,k2,ea8qk5igngzk2) call epsilon4(a8qk5i,gn,gz,k3,ea8qk5igngzk3) call epsilon4(a8qk5i,gn,gz,k4,ea8qk5igngzk4) call epsilon4(a8qk5i,gn,k1,k2,ea8qk5ignk1k2) call epsilon4(a8qk5i,gn,k1,k3,ea8qk5ignk1k3) call epsilon4(a8qk5i,gn,k1,k4,ea8qk5ignk1k4) call epsilon4(a8qk5i,gn,k2,k3,ea8qk5ignk2k3) call epsilon4(a8qk5i,gn,k2,k4,ea8qk5ignk2k4) call epsilon4(a8qk5i,gn,k3,k4,ea8qk5ignk3k4) call epsilon4(a8qk5i,gz,k1,k2,ea8qk5igzk1k2) call epsilon4(a8qk5i,gz,k1,k4,ea8qk5igzk1k4) call epsilon4(a8qk5i,gz,k2,k3,ea8qk5igzk2k3) call epsilon4(a8qk5i,gz,k2,k4,ea8qk5igzk2k4) call epsilon4(a8qk5i,gz,k3,k4,ea8qk5igzk3k4) call epsilon4(a8qk5i,k1,k2,k3,ea8qk5ik1k2k3) call epsilon4(a8qk5i,k1,k3,k4,ea8qk5ik1k3k4) x(1) = k11*(kz3**2*v8qwk5k2 + e3*(ea8qk5ignk2k4 - k2k4*v8qwk5gn & + e4*v8qwk5k2 + e2*v8qwk5k4) + kz3*(-ea8qk5igzk2k4 & + k2k4*v8qwk5gz + kz1*v8qwk5k4)) x(2) = kz1*(-ea8qk5igzk2k4 + k2k4*v8qwk5gz + kz3*v8qwk5k2) & + kz1**2*v8qwk5k4 + e1*(ea8qk5ignk2k4 - k2k4*v8qwk5gn & + e4*v8qwk5k2 + e2*v8qwk5k4) x(3) = x(1) + k33*x(2) x(4) = -(ea8qk5ignk3k4*k1k2) + ea8qk5ignk2k4*k1k3 & + ea8qk5ignk2k3*k1k4 + ea8qk5ignk1k4*k2k3 - ea8qk5ignk1k3*k2k4 & + ea8qk5ignk1k2*k3k4 + k33*(-(e1*ea8qgnignk2k4) & + e1*k2k4*v8qwgngn) x(5) = -(k1k4*k2k3) - k1k3*k2k4 + k1k2*k3k4 x(6) = x(4) + v8qwk5gn*x(5) x(7) = ea8qk5ik1k3k4 - e1*k33*v8qwgnk4 - k3k4*v8qwk5k1 & + k1k4*v8qwk5k3 + k1k3*v8qwk5k4 x(8) = x(6) + e2*x(7) x(9) = -ea8qk5ik1k2k3 - e1*k33*v8qwgnk2 + k2k3*v8qwk5k1 & + k1k3*v8qwk5k2 - k1k2*v8qwk5k3 x(10) = x(8) + e4*x(9) x(11) = k11*(-ea8qgnignk2k4 + k2k4*v8qwgngn - e4*v8qwgnk2 & - e2*v8qwgnk4) + e1*(-2*ea8qk5ignk2k4 + 2*k2k4*v8qwk5gn & - 2*e4*v8qwk5k2 - 2*e2*v8qwk5k4) x(12) = x(10) + e3*x(11) x(13) = -(e4*ea8qk5igzk2k3) + e3*ea8qk5igzk2k4 + e2*ea8qk5igzk3k4 & + ea8qk5igngzk4*k2k3 - ea8qk5igngzk3*k2k4 + ea8qk5igngzk2*k3k4 & + k33*(ea8qgnigzk2k4 - k2k4*v8qwgngz) x(14) = e4*k2k3 - e3*k2k4 - e2*k3k4 x(15) = x(13) + v8qwk5gz*x(14) x(16) = ea8qk5ignk3k4 - k33*v8qwgnk4 - k3k4*v8qwk5gn & + e4*v8qwk5k3 - e3*v8qwk5k4 x(17) = x(12) + kz1*x(15) + kz1**2*x(16) x(18) = -(e4*ea8qk5igzk1k2) - e2*ea8qk5igzk1k4 + e1*ea8qk5igzk2k4 & + ea8qgnigzk2k4*k11 - ea8qk5igngzk4*k1k2 - ea8qk5igngzk2*k1k4 & + k2k4*(ea8qk5igngzk1 - k11*v8qwgngz) x(19) = -(e4*k1k2) + e2*k1k4 - e1*k2k4 x(20) = x(18) + v8qwk5gz*x(19) x(21) = -ea8qk5ignk1k4 - ea8qk5ignk2k3 - k33*v8qwgnk2 & - k11*v8qwgnk4 - e4*v8qwk5k1 - e3*v8qwk5k2 - e2*v8qwk5k3 & - e1*v8qwk5k4 x(22) = k1k4 + k2k3 x(23) = x(21) + v8qwk5gn*x(22) x(24) = x(20) + kz1*x(23) x(25) = -ea8qk5ignk1k2 - k11*v8qwgnk2 - k1k2*v8qwk5gn & + e2*v8qwk5k1 - e1*v8qwk5k2 x(26) = x(17) + kz3*x(24) + kz3**2*x(25) x(27) = x(3) + e5*x(26) x(28) = e4*ea8qgnik1k2k3 - e2*ea8qgnik1k3k4 + 2*ea8qk2ik1k3k4 & - 2*ea8qk4ik1k2k3 + (ea8qgnignk1k3 - ea8qgzigzk1k3 & + 2*ea8qk1k3)*k2k4 x(29) = ea8qgnignk3k4 - ea8qgzigzk3k4 + 2*ea8qk3k4 + e4*v8qwgnk3 & - 2*v8qwk4k3 x(30) = x(28) + k1k2*x(29) x(31) = -ea8qgnignk2k3 + ea8qgzigzk2k3 - 2*ea8qk2k3 - e2*v8qwgnk3 & + 2*v8qwk2k3 x(32) = x(30) + k1k4*x(31) x(33) = ea8qgnignk2k4 - ea8qgzigzk2k4 + e4*v8qwgnk2 + e2*v8qwgnk4 & + k2k4*(-v8qwgngn + v8qwgzgz) x(34) = x(32) + k1k3*x(33) x(35) = -ea8qgnignk1k4 + ea8qgzigzk1k4 - 2*ea8qk1k4 - e4*v8qwgnk1 & + k1k4*(-2*tracev8q + v8qwgngn - v8qwgzgz) + 2*v8qwk4k1 x(36) = x(34) + k2k3*x(35) x(37) = -ea8qgnignk1k2 + ea8qgzigzk1k2 - 2*ea8qk1k2 + e2*v8qwgnk1 & + k1k2*(2*tracev8q - v8qwgngn + v8qwgzgz) - 2*v8qwk2k1 x(38) = x(36) + k3k4*x(37) x(39) = -ea8qk2ignk3k4 - ea8qk3ignk2k4 + ea8qk4ignk2k3 + k3k4 & *(ea8qgnk2 + v8qwk2gn) + k2k4*(-ea8qgnk3 + v8qwk3gn) + k2k3 & *(ea8qgnk4 - v8qwk4gn) x(40) = -ea8qk3k4 - k3k4*tracev8q - v8qwk3k4 + v8qwk4k3 x(41) = x(39) + e2*x(40) x(42) = ea8qk2k3 + k2k3*tracev8q - v8qwk2k3 - v8qwk3k2 x(43) = x(41) + e4*x(42) x(44) = x(38) + e1*x(43) x(45) = -ea8qk1ignk2k4 + ea8qk2ignk1k4 + ea8qk4ignk1k2 + k2k4 & *(ea8qgnk1 + v8qwk1gn) + k1k4*(-ea8qgnk2 - v8qwk2gn) + k1k2 & *(-ea8qgnk4 + v8qwk4gn) x(46) = ea8qk1k4 + k1k4*tracev8q - v8qwk1k4 - v8qwk4k1 x(47) = x(45) + e2*x(46) x(48) = ea8qk1k2 - k1k2*tracev8q - v8qwk1k2 + v8qwk2k1 x(49) = x(47) + e4*x(48) x(50) = x(44) + e3*x(49) x(51) = -ea8qgzik1k3k4 + ea8qk2igzk3k4 + ea8qk3igzk2k4 & - ea8qk4igzk2k3 - k1k4*v8qwgzk3 + k1k3*v8qwgzk4 + k2k3*(-ea8qgzk4 & + v8qwk4gz) x(52) = ea8qgzk3 - v8qwk3gz x(53) = x(51) + k2k4*x(52) x(54) = -ea8qgzk2 + v8qwgzk1 - v8qwk2gz x(55) = x(53) + k3k4*x(54) x(56) = -ea8qk3k4 - k3k4*tracev8q - v8qwk3k4 + v8qwk4k3 x(57) = x(50) + kz1*x(55) + kz1**2*x(56) x(58) = ea8qgzik1k2k3 + ea8qk1igzk2k4 - ea8qk2igzk1k4 & - ea8qk4igzk1k2 - k2k3*v8qwgzk1 + k1k3*v8qwgzk2 + k1k4*(ea8qgzk2 & + v8qwk2gz) x(59) = -ea8qgzk1 - v8qwk1gz x(60) = x(58) + k2k4*x(59) x(61) = ea8qgzk4 + v8qwgzk3 - v8qwk4gz x(62) = x(60) + k1k2*x(61) x(63) = ea8qk1k4 + ea8qk2k3 + (k1k4 + k2k3)*tracev8q - v8qwk1k4 & - v8qwk2k3 - v8qwk3k2 - v8qwk4k1 x(64) = x(62) + kz1*x(63) x(65) = ea8qk1k2 - k1k2*tracev8q - v8qwk1k2 + v8qwk2k1 x(66) = x(57) + kz3*x(64) + kz3**2*x(65) x(67) = x(27) + tk55*x(66) feynman = (-12*cf*nc*x(67))/tk55 feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 8) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,quark,qbar,quark,gluon,gluon,quark} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 tk66 = tk66 - k6(mu)**2 tk77 = tk77 - k7(mu)**2 tk88 = tk88 - k8(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 k66 = e6**2 + tk66 k77 = e7**2 + tk77 k88 = e8**2 + tk88 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF IF (cut(6)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk66) ELSE prefactor = prefactor/k66 END IF IF (cut(7)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk77) ELSE prefactor = prefactor/k77 END IF IF (cut(8)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk88) ELSE prefactor = prefactor/k88 END IF feynman = 0 feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {quark,qbar,qbar,quark,quark,gluon,gluon,qbar} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 tk66 = tk66 - k6(mu)**2 tk77 = tk77 - k7(mu)**2 tk88 = tk88 - k8(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 k66 = e6**2 + tk66 k77 = e7**2 + tk77 k88 = e8**2 + tk88 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF IF (cut(6)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk66) ELSE prefactor = prefactor/k66 END IF IF (cut(7)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk77) ELSE prefactor = prefactor/k77 END IF IF (cut(8)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk88) ELSE prefactor = prefactor/k88 END IF feynman = 0 feynman = feynman*prefactor ! ELSE IF (flavorsetnumber .EQ. 3) THEN ! types = {quark,qbar,qbar,quark,gluon,quark,qbar,gluon} ! prefactor = 1.0d0 tk66 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk66 = tk66 - k6(mu)**2 tk77 = tk77 - k7(mu)**2 END DO k66 = e6**2 + tk66 k77 = e7**2 + tk77 IF (cut(6)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk66) ELSE prefactor = prefactor/k66 END IF IF (cut(7)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk77) ELSE prefactor = prefactor/k77 END IF DO mu = 0,3 k3pt(1,mu) = -k1(mu) k3pt(2,mu) = k2(mu) k3pt(3,mu) = -k5(mu) END DO cut3pt(1) = cut(1) cut3pt(2) = cut(2) cut3pt(3) = cut(5) kind3pt = 'qqp/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v1q,a1q) DO mu = 0,3 k3pt(1,mu) = -k4(mu) k3pt(2,mu) = k3(mu) k3pt(3,mu) = k8(mu) END DO cut3pt(1) = cut(4) cut3pt(2) = cut(3) cut3pt(3) = cut(8) kind3pt = 'qqp/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q) a1qda4q = 0.0d0 v1qdv4q = 0.0d0 DO mu = 0,3 DO nu = 0,3 a1qda4q = a1qda4q + a1q(mu,nu)*a4q(mu,nu)*metric(mu)*metric(nu) v1qdv4q = v1qdv4q + v1q(mu,nu)*v4q(mu,nu)*metric(mu)*metric(nu) END DO END DO a1qwgnk6 = 0.0d0 a1qwgnk7 = 0.0d0 a1qwgzk6 = 0.0d0 a1qwgzk7 = 0.0d0 a4qwgnk6 = 0.0d0 a4qwgnk7 = 0.0d0 a4qwgzk6 = 0.0d0 a4qwgzk7 = 0.0d0 v1qwgnk6 = 0.0d0 v1qwgnk7 = 0.0d0 v1qwgzk6 = 0.0d0 v1qwgzk7 = 0.0d0 v4qwgnk6 = 0.0d0 v4qwgnk7 = 0.0d0 v4qwgzk6 = 0.0d0 v4qwgzk7 = 0.0d0 DO mu = 0,3 DO nu = 0,3 a1qwgnk6 = a1qwgnk6 & + a1q(mu,nu)*gn(mu)*k6(nu)*metric(mu)*metric(nu) a1qwgnk7 = a1qwgnk7 & + a1q(mu,nu)*gn(mu)*k7(nu)*metric(mu)*metric(nu) a1qwgzk6 = a1qwgzk6 & + a1q(mu,nu)*gz(mu)*k6(nu)*metric(mu)*metric(nu) a1qwgzk7 = a1qwgzk7 & + a1q(mu,nu)*gz(mu)*k7(nu)*metric(mu)*metric(nu) a4qwgnk6 = a4qwgnk6 & + a4q(mu,nu)*gn(mu)*k6(nu)*metric(mu)*metric(nu) a4qwgnk7 = a4qwgnk7 & + a4q(mu,nu)*gn(mu)*k7(nu)*metric(mu)*metric(nu) a4qwgzk6 = a4qwgzk6 & + a4q(mu,nu)*gz(mu)*k6(nu)*metric(mu)*metric(nu) a4qwgzk7 = a4qwgzk7 & + a4q(mu,nu)*gz(mu)*k7(nu)*metric(mu)*metric(nu) v1qwgnk6 = v1qwgnk6 & + v1q(mu,nu)*gn(mu)*k6(nu)*metric(mu)*metric(nu) v1qwgnk7 = v1qwgnk7 & + v1q(mu,nu)*gn(mu)*k7(nu)*metric(mu)*metric(nu) v1qwgzk6 = v1qwgzk6 & + v1q(mu,nu)*gz(mu)*k6(nu)*metric(mu)*metric(nu) v1qwgzk7 = v1qwgzk7 & + v1q(mu,nu)*gz(mu)*k7(nu)*metric(mu)*metric(nu) v4qwgnk6 = v4qwgnk6 & + v4q(mu,nu)*gn(mu)*k6(nu)*metric(mu)*metric(nu) v4qwgnk7 = v4qwgnk7 & + v4q(mu,nu)*gn(mu)*k7(nu)*metric(mu)*metric(nu) v4qwgzk6 = v4qwgzk6 & + v4q(mu,nu)*gz(mu)*k6(nu)*metric(mu)*metric(nu) v4qwgzk7 = v4qwgzk7 & + v4q(mu,nu)*gz(mu)*k7(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a1qgni(mu) = 0.0d0 a1qgzi(mu) = 0.0d0 a1qik6(mu) = 0.0d0 a1qik7(mu) = 0.0d0 a4qgni(mu) = 0.0d0 a4qgzi(mu) = 0.0d0 a4qik6(mu) = 0.0d0 a4qik7(mu) = 0.0d0 v1qgni(mu) = 0.0d0 v1qgzi(mu) = 0.0d0 v1qik6(mu) = 0.0d0 v1qik7(mu) = 0.0d0 v4qgni(mu) = 0.0d0 v4qgzi(mu) = 0.0d0 v4qik6(mu) = 0.0d0 v4qik7(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a1qgni(mu) = a1qgni(mu) + a1q(nu,mu)*gn(nu)*metric(nu) a1qgzi(mu) = a1qgzi(mu) + a1q(nu,mu)*gz(nu)*metric(nu) a1qik6(mu) = a1qik6(mu) + a1q(mu,nu)*k6(nu)*metric(nu) a1qik7(mu) = a1qik7(mu) + a1q(mu,nu)*k7(nu)*metric(nu) a4qgni(mu) = a4qgni(mu) + a4q(nu,mu)*gn(nu)*metric(nu) a4qgzi(mu) = a4qgzi(mu) + a4q(nu,mu)*gz(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) v1qgni(mu) = v1qgni(mu) + v1q(nu,mu)*gn(nu)*metric(nu) v1qgzi(mu) = v1qgzi(mu) + v1q(nu,mu)*gz(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) v4qgni(mu) = v4qgni(mu) + v4q(nu,mu)*gn(nu)*metric(nu) v4qgzi(mu) = v4qgzi(mu) + v4q(nu,mu)*gz(nu)*metric(nu) v4qik6(mu) = v4qik6(mu) + v4q(mu,nu)*k6(nu)*metric(nu) v4qik7(mu) = v4qik7(mu) + v4q(mu,nu)*k7(nu)*metric(nu) END DO END DO DO mu = 0,3 DO nu = 0,3 a1qzv4q(mu,nu) = 0.0d0 a4qzv1q(mu,nu) = 0.0d0 END DO END DO DO mu = 0,3 DO nu = 0,3 DO tau = 0,3 a1qzv4q(mu,nu) = a1qzv4q(mu,nu) & + a1q(tau,mu)*v4q(tau,nu)*metric(tau) a4qzv1q(mu,nu) = a4qzv1q(mu,nu) & + a4q(tau,mu)*v1q(tau,nu)*metric(tau) END DO END DO END DO a1qgnia4qgni = 0.0d0 a1qgzia4qgzi = 0.0d0 a1qik6a4qik7 = 0.0d0 a1qik7a4qik6 = 0.0d0 k6k7 = 0.0d0 v1qgniv4qgni = 0.0d0 v1qgziv4qgzi = 0.0d0 v1qik6v4qik7 = 0.0d0 v1qik7v4qik6 = 0.0d0 DO mu = 0,3 a1qgnia4qgni = a1qgnia4qgni + a1qgni(mu)*a4qgni(mu)*metric(mu) a1qgzia4qgzi = a1qgzia4qgzi + a1qgzi(mu)*a4qgzi(mu)*metric(mu) a1qik6a4qik7 = a1qik6a4qik7 + a1qik6(mu)*a4qik7(mu)*metric(mu) a1qik7a4qik6 = a1qik7a4qik6 + a1qik7(mu)*a4qik6(mu)*metric(mu) k6k7 = k6k7 + k6(mu)*k7(mu)*metric(mu) v1qgniv4qgni = v1qgniv4qgni + v1qgni(mu)*v4qgni(mu)*metric(mu) v1qgziv4qgzi = v1qgziv4qgzi + v1qgzi(mu)*v4qgzi(mu)*metric(mu) v1qik6v4qik7 = v1qik6v4qik7 + v1qik6(mu)*v4qik7(mu)*metric(mu) v1qik7v4qik6 = v1qik7v4qik6 + v1qik7(mu)*v4qik6(mu)*metric(mu) END DO call epsilont2(a1qzv4q,k6,k7,ea1qzv4qk6k7) call epsilont2(a4qzv1q,k6,k7,ea4qzv1qk6k7) call epsilon4(a1qgni,k6,k7,v4qgni,ea1qgnik6k7v4qgni) call epsilon4(a1qgzi,k6,k7,v4qgzi,ea1qgzik6k7v4qgzi) call epsilon4(a4qgni,k6,k7,v1qgni,ea4qgnik6k7v1qgni) call epsilon4(a4qgzi,k6,k7,v1qgzi,ea4qgzik6k7v1qgzi) x(1) = a1qik6a4qik7 + a1qik7a4qik6 - a1qwgnk7*a4qwgnk6 & - a1qwgnk6*a4qwgnk7 + a1qwgzk7*a4qwgzk6 + a1qwgzk6*a4qwgzk7 & - ea1qgnik6k7v4qgni + ea1qgzik6k7v4qgzi + ea1qzv4qk6k7 x(2) = 1 x(3) = x(1) + ea4qgnik6k7v1qgni*x(2) x(4) = -1 x(5) = x(3) + ea4qgzik6k7v1qgzi*x(4) x(6) = -1 x(7) = x(5) + ea4qzv1qk6k7*x(6) x(8) = -1 x(9) = x(7) + v1qik6v4qik7*x(8) x(10) = -1 x(11) = x(9) + v1qik7v4qik6*x(10) x(12) = v1qwgnk7 x(13) = x(11) + v4qwgnk6*x(12) x(14) = v1qwgnk6 x(15) = x(13) + v4qwgnk7*x(14) x(16) = -v1qwgzk7 x(17) = x(15) + v4qwgzk6*x(16) x(18) = -v1qwgzk6 x(19) = x(17) + v4qwgzk7*x(18) x(20) = -a1qda4q + a1qgnia4qgni - a1qgzia4qgzi + v1qdv4q & - v1qgniv4qgni + v1qgziv4qgzi x(21) = x(19) + k6k7*x(20) feynman = 6*nc*x(21) feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 9) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,qbar,quark,gluon,quark,gluon,qbar} ! prefactor = 1.0d0 DO mu = 0,3 k2pt(0,mu) = k1(mu) k2pt(1,mu) = k5(mu) k2pt(2,mu) = k6(mu) END DO cut2pt(0) = cut(1) cut2pt(1) = cut(5) cut2pt(2) = cut(6) cut2pt(3) = cut(3) call twopointq(k2pt,cut2pt,mumsbar,flag,q15) DO mu = 0,3 k2pt(0,mu) = k4(mu) k2pt(1,mu) = -k7(mu) k2pt(2,mu) = -k8(mu) END DO cut2pt(0) = cut(4) cut2pt(1) = cut(7) cut2pt(2) = cut(8) cut2pt(3) = cut(2) call twopointq(k2pt,cut2pt,mumsbar,flag,q47) gnq15 = 0.0d0 gnq47 = 0.0d0 gzq15 = 0.0d0 gzq47 = 0.0d0 DO mu = 0,3 gnq15 = gnq15 + gn(mu)*q15(mu)*metric(mu) gnq47 = gnq47 + gn(mu)*q47(mu)*metric(mu) gzq15 = gzq15 + gz(mu)*q15(mu)*metric(mu) gzq47 = gzq47 + gz(mu)*q47(mu)*metric(mu) END DO feynman = -12*(gnq15*gnq47 - gzq15*gzq47)*nc feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 10) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,quark,qbar,gluon,quark,qbar,gluon} ! prefactor = 1.0d0 tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 tk66 = tk66 - k6(mu)**2 tk77 = tk77 - k7(mu)**2 tk88 = tk88 - k8(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 k66 = e6**2 + tk66 k77 = e7**2 + tk77 k88 = e8**2 + tk88 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk55) ELSE prefactor = prefactor/k55 END IF IF (cut(6)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk66) ELSE prefactor = prefactor/k66 END IF IF (cut(7)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk77) ELSE prefactor = prefactor/k77 END IF IF (cut(8)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk88) ELSE prefactor = prefactor/k88 END IF k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k1k6 = 0.0d0 k1k7 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k2k6 = 0.0d0 k2k7 = 0.0d0 k3k4 = 0.0d0 k3k6 = 0.0d0 k3k7 = 0.0d0 k4k6 = 0.0d0 k4k7 = 0.0d0 k6k7 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k1k6 = k1k6 + k1(mu)*k6(mu)*metric(mu) k1k7 = k1k7 + k1(mu)*k7(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k2k6 = k2k6 + k2(mu)*k6(mu)*metric(mu) k2k7 = k2k7 + k2(mu)*k7(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) k3k6 = k3k6 + k3(mu)*k6(mu)*metric(mu) k3k7 = k3k7 + k3(mu)*k7(mu)*metric(mu) k4k6 = k4k6 + k4(mu)*k6(mu)*metric(mu) k4k7 = k4k7 + k4(mu)*k7(mu)*metric(mu) k6k7 = k6k7 + k6(mu)*k7(mu)*metric(mu) END DO x(1) = 0 x(2) = 0 x(3) = 0 x(4) = -8*e3*e4*k1k2 + 8*e2*e3*k1k4 + (8*e1*e4 - 8*k1k4)*k2k3 & - 8*k1k3*k2k4 + k3k4*(-8*e1*e2 + 8*k1k2 - 8*kz1**2) x(5) = (8*k1k4 + 8*k2k3)*kz1 x(6) = -8*k1k2 x(7) = x(4) + kz3*x(5) + kz3**2*x(6) x(8) = x(3) + k6k7*x(7) x(9) = x(2) + tk88*x(8) x(10) = 0 x(11) = 2*e3*e7*k1k6 - 2*k1k3*k6k7 + k1k7*(-2*e3*e6 + 2*kz3*kz6) & - 2*k1k6*kz3*kz7 + k3k6*(-2*e1*e7 + 2*k1k7 + 2*kz1*kz7) x(12) = 2*e1*e6 - 2*k1k6 - 2*kz1*kz6 x(13) = x(11) + k3k7*x(12) x(14) = x(10) + k44*x(13) x(15) = 2*e3*e7*k1k4 - 2*e3*e4*k1k7 + (2*e1*e4 - 2*k1k4)*k3k7 & - 2*k1k3*k4k7 + k3k4*(-2*e1*e7 + 2*k1k7 + 2*kz1*kz7) x(16) = 2*k3k7*kz1 - 2*k1k4*kz7 x(17) = -2*k1k7 x(18) = x(15) + kz3*x(16) + kz3**2*x(17) x(19) = x(14) + k66*x(18) x(20) = x(9) + k22*x(19) x(21) = x(1) + tk55*x(20) x(22) = 0 x(23) = k11*k44*(-(e6*e7) + kz6*kz7) x(24) = e7*(-(e6*k1k4) + e4*(-k11 + k1k6) + e1*(k44 + k4k6)) x(25) = (-k44 - k4k6)*kz1 + (-k11 + k1k6)*kz3 + k1k4*kz6 x(26) = x(24) + kz7*x(25) x(27) = x(23) + k66*x(26) x(28) = x(22) + k22*x(27) x(29) = 0 x(30) = -2*e4*e7*k2k6 - 2*k2k4*k6k7 + k2k7*(2*e4*e6 + 2*kz3*kz6) & - 2*k2k6*kz3*kz7 + k4k6*(2*e2*e7 - 2*k2k7 + 2*kz1*kz7) x(31) = -2*e2*e6 + 2*k2k6 - 2*kz1*kz6 x(32) = x(30) + k4k7*x(31) x(33) = x(29) + k11*x(32) x(34) = -2*e2*e7*k1k4 + 2*k1k7*k2k4 + (-2*e1*e4 + 2*k1k4)*k2k7 & + 2*e1*e2*k4k7 + k1k2*(2*e4*e7 - 2*k4k7 + 2*kz3*kz7) x(35) = -2*k2k7*kz3 - 2*k1k4*kz7 x(36) = 2*k4k7 x(37) = x(34) + kz1*x(35) + kz1**2*x(36) x(38) = x(33) + k66*x(37) x(39) = x(28) + tk88*x(38) x(40) = x(21) + k33*x(39) x(41) = 0 x(42) = k44*(k33*(e7*(2*e1*e6 - k1k6) - e6*kz1*kz7 - e1*kz6*kz7) & + k11*(e6*k3k7 + e7*(-2*e3*e6 + kz3*kz6) + e3*kz6*kz7)) x(43) = -(e7*k1k4*k33) + (e3*(-k44 - k4k6)*kz1 + e3*k1k4*kz6)*kz7 & + e6*(-(k1k7*k3k4) + k1k4*(-2*e3*e7 + k3k7) + k1k3*k4k7 & - k3k4*kz1*kz7) x(44) = (2*e3*e7 - k3k7)*k44 + (2*e3*e7 - k3k7)*k4k6 - k3k6*k4k7 & + k3k4*(k6k7 + kz6*kz7) x(45) = x(43) + e1*x(44) x(46) = e7*(-2*e3*k11 + 2*e3*k1k6 + 2*e1*k33) + k1k7*k3k6 + (k11 & - k1k6)*k3k7 - k1k3*k6k7 x(47) = (-k33 + k3k6)*kz1 - k1k3*kz6 x(48) = x(46) + kz7*x(47) x(49) = x(45) + e4*x(48) x(50) = (e7*(-k44 - k4k6) + e6*k4k7 - e4*k6k7)*kz1 + (e7*k1k4 & + e4*k1k7 - e1*k4k7)*kz6 x(51) = -(e6*k1k3) + e3*(-k11 + k1k6) + e1*(k33 + k3k6) x(52) = x(50) + kz7*x(51) x(53) = e7*(-k11 + k1k6) + e6*k1k7 - e1*k6k7 x(54) = x(49) + kz3*x(52) + kz3**2*x(53) x(55) = x(42) + k66*x(54) x(56) = x(41) + k22*x(55) x(57) = 0 x(58) = e7*(2*k2k6*k3k4 - 2*k2k4*k3k6 - 2*k2k3*k4k6) + e6 & *(-2*k2k7*k3k4 + 2*k2k4*k3k7 + 2*k2k3*k4k7) x(59) = (-2*e7*k3k4 + 2*e4*k3k7)*kz6 + (2*e6*k3k4 - 2*e4*k3k6)*kz7 x(60) = x(58) + kz1*x(59) x(61) = -4*e4*e7*k2k6 + 4*e4*e6*k2k7 - 2*k2k4*k6k7 + k4k7 & *(-4*e2*e6 + 2*k2k6 - 2*kz1*kz6) + k4k6*(4*e2*e7 - 2*k2k7 & + 2*kz1*kz7) x(62) = x(60) + e3*x(61) x(63) = x(57) + k11*x(62) x(64) = e7*(2*k1k4*k2k3 + 2*k1k3*k2k4 - 2*k1k2*k3k4) + e1 & *(2*k2k7*k3k4 - 2*k2k4*k3k7 - 2*k2k3*k4k7) x(65) = (2*e4*k1k3 - 2*e1*k3k4)*kz7 x(66) = 2*e7*k3k4 - 2*e4*k3k7 x(67) = x(64) + kz1*x(65) + kz1**2*x(66) x(68) = 4*e4*e7*k1k2 + 2*k1k7*k2k4 - 4*e1*e4*k2k7 + k4k7*(4*e1*e2 & - 2*k1k2 + 2*kz1**2) + k1k4*(-4*e2*e7 + 2*k2k7 - 2*kz1*kz7) x(69) = x(67) + e3*x(68) x(70) = x(63) + k66*x(69) x(71) = e7*(-2*k1k6*k2k4 - 2*k1k4*k2k6 + 2*k1k2*k4k6) + e6 & *(2*k1k7*k2k4 + 2*k1k4*k2k7 - 2*k1k2*k4k7) x(72) = 4*e4*e7*k2k6 - 4*e4*e6*k2k7 + (-4*e2*e7 + 2*k2k7)*k4k6 & + (4*e2*e6 - 2*k2k6)*k4k7 + 2*k2k4*k6k7 x(73) = x(71) + e1*x(72) x(74) = (2*e7*k1k4 - 2*e4*k1k7 + 2*e1*k4k7)*kz6 + (-2*e6*k1k4 & + 2*e4*k1k6 - 2*e1*k4k6)*kz7 x(75) = -2*e7*k4k6 + 2*e6*k4k7 + 2*e4*k6k7 x(76) = x(73) + kz1*x(74) + kz1**2*x(75) x(77) = x(70) + k33*x(76) x(78) = ((-2*e7*k1k2 + 2*e2*k1k7 - 2*e1*k2k7)*k33 + k11 & *(2*e7*k2k3 + 2*e3*k2k7 - 2*e2*k3k7))*kz6 x(79) = (2*e6*k1k2 - 2*e2*k1k6 + 2*e1*k2k6)*k33 + k11*(-2*e6*k2k3 & - 2*e3*k2k6 + 2*e2*k3k6) + (2*e3*k1k2 - 2*e2*k1k3 + 2*e1*k2k3)*k66 x(80) = x(78) + kz7*x(79) x(81) = k33*(2*e7*k2k6 - 2*e6*k2k7 - 2*e2*k6k7) + k11*(2*e7*k4k6 & - 2*e6*k4k7 + 2*e4*k6k7) x(82) = -2*e4*k1k7 + e7*(-2*k1k4 - 2*k2k3) - 2*e3*k2k7 & + 2*e2*k3k7 + 2*e1*k4k7 x(83) = x(81) + k66*x(82) x(84) = x(80) + kz1*x(83) x(85) = (2*e7*k1k2 + 2*e2*k1k7 - 2*e1*k2k7)*k66 + k11*(-2*e7*k2k6 & + 2*e6*k2k7 - 2*e2*k6k7) x(86) = x(77) + kz3*x(84) + kz3**2*x(85) x(87) = x(56) + tk88*x(86) x(88) = x(40) + e5*x(87) x(89) = 0 x(90) = 0 x(91) = 2*e4*e6*k2k3 - 2*e3*e4*k2k6 - 2*k2k4*k3k6 + (2*e2*e3 & - 2*k2k3)*k4k6 + k3k4*(-2*e2*e6 + 2*k2k6 - 2*kz1*kz6) x(92) = 2*k4k6*kz1 + 2*k2k3*kz6 x(93) = -2*k2k6 x(94) = x(91) + kz3*x(92) + kz3**2*x(93) x(95) = x(90) + k11*x(94) x(96) = x(89) + tk88*x(95) x(97) = 0 x(98) = e6*(-(e7*k2k3) + e3*(-k22 + k2k7) + e2*(k33 + k3k7)) x(99) = (k33 + k3k7)*kz1 + (k22 - k2k7)*kz3 + k2k3*kz7 x(100) = x(98) + kz6*x(99) x(101) = x(97) + k11*x(100) x(102) = -2*e2*e3*k1k6 + (-2*e1*e6 + 2*k1k6)*k2k3 + 2*k1k3*k2k6 & + 2*e1*e2*k3k6 + k1k2*(2*e3*e6 - 2*k3k6 - 2*kz3*kz6) x(103) = -2*k1k6*kz3 + 2*k2k3*kz6 x(104) = 2*k3k6 x(105) = x(102) + kz1*x(103) + kz1**2*x(104) x(106) = x(101) + tk55*x(105) x(107) = x(96) + k44*x(106) x(108) = 0 x(109) = e6*(2*k1k4*k2k3 + 2*k1k3*k2k4 - 2*k1k2*k3k4) + e3 & *(-2*k1k6*k2k4 - 2*k1k4*k2k6 + 2*k1k2*k4k6) x(110) = (-2*e4*k1k3 + 2*e3*k1k4)*kz6 x(111) = 2*e6*k3k4 + 2*e4*k3k6 - 2*e3*k4k6 x(112) = x(109) + kz1*x(110) + kz1**2*x(111) x(113) = -4*e4*e6*k2k3 + 4*e3*e4*k2k6 + 2*k2k4*k3k6 + (-4*e2*e3 & + 2*k2k3)*k4k6 + k3k4*(4*e2*e6 - 2*k2k6 + 2*kz1*kz6) x(114) = x(112) + e1*x(113) x(115) = (-2*e6*k1k4 + 2*e4*k1k6 - 2*e6*k2k3 + 2*e3*k2k6 & - 2*e2*k3k6 - 2*e1*k4k6)*kz1 + (-2*e3*k1k2 + 2*e2*k1k3 & - 2*e1*k2k3)*kz6 x(116) = 2*e6*k1k2 - 2*e2*k1k6 + 2*e1*k2k6 x(117) = x(114) + kz3*x(115) + kz3**2*x(116) x(118) = x(108) + tk88*x(117) x(119) = -(e6*k11*k2k3) + e7*((2*e1*e6 - k1k6)*k2k3 - k1k3*k2k6 & + k1k2*k3k6 + k1k2*kz3*kz6) + kz6*(e1*(-k22 + k2k7)*kz3 & - e1*k2k3*kz7) x(120) = (2*e1*e6 - k1k6)*k22 + k1k7*k2k6 + (-2*e1*e6 & + k1k6)*k2k7 + k1k2*(-k6k7 - kz6*kz7) x(121) = x(119) + e3*x(120) x(122) = k1k6*k33 - k1k7*k3k6 + k1k6*k3k7 + e6*(2*e3*k11 & - 2*e1*k33 - 2*e1*k3k7) + k1k3*k6k7 x(123) = (-k11 - k1k7)*kz3 + k1k3*kz7 x(124) = x(122) + kz6*x(123) x(125) = x(121) + e2*x(124) x(126) = (-(e7*k2k6) + e6*(-k22 + k2k7) + e2*k6k7)*kz3 & + (-(e6*k2k3) + e3*k2k6 - e2*k3k6)*kz7 x(127) = e7*k1k3 + e3*(k11 - k1k7) + e1*(-k33 - k3k7) x(128) = x(126) + kz6*x(127) x(129) = -(e7*k3k6) + e6*(-k33 - k3k7) + e3*k6k7 x(130) = x(125) + kz1*x(128) + kz1**2*x(129) x(131) = x(118) + k44*x(130) x(132) = x(107) + e5*x(131) x(133) = (2*k1k3*k2k6 - 2*k1k2*k3k6)*k4k7 + k1k4*(-2*e2*e3*tk55 & - 2*e2*e3*tk88 + k2k3*(kz6*kz7 + 2*tk55 + 2*tk88)) x(134) = 2*k1k7*k3k6 + k1k3*(-2*k6k7 - kz6*kz7 + 2*tk55 + 2*tk88) x(135) = x(133) + k2k4*x(134) x(136) = -2*k1k7*k2k6 + k1k2*(2*k6k7 + kz6*kz7 - 2*tk55 - 2*tk88) x(137) = x(135) + k3k4*x(136) x(138) = (e7*k1k3 - e3*k1k7)*k2k4 + (-(e7*k1k2) + e2*k1k7)*k3k4 & + (e3*k1k2 - e2*k1k3)*k4k7 x(139) = -(e7*k2k3) + e3*(-k22 + k2k7) + e2*(k33 + k3k7) x(140) = x(138) + k1k4*x(139) x(141) = x(137) + e6*x(140) x(142) = (k1k7*k3k4 + k1k4*(k33 + k3k7) - k1k3*k4k7)*kz6 & + (-(k2k6*k3k4) + k2k4*k3k6 + k2k3*(-k44 - k4k6))*kz7 x(143) = (-k33 - k3k7)*k44 + (-k33 - k3k7)*k4k6 + k3k6*k4k7 & + k3k4*(-k6k7 + 2*tk55 + 2*tk88) x(144) = x(141) + kz1*x(142) + kz1**2*x(143) x(145) = e7*(k2k6*k3k4 - k2k4*k3k6 + k2k3*(k44 + k4k6)) x(146) = (k22 - k2k7)*k44 + (k22 - k2k7)*k4k6 - k2k6*k4k7 & + k2k4*k6k7 x(147) = x(145) + e3*x(146) x(148) = (-k33 - k3k7)*k44 + (-k33 - k3k7)*k4k6 + k3k6*k4k7 & + k3k4*(-k6k7 + 2*tk55 + 2*tk88) x(149) = x(147) + e2*x(148) x(150) = x(144) + e1*x(149) x(151) = e7*(-(k1k3*k2k6) + k1k2*k3k6) + k2k3*(e7*(-k11 + k1k6) & + e1*(-2*tk55 - 2*tk88)) x(152) = (k11 - k1k6)*k33 - k1k7*k3k6 + (k11 - k1k6)*k3k7 & + k1k3*k6k7 x(153) = x(151) + e2*x(152) x(154) = (-k11 + k1k6)*k22 + k1k7*k2k6 + (k11 - k1k6)*k2k7 + k1k2 & *(-k6k7 + 2*tk55 + 2*tk88) x(155) = x(153) + e3*x(154) x(156) = x(150) + e4*x(155) x(157) = (k1k7*k2k4 + k1k4*(k22 - k2k7) - k1k2*k4k7)*kz6 + ((-k11 & + k1k6)*k2k3 - k1k3*k2k6 + k1k2*k3k6)*kz7 x(158) = (-k11 + k1k6)*k33 + k1k7*k3k6 + (-k11 + k1k6)*k3k7 & + (-k22 + k2k7)*k44 + k2k6*k4k7 x(159) = -k22 + k2k7 x(160) = x(158) + k4k6*x(159) x(161) = -k1k3 - k2k4 x(162) = x(160) + k6k7*x(161) x(163) = -2*k1k4 - 2*k2k3 x(164) = x(162) + tk55*x(163) x(165) = -2*k1k4 - 2*k2k3 x(166) = x(164) + tk88*x(165) x(167) = x(157) + kz1*x(166) x(168) = (-k11 + k1k6)*k22 + k1k7*k2k6 + (k11 - k1k6)*k2k7 + k1k2 & *(-k6k7 + 2*tk55 + 2*tk88) x(169) = x(156) + kz3*x(167) + kz3**2*x(168) x(170) = k2k4*((-e6 - e7)*k1k3 + e1*k3k6) + e2*k1k4*(k33 + k3k7) & + e2*k1k3*k4k7 x(171) = (-e6 - e7)*k1k4 + e1*(k44 + k4k6) x(172) = x(170) + k2k3*x(171) x(173) = (e6 + e7)*k1k2 - e2*k1k7 - e1*k2k6 + (-e6 - e7)*kz1**2 & + kz1*(e1*kz6 - e2*kz7) x(174) = x(172) + k3k4*x(173) x(175) = k1k7*k2k4 + k1k4*(2*e2*e6 - k22 + k2k7) + e1*e2*(-2*k44 & - 2*k4k6) - k1k2*k4k7 x(176) = k1k4*kz6 + k2k4*kz7 x(177) = -k44 - k4k6 + k4k7 x(178) = x(175) + kz1*x(176) + kz1**2*x(177) x(179) = x(174) + e3*x(178) x(180) = 2*e2*e3*k11 - 2*e2*e3*k1k6 + (-k11 + k1k6)*k2k3 & + k1k3*k2k6 - k1k2*k3k6 x(181) = 2*e7*k2k3 + e3*(2*k22 - 2*k2k7) + e2*(-2*k33 - 2*k3k7) x(182) = x(180) + e1*x(181) x(183) = -(k1k3*kz6) - k2k3*kz7 x(184) = -k33 + k3k6 - k3k7 x(185) = x(182) + kz1*x(183) + kz1**2*x(184) x(186) = x(179) + e4*x(185) x(187) = (-(e4*k1k2) - e2*k1k4 + e1*k2k4)*kz6 + (e3*k1k2 & - e2*k1k3 + e1*k2k3)*kz7 x(188) = (-e6 - e7)*k1k3 + (-e6 - e7)*k2k4 + e1*(k33 + k3k6 & + k3k7) x(189) = k44 + k4k6 + k4k7 x(190) = x(188) + e2*x(189) x(191) = -k11 + k1k6 + k1k7 x(192) = x(190) + e3*x(191) x(193) = -k22 + k2k6 + k2k7 x(194) = x(192) + e4*x(193) x(195) = x(187) + kz1*x(194) x(196) = (-e6 - e7)*k1k2 + e2*(k11 - k1k6 + k1k7) + e1*(k22 & + k2k6 - k2k7) x(197) = x(186) + kz3*x(195) + kz3**2*x(196) x(198) = x(169) + e5*x(197) x(199) = x(132) + k66*x(198) x(200) = x(88) + k77*x(199) x(201) = 0 x(202) = k11*(k44*(-(e6*k2k7) + e7*(2*e2*e6 + kz1*kz6) & - e2*kz6*kz7) + k22*(e7*(-2*e4*e6 + k4k6) - e6*kz3*kz7 & + e4*kz6*kz7)) x(203) = -(e7*k1k4*k22) + (e2*(k11 - k1k6)*kz3 - e2*k1k4*kz6)*kz7 & + e6*(-(k1k7*k2k4) + k1k4*(2*e2*e7 - k2k7) + k1k2*k4k7 & - k1k2*kz3*kz7) x(204) = 2*e2*e7*k11 - 2*e2*e7*k1k6 + k1k7*k2k6 + (-k11 & + k1k6)*k2k7 + k1k2*(-k6k7 - kz6*kz7) x(205) = x(203) + e4*x(204) x(206) = k2k7*k44 + k2k7*k4k6 + e7*(2*e4*k22 - 2*e2*k44 & - 2*e2*k4k6) - k2k6*k4k7 + k2k4*k6k7 x(207) = (k22 + k2k6)*kz3 + k2k4*kz6 x(208) = x(206) + kz7*x(207) x(209) = x(205) + e1*x(208) x(210) = (e7*(-k11 + k1k6) - e6*k1k7 + e1*k6k7)*kz3 + (e7*k1k4 & - e4*k1k7 + e1*k4k7)*kz6 x(211) = -(e6*k2k4) + e4*(-k22 + k2k6) + e2*(k44 + k4k6) x(212) = x(210) + kz7*x(211) x(213) = e7*(-k44 - k4k6) - e6*k4k7 + e4*k6k7 x(214) = x(209) + kz1*x(212) + kz1**2*x(213) x(215) = x(202) + k66*x(214) x(216) = x(201) + k33*x(215) x(217) = 0 x(218) = e7*(-2*k1k6*k3k4 + 2*k1k4*k3k6 + 2*k1k3*k4k6) + e6 & *(2*k1k7*k3k4 - 2*k1k4*k3k7 - 2*k1k3*k4k7) x(219) = (-2*e7*k3k4 + 2*e3*k4k7)*kz6 + (2*e6*k3k4 & - 2*e3*k4k6)*kz7 x(220) = x(218) + kz1*x(219) x(221) = 4*e3*e7*k1k6 - 4*e3*e6*k1k7 - 2*k1k3*k6k7 + k3k7 & *(4*e1*e6 - 2*k1k6 - 2*kz1*kz6) + k3k6*(-4*e1*e7 + 2*k1k7 & + 2*kz1*kz7) x(222) = x(220) + e4*x(221) x(223) = x(217) + k22*x(222) x(224) = e7*(2*k1k4*k2k3 + 2*k1k3*k2k4 - 2*k1k2*k3k4) + e4 & *(-2*k1k7*k2k3 - 2*k1k3*k2k7 + 2*k1k2*k3k7) x(225) = (-2*e4*k2k3 + 2*e3*k2k4)*kz7 x(226) = 2*e7*k3k4 - 2*e4*k3k7 + 2*e3*k4k7 x(227) = x(224) + kz1*x(225) + kz1**2*x(226) x(228) = -4*e3*e7*k1k4 + 4*e3*e4*k1k7 + (-4*e1*e4 + 2*k1k4)*k3k7 & + 2*k1k3*k4k7 + k3k4*(4*e1*e7 - 2*k1k7 - 2*kz1*kz7) x(229) = x(227) + e2*x(228) x(230) = x(223) + k66*x(229) x(231) = e7*(2*k1k6*k2k3 + 2*k1k3*k2k6 - 2*k1k2*k3k6) + e6 & *(-2*k1k7*k2k3 - 2*k1k3*k2k7 + 2*k1k2*k3k7) x(232) = -4*e3*e7*k1k6 + 4*e3*e6*k1k7 + (4*e1*e7 - 2*k1k7)*k3k6 & + (-4*e1*e6 + 2*k1k6)*k3k7 + 2*k1k3*k6k7 x(233) = x(231) + e2*x(232) x(234) = (2*e7*k2k3 - 2*e3*k2k7 + 2*e2*k3k7)*kz6 + (-2*e6*k2k3 & + 2*e3*k2k6 - 2*e2*k3k6)*kz7 x(235) = 2*e7*k3k6 - 2*e6*k3k7 + 2*e3*k6k7 x(236) = x(233) + kz1*x(234) + kz1**2*x(235) x(237) = x(230) + k44*x(236) x(238) = ((-2*e7*k1k2 - 2*e2*k1k7 + 2*e1*k2k7)*k44 + k22 & *(2*e7*k1k4 + 2*e4*k1k7 - 2*e1*k4k7))*kz6 x(239) = (2*e6*k1k2 + 2*e2*k1k6 - 2*e1*k2k6)*k44 + k22 & *(-2*e6*k1k4 - 2*e4*k1k6 + 2*e1*k4k6) + (2*e4*k1k2 + 2*e2*k1k4 & - 2*e1*k2k4)*k66 x(240) = x(238) + kz7*x(239) x(241) = k44*(-2*e7*k1k6 + 2*e6*k1k7 - 2*e1*k6k7) + k22 & *(-2*e7*k3k6 + 2*e6*k3k7 + 2*e3*k6k7) x(242) = 2*e4*k1k7 + e7*(-2*k1k4 - 2*k2k3) + 2*e3*k2k7 & - 2*e2*k3k7 - 2*e1*k4k7 x(243) = x(241) + k66*x(242) x(244) = x(240) + kz1*x(243) x(245) = (2*e7*k1k2 + 2*e2*k1k7 - 2*e1*k2k7)*k66 + k22*(2*e7*k1k6 & - 2*e6*k1k7 - 2*e1*k6k7) x(246) = x(237) + kz3*x(244) + kz3**2*x(245) x(247) = x(216) + tk55*x(246) x(248) = 0 x(249) = e6*(2*k1k4*k2k3 + 2*k1k3*k2k4 - 2*k1k2*k3k4) + e2 & *(2*k1k6*k3k4 - 2*k1k4*k3k6 - 2*k1k3*k4k6) x(250) = (-2*e3*k2k4 + 2*e2*k3k4)*kz6 x(251) = 2*e6*k3k4 - 2*e3*k4k6 x(252) = x(249) + kz1*x(250) + kz1**2*x(251) x(253) = 4*e3*e6*k1k2 - 4*e2*e3*k1k6 + 2*k1k3*k2k6 + k3k6 & *(4*e1*e2 - 2*k1k2 + 2*kz1**2) + k2k3*(-4*e1*e6 + 2*k1k6 & + 2*kz1*kz6) x(254) = x(252) + e4*x(253) x(255) = (-2*e6*k1k4 - 2*e4*k1k6 - 2*e6*k2k3 - 2*e3*k2k6 & + 2*e2*k3k6 + 2*e1*k4k6)*kz1 + (-2*e4*k1k2 - 2*e2*k1k4 & + 2*e1*k2k4)*kz6 x(256) = 2*e6*k1k2 - 2*e2*k1k6 + 2*e1*k2k6 x(257) = x(254) + kz3*x(255) + kz3**2*x(256) x(258) = x(248) + tk55*x(257) x(259) = -(e6*k2k3*k44) + e7*(-(k2k6*k3k4) + k2k4*k3k6 + k2k3 & *(-2*e4*e6 + k4k6) + k3k4*kz1*kz6) + kz6*(e4*(k33 + k3k7)*kz1 & + e4*k2k3*kz7) x(260) = 2*e4*e6*k33 + 2*e4*e6*k3k7 + (-k33 - k3k7)*k4k6 & - k3k6*k4k7 + k3k4*(k6k7 + kz6*kz7) x(261) = x(259) + e2*x(260) x(262) = e6*(-2*e4*k22 + 2*e4*k2k7 + 2*e2*k44) + (k22 & - k2k7)*k4k6 + k2k6*k4k7 - k2k4*k6k7 x(263) = (k44 - k4k7)*kz1 - k2k4*kz7 x(264) = x(262) + kz6*x(263) x(265) = x(261) + e3*x(264) x(266) = (e7*k3k6 + e6*(-k33 - k3k7) - e3*k6k7)*kz1 + (-(e6*k2k3) & - e3*k2k6 + e2*k3k6)*kz7 x(267) = e7*k2k4 + e4*(k22 - k2k7) + e2*(-k44 - k4k7) x(268) = x(266) + kz6*x(267) x(269) = e7*k2k6 + e6*(-k22 + k2k7) - e2*k6k7 x(270) = x(265) + kz3*x(268) + kz3**2*x(269) x(271) = x(258) + k11*x(270) x(272) = k2k4*((-e6 - e7)*k1k3 + e1*k3k6) + e2*k1k4*(k33 + k3k7) & + e2*k1k3*k4k7 x(273) = (-e6 - e7)*k1k4 + e1*(k44 + k4k6) x(274) = x(272) + k2k3*x(273) x(275) = (e6 + e7)*k1k2 - e2*k1k7 - e1*k2k6 + (-e6 - e7)*kz1**2 & + kz1*(e1*kz6 - e2*kz7) x(276) = x(274) + k3k4*x(275) x(277) = k1k7*k2k4 + k1k4*(2*e2*e6 - k22 + k2k7) + e1*e2*(-2*k44 & - 2*k4k6) - k1k2*k4k7 x(278) = k1k4*kz6 + k2k4*kz7 x(279) = -k44 - k4k6 + k4k7 x(280) = x(277) + kz1*x(278) + kz1**2*x(279) x(281) = x(276) + e3*x(280) x(282) = 2*e2*e3*k11 - 2*e2*e3*k1k6 + (-k11 + k1k6)*k2k3 & + k1k3*k2k6 - k1k2*k3k6 x(283) = 2*e7*k2k3 + e3*(2*k22 - 2*k2k7) + e2*(-2*k33 - 2*k3k7) x(284) = x(282) + e1*x(283) x(285) = -(k1k3*kz6) - k2k3*kz7 x(286) = -k33 + k3k6 - k3k7 x(287) = x(284) + kz1*x(285) + kz1**2*x(286) x(288) = x(281) + e4*x(287) x(289) = (-(e4*k1k2) - e2*k1k4 + e1*k2k4)*kz6 + (e3*k1k2 & - e2*k1k3 + e1*k2k3)*kz7 x(290) = (-e6 - e7)*k1k3 + (-e6 - e7)*k2k4 + e1*(k33 + k3k6 & + k3k7) x(291) = k44 + k4k6 + k4k7 x(292) = x(290) + e2*x(291) x(293) = -k11 + k1k6 + k1k7 x(294) = x(292) + e3*x(293) x(295) = -k22 + k2k6 + k2k7 x(296) = x(294) + e4*x(295) x(297) = x(289) + kz1*x(296) x(298) = (-e6 - e7)*k1k2 + e2*(k11 - k1k6 + k1k7) + e1*(k22 & + k2k6 - k2k7) x(299) = x(288) + kz3*x(297) + kz3**2*x(298) x(300) = x(271) + k66*x(299) x(301) = x(247) + k77*x(300) x(302) = 0 x(303) = k33*(e7*(e6*(4*e1*e4 - k1k4) - e4*k1k6 - e1*k4k6) & + (k4k6*kz1 - k1k6*kz3 + e6*(-2*e4*kz1 + 2*e1*kz3) & - k1k4*kz6)*kz7) x(304) = k3k7*(2*e4*e6 - k4k6) + (e3*e6 - k3k6)*k4k7 + (-(e3*e4) & + k3k4)*k6k7 + k3k4*kz6*kz7 x(305) = e6*(-4*e3*e4 - k3k4) + e4*k3k6 + 2*e3*k4k6 x(306) = x(304) + e7*x(305) x(307) = (2*e4*e7 - k4k7)*kz6 + (-2*e3*e6 + k3k6)*kz7 x(308) = -k6k7 x(309) = x(306) + kz3*x(307) + kz3**2*x(308) x(310) = x(303) + k11*x(309) x(311) = x(302) + k22*x(310) x(312) = k11*(e6*e7*(4*e2*e3 - k2k3) + e6*(-(e3*k2k7) - e2*k3k7) & + kz6*(-(k3k7*kz1) + k2k7*kz3 + e7*(2*e3*kz1 - 2*e2*kz3) & - k2k3*kz7)) x(313) = k1k7*(e2*e6 - k2k6) + (2*e1*e6 - k1k6)*k2k7 + (-(e1*e2) & + k1k2)*k6k7 + k1k2*kz6*kz7 x(314) = e6*(-4*e1*e2 - k1k2) + 2*e2*k1k6 + e1*k2k6 x(315) = x(313) + e7*x(314) x(316) = (-2*e1*e7 + k1k7)*kz6 + (2*e2*e6 - k2k6)*kz7 x(317) = -k6k7 x(318) = x(315) + kz1*x(316) + kz1**2*x(317) x(319) = x(312) + k33*x(318) x(320) = x(311) + k44*x(319) x(321) = (2*e1*e4*k2k7 - k1k4*k2k7)*k33 - 2*e1*e4*k22*k3k7 + k2k4 & *(-(k1k7*k33) - 2*k1k7*k3k6 + 2*k1k3*k6k7 + k1k3*kz6*kz7) + k1k4 & *(k22*k3k7 - k2k3*kz6*kz7) x(322) = k1k7*(-k22 + 2*k2k6) + k1k2*(-2*k6k7 - kz6*kz7) x(323) = x(321) + k3k4*x(322) x(324) = k1k3*(k22 - 2*k2k6) + k1k2*(k33 + 2*k3k6) x(325) = x(323) + k4k7*x(324) x(326) = k1k7*(-(e6*k3k4) + e4*(k33 + k3k6)) + (e6*k1k3 + e1 & *(-k33 - k3k6))*k4k7 - e4*k1k3*k6k7 + e1*k3k4*k6k7 x(327) = -(e6*k1k4) + e4*(-k11 + k1k6) + e1*(k44 + k4k6) x(328) = x(326) + k3k7*x(327) x(329) = x(325) + e2*x(328) x(330) = k1k7*(e6*k2k4 + e4*(k22 - k2k6)) + (-(e6*k1k2) + e1 & *(-k22 + k2k6))*k4k7 + e4*k1k2*k6k7 - e1*k2k4*k6k7 x(331) = -(e6*k1k4) + e4*(-k11 + k1k6) + e1*(k44 + k4k6) x(332) = x(330) + k2k7*x(331) x(333) = x(329) + e3*x(332) x(334) = (-(k1k7*k3k4) - k1k4*k3k7 + k1k3*k4k7)*kz6 x(335) = (2*e2*e4 - k2k4)*k33 + (-k22 + k2k6)*k3k4 - k2k4*k3k6 & + k2k3*(k44 + k4k6) x(336) = x(334) + kz7*x(335) x(337) = k3k7*(k44 + k4k6) + (-k33 - k3k6)*k4k7 + k3k4*k6k7 x(338) = x(333) + kz1*x(336) + kz1**2*x(337) x(339) = (-(k1k7*k2k4) + k1k4*k2k7 + k1k2*k4k7)*kz6 x(340) = (2*e1*e3 - k1k3)*k22 + (k11 - k1k6)*k2k3 + k1k3*k2k6 & + k1k2*(-k33 - k3k6) x(341) = x(339) + kz7*x(340) x(342) = k1k7*(-k33 - k3k6) + (k11 - k1k6)*k3k7 + k2k7*(-k44 & - k4k6) + (k22 - k2k6)*k4k7 x(343) = k1k3 + k2k4 x(344) = x(342) + k6k7*x(343) x(345) = x(341) + kz1*x(344) x(346) = k1k7*(k22 - k2k6) + (-k11 + k1k6)*k2k7 + k1k2*k6k7 x(347) = x(338) + kz3*x(345) + kz3**2*x(346) x(348) = e6*(-3*k1k3*k2k4 + 3*k1k2*k3k4) + (-2*e6*k3k4 + e3 & *(-2*k44 - 2*k4k6))*kz1**2 x(349) = -(e6*k2k3) + 2*e2*k33 + e3*(4*e2*e6 - 2*k22 + 2*kz1*kz6) x(350) = x(348) + k1k4*x(349) x(351) = k2k4*(k33 + 3*k3k6) + (-4*e2*e3 + k2k3)*k44 + (-4*e2*e3 & + k2k3)*k4k6 + k3k4*(k22 - 3*k2k6 + 2*kz1*kz6) x(352) = x(350) + e1*x(351) x(353) = e3*(e2*(4*k11 - 4*k1k6) + 4*e1*k22) + (-k11 + k1k6)*k2k3 & - 4*e1*e2*k33 - k1k2*k33 + k3k6*(-3*k1k2 + 2*kz1**2) x(354) = -k22 + 3*k2k6 - 2*kz1*kz6 x(355) = x(353) + k1k3*x(354) x(356) = x(352) + e4*x(355) x(357) = (-2*e4*k1k2 - 2*e2*k1k4 + 2*e1*k2k4)*kz6 x(358) = e3*(-2*k11 + 2*k1k6) + e4*(-2*k22 + 2*k2k6) + e1*(2*k33 & + 2*k3k6) + e2*(2*k44 + 2*k4k6) x(359) = -2*k1k3 - 2*k2k4 x(360) = x(358) + e6*x(359) x(361) = x(357) + kz1*x(360) x(362) = -2*e6*k1k2 + e2*(2*k11 - 2*k1k6) + 2*e1*k2k6 x(363) = x(356) + kz3*x(361) + kz3**2*x(362) x(364) = x(347) + e7*x(363) x(365) = x(320) + k66*x(364) x(366) = -2*e2*e3*k11*k4k6 + (-2*k1k3*k2k6 + 2*k1k2*k3k6)*k4k7 & + 4*e2*e3*k1k4*k66 + k2k3*(k11*k4k6 + k1k4*(-2*k66 - kz6*kz7)) x(367) = k1k6*(2*e2*e3 - k2k3) - k1k3*k2k6 + k1k2*k3k6 x(368) = x(366) + k44*x(367) x(369) = (k11 - 2*k1k7)*k3k6 + k1k3*(-2*k66 + 2*k6k7 + kz6*kz7) x(370) = x(368) + k2k4*x(369) x(371) = (-k11 + 2*k1k7)*k2k6 + k1k2*(2*k66 - 2*k6k7 - kz6*kz7) x(372) = x(370) + k3k4*x(371) x(373) = -(e7*k1k6*k2k3) + e7*k1k3*k2k6 - e7*k1k2*k3k6 + e2 & *((-k11 + k1k7)*k3k6 + k1k6*(k33 + k3k7) + k1k3*(2*k66 - k6k7)) x(374) = (k11 - k1k7)*k2k6 + k1k6*(-k22 + k2k7) + k1k2*(-2*k66 & + k6k7) x(375) = x(373) + e3*x(374) x(376) = x(372) + e4*x(375) x(377) = ((k11 - k1k7)*k3k4 + k1k4*(-k33 - k3k7) + k1k3*(k44 & + k4k7))*kz6 + (k2k6*k3k4 - k2k4*k3k6 + k2k3*k4k6)*kz7 x(378) = (k33 + k3k7)*k4k6 + k3k6*(-k44 - k4k7) + k3k4*(-2*k66 & + k6k7) x(379) = x(376) + kz1*x(377) + kz1**2*x(378) x(380) = e7*(-(k2k6*k3k4) + k2k4*k3k6 - k2k3*k4k6) + 4*e4*k2k3*k66 x(381) = (k33 + k3k7)*k4k6 + k3k6*(-k44 - k4k7) + k3k4*(-2*k66 & + k6k7) x(382) = x(380) + e2*x(381) x(383) = (-k22 + k2k7)*k4k6 + k2k6*k4k7 + (-8*e2*e4 + 2*k2k4)*k66 & - k2k4*k6k7 + k44*(k2k6 - 2*kz1*kz6) x(384) = x(382) + e3*x(383) x(385) = x(379) + e1*x(384) x(386) = (-(k1k6*k2k3) + k1k3*k2k6 - k1k2*k3k6)*kz7 x(387) = -2*e2*e4*k11 + (k11 - k1k7)*k2k4 + k1k4*(-k22 + k2k7) & + k1k2*(k44 + k4k7) x(388) = x(386) + kz6*x(387) x(389) = (k11 - k1k7)*k3k6 + k1k6*(-k33 - k3k7) + (k22 & - k2k7)*k4k6 + k2k6*(-k44 - k4k7) x(390) = k1k3 + k2k4 x(391) = x(389) + k6k7*x(390) x(392) = 4*e1*e3 + 4*e2*e4 - 2*k1k3 - 2*k2k4 x(393) = x(391) + k66*x(392) x(394) = x(388) + kz1*x(393) x(395) = (k11 - k1k7)*k2k6 + k1k6*(-k22 + k2k7) + k1k2*(-2*k66 & + k6k7) x(396) = x(385) + kz3*x(394) + kz3**2*x(395) x(397) = e7*(-3*k1k3*k2k4 + 3*k1k2*k3k4) + (-2*e7*k3k4 + e4 & *(-2*k33 - 2*k3k7))*kz1**2 x(398) = -(e7*k1k4) + 2*e1*k44 + e4*(4*e1*e7 - 2*k11 - 2*kz1*kz7) x(399) = x(397) + k2k3*x(398) x(400) = (-4*e1*e4 + k1k4)*k33 + (-4*e1*e4 + k1k4)*k3k7 + k1k3 & *(k44 + 3*k4k7) + k3k4*(k11 - 3*k1k7 - 2*kz1*kz7) x(401) = x(399) + e2*x(400) x(402) = -(k1k4*k22) + e4*(4*e2*k11 + e1*(4*k22 - 4*k2k7)) & + k1k4*k2k7 - 4*e1*e2*k44 - k1k2*k44 + k4k7*(-3*k1k2 + 2*kz1**2) x(403) = -k11 + 3*k1k7 + 2*kz1*kz7 x(404) = x(402) + k2k4*x(403) x(405) = x(401) + e3*x(404) x(406) = (2*e3*k1k2 - 2*e2*k1k3 + 2*e1*k2k3)*kz7 x(407) = e3*(-2*k11 + 2*k1k7) + e4*(-2*k22 + 2*k2k7) + e1*(2*k33 & + 2*k3k7) + e2*(2*k44 + 2*k4k7) x(408) = -2*k1k3 - 2*k2k4 x(409) = x(407) + e7*x(408) x(410) = x(406) + kz1*x(409) x(411) = -2*e7*k1k2 + 2*e2*k1k7 + e1*(2*k22 - 2*k2k7) x(412) = x(405) + kz3*x(410) + kz3**2*x(411) x(413) = x(396) + e6*x(412) x(414) = x(365) + k77*x(413) x(415) = x(301) + e5*x(414) x(416) = x(200) + e8*x(415) feynman = (6*cf*x(416))/(tk55*tk88) feynman = feynman*prefactor ! ! (End flavorset query.) ! END IF !------ ! END IF ! RETURN END function feynman ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Feynman integrand in Coulomb gauge, soft subtraction for shower calc. ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function softsubtraction(k,absk, & graphnumber,flavorsetnumber,cutnumber) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: k(0:3*size-1,0:3),absk(0:3*size-1) integer :: graphnumber,flavorsetnumber,cutnumber ! Out: complex(kind=dbl) :: softsubtraction ! ! Calculates the soft subtraction for NLO graphs. ! Used for calculations with showers, in Coulomb gauge. ! This version written by Mathematica code of 2 October 2004 on ! 2 Oct 2004. ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) complex(kind=dbl), parameter :: zero = (0.0d0,0.0d0) real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! integer :: mu complex(kind=dbl) :: result real(kind=dbl) :: qi(3),qj(3),l(3) real(kind=dbl) :: absqi,absqj,absqk,absl real(kind=dbl) :: lrsign real(kind=dbl) :: colorfactor complex(kind=dbl) :: softfactor complex(kind=dbl) :: q12,q13,q23,tq22 complex(kind=dbl) :: qz1,qz2,qz3 real(kind=dbl) :: e1,e2,e3,e4,e5,e6,e7,e8 real(kind=dbl) :: kz1,kz2,kz3,kz4,kz5,kz6,kz7,kz8 real(kind=dbl) :: tk11,tk22,tk33,tk44,tk55,tk66,tk77,tk88 real(kind=dbl) :: k11,k12,k13,k14,k15,k16,k17,k18 real(kind=dbl) :: k22,k23,k24,k25,k26,k27,k28,k33 real(kind=dbl) :: k34,k35,k36,k37,k38,k44,k45,k46 real(kind=dbl) :: k47,k48,k56,k57,k67,k68,k78 ! softsubtraction = zero ! IF (graphnumber.EQ.1) THEN ! Code for graph 1, with connections ! {{2, 3}, {1, 4}, {1, 4, 5}, {2, 3, 6}, {3, 6, 6}, {4, 5, 5}}. ! softsubtraction = zero ! ELSE IF (graphnumber.EQ.2) THEN ! Code for graph 2, with connections ! {{2, 3}, {1, 4}, {1, 5, 5}, {2, 6, 6}, {3, 3, 6}, {4, 4, 5}}. ! softsubtraction = zero ! ELSE IF (graphnumber.EQ.3) THEN ! Code for graph 3, with connections ! {{2, 3}, {1, 4}, {1, 5, 6}, {2, 5, 6}, {3, 4, 6}, {3, 4, 5}}. ! IF (flavorsetnumber.EQ.1) THEN ! Flavors = {quark, qbar, quark, gluon, qbar, quark, gluon, quark} ! softsubtraction = zero ! ELSE IF (flavorsetnumber.EQ.2) THEN ! Flavors = {quark, qbar, quark, gluon, qbar, gluon, quark, gluon} ! IF (cutnumber.EQ.1) THEN ! cut = {5, 4, 1, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(4,mu) qj(mu) = k(5,mu) l(mu) = k(8,mu) END DO absqi = absk(4) absqj = absk(5) absqk = absk(1) absl = absk(8) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(1) e2 = absk(4) e3 = absk(5) qz1 = + k(1,3) qz2 = + k(4,3) qz3 = + k(5,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(1,mu)*k(4,mu)*metric(mu) q13 = q13 + k(1,mu)*k(5,mu)*metric(mu) q23 = q23 + k(4,mu)*k(5,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1*e2**2*e3 - 2*e1*e2*e3**2 + e1*e2*q23 & + e1*e3*q23 + e2*e3*qz1*qz2 + e2**2*qz1*qz3 + 2*e2*e3*qz1*qz3 & - q23*qz1*qz3 + e1*e2*tq22 & - qz1*qz2*tq22))/(2.0d0*e1*e2*e3*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.2) THEN ! cut = {7, 6, 1, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = - k(6,mu) qj(mu) = - k(7,mu) l(mu) = k(8,mu) END DO absqi = absk(6) absqj = absk(7) absqk = absk(1) absl = absk(8) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(1) e2 = absk(6) e3 = absk(7) qz1 = + k(1,3) qz2 = - k(6,3) qz3 = - k(7,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 - k(1,mu)*k(6,mu)*metric(mu) q13 = q13 - k(1,mu)*k(7,mu)*metric(mu) q23 = q23 + k(6,mu)*k(7,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1*e2**2*e3 - 2*e1*e2*e3**2 + e1*e2*q23 & + e1*e3*q23 + e2*e3*qz1*qz2 + e2**2*qz1*qz3 + 2*e2*e3*qz1*qz3 & - q23*qz1*qz3 + e1*e2*tq22 & - qz1*qz2*tq22))/(2.0d0*e1*e2*e3*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.3) THEN ! cut = {8, 7, 4, 1}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(7,mu) + k(5,mu)) qj(mu) = 0.5d0*( k(4,mu) - k(6,mu)) l(mu) = - k(8,mu) END DO absl = absk(8) absqk = absk(1) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e4 = k(4,0) e7 = k(7,0) kz1 = k(1,3) kz2 = k(2,3) kz4 = k(4,3) kz7 = k(7,3) k22 = 0.0d0 k24 = 0.0d0 k27 = 0.0d0 k47 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk44 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk44 = tk44 - k(4,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (-3*cf*nc*(2*e1*e2*e4*e7*k24 - 2*e1*e2*e4**2*k27 & + 2*e1*e2**2*e4*k47 - 2*e1*e2*k24*k47 - 2*e4*e7*k24*kz1*kz2 & + 2*e4**2*k27*kz1*kz2 - 2*e2*e4*k47*kz1*kz2 + 2*k24*k47*kz1*kz2 & + e4*e7*k22*kz1*kz4 - k22*k47*kz1*kz4 - e4**2*k22*kz1*kz7 & + e1*e7*k22*tk44 - 2*e1*e2*k27*tk44 + 2*k27*kz1*kz2*tk44 & - k22*kz1*kz7*tk44))/(e1*e4*e7*k22**2*tk44) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.4) THEN ! cut = {8, 6, 5, 1}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(6,mu) + k(4,mu)) qj(mu) = 0.5d0*( k(5,mu) - k(7,mu)) l(mu) = k(8,mu) END DO absl = absk(8) absqk = absk(1) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e5 = k(5,0) e6 = k(6,0) kz1 = k(1,3) kz2 = k(2,3) kz5 = k(5,3) kz6 = k(6,3) k22 = 0.0d0 k25 = 0.0d0 k26 = 0.0d0 k56 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k25 = k25 + k(2,mu)*k(5,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k56 = k56 + k(5,mu)*k(6,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk55 = tk55 - k(5,mu)**2 tk66 = tk66 - k(6,mu)**2 END DO ! result = (-3*cf*nc*(2*e1*e2*e6**2*k25 - 2*e1*e2*e5*e6*k26 & - 2*e1*e2**2*e6*k56 + 2*e1*e2*k26*k56 - 2*e6**2*k25*kz1*kz2 & + 2*e5*e6*k26*kz1*kz2 + 2*e2*e6*k56*kz1*kz2 - 2*k26*k56*kz1*kz2 & + e6**2*k22*kz1*kz5 - e5*e6*k22*kz1*kz6 + k22*k56*kz1*kz6 & - e1*e5*k22*tk66 + 2*e1*e2*k25*tk66 - 2*k25*kz1*kz2*tk66 & + k22*kz1*kz5*tk66))/(e1*e5*e6*k22**2*tk66) result = result*softfactor softsubtraction = softsubtraction - result ! ! Close IF (cutnumber.EQ....) THEN ! END IF ! ELSE IF (flavorsetnumber.EQ.3) THEN ! Flavors = {qbar, quark, qbar, gluon, quark, qbar, gluon, qbar} ! softsubtraction = zero ! ELSE IF (flavorsetnumber.EQ.4) THEN ! Flavors = {qbar, quark, qbar, gluon, quark, gluon, qbar, gluon} ! IF (cutnumber.EQ.1) THEN ! cut = {5, 4, 1, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(4,mu) qj(mu) = k(5,mu) l(mu) = k(8,mu) END DO absqi = absk(4) absqj = absk(5) absqk = absk(1) absl = absk(8) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(5) e2 = absk(4) e3 = absk(1) qz1 = + k(5,3) qz2 = + k(4,3) qz3 = + k(1,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(5,mu)*k(4,mu)*metric(mu) q13 = q13 + k(5,mu)*k(1,mu)*metric(mu) q23 = q23 + k(4,mu)*k(1,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1**2*e2*e3 - 2*e1*e2**2*e3 + e1*e3*q12 & + e2*e3*q12 + 2*e1*e2*qz1*qz3 + e2**2*qz1*qz3 - q12*qz1*qz3 & + e1*e2*qz2*qz3 + e2*e3*tq22 & - qz2*qz3*tq22))/(2.0d0*e1*e2*e3*q12*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.2) THEN ! cut = {7, 6, 1, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = - k(6,mu) qj(mu) = - k(7,mu) l(mu) = k(8,mu) END DO absqi = absk(6) absqj = absk(7) absqk = absk(1) absl = absk(8) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(7) e2 = absk(6) e3 = absk(1) qz1 = - k(7,3) qz2 = - k(6,3) qz3 = + k(1,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(7,mu)*k(6,mu)*metric(mu) q13 = q13 - k(7,mu)*k(1,mu)*metric(mu) q23 = q23 - k(6,mu)*k(1,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1**2*e2*e3 - 2*e1*e2**2*e3 + e1*e3*q12 & + e2*e3*q12 + 2*e1*e2*qz1*qz3 + e2**2*qz1*qz3 - q12*qz1*qz3 & + e1*e2*qz2*qz3 + e2*e3*tq22 & - qz2*qz3*tq22))/(2.0d0*e1*e2*e3*q12*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.3) THEN ! cut = {8, 7, 4, 1}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(7,mu) + k(5,mu)) qj(mu) = 0.5d0*( k(4,mu) - k(6,mu)) l(mu) = - k(8,mu) END DO absl = absk(8) absqk = absk(1) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e4 = k(4,0) e7 = k(7,0) kz1 = k(1,3) kz2 = k(2,3) kz4 = k(4,3) kz7 = k(7,3) k22 = 0.0d0 k24 = 0.0d0 k27 = 0.0d0 k47 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk44 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk44 = tk44 - k(4,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (-3*cf*nc*(2*e1*e2*e4*e7*k24 - 2*e1*e2*e4**2*k27 & + 2*e1*e2**2*e4*k47 - 2*e1*e2*k24*k47 - 2*e4*e7*k24*kz1*kz2 & + 2*e4**2*k27*kz1*kz2 - 2*e2*e4*k47*kz1*kz2 + 2*k24*k47*kz1*kz2 & + e4*e7*k22*kz1*kz4 - k22*k47*kz1*kz4 - e4**2*k22*kz1*kz7 & + e1*e7*k22*tk44 - 2*e1*e2*k27*tk44 + 2*k27*kz1*kz2*tk44 & - k22*kz1*kz7*tk44))/(e1*e4*e7*k22**2*tk44) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.4) THEN ! cut = {8, 6, 5, 1}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(6,mu) + k(4,mu)) qj(mu) = 0.5d0*( k(5,mu) - k(7,mu)) l(mu) = k(8,mu) END DO absl = absk(8) absqk = absk(1) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e5 = k(5,0) e6 = k(6,0) kz1 = k(1,3) kz2 = k(2,3) kz5 = k(5,3) kz6 = k(6,3) k22 = 0.0d0 k25 = 0.0d0 k26 = 0.0d0 k56 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k25 = k25 + k(2,mu)*k(5,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k56 = k56 + k(5,mu)*k(6,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk55 = tk55 - k(5,mu)**2 tk66 = tk66 - k(6,mu)**2 END DO ! result = (-3*cf*nc*(2*e1*e2*e6**2*k25 - 2*e1*e2*e5*e6*k26 & - 2*e1*e2**2*e6*k56 + 2*e1*e2*k26*k56 - 2*e6**2*k25*kz1*kz2 & + 2*e5*e6*k26*kz1*kz2 + 2*e2*e6*k56*kz1*kz2 - 2*k26*k56*kz1*kz2 & + e6**2*k22*kz1*kz5 - e5*e6*k22*kz1*kz6 + k22*k56*kz1*kz6 & - e1*e5*k22*tk66 + 2*e1*e2*k25*tk66 - 2*k25*kz1*kz2*tk66 & + k22*kz1*kz5*tk66))/(e1*e5*e6*k22**2*tk66) result = result*softfactor softsubtraction = softsubtraction - result ! ! Close IF (cutnumber.EQ....) THEN ! END IF ! ! Close IF (flavorsetnumber.EQ.1) THEN ... ! END IF ELSE IF (graphnumber.EQ.4) THEN ! Code for graph 4, with connections ! {{3, 4}, {3, 4}, {1, 2, 5}, {1, 2, 6}, {3, 6, 6}, {4, 5, 5}}. ! softsubtraction = zero ! ELSE IF (graphnumber.EQ.5) THEN ! Code for graph 5, with connections ! {{3, 4}, {3, 5}, {1, 2, 4}, {1, 3, 6}, {2, 6, 6}, {4, 5, 5}}. ! softsubtraction = zero ! ELSE IF (graphnumber.EQ.6) THEN ! Code for graph 6, with connections ! {{3, 4}, {3, 5}, {1, 2, 5}, {1, 6, 6}, {2, 3, 6}, {4, 4, 5}}. ! softsubtraction = zero ! ELSE IF (graphnumber.EQ.7) THEN ! Code for graph 7, with connections ! {{3, 4}, {3, 5}, {1, 2, 6}, {1, 5, 6}, {2, 4, 6}, {3, 4, 5}}. ! IF (flavorsetnumber.EQ.1) THEN ! Flavors = {quark, qbar, qbar, quark, gluon, qbar, gluon, gluon} ! IF (cutnumber.EQ.1) THEN ! cut = {5, 4, 1, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = - k(4,mu) qj(mu) = - k(5,mu) l(mu) = k(8,mu) END DO absqi = absk(4) absqj = absk(5) absqk = absk(1) absl = absk(8) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(1) e2 = absk(5) e3 = absk(4) qz1 = + k(1,3) qz2 = - k(5,3) qz3 = - k(4,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 - k(1,mu)*k(5,mu)*metric(mu) q13 = q13 - k(1,mu)*k(4,mu)*metric(mu) q23 = q23 + k(5,mu)*k(4,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.2) THEN ! cut = {7, 6, 1, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(1,mu) qj(mu) = k(7,mu) l(mu) = k(5,mu) END DO absqi = absk(1) absqj = absk(7) absqk = absk(6) absl = absk(5) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(1) e2 = absk(7) e3 = absk(6) qz1 = + k(1,3) qz2 = + k(7,3) qz3 = + k(6,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(1,mu)*k(7,mu)*metric(mu) q13 = q13 + k(1,mu)*k(6,mu)*metric(mu) q23 = q23 + k(7,mu)*k(6,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1*e2**2*e3 - 2*e1*e2*e3**2 + e1*e2*q23 & + e1*e3*q23 + e2*e3*qz1*qz2 + e2**2*qz1*qz3 + 2*e2*e3*qz1*qz3 & - q23*qz1*qz3 + e1*e2*tq22 & - qz1*qz2*tq22))/(2.0d0*e1*e2*e3*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {7, 6, 1, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(6,mu) qj(mu) = k(7,mu) l(mu) = k(8,mu) END DO absqi = absk(6) absqj = absk(7) absqk = absk(1) absl = absk(8) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(1) e2 = absk(7) e3 = absk(6) qz1 = + k(1,3) qz2 = + k(7,3) qz3 = + k(6,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(1,mu)*k(7,mu)*metric(mu) q13 = q13 + k(1,mu)*k(6,mu)*metric(mu) q23 = q23 + k(7,mu)*k(6,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.3) THEN ! cut = {5, 3, 2, 0}, psoft = 7 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(2,mu) qj(mu) = k(5,mu) l(mu) = k(7,mu) END DO absqi = absk(2) absqj = absk(5) absqk = absk(3) absl = absk(7) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(3) e2 = absk(5) e3 = absk(2) qz1 = - k(3,3) qz2 = + k(5,3) qz3 = + k(2,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 - k(3,mu)*k(5,mu)*metric(mu) q13 = q13 - k(3,mu)*k(2,mu)*metric(mu) q23 = q23 + k(5,mu)*k(2,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.4) THEN ! cut = {8, 6, 3, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = - k(3,mu) qj(mu) = - k(8,mu) l(mu) = k(5,mu) END DO absqi = absk(3) absqj = absk(8) absqk = absk(6) absl = absk(5) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(3) e2 = absk(8) e3 = absk(6) qz1 = - k(3,3) qz2 = - k(8,3) qz3 = + k(6,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(3,mu)*k(8,mu)*metric(mu) q13 = q13 - k(3,mu)*k(6,mu)*metric(mu) q23 = q23 - k(8,mu)*k(6,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1*e2**2*e3 - 2*e1*e2*e3**2 + e1*e2*q23 & + e1*e3*q23 + e2*e3*qz1*qz2 + e2**2*qz1*qz3 + 2*e2*e3*qz1*qz3 & - q23*qz1*qz3 + e1*e2*tq22 & - qz1*qz2*tq22))/(2.0d0*e1*e2*e3*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {8, 6, 3, 0}, psoft = 7 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(6,mu) qj(mu) = - k(8,mu) l(mu) = k(7,mu) END DO absqi = absk(6) absqj = absk(8) absqk = absk(3) absl = absk(7) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(3) e2 = absk(8) e3 = absk(6) qz1 = - k(3,3) qz2 = - k(8,3) qz3 = + k(6,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(3,mu)*k(8,mu)*metric(mu) q13 = q13 - k(3,mu)*k(6,mu)*metric(mu) q23 = q23 - k(8,mu)*k(6,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.5) THEN ! cut = {8, 7, 4, 1}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(4,mu) + k(6,mu)) qj(mu) = 0.5d0*( k(7,mu) - k(5,mu)) l(mu) = k(8,mu) END DO absl = absk(8) absqk = absk(1) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e7 = k(7,0) kz1 = k(1,3) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz7 = k(7,3) k12 = 0.0d0 k13 = 0.0d0 k14 = 0.0d0 k17 = 0.0d0 k22 = 0.0d0 k23 = 0.0d0 k24 = 0.0d0 k27 = 0.0d0 k33 = 0.0d0 k34 = 0.0d0 k37 = 0.0d0 k47 = 0.0d0 DO mu = 0,3 k12 = k12 + k(1,mu)*k(2,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k14 = k14 + k(1,mu)*k(4,mu)*metric(mu) k17 = k17 + k(1,mu)*k(7,mu)*metric(mu) k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k23 = k23 + k(2,mu)*k(3,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k33 = k33 + k(3,mu)*k(3,mu)*metric(mu) k34 = k34 + k(3,mu)*k(4,mu)*metric(mu) k37 = k37 + k(3,mu)*k(7,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (-3*cf*nc*(-2*e2*e4*e7**2*k13 + 2*e2*e3*e4*e7*k17 & + 3*e7**2*k14*k23 - 2*e4*e7*k17*k23 - 2*e1*e3*e7**2*k24 & + e7**2*k13*k24 + 2*e1*e3*e4*e7*k27 - 2*e3*e7*k14*k27 & - 3*e7**2*k12*k34 + 2*e2*e7*k17*k34 + 2*e1*e7*k27*k34 & - 2*k17*k27*k34 + 2*e1*e2*e4*e7*k37 + 2*e4*e7*k12*k37 & - 2*e2*e7*k14*k37 - 2*e1*e4*k27*k37 + 2*k14*k27*k37 & + 2*e1*e2*e3*e7*k47 + 2*e3*e7*k12*k47 - 2*e2*e3*k17*k47 & - 2*e1*e7*k23*k47 + 2*k17*k23*k47 - 2*k12*k37*k47 & - 2*e7**2*k34*kz1*kz2 + 2*e7**2*k14*kz2*kz3 - 2*e4*e7*k17*kz2*kz3 & - 2*e1*e7*k47*kz2*kz3 + 2*k17*k47*kz2*kz3 + 2*e7**2*k23*kz1*kz4 & - 2*e3*e7*k27*kz1*kz4 - 2*e2*e7*k37*kz1*kz4 + 2*k27*k37*kz1*kz4 & - 2*e7**2*k12*kz3*kz4 - e4*e7*k23*kz1*kz7 + e3*e7*k24*kz1*kz7 & + e2*e7*k34*kz1*kz7 - k27*k34*kz1*kz7 - k24*k37*kz1*kz7 & + k23*k47*kz1*kz7 + e4*e7*k13*kz2*kz7 - e3*e7*k14*kz2*kz7 & + e1*e7*k34*kz2*kz7 - k17*k34*kz2*kz7 + k14*k37*kz2*kz7 & - k13*k47*kz2*kz7 + e4*e7*k12*kz3*kz7 - e2*e7*k14*kz3*kz7 & + e1*e7*k24*kz3*kz7 - k17*k24*kz3*kz7 + k14*k27*kz3*kz7 & - k12*k47*kz3*kz7 + e3*e7*k12*kz4*kz7 + e2*e7*k13*kz4*kz7 & - e1*e7*k23*kz4*kz7 + k17*k23*kz4*kz7 - k13*k27*kz4*kz7 & - k12*k37*kz4*kz7 - k14*k23*kz7**2 + k13*k24*kz7**2 & + k12*k34*kz7**2 + 2*e3*e4*k12*tk77 - 2*e2*e4*k13*tk77 & + 2*k14*k23*tk77 - 2*e1*e3*k24*tk77 + 2*k13*k24*tk77 & + 2*e1*e2*k34*tk77 - 2*k12*k34*tk77 - 2*k34*kz1*kz2*tk77 & + 2*k24*kz1*kz3*tk77 + 2*k13*kz2*kz4*tk77 & - 2*k12*kz3*kz4*tk77))/(2.0d0*e1*e4*e7*k22*k33*tk77) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.6) THEN ! cut = {8, 6, 5, 1}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(5,mu) + k(7,mu)) qj(mu) = 0.5d0*( k(6,mu) - k(4,mu)) l(mu) = - k(8,mu) END DO absl = absk(8) absqk = absk(1) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e3 = k(3,0) e5 = k(5,0) e6 = k(6,0) kz1 = k(1,3) kz2 = k(2,3) kz3 = k(3,3) kz5 = k(5,3) kz6 = k(6,3) k12 = 0.0d0 k13 = 0.0d0 k15 = 0.0d0 k16 = 0.0d0 k22 = 0.0d0 k23 = 0.0d0 k25 = 0.0d0 k26 = 0.0d0 k33 = 0.0d0 k35 = 0.0d0 k36 = 0.0d0 k56 = 0.0d0 DO mu = 0,3 k12 = k12 + k(1,mu)*k(2,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k15 = k15 + k(1,mu)*k(5,mu)*metric(mu) k16 = k16 + k(1,mu)*k(6,mu)*metric(mu) k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k23 = k23 + k(2,mu)*k(3,mu)*metric(mu) k25 = k25 + k(2,mu)*k(5,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k33 = k33 + k(3,mu)*k(3,mu)*metric(mu) k35 = k35 + k(3,mu)*k(5,mu)*metric(mu) k36 = k36 + k(3,mu)*k(6,mu)*metric(mu) k56 = k56 + k(5,mu)*k(6,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk55 = tk55 - k(5,mu)**2 tk66 = tk66 - k(6,mu)**2 END DO ! result = (3*cf*nc*(-2*e2*e5**2*e6*k13 + 2*e2*e3*e5*e6*k15 & - 2*e5*e6*k15*k23 + 3*e5**2*k16*k23 + 2*e1*e3*e5*e6*k25 & - 2*e3*e5*k16*k25 - 2*e1*e3*e5**2*k26 + e5**2*k13*k26 & + 2*e1*e2*e5*e6*k35 + 2*e5*e6*k12*k35 - 2*e2*e5*k16*k35 & - 2*e1*e6*k25*k35 + 2*k16*k25*k35 - 3*e5**2*k12*k36 & + 2*e2*e5*k15*k36 + 2*e1*e5*k25*k36 - 2*k15*k25*k36 & + 2*e1*e2*e3*e5*k56 + 2*e3*e5*k12*k56 - 2*e2*e3*k15*k56 & - 2*e1*e5*k23*k56 + 2*k15*k23*k56 - 2*k12*k35*k56 & - 2*e5**2*k36*kz1*kz2 - 2*e5*e6*k15*kz2*kz3 + 2*e5**2*k16*kz2*kz3 & - 2*e1*e5*k56*kz2*kz3 + 2*k15*k56*kz2*kz3 - e5*e6*k23*kz1*kz5 & + e3*e5*k26*kz1*kz5 - k26*k35*kz1*kz5 + e2*e5*k36*kz1*kz5 & - k25*k36*kz1*kz5 + k23*k56*kz1*kz5 + e5*e6*k13*kz2*kz5 & - e3*e5*k16*kz2*kz5 + k16*k35*kz2*kz5 + e1*e5*k36*kz2*kz5 & - k15*k36*kz2*kz5 - k13*k56*kz2*kz5 + e5*e6*k12*kz3*kz5 & - e2*e5*k16*kz3*kz5 + k16*k25*kz3*kz5 + e1*e5*k26*kz3*kz5 & - k15*k26*kz3*kz5 - k12*k56*kz3*kz5 - k16*k23*kz5**2 & + k13*k26*kz5**2 + k12*k36*kz5**2 + 2*e5**2*k23*kz1*kz6 & - 2*e3*e5*k25*kz1*kz6 - 2*e2*e5*k35*kz1*kz6 + 2*k25*k35*kz1*kz6 & - 2*e5**2*k12*kz3*kz6 + e3*e5*k12*kz5*kz6 + e2*e5*k13*kz5*kz6 & - e1*e5*k23*kz5*kz6 + k15*k23*kz5*kz6 - k13*k25*kz5*kz6 & - k12*k35*kz5*kz6 + 2*e3*e6*k12*tk55 - 2*e2*e6*k13*tk55 & + 2*k16*k23*tk55 - 2*e1*e3*k26*tk55 + 2*k13*k26*tk55 & + 2*e1*e2*k36*tk55 - 2*k12*k36*tk55 - 2*k36*kz1*kz2*tk55 & + 2*k26*kz1*kz3*tk55 + 2*k13*kz2*kz6*tk55 & - 2*k12*kz3*kz6*tk55))/(2.0d0*e1*e5*e6*k22*k33*tk55) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {8, 6, 5, 1}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(8,mu) + k(7,mu)) qj(mu) = 0.5d0*( k(1,mu) - k(3,mu)) l(mu) = - k(5,mu) END DO absl = absk(5) absqk = absk(6) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e4 = k(4,0) e6 = k(6,0) e8 = k(8,0) kz1 = k(1,3) kz2 = k(2,3) kz4 = k(4,3) kz6 = k(6,3) kz8 = k(8,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k28 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k48 = 0.0d0 k68 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k28 = k28 + k(2,mu)*k(8,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k48 = k48 + k(4,mu)*k(8,mu)*metric(mu) k68 = k68 + k(6,mu)*k(8,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk88 = tk88 - k(8,mu)**2 END DO ! result = (3*cf*nc*(e1*e4*e8**2*k26 - e1*e4*e6*e8*k28 & + e1*e2*e8**2*k46 - e1*e2*e6*e8*k48 - 2*e1*e2*e4*e8*k68 & + e1*e4*k28*k68 + e1*e2*k48*k68 - e8**2*k46*kz1*kz2 & + e6*e8*k48*kz1*kz2 + e4*e8*k68*kz1*kz2 - k48*k68*kz1*kz2 & - e8**2*k26*kz1*kz4 + e6*e8*k28*kz1*kz4 + e2*e8*k68*kz1*kz4 & - k28*k68*kz1*kz4 + e8**2*k24*kz1*kz6 - e6*e8*k24*kz1*kz8 & + k24*k68*kz1*kz8 - e1*e6*k24*tk88 + e1*e4*k26*tk88 & + e1*e2*k46*tk88 - k46*kz1*kz2*tk88 - k26*kz1*kz4*tk88 & + k24*kz1*kz6*tk88))/(e1*e6*e8*k22*k44*tk88) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.7) THEN ! cut = {8, 7, 3, 2}, psoft = 7 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(8,mu) + k(5,mu)) qj(mu) = 0.5d0*( k(2,mu) + k(6,mu)) l(mu) = - k(7,mu) END DO absl = absk(7) absqk = absk(3) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e8 = k(8,0) kz1 = k(1,3) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz8 = k(8,3) k11 = 0.0d0 k12 = 0.0d0 k13 = 0.0d0 k14 = 0.0d0 k18 = 0.0d0 k23 = 0.0d0 k24 = 0.0d0 k28 = 0.0d0 k34 = 0.0d0 k38 = 0.0d0 k44 = 0.0d0 k48 = 0.0d0 DO mu = 0,3 k11 = k11 + k(1,mu)*k(1,mu)*metric(mu) k12 = k12 + k(1,mu)*k(2,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k14 = k14 + k(1,mu)*k(4,mu)*metric(mu) k18 = k18 + k(1,mu)*k(8,mu)*metric(mu) k23 = k23 + k(2,mu)*k(3,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k28 = k28 + k(2,mu)*k(8,mu)*metric(mu) k34 = k34 + k(3,mu)*k(4,mu)*metric(mu) k38 = k38 + k(3,mu)*k(8,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k48 = k48 + k(4,mu)*k(8,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk88 = tk88 - k(8,mu)**2 END DO ! result = (3*cf*nc*(-2*e2*e4*e8**2*k13 + 2*e2*e3*e4*e8*k18 & + 3*e8**2*k14*k23 - 2*e4*e8*k18*k23 - 2*e1*e3*e8**2*k24 & + e8**2*k13*k24 + 2*e1*e3*e4*e8*k28 - 2*e3*e8*k14*k28 & - 3*e8**2*k12*k34 + 2*e2*e8*k18*k34 + 2*e1*e8*k28*k34 & - 2*k18*k28*k34 + 2*e1*e2*e4*e8*k38 + 2*e4*e8*k12*k38 & - 2*e2*e8*k14*k38 - 2*e1*e4*k28*k38 + 2*k14*k28*k38 & + 2*e1*e2*e3*e8*k48 + 2*e3*e8*k12*k48 - 2*e2*e3*k18*k48 & - 2*e1*e8*k23*k48 + 2*k18*k23*k48 - 2*k12*k38*k48 & - 2*e8**2*k34*kz1*kz2 + 2*e8**2*k14*kz2*kz3 - 2*e4*e8*k18*kz2*kz3 & - 2*e1*e8*k48*kz2*kz3 + 2*k18*k48*kz2*kz3 + 2*e8**2*k23*kz1*kz4 & - 2*e3*e8*k28*kz1*kz4 - 2*e2*e8*k38*kz1*kz4 + 2*k28*k38*kz1*kz4 & - 2*e8**2*k12*kz3*kz4 - e4*e8*k23*kz1*kz8 + e3*e8*k24*kz1*kz8 & + e2*e8*k34*kz1*kz8 - k28*k34*kz1*kz8 - k24*k38*kz1*kz8 & + k23*k48*kz1*kz8 + e4*e8*k13*kz2*kz8 - e3*e8*k14*kz2*kz8 & + e1*e8*k34*kz2*kz8 - k18*k34*kz2*kz8 + k14*k38*kz2*kz8 & - k13*k48*kz2*kz8 + e4*e8*k12*kz3*kz8 - e2*e8*k14*kz3*kz8 & + e1*e8*k24*kz3*kz8 - k18*k24*kz3*kz8 + k14*k28*kz3*kz8 & - k12*k48*kz3*kz8 + e3*e8*k12*kz4*kz8 + e2*e8*k13*kz4*kz8 & - e1*e8*k23*kz4*kz8 + k18*k23*kz4*kz8 - k13*k28*kz4*kz8 & - k12*k38*kz4*kz8 - k14*k23*kz8**2 + k13*k24*kz8**2 & + k12*k34*kz8**2 + 2*e3*e4*k12*tk88 - 2*e2*e4*k13*tk88 & + 2*k14*k23*tk88 - 2*e1*e3*k24*tk88 + 2*k13*k24*tk88 & + 2*e1*e2*k34*tk88 - 2*k12*k34*tk88 - 2*k34*kz1*kz2*tk88 & + 2*k24*kz1*kz3*tk88 + 2*k13*kz2*kz4*tk88 & - 2*k12*kz3*kz4*tk88))/(2.0d0*e2*e3*e8*k11*k44*tk88) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.8) THEN ! cut = {7, 6, 5, 3}, psoft = 7 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*(k(6,mu) + k(2,mu)) qj(mu) = 0.5d0*( k(5,mu) - k(8,mu)) l(mu) = k(7,mu) END DO absl = absk(7) absqk = absk(3) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e3 = k(3,0) e4 = k(4,0) e5 = k(5,0) e6 = k(6,0) kz1 = k(1,3) kz3 = k(3,3) kz4 = k(4,3) kz5 = k(5,3) kz6 = k(6,3) k11 = 0.0d0 k13 = 0.0d0 k14 = 0.0d0 k15 = 0.0d0 k16 = 0.0d0 k34 = 0.0d0 k35 = 0.0d0 k36 = 0.0d0 k44 = 0.0d0 k45 = 0.0d0 k46 = 0.0d0 k56 = 0.0d0 DO mu = 0,3 k11 = k11 + k(1,mu)*k(1,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k14 = k14 + k(1,mu)*k(4,mu)*metric(mu) k15 = k15 + k(1,mu)*k(5,mu)*metric(mu) k16 = k16 + k(1,mu)*k(6,mu)*metric(mu) k34 = k34 + k(3,mu)*k(4,mu)*metric(mu) k35 = k35 + k(3,mu)*k(5,mu)*metric(mu) k36 = k36 + k(3,mu)*k(6,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k45 = k45 + k(4,mu)*k(5,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k56 = k56 + k(5,mu)*k(6,mu)*metric(mu) END DO tk11 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk55 = tk55 - k(5,mu)**2 tk66 = tk66 - k(6,mu)**2 END DO ! result = (-3*cf*nc*(-2*e4*e5**2*e6*k13 + 2*e3*e4*e5*e6*k15 & + 2*e5*e6*k15*k34 - 3*e5**2*k16*k34 + 2*e1*e4*e5*e6*k35 & - 2*e5*e6*k14*k35 + 2*e4*e5*k16*k35 + 3*e5**2*k14*k36 & - 2*e4*e5*k15*k36 + 2*e1*e3*e5*e6*k45 - 2*e3*e6*k15*k45 & + 2*e3*e5*k16*k45 - 2*k16*k35*k45 - 2*e1*e5*k36*k45 & + 2*k15*k36*k45 - 2*e1*e3*e5**2*k46 + e5**2*k13*k46 & + 2*e1*e3*e4*e5*k56 - 2*e3*e5*k14*k56 + 2*e1*e5*k34*k56 & - 2*k15*k34*k56 - 2*e1*e4*k35*k56 + 2*k14*k35*k56 & - 2*e5*e6*k35*kz1*kz4 + 2*e5**2*k36*kz1*kz4 - 2*e3*e5*k56*kz1*kz4 & + 2*k35*k56*kz1*kz4 - 2*e5**2*k16*kz3*kz4 + e5*e6*k34*kz1*kz5 & - e4*e5*k36*kz1*kz5 + k36*k45*kz1*kz5 + e3*e5*k46*kz1*kz5 & - k35*k46*kz1*kz5 - k34*k56*kz1*kz5 - e5*e6*k14*kz3*kz5 & + e4*e5*k16*kz3*kz5 - k16*k45*kz3*kz5 + e1*e5*k46*kz3*kz5 & - k15*k46*kz3*kz5 + k14*k56*kz3*kz5 + e5*e6*k13*kz4*kz5 & + e3*e5*k16*kz4*kz5 - k16*k35*kz4*kz5 - e1*e5*k36*kz4*kz5 & + k15*k36*kz4*kz5 - k13*k56*kz4*kz5 + k16*k34*kz5**2 & - k14*k36*kz5**2 + k13*k46*kz5**2 - 2*e5**2*k34*kz1*kz6 & + 2*e5**2*k14*kz3*kz6 - 2*e4*e5*k15*kz3*kz6 - 2*e1*e5*k45*kz3*kz6 & + 2*k15*k45*kz3*kz6 + e4*e5*k13*kz5*kz6 - e3*e5*k14*kz5*kz6 & + e1*e5*k34*kz5*kz6 - k15*k34*kz5*kz6 + k14*k35*kz5*kz6 & - k13*k45*kz5*kz6 - 2*e4*e6*k13*tk55 + 2*e3*e4*k16*tk55 & + 2*e1*e6*k34*tk55 - 2*k16*k34*tk55 + 2*k14*k36*tk55 & - 2*e1*e3*k46*tk55 + 2*k13*k46*tk55 + 2*k46*kz1*kz3*tk55 & - 2*k16*kz3*kz4*tk55 - 2*k34*kz1*kz6*tk55 & + 2*k13*kz4*kz6*tk55))/(2.0d0*e3*e5*e6*k11*k44*tk55) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {7, 6, 5, 3}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(3,mu) + k(1,mu)) qj(mu) = 0.5d0*( k(7,mu) - k(8,mu)) l(mu) = k(5,mu) END DO absl = absk(5) absqk = absk(6) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e6 = k(6,0) e7 = k(7,0) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz6 = k(6,3) kz7 = k(7,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k27 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k47 = 0.0d0 k67 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) k67 = k67 + k(6,mu)*k(7,mu)*metric(mu) END DO tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (-3*cf*nc*(e3*e4*e7**2*k26 - e3*e4*e6*e7*k27 & + e2*e3*e7**2*k46 - e2*e3*e6*e7*k47 - 2*e2*e3*e4*e7*k67 & + e3*e4*k27*k67 + e2*e3*k47*k67 - e7**2*k46*kz2*kz3 & + e6*e7*k47*kz2*kz3 + e4*e7*k67*kz2*kz3 - k47*k67*kz2*kz3 & - e7**2*k26*kz3*kz4 + e6*e7*k27*kz3*kz4 + e2*e7*k67*kz3*kz4 & - k27*k67*kz3*kz4 + e7**2*k24*kz3*kz6 - e6*e7*k24*kz3*kz7 & + k24*k67*kz3*kz7 - e3*e6*k24*tk77 + e3*e4*k26*tk77 & + e2*e3*k46*tk77 - k46*kz2*kz3*tk77 - k26*kz3*kz4*tk77 & + k24*kz3*kz6*tk77))/(e3*e6*e7*k22*k44*tk77) result = result*softfactor softsubtraction = softsubtraction - result ! ! Close IF (cutnumber.EQ....) THEN ! END IF ! ELSE IF (flavorsetnumber.EQ.2) THEN ! Flavors = {quark, qbar, qbar, quark, gluon, gluon, qbar, quark} ! IF (cutnumber.EQ.2) THEN ! cut = {7, 6, 1, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(1,mu) qj(mu) = k(7,mu) l(mu) = k(5,mu) END DO absqi = absk(1) absqj = absk(7) absqk = absk(6) absl = absk(5) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = 0.5d0/nc ! for q-barq call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(1) e2 = absk(6) e3 = absk(7) qz1 = + k(1,3) qz2 = + k(6,3) qz3 = + k(7,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(1,mu)*k(6,mu)*metric(mu) q13 = q13 + k(1,mu)*k(7,mu)*metric(mu) q23 = q23 + k(6,mu)*k(7,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1*e2**2*e3 - 2*e1*e2*e3**2 + e1*e2*q23 & + e1*e3*q23 + e2*e3*qz1*qz2 + e2**2*qz1*qz3 + 2*e2*e3*qz1*qz3 & - q23*qz1*qz3 + e1*e2*tq22 & - qz1*qz2*tq22))/(2.0d0*e1*e2*e3*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.4) THEN ! cut = {8, 6, 3, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = - k(3,mu) qj(mu) = - k(8,mu) l(mu) = k(5,mu) END DO absqi = absk(3) absqj = absk(8) absqk = absk(6) absl = absk(5) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = 0.5d0/nc ! for q-barq call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(3) e2 = absk(6) e3 = absk(8) qz1 = - k(3,3) qz2 = + k(6,3) qz3 = - k(8,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 - k(3,mu)*k(6,mu)*metric(mu) q13 = q13 + k(3,mu)*k(8,mu)*metric(mu) q23 = q23 - k(6,mu)*k(8,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1*e2**2*e3 - 2*e1*e2*e3**2 + e1*e2*q23 & + e1*e3*q23 + e2*e3*qz1*qz2 + e2**2*qz1*qz3 + 2*e2*e3*qz1*qz3 & - q23*qz1*qz3 + e1*e2*tq22 & - qz1*qz2*tq22))/(2.0d0*e1*e2*e3*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.6) THEN ! cut = {8, 6, 5, 1}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(8,mu) + k(7,mu)) qj(mu) = 0.5d0*( k(1,mu) - k(3,mu)) l(mu) = - k(5,mu) END DO absl = absk(5) absqk = absk(6) colorfactor = 0.5d0/nc ! for q-barq call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e4 = k(4,0) e6 = k(6,0) e8 = k(8,0) kz1 = k(1,3) kz2 = k(2,3) kz4 = k(4,3) kz6 = k(6,3) kz8 = k(8,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k28 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k48 = 0.0d0 k68 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k28 = k28 + k(2,mu)*k(8,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k48 = k48 + k(4,mu)*k(8,mu)*metric(mu) k68 = k68 + k(6,mu)*k(8,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk88 = tk88 - k(8,mu)**2 END DO ! result = (3*cf*nc*(e1*e4*e6*e8*k26 - e1*e4*e6**2*k28 & + e1*e2*e6*e8*k46 - e1*e2*e6**2*k48 + 2*e1*e2*e4*e6*k68 & - e1*e4*k26*k68 - e1*e2*k46*k68 - e6*e8*k46*kz1*kz2 & + e6**2*k48*kz1*kz2 - e4*e6*k68*kz1*kz2 + k46*k68*kz1*kz2 & - e6*e8*k26*kz1*kz4 + e6**2*k28*kz1*kz4 - e2*e6*k68*kz1*kz4 & + k26*k68*kz1*kz4 + e6*e8*k24*kz1*kz6 - k24*k68*kz1*kz6 & - e6**2*k24*kz1*kz8 + e1*e8*k24*tk66 - e1*e4*k28*tk66 & - e1*e2*k48*tk66 + k48*kz1*kz2*tk66 + k28*kz1*kz4*tk66 & - k24*kz1*kz8*tk66))/(e1*e6*e8*k22*k44*tk66) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.8) THEN ! cut = {7, 6, 5, 3}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(3,mu) + k(1,mu)) qj(mu) = 0.5d0*( k(7,mu) - k(8,mu)) l(mu) = k(5,mu) END DO absl = absk(5) absqk = absk(6) colorfactor = 0.5d0/nc ! for q-barq call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e6 = k(6,0) e7 = k(7,0) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz6 = k(6,3) kz7 = k(7,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k27 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k47 = 0.0d0 k67 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) k67 = k67 + k(6,mu)*k(7,mu)*metric(mu) END DO tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (3*cf*nc*(e3*e4*e6*e7*k26 - e3*e4*e6**2*k27 & + e2*e3*e6*e7*k46 - e2*e3*e6**2*k47 + 2*e2*e3*e4*e6*k67 & - e3*e4*k26*k67 - e2*e3*k46*k67 - e6*e7*k46*kz2*kz3 & + e6**2*k47*kz2*kz3 - e4*e6*k67*kz2*kz3 + k46*k67*kz2*kz3 & - e6*e7*k26*kz3*kz4 + e6**2*k27*kz3*kz4 - e2*e6*k67*kz3*kz4 & + k26*k67*kz3*kz4 + e6*e7*k24*kz3*kz6 - k24*k67*kz3*kz6 & - e6**2*k24*kz3*kz7 + e3*e7*k24*tk66 - e3*e4*k27*tk66 & - e2*e3*k47*tk66 + k47*kz2*kz3*tk66 + k27*kz3*kz4*tk66 & - k24*kz3*kz7*tk66))/(e3*e6*e7*k22*k44*tk66) result = result*softfactor softsubtraction = softsubtraction - result ! ! Close IF (cutnumber.EQ....) THEN ! END IF ! ELSE IF (flavorsetnumber.EQ.3) THEN ! Flavors = {qbar, quark, quark, qbar, gluon, quark, gluon, gluon} ! IF (cutnumber.EQ.1) THEN ! cut = {5, 4, 1, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = - k(4,mu) qj(mu) = - k(5,mu) l(mu) = k(8,mu) END DO absqi = absk(4) absqj = absk(5) absqk = absk(1) absl = absk(8) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(4) e2 = absk(5) e3 = absk(1) qz1 = - k(4,3) qz2 = - k(5,3) qz3 = + k(1,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(4,mu)*k(5,mu)*metric(mu) q13 = q13 - k(4,mu)*k(1,mu)*metric(mu) q23 = q23 - k(5,mu)*k(1,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.2) THEN ! cut = {7, 6, 1, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(1,mu) qj(mu) = k(7,mu) l(mu) = k(5,mu) END DO absqi = absk(1) absqj = absk(7) absqk = absk(6) absl = absk(5) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(6) e2 = absk(7) e3 = absk(1) qz1 = + k(6,3) qz2 = + k(7,3) qz3 = + k(1,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(6,mu)*k(7,mu)*metric(mu) q13 = q13 + k(6,mu)*k(1,mu)*metric(mu) q23 = q23 + k(7,mu)*k(1,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1**2*e2*e3 - 2*e1*e2**2*e3 + e1*e3*q12 & + e2*e3*q12 + 2*e1*e2*qz1*qz3 + e2**2*qz1*qz3 - q12*qz1*qz3 & + e1*e2*qz2*qz3 + e2*e3*tq22 & - qz2*qz3*tq22))/(2.0d0*e1*e2*e3*q12*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {7, 6, 1, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(6,mu) qj(mu) = k(7,mu) l(mu) = k(8,mu) END DO absqi = absk(6) absqj = absk(7) absqk = absk(1) absl = absk(8) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(6) e2 = absk(7) e3 = absk(1) qz1 = + k(6,3) qz2 = + k(7,3) qz3 = + k(1,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(6,mu)*k(7,mu)*metric(mu) q13 = q13 + k(6,mu)*k(1,mu)*metric(mu) q23 = q23 + k(7,mu)*k(1,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.3) THEN ! cut = {5, 3, 2, 0}, psoft = 7 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(2,mu) qj(mu) = k(5,mu) l(mu) = k(7,mu) END DO absqi = absk(2) absqj = absk(5) absqk = absk(3) absl = absk(7) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(2) e2 = absk(5) e3 = absk(3) qz1 = + k(2,3) qz2 = + k(5,3) qz3 = - k(3,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(2,mu)*k(5,mu)*metric(mu) q13 = q13 - k(2,mu)*k(3,mu)*metric(mu) q23 = q23 - k(5,mu)*k(3,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.4) THEN ! cut = {8, 6, 3, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = - k(3,mu) qj(mu) = - k(8,mu) l(mu) = k(5,mu) END DO absqi = absk(3) absqj = absk(8) absqk = absk(6) absl = absk(5) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(6) e2 = absk(8) e3 = absk(3) qz1 = + k(6,3) qz2 = - k(8,3) qz3 = - k(3,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 - k(6,mu)*k(8,mu)*metric(mu) q13 = q13 - k(6,mu)*k(3,mu)*metric(mu) q23 = q23 + k(8,mu)*k(3,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1**2*e2*e3 - 2*e1*e2**2*e3 + e1*e3*q12 & + e2*e3*q12 + 2*e1*e2*qz1*qz3 + e2**2*qz1*qz3 - q12*qz1*qz3 & + e1*e2*qz2*qz3 + e2*e3*tq22 & - qz2*qz3*tq22))/(2.0d0*e1*e2*e3*q12*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {8, 6, 3, 0}, psoft = 7 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(6,mu) qj(mu) = - k(8,mu) l(mu) = k(7,mu) END DO absqi = absk(6) absqj = absk(8) absqk = absk(3) absl = absk(7) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = - 0.5d0*nc ! for q-g or qbar-g call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(6) e2 = absk(8) e3 = absk(3) qz1 = + k(6,3) qz2 = - k(8,3) qz3 = - k(3,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 - k(6,mu)*k(8,mu)*metric(mu) q13 = q13 - k(6,mu)*k(3,mu)*metric(mu) q23 = q23 + k(8,mu)*k(3,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.5) THEN ! cut = {8, 7, 4, 1}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(4,mu) + k(6,mu)) qj(mu) = 0.5d0*( k(7,mu) - k(5,mu)) l(mu) = k(8,mu) END DO absl = absk(8) absqk = absk(1) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e7 = k(7,0) kz1 = k(1,3) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz7 = k(7,3) k12 = 0.0d0 k13 = 0.0d0 k14 = 0.0d0 k17 = 0.0d0 k22 = 0.0d0 k23 = 0.0d0 k24 = 0.0d0 k27 = 0.0d0 k33 = 0.0d0 k34 = 0.0d0 k37 = 0.0d0 k47 = 0.0d0 DO mu = 0,3 k12 = k12 + k(1,mu)*k(2,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k14 = k14 + k(1,mu)*k(4,mu)*metric(mu) k17 = k17 + k(1,mu)*k(7,mu)*metric(mu) k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k23 = k23 + k(2,mu)*k(3,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k33 = k33 + k(3,mu)*k(3,mu)*metric(mu) k34 = k34 + k(3,mu)*k(4,mu)*metric(mu) k37 = k37 + k(3,mu)*k(7,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (-3*cf*nc*(-2*e2*e4*e7**2*k13 + 2*e2*e3*e4*e7*k17 & + 3*e7**2*k14*k23 - 2*e4*e7*k17*k23 - 2*e1*e3*e7**2*k24 & + e7**2*k13*k24 + 2*e1*e3*e4*e7*k27 - 2*e3*e7*k14*k27 & - 3*e7**2*k12*k34 + 2*e2*e7*k17*k34 + 2*e1*e7*k27*k34 & - 2*k17*k27*k34 + 2*e1*e2*e4*e7*k37 + 2*e4*e7*k12*k37 & - 2*e2*e7*k14*k37 - 2*e1*e4*k27*k37 + 2*k14*k27*k37 & + 2*e1*e2*e3*e7*k47 + 2*e3*e7*k12*k47 - 2*e2*e3*k17*k47 & - 2*e1*e7*k23*k47 + 2*k17*k23*k47 - 2*k12*k37*k47 & - 2*e7**2*k34*kz1*kz2 + 2*e7**2*k14*kz2*kz3 - 2*e4*e7*k17*kz2*kz3 & - 2*e1*e7*k47*kz2*kz3 + 2*k17*k47*kz2*kz3 + 2*e7**2*k23*kz1*kz4 & - 2*e3*e7*k27*kz1*kz4 - 2*e2*e7*k37*kz1*kz4 + 2*k27*k37*kz1*kz4 & - 2*e7**2*k12*kz3*kz4 - e4*e7*k23*kz1*kz7 + e3*e7*k24*kz1*kz7 & + e2*e7*k34*kz1*kz7 - k27*k34*kz1*kz7 - k24*k37*kz1*kz7 & + k23*k47*kz1*kz7 + e4*e7*k13*kz2*kz7 - e3*e7*k14*kz2*kz7 & + e1*e7*k34*kz2*kz7 - k17*k34*kz2*kz7 + k14*k37*kz2*kz7 & - k13*k47*kz2*kz7 + e4*e7*k12*kz3*kz7 - e2*e7*k14*kz3*kz7 & + e1*e7*k24*kz3*kz7 - k17*k24*kz3*kz7 + k14*k27*kz3*kz7 & - k12*k47*kz3*kz7 + e3*e7*k12*kz4*kz7 + e2*e7*k13*kz4*kz7 & - e1*e7*k23*kz4*kz7 + k17*k23*kz4*kz7 - k13*k27*kz4*kz7 & - k12*k37*kz4*kz7 - k14*k23*kz7**2 + k13*k24*kz7**2 & + k12*k34*kz7**2 + 2*e3*e4*k12*tk77 - 2*e2*e4*k13*tk77 & + 2*k14*k23*tk77 - 2*e1*e3*k24*tk77 + 2*k13*k24*tk77 & + 2*e1*e2*k34*tk77 - 2*k12*k34*tk77 - 2*k34*kz1*kz2*tk77 & + 2*k24*kz1*kz3*tk77 + 2*k13*kz2*kz4*tk77 & - 2*k12*kz3*kz4*tk77))/(2.0d0*e1*e4*e7*k22*k33*tk77) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.6) THEN ! cut = {8, 6, 5, 1}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(5,mu) + k(7,mu)) qj(mu) = 0.5d0*( k(6,mu) - k(4,mu)) l(mu) = - k(8,mu) END DO absl = absk(8) absqk = absk(1) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e3 = k(3,0) e5 = k(5,0) e6 = k(6,0) kz1 = k(1,3) kz2 = k(2,3) kz3 = k(3,3) kz5 = k(5,3) kz6 = k(6,3) k12 = 0.0d0 k13 = 0.0d0 k15 = 0.0d0 k16 = 0.0d0 k22 = 0.0d0 k23 = 0.0d0 k25 = 0.0d0 k26 = 0.0d0 k33 = 0.0d0 k35 = 0.0d0 k36 = 0.0d0 k56 = 0.0d0 DO mu = 0,3 k12 = k12 + k(1,mu)*k(2,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k15 = k15 + k(1,mu)*k(5,mu)*metric(mu) k16 = k16 + k(1,mu)*k(6,mu)*metric(mu) k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k23 = k23 + k(2,mu)*k(3,mu)*metric(mu) k25 = k25 + k(2,mu)*k(5,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k33 = k33 + k(3,mu)*k(3,mu)*metric(mu) k35 = k35 + k(3,mu)*k(5,mu)*metric(mu) k36 = k36 + k(3,mu)*k(6,mu)*metric(mu) k56 = k56 + k(5,mu)*k(6,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk55 = tk55 - k(5,mu)**2 tk66 = tk66 - k(6,mu)**2 END DO ! result = (3*cf*nc*(-2*e2*e5**2*e6*k13 + 2*e2*e3*e5*e6*k15 & - 2*e5*e6*k15*k23 + 3*e5**2*k16*k23 + 2*e1*e3*e5*e6*k25 & - 2*e3*e5*k16*k25 - 2*e1*e3*e5**2*k26 + e5**2*k13*k26 & + 2*e1*e2*e5*e6*k35 + 2*e5*e6*k12*k35 - 2*e2*e5*k16*k35 & - 2*e1*e6*k25*k35 + 2*k16*k25*k35 - 3*e5**2*k12*k36 & + 2*e2*e5*k15*k36 + 2*e1*e5*k25*k36 - 2*k15*k25*k36 & + 2*e1*e2*e3*e5*k56 + 2*e3*e5*k12*k56 - 2*e2*e3*k15*k56 & - 2*e1*e5*k23*k56 + 2*k15*k23*k56 - 2*k12*k35*k56 & - 2*e5**2*k36*kz1*kz2 - 2*e5*e6*k15*kz2*kz3 + 2*e5**2*k16*kz2*kz3 & - 2*e1*e5*k56*kz2*kz3 + 2*k15*k56*kz2*kz3 - e5*e6*k23*kz1*kz5 & + e3*e5*k26*kz1*kz5 - k26*k35*kz1*kz5 + e2*e5*k36*kz1*kz5 & - k25*k36*kz1*kz5 + k23*k56*kz1*kz5 + e5*e6*k13*kz2*kz5 & - e3*e5*k16*kz2*kz5 + k16*k35*kz2*kz5 + e1*e5*k36*kz2*kz5 & - k15*k36*kz2*kz5 - k13*k56*kz2*kz5 + e5*e6*k12*kz3*kz5 & - e2*e5*k16*kz3*kz5 + k16*k25*kz3*kz5 + e1*e5*k26*kz3*kz5 & - k15*k26*kz3*kz5 - k12*k56*kz3*kz5 - k16*k23*kz5**2 & + k13*k26*kz5**2 + k12*k36*kz5**2 + 2*e5**2*k23*kz1*kz6 & - 2*e3*e5*k25*kz1*kz6 - 2*e2*e5*k35*kz1*kz6 + 2*k25*k35*kz1*kz6 & - 2*e5**2*k12*kz3*kz6 + e3*e5*k12*kz5*kz6 + e2*e5*k13*kz5*kz6 & - e1*e5*k23*kz5*kz6 + k15*k23*kz5*kz6 - k13*k25*kz5*kz6 & - k12*k35*kz5*kz6 + 2*e3*e6*k12*tk55 - 2*e2*e6*k13*tk55 & + 2*k16*k23*tk55 - 2*e1*e3*k26*tk55 + 2*k13*k26*tk55 & + 2*e1*e2*k36*tk55 - 2*k12*k36*tk55 - 2*k36*kz1*kz2*tk55 & + 2*k26*kz1*kz3*tk55 + 2*k13*kz2*kz6*tk55 & - 2*k12*kz3*kz6*tk55))/(2.0d0*e1*e5*e6*k22*k33*tk55) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {8, 6, 5, 1}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(8,mu) + k(7,mu)) qj(mu) = 0.5d0*( k(1,mu) - k(3,mu)) l(mu) = - k(5,mu) END DO absl = absk(5) absqk = absk(6) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e4 = k(4,0) e6 = k(6,0) e8 = k(8,0) kz1 = k(1,3) kz2 = k(2,3) kz4 = k(4,3) kz6 = k(6,3) kz8 = k(8,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k28 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k48 = 0.0d0 k68 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k28 = k28 + k(2,mu)*k(8,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k48 = k48 + k(4,mu)*k(8,mu)*metric(mu) k68 = k68 + k(6,mu)*k(8,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk88 = tk88 - k(8,mu)**2 END DO ! result = (3*cf*nc*(e1*e4*e8**2*k26 - e1*e4*e6*e8*k28 & + e1*e2*e8**2*k46 - e1*e2*e6*e8*k48 - 2*e1*e2*e4*e8*k68 & + e1*e4*k28*k68 + e1*e2*k48*k68 - e8**2*k46*kz1*kz2 & + e6*e8*k48*kz1*kz2 + e4*e8*k68*kz1*kz2 - k48*k68*kz1*kz2 & - e8**2*k26*kz1*kz4 + e6*e8*k28*kz1*kz4 + e2*e8*k68*kz1*kz4 & - k28*k68*kz1*kz4 + e8**2*k24*kz1*kz6 - e6*e8*k24*kz1*kz8 & + k24*k68*kz1*kz8 - e1*e6*k24*tk88 + e1*e4*k26*tk88 & + e1*e2*k46*tk88 - k46*kz1*kz2*tk88 - k26*kz1*kz4*tk88 & + k24*kz1*kz6*tk88))/(e1*e6*e8*k22*k44*tk88) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.7) THEN ! cut = {8, 7, 3, 2}, psoft = 7 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(8,mu) + k(5,mu)) qj(mu) = 0.5d0*( k(2,mu) + k(6,mu)) l(mu) = - k(7,mu) END DO absl = absk(7) absqk = absk(3) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e8 = k(8,0) kz1 = k(1,3) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz8 = k(8,3) k11 = 0.0d0 k12 = 0.0d0 k13 = 0.0d0 k14 = 0.0d0 k18 = 0.0d0 k23 = 0.0d0 k24 = 0.0d0 k28 = 0.0d0 k34 = 0.0d0 k38 = 0.0d0 k44 = 0.0d0 k48 = 0.0d0 DO mu = 0,3 k11 = k11 + k(1,mu)*k(1,mu)*metric(mu) k12 = k12 + k(1,mu)*k(2,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k14 = k14 + k(1,mu)*k(4,mu)*metric(mu) k18 = k18 + k(1,mu)*k(8,mu)*metric(mu) k23 = k23 + k(2,mu)*k(3,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k28 = k28 + k(2,mu)*k(8,mu)*metric(mu) k34 = k34 + k(3,mu)*k(4,mu)*metric(mu) k38 = k38 + k(3,mu)*k(8,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k48 = k48 + k(4,mu)*k(8,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk88 = tk88 - k(8,mu)**2 END DO ! result = (3*cf*nc*(-2*e2*e4*e8**2*k13 + 2*e2*e3*e4*e8*k18 & + 3*e8**2*k14*k23 - 2*e4*e8*k18*k23 - 2*e1*e3*e8**2*k24 & + e8**2*k13*k24 + 2*e1*e3*e4*e8*k28 - 2*e3*e8*k14*k28 & - 3*e8**2*k12*k34 + 2*e2*e8*k18*k34 + 2*e1*e8*k28*k34 & - 2*k18*k28*k34 + 2*e1*e2*e4*e8*k38 + 2*e4*e8*k12*k38 & - 2*e2*e8*k14*k38 - 2*e1*e4*k28*k38 + 2*k14*k28*k38 & + 2*e1*e2*e3*e8*k48 + 2*e3*e8*k12*k48 - 2*e2*e3*k18*k48 & - 2*e1*e8*k23*k48 + 2*k18*k23*k48 - 2*k12*k38*k48 & - 2*e8**2*k34*kz1*kz2 + 2*e8**2*k14*kz2*kz3 - 2*e4*e8*k18*kz2*kz3 & - 2*e1*e8*k48*kz2*kz3 + 2*k18*k48*kz2*kz3 + 2*e8**2*k23*kz1*kz4 & - 2*e3*e8*k28*kz1*kz4 - 2*e2*e8*k38*kz1*kz4 + 2*k28*k38*kz1*kz4 & - 2*e8**2*k12*kz3*kz4 - e4*e8*k23*kz1*kz8 + e3*e8*k24*kz1*kz8 & + e2*e8*k34*kz1*kz8 - k28*k34*kz1*kz8 - k24*k38*kz1*kz8 & + k23*k48*kz1*kz8 + e4*e8*k13*kz2*kz8 - e3*e8*k14*kz2*kz8 & + e1*e8*k34*kz2*kz8 - k18*k34*kz2*kz8 + k14*k38*kz2*kz8 & - k13*k48*kz2*kz8 + e4*e8*k12*kz3*kz8 - e2*e8*k14*kz3*kz8 & + e1*e8*k24*kz3*kz8 - k18*k24*kz3*kz8 + k14*k28*kz3*kz8 & - k12*k48*kz3*kz8 + e3*e8*k12*kz4*kz8 + e2*e8*k13*kz4*kz8 & - e1*e8*k23*kz4*kz8 + k18*k23*kz4*kz8 - k13*k28*kz4*kz8 & - k12*k38*kz4*kz8 - k14*k23*kz8**2 + k13*k24*kz8**2 & + k12*k34*kz8**2 + 2*e3*e4*k12*tk88 - 2*e2*e4*k13*tk88 & + 2*k14*k23*tk88 - 2*e1*e3*k24*tk88 + 2*k13*k24*tk88 & + 2*e1*e2*k34*tk88 - 2*k12*k34*tk88 - 2*k34*kz1*kz2*tk88 & + 2*k24*kz1*kz3*tk88 + 2*k13*kz2*kz4*tk88 & - 2*k12*kz3*kz4*tk88))/(2.0d0*e2*e3*e8*k11*k44*tk88) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.8) THEN ! cut = {7, 6, 5, 3}, psoft = 7 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*(k(6,mu) + k(2,mu)) qj(mu) = 0.5d0*( k(5,mu) - k(8,mu)) l(mu) = k(7,mu) END DO absl = absk(7) absqk = absk(3) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e3 = k(3,0) e4 = k(4,0) e5 = k(5,0) e6 = k(6,0) kz1 = k(1,3) kz3 = k(3,3) kz4 = k(4,3) kz5 = k(5,3) kz6 = k(6,3) k11 = 0.0d0 k13 = 0.0d0 k14 = 0.0d0 k15 = 0.0d0 k16 = 0.0d0 k34 = 0.0d0 k35 = 0.0d0 k36 = 0.0d0 k44 = 0.0d0 k45 = 0.0d0 k46 = 0.0d0 k56 = 0.0d0 DO mu = 0,3 k11 = k11 + k(1,mu)*k(1,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k14 = k14 + k(1,mu)*k(4,mu)*metric(mu) k15 = k15 + k(1,mu)*k(5,mu)*metric(mu) k16 = k16 + k(1,mu)*k(6,mu)*metric(mu) k34 = k34 + k(3,mu)*k(4,mu)*metric(mu) k35 = k35 + k(3,mu)*k(5,mu)*metric(mu) k36 = k36 + k(3,mu)*k(6,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k45 = k45 + k(4,mu)*k(5,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k56 = k56 + k(5,mu)*k(6,mu)*metric(mu) END DO tk11 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk55 = tk55 - k(5,mu)**2 tk66 = tk66 - k(6,mu)**2 END DO ! result = (-3*cf*nc*(-2*e4*e5**2*e6*k13 + 2*e3*e4*e5*e6*k15 & + 2*e5*e6*k15*k34 - 3*e5**2*k16*k34 + 2*e1*e4*e5*e6*k35 & - 2*e5*e6*k14*k35 + 2*e4*e5*k16*k35 + 3*e5**2*k14*k36 & - 2*e4*e5*k15*k36 + 2*e1*e3*e5*e6*k45 - 2*e3*e6*k15*k45 & + 2*e3*e5*k16*k45 - 2*k16*k35*k45 - 2*e1*e5*k36*k45 & + 2*k15*k36*k45 - 2*e1*e3*e5**2*k46 + e5**2*k13*k46 & + 2*e1*e3*e4*e5*k56 - 2*e3*e5*k14*k56 + 2*e1*e5*k34*k56 & - 2*k15*k34*k56 - 2*e1*e4*k35*k56 + 2*k14*k35*k56 & - 2*e5*e6*k35*kz1*kz4 + 2*e5**2*k36*kz1*kz4 - 2*e3*e5*k56*kz1*kz4 & + 2*k35*k56*kz1*kz4 - 2*e5**2*k16*kz3*kz4 + e5*e6*k34*kz1*kz5 & - e4*e5*k36*kz1*kz5 + k36*k45*kz1*kz5 + e3*e5*k46*kz1*kz5 & - k35*k46*kz1*kz5 - k34*k56*kz1*kz5 - e5*e6*k14*kz3*kz5 & + e4*e5*k16*kz3*kz5 - k16*k45*kz3*kz5 + e1*e5*k46*kz3*kz5 & - k15*k46*kz3*kz5 + k14*k56*kz3*kz5 + e5*e6*k13*kz4*kz5 & + e3*e5*k16*kz4*kz5 - k16*k35*kz4*kz5 - e1*e5*k36*kz4*kz5 & + k15*k36*kz4*kz5 - k13*k56*kz4*kz5 + k16*k34*kz5**2 & - k14*k36*kz5**2 + k13*k46*kz5**2 - 2*e5**2*k34*kz1*kz6 & + 2*e5**2*k14*kz3*kz6 - 2*e4*e5*k15*kz3*kz6 - 2*e1*e5*k45*kz3*kz6 & + 2*k15*k45*kz3*kz6 + e4*e5*k13*kz5*kz6 - e3*e5*k14*kz5*kz6 & + e1*e5*k34*kz5*kz6 - k15*k34*kz5*kz6 + k14*k35*kz5*kz6 & - k13*k45*kz5*kz6 - 2*e4*e6*k13*tk55 + 2*e3*e4*k16*tk55 & + 2*e1*e6*k34*tk55 - 2*k16*k34*tk55 + 2*k14*k36*tk55 & - 2*e1*e3*k46*tk55 + 2*k13*k46*tk55 + 2*k46*kz1*kz3*tk55 & - 2*k16*kz3*kz4*tk55 - 2*k34*kz1*kz6*tk55 & + 2*k13*kz4*kz6*tk55))/(2.0d0*e3*e5*e6*k11*k44*tk55) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {7, 6, 5, 3}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(3,mu) + k(1,mu)) qj(mu) = 0.5d0*( k(7,mu) - k(8,mu)) l(mu) = k(5,mu) END DO absl = absk(5) absqk = absk(6) colorfactor = - 0.5d0*nc ! for q-g or qbar-g call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e6 = k(6,0) e7 = k(7,0) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz6 = k(6,3) kz7 = k(7,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k27 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k47 = 0.0d0 k67 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) k67 = k67 + k(6,mu)*k(7,mu)*metric(mu) END DO tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (-3*cf*nc*(e3*e4*e7**2*k26 - e3*e4*e6*e7*k27 & + e2*e3*e7**2*k46 - e2*e3*e6*e7*k47 - 2*e2*e3*e4*e7*k67 & + e3*e4*k27*k67 + e2*e3*k47*k67 - e7**2*k46*kz2*kz3 & + e6*e7*k47*kz2*kz3 + e4*e7*k67*kz2*kz3 - k47*k67*kz2*kz3 & - e7**2*k26*kz3*kz4 + e6*e7*k27*kz3*kz4 + e2*e7*k67*kz3*kz4 & - k27*k67*kz3*kz4 + e7**2*k24*kz3*kz6 - e6*e7*k24*kz3*kz7 & + k24*k67*kz3*kz7 - e3*e6*k24*tk77 + e3*e4*k26*tk77 & + e2*e3*k46*tk77 - k46*kz2*kz3*tk77 - k26*kz3*kz4*tk77 & + k24*kz3*kz6*tk77))/(e3*e6*e7*k22*k44*tk77) result = result*softfactor softsubtraction = softsubtraction - result ! ! Close IF (cutnumber.EQ....) THEN ! END IF ! ELSE IF (flavorsetnumber.EQ.4) THEN ! Flavors = {qbar, quark, quark, qbar, gluon, gluon, quark, qbar} ! IF (cutnumber.EQ.2) THEN ! cut = {7, 6, 1, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(1,mu) qj(mu) = k(7,mu) l(mu) = k(5,mu) END DO absqi = absk(1) absqj = absk(7) absqk = absk(6) absl = absk(5) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = 0.5d0/nc ! for q-barq call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(7) e2 = absk(6) e3 = absk(1) qz1 = + k(7,3) qz2 = + k(6,3) qz3 = + k(1,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(7,mu)*k(6,mu)*metric(mu) q13 = q13 + k(7,mu)*k(1,mu)*metric(mu) q23 = q23 + k(6,mu)*k(1,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1**2*e2*e3 - 2*e1*e2**2*e3 + e1*e3*q12 & + e2*e3*q12 + 2*e1*e2*qz1*qz3 + e2**2*qz1*qz3 - q12*qz1*qz3 & + e1*e2*qz2*qz3 + e2*e3*tq22 & - qz2*qz3*tq22))/(2.0d0*e1*e2*e3*q12*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.4) THEN ! cut = {8, 6, 3, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = - k(3,mu) qj(mu) = - k(8,mu) l(mu) = k(5,mu) END DO absqi = absk(3) absqj = absk(8) absqk = absk(6) absl = absk(5) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = 0.5d0/nc ! for q-barq call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(8) e2 = absk(6) e3 = absk(3) qz1 = - k(8,3) qz2 = + k(6,3) qz3 = - k(3,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 - k(8,mu)*k(6,mu)*metric(mu) q13 = q13 + k(8,mu)*k(3,mu)*metric(mu) q23 = q23 - k(6,mu)*k(3,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (3*cf*nc*(-2*e1**2*e2*e3 - 2*e1*e2**2*e3 + e1*e3*q12 & + e2*e3*q12 + 2*e1*e2*qz1*qz3 + e2**2*qz1*qz3 - q12*qz1*qz3 & + e1*e2*qz2*qz3 + e2*e3*tq22 & - qz2*qz3*tq22))/(2.0d0*e1*e2*e3*q12*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.6) THEN ! cut = {8, 6, 5, 1}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(8,mu) + k(7,mu)) qj(mu) = 0.5d0*( k(1,mu) - k(3,mu)) l(mu) = - k(5,mu) END DO absl = absk(5) absqk = absk(6) colorfactor = 0.5d0/nc ! for q-barq call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e4 = k(4,0) e6 = k(6,0) e8 = k(8,0) kz1 = k(1,3) kz2 = k(2,3) kz4 = k(4,3) kz6 = k(6,3) kz8 = k(8,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k28 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k48 = 0.0d0 k68 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k28 = k28 + k(2,mu)*k(8,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k48 = k48 + k(4,mu)*k(8,mu)*metric(mu) k68 = k68 + k(6,mu)*k(8,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk88 = tk88 - k(8,mu)**2 END DO ! result = (3*cf*nc*(e1*e4*e6*e8*k26 - e1*e4*e6**2*k28 & + e1*e2*e6*e8*k46 - e1*e2*e6**2*k48 + 2*e1*e2*e4*e6*k68 & - e1*e4*k26*k68 - e1*e2*k46*k68 - e6*e8*k46*kz1*kz2 & + e6**2*k48*kz1*kz2 - e4*e6*k68*kz1*kz2 + k46*k68*kz1*kz2 & - e6*e8*k26*kz1*kz4 + e6**2*k28*kz1*kz4 - e2*e6*k68*kz1*kz4 & + k26*k68*kz1*kz4 + e6*e8*k24*kz1*kz6 - k24*k68*kz1*kz6 & - e6**2*k24*kz1*kz8 + e1*e8*k24*tk66 - e1*e4*k28*tk66 & - e1*e2*k48*tk66 + k48*kz1*kz2*tk66 + k28*kz1*kz4*tk66 & - k24*kz1*kz8*tk66))/(e1*e6*e8*k22*k44*tk66) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.8) THEN ! cut = {7, 6, 5, 3}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(3,mu) + k(1,mu)) qj(mu) = 0.5d0*( k(7,mu) - k(8,mu)) l(mu) = k(5,mu) END DO absl = absk(5) absqk = absk(6) colorfactor = 0.5d0/nc ! for q-barq call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e6 = k(6,0) e7 = k(7,0) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz6 = k(6,3) kz7 = k(7,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k27 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k47 = 0.0d0 k67 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) k67 = k67 + k(6,mu)*k(7,mu)*metric(mu) END DO tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (3*cf*nc*(e3*e4*e6*e7*k26 - e3*e4*e6**2*k27 & + e2*e3*e6*e7*k46 - e2*e3*e6**2*k47 + 2*e2*e3*e4*e6*k67 & - e3*e4*k26*k67 - e2*e3*k46*k67 - e6*e7*k46*kz2*kz3 & + e6**2*k47*kz2*kz3 - e4*e6*k67*kz2*kz3 + k46*k67*kz2*kz3 & - e6*e7*k26*kz3*kz4 + e6**2*k27*kz3*kz4 - e2*e6*k67*kz3*kz4 & + k26*k67*kz3*kz4 + e6*e7*k24*kz3*kz6 - k24*k67*kz3*kz6 & - e6**2*k24*kz3*kz7 + e3*e7*k24*tk66 - e3*e4*k27*tk66 & - e2*e3*k47*tk66 + k47*kz2*kz3*tk66 + k27*kz3*kz4*tk66 & - k24*kz3*kz7*tk66))/(e3*e6*e7*k22*k44*tk66) result = result*softfactor softsubtraction = softsubtraction - result ! ! Close IF (cutnumber.EQ....) THEN ! END IF ! ! Close IF (flavorsetnumber.EQ.1) THEN ... ! END IF ELSE IF (graphnumber.EQ.8) THEN ! Code for graph 8, with connections ! {{3, 4}, {5, 6}, {1, 4, 5}, {1, 3, 6}, {2, 3, 6}, {2, 4, 5}}. ! softsubtraction = zero ! ELSE IF (graphnumber.EQ.9) THEN ! Code for graph 9, with connections ! {{3, 4}, {5, 6}, {1, 5, 5}, {1, 6, 6}, {2, 3, 3}, {2, 4, 4}}. ! softsubtraction = zero ! ELSE IF (graphnumber.EQ.10) THEN ! Code for graph 10, with connections ! {{3, 4}, {5, 6}, {1, 5, 6}, {1, 5, 6}, {2, 3, 4}, {2, 3, 4}}. ! IF (flavorsetnumber.EQ.1) THEN ! Flavors = {quark, qbar, quark, qbar, gluon, quark, qbar, gluon} ! IF (cutnumber.EQ.1) THEN ! cut = {8, 7, 1, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(1,mu) qj(mu) = k(7,mu) l(mu) = k(5,mu) END DO absqi = absk(1) absqj = absk(7) absqk = absk(8) absl = absk(5) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = 0.5d0/nc ! for q-barq call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(1) e2 = absk(8) e3 = absk(7) qz1 = + k(1,3) qz2 = + k(8,3) qz3 = + k(7,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(1,mu)*k(8,mu)*metric(mu) q13 = q13 + k(1,mu)*k(7,mu)*metric(mu) q23 = q23 + k(8,mu)*k(7,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.2) THEN ! cut = {6, 5, 2, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(2,mu) qj(mu) = k(6,mu) l(mu) = k(8,mu) END DO absqi = absk(2) absqj = absk(6) absqk = absk(5) absl = absk(8) lrsign = -1 ! +1 for a leftloop, -1 for a rightloop colorfactor = 0.5d0/nc ! for q-barq call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(6) e2 = absk(5) e3 = absk(2) qz1 = + k(6,3) qz2 = + k(5,3) qz3 = + k(2,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(6,mu)*k(5,mu)*metric(mu) q13 = q13 + k(6,mu)*k(2,mu)*metric(mu) q23 = q23 + k(5,mu)*k(2,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.3) THEN ! cut = {8, 6, 3, 0}, psoft = 5 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(6,mu) qj(mu) = - k(3,mu) l(mu) = k(5,mu) END DO absqi = absk(6) absqj = absk(3) absqk = absk(8) absl = absk(5) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = 0.5d0/nc ! for q-barq call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(6) e2 = absk(8) e3 = absk(3) qz1 = + k(6,3) qz2 = + k(8,3) qz3 = - k(3,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 + k(6,mu)*k(8,mu)*metric(mu) q13 = q13 - k(6,mu)*k(3,mu)*metric(mu) q23 = q23 - k(8,mu)*k(3,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.4) THEN ! cut = {7, 5, 4, 0}, psoft = 8 ! Calculate for exchange of a virtual soft gluon. ! DO mu = 1,3 qi(mu) = k(7,mu) qj(mu) = - k(4,mu) l(mu) = k(8,mu) END DO absqi = absk(7) absqj = absk(4) absqk = absk(5) absl = absk(8) lrsign = 1 ! +1 for a leftloop, -1 for a rightloop colorfactor = 0.5d0/nc ! for q-barq call & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = absk(4) e2 = absk(5) e3 = absk(7) qz1 = - k(4,3) qz2 = + k(5,3) qz3 = + k(7,3) q12 = 0.0d0 q13 = 0.0d0 q23 = 0.0d0 DO mu = 0,3 q12 = q12 - k(4,mu)*k(5,mu)*metric(mu) q13 = q13 - k(4,mu)*k(7,mu)*metric(mu) q23 = q23 + k(5,mu)*k(7,mu)*metric(mu) END DO tq22 = - e2**2 ! result = (-3*cf*nc*(-2*e1*e2**2*e3*q12 - 2*e1*e2*e3**2*q12 & - 2*e1**2*e2*e3*q23 - 2*e1*e2**2*e3*q23 + e1*e2*q12*q23 & + 2*e1*e3*q12*q23 + e2*e3*q12*q23 + e2*e3*q12*qz1*qz2 & + e2**2*q12*qz1*qz3 + 2*e2*e3*q12*qz1*qz3 + 2*e1*e2*q23*qz1*qz3 & + e2**2*q23*qz1*qz3 - 2*q12*q23*qz1*qz3 + e1*e2*q23*qz2*qz3 & - e1*e3*q12*tq22 + e3**2*q12*tq22 - e1*e2*q13*tq22 & - 2*e1*e3*q13*tq22 - e2*e3*q13*tq22 + e1**2*q23*tq22 & - e1*e3*q23*tq22 - q23*qz1**2*tq22 + q13*qz1*qz2*tq22 & + q12*qz1*qz3*tq22 + 2*q13*qz1*qz3*tq22 + q23*qz1*qz3*tq22 & + q13*qz2*qz3*tq22 & - q12*qz3**2*tq22))/(4.0d0*e1*e2*e3*q12*q23*tq22) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.5) THEN ! cut = {8, 5, 3, 1}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(3,mu) + k(7,mu)) qj(mu) = 0.5d0*( k(1,mu) + k(6,mu)) l(mu) = - k(5,mu) END DO absl = absk(5) absqk = absk(8) colorfactor = 0.5d0/nc ! for q-barq call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e8 = k(8,0) kz1 = k(1,3) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz8 = k(8,3) k12 = 0.0d0 k13 = 0.0d0 k14 = 0.0d0 k18 = 0.0d0 k22 = 0.0d0 k23 = 0.0d0 k24 = 0.0d0 k28 = 0.0d0 k34 = 0.0d0 k38 = 0.0d0 k44 = 0.0d0 k48 = 0.0d0 DO mu = 0,3 k12 = k12 + k(1,mu)*k(2,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k14 = k14 + k(1,mu)*k(4,mu)*metric(mu) k18 = k18 + k(1,mu)*k(8,mu)*metric(mu) k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k23 = k23 + k(2,mu)*k(3,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k28 = k28 + k(2,mu)*k(8,mu)*metric(mu) k34 = k34 + k(3,mu)*k(4,mu)*metric(mu) k38 = k38 + k(3,mu)*k(8,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k48 = k48 + k(4,mu)*k(8,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk88 = tk88 - k(8,mu)**2 END DO ! result = (-3*cf*nc*(-2*e2*e3*e8**2*k14 + 2*e2*e3*e4*e8*k18 & - 2*e1*e4*e8**2*k23 + e8**2*k14*k23 + 3*e8**2*k13*k24 & - 2*e3*e8*k18*k24 + 2*e1*e3*e4*e8*k28 - 2*e4*e8*k13*k28 & - 3*e8**2*k12*k34 + 2*e2*e8*k18*k34 + 2*e1*e8*k28*k34 & - 2*k18*k28*k34 + 2*e1*e2*e4*e8*k38 + 2*e4*e8*k12*k38 & - 2*e2*e4*k18*k38 - 2*e1*e8*k24*k38 + 2*k18*k24*k38 & + 2*e1*e2*e3*e8*k48 + 2*e3*e8*k12*k48 - 2*e2*e8*k13*k48 & - 2*e1*e3*k28*k48 + 2*k13*k28*k48 - 2*k12*k38*k48 & - 2*e8**2*k34*kz1*kz2 + 2*e8**2*k24*kz1*kz3 - 2*e4*e8*k28*kz1*kz3 & - 2*e2*e8*k48*kz1*kz3 + 2*k28*k48*kz1*kz3 + 2*e8**2*k13*kz2*kz4 & - 2*e3*e8*k18*kz2*kz4 - 2*e1*e8*k38*kz2*kz4 + 2*k18*k38*kz2*kz4 & - 2*e8**2*k12*kz3*kz4 + e4*e8*k23*kz1*kz8 - e3*e8*k24*kz1*kz8 & + e2*e8*k34*kz1*kz8 - k28*k34*kz1*kz8 + k24*k38*kz1*kz8 & - k23*k48*kz1*kz8 - e4*e8*k13*kz2*kz8 + e3*e8*k14*kz2*kz8 & + e1*e8*k34*kz2*kz8 - k18*k34*kz2*kz8 - k14*k38*kz2*kz8 & + k13*k48*kz2*kz8 + e4*e8*k12*kz3*kz8 + e2*e8*k14*kz3*kz8 & - e1*e8*k24*kz3*kz8 + k18*k24*kz3*kz8 - k14*k28*kz3*kz8 & - k12*k48*kz3*kz8 + e3*e8*k12*kz4*kz8 - e2*e8*k13*kz4*kz8 & + e1*e8*k23*kz4*kz8 - k18*k23*kz4*kz8 + k13*k28*kz4*kz8 & - k12*k38*kz4*kz8 + k14*k23*kz8**2 - k13*k24*kz8**2 & + k12*k34*kz8**2 + 2*e3*e4*k12*tk88 - 2*e2*e3*k14*tk88 & - 2*e1*e4*k23*tk88 + 2*k14*k23*tk88 + 2*k13*k24*tk88 & + 2*e1*e2*k34*tk88 - 2*k12*k34*tk88 - 2*k34*kz1*kz2*tk88 & + 2*k14*kz2*kz3*tk88 + 2*k23*kz1*kz4*tk88 & - 2*k12*kz3*kz4*tk88))/(2.0d0*e1*e3*e8*k22*k44*tk88) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.8) THEN ! cut = {8, 5, 4, 2}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*( - k(4,mu) + k(6,mu)) qj(mu) = 0.5d0*( k(2,mu) + k(7,mu)) l(mu) = - k(8,mu) END DO absl = absk(8) absqk = absk(5) colorfactor = 0.5d0/nc ! for q-barq call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e2 = k(2,0) e3 = k(3,0) e4 = k(4,0) e5 = k(5,0) kz1 = k(1,3) kz2 = k(2,3) kz3 = k(3,3) kz4 = k(4,3) kz5 = k(5,3) k11 = 0.0d0 k12 = 0.0d0 k13 = 0.0d0 k14 = 0.0d0 k15 = 0.0d0 k23 = 0.0d0 k24 = 0.0d0 k25 = 0.0d0 k33 = 0.0d0 k34 = 0.0d0 k35 = 0.0d0 k45 = 0.0d0 DO mu = 0,3 k11 = k11 + k(1,mu)*k(1,mu)*metric(mu) k12 = k12 + k(1,mu)*k(2,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k14 = k14 + k(1,mu)*k(4,mu)*metric(mu) k15 = k15 + k(1,mu)*k(5,mu)*metric(mu) k23 = k23 + k(2,mu)*k(3,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k25 = k25 + k(2,mu)*k(5,mu)*metric(mu) k33 = k33 + k(3,mu)*k(3,mu)*metric(mu) k34 = k34 + k(3,mu)*k(4,mu)*metric(mu) k35 = k35 + k(3,mu)*k(5,mu)*metric(mu) k45 = k45 + k(4,mu)*k(5,mu)*metric(mu) END DO tk11 = 0.0d0 tk22 = 0.0d0 tk33 = 0.0d0 tk44 = 0.0d0 tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk22 = tk22 - k(2,mu)**2 tk33 = tk33 - k(3,mu)**2 tk44 = tk44 - k(4,mu)**2 tk55 = tk55 - k(5,mu)**2 END DO ! result = (-3*cf*nc*(-2*e2*e3*e5**2*k14 + 2*e2*e3*e4*e5*k15 & - 2*e1*e4*e5**2*k23 + e5**2*k14*k23 + 3*e5**2*k13*k24 & - 2*e3*e5*k15*k24 + 2*e1*e3*e4*e5*k25 - 2*e4*e5*k13*k25 & - 3*e5**2*k12*k34 + 2*e2*e5*k15*k34 + 2*e1*e5*k25*k34 & - 2*k15*k25*k34 + 2*e1*e2*e4*e5*k35 + 2*e4*e5*k12*k35 & - 2*e2*e4*k15*k35 - 2*e1*e5*k24*k35 + 2*k15*k24*k35 & + 2*e1*e2*e3*e5*k45 + 2*e3*e5*k12*k45 - 2*e2*e5*k13*k45 & - 2*e1*e3*k25*k45 + 2*k13*k25*k45 - 2*k12*k35*k45 & - 2*e5**2*k34*kz1*kz2 + 2*e5**2*k24*kz1*kz3 - 2*e4*e5*k25*kz1*kz3 & - 2*e2*e5*k45*kz1*kz3 + 2*k25*k45*kz1*kz3 + 2*e5**2*k13*kz2*kz4 & - 2*e3*e5*k15*kz2*kz4 - 2*e1*e5*k35*kz2*kz4 + 2*k15*k35*kz2*kz4 & - 2*e5**2*k12*kz3*kz4 + e4*e5*k23*kz1*kz5 - e3*e5*k24*kz1*kz5 & + e2*e5*k34*kz1*kz5 - k25*k34*kz1*kz5 + k24*k35*kz1*kz5 & - k23*k45*kz1*kz5 - e4*e5*k13*kz2*kz5 + e3*e5*k14*kz2*kz5 & + e1*e5*k34*kz2*kz5 - k15*k34*kz2*kz5 - k14*k35*kz2*kz5 & + k13*k45*kz2*kz5 + e4*e5*k12*kz3*kz5 + e2*e5*k14*kz3*kz5 & - e1*e5*k24*kz3*kz5 + k15*k24*kz3*kz5 - k14*k25*kz3*kz5 & - k12*k45*kz3*kz5 + e3*e5*k12*kz4*kz5 - e2*e5*k13*kz4*kz5 & + e1*e5*k23*kz4*kz5 - k15*k23*kz4*kz5 + k13*k25*kz4*kz5 & - k12*k35*kz4*kz5 + k14*k23*kz5**2 - k13*k24*kz5**2 & + k12*k34*kz5**2 + 2*e3*e4*k12*tk55 - 2*e2*e3*k14*tk55 & - 2*e1*e4*k23*tk55 + 2*k14*k23*tk55 + 2*k13*k24*tk55 & + 2*e1*e2*k34*tk55 - 2*k12*k34*tk55 - 2*k34*kz1*kz2*tk55 & + 2*k14*kz2*kz3*tk55 + 2*k23*kz1*kz4*tk55 & - 2*k12*kz3*kz4*tk55))/(2.0d0*e2*e4*e5*k11*k33*tk55) result = result*softfactor softsubtraction = softsubtraction - result ! ELSE IF (cutnumber.EQ.9) THEN ! cut = {8, 7, 6, 5}, psoft = 8 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*(k(7,mu) + k(2,mu)) qj(mu) = 0.5d0*( k(6,mu) - k(4,mu)) l(mu) = k(8,mu) END DO absl = absk(8) absqk = absk(5) colorfactor = 0.5d0/nc ! for q-barq call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e1 = k(1,0) e3 = k(3,0) e5 = k(5,0) e6 = k(6,0) e7 = k(7,0) kz1 = k(1,3) kz3 = k(3,3) kz5 = k(5,3) kz6 = k(6,3) kz7 = k(7,3) k11 = 0.0d0 k13 = 0.0d0 k15 = 0.0d0 k16 = 0.0d0 k17 = 0.0d0 k33 = 0.0d0 k35 = 0.0d0 k36 = 0.0d0 k37 = 0.0d0 k56 = 0.0d0 k57 = 0.0d0 k67 = 0.0d0 DO mu = 0,3 k11 = k11 + k(1,mu)*k(1,mu)*metric(mu) k13 = k13 + k(1,mu)*k(3,mu)*metric(mu) k15 = k15 + k(1,mu)*k(5,mu)*metric(mu) k16 = k16 + k(1,mu)*k(6,mu)*metric(mu) k17 = k17 + k(1,mu)*k(7,mu)*metric(mu) k33 = k33 + k(3,mu)*k(3,mu)*metric(mu) k35 = k35 + k(3,mu)*k(5,mu)*metric(mu) k36 = k36 + k(3,mu)*k(6,mu)*metric(mu) k37 = k37 + k(3,mu)*k(7,mu)*metric(mu) k56 = k56 + k(5,mu)*k(6,mu)*metric(mu) k57 = k57 + k(5,mu)*k(7,mu)*metric(mu) k67 = k67 + k(6,mu)*k(7,mu)*metric(mu) END DO tk11 = 0.0d0 tk33 = 0.0d0 tk55 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k(1,mu)**2 tk33 = tk33 - k(3,mu)**2 tk55 = tk55 - k(5,mu)**2 tk66 = tk66 - k(6,mu)**2 tk77 = tk77 - k(7,mu)**2 END DO ! result = (3*cf*nc*(-2*e3*e5*e6*e7*k15 + 2*e3*e5**2*e7*k16 & - 2*e1*e5*e6*e7*k35 + 2*e6*e7*k15*k35 - 2*e5*e6*k17*k35 & - 2*e5*e7*k15*k36 + 3*e5**2*k17*k36 + 2*e1*e5**2*e6*k37 & - e5**2*k16*k37 - 2*e1*e3*e5*e7*k56 + 2*e5*e7*k13*k56 & - 2*e3*e5*k17*k56 + 2*k17*k35*k56 - 2*e1*e3*e5*e6*k57 & + 2*e5*e6*k13*k57 - 2*e1*e5*k36*k57 + 2*k15*k36*k57 & + 2*e1*e3*k56*k57 - 2*k13*k56*k57 - 3*e5**2*k13*k67 & + 2*e3*e5*k15*k67 + 2*e1*e5*k35*k67 - 2*k15*k35*k67 & + 2*e5*e7*k56*kz1*kz3 + 2*e5*e6*k57*kz1*kz3 - 2*k56*k57*kz1*kz3 & - 2*e5**2*k67*kz1*kz3 - e5*e7*k36*kz1*kz5 - e5*e6*k37*kz1*kz5 & + k37*k56*kz1*kz5 + k36*k57*kz1*kz5 + e3*e5*k67*kz1*kz5 & - k35*k67*kz1*kz5 - e5*e7*k16*kz3*kz5 - e5*e6*k17*kz3*kz5 & + k17*k56*kz3*kz5 + k16*k57*kz3*kz5 + e1*e5*k67*kz3*kz5 & - k15*k67*kz3*kz5 - k17*k36*kz5**2 - k16*k37*kz5**2 & + k13*k67*kz5**2 + 2*e5**2*k17*kz3*kz6 + e5*e7*k13*kz5*kz6 & - e3*e5*k17*kz5*kz6 + k17*k35*kz5*kz6 - e1*e5*k37*kz5*kz6 & + k15*k37*kz5*kz6 - k13*k57*kz5*kz6 + 2*e5**2*k36*kz1*kz7 & + e5*e6*k13*kz5*kz7 - e3*e5*k16*kz5*kz7 + k16*k35*kz5*kz7 & - e1*e5*k36*kz5*kz7 + k15*k36*kz5*kz7 - k13*k56*kz5*kz7 & - 2*e5**2*k13*kz6*kz7 + 2*e3*e5*k15*kz6*kz7 + 2*e1*e5*k35*kz6*kz7 & - 2*k15*k35*kz6*kz7 + 2*e3*e7*k16*tk55 - 2*e3*e6*k17*tk55 & - 2*e1*e7*k36*tk55 + 2*k17*k36*tk55 + 2*e1*e6*k37*tk55 & - 2*k16*k37*tk55 - 2*k13*k67*tk55 - 2*k37*kz1*kz6*tk55 & + 2*k17*kz3*kz6*tk55 + 2*k36*kz1*kz7*tk55 & - 2*k16*kz3*kz7*tk55))/(2.0d0*e5*e6*e7*k11*k33*tk55) result = result*softfactor softsubtraction = softsubtraction - result ! ! cut = {8, 7, 6, 5}, psoft = 5 ! Calculate for exchange of a real soft gluon. ! DO mu = 1,3 qi(mu) = 0.5d0*(k(6,mu) + k(1,mu)) qj(mu) = 0.5d0*( k(7,mu) - k(3,mu)) l(mu) = k(5,mu) END DO absl = absk(5) absqk = absk(8) colorfactor = 0.5d0/nc ! for q-barq call getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! ! Now we calculate the remaining Born graph. ! e2 = k(2,0) e4 = k(4,0) e6 = k(6,0) e7 = k(7,0) e8 = k(8,0) kz2 = k(2,3) kz4 = k(4,3) kz6 = k(6,3) kz7 = k(7,3) kz8 = k(8,3) k22 = 0.0d0 k24 = 0.0d0 k26 = 0.0d0 k27 = 0.0d0 k28 = 0.0d0 k44 = 0.0d0 k46 = 0.0d0 k47 = 0.0d0 k48 = 0.0d0 k67 = 0.0d0 k68 = 0.0d0 k78 = 0.0d0 DO mu = 0,3 k22 = k22 + k(2,mu)*k(2,mu)*metric(mu) k24 = k24 + k(2,mu)*k(4,mu)*metric(mu) k26 = k26 + k(2,mu)*k(6,mu)*metric(mu) k27 = k27 + k(2,mu)*k(7,mu)*metric(mu) k28 = k28 + k(2,mu)*k(8,mu)*metric(mu) k44 = k44 + k(4,mu)*k(4,mu)*metric(mu) k46 = k46 + k(4,mu)*k(6,mu)*metric(mu) k47 = k47 + k(4,mu)*k(7,mu)*metric(mu) k48 = k48 + k(4,mu)*k(8,mu)*metric(mu) k67 = k67 + k(6,mu)*k(7,mu)*metric(mu) k68 = k68 + k(6,mu)*k(8,mu)*metric(mu) k78 = k78 + k(7,mu)*k(8,mu)*metric(mu) END DO tk22 = 0.0d0 tk44 = 0.0d0 tk66 = 0.0d0 tk77 = 0.0d0 tk88 = 0.0d0 DO mu = 1,3 tk22 = tk22 - k(2,mu)**2 tk44 = tk44 - k(4,mu)**2 tk66 = tk66 - k(6,mu)**2 tk77 = tk77 - k(7,mu)**2 tk88 = tk88 - k(8,mu)**2 END DO ! result = (3*cf*nc*(2*e4*e6*e8**2*k27 - 2*e4*e6*e7*e8*k28 & + 2*e2*e7*e8**2*k46 - e8**2*k27*k46 + 3*e8**2*k26*k47 & - 2*e6*e8*k28*k47 - 2*e2*e6*e7*e8*k48 - 2*e7*e8*k26*k48 & + 2*e6*e7*k28*k48 - 3*e8**2*k24*k67 + 2*e4*e8*k28*k67 & + 2*e2*e8*k48*k67 - 2*k28*k48*k67 - 2*e2*e4*e7*e8*k68 & + 2*e7*e8*k24*k68 - 2*e2*e8*k47*k68 + 2*k28*k47*k68 & - 2*e2*e4*e6*e8*k78 + 2*e6*e8*k24*k78 - 2*e4*e8*k26*k78 & + 2*k26*k48*k78 + 2*e2*e4*k68*k78 - 2*k24*k68*k78 & - 2*e8**2*k67*kz2*kz4 + 2*e7*e8*k68*kz2*kz4 + 2*e6*e8*k78*kz2*kz4 & - 2*k68*k78*kz2*kz4 + 2*e8**2*k47*kz2*kz6 + 2*e8**2*k26*kz4*kz7 & - 2*e8**2*k24*kz6*kz7 + 2*e4*e8*k28*kz6*kz7 + 2*e2*e8*k48*kz6*kz7 & - 2*k28*k48*kz6*kz7 - e7*e8*k46*kz2*kz8 - e6*e8*k47*kz2*kz8 & + e4*e8*k67*kz2*kz8 - k48*k67*kz2*kz8 + k47*k68*kz2*kz8 & + k46*k78*kz2*kz8 - e7*e8*k26*kz4*kz8 - e6*e8*k27*kz4*kz8 & + e2*e8*k67*kz4*kz8 - k28*k67*kz4*kz8 + k27*k68*kz4*kz8 & + k26*k78*kz4*kz8 + e7*e8*k24*kz6*kz8 - e4*e8*k27*kz6*kz8 & - e2*e8*k47*kz6*kz8 + k28*k47*kz6*kz8 + k27*k48*kz6*kz8 & - k24*k78*kz6*kz8 + e6*e8*k24*kz7*kz8 - e4*e8*k26*kz7*kz8 & - e2*e8*k46*kz7*kz8 + k28*k46*kz7*kz8 + k26*k48*kz7*kz8 & - k24*k68*kz7*kz8 - k27*k46*kz8**2 - k26*k47*kz8**2 & + k24*k67*kz8**2 - 2*e4*e7*k26*tk88 + 2*e4*e6*k27*tk88 & + 2*e2*e7*k46*tk88 - 2*k27*k46*tk88 - 2*e2*e6*k47*tk88 & + 2*k26*k47*tk88 - 2*k24*k67*tk88 + 2*k47*kz2*kz6*tk88 & - 2*k27*kz4*kz6*tk88 - 2*k46*kz2*kz7*tk88 & + 2*k26*kz4*kz7*tk88))/(2.0d0*e6*e7*e8*k22*k44*tk88) result = result*softfactor softsubtraction = softsubtraction - result ! ! Close IF (cutnumber.EQ....) THEN ! END IF ! ! Close IF (flavorsetnumber.EQ.1) THEN ... ! END IF ! ! Close IF (graphnumber.EQ.1) THEN ! END IF ! end function softsubtraction ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine & getsoftfactorV(qi,qj,l,absqi,absqj,absqk,absl,colorfactor,lrsign,softfactor) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: qi(3),qj(3),l(3) real(kind=dbl) :: absqi,absqj,absqk,absl real(kind=dbl) :: colorfactor,lrsign ! Out: complex(kind=dbl) :: softfactor ! ! Calculates softfactor, the integrand for the virtual soft subtraction. ! Here softfactor includes the factor F_{ij}, the factor ! theta(l_{ij}^2 < Msoft^2), the jacobian, and a factor 1/(2*|s_{ij}|^3). ! ! 6 February 2003 ! 14 June 2003 ! ! Factor in msoftsq =(msoftfactor*rts0*onemthrust)**2 real(kind=dbl) :: msoftfactor common /softcutoff/ msoftfactor ! complex(kind=dbl), parameter :: zero = (0.0d0,0.0d0) complex(kind=dbl), parameter :: one = (1.0d0,0.0d0) complex(kind=dbl), parameter :: i = (0.0d0,1.0d0) real(kind=dbl) :: deformalpha,deformbeta,deformgamma common /deformscales/deformalpha,deformbeta,deformgamma integer :: mu,nu real(kind=dbl) :: cosli,coslj,cosij real(kind=dbl) :: hatqi(3),hatqj(3),hatl(3) real(kind=dbl) :: lsq real(kind=dbl) :: temp,temp1,temp2,temp3 real(kind=dbl) :: tempi(3),tempj(3),tempa(3),tempb(3) real(kind=dbl) :: czeta,dampingfactor real(kind=dbl) :: xi(3),zeta(3) complex(kind=dbl) :: s(3),hats(3) complex(kind=dbl) :: complexsqrt complex(kind=dbl) :: ssq,abss,cosis,cosjs complex(kind=dbl) :: fijV real(kind=dbl) :: delta real(kind=dbl) :: gradxi(3,3),gradzeta(3,3) real(kind=dbl) :: msoftsq complex(kind=dbl) :: b(3,3) complex(kind=dbl) :: jacobian real(kind=dbl) :: rts0,thrust0 real(kind=dbl) :: n(3) complex(kind=dbl) :: eta(3) real(kind=dbl) :: x,x0,y complex(kind=dbl) :: z,c complex(kind=dbl) :: ctemp1,ctemp2 real(kind=dbl) :: gradx(3),grady(3) complex(kind=dbl) :: gradz(3),gradc(3),tempc(3) complex(kind=dbl) :: gradeta(3,3) ! ! Return 0 if absl is out of range. We first calculate lsq and msoftsq. ! lsq = absl**2 rts0 = absqi + absqj + absqk thrust0 = 2.0d0 * max(absqi,absqj,absqk) /rts0 msoftsq = ( msoftfactor * rts0 *(1.0d0 - thrust0) )**2 IF (lsq.GT.msoftsq) THEN softfactor = zero RETURN END IF ! cosli = 0.0d0 coslj = 0.0d0 cosij = 0.0d0 DO mu = 1,3 hatqi(mu) = qi(mu)/absqi hatqj(mu) = qj(mu)/absqj hatl(mu) = l(mu)/absl cosli = cosli + hatl(mu)*hatqi(mu) coslj = coslj + hatl(mu)*hatqj(mu) cosij = cosij + hatqi(mu)*hatqj(mu) END DO temp = sqrt(2.0d0*(1.0d0 - cosij)) x0 = 0.5d0*temp x = 0.0d0 DO mu = 1,3 n(mu) = (hatqj(mu) - hatqi(mu))/temp x = x + n(mu)*hatl(mu) END DO IF (x**2.GT.x0**2) THEN DO mu = 1,3 eta(mu) = zero END DO ELSE y = lsq/msoftsq*(x0**2 - x**2)**2 z = x + i*y c = complexsqrt((one - z**2)/(1.0d0 - x**2)) ctemp1 = c - one ctemp2 = (z - c*x)*absl DO mu = 1,3 eta(mu) = ctemp1*l(mu) + ctemp2*n(mu) END DO END IF ! temp = lrsign*lsq/2.0d0/absqi/absqj/(1.0d0 - cosij) temp1 = 1.0d0 - coslj**2 temp2 = 1.0d0 - cosli**2 czeta = 2.0d0*deformalpha/(1.0d0 + deformgamma) czeta = czeta/(absqi + absqj - absqk) temp3 = czeta * lsq * min(1.0d0 + lrsign*cosli,1.0d0 - lrsign*coslj) dampingfactor = (1.0d0 - lsq/msoftsq) ssq = zero DO mu = 1,3 xi(mu) = temp*(temp1*qi(mu) - temp2*qj(mu)) zeta(mu) = temp3*(hatqj(mu) - hatqi(mu)) s(mu) = l(mu) + dampingfactor*( xi(mu) + i*zeta(mu) ) + eta(mu) ssq = ssq + s(mu)**2 END DO abss = complexsqrt(ssq) cosis = zero cosjs = zero DO mu = 1,3 hats(mu) = s(mu)/abss cosis = cosis + hatqi(mu)*hats(mu) cosjs = cosjs + hatqj(mu)*hats(mu) END DO fijV = one/(one + lrsign*cosis) + one/(one - lrsign*cosjs) fijV = -fijV*(cosij - cosis*cosjs) fijV = fijV + 2.0d0 fijV = colorfactor*lrsign*fijV/(cosjs - cosis) ! ! Calculate the jacobian. ! Start with grad xi. ! temp = lrsign*absqi*absqj*(1.0d0 - cosij) DO mu = 1,3 tempj(mu) = l(mu) - absl*coslj*hatqj(mu) tempi(mu) = l(mu) - absl*cosli*hatqi(mu) END DO DO mu = 1,3 DO nu = 1,3 gradxi(mu,nu) = ( qi(mu)*tempj(nu) - qj(mu)*tempi(nu) )/temp END DO END DO ! ! Now try grad zeta. There are four cases. ! IF ((cosli + coslj).LT.0.0d0) THEN DO mu = 1,3 tempa(mu) = czeta*( hatqj(mu) - hatqi(mu) ) IF (lrsign.GT.0.0d0) THEN ! left loop tempb(mu) = (2.0d0 + cosli)*l(mu) + absl*hatqi(mu) ELSE ! right loop tempb(mu) = (2.0d0 + coslj)*l(mu) + absl*hatqj(mu) END IF END DO DO mu = 1,3 DO nu = 1,3 gradzeta(mu,nu) = tempa(mu)*tempb(nu) END DO END DO ELSE ! (cosli + coslj.GT.0.0d0) DO mu = 1,3 tempa(mu) = czeta*( hatqj(mu) - hatqi(mu) ) IF (lrsign.GT.0.0d0) THEN ! left loop tempb(mu) = (2.0d0 - coslj)*l(mu) - absl*hatqj(mu) ELSE ! right loop tempb(mu) = (2.0d0 - cosli)*l(mu) - absl*hatqi(mu) END IF END DO DO mu = 1,3 DO nu = 1,3 gradzeta(mu,nu) = tempa(mu)*tempb(nu) END DO END DO END IF ! ! Now we need gradeta(mu,nu). ! IF (x**2.GT.x0**2) THEN ! In this case, eta(mu) = 0. DO mu = 1,3 DO nu = 1,3 gradeta(mu,nu) = zero END DO END DO ELSE DO mu = 1,3 gradx(mu) = (n(mu) - x*hatl(mu))/absl grady(mu) = 2.0d0*y/absl*hatl(mu) - 4.0d0*x*y/(x0**2 - x**2)*gradx(mu) gradz(mu) = gradx(mu) + i*grady(mu) gradc(mu) = c*(x/(1.0d0 - x**2)*gradx(mu) - z/(one - z**2)*gradz(mu)) tempc(mu) = (gradz(mu) - gradx(mu)*c - x*gradc(mu))*absl & + (z - x*c)*hatl(mu) END DO DO mu = 1,3 DO nu = 1,3 gradeta(mu,nu) = tempc(nu)*n(mu) + gradc(nu)*l(mu) END DO gradeta(mu,mu) = gradeta(mu,mu) + c - one END DO END IF ! x**2.GT.x0**2 ! ! Now assemble the matrix B. ! temp1 = (1.0d0 - lsq/msoftsq) temp2 = 2.0d0/msoftsq DO mu = 1,3 DO nu = 1,3 b(mu,nu) = delta(mu,nu) & + temp1*( gradxi(mu,nu) + i*gradzeta(mu,nu) ) & - temp2*l(mu)*( xi(nu) + i*zeta(nu) ) & + gradeta(mu,nu) END DO END DO ! ! The jacobian is the deteminant of the matrix B. ! jacobian = b(1,1)*(b(2,2)*b(3,3) - b(2,3)*b(3,2)) & + b(1,2)*(b(2,3)*b(3,1) - b(2,1)*b(3,3)) & + b(1,3)*(b(2,1)*b(3,2) - b(2,2)*b(3,1)) ! ! Now we can assemble everything. ! softfactor = jacobian*fijV/2.0d0/abss**3 ! END subroutine getsoftfactorV ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine & getsoftfactorR(qi,qj,l,absl,absqk,colorfactor,softfactor) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: qi(3),qj(3),l(3) real(kind=dbl) :: absl,absqk,colorfactor ! Out: complex(kind=dbl) :: softfactor ! ! Calculates softfactor, the integrand for the real soft subtraction. ! Here softfactor includes the factor F_{ij}, a factor 1/(2*|l_{ij}|^3), ! and a theta function theta(l_{ij}^2 < Msoft^2). ! ! 1 February 2003 ! 15 June 2003 ! ! Factor in msoftsq =(msoftfactor*rts0*onemthrust)**2 real(kind=dbl) :: msoftfactor common /softcutoff/ msoftfactor ! integer :: mu real(kind=dbl) :: qisq,qjsq,absqi,absqj real(kind=dbl) :: hatqi(3),hatqj(3),hatl(3) real(kind=dbl) :: cosli,coslj,cosij real(kind=dbl) :: msoftsq,fijR real(kind=dbl) :: rts0,thrust0 ! qisq = 0.0d0 qjsq = 0.0d0 DO mu = 1,3 qisq = qisq + qi(mu)**2 qjsq = qjsq + qj(mu)**2 END DO absqi = sqrt(qisq) absqj = sqrt(qjsq) ! ! We need msoftsq, the square of msoftfactor * rts0 * (1 - thrust). ! rts0 = absqi + absqj + absqk thrust0 = 2.0d0 * max(absqi,absqj,absqk) /rts0 msoftsq = ( msoftfactor * rts0 *(1.0d0 - thrust0) )**2 ! ! Now we can implement the theta(l_{ij}^2 < Msoft^2). ! IF (absl**2.GT.msoftsq) THEN softfactor = (0.0d0,0.0d0) RETURN END IF ! DO mu = 1,3 hatqi(mu) = qi(mu)/absqi hatqj(mu) = qj(mu)/absqj hatl(mu) = l(mu)/absl END DO cosli = 0.0d0 coslj = 0.0d0 cosij = 0.0d0 DO mu = 1,3 cosli = cosli + hatl(mu)*hatqi(mu) coslj = coslj + hatl(mu)*hatqj(mu) cosij = cosij + hatqi(mu)*hatqj(mu) END DO fijR = (cosij - cosli*coslj)/(1.0d0 - cosli)/(1.0d0 - coslj) fijR = colorfactor*fijR softfactor = fijR/2.0d0/absl**3 ! END subroutine getsoftfactorR ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Feynman integrand in Coulomb gauge, BORN level ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function feynman0(graphnumber,flavorsetnumber,kin,cut) ! use beowulf_parameters implicit none ! In: integer :: graphnumber,flavorsetnumber real(kind=dbl), dimension(0:3*size-1,0:3) :: kin logical, dimension(3*size-1) :: cut ! Out: complex(kind=dbl) :: feynman0 ! ! Feynman integrand function for graph GRAPHNUMBER ! with momenta KIN and cut specified by CUT. This subroutine ! is for the Born graphs in Coulomb gauge. ! Early version: 17 July 1994. ! This version written by Mathematica code of 2 October 2004 on ! 2 Oct 2004. ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) real(kind=dbl), parameter :: gn(0:3) = (/1.0d0,0.0d0,0.0d0,0.0d0/) real(kind=dbl), parameter :: gz(0:3) = (/0.0d0,0.0d0,0.0d0,-1.0d0/) ! integer :: mu real(kind=dbl),dimension(256) :: x real(kind=dbl),dimension(0:3) :: k1,k2,k3,k4,k5 real(kind=dbl) :: e1,e2,e3,e4,e5 real(kind=dbl) :: kz1,kz2,kz3,kz4,kz5 real(kind=dbl) :: k11,k22,k33,k44,k55 real(kind=dbl) :: tk11,tk22,tk33,tk44,tk55 real(kind=dbl) :: prefactor real(kind=dbl) :: result ! real(kind=dbl) :: k1k2,k1k3,k1k4,k2k3,k2k4,k2k5,k3k4,k3k5 ! DO mu = 0,3 k1(mu) = kin(1,mu) k2(mu) = kin(2,mu) k3(mu) = kin(3,mu) k4(mu) = kin(4,mu) k5(mu) = kin(5,mu) END DO result = 0.0d0 ! !------ ! IF (graphnumber .EQ. 11) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,quark,gluon,qbar} ! prefactor = 1.0d0 e1 = k1(0) kz1 = k1(3) tk11 = 0.0d0 e2 = k2(0) kz2 = k2(3) tk22 = 0.0d0 e3 = k3(0) kz3 = k3(3) tk33 = 0.0d0 e4 = k4(0) kz4 = k4(3) tk44 = 0.0d0 e5 = k5(0) kz5 = k5(3) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/sqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/sqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/sqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/sqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/sqrt(-tk55) ELSE prefactor = prefactor/k55 END IF k2k3 = 0.0d0 k2k5 = 0.0d0 k3k5 = 0.0d0 DO mu = 0,3 k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k5 = k2k5 + k2(mu)*k5(mu)*metric(mu) k3k5 = k3k5 + k3(mu)*k5(mu)*metric(mu) END DO x(1) = kz1*kz2*(2*e4*e5*k2k3 + 2*k2k3*k55 + k2k5*(-2*e3*e4 & + 2*k55 + 4*tk44)) x(2) = e4*(2*k3k5*kz1*kz2 + 4*k55*kz1*kz2) + e1*(e4*(-2*e5*k2k3 & + 2*e3*k2k5) + (-2*k2k3 - 2*k2k5)*k55 - 4*k2k5*tk44) x(3) = e1*e4*(-2*k3k5 - 4*k55) x(4) = x(1) + e2*x(2) + e2**2*x(3) x(5) = 0 x(6) = -(e3*k2k5) + e2*k3k5 + e4*(-k2k5 + k3k5) + e5*(2*e2*e4 & + k2k3 + 2*tk44) x(7) = e2 + e3 + 2*e4 + e5 x(8) = x(6) + k55*x(7) x(9) = x(5) + e1*x(8) x(10) = (-(e4*e5) - k3k5 - k55)*kz2 + (-(e4*e5) + k2k5 - k55)*kz3 x(11) = (-e2 + e3)*e4 - k2k3 - k55 - 2*tk44 x(12) = x(10) + kz5*x(11) x(13) = x(9) + kz1*x(12) x(14) = x(4) + k22*x(13) result = (-12*cf*nc*x(14))/tk44 result = result*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {qbar,quark,qbar,gluon,quark} ! prefactor = 1.0d0 e1 = k1(0) kz1 = k1(3) tk11 = 0.0d0 e2 = k2(0) kz2 = k2(3) tk22 = 0.0d0 e3 = k3(0) kz3 = k3(3) tk33 = 0.0d0 e4 = k4(0) kz4 = k4(3) tk44 = 0.0d0 e5 = k5(0) kz5 = k5(3) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/sqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/sqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/sqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/sqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/sqrt(-tk55) ELSE prefactor = prefactor/k55 END IF k2k3 = 0.0d0 k2k5 = 0.0d0 k3k5 = 0.0d0 DO mu = 0,3 k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k5 = k2k5 + k2(mu)*k5(mu)*metric(mu) k3k5 = k3k5 + k3(mu)*k5(mu)*metric(mu) END DO x(1) = kz1*kz2*(2*e4*e5*k2k3 + 2*k2k3*k55 + k2k5*(-2*e3*e4 & + 2*k55 + 4*tk44)) x(2) = e4*(2*k3k5*kz1*kz2 + 4*k55*kz1*kz2) + e1*(e4*(-2*e5*k2k3 & + 2*e3*k2k5) + (-2*k2k3 - 2*k2k5)*k55 - 4*k2k5*tk44) x(3) = e1*e4*(-2*k3k5 - 4*k55) x(4) = x(1) + e2*x(2) + e2**2*x(3) x(5) = 0 x(6) = -(e3*k2k5) + e2*k3k5 + e4*(-k2k5 + k3k5) + e5*(2*e2*e4 & + k2k3 + 2*tk44) x(7) = e2 + e3 + 2*e4 + e5 x(8) = x(6) + k55*x(7) x(9) = x(5) + e1*x(8) x(10) = (-(e4*e5) - k3k5 - k55)*kz2 + (-(e4*e5) + k2k5 - k55)*kz3 x(11) = (-e2 + e3)*e4 - k2k3 - k55 - 2*tk44 x(12) = x(10) + kz5*x(11) x(13) = x(9) + kz1*x(12) x(14) = x(4) + k22*x(13) result = (-12*cf*nc*x(14))/tk44 result = result*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 12) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,qbar,quark,gluon} ! prefactor = 1.0d0 e1 = k1(0) kz1 = k1(3) tk11 = 0.0d0 e2 = k2(0) kz2 = k2(3) tk22 = 0.0d0 e3 = k3(0) kz3 = k3(3) tk33 = 0.0d0 e4 = k4(0) kz4 = k4(3) tk44 = 0.0d0 e5 = k5(0) kz5 = k5(3) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/sqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/sqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/sqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/sqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/sqrt(-tk55) ELSE prefactor = prefactor/k55 END IF k1k2 = 0.0d0 k1k3 = 0.0d0 k1k4 = 0.0d0 k2k3 = 0.0d0 k2k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) k1k3 = k1k3 + k1(mu)*k3(mu)*metric(mu) k1k4 = k1k4 + k1(mu)*k4(mu)*metric(mu) k2k3 = k2k3 + k2(mu)*k3(mu)*metric(mu) k2k4 = k2k4 + k2(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO x(1) = k44*(k33*(e1*e2 - kz1*kz2) + k11*(e2*e3 - kz2*kz3)) & + k22*k33*(e1*e4 - kz1*kz4) + k11*k22*(e3*e4 - kz3*kz4) x(2) = 2*e3*e4*k1k2 + 2*k1k4*k2k3 + k2k4*(-2*e1*e3 + 2*k1k3 & + 2*kz1*kz3) - 2*k1k2*kz3*kz4 + k1k3*(-2*e2*e4 + 2*kz2*kz4) x(3) = 2*e1*e2 - 2*k1k2 - 2*kz1*kz2 x(4) = x(2) + k3k4*x(3) x(5) = x(1) + tk55*x(4) x(6) = -(e3*k11*k2k4) - e1*k2k4*k33 + k44*(e2*k1k3 + e3*(-2*e1*e2 & + kz1*kz2) + e1*kz2*kz3) x(7) = (e3*k22 - e2*k33)*kz1 + (-(e2*k11) + e1*k22)*kz3 x(8) = x(6) + kz4*x(7) x(9) = 2*e2*e3*k11 + (-2*e1*e3 + k1k3)*k22 + 2*e1*e2*k33 + kz2 & *(-(k33*kz1) - k11*kz3) x(10) = x(8) + e4*x(9) x(11) = x(5) + e5*x(10) result = (12*cf*nc*x(11))/tk55 result = result*prefactor ! ! (End flavorset query.) ! END IF !------ ! END IF ! feynman0 = result RETURN END function feynman0 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Vertex and propagator functions in Coulomb gauge ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,out) ! use beowulf_parameters implicit none ! In: character(len=9) :: kind2pt complex(kind=dbl) :: k2pt(0:2,0:3) logical :: cut2pt(0:3) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: out(0:3,0:3) ! ! Calculates the one loop gluon two-point function, including the ! adjoining propagators. ! ! kind2pt: ! GLUONLOOP gluon self-energy with a gluon (including ghost) loop ! QUARKLOOP gluon self-energy with a quark loop ! BOTHLOOPS the sum of these ! ! k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part) ! k2pt(1,mu): 1st momentum in loop (kplus for the space part) ! k2pt(2,mu): 2nd momentum in loop (kminus for the space part) ! ! cut2pt(0): whether incoming line is cut ! cut2pt(1): whether 1st internal line is cut ! cut2pt(2): whether 2nd internal line is cut ! cut2pt(3): whether outgoing line is cut ! ! mumsbar is the MSbar renormalization scale. ! ! The result is the two point function out(mu,nu) with a certain ! normalization. Specifically, for the cut gluon self-energy ! graph, out(mu,nu) is {\cal M}_g^{\mu\nu} ! divided by (\alpha_s/(4\pi)) * 1/(1+\Delta) and divided ! by 2\omega_+ * 2\omega_- *\bar q^2. The factor by which we divide ! consists of ! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and ! one (2\pi)^{-3} for each loop that is factored out of each ! graph in our program. ! * (d\vec l)/(d\bar q^2 dx d\phi) ! = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) ! * 4 \pi {\cal Q} \bar q^2 included in the relation between ! {\cal I}[real] and {\cal M}_g^{\mu\nu} ! ! In the case of the virtual gluon self-energy graphs ! with an adjacent propagator cut, out(mu,nu) is {\cal W}_g^{\mu\nu} ! divided by the same factors. ! ! 16 December 2001 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf integer :: mu,nu complex(kind=dbl) :: complexsqrt complex(kind=dbl) :: kplus(1:3),kminus(1:3),ell(1:3),q(1:3) complex(kind=dbl) :: calqsq, omegaplussq,omegaminussq complex(kind=dbl) :: calq,omegaplus,omegaminus,q0 complex(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq complex(kind=dbl) :: ellt(1:3) complex(kind=dbl) :: elltsq,denom,onem2x1mx,onem4x1mx complex(kind=dbl) :: temp complex(kind=dbl) :: bareprop(1:3,1:3) complex(kind=dbl) :: ntt,nll,nee,nel complex(kind=dbl) :: prefactor complex(kind=dbl) :: termtt,termll complex(kind=dbl) :: at0,at1,at2 complex(kind=dbl) :: ntt0,ntt1,ntt2 complex(kind=dbl) :: net0,net1,net2 complex(kind=dbl) :: utt,net ! ! Some auxilliary variables, including ! CALQ = {\cal Q} ! OMEGAPLUS = \omega_+ ! OMEGAMINUS = \omega_- ! DELTAP1 = \Delta + 1 ! TWOXM1 = 2 x - 1 ! X1MX = x (1-x) ! ELLT(mu) = l_T^\mu ! ELLTSQ = (\vec l_T)^2 ! Q(mu) = the incoming *three*-momentum ! Q0 = the incoming energy ! DO mu = 1,3 kplus(mu) = k2pt(1,mu) kminus(mu) = k2pt(2,mu) ell(mu) = (kplus(mu) - kminus(mu))/2.0d0 q(mu) = k2pt(0,mu) END DO q0 = k2pt(0,0) calqsq = 0.0d0 omegaplussq = 0.0d0 omegaminussq = 0.0d0 DO mu = 1,3 calqsq = calqsq + q(mu)**2 omegaplussq = omegaplussq + kplus(mu)**2 omegaminussq = omegaminussq + kminus(mu)**2 END DO calq = complexsqrt(calqsq) omegaplus = complexsqrt(omegaplussq) omegaminus = complexsqrt(omegaminussq) deltap1 = (omegaplus + omegaminus)/calq delta = deltap1 - 1.0d0 twoxm1 = (omegaplus - omegaminus)/calq x1mx = (1.0d0 - twoxm1**2)/4.0d0 qbarsq = calqsq * delta * (delta + 2.0d0) DO mu = 1,3 ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu) END DO elltsq = qbarsq*x1mx denom = qbarsq/calqsq + 4.0d0*x1mx onem2x1mx = 1.0d0 - 2.0d0*x1mx onem4x1mx = 1.0d0 - 4.0d0*x1mx ! ! The gluon propagator in Coulomb gauge for an on-shell gluon ! with three-momentum Q(mu). This is the space components only. ! DO mu = 1,3 bareprop(mu,mu) = 1.0d0 - q(mu)**2/calqsq DO nu = mu+1,3 temp = - q(mu)*q(nu)/calqsq bareprop(mu,nu) = temp bareprop(nu,mu) = temp END DO END DO ! IF (cut2pt(1).AND.cut2pt(2)) THEN ! ! We have the contribution from a cut self-energy diagram. ! We compute the coefficients for, alternatively, the gluon loop ! or the quark loop. We use the name NLL for Ntt and NEL for NEt. ! IF (kind2pt.EQ.'gluonloop') THEN ! ntt = x1mx ntt = ntt + 8.0d0*x1mx*(1.0d0 - x1mx)/denom ntt = ntt + 16.0d0*x1mx*(onem4x1mx + 2.0d0*x1mx**2)/denom**2 ntt = ntt * 2.0d0 * nc nll = x1mx nll = nll - 8.0d0*x1mx**2/denom nll = nll + 32.0d0*x1mx**3/denom**2 nll = nll * 4.0d0 * nc nee = onem4x1mx nee = nee - 8.0d0*x1mx*onem4x1mx/denom nee = nee + 32.0d0*x1mx**2*onem4x1mx/denom**2 nee = nee * nc nel = -1.0d0 nel = nel - 2.0d0*onem4x1mx/denom nel = nel + 16.0d0*x1mx*onem2x1mx/denom**2 nel = nel * 2.0d0 * nc * twoxm1 ! ELSE IF (kind2pt.EQ.'quarkloop') THEN ! ntt = nf*onem2x1mx nll = - 4.0d0*nf*x1mx nee = 4.0d0*nf*x1mx nel = 2.0d0*nf*twoxm1 ! ELSE IF (kind2pt.EQ.'bothloops') THEN ! ntt = x1mx ntt = ntt + 8.0d0*x1mx*(1.0d0 - x1mx)/denom ntt = ntt + 16.0d0*x1mx*(onem4x1mx + 2.0d0*x1mx**2)/denom**2 ntt = ntt * 2.0d0 * nc nll = x1mx nll = nll - 8.0d0*x1mx**2/denom nll = nll + 32.0d0*x1mx**3/denom**2 nll = nll * 4.0d0 * nc nee = onem4x1mx nee = nee - 8.0d0*x1mx*onem4x1mx/denom nee = nee + 32.0d0*x1mx**2*onem4x1mx/denom**2 nee = nee * nc nel = -1.0d0 nel = nel - 2.0d0*onem4x1mx/denom nel = nel + 16.0d0*x1mx*onem2x1mx/denom**2 nel = nel * 2.0d0 * nc * twoxm1 ! ntt = ntt + nf*onem2x1mx nll = nll - 4.0d0*nf*x1mx nee = nee + 4.0d0*nf*x1mx nel = nel + 2.0d0*nf*twoxm1 ! ELSE write(nout,*)'Unrecognized type in subroutine twopointg.' stop END IF ! ! With the coefficients in hand, we compute the result. ! prefactor = 1.0d0/(4.0d0*omegaplus*omegaminus*qbarsq) ! out(0,0) = prefactor*qbarsq/calqsq*nee DO mu = 1,3 temp = prefactor*q0/deltap1/calqsq*nel*ellt(mu) out(0,mu) = temp out(mu,0) = temp END DO DO mu = 1,3 DO nu = 1,3 termtt = ntt*bareprop(mu,nu) termll = nll*(ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu)) out(mu,nu) = prefactor*(termtt + termll) END DO END DO ! ! Alternative for IF (CUT2PT(1).AND.CUT2PT(2)) THEN .... ! ELSE IF (cut2pt(0).OR.cut2pt(3)) THEN ! ! We have the contribution from a virtual self-energy diagram ! with one of the neighboring propagators cut. ! We compute the coefficients for, alternatively, the gluon loop ! or the quark loop. ! IF (kind2pt.EQ.'gluonloop') THEN ! temp = mumsbar**2*exp(2.0d0) at0 = - 2.0d0*nc*temp/(qbarsq + temp) temp = mumsbar**2*exp(5.0d0/3.0d0) at0 = at0 + 2.0d0*nc*x1mx*temp/(qbarsq + temp) temp = mumsbar**2*exp(8.0d0/3.0d0) at0 = at0 + 4.0d0*nc*x1mx*temp/(qbarsq + temp) at1 = 24.0d0*nc*x1mx*onem2x1mx at2 = 32.0d0*nc*x1mx*(onem4x1mx + 4.0d0*x1mx**2) ntt0 = 4.0d0*nc*x1mx ntt1 = - 32.0d0*nc*x1mx**2 ntt2 = 128.0d0*nc*x1mx**3 net0 = - 2.0d0*nc*twoxm1 net1 = - 4.0d0*nc*twoxm1*onem4x1mx net2 = 32.0d0*nc*twoxm1*x1mx*onem2x1mx ! utt = at0 + at1/denom + at2/denom**2 ntt = ntt0 + ntt1/denom + ntt2/denom**2 net = net0 + net1/denom + net2/denom**2 ! ELSE IF (kind2pt.EQ.'quarkloop') THEN ! ! Here AT1 = AT2 = NTT1 = NTT2 = NET1 = NET2 = 0. ! temp = mumsbar**2*exp(2.0d0) at0 = nf*temp/(qbarsq + temp) temp = mumsbar**2*exp(8.0d0/3.0d0) at0 = at0 - 2.0d0*nf*x1mx*temp/(qbarsq + temp) at1 = 0.0d0 at2 = 0.0d0 ntt0 = - 4.0d0*nf*x1mx net0 = 2.0d0*nf*twoxm1 ! utt = at0 ntt = ntt0 net = net0 ! ELSE IF (kind2pt.EQ.'bothloops') THEN ! temp = mumsbar**2*exp(2.0d0) at0 = - 2.0d0*nc*temp/(qbarsq + temp) temp = mumsbar**2*exp(5.0d0/3.0d0) at0 = at0 + 2.0d0*nc*x1mx*temp/(qbarsq + temp) temp = mumsbar**2*exp(8.0d0/3.0d0) at0 = at0 + 4.0d0*nc*x1mx*temp/(qbarsq + temp) at1 = 24.0d0*nc*x1mx*onem2x1mx at2 = 32.0d0*nc*x1mx*(onem4x1mx + 4.0d0*x1mx**2) ntt0 = 4.0d0*nc*x1mx ntt1 = - 32.0d0*nc*x1mx**2 ntt2 = 128.0d0*nc*x1mx**3 net0 = - 2.0d0*nc*twoxm1 net1 = - 4.0d0*nc*twoxm1*onem4x1mx net2 = 32.0d0*nc*twoxm1*x1mx*onem2x1mx ! utt = at0 + at1/denom + at2/denom**2 ntt = ntt0 + ntt1/denom + ntt2/denom**2 net = net0 + net1/denom + net2/denom**2 ! temp = mumsbar**2*exp(2.0d0) at0 = nf*temp/(qbarsq + temp) temp = mumsbar**2*exp(8.0d0/3.0d0) at0 = at0 - 2.0d0*nf*x1mx*temp/(qbarsq + temp) at1 = 0.0d0 at2 = 0.0d0 ntt0 = - 4.0d0*nf*x1mx net0 = 2.0d0*nf*twoxm1 ! utt = utt + at0 ntt = ntt + ntt0 net = net + net0 ! ELSE write(nout,*)'Unrecognized type in subroutine twopointg.' stop END IF ! ! With the coefficients in hand, we compute the result. There is ! an extra factor 1 + \Delta compared to the real self-energy ! graphs because {\cal W} lacks the factor 1/(1 + \Delta) that ! appears in {\cal M}. ! ! Also, we divide by 2 because we will get this contribution ! twice, once when one adjacent propagator is cut and onece ! when the other adjacent propagator is cut. ! prefactor = - deltap1/(4.0d0*omegaplus*omegaminus*qbarsq) prefactor = 0.5d0*prefactor ! out(0,0) = 0.0d0 DO mu = 1,3 temp = prefactor*q0/deltap1/calqsq/(1 + qbarsq/calqsq) temp = temp*net*ellt(mu) out(0,mu) = temp out(mu,0) = temp END DO DO mu = 1,3 DO nu = 1,3 termtt = utt*bareprop(mu,nu) temp = ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu) termll = ntt/(1 + qbarsq/calqsq)*temp out(mu,nu) = prefactor*(termtt + termll) END DO END DO ! ! Closing for IF (CUT2PT(1).AND.CUT2PT(2)) THEN ....ELSE IF ... ! ELSE write(nout,*)'For a gluon two point function,' write(nout,*)'either the self-energy graph must be cut' write(nout,*)'or one of the neighboring propagators' write(nout,*)'must be cut.' stop END IF ! RETURN END subroutine twopointg ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine twopointq(k2pt,cut2pt,mumsbar,flag,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: k2pt(0:2,0:3) logical :: cut2pt(0:3) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: out(0:3) ! ! Calculates the one loop quark two-point function, including the ! adjoining propagators. ! ! k2pt(0,mu): incoming momentum (q = kplus + kminus for the space part) ! k2pt(1,mu): 1st momentum in loop (kplus for the space part) ! k2pt(2,mu): 2nd momentum in loop (kminus for the space part) ! ! cut2pt(0): whether incoming line is cut ! cut2pt(1): whether 1st internal line is cut ! cut2pt(2): whether 2nd internal line is cut ! cut2pt(3): whether outgoing line is cut ! ! mumsbar is the MSbar renormalization scale. ! ! The two point function, with a certain normalization, ! is represented as out^mu gamma_mu. ! For the real quark self-energy graphs, out^{\mu} gamma_{\mu} ! is {\cal M}_q divided by ! (\alpha_s/(4\pi)) * 1/(1+\Delta) ! and divided by ! 4 * \omega_+ * \omega_- * \bar q^2. ! The factor by which we divide consists of ! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and ! one (2\pi)^{-3} for each loop that is factored out of each ! graph in our program. ! * (d\vec l)/(d\bar q^2 dx d\phi) ! = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) ! * 4 \pi {\cal Q} \bar q^2 included in the relation between ! {\cal I}[real] and {\cal M}_q. ! ! In the case of the virtual quark self-energy graphs with ! one of the adjacent propagators cut, OUT^{\mu} gamma_{\mu} ! is {\cal W}_q divided by the same factors. ! ! In the case of the virtual quark self-energy graphs with ! the adjacent propagators *not* cut, OUT^{\mu} gamma_{\mu} ! is W_q divided by ! (\alpha_s/(4\pi)) * 1/(1+\Delta) ! and divided by ! 2 * \omega_+ * \omega_- * (\bar q^2 - q^2) * q^2/{\cal Q}. ! The factor by which we divide consists of ! * g^2/(2\pi)^3 = \alpha_s/(2 \pi^2) , one g for each vertex and ! one (2\pi)^{-3} for each loop that is factored out of each ! graph in our program. ! * (d\vec l)/(d\bar q^2 dx d\phi) ! = (2\omega_+ * 2\omega_-) /(8 {\cal Q} ( 1 + \Delta)) ! * 2 \pi q^2 (\bar q^2 - q^2) included in the relation between ! {\cal I}[all uncut] and W_q. ! ! 2 January 2001 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf complex(kind=dbl) :: complexsqrt integer :: mu complex(kind=dbl) :: kplus(1:3),kminus(1:3),ell(1:3),q(1:3) complex(kind=dbl) :: calqsq,omegaplussq,omegaminussq complex(kind=dbl) :: calq,omegaplus,omegaminus complex(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq complex(kind=dbl) :: ellt(1:3) complex(kind=dbl) :: elltsq,denom,onem2x1mx,onem4x1mx,x complex(kind=dbl) :: temp,tempsq complex(kind=dbl) :: nl,ne,nt,prefactor complex(kind=dbl) :: bl0,bl1,bl2 complex(kind=dbl) :: nl0,nl1,nl2 complex(kind=dbl) :: nt0,nt1,nt2 complex(kind=dbl) :: ul,vl,vt complex(kind=dbl) :: q0,qsq complex(kind=dbl) :: be0,be1,be2 complex(kind=dbl) :: ue ! ! Some auxilliary variables, including ! CALQ = {\cal Q} ! OMEGAPLUS = \omega_+ ! OMEGAMINUS = \omega_- ! DELTAP1 = \Delta + 1 ! TWOXM1 = 2 x - 1 ! X1MX = x (1-x) ! ELLT(mu) = l_T^\mu ! ELLTSQ = (\vec l_T)^2 ! Q(mu) = the incoming *three*-momentum ! Q0 = the incoming energy ! DO mu = 1,3 kplus(mu) = k2pt(1,mu) kminus(mu) = k2pt(2,mu) ell(mu) = (kplus(mu) - kminus(mu))/2.0d0 q(mu) = k2pt(0,mu) END DO q0 = k2pt(0,0) calqsq = 0.0d0 omegaplussq = 0.0d0 omegaminussq = 0.0d0 DO mu = 1,3 calqsq = calqsq + q(mu)**2 omegaplussq = omegaplussq + kplus(mu)**2 omegaminussq = omegaminussq + kminus(mu)**2 END DO calq = complexsqrt(calqsq) omegaplus = complexsqrt(omegaplussq) omegaminus = complexsqrt(omegaminussq) deltap1 = (omegaplus + omegaminus)/calq delta = deltap1 - 1.0d0 twoxm1 = (omegaplus - omegaminus)/calq x1mx = (1.0d0 - twoxm1**2)/4.0d0 qbarsq = calqsq * delta * (delta + 2.0d0) DO mu = 1,3 ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu) END DO elltsq = qbarsq*x1mx denom = qbarsq/calqsq + 4.0d0*x1mx onem2x1mx = 1.0d0 - 2.0d0*x1mx onem4x1mx = 1.0d0 - 4.0d0*x1mx x = (twoxm1 + 1.0d0)/2.0d0 ! ! Now we will go through these possible cut structures and ! calculate the terms contributing to out(mu). ! IF ( cut2pt(1).AND.cut2pt(2) ) THEN ! ! First possibility for cut structure: a cut self-energy diagram. ! Here TEMP = 2 x + Delta. ! temp = twoxm1 + deltap1 tempsq = temp**2 nl = 12.0d0*x1mx + twoxm1*temp nl = nl - 16.0d0*x1mx*twoxm1/temp + 16.0d0*x1mx*onem2x1mx/tempsq nl = cf*nl ne = 2.0d0*cf*(1.0d0 - x)*(4.0d0*x**2 + delta**2)/tempsq nt = 1.0d0 - 2.0d0*twoxm1/temp - 8.0d0*x1mx/tempsq nt = 2.0d0*cf*nt ! prefactor = 1.0d0/(4.0d0*omegaplus*omegaminus*qbarsq) out(0) = prefactor*q0/deltap1*(nl + delta*ne) DO mu = 1,3 out(mu) = prefactor*(nl*q(mu) + nt*ellt(mu)) END DO ! ELSE IF ( cut2pt(0).OR.cut2pt(3) ) THEN ! ! Second possibility for cut structure: a virtual self-energy ! with an adjacent propagator cut. ! temp = mumsbar**2 * exp(3.0d0) bl0 = - temp/(qbarsq + temp) temp = mumsbar**2 * exp(5.0d0/3.0d0) bl0 = bl0 + 12.0d0*x1mx*temp/(qbarsq + temp) bl0 = cf*bl0 bl1 = 8.0d0*cf*x1mx*(5.0d0 - 14.0d0*x1mx) bl2 = 32.0d0*cf*x1mx*(1.0d0 - 6.0d0*x1mx + 8.0d0*x1mx**2) nl0 = cf*twoxm1 nl1 = - 16.0d0*cf*twoxm1*x1mx nl2 = - 32.0d0*cf*twoxm1*x1mx*onem2x1mx nt0 = 2.0d0*cf nt1 = - 4.0d0*cf*twoxm1 nt2 = - 16.0d0*cf*x1mx ul = bl0 + bl1/denom + bl2/denom**2 vl = nl0 + nl1/denom + nl2/denom**2 temp = delta + 2.0d0*x vt = nt0 + nt1/temp + nt2/temp**2 ! ! We divide by 2 because we will get this contribution ! twice, once when one adjacent propagator is cut and once ! when the other adjacent propagator is cut. ! prefactor = deltap1/(4.0d0*omegaplus*omegaminus*qbarsq) prefactor = 0.5d0*prefactor ! temp = ul + vl/(1.0d0 + qbarsq/calqsq) out(0) = - prefactor*q0*temp DO mu = 1,3 out(mu) = - prefactor*(temp*q(mu) & + vt*ellt(mu)/(1.0d0 + qbarsq/calqsq)) END DO ! ELSE ! ! Third possibility for cut structure: a virtual self-energy ! with *no* adjacent propagator cut. ! qsq = q0**2 - calqsq ! temp = mumsbar**2 * exp(3.0d0) bl0 = - (qsq + temp)/(qbarsq + temp) temp = mumsbar**2 * exp(5.0d0/3.0d0) bl0 = bl0 + 12.0d0*x1mx*(qsq + temp)/(qbarsq + temp) bl0 = cf*bl0 bl1 = 20.0d0*x1mx - 56.0d0*x1mx**2 + qsq/calqsq*onem2x1mx bl1 = 2.0d0*cf*bl1 bl2 = 32.0d0*cf*x1mx*(1.0d0 - 6.0d0*x1mx + 8.0d0*x1mx**2) be0 = 0.0d0 be1 = -8.0d0*cf*x1mx be2 = -16.0d0*cf*x1mx*onem4x1mx ul = bl0 + bl1/denom + bl2/denom**2 ue = be0 + be1/denom + be2/denom**2 ! prefactor = 2.0d0*omegaplus*omegaminus*qsq*(qbarsq - qsq) prefactor = deltap1*calq/prefactor out(0) = - prefactor*q0*(ul + qsq/calqsq*ue) DO mu = 1,3 out(mu) = - prefactor*q(mu)*ul END DO ! ! Completion of IF ... block for cut structure. ! END IF ! RETURN END subroutine twopointq ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,hv,ha) ! use beowulf_parameters implicit none ! In: character(len=7) :: kind3pt complex(kind=dbl) :: k3pt(3,0:3) logical :: cut3pt(3) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: hv(0:3,0:3),ha(0:3,0:3) ! ! The unintegrated quark-antiquark-gluon three point function ! for the graph with flavors labelled by KIND3PT. ! ! KIND3PT has the form abc/def where a,...,f are chosen from ! Q,G,P. Here Q denotes "quark" or "antiquark", G denotes "gluon", ! and P denotes "photon". The external lines have flavors a,b,c ! and the internal lines have flavors d,e,f. The possibilities ! are QQG/QQG, QQG/GGQ, and QQP/QQG. There is also QQG/ALL, which ! gives the sum of the results for QQG/QQG and QQG/GGQ. ! ! The unintegrated three-point function \Gamma^\mu can be decomposed ! into a function HV^\mu_\nu \gamma^\mu plus a function ! HA^\mu_\nu I \gamma^\mu \gamma_5 (all times a t^a color matrix or a ! unit color matrix in the case of a QQP vertex). This subroutine ! calculates the functions HV^{\mu\nu} and HA^{\mu\nu}. The arguments ! are the momenta k3pt(1,mu), k3pt(2,mu), k3pt(3,mu), of the propagators ! around the loop. ! ! The variable cut3pt(j) is .true. if line j is cut, .false. otherwise. ! If the line is cut, the corresponding energy is set by the calling ! programs to be k0 = + |\vec k| or else k0 = - |\vec k|. (Here ! |\vec k| is a shorthand for sqrt(\vec k^2), not the square root of ! \vec k dotted into its complex conjugate.) This subroutine supplies a ! factor k(j)^2 for uncut propagators and 2 sqrt(\vec k^2) for a cut ! propagator. For a virtual loop, subroutine vertex will be called six ! times, once with each of the three propagators cut and k0 = + |\vec k| ! and once with each of the three propagators cut and k0 = - |\vec k|. ! Then it will be called with no propagator cut, which implies that it ! should supply the renormalization counter term. ! ! 31 December 2001 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf complex(kind=dbl) :: complexsqrt ! complex(kind=dbl), parameter :: nvec(0:3) = & (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) real(kind=dbl), parameter :: g(0:3,0:3) = reshape( & (/1.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0,-1.0d0, 0.0d0, 0.0d0, & 0.0d0, 0.0d0,-1.0d0, 0.0d0, & 0.0d0, 0.0d0, 0.0d0,-1.0d0/)& ,(/4,4/)) ! complex(kind=dbl) :: tk11,tk22,tk33,tk12,tk23,tk13 complex(kind=dbl) :: k11,k22,k33,k12,k23,k13 complex(kind=dbl) :: e1,e2,e3 complex(kind=dbl) :: c1,c2,c3,c4,c5,c6,c7,c8,c9 complex(kind=dbl) :: c10,c11,c12,c13,c14,c15,c16,c17 complex(kind=dbl) :: temp,prefactor integer :: mu,nu complex(kind=dbl) :: k1(0:3),k2(0:3),k3(0:3) complex(kind=dbl) :: epsn1(0:3,0:3),epsn2(0:3,0:3),epsn3(0:3,0:3) complex(kind=dbl) :: eps12(0:3,0:3),eps13(0:3,0:3),eps23(0:3,0:3) complex(kind=dbl) :: epsn12(0:3),epsn13(0:3),epsn23(0:3),eps123(0:3) complex(kind=dbl) :: tl(0:3),omegasq,omega,cr1,cr2,cr3 integer :: ncut,p ! !----- ! ncut = 0 DO p=1,3 IF (cut3pt(p)) THEN ncut = ncut + 1 END IF END DO ! IF ((ncut.GT.1).OR.(flag.NE.'renormalize 3 pt')) THEN ! ! If NCUT = 1, we have a virtual loop. In this case, one of the ! possibilities is the renormalization counter term, for which ! FLAG would have been set to 'renormalize 3 pt'. Thus we get ! here is we do *not* have the the renormalization counter term. ! (Note that we could have NCUT = 2 but FLAG = 'renormalize 3 pt' ! in the case that there are two three point functions and ours ! is cut but the other one is virtual and needs to be renormalized.) ! ! First, dot products and energies. The dot products between vectors ! omitting their mu = 0 parts (\tilde vector) are denoted TKij. ! tk11 = (0.0d0,0.0d0) tk22 = (0.0d0,0.0d0) tk33 = (0.0d0,0.0d0) tk12 = (0.0d0,0.0d0) tk23 = (0.0d0,0.0d0) tk13 = (0.0d0,0.0d0) DO mu = 1,3 tk11 = tk11 - k3pt(1,mu)*k3pt(1,mu) tk22 = tk22 - k3pt(2,mu)*k3pt(2,mu) tk33 = tk33 - k3pt(3,mu)*k3pt(3,mu) tk12 = tk12 - k3pt(1,mu)*k3pt(2,mu) tk23 = tk23 - k3pt(2,mu)*k3pt(3,mu) tk13 = tk13 - k3pt(1,mu)*k3pt(3,mu) END DO e1 = k3pt(1,0) e2 = k3pt(2,0) e3 = k3pt(3,0) k11 = e1*e1 + tk11 k22 = e2*e2 + tk22 k33 = e3*e3 + tk33 k12 = e1*e2 + tk12 k23 = e2*e3 + tk23 k13 = e1*e3 + tk13 ! ! We need the factor equal to 1/k^2 for an uncut propagator ! and 1/ 2|E| for a cut propagator. ! prefactor = (1.0d0,0.0d0) IF (.NOT.cut3pt(1)) THEN prefactor = prefactor/k11 ELSE prefactor = prefactor/(2.0d0*complexsqrt(-tk11)) END IF IF (.NOT.cut3pt(2)) THEN prefactor = prefactor/k22 ELSE prefactor = prefactor/(2.0d0*complexsqrt(-tk22)) END IF IF (.NOT.cut3pt(3)) THEN prefactor = prefactor/k33 ELSE prefactor = prefactor/(2.0d0*complexsqrt(-tk33)) END IF ! !------------------------ ! First, we calculate hv. !------------------------ ! Generate the coefficients for the hv, depending on KIND3PT. ! IF (kind3pt.EQ.'qqg/qqg') THEN ! c1 = -(k12*(-2*e3**2 + k33 - 2*tk33))/(2.0d0*nc*tk33) c2 = 0.0d0 c3 = 0.0d0 c4 = 0.0d0 c5 = -((e3*k12)/(nc*tk33)) c6 = (e3*k23)/(nc*tk33) c7 = (e3*k13)/(nc*tk33) c8 = -((e3*k12)/(nc*tk33)) c9 = 0.0d0 c10 = (-2*e3**2 + k33 - 2*tk33)/(2.0d0*nc*tk33) c11 = -((-(e2*e3) + k23)/(nc*tk33)) c12 = (-2*e3**2 + k33 - 2*tk33)/(2.0d0*nc*tk33) c13 = 0.0d0 c14 = -((-(e1*e3) + k13)/(nc*tk33)) c15 = 0.0d0 c16 = 0.0d0 c17 = k12/(nc*tk33) ! ELSE IF (kind3pt.EQ.'qqg/ggq') THEN ! c1 = -(nc*((-(e2**2*k23) + (-2*k12 + k22)*k23 + e2*(e3*(2*k12 & - k22) + 2*e1*k23))*tk11 + (e1*e3*(-k11 + 2*k12) - e1**2*k13 & + 2*e1*e2*k13 + (k11 - 2*k12)*k13 + (k13 & + k23)*tk11)*tk22))/(2.0d0*tk11*tk22) c2 = -(e1*e2*(2*k12*k13 - k13*k22 - k11*k23 & + 2*k12*k23)*nc)/(2.0d0*tk11*tk22) c3 = -(nc*(e1**2*e2*k23 + e2*k23*(k11 - 2*k12 - tk11) + e1*(e2 & *(2*e3*k12 - e3*k22) + k23*(e2**2 - 2*k12 + k22 - tk22) & + 4*k13*tk22)))/(2.0d0*tk11*tk22) c4 = (nc*(-(e1*e2**2*k13) + e2*(e1*(e3*k11 - 2*e3*k12) & - 4*k23*tk11 + k13*(-e1**2 - k11 + 2*k12 + tk11)) + e1*k13*(2*k12 & - k22 + tk22)))/(2.0d0*tk11*tk22) c5 = (nc*(e1*e2**2*(-k11 + 3*k12) + e2*(-2*k12**2 + e1**2*(3*k12 & - k22) + k22*tk11 + k12*(k11 + tk11)) + e1*(-2*k12**2 + k11*tk22 & + k12*(k22 + tk22))))/(2.0d0*tk11*tk22) c6 = (nc*(e1*e2**2*(k13 + k23) + e2*(k12*k13 - k13*k22 + e1 & *(-2*e3*k12 + 2*e3*k22) - e1**2*k23 + 2*k23*tk11) + e1*k23*(k12 & - k22 + tk22)))/(2.0d0*tk11*tk22) c7 = (nc*(-(e1*e2**2*k13) + e2*(e1*(2*e3*k11 - 2*e3*k12) + e1**2 & *(k13 + k23) + k13*(-k11 + k12 + tk11)) + e1*((-k11 + k12)*k23 & + 2*k13*tk22)))/(2.0d0*tk11*tk22) c8 = (nc*(-2*e2*k12*tk11 + e2*k22*tk11 + e1*k11*tk22 & - 2*e1*k12*tk22))/(2.0d0*tk11*tk22) c9 = (nc*(e1*e2**2*e3 + e2*e3*k12 - e2*e3*k22 + e1*e2*k23 & - e2**2*k23 - k12*k23 + k22*k23 + 2*k13*tk22 & - k23*tk22))/(2.0d0*tk11*tk22) c10 = -(nc*(-(e1*e2*k13) + e2**2*k13 + 2*k23*tk11 + e3*(e1**2*e2 & - 2*e2*tk11 + e1*(-e2**2 - k12 + k22 - tk22)) + k13*(k12 - k22 & + tk22)))/(2.0d0*tk11*tk22) c11 = (nc*(-(e1*e2**3) + k12**2 + e2**2*(k12 - 2*tk11) + k22*tk11 & + k12*(-k22 - tk22) - e1**2*tk22 - tk11*tk22 + e1*e2*(-2*k12 & + k22 + tk22)))/(2.0d0*tk11*tk22) c12 = -(nc*(e1**2*k23 - e1*e2*k23 + k23*(-k11 + k12 + tk11) & + 2*k13*tk22 + e3*(e1*e2**2 + e2*(-e1**2 + k11 - k12 - tk11) & - 2*e1*tk22)))/(2.0d0*tk11*tk22) c13 = (nc*(e1**2*e2*e3 - e1*e3*k11 + e1*e3*k12 - e1**2*k13 & + e1*e2*k13 + k11*k13 - k12*k13 - k13*tk11 & + 2*k23*tk11))/(2.0d0*tk11*tk22) c14 = -(nc*(e1**3*e2 - k12**2 + e1*e2*(-k11 + 2*k12 - tk11) & + e2**2*tk11 + k12*(k11 + tk11) - k11*tk22 + tk11*tk22 + e1**2 & *(-k12 + 2*tk22)))/(2.0d0*tk11*tk22) c15 = -(nc*(-e1**2 + 2*e1*e2 + k11 - 2*k12 + tk11))/(2.0d0*tk11) c16 = (nc*(-2*e1*e2 + e2**2 + 2*k12 - k22 - tk22))/(2.0d0*tk22) c17 = 0.0d0 ! ELSE IF (kind3pt.EQ.'qqg/all') THEN ! c1 = -(nc*((-(e2**2*k23) + (-2*k12 + k22)*k23 + e2*(e3*(2*k12 & - k22) + 2*e1*k23))*tk11 + (e1*e3*(-k11 + 2*k12) - e1**2*k13 & + 2*e1*e2*k13 + (k11 - 2*k12)*k13 + (k13 & + k23)*tk11)*tk22))/(2.0d0*tk11*tk22) c2 = -(e1*e2*(2*k12*k13 - k13*k22 - k11*k23 & + 2*k12*k23)*nc)/(2.0d0*tk11*tk22) c3 = -(nc*(e1**2*e2*k23 + e2*k23*(k11 - 2*k12 - tk11) + e1*(e2 & *(2*e3*k12 - e3*k22) + k23*(e2**2 - 2*k12 + k22 - tk22) & + 4*k13*tk22)))/(2.0d0*tk11*tk22) c4 = (nc*(-(e1*e2**2*k13) + e2*(e1*(e3*k11 - 2*e3*k12) & - 4*k23*tk11 + k13*(-e1**2 - k11 + 2*k12 + tk11)) + e1*k13*(2*k12 & - k22 + tk22)))/(2.0d0*tk11*tk22) c5 = (nc*(e1*e2**2*(-k11 + 3*k12) + e2*(-2*k12**2 + e1**2*(3*k12 & - k22) + k22*tk11 + k12*(k11 + tk11)) + e1*(-2*k12**2 + k11*tk22 & + k12*(k22 + tk22))))/(2.0d0*tk11*tk22) c6 = (nc*(e1*e2**2*(k13 + k23) + e2*(k12*k13 - k13*k22 + e1 & *(-2*e3*k12 + 2*e3*k22) - e1**2*k23 + 2*k23*tk11) + e1*k23*(k12 & - k22 + tk22)))/(2.0d0*tk11*tk22) c7 = (nc*(-(e1*e2**2*k13) + e2*(e1*(2*e3*k11 - 2*e3*k12) + e1**2 & *(k13 + k23) + k13*(-k11 + k12 + tk11)) + e1*((-k11 + k12)*k23 & + 2*k13*tk22)))/(2.0d0*tk11*tk22) c8 = (nc*(-2*e2*k12*tk11 + e2*k22*tk11 + e1*k11*tk22 & - 2*e1*k12*tk22))/(2.0d0*tk11*tk22) c9 = (nc*(e1*e2**2*e3 + e2*e3*k12 - e2*e3*k22 + e1*e2*k23 & - e2**2*k23 - k12*k23 + k22*k23 + 2*k13*tk22 & - k23*tk22))/(2.0d0*tk11*tk22) c10 = -(nc*(-(e1*e2*k13) + e2**2*k13 + 2*k23*tk11 + e3*(e1**2*e2 & - 2*e2*tk11 + e1*(-e2**2 - k12 + k22 - tk22)) + k13*(k12 - k22 & + tk22)))/(2.0d0*tk11*tk22) c11 = (nc*(-(e1*e2**3) + k12**2 + e2**2*(k12 - 2*tk11) + k22*tk11 & + k12*(-k22 - tk22) - e1**2*tk22 - tk11*tk22 + e1*e2*(-2*k12 & + k22 + tk22)))/(2.0d0*tk11*tk22) c12 = -(nc*(e1**2*k23 - e1*e2*k23 + k23*(-k11 + k12 + tk11) & + 2*k13*tk22 + e3*(e1*e2**2 + e2*(-e1**2 + k11 - k12 - tk11) & - 2*e1*tk22)))/(2.0d0*tk11*tk22) c13 = (nc*(e1**2*e2*e3 - e1*e3*k11 + e1*e3*k12 - e1**2*k13 & + e1*e2*k13 + k11*k13 - k12*k13 - k13*tk11 & + 2*k23*tk11))/(2.0d0*tk11*tk22) c14 = -(nc*(e1**3*e2 - k12**2 + e1*e2*(-k11 + 2*k12 - tk11) & + e2**2*tk11 + k12*(k11 + tk11) - k11*tk22 + tk11*tk22 + e1**2 & *(-k12 + 2*tk22)))/(2.0d0*tk11*tk22) c15 = -(nc*(-e1**2 + 2*e1*e2 + k11 - 2*k12 + tk11))/(2.0d0*tk11) c16 = (nc*(-2*e1*e2 + e2**2 + 2*k12 - k22 - tk22))/(2.0d0*tk22) c17 = 0.0d0 ! c1 = c1 - (k12*(-2*e3**2 + k33 - 2*tk33))/(2.0d0*nc*tk33) c5 = c5 - ((e3*k12)/(nc*tk33)) c6 = c6 + (e3*k23)/(nc*tk33) c7 = c7 + (e3*k13)/(nc*tk33) c8 = c8 - ((e3*k12)/(nc*tk33)) c10 = c10 + (-2*e3**2 + k33 - 2*tk33)/(2.0d0*nc*tk33) c11 = c11 - ((-(e2*e3) + k23)/(nc*tk33)) c12 = c12 + (-2*e3**2 + k33 - 2*tk33)/(2.0d0*nc*tk33) c14 = c14 - ((-(e1*e3) + k13)/(nc*tk33)) c17 = c17 + k12/(nc*tk33) ! ELSE IF (kind3pt.EQ.'qqp/qqg') THEN ! c1 = (cf*k12*(-2*e3**2 + k33 - 2*tk33))/tk33 c2 = 0.0d0 c3 = 0.0d0 c4 = 0.0d0 c5 = (2*cf*e3*k12)/tk33 c6 = (-2*cf*e3*k23)/tk33 c7 = (-2*cf*e3*k13)/tk33 c8 = (2*cf*e3*k12)/tk33 c9 = 0.0d0 c10 = -((cf*(-2*e3**2 + k33 - 2*tk33))/tk33) c11 = (2*cf*(-(e2*e3) + k23))/tk33 c12 = -((cf*(-2*e3**2 + k33 - 2*tk33))/tk33) c13 = 0.0d0 c14 = (2*cf*(-(e1*e3) + k13))/tk33 c15 = 0.0d0 c16 = 0.0d0 c17 = (-2*cf*k12)/tk33 ! ELSE write(nout,*)'Wrong kind in subroutine vertex.' stop END IF ! ! Now we have the coefficients, so we can calculate hv. ! DO mu = 0,3 DO nu = 0,3 ! temp = c1*g(mu,nu) & + c2*nvec(mu)*nvec(nu) & + c3*nvec(mu)*k3pt(1,nu) & + c4*nvec(mu)*k3pt(2,nu) & + c5*nvec(mu)*k3pt(3,nu) & + c6*k3pt(1,mu)*nvec(nu) & + c7*k3pt(2,mu)*nvec(nu) & + c8*k3pt(3,mu)*nvec(nu) & + c9*k3pt(1,mu)*k3pt(1,nu) & + c10*k3pt(1,mu)*k3pt(2,nu) & + c11*k3pt(1,mu)*k3pt(3,nu) & + c12*k3pt(2,mu)*k3pt(1,nu) & + c13*k3pt(2,mu)*k3pt(2,nu) & + c14*k3pt(2,mu)*k3pt(3,nu) & + c15*k3pt(3,mu)*k3pt(1,nu) & + c16*k3pt(3,mu)*k3pt(2,nu) & + c17*k3pt(3,mu)*k3pt(3,nu) ! hv(mu,nu) = prefactor * temp ! END DO END DO ! !------------------------ ! Next, we calculate ha. !------------------------ ! ! We need certain vectors and tensors made by dotting vectors ! into the epsilon tensor. ! DO mu = 0,3 k1(mu) = k3pt(1,mu) k2(mu) = k3pt(2,mu) k3(mu) = k3pt(3,mu) END DO call epsilon1n(k1,epsn1) call epsilon1n(k2,epsn2) call epsilon1n(k3,epsn3) call epsilon2(k1,k2,eps12) call epsilon2(k1,k3,eps13) call epsilon2(k2,k3,eps23) call epsilon2n(k1,k2,epsn12) call epsilon2n(k1,k3,epsn13) call epsilon2n(k2,k3,epsn23) call epsilon3(k1,k2,k3,eps123) ! ! Generate the coefficients for the hv, depending on KIND3PT. ! IF (kind3pt.EQ.'qqg/qqg') THEN ! c1 = (e3*k23)/(nc*tk33) c2 = -((e3*k13)/(nc*tk33)) c3 = 0.0d0 c4 = -(-2*e3**2 + k33 + 2*tk33)/(2.0d0*nc*tk33) c5 = (-(e2*e3) + k23)/(nc*tk33) c6 = -((-(e1*e3) + k13)/(nc*tk33)) c7 = e3/(nc*tk33) c8 = 0.0d0 c9 = 0.0d0 c10 = 0.0d0 c11 = 0.0d0 c12 = 0.0d0 c13 = 0.0d0 c14 = e3/(nc*tk33) c15 = 0.0d0 c16 = 0.0d0 c17 = -(1/(nc*tk33)) ! ELSE IF (kind3pt.EQ.'qqg/ggq') THEN ! c1 = 0.0d0 c2 = 0.0d0 c3 = (nc*(2*e2*k12*tk11 - e2*k22*tk11 + e1*k11*tk22 & - 2*e1*k12*tk22))/(2.0d0*tk11*tk22) c4 = 0 c5 = -(nc*(-e1**2 + 2*e1*e2 + k11 - 2*k12 - 3*tk11))/(2.0d0*tk11) c6 = -(nc*(-2*e1*e2 + e2**2 + 2*k12 - k22 + 3*tk22))/(2.0d0*tk22) c7 = 0.0d0 c8 = (e1*e2*(2*k12 - k22)*nc)/(2.0d0*tk11*tk22) c9 = -(nc*(e1*e2**2 + e2*k12 - e2*k22 & + 2*e1*tk22))/(2.0d0*tk11*tk22) c10 = (e2*nc*(-e1**2 + e1*e2 + k11 - k12 & - tk11))/(2.0d0*tk11*tk22) c11 = (e1*e2*(k11 - 2*k12)*nc)/(2.0d0*tk11*tk22) c12 = -(e1*nc*(e1*e2 - e2**2 - k12 + k22 & - tk22))/(2.0d0*tk11*tk22) c13 = -(nc*(-(e1**2*e2) + e1*k11 - e1*k12 & - 2*e2*tk11))/(2.0d0*tk11*tk22) c14 = (nc*(-(e1**2*e2) - e1*e2**2 - e2*k11 + 2*e1*k12 + 2*e2*k12 & - e1*k22 + e2*tk11 + e1*tk22))/(2.0d0*tk11*tk22) c15 = -(nc*(-(e1*e2) + e2**2 + k12 - k22 & + tk22))/(2.0d0*tk11*tk22) c16 = (nc*(-e1**2 + e1*e2 + k11 - k12 - tk11))/(2.0d0*tk11*tk22) c17 = 0.0d0 ! ELSE IF (kind3pt.EQ.'qqg/all') THEN ! c1 = 0.0d0 c2 = 0.0d0 c3 = (nc*(2*e2*k12*tk11 - e2*k22*tk11 + e1*k11*tk22 & - 2*e1*k12*tk22))/(2.0d0*tk11*tk22) c4 = 0 c5 = -(nc*(-e1**2 + 2*e1*e2 + k11 - 2*k12 - 3*tk11))/(2.0d0*tk11) c6 = -(nc*(-2*e1*e2 + e2**2 + 2*k12 - k22 + 3*tk22))/(2.0d0*tk22) c7 = 0.0d0 c8 = (e1*e2*(2*k12 - k22)*nc)/(2.0d0*tk11*tk22) c9 = -(nc*(e1*e2**2 + e2*k12 - e2*k22 & + 2*e1*tk22))/(2.0d0*tk11*tk22) c10 = (e2*nc*(-e1**2 + e1*e2 + k11 - k12 & - tk11))/(2.0d0*tk11*tk22) c11 = (e1*e2*(k11 - 2*k12)*nc)/(2.0d0*tk11*tk22) c12 = -(e1*nc*(e1*e2 - e2**2 - k12 + k22 & - tk22))/(2.0d0*tk11*tk22) c13 = -(nc*(-(e1**2*e2) + e1*k11 - e1*k12 & - 2*e2*tk11))/(2.0d0*tk11*tk22) c14 = (nc*(-(e1**2*e2) - e1*e2**2 - e2*k11 + 2*e1*k12 + 2*e2*k12 & - e1*k22 + e2*tk11 + e1*tk22))/(2.0d0*tk11*tk22) c15 = -(nc*(-(e1*e2) + e2**2 + k12 - k22 & + tk22))/(2.0d0*tk11*tk22) c16 = (nc*(-e1**2 + e1*e2 + k11 - k12 - tk11))/(2.0d0*tk11*tk22) c17 = 0.0d0 ! c1 = c1 + (e3*k23)/(nc*tk33) c2 = c2 - ((e3*k13)/(nc*tk33)) c4 = c4 - (-2*e3**2 + k33 + 2*tk33)/(2.0d0*nc*tk33) c5 = c5 + (-(e2*e3) + k23)/(nc*tk33) c6 = c6 - ((-(e1*e3) + k13)/(nc*tk33)) c7 = c7 + e3/(nc*tk33) c14 = c14 + e3/(nc*tk33) c17 = c17 - (1/(nc*tk33)) ! ELSE IF (kind3pt.EQ.'qqp/qqg') THEN ! c1 = (-2*cf*e3*k23)/tk33 c2 = (2*cf*e3*k13)/tk33 c3 = 0.0d0 c4 = (cf*(-2*e3**2 + k33 + 2*tk33))/tk33 c5 = (-2*cf*(-(e2*e3) + k23))/tk33 c6 = (2*cf*(-(e1*e3) + k13))/tk33 c7 = (-2*cf*e3)/tk33 c8 = 0.0d0 c9 = 0.0d0 c10 = 0.0d0 c11 = 0.0d0 c12 = 0.0d0 c13 = 0.0d0 c14 = (-2*cf*e3)/tk33 c15 = 0.0d0 c16 = 0.0d0 c17 = (2*cf)/tk33 ! ELSE write(nout,*)'Wrong kind in subroutine vertex.' stop END IF ! ! Now we have the coefficients, so we can calculate ha. ! DO mu = 0,3 DO nu = 0,3 ! temp = c1*epsn1(mu,nu) & + c2*epsn2(mu,nu) & + c3*epsn3(mu,nu) & + c4*eps12(mu,nu) & + c5*eps13(mu,nu) & + c6*eps23(mu,nu) & + c7*k3pt(3,mu)*epsn12(nu) & + c8*nvec(mu)*epsn13(nu) & + c9*k3pt(1,mu)*epsn13(nu) & + c10*k3pt(2,mu)*epsn13(nu) & + c11*nvec(mu)*epsn23(nu) & + c12*k3pt(1,mu)*epsn23(nu) & + c13*k3pt(2,mu)*epsn23(nu) & + c14*nvec(mu)*eps123(nu) & + c15*k3pt(1,mu)*eps123(nu) & + c16*k3pt(2,mu)*eps123(nu) & + c17*k3pt(3,mu)*eps123(nu) ! ha(mu,nu) = prefactor * temp ! END DO END DO ! !----------------------------- ! Now, we have both hv and ha. !----------------------------- ! ! Alternative for IF (FLAG.NE.'renormalize 3 pt') THEN ! ELSE ! ! We need the renormalization counter term. ! tl(0) = 0.0d0 omegasq = 0.0d0 DO mu = 1,3 tl(mu) =(k3pt(1,mu) + k3pt(2,mu) + k3pt(3,mu))/3.0d0 omegasq = omegasq + tl(mu)**2 END DO omegasq = omegasq + mumsbar**2 omega = complexsqrt(omegasq) ! ! Generate the coefficients for the hv counter term, ! depending on KIND3PT. ! IF (kind3pt.EQ.'qqg/qqg') THEN ! cr1 = - 1.0d0/(4.0d0*nc*omega**3) & - 3.0d0*mumsbar**2/(16.0d0*nc*omega**5) cr2 = - 3.0d0/(8.0d0*nc*omega**5) cr3 = 1.0d0/(8.0d0*nc*omega**3) ! ELSE IF (kind3pt.EQ.'qqg/ggq') THEN ! cr1 = nc/(4.0d0*omega**3) & + 3.0d0*nc*mumsbar**2/(16.0d0*omega**5) cr2 = - 5.0d0*nc/(8.0d0*omega**5) cr3 = - nc/(8.0d0*omega**3) ! ELSE IF (kind3pt.EQ.'qqg/all') THEN ! cr1 = nc/(4.0d0*omega**3) & + 3.0d0*nc*mumsbar**2/(16.0d0*omega**5) cr2 = - 5.0d0*nc/(8.0d0*omega**5) cr3 = - nc/(8.0d0*omega**3) ! cr1 = cr1 - 1.0d0/(4.0d0*nc*omega**3) & - 3.0d0*mumsbar**2/(16.0d0*nc*omega**5) cr2 = cr2 - 3.0d0/(8.0d0*nc*omega**5) cr3 = cr3 + 1.0d0/(8.0d0*nc*omega**3) ! ELSE IF (kind3pt.EQ.'qqp/qqg') THEN ! cr1 = cf/(2.0d0*omega**3) & + 3.0d0*cf*mumsbar**2/(8.0d0*omega**5) cr2 = 3.0d0*cf/(4.0d0*omega**5) cr3 = - cf/(4.0d0*omega**3) ! ELSE write(nout,*)'Wrong kind in subroutine vertex.' stop END IF ! ! Now we have the coefficients, so we can calculate the hv counter term. ! The ha counter term is zero. ! DO mu = 0,3 DO nu = 0,3 hv(mu,nu) = - cr1*g(mu,nu) & - cr2*tl(mu)*tl(nu) & - cr3*nvec(mu)*nvec(nu) ha(mu,nu) = 0.0d0 END DO END DO RETURN ! ! End IF (CUT3PT(1).OR.CUT3PT(2).OR.CUT3PT(3)) THEN ... ELSE ... ! END IF ! RETURN END subroutine vertex ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine twopt2(kind2pt2,k2pt2,cut2pt2,mumsbar,flag,vout) ! use beowulf_parameters implicit none ! In: character(len=13) :: kind2pt2 complex(kind=dbl) :: k2pt2(0:5,0:3) logical :: cut2pt2(1:5) real(kind=dbl) :: mumsbar character(len=16) :: flag ! Out: complex(kind=dbl) :: vout(0:3) ! ! The two-loop contribution to the quark propagator. The function is ! a dot product of a four-vector VOUT(mu) with gamma(mu), times a ! unit color matrix. This subroutine calculates VOUT(mu). (There is ! another contribution proportional to gamma(mu) gamma(5), but this ! contribution is not needed at our level of perturbation theory.) The ! contribution includes the self-energy diagram and the adjoining bare ! quark propagators. The calculation includes the denominator factors. ! Some of the internal propagators may be cut, as specified by cut2pt2, ! where cut2pt2(j) = .true. indicates that the corresponding line is ! cut. ! ! The variable kind2pt2 tells what sort of graph we have. ! ! 1) There are graphs with two overlapping three point functions, ! incicated by kind2pt2 = OVERLAP/abcde where a,...,e are chosen from ! Q,G. Here Q denotes "quark" or "antiquark" while G denotes "gluon". ! These characters indicate the flavors on the internal lines. There ! are two possibilities: OVERLAP/QGGQQ and OVERLAP/QGQGG. (The first ! of these has all qqg vertices, while the second has two qqg vertices ! and one ggg vertex.) ! ! 2) There are graphs with a one loop two point function nested inside ! the two loop two point function. These are indicated by ! kind2pt2 = NESTED /abcde, where, again, a,...,e are chosen from ! Q,G. There are three possibilities: ! NESTED /QGGGG gluon self-enegy with a gluon loop ! NESTED /QGGQQ gluon self-enegy with a quark loop ! NESTED /GQQGQ quark self-enegy ! ! Numbering for graphs of type OVERLAP: ! vrtx1 attaches to the incoming quark line ! vrtx2 attaches to the outgoing quark line ! vrtx3 is the internal vertex attached to a quark line from vrtx1 ! vrtx4 is the other internal vertex ! k0(mu) is the momentum of the quark line entering vrtx1 ! k1(mu) is the momentum of the internal line from vrtx1 to vrtx3 ! k2(mu) is the momentum of the internal line from vrtx1 to vrtx4 ! k3(mu) is the momentum of the internal line from vrtx3 to vrtx2 ! k4(mu) is the momentum of the internal line from vrtx4 to vrtx2 ! k5(mu) is the momentum of the internal line from vrtx3 to vrtx4 ! ! Numbering for graphs of type NESTED: ! vrtx1 attaches to the incoming quark line ! vrtx2 attaches to the outgoing quark line ! vrtx3 is the internal vertex attached to a line from vrtx1 ! vrtx4 is the other internal vertex ! k0(mu) is the momentum of the quark line entering vrtx1 ! k1(mu) is the momentum of the internal line from vrtx1 to vrtx2 ! k2(mu) is the momentum of the internal line from vrtx1 to vrtx3 ! k3(mu) is the momentum of the internal line from vrtx4 to vrtx2 ! k4(mu) ane k5(mu) are the momentum of the internal lines ! from vrtx3 to vrtx4. For a quark internal self-energy, ! 4 is the gluon and 5 is the quark line. ! ! The FLAG variable passed on to lower level subroutines. ! ! 31 December 2001 ! ! For testing purposes only: ! LOGICAL OVERRIDE,LEFTOVERRIDE ! COMMON /TESTING/ OVERRIDE,LEFTOVERRIDE ! --- ! complex(kind=dbl) :: complexsqrt complex(kind=dbl) :: tk00,tk11,tk22,tk33,tk44 complex(kind=dbl) :: k00,k11,k22,k33,k44 complex(kind=dbl) :: temp,prefactor complex(kind=dbl) :: k0(0:3),k1(0:3),k2(0:3),k3(0:3),k4(0:3),k5(0:3) complex(kind=dbl) :: e0,e1,e2,e3,e4 logical :: cut(1:5) complex(kind=dbl) :: x(9) ! complex(kind=dbl) :: ea4ggnik0k1k2,ea4gk0k1,ea4gk2ignk0k1,ea4gk2ik0k1k2 complex(kind=dbl) :: ea4qgnik0k1k2,ea4qk0k1,ea4qk2ignk0k1,ea4qk2ik0k1k2 complex(kind=dbl) :: ea5ggnik0k3k4,ea5gk0k3,ea5gk4ignk0k3,ea5gk4ik0k3k4 complex(kind=dbl) :: ea5qgnik0k3k4,ea5qk0k4,ea5qk3ignk0k4,ea5qk3ik0k3k4 complex(kind=dbl) :: k0k1,k0k2,k0k3,k0k4,k1k2,k3k4,tracev4g,tracev4q complex(kind=dbl) :: tracev5g,tracev5q,v4gwgnk0,v4gwgnk1,v4gwgnk2,v4gwk0k1 complex(kind=dbl) :: v4gwk1k0,v4gwk2gn,v4gwk2k0,v4gwk2k1,v4gwk2k2,v4qwgnk0 complex(kind=dbl) :: v4qwgnk1,v4qwgnk2,v4qwk0k1,v4qwk1k0,v4qwk2gn,v4qwk2k0 complex(kind=dbl) :: v4qwk2k1,v4qwk2k2,v5gwgnk0,v5gwgnk3,v5gwgnk4,v5gwk0k3 complex(kind=dbl) :: v5gwk3k0,v5gwk4gn,v5gwk4k0,v5gwk4k3,v5gwk4k4,v5qwgnk0 complex(kind=dbl) :: v5qwgnk3,v5qwgnk4,v5qwk0k4,v5qwk3gn,v5qwk3k0,v5qwk3k3 complex(kind=dbl) :: v5qwk3k4,v5qwk4k0,a4ggni(0:3),a4gk2i(0:3),a4qgni(0:3) complex(kind=dbl) :: a4qk2i(0:3),a5ggni(0:3),a5gk4i(0:3),a5qgni(0:3) complex(kind=dbl) :: a5qk3i(0:3),ea4ggnik1k2(0:3),ea4gk1(0:3) complex(kind=dbl) :: ea4gk2ignk1(0:3),ea4gk2ik1k2(0:3),ea4qgnik1k2(0:3) complex(kind=dbl) :: ea4qk1(0:3),ea4qk2ignk1(0:3),ea4qk2ik1k2(0:3) complex(kind=dbl) :: ea5ggnik3k4(0:3),ea5gk3(0:3),ea5gk4ignk3(0:3) complex(kind=dbl) :: ea5gk4ik3k4(0:3),ea5qgnik3k4(0:3),ea5qk3ignk4(0:3) complex(kind=dbl) :: ea5qk3ik3k4(0:3),ea5qk4(0:3),v4ggni(0:3),v4gik1(0:3) complex(kind=dbl) :: v4gk1i(0:3),v4gk2i(0:3),v4qgni(0:3),v4qik1(0:3) complex(kind=dbl) :: v4qk1i(0:3),v4qk2i(0:3),v5ggni(0:3),v5gik3(0:3) complex(kind=dbl) :: v5gk3i(0:3),v5gk4i(0:3),v5qgni(0:3),v5qik4(0:3) complex(kind=dbl) :: v5qk3i(0:3),v5qk4i(0:3),a4g(0:3,0:3),a4q(0:3,0:3) complex(kind=dbl) :: a5g(0:3,0:3),a5q(0:3,0:3),v4g(0:3,0:3),v4q(0:3,0:3) complex(kind=dbl) :: v5g(0:3,0:3),v5q(0:3,0:3) ! character(len=7) :: kind3pt logical :: overlap,qqgverts,tripleglue logical :: nested,nestedglue,nestedquark,glueloop,quarkloop complex(kind=dbl) :: k2pt(0:2,0:3),q(0:3) complex(kind=dbl) :: omegasq,qsq character(len=9) :: kind2pt logical :: cut2pt(0:3) complex(kind=dbl) :: outg(0:3,0:3) complex(kind=dbl) :: mk1(0:3),tracem,dotqk1,mqk1 complex(kind=dbl) :: outq(0:3) complex(kind=dbl) :: omega1sq,bareprop(0:3,0:3),dm(0:3),qm,dqm complex(kind=dbl) :: tracebareprop ! complex(kind=dbl), parameter :: gn(0:3) = & (/(1.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0),(0.0d0,0.0d0)/) real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf integer :: mu,nu,alpha logical :: left,right ! complex(kind=dbl) :: k3pt(3,0:3) logical :: cut3pt(3) ! ! Set logical variables according to what case we have. ! overlap = .false. qqgverts = .false. tripleglue = .false. nested = .false. nestedglue = .false. nestedquark = .false. glueloop = .false. quarkloop = .false. IF (kind2pt2.EQ.'overlap/qggqq') THEN overlap = .true. qqgverts = .true. ELSE IF (kind2pt2.EQ.'overlap/qgqgg') THEN overlap = .true. tripleglue = .true. ELSE IF (kind2pt2.EQ.'nested /qgggg') THEN nested = .true. nestedglue = .true. glueloop = .true. ELSE IF (kind2pt2.EQ.'nested /qggqq') THEN nested = .true. nestedglue = .true. quarkloop = .true. ELSE IF (kind2pt2.EQ.'nested /gqqgq') THEN nested = .true. nestedquark = .true. ELSE write(nout,*)'Not programmed for that.' stop END IF ! IF (overlap) THEN ! ! Short form of momentum variables and rename cut variables ! for overlap graphs. ! DO mu = 0,3 k0(mu) = k2pt2(0,mu) k1(mu) = k2pt2(1,mu) k2(mu) = k2pt2(2,mu) k3(mu) = k2pt2(3,mu) k4(mu) = k2pt2(4,mu) k5(mu) = k2pt2(5,mu) END DO cut(1) = cut2pt2(1) cut(2) = cut2pt2(2) cut(3) = cut2pt2(3) cut(4) = cut2pt2(4) cut(5) = cut2pt2(5) ! ! We have an OVERLAP type graph. We can treat it two different ! ways: either the left=hand three point graph is calculated ! using subroutine VERTEX or else the right-hand three point ! graph is calculated with subroutine VERTEX. We choose according ! to which lines are cut. Generally, we take the "left" choice, ! but if the right-hand loop is virtual, we take the "right" choice. ! left = .true. right = .false. IF (cut2pt2(1).AND.cut2pt2(2)) THEN left = .false. right = .true. END IF ! ! For testing purposes, we include code to override this choice. ! ! IF (OVERRIDE) THEN ! LEFT = LEFTOVERRIDE ! RIGHT = .NOT.LEFT ! END IF ! ! Calculate according to case, with logic ! IF (QQGVERTS.AND.RIGHT) THEN ! ELSE IF (QQGVERTS.AND.LEFT) THEN ! ELSE IF (TRIPLEGLUE.AND.RIGHT) THEN ! ELSE IF (TRIPLEGLUE.AND.LEFT) THEN ! ELSE ! END IF ! ! !--- ! IF (qqgverts.AND.right) THEN ! !--- tk00 = 0.0d0 DO mu = 1,3 tk00 = tk00 - k0(mu)**2 END DO e0 = k0(0) k00 = e0**2 + tk00 prefactor = 1.0d0/k00**2 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF DO mu = 0,3 k3pt(1,mu) = -k4(mu) k3pt(2,mu) = -k5(mu) k3pt(3,mu) = k3(mu) END DO cut3pt(1) = cut(4) cut3pt(2) = cut(5) cut3pt(3) = cut(3) kind3pt = 'qqg/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v4q,a4q) tracev4q = 0.0d0 DO mu = 0,3 tracev4q = tracev4q + v4q(mu,mu)*metric(mu) END DO v4qwgnk0 = 0.0d0 v4qwgnk1 = 0.0d0 v4qwgnk2 = 0.0d0 v4qwk0k1 = 0.0d0 v4qwk1k0 = 0.0d0 v4qwk2gn = 0.0d0 v4qwk2k0 = 0.0d0 v4qwk2k1 = 0.0d0 v4qwk2k2 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v4qwgnk0 = v4qwgnk0 & + v4q(mu,nu)*gn(mu)*k0(nu)*metric(mu)*metric(nu) v4qwgnk1 = v4qwgnk1 & + v4q(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) v4qwgnk2 = v4qwgnk2 & + v4q(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu) v4qwk0k1 = v4qwk0k1 & + v4q(mu,nu)*k0(mu)*k1(nu)*metric(mu)*metric(nu) v4qwk1k0 = v4qwk1k0 & + v4q(mu,nu)*k1(mu)*k0(nu)*metric(mu)*metric(nu) v4qwk2gn = v4qwk2gn & + v4q(mu,nu)*k2(mu)*gn(nu)*metric(mu)*metric(nu) v4qwk2k0 = v4qwk2k0 & + v4q(mu,nu)*k2(mu)*k0(nu)*metric(mu)*metric(nu) v4qwk2k1 = v4qwk2k1 & + v4q(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu) v4qwk2k2 = v4qwk2k2 & + v4q(mu,nu)*k2(mu)*k2(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a4qgni(mu) = 0.0d0 a4qk2i(mu) = 0.0d0 v4qgni(mu) = 0.0d0 v4qik1(mu) = 0.0d0 v4qk1i(mu) = 0.0d0 v4qk2i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a4qgni(mu) = a4qgni(mu) + a4q(nu,mu)*gn(nu)*metric(nu) a4qk2i(mu) = a4qk2i(mu) + a4q(nu,mu)*k2(nu)*metric(nu) v4qgni(mu) = v4qgni(mu) + v4q(nu,mu)*gn(nu)*metric(nu) v4qik1(mu) = v4qik1(mu) + v4q(mu,nu)*k1(nu)*metric(nu) v4qk1i(mu) = v4qk1i(mu) + v4q(nu,mu)*k1(nu)*metric(nu) v4qk2i(mu) = v4qk2i(mu) + v4q(nu,mu)*k2(nu)*metric(nu) END DO END DO k0k1 = 0.0d0 k0k2 = 0.0d0 k1k2 = 0.0d0 DO mu = 0,3 k0k1 = k0k1 + k0(mu)*k1(mu)*metric(mu) k0k2 = k0k2 + k0(mu)*k2(mu)*metric(mu) k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) END DO call epsilont2(a4q,k0,k1,ea4qk0k1) call epsilon4(a4qgni,k0,k1,k2,ea4qgnik0k1k2) call epsilon4(a4qk2i,gn,k0,k1,ea4qk2ignk0k1) call epsilon4(a4qk2i,k0,k1,k2,ea4qk2ik0k1k2) call epsilon3(a4qgni,k1,k2,ea4qgnik1k2) call epsilon3(a4qk2i,gn,k1,ea4qk2ignk1) call epsilon3(a4qk2i,k1,k2,ea4qk2ik1k2) call epsilont1(a4q,k1,ea4qk1) DO nu = 0,3 ! x(1) = 0 x(2) = -ea4qk2ik1k2(nu) + v4qwk2k2*k1(nu) - v4qwk2k1*k2(nu) & + tk22*(ea4qk1(nu) - tracev4q*k1(nu) + v4qik1(nu) + v4qk1i(nu)) & - k1k2*v4qk2i(nu) x(3) = ea4qgnik1k2(nu) - ea4qk2ignk1(nu) + v4qwk2k1*gn(nu) & + (-v4qwgnk2 - v4qwk2gn)*k1(nu) + v4qwgnk1*k2(nu) & + k1k2*v4qgni(nu) + e1*v4qk2i(nu) x(4) = x(2) + e2*x(3) x(5) = x(1) + k00*x(4) x(6) = -2*ea4qk2ik0k1k2 + tk22*(-2*ea4qk0k1 + 2*k0k1*tracev4q & - 2*v4qwk0k1 - 2*v4qwk1k0) + 2*k1k2*v4qwk2k0 + 2*k0k2*v4qwk2k1 & - 2*k0k1*v4qwk2k2 x(7) = 2*ea4qgnik0k1k2 + 2*ea4qk2ignk0k1 - 2*k1k2*v4qwgnk0 & - 2*k0k2*v4qwgnk1 + k0k1*(2*v4qwgnk2 + 2*v4qwk2gn) & - 2*e1*v4qwk2k0 - 2*e0*v4qwk2k1 x(8) = x(6) + e2*x(7) x(9) = x(5) + k0(nu)*x(8) vout(nu) = (cf*x(9))/tk22 vout(nu) = vout(nu)*prefactor ! END DO ! ELSE IF (qqgverts.AND.left) THEN ! !--- tk00 = 0.0d0 DO mu = 1,3 tk00 = tk00 - k0(mu)**2 END DO e0 = k0(0) k00 = e0**2 + tk00 prefactor = 1.0d0/k00**2 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 DO mu = 1,3 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 END DO k33 = e3**2 + tk33 k44 = e4**2 + tk44 IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF DO mu = 0,3 k3pt(1,mu) = -k5(mu) k3pt(2,mu) = -k1(mu) k3pt(3,mu) = k2(mu) END DO cut3pt(1) = cut(5) cut3pt(2) = cut(1) cut3pt(3) = cut(2) kind3pt = 'qqg/qqg' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v5q,a5q) tracev5q = 0.0d0 DO mu = 0,3 tracev5q = tracev5q + v5q(mu,mu)*metric(mu) END DO v5qwgnk0 = 0.0d0 v5qwgnk3 = 0.0d0 v5qwgnk4 = 0.0d0 v5qwk0k4 = 0.0d0 v5qwk3gn = 0.0d0 v5qwk3k0 = 0.0d0 v5qwk3k3 = 0.0d0 v5qwk3k4 = 0.0d0 v5qwk4k0 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v5qwgnk0 = v5qwgnk0 & + v5q(mu,nu)*gn(mu)*k0(nu)*metric(mu)*metric(nu) v5qwgnk3 = v5qwgnk3 & + v5q(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) v5qwgnk4 = v5qwgnk4 & + v5q(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu) v5qwk0k4 = v5qwk0k4 & + v5q(mu,nu)*k0(mu)*k4(nu)*metric(mu)*metric(nu) v5qwk3gn = v5qwk3gn & + v5q(mu,nu)*k3(mu)*gn(nu)*metric(mu)*metric(nu) v5qwk3k0 = v5qwk3k0 & + v5q(mu,nu)*k3(mu)*k0(nu)*metric(mu)*metric(nu) v5qwk3k3 = v5qwk3k3 & + v5q(mu,nu)*k3(mu)*k3(nu)*metric(mu)*metric(nu) v5qwk3k4 = v5qwk3k4 & + v5q(mu,nu)*k3(mu)*k4(nu)*metric(mu)*metric(nu) v5qwk4k0 = v5qwk4k0 & + v5q(mu,nu)*k4(mu)*k0(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a5qgni(mu) = 0.0d0 a5qk3i(mu) = 0.0d0 v5qgni(mu) = 0.0d0 v5qik4(mu) = 0.0d0 v5qk3i(mu) = 0.0d0 v5qk4i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a5qgni(mu) = a5qgni(mu) + a5q(nu,mu)*gn(nu)*metric(nu) a5qk3i(mu) = a5qk3i(mu) + a5q(nu,mu)*k3(nu)*metric(nu) v5qgni(mu) = v5qgni(mu) + v5q(nu,mu)*gn(nu)*metric(nu) v5qik4(mu) = v5qik4(mu) + v5q(mu,nu)*k4(nu)*metric(nu) v5qk3i(mu) = v5qk3i(mu) + v5q(nu,mu)*k3(nu)*metric(nu) v5qk4i(mu) = v5qk4i(mu) + v5q(nu,mu)*k4(nu)*metric(nu) END DO END DO k0k3 = 0.0d0 k0k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k0k3 = k0k3 + k0(mu)*k3(mu)*metric(mu) k0k4 = k0k4 + k0(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO call epsilont2(a5q,k0,k4,ea5qk0k4) call epsilon4(a5qgni,k0,k3,k4,ea5qgnik0k3k4) call epsilon4(a5qk3i,gn,k0,k4,ea5qk3ignk0k4) call epsilon4(a5qk3i,k0,k3,k4,ea5qk3ik0k3k4) call epsilon3(a5qgni,k3,k4,ea5qgnik3k4) call epsilon3(a5qk3i,gn,k4,ea5qk3ignk4) call epsilon3(a5qk3i,k3,k4,ea5qk3ik3k4) call epsilont1(a5q,k4,ea5qk4) DO nu = 0,3 ! x(1) = 0 x(2) = -ea5qk3ik3k4(nu) - v5qwk3k4*k3(nu) + v5qwk3k3*k4(nu) & - k3k4*v5qk3i(nu) + tk33*(-ea5qk4(nu) - tracev5q*k4(nu) & + v5qik4(nu) + v5qk4i(nu)) x(3) = ea5qgnik3k4(nu) + ea5qk3ignk4(nu) + v5qwk3k4*gn(nu) & + v5qwgnk4*k3(nu) + (-v5qwgnk3 - v5qwk3gn)*k4(nu) & + k3k4*v5qgni(nu) + e4*v5qk3i(nu) x(4) = x(2) + e3*x(3) x(5) = x(1) + k00*x(4) x(6) = -2*ea5qk3ik0k3k4 + 2*k3k4*v5qwk3k0 - 2*k0k4*v5qwk3k3 & + 2*k0k3*v5qwk3k4 + tk33*(2*ea5qk0k4 + 2*k0k4*tracev5q & - 2*v5qwk0k4 - 2*v5qwk4k0) x(7) = 2*ea5qgnik0k3k4 - 2*ea5qk3ignk0k4 - 2*k3k4*v5qwgnk0 & - 2*k0k3*v5qwgnk4 + k0k4*(2*v5qwgnk3 + 2*v5qwk3gn) & - 2*e4*v5qwk3k0 - 2*e0*v5qwk3k4 x(8) = x(6) + e3*x(7) x(9) = x(5) + k0(nu)*x(8) vout(nu) = (cf*x(9))/tk33 vout(nu) = vout(nu)*prefactor ! END DO ! ELSE IF (tripleglue.AND.right) THEN ! !--- tk00 = 0.0d0 DO mu = 1,3 tk00 = tk00 - k0(mu)**2 END DO e0 = k0(0) k00 = e0**2 + tk00 prefactor = 1.0d0/k00**2 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 IF (cut(1)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk22) ELSE prefactor = prefactor/k22 END IF DO mu = 0,3 k3pt(1,mu) = -k4(mu) k3pt(2,mu) = -k5(mu) k3pt(3,mu) = k3(mu) END DO cut3pt(1) = cut(4) cut3pt(2) = cut(5) cut3pt(3) = cut(3) kind3pt = 'qqg/ggq' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v4g,a4g) tracev4g = 0.0d0 DO mu = 0,3 tracev4g = tracev4g + v4g(mu,mu)*metric(mu) END DO v4gwgnk0 = 0.0d0 v4gwgnk1 = 0.0d0 v4gwgnk2 = 0.0d0 v4gwk0k1 = 0.0d0 v4gwk1k0 = 0.0d0 v4gwk2gn = 0.0d0 v4gwk2k0 = 0.0d0 v4gwk2k1 = 0.0d0 v4gwk2k2 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v4gwgnk0 = v4gwgnk0 & + v4g(mu,nu)*gn(mu)*k0(nu)*metric(mu)*metric(nu) v4gwgnk1 = v4gwgnk1 & + v4g(mu,nu)*gn(mu)*k1(nu)*metric(mu)*metric(nu) v4gwgnk2 = v4gwgnk2 & + v4g(mu,nu)*gn(mu)*k2(nu)*metric(mu)*metric(nu) v4gwk0k1 = v4gwk0k1 & + v4g(mu,nu)*k0(mu)*k1(nu)*metric(mu)*metric(nu) v4gwk1k0 = v4gwk1k0 & + v4g(mu,nu)*k1(mu)*k0(nu)*metric(mu)*metric(nu) v4gwk2gn = v4gwk2gn & + v4g(mu,nu)*k2(mu)*gn(nu)*metric(mu)*metric(nu) v4gwk2k0 = v4gwk2k0 & + v4g(mu,nu)*k2(mu)*k0(nu)*metric(mu)*metric(nu) v4gwk2k1 = v4gwk2k1 & + v4g(mu,nu)*k2(mu)*k1(nu)*metric(mu)*metric(nu) v4gwk2k2 = v4gwk2k2 & + v4g(mu,nu)*k2(mu)*k2(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a4ggni(mu) = 0.0d0 a4gk2i(mu) = 0.0d0 v4ggni(mu) = 0.0d0 v4gik1(mu) = 0.0d0 v4gk1i(mu) = 0.0d0 v4gk2i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a4ggni(mu) = a4ggni(mu) + a4g(nu,mu)*gn(nu)*metric(nu) a4gk2i(mu) = a4gk2i(mu) + a4g(nu,mu)*k2(nu)*metric(nu) v4ggni(mu) = v4ggni(mu) + v4g(nu,mu)*gn(nu)*metric(nu) v4gik1(mu) = v4gik1(mu) + v4g(mu,nu)*k1(nu)*metric(nu) v4gk1i(mu) = v4gk1i(mu) + v4g(nu,mu)*k1(nu)*metric(nu) v4gk2i(mu) = v4gk2i(mu) + v4g(nu,mu)*k2(nu)*metric(nu) END DO END DO k0k1 = 0.0d0 k0k2 = 0.0d0 k1k2 = 0.0d0 DO mu = 0,3 k0k1 = k0k1 + k0(mu)*k1(mu)*metric(mu) k0k2 = k0k2 + k0(mu)*k2(mu)*metric(mu) k1k2 = k1k2 + k1(mu)*k2(mu)*metric(mu) END DO call epsilont2(a4g,k0,k1,ea4gk0k1) call epsilon4(a4ggni,k0,k1,k2,ea4ggnik0k1k2) call epsilon4(a4gk2i,gn,k0,k1,ea4gk2ignk0k1) call epsilon4(a4gk2i,k0,k1,k2,ea4gk2ik0k1k2) call epsilon3(a4ggni,k1,k2,ea4ggnik1k2) call epsilon3(a4gk2i,gn,k1,ea4gk2ignk1) call epsilon3(a4gk2i,k1,k2,ea4gk2ik1k2) call epsilont1(a4g,k1,ea4gk1) DO nu = 0,3 ! x(1) = 0 x(2) = -ea4gk2ik1k2(nu) + v4gwk2k2*k1(nu) - v4gwk2k1*k2(nu) & + tk22*(ea4gk1(nu) - tracev4g*k1(nu) + v4gik1(nu) + v4gk1i(nu)) & - k1k2*v4gk2i(nu) x(3) = ea4ggnik1k2(nu) - ea4gk2ignk1(nu) + v4gwk2k1*gn(nu) & + (-v4gwgnk2 - v4gwk2gn)*k1(nu) + v4gwgnk1*k2(nu) & + k1k2*v4ggni(nu) + e1*v4gk2i(nu) x(4) = x(2) + e2*x(3) x(5) = x(1) + k00*x(4) x(6) = -2*ea4gk2ik0k1k2 + tk22*(-2*ea4gk0k1 + 2*k0k1*tracev4g & - 2*v4gwk0k1 - 2*v4gwk1k0) + 2*k1k2*v4gwk2k0 + 2*k0k2*v4gwk2k1 & - 2*k0k1*v4gwk2k2 x(7) = 2*ea4ggnik0k1k2 + 2*ea4gk2ignk0k1 - 2*k1k2*v4gwgnk0 & - 2*k0k2*v4gwgnk1 + k0k1*(2*v4gwgnk2 + 2*v4gwk2gn) & - 2*e1*v4gwk2k0 - 2*e0*v4gwk2k1 x(8) = x(6) + e2*x(7) x(9) = x(5) + k0(nu)*x(8) vout(nu) = (cf*x(9))/tk22 vout(nu) = vout(nu)*prefactor ! END DO ! ELSE IF (tripleglue.AND.left) THEN ! !--- tk00 = 0.0d0 DO mu = 1,3 tk00 = tk00 - k0(mu)**2 END DO e0 = k0(0) k00 = e0**2 + tk00 prefactor = 1.0d0/k00**2 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 DO mu = 1,3 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 END DO k33 = e3**2 + tk33 k44 = e4**2 + tk44 IF (cut(3)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/complexsqrt(-tk44) ELSE prefactor = prefactor/k44 END IF DO mu = 0,3 k3pt(1,mu) = k5(mu) k3pt(2,mu) = -k2(mu) k3pt(3,mu) = k1(mu) END DO cut3pt(1) = cut(5) cut3pt(2) = cut(2) cut3pt(3) = cut(1) kind3pt = 'qqg/ggq' call vertex(kind3pt,k3pt,cut3pt,mumsbar,flag,v5g,a5g) tracev5g = 0.0d0 DO mu = 0,3 tracev5g = tracev5g + v5g(mu,mu)*metric(mu) END DO v5gwgnk0 = 0.0d0 v5gwgnk3 = 0.0d0 v5gwgnk4 = 0.0d0 v5gwk0k3 = 0.0d0 v5gwk3k0 = 0.0d0 v5gwk4gn = 0.0d0 v5gwk4k0 = 0.0d0 v5gwk4k3 = 0.0d0 v5gwk4k4 = 0.0d0 DO mu = 0,3 DO nu = 0,3 v5gwgnk0 = v5gwgnk0 & + v5g(mu,nu)*gn(mu)*k0(nu)*metric(mu)*metric(nu) v5gwgnk3 = v5gwgnk3 & + v5g(mu,nu)*gn(mu)*k3(nu)*metric(mu)*metric(nu) v5gwgnk4 = v5gwgnk4 & + v5g(mu,nu)*gn(mu)*k4(nu)*metric(mu)*metric(nu) v5gwk0k3 = v5gwk0k3 & + v5g(mu,nu)*k0(mu)*k3(nu)*metric(mu)*metric(nu) v5gwk3k0 = v5gwk3k0 & + v5g(mu,nu)*k3(mu)*k0(nu)*metric(mu)*metric(nu) v5gwk4gn = v5gwk4gn & + v5g(mu,nu)*k4(mu)*gn(nu)*metric(mu)*metric(nu) v5gwk4k0 = v5gwk4k0 & + v5g(mu,nu)*k4(mu)*k0(nu)*metric(mu)*metric(nu) v5gwk4k3 = v5gwk4k3 & + v5g(mu,nu)*k4(mu)*k3(nu)*metric(mu)*metric(nu) v5gwk4k4 = v5gwk4k4 & + v5g(mu,nu)*k4(mu)*k4(nu)*metric(mu)*metric(nu) END DO END DO DO mu = 0,3 a5ggni(mu) = 0.0d0 a5gk4i(mu) = 0.0d0 v5ggni(mu) = 0.0d0 v5gik3(mu) = 0.0d0 v5gk3i(mu) = 0.0d0 v5gk4i(mu) = 0.0d0 END DO DO mu = 0,3 DO nu = 0,3 a5ggni(mu) = a5ggni(mu) + a5g(nu,mu)*gn(nu)*metric(nu) a5gk4i(mu) = a5gk4i(mu) + a5g(nu,mu)*k4(nu)*metric(nu) v5ggni(mu) = v5ggni(mu) + v5g(nu,mu)*gn(nu)*metric(nu) v5gik3(mu) = v5gik3(mu) + v5g(mu,nu)*k3(nu)*metric(nu) v5gk3i(mu) = v5gk3i(mu) + v5g(nu,mu)*k3(nu)*metric(nu) v5gk4i(mu) = v5gk4i(mu) + v5g(nu,mu)*k4(nu)*metric(nu) END DO END DO k0k3 = 0.0d0 k0k4 = 0.0d0 k3k4 = 0.0d0 DO mu = 0,3 k0k3 = k0k3 + k0(mu)*k3(mu)*metric(mu) k0k4 = k0k4 + k0(mu)*k4(mu)*metric(mu) k3k4 = k3k4 + k3(mu)*k4(mu)*metric(mu) END DO call epsilont2(a5g,k0,k3,ea5gk0k3) call epsilon4(a5ggni,k0,k3,k4,ea5ggnik0k3k4) call epsilon4(a5gk4i,gn,k0,k3,ea5gk4ignk0k3) call epsilon4(a5gk4i,k0,k3,k4,ea5gk4ik0k3k4) call epsilon3(a5ggni,k3,k4,ea5ggnik3k4) call epsilon3(a5gk4i,gn,k3,ea5gk4ignk3) call epsilon3(a5gk4i,k3,k4,ea5gk4ik3k4) call epsilont1(a5g,k3,ea5gk3) DO nu = 0,3 ! x(1) = 0 x(2) = -ea5gk4ik3k4(nu) - v5gwk4k4*k3(nu) + v5gwk4k3*k4(nu) & + tk44*(ea5gk3(nu) + tracev5g*k3(nu) - v5gik3(nu) - v5gk3i(nu)) & + k3k4*v5gk4i(nu) x(3) = ea5ggnik3k4(nu) - ea5gk4ignk3(nu) - v5gwk4k3*gn(nu) & + (v5gwgnk4 + v5gwk4gn)*k3(nu) - v5gwgnk3*k4(nu) & - k3k4*v5ggni(nu) - e3*v5gk4i(nu) x(4) = x(2) + e4*x(3) x(5) = x(1) + k00*x(4) x(6) = -2*ea5gk4ik0k3k4 + tk44*(-2*ea5gk0k3 - 2*k0k3*tracev5g & + 2*v5gwk0k3 + 2*v5gwk3k0) - 2*k3k4*v5gwk4k0 - 2*k0k4*v5gwk4k3 & + 2*k0k3*v5gwk4k4 x(7) = 2*ea5ggnik0k3k4 + 2*ea5gk4ignk0k3 + 2*k3k4*v5gwgnk0 & + 2*k0k4*v5gwgnk3 + k0k3*(-2*v5gwgnk4 - 2*v5gwk4gn) & + 2*e3*v5gwk4k0 + 2*e0*v5gwk4k3 x(8) = x(6) + e4*x(7) x(9) = x(5) + k0(nu)*x(8) vout(nu) = -((cf*x(9))/tk44) vout(nu) = vout(nu)*prefactor ! END DO ELSE write(nout,*)'Not programmed for that.' stop END IF ! !------------- ! ! Alternative for IF (OVERLAP) THEN. ! ELSE IF (nested) THEN ! ! We have a nested graph. ! DO mu = 0,3 k2pt(0,mu) = k2pt2(2,mu) k2pt(1,mu) = k2pt2(4,mu) k2pt(2,mu) = k2pt2(5,mu) q(mu) = k2pt2(0,mu) k1(mu) = k2pt2(1,mu) END DO omegasq = q(1)**2 + q(2)**2 + q(3)**2 qsq = q(0)**2 - omegasq omega1sq = k1(1)**2 + k1(2)**2 + k1(3)**2 ! cut2pt(0) = cut2pt2(2) cut2pt(1) = cut2pt2(4) cut2pt(2) = cut2pt2(5) cut2pt(3) = cut2pt2(3) ! ! We need the factor equal to 1/k^2 for an uncut propagator ! and 1/ 2|\vec k| for a cut propagator. BUT line 1 is always ! cut, propagator 0 never cut, and the one-loop two point function ! that is nested inside has the factor for propagators 2,3,4,5. ! prefactor = cf/(qsq**2*2.0d0*complexsqrt(omega1sq)) ! IF (nestedglue) THEN ! ! Our nested graph has a gluon self-energy insertion. ! Calculate OUTG according to what kind of self-energy insertion it is. ! IF (glueloop) THEN kind2pt = 'gluonloop' call twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,outg) ELSE IF (quarkloop) THEN kind2pt = 'quarkloop' call twopointg(kind2pt,k2pt,cut2pt,mumsbar,flag,outg) END IF ! ! Now comlete the calculation for a gluon self-energy insertion. ! DO alpha = 0,3 temp = 0.0d0 DO nu = 0,3 temp = temp + outg(alpha,nu)*k1(nu)*metric(nu) END DO mk1(alpha) = temp END DO ! tracem = 0.0d0 dotqk1 = 0.0d0 DO mu = 0,3 tracem = tracem + outg(mu,mu)*metric(mu) dotqk1 = dotqk1 + q(mu)*k1(mu)*metric(mu) END DO ! mqk1 = 0.0d0 DO mu = 0,3 DO nu = 0,3 mqk1 = mqk1 + outg(mu,nu)*q(mu)*k1(nu)*metric(mu)*metric(nu) END DO END DO ! DO alpha = 0,3 temp = - 2.0d0*qsq*mk1(alpha) temp = temp + 4.0d0*q(alpha)*mqk1 temp = temp + (qsq*k1(alpha) - 2.0d0*q(alpha)*dotqk1)*tracem vout(alpha) = prefactor*temp END DO ! ! Alternative for IF (NESTEDGLUE) THEN ! ELSE IF (nestedquark) THEN ! ! Our nested graph has a quark self-energy insertion. ! Calculate OUTQ. ! call twopointq(k2pt,cut2pt,mumsbar,flag,outq) ! ! Now comlete the calculation for a quark self-energy insertion. ! ! The gluon propagator in Coulomb gauge for an on-shell gluon ! with three-momentum K1(mu). ! bareprop(0,0) = 0.0d0 DO mu = 1,3 bareprop(0,mu) = 0.0d0 bareprop(mu,0) = 0.0d0 bareprop(mu,mu) = 1.0d0 - k1(mu)**2/omega1sq DO nu = mu+1,3 temp = - k1(mu)*k1(nu)/omega1sq bareprop(mu,nu) = temp bareprop(nu,mu) = temp END DO END DO tracebareprop = -2.0d0 ! DO alpha = 0,3 dm(alpha) = 0.0d0 DO nu = 0,3 dm(alpha) = dm(alpha) + bareprop(alpha,nu)*outq(nu)*metric(nu) END DO END DO ! dqm = 0.0d0 qm = 0.0d0 DO mu = 0,3 qm = qm + q(mu)*outq(mu)*metric(mu) DO nu = 0,3 dqm = dqm + bareprop(mu,nu)*q(mu)*outq(nu)*metric(mu)*metric(nu) END DO END DO ! DO alpha = 0,3 temp = - 2.0d0*qsq*dm(alpha) temp = temp + 4.0d0*q(alpha)*dqm temp = temp & + (qsq*outq(alpha) - 2.0d0*q(alpha)*qm)*tracebareprop vout(alpha) = prefactor*temp END DO ! ! Close IF (NESTEDGLUE) THEN ... ELSE IF (NESTEDQUARK) THEN ! ELSE write(nout,*)'Oops, something must have gone wrong.' stop END IF ! ! Close IF (OVERLAP) THEN ... ELSE IF (NESTED) THEN ! ELSE write(nout,*)'Oops, something has gone wrong.' stop END IF ! RETURN END subroutine twopt2 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Dotting the epsilon tensor into vectors and tensors ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine epsilon4(v1,v2,v3,v4,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: v1(0:3),v2(0:3),v3(0:3),v4(0:3) ! Out: complex(kind=dbl) :: out ! ! Computes the contraction of the epsilon tensor with four four-vectors, ! giving a scalar result, OUT. The four vectors have upper indices. ! The epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1. ! ! 5 June 2001 ! integer :: n ! ! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that ! define the contributions to epsilon and J = 1,...,4 labelling ! the four indices of epsilon. ! integer, parameter :: mu(24,4) = reshape( & (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, & 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, & 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, & 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)& ,(/24,4/) ) ! ! Sign(N) is minus the signature of the permutation. ! integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, & -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/) ! out = (0.0d0,0.0d0) DO n = 1,24 out = out & + sign(n)*v1(mu(n,1))*v2(mu(n,2))*v3(mu(n,3))*v4(mu(n,4)) END DO RETURN END subroutine epsilon4 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine epsilon3(v2,v3,v4,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: v2(0:3),v3(0:3),v4(0:3) ! Out: complex(kind=dbl) :: out(0:3) ! ! Computes the contraction of the epsilon tensor with three ! four-vectors, giving a vector result, OUT(mu1). The vectors have ! upper indices. The epsilon tensor has lower indices, so ! epsilon(0,1,2,3) = -1, and in addition we need a metric tensor to ! raise the index of OUT. We calculate ! ! Out(mu1) = epsilon(mu1,mu2,mu3,mu4) v2(mu2) v3(mu3) v4(mu4) ! ! 5 June 2001 ! integer :: n,nu ! ! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that ! define the contributions to epsilon and J = 1,...,4 labelling ! the four indices of epsilon. ! integer, parameter :: mu(24,4) = reshape( & (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, & 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, & 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, & 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)& ,(/24,4/) ) ! ! Sign(N) is minus the signature of the permutation. ! integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, & -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/) ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) ! DO nu = 0,3 out(nu) = (0.0d0,0.0d0) END DO DO n = 1,24 nu = mu(n,1) out(nu) = out(nu) & + metric(nu)*sign(n)*v2(mu(n,2))*v3(mu(n,3))*v4(mu(n,4)) END DO RETURN END subroutine epsilon3 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine epsilon2(v3,v4,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: v3(0:3),v4(0:3) ! Out: complex(kind=dbl) :: out(0:3,0:3) ! ! Computes the contraction of the epsilon tensor with two ! four-vectors, giving a second rank tensor result, OUT(mu1,mu2). The ! vectors have upper indices. The epsilon tensor has lower ! indices, so epsilon(0,1,2,3) = -1, and in addition we need a metric ! tensor to raise the indices of OUT. We calculate ! ! Out(mu1,mu2) = epsilon(mu1,mu2,mu3,mu4) v3(mu3) v4(mu4) ! ! 5 June 2001 ! integer :: n,nu1,nu2 ! ! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that ! define the contributions to epsilon and J = 1,...,4 labelling ! the four indices of epsilon. ! integer, parameter :: mu(24,4) = reshape( & (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, & 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, & 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, & 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)& ,(/24,4/) ) ! ! Sign(N) is minus the signature of the permutation. ! integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, & -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/) ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) ! DO nu1 = 0,3 DO nu2 = 0,3 out(nu1,nu2) = (0.0d0,0.0d0) END DO END DO DO n = 1,24 nu1 = mu(n,1) nu2 = mu(n,2) out(nu1,nu2) = out(nu1,nu2) & + metric(nu1)*metric(nu2)*sign(n)*v3(mu(n,3))*v4(mu(n,4)) END DO RETURN END subroutine epsilon2 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine epsilon2n(v3,v4,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: v3(0:3),v4(0:3) ! Out: complex(kind=dbl) :: out(0:3) ! ! Computes the contraction of the epsilon tensor with two ! four-vectors and the unit vector n in the 0 direction, giving a ! four-vector result, OUT(mu1). The vectors have upper indices. The ! epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1, and in ! addition we need a metric tensor to raise the index of OUT. However ! the metric contributes a factor (-1) in each case. We ! calculate ! ! Out(mu1) = epsilon(mu1,mu2,mu3,mu4) n(mu2) v3(mu3) v4(mu4) ! ! 5 June 2001 ! integer :: n,nu ! ! Mu is Mu(N,J) with N = 1,...,6 labelling the permutations that ! define the contributions to epsilon that have 0 for the second ! index and J = 1,...,4 labelling the four indices of epsilon. ! integer, parameter :: mu(6,4) = reshape( & (/1,1,2,2,3,3, & 0,0,0,0,0,0, & 2,3,1,3,1,2, & 3,2,3,1,2,1/)& ,(/6,4/) ) ! ! Sign(N) is minus the signature of the permutation. ! integer, parameter :: sign(6) = (/1,-1,-1,1,1,-1/) ! ! Our result would have a factor METRIC(NU), but this factor is ! always -1. ! DO nu = 0,3 out(nu) = (0.0d0,0.0d0) END DO DO n = 1,6 nu = mu(n,1) out(nu) = out(nu) - sign(n)*v3(mu(n,3))*v4(mu(n,4)) END DO RETURN END subroutine epsilon2n ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine epsilon1n(v4,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: v4(0:3) ! Out: complex(kind=dbl) :: out(0:3,0:3) ! ! Computes the contraction of the epsilon tensor with one ! four-vector and the unit vector n in the 0 direction, giving a ! tensor result, OUT(mu1,mu2). The vectors have upper indices. The ! epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1, and in ! addition we need a metric tensor to raise the index of OUT. ! However, the metric tensor in each case contributes (-1)^2 = 1. We ! calculate ! ! Out(mu1,mu2) = epsilon(mu1,mu2,mu3,mu4) n(mu3) v4(mu4) ! ! 7 December 2001 ! integer :: n,mu1,mu2 ! ! Mu is Mu(N,J) with N = 1,...,6 labelling the permutations that ! define the contributions to epsilon that have 0 for the third ! index and J = 1,...,4 labelling the four indices of epsilon. ! integer, parameter :: mu(6,4) = reshape( & (/1,1,2,2,3,3, & 2,3,1,3,1,2, & 0,0,0,0,0,0, & 3,2,3,1,2,1/)& ,(/6,4/) ) ! ! Sign(N) is minus the signature of the permutation. ! integer, parameter :: sign(6) = (/-1,1,1,-1,-1,1/) ! ! Our result would have a factor METRIC(MU1)*METRIC(MU2), ! but this factor is always +1. ! DO mu1 = 0,3 DO mu2 = 0,3 out(mu1,mu2) = (0.0d0,0.0d0) END DO END DO DO n = 1,6 mu1 = mu(n,1) mu2 = mu(n,2) out(mu1,mu2) = out(mu1,mu2) + sign(n)*v4(mu(n,4)) END DO RETURN END subroutine epsilon1n ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine epsilont2(t12,v3,v4,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: t12(0:3,0:3),v3(0:3),v4(0:3) ! Out: complex(kind=dbl) :: out ! ! Computes the contraction of the epsilon tensor with a second rank ! tensor and two four-vectors, giving a scalar result, OUT. ! The tensor and the four vectors have upper indices. ! The epsilon tensor has lower indices, so epsilon(0,1,2,3) = -1. ! ! 4 August 2001 ! integer :: n ! ! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that ! define the contributions to epsilon and J = 1,...,4 labelling ! the four indices of epsilon. ! integer, parameter :: mu(24,4) = reshape( & (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, & 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, & 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, & 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)& ,(/24,4/) ) ! ! Sign(N) is minus the signature of the permutation. ! integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, & -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/) ! out = (0.0d0,0.0d0) DO n = 1,24 out = out & + sign(n)*t12(mu(n,1),mu(n,2))*v3(mu(n,3))*v4(mu(n,4)) END DO RETURN END subroutine epsilont2 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine epsilont1(t23,v4,out) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: t23(0:3,0:3),v4(0:3) ! Out: complex(kind=dbl) :: out(0:3) ! ! Computes the contraction of the epsilon tensor with a second ! rank tensor and a four-vector, giving a vector result, OUT(mu1). ! The tensor and the vector have upper indices. The epsilon tensor has ! lower indices, so epsilon(0,1,2,3) = -1, and in addition we need ! a metric tensor to raise the index of OUT. We calculate ! ! Out(mu1) = epsilon(mu1,mu2,mu3,mu4) t23(mu2,mu3) v4(mu4) ! ! 4 August 2001 ! integer :: n,nu ! ! Mu is Mu(N,J) with N = 1,...,24 labelling the permutations that ! define the contributions to epsilon and J = 1,...,4 labelling ! the four indices of epsilon. ! integer, parameter :: mu(24,4) = reshape( & (/0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,2,2,3,3,3,3,3,3, & 1,1,2,2,3,3,0,0,2,2,3,3,0,0,1,1,3,3,0,0,1,1,2,2, & 2,3,1,3,1,2,2,3,0,3,0,2,1,3,0,3,0,1,1,2,0,2,0,1, & 3,2,3,1,2,1,3,2,3,0,2,0,3,1,3,0,1,0,2,1,2,0,1,0/)& ,(/24,4/) ) ! ! Sign(N) is minus the signature of the permutation. ! integer, parameter :: sign(24) = (/-1,1,1,-1,-1,1,1,-1,-1,1,1,-1, & -1,1,1,-1,-1,1,1,-1,-1,1,1,-1/) ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) ! DO nu = 0,3 out(nu) = (0.0d0,0.0d0) END DO DO n = 1,24 nu = mu(n,1) out(nu) = out(nu) & + metric(nu)*sign(n)*t23(mu(n,2),mu(n,3))*v4(mu(n,4)) END DO RETURN END subroutine epsilont1 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine diagnostic(badpointinfo) ! use beowulf_parameters use beowulf_structures implicit none ! In: type(badpointstate) :: badpointinfo ! integer :: nprops,nverts integer :: order integer :: nloops1,nprops1,nverts1,cutmax1 integer :: nloops2,nprops2,nverts2,cutmax2 common /sizes/ nloops1,nprops1,nverts1,cutmax1, & nloops2,nprops2,nverts2,cutmax2 ! ! NEWGRAPH variables: type(graphstructure) :: graph logical :: graphfound integer :: graphnumber ! MAP variables: integer :: nmaps,qs(maxmaps,0:size),qsigns(maxmaps,0:size) character(len=6) :: maptypes(maxmaps) ! Calculate variables: logical :: report,details common /calculook/ report,details complex(kind=dbl) :: value complex(kind=dbl) :: valuechk real(kind=dbl) :: maxpart ! real(kind=dbl) :: k(0:3*size-1,0:3) real(kind=dbl) :: absk(0:3*size-1) integer :: p,mu,v real(kind=dbl) :: cos12,cos23,cos31,sin12,sin23,sin31 real(kind=dbl) :: badness ! Reno size and counting variables: integer :: groupsize(maxgraphs,maxmaps) integer :: groupsizegraph(maxgraphs) integer :: groupsizetotal common /montecarlo/groupsize,groupsizegraph,groupsizetotal ! ! State of the random number generator. For its diagnostic purposes, ! subroutine diagnostic sets the state of the random number generator ! to what it was just before subroutine calculate was called for the ! bad point, then subroutine diagnostic calls subroutine calculate. ! integer :: jrandom,irandom(250) real(kind=dbl) :: rrandom(250) common/rando/ rrandom,jrandom,irandom ! ! This finds data for the kind of graph with the worst value ! Latest revision: 9 February 2003 ! ------- ! order = 2 IF (badpointinfo%graphnumber.GT.10) THEN order = 1 END IF IF (order.EQ.1) THEN nprops = nprops1 nverts = nverts1 ELSE IF (order.EQ.2) THEN nprops = nprops2 nverts = nverts2 ELSE write(nout,*)'Order must be 1 or 2.',order END IF ! ! First we have to run NEWGRAPH through all the graphs so that it ! initializes itself. ! graphfound = .true. DO WHILE (graphfound) call getnewgraph(order,graph,graphfound) END DO ! ! Now we find the graph we wanted. ! graphfound = .true. IF (order.EQ.2) THEN graphnumber = 0 ELSE IF (order.EQ.1) THEN graphnumber = 10 ELSE write(nout,*)'Order must be 1 or 2.',order stop END IF DO WHILE (graphfound) call getnewgraph(order,graph,graphfound) IF (graphfound) THEN graphnumber = graphnumber + 1 END IF IF (graphfound.eqv..false.) THEN write(nout,*)'Oops, snafu in diagnostic.' stop END IF IF (graphnumber.EQ.badpointinfo%graphnumber) THEN graphfound = .false. END IF END DO ! ! Calculate information associated with the maps. ! call findtypes(graph,nmaps,qs,qsigns,maptypes) ! ! We are ready to go. ! ! DO p = 0,nprops DO mu = 0,3 k(p,mu) = badpointinfo%k(p,mu) END DO END DO ! DO p = 1,nprops absk(p) = 0.0d0 DO mu = 1,3 absk(p) = absk(p) + k(p,mu)**2 END DO absk(p) = sqrt(absk(p)) END DO ! write(nout,*)' ' write(nout,*)'Analysis by subroutine diagnostic' write(nout,*)' ' write(nout,702)graphnumber 702 format('graph number ',i3) write(nout,*)'Point:' DO p=1,nprops write(nout,703) p,k(p,1),k(p,2),k(p,3) 703 format('p =',i2,' k = ',3(1p g12.3)) END DO ! write(nout,*)' ' write(nout,*)'Softness:' DO p = 1,nprops write(nout,704) p,absk(p) 704 format('p =',i2,' |k| = ',1p g12.3) END DO ! write(nout,*)' ' write(nout,*)'Collinearity:' DO v = 3,nverts cos12 = 0.0d0 cos23 = 0.0d0 cos31 = 0.0d0 DO mu = 1,3 cos12 = cos12 + k(graph%prop(v,1),mu) * k(graph%prop(v,2),mu) cos23 = cos23 + k(graph%prop(v,2),mu) * k(graph%prop(v,3),mu) cos31 = cos31 + k(graph%prop(v,3),mu) * k(graph%prop(v,1),mu) END DO cos12 = cos12 /absk(graph%prop(v,1))/absk(graph%prop(v,2)) cos23 = cos23 /absk(graph%prop(v,2))/absk(graph%prop(v,3)) cos31 = cos31 /absk(graph%prop(v,3))/absk(graph%prop(v,1)) sin12 = sqrt(1.0d0 - cos12**2) sin23 = sqrt(1.0d0 - cos23**2) sin31 = sqrt(1.0d0 - cos31**2) write(nout,705)v,graph%prop(v,1),graph%prop(v,2),graph%prop(v,3), & sin12,sin23,sin31 705 format('v =',i2,' ps =',3i2,' sines =', 3f10.5) END DO ! write(nout,*)' ' call checkpoint(k,absk,graph%prop,order,badness) write(nout,706)badness 706 format('Badness of this point is',1p g10.2) ! write(nout,*)' ' write(nout,*)'Calculate finds the folowing:' ! report = .true. !! Use this if you want to see the contributions. ! details = .true. !! Use this if you want to see even more. ! jrandom = badpointinfo%jr ! This sets the state of the random number irandom = badpointinfo%ir ! generator to what it was just before rrandom = badpointinfo%rr ! calculate was called for the bad point. call calculate(graph,k,absk, & qs,qsigns,maptypes,nmaps,value,maxpart,valuechk) ! write(nout,707)value*groupsizetotal, abs(value)*groupsizetotal, & maxpart*groupsizetotal 707 format('valuept =',2(1p g12.4),' abs(valuept) = ',1p g12.4,/, & 'biggest contribution was ',1p g12.4) RETURN END subroutine diagnostic ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Shower Subroutines ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine softradiate(theshower) ! use beowulf_parameters use beowulf_structures implicit none ! In and Out: type(showerlist) :: theshower ! ! Starting with three final state partons from a Born graph, this subroutine ! radiates one soft gluon and adds it to the shower. It also adjusts the ! momenta of the emitting and absorbing parton by half of the soft gluon ! momentum so that the momenta still sum to zero and it calculates the ! factor by which the |matrix element|^2 should be multiplied to account ! for the soft gluon emission. The indices pii and pjj of the partons that ! emit and absorb the soft gluon are also recorded for use in calculating ! the |matrix element|^2. ! ! 5 April 2003 ! 16 June 2003 ! 28 September 2003 modify kappa ! 9 December 2003 ! 23 December 2004 ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 real(kind=dbl), parameter :: ckappasoft = 0.3d0 real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf real(kind=dbl) :: muoverrts common /renormalize/ muoverrts ! Physics data: real(kind=dbl) :: alphasofmz,sinsqthetaw,mz,widthz,externalrts common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! integer :: mu,n,i,j,ii,jj,kk real(kind=dbl) :: musq,alpival,alpi integer :: ptnindex(3) real(kind=dbl) :: qsq,absq,q(3,3),qhat(3,3) real(kind=dbl) :: cosqq(3,3) real(kind=dbl) :: random,x real(kind=dbl) :: costheta,phi real(kind=dbl) :: ea(3),eb(3),ec(3) real(kind=dbl) :: lhat(3) real(kind=dbl) :: norm real(kind=dbl) :: coslq(3) real(kind=dbl) :: colorfactor,fijk,density,softintegral real(kind=dbl) :: lsq,labs,l(3) real(kind=dbl) :: sinhinv real(kind=dbl) :: y,y0,x0 ! ! For testing, integer, save :: count=0 real(kind=dbl), save :: test=0.0d0 ! ! We need alpha_s/pi ! musq = (muoverrts*theshower%rts0)**2 alpival = alpi(muoverrts*externalrts) ! ! Find which parton is which. ! IF (theshower%length.NE.3) THEN write(nout,*)'Oops, softradiate called wrongly.' stop END IF DO n = 1,3 IF (theshower%ptn(n)%type.EQ.'quark') THEN ptnindex(1) = n ELSE IF (theshower%ptn(n)%type.EQ.'gluon') THEN ptnindex(2) = n ELSE IF (theshower%ptn(n)%type.EQ.'qbar ') THEN ptnindex(3) = n ELSE write(nout,*)'Parton type not found in softradiate.' stop END IF END DO ! ! Define momenta q, unit vectors qhat, and their dot products. ! DO n = 1,3 qsq = 0.0d0 DO mu = 1,3 q(n,mu) = theshower%ptn(ptnindex(n))%momentum(mu) qsq = qsq + q(n,mu)**2 END DO absq = sqrt(qsq) DO mu = 1,3 qhat(n,mu) = q(n,mu)/absq END DO END DO DO i = 1,2 DO j = i+1,3 cosqq(i,j) = 0.0d0 DO mu = 1,3 cosqq(i,j) = cosqq(i,j) + qhat(i,mu)*qhat(j,mu) END DO IF (cosqq(i,j).GT.0.9999999999999d0) THEN cosqq(i,j) = 0.9999999999999d0 ! This may prevent a divide by zero later on. END IF cosqq(j,i) = cosqq(i,j) END DO END DO cosqq(1,1) = 1.0d0 cosqq(2,2) = 1.0d0 cosqq(3,3) = 1.0d0 ! ! Choose emitting (ii) and absorbing (jj) partons at random. ! x = random(1) IF (x.LT.0.111111111111111111d0) THEN ii = 1 jj = 2 ELSE IF (x.LT.0.222222222222222222d0) THEN ii = 2 jj = 1 ELSE IF (x.LT.0.333333333333333333d0) THEN ii = 2 jj = 3 ELSE IF (x.LT.0.444444444444444444d0) THEN ii = 3 jj = 2 ELSE IF (x.LT.0.555555555555555556d0) THEN ii = 3 jj = 1 ELSE IF (x.LT.0.666666666666666667d0) THEN ii = 1 jj = 3 ELSE IF (x.LT.0.777777777777777778d0) THEN ii = 1 jj = 1 ELSE IF (x.LT.0.888888888888888889d0) THEN ii = 2 jj = 2 ELSE ii = 3 jj = 3 END IF ! ! We want to choose lhat(mu). ! There are two cases: first is for the interference terms, with ! emittingparton.ne.absorbingparton; then the second is for ! emittingparton.eq.absorbingparton. ! IF (ii.NE.jj) THEN ! ! Choose theta and phi, uniformly in phi, but with a density ! d N/d costheta = 1/[4 sqrt(y0) arcsinh(sqrt(1/y0))]/sqrt(y)/sqrt(1+y/y0) ! where y = (1 - costheta)/2 and we take y0 = (1 - cosqq(i,j))/8. ! x = random(1) y0 = (1 - cosqq(ii,jj))/8.0d0 x0 = 1/sinhinv(sqrt(1/y0)) y = y0*sinh(x/x0)**2 costheta = 1.0d0 - 2.0d0 * y IF (costheta.GT.0.9999999999999d0) THEN costheta = 0.9999999999999d0 ! This prevents divide by zero later on. END IF x = random(1) phi = 2.0d0*pi*x ! ! Generate lhat with a distribution in theta and phi as above, ! where theta is the angle between lhat and either the emitting parton ! direction (with probability 1/2) or the absorbing parton direction ! (with probability 1/2). ! x = random(1) IF (x.LT.0.5d0) THEN DO mu = 1,3 ea(mu) = qhat(ii,mu) END DO ELSE DO mu = 1,3 ea(mu) = qhat(jj,mu) END DO END IF ! call axes(ea,eb,ec) DO mu = 1,3 lhat(mu) = costheta*ea(mu) & + sqrt(1.0d0 - costheta**2)*(cos(phi)*eb(mu) + sin(phi)*ec(mu)) END DO ! ELSE ! ii.EQ.jj ! x = random(1) IF (x.lt.0.5d0) THEN kk = mod(ii,3) + 1 ! 1 -> 2, 2 -> 3, 3 -> 1 ELSE kk = mod(ii + 1,3) + 1 ! 1 -> 3, 2 -> 1, 3 -> 2 END IF ! ! Choose theta and phi, uniformly in phi, but with a density ! d N/d costheta = 1/(1 - costheta)/log(2/(1-costhetamax)) ! norm = log( 2.0d0/(1.0d0 - cosqq(ii,kk)) ) x = random(1) costheta = 1.0d0 - 2.0d0*exp(-norm*x) x = random(1) phi = 2.0d0*pi*x DO mu = 1,3 ea(mu) = qhat(ii,mu) END DO call axes(ea,eb,ec) DO mu = 1,3 lhat(mu) = costheta*ea(mu) & + sqrt(1.0d0 - costheta**2)*(cos(phi)*eb(mu) + sin(phi)*ec(mu)) END DO ! END IF ! (ii.NE.jj)...ELSE... ! ! We have chosen lhat(mu). Now calculate fijk. (This is called F_{ij} in ! the notes, but for j=i there are two terms depending on another index ! called a there and k here. Each term is then denoted fijk here. ! DO i = 1,3 coslq(i) = 0.0d0 DO mu = 1,3 coslq(i) = coslq(i) + lhat(mu)*qhat(i,mu) END DO IF (coslq(i).GT.0.9999999999999d0) THEN coslq(i) = 0.9999999999999d0 ! This may prevent a divide by zero later on. END IF END DO ! IF (ii.NE.jj) THEN ! IF ((ii.EQ.2).OR.(jj.EQ.2)) THEN colorfactor = - 0.5d0*nc ELSE colorfactor = 0.5d0/nc END IF fijk = colorfactor*(cosqq(ii,jj) - coslq(ii)*coslq(jj)) & /(1.0d0 - coslq(ii))/(1.0d0 - coslq(jj)) ! ELSE ! ii.EQ.jj ! IF ((ii.EQ.2).OR.(kk.EQ.2)) THEN colorfactor = 0.5d0*nc ELSE colorfactor = - 0.5d0/nc END IF fijk = colorfactor*(1.0d0 + coslq(ii))/(1.0d0 - coslq(ii)) ! END IF ! (ii.NE.jj)...ELSE... ! ! We have chosen points hatl(mu). Now we need the density of points ! in {lhat,ii,jj,kk}. Recall that x0 = 1/sinhinv(sqrt(1/y0)) ! and y0 = (1 - cosqq(ii,jj))/8.0d0 for ii.ne.jj or ! norm = log( 2.0d0/(1.0d0 - cosqq(ii,kk)) ) for ii.eq.jj. ! IF (ii.ne.jj) THEN y = 0.5d0*(1.0d0 - coslq(ii)) density = 1.0d0/sqrt(y)/sqrt(1.0d0 + y/y0) y = 0.5d0*(1.0d0 - coslq(jj)) density = density + 1.0d0/sqrt(y)/sqrt(1.0d0 + y/y0) density = density*x0/sqrt(y0)/16.0d0/pi ! This includes 1/(2 pi) for the phi integral and 1/2 for the ! random choice of alignment with qii or qjj. ELSE ! ii.eq.jj density = 1.0d0/(1.0d0 - coslq(ii))/norm density = density/2.0d0/pi ! 1/(2 pi) for the phi integral density = density/2.0d0 ! For the random choice of k END IF density = density/9.0d0 ! For random choice of i,j ! ! Calculate the soft angular integral, ! \sum_{ij} \int d^2\hat l/(4\pi) F_{ij}(\hat l,\hat q_1,\hat q_2,\hat q_2) ! = (nc/2)(1 - \hat q_1\cdot \hatq_2) + (nc/2)(1 - \hat q_3\cdot \hatq_2) ! - (1/2/nc)(1 - \hat q_1\cdot \hatq_3) ! softintegral = 0.5d0*nc*(2.0d0 - cosqq(1,2) - cosqq(2,3)) & - 0.5d0/nc*(1.0d0 - cosqq(1,3)) ! ! We now have lhat and the density of points lhat. We need the absolute ! value of l. ! x = random(1) lsq = theshower%msoftsq*x**(2.0d0/alpival/softintegral) labs = sqrt(lsq) ! ! We form l(mu) and adjust the final state parton momenta. ! DO mu = 1,3 l(mu) = labs*lhat(mu) theshower%ptn(ptnindex(ii))%momentum(mu) = & theshower%ptn(ptnindex(ii))%momentum(mu) - 0.5d0*l(mu) theshower%ptn(ptnindex(jj))%momentum(mu) = & theshower%ptn(ptnindex(jj))%momentum(mu) - 0.5d0*l(mu) END DO ! ! Finally, we record the original parton labels corresponding ! to ii and jj, we record the factor that will multiply ! the Born graph, which is fijk/(4 Pi * softintegral)/density, ! and we add the soft gluon to the shower. ! theshower%multfactor = fijk/4.0d0/pi/softintegral/density theshower%pii = ptnindex(ii) theshower%pjj = ptnindex(jj) theshower%length = 4 theshower%ptn(4)%type = 'gluon' theshower%ptn(4)%self = 4 theshower%ptn(4)%parent = 0 theshower%ptn(4)%ancestor = 4 theshower%ptn(4)%child1 = -1 theshower%ptn(4)%child2 = -1 theshower%ptn(4)%childless = .true. theshower%ptn(4)%done = .false. DO mu = 1,3 theshower%ptn(4)%momentum(mu) = l(mu) END DO theshower%ptn(4)%kappasq = ckappasoft * lsq theshower%ptn(4)%flavor = 0 ! ! String analysis. ! theshower%nstrings = 3 + 500 ! The string indices start at 501. ! IF ((ii.eq.1).AND.(jj.EQ.1)) THEN theshower%ptn(ptnindex(1))%stringquark = 503 theshower%ptn(4)%stringqbar = 503 theshower%ptn(4)%stringquark = 501 ELSE IF ((ii.eq.2).AND.(jj.EQ.2)) THEN IF (random(1).LT.0.5d0) THEN theshower%ptn(ptnindex(2))%stringqbar = 503 theshower%ptn(4)%stringquark = 503 theshower%ptn(4)%stringqbar = 501 ELSE theshower%ptn(ptnindex(2))%stringquark = 503 theshower%ptn(4)%stringqbar = 503 theshower%ptn(4)%stringquark = 502 END IF ELSE IF ((ii.eq.3).AND.(jj.EQ.3)) THEN theshower%ptn(ptnindex(3))%stringqbar = 503 theshower%ptn(4)%stringquark = 503 theshower%ptn(4)%stringqbar = 502 ELSE IF (((ii.eq.2).AND.(jj.EQ.1)).OR.((ii.eq.1).AND.(jj.EQ.2))) THEN theshower%ptn(ptnindex(1))%stringquark = 503 theshower%ptn(4)%stringqbar = 503 theshower%ptn(4)%stringquark = 501 ELSE IF (((ii.eq.2).AND.(jj.EQ.3)).OR.((ii.eq.3).AND.(jj.EQ.2))) THEN theshower%ptn(ptnindex(3))%stringqbar = 503 theshower%ptn(4)%stringquark = 503 theshower%ptn(4)%stringqbar = 502 ELSE IF (((ii.eq.1).AND.(jj.EQ.3)).OR.((ii.eq.3).AND.(jj.EQ.1))) THEN IF (random(1).LT.0.5d0) THEN theshower%ptn(ptnindex(2))%stringqbar = 503 theshower%ptn(4)%stringquark = 503 theshower%ptn(4)%stringqbar = 501 ELSE theshower%ptn(ptnindex(2))%stringquark = 503 theshower%ptn(4)%stringqbar = 503 theshower%ptn(4)%stringquark = 502 END IF ELSE write(nout,*)'Mixed up in softradiate.' STOP END IF ! ! Uncomment this if you want to see if the soft integration works. ! count = count + 1 ! test = test + fijk/4.0d0/pi/softintegral/density ! IF (mod(count,10000).EQ.0) THEN ! write(nout,*)'For count = ',count,'soft test integral = ',test/count ! END IF ! end subroutine softradiate ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine makeshowerI(theshower,softinfos) ! use beowulf_parameters use beowulf_structures implicit none ! In: type(softinformation), dimension(3) :: softinfos ! In and Out: type(showerlist) :: theshower ! ! This subroutine creates the beginnings of a shower starting from three ! hard partons emerging from a Born graph, whose parton information is ! initially found in 'theshower'. (One soft gluon has also been created ! by subroutine softradiate, but is not touched here.) Each hard parton ! splits once, with the subroutine splitI, which is based on the exact ! one loop self-energy function in Coulomb gauge. ! ! Note: ! theshower%multfactor is divided by the densities of points {qbarsq,x,phi} ! for each splitting in the first level splittings from a Born graph. ! The Sudakov factor is not included, nor are 1/qbarsq/(2 pi). ! ! 10 November 2002 ! 13 March 2003 ! 5 December 2003 ! integer :: n,currentN,currentNS type(parton) :: mother,daughter1,daughter2 real(kind=dbl) :: splitdensityval ! DO n = 1,3 mother = theshower%ptn(n) currentN = theshower%length currentNS = theshower%nstrings call splitI(currentN,currentNS,theshower%rts0,mother,softinfos(n), & daughter1,daughter2,splitdensityval) theshower%ptn(n) = mother ! mother has been modified theshower%ptn(currentN + 1) = daughter1 theshower%ptn(currentN + 2) = daughter2 theshower%length = currentN + 2 ! Two partons were added theshower%nstrings = currentNS ! A string may have been added. theshower%multfactor = theshower%multfactor/splitdensityval END DO ! END subroutine makeshowerI ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine splitI(currentN,currentNS,rts0,mother,softinfo, & daughter1,daughter2,splitdensityval) ! use beowulf_parameters use beowulf_structures implicit none ! In: integer :: currentN ! We do not modify currentN. real(kind=dbl) :: rts0 type(softinformation) :: softinfo ! In and Out: type(parton) :: mother ! We modify mother. integer :: currentNS ! We may add a string. ! Out: type(parton) :: daughter1, daughter2 real(kind=dbl) :: splitdensityval ! ! This subroutine 'splits' a mother parton into two daughters ! using the exact one-loop self-energy function in Coulomb gauge ! minus a soft gluon subtraction that removes soft wide angle splitting. ! That is, given the information stored in 'mother', it creates ! information for 'daughter1' and 'daughter2' according to ! this probability distribution. ! ! 28 October 2002 ! 22 May 2003 ! 28 September 2003 ! 6 December 2003 ! ! Physics data: real(kind=dbl) :: alphasofmz,sinsqthetaw,mz,widthz,externalrts common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! ! Color factors: real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 real(kind=dbl), parameter :: ckappa = 4.0d0 real(kind=dbl), parameter :: tiny = 1.0d-10 logical, save :: writetinymessage = .true. ! ! For diagnosis: logical :: showercheck common /showercheckinfo/ showercheck integer :: count integer, save :: countg = 0, countq = 0, countgg = 0, countgq = 0 real(kind=dbl), save :: testgg=0.0d0, testgq=0.0d0, testq=0.0d0 real(kind=dbl), save :: triesgg=0.0d0,triesgq=0.0d0,triesq=0.0d0 ! integer :: mu real(kind=dbl) :: qbarsq,x,phi character(len=5) :: type0,type1,type2 ! parton types for mother and daughters integer :: flavorindex real(kind=dbl) :: random,r,fraction real(kind=dbl) :: calqsq,calq real(kind=dbl), dimension(3) :: nx,ny,nz,ell real(kind=dbl) :: lt,lq,cosphi,sinphi,calQ1,calQ2 real(kind=dbl) :: approxcalpval,approxcalp,truecalpval,truecalp real(kind=dbl) :: splitdensity0 real(kind=dbl) :: pbarsqinv real(kind=dbl) :: nfmax ! ! Start by supplying straightforward information. ! daughter1%self = currentN + 1 daughter2%self = currentN + 2 daughter1%parent = mother%self daughter2%parent = mother%self daughter1%ancestor = mother%ancestor daughter2%ancestor = mother%ancestor daughter1%child1 = -1 daughter2%child1 = -1 daughter1%child2 = -1 daughter2%child2 = -1 mother%child1 = daughter1%self mother%child2 = daughter2%self mother%childless = .false. daughter1%childless = .true. daughter2%childless = .true. daughter1%done = .false. daughter2%done = .false. ! ! The momentum scale is provided by {\cal Q}, the absolute value of the ! mother parton's momentum. ! calqsq = 0.0d0 DO mu = 1,3 calqsq = calqsq + mother%momentum(mu)**2 END DO calq = sqrt(calqsq) ! ! Now, we generage qbarsq. getqbarsq0 gives a qbarsq according to the ! distribution approxcalp. We keep the selected point with probability ! truecalp/approxcalp. ! type0 = mother%type pbarsqinv = 0.0d0 count = 1 DO call getqbarsq0(rts0,calqsq,pbarsqinv,type0,qbarsq) IF (qbarsq/calqsq .LT. tiny) THEN IF (writetinymessage) THEN write(nout,*)'Primary splitting in splitI aborted because of' write(nout,*)'small qbarsq/calqsq,',qbarsq/calqsq write(nout,*)'Further such messages will be suppressed.' writetinymessage = .false. END IF qbarsq = tiny * calqsq exit END IF approxcalpval = approxcalp(rts0,calqsq,type0,qbarsq) truecalpval = truecalp(rts0,calqsq,type0,softinfo,qbarsq) fraction = truecalpval/approxcalpval IF (fraction.GT.1.0d0) THEN write(nout,*)'Oops, truecalp > approxcalp in splitI.' write(nout,*)'truecalp = ',truecalpval,' approxcalp =',approxcalpval write(nout,*)'truecalp/approxcalp = ',fraction write(nout,*)'mother parton type was ',mother%type write(nout,*)'rts0sq = ',rts0**2,'calQsq =',calqsq,' qbarsq',qbarsq write(nout,*)'sister1 is ',softinfo%type1, & ' with cos1 = ',softinfo%cos1 write(nout,*)'sister2 is ',softinfo%type2, & ' with cos2 = ',softinfo%cos2 write(nout,*)'soft scale is msoftsq =',softinfo%msoftsq STOP END IF IF (fraction.LT.0.0d0) THEN write(nout,*)'Oops, c was supposed to positive.', qbarsq STOP END IF r = random(1) IF (fraction .GT. r) EXIT pbarsqinv = 1/qbarsq count = count + 1 END DO ! ! We have qbarsq, but we need types, x, and phi. ! call gettypexphi0(qbarsq,calqsq,type0,x,phi,type1,type2) ! ! Also, we need the density of points, excluding the Sudakov factor. ! splitdensityval = & splitdensity0(qbarsq,x,phi,type0,type1,type2,rts0,calqsq,softinfo) ! !------------------------------------ ! We use {qbarsq, x, phi} to generate the daughter momenta and ! the value of kappasq to be used later for splitting the daughters. ! ! First we calculate the unit vectors n_x, n_y, n_z used to define ! the orientation of the elliptical coordinate system. ! DO mu = 1,3 nz(mu) = mother%momentum(mu)/calq END DO call axes(nz,ny,nx) ! ! Now we find l(mu). ! lt = sqrt(x*(1.0d0 - x)*qbarsq) lq = 0.5d0*calq*sqrt(1.0d0 + qbarsq/calqsq)*(2.0d0*x - 1.0d0) cosphi = cos(phi) sinphi = sin(phi) DO mu = 1,3 ell(mu) = lt*cosphi*nx(mu) + lt*sinphi*ny(mu) + lq*nz(mu) END DO ! ! This gives the daughter type, momenta and kappasq values. ! DO mu = 1,3 daughter1%momentum(mu) = 0.5d0*mother%momentum(mu) + ell(mu) daughter2%momentum(mu) = 0.5d0*mother%momentum(mu) - ell(mu) END DO calQ1 = sqrt((0.5d0*calQ + lq)**2 + lt**2) calQ2 = sqrt((0.5d0*calQ - lq)**2 + lt**2) daughter1%kappasq = min(x*qbarsq/(1.0d0 - x),calQ1**2,ckappa*qbarsq) daughter2%kappasq = min((1.0d0 - x)*qbarsq/x,calQ2**2,ckappa*qbarsq) ! IF (type0.EQ.'gluon') THEN IF ((type1.EQ.'gluon').AND.(type2.EQ.'gluon')) THEN daughter1%type = 'gluon' daughter2%type = 'gluon' daughter1%flavor = 0 daughter2%flavor = 0 daughter1%stringquark = mother%stringquark daughter1%stringqbar = currentNS + 1 daughter2%stringquark = currentNS + 1 daughter2%stringqbar = mother%stringqbar currentNS = currentNS + 1 ! We have added one string ELSE IF ((type1.EQ.'quark').AND.(type2.EQ.'qbar ')) THEN daughter1%type = 'quark' daughter2%type = 'qbar ' ! Find flavors available for splitting, in a crude approximation. ! g --> t, tbar is never allowed. Of course, the perturbative diagrams ! have nf *massless* quarks, but for small qbarsq it isn't nice to actually ! try to put a heavy quark in the final state. IF (qbarsq.GT.200.0d0) THEN ! 2 * (2*5 GeV)^2 nfmax = 5.0d0 ! u,d,s,c,b ELSE IF (qbarsq.GT.18.0d0) THEN ! 2 * (2*1.5 GeV)^2 nfmax = 4.0d0 ! u,d,s,c ELSE IF (qbarsq.GT.2.0d0) THEN ! 2 * (2*0.5)^2 nfmax = 3.0d0 ! u,d,s ELSE nfmax = 2.0d0 ! u,d END IF nfmax = min(nf,nfmax) ! Heaviest quark available for splitting. flavorindex = ceiling(random(1)*nfmax) ! choose the flavor at random daughter1%flavor = flavorindex daughter2%flavor = - flavorindex daughter1%stringquark = mother%stringquark daughter1%stringqbar = 0 ! only one string for quarks daughter2%stringquark = 0 ! only one string for qbars daughter2%stringqbar = mother%stringqbar ELSE write(nout,*)'Oops, splitI is confused.' STOP END IF ELSE IF (type0.EQ.'quark') THEN IF ((type1.EQ.'gluon').AND.(type2.EQ.'quark')) THEN daughter1%type = 'gluon' daughter2%type = 'quark' daughter1%flavor = 0 daughter2%flavor = mother%flavor daughter1%stringquark = mother%stringquark daughter1%stringqbar = currentNS + 1 daughter2%stringquark = currentNS + 1 daughter2%stringqbar = 0 ! only one string for quarks currentNS = currentNS + 1 ! We have added one string ELSE write(nout,*)'Oops, splitI is confused.' STOP END IF ELSE IF (type0.EQ.'qbar ') THEN IF ((type1.EQ.'gluon').AND.(type2.EQ.'qbar ')) THEN daughter1%type = 'gluon' daughter2%type = 'qbar ' daughter1%flavor = 0 daughter2%flavor = mother%flavor daughter1%stringquark = currentNS + 1 daughter1%stringqbar = mother%stringqbar daughter2%stringquark = 0 ! only one string for qbars daughter2%stringqbar = currentNS + 1 currentNS = currentNS + 1 ! We have added one string ELSE write(nout,*)'Oops, splitI is confused.' STOP END IF ELSE write(nout,*)'Oops, splitI is confused.' STOP END IF ! (type0.EQ.'gluon') ELSE ... ! !------------------------------------ ! ! Diagnostics ! IF (showercheck) THEN IF (type0.EQ.'gluon') THEN countg = countg + 1 IF (type1.EQ.'gluon') THEN countgg = countgg + 1 testgg = testgg + truecalpval/splitdensityval triesgg = triesgg + count ELSE countgq = countgq + 1 testgq = testgq + truecalpval/splitdensityval triesgq = triesgq + count END IF ELSE countq = countq + 1 testq = testq + truecalpval/splitdensityval triesq = triesq + count END IF IF (mod(countg+countq,10000).EQ.0) THEN write(nout,*)'For count gg = ',countgg, & 'collinear test integral gg = ',testgg/countg write(nout,*)'For count gq = ',countgq, & 'collinear test integral gq = ',testgq/countg write(nout,*)'For countq = ',countq, & 'collinear test integral q = ',testq/countq write(nout,*)'Average numbers of tries are', & triesgg/countgg,triesgq/countgq,triesq/countq END IF END IF ! showercheck ! END subroutine splitI ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine getqbarsq0(rts0,calqsq,pbarsqinv,type0,qbarsq) use beowulf_parameters implicit none ! In: real(kind=dbl) :: rts0,calqsq,pbarsqinv character(len=5) :: type0 ! quark, qbar, gluon ! Out: real(kind=dbl) :: qbarsq ! ! Produces qbarsq distributed according to a simple function approxc0(qbarsq): ! ! density = approxc0(qbarsq) ! x exp[ - int_qbarsq^pbarsq d lbarsq approxc0(lbarsq) ] ! d qbarsq ! where ! ! approxc0(qbarsq) = alpha_s/(2 Pi)/qbarsq * approxcalP(qbarsq) ! ! The subroutine getqbarsq0 matches the function approxcalP. ! 19 October 2002 ! 22 March 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf real(kind=dbl) :: muoverrts common /renormalize/ muoverrts ! Physics data: real(kind=dbl) :: alphasofmz,sinsqthetaw,mz,widthz,externalrts common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! real(kind=dbl) :: random,r real(kind=dbl) :: b,musq,musqmod,alpi,alpival,colorfactor real(kind=dbl) :: ip,iq,temp,root,thelog ! !--- ! musq = (muoverrts*rts0)**2 musqmod = min(musq,calqsq) alpival = alpi(muoverrts*externalrts) ! IF (type0.EQ.'gluon') THEN b = 6.0d0*nc*calqsq/5.0d0 b = b + (2.0d0*nf - 3.0d0*nc)*musqmod/18.0d0*(8.0d0 + 3.0d0*log(musq/musqmod)) b = 1.1d0*b ! This makes approxcalP just a little bigger. colorfactor = nc ELSE IF ((type0.EQ.'quark').OR.(type0.EQ.'qbar ')) THEN b = 22.0d0*cf*calqsq/15.0d0 b = b + cf*musqmod/6.0d0*(4.0d0 + 3.0d0*log(musq/musqmod)) b = 1.1d0*b ! This makes approxcalP just a little bigger. colorfactor = cf ELSE write(nout,*)'Unknown parton type in getqbarsq0.' stop END IF IF (musqmod*pbarsqinv.GT.1.0d0) THEN temp = log(musqmod*pbarsqinv) ip = colorfactor*temp**2 + b/musqmod*(temp + 1) ELSE ip = b*pbarsqinv END IF r = random(1) iq = ip + log(1/r)*2.0d0/alpival IF (iq.LT.b/musqmod) THEN qbarsq = b/iq ELSE temp = b/musqmod root = sqrt(temp**2 + 4.0d0*colorfactor*(iq - temp)) thelog = (root - temp)/2.0d0/colorfactor qbarsq = musqmod*exp(-thelog) END IF ! END subroutine getqbarsq0 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function approxcalp(rts0,calqsq,type0,qbarsq) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: rts0,calqsq character(len=5) :: type0 ! quark, qbar, gluon real(kind=dbl) :: qbarsq ! Out: real(kind=dbl) :: approxcalp ! ! The function approxcalP(qbarsq) used for approximate splitting: ! ! density = approxc0(qbarsq) ! x exp[ - int_qbarsq^pbarsq d lbarsq approxc0(lbarsq) ] ! d qbarsq ! ! where ! ! approxc0(qbarsq) = alpha_s/(2 Pi)/qbarsq * approxcalP(qbarsq) ! ! The function approxcalP(qbarsq) matches getqbarsq0. ! 22 March 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf real(kind=dbl) :: muoverrts common /renormalize/ muoverrts ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! real(kind=dbl) :: musq,musqmod real(kind=dbl) :: b,colorfactor ! musq = (muoverrts*rts0)**2 musqmod = min(musq,calqsq) ! IF (type0.EQ.'gluon') THEN b = 6.0d0*nc*calqsq/5.0d0 b = b + (2.0d0*nf - 3.0d0*nc)*musqmod/18.0d0*(8.0d0 + 3.0d0*log(musq/musqmod)) b = 1.1d0*b ! This makes approxcalP just a little bigger. colorfactor = nc ELSE IF ((type0.EQ.'quark').OR.(type0.EQ.'qbar ')) THEN b = 22.0d0*cf*calqsq/15.0d0 b = b + cf*musqmod/6.0d0*(4.0d0 + 3.0d0*log(musq/musqmod)) b = 1.1d0*b ! This makes approxcalP just a little bigger. colorfactor = cf ELSE write(nout,*)'Unknown parton type in approxcalp.' stop END IF IF (qbarsq.LT.musqmod) THEN approxcalp = 2.0d0*colorfactor*log(musqmod/qbarsq) + b/musqmod ELSE approxcalp = b/qbarsq END IF ! END function approxcalp ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function truecalp(rts0,calqsq,type0,softinfo,qbarsq) ! use beowulf_parameters use beowulf_structures implicit none ! In: real(kind=dbl) :: rts0,calqsq character(len=5) :: type0 ! quark, qbar, gluon real(kind=dbl) :: qbarsq type(softinformation) :: softinfo ! Out: real(kind=dbl) :: truecalp ! ! The function truecalP(qbarsq) used for Born level splitting: ! ! density = truec0(qbarsq) ! x exp[ - int_qbarsq^pbarsq d lbarsq truec0(lbarsq) ] ! d qbarsq ! ! where ! ! truec0(qbarsq) = alpha_s/(2 Pi)/qbarsq * truecalP(qbarsq) ! 19 October 2002 ! 24 June 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf real(kind=dbl) :: muoverrts common /renormalize/ muoverrts ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! real(kind=dbl) :: musq,musqmod,qoq,qom,denomm,denomq,thelog real(kind=dbl) :: temp real(kind=dbl) :: delta,sqrtm1,xmax,isoft,xmaxsoft real(kind=dbl) :: colorfactor1,colorfactor2 real(kind=dbl) :: softp1,softp2 ! musq = (muoverrts*rts0)**2 musqmod = min(musq,calqsq) qoq = qbarsq/calqsq qom = qbarsq/musqmod denomm = 1.0d0 + qom denomq = 1.0d0 + qoq thelog = log( (sqrt(denomq) + 1.0d0)/(sqrt(denomq) - 1.0d0) ) ! IF (type0.EQ.'gluon') THEN IF (qoq.LT.1.0d2) THEN temp = (2.0d0*nf - 3.0d0*nc) temp = temp*(3.0d0 + 8.0d0*qom + 3.0d0*qom*log(musq/musqmod)) temp = temp/18.0d0/denomm**2 truecalp = temp temp = nc*(5.0d0 + 2.0d0*qoq)*(4.0d0 + 3.0d0*qoq) temp = temp/6.0d0/denomq truecalp = truecalp - temp temp = nc*(2.0d0 + qoq)*(4.0d0 + 5.0d0*qoq + 2.0d0*qoq**2)*thelog temp = temp/4.0d0/denomq**1.5d0 truecalp = truecalp + temp ELSE ! We need an expansion in powers of 1/q0q. temp = (2.0d0*nf - 3.0d0*nc) temp = temp*(3.0d0 + 8.0d0*qom + 3.0d0*qom*log(musq/musqmod)) temp = temp/18.0d0/denomm**2 truecalp = temp temp = nc*(6.0d0/5.0d0/qoq + 8.0d0/105.0d0/qoq**2 & - 208.0d0/315.0d0/qoq**3 + 1216.0d0/1155.0d0/qoq**4 & - 61184.0d0/45045.0d0/qoq**5 + 72704.0d0/45045.0d0/qoq**6) truecalp = truecalp + temp END IF ! Do soft subtraction (if delta is in range). delta = sqrtm1(qbarsq/calqsq) ! sqrtm1(x) = sqrt(1 + x) - 1 xmaxsoft = sqrt(softinfo%msoftsq/calqsq) - 0.5d0*delta IF (xmaxsoft.GT.0.0d0) THEN colorfactor1 = 0.5d0*nc colorfactor2 = 0.5d0*nc xmax = 0.5d0*delta*(1.0d0 + softinfo%cos1)/(1.0d0 + delta - softinfo%cos1) xmax = min(xmax,xmaxsoft) softp1 = colorfactor1/(1.0d0 + delta) & ! first subtraction term *isoft(xmax,delta) xmax = 0.5d0*delta*(1.0d0 + softinfo%cos2)/(1.0d0 + delta - softinfo%cos2) xmax = min(xmax,xmaxsoft) softp2 = colorfactor2/(1.0d0 + delta) & ! second subtraction term *isoft(xmax,delta) truecalp = truecalp - softp1 - softp2 END IF ! xmaxsoft > 0 ! Done with soft subtraction ELSE IF ((type0.EQ.'quark').OR.(type0.EQ.'qbar ')) THEN IF (qoq.LT.1.0d2) THEN temp = cf*(3.0d0 + 4.0d0*qom + 3.0d0*qom*log(musq/musqmod)) temp = temp/6.0d0/denomm**2 truecalp = temp temp = 0.5d0*cf*(8.0d0 + 3.0d0*qoq) truecalp = truecalp - temp temp = cf*(2.0d0 + qoq)*(4.0d0 + 3.0d0*qoq)*thelog temp = temp/4.0d0/denomq**0.5d0 truecalp = truecalp + temp ELSE ! We need an expansion in powers of 1/q0q. temp = cf*(3.0d0 + 4.0d0*qom + 3.0d0*qom*log(musq/musqmod)) temp = temp/6.0d0/denomm**2 truecalp = temp temp = cf*(22.0d0/15.0d0/qoq - 24.0d0/35.0d0/qoq**2 & + 16.0d0/35.0d0/qoq**3 - 1216.0d0/3465.0d0/qoq**4 & + 4352.0d0/15015.0d0/qoq**5 - 1024.0d0/4095.0d0/qoq**6) truecalp = truecalp + temp END IF ! Do soft subtraction. delta = sqrtm1(qbarsq/calqsq) ! sqrtm1(x) = sqrt(1 + x) - 1 xmaxsoft = sqrt(softinfo%msoftsq/calqsq) - 0.5d0*delta IF (xmaxsoft.GT.0.0d0) THEN IF (softinfo%type1.EQ.'gluon') then colorfactor1 = 0.5d0*nc colorfactor2 = - 0.5d0/nc ELSE IF (softinfo%type2.EQ.'gluon') then colorfactor2 = 0.5d0*nc colorfactor1 = - 0.5d0/nc ELSE write(nout,*)'parton types messed up in truecalp.' STOP END IF xmax = 0.5d0*delta*(1.0d0 + softinfo%cos1)/(1.0d0 + delta - softinfo%cos1) xmax = min(xmax,xmaxsoft) softp1 = colorfactor1/(1.0d0 + delta) & ! first subtraction term *isoft(xmax,delta) xmax = 0.5d0*delta*(1.0d0 + softinfo%cos2)/(1.0d0 + delta - softinfo%cos2) xmax = min(xmax,xmaxsoft) softp2 = colorfactor2/(1.0d0 + delta) & ! second subtraction term *isoft(xmax,delta) truecalp = truecalp - softp1 - softp2 END IF ! xmaxsoft > 0 ! Done with soft subtraction ELSE write(nout,*)'Unknown parton type in truecalp.' stop END IF IF (truecalp.LT.0.0d0) THEN write(nout,*)'Houston, we have a problem.' write(nout,*)'plaincalp = ',truecalp+softp1+softp2 write(nout,*)' softp1 = ',softp1 write(nout,*)' softp2 = ',softp2 write(nout,*)' truecalp = ',truecalp,' for' write(nout,*)'qbarsq = ',qbarsq,' with' write(nout,*)' rts0 = ',rts0 write(nout,*)' calqsq = ',calqsq write(nout,*)' type0 = ',type0 write(nout,*)'softinfo%type0 = ',softinfo%type0 write(nout,*)'softinfo%type1 = ',softinfo%type1 write(nout,*)'softinfo%type2 = ',softinfo%type2 write(nout,*)' softinfo%cos1 = ',softinfo%cos1 write(nout,*)' softinfo%cos2 = ',softinfo%cos2 write(nout,*)'softinfo%msoftsq = ',softinfo%msoftsq stop END IF ! END function truecalp ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function isoft(xmax,delta) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: xmax,delta ! Out: real(kind=dbl) :: isoft ! ! The integral over x of P_i^{soft}(x, qbarsq) is the sum over a = 1,2,3 ! not a = i of color factors -c_{ia} times this integral, with choices ! x^a_{max} for the maximum x in the integral. ! ! 18 March 2003 ! 14 June 2003 ! real(kind=dbl) :: b real(kind=dbl) :: c1,c2,c3 real(kind=dbl) :: f1,f2,f3 real(kind=dbl) :: y,dy real(kind=dbl) :: log1px ! b = 2.0d0 + delta ! c1 = 2.0d0 c2 = - 2.0d0 c3 = b*delta ! y = delta dy = 2.0d0*xmax ! ! log1px(x) = log(1.0d0 + x) ! f1 = log1px(dy/y) f2 = log1px(-dy/(b-y)) f3 = - dy/y/(y + dy) ! isoft = c1*f1 + c2*f2 + c3*f3 ! IF (isoft.LT.-1.0d-10) THEN write(nout,*)'isoft<-1.0d-10',xmax,delta stop END IF ! RETURN END function isoft ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine gettypexphi0(qbarsq,calqsq,type0,x,phi,type1,type2) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: qbarsq,calqsq character(len=5) :: type0 ! quark, qbar, gluon !Out: real(kind=dbl) :: x,phi character(len=5) :: type1,type2 ! quark, qbar, gluon ! ! Produces x,phi,type1,type2 distributed according to a simple function. ! 20 October 2002 ! 5 April 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! real(kind=dbl) :: random,r real(kind=dbl) :: integralq,integralg,temp ! !--- ! IF (type0.EQ.'gluon') THEN integralq = 0.5d0 integralg = nc*(1.0d0 + qbarsq/calqsq)*log(1.0d0 + calqsq/qbarsq) r = random(1) IF ( integralg/(integralg + nf*integralq).GT.r) THEN type1 = 'gluon' type2 = 'gluon' r = random(1) temp = 1.0d0 + calqsq/qbarsq IF (r.LT.0.5d0) THEN x = 0.5d0*qbarsq/calqsq*(temp**(2*r) - 1.0d0) ELSE r = 1.0d0 - r x = 0.5d0*qbarsq/calqsq*(temp**(2*r) - 1.0d0) x = 1.0d0 - x END IF ELSE type1 = 'quark' type2 = 'qbar ' r = random(1) x = r END IF ELSE IF ((type0.EQ.'quark').OR.(type0.EQ.'qbar ')) THEN type1 = 'gluon' type2 = type0 r = random(1) temp = 1.0d0 + calqsq/qbarsq x = qbarsq/calqsq*(temp**r - 1.0d0) ELSE write(nout,*)'Unknown parton type in gettypexphi0.' stop END IF r = random(1) phi = (2.0d0*r - 1.0d0)*pi ! END subroutine gettypexphi0 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function & splitdensity0(qbarsq,x,phi,type0,type1,type2,rts0,calqsq,softinfo) ! use beowulf_parameters use beowulf_structures implicit none ! In: real(kind=dbl) :: qbarsq,x,phi,rts0,calqsq character(len=5) :: type0,type1,type2 ! quark, qbar, gluon type(softinformation) :: softinfo !Out: real(kind=dbl) :: splitdensity0 ! ! Density of points {qbarsq,x,phi} for each splitting in the first level ! splittings from a Born graph. The Sudakov factor is not included, nor ! are 1/qbarsq/(2 pi) and 1/(alpha_s/2/pi). ! ! 20 October 2002 ! 22 March 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl) :: integral,h,n,pg,pq,truecalp ! IF (type0.EQ.'gluon') THEN integral = nc*(1.0d0 + qbarsq/calqsq)*log(1.0d0 + calqsq/qbarsq) + 0.5d0*nf IF (type1.EQ.'gluon') THEN h = nc*(1.0d0 + qbarsq/calqsq)/(2.0d0*min(x,1.0d0-x) + qbarsq/calqsq) n = 1.0d0 ELSE IF (type1.EQ.'quark') THEN h = 0.5d0 n = nf ELSE write(nout,*)'Unknown type1 in splitdensity0.' stop END IF pg = truecalp(rts0,calqsq,type0,softinfo,qbarsq) splitdensity0 = n*h*pg/integral ELSE IF ((type0.EQ.'quark').OR.(type0.EQ.'qbar ')) THEN integral = cf*log(1.0d0 + calqsq/qbarsq) h = cf/(x + qbarsq/calqsq) pq = truecalp(rts0,calqsq,type0,softinfo,qbarsq) splitdensity0 = h*pq/integral ELSE write(nout,*)'Unknown type0 in splitdensity0.' stop END IF ! END function splitdensity0 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine makeshowerII(theshower) ! use beowulf_parameters use beowulf_structures implicit none ! In and Out: type(showerlist) :: theshower ! ! This subroutine creates a shower starting from three or more partons, ! whose parton information is initially found in 'theshower'. The splitting ! uses the function splitII, which is based on small angle approximations. ! 10 November 2002 ! 22 April 2003 ! 9 November 2003 ! integer :: n,currentN,currentNS,nmax logical showermore type(parton) :: mother,daughter1,daughter2 ! DO ! showermore = .false. ! We will exit unless showermore -> .true. nmax = theshower%length DO n = 1,nmax IF ((theshower%ptn(n)%childless).and.& (.not.theshower%ptn(n)%done)) THEN mother = theshower%ptn(n) currentN = theshower%length currentNS = theshower%nstrings call splitII(currentN,currentNS,theshower%rts0,mother,daughter1,daughter2) theshower%ptn(n) = mother !mother has been modified IF (.not.mother%done) THEN theshower%ptn(currentN + 1) = daughter1 theshower%ptn(currentN + 2) = daughter2 theshower%length = currentN + 2 ! Two partons were added theshower%nstrings = currentNS ! A string may have been added. showermore = .true. END IF END IF END DO IF (.not.showermore) EXIT ! END DO ! END subroutine makeshowerII ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine splitII(currentN,currentNS,rts0,mother,daughter1,daughter2) ! use beowulf_parameters use beowulf_structures implicit none ! In: real(kind=dbl) :: rts0 integer :: currentN ! In and Out: type(parton) :: mother integer :: currentNS ! Out: type(parton) :: daughter1, daughter2 ! ! This subroutine 'splits' a mother parton into two daughters ! using probability distributions based on small angle approximations. ! That is, given the information stored in 'mother', it creates ! information for 'daughter1' and 'daughter2' according to ! these probability distributions. ! ! 28 October 2002 ! 1 May 2003 ! 6 December 2003 ! ! Physics data: real(kind=dbl) :: alphasofmz,sinsqthetaw,mz,widthz,externalrts common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! ! Color factors: real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! When to stop: real(kind=dbl) :: showerendratio common /showerend/ showerendratio ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! ! For diagnosis: logical :: showercheck common /showercheckinfo/ showercheck integer :: count integer, save :: showernumber = 0 real(kind=dbl), save :: sum = 0.0d0 ! integer :: mu real(kind=dbl) :: qbarsq,x,phi character(len=5) :: type0,type1,type2 ! parton types for mother and daughters integer :: flavorindex real(kind=dbl) :: random,r,fraction real(kind=dbl) :: calqsq,calq,kappasq real(kind=dbl), dimension(3) :: nx,ny,nz,ell real(kind=dbl) :: lt,lq,cosphi,sinphi,calQ1,calQ2 real(kind=dbl) :: approxcval,approxc,truecval,truec real(kind=dbl) :: pbarsqinv real(kind=dbl) :: nfmax ! ! Check whether we have filled up the parton space. ! IF (currentN.GT.(maxparticles-2)) THEN mother%done = .true. RETURN END IF ! ! Start by supplying straightforward information. ! daughter1%self = currentN + 1 daughter2%self = currentN + 2 daughter1%parent = mother%self daughter2%parent = mother%self daughter1%ancestor = mother%ancestor daughter2%ancestor = mother%ancestor daughter1%child1 = -1 daughter2%child1 = -1 daughter1%child2 = -1 daughter2%child2 = -1 daughter1%childless = .true. daughter2%childless = .true. daughter1%done = .false. daughter2%done = .false. ! ! The momentum scale is provided by {\cal Q}, the absolute value of the ! mother parton's momentum. ! calqsq = 0.0d0 DO mu = 1,3 calqsq = calqsq + mother%momentum(mu)**2 END DO calq = sqrt(calqsq) !------------------------------------ ! ! Now, we generate {qbarsq,x,phi,type1,type2}. The subroutine ! getsplitvars generates {qbarsq,x,phi,type1,type2} according to the ! distribution \tilde c. We keep the selected pointwith probability ! with probability c/(\tilde c). ! type0 = mother%type kappasq = mother%kappasq pbarsqinv = 4.0d0/kappasq count = 1 DO call getsplitvars(rts0,kappasq,pbarsqinv,type0, & qbarsq,x,phi,type1,type2) IF (qbarsq.LT.showerendratio*rts0**2) THEN ! Cancel splitting. mother%done = .true. RETURN END IF approxcval = & approxc(rts0,kappasq,type0,qbarsq,x,phi,type1,type2) truecval = truec(rts0,kappasq,type0,qbarsq,x,phi,type1,type2) fraction = truecval/approxcval IF (fraction.GT.1.0d0) THEN write(nout,*)'Oops, c was supposed to be smaller than \tilde c.' STOP END IF r = random(1) IF (fraction .GT. r) EXIT pbarsqinv = 1/qbarsq count = count + 1 IF (count.GT.1000000) THEN write(nout,*)'Subroutine splitII running too long.' STOP END IF END DO ! ! We have a splitting. Record new information for mother. ! mother%child1 = daughter1%self mother%child2 = daughter2%self mother%childless = .false. !------------------------------------ ! We use {qbarsq, x, phi} to generate the daughter momenta and ! the value of kappasq to be used later for splitting the daughters. ! ! First we calculate the unit vectors n_x, n_y, n_z used to define ! the orientation of the elliptical coordinate system. ! DO mu = 1,3 nz(mu) = mother%momentum(mu)/calq END DO call axes(nz,ny,nx) ! ! Now we find l(mu). ! lt = sqrt(x*(1.0d0 - x)*qbarsq) lq = 0.5d0*calq*sqrt(1.0d0 + qbarsq/calqsq)*(2.0d0*x - 1.0d0) cosphi = cos(phi) sinphi = sin(phi) DO mu = 1,3 ell(mu) = lt*cosphi*nx(mu) + lt*sinphi*ny(mu) + lq*nz(mu) END DO ! ! This gives the daughter type, momenta and kappasq values. ! DO mu = 1,3 daughter1%momentum(mu) = 0.5d0*mother%momentum(mu) + ell(mu) daughter2%momentum(mu) = 0.5d0*mother%momentum(mu) - ell(mu) END DO calQ1 = sqrt((0.5d0*calQ + lq)**2 + lt**2) calQ2 = sqrt((0.5d0*calQ - lq)**2 + lt**2) daughter1%kappasq = min(x*qbarsq/(1.0d0 - x),calQ1**2,mother%kappasq) daughter2%kappasq = min((1.0d0 - x)*qbarsq/x,calQ2**2,mother%kappasq) ! IF (type0.EQ.'gluon') THEN IF ((type1.EQ.'gluon').AND.(type2.EQ.'gluon')) THEN daughter1%type = 'gluon' daughter2%type = 'gluon' daughter1%flavor = 0 daughter2%flavor = 0 daughter1%stringquark = mother%stringquark daughter1%stringqbar = currentNS + 1 daughter2%stringquark = currentNS + 1 daughter2%stringqbar = mother%stringqbar currentNS = currentNS + 1 ! We have added a string ELSE IF ((type1.EQ.'quark').AND.(type2.EQ.'qbar ')) THEN daughter1%type = 'quark' daughter2%type = 'qbar ' ! Find flavors available for splitting, in a crude approximation. ! g --> t, tbar is never allowed. The perturbative splitting probabilities ! have nf *massless* quarks, but for small qbarsq it isn't nice to actually ! try to put a heavy quark in the final state. IF (qbarsq.GT.200.0d0) THEN ! 2 * (2*5 GeV)^2 nfmax = 5.0d0 ! u,d,s,c,b ELSE IF (qbarsq.GT.18.0d0) THEN ! 2 * (2*1.5 GeV)^2 nfmax = 4.0d0 ! u,d,s,c ELSE IF (qbarsq.GT.2.0d0) THEN ! 2 * (2*0.5)^2 nfmax = 3.0d0 ! u,d,s ELSE nfmax = 2.0d0 ! u,d END IF nfmax = min(nf,nfmax) ! Heaviest quark available for splitting. flavorindex = ceiling(random(1)*nfmax) ! choose the flavor at random daughter1%flavor = flavorindex daughter2%flavor = - flavorindex daughter1%stringquark = mother%stringquark daughter1%stringqbar = 0 ! only one string for quarks daughter2%stringquark = 0 ! only one string for qbars daughter2%stringqbar = mother%stringqbar ELSE write(nout,*)'Oops, splitII is confused.' STOP END IF ELSE IF (type0.EQ.'quark') THEN IF ((type1.EQ.'gluon').AND.(type2.EQ.'quark')) THEN daughter1%type = 'gluon' daughter2%type = 'quark' daughter1%flavor = 0 daughter2%flavor = mother%flavor daughter1%stringquark = mother%stringquark daughter1%stringqbar = currentNS + 1 daughter2%stringquark = currentNS + 1 daughter2%stringqbar = 0 ! only one string for quarks currentNS = currentNS + 1 ! We have added a string ELSE write(nout,*)'Oops, splitII is confused.' STOP END IF ELSE IF (type0.EQ.'qbar ') THEN IF ((type1.EQ.'gluon').AND.(type2.EQ.'qbar ')) THEN daughter1%type = 'gluon' daughter2%type = 'qbar ' daughter1%flavor = 0 daughter2%flavor = mother%flavor daughter1%stringquark = currentNS + 1 daughter1%stringqbar = mother%stringqbar daughter2%stringquark = 0 ! only one string for qbars daughter2%stringqbar = currentNS + 1 currentNS = currentNS + 1 ! We have added a string ELSE write(nout,*)'Oops, splitII is confused.' STOP END IF ELSE write(nout,*)'Oops, splitII is confused.' STOP END IF ! (type0.EQ.'gluon') ELSE ... ! !------------------------------------ ! ! Diagnostics ! IF (showercheck) THEN showernumber = showernumber + 1 sum = sum + count IF ( mod(showernumber,10000).EQ.0 ) THEN write(nout,*)'ShowerII average number of tries is', & sum/showernumber END IF END IF ! END subroutine splitII ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine getsplitvars(rts0,kappasq,pbarsqinv,type0, & qbarsq,x,phi,type1,type2) use beowulf_parameters implicit none ! In: real(kind=dbl) :: rts0,kappasq,pbarsqinv character(len=5) :: type0 ! quark, qbar, gluon !Out: real(kind=dbl) :: qbarsq,x,phi character(len=5) :: type1,type2 ! quark, qbar, gluon ! ! Produces {qbarsq,x,phi,type1,type2} distributed according ! to a simple function approxc(qbarsq,x,type1,type2): ! ! density = approxc(qbarsq,x,type1,type2) ! x exp[ - int_qbarsq^infinity d lbarsq int_0^1 dz sum_types ! approxc(lbarsq,z,types) ] ! d qbarsq d x d phi /(2 pi) ! ! This version, getsplitvars, is for the secondary parton splittings ! (not directly from a Born graph) and matches the function approxc. ! 16 September 2002 ! 1 May 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf real(kind=dbl), parameter :: pi = 3.141592653589793239d0 ! real(kind=dbl) :: random,r real(kind=dbl) :: temp,temp1 ! !--- ! IF ((type0.EQ.'quark').OR.(type0.EQ.'qbar ')) THEN type1 = 'gluon' type2 = type0 r = random(1) temp = log(kappasq*pbarsqinv)**2 + (2.0d0*pi/cf)*log(1/r) temp = sqrt(temp) qbarsq = kappasq*exp(-temp) r = random(1) x = (kappasq/qbarsq)**(r-1) r = random(1) phi = (2.0d0*r - 1.0d0)*pi ! ELSE IF (type0 == 'gluon') THEN ! r = random(1) temp1 = 2.0d0*nf/9.0d0/nc temp = log(0.5d0*kappasq*pbarsqinv + temp1)**2 & + (16.0d0*pi/9.0d0/nc)*log(1/r) temp = sqrt(temp) - temp1 qbarsq =0.5d0*kappasq*exp(-temp) ! r = random(1) IF (r < 1.0d0/(1.0d0 + temp/temp1)) THEN type1 = 'quark' type2 = 'qbar ' r = random(1) x = r ELSE type1 = 'gluon' type2 = 'gluon' r = random(1) IF (r.LT.0.5d0) THEN x = 0.5d0*exp((2.0d0*r - 1.0d0)*temp) ELSE x = 0.5d0*exp((1.0d0 - 2.0d0*r)*temp) x = 1.0d0 - x END IF IF (qbarsq.GT.min(x,1.0d0-x)*kappasq) THEN write(nout,*)'That is impossible, error in getsplitvars' write(nout,*)x,qbarsq,min(x,1.0d0-x)*kappasq stop END IF END IF ! r = random(1) phi = (2.0d0*r - 1.0d0)*pi END IF ! END subroutine getsplitvars ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function approxc(rts0,kappasq,type0,qbarsq,x,phi,type1,type2) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: rts0,kappasq character(len=5) :: type0 ! quark, qbar, gluon real(kind=dbl) :: qbarsq,x,phi character(len=5) :: type1,type2 ! quark, qbar, gluon ! Out: real(kind=dbl) :: approxc ! ! The function approxc(qbarsq,x,type1,type2) used for approximate splitting: ! ! density = approxc(qbarsq,x,type1,type2) ! x exp[ - int_qbarsq^infinity d lbarsq int_0^1 dz sum_types ! approxc(lbarsq,z,types) ] ! d qbarsq d x d phi /(2 pi) ! ! This version, approxc, is for secondary parton splittings and matches ! getsplitvars. ! 16 September 2002 ! 1 May 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl), parameter :: twopi = 6.28318530717959d0 real(kind=dbl) :: temp ! IF (type0.EQ.'gluon') THEN IF (type1.EQ.'quark') THEN temp = 0.5d0*nf ELSE IF (type1.EQ.'gluon') THEN temp = (9.0d0*nc/8.0d0)/min(x,1.0d0-x) ELSE write(nout,*)'Wrong parton types in approxc.',type0,type1,type2 STOP END IF ELSE IF ((type0.EQ.'quark').OR.(type0.EQ.'qbar ')) THEN temp = 2.0d0*cf/x ELSE write(nout,*)'Wrong parton types in approxc.' STOP END IF approxc = temp/twopi/qbarsq ! END function approxc ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function truec(rts0,kappasq,type0,qbarsq,x,phi,type1,type2) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: rts0,kappasq character(len=5) :: type0 ! quark, qbar, gluon real(kind=dbl) :: qbarsq,x,phi character(len=5) :: type1,type2 ! quark, qbar, gluon ! Out: real(kind=dbl) :: truec ! ! The function truec(qbarsq,x,type1,type2) to be produced by the splitting ! routine: ! ! density = truec(qbarsq,x,type1,type2) ! x exp[ - int_qbarsq^infinity d lbarsq int_0^1 dz sum_types ! truec(lbarsq,z,types) ] ! d qbarsq d x d phi /(2 pi) ! ! This version, truec rather thant truec0, is for the *other than* the first ! parton splitting from a Born graph. ! ! 31 August 2002 ! 1 May 2003 ! real(kind=dbl), parameter :: pi = 3.141592653589793239d0 real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! Physics data: real(kind=dbl) :: alphasofmz,sinsqthetaw,mz,widthz,externalrts common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! real(kind=dbl) x1mx,altarelli,externalmumsbar,alpi ! x1mx = x*(1.0d0 - x) IF (qbarsq .GT. x1mx*kappasq) THEN truec = 0.0d0 RETURN END IF ! ! We need the effective Altarelli-Parisi splitting functions ! times appropriate counting factors. ! IF (type0.EQ.'gluon') THEN IF ((type1.EQ.'gluon').AND.(type2.EQ.'gluon')) THEN altarelli = nc * (1.0d0 - x1mx)**2 /x1mx ! half of Pgg ELSE IF ((type1.EQ.'quark').AND.(type2.EQ.'qbar ')) THEN altarelli = nf * 0.5d0 * (1.0d0 - 2.0d0*x1mx) ! Nf times Pqg ELSE write(nout,*)'We should not have generated this parton type combination.' STOP END IF ELSE IF ((type0.EQ.'quark').OR.(type0.EQ.'qbar ')) THEN IF ((type1.EQ.'gluon').AND.(type2.EQ.type0)) THEN altarelli = cf*(1.0d0 + (1.0d0 - x)**2)/x ! Pgq ELSE write(nout,*)'We should not have generated this parton type combination.' STOP END IF ELSE write(nout,*)'We should not have generated this parton type combination.' STOP END IF ! externalmumsbar = sqrt(x1mx*qbarsq) * externalrts/rts0 truec = 0.5d0*alpi(externalmumsbar)/qbarsq*altarelli ! END function truec ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine findkoff(graphnumber,cut,kcut,pii,pjj,koff) ! use beowulf_parameters use beowulf_structures implicit none ! In: integer :: graphnumber type(cutstructure) :: cut real(kind=dbl) :: kcut(size+1,0:3) integer :: pii,pjj ! Out: real(kind=dbl) :: koff(0:3*size-1,0:3) ! ! Calculates momenta koff(p,mu), which is like k(p,mu) except that ! the final state particles are given energies equal to the total energy ! of the shower that originates from that particle and the momentum of ! the soft gluon shower is appropriately routed. This is only for the ! Born graphs. ! ! 2 February 2003 ! integer :: i,mu ! ! The momenta for the propagators that enter the final state are simple. ! DO i = 1,3 DO mu = 0,3 koff(cut%cutindex(i),mu) = cut%cutsign(i)*kcut(i,mu) END DO END DO ! ! For the other two propagators, we use the structure of the graph and ! our information on where the soft gluon attached. Since the graphs are ! so simple, we just do it by hand. ! IF (graphnumber.EQ.11) THEN IF (cut%cutindex(pii).EQ.1) THEN DO mu = 0,3 koff(2,mu) = koff(4,mu) + koff(5,mu) koff(0,mu) = koff(1,mu) + koff(2,mu) + kcut(4,mu) END DO ELSE DO mu = 0,3 koff(2,mu) = koff(4,mu) + koff(5,mu) + kcut(4,mu) koff(0,mu) = koff(1,mu) + koff(2,mu) END DO END IF IF (cut%cutindex(pjj).EQ.1) THEN DO mu = 0,3 koff(3,mu) = -koff(4,mu) - koff(5,mu) END DO ELSE DO mu = 0,3 koff(3,mu) = -koff(4,mu) - koff(5,mu) - kcut(4,mu) END DO END IF ELSE IF (graphnumber.EQ.12) THEN IF (cut%cutindex(3).EQ.1) THEN IF (cut%cutindex(pii).EQ.1) THEN DO mu = 0,3 koff(2,mu) = - koff(4,mu) - koff(5,mu) koff(0,mu) = koff(1,mu) + koff(2,mu) + kcut(4,mu) END DO ELSE DO mu = 0,3 koff(2,mu) = - koff(4,mu) - koff(5,mu) + kcut(4,mu) koff(0,mu) = koff(1,mu) + koff(2,mu) END DO END IF IF (cut%cutindex(pjj).EQ.4) THEN DO mu = 0,3 koff(3,mu) = - koff(1,mu) + koff(5,mu) END DO ELSE DO mu = 0,3 koff(3,mu) = - koff(1,mu) + koff(5,mu) - kcut(4,mu) END DO END IF ELSE IF (cut%cutindex(3).EQ.2) THEN IF (cut%cutindex(pii).EQ.2) THEN DO mu = 0,3 koff(1,mu) = - koff(3,mu) + koff(5,mu) koff(0,mu) = koff(1,mu) + koff(2,mu) + kcut(4,mu) END DO ELSE DO mu = 0,3 koff(1,mu) = - koff(3,mu) + koff(5,mu) + kcut(4,mu) koff(0,mu) = koff(1,mu) + koff(2,mu) END DO END IF IF (cut%cutindex(pjj).EQ.3) THEN DO mu = 0,3 koff(4,mu) = - koff(2,mu) - koff(5,mu) END DO ELSE DO mu = 0,3 koff(4,mu) = - koff(2,mu) - koff(5,mu) - kcut(4,mu) END DO END IF ELSE write(nout,*)'Cut propagator 3 for graph 12 should be 1 or 2.' stop END IF ELSE write(nout,*)'We should have been working on graph number 11 or 12.' stop END IF ! end subroutine findkoff ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine showerglueprop(kind2pt,softinfo,q,kplus,kminus,out) ! use beowulf_parameters use beowulf_structures implicit none ! In: character(len=9) :: kind2pt type(softinformation) :: softinfo real(kind=dbl) :: q(1:3),kplus(1:3),kminus(1:3) ! Out: real(kind=dbl) :: out(0:3,0:3) ! ! Calculates the one loop cut gluon two-point function. ! ! kind2pt: ! GLUONLOOP gluon self-energy with a gluon (including ghost) loop ! QUARKLOOP gluon self-energy with a quark loop ! ! q(mu): incoming momentum (q = kplus + kminus) ! kplus(mu): 1st momentum in loop ! kminus(mu): 2nd momentum in loop ! ! The result is the two point function out(mu,nu) with a certain ! normalization. Specifically, for the cut gluon self-energy ! graph, out(mu,nu) is {\cal M}_{g -> g g}^{\mu\nu} divided by ! (\alpha_s/(2\pi)) or else out(mu,nu) is {\cal M}_{g -> q barq}^{\mu\nu} ! divided by (\alpha_s/(2\pi)), depending on the value of kind2pt. ! ! We also include the soft gluon subtraction in the case of g -> g g. ! ! 20 October 2002 ! 15 June 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf real(kind=dbl) :: showercut common /showercutinfo/ showercut ! real(kind=dbl), parameter :: esq = 7.38905609893065d0 real(kind=dbl), parameter :: e5thirds = 5.29449005047003d0 real(kind=dbl), parameter :: e8thirds = 14.3919160951499d0 ! integer :: mu,nu real(kind=dbl) :: calqsq,omegaplussq,omegaminussq real(kind=dbl) :: calq,omegaplus,omegaminus,q0 real(kind=dbl) :: deltap1,delta,twoxm1,x1mx,qbarsq real(kind=dbl), dimension(3) :: ell,ellt real(kind=dbl) :: elltsq,denom,onem2x1mx,onem4x1mx real(kind=dbl) :: temp real(kind=dbl), dimension(0:3,0:3) :: bareprop real(kind=dbl) :: ntt,nll,nee,nel real(kind=dbl) :: prefactor real(kind=dbl) :: termtt,termll real(kind=dbl) :: cosqkplus,cosqkminus,psoft ! ! Some auxilliary variables, include ! CALQ = {\cal Q} ! OMEGAPLUS = \omega_+ ! OMEGAMINUS = \omega_- ! DELTAP1 = \Delta + 1 ! TWOXM1 = 2 x - 1 ! X1MX = x (1-x) ! ELLT(mu) = l_T^\mu ! ELLTSQ = (\vec l_T)^2 ! Q(mu) = the incoming *three*-momentum ! Q0 = the incoming energy ! calqsq = 0.0d0 omegaplussq = 0.0d0 omegaminussq = 0.0d0 DO mu = 1,3 calqsq = calqsq + q(mu)**2 omegaplussq = omegaplussq + kplus(mu)**2 omegaminussq = omegaminussq + kminus(mu)**2 END DO calq = sqrt(calqsq) omegaplus = sqrt(omegaplussq) omegaminus = sqrt(omegaminussq) q0 = omegaplus + omegaminus deltap1 = (omegaplus + omegaminus)/calq delta = deltap1 - 1.0d0 twoxm1 = (omegaplus - omegaminus)/calq x1mx = (1.0d0 - twoxm1**2)/4.0d0 qbarsq = calqsq * delta * (delta + 2.0d0) ! IF ( qbarsq.GT.(showercut*calqsq) ) THEN ! We have a wide angle splitting and we don't count it as a shower. DO mu = 0,3 DO nu = 0,3 out(mu,nu) = 0.0d0 END DO END DO ELSE ! ! Proceed with the calculation. ! DO mu = 1,3 ell(mu) = (kplus(mu) - kminus(mu))/2.0d0 ellt(mu) = ell(mu) - 0.5d0*deltap1*twoxm1*q(mu) END DO elltsq = qbarsq*x1mx denom = qbarsq/calqsq + 4.0d0*x1mx onem2x1mx = 1.0d0 - 2.0d0*x1mx onem4x1mx = 1.0d0 - 4.0d0*x1mx ! ! The gluon propagator in Coulomb gauge for an on-shell gluon ! with three-momentum q(mu). This is the space components only. ! DO mu = 1,3 bareprop(mu,mu) = 1.0d0 - q(mu)**2/calqsq DO nu = mu+1,3 temp = - q(mu)*q(nu)/calqsq bareprop(mu,nu) = temp bareprop(nu,mu) = temp END DO END DO ! ! We compute the coefficients for, alternatively, the gluon loop ! or the quark loop. We use the name NLL for Ntt and NEL for NEt. ! IF (kind2pt.EQ.'gluonloop') THEN ! ntt = x1mx ntt = ntt + 8.0d0*x1mx*(1.0d0 - x1mx)/denom ntt = ntt + 16.0d0*x1mx*(onem4x1mx + 2.0d0*x1mx**2)/denom**2 ntt = ntt * 2.0d0*nc nll = x1mx nll = nll - 8.0d0*x1mx**2/denom nll = nll + 32.0d0*x1mx**3/denom**2 nll = nll * 4.0d0*nc nee = onem4x1mx nee = nee - 8.0d0*x1mx*onem4x1mx/denom nee = nee + 32.0d0*x1mx**2*onem4x1mx/denom**2 nee = nee * nc nel = -1.0d0 nel = nel - 2.0d0*onem4x1mx/denom nel = nel + 16.0d0*x1mx*onem2x1mx/denom**2 nel = nel * 2.0d0*nc*twoxm1 ! ELSE IF (kind2pt.EQ.'quarkloop') THEN ! ntt = nf*onem2x1mx nll = - nf*4.0d0*x1mx nee = 4.0d0*nf*x1mx nel = 2.0d0*nf*twoxm1 ! ELSE write(nout,*)'Unrecognized type in subroutine showerglueprop.' stop END IF ! ! With the coefficients in hand, we compute the result. ! prefactor = 1.0d0/(2.0d0*deltap1) ! out(0,0) = prefactor*qbarsq/calqsq*nee DO mu = 1,3 temp = prefactor*q0/deltap1/calqsq*nel*ellt(mu) out(0,mu) = temp out(mu,0) = temp END DO DO mu = 1,3 DO nu = 1,3 termtt = ntt*bareprop(mu,nu) termll = nll*(ellt(mu)*ellt(nu)/elltsq - 0.5d0*bareprop(mu,nu)) out(mu,nu) = prefactor*(termtt + termll) END DO END DO ! ! Close IF(qbarsq.GT.calqsq) THEN out(mu,nu) = 0 ELSE calculate it. ! END IF ! ! Do soft subtraction. IF (kind2pt.EQ.'gluonloop') THEN ! ! Soft subtraction, symmetrized between kplus(mu) and kminus(mu). ! IF (omegaplussq.LT.softinfo%msoftsq) THEN ! theta(omega_+^2 < msoft^2) cosqkplus = 0.0d0 DO mu = 1,3 cosqkplus = cosqkplus + q(mu)*kplus(mu)/calq/omegaplus END DO IF ((cosqkplus.LT.softinfo%cos1).OR.(cosqkplus.LT.softinfo%cos2)) THEN psoft = 0.0d0 IF (cosqkplus.LT.softinfo%cos1) THEN psoft = psoft + 0.5d0*nc END IF IF (cosqkplus.LT.softinfo%cos2) THEN psoft = psoft + 0.5d0*nc END IF psoft = psoft*0.5d0*qbarsq/deltap1 psoft = psoft/omegaplussq psoft = psoft*(1.0d0 + cosqkplus)/(1.0d0 - cosqkplus) ! DO mu = 1,3 bareprop(mu,mu) = 1.0d0 - kminus(mu)**2/omegaminussq DO nu = mu+1,3 temp = - kminus(mu)*kminus(nu)/omegaminussq bareprop(mu,nu) = temp bareprop(nu,mu) = temp END DO END DO ! DO mu = 1,3 DO nu = 1,3 out(mu,nu) = out(mu,nu) - 0.5d0*psoft*bareprop(mu,nu) END DO END DO END IF ! (cosqkplus.LT.cos1).OR.(cosqkplus.LT.cos2) END IF ! omegaplussq.LT.softinfo%msoftsq ! ! Now the same with kplus(mu) <-> kminus(mu). ! IF (omegaminussq.LT.softinfo%msoftsq) THEN ! theta(omega_-^2 < msoft^2) cosqkminus = 0.0d0 DO mu = 1,3 cosqkminus = cosqkminus + q(mu)*kminus(mu)/calq/omegaminus END DO IF ((cosqkminus.LT.softinfo%cos1).OR.(cosqkminus.LT.softinfo%cos2)) THEN psoft = 0.0d0 IF (cosqkminus.LT.softinfo%cos1) THEN psoft = psoft + 0.5d0*nc END IF IF (cosqkminus.LT.softinfo%cos2) THEN psoft = psoft + 0.5d0*nc END IF psoft = psoft*0.5d0*qbarsq/deltap1 psoft = psoft/omegaminussq psoft = psoft*(1.0d0 + cosqkminus)/(1.0d0 - cosqkminus) ! DO mu = 1,3 bareprop(mu,mu) = 1.0d0 - kplus(mu)**2/omegaplussq DO nu = mu+1,3 temp = - kplus(mu)*kplus(nu)/omegaplussq bareprop(mu,nu) = temp bareprop(nu,mu) = temp END DO END DO ! DO mu = 1,3 DO nu = 1,3 out(mu,nu) = out(mu,nu) - 0.5d0*psoft*bareprop(mu,nu) END DO END DO END IF ! (cosqkminus.LT.cos1).OR.(cosqkminus.LT.cos2) END IF ! omegaminussq.LT.softinfo%msoftsq ! END IF ! kind2pt.EQ.'gluonloop' ! Done with soft subtraction ! END subroutine showerglueprop ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine showerquarkprop(softinfo,q,kplus,kminus,out) ! use beowulf_parameters use beowulf_structures implicit none ! In: type(softinformation) :: softinfo real(kind=dbl) :: q(1:3),kplus(1:3),kminus(1:3) ! Out: real(kind=dbl) :: out(0:3) ! ! Calculates the one loop cut quark two-point function. ! ! q(mu): incoming momentum (q = kplus + kminus) ! kplus(mu): 1st momentum in loop ! kminus(mu): 2nd momentum in loop ! ! The quark cut two point function, with a certain normalization, ! is represented as out^mu gamma_mu. Specifically, for the cut quark ! self-energy graph, out^mu gamma_mu is {\cal M}_{q -> g q} divided by ! (\alpha_s/(2\pi)). ! ! 20 October 2002 ! 15 June 2003 ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf real(kind=dbl) :: showercut common /showercutinfo/ showercut ! real(kind=dbl) :: ecube = 20.0855369231877d0 real(kind=dbl) :: e5thirds = 5.29449005047003d0 ! integer :: mu real(kind=dbl) :: calqsq,omegaplussq,omegaminussq real(kind=dbl) :: calq,omegaplus,omegaminus,q0 real(kind=dbl) :: deltap1,delta,twoxm1,x1mx,x,qbarsq real(kind=dbl), dimension(3) :: ellt real(kind=dbl) :: elltsq,denom,onem2x1mx,onem4x1mx real(kind=dbl) :: temp,tempsq,nl,ne,nt real(kind=dbl) :: prefactor real(kind=dbl) :: cosqkplus,psoft ! ! Auxilliary variables include ! calq = {\cal Q} ! omegaplus = \omega_+ ! omegaminus = \omega_- ! deltap1 = \Delta + 1 ! twoxm1 = 2 x - 1 ! x1mx = x (1-x) ! ellt(mu) = l_T^\mu ! elltsq = (\vec l_T)^2 ! q(mu) = the incoming *three*-momentum ! q0 = the incoming energy ! calqsq = 0.0d0 omegaplussq = 0.0d0 omegaminussq = 0.0d0 DO mu = 1,3 calqsq = calqsq + q(mu)**2 omegaplussq = omegaplussq + kplus(mu)**2 omegaminussq = omegaminussq + kminus(mu)**2 END DO calq = sqrt(calqsq) omegaplus = sqrt(omegaplussq) omegaminus = sqrt(omegaminussq) q0 = omegaplus + omegaminus deltap1 = (omegaplus + omegaminus)/calq delta = deltap1 - 1.0d0 twoxm1 = (omegaplus - omegaminus)/calq x1mx = (1.0d0 - twoxm1**2)/4.0d0 x = 0.5d0*(twoxm1 + 1.0d0) qbarsq = calqsq * delta * (delta + 2.0d0) ! IF ( qbarsq.GT.(showercut*calqsq) ) THEN ! We have a wide angle splitting and we don't count it as a shower. DO mu = 0,3 out(mu) = 0.0d0 END DO ELSE ! ! Proceed with the calculation. ! DO mu = 1,3 ellt(mu) = (kplus(mu) - kminus(mu))/2.0d0 - 0.5d0*deltap1*twoxm1*q(mu) END DO elltsq = qbarsq*x1mx denom = qbarsq/calqsq + 4.0d0*x1mx onem2x1mx = 1.0d0 - 2.0d0*x1mx onem4x1mx = 1.0d0 - 4.0d0*x1mx ! ! Here temp = 2 x + Delta. ! temp = twoxm1 + deltap1 tempsq = temp**2 nl = 12.0d0*x1mx + twoxm1*temp nl = nl - 16.0d0*x1mx*twoxm1/temp + 16.0d0*x1mx*onem2x1mx/tempsq nl = nl * cf ne = 2.0d0*cf*(1.0d0 - x)*(4.0d0*x**2 + delta**2)/tempsq nt = 1.0d0 - 2.0d0*twoxm1/temp - 8.0d0*x1mx/tempsq nt = 2.0d0*cf*nt ! ! Now we costruct out(mu), ! prefactor = 1.0d0/(2.0d0*deltap1) out(0) = prefactor*q0/deltap1*(nl + delta*ne) DO mu = 1,3 out(mu) = prefactor*(nl*q(mu) + nt*ellt(mu)) END DO ! ! Close IF(qbarsq.GT.calqsq) THEN out(mu) = 0 ELSE calculate it. ! END IF ! ! Do soft subtraction. IF (omegaplussq.LT.softinfo%msoftsq) THEN ! theta(omega_+^2 < msoft^2) cosqkplus = 0.0d0 DO mu = 1,3 cosqkplus = cosqkplus + q(mu)*kplus(mu)/calq/omegaplus END DO IF ((cosqkplus.LT.softinfo%cos1).OR.(cosqkplus.LT.softinfo%cos2)) THEN psoft = 0.0d0 IF (cosqkplus.LT.softinfo%cos1) THEN IF (softinfo%type1.EQ.'gluon') THEN psoft = psoft + 0.5d0*nc ELSE psoft = psoft - 0.5d0/nc END IF END IF IF (cosqkplus.LT.softinfo%cos2) THEN IF (softinfo%type1.EQ.'gluon') THEN psoft = psoft + 0.5d0*nc ELSE psoft = psoft - 0.5d0/nc END IF END IF psoft = psoft*0.5d0*qbarsq/deltap1 psoft = psoft/omegaplussq psoft = psoft*(1.0d0 + cosqkplus)/(1.0d0 - cosqkplus) out(0) = out(0) - psoft*omegaminus DO mu = 1,3 out(mu) = out(mu) - psoft*kminus(mu) END DO END IF ! (cosqkplus.LT.softinfo%cos1).OR.(cosqkplus.LT.softinfo%cos2) END IF ! omegaplussq.LT.softinfo%msoftsq ! Done with soft subtraction ! END subroutine showerquarkprop ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Feynman integrand in Coulomb gauge, BORN LEVEL ! with final state propagators replaced by shower functions ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function feynmanSH0(graphnumber,flavorsetnumber,kin,cut, & vquark,vqbar,tglue) ! use beowulf_parameters implicit none ! In: integer :: graphnumber,flavorsetnumber real(kind=dbl), dimension(0:3*size-1,0:3) :: kin logical, dimension(3*size-1) :: cut real(kind=dbl), dimension(0:3) :: vquark,vqbar real(kind=dbl), dimension(0:3,0:3) :: tglue ! Out: complex(kind=dbl) :: feynmanSH0 ! ! Feynman integrand function for graph GRAPHNUMBER ! with real momenta kin and cut specified by CUT. ! Early version: 17 July 1994. ! This routine for Born graphs with level-1 parton splitting, ! that is SHower-zero. ! This version written by Mathematica code of 2 October 2004 on ! 2 Oct 2004. ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! real(kind=dbl), parameter :: metric(0:3) = (/1.0d0,-1.0d0,-1.0d0,-1.0d0/) real(kind=dbl), parameter :: gn(0:3) = (/1.0d0,0.0d0,0.0d0,0.0d0/) real(kind=dbl), parameter :: gz(0:3) = (/0.0d0,0.0d0,0.0d0,-1.0d0/) ! integer :: mu,nu real(kind=dbl),dimension(256) :: x real(kind=dbl),dimension(0:3) :: k1,k2,k3,k4,k5 real(kind=dbl) :: e1,e2,e3,e4,e5 real(kind=dbl) :: k11,k22,k33,k44,k55 real(kind=dbl) :: tk11,tk22,tk33,tk44,tk55 real(kind=dbl) :: prefactor real(kind=dbl) :: result ! real(kind=dbl) :: gnva1,gnva2,gnva3,gnva4,gnva5,gnvb1,gnvb2,gnvb3,gnvb5 real(kind=dbl) :: gzva1,gzva2,gzva3,gzva4,gzva5,gzvb1,gzvb2,gzvb3,gzvb5 real(kind=dbl) :: tg4wgnva5,tg4wgnvb5,tg4wgzva5,tg4wgzvb5,tg4wva2va5 real(kind=dbl) :: tg4wva3vb5,tg4wva5vb3,tg4wvb2vb5,tg5wgngn,tg5wgnva1 real(kind=dbl) :: tg5wgnva4,tg5wgnvb2,tg5wgnvb3,tg5wgzgz,tg5wgzva1 real(kind=dbl) :: tg5wgzva4,tg5wgzvb2,tg5wgzvb3,tg5wva1va4,tg5wva1vb2 real(kind=dbl) :: tg5wva4vb3,tg5wvb2vb3,tracetg4,tracetg5,va1va4,va1vb2 real(kind=dbl) :: va1vb3,va2va5,va2vb3,va3vb2,va3vb5,va4vb2,va4vb3 real(kind=dbl) :: va5vb3,vb2vb3,vb2vb5,va1(0:3),va2(0:3),va3(0:3) real(kind=dbl) :: va4(0:3),va5(0:3),vb1(0:3),vb2(0:3),vb3(0:3),vb5(0:3) real(kind=dbl) :: tg4(0:3,0:3),tg5(0:3,0:3) ! DO mu = 0,3 k1(mu) = kin(1,mu) k2(mu) = kin(2,mu) k3(mu) = kin(3,mu) k4(mu) = kin(4,mu) k5(mu) = kin(5,mu) END DO result = 0.0d0 ! !------ ! IF (graphnumber .EQ. 11) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,quark,gluon,qbar} ! IF (cut(1)) THEN DO mu = 0,3 va1(mu) = vquark(mu) END DO ELSE write(nout,*)'Oops, this line should have been cut' STOP END IF IF (cut(2)) THEN write(nout,*) 'This propagator should not be cut' STOP ELSE DO mu = 0,3 vb2(mu) = -kin(2,mu) END DO END IF IF (cut(3)) THEN write(nout,*) 'This propagator should not be cut' STOP ELSE DO mu = 0,3 va3(mu) = kin(3,mu) END DO END IF IF (cut(4)) THEN DO mu = 0,3 DO nu = 0,3 tg4(mu,nu) = tglue(mu,nu) END DO END DO ELSE write(nout,*)'Oops, this line should have been cut' STOP END IF IF (cut(5)) THEN DO mu = 0,3 vb5(mu) = vqbar(mu) END DO ELSE write(nout,*)'Oops, this line should have been cut' STOP END IF prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 e5 = k5(0) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/sqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/sqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/sqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/sqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/sqrt(-tk55) ELSE prefactor = prefactor/k55 END IF tracetg4 = 0.0d0 DO mu = 0,3 tracetg4 = tracetg4 + tg4(mu,mu)*metric(mu) END DO tg4wgnvb5 = 0.0d0 tg4wgzvb5 = 0.0d0 tg4wva3vb5 = 0.0d0 tg4wvb2vb5 = 0.0d0 DO mu = 0,3 DO nu = 0,3 tg4wgnvb5 = tg4wgnvb5 & + tg4(mu,nu)*gn(mu)*vb5(nu)*metric(mu)*metric(nu) tg4wgzvb5 = tg4wgzvb5 & + tg4(mu,nu)*gz(mu)*vb5(nu)*metric(mu)*metric(nu) tg4wva3vb5 = tg4wva3vb5 & + tg4(mu,nu)*va3(mu)*vb5(nu)*metric(mu)*metric(nu) tg4wvb2vb5 = tg4wvb2vb5 & + tg4(mu,nu)*vb2(mu)*vb5(nu)*metric(mu)*metric(nu) END DO END DO gnva1 = 0.0d0 gnva3 = 0.0d0 gnvb2 = 0.0d0 gnvb5 = 0.0d0 gzva1 = 0.0d0 gzva3 = 0.0d0 gzvb2 = 0.0d0 gzvb5 = 0.0d0 va3vb2 = 0.0d0 va3vb5 = 0.0d0 vb2vb5 = 0.0d0 DO mu = 0,3 gnva1 = gnva1 + gn(mu)*va1(mu)*metric(mu) gnva3 = gnva3 + gn(mu)*va3(mu)*metric(mu) gnvb2 = gnvb2 + gn(mu)*vb2(mu)*metric(mu) gnvb5 = gnvb5 + gn(mu)*vb5(mu)*metric(mu) gzva1 = gzva1 + gz(mu)*va1(mu)*metric(mu) gzva3 = gzva3 + gz(mu)*va3(mu)*metric(mu) gzvb2 = gzvb2 + gz(mu)*vb2(mu)*metric(mu) gzvb5 = gzvb5 + gz(mu)*vb5(mu)*metric(mu) va3vb2 = va3vb2 + va3(mu)*vb2(mu)*metric(mu) va3vb5 = va3vb5 + va3(mu)*vb5(mu)*metric(mu) vb2vb5 = vb2vb5 + vb2(mu)*vb5(mu)*metric(mu) END DO x(1) = gnva1*(2*gnvb2*tg4wva3vb5 + 2*gnva3*tg4wvb2vb5 & - 2*tg4wgnvb5*va3vb2) + gzva1*(-2*gzvb2*tg4wva3vb5 & - 2*gzva3*tg4wvb2vb5 + 2*tg4wgzvb5*va3vb2) x(2) = gnva1*(gnvb5*va3vb2 - gnvb2*va3vb5 - gnva3*vb2vb5) + gzva1 & *(-(gzvb5*va3vb2) + gzvb2*va3vb5 + gzva3*vb2vb5) x(3) = x(1) + tracetg4*x(2) result = -12*cf*nc*x(3) result = result*prefactor ! ELSE IF (flavorsetnumber .EQ. 2) THEN ! types = {qbar,quark,qbar,gluon,quark} ! IF (cut(1)) THEN DO mu = 0,3 vb1(mu) = vqbar(mu) END DO ELSE write(nout,*)'Oops, this line should have been cut' STOP END IF IF (cut(2)) THEN write(nout,*) 'This propagator should not be cut' STOP ELSE DO mu = 0,3 va2(mu) = kin(2,mu) END DO END IF IF (cut(3)) THEN write(nout,*) 'This propagator should not be cut' STOP ELSE DO mu = 0,3 vb3(mu) = -kin(3,mu) END DO END IF IF (cut(4)) THEN DO mu = 0,3 DO nu = 0,3 tg4(mu,nu) = tglue(mu,nu) END DO END DO ELSE write(nout,*)'Oops, this line should have been cut' STOP END IF IF (cut(5)) THEN DO mu = 0,3 va5(mu) = vquark(mu) END DO ELSE write(nout,*)'Oops, this line should have been cut' STOP END IF prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 e5 = k5(0) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/sqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/sqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/sqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/sqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/sqrt(-tk55) ELSE prefactor = prefactor/k55 END IF tracetg4 = 0.0d0 DO mu = 0,3 tracetg4 = tracetg4 + tg4(mu,mu)*metric(mu) END DO tg4wgnva5 = 0.0d0 tg4wgzva5 = 0.0d0 tg4wva2va5 = 0.0d0 tg4wva5vb3 = 0.0d0 DO mu = 0,3 DO nu = 0,3 tg4wgnva5 = tg4wgnva5 & + tg4(mu,nu)*gn(mu)*va5(nu)*metric(mu)*metric(nu) tg4wgzva5 = tg4wgzva5 & + tg4(mu,nu)*gz(mu)*va5(nu)*metric(mu)*metric(nu) tg4wva2va5 = tg4wva2va5 & + tg4(mu,nu)*va2(mu)*va5(nu)*metric(mu)*metric(nu) tg4wva5vb3 = tg4wva5vb3 & + tg4(mu,nu)*va5(mu)*vb3(nu)*metric(mu)*metric(nu) END DO END DO gnva2 = 0.0d0 gnva5 = 0.0d0 gnvb1 = 0.0d0 gnvb3 = 0.0d0 gzva2 = 0.0d0 gzva5 = 0.0d0 gzvb1 = 0.0d0 gzvb3 = 0.0d0 va2va5 = 0.0d0 va2vb3 = 0.0d0 va5vb3 = 0.0d0 DO mu = 0,3 gnva2 = gnva2 + gn(mu)*va2(mu)*metric(mu) gnva5 = gnva5 + gn(mu)*va5(mu)*metric(mu) gnvb1 = gnvb1 + gn(mu)*vb1(mu)*metric(mu) gnvb3 = gnvb3 + gn(mu)*vb3(mu)*metric(mu) gzva2 = gzva2 + gz(mu)*va2(mu)*metric(mu) gzva5 = gzva5 + gz(mu)*va5(mu)*metric(mu) gzvb1 = gzvb1 + gz(mu)*vb1(mu)*metric(mu) gzvb3 = gzvb3 + gz(mu)*vb3(mu)*metric(mu) va2va5 = va2va5 + va2(mu)*va5(mu)*metric(mu) va2vb3 = va2vb3 + va2(mu)*vb3(mu)*metric(mu) va5vb3 = va5vb3 + va5(mu)*vb3(mu)*metric(mu) END DO x(1) = gnvb1*(2*gnvb3*tg4wva2va5 + 2*gnva2*tg4wva5vb3 & - 2*tg4wgnva5*va2vb3) + gzvb1*(-2*gzvb3*tg4wva2va5 & - 2*gzva2*tg4wva5vb3 + 2*tg4wgzva5*va2vb3) x(2) = gnvb1*(-(gnvb3*va2va5) + gnva5*va2vb3 - gnva2*va5vb3) & + gzvb1*(gzvb3*va2va5 - gzva5*va2vb3 + gzva2*va5vb3) x(3) = x(1) + tracetg4*x(2) result = -12*cf*nc*x(3) result = result*prefactor ! ! (End flavorset query.) ! END IF !------ ! ELSE IF (graphnumber .EQ. 12) THEN ! IF (flavorsetnumber .EQ. 1) THEN ! types = {quark,qbar,qbar,quark,gluon} ! IF (cut(1)) THEN DO mu = 0,3 va1(mu) = vquark(mu) END DO ELSE DO mu = 0,3 va1(mu) = kin(1,mu) END DO END IF IF (cut(2)) THEN DO mu = 0,3 vb2(mu) = vqbar(mu) END DO ELSE DO mu = 0,3 vb2(mu) = -kin(2,mu) END DO END IF IF (cut(3)) THEN DO mu = 0,3 vb3(mu) = vquark(mu) END DO ELSE DO mu = 0,3 vb3(mu) = -kin(3,mu) END DO END IF IF (cut(4)) THEN DO mu = 0,3 va4(mu) = vqbar(mu) END DO ELSE DO mu = 0,3 va4(mu) = kin(4,mu) END DO END IF IF (cut(5)) THEN DO mu = 0,3 DO nu = 0,3 tg5(mu,nu) = tglue(mu,nu) END DO END DO ELSE write(nout,*)'Oops, this line should have been cut' STOP END IF prefactor = 1.0d0 e1 = k1(0) tk11 = 0.0d0 e2 = k2(0) tk22 = 0.0d0 e3 = k3(0) tk33 = 0.0d0 e4 = k4(0) tk44 = 0.0d0 e5 = k5(0) tk55 = 0.0d0 DO mu = 1,3 tk11 = tk11 - k1(mu)**2 tk22 = tk22 - k2(mu)**2 tk33 = tk33 - k3(mu)**2 tk44 = tk44 - k4(mu)**2 tk55 = tk55 - k5(mu)**2 END DO k11 = e1**2 + tk11 k22 = e2**2 + tk22 k33 = e3**2 + tk33 k44 = e4**2 + tk44 k55 = e5**2 + tk55 IF (cut(1)) THEN prefactor = prefactor/2.0d0/sqrt(-tk11) ELSE prefactor = prefactor/k11 END IF IF (cut(2)) THEN prefactor = prefactor/2.0d0/sqrt(-tk22) ELSE prefactor = prefactor/k22 END IF IF (cut(3)) THEN prefactor = prefactor/2.0d0/sqrt(-tk33) ELSE prefactor = prefactor/k33 END IF IF (cut(4)) THEN prefactor = prefactor/2.0d0/sqrt(-tk44) ELSE prefactor = prefactor/k44 END IF IF (cut(5)) THEN prefactor = prefactor/2.0d0/sqrt(-tk55) ELSE prefactor = prefactor/k55 END IF tracetg5 = 0.0d0 DO mu = 0,3 tracetg5 = tracetg5 + tg5(mu,mu)*metric(mu) END DO tg5wgngn = 0.0d0 tg5wgnva1 = 0.0d0 tg5wgnva4 = 0.0d0 tg5wgnvb2 = 0.0d0 tg5wgnvb3 = 0.0d0 tg5wgzgz = 0.0d0 tg5wgzva1 = 0.0d0 tg5wgzva4 = 0.0d0 tg5wgzvb2 = 0.0d0 tg5wgzvb3 = 0.0d0 tg5wva1va4 = 0.0d0 tg5wva1vb2 = 0.0d0 tg5wva4vb3 = 0.0d0 tg5wvb2vb3 = 0.0d0 DO mu = 0,3 DO nu = 0,3 tg5wgngn = tg5wgngn & + tg5(mu,nu)*gn(mu)*gn(nu)*metric(mu)*metric(nu) tg5wgnva1 = tg5wgnva1 & + tg5(mu,nu)*gn(mu)*va1(nu)*metric(mu)*metric(nu) tg5wgnva4 = tg5wgnva4 & + tg5(mu,nu)*gn(mu)*va4(nu)*metric(mu)*metric(nu) tg5wgnvb2 = tg5wgnvb2 & + tg5(mu,nu)*gn(mu)*vb2(nu)*metric(mu)*metric(nu) tg5wgnvb3 = tg5wgnvb3 & + tg5(mu,nu)*gn(mu)*vb3(nu)*metric(mu)*metric(nu) tg5wgzgz = tg5wgzgz & + tg5(mu,nu)*gz(mu)*gz(nu)*metric(mu)*metric(nu) tg5wgzva1 = tg5wgzva1 & + tg5(mu,nu)*gz(mu)*va1(nu)*metric(mu)*metric(nu) tg5wgzva4 = tg5wgzva4 & + tg5(mu,nu)*gz(mu)*va4(nu)*metric(mu)*metric(nu) tg5wgzvb2 = tg5wgzvb2 & + tg5(mu,nu)*gz(mu)*vb2(nu)*metric(mu)*metric(nu) tg5wgzvb3 = tg5wgzvb3 & + tg5(mu,nu)*gz(mu)*vb3(nu)*metric(mu)*metric(nu) tg5wva1va4 = tg5wva1va4 & + tg5(mu,nu)*va1(mu)*va4(nu)*metric(mu)*metric(nu) tg5wva1vb2 = tg5wva1vb2 & + tg5(mu,nu)*va1(mu)*vb2(nu)*metric(mu)*metric(nu) tg5wva4vb3 = tg5wva4vb3 & + tg5(mu,nu)*va4(mu)*vb3(nu)*metric(mu)*metric(nu) tg5wvb2vb3 = tg5wvb2vb3 & + tg5(mu,nu)*vb2(mu)*vb3(nu)*metric(mu)*metric(nu) END DO END DO gnva1 = 0.0d0 gnva4 = 0.0d0 gnvb2 = 0.0d0 gnvb3 = 0.0d0 gzva1 = 0.0d0 gzva4 = 0.0d0 gzvb2 = 0.0d0 gzvb3 = 0.0d0 va1va4 = 0.0d0 va1vb2 = 0.0d0 va1vb3 = 0.0d0 va4vb2 = 0.0d0 va4vb3 = 0.0d0 vb2vb3 = 0.0d0 DO mu = 0,3 gnva1 = gnva1 + gn(mu)*va1(mu)*metric(mu) gnva4 = gnva4 + gn(mu)*va4(mu)*metric(mu) gnvb2 = gnvb2 + gn(mu)*vb2(mu)*metric(mu) gnvb3 = gnvb3 + gn(mu)*vb3(mu)*metric(mu) gzva1 = gzva1 + gz(mu)*va1(mu)*metric(mu) gzva4 = gzva4 + gz(mu)*va4(mu)*metric(mu) gzvb2 = gzvb2 + gz(mu)*vb2(mu)*metric(mu) gzvb3 = gzvb3 + gz(mu)*vb3(mu)*metric(mu) va1va4 = va1va4 + va1(mu)*va4(mu)*metric(mu) va1vb2 = va1vb2 + va1(mu)*vb2(mu)*metric(mu) va1vb3 = va1vb3 + va1(mu)*vb3(mu)*metric(mu) va4vb2 = va4vb2 + va4(mu)*vb2(mu)*metric(mu) va4vb3 = va4vb3 + va4(mu)*vb3(mu)*metric(mu) vb2vb3 = vb2vb3 + vb2(mu)*vb3(mu)*metric(mu) END DO x(1) = (2*gnvb2*gnvb3 - 2*gzvb2*gzvb3)*tg5wva1va4 & + (2*gnva1*gnva4 - 2*gzva1*gzva4)*tg5wvb2vb3 & + (-(gnvb2*tg5wgnva4) - gnva4*tg5wgnvb2 + gzvb2*tg5wgzva4 & + gzva4*tg5wgzvb2)*va1vb3 x(2) = -(gnvb3*tg5wgnva1) - gnva1*tg5wgnvb3 + gzvb3*tg5wgzva1 & + gzva1*tg5wgzvb3 + (tg5wgngn - tg5wgzgz)*va1vb3 x(3) = x(1) + va4vb2*x(2) x(4) = gnvb3*tg5wgnvb2 + gnvb2*tg5wgnvb3 - gzvb3*tg5wgzvb2 & - gzvb2*tg5wgzvb3 - 2*tg5wvb2vb3 + (-(gnvb2*gnvb3) & + gzvb2*gzvb3)*tracetg5 x(5) = x(3) + va1va4*x(4) x(6) = -(gnvb3*tg5wgnva4) - gnva4*tg5wgnvb3 + gzvb3*tg5wgzva4 & + gzva4*tg5wgzvb3 + 2*tg5wva4vb3 + (gnva4*gnvb3 & - gzva4*gzvb3)*tracetg5 x(7) = x(5) + va1vb2*x(6) x(8) = -(gnvb2*tg5wgnva1) - gnva1*tg5wgnvb2 + gzvb2*tg5wgzva1 & + gzva1*tg5wgzvb2 + 2*tg5wva1vb2 + (gnva1*gnvb2 & - gzva1*gzvb2)*tracetg5 x(9) = tg5wgngn - tg5wgzgz - 2*tracetg5 x(10) = x(8) + va1vb2*x(9) x(11) = x(7) + va4vb3*x(10) x(12) = gnva4*tg5wgnva1 + gnva1*tg5wgnva4 - gzva4*tg5wgzva1 & - gzva1*tg5wgzva4 - 2*tg5wva1va4 + (-(gnva1*gnva4) & + gzva1*gzva4)*tracetg5 x(13) = -tg5wgngn + tg5wgzgz + 2*tracetg5 x(14) = x(12) + va1va4*x(13) x(15) = x(11) + vb2vb3*x(14) result = -12*cf*nc*x(15) result = result*prefactor ! ! (End flavorset query.) ! END IF !------ ! END IF ! feynmanSH0 = result RETURN END function feynmanSH0 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! ! Miscellaneous Functions ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function alpi(mumsbar) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: mumsbar ! Out: real(kind=dbl) :: alpi ! ! Alpha_s/pi as a function of the MSbar scale, frozen at alpimax = 1/pi. ! See D.~E.~Soper and L.~R.~Surguladze, ! %``On the QCD perturbative expansion for e~+ e~- $\to$ hadrons,'' ! Phys.\ Rev.\ D {\bf 54}, 4566 (1996) ! [arXiv:hep-ph/9511258]. ! 21 February 2002 ! 17 September 2002 : add freezing at alphamax. ! real(kind=dbl) :: nc,nf,cf common /colorfactors/ nc,nf,cf ! Physics data: real(kind=dbl) :: alphasofmz,sinsqthetaw,mz,widthz,externalrts common /physicsdata/ alphasofmz,sinsqthetaw,mz,widthz,externalrts ! real(kind=dbl) :: b0,b1,b2 real(kind=dbl) :: t,x,alpi0,alpiinv,temp,onepx,ln1px real(kind=dbl), parameter :: pi = 3.141592653589793239d0 real(kind=dbl), parameter :: alpimax = 0.31830988618379d0 ! 1/pi ! real(kind=dbl) :: mumin = 0.0d0 ! This gets adjusted and saved. ! IF (mumsbar.LT.mumin) THEN alpi = alpimax RETURN END IF ! ! The beta function coefficients. ! b0 = (33.0d0 - 2.0d0*nf)/12.0d0 b1 = (306.0d0 - 38.0d0*nf)/48.0d0 b2 = (77139.0d0 - 15099.0d0*nf + 325.0d0*nf**2)/3456.0d0 ! alpi0 = alphasofmz/pi t = 2.0d0*log(mumsbar/mz) x = b0*t*alpi0 onepx = 1.0d0 + x IF (onepx.LT.0.0d0) THEN mumin = mumsbar alpi = alpimax RETURN END IF ln1px = log(onepx) alpiinv = onepx/alpi0 alpiinv = alpiinv + ln1px*b1/b0 temp = (b0*b2 - b1**2)/b0**2 * x/onepx temp = temp + b1**2/b0**2 * ln1px/onepx temp = alpi0 * temp alpiinv = alpiinv + temp IF (alpiinv.LE.0.0d0) THEN mumin = mumsbar alpi = alpimax RETURN END IF alpi = 1.0d0/alpiinv IF (alpi.GT.alpimax) THEN mumin = mumsbar alpi = alpimax RETURN END IF END function alpi ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function xxreal(z) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: z ! Out: real(kind=dbl) :: xxreal ! xxreal = dble(z) RETURN END function xxreal ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function xximag(z) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: z ! Out: real(kind=dbl) :: xximag ! complex(kind=dbl) :: zz ! zz = (0.0d0,-1.0d0) * z xximag = dble(zz) RETURN END function xximag ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function complexsqrt(z) ! use beowulf_parameters implicit none ! In: complex(kind=dbl) :: z ! Out: complex(kind=dbl) :: complexsqrt ! ! Square root for complex numbers with error checking. ! 1 February 1998 ! real(kind=dbl) :: xxreal,xximag ! IF (xxreal(z).LT.0.0d0) THEN IF(abs(xximag(z)).LT. (1.0d-1 * abs(xxreal(z))) ) THEN write(nout,*)'Too near cut of sqrt(z) in complexsqrt(z).' write(nout,*) z stop END IF END IF complexsqrt = sqrt(z) RETURN END function complexsqrt ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function factorial(n) ! use beowulf_parameters implicit none ! In: integer :: n ! Out: real(kind=dbl) :: factorial ! integer :: j ! factorial = 1.0d0 DO j = 1,n factorial = factorial * j END DO RETURN END function factorial ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function sinhinv(z) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: z ! Out: real(kind=dbl) :: sinhinv ! ! Evaluate arcsinh(z) = log( z + Sqrt(1+z^2) ). ! For small z, we use the first four terms in the power ! series expansion of this function so that we do not ! lose precision in evaluating log(1 + z + z^2/2 + ...). ! At z = 0.03, the series evaluation is accurate to a ! fractional error of 2E-14. At this same point, the ! precision of the Log form of the function should be ! about that for representing 1.03 - 1.00, or 14 digits ! minus 1.5 digits, or 3E-12. ! real(kind=dbl) :: z2,z3,z5,z7 ! IF (z.LT.3.0d-2) THEN z2 = z**2 z3 = z * z2 z5 = z3 * z2 z7 = z5 * z2 sinhinv = z - 1.66666666667d-1 * z3 & + 7.5d-2 * z5 - 4.46428571429d-2 * z7 ELSE sinhinv = log(z + sqrt(1.0d0 + z**2)) END IF RETURN END function sinhinv ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function log1px(x) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: x ! Out: real(kind=dbl) :: log1px ! ! Returns log(1+x). ! 17 March 2003 ! IF (abs(x).gt.1d-2) THEN log1px = log(1.0d0 + x) ELSE ! ! log1px = x - x^2/2 + x^3/3 + ... + x^7/7. ! log1px = (0.1666666666666667d0 - 0.1428571428571429d0*x) log1px = 0.2d0 - x*log1px log1px = 0.25d0 - x*log1px log1px = 0.3333333333333333d0 - x*log1px log1px = 0.5d0 - x*log1px log1px = 1.0d0 - x*log1px log1px = x*log1px END IF ! end function log1px ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function expm1(x) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: x ! Out: real(kind=dbl) :: expm1 ! ! Returns exp(x) - 1. ! 15 December 1999 ! real(kind=dbl), parameter :: inv2 = 0.5d0 real(kind=dbl), parameter :: inv3 = 0.333333333333333333d0 real(kind=dbl), parameter :: inv4 = 0.25d0 real(kind=dbl), parameter :: inv5 = 0.2d0 real(kind=dbl), parameter :: inv6 = 0.166666666666666667d0 real(kind=dbl), parameter :: inv7 = 0.142857142857142857d0 real(kind=dbl), parameter :: inv8 = 0.125d0 ! IF (abs(x) .GT. 0.1d0) THEN expm1 = exp(x) - 1.0d0 ELSE expm1 = 1.0d0 + inv8*x expm1 = 1.0d0 + inv7*x*expm1 expm1 = 1.0d0 + inv6*x*expm1 expm1 = 1.0d0 + inv5*x*expm1 expm1 = 1.0d0 + inv4*x*expm1 expm1 = 1.0d0 + inv3*x*expm1 expm1 = 1.0d0 + inv2*x*expm1 expm1 = x*expm1 END IF RETURN END function expm1 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function sqrtm1(x) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: x ! Out: real(kind=dbl) :: sqrtm1 ! ! Returns sqrt(1+x) -1. ! The coefficients are 1/2,1/4,3/6,5/8,7/10,9/12,11/14,13/16,15/18. ! 15 December 1999 ! real(kind=dbl), parameter :: c1 = 0.5d0 real(kind=dbl), parameter :: c2 = 0.25d0 real(kind=dbl), parameter :: c3 = 0.5d0 real(kind=dbl), parameter :: c4 = 0.625d0 real(kind=dbl), parameter :: c5 = 0.7d0 real(kind=dbl), parameter :: c6 = 0.75d0 real(kind=dbl), parameter :: c7 = 0.785714285714285714d0 real(kind=dbl), parameter :: c8 = 0.8125d0 real(kind=dbl), parameter :: c9 = 0.833333333333333333d0 ! IF (abs(x) .GT. 0.03d0) THEN sqrtm1 = sqrt(1 + x) - 1.0d0 ELSE sqrtm1 = 1.0d0 - c9*x sqrtm1 = 1.0d0 - c8*x*sqrtm1 sqrtm1 = 1.0d0 - c7*x*sqrtm1 sqrtm1 = 1.0d0 - c6*x*sqrtm1 sqrtm1 = 1.0d0 - c5*x*sqrtm1 sqrtm1 = 1.0d0 - c4*x*sqrtm1 sqrtm1 = 1.0d0 - c3*x*sqrtm1 sqrtm1 = 1.0d0 - c2*x*sqrtm1 sqrtm1 = c1*x*sqrtm1 END IF RETURN END function sqrtm1 ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function logsqint(y) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: y ! Out: real(kind=dbl) :: logsqint ! ! The integral from 0 to Y of Log^2(y'). ! 20 February 2001 ! real(kind=dbl) :: l ! l = log(y) logsqint = y * (l**2 - 2.0d0*l + 2.0d0) RETURN END function logsqint ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function invlogsqint(w) ! use beowulf_parameters implicit none ! In: real(kind=dbl) :: w ! Out: real(kind=dbl) :: invlogsqint ! ! Y = INVLOGSQINT(W) iff W = LOGSQINT(Y) where ! LOGSQINT(Y) is the integral from 0 to Y of Log^2(y'), ! namely LOGSQINT(Y) = Y * (Log(Y)**2 - 2.0D0*Log(Y) + 2.0D0). ! 20 February 2001 ! ! real(kind=dbl) :: u,z,zsq,temp,ucalc,deltau logical :: moreneeded integer :: n ! ! We use variables Z = Log(Y) and U = Log(W). Thus we want to solve ! U = Z + Log( Z** - 2*Z + 2 ). We iteratively use ! Z_(n+1) = Z_n + (U - U_n)/ (dU/dZ) where ! dU/dZ = Z**2/( Z** - 2*Z + 2 ). ! u = log(w) z = 1.2d0*u - 2.0d0 moreneeded = .true. n = 0 DO WHILE (moreneeded) n = n + 1 zsq = z**2 temp = zsq - 2.0d0*z + 2.0d0 ucalc = z + log(temp) deltau = u - ucalc z = z + deltau*temp/zsq IF (abs(deltau).LT.1.0d-8) THEN moreneeded = .false. END IF IF (n.GT.10) THEN write(nout,*)'Failed convergence in invlogsqint.' stop END IF END DO invlogsqint = exp(z) RETURN END function invlogsqint ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! Random Number Generator !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine randominit(iran) ! use beowulf_parameters implicit none ! In: integer :: iran ! ! Code from CERN, 1991. ! Modified to replace .AND. by IAND() and .OR. by IOR(). ! ! Initialize the shift-register random number generator from a random ! seed IRAN, 0 <= IRAN < 259200, with the help of a portable "quick ! and dirty" generator. ! integer, parameter :: lbit=31 real(kind=dbl), parameter :: fac= 2.0d0**(-lbit) ! Here LBIT is the number of bits used in the shift register generator integer :: j,ir(250) real(kind=dbl) :: rr(250) common/rando/ rr,j,ir save /rando/ integer :: i,lb,jran,ifac1,isk,idi,i1s ! Configuration of the shift register generator integer, parameter :: im = 259200 integer, parameter :: ia = 7141 integer, parameter :: ic = 54773 ! ! IF(iran.LT.0.OR.iran.GE.im)STOP & 'rini: iran out of range' jran=iran ! Warm up the auxiliary generator a little DO i=1,10 jran=mod(jran*ia+ic,im) END DO ifac1=((2**(lbit-1)-1)*2+1)/im DO i=2,250 jran=mod(jran*ia+ic,im) ir(i)=ifac1*jran END DO ! Guarantee LBIT linearly independent (over the field of 2 el.) ! elements in IR(I): ir(1)=1 i=1 isk=250/lbit idi=1 i1s=1 DO lb=1,lbit-1 i=i+isk idi=idi*2 i1s=i1s+idi ir(i)=ior(ir(i),idi) ir(i)=iand(ir(i),i1s) END DO call newran END subroutine randominit ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! subroutine newran ! use beowulf_parameters implicit none ! ! Code from CERN, 1991. ! Modified to replace .XOR. by IEOR(). ! ! Fills IR(I),RR(I) with 250 new random numbers, resets J=0. ! Increment J before use! ! integer, parameter :: lbit=31 real(kind=dbl), parameter :: fac= 2.0d0**(-lbit) integer :: j,ir(250) real(kind=dbl) :: rr(250) common/rando/ rr,j,ir save /rando/ ! integer :: n ! DO n=1,103 ir(n)=ieor(ir(n+147),ir(n)) rr(n)=fac*(dble(ir(n)) + 0.5d0) END DO ! DO n=104,250 ir(n)=ieor(ir(n-103),ir(n)) rr(n)=fac*(dble(ir(n)) + 0.5d0) END DO ! j=0 END subroutine newran ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! function random(dummy) ! use beowulf_parameters implicit none ! In: integer :: dummy ! Out: real(kind=dbl) :: random ! ! Code from CERN, 1991. ! ! Random number between 2**(-32) and 1 - 2**(-32): ! integer :: j,ir(250) real(kind=dbl) :: rr(250) common/rando/ rr,j,ir save /rando/ ! IF(j.GE.250)call newran j=j+1 random = rr(j) END function random ! !2345678901234567890123456789012345678901234567890123456789012345678901234567890 ! END OF LIBRARY ROUTINES FOR E+E- CALCULATION !2345678901234567890123456789012345678901234567890123456789012345678901234567890