JHUGen MELA  JHUGen v7.5.6, MELA v2.4.2
Matrix element calculations as used in JHUGen.
mod_TTBHiggs.F90
Go to the documentation of this file.
1 MODULE modttbhiggs
2 use modparameters
3 implicit none
4 
5 
6 public :: evalxsec_pp_ttbh, evalxsec_pp_bbbh, evalamp_gg_ttbh, evalamp_qqb_ttbh
7 public :: initprocess_ttbh
8 public :: exitprocess_ttbh
9 private
10 
11 integer,parameter :: colorlesstag = 1
12 
13 
14 type :: particle
15  integer :: parttype
16  integer :: extref
17  integer :: helicity
18  real(8) :: mass
19  real(8) :: mass2
20  complex(8) :: mom(1:4)
21  complex(8) :: pol(1:4)
22 end type
23 
24 type :: ptrtoparticle
25  integer,pointer :: parttype
26  integer,pointer :: extref
27  real(8),pointer :: mass
28  real(8),pointer :: mass2
29  integer ,pointer :: helicity
30  complex(8),pointer :: mom(:)
31  complex(8),pointer :: pol(:)
32 end type
33 
34 
35 
36 type :: treeprocess
37  integer :: numpart
38  integer :: numqua
39  integer :: numsca
40  integer :: numw
41  integer :: numv
42  integer :: bosonvertex
43  integer,allocatable :: numglu(:)
44  integer,allocatable :: partref(:)
45  integer,allocatable :: parttype(:)
46  type(ptrtoparticle),allocatable :: quarks(:)
47  type(ptrtoparticle),allocatable :: gluons(:)
48  type(ptrtoparticle) :: boson
49  type(ptrtoparticle),allocatable :: scalars(:)
50 end type
51 
52 
53 INTERFACE OPERATOR (.ndot.)
54  module procedure fourvecdot
55 END INTERFACE OPERATOR (.Ndot.)
56 
57 
58 real(8), parameter :: propcut = 1.0d-8
59 integer, parameter :: dv=4,ds=4
60 
61 type(particle),save :: extparticles(1:7)
62 type(treeprocess),save :: thetreeamps_gg_ttbh(1:2)
63 type(treeprocess),save :: thetreeamps_qqb_ttbh(1:1)
64 
65 
66 complex(8) :: couplhtt_right_dyn,couplhtt_left_dyn
67 
68 
69 
70 
71  CONTAINS
72 
73 
74 SUBROUTINE evalxsec_pp_ttbh(Mom,SelectProcess,Res)
75 implicit none
76 real(8), intent(in) :: mom(1:4,1:13)
77 integer,intent(in) :: selectprocess! 0=gg, 1=qqb, 2=all
78 real(8), intent(out) :: res(-5:5,-5:5)
79 real(8) :: matelsq_gg,matelsq_qqb,matelsq_qbq
80 integer :: iq
81 
82  call initprocess_ttbh()
83 
84  matelsq_qqb = 0d0
85  matelsq_qbq = 0d0
86  matelsq_gg = 0d0
87  if( selectprocess.eq.0 ) then
88  call evalamp_gg_ttbh(mom(1:4,1:13),matelsq_gg)
89  elseif( selectprocess.eq.1 ) then
90  call evalamp_qqb_ttbh(mom(1:4,1:13),matelsq_qqb)
91  matelsq_qbq = matelsq_qqb
92  else
93  call evalamp_gg_ttbh(mom(1:4,1:13),matelsq_gg)
94  call evalamp_qqb_ttbh(mom(1:4,1:13),matelsq_qqb)
95  matelsq_qbq = matelsq_qqb
96  endif
97  do iq=0,5
98  if(iq.eq.pdfglu_) then
99  res(iq,iq) = matelsq_gg
100  else
101  res(iq,-iq) = matelsq_qqb
102  res(-iq,iq) = matelsq_qbq
103  endif
104  enddo
105 
106  call exitprocess_ttbh()
107  RETURN
108 END SUBROUTINE
109 
110 SUBROUTINE evalxsec_pp_bbbh(Mom,SelectProcess,Res)
111 implicit none
112 real(8), intent(in) :: mom(1:4,1:13)
113 integer,intent(in) :: selectprocess! 0=gg, 1=qqb, 2=all
114 real(8), intent(out) :: res(-5:5,-5:5)
115 real(8) :: tmptopmass
116 integer :: tmptopdec
117  tmptopmass = m_top
118  tmptopdec = topdecays
119 
120  m_top = m_bot
121  topdecays=0
122  call evalxsec_pp_ttbh(mom,selectprocess,res)
123 
124  m_top = tmptopmass
125  topdecays = tmptopdec
126  RETURN
127 END SUBROUTINE
128 
129 
130 
131 SUBROUTINE initprocess_ttbh()
132 implicit none
133 integer :: numquarks,numgluons,numboson
134 integer :: numtrees
135 integer :: itree,numparticles
136 
137 
138 ! gg->ttbar+H
139  numquarks=2; numgluons=2; numboson=1;
140  numparticles=numquarks+numgluons+numboson
141  numtrees=2
142  do itree=1,numtrees
143  thetreeamps_gg_ttbh(itree)%NumPart=numparticles
144  thetreeamps_gg_ttbh(itree)%NumQua=numquarks
145  allocate( thetreeamps_gg_ttbh(itree)%NumGlu(0:numquarks+1) )
146  allocate( thetreeamps_gg_ttbh(itree)%PartRef(1:numparticles) )
147  allocate( thetreeamps_gg_ttbh(itree)%PartType(1:numparticles) )
148  allocate( thetreeamps_gg_ttbh(itree)%Quarks(1:numquarks) )
149  allocate( thetreeamps_gg_ttbh(itree)%Gluons(1:numgluons) )
150  thetreeamps_gg_ttbh(itree)%NumGlu(0) = numgluons
151  thetreeamps_gg_ttbh(itree)%NumSca = 0
152  enddo
153 
154 ! qqbar->ttbar+H
155  numquarks=4; numgluons=0; numboson=1;
156  numparticles=numquarks+numgluons+numboson
157  numtrees=1
158  do itree=1,numtrees
159  thetreeamps_qqb_ttbh(itree)%NumPart=numparticles
160  thetreeamps_qqb_ttbh(itree)%NumQua=numquarks
161  allocate( thetreeamps_qqb_ttbh(itree)%NumGlu(0:numquarks+1) )
162  allocate( thetreeamps_qqb_ttbh(itree)%PartRef(1:numparticles) )
163  allocate( thetreeamps_qqb_ttbh(itree)%PartType(1:numparticles) )
164  allocate( thetreeamps_qqb_ttbh(itree)%Quarks(1:numquarks) )
165  allocate( thetreeamps_qqb_ttbh(itree)%Gluons(1:numgluons) )
166  thetreeamps_qqb_ttbh(itree)%NumGlu(0) = numgluons
167  thetreeamps_qqb_ttbh(itree)%NumSca = 0
168  enddo
169 
170  extparticles(1)%PartType = atop_
171  extparticles(1)%ExtRef = 1
172  extparticles(1)%Mass = m_top
173  extparticles(1)%Mass2= extparticles(1)%Mass**2
174  extparticles(1)%Helicity = 0
175 
176  extparticles(2)%PartType = top_
177  extparticles(2)%ExtRef = 2
178  extparticles(2)%Mass = m_top
179  extparticles(2)%Mass2= extparticles(2)%Mass**2
180  extparticles(2)%Helicity = 0
181 
182  extparticles(3)%PartType = glu_
183  extparticles(3)%ExtRef = 3
184  extparticles(3)%Mass = 0d0
185  extparticles(3)%Mass2= 0d0
186  extparticles(3)%Helicity = 0
187 
188  extparticles(4)%PartType = glu_
189  extparticles(4)%ExtRef = 4
190  extparticles(4)%Mass = 0d0
191  extparticles(4)%Mass2= 0d0
192  extparticles(4)%Helicity = 0
193 
194  extparticles(5)%PartType = astr_
195  extparticles(5)%ExtRef = 5
196  extparticles(5)%Mass = 0d0
197  extparticles(5)%Mass2= 0d0
198  extparticles(5)%Helicity = 0
199 
200  extparticles(6)%PartType = str_
201  extparticles(6)%ExtRef = 6
202  extparticles(6)%Mass = 0d0
203  extparticles(6)%Mass2= 0d0
204  extparticles(6)%Helicity = 0
205 
206  extparticles(7)%PartType = hig_
207  extparticles(7)%ExtRef = 7
208  extparticles(7)%Mass = m_reso
209  extparticles(7)%Mass2= extparticles(5)%Mass**2
210  extparticles(7)%Helicity = 0
211 
212 
213  thetreeamps_gg_ttbh(1)%PartRef(1:5) = (/3,4,1,7,2/)! (/1,7,2,3,4/)
214  thetreeamps_gg_ttbh(2)%PartRef(1:5) = (/3,1,7,2,4/)! (/1,7,2,4,3/)
215  do itree=1,2
216  call linktreeparticles(thetreeamps_gg_ttbh(itree),extparticles(1:7))
217  enddo
218 
219  thetreeamps_qqb_ttbh(1)%PartRef(1:5) = (/5,6,1,7,2/)! (/1,7,2,5,6/)
220  call linktreeparticles(thetreeamps_qqb_ttbh(1),extparticles(1:7))
221 
222 
223  couplhtt_right_dyn = m_top/vev/2d0 * ( kappa + (0d0,1d0)*kappa_tilde )
224  couplhtt_left_dyn = m_top/vev/2d0 * ( kappa - (0d0,1d0)*kappa_tilde )
225 
226 
227 RETURN
228 END SUBROUTINE
229 
230 
231 SUBROUTINE exitprocess_ttbh()
232 implicit none
233 integer :: numtrees, itree
234 
235 
236 ! gg->ttbar+H
237  numtrees=2
238  do itree=1,numtrees
239  !call UnLinkTreeParticles(TheTreeAmps_GG_TTBH(iTree))
240 
241  if(allocated( thetreeamps_gg_ttbh(itree)%NumGlu )) then
242  deallocate( thetreeamps_gg_ttbh(itree)%NumGlu )
243  endif
244  if(allocated( thetreeamps_gg_ttbh(itree)%PartRef )) then
245  deallocate( thetreeamps_gg_ttbh(itree)%PartRef )
246  endif
247  if(allocated( thetreeamps_gg_ttbh(itree)%PartType )) then
248  deallocate( thetreeamps_gg_ttbh(itree)%PartType )
249  endif
250  if(allocated( thetreeamps_gg_ttbh(itree)%Quarks )) then
251  deallocate( thetreeamps_gg_ttbh(itree)%Quarks )
252  endif
253  if(allocated( thetreeamps_gg_ttbh(itree)%Gluons )) then
254  deallocate( thetreeamps_gg_ttbh(itree)%Gluons )
255  endif
256  if(allocated( thetreeamps_gg_ttbh(itree)%Scalars )) then
257  deallocate( thetreeamps_gg_ttbh(itree)%Scalars )
258  endif
259  enddo
260 
261  numtrees=1
262  do itree=1,numtrees
263  !call UnLinkTreeParticles(TheTreeAmps_QQB_TTBH(iTree))
264 
265  if(allocated( thetreeamps_qqb_ttbh(itree)%NumGlu )) then
266  deallocate( thetreeamps_qqb_ttbh(itree)%NumGlu )
267  endif
268  if(allocated( thetreeamps_qqb_ttbh(itree)%PartRef )) then
269  deallocate( thetreeamps_qqb_ttbh(itree)%PartRef )
270  endif
271  if(allocated( thetreeamps_qqb_ttbh(itree)%PartType )) then
272  deallocate( thetreeamps_qqb_ttbh(itree)%PartType )
273  endif
274  if(allocated( thetreeamps_qqb_ttbh(itree)%Quarks )) then
275  deallocate( thetreeamps_qqb_ttbh(itree)%Quarks )
276  endif
277  if(allocated( thetreeamps_qqb_ttbh(itree)%Gluons )) then
278  deallocate( thetreeamps_qqb_ttbh(itree)%Gluons )
279  endif
280  if(allocated( thetreeamps_qqb_ttbh(itree)%Scalars )) then
281  deallocate( thetreeamps_qqb_ttbh(itree)%Scalars )
282  endif
283  enddo
284 
285 
286 RETURN
287 END SUBROUTINE
288 
289 
290 
291 SUBROUTINE evalamp_gg_ttbh(Mom,SqAmp)
292 use modtopdecay
293 implicit none
294 real(8) :: mom(1:4,1:13),sqamp
295 complex(8) :: resoffsh(1:4,1:2),res(1:2,1:2)
296 complex(8) :: glupol(1:4,1:2,1:2)
297 integer :: hel4,tophel1,tophel2,nhel
298 real(8),parameter :: c_aa=64.d0/3.d0, c_ab=-8.d0/3.d0
299 integer, parameter :: inleft=1,inright=2,hbos=3,tbar=4,t=5, bbar=6,wm=7,lepm=8,nubar=9, b=10,wp=11,lepp=12,nu=13
300 sqamp = 0d0
301 
302 
303  extparticles(1)%Mom(1:4) = mom(1:4,tbar)
304  extparticles(2)%Mom(1:4) = mom(1:4,t)
305  extparticles(3)%Mom(1:4) =-mom(1:4,inleft)
306  extparticles(4)%Mom(1:4) =-mom(1:4,inright)
307  extparticles(7)%Mom(1:4) = mom(1:4,hbos)
308 
309  if( topdecays.ne.0 ) then
310  call topdecay(atop_,(/mom(1:4,bbar),mom(1:4,lepm),mom(1:4,nubar)/),extparticles(1)%Pol(1:4))
311  call topdecay(top_,(/mom(1:4,b),mom(1:4,lepp),mom(1:4,nu)/),extparticles(2)%Pol(1:4))
312  endif
313  extparticles(7)%Pol(1:4) = 1d0
314 ! call HDecay(ExtParticles(7),DK_LO,MomExt(1:4,12:13))
315  glupol(1:4,1,1) = pol_mless(extparticles(3)%Mom(1:4),+1,outgoing=.true.)
316  glupol(1:4,1,2) = pol_mless(extparticles(3)%Mom(1:4),-1,outgoing=.true.)
317  glupol(1:4,2,1) = pol_mless(extparticles(4)%Mom(1:4),+1,outgoing=.true.)
318  glupol(1:4,2,2) = pol_mless(extparticles(4)%Mom(1:4),-1,outgoing=.true.)
319 ! GluPol(1:4,1,1) = ExtParticles(3)%Mom(1:4); GluPol(1:4,1,2) = ExtParticles(3)%Mom(1:4); print *, "checking gauge invariance"
320 
321 
322  nhel=-1
323  if( topdecays.EQ.0 ) nhel=+1
324  do tophel1=-1,nhel,2
325  do tophel2=-1,nhel,2
326  if( topdecays.eq.0 ) then
327  call ubarspi_dirac(extparticles(2)%Mom(1:4),m_top,tophel1,extparticles(2)%Pol(1:4))
328  call vspi_dirac(extparticles(1)%Mom(1:4),m_top,tophel2,extparticles(1)%Pol(1:4))
329  endif
330  do hel4=1,2
331 
332  extparticles(4)%Pol(1:4) = glupol(1:4,2,hel4)
333 ! ExtParticles(4)%Pol(1:4) = ExtParticles(4)%Mom(1:4); print *, "checking gauge invariance"
334  call new_calc_ampl(0,0,thetreeamps_gg_ttbh(1),resoffsh(1:4,1))
335  call new_calc_ampl(0,0,thetreeamps_gg_ttbh(2),resoffsh(1:4,2))
336 
337  res(1,1) = (resoffsh(1:4,1).ndot.glupol(1:4,1,1))! col1 hel+
338  res(2,1) = (resoffsh(1:4,2).ndot.glupol(1:4,1,1))! col2 hel+
339  res(1,2) = (resoffsh(1:4,1).ndot.glupol(1:4,1,2))! col1 hel-
340  res(2,2) = (resoffsh(1:4,2).ndot.glupol(1:4,1,2))! col2 hel-
341 
342  sqamp = sqamp &
343  + c_aa * dreal( res(1,1)*dconjg(res(1,1)) + res(1,2)*dconjg(res(1,2)) ) &
344  + c_ab * dreal( res(1,1)*dconjg(res(2,1)) + res(1,2)*dconjg(res(2,2)) ) &
345  + c_ab * dreal( res(2,1)*dconjg(res(1,1)) + res(2,2)*dconjg(res(1,2)) ) &
346  + c_aa * dreal( res(2,1)*dconjg(res(2,1)) + res(2,2)*dconjg(res(2,2)) )
347  enddo
348  enddo
349  enddo
350 
351  sqamp = sqamp * spinavg * gluoncolavg**2 * (4d0*pi*alphas)**2 !* (4d0*pi*alpha_QED) * (m_top/(2d0*sitW*M_W))**2
352 
353 
354 RETURN
355 END SUBROUTINE
356 
357 
358 
359 
360 
361 
362 
363 SUBROUTINE evalamp_qqb_ttbh(Mom,SqAmp)
364 use modtopdecay
365 implicit none
366 real(8) :: mom(1:4,1:13),sqamp
367 complex(8) :: resoffsh(1:4),res(1:2)
368 complex(8) :: quapol(1:4,1:2,1:2)
369 integer :: hel4,tophel1,tophel2,nhel
370 real(8),parameter :: c_aa=8.0d0
371 integer, parameter :: inleft=1,inright=2,hbos=3,tbar=4,t=5, bbar=6,wm=7,lepm=8,nubar=9, b=10,wp=11,lepp=12,nu=13
372 sqamp = 0d0
373 
374  extparticles(1)%Mom(1:4) = mom(1:4,tbar)
375  extparticles(2)%Mom(1:4) = mom(1:4,t)
376  extparticles(5)%Mom(1:4) =-mom(1:4,inleft)
377  extparticles(6)%Mom(1:4) =-mom(1:4,inright)
378  extparticles(7)%Mom(1:4) = mom(1:4,hbos)
379 
380  if( topdecays.ne.0 ) then
381  call topdecay(atop_,(/mom(1:4,bbar),mom(1:4,lepm),mom(1:4,nubar)/),extparticles(1)%Pol(1:4))
382  call topdecay(top_,(/mom(1:4,b),mom(1:4,lepp),mom(1:4,nu)/),extparticles(2)%Pol(1:4))
383  endif
384  extparticles(7)%Pol(1:4) = 1d0
385 ! call HDecay(ExtParticles(7),DK_LO,MomExt(1:4,12:13))
386  call ubarspi_dirac(extparticles(6)%Mom(1:4),0d0,-1,quapol(1:4,1,1))
387  call ubarspi_dirac(extparticles(6)%Mom(1:4),0d0,+1,quapol(1:4,1,2))
388  call vspi_dirac(extparticles(5)%Mom(1:4),0d0,-1,quapol(1:4,2,1))
389  call vspi_dirac(extparticles(5)%Mom(1:4),0d0,+1,quapol(1:4,2,2))
390 
391 
392 
393  nhel=-1
394  if( topdecays.EQ.0 ) nhel=+1
395  do tophel1=-1,nhel,2
396  do tophel2=-1,nhel,2
397  if( topdecays.eq.0 ) then
398  call ubarspi_dirac(extparticles(2)%Mom(1:4),m_top,tophel1,extparticles(2)%Pol(1:4))
399  call vspi_dirac(extparticles(1)%Mom(1:4),m_top,tophel2,extparticles(1)%Pol(1:4))
400  endif
401  do hel4=1,2
402 
403  extparticles(6)%Pol(1:4) = quapol(1:4,2,hel4)
404 ! ExtParticles(4)%Pol(1:4) = ExtParticles(4)%Mom(1:4); print *, "checking gauge invariance"
405  call new_calc_ampl(0,0,thetreeamps_qqb_ttbh(1),resoffsh(1:4))
406 
407  res(1) = psp1_(resoffsh(1:4),quapol(1:4,1,1))! hel+
408  res(2) = psp1_(resoffsh(1:4),quapol(1:4,1,2))! hel-
409 
410  sqamp = sqamp &
411  + c_aa * dreal( res(1)*dconjg(res(1)) + res(2)*dconjg(res(2)) )
412  enddo
413  enddo
414  enddo
415  sqamp = sqamp * spinavg * quarkcolavg**2 * (4d0*pi*alphas)**2 !* (4d0*pi*alpha_QED) * (m_top/(2d0*sitW*M_W))**2
416 
417 RETURN
418 END SUBROUTINE
419 
420 
421 
422 
423 
424 
425 
426 
427 SUBROUTINE new_calc_ampl(tag_f,tag_Z,TreeProc,Res)
428 implicit none
429 integer :: tag_f,tag_Z,n
430 complex(8) :: Res(1:Ds)
431 type(treeprocess) :: TreeProc
432 logical,parameter :: Boson=.true.
433 integer :: i,j,Order(1:6)
434 
435 
436  if( treeproc%NumQua.eq.2 .and. treeproc%NumSca.eq.0 ) then! 2 quarks and no scalars
437  if ( treeproc%PartType(1).eq.glu_ .and. boson ) then
438  res(1:dv) = cur_g_2fv( treeproc%Gluons(2:treeproc%NumGlu(0)),treeproc%Quarks(1:treeproc%NumQua),treeproc%Boson,treeproc%NumGlu(0:3) )
439  elseif( isaquark(treeproc%PartType(1)) .and. boson ) then
440  if( treeproc%NumV.eq.1 ) then
441  res(1:ds) = cur_f_2fv(treeproc%Gluons(1:treeproc%NumGlu(0)),treeproc%Quarks(2:2),treeproc%Quarks(1)%PartType,treeproc%Boson,treeproc%NumGlu(0:2))
442  else
443  print *, "requested current with a boson is not available"
444  stop
445  endif
446  else
447  print *, "requested current is not available 2q"
448  stop
449  endif
450 
451  elseif( treeproc%NumQua.eq.4 .and. treeproc%NumSca.eq.0) then! 4 quarks, no scalars
452  if( treeproc%PartType(1).eq.glu_ ) then
453  res(1:dv) = cur_g_4fv( treeproc%Gluons(2:treeproc%NumGlu(0)),treeproc%Quarks(1:treeproc%NumQua),treeproc%Boson,treeproc%BosonVertex,treeproc%NumGlu(0:5) )
454  elseif( isaquark(treeproc%PartType(1)) ) then
455  res(1:ds) = cur_f_4fv( treeproc%Gluons(1:treeproc%NumGlu(0)),treeproc%Quarks(2:4),treeproc%Quarks(1)%PartType,treeproc%Boson,treeproc%BosonVertex,treeproc%NumGlu(0:4),tag_f,tag_z )
456  else
457  print *, "requested current is not available 4q"
458  stop
459  endif
460  else
461  print *, "requested current is not available xx"
462  stop
463  endif
464 
465 return
466 END SUBROUTINE
467 
468 
469 
470 
471 SUBROUTINE linktreeparticles(TheTreeAmp,TheParticles)
472 implicit none
473 type(treeprocess) :: TheTreeAmp
474 type(particle),target :: TheParticles(:)
475 integer :: iPart,PartRef,PartType,ig,iq,ib,NPart,counterQ,counterG,LastQuark,QuarkPos(1:6)
476 
477 
478  thetreeamp%NumW = 0
479  thetreeamp%NumV = 0
480  counterq = 0
481  counterg = 0
482 
483  do npart=1,thetreeamp%NumPart
484  thetreeamp%PartType(npart) = theparticles( thetreeamp%PartRef(npart) )%PartType
485  if( isaquark(thetreeamp%PartType(npart)) ) then
486  !TheTreeAmp%NumQua = TheTreeAmp%NumQua + 1 ! this is suppoed to be done outside this subroutine
487  counterq = counterq + 1
488  quarkpos(counterq) = counterq + counterg
489  lastquark = counterq! only required for BosonVertex below
490 ! elseif( IsAScalar(TheTreeAmp%PartType(NPart)) ) then
491 ! ! TheTreeAmp%NumSca = TheTreeAmp%NumSca + 1 ! this is suppoed to be done outside this subroutine
492 ! counterQ = counterQ + 1! treat the scalar like a quark here because this is only to determine NumGlu
493 ! QuarkPos(counterQ) = counterQ + counterG
494  elseif( thetreeamp%PartType(npart).eq.glu_ ) then
495  counterg = counterg + 1
496  elseif( isaboson(thetreeamp%PartType(npart)) ) then! careful: bosons should only be places *between* same flavor quark lines
497  if( npart.eq.1 ) print *, "Vector boson should not be the first particle."
498  if( abs(thetreeamp%PartType(npart)).eq.abs(wp_) ) thetreeamp%NumW = thetreeamp%NumW + 1
499  if( abs(thetreeamp%PartType(npart)).eq.abs(z0_) ) thetreeamp%NumV = thetreeamp%NumV + 1
500  if( abs(thetreeamp%PartType(npart)).eq.abs(pho_)) thetreeamp%NumV = thetreeamp%NumV + 1
501 ! TheTreeAmp%BosonVertex = TheTreeAmp%PartType(LastQuark)! this variable specifies the position of the boson wrt. to the quark lines
502  thetreeamp%BosonVertex = lastquark
503  endif
504  enddo
505 
506 
507 ! set number of gluons between quark lines
508 ! if( IsAQuark( TheTreeAmp%PartType(1) ) .or. IsAScalar(TheTreeAmp%PartType(1)) ) then ! not a gluon and not a boson
509  if( isaquark( thetreeamp%PartType(1) ) ) then ! not a gluon and not a boson
510  if( thetreeamp%NumQua+thetreeamp%NumSca .eq. 2 ) then
511  thetreeamp%NumGlu(1) = quarkpos(2) - quarkpos(1) - 1
512  thetreeamp%NumGlu(2) = thetreeamp%NumSca+thetreeamp%NumQua+thetreeamp%NumGlu(0) - quarkpos(2)
513  endif
514  if( thetreeamp%NumQua .eq. 4 ) then
515  thetreeamp%NumGlu(1) = quarkpos(2) - quarkpos(1) - 1
516  thetreeamp%NumGlu(2) = quarkpos(3) - quarkpos(2) - 1
517  thetreeamp%NumGlu(3) = quarkpos(4) - quarkpos(3) - 1
518  thetreeamp%NumGlu(4) = thetreeamp%NumSca+thetreeamp%NumQua+thetreeamp%NumGlu(0) - quarkpos(4)
519  endif
520  if( thetreeamp%NumQua .eq. 6 ) then
521  thetreeamp%NumGlu(1) = quarkpos(2) - quarkpos(1) - 1
522  thetreeamp%NumGlu(2) = quarkpos(3) - quarkpos(2) - 1
523  thetreeamp%NumGlu(3) = quarkpos(4) - quarkpos(3) - 1
524  thetreeamp%NumGlu(4) = quarkpos(5) - quarkpos(4) - 1
525  thetreeamp%NumGlu(5) = quarkpos(6) - quarkpos(5) - 1
526  thetreeamp%NumGlu(6) = thetreeamp%NumSca+thetreeamp%NumQua+thetreeamp%NumGlu(0) - quarkpos(6)
527  endif
528 
529  elseif( thetreeamp%PartType(1).eq.10 ) then ! is a gluon
530  if( thetreeamp%NumQua .eq. 2 ) then
531  thetreeamp%NumGlu(1) = quarkpos(1) - 2
532  thetreeamp%NumGlu(2) = quarkpos(2) - quarkpos(1) - 1
533  thetreeamp%NumGlu(3) = thetreeamp%NumSca+thetreeamp%NumQua+thetreeamp%NumGlu(0) - quarkpos(2)
534  endif
535  if( thetreeamp%NumQua .eq. 4 ) then
536  thetreeamp%NumGlu(1) = quarkpos(1) - 2
537  thetreeamp%NumGlu(2) = quarkpos(2) - quarkpos(1) - 1
538  thetreeamp%NumGlu(3) = quarkpos(3) - quarkpos(2) - 1
539  thetreeamp%NumGlu(4) = quarkpos(4) - quarkpos(3) - 1
540  thetreeamp%NumGlu(5) = thetreeamp%NumSca+thetreeamp%NumQua+thetreeamp%NumGlu(0) - quarkpos(4)
541  endif
542  if( thetreeamp%NumQua .eq. 6 ) then
543  thetreeamp%NumGlu(1) = quarkpos(1) - 2
544  thetreeamp%NumGlu(2) = quarkpos(2) - quarkpos(1) - 1
545  thetreeamp%NumGlu(3) = quarkpos(3) - quarkpos(2) - 1
546  thetreeamp%NumGlu(4) = quarkpos(4) - quarkpos(3) - 1
547  thetreeamp%NumGlu(5) = quarkpos(5) - quarkpos(4) - 1
548  thetreeamp%NumGlu(6) = quarkpos(6) - quarkpos(5) - 1
549  thetreeamp%NumGlu(7) = thetreeamp%NumSca+thetreeamp%NumQua+thetreeamp%NumGlu(0) - quarkpos(6)
550  endif
551  endif
552 
553 
554  ig=0; iq=0; ib=0;
555  do ipart=1,thetreeamp%NumPart
556  partref = thetreeamp%PartRef(ipart)
557  parttype= theparticles(partref)%PartType
558  if( parttype.eq.glu_ ) then
559  ig=ig+1
560  thetreeamp%Gluons(ig)%PartType => theparticles(partref)%PartType
561  thetreeamp%Gluons(ig)%ExtRef => theparticles(partref)%ExtRef
562  thetreeamp%Gluons(ig)%Mass => theparticles(partref)%Mass
563  thetreeamp%Gluons(ig)%Mass2 => theparticles(partref)%Mass2
564  thetreeamp%Gluons(ig)%Helicity => theparticles(partref)%Helicity
565  thetreeamp%Gluons(ig)%Mom => theparticles(partref)%Mom
566  thetreeamp%Gluons(ig)%Pol => theparticles(partref)%Pol
567  if( parttype.ne.theparticles(partref)%PartType ) print *,"Error1 in LinkTreeParticles"
568  elseif( isaquark(parttype) ) then ! PartType==Quark
569  iq=iq+1
570  thetreeamp%Quarks(iq)%PartType => theparticles(partref)%PartType
571  thetreeamp%Quarks(iq)%ExtRef => theparticles(partref)%ExtRef
572  thetreeamp%Quarks(iq)%Mass => theparticles(partref)%Mass
573  thetreeamp%Quarks(iq)%Mass2 => theparticles(partref)%Mass2
574  thetreeamp%Quarks(iq)%Helicity => theparticles(partref)%Helicity
575  thetreeamp%Quarks(iq)%Mom => theparticles(partref)%Mom
576  thetreeamp%Quarks(iq)%Pol => theparticles(partref)%Pol
577  if( parttype.ne.theparticles(partref)%PartType ) print *,"Error2 in LinkTreeParticles"
578  elseif( isaboson(parttype) ) then ! PartType==Boson
579  ib=ib+1
580  if( ib.ge.2 ) print *, "Too many bosons in LinkTreeParticles"
581  thetreeamp%Boson%PartType => theparticles(partref)%PartType
582  thetreeamp%Boson%ExtRef => theparticles(partref)%ExtRef
583  thetreeamp%Boson%Mass => theparticles(partref)%Mass
584  thetreeamp%Boson%Mass2 => theparticles(partref)%Mass2
585  thetreeamp%Boson%Helicity => theparticles(partref)%Helicity
586  thetreeamp%Boson%Mom => theparticles(partref)%Mom
587  thetreeamp%Boson%Pol => theparticles(partref)%Pol
588  if( parttype.ne.theparticles(partref)%PartType ) print *,"Error2 in LinkTreeParticles"
589  endif
590  enddo
591  if( ig.ne.thetreeamp%NumGlu(0) .OR. iq.ne.thetreeamp%NumQua+thetreeamp%NumSca .OR. ib.ne.thetreeamp%NumPart-thetreeamp%NumGlu(0)-thetreeamp%NumQua-thetreeamp%NumSca) print *,"Error3 in LinkTreeParticles"
592 
593 
594 RETURN
595 END SUBROUTINE
596 
597 
598 
599 !SUBROUTINE UnLinkTreeParticles(TheTreeAmp)
600 !implicit none
601 !type(TreeProcess) :: TheTreeAmp
602 !integer :: iPart,PartType,PartRef,ig,iq,ib
603 
604 ! ig=0; iq=0; ib=0;
605 ! do iPart=1,TheTreeAmp%NumPart
606 ! PartRef = TheTreeAmp%PartRef(iPart)
607 ! PartType = TheParticles(PartRef)%PartType
608 
609 ! if( PartType.eq.Glu_ ) then
610 ! ig=ig+1
611 ! nullify(TheTreeAmp%Gluons(ig)%PartType)
612 ! nullify(TheTreeAmp%Gluons(ig)%ExtRef)
613 ! nullify(TheTreeAmp%Gluons(ig)%Mass)
614 ! nullify(TheTreeAmp%Gluons(ig)%Mass2)
615 ! nullify(TheTreeAmp%Gluons(ig)%Helicity)
616 ! nullify(TheTreeAmp%Gluons(ig)%Mom)
617 ! nullify(TheTreeAmp%Gluons(ig)%Pol)
618 ! elseif( IsAQuark(PartType) ) then ! PartType==Quark
619 ! iq=iq+1
620 ! nullify(TheTreeAmp%Quarks(iq)%PartType)
621 ! nullify(TheTreeAmp%Quarks(iq)%ExtRef)
622 ! nullify(TheTreeAmp%Quarks(iq)%Mass)
623 ! nullify(TheTreeAmp%Quarks(iq)%Mass2)
624 ! nullify(TheTreeAmp%Quarks(iq)%Helicity)
625 ! nullify(TheTreeAmp%Quarks(iq)%Mom)
626 ! nullify(TheTreeAmp%Quarks(iq)%Pol)
627 ! elseif( IsABoson(PartType) ) then ! PartType==Boson
628 ! ib=ib+1
629 ! nullify(TheTreeAmp%Boson%PartType)
630 ! nullify(TheTreeAmp%Boson%ExtRef)
631 ! nullify(TheTreeAmp%Boson%Mass)
632 ! nullify(TheTreeAmp%Boson%Mass2)
633 ! nullify(TheTreeAmp%Boson%Helicity)
634 ! nullify(TheTreeAmp%Boson%Mom)
635 ! nullify(TheTreeAmp%Boson%Pol)
636 ! endif
637 ! enddo
638 
639 !RETURN
640 !END SUBROUTINE
641 
642 
643 
644 
645 ! ----------------------------------------------------
646 
647 
648 FUNCTION cur_f_2fv(Gluons,Quark,Quark1PartType,Boson,NumGlu) result(Res) ! Quarks(:) DOES include the OFF-shell quark, in contrast to all other routines!
649 implicit none
650 complex(8) :: res(1:ds)
651 integer :: numglu(0:2),i,rin,rout,quark1parttype
652 type(ptrtoparticle) :: gluons(1:),boson,quark(2:2)
653 complex(8) :: glumom(1:dv,numglu(0)), quarkmom(1:dv)
654 complex(8) :: glupol(1:dv,numglu(0)), quarkpol(1:ds)
655 
656 
657 
658  do i=1,numglu(0)
659  glumom(1:dv,i) = gluons(i)%Mom(1:dv)
660  glupol(1:dv,i) = gluons(i)%Pol(1:dv)
661  enddo
662  quarkmom(1:dv) = quark(2)%Mom(1:dv)
663  quarkpol(1:ds) = quark(2)%Pol(1:ds)
664 
665  if( quark1parttype.ne.-quark(2)%PartType ) print *, "Wrong quark flavors in cur_f_2fV"
666  if( numglu(0)-numglu(1)-numglu(2).ne.0 ) print *, "Wrong NumGlu in cur_f_2fV",numglu(0)-numglu(1)-numglu(2)
667 
668  rin =1
669  rout=numglu(0)
670  if( quark(2)%PartType .gt.0 ) then ! X----->----
671  res(:) = fv(glupol(1:dv,rin:rout),glumom(1:dv,rin:rout),quarkpol(1:ds),quarkmom(1:dv),quark(2)%Mass,quark1parttype,boson%Pol(1:dv),boson%Mom(1:dv),numglu(1))
672  else
673  res(:) = bfv(glupol(1:dv,rin:rout),glumom(1:dv,rin:rout),quarkpol(1:ds),quarkmom(1:dv),quark(2)%Mass,quark1parttype,boson%Pol(1:dv),boson%Mom(1:dv),numglu(1))
674  endif
675 
676 
677 return
678 END FUNCTION
679 
680 
681 
682 
683 
684 
685 
686  recursive function fv(e,k,sp,p,mass,QuarkFlavor,eV,kV,ms) result(res)
687  implicit none
688  complex(8), intent(in) :: e(:,:), k(:,:)
689  complex(8), intent(in) :: sp(:), p(:)
690  complex(8), intent(in) :: ev(:), kv(:)
691  integer, intent(in) :: ms,quarkflavor
692  integer :: ms1,m,ng1, ng2
693  integer :: ngluon
694  complex(8) :: res(size(sp))
695  complex(8) :: tmp(size(sp))
696  complex(8) :: k1(size(p))
697  complex(8) :: k2(size(p))
698  complex(8) :: sp2(size(sp))
699  complex(8) :: sp3(size(sp))
700  complex(8) :: e1(size(e,dim=1))
701  complex(8) :: e2(size(e,dim=1))
702  complex(8) :: k1sq,k2sq,k3sq
703  real(8) :: mass
704  complex(8) :: couplvqq_left,couplvqq_right,couplvqq_left2,couplvqq_right2
705  character,parameter :: ferfla*3="dum" ! dummy, only used for check of flavor consistency inside the functions f,bf
706 
707 
708  ngluon = size(e,dim=2)
709  ng1 = ms !#gluons to the left of a f-line
710  ng2 = ngluon - ms !#gluons to the right of the f-line
711  if (ng2 < 0) write(*,*) 'WRONG DEFINITION OF CURRENT fV'
712 
713  if( abs(quarkflavor).eq.top_ .or. abs(quarkflavor).eq.bot_ ) then! note that Bot_ is treated as top quark in TOPAZ!
714  couplvqq_left = couplhtt_left_dyn
715  couplvqq_right = couplhtt_right_dyn
716  else
717  couplvqq_left=0d0
718  couplvqq_right=0d0
719  print *, "this should not happen for the Higgs",quarkflavor,top_
720  endif
721 
722 
723 
724 if (ngluon == 0) then
725  res = vbqv(sp,ev,couplvqq_left,couplvqq_right)
726 else
727 
728  res = (0d0,0d0)
729  do m=0,ng2-1
730  k1 = sum(k(:,ng1+1+m:ngluon),dim=2)
731  e1=g(e(:,ng1+1+m:ngluon),k(:,ng1+1+m:ngluon))
732  k1sq=sc_(k1,k1)
733 
734  k2 = sum(k(:,1:ng1+m),dim=2)
735  k2 = k2 + p + kv
736  k2sq = sc_(k2,k2)-mass**2
737  sp2 = fv(e(:,1:ng1+m),k(:,1:ng1+m),sp,p,mass,quarkflavor,ev,kv,ng1)
738  sp2 = spb2_(sp2,k2)+mass*sp2
739 
740  tmp = vqg(sp2,e1)
741  if (m < ng2-1) then
742  if(abs(k1sq) > propcut) then
743  tmp = -(0d0,1d0)/k1sq*tmp
744  else
745  tmp = (0d0,0d0)
746  endif
747  endif
748 
749  if (abs(k2sq) > propcut) then
750  tmp = (0d0,1d0)/k2sq*tmp
751  else
752  tmp = (0d0,0d0)
753  endif
754  res = res + tmp
755  enddo
756 
757 
758 
759 
760  do m=1,ng1
761  k1 = sum(k(:,1:m),dim=2)
762  e1=g(e(:,1:m),k(:,1:m))
763  k1sq = sc_(k1,k1)
764 
765  k2 = sum(k(:,m+1:ngluon),dim=2)
766  k2 = k2 + p + kv
767  k2sq = sc_(k2,k2) - mass**2
768  ms1 = ng1 - m
769  sp2=fv(e(:,m+1:ngluon),k(:,m+1:ngluon),sp,p,mass,quarkflavor,ev,kv,ms1)
770 
771  sp2 = spb2_(sp2,k2)+mass*sp2
772 
773  tmp = vgq(e1,sp2)
774  if (m > 1) then
775  if (abs(k1sq) > propcut) then
776  tmp=-(0d0,1d0)/k1sq*tmp
777  else
778  tmp = (0d0,0d0)
779  endif
780  endif
781 
782  if (abs(k2sq) > propcut) then
783  tmp=(0d0,1d0)/k2sq*tmp
784  else
785  tmp = (0d0,0d0)
786  endif
787 
788  res = res + tmp
789  enddo
790 
791 
792  sp2 = f(e,k,sp,p,mass,ferfla,ferfla,ms)
793  k2 = sum(k(:,1:ngluon),dim=2)
794  k2 = k2 + p
795  k2sq = sc_(k2,k2) - mass**2
796 
797  sp2 = spb2_(sp2,k2)+ mass*sp2
798 
799  tmp = vbqv(sp2,ev,couplvqq_left,couplvqq_right)
800  if (abs(k2sq) > propcut) then
801  tmp = (0d0,1d0)/k2sq*tmp
802  else
803  tmp = (0d0,0d0)
804  endif
805  res = res + tmp
806 
807 endif
808 
809 end function fv
810 
811 
812 
813 
814  recursive function bfv(e,k,sp,p,mass,QuarkFlavor,eV,kV,ms) result(res)
815  implicit none
816  complex(8), intent(in) :: e(:,:), k(:,:)
817  complex(8), intent(in) :: sp(:), p(:)
818  complex(8), intent(in) :: ev(:), kv(:)
819  integer, intent(in) :: ms,quarkflavor
820  integer :: ms1,m,ng1, ng2
821  integer :: ngluon
822  complex(8) :: res(size(sp))
823  complex(8) :: tmp(size(sp))
824  complex(8) :: k1(size(p))
825  complex(8) :: k2(size(p))
826  complex(8) :: sp2(size(sp))
827  complex(8) :: sp3(size(sp))
828  complex(8) :: e1(size(e,dim=1))
829  complex(8) :: e2(size(e,dim=1))
830  complex(8) :: k1sq,k2sq,k3sq
831  real(8) :: mass
832  complex(8) :: couplvqq_left,couplvqq_right,couplvqq_left2,couplvqq_right2
833  character,parameter :: ferfla*3="dum" ! dummy, only used for check of flavor consistency inside the functions f,bf
834 
835 
836  ngluon = size(e,dim=2)
837  ng1 = ms !#gluons to the left of a f-line
838  ng2 = ngluon - ms !#gluons to the right of the f-line
839 
840  if (ng2 < 0) write(*,*) 'WRONG DEFINITION OF CURRENT fbV'
841 
842  if( abs(quarkflavor).eq.top_ .or. abs(quarkflavor).eq.bot_ ) then! note that Bot_ is treated as top quark in TOPAZ!
843  couplvqq_left = couplhtt_left_dyn
844  couplvqq_right = couplhtt_right_dyn
845  else
846  couplvqq_left=0d0
847  couplvqq_right=0d0
848  print *, "this should not happen for the Higgs",quarkflavor,top_
849  endif
850 
851 
852 
853 if (ngluon == 0) then
854  res = vvq(ev,sp,couplvqq_left,couplvqq_right)
855 else
856 
857  res = (0d0,0d0)
858  do m=0,ng2-1
859  k1 = sum(k(:,ng1+1+m:ngluon),dim=2)
860  e1=g(e(:,ng1+1+m:ngluon),k(:,ng1+1+m:ngluon))
861  k1sq=sc_(k1,k1)
862 
863  k2 = sum(k(:,1:ng1+m),dim=2)
864  k2 = -k2 - p - kv
865  k2sq = sc_(k2,k2)-mass**2
866 
867  sp2 = bfv(e(:,1:ng1+m),k(:,1:ng1+m),sp,p,mass,quarkflavor,ev,kv,ng1)
868  sp2 = spi2_(k2,sp2)+mass*sp2
869 
870  tmp = vbqg(sp2,e1)
871 
872  if (m < ng2-1) then
873  if (abs(k1sq) > propcut) then
874  tmp = -(0d0,1d0)/k1sq*tmp
875  else
876  tmp = (0d0,0d0)
877  endif
878  endif
879 
880  if (abs(k2sq) > propcut) then
881  tmp = (0d0,1d0)/k2sq*tmp
882  else
883  tmp = (0d0,0d0)
884  endif
885 
886  res = res + tmp
887  enddo
888 
889 
890  do m=1,ng1
891 
892  k1 = sum(k(:,1:m),dim=2)
893  e1=g(e(:,1:m),k(:,1:m))
894  k1sq = sc_(k1,k1)
895 
896  k2 = sum(k(:,m+1:ngluon),dim=2)
897  k2 = -k2 - p - kv
898  k2sq = sc_(k2,k2) - mass**2
899  ms1 = ng1 - m
900  sp2=bfv(e(:,m+1:ngluon),k(:,m+1:ngluon),sp,p,mass,quarkflavor,ev,kv,ms1)
901 
902  sp2 = spi2_(k2,sp2)+mass*sp2
903 
904  tmp = vgbq(e1,sp2)
905 
906  if (m > 1) then
907  if (abs(k1sq) > propcut) then
908  tmp=-(0d0,1d0)/k1sq*tmp
909  else
910  tmp = (0d0,0d0)
911  endif
912  endif
913 
914  if (abs(k2sq) > propcut) then
915  tmp=(0d0,1d0)/k2sq*tmp
916  else
917  tmp = (0d0,0d0)
918  endif
919 
920  res = res + tmp
921 
922  enddo
923 
924 
925 
926  sp2 = bf(e,k,sp,p,mass,ferfla,ferfla,ms)
927  k2 = sum(k(:,1:ngluon),dim=2)
928  k2 = -k2 - p
929  k2sq = sc_(k2,k2) -mass**2
930 
931 ! sp2 = spb2_(sp2,k2) +mass*sp2
932  sp2 = spi2_(k2,sp2) +mass*sp2
933 
934  tmp = vvq(ev,sp2,couplvqq_left,couplvqq_right)
935  if (abs(k2sq) > propcut) then
936  tmp = (0d0,1d0)/k2sq*tmp
937  else
938  tmp = (0d0,0d0)
939  endif
940  res = res + tmp
941 
942 endif
943 
944 
945 
946 
947  end function bfv
948 
949 
950 
951 
952 
953 FUNCTION cur_f_4fv(Gluons,Quarks,Quark1PartType,Boson,BosonVertex,NumGlu,tag_f,tag_Z) result(res) ! Quarks(:) does not include the OFF-shell quark
954 implicit none
955 integer :: numglu(0:4),quark1parttype
956 type(ptrtoparticle) :: gluons(1:),quarks(2:4),boson
957 integer :: tag_f,bosonvertex,tag_z
958 integer,target :: tmpextref
959 complex(8) :: res(1:ds),tmp(1:ds)
960 complex(8) :: ubar1(1:ds)
961 complex(8),target :: ubar0(1:ds)
962 complex(8) :: eps1(1:dv)
963 complex(8) :: eps2(1:dv)
964 type(ptrtoparticle) :: tmpgluons(1:numglu(1)+numglu(4)),tmpquark(1:1)
965 complex(8) :: propfac1,propfac2
966 complex(8),target :: pmom1(1:dv)
967 complex(8) :: pmom2(1:dv)
968 integer :: n1a,n1b,n2a,n2b,n3a,n3b,n4a,n4b
969 integer :: rin,rout,i,counter
970 
971 
972 !DEC$ IF (_DebugCheckMyImpl1==1)
973  if( numglu(0)-numglu(1)-numglu(2)-numglu(3)-numglu(4).ne.0 ) print *, "wrong number of gluons in cur_f_4f"
974  if(quarks(3)%PartType.eq.-quarks(4)%PartType .and. quark1parttype.ne.-quarks(2)%PartType ) print *,"wrong flavor in cur_f_4f (1)"
975  if(quarks(2)%PartType.eq.-quarks(3)%PartType .and. quark1parttype.ne.-quarks(4)%PartType ) print *,"wrong flavor in cur_f_4f (2)"
976 !DEC$ ENDIF
977  res(:)=(0d0,0d0)
978  if ( quark1parttype.eq.-quarks(2)%PartType .and. quarks(3)%PartType.eq.-quarks(4)%PartType ) then
979  do n2a=0,numglu(2)
980  do n4a=0,numglu(4)
981  n2b = numglu(2)-n2a
982  n4b = numglu(4)-n4a
983  rin =numglu(1)+n2a+1
984  rout=numglu(1)+numglu(2)+numglu(3)+n4a
985  if (bosonvertex .eq. 1 .or. bosonvertex .eq. 2 .or. bosonvertex .eq. 4) then
986  eps2 = cur_g_2f(gluons(rin:rout),quarks(3:4),(/1+n2b+numglu(3)+n4a,n2b,numglu(3),n4a/))
987  pmom1(:) = summom(gluons,rin,rout) + quarks(3)%Mom + quarks(4)%Mom
988  elseif (bosonvertex .eq. 3) then
989  eps2 = cur_g_2fv(gluons(rin:rout),quarks(3:4),boson,(/1+n2b+numglu(3)+n4a,n2b,numglu(3),n4a/))
990  pmom1(:) = summom(gluons,rin,rout) + quarks(3)%Mom(:) + quarks(4)%Mom(:) + boson%Mom(:)
991  endif
992  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
993  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
994  eps2 = eps2*propfac1
995  do n1a=0,numglu(1)
996  n1b = numglu(1)-n1a
997  ! Fer2
998  if (bosonvertex.eq.1 .or. bosonvertex.eq.2) then
999  rin =n1a+1
1000  rout=numglu(1)+n2a
1001  ubar1(:) = cur_f_2fv(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,boson,(/n2a+n1b,n1b,n2a/) )
1002  pmom2(:) = quarks(2)%Mom(:) + summom(gluons,rin,rout) + boson%Mom(:)
1003  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
1004 
1005  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) then
1006  propfac2=(0d0,0d0)
1007  endif
1008 
1009  if( quarks(2)%PartType.lt.0 ) then
1010  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(2)%Mass*ubar1(:))*propfac2
1011  else
1012  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(2)%Mass*ubar1(:))*propfac2
1013  endif
1014 
1015  if( quarks(2)%PartType.lt.0 ) then
1016  ubar0(:) = vbqg(ubar1,eps2)
1017  else
1018  ubar0(:) = vqg(ubar1,eps2)
1019  endif
1020 
1021  pmom1 = quarks(2)%Mom+quarks(3)%Mom+quarks(4)%Mom+summom(gluons,n1a+1,numglu(1)+numglu(2)+numglu(3)+n4a) + boson%Mom(:)
1022  if(n1a.ge.1 .or. n4b.ge.1) then
1023  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(2)%Mass2)
1024  if( abs(sc_(pmom1,pmom1)-quarks(2)%Mass2).lt.propcut ) then
1025  propfac1=(0d0,0d0)
1026  endif
1027  if( quarks(2)%PartType.lt.0 ) then
1028  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(2)%Mass*ubar0(:))*propfac1
1029  else
1030  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(2)%Mass*ubar0(:))*propfac1
1031  endif
1032  endif
1033 
1034  tmpquark(1)%Mom => pmom1(:)
1035  tmpquark(1)%Pol => ubar0(:)
1036  tmpquark(1)%Mass => quarks(2)%Mass
1037  tmpquark(1)%Mass2=> quarks(2)%Mass2
1038  tmpextref = -1
1039  tmpquark(1)%ExtRef => tmpextref
1040  tmpquark(1)%PartType => quarks(2)%PartType
1041  counter=1
1042  rin =1
1043  rout=n1a
1044  do i=rin,rout
1045  call copyparticleptr(gluons(i),tmpgluons(counter))
1046  counter=counter+1
1047  enddo
1048  rin =numglu(1)+numglu(2)+numglu(3)+n4a+1
1049  rout=numglu(0)
1050  do i=rin,rout
1051  call copyparticleptr(gluons(i),tmpgluons(counter))
1052  counter=counter+1
1053  enddo
1054  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n4b/) )
1055  res(:) = res(:) + tmp(:)
1056  endif
1057 
1058  ! Fer 3
1059  if (bosonvertex .eq. 1 .or. bosonvertex .eq. 4) then
1060  rin =n1a+1
1061  rout=numglu(1)+n2a
1062  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/n2a+n1b,n1b,n2a/) )
1063  if(n1b.ge.1 .or. n2a.ge.1) then
1064  pmom2(:) = quarks(2)%Mom + summom(gluons,rin,rout) ! can be moved outside the n1a-loop
1065  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
1066  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) cycle
1067  if( quarks(2)%PartType.lt.0 ) then
1068  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(2)%Mass*ubar1(:))*propfac2
1069  else
1070  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(2)%Mass*ubar1(:))*propfac2
1071  endif
1072  endif
1073  if( quarks(2)%PartType.lt.0 ) then
1074  ubar0(:) = vbqg(ubar1,eps2)
1075  else
1076  ubar0(:) = vqg(ubar1,eps2)
1077  endif
1078 
1079  pmom1 = quarks(2)%Mom+quarks(3)%Mom+quarks(4)%Mom+summom(gluons,n1a+1,numglu(1)+numglu(2)+numglu(3)+n4a)
1080  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(2)%Mass2)
1081  if( abs(sc_(pmom1,pmom1)-quarks(2)%Mass2).lt.propcut ) then
1082  propfac1=(0d0,0d0)
1083  endif
1084  if( quarks(2)%PartType.lt.0 ) then
1085  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(2)%Mass*ubar0(:))*propfac1
1086  else
1087  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(2)%Mass*ubar0(:))*propfac1
1088  endif
1089 
1090  tmpquark(1)%Mom => pmom1(:)
1091  tmpquark(1)%Pol => ubar0(:)
1092  tmpquark(1)%Mass => quarks(2)%Mass
1093  tmpquark(1)%Mass2=> quarks(2)%Mass2
1094  tmpextref = -1
1095  tmpquark(1)%ExtRef => tmpextref
1096  tmpquark(1)%PartType => quarks(2)%PartType
1097  counter=1
1098  rin =1
1099  rout=n1a
1100  do i=rin,rout
1101  call copyparticleptr(gluons(i),tmpgluons(counter))
1102  counter=counter+1
1103  enddo
1104  rin =numglu(1)+numglu(2)+numglu(3)+n4a+1
1105  rout=numglu(0)
1106  do i=rin,rout
1107  call copyparticleptr(gluons(i),tmpgluons(counter))
1108  counter=counter+1
1109  enddo
1110  tmp(:) = cur_f_2fv(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,boson,(/counter-1,n1a,n4b/) )
1111  res(:) = res(:) + tmp(:)
1112  endif
1113 
1114  if (bosonvertex .eq. 3) then
1115  rin =n1a+1
1116  rout=numglu(1)+n2a
1117  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/n2a+n1b,n1b,n2a/) )
1118  if(n1b.ge.1 .or. n2a.ge.1) then
1119  pmom2(:) = quarks(2)%Mom + summom(gluons,rin,rout) ! can be moved outside the n1a-loop
1120  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
1121  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) then
1122  propfac2=(0d0,0d0)
1123  endif
1124  if( quarks(2)%PartType.lt.0 ) then
1125  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(2)%Mass*ubar1(:))*propfac2
1126  else
1127  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(2)%Mass*ubar1(:))*propfac2
1128  endif
1129  endif
1130  if( quarks(2)%PartType.lt.0 ) then
1131  ubar0(:) = vbqg(ubar1,eps2)
1132  else
1133  ubar0(:) = vqg(ubar1,eps2)
1134  endif
1135 
1136  pmom1 = quarks(2)%Mom+quarks(3)%Mom+quarks(4)%Mom+summom(gluons,n1a+1,numglu(1)+numglu(2)+numglu(3)+n4a)+boson%Mom
1137  if(n1a.ge.1 .or. n4b.ge.1) then
1138  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(2)%Mass2)
1139  if( abs(sc_(pmom1,pmom1)-quarks(2)%Mass2).lt.propcut ) cycle
1140  if( quarks(2)%PartType.lt.0 ) then
1141  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(2)%Mass*ubar0(:))*propfac1
1142  else
1143  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(2)%Mass*ubar0(:))*propfac1
1144  endif
1145  endif
1146 
1147  tmpquark(1)%Mom => pmom1(:)
1148  tmpquark(1)%Pol => ubar0(:)
1149  tmpquark(1)%Mass => quarks(2)%Mass
1150  tmpquark(1)%Mass2=> quarks(2)%Mass2
1151  tmpextref = -1
1152  tmpquark(1)%ExtRef => tmpextref
1153  tmpquark(1)%PartType => quarks(2)%PartType
1154  counter=1
1155  rin =1
1156  rout=n1a
1157  do i=rin,rout
1158  call copyparticleptr(gluons(i),tmpgluons(counter))
1159  counter=counter+1
1160  enddo
1161  rin =numglu(1)+numglu(2)+numglu(3)+n4a+1
1162  rout=numglu(0)
1163  do i=rin,rout
1164  call copyparticleptr(gluons(i),tmpgluons(counter))
1165  counter=counter+1
1166  enddo
1167  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n4b/) )
1168  res(:) = res(:) + tmp(:)
1169  endif
1170  enddo
1171  enddo
1172  enddo
1173  endif
1174 
1175 
1176  if( (quark1parttype.eq.-quarks(4)%PartType .and. quarks(2)%PartType.eq.-quarks(3)%PartType) .AND. &
1177  (quarks(4)%ExtRef.ne.-1 .or. tag_f.ne.1 .or. abs(quark1parttype).ne.abs(quarks(2)%PartType)) ) then
1178 
1179  do n1a=0,numglu(1)
1180  do n3a=0,numglu(3)
1181  n1b = numglu(1)-n1a
1182  n3b = numglu(3)-n3a
1183 
1184  rin =n1a+1
1185  rout=numglu(1)+numglu(2)+n3a
1186 
1187 ! This means that all the ext gluons are on this lines,
1188 ! and we must remove this to prevent color issues with a Z on the quark loop, see RR notes
1189 
1190  if (bosonvertex.eq.1 .or. bosonvertex.eq.3 .or. bosonvertex.eq.4) then
1191  if ( tag_z .eq. 1 .and. n1b+numglu(2)+n3a .eq. numglu(0) ) then
1192 ! print * , "cycle for tag_Z=1 in cur_f_4fV"
1193  cycle
1194  endif
1195  eps2 = cur_g_2f(gluons(rin:rout),quarks(2:3),(/1+n1b+numglu(2)+n3a,n1b,numglu(2),n3a/))
1196  pmom1(:) = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
1197  elseif (bosonvertex .eq. 2) then
1198  eps2 = cur_g_2fv(gluons(rin:rout),quarks(2:3),boson,(/1+n1b+numglu(2)+n3a,n1b,numglu(2),n3a/))
1199  pmom1(:) = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + boson%Mom
1200  endif
1201  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
1202  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
1203  eps2 = eps2*propfac1
1204 
1205  do n4a=0,numglu(4)
1206  n4b = numglu(4)-n4a
1207  ! radiate V off Fer4
1208  if (bosonvertex .eq. 3 .or. bosonvertex .eq. 4) then
1209  rin =numglu(1)+numglu(2)+n3a+1
1210  rout=numglu(1)+numglu(2)+numglu(3)+n4a
1211 
1212  ubar1(:) = cur_f_2fv(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,boson,(/n3b+n4a,n3b,n4a/) )
1213  pmom2(:) = quarks(4)%Mom(:) + summom(gluons,rin,rout) + boson%Mom(:)
1214  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(4)%Mass2)
1215  if( abs(sc_(pmom2,pmom2)-quarks(4)%Mass2).lt.propcut ) then
1216  propfac2=(0d0,0d0)
1217  endif
1218 
1219  if( quarks(4)%PartType.lt.0 ) then
1220  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(4)%Mass*ubar1(:))*propfac2
1221  else
1222  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(4)%Mass*ubar1(:))*propfac2
1223  endif
1224  if( quarks(4)%PartType.lt.0 ) then
1225  ubar0(:) = vgbq(eps2,ubar1)
1226  else
1227  ubar0(:) = vgq(eps2,ubar1)
1228  endif
1229 
1230  pmom1 = quarks(2)%Mom+quarks(3)%Mom+quarks(4)%Mom+summom(gluons,n1a+1,numglu(1)+numglu(2)+numglu(3)+n4a) + boson%Mom(:)
1231  if(n1a.ge.1 .or. n4b.ge.1) then
1232  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(4)%Mass2)
1233  if( abs(sc_(pmom1,pmom1)-quarks(4)%Mass2).lt.propcut ) then
1234  propfac1=(0d0,0d0)
1235  endif
1236  if( quarks(4)%PartType.lt.0 ) then
1237  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(4)%Mass*ubar0(:))*propfac1
1238  else
1239  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(4)%Mass*ubar0(:))*propfac1
1240  endif
1241  endif
1242 
1243  tmpquark(1)%Mom => pmom1(:)
1244  tmpquark(1)%Pol => ubar0(:)
1245  tmpquark(1)%Mass => quarks(4)%Mass
1246  tmpquark(1)%Mass2=> quarks(4)%Mass2
1247  tmpextref = -1
1248  tmpquark(1)%ExtRef => tmpextref
1249  tmpquark(1)%PartType => quarks(4)%PartType
1250  counter=1
1251  rin =1
1252  rout=n1a
1253  do i=rin,rout
1254  call copyparticleptr(gluons(i),tmpgluons(counter))
1255  counter=counter+1
1256  enddo
1257  rin =numglu(1)+numglu(2)+numglu(3)+n4a+1
1258  rout=numglu(0)
1259  do i=rin,rout
1260  call copyparticleptr(gluons(i),tmpgluons(counter))
1261  counter=counter+1
1262  enddo
1263  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n4b/) )
1264  res(:) = res(:) + tmp(:)
1265  endif
1266 
1267  if (bosonvertex .eq. 1 .or. bosonvertex .eq. 4) then
1268  ! radiate V off Fer1
1269  rin =numglu(1)+numglu(2)+n3a+1
1270  rout=numglu(1)+numglu(2)+numglu(3)+n4a
1271  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,(/n3b+n4a,n3b,n4a/) )
1272  if(n3b.ge.1 .or. n4a.ge.1) then
1273  pmom2(:) = quarks(4)%Mom + summom(gluons,rin,rout) ! can be moved outside the n1a-loop
1274  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(4)%Mass2)
1275  if( abs(sc_(pmom2,pmom2)-quarks(4)%Mass2).lt.propcut ) then
1276  propfac2=(0d0,0d0)
1277  endif
1278 
1279  if( quarks(4)%PartType.lt.0 ) then
1280  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(4)%Mass*ubar1(:))*propfac2
1281  else
1282  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(4)%Mass*ubar1(:))*propfac2
1283  endif
1284  endif
1285  if( quarks(4)%PartType.lt.0 ) then
1286  ubar0(:) = vgbq(eps2,ubar1)
1287  else
1288  ubar0(:) = vgq(eps2,ubar1)
1289  endif
1290 
1291  pmom1 = quarks(2)%Mom+quarks(3)%Mom+quarks(4)%Mom+summom(gluons,n1a+1,numglu(1)+numglu(2)+numglu(3)+n4a)
1292  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(4)%Mass2)
1293  if( abs(sc_(pmom1,pmom1)-quarks(4)%Mass2).lt.propcut ) then
1294  propfac1=(0d0,0d0)
1295  endif
1296  if( quarks(4)%PartType.lt.0 ) then
1297  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(4)%Mass*ubar0(:))*propfac1
1298  else
1299  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(4)%Mass*ubar0(:))*propfac1
1300  endif
1301 
1302  tmpquark(1)%Mom => pmom1(:)
1303  tmpquark(1)%Pol => ubar0(:)
1304  tmpquark(1)%Mass => quarks(4)%Mass
1305  tmpquark(1)%Mass2=> quarks(4)%Mass2
1306  tmpextref = -1
1307  tmpquark(1)%ExtRef => tmpextref
1308  tmpquark(1)%PartType => quarks(4)%PartType
1309  counter=1
1310  rin =1
1311  rout=n1a
1312  do i=rin,rout
1313  call copyparticleptr(gluons(i),tmpgluons(counter))
1314  counter=counter+1
1315  enddo
1316  rin =numglu(1)+numglu(2)+numglu(3)+n4a+1
1317  rout=numglu(0)
1318  do i=rin,rout
1319  call copyparticleptr(gluons(i),tmpgluons(counter))
1320  counter=counter+1
1321  enddo
1322  tmp(:) = cur_f_2fv(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,boson,(/counter-1,n1a,n4b/) )
1323  res(:) = res(:) + tmp(:)
1324  endif
1325 
1326 
1327  if (bosonvertex .eq. 2) then
1328  rin =numglu(1)+numglu(2)+n3a+1
1329  rout=numglu(1)+numglu(2)+numglu(3)+n4a
1330  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,(/n3b+n4a,n3b,n4a/) )
1331  if ( n3b .ge. 1 .or. n4a .ge. 1) then
1332  pmom2(:) = quarks(4)%Mom(:) + summom(gluons,rin,rout)
1333  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(4)%Mass2)
1334 
1335  if( abs(sc_(pmom2,pmom2)-quarks(4)%Mass2).lt.propcut ) then
1336  propfac2=(0d0,0d0)
1337  endif
1338 
1339  if( quarks(4)%PartType.lt.0 ) then
1340  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(4)%Mass*ubar1(:))*propfac2
1341  else
1342  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(4)%Mass*ubar1(:))*propfac2
1343  endif
1344  endif
1345  if( quarks(4)%PartType.lt.0 ) then
1346  ubar0(:) = vgbq(eps2,ubar1)
1347  else
1348  ubar0(:) = vgq(eps2,ubar1)
1349  endif
1350  pmom1 = quarks(2)%Mom+quarks(3)%Mom+quarks(4)%Mom+summom(gluons,n1a+1,numglu(1)+numglu(2)+numglu(3)+n4a)+boson%Mom
1351  if(n1a.ge.1 .or. n4b.ge.1) then
1352  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(4)%Mass2)
1353  if( abs(sc_(pmom1,pmom1)-quarks(4)%Mass2).lt.propcut ) then
1354  cycle
1355  endif
1356  if( quarks(4)%PartType.lt.0 ) then
1357  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(4)%Mass*ubar0(:))*propfac1
1358  else
1359  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(4)%Mass*ubar0(:))*propfac1
1360  endif
1361  endif
1362 
1363  tmpquark(1)%Mom => pmom1(:)
1364  tmpquark(1)%Pol => ubar0(:)
1365  tmpquark(1)%Mass => quarks(4)%Mass
1366  tmpquark(1)%Mass2=> quarks(4)%Mass2
1367  tmpextref = -1
1368  tmpquark(1)%ExtRef => tmpextref
1369  tmpquark(1)%PartType => quarks(4)%PartType
1370  counter=1
1371  rin =1
1372  rout=n1a
1373  do i=rin,rout
1374  call copyparticleptr(gluons(i),tmpgluons(counter))
1375  counter=counter+1
1376  enddo
1377  rin =numglu(1)+numglu(2)+numglu(3)+n4a+1
1378  rout=numglu(0)
1379  do i=rin,rout
1380  call copyparticleptr(gluons(i),tmpgluons(counter))
1381  counter=counter+1
1382  enddo
1383  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n4b/) )
1384  res(:) = res(:) + tmp(:)
1385  endif
1386  enddo
1387  enddo
1388  enddo
1389 
1390  endif
1391 
1392  return
1393  END FUNCTION cur_f_4fv
1394 
1395 
1396 
1397 
1398 
1399 
1400 FUNCTION cur_f_4f(Gluons,Quarks,Quark1PartType,NumGlu,tag_f,tag_Z_arg) result(res) ! Quarks(:) does not include the OFF-shell quark
1401 implicit none
1402 integer :: numglu(0:4),quark1parttype
1403 type(ptrtoparticle) :: gluons(1:),quarks(2:4)
1404 integer :: tag_f,tag_z
1405 integer, optional :: tag_z_arg
1406 integer,target :: tmpextref
1407 complex(8) :: res(1:ds),tmp(1:ds)
1408 complex(8) :: ubar1(1:ds)
1409 complex(8),target :: ubar0(1:ds)
1410 complex(8) :: eps1(1:dv)
1411 complex(8) :: eps2(1:dv)
1412 type(ptrtoparticle) :: tmpgluons(1:numglu(1)+numglu(4)),tmpquark(1:1)
1413 complex(8) :: propfac1,propfac2
1414 complex(8),target :: pmom1(1:dv)
1415 complex(8) :: pmom2(1:dv)
1416 integer :: n1a,n1b,n2a,n2b,n3a,n3b,n4a,n4b
1417 integer :: rin,rout,i,counter
1418 
1419 
1420 !DEC$ IF (_DebugCheckMyImpl1==1)
1421  if( numglu(0)-numglu(1)-numglu(2)-numglu(3)-numglu(4).ne.0 ) print *, "wrong number of gluons in cur_f_4f"
1422  if(quarks(3)%PartType.eq.-quarks(4)%PartType .and. quark1parttype.ne.-quarks(2)%PartType ) print *,"wrong flavor in cur_f_4f (1)"
1423  if(quarks(2)%PartType.eq.-quarks(3)%PartType .and. quark1parttype.ne.-quarks(4)%PartType ) print *,"wrong flavor in cur_f_4f (2)"
1424 !DEC$ ENDIF
1425 
1426  res(:)=(0d0,0d0)
1427 
1428  tag_z=0
1429  if( present(tag_z_arg) ) then
1430  tag_z=tag_z_arg
1431  endif
1432 
1433  if( quark1parttype.eq.-quarks(2)%PartType .and. quarks(3)%PartType.eq.-quarks(4)%PartType ) then
1434 ! (I)
1435  do n2a=0,numglu(2)
1436  do n4a=0,numglu(4)
1437  n2b = numglu(2)-n2a
1438  n4b = numglu(4)-n4a
1439 
1440  rin =numglu(1)+n2a+1
1441  rout=numglu(1)+numglu(2)+numglu(3)+n4a
1442  eps2 = cur_g_2f(gluons(rin:rout),quarks(3:4),(/1+n2b+numglu(3)+n4a,n2b,numglu(3),n4a/))
1443  pmom1(:) = summom(gluons,rin,rout) + quarks(3)%Mom + quarks(4)%Mom
1444  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
1445  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
1446  eps2 = eps2*propfac1
1447  do n1a=0,numglu(1)
1448  n1b = numglu(1)-n1a
1449  ! Fer2
1450  rin =n1a+1
1451  rout=numglu(1)+n2a
1452  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/n2a+n1b,n1b,n2a/) )
1453  if(n1b.ge.1 .or. n2a.ge.1) then
1454  pmom2(:) = quarks(2)%Mom + summom(gluons,rin,rout) ! can be moved outside the n1a-loop
1455  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
1456  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) cycle
1457  if( quarks(2)%PartType.lt.0 ) then
1458  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(2)%Mass*ubar1(:))*propfac2
1459  else
1460  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(2)%Mass*ubar1(:))*propfac2
1461  endif
1462  endif
1463  if( quarks(2)%PartType.lt.0 ) then
1464  ubar0(:) = vbqg(ubar1,eps2) ! re-checked
1465  else
1466  ubar0(:) = vqg(ubar1,eps2) ! re-checked
1467  endif
1468 
1469  pmom1 = quarks(2)%Mom+quarks(3)%Mom+quarks(4)%Mom+summom(gluons,n1a+1,numglu(1)+numglu(2)+numglu(3)+n4a)
1470  if(n1a.ge.1 .or. n4b.ge.1) then
1471  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(2)%Mass2)
1472  if( abs(sc_(pmom1,pmom1)-quarks(2)%Mass2).lt.propcut ) cycle
1473  if( quarks(2)%PartType.lt.0 ) then
1474  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(2)%Mass*ubar0(:))*propfac1
1475  else
1476  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(2)%Mass*ubar0(:))*propfac1
1477  endif
1478  endif
1479 
1480  tmpquark(1)%Mom => pmom1(:)
1481  tmpquark(1)%Pol => ubar0(:)
1482  tmpquark(1)%Mass => quarks(2)%Mass
1483  tmpquark(1)%Mass2=> quarks(2)%Mass2
1484  tmpextref = -1
1485  tmpquark(1)%ExtRef => tmpextref
1486  tmpquark(1)%PartType => quarks(2)%PartType
1487  counter=1
1488  rin =1
1489  rout=n1a
1490  do i=rin,rout
1491  call copyparticleptr(gluons(i),tmpgluons(counter))
1492  counter=counter+1
1493  enddo
1494  rin =numglu(1)+numglu(2)+numglu(3)+n4a+1
1495  rout=numglu(0)
1496  do i=rin,rout
1497  call copyparticleptr(gluons(i),tmpgluons(counter))
1498  counter=counter+1
1499  enddo
1500  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n4b/) )
1501  res(:) = res(:) + tmp(:)
1502  enddo
1503  enddo
1504  enddo
1505  endif
1506 
1507 
1508 ! if( (Quark1PartType.eq.-Quarks(4)%PartType .and. Quarks(2)%PartType.eq.-Quarks(3)%PartType) .AND. &
1509 ! ((abs(Quark1PartType).ne.abs(Quarks(2)%PartType).and.(tag_f.ne.3)) .or. &
1510 ! (abs(Quark1PartType).eq.abs(Quarks(2)%PartType).and.(tag_f.ne.1.and.tag_f.ne.3))) ) then
1511 ! if( (Quark1PartType.eq.-Quarks(4)%PartType .and. Quarks(2)%PartType.eq.-Quarks(3)%PartType) .AND. &
1512 ! .not.(Quarks(4)%ExtRef.eq.-1 .and. tag_f.eq.1 .and. abs(Quark1PartType).eq.(Quarks(2)%PartType)) ) then
1513  if( (quark1parttype.eq.-quarks(4)%PartType .and. quarks(2)%PartType.eq.-quarks(3)%PartType) .AND. &
1514  (quarks(4)%ExtRef.ne.-1 .or. tag_f.ne.1 .or. abs(quark1parttype).ne.abs(quarks(2)%PartType)) &
1515  ) then
1516 ! (II)
1517  do n1a=0,numglu(1)
1518  do n3b=0,numglu(3)
1519  n1b = numglu(1)-n1a
1520  n3a = numglu(3)-n3b
1521  rin =n1a+1
1522  rout=numglu(1)+numglu(2)+n3a
1523 
1524 
1525 ! This prevents color issues with a Z on the quark loop, see RR notes
1526  if ( tag_z .eq. 1 .and. (n1b+numglu(2)+n3a .eq. numglu(0)) .and. quarks(4)%ExtRef .eq. -1) then
1527 ! print * , "cycle for tag_Z=1 in cur_f_4f",n1a,n1b
1528  cycle
1529  endif
1530 
1531 
1532 
1533 
1534  eps2 = cur_g_2f(gluons(rin:rout),quarks(2:3),(/1+n1b+numglu(2)+n3a,n1b,numglu(2),n3a/))
1535  pmom1(:) = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
1536  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
1537  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
1538  eps2 = eps2*propfac1
1539 
1540  do n4a=0,numglu(4)
1541  n4b = numglu(4)-n4a
1542  ! Fer4
1543  rin =numglu(1)+numglu(2)+n3a+1
1544  rout=numglu(1)+numglu(2)+numglu(3)+n4a
1545  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,(/numglu(3)+n4a-n3a,n3b,n4a/) )
1546  if(n3b.ge.1 .or. n4a.ge.1) then
1547  pmom2(:) = quarks(4)%Mom + summom(gluons,rin,rout)
1548  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(4)%Mass2)
1549  if( abs(sc_(pmom2,pmom2)-quarks(4)%Mass2).lt.propcut ) cycle
1550  if( quarks(4)%PartType.lt.0 ) then
1551  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(4)%Mass*ubar1(:))*propfac2
1552  else
1553  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(4)%Mass*ubar1(:))*propfac2
1554  endif
1555  endif
1556  if( quarks(4)%PartType.lt.0 ) then
1557  ubar0(:) = vgbq(eps2,ubar1) !! changed from vqg(ubar1,eps2) ! re-checked
1558  else
1559  ubar0(:) = vgq(eps2,ubar1) !! changed from vbqg(ubar1,eps2) ! re-checked
1560  endif
1561 
1562  pmom1 = quarks(2)%Mom+quarks(3)%Mom+quarks(4)%Mom+summom(gluons,n1a+1,numglu(1)+numglu(2)+numglu(3)+n4a)
1563  if(n1a.ge.1 .or. n4b.ge.1) then
1564  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(4)%Mass2)
1565  if( abs(sc_(pmom1,pmom1)-quarks(4)%Mass2).lt.propcut ) cycle
1566  if( quarks(4)%PartType.lt.0 ) then
1567  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(4)%Mass*ubar0(:))*propfac1
1568  else
1569  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(4)%Mass*ubar0(:))*propfac1
1570  endif
1571  endif
1572  tmpquark(1)%Mom => pmom1(:)
1573  tmpquark(1)%Pol => ubar0(:)
1574  tmpquark(1)%Mass => quarks(4)%Mass
1575  tmpquark(1)%Mass2=> quarks(4)%Mass2
1576  tmpextref = -1
1577  tmpquark(1)%ExtRef => tmpextref
1578  tmpquark(1)%PartType => quarks(4)%PartType
1579  counter=1
1580  rin =1
1581  rout=n1a
1582  do i=rin,rout
1583  call copyparticleptr(gluons(i),tmpgluons(counter))
1584  counter=counter+1
1585  enddo
1586  rin =numglu(1)+numglu(2)+numglu(3)+n4a+1
1587  rout=numglu(0)
1588  do i=rin,rout
1589  call copyparticleptr(gluons(i),tmpgluons(counter))
1590  counter=counter+1
1591  enddo
1592  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n4b/) )
1593  res(:) = res(:) + tmp(:)
1594  enddo
1595  enddo
1596  enddo
1597  endif
1598 return
1599 END FUNCTION
1600 
1601 
1602 
1603 
1604  recursive function g(e,k) result(res)
1605  implicit none
1606  complex(8), intent(in) :: e(:,:),k(:,:)
1607  complex(8) :: e1(size(e,dim=1))
1608  complex(8) :: res(size(e,dim=1))
1609  complex(8) :: k1(size(e,dim=1))
1610  complex(8) :: k2(size(e,dim=1))
1611  complex(8) :: k3(size(e,dim=1))
1612  complex(8) :: e2(size(e,dim=1))
1613  complex(8) :: e3(size(e,dim=1))
1614  complex(8) :: tmp(size(e,dim=1))
1615  complex(8) :: k1sq, k2sq, k3sq
1616  integer :: npart, m, m1
1617 
1618  npart = size(e,dim=2)
1619 
1620  if (npart == 1) then
1621  res = e(:,1)
1622 
1623  elseif (npart == 2) then
1624  res = vggg(e(:,1),k(:,1),e(:,2),k(:,2))
1625  else
1626 
1627  res = (0d0,0d0)
1628 
1629  do m=1,npart-1
1630  k1=sum(k(:,1:m),dim=2)
1631  k2=sum(k(:,m+1:npart),dim=2)
1632 
1633  e1 = g(e(:,1:m),k(:,1:m))
1634  e2 = g(e(:,m+1:npart),k(:,m+1:npart))
1635 
1636  tmp = vggg(e1,k1,e2,k2)
1637 
1638  if (m > 1) then
1639  k1sq = sc_(k1,k1)
1640  if (abs(k1sq) > propcut) then
1641  tmp = -(0d0,1d0)*tmp/k1sq
1642  else
1643  tmp = (0d0,0d0)
1644  endif
1645  endif
1646 
1647  if (m + 1 < npart) then
1648  k2sq = sc_(k2,k2)
1649  if (abs(k2sq) > propcut) then
1650  tmp = -(0d0,1d0)*tmp/k2sq
1651  else
1652  tmp = (0d0,0d0)
1653  endif
1654  endif
1655 
1656  res = res + tmp
1657 
1658  if (m <= npart-2) then
1659 
1660  do m1=m+1,npart-1
1661 ! e1 = g(e(:,1:m),k(:,1:m)) ! e1 is already computed
1662  e2=g(e(:,m+1:m1),k(:,m+1:m1))
1663  e3=g(e(:,m1+1:npart),k(:,m1+1:npart))
1664  k2 = sum(k(:,m+1:m1),dim=2)
1665  k3 = sum(k(:,m1+1:npart),dim=2)
1666  tmp = vgggg(e1,e2,e3)
1667  if (m > 1) then
1668  k1sq = sc_(k1,k1)
1669  if(abs(k1sq) > propcut) then
1670  tmp = -(0d0,1d0)*tmp/k1sq
1671  else
1672  tmp = (0d0,0d0)
1673  endif
1674  endif
1675  if (m+1 < m1) then
1676  k2sq = sc_(k2,k2)
1677  if(abs(k2sq) > propcut) then
1678  tmp = -(0d0,1d0)*tmp/k2sq
1679  else
1680  tmp = (0d0,0d0)
1681  endif
1682  endif
1683  if (m1+1 < npart) then
1684  k3sq = sc_(k3,k3)
1685  if(abs(k3sq) > propcut) then
1686  tmp = -(0d0,1d0)*tmp/k3sq
1687  else
1688  tmp = (0d0,0d0)
1689  endif
1690  endif
1691  res = res + tmp
1692  enddo
1693 
1694  endif
1695  enddo
1696  endif
1697 
1698  end function
1699 
1700 
1701 
1702 
1703 
1704 FUNCTION cur_g(Gluons,NumGlu)! note the off-shell gluon has be counted in NumGlu
1705 implicit none
1706 type(ptrtoparticle) :: gluons(1:)
1707 complex(8) :: cur_g(1:dv)
1708 integer :: ngluons,numglu
1709 complex(8) :: glu_subcur(1:dv,1:36) ! max. 8 gluons allowed
1710 complex(8) :: mom_sum(1:dv,1:36), propfactor,propdenom
1711 integer :: ind0,ind1,ind2,ind3,j,l,mu
1712 integer :: a,b,i1,i2
1713 
1714 !DEC$ IF (_DebugWriteCurrents==1)
1715 character :: parts(20)*4
1716 integer :: parti(20)
1717 
1718  do i1=1,numglu-1
1719  if( gluons(i1)%ExtRef.eq.-1 ) then
1720  exit
1721  else
1722  parti(i1)=gluons(i1)%ExtRef
1723  endif
1724  if(i1.eq.numglu-1) print *, parti(1:numglu-1)
1725 ! write (parts(1:20), '(I20)') parti(1:NumGlu-1)
1726  enddo
1727 !DEC$ ENDIF
1728 
1729  ngluons = numglu-1
1730 
1731  do a=0,ngluons-1
1732  do b=1,ngluons-a
1733 
1734  i1 = b
1735  i2 = a+b
1736  ind0 = linear_map(i1,i2,ngluons)
1737 
1738  if (i1.eq.i2) then
1739  glu_subcur(1:dv,ind0) = gluons(i1)%Pol(1:dv)
1740  mom_sum(1:dv,ind0) = gluons(i1)%Mom(1:dv)
1741  else
1742  mom_sum(1:dv,ind0) = mom_sum(1:dv,ind0-ngluons+i2-i1-1) + gluons(i2)%Mom(1:dv)
1743  if ( i1 .ne. 1 .or. i2 .ne. ngluons ) then
1744  propdenom = mom_sum(1:dv,ind0).ndot.mom_sum(1:dv,ind0)
1745  if( abs(propdenom).lt.propcut ) cycle
1746  propfactor = (0d0,-1d0)/propdenom
1747  else
1748  propfactor = 1d0
1749  endif
1750  do mu=1,dv
1751  glu_subcur(mu,ind0) = 0d0
1752  enddo
1753  do j=i1,i2-1
1754  ind1 = linear_map(i1,j,ngluons)
1755  ind2 = linear_map(j+1,i2,ngluons)
1756  glu_subcur(1:dv,ind0) = glu_subcur(1:dv,ind0) + &
1757  eval_tripvert( mom_sum(1:dv,ind1),mom_sum(1:dv,ind2), &
1758  glu_subcur(1:dv,ind1),glu_subcur(1:dv,ind2)) * propfactor
1759  enddo
1760  do j=i1,i2-2
1761  do l=j+1,i2-1
1762  ind1 = linear_map(i1,j,ngluons)
1763  ind2 = linear_map(j+1,l,ngluons)
1764  ind3 = linear_map(l+1,i2,ngluons)
1765  glu_subcur(1:dv,ind0) = glu_subcur(1:dv,ind0) + &
1766  eval_quadvert( &
1767  glu_subcur(1:dv,ind1),glu_subcur(1:dv,ind2),glu_subcur(1:dv,ind3)) * propfactor
1768  enddo
1769  enddo
1770  endif
1771  enddo
1772  enddo
1773  cur_g(1:dv) = glu_subcur(1:dv,ind0)
1774 
1775 return
1776 END FUNCTION
1777 
1778 
1779 
1780 
1781 
1782  recursive function f(e,k,sp,p,mass,flout,flin,ms) result(res)
1783  implicit none
1784  complex(8), intent(in) :: e(:,:), k(:,:)
1785  complex(8), intent(in) :: sp(:), p(:)
1786  character, intent(in) :: flin*3 ! flavor of off-shell f-line
1787  character, intent(in) :: flout*3 ! flavor of on-shell f-line
1788  integer, intent(in) :: ms
1789  integer :: ms1,m,ng1, ng2
1790  integer :: ngluon
1791  complex(8) :: res(size(sp))
1792  complex(8) :: tmp(size(sp))
1793  complex(8) :: k1(size(p))
1794  complex(8) :: k2(size(p))
1795  complex(8) :: sp2(size(sp))
1796  complex(8) :: sp3(size(sp))
1797  complex(8) :: e1(size(e,dim=1))
1798  complex(8) :: e2(size(e,dim=1))
1799  complex(8) :: k1sq,k2sq,k3sq
1800  real(8) :: mass
1801 
1802  ngluon = size(e,dim=2)
1803  ng1 = ms !#gluons to the left of a f-line
1804  ng2 = ngluon - ms !#gluons to the right of the f-line
1805 
1806  if (flout.ne.flin) then
1807  res = (0d0,0d0)
1808  else
1809 
1810  if (ng2 < 0) write(*,*) 'WRONG DEFINITION OF CURRENT A'
1811 
1812  if (ngluon == 0) then
1813  res = sp
1814 
1815  else
1816 
1817  res = (0d0,0d0)
1818  do m=0,ng2-1
1819  k1 = sum(k(:,ng1+1+m:ngluon),dim=2)
1820  e1=g(e(:,ng1+1+m:ngluon),k(:,ng1+1+m:ngluon))
1821  k1sq=sc_(k1,k1)
1822 
1823  k2 = sum(k(:,1:ng1+m),dim=2)
1824  k2 = k2 + p
1825  k2sq = sc_(k2,k2)-mass**2
1826  sp2 = f(e(:,1:ng1+m),k(:,1:ng1+m),sp,p,mass,flout,flin,ng1)
1827  if (ng1 >0.or.m>0) sp2 = spb2_(sp2,k2)+mass*sp2
1828  tmp = vqg(sp2,e1)
1829 
1830 ! print *, m,e1
1831 ! pause
1832  if (m < ng2-1) then
1833  if(abs(k1sq) > propcut) then
1834  tmp = -(0d0,1d0)/k1sq*tmp
1835  else
1836  tmp = (0d0,0d0)
1837  endif
1838  endif
1839 
1840  if (ng1>0.or.m>0) then
1841  if (abs(k2sq) > propcut) then
1842  tmp = (0d0,1d0)/k2sq*tmp
1843  else
1844  tmp = (0d0,0d0)
1845  endif
1846  endif
1847  res = res + tmp
1848 
1849  enddo
1850 
1851  do m=1,ng1
1852 
1853  k1 = sum(k(:,1:m),dim=2)
1854  e1=g(e(:,1:m),k(:,1:m))
1855  k1sq = sc_(k1,k1)
1856 
1857  k2 = sum(k(:,m+1:ngluon),dim=2)
1858  k2 = k2 + p
1859  k2sq = sc_(k2,k2) - mass**2
1860  ms1 = ng1 - m
1861  sp2=f(e(:,m+1:ngluon),k(:,m+1:ngluon),sp,p,mass,flout,flin,ms1)
1862 
1863  if (ng2 > 0.or.m < ng1) sp2 = spb2_(sp2,k2)+mass*sp2
1864  tmp = vgq(e1,sp2)
1865  if (m > 1) then
1866  if (abs(k1sq) > propcut) then
1867  tmp=-(0d0,1d0)/k1sq*tmp
1868  else
1869  tmp = (0d0,0d0)
1870  endif
1871  endif
1872 
1873  if (ng2 > 0.or. m < ng1) then
1874  if (abs(k2sq) > propcut) then
1875  tmp=(0d0,1d0)/k2sq*tmp
1876  else
1877  tmp = (0d0,0d0)
1878  endif
1879  endif
1880 
1881  res = res + tmp
1882  enddo
1883 
1884  endif
1885  endif ! endif for flavor consistency condition
1886 
1887  end function f
1888 
1889 
1890 
1891  recursive function bf(e,k,sp,p,mass,flout,flin,ms) result(res)
1892  implicit none
1893  complex(8), intent(in) :: e(:,:), k(:,:)
1894  complex(8), intent(in) :: sp(:), p(:)
1895  integer, intent(in) :: ms
1896  character, intent(in) :: flout*3 ! flavor of on-shell f-line
1897  character, intent(in) :: flin*3 ! flavor of off-shell f-line
1898  integer :: ms1,m,ng1, ng2
1899  integer :: ngluon
1900  complex(8) :: res(size(sp))
1901  complex(8) :: tmp(size(sp))
1902  complex(8) :: k1(size(p))
1903  complex(8) :: k2(size(p))
1904  complex(8) :: sp2(size(sp))
1905  complex(8) :: sp3(size(sp))
1906  complex(8) :: e1(size(e,dim=1))
1907  complex(8) :: e2(size(e,dim=1))
1908  complex(8) :: k1sq,k2sq,k3sq
1909  real(8) :: mass
1910 
1911 
1912  if (flout.ne.flin) then
1913  res = (0d0,0d0)
1914  else
1915 
1916  ngluon = size(e,dim=2)
1917  ng1 = ms !#gluons to the left of a f-line
1918  ng2 = ngluon - ms !#gluons to the right of the f-line
1919 
1920  if (ng2 < 0) write(*,*) 'WRONG DEFINITION OF CURRENT B'
1921  if (ngluon == 0) then
1922  res = sp
1923  else
1924 
1925  res = (0d0,0d0)
1926  do m=0,ng2-1
1927  k1 = sum(k(:,ng1+1+m:ngluon),dim=2)
1928  e1=g(e(:,ng1+1+m:ngluon),k(:,ng1+1+m:ngluon))
1929  k1sq=sc_(k1,k1)
1930 
1931  k2 = sum(k(:,1:ng1+m),dim=2)
1932  k2 = -k2 - p
1933  k2sq = sc_(k2,k2)-mass**2
1934  sp2 = bf(e(:,1:ng1+m),k(:,1:ng1+m),sp,p,mass,flout,flin,ng1)
1935  if (ng1>0.or.m>0) sp2 = spi2_(k2,sp2)+mass*sp2
1936 
1937  tmp = vbqg(sp2,e1)
1938 
1939  if (m < ng2-1) then
1940  if (abs(k1sq) > propcut) then
1941  tmp = -(0d0,1d0)/k1sq*tmp
1942  else
1943  tmp = (0d0,0d0)
1944  endif
1945  endif
1946  if (ng1>0.or.m>0) then
1947  if (abs(k2sq) > propcut) then
1948  tmp = (0d0,1d0)/k2sq*tmp
1949  else
1950  tmp = (0d0,0d0)
1951  endif
1952  endif
1953 
1954  res = res + tmp
1955 
1956 
1957  enddo
1958 
1959 
1960  do m=1,ng1
1961 
1962  k1 = sum(k(:,1:m),dim=2)
1963  e1=g(e(:,1:m),k(:,1:m))
1964  k1sq = sc_(k1,k1)
1965 
1966  k2 = sum(k(:,m+1:ngluon),dim=2)
1967  k2 = -k2 - p
1968  k2sq = sc_(k2,k2) - mass**2
1969  ms1 = ng1 - m
1970  sp2=bf(e(:,m+1:ngluon),k(:,m+1:ngluon),sp,p,mass,flout,flin,ms1)
1971 
1972  if (ng2 > 0.or.m < ng1) sp2 = spi2_(k2,sp2)+mass*sp2
1973 
1974  tmp = vgbq(e1,sp2)
1975 
1976  if (m > 1) then
1977  if (abs(k1sq) > propcut) then
1978  tmp=-(0d0,1d0)/k1sq*tmp
1979  else
1980  tmp = (0d0,0d0)
1981  endif
1982  endif
1983 
1984  if (ng2 > 0.or. m < ng1) then
1985  if (abs(k2sq) > propcut) then
1986  tmp=(0d0,1d0)/k2sq*tmp
1987  else
1988  tmp = (0d0,0d0)
1989  endif
1990  endif
1991 
1992  res = res + tmp
1993 
1994  enddo
1995 
1996  endif
1997  endif ! endif for flavor consisency condition
1998  end function bf
1999 
2000 
2001 
2002 
2003 
2004 
2005 FUNCTION cur_g_2f(Gluons,Quarks,NumGlu) result(Res) ! Gluons(:) does not include the OFF-shell gluon, however NumGlu(0) is the number of all gluons
2006 implicit none
2007 integer :: numglu(0:3),i,counter
2008 type(ptrtoparticle) :: gluons(1:),quarks(1:2)
2009 integer :: rin,rout,n1a,n1b,n2a,n2b,n3a,n3b
2010 integer,target :: tmpextref
2011 complex(8) :: res(1:dv)
2012 complex(8) :: u1(1:ds),ubar2(1:ds)
2013 complex(8),target :: eps1(1:dv)
2014 complex(8) :: eps2(1:dv)
2015 type(ptrtoparticle) :: tmpgluons(1:numglu(1)+numglu(3)+1)
2016 complex(8) :: pmom1(1:dv),pmom2(1:dv),pmom4(1:dv)
2017 complex(8),target :: pmom3(1:dv)
2018 complex(8) :: propfac1,propfac2,propfac3,propfac4
2019 integer :: partkey,helkey,currkey,hel_tmp
2020 
2021 
2022 
2023 
2024  res = (0d0,0d0)
2025  if( quarks(1)%PartType .ne. -quarks(2)%PartType ) return
2026  do n1a=0,numglu(1)
2027  do n3a=0,numglu(3)
2028  do n2a=0,numglu(2)
2029  n1b=numglu(1)-n1a
2030  n2b=numglu(2)-n2a
2031  n3b=numglu(3)-n3a
2032  ! Fer1
2033  rin=n1a+1
2034  rout=numglu(1)+n2a
2035  pmom1(:) = quarks(1)%Mom(:)+ summom(gluons,rin,rout)
2036  u1(:) = cur_f_2f(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,(/n1b+n2a,n1b,n2a/))
2037  if(n1b.ge.1 .or. n2a.ge.1) then
2038  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(1)%Mass2)
2039  if( abs(sc_(pmom1,pmom1)-quarks(1)%Mass2).lt.propcut ) cycle
2040  if( quarks(1)%PartType.lt.0 ) then
2041  u1(:) = (-spi2_(pmom1,u1)+quarks(1)%Mass*u1(:) )*propfac1
2042  else
2043  u1(:) = (+spb2_(u1,pmom1)+quarks(1)%Mass*u1(:) )*propfac1
2044  endif
2045  endif
2046 
2047  ! Fer2
2048  rin=numglu(1)+n2a+1
2049  rout=numglu(1)+numglu(2)+n3a
2050  pmom2(:) = quarks(2)%Mom(:)+ summom(gluons,rin,rout)
2051  ubar2(:) = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/n2b+n3a,n2b,n3a/))
2052  if(n2b.ge.1 .or. n3a.ge.1) then
2053  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
2054  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) cycle
2055  if( quarks(2)%PartType.lt.0 ) then
2056  ubar2(:) = (-spi2_(pmom2,ubar2)+quarks(2)%Mass*ubar2(:) )*propfac2
2057  else
2058  ubar2(:) = (+spb2_(ubar2,pmom2)+quarks(2)%Mass*ubar2(:) )*propfac2
2059  endif
2060  endif
2061 
2062  if( quarks(1)%PartType.lt.0 ) then
2063  eps1(:)= -vbqq(dv,ubar2,u1) ! re-checked
2064  else
2065  eps1(:)= +vbqq(dv,u1,ubar2) ! re-checked
2066  endif
2067  pmom3(:) = quarks(1)%Mom(:)+quarks(2)%Mom(:) + summom(gluons,n1a+1,numglu(1)+numglu(2)+n3a)
2068  counter=1
2069  rin =1
2070  rout=n1a
2071  do i=rin,rout
2072  call copyparticleptr(gluons(i),tmpgluons(counter))
2073  counter=counter+1
2074  enddo
2075  tmpgluons(counter)%Mom => pmom3(:)
2076  tmpgluons(counter)%Pol => eps1(:)
2077  tmpextref = -1
2078  tmpgluons(counter)%ExtRef => tmpextref
2079  counter=counter+1
2080  rin =numglu(1)+numglu(2)+n3a+1
2081  rout=numglu(1)+numglu(2)+numglu(3)
2082  do i=rin,rout
2083  call copyparticleptr(gluons(i),tmpgluons(counter))
2084  counter=counter+1
2085  enddo
2086  eps2(:) = cur_g(tmpgluons(1:counter-1),1+n1a+n3b+1)
2087 
2088 
2089  if(n1a.ge.1 .or. n3b.ge.1) then
2090  propfac3 = (0d0,-1d0)/sc_(pmom3,pmom3)
2091  if( abs(sc_(pmom3,pmom3)).lt.propcut ) cycle
2092  eps2(:) = eps2(:)*propfac3
2093  endif
2094 
2095  res(:) = res(:) + eps2(:)
2096  enddo
2097  enddo
2098  enddo
2099 
2100 
2101 
2102 return
2103 END FUNCTION
2104 
2105 
2106 
2107 
2108 
2109 FUNCTION cur_g_2fv(Gluons,Quarks,Boson,NumGlu) result(Res) ! Gluons(:) does not include the OFF-shell gluon, however NumGlu(0) is the number of all gluons
2110 implicit none
2111 integer :: numglu(0:3),i,counter
2112 type(ptrtoparticle) :: gluons(1:),quarks(1:2),boson
2113 integer :: rin,rout,n1a,n1b,n2a,n2b,n3a,n3b
2114 integer,target :: tmpextref
2115 complex(8) :: res(1:dv)
2116 complex(8) :: u1(1:ds),ubar2(1:ds)
2117 complex(8),target :: eps1(1:dv)
2118 complex(8) :: eps2(1:dv)
2119 type(ptrtoparticle) :: tmpgluons(1:numglu(1)+numglu(3)+1)
2120 complex(8) :: pmom1(1:dv),pmom2(1:dv),pmom4(1:dv)
2121 complex(8),target :: pmom3(1:dv)
2122 complex(8) :: propfac1,propfac2,propfac3,propfac4
2123 integer :: partkey,helkey,currkey,hel_tmp
2124 
2125 
2126 
2127 
2128 !DEC$ IF (_DebugCheckMyImpl1==1)
2129  if(quarks(1)%PartType*quarks(2)%PartType.ge.0) print *,"Error in cur_g_2f: wrong PartTypes"
2130 !DEC$ ENDIF
2131 !DEC$ IF (_DebugCheckMyImpl1==1)
2132  if( numglu(0)-1-numglu(1)-numglu(2)-numglu(3).ne.0 ) print *, "wrong number of gluons in cur_g_2f"
2133 !DEC$ ENDIF
2134 
2135  res = (0d0,0d0)
2136  if( quarks(1)%PartType .ne. -quarks(2)%PartType ) return
2137  do n1a=0,numglu(1)
2138  do n3a=0,numglu(3)
2139  do n2a=0,numglu(2)
2140  n1b=numglu(1)-n1a
2141  n2b=numglu(2)-n2a
2142  n3b=numglu(3)-n3a
2143 
2144  ! Fer1 and V coupling
2145  rin=n1a+1
2146  rout=numglu(1)+n2a
2147  pmom1(:) = quarks(1)%Mom(:) + summom(gluons,rin,rout) + boson%Mom(:)
2148  u1(:) = cur_f_2fv(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,boson,(/n1b+n2a,n1b,n2a/))
2149  !if(n1b.ge.1 .or. n2a.ge.1) then
2150  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(1)%Mass2)
2151  if( abs(sc_(pmom1,pmom1)-quarks(1)%Mass2).lt.propcut ) then
2152  propfac1=(0d0,0d0)
2153  endif
2154  if( quarks(1)%PartType.lt.0 ) then
2155  u1(:) = (-spi2_(pmom1,u1)+quarks(1)%Mass*u1(:) )*propfac1
2156  else
2157  u1(:) = (+spb2_(u1,pmom1)+quarks(1)%Mass*u1(:) )*propfac1
2158  endif
2159  !endif
2160 
2161  ! Fer2
2162  rin=numglu(1)+n2a+1
2163  rout=numglu(1)+numglu(2)+n3a
2164  pmom2(:) = quarks(2)%Mom(:)+ summom(gluons,rin,rout)
2165  ubar2(:) = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/n2b+n3a,n2b,n3a/))
2166  if(n2b.ge.1 .or. n3a.ge.1) then
2167  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
2168  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) then
2169  propfac2=(0d0,0d0)
2170  endif
2171  if( quarks(2)%PartType.lt.0 ) then
2172  ubar2(:) = (-spi2_(pmom2,ubar2)+quarks(2)%Mass*ubar2(:) )*propfac2
2173  else
2174  ubar2(:) = (+spb2_(ubar2,pmom2)+quarks(2)%Mass*ubar2(:) )*propfac2
2175  endif
2176  endif
2177 
2178 
2179  if( quarks(1)%PartType.lt.0 ) then
2180  eps1(:)= -vbqq(dv,ubar2,u1)
2181  else
2182  eps1(:)= +vbqq(dv,u1,ubar2)
2183  endif
2184 
2185 
2186 
2187 
2188 
2189  ! Fer1
2190  rin=n1a+1
2191  rout=numglu(1)+n2a
2192  pmom1(:) = quarks(1)%Mom(:) + summom(gluons,rin,rout)
2193  u1(:) = cur_f_2f(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,(/n1b+n2a,n1b,n2a/))
2194  if(n1b.ge.1 .or. n2a.ge.1) then
2195  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(1)%Mass2)
2196  if( abs(sc_(pmom1,pmom1)-quarks(1)%Mass2).lt.propcut ) cycle
2197  if( quarks(1)%PartType.lt.0 ) then
2198  u1(:) = (-spi2_(pmom1,u1)+quarks(1)%Mass*u1(:) )*propfac1
2199  else
2200  u1(:) = (+spb2_(u1,pmom1)+quarks(1)%Mass*u1(:) )*propfac1
2201  endif
2202  endif
2203 
2204  ! Fer2 and V coupling
2205  rin=numglu(1)+n2a+1
2206  rout=numglu(1)+numglu(2)+n3a
2207  pmom2(:) = quarks(2)%Mom(:)+ summom(gluons,rin,rout) + boson%Mom(:)
2208  ubar2(:) = cur_f_2fv(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,boson,(/n2b+n3a,n2b,n3a/))
2209  !if(n2b.ge.1 .or. n3a.ge.1) then
2210  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
2211  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) cycle
2212  if( quarks(2)%PartType.lt.0 ) then
2213  ubar2(:) = (-spi2_(pmom2,ubar2)+quarks(2)%Mass*ubar2(:) )*propfac2
2214  else
2215  ubar2(:) = (+spb2_(ubar2,pmom2)+quarks(2)%Mass*ubar2(:) )*propfac2
2216  endif
2217  !endif
2218 
2219  if( quarks(1)%PartType.lt.0 ) then
2220  eps1(:)= eps1(:) - vbqq(dv,ubar2,u1)
2221  else
2222  eps1(:)= eps1(:) + vbqq(dv,u1,ubar2)
2223  endif
2224 !
2225 
2226  pmom3(:) = quarks(1)%Mom(:)+quarks(2)%Mom(:) + summom(gluons,n1a+1,numglu(1)+numglu(2)+n3a) + boson%Mom(:)
2227  counter=1
2228  rin =1
2229  rout=n1a
2230  do i=rin,rout
2231  call copyparticleptr(gluons(i),tmpgluons(counter))
2232  counter=counter+1
2233  enddo
2234  tmpgluons(counter)%Mom => pmom3(:)
2235  tmpgluons(counter)%Pol => eps1(:)
2236  tmpextref = -1
2237  tmpgluons(counter)%ExtRef => tmpextref
2238  counter=counter+1
2239  rin =numglu(1)+numglu(2)+n3a+1
2240  rout=numglu(1)+numglu(2)+numglu(3)
2241  do i=rin,rout
2242  call copyparticleptr(gluons(i),tmpgluons(counter))
2243  counter=counter+1
2244  enddo
2245  eps2(:) = cur_g(tmpgluons(1:counter-1),1+n1a+n3b+1)
2246 
2247 
2248  if(n1a.ge.1 .or. n3b.ge.1) then
2249  propfac3 = (0d0,-1d0)/sc_(pmom3,pmom3)
2250  if( abs(sc_(pmom3,pmom3)).lt.propcut ) cycle
2251  eps2(:) = eps2(:)*propfac3
2252  endif
2253 
2254  res(:) = res(:) + eps2(:)
2255 
2256  enddo
2257  enddo
2258  enddo
2259 
2260 
2261 
2262 return
2263 END FUNCTION
2264 
2265 
2266 
2267 
2268 
2269 
2270 
2271 
2272 FUNCTION cur_f_2f(Gluons,Quarks,Quark1PartType,NumGlu) result(Res) ! Quarks(:) does not include the OFF-shell quark
2273 implicit none
2274 complex(8) :: res(1:ds)
2275 integer :: numglu(0:2),i,rin,rout,quark1parttype
2276 type(ptrtoparticle) :: gluons(1:),quarks(2:2) ! off-shell quark is not included in Quarks(:)
2277 complex(8) :: glumom(1:dv,numglu(0)), quarkmom(1:dv)
2278 complex(8) :: glupol(1:dv,numglu(0)), quarkpol(1:ds)
2279 character :: ferfla1*3,ferfla2*3
2280 integer :: partkey,helkey,currkey,hel_tmp
2281 
2282 
2283 
2284 
2285 
2286 
2287 !DEC$ IF (_DebugGeneralChecks==1)
2288  if( quarks(2)%PartType .eq.0 .or. .not.isaquark(quarks(2)%PartType)) then
2289  print *, "Error in cur_f_2f"
2290  stop
2291  endif
2292 !DEC$ ENDIF
2293 !DEC$ IF (_DebugCheckMyImpl1==1)
2294  if( numglu(0)-numglu(1)-numglu(2).ne.0 ) print *, "wrong number of gluons in cur_f_2f"
2295  if( quarks(2)%PartType.ne.-quark1parttype ) print *, "unequal flavors in cur_f_2f"
2296 !DEC$ ENDIF
2297 
2298 
2299  do i=1,numglu(0)
2300  glumom(1:dv,i) = gluons(i)%Mom(1:dv)
2301  glupol(1:dv,i) = gluons(i)%Pol(1:dv)
2302  enddo
2303  quarkmom(1:dv) = quarks(2)%Mom(1:dv)
2304  quarkpol(1:ds) = quarks(2)%Pol(1:ds)
2305 
2306  if( abs(quark1parttype).eq.5 ) then
2307  ferfla1="top"
2308  elseif( abs(quark1parttype).eq.6 ) then
2309  ferfla1="bot"
2310  elseif( abs(quark1parttype).eq.3 ) then
2311  ferfla1="chm"
2312  else
2313  ferfla1="str"
2314  endif
2315 
2316  if( abs(quarks(2)%PartType).eq.5 ) then
2317  ferfla2="top"
2318  elseif( abs(quarks(2)%PartType).eq.6 ) then
2319  ferfla2="bot"
2320  elseif( abs(quarks(2)%PartType).eq.3 ) then
2321  ferfla2="chm"
2322  else
2323  ferfla2="str"
2324  endif
2325 
2326  rin =1
2327  rout=numglu(0)
2328  if( quarks(2)%PartType .gt.0 ) then ! X----->----
2329  res(:) = f(glupol(1:dv,rin:rout),glumom(1:dv,rin:rout),quarkpol(1:ds),quarkmom(1:dv),quarks(2)%Mass,ferfla2,ferfla1,numglu(1))
2330  else ! X-----<----
2331  res(:) = bf(glupol(1:dv,rin:rout),glumom(1:dv,rin:rout),quarkpol(1:ds),quarkmom(1:dv),quarks(2)%Mass,ferfla2,ferfla1,numglu(1))
2332  endif
2333 
2334 
2335 return
2336 END FUNCTION
2337 
2338 
2339 
2340 
2341 
2342 
2343 FUNCTION cur_g_4f(Gluons,Quarks,NumGlu) result(res) ! Gluons(:) does not include the OFF-shell gluon, however NumGlu is the number of all gluons
2344 implicit none
2345 integer,intent(in) :: numglu(0:5)
2346 type(ptrtoparticle) :: gluons(1:),quarks(1:)
2347 integer :: na,nb,nc,nd,ne,nf,ng,nh,ni,nj,nk
2348 integer :: rin,rout
2349 integer :: tag_f,counter,i
2350 complex(8) :: res(dv)
2351 type(ptrtoparticle) :: tmpgluons(1:2+numglu(1)+numglu(3)+numglu(5))
2352 complex(8),target :: tmpmom1(1:dv),tmpmom2(1:dv)
2353 integer,target :: tmpextref1,tmpextref2
2354 complex(8),target :: eps1(1:dv)
2355 complex(8),target :: eps2(1:dv)
2356 complex(8) :: eps3(1:dv)
2357 complex(8) :: u1(1:ds)
2358 complex(8) :: ubar2(1:ds)
2359 complex(8) :: propfac1,propfac2,propfac3,propfac4
2360 complex(8) :: pmom1(1:dv)
2361 complex(8) :: pmom2(1:dv)
2362 complex(8) :: pmom3(1:dv)
2363 complex(8) :: pmom4(1:dv)
2364 
2365 !DEC$ IF (_DebugCheckMyImpl1==1)
2366  if( numglu(0)-1-numglu(1)-numglu(2)-numglu(3)-numglu(4)-numglu(5).ne.0 ) print *, "wrong number of gluons in cur_g_4f"
2367 !DEC$ ENDIF
2368 
2369  res = (0d0,0d0)
2370  if( (quarks(1)%PartType.eq.-quarks(2)%PartType .and. quarks(3)%PartType.eq.-quarks(4)%PartType) &
2371  .OR. (quarks(1)%PartType.eq.-quarks(4)%PartType .and. quarks(2)%PartType.eq.-quarks(3)%PartType) ) then
2372 ! type (1)
2373  do na=0,numglu(1)
2374  do nc=0,numglu(2)
2375  do ne=0,numglu(5)
2376  nb=numglu(1)-na
2377  nd=numglu(2)-nc
2378  nf=numglu(5)-ne
2379  rin = numglu(1)+nc+1
2380  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
2381  u1 = cur_f_4f(gluons(rin:rout),quarks(2:4),quarks(1)%PartType,(/nd+numglu(3)+numglu(4)+ne,nd,numglu(3),numglu(4),ne/),0,0)
2382  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom
2383  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(1)%Mass2)
2384  if( abs(sc_(pmom2,pmom2) - quarks(1)%Mass2).lt.propcut ) cycle
2385  if( quarks(1)%PartType.lt.0 ) then
2386  u1 = ( spb2_(u1,pmom2) + quarks(1)%Mass*u1 )*propfac2
2387  else
2388  u1 = (-spi2_(pmom2,u1) + quarks(1)%Mass*u1 )*propfac2
2389  endif
2390 
2391  rin = na+1
2392  rout= numglu(1)+nc
2393  ubar2 = cur_f_2f(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,(/nb+nc,nb,nc/))
2394  pmom3 = summom(gluons,rin,rout) + quarks(1)%Mom
2395  if( nb.ge.1 .or. nc.ge.1 ) then
2396  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(1)%Mass2)
2397  if( abs(sc_(pmom3,pmom3) - quarks(1)%Mass2).lt.propcut ) cycle
2398  if( quarks(1)%PartType.lt.0 ) then
2399  ubar2 = (-spi2_(pmom3,ubar2) + quarks(1)%Mass*ubar2 )*propfac3
2400  else
2401  ubar2 = (+spb2_(ubar2,pmom3) + quarks(1)%Mass*ubar2 )*propfac3
2402  endif
2403  endif
2404 
2405  if( quarks(1)%PartType.lt.0 ) then
2406  eps1 = -vbqq(dv,u1,ubar2) ! re-checked
2407  else
2408  eps1 = +vbqq(dv,ubar2,u1) ! re-checked
2409  endif
2410 
2411  counter=1
2412  rin =1
2413  rout=na
2414  do i=rin,rout
2415  call copyparticleptr(gluons(i),tmpgluons(counter))
2416  counter=counter+1
2417  enddo
2418  tmpmom1(:) = pmom2(:)+pmom3(:)
2419  tmpextref1 = -1
2420  tmpgluons(counter)%Mom => tmpmom1(:)
2421  tmpgluons(counter)%Pol => eps1(:)
2422  tmpgluons(counter)%ExtRef => tmpextref1
2423  counter=counter+1
2424  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
2425  rout=numglu(0)-1
2426  do i=rin,rout
2427  call copyparticleptr(gluons(i),tmpgluons(counter))
2428  counter=counter+1
2429  enddo
2430  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
2431 
2432  if( na.ge.1 .or. nf.ge.1 ) then
2433  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
2434  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
2435  eps2 = eps2*propfac1
2436  endif
2437 
2438  res = res + eps2
2439  enddo
2440  enddo
2441  enddo
2442 
2443 
2444 ! type (2)
2445  do na=0,numglu(1)
2446  do nc=0,numglu(4)
2447  do ne=0,numglu(5) ! can be replaced by above ne-loop
2448  nb=numglu(1)-na
2449  nd=numglu(4)-nc
2450  nf=numglu(5)-ne
2451 
2452  rin = na+1
2453  rout= numglu(1)+numglu(2)+numglu(3)+nc
2454  u1 = cur_f_4f(gluons(rin:rout),quarks(1:3),quarks(4)%PartType,(/nb+numglu(2)+numglu(3)+nc,nb,numglu(2),numglu(3),nc/),0,0)
2455  pmom2 = summom(gluons,rin,rout) + quarks(1)%Mom + quarks(2)%Mom + quarks(3)%Mom
2456  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
2457  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
2458  if( quarks(4)%PartType.lt.0 ) then
2459  u1 = (+spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
2460  else
2461  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
2462  endif
2463  rin = numglu(1)+numglu(2)+numglu(3)+nc+1
2464  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
2465  ubar2 = cur_f_2f(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,(/nd+ne,nd,ne/))
2466  pmom3 = summom(gluons,rin,rout) + quarks(4)%Mom
2467  if( nd.ge.1 .or. ne.ge.1 ) then
2468  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(4)%Mass2)
2469  if( abs(sc_(pmom3,pmom3) - quarks(4)%Mass2).lt.propcut ) cycle
2470  if( quarks(4)%PartType.lt.0 ) then
2471  ubar2 = (-spi2_(pmom3,ubar2) + quarks(4)%Mass*ubar2 )*propfac3
2472  else
2473  ubar2 = (+spb2_(ubar2,pmom3) + quarks(4)%Mass*ubar2 )*propfac3
2474  endif
2475  endif
2476 
2477  if( quarks(4)%PartType.lt.0 ) then
2478  eps1 = +vbqq(dv,u1,ubar2) ! re-checked
2479  else
2480  eps1 = -vbqq(dv,ubar2,u1) ! re-checked
2481  endif
2482 
2483  counter=1
2484  rin =1
2485  rout=na
2486  do i=rin,rout
2487  call copyparticleptr(gluons(i),tmpgluons(counter))
2488  counter=counter+1
2489  enddo
2490  tmpmom1(:) = pmom2(:)+pmom3(:)
2491  tmpextref1 = -1
2492  tmpgluons(counter)%Mom => tmpmom1(:)
2493  tmpgluons(counter)%Pol => eps1(:)
2494  tmpgluons(counter)%ExtRef => tmpextref1
2495  counter=counter+1
2496  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
2497  rout=numglu(0)-1
2498  do i=rin,rout
2499  call copyparticleptr(gluons(i),tmpgluons(counter))
2500  counter=counter+1
2501  enddo
2502  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
2503 
2504  if( na.ge.1 .or. nf.ge.1 ) then
2505  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
2506  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
2507  eps2 = eps2*propfac1
2508  endif
2509 
2510  res = res + eps2
2511  enddo
2512  enddo
2513  enddo
2514  endif
2515 
2516 
2517 
2518  if( quarks(1)%PartType.eq.-quarks(2)%PartType .and. quarks(3)%PartType.eq.-quarks(4)%PartType) then
2519 ! type(3)
2520  do na=0,numglu(1)
2521  do nc=0,numglu(2)
2522  do ne=0,numglu(3)
2523  do nf=0,numglu(3)-ne
2524  do nh=0,numglu(4) ! this loop can be placed after Eps1 has been calculated
2525  do nj=0,numglu(5)
2526  nb=numglu(1)-na
2527  nd=numglu(2)-nc
2528  ng=numglu(3)-ne-nf
2529  ni=numglu(4)-nh
2530  nk=numglu(5)-nj
2531 
2532  rin = na+1
2533  rout= numglu(1)+nc
2534  ubar2 = cur_f_2f(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,(/nb+nc,nb,nc/))
2535  pmom1 = summom(gluons,rin,rout) + quarks(1)%Mom
2536  if( nb.ge.1 .or. nc.ge.1 ) then
2537  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1) - quarks(1)%Mass2)
2538  if( abs(sc_(pmom1,pmom1) - quarks(1)%Mass2).lt.propcut ) cycle
2539  if( quarks(1)%PartType.lt.0 ) then
2540  ubar2 = (-spi2_(pmom1,ubar2) + quarks(1)%Mass*ubar2 )*propfac1
2541  else
2542  ubar2 = (+spb2_(ubar2,pmom1) + quarks(1)%Mass*ubar2 )*propfac1
2543  endif
2544  endif
2545  rin = numglu(1)+nc+1
2546  rout= numglu(1)+numglu(2)+ne
2547  u1 = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/nd+ne,nd,ne/))
2548  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom
2549  if( nd.ge.1 .or. ne.ge.1 ) then
2550  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
2551  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
2552  if( quarks(2)%PartType.lt.0 ) then
2553  u1 = (-spi2_(pmom2,u1) + quarks(2)%Mass*u1 )*propfac2
2554  else
2555  u1 = (+spb2_(u1,pmom2) + quarks(2)%Mass*u1 )*propfac2
2556  endif
2557  endif
2558 
2559  if( quarks(2)%PartType.lt.0 ) then
2560  eps1 = +vbqq(dv,ubar2,u1) ! re-checked
2561  else
2562  eps1 = -vbqq(dv,u1,ubar2) ! re-checked
2563  endif
2564  tmpmom1 = pmom1 + pmom2
2565  propfac3 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
2566  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
2567  eps1 = eps1*propfac3
2568 
2569 
2570  rin = numglu(1)+numglu(2)+ne+nf+1
2571  rout= numglu(1)+numglu(2)+numglu(3)+nh
2572  u1 = cur_f_2f(gluons(rin:rout),quarks(3:3),-quarks(3)%PartType,(/ng+nh,ng,nh/))
2573  pmom3 = summom(gluons,rin,rout) + quarks(3)%Mom
2574  if( ng.ge.1 .or. nh.ge.1 ) then
2575  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(3)%Mass2)
2576  if( abs(sc_(pmom3,pmom3) - quarks(3)%Mass2).lt.propcut ) cycle
2577  if( quarks(3)%PartType.lt.0 ) then
2578  u1 = (-spi2_(pmom3,u1) + quarks(3)%Mass*u1 )*propfac3
2579  else
2580  u1 = (+spb2_(u1,pmom3) + quarks(3)%Mass*u1 )*propfac3
2581  endif
2582  endif
2583  rin = numglu(1)+numglu(2)+numglu(3)+nh+1
2584  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+nj
2585  ubar2 = cur_f_2f(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,(/ni+nj,ni,nj/))
2586  pmom4 = summom(gluons,rin,rout) + quarks(4)%Mom
2587  if( ni.ge.1 .or. nj.ge.1 ) then
2588  propfac4 = (0d0,1d0)/(sc_(pmom4,pmom4) - quarks(4)%Mass2)
2589  if( abs(sc_(pmom4,pmom4) - quarks(4)%Mass2).lt.propcut ) cycle
2590  if( quarks(4)%PartType.lt.0 ) then
2591  ubar2 = (-spi2_(pmom4,ubar2) + quarks(4)%Mass*ubar2 )*propfac4
2592  else
2593  ubar2 = (+spb2_(ubar2,pmom4) + quarks(4)%Mass*ubar2 )*propfac4
2594  endif
2595  endif
2596 
2597  if( quarks(4)%PartType.lt.0 ) then
2598  eps2 = +vbqq(dv,u1,ubar2) ! re-checked
2599  else
2600  eps2 = -vbqq(dv,ubar2,u1) ! re-checked
2601  endif
2602  tmpmom2 = pmom3 + pmom4
2603  propfac1 = (0d0,-1d0)/sc_(tmpmom2,tmpmom2)
2604  if( abs(sc_(tmpmom2,tmpmom2)).lt.propcut ) cycle
2605  eps2 = eps2*propfac1
2606 
2607 
2608  counter=1
2609  rin =1
2610  rout=na
2611  do i=rin,rout
2612  call copyparticleptr(gluons(i),tmpgluons(counter))
2613  counter=counter+1
2614  enddo
2615  tmpextref1 = -1
2616  tmpgluons(counter)%Mom => tmpmom1(:)
2617  tmpgluons(counter)%Pol => eps1(:)
2618  tmpgluons(counter)%ExtRef => tmpextref1
2619  counter=counter+1
2620  rin =numglu(1)+numglu(2)+ne+1
2621  rout=numglu(1)+numglu(2)+ne+nf
2622  do i=rin,rout
2623  call copyparticleptr(gluons(i),tmpgluons(counter))
2624  counter=counter+1
2625  enddo
2626  tmpgluons(counter)%Mom => tmpmom2(:)
2627  tmpgluons(counter)%Pol => eps2(:)
2628  tmpgluons(counter)%ExtRef => tmpextref1
2629  counter=counter+1
2630  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+nj+1
2631  rout=numglu(0)-1
2632  do i=rin,rout
2633  call copyparticleptr(gluons(i),tmpgluons(counter))
2634  counter=counter+1
2635  enddo
2636  eps3(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+nk+2)
2637  res = res + eps3
2638  enddo
2639  enddo
2640  enddo
2641  enddo
2642  enddo
2643  enddo
2644  endif
2645 
2646 
2647 return
2648 END FUNCTION
2649 
2650 
2651 
2652 
2653 FUNCTION cur_f_6f(Gluons,Quarks,Quark1PartType,NumGlu,tag_f,tag_Z) result(res) ! Quarks(:) does not include the OFF-shell quark
2654 implicit none
2655 integer :: numglu(0:6),quark1parttype,tag_f,tag_z
2656 type(ptrtoparticle) :: gluons(1:),quarks(2:6)
2657 integer,target :: tmpparttype,tmpextref
2658 complex(8) :: res(1:ds),tmp(1:ds)
2659 ! complex(8) :: Res1(1:Ds),Res2(1:Ds),Res3(1:Ds),Res4(1:Ds)
2660 complex(8) :: u1(1:ds),ubar1(1:ds)
2661 complex(8),target :: ubar0(1:ds)
2662 complex(8) :: eps1(1:dv)
2663 complex(8) :: eps2(1:dv)
2664 type(ptrtoparticle) :: tmpgluons(1:numglu(1)+numglu(6)),tmpquark(1:1)
2665 complex(8) :: propfac1,propfac2
2666 complex(8),target :: pmom1(1:dv)
2667 complex(8),target :: pmom2(1:dv)
2668 integer :: n1a,n1b,n2a,n2b,n3a,n3b,n4a,n4b,n5a,n5b,n6a,n6b
2669 integer :: rin,rout,i,counter
2670 
2671 
2672 !DEC$ IF (_DebugCheckMyImpl1==1)
2673  if( numglu(0)-numglu(1)-numglu(2)-numglu(3)-numglu(4)-numglu(5)-numglu(6).ne.0 ) print *, "wrong number of gluons in cur_f_6f"
2674 !DEC$ ENDIF
2675 
2676  res = (0d0,0d0)
2677 ! Res1=(0d0,0d0); Res2=(0d0,0d0); Res3=(0d0,0d0); Res4=(0d0,0d0);
2678 
2679 
2680 ! (A)
2681  if( quark1parttype.eq.-quarks(2)%PartType .AND. (quarks(3)%PartType.eq.-quarks(4)%PartType .or. quarks(3)%PartType.eq.-quarks(6)%PartType) &
2682  .AND. (quarks(2)%ExtRef.ne.-1 .or. tag_f.ne.1) &
2683  ) then
2684 
2685  do n2a=0,numglu(2)
2686  do n6a=0,numglu(6)
2687  n2b = numglu(2)-n2a
2688  n6b = numglu(6)-n6a
2689 
2690  rin =numglu(1)+n2a+1
2691  rout=numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2692  eps2 = cur_g_4f(gluons(rin:rout),quarks(3:6),(/1+n2b+numglu(3)+numglu(4)+numglu(5)+n6a,n2b,numglu(3),numglu(4),numglu(5),n6a/))
2693  pmom1(:) = summom(gluons,rin,rout) + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom
2694  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
2695  if( abs(sc_(pmom1,pmom1)).lt.propcut) cycle
2696  eps2 = eps2*propfac1
2697  do n1a=0,numglu(1)
2698  n1b = numglu(1)-n1a
2699  ! Fer2
2700  rin =n1a+1
2701  rout=numglu(1)+n2a
2702  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/n1b+n2a,n1b,n2a/) )
2703  if(n1b.ge.1 .or. n2a.ge.1) then
2704  pmom2(:) = quarks(2)%Mom + summom(gluons,rin,rout)
2705  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
2706  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) cycle
2707  if( quarks(2)%PartType.lt.0 ) then
2708  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(2)%Mass*ubar1(:))*propfac2
2709  else
2710  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(2)%Mass*ubar1(:))*propfac2
2711  endif
2712  endif
2713  if( quarks(2)%PartType.lt.0 ) then
2714  ubar0(:) = vbqg(ubar1,eps2) ! re-checked
2715  else
2716  ubar0(:) = vqg(ubar1,eps2) ! re-checked
2717  endif
2718 
2719  rin = n1a+1
2720  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2721  pmom1 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom ! can be simplified with PMom1(:)
2722  if(n1a.ge.1 .or. n6b.ge.1) then
2723  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(2)%Mass2)
2724  if( abs(sc_(pmom1,pmom1)-quarks(2)%Mass2).lt.propcut ) cycle
2725  if( quarks(2)%PartType.lt.0 ) then
2726  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(2)%Mass*ubar0(:))*propfac1
2727  else
2728  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(2)%Mass*ubar0(:))*propfac1
2729  endif
2730  endif
2731 
2732  tmpquark(1)%Mom => pmom1(:)
2733  tmpquark(1)%Pol => ubar0(:)
2734  tmpquark(1)%Mass => quarks(2)%Mass
2735  tmpquark(1)%Mass2=> quarks(2)%Mass2
2736  tmpextref = -1
2737  tmpquark(1)%ExtRef => tmpextref
2738  tmpquark(1)%PartType => quarks(2)%PartType
2739  counter=1
2740  rin =1
2741  rout=n1a
2742  do i=rin,rout
2743  call copyparticleptr(gluons(i),tmpgluons(counter))
2744  counter=counter+1
2745  enddo
2746  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
2747  rout=numglu(0)
2748  do i=rin,rout
2749  call copyparticleptr(gluons(i),tmpgluons(counter))
2750  counter=counter+1
2751  enddo
2752  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n6b/) )
2753 
2754  res(:) = res(:) + tmp(:)
2755 ! Res1(:) = Res1(:) + tmp(:)
2756 ! print *, "1",tmp(:)
2757  enddo
2758  enddo
2759  enddo
2760  endif
2761 
2762 
2763 
2764 ! (B)
2765  if( quark1parttype.eq.-quarks(6)%PartType .AND. (quarks(2)%PartType.eq.-quarks(5)%PartType .or. quarks(2)%PartType.eq.-quarks(3)%PartType) &
2766  .AND. (quarks(6)%ExtRef.ne.-1 .or. tag_f.ne.1) &
2767  ) then
2768  do n1a=0,numglu(1)
2769  do n5b=0,numglu(5)
2770  n1b = numglu(1)-n1a
2771  n5a = numglu(5)-n5b
2772 
2773  rin =n1a+1
2774  rout=numglu(1)+numglu(2)+numglu(3)+numglu(4)+n5a
2775 
2776 ! preventing color issues with Z on the loop, see RR notes 05-22-2013
2777 !note: only tested for zero gluons
2778  if ( tag_z .eq. 1 .and. (n1b+numglu(2)+numglu(3)+numglu(4)+n5a .eq. numglu(0)) ) then
2779 ! print * , "cycle for tag_Z=1 in cur_f_6f"
2780  cycle
2781  endif
2782 
2783  eps2 = cur_g_4f(gluons(rin:rout),quarks(2:5),(/1+n1b+numglu(2)+numglu(3)+numglu(4)+n5a,n1b,numglu(2),numglu(3),numglu(4),n5a/))
2784  pmom1(:) = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom
2785  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
2786  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
2787  eps2 = eps2*propfac1
2788 
2789  do n6a=0,numglu(6)
2790  n6b = numglu(6)-n6a
2791  ! Fer6
2792  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+n5a+1
2793  rout=numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2794  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(6:6),-quarks(6)%PartType,(/n5b+n6a,n5b,n6a/) )
2795  if(n5b.ge.1 .or. n6a.ge.1) then
2796  pmom2(:) = summom(gluons,rin,rout) + quarks(6)%Mom
2797  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(6)%Mass2)
2798  if( abs(sc_(pmom2,pmom2)-quarks(6)%Mass2).lt.propcut ) cycle
2799  if( quarks(6)%PartType.lt.0 ) then
2800  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(6)%Mass*ubar1(:))*propfac2
2801  else
2802  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(6)%Mass*ubar1(:))*propfac2
2803  endif
2804  endif
2805  if( quarks(6)%PartType.lt.0 ) then
2806  ubar0(:) = vgbq(eps2,ubar1) ! re-checked
2807  else
2808  ubar0(:) = vgq(eps2,ubar1) ! re-checked
2809  endif
2810 
2811  rin = n1a+1
2812  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2813  pmom1 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom
2814  if(n1a.ge.1 .or. n6b.ge.1) then
2815  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(6)%Mass2)
2816  if( abs(sc_(pmom1,pmom1)-quarks(6)%Mass2).lt.propcut ) cycle
2817  if( quarks(6)%PartType.lt.0 ) then
2818  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(6)%Mass*ubar0(:))*propfac1
2819  else
2820  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(6)%Mass*ubar0(:))*propfac1
2821  endif
2822  endif
2823  tmpquark(1)%Mom => pmom1(:)
2824  tmpquark(1)%Pol => ubar0(:)
2825  tmpquark(1)%Mass => quarks(6)%Mass
2826  tmpquark(1)%Mass2=> quarks(6)%Mass2
2827  tmpextref = -1
2828  tmpquark(1)%ExtRef => tmpextref
2829  tmpquark(1)%PartType => quarks(6)%PartType
2830  counter=1
2831  rin =1
2832  rout=n1a
2833  do i=rin,rout
2834  call copyparticleptr(gluons(i),tmpgluons(counter))
2835  counter=counter+1
2836  enddo
2837  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
2838  rout=numglu(0)
2839  do i=rin,rout
2840  call copyparticleptr(gluons(i),tmpgluons(counter))
2841  counter=counter+1
2842  enddo
2843  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,(/counter-1,n1a,n6b/) )
2844 
2845  res(:) = res(:) + tmp(:)
2846 
2847 ! Res2(:) = Res2(:) + tmp(:)
2848 
2849 ! print *, "2",tmp(:)
2850  enddo
2851  enddo
2852  enddo
2853  endif
2854 
2855 
2856 
2857 
2858 ! (C)
2859 ! if( Quarks(5)%PartType.eq.-Quarks(6)%PartType .AND. (Quark1PartType.eq.-Quarks(2)%PartType .or. Quark1PartType.eq.-Quarks(4)%PartType) &
2860 ! .AND. .not.(Quarks(6)%ExtRef.eq.-1 .and. tag_f.eq.1) &
2861 ! ) then
2862 ! if( Quark1PartType.eq.-Quarks(2)%PartType .and. Quarks(5)%PartType.eq.-Quarks(6)%PartType .and..not.(Quarks(2)%ExtRef.eq.-1 .and. tag_f.eq.1) &
2863 ! .OR. Quark1PartType.eq.-Quarks(4)%PartType .and. Quarks(5)%PartType.eq.-Quarks(6)%PartType .and..not.(Quarks(4)%ExtRef.eq.-1 .and. tag_f.eq.1) &
2864 ! ) then
2865 
2866  if( quarks(5)%PartType.eq.-quarks(6)%PartType .AND. &
2867  ((quark1parttype.eq.-quarks(2)%PartType .and. (quarks(2)%ExtRef.ne.-1.or.tag_f.ne.1) ) &
2868  .OR. (quark1parttype.eq.-quarks(4)%PartType .and. (quarks(4)%ExtRef.ne.-1.or.tag_f.ne.1) ))&
2869  ) then
2870 
2871  do n1a=0,numglu(1)
2872  do n4a=0,numglu(4)
2873  do n6a=0,numglu(6)
2874  n1b = numglu(1)-n1a
2875  n4b = numglu(4)-n4a
2876  n6b = numglu(6)-n6a
2877 
2878  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
2879  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2880  eps2 = cur_g_2f(gluons(rin:rout),quarks(5:6),(/1+n4b+numglu(5)+n6a,n4b,numglu(5),n6a/))
2881  pmom1(:) = summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
2882  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
2883  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
2884  eps2 = eps2*propfac1
2885 
2886  rin = n1a+1
2887  rout= numglu(1)+numglu(2)+numglu(3)+n4a
2888  u1 = cur_f_4f(gluons(rin:rout),quarks(2:4),quark1parttype,(/n1b+numglu(2)+numglu(3)+n4a,n1b,numglu(2),numglu(3),n4a/),0,0)
2889  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom
2890 
2891  if( quark1parttype.eq.-quarks(2)%PartType) then
2892  if( quarks(2)%PartType.lt.0 ) then
2893  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
2894  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
2895  u1 = (-spi2_(pmom2,u1) + quarks(2)%Mass*u1 )*propfac2
2896  ubar0 = vbqg(u1,eps2) ! re-checked
2897  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
2898  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2899  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom ! this PMom2 will be re-used below
2900  if( n1a.ge.1 .or. n6b.ge.1 ) then
2901  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
2902  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
2903  ubar0 = (-spi2_(pmom2,ubar0) + quarks(2)%Mass*ubar0 )*propfac2
2904  endif
2905  elseif( quarks(2)%PartType.gt.0 ) then
2906  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
2907  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
2908  u1 = ( spb2_(u1,pmom2) + quarks(2)%Mass*u1 )*propfac2
2909  ubar0 = vqg(u1,eps2) ! re-checked
2910  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
2911  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2912  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
2913  if( n1a.ge.1 .or. n6b.ge.1 ) then
2914  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
2915  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
2916  ubar0 = ( spb2_(ubar0,pmom2) + quarks(2)%Mass*ubar0 )*propfac2
2917  endif
2918  endif
2919  tmpquark(1)%Mom => pmom2(:)
2920  tmpquark(1)%Pol => ubar0(:)
2921  tmpquark(1)%Mass => quarks(2)%Mass
2922  tmpquark(1)%Mass2=> quarks(2)%Mass2
2923  elseif( quark1parttype.eq.-quarks(4)%PartType) then
2924  if( quarks(4)%PartType.lt.0 ) then
2925  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
2926  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
2927  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
2928  ubar0 = vbqg(u1,eps2) ! re-checked
2929  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
2930  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2931  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
2932  if( n1a.ge.1 .or. n6b.ge.1 ) then
2933  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
2934  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
2935  ubar0 = (-spi2_(pmom2,ubar0) + quarks(4)%Mass*ubar0 )*propfac2
2936  endif
2937  elseif( quarks(4)%PartType.gt.0 ) then
2938  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
2939  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
2940  u1 = ( spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
2941  ubar0 = vqg(u1,eps2) ! re-checked
2942  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
2943  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
2944  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
2945  if( n1a.ge.1 .or. n6b.ge.1 ) then
2946  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
2947  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
2948  ubar0 = ( spb2_(ubar0,pmom2) + quarks(4)%Mass*ubar0 )*propfac2
2949  endif
2950  endif
2951  tmpquark(1)%Mom => pmom2(:)
2952  tmpquark(1)%Pol => ubar0(:)
2953  tmpquark(1)%Mass => quarks(4)%Mass
2954  tmpquark(1)%Mass2=> quarks(4)%Mass2
2955  endif
2956  tmpextref = -1
2957  tmpquark(1)%ExtRef => tmpextref
2958  tmpparttype = -quark1parttype
2959  tmpquark(1)%PartType => tmpparttype
2960  counter=1
2961  rin =1
2962  rout=n1a
2963  do i=rin,rout
2964  call copyparticleptr(gluons(i),tmpgluons(counter))
2965  counter=counter+1
2966  enddo
2967  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
2968  rout=numglu(0)
2969  do i=rin,rout
2970  call copyparticleptr(gluons(i),tmpgluons(counter))
2971  counter=counter+1
2972  enddo
2973  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,(/counter-1,n1a,n6b/) )
2974 
2975  res(:) = res(:) + tmp(:)
2976 ! Res3(:) = Res3(:) + tmp(:)
2977 ! print *, "3",tmp(:)
2978  enddo
2979  enddo
2980  enddo
2981  endif
2982 
2983 
2984 ! (D)
2985  if( quarks(2)%PartType.eq.-quarks(3)%PartType .AND. ( &
2986  (quark1parttype.eq.-quarks(4)%PartType .and. (quarks(4)%ExtRef.ne.-1.or.tag_f.ne.1)) &
2987  .OR. (quark1parttype.eq.-quarks(6)%PartType .and. (quarks(6)%ExtRef.ne.-1.or.tag_f.ne.1)) )) then
2988 ! if( Quark1PartType.eq.-Quarks(4)%PartType .and. Quarks(2)%PartType.eq.-Quarks(3)%PartType .and..not.(Quarks(4)%ExtRef.eq.-1 .and. tag_f.eq.1) &
2989 ! .OR.Quark1PartType.eq.-Quarks(6)%PartType .and. Quarks(2)%PartType.eq.-Quarks(3)%PartType .and..not.(Quarks(6)%ExtRef.eq.-1 .and. tag_f.eq.1) &
2990 ! ) then
2991 
2992  do n1a=0,numglu(1)
2993  do n3a=0,numglu(3)
2994  do n6a=0,numglu(6)
2995  n1b = numglu(1)-n1a
2996  n3b = numglu(3)-n3a
2997  n6b = numglu(6)-n6a
2998 
2999  counter=1
3000  rin = n1a+1
3001  rout= numglu(1)+numglu(2)+n3a
3002 
3003 
3004  eps2 = cur_g_2f(gluons(rin:rout),quarks(2:3),(/1+n1b+numglu(2)+n3a,n1b,numglu(2),n3a/))
3005  pmom1(:) = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
3006  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
3007  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
3008  eps2 = eps2*propfac1
3009 
3010  rin = numglu(1)+numglu(2)+n3a+1
3011  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
3012  u1 = cur_f_4f(gluons(rin:rout),quarks(4:6),quark1parttype,(/n3b+numglu(4)+numglu(5)+n6a,n3b,numglu(4),numglu(5),n6a/),tag_f,0)
3013  pmom2 = summom(gluons,rin,rout) + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom
3014 
3015  if( quark1parttype.eq.-quarks(4)%PartType ) then
3016  if( quarks(4)%PartType.lt.0 ) then
3017  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
3018  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
3019  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
3020  ubar0 = vgbq(eps2,u1) ! re-checked
3021  rin = n1a+1
3022  rout= numglu(1)+numglu(2)+n3a
3023  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom !this PMom2 will be re-used below ! CAN be written as PMom2=PMom2+PMom1
3024  if( n1a.ge.1 .or. n6b.ge.1 ) then
3025  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
3026  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
3027  ubar0 = (-spi2_(pmom2,ubar0) + quarks(4)%Mass*ubar0 )*propfac2
3028  endif
3029  elseif( quarks(4)%PartType.gt.0 ) then
3030  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
3031  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
3032  u1 = ( spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
3033  ubar0 = vgq(eps2,u1) ! re-checked
3034  rin = n1a+1
3035  rout= numglu(1)+numglu(2)+n3a
3036  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
3037  if( n1a.ge.1 .or. n6b.ge.1 ) then
3038  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
3039  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
3040  ubar0 = ( spb2_(ubar0,pmom2) + quarks(4)%Mass*ubar0 )*propfac2
3041  endif
3042  endif
3043  tmpquark(1)%Mom => pmom2(:)
3044  tmpquark(1)%Pol => ubar0(:)
3045  tmpquark(1)%Mass => quarks(4)%Mass
3046  tmpquark(1)%Mass2=> quarks(4)%Mass2
3047  elseif(quark1parttype.eq.-quarks(6)%PartType) then
3048  if( quarks(6)%PartType.lt.0 ) then
3049  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
3050  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
3051  u1 = (-spi2_(pmom2,u1) + quarks(6)%Mass*u1 )*propfac2
3052  ubar0 = vgbq(eps2,u1) ! re-checked
3053  rin = n1a+1
3054  rout= numglu(1)+numglu(2)+n3a
3055  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
3056  if( n1a.ge.1 .or. n6b.ge.1 ) then
3057  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
3058  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
3059  ubar0 = (-spi2_(pmom2,ubar0) + quarks(6)%Mass*ubar0 )*propfac2
3060  endif
3061  elseif( quarks(6)%PartType.gt.0 ) then
3062  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
3063  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
3064  u1 = ( spb2_(u1,pmom2) + quarks(6)%Mass*u1 )*propfac2
3065  ubar0 = vgq(eps2,u1) ! re-checked
3066  rin = n1a+1
3067  rout= numglu(1)+numglu(2)+n3a
3068  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
3069  if( n1a.ge.1 .or. n6b.ge.1 ) then
3070  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
3071  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
3072  ubar0 = ( spb2_(ubar0,pmom2) + quarks(6)%Mass*ubar0 )*propfac2
3073  endif
3074  endif
3075  tmpquark(1)%Mom => pmom2(:)
3076  tmpquark(1)%Pol => ubar0(:)
3077  tmpquark(1)%Mass => quarks(6)%Mass
3078  tmpquark(1)%Mass2=> quarks(6)%Mass2
3079  endif
3080  tmpextref = -1
3081  tmpquark(1)%ExtRef => tmpextref
3082  tmpparttype = -quark1parttype
3083  tmpquark(1)%PartType => tmpparttype
3084  counter=1
3085  rin =1
3086  rout=n1a
3087  do i=rin,rout
3088  call copyparticleptr(gluons(i),tmpgluons(counter))
3089  counter=counter+1
3090  enddo
3091  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
3092  rout=numglu(0)
3093  do i=rin,rout
3094  call copyparticleptr(gluons(i),tmpgluons(counter))
3095  counter=counter+1
3096  enddo
3097  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,(/counter-1,n1a,n6b/))
3098 
3099  res(:) = res(:) + tmp(:)
3100 ! Res4(:) = Res4(:) + Tmp(:)
3101 ! print *, "4",tmp(:)
3102  enddo
3103  enddo
3104  enddo
3105  endif
3106 ! print *, 'res', res
3107 ! pause
3108 ! Res(:) = Res1(:)+Res2(:)+Res3(:)+Res4(:)
3109 ! print *, "Res1:",Res1(1:4)
3110 ! print *, "Res2:",Res2(1:4)
3111 ! print *, "Res3:",Res3(1:4)
3112 ! print *, "Res4:",Res4(1:4)
3113 return
3114 END FUNCTION
3115 
3116 
3117 
3118 
3119 
3120 
3121 
3122 
3123 FUNCTION cur_g_4fv(Gluons,Quarks,Boson,BosonVertex,NumGlu) result(res) ! Gluons(:) does not include the OFF-shell gluon, however NumGlu is the number of all gluons
3124 implicit none
3125 integer,intent(in) :: numglu(0:5),bosonvertex
3126 type(ptrtoparticle) :: gluons(1:),quarks(1:),boson
3127 integer :: na,nb,nc,nd,ne,nf,ng,nh,ni,nj,nk,bosonvertex_mod
3128 integer :: rin,rout
3129 integer :: tag_f,counter,i
3130 complex(8) :: res(dv)
3131 type(ptrtoparticle) :: tmpgluons(1:2+numglu(1)+numglu(3)+numglu(5))
3132 complex(8),target :: tmpmom1(1:dv),tmpmom2(1:dv)
3133 integer,target :: tmpextref1,tmpextref2
3134 complex(8),target :: eps1(1:dv)
3135 complex(8),target :: eps2(1:dv)
3136 complex(8) :: eps3(1:dv)
3137 complex(8) :: u1(1:ds)
3138 complex(8) :: ubar2(1:ds)
3139 complex(8) :: propfac1,propfac2,propfac3,propfac4
3140 complex(8) :: pmom1(1:dv)
3141 complex(8) :: pmom2(1:dv)
3142 complex(8) :: pmom3(1:dv)
3143 complex(8) :: pmom4(1:dv)
3144 
3145 !DEC$ IF (_DebugCheckMyImpl1==1)
3146  if( numglu(0)-1-numglu(1)-numglu(2)-numglu(3)-numglu(4)-numglu(5).ne.0 ) print *, "wrong number of gluons in cur_g_4f"
3147 !DEC$ ENDIF
3148 
3149  res = (0d0,0d0)
3150  if (quarks(1)%PartType.eq.-quarks(4)%PartType .and. quarks(2)%PartType.eq.-quarks(3)%PartType) then
3151  ! for this flavor structure, the BosonVertex implies the following:
3152  ! BV = 1 : Boson on quark 1 only
3153  ! BV = 2 : Boson on both quarks 2 and 3
3154  ! BV = 3 : Boson on quark 4 only
3155  ! See RR notes
3156 
3157  if( bosonvertex.eq.1) then
3158  ! type (1)
3159  do na=0,numglu(1)
3160  do nc=0,numglu(2)
3161  do ne=0,numglu(5)
3162  nb=numglu(1)-na
3163  nd=numglu(2)-nc
3164  nf=numglu(5)-ne
3165  rin = numglu(1)+nc+1
3166  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
3167  u1 = cur_f_4f(gluons(rin:rout),quarks(2:4),quarks(1)%PartType,(/nd+numglu(3)+numglu(4)+ne,nd,numglu(3),numglu(4),ne/),0,0)
3168  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom
3169  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(1)%Mass2)
3170  if( abs(sc_(pmom2,pmom2) - quarks(1)%Mass2).lt.propcut ) cycle
3171  if( quarks(1)%PartType.lt.0 ) then
3172  u1 = ( spb2_(u1,pmom2) + quarks(1)%Mass*u1 )*propfac2
3173  else
3174  u1 = (-spi2_(pmom2,u1) + quarks(1)%Mass*u1 )*propfac2
3175  endif
3176 
3177  rin = na+1
3178  rout= numglu(1)+nc
3179  ubar2 = cur_f_2fv(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,boson,(/nb+nc,nb,nc/))
3180  pmom3 = summom(gluons,rin,rout) + quarks(1)%Mom + boson%Mom
3181  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(1)%Mass2)
3182  if( abs(sc_(pmom3,pmom3) - quarks(1)%Mass2).lt.propcut ) cycle
3183  if( quarks(1)%PartType.lt.0 ) then
3184  ubar2 = (-spi2_(pmom3,ubar2) + quarks(1)%Mass*ubar2 )*propfac3
3185  else
3186  ubar2 = (+spb2_(ubar2,pmom3) + quarks(1)%Mass*ubar2 )*propfac3
3187  endif
3188 
3189  if( quarks(1)%PartType.lt.0 ) then
3190  eps1 = -vbqq(dv,u1,ubar2) ! re-checked
3191  else
3192  eps1 = +vbqq(dv,ubar2,u1) ! re-checked
3193  endif
3194 
3195  counter=1
3196  rin =1
3197  rout=na
3198  do i=rin,rout
3199  call copyparticleptr(gluons(i),tmpgluons(counter))
3200  counter=counter+1
3201  enddo
3202  tmpmom1(:) = pmom2(:)+pmom3(:)
3203  tmpextref1 = -1
3204  tmpgluons(counter)%Mom => tmpmom1(:)
3205  tmpgluons(counter)%Pol => eps1(:)
3206  tmpgluons(counter)%ExtRef => tmpextref1
3207  counter=counter+1
3208  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
3209  rout=numglu(0)-1
3210  do i=rin,rout
3211  call copyparticleptr(gluons(i),tmpgluons(counter))
3212  counter=counter+1
3213  enddo
3214  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
3215 
3216  if( na.ge.1 .or. nf.ge.1 ) then
3217  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3218  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3219  eps2 = eps2*propfac1
3220  endif
3221 
3222  res = res + eps2
3223  enddo
3224  enddo
3225  enddo
3226  endif! Bosonvertex
3227 
3228  if( bosonvertex.eq.1 .or. bosonvertex.eq.2 .or. bosonvertex .eq. 3) then
3229 ! type (2)
3230  do na=0,numglu(1)
3231  do nc=0,numglu(4)
3232  do ne=0,numglu(5)
3233  nb=numglu(1)-na
3234  nd=numglu(4)-nc
3235  nf=numglu(5)-ne
3236 
3237  rin = na+1
3238  rout= numglu(1)+numglu(2)+numglu(3)+nc
3239  bosonvertex_mod = bosonvertex + 1
3240 ! if (BosonVertex .eq. 1) BosonVertex_mod=BosonVertex
3241  u1 = cur_f_4fv(gluons(rin:rout),quarks(1:3),quarks(4)%PartType,boson,bosonvertex_mod,(/nb+numglu(2)+numglu(3)+nc,nb,numglu(2),numglu(3),nc/),0,0)
3242  pmom2 = summom(gluons,rin,rout) + quarks(1)%Mom + quarks(2)%Mom + quarks(3)%Mom + boson%Mom
3243  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
3244  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
3245  if( quarks(4)%PartType.lt.0 ) then
3246  u1 = (+spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
3247  else
3248  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
3249  endif
3250 
3251  rin = numglu(1)+numglu(2)+numglu(3)+nc+1
3252  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
3253  ubar2 = cur_f_2f(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,(/nd+ne,nd,ne/))
3254  pmom3 = summom(gluons,rin,rout) + quarks(4)%Mom
3255  if( nd.ge.1 .or. ne.ge.1 ) then
3256  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(4)%Mass2)
3257  if( abs(sc_(pmom3,pmom3) - quarks(4)%Mass2).lt.propcut ) cycle
3258  if( quarks(4)%PartType.lt.0 ) then
3259  ubar2 = (-spi2_(pmom3,ubar2) + quarks(4)%Mass*ubar2 )*propfac3
3260  else
3261  ubar2 = (+spb2_(ubar2,pmom3) + quarks(4)%Mass*ubar2 )*propfac3
3262  endif
3263  endif
3264 
3265  if( quarks(4)%PartType.lt.0 ) then
3266  eps1 = +vbqq(dv,u1,ubar2)
3267  else
3268  eps1 = -vbqq(dv,ubar2,u1)
3269  endif
3270 
3271  counter=1
3272  rin =1
3273  rout=na
3274  do i=rin,rout
3275  call copyparticleptr(gluons(i),tmpgluons(counter))
3276  counter=counter+1
3277  enddo
3278  tmpmom1(:) = pmom2(:)+pmom3(:)
3279  tmpextref1 = -1
3280  tmpgluons(counter)%Mom => tmpmom1(:)
3281  tmpgluons(counter)%Pol => eps1(:)
3282  tmpgluons(counter)%ExtRef => tmpextref1
3283  counter=counter+1
3284  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
3285  rout=numglu(0)-1
3286  do i=rin,rout
3287  call copyparticleptr(gluons(i),tmpgluons(counter))
3288  counter=counter+1
3289  enddo
3290  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
3291 
3292  if( na.ge.1 .or. nf.ge.1 ) then
3293  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3294  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3295  eps2 = eps2*propfac1
3296  endif
3297 
3298  res = res + eps2
3299 
3300  enddo
3301  enddo
3302  enddo
3303 
3304  endif ! BosonVertex
3305 
3306 
3307  if (bosonvertex .eq. 1 .or. bosonvertex .eq. 2 .or. bosonvertex .eq. 3 ) then
3308 
3309  do na=0,numglu(1)
3310  do nc=0,numglu(2)
3311  do ne=0,numglu(5)
3312  nb=numglu(1)-na
3313  nd=numglu(2)-nc
3314  nf=numglu(5)-ne
3315  rin = numglu(1)+nc+1
3316  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
3317  bosonvertex_mod=bosonvertex
3318  u1 = cur_f_4fv(gluons(rin:rout),quarks(2:4),quarks(1)%PartType,boson,bosonvertex_mod,(/nd+numglu(3)+numglu(4)+ne,nd,numglu(3),numglu(4),ne/),0,0)
3319  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + boson%Mom
3320  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(1)%Mass2)
3321  if( abs(sc_(pmom2,pmom2) - quarks(1)%Mass2).lt.propcut ) cycle
3322  if( quarks(1)%PartType.lt.0 ) then
3323  u1 = ( spb2_(u1,pmom2) + quarks(1)%Mass*u1 )*propfac2
3324  else
3325  u1 = (-spi2_(pmom2,u1) + quarks(1)%Mass*u1 )*propfac2
3326  endif
3327 
3328  rin = na+1
3329  rout= numglu(1)+nc
3330  ubar2 = cur_f_2f(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,(/nb+nc,nb,nc/))
3331  pmom3 = summom(gluons,rin,rout) + quarks(1)%Mom
3332  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(1)%Mass2)
3333  if ( nb .ge. 1 .or. nc .ge. 1) then
3334  if( abs(sc_(pmom3,pmom3) - quarks(1)%Mass2).lt.propcut ) cycle
3335  if( quarks(1)%PartType.lt.0 ) then
3336  ubar2 = (-spi2_(pmom3,ubar2) + quarks(1)%Mass*ubar2 )*propfac3
3337  else
3338  ubar2 = (+spb2_(ubar2,pmom3) + quarks(1)%Mass*ubar2 )*propfac3
3339  endif
3340  endif
3341 
3342  if( quarks(1)%PartType.lt.0 ) then
3343  eps1 = -vbqq(dv,u1,ubar2) ! re-checked
3344  else
3345  eps1 = +vbqq(dv,ubar2,u1) ! re-checked
3346  endif
3347 
3348  counter=1
3349  rin =1
3350  rout=na
3351  do i=rin,rout
3352  call copyparticleptr(gluons(i),tmpgluons(counter))
3353  counter=counter+1
3354  enddo
3355  tmpmom1(:) = pmom2(:)+pmom3(:)
3356  tmpextref1 = -1
3357  tmpgluons(counter)%Mom => tmpmom1(:)
3358  tmpgluons(counter)%Pol => eps1(:)
3359  tmpgluons(counter)%ExtRef => tmpextref1
3360  counter=counter+1
3361  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
3362  rout=numglu(0)-1
3363  do i=rin,rout
3364  call copyparticleptr(gluons(i),tmpgluons(counter))
3365  counter=counter+1
3366  enddo
3367  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
3368 
3369  if( na.ge.1 .or. nf.ge.1 ) then
3370  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3371  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3372  eps2 = eps2*propfac1
3373  endif
3374 
3375  res = res + eps2
3376  enddo
3377  enddo
3378  enddo
3379  endif! Bosonvertex
3380 
3381 
3382  if( bosonvertex.eq.3) then
3383 ! type (2)
3384  do na=0,numglu(1)
3385  do nc=0,numglu(4)
3386  do ne=0,numglu(5)
3387  nb=numglu(1)-na
3388  nd=numglu(4)-nc
3389  nf=numglu(5)-ne
3390 
3391  rin = na+1
3392  rout= numglu(1)+numglu(2)+numglu(3)+nc
3393  u1 = cur_f_4f(gluons(rin:rout),quarks(1:3),quarks(4)%PartType,(/nb+numglu(2)+numglu(3)+nc,nb,numglu(2),numglu(3),nc/),0,0)
3394  pmom2 = summom(gluons,rin,rout) + quarks(1)%Mom + quarks(2)%Mom + quarks(3)%Mom
3395  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
3396  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
3397  if( quarks(4)%PartType.lt.0 ) then
3398  u1 = (+spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
3399  else
3400  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
3401  endif
3402 
3403  rin = numglu(1)+numglu(2)+numglu(3)+nc+1
3404  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
3405  bosonvertex_mod = bosonvertex - 3
3406  ubar2 = cur_f_2fv(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,boson,(/nd+ne,nd,ne/))
3407  pmom3 = summom(gluons,rin,rout) + quarks(4)%Mom + boson%Mom
3408  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(4)%Mass2)
3409  if( abs(sc_(pmom3,pmom3) - quarks(4)%Mass2).lt.propcut ) cycle
3410  if( quarks(4)%PartType.lt.0 ) then
3411  ubar2 = (-spi2_(pmom3,ubar2) + quarks(4)%Mass*ubar2 )*propfac3
3412  else
3413  ubar2 = (+spb2_(ubar2,pmom3) + quarks(4)%Mass*ubar2 )*propfac3
3414  endif
3415 
3416  if( quarks(4)%PartType.lt.0 ) then
3417  eps1 = +vbqq(dv,u1,ubar2) ! re-checked
3418  else
3419  eps1 = -vbqq(dv,ubar2,u1) ! re-checked
3420  endif
3421 
3422  counter=1
3423  rin =1
3424  rout=na
3425  do i=rin,rout
3426  call copyparticleptr(gluons(i),tmpgluons(counter))
3427  counter=counter+1
3428  enddo
3429  tmpmom1(:) = pmom2(:)+pmom3(:)
3430  tmpextref1 = -1
3431  tmpgluons(counter)%Mom => tmpmom1(:)
3432  tmpgluons(counter)%Pol => eps1(:)
3433  tmpgluons(counter)%ExtRef => tmpextref1
3434  counter=counter+1
3435  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
3436  rout=numglu(0)-1
3437  do i=rin,rout
3438  call copyparticleptr(gluons(i),tmpgluons(counter))
3439  counter=counter+1
3440  enddo
3441  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
3442 
3443  if( na.ge.1 .or. nf.ge.1 ) then
3444  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3445  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3446  eps2 = eps2*propfac1
3447  endif
3448 
3449  res = res + eps2
3450  enddo
3451  enddo
3452  enddo
3453  endif! Bosonvertex
3454 
3455 
3456  if (bosonvertex .ne. 1 .and. bosonvertex .ne. 2 .and. bosonvertex .ne. 3) then
3457  print *, 'cur_g_4fV not implemented for this flavor choice and BosonVertex=', bosonvertex
3458  stop
3459  endif
3460 
3461  endif! Flavor check
3462 
3463  if( quarks(1)%PartType.eq.-quarks(2)%PartType .and. quarks(3)%PartType.eq.-quarks(4)%PartType) then
3464 
3465  if (bosonvertex .eq. 1 .or. bosonvertex .eq. 3) then
3466  do na=0,numglu(1)
3467  do nc=0,numglu(2)
3468  do ne=0,numglu(5)
3469 
3470  nb=numglu(1)-na
3471  nd=numglu(2)-nc
3472  nf=numglu(5)-ne
3473  rin = numglu(1)+nc+1
3474  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
3475  u1 = cur_f_4fv(gluons(rin:rout),quarks(2:4),quarks(1)%PartType,boson, bosonvertex,(/nd+numglu(3)+numglu(4)+ne,nd,numglu(3),numglu(4),ne/),0,0)
3476  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + boson%Mom
3477  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(1)%Mass2)
3478  if( abs(sc_(pmom2,pmom2) - quarks(1)%Mass2).lt.propcut ) cycle
3479  if( quarks(1)%PartType.lt.0 ) then
3480  u1 = ( spb2_(u1,pmom2) + quarks(1)%Mass*u1 )*propfac2
3481  else
3482  u1 = (-spi2_(pmom2,u1) + quarks(1)%Mass*u1 )*propfac2
3483  endif
3484 
3485  rin = na+1
3486  rout= numglu(1)+nc
3487  ubar2 = cur_f_2f(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,(/nb+nc,nb,nc/))
3488  pmom3 = summom(gluons,rin,rout) + quarks(1)%Mom
3489  if( nb.ge.1 .or. nc.ge.1 ) then
3490  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(1)%Mass2)
3491  if( abs(sc_(pmom3,pmom3) - quarks(1)%Mass2).lt.propcut ) cycle
3492  if( quarks(1)%PartType.lt.0 ) then
3493  ubar2 = (-spi2_(pmom3,ubar2) + quarks(1)%Mass*ubar2 )*propfac3
3494  else
3495  ubar2 = (+spb2_(ubar2,pmom3) + quarks(1)%Mass*ubar2 )*propfac3
3496  endif
3497  endif
3498 
3499  if( quarks(1)%PartType.lt.0 ) then
3500  eps1 = -vbqq(dv,u1,ubar2) ! re-checked
3501  else
3502  eps1 = +vbqq(dv,ubar2,u1) ! re-checked
3503  endif
3504 
3505  counter=1
3506  rin =1
3507  rout=na
3508  do i=rin,rout
3509  call copyparticleptr(gluons(i),tmpgluons(counter))
3510  counter=counter+1
3511  enddo
3512  tmpmom1(:) = pmom2(:)+pmom3(:)
3513  tmpextref1 = -1
3514  tmpgluons(counter)%Mom => tmpmom1(:)
3515  tmpgluons(counter)%Pol => eps1(:)
3516  tmpgluons(counter)%ExtRef => tmpextref1
3517  counter=counter+1
3518  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
3519  rout=numglu(0)-1
3520  do i=rin,rout
3521  call copyparticleptr(gluons(i),tmpgluons(counter))
3522  counter=counter+1
3523  enddo
3524  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
3525 
3526  if( na.ge.1 .or. nf.ge.1 ) then
3527  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3528  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3529  eps2 = eps2*propfac1
3530  endif
3531 
3532  res = res + eps2
3533  enddo
3534  enddo
3535  enddo
3536  endif
3537 
3538  if (bosonvertex .eq. 1) then
3539  do na=0,numglu(1)
3540  do nc=0,numglu(2)
3541  do ne=0,numglu(5)
3542  nb=numglu(1)-na
3543  nd=numglu(2)-nc
3544  nf=numglu(5)-ne
3545  rin = numglu(1)+nc+1
3546  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
3547  u1 = cur_f_4f(gluons(rin:rout),quarks(2:4),quarks(1)%PartType,(/nd+numglu(3)+numglu(4)+ne,nd,numglu(3),numglu(4),ne/),0,0)
3548  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom
3549  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(1)%Mass2)
3550  if( abs(sc_(pmom2,pmom2) - quarks(1)%Mass2).lt.propcut ) cycle
3551  if( quarks(1)%PartType.lt.0 ) then
3552  u1 = ( spb2_(u1,pmom2) + quarks(1)%Mass*u1 )*propfac2
3553  else
3554  u1 = (-spi2_(pmom2,u1) + quarks(1)%Mass*u1 )*propfac2
3555  endif
3556 
3557  rin = na+1
3558  rout= numglu(1)+nc
3559  ubar2 = cur_f_2fv(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,boson,(/nb+nc,nb,nc/))
3560  pmom3 = summom(gluons,rin,rout) + quarks(1)%Mom + boson%Mom
3561  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(1)%Mass2)
3562  if( abs(sc_(pmom3,pmom3) - quarks(1)%Mass2).lt.propcut ) cycle
3563  if( quarks(1)%PartType.lt.0 ) then
3564  ubar2 = (-spi2_(pmom3,ubar2) + quarks(1)%Mass*ubar2 )*propfac3
3565  else
3566  ubar2 = (+spb2_(ubar2,pmom3) + quarks(1)%Mass*ubar2 )*propfac3
3567  endif
3568 
3569  if( quarks(1)%PartType.lt.0 ) then
3570  eps1 = -vbqq(dv,u1,ubar2) ! re-checked
3571  else
3572  eps1 = +vbqq(dv,ubar2,u1) ! re-checked
3573  endif
3574 
3575  counter=1
3576  rin =1
3577  rout=na
3578  do i=rin,rout
3579  call copyparticleptr(gluons(i),tmpgluons(counter))
3580  counter=counter+1
3581  enddo
3582  tmpmom1(:) = pmom2(:)+pmom3(:)
3583  tmpextref1 = -1
3584  tmpgluons(counter)%Mom => tmpmom1(:)
3585  tmpgluons(counter)%Pol => eps1(:)
3586  tmpgluons(counter)%ExtRef => tmpextref1
3587  counter=counter+1
3588  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
3589  rout=numglu(0)-1
3590  do i=rin,rout
3591  call copyparticleptr(gluons(i),tmpgluons(counter))
3592  counter=counter+1
3593  enddo
3594  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
3595 
3596  if( na.ge.1 .or. nf.ge.1 ) then
3597  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3598  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3599  eps2 = eps2*propfac1
3600  endif
3601 
3602  res = res + eps2
3603  enddo
3604  enddo
3605  enddo
3606  endif
3607 
3608 
3609  if (bosonvertex .eq. 1 .or. bosonvertex .eq. 3) then
3610 ! type (3)
3611  do na=0,numglu(1)
3612  do nc=0,numglu(4)
3613  do ne=0,numglu(5) ! can be replaced by above ne-loop
3614  nb=numglu(1)-na
3615  nd=numglu(4)-nc
3616  nf=numglu(5)-ne
3617 
3618  rin = na+1
3619  rout= numglu(1)+numglu(2)+numglu(3)+nc
3620  bosonvertex_mod=bosonvertex+1
3621  u1 = cur_f_4fv(gluons(rin:rout),quarks(1:3),quarks(4)%PartType,boson,bosonvertex_mod,(/nb+numglu(2)+numglu(3)+nc,nb,numglu(2),numglu(3),nc/),0,0)
3622  pmom2 = summom(gluons,rin,rout) + quarks(1)%Mom + quarks(2)%Mom + quarks(3)%Mom + boson%Mom
3623  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
3624  if ( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) then
3625  cycle
3626  endif
3627  if( quarks(4)%PartType.lt.0 ) then
3628  u1 = (+spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
3629  else
3630  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
3631  endif
3632  rin = numglu(1)+numglu(2)+numglu(3)+nc+1
3633  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
3634  ubar2 = cur_f_2f(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,(/nd+ne,nd,ne/))
3635  pmom3 = summom(gluons,rin,rout) + quarks(4)%Mom
3636  if( nd.ge.1 .or. ne.ge.1 ) then
3637  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(4)%Mass2)
3638  if( abs(sc_(pmom3,pmom3) - quarks(4)%Mass2).lt.propcut ) cycle
3639  if( quarks(4)%PartType.lt.0 ) then
3640  ubar2 = (-spi2_(pmom3,ubar2) + quarks(4)%Mass*ubar2 )*propfac3
3641  else
3642  ubar2 = (+spb2_(ubar2,pmom3) + quarks(4)%Mass*ubar2 )*propfac3
3643  endif
3644  endif
3645 
3646  if( quarks(4)%PartType.lt.0 ) then
3647  eps1 = +vbqq(dv,u1,ubar2) ! re-checked
3648  else
3649  eps1 = -vbqq(dv,ubar2,u1) ! re-checked
3650  endif
3651 
3652  counter=1
3653  rin =1
3654  rout=na
3655  do i=rin,rout
3656  call copyparticleptr(gluons(i),tmpgluons(counter))
3657  counter=counter+1
3658  enddo
3659  tmpmom1(:) = pmom2(:)+pmom3(:)
3660  tmpextref1 = -1
3661  tmpgluons(counter)%Mom => tmpmom1(:)
3662  tmpgluons(counter)%Pol => eps1(:)
3663  tmpgluons(counter)%ExtRef => tmpextref1
3664  counter=counter+1
3665  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
3666  rout=numglu(0)-1
3667  do i=rin,rout
3668  call copyparticleptr(gluons(i),tmpgluons(counter))
3669  counter=counter+1
3670  enddo
3671  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
3672 
3673  if( na.ge.1 .or. nf.ge.1 ) then
3674  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3675  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3676  eps2 = eps2*propfac1
3677  endif
3678 
3679  res = res + eps2
3680  enddo
3681  enddo
3682  enddo
3683  endif
3684 
3685  if (bosonvertex .eq. 1) then
3686 ! type(4)
3687  do na=0,numglu(1)
3688  do nc=0,numglu(2)
3689  do ne=0,numglu(3)
3690  do nf=0,numglu(3)-ne
3691  do nh=0,numglu(4) ! this loop can be placed after Eps1 has been calculated
3692  do nj=0,numglu(5)
3693  nb=numglu(1)-na
3694  nd=numglu(2)-nc
3695  ng=numglu(3)-ne-nf
3696  ni=numglu(4)-nh
3697  nk=numglu(5)-nj
3698 
3699  rin = na+1
3700  rout= numglu(1)+numglu(2)+ne
3701  eps1 = cur_g_2fv(gluons(rin:rout),quarks(1:2),boson,(/1+nb+nc+nd+ne,nc,nc+nd,ne/) )
3702  tmpmom1 = summom(gluons,rin,rout) + quarks(1)%Mom + quarks(2)%Mom + boson%Mom
3703  propfac3 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3704  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3705  eps1 = eps1*propfac3
3706 
3707  rin = numglu(1)+numglu(2)+ne+nf+1
3708  rout= numglu(1)+numglu(2)+numglu(3)+nh
3709  u1 = cur_f_2f(gluons(rin:rout),quarks(3:3),-quarks(3)%PartType,(/ng+nh,ng,nh/))
3710  pmom3 = summom(gluons,rin,rout) + quarks(3)%Mom
3711  if( ng.ge.1 .or. nh.ge.1 ) then
3712  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(3)%Mass2)
3713  if( abs(sc_(pmom3,pmom3) - quarks(3)%Mass2).lt.propcut ) cycle
3714  if( quarks(3)%PartType.lt.0 ) then
3715  u1 = (-spi2_(pmom3,u1) + quarks(3)%Mass*u1 )*propfac3
3716  else
3717  u1 = (+spb2_(u1,pmom3) + quarks(3)%Mass*u1 )*propfac3
3718  endif
3719  endif
3720  rin = numglu(1)+numglu(2)+numglu(3)+nh+1
3721  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+nj
3722  ubar2 = cur_f_2f(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,(/ni+nj,ni,nj/))
3723  pmom4 = summom(gluons,rin,rout) + quarks(4)%Mom
3724  if( ni.ge.1 .or. nj.ge.1 ) then
3725  propfac4 = (0d0,1d0)/(sc_(pmom4,pmom4) - quarks(4)%Mass2)
3726  if( abs(sc_(pmom4,pmom4) - quarks(4)%Mass2).lt.propcut ) cycle
3727  if( quarks(4)%PartType.lt.0 ) then
3728  ubar2 = (-spi2_(pmom4,ubar2) + quarks(4)%Mass*ubar2 )*propfac4
3729  else
3730  ubar2 = (+spb2_(ubar2,pmom4) + quarks(4)%Mass*ubar2 )*propfac4
3731  endif
3732  endif
3733 
3734  if( quarks(4)%PartType.lt.0 ) then
3735  eps2 = +vbqq(dv,u1,ubar2) ! re-checked
3736  else
3737  eps2 = -vbqq(dv,ubar2,u1) ! re-checked
3738  endif
3739  tmpmom2 = pmom3 + pmom4
3740  propfac1 = (0d0,-1d0)/sc_(tmpmom2,tmpmom2)
3741  if( abs(sc_(tmpmom2,tmpmom2)).lt.propcut ) cycle
3742  eps2 = eps2*propfac1
3743 
3744 
3745  counter=1
3746  rin =1
3747  rout=na
3748  do i=rin,rout
3749  call copyparticleptr(gluons(i),tmpgluons(counter))
3750  counter=counter+1
3751  enddo
3752  tmpextref1 = -1
3753  tmpgluons(counter)%Mom => tmpmom1(:)
3754  tmpgluons(counter)%Pol => eps1(:)
3755  tmpgluons(counter)%ExtRef => tmpextref1
3756  counter=counter+1
3757  rin =numglu(1)+numglu(2)+ne+1
3758  rout=numglu(1)+numglu(2)+ne+nf
3759  do i=rin,rout
3760  call copyparticleptr(gluons(i),tmpgluons(counter))
3761  counter=counter+1
3762  enddo
3763  tmpgluons(counter)%Mom => tmpmom2(:)
3764  tmpgluons(counter)%Pol => eps2(:)
3765  tmpgluons(counter)%ExtRef => tmpextref1
3766  counter=counter+1
3767  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+nj+1
3768  rout=numglu(0)-1
3769  do i=rin,rout
3770  call copyparticleptr(gluons(i),tmpgluons(counter))
3771  counter=counter+1
3772  enddo
3773  eps3(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+nk+2)
3774  res = res + eps3
3775  enddo
3776  enddo
3777  enddo
3778  enddo
3779  enddo
3780  enddo
3781  endif
3782 
3783  if (bosonvertex .eq. 3) then
3784 
3785  do na=0,numglu(1)
3786  do nc=0,numglu(4)
3787  do ne=0,numglu(5) ! can be replaced by above ne-loop
3788  nb=numglu(1)-na
3789  nd=numglu(4)-nc
3790  nf=numglu(5)-ne
3791 
3792  rin = na+1
3793  rout= numglu(1)+numglu(2)+numglu(3)+nc
3794  u1 = cur_f_4f(gluons(rin:rout),quarks(1:3),quarks(4)%PartType,(/nb+numglu(2)+numglu(3)+nc,nb,numglu(2),numglu(3),nc/),0,0)
3795  pmom2 = summom(gluons,rin,rout) + quarks(1)%Mom + quarks(2)%Mom + quarks(3)%Mom
3796  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
3797  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
3798  if( quarks(4)%PartType.lt.0 ) then
3799  u1 = (+spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
3800  else
3801  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
3802  endif
3803  rin = numglu(1)+numglu(2)+numglu(3)+nc+1
3804  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne
3805  ubar2 = cur_f_2fv(gluons(rin:rout),quarks(4:4),-quarks(4)%PartType,boson,(/nd+ne,nd,ne/))
3806  pmom3 = summom(gluons,rin,rout) + quarks(4)%Mom + boson%Mom
3807  propfac3 = (0d0,1d0)/(sc_(pmom3,pmom3) - quarks(4)%Mass2)
3808  if( abs(sc_(pmom3,pmom3) - quarks(4)%Mass2).lt.propcut ) cycle
3809  if( quarks(4)%PartType.lt.0 ) then
3810  ubar2 = (-spi2_(pmom3,ubar2) + quarks(4)%Mass*ubar2 )*propfac3
3811  else
3812  ubar2 = (+spb2_(ubar2,pmom3) + quarks(4)%Mass*ubar2 )*propfac3
3813  endif
3814 
3815  if( quarks(4)%PartType.lt.0 ) then
3816  eps1 = +vbqq(dv,u1,ubar2) ! re-checked
3817  else
3818  eps1 = -vbqq(dv,ubar2,u1) ! re-checked
3819  endif
3820 
3821  counter=1
3822  rin =1
3823  rout=na
3824  do i=rin,rout
3825  call copyparticleptr(gluons(i),tmpgluons(counter))
3826  counter=counter+1
3827  enddo
3828  tmpmom1(:) = pmom2(:)+pmom3(:)
3829  tmpextref1 = -1
3830  tmpgluons(counter)%Mom => tmpmom1(:)
3831  tmpgluons(counter)%Pol => eps1(:)
3832  tmpgluons(counter)%ExtRef => tmpextref1
3833  counter=counter+1
3834  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+ne+1
3835  rout=numglu(0)-1
3836  do i=rin,rout
3837  call copyparticleptr(gluons(i),tmpgluons(counter))
3838  counter=counter+1
3839  enddo
3840  eps2(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+1)
3841 
3842  if( na.ge.1 .or. nf.ge.1 ) then
3843  propfac1 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3844  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3845  eps2 = eps2*propfac1
3846  endif
3847 
3848  res = res + eps2
3849  enddo
3850  enddo
3851  enddo
3852  endif
3853 
3854  if (bosonvertex .eq. 3) then
3855 
3856  do na=0,numglu(1)
3857  do nc=0,numglu(2)
3858  do ne=0,numglu(3)
3859  do nf=0,numglu(3)-ne
3860  do nh=0,numglu(4) ! this loop can be placed after Eps1 has been calculated
3861  do nj=0,numglu(5)
3862  nb=numglu(1)-na
3863  nd=numglu(2)-nc
3864  ng=numglu(3)-ne-nf
3865  ni=numglu(4)-nh
3866  nk=numglu(5)-nj
3867 
3868  rin = na+1
3869  rout= numglu(1)+nc
3870  ubar2 = cur_f_2f(gluons(rin:rout),quarks(1:1),-quarks(1)%PartType,(/nb+nc,nb,nc/))
3871  pmom1 = summom(gluons,rin,rout) + quarks(1)%Mom
3872  if( nb.ge.1 .or. nc.ge.1 ) then
3873  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1) - quarks(1)%Mass2)
3874  if( abs(sc_(pmom1,pmom1) - quarks(1)%Mass2).lt.propcut ) cycle
3875  if( quarks(1)%PartType.lt.0 ) then
3876  ubar2 = (-spi2_(pmom1,ubar2) + quarks(1)%Mass*ubar2 )*propfac1
3877  else
3878  ubar2 = (+spb2_(ubar2,pmom1) + quarks(1)%Mass*ubar2 )*propfac1
3879  endif
3880  endif
3881  rin = numglu(1)+nc+1
3882  rout= numglu(1)+numglu(2)+ne
3883  u1 = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/nd+ne,nd,ne/))
3884  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom
3885  if( nd.ge.1 .or. ne.ge.1 ) then
3886  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
3887  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
3888  if( quarks(2)%PartType.lt.0 ) then
3889  u1 = (-spi2_(pmom2,u1) + quarks(2)%Mass*u1 )*propfac2
3890  else
3891  u1 = (+spb2_(u1,pmom2) + quarks(2)%Mass*u1 )*propfac2
3892  endif
3893  endif
3894 
3895  if( quarks(2)%PartType.lt.0 ) then
3896  eps1 = +vbqq(dv,ubar2,u1) ! re-checked
3897  else
3898  eps1 = -vbqq(dv,u1,ubar2) ! re-checked
3899  endif
3900  tmpmom1 = pmom1 + pmom2
3901  propfac3 = (0d0,-1d0)/sc_(tmpmom1,tmpmom1)
3902  if( abs(sc_(tmpmom1,tmpmom1)).lt.propcut ) cycle
3903  eps1 = eps1*propfac3
3904 
3905  rin = numglu(1)+numglu(2)+ne+nf+1
3906  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+nj
3907  eps2=cur_g_2fv(gluons(rin:rout),quarks(3:4),boson,(/1+ng+nh+ni+nj,ng,nh,ni,nj /) )
3908  tmpmom2 = summom(gluons,rin,rout) +quarks(3)%Mom + quarks(4)%Mom + boson%Mom
3909  propfac1 = (0d0,-1d0)/sc_(tmpmom2,tmpmom2)
3910  if( abs(sc_(tmpmom2,tmpmom2)).lt.propcut ) cycle
3911  eps2 = eps2*propfac1
3912 
3913  counter=1
3914  rin =1
3915  rout=na
3916  do i=rin,rout
3917  call copyparticleptr(gluons(i),tmpgluons(counter))
3918  counter=counter+1
3919  enddo
3920  tmpextref1 = -1
3921  tmpgluons(counter)%Mom => tmpmom1(:)
3922  tmpgluons(counter)%Pol => eps1(:)
3923  tmpgluons(counter)%ExtRef => tmpextref1
3924  counter=counter+1
3925  rin =numglu(1)+numglu(2)+ne+1
3926  rout=numglu(1)+numglu(2)+ne+nf
3927  do i=rin,rout
3928  call copyparticleptr(gluons(i),tmpgluons(counter))
3929  counter=counter+1
3930  enddo
3931  tmpgluons(counter)%Mom => tmpmom2(:)
3932  tmpgluons(counter)%Pol => eps2(:)
3933  tmpgluons(counter)%ExtRef => tmpextref1
3934  counter=counter+1
3935  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+nj+1
3936  rout=numglu(0)-1
3937  do i=rin,rout
3938  call copyparticleptr(gluons(i),tmpgluons(counter))
3939  counter=counter+1
3940  enddo
3941  eps3(:) = cur_g(tmpgluons(1:counter-1),1+na+nf+nk+2)
3942  res = res + eps3
3943 
3944  enddo
3945  enddo
3946  enddo
3947 enddo
3948 enddo
3949 enddo
3950 
3951 endif ! BosonVertex
3952 
3953 
3954 if (bosonvertex .ne. 1 .and. bosonvertex .ne. 3) then
3955  print *, 'Not implemented for for cur_g_4fV for this flavor structure and BosonVertex=', bosonvertex
3956  stop
3957 endif
3958 endif
3959 
3960 return
3961 END FUNCTION
3962 
3963 
3964 
3965 
3966 
3967 
3968 
3969 
3970 
3971 
3972 
3973 FUNCTION cur_f_6fv(Gluons,Quarks,Quark1PartType,Boson,BosonVertex,NumGlu,tag_f) result(res) ! Quarks(:) does not include the OFF-shell quark
3974 implicit none
3975 integer :: numglu(0:6),quark1parttype,tag_f,bosonvertex,bosonvertex_mod
3976 type(ptrtoparticle) :: gluons(1:),quarks(2:6),boson
3977 integer,target :: tmpparttype,tmpextref
3978 complex(8) :: res(1:ds),tmp(1:ds)
3979 ! complex(8) :: Res1(1:Ds),Res2(1:Ds),Res3(1:Ds),Res4(1:Ds)
3980 complex(8) :: u1(1:ds),ubar1(1:ds)
3981 complex(8),target :: ubar0(1:ds)
3982 complex(8) :: eps1(1:dv)
3983 complex(8) :: eps2(1:dv)
3984 type(ptrtoparticle) :: tmpgluons(1:numglu(1)+numglu(6)),tmpquark(1:1)
3985 complex(8) :: propfac1,propfac2
3986 complex(8),target :: pmom1(1:dv)
3987 complex(8),target :: pmom2(1:dv)
3988 integer :: n1a,n1b,n2a,n2b,n3a,n3b,n4a,n4b,n5a,n5b,n6a,n6b
3989 integer :: rin,rout,i,counter
3990 
3991 
3992 !DEC$ IF (_DebugCheckMyImpl1==1)
3993  if( numglu(0)-numglu(1)-numglu(2)-numglu(3)-numglu(4)-numglu(5)-numglu(6).ne.0 ) print *, "wrong number of gluons in cur_f_6fV"
3994 !DEC$ ENDIF
3995 
3996  res = (0d0,0d0)
3997 
3998 
3999 ! -- not all possible choices of flavors and BosonVertex values are used in ttb+Z calculation. This warns you if you try to use something new and potentially buggy.
4000  if (quark1parttype.eq.-quarks(2)%PartType) then
4001  if ( ((quarks(3)%PartType.eq.-quarks(4)%PartType) .AND. (bosonvertex .eq. 2 .OR.bosonvertex .eq. 4 .OR.bosonvertex .eq. 6)) .OR. &
4002  ((quarks(3)%PartType.eq.-quarks(6)%PartType) .AND. (bosonvertex .eq. 2 .OR.bosonvertex .eq. 6)) ) then
4003  print *, 'WARNING : cur_f_6fV with this flavor structure and this choice of BosonVertex is implemented, but not checked!'
4004  print *, 'Quark flavors: ',quark1parttype, quarks(2)%PartType,quarks(3)%PartType,quarks(4)%PartType,quarks(5)%PartType,quarks(6)%PartType
4005  print *, 'BosonVertex =', bosonvertex
4006  endif
4007  elseif (quark1parttype.eq.-quarks(6)%PartType ) then
4008  if ( ((quark1parttype.eq.-quarks(2)%PartType) .AND. (bosonvertex .eq. 2 .or. bosonvertex .eq. 4 .or. bosonvertex .eq. 6)) .OR. &
4009  & ((quark1parttype.eq.-quarks(4)%PartType) .AND. (bosonvertex .eq. 4 .or. bosonvertex .eq. 6)) ) then
4010  print *, 'WARNING : cur_f_6fV with this flavor structure and this choice of BosonVertex is implemented, but not checked!'
4011  print *, 'Quark flavors: ',quark1parttype, quarks(2)%PartType,quarks(3)%PartType,quarks(4)%PartType,quarks(5)%PartType,quarks(6)%PartType
4012  print *, 'BosonVertex =', bosonvertex
4013  endif
4014  elseif (quarks(2)%PartType.eq.-quarks(3)%PartType) then
4015  if ( ((quark1parttype.eq.-quarks(4)%PartType) .AND. (bosonvertex .eq. 4 .or. bosonvertex .eq. 6) ) .OR. &
4016  ((quark1parttype.eq.-quarks(6)%PartType) .AND. (bosonvertex .eq. 4 .or. bosonvertex .eq. 6) ) ) then
4017  print *, 'WARNING : cur_f_6fV with this flavor structure and this choice of BosonVertex is implemented, but not checked!'
4018  print *, 'Quark flavors: ',quark1parttype, quarks(2)%PartType,quarks(3)%PartType,quarks(4)%PartType,quarks(5)%PartType,quarks(6)%PartType
4019  print *, 'BosonVertex =', bosonvertex
4020  endif
4021  endif
4022 
4023 
4024 ! probably some tag_Z checks are needed here: not yet implemented
4025 
4026 
4027 ! (A)
4028  if( quark1parttype.eq.-quarks(2)%PartType .AND. (quarks(3)%PartType.eq.-quarks(4)%PartType .or. quarks(3)%PartType.eq.-quarks(6)%PartType) &
4029  .AND. (quarks(2)%ExtRef.ne.-1 .or. tag_f.ne.1) &
4030  .AND. ( bosonvertex.eq.1 .OR. bosonvertex.eq.2) &
4031  ) then
4032 ! print *, 'A-1'
4033  do n2a=0,numglu(2)
4034  do n6a=0,numglu(6)
4035  n2b = numglu(2)-n2a
4036  n6b = numglu(6)-n6a
4037 
4038  rin =numglu(1)+n2a+1
4039  rout=numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4040  eps2 = cur_g_4f(gluons(rin:rout),quarks(3:6),(/1+n2b+numglu(3)+numglu(4)+numglu(5)+n6a,n2b,numglu(3),numglu(4),numglu(5),n6a/))
4041  pmom1(:) = summom(gluons,rin,rout) + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom
4042  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
4043  if( abs(sc_(pmom1,pmom1)).lt.propcut) cycle
4044  eps2 = eps2*propfac1
4045  do n1a=0,numglu(1)
4046  n1b = numglu(1)-n1a
4047  ! Fer2 couple V on the top
4048  rin =n1a+1
4049  rout=numglu(1)+n2a
4050  if (bosonvertex .eq. 1 .or. bosonvertex .eq. 2) then
4051  ubar1(:) = cur_f_2fv(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,boson,(/n1b+n2a,n1b,n2a/) )
4052  pmom2(:) = quarks(2)%Mom + summom(gluons,rin,rout) + boson%Mom
4053  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
4054  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) then
4055  propfac2=(0d0,0d0)
4056  endif
4057 
4058  if( quarks(2)%PartType.lt.0 ) then
4059  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(2)%Mass*ubar1(:))*propfac2
4060  else
4061  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(2)%Mass*ubar1(:))*propfac2
4062  endif
4063  if( quarks(2)%PartType.lt.0 ) then
4064  ubar0(:) = vbqg(ubar1,eps2)
4065  else
4066  ubar0(:) = vqg(ubar1,eps2)
4067  endif
4068 
4069  rin = n1a+1
4070  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4071  pmom1 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom + boson%Mom ! can be simplified with PMom1(:)
4072  if(n1a.ge.1 .or. n6b.ge.1) then
4073  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(2)%Mass2)
4074  if( abs(sc_(pmom1,pmom1)-quarks(2)%Mass2).lt.propcut ) then
4075  propfac1=(0d0,0d0)
4076  endif
4077 
4078  if( quarks(2)%PartType.lt.0 ) then
4079  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(2)%Mass*ubar0(:))*propfac1
4080  else
4081  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(2)%Mass*ubar0(:))*propfac1
4082  endif
4083  endif
4084 
4085  tmpquark(1)%Mom => pmom1(:)
4086  tmpquark(1)%Pol => ubar0(:)
4087  tmpquark(1)%Mass => quarks(2)%Mass
4088  tmpquark(1)%Mass2=> quarks(2)%Mass2
4089  tmpextref = -1
4090  tmpquark(1)%ExtRef => tmpextref
4091  tmpquark(1)%PartType => quarks(2)%PartType
4092  counter=1
4093  rin =1
4094  rout=n1a
4095  do i=rin,rout
4096  call copyparticleptr(gluons(i),tmpgluons(counter))
4097  counter=counter+1
4098  enddo
4099  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4100  rout=numglu(0)
4101  do i=rin,rout
4102  call copyparticleptr(gluons(i),tmpgluons(counter))
4103  counter=counter+1
4104  enddo
4105  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n6b/) )
4106  res(:) = res(:) + tmp(:)
4107  endif
4108  if (bosonvertex .eq. 1 .or. bosonvertex .eq. 6) then
4109  ! Fer2 couple V on the bottom
4110  rin =n1a+1
4111  rout=numglu(1)+n2a
4112  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/n1b+n2a,n1b,n2a/) )
4113  if(n1b.ge.1 .or. n2a.ge.1) then
4114  pmom2(:) = quarks(2)%Mom + summom(gluons,rin,rout)
4115  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
4116  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) cycle
4117  if( quarks(2)%PartType.lt.0 ) then
4118  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(2)%Mass*ubar1(:))*propfac2
4119  else
4120  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(2)%Mass*ubar1(:))*propfac2
4121  endif
4122  endif
4123  if( quarks(2)%PartType.lt.0 ) then
4124  ubar0(:) = vbqg(ubar1,eps2) ! re-checked
4125  else
4126  ubar0(:) = vqg(ubar1,eps2) ! re-checked
4127  endif
4128 
4129  rin = n1a+1
4130  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4131  pmom1 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom
4132 
4133  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(2)%Mass2)
4134  if( abs(sc_(pmom1,pmom1)-quarks(2)%Mass2).lt.propcut ) cycle
4135  if( quarks(2)%PartType.lt.0 ) then
4136  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(2)%Mass*ubar0(:))*propfac1
4137  else
4138  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(2)%Mass*ubar0(:))*propfac1
4139  endif
4140 
4141  tmpquark(1)%Mom => pmom1(:)
4142  tmpquark(1)%Pol => ubar0(:)
4143  tmpquark(1)%Mass => quarks(2)%Mass
4144  tmpquark(1)%Mass2=> quarks(2)%Mass2
4145  tmpextref = -1
4146  tmpquark(1)%ExtRef => tmpextref
4147  tmpquark(1)%PartType => quarks(2)%PartType
4148  counter=1
4149  rin =1
4150  rout=n1a
4151  do i=rin,rout
4152  call copyparticleptr(gluons(i),tmpgluons(counter))
4153  counter=counter+1
4154  enddo
4155  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4156  rout=numglu(0)
4157  do i=rin,rout
4158  call copyparticleptr(gluons(i),tmpgluons(counter))
4159  counter=counter+1
4160  enddo
4161  tmp(:) = cur_f_2fv(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,boson,(/counter-1,n1a,n6b/) )
4162  res(:) = res(:) + tmp(:)
4163  endif
4164  enddo
4165  enddo
4166  enddo
4167  endif
4168 
4169 
4170 
4171 ! (A)
4172  if( quark1parttype.eq.-quarks(2)%PartType .AND. (quarks(3)%PartType.eq.-quarks(4)%PartType .or. quarks(3)%PartType.eq.-quarks(6)%PartType) &
4173  .AND. (quarks(2)%ExtRef.ne.-1 .or. tag_f.ne.1) &
4174  .AND. ( bosonvertex.eq.3 .OR. bosonvertex .eq. 4 .OR. bosonvertex.eq.5 ) &
4175  ) then
4176 ! print *, 'A-2'
4177  do n2a=0,numglu(2)
4178  do n6a=0,numglu(6)
4179  n2b = numglu(2)-n2a
4180  n6b = numglu(6)-n6a
4181 
4182  rin =numglu(1)+n2a+1
4183  rout=numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4184  bosonvertex_mod = bosonvertex - 2
4185  eps2 = cur_g_4fv(gluons(rin:rout),quarks(3:6),boson,bosonvertex_mod,(/1+n2b+numglu(3)+numglu(4)+numglu(5)+n6a,n2b,numglu(3),numglu(4),numglu(5),n6a/))
4186  pmom1(:) = summom(gluons,rin,rout) + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom + boson%Mom
4187  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
4188  if( abs(sc_(pmom1,pmom1)).lt.propcut) cycle
4189  eps2 = eps2*propfac1
4190  do n1a=0,numglu(1)
4191  n1b = numglu(1)-n1a
4192  ! Fer2
4193  rin =n1a+1
4194  rout=numglu(1)+n2a
4195  ubar1(:) = cur_f_2f(gluons(rin:rout),quarks(2:2),-quarks(2)%PartType,(/n1b+n2a,n1b,n2a/) )
4196  if(n1b.ge.1 .or. n2a.ge.1) then
4197  pmom2(:) = quarks(2)%Mom + summom(gluons,rin,rout)
4198  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2)-quarks(2)%Mass2)
4199  if( abs(sc_(pmom2,pmom2)-quarks(2)%Mass2).lt.propcut ) cycle
4200  if( quarks(2)%PartType.lt.0 ) then
4201  ubar1(:) = (-spi2_(pmom2,ubar1)+quarks(2)%Mass*ubar1(:))*propfac2
4202  else
4203  ubar1(:) = (+spb2_(ubar1,pmom2)+quarks(2)%Mass*ubar1(:))*propfac2
4204  endif
4205  endif
4206  if( quarks(2)%PartType.lt.0 ) then
4207  ubar0(:) = vbqg(ubar1,eps2)
4208  else
4209  ubar0(:) = vqg(ubar1,eps2)
4210  endif
4211 
4212  rin = n1a+1
4213  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4214  pmom1 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom + boson%Mom
4215  if(n1a.ge.1 .or. n6b.ge.1) then
4216  propfac1 = (0d0,1d0)/(sc_(pmom1,pmom1)-quarks(2)%Mass2)
4217  if( abs(sc_(pmom1,pmom1)-quarks(2)%Mass2).lt.propcut ) cycle
4218  if( quarks(2)%PartType.lt.0 ) then
4219  ubar0(:) = (-spi2_(pmom1,ubar0)+quarks(2)%Mass*ubar0(:))*propfac1
4220  else
4221  ubar0(:) = (+spb2_(ubar0,pmom1)+quarks(2)%Mass*ubar0(:))*propfac1
4222  endif
4223  endif
4224 
4225  tmpquark(1)%Mom => pmom1(:)
4226  tmpquark(1)%Pol => ubar0(:)
4227  tmpquark(1)%Mass => quarks(2)%Mass
4228  tmpquark(1)%Mass2=> quarks(2)%Mass2
4229  tmpextref = -1
4230  tmpquark(1)%ExtRef => tmpextref
4231  tmpquark(1)%PartType => quarks(2)%PartType
4232  counter=1
4233  rin =1
4234  rout=n1a
4235  do i=rin,rout
4236  call copyparticleptr(gluons(i),tmpgluons(counter))
4237  counter=counter+1
4238  enddo
4239  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4240  rout=numglu(0)
4241  do i=rin,rout
4242  call copyparticleptr(gluons(i),tmpgluons(counter))
4243  counter=counter+1
4244  enddo
4245  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),-tmpquark(1)%PartType,(/counter-1,n1a,n6b/) )
4246  res(:) = res(:) + tmp(:)
4247 
4248  enddo
4249  enddo
4250  enddo
4251  endif
4252 
4253 
4254 
4255 ! (B)
4256 !! RR -- I think that only times this will be called in ttbZ will be color-zero in any case (tadpoles), so I'm going to just comment it out.
4257 !! I imagine that if implemented correctly, then the it would return zero for ttbZ for kinematic reasons, but there doesn't seem to be any poin in coding it up for now...
4258 
4259 ! if( Quark1PartType.eq.-Quarks(6)%PartType .AND. (Quarks(2)%PartType.eq.-Quarks(5)%PartType .or. Quarks(2)%PartType.eq.-Quarks(3)%PartType) &
4260 ! .AND. (Quarks(6)%ExtRef.ne.-1 .or. tag_f.ne.1) &
4261 ! ) then
4262 ! call Error("This 6fV(B) current is not yet implemented")
4263 !
4264 ! endif
4265 
4266 ! (C)
4267  if( quarks(5)%PartType.eq.-quarks(6)%PartType .AND. &
4268  ((quark1parttype.eq.-quarks(2)%PartType .and. (quarks(2)%ExtRef.ne.-1.or.tag_f.ne.1) ) &
4269  .OR. (quark1parttype.eq.-quarks(4)%PartType .and. (quarks(4)%ExtRef.ne.-1.or.tag_f.ne.1) ))&
4270  .AND. ( bosonvertex.eq.1 .OR. bosonvertex.eq.6 ) &
4271  ) then
4272 ! print *, 'C-1'
4273  do n1a=0,numglu(1)
4274  do n4a=0,numglu(4)
4275  do n6a=0,numglu(6)
4276  n1b = numglu(1)-n1a
4277  n4b = numglu(4)-n4a
4278  n6b = numglu(6)-n6a
4279 
4280  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4281  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4282  eps2 = cur_g_2f(gluons(rin:rout),quarks(5:6),(/1+n4b+numglu(5)+n6a,n4b,numglu(5),n6a/))
4283  pmom1(:) = summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4284  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
4285  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
4286  eps2 = eps2*propfac1
4287 
4288  rin = n1a+1
4289  rout= numglu(1)+numglu(2)+numglu(3)+n4a
4290  u1 = cur_f_4f(gluons(rin:rout),quarks(2:4),quark1parttype,(/n1b+numglu(2)+numglu(3)+n4a,n1b,numglu(2),numglu(3),n4a/),0,0)
4291  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom
4292 
4293  if( quark1parttype.eq.-quarks(2)%PartType) then
4294  if( quarks(2)%PartType.lt.0 ) then
4295  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4296  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4297  u1 = (-spi2_(pmom2,u1) + quarks(2)%Mass*u1 )*propfac2
4298  ubar0 = vbqg(u1,eps2) ! re-checked
4299  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4300  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4301  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom ! this PMom2 will be re-used below
4302 
4303  if( n1a.ge.1 .or. n6b.ge.1 .or. bosonvertex.eq.1 .or. bosonvertex.eq.6 ) then
4304  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4305  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4306  ubar0 = (-spi2_(pmom2,ubar0) + quarks(2)%Mass*ubar0 )*propfac2
4307  endif
4308  elseif( quarks(2)%PartType.gt.0 ) then
4309  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4310  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4311  u1 = ( spb2_(u1,pmom2) + quarks(2)%Mass*u1 )*propfac2
4312  ubar0 = vqg(u1,eps2) ! re-checked
4313  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4314  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4315  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4316 
4317  if( n1a.ge.1 .or. n6b.ge.1 .or. bosonvertex.eq.1 .or. bosonvertex.eq.6 ) then
4318  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4319  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4320  ubar0 = ( spb2_(ubar0,pmom2) + quarks(2)%Mass*ubar0 )*propfac2
4321  endif
4322  endif
4323  tmpquark(1)%Mom => pmom2(:)
4324  tmpquark(1)%Pol => ubar0(:)
4325  tmpquark(1)%Mass => quarks(2)%Mass
4326  tmpquark(1)%Mass2=> quarks(2)%Mass2
4327  elseif( quark1parttype.eq.-quarks(4)%PartType) then
4328  if( quarks(4)%PartType.lt.0 ) then
4329  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4330  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4331  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
4332  ubar0 = vbqg(u1,eps2)
4333  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4334  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4335  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4336  if( n1a.ge.1 .or. n6b.ge.1 .or. bosonvertex.eq.1 .or. bosonvertex.eq.6 ) then
4337  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4338  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4339  ubar0 = (-spi2_(pmom2,ubar0) + quarks(4)%Mass*ubar0 )*propfac2
4340  endif
4341  elseif( quarks(4)%PartType.gt.0 ) then
4342  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4343  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4344  u1 = ( spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
4345  ubar0 = vqg(u1,eps2)
4346  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4347  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4348  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4349  if( n1a.ge.1 .or. n6b.ge.1 .or. bosonvertex.eq.1 .or. bosonvertex.eq.6 ) then
4350  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4351  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4352  ubar0 = ( spb2_(ubar0,pmom2) + quarks(4)%Mass*ubar0 )*propfac2
4353  endif
4354  endif
4355  tmpquark(1)%Mom => pmom2(:)
4356  tmpquark(1)%Pol => ubar0(:)
4357  tmpquark(1)%Mass => quarks(4)%Mass
4358  tmpquark(1)%Mass2=> quarks(4)%Mass2
4359  endif
4360  tmpextref = -1
4361  tmpquark(1)%ExtRef => tmpextref
4362  tmpparttype = -quark1parttype
4363  tmpquark(1)%PartType => tmpparttype
4364  counter=1
4365  rin =1
4366  rout=n1a
4367  do i=rin,rout
4368  call copyparticleptr(gluons(i),tmpgluons(counter))
4369  counter=counter+1
4370  enddo
4371  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4372  rout=numglu(0)
4373  do i=rin,rout
4374  call copyparticleptr(gluons(i),tmpgluons(counter))
4375  counter=counter+1
4376  enddo
4377  tmp(:) = cur_f_2fv(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,boson,(/counter-1,n1a,n6b/) )
4378 
4379  res(:) = res(:) + tmp(:)
4380 
4381  enddo
4382  enddo
4383  enddo
4384  endif
4385 
4386 
4387 
4388  if( quarks(5)%PartType.eq.-quarks(6)%PartType .AND. &
4389  ((quark1parttype.eq.-quarks(2)%PartType .and. (quarks(2)%ExtRef.ne.-1.or.tag_f.ne.1) ) &
4390  .OR. (quark1parttype.eq.-quarks(4)%PartType .and. (quarks(4)%ExtRef.ne.-1.or.tag_f.ne.1) ))&
4391  .AND. ( bosonvertex.eq.1 .OR. bosonvertex.eq.2 .OR. bosonvertex.eq.3 .OR. bosonvertex.eq.4 ) &
4392  ) then
4393 ! print *, 'C-2'
4394  do n1a=0,numglu(1)
4395  do n4a=0,numglu(4)
4396  do n6a=0,numglu(6)
4397  n1b = numglu(1)-n1a
4398  n4b = numglu(4)-n4a
4399  n6b = numglu(6)-n6a
4400 
4401  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4402  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4403  eps2 = cur_g_2f(gluons(rin:rout),quarks(5:6),(/1+n4b+numglu(5)+n6a,n4b,numglu(5),n6a/))
4404  pmom1(:) = summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4405  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
4406  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
4407  eps2 = eps2*propfac1
4408 
4409  rin = n1a+1
4410  rout= numglu(1)+numglu(2)+numglu(3)+n4a
4411  bosonvertex_mod = bosonvertex
4412  u1 = cur_f_4fv(gluons(rin:rout),quarks(2:4),quark1parttype,boson,bosonvertex_mod,(/n1b+numglu(2)+numglu(3)+n4a,n1b,numglu(2),numglu(3),n4a/),0,0)
4413  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom + boson%Mom
4414 
4415  if( quark1parttype.eq.-quarks(2)%PartType) then
4416  if( quarks(2)%PartType.lt.0 ) then
4417  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4418  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4419  u1 = (-spi2_(pmom2,u1) + quarks(2)%Mass*u1 )*propfac2
4420  ubar0 = vbqg(u1,eps2) ! re-checked
4421  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4422  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4423  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom ! this PMom2 will be re-used below
4424  if( n1a.ge.1 .or. n6b.ge.1 ) then
4425  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4426  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4427  ubar0 = (-spi2_(pmom2,ubar0) + quarks(2)%Mass*ubar0 )*propfac2
4428  endif
4429  elseif( quarks(2)%PartType.gt.0 ) then
4430  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4431  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4432  u1 = ( spb2_(u1,pmom2) + quarks(2)%Mass*u1 )*propfac2
4433  ubar0 = vqg(u1,eps2) ! re-checked
4434  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4435  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4436  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4437  if( n1a.ge.1 .or. n6b.ge.1 ) then
4438  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4439  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4440  ubar0 = ( spb2_(ubar0,pmom2) + quarks(2)%Mass*ubar0 )*propfac2
4441  endif
4442  endif
4443  tmpquark(1)%Mom => pmom2(:)
4444  tmpquark(1)%Pol => ubar0(:)
4445  tmpquark(1)%Mass => quarks(2)%Mass
4446  tmpquark(1)%Mass2=> quarks(2)%Mass2
4447  elseif( quark1parttype.eq.-quarks(4)%PartType) then
4448  if( quarks(4)%PartType.lt.0 ) then
4449  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4450  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4451  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
4452  ubar0 = vbqg(u1,eps2)
4453  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4454  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4455  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4456  if( n1a.ge.1 .or. n6b.ge.1 ) then
4457  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4458  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4459  ubar0 = (-spi2_(pmom2,ubar0) + quarks(4)%Mass*ubar0 )*propfac2
4460  endif
4461  elseif( quarks(4)%PartType.gt.0 ) then
4462  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4463  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4464  u1 = ( spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
4465  ubar0 = vqg(u1,eps2)
4466  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4467  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4468  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4469  if( n1a.ge.1 .or. n6b.ge.1 ) then
4470  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4471  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4472  ubar0 = ( spb2_(ubar0,pmom2) + quarks(4)%Mass*ubar0 )*propfac2
4473  endif
4474  endif
4475  tmpquark(1)%Mom => pmom2(:)
4476  tmpquark(1)%Pol => ubar0(:)
4477  tmpquark(1)%Mass => quarks(4)%Mass
4478  tmpquark(1)%Mass2=> quarks(4)%Mass2
4479  endif
4480  tmpextref = -1
4481  tmpquark(1)%ExtRef => tmpextref
4482  tmpparttype = -quark1parttype
4483  tmpquark(1)%PartType => tmpparttype
4484  counter=1
4485  rin =1
4486  rout=n1a
4487  do i=rin,rout
4488  call copyparticleptr(gluons(i),tmpgluons(counter))
4489  counter=counter+1
4490  enddo
4491  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4492  rout=numglu(0)
4493  do i=rin,rout
4494  call copyparticleptr(gluons(i),tmpgluons(counter))
4495  counter=counter+1
4496  enddo
4497  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,(/counter-1,n1a,n6b/) )
4498 
4499  res(:) = res(:) + tmp(:)
4500 
4501  enddo
4502  enddo
4503  enddo
4504  endif
4505 
4506 
4507 ! (C)
4508  if( quarks(5)%PartType.eq.-quarks(6)%PartType .AND. &
4509  ((quark1parttype.eq.-quarks(2)%PartType .and. (quarks(2)%ExtRef.ne.-1.or.tag_f.ne.1) ) &
4510  .OR. (quark1parttype.eq.-quarks(4)%PartType .and. (quarks(4)%ExtRef.ne.-1.or.tag_f.ne.1) ))&
4511  .AND. ( bosonvertex.eq.5 ) &
4512  ) then
4513 ! print *, 'C-3'
4514  do n1a=0,numglu(1)
4515  do n4a=0,numglu(4)
4516  do n6a=0,numglu(6)
4517  n1b = numglu(1)-n1a
4518  n4b = numglu(4)-n4a
4519  n6b = numglu(6)-n6a
4520 
4521  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4522  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4523  eps2 = cur_g_2fv(gluons(rin:rout),quarks(5:6),boson,(/1+n4b+numglu(5)+n6a,n4b,numglu(5),n6a/))
4524  pmom1(:) = summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom + boson%Mom
4525  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
4526  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
4527  eps2 = eps2*propfac1
4528 
4529  rin = n1a+1
4530  rout= numglu(1)+numglu(2)+numglu(3)+n4a
4531  u1 = cur_f_4f(gluons(rin:rout),quarks(2:4),quark1parttype,(/n1b+numglu(2)+numglu(3)+n4a,n1b,numglu(2),numglu(3),n4a/),0,0)
4532  pmom2 = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + quarks(4)%Mom
4533 
4534  if( quark1parttype.eq.-quarks(2)%PartType) then
4535 
4536  if( quarks(2)%PartType.lt.0 ) then
4537  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4538  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4539  u1 = (-spi2_(pmom2,u1) + quarks(2)%Mass*u1 )*propfac2
4540  ubar0 = vbqg(u1,eps2) ! re-checked
4541  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4542  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4543  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom + boson%Mom! this PMom2 will be re-used below
4544  if( n1a.ge.1 .or. n6b.ge.1 ) then
4545  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4546  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4547  ubar0 = (-spi2_(pmom2,ubar0) + quarks(2)%Mass*ubar0 )*propfac2
4548  endif
4549  elseif( quarks(2)%PartType.gt.0 ) then
4550  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4551  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4552  u1 = ( spb2_(u1,pmom2) + quarks(2)%Mass*u1 )*propfac2
4553  ubar0 = vqg(u1,eps2) ! re-checked
4554  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4555  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4556  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom + boson%Mom! this PMom2 will be re-used below
4557  if( n1a.ge.1 .or. n6b.ge.1 ) then
4558  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(2)%Mass2)
4559  if( abs(sc_(pmom2,pmom2) - quarks(2)%Mass2).lt.propcut ) cycle
4560  u1 = ( spb2_(u1,pmom2) + quarks(2)%Mass*u1 )*propfac2
4561  endif
4562  endif
4563  tmpquark(1)%Mom => pmom2(:)
4564  tmpquark(1)%Pol => ubar0(:)
4565  tmpquark(1)%Mass => quarks(2)%Mass
4566  tmpquark(1)%Mass2=> quarks(2)%Mass2
4567  elseif( quark1parttype.eq.-quarks(4)%PartType) then
4568  if( quarks(4)%PartType.lt.0 ) then
4569  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4570  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4571  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
4572  ubar0 = vbqg(u1,eps2)
4573  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4574  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4575  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4576  if( n1a.ge.1 .or. n6b.ge.1 ) then
4577  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4578  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4579  ubar0 = (-spi2_(pmom2,ubar0) + quarks(4)%Mass*ubar0 )*propfac2
4580  endif
4581  elseif( quarks(4)%PartType.gt.0 ) then
4582  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4583  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4584  u1 = ( spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
4585  ubar0 = vqg(u1,eps2)
4586  rin = numglu(1)+numglu(2)+numglu(3)+n4a+1
4587  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4588  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(5)%Mom + quarks(6)%Mom
4589  if( n1a.ge.1 .or. n6b.ge.1 ) then
4590  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4591  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4592  ubar0 = ( spb2_(ubar0,pmom2) + quarks(4)%Mass*ubar0 )*propfac2
4593  endif
4594  endif
4595  tmpquark(1)%Mom => pmom2(:)
4596  tmpquark(1)%Pol => ubar0(:)
4597  tmpquark(1)%Mass => quarks(4)%Mass
4598  tmpquark(1)%Mass2=> quarks(4)%Mass2
4599  endif
4600  tmpextref = -1
4601  tmpquark(1)%ExtRef => tmpextref
4602  tmpparttype = -quark1parttype
4603  tmpquark(1)%PartType => tmpparttype
4604  counter=1
4605  rin =1
4606  rout=n1a
4607  do i=rin,rout
4608  call copyparticleptr(gluons(i),tmpgluons(counter))
4609  counter=counter+1
4610  enddo
4611  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4612  rout=numglu(0)
4613  do i=rin,rout
4614  call copyparticleptr(gluons(i),tmpgluons(counter))
4615  counter=counter+1
4616  enddo
4617  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,(/counter-1,n1a,n6b/) )
4618 
4619  res(:) = res(:) + tmp(:)
4620  enddo
4621  enddo
4622  enddo
4623 
4624 
4625 endif
4626 
4627 
4628 
4629 ! (D)
4630  if( quarks(2)%PartType.eq.-quarks(3)%PartType .AND. ( &
4631  (quark1parttype.eq.-quarks(4)%PartType .and. (quarks(4)%ExtRef.ne.-1.or.tag_f.ne.1)) &
4632  .OR. (quark1parttype.eq.-quarks(6)%PartType .and. (quarks(6)%ExtRef.ne.-1.or.tag_f.ne.1)) ) &
4633  .AND. ( bosonvertex.eq.1 ) &
4634  ) then
4635 ! print *, 'D-1'
4636  do n1a=0,numglu(1)
4637  do n3a=0,numglu(3)
4638  do n6a=0,numglu(6)
4639  n1b = numglu(1)-n1a
4640  n3b = numglu(3)-n3a
4641  n6b = numglu(6)-n6a
4642 
4643  counter=1
4644  rin = n1a+1
4645  rout= numglu(1)+numglu(2)+n3a
4646  eps2 = cur_g_2f(gluons(rin:rout),quarks(2:3),(/1+n1b+numglu(2)+n3a,n1b,numglu(2),n3a/))
4647  pmom1(:) = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
4648  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
4649  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
4650  eps2 = eps2*propfac1
4651 
4652  rin = numglu(1)+numglu(2)+n3a+1
4653  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4654  u1 = cur_f_4f(gluons(rin:rout),quarks(4:6),quark1parttype,(/n3b+numglu(4)+numglu(5)+n6a,n3b,numglu(4),numglu(5),n6a/),tag_f,0)
4655  pmom2 = summom(gluons,rin,rout) + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom
4656 
4657  if( quark1parttype.eq.-quarks(4)%PartType ) then
4658  if( quarks(4)%PartType.lt.0 ) then
4659  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4660  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4661  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
4662  ubar0 = vgbq(eps2,u1) ! re-checked
4663  rin = n1a+1
4664  rout= numglu(1)+numglu(2)+n3a
4665  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom !this PMom2 will be re-used below ! CAN be written as PMom2=PMom2+PMom1
4666  if( n1a.ge.1 .or. n6b.ge.1 .or. bosonvertex.eq.1 .or. bosonvertex.eq.6 ) then
4667  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4668  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4669  ubar0 = (-spi2_(pmom2,ubar0) + quarks(4)%Mass*ubar0 )*propfac2
4670  endif
4671  elseif( quarks(4)%PartType.gt.0 ) then
4672  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4673  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4674  u1 = ( spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
4675  ubar0 = vgq(eps2,u1) ! re-checked
4676  rin = n1a+1
4677  rout= numglu(1)+numglu(2)+n3a
4678  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
4679  if( n1a.ge.1 .or. n6b.ge.1 .or. bosonvertex.eq.1 .or. bosonvertex.eq.6 ) then
4680  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4681  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4682  ubar0 = ( spb2_(ubar0,pmom2) + quarks(4)%Mass*ubar0 )*propfac2
4683  endif
4684  endif
4685  tmpquark(1)%Mom => pmom2(:)
4686  tmpquark(1)%Pol => ubar0(:)
4687  tmpquark(1)%Mass => quarks(4)%Mass
4688  tmpquark(1)%Mass2=> quarks(4)%Mass2
4689  elseif(quark1parttype.eq.-quarks(6)%PartType) then
4690  if( quarks(6)%PartType.lt.0 ) then
4691  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4692  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4693  u1 = (-spi2_(pmom2,u1) + quarks(6)%Mass*u1 )*propfac2
4694  ubar0 = vgbq(eps2,u1) ! re-checked
4695  rin = n1a+1
4696  rout= numglu(1)+numglu(2)+n3a
4697  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
4698  if( n1a.ge.1 .or. n6b.ge.1 .or. bosonvertex.eq.1 .or. bosonvertex.eq.6 ) then
4699  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4700  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4701  ubar0 = (-spi2_(pmom2,ubar0) + quarks(6)%Mass*ubar0 )*propfac2
4702  endif
4703  elseif( quarks(6)%PartType.gt.0 ) then
4704  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4705  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4706  u1 = ( spb2_(u1,pmom2) + quarks(6)%Mass*u1 )*propfac2
4707  ubar0 = vgq(eps2,u1) ! re-checked
4708  rin = n1a+1
4709  rout= numglu(1)+numglu(2)+n3a
4710  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
4711  if( n1a.ge.1 .or. n6b.ge.1 .or. bosonvertex.eq.1 .or. bosonvertex.eq.6 ) then
4712  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4713  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4714  ubar0 = ( spb2_(ubar0,pmom2) + quarks(6)%Mass*ubar0 )*propfac2
4715  endif
4716  endif
4717  endif
4718  tmpextref = -1
4719  tmpquark(1)%ExtRef => tmpextref
4720  tmpparttype = -quark1parttype
4721  tmpquark(1)%PartType => tmpparttype
4722  counter=1
4723  rin =1
4724  rout=n1a
4725  do i=rin,rout
4726  call copyparticleptr(gluons(i),tmpgluons(counter))
4727  counter=counter+1
4728  enddo
4729  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4730  rout=numglu(0)
4731  do i=rin,rout
4732  call copyparticleptr(gluons(i),tmpgluons(counter))
4733  counter=counter+1
4734  enddo
4735  tmp(:) = cur_f_2fv(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,boson,(/counter-1,n1a,n6b/))
4736 
4737  res(:) = res(:) + tmp(:)
4738 
4739  enddo
4740  enddo
4741  enddo
4742  endif
4743 
4744 
4745 
4746 ! (D)
4747  if( quarks(2)%PartType.eq.-quarks(3)%PartType .AND. ( &
4748  (quark1parttype.eq.-quarks(4)%PartType .and. (quarks(4)%ExtRef.ne.-1.or.tag_f.ne.1)) &
4749  .OR. (quark1parttype.eq.-quarks(6)%PartType .and. (quarks(6)%ExtRef.ne.-1.or.tag_f.ne.1)) ) &
4750  .AND. ( bosonvertex.eq.2) &
4751  ) then
4752 ! print *, 'D-2'
4753  do n1a=0,numglu(1)
4754  do n3a=0,numglu(3)
4755  do n6a=0,numglu(6)
4756  n1b = numglu(1)-n1a
4757  n3b = numglu(3)-n3a
4758  n6b = numglu(6)-n6a
4759 
4760  counter=1
4761  rin = n1a+1
4762  rout= numglu(1)+numglu(2)+n3a
4763  eps2 = cur_g_2fv(gluons(rin:rout),quarks(2:3),boson,(/1+n1b+numglu(2)+n3a,n1b,numglu(2),n3a/))
4764  pmom1(:) = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + boson%Mom
4765  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
4766  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
4767  eps2 = eps2*propfac1
4768 
4769  rin = numglu(1)+numglu(2)+n3a+1
4770  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4771  bosonvertex_mod = bosonvertex
4772  u1 = cur_f_4f(gluons(rin:rout),quarks(4:6),quark1parttype,(/n3b+numglu(4)+numglu(5)+n6a,n3b,numglu(4),numglu(5),n6a/),tag_f,0)
4773  pmom2 = summom(gluons,rin,rout) + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom
4774 
4775  if( quark1parttype.eq.-quarks(4)%PartType ) then
4776  if( quarks(4)%PartType.lt.0 ) then
4777  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4778  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4779  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
4780  ubar0 = vgbq(eps2,u1) ! re-checked
4781  rin = n1a+1
4782  rout= numglu(1)+numglu(2)+n3a
4783  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + boson%Mom !this PMom2 will be re-used below ! CAN be written as PMom2=PMom2+PMom1
4784  if( n1a.ge.1 .or. n6b.ge.1 ) then
4785  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4786  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4787  ubar0 = (-spi2_(pmom2,ubar0) + quarks(4)%Mass*ubar0 )*propfac2
4788  endif
4789  elseif( quarks(4)%PartType.gt.0 ) then
4790  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4791  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4792  u1 = ( spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
4793  ubar0 = vgq(eps2,u1) ! re-checked
4794  rin = n1a+1
4795  rout= numglu(1)+numglu(2)+n3a
4796  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + boson%Mom
4797  if( n1a.ge.1 .or. n6b.ge.1 ) then
4798  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4799  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4800  ubar0 = ( spb2_(ubar0,pmom2) + quarks(4)%Mass*ubar0 )*propfac2
4801  endif
4802  endif
4803  elseif(quark1parttype.eq.-quarks(6)%PartType) then
4804  if( quarks(6)%PartType.lt.0 ) then
4805  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4806  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4807  u1 = (-spi2_(pmom2,u1) + quarks(6)%Mass*u1 )*propfac2
4808  ubar0 = vgbq(eps2,u1) ! re-checked
4809  rin = n1a+1
4810  rout= numglu(1)+numglu(2)+n3a
4811  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom+ boson%Mom
4812  if( n1a.ge.1 .or. n6b.ge.1 ) then
4813  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4814  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4815  ubar0 = (-spi2_(pmom2,ubar0) + quarks(6)%Mass*ubar0 )*propfac2
4816  endif
4817  elseif( quarks(6)%PartType.gt.0 ) then
4818  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4819  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4820  u1 = ( spb2_(u1,pmom2) + quarks(6)%Mass*u1 )*propfac2
4821  ubar0 = vgq(eps2,u1) ! re-checked
4822  rin = n1a+1
4823  rout= numglu(1)+numglu(2)+n3a
4824  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom + boson%Mom
4825  if( n1a.ge.1 .or. n6b.ge.1 ) then
4826  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4827  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4828  ubar0 = ( spb2_(ubar0,pmom2) + quarks(6)%Mass*ubar0 )*propfac2
4829  endif
4830  endif
4831  endif
4832  tmpquark(1)%Mom => pmom2(:)
4833  tmpquark(1)%Pol => ubar0(:)
4834  tmpquark(1)%Mass => quarks(4)%Mass
4835  tmpquark(1)%Mass2=> quarks(4)%Mass2
4836  tmpextref = -1
4837  tmpquark(1)%ExtRef => tmpextref
4838  tmpparttype = -quark1parttype
4839  tmpquark(1)%PartType => tmpparttype
4840  counter=1
4841  rin =1
4842  rout=n1a
4843  do i=rin,rout
4844  call copyparticleptr(gluons(i),tmpgluons(counter))
4845  counter=counter+1
4846  enddo
4847  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4848  rout=numglu(0)
4849  do i=rin,rout
4850  call copyparticleptr(gluons(i),tmpgluons(counter))
4851  counter=counter+1
4852  enddo
4853  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,(/counter-1,n1a,n6b/))
4854 
4855  res(:) = res(:) + tmp(:)
4856  enddo
4857  enddo
4858  enddo
4859  endif
4860 
4861 
4862 ! (D)
4863  if( quarks(2)%PartType.eq.-quarks(3)%PartType .AND. ( &
4864  (quark1parttype.eq.-quarks(4)%PartType .and. (quarks(4)%ExtRef.ne.-1.or.tag_f.ne.1)) &
4865  .OR. (quark1parttype.eq.-quarks(6)%PartType .and. (quarks(6)%ExtRef.ne.-1.or.tag_f.ne.1)) ) &
4866  .AND. ( bosonvertex .ge. 3 .and. bosonvertex .le. 6 ) ) then
4867 ! print *, 'D-3'
4868  do n1a=0,numglu(1)
4869  do n3a=0,numglu(3)
4870  do n6a=0,numglu(6)
4871  n1b = numglu(1)-n1a
4872  n3b = numglu(3)-n3a
4873  n6b = numglu(6)-n6a
4874 
4875  counter=1
4876  rin = n1a+1
4877  rout= numglu(1)+numglu(2)+n3a
4878  eps2 = cur_g_2f(gluons(rin:rout),quarks(2:3),(/1+n1b+numglu(2)+n3a,n1b,numglu(2),n3a/))
4879  pmom1(:) = summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
4880  propfac1 = (0d0,-1d0)/sc_(pmom1,pmom1)
4881  if( abs(sc_(pmom1,pmom1)).lt.propcut ) cycle
4882  eps2 = eps2*propfac1
4883 
4884  rin = numglu(1)+numglu(2)+n3a+1
4885  rout= numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a
4886  bosonvertex_mod=bosonvertex-2
4887  u1 = cur_f_4fv(gluons(rin:rout),quarks(4:6),quark1parttype,boson,bosonvertex_mod,(/n3b+numglu(4)+numglu(5)+n6a,n3b,numglu(4),numglu(5),n6a/),tag_f,0)
4888  pmom2 = summom(gluons,rin,rout) + quarks(4)%Mom + quarks(5)%Mom + quarks(6)%Mom+boson%Mom
4889 
4890  if( quark1parttype.eq.-quarks(4)%PartType ) then
4891  if( quarks(4)%PartType.lt.0 ) then
4892  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4893  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4894  u1 = (-spi2_(pmom2,u1) + quarks(4)%Mass*u1 )*propfac2
4895  ubar0 = vgbq(eps2,u1) ! re-checked
4896  rin = n1a+1
4897  rout= numglu(1)+numglu(2)+n3a
4898  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom !this PMom2 will be re-used below ! CAN be written as PMom2=PMom2+PMom1
4899  if( n1a.ge.1 .or. n6b.ge.1 ) then
4900  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4901  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4902  ubar0 = (-spi2_(pmom2,ubar0) + quarks(4)%Mass*ubar0 )*propfac2
4903  endif
4904  elseif( quarks(4)%PartType.gt.0 ) then
4905  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4906  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4907  u1 = ( spb2_(u1,pmom2) + quarks(4)%Mass*u1 )*propfac2
4908  ubar0 = vgq(eps2,u1) ! re-checked
4909  rin = n1a+1
4910  rout= numglu(1)+numglu(2)+n3a
4911  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
4912  if( n1a.ge.1 .or. n6b.ge.1 ) then
4913  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(4)%Mass2)
4914  if( abs(sc_(pmom2,pmom2) - quarks(4)%Mass2).lt.propcut ) cycle
4915  ubar0 = ( spb2_(ubar0,pmom2) + quarks(4)%Mass*ubar0 )*propfac2
4916  endif
4917  endif
4918  tmpquark(1)%Mom => pmom2(:)
4919  tmpquark(1)%Pol => ubar0(:)
4920  tmpquark(1)%Mass => quarks(4)%Mass
4921  tmpquark(1)%Mass2=> quarks(4)%Mass2
4922  elseif(quark1parttype.eq.-quarks(6)%PartType) then
4923  if( quarks(6)%PartType.lt.0 ) then
4924  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4925  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4926  u1 = (-spi2_(pmom2,u1) + quarks(6)%Mass*u1 )*propfac2
4927  ubar0 = vgbq(eps2,u1) ! re-checked
4928  rin = n1a+1
4929  rout= numglu(1)+numglu(2)+n3a
4930  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
4931  if( n1a.ge.1 .or. n6b.ge.1 ) then
4932  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4933  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4934  ubar0 = (-spi2_(pmom2,ubar0) + quarks(6)%Mass*ubar0 )*propfac2
4935  endif
4936  elseif( quarks(6)%PartType.gt.0 ) then
4937  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4938  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4939  u1 = ( spb2_(u1,pmom2) + quarks(6)%Mass*u1 )*propfac2
4940  ubar0 = vgq(eps2,u1) ! re-checked
4941  rin = n1a+1
4942  rout= numglu(1)+numglu(2)+n3a
4943  pmom2 = pmom2 + summom(gluons,rin,rout) + quarks(2)%Mom + quarks(3)%Mom
4944  if( n1a.ge.1 .or. n6b.ge.1 ) then
4945  propfac2 = (0d0,1d0)/(sc_(pmom2,pmom2) - quarks(6)%Mass2)
4946  if( abs(sc_(pmom2,pmom2) - quarks(6)%Mass2).lt.propcut ) cycle
4947  ubar0 = ( spb2_(ubar0,pmom2) + quarks(6)%Mass*ubar0 )*propfac2
4948  endif
4949  endif
4950  tmpquark(1)%Mom => pmom2(:)
4951  tmpquark(1)%Pol => ubar0(:)
4952  tmpquark(1)%Mass => quarks(6)%Mass
4953  tmpquark(1)%Mass2=> quarks(6)%Mass2
4954  endif
4955  tmpextref = -1
4956  tmpquark(1)%ExtRef => tmpextref
4957  tmpparttype = -quark1parttype
4958  tmpquark(1)%PartType => tmpparttype
4959  counter=1
4960  rin =1
4961  rout=n1a
4962  do i=rin,rout
4963  call copyparticleptr(gluons(i),tmpgluons(counter))
4964  counter=counter+1
4965  enddo
4966  rin =numglu(1)+numglu(2)+numglu(3)+numglu(4)+numglu(5)+n6a+1
4967  rout=numglu(0)
4968  do i=rin,rout
4969  call copyparticleptr(gluons(i),tmpgluons(counter))
4970  counter=counter+1
4971  enddo
4972  tmp(:) = cur_f_2f(tmpgluons(1:counter-1),tmpquark(1:1),quark1parttype,(/counter-1,n1a,n6b/))
4973 
4974  res(:) = res(:) + tmp(:)
4975  enddo
4976  enddo
4977  enddo
4978  endif
4979 
4980 
4981 return
4982 END FUNCTION
4983 
4984 
4985 
4986 
4987 
4988 
4989 !---------------------------------------
4990 
4991 
4992 FUNCTION summom(Particles,i1,i2)
4993 implicit none
4994 complex(8) :: summom(1:dv)
4995 type(ptrtoparticle) :: particles(:)
4996 integer :: i1,i2,j
4997 
4998  summom(1:dv)= (0d0,0d0)
4999  if (i2.ge.i1) then
5000  do j=i1,i2
5001  summom(1:dv) = summom(1:dv) + particles(j)%Mom(1:dv)
5002  enddo
5003  endif
5004 END FUNCTION
5005 
5006 
5007 
5008 FUNCTION fourvecdot(p1,p2)
5009 implicit none
5010 complex(8), intent(in) :: p1(1:dv),p2(1:dv)
5011 complex(8) :: fourvecdot
5012 integer :: mu
5013 
5014  fourvecdot = p1(1)*p2(1)
5015 !DEC$ UNROLL
5016  do mu=2,dv
5017  fourvecdot = fourvecdot - p1(mu)*p2(mu)
5018  enddo
5019 return
5020 END FUNCTION fourvecdot
5021 
5022 FUNCTION eval_tripvert(k1,k2,v1,v2)
5023 implicit none
5024 complex(8) :: eval_tripvert(1:dv)
5025 complex(8) :: k1(1:dv),k2(1:dv),v1(1:dv),v2(1:dv)
5026 complex(8), parameter :: ioversqrt2=(0d0,1d0)/dsqrt(2d0)
5027 
5028  eval_tripvert(1:dv) = ioversqrt2 * ( (k1(1:dv)-k2(1:dv))*(v1.ndot.v2) &
5029  - 2d0*v1(1:dv)*(k1.ndot.v2) &
5030  + 2d0*v2(1:dv)*(k2.ndot.v1) )
5031 return
5032 END FUNCTION eval_tripvert
5033 
5034 FUNCTION eval_quadvert(k1,k2,k3)
5035 implicit none
5036 complex(8) :: eval_quadvert(1:dv)
5037 complex(8) :: k1(1:dv),k2(1:dv),k3(1:dv)
5038 complex(8), parameter :: i=(0d0,1d0)
5039 
5040  eval_quadvert(1:dv) = i * (-k1(1:dv)*(k2.ndot.k3)*0.5d0 &
5041  + k2(1:dv)*(k1.ndot.k3) &
5042  - k3(1:dv)*(k1.ndot.k2)*0.5d0 )
5043 return
5044 END FUNCTION eval_quadvert
5045 
5046 
5047 
5048 
5049 !DEC$ ATTRIBUTES INLINE :: linear_map
5050 FUNCTION linear_map(i1,i2,Ngluons)
5051 implicit none
5052 integer :: linear_map,i1,i2,ngluons
5053 
5054  linear_map = i2+ngluons*(i2-i1)-((i2-i1)*(i2-i1+1))/2
5055 return
5056 END FUNCTION linear_map
5057 
5058 
5059 
5060 
5061 
5062 
5063 SUBROUTINE copyparticleptr(InPointer,OutPointer)
5064 implicit none
5065 type(ptrtoparticle), intent(in) :: InPointer
5066 type(ptrtoparticle), intent(out):: OutPointer
5067 
5068  outpointer%PartType => inpointer%PartType
5069  outpointer%ExtRef => inpointer%ExtRef
5070  outpointer%Mass => inpointer%Mass
5071  outpointer%Mass2 => inpointer%Mass2
5072  outpointer%Helicity => inpointer%Helicity
5073  outpointer%Mom => inpointer%Mom
5074  outpointer%Pol => inpointer%Pol
5075 return
5076 END SUBROUTINE
5077 
5078 
5079 
5080 
5081 
5082 
5083 
5084 !---------------------------------------
5085 
5086 
5087 
5088 
5089 !-----------modified procedure
5090 !---------- Dv is the dimensionality of the vector space
5091 !---------- Ds is the dimensionality of the spinorial representation
5092  subroutine spi2(Dv,Ds,v,sp,f)
5093  implicit none
5094  integer i,i1,i2,i3,imax,Dv,Ds
5095  double complex sp(Ds),v(Dv),f(Ds)
5096  double complex x0(4,4),xx(4,4),xy(4,4)
5097  double complex xz(4,4),x5(4,4)
5098  double complex y1,y2,y3,y4,bp,bm,cp,cm
5099  double complex test(Ds)
5100 
5101 
5102  imax = ds/4
5103 
5104  do i=1,imax
5105  i1= 1+4*(i-1)
5106  i2=i1+3
5107 
5108  y1=sp(i1)
5109  y2=sp(i1+1)
5110  y3=sp(i1+2)
5111  y4=sp(i1+3)
5112 
5113  x0(1,i)=y1
5114  x0(2,i)=y2
5115  x0(3,i)=-y3
5116  x0(4,i)=-y4
5117 
5118 
5119  xx(1,i) = y4
5120  xx(2,i) = y3
5121  xx(3,i) = -y2
5122  xx(4,i) = -y1
5123 
5124 
5125  xy(1,i)=dcmplx(0d0,-1d0)*y4
5126  xy(2,i)=dcmplx(0d0,1d0)*y3
5127  xy(3,i)=dcmplx(0d0,1d0)*y2
5128  xy(4,i)=dcmplx(0d0,-1d0)*y1
5129 
5130  xz(1,i)=y3
5131  xz(2,i)=-y4
5132  xz(3,i)=-y1
5133  xz(4,i)=y2
5134 
5135  x5(1,i)=y3
5136  x5(2,i)=y4
5137  x5(3,i)=y1
5138  x5(4,i)=y2
5139 
5140  enddo
5141 
5142  if(dv.eq.4) then
5143 
5144  do i=1,4
5145 
5146  f(i)=v(1)*x0(i,1)-v(2)*xx(i,1)-v(3)*xy(i,1)-v(4)*xz(i,1)
5147  enddo
5148 
5149  endif
5150 
5151 
5152  if (dv.eq.6) then
5153  bp = (v(5)+dcmplx(0d0,1d0)*v(6))
5154  bm=(v(5)-dcmplx(0d0,1d0)*v(6))
5155 
5156 
5157  do i=1,4
5158 
5159  f(i)=v(1)*x0(i,1)-v(2)*xx(i,1)-v(3)*xy(i,1)-v(4)*xz(i,1)-bp*x5(i,2)
5160 
5161  i1=i+4
5162 
5163  f(i1)=v(1)*x0(i,2)-v(2)*xx(i,2)-v(3)*xy(i,2)-v(4)*xz(i,2)+bm*x5(i,1)
5164 
5165  enddo
5166 
5167  endif
5168 
5169  if (dv.eq.8) then
5170 
5171  bp = (v(5)+dcmplx(0d0,1d0)*v(6))
5172  bm=(v(5)-dcmplx(0d0,1d0)*v(6))
5173  cp=(v(7)+dcmplx(0d0,1d0)*v(8))
5174  cm=(v(7)-dcmplx(0d0,1d0)*v(8))
5175 
5176 
5177 
5178  do i=1,4
5179 
5180  f(i)=v(1)*x0(i,1)-v(2)*xx(i,1)-v(3)*xy(i,1)-v(4)*xz(i,1)-bp*x5(i,2)+ cp*x5(i,3)
5181 
5182  i1=i+4
5183 
5184  f(i1)=v(1)*x0(i,2)-v(2)*xx(i,2)-v(3)*xy(i,2)-v(4)*xz(i,2)+bm*x5(i,1)-cp*x5(i,4)
5185 
5186  i2=i1+4
5187 
5188  f(i2)=v(1)*x0(i,3)-v(2)*xx(i,3)-v(3)*xy(i,3)-v(4)*xz(i,3)-bp*x5(i,4)-cm*x5(i,1)
5189 
5190  i3=i2+4
5191 
5192  f(i3)=v(1)*x0(i,4)-v(2)*xx(i,4)-v(3)*xy(i,4)-v(4)*xz(i,4)+bm*x5(i,3)+cm*x5(i,2)
5193 
5194 
5195  enddo
5196 
5197  endif
5198 
5199 ! if(Ds.eq.16) then
5200 ! test(:) = VSpiL(v,sp)
5201 ! print *, ""
5202 ! print *, "spi2",f(1:Ds)
5203 ! print *, "test",test(1:Ds)
5204 ! print *, "diff",test(1:Ds)-f(1:Ds)
5205 ! if( any( abs(test(1:Ds)-f(1:Ds) ).gt.1d-10 ) ) pause
5206 ! endif
5207 
5208  return
5209  end subroutine
5210 
5211 
5212 
5213  function spi2_(v,sp)
5214  implicit none
5215  double complex, intent(in) :: sp(:),v(:)
5216  double complex :: spi2_(size(sp)) ,tmp(size(sp))
5217  integer :: dv,ds
5218 
5219  ds = size(sp)
5220  if (ds == 4) dv = 4
5221  if (ds == 8) dv = 6
5222  if (ds == 16) dv = 8
5223  call spi2(dv,ds,v,sp,spi2_)
5224 
5225 ! tmp = VSpiL(v,sp)
5226 ! print *, "diff1",tmp-spi2_
5227 ! pause
5228 
5229  return
5230  end function
5231 
5232 
5233 
5234  function spivl(sp,v) ! SpiVL=sp.(v_mu*gamma^mu) =spb2(4,4,...)
5235  implicit none
5236  double complex :: sp(:),v(:)
5237  double complex :: spivl(size(sp))
5238 
5239  spivl(1) = sp(1)*v(1) + sp(4)*(v(2) + (0d0,1d0)*v(3)) + sp(3)*v(4)
5240  spivl(2) = sp(2)*v(1) + sp(3)*(v(2) - (0d0,1d0)*v(3)) - sp(4)*v(4)
5241  spivl(3) =-sp(3)*v(1) - sp(2)*(v(2) + (0d0,1d0)*v(3)) - sp(1)*v(4)
5242  spivl(4) =-sp(4)*v(1) - sp(1)*(v(2) - (0d0,1d0)*v(3)) + sp(2)*v(4)
5243 
5244  return
5245  end function
5246 
5247 
5248 
5249 subroutine spb2(Dv,Ds,sp,v,f)
5250  implicit none
5251  integer i,i1,i2,i3,Dv,Ds,imax
5252  double complex sp(Ds),v(Dv),f(Ds)
5253  double complex x0(4,4),xx(4,4),xy(4,4)
5254  double complex xz(4,4),x5(4,4)
5255  double complex y1,y2,y3,y4,bp,bm,cp,cm
5256  double complex test(Ds)
5257 
5258  imax = ds/4
5259 
5260  do i=1,imax
5261  i1= 1+4*(i-1)
5262  i2=i1+3
5263 
5264  y1=sp(i1)
5265  y2=sp(i1+1)
5266  y3=sp(i1+2)
5267  y4=sp(i1+3)
5268 
5269  x0(1,i)=y1
5270  x0(2,i)=y2
5271  x0(3,i)=-y3
5272  x0(4,i)=-y4
5273 
5274  xx(1,i) = -y4
5275  xx(2,i) = -y3
5276  xx(3,i) = y2
5277  xx(4,i) = y1
5278 
5279  xy(1,i)=dcmplx(0d0,-1d0)*y4
5280  xy(2,i)=dcmplx(0d0,1d0)*y3
5281  xy(3,i)=dcmplx(0d0,1d0)*y2
5282  xy(4,i)=dcmplx(0d0,-1d0)*y1
5283 
5284  xz(1,i)=-y3
5285  xz(2,i)=y4
5286  xz(3,i)=y1
5287  xz(4,i)=-y2
5288 
5289  x5(1,i)=y3
5290  x5(2,i)=y4
5291  x5(3,i)=y1
5292  x5(4,i)=y2
5293 
5294  enddo
5295 
5296  if (dv.eq.4) then
5297 
5298  do i=1,4
5299 
5300  f(i)=v(1)*x0(i,1)-v(2)*xx(i,1)-v(3)*xy(i,1)-v(4)*xz(i,1)
5301 
5302  enddo
5303 
5304  endif
5305 
5306  if (dv.eq.6) then
5307  bp = (v(5)+dcmplx(0d0,1d0)*v(6))
5308  bm=(v(5)-dcmplx(0d0,1d0)*v(6))
5309 
5310  do i=1,4
5311 
5312  f(i)=v(1)*x0(i,1)-v(2)*xx(i,1)-v(3)*xy(i,1)-v(4)*xz(i,1)+bm*x5(i,2)
5313 
5314  i1 = i+4
5315 
5316  f(i1)= v(1)*x0(i,2)-v(2)*xx(i,2)-v(3)*xy(i,2)-v(4)*xz(i,2)-bp*x5(i,1)
5317 
5318 
5319  enddo
5320 
5321  endif
5322 
5323  if (dv.eq.8) then
5324  bp=(v(5)+dcmplx(0d0,1d0)*v(6))
5325  bm=(v(5)-dcmplx(0d0,1d0)*v(6))
5326  cp=(v(7)+dcmplx(0d0,1d0)*v(8))
5327  cm=(v(7)-dcmplx(0d0,1d0)*v(8))
5328 
5329  do i=1,4
5330 
5331  f(i)=v(1)*x0(i,1)-v(2)*xx(i,1)-v(3)*xy(i,1)-v(4)*xz(i,1)+bm*x5(i,2)-cm*x5(i,3)
5332 
5333  i1 = i+4
5334 
5335  f(i1)= v(1)*x0(i,2)-v(2)*xx(i,2)-v(3)*xy(i,2)-v(4)*xz(i,2)-bp*x5(i,1)+cm*x5(i,4)
5336 
5337  i2 = i1+4
5338 
5339  f(i2)=v(1)*x0(i,3)-v(2)*xx(i,3)-v(3)*xy(i,3)-v(4)*xz(i,3)+bm*x5(i,4)+cp*x5(i,1)
5340 
5341  i3=i2+4
5342 
5343  f(i3)=v(1)*x0(i,4)-v(2)*xx(i,4)-v(3)*xy(i,4)-v(4)*xz(i,4)-bp*x5(i,3)-cp*x5(i,2)
5344 
5345  enddo
5346 
5347  endif
5348 
5349 
5350 
5351 ! if(Ds.eq.16) then
5352 ! test(:) = SpiVL(sp,v)
5353 ! print *, ""
5354 ! print *, "spb2",f(1:Ds)
5355 ! print *, "test",test(1:Ds)
5356 ! print *, "diff",test(1:Ds)-f(1:Ds)
5357 ! if( any( abs(test(1:Ds)-f(1:Ds) ).gt.1d-10 ) ) pause
5358 ! endif
5359 
5360 
5361 
5362 
5363  return
5364 end subroutine
5365 
5366 
5367  function spb2_(sp,v)
5368  implicit none
5369  double complex, intent(in) :: sp(:),v(:)
5370  double complex :: spb2_(size(sp)) ,tmp(size(sp))
5371  integer :: dv,ds
5372 
5373  ds = size(sp)
5374  if (ds == 4) dv = 4
5375  if (ds == 8) dv = 6
5376  if (ds == 16) dv = 8
5377  call spb2(dv,ds,sp,v,spb2_)
5378 
5379 ! tmp = SpiVL(sp(1:Ds),v(1:Dv))
5380 ! print *, "diff2",tmp-spb2_
5381 ! pause
5382  return
5383  end function
5384 
5385 
5386 
5387 
5388  function psp1_(sp1,sp2) result(res)
5389  implicit none
5390  complex(8), intent(in) :: sp1(:)
5391  complex(8), intent(in) :: sp2(:)
5392  complex(8) :: res
5393 
5394  res = sum(sp1(1:)*sp2(1:))
5395 
5396  end function
5397 
5398 
5399 
5400 
5401 ! RR -- new for D-dim chirality
5402  recursive function chir(sign,sp) result(res)
5403  implicit none
5404  logical :: sign
5405  double complex :: sp(:)
5406  double complex :: res(size(sp))
5407  integer :: d
5408 
5409  d = size(sp)
5410  if ( d .eq. 4) then
5411  if(sign) then !omega_+
5412  res(1) = 0.5d0*(sp(1)+sp(3))
5413  res(2) = 0.5d0*(sp(2)+sp(4))
5414  res(3) = res(1)
5415  res(4) = res(2)
5416  else !omega_-
5417  res(1) = 0.5d0*(sp(1)-sp(3))
5418  res(2) = 0.5d0*(sp(2)-sp(4))
5419  res(3) =-res(1)
5420  res(4) =-res(2)
5421  endif
5422  else
5423  res(1:d/2) = chir(sign,sp(1:d/2))
5424  res((d/2+1):d) = chir(sign,sp( (d/2+1):d ))
5425  endif
5426 
5427  end function chir
5428 
5429 
5430 
5431 
5432  recursive function ichir(sign,sp) result(res)
5433 ! RR -- this function is needed for the electric and dipole moment like couplings,
5434 !! which have a 1 +\- i*gamma5 (see 0811.3842)
5435  implicit none
5436  logical :: sign
5437  double complex :: sp(:)
5438  double complex :: res(size(sp))
5439  double complex :: ci
5440  integer :: d
5441 
5442  ci=(0d0,1d0)
5443  d = size(sp)
5444  if ( d .eq. 4) then
5445  if(sign) then !omega_+
5446  res(1) = 0.5d0*(sp(1)+ci*sp(3))
5447  res(2) = 0.5d0*(sp(2)+ci*sp(4))
5448  res(3) = 0.5d0*(ci*sp(1)+sp(3))
5449  res(4) = 0.5d0*(ci*sp(2)+sp(4))
5450  else !omega_-
5451  res(1) = 0.5d0*(sp(1)-ci*sp(3))
5452  res(2) = 0.5d0*(sp(2)-ci*sp(4))
5453  res(3) = 0.5d0*(-ci*sp(1)+sp(3))
5454  res(4) = 0.5d0*(-ci*sp(2)+sp(4))
5455  endif
5456  else
5457  res(1:d/2) = ichir(sign,sp(1:d/2))
5458  res((d/2+1):d) = ichir(sign,sp( (d/2+1):d ))
5459  endif
5460 
5461  end function ichir
5462 
5463 
5464 
5465 
5466  function vbqv(sp,e1,coupl_left,coupl_right)
5467  implicit none
5468  complex(8), intent(in) :: e1(:)
5469  complex(8), intent(in) :: sp(:)
5470  complex(8), intent(in) :: coupl_left,coupl_right
5471  complex(8) :: vbqv(size(sp))
5472 
5473 ! vbqV = -(0d0,1d0)*( coupl_left*Chir(.false.,spb2_(sp,e1)) + coupl_right*Chir(.true.,spb2_(sp,e1)) )
5474  vbqv = -(0d0,1d0)*( coupl_left*chir(.false.,sp) + coupl_right*chir(.true.,sp) )
5475 
5476  return
5477  end function
5478 
5479 
5480 
5481  function vvq(e1,sp,coupl_left,coupl_right)
5482  implicit none
5483  complex(8), intent(in) :: e1(:)
5484  complex(8), intent(in) :: sp(:)
5485  complex(8), intent(in) :: coupl_left,coupl_right
5486  complex(8) :: vvq(size(sp))
5487 
5488 ! vVq = -(0d0,1d0)*( coupl_left*Chir(.true., spi2_(e1,sp)) + coupl_right*Chir(.false., spi2_(e1,sp)) )
5489  vvq = -(0d0,1d0)*( coupl_left*chir(.false.,sp) + coupl_right*chir(.true.,sp) )
5490 
5491 
5492  return
5493  end function
5494 
5495 
5496 
5497 
5498  function sc_(p1,p2)
5499  implicit none
5500  complex(8) :: p1(:),p2(:)
5501  complex(8) :: sc_
5502  integer :: sizemin
5503 
5504  sizemin=min(size(p1),size(p2))
5505  call rsc_(sizemin,p1,p2,sc_)
5506 
5507  return
5508  end function
5509 
5510 
5511 
5512  subroutine rsc_(n,x,y,r)
5513  implicit none
5514  integer i,n
5515  complex(8) x(*),y(*)
5516  complex(8) r
5517 
5518  r = x(1)*y(1)
5519  do i=2, n
5520  r = r - x(i)*y(i)
5521  enddo
5522 
5523  return
5524  end subroutine
5525 
5526 
5527 
5528 
5529 
5530 
5531  function vggg(e1,k1,e2,k2)
5532  implicit none
5533  complex(8), intent(in) :: e1(:), e2(:)
5534  complex(8), intent(in) :: k1(:), k2(:)
5535  complex(8) :: vggg(size(e1))
5536  complex(8):: sk1e2,se1e2,sk2e1,xx
5537  real(8), parameter :: sqrt2 = 1.4142135623730950488016887242096980786d0
5538 
5539 
5540  sk1e2=sc_(k1,e2)
5541  sk2e1=sc_(k2,e1)
5542  se1e2=sc_(e1,e2)
5543  xx=(0.0d0,1.0d0)*sqrt2
5544  vggg = xx*(-sk1e2*e1+sk2e1*e2+se1e2/2d0*(k1-k2))
5545 
5546  end function vggg
5547 
5548 
5549  function vgggg(e1,e2,e3)
5550  implicit none
5551  complex(8), intent(in) :: e1(:),e2(:),e3(:)
5552  complex(8) :: vgggg(size(e1))
5553  complex(8):: se1e3,se2e3,se1e2
5554 
5555  se1e3=sc_(e1,e3)
5556  se2e3=sc_(e2,e3)
5557  se1e2=sc_(e1,e2)
5558  vgggg = (0.0d0,1.0d0)*(e2*se1e3-0.5d0*(e1*se2e3+ e3*se1e2))
5559 
5560  end function vgggg
5561 
5562 
5563  function vqg(sp,e1)
5564  implicit none
5565  complex(8), intent(in) :: e1(:)
5566  complex(8), intent(in) :: sp(:)
5567  complex(8) :: vqg(size(sp))
5568  real(8), parameter :: sqrt2 = 1.4142135623730950488016887242096980786d0
5569 
5570  vqg = (0d0,1d0)/sqrt2*spb2_(sp,e1)
5571 
5572  end function vqg
5573 
5574 
5575 
5576 
5577  function vgq(e1,sp)
5578  implicit none
5579  complex(8), intent(in) :: e1(:)
5580  complex(8), intent(in) :: sp(:)
5581  complex(8) :: vgq(size(sp))
5582  real(8), parameter :: sqrt2 = 1.4142135623730950488016887242096980786d0
5583 
5584  vgq = (0d0,-1d0)/sqrt2*spb2_(sp,e1)
5585 
5586  end function vgq
5587 
5588 
5589 
5590 
5591 
5592  function vbqg(sp,e1)
5593  implicit none
5594  complex(8), intent(in) :: e1(:)
5595  complex(8), intent(in) :: sp(:)
5596  complex(8) :: vbqg(size(sp))
5597  real(8), parameter :: sqrt2 = 1.4142135623730950488016887242096980786d0
5598 
5599  vbqg = (0d0,-1d0)/sqrt2*spi2_(e1,sp)
5600 
5601  end function vbqg
5602 
5603 
5604 
5605  function vgbq(e1,sp)
5606  implicit none
5607  complex(8), intent(in) :: e1(:)
5608  complex(8), intent(in) :: sp(:)
5609  complex(8) :: vgbq(size(sp))
5610  real(8), parameter :: sqrt2 = 1.4142135623730950488016887242096980786d0
5611 
5612  vgbq = (0d0,1d0)/sqrt2*spi2_(e1,sp)
5613 
5614  end function vgbq
5615 
5616 
5617 
5618 ! function vbqq(Dv,sp1,sp2)
5619 ! implicit none
5620 ! complex(8), intent(in) :: sp1(:), sp2(:)
5621 ! integer, intent(in) :: Dv
5622 ! integer :: i
5623 ! complex(8) :: vbqq(Dv)
5624 ! complex(8) :: rr, va(Dv),sp1a(size(sp1))
5625 ! real(8), parameter :: sqrt2 = 1.4142135623730950488016887242096980786d0
5626 !
5627 ! va=(0d0,0d0)
5628 ! vbqq=(0d0,0d0)
5629 !
5630 ! do i=1,Dv
5631 ! if (i.eq.1) then
5632 ! va(1)=(1d0,0d0)
5633 ! else
5634 ! va(i)=(-1d0,0d0)
5635 ! endif
5636 ! sp1a=spb2_(sp1,va)
5637 !
5638 ! rr=(0d0,-1d0)/sqrt2*psp1_(sp1a,sp2)
5639 ! if (i.eq.1) then
5640 ! vbqq = vbqq + rr*va
5641 ! else
5642 ! vbqq = vbqq - rr*va
5643 ! endif
5644 ! va(i)=(0d0,0d0)
5645 ! enddo
5646 !
5647 ! end function vbqq
5648 
5649 
5650 
5651 
5652 
5653  function vbqq(Dummy,sp1,sp2)! this is my own simpler 4-dim version
5654  implicit none
5655  complex(8), intent(in) :: sp1(1:4), sp2(1:4)
5656  integer :: i,dummy
5657  complex(8) :: vbqq(4)
5658  complex(8) :: sp1a(4)
5659  real(8) :: va(1:4,1:4)
5660  real(8), parameter :: sqrt2 = 1.4142135623730950488016887242096980786d0
5661 
5662  va(1,1:4)=(/+1d0,0d0,0d0,0d0/)
5663  va(2,1:4)=(/0d0,-1d0,0d0,0d0/)
5664  va(3,1:4)=(/0d0,0d0,-1d0,0d0/)
5665  va(4,1:4)=(/0d0,0d0,0d0,-1d0/)
5666 
5667  do i=1,4
5668  sp1a=spivl(sp1,dcmplx(va(i,1:4)))
5669  vbqq(i) = (sp1a(1)*sp2(1)+sp1a(2)*sp2(2)+sp1a(3)*sp2(3)+sp1a(4)*sp2(4)) * (0d0,-1d0)/sqrt2
5670  enddo
5671 
5672 
5673  end function vbqq
5674 
5675 
5676 
5677 
5678  function vvbqq(sp1,sp2)
5679  implicit none
5680  complex(8), intent(in) :: sp1(:), sp2(:)
5681  integer :: i,j
5682  complex(8) :: vvbqq(4,4)
5683  complex(8) :: sp1a(4)
5684  real(8) :: va(1:4,1:4)
5685 
5686  va(1,1:4)=(/+1d0,0d0,0d0,0d0/)
5687  va(2,1:4)=(/0d0,-1d0,0d0,0d0/)
5688  va(3,1:4)=(/0d0,0d0,-1d0,0d0/)
5689  va(4,1:4)=(/0d0,0d0,0d0,-1d0/)
5690 
5691  do i=1,4
5692  do j=1,4
5693  sp1a=spb2_(sp1, dcmplx(va(i,1:4)))
5694  sp1a=spb2_(sp1a,dcmplx(va(j,1:4)))
5695  vvbqq(i,j) = psp1_(sp1a,sp2)
5696  enddo
5697  enddo
5698 
5699  end function vvbqq
5700 
5701 
5702 
5703 
5704 
5705 
5706 
5707 END MODULE
modttbhiggs::propcut
real(8), parameter propcut
Definition: mod_TTBHiggs.F90:58
modparameters::glu_
integer, target, public glu_
Definition: mod_Parameters.F90:1093
modttbhiggs
Definition: mod_TTBHiggs.F90:1
modttbhiggs::colorlesstag
integer, parameter colorlesstag
Definition: mod_TTBHiggs.F90:11
modparameters::vev
real(8), public vev
Definition: mod_Parameters.F90:249
modtopdecay::topdecay
subroutine, public topdecay(Flavor, Mom, Spinor, TopHel)
Definition: mod_TopDecay.F90:15
modttbhiggs::cur_f_6f
complex(8) function, dimension(1:ds) cur_f_6f(Gluons, Quarks, Quark1PartType, NumGlu, tag_f, tag_Z)
Definition: mod_TTBHiggs.F90:2654
modttbhiggs::vggg
complex(8) function, dimension(size(e1)) vggg(e1, k1, e2, k2)
Definition: mod_TTBHiggs.F90:5532
modparameters::pdfglu_
integer, parameter, public pdfglu_
Definition: mod_Parameters.F90:1124
modttbhiggs::cur_f_6fv
complex(8) function, dimension(1:ds) cur_f_6fv(Gluons, Quarks, Quark1PartType, Boson, BosonVertex, NumGlu, tag_f)
Definition: mod_TTBHiggs.F90:3974
modttbhiggs::f
recursive complex(8) function, dimension(size(sp)) f(e, k, sp, p, mass, flout, flin, ms)
Definition: mod_TTBHiggs.F90:1783
modttbhiggs::evalamp_gg_ttbh
subroutine, public evalamp_gg_ttbh(Mom, SqAmp)
Definition: mod_TTBHiggs.F90:292
modtopdecay
Definition: mod_TopDecay.F90:1
modttbhiggs::cur_f_2f
complex(8) function, dimension(1:ds) cur_f_2f(Gluons, Quarks, Quark1PartType, NumGlu)
Definition: mod_TTBHiggs.F90:2273
modparameters::topdecays
integer, public topdecays
Definition: mod_Parameters.F90:17
modttbhiggs::spi2
subroutine spi2(Dv, Ds, v, sp, f)
Definition: mod_TTBHiggs.F90:5093
modttbhiggs::evalamp_qqb_ttbh
subroutine, public evalamp_qqb_ttbh(Mom, SqAmp)
Definition: mod_TTBHiggs.F90:364
modttbhiggs::bfv
recursive complex(8) function, dimension(size(sp)) bfv(e, k, sp, p, mass, QuarkFlavor, eV, kV, ms)
Definition: mod_TTBHiggs.F90:815
modttbhiggs::vgbq
complex(8) function, dimension(size(sp)) vgbq(e1, sp)
Definition: mod_TTBHiggs.F90:5606
modparameters::sqrt2
real(dp), parameter, public sqrt2
Definition: mod_Parameters.F90:80
modttbhiggs::dv
integer, parameter dv
Definition: mod_TTBHiggs.F90:59
modttbhiggs::cur_f_4f
complex(8) function, dimension(1:ds) cur_f_4f(Gluons, Quarks, Quark1PartType, NumGlu, tag_f, tag_Z_arg)
Definition: mod_TTBHiggs.F90:1401
modparameters::ci
complex(8), parameter, public ci
Definition: mod_Parameters.F90:88
modttbhiggs::thetreeamps_gg_ttbh
type(treeprocess), dimension(1:2), save thetreeamps_gg_ttbh
Definition: mod_TTBHiggs.F90:62
modttbhiggs::spi2_
double complex function, dimension(size(sp)) spi2_(v, sp)
Definition: mod_TTBHiggs.F90:5214
modttbhiggs::copyparticleptr
subroutine copyparticleptr(InPointer, OutPointer)
Definition: mod_TTBHiggs.F90:5064
modparameters::bot_
integer, target, public bot_
Definition: mod_Parameters.F90:1089
modtopdecay::vspi_dirac
subroutine, public vspi_dirac(p, m, i, f)
Definition: mod_TopDecay.F90:374
modttbhiggs::vgggg
complex(8) function, dimension(size(e1)) vgggg(e1, e2, e3)
Definition: mod_TTBHiggs.F90:5550
modparameters::m_top
real(8), public m_top
Definition: mod_Parameters.F90:224
modttbhiggs::psp1_
complex(8) function psp1_(sp1, sp2)
Definition: mod_TTBHiggs.F90:5389
modparameters::nf
real(dp), parameter, public nf
Definition: mod_Parameters.F90:1014
modttbhiggs::vvbqq
complex(8) function, dimension(4, 4) vvbqq(sp1, sp2)
Definition: mod_TTBHiggs.F90:5679
modttbhiggs::chir
recursive double complex function, dimension(size(sp)) chir(sign, sp)
Definition: mod_TTBHiggs.F90:5403
modttbhiggs::thetreeamps_qqb_ttbh
type(treeprocess), dimension(1:1), save thetreeamps_qqb_ttbh
Definition: mod_TTBHiggs.F90:63
modttbhiggs::extparticles
type(particle), dimension(1:7), save extparticles
Definition: mod_TTBHiggs.F90:61
modparameters::kappa
complex(8), public kappa
Definition: mod_Parameters.F90:882
modttbhiggs::cur_f_2fv
complex(8) function, dimension(1:ds) cur_f_2fv(Gluons, Quark, Quark1PartType, Boson, NumGlu)
Definition: mod_TTBHiggs.F90:649
modparameters::ev
real(8), parameter, public ev
Definition: mod_Parameters.F90:97
modttbhiggs::spb2
subroutine spb2(Dv, Ds, sp, v, f)
Definition: mod_TTBHiggs.F90:5250
modttbhiggs::cur_g_4f
complex(8) function, dimension(dv) cur_g_4f(Gluons, Quarks, NumGlu)
Definition: mod_TTBHiggs.F90:2344
modparameters::ubar0
complex(dp) function, dimension(4) ubar0(p, i)
Definition: mod_Parameters.F90:3193
modttbhiggs::eval_tripvert
complex(8) function, dimension(1:dv) eval_tripvert(k1, k2, v1, v2)
Definition: mod_TTBHiggs.F90:5023
modttbhiggs::g
recursive complex(8) function, dimension(size(e, dim=1)) g(e, k)
Definition: mod_TTBHiggs.F90:1605
modttbhiggs::ichir
recursive double complex function, dimension(size(sp)) ichir(sign, sp)
Definition: mod_TTBHiggs.F90:5433
modttbhiggs::sc_
complex(8) function sc_(p1, p2)
Definition: mod_TTBHiggs.F90:5499
modttbhiggs::fv
recursive complex(8) function, dimension(size(sp)) fv(e, k, sp, p, mass, QuarkFlavor, eV, kV, ms)
Definition: mod_TTBHiggs.F90:687
modttbhiggs::new_calc_ampl
subroutine new_calc_ampl(tag_f, tag_Z, TreeProc, Res)
Definition: mod_TTBHiggs.F90:428
modparameters::kappa_tilde
complex(8), public kappa_tilde
Definition: mod_Parameters.F90:883
modttbhiggs::vqg
complex(8) function, dimension(size(sp)) vqg(sp, e1)
Definition: mod_TTBHiggs.F90:5564
modttbhiggs::evalxsec_pp_ttbh
subroutine, public evalxsec_pp_ttbh(Mom, SelectProcess, Res)
Definition: mod_TTBHiggs.F90:75
modparameters::atop_
integer, target, public atop_
Definition: mod_Parameters.F90:1110
modparameters::spinavg
real(8), parameter, public spinavg
Definition: mod_Parameters.F90:91
modttbhiggs::bf
recursive complex(8) function, dimension(size(sp)) bf(e, k, sp, p, mass, flout, flin, ms)
Definition: mod_TTBHiggs.F90:1892
modttbhiggs::rsc_
subroutine rsc_(n, x, y, r)
Definition: mod_TTBHiggs.F90:5513
modparameters::isaboson
logical function isaboson(PartType)
Definition: mod_Parameters.F90:2453
modttbhiggs::vvq
complex(8) function, dimension(size(sp)) vvq(e1, sp, coupl_left, coupl_right)
Definition: mod_TTBHiggs.F90:5482
modttbhiggs::vbqv
complex(8) function, dimension(size(sp)) vbqv(sp, e1, coupl_left, coupl_right)
Definition: mod_TTBHiggs.F90:5467
modttbhiggs::ds
integer, parameter ds
Definition: mod_TTBHiggs.F90:59
modttbhiggs::couplhtt_left_dyn
complex(8) couplhtt_left_dyn
Definition: mod_TTBHiggs.F90:66
modparameters
Definition: mod_Parameters.F90:1
modttbhiggs::cur_f_4fv
complex(8) function, dimension(1:ds) cur_f_4fv(Gluons, Quarks, Quark1PartType, Boson, BosonVertex, NumGlu, tag_f, tag_Z)
Definition: mod_TTBHiggs.F90:954
modttbhiggs::vbqq
complex(8) function, dimension(4) vbqq(Dummy, sp1, sp2)
Definition: mod_TTBHiggs.F90:5654
modttbhiggs::couplhtt_right_dyn
complex(8) couplhtt_right_dyn
Definition: mod_TTBHiggs.F90:66
modttbhiggs::exitprocess_ttbh
subroutine, public exitprocess_ttbh()
Definition: mod_TTBHiggs.F90:232
modttbhiggs::spb2_
double complex function, dimension(size(sp)) spb2_(sp, v)
Definition: mod_TTBHiggs.F90:5368
modttbhiggs::summom
complex(8) function, dimension(1:dv) summom(Particles, i1, i2)
Definition: mod_TTBHiggs.F90:4993
modtopdecay::psp1_
complex(8) function psp1_(sp1, sp2)
Definition: mod_TopDecay.F90:317
modttbhiggs::spivl
double complex function, dimension(size(sp)) spivl(sp, v)
Definition: mod_TTBHiggs.F90:5235
modttbhiggs::fourvecdot
complex(8) function fourvecdot(p1, p2)
Definition: mod_TTBHiggs.F90:5009
modttbhiggs::treeprocess
Definition: mod_TTBHiggs.F90:36
modttbhiggs::linktreeparticles
subroutine linktreeparticles(TheTreeAmp, TheParticles)
Definition: mod_TTBHiggs.F90:472
modparameters::wp_
integer, target, public wp_
Definition: mod_Parameters.F90:1096
modttbhiggs::vgq
complex(8) function, dimension(size(sp)) vgq(e1, sp)
Definition: mod_TTBHiggs.F90:5578
modparameters::m_bot
real(8), public m_bot
Definition: mod_Parameters.F90:238
modttbhiggs::vbqg
complex(8) function, dimension(size(sp)) vbqg(sp, e1)
Definition: mod_TTBHiggs.F90:5593
modparameters::m_reso
real(8), public m_reso
Definition: mod_Parameters.F90:230
endif
O0 g endif() string(TOLOWER "$
Definition: CMakeLists.txt:143
modparameters::alphas
real(dp), public alphas
Definition: mod_Parameters.F90:269
modparameters::str_
integer, target, public str_
Definition: mod_Parameters.F90:1087
modparameters::isaquark
logical function isaquark(PartType)
Definition: mod_Parameters.F90:2369
modttbhiggs::cur_g_4fv
complex(8) function, dimension(dv) cur_g_4fv(Gluons, Quarks, Boson, BosonVertex, NumGlu)
Definition: mod_TTBHiggs.F90:3124
modttbhiggs::initprocess_ttbh
subroutine, public initprocess_ttbh()
Definition: mod_TTBHiggs.F90:132
modparameters::astr_
integer, target, public astr_
Definition: mod_Parameters.F90:1109
modttbhiggs::particle
Definition: mod_TTBHiggs.F90:14
modtopdecay::ubarspi_dirac
subroutine, public ubarspi_dirac(p, m, i, f)
Definition: mod_TopDecay.F90:331
modttbhiggs::evalxsec_pp_bbbh
subroutine, public evalxsec_pp_bbbh(Mom, SelectProcess, Res)
Definition: mod_TTBHiggs.F90:111
modttbhiggs::linear_map
integer function linear_map(i1, i2, Ngluons)
Definition: mod_TTBHiggs.F90:5051
modparameters::hig_
integer, target, public hig_
Definition: mod_Parameters.F90:1100
modttbhiggs::cur_g_2f
complex(8) function, dimension(1:dv) cur_g_2f(Gluons, Quarks, NumGlu)
Definition: mod_TTBHiggs.F90:2006
modparameters::pol_mless
complex(dp) function, dimension(4) pol_mless(p, i, outgoing)
Definition: mod_Parameters.F90:2997
modparameters::top_
integer, target, public top_
Definition: mod_Parameters.F90:1088
modparameters::quarkcolavg
real(8), parameter, public quarkcolavg
Definition: mod_Parameters.F90:91
modttbhiggs::ptrtoparticle
Definition: mod_TTBHiggs.F90:24
modparameters::pho_
integer, target, public pho_
Definition: mod_Parameters.F90:1094
modparameters::z0_
integer, target, public z0_
Definition: mod_Parameters.F90:1095
modttbhiggs::cur_g_2fv
complex(8) function, dimension(1:dv) cur_g_2fv(Gluons, Quarks, Boson, NumGlu)
Definition: mod_TTBHiggs.F90:2110
modparameters::ne
complex(8), parameter, public ne
Definition: mod_Parameters.F90:89
modttbhiggs::eval_quadvert
complex(8) function, dimension(1:dv) eval_quadvert(k1, k2, k3)
Definition: mod_TTBHiggs.F90:5035
modparameters::gluoncolavg
real(8), parameter, public gluoncolavg
Definition: mod_Parameters.F90:91
modttbhiggs::cur_g
complex(8) function, dimension(1:dv) cur_g(Gluons, NumGlu)
Definition: mod_TTBHiggs.F90:1705