Page MenuHomeHEPForge
Files F10664286

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
diff --git a/Looptools/A/ffca0.F b/Looptools/A/ffca0.F
--- a/Looptools/A/ffca0.F
+++ b/Looptools/A/ffca0.F
@@ -1,60 +1,42 @@
-*###[ ffca0:
- subroutine ffca0(ca0,cm,ier)
-***#[*comment:***********************************************************
-* *
-* calculates the one-point function (see 't Hooft and *
-* Veltman) for complex mass *
-* *
-* Input: cm (complex) mass2, re>0, im<0. *
-* *
-* Output: ca0 (complex) A0, the one-point function, *
-* ier 0 (OK) *
-* *
-* Calls: log. *
-* *
-***#]*comment:***********************************************************
-* #[ declarations:
+* ffca0.F
+* the one-point function for complex mass
+* original code by G.J. van Oldenborgh
+* this file is part of LoopTools
+* last modified 7 Dec 10 th
+
+#include "externals.h"
+
+* Input: cm (complex) mass2, re > 0, im < 0.
+* Output: ca0 (complex) A0, the one-point function,
+* ier 0 (OK)
+
+ subroutine ffca0(ca0, cm, ier)
implicit none
-*
-* arguments
-*
+ double complex ca0, cm
integer ier
- DOUBLE COMPLEX ca0,cm
-*
-* local variables
-*
- DOUBLE COMPLEX cmu,clogm,c
- DOUBLE PRECISION absc,xm
-*
-* common blocks etc
-*
- include 'ff.h'
+
+#include "ff.h"
+
+ double complex cmu, clogm
+
+ double precision absc
+ double complex c
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
-*
-* #] declarations:
-* #[ the real case:
-*
-* adapted to log-and-pole scheme 25-mar-1992
-*
- if ( DIMAG(cm) .eq. 0 .or. nschem .lt. 7 ) then
- xm = DBLE(cm)
- call ffxa0(ca0,xm,ier)
- return
+
+* the real case:
+* adapted to log-and-pole scheme 25-mar-1992
+ if( DIMAG(cm) .eq. 0 .or. nschem .lt. 7 ) then
+ call ffxa0(ca0, cm, ier)
+ return
endif
-* #] the real case:
-* #[ "calculations":
- if ( mudim .ne. 0 ) then
- cmu = cm/DBLE(mudim)
+
+ cmu = cm
+ if( mudim .ne. 0 ) cmu = cmu/mudim
+ if( absc(cmu) .gt. xclogm ) then
+ clogm = log(cmu)
else
- cmu = cm
+ clogm = 0
+ if ( cmu .ne. 0 ) call fferr(1, ier)
endif
- if ( absc(cmu) .gt. xclogm ) then
- clogm = log(cmu)
- else
- clogm = 0
- if ( cmu .ne. czero ) call fferr(1,ier)
- endif
- ca0 = - cm * ( clogm - 1 - DBLE(delta) )
-* #] "calculations":
-*###] ffca0:
+ ca0 = -cm*(clogm - 1 - delta)
end
diff --git a/Looptools/A/ffxa0.F b/Looptools/A/ffxa0.F
--- a/Looptools/A/ffxa0.F
+++ b/Looptools/A/ffxa0.F
@@ -1,48 +1,32 @@
-*###[ ffxa0:
- subroutine ffxa0(ca0,xm,ier)
-***#[*comment:***********************************************************
-* *
-* calculates the one-point function (see 't Hooft and *
-* Veltman) for real mass *
-* *
-* Input: xm (real) mass2, *
-* *
-* Output: ca0 (complex) A0, the one-point function, *
-* ier 0 (ok) *
-* *
-* Calls: log. *
-* *
-***#]*comment:***********************************************************
-* #[ declarations:
+* ffxa0.F
+* the one-point function for real mass
+* original code by G.J. van Oldenborgh
+* this file is part of LoopTools
+* last modified 7 Dec 10 th
+
+#include "externals.h"
+
+* Input: xm (real) mass2,
+* Output: ca0 (complex) A0, the one-point function,
+* ier 0 (ok)
+
+ subroutine ffxa0(ca0, xm, ier)
implicit none
-*
-* arguments
-*
+ double complex ca0
+ double precision xm
integer ier
- DOUBLE COMPLEX ca0
- DOUBLE PRECISION xm
-*
-* local variables
-*
- DOUBLE PRECISION xmu,xlogm
-*
-* common blocks etc
-*
- include 'ff.h'
-* #] declarations:
-* #[ "calculations":
- if ( mudim .ne. 0 ) then
- xmu = xm/mudim
+
+#include "ff.h"
+
+ double precision xmu, xlogm
+
+ xmu = xm
+ if( mudim .ne. 0 ) xmu = xmu/mudim
+ if( xmu .gt. xalogm ) then
+ xlogm = log(xmu)
else
- xmu = xm
- endif
- if ( xmu .gt. xalogm ) then
- xlogm = log(xmu)
- else
- xlogm = 0
- if ( xmu .ne. 0 ) call fferr(2,ier)
+ xlogm = 0
+ if( xmu .ne. 0 ) call fferr(2, ier)
endif
ca0 = -(xm*(xlogm - 1 - delta))
-* #] "calculations":
-*###] ffxa0:
end
diff --git a/Looptools/B/Bcoeff.F b/Looptools/B/Bcoeff.F
--- a/Looptools/B/Bcoeff.F
+++ b/Looptools/B/Bcoeff.F
@@ -1,77 +1,103 @@
* Bcoeff.F
* invoke the two-point tensor coefficients
* this file is part of LoopTools
-* last modified 5 Dec 06 th
+* last modified 22 Dec 10 th
#include "defs.h"
subroutine Bcoeff(para, B, ldpara)
implicit none
integer ldpara
double precision para(ldpara,Pbb)
double complex B(Nbb)
#include "lt.h"
double complex Bcmp(Nbb)
+ double precision p, m1, m2
integer ier(Nbb), ierall, i
+ p = para(1,1)
+ m1 = para(1,2)
+ m2 = para(1,3)
+
+ if( lambda .lt. 0 .or.
+ & abs(p) + abs(m1) + abs(m2) .lt. eps ) then
+ do i = 1, Nbb
+ B(i) = 0
+ enddo
+ if( lambda .eq. -1 ) then
+ B(bb0) = 1
+ B(bb1) = -.5D0
+ B(bb00) = -(p - 3*(m1 + m2))/12D0
+ B(bb11) = 1/3D0
+ B(bb001) = -(p - 2*m1 - 4*m2)/24D0
+ B(bb111) = -.25D0
+ if( m1*m2 .eq. 0 .and. abs(p - m1 - m2) .lt. acc )
+ & B(dbb0) = -.5D0/p
+ if( m2 .eq. 0 .and. abs(p - m1) .lt. acc )
+ & B(dbb1) = .5D0/p
+ B(dbb00) = -1/12D0
+ endif
+ return
+ endif
+
goto (1, 2, 3) ibits(versionkey, KeyBget, 2)
call Bcoeffa(para, B, ldpara, ier)
ierall = 0
do i = 1, Nbb
ierall = max(ierall, ier(i))
enddo
if( ierall .gt. warndigits ) then
call Bcoeffb(para, Bcmp, ldpara)
call Bcheck(para, B, Bcmp, ldpara, ier)
endif
return
1 call Bcoeffb(para, B, ldpara)
return
2 call Bcoeffa(para, B, ldpara, ier)
call Bcoeffb(para, Bcmp, ldpara)
call Bcheck(para, B, Bcmp, ldpara, ier)
return
3 call Bcoeffa(para, Bcmp, ldpara, ier)
call Bcoeffb(para, B, ldpara)
call Bcheck(para, Bcmp, B, ldpara, ier)
end
************************************************************************
subroutine Bcheck(para, Ba, Bb, ldpara, ier)
implicit none
integer ldpara, ier(Nbb)
DVAR para(ldpara,Pbb)
double complex Ba(Nbb), Bb(Nbb)
#include "lt.h"
integer i
logical ini
character*5 name(Nbb)
data name /"bb0", "bb1", "bb00", "bb11", "bb001", "bb111",
& "dbb0", "dbb1", "dbb00", "dbb11"/
ini = .TRUE.
do i = 1, Nbb
if( abs(Ba(i) - Bb(i)) .gt. maxdev*abs(Ba(i)) ) then
if( ini ) then
print *, "Discrepancy in Bget:"
call DumpPara(2, para, ldpara, " ")
ini = .FALSE.
endif
print *, name(i), " a =", Ba(i)
print *, name(i), " b =", Bb(i)
if( ier(i) .gt. errdigits ) Ba(i) = Bb(i)
endif
enddo
end
diff --git a/Looptools/B/BcoeffC.F b/Looptools/B/BcoeffC.F
--- a/Looptools/B/BcoeffC.F
+++ b/Looptools/B/BcoeffC.F
@@ -1,38 +1,54 @@
* BcoeffC.F
* invoke the two-point tensor coefficients
* this file is part of LoopTools
-* last modified 16 Nov 06 th
+* last modified 24 Aug 09 th
#include "defs.h"
subroutine BcoeffC(para, B, ldpara)
implicit none
integer ldpara
double complex para(ldpara,Pbb)
double complex B(Nbb)
#include "lt.h"
integer ier(Nbb), i
logical ini
character*5 name(Nbb)
data name /"bb0", "bb1", "bb11", "bb00", "bb001", "bb111",
& "dbb0", "dbb1", "dbb00", "dbb11"/
+ if( lambda .lt. 0 ) then
+ do i = 1, Nbb
+ B(i) = 0
+ enddo
+ if( lambda .eq. -1 ) then
+ B(bb0) = 1
+ B(bb1) = -.5D0
+ B(bb00) = -(para(1,1) - 3*(para(1,2) + para(1,3)))/12D0
+ B(bb11) = 1/3D0
+ B(bb001) = -(para(1,1) - 2*para(1,2) - 4*para(1,3))/24D0
+ B(bb111) = -.25D0
+ B(dbb00) = -1/12D0
+ endif
+ return
+ endif
+
call BcoeffaC(para, B, ldpara, ier)
ini = .TRUE.
do i = 1, Nbb
if( ier(i) .gt. warndigits ) then
if( ini ) then
- print *, "Loss of digits in CBget for:"
+ print *, "Loss of digits in BgetC for:"
call DumpParaC(2, para, ldpara, " ")
ini = .FALSE.
endif
print *, name(i), " claims ", ier(i), "lost digits"
endif
enddo
end
diff --git a/Looptools/B/Bcoeffa.F b/Looptools/B/Bcoeffa.F
--- a/Looptools/B/Bcoeffa.F
+++ b/Looptools/B/Bcoeffa.F
@@ -1,116 +1,117 @@
* Bcoeffa.F
* the two-point tensor coefficients from FF
* this file is part of LoopTools
-* last modified 7 Dec 05 th
+* last modified 28 Sep 10 th
#include "defs.h"
subroutine XBcoeffa(para, B, ldpara, ier)
implicit none
integer ldpara, ier(Nbb)
DVAR para(ldpara,Pbb)
double complex B(Nbb)
#include "lt.h"
DVAR p, m1, m2, dm
double complex a0(2), b2(2), pdb0
integer i
logical dump
#ifdef COMPLEXPARA
DVAR m1dm
double complex dmp, d2mp
#endif
- p = para(1,1)
- m1 = para(1,2)
- m2 = para(1,3)
-
#ifdef COMPLEXPARA
- if( DIMAG(p) .eq. 0 .and.
- & DIMAG(m1) .eq. 0 .and.
- & DIMAG(m2) .eq. 0 ) then
+ if( abs(DIMAG(para(1,1))) .gt. 0 )
+ & print *, "Warning: complex momenta not implemented"
+ if( abs(DIMAG(para(1,2))) +
+ & abs(DIMAG(para(1,3))) .eq. 0 ) then
call Bcoeffa(para, B, 2, ier)
return
endif
#endif
+ p = para(1,1)
+ m1 = para(1,2)
+ m2 = para(1,3)
+
serial = serial + 1
dump = ibits(debugkey, DebugB, 1) .ne. 0 .and.
& serial .ge. debugfrom .and. serial .le. debugto
if( dump ) call XDumpPara(2, para, ldpara, "Bcoeffa")
do i = 1, Nbb
ier(i) = 0
enddo
ldot = .TRUE.
i = 0
call Xffb0(B(bb0), p, m1, m2, i)
ier(bb0) = i
call Xffa0(a0(1), m1, i)
call Xffa0(a0(2), m2, i)
ier(bb1) = i
call Xffb1(B(bb1), B(bb0), a0, p, m1, m2, Xfpij2, ier(bb1))
call Xffb2p(b2, B(bb1), B(bb0), a0, p, m1, m2, Xfpij2, i)
ier(bb00) = i
ier(bb11) = i
B(bb11) = b2(1)
B(bb00) = b2(2)
ldot = .FALSE.
dm = m1 - m2
if( abs(p) .lt. acc ) then
if( abs(dm) .lt. acc ) then
B(bb001) = -.5D0*B(bb00)
else
B(bb001) = -( ((m1 + m2)/6D0)**2 +
& m1*m2/6D0 * (B(bb0) + 1/3D0) +
& (dm - m2)/3D0 * B(bb00) )/dm
endif
else
B(bb001) = .125D0*( 2*m1*B(bb1) - a0(2) +
& (p + dm)*(B(bb11) + 1/6D0) - .5D0*(m1 + m2) )
endif
call Xffdb0(B(dbb0), pdb0, p, m1, m2, ier(dbb0))
#ifdef COMPLEXPARA
if( abs(p) .lt. acc ) then
if( abs(dm) .lt. acc ) then
B(bb111) = -.25D0*B(bb0)
else
m1dm = m1/dm
B(bb111)= 3/16D0 + .25D0*a0(2)/dm*(m1dm + 1) +
& .5D0*m1dm*(m1dm*(B(bb1) - .5D0) - 1/6D0)
endif
else
B(bb111) = -.25D0*( a0(2) + 2*m1*B(bb1) +
& (p + dm)*(3*B(bb11) + 1/6D0) - .5D0*(m1 + m2) )/p
endif
B(dbb1) = .5D0/p*(
& (a0(2) - a0(1) + dm*B(bb0))/p -
& (p + dm)*B(dbb0) )
dmp = (m1 - m2)/p
d2mp = (m1 - 2*m2)/p
B(dbb11) = 1/3D0*(
& ( (.5D0*(m1 + m2) +
& (2*dmp + 1)*a0(1) - (2*dmp + 2)*a0(2))/p -
& (d2mp + 2*dmp**2)*B(bb0) )/p +
& (d2mp + dmp**2 + 1)*B(dbb0) )
#else
call ffxb111(B(bb111), p, m1, m2, ier(bb111))
call ffxdb1(B(dbb1), p, m1, m2, ier(dbb1))
call ffxdb11(B(dbb11), p, m1, m2, ier(dbb11))
#endif
B(dbb00) = 1/6D0*( 2*m1*B(dbb0) + B(bb1) +
& (p + dm)*B(dbb1) - 1/3D0 )
if( dump ) call DumpCoeff(2, B)
end
diff --git a/Looptools/B/Bcoeffb.F b/Looptools/B/Bcoeffb.F
--- a/Looptools/B/Bcoeffb.F
+++ b/Looptools/B/Bcoeffb.F
@@ -1,307 +1,309 @@
* Bcoeffb.F
* the two-point tensor coefficients from Ansgar Denner's bcanew.f,
* adapted to the conventions of LoopTools
* this file is part of LoopTools
-* last modified 5 Dec 06 th
+* last modified 22 Dec 10 th
#include "defs.h"
subroutine Bcoeffb(para, B, ldpara)
implicit none
integer ldpara
double precision para(ldpara,Pbb)
double complex B(Nbb)
#include "lt.h"
double complex fpv, yfpv, fth, xlogx, A0b
external fpv, yfpv, fth, xlogx, A0b
double precision p, m1, m2
- double precision minacc, dm
+ double precision minacc, dm, la
double complex x1, x2, y1, y2, r
double complex mu, f1, f2, g1, g2
integer sel
logical dump
p = para(1,1)
m1 = para(1,2)
m2 = para(1,3)
serial = serial + 1
dump = ibits(debugkey, DebugB, 1) .ne. 0 .and.
& serial .ge. debugfrom .and. serial .le. debugto
if( dump ) call DumpPara(2, para, ldpara, "Bcoeffb")
minacc = acc*(m1 + m2)
dm = m1 - m2
* general case
if( abs(p) .gt. minacc ) then
r = sqrt(DCMPLX(p*(p - m1 - m2) -
& m1*(p - dm) - m2*(p + dm)))
x1 = .5D0*(p + dm + r)/p
x2 = .5D0*(p + dm - r)/p
if( abs(x2) .gt. abs(x1) ) then
x1 = m1/(p*x2)
else if( abs(x1) .gt. abs(x2) ) then
x2 = m1/(p*x1)
endif
x1 = x1 + abs(p*x1)/p*eps*cI
x2 = x2 - abs(p*x2)/p*eps*cI
y2 = .5D0*(p - dm + r)/p
y1 = .5D0*(p - dm - r)/p
if( abs(y2) .gt. abs(y1) ) then
y1 = m2/(p*y2)
else if( abs(y1) .gt. abs(y2) ) then
y2 = m2/(p*y1)
endif
y1 = y1 - abs(p*y1)/p*eps*cI
y2 = y2 + abs(p*y2)/p*eps*cI
if( abs(y1) .gt. .5D0 .and. abs(y2) .gt. .5D0 ) then
mu = log(m2/mudim) - delta
B(bb0) = -(mu + fpv(1, x1, y1) + fpv(1, x2, y2))
B(bb1) = 1/2D0*(mu + fpv(2, x1, y1) + fpv(2, x2, y2))
B(bb11) = -1/3D0*(mu + fpv(3, x1, y1) + fpv(3, x2, y2))
B(bb111) = 1/4D0*(mu + fpv(4, x1, y1) + fpv(4, x2, y2))
else if( abs(x1) .lt. 10 .and. abs(x2) .lt. 10 ) then
mu = log(p/mudim*(1 - cI*eps)) - delta
g1 = xlogx(y1)
f1 = xlogx(-x1) - g1 + 1
g2 = xlogx(y2)
f2 = xlogx(-x2) - g2 + 1
B(bb0) = -(mu - f1 - f2)
f1 = x1*f1 - g1 + 1/2D0
f2 = x2*f2 - g2 + 1/2D0
B(bb1) = 1/2D0*(mu - f1 - f2)
f1 = x1*f1 - g1 + 1/3D0
f2 = x2*f2 - g2 + 1/3D0
B(bb11) = -1/3D0*(mu - f1 - f2)
f1 = x1*f1 - g1 + 1/4D0
f2 = x2*f2 - g2 + 1/4D0
B(bb111) = 1/4D0*(mu - f1 - f2)
else if( abs(x1) .gt. .5D0 .and. abs(x2) .gt. .5D0 ) then
mu = log(m1/mudim) - delta +
& fth(1, x1, y1) + fth(1, x2, y2)
B(bb0) = -mu
mu = mu + fth(2, x1, y1) + fth(2, x2, y2)
B(bb1) = 1/2D0*mu
mu = mu + fth(3, x1, y1) + fth(3, x2, y2)
B(bb11) = -1/3D0*mu
mu = mu + fth(4, x1, y1) + fth(4, x2, y2)
B(bb111) = 1/4D0*mu
else
print *, "Bcoeffb not defined for"
print *, " p =", p
print *, " m1 =", m1
print *, " m2 =", m2
B(bb0) = nan
B(bb1) = nan
B(bb11) = nan
B(bb111) = nan
endif
B(bb00) = ((p + dm)*B(bb1) +
& 2*m1*B(bb0) + A0b(m2) + m1 + m2 - p/3D0)/6D0
B(bb001) = .125D0*( 2*m1*B(bb1) - A0b(m2) +
& (p + dm)*(B(bb11) + 1/6D0) - .5D0*(m1 + m2) )
if( abs(x1 - x2) .gt. acc*abs(x1 + x2) ) then
B(dbb11) = (yfpv(3, x2, y2) - yfpv(3, x1, y1))/r
sel = 1
else if( abs(x1) .gt. 10 ) then
B(dbb11) = -DBLE((3/4D0 + (3 - 4*x1)*fpv(4, x1, y1))/
& x1**2)/p
sel = 2
else if( abs(y1) .gt. acc ) then
B(dbb11) = -DBLE(4/3D0 + (3 - 4*x1)*fpv(2, x1, y1))/p
sel = 3
else
B(dbb11) = nan
endif
if( m1*m2 .eq. 0 .and.
& abs(p - m1 - m2) .lt. acc ) then
* IR divergent case
- B(dbb0) = -(1 + .5D0*log(lambda/p))/p
+ la = lambda
+ if( la .le. 0 ) la = mudim
+ B(dbb0) = -(1 + .5D0*log(la/p))/p
else if( sel .eq. 1 ) then
B(dbb0) = (yfpv(1, x2, y2) - yfpv(1, x1, y1))/r
else if( sel .eq. 2 ) then
B(dbb0) = -DBLE((.5D0 + (1 - 2*x1)*fpv(2, x1, y1))/
& x1**2)/p
else if( sel .eq. 3 ) then
B(dbb0) = -DBLE(2 + (1 - 2*x1)*fpv(0, x1, y1))/p
else
B(dbb0) = nan
endif
if( m2 .eq. 0 .and. abs(p - m1) .lt. acc ) then
* IR divergent case
- B(dbb1) = .5D0*(3 + log(lambda/p))/p
+ B(dbb1) = .5D0*(3 + log(la/p))/p
else if( sel .eq. 1 ) then
B(dbb1) = (yfpv(2, x1, y1) - yfpv(2, x2, y2))/r
else if( sel .eq. 2 ) then
B(dbb1) = DBLE((2/3D0 + (2 - 3*x1)*fpv(3, x1, y1))/
& x1**2)/p
else if( sel .eq. 3 ) then
B(dbb1) = DBLE(3/2D0 + (2 - 3*x1)*fpv(1, x1, y1))/p
else
B(dbb1) = nan
endif
* zero momentum
else if( abs(dm) .gt. minacc ) then
x2 = m1/dm*(1 - cI*eps)
y2 = -m2/dm*(1 - cI*eps)
if( abs(y2) .gt. .5D0 ) then
mu = log(m2/mudim) - delta
B(bb0) = -(mu + fpv(1, x2, y2))
B(bb1) = 1/2D0*(mu + fpv(2, x2, y2))
B(bb11) = -1/3D0*(mu + fpv(3, x2, y2))
B(bb111) = 1/4D0*(mu + fpv(4, x2, y2))
B(bb00) = (2*(m1*B(bb0) + A0b(m2)) + m1 + m2)/8D0
else
mu = log(m1/mudim) - delta
f1 = fpv(1, y2, x2)
B(bb0) = -(mu + f1)
B(bb1) = 1/2D0*(mu + (1 + x2)*f1 + 1/2D0)
B(bb11) = -1/3D0*(mu - (1 + x2*(1 + x2))*yfpv(0, x2, y2) -
& x2*(x2 + 1/2D0) - 1/3D0)
B(bb111) = 1/4D0*(mu -
& (1 + x2*(1 + x2*(1 + x2)))*yfpv(0, x2, y2) -
& x2*(x2*(x2 + 1/2D0) + 1/3D0) - 1/4D0)
B(bb00) = (2*(m2*B(bb0) + A0b(m1)) + m1 + m2)/8D0
endif
B(bb001) = -( ((m1 + m2)/6D0)**2 +
& m1*m2/6D0 * (B(bb0) + 1/3D0) +
& (dm - m2)/3D0 * B(bb00) )/dm
if( abs(x2) .lt. 10 ) then
B(dbb0) = (1/2D0 + yfpv(1, x2, y2))/dm
B(dbb1) = -(1/3D0 + yfpv(2, x2, y2))/dm
B(dbb11) = (1/4D0 + yfpv(3, x2, y2))/dm
else
B(dbb0) = (1/2D0 + yfpv(2, x2, y2))/m1
B(dbb1) = -(1/3D0 + yfpv(3, x2, y2))/m1
B(dbb11) = (1/4D0 + yfpv(4, x2, y2))/m1
endif
else
mu = log(m2/mudim) - delta
B(bb0) = -mu
B(bb1) = 1/2D0*mu
B(bb11) = -1/3D0*mu
B(bb111) = 1/4D0*mu
B(bb00) = .5D0*m1*(1 - mu)
B(bb001) = -.5D0*B(bb00)
B(dbb0) = 1/6D0/m1
B(dbb1) = -1/12D0/m1
B(dbb11) = 1/20D0/m1
endif
B(dbb00) = 1/6D0*( 2*m1*B(dbb0) + B(bb1) +
& (p + dm)*B(dbb1) - 1/3D0 )
if( dump ) call DumpCoeff(2, B)
end
************************************************************************
double complex function fpv(n, x, y)
implicit none
integer n
double complex x, y
#include "lt.h"
double complex xm
integer m
if( abs(x) .lt. 5 ) then
if( n .eq. 0 ) then
fpv = -log(-y/x)
else if( abs(x) .lt. acc ) then
fpv = -1D0/n
else
xm = -log(-y/x)
do m = 1, n
xm = x*xm - 1D0/m
enddo
fpv = xm
endif
else
fpv = 0
xm = 1
do m = 1, 50
xm = xm/x
fpv = fpv + xm/(m + n)
if( abs(xm) .lt. precx*abs(fpv) ) return
enddo
endif
end
************************************************************************
double complex function yfpv(n, x, y)
implicit none
integer n
double complex x, y
double complex fpv
external fpv
if( abs(y) .eq. 0 ) then
yfpv = 0
else
yfpv = y*fpv(n, x, y)
endif
end
************************************************************************
double complex function fth(n, x, y)
implicit none
integer n
double complex x, y
#include "lt.h"
double complex fpv
external fpv
double complex xm
integer m
if( abs(x) .gt. 1D4 ) then
xm = 1
fth = 0
do m = n, 30 + n
xm = xm/x
fth = fth - xm/(m*(m + 1))
if( abs(xm) .lt. precx*abs(fth) ) return
enddo
else
fth = fpv(1, y, x)
do m = 1, n - 1
fth = x*fth + 1D0/(m*(m + 1))
enddo
endif
end
************************************************************************
double complex function xlogx(x)
implicit none
double complex x
if( abs(x) .eq. 0 ) then
xlogx = 0
else
xlogx = x*log(x)
endif
end
diff --git a/Looptools/B/Bget.F b/Looptools/B/Bget.F
--- a/Looptools/B/Bget.F
+++ b/Looptools/B/Bget.F
@@ -1,184 +1,186 @@
* Bget.F
* retrieve the two-point tensor coefficients
* this file is part of LoopTools
-* last modified 28 Oct 05 th
+* last modified 15 Jun 09 th
#include "defs.h"
integer function XBget(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer cachelookup
external cachelookup, XBcoeff
DVAR para(Pbb)
para(1) = p
para(2) = m1
+ if( abs(para(2)) .lt. minmass ) para(2) = 0
para(3) = m2
+ if( abs(para(3)) .lt. minmass ) para(3) = 0
XBget = cachelookup(para, Bval(1,0), XBcoeff, RC*Pbb, Nbb)
end
************************************************************************
double complex function XB0i(i, p, m1, m2)
implicit none
integer i
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
integer b
b = XBget(p, m1, m2)
XB0i = Bval(i,b)
end
************************************************************************
double complex function XB0(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XB0 = Bval(bb0,XBget(p, m1, m2))
end
************************************************************************
double complex function XB1(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XB1 = Bval(bb1,XBget(p, m1, m2))
end
************************************************************************
double complex function XB00(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XB00 = Bval(bb00,XBget(p, m1, m2))
end
************************************************************************
double complex function XB11(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XB11 = Bval(bb11,XBget(p, m1, m2))
end
************************************************************************
double complex function XB001(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XB001 = Bval(bb001,XBget(p, m1, m2))
end
************************************************************************
double complex function XB111(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XB111 = Bval(bb111,XBget(p, m1, m2))
end
************************************************************************
double complex function XDB0(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XDB0 = Bval(dbb0,XBget(p, m1, m2))
end
************************************************************************
double complex function XDB1(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XDB1 = Bval(dbb1,XBget(p, m1, m2))
end
************************************************************************
double complex function XDB00(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XDB00 = Bval(dbb00,XBget(p, m1, m2))
end
************************************************************************
double complex function XDB11(p, m1, m2)
implicit none
DVAR p, m1, m2
#include "lt.h"
integer XBget
external XBget
XDB11 = Bval(dbb11,XBget(p, m1, m2))
end
diff --git a/Looptools/B/ffcb0.F b/Looptools/B/ffcb0.F
--- a/Looptools/B/ffcb0.F
+++ b/Looptools/B/ffcb0.F
@@ -1,832 +1,835 @@
+#include "externals.h"
+
+
* $Id: ffcb0.f,v 1.11 1996/07/18 10:49:04 gj Exp $
*###[ ffcb0:
subroutine ffcb0(cb0,cp,cma,cmb,ier)
***#[*comment:***********************************************************
* *
* calculates the the two-point function (cf 't Hooft and Veltman) *
* we include an overall factor 1/(i*pi^2) relative to FormF *
* *
* Input: cp (complex) k2, in B&D metric *
* cma (complex) mass2, re>0, im<0. *
* cmb (complex) mass2, re>0, im<0. *
* *
* Output: cb0 (complex) B0, the two-point function, *
* ier (integer) number of digits lost in calculation *
* *
* Calls: ffcb0p,ffxb0p *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cb0,cp,cma,cmb
*
* local variables
*
integer init,ithres,i,j,nschsa
logical lreal
DOUBLE COMPLEX cmamb,cmap,cmbp,cm,c,cb0p,cqi(3),cqiqj(3,3)
DOUBLE PRECISION absc,xp,xma,xmb,sprec,smax
save init
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* data
*
data init /0/
*
* #] declarations:
* #[ the real cases:
*
if ( DIMAG(cma) .eq. 0 .and. DIMAG(cmb) .eq. 0 .and.
+ DIMAG(cp).eq.0 ) then
lreal = .TRUE.
elseif ( nschem.le.4 ) then
lreal = .TRUE.
if ( init.eq.0 ) then
init = 1
print *,'ffcb0: nschem <= 4, ignoring complex masses: ',
+ nschem
endif
elseif ( nschem.le.6 ) then
if ( init.eq.0 ) then
init = 1
print *,'ffcb0: nschem = 5,6 complex masses near ',
+ 'threshold: ',nschem
endif
cqi(1) = cma
cqi(2) = cmb
cqi(3) = cp
cqiqj(1,2) = cma - cmb
cqiqj(2,1) = -cqiqj(1,2)
cqiqj(1,3) = cma - cp
cqiqj(3,1) = -cqiqj(1,3)
cqiqj(2,3) = cmb - cp
cqiqj(3,2) = -cqiqj(2,3)
cqiqj(1,1) = 0
cqiqj(2,2) = 0
cqiqj(3,3) = 0
call ffthre(ithres,cqi,cqiqj,3,1,2,3)
if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
lreal = .TRUE.
else
lreal = .FALSE.
endif
else
lreal = .FALSE.
endif
if ( lreal ) then
xp = DBLE(cp)
xma = DBLE(cma)
xmb = DBLE(cmb)
sprec = precx
precx = precc
call ffxb0(cb0,xp,xma,xmb,ier)
precx = sprec
if ( ldot ) then
do 120 j=1,3
do 110 i=1,3
cfpij2(i,j) = fpij2(i,j)
110 continue
120 continue
endif
return
endif
*
* #] the real cases:
* #[ get differences:
*
cmamb = cma - cmb
cmap = cma - cp
cmbp = cmb - cp
*
* #] get differences:
* #[ calculations:
*
* no more schem-checking, please...
*
nschsa = nschem
nschem = 7
call ffcb0p(cb0p,cp,cma,cmb,cmap,cmbp,cmamb,ier)
nschem = nschsa
if ( cma .eq. 0 ) then
if ( cmb .eq. 0 ) then
cm = 1
else
cm = cmb**2
endif
elseif ( cmb .eq. 0 ) then
cm = cma**2
else
cm = cma*cmb
endif
if ( mudim .ne. 0 ) cm = cm/DBLE(mudim)**2
if ( absc(cm) .gt. xclogm ) then
cb0 = DBLE(delta) - cb0p - log(cm)/2
smax = max(abs(delta),absc(cb0p),absc(log(cm))/2)
else
call fferr(3,ier)
cb0 = -cb0p + DBLE(delta)
endif
* #] calculations:
*###] ffcb0:
end
*###[ ffcb0p:
subroutine ffcb0p(cb0p,cp,cma,cmb,cmap,cmbp,cmamb,ier)
***#[*comment:***********************************************************
* *
* calculates the main part of the two-point function (cf 't *
* Hooft and Veltman) for all possible cases: masses equal, *
* unequal, equal to zero, real or complex (with a negative *
* imaginary part). I think it works. *
* Has been checked against FormF for all parameter space. *
* Only problems with underflow for extreme cases. VERY OLD CODE. *
* *
* Input: cp (complex) k2, in B&D metric *
* cma (complex) mass2, re>0, im<0. *
* cmb (complex) mass2, re>0, im<0. *
* cmap/b (complex) cma/b - cp *
* cmamb (complex) cma - cmb *
* *
* Output: cb0p (complex) B0, the two-point function, *
* minus log(cm/mu), delta and the *
* factor -ipi^2. *
* ier (integer) 0=ok, 1=numerical problems, 2=error *
* *
* Calls: (z/a)log, atan. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cb0p,cp,cma,cmb,cmap,cmbp,cmamb
*
* local variables
*
integer i,j,initeq,initn1,n1,n2,nffeta,nffet1,init,
+ ithres,is1
logical lreal
DOUBLE PRECISION xp,ax,ay,ffbnd,
+ xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ xprcn1,bdn101,bdn105,bdn110,bdn115,
+ xprnn2,bdn201,bdn205,bdn210,bdn215,
+ xpneq(30),xpnn1(30),
+ absc,sprec,xma,xmb,dmap,dmbp,dmamb,smax
DOUBLE COMPLEX cm,cmp,cm1,cm2,cm1m2,
+ cm1p,cm2p,cs,cs1,cs2,cx,cy,csom,clam,cslam,clogmm,
+ zfflo1,c,zm,zp,zm1,zp1,zfflog,cqi(3),
+ cqiqj(3,3),cpiDpj(3,3),ck,clamr,cslamr,zmr,zpr,zm1r,zp1r
save initeq,initn1,xpneq,xpnn1,init,
+ xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ xprcn1,bdn101,bdn105,bdn110,bdn115,
+ xprnn2,bdn201,bdn205,bdn210,bdn215
*FOR ABSOFT ONLY
* DOUBLE COMPLEX csqrt
* external csqrt
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data xprceq /-1./
data xprcn1 /-1./
data xprnn2 /-1./
data initeq /0/
data initn1 /0/
data init /0/
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ fill some dotproducts:
*
call ffcot2(cpiDpj,cp,cma,cmb,cmap,cmbp,cmamb,ier)
if ( ldot ) then
do 20 i=1,3
do 10 j=1,3
cfpij2(j,i) = cpiDpj(j,i)
fpij2(j,i) = DBLE(cpiDpj(j,i))
10 continue
20 continue
endif
*
* #] fill some dotproducts:
* #[ the real cases:
*
if ( DIMAG(cma) .eq. 0 .and. DIMAG(cmb) .eq. 0 .and.
+ DIMAG(cp).eq.0 ) then
lreal = .TRUE.
elseif ( nschem.le.4 ) then
lreal = .TRUE.
if( init.eq.0 ) then
init = 1
print *,'ffcb0p: nschem <= 4, ignoring complex masses:',
+ nschem
endif
elseif ( nschem.le.6 ) then
if( init.eq.0 ) then
init = 1
print *,'ffcb0p: nschem = 4,6 complex masses near ',
+ 'threshold: ',nschem
endif
cqi(1) = cma
cqi(2) = cmb
cqi(3) = cp
cqiqj(1,2) = cmamb
cqiqj(2,1) = -cqiqj(1,2)
cqiqj(1,3) = cmap
cqiqj(3,1) = -cqiqj(1,3)
cqiqj(2,3) = cmbp
cqiqj(3,2) = -cqiqj(2,3)
cqiqj(1,1) = 0
cqiqj(2,2) = 0
cqiqj(3,3) = 0
call ffthre(ithres,cqi,cqiqj,3,1,2,3)
if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
lreal = .TRUE.
else
lreal = .FALSE.
endif
else
lreal = .FALSE.
endif
if ( lreal ) then
xp = DBLE(cp)
xma = DBLE(cma)
xmb = DBLE(cmb)
dmap = DBLE(cmap)
dmbp = DBLE(cmbp)
dmamb = DBLE(cmamb)
sprec = precx
precx = precc
call ffxb0p(cb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
precx = sprec
if ( ldot ) then
do 120 j=1,3
do 110 i=1,3
cfpij2(i,j) = fpij2(i,j)
110 continue
120 continue
endif
return
endif
*
* #] the real cases:
* #[ which case:
*
* sort according to the type of mass combination encountered:
* 200: one equal to zero, 300: both equal, 400: rest.
*
if ( cma .eq. 0 ) then
if ( cmb .eq. 0 ) then
goto 100
endif
cm = cmb
cmp = cmbp
goto 200
endif
if ( cmb .eq. 0 ) then
cm = cma
cmp = cmap
goto 200
endif
if ( cma .eq. cmb ) then
cm = cma
cmp = cmap
goto 300
endif
if ( DBLE(cma) .lt. DBLE(cmb) ) then
cm2 = cma
cm1 = cmb
cm1m2 = -cmamb
cm1p = cmbp
cm2p = cmap
is1 = 2
else
cm1 = cma
cm2 = cmb
cm1m2 = cmamb
cm1p = cmap
cm2p = cmbp
is1 = 1
endif
goto 400
* #] which case:
* #[ both masses equal to zero:
100 continue
if ( absc(cp) .gt. xclogm ) then
if ( DBLE(cp).gt.0 ) then
cb0p = log(cp) - c2ipi/2 - 2
else
cb0p = log(-cp) - 2
endif
else
cb0p = 0
call fferr(7,ier)
endif
return
* #] both masses equal to zero:
* #[ one mass zero:
200 continue
*
* special case cp = 0, checked 25-oct-1991
*
if ( cp .eq. 0 ) then
cb0p = -1
goto 990
endif
*
* Normal case:
*
cs1 = cp/cm
cs2 = cmp/cm
* make sure we get the right Riemann sheet!
if ( absc(cs1) .lt. xloss ) then
cs = zfflo1(cs1,ier)
elseif ( DBLE(cs2).gt.0 ) then
cs = zfflog(cs2,0,czero,ier)
else
cs = zfflog(-cs2,0,czero,ier)
cs = cs - c2ipi/2
endif
cs = -cs*cmp/cp
cb0p = cs - 2
goto 990
* #] one mass zero:
* #[ both masses equal:
300 continue
*
* Both masses are equal. Not only this speeds up things, some
* cancellations have to be avoided as well. Checked 25-oct-1991.
* -#[ taylor expansion:
*
* first this special case
*
if ( absc(cp) .lt. 8*xloss*absc(cm) ) then
*
* a Taylor expansion seems appropriate as the result will go
* as k^2 but seems to go as 1/k !!
*
* #[ data and bounds:
if ( initeq .eq. 0 ) then
initeq = 1
xpneq(1) = 1/6D0
do 1 i=2,30
xpneq(i) = xpneq(i-1)*DBLE(i-1)/DBLE(2*(2*i+1))
1 continue
endif
if (xprceq .ne. precc ) then
*
* calculate the boundaries for the number of terms to be
* included in the taylorexpansion
*
xprceq = precc
sprec = precx
precx = precc
bdeq01 = ffbnd(1,1,xpneq)
bdeq05 = ffbnd(1,5,xpneq)
bdeq11 = ffbnd(1,11,xpneq)
bdeq17 = ffbnd(1,17,xpneq)
bdeq25 = ffbnd(1,25,xpneq)
precx = sprec
endif
* #] data and bounds:
cx = cp/cm
ax = absc(cx)
if ( ax .gt. bdeq17 ) then
csom = cx*(DBLE(xpneq(18)) + cx*(DBLE(xpneq(19)) +
+ cx*(DBLE(xpneq(20)) + cx*(DBLE(xpneq(21)) +
+ cx*(DBLE(xpneq(22)) + cx*(DBLE(xpneq(23)) +
+ cx*(DBLE(xpneq(24)) + cx*(DBLE(xpneq(25)) ))))))))
else
csom = 0
endif
if ( ax .gt. bdeq11 ) then
csom = cx*(DBLE(xpneq(12)) + cx*(DBLE(xpneq(13)) +
+ cx*(DBLE(xpneq(14)) + cx*(DBLE(xpneq(15)) +
+ cx*(DBLE(xpneq(16)) + cx*(DBLE(xpneq(17)) + csom ))))
+ ))
endif
if ( ax .gt. bdeq05 ) then
csom = cx*(DBLE(xpneq(6)) + cx*(DBLE(xpneq(7)) +
+ cx*(DBLE(xpneq(8)) + cx*(DBLE(xpneq(9)) +
+ cx*(DBLE(xpneq(10)) + cx*(DBLE(xpneq(11)) + csom ))))))
endif
if ( ax .gt. bdeq01 ) then
csom = cx*(DBLE(xpneq(2)) + cx*(DBLE(xpneq(3)) +
+ cx*(DBLE(xpneq(4)) + cx*(DBLE(xpneq(5)) + csom ))))
endif
cb0p = -cx*(DBLE(xpneq(1))+csom)
goto 990
endif
* -#] taylor expansion:
* -#[ normal case:
*
* normal case. first determine if the arguments of the logarithm
* has positive real part: (we assume Re(cm) > Im(cm) )
*
call ffclmb(clam,-cp,-cm,-cm,cmp,cmp,czero)
cslam = sqrt(clam)
call ffcoot(zm,zp,cone,chalf,cm/cp,cslam/(2*cp),ier)
cs1 = zp/zm
if ( absc(cs1-1) .lt. xloss ) then
* In this case a quicker and more accurate way is to
* calculate log(1-cx).
cs2 = cp - cslam
if ( absc(cs2) .lt. xloss*absc(cp) ) then
cs2 = -cslam*(cp+cslam)/(4*cp*cm)
else
cs2 = -2*cslam/cs2
endif
cs = zfflo1(cs2/(2*cm),ier)
else
* finally the normal case
cs = zfflog(cs1,0,czero,ier)
endif
cs = cslam*cs/cp
cb0p = cs - 2
*
* eta terms
*
n1 = nffet1(zp,1/zm,cs1,ier)
if ( DIMAG(cp).eq.0 ) then
n2 = nffet1(-zp,-1/zm,cs1,ier)
else
* use the onshell expression to get the correct continuation
ck = DBLE(cp)
call ffclmb(clamr,-ck,-cm,-cm,cm-ck,cm-ck,czero)
cslamr = sqrt(clamr)
call ffcoot(zmr,zpr,cone,chalf,cm/ck,cslamr/(2*ck),ier)
if ( absc(zm-zmr)+absc(zp-zpr).gt.absc(zm-zpr)+absc(zp-zmr)
+ ) then
cs1 = zmr
zmr = zpr
zpr = cs1
endif
if ( DIMAG(zmr).eq.0 .or. DIMAG(zpr).eq.0 ) then
if ( DBLE(zpr).gt.DBLE(zmr) ) then
n2 = +1
else
n2 = -1
endif
else
n2 = nffeta(-zpr,-1/zmr,ier)
endif
endif
if ( n1+n2 .ne. 0 )
+ cb0p = cb0p - cslam*c2ipi*(n1+n2)/(2*cp)
* also superfluous - just to make sure
goto 990
* -#] normal case:
*
* #] both masses equal:
* #[ unequal nonzero masses:
400 continue
* -#[ get log(xm2/xm1):
cx = cm2/cm1
c = cx-1
if ( 1/absc(cx) .lt. xclogm ) then
call fferr(6,ier)
clogmm = 0
elseif ( absc(c) .lt. xloss ) then
clogmm = zfflo1(cm1m2/cm1,ier)
else
clogmm = log(cx)
endif
* -#] get log(xm2/xm1):
* -#[ cp = 0:
*
* first a special case
*
if ( cp .eq. 0 ) then
cs2 = ((cm2+cm1) / cm1m2)*clogmm
* save the factor 1/2 for the end
cs = - cs2 - 2
if ( absc(cs) .lt. xloss*2 ) then
* Taylor expansions: choose which one
cx = cm1m2/cm1
ax = absc(cx)
if ( ax .lt. .15 .or. precc .gt. 1.E-8 .and. ax
+ .lt. .3 ) then
* #[ taylor 1:
*
* This is the simple Taylor expansion 'n1'
*
*--#[ data and bounds:
* get the coefficients of the taylor expansion
if ( initn1 .eq. 0 ) then
initn1 = 1
do 410 i = 1,30
410 xpnn1(i)=DBLE(i)/DBLE((i+1)*(i+2))
endif
* determine the boundaries for 1,5,10,15 terms
if ( xprcn1 .ne. precc ) then
xprcn1 = precc
sprec = precx
precx = precc
bdn101 = ffbnd(1,1,xpnn1)
bdn105 = ffbnd(1,5,xpnn1)
bdn110 = ffbnd(1,10,xpnn1)
bdn115 = ffbnd(1,15,xpnn1)
precx = sprec
endif
*--#] data and bounds:
* calculate:
if ( ax .gt. bdn110 ) then
cs = cx*(DBLE(xpnn1(11)) + cx*(DBLE(xpnn1(12))
+ + cx*(DBLE(xpnn1(13)) + cx*(DBLE(xpnn1(14))
+ + cx*(DBLE(xpnn1(15))) ))))
else
cs = 0
endif
if ( ax .gt. bdn105 ) then
cs = cx*(DBLE(xpnn1(6)) + cx*(DBLE(xpnn1(7)) +
+ cx*(DBLE(xpnn1(8)) + cx*(DBLE(xpnn1(9)) +
+ cx*(DBLE(xpnn1(10)) + cs)))))
endif
if ( ax .gt. bdn101 ) then
cs = cx*(DBLE(xpnn1(2)) + cx*(DBLE(xpnn1(3)) +
+ cx*(DBLE(xpnn1(4)) + cx*(DBLE(xpnn1(5)) +
+ cs))))
endif
cs = cx*cx*(DBLE(xpnn1(1)) + cs)
* #] taylor 1:
else
* #[ taylor 2:
*
* This is the more complicated exponential Taylor
* expansion 'n2'
*
* #[ bounds:
* determine the boundaries for 1,5,10,15 terms for this
* Taylor expansion (starting at i=4)
*
if ( xprnn2 .ne. precc ) then
xprnn2 = precc
sprec = precx
precx = precc
bdn201 = ffbnd(4,1,xinfac)
bdn205 = ffbnd(4,5,xinfac)
bdn210 = ffbnd(4,10,xinfac)
bdn215 = ffbnd(4,15,xinfac)
precx = sprec
endif
* #] bounds:
* calculate:
cy = 2*cx/(2-cx)
ay = absc(cy)
if ( ay .gt. bdn210 ) then
cs = cy*(DBLE(xinfac(14)) + cy*(DBLE(xinfac(15))
+ + cy*(DBLE(xinfac(16)) + cy*(DBLE(xinfac(17))
+ + cy*(DBLE(xinfac(18)))))))
else
cs = 0
endif
if ( ay .gt. bdn205 ) then
cs = cy*(DBLE(xinfac(9)) + cy*(DBLE(xinfac(10))
+ + cy*(DBLE(xinfac(11)) + cy*(DBLE(xinfac(12))
+ + cy*(DBLE(xinfac(13)) + cs)))))
endif
if ( ay .gt. bdn201 ) then
cs = cy*(DBLE(xinfac(5)) + cy*(DBLE(xinfac(6))
+ + cy*(DBLE(xinfac(7)) + cy*(DBLE(xinfac(8))
+ + cs))))
endif
cs = (1-cx)*cy**4 * (DBLE(xinfac(4)) + cs)
cs = cx*cy**2*(1+cy)/12 - cs
cs = - 2*zfflo1(cs,ier)/cy
* #] taylor 2:
endif
endif
cb0p = cs/2
goto 990
endif
* -#] cp = 0:
* -#[ normal case:
*
* (programmed anew 28-oct-1991)
*
call ffclmb(clam,cm1,cm2,cp,cm1m2,cm1p,cm2p)
cslam = sqrt(clam)
if ( is1.eq.1 ) then
cs = +cpiDpj(2,3)
else
cs = -cpiDpj(1,3)
endif
call ffcoot(zm,zp,cp,cs,cm2,cslam/2,ier)
zm1 = 1-zm
zp1 = 1-zp
if ( absc(zm1) .lt. xloss .or. absc(zp1) .lt. xloss ) then
if ( is1.eq.1 ) then
cs = -cpiDpj(1,3)
else
cs = +cpiDpj(2,3)
endif
call ffcoot(zp1,zm1,cp,cs,cm1,cslam/2,ier)
if ( abs(DIMAG(zm)) .lt. abs(DIMAG(zm1)) ) then
zm = DCMPLX(DBLE(zm),-DIMAG(zm1))
else
zm1 = DCMPLX(DBLE(zm1),-DIMAG(zm))
endif
if ( abs(DIMAG(zp)) .lt. abs(DIMAG(zp1)) ) then
zp = DCMPLX(DBLE(zp),-DIMAG(zp1))
else
zp1 = DCMPLX(DBLE(zp1),-DIMAG(zp))
endif
endif
if ( DIMAG(cp).ne.0 ) then
* compute roots for Im(cp).eq.0 for continuation terms.
ck = DBLE(cp)
call ffclmb(clamr,cm1,cm2,ck,cm1m2,cm1-ck,cm2-ck)
cslamr = sqrt(clamr)
if ( absc(cslamr-cslam).gt.absc(cslamr+cslam) )
+ cslamr = -cslamr
cs = (cm2-cm1+ck)/2
call ffcoot(zmr,zpr,ck,cs,cm2,cslamr/2,ier)
zm1r = 1-zmr
zp1r = 1-zpr
if ( absc(zm1r) .lt. xloss .or. absc(zp1r) .lt. xloss ) then
cs = -(cm2-cm1-ck)/2
call ffcoot(zp1r,zm1r,ck,cs,cm1,cslamr/2,ier)
if ( abs(DIMAG(zmr)) .lt. abs(DIMAG(zm1r)) ) then
zmr = DCMPLX(DBLE(zmr),-DIMAG(zm1r))
else
zm1r = DCMPLX(DBLE(zm1r),-DIMAG(zmr))
endif
if ( abs(DIMAG(zpr)) .lt. abs(DIMAG(zp1r)) ) then
zpr = DCMPLX(DBLE(zpr),-DIMAG(zp1r))
else
zp1r = DCMPLX(DBLE(zp1r),-DIMAG(zpr))
endif
endif
else
zmr = zm
zm1r = zm1
zpr = zp
zp1r = zp1
endif
call ffc1lg(cs1,zm,zm1,zmr,zm1r,-1,ier)
call ffc1lg(cs2,zp,zp1,zpr,zp1r,+1,ier)
cb0p = -clogmm/2 + cs1 + cs2
smax = max(absc(clogmm)/2,absc(cs1),absc(cs2))
if ( absc(cb0p) .lt. xloss*smax ) then
call ffwarn(7,ier,absc(cb0p),smax)
endif
goto 990
* -#] normal case:
* #] unequal nonzero masses:
* #[ debug:
990 continue
* #] debug:
*###] ffcb0p:
end
*###[ ffc1lg:
subroutine ffc1lg(cs,z,z1,zr,z1r,is,ier)
***#[*comment:***********************************************************
* *
* Calculate the potentially unstable combination -1-z*log(1-1/z) *
* = sum_{n=1} 1/(n+1) z^{-n}. *
* *
* Input z,z1 complex root, z1=1-z *
* zr,z1r complex root for Im(p^2)=0, z1r=1-zr *
* is integer -1: roots are z-, +1: z+ *
* *
* Output cs complex see above *
* ier integer usual error flag *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer is,ier
DOUBLE COMPLEX cs,z,z1,zr,z1r
*
* local variables
*
DOUBLE PRECISION absc
DOUBLE COMPLEX c,zfflog
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ work:
if ( 1 .lt. xclogm*absc(z) ) then
cs = 0
elseif ( 1 .lt. precc*absc(z) ) then
cs = 1/(2*z)
elseif ( 1 .gt. 2*xloss*absc(z) ) then
*
* normal case
*
cs = -1 - z*zfflog(-z1/z,0,czero,ier)
*
* check analytical continuation for Im(p^2) -> 0
*
if ( z.ne.zr .or. z1.ne.z1r ) then
c = -z1r/zr
if ( DBLE(c).lt.0 ) then
* check whetehr we chose the correct continuation
if ( (DIMAG(c).gt.0 .or. DIMAG(c).eq.0 .and.
+ is.eq.+1) .and. DIMAG(-z1/z).lt.0 ) then
cs = cs - c2ipi*z
elseif ( (DIMAG(c).lt.0 .or. DIMAG(c).eq.0 .and.
+ is.eq.-1) .and. DIMAG(-z1/z).gt.0 ) then
cs = cs + c2ipi*z
endif
endif
endif
if ( absc(cs) .lt. xloss ) call ffwarn(8,ier,absc(cs),1D0)
else
*
* Taylor expansion
*
call ffcayl(cs,1/z,xninv(2),29,ier)
endif
* #] work:
*###] ffc1lg:
end
*###[ ffcot2:
subroutine ffcot2(cpiDpj,cp,cma,cmb,cmap,cmbp,cmamb,ier)
***#[*comment:***********************************************************
* *
* Store the 3 dotproducts in the common block ffdot. *
* *
* Input: see ffxc0p *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cpiDpj(3,3),cp,cma,cmb,cmap,cmbp,cmamb
*
* local variables
*
integer ier1
DOUBLE PRECISION absc,xmax
DOUBLE COMPLEX c
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ work:
ier1 = ier
cpiDpj(1,1) = cma
cpiDpj(2,2) = cmb
cpiDpj(3,3) = cp
if ( absc(cmap) .lt. absc(cmbp) ) then
cpiDpj(1,2) = (cmap + cmb)/2
else
cpiDpj(1,2) = (cmbp + cma)/2
endif
cpiDpj(2,1) = cpiDpj(1,2)
xmax = min(absc(cma),absc(cmb))/2
if ( absc(cmamb) .lt. absc(cmbp) ) then
cpiDpj(1,3) = (-cmamb - cp)/2
else
cpiDpj(1,3) = (cmbp - cma)/2
endif
cpiDpj(3,1) = cpiDpj(1,3)
xmax = min(absc(cma),absc(cp))/2
if ( absc(cmamb) .lt. absc(cmap) ) then
cpiDpj(2,3) = (-cmamb + cp)/2
else
cpiDpj(2,3) = (-cmap + cmb)/2
endif
cpiDpj(3,2) = cpiDpj(2,3)
xmax = min(absc(cmb),absc(cp))/2
ier = ier1
* #] work:
*###] ffcot2:
end
diff --git a/Looptools/B/ffcb1.F b/Looptools/B/ffcb1.F
--- a/Looptools/B/ffcb1.F
+++ b/Looptools/B/ffcb1.F
@@ -1,356 +1,359 @@
+#include "externals.h"
+
+
*###[ ffcb1:
subroutine ffcb1(cb1,cb0,ca0i,xp,xm1,xm2,piDpj,ier)
***#[*comment:***********************************************************
* *
* Calculate 1 / d^n Q Q(mu) *
* ------ | ------------------------ = B1*p(mu) *
* i pi^2 / (Q^2-m1^2)((Q+p)^2-m2^2) *
* *
* Input: cb0 complex scalar twopoint function *
* ca0i(2) complex scalar onepoint function with *
* m1,m2 *
* xp complex p.p in B&D metric *
* xm1,2 complex m_1^2,m_2^2 *
* piDpj(3,3) complex dotproducts between s1,s2,p *
* ier integer digits lost so far *
* Output: cb1 complex B1 *
* ier integer digits lost *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX xp,xm1,xm2,piDpj(3,3)
DOUBLE COMPLEX cb1,cb0,ca0i(2)
*
* local variables
*
integer ier0,i,j
DOUBLE COMPLEX dm1p,dm2p,dm1m2
DOUBLE PRECISION rm1,rm2,rp,rpiDpj(3,3),sprec
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ real case:
if ( DIMAG(xm1).eq.0 .and. DIMAG(xm2).eq.0 ) then
rm1 = DBLE(xm1)
rm2 = DBLE(xm2)
rp = DBLE(xp)
do 20 j=1,3
do 10 i=1,3
rpiDpj(i,j) = DBLE(piDpj(i,j))
10 continue
20 continue
sprec = precx
precx = precc
call ffxb1(cb1,cb0,ca0i,rp,rm1,rm2,rpiDpj,ier)
precx = sprec
return
endif
* #] real case:
* #[ get differences:
ier0 = 0
dm1m2 = xm1 - xm2
dm1p = xm1 - xp
dm2p = xm2 - xp
* #] get differences:
* #[ call ffcb1a:
call ffcb1a(cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj,ier)
* #] call ffcb1a:
*###] ffcb1:
end
*###[ ffcb1a:
subroutine ffcb1a(cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj,
+ ier)
***#[*comment:***********************************************************
* *
* Calculate 1 / d^n Q Q(mu) *
* ------ | ------------------------ = B1*p(mu) *
* i pi^2 / (Q^2-m1^2)((Q+p)^2-m2^2) *
* *
* Input: cb0 complex scalar twopoint function *
* ca0i(2) complex scalar onepoint function with *
* m1,m2 *
* xp complex p.p in B&D metric *
* xm1,2 complex m_1^2,m_2^2 *
* piDpj(3,3) complex dotproducts between s1,s2,p *
* ier integer digits lost so far *
* Output: cb1 complex B1 *
* ier integer digits lost *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj(3,3)
DOUBLE COMPLEX cb1,cb0,ca0i(2)
*
* local variables
*
integer i,j,ithres,init
logical lneg,lreal
DOUBLE PRECISION xmax,absc,bnd101,bnd105,bnd110,bnd115,ax,cprec,
+ xprec,xmxp
DOUBLE COMPLEX s,s1,h,slam,xma,xmb,x,small,dmbma,clam,clogm,
+ ts2Dp,xlo3,xlogm,cqiqj(3,3),cqi(3)
DOUBLE COMPLEX cs(5),cc,csom
DOUBLE PRECISION ffbnd
DOUBLE COMPLEX zfflo1,zfflo3
DOUBLE PRECISION rm1,rm2,rp,rm1m2,rm1p,rm2p,rpiDpj(3,3),sprec
save cprec,bnd101,bnd105,bnd110,bnd115,init
*FOR ABSOFT ONLY
* DOUBLE COMPLEX csqrt
* external csqrt
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
* data
*
data cprec /0./
*
* #] declarations:
* #[ the real cases:
*
if ( DIMAG(xm1) .eq. 0 .and. DIMAG(xm2) .eq. 0 ) then
lreal = .TRUE.
elseif ( nschem.le.4 ) then
lreal = .TRUE.
if ( init.eq.0 ) then
init = 1
print *,'ffcb1a: nschem <= 4, ignoring complex masses:',
+ nschem
endif
elseif ( nschem.le.6 ) then
if ( init.eq.0 ) then
init = 1
print *,'ffcb1a: nschem = 5,6 complex masses near ',
+ 'threshold: ',nschem
endif
cqi(1) = xm1
cqi(2) = xm2
cqi(3) = xp
cqiqj(1,2) = dm1m2
cqiqj(2,1) = -cqiqj(1,2)
cqiqj(1,3) = dm1p
cqiqj(3,1) = -cqiqj(1,3)
cqiqj(2,3) = dm2p
cqiqj(3,2) = -cqiqj(2,3)
cqiqj(1,1) = 0
cqiqj(2,2) = 0
cqiqj(3,3) = 0
call ffthre(ithres,cqi,cqiqj,3,1,2,3)
if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
lreal = .TRUE.
else
lreal = .FALSE.
endif
else
lreal = .FALSE.
endif
if ( lreal ) then
rm1 = DBLE(xm1)
rm2 = DBLE(xm2)
rp = DBLE(xp)
rm1p = DBLE(dm1p)
rm2p = DBLE(dm2p)
rm1m2 = DBLE(dm1m2)
do 20 j=1,3
do 10 i=1,3
rpiDpj(i,j) = DBLE(piDpj(i,j))
10 continue
20 continue
sprec = precx
precx = precc
call ffxb1a(cb1,cb0,ca0i,rp,rm1,rm2,rm1m2,rpiDpj,ier)
precx = sprec
return
endif
* #] the real cases:
* #[ p^2 != 0:
if ( DBLE(xp) .ne. 0 ) then
* #[ normal case:
if ( dm1m2 .ne. 0 ) then
cs(1) = -ca0i(2)
cs(2) = +ca0i(1)
else
cs(1) = 0
cs(2) = 0
endif
cs(3) = +2*piDpj(1,3)*cb0
cb1 = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb1) .ge. xloss*xmax ) goto 110
* #] normal case:
* #[ almost equal masses:
if ( absc(dm1m2) .le. xloss*absc(xm1) ) then
cs(2) = dm1m2/xm1*cs(2)
cs(1) = -xm2*zfflo1(-dm1m2/xm2,ier)
cb1 = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb1) .ge. xloss*xmax ) goto 110
* for the perfectionist (not me (today)):
* if d0=0 and mu~m1(~m2), then the terms of order
* (m1^2-m2^2) also cancel. To patch this I need d0 and mu
endif
* #] almost equal masses:
* #[ p2 -> 0:
if ( xloss**2*max(absc(xm1),absc(xm2)) .gt. absc(xp) ) then
if ( DBLE(xm2).gt.DBLE(xm1) ) then
xma = xm1
xmb = xm2
dmbma = -dm1m2
ts2Dp = +2*piDpj(2,3)
lneg = .FALSE.
else
xma = xm2
xmb = xm1
dmbma = +dm1m2
ts2Dp = -2*piDpj(1,3)
lneg = .TRUE.
endif
else
goto 100
endif
*
* We found a situation in which p2 is much smaller than
* the masses.
*
if ( xma.eq.0 ) then
clogm = 1
elseif ( absc(dmbma) .gt. xloss*absc(xmb) ) then
clogm = log(xmb/xma)
else
clogm = zfflo1(-dmbma/xma,ier)
endif
clam = (dmbma-xp)**2 - 4*xma*xp
slam = sqrt(clam)
small = xp*(-2*(xma+xmb) + xp)/(slam+dmbma)
cs(1) = clogm*xma*(4*xmb*(small-xp) + (small-xp)**2)/(2*
+ (slam+dmbma)*(slam+2*piDpj(1,2)))
if ( cprec.ne.precc ) then
cprec = precc
xprec = precx
precx = precc
bnd101 = ffbnd(2,1,xinfac)
bnd105 = ffbnd(2,5,xinfac)
bnd110 = ffbnd(2,10,xinfac)
bnd115 = ffbnd(2,15,xinfac)
precx = xprec
endif
x = xp/slam
ax = absc(x)
if ( ax.gt.bnd110 ) then
s = x*(DBLE(xinfac(12)) + x*(DBLE(xinfac(13)) +
+ x*(DBLE(xinfac(14)) + x*(DBLE(xinfac(15)) +
+ x*(DBLE(xinfac(16)) )))))
else
s = 0
endif
if ( ax.gt.bnd105 ) then
s = x*(DBLE(xinfac(7)) + x*(DBLE(xinfac(8)) +
+ x*(DBLE(xinfac(9)) + x*(DBLE(xinfac(10)) +
+ x*(DBLE(xinfac(11) + s) )))))
endif
if ( ax.gt.bnd101) then
s = x*(DBLE(xinfac(3)) + x*(DBLE(xinfac(4)) +
+ x*(DBLE(xinfac(5)) + x*(DBLE(xinfac(6)) + s))))
endif
s = x**2*(.5D0 + s)
s1 = 2*xp/(ts2Dp + slam)*(s + x)
h = -4*xp**2*xmb/(slam*(slam+ts2Dp)**2) - s + s1
if ( absc(h) .lt. .1 ) then
cs(2) = dmbma*slam/xp*zfflo1(h,ier)
else
print *,'ffcb1: warning: I thought this was small: ',h
print *,' cp,cma,cmb = ',xp,xma,xmb
cs(2) = dmbma*slam/xp*log(1-h)
*** goto 100
endif
if ( lneg ) then
cs(1) = -cs(1)
cs(2) = -cs(2)
endif
cs(3) = -xp*cb0
cb1 = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb1) .gt. xloss*xmax) goto 110
* #] p2 -> 0:
* #[ give up:
*
* give up...
*
100 continue
110 continue
* #] give up:
cb1 = cb1/(2*xp)
* #] p^2 != 0:
* #[ p^2=0, m1 != m2:
elseif ( dm1m2 .ne. 0 ) then
cs(1) = +xm2/(2*dm1m2**2)*(ca0i(2)+xm2/2)
cs(2) = -xm1/(2*dm1m2**2)*(ca0i(1)+xm1/2)
cs(3) = +ca0i(2)/dm1m2
cb1 = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)))
if ( absc(cb1).ge.xloss**2*xmax ) goto 120
*
* m1 ~ m2, see b21.frm
*
if ( absc(dm1m2).lt.xloss*absc(xm1) ) then
xlogm = zfflo1(dm1m2/xm1,ier)
else
xlogm = log(xm2/xm1)
endif
cs(1) = -(xm1/dm1m2)/2
cs(2) = -xlogm/2*(xm1/dm1m2)**2
cs(3) = +1/DBLE(4) - ca0i(1)/(2*xm1)
cs(4) = xlogm/2
csom = cs(1) + cs(2) + cs(3) + cs(4)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb1 = csom
if ( absc(cb1).gt.xloss**2*xmax ) goto 120
endif
*
* better
*
xlo3 = zfflo3(dm1m2/xm1,ier)
cs(1) = -(dm1m2/xm1)**2/4
cs(2) = -(dm1m2/xm1)/2
cs(3) = -xlo3/(dm1m2/xm1)**2/2
cs(4) = xlo3/2
cs(5) = 1/DBLE(2) - ca0i(1)/(2*xm1)
csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb1 = csom
if ( absc(cb1).gt.xloss**2*xmax ) goto 120
endif
*
* give up
*
120 continue
* #] p^2=0, m1 != m2:
* #[ p^2=0, m1 == m2:
else
cb1 = -cb0/2
endif
* #] p^2=0, m1 == m2:
*###] ffcb1a:
end
diff --git a/Looptools/B/ffcb2p.F b/Looptools/B/ffcb2p.F
--- a/Looptools/B/ffcb2p.F
+++ b/Looptools/B/ffcb2p.F
@@ -1,429 +1,432 @@
+#include "externals.h"
+
+
*###[ ffcb2p:
subroutine ffcb2p(cb2i,cb1,cb0,ca0i,cp,xm1,xm2,piDpj,ier)
***#[*comment:***********************************************************
* *
* Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu) *
* of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2) *
* originally based on aaxbx by Andre Aeppli. *
* *
* Input: cb1 complex vector two point function *
* cb0 complex scalar two point function *
* ca0i(2) complex scalar onepoint function with *
* m1,m2 *
* cp complex p.p in B&D metric *
* xm1,2 complex m_1^2,m_2^2 *
* piDpj(3,3) complex dotproducts between s1,s2,p *
* ier integer digits lost so far *
* *
* Output: cb2i(2) complex B21,B22: coeffs of p*p, g in B2 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cp,xm1,xm2,piDpj(3,3)
DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
DOUBLE PRECISION rm1,rm2,rp,rpiDpj(3,3),sprec
*
* local variables
*
integer i,j
DOUBLE COMPLEX dm1p,dm2p,dm1m2
*
* common blocks
*
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ real case:
if ( DIMAG(xm1).eq.0 .and. DIMAG(xm2).eq.0 ) then
rm1 = DBLE(xm1)
rm2 = DBLE(xm2)
rp = DBLE(cp)
do 20 j=1,3
do 10 i=1,3
rpiDpj(i,j) = DBLE(piDpj(i,j))
10 continue
20 continue
sprec = precx
precx = precc
call ffxb2p(cb2i,cb1,cb0,ca0i,rp,rm1,rm2,rpiDpj,ier)
precx = sprec
return
endif
* #] real case:
* #[ work:
*
dm1p = xm1 - cp
dm2p = xm2 - cp
dm1m2= xm1 - xm2
call ffcb2q(cb2i,cb1,cb0,ca0i,cp,xm1,xm2,dm1p,dm2p,dm1m2,
+ piDpj,ier)
*
* #] work:
*###] ffcb2p:
end
*###[ ffcb2q:
subroutine ffcb2q(cb2i,cb1,cb0,ca0i,cp,xm1,xm2,dm1p,dm2p,dm1m2,
+ piDpj,ier)
***#[*comment:***********************************************************
* *
* Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu) *
* of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2) *
* originally based on aaxbx by Andre Aeppli. *
* *
* Input: cb1 complex vector two point function *
* cb0 complex scalar two point function *
* ca0i(2) complex scalar onepoint function with *
* m1,m2 *
* cp complex p.p in B&D metric *
* xm1,2 complex m_1^2,m_2^2 *
* piDpj(3,3) complex dotproducts between s1,s2,p *
* ier integer digits lost so far *
* *
* Output: cb2i(2) complex B21,B22: coeffs of p*p, g in B2 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj(3,3)
DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
*
* local variables
*
integer i,j,ier0,ier1,ithres,init
logical lreal,llogmm
DOUBLE PRECISION xmax,xmxsav,absc,xmxp
DOUBLE PRECISION rm1,rm2,rp,rm1p,rm2p,rm1m2,rpiDpj(3,3),sprec
DOUBLE COMPLEX cs(14),cc,slam,xlo3,csom,clam,xlogmm,zfflo1,alp,
+ bet,xnoe,xnoe2,zfflo3
DOUBLE COMPLEX cqi(3),cqiqj(3,3)
save init
* for Absoft only
* external csqrt
* DOUBLE COMPLEX csqrt
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
* #] declarations:
* #[ real cases:
if ( DIMAG(xm1).eq.0 .and. DIMAG(xm2).eq.0 ) then
lreal = .TRUE.
elseif ( nschem.le.4 ) then
lreal = .TRUE.
if ( init.eq.0 ) then
init = 1
print *,'ffcb2q: nschem <= 4, ignoring complex masses:',
+ nschem
endif
elseif ( nschem.le.6 ) then
if ( init.eq.0 ) then
init = 1
print *,'ffcb2q: nschem = 5,6 complex masses near ',
+ 'threshold: ',nschem
endif
cqi(1) = xm1
cqi(2) = xm2
cqi(3) = cp
cqiqj(1,2) = dm1m2
cqiqj(2,1) = -cqiqj(1,2)
cqiqj(1,3) = dm1p
cqiqj(3,1) = -cqiqj(1,3)
cqiqj(2,3) = dm2p
cqiqj(3,2) = -cqiqj(2,3)
cqiqj(1,1) = 0
cqiqj(2,2) = 0
cqiqj(3,3) = 0
call ffthre(ithres,cqi,cqiqj,3,1,2,3)
if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
lreal = .TRUE.
else
lreal = .FALSE.
endif
else
lreal = .FALSE.
endif
if ( lreal ) then
rm1 = DBLE(xm1)
rm2 = DBLE(xm2)
rp = DBLE(cp)
rm1p = DBLE(dm1p)
rm2p = DBLE(dm2p)
rm1m2 = DBLE(dm1m2)
do 20 j=1,3
do 10 i=1,3
rpiDpj(i,j) = DBLE(piDpj(i,j))
10 continue
20 continue
sprec = precx
precx = precc
call ffxb2q(cb2i,cb1,cb0,ca0i,rp,rm1,rm2,rm1m2,rpiDpj,ier)
precx = sprec
return
endif
* #] real cases:
* #[ normal case:
ier0 = ier
ier1 = ier
*
* with thanks to Andre Aeppli, off whom I stole the original
*
if ( DBLE(cp) .ne. 0) then
cs(1) = ca0i(2)
cs(2) = xm1*cb0
cs(3) = 2*piDpj(1,3)*cb1
cs(4) = (xm1+xm2)/2
cs(5) = -cp/6
cb2i(1) = cs(1) - cs(2) + 2*cs(3) - cs(4) - cs(5)
cb2i(2) = cs(1) + 2*cs(2) - cs(3) + 2*cs(4) + 2*cs(5)
xmax = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
xmxsav = xmax
if ( absc(cb2i(1)) .ge. xloss*xmax ) goto 100
* #] normal case:
* #[ improve: m1=m2:
*
* a relatively simple case: dm1m2 = 0 (bi0.frm)
*
if ( dm1m2.eq.0 ) then
slam = sqrt(cp**2-4*xm1*cp)
xlo3 = zfflo3((cp-slam)/(2*xm1),ier)
cs(1) = cp*(-1/DBLE(3) + slam/(4*xm1))
cs(2) = cp**2*(-slam/(4*xm1**2) - 3/(4*xm1))
cs(3) = cp**3/(4*xm1**2)
cs(4) = cp/xm1*ca0i(1)
cs(5) = xlo3/cp*(-xm1*slam)
cs(6) = xlo3*slam
csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) + cs(6)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ absc(cs(5)),absc(cs(6)))
if ( xmxp.lt.xmax ) then
cb2i(1) = csom
xmax = xmxp
endif
if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
endif
* #] improve: m1=m2:
* #[ improve: |cp| < xm1 < xm2:
*
* try again (see bi.frm)
*
clam = 4*(piDpj(1,3)**2 - xm1*cp)
if ( xm1.eq.0 .or. xm2.eq.0 ) then
xlogmm = 0
elseif ( absc(dm1m2).lt.xloss*absc(xm1) ) then
xlogmm = zfflo1(dm1m2/xm1,ier)
else
xlogmm = log(xm2/xm1)
endif
if ( abs(DBLE(cp)).lt.xloss*absc(xm2) .and.
+ DBLE(xm1).lt.DBLE(xm2) ) then
slam = sqrt(clam)
alp = (2*xm1*xm2/(2*piDpj(1,2)+slam) + xm1)/(slam-dm1m2)
* bet = [xm2-xm1-cp-slam]
bet = 4*xm1*cp/(2*piDpj(1,3)+slam)
cs(1) = cp/xm2*ca0i(2)
cs(2) = xlogmm*bet*(-2*xm1**2*xm2 - 2*xm1**3)
+ /((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
cs(3) = xlogmm*(-4*cp*xm1**3)
+ /((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
xnoe = 1/(2*piDpj(2,3)+slam)
xnoe2 = xnoe**2
cs(4) = xnoe2*xm1*bet*(cp-4*xm2)
cs(5) = xnoe2*xm1*2*cp*xm2
cs(6) = xnoe2*xm1**2*bet
cs(7) = xnoe2*xm1**2*4*cp
cs(8) = xnoe2*bet*(cp*xm2+3*xm2**2)
cs(9) = xnoe2*(-6*cp*xm2**2)
cs(10)= cp*(7/6.d0 - 2*xm1*slam*xnoe2 +
+ 4*xm2*slam*xnoe2 - 2*slam*xnoe)
cs(11)= cp**2*( -2*slam*xnoe2 )
xlo3 = zfflo3(2*cp*xnoe,ier)
cs(12) = xlo3*dm1m2**2*slam/cp**2
cs(13) = xlo3*(xm1 - 2*xm2)*slam/cp
cs(14) = xlo3*slam
csom = 0
xmxp = 0
do 50 i=1,14
csom = csom + cs(i)
xmxp = max(xmxp,absc(cs(i)))
50 continue
if ( xmxp.lt.xmax ) then
cb2i(1) = csom
xmax = xmxp
endif
if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
endif
* #] improve: |cp| < xm1 < xm2:
* #[ improve: |cp| < xm2 < xm1:
if ( abs(DBLE(cp)).lt.xloss*absc(xm1) .and.
+ DBLE(xm2).lt.DBLE(xm1) ) then
slam = sqrt(clam)
alp = (2*xm2*xm1/(2*piDpj(1,2)+slam) + xm2)/(slam+dm1m2)
* bet = [xm1-xm2-cp-slam]
bet = 4*xm2*cp/(-2*piDpj(2,3)+slam)
xnoe = 1/(-2*piDpj(1,3)+slam)
xnoe2 = xnoe**2
cs(1) = cp/xm1*ca0i(1)
cs(2) = -xlogmm*bet*(12*cp*xm1*xm2+6*cp*xm2**2-
+ 6*cp**2*xm2-2*xm1*xm2**2-2*xm2**3)
+ /((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
cs(3) = -xlogmm*(-24*cp*xm1**2*xm2-4*cp*xm2**3+36*
+ cp**2*xm1*xm2+12*cp**2*xm2**2-12*cp**3*xm2)
+ /((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
cs(4) = xnoe2*xm2*bet*(cp-4*xm1)
cs(5) = xnoe2*xm2*(-10*cp*xm1)
cs(6) = xnoe2*xm2**2*bet
cs(7) = xnoe2*xm2**2*4*cp
cs(8) = xnoe2*bet*(cp*xm1+3*xm1**2)
cs(9) = xnoe2*6*cp*xm1**2
cs(10)= cp*(7/6.d0 - 2*xm1*slam*xnoe2 +
+ 4*xm2*slam*xnoe2 - 2*slam*xnoe)
cs(11)= cp**2*( -2*slam*xnoe2 )
xlo3 = zfflo3(2*cp*xnoe,ier)
cs(12) = xlo3*dm1m2**2*slam/cp**2
cs(13) = xlo3*(xm1 - 2*xm2)*slam/cp
cs(14) = xlo3*slam
csom = 0
xmxp = 0
do 60 i=1,14
csom = csom + cs(i)
xmxp = max(xmxp,absc(cs(i)))
60 continue
if ( xmxp.lt.xmax ) then
cb2i(1) = csom
xmax = xmxp
endif
if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
endif
* #] improve: |cp| < xm2 < xm1:
* #[ wrap up:
100 continue
xmax = xmxsav
cb2i(1) = DBLE(1/(3*cp)) * cb2i(1)
cb2i(2) = DBLE(1/6.d0) * cb2i(2)
* #] wrap up:
* #[ cp=0, m1!=m2:
elseif (dm1m2 .ne. 0) then
* #[ B21:
llogmm = .FALSE.
*
* B21 (see thesis, b21.frm)
*
cs(1) = xm1**2/3/dm1m2**3*ca0i(1)
cs(2) = (-xm1**2 + xm1*xm2 - xm2**2/3)/dm1m2**3*ca0i(2)
cs(3) = (5*xm1**3/18 - xm1*xm2**2/2 + 2*xm2**3/9)
+ /dm1m2**3
cb2i(1) = cs(1)+cs(2)+cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
*
* ma ~ mb
*
if ( absc(dm1m2).lt.xloss*absc(xm1) ) then
xlogmm = zfflo1(dm1m2/xm1,ier)
else
xlogmm = log(xm2/xm1)
endif
llogmm = .TRUE.
cs(1) = (xm1/dm1m2)/6
cs(2) = (xm1/dm1m2)**2/3
cs(3) = (xm1/dm1m2)**3*xlogmm/3
cs(4) = -2/DBLE(9) + ca0i(1)/(3*xm1)
cs(5) = -xlogmm/3
csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ absc(cs(5)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb2i(1) = csom
if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
endif
*
* and last try
*
xlo3 = zfflo3(dm1m2/xm1,ier)
cs(1) = (dm1m2/xm1)**2/6
cs(2) = (dm1m2/xm1)/3
cs(3) = xlo3/(3*(dm1m2/xm1)**3)
*same cs(4) = -2/DBLE(9) + ca0i(1)/(3*xm1)
cs(5) = -xlo3/3
csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ absc(cs(5)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb2i(1) = csom
if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
endif
*
* give up
*
160 continue
* #] B21:
* #[ B22:
*
* B22
*
cs(1) = +xm1/(4*dm1m2)*ca0i(1)
cs(2) = -xm2/(4*dm1m2)*ca0i(2)
cs(3) = (xm1+xm2)/8
cb2i(2) = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
*
* second try, close together
*
if ( .not.llogmm ) then
if ( abs(dm1m2).lt.xloss*absc(xm1) ) then
xlogmm = zfflo1(dm1m2/xm1,ier)
else
xlogmm = log(xm2/xm1)
endif
endif
cs(1) = dm1m2*( -1/DBLE(8) - ca0i(1)/(4*xm1) )
cs(2) = dm1m2*xlogmm/4
cs(3) = xm1*(xm1/dm1m2)/4*xlogmm
cs(4) = xm1*( 1/DBLE(4) + ca0i(1)/(2*xm1) )
cs(5) = -xm1*xlogmm/2
csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ absc(cs(5)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb2i(2) = csom
endif
if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
*
* give up
*
210 continue
* #] B22:
* #] cp=0, m1!=m2:
* #[ cp=0, m1==m2:
else
*
* taken over from ffxb2a, which in turns stem from my thesis GJ
*
cb2i(1) = cb0/3
cb2i(2) = xm1/2*(cb0 + 1)
endif
* #] cp=0, m1==m2:
* #[ finish up:
ier = max(ier0,ier1)
* #] finish up:
*###] ffcb2q:
end
diff --git a/Looptools/B/ffcdb0.F b/Looptools/B/ffcdb0.F
--- a/Looptools/B/ffcdb0.F
+++ b/Looptools/B/ffcdb0.F
@@ -1,711 +1,713 @@
+#include "externals.h"
+
+
*###[ ffcdb0:
subroutine ffcdb0(cdb0,cdb0p,cp,cma,cmb,ier)
***#[*comment:***********************************************************
* *
* Calculates the derivative of the two-point function with *
* respect to p2, plus the same times p2. *
* *
* Input: cp (complex) k2, in B&D metric *
* cma (complex) mass2 *
* cmb (complex) mass2 *
* *
* Output: cdb0 (complex) dB0/dxp *
* cdb0p (complex) cp*dB0/dxp *
* ier (integer) # of digits lost, if >=100: error *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cdb0,cdb0p
DOUBLE COMPLEX cp,cma,cmb
*
* local variables
*
integer ier0
DOUBLE COMPLEX cmamb,cmap,cmbp
DOUBLE PRECISION xp,xma,xmb
*
* common
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ check input:
if ( DIMAG(cma).eq.0 .and. DIMAG(cmb).eq.0 ) then
xma = DBLE(cma)
xmb = DBLE(cmb)
xp = DBLE(cp)
call ffxdb0(cdb0,cdb0p,xp,xma,xmb,ier)
return
endif
* #] check input:
* #[ get differences:
ier0 = 0
cmamb = cma - cmb
cmap = cma - cp
cmbp = cmb - cp
* #] get differences:
* #[ calculations:
call ffcdbp(cdb0,cdb0p,cp,cma,cmb,cmap,cmbp,cmamb,ier)
* #] calculations:
*###] ffcdb0:
end
*###[ ffcdbp:
subroutine ffcdbp(cdb0,cdb0p,cp,cma,cmb,cmap,cmbp,cmamb,ier)
***#[*comment:***********************************************************
* *
* calculates the derivatives of the two-point function *
* *
* Input: cp (complex) p.p, in B&D metric *
* cma (complex) mass2, *
* cmb (complex) mass2, *
* dm[ab]p (complex) cm[ab] - cp *
* cmamb (complex) cma - cmb *
* *
* Output: cdb0 (complex) B0' = dB0/dxp *
* cdb0p (complex) cp*B0' *
* ier (integer) 0=ok,>0=numerical problems,>100=error *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cdb0,cdb0p
DOUBLE COMPLEX cp,cma,cmb,cmap,cmbp,cmamb
*
* local variables
*
integer i,initeq,jsign,init,ithres,initir,n1,n2,nffet1
logical lreal
DOUBLE PRECISION ax,ffbnd,ffbndc,
+ xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ xprcn3,bdn301,bdn305,bdn310,bdn315,
+ xprcn5,bdn501,bdn505,bdn510,bdn515,
+ xprec0,bdn001,bdn005,bdn010,bdn015,bdn020,
+ absc,xmax,prcsav
DOUBLE COMPLEX cm,cdmp,cm1,cm2,cm1m2,cdm1p,
+ cdm2p,s,s1,s1a,s1b,s1p,s2,s2a,s2b,s2p,s3,cx,som,
+ clam,slam,xlogmm,alpha,alph1,xnoe,xpneq(30),
+ zfflo1,zfflo3,d1,d2,diff,h,a,b,c,d,beta,
+ betm2n,s1c,s1d,s1e,s1f,cqi(3),cqiqj(3,3),zm,zp
DOUBLE COMPLEX cc
DOUBLE PRECISION xp,xma,xmb,dmamb,dmap,dmbp,sprec
save initeq,xpneq,init,initir,
+ xprceq,bdeq01,bdeq05,bdeq11,bdeq17,bdeq25,
+ xprcn3,bdn301,bdn305,bdn310,bdn315,
+ xprcn5,bdn501,bdn505,bdn510,bdn515,
+ xprec0,bdn001,bdn005,bdn010,bdn015,bdn020
*for ABSOFT only
* DOUBLE COMPLEX csqrt
* external csqrt
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data xprceq /-1./
data xprec0 /-1./
data xprcn3 /-1./
data xprcn5 /-1./
data initeq /0/
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
* #] declarations:
* #[ the real cases:
*
if ( DIMAG(cma) .eq. 0 .and. DIMAG(cmb) .eq. 0 ) then
lreal = .TRUE.
elseif ( nschem.le.2 ) then
lreal = .TRUE.
if ( init.eq.0 ) then
init = 1
print *,'ffcb0: nschem <= 2, ignoring complex masses: ',
+ nschem
endif
elseif ( nschem.le.4 ) then
if ( init.eq.0 ) then
init = 1
print *,'ffcdbp: nschem = 3,4 complex masses near ',
+ 'singularity: ',nschem
endif
if ( abs(DBLE(cma)) .lt. -xloss*DIMAG(cmb)
+ .and. abs(DBLE(cmbp)) .le. -nwidth*DIMAG(cmb)
+ .or. abs(DBLE(cmb)) .lt. -xloss*DIMAG(cma)
+ .and. abs(DBLE(cmap)) .le. -nwidth*DIMAG(cma) ) then
lreal = .FALSE.
else
lreal = .TRUE.
endif
elseif ( nschem.le.6 ) then
if ( init.eq.0 ) then
init = 1
print *,'ffcdbp: nschem = 5,6 complex masses near ',
+ 'threshold: ',nschem
endif
cqi(1) = cma
cqi(2) = cmb
cqi(3) = cp
cqiqj(1,2) = cmamb
cqiqj(2,1) = -cqiqj(1,2)
cqiqj(1,3) = cmap
cqiqj(3,1) = -cqiqj(1,3)
cqiqj(2,3) = cmbp
cqiqj(3,2) = -cqiqj(2,3)
cqiqj(1,1) = 0
cqiqj(2,2) = 0
cqiqj(3,3) = 0
call ffthre(ithres,cqi,cqiqj,3,1,2,3)
if ( ithres.eq.0 .or. ithres.eq.1 .and. nschem.eq.5 ) then
lreal = .TRUE.
else
lreal = .FALSE.
endif
else
lreal = .FALSE.
endif
if ( lreal ) then
xp = DBLE(cp)
xma = DBLE(cma)
xmb = DBLE(cmb)
dmap = DBLE(cmap)
dmbp = DBLE(cmbp)
dmamb = DBLE(cmamb)
sprec = precx
precx = precc
call ffxdbp(cdb0,cdb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
precx = sprec
return
endif
*
* #] the real cases:
* #[ which case:
*
* sort according to the type of masscombination encountered:
* 100: both masses zero, 200: one equal to zero, 300: both equal
* 400: rest.
*
if ( cma .eq. 0 ) then
if ( cmb .eq. 0 ) then
goto 100
endif
cm = cmb
cdmp = cmbp
goto 200
endif
if ( cmb .eq. 0 ) then
cm = cma
cdmp = cmap
goto 200
elseif ( cmamb .eq. 0 ) then
cm = cma
cdmp = cmap
goto 300
elseif ( DBLE(cma) .gt. DBLE(cmb) ) then
cm2 = cma
cm1 = cmb
cm1m2 = -cmamb
cdm1p = cmbp
cdm2p = cmap
else
cm1 = cma
cm2 = cmb
cm1m2 = cmamb
cdm1p = cmap
cdm2p = cmbp
endif
goto 400
* #] which case:
* #[ both masses equal to zero:
100 continue
if ( cp.ne.0 ) cdb0 = -1/cp
cdb0p = -1
return
* #] both masses equal to zero:
* #[ one mass equal to zero:
200 continue
*
* special case cp = 0
*
if ( cp .eq. 0 ) then
cdb0p = 0
cdb0 = 1/(2*cm)
goto 990
*
* special case cp = cm
*
elseif ( cdmp.eq.0 ) then
if ( initir.eq.0 ) then
initir = 1
print *,'ffcdbd: IR divergent B0'', using cutoff ',
& lambda
endif
- if ( lambda.eq.0 ) then
- call fferr(74,ier)
- cdb0p = 0
+ if ( lambda .le. 0 ) then
+ cdb0p = -1 + log(cm/mudim)/2
else
- cdb0p = -1 + log(cm/DBLE(lambda))/2
+ cdb0p = -1 + log(cm/lambda)/2
endif
cdb0 = cdb0p/cp
goto 990
endif
*
* Normal case:
*
cx = cp/cm
ax = absc(cx)
if ( ax .lt. xloss ) then
* #[ Taylor expansion:
if ( xprec0 .ne. precx ) then
xprec0 = precc
prcsav = precx
precx = precc
bdn001 = ffbnd(2,1,xninv)
bdn005 = ffbnd(2,5,xninv)
bdn010 = ffbnd(2,10,xninv)
bdn015 = ffbnd(2,15,xninv)
bdn020 = ffbnd(2,20,xninv)
precx = prcsav
endif
if ( ax .gt. bdn015 ) then
som = cx*(DBLE(xninv(17)) + cx*(DBLE(xninv(18))
+ + cx*(DBLE(xninv(19)) + cx*(DBLE(xninv(20))
+ + cx*(DBLE(xninv(21)) )))))
else
som = 0
endif
if ( ax .gt. bdn010 ) then
som = cx*(DBLE(xninv(12)) + cx*(DBLE(xninv(13))
+ + cx*(DBLE(xninv(14)) + cx*(DBLE(xninv(15))
+ + cx*(DBLE(xninv(16)) + som )))))
endif
if ( ax .gt. bdn005 ) then
som = cx*(DBLE(xninv(7)) + cx*(DBLE(xninv(8))
+ + cx*(DBLE(xninv(9)) + cx*(DBLE(xninv(10))
+ + cx*(DBLE(xninv(11)) + som )))))
endif
if ( ax .gt. bdn001 ) then
som = cx*(DBLE(xninv(3)) + cx*(DBLE(xninv(4))
+ + cx*(DBLE(xninv(5)) + cx*(DBLE(xninv(6)) + som ))))
endif
cdb0p = cx*(DBLE(xninv(2)) + som)
* #] Taylor expansion:
else
* #[ short formula:
s = log(cdmp/cm)
cdb0p = -(1 + s*cm/cp)
* #] short formula:
endif
cdb0 = cdb0p/cp
goto 990
* #] one mass equal to zero:
* #[ both masses equal:
300 continue
*
* Both masses are equal. Not only this speeds up things, some
* cancellations have to be avoided as well.
*
* first a special case
*
if ( absc(cp) .lt. 8*xloss*absc(cm) ) then
* -#[ taylor expansion:
*
* a Taylor expansion seems appropriate as the result will go
* as k^2 but seems to go as 1/k !!
*
*--#[ data and bounds:
if ( initeq .eq. 0 ) then
initeq = 1
xpneq(1) = 1/6D0
do 1 i=2,30
xpneq(i) = - xpneq(i-1)*DBLE(i)/DBLE(2*(2*i+1))
1 continue
endif
if (xprceq .ne. precx ) then
*
* calculate the boundaries for the number of terms to be
* included in the taylorexpansion
*
xprceq = precx
bdeq01 = ffbndc(1,1,xpneq)
bdeq05 = ffbndc(1,5,xpneq)
bdeq11 = ffbndc(1,11,xpneq)
bdeq17 = ffbndc(1,17,xpneq)
bdeq25 = ffbndc(1,25,xpneq)
endif
*--#] data and bounds:
cx = -cp/cm
ax = absc(cx)
if ( ax .gt. bdeq17 ) then
som = cx*(xpneq(18) + cx*(xpneq(19) + cx*(xpneq(20) +
+ cx*(xpneq(21) + cx*(xpneq(22) + cx*(xpneq(23) +
+ cx*(xpneq(24) + cx*(xpneq(25) ))))))))
else
som = 0
endif
if ( ax .gt. bdeq11 ) then
som = cx*(xpneq(12) + cx*(xpneq(13) + cx*(xpneq(14) +
+ cx*(xpneq(15) + cx*(xpneq(16) + cx*(xpneq(17) + som ))))
+ ))
endif
if ( ax .gt. bdeq05 ) then
som = cx*(xpneq(6) + cx*(xpneq(7) + cx*(xpneq(8) + cx*(
+ xpneq(9) + cx*(xpneq(10) + cx*(xpneq(11) + som ))))))
endif
if ( ax .gt. bdeq01 ) then
som = cx*(xpneq(2) + cx*(xpneq(3) + cx*(xpneq(4) + cx*(
+ xpneq(5) + som ))))
endif
cdb0p = -cx*(xpneq(1)+som)
if ( cp.ne.0 ) then
cdb0 = cdb0p*(1/DBLE(cp))
else
cdb0 = xpneq(1)/cm
endif
goto 990
* -#] taylor expansion:
endif
* -#[ normal case:
*
* normal case
*
call ffclmb(clam,-cp,-cm,-cm,cdmp,cdmp,czero)
slam = sqrt(clam)
call ffcoot(zm,zp,cone,chalf,cm/cp,slam/(2*cp),ier)
s1 = zp/zm
if( abs(s1-1) .lt. xloss ) then
* In this case a quicker and more accurate way is to
* calculate log(1-cx).
print *,'Not tested, probably wrong'
ier = ier + 50
s2 = (cp - slam)
if ( absc(s2) .lt. xloss*absc(cp) ) then
s2 = -slam*(cp+slam)/(4*cp*cm)
else
s2 = -2*slam/s2
endif
s = -2*cm/slam*zfflo1(s2/(2*cm),ier)
else
* finally the normal case
s = -2*cm/slam*log(s1)
endif
*
* eta terms
*
n1 = nffet1(zp,1/zm,s1,ier)
n2 = nffet1(-zp,-1/zm,s1,ier)
if ( n1+n2 .ne. 0 ) then
s1 = cm/slam*c2ipi*(n1+n2)
s = s + s1
endif
cdb0p = s - 1
cdb0 = cdb0p/cp
goto 990
* -#] normal case:
*
* #] both masses equal:
* #[ unequal nonzero masses:
400 continue
* -#[ get log(cm2/cm1):
cx = cm2/cm1
c = cx-1
if ( 1 .lt. xclogm*absc(cx) ) then
call fferr(8,ier)
xlogmm = 0
elseif ( absc(c) .lt. xloss ) then
xlogmm = zfflo1(cm1m2/cm1,ier)
else
xlogmm = log(cx)
endif
* -#] get log(cm2/cm1):
* -#[ cp = 0:
*
* first a special case
*
if ( cp .eq. 0 ) then
*
* repaired 19-nov-1993, see b2.frm
*
s1 = cm1*cm2*xlogmm/cm1m2**3
s2 = (cm1+cm2)/(2*cm1m2**2)
s = s1 + s2
if ( absc(s) .lt. xloss**2*absc(s2) ) then
*
* second try
*
h = zfflo3(cm1m2/cm1,ier)
s1 = -cm1*h/cm1m2**2
s2 = 1/(2*cm1)
s3 = cm1**2*h/cm1m2**3
s = s1 + s2 + s3
if ( absc(s) .lt. xloss*max(absc(s2),absc(s3)) ) then
call ffwarn(234,ier,absc(s),absc(s2))
endif
endif
cdb0 = s
cdb0p = 0
goto 990
endif
* -#] cp = 0:
* -#[ normal case:
*
* proceeding with the normal case
*
call ffclmb(clam,-cp,-cm2,-cm1,cdm2p,cdm1p,cm1m2)
diff = clam + cp*(cdm2p+cm1)
if ( absc(diff) .lt. xloss*absc(clam) ) then
h = cm1m2**2 - cp*(cm1+cm2)
if ( absc(h) .lt. xloss*absc(cm1m2)**2 ) then
if ( absc(cm1m2)**2 .lt. absc(clam) ) diff = h
call ffwarn(235,ier,absc(diff),min(absc(cm1m2)**2,
+ absc(clam)))
endif
endif
*--#[ first try:
* first try the normal way
slam = sqrt(clam)
if ( abs(DBLE(cm1)) .lt. abs(DBLE(cm2)) ) then
s2a = cm1 + cdm2p
else
s2a = cm2 + cdm1p
endif
s2 = s2a + slam
if ( absc(s2) .gt. xloss*absc(slam) ) then
* looks fine
jsign = 1
else
s2 = s2a - slam
jsign = -1
endif
s2 = s2/sqrt(4*cm1*cm2)
if ( absc(s2) .lt. xclogm ) then
call fferr(9,ier)
s2 = 0
elseif ( absc(s2-1) .lt. xloss ) then
ier = ier + 50
print *,'ffcdb0: untested: s2 better in first try'
if ( jsign.eq.1 ) then
s2 = -slam*(s2a+slam)/(2*cm1*cm2)
s2 = -diff/(2*slam*cp)*zfflo1(s2,ier)
else
s2 = +slam*(s2a-slam)/(2*cm1*cm2)
s2 = +diff/(2*slam*cp)*zfflo1(s2,ier)
endif
else
s2 = -diff/(2*slam*cp)*2*log(s2)
if ( jsign .eq. -1 ) s2 = -s2
endif
s1 = -cm1m2*xlogmm/(2*cp)
cdb0p = s1+s2-1
*--#] first try:
if ( absc(cdb0p) .lt. xloss**2*max(absc(s1),absc(s2)) ) then
*--#[ second try:
* this is unacceptable, try a better solution
s1a = diff + slam*cm1m2
if ( absc(s1a) .gt. xloss*absc(diff) ) then
* this works
s1 = -s1a/(2*cp*slam)
else
* by division a more accurate form can be found
s1 = -2*cm1*cm2*cp/(slam*(diff - slam*cm1m2))
endif
s = s1
s1 = s1*xlogmm
if ( abs(DBLE(cp)).lt.abs(DBLE(cm2)) ) then
s2a = cp - cm1m2
else
s2a = cm2 - cdm1p
endif
s2 = s2a - slam
if ( absc(s2) .gt. xloss*absc(slam) ) then
* at least reasonable
s2 = s2 / (2*cm2)
else
* division again
s2 = (2*cp) / (s2a+slam)
endif
if ( absc(s2) .lt. .1 ) then
* choose a quick way to get the logarithm
s2 = zfflo1(s2,ier)
else
s2 = log(1-s2)
endif
s2 = -diff/(slam*cp)*s2
cdb0p = s1 + s2 - 1
*--#] second try:
if ( absc(cdb0p) .lt. xloss**2*max(absc(s1),absc(s2)) )
+ then
*--#[ third try:
* (we accept two times xloss because that's the same
* as in this try)
* A Taylor expansion might work. We expand
* inside the logs. Only do the necessary work.
*
* #[ split up 1:
xnoe = s2a+slam
a = 1
b = 2/xnoe-1/cp
c = -4/(cp*xnoe)
d = sqrt(cp**(-2) + (2/xnoe)**2)
call ffcoot(d1,d2,a,b,c,d,ier)
if ( DBLE(cp).gt.0 ) then
beta = d2
else
beta = d1
endif
alpha = beta*diff/slam
alph1 = 1-alpha
if ( absc(alph1) .lt. xloss ) then
s1a = 4*cp**2*cm1*cm2/(slam*cm1m2*(diff-slam*
+ cm1m2))
s1b = -diff/slam*4*cm1*cp/(cm1m2*xnoe*(2*cp-
+ xnoe))
b = -1/cp
c = -(2/xnoe)**2
call ffcoot(d1,d2,a,b,c,d,ier)
if ( DBLE(cp).gt.0 ) then
betm2n = d2
else
betm2n = d1
endif
d1 = s1a + s1b - diff/slam*betm2n
xmax = max(absc(s1a),absc(s1b))
if ( xmax .lt. 1 ) then
alph1 = d1
else
xmax = 1
endif
if ( absc(alph1) .lt. xloss*xmax )
+ call ffwarn(236,ier,absc(alph1),xmax)
else
betm2n = beta - 2/xnoe
endif
* #] split up 1:
* #[ s2:
*
* first s2:
*
- 490 s2p = s2 - alpha
+ s2p = s2 - alpha
if ( absc(s2p) .lt. xloss*absc(s2) ) then
* -#[ bounds:
* determine the boundaries for 1,5,10,15 terms
if ( xprcn5 .ne. precx ) then
xprcn5 = precc
prcsav = precx
precx = precc
bdn501 = ffbnd(3,1,xinfac)
bdn505 = ffbnd(3,5,xinfac)
bdn510 = ffbnd(3,10,xinfac)
bdn515 = ffbnd(3,15,xinfac)
precx = prcsav
endif
* -#] bounds:
cx = beta*cp
ax = absc(cx)
if ( ax .gt. bdn510 ) then
s2a = cx*(DBLE(xinfac(13)) + cx*(DBLE(xinfac(
+ 14))+ cx*(DBLE(xinfac(15)) + cx*(DBLE(xinfac(
+ 16))+ cx*(DBLE(xinfac(17)))))))
else
s2a = 0
endif
if ( ax .gt. bdn505 ) then
s2a = cx*(DBLE(xinfac( 8)) + cx*(DBLE(xinfac(
+ 9))+ cx*(DBLE(xinfac(10)) + cx*(DBLE(xinfac(
+ 11))+ cx*(DBLE(xinfac(12)) + s2a)))))
endif
if ( ax .gt. bdn501 ) then
s2a =cx*(DBLE(xinfac(4))+cx*(DBLE(xinfac(5))
+ +cx*(DBLE(xinfac(6))+cx*(DBLE(xinfac(7))
+ + s2a))))
endif
s2a = cx**3*(DBLE(xinfac(3))+s2a)
s2b = 2*cp/xnoe*(s2a + cx**2/2)
s2p = s2b - s2a
s2p = -diff/(cp*slam)*zfflo1(s2p,ier)
endif
* #] s2:
* #[ s1:
*
* next s1:
*
- 495 s1p = s1 - alph1
+ s1p = s1 - alph1
if ( absc(s1p) .lt. xloss*absc(s1) ) then
* -#[ bounds:
* determine the boundaries for 1,5,10,15 terms
if ( xprcn3 .ne. precx ) then
xprcn3 = precc
prcsav = precx
precx = precc
bdn301 = ffbnd(3,1,xinfac)
bdn305 = ffbnd(3,5,xinfac)
bdn310 = ffbnd(3,10,xinfac)
bdn315 = ffbnd(3,15,xinfac)
precx = prcsav
endif
* -#] bounds:
*
cx = slam*(diff-slam*cm1m2)*alph1/(2*cp*cm1*cm2)
ax = absc(cx)
h = (2*cp*(cm1+cm2) - cp**2)/(slam-cm1m2)
*
* see form job gets1.frm
*
s1b = diff*(diff-slam*cm1m2)*betm2n/(2*cp*cm1*
+ cm2)
s1c = 1/(cm1*xnoe*(2*cp-xnoe))*(
+ cp*( 4*cp*cm2 + 2*cm1m2**2/cm2*(cp-h) +
+ 2*cm1m2*(3*cp-h) - 8*cm1m2**2 )
+ - 2*cm1m2**3/cm2*(3*cp-h)
+ + 4*cm1m2**4/cm2
+ )
s1d = cx*cm1m2/cm1
s1e = -cx**2/2
if ( ax .gt. bdn310 ) then
s1a = cx*(DBLE(xinfac(13)) + cx*(DBLE(xinfac(
+ 14))+ cx*(DBLE(xinfac(15)) + cx*(DBLE(xinfac(
+ 16))+ cx*(DBLE(xinfac(17)))))))
else
s1a = 0
endif
if ( ax .gt. bdn305 ) then
s1a = cx*(DBLE(xinfac( 8)) + cx*(DBLE(xinfac(
+ 9))+ cx*(DBLE(xinfac(10)) + cx*(DBLE(xinfac(
+ 11))+ cx*(DBLE(xinfac(12)) + s1a)))))
endif
if ( ax .gt. bdn301 ) then
s1a =cx*(DBLE(xinfac(4))+cx*(DBLE(xinfac(5))
+ +cx*(DBLE(xinfac(6))+cx*(DBLE(xinfac(7))
+ +s1a))))
endif
s1a = -cx**3 *(DBLE(xinfac(3)) + s1a)
s1f = cm1m2/cm1*(cx**2/2 - s1a)
s1p = s1e + s1d + s1c + s1b + s1a + s1f
xmax = max(absc(s1a),absc(s1b),absc(s1c),
+ absc(s1d),absc(s1e))
s1p = s*zfflo1(s1p,ier)
endif
* #] s1:
*
* finally ...
*
- 496 cdb0p = s1p + s2p
+ cdb0p = s1p + s2p
*--#] third try:
endif
endif
cdb0 = cdb0p*(1/DBLE(cp))
* -#] normal case:
* #] unequal nonzero masses:
990 continue
*###] ffcdbp:
end
diff --git a/Looptools/B/ffcel2.F b/Looptools/B/ffcel2.F
--- a/Looptools/B/ffcel2.F
+++ b/Looptools/B/ffcel2.F
@@ -1,554 +1,557 @@
+#include "externals.h"
+
+
*###[ ffcel2:
subroutine ffcel2(del2,piDpj,ns,i1,i2,i3,lerr,ier)
*************************************************************************
* calculate in a numerically stable way *
* del2(piDpj(i1,i1),piDpj(i2,i2),piDpj(i3,i3)) = *
* = piDpj(i1,i1)*piDpj(i2,i2) - piDpj(i1,i2)^2 *
* = piDpj(i1,i1)*piDpj(i3,i3) - piDpj(i1,i3)^2 *
* = piDpj(i2,i2)*piDpj(i3,i3) - piDpj(i2,i3)^2 *
* ier is the usual error flag. *
*************************************************************************
implicit none
*
* arguments:
*
integer ns,i1,i2,i3,lerr,ier
DOUBLE COMPLEX del2,piDpj(ns,ns)
*
* local variables
*
DOUBLE COMPLEX s1,s2,cc
DOUBLE PRECISION absc
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
* calculations
*
if ( absc(piDpj(i1,i2)) .lt. absc(piDpj(i1,i3)) .and.
+ absc(piDpj(i1,i2)) .lt. absc(piDpj(i2,i3)) ) then
s1 = piDpj(i1,i1)*piDpj(i2,i2)
s2 = piDpj(i1,i2)**2
elseif ( absc(piDpj(i1,i3)) .lt. absc(piDpj(i2,i3)) ) then
s1 = piDpj(i1,i1)*piDpj(i3,i3)
s2 = piDpj(i1,i3)**2
else
s1 = piDpj(i2,i2)*piDpj(i3,i3)
s2 = piDpj(i2,i3)**2
endif
del2 = s1 - s2
if ( absc(del2) .lt. xloss*absc(s2) ) then
if ( lerr .eq. 0 ) then
* we know we have another chance
if ( del2.ne.0 ) then
ier = ier + int(log10(xloss*absc(s2)/absc(del2)))
else
ier = ier + int(log10(xloss*absc(s2)/xclogm))
endif
endif
endif
*###] ffcel2:
end
*###[ ffcl2p:
subroutine ffcl2p(delps1,xpi,dpipj,piDpj,
+ ip1,ip2,ip3,is1,is2,is3,ns)
***#[*comment:***********************************************************
* *
* calculate in a numerically stable way *
* delta_{ip1,is2}^{ip1,ip2} *
* ier is the usual error flag. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ns,ip1,ip2,ip3,is1,is2,is3
DOUBLE COMPLEX delps1,xpi(ns),dpipj(ns,ns),piDpj(ns,ns)
*
* local variables
*
DOUBLE COMPLEX s1,s2,s3,som,c
DOUBLE PRECISION xmax,absc
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ stupid tree:
* 1
s1 = xpi(ip1)*piDpj(ip2,is2)
s2 = piDpj(ip1,ip2)*piDpj(ip1,is2)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
som = delps1
xmax = absc(s1)
* 2
s1 = piDpj(ip1,ip2)*piDpj(ip3,is2)
s2 = piDpj(ip1,ip3)*piDpj(ip2,is2)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
if ( absc(s1) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
* 3
s1 = piDpj(ip1,ip3)*piDpj(ip1,is2)
s2 = xpi(ip1)*piDpj(ip3,is2)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
if ( absc(s1) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
* 4
s1 = xpi(ip1)*piDpj(ip2,is1)
s2 = piDpj(ip1,is1)*piDpj(ip1,ip2)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
if ( absc(s1) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
* 5
s1 = piDpj(ip1,is2)*piDpj(ip2,is1)
s2 = piDpj(ip1,is1)*piDpj(ip2,is2)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
if ( absc(s1) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
* 6
s1 = piDpj(ip1,ip2)*piDpj(ip3,is1)
s2 = piDpj(ip1,ip3)*piDpj(ip2,is1)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
if ( absc(s1) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
* 7
s1 = piDpj(ip2,is2)*piDpj(ip3,is1)
s2 = piDpj(ip2,is1)*piDpj(ip3,is2)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
if ( absc(s1) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
* 8
s1 = piDpj(ip1,ip3)*piDpj(ip1,is1)
s2 = xpi(ip1)*piDpj(ip3,is1)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
if ( absc(s1) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
* 9
s1 = piDpj(ip1,is1)*piDpj(ip3,is2)
s2 = piDpj(ip1,is2)*piDpj(ip3,is1)
delps1 = s1 - s2
if ( absc(delps1) .ge. xloss*absc(s1) ) goto 100
if ( absc(s1) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
*10 22-nov-1993 yet another one
if ( dpipj(1,1).eq.0 ) then
s1 = +xpi(ip1)*dpipj(is3,is2)/2
s2 = -piDpj(ip1,ip2)*dpipj(is2,is1)/2
s3 = +xpi(ip1)*piDpj(ip2,ip3)/2
delps1 = s1+s2+s3
if ( absc(delps1) .ge. xloss*max(absc(s1),absc(s2)) )
+ goto 100
if ( max(absc(s1),absc(s2)) .lt. xmax ) then
som = delps1
xmax = absc(s1)
endif
endif
* NO possibility
delps1 = som
100 continue
* #] stupid tree:
*###] ffcl2p:
end
*###[ ffcl2t:
subroutine ffcl2t(delps,piDpj,in,jn,kn,ln,lkn,islk,iss,ns)
***#[*comment:***********************************************************
* *
* calculate in a numerically stable way *
* *
* \delta_{si,sj}^{sk,sl} *
* *
* with p(lk) = islk*(iss*sl - sk) (islk,iss = +/-1) *
* and NO relationship between s1,s2 assumed (so 1/2 the *
* possibilities of ffdl2s). *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer in,jn,kn,ln,lkn,islk,iss,ns
DOUBLE COMPLEX delps,piDpj(ns,ns)
*
* local variables
*
DOUBLE COMPLEX s1,s2,c
DOUBLE PRECISION absc
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ calculations:
if ( in .eq. jn ) then
delps = 0D0
return
endif
s1 = piDpj(kn,in)*piDpj(ln,jn)
s2 = piDpj(ln,in)*piDpj(kn,jn)
delps = s1 - s2
if ( absc(delps) .ge. xloss*absc(s1) ) goto 10
s1 = piDpj(kn,in)*piDpj(lkn,jn)
s2 = piDpj(lkn,in)*piDpj(kn,jn)
delps = iss*islk*(s1 - s2)
if ( absc(delps) .ge. xloss*absc(s1) ) goto 10
s1 = piDpj(lkn,in)*piDpj(ln,jn)
s2 = piDpj(ln,in)*piDpj(lkn,jn)
delps = islk*(- s1 + s2)
if ( absc(delps) .ge. xloss*absc(s1) ) goto 10
10 continue
* #] calculations:
*###] ffcl2t:
end
*###[ ffcl3m:
subroutine ffcl3m(del3mi,ldel,del3,del2,xpi,dpipj,piDpj,ns,ip1n,
+ ip2n,ip3n,is,itime)
***#[*comment:***********************************************************
* *
* Calculate xpi(i)*del2 - del3(piDpj) *
* *
* / si mu \2 (This appears to be one of the harder *
* = | d | determinants to calculate accurately. *
* \ p1 p2 / Note that we allow a loss of xloss^2) *
* *
* Input: ldel iff .true. del2 and del3 exist *
* del3 \delta^{s(1),p1,p2}_{s(1),p1,p2} *
* del2 \delta^{p1,p2}_{p1,p2} *
* xpi(ns) standard *
* dpipj(ns,ns) standard *
* piDpj(ns,ns) standard *
* ipi pi = xpi(abs(ipi)) [p3=-p1 +/-p2] *
* is si = xpi(is,is+1,..,is+itime-1) *
* itime number of functions to calculate *
* *
* Output: del3mi(3) (\delta^{s_i \mu}_{p_1 p_2})^2 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ns,ip1n,ip2n,ip3n,is,itime
logical ldel
DOUBLE COMPLEX del3mi(itime),del3,del2,xpi(ns),dpipj(ns,ns),
+ piDpj(ns,ns)
*
* local variables:
*
DOUBLE PRECISION smax,xmax,absc
DOUBLE COMPLEX s(7),som,xsom,c
integer i,j,k,ip1,ip2,ip3,ipn,is1,is2,isi,is3,ihlp,iqn,
+ jsgn1,jsgn2,jsgn3,jsgnn,iadj(10,10,3:4),init,nm
save iadj,init
logical lmax,ltwist
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* data
*
data iadj /200*0/
data init /0/
* #] declarations:
* #[ initialisations:
if ( init .eq. 0 ) then
init = 1
*
* Fill the array with adjacent values: if
* x = iadj(i,j)
* k = abs(mod(k,100))
* jsgnk = sign(x)
* jsgnj = 1-2*theta(x-100) (ie -1 iff |x|>100)
* then
* pi(k) = jsgnk*( p(i) - jsgnj*pi(j) )
*
do 5 nm=3,4
do 4 i=1,nm
is1 = i
is2 = i+1
if ( is2 .gt. nm ) is2 = 1
is3 = i-1
if ( is3 .eq. 0 ) is3 = nm
ip1 = is1 + nm
iadj(is1,is2,nm) = -ip1
iadj(is2,is1,nm) = ip1
iadj(ip1,is2,nm) = -is1
iadj(is2,ip1,nm) = is1
iadj(is1,ip1,nm) = 100+is2
iadj(ip1,is1,nm) = 100+is2
if ( nm .eq. 3 ) then
iadj(ip1,is2+3,3) = -100-is3-3
iadj(is2+3,ip1,3) = -100-is3-3
endif
4 continue
5 continue
iadj(3,1,4) = -9
iadj(1,3,4) = 9
iadj(9,1,4) = -3
iadj(1,9,4) = 3
iadj(3,9,4) = 100+1
iadj(9,3,4) = 100+1
iadj(2,4,4) = -10
iadj(4,2,4) = 10
iadj(10,4,4) = -2
iadj(4,10,4) = 2
iadj(2,10,4) = 100+4
iadj(10,2,4) = 100+4
endif
if ( ns .eq. 6 ) then
nm = 3
else
nm = 4
endif
* #] initialisations:
* #[ easy tries:
do 40 i=1,itime
isi = i+is-1
lmax = .FALSE.
*
* get xpi(isi)*del2 - del3 ... if del3 and del2 are defined
*
if ( ldel ) then
s(1) = xpi(isi)*del2
som = s(1) - del3
smax = absc(s(1))
if ( absc(som) .ge. xloss**2*smax ) goto 35
xsom = som
xmax = smax
lmax = .TRUE.
endif
ip1 = ip1n
ip2 = ip2n
ip3 = ip3n
do 20 j=1,3
*
* otherwise use the simple threeterm formula
*
s(1) = xpi(ip2)*piDpj(ip1,isi)**2
s(2) = xpi(ip1)*piDpj(ip2,isi)*piDpj(ip2,isi)
s(3) = -2*piDpj(ip2,isi)*piDpj(ip2,ip1)*piDpj(ip1,isi)
som = s(1) + s(2) + s(3)
smax = max(absc(s(1)),absc(s(2)),absc(s(3)))
if ( absc(som) .ge. xloss**2*smax ) goto 35
if ( .not. lmax .or. smax .lt. xmax ) then
xsom = som
xmax = smax
lmax = .TRUE.
endif
*
* if there are cancellations between two of the terms:
* we try mixing with isi.
*
* First map cancellation to s(2)+s(3) (do not mess up
* rotations...)
*
if ( absc(s(1)+s(3)) .lt. absc(s(3))/2 ) then
ihlp = ip1
ip1 = ip2
ip2 = ihlp
som = s(1)
s(1) = s(2)
s(2) = som
ltwist = .TRUE.
else
ltwist = .FALSE.
endif
if ( absc(s(2)+s(3)) .lt. absc(s(3))/2 ) then
*
* switch to the vector pn so that si = jsgn1*p1 + jsgnn*pn
*
k = iadj(isi,ip1,nm)
if ( k .ne. 0 ) then
ipn = abs(k)
jsgnn = isign(1,k)
if ( ipn .gt. 100 ) then
ipn = ipn - 100
jsgn1 = -1
else
jsgn1 = +1
endif
if ( absc(dpipj(ipn,isi)) .lt.
+ xloss*absc(piDpj(ip1,isi)) .and.
+ absc(piDpj(ipn,ip2)) .lt.
+ xloss*absc(piDpj(ip2,isi)) ) then
* same: s(1) = xpi(ip2)*piDpj(ip1,isi)**2
s(2) = jsgnn*piDpj(isi,ip2)*piDpj(ipn,ip2)*
+ xpi(ip1)
s(3) = jsgn1*piDpj(isi,ip2)*piDpj(ip1,ip2)*
+ dpipj(ipn,isi)
som = s(1) + s(2) + s(3)
smax = max(absc(s(1)),absc(s(2)),absc(s(3)))
* print *,' (isi+ip1) with isi,ip1,ip2,ipn: ',
* + isi,ip1,ip2,ipn
* print *,'xpi(ip2),piDpj(ip1,isi)',xpi(ip2),
* + piDpj(ip1,isi)
* print *,'piDpj(isi,ip2),piDpj(ipn,ip2),xpi(ip1)'
* + ,piDpj(isi,ip2),piDpj(ipn,ip2),xpi(ip1)
if ( absc(som) .ge. xloss**2*smax ) goto 35
if ( smax .lt. xmax ) then
xsom = som
xmax = smax
endif
*
* there may be a cancellation between s(1) and
* s(2) left. Introduce a vector q such that
* pn = jsgnq*q + jsgn2*p2. We also need the sign
* jsgn3 in p3 = -p1 - jsgn3*p2
*
k = iadj(ipn,ip2,nm)
if ( k .ne. 0 ) then
iqn = abs(k)
*not used jsgnq = isign(1,k)
if ( iqn .gt. 100 ) then
iqn = iqn - 100
jsgn2 = -1
else
jsgn2 = +1
endif
k = iadj(ip1,ip2,nm)
if ( k .eq. 0 .or. k .lt. 100 ) then
* we have p1,p2,p3 all p's
jsgn3 = +1
elseif ( k .lt. 0 ) then
* ip1,ip2 are 2*s,1*p such that p2-p1=ip3
jsgn3 = -1
else
jsgn3 = 0
endif
* we need one condition on the signs for this
* to work
if ( ip3.ne.0 .and. jsgn1*jsgn2.eq.jsgnn*
+ jsgn3 .and. absc(s(3)).lt.xloss*smax ) then
s(1) = piDpj(ip1,isi)**2*dpipj(iqn,ipn)
s(2) = -jsgn2*jsgn1*piDpj(ipn,ip2)*
+ piDpj(ip1,isi)*dpipj(ipn,isi)
* s(3) stays the same
s(4) = -jsgn2*jsgn1*piDpj(ipn,ip2)*
+ xpi(ip1)*piDpj(isi,ip3)
som = s(1) + s(2) + s(3) + s(4)
smax = max(absc(s(1)),absc(s(2)),
+ absc(s(3)),absc(s(4)))
if (absc(som).ge.xloss**2*smax) goto 35
if ( smax .lt. xmax ) then
xsom = som
xmax = smax
endif
endif
endif
endif
endif
k = iadj(isi,ip2,nm)
if ( k .ne. 0 ) then
ipn = abs(k)
jsgnn = isign(1,k)
if ( ipn .gt. 100 ) then
jsgn1 = -1
ipn = ipn - 100
else
jsgn1 = +1
endif
if ( absc(dpipj(ipn,isi)) .lt.
+ xloss*absc(piDpj(ip2,isi)) .and.
+ absc(piDpj(ipn,ip1)) .lt.
+ xloss*absc(piDpj(ip1,isi)) ) then
s(1) = jsgnn*piDpj(isi,ip1)*piDpj(ipn,ip1)*
+ xpi(ip2)
s(2) = xpi(ip1)*piDpj(ip2,isi)**2
s(3) = jsgn1*piDpj(isi,ip1)*piDpj(ip2,ip1)*
+ dpipj(ipn,isi)
som = s(1) + s(2) + s(3)
smax = max(absc(s(1)),absc(s(2)),absc(s(3)))
print *,' (isi+ip2) with isi,ip1,ip2,ipn: ',
+ isi,ip1,ip2,ipn
if ( absc(som) .ge. xloss**2*smax ) goto 35
if ( smax .lt. xmax ) then
xsom = som
xmax = smax
endif
endif
endif
endif
*
* rotate the ipi
*
if ( ip3 .eq. 0 ) goto 30
if ( j .ne. 3 ) then
if ( .not. ltwist ) then
ihlp = ip1
ip1 = ip2
ip2 = ip3
ip3 = ihlp
else
ihlp = ip2
ip2 = ip3
ip3 = ihlp
endif
endif
20 continue
30 continue
* #] easy tries:
* #[ choose the best value:
*
* These values are the best found:
*
som = xsom
smax = xmax
35 continue
del3mi(i) = som
40 continue
* #] choose the best value:
*###] ffcl3m:
end
diff --git a/Looptools/B/ffdel2.F b/Looptools/B/ffdel2.F
--- a/Looptools/B/ffdel2.F
+++ b/Looptools/B/ffdel2.F
@@ -1,627 +1,630 @@
+#include "externals.h"
+
+
*###[ ffdel2:
subroutine ffdel2(del2,piDpj,ns,i1,i2,i3,lerr,ier)
*************************************************************************
* calculate in a numerically stable way *
* del2(piDpj(i1,i1),piDpj(i2,i2),piDpj(i3,i3)) = *
* = piDpj(i1,i1)*piDpj(i2,i2) - piDpj(i1,i2)^2 *
* = piDpj(i1,i1)*piDpj(i3,i3) - piDpj(i1,i3)^2 *
* = piDpj(i2,i2)*piDpj(i3,i3) - piDpj(i2,i3)^2 *
* ier is the usual error flag. *
*************************************************************************
implicit none
*
* arguments:
*
integer ns,i1,i2,i3,lerr,ier
DOUBLE PRECISION del2,piDpj(ns,ns)
*
* local variables
*
DOUBLE PRECISION s1,s2
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* calculations
*
idsub = idsub + 1
if ( abs(piDpj(i1,i2)) .lt. abs(piDpj(i1,i3)) .and.
+ abs(piDpj(i1,i2)) .lt. abs(piDpj(i2,i3)) ) then
s1 = piDpj(i1,i1)*piDpj(i2,i2)
s2 = piDpj(i1,i2)**2
elseif ( abs(piDpj(i1,i3)) .lt. abs(piDpj(i2,i3)) ) then
s1 = piDpj(i1,i1)*piDpj(i3,i3)
s2 = piDpj(i1,i3)**2
else
s1 = piDpj(i2,i2)*piDpj(i3,i3)
s2 = piDpj(i2,i3)**2
endif
del2 = s1 - s2
if ( abs(del2) .lt. xloss*s2 ) then
if ( lerr .eq. 0 ) then
* we know we have another chance
if ( del2.ne.0 ) then
ier = ier + int(log10(xloss*abs(s2/del2)))
else
ier = ier + int(log10(xloss*abs(s2)/xclogm))
endif
endif
endif
*###] ffdel2:
end
*###[ ffdl2p:
subroutine ffdl2p(delps1,xpi,dpipj,piDpj,
+ ip1,ip2,ip3,is1,is2,is3,ns)
***#[*comment:***********************************************************
* *
* calculate in a numerically stable way *
* delta_{ip1,is2}^{ip1,ip2} *
* ier is the usual error flag. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ns,ip1,ip2,ip3,is1,is2,is3
DOUBLE PRECISION delps1,xpi(ns),dpipj(ns,ns),piDpj(ns,ns)
*
* local variables
*
DOUBLE PRECISION s1,s2,s3,xmax,som
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ stupid tree:
* 1
s1 = xpi(ip1)*piDpj(ip2,is2)
s2 = piDpj(ip1,ip2)*piDpj(ip1,is2)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
som = delps1
xmax = abs(s1)
* 2
s1 = piDpj(ip1,ip2)*piDpj(ip3,is2)
s2 = piDpj(ip1,ip3)*piDpj(ip2,is2)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
if ( abs(s1) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
* 3
s1 = piDpj(ip1,ip3)*piDpj(ip1,is2)
s2 = xpi(ip1)*piDpj(ip3,is2)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
if ( abs(s1) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
* 4
s1 = xpi(ip1)*piDpj(ip2,is1)
s2 = piDpj(ip1,is1)*piDpj(ip1,ip2)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
if ( abs(s1) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
* 5
s1 = piDpj(ip1,is2)*piDpj(ip2,is1)
s2 = piDpj(ip1,is1)*piDpj(ip2,is2)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
if ( abs(s1) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
* 6
s1 = piDpj(ip1,ip2)*piDpj(ip3,is1)
s2 = piDpj(ip1,ip3)*piDpj(ip2,is1)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
if ( abs(s1) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
* 7
s1 = piDpj(ip2,is2)*piDpj(ip3,is1)
s2 = piDpj(ip2,is1)*piDpj(ip3,is2)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
if ( abs(s1) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
* 8
s1 = piDpj(ip1,ip3)*piDpj(ip1,is1)
s2 = xpi(ip1)*piDpj(ip3,is1)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
if ( abs(s1) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
* 9
s1 = piDpj(ip1,is1)*piDpj(ip3,is2)
s2 = piDpj(ip1,is2)*piDpj(ip3,is1)
delps1 = s1 - s2
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 100
if ( abs(s1) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
*10 22-nov-1993 yet another one
if ( dpipj(1,1).eq.0 ) then
s1 = +xpi(ip1)*dpipj(is3,is2)/2
s2 = -piDpj(ip1,ip2)*dpipj(is2,is1)/2
s3 = +xpi(ip1)*piDpj(ip2,ip3)/2
delps1 = s1+s2+s3
if ( abs(delps1) .ge. xloss*max(abs(s1),abs(s2)) ) goto 100
if ( max(abs(s1),abs(s2)) .lt. xmax ) then
som = delps1
xmax = abs(s1)
endif
endif
* NO possibility
delps1 = som
100 continue
* #] stupid tree:
*###] ffdl2p:
end
*###[ ffdl2s:
subroutine ffdl2s(delps1,piDpj,in,jn,jin,isji,
+ kn,ln,lkn,islk,ns)
***#[*comment:***********************************************************
* *
* calculate in a numerically stable way *
* *
* \delta_{si,sj}^{sk,sl} *
* *
* with p(ji) = isji*(sj-si) *
* p(lk) = islk*(sl-sk) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer in,jn,jin,isji,kn,ln,lkn,islk,ns
DOUBLE PRECISION delps1,piDpj(ns,ns)
*
* local variables
*
integer ii,jj,i,j,ji,k,l,lk,ihlp
DOUBLE PRECISION s1,s2,som,smax
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ stupid tree:
idsub = idsub + 1
som = 0
smax = 0
i = in
j = jn
ji = jin
k = kn
l = ln
lk = lkn
do 20 ii=1,3
do 10 jj=1,3
s1 = piDpj(i,k)*piDpj(j,l)
s2 = piDpj(i,l)*piDpj(j,k)
delps1 = s1 - s2
if ( ii .gt. 1 ) delps1 = isji*delps1
if ( jj .gt. 1 ) delps1 = islk*delps1
if ( ii .eq. 3 .neqv. jj .eq. 3 ) delps1 = -delps1
if ( abs(delps1) .ge. xloss*abs(s1) ) goto 30
*
* Save the most accurate estimate so far:
if ( ii .eq. 1 .and. jj .eq. 1 .or. abs(s1) .lt. smax
+ ) then
som = delps1
smax = abs(s1)
endif
*
* rotate the jj's
if ( lk .eq. 0 ) goto 20
ihlp = k
k = l
l = lk
lk = ihlp
10 continue
*
* and the ii's
if ( ji .eq. 0 ) goto 25
ihlp = i
i = j
j = ji
ji = ihlp
20 continue
25 continue
delps1 = som
30 continue
* #] stupid tree:
*###] ffdl2s:
end
*###[ ffdl2t:
subroutine ffdl2t(delps,piDpj,in,jn,kn,ln,lkn,islk,iss,ns)
***#[*comment:***********************************************************
* *
* calculate in a numerically stable way *
* *
* \delta_{si,sj}^{sk,sl} *
* *
* with p(lk) = islk*(iss*sl - sk) (islk,iss = +/-1) *
* and NO relationship between s1,s2 assumed (so 1/2 the *
* possibilities of ffdl2s). *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer in,jn,kn,ln,lkn,islk,iss,ns
DOUBLE PRECISION delps,piDpj(ns,ns)
*
* local variables
*
DOUBLE PRECISION s1,s2,som,smax
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ calculations:
if ( in .eq. jn ) then
delps = 0
return
endif
s1 = piDpj(kn,in)*piDpj(ln,jn)
s2 = piDpj(ln,in)*piDpj(kn,jn)
delps = s1 - s2
if ( abs(delps) .ge. xloss*abs(s1) ) goto 20
som = delps
smax = abs(s1)
s1 = piDpj(kn,in)*piDpj(lkn,jn)
s2 = piDpj(lkn,in)*piDpj(kn,jn)
delps = iss*islk*(s1 - s2)
if ( abs(delps) .ge. xloss*abs(s1) ) goto 20
if ( abs(s1) .lt. smax ) then
som = delps
smax = abs(s1)
endif
s1 = piDpj(lkn,in)*piDpj(ln,jn)
s2 = piDpj(ln,in)*piDpj(lkn,jn)
delps = islk*(- s1 + s2)
if ( abs(delps) .ge. xloss*abs(s1) ) goto 20
if ( abs(s1) .lt. smax ) then
som = delps
smax = abs(s1)
endif
*
* give up
*
delps = som
20 continue
* #] calculations:
*###] ffdl2t:
end
*###[ ffdl3m:
subroutine ffdl3m(del3mi,ldel,del3,del2,xpi,dpipj,piDpj,ns,ip1n,
+ ip2n,ip3n,is,itime)
***#[*comment:***********************************************************
* *
* Calculate xpi(i)*del2 - del3(piDpj) *
* *
* / si mu \2 (This appears to be one of the harder *
* = | d | determinants to calculate accurately. *
* \ p1 p2 / Note that we allow a loss of xloss^2) *
* *
* Input: ldel iff .true. del2 and del3 exist *
* del3 \delta^{s(1),p1,p2}_{s(1),p1,p2} *
* del2 \delta^{p1,p2}_{p1,p2} *
* xpi(ns) standard *
* dpipj(ns,ns) standard *
* piDpj(ns,ns) standard *
* ipi pi = xpi(abs(ipi)) [p3=-p1 +/-p2] *
* is si = xpi(is,is+1,..,is+itime-1) *
* itime number of functions to calculate *
* *
* Output: del3mi(3) (\delta^{s_i \mu}_{p_1 p_2})^2 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ns,ip1n,ip2n,ip3n,is,itime
logical ldel
DOUBLE PRECISION del3mi(itime),del3,del2,xpi(ns),dpipj(ns,ns),
+ piDpj(ns,ns)
*
* local variables:
*
DOUBLE PRECISION s(7),som,smax,xsom,xmax
integer i,j,k,ip1,ip2,ip3,ipn,is1,is2,isi,is3,ihlp,iqn,
+ jsgn1,jsgn2,jsgn3,jsgnn,iadj(10,10,3:4),init,nm
save iadj,init
logical lmax,ltwist
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data iadj /200*0/
data init /0/
* #] declarations:
* #[ initialisations:
if ( init .eq. 0 ) then
init = 1
*
* Fill the array with adjacent values: if
* x = iadj(i,j)
* k = abs(mod(k,100))
* jsgnk = sign(x)
* jsgnj = 1-2*theta(x-100) (ie -1 iff |x|>100)
* then
* pi(k) = jsgnk*( p(i) - jsgnj*pi(j) )
*
do 5 nm=3,4
do 4 i=1,nm
is1 = i
is2 = i+1
if ( is2 .gt. nm ) is2 = 1
is3 = i-1
if ( is3 .eq. 0 ) is3 = nm
ip1 = is1 + nm
iadj(is1,is2,nm) = -ip1
iadj(is2,is1,nm) = ip1
iadj(ip1,is2,nm) = -is1
iadj(is2,ip1,nm) = is1
iadj(is1,ip1,nm) = 100+is2
iadj(ip1,is1,nm) = 100+is2
if ( nm .eq. 3 ) then
iadj(ip1,is2+3,3) = -100-is3-3
iadj(is2+3,ip1,3) = -100-is3-3
endif
4 continue
5 continue
iadj(3,1,4) = -9
iadj(1,3,4) = 9
iadj(9,1,4) = -3
iadj(1,9,4) = 3
iadj(3,9,4) = 100+1
iadj(9,3,4) = 100+1
iadj(2,4,4) = -10
iadj(4,2,4) = 10
iadj(10,4,4) = -2
iadj(4,10,4) = 2
iadj(2,10,4) = 100+4
iadj(10,2,4) = 100+4
endif
if ( ns .eq. 6 ) then
nm = 3
else
nm = 4
endif
* #] initialisations:
* #[ easy tries:
do 40 i=1,itime
isi = i+is-1
lmax = .FALSE.
*
* get xpi(isi)*del2 - del3 ... if del3 and del2 are defined
*
if ( ldel ) then
s(1) = xpi(isi)*del2
som = s(1) - del3
smax = abs(s(1))
if ( abs(som) .ge. xloss**2*smax ) goto 35
xsom = som
xmax = smax
lmax = .TRUE.
endif
ip1 = ip1n
ip2 = ip2n
ip3 = ip3n
do 20 j=1,3
*
* otherwise use the simple threeterm formula
*
s(1) = xpi(ip2)*piDpj(ip1,isi)**2
s(2) = xpi(ip1)*piDpj(ip2,isi)*piDpj(ip2,isi)
s(3) = -2*piDpj(ip2,isi)*piDpj(ip2,ip1)*piDpj(ip1,isi)
som = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( abs(som) .ge. xloss**2*smax ) goto 35
if ( .not. lmax .or. smax .lt. xmax ) then
xsom = som
xmax = smax
lmax = .TRUE.
endif
*
* if there are cancellations between two of the terms:
* we try mixing with isi.
*
* First map cancellation to s(2)+s(3) (do not mess up
* rotations...)
*
if ( abs(s(1)+s(3)) .lt. abs(s(3))/2 ) then
ihlp = ip1
ip1 = ip2
ip2 = ihlp
som = s(1)
s(1) = s(2)
s(2) = som
ltwist = .TRUE.
else
ltwist = .FALSE.
endif
if ( abs(s(2)+s(3)) .lt. abs(s(3))/2 ) then
*
* switch to the vector pn so that si = jsgn1*p1 + jsgnn*pn
*
k = iadj(isi,ip1,nm)
if ( k .ne. 0 ) then
ipn = abs(k)
jsgnn = isign(1,k)
if ( ipn .gt. 100 ) then
ipn = ipn - 100
jsgn1 = -1
else
jsgn1 = +1
endif
if (abs(dpipj(ipn,isi)).lt.xloss*abs(piDpj(ip1,isi))
+ .and.
+ abs(piDpj(ipn,ip2)).lt.xloss*abs(piDpj(ip2,isi))
+ ) then
* same: s(1) = xpi(ip2)*piDpj(ip1,isi)**2
s(2) = jsgnn*piDpj(isi,ip2)*piDpj(ipn,ip2)*
+ xpi(ip1)
s(3) = jsgn1*piDpj(isi,ip2)*piDpj(ip1,ip2)*
+ dpipj(ipn,isi)
som = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( abs(som) .ge. xloss**2*smax ) goto 35
if ( smax .lt. xmax ) then
xsom = som
xmax = smax
endif
*
* there may be a cancellation between s(1) and
* s(2) left. Introduce a vector q such that
* pn = jsgnq*q + jsgn2*p2. We also need the sign
* jsgn3 in p3 = -p1 - jsgn3*p2
*
k = iadj(ipn,ip2,nm)
if ( k .ne. 0 ) then
iqn = abs(k)
if ( iqn .gt. 100 ) then
iqn = iqn - 100
jsgn2 = -1
else
jsgn2 = +1
endif
k = iadj(ip1,ip2,nm)
if ( k .eq. 0 .or. k .lt. 100 ) then
* we have p1,p2,p3 all p's
jsgn3 = +1
elseif ( k .lt. 0 ) then
* ip1,ip2 are 2*s,1*p such that p2-p1=ip3
jsgn3 = -1
else
jsgn3 = 0
endif
* we need one condition on the signs for this
* to work
if ( ip3.ne.0 .and. jsgn1*jsgn2.eq.jsgnn*
+ jsgn3 .and. abs(s(3)).lt.xloss*smax ) then
s(1) = piDpj(ip1,isi)**2*dpipj(iqn,ipn)
s(2) = -jsgn2*jsgn1*piDpj(ipn,ip2)*
+ piDpj(ip1,isi)*dpipj(ipn,isi)
* s(3) stays the same
s(4) = -jsgn2*jsgn1*piDpj(ipn,ip2)*
+ xpi(ip1)*piDpj(isi,ip3)
som = s(1) + s(2) + s(3) + s(4)
smax =max(abs(s(1)),abs(s(2)),abs(s(3)),
+ abs(s(4)))
if ( abs(som).ge.xloss**2*smax ) goto 35
if ( smax .lt. xmax ) then
xsom = som
xmax = smax
endif
endif
endif
endif
endif
k = iadj(isi,ip2,nm)
if ( k .ne. 0 ) then
ipn = abs(k)
jsgnn = isign(1,k)
if ( ipn .gt. 100 ) then
jsgn1 = -1
ipn = ipn - 100
else
jsgn1 = +1
endif
if (abs(dpipj(ipn,isi)).lt.xloss*abs(piDpj(ip2,isi))
+ .and.
+ abs(piDpj(ipn,ip1)).lt.xloss*abs(piDpj(ip1,isi))
+ ) then
s(1) = jsgnn*piDpj(isi,ip1)*piDpj(ipn,ip1)*
+ xpi(ip2)
s(2) = xpi(ip1)*piDpj(ip2,isi)**2
s(3) = jsgn1*piDpj(isi,ip1)*piDpj(ip2,ip1)*
+ dpipj(ipn,isi)
som = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
print *,' (isi+ip2) with isi,ip1,ip2,ipn: ',
+ isi,ip1,ip2,ipn
if ( abs(som) .ge. xloss**2*smax ) goto 35
if ( smax .lt. xmax ) then
xsom = som
xmax = smax
endif
endif
endif
endif
*
* rotate the ipi
*
if ( ip3 .eq. 0 ) goto 30
if ( j .ne. 3 ) then
if ( .not. ltwist ) then
ihlp = ip1
ip1 = ip2
ip2 = ip3
ip3 = ihlp
else
ihlp = ip2
ip2 = ip3
ip3 = ihlp
endif
endif
20 continue
30 continue
* #] easy tries:
* #[ choose the best value:
*
* These values are the best found:
*
som = xsom
smax = xmax
35 continue
del3mi(i) = som
40 continue
* #] choose the best value:
*###] ffdl3m:
end
diff --git a/Looptools/B/ffxb0.F b/Looptools/B/ffxb0.F
--- a/Looptools/B/ffxb0.F
+++ b/Looptools/B/ffxb0.F
@@ -1,961 +1,964 @@
+#include "externals.h"
+
+
*###[ ffxb0:
subroutine ffxb0(cb0,xp,xma,xmb,ier)
***#[*comment:***********************************************************
* *
* Calculates the the two-point function (cf 't Hooft and Veltman) *
* we include an overall factor 1/(i*pi^2) relative to FormF *
* *
* Input: xp (real) k2, in B&D metric *
* xma (real) mass2 *
* xmb (real) mass2 *
* *
* Output: cb0 (complex) B0, the two-point function, *
* ier (integer) # of digits lost, if >=100: error *
* *
* Calls: ffxb0p *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cb0
DOUBLE PRECISION xp,xma,xmb
*
* local variables
*
DOUBLE COMPLEX cb0p
DOUBLE PRECISION dmamb,dmap,dmbp,xm
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ get differences:
dmamb = xma - xmb
dmap = xma - xp
dmbp = xmb - xp
* #] get differences:
* #[ calculations:
call ffxb0p(cb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
if ( xma .eq. 0 ) then
if ( xmb .eq. 0 ) then
xm = 1D0
else
xm = xmb**2
endif
elseif ( xmb .eq. 0 ) then
xm = xma**2
else
xm = xma*xmb
endif
if ( mudim .ne. 0 ) xm = xm/mudim**2
if ( abs(xm) .gt. xalogm ) then
cb0 = DBLE(delta - log(xm)/2D0) - cb0p
else
call fferr(4,ier)
cb0 = DBLE(delta) - cb0p
endif
* #] calculations:
*###] ffxb0:
end
*###[ ffxb0p:
subroutine ffxb0p(cb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
***#[*comment:***********************************************************
* *
* calculates the two-point function (see 't Hooft and *
* Veltman) for all possible cases: masses equal, unequal, *
* equal to zero. *
* *
* Input: xp (real) p.p, in B&D metric *
* xma (real) mass2, *
* xmb (real) mass2, *
* dm[ab]p (real) xm[ab] - xp *
* dmamb (real) xma - xmb *
* *
* Output: cb0p (complex) B0, the two-point function, minus *
* log(xm1*xm2)/2, delta and ipi^2 *
* ier (integer) 0=ok, 1=numerical problems, 2=error *
* *
* Calls: ffxb0q. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cb0p
DOUBLE PRECISION xp,xma,xmb,dmap,dmbp,dmamb
*
* local variables
*
integer i,initeq,initn1,jsign
DOUBLE PRECISION ax,ay,ffbnd,
+ xprceq,bdeq01,bdeq05,bdeq11,bdeq17,
+ xprcn1,bdn101,bdn105,bdn110,bdn115,
+ xprnn2,bdn205,bdn210,bdn215,bdn220,
+ xprcn3,bdn301,bdn305,bdn310,bdn315,
+ xprcn5,bdn501,bdn505,bdn510,bdn515,
+ absc
DOUBLE PRECISION xm,dmp,xm1,xm2,dm1m2,dm1p,
+ dm2p,s,s1,s1a,s1b,s1p,s2,s2a,s2b,s2p,x,y,som,
+ xlam,slam,xlogmm,alpha,alph1,xnoe,xpneq(30),
+ xpnn1(30),xx,xtel,dfflo1
DOUBLE COMPLEX cs2a,cs2b,cs2p,c,cx
external ffbnd,dfflo1
save initeq,initn1,xpneq,xpnn1,
+ xprceq,bdeq01,bdeq05,bdeq11,bdeq17,
+ xprcn1,bdn101,bdn105,bdn110,bdn115,
+ xprnn2,bdn205,bdn210,bdn215,bdn220,
+ xprcn3,bdn301,bdn305,bdn310,bdn315,
+ xprcn5,bdn501,bdn505,bdn510,bdn515
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data xprceq /-1D0/
data xprcn1 /-1D0/
data xprnn2 /-1D0/
data xprcn3 /-1D0/
data xprcn5 /-1D0/
data initeq /0/
data initn1 /0/
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ fill some dotproducts:
if ( ldot ) then
call ffdot2(fpij2,xp,xma,xmb,dmap,dmbp,dmamb,ier)
endif
* #] fill some dotproducts:
* #[ which case:
*
* sort according to the type of masscombination encountered:
* 100: both masses zero, 200: one equal to zero, 300: both equal
* 400: rest.
*
if ( xma .eq. 0 ) then
if ( xmb .eq. 0 ) then
goto 100
endif
xm = xmb
dmp = dmbp
goto 200
endif
if ( xmb .eq. 0 ) then
xm = xma
dmp = dmap
goto 200
elseif ( dmamb .eq. 0 ) then
xm = xma
dmp = dmap
goto 300
elseif ( xma .gt. xmb ) then
xm2 = xma
xm1 = xmb
dm1m2 = -dmamb
dm1p = dmbp
dm2p = dmap
else
xm1 = xma
xm2 = xmb
dm1m2 = dmamb
dm1p = dmap
dm2p = dmbp
endif
goto 400
* #] which case:
* #[ both masses equal to zero:
100 continue
if ( xp .lt. -xalogm ) then
cb0p = log(-xp) - 2
elseif ( xp .gt. xalogm ) then
cb0p = DCMPLX( DBLE(log(xp) - 2), DBLE(-pi) )
else
cb0p = 0
call fferr(7,ier)
endif
return
* #] both masses equal to zero:
* #[ one mass equal to zero:
200 continue
*
* special case xp = 0
*
if ( xp .eq. 0 ) then
cb0p = -1
goto 990
*
* special case xp = xm
*
elseif ( dmp.eq.0 ) then
cb0p = -2
goto 990
endif
*
* Normal case:
*
s1 = xp/xm
if ( abs(s1) .lt. xloss ) then
s = dfflo1(s1,ier)
else
s = log(abs(dmp/xm))
endif
s = -s*dmp/xp
cb0p = s - 2
if ( xp .gt. xm )
+ cb0p = cb0p - DCMPLX(0D0,-(dmp/xp)*pi)
goto 990
* #] one mass equal to zero:
* #[ both masses equal:
300 continue
*
* Both masses are equal. Not only this speeds up things, some
* cancellations have to be avoided as well.
*
* first a special case
*
if ( abs(xp) .lt. 8*xloss*xm ) then
* -#[ taylor expansion:
*
* a Taylor expansion seems appropriate as the result will go
* as k^2 but seems to go as 1/k !!
*
*--#[ data and bounds:
if ( initeq .eq. 0 ) then
initeq = 1
xpneq(1) = 1D0/6D0
do 1 i=2,30
xpneq(i) = - xpneq(i-1)*DBLE(i-1)/DBLE(2*(2*i+1))
1 continue
endif
if (xprceq .ne. precx ) then
*
* calculate the boundaries for the number of terms to be
* included in the taylorexpansion
*
xprceq = precx
bdeq01 = ffbnd(1,1,xpneq)
bdeq05 = ffbnd(1,5,xpneq)
bdeq11 = ffbnd(1,11,xpneq)
bdeq17 = ffbnd(1,17,xpneq)
endif
*--#] data and bounds:
x = -xp/xm
ax = abs(x)
if ( ax .gt. bdeq17 ) then
som = x*(xpneq(18) + x*(xpneq(19) + x*(xpneq(20) +
+ x*(xpneq(21) + x*(xpneq(22) + x*(xpneq(23) +
+ x*(xpneq(24) + x*xpneq(25) )))))))
else
som = 0
endif
if ( ax .gt. bdeq11 ) then
som = x*(xpneq(12) + x*(xpneq(13) + x*(xpneq(14) +
+ x*(xpneq(15) + x*(xpneq(16) + x*(xpneq(17) + som ))))
+ ))
endif
if ( ax .gt. bdeq05 ) then
som = x*(xpneq(6) + x*(xpneq(7) + x*(xpneq(8) + x*(
+ xpneq(9) + x*(xpneq(10) + x*(xpneq(11) + som ))))))
endif
if ( ax .gt. bdeq01 ) then
som = x*(xpneq(2) + x*(xpneq(3) + x*(xpneq(4) + x*(
+ xpneq(5) + som ))))
endif
cb0p = x*(xpneq(1)+som)
goto 990
* -#] taylor expansion:
endif
* -#[ normal case:
*
* normal case
*
call ffxlmb(xlam,-xp,-xm,-xm,dmp,dmp,0D0)
if ( xlam .ge. 0 ) then
* cases 1,2 and 4
slam = sqrt(xlam)
s2a = dmp + xm
s2 = s2a + slam
if ( abs(s2) .gt. xloss*slam ) then
* looks fine
jsign = 1
else
s2 = s2a - slam
jsign = -1
endif
ax = abs(s2/(2*xm))
if ( ax .lt. xalogm ) then
s = 0
elseif( ax-1 .lt. .1 .and. s2 .gt. 0 ) then
* In this case a quicker and more accurate way is to
* calculate log(1-x).
s2 = (xp - slam)
* the following line is superfluous.
s = -slam/xp*dfflo1(s2/(2*xm),ier)
else
* finally the normal case
s = -slam/xp*log(ax)
if ( jsign .eq. -1 ) s = -s
endif
if ( xp .gt. 2*xm ) then
* in this case ( xlam>0, so xp>(2*m)^2) ) there also
* is an imaginary part
y = -pi*slam/xp
else
y = 0
endif
else
* the root is complex (k^2 between 0 and (2*m1)^2)
slam = sqrt(-xlam)
s = 2*slam/xp*atan2(xp,slam)
y = 0
endif
xx = s - 2
cb0p = DCMPLX(DBLE(xx),DBLE(y))
goto 990
* -#] normal case:
*
* #] both masses equal:
* #[ unequal nonzero masses:
* -#[ get log(xm2/xm1):
400 continue
x = xm2/xm1
if ( 1 .lt. xalogm*x ) then
call fferr(8,ier)
xlogmm = 0
elseif ( abs(x-1) .lt. xloss ) then
xlogmm = dfflo1(dm1m2/xm1,ier)
else
xlogmm = log(x)
endif
* -#] get log(xm2/xm1):
* -#[ xp = 0:
*
* first a special case
*
if ( xp .eq. 0 ) then
s2 = ((xm2+xm1) / dm1m2)*xlogmm
s = - s2 - 2
* save the factor 1/2 for the end
if ( abs(s) .lt. xloss*2 ) then
* Taylor expansions: choose which one
x = dm1m2/xm1
ax = abs(x)
if ( ax .lt. .15 .or. precx .gt. 1.E-8 .and. ax
+ .lt. .3 ) then
*
* This is the simple Taylor expansion 'n1'
*
*--#[ data and bounds:
* get the coefficients of the taylor expansion
if ( initn1 .eq. 0 ) then
initn1 = 1
do 410 i = 1,30
410 xpnn1(i) = DBLE(i)/DBLE((i+1)*(i+2))
endif
* determine the boundaries for 1,5,10,15 terms
if ( xprcn1 .ne. precx ) then
xprcn1 = precx
bdn101 = ffbnd(1,1,xpnn1)
bdn105 = ffbnd(1,5,xpnn1)
bdn110 = ffbnd(1,10,xpnn1)
bdn115 = ffbnd(1,15,xpnn1)
endif
*--#] data and bounds:
* calculate:
if ( ax .gt. bdn115 ) then
s = x*(xpnn1(16) + x*(xpnn1(17) + x*(xpnn1(18) +
+ x*(xpnn1(19) + x*xpnn1(20) ))))
else
s = 0
endif
if ( ax .gt. bdn110 ) then
s = x*(xpnn1(11) + x*(xpnn1(12) + x*(xpnn1(13) +
+ x*(xpnn1(14) + x*xpnn1(15) + s))))
endif
if ( ax .gt. bdn105 ) then
s = x*(xpnn1(6) + x*(xpnn1(7) + x*(xpnn1(8) + x*
+ (xpnn1(9) + x*(xpnn1(10) + s)))))
endif
if ( ax .gt. bdn101 ) then
s = x*(xpnn1(2) + x*(xpnn1(3) + x*(xpnn1(4) + x*
+ (xpnn1(5) +s))))
endif
s = x*x*(xpnn1(1) + s)
else
*
* This is the more complicated Taylor expansion 'fc'
*
* #[ bounds:
* determine the boundaries for 1,5,10,15 terms for
* the exponential taylor expansion, assuming it
* starts at n=2.
*
if ( xprnn2 .ne. precx ) then
xprnn2 = precx
bdn205 = ffbnd(4,5,xinfac)
bdn210 = ffbnd(4,10,xinfac)
bdn215 = ffbnd(4,15,xinfac)
bdn220 = ffbnd(4,20,xinfac)
endif
* #] bounds:
* calculate:
y = 2*x/(2-x)
ay = abs(y)
if ( ay .gt. bdn220 ) then
s = y*(xinfac(19) + y*(xinfac(20) + y*(xinfac(
+ 21) + y*(xinfac(22) + y*xinfac(
+ 23) ))))
else
s = 0
endif
if ( ay .gt. bdn215 ) then
s = y*(xinfac(14) + y*(xinfac(15) + y*(xinfac(
+ 16) + y*(xinfac(17) + y*(xinfac(
+ 18) + s)))))
endif
if ( ay .gt. bdn210 ) then
s = y*(xinfac(9) + y*(xinfac(10) + y*(xinfac(11)
+ + y*(xinfac(12) + y*(xinfac(13) + s)))))
endif
if ( ay .gt. bdn205 ) then
s = y*(xinfac(5) + y*(xinfac(6) + y*(xinfac(7) +
+ y*(xinfac(8) + s))))
endif
s = (1-x)*y**4*(xinfac(4)+s)
s = x*y**2*(1+y)/12 - s
s = - 2*dfflo1(s,ier)/y
endif
endif
cb0p = s/2
goto 990
endif
* -#] xp = 0:
* -#[ normal case:
*
* proceeding with the normal case
*
call ffxlmb(xlam,-xp,-xm2,-xm1,dm2p,dm1p,dm1m2)
if ( xlam .gt. 0 ) then
* cases k^2 < -(m2+m1)^2 or k^2 > -(m2-m1)^2:
*--#[ first try:
* first try the normal way
slam = sqrt(xlam)
s2a = dm2p + xm1
s2 = s2a + slam
if ( abs(s2) .gt. xloss*slam ) then
* looks fine
jsign = 1
else
s2 = s2a - slam
jsign = -1
endif
s2 = s2**2/(4*xm1*xm2)
if ( abs(s2) .lt. xalogm ) then
call fferr(9,ier)
s2 = 0
elseif ( abs(s2-1) .lt. xloss ) then
if ( jsign.eq.1 ) then
s2 = -slam*(s2a+slam)/(2*xm1*xm2)
s2 = -slam/(2*xp)*dfflo1(s2,ier)
else
s2 = +slam*(s2a-slam)/(2*xm1*xm2)
s2 = +slam/(2*xp)*dfflo1(s2,ier)
endif
else
s2 = -slam/(2*xp)*log(s2)
if ( jsign .eq. -1 ) s2 = -s2
endif
s1 = -dm1m2*xlogmm/(2*xp)
xx = s1+s2-2
*--#] first try:
if ( abs(xx) .lt. xloss*max(abs(s1),abs(s2)) ) then
*--#[ second try:
* this is unacceptable, try a better solution
s1a = dm1m2 + slam
if ( abs(s1a) .gt. xloss*slam ) then
* (strangely) this works
s1 = -s1a/(2*xp)
else
* by division a more accurate form can be found
s1 = ( -xp/2 + xm1 + xm2 ) / ( slam - dm1m2 )
endif
s1 = s1*xlogmm
if ( abs(xp) .lt. xm2 ) then
s2a = xp - dm1m2
else
s2a = xm2 - dm1p
endif
s2 = s2a - slam
if ( abs(s2) .gt. xloss*slam ) then
* at least reasonable
s2 = s2 / (2*xm2)
else
* division again
s2 = (2*xp) / (s2a+slam)
endif
if ( abs(s2) .lt. .1 ) then
* choose a quick way to get the logarithm
s2 = dfflo1(s2,ier)
else
s2a = abs(1-s2)
s2 = log(s2a)
endif
s2 = -(slam/xp)*s2
xx = s1 + s2 - 2
*--#] second try:
if ( abs(xx) .lt. xloss**2*max(abs(s1),abs(s2)) ) then
*--#[ third try:
* (we accept two times xloss because that's the same
* as in this try)
* A Taylor expansion might work. We expand
* inside the logs. Only do the necessary work.
*
alpha = slam/(slam-dm1m2)
alph1 = -dm1m2/(slam-dm1m2)
*
* First s1:
*
s1p = s1 - 2*alph1
if ( abs(s1p) .lt. xloss*abs(s1) ) then
* -#[ bounds:
* determine the boundaries for 1,5,10,15 terms
if ( xprcn3 .ne. precx ) then
xprcn3 = precx
bdn301 = ffbnd(3,1,xinfac)
bdn305 = ffbnd(3,5,xinfac)
bdn310 = ffbnd(3,10,xinfac)
bdn315 = ffbnd(3,15,xinfac)
endif
* -#] bounds:
xnoe = -xp + 2*xm1 + 2*xm2
x = 4*dm1m2/xnoe
ax = abs(x)
if ( ax .gt. bdn310 ) then
s1a = x*(xinfac(13) + x*(xinfac(14) + x*(
+ xinfac(15) + x*(xinfac(16) + x*
+ xinfac(17) ))))
else
s1a = 0
endif
if ( ax .gt. bdn305 ) then
s1a = x*(xinfac(8) + x*(xinfac(9) + x*(
+ xinfac(10) + x*(xinfac(11) + x*(
+ xinfac(12) + s1a)))))
endif
if ( ax .gt. bdn301 ) then
s1a = x*(xinfac(4) + x*(xinfac(5) + x*(
+ xinfac(6) + x*(xinfac(7) + s1a))))
endif
s1a = x**3 *(xinfac(3) + s1a) *xm2/xm1
s1b = dm1m2*(4*dm1m2**2 - xp*(4*xm1-xp))/
+ (xm1*xnoe**2)
s1p = s1b - s1a
s1p = xnoe*dfflo1(s1p,ier)/(slam - dm1m2)/2
endif
*
* next s2:
*
- 490 s2p = s2 - 2*alpha
+ s2p = s2 - 2*alpha
if ( abs(s2p) .lt. xloss*abs(s2) ) then
* -#[ bounds:
* determine the boundaries for 1,5,10,15 terms
if ( xprcn5 .ne. precx ) then
xprcn5 = precx
bdn501 = ffbnd(4,1,xinfac)
bdn505 = ffbnd(4,5,xinfac)
bdn510 = ffbnd(4,10,xinfac)
bdn515 = ffbnd(4,15,xinfac)
endif
* -#] bounds:
xnoe = slam - dm1m2
x = 2*xp/xnoe
ax = abs(x)
* do not do the Taylor expansion
if ( ax .gt. bdn515 ) goto 495
if ( ax .gt. bdn510 ) then
s2a = x*(xinfac(14) + x*(xinfac(15) + x*(
+ xinfac(16) + x*(xinfac(17) + x*
+ xinfac(18) ))))
else
s2a = 0
endif
if ( ax .gt. bdn505 ) then
s2a = x*(xinfac(9) + x*(xinfac(10) + x*(
+ xinfac(11) + x*(xinfac(12) + x*(
+ xinfac(13) + s2a)))))
endif
if ( ax .gt. bdn501 ) then
s2a = x*(xinfac(5) + x*(xinfac(6) + x*(
+ xinfac(7) + x*(xinfac(8) + s2a))))
endif
s2a = x**4*(xinfac(4)+s2a)*(1-2*xp/(xnoe+xp))
s2b = -2*xp**3 *(-2*xp - xnoe)/(3*(xnoe+xp)*
+ xnoe**3)
s2p = s2b - s2a
s2p = -slam/xp*dfflo1(s2p,ier)
endif
*
* finally ...
*
495 xx = s1p + s2p
*--#] third try:
endif
endif
if ( xp .gt. xm1+xm2 ) then
*--#[ imaginary part:
* in this case ( xlam>0, so xp>(m1+m2)^2) ) there also
* is an imaginary part
y = -pi*slam/xp
else
y = 0
*--#] imaginary part:
endif
else
* the root is complex (k^2 between -(m1+m2)^2 and -(m2-m1)^2)
*--#[ first try:
slam = sqrt(-xlam)
xnoe = dm2p + xm1
s1 = -(dm1m2/(2*xp))*xlogmm
s2 = (slam/xp)*atan2(slam,xnoe)
xx = s1 + s2 - 2
*--#] first try:
if ( abs(xx) .lt. xloss**2*max(abs(s1),abs(s2)) ) then
*--#[ second try:
* Again two times xloss as we'll accept that in the next
* step as well.
*
xtel = dm1m2**2 - xp**2
alpha = -xlam/(2*xp*xnoe)
alph1 = xtel/(2*xp*xnoe)
*
* try a taylor expansion on the terms. First s1:
*
s1p = s1 - 2*alph1
if ( abs(s1p) .lt. xloss*abs(s1) ) then
* -#[ bounds:
* determine the boundaries for 1,5,10,15 terms
if ( xprcn3 .ne. precx ) then
xprcn3 = precx
bdn301 = ffbnd(3,1,xinfac)
bdn305 = ffbnd(3,5,xinfac)
bdn310 = ffbnd(3,10,xinfac)
bdn315 = ffbnd(3,15,xinfac)
endif
* -#] bounds:
x = 2*xtel/(dm1m2*xnoe)
ax = abs(x)
* do not do the Taylor expansion
if ( ax .gt. bdn315 ) goto 590
if ( ax .gt. bdn310 ) then
s1a = x*(xinfac(13) + x*(xinfac(14) + x*(
+ xinfac(15) + x*(xinfac(16) + x*
+ xinfac(17) ))))
else
s1a = 0
endif
if ( ax .gt. bdn305 ) then
s1a = x*(xinfac(8) + x*(xinfac(9) + x*(
+ xinfac(10) + x*(xinfac(11) + x*(
+ xinfac(12) + s1a)))))
endif
if ( ax .gt. bdn301 ) then
s1a = x*(xinfac(4) + x*(xinfac(5) + x*(
+ xinfac(6) + x*(xinfac(7) + s1a))))
endif
s1a = x**3 *(xinfac(3) + s1a) *xm2/xm1
s1b = (dm1m2**3*(dm1m2**2-2*xp*xm1) + xp**2*(4*
+ dm1m2*xm1**2-dm1m2**2*(dm1m2+2*xm1))-2*xm2*
+ xp**3*(dm1m2+xp))/(xm1*dm1m2**2*xnoe**2)
s1p = s1b - s1a
s1p = -dm1m2*dfflo1(s1p,ier)/(2*xp)
endif
*
* next s2:
*
590 continue
s2p = s2 - 2*alpha
if ( abs(s2p) .lt. xloss*abs(s2) ) then
* -#[ bounds:
* determine the boundaries for 1,5,10,15 terms
if ( xprcn3 .ne. precx ) then
xprcn3 = precx
bdn301 = ffbnd(3,1,xinfac)
bdn305 = ffbnd(3,5,xinfac)
bdn310 = ffbnd(3,10,xinfac)
bdn315 = ffbnd(3,15,xinfac)
endif
* -#] bounds:
cx = DCMPLX(0D0,-slam/xnoe)
ax = absc(cx)
if ( ax .gt. bdn315 ) goto 600
if ( ax .gt. bdn310 ) then
cs2a = cx*(DBLE(xinfac(13)) + cx*(DBLE(xinfac(14
+ )) + cx*(DBLE(xinfac(15)) + cx*(DBLE(xinfac(16
+ )) + cx*(DBLE(xinfac(17)))))))
else
cs2a = 0
endif
if ( ax .gt. bdn305 ) then
cs2a = cx*(DBLE(xinfac(8)) + cx*(DBLE(xinfac(9))
+ + cx*(DBLE(xinfac(10)) + cx*(DBLE(xinfac(11))
+ + cx*(DBLE(xinfac(12)) + cs2a)))))
endif
if ( ax .gt. bdn301 ) then
cs2a = cx*(DBLE(xinfac(4)) + cx*(DBLE(xinfac(5))
+ + cx*(DBLE(xinfac(6)) + cx*(DBLE(xinfac(7))
+ + cs2a))))
endif
cs2a = cx**3*(DBLE(xinfac(3))+cs2a)*
+ DCMPLX(DBLE(xnoe),DBLE(slam))
cs2b = DCMPLX(DBLE(xnoe-xlam/xnoe/2),
+ -DBLE(slam**3/xnoe**2/2))
cs2p = cs2b + cs2a
s2p = slam*atan2(DIMAG(cs2p),DBLE(cs2p))/xp
endif
600 continue
xx = s1p + s2p
*--#] second try:
endif
y = 0
endif
cb0p = DCMPLX(DBLE(xx),DBLE(y))
goto 990
* -#] normal case:
* #] unequal nonzero masses:
* #[ debug:
990 continue
* #] debug:
*###] ffxb0p:
end
*###[ ffxlmb:
subroutine ffxlmb(xlambd,a1,a2,a3,a12,a13,a23)
***#[*comment:***********************************************************
* calculate in a numerically stable way *
* lambda(a1,a2,a3) = *
* a1**2 + a2**2 + a3**2 - 2*a2*a3 - 2*a3*a1 - 2*a1*a2 *
* aij = ai - aj are required for greater accuracy at times *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE PRECISION xlambd,a1,a2,a3,a12,a13,a23
*
* local variables
*
DOUBLE PRECISION aa1,aa2,aa3,a,aff,asq
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ calculations:
aa1 = abs(a1)
aa2 = abs(a2)
aa3 = abs(a3)
*
* first see if there are input parameters with opposite sign:
*
if ( a1 .lt. 0 .and. a2 .gt. 0 .or.
+ a1 .gt. 0 .and. a2 .lt. 0 ) then
goto 12
elseif ( a1 .lt. 0 .and. a3 .gt. 0 .or.
+ a1 .gt. 0 .and. a3 .lt. 0 ) then
goto 13
*
* all have the same sign, choose the smallest 4*ai*aj term
*
elseif ( aa1 .gt. aa2 .and. aa1 .gt. aa3 ) then
goto 23
elseif ( aa2 .gt. aa3 ) then
goto 13
else
goto 12
endif
12 continue
if ( aa1 .gt. aa2 ) then
a = a13 + a2
else
a = a1 + a23
endif
aff = 4*a1*a2
goto 100
13 continue
if ( aa1 .gt. aa3 ) then
a = a12 + a3
else
a = a1 - a23
endif
aff = 4*a1*a3
goto 100
23 continue
if ( aa2 .gt. aa3 ) then
a = a12 - a3
else
a = a13 - a2
endif
aff = 4*a2*a3
100 continue
asq = a**2
xlambd = asq - aff
* #] calculations:
*###] ffxlmb:
end
*###[ ffclmb:
subroutine ffclmb(clambd,cc1,cc2,cc3,cc12,cc13,cc23)
***#[*comment:***********************************************************
* calculate in cc numerically stable way *
* lambda(cc1,cc2,cc3) = *
* cc1**2 + cc2**2 + cc3**2 - 2*cc2*cc3 - 2*cc3*cc1 - 2*cc1*cc2 *
* cij = ci - cj are required for greater accuracy at times *
* ier is the usual error flag. *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX clambd,cc1,cc2,cc3,cc12,cc13,cc23
*
* local variables
*
DOUBLE PRECISION aa1,aa2,aa3,absc
DOUBLE COMPLEX cc,cff,csq,c
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ calculations (rather old style ...):
aa1 = absc(cc1)
aa2 = absc(cc2)
aa3 = absc(cc3)
*
* first see if there are input parameters with opposite sign:
*
if ( DBLE(cc1) .lt. 0 .and. DBLE(cc2) .gt. 0 .or.
+ DBLE(cc1) .gt. 0 .and. DBLE(cc2) .lt. 0 ) then
goto 12
elseif ( DBLE(cc1) .lt. 0 .and. DBLE(cc3) .gt. 0 .or.
+ DBLE(cc1) .gt. 0 .and. DBLE(cc3) .lt. 0 ) then
goto 13
*
* all have the same sign, choose the smallest 4*ci*cj term
*
elseif ( aa1 .gt. aa2 .and. aa1 .gt. aa3 ) then
goto 23
elseif ( aa2 .gt. aa3 ) then
goto 13
else
goto 12
endif
12 continue
if ( aa1 .gt. aa2 ) then
cc = cc13 + cc2
else
cc = cc1 + cc23
endif
cff = 4*cc1*cc2
goto 100
13 continue
if ( aa1 .gt. aa3 ) then
cc = cc12 + cc3
else
cc = cc1 - cc23
endif
cff = 4*cc1*cc3
goto 100
23 continue
if ( aa2 .gt. aa3 ) then
cc = cc12 - cc3
else
cc = cc13 - cc2
endif
cff = 4*cc2*cc3
100 continue
csq = cc**2
clambd = csq - cff
* #] calculations (rather old style ...):
*###] ffclmb:
end
*###[ ffdot2:
subroutine ffdot2(piDpj,xp,xma,xmb,dmap,dmbp,dmamb,ier)
***#[*comment:***********************************************************
* *
* Store the 3 dotproducts in the common block ffdot. *
* *
* Input: see ffxb0p *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE PRECISION piDpj(3,3),xp,xma,xmb,dmap,dmbp,dmamb
*
* local variables
*
integer ier1
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
* absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ work:
ier1 = ier
piDpj(1,1) = xma
piDpj(2,2) = xmb
piDpj(3,3) = xp
if ( abs(dmap) .lt. abs(dmbp) ) then
piDpj(1,2) = (dmap + xmb)/2
else
piDpj(1,2) = (dmbp + xma)/2
endif
piDpj(2,1) = piDpj(1,2)
if ( abs(dmamb) .lt. abs(dmbp) ) then
piDpj(1,3) = (-dmamb - xp)/2
else
piDpj(1,3) = (dmbp - xma)/2
endif
piDpj(3,1) = piDpj(1,3)
if ( abs(dmamb) .lt. abs(dmap) ) then
piDpj(2,3) = (-dmamb + xp)/2
else
piDpj(2,3) = (-dmap + xmb)/2
endif
piDpj(3,2) = piDpj(2,3)
ier = ier1
* #] work:
*###] ffdot2:
end
diff --git a/Looptools/B/ffxb1.F b/Looptools/B/ffxb1.F
--- a/Looptools/B/ffxb1.F
+++ b/Looptools/B/ffxb1.F
@@ -1,278 +1,281 @@
+#include "externals.h"
+
+
*###[ ffxb1:
subroutine ffxb1(cb1,cb0,ca0i,xp,xm1,xm2,piDpj,ier)
***#[*comment:***********************************************************
* *
* Calculate 1 / d^n Q Q(mu) *
* ------ | ------------------------ = B1*p(mu) *
* i pi^2 / (Q^2-m1^2)((Q+p)^2-m2^2) *
* *
* Input: cb0 complex scalar twopoint function *
* ca0i(2) complex scalar onepoint function with *
* m1,m2 *
* xp real p.p in B&D metric *
* xm1,2 real m_1^2,m_2^2 *
* piDpj(3,3) real dotproducts between s1,s2,p *
* ier integer digits lost so far *
* Output: cb1 complex B1 *
* ier integer digits lost *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE PRECISION xp,xm1,xm2,piDpj(3,3)
DOUBLE COMPLEX cb1,cb0,ca0i(2)
*
* local variables
*
DOUBLE PRECISION dm1m2
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ get differences:
dm1m2 = xm1 - xm2
* #] get differences:
* #[ call ffxb1a:
call ffxb1a(cb1,cb0,ca0i,xp,xm1,xm2,dm1m2,piDpj,ier)
* #] call ffxb1a:
*###] ffxb1:
end
*###[ ffxb1a:
subroutine ffxb1a(cb1,cb0,ca0i,xp,xm1,xm2,dm1m2,piDpj,ier)
***#[*comment:***********************************************************
* *
* Calculate 1 / d^n Q Q(mu) *
* ------ | ------------------------ = B1*p(mu) *
* i pi^2 / (Q^2-m1^2)((Q+p)^2-m2^2) *
* *
* Input: cb0 complex scalar twopoint function *
* ca0i(2) complex scalar onepoint function with *
* m1,m2 *
* xp real p.p in B&D metric *
* xm1,2 real m_1^2,m_2^2 *
* piDpj(3,3) real dotproducts between s1,s2,p *
* ier integer digits lost so far *
* Output: cb1 complex B1 *
* ier integer digits lost *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE PRECISION xp,xm1,xm2,dm1m2,piDpj(3,3)
DOUBLE COMPLEX cb1,cb0,ca0i(2)
*
* local variables
*
logical lneg
DOUBLE PRECISION xmax,absc,s,s1,h,slam,bnd101,bnd105,bnd110,
+ xma,xmb,x,ax,xlogm,small,dmbma,xprec,xlam,ts2Dp,
+ xmxp,xlo3,dfflo3
DOUBLE COMPLEX cs(5),cc,csom
DOUBLE PRECISION ffbnd,dfflo1
external ffbnd,dfflo1,dfflo3
save xprec,bnd101,bnd105,bnd110
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
* data
*
data xprec /0D0/
*
* #] declarations:
* #[ p^2 != 0:
if ( xp .ne. 0 ) then
* #[ normal case:
if ( dm1m2 .ne. 0 ) then
cs(1) = -ca0i(2)
cs(2) = +ca0i(1)
else
cs(1) = 0
cs(2) = 0
endif
cs(3) = +DBLE(2*piDpj(1,3))*cb0
cb1 = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb1) .ge. xloss*xmax ) goto 110
* #] normal case:
* #[ almost equal masses:
if ( abs(dm1m2) .le. xloss*xm1 ) then
cs(2) = DBLE(dm1m2/xm1)*cs(2)
cs(1) = -xm2*dfflo1(-dm1m2/xm2,ier)
cb1 = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb1) .ge. xloss*xmax ) goto 110
* for the perfectionist (not me (today)):
* if d0=0 and mu~m1(~m2), then the terms of order
* (m1^2-m2^2) also cancel. To patch this I need d0 and mu
endif
* #] almost equal masses:
* #[ p2 -> 0:
if ( xloss**2*max(xm1,xm2) .gt. abs(xp) ) then
if ( xm2.gt.xm1 ) then
xma = xm1
xmb = xm2
ts2Dp = +2*piDpj(2,3)
lneg = .FALSE.
else
xma = xm2
xmb = xm1
ts2Dp = -2*piDpj(1,3)
lneg = .TRUE.
endif
else
goto 100
endif
*
* We found a situation in which p2 is much smaller than
* the masses.
*
dmbma = abs(dm1m2)
if ( xma.eq.0 ) then
xlogm = 1
elseif ( dmbma .gt. xloss*xmb ) then
xlogm = log(xmb/xma)
else
xlogm = dfflo1(-dmbma/xma,ier)
endif
xlam = (dmbma-xp)**2 - 4*xma*xp
if ( xlam.gt.0 ) then
* #[ real roots:
slam = sqrt(xlam)
small = xp*(-2*(xma+xmb) + xp)/(slam+dmbma)
h = slam+2*piDpj(1,2)
cs(1) = xlogm*xma*(4*xmb*(small-xp) + (small-xp)**2)/(2*
+ (slam+dmbma)*h)
if ( xprec.ne.precx ) then
xprec = precx
bnd101 = ffbnd(2,1,xinfac)
bnd105 = ffbnd(2,5,xinfac)
bnd110 = ffbnd(2,10,xinfac)
endif
x = xp/slam
ax = abs(x)
if ( ax.gt.bnd110 ) then
s = x*(xinfac(12) + x*(xinfac(13) + x*(xinfac(14) +
+ x*(xinfac(15) + x*xinfac(16) ))))
else
s = 0
endif
if ( ax.gt.bnd105 ) then
s = x*(xinfac(7) + x*(xinfac(8) + x*(xinfac(9) +
+ x*(xinfac(10) + x*(xinfac(11) + s )))))
endif
if ( ax.gt.bnd101) then
s = x*(xinfac(3) + x*(xinfac(4) + x*(xinfac(5) +
+ x*(xinfac(6) + s ))))
endif
s = x**2*(.5D0 + s)
h = ts2Dp + slam
s1 = 2*xp/h*(s + x)
h = -4*xp**2*xmb/(slam*h**2) - s + s1
if ( abs(h) .lt. .1 ) then
cs(2) = dmbma*slam/xp*dfflo1(h,ier)
else
goto 100
endif
if ( lneg ) then
cs(1) = -cs(1)
cs(2) = -cs(2)
endif
cs(3) = -DBLE(xp)*cb0
cb1 = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb1) .gt. xloss*xmax) goto 110
*
* this still occurs in the case xp << dmamb << xma,
* with a cancellation of order dmamb/xma between cs1 and
* cs2; as the standard model does not contain these kind
* of doublets I leave this as an exercise for the
* reader...
*
* #] real roots:
else
* #[ imaginary roots:
* #] imaginary roots:
endif
* #] p2 -> 0:
* #[ give up:
*
* give up...
*
100 continue
110 continue
* #] give up:
cb1 = cb1*(1/DBLE(2*xp))
* #] p^2 != 0:
* #[ p^2=0, m1 != m2:
elseif ( dm1m2 .ne. 0 ) then
cs(1) = +DBLE(xm2/(2*dm1m2**2))*(ca0i(2)+DBLE(xm2)/2)
cs(2) = -DBLE(xm1/(2*dm1m2**2))*(ca0i(1)+DBLE(xm1)/2)
cs(3) = +ca0i(2)*(1/DBLE(dm1m2))
cb1 = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)))
if ( absc(cb1).ge.xloss**2*xmax ) goto 120
*
* m1 ~ m2, see b21.frm
*
if ( abs(dm1m2).lt.xloss*xm1 ) then
xlogm = dfflo1(dm1m2/xm1,ier)
else
xlogm = log(xm2/xm1)
endif
cs(1) = -(xm1/dm1m2)/2
cs(2) = -xlogm/2*(xm1/dm1m2)**2
cs(3) = +1/DBLE(4) - ca0i(1)*DBLE(1/(2*xm1))
cs(4) = xlogm/2
csom = cs(1) + cs(2) + cs(3) + cs(4)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb1 = csom
if ( absc(cb1).gt.xloss**2*xmax ) goto 120
endif
*
* better
*
xlo3 = dfflo3(dm1m2/xm1,ier)
cs(1) = -(dm1m2/xm1)**2/4
cs(2) = -(dm1m2/xm1)/2
cs(3) = -xlo3/(dm1m2/xm1)**2/2
cs(4) = xlo3/2
cs(5) = 1/DBLE(2) - ca0i(1)*DBLE(1/(2*xm1))
csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb1 = csom
if ( absc(cb1).gt.xloss**2*xmax ) goto 120
endif
*
* give up
*
120 continue
* #] p^2=0, m1 != m2:
* #[ p^2=0, m1 == m2:
else
cb1 = -cb0/2
endif
* #] p^2=0, m1 == m2:
*###] ffxb1a:
end
diff --git a/Looptools/B/ffxb2p.F b/Looptools/B/ffxb2p.F
--- a/Looptools/B/ffxb2p.F
+++ b/Looptools/B/ffxb2p.F
@@ -1,409 +1,412 @@
+#include "externals.h"
+
+
*###[ ffxb2p:
subroutine ffxb2p(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,piDpj,ier)
***#[*comment:***********************************************************
* *
* Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu) *
* of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2) *
* originally based on aaxbx by Andre Aeppli. *
* *
* Input: cb1 complex vector two point function *
* cb0 complex scalar two point function *
* ca0i(2) complex scalar onepoint function with *
* m1,m2 *
* xp real p.p in B&D metric *
* xm1,2 real m_1^2,m_2^2 *
* piDpj(3,3) real dotproducts between s1,s2,p *
* ier integer digits lost so far *
* *
* Output: cb2i(2) complex B21,B22: coeffs of p*p, g in B2 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE PRECISION xp,xm1,xm2,piDpj(3,3)
DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
*
* local variables
*
DOUBLE PRECISION dm1m2
*
* #] declarations:
* #[ work:
*
dm1m2= xm1 - xm2
call ffxb2q(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,dm1m2,piDpj,ier)
*
* #] work:
*###] ffxb2p:
end
*###[ ffxb2q:
subroutine ffxb2q(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,dm1m2,piDpj,ier)
***#[*comment:***********************************************************
* *
* Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu) *
* of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2) *
* originally based on aaxbx by Andre Aeppli. *
* *
* Input: cb1 complex vector two point function *
* cb0 complex scalar two point function *
* ca0i(2) complex scalar onepoint function with *
* m1,m2 *
* xp real p.p in B&D metric *
* xm1,2 real m_1^2,m_2^2 *
* piDpj(3,3) real dotproducts between s1,s2,p *
* ier integer digits lost so far *
* *
* Output: cb2i(2) complex B21,B22: coeffs of p*p, g in B2 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE PRECISION xp,xm1,xm2,dm1m2,piDpj(3,3)
DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
*
* local variables
*
integer i,ier0,ier1
logical llogmm
DOUBLE PRECISION xmax,absc,xlam,slam,bet,xmxp,dfflo3,xlo3,
+ xmxsav,xnoe,xnoe2,xlogmm,dfflo1
DOUBLE COMPLEX cs(16),cc,csom,clo3,zfflo3
external dfflo1,dfflo3,zfflo3
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
* #] declarations:
* #[ normal case:
ier0 = ier
ier1 = ier
*
* with thanks to Andre Aeppli, off whom I stole the original
*
if ( xp .ne. 0) then
cs(1) = ca0i(2)
cs(2) = DBLE(xm1)*cb0
cs(3) = DBLE(2*piDpj(1,3))*cb1
cs(4) = (xm1+xm2)/2
cs(5) = -xp/6
cb2i(1) = cs(1) - cs(2) - cs(4) + 2*cs(3) - cs(5)
cb2i(2) = cs(1) + 2*cs(2) - cs(3) + 2*cs(4) + 2*cs(5)
xmax = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
xmxsav = xmax
if ( absc(cb2i(1)) .ge. xloss*xmax ) goto 100
* #] normal case:
* #[ improve: m1=m2:
*
* a relatively simple case: dm1m2 = 0 (bi0.frm)
*
if ( dm1m2.eq.0 .and. xm1.ne.0 ) then
if ( xp.lt.0 ) then
slam = sqrt(xp**2-4*xm1*xp)
xlo3 = dfflo3((xp-slam)/(2*xm1),ier)
cs(1) = xp*(-1/DBLE(3) + slam/(4*xm1))
cs(2) = xp**2*(-slam/(4*xm1**2) - 3/(4*xm1))
cs(3) = xp**3/(4*xm1**2)
cs(4) = DBLE(xp/xm1)*ca0i(1)
cs(5) = xlo3/xp*(-xm1*slam)
cs(6) = xlo3*slam
else
slam = isgnal*sqrt(-xp**2+4*xm1*xp)
clo3 = zfflo3(DCMPLX(DBLE(xp/(2*xm1)),
+ DBLE(-slam/(2*xm1))),ier)
cs(1) = DBLE(xp)*DCMPLX(-1/DBLE(3),
+ DBLE(slam/(4*xm1)))
cs(2) = DBLE(xp**2)*DCMPLX(DBLE(-3/(4*xm1)),
+ DBLE(-slam/(4*xm1**2)))
cs(3) = DBLE(xp**3/(4*xm1**2))
cs(4) = DBLE(xp/xm1)*ca0i(1)
cs(5) = clo3*DCMPLX(DBLE(0),DBLE(-xm1*slam/xp))
cs(6) = clo3*DCMPLX(DBLE(0),DBLE(slam))
endif
csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) + cs(6)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ absc(cs(5)),absc(cs(6)))
*
* get rid of noise in the imaginary part
*
if ( xloss*abs(DIMAG(csom)).lt.precc*abs(DBLE(csom)) )
+ csom = DCMPLX(DBLE(csom),DBLE(0))
if ( xmxp.lt.xmax ) then
cb2i(1) = csom
xmax = xmxp
endif
if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
endif
* #] improve: m1=m2:
* #[ improve: |xp| < xm1 < xm2:
*
* try again (see bi.frm)
*
xlam = 4*(piDpj(1,3)**2 - xm1*xp)
if ( xm1.eq.0 .or. xm2.eq.0 ) then
xlogmm = 0
elseif ( abs(dm1m2).lt.xloss*xm1 ) then
xlogmm = dfflo1(dm1m2/xm1,ier)
else
xlogmm = log(xm2/xm1)
endif
if ( xlam.gt.0 .and. abs(xp).lt.xloss*xm2 .and.
+ xm1.lt.xm2 ) then
slam = sqrt(xlam)
bet = 4*xm1*xp/(2*piDpj(1,3)+slam)
cs(1) = DBLE(xp/xm2)*ca0i(2)
cs(2) = -xlogmm*bet*xm1**2*2*(xm2 + xm1)
+ /((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
cs(3) = xlogmm*(-4*xp*xm1**3)
+ /((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
xnoe = 1/(2*piDpj(2,3)+slam)
xnoe2 = xnoe**2
cs(4) = xnoe2*xm1*bet*(xp-4*xm2)
cs(5) = xnoe2*xm1*2*xp*xm2
cs(6) = xnoe2*xm1**2*bet
cs(7) = xnoe2*xm1**2*4*xp
cs(8) = xnoe2*bet*xm2*(xp+3*xm2)
cs(9) = xnoe2*(-6*xp*xm2**2)
cs(10)= xp*(7/6.d0 - 2*xm1*slam*xnoe2 +
+ 4*xm2*slam*xnoe2 - 2*slam*xnoe)
cs(11)= xp**2*( -2*slam*xnoe2 )
xlo3 = dfflo3(2*xp*xnoe,ier)
cs(12) = xlo3*dm1m2**2*slam/xp**2
cs(13) = xlo3*(xm1 - 2*xm2)*slam/xp
cs(14) = xlo3*slam
csom = 0
xmxp = 0
do 50 i=1,14
csom = csom + cs(i)
xmxp = max(xmxp,absc(cs(i)))
50 continue
if ( xmxp.lt.xmax ) then
cb2i(1) = csom
xmax = xmxp
endif
cs(7) = -2*bet*xnoe2*xm2*dm1m2
cs(6) = -bet*xm1**2*xlogmm*
& (2*(xm1 + xm2)/(2*piDpj(1,3)+slam) + 1)/
& ((-dm1m2+slam)*(2*piDpj(1,2)+slam))
cs(5) = xnoe2*xp*((xm1 + xm2)*(bet + 4*dm1m2) +
& 2*xm2*(dm1m2 + slam))
cs(4) = xnoe2*(bet*dm1m2**2 -
& 2*xp*slam*(dm1m2 + 1/xnoe + xp))
cs(3) = 7/6D0*xp
xmxp = dm1m2/xp
cs(2) = xlo3*slam*(xmxp*(xmxp + 1) - xm2/xp + 1)
csom = 0
xmxp = 0
do i=7,1,-1
c do i=1,7
csom = csom + cs(i)
xmxp = max(xmxp,absc(cs(i)))
enddo
if ( xmxp.lt.xmax ) then
cb2i(1) = csom
xmax = xmxp
endif
if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
endif
* #] improve: |xp| < xm1 < xm2:
* #[ improve: |xp| < xm2 < xm1:
if ( xlam.gt.0 .and. abs(xp).lt.xloss*xm1 .and.
+ xm2.lt.xm1 ) then
slam = sqrt(xlam)
bet = 4*xm2*xp/(-2*piDpj(2,3)+slam)
xnoe = 1/(-2*piDpj(1,3)+slam)
xnoe2 = xnoe**2
cs(1) = DBLE(xp/xm1)*ca0i(1)
cs(2) = -2*xlogmm*bet*xm2*
+ (3*xp*(2*xm1 + xm2 - xp) - xm2*(xm1 + xm2))/
+ ((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
cs(3) = -4*xlogmm*xm2*xp*
+ (-6*xm1**2-xm2**2+ 3*xp*(3*xm1 + xm2 - xp))/
+ ((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
cs(4) = xnoe2*xm2*bet*(xp-4*xm1)
cs(5) = xnoe2*xm2*(-10*xp*xm1)
cs(6) = xnoe2*xm2**2*bet
cs(7) = xnoe2*xm2**2*4*xp
cs(8) = xnoe2*bet*xm1*(xp+3*xm1)
cs(9) = xnoe2*6*xp*xm1**2
cs(10)= xp*(7/6.d0 - 2*xm1*slam*xnoe2 +
+ 4*xm2*slam*xnoe2 - 2*slam*xnoe)
cs(11)= xp**2*( -2*slam*xnoe2 )
xlo3 = dfflo3(2*xp*xnoe,ier)
cs(12) = xlo3*dm1m2**2*slam/xp**2
cs(13) = xlo3*(xm1 - 2*xm2)*slam/xp
cs(14) = xlo3*slam
csom = 0
xmxp = 0
do 60 i=1,14
csom = csom + cs(i)
xmxp = max(xmxp,absc(cs(i)))
60 continue
if ( xmxp.lt.xmax ) then
cb2i(1) = csom
xmax = xmxp
endif
xmxp = xlogmm*xm2/((dm1m2+slam)*
& (2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
cs(8) = 2*bet*(xnoe2*dm1m2*xm1 + xmxp*(xm1+xm2)*xm2)
cs(7) = 2*xmxp*xp*(13*xm1**2 + xm2**2 + dm1m2**2)
cs(6) = 2*xnoe2*xp*dm1m2*(xm1 + 2*dm1m2)
cs(5) = bet*xnoe2*(dm1m2**2 + xp*(xm1 + xm2))
cs(4)= xp*(7/6D0 -
& 2*slam*xnoe*(xnoe*(dm1m2 - xm2 + xp) + 1))
cs(3) = -2*xmxp*xp*(
& 3*(bet + 2*xp)*(2*xm1 + xm2 - xp) +
& 2*xm1*(3*xp + dm1m2) )
xmxp = dm1m2/xp
cs(2) = xlo3*slam*(xmxp*(xmxp + 1) - xm2/xp + 1)
csom = 0
xmxp = 0
do i=8,1,-1
csom = csom + cs(i)
xmxp = max(xmxp,absc(cs(i)))
enddo
if ( xmxp.lt.xmax ) then
cb2i(1) = csom
xmax = xmxp
endif
if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
endif
* #] improve: |xp| < xm2 < xm1:
* #[ wrap up:
100 continue
xmax = xmxsav
cb2i(1) = DBLE(1/(3*xp)) * cb2i(1)
cb2i(2) = DBLE(1/6.d0) * cb2i(2)
* #] wrap up:
* #[ xp=0, m1!=m2:
elseif (dm1m2 .ne. 0) then
* #[ B21:
llogmm = .FALSE.
*
* B21 (see thesis, b21.frm)
*
cs(1) = DBLE(xm1**2/3/dm1m2**3)*ca0i(1)
cs(2) = DBLE((-xm1**2 + xm1*xm2 - xm2**2/3)/dm1m2**3)*
+ ca0i(2)
cs(3) = (5*xm1**3/18 - xm1*xm2**2/2 + 2*xm2**3/9)
+ /dm1m2**3
cb2i(1) = cs(1)+cs(2)+cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
*
* ma ~ mb
*
if ( abs(dm1m2).lt.xloss*xm1 ) then
xlogmm = dfflo1(dm1m2/xm1,ier)
else
xlogmm = log(xm2/xm1)
endif
llogmm = .TRUE.
cs(1) = (xm1/dm1m2)/6
cs(2) = (xm1/dm1m2)**2/3
cs(3) = (xm1/dm1m2)**3*xlogmm/3
cs(4) = -2/DBLE(9) + ca0i(1)*DBLE(1/(3*xm1))
cs(5) = -xlogmm/3
csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ absc(cs(5)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb2i(1) = csom
if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
endif
*
* and last try
*
xlo3 = dfflo3(dm1m2/xm1,ier)
cs(1) = (dm1m2/xm1)**2/6
cs(2) = (dm1m2/xm1)/3
cs(3) = xlo3/(3*(dm1m2/xm1)**3)
*same cs(4) = -2/DBLE(9) + ca0i(1)*DBLE(1/(3*xm1))
cs(5) = -xlo3/3
csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ absc(cs(5)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb2i(1) = csom
if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
endif
*
* give up
*
160 continue
* #] B21:
* #[ B22:
*
* B22
*
cs(1) = +DBLE(xm1/(4*dm1m2))*ca0i(1)
cs(2) = -DBLE(xm2/(4*dm1m2))*ca0i(2)
cs(3) = (xm1+xm2)/8
cb2i(2) = cs(1) + cs(2) + cs(3)
xmax = max(absc(cs(2)),absc(cs(3)))
if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
*
* second try, close together
*
if ( .not.llogmm ) then
if ( abs(dm1m2).lt.xloss*xm1 ) then
xlogmm = dfflo1(dm1m2/xm1,ier)
else
xlogmm = log(xm2/xm1)
endif
endif
cs(1) = dm1m2*( -1/DBLE(8) - ca0i(1)*DBLE(1/(4*xm1)) )
cs(2) = dm1m2*xlogmm/4
cs(3) = xm1*(xm1/dm1m2)/4*xlogmm
cs(4) = xm1*( 1/DBLE(4) + ca0i(1)*DBLE(1/(2*xm1)) )
cs(5) = -xm1*xlogmm/2
csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
+ absc(cs(5)))
if ( xmxp.lt.xmax ) then
xmax = xmxp
cb2i(2) = csom
endif
if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
*
* give up
*
210 continue
* #] B22:
* #] xp=0, m1!=m2:
* #[ xp=0, m1==m2:
else
*
* taken over from ffxb2a, which in turns stem from my thesis GJ
*
cb2i(1) = cb0/3
cb2i(2) = DBLE(xm1/2)*(cb0 + 1)
endif
* #] xp=0, m1==m2:
* #[ finish up:
ier = max(ier0,ier1)
* #] finish up:
*###] ffxb2q:
end
diff --git a/Looptools/B/ffxdb0.F b/Looptools/B/ffxdb0.F
--- a/Looptools/B/ffxdb0.F
+++ b/Looptools/B/ffxdb0.F
@@ -1,672 +1,670 @@
+#include "externals.h"
+
+
*###[ ffxdb0:
subroutine ffxdb0(cdb0,cdb0p,xp,xma,xmb,ier)
***#[*comment:***********************************************************
* *
* Calculates the the derivative of the two-point function with *
* respect to p2 and the same times p2 (one is always well-defined)*
* *
* Input: xp (real) k2, in B&D metric *
* xma (real) mass2 *
* xmb (real) mass2 *
* *
* Output: cdb0 (complex) dB0/dxp *
* cdb0p (complex) xp*dB0/dxp *
* ier (integer) # of digits lost, if >=100: error *
* *
* Calls: ffxdba *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cdb0,cdb0p
DOUBLE PRECISION xp,xma,xmb
*
* local variables
*
DOUBLE PRECISION dmamb,dmap,dmbp
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
dmamb = (sqrt(xma) - sqrt(xmb))**2
if( abs(xp - dmamb) .lt. precx .and.
& abs(dmamb) .gt. precx .and.
& xma .gt. precx .and. xmb .gt. precx ) then
cdb0p = .5D0*(xmb - xma)/dmamb*log(xmb/xma) - 2
cdb0 = cdb0p/dmamb
return
endif
* #[ get differences:
dmamb = xma - xmb
dmap = xma - xp
dmbp = xmb - xp
* #] get differences:
* #[ calculations:
call ffxdbp(cdb0,cdb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
* #] calculations:
*###] ffxdb0:
end
*###[ ffxdbp:
subroutine ffxdbp(cdb0,cdb0p,xp,xma,xmb,dmap,dmbp,dmamb,ier)
***#[*comment:***********************************************************
* *
* calculates the derivatives of the two-point function *
* Veltman) for all possible cases: masses equal, unequal, *
* equal to zero. *
* *
* Input: xp (real) p.p, in B&D metric *
* xma (real) mass2, *
* xmb (real) mass2, *
* dm[ab]p (real) xm[ab] - xp *
* dmamb (real) xma - xmb *
* *
* Output: cdb0 (complex) B0' = dB0/dxp *
* cdb0p (complex) xp*dB0/dxp *
* ier (integer) 0=ok,>0=numerical problems,>100=error *
* *
* Calls: ffxdbp. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cdb0,cdb0p
DOUBLE PRECISION xp,xma,xmb,dmap,dmbp,dmamb
*
* local variables
*
integer i,initeq,jsign,initir
DOUBLE PRECISION ax,ffbnd,
+ xprceq,bdeq01,bdeq05,bdeq11,bdeq17,
+ xprcn3,bdn301,bdn305,bdn310,
+ xprcn5,bdn501,bdn505,bdn510,
+ xprec0,bdn001,bdn005,bdn010,bdn015
DOUBLE PRECISION xm,dmp,xm1,xm2,dm1m2,dm1p,
+ dm2p,s,s1,s1a,s1b,s1p,s2,s2a,s2b,s2p,x,y,som,
+ xlam,slam,xlogmm,alpha,alph1,xnoe,xpneq(30),
+ xx,dfflo1,dfflo3,d1,d2,diff,h,a,b,c,d,beta,
+ betm2n,xmax,s1c,s1d,s1e,s1f,s3
external ffbnd,dfflo1,dfflo3
save initeq,xpneq,initir,
+ xprceq,bdeq01,bdeq05,bdeq11,bdeq17,
+ xprcn3,bdn301,bdn305,bdn310,
+ xprcn5,bdn501,bdn505,bdn510,
+ xprec0,bdn001,bdn005,bdn010,bdn015
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data xprceq /-1D0/
data xprec0 /-1D0/
data xprcn3 /-1D0/
data xprcn5 /-1D0/
data initeq /0/
data initir /0/
*
* #] declarations:
* #[ which case:
*
* sort according to the type of masscombination encountered:
* 100: both masses zero, 200: one equal to zero, 300: both equal
* 400: rest.
*
if ( xma .eq. 0 ) then
if ( xmb .eq. 0 ) then
goto 100
endif
xm = xmb
dmp = dmbp
goto 200
endif
if ( xmb .eq. 0 ) then
xm = xma
dmp = dmap
goto 200
elseif ( dmamb .eq. 0 ) then
xm = xma
dmp = dmap
goto 300
elseif ( xma .gt. xmb ) then
xm2 = xma
xm1 = xmb
dm1m2 = -dmamb
dm1p = dmbp
dm2p = dmap
else
xm1 = xma
xm2 = xmb
dm1m2 = dmamb
dm1p = dmap
dm2p = dmbp
endif
goto 400
* #] which case:
* #[ both masses equal to zero:
100 continue
if ( xp.ne.0 ) cdb0 = -1/xp
cdb0p = -1
return
* #] both masses equal to zero:
* #[ one mass equal to zero:
200 continue
*
* special case xp = 0
*
if ( xp .eq. 0 ) then
cdb0p = 0
cdb0 = 1/(2*xm)
goto 990
*
* special case xp = xm
*
elseif ( dmp.eq.0 ) then
if ( lsmug ) then
if ( DBLE(cmipj(1,3)).lt.DBLE(cmipj(2,3)) ) then
cdb0p = -1 - log(cmipj(1,3)*DBLE(1/xm))
else
cdb0p = -1 - log(cmipj(2,3)*DBLE(1/xm))
endif
else
if ( initir.eq.0 ) then
initir = 1
print *,'ffxdb0: IR divergent B0'', using cutoff ',
+ lambda
endif
- if ( lambda .eq. 0D0 ) then
- call fferr(74,ier)
- cdb0p = 0
+ if ( lambda .le. 0 ) then
+ cdb0p = -1 + log(xm/mudim)/2
else
cdb0p = -1 + log(xm/lambda)/2
endif
endif
cdb0 = cdb0p*(1/DBLE(xp))
goto 990
endif
*
* Normal case:
*
x = xp/xm
ax = abs(x)
if ( ax .lt. xloss ) then
* #[ Taylor expansion:
if ( xprec0 .ne. precx ) then
xprec0 = precx
bdn001 = ffbnd(2,1,xninv)
bdn005 = ffbnd(2,5,xninv)
bdn010 = ffbnd(2,10,xninv)
bdn015 = ffbnd(2,15,xninv)
endif
if ( ax .gt. bdn015 ) then
som = x*(xninv(17) + x*(xninv(18) + x*(xninv(19) +
+ x*(xninv(20) + x*xninv(21) ))))
else
som = 0
endif
if ( ax .gt. bdn010 ) then
som = x*(xninv(12) + x*(xninv(13) + x*(xninv(14) +
+ x*(xninv(15) + x*(xninv(16) + som )))))
endif
if ( ax .gt. bdn005 ) then
som = x*(xninv(7) + x*(xninv(8) + x*(xninv(9) +
+ x*(xninv(10) + x*(xninv(11) + som )))))
endif
if ( ax .gt. bdn001 ) then
som = x*(xninv(3) + x*(xninv(4) + x*(xninv(5) +
+ x*(xninv(6) + som ))))
endif
cdb0p = x*(xninv(2) + som)
* #] Taylor expansion:
else
* #[ short formula:
s = log(abs(dmp/xm))
cdb0p = -(1 + s*xm/xp)
if ( xp.gt.xm ) cdb0p = cdb0p+DCMPLX(DBLE(0),DBLE(xm/xp*pi))
* #] short formula:
endif
cdb0 = cdb0p*(1/DBLE(xp))
goto 990
* #] one mass equal to zero:
* #[ both masses equal:
300 continue
*
* Both masses are equal. Not only this speeds up things, some
* cancellations have to be avoided as well.
*
* first a special case
*
if ( abs(xp) .lt. 8*xloss*xm ) then
* -#[ taylor expansion:
*
* a Taylor expansion seems appropriate as the result will go
* as k^2 but seems to go as 1/k !!
*
*--#[ data and bounds:
if ( initeq .eq. 0 ) then
initeq = 1
xpneq(1) = 1D0/6D0
do 1 i=2,30
xpneq(i) = - xpneq(i-1)*DBLE(i)/DBLE(2*(2*i+1))
1 continue
endif
if (xprceq .ne. precx ) then
*
* calculate the boundaries for the number of terms to be
* included in the taylorexpansion
*
xprceq = precx
bdeq01 = ffbnd(1,1,xpneq)
bdeq05 = ffbnd(1,5,xpneq)
bdeq11 = ffbnd(1,11,xpneq)
bdeq17 = ffbnd(1,17,xpneq)
endif
*--#] data and bounds:
x = -xp/xm
ax = abs(x)
if ( ax .gt. bdeq17 ) then
som = x*(xpneq(18) + x*(xpneq(19) + x*(xpneq(20) +
+ x*(xpneq(21) + x*(xpneq(22) + x*(xpneq(23) +
+ x*(xpneq(24) + x*xpneq(25) )))))))
else
som = 0
endif
if ( ax .gt. bdeq11 ) then
som = x*(xpneq(12) + x*(xpneq(13) + x*(xpneq(14) +
+ x*(xpneq(15) + x*(xpneq(16) + x*(xpneq(17) + som ))))
+ ))
endif
if ( ax .gt. bdeq05 ) then
som = x*(xpneq(6) + x*(xpneq(7) + x*(xpneq(8) + x*(
+ xpneq(9) + x*(xpneq(10) + x*(xpneq(11) + som ))))))
endif
if ( ax .gt. bdeq01 ) then
som = x*(xpneq(2) + x*(xpneq(3) + x*(xpneq(4) + x*(
+ xpneq(5) + som ))))
endif
cdb0p = -x*(xpneq(1)+som)
if ( xp.ne.0 ) then
cdb0 = cdb0p*(1/DBLE(xp))
else
cdb0 = xpneq(1)/xm
endif
goto 990
* -#] taylor expansion:
endif
* -#[ normal case:
*
* normal case
*
call ffxlmb(xlam,-xp,-xm,-xm,dmp,dmp,0D0)
if ( xlam .eq. 0 ) then
call fferr(86,ier)
return
elseif ( xlam .gt. 0 ) then
* cases 1,2 and 4
slam = sqrt(xlam)
s2a = dmp + xm
s2 = s2a + slam
if ( abs(s2) .gt. xloss*slam ) then
* looks fine
jsign = 1
else
s2 = s2a - slam
jsign = -1
endif
ax = abs(s2/(2*xm))
if ( ax .lt. xalogm ) then
s = 0
elseif( ax-1 .lt. .1 .and. s2 .gt. 0 ) then
* In this case a quicker and more accurate way is to
* calculate log(1-x).
s2 = (xp - slam)
* the following line is superfluous.
s = 2*xm/slam*dfflo1(s2/(2*xm),ier)
else
* finally the normal case
s = 2*xm/slam*log(ax)
if ( jsign .eq. -1 ) s = -s
endif
if ( xp .gt. 2*xm ) then
* in this case ( xlam>0, so xp>(2*m)^2) ) there also
* is an imaginary part
y = pi*2*xm/slam
else
y = 0
endif
else
* the root is complex (k^2 between 0 and (2*m1)^2)
slam = sqrt(-xlam)
s = 4*xm/slam*atan2(xp,slam)
y = 0
endif
xx = s - 1
cdb0p = DCMPLX(DBLE(xx),DBLE(y))
cdb0 = cdb0p*(1/DBLE(xp))
goto 990
* -#] normal case:
*
* #] both masses equal:
* #[ unequal nonzero masses:
* -#[ get log(xm2/xm1):
400 continue
x = xm2/xm1
if ( 1 .lt. xalogm*x ) then
call fferr(8,ier)
xlogmm = 0
elseif ( abs(x-1) .lt. xloss ) then
xlogmm = dfflo1(dm1m2/xm1,ier)
else
xlogmm = log(x)
endif
* -#] get log(xm2/xm1):
* -#[ xp = 0:
*
* first a special case
*
if ( xp .eq. 0 ) then
*
* repaired 19-nov-1993, see b2.frm
*
s1 = xm1*xm2*xlogmm/dm1m2**3
s2 = (xm1+xm2)/(2*dm1m2**2)
s = s1 + s2
if ( abs(s) .lt. xloss**2*s2 ) then
*
* second try
*
h = dfflo3(dm1m2/xm1,ier)
s1 = -xm1*h/dm1m2**2
s2 = 1/(2*xm1)
s3 = xm1**2*h/dm1m2**3
s = s1 + s2 + s3
if ( abs(s) .lt. xloss*max(abs(s2),abs(s3)) ) then
call ffwarn(228,ier,s,s2)
endif
endif
cdb0 = s
cdb0p = 0
goto 990
endif
* -#] xp = 0:
* -#[ normal case:
*
* proceeding with the normal case
*
call ffxlmb(xlam,-xp,-xm2,-xm1,dm2p,dm1p,dm1m2)
diff = xlam + xp*(dm2p+xm1)
if ( abs(diff) .lt. xloss*xlam ) then
h = dm1m2**2 - xp*(xm1+xm2)
if ( abs(h) .lt. xloss*dm1m2**2 ) then
if ( dm1m2**2 .lt. abs(xlam) ) diff = h
endif
endif
if ( xlam .eq. 0 ) then
call fferr(86,ier)
return
elseif ( xlam .gt. 0 ) then
* cases k^2 < -(m2+m1)^2 or k^2 > -(m2-m1)^2:
*--#[ first try:
* first try the normal way
slam = sqrt(xlam)
s2a = dm2p + xm1
s2 = s2a + slam
if ( abs(s2) .gt. xloss*slam ) then
* looks fine
jsign = 1
else
s2 = s2a - slam
jsign = -1
endif
s2 = s2**2/(4*xm1*xm2)
if ( abs(s2) .lt. xalogm ) then
call fferr(9,ier)
s2 = 0
elseif ( abs(s2-1) .lt. xloss ) then
if ( jsign.eq.1 ) then
s2 = -slam*(s2a+slam)/(2*xm1*xm2)
s2 = -diff/(2*slam*xp)*dfflo1(s2,ier)
else
ier = ier + 50
print *,'ffxdb0: untested: s2 better in first try'
s2 = +slam*(s2a-slam)/(2*xm1*xm2)
s2 = +diff/(2*slam*xp)*dfflo1(s2,ier)
endif
else
s2 = -diff/(2*slam*xp)*log(s2)
if ( jsign .eq. -1 ) s2 = -s2
endif
s1 = -dm1m2*xlogmm/(2*xp)
xx = s1+s2-1
*--#] first try:
if ( abs(xx) .lt. xloss**2*max(abs(s1),abs(s2)) ) then
*--#[ second try:
* this is unacceptable, try a better solution
s1a = diff + slam*dm1m2
if ( abs(s1a) .gt. xloss*diff ) then
* this works
s1 = -s1a/(2*xp*slam)
else
* by division a more accurate form can be found
s1 = -2*xm1*xm2*xp/(slam*(diff - slam*dm1m2))
endif
s = s1
s1 = s1*xlogmm
if ( abs(xp) .lt. xm2 ) then
s2a = xp - dm1m2
else
s2a = xm2 - dm1p
endif
s2 = s2a - slam
if ( abs(s2) .gt. xloss*slam ) then
* at least reasonable
s2 = s2 / (2*xm2)
else
* division again
s2 = (2*xp) / (s2a+slam)
endif
if ( abs(s2) .lt. .1 ) then
* choose a quick way to get the logarithm
s2 = dfflo1(s2,ier)
elseif ( s2.eq.1 ) then
print *,'ffxdbp: error: arg log would be 0!'
print *,' xp,xma,xmb = ',xp,xma,xmb
goto 600
else
s2 = log(abs(1 - s2))
endif
s2 = -diff/(slam*xp)*s2
xx = s1 + s2 - 1
*--#] second try:
if ( abs(xx) .lt. xloss**2*max(abs(s1),abs(s2)) ) then
*--#[ third try:
* (we accept two times xloss because that's the same
* as in this try)
* A Taylor expansion might work. We expand
* inside the logs. Only do the necessary work.
*
* #[ split up 1:
xnoe = s2a+slam
a = 1
b = 2/xnoe-1/xp
c = -4/(xp*xnoe)
d = sqrt((2/xnoe)**2 + 1/xp**2)
call ffroot(d1,d2,a,b,c,d,ier)
if ( xp.gt.0 ) then
beta = d2
else
beta = d1
endif
alpha = beta*diff/slam
alph1 = 1-alpha
if ( alph1 .lt. xloss ) then
s1a = 4*xp**2*xm1*xm2/(slam*dm1m2*(diff-slam*
+ dm1m2))
s1b = -diff/slam*4*xm1*xp/(dm1m2*xnoe*(2*xp-
+ xnoe))
b = -1/xp
c = -(2/xnoe)**2
call ffroot(d1,d2,a,b,c,d,ier)
if ( xp.gt.0 ) then
betm2n = d2
else
betm2n = d1
endif
d1 = s1a + s1b - diff/slam*betm2n
xmax = max(abs(s1a),abs(s1b))
if ( xmax .lt. 1 ) then
alph1 = d1
else
xmax = 1
endif
else
betm2n = beta - 2/xnoe
endif
* #] split up 1:
* #[ s2:
*
* first s2:
*
- 490 continue
s2p = s2 - alpha
if ( abs(s2p) .lt. xloss*abs(s2) ) then
* -#[ bounds:
* determine the boundaries for 1,5,10,15 terms
if ( xprcn5 .ne. precx ) then
xprcn5 = precx
bdn501 = ffbnd(3,1,xinfac)
bdn505 = ffbnd(3,5,xinfac)
bdn510 = ffbnd(3,10,xinfac)
endif
* -#] bounds:
x = beta*xp
ax = abs(x)
if ( ax .gt. bdn510 ) then
s2a = x*(xinfac(13) + x*(xinfac(14) + x*(
+ xinfac(15) + x*(xinfac(16) + x*
+ xinfac(17) ))))
else
s2a = 0
endif
if ( ax .gt. bdn505 ) then
s2a = x*(xinfac(8) + x*(xinfac(9) + x*(
+ xinfac(10) + x*(xinfac(11) + x*(
+ xinfac(12) + s2a)))))
endif
if ( ax .gt. bdn501 ) then
s2a = x*(xinfac(4) + x*(xinfac(5) + x*(
+ xinfac(6) + x*(xinfac(7) + s2a))))
endif
s2a = x**3*(xinfac(3)+s2a)
s2b = 2*xp/xnoe*(s2a + x**2/2)
s2p = s2b - s2a
s2p = -diff/(xp*slam)*dfflo1(s2p,ier)
endif
* #] s2:
* #[ s1:
*
* next s1:
*
- 495 continue
s1p = s1 - alph1
if ( abs(s1p) .lt. xloss*abs(s1) ) then
* -#[ bounds:
* determine the boundaries for 1,5,10,15 terms
if ( xprcn3 .ne. precx ) then
xprcn3 = precx
bdn301 = ffbnd(3,1,xinfac)
bdn305 = ffbnd(3,5,xinfac)
bdn310 = ffbnd(3,10,xinfac)
endif
* -#] bounds:
*
x = slam*(diff-slam*dm1m2)*alph1/(2*xp*xm1*xm2)
h = (2*xp*(xm1+xm2) - xp**2)/(slam-dm1m2)
ax = abs(x)
*
* see form job gets1.frm
*
s1b = diff*(diff-slam*dm1m2)*betm2n/(2*xp*xm1*
+ xm2)
s1c = 1/(xm1*xnoe*(2*xp-xnoe))*(
+ xp*( 4*xp*xm2 + 2*dm1m2**2/xm2*(xp-h) +
+ 2*dm1m2*(3*xp-h) - 8*dm1m2**2 )
+ - 2*dm1m2**3/xm2*(3*xp-h)
+ + 4*dm1m2**4/xm2
+ )
s1d = x*dm1m2/xm1
s1e = -x**2/2
if ( ax .gt. bdn310 ) then
s1a = x*(xinfac(13) + x*(xinfac(14) + x*(
+ xinfac(15) + x*(xinfac(16) + x*
+ xinfac(17) ))))
else
s1a = 0
endif
if ( ax .gt. bdn305 ) then
s1a = x*(xinfac(8) + x*(xinfac(9) + x*(
+ xinfac(10) + x*(xinfac(11) + x*(
+ xinfac(12) + s1a)))))
endif
if ( ax .gt. bdn301 ) then
s1a = x*(xinfac(4) + x*(xinfac(5) + x*(
+ xinfac(6) + x*(xinfac(7) + s1a))))
endif
s1a = -x**3 *(xinfac(3) + s1a)
s1f = dm1m2/xm1*(x**2/2 - s1a)
s1p = s1e + s1d + s1c + s1b + s1a + s1f
xmax = max(abs(s1a),abs(s1b),abs(s1c),abs(s1d),
+ abs(s1e))
s1p = s*dfflo1(s1p,ier)
endif
* #] s1:
*
* finally ...
*
- 500 continue
xx = s1p + s2p
*--#] third try:
endif
endif
600 continue
if ( xp .gt. xm1+xm2 ) then
*--#[ imaginary part:
* in this case ( xlam>0, so xp>(m1+m2)^2) ) there also
* is an imaginary part
y = -pi*diff/(slam*xp)
else
y = 0
*--#] imaginary part:
endif
else
* the root is complex (k^2 between -(m1+m2)^2 and -(m2-m1)^2)
*--#[ first try:
slam = sqrt(-xlam)
xnoe = dm2p + xm1
s1 = -(dm1m2/(2*xp))*xlogmm
s2 = -diff/(slam*xp)*atan2(slam,xnoe)
xx = s1 + s2 - 1
*--#] first try:
y = 0
endif
- 590 continue
cdb0p = DCMPLX(DBLE(xx),DBLE(y))
cdb0 = cdb0p*(1/DBLE(xp))
goto 990
* -#] normal case:
* #] unequal nonzero masses:
990 continue
*###] ffxdbp:
end
diff --git a/Looptools/B/ffxdb1.F b/Looptools/B/ffxdb1.F
--- a/Looptools/B/ffxdb1.F
+++ b/Looptools/B/ffxdb1.F
@@ -1,395 +1,411 @@
+#include "externals.h"
+
+
*###[ ffxdb1:
subroutine ffxdb1(cdb1, p, m1, m2, ier)
***#[*comment:***********************************************************
* *
* DB1 function (derivative of B1) *
* *
* algorithm adapted from Ansgar Denner's bcanew.f *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cdb1
DOUBLE PRECISION p, m1, m2
integer ier
DOUBLE COMPLEX ffpvf, ffypvf
external ffpvf, ffypvf
DOUBLE COMPLEX xp, xm, yp, ym, r
- include 'ff.h'
+#include "ff.h"
logical initir
save initir
data initir /.FALSE./
*
* #[ declarations:
if( abs(p) .gt. acc*(m1 + m2) ) then
* IR divergent case
if( m2 .eq. 0 .and. p .eq. m1 ) then
if( .not. initir ) then
initir = .TRUE.
print *, "ffxdb1: IR divergent B1', using cutoff ",
+ lambda
endif
- cdb1 = .5D0*(3 + log(lambda/p))/p
+ if( lambda .le. 0 ) then
+ cdb1 = .5D0*(3 + log(mudim/p))/p
+ else
+ cdb1 = .5D0*(3 + log(lambda/p))/p
+ endif
return
endif
- call ffroots(p, m1, m2, xp, xm, yp, ym, r)
+ call ffroots(p, m1, m2, xp, xm, yp, ym, r, ier)
if( abs(xp - xm) .gt. acc*abs(xp + xm) ) then
cdb1 = (ffypvf(2, xp, yp) - ffypvf(2, xm, ym))/r
else if( abs(xp) .gt. 10 ) then
cdb1 = DBLE( (2/3D0 +
+ (2 - 3*xp)*ffpvf(3, xp, yp))/xp**2 )/p
else if( abs(yp) .gt. acc ) then
cdb1 = DBLE( (3/2D0 +
+ (2 - 3*xp)*ffpvf(1, xp, yp)) )/p
else
call fferr(101, ier)
cdb1 = nan
endif
* zero momentum case
else if( abs(m1 - m2) .gt. acc*(m1 + m2) ) then
xm = (1 - cI*eps)*m1/(m1 - m2)
ym = (1 - cI*eps)*m2/(m2 - m1)
if( abs(xm) .lt. 10 ) then
cdb1 = -(1/3D0 + ffypvf(2, xm, ym))/(m1 - m2)
else
cdb1 = -(1/3D0 + ffypvf(3, xm, ym))/m1
endif
else
cdb1 = -1/12D0/m1
endif
end
*###[ ffxdb11:
subroutine ffxdb11(cdb11, p, m1, m2, ier)
***#[*comment:***********************************************************
* *
* DB11 function (derivative of B11) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cdb11
DOUBLE PRECISION p, m1, m2
integer ier
DOUBLE COMPLEX ffpvf, ffypvf
external ffpvf, ffypvf
DOUBLE COMPLEX xp, xm, yp, ym, r
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
if( abs(p) .gt. acc*(m1 + m2) ) then
- call ffroots(p, m1, m2, xp, xm, yp, ym, r)
+ call ffroots(p, m1, m2, xp, xm, yp, ym, r, ier)
if( abs(xp - xm) .gt. acc*abs(xp + xm) ) then
cdb11 = (ffypvf(3, xm, ym) - ffypvf(3, xp, yp))/r
else if( abs(xp) .gt. 10 ) then
cdb11 = DBLE( (-3/4D0 +
+ (4*xp - 3)*ffpvf(4, xp, yp))/xp**2 )/p
else if( abs(yp) .gt. acc ) then
cdb11 = DBLE( (-4/3D0 +
+ (4*xp - 3)*ffpvf(2, xp, yp))/p )
else
c call fferr(102, ier)
cdb11 = nan
endif
* zero momentum case
else if( abs(m1 - m2) .gt. acc*(m1 + m2) ) then
xm = (1 - cI*eps)*m1/(m1 - m2)
ym = (1 - cI*eps)*m2/(m2 - m1)
if( abs(xm) .lt. 10 ) then
cdb11 = (1/4D0 + ffypvf(3, xm, ym))/(m1 - m2)
else
cdb11 = (1/4D0 + ffypvf(4, xm, ym))/m1
endif
else
cdb11 = 1/20D0/m1
endif
end
*###[ ffxdb11:
subroutine ffxb111(cb111, p, m1, m2, ier)
***#[*comment:***********************************************************
* *
* B111 function (coefficient of p_mu p_nu p_rho) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cb111
DOUBLE PRECISION p, m1, m2
integer ier
DOUBLE COMPLEX ffpvf, ffypvf, ffthf, ffxlogx
external ffpvf, ffypvf, ffthf, ffxlogx
DOUBLE COMPLEX xp, xm, yp, ym, r
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
if( abs(p) .gt. acc*(m1 + m2) ) then
- call ffroots(p, m1, m2, xp, xm, yp, ym, r)
+ call ffroots(p, m1, m2, xp, xm, yp, ym, r, ier)
if( abs(yp) .gt. .5D0 .and. abs(ym) .gt. .5D0 ) then
cb111 = 1/4D0*( log(m2/mudim) - delta +
& ffpvf(4, xp, yp) + ffpvf(4, xm, ym) )
else if( abs(xp) .lt. 10 .and. abs(xm) .lt. 10 ) then
cb111 = 1/4D0*( log(p/mudim*(1 - cI*eps)) -
& delta - 1/2D0 +
& (1 + xp)*(1 + xp**2)*ffxlogx(yp) -
& xp*(1/3D0 + xp*(1/2D0 + xp*(1 + ffxlogx(-xp)))) +
& (1 + xm)*(1 + xm**2)*ffxlogx(ym) -
& xm*(1/3D0 + xm*(1/2D0 + xm*(1 + ffxlogx(-xm)))) )
else if( abs(xp) .gt. .5D0 .and. abs(xm) .gt. .5D0 ) then
cb111 = 1/4D0*( log(m1/mudim) - delta +
& ffthf(4, xp, yp) + ffthf(4, xm, ym) )
else
c call fferr(102, ier)
cb111 = nan
endif
* zero momentum case
else if( abs(m1 - m2) .gt. acc*(m1 + m2) ) then
xm = (1 - cI*eps)*m1/(m1 - m2)
ym = (1 - cI*eps)*m2/(m2 - m1)
if( abs(ym) .gt. .5D0 ) then
cb111 = 1/4D0*(log(m2/mudim) - delta + ffpvf(4, xm, ym))
else
cb111 = 1/4D0*(log(m1/mudim) - delta -
& (1 + xm*(1 + xm*(1 + xm)))*ffypvf(0, xm, ym) -
& xm*(xm*(xm + 1/2D0) + 1/3D0) - 1/4D0)
endif
else
cb111 = 1/4D0*(log(m2/mudim) - delta)
endif
end
*###[ ffroots
- subroutine ffroots(p, m1, m2, xp, xm, yp, ym, r)
+ subroutine ffroots(p, m1, m2, xp, xm, yp, ym, r, ier)
***#[*comment:***********************************************************
* *
* roots of quadratic equation *
-* p*x^2 + (m2 - m1 - p)*x + m2 - eps = *
+* p*x^2 + (m2 - m1 - p)*x + m2 - I eps = *
* p*(x - xp)*(x - xm) = p*(x - 1 + yp)*(x - 1 + ym) *
* i.e. x[pm] = 1 - y[pm] *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE PRECISION p, m1, m2
DOUBLE COMPLEX xp, xm, yp, ym, r
+ integer ier
DOUBLE PRECISION qx, qy
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
+* #[ check input:
+ if( p .eq. 0 ) then
+ call fferr(39, ier)
+ return
+ endif
+* #] check input:
+
qx = m1 - m2 + p
qy = m2 - m1 + p
+
r = sqrt(DCMPLX(p*(p - m1 - m2) - m1*qy - m2*qx))
- xp = (qx + r)/2D0/p
- xm = (qx - r)/2D0/p
+ xp = .5D0*(qx + r)/p
+ xm = .5D0*(qx - r)/p
if( abs(xm) .gt. abs(xp) ) then
xp = m1/(p*xm)
else if( abs(xp) .gt. abs(xm) ) then
xm = m1/(p*xp)
endif
xp = xp + abs(p*xp)/p*eps*cI
xm = xm - abs(p*xm)/p*eps*cI
- ym = (qy + r)/2D0/p
- yp = (qy - r)/2D0/p
+ ym = .5D0*(qy + r)/p
+ yp = .5D0*(qy - r)/p
if( abs(ym) .gt. abs(yp) ) then
yp = m2/(p*ym)
else if( abs(yp) .gt. abs(ym) ) then
ym = m2/(p*yp)
endif
yp = yp - abs(p*yp)/p*eps*cI
ym = ym + abs(p*ym)/p*eps*cI
end
*###[ ffpvf
DOUBLE COMPLEX function ffpvf(n, x, y)
***#[*comment:***********************************************************
* *
* Passarino-Veltman function f(n, x) *
* here third arg y = 1 - x *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer n
DOUBLE COMPLEX x, y
DOUBLE COMPLEX xm
integer m
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
if( abs(x) .lt. 5 ) then
if( n .eq. 0 ) then
ffpvf = -log(-y/x)
- else if( x .eq. 0 ) then
+ else if( abs(x) .lt. 1D-14 ) then
ffpvf = -1D0/n
else
xm = -log(-y/x)
do m = 1, n
xm = x*xm - 1D0/m
enddo
ffpvf = xm
endif
else
ffpvf = 0
xm = 1
do m = 1, 30
xm = xm/x
ffpvf = ffpvf + xm/(m + n)
if( abs(xm) .lt. precx*abs(ffpvf) ) return
enddo
endif
end
*###[ ffypvf
DOUBLE COMPLEX function ffypvf(n, x, y)
***#[*comment:***********************************************************
* *
* y*ffpvf(n, x, y) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer n
DOUBLE COMPLEX x, y
DOUBLE COMPLEX ffpvf
external ffpvf
*
* #] declarations:
if( abs(y) .eq. 0 ) then
ffypvf = 0
else
ffypvf = y*ffpvf(n, x, y)
endif
end
*###[ ffypvf
DOUBLE COMPLEX function ffxlogx(x)
***#[*comment:***********************************************************
* *
* x*log(x) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX x
*
* #] declarations:
if( abs(x) .eq. 0 ) then
ffxlogx = 0
else
ffxlogx = x*log(x)
endif
end
*###[ ffthf
DOUBLE COMPLEX function ffthf(n, x, y)
***#[*comment:***********************************************************
* *
* y*ffpvf(n, x, y) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer n
DOUBLE COMPLEX x, y
DOUBLE COMPLEX ffpvf
external ffpvf
DOUBLE COMPLEX xm
integer m
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
if( abs(x) .gt. 1D4 ) then
xm = n
ffthf = 0
do m = 1, 30
xm = xm/x
ffthf = ffthf - xm/(m*(m + n))
if( abs(xm) .lt. precx*abs(ffthf) ) return
enddo
else
xm = ffpvf(1, y, x)
ffthf = xm
do m = 1, n - 1
xm = x*xm + 1D0/(m*(m + 1))
ffthf = ffthf + xm
enddo
endif
end
diff --git a/Looptools/C/C0.F b/Looptools/C/C0.F
--- a/Looptools/C/C0.F
+++ b/Looptools/C/C0.F
@@ -1,404 +1,696 @@
* C0.F
* the scalar three-point function
* this file is part of LoopTools
-* last modified 24 Jan 06 th
+* last modified 21 Dec 10 th
#include "defs.h"
+#define legs 3
+#define M(i) xpi(i)
+#define P(i) xpi(i+legs)
+
double complex function C0(p1, p2, p1p2, m1, m2, m3)
implicit none
double precision p1, p2, p1p2, m1, m2, m3
#include "lt.h"
- double complex C0b
- external C0b
+ external C0soft, C0coll, C0softDR, C0collDR
double complex res(0:1)
double precision xpi(6)
integer key, ier
+ M(1) = m1
+ M(2) = m2
+ M(3) = m3
+ P(1) = p1
+ P(2) = p2
+ P(3) = p1p2
+
+ if( lambda .le. 0 ) then
+ call CDispatch(C0, xpi, C0softDR, C0collDR)
+ return
+ endif
+
ier = 0
key = ibits(versionkey, KeyC0, 2)
if( key .ne. 1 ) then
- xpi(1) = m1
- xpi(2) = m2
- xpi(3) = m3
- xpi(4) = p1
- xpi(5) = p2
- xpi(6) = p1p2
call ffxc0(res(0), xpi, ier)
if( ier .gt. warndigits ) then
ier = 0
call ffxc0r(res(0), xpi, ier)
if( ier .gt. warndigits ) key = ior(key, 2)
endif
endif
if( key .ne. 0 ) then
- res(1) = C0b(p1, p2, p1p2, m1, m2, m3)
+ call CDispatch(res(1), xpi, C0soft, C0coll)
if( key .gt. 1 .and.
& abs(res(0) - res(1)) .gt. maxdev*abs(res(0)) ) then
print *, "Discrepancy in C0:"
print *, " p1 =", p1
print *, " p2 =", p2
print *, " p1p2 =", p1p2
print *, " m1 =", m1
print *, " m2 =", m2
print *, " m3 =", m3
print *, "C0 a =", res(0)
print *, "C0 b =", res(1)
if( ier .gt. errdigits ) res(0) = res(1)
endif
endif
C0 = res(iand(key, 1))
end
************************************************************************
* adapter code for C++
subroutine c0sub(res, p1, p2, p1p2, m1, m2, m3)
implicit none
double complex res
double precision p1, p2, p1p2, m1, m2, m3
double complex C0
external C0
res = C0(p1, p2, p1p2, m1, m2, m3)
end
************************************************************************
-* this routine is adapted from Ansgar Denner's bcanew.f
-* to the conventions of LoopTools;
-* it is used for double-checking the results of FF
- double complex function C0b(p1, p2, p1p2, m1, m2, m3)
+ subroutine CDispatch(res, xpi, soft, coll)
implicit none
- double precision p1, p2, p1p2, m1, m2, m3
+ double complex res
+ double precision xpi(6)
+ external soft, coll
#include "lt.h"
- double complex C0ir, C0reg
- external C0ir, C0reg
+ integer i, z, c, perm
- if( m1 .eq. 0 .and.
- & (abs(p1 - m2) + abs(p1p2 - m3)) .lt. acc ) then
- C0b = C0ir(p2, p1, p1p2)
- else if( m2 .eq. 0 .and.
- & (abs(p1 - m1) + abs(p2 - m3)) .lt. acc ) then
- C0b = C0ir(p1p2, p1, p2)
- else if( m3 .eq. 0 .and.
- & (abs(p2 - m2) + abs(p1p2 - m1)) .lt. acc ) then
- C0b = C0ir(p1, p2, p1p2)
+ double complex C0p3, C0p2, C0p1, C0p0
+ external C0p3, C0p2, C0p1, C0p0
+
+ integer p123, p231, p312
+ parameter (p123 = O'123', p231 = O'231', p312 = O'312')
+
+ integer xpiperm(3)
+ data xpiperm /p123, p231, p312/
+
+#define Px(j) P(ibits(perm,3*(3-j),3))
+#define Mx(j) M(ibits(perm,3*(3-j),3))
+
+555 z = 0
+ c = 0
+ do i = 1, 3
+ perm = xpiperm(i)
+ if( abs(Mx(1)) .lt. eps ) then
+ if( abs(Px(1) - Mx(2)) +
+ & abs(Px(3) - Mx(3)) .lt. acc ) then
+ if( DEBUGLEVEL .gt. 0 )
+ & print '(A,O3)', "soft C0, perm = ", perm
+ call soft(res, xpi, perm)
+ return
+ endif
+ if( abs(Px(1)) + abs(Mx(2)) .lt. eps ) c = perm
+ endif
+ if( abs(P(i)) .lt. eps ) z = z + 1
+ enddo
+
+ if( c .ne. 0 ) then
+ if( DEBUGLEVEL .gt. 0 )
+ & print '(A,O3)', "collinear C0, perm = ", perm
+ call coll(res, xpi, c)
+ if( res .eq. c ) goto 555
+ return
+ endif
+
+ goto (1, 2, 3) z
+
+ res = C0p3(xpi, p123) + C0p3(xpi, p231) + C0p3(xpi, p312)
+ return
+
+1 res = C0p2(xpi, p123) + C0p2(xpi, p231) + C0p2(xpi, p312)
+ return
+
+2 res = C0p1(xpi, p123) + C0p1(xpi, p231) + C0p1(xpi, p312)
+ return
+
+3 res = C0p0(xpi)
+ end
+
+************************************************************************
+* the following routines are adapted from Ansgar Denner's bcanew.f
+* to the conventions of LoopTools;
+* they are used for double-checking the results of FF
+
+* all mom-squares != 0
+
+ double complex function C0p3(xpi, perm)
+ implicit none
+ double precision xpi(6)
+ integer perm
+
+#include "lt.h"
+
+ double precision m1, m2, m3, p1, p2, p3
+ double precision m12, m13, m23, a2, n
+ double complex a, b, c
+ double complex y1, y2, y3, y4, x1, x2, x3, x4, z3, z4
+ integer z3z4, x1z3, x3z3, x2z4, x4z4
+
+ double complex spence
+ integer eta
+ external spence, eta
+
+ m1 = Mx(1)
+ m2 = Mx(2)
+ m3 = Mx(3)
+ p1 = Px(1)
+ p2 = Px(2)
+ p3 = Px(3)
+
+ m12 = m1 - m2
+ m13 = m1 - m3
+ m23 = m2 - m3
+
+ a2 = (p1 - p2 - p3)**2 - 4*p2*p3
+ a = sqrt(DCMPLX(a2))
+ n = .5D0/p1
+ c = (p1*(p1 - p2 - p3 - m13 - m23) - m12*(p2 - p3))/a
+
+ y1 = n*(c + (p1 - m12))
+ y4 = n*(c - (p1 - m12))
+ if( abs(y1) .lt. abs(y4) )
+ & y1 = ((p1 - m12)*(p2 + m23)*p3 -
+ & (p1 - p2 - m13)*(m12*p2 + m23*p1))/(a2*p1*y4)
+
+ y2 = n*(c - (p1 + m12))
+ y4 = n*(c + (p1 + m12))
+ if( abs(y2) .lt. abs(y4) )
+ & y2 = ((p1 + m12)*(p3 + m13)*p2 +
+ & (p1 - p3 - m23)*(m12*p3 - m13*p1))/(a2*p1*y4)
+
+ b = sqrt(DCMPLX((p1 - m12)**2 - 4*p1*m2))
+ y3 = n*(c + b)
+ y4 = n*(c - b)
+ n = (p1*((p1 - p2 - p3)*m3 + p2*p3 + m13*m23) +
+ & p2*((p2 - p3 - p1)*m1 + m12*m13) +
+ & p3*((p3 - p1 - p2)*m2 - m12*m23))/(a2*p1)
+ if( abs(y3) .lt. abs(y4) ) then
+ y3 = n/y4
else
- C0b = C0reg(p1, p2, p1p2, m1, m2, m3)
+ y4 = n/y3
+ endif
+ c = a*b
+ if( c .ne. 0 ) then
+ y3 = y3 + cI*eps*abs(c*y3)/c
+ y4 = y4 - cI*eps*abs(c*y4)/c
+ else
+ y3 = y3*(1 + cI*eps)
+ y4 = y4*(1 - cI*eps)
+ endif
+
+ C0p3 = spence(y2/y3, 0D0) + spence(y2/y4, 0D0) -
+ & spence(y1/y3, 0D0) - spence(y1/y4, 0D0)
+
+ if( DIMAG(a) .ne. 0 ) then
+ c = abs(b)/b*eps*cI
+ x1 = -.5D0/p1*( p1 - m12 + b) - c
+ x2 = -.5D0/p1*( p1 - m12 - b) - c
+ x3 = -.5D0/p1*(-p1 - m12 + b) - c
+ x4 = -.5D0/p1*(-p1 - m12 - b) - c
+ z3 = 1/y3
+ z4 = 1/y4
+ z3z4 = eta(z3, 0D0, z4, 0D0, 0D0)
+ x1z3 = eta(x1, 0D0, z3, 0D0, 0D0)
+ x3z3 = eta(x3, 0D0, z3, 0D0, 0D0)
+ x2z4 = eta(x2, 0D0, z4, 0D0, 0D0)
+ x4z4 = eta(x4, 0D0, z4, 0D0, 0D0)
+ c = log(y1)*(eta(x1, 0D0, x2, 0D0, 0D0) +
+ & z3z4 - x1z3 - x2z4) -
+ & log(y2)*(eta(x3, 0D0, x4, 0D0, 0D0) +
+ & z3z4 - x3z3 - x4z4) +
+ & log(y3)*(x1z3 - x3z3) +
+ & log(y4)*(x2z4 - x4z4)
+ if( DIMAG(a) .gt. 0 .and. p1 .lt. 0 ) c = c - log(y1/y2)
+ C0p3 = C0p3 + c2ipi*c
+ endif
+
+ C0p3 = C0p3/a
+ end
+
+************************************************************************
+* one mom-square zero
+
+ double complex function C0p2(xpi, perm)
+ implicit none
+ double precision xpi(6)
+ integer perm
+
+#include "lt.h"
+
+ double precision m1, m2, m3, p1, p2, p3
+ double precision m12, m23, m13, a, c, y1, y2
+ double complex b, y3, y4
+
+ double complex spence
+ external spence
+
+ if( abs(Px(1)) .lt. eps ) then
+ C0p2 = 0
+ return
+ endif
+
+ m1 = Mx(1)
+ m2 = Mx(2)
+ m3 = Mx(3)
+ p1 = Px(1)
+ p2 = Px(2)
+ p3 = Px(3)
+
+ m12 = m1 - m2
+ m23 = m2 - m3
+ m13 = m1 - m3
+
+ if( abs(p3) .lt. eps ) then
+ a = p1 - p2
+ y1 = -2*p1*(m13 - a)
+ y2 = -2*p1*m13
+ else
+ a = p3 - p1
+ y1 = -2*p1*m23
+ y2 = -2*p1*(m23 + a)
+ endif
+
+ c = p1*(p1 - p2 - p3 - m13 - m23) - m12*(p2 - p3)
+ b = a*sqrt(DCMPLX((p1 - m12)**2 - 4*p1*m2))
+ y3 = c + b
+ y4 = c - b
+ c = 4*p1*(
+ & p1*((p1 - p2 - p3)*m3 + p2*p3 + m13*m23) +
+ & p2*((p2 - p3 - p1)*m1 + m12*m13) +
+ & p3*((p3 - p1 - p2)*m2 - m12*m23) )
+ if( abs(y3) .lt. abs(y4) ) then
+ y3 = c/y4
+ else
+ y4 = c/y3
+ endif
+ c = a/p1
+ if( c .ne. 0 ) then
+ y3 = y3 + cI*eps*abs(c*y3)/c
+ y4 = y4 - cI*eps*abs(c*y4)/c
+ else
+ y3 = y3*(1 + cI*eps)
+ y4 = y4*(1 - cI*eps)
+ endif
+
+ C0p2 = (spence(y2/y3, 0D0) + spence(y2/y4, 0D0) -
+ & spence(y1/y3, 0D0) - spence(y1/y4, 0D0))/a
+ end
+
+************************************************************************
+* two mom-squares zero
+
+ double complex function C0p1(xpi, perm)
+ implicit none
+ double precision xpi(6)
+ integer perm
+
+#include "lt.h"
+
+ double precision m1, m2, m3, p1, p2, p3
+ double precision m12, m23, m13, c, y1, y2
+ double complex b, y3, y4
+
+ double complex spence
+ external spence
+
+ if( abs(Px(1)) .lt. eps ) then
+ C0p1 = 0
+ return
+ endif
+
+ m1 = Mx(1)
+ m2 = Mx(2)
+ m3 = Mx(3)
+ p1 = Px(1)
+ p2 = Px(2)
+ p3 = Px(3)
+
+ m12 = m1 - m2
+ m23 = m2 - m3
+ m13 = m1 - m3
+
+ C0p1 = 0
+
+ if( abs(m13) .gt. acc ) then
+ y1 = m23 - p1
+ y2 = m23
+ c = m23 + p1*m3/m13
+ y3 = c - cI*eps*sign(1D0, p1/m13)*abs(c)
+ C0p1 = spence(y1/y3, 0D0) - spence(y2/y3, 0D0)
+ endif
+
+ y1 = -2*p1*m23
+ y2 = -2*p1*(m23 - p1)
+
+ c = p1*(p1 - m13 - m23)
+ b = p1*sqrt(DCMPLX((p1 - m12)**2 - 4*p1*m2))
+ y3 = c - b
+ y4 = c + b
+ c = 4*p1**2*(p1*m3 + m13*m23)
+ if( abs(y3) .lt. abs(y4) ) then
+ y3 = c/y4
+ else
+ y4 = c/y3
+ endif
+ y3 = y3 - cI*eps*abs(y3)
+ y4 = y4 + cI*eps*abs(y4)
+
+ C0p1 = (C0p1 +
+ & spence(y1/y3, 0D0) + spence(y1/y4, 0D0) -
+ & spence(y2/y3, 0D0) - spence(y2/y4, 0D0))/p1
+ end
+
+************************************************************************
+
+ double complex function C0p0(xpi)
+ implicit none
+ double precision xpi(6)
+
+#include "lt.h"
+
+ double precision m1, m2, m3
+ double precision m12, m23, m13
+
+ m1 = M(1)
+ m2 = M(2)
+ m3 = M(3)
+
+ m12 = m1 - m2
+ m23 = m2 - m3
+ m13 = m1 - m3
+
+ if( abs(m23) .lt. acc ) then
+ if( abs(m13) .lt. acc ) then
+ C0p0 = -.5D0/m1
+ else
+ C0p0 = (m13 - m1*log(m1/m3))/m13**2
+ endif
+ else
+ if( abs(m12) .lt. acc ) then
+ C0p0 = (-m23 + m3*log(m2/m3))/m23**2
+ else if( abs(m13) .lt. acc ) then
+ C0p0 = (m23 - m2*log(m2/m3))/m23**2
+ else
+ C0p0 = m3/(m13*m23)*log(m1/m3) - m2/(m12*m23)*log(m1/m2)
+ endif
endif
end
************************************************************************
- double complex function C0reg(p1, p2, p1p2, m1, m2, m3)
+ subroutine C0soft(res, xpi, perm)
implicit none
- double precision p1, p2, p1p2, m1, m2, m3
+ double complex res
+ double precision xpi(6)
+ integer perm
#include "lt.h"
- double precision q(5), m(5), mki, mkj, mij, qijk, ar
- double complex a, b, h, h0, h1, h2, h3, h4
- double complex y1, y2, y3, y4, x1, x2, x3, x4
- integer i, j, k
+ double complex ln, spence
+ external ln, spence
- double complex spence
- integer eta_n
- external spence, eta_n
+ double precision s, m1, m2
+ double precision a, h1, h2, h3, ps
+ double complex ls
- q(1) = p1
- q(2) = p2
- q(3) = p1p2
- q(4) = q(1)
- q(5) = q(2)
+ logical ini
+ data ini /.FALSE./
- m(1) = m1
- m(2) = m2
- m(3) = m3
- m(4) = m(1)
- m(5) = m(2)
+ s = Px(2)
+ m1 = Px(1)
+ m2 = Px(3)
- C0reg = 0
+ a = sqrt(4*m1*m2)
+ if( abs(a) .lt. eps ) then
+ ps = max(minmass, 1D-14)
+ if( abs(m1) .lt. eps ) m1 = ps
+ if( abs(m2) .lt. eps ) m2 = ps
+ if( .not. ini ) then
+ print *, "collinear-divergent C0, using mass cutoff ", ps
+ ini = .TRUE.
+ endif
+ endif
-* all mom-squares != 0
- if( p1*p2*p1p2 .ne. 0 ) then
- a = sqrt(DCMPLX((p2 - p1 - p1p2)**2 - 4*p1*p1p2))
- do i = 1, 3
- j = i + 1
- k = i + 2
- mki = m(k) - m(i)
- mkj = m(k) - m(j)
- mij = m(i) - m(j)
- qijk = q(i) - q(j) - q(k)
- h2 = .5D0/(a*q(i))
-
- h = q(i)*(qijk + mki + mkj) - mij*(q(j) - q(k))
- y1 = h2*(h + a*(q(i) - mij))
- y2 = h2*(h - a*(q(i) + mij))
- b = sqrt(DCMPLX((q(i) - mij)**2 - 4*q(i)*m(j)))
- y3 = h2*(h + a*b)
- y4 = h2*(h - a*b)
-
- h0 = q(i)*(q(j)*q(k) + qijk*m(k) + mki*mkj) -
- & mij*(q(j)*mki - q(k)*mkj)
- qijk = q(j) - q(k) - q(i)
- h3 = h0 + q(j)*qijk*m(i) + q(k)*(q(k) - q(i) - q(j))*m(j)
- if( abs(y3) .lt. abs(y4) ) then
- y3 = h3/(a**2*q(i)*y4)
- else
- y4 = h3/(a**2*q(i)*y3)
- endif
- if( a*b .ne. 0 ) then
- y3 = y3 + cI*eps*abs(a*b*y3)/(a*b)
- y4 = y4 - cI*eps*abs(a*b*y4)/(a*b)
- else
- y3 = y3*(1 + cI*eps)
- y4 = y4*(1 - cI*eps)
- endif
-
- h1 = h2*(h - a*(q(i) - mij))
- if( abs(y1) .lt. abs(h1) ) then
- h3 = (q(i) - q(j) + mki)*(mkj*q(i) - mij*q(j)) +
- & (q(i) - mij)*(q(j) - mkj)*q(k)
- y1 = h3/(a**2*q(i)*h1)
- endif
- h1 = h2*(h + a*(q(i) + mij))
- if( abs(y2) .lt. abs(h1) ) then
- h3 = (q(i) - q(k) + mkj)*(mki*q(i) + mij*q(k)) +
- & (q(i) + mij)*(q(k) - mki)*q(j)
- y2 = h3/(a**2*q(i)*h1)
- endif
-
- C0reg = C0reg +
- & spence(y2/y3, 0D0) + spence(y2/y4, 0D0) -
- & spence(y1/y3, 0D0) - spence(y1/y4, 0D0)
-
- if( DIMAG(a) .ne. 0 ) then
- h3 = abs(b)/b*eps*cI
- x1 = -.5D0*(q(i) - mij + b)/q(i) - h3
- x2 = -.5D0*(q(i) - mij - b)/q(i) - h3
- x3 = -.5D0*(-q(i) - mij + b)/q(i) - h3
- x4 = -.5D0*(-q(i) - mij - b)/q(i) - h3
- h3 = 1/y3
- h4 = 1/y4
- h = log(y1)*(eta_n(x1, x2) + eta_n(h3, h4) -
- & eta_n(x1, h3) - eta_n(x2, h4) ) -
- & log(y2)*(eta_n(x3, x4) + eta_n(h3, h4) -
- & eta_n(x3, h3) - eta_n(x4, h4) ) +
- & log(y3)*(eta_n(x1, h3) - eta_n(x3, h3)) +
- & log(y4)*(eta_n(x2, h4) - eta_n(x4, h4))
- if( DIMAG(a) .gt. 0 .and. q(i) .lt. 0 )
- & h = h - log(y1/y2)
- C0reg = C0reg + 2*pi*cI*h
- endif
- enddo
- C0reg = C0reg/a
+ if( abs(s) .lt. acc ) then
+ if( abs(m1 - m2) .lt. acc ) then
+ res = -.5D0*log(m1/lambda)/m1
+ else
+ res = -.25D0*log(m2*m1/lambda**2)*
+ & log(m1/m2)/(m1 - m2)
+ endif
return
endif
-* one mom-square zero
- if( (p2*p1 + p1p2*p2 + p1*p1p2) .ne. 0 ) then
- if( p1 .ne. 0 ) then
- if( p2 .eq. 0 ) then
- m(1) = m2
- m(2) = m3
- m(3) = m1
- q(1) = p2
- q(2) = p1p2
- q(3) = p1
- else
- m(1) = m3
- m(2) = m1
- m(3) = m2
- q(1) = p1p2
- q(2) = p1
- q(3) = p2
- endif
- m(4) = m(1)
- m(5) = m(2)
- q(4) = q(1)
- q(5) = q(2)
- endif
- ar = q(2) - q(3)
- do i = 2, 3
- j = i + 1
- k = i + 2
- mki = m(k) - m(i)
- mkj = m(k) - m(j)
- mij = m(i) - m(j)
- qijk = q(i) - q(j) - q(k)
-
- if( i .eq. 2 ) then
- y1 = 2*q(2)*(mki + ar)
- y2 = 2*q(2)*mki
- else
- y1 = 2*q(3)*mkj
- y2 = 2*q(3)*(mkj - ar)
- endif
- h = q(i)*(qijk + mki + mkj) - mij*(q(j) - q(k))
- b = sqrt(DCMPLX((q(i) - mij)**2 - 4*q(i)*m(j)))
- y3 = h + ar*b
- y4 = h - ar*b
-
- h0 = q(i)*(q(j)*q(k) + qijk*m(k) + mki*mkj) -
- & mij*(q(j)*mki - q(k)*mkj)
- h3 = h0 + q(j)*(q(j) - q(k) - q(i))*m(i) +
- & q(k)*(q(k) - q(i) - q(j))*m(j)
- h3 = 4*h3*q(i)
- if( abs(y3) .lt. abs(y4) ) then
- y3 = h3/y4
- else
- y4 = h3/y3
- endif
- qijk = ar/q(i)
- if( qijk .ne. 0 ) then
- y3 = y3 + cI*eps/qijk*abs(qijk*y3)
- y4 = y4 - cI*eps/qijk*abs(qijk*y4)
- else
- y3 = y3*(1 + cI*eps)
- y4 = y4*(1 - cI*eps)
- endif
-
- C0reg = C0reg +
- & spence(y2/y3, 0D0) + spence(y2/y4, 0D0) -
- & spence(y1/y3, 0D0) - spence(y1/y4, 0D0)
- enddo
- C0reg = C0reg/ar
- return
+ ps = s - m1 - m2
+ a = (ps - a)*(ps + a)
+ if( a .lt. 0 ) then
+ print *, "C0soft: complex square root not implemented"
+ a = 0
+ endif
+ a = sqrt(a)
+ if( ps .le. 0 ) then
+ h1 = .5D0*(a - ps)
+ else
+ h1 = -2*m1*m2/(a + ps)
+ endif
+ ps = s - m1 + m2
+ if( ps .le. 0 ) then
+ h2 = .5D0*(a - ps)
+ else
+ h2 = -2*s*m2/(a + ps)
+ endif
+ ps = s + m1 - m2
+ if( ps .le. 0 ) then
+ h3 = .5D0*(a - ps)
+ else
+ h3 = -2*m1*s/(a + ps)
endif
-* two mom-squares zero
- if( p1p2 .eq. 0 ) then
- if( p2 .ne. 0 ) then
- m(1) = m3
- m(2) = m1
- m(3) = m2
- q(1) = p1p2
- q(2) = p1
- q(3) = p2
- else
- m(1) = m2
- m(2) = m3
- m(3) = m1
- q(1) = p2
- q(2) = p1p2
- q(3) = p1
- endif
- m(4) = m(1)
- m(5) = m(2)
- q(4) = q(1)
- q(5) = q(2)
- endif
-
- mki = m(2) - m(3)
- mkj = m(2) - m(1)
- mij = m(3) - m(1)
-
- if( m(2) .ne. m(3) ) then
- y1 = -q(3) - mkj
- y2 = -mkj
- qijk = -mkj - q(3)*m(2)/mki
- y3 = qijk - cI*eps*sign(1D0, -q(3)/mki)*abs(qijk)
- C0reg = C0reg + spence(y2/y3, 0D0) - spence(y1/y3, 0D0)
- endif
-
- b = sqrt(DCMPLX((q(3) - mij)**2 - 4*q(3)*m(1)))
- h = q(3)*(q(3) + mki + mkj)
- y1 = 2*q(3)*mkj
- y2 = 2*q(3)*(q(3) + mkj)
- y3 = h - q(3)*b
- y4 = h + q(3)*b
- h0 = 4*q(3)**2*(q(3)*m(2) + mki*mkj)
- if( abs(y3) .lt. abs(y4) ) then
- y3 = h0/y4
- else
- y4 = h0/y3
- endif
- y3 = y3 - cI*eps*abs(y3)
- y4 = y4 + cI*eps*abs(y4)
-
- C0reg = -(C0reg +
- & spence(y2/y3, 0D0) + spence(y2/y4, 0D0) -
- & spence(y1/y3, 0D0) - spence(y1/y4, 0D0))/q(3)
+ ls = ln(-a/s, -1D0)
+ res = (-pi6 +
+ & spence(DCMPLX(h2/a), -1D0) + spence(DCMPLX(h3/a), -1D0) -
+ & .5D0*(ln(-h2/s, -1D0)**2 + ln(-h3/s, -1D0)**2) +
+ & .25D0*(ln(-m1/s, -1D0)**2 + ln(-m2/s, -1D0)**2) -
+ & ls*(ln(-h1/s, -1D0) - ls) +
+ & ln(-lambda/s, -1D0)*ln(h1/sqrt(m1*m2), 1D0))/a
end
************************************************************************
- double complex function C0ir(p2, p1, p1p2)
+ subroutine C0coll(res, xpi, perm)
implicit none
- double precision p2, p1, p1p2
+ double complex res
+ double precision xpi(6)
+ integer perm
#include "lt.h"
- double complex spence, ln
- external spence, ln
+ logical ini
+ data ini /.FALSE./
- double precision a, h1, h2, h3, ps
- double complex c
+ Px(1) = max(minmass, 1D-14)
+ res = perm
- if( abs(p1p2) .lt. acc .or. abs(p1) .lt. acc ) then
- print *, "C0ir: mass singular case"
- C0ir = nan
- return
- endif
-
- if( abs(p2) .lt. acc ) then
- C0ir = -.25D0*log(p1p2*p1/lambda**2)*
- & log(p1/p1p2)/(p1 - p1p2)
- return
- endif
-
- ps = p2 - p1 - p1p2
- a = ps**2 - 4*p1*p1p2
- if( a .lt. 0 )
- & print *, "C0ir: complex square root not implemented"
- a = sqrt(a)
- if( ps .le. 0 ) then
- h1 = .5D0*(a - ps)
- else
- h1 = -2*p1*p1p2/(a + ps)
- endif
- ps = p2 - p1 + p1p2
- if( ps .le. 0 ) then
- h2 = .5D0*(a - ps)
- else
- h2 = -2*p2*p1p2/(a + ps)
- endif
- ps = p2 + p1 - p1p2
- if( ps .le. 0 ) then
- h3 = .5D0*(a - ps)
- else
- h3 = -2*p1*p2/(a + ps)
- endif
-
- c = ln(-a/p2, -1D0)
- C0ir = (-pi**2/6D0 +
- & spence(DCMPLX(h2/a), -1D0) + spence(DCMPLX(h3/a), -1D0) -
- & .5D0*(ln(-h2/p2, -1D0)**2 + ln(-h3/p2, -1D0)**2) +
- & .25D0*(ln(-p1/p2, -1D0)**2 + ln(-p1p2/p2, -1D0)**2) -
- & c*(ln(-h1/p2, -1D0) - c) +
- & ln(-lambda/p2, -1D0)*ln(h1/sqrt(p1*p1p2), 1D0))/a
+ if( ini ) return
+ print *, "collinear-divergent C0, using mass cutoff ", Px(1)
+ ini = .TRUE.
end
************************************************************************
- integer function eta_n(c1, c2)
+ subroutine C0softDR(res, xpi, perm)
implicit none
- double complex c1, c2
+ double complex res
+ double precision xpi(6)
+ integer perm
- integer eta
- external eta
+#include "lt.h"
- eta_n = eta(c1, c2, 0D0, 0D0, 0D0)
+ double precision s, m1, m2
+ double precision m, dm, r
+ double complex root, fac, ls, lm, mK, lmK
+
+ double complex Li2omx2, lnrat, cln, spence
+ external Li2omx2, lnrat, cln, spence
+
+ s = Px(2)
+ m1 = Px(1)
+ m2 = Px(3)
+
+ m = sqrt(m1*m2)
+ if( abs(m) .lt. eps ) then
+ if( abs(m1) .lt. eps ) then
+ m1 = m2
+ if( abs(m1) .lt. eps ) then
+ if( abs(s) .lt. eps ) then
+ print *, "C0softDR: all scales zero"
+ res = nan
+ return
+ endif
+* qltri1
+ if( DEBUGLEVEL .gt. 1 ) print *, "qltri1"
+ if( lambda .eq. -2 ) then
+ res = 1/s
+ else if( lambda .eq. -1 ) then
+ res = lnrat(mudim, -s)/s
+ else
+ res = .5D0*lnrat(mudim, -s)**2/s
+ endif
+ return
+ endif
+ endif
+ if( abs(s - m1) .lt. acc ) then
+* qltri5
+ if( DEBUGLEVEL .gt. 1 ) print *, "qltri5"
+ if( lambda .eq. -2 ) then
+ res = 0
+ else if( lambda .eq. -1 ) then
+ res = -.5D0/m1
+ else
+ res = (-.5D0*lnrat(mudim, m1) + 1)/m1
+ endif
+ return
+ endif
+
+* qltri4
+ if( DEBUGLEVEL .gt. 1 ) print *, "qltri4"
+ if( lambda .eq. -2 ) then
+ res = .5D0/(s - m1)
+ else if( lambda .eq. -1 ) then
+ res = (.5D0*lnrat(mudim, m1) + lnrat(m1, m1 - s))/(s - m1)
+ else
+ ls = lnrat(m1, m1 - s)
+ lm = lnrat(mudim, m1)
+ res = (lm*(.25D0*lm + ls) + .5D0*ls**2 + pi12 -
+ & spence(DCMPLX(s/(s - m1)), 0D0))/(s - m1)
+ endif
+ return
+ endif
+
+ if( lambda .eq. -2 ) then
+ res = 0
+ return
+ endif
+
+* qltri6
+ if( DEBUGLEVEL .gt. 1 ) print *, "qltri6"
+ dm = sqrt(m1) - sqrt(m2)
+ r = s - dm**2
+ root = sqrt(DCMPLX((r - 4*m)/r))
+ mK = -4*m/(r*(1 + root)**2)
+
+ if( abs(mK - 1) .lt. acc ) then
+ if( lambda .eq. -1 ) then
+ res = .5D0/m
+ else
+ res = 0
+ if( abs(m1 - m2) .gt. acc )
+ & res = 2 + .5D0*(sqrt(m1) + sqrt(m2))/dm*log(m2/m1)
+ res = .5D0/m*(log(mudim/m) - res)
+ endif
+ return
+ endif
+
+ lmK = cln(mK, 1D0)
+ fac = 1/(r*root)
+
+ if( lambda .eq. -1 ) then
+ res = fac*lmK
+ else
+ res = fac*( lmK*(.5D0*lmK + log(mudim/m)) -
+ & .125D0*log(m1/m2)**2 +
+ & Li2omx2(mK, 1D0, mK, 1D0) -
+ & Li2omx2(mK, 1D0, DCMPLX(sqrt(m1/m2)), 0D0) -
+ & Li2omx2(mK, 1D0, DCMPLX(sqrt(m2/m1)), 0D0) )
+ endif
end
+************************************************************************
+
+ subroutine C0collDR(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(6)
+ integer perm
+
+#include "lt.h"
+
+ double precision s1, s2, m
+ double precision m1, m2, r
+ double complex l1, l2, lm
+
+ double complex Li2omrat, lnrat
+ external Li2omrat, lnrat
+
+ if( lambda .eq. -2 ) then
+ res = 0
+ return
+ endif
+
+ m = Mx(3)
+ s1 = Px(2)
+ s2 = Px(3)
+
+ if( abs(m) .lt. eps ) then
+* qltri2
+ if( DEBUGLEVEL .gt. 1 ) print *, "qltri2"
+ r = .5D0*(s2 - s1)/s1
+ if( abs(r) .lt. acc ) then
+ if( lambda .eq. -1 ) then
+ res = (1 - r*mudim/s1)/s1
+ else
+ res = (lnrat(mudim, -s1)*(1 - r) - r)/s1
+ endif
+ return
+ endif
+ l1 = lnrat(mudim, -s1)
+ l2 = lnrat(mudim, -s2)
+ res = (l1 - l2)/(s1 - s2)
+ if( lambda .ne. -1 ) res = .5D0*(l1 + l2)*res
+ return
+ endif
+
+* qltri3
+ if( DEBUGLEVEL .gt. 1 ) print *, "qltri3"
+ m1 = m - s1
+ m2 = m - s2
+ l1 = lnrat(m1, m)
+ l2 = lnrat(m2, m)
+ lm = lnrat(mudim, m)
+
+ r = .5D0*(s1 - s2)/m1
+ if( abs(r) .lt. acc ) then
+ if( lambda .eq. -1 ) then
+ res = (1 - r)/m1
+ else
+ m = m/s1
+ res = (lm - (m + 1)*(l2 + r) -
+ & r*((m*(m - 2) - 1)*l2 + lm))/m1
+ endif
+ return
+ endif
+
+ res = l2 - l1
+ if( lambda .ne. -1 )
+ & res = (lm - l1 - l2)*res +
+ & Li2omrat(m1, m) - Li2omrat(m2, m)
+ res = res/(s1 - s2)
+ end
+
diff --git a/Looptools/C/Cget.F b/Looptools/C/Cget.F
--- a/Looptools/C/Cget.F
+++ b/Looptools/C/Cget.F
@@ -1,191 +1,207 @@
* Cget.F
* the three-point tensor coefficients
* this file is part of LoopTools
* improvements by M. Rauch
-* last modified 7 Dec 05 th
+* last modified 28 Sep 10 th
#include "defs.h"
integer function XCget(p1, p2, p1p2, m1, m2, m3)
implicit none
DVAR p1, p2, p1p2, m1, m2, m3
#include "lt.h"
integer cachelookup
external cachelookup, XCcoeff
+ integer dummy
+ DVAR dvardummy
+
DVAR para(Pcc)
para(1) = p1
para(2) = p2
para(3) = p1p2
para(4) = m1
+ if( abs(para(4)) .lt. minmass ) para(4) = 0
para(5) = m2
+ if( abs(para(5)) .lt. minmass ) para(5) = 0
para(6) = m3
-
+ if( abs(para(6)) .lt. minmass ) para(6) = 0
XCget = cachelookup(para, Cval(1,0), XCcoeff, RC*Pcc, Ncc)
end
************************************************************************
double complex function XC0i(i, p1, p2, p1p2, m1, m2, m3)
implicit none
integer i
DVAR p1, p2, p1p2, m1, m2, m3
#include "lt.h"
integer XCget
external XCget
integer b
b = XCget(p1, p2, p1p2, m1, m2, m3)
XC0i = Cval(i,b)
end
************************************************************************
subroutine XCcoeff(para, C, ldpara)
implicit none
integer ldpara
DVAR para(ldpara,Pcc)
double complex C(Ncc)
#include "lt.h"
integer XBget
double complex XC0
external XBget, XC0
DVAR p1, p2, p1p2, m1, m2, m3
DVAR f1, f2
QVAR G(2,2)
double complex bsum, b1sum, b00sum, b11sum, in(2)
integer B12, B23, B13
+ logical dump
+
+#ifdef SOLVE_EIGEN
+ QVAR Ginv(2,2)
+#define SOLVE_SETUP XInverse(2, G,2, Ginv,2)
+#define SOLVE(b) XSolve(2, G,2, Ginv,2, b)
+#else
integer perm(2)
- logical dump
+#define IN(i) in(perm(i))
+#define SOLVE_SETUP XDecomp(2, G,2, perm)
+#define SOLVE(b) XSolve(2, G,2, b)
+#endif
+
+#ifdef COMPLEXPARA
+ if( abs(DIMAG(para(1,1))) +
+ & abs(DIMAG(para(1,2))) +
+ & abs(DIMAG(para(1,3))) .gt. 0 )
+ & print *, "Warning: complex momenta not implemented"
+ if( abs(DIMAG(para(1,4))) +
+ & abs(DIMAG(para(1,5))) +
+ & abs(DIMAG(para(1,6))) .eq. 0 ) then
+ call Ccoeff(para, C, 2)
+ return
+ endif
+#endif
p1 = para(1,1)
p2 = para(1,2)
p1p2 = para(1,3)
m1 = para(1,4)
m2 = para(1,5)
m3 = para(1,6)
-#ifdef COMPLEXPARA
- if( DIMAG(p1) .eq. 0 .and.
- & DIMAG(p2) .eq. 0 .and.
- & DIMAG(p1p2) .eq. 0 .and.
- & DIMAG(m1) .eq. 0 .and.
- & DIMAG(m2) .eq. 0 .and.
- & DIMAG(m3) .eq. 0 ) then
- call Ccoeff(para, C, 2)
- return
- endif
-#endif
-
B12 = XBget(p1, m1, m2)
B23 = XBget(p2, m2, m3)
B13 = XBget(p1p2, m1, m3)
serial = serial + 1
dump = ibits(debugkey, DebugC, 1) .ne. 0 .and.
& serial .ge. debugfrom .and. serial .le. debugto
if( dump ) call XDumpPara(3, para, ldpara, "Ccoeff")
- f1 = QEXT(m2) - QEXT(m1) - QEXT(p1)
- f2 = QEXT(m3) - QEXT(m1) - QEXT(p1p2)
+ f1 = QPREC(m2) - QPREC(m1) - QPREC(p1)
+ f2 = QPREC(m3) - QPREC(m1) - QPREC(p1p2)
- G(1,1) = 2*QEXT(p1)
- G(2,2) = 2*QEXT(p1p2)
- G(1,2) = QEXT(p1) + QEXT(p1p2) - QEXT(p2)
+ G(1,1) = 2*QPREC(p1)
+ G(2,2) = 2*QPREC(p1p2)
+ G(1,2) = QPREC(p1) + QPREC(p1p2) - QPREC(p2)
G(2,1) = G(1,2)
- call XLUDecomp(G, 2, perm)
+ call SOLVE_SETUP
bsum = Bval(bb0,B23) + Bval(bb1,B23)
b1sum = Bval(bb1,B23) + Bval(bb11,B23)
b00sum = Bval(bb00,B23) + Bval(bb001,B23)
b11sum = Bval(bb11,B23) + Bval(bb111,B23)
C(cc0) = XC0(p1, p2, p1p2, m1, m2, m3)
- in(1) = f1*C(cc0) - Bval(bb0,B23) + Bval(bb0,B13)
- in(2) = f2*C(cc0) - Bval(bb0,B23) + Bval(bb0,B12)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc0) - Bval(bb0,B23) + Bval(bb0,B13)
+ IN(2) = f2*C(cc0) - Bval(bb0,B23) + Bval(bb0,B12)
+ call SOLVE(in)
C(cc1) = in(1)
C(cc2) = in(2)
C(cc00) = .5D0*(m1*C(cc0) -
& .5D0*(f1*C(cc1) + f2*C(cc2) - Bval(bb0,B23) - 1))
- in(1) = f1*C(cc1) + bsum - 2*C(cc00)
- in(2) = f2*C(cc1) + bsum + Bval(bb1,B12)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc1) + bsum - 2*C(cc00)
+ IN(2) = f2*C(cc1) + bsum + Bval(bb1,B12)
+ call SOLVE(in)
C(cc11) = in(1)
C(cc12) = in(2)
- in(1) = f1*C(cc2) - Bval(bb1,B23) + Bval(bb1,B13)
- in(2) = f2*C(cc2) - Bval(bb1,B23) - 2*C(cc00)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc2) - Bval(bb1,B23) + Bval(bb1,B13)
+ IN(2) = f2*C(cc2) - Bval(bb1,B23) - 2*C(cc00)
+ call SOLVE(in)
C(cc12) = .5D0*(C(cc12) + in(1))
C(cc22) = in(2)
C(cc001) = 1/3D0*(m1*C(cc1) -
& .5D0*(f1*C(cc11) + f2*C(cc12) + bsum + 1/3D0))
C(cc002) = 1/3D0*(m1*C(cc2) -
& .5D0*(f1*C(cc12) + f2*C(cc22) - Bval(bb1,B23) + 1/3D0))
bsum = bsum + b1sum
- in(1) = f1*C(cc11) - bsum - 4*C(cc001)
- in(2) = f2*C(cc11) - bsum + Bval(bb11,B12)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc11) - bsum - 4*C(cc001)
+ IN(2) = f2*C(cc11) - bsum + Bval(bb11,B12)
+ call SOLVE(in)
C(cc111) = in(1)
C(cc112) = in(2)
- in(1) = f1*C(cc22) - Bval(bb11,B23) + Bval(bb11,B13)
- in(2) = f2*C(cc22) - Bval(bb11,B23) - 4*C(cc002)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc22) - Bval(bb11,B23) + Bval(bb11,B13)
+ IN(2) = f2*C(cc22) - Bval(bb11,B23) - 4*C(cc002)
+ call SOLVE(in)
C(cc122) = in(1)
C(cc222) = in(2)
C(cc0000) = 1/4D0*(m1*C(cc00) -
& .5D0*(f1*C(cc001) + f2*C(cc002) - Bval(bb00,B23) -
& (m1 + m2 + m3 - .25D0*(p1 + p2 + p1p2))/6D0))
- in(1) = f1*C(cc001) + b00sum - 2*C(cc0000)
- in(2) = f2*C(cc001) + b00sum + Bval(bb001,B12)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc001) + b00sum - 2*C(cc0000)
+ IN(2) = f2*C(cc001) + b00sum + Bval(bb001,B12)
+ call SOLVE(in)
C(cc0011) = in(1)
C(cc0012) = in(2)
- in(1) = f1*C(cc002) - Bval(bb001,B23) + Bval(bb001,B13)
- in(2) = f2*C(cc002) - Bval(bb001,B23) - 2*C(cc0000)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc002) - Bval(bb001,B23) + Bval(bb001,B13)
+ IN(2) = f2*C(cc002) - Bval(bb001,B23) - 2*C(cc0000)
+ call SOLVE(in)
C(cc0012) = .5D0*(C(cc0012) + in(1))
C(cc0022) = in(2)
bsum = bsum + b1sum + b11sum
- in(1) = f1*C(cc111) + bsum - 6*C(cc0011)
- in(2) = f2*C(cc111) + bsum + Bval(bb111,B12)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc111) + bsum - 6*C(cc0011)
+ IN(2) = f2*C(cc111) + bsum + Bval(bb111,B12)
+ call SOLVE(in)
C(cc1111) = in(1)
C(cc1112) = in(2)
- in(1) = f1*C(cc222) - Bval(bb111,B23) + Bval(bb111,B13)
- in(2) = f2*C(cc222) - Bval(bb111,B23) - 6*C(cc0022)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc222) - Bval(bb111,B23) + Bval(bb111,B13)
+ IN(2) = f2*C(cc222) - Bval(bb111,B23) - 6*C(cc0022)
+ call SOLVE(in)
C(cc1222) = in(1)
C(cc2222) = in(2)
- in(1) = f1*C(cc122) + b11sum - 2*C(cc0022)
- in(2) = f2*C(cc122) + b11sum - 4*C(cc0012)
- call XLUBackSubst(G, 2, perm, in)
+ IN(1) = f1*C(cc122) + b11sum - 2*C(cc0022)
+ IN(2) = f2*C(cc122) + b11sum - 4*C(cc0012)
+ call SOLVE(in)
C(cc1122) = in(1)
C(cc1222) = .5D0*(C(cc1222) + in(2))
if( dump ) call XDumpCoeff(3, C)
end
diff --git a/Looptools/C/ffcc0.F b/Looptools/C/ffcc0.F
--- a/Looptools/C/ffcc0.F
+++ b/Looptools/C/ffcc0.F
@@ -1,1005 +1,1008 @@
+#include "externals.h"
+
+
* $Id: ffcc0.f,v 1.2 1996/06/30 19:03:55 gj Exp $
*###[ ffcc0:
subroutine ffcc0(cc0,cpi,ier)
***#[*comment:***********************************************************
* *
* Calculates the threepoint function closely following *
* recipe in 't Hooft & Veltman, NP B(183) 1979. *
* B&D metric is used throughout! *
* *
* p2 | | *
* v | *
* / \ *
* m2/ \m3 *
* p1 / \ p3 *
* -> / m1 \ <- *
* ------------------------ *
* *
* 1 / 1 *
* = ----- \d^4Q---------------------------------------- *
* ipi^2 / [Q^2-m1^2][(Q+p1)^2-m2^2][(Q-p3)^2-m3^2] *
* *
* If the function is infra-red divergent (p1=m2,p3=m3,m1=0 or *
* cyclic) the function is calculated with a user-supplied cutoff *
* lambda in the common block /ffregul/. *
* *
* the parameter nschem in the common block /fflags/ determines *
* which recipe is followed, see ffinit.f *
* *
* Input: cpi(6) (complex) m1^2,m2^3,p1^2,p2^2,p3^2 *
* of divergences, but C0 has none) *
* /ffregul/ lambda (real) IR cutoff *
* /fflags/..nschem(integer) 6: full complex, 0: real, else: *
* some or all logs *
* /fflags/..nwidth(integer) when |p^2-Re(m^2)| < nwidth|Im(m^2) *
* use complex mass *
* ier (integer) number of digits lost so far *
* Output: cc0 (complex) C0, the threepoint function *
* ier (integer) number of digits lost more than (at *
* most) xloss^5 *
* Calls: ffcc0p,ffcb0p *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cc0,cpi(6)
*
* local variables:
*
integer i,j,init
DOUBLE COMPLEX cdpipj(6,6)
DOUBLE PRECISION xpi(6),sprecx
save init
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data init/0/
*
* #] declarations:
* #[ the real case:
*
* take a faster route if all masses are real or nschem < 3
*
if ( nschem .ge. 3 ) then
do 10 i = 1,6
if ( DIMAG(cpi(i)) .ne. 0 ) goto 30
10 continue
elseif ( init .eq. 0 ) then
init = 1
print *,'ffcc0: disregarding complex masses, nschem= ',
+ nschem
endif
do 20 i = 1,6
xpi(i) = DBLE(cpi(i))
20 continue
sprecx = precx
precx = precc
call ffxc0(cc0,xpi,ier)
precx = sprecx
if ( ldot ) call ffcod3(cpi)
return
30 continue
*
* #] the real case:
* #[ check input:
*
idsub = 0
*
* #] check input:
* #[ convert input:
do 70 i=1,6
cdpipj(i,i) = 0
do 60 j = 1,6
cdpipj(j,i) = cpi(j) - cpi(i)
60 continue
70 continue
* #] convert input:
* #[ call ffcc0a:
call ffcc0a(cc0,cpi,cdpipj,ier)
* #] call ffcc0a:
*###] ffcc0:
end
*###[ ffcc0r:
subroutine ffcc0r(cc0,cpi,ier)
***#[*comment:***********************************************************
* *
* Tries all 2 permutations of the 3pointfunction *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE COMPLEX cc0,cc0p,cpi(6),cqi(6)
integer inew(6,2),irota,ier1,i,j,ialsav
save inew
- include 'ff.h'
+#include "ff.h"
data inew /1,2,3,4,5,6,
+ 1,3,2,6,5,4/
* #] declarations:
* #[ calculations:
cc0 = 0
ier = 999
ialsav = isgnal
do 30 j = -1,1,2
do 20 irota=1,2
do 10 i=1,6
cqi(inew(i,irota)) = cpi(i)
10 continue
print '(a,i1,a,i2)','---#[ rotation ',irota,': isgnal ',
+ isgnal
ier1 = 0
ner = 0
id = id + 1
isgnal = ialsav
call ffcc0(cc0p,cqi,ier1)
ier1 = ier1 + ner
print '(a,i1,a,i2)','---#] rotation ',irota,': isgnal ',
+ isgnal
print '(a,2g28.16,i3)','c0 = ',cc0p,ier1
if ( ier1 .lt. ier ) then
cc0 = cc0p
ier = ier1
endif
20 continue
ialsav = -ialsav
30 continue
* #] calculations:
*###] ffcc0r:
end
*###[ ffcc0a:
subroutine ffcc0a(cc0,cpi,cdpipj,ier)
***#[*comment:***********************************************************
* *
* see ffcc0 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cc0,cpi(6),cdpipj(6,6)
*
* local variables:
*
integer i,j,irota,inew(6,6),i1,i2,i3,initlo,ithres(3),ifound
logical ljust
* DOUBLE COMPLEX cs,cs1,cs2
DOUBLE COMPLEX cqi(6),cqiqj(6,6),cqiDqj(6,6)
DOUBLE PRECISION xqi(6),dqiqj(6,6),qiDqj(6,6),sprec
save initlo
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* memory
*
integer iermem(memory),ialmem(memory),nscmem(memory),memind,
+ ierini
DOUBLE COMPLEX cpimem(6,memory)
DOUBLE COMPLEX cc0mem(memory)
DOUBLE PRECISION dl2mem(memory)
save memind,iermem,ialmem,cpimem,cc0mem
data memind /0/
*
* data
*
data inew /1,2,3,4,5,6,
+ 2,3,1,5,6,4,
+ 3,1,2,6,4,5,
+ 1,3,2,6,5,4,
+ 3,2,1,5,4,6,
+ 2,1,3,4,6,5/
data initlo /0/
*
* #] declarations:
* #[ initialisations:
if ( lmem .and. memind .eq. 0 ) then
do 2 i=1,memory
do 1 j=1,6
cpimem(j,i) = 0
1 continue
ialmem(i) = 0
nscmem(i) = -1
2 continue
endif
idsub = 0
ljust = .FALSE.
* #] initialisations:
* #[ handle special cases:
if ( DIMAG(cpi(1)).eq.0 .and. DIMAG(cpi(2)).eq.0 .and.
+ DIMAG(cpi(3)).eq.0 ) then
do 4 i=1,6
xqi(i) = DBLE(cpi(i))
do 3 j=1,6
dqiqj(j,i) = DBLE(cdpipj(j,i))
3 continue
4 continue
sprec = precx
precx = precc
call ffxc0a(cc0,xqi,dqiqj,ier)
precx = sprec
if ( ldot ) call ffcod3(cpi)
return
endif
* goto 5
* No special cases for the moment...
**
* The infrared divergent diagrams cannot be complex
**
* The general case cannot handle cpi=0, pj=pk. These are simple
* though.
**
* if ( cpi(4) .eq. 0 .and. cdpipj(5,6) .eq. 0 .and. cdpipj(1,2)
* + .ne. 0 ) then
* call ffcb0p(cs1,-cpi(5),cpi(1),cpi(3),cdpipj(1,6),
* + cdpipj(3,5),cdpipj(1,3),ier)
* call ffcb0p(cs2,-cpi(5),cpi(2),cpi(3),cdpipj(2,5),
* + cdpipj(3,5),cdpipj(2,3),ier)
* cs = cs1 - cs2
* cc0 = cs/cdpipj(1,2)
* elseif ( cpi(6) .eq. 0 .and. cdpipj(4,5) .eq. 0 .and.
* + cdpipj(3,1) .ne. 0 ) then
* call ffcb0p(cs1,-cpi(4),cpi(3),cpi(2),cdpipj(3,5),
* + cdpipj(2,4),cdpipj(3,2),ier)
* call ffcb0p(cs2,-cpi(4),cpi(1),cpi(2),cdpipj(1,4),
* + cdpipj(2,4),cdpipj(1,2),ier)
* cs = cs1 - cs2
* cc0 = cs/cdpipj(3,1)
* elseif ( cpi(5) .eq. 0 .and. cdpipj(6,4) .eq. 0 .and.
* + cdpipj(2,3) .ne. 0 ) then
* call ffcb0p(cs1,-cpi(6),cpi(2),cpi(1),cdpipj(2,4),
* + cdpipj(1,6),cdpipj(2,1),ier)
* call ffcb0p(cs2,-cpi(6),cpi(3),cpi(1),cdpipj(3,6),
* + cdpipj(1,6),cdpipj(3,1),ier)
* cs = cs1 - cs2
* cc0 = cs/cdpipj(2,3)
* else
* goto 5
* endif
**
* common piece - excuse my style
**
* print *,'ffcc0: WARNING: this algorithm has not yet been tested'
* if ( absc(cs) .lt. xloss*absc(cs1) )
* + call ffwarn(26,ier,absc(cs),absc(cs1))
**
* return
* 5 continue
* #] handle special cases:
* #[ rotate to alpha in (0,1):
call ffcrt3(irota,cqi,cqiqj,cpi,cdpipj,6,2,ier)
* #] rotate to alpha in (0,1):
* #[ look in memory:
ierini = ier+ner
if ( lmem ) then
do 70 i=1,memory
do 60 j=1,6
if ( cqi(j) .ne. cpimem(j,i) ) goto 70
60 continue
if ( ialmem(i) .ne. isgnal .or.
+ nscmem(i) .ne. nschem ) goto 70
* we found an already calculated masscombination ..
* (maybe check differences as well)
cc0 = cc0mem(i)
ier = ier+iermem(i)
if ( ldot ) then
fodel2 = dl2mem(i)
fdel2 = fodel2
* we forgot to recalculate the stored quantities
ljust = .TRUE.
goto 71
endif
return
70 continue
endif
71 continue
* #] look in memory:
* #[ dot products:
call ffcot3(cqiDqj,cqi,cqiqj,6,ier)
*
* save dotproducts for tensor functions if requested
*
if ( ldot ) then
do 75 i=1,6
do 74 j=1,6
cfpij3(j,i) = cqiDqj(inew(i,irota),inew(j,irota))
74 continue
75 continue
if ( irota .gt. 3 ) then
*
* the signs of the s's have been changed
*
do 77 i=1,3
do 76 j=4,6
cfpij3(j,i) = -cfpij3(j,i)
cfpij3(i,j) = -cfpij3(i,j)
76 continue
77 continue
endif
*
* also give the real dotproducts as reals
*
do 79 i=4,6
do 78 j=4,6
fpij3(j,i) = DBLE(cfpij3(j,i))
78 continue
79 continue
endif
if ( ljust ) return
* #] dot products:
* #[ handle poles-only approach:
sprec = precx
precx = precc
if ( nschem.le.6 ) then
if ( initlo.eq.0 ) then
initlo = 1
if ( nschem.eq.1 .or. nschem.eq.2 ) then
print *,'ffcc0a: disregarding all complex masses'
elseif ( nschem.eq.3 ) then
print *,'ffcc0a: undefined nschem=3'
elseif ( nschem.eq.4 ) then
print *,'ffcc0a: using the scheme in which ',
+ 'complex masses are used everywhere when ',
+ 'there is a divergent log'
elseif ( nschem.eq.5 ) then
print *,'ffcc0a: using the scheme in which ',
+ 'complex masses are used everywhere when ',
+ 'there is a divergent or almost divergent log'
elseif ( nschem.eq.6 ) then
print *,'ffcc0a: using the scheme in which ',
+ 'complex masses are used everywhere when ',
+ 'there is a singular log'
elseif ( nschem.eq.7 ) then
print *,'ffcc0a: using complex masses'
endif
if ( nschem.ge.3 ) then
print *,'ffcc0a: switching to complex when ',
+ '|p^2-Re(m^2)| < ',nwidth,'*|Im(m^2)|'
endif
endif
do 9 i=1,6
xqi(i) = DBLE(cqi(i))
do 8 j=1,6
dqiqj(j,i) = DBLE(cqiqj(j,i))
qiDqj(j,i) = DBLE(cqiDqj(j,i))
8 continue
9 continue
i1 = 0
ithres(1) = 0
ithres(2) = 0
ithres(3) = 0
if ( nschem.le.2 ) goto 21
*
do 10 i1=1,3
*
* search for a combination of 2 almost on-shell particles
* and a light one
*
i2 = mod(i1,3)+1
i3 = mod(i2,3)+1
call ffbglg(ifound,cqi,cqiqj,cqiDqj,6,i1,i2,i3,i1+3,
+ i3+3)
if ( ifound .ne. 0 ) goto 11
10 continue
i1 = 0
11 continue
if ( nschem.ge.4 .and. i1.ne.0 ) goto 30
if ( nschem.le.3 ) goto 21
*
do 20 i=1,3
i2 = mod(i,3)+1
call ffthre(ithres(i),cqi,cqiqj,6,i,i2,i+3)
20 continue
*
if ( nschem.eq.5 .and. (ithres(1).eq.2 .or.
+ ithres(2).eq.2 .or. ithres(3).eq.2) ) goto 30
if ( nschem.eq.6 .and. (ithres(1).eq.1 .or.
+ ithres(2).eq.1 .or. ithres(3).eq.1) ) goto 30
*
21 continue
*
* The infrared divergent diagrams are calculated in ffxc0i:
*
if ( dqiqj(2,4).eq.0 .and. dqiqj(3,6).eq.0 .and. xqi(1).eq.0
+ .or. dqiqj(3,5).eq.0 .and. dqiqj(1,4).eq.0 .and. xqi(2).eq.0
+ .or. dqiqj(1,6).eq.0 .and. dqiqj(2,5).eq.0 .and. xqi(3).eq.0
+ ) then
call ffxc0i(cc0,xqi,dqiqj,ier)
else
call ffxc0b(cc0,xqi,dqiqj,qiDqj,ier)
endif
* the dotproducts are already set, but I forgot this
if ( ldot ) fodel2 = fdel2
goto 31
*
* the complex case
*
30 continue
precx = sprec
call ffcc0b(cc0,cqi,cqiqj,cqiDqj,ier)
31 continue
*
* #] handle poles-only approach:
* #[ call ffcc0b:
else
precx = sprec
call ffcc0b(cc0,cqi,cqiqj,cqiDqj,ier)
endif
* #] call ffcc0b:
* #[ add to memory:
if ( lmem ) then
memind = memind + 1
if ( memind .gt. memory ) memind = 1
do 200 j=1,6
cpimem(j,memind) = cqi(j)
200 continue
cc0mem(memind) = cc0
iermem(memind) = ier+ner-ierini
ialmem(memind) = isgnal
nscmem(memind) = nschem
dl2mem(memind) = fodel2
endif
* #] add to memory:
*###] ffcc0a:
end
*###[ ffcc0b:
subroutine ffcc0b(cc0,cqi,cqiqj,cqiDqj,ier)
***#[*comment:***********************************************************
* *
* see ffcc0 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer nerr
parameter (nerr=6)
*
* arguments
*
DOUBLE COMPLEX cc0,cqi(6),cqiqj(6,6),cqiDqj(6,6)
integer ier
*
* local variables:
*
integer isoort(8),ipi12(8),i,j,k,ipi12t,ilogi(3),ier0,ieri(nerr)
DOUBLE COMPLEX cs3(80),cs,cs1,cs2,cslam,c,cel2,cel3,cel2s(3),
+ cel3mi(3),clogi(3),calph(3),cblph(3),cetalm,cetami(6),
+ csdel2,celpsi(3)
DOUBLE PRECISION xmax,absc,del2,qiDqj(6,6)
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function:
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ calculations:
*
* some determinants
*
do 98 i = 1,nerr
ieri(i) = 0
98 continue
do 104 i=4,6
do 103 j=4,6
qiDqj(j,i) = DBLE(cqiDqj(j,i))
103 continue
104 continue
call ffdel2(del2,qiDqj,6,4,5,6,1,ier)
fodel2 = del2
fdel2 = fodel2
cel2 = DCMPLX(DBLE(del2))
- call ffcel3(cel3,cqi,cqiDqj,6,ier)
+ call ffcel3(cel3,cqiDqj)
if ( DIMAG(cel3).ne.0 .and.
+ abs(DIMAG(cel3)).lt.precc*abs(DBLE(cel3)) ) then
cel3 = DBLE(cel3)
endif
call ffcl3m(cel3mi,.TRUE.,cel3,cel2,cqi,cqiqj,cqiDqj,6, 4,5,6,
+ 1,3)
do 105 i=1,3
j = i+1
if ( j .eq. 4 ) j = 1
call ffcel2(cel2s(i),cqiDqj,6,i+3,i,j,1,ieri(i))
k = i-1
if ( k .eq. 0 ) k = 3
call ffcl2p(celpsi(i),cqi,cqiqj,cqiDqj,i+3,j+3,k+3,i,j,k,6)
105 continue
cetalm = cel3*DBLE(1/del2)
do 108 i=1,3
cetami(i) = cel3mi(i)*DBLE(1/del2)
108 continue
csdel2 = isgnal*DBLE(sqrt(-del2))
ier0 = 0
do 99 i=1,nerr
ier0 = max(ier0,ieri(i))
99 continue
ier = ier + ier0
*
* initialize cs3:
*
do 80 i=1,80
cs3(i) = 0
80 continue
do 90 i=1,8
ipi12(i) = 0
90 continue
*
* get alpha,1-alpha
*
call ffcoot(cblph(1),calph(1),cqi(5),-cqiDqj(5,6),cqi(6),csdel2,
+ ier)
call ffcoot(calph(3),cblph(3),cqi(5),-cqiDqj(5,4),cqi(4),csdel2,
+ ier)
cs1 = cblph(1) - chalf
cs2 = calph(1) - chalf
if ( l4also .and. ( DBLE(calph(1)) .gt. 1 .or. DBLE(calph(1))
+ .lt. 0 ) .and. absc(cs1) .lt. absc(cs2) ) then
calph(1) = cblph(1)
calph(3) = cblph(3)
csdel2 = -csdel2
isgnal = -isgnal
endif
cslam = 2*csdel2
*
* and the calculations
*
call ffcc0p(cs3,ipi12,isoort,clogi,ilogi,cqi,cqiqj,cqiDqj,
+ csdel2,cel2s,cetalm,cetami,celpsi,calph,3,ier)
*
* sum'em up:
*
cs = 0
xmax = 0
do 110 i=1,80
cs = cs + cs3(i)
xmax = max(xmax,absc(cs))
110 continue
ipi12t = ipi12(1)
do 120 i=2,8
ipi12t = ipi12t + ipi12(i)
120 continue
cs = cs + ipi12t*DBLE(pi12)
*
* check for imaginary part zero (this may have to be dropped)
*
if ( abs(DIMAG(cs)) .lt. precc*abs(DBLE(cs)) )
+ cs = DCMPLX(DBLE(cs))
cc0 = - cs/cslam
* #] calculations:
*###] ffcc0b:
end
*###[ ffcrt3:
subroutine ffcrt3(irota,cqi,cdqiqj,cpi,cdpipj,ns,iflag,ier)
***#[*comment:***********************************************************
* *
* rotates the arrays cpi, cdpipj into cqi,cdqiqj so that *
* cpi(6),cpi(4) suffer the strongest outside cancellations and *
* cpi(6) > cpi(4) if iflag = 1, so that cpi(5) largest and cpi(5) *
* and cpi(6) suffer cancellations if iflag = 2. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer irota,ns,iflag,ier
DOUBLE COMPLEX cpi(ns),cdpipj(ns,ns),cqi(ns),cdqiqj(ns,ns)
*
* local variables
*
DOUBLE PRECISION a1,a2,a3,xpimax,absc
DOUBLE COMPLEX c
integer i,j,inew(6,6)
save inew
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data inew /1,2,3,4,5,6,
+ 2,3,1,5,6,4,
+ 3,1,2,6,4,5,
+ 1,3,2,6,5,4,
+ 3,2,1,5,4,6,
+ 2,1,3,4,6,5/
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ get largest cancellation:
if ( iflag .eq. 1 ) then
a1 = absc(cdpipj(6,4))/max(absc(cpi(6)+cpi(4)),xclogm)
a2 = absc(cdpipj(5,4))/max(absc(cpi(5)+cpi(4)),xclogm)
a3 = absc(cdpipj(5,6))/max(absc(cpi(6)+cpi(5)),xclogm)
if ( a1 .le. a2 .and. a1 .le. a3 ) then
if ( absc(cpi(6)) .lt. absc(cpi(4)) ) then
irota = 4
else
irota = 1
endif
elseif ( a2 .le. a3 ) then
if ( absc(cpi(4)) .lt. absc(cpi(5)) ) then
irota = 6
else
irota = 3
endif
else
if ( absc(cpi(5)) .lt. absc(cpi(6)) ) then
irota = 5
else
irota = 2
endif
endif
elseif ( iflag .eq. 2 ) then
xpimax = max(DBLE(cpi(4)),DBLE(cpi(5)),DBLE(cpi(6)))
if ( xpimax .eq. 0 ) then
if ( DBLE(cpi(5)) .ne. 0 ) then
irota = 1
elseif ( DBLE(cpi(4)) .ne. 0 ) then
irota = 2
elseif ( DBLE(cpi(6)) .ne. 0 ) then
irota = 3
else
call fferr(40,ier)
return
endif
elseif ( DBLE(cpi(5)) .eq. xpimax ) then
if ( DBLE(cpi(4)) .le. DBLE(cpi(6)) ) then
irota = 1
else
irota = 4
endif
elseif ( DBLE(cpi(4)) .eq. xpimax ) then
if ( DBLE(cpi(5)) .ge. DBLE(cpi(6)) ) then
irota = 2
else
irota = 5
endif
else
if ( DBLE(cpi(4)) .ge. DBLE(cpi(6)) ) then
irota = 3
else
irota = 6
endif
endif
else
call fferr(35,ier)
endif
* #] get largest cancellation:
* #[ rotate:
do 20 i=1,6
cqi(inew(i,irota)) = cpi(i)
do 10 j=1,6
cdqiqj(inew(i,irota),inew(j,irota)) = cdpipj(i,j)
10 continue
20 continue
* #] rotate:
*###] ffcrt3:
end
*###[ ffcot3:
subroutine ffcot3(cpiDpj,cpi,cdpipj,ns,ier)
***#[*comment:***********************************************************
* *
* calculate the dotproducts pi.pj with *
* *
* pi = si i1=1,3 *
* pi = p(i-3) i1=4,6 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ns,ier
DOUBLE COMPLEX cpi(ns),cdpipj(ns,ns),cpiDpj(ns,ns)
*
* locals
*
integer is1,is2,is3,ip1,ip2,ip3,ier1
DOUBLE COMPLEX c
DOUBLE PRECISION absc
*
* rest
*
- include 'ff.h'
+#include "ff.h"
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ calculations:
*
ier1 = 0
do 10 is1=1,3
is2 = is1 + 1
if ( is2 .eq. 4 ) is2 = 1
is3 = is2 + 1
if ( is3 .eq. 4 ) is3 = 1
ip1 = is1 + 3
ip2 = is2 + 3
ip3 = is3 + 3
*
* pi.pj, si.sj
*
cpiDpj(is1,is1) = cpi(is1)
cpiDpj(ip1,ip1) = cpi(ip1)
*
* si.s(i+1)
*
if ( absc(cdpipj(is1,ip1)) .le. absc(cdpipj(is2,ip1)) ) then
cpiDpj(is1,is2) = (cdpipj(is1,ip1) + cpi(is2))/2
else
cpiDpj(is1,is2) = (cdpipj(is2,ip1) + cpi(is1))/2
endif
cpiDpj(is2,is1) = cpiDpj(is1,is2)
*
* pi.si
*
if ( absc(cdpipj(is2,is1)) .le. absc(cdpipj(is2,ip1)) ) then
cpiDpj(ip1,is1) = (cdpipj(is2,is1) - cpi(ip1))/2
else
cpiDpj(ip1,is1) = (cdpipj(is2,ip1) - cpi(is1))/2
endif
cpiDpj(is1,ip1) = cpiDpj(ip1,is1)
*
* pi.s(i+1)
*
if ( absc(cdpipj(is2,is1)) .le. absc(cdpipj(ip1,is1)) ) then
cpiDpj(ip1,is2) = (cdpipj(is2,is1) + cpi(ip1))/2
else
cpiDpj(ip1,is2) = (cdpipj(ip1,is1) + cpi(is2))/2
endif
cpiDpj(is2,ip1) = cpiDpj(ip1,is2)
*
* pi.s(i+2)
*
if ( (absc(cdpipj(is2,is1)) .le. absc(cdpipj(ip3,is1)) .and.
+ absc(cdpipj(is2,is1)) .le. absc(cdpipj(is2,ip2))) .or.
+ (absc(cdpipj(ip3,ip2)) .le. absc(cdpipj(ip3,is1)) .and.
+ absc(cdpipj(ip3,ip2)).le.absc(cdpipj(is2,ip2))))then
cpiDpj(ip1,is3) = (cdpipj(ip3,ip2)+cdpipj(is2,is1))/2
else
cpiDpj(ip1,is3) = (cdpipj(ip3,is1)+cdpipj(is2,ip2))/2
endif
cpiDpj(is3,ip1) = cpiDpj(ip1,is3)
*
* pi.p(i+1)
*
if ( absc(cdpipj(ip3,ip1)) .le. absc(cdpipj(ip3,ip2)) ) then
cpiDpj(ip1,ip2) = (cdpipj(ip3,ip1) - cpi(ip2))/2
else
cpiDpj(ip1,ip2) = (cdpipj(ip3,ip2) - cpi(ip1))/2
endif
cpiDpj(ip2,ip1) = cpiDpj(ip1,ip2)
10 continue
ier = ier + ier1
* #] calculations:
*###] ffcot3:
end
*###[ ffbglg:
subroutine ffbglg(ifound,cqi,cqiqj,cqiDqj,ns,i1,i2,i3,ip1,ip3)
***#[*comment:***********************************************************
* *
* Find a configuration which contains big logs, i.e. terms which *
* would be IR divergent but for the finite width effects. *
* We also use the criterium that delta^{s1 s2 s[34]}_{s1 s2 s[34]}*
* should not be 0 when m^2 is shifted over nwidth*Im(m^2) *
* *
* Input: cqi(ns) (complex) masses, p^2 *
* cqiqj(ns,ns) (complex) diff cqi(i)-cqi(j) * *
* cqiDqj(ns,ns) (complex) cqi(i).cqi(j) * *
* ns (integer) size of cqi,cqiqj *
* i1,i2,i3 (integer) combo to be tested *
* small,~onshell,~onshell *
* ip1,ip3 (integer) (i1,i2) and (i1,i3) inx *
* Output: ifound (integer) 0: no divergence, 1: IR *
* -1: del(s,s,s)~0 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ifound,ns,i1,i2,i3,ip1,ip3
DOUBLE COMPLEX cqi(ns),cqiqj(ns,ns),cqiDqj(ns,ns)
*
* locals vars
*
integer i123
DOUBLE PRECISION absc
DOUBLE COMPLEX cel3,cdm2,cdm3,c
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ work:
ifound = 0
if ( abs(DBLE(cqi(i1))) .lt. -xloss*(DIMAG(cqi(i2)) +
+ DIMAG(cqi(i3)))
+ .and. abs(DBLE(cqiqj(ip1,i2))) .le. -nwidth*DIMAG(cqi(i2))
+ .and. abs(DBLE(cqiqj(ip3,i3))) .le. -nwidth*DIMAG(cqi(i3))
+ ) then
ifound = 1
return
endif
if ( nschem.ge.5 .and. cqi(i1).eq.0 ) then
i123 = 2**i1 + 2**i2 + 2**i3
if ( i123.eq.2**1+2**2+2**3 .or. i123.eq.2**1+2**2+2**4 )
+ then
cel3 = - cqiDqj(i1,i2)**2*cqi(i3)
+ - cqiDqj(i1,i3)**2*cqi(i2)
+ + 2*cqiDqj(i1,i2)*cqiDqj(i1,i3)*cqiDqj(i2,i3)
cdm2 = cqiDqj(i1,i2)*cqiDqj(ip3,i3) +
+ cqiDqj(i1,i3)*cqiDqj(ip1,i3)
cdm3 = -cqiDqj(i1,i2)*cqiDqj(ip3,i2) -
+ cqiDqj(i1,i3)*cqiDqj(ip1,i2)
if ( 2*absc(cel3) .lt.-nwidth*(absc(cdm2)*DIMAG(cqi(i2))
+ + absc(cdm3)*DIMAG(cqi(i3))) ) then
ifound = -1
endif
endif
endif
* #] work:
*###] ffbglg:
end
*###[ ffthre:
subroutine ffthre(ithres,cqi,cqiqj,ns,i1,i2,ip)
***#[*comment:***********************************************************
* *
* look for threshold effects. *
* ithres = 1: 3 heavy masses *
* ithres = 2: 2 masses almost equal and 1 zero *
* *
* Input: cqi(ns) (complex) usual masses,p^2 *
* cqiqj(ns,ns) (complex) cqi(i)-cqi(j) *
* ns (integer) size *
* i1,i2 (integer) position to be tested *
* ip (integer) (i1,i2) index *
* *
* Output: ithres (integer) see above, 0 if nothing *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ithres,ns,i1,i2,ip
DOUBLE COMPLEX cqi(ns),cqiqj(ns,ns)
*
* local variables
*
integer ier0
DOUBLE COMPLEX c
DOUBLE PRECISION absc,xq1,xq2,xq3,dq1q2,dq1q3,dq2q3,xlam,d1,d2,
+ sprecx
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ work:
ithres = 0
if ( DIMAG(cqi(i1)).eq.0 .and. DIMAG(cqi(i2)).eq.0 .or.
+ nschem.le.4 ) return
if ( DBLE(cqi(i1)).lt.-DIMAG(cqi(i2)) .and.
+ abs(DBLE(cqiqj(ip,i2))).lt.-nwidth*DIMAG(cqi(i2))
+ .or. DBLE(cqi(i2)).lt.-DIMAG(cqi(i1)) .and.
+ abs(DBLE(cqiqj(ip,i1))).lt.-nwidth*DIMAG(cqi(i1)) ) then
ithres = 2
elseif ( nschem.ge.6 .and. DBLE(cqi(i1)).ne.0 .and.
+ DBLE(cqi(i2)).ne.0 ) then
ier0 = 0
xq1 = DBLE(cqi(i1))
xq2 = DBLE(cqi(i2))
xq3 = DBLE(cqi(ip))
dq1q2 = DBLE(cqiqj(i1,i2))
dq1q3 = DBLE(cqiqj(i1,ip))
dq2q3 = DBLE(cqiqj(i2,ip))
sprecx = precx
precx = precc
call ffxlmb(xlam,xq1,xq2,xq3, dq1q2,dq1q3,dq2q3)
precx = sprecx
d1 = absc(cqiqj(i1,ip) - cqi(i2))
d2 = absc(cqiqj(i2,ip) - cqi(i1))
* if ( d1 .lt. -nwidth*DIMAG(cqi(i1)) .or.
** + d2 .lt. -nwidth*DIMAG(cqi(i2)) )
** + call ffwarn(182,ier0,x1,x1)
if ( abs(xlam) .lt. -nwidth*(DBLE(d1)*
+ DIMAG(cqi(i1)) + d2*DIMAG(cqi(i2))) ) then
ithres = 1
endif
endif
* #] work:
*###] ffthre:
end
*###[ ffcod3:
subroutine ffcod3(cpi)
***#[*comment:***********************************************************
* *
* Convert real dorproducts into complex ones, adding the *
* imaginary parts where appropriate. *
* *
* Input: cpi(6) complex m^2, p^2 *
* /ffdots/fpij3(6,6) real p.p real *
* *
* Output: /ffcots/cfpij3(6,6) complex p.p complex *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cpi(6)
*
* local variables
*
integer i,i1,i2,ip
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ add widths:
*
do 25 i=1,3
ip = i+3
i1 = 1 + mod(i,3)
i2 = 1 + mod(i1,3)
* s.s
cfpij3(i,i) = cpi(i)
cfpij3(i1,i) = DCMPLX(DBLE(fpij3(i1,i)),
+ (DIMAG(cpi(i1))+DIMAG(cpi(i)))/2)
cfpij3(i,i1) = cfpij3(i1,i)
* s.p
cfpij3(i,ip) = DCMPLX(DBLE(fpij3(i,ip)),
+ (DIMAG(cpi(i1))-DIMAG(cpi(i)))/2)
cfpij3(ip,i) = cfpij3(i,ip)
cfpij3(i1,ip) = DCMPLX(DBLE(fpij3(i1,ip)),
+ (DIMAG(cpi(i1))-DIMAG(cpi(i)))/2)
cfpij3(ip,i1) = cfpij3(i1,ip)
cfpij3(i2,ip) = DCMPLX(DBLE(fpij3(i2,ip)),
+ (DIMAG(cpi(i1))-DIMAG(cpi(i)))/2)
cfpij3(ip,i2) = cfpij3(i2,ip)
* p.p
cfpij3(ip,ip) = cpi(ip)
cfpij3(ip,i1+3) = fpij3(ip,i1+3)
cfpij3(i1+3,ip) = cfpij3(ip,i1+3)
25 continue
fodel2 = fdel2
*
* #] add widths:
*###] ffcod3:
end
diff --git a/Looptools/C/ffcc0p.F b/Looptools/C/ffcc0p.F
--- a/Looptools/C/ffcc0p.F
+++ b/Looptools/C/ffcc0p.F
@@ -1,441 +1,444 @@
+#include "externals.h"
+
+
*###[ ffcc0p:
subroutine ffcc0p(cs3,ipi12,isoort,clogi,ilogi,cpi,cpipj,
+ cpiDpj,sdel2,cel2si,etalam,etami,delpsi,alpha,npoin,ier)
***#[*comment:***********************************************************
* *
* Calculates the threepoint function closely following *
* recipe in 't Hooft & Veltman, NP B(183) 1979. *
* Bjorken and Drell metric is used nowadays! *
* *
* p2 ^ | *
* | | *
* / \ *
* m2/ \m3 *
* p1 / \ p3 *
* <- / m1 \ -> *
* ------------------------ *
* *
* Input: cpi(1-3) (complex) pi squared (,2=untransformed *
* when npoin=4) *
* cpi(4-6) (complex) internal mass squared *
* cpipj(6,6) (complex) cpi(i)-cpi(j) *
* cpiDpj(6,6) (complex) pi(i).pi(j) *
* *
* Output: cs3 (complex)(48) C0, not yet summed. *
* ipi12 (integer)(3) factors pi^2/12, not yet summed *
* cslam (complex) lambda(p1,p2,p3). *
* isoort (integer)(3) indication of he method used *
* ier (integer) 0=ok, 1=inaccurate, 2=error *
* *
* Calls: ffcel2,ffcoot,ffccyz,ffcdwz,ffcs3,ffcs4 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(8),isoort(8),ilogi(3),npoin,ier
DOUBLE COMPLEX cs3(80),clogi(3),cpi(6),cpipj(6,6),
+ cpiDpj(6,6),sdel2,cel2si(3),etalam,etami(6),
+ delpsi(3),alpha(3)
*
* local variables:
*
integer i,j,k,ip,ierw,jsoort(8),iw,ismall(3)
logical l4,l4pos
DOUBLE COMPLEX c,cs,zfflog,cs1,cs2,cs4
DOUBLE COMPLEX cy(4,3),cz(4,3),cw(4,3),cdyz(2,2,3),
+ cdwy(2,2,3),cdwz(2,2,3),cd2yzz(3),cd2yww(3)
DOUBLE COMPLEX csdl2i(3)
* DOUBLE COMPLEX cyp,cym,ca,cb,cc,cd
DOUBLE COMPLEX zfflo1
DOUBLE PRECISION absc
external zfflo1,zfflog
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ get roots etc:
* #[ get z-roots:
if ( npoin .ne. 3 ) then
l4pos = .FALSE.
else
l4pos = l4also
endif
do 10 i=1,3
*
* get roots (y,z)
*
ip = i+3
* first get the roots
j = i+1
if ( j .eq. 4 ) j = 1
csdl2i(i) = sqrt(-cel2si(i))
if ( cpi(ip) .eq. 0 ) then
if ( i .eq. 1 .and. alpha(3) .eq. 0 .or.
+ i .eq. 3 .and. alpha(1) .eq. 0 ) then
isoort(2*i-1) = 0
isoort(2*i) = 0
l4pos = .FALSE.
goto 10
endif
endif
call ffccyz(cy(1,i),cz(1,i),cdyz(1,1,i),cd2yzz(i),i,
+ sdel2,csdl2i(i),etalam,etami,delpsi(i),
+ cpi,cpiDpj,isoort(2*i-1),ier)
10 continue
* #] get z-roots:
* #[ get w-roots:
*
* get w's:
*
ierw = 0
l4 = .FALSE.
if ( isoort(4) .eq. 0 ) then
call fferr(10,ierw)
goto 90
endif
do 70 iw = 1,3,2
if ( .not. l4pos .or. alpha(4-iw) .eq. 0 ) then
jsoort(2*iw-1) = 0
jsoort(2*iw) = 0
l4pos = .FALSE.
else
jsoort(2*iw-1) = -1
jsoort(2*iw) = -1
cd2yww(iw) = -cd2yzz(2)/alpha(4-iw)
do 20 j=1,2
cw(j+iw-1,iw) = cz(j+3-iw,2)/alpha(4-iw)
cw(j+3-iw,iw) = 1 - cw(j+iw-1,iw)
if ( absc(cw(j+3-iw,iw)) .lt. xloss ) then
cs = cz(j+iw-1,2) - alpha(iw)
if ( absc(cs) .lt. xloss*absc(alpha(iw)) ) then
ierw = 1
goto 70
endif
cw(j+3-iw,iw) = cs/alpha(4-iw)
endif
cdwy(j,2,iw) = cdyz(2,j,2)/alpha(4-iw)
do 15 i=1,2
cdwz(j,i,iw) = cw(j,iw) - cz(i,iw)
if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cw(j,iw)) )
+ goto 14
cdwz(j,i,iw) = cz(i+2,iw) - cw(j+2,iw)
if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cw(j+2,iw)) )
+ goto 14
cdwz(j,i,iw) = cdwy(j,2,iw) + cdyz(2,i,iw)
if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cdwy(j,2,iw)) )
+ goto 14
l4 = .TRUE.
call ffcdwz(cdwz(1,1,iw),cz(1,iw),j,i,iw,
+ alpha(1),alpha(3),cpi,cpipj,cpiDpj,csdl2i,
+ sdel2,6,ierw)
14 continue
15 continue
20 continue
endif
70 continue
* #] get w-roots:
* #[ which case:
90 if ( l4 ) then
if ( DIMAG(alpha(1)) .ne. 0 ) then
l4pos = .FALSE.
elseif ( ierw .ge. 1 ) then
l4pos = .FALSE.
else
ier = max(ier,ierw)
endif
endif
* #] which case:
* #] get roots etc:
* #[ logarithms for 4point function:
if ( npoin .eq. 4 ) then
do 95 i = 1,3
ismall(i) = 0
if ( ilogi(i) .ne. -999 ) goto 95
if ( isoort(2*i) .ne. 0 ) then
* maybe add sophisticated factors i*pi later
c = -cdyz(2,1,i)/cdyz(2,2,i)
if ( absc(c-1) .lt. xloss ) then
cs = cd2yzz(i)/cdyz(2,2,i)
clogi(i) = zfflo1(cs,ier)
ilogi(i) = 0
ismall(i) = 1
elseif ( DBLE(c) .gt. 0 ) then
clogi(i) = zfflog(c,0,czero,ier)
ilogi(i) = 0
else
if ( absc(c+1) .lt. xloss ) then
cs = -2*csdl2i(i)/cdyz(2,2,i)/
+ DBLE(cpi(i+3))
clogi(i) = zfflo1(cs,ier)
ismall(i) = -1
else
cs = 0
clogi(i) = zfflog(-c,0,czero,ier)
endif
if ( DIMAG(c).lt.0 .or. DIMAG(cs).lt.0 ) then
ilogi(i) = -1
elseif ( DIMAG(c).gt.0 .or. DIMAG(cs).gt.0 ) then
ilogi(i) = +1
elseif ( DBLE(cdyz(2,2,i)) .eq. 0 ) then
ilogi(i)=-nint(sign(1D0,DBLE(cpi(i+3))))
ier = ier + 50
print *,'doubtful imaginary part ',ilogi(i)
endif
if ( abs(DIMAG(c)).lt.precc*absc(c) .and.
+ abs(DIMAG(cs)).lt.precc*absc(cs) ) then
print *,'ffcc0p: error: imaginary part doubtful'
ier = ier + 50
endif
endif
endif
95 continue
do 96 i=1,3
j = i + 1
if ( j .eq. 4 ) j = 1
if ( abs(ismall(i)+ismall(j)) .eq. 2 .and. absc(clogi(i)+
+ clogi(j)) .lt. xloss*absc(clogi(i)) ) then
* assume that we got here because of complex sqrt(-delta)
cs1=-2*cI*DIMAG(cy(2,i))*csdl2i(j)/DBLE(cpi(j+3))/
+ (cdyz(2,2,i)*cdyz(2,2,j))
cs2=-2*cI*DIMAG(cy(2,j))*csdl2i(i)/DBLE(cpi(i+3))/
+ (cdyz(2,2,i)*cdyz(2,2,j))
cs = cs1 + cs2
if ( absc(cs) .lt. xloss*absc(cs1) ) then
k = j+1
if ( k .eq. 4 ) k = 1
cs1 = cpipj(j+3,i+3)*cpi(j)
cs2 = cpiDpj(k+3,j)*cpiDpj(j+3,j)
cs4 = -cpiDpj(k+3,j)*cpiDpj(i+3,j)
cs = cs1 + cs2 + cs4
if ( absc(cs) .lt. xloss*max(absc(cs1),absc(cs2),
+ absc(cs4)) ) then
print *,'ffcc0p: cancellations in delj-deli'
goto 96
endif
cs1 = cI*DIMAG(cy(2,j))*cs/(csdl2i(i)+csdl2i(j))
call ffcl2t(cs2,cpiDpj,k+3,j,4,5,6,+1,-1,6)
cs2 = -cs2*csdl2i(j)/sdel2/DBLE(cpi(j+3))
cs = cs1 + cs2
if ( absc(cs) .lt. xloss*absc(cs1) ) then
print *,'ffcc0p: cancellations in extra terms'
goto 96
endif
cs = -2*cs/DBLE(cpi(i+3))/(cdyz(2,2,i)*
+ cdyz(2,2,j))
endif
clogi(i) = zfflo1(cs,ier)
clogi(j) = 0
endif
96 continue
endif
* #] logarithms for 4point function:
* #[ integrals:
if ( .not. l4 .or. .not. l4pos ) then
* normal case
do 200 i=1,3
j = 2*i-1
if ( isoort(2*i-1) .ne. 0 ) then
call ffcs3(cs3(20*i-19),ipi12(2*i-1),cy(1,i),
+ cz(1,i),cdyz(1,1,i),cd2yzz(i),cpi,cpiDpj,
+ i,6,isoort(j),ier)
endif
200 continue
isoort(7) = 0
isoort(8) = 0
else
isoort(3) = jsoort(1)
isoort(4) = jsoort(2)
call ffcs4(cs3(1),ipi12(1),cw(1,1),cy(1,1),
+ cz(1,1),cdwy(1,1,1),cdwz(1,1,1),cdyz(1,1,1),
+ cd2yww(1),cd2yzz(1),cpi,cpiDpj,
+ cpi(5)*alpha(3)**2,1,6,isoort(1),ier)
isoort(7) = jsoort(5)
isoort(8) = jsoort(6)
call ffcs4(cs3(41),ipi12(1),cw(1,3),cy(1,3),
+ cz(1,3),cdwy(1,1,3),cdwz(1,1,3),cdyz(1,1,3),
+ cd2yww(3),cd2yzz(3),cpi,cpiDpj,
+ cpi(5)*alpha(1)**2,3,6,isoort(5),ier)
endif
* #] integrals:
*###] ffcc0p:
end
*###[ ffccyz:
subroutine ffccyz(cy,cz,cdyz,cd2yzz,ivert,csdelp,csdels,etalam,
+ etami,delps,xpi,piDpj,isoort,ier)
***#[*comment:***********************************************************
* *
* calculate in a numerically stable way *
* *
* cz(1,2) = (-p(ip1).p(is2) +/- csdelp)/xpi(ip1) *
* cy(1,2) = (-p(ip1).p(is2) +/- sdisc)/xpi(ip1) *
* cdisc = csdels + etaslam*xpi(ip1) *
* *
* cy(3,4) = 1-cy(1,2) *
* cz(3,4) = 1-cz(1,2) *
* cdyz(i,j) = cy(i) - cz(j) *
* *
* Input: ivert (integer) defines the vertex *
* csdelp (complex) sqrt(lam(p1,p2,p3))/2 *
* csdels (complex) sqrt(lam(p,ma,mb))/2 *
* etalam (complex) det(si.sj)/det(pi.pj) *
* etami(6) (complex) si.si - etalam *
* xpi(ns) (complex) standard *
* piDpj(ns,ns) (complex) standard *
* ns (integer) dim of xpi,piDpj *
* *
* Output: cy(4),cz(4),cdyz(4,4) (complex) see above *
* ier (integer) usual error flag *
* *
* Calls: fferr,ffroot *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ivert,ier,isoort(2)
DOUBLE COMPLEX cy(4),cz(4),cdyz(2,2),cd2yzz,csdelp,csdels
DOUBLE COMPLEX etalam,etami(6),delps,xpi(6),piDpj(6,6)
*
* local variables:
*
integer ip1,is1,is2,is3
DOUBLE COMPLEX cdisc,c
DOUBLE PRECISION absc
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ set up pointers:
is1 = ivert
is2 = ivert+1
if ( is2 .eq. 4 ) is2 = 1
is3 = ivert-1
if ( is3 .eq. 0 ) is3 = 3
ip1 = is1 + 3
* #] set up pointers:
* #[ xk = 0:
if ( xpi(ip1) .eq. 0 ) then
isoort(2) = 0
if ( piDpj(is1,ip1) .eq. 0 ) then
isoort(1) = 0
return
endif
if ( DIMAG(etalam).ne.0 ) then
isoort(1) = -1
else
isoort(1) = -3
endif
cy(1) = etami(is2) / piDpj(is1,ip1) /2
cy(2) = cy(1)
cy(3) = - etami(is1) / piDpj(is1,ip1) /2
cy(4) = cy(3)
cz(1) = xpi(is2) / piDpj(is1,ip1) /2
cz(2) = cz(1)
cz(3) = - xpi(is1) / piDpj(is1,ip1) /2
cz(4) = cz(3)
cdyz(1,1) = - etalam / piDpj(is1,ip1) /2
cdyz(1,2) = cdyz(1,1)
cdyz(2,1) = cdyz(1,1)
cdyz(2,2) = cdyz(1,1)
return
endif
* #] xk = 0:
* #[ get cy(1,2),cz(1,2):
if ( DIMAG(etalam).ne.0 ) then
isoort(1) = -1
isoort(2) = -1
else
isoort(1) = -3
isoort(2) = -3
endif
call ffcoot(cz(1),cz(2),xpi(ip1),piDpj(ip1,is2),xpi(is2),
+ csdels,ier)
cdisc = delps/csdelp
call ffcoot(cy(1),cy(2),xpi(ip1),piDpj(ip1,is2),etami(is2),
+ cdisc,ier)
* #] get cy(1,2),cz(1,2):
* #[ get cy(3,4),cz(3,4):
cz(4) = 1-cz(2)
cz(3) = 1-cz(1)
if ( absc(cz(3)) .lt. xloss .or. absc(cz(4)) .lt. xloss ) then
call ffcoot(cz(4),cz(3),xpi(ip1),-piDpj(ip1,is1),
+ xpi(is1),csdels,ier)
endif
* the imaginary part may not be accurate in these cases, take
* some precautions:
if ( cz(3) .eq. 0 ) cz(1) = 1
if ( cz(4) .eq. 0 ) cz(2) = 1
if ( DIMAG(cz(1)).eq.0 )
+ cz(1) = DCMPLX(DBLE(cz(1)),-DIMAG(cz(3)))
if ( DIMAG(cz(2)).eq.0 )
+ cz(2) = DCMPLX(DBLE(cz(2)),-DIMAG(cz(4)))
if ( DIMAG(cz(1)) .gt. 0 .neqv. DIMAG(cz(3)) .lt. 0 ) then
if ( abs(DBLE(cz(1))) .ge. abs(DBLE(cz(3))) ) then
cz(1) = DCMPLX(DBLE(cz(1)),-DIMAG(cz(3)))
else
cz(3) = DCMPLX(DBLE(cz(3)),-DIMAG(cz(1)))
endif
endif
if ( DIMAG(cz(2)) .gt. 0 .neqv. DIMAG(cz(4)) .lt. 0 ) then
if ( abs(DBLE(cz(2))) .ge. abs(DBLE(cz(4))) ) then
cz(2) = DCMPLX(DBLE(cz(2)),-DIMAG(cz(4)))
else
cz(4) = DCMPLX(DBLE(cz(4)),-DIMAG(cz(2)))
endif
endif
cy(4) = 1-cy(2)
cy(3) = 1-cy(1)
if ( absc(cy(3)) .lt. xloss .or. absc(cy(4)) .lt. xloss ) then
call ffcoot(cy(4),cy(3),xpi(ip1),-piDpj(ip1,is1),
+ etami(is1),cdisc,ier)
endif
if ( cy(3) .eq. 0 ) cy(1) = 1
if ( cy(4) .eq. 0 ) cy(2) = 1
if ( DIMAG(cy(1)).eq.0 )
+ cy(1) = DCMPLX(DBLE(cy(1)),-DIMAG(cy(3)))
if ( DIMAG(cy(2)).eq.0 )
+ cy(2) = DCMPLX(DBLE(cy(2)),-DIMAG(cy(4)))
if ( DIMAG(cy(1)) .gt. 0 .neqv. DIMAG(cy(3)) .lt. 0 ) then
if ( abs(DBLE(cy(1))) .ge. abs(DBLE(cy(3))) ) then
cy(1) = DCMPLX(DBLE(cy(1)),-DIMAG(cy(3)))
else
cy(3) = DCMPLX(DBLE(cy(3)),-DIMAG(cy(1)))
endif
endif
if ( DIMAG(cy(2)) .gt. 0 .neqv. DIMAG(cy(4)) .lt. 0 ) then
if ( abs(DBLE(cy(2))) .ge. abs(DBLE(cy(4))) ) then
cy(2) = DCMPLX(DBLE(cy(2)),-DIMAG(cy(4)))
else
cy(4) = DCMPLX(DBLE(cy(4)),-DIMAG(cy(2)))
endif
endif
* #] get cy(3,4),cz(3,4):
* #[ get cdyz:
* Note that cdyz(i,j) only exists for i,j=1,2!
if ( absc(cdisc+csdels) .gt. xloss*absc(cdisc) ) then
cdyz(2,1) = ( cdisc + csdels )/xpi(ip1)
cdyz(2,2) = etalam/(xpi(ip1)*cdyz(2,1))
else
cdyz(2,2) = ( cdisc - csdels )/xpi(ip1)
cdyz(2,1) = etalam/(xpi(ip1)*cdyz(2,2))
endif
cdyz(1,1) = -cdyz(2,2)
cdyz(1,2) = -cdyz(2,1)
cd2yzz = 2*cdisc/xpi(ip1)
* #] get cdyz:
*###] ffccyz:
end
diff --git a/Looptools/C/ffcel3.F b/Looptools/C/ffcel3.F
--- a/Looptools/C/ffcel3.F
+++ b/Looptools/C/ffcel3.F
@@ -1,256 +1,120 @@
+#include "externals.h"
+
+
*###[ ffcel3:
- subroutine ffcel3(del3,xpi,piDpj,ns,ier)
+ subroutine ffcel3(del3,piDpj)
***#[*comment:***********************************************************
* *
* Calculate del3(piDpj) = det(si.sj) with *
* the momenta as follows: *
* p(1-3) = s(i) *
* p(4-6) = p(i) *
* *
-* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
-* piDpj(ns,ns) (real) *
-* ns (integer) *
-* ier (integer) *
+* Input: piDpj(6,6) (real) *
* *
* Output: del3 (real) det(si.sj) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
- integer ns,ier
- DOUBLE COMPLEX del3,xpi(6),piDpj(6,6)
+ DOUBLE COMPLEX del3,piDpj(6,6)
*
* local variables:
*
integer mem,nperm
parameter(mem=10,nperm=16)
integer i,jj(6),iperm(3,nperm),imem,memarr(mem,3),memind,inow
DOUBLE COMPLEX s(6),del3p,cc
DOUBLE PRECISION xmax,xmaxp,absc
save iperm,memind,memarr,inow
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
* #] declarations:
* #[ data:
data memind /0/
data memarr /mem*0,mem*0,mem*1/
data inow /1/
*
* these are all permutations that give a non-zero result with the
* correct sign. This list was generated with getperm3.
*
data iperm/
+ 1,2,3, 1,2,5, 1,6,2, 1,4,3,
+ 1,3,5, 1,4,5, 1,6,4, 1,5,6,
+ 2,4,3, 2,3,6, 2,4,5, 2,6,4,
+ 2,5,6, 3,4,5, 3,6,4, 3,5,6/
* #] data:
* #[ starting point in memory?:
*
* see if we know were to start, if not: go on as last time
*
do 5 i=1,mem
if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
inow = memarr(i,3)
goto 6
endif
5 continue
6 continue
* #] starting point in memory?:
* #[ calculations:
imem = inow
del3 = 0
xmax = 0
10 continue
jj(1) = iperm(1,inow)
jj(3) = iperm(2,inow)
jj(5) = iperm(3,inow)
jj(2) = iperm(1,inow)
jj(4) = iperm(2,inow)
jj(6) = iperm(3,inow)
s(1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(6))
s(2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(2))
s(3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(4))
s(4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(4))
s(5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(2))
s(6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(6))
del3p = 0
xmaxp = 0
do 20 i=1,6
del3p = del3p + s(i)
xmaxp = max(xmaxp,absc(s(i)))
20 continue
if ( absc(del3p) .lt. xloss*xmaxp ) then
if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
del3 = del3p
xmax = xmaxp
endif
inow = inow + 1
if ( inow .gt. nperm ) inow = 1
if ( inow .eq. imem ) then
goto 800
endif
goto 10
endif
del3 = del3p
xmax = xmaxp
* #] calculations:
* #[ into memory:
800 continue
memind = memind + 1
if ( memind .gt. mem ) memind = 1
memarr(memind,1) = id
memarr(memind,2) = idsub
memarr(memind,3) = inow
* #] into memory:
*###] ffcel3:
end
-*(##[ ffcl3s:
- subroutine ffcl3s(dl3s,xpi,piDpj,ii,ns,ier)
-***#[*comment:***********************************************************
-* *
-* Calculate dl3s(piDpj) = det(si.sj) with *
-* the momenta indicated by the indices ii(1-6,1), ii(1-6,2) *
-* as follows: *
-* p(|ii(1,)|-|ii(3,)|) = s(i) *
-* p(|ii(4,)|-|ii(6,)|) = p(i) = sgn(ii())*(s(i+1) - s(i)) *
-* *
-* At this moment (26-apr-1990) only the diagonal is tried *
-* *
-* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
-* piDpj(ns,ns) (real) *
-* ii(6,2) (integer) see above *
-* ns (integer) *
-* ier (integer) *
-* *
-* Output: dl3s (real) det(si.sj) *
-* *
-***#]*comment:***********************************************************
-* #[ declarations:
- implicit none
-*
-* arguments:
-*
- integer ii(6,2),ns,ier
- DOUBLE COMPLEX dl3s,xpi(ns),piDpj(ns,ns)
-*
-* local variables:
-*
- integer mem,nperm
- parameter(mem=10,nperm=16)
- integer i,jj(6),jsgn,iperm(3,nperm),imem,memarr(mem,3),
- + memind,inow
- DOUBLE PRECISION xmax,xmaxp,absc
- DOUBLE COMPLEX s(6),dl3sp,cc
- save iperm,memind,memarr,inow
-*
-* common blocks:
-*
- include 'ff.h'
-*
-* statement function
-*
- absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
-*
-* #] declarations:
-* #[ data:
-*
- data memind /0/
- data memarr /mem*0,mem*0,mem*1/
- data inow /1/
-*
-* these are all permutations that give a non-zero result with the
-* correct sign. This list was generated with getperm3.
-*
- data iperm/
- + 1,2,3, 1,2,5, 1,6,2, 1,4,3,
- + 1,3,5, 1,4,5, 1,6,4, 1,5,6,
- + 2,4,3, 2,3,6, 2,4,5, 2,6,4,
- + 2,5,6, 3,4,5, 3,6,4, 3,5,6/
-* #] data:
-* #[ starting point in memory?:
-*
-* see if we know were to start, if not: go on as last time
-*
- do 5 i=1,mem
- if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
- inow = memarr(i,3)
- goto 6
- endif
- 5 continue
- 6 continue
-* #] starting point in memory?:
-* #[ calculations:
- imem = inow
- dl3s = 0
- xmax = 0
-
- 10 continue
-
- jj(1) = abs(ii(iperm(1,inow),1))
- jj(3) = abs(ii(iperm(2,inow),1))
- jj(5) = abs(ii(iperm(3,inow),1))
-
- jj(2) = abs(ii(iperm(1,inow),2))
- jj(4) = abs(ii(iperm(2,inow),2))
- jj(6) = abs(ii(iperm(3,inow),2))
-
- jsgn = sign(1,ii(iperm(1,inow),1))
- + *sign(1,ii(iperm(2,inow),1))
- + *sign(1,ii(iperm(3,inow),1))
- + *sign(1,ii(iperm(1,inow),2))
- + *sign(1,ii(iperm(2,inow),2))
- + *sign(1,ii(iperm(3,inow),2))
-
- s(1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(6))
- s(2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(2))
- s(3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(4))
- s(4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(4))
- s(5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(2))
- s(6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(6))
-
- dl3sp = 0
- xmaxp = 0
- do 20 i=1,6
- dl3sp = dl3sp + s(i)
- xmaxp = max(xmaxp,absc(s(i)))
- 20 continue
- if ( absc(dl3sp) .lt. xloss*xmaxp ) then
- if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
- dl3s = jsgn*dl3sp
- xmax = xmaxp
- endif
- inow = inow + 1
- if ( inow .gt. nperm ) inow = 1
- if ( inow .eq. imem ) then
- goto 800
- endif
- goto 10
- endif
- dl3s = jsgn*dl3sp
- xmax = xmaxp
-* #] calculations:
-* #[ into memory:
- 800 continue
- memind = memind + 1
- if ( memind .gt. mem ) memind = 1
- memarr(memind,1) = id
- memarr(memind,2) = idsub
- memarr(memind,3) = inow
-* #] into memory:
-*)##] ffcl3s:
- end
diff --git a/Looptools/C/ffdel3.F b/Looptools/C/ffdel3.F
--- a/Looptools/C/ffdel3.F
+++ b/Looptools/C/ffdel3.F
@@ -1,241 +1,244 @@
+#include "externals.h"
+
+
*###[ ffdel3:
subroutine ffdel3(del3,piDpj)
***#[*comment:***********************************************************
* *
* Calculate del3(piDpj) = det(si.sj) with *
* the momenta as follows: *
* p(1-3) = s(i) *
* p(4-6) = p(i) *
* *
* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
* piDpj(ns,ns) (real) *
* ns (integer) *
* ier (integer) *
* *
* Output: del3 (real) det(si.sj) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
DOUBLE PRECISION del3,piDpj(6,6)
*
* local variables:
*
integer mem,nperm
parameter(mem=10,nperm=16)
integer i,jj(6),iperm(3,nperm),imem,memarr(mem,3),memind,inow
DOUBLE PRECISION s(6),xmax,del3p,xmaxp
save iperm,memind,memarr,inow
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ data:
data memind /0/
data memarr /mem*0,mem*0,mem*1/
data inow /1/
*
* these are all permutations that give a non-zero result with the
* correct sign. This list was generated with getperm3.
*
data iperm/
+ 1,2,3, 1,2,5, 1,6,2, 1,4,3,
+ 1,3,5, 1,4,5, 1,6,4, 1,5,6,
+ 2,4,3, 2,3,6, 2,4,5, 2,6,4,
+ 2,5,6, 3,4,5, 3,6,4, 3,5,6/
* #] data:
* #[ starting point in memory?:
*
* see if we know were to start, if not: go on as last time
*
do 5 i=1,mem
if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
inow = memarr(i,3)
goto 6
endif
5 continue
6 continue
* #] starting point in memory?:
* #[ calculations:
imem = inow
del3 = 0
xmax = 0
10 continue
jj(1) = iperm(1,inow)
jj(3) = iperm(2,inow)
jj(5) = iperm(3,inow)
jj(2) = iperm(1,inow)
jj(4) = iperm(2,inow)
jj(6) = iperm(3,inow)
s(1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(6))
s(2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(2))
s(3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(4))
s(4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(4))
s(5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(2))
s(6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(6))
del3p = 0
xmaxp = 0
do 20 i=1,6
del3p = del3p + s(i)
xmaxp = max(xmaxp,abs(s(i)))
20 continue
if ( abs(del3p) .lt. xloss*xmaxp ) then
if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
del3 = del3p
xmax = xmaxp
endif
inow = inow + 1
if ( inow .gt. nperm ) inow = 1
if ( inow .eq. imem ) goto 800
goto 10
endif
del3 = del3p
xmax = xmaxp
* #] calculations:
* #[ into memory:
800 continue
memind = memind + 1
if ( memind .gt. mem ) memind = 1
memarr(memind,1) = id
memarr(memind,2) = idsub
memarr(memind,3) = inow
* #] into memory:
*###] ffdel3:
end
*(##[ ffdl3s:
subroutine ffdl3s(dl3s,piDpj,ii,ns)
***#[*comment:***********************************************************
* *
* Calculate dl3s(piDpj) = det(si.sj) with *
* the momenta indicated by the indices ii(1-6,1), ii(1-6,2) *
* as follows: *
* p(|ii(1,)|-|ii(3,)|) = s(i) *
* p(|ii(4,)|-|ii(6,)|) = p(i) = sgn(ii())*(s(i+1) - s(i)) *
* *
* At this moment (26-apr-1990) only the diagonal is tried *
* *
* Input: xpi(ns) (real) m^2(i),i=1,3; p^2(i-3),i=4,10 *
* piDpj(ns,ns) (real) *
* ii(6,2) (integer) see above *
* ns (integer) *
* ier (integer) *
* *
* Output: dl3s (real) det(si.sj) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ii(6,2),ns
DOUBLE PRECISION dl3s,piDpj(ns,ns)
*
* local variables:
*
integer mem,nperm
parameter(mem=10,nperm=16)
integer i,jj(6),jsgn,iperm(3,nperm),imem,memarr(mem,3),
+ memind,inow
DOUBLE PRECISION s(6),xmax,dl3sp,xmaxp
save iperm,memind,memarr,inow
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ data:
data memind /0/
data memarr /mem*0,mem*0,mem*1/
data inow /1/
*
* these are all permutations that give a non-zero result with the
* correct sign. This list was generated with getperm3.
*
data iperm/
+ 1,2,3, 1,2,5, 1,6,2, 1,4,3,
+ 1,3,5, 1,4,5, 1,6,4, 1,5,6,
+ 2,4,3, 2,3,6, 2,4,5, 2,6,4,
+ 2,5,6, 3,4,5, 3,6,4, 3,5,6/
* #] data:
* #[ starting point in memory?:
*
* see if we know were to start, if not: go on as last time
*
do 5 i=1,mem
if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
inow = memarr(i,3)
goto 6
endif
5 continue
6 continue
* #] starting point in memory?:
* #[ calculations:
imem = inow
dl3s = 0
xmax = 0
10 continue
jj(1) = abs(ii(iperm(1,inow),1))
jj(3) = abs(ii(iperm(2,inow),1))
jj(5) = abs(ii(iperm(3,inow),1))
jj(2) = abs(ii(iperm(1,inow),2))
jj(4) = abs(ii(iperm(2,inow),2))
jj(6) = abs(ii(iperm(3,inow),2))
jsgn = sign(1,ii(iperm(1,inow),1))
+ *sign(1,ii(iperm(2,inow),1))
+ *sign(1,ii(iperm(3,inow),1))
+ *sign(1,ii(iperm(1,inow),2))
+ *sign(1,ii(iperm(2,inow),2))
+ *sign(1,ii(iperm(3,inow),2))
s(1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(6))
s(2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(2))
s(3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(4))
s(4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*piDpj(jj(5),jj(4))
s(5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*piDpj(jj(5),jj(2))
s(6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*piDpj(jj(5),jj(6))
dl3sp = 0
xmaxp = 0
do 20 i=1,6
dl3sp = dl3sp + s(i)
xmaxp = max(xmaxp,abs(s(i)))
20 continue
if ( abs(dl3sp) .lt. xloss*xmaxp ) then
if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
dl3s = jsgn*dl3sp
xmax = xmaxp
endif
inow = inow + 1
if ( inow .gt. nperm ) inow = 1
if ( inow .eq. imem ) goto 800
goto 10
endif
dl3s = jsgn*dl3sp
xmax = xmaxp
* #] calculations:
* #[ into memory:
800 continue
memind = memind + 1
if ( memind .gt. mem ) memind = 1
memarr(memind,1) = id
memarr(memind,2) = idsub
memarr(memind,3) = inow
* #] into memory:
*)##] ffdl3s:
end
diff --git a/Looptools/C/ffdxc0.F b/Looptools/C/ffdxc0.F
--- a/Looptools/C/ffdxc0.F
+++ b/Looptools/C/ffdxc0.F
@@ -1,816 +1,817 @@
+#include "externals.h"
+
+
*###[ ffdxc0:
subroutine ffdxc0(cs3,ipi12,isoort,clogi,ilogi,xpi,dpipj,piDpj,
+ xqi,qiDqj,sdel2,del2s,etalam,etami,delpsi,alph,
+ ddel2s,ldel2s,npoin,ier)
***#[*comment:***********************************************************
* *
* Calculates the difference of two threepoint functions *
* C(3,...a) - C(4,...b) *
* For this we not only calculate the roots of the three-point *
* function y,z(1-4,3-4,1-3) but also the combinations *
* *
* yzzy = y(,4,)*z(,3,) - z(,4,)*y(,3,) *
* and *
* yyzz = y(,4,) - z(,4,) - y(,3,) + z(,3,) *
* *
* This is done explicitly for most special cases, so a lot of *
* lines of code result. This may be shortened with a smart use *
* of indices, however, it is readable now. *
* *
* Input: xpi(6,3:4) (real) transformed mi,pi squared in Ci *
* dpipj(6,6,3:4) (real) xpi(i)-xpi(j) *
* piDpj(6,6,3:4) (real) pi(i).pi(j) *
* xqi(10,10) (real) transformed mi,pi squared in D *
* qiDqj(10,10) (real) qi(i).qi(j) *
* sdel2 (real) sqrt(delta_{p_1 p_2}^{p_1 p_2}) *
* del2s(3,3:4) (real) delta_{p_i s_i}^{p_i s_i} *
* etalam(3:4) (real) delta_{s_1 s_2 s_3}^{s_1 s_2 s_3}
* /delta_{p_1 p_2}^{p_1 p_2} *
* etami(6,3:4) (real) m_i^2 - etalam *
* ddel2s(2:3) (real) del2s(i,3) - del2s(i,4) *
* alph(3) (real) alph(1)=alpha, alph(3)=1-alpha *
* ldel2s (logical) indicates yes/no limit del2s->0 *
* *
* Output: cs3 (complex)(160) C0(3)-C0(4), not yet summed. *
* ipi12 (integer)(6) factors pi^2/12, not yet summed *
* slam (complex) lambda(p1,p2,p3). *
* isoort (integer)(16) indication of he method used *
* clogi (complex)(6) log(-dyz(2,1,i)/dyz(2,2,i)) *
* ilogi (integer)(6) factors i*pi in this *
* ier (integer) 0=ok, 1=inaccurate, 2=error *
* *
* Calls: ... *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(16),isoort(16),ilogi(6),npoin,ier
logical ldel2s
DOUBLE COMPLEX cs3(160),clogi(6)
DOUBLE PRECISION xqi(10),qiDqj(10,10),
+ xpi(6,3:4),dpipj(6,6,3:4),piDpj(6,6,3:4),
+ sdel2,del2s(3,3:4),etalam(3:4),etami(6,3:4),alph(3),
+ ddel2s(2:3),delpsi(3,3:4)
*
* local variables:
*
integer i,j,k,l,ip,ier0,ii,ifirst,ieri(12),idone(6)
logical lcompl
DOUBLE COMPLEX c,csom,cs(5),csdeli(3,3:4),csdel2,
+ cy(4,3:4,3),cz(4,3:4,3),cdyz(2,2,3:4,3),cd2yzz(3:4,3),
+ cpi(6,3:4),cpiDpj(6,6,3:4),cdyzzy(4,3),cdyyzz(2,3)
DOUBLE PRECISION sdel2i(3,3:4),s(5),som,smax,absc,dfflo1,
+ y(4,3:4,3),z(4,3:4,3),dyz(2,2,3:4,3),d2yzz(3:4,3),
+ dy2z(4,3:4,3),dyzzy(4,3),dsdel2,xmax
DOUBLE COMPLEX zxfflg,zfflo1
external dfflo1,zxfflg,zfflo1
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ get y,z-roots:
lcompl = .FALSE.
do 20 k=3,4
do 10 i=1,3
*
* get roots (y,z) and flag what to do: 0=nothing, 1=normal,
* -1=complex
*
ip = i+3
* first get the roots
if ( del2s(i,k) .le. 0 ) then
* real case
sdel2i(i,k) = sqrt(-del2s(i,k))
* then handle the special case Si = 0
if ( xpi(ip,k) .eq. 0 ) then
if ( i .eq. 1 .and. alph(3) .eq. 0 .or.
+ i .eq. 3 .and. alph(1) .eq. 0 ) then
isoort(2*i-1+8*(k-3)) = 0
isoort(2*i+8*(k-3)) = 0
goto 10
endif
endif
call ffxxyz(y(1,k,i),z(1,k,i),dyz(1,1,k,i),d2yzz(k,i),
+ dy2z(1,k,i),i,sdel2,sdel2i(i,k),etalam(k),etami(1,k),
+ delpsi(i,k),xpi(1,k),dpipj(1,1,k),piDpj(1,1,k),
+ isoort(2*i-1+8*(k-3)),ldel2s,6,ier)
else
* complex case
sdel2i(i,k) = sqrt(del2s(i,k))
csdeli(i,k) = DCMPLX(0D0,sdel2i(i,k))
lcompl = .TRUE.
call ffcxyz(cy(1,k,i),cz(1,k,i),cdyz(1,1,k,i),cd2yzz(k,i),i,
+ sdel2,sdel2i(i,k),etami(1,k),delpsi(i,k),xpi(
+ 1,k),piDpj(1,1,k),isoort(2*i-1+8*(k-3)),ldel2s,6,ier)
endif
10 continue
20 continue
* #] get y,z-roots:
* #[ convert to complex if necessary:
do 60 i=2,3
l = 2*i-1
if ( isoort(l).gt.0 .and. isoort(l+8).lt.0 ) then
k = 3
* we get -5, -105 if they have equal roots, isoort=+2
* -6, -106 if they have unequal roots, isoort=+1
if ( .not.ldel2s ) then
isoort(l) = isoort(l)-7
isoort(l+1) = isoort(l+1)-7
else
isoort(l) = isoort(l)-207
isoort(l+1) = isoort(l+1)-207
endif
elseif ( isoort(l).lt.0 .and. isoort(l+8).gt.0 ) then
k = 4
if ( .not.ldel2s ) then
isoort(l+8) = isoort(l+8)-7
isoort(l+9) = isoort(l+9)-7
else
isoort(l+8) = isoort(l+8)-207
isoort(l+9) = isoort(l+9)-207
endif
else
k = 0
endif
if ( k .ne. 0 ) then
do 30 j=1,4
cy(j,k,i) = y(j,k,i)
cz(j,k,i) = z(j,k,i)
30 continue
do 50 j=1,2
do 40 l=1,2
cdyz(l,j,k,i) = dyz(l,j,k,i)
40 continue
50 continue
cd2yzz(k,i) = d2yzz(k,i)
csdeli(i,k) = sdel2i(i,k)
endif
60 continue
* #] convert to complex if necessary:
* #[ get differences:
*
* the only important differences are y4z3-z3y4 and (1-y4)(1-z3)-
* (1-y3)(1-z4)
*
do 100 i=1,12
ieri(i) = 0
100 continue
* #[ vertices (1):
som = qiDqj(7,2)/sdel2
if ( isoort(1) .ge. 0 ) then
* Note that the isoorts are equal as the vertex is equal.
*
* flag if we have a cancellation
*
if ( abs(som) .lt. xloss ) then
isoort(1) = isoort(1) + 10
isoort(9) = isoort(9) + 10
endif
do 110 k=1,4
dyzzy(k,1) = som*z(k,3,1)
if ( k .gt. 2 ) dyzzy(k,1) = -dyzzy(k,1)
110 continue
else
if ( abs(som) .lt. xloss ) then
isoort(1) = isoort(1) - 10
isoort(9) = isoort(9) - 10
endif
do 120 k=1,4
cdyzzy(k,1) = DBLE(som)*cz(k,3,1)
if ( k .gt. 2 ) cdyzzy(k,1) = -cdyzzy(k,1)
120 continue
cdyyzz(1,1) = som
cdyyzz(2,1) = som
endif
* #] vertices (1):
* #[ vertices (2):
if ( isoort(3) .ge. 0 ) then
* #[ real case: (note that this implies isoort(11)>0)
ifirst = 0
do 150 j=1,2
do 140 k=1,2
ii = 2*(j-1) + k
dyzzy(ii,2) = y(2*j,4,2)*z(ii,3,2)-y(2*j,3,2)*z(ii,4,2)
xmax = abs(y(2*j,4,2)*z(ii,3,2))
if ( abs(dyzzy(ii,2)) .ge. xmax ) goto 140
isoort(3) = isoort(3) + 10
isoort(11) = isoort(11) + 10
- 1000 format(a,i1,a,g22.14,g12.4)
if ( ldel2s ) then
print *,'ffdxc0: not ready for del2s=0, real case'
goto 130
endif
if ( ifirst .le. 0 ) then
if ( ddel2s(2) .eq. 0 ) then
dsdel2 = 0
else
dsdel2 = ddel2s(2)/(sdel2i(2,3)+sdel2i(2,4))
endif
endif
if ( ifirst .le. 1 ) then
if ( j .eq. 1 ) then
s(1) = xqi(6)*qiDqj(7,4)*qiDqj(5,4)/sdel2
s(2) = -qiDqj(7,4)*sdel2i(2,3)
s(3) = +qiDqj(6,4)*dsdel2
else
s(1) = xqi(6)*qiDqj(7,2)*qiDqj(5,2)/sdel2
s(2) = -qiDqj(7,2)*sdel2i(2,3)
s(3) = +qiDqj(6,2)*dsdel2
endif
endif
if ( ifirst .le. 0 ) then
ifirst = 2
s(4) = -qiDqj(5,10)*qiDqj(7,4)*sdel2i(2,3)/sdel2
s(5) = delpsi(2,3)*dsdel2/sdel2
endif
if ( k .eq. 1 ) then
som = s(1) + s(2) + s(3) + s(4) + s(5)
else
som = s(1) - s(2) - s(3) - s(4) - s(5)
endif
smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ abs(s(5)))/xqi(6)**2
if ( smax .lt. xmax ) then
dyzzy(ii,2) = som/xqi(6)**2
xmax = smax
endif
130 continue
140 continue
ifirst = ifirst - 1
150 continue
* #] real case:
else
* #[ complex case:
ifirst = 0
do 180 j=1,2
do 170 k=1,2
ii = 2*(j-1) + k
cdyzzy(ii,2) = cy(2*j,4,2)*cz(ii,3,2)-cy(2*j,3,2)*
+ cz(ii,4,2)
xmax = absc(cy(2*j,4,2)*cz(ii,3,2))
if ( absc(cdyzzy(ii,2)) .ge. xmax ) goto 170
isoort(3) = isoort(3) - 10
isoort(11) = isoort(11) - 10
- 1002 format(a,i1,a,2g22.14,g12.4)
if ( ldel2s ) then
ip = 3
else
ip = 6
endif
if ( mod(isoort(3),10).ne.0 .or. mod(isoort(11),10).ne.0
+ ) then
*
* one of the roots is really real
*
if ( ifirst .le. 0 ) then
csdel2=DBLE(ddel2s(2))/(csdeli(2,3)+csdeli(2,4))
endif
if ( ifirst .le. 1 ) then
if ( j .eq. 1 .neqv. ldel2s ) then
if ( .not.ldel2s ) then
cs(1)=xqi(6)*qiDqj(7,4)*qiDqj(5,4)/sdel2
cs(2) = -DBLE(qiDqj(7,4))*csdeli(2,3)
cs(3) = +DBLE(qiDqj(6,4))*csdel2
else
cs(1)=-xqi(3)*qiDqj(5,10)*qiDqj(7,2)/
+ sdel2
cs(2) = -DBLE(qiDqj(7,2))*csdeli(2,3)
cs(3) = -DBLE(qiDqj(6,3))*csdel2
endif
else
cs(1) = xqi(ip)*qiDqj(7,2)*qiDqj(5,2)/sdel2
cs(2) = -DBLE(qiDqj(7,2))*csdeli(2,3)
cs(3) = +DBLE(qiDqj(ip,2))*csdel2
endif
endif
if ( ifirst .le. 0 ) then
ifirst = 2
if ( .not.ldel2s ) then
cs(4) = -DBLE(qiDqj(5,10)*qiDqj(7,4)/sdel2)*
+ csdeli(2,3)
else
cs(4) = -DBLE(qiDqj(5,3)*qiDqj(7,2)/sdel2)*
+ csdeli(2,3)
endif
cs(5) = DBLE(delpsi(2,3)/sdel2)*csdel2
endif
else
*
* both roots are complex
*
if ( ifirst .eq. 0 ) then
dsdel2 = -ddel2s(2)/(sdel2i(2,3)+sdel2i(2,4))
csdel2 = DCMPLX(0D0,dsdel2)
endif
if ( ifirst .le. 1 ) then
if ( j .eq. 1 .neqv. ldel2s ) then
if ( .not.ldel2s ) then
cs(1)=xqi(6)*qiDqj(7,4)*qiDqj(5,4)/sdel2
cs(2)=-DCMPLX(0D0,qiDqj(7,4)*sdel2i(2,3))
cs(3)=+DCMPLX(0D0,qiDqj(6,3)*dsdel2)
else
cs(1)=-xqi(3)*qiDqj(5,10)*qiDqj(7,2)/
+ sdel2
cs(2)=-DCMPLX(0D0,qiDqj(7,2)*sdel2i(2,3))
cs(3)=-DCMPLX(0D0,qiDqj(6,3)*dsdel2)
endif
else
cs(1) = xqi(ip)*qiDqj(7,2)*qiDqj(5,2)/sdel2
cs(2) = -DCMPLX(0D0,qiDqj(7,2)*sdel2i(2,3))
cs(3) = +DCMPLX(0D0,qiDqj(ip,2)*dsdel2)
endif
endif
if ( ifirst .eq. 0 ) then
ifirst = 2
if ( .not.ldel2s ) then
cs(4) = -DCMPLX(0D0,qiDqj(5,10)*qiDqj(7,4)*
+ sdel2i(2,3)/sdel2)
else
cs(4) = -DCMPLX(0D0,qiDqj(5,3)*qiDqj(7,2)*
+ sdel2i(2,3)/sdel2)
endif
cs(5) = DCMPLX(0D0,delpsi(2,3)*dsdel2/sdel2)
endif
endif
if ( k .eq. 1 ) then
csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
else
csom = cs(1) - cs(2) - cs(3) - cs(4) - cs(5)
endif
smax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
+ absc(cs(4)),absc(cs(5)))/xqi(ip)**2
if ( smax .lt. xmax ) then
cdyzzy(ii,2) = csom/DBLE(xqi(ip))**2
xmax = smax
endif
170 continue
*
* get cdyyzz
*
if ( ldel2s ) then
cdyyzz(j,2) = cdyz(2,j,4,2) - cdyz(2,j,3,2)
xmax = absc(cdyz(2,j,4,2))
if ( absc(cdyyzz(j,2)) .ge. xloss*xmax ) goto 175
if ( ifirst .le. 0 ) then
if ( mod(isoort( 3),10).ne.0 .or.
+ mod(isoort(11),10).ne.0 ) then
csdel2=DBLE(ddel2s(2))/(csdeli(2,3)+csdeli(2,4))
else
dsdel2 = -ddel2s(2)/(sdel2i(2,3)+sdel2i(2,4))
csdel2 = DCMPLX(0D0,dsdel2)
endif
endif
cs(2) = csdel2/DBLE(xqi(3))
cs(1) = qiDqj(5,3)*qiDqj(7,2)/(sdel2*xqi(3))
if ( j .eq. 1 ) then
csom = cs(1) + cs(2)
else
csom = cs(1) - cs(2)
endif
smax = absc(cs(1))
if ( smax .lt. xmax ) then
cdyyzz(j,2) = csom
xmax = smax
endif
endif
*
* bookkeeping
*
175 continue
ifirst = ifirst - 1
180 continue
* #] complex case:
endif
* #] vertices (2):
* #[ vertices (3):
if ( isoort(5) .ge. 0 ) then
* #[ real case: (note that this implies isoort(15)>0)
ifirst = 0
do 210 j=1,2
do 200 k=1,2
ii = 2*(j-1) + k
dyzzy(ii,3) = y(2*j,4,3)*z(ii,3,3)-y(2*j,3,3)*z(ii,4,3)
xmax = abs(y(2*j,4,3)*z(ii,3,3))
if ( abs(dyzzy(ii,3)) .ge. xmax ) goto 200
isoort(5) = isoort(5) + 10
isoort(13) = isoort(13) + 10
if ( ldel2s ) then
print *,'ffdxc0: not ready for del2s=0, real case'
goto 190
endif
if ( ifirst .le. 0 ) then
if ( ddel2s(2) .eq. 0 ) then
dsdel2 = 0
else
dsdel2 = ddel2s(3)/(sdel2i(3,3)+sdel2i(3,4))
endif
endif
if ( ifirst .le. 1 ) then
if ( j .eq. 1 ) then
s(1) = xqi(8)*qiDqj(7,1)*qiDqj(5,1)/sdel2
s(2) = +qiDqj(7,1)*sdel2i(3,3)
s(3) = +qiDqj(9,1)*dsdel2
else
s(1) = xqi(8)*qiDqj(7,4)*qiDqj(5,4)/sdel2
s(2) = +qiDqj(7,4)*sdel2i(3,3)
s(3) = +qiDqj(9,4)*dsdel2
endif
endif
if ( ifirst .le. 0 ) then
ifirst = 2
s(4) = -qiDqj(5,9)*qiDqj(7,1)*sdel2i(3,3)/sdel2
s(5) = delpsi(3,3)*dsdel2/sdel2
endif
if ( k .eq. 1 ) then
som = s(1) + s(2) + s(3) + s(4) + s(5)
else
som = s(1) - s(2) - s(3) - s(4) - s(5)
endif
smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ abs(s(5)))/xqi(8)**2
if ( smax .lt. xmax ) then
dyzzy(ii,3) = som/xqi(8)**2
xmax = smax
endif
190 continue
200 continue
ifirst = ifirst - 1
210 continue
* #] real case:
else
* #[ complex case:
ifirst = 0
do 240 j=1,2
do 230 k=1,2
ii = 2*(j-1) + k
cdyzzy(ii,3) = cy(2*j,4,3)*cz(ii,3,3)-cy(2*j,3,3)*
+ cz(ii,4,3)
xmax = absc(cy(2*j,4,3)*cz(ii,3,3))
if ( absc(cdyzzy(ii,3)) .ge. xmax ) goto 230
isoort(5) = isoort(5) - 10
isoort(13) = isoort(13) - 10
if ( ldel2s ) then
ip = 3
else
ip = 8
endif
if ( mod(isoort(3),10).ne.0 .or. mod(isoort(11),10).ne.0
+ ) then
*
* one of the roots is really real
*
if ( ifirst .le. 0 ) then
csdel2=DBLE(ddel2s(3))/(csdeli(3,3)+csdeli(3,4))
endif
if ( ifirst .le. 1 ) then
if ( j .eq. 1 ) then
cs(1) = xqi(ip)*qiDqj(7,1)*qiDqj(5,1)/sdel2
cs(2) = +DBLE(qiDqj(7,1))*csdeli(3,3)
if ( .not.ldel2s ) then
cs(3) = +DBLE(qiDqj(9,1))*csdel2
else
cs(3) = +DBLE(qiDqj(3,1))*csdel2
endif
else
if ( .not.ldel2s ) then
cs(1) = xqi(ip)*qiDqj(7,4)*qiDqj(5,4)/
+ sdel2
cs(2) = DBLE(qiDqj(7,4))*csdeli(3,3)
else
cs(1) = xqi(ip)*qiDqj(7,1)*qiDqj(5,9)/
+ sdel2
cs(2) = DBLE(qiDqj(7,1))*csdeli(3,3)
endif
cs(3) = +DBLE(qiDqj(9,3))*csdel2
endif
if ( ldel2s ) cs(3) = -cs(3)
endif
if ( ifirst .le. 0 ) then
ifirst = 2
if ( .not.ldel2s ) then
cs(4) = -DBLE(qiDqj(5,9)*qiDqj(7,1)/sdel2)*
+ csdeli(3,3)
else
cs(4) = DBLE(qiDqj(5,4)*qiDqj(7,1)/sdel2)*
+ csdeli(3,3)
endif
cs(5) = DBLE(delpsi(3,3)/sdel2)*csdel2
endif
else
*
* both roots are complex
*
if ( ifirst .eq. 0 ) then
dsdel2 = -ddel2s(3)/(sdel2i(3,3)+sdel2i(3,4))
csdel2 = DCMPLX(0D0,dsdel2)
endif
if ( ifirst .le. 1 ) then
if ( j .eq. 1 ) then
cs(1) = xqi(ip)*qiDqj(7,1)*qiDqj(5,1)/sdel2
cs(2) = +DCMPLX(0D0,qiDqj(7,1)*sdel2i(3,3))
if ( .not.ldel2s ) then
cs(3) = +DCMPLX(0D0,qiDqj(9,1)*dsdel2)
else
cs(3) = +DCMPLX(0D0,qiDqj(3,1)*dsdel2)
endif
else
if ( .not.ldel2s ) then
cs(1)= xqi(ip)*qiDqj(7,4)*qiDqj(5,4)/
+ sdel2
cs(2)=DCMPLX(0D0,qiDqj(7,4)*sdel2i(3,3))
else
cs(1)= xqi(ip)*qiDqj(7,1)*qiDqj(5,9)/
+ sdel2
cs(2)=DCMPLX(0D0,qiDqj(7,1)*sdel2i(3,3))
endif
cs(3) = +DCMPLX(0D0,qiDqj(9,3)*dsdel2)
endif
if ( ldel2s ) cs(3) = -cs(3)
endif
if ( ifirst .le. 0 ) then
ifirst = 2
if ( .not.ldel2s ) then
cs(4) = -DCMPLX(0D0,qiDqj(5,9)*qiDqj(7,1)*
+ sdel2i(3,3)/sdel2)
else
cs(4) = DCMPLX(0D0,qiDqj(5,4)*qiDqj(7,1)*
+ sdel2i(3,3)/sdel2)
endif
cs(5) = DCMPLX(0D0,delpsi(3,3)*dsdel2/sdel2)
endif
endif
if ( k .eq. 1 ) then
csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
else
csom = cs(1) - cs(2) - cs(3) - cs(4) - cs(5)
endif
smax =max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
+ absc(cs(4)),absc(cs(5)))/xqi(ip)**2
if ( smax .lt. xmax ) then
cdyzzy(ii,3) = csom/DBLE(xqi(ip))**2
xmax = smax
endif
230 continue
*
* get cdyyzz
*
if ( ldel2s ) then
cdyyzz(j,3) = cdyz(2,j,4,3) - cdyz(2,j,3,3)
xmax = absc(cdyz(2,j,4,3))
if ( absc(cdyyzz(j,3)) .ge. xloss*xmax ) goto 235
if ( ifirst .le. 0 ) then
if ( mod(isoort( 5),10).ne.0 .or.
+ mod(isoort(13),10).ne.0 ) then
csdel2=DBLE(ddel2s(3))/(csdeli(3,3)+csdeli(3,4))
else
dsdel2 = -ddel2s(3)/(sdel2i(3,3)+sdel2i(3,4))
csdel2 = DCMPLX(0D0,dsdel2)
endif
endif
cs(2) = -csdel2/DBLE(xqi(3))
cs(1) = qiDqj(5,3)*qiDqj(7,1)/(sdel2*xqi(3))
if ( j .eq. 1 ) then
csom = cs(1) + cs(2)
else
csom = cs(1) - cs(2)
endif
smax = absc(cs(1))
if ( smax .lt. xmax ) then
cdyyzz(j,3) = csom
xmax = smax
endif
endif
*
* bookkeeping
*
235 continue
ifirst = ifirst - 1
240 continue
* #] complex case:
endif
* #] vertices (3):
ier0 = 0
do 250 i = 1,12
ier0 = max(ier0,ieri(i))
250 continue
ier = ier + ier0
* #] get differences:
* #[ logarithms for 4point function:
*
* Not yet made stable ...
*
if ( npoin .eq. 4 ) then
do 420 i = 1,3
do 410 k = 3,4
ii = i+3*(k-3)
if ( ilogi(ii) .ne. -999 ) then
idone(ii) = 0
goto 410
endif
l = 2*i+8*(k-3)-1
if ((isoort(l).gt.0 .or. mod(isoort(l),10).le.-5) .and.
+ (isoort(l+1).ge.0 .or. mod(isoort(l+1),10).le.-5)) then
* #[ real case:
*
* the real case (isoort=-5,-6: really real but complex for ffdcs)
*
s(1) = -dyz(2,1,k,i)/dyz(2,2,k,i)
if ( abs(s(1)-1) .lt. xloss ) then
clogi(ii) = dfflo1(d2yzz(k,i)/dyz(2,2,k,i),ier)
ilogi(ii) = 0
else
if ( abs(s(1)+1) .lt. xloss ) then
clogi(ii) = dfflo1(-2*sdel2i(i,k)/(xpi(i+3,k)*
+ dyz(2,2,k,i)),ier)
else
clogi(ii) = zxfflg(abs(s(1)),0,0D0,ier)
endif
if ( dyz(2,2,k,i).gt.0 .and. dyz(2,1,k,i).gt.0 )
+ then
ilogi(ii) = -1
elseif ( dyz(2,1,k,i).lt.0 .and. dyz(2,2,k,i).lt.0)
+ then
ilogi(ii) = +1
else
ilogi(ii) = 0
endif
* in case del2s=0 and i=3 we pick up a minus sign, I think
if ( ldel2s .and. i .eq. 3 ) ilogi(ii) = -ilogi(ii)
endif
idone(ii) = 1
* #] real case:
elseif ( isoort(l) .lt. 0 ) then
* #[ complex case:
* for stability split the unit circle up in 4*pi/2
* (this may have to be improved to 8*pi/4...)
*
ier0 = 0
if ( DBLE(cdyz(2,1,k,i)) .gt. abs(DIMAG(cdyz(2,1,k,i))))
+ then
som =2*atan2(DIMAG(cdyz(2,1,k,i)),DBLE(
+ cdyz(2,1,k,i)))
clogi(ii) = DCMPLX(0D0,som)
if ( DIMAG(cdyz(2,1,k,i)) .gt. 0 ) then
ilogi(ii) = -1
else
ilogi(ii) = +1
endif
elseif ( DBLE(cdyz(2,1,k,i)) .lt.
+ -abs(DIMAG(cdyz(2,1,k,i))) ) then
if ( DIMAG(cdyz(2,1,k,i)) .eq. 0 ) then
call fferr(82,ier)
print *,'isoort = ',isoort(l),isoort(l+1)
endif
som = 2*atan2(-DIMAG(cdyz(2,1,k,i)),-DBLE(
+ cdyz(2,1,k,i)))
clogi(ii) = DCMPLX(0D0,som)
if ( DIMAG(cdyz(2,1,k,i)) .gt. 0 ) then
ilogi(ii) = +1
else
ilogi(ii) = -1
endif
else
s(1) = -DBLE(cdyz(2,1,k,i))
s(2) = DIMAG(cdyz(2,1,k,i))
som = 2*atan2(s(1),s(2))
clogi(ii) = DCMPLX(0D0,som)
ilogi(ii) = 0
endif
idone(ii) = 1
* #] complex case:
endif
410 continue
if ( idone(ii) .ne. 0 .and. idone(ii-3) .ne. 0 .and.
+ absc(clogi(ii)-clogi(ii-3)).lt.xloss*absc(clogi(ii)) .and.
+ ilogi(ii).eq.ilogi(ii-3) ) then
* #[ subtract more smartly:
if ( isoort(l).gt.0 .and. isoort(l+1).ge.0 ) then
goto 420
else
cs(1) = cdyzzy(1,i)
cs(2) = cdyzzy(2,i)
if ( i .eq. 1 ) then
cs(3) = 0
else
goto 420
endif
csom = cs(1) - cs(2) + cs(3)
xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)))
* change this to "no warning and quit" later
c = csom/(cdyz(2,2,3,i)*cdyz(2,1,4,i))
c = zfflo1(c,ier)
*
* the log is never much bigger than 1, so demand at least
* accuracy to 0.1; this will catch all i*pi errors
*
if ( abs(clogi(ii-3)-clogi(ii)-c).gt.0.1 ) then
print *,'ffdxc0: error in smart logs: ',clogi(ii-3)-
+ clogi(ii),c,' not used'
goto 420
endif
clogi(ii-3) = c
clogi(ii) = 0
endif
* #] subtract more smartly:
endif
420 continue
* An algorithm to obtain the sum of two small logarithms more
* accurately has been put in ffcc0p, not yet here
endif
* #] logarithms for 4point function:
* #[ real case integrals:
if ( .not. lcompl ) then
* normal case
do 510 i=1,3
j = 2*i-1
if ( isoort(j) .eq. 0 ) then
if ( isoort(j+8) .ne. 0 ) then
call ffcxs3(cs3(20*i+61),ipi12(j+8),y(1,4,i),
+ z(1,4,i),dyz(1,1,4,i),d2yzz(4,i),dy2z(1,4,i),
+ xpi(1,4),piDpj(1,1,4),i,6,isoort(j+8),ier)
endif
elseif ( isoort(j+8) .eq. 0 ) then
call ffcxs3(cs3(20*i-19),ipi12(j),y(1,3,i),
+ z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),
+ xpi(1,3),piDpj(1,1,3),i,6,isoort(j),ier)
else
call ffdcxs(cs3(20*i-19),ipi12(j),y(1,3,i),z(1,3,i),
+ dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),dyzzy(1,i),
+ xpi,piDpj,i,6,isoort(j),ier)
endif
510 continue
isoort(7) = 0
isoort(8) = 0
* #] real case integrals:
* #[ complex case integrals:
else
* convert xpi
do 540 k=3,4
*not cetami(1,k) = etami(1,k)
*used cetami(3,k) = etami(3,k)
do 530 i=1,6
cpi(i,k) = xpi(i,k)
do 520 j=1,6
cpiDpj(j,i,k) = piDpj(j,i,k)
520 continue
530 continue
540 continue
do 550 i=1,3
j = 2*i-1
if ( isoort(j) .eq. 0 ) then
if ( isoort(j+8) .ne. 0 ) then
call ffcxs3(cs3(20*i+61),ipi12(j+8),y(1,4,i),
+ z(1,4,i),dyz(1,1,4,i),d2yzz(4,i),dy2z(1,4,i),
+ xpi(1,4),piDpj(1,1,4),i,6,isoort(j+8),ier)
endif
elseif ( isoort(j+8) .eq. 0 ) then
call ffcxs3(cs3(20*i-19),ipi12(j),y(1,3,i),
+ z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),
+ xpi(1,3),piDpj(1,1,3),i,6,isoort(j),ier)
elseif ( isoort(j) .gt. 0 ) then
if ( isoort(j+8) .gt. 0 ) then
call ffdcxs(cs3(20*i-19),ipi12(j),y(1,3,i),
+ z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),
+ dyzzy(1,i),xpi,piDpj,i,6,isoort(j),ier)
else
print *,'ffdxc0: error: should not occur!'
call ffcxs3(cs3(20*i-19),ipi12(j),y(1,3,i),
+ z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),dy2z(1,3,i),
+ xpi(1,3),piDpj(1,1,3),i,6,isoort(j),ier)
call ffcs3(cs3(20*i+61),ipi12(j+8),cy(1,4,i),
+ cz(1,4,i),cdyz(1,1,4,i),cd2yzz(4,i),
+ cpi(1,4),cpiDpj(1,1,4),i,6,isoort(j+8),ier)
endif
else
if ( isoort(j+8) .lt. 0 ) then
call ffdcs(cs3(20*i-19),ipi12(j),cy(1,3,i),
+ cz(1,3,i),cdyz(1,1,3,i),cd2yzz(3,i),
+ cdyzzy(1,i),cdyyzz(1,i),cpi,cpiDpj,
+ i,6,isoort(j),ier)
else
print *,'ffdxc0: error: should not occur!'
call ffcs3(cs3(20*i-19),ipi12(j),cy(1,3,i),
+ cz(1,3,i),cdyz(1,1,3,i),cd2yzz(3,i),
+ cpi(1,3),cpiDpj(1,1,3),i,6,isoort(j),ier)
call ffcxs3(cs3(20*i+61),ipi12(j+8),y(1,4,i),
+ z(1,4,i),dyz(1,1,4,i),d2yzz(4,i),dy2z(1,4,i),
+ xpi(1,4),piDpj(1,1,4),i,6,isoort(j+8),ier)
endif
endif
550 continue
isoort(7) = 0
isoort(8) = 0
endif
return
* #] complex case integrals:
*###] ffdxc0:
end
diff --git a/Looptools/C/ffxc0.F b/Looptools/C/ffxc0.F
--- a/Looptools/C/ffxc0.F
+++ b/Looptools/C/ffxc0.F
@@ -1,741 +1,744 @@
+#include "externals.h"
+
+
* $Id: ffxc0.f,v 1.5 1996/08/15 09:36:47 gj Exp $
*###[ ffxc0:
subroutine ffxc0(cc0,xpi,ier)
***#[*comment:***********************************************************
* *
* Calculates the threepoint function closely following *
* recipe in 't Hooft & Veltman, NP B(183) 1979. *
* Bjorken and Drell metric is used nowadays! *
* *
* p2 | | *
* v | *
* / \ *
* m2/ \m3 *
* p1 / \ p3 *
* -> / m1 \ <- *
* ------------------------ *
* *
* 1 / 1 *
* = ----- \d^4Q---------------------------------------- *
* ipi^2 / [Q^2-m1^2][(Q+p1)^2-m2^2][(Q-p3)^2-m3^2] *
* *
* If the function is infra-red divergent (p1=m2,p3=m3,m1=0 or *
* cyclic) the function is calculated with a user-supplied cutoff *
* lambda in the common block /ffregul/. *
* *
* Input: xpi (real) i=1,3: mass^2, i=4,6: pi.pi *
* Output: cc0 (complex) C0, the threepoint function. *
* ier (integer) 0=ok, 1=inaccurate, 2=error *
* Calls: ffxc0p,ffxb0p *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cc0
DOUBLE PRECISION xpi(6)
integer ier
*
* local variables:
*
integer i,j
DOUBLE PRECISION dpipj(6,6)
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ special case: all momenta^2 = 0
*
if (abs(xpi(4)) + abs(xpi(5)) + abs(xpi(6)) .lt. 1D-10) then
- call ffxc0p0(cc0,xpi,ier)
+ call ffxc0p0(cc0, xpi)
return
endif
* #[ convert input:
do 40 i=1,6
do 39 j = 1,6
dpipj(j,i) = xpi(j) - xpi(i)
39 continue
40 continue
* #] convert input:
* #[ call ffxc0a:
call ffxc0a(cc0,xpi,dpipj,ier)
* #] call ffxc0a:
*###] ffxc0:
end
*###[ ffxc0a:
subroutine ffxc0a(cc0,xpi,dpipj,ier)
***#[*comment:***********************************************************
* *
* See ffxc0. *
* *
* Input: xpi (real) i=1,3: mass^2, i=4,6: pi.pi *
* dpipj (real) = xpi(i) - xpi(j) *
* Output: cc0 (complex) C0, the threepoint function. *
* ier (integer) 0=ok, 1=inaccurate, 2=error *
* Calls: ffxc0p,ffxb0p *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cc0
DOUBLE PRECISION xpi(6),dpipj(6,6)
integer ier
*
* local variables:
*
logical ljust
integer i,j,inew(6,6)
* DOUBLE COMPLEX cs,cs1,cs2
DOUBLE PRECISION xqi(6),dqiqj(6,6),qiDqj(6,6),lambda0,dum66(6,6)
save inew,lambda0
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* memory
*
integer iermem(memory),ialmem(memory),memind,ierini
DOUBLE PRECISION xpimem(6,memory),dl2mem(memory)
DOUBLE COMPLEX cc0mem(memory)
save memind,iermem,ialmem,xpimem,dl2mem,cc0mem
data memind /0/
*
* data
*
data lambda0 /1.D0/
data inew /1,2,3,4,5,6,
+ 2,3,1,5,6,4,
+ 3,1,2,6,4,5,
+ 1,3,2,6,5,4,
+ 3,2,1,5,4,6,
+ 2,1,3,4,6,5/
* #] declarations:
* #[ initialisations:
if ( lmem .and. memind .eq. 0 ) then
do 2 i=1,memory
do 1 j=1,6
xpimem(j,i) = 0
1 continue
ialmem(i) = 0
2 continue
endif
idsub = 0
ljust = .FALSE.
* #] initialisations:
* #[ handle special cases:
*
* The infrared divergent diagrams are calculated in ffxc0i:
*
if ( dpipj(2,4).eq.0 .and. dpipj(3,6).eq.0 .and. xpi(1).eq.0
+ .or. dpipj(3,5).eq.0 .and. dpipj(1,4).eq.0 .and. xpi(2).eq.0
+ .or. dpipj(1,6).eq.0 .and. dpipj(2,5).eq.0 .and. xpi(3).eq.0 )
+ then
call ffxc0i(cc0,xpi,dpipj,ier)
return
endif
* #] handle special cases:
* #[ rotate to alpha in (0,1):
call ffrot3(irota3,xqi,dqiqj,qiDqj,xpi,dpipj,dum66,2,3,ier)
* #] rotate to alpha in (0,1):
* #[ look in memory:
ierini = ier+ner
if ( lmem .and. lambda .eq. lambda0 ) then
do 70 i=1,memory
do 60 j=1,6
if ( xqi(j) .ne. xpimem(j,i) ) goto 70
60 continue
if ( ialmem(i) .ne. isgnal ) goto 70
* we found an already calculated mass combination ..
* (maybe check differences as well)
cc0 = cc0mem(i)
ier = ier+iermem(i)
if ( ldot ) then
fdel2 = dl2mem(i)
* we forgot to recalculate the stored quantities
ljust = .TRUE.
goto 71
endif
return
70 continue
elseif ( lmem ) then
lambda0 = lambda
endif
71 continue
* #] look in memory:
* #[ dot products:
call ffdot3(qiDqj,xqi,dqiqj,6,ier)
*
* save dotproducts for tensor functions if requested
*
if ( ldot ) then
do 75 i=1,6
do 74 j=1,6
fpij3(j,i) = qiDqj(inew(i,irota3),inew(j,irota3))
74 continue
75 continue
if ( irota3 .gt. 3 ) then
*
* the sign of the s's has been changed!
*
do 77 i=1,3
do 76 j=4,6
fpij3(j,i) = -fpij3(j,i)
fpij3(i,j) = -fpij3(i,j)
76 continue
77 continue
endif
endif
if ( ljust ) return
* #] dot products:
* #[ call ffxc0b:
call ffxc0b(cc0,xqi,dqiqj,qiDqj,ier)
* #] call ffxc0b:
* #[ add to memory:
if ( lmem ) then
memind = memind + 1
if ( memind .gt. memory ) memind = 1
do 200 j=1,6
xpimem(j,memind) = xqi(j)
200 continue
cc0mem(memind) = cc0
iermem(memind) = ier+ner-ierini
ialmem(memind) = isgnal
dl2mem(memind) = fdel2
endif
* #] add to memory:
*###] ffxc0a:
end
*###[ ffxc0b:
subroutine ffxc0b(cc0,xqi,dqiqj,qiDqj,ier)
***#[*comment:***********************************************************
* *
* See ffxc0. *
* *
* Input: xpi (real) i=1,3: mass^2, i=4,6: pi.pi *
* dpipj (real) = xpi(i) - xpi(j) *
* Output: cc0 (complex) C0, the threepoint function. *
* ier (integer) 0=ok, 1=inaccurate, 2=error *
* Calls: ffxc0p,ffxb0p *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cc0
DOUBLE PRECISION xqi(6),dqiqj(6,6),qiDqj(6,6)
integer ier
*
* local variables:
*
integer nerr
parameter(nerr=6)
integer isoort(8),ipi12(8),i,j,k,ipi12t,ilogi(3),ier0,ieri(nerr)
DOUBLE COMPLEX cs3(80),cs,c,clogi(3),cslam,cetalm,
+ cetami(6),cel2s(3),calph(3),cblph(3),csdel2,
+ cqi(6),cdqiqj(6,6),cqiDqj(6,6),celpsi(3)
DOUBLE PRECISION del2,del2s(3),del3,delpsi(3),
+ del3mi(3)
DOUBLE PRECISION xmax,absc,alph(3),etalam,etami(6),sdel2,
+ blph(3)
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function:
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ calculations:
*
* some determinants
*
do 98 i = 1,nerr
ieri(i) = 0
98 continue
call ffdel2(del2,qiDqj, 6, 4,5,6, 1,ier)
if ( ldot ) fdel2 = del2
if ( del2 .gt. 0 ) then
* shouldn't occur ...
* 12-10-1993 three spacelike momenta are OK
if ( .not.(xqi(4).lt.0 .and. xqi(5).lt.0 .and. xqi(6).lt.0)
+ ) then
call fferr(41,ier)
print *,'xpi = ',xqi
endif
elseif ( del2 .eq. 0 ) then
call fferr(42,ier)
return
endif
call ffdel3(del3,qiDqj)
call ffdl3m(del3mi,.TRUE.,del3,del2,xqi,dqiqj,qiDqj,6, 4,5,6,
+ 1,3)
do 101 i=1,3
j = i+1
if ( j .eq. 4 ) j = 1
call ffdel2(del2s(i),qiDqj,6, i+3,i,j, 1,ieri(i))
k = i-1
if ( k .eq. 0 ) k = 3
call ffdl2p(delpsi(i),xqi,dqiqj,qiDqj,i+3,j+3,k+3,i,j,k,6)
101 continue
ier0 = 0
do 99 i=1,nerr
ier0 = max(ier0,ieri(i))
99 continue
ier = ier + ier0
*
* initialize cs3:
*
do 80 i=1,80
cs3(i) = 0
80 continue
do 90 i=1,8
ipi12(i) = 0
90 continue
do 100 i=1,3
clogi(i) = 0
ilogi(i) = 0
100 continue
* #[ complex case:
* in case of three spacelike momenta or unphysical real ones
if ( del2 .gt. 0 ) then
do 102 i=1,3
cel2s(i) = del2s(i)
celpsi(i) = delpsi(i)
cetami(i) = del3mi(i)/del2
102 continue
do 104 i=1,6
cqi(i) = xqi(i)
do 103 j=1,6
cdqiqj(j,i) = dqiqj(j,i)
cqiDqj(j,i) = qiDqj(j,i)
103 continue
104 continue
cetalm = del3/del2
csdel2 = isgnal*DCMPLX(0D0,sqrt(del2))
*
* get alpha,1-alpha
*
call ffcoot(cblph(1),calph(1),cqi(5),-cqiDqj(5,6),cqi(6),
+ csdel2,ier)
call ffcoot(calph(3),cblph(3),cqi(5),-cqiDqj(5,4),cqi(4),
+ csdel2,ier)
cslam = 2*csdel2
call ffcc0p(cs3,ipi12,isoort,clogi,ilogi,cqi,cdqiqj,cqiDqj,
+ csdel2,cel2s,cetalm,cetami,celpsi,calph,3,ier)
goto 109
endif
* #] complex case:
etalam = del3/del2
do 106 i=1,3
etami(i) = del3mi(i)/del2
106 continue
if ( abs(isgnal).ne.1 ) then
print *,'ffxc0b: error: isgnal should be +/-1, not ',isgnal
- print *,' forgot to call ffini?'
- call ffini
+ print *,' forgot to call ltini?'
+ call ltini
endif
sdel2 = isgnal*sqrt(-del2)
*
* get alpha,1-alpha
*
call ffroot(blph(1),alph(1),xqi(5),-qiDqj(5,6),xqi(6),sdel2,ier)
call ffroot(alph(3),blph(3),xqi(5),-qiDqj(5,4),xqi(4),sdel2,ier)
if ( l4also .and. ( alph(1) .gt. 1 .or. alph(1) .lt. 0 ) .and.
+ abs(blph(1)-.5D0) .lt. abs(alph(1)-.5D0) ) then
alph(1) = blph(1)
alph(3) = blph(3)
sdel2 = -sdel2
isgnal = -isgnal
endif
cslam = 2*sdel2
*
* and the calculations
*
call ffxc0p(cs3,ipi12,isoort,clogi,ilogi,xqi,dqiqj,qiDqj,
+ sdel2,del2s,etalam,etami,delpsi,alph,3,ier)
*
* sum'em up:
*
109 continue
cs = 0
xmax = 0
do 110 i=1,80
* if ( cs3(i) .ne. 0 ) then
cs = cs + cs3(i)
xmax = max(xmax,absc(cs))
* endif
110 continue
ipi12t = 0
do 120 i=1,8
ipi12t = ipi12t + ipi12(i)
120 continue
cs = cs + ipi12t*DBLE(pi12)
*
* A imaginary component less than precc times the real part is
* zero (may be removed)
*
if ( abs(DIMAG(cs)) .lt. precc*abs(DBLE(cs)) )
+ cs = DCMPLX(DBLE(cs))
*
* Finally ...
*
cc0 = - cs/cslam
* #] calculations:
*###] ffxc0b:
end
*###[ ffrot3:
subroutine ffrot3(irota,xqi,dqiqj,qiDqj,xpi,dpipj,piDpj,
+ iflag,npoin,ier)
***#[*comment:***********************************************************
* *
* rotates the arrays xpi, dpipj into xqi,dqiqj so that *
* xpi(6),xpi(4) suffer the strongest outside cancellations and *
* xpi(6) > xpi(4) if iflag = 1, so that xpi(5) largest and xpi(5) *
* and xpi(6) suffer cancellations if iflag = 2. *
* if iflag = 3 make xqi(3)=0. *
* If npoin=4, rotate piDpj into qiDqj as well. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer irota,iflag,ier,npoin
DOUBLE PRECISION xpi(6),dpipj(6,6),piDpj(6,6),xqi(6),dqiqj(6,6),
+ qiDqj(6,6)
*
* local variables
*
DOUBLE PRECISION a1,a2,a3,xpimax
DOUBLE COMPLEX chulp(3,3)
integer i,j,inew(6,6)
save inew
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data inew /1,2,3,4,5,6,
+ 2,3,1,5,6,4,
+ 3,1,2,6,4,5,
+ 1,3,2,6,5,4,
+ 3,2,1,5,4,6,
+ 2,1,3,4,6,5/
* #] declarations:
* #[ get largest cancellation:
if ( iflag .eq. 1 ) then
a1 = abs(dpipj(6,4))/max(abs(xpi(6)+xpi(4)),xalogm)
a2 = abs(dpipj(5,4))/max(abs(xpi(5)+xpi(4)),xalogm)
a3 = abs(dpipj(5,6))/max(abs(xpi(6)+xpi(5)),xalogm)
if ( a1 .le. a2 .and. a1 .le. a3 ) then
irota = 1
if ( abs(xpi(6)) .lt. abs(xpi(4)) ) then
irota = 4
endif
elseif ( a2 .le. a3 ) then
irota = 3
if ( abs(xpi(4)) .lt. abs(xpi(5)) ) then
irota = 6
endif
else
irota = 2
if ( abs(xpi(5)) .lt. abs(xpi(6)) ) then
irota = 5
endif
endif
elseif ( iflag .eq. 2 ) then
xpimax = max(xpi(4),xpi(5),xpi(6))
if ( xpimax .eq. 0 ) then
if ( xpi(5) .ne. 0 ) then
irota = 1
elseif ( xpi(4) .ne. 0 ) then
irota = 2
elseif ( xpi(6) .ne. 0 ) then
irota = 3
else
call fferr(40,ier)
irota = 1
endif
elseif ( xpi(5) .eq. xpimax ) then
if ( xpi(4) .le. xpi(6) ) then
irota = 1
else
irota = 4
endif
elseif ( xpi(4) .eq. xpimax ) then
if ( xpi(5) .ge. xpi(6) ) then
irota = 2
else
irota = 5
endif
else
if ( xpi(4) .ge. xpi(6) ) then
irota = 3
else
irota = 6
endif
endif
elseif ( iflag .eq. 3 ) then
if ( dpipj(2,4).eq.0 .and. dpipj(3,6).eq.0 .and.
+ xpi(1).eq.0 ) then
irota = 3
elseif ( dpipj(1,6).eq.0 .and. dpipj(2,5).eq.0 .and.
+ xpi(3).eq.0 ) then
irota = 1
elseif ( dpipj(3,5).eq.0 .and. dpipj(1,4).eq.0 .and.
+ xpi(2).eq.0 ) then
irota = 2
else
call fferr(35,ier)
irota = 1
endif
else
call fferr(35,ier)
irota = 1
endif
* #] get largest cancellation:
* #[ rotate:
do 20 i=1,6
xqi(inew(i,irota)) = xpi(i)
do 10 j=1,6
dqiqj(inew(i,irota),inew(j,irota)) = dpipj(i,j)
10 continue
20 continue
*
* when called in a 4pointfunction we already have the dotproducts
*
if ( npoin .eq. 4 ) then
do 80 j=1,6
do 70 i=1,6
qiDqj(inew(i,irota),inew(j,irota)) = piDpj(i,j)
70 continue
80 continue
endif
*DEBUG if ( iflag .eq. 3 .and. lsmug ) then
if ( lsmug ) then
*
* do not forget to rotate the smuggled differences
*
do 40 j=1,3
do 30 i=1,3
chulp(i,j) = cmipj(i,j)
30 continue
40 continue
do 60 j=1,3
do 50 i=1,3
cmipj(inew(i,irota),inew(j+3,irota)-3) = chulp(i,j)
50 continue
60 continue
endif
* #] rotate:
*###] ffrot3:
end
*###[ ffdot3:
subroutine ffdot3(piDpj,xpi,dpipj,ns,ier)
***#[*comment:***********************************************************
* *
* calculate the dotproducts pi.pj with *
* *
* pi = si i1=1,3 *
* pi = p(i-3) i1=4,6 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ns,ier
DOUBLE PRECISION xpi(6),dpipj(6,6),piDpj(6,6)
*
* locals
*
integer is1,is2,is3,ip1,ip2,ip3,i,j,ier1,inew(6,6)
save inew
*
* rest
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data inew /1,2,3,4,5,6,
+ 2,3,1,5,6,4,
+ 3,1,2,6,4,5,
+ 1,3,2,6,5,4,
+ 3,2,1,5,4,6,
+ 2,1,3,4,6,5/
*
* #] declarations:
* #[ check input:
if ( ns .ne. 6 ) print *,'ffdot3: error: ns /= 6 '
* #] check input:
* #[ copy if known:
*
if ( idot.ge.3 ) then
do 2 i=1,6
do 1 j=1,6
piDpj(inew(j,irota3),inew(i,irota3)) = fpij3(j,i)
1 continue
2 continue
if ( irota3 .gt. 3 ) then
*
* the sign of the s's has been changed!
*
do 4 i=1,3
do 3 j=4,6
piDpj(j,i) = -piDpj(j,i)
piDpj(i,j) = -piDpj(i,j)
3 continue
4 continue
endif
return
endif
*
* #] copy if known:
* #[ calculations:
ier1 = ier
do 10 is1=1,3
is2 = is1 + 1
if ( is2 .eq. 4 ) is2 = 1
is3 = is2 + 1
if ( is3 .eq. 4 ) is3 = 1
ip1 = is1 + 3
ip2 = is2 + 3
ip3 = is3 + 3
*
* pi.pj, si.sj
*
piDpj(is1,is1) = xpi(is1)
piDpj(ip1,ip1) = xpi(ip1)
*
* si.s(i+1)
*
if ( xpi(is2) .le. xpi(is1) ) then
piDpj(is1,is2) = (dpipj(is1,ip1) + xpi(is2))/2
else
piDpj(is1,is2) = (dpipj(is2,ip1) + xpi(is1))/2
endif
piDpj(is2,is1) = piDpj(is1,is2)
*
* pi.si
*
if ( abs(xpi(ip1)) .le. xpi(is1) ) then
piDpj(ip1,is1) = (dpipj(is2,is1) - xpi(ip1))/2
else
piDpj(ip1,is1) = (dpipj(is2,ip1) - xpi(is1))/2
endif
piDpj(is1,ip1) = piDpj(ip1,is1)
*
* pi.s(i+1)
*
if ( abs(xpi(ip1)) .le. xpi(is2) ) then
piDpj(ip1,is2) = (dpipj(is2,is1) + xpi(ip1))/2
else
piDpj(ip1,is2) = (dpipj(ip1,is1) + xpi(is2))/2
endif
piDpj(is2,ip1) = piDpj(ip1,is2)
*
* pi.s(i+2)
*
if ( min(abs(dpipj(is2,is1)),abs(dpipj(ip3,ip2))) .le.
+ min(abs(dpipj(ip3,is1)),abs(dpipj(is2,ip2))) ) then
piDpj(ip1,is3) = (dpipj(ip3,ip2) + dpipj(is2,is1))/2
else
piDpj(ip1,is3) = (dpipj(ip3,is1) + dpipj(is2,ip2))/2
endif
piDpj(is3,ip1) = piDpj(ip1,is3)
*
* pi.p(i+1)
*
if ( idot.le.0 ) then
if ( abs(xpi(ip2)) .le. abs(xpi(ip1)) ) then
piDpj(ip1,ip2) = (dpipj(ip3,ip1) - xpi(ip2))/2
else
piDpj(ip1,ip2) = (dpipj(ip3,ip2) - xpi(ip1))/2
endif
piDpj(ip2,ip1) = piDpj(ip1,ip2)
else
piDpj(inew(ip2,irota3),inew(ip1,irota3)) =
+ fpij3(ip1,ip2)
piDpj(inew(ip1,irota3),inew(ip2,irota3)) =
+ piDpj(inew(ip2,irota3),inew(ip1,irota3))
endif
10 continue
ier = ier1
*
* #] calculations:
*###] ffdot3:
end
*###[ ffxc0r:
subroutine ffxc0r(cc0,xpi,ier)
***#[*comment:***********************************************************
* *
* Tries all 2 permutations of the 3pointfunction *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE PRECISION xpi(6),xqi(6)
DOUBLE COMPLEX cc0,cc0p
integer inew(6,2),irota,ier1,i,j,ialsav
save inew
- include 'ff.h'
+#include "ff.h"
data inew /1,2,3,4,5,6,
+ 1,3,2,6,5,4/
* #] declarations:
* #[ calculations:
cc0 = 0
ier = 999
ialsav = isgnal
do 30 j = -1,1,2
do 20 irota=1,2
do 10 i=1,6
xqi(inew(i,irota)) = xpi(i)
10 continue
print '(a,i1,a,i2)','---#[ rotation ',irota,': isgnal ',
+ isgnal
ier1 = 0
ner = 0
id = id + 1
isgnal = ialsav
call ffxc0(cc0p,xqi,ier1)
ier1 = ier1 + ner
print '(a,i1,a,i2)','---#] rotation ',irota,': isgnal ',
+ isgnal
print '(a,2g28.16,i3)','c0 = ',cc0p,ier1
if ( ier1 .lt. ier ) then
cc0 = cc0p
ier = ier1
endif
20 continue
ialsav = -ialsav
30 continue
* #] calculations:
*###] ffxc0r:
end
diff --git a/Looptools/C/ffxc0i.F b/Looptools/C/ffxc0i.F
--- a/Looptools/C/ffxc0i.F
+++ b/Looptools/C/ffxc0i.F
@@ -1,761 +1,763 @@
+#include "externals.h"
+
+
*--#[ log:
* $Id: ffxc0i.f,v 1.3 1996/06/03 12:11:43 gj Exp $
* $Log: ffxc0i.f,v $
c Revision 1.3 1996/06/03 12:11:43 gj
c Added an error message for ffxc0j with zero masses, which is ill-defined.
c
c Revision 1.2 1995/12/01 15:04:40 gj
c Fixed a ridiculous bug: wrong sign for p4^2=0, m2<m1.
c
*--#] log:
*###[ ffxc0i:
subroutine ffxc0i(cc0,xpi,dpipj,ier)
***#[*comment:***********************************************************
* *
* Calculates the infrared finite part of a infrared divergent *
* threepoint function with the factor ipi^2. The cutoff *
* parameter is assumed to be in /ffregul/. *
* *
* Input: xpi(6) (real) pi.pi (B&D) *
* dpipj(6,6) (real) xpi(i)-xpi(j) *
* lambda (real) cutoff (either photon mass**2 *
* or radiation limit). *
* Output: cc0 (complex) C0, the threepoint function. *
* ier (integer) usual error flag *
* Calls: *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cc0
DOUBLE PRECISION xpi(6),dpipj(6,6)
*
* local variables
*
integer init,ipi12,i,ilogi(3),irota,n
integer j,inew(6,6)
DOUBLE COMPLEX cs(15),csum,c,clogi(3)
DOUBLE PRECISION xqi(6),dqiqj(6,6),qiDqj(6,6),sdel2,xmax,absc,
+ dum66(6,6),del2,m1,m2
save init,inew,ilogi
*
* common blocks etc
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data init /0/
data inew /1,2,3,4,5,6,
+ 2,3,1,5,6,4,
+ 3,1,2,6,4,5,
+ 1,3,2,6,5,4,
+ 3,2,1,5,4,6,
+ 2,1,3,4,6,5/
data ilogi /3*0/
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* initialisations
*
do 1 i=1,15
cs(i) = 0
1 continue
ipi12 = 0
* #] declarations:
* #[ check input:
if ( init .eq. 0 .and. .not.lsmug ) then
init = 1
print *,'ffxc0i: infra-red divergent threepoint function, ',
+ 'working with a cutoff ',lambda
endif
if ( .not.lsmug .and. lambda .eq. 0 ) then
call fferr(59,ier)
return
endif
* #] check input:
* #[ groundwork:
*
* rotate to xpi(3)=0, xpi(1)=xpi(6), xpi(2)=xpi(5)
*
call ffrot3(irota,xqi,dqiqj,qiDqj,xpi,dpipj,dum66,3,3,ier)
*
* get some dotproducts
*
if ( ldot ) then
call ffdot3(qiDqj,xqi,dqiqj,6,ier)
do 5 i=1,6
do 4 j=1,6
fpij3(j,i) = qiDqj(inew(i,irota),inew(j,irota))
4 continue
5 continue
else
if ( abs(xqi(4)) .lt. xqi(1) ) then
qiDqj(4,1) = dqiqj(2,1) - xqi(4)
xmax = abs(xqi(4))
else
qiDqj(4,1) = dqiqj(2,4) - xqi(1)
xmax = xqi(1)
endif
qiDqj(4,1) = qiDqj(4,1)/2
qiDqj(1,4) = qiDqj(4,1)
if ( abs(xqi(4)) .lt. xqi(2) ) then
qiDqj(4,2) = dqiqj(2,1) + xqi(4)
xmax = abs(xqi(4))
else
qiDqj(4,2) = xqi(2) - dqiqj(1,4)
xmax = xqi(2)
endif
qiDqj(4,2) = qiDqj(4,2)/2
qiDqj(2,4) = qiDqj(4,2)
if ( xqi(1) .lt. xqi(2) ) then
qiDqj(1,2) = xqi(1) + dqiqj(2,4)
xmax = xqi(1)
else
qiDqj(1,2) = xqi(2) + dqiqj(1,4)
xmax = xqi(2)
endif
qiDqj(1,2) = qiDqj(1,2)/2
qiDqj(2,1) = qiDqj(1,2)
qiDqj(1,1) = xqi(1)
qiDqj(2,2) = xqi(2)
qiDqj(4,4) = xqi(4)
endif
* #] groundwork:
* #[ calculations:
*
call ffdel2(del2,qiDqj,6,1,2,4,1,ier)
if ( ldot ) fdel2 = del2
*
* the case del2=0 is hopeless - this is really a two-point function
*
if ( abs(del2) .lt. 1D-14 ) then
if(xpi(1) .eq. 0) then
m1 = xpi(2)
m2 = xpi(3)
else if(xpi(2) .eq. 0) then
m1 = xpi(1)
m2 = xpi(3)
else
m1 = xpi(1)
m2 = xpi(2)
endif
if(m1 .eq. m2) then
cc0 = -1/(16*pi**2)/2D0/m1 * log(lambda/m1)
else
m1 = sqrt(m1)
m2 = sqrt(m2)
cc0 = -1/(16*pi**2)/2D0/(m1*m2) *
+ (log(lambda/(m1*m2)) - 2
+ + (m1 + m2)/(m1 - m2)*log(m1/m2))
endif
return
endif
*
* we cannot yet handle the complex case
*
if ( del2 .gt. 0 ) then
call fferr(83,ier)
return
endif
*
sdel2 = isgnal*sqrt(-del2)
*
call ffxc0j(cs,ipi12,sdel2,clogi,ilogi,xqi,dqiqj,qiDqj,
+ lambda,3,ier)
* #] calculations:
* #[ sum:
*
* Sum
*
xmax = 0
csum = 0
if ( .not.lsmug ) then
n = 10
else
n = 15
endif
- do 10 i=1,n
+ do i=1,n
csum = csum + cs(i)
xmax = max(xmax,absc(csum))
- 10 continue
+ enddo
csum = csum + ipi12*DBLE(pi12)
cc0 = -csum*DBLE(1/(2*sdel2))
* #] sum:
- 900 continue
*###] ffxc0i:
end
*###[ ffxc0j:
subroutine ffxc0j(cs,ipi12,sdel2i,clogi,ilogi,
+ xpi,dpipj,piDpj,lamsq,npoin,ier)
***#[*comment:***********************************************************
* *
* Calculates the infrared finite part of a infrared divergent *
* threepoint function with the factor ipi^2. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ipi12,ilogi(3),npoin,ier
DOUBLE COMPLEX cs(15),clogi(3)
DOUBLE PRECISION xpi(6),dpipj(6,6),piDpj(6,6),lamsq,sdel2i
*
* local variables
*
integer i,ieps,ieps1,n,ier0
DOUBLE COMPLEX clog1,clog2,cdum(2),cel3,cdyzm,cdyzp,cli,chulp,
+ carg1,carg2,chulp1
DOUBLE COMPLEX zfflog,zxfflg,cc
DOUBLE PRECISION del2,zm,zp,zm1,zp1,sdel2,hulp,dum(3),
+ dfflo1,dyzp,dyzm,wm,wp,absc,arg1,arg2,del3
external dfflo1,zfflog,zxfflg
*
* common blocks etc
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
* #] declarations:
* #[ get determinants, roots, ieps:
*
if ( lsmug ) then
del3 = (- DBLE(xpi(1))*DBLE(cmipj(2,2))**2
+ - DBLE(xpi(2))*DBLE(cmipj(1,3))**2
+ + 2*DBLE(piDpj(1,2))*DBLE(cmipj(2,2))*
+ DBLE(cmipj(1,3)) )/4
if ( nschem .ge. 3 ) then
cel3 = (- DBLE(xpi(1))*cmipj(2,2)**2
+ - DBLE(xpi(2))*cmipj(1,3)**2
+ + 2*DBLE(piDpj(1,2))*cmipj(2,2)*cmipj(1,3) )/4
else
cel3 = DBLE(del3)
endif
endif
del2 = -sdel2i**2
*
* the routine as it stands can not handle sdel2<0.
* the simplest solution seems to be to switch to sdel2>0 for
* the time being - we calculate a complete 3point function so it
* should not be a problem (just a sign). Of course this spoils a
* good check on the correctness.
*
sdel2 = abs(sdel2i)
*
if ( xpi(4).eq.0 ) then
zm = xpi(2)/dpipj(2,1)
zm1 = -xpi(1)/dpipj(2,1)
else
call ffroot(zm,zp,xpi(4),piDpj(4,2),xpi(2),sdel2,ier)
if ( dpipj(1,2) .ne. 0 ) then
call ffroot(zp1,zm1,xpi(4),-piDpj(4,1),xpi(1),sdel2,ier)
else
zm1 = zp
zp1 = zm
endif
endif
* imag sign ok 30-oct-1989
ieps = -1
if ( xpi(4).ne.0 ) dyzp = -2*sdel2/xpi(4)
*
* #] get determinants, roots, ieps:
* #[ the finite+divergent S1:
*
if ( xpi(4).ne.0 ) then
call ffcxr(cs(1),ipi12,zm,zm1,zp,zp1,dyzp,
+ .FALSE.,0D0,0D0,0D0,.FALSE.,dum,ieps,ier)
endif
*
* Next the divergent piece
*
if ( .not.lsmug ) then
*
* Here we dropped the term log(lam/lamsq)*log(-zm/zm1)
*
if ( abs(zm1) .gt. 1/xloss ) then
clog1 = dfflo1(1/zm1,ier)
elseif ( zm.ne.0 ) then
clog1 = zxfflg(-zm/zm1,-2,0D0,ier)
else
call fferr(97,ier)
return
endif
hulp = zm*zm1*4*del2/lamsq**2
*
* 14-jan-1994: do not count when this is small, this was
* meant to be so by the user carefully adjusting lamsq
*
ier0 = ier
if ( hulp.eq.0 ) call fferr(97,ier)
clog2 = zxfflg(hulp,2,0D0,ier0)
cs(8) = -clog1*clog2/2
else
*
* checked 4-aug-1992, but found Yet Another Bug 30-sep-1992
*
cdyzm = cel3*DBLE(1/(-2*sdel2*del2))
dyzm = del3/(-2*sdel2*del2)
carg1 = +cdyzm*DBLE(1/zm)
arg1 = +dyzm/zm
clog1 = zfflog(-carg1,+ieps,DCMPLX(DBLE(zm),DBLE(0)),ier)
if (DIMAG(cdyzm) .lt. 0 .and. arg1 .gt. 0 ) then
clog1 = clog1 - c2ipi
* ier = ier + 50
endif
cs(8) = -clog1**2/2
carg2 = -cdyzm*DBLE(1/zm1)
arg2 = -dyzm/zm1
clog2 = zfflog(-carg2,ieps,DCMPLX(DBLE(-zm1),DBLE(0)),ier)
if ( DIMAG(cdyzm) .lt. 0 .and. arg2 .gt. 0 ) then
clog2 = clog2 + c2ipi
endif
cs(9) = +clog2**2/2
endif
* #] the finite+divergent S1:
* #[ log(1) for npoin=4:
if ( npoin .eq. 4 ) then
if ( ilogi(1) .eq. -999 ) then
if ( .not.lsmug ) then
hulp = xpi(4)*lamsq/(4*del2)
ier0 = ier
if ( hulp.eq.0 ) call fferr(97,ier)
clogi(1) = -zxfflg(abs(hulp),0,0D0,ier0)
if ( hulp .lt. 0 ) then
if ( xpi(4) .gt. 0 ) then
ilogi(1) = -1
else
ilogi(1) = +1
endif
else
ilogi(1) = 0
endif
else
if ( xpi(4).eq.0 ) then
print *,'ffxc0i: cannot handle t=0 yet, sorry'
print *,'Please regularize with a small mass'
stop
endif
chulp = -cdyzm*DBLE(1/dyzp)
chulp1 = 1+chulp
if ( absc(chulp1) .lt. xloss )
+ call ffwarn(129,ier,absc(chulp1),1D0)
call ffxclg(clogi(1),ilogi(1),chulp,chulp1,dyzp,
+ ier)
endif
endif
endif
* #] log(1) for npoin=4:
* #[ the log(lam) Si:
if ( .not.lsmug ) then
*
* Next the divergent S_i (easy).
* The term -2*log(lam/lamsq)*log(xpi(2)/xpi(1)) has been discarded
* with lam the photon mass (regulator).
* If lamsq = sqrt(xpi(1)*xpi(2)) the terms cancel as well
*
if ( dpipj(1,2).ne.0 .and. xloss*abs(xpi(1)*xpi(2)-lamsq**2)
+ .gt.precx*lamsq**2 ) then
if ( xpi(1) .ne. lamsq ) then
ier0 = ier
if ( xpi(1).eq.0 ) call fferr(97,ier)
cs(9) = -zxfflg(xpi(1)/lamsq,0,0D0,ier0)**2 /4
endif
if ( xpi(2) .ne. lamsq ) then
ier0 = ier
if ( xpi(2).eq.0 ) call fferr(97,ier)
cs(10) = zxfflg(xpi(2)/lamsq,0,0D0,ier0)**2 /4
endif
endif
* #] the log(lam) Si:
* #[ the logs for A_i<0:
if ( npoin.eq.4 ) then
clogi(2) = 0
ilogi(2) = 0
clogi(3) = 0
ilogi(3) = 0
endif
* #] the logs for A_i<0:
* #[ the off-shell S3:
else
*
* the divergent terms in the offshell regulator scheme - not
* quite as easy
* wm = p3.p2/sqrtdel - 1 = -s1.s2/sqrtdel - 1
* wp = p3.p2/sqrtdel + 1 = -s1.s2/sqrtdel + 1
* Note that we took the choice sdel2<0 in S1 when
* \delta^{p1 s2}_{p1 p2} < 0 by using yp=zm
*
wm = -1 - piDpj(1,2)/sdel2
wp = wm + 2
if ( abs(wm) .lt. abs(wp) ) then
wm = -xpi(5)*xpi(6)/(del2*wp)
else
wp = -xpi(5)*xpi(6)/(del2*wm)
endif
*
* the im sign
*
if ( -DBLE(cmipj(1,3)) .gt. 0 ) then
ieps = -1
else
ieps = +1
endif
*
if ( nschem .lt. 3 .or. DIMAG(cmipj(1,3)).eq.0 .and.
+ DIMAG(cmipj(2,2)).eq.0 ) then
* #[ real case:
*
* first z-,z+
*
dyzp = -DBLE(cmipj(1,3))*DBLE(wm)/(2*DBLE(xpi(6))) -
+ DBLE(cmipj(2,2))/(2*DBLE(sdel2))
dyzm = -DBLE(cmipj(1,3))*DBLE(wp)/(2*DBLE(xpi(6))) -
+ DBLE(cmipj(2,2))/(2*DBLE(sdel2))
*
* the (di)logs
*
clog1 = zxfflg(-dyzp,-ieps,1D0,ier)
cs(10) = -clog1**2/2
ipi12 = ipi12 - 4
clog2 = zxfflg(-dyzm,+ieps,1D0,ier)
cs(11) = -clog2**2/2
ipi12 = ipi12 - 2
hulp = dyzp/dyzm
if ( dyzp .lt. 0 ) then
ieps1 = -ieps
else
ieps1 = +ieps
endif
call ffzxdl(cli,i,cdum(1),hulp,+ieps1,ier)
cs(12) = -cli
ipi12 = ipi12 - i
*
* the log for npoin=4
*
if ( npoin.eq.4 ) then
if ( ilogi(3) .eq. -999 ) then
if ( DBLE(cmipj(1,3)) .eq. 0 ) then
chulp = -1
chulp1 = 0
elseif ( dyzp .lt. dyzm ) then
chulp = -dyzm/dyzp
chulp1 = +DBLE(cmipj(1,3))/DBLE(xpi(6)*dyzp)
else
chulp = -dyzp/dyzm
chulp1 = -DBLE(cmipj(1,3))/DBLE(xpi(6)*dyzm)
endif
call ffxclg(clogi(3),ilogi(3),chulp,chulp1,dyzp,
+ ier)
endif
endif
* #] real case:
else
* #[ complex case:
*
* first z+
*
cdyzp = -cmipj(1,3)*DBLE(wm)/(2*DBLE(xpi(6))) -
+ cmipj(2,2)/(2*DBLE(sdel2))
clog1 = zfflog(-cdyzp,-ieps,cone,ier)
if ( ieps*DIMAG(cdyzp).lt.0.and.DBLE(cdyzp).gt.0 ) then
clog1 = clog1 - ieps*c2ipi
endif
cs(10) = -clog1**2/2
ipi12 = ipi12 - 4
*
* now z-
*
cdyzm = -cmipj(1,3)*DBLE(wp)/(2*DBLE(xpi(6))) -
+ cmipj(2,2)/(2*DBLE(sdel2))
clog2 = zfflog(-cdyzm,+ieps,cone,ier)
if ( ieps*DIMAG(cdyzm).gt.0.and.DBLE(cdyzm).gt.0 ) then
clog2 = clog2 + ieps*c2ipi
endif
cs(11) = -clog2**2/2
ipi12 = ipi12 - 2
*
* the dilog
*
chulp = cdyzp/cdyzm
hulp = DBLE(cdyzp)/DBLE(cdyzm)
if ( DBLE(cdyzp) .lt. 0 ) then
ieps1 = -ieps
else
ieps1 = +ieps
endif
if ( DIMAG(chulp) .eq. 0 ) then
hulp = DBLE(chulp)
call ffzxdl(cli,i,cdum(1),hulp,+ieps1,ier)
else
call ffzzdl(cli,i,cdum(1),chulp,ier)
if ( hulp.gt.1 .and. ieps1*DIMAG(chulp).lt.0 ) then
cli = cli + ieps1*c2ipi*zfflog(chulp,0,czero,ier)
endif
endif
cs(12) = -cli
ipi12 = ipi12 - i
*
* the log for npoin=4
*
if ( npoin.eq.4 ) then
if ( ilogi(3) .eq. -999 ) then
if ( cmipj(1,3) .eq. 0 ) then
chulp = -1
chulp1 = 0
elseif ( DBLE(cdyzp) .lt. DBLE(cdyzm) ) then
chulp = -cdyzm/cdyzp
chulp1 = +cmipj(1,3)/cdyzp*DBLE(1/xpi(6))
else
chulp = -cdyzp/cdyzm
chulp1 = -cmipj(1,3)/cdyzm*DBLE(1/xpi(6))
endif
dyzp = DBLE(cdyzp)
call ffxclg(clogi(3),ilogi(3),chulp,chulp1,dyzp,
+ ier)
endif
endif
* #] complex case:
endif
* #] the off-shell S3:
* #[ the off-shell S2:
*
* the im sign
*
if ( -DBLE(cmipj(2,2)) .gt. 0 ) then
ieps = -1
else
ieps = +1
endif
*
if ( nschem .lt. 3 ) then
* #[ real case:
*
* first z-
*
dyzm = -DBLE(cmipj(2,2))*DBLE(wp)/(2*DBLE(xpi(5))) -
+ DBLE(cmipj(1,3))/(2*DBLE(sdel2))
clog1 = zxfflg(+dyzm,-ieps,1D0,ier)
cs(13) = +clog1**2/2
ipi12 = ipi12 + 4
*
* now z+
*
dyzp = -DBLE(cmipj(2,2))*DBLE(wm)/(2*DBLE(xpi(5))) -
+ DBLE(cmipj(1,3))/(2*DBLE(sdel2))
clog2 = zxfflg(+dyzp,+ieps,1D0,ier)
cs(14) = +clog2**2/2
ipi12 = ipi12 + 2
hulp = dyzm/dyzp
if ( dyzm .lt. 0 ) then
ieps1 = -ieps
else
ieps1 = +ieps
endif
call ffzxdl(cli,i,cdum(1),hulp,-ieps1,ier)
cs(15) = +cli
ipi12 = ipi12 + i
*
* the log for npoin=4
*
if ( npoin.eq.4 ) then
if ( ilogi(2) .eq. -999 ) then
if ( DBLE(cmipj(2,2)) .eq. 0 ) then
chulp = -1
chulp1 = 0
elseif ( dyzp .lt. dyzm ) then
chulp = -dyzm/dyzp
chulp1 = +DBLE(cmipj(2,2))/DBLE(xpi(5)*dyzp)
elseif ( dyzp .gt. dyzm ) then
chulp = -dyzp/dyzm
chulp1 = -DBLE(cmipj(2,2))/DBLE(xpi(5)*dyzm)
endif
call ffxclg(clogi(2),ilogi(2),chulp,chulp1,dyzp,
+ ier)
endif
endif
* #] real case:
else
* #[ complex case:
*
* first z-
*
cdyzm = -cmipj(2,2)*DBLE(wp)/(2*DBLE(xpi(5))) -
+ cmipj(1,3)/(2*DBLE(sdel2))
clog1 = zfflog(+cdyzm,-ieps,cone,ier)
if ( DBLE(cdyzm).lt.0.and.ieps*DIMAG(cdyzm).gt.0 ) then
clog1 = clog1 - ieps*c2ipi
endif
cs(13) = +clog1**2/2
ipi12 = ipi12 + 4
*
* now z+
*
cdyzp = -cmipj(2,2)*DBLE(wm)/(2*DBLE(xpi(5))) -
+ cmipj(1,3)/(2*DBLE(sdel2))
clog2 = zfflog(+cdyzp,+ieps,cone,ier)
if ( DBLE(cdyzp).lt.0.and.ieps*DIMAG(cdyzp).lt.0 ) then
clog2 = clog2 + ieps*c2ipi
endif
cs(14) = +clog2**2/2
ipi12 = ipi12 + 2
*
* and ghe dilog
*
chulp = cdyzm/cdyzp
hulp = DBLE(dyzm)/DBLE(dyzp)
if ( DBLE(cdyzm) .lt. 0 ) then
ieps1 = -ieps
else
ieps1 = +ieps
endif
if ( DIMAG(chulp ) .eq. 0 ) then
hulp = DBLE(chulp)
call ffzxdl(cli,i,cdum(1),hulp,-ieps1,ier)
else
call ffzzdl(cli,i,cdum(1),chulp,ier)
if ( hulp.gt.1 .and. ieps1*DIMAG(chulp).gt.0 ) then
cli = cli - ieps1*c2ipi*zfflog(chulp,0,czero,ier)
endif
endif
cs(15) = +cli
ipi12 = ipi12 + i
*
* the log for npoin=4
*
if ( npoin.eq.4 ) then
if ( ilogi(2) .eq. -999 ) then
if ( cmipj(2,2) .eq. 0 ) then
chulp = -1
chulp1 = 0
elseif ( DBLE(cdyzp) .lt. DBLE(cdyzm) ) then
chulp = -cdyzm/cdyzp
chulp1 = +cmipj(2,2)/cdyzp*DBLE(1/xpi(5))
elseif ( DBLE(cdyzp) .gt. DBLE(cdyzm) ) then
chulp = -cdyzp/cdyzm
chulp1 = -cmipj(2,2)/cdyzm*DBLE(1/xpi(5))
endif
dyzp = DBLE(cdyzp)
call ffxclg(clogi(2),ilogi(2),chulp,chulp1,dyzp,
+ ier)
endif
endif
* #] complex case:
endif
endif
* #] the off-shell S2:
* #[ sdel2<0!:
if ( sdel2i.gt.0 .neqv. xpi(4).eq.0.and.xpi(1).gt.xpi(2) ) then
if ( .not.lsmug ) then
n = 10
else
n = 15
endif
do 10 i=1,n
cs(i) = -cs(i)
10 continue
ipi12 = -ipi12
if ( npoin.eq.4 ) then
do 20 i=1,3
ilogi(i) = -ilogi(i)
clogi(i) = -clogi(i)
20 continue
endif
endif
* #] sdel2<0!:
*###] ffxc0j:
end
*###[ ffxclg:
subroutine ffxclg(clg,ilg,chulp,chulp1,dyzp,ier)
***#[*comment:***********************************************************
* *
* compute the extra logs for npoin=4 given chulp=-cdyzm/cdyzp *
* all flagchecking has already been done. *
* *
* Input: chulp (complex) see above *
* chulp1 (complex) 1+chulp (in case chulp ~ -1) *
* dyzp (real) (real part of) y-z+ for im part *
* Output: clg (complex) the log *
* ilg (integer) factor i*pi split off clg *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ilg,ier
DOUBLE PRECISION dyzp
DOUBLE COMPLEX clg,chulp,chulp1
*
* local variables
*
DOUBLE PRECISION hulp,hulp1,dfflo1
DOUBLE COMPLEX zxfflg,zfflog,zfflo1
external dfflo1,zxfflg,zfflog,zfflo1
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ work:
*
if ( DIMAG(chulp) .eq. 0 ) then
hulp = DBLE(chulp)
hulp1 = DBLE(chulp1)
if ( abs(hulp1) .lt. xloss ) then
clg = DBLE(dfflo1(hulp1,ier))
else
clg = zxfflg(abs(hulp),0,0D0,ier)
endif
if ( hulp .lt. 0 ) then
if ( dyzp.lt.0 ) then
ilg = +1
else
ilg = -1
endif
else
ilg = 0
endif
else
*
* may have to be improved
*
if ( abs(DBLE(chulp1))+abs(DIMAG(chulp1)) .lt. xloss ) then
clg = zfflo1(chulp1,ier)
else
clg = zfflog(chulp,0,czero,ier)
endif
ilg = 0
if ( DBLE(chulp) .lt. 0 ) then
if ( dyzp.lt.0 .and. DIMAG(clg).lt.0 ) then
ilg = +2
elseif ( dyzp.gt.0 .and. DIMAG(clg).gt.0 ) then
ilg = -2
endif
endif
endif
* #] work:
*###] ffxclg:
end
diff --git a/Looptools/C/ffxc0p.F b/Looptools/C/ffxc0p.F
--- a/Looptools/C/ffxc0p.F
+++ b/Looptools/C/ffxc0p.F
@@ -1,507 +1,510 @@
+#include "externals.h"
+
+
* $Id: ffxc0p.f,v 1.3 1995/10/06 09:17:26 gj Exp $
* $Log: ffxc0p.f,v $
c Revision 1.3 1995/10/06 09:17:26 gj
c Found stupid typo in ffxc0p which caused the result to be off by pi^2/3 in
c some equal-mass cases. Added checks to ffcxs4.f ffcrr.f.
c
*###[ ffxc0p:
subroutine ffxc0p(cs3,ipi12,isoort,clogi,ilogi,xpi,dpipj,piDpj,
+ sdel2,del2s,etalam,etami,delpsi,alph,npoin,ier)
***#[*comment:***********************************************************
* *
* calculates the threepoint function closely following *
* recipe in 't Hooft & Veltman, NP B(183) 1979. *
* Bjorken and Drell metric is used nowadays! *
* *
* p2 ^ | *
* | | *
* / \ *
* m2/ \m3 *
* p1 / \ p3 *
* <- / m1 \ -> *
* ------------------------ *
* *
* Input: xpi(1-3) (real) pi squared *
* xpi(4-6) (real) internal mass squared *
* dpipj(6,6) (real) xpi(i)-xpi(j) *
* piDpj(6,6) (real) pi(i).pi(j) *
* sdel2 (real) sqrt(delta_{p_1 p_2}^{p_1 p_2}) *
* del2s(3) (real) delta_{p_i s_i}^{p_i s_i} *
* etalam (real) delta_{s_1 s_2 s_3}^{s_1 s_2 s_3}
* /delta_{p_1 p_2}^{p_1 p_2} *
* etami(6) (real) m_i^2 - etalam *
* alph(3) (real) alph(1)=alpha, alph(3)=1-alpha *
* *
* Output: cs3(80) (complex) C0, not yet summed. *
* ipi12(8) (integer) factors pi^2/12, not yet summed *
* slam (complex) lambda(p1,p2,p3). *
* isoort(8) (integer) indication of he method used *
* clogi(3) (complex) log(-dyz(2,1,i)/dyz(2,2,i)) *
* ilogi(3) (integer) factors i*pi in this *
* ier (integer) number of digits inaccurate in *
* answer *
* *
* Calls: ffroot,ffxxyz,ffcxyz,ffdwz,ffcdwz, *
* ffcxs3,ffcs3,ffcxs4,ffcs4 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(8),isoort(8),ilogi(3),npoin,ier
DOUBLE COMPLEX cs3(80),clogi(3)
DOUBLE PRECISION xpi(6),dpipj(6,6),piDpj(6,6),sdel2,del2s(3),
+ etalam,etami(6),delpsi(3),alph(3)
*
* local variables:
*
integer i,j,k,m,ip,jsoort(8),ierw,iw,ier0,ier1,irota,
+ ilogip(3)
logical l4,lcompl,lcpi,l4pos
DOUBLE COMPLEX c,cs,calph(3),csdl2i(3),csdel2
DOUBLE COMPLEX cy(4,3),cz(4,3),cw(4,3),cdyz(2,2,3),cdwy(2,2,3),
+ cdwz(2,2,3),cd2yzz(3),cd2yww(3)
DOUBLE COMPLEX cpi(6),cdpipj(6,6),cpiDpj(6,6),clogip(3)
DOUBLE PRECISION y(4,3),z(4,3),w(4,3),dyz(2,2,3),dwy(2,2,3),
+ dwz(2,2,3),d2yzz(3),d2yww(3),dy2z(4,3)
DOUBLE PRECISION sdel2i(3),s1,s2
DOUBLE PRECISION absc,s,xqi(6),dqiqj(6,6),qiDqj(6,6)
DOUBLE PRECISION dfflo1
DOUBLE COMPLEX zxfflg
external dfflo1,zxfflg
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ IR case:
*
* but only the off-shell regulator case - the log(lam) has been
* caught before
*
if ( lsmug ) then
do 5 i=1,3
if ( xpi(i) .eq. 0 ) then
j = mod(i,3)+1
k = mod(j,3)+1
if ( piDpj(i,j).eq.0 .and. piDpj(i,k).eq.0 ) then
call ffrot3(irota,xqi,dqiqj,qiDqj,
+ xpi,dpipj,piDpj,3,4,ier)
if ( npoin.eq.4 ) call ffrt3p(clogip,ilogip,
+ irota,clogi,ilogi,+1)
call ffxc0j(cs3(1),ipi12(1),sdel2,clogip,ilogip,
+ xqi,dqiqj,qiDqj,0D0,4,ier)
if ( npoin.eq.4 ) call ffrt3p(clogi,ilogi,irota,
+ clogip,ilogip,-1)
return
endif
endif
5 continue
endif
* #] IR case:
* #[ get roots etc:
* #[ get z-roots:
* if ( npoin .eq. 3 ) then
l4pos = l4also
* else
* l4pos = .FALSE.
* endif
lcompl = .FALSE.
ier1 = ier
do 10 i=1,3
*
* get roots (y,z,w) and flag what to do: 0=nothing, 1=normal,
* -1=complex
*
ip = i+3
* first get the roots
ier0 = ier
if ( del2s(i) .le. 0 ) then
* real case
sdel2i(i) = sqrt(-del2s(i))
csdl2i(i) = sdel2i(i)
* then handle the special case Si = 0
if ( xpi(ip) .eq. 0 ) then
if ( i .eq. 1 .and. alph(3) .eq. 0 .or.
+ i .eq. 3 .and. alph(1) .eq. 0 ) then
isoort(2*i-1) = 0
isoort(2*i) = 0
l4pos = .FALSE.
goto 10
endif
endif
call ffxxyz(y(1,i),z(1,i),dyz(1,1,i),d2yzz(i),dy2z(1,i),
+ i,sdel2,sdel2i(i),etalam,etami,delpsi(i),xpi,
+ dpipj,piDpj,isoort(2*i-1),.FALSE.,6,ier0)
else
* complex case
sdel2i(i) = sqrt(del2s(i))
csdl2i(i) = DCMPLX(0D0,sdel2i(i))
lcompl = .TRUE.
call ffcxyz(cy(1,i),cz(1,i),cdyz(1,1,i),cd2yzz(i),i,
+ sdel2,sdel2i(i),etami,delpsi(i),xpi,
+ piDpj,isoort(2*i-1),.FALSE.,6,ier0)
endif
ier1 = max(ier1,ier0)
10 continue
ier = ier1
* #] get z-roots:
* #[ get w-roots:
*
* get w's:
*
ierw = ier
l4 = .FALSE.
lcpi = .FALSE.
if ( isoort(4) .eq. 0 ) then
* no error message; just bail out
ierw = ierw + 100
goto 90
endif
do 70 iw = 1,3,2
if ( .not. l4pos .or. alph(4-iw) .eq. 0 ) then
jsoort(2*iw-1) = 0
jsoort(2*iw) = 0
l4pos = .FALSE.
else
if ( isoort(4) .gt. 0 .and. isoort(2*iw) .ge. 0 ) then
jsoort(2*iw-1) = 1
jsoort(2*iw) = 1
d2yww(iw) = -d2yzz(2)/alph(4-iw)
do 20 j=1,2
w(j+iw-1,iw) = z(j+3-iw,2)/alph(4-iw)
w(j+3-iw,iw) = 1 - w(j+iw-1,iw)
if ( abs(w(j+3-iw,iw)) .lt. xloss ) then
s = z(j+iw-1,2) - alph(iw)
if ( abs(s) .lt. xloss*alph(iw) ) then
ierw = ierw + 15
goto 70
endif
w(j+3-iw,iw) = s/alph(4-iw)
endif
dwy(j,2,iw) = dyz(2,j,2)/alph(4-iw)
do 15 i=1,2
dwz(j,i,iw) = w(j,iw) - z(i,iw)
if ( abs(dwz(j,i,iw)) .ge. xloss*abs(w(j,iw)) )
+ goto 14
dwz(j,i,iw) = z(i+2,iw) - w(j+2,iw)
if ( abs(dwz(j,i,iw)) .ge. xloss*abs(w(j+2,iw)) )
+ goto 14
dwz(j,i,iw) = dwy(j,2,iw) + dyz(2,i,iw)
if ( abs(dwz(j,i,iw)) .ge. xloss*abs(dwy(j,2,iw)) )
+ goto 14
l4 = .TRUE.
call ffdwz(dwz(1,1,iw),z(1,iw),j,i,iw,
+ alph(1),alph(3),xpi,dpipj,piDpj,sdel2i,6,ierw)
14 continue
15 continue
20 continue
else
* convert to complex ...
jsoort(2*iw-1) = -10
jsoort(2*iw) = -10
if ( isoort(4).ge.0 .and. (iw.eq.1 .or. isoort(2).ge.0) )
+ then
cd2yzz(2) = d2yzz(2)
do 21 i=1,4
cy(i,2) = y(i,2)
cz(i,2) = z(i,2)
21 continue
do 23 i=1,2
do 22 j=1,2
cdyz(j,i,2) = dyz(j,i,2)
22 continue
23 continue
endif
if ( isoort(2*iw) .ge. 0 ) then
cd2yzz(iw) = d2yzz(iw)
do 24 i=1,4
cy(i,iw) = y(i,iw)
cz(i,iw) = z(i,iw)
24 continue
do 26 i=1,2
do 25 j=1,2
cdyz(j,i,iw) = dyz(j,i,iw)
25 continue
26 continue
endif
cd2yww(iw) = -cd2yzz(2)/DBLE(alph(4-iw))
do 30 j=1,2
cw(j+iw-1,iw) = cz(j+3-iw,2)/DBLE(alph(4-iw))
cw(j+3-iw,iw) = 1 - cw(j+iw-1,iw)
if ( absc(cw(j+3-iw,iw)) .lt. xloss ) then
cs = cz(j+iw-1,2) - DBLE(alph(iw))
if ( absc(cs) .lt. xloss*alph(iw) ) ierw = ierw + 15
cw(j+3-iw,iw) = cs/DBLE(alph(4-iw))
endif
cdwy(j,2,iw) = cdyz(2,j,2)/DBLE(alph(4-iw))
do 29 i=1,2
cdwz(j,i,iw) = cw(j,iw) - cz(i,iw)
if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cw(j,iw)) )
+ goto 31
cdwz(j,i,iw) = cz(i+2,iw) - cw(j+2,iw)
if ( absc(cdwz(j,i,iw)) .ge. xloss*absc(cw(j+2,iw)))
+ goto 31
cdwz(j,i,iw) = cdwy(j,2,iw) + cdyz(2,i,iw)
if ( absc(cdwz(j,i,iw)).ge.xloss*absc(cdwy(j,2,iw)))
+ goto 31
l4 = .TRUE.
if ( .not. lcpi ) then
lcpi = .TRUE.
calph(1) = alph(1)
calph(3) = alph(3)
csdel2 = sdel2
do 28 k=1,6
cpi(k) = xpi(k)
do 27 m=1,6
cdpipj(m,k) = dpipj(m,k)
cpiDpj(m,k) = piDpj(m,k)
27 continue
28 continue
endif
call ffcdwz(cdwz(1,1,iw),cz(1,iw),j,i,iw,
+ calph(1),calph(3),cpi,cdpipj,cpiDpj,csdl2i,
+ csdel2,6,ierw)
31 continue
29 continue
30 continue
endif
endif
70 continue
90 continue
ierw = ierw-ier
* #] get w-roots:
* #[ which case:
if ( l4 ) then
* 21-aug-1995. added check for isoort(2*i-1).eq.0 to avoid
* undefined variables etc in ffdcs, ffdcrr. They should be
* able to handle this, but are not (yet?)
if ( ierw .ge. 1 .or. isoort(1).eq.0 .or. isoort(3).eq.0
+ .or. isoort(5).eq.0 ) then
l4pos = .FALSE.
else
ier = ier + ierw
endif
endif
* #] which case:
* #] get roots etc:
* #[ logarithms for 4point function:
if ( npoin .eq. 4 ) then
do 95 i = 1,3
if ( ilogi(i) .ne. -999 ) goto 95
if ( isoort(2*i) .gt. 0 .and.
+ isoort(2*i-1) .ge. 0 ) then
s1 = -dyz(2,1,i)/dyz(2,2,i)
if ( abs(s1-1) .lt. xloss ) then
clogi(i) = dfflo1(d2yzz(i)/dyz(2,2,i),ier)
ilogi(i) = 0
else
if ( abs(s1+1) .lt. xloss ) then
clogi(i) = dfflo1(-2*sdel2i(i)/(xpi(i+3)*
+ dyz(2,2,i)),ier)
else
clogi(i) = zxfflg(abs(s1),0,0D0,ier)
endif
if ( dyz(2,2,i).gt.0 .and. dyz(2,1,i).gt.0 ) then
ilogi(i) = -1
elseif ( dyz(2,1,i).lt.0 .and. dyz(2,2,i).lt.0) then
ilogi(i) = +1
else
ilogi(i) = 0
endif
endif
elseif ( isoort(2*i-1) .lt. 0 ) then
* for stability split the unit circle up in 4*pi/2
* (this may have to be improved to 8*pi/4...)
ier0 = 0
if ( DBLE(cdyz(2,1,i)) .gt. DIMAG(cdyz(2,1,i)) ) then
s = 2*atan2(DIMAG(cdyz(2,1,i)),DBLE(cdyz(2,1,i)))
clogi(i) = DCMPLX(0D0,s)
ilogi(i) = -1
elseif ( DBLE(cdyz(2,1,i)) .lt. -DIMAG(cdyz(2,1,i)))
+ then
if ( DIMAG(cdyz(2,1,i)) .eq. 0 ) then
call fferr(84,ier)
endif
s = 2*atan2(-DIMAG(cdyz(2,1,i)),-DBLE(cdyz(2,1,i)))
clogi(i) = DCMPLX(0D0,s)
ilogi(i) = 1
else
s1 = -DBLE(cdyz(2,1,i))
s2 = DIMAG(cdyz(2,1,i))
s = 2*atan2(s1,s2)
clogi(i) = DCMPLX(0D0,s)
ilogi(i) = 0
endif
endif
95 continue
* An algorithm to obtain the sum of two small logarithms more
* accurately has been put in ffcc0p, not yet here
endif
* #] logarithms for 4point function:
* #[ real case integrals:
ier1 = ier
if ( .not. lcompl ) then
if ( .not. l4 .or. .not. l4pos ) then
* normal case
do 100 i=1,3
j = 2*i-1
if ( isoort(j) .ne. 0 ) then
ier0 = ier
call ffcxs3(cs3(20*i-19),ipi12(j),y(1,i),z(1,i),
+ dyz(1,1,i),d2yzz(i),dy2z(1,i),xpi,piDpj,
+ i,6,isoort(j),ier0)
ier1 = max(ier1,ier0)
endif
100 continue
isoort(7) = 0
isoort(8) = 0
else
do 110 i=1,3,2
j = 2*i-1
isoort(j+2) = jsoort(j)
isoort(j+3) = jsoort(j+1)
ier0 = ier
call ffcxs4(cs3(20*i-19),ipi12(j),w(1,i),y(1,i),
+ z(1,i),dwy(1,1,i),dwz(1,1,i),dyz(1,1,i),
+ d2yww(i),d2yzz(i),xpi,piDpj,i,6,isoort(j),ier0)
ier1 = max(ier1,ier0)
110 continue
endif
* #] real case integrals:
* #[ complex case integrals:
else
* convert xpi
if ( .not.lcpi ) then
do 190 i=1,6
cpi(i) = xpi(i)
190 continue
endif
if ( .not. l4 .or. .not. l4pos ) then
* normal case
do 200 i=1,3
j = 2*i-1
ier0 = ier
if ( isoort(j) .gt. 0 ) then
call ffcxs3(cs3(20*i-19),ipi12(2*i-1),y(1,i),
+ z(1,i),dyz(1,1,i),d2yzz(i),dy2z(1,i),
+ xpi,piDpj,i,6,isoort(j),ier0)
elseif( isoort(j) .ne. 0 ) then
call ffcs3(cs3(20*i-19),ipi12(2*i-1),cy(1,i),
+ cz(1,i),cdyz(1,1,i),cd2yzz(i),cpi,
+ cpiDpj,i,6,isoort(j),ier0)
endif
ier1 = max(ier1,ier0)
200 continue
isoort(7) = 0
isoort(8) = 0
else
isoort(3) = jsoort(1)
isoort(4) = jsoort(2)
ier0 = ier
if ( isoort(1) .gt. 0 .and. isoort(3) .gt. 0 ) then
call ffcxs4(cs3(1),ipi12(1),w(1,1),y(1,1),
+ z(1,1),dwy(1,1,1),dwz(1,1,1),dyz(1,1,1),
+ d2yww(1),d2yzz(1),xpi,piDpj,1,6,isoort(1),ier0)
else
call ffcs4(cs3(1),ipi12(1),cw(1,1),cy(1,1),
+ cz(1,1),cdwy(1,1,1),cdwz(1,1,1),cdyz(1,1,1),
+ cd2yww(1),cd2yzz(1),cpi,cpiDpj,
+ DCMPLX(xpi(5)*alph(3)**2),1,6,isoort(1),
+ ier0)
endif
ier1 = max(ier1,ier0)
isoort(7) = jsoort(5)
isoort(8) = jsoort(6)
ier0 = ier
if ( isoort(5) .gt. 0 .and. isoort(7) .gt. 0 ) then
call ffcxs4(cs3(41),ipi12(5),w(1,3),y(1,3),
+ z(1,3),dwy(1,1,3),dwz(1,1,3),dyz(1,1,3),
+ d2yww(3),d2yzz(3),xpi,piDpj,3,6,isoort(5),ier0)
else
call ffcs4(cs3(41),ipi12(5),cw(1,3),cy(1,3),
+ cz(1,3),cdwy(1,1,3),cdwz(1,1,3),cdyz(1,1,3),
+ cd2yww(3),cd2yzz(3),cpi,cpiDpj,
+ DCMPLX(xpi(5)*alph(1)**2),3,6,isoort(5),
+ ier0)
endif
ier1 = max(ier1,ier0)
endif
endif
ier = ier1
* #] complex case integrals:
*###] ffxc0p:
end
*###[ ffrt3p:
subroutine ffrt3p(clogip,ilogip,irota,clogi,ilogi,idir)
***#[*comment:***********************************************************
* *
* rotates the arrays clogi,ilogi also over irota (idir=+1) or *
* back (-1) *
* *
* Input: irota (integer) index in rotation array *
* clogi(3) (complex) only if idir=-1 *
* ilogi(3) (integer) indicates which clogi are needed*
* (idir=+1), i*pi terms (idir=-1) *
* idir (integer) direction: forward (+1) or *
* backward (-1) *
* Output: clogip(3) (integer) clogi rotated *
* ilogip(3) (integer) ilogi rotated *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer irota,idir,ilogi(3),ilogip(3)
DOUBLE COMPLEX clogi(3),clogip(3)
*
* local variables
*
integer i,inew(6,6)
save inew
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data inew /1,2,3,4,5,6,
+ 2,3,1,5,6,4,
+ 3,1,2,6,4,5,
+ 1,3,2,6,5,4,
+ 3,2,1,5,4,6,
+ 2,1,3,4,6,5/
* #] declarations:
* #[ rotate:
*
* the clogi, ilogi are numbered according to the p_i
*
if ( idir .eq. +1 ) then
do 10 i=1,3
ilogip(inew(i+3,irota)-3) = ilogi(i)
clogip(inew(i+3,irota)-3) = clogi(i)
10 continue
else
do 20 i=1,3
ilogip(i) = ilogi(inew(i+3,irota)-3)
clogip(i) = clogi(inew(i+3,irota)-3)
20 continue
endif
*
* #] rotate:
*###] ffrt3p:
end
diff --git a/Looptools/C/ffxc0p0.F b/Looptools/C/ffxc0p0.F
--- a/Looptools/C/ffxc0p0.F
+++ b/Looptools/C/ffxc0p0.F
@@ -1,86 +1,86 @@
+#include "externals.h"
+
+
*###[ ffxc0p0
- subroutine ffxc0p0(cc0, xpi, ier)
+ subroutine ffxc0p0(cc0, xpi)
***#[*comment:***********************************************************
* *
* C0 function for all three momenta^2 = 0 *
* input parameters as for ffxc0 *
* *
* original code from David Garcia *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
+ DOUBLE COMPLEX cc0
DOUBLE PRECISION xpi(6)
- DOUBLE COMPLEX cc0
- integer ier
DOUBLE PRECISION m1, m2, m3, m
- DOUBLE PRECISION xeps
- parameter (xeps = 1D-6)
- include 'ff.h'
+#include "ff.h"
m1 = xpi(1)
m2 = xpi(2)
m3 = xpi(3)
* sort the masses such that m1 >= m2 >= m3
* this is important to avoid complex logs later
- if(m1 .lt. m2) then
+ if( m1 .lt. m2 ) then
m = m2
m2 = m1
m1 = m
endif
- if(m2 .lt. m3) then
+ if( m2 .lt. m3 ) then
m = m3
m3 = m2
m2 = m
endif
- if(m1 .lt. m2) then
+ if( m1 .lt. m2 ) then
m = m2
m2 = m1
m1 = m
endif
- m = m1 + m2 + m3
+ m = (m1 + m2 + m3)*1D-6
- if(m3/m .gt. xeps) then
+ if( m3 .gt. m ) then
* non-zero masses:
- if((m2 - m3)/m .gt. xeps) then
- if((m1 - m2)/m .gt. xeps) then
+ if( m2 - m3 .gt. m ) then
+ if( m1 - m2 .gt. m ) then
* m1 != m2 != m3
- cc0 = (log(m3/m2) + m1/(m3 - m1)*log(m3/m1)
- + - m1/(m2 - m1)*log(m2/m1))/(m2 - m3)
+ cc0 = (log(m3/m2) + m1/(m3 - m1)*log(m3/m1) -
+ & m1/(m2 - m1)*log(m2/m1))/(m2 - m3)
else
* m1 = m2 != m3
cc0 = (1 - m3/(m2 - m3)*log(m2/m3))/(m3 - m2)
endif
else
- if((m1 - m2)/m .gt. xeps) then
+ if( m1 - m2 .gt. m ) then
* m1 != m2 = m3
cc0 = (1 - m1/(m2 - m1)*log(m2/m1))/(m1 - m2)
else
* m1 = m2 = m3
cc0 = -.5D0/m1
endif
endif
else
* zero masses:
- if((m1 - m2)/m .gt. xeps) then
+ if( m1 - m2 .gt. m ) then
* m1 != m2, m3 = 0
cc0 = log(m2/m1)/(m1 - m2)
else
* m1 = m2, m3 = 0
- cc0 = -1D0/m1
+ cc0 = -1/m1
endif
endif
end
diff --git a/Looptools/D/D0.F b/Looptools/D/D0.F
--- a/Looptools/D/D0.F
+++ b/Looptools/D/D0.F
@@ -1,853 +1,1713 @@
* D0.F
* the scalar four-point function
* this file is part of LoopTools
-* last modified 10 Apr 06 th
+* last modified 14 Dec 10 th
#include "defs.h"
+#define legs 4
+#define M(i) xpi(i)
+#define P(i) xpi(i+legs)
+
double complex function D0(p1, p2, p3, p4, p1p2, p2p3,
& m1, m2, m3, m4)
implicit none
double precision p1, p2, p3, p4, p1p2, p2p3
double precision m1, m2, m3, m4
#include "lt.h"
- double complex D0b
- external D0b
-
double complex res(0:1)
double precision xpi(13)
integer key, ier
+ external D0softDR, D0collDR, D0soft, D0coll
+
+ M(1) = m1
+ M(2) = m2
+ M(3) = m3
+ M(4) = m4
+ P(1) = p1
+ P(2) = p2
+ P(3) = p3
+ P(4) = p4
+ P(5) = p1p2
+ P(6) = p2p3
+ P(7) = 0
+ P(8) = 0
+ P(9) = 0
+
+ if( lambda .le. 0 ) then
+ call DDispatch(D0, xpi, D0softDR, D0collDR)
+ return
+ endif
+
ier = 0
key = ibits(versionkey, KeyD0, 2)
if( key .ne. 1 ) then
- xpi(1) = m1
- xpi(2) = m2
- xpi(3) = m3
- xpi(4) = m4
- xpi(5) = p1
- xpi(6) = p2
- xpi(7) = p3
- xpi(8) = p4
- xpi(9) = p1p2
- xpi(10) = p2p3
- xpi(11) = 0
- xpi(12) = 0
- xpi(13) = 0
call ffxd0(res(0), xpi, ier)
if( ier .gt. warndigits ) then
ier = 0
call ffxd0r(res(0), xpi, ier)
if( ier .gt. warndigits ) key = ior(key, 2)
if( ier .ge. errdigits ) key = ior(key, 3)
endif
endif
if( key .ne. 0 ) then
- res(1) = D0b(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)
+ call DDispatch(res(1), xpi, D0soft, D0coll)
if( key .gt. 1 .and.
& abs(res(0) - res(1)) .gt. maxdev*abs(res(0)) ) then
print *, "Discrepancy in D0:"
print *, " p1 =", p1
print *, " p2 =", p2
print *, " p3 =", p3
print *, " p4 =", p4
print *, " p1p2 =", p1p2
print *, " p2p3 =", p2p3
print *, " m1 =", m1
print *, " m2 =", m2
print *, " m3 =", m3
print *, " m4 =", m4
print *, "D0 a =", res(0)
print *, "D0 b =", res(1)
if( ier .gt. errdigits ) res(0) = res(1)
endif
endif
D0 = res(iand(key, 1))
end
************************************************************************
* adapter code for C++
subroutine d0sub(res, p1, p2, p3, p4, p1p2, p2p3,
& m1, m2, m3, m4)
implicit none
double complex res
double precision p1, p2, p3, p4, p1p2, p2p3
double precision m1, m2, m3, m4
double complex D0
external D0
res = D0(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)
end
************************************************************************
+
+ subroutine DDispatch(res, xpi, soft, coll)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ external soft, coll
+
+#include "lt.h"
+
+ integer i, z, s, perm
+
+ integer xpiperm(12), mperm(0:7)
+ data xpiperm /
+ & O'1234561234', O'1635421243', O'5264131324',
+ & O'2341652341', O'6351242431', O'2546132314',
+ & O'3412563412', O'5462313142', O'3615243421',
+ & O'4123654123', O'4526314132', O'6153424213' /
+ data mperm / O'1234561234', O'1234561234',
+ & O'5264131324', O'1234561234', O'4321561432',
+ & O'1635421243', O'5361421342', O'1234561234' /
+
+* 0 1 1xxx O'1234561234'
+* 1 2 12xx O'1234561234'
+* 2 2 13xx O'5264131324'
+* 3 3 123x O'1234561234'
+* 4 2 14xx O'4321561432'
+* 5 3 124x O'1635421243'
+* 6 3 134x O'5361421342'
+* 7 4 xxxx O'1234561234'
+
+#define pj(p,j) ibits(p,3*(10-j),3)
+#define mj(p,j) ibits(p,3*(4-j),3)
+
+#define Px(j) P(pj(perm,j))
+#define Mx(j) M(mj(perm,j))
+
+ z = 0
+ s = 0
+ do i = 1, 12
+ perm = xpiperm(i)
+ if( abs(Mx(1)) .lt. eps ) then
+ if( abs(Px(1)) + abs(Mx(2)) .lt. eps ) then
+ call coll(res, xpi, perm)
+ if( res .ne. perm ) return
+ endif
+ if( s .eq. 0 .and.
+ & abs(Px(1) - Mx(2)) +
+ & abs(Px(4) - Mx(4)) .lt. acc ) s = perm
+ if( z .eq. 0 ) z = perm
+ endif
+ enddo
+
+ if( s .ne. 0 ) then
+ call soft(res, xpi, s)
+ return
+ endif
+
+ if( z .eq. 0 ) then
+ call D0m4(res, xpi)
+ return
+ endif
+
+ perm = z
+ z = 0
+ if( abs(Mx(2)) .lt. eps ) z = 1
+ if( abs(Mx(3)) .lt. eps ) z = z + 2
+ if( abs(Mx(4)) .lt. eps ) z = z + 4
+ s = mperm(z)
+ if( s .ne. O'1234561234' ) perm =
+ & pj(perm, pj(s, 1))*8**9 +
+ & pj(perm, pj(s, 2))*8**8 +
+ & pj(perm, pj(s, 3))*8**7 +
+ & pj(perm, pj(s, 4))*8**6 +
+ & pj(perm, pj(s, 5))*8**5 +
+ & pj(perm, pj(s, 6))*8**4 +
+ & mj(perm, mj(s, 1))*8**3 +
+ & mj(perm, mj(s, 2))*8**2 +
+ & mj(perm, mj(s, 3))*8**1 +
+ & mj(perm, mj(s, 4))*8**0
+
+ goto (2, 2, 3, 2, 3, 3, 4) z
+
+ call D0m3(res, xpi, perm)
+ return
+
+2 call D0m2(res, xpi, perm)
+ return
+
+3 call D0m1(res, xpi, perm)
+ return
+
+4 call D0m0(res, xpi)
+ end
+
+************************************************************************
+
+ subroutine D0soft(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision m3, p1, p2, p3, p4, p1p2, p2p3
+ double precision r1, r3, r4
+ double complex xs, x2, x3, y, c, fac
+ double complex lxs, lx2, lx3, l1x2, l1x3, ly, lm
+
+ double complex ln, spence, bdK
+ external ln, spence, bdK
+
+ m3 = Mx(3)
+ p1 = Px(1)
+ p2 = Px(2)
+ p3 = Px(3)
+ p4 = Px(4)
+ p1p2 = Px(5)
+ p2p3 = Px(6)
+
+ r1 = sqrt(p1)
+ r4 = sqrt(p4)
+ fac = .5D0/(r1*r4*(p1p2 - m3))
+ xs = bdK(p2p3, r1, r4)
+ lxs = -1
+ if( xs .ne. 1 ) then
+ lxs = log(xs)
+ fac = 2*xs/((1 - xs)*(1 + xs))*fac
+ endif
+
+* massless case
+ if( abs(m3) .lt. eps ) then
+ if( abs(p1 - p2) + abs(p3 - p4) .lt. acc ) then
+ res = -2*ln(-lambda/p1p2, 1D0)*lxs*fac
+ return
+ endif
+ y = (r1*(p3 - p4 + cI*eps))/(r4*(p2 - p1 + cI*eps))
+ ly = log(y)
+ c = ln(lambda/(r1*r4), 0D0) +
+ & ln((p2 - p1)/p1p2, p1 - p2) +
+ & ln((p3 - p4)/p1p2, p4 - p3)
+ if( xs .eq. 1 ) then
+ res = fac*(c - 2 - (1 + y)/(1 - y)*ly)
+ else
+ res = fac*(pi6 -
+ & spence(xs/y, 0D0) -
+ & (lxs + log(1/y))*log(1 - xs/y) -
+ & spence(xs*y, 0D0) -
+ & (lxs + ly)*(log(1 - xs*y) + .5D0*(lxs - ly)) +
+ & spence(xs**2, 0D0) +
+ & lxs*(2*log((1 - xs)*(1 + xs)) - c))
+ endif
+ return
+ endif
+
+* massive case
+ r3 = sqrt(m3)
+ x2 = bdK(p2, r1, r3)
+ x3 = bdK(p3, r4, r3)
+ lx2 = log(x2)
+ lx3 = log(x3)
+ l1x3 = log(1/x3)
+ lm = 2*ln(r3*sqrt(lambda)/(m3 - p1p2), 1D0)
+ if( xs .eq. 1 ) then
+ c = -2
+ if( abs(x2 - x3) .gt. acc ) then
+ c = (1 + x2/x3)/(1 - x2/x3)*(lx2 + l1x3) +
+ & (1 + x2*x3)/(1 - x2*x3)*(lx2 + lx3) + 2
+ else if( abs(x2 - 1) .gt. acc ) then
+ c = -2*(x2**2 + 1)/((x2 - 1)*(x2 + 1))*lx2
+ endif
+ res = fac*(lm - c)
+ else
+ l1x2 = log(1/x2)
+ res = fac*( .5D0*pi**2 +
+ & lxs*(2*log((1 - xs)*(1 + xs)) - lm) +
+ & spence(xs**2, 0D0) + lx2**2 + lx3**2 -
+ & spence(xs/(x2*x3), 0D0) -
+ & (lxs + l1x2 + l1x3)*log(1 - xs/(x2*x3)) -
+ & spence(xs*x2/x3, 0D0) -
+ & (lxs + lx2 + l1x3)*log(1 - xs*x2/x3) -
+ & spence(xs/x2*x3, 0D0) -
+ & (lxs + l1x2 + lx3)*log(1 - xs/x2*x3) -
+ & spence(xs*x2*x3, 0D0) -
+ & (lxs + lx2 + lx3)*log(1 - xs*x2*x3) )
+ endif
+ end
+
+************************************************************************
+
+ double complex function bdK(x, m1, m2)
+* this is actually -K from the Beenakker/Denner paper for D0soft
+ implicit none
+ double precision x, m1, m2
+
+#include "lt.h"
+
+ double precision d
+ double complex t
+
+ d = x - (m1 - m2)**2
+ if( abs(d) .lt. acc ) then
+ bdK = 1
+ else
+ t = 4*m1*m2/(d + cI*eps)
+ bdK = -t/(sqrt(1 - t) + 1)**2
+ endif
+ end
+
+************************************************************************
+
+ subroutine D0coll(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ logical ini
+ data ini /.FALSE./
+
+ Px(1) = max(minmass, 1D-14)
+ res = perm
+
+ if( ini ) return
+ print *, "collinear-divergent D0, using mass cutoff ", Px(1)
+ ini = .TRUE.
+ end
+
+************************************************************************
+* IR-divergent D0 in dim reg
+* from W. Beenakker and A. Denner, NPB 338 (1990) 349
+
+ subroutine D0softDR(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision m2, m3, m4, p2, p3, t, p2p3, q2, q3
+ double precision r1, r3, r4, m24, sy
+ double complex c, fac, xs, x2, x3, lxs, lx2, lx3, lm, y
+
+ double complex bdK, ln, cln, lnrat, Li2omx2, Li2omx3
+ external bdK, ln, cln, lnrat, Li2omx2, Li2omx3
+
+c PRINT *, "D0softDR"
+
+ if( lambda .eq. -2 ) then
+ res = 0
+ return
+ endif
+
+ m2 = Mx(2)
+ m3 = Mx(3)
+ m4 = Mx(4)
+ t = m3 - Px(5)
+ p2p3 = Px(6)
+
+ p2 = Px(2)
+ q2 = m2 - p2
+ p3 = Px(3)
+ q3 = m4 - p3
+
+ r1 = sqrt(m2)
+ r4 = sqrt(m4)
+
+ fac = .5D0/(r1*r4*t)
+ xs = bdK(p2p3, r1, r4)
+ lxs = -1
+ if( xs .ne. 1 ) then
+ lxs = log(xs)
+ fac = 2*xs/((1 - xs)*(1 + xs))*fac
+ endif
+
+ if( abs(m3) .lt. eps ) then
+ if( abs(q2) + abs(q3) .lt. acc ) then
+* qlbox14: D0(m2, m2, m4, m4; p1p2, p2p3; 0, m2, 0, m4)
+c PRINT *, "D0softDR: qlbox14"
+ res = 2*fac*lxs
+ if( lambda .ne. -1 ) res = res*lnrat(mudim, t)
+ return
+ endif
+
+* qlbox15: D0(m2, p2, p3, m4; p1p2, p2p3; 0, m2, 0, m4)
+* Beenakker-Denner Eq. (2.11)
+c PRINT *, "D0softDR: qlbox15"
+ if( lambda .eq. -1 ) then
+ res = fac*lxs
+ return
+ endif
+
+ if( abs(q2*q3) .lt. acc ) then
+ m24 = m2
+ if( abs(q2) .lt. acc ) m24 = m4
+ res = fac*( lxs*(lxs + log(mudim/m24) +
+ & 2*lnrat(q2 + q3, t)) +
+ & Li2omx2(xs, 1D0, xs, 1D0) )
+ return
+ endif
+
+ y = r1*q3/(r4*q2)
+ sy = sign(.5D0, r1*q3) - sign(.5D0, r4*q2)
+
+ if( xs .eq. 1 ) then
+ res = fac*( -log(mudim/(r1*r4)) +
+ & lnrat(q2, t) + lnrat(q3, t) + 2 +
+ & (1 + y)/(1 - y)*ln(y, sy) )
+ else
+ res = fac*( -.5D0*ln(y, sy)**2 +
+ & lxs*(.5D0*lxs + lnrat(q2, t) + lnrat(q3, t) +
+ & log(mudim/(r1*r4))) +
+ & Li2omx2(xs, 1D0, xs, 1D0) -
+ & Li2omx2(xs, 1D0, y, sy) -
+ & Li2omx2(xs, 1D0, 1/y, -sy) )
+ endif
+ return
+ endif
+
+* qlbox16: D0(m2, p2, p3, m4; p1p2, p2p3; 0, m2, m3, m4)
+* Beenakker-Denner Eq. (2.9)
+c PRINT *, "D0softDR: qlbox16"
+
+ if( lambda .eq. -1 ) then
+ res = fac*lxs
+ return
+ endif
+
+ r3 = sqrt(m3)
+ x2 = bdK(p2, r1, r3)
+ x3 = bdK(p3, r4, r3)
+ lx2 = log(x2)
+ lx3 = log(x3)
+
+ lm = 2*lnrat(sqrt(m3*mudim), t)
+
+ if( xs .eq. 1 ) then
+ c = -2
+ if( abs(x2 - x3) .gt. acc ) then
+ c = (1 + x2/x3)/(1 - x2/x3)*(lx2 + log(1/x3)) +
+ & (1 + x2*x3)/(1 - x2*x3)*(lx2 + lx3) + 2
+ else if( abs(x2 - 1) .gt. acc ) then
+ c = -2*(x2**2 + 1)/((x2 - 1)*(x2 + 1))*lx2
+ endif
+ res = fac*(c - lm)
+ else
+ res = fac*(lm*lxs - lx2**2 - lx3**2 +
+ & Li2omx2(xs, 1D0, xs, 1D0) -
+ & Li2omx3(xs, 1D0, x2, 1D0, x3, 1D0) -
+ & Li2omx3(xs, 1D0, 1/x2, -1D0, 1/x3, -1D0) -
+ & Li2omx3(xs, 1D0, x2, 1D0, 1/x3, -1D0) -
+ & Li2omx3(xs, 1D0, 1/x2, -1D0, x3, 1D0))
+ endif
+ end
+
+************************************************************************
+
+ subroutine D0collDR(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ integer z, s
+
+* see D0table.f
+ integer pperm(0:127)
+ data pperm /
+ & -898440548, -898440548, -865381277, -898440548,
+ & -898440548, -1972182372, -865381277, -1972182372,
+ & -898440548, -898440548, -865381277, -1972182372,
+ & -898440548, -1972182372, -865381277, 1249043100,
+ & -898440548, -898440548, -1939123101, -1939123101,
+ & -898440548, -1972182372, -1939123101, 1368319628,
+ & -898440548, -898440548, -1939123101, 1282102371,
+ & -898440548, -1972182372, -1939123101, 175301276,
+ & -898440548, -1921432484, -865381277, -1921432484,
+ & -898440548, -1972182372, -865381277, -1972182372,
+ & -898440548, -1921432484, -865381277, 1299792988,
+ & -898440548, -1921432484, -865381277, 1249043100,
+ & -898440548, -1921432484, -1939123101, -1939123101,
+ & -898440548, -1972182372, -1939123101, 1368319628,
+ & -898440548, -1921432484, -1939123101, 1282102371,
+ & -898440548, -1972182372, -1939123101, 175301276,
+ & -898440548, -898440548, -1904860509, -1904860509,
+ & -898440548, -1972182372, -1904860509, -1972182372,
+ & -898440548, -898440548, -1904860509, 1316364963,
+ & -898440548, -1972182372, -1904860509, 1249043100,
+ & -898440548, -898440548, -1904860509, -1939123101,
+ & -898440548, -1972182372, -1904860509, 1368319628,
+ & -898440548, -898440548, -1904860509, 1282102371,
+ & -898440548, -1972182372, -1904860509, 175301276,
+ & -898440548, -1921432484, -1904860509, 1907239051,
+ & -898440548, -1972182372, -1904860509, 1907239051,
+ & -898440548, -1921432484, -1904860509, 833497227,
+ & -898440548, -1972182372, -1904860509, 833497227,
+ & -898440548, -1921432484, -1904860509, 1907239051,
+ & -898440548, -1972182372, -1904860509, 850499737,
+ & -898440548, -1921432484, -1904860509, 833497227,
+ & -898440548, -1972182372, -1904860509, 175301276 /
+
+ z = 0
+ if( abs(Mx(3)) .lt. eps ) z = 1
+ if( abs(Mx(4)) .lt. eps ) z = z + 2
+ if( abs(Px(2)) .lt. eps ) z = z + 4
+ if( abs(Px(3)) .lt. eps ) z = z + 8
+ if( abs(Px(4)) .lt. eps ) z = z + 16
+ if( abs(Px(5)) .lt. eps ) z = z + 32
+ if( abs(Px(6)) .lt. eps ) z = z + 64
+ s = pperm(z)
+ if( iand(s, O'7777777777') .ne. O'1234561234' ) perm =
+ & pj(perm, pj(s, 1))*8**9 +
+ & pj(perm, pj(s, 2))*8**8 +
+ & pj(perm, pj(s, 3))*8**7 +
+ & pj(perm, pj(s, 4))*8**6 +
+ & pj(perm, pj(s, 5))*8**5 +
+ & pj(perm, pj(s, 6))*8**4 +
+ & mj(perm, mj(s, 1))*8**3 +
+ & mj(perm, mj(s, 2))*8**2 +
+ & mj(perm, mj(s, 3))*8**1 +
+ & mj(perm, mj(s, 4))*8**0
+
+ goto (22,22,22,23, 22,22,22,23, 10,11,12,13)
+ & ibits(s, 30, 2) + ibits(z, 0, 2)*4 - 3
+
+ call D0m2p3(res, xpi, perm)
+ return
+
+23 call D0m1p3(res, xpi, perm)
+ return
+
+22 call D0m1p2(res, xpi, perm)
+ return
+
+13 call D0m0p3(res, xpi, perm)
+ return
+
+12 call D0m0p2(res, xpi, perm)
+ return
+
+11 call D0m0p1(res, xpi, perm)
+ return
+
+10 call D0m0p0(res, xpi, perm)
+ end
+
+************************************************************************
+* qlbox1: D0(0, 0, 0, 0; p1p2, p2p3; 0, 0, 0, 0)
+* Bern, Dixon, Kosower, NPB 412 (1994) 751 [hep-ph/9306240], Eq. (I.11)
+
+ subroutine D0m0p0(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision s, t, fac
+
+ double complex lnrat
+ external lnrat
+
+c PRINT *, "D0m0p0: qlbox1"
+ s = -Px(5)
+ t = -Px(6)
+ fac = 1/(s*t)
+ if( lambda .eq. -2 )then
+ res = 4*fac
+ else if( lambda .eq. -1 ) then
+ res = 2*fac*(-lnrat(t, mudim) - lnrat(s, mudim))
+ else
+ res = fac*(lnrat(t, mudim)**2 + lnrat(s, mudim)**2 -
+ & lnrat(t, s)**2 - pi**2)
+ endif
+ end
+
+************************************************************************
+* qlbox2: D0(0, 0, 0, p4; p1p2, p2p3; 0, 0, 0, 0)
+* One-mass integral as given in
+* Ellis, Giele, Zanderighi, Eq. (A22).
+
+ subroutine D0m0p1(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision s, t, m4, fac
+ double complex l1, l2
+
+ double complex lnrat, Li2omrat
+ external lnrat, Li2omrat
+
+c PRINT *, "D0m0p1: qlbox2"
+ s = -Px(5)
+ t = -Px(6)
+ m4 = -Px(4)
+ fac = 1/(s*t)
+ if( lambda .eq. -2 ) then
+ res = 2*fac
+ else if( lambda .eq. -1 ) then
+ res = 2*fac*(lnrat(m4, mudim) -
+ & lnrat(t, mudim) - lnrat(s, mudim))
+ else
+ l1 = sqrt(lnrat(t, mudim)**2 + lnrat(m4, t)**2 +
+ & lnrat(s, mudim)**2 + lnrat(m4, s)**2)
+ l2 = sqrt(lnrat(m4, mudim)**2 + lnrat(t, s)**2)
+ res = fac*((l1 - l2)*(l1 + l2) +
+ & 2*(Li2omrat(t, m4) + Li2omrat(s, m4) - pi6))
+ endif
+ end
+
+************************************************************************
+
+ subroutine D0m0p2(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision s, t, q2, q3, q4, fac, r
+ double complex ls, lt, lq2, lq3, lq4
+
+ double complex lnrat, lndiv0, lndiv1, Li2omrat, Li2omrat2
+ external lnrat, lndiv0, lndiv1, Li2omrat, Li2omrat2
+
+c PRINT *, "D0m0p2"
+ s = -Px(5)
+ t = -Px(6)
+ fac = 1/(s*t)
+ q4 = -Px(4)
+ q3 = -Px(3)
+
+ if( abs(q3) .lt. eps ) then
+* qlbox3: D0(0, p2, 0, p4; p1p2, p2p3; 0, 0, 0, 0)
+* Bern, Dixon, Kosower, NPB 412 (1994) 751 [hep-ph/9306240], Eq. (I.13)
+c PRINT *, "D0m0p2: qlbox3"
+
+ if( lambda .eq. -2 ) then
+ res = 0
+ return
+ endif
+
+ q2 = -Px(2)
+ r = 1 - q2*q4*fac
+
+* Use expansion only in cases where signs (s,t,m2,m4) are not
+* ++-- or --++
+ if( abs(r) .lt. 1D-6 .and.
+ & (fac .lt. 0 .or. q2*q4 .lt. 0) ) then
+* expanded case
+ if( lambda .eq. -1 ) then
+ res = -(2 + r)*fac
+ else
+ res = fac*(2 - .5D0*r +
+ & (2 + r)*(lnrat(s, mudim) + lnrat(t, q4)) +
+ & 2*(lndiv0(q4, t) + lndiv0(q4, s)) +
+ & r*(lndiv1(q4, t) + lndiv1(q4, s)))
+ endif
+ else
+* general case
+ fac = 1/(s*t - q2*q4)
+ if( lambda .eq. -1 ) then
+ res = 2*fac*(lnrat(q2, s) + lnrat(q4, t))
+ else
+ ls = lnrat(s, mudim)
+ lt = lnrat(t, mudim)
+ lq2 = lnrat(q2, mudim)
+ lq4 = lnrat(q4, mudim)
+ res = fac*(
+ & (ls - lq2)*(ls + lq2) +
+ & (lt - lq4)*(lt + lq4) - lnrat(s, t)**2 +
+ & 2*(Li2omrat2(q2, s, q4, t) -
+ & Li2omrat(q2, s) - Li2omrat(q2, t) -
+ & Li2omrat(q4, s) - Li2omrat(q4, t)) )
+ endif
+ endif
+ return
+ endif
+
+* qlbox4: D0(0, 0, p3, p4; p1p2, p2p3; 0, 0, 0, 0)
+* Bern, Dixon, Kosower, NPB 412 (1994) 751 [hep-ph/9306240], Eq. (I.14)
+c PRINT *, "D0m0p2: qlbox4"
+
+ if( lambda .eq. -2 ) then
+ res = fac
+ else if( lambda .eq. -1 ) then
+ res = -fac*(lnrat(s, q3) + lnrat(t, q4) + lnrat(t, mudim))
+ else
+ ls = lnrat(s, mudim)
+ lt = lnrat(t, mudim)
+ lq3 = lnrat(q3, mudim)
+ lq4 = lnrat(q4, mudim)
+ res = fac*(
+ & .5D0*((ls - lq3)*(ls + lq3) +
+ & (lt - lq4)*(lt + lq4) + lt**2) +
+ & lnrat(s, q3)*lnrat(s, q4) - lnrat(s, t)**2 -
+ & 2*(Li2omrat(q3, t) + Li2omrat(q4, t)) )
+ endif
+ end
+
+************************************************************************
+* qlbox5: D0(0, p2, p3, p4; p1p2, p2p3; 0, 0, 0, 0)
+* Bern, Dixon, Kosower, NPB 412 (1994) 751 [hep-ph/9306240], Eq. (I.15)
+* or from hep-ph/0508308v3 Eq. (A27)
+* (v3 corrects previous versions)
+
+ subroutine D0m0p3(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision s, t, q2, q3, q4, fac, r
+
+ double complex lnrat, lndiv0, lndiv1, Li2omrat, Li2omrat2
+ external lnrat, lndiv0, lndiv1, Li2omrat, Li2omrat2
+
+c PRINT *, "D0m0p3: qlbox5"
+
+ if( lambda .eq. -2 ) then
+ res = 0
+ return
+ endif
+
+ s = -Px(5)
+ t = -Px(6)
+ fac = 1/(s*t)
+ q2 = -Px(2)
+ q3 = -Px(3)
+ q4 = -Px(4)
+
+ r = 1 - q2*q4*fac
+
+* Use expansion only in cases where signs of (s,t,q2,q4) are
+* not ++-- or --++
+ if( abs(r) .lt. 1D-6 .and.
+ & (fac .lt. 0 .or. q2*q4 .lt. 0) ) then
+* expanded case
+ if( lambda .eq. -1 ) then
+ res = -.5D0*(2 + r)*fac
+ else
+ res = lndiv0(q4, t)
+ res = fac*(
+ & .5D0*(2 + r)*(2 + (1 + q4/t)*res -
+ & lnrat(mudim, s) - lnrat(q3, t)) +
+ & r*(lndiv1(q4, t) - res - 1) )
+ endif
+ else
+* general case
+ fac = 1/(s*t - q2*q4)
+ if( lambda .eq. -1 ) then
+ res = fac*(lnrat(q2, t) + lnrat(q4, s))
+ else
+ res = fac*(
+ & (lnrat(q3, t) + lnrat(mudim, t))*lnrat(q2, t) +
+ & (lnrat(q3, s) + lnrat(mudim, s))*lnrat(q4, s) -
+ & .5D0*(lnrat(t, q2)**2 + lnrat(s, q4)**2) -
+ & lnrat(s, t)**2 -
+ & 2*(Li2omrat(q2, s) + Li2omrat(q4, t) -
+ & Li2omrat2(q2, s, q4, t)) )
+ endif
+ endif
+ end
+
+************************************************************************
+
+ subroutine D0m1p2(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision m4, s, t, q3, q4, fac
+ double complex lm, ls, lt, lq
+ integer ir
+
+ double complex lnrat, Li2omrat, Li2omrat2
+ external lnrat, Li2omrat, Li2omrat2
+
+c PRINT *, "D0m1p2"
+ m4 = Mx(4)
+ s = -Px(5)
+ t = m4 - Px(6)
+ fac = 1/(s*t)
+ q3 = m4 - Px(3)
+ q4 = m4 - Px(4)
+
+ ir = 0
+ if( abs(q3) .lt. acc ) ir = 1
+ if( abs(q4) .lt. acc ) then
+ ir = ir + 1
+ q4 = q3
+ endif
+
+ if( lambda .eq. -2 ) then
+ res = .5D0*(2 + ir)*fac
+ return
+ endif
+
+ goto (1, 2) ir
+
+* qlbox8: D0(0, 0, p3, p4; p1p2, p2p3; 0, 0, 0, m4)
+c PRINT *, "D0m1p2: qlbox8"
+ lm = lnrat(s, mudim)
+ if( lambda .eq. -1 ) then
+ res = fac*(lnrat(q3, t) + lnrat(q4, t) - lm)
+ else
+ ls = lnrat(s, m4)
+ res = fac*(-2*(Li2omrat(q3, t) + Li2omrat(q4, t)) -
+ & Li2omrat2(q3, s, q4, m4) - pi6 +
+ & .5D0*(lm - ls)*(lm + ls) + 2*lm*lnrat(t, m4) -
+ & lnrat(q3, mudim)*lnrat(q3, m4) -
+ & lnrat(q4, mudim)*lnrat(q4, m4))
+ endif
+ return
+
+1 continue
+* qlbox7: D0(0, 0, m4, p4; p1p2, p2p3; 0, 0, 0, m4)
+c PRINT *, "D0m1p2: qlbox7"
+ ls = lnrat(s, m4)
+ lt = lnrat(t, m4)
+ lm = lnrat(mudim, m4)
+ lq = lnrat(q4, m4)
+ if( lambda .eq. -1 ) then
+ res = fac*(1.5D0*lm - 2*lt - ls + lq)
+ else
+ res = fac*(2*ls*lt - lq**2 - 5*pi12 +
+ & lm*(.75D0*lm - 2*lt - ls + lq) -
+ & 2*Li2omrat(q4, t))
+ endif
+ return
+
+2 continue
+* qlbox6: D0(0, 0, m4, m4; p1p2, p2p3; 0, 0, 0, m4)
+c PRINT *, "D0m1p2: qlbox6"
+ ls = lnrat(s, m4)
+ lt = lnrat(t, m4)
+ lm = lnrat(mudim, m4)
+ if( lambda .eq. -1 ) then
+ res = fac*(2*(lm - lt) - ls)
+ else
+ res = fac*((lm - ls)*(lm - 2*lt) - .5D0*pi**2)
+ endif
+ end
+
+************************************************************************
+
+ subroutine D0m1p3(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision s, t, m4, q2, q3, q4, m4mu, fac
+
+ double complex lnrat, Li2omrat, Li2omrat2
+ external lnrat, Li2omrat, Li2omrat2
+
+c PRINT *, "D0m1p3"
+
+ if( lambda .eq. -2 ) then
+ res = 0
+ return
+ endif
+
+ q2 = -Px(2)
+ s = -Px(5)
+ m4 = Mx(4)
+ q3 = m4 - Px(3)
+ q4 = m4 - Px(4)
+ t = m4 - Px(6)
+
+ if( abs(t) .lt. acc ) then
+ t = q4
+ q4 = 0
+ s = q2
+ q2 = -Px(5)
+ endif
+
+ m4mu = sqrt(m4*mudim)
+
+* qlbox9: D0(0, p2, p3, m4; p1p2, p2p3; 0, 0, 0, m4)
+ if( abs(q4) .lt. acc ) then
+c PRINT *, "D0m1p3: qlbox9"
+ fac = 1/(s*t)
+ if( lambda .eq. -1 ) then
+ res = -fac*(lnrat(t, m4mu) + lnrat(s, q2))
+ else
+ res = fac*(Li2omrat2(q3, q2, t, m4) + 2*Li2omrat(s, q2) +
+ & lnrat(t, m4mu) + lnrat(s, q2) + pi12)
+ endif
+ return
+ endif
+
+* qlbox10: D0(0, p2, p3, p4; p1p2, p2p3; 0, 0, 0, m4)
+c PRINT *, "D0m1p3: qlbox10"
+ fac = 1/(s*t - q2*q4)
+ res = fac*(lnrat(q2, mudim) + lnrat(q4, mudim) -
+ & lnrat(s, mudim) - lnrat(t, mudim))
+ if( lambda .ne. -1 ) then
+ res = 2*res*lnrat(m4mu, t) +
+ & fac*(Li2omrat2(q3, q2, t, m4) - Li2omrat2(q3, s, q4, m4) +
+ & 2*(Li2omrat2(q2, s, q4, t) +
+ & Li2omrat(q2, s) - Li2omrat(t, q4)))
+ endif
+ end
+
+************************************************************************
+
+ subroutine D0m2p3(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision s, t, m3, m4, q3, q4, p3, fac, m3mu, m4mu
+ double precision p34, c, s3t, s4s
+ double complex ls, lt, lq3, lq4, d
+ double complex x43(4), r3t, r4s, r43p, r43m
+ double complex logs, dilogs
+ integer ir, case
+
+ double complex lnrat, cln, Li2rat, Li2omrat, Li2omrat2
+ external lnrat, cln, Li2rat, Li2omrat, Li2omrat2
+
+c PRINT *, "D0m2p3"
+ m3 = Mx(3)
+ s = m3 - Px(5)
+ q3 = m3 - Px(2)
+ m4 = Mx(4)
+ t = m4 - Px(6)
+ q4 = m4 - Px(4)
+
+ if( abs(s*t) .lt. eps ) then
+ s = q3
+ q3 = m3 - Px(5)
+ t = q4
+ q4 = m4 - Px(6)
+ endif
+
+ fac = 1/(s*t - q3*q4)
+
+ ir = 0
+ if( abs(q3) .lt. acc ) ir = 1
+ if( abs(q4) .lt. acc ) then
+ ir = ir + 1
+ q4 = q3
+ s = t
+ t = m3 - Px(5)
+ m4 = m3
+ m3 = Mx(4)
+ endif
+
+ if( lambda .eq. -2 ) then
+ res = .5D0*fac*ir
+ return
+ endif
+
+ if( lambda .eq. -1 ) goto (10, 11, 12) ir + 1
+
+ p3 = Px(3)
+ if( abs(p3) .lt. eps ) then
+ case = 1
+ logs = lnrat(m3, m4)**2
+ else
+ p34 = p3 + m3 - m4
+ c = -4*p3*m3
+ d = sqrt(DCMPLX(p34**2 + c))
+
+ x43(1) = -p34 - d
+ x43(2) = p34 - d
+ if( abs(x43(1)) .lt. abs(x43(2)) ) then
+ x43(1) = c/x43(2)
+ else
+ x43(2) = c/x43(1)
+ endif
+
+ p34 = -p3 + m3 - m4
+ c = -4*p3*m4
+
+ x43(3) = -p34 - d
+ x43(4) = p34 - d
+ if( abs(x43(3)) .lt. abs(x43(4)) ) then
+ x43(3) = c/x43(4)
+ else
+ x43(4) = c/x43(3)
+ endif
+
+ if( abs(DIMAG(d)) .lt. eps ) then
+ case = 2
+ logs = lnrat(x43(1), x43(3))**2 +
+ & lnrat(x43(2), x43(4))**2
+ else
+ case = 3
+ r43p = x43(1)/x43(3)
+ r43m = x43(2)/x43(4)
+ logs = cln(r43p, 0D0)**2 + cln(r43m, 0D0)**2
+ endif
+ endif
+
+ goto (1, 2) ir
+
+* qlbox13: D0(0, p2, p3, p4; p1p2, p2p3; 0, 0, m3, m4)
+c PRINT *, "D0m2p3: qlbox13"
+
+ ls = lnrat(s, mudim)
+ lt = lnrat(t, mudim)
+ lq3 = lnrat(q3, mudim)
+ lq4 = lnrat(q4, mudim)
+
+ if( case .eq. 1 ) then
+ dilogs = Li2omrat2(q3, t, -1D0, -1D0) +
+ & Li2omrat2(q3, t, m4, m3) +
+ & Li2omrat2(q4, s, m3, m4) +
+ & Li2omrat2(q4, s, -1D0, -1D0)
+ else if( case .eq. 2 ) then
+ dilogs = Li2omrat2(q3, t, x43(4), x43(2)) +
+ & Li2omrat2(q3, t, x43(3), x43(1)) +
+ & Li2omrat2(q4, s, x43(1), x43(3)) +
+ & Li2omrat2(q4, s, x43(2), x43(4))
+ else
+ r3t = q3/t
+ s3t = sign(.5D0, q3) - sign(.5D0, t)
+ r4s = q4/s
+ s4s = sign(.5D0, q4) - sign(.5D0, s)
+ dilogs = Li2rat(r3t,s3t, 1/r43m,0D0) +
+ & Li2rat(r3t,s3t, 1/r43p,0D0) +
+ & Li2rat(r4s,s4s, r43p,0D0) +
+ & Li2rat(r4s,s4s, r43m,0D0)
+ endif
+
+ res = -fac*(dilogs + .5D0*logs + lq3**2 + lq4**2 +
+ & 2*(Li2omrat(q3, s) + Li2omrat(q4, t) -
+ & Li2omrat2(q3, s, q4, t) - ls*lt) +
+ & (lt - lq3)*log(m3/mudim) + (ls - lq4)*log(m4/mudim))
+ return
+
+10 res = fac*(lnrat(q3, mudim) + lnrat(q4, mudim) -
+ & lnrat(s, mudim) - lnrat(t, mudim))
+ return
+
+1 continue
+* qlbox12: D0(0, m3, p3, p4; p1p2, p2p3; 0, 0, m3, m4)
+c PRINT *, "D0m2p3: qlbox12"
+
+ m3mu = sqrt(m3*mudim)
+ ls = lnrat(s, m3mu)
+ lt = lnrat(t, m3mu)
+ lq4 = lnrat(q4, m3mu)
+
+ if( case .eq. 1 ) then
+ dilogs = 0
+ else if( case .eq. 2 ) then
+ dilogs = Li2omrat2(q4, s, x43(1), x43(3)) +
+ & Li2omrat2(q4, s, x43(2), x43(4))
+ else
+ r4s = q4/s
+ s4s = sign(.5D0, q4) - sign(.5D0, s)
+ dilogs = Li2rat(r4s,s4s, r43p,0D0) +
+ & Li2rat(r4s,s4s, r43m,0D0)
+ endif
+
+ res = -fac*(dilogs + .5D0*logs + pi12 +
+ & 2*(Li2omrat(q4, t) - ls*lt) +
+ & lq4**2 + (ls - lq4)*log(m4/m3))
+ return
+
+11 m3mu = sqrt(m3*mudim)
+ res = fac*(lnrat(q4, m3mu) - lnrat(s, m3mu) - lnrat(t, m3mu))
+ return
+
+2 continue
+* qlbox11: D0(0, m3, p3, m4; p1p2, p2p3; 0, 0, m3, m4)
+c PRINT *, "D0m2p3: qlbox11"
+
+ m3mu = sqrt(m3*mudim)
+ m4mu = sqrt(m4*mudim)
+ ls = lnrat(s, m3mu)
+ lt = lnrat(t, m4mu)
+
+ res = fac*(.25D0*log(m3/m4)**2 - .5D0*(logs + pi**2) +
+ & 2*lnrat(s, sqrt(m3*mudim))*lnrat(t, sqrt(m4*mudim)))
+ return
+
+12 res = -fac*(lnrat(s, sqrt(m3*mudim)) +
+ & lnrat(t, sqrt(m4*mudim)))
+ end
+
+************************************************************************
* this routine is adapted from Ansgar Denner's bcanew.f
* to the conventions of LoopTools;
* it is used for double-checking the results of FF
* M. Rauch: implemented the log branch cuts for k13 < 2
* (from Denner, Nierste, Scharf; Nucl Phys B367 (1991) 637)
#define AddEps(k) k*DCMPLX(1D0, -sign(eps, k))
#define k2r(k) (.5D0*k*(1 + sqrt(DCMPLX((1 - 2/k)*(1 + 2/k)))))
- double complex function D0b(p1, p2, p3, p4, p1p2, p2p3,
- & m1, m2, m3, m4)
+ subroutine D0m4(res, xpi)
implicit none
- double precision p1, p2, p3, p4, p1p2, p2p3
- double precision m1, m2, m3, m4
+ double complex res
+ double precision xpi(13)
#include "lt.h"
- double complex D0ir, D0m0, D0reg
- external D0ir, D0m0, D0reg
-
-* check IR cases first
- if( m1 .eq. 0 ) then
- if( abs(p1 - m2) + abs(p4 - m4) .lt. acc ) then
- D0b = D0ir(p1, p2, p3, p4, p1p2, p2p3, m3)
- return
- endif
- if( abs(p1 - m2) + abs(p1p2 - m3) .lt. acc ) then
- D0b = D0ir(p1, p2p3, p3, p1p2, p4, p2, m4)
- return
- endif
- if( abs(p4 - m4) + abs(p1p2 - m3) .lt. acc ) then
- D0b = D0ir(p1p2, p2, p2p3, p4, p1, p3, m2)
- return
- endif
- endif
-
- if( m2 .eq. 0 ) then
- if( abs(p1 - m1) + abs(p2 - m3) .lt. acc ) then
- D0b = D0ir(p1, p4, p3, p2, p2p3, p1p2, m4)
- return
- endif
- if( abs(p1 - m1) + abs(p2p3 - m4) .lt. acc ) then
- D0b = D0ir(p1, p1p2, p3, p2p3, p2, p4, m3)
- return
- endif
- if( abs(p2 - m3) + abs(p2p3 - m4) .lt. acc ) then
- D0b = D0ir(p2, p1p2, p4, p2p3, p1, p3, m1)
- return
- endif
- endif
-
- if( m3 .eq. 0 ) then
- if( abs(p2 - m2) + abs(p3 - m4) .lt. acc ) then
- D0b = D0ir(p2, p1, p4, p3, p1p2, p2p3, m1)
- return
- endif
- if( abs(p2 - m2) + abs(p1p2 - m1) .lt. acc ) then
- D0b = D0ir(p2, p2p3, p4, p1p2, p3, p1, m4)
- return
- endif
- if( abs(p3 - m4) + abs(p1p2 - m1) .lt. acc ) then
- D0b = D0ir(p1p2, p1, p2p3, p3, p2, p4, m2)
- return
- endif
- endif
-
- if( m4 .eq. 0 ) then
- if( abs(p4 - m1) + abs(p3 - m3) .lt. acc ) then
- D0b = D0ir(p3, p2, p1, p4, p2p3, p1p2, m2)
- return
- endif
- if( abs(p4 - m1) + abs(p2p3 - m2) .lt. acc ) then
- D0b = D0ir(p2p3, p2, p1p2, p4, p3, p1, m3)
- return
- endif
- if( abs(p3 - m3) + abs(p2p3 - m2) .lt. acc ) then
- D0b = D0ir(p3, p1p2, p1, p2p3, p4, p2, m1)
- return
- endif
- endif
-
- if( m1 .eq. 0 ) then
- D0b = D0m0(p3, p4, p1, p2, p1p2, p2p3, m3, m4, m2)
- else if( m2 .eq. 0 ) then
- D0b = D0m0(p4, p1, p2, p3, p2p3, p1p2, m4, m1, m3)
- else if( m3 .eq. 0 ) then
- D0b = D0m0(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m4)
- else if( m4 .eq. 0 ) then
- D0b = D0m0(p2, p3, p4, p1, p2p3, p1p2, m2, m3, m1)
- else
- D0b = D0reg(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)
- endif
- end
-
-************************************************************************
-
- double complex function D0ir(p1, p2, p3, p4, p1p2, p2p3, m3)
- implicit none
- double precision p1, p2, p3, p4, p1p2, p2p3, m3
-
-#include "lt.h"
-
- double precision m1_, m3_, m4_, d
- double complex xs, x2, x3, y, c, f
- double complex logxs, logx2, logx3, log1x2, log1x3, logy
-
- double complex ln, spence, bdK
- external ln, spence, bdK
-
- m1_ = sqrt(p1)
- m4_ = sqrt(p4)
- f = .5D0/(m1_*m4_*(p1p2 - m3))
- d = p2p3 - (m1_ - m4_)**2
- if( d .ne. 0 ) then
- xs = bdK(p2p3, m1_, m4_)
- logxs = log(xs)
- f = f*2*xs/((1 - xs)*(1 + xs))
- endif
-
-* massless case
- if( m3 .eq. 0 ) then
- if( p1 .eq. p2 .and. p3 .eq. p4 ) then
- D0ir = 2*f*ln(-lambda/p1p2, 1D0)
- if( d .ne. 0 ) D0ir = -logxs*D0ir
- return
- endif
- y = m1_/m4_*(p3 - p4 + cI*eps)/
- & (p2 - p1 + cI*eps)
- logy = log(y)
- c = ln(lambda/m1_/m4_, 0D0) +
- & ln((p2 - p1)/p1p2, p1 - p2) + ln((p3 - p4)/p1p2, p4 - p3)
- if( d .ne. 0 ) then
- D0ir = f*(pi6 - .5D0*(logxs - logy)*(logxs + logy) -
- & spence(xs/y, 0D0) - (logxs + log(1/y))*log(1 - xs/y) -
- & spence(xs*y, 0D0) - (logxs + logy)*log(1 - xs*y) +
- & spence(xs**2, 0D0) +
- & logxs*(2*log((1 - xs)*(1 + xs)) - c))
- return
- endif
- D0ir = f*(c - 2 - (1 + y)/(1 - y)*logy)
- return
- endif
-
-* massive case
- m3_ = sqrt(m3)
- x2 = bdK(p2, m1_, m3_)
- x3 = bdK(p3, m4_, m3_)
- logx2 = log(x2)
- logx3 = log(x3)
- log1x3 = log(1/x3)
- c = ln(m3_*sqrt(lambda)/(m3 - p1p2), 1D0)
- if( d .ne. 0 ) then
- log1x2 = log(1/x2)
- D0ir = f*(.5D0*pi**2 +
- & 2*log(xs)*(log((1 - xs)*(1 + xs)) - c) +
- & spence(xs**2, 0D0) + logx2**2 + logx3**2 -
- & spence(xs/x2/x3, 0D0) -
- & (logxs + log1x2 + log1x3)*log(1 - xs/x2/x3) -
- & spence(xs*x2/x3, 0D0) -
- & (logxs + logx2 + log1x3)*log(1 - xs*x2/x3) -
- & spence(xs/x2*x3, 0D0) -
- & (logxs + log1x2 + logx3)*log(1 - xs/x2*x3) -
- & spence(xs*x2*x3, 0D0) -
- & (logxs + logx2 + logx3)*log(1 - xs*x2*x3))
- return
- endif
- D0ir = f*(2*c -
- & (1 + x2/x3)/(1 - x2/x3)*(logx2 + log1x3) -
- & (1 + x2*x3)/(1 - x2*x3)*(logx2 + logx3) - 2)
- end
-
-************************************************************************
-
- double complex function D0m0(p1, p2, p3, p4, p1p2, p2p3,
- & m1, m2, m4)
- implicit none
- double precision p1, p2, p3, p4, p1p2, p2p3
- double precision m1, m2, m4
-
-#include "lt.h"
-
- double complex D0m00, cspence, cln
- integer eta_tilde
- external D0m00, cspence, eta_tilde, cln
-
- double precision m1_, m2_, m4_
- double precision k12, k13, k14, k23, k24, k34
- double precision ir12, ir14, ir24, ix1(2), ix4(2)
- double complex r12, r14, r24, x4(2), x1
- double complex a, b, c, d, disc
- integer i
-
- if( m1 .eq. 0 ) then
- D0m0 = D0m00(p1, p1p2, p3, p2p3, p2, p4, m2, m4)
- return
- endif
- if( m2 .eq. 0 ) then
- D0m0 = D0m00(p1, p2, p3, p4, p1p2, p2p3, m1, m4)
- return
- endif
- if( m4 .eq. 0 ) then
- D0m0 = D0m00(p4, p3, p2, p1, p1p2, p2p3, m1, m2)
- return
- endif
-
- m1_ = sqrt(m1)
- m2_ = sqrt(m2)
- m4_ = sqrt(m4)
-
- k12 = (m1 + m2 - p1)/(m1_*m2_)
- k13 = (m1 - p1p2)/m1
- k14 = (m1 + m4 - p4)/(m1_*m4_)
- k23 = (m2 - p2)/(m2_*m1_)
- k24 = (m2 + m4 - p2p3)/(m2_*m4_)
- k34 = (m4 - p3)/(m1_*m4_)
-
- r12 = k2r(k12)
- r14 = k2r(k14)
- r24 = k2r(k24)
-
- a = k34/r24 - k23
- b = k13*(1/r24 - r24) + k12*k34 - k14*k23
- c = k13*(k12 - r24*k14) + r24*k34 - k23
- d = -k34*r24 + k23
- disc = sqrt(DCMPLX((k12*k34 - k13*k24 - k14*k23)**2 -
- & 4*(k13*(k13 - k23*(k12 - k14*k24)) +
- & k23*(k23 - k24*k34) + k34*(k34 - k13*k14))))
- x4(1) = .5D0/a*(-b + disc)
- x4(2) = .5D0/a*(-b - disc)
- if( abs(x4(1)) .gt. abs(x4(2)) ) then
- x4(2) = c/(a*x4(1))
- else
- x4(1) = c/(a*x4(2))
- endif
-
- if( k12 .lt. -2 ) then
- ir12 = sign(10D0, 1 - abs(r12))
- else
- ir12 = 0
- endif
- if( k14 .lt. -2 ) then
- ir14 = sign(10D0, 1 - abs(r14))
- else
- ir14 = 0
- endif
- if( k24 .lt. -2 ) then
- ir24 = sign(10D0, 1 - abs(r24))
- else
- ir24 = 0
- endif
-
- ix4(2) = sign(1D0, DBLE(d))
- ix4(1) = -ix4(2)
- ix1(1) = sign(1D0, ix4(1)*DBLE(r24))
- ix1(2) = -ix1(1)
-
- b = DCMPLX(k34/k13)
- c = DCMPLX(k23/k13)
-
- D0m0 = 0
- do i = 1, 2
- x1 = -x4(i)/r24
- D0m0 = D0m0 + Sgn(i)*(
- & cspence(-x4(i), r14, -ix4(i), ir14) +
- & cspence(-x4(i), 1/r14, -ix4(i), -ir14) -
- & cspence(x1, r12, -ix1(i), ir12) -
- & cspence(x1, 1/r12, -ix1(i), -ir12) -
- & cspence(-x4(i), b, -ix4(i), -k13) +
- & cspence(x1, c, -ix1(i), -k13) -
- & eta_tilde(-x4(i), 1/r24, -ix4(i), -ir24)*c2ipi*(
- & cln((k12 - r24*(k14 + x4(i)) - x1)/d,
- & DBLE(-(r24 - 1/r24)*ix4(i)/d)) +
- & cln(DCMPLX(k13), -1D0) ) )
- enddo
- D0m0 = D0m0/(m1*m2_*m4_*a*(x4(1) - x4(2)))
- end
-
-************************************************************************
-
- double complex function D0m00(p1, p2, p3, p4, p1p2, p2p3,
- & m1, m4)
- implicit none
- double precision p1, p2, p3, p4, p1p2, p2p3
- double precision m1, m4
-
-#include "lt.h"
-
- double complex D0m000, cspence
- external D0m000, cspence
-
- double precision m1_, m4_
- double precision k12, k13, k14, k23, k24, k34
- double complex k12c, k13c, k23c, k24c, k34c
- double complex r14, x4(2)
- double complex a, b, c, disc
- integer i
-
- if( m1 .eq. 0 ) then
- D0m00 = D0m000(p4, p1, p2, p3, p2p3, p1p2, m4)
- return
- endif
- if( m4 .eq. 0 ) then
- D0m00 = D0m000(p1, p2, p3, p4, p1p2, p2p3, m1)
- return
- endif
-
- m1_ = sqrt(m1)
- m4_ = sqrt(m4)
-
- k12 = (m1 - p1)/m1
- k13 = (m1 - p1p2)/m1
- k14 = (m1 + m4 - p4)/(m1_*m4_)
- k23 = -p2/m1
- k24 = (m4 - p2p3)/(m1_*m4_)
- k34 = (m4 - p3)/(m1_*m4_)
-
- a = k34*k24 - k23
- b = k13*k24 + k12*k34 - k14*k23
- c = k13*k12 - k23*(1 - cI*eps)
- disc = sqrt(b**2 - 4*a*c)
- x4(1) = .5D0/a*(-b + disc)
- x4(2) = .5D0/a*(-b - disc)
- if( abs(x4(1)) .gt. abs(x4(2)) ) then
- x4(2) = c/(a*x4(1))
- else
- x4(1) = c/(a*x4(2))
- endif
-
- k12c = AddEps(k12)
- k13c = AddEps(k13)
- k23c = AddEps(k23)
-
- k24c = AddEps(k24)/k12c
- k34c = AddEps(k34)/k13c
- c = log(k12c) + log(k13c) - log(k23c)
-
- r14 = k2r(k14)
- r14 = r14*DCMPLX(1D0, sign(eps, DBLE(1/r14 - r14)))
-
- D0m00 = 0
- do i = 1, 2
- D0m00 = D0m00 + Sgn(i)*(
- & cspence(-x4(i), r14, 0D0, 0D0) +
- & cspence(-x4(i), 1/r14, 0D0, 0D0) -
- & cspence(-x4(i), k34c, 0D0, 0D0) -
- & cspence(-x4(i), k24c, 0D0, 0D0) +
- & log(-x4(i))*c )
- enddo
- D0m00 = D0m00/(m1*m1_*m4_*a*(x4(1) - x4(2)))
- end
-
-************************************************************************
-
- double complex function D0m000(p1, p2, p3, p4, p1p2, p2p3, m1)
- implicit none
- double precision p1, p2, p3, p4, p1p2, p2p3
- double precision m1
-
-#include "lt.h"
-
- double complex D0m0000, cspence
- external D0m0000, cspence
-
- double precision k12, k13, k14, k23, k24, k34
- double complex k12c, k13c, k14c, k23c, k24c, k34c
- double precision a, b
- double complex c, disc, x4(2)
- integer i
-
- if( m1 .eq. 0 ) then
- D0m000 = D0m0000(p1, p2, p3, p4, p1p2, p2p3)
- return
- endif
-
- k12 = (m1 - p1)/m1
- k13 = (m1 - p1p2)/m1
- k14 = (m1 - p4)/m1
- k23 = -p2/m1
- k24 = -p2p3/m1
- k34 = -p3/m1
-
- a = k34*k24
- b = k13*k24 + k12*k34 - k14*k23
- c = k13*k12 - k23*(1 - cI*eps)
- disc = sqrt(b*b - 4*a*c)
- x4(1) = .5D0/a*(-b + disc)
- x4(2) = .5D0/a*(-b - disc)
- if( abs(x4(1)) .gt. abs(x4(2)) ) then
- x4(2) = c/(a*x4(1))
- else
- x4(1) = c/(a*x4(2))
- endif
-
- k12c = AddEps(k12)
- k13c = AddEps(k13)
- k23c = AddEps(k23)
- k14c = AddEps(k14)
-
- k24c = AddEps(k24)/k12c
- k34c = AddEps(k34)/k13c
- c = log(k12c) + log(k13c) - log(k23c)
-
- D0m000 = 0
- do i = 1, 2
- D0m000 = D0m000 + Sgn(i)*(
- & cspence(-x4(i), k14c, 0D0, 0D0) -
- & cspence(-x4(i), k34c, 0D0, 0D0) -
- & cspence(-x4(i), k24c, 0D0, 0D0) +
- & log(-x4(i))*c )
- enddo
- D0m000 = D0m000/(m1**2*a*(x4(1) - x4(2)))
- end
-
-************************************************************************
-
- double complex function D0m0000(p1, p2, p3, p4, p1p2, p2p3)
- implicit none
- double precision p1, p2, p3, p4, p1p2, p2p3
-
-#include "lt.h"
-
- double complex cspence
- external cspence
-
- double precision m2
- double precision k12, k13, k14, k23, k24, k34
- double complex k12c, k13c, k14c, k23c, k24c, k34c
- double precision a, b
- double complex c, disc, x4(2)
- integer i
-
- m2 = abs(p2p3)
- k12 = -p1/m2
- k13 = -p1p2/m2
- k14 = -p4/m2
- k23 = -p2/m2
- k24 = -p2p3/m2
- k34 = -p3/m2
-
- a = k34*k24
- b = k13*k24 + k12*k34 - k14*k23
- c = k13*k12 + cI*eps*k23
- disc = sqrt(b*b - 4*a*c)
- x4(1) = .5D0/a*(-b + disc)
- x4(2) = .5D0/a*(-b - disc)
- if( abs(x4(1)) .gt. abs(x4(2)) ) then
- x4(2) = c/(a*x4(1))
- else
- x4(1) = c/(a*x4(2))
- endif
-
- k12c = AddEps(k12)
- k13c = AddEps(k13)
- k23c = AddEps(k23)
- k14c = AddEps(k14)
-
- k24c = AddEps(k24)/k12c
- k34c = AddEps(k34)/k13c
- c = log(k12c) + log(k13c) - log(k23c) - log(k14c)
-
- D0m0000 = 0
- do i = 1, 2
- disc = log(-x4(i))
- D0m0000 = D0m0000 + Sgn(i)*(
- & -cspence(-x4(i), k34c, 0D0, 0D0) -
- & cspence(-x4(i), k24c, 0D0, 0D0) +
- & disc*(c - .5D0*disc) )
- enddo
- D0m0000 = D0m0000/(m2**2*a*(x4(1) - x4(2)))
- end
-
-************************************************************************
-
- double complex function D0reg(p1, p2, p3, p4, p1p2, p2p3,
- & m1, m2, m3, m4)
- implicit none
- double precision p1, p2, p3, p4, p1p2, p2p3
- double precision m1, m2, m3, m4
-
-#include "lt.h"
-
- double complex cspence, cln
- integer eta, eta_tilde
- external cspence, cln, eta, eta_tilde
-
- double precision m1_, m2_, m3_, m4_
- double precision tmp, ir1324, gamma
+ double precision tmp, ir1324, gamma, s1, s2
double precision kij(6), irij(6), ix(2,4)
- double complex rij(6), x(2,4)
- double complex a, b, c, d, disc, ki
- integer j, k
+ double complex rij(6), x(2,4), l(2,4), q13, q24
+ double complex a, b, c, d, disc, ki, etas
+ integer j
double precision k12, k13, k14, k23, k24, k34
double precision ir12, ir13, ir14, ir23, ir24, ir34
double complex r12, r14, r13, r23, r24, r34
equivalence (kij(1), k12), (rij(1), r12), (irij(1), ir12)
equivalence (kij(2), k23), (rij(2), r23), (irij(2), ir23)
equivalence (kij(3), k34), (rij(3), r34), (irij(3), ir34)
equivalence (kij(4), k14), (rij(4), r14), (irij(4), ir14)
equivalence (kij(5), k13), (rij(5), r13), (irij(5), ir13)
equivalence (kij(6), k24), (rij(6), r24), (irij(6), ir24)
- m1_ = sqrt(m1)
- m2_ = sqrt(m2)
- m3_ = sqrt(m3)
- m4_ = sqrt(m4)
+ double complex cln, xspence, xeta, xetatilde
+ integer eta
+ external cln, xspence, xeta, xetatilde, eta
- k12 = (m1 + m2 - p1)/m1_/m2_
- k23 = (m2 + m3 - p2)/m2_/m3_
- k34 = (m3 + m4 - p3)/m3_/m4_
- k14 = (m1 + m4 - p4)/m1_/m4_
- k13 = (m1 + m3 - p1p2)/m1_/m3_
- k24 = (m2 + m4 - p2p3)/m2_/m4_
+ k12 = (M(1) + M(2) - P(1))/sqrt(M(1)*M(2))
+ k23 = (M(2) + M(3) - P(2))/sqrt(M(2)*M(3))
+ k34 = (M(3) + M(4) - P(3))/sqrt(M(3)*M(4))
+ k14 = (M(1) + M(4) - P(4))/sqrt(M(1)*M(4))
+ k13 = (M(1) + M(3) - P(5))/sqrt(M(1)*M(3))
+ k24 = (M(2) + M(4) - P(6))/sqrt(M(2)*M(4))
* test if r_13 can be made real by a permutation
* if one of the r_ij is real r_13 must be made real => case 1
if( abs(k13) .ge. 2 ) then
* nothing to do
* otherwise try all permutations
else if( abs(k12) .ge. 2 ) then
* 2 <-> 3
tmp = k12
k12 = k13
k13 = tmp
tmp = k24
k24 = k34
k34 = tmp
else if( abs(k14) .ge. 2 ) then
* 3 <-> 4
tmp = k13
k13 = k14
k14 = tmp
tmp = k23
k23 = k24
k24 = tmp
else if( abs(k23) .ge. 2 ) then
* 1 <-> 2
tmp = k13
k13 = k23
k23 = tmp
tmp = k14
k14 = k24
k24 = tmp
else if( abs(k24) .ge. 2 ) then
* 1 -> 4, 2 -> 1, 3 -> 2, 4 -> 3
tmp = k12
k12 = k23
k23 = k34
k34 = k14
k14 = tmp
tmp = k13
k13 = k24
k24 = tmp
else if( abs(k34) .ge. 2 ) then
* 1 <-> 4
tmp = k12
k12 = k24
k24 = tmp
tmp = k13
k13 = k34
k34 = tmp
* else
* nothing found => all r_ij on the complex unit circle => case 2
endif
r12 = k2r(k12)
r23 = k2r(k23)
r34 = k2r(k34)
r14 = k2r(k14)
r13 = 1/k2r(k13)
r24 = 1/k2r(k24)
do j = 1, 6
if( DIMAG(rij(j)) .eq. 0 ) then
ki = kij(j) - cI*eps
irij(j) = sign(1D0, abs(rij(j)) - 1)*
& DIMAG(k2r(ki))
else
irij(j) = 0
endif
enddo
ir1324 = sign(1D0, DBLE(r24))*ir13 -
& sign(1D0, DBLE(r13))*ir24
a = k34/r24 - k23 + (k12 - k14/r24)*r13
b = (1/r13 - r13)*(1/r24 - r24) + k12*k34 - k14*k23
c = k34*r24 - k23 + (k12 - k14*r24)/r13
d = k23 + (r24*k14 - k12)*r13 - r24*k34
disc = sqrt(b**2 - 4*a*(c + cI*eps*d))
- ix(1,4) = DIMAG(.5D0/a*(-b + disc))
- ix(2,4) = DIMAG(.5D0/a*(-b - disc))
+ ix(1,4) = DIMAG(.5D0/a*(b - disc))
+ ix(2,4) = DIMAG(.5D0/a*(b + disc))
disc = sqrt(b**2 - 4*a*c)
- x(1,4) = .5D0/a*(-b + disc)
- x(2,4) = .5D0/a*(-b - disc)
+ x(1,4) = .5D0/a*(b - disc)
+ x(2,4) = .5D0/a*(b + disc)
if( abs(x(1,4)) .gt. abs(x(2,4)) ) then
- x(2,4) = c/a/x(1,4)
+ x(2,4) = c/(a*x(1,4))
else
- x(1,4) = c/a/x(2,4)
+ x(1,4) = c/(a*x(2,4))
endif
x(1,1) = x(1,4)/r24
x(2,1) = x(2,4)/r24
- x(1,2) = x(1,4)/r24*r13
- x(2,2) = x(2,4)/r24*r13
+ x(1,2) = x(1,4)*r13/r24
+ x(2,2) = x(2,4)*r13/r24
x(1,3) = x(1,4)*r13
x(2,3) = x(2,4)*r13
- ix(1,1) = ix(1,4)*DBLE(x(1,1))*sign(1D0, DBLE(x(1,4)))
- ix(2,1) = ix(2,4)*DBLE(x(2,1))*sign(1D0, DBLE(x(2,4)))
- ix(1,2) = ix(1,4)*DBLE(x(1,2))*sign(1D0, DBLE(x(1,4)))
- ix(2,2) = ix(2,4)*DBLE(x(2,2))*sign(1D0, DBLE(x(2,4)))
- ix(1,3) = ix(1,4)*DBLE(x(1,3))*sign(1D0, DBLE(x(1,4)))
- ix(2,3) = ix(2,4)*DBLE(x(2,3))*sign(1D0, DBLE(x(2,4)))
+ s1 = sign(1D0, DBLE(x(1,4)))
+ s2 = sign(1D0, DBLE(x(2,4)))
+ ix(1,1) = ix(1,4)*DBLE(x(1,1))*s1
+ ix(2,1) = ix(2,4)*DBLE(x(2,1))*s2
+ ix(1,2) = ix(1,4)*DBLE(x(1,2))*s1
+ ix(2,2) = ix(2,4)*DBLE(x(2,2))*s2
+ ix(1,3) = ix(1,4)*DBLE(x(1,3))*s1
+ ix(2,3) = ix(2,4)*DBLE(x(2,3))*s2
- D0reg = 0
- do k = 1, 2
- do j = 1, 4
- D0reg = D0reg + Sgn(j + k)*(
- & cspence(-x(k,j), rij(j), -ix(k,j), irij(j)) +
- & cspence(-x(k,j), 1/rij(j), -ix(k,j), -irij(j)) )
+ res = 0
+ do j = 1, 4
+ res = res + Sgn(j)*(
+ & xspence(x(1,j), ix(1,j), rij(j), irij(j)) +
+ & xspence(x(1,j), ix(1,j), 1/rij(j), -irij(j)) )
+ enddo
+
+ gamma = sign(1D0, DBLE(a*(x(2,4) - x(1,4))))
+ l(1,4) = c2ipi*eta(r13, ir13, 1/r24, -ir24, ir1324)
+ l(2,4) = l(1,4)
+
+ if( DIMAG(r13) .eq. 0 ) then
+ r12 = k12 - r24*k14
+ r23 = k23 - r24*k34
+ r34 = k34 - r13*k14
+ r14 = k23 - r13*k12
+ q13 = k13 - 2*r13
+ q24 = k24 - 2*r24
+
+ c = gamma*sign(1D0, DIMAG(r24) + ir24)
+ l(1,1) = cln(-x(1,1), -ix(1,1)) +
+ & cln(r14 - q13/x(1,1), -1D0) +
+ & cln((r12 - q24*x(1,4))/d, c)
+ l(2,1) = cln(-x(2,1), -ix(2,1)) +
+ & cln(r14 - q13/x(2,1), -1D0) +
+ & cln((r12 - q24*x(2,4))/d, -c)
+
+ c = gamma*sign(1D0, DBLE(r13)*(DIMAG(r24) + ir24))
+ l(1,2) = cln(-x(1,2), -ix(1,2)) +
+ & cln(r14 - q13/x(1,1), -1D0) +
+ & cln((r23 - q24*x(1,3))/d, c)
+ l(2,2) = cln(-x(2,2), -ix(2,2)) +
+ & cln(r14 - q13/x(2,1), -1D0) +
+ & cln((r23 - q24*x(2,3))/d, -c)
+
+ l(1,3) = cln(-x(1,3), -ix(1,3)) +
+ & cln(r34 - q13/x(1,4), -1D0) +
+ & cln((r23 - q24*x(1,3))/d, c)
+ l(2,3) = cln(-x(2,3), -ix(2,3)) +
+ & cln(r34 - q13/x(2,4), -1D0) +
+ & cln((r23 - q24*x(2,3))/d, -c)
+
+ etas =
+ & xetatilde(x(1,4), ix(1,4), r13, ir13, l(1,3)) +
+ & xetatilde(x(1,4), ix(1,4), 1/r24, -ir24, l(1,1)) -
+ & xetatilde(x(1,4), ix(1,4), r13/r24, ir1324, l(1,2)) +
+ & xetatilde(x(1,4), ix(1,4), -r13/r24, -ir1324, l(1,4))
+ else
+ do j = 1, 3
+ l(1,j) = log(-x(1,j)) +
+ & cln(kij(j) - 1/x(1,j) - x(1,j), -x(1,j)*b*gamma)
+ l(2,j) = log(-x(2,j)) +
+ & cln(kij(j) - 1/x(2,j) - x(2,j), -x(2,j)*b*gamma)
enddo
- gamma = sign(1D0, DBLE(a*(x(k,4) - x(3-k,4))))
- if( DIMAG(r13) .eq. 0 ) then
- D0reg = D0reg - Sgn(k)*c2ipi*(
- & eta_tilde(-x(k,4), r13, -ix(k,4), ir13)*(
- & cln(x(k,3), ix(k,3)) +
- & cln((k13 - 2*r13)/x(k,4) - r13*k14 + k34, -1D0) +
- & cln(((k24 - 2*r24)*x(k,3) - r24*k34 + k23)/d,
- & gamma*sign(1D0, DBLE(r13)*(DIMAG(r24) + ir24)))
- & ) +
- & eta_tilde(-x(k,4), 1/r24, -ix(k,4), -ir24)*(
- & cln(x(k,1), ix(k,1)) +
- & cln((k13 - 2*r13)/x(k,1) - r13*k12 + k23, -1D0) +
- & cln(((k24 - 2*r24)*x(k,4) - r24*k14 + k12)/d,
- & gamma*sign(1D0, DIMAG(r24) + ir24))
- & ) -
- & (eta_tilde(-x(k,4), r13/r24, -ix(k,4), ir1324) +
- & eta(r13, 1/r24, ir13, -ir24, ir1324))*(
- & cln(x(k,2), ix(k,2)) +
- & cln((k13 - 2*r13)/x(k,1) - r13*k12 + k23, -1D0) +
- & cln(((k24 - 2*r24)*x(k,3) - r24*k34 + k23)/d,
- & gamma*sign(1D0, DBLE(r13)*(DIMAG(r24) + ir24)))
- & ) +
- & eta_tilde(-x(k,4), -r13/r24, -ix(k,4), -ir1324)*
- & eta(r13, 1D0/r24, ir13, -ir24, ir1324)*c2ipi
- & )
- else
- D0reg = D0reg - Sgn(k)*c2ipi*(
- & eta(-x(k,4), 1/r24, -ix(k,4), -ir24, -ix(k,1))*(
- & cln(1/x(k,1) + x(k,1) + k12, x(k,1)*b*gamma) +
- & log(x(k,1))
- & ) +
- & eta(-x(k,4), r13, -ix(k,4), ir13, -ix(k,3))*(
- & cln(1/x(k,3) + x(k,3) + k34, x(k,3)*b*gamma) +
- & log(x(k,3))
- & ) -
- & (eta(-x(k,4), r13/r24, -ix(k,4), ir13/ir24, -ix(k,2)) +
- & eta(r13, 1D0/r24, ir13, -ir24, ir13/ir24))*(
- & cln(1/x(k,2) + x(k,2) + k23, x(k,2)*b*gamma) +
- & log(x(k,2))
- & ) +
- & eta(-x(k,4), -r13/r24, -ix(k,4), -ir13/ir24, ix(k,2))*
- & eta(r13, 1/r24, ir13, -ir24, ir13/ir24)*
- & (1 - sign(1D0, DBLE(b))*gamma)*c2ipi
- & )
- endif
- enddo
- D0reg = D0reg/m1_/m2_/m3_/m4_/disc
+
+ etas =
+ & xeta(x(1,4), ix(1,4), r13, ir13, ix(1,3), l(1,3)) +
+ & xeta(x(1,4), ix(1,4), 1/r24, -ir24, ix(1,1), l(1,1)) -
+ & xeta(x(1,4), ix(1,4), r13/r24, ir1324, ix(1,2), l(1,2)) +
+ & xeta(x(1,4), ix(1,4), -r13/r24, -ir1324, ix(1,4), l(1,4))*
+ & (1 - sign(1D0, DBLE(b))*gamma)
+ endif
+
+ res = (res - c2ipi*etas + (l(2,2) - l(1,2))*l(1,4))/
+ & (sqrt(M(1)*M(2)*M(3)*M(4))*disc)
end
************************************************************************
- double complex function bdK(x, m1, m2)
-* this is actually -K from the Beenakker/Denner paper for D0ir
+ subroutine D0m3(res, xpi, perm)
implicit none
- double precision x, m1, m2
+ double complex res
+ double precision xpi(13)
+ integer perm
#include "lt.h"
- double precision d
- double complex t
+ double precision m2, m3, m4, p1, p2, p3, p4, p1p2, p2p3
+ double precision m, k12, k13, k14, k23, k24, k34
+ double precision ir12, ir14, ir24, ix1(2), ix4(2)
+ double complex r12, r14, r24, q12, q24
+ double complex x1(2), x4(2), l4(2)
+ double complex a, b, c, d
- d = x - (m1 - m2)**2
- if( d .eq. 0 ) then
- bdK = 1
+ double complex cln, xspence, xetatilde
+ external cln, xspence, xetatilde
+
+ m2 = Mx(2)
+ m3 = Mx(3)
+ m4 = Mx(4)
+ p1 = Px(1)
+ p2 = Px(2)
+ p3 = Px(3)
+ p4 = Px(4)
+ p1p2 = Px(5)
+ p2p3 = Px(6)
+
+ m = sqrt(m3*m4)
+ k23 = (m4 - p4)/m
+ k12 = (m4 + m3 - p3)/m
+ r12 = k2r(k12)
+ ir12 = 0
+ if( k12 .lt. -2 ) ir12 = sign(10D0, 1 - abs(r12))
+
+ m = sqrt(m2*m3)
+ k34 = (m2 - p1)/m
+ k14 = (m2 + m3 - p2)/m
+ r14 = k2r(k14)
+ ir14 = 0
+ if( k14 .lt. -2 ) ir14 = sign(10D0, 1 - abs(r14))
+
+ k13 = (m3 - p1p2)/m3
+
+ m = sqrt(m2*m4)
+ k24 = (m2 + m4 - p2p3)/m
+ r24 = k2r(k24)
+ ir24 = 0
+ if( k24 .lt. -2 ) ir24 = sign(10D0, 1 - abs(r24))
+
+ q24 = r24 - 1/r24
+ q12 = k12 - r24*k14
+
+ a = k34/r24 - k23
+ b = k12*k34 - k13*q24 - k14*k23
+ c = k13*q12 + r24*k34 - k23
+ d = sqrt(DCMPLX((k12*k34 - k13*k24 - k14*k23)**2 -
+ & 4*(k13*(k13 - k23*(k12 - k14*k24)) +
+ & k23*(k23 - k24*k34) + k34*(k34 - k13*k14))))
+ x4(1) = .5D0/a*(b - d)
+ x4(2) = .5D0/a*(b + d)
+ if( abs(x4(1)) .gt. abs(x4(2)) ) then
+ x4(2) = c/(a*x4(1))
else
- t = 4*m1*m2/(d + cI*eps)
- bdK = -t/(sqrt(1 - t) + 1)**2
+ x4(1) = c/(a*x4(2))
endif
+
+ d = -k34*r24 + k23
+ ix4(1) = sign(1D0, DBLE(d))
+ ix4(2) = -ix4(1)
+
+ x1(1) = x4(1)/r24
+ x1(2) = x4(2)/r24
+ ix1(1) = sign(1D0, ix4(1)*DBLE(r24))
+ ix1(2) = -ix1(1)
+
+ c = cln(DCMPLX(k13), -1D0)
+ l4(1) = c + cln((q12 + q24*x4(1))/d, DBLE(q24*ix4(1)/d))
+ l4(2) = c + cln((q12 + q24*x4(2))/d, DBLE(q24*ix4(2)/d))
+
+ res = (
+ & xspence(x4, ix4, r14, ir14) +
+ & xspence(x4, ix4, 1/r14, -ir14) -
+ & xspence(x4, ix4, DCMPLX(k34/k13), -k13) -
+ & xspence(x1, ix1, r12, ir12) -
+ & xspence(x1, ix1, 1/r12, -ir12) +
+ & xspence(x1, ix1, DCMPLX(k23/k13), -k13) -
+ & c2ipi*xetatilde(x4, ix4, 1/r24, -ir24, l4)
+ & )/(m3*m*a*(x4(2) - x4(1)))
end
************************************************************************
- double complex function cspence(z1, z2, im1, im2)
+ subroutine D0m2(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision m3, m4, p1, p2, p3, p4, p1p2, p2p3
+ double precision m, k12, k13, k14, k23, k24, k34
+ double complex k12c, k13c, k23c, k24c, k34c
+ double complex r14, x4(2)
+ double complex a, b, c, disc
+
+ double complex xspence
+ external xspence
+
+ double precision imzero(2)
+ data imzero /0D0, 0D0/
+
+ m3 = Mx(3)
+ m4 = Mx(4)
+ p1 = Px(1)
+ p2 = Px(2)
+ p3 = Px(3)
+ p4 = Px(4)
+ p1p2 = Px(5)
+ p2p3 = Px(6)
+
+ k12 = (m3 - p2)/m3
+ k12c = AddEps(k12)
+
+ k13 = (m3 - p1p2)/m3
+ k13c = AddEps(k13)
+
+ k23 = -p1/m3
+ k23c = AddEps(k23)
+
+ m = sqrt(m3*m4)
+ k24 = (m4 - p2p3)/m
+ k24c = AddEps(k24)/k12c
+ k34 = (m4 - p4)/m
+ k34c = AddEps(k34)/k13c
+ k14 = (m3 + m4 - p3)/m
+ r14 = k2r(k14)
+ r14 = r14*DCMPLX(1D0, sign(eps, DBLE(1/r14 - r14)))
+
+ a = k34*k24 - k23
+ b = k13*k24 + k12*k34 - k14*k23
+ c = k13*k12 - k23*(1 - cI*eps)
+ disc = sqrt(b**2 - 4*a*c)
+ x4(1) = .5D0/a*(b - disc)
+ x4(2) = .5D0/a*(b + disc)
+ if( abs(x4(1)) .gt. abs(x4(2)) ) then
+ x4(2) = c/(a*x4(1))
+ else
+ x4(1) = c/(a*x4(2))
+ endif
+
+ res = (
+ & xspence(x4, imzero, r14, 0D0) +
+ & xspence(x4, imzero, 1/r14, 0D0) -
+ & xspence(x4, imzero, k34c, 0D0) -
+ & xspence(x4, imzero, k24c, 0D0) +
+ & (log(x4(2)) - log(x4(1)))*
+ & (log(k12c) + log(k13c) - log(k23c))
+ & )/(m3*m*a*(x4(2) - x4(1)))
+ end
+
+************************************************************************
+
+ subroutine D0m1(res, xpi, perm)
+ implicit none
+ double complex res
+ double precision xpi(13)
+ integer perm
+
+#include "lt.h"
+
+ double precision m4, k12, k13, k14, k23, k24, k34
+ double complex k12c, k13c, k14c, k23c, k24c, k34c
+ double precision a, b
+ double complex c, disc, x4(2)
+
+ double complex xspence
+ external xspence
+
+ double precision imzero(2)
+ data imzero /0D0, 0D0/
+
+ m4 = Mx(4)
+ k12 = (m4 - Px(3))/m4
+ k12c = AddEps(k12)
+ k13 = (m4 - Px(4))/m4
+ k13c = AddEps(k13)
+ k14 = (m4 - Px(6))/m4
+ k14c = AddEps(k14)
+ k23 = -Px(5)/m4
+ k23c = AddEps(k23)
+ k24 = -Px(2)/m4
+ k24c = AddEps(k24)/k12c
+ k34 = -Px(1)/m4
+ k34c = AddEps(k34)/k13c
+
+ a = k34*k24
+ b = k13*k24 + k12*k34 - k14*k23
+ c = k13*k12 - k23*(1 - cI*eps)
+ disc = sqrt(b*b - 4*a*c)
+ x4(1) = .5D0/a*(b - disc)
+ x4(2) = .5D0/a*(b + disc)
+ if( abs(x4(1)) .gt. abs(x4(2)) ) then
+ x4(2) = c/(a*x4(1))
+ else
+ x4(1) = c/(a*x4(2))
+ endif
+
+ res = (
+ & xspence(x4, imzero, k14c, 0D0) -
+ & xspence(x4, imzero, k34c, 0D0) -
+ & xspence(x4, imzero, k24c, 0D0) +
+ & (log(x4(2)) - log(x4(1)))*
+ & (log(k12c) + log(k13c) - log(k23c))
+ & )/(m4**2*a*(x4(2) - x4(1)))
+ end
+
+************************************************************************
+
+ subroutine D0m0(res, xpi)
+ implicit none
+ double complex res
+ double precision xpi(13)
+
+#include "lt.h"
+
+ double precision m2, k12, k13, k14, k23, k24, k34
+ double complex k12c, k13c, k14c, k23c, k24c, k34c
+ double precision a, b
+ double complex c, disc, x4(2)
+
+ double complex xspence
+ external xspence
+
+ double precision imzero(2)
+ data imzero /0D0, 0D0/
+
+ m2 = abs(P(6))
+ k12 = -P(1)/m2
+ k12c = AddEps(k12)
+ k13 = -P(5)/m2
+ k13c = AddEps(k13)
+ k14 = -P(4)/m2
+ k14c = AddEps(k14)
+ k23 = -P(2)/m2
+ k23c = AddEps(k23)
+ k24 = -P(6)/m2
+ k24c = AddEps(k24)/k12c
+ k34 = -P(3)/m2
+ k34c = AddEps(k34)/k13c
+
+ a = k34*k24
+ b = k13*k24 + k12*k34 - k14*k23
+ c = k13*k12 + cI*eps*k23
+ disc = sqrt(b*b - 4*a*c)
+ x4(1) = .5D0/a*(b - disc)
+ x4(2) = .5D0/a*(b + disc)
+ if( abs(x4(1)) .gt. abs(x4(2)) ) then
+ x4(2) = c/(a*x4(1))
+ else
+ x4(1) = c/(a*x4(2))
+ endif
+
+ res = (
+ & (log(x4(2)) - log(x4(1)))*
+ & (-.5D0*(log(x4(2)) + log(x4(1))) +
+ & log(k12c) + log(k13c) - log(k23c) - log(k14c)) -
+ & xspence(x4, imzero, k34c, 0D0) -
+ & xspence(x4, imzero, k24c, 0D0)
+ & )/(m2**2*a*(x4(2) - x4(1)))
+ end
+
+************************************************************************
+
+ double complex function xspence(z1, im1, z2, im2)
+ implicit none
+ double complex z1(2), z2
+ double precision im1(2), im2
+
+#include "lt.h"
+
+ double complex cspence
+ external cspence
+
+ xspence = cspence(z1(2), im1(2), z2, im2) -
+ & cspence(z1(1), im1(1), z2, im2)
+ end
+
+************************************************************************
+
+ double complex function cspence(z1, im1, z2, im2)
implicit none
double complex z1, z2
double precision im1, im2
#include "lt.h"
double complex cln, spence
integer eta
external cln, spence, eta
double complex z12
double precision im12
integer etas
z12 = z1*z2
im12 = im2*sign(1D0, DBLE(z1))
if( DBLE(z12) .gt. .5D0 ) then
cspence = spence(1 - z12, 0D0)
- etas = eta(z1, z2, im1, im2, im12)
+ etas = eta(z1, im1, z2, im2, im12)
if( etas .ne. 0 ) cspence = cspence +
& etas*cln(1 - z12, -im12)*c2ipi
else if( abs(z12) .lt. 1D-4 ) then
cspence = pi6
if( abs(z12) .gt. 1D-14 ) cspence = cspence -
& spence(z12, 0D0) +
& (cln(z1, im1) + cln(z2, im2))*z12*
& (1 + z12*(.5D0 + z12*(1/3D0 + z12/4D0)))
else
- cspence = pi6 -
- & spence(z12, 0D0) -
+ cspence = pi6 - spence(z12, 0D0) -
& (cln(z1, im1) + cln(z2, im2))*cln(1 - z12, 0D0)
endif
end
************************************************************************
- integer function eta_tilde(c1, c2, im1x, im2x)
+ double complex function xeta(z1, im1, z2, im2, im12, l1)
+ implicit none
+ double complex z1(2), z2, l1(2)
+ double precision im1(2), im2, im12
+
+#include "lt.h"
+
+ integer eta
+ external eta
+
+ xeta = l1(2)*eta(z1(2), im1(2), z2, im2, im12) -
+ & l1(1)*eta(z1(1), im1(1), z2, im2, im12)
+ end
+
+************************************************************************
+
+ double complex function xetatilde(z1, im1, z2, im2, l1)
+ implicit none
+ double complex z1(2), z2, l1(2)
+ double precision im1(2), im2
+
+#include "lt.h"
+
+ integer etatilde
+ external etatilde
+
+ xetatilde = l1(2)*etatilde(z1(2), im1(2), z2, im2) -
+ & l1(1)*etatilde(z1(1), im1(1), z2, im2)
+ end
+
+************************************************************************
+
+ integer function etatilde(c1, im1x, c2, im2x)
implicit none
double complex c1, c2
double precision im1x, im2x
double precision im1, im2
integer eta
external eta
im1 = DIMAG(c1)
if( im1 .eq. 0 ) im1 = im1x
im2 = DIMAG(c2)
if( im2 .ne. 0 ) then
- eta_tilde = eta(c1, c2, im1x, 0D0, 0D0)
+ etatilde = eta(c1, im1x, c2, 0D0, 0D0)
else if( DBLE(c2) .gt. 0 ) then
- eta_tilde = 0
+ etatilde = 0
else if( im1 .gt. 0 .and. im2x .gt. 0 ) then
- eta_tilde = -1
+ etatilde = -1
else if( im1 .lt. 0 .and. im2x .lt. 0 ) then
- eta_tilde = 1
+ etatilde = 1
else
- eta_tilde = 0
+ etatilde = 0
#ifdef WARNINGS
if( im1 .eq. 0 .and. DBLE(c1) .lt. 0 .or.
& im2x .eq. 0 .and. DBLE(c1*c2) .lt. 0 )
- & print *, "eta_tilde not defined"
+ & print *, "etatilde not defined"
#endif
endif
end
diff --git a/Looptools/D/D0C.F b/Looptools/D/D0C.F
--- a/Looptools/D/D0C.F
+++ b/Looptools/D/D0C.F
@@ -1,67 +1,77 @@
* D0C.F
-* the scalar four-point function for complex parameters
+* the scalar four-point function with complex masses
* this file is part of LoopTools
-* last modified 24 Jan 06 th
+* last modified 29 Jan 09 th
#include "defs.h"
double complex function D0C(p1, p2, p3, p4, p1p2, p2p3,
& m1, m2, m3, m4)
implicit none
double complex p1, p2, p3, p4, p1p2, p2p3
double complex m1, m2, m3, m4
#include "lt.h"
- double complex cpi(13)
- integer ier
+ double complex cpi(10), res(0:1)
+ integer key, ier, ier1
cpi(1) = m1
cpi(2) = m2
cpi(3) = m3
cpi(4) = m4
- cpi(5) = p1
+ cpi(5) = p1
cpi(6) = p2
cpi(7) = p3
cpi(8) = p4
cpi(9) = p1p2
cpi(10) = p2p3
- cpi(11) = 0
- cpi(12) = 0
- cpi(13) = 0
ier = 0
- call ffcd0(D0C, cpi, ier)
+ key = ibits(versionkey, KeyD0C, 2)
- if( ier .gt. warndigits ) then
- print *, "D0C lost ", ier, " digits"
- print *, "p1 =", p1
- print *, "p2 =", p2
- print *, "p3 =", p3
- print *, "p4 =", p4
- print *, "p1p2 =", p1p2
- print *, "p2p3 =", p2p3
- print *, "m1 =", m1
- print *, "m2 =", m2
- print *, "m3 =", m3
- print *, "m4 =", m4
+ if( key .ne. 1 ) call ffd0c(res(0), cpi, 0, ier)
+
+ if( key .ne. 0 ) then
+ ier1 = 0
+ call ffd0c(res(1), cpi, 1, ier1)
+ if( key .gt. 1 .and.
+ & abs(res(0) - res(1)) .gt. maxdev*abs(res(0)) ) then
+ print *, "Discrepancy in D0C:"
+ print *, " p1 =", p1
+ print *, " p2 =", p2
+ print *, " p3 =", p3
+ print *, " p4 =", p4
+ print *, " p1p2 =", p1p2
+ print *, " p2p3 =", p2p3
+ print *, " m1 =", m1
+ print *, " m2 =", m2
+ print *, " m3 =", m3
+ print *, " m4 =", m4
+ print *, "D0C a =", res(0)
+ print *, "D0C b =", res(1)
+ if( ier1 .lt. ier .and. ier .gt. errdigits )
+ & res(0) = res(1)
+ endif
endif
+
+ D0C = res(iand(key, 1))
end
************************************************************************
* adapter code for C++
subroutine d0subc(res, p1, p2, p3, p4, p1p2, p2p3,
& m1, m2, m3, m4)
implicit none
double complex res
double complex p1, p2, p3, p4, p1p2, p2p3
double complex m1, m2, m3, m4
double complex D0C
external D0C
res = D0C(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)
end
diff --git a/Looptools/D/Dget.F b/Looptools/D/Dget.F
--- a/Looptools/D/Dget.F
+++ b/Looptools/D/Dget.F
@@ -1,425 +1,440 @@
* Dget.F
* retrieve the four-point tensor coefficients
* this file is part of LoopTools
* improvements by M. Rauch
-* last modified 7 Dec 05 th
+* last modified 28 Sep 10 th
#include "defs.h"
integer function XDget(p1, p2, p3, p4, p1p2, p2p3,
& m1, m2, m3, m4)
implicit none
DVAR p1, p2, p3, p4, p1p2, p2p3
DVAR m1, m2, m3, m4
#include "lt.h"
integer cachelookup
external cachelookup, XDcoeff
DVAR para(Pdd)
para(1) = p1
para(2) = p2
para(3) = p3
para(4) = p4
para(5) = p1p2
para(6) = p2p3
para(7) = m1
+ if( abs(para(7)) .lt. minmass ) para(7) = 0
para(8) = m2
+ if( abs(para(8)) .lt. minmass ) para(8) = 0
para(9) = m3
+ if( abs(para(9)) .lt. minmass ) para(9) = 0
para(10) = m4
+ if( abs(para(10)) .lt. minmass ) para(10) = 0
XDget = cachelookup(para, Dval(1,0), XDcoeff, RC*Pdd, Ndd)
end
************************************************************************
double complex function XD0i(i, p1, p2, p3, p4, p1p2, p2p3,
& m1, m2, m3, m4)
implicit none
integer i
DVAR p1, p2, p3, p4, p1p2, p2p3
DVAR m1, m2, m3, m4
#include "lt.h"
integer XDget
external XDget
integer b
b = XDget(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)
XD0i = Dval(i,b)
end
************************************************************************
subroutine XDcoeff(para, D, ldpara)
implicit none
integer ldpara
DVAR para(ldpara,Pdd)
double complex D(Ndd)
#include "lt.h"
integer XCget
double complex XD0
external XCget, XD0
DVAR p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4
DVAR f1, f2, f3
QVAR G(3,3)
double complex c0sum, c1sum, c2sum, csum
double complex c00sum, c11sum, c12sum, c22sum
double complex in(3)
integer C234, C134, C124, C123
+ logical dump
+
+#ifdef SOLVE_EIGEN
+ QVAR Ginv(3,3)
+#define SOLVE_SETUP XInverse(3, G,3, Ginv,3)
+#define SOLVE(b) XSolve(3, G,3, Ginv,3, b)
+#else
integer perm(3)
- logical dump
+#define IN(i) in(perm(i))
+#define SOLVE_SETUP XDecomp(3, G,3, perm)
+#define SOLVE(b) XSolve(3, G,3, b)
+#endif
+
+#ifdef COMPLEXPARA
+ if( abs(DIMAG(para(1,1))) +
+ & abs(DIMAG(para(1,2))) +
+ & abs(DIMAG(para(1,3))) +
+ & abs(DIMAG(para(1,4))) +
+ & abs(DIMAG(para(1,5))) +
+ & abs(DIMAG(para(1,6))) .gt. 0 )
+ & print *, "Warning: complex momenta not implemented"
+ if( abs(DIMAG(para(1,7))) +
+ & abs(DIMAG(para(1,8))) +
+ & abs(DIMAG(para(1,9))) +
+ & abs(DIMAG(para(1,10))) .eq. 0 ) then
+ call Dcoeff(para, D, 2)
+ return
+ endif
+#endif
p1 = para(1,1)
p2 = para(1,2)
p3 = para(1,3)
p4 = para(1,4)
p1p2 = para(1,5)
p2p3 = para(1,6)
m1 = para(1,7)
m2 = para(1,8)
m3 = para(1,9)
m4 = para(1,10)
-#ifdef COMPLEXPARA
- if( DIMAG(p1) .eq. 0 .and.
- & DIMAG(p2) .eq. 0 .and.
- & DIMAG(p3) .eq. 0 .and.
- & DIMAG(p4) .eq. 0 .and.
- & DIMAG(p1p2) .eq. 0 .and.
- & DIMAG(p2p3) .eq. 0 .and.
- & DIMAG(m1) .eq. 0 .and.
- & DIMAG(m2) .eq. 0 .and.
- & DIMAG(m3) .eq. 0 .and.
- & DIMAG(m4) .eq. 0 ) then
- call Dcoeff(para, D, 2)
- return
- endif
-#endif
-
C234 = XCget(p2, p3, p2p3, m2, m3, m4)
C134 = XCget(p1p2, p3, p4, m1, m3, m4)
C124 = XCget(p1, p2p3, p4, m1, m2, m4)
C123 = XCget(p1, p2, p1p2, m1, m2, m3)
serial = serial + 1
dump = ibits(debugkey, DebugD, 1) .ne. 0 .and.
& serial .ge. debugfrom .and. serial .le. debugto
if( dump ) call XDumpPara(4, para, ldpara, "Dcoeff")
- f1 = QEXT(m2) - QEXT(m1) - QEXT(p1)
- f2 = QEXT(m3) - QEXT(m1) - QEXT(p1p2)
- f3 = QEXT(m4) - QEXT(m1) - QEXT(p4)
+ f1 = QPREC(m2) - QPREC(m1) - QPREC(p1)
+ f2 = QPREC(m3) - QPREC(m1) - QPREC(p1p2)
+ f3 = QPREC(m4) - QPREC(m1) - QPREC(p4)
- G(1,1) = 2*QEXT(p1)
- G(2,2) = 2*QEXT(p1p2)
- G(3,3) = 2*QEXT(p4)
- G(1,2) = QEXT(p1) + QEXT(p1p2) - QEXT(p2)
+ G(1,1) = 2*QPREC(p1)
+ G(2,2) = 2*QPREC(p1p2)
+ G(3,3) = 2*QPREC(p4)
+ G(1,2) = QPREC(p1) + QPREC(p1p2) - QPREC(p2)
G(2,1) = G(1,2)
- G(1,3) = QEXT(p1) + QEXT(p4) - QEXT(p2p3)
+ G(1,3) = QPREC(p1) + QPREC(p4) - QPREC(p2p3)
G(3,1) = G(1,3)
- G(2,3) = QEXT(p1p2) - QEXT(p3) + QEXT(p4)
+ G(2,3) = QPREC(p1p2) - QPREC(p3) + QPREC(p4)
G(3,2) = G(2,3)
- call XLUDecomp(G, 3, perm)
+ call SOLVE_SETUP
c0sum = Cval(cc0,C234) + Cval(cc1,C234) + Cval(cc2,C234)
c1sum = Cval(cc1,C234) + Cval(cc11,C234) + Cval(cc12,C234)
c2sum = Cval(cc2,C234) + Cval(cc12,C234) + Cval(cc22,C234)
csum = c0sum + c1sum + c2sum
c00sum = Cval(cc00,C234) +
& Cval(cc001,C234) + Cval(cc002,C234)
c11sum = Cval(cc11,C234) +
& Cval(cc111,C234) + Cval(cc112,C234)
c12sum = Cval(cc12,C234) +
& Cval(cc112,C234) + Cval(cc122,C234)
c22sum = Cval(cc22,C234) +
& Cval(cc122,C234) + Cval(cc222,C234)
D(dd0) = XD0(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)
- in(1) = f1*D(dd0) - Cval(cc0,C234) + Cval(cc0,C134)
- in(2) = f2*D(dd0) - Cval(cc0,C234) + Cval(cc0,C124)
- in(3) = f3*D(dd0) - Cval(cc0,C234) + Cval(cc0,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd0) - Cval(cc0,C234) + Cval(cc0,C134)
+ IN(2) = f2*D(dd0) - Cval(cc0,C234) + Cval(cc0,C124)
+ IN(3) = f3*D(dd0) - Cval(cc0,C234) + Cval(cc0,C123)
+ call SOLVE(in)
D(dd1) = in(1)
D(dd2) = in(2)
D(dd3) = in(3)
D(dd00) = m1*D(dd0) - .5D0*
& (D(dd1)*f1 + D(dd2)*f2 + D(dd3)*f3 - Cval(cc0,C234))
- in(1) = f1*D(dd1) + c0sum - 2*D(dd00)
- in(2) = f2*D(dd1) + c0sum + Cval(cc1,C124)
- in(3) = f3*D(dd1) + c0sum + Cval(cc1,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd1) + c0sum - 2*D(dd00)
+ IN(2) = f2*D(dd1) + c0sum + Cval(cc1,C124)
+ IN(3) = f3*D(dd1) + c0sum + Cval(cc1,C123)
+ call SOLVE(in)
D(dd11) = in(1)
D(dd12) = in(2)
D(dd13) = in(3)
- in(1) = f1*D(dd2) - Cval(cc1,C234) + Cval(cc1,C134)
- in(2) = f2*D(dd2) - Cval(cc1,C234) - 2*D(dd00)
- in(3) = f3*D(dd2) - Cval(cc1,C234) + Cval(cc2,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd2) - Cval(cc1,C234) + Cval(cc1,C134)
+ IN(2) = f2*D(dd2) - Cval(cc1,C234) - 2*D(dd00)
+ IN(3) = f3*D(dd2) - Cval(cc1,C234) + Cval(cc2,C123)
+ call SOLVE(in)
D(dd12) = .5D0*(D(dd12) + in(1))
D(dd22) = in(2)
D(dd23) = in(3)
- in(1) = f1*D(dd3) - Cval(cc2,C234) + Cval(cc2,C134)
- in(2) = f2*D(dd3) - Cval(cc2,C234) + Cval(cc2,C124)
- in(3) = f3*D(dd3) - Cval(cc2,C234) - 2*D(dd00)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd3) - Cval(cc2,C234) + Cval(cc2,C134)
+ IN(2) = f2*D(dd3) - Cval(cc2,C234) + Cval(cc2,C124)
+ IN(3) = f3*D(dd3) - Cval(cc2,C234) - 2*D(dd00)
+ call SOLVE(in)
D(dd13) = .5D0*(D(dd13) + in(1))
D(dd23) = .5D0*(D(dd23) + in(2))
D(dd33) = in(3)
- in(1) = f1*D(dd00) - Cval(cc00,C234) + Cval(cc00,C134)
- in(2) = f2*D(dd00) - Cval(cc00,C234) + Cval(cc00,C124)
- in(3) = f3*D(dd00) - Cval(cc00,C234) + Cval(cc00,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd00) - Cval(cc00,C234) + Cval(cc00,C134)
+ IN(2) = f2*D(dd00) - Cval(cc00,C234) + Cval(cc00,C124)
+ IN(3) = f3*D(dd00) - Cval(cc00,C234) + Cval(cc00,C123)
+ call SOLVE(in)
D(dd001) = in(1)
D(dd002) = in(2)
D(dd003) = in(3)
- in(1) = f1*D(dd11) - csum - 4*D(dd001)
- in(2) = f2*D(dd11) - csum + Cval(cc11,C124)
- in(3) = f3*D(dd11) - csum + Cval(cc11,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd11) - csum - 4*D(dd001)
+ IN(2) = f2*D(dd11) - csum + Cval(cc11,C124)
+ IN(3) = f3*D(dd11) - csum + Cval(cc11,C123)
+ call SOLVE(in)
D(dd111) = in(1)
D(dd112) = in(2)
D(dd113) = in(3)
- in(1) = f1*D(dd22) - Cval(cc11,C234) + Cval(cc11,C134)
- in(2) = f2*D(dd22) - Cval(cc11,C234) - 4*D(dd002)
- in(3) = f3*D(dd22) - Cval(cc11,C234) + Cval(cc22,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd22) - Cval(cc11,C234) + Cval(cc11,C134)
+ IN(2) = f2*D(dd22) - Cval(cc11,C234) - 4*D(dd002)
+ IN(3) = f3*D(dd22) - Cval(cc11,C234) + Cval(cc22,C123)
+ call SOLVE(in)
D(dd122) = in(1)
D(dd222) = in(2)
D(dd223) = in(3)
- in(1) = f1*D(dd33) - Cval(cc22,C234) + Cval(cc22,C134)
- in(2) = f2*D(dd33) - Cval(cc22,C234) + Cval(cc22,C124)
- in(3) = f3*D(dd33) - Cval(cc22,C234) - 4*D(dd003)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd33) - Cval(cc22,C234) + Cval(cc22,C134)
+ IN(2) = f2*D(dd33) - Cval(cc22,C234) + Cval(cc22,C124)
+ IN(3) = f3*D(dd33) - Cval(cc22,C234) - 4*D(dd003)
+ call SOLVE(in)
D(dd133) = in(1)
D(dd233) = in(2)
D(dd333) = in(3)
- in(1) = f1*D(dd13) + c2sum - 2*D(dd003)
- in(2) = f2*D(dd13) + c2sum + Cval(cc12,C124)
- in(3) = f3*D(dd13) + c2sum - 2*D(dd001)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd13) + c2sum - 2*D(dd003)
+ IN(2) = f2*D(dd13) + c2sum + Cval(cc12,C124)
+ IN(3) = f3*D(dd13) + c2sum - 2*D(dd001)
+ call SOLVE(in)
D(dd113) = .5D0*(D(dd113) + in(1))
D(dd123) = in(2)
D(dd133) = .5D0*(D(dd133) + in(3))
D(dd0000) = 1/3D0*(m1*D(dd00) -
& .5D0*(f1*D(dd001) + f2*D(dd002) + f3*D(dd003) -
& Cval(cc00,C234) - 1/6D0))
D(dd0011) = 1/3D0*(m1*D(dd11) -
& .5D0*(f1*D(dd111) + f2*D(dd112) + f3*D(dd113) - csum))
D(dd0012) = 1/3D0*(m1*D(dd12) -
& .5D0*(f1*D(dd112) + f2*D(dd122) + f3*D(dd123) + c1sum))
D(dd0013) = 1/3D0*(m1*D(dd13) -
& .5D0*(f1*D(dd113) + f2*D(dd123) + f3*D(dd133) + c2sum))
D(dd0022) = 1/3D0*(m1*D(dd22) -
& .5D0*(f1*D(dd122) + f2*D(dd222) + f3*D(dd223) -
& Cval(cc11,C234)))
D(dd0023) = 1/3D0*(m1*D(dd23) -
& .5D0*(f1*D(dd123) + f2*D(dd223) + f3*D(dd233) -
& Cval(cc12,C234)))
D(dd0033) = 1/3D0*(m1*D(dd33) -
& .5D0*(f1*D(dd133) + f2*D(dd233) + f3*D(dd333) -
& Cval(cc22,C234)))
c1sum = c1sum + c11sum + c12sum
c2sum = c2sum + c12sum + c22sum
csum = csum + c1sum + c2sum
- in(1) = f1*D(dd111) + csum - 6*D(dd0011)
- in(2) = f2*D(dd111) + csum + Cval(cc111,C124)
- in(3) = f3*D(dd111) + csum + Cval(cc111,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd111) + csum - 6*D(dd0011)
+ IN(2) = f2*D(dd111) + csum + Cval(cc111,C124)
+ IN(3) = f3*D(dd111) + csum + Cval(cc111,C123)
+ call SOLVE(in)
D(dd1111) = in(1)
D(dd1112) = in(2)
D(dd1113) = in(3)
- in(1) = f1*D(dd113) - c2sum - 4*D(dd0013)
- in(2) = f2*D(dd113) - c2sum + Cval(cc112,C124)
- in(3) = f3*D(dd113) - c2sum - 2*D(dd0011)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd113) - c2sum - 4*D(dd0013)
+ IN(2) = f2*D(dd113) - c2sum + Cval(cc112,C124)
+ IN(3) = f3*D(dd113) - c2sum - 2*D(dd0011)
+ call SOLVE(in)
D(dd1113) = .5D0*(D(dd1113) + in(1))
D(dd1123) = in(2)
D(dd1133) = in(3)
- in(1) = f1*D(dd122) + c11sum - 2*D(dd0022)
- in(2) = f2*D(dd122) + c11sum - 4*D(dd0012)
- in(3) = f3*D(dd122) + c11sum + Cval(cc122,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd122) + c11sum - 2*D(dd0022)
+ IN(2) = f2*D(dd122) + c11sum - 4*D(dd0012)
+ IN(3) = f3*D(dd122) + c11sum + Cval(cc122,C123)
+ call SOLVE(in)
D(dd1122) = in(1)
D(dd1222) = in(2)
D(dd1223) = in(3)
- in(1) = f1*D(dd222) - Cval(cc111,C234) + Cval(cc111,C134)
- in(2) = f2*D(dd222) - Cval(cc111,C234) - 6*D(dd0022)
- in(3) = f3*D(dd222) - Cval(cc111,C234) + Cval(cc222,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd222) - Cval(cc111,C234) + Cval(cc111,C134)
+ IN(2) = f2*D(dd222) - Cval(cc111,C234) - 6*D(dd0022)
+ IN(3) = f3*D(dd222) - Cval(cc111,C234) + Cval(cc222,C123)
+ call SOLVE(in)
D(dd1222) = .5D0*(D(dd1222) + in(1))
D(dd2222) = in(2)
D(dd2223) = in(3)
- in(1) = f1*D(dd233) - Cval(cc122,C234) + Cval(cc122,C134)
- in(2) = f2*D(dd233) - Cval(cc122,C234) - 2*D(dd0033)
- in(3) = f3*D(dd233) - Cval(cc122,C234) - 4*D(dd0023)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd233) - Cval(cc122,C234) + Cval(cc122,C134)
+ IN(2) = f2*D(dd233) - Cval(cc122,C234) - 2*D(dd0033)
+ IN(3) = f3*D(dd233) - Cval(cc122,C234) - 4*D(dd0023)
+ call SOLVE(in)
D(dd1233) = in(1)
D(dd2233) = in(2)
D(dd2333) = in(3)
- in(1) = f1*D(dd333) - Cval(cc222,C234) + Cval(cc222,C134)
- in(2) = f2*D(dd333) - Cval(cc222,C234) + Cval(cc222,C124)
- in(3) = f3*D(dd333) - Cval(cc222,C234) - 6*D(dd0033)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd333) - Cval(cc222,C234) + Cval(cc222,C134)
+ IN(2) = f2*D(dd333) - Cval(cc222,C234) + Cval(cc222,C124)
+ IN(3) = f3*D(dd333) - Cval(cc222,C234) - 6*D(dd0033)
+ call SOLVE(in)
D(dd1333) = in(1)
D(dd2333) = .5D0*(D(dd2333) + in(2))
D(dd3333) = in(3)
c00sum = c00sum +
& Cval(cc001,C234) + Cval(cc0011,C234) + Cval(cc0012,C234) +
& Cval(cc002,C234) + Cval(cc0012,C234) + Cval(cc0022,C234)
c11sum = c11sum +
& Cval(cc111,C234) + Cval(cc1111,C234) + Cval(cc1112,C234) +
& Cval(cc112,C234) + Cval(cc1112,C234) + Cval(cc1122,C234)
c12sum = c12sum +
& Cval(cc112,C234) + Cval(cc1112,C234) + Cval(cc1122,C234) +
& Cval(cc122,C234) + Cval(cc1122,C234) + Cval(cc1222,C234)
c22sum = c22sum +
& Cval(cc122,C234) + Cval(cc1122,C234) + Cval(cc1222,C234) +
& Cval(cc222,C234) + Cval(cc1222,C234) + Cval(cc2222,C234)
c1sum = c1sum + c11sum + c12sum
c2sum = c2sum + c12sum + c22sum
csum = csum + c1sum + c2sum
- in(1) = f1*D(dd0000) - Cval(cc0000,C234) + Cval(cc0000,C134)
- in(2) = f2*D(dd0000) - Cval(cc0000,C234) + Cval(cc0000,C124)
- in(3) = f3*D(dd0000) - Cval(cc0000,C234) + Cval(cc0000,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd0000) - Cval(cc0000,C234) + Cval(cc0000,C134)
+ IN(2) = f2*D(dd0000) - Cval(cc0000,C234) + Cval(cc0000,C124)
+ IN(3) = f3*D(dd0000) - Cval(cc0000,C234) + Cval(cc0000,C123)
+ call SOLVE(in)
D(dd00001) = in(1)
D(dd00002) = in(2)
D(dd00003) = in(3)
- in(1) = f1*D(dd0011) - c00sum - 4*D(dd00001)
- in(2) = f2*D(dd0011) - c00sum + Cval(cc0011,C124)
- in(3) = f3*D(dd0011) - c00sum + Cval(cc0011,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd0011) - c00sum - 4*D(dd00001)
+ IN(2) = f2*D(dd0011) - c00sum + Cval(cc0011,C124)
+ IN(3) = f3*D(dd0011) - c00sum + Cval(cc0011,C123)
+ call SOLVE(in)
D(dd00111) = in(1)
D(dd00112) = in(2)
D(dd00113) = in(3)
- in(1) = f1*D(dd0022) - Cval(cc0011,C234) + Cval(cc0011,C134)
- in(2) = f2*D(dd0022) - Cval(cc0011,C234) - 4*D(dd00002)
- in(3) = f3*D(dd0022) - Cval(cc0011,C234) + Cval(cc0022,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd0022) - Cval(cc0011,C234) + Cval(cc0011,C134)
+ IN(2) = f2*D(dd0022) - Cval(cc0011,C234) - 4*D(dd00002)
+ IN(3) = f3*D(dd0022) - Cval(cc0011,C234) + Cval(cc0022,C123)
+ call SOLVE(in)
D(dd00122) = in(1)
D(dd00222) = in(2)
D(dd00223) = in(3)
- in(1) = f1*D(dd0033) - Cval(cc0022,C234) + Cval(cc0022,C134)
- in(2) = f2*D(dd0033) - Cval(cc0022,C234) + Cval(cc0022,C124)
- in(3) = f3*D(dd0033) - Cval(cc0022,C234) - 4*D(dd00003)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd0033) - Cval(cc0022,C234) + Cval(cc0022,C134)
+ IN(2) = f2*D(dd0033) - Cval(cc0022,C234) + Cval(cc0022,C124)
+ IN(3) = f3*D(dd0033) - Cval(cc0022,C234) - 4*D(dd00003)
+ call SOLVE(in)
D(dd00133) = in(1)
D(dd00233) = in(2)
D(dd00333) = in(3)
- in(1) = f1*D(dd0023) - Cval(cc0012,C234) + Cval(cc0012,C134)
- in(2) = f2*D(dd0023) - Cval(cc0012,C234) - 2*D(dd00003)
- in(3) = f3*D(dd0023) - Cval(cc0012,C234) - 2*D(dd00002)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd0023) - Cval(cc0012,C234) + Cval(cc0012,C134)
+ IN(2) = f2*D(dd0023) - Cval(cc0012,C234) - 2*D(dd00003)
+ IN(3) = f3*D(dd0023) - Cval(cc0012,C234) - 2*D(dd00002)
+ call SOLVE(in)
D(dd00123) = in(1)
D(dd00223) = .5D0*(D(dd00223) + in(2))
D(dd00233) = .5D0*(D(dd00233) + in(3))
- in(1) = f1*D(dd1111) - csum - 8*D(dd00111)
- in(2) = f2*D(dd1111) - csum + Cval(cc1111,C124)
- in(3) = f3*D(dd1111) - csum + Cval(cc1111,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd1111) - csum - 8*D(dd00111)
+ IN(2) = f2*D(dd1111) - csum + Cval(cc1111,C124)
+ IN(3) = f3*D(dd1111) - csum + Cval(cc1111,C123)
+ call SOLVE(in)
D(dd11111) = in(1)
D(dd11112) = in(2)
D(dd11113) = in(3)
- in(1) = f1*D(dd2222) - Cval(cc1111,C234) + Cval(cc1111,C134)
- in(2) = f2*D(dd2222) - Cval(cc1111,C234) - 8*D(dd00222)
- in(3) = f3*D(dd2222) - Cval(cc1111,C234) + Cval(cc2222,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd2222) - Cval(cc1111,C234) + Cval(cc1111,C134)
+ IN(2) = f2*D(dd2222) - Cval(cc1111,C234) - 8*D(dd00222)
+ IN(3) = f3*D(dd2222) - Cval(cc1111,C234) + Cval(cc2222,C123)
+ call SOLVE(in)
D(dd12222) = in(1)
D(dd22222) = in(2)
D(dd22223) = in(3)
- in(1) = f1*D(dd3333) - Cval(cc2222,C234) + Cval(cc2222,C134)
- in(2) = f2*D(dd3333) - Cval(cc2222,C234) + Cval(cc2222,C124)
- in(3) = f3*D(dd3333) - Cval(cc2222,C234) - 8*D(dd00333)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd3333) - Cval(cc2222,C234) + Cval(cc2222,C134)
+ IN(2) = f2*D(dd3333) - Cval(cc2222,C234) + Cval(cc2222,C124)
+ IN(3) = f3*D(dd3333) - Cval(cc2222,C234) - 8*D(dd00333)
+ call SOLVE(in)
D(dd13333) = in(1)
D(dd23333) = in(2)
D(dd33333) = in(3)
- in(1) = f1*D(dd1122) - c11sum - 4*D(dd00122)
- in(2) = f2*D(dd1122) - c11sum - 4*D(dd00112)
- in(3) = f3*D(dd1122) - c11sum + Cval(cc1122,C123)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd1122) - c11sum - 4*D(dd00122)
+ IN(2) = f2*D(dd1122) - c11sum - 4*D(dd00112)
+ IN(3) = f3*D(dd1122) - c11sum + Cval(cc1122,C123)
+ call SOLVE(in)
D(dd11122) = in(1)
D(dd11222) = in(2)
D(dd11223) = in(3)
- in(1) = f1*D(dd1133) - c22sum - 4*D(dd00133)
- in(2) = f2*D(dd1133) - c22sum + Cval(cc1122,C124)
- in(3) = f3*D(dd1133) - c22sum - 4*D(dd00113)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd1133) - c22sum - 4*D(dd00133)
+ IN(2) = f2*D(dd1133) - c22sum + Cval(cc1122,C124)
+ IN(3) = f3*D(dd1133) - c22sum - 4*D(dd00113)
+ call SOLVE(in)
D(dd11133) = in(1)
D(dd11233) = in(2)
D(dd11333) = in(3)
- in(1) = f1*D(dd2233) - Cval(cc1122,C234) + Cval(cc1122,C134)
- in(2) = f2*D(dd2233) - Cval(cc1122,C234) - 4*D(dd00233)
- in(3) = f3*D(dd2233) - Cval(cc1122,C234) - 4*D(dd00223)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd2233) - Cval(cc1122,C234) + Cval(cc1122,C134)
+ IN(2) = f2*D(dd2233) - Cval(cc1122,C234) - 4*D(dd00233)
+ IN(3) = f3*D(dd2233) - Cval(cc1122,C234) - 4*D(dd00223)
+ call SOLVE(in)
D(dd12233) = in(1)
D(dd22233) = in(2)
D(dd22333) = in(3)
- in(1) = f1*D(dd1123) - c12sum - 4*D(dd00123)
- in(2) = f2*D(dd1123) - c12sum - 2*D(dd00113)
- in(3) = f3*D(dd1123) - c12sum - 2*D(dd00112)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd1123) - c12sum - 4*D(dd00123)
+ IN(2) = f2*D(dd1123) - c12sum - 2*D(dd00113)
+ IN(3) = f3*D(dd1123) - c12sum - 2*D(dd00112)
+ call SOLVE(in)
D(dd11123) = in(1)
D(dd11223) = .5D0*(D(dd11223) + in(2))
D(dd11233) = .5D0*(D(dd11233) + in(3))
- in(1) = f1*D(dd2223) - Cval(cc1112,C234) + Cval(cc1112,C134)
- in(2) = f2*D(dd2223) - Cval(cc1112,C234) - 6*D(dd00223)
- in(3) = f3*D(dd2223) - Cval(cc1112,C234) - 2*D(dd00222)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd2223) - Cval(cc1112,C234) + Cval(cc1112,C134)
+ IN(2) = f2*D(dd2223) - Cval(cc1112,C234) - 6*D(dd00223)
+ IN(3) = f3*D(dd2223) - Cval(cc1112,C234) - 2*D(dd00222)
+ call SOLVE(in)
D(dd12223) = in(1)
D(dd22223) = .5D0*(D(dd22223) + in(2))
D(dd22233) = .5D0*(D(dd22233) + in(3))
- in(1) = f1*D(dd2333) - Cval(cc1222,C234) + Cval(cc1222,C134)
- in(2) = f2*D(dd2333) - Cval(cc1222,C234) - 2*D(dd00333)
- in(3) = f3*D(dd2333) - Cval(cc1222,C234) - 6*D(dd00233)
- call XLUBackSubst(G, 3, perm, in)
+ IN(1) = f1*D(dd2333) - Cval(cc1222,C234) + Cval(cc1222,C134)
+ IN(2) = f2*D(dd2333) - Cval(cc1222,C234) - 2*D(dd00333)
+ IN(3) = f3*D(dd2333) - Cval(cc1222,C234) - 6*D(dd00233)
+ call SOLVE(in)
D(dd12333) = in(1)
D(dd22333) = .5D0*(D(dd22333) + in(2))
D(dd23333) = .5D0*(D(dd23333) + in(3))
if( dump ) call XDumpCoeff(4, D)
end
diff --git a/Looptools/D/ffRn.F b/Looptools/D/ffRn.F
new file mode 100644
--- /dev/null
+++ b/Looptools/D/ffRn.F
@@ -0,0 +1,130 @@
+* ffRn.F
+* calculate Rn = \int_0^1 dx (x - cz - I signz) (x - cy - I signy)
+* Input: cy, cz, signz, signy
+* i*sign=-i*eps is needed in the case of real masses
+* this file is part of LoopTools
+* last modified 8 Dec 10 th
+
+* Written by Le Duc Ninh, MPI, Munich (Dec 15, 2008).
+* Spence, log and eta functions are taken from FF.
+* 14 Aug 2009: changed ieps of cdyza to "signy" (before used "signza").
+
+#include "externals.h"
+
+
+ double complex function ffRn(cy, signy, cz, signz, ier)
+ implicit none
+ double complex cy, cz
+ double precision signy, signz
+ integer ier
+
+#include "ff.h"
+
+ double complex c1, c2, c1yz, cab1, cab2, dummy
+ double precision sz, syz, sab1, sab2
+ integer n
+
+ double complex zfflog
+ integer nffet1
+ external zfflog, nffet1
+
+ if( abs(cy - cz) .lt. precx ) then
+* cy == cza and check for singularities
+* be careful with log(0) singularity.
+ sz = signz
+ c1 = 0
+ c2 = 0
+ if( abs(DIMAG(cy)) .lt. precx .and. signy*sz .lt. 0 ) then
+ sz = signy
+ if( DBLE(cy) .ge. 0 ) then
+ c2 = sign(2D0, signz)*c2ipi
+ if( DBLE(cy) .le. 1 ) then
+ call ffwarn(255, ier, 1D0, 0D0)
+ c1 = c2*(zfflog(-cy, 1, DCMPLX(-sz), ier) -
+ & zfflog(DCMPLX(-1D-16), 1, DCMPLX(-sz), ier))
+ c2 = 0
+ endif
+ endif
+ endif
+ ffRn = .5D0*(c1 +
+ & zfflog((cy - 1)/cy, 1, DCMPLX(sz), ier)*(
+ & zfflog(1 - cy, 1, DCMPLX(-sz), ier) +
+ & zfflog(-cy, 1, DCMPLX(-sz), ier) - c2 ))
+ return
+ endif
+
+* calculate the sign of imaginary parts and eta functions
+* we do not need the ieps for y0
+* if im(y0) == im(y1) we may need the ieps for the logs
+
+ sz = DIMAG(cz)
+ if( sz .eq. 0 ) sz = signz
+
+ syz = DIMAG(cy - cz)
+ if( syz .eq. 0 ) syz = signy
+
+ c1yz = 1/(cy - cz)
+
+ sab1 = DIMAG(-cz*c1yz)
+ if( sab1 .eq. 0 ) then
+ sab1 = DBLE(cz)*signy
+c if( sab1 .eq. 0 ) call ffwarn(256, ier, 1D0, 0D0)
+* this step: not checked but same as below
+* choose +signy since this ieps is relevant if cza in (0,1)
+ if( sab1 .eq. 0 ) sab1 = signy
+ endif
+
+ sab2 = DIMAG((1 - cz)*c1yz)
+ if( sab2 .eq. 0 ) then
+ sab2 = -DBLE(1 - cz)*signy
+c if( sab2 .eq. 0 ) call ffwarn(257, ier, 1D0, 0D0)
+* this step: checked and worked
+* choose -signy since this ieps is relevant if cza in (0,1)
+ if( sab2 .eq. 0 ) sab2 = -signy
+ endif
+
+* calculate R-func from Sp-func
+* def: R(y0, y1) =
+* Sp(y0/(y0-y1)) + ln(y0/(y0-y1))*eta(-y1,1/(y0-y1)) -
+* Sp((y0-1)/(y0-y1)) - ln((y0-1)/(y0-y1))*eta(1-y1,1/(y0-y1))
+
+* calculate the two dilogs
+* calls "ffzzdl(zdilog,ipi12,zlog,cx,ier)" in "ffcli2.F" or Li2C(z)
+
+ cab1 = cy*c1yz
+ if( DIMAG(cab1) .eq. 0 .and. DBLE(cab1) .ge. 1 ) then
+ call ffzzdl(c1, n, dummy, 1/cab1, ier)
+ c1 = -c1 - n*pi12 - pi6 -
+ & .5D0*zfflog(-cab1, 1, DCMPLX(sab1), ier)**2
+ else
+ call ffzzdl(c1, n, dummy, cab1, ier)
+ c1 = c1 + n*pi12
+ endif
+
+ cab2 = (cy - 1)*c1yz
+ if( DIMAG(cab2) .eq. 0 .and. DBLE(cab2) .ge. 1 ) then
+ call ffzzdl(c2, n, dummy, 1/cab2, ier)
+ c2 = -c2 - n*pi12 - pi6 -
+ & .5D0*zfflog(-cab2, 1, DCMPLX(sab2), ier)**2
+ else
+ call ffzzdl(c2, n, dummy, cab2, ier)
+ c2 = c2 + n*pi12
+ endif
+
+* calculate the two logs
+* ieps=1 to choose the cut along the real axis,
+
+ n = nffet1(DCMPLX(0D0, -sz), DCMPLX(0D0, -syz),
+ & DCMPLX(0D0, sab1), ier)
+ if( n .ne. 0 )
+ & c1 = c1 + n*c2ipi*zfflog(cab1, 1, DCMPLX(-sab1), ier)
+
+ n = nffet1(DCMPLX(0D0, -sz), DCMPLX(0D0, -syz),
+ & DCMPLX(0D0, sab2), ier)
+ if( n .ne. 0 )
+ & c2 = c2 + n*c2ipi*zfflog(cab2, 1, DCMPLX(-sab2), ier)
+
+ ffRn = c1 - c2 +
+ & zfflog((cy - 1)/cy, 1, DCMPLX(signy), ier)*
+ & zfflog(cy - cz, 1, DCMPLX(signy), ier)
+ end
diff --git a/Looptools/D/ffS2.F b/Looptools/D/ffS2.F
new file mode 100644
--- /dev/null
+++ b/Looptools/D/ffS2.F
@@ -0,0 +1,130 @@
+* ffS2.F
+* calculate S2 = \int_0^1 dy ln(a y^2 + b y + c),
+* where a is real and can be zero; b and c complex
+* input: ra=a (real), cb=b, cc=c
+* signc=sign(img(c)) in case c is real.
+* cza and czb are the 2 roots of: a y^2 + b y + c == 0
+* remarks: ieps is needed for cza, czb.
+* this file is part of LoopTools
+* last modified 8 Dec 10 th
+
+* Written by Le Duc Ninh, MPI, Munich (2008).
+* Spence, log and eta functions are taken from FF.
+* Oct 28 2008
+
+#include "externals.h"
+
+
+ double complex function ffS2(ra, cb, cc, signc, ier)
+ implicit none
+ double precision ra, signc
+ double complex cb, cc
+ integer ier
+
+#include "ff.h"
+
+ double complex crdisc, cza, czb
+ double precision sza, szb, sy1, sy2, sc
+
+ double complex ffS2_linr, zfflog
+ integer nffet1
+ external ffS2_linr, zfflog, nffet1
+
+ sc = DIMAG(cc)
+ if( sc .eq. 0 ) sc = signc
+
+ if( abs(ra) .lt. precx ) then
+ if( abs(cb) .lt. precx ) then
+* 0 roots:
+ if( abs(cc) .lt. precx ) then
+ call fferr(89, ier)
+ ffS2 = 0
+ return
+ endif
+ ffS2 = zfflog(cc, 1, DCMPLX(signc), ier)
+ return
+ endif
+
+* 1 root:
+ cza = -cc/cb
+ sza = -signc*DBLE(cb)
+ if( sza .eq. 0 ) sza = -signc
+
+ ffS2 = zfflog(cb, 1, DCMPLX(sc), ier) +
+ & ffS2_linr(cza, sza, ier)
+
+ if( abs(DIMAG(cb)) .lt. precx ) return
+
+* complex b
+ szb = DIMAG(cza)
+ if( szb .eq. 0 ) szb = sza
+
+ ffS2 = ffS2 +
+ & c2ipi*nffet1(cb, DCMPLX(0D0, -szb), DCMPLX(0D0, sc), ier)
+ return
+ endif
+
+* 2 roots: cza = y1, czb = y2
+* eq.: y**2 + (b/a) y + (c/a) = 0
+* the ieps is irrelevant here since we take into account
+* the contributions of both roots
+
+*** Ninh changed: 14 Aug 2009
+ crdisc = sqrt(cb**2/ra**2 - 4*cc/ra)
+ cza = -.5D0*(cb/ra + crdisc)
+ czb = -.5D0*(cb/ra - crdisc)
+ if( abs(cza) .gt. abs(czb) ) then
+ czb = cc/(ra*cza)
+ else
+ cza = cc/(ra*czb)
+ endif
+
+* calculate the sign of im(cza) and im(czb) which are related to ieps
+ sza = signc/ra
+ if( abs(DBLE(crdisc)) .gt. precx ) sza = sza/DBLE(crdisc)
+ szb = -sza
+
+ sy1 = DIMAG(cza)
+ if( sy1 .eq. 0 ) sy1 = sza
+ sy2 = DIMAG(czb)
+ if( sy2 .eq. 0 ) sy2 = szb
+
+* calculate the log and etas
+* ieps=1 to choose the cut along the real axis
+
+ ffS2 =
+ & zfflog(DCMPLX(ra), 1, DCMPLX(sc), ier) +
+ & c2ipi*nffet1(DCMPLX(0D0, -sy1), DCMPLX(0D0, -sy2),
+ & DCMPLX(0D0, sc/ra), ier) +
+ & ffS2_linr(cza, sza, ier) +
+ & ffS2_linr(czb, szb, ier)
+ end
+
+************************************************************************
+* calculate S2 = \int_0^1 dy ln(y - z),
+* where z is complex
+* input: cz, signz = sign(im(z)) in case z is real.
+* remarks: ieps is needed.
+
+ double complex function ffS2_linr(cz, signz, ier)
+ implicit none
+ double complex cz
+ double precision signz
+ integer ier
+
+#include "ff.h"
+
+ double complex zfflog
+ external zfflog
+
+ if( abs(cz) .lt. precx ) then
+ ffS2_linr = -1
+ else if( abs(cz - 1) .lt. precx ) then
+ ffS2_linr = zfflog(-cz, 1, DCMPLX(-signz), ier) - 1
+ else
+ ffS2_linr =
+ & zfflog(1 - cz, 1, DCMPLX(-signz), ier)*(1 - cz) +
+ & zfflog(-cz, 1, DCMPLX(-signz), ier)*cz - 1
+ endif
+ end
+
diff --git a/Looptools/D/ffS3n.F b/Looptools/D/ffS3n.F
new file mode 100644
--- /dev/null
+++ b/Looptools/D/ffS3n.F
@@ -0,0 +1,111 @@
+* ffS3n.F
+* calculate S3n = \int_0^1 dy (ra y^2 + cb y + cc + I signc)/(y - cy)
+* where ra can be zero.
+* input: cy=y0, ra=a (real), cb=b, cc=c
+* signc=sign(im(c)), signy=sign(im(cy)) in case they are real.
+* cza and czb are the 2 roots of: a y^2 + b y + c == 0
+* remarks: ieps is needed for cza, czb and y0.
+* this file is part of LoopTools
+* last modified 8 Dec 10 th
+
+* Written by Le Duc Ninh, MPI, Munich (2008).
+* Spence, log and eta functions are taken from FF.
+* Oct 27 2008
+
+#include "externals.h"
+
+
+ double complex function ffS3n(cy, signy, ra, cb, cc, signc,
+ & ier)
+ implicit none
+ double precision ra, signy, signc
+ double complex cy, cb, cc
+ integer ier
+
+#include "ff.h"
+
+ double complex cl, crdisc, cza, czb
+ double precision sza, szb, sy1, sy2, sc
+
+ double complex ffRn, zfflog
+ integer nffet1
+ external ffRn, zfflog, nffet1
+
+* check for end-point sing.
+ if( abs(cy) .lt. precx .or. abs(cy - 1) .lt. precx ) then
+ call fferr(90, ier)
+ ffS3n = 0
+ return
+ endif
+
+ cl = zfflog((cy - 1)/cy, 1, DCMPLX(signy), ier)
+
+ sc = DIMAG(cc)
+ if( sc .eq. 0 ) sc = signc
+
+ if( abs(ra) .lt. precx ) then
+ if( abs(cb) .lt. precx ) then
+* 0 roots:
+ if( abs(cc) .lt. precx ) then
+ call fferr(91, ier)
+ ffS3n = 0
+ return
+ endif
+ ffS3n = cl*zfflog(cc, 1, DCMPLX(signc), ier)
+ return
+ endif
+
+* 1 root:
+* eq.: b y + c == 0
+ cza = -cc/cb
+ sza = -signc*DBLE(cb)
+ if( sza .eq. 0 ) sza = -signc
+
+ ffS3n = cl*zfflog(cb, 1, DCMPLX(signc), ier) +
+ & ffRn(cy, signy, cza, sza, ier)
+
+ if( abs(DIMAG(cb)) .gt. precx ) then
+ szb = DIMAG(cza)
+ if( szb .eq. 0 ) szb = sza
+ ffS3n = ffS3n + cl*c2ipi*
+ & nffet1(cb, DCMPLX(0D0, -szb), DCMPLX(0D0, sc), ier)
+ endif
+ return
+ endif
+
+* 2 roots: cza = y1, czb = y2
+* eq.: y**2 + (b/a) y + (c/a) = 0
+* the ieps is irrelevant here since we take into account
+* the contributions of both roots
+
+*** Ninh changed: 14 Aug 2009
+ crdisc = sqrt(cb**2/ra**2 - 4*cc/ra)
+ cza = -.5D0*(cb/ra + crdisc)
+ czb = -.5D0*(cb/ra - crdisc)
+ if( abs(cza) .gt. abs(czb) ) then
+ czb = cc/(ra*cza)
+ else if( abs(czb) .gt. 1D-13 ) then
+ cza = cc/(ra*czb)
+ endif
+
+* calculate the sign of im(cza) and im(czb) which are related to ieps
+ sza = sc/ra
+ if( abs(DBLE(crdisc)) .gt. precx ) sza = sza/DBLE(crdisc)
+ szb = -sza
+
+ sy1 = DIMAG(cza)
+ if( sy1 .eq. 0 ) sy1 = sza
+ sy2 = DIMAG(czb)
+ if( sy2 .eq. 0 ) sy2 = szb
+
+* calculate the log, etas, and the 2 R-functions
+* ieps=1 to choose the cut along the real axis
+
+ ffS3n =
+ & cl*( zfflog(DCMPLX(ra), 1, DCMPLX(sc), ier) +
+ & c2ipi*nffet1(DCMPLX(0D0, -sy1), DCMPLX(0D0, -sy2),
+ & DCMPLX(0D0, sc/ra), ier) ) +
+ & ffRn(cy, signy, cza, sza, ier) +
+ & ffRn(cy, signy, czb, szb, ier)
+ end
+
diff --git a/Looptools/D/ffT13.F b/Looptools/D/ffT13.F
new file mode 100644
--- /dev/null
+++ b/Looptools/D/ffT13.F
@@ -0,0 +1,125 @@
+* ffT13.F
+* part of the complex four-point function
+* this file is part of LoopTools
+* last modified 8 Dec 10 th
+
+#include "externals.h"
+
+
+* T13 = \int_0^1 dx \int_0^x dy
+* y/( (rg y^2 + rh xy + cd x + cj y + cf + I signf) *
+* (ra y^2 + rc xy + cd x + ce y + cf + I signf) )
+* with signf = -eps
+* variables "signX" is the sign of im(X) in case X becomes real.
+* No extra term is needed.
+* Nov 11 2008
+
+ double complex function ffT13(ra, rc, rg, rh,
+ & cd, ce, cf, signf, cj, ier)
+ implicit none
+ double precision ra, rc, rg, rh, signf
+ double complex cd, ce, cf, cj
+ integer ier
+
+#include "ff.h"
+
+ double complex ck, cl, cn, cy(2), crdetq4
+ double complex cbj(4), ccj(4)
+ double complex ffS3nAll1, ffS3nAll2
+ double precision sn, scj, sy(2), raj(4)
+
+ double complex ffS2, ffS3n
+ external ffS2, ffS3n
+
+* the coefficients of the 4 log arguments
+ raj(1) = ra
+ raj(2) = rg
+ raj(3) = rg + rh
+ raj(4) = ra + rc
+
+ cbj(1) = ce + rc
+ cbj(2) = cj + rh
+ cbj(3) = cd + cj
+ cbj(4) = ce + cd
+
+ ccj(1) = cf + cd
+ ccj(2) = cf + cd
+ ccj(3) = cf
+ ccj(4) = cf
+
+* the ieps is the same for all
+ scj = signf
+
+* the prefactor 1/(S V - T U)
+* eq. (S V - T U) = K y^2 + L y + N == 0
+* Leading Landau singularity can occur if y1 = y2 and eps -> 0
+* the ieps is needed for the roots
+
+ ck = rh*ra - rc*rg
+ cl = (ra - rg)*cd + rh*ce - rc*cj
+ cn = (rh - rc)*cf + cd*(ce - cj)
+* the ieps for cn
+ sn = signf*(rh - rc)
+* if (rh - rc) = 0 then we are at the boundary of phase space
+* and sn is irrelevant
+
+ if( abs(ck) .lt. precx ) then
+ if( abs(cl) .lt. precx ) then
+ if( abs(cn) .lt. precx ) then
+ call fferr(99, ier)
+ ffT13 = 0
+ return
+ endif
+* the case ny = 0, (SV - TU) = N = constant
+* no extra term is needed
+ ffT13 = -1/cn*(
+ & ffS2(raj(1), cbj(1), ccj(1), scj, ier) -
+ & ffS2(raj(2), cbj(2), ccj(2), scj, ier) +
+ & ffS2(raj(3), cbj(3), ccj(3), scj, ier) -
+ & ffS2(raj(4), cbj(4), ccj(4), scj, ier) )
+ return
+ endif
+
+* the case ny = 1, (S V - T U) = L y + N
+ cy(1) = -cn/cl
+* ieps for this root
+ sy(1) = -sn*DBLE(cl)
+ if( sy(1) .eq. 0 ) sy(1) = signf
+
+ ffS3nAll1 =
+ & ffS3n(cy(1), sy(1), raj(1), cbj(1), ccj(1), scj, ier) -
+ & ffS3n(cy(1), sy(1), raj(2), cbj(2), ccj(2), scj, ier) +
+ & ffS3n(cy(1), sy(1), raj(3), cbj(3), ccj(3), scj, ier) -
+ & ffS3n(cy(1), sy(1), raj(4), cbj(4), ccj(4), scj, ier)
+ ffT13 = -ffS3nAll1/cl
+ return
+ endif
+
+* the case ny = 2, (SV - TU) = K y^2 + L y + N
+ crdetq4 = sqrt(cl**2 - 4*ck*cn)
+ cy(1) = -.5D0/ck*(cl + crdetq4)
+ cy(2) = -.5D0/ck*(cl - crdetq4)
+ if( abs(cy(1)) .gt. abs(cy(2)) ) then
+ cy(2) = cn/(ck*cy(1))
+ else
+ cy(1) = cn/(ck*cy(2))
+ endif
+
+* calculate the signs of img(cy1) and img(cy2) which are related to ieps
+ sy(1) = sn*DBLE(crdetq4)
+ if( sy(1) .eq. 0 ) sy(1) = signf
+ sy(2) = -sy(1)
+
+ ffS3nAll1 =
+ & ffS3n(cy(1), sy(1), raj(1), cbj(1), ccj(1), scj, ier) -
+ & ffS3n(cy(1), sy(1), raj(2), cbj(2), ccj(2), scj, ier) +
+ & ffS3n(cy(1), sy(1), raj(3), cbj(3), ccj(3), scj, ier) -
+ & ffS3n(cy(1), sy(1), raj(4), cbj(4), ccj(4), scj, ier)
+ ffS3nAll2 =
+ & ffS3n(cy(2), sy(2), raj(1), cbj(1), ccj(1), scj, ier) -
+ & ffS3n(cy(2), sy(2), raj(2), cbj(2), ccj(2), scj, ier) +
+ & ffS3n(cy(2), sy(2), raj(3), cbj(3), ccj(3), scj, ier) -
+ & ffS3n(cy(2), sy(2), raj(4), cbj(4), ccj(4), scj, ier)
+ ffT13 = (ffS3nAll1 - ffS3nAll2)/crdetq4
+ end
+
diff --git a/Looptools/D/ffTn.F b/Looptools/D/ffTn.F
new file mode 100644
--- /dev/null
+++ b/Looptools/D/ffTn.F
@@ -0,0 +1,467 @@
+* ffTn.F
+* calculate T(ra, rb, rc, rg, rh; cd, ce, cf, cj) defined as:
+* T = \int_0^1 dx \int_0^x dy
+* 1/((rg x + rh y + cj)
+* (ra x^2 + rb y^2 + rc x y + cd x + ce y + cf + I signf))
+* with signf = -eps,
+* {ra,rb,rc,rg,rh} are real, {cd,ce,cf,cj} are complex.
+* important: variables "signX" is the sign of im(X) in case X becomes real.
+* this file is part of LoopTools
+* last modified 8 Dec 10 th
+
+* Written by Le Duc Ninh, MPI, Munich (2008).
+* Spence, log and eta functions are taken from FF.
+* Oct 27 2008
+
+#include "defs.h"
+
+
+ double complex function ffTn(ra, rb, rc, rgx, rhx,
+ & cd, ce, cf, signf, cjx, signj, key, ier)
+ implicit none
+ double precision ra, rb, rc, rgx, rhx, signf, signj
+ double complex cd, ce, cf, cjx
+ integer key, ier
+
+#include "ff.h"
+
+ double complex cj, crdetq4, crdetq42, cy(2), cy2(2)
+ double complex crdisc, cbeta1, cbeta2, cbeta
+ double complex ctv, ctemp, cresd, cyij
+ double complex cbj(6), ccj(6), cbk(6), cck(6)
+ double precision rg, rh, reps
+ double precision sj, scj, sy(2), sy2(2), stv, syij
+ double precision rminuv, rminuv2, raj(6)
+ integer i, j, ny, ny2, chketa(2), chketa2(2)
+
+ double complex ffT_lin, ffS2, ffS3n, zfflog
+ integer nffet1
+ external ffT_lin, ffS2, ffS3n, zfflog, nffet1
+
+ ier = 0
+
+* calculate ieps and the sign of im(J)
+ reps = DIMAG(cf)
+ if( reps .eq. 0 ) reps = signf
+ reps = sign(1D0, -reps)
+
+ sj = DIMAG(cjx)
+ if( sj .eq. 0 ) sj = signj
+ sj = sign(1D0, sj*reps)
+
+* change the sign of G,H,J
+* sj = 1 or -1
+ rg = -sj*rgx
+ rh = -sj*rhx
+ cj = -sj*cjx
+
+ if( abs(rb) .lt. precx ) then
+ ffTn = sj*ffT_lin(ra, rc, rg, rh, cd, ce, cf, cj,
+ & signf, reps, ier)
+ return
+ endif
+
+ if( abs(ra) .lt. precx ) then
+* change the integration variables to get rb = 0 as above
+ ffTn = sj*ffT_lin(rb + rc, -rc, -rg - rh, rg,
+ & -2*(rb + rc) - cd - ce,
+ & rc + cd,
+ & rb + rc + cd + ce + cf,
+ & rg + rh + cj,
+ & signf, reps, ier)
+ return
+ endif
+
+* calculate beta
+* beta is one root of: B beta^2 + C beta + A = 0
+* we do not need the ieps for beta
+ crdisc = sqrt(DCMPLX(rc**2 - 4*rb*ra))
+ cbeta1 = -.5D0/rb*(rc + crdisc)
+ cbeta2 = -.5D0/rb*(rc - crdisc)
+ if( abs(cbeta1) .gt. abs(cbeta2) ) then
+ cbeta2 = ra/(rb*cbeta1)
+ else
+ cbeta1 = cbeta2
+ cbeta2 = ra/(rb*cbeta2)
+ endif
+
+* Ninh added: 14 Aug 2009
+* be careful with this approximation, IMG can be wrong
+ if( abs(1 - cbeta1) .lt. precx ) cbeta1 = 1
+ if( abs(1 - cbeta2) .lt. precx ) cbeta2 = 1
+* which one for beta?
+ if( abs(cbeta1) .gt. abs(cbeta2) ) then
+ ctemp = cbeta1
+ cbeta1 = cbeta2
+ cbeta2 = ctemp
+ endif
+
+* look at the prefactor 1/(S V - T U)
+* eq. (S V - T U) = K y^2 + L y + N == 0
+* to decide which beta is the best.
+* The two roots are calculated.
+* Leading Landau Sing. can occur if y1 = y2 and eps -> 0
+* the ieps is needed for the roots
+
+ cbeta = cbeta1
+ if( abs(cbeta2 - 1) .lt. precx ) then
+ cbeta = cbeta2
+ cbeta2 = cbeta1
+ endif
+
+ call ffwbeta(rb, rc, rg, rh, cd, ce, cf, cj, signf,
+ & cbeta, crdetq4, ny, cy, sy, chketa, rminuv, key, ier)
+
+* to check whether there is numerical cancellation
+* at the border of the triangle
+ if( rminuv .lt. 1D-10 ) then
+ call ffwbeta(rb, rc, rg, rh, cd, ce, cf, cj, signf,
+ & cbeta2, crdetq42, ny2, cy2, sy2, chketa2, rminuv2,
+ & key, ier)
+ if( rminuv2 .lt. rminuv ) then
+ call ffwarn(254, ier, 1D0, 0D0)
+ else
+* choose the beta2-parameters
+ cbeta = cbeta2
+ crdetq4 = crdetq42
+ ny = ny2
+ do i = 1, ny
+ sy(i) = sy2(i)
+ cy(i) = cy2(i)
+ chketa(i) = chketa2(i)
+ enddo
+ endif
+ endif
+
+* the coefficients of the 6 log arguments
+ raj(1) = 0
+ raj(2) = 0
+ raj(3) = 0
+ raj(4) = rb
+ raj(5) = ra + rb + rc
+ raj(6) = ra
+
+ cbj(1) = rh
+ cbj(2) = rg + rh
+ cbj(3) = rg
+ cbj(4) = rc + ce
+ cbj(5) = ce + cd
+ cbj(6) = cd
+
+ ccj(1) = rg + cj
+ ccj(2) = cj
+ ccj(3) = cj
+ ccj(4) = ra + cd + cf
+ ccj(5) = cf
+ ccj(6) = cf
+
+* the ieps for the log arguments
+ scj = -reps
+
+* the cck(6)-coefficients before the logs
+ cck(1) = 1
+ cck(2) = -1 + cbeta
+ cck(3) = -cbeta
+ cck(4) = -1
+ cck(5) = 1 - cbeta
+ cck(6) = cbeta
+
+ if( ny .eq. 0 ) then
+* no extra term is needed
+ ffTn = -sj/crdetq4*(
+ & cck(1)*ffS2(raj(1), cbj(1), ccj(1), scj, ier) +
+ & cck(2)*ffS2(raj(2), cbj(2), ccj(2), scj, ier) +
+ & cck(3)*ffS2(raj(3), cbj(3), ccj(3), scj, ier) +
+ & cck(4)*ffS2(raj(4), cbj(4), ccj(4), scj, ier) +
+ & cck(5)*ffS2(raj(5), cbj(5), ccj(5), scj, ier) +
+ & cck(6)*ffS2(raj(6), cbj(6), ccj(6), scj, ier) )
+ return
+ endif
+
+* cbk(6)-coefficients of cj/(aj y - bj - yi)
+ cbk(1) = cbeta
+ cbk(2) = 0
+ cbk(3) = 0
+ cbk(4) = cbeta
+ cbk(5) = 0
+ cbk(6) = 0
+
+ ffTn = 0
+ do i = 1, ny
+ cresd = 0
+ if( chketa(i) .ne. 0 ) then
+* extra term needed
+* calculate the residue
+
+* the denominator was checked above in ffS3n therefore the (V/T)_pole
+* should be safe now:
+ ctv = (rh*cy(i) + cj)/(cy(i)*(rb*cy(i) + ce) + cf)
+ ctemp = (rg + cbeta*rh)/
+ & ((rc + 2*cbeta*rb)*cy(i) + cd + ce*cbeta)
+ if( abs(DIMAG(ctemp)) .gt. abs(DIMAG(ctv)) ) ctv = ctemp
+
+* if im(ctv) = 0 then take the ieps from T/V
+ stv = -signf*DBLE(rh*cy(i) + cj)
+ if( stv .eq. 0 ) stv = -signf
+
+ ctv = zfflog(ctv, 1, DCMPLX(stv), ier)
+ if( abs(ctv) .gt. precx ) then
+ do j = 1, 3
+ if( abs(cck(j)) .gt. precx ) then
+ cyij = -Sgn(j)*(cy(i) + cbk(j))/cck(j)
+ syij = -Sgn(j)*sy(i)*DBLE(cck(j))
+ if( syij .eq. 0 ) syij = sy(i)
+ cresd = cresd - Sgn(i+j)*
+ & zfflog((cyij - 1)/cyij, 1, DCMPLX(syij), ier)
+ endif
+ enddo
+ cresd = cresd*ctv
+ endif
+ endif
+
+* calculate the main part
+ do j = 1, 6
+ if( abs(cck(j)) .gt. precx ) then
+ cyij = -Sgn(j)*(cy(i) + cbk(j))/cck(j)
+ syij = -Sgn(j)*sy(i)*DBLE(cck(j))
+ if( syij .eq. 0 ) syij = sy(i)
+ cresd = cresd + Sgn(i+j)*
+ & ffS3n(cyij, syij, raj(j), cbj(j), ccj(j), scj, ier)
+ endif
+ enddo
+ ffTn = ffTn + cresd
+ enddo
+
+* the prefactor of Landau det.
+ ffTn = sj/crdetq4*ffTn
+ end
+
+************************************************************************
+* calculate the roots of the eq. ck x^2 + cl x + cn = 0
+* and check if the roots are inside the triangle [0, -cbeta, 1 - cbeta]
+* the ieps part for the roots is needed.
+* Nov 17 2008
+
+* input: rb, rc, rg, rh, cd, ce, cf, cj, signf, cbeta
+* output: ru, rv, ny, cy, signy, ck, cl, cn
+
+ subroutine ffwbeta(rb, rc, rg, rh, cd, ce, cf, cj, signf,
+ & cbeta, crdetq4, ny, cy, signy, chketa, rminuv, key, ier)
+ implicit none
+ double precision rb, rc, rg, rh, signf, signy(2), rminuv
+ double complex cd, ce, cf, cj, cbeta, cy(2), crdetq4
+ integer ny, chketa(2), key, ier
+
+#include "lt.h"
+
+ double complex ck, cl, cn
+ double complex cab, cac, cay
+ double precision dotyc, dotyb, dotbc, dotbb, dotcc
+ double precision sn, ru, rv, abc2
+ integer i
+
+ chketa(1) = 0
+ chketa(2) = 0
+ rminuv = 1D300
+
+ ck = rb*rg - rh*(rc + cbeta*rb)
+ cl = rg*ce - rh*cd - cj*(rc + 2*rb*cbeta)
+ cn = (rg + rh*cbeta)*cf - cj*(cd + ce*cbeta)
+
+* the ieps for cn
+ sn = signf*DBLE(rg + rh*cbeta)
+ if( sn .eq. 0 ) sn = signf
+
+ if( abs(ck) .lt. precx ) then
+ if( abs(cl) .lt. precx ) then
+* the case ny = 0, (S V - T U) = N = constant
+ if( abs(cn) .lt. precx ) then
+ call fferr(104, ier)
+ cbeta = 0
+ return
+ endif
+ ny = 0
+ crdetq4 = cn
+ else
+* the case ny = 1, (S V - T U) = L y + N
+ ny = 1
+
+ cy(1) = -cn/cl
+* ieps for this pole
+ signy(1) = -sn*DBLE(cl)
+ if( signy(1) .eq. 0 ) signy(1) = signf
+
+ crdetq4 = cl
+ endif
+ else
+* the case ny = 2, (S V - T U) = K y^2 + L y + N
+ ny = 2
+
+ crdetq4 = sqrt(cl**2 - 4*ck*cn)
+ cy(1) = -.5D0/ck*(cl + crdetq4)
+ cy(2) = -.5D0/ck*(cl - crdetq4)
+ if( abs(cy(1)) .gt. abs(cy(2)) ) then
+ cy(2) = cn/(ck*cy(1))
+ else
+ cy(1) = cn/(ck*cy(2))
+ endif
+
+* calculate the sign of img(cy1) and img(cy2) which are related to ieps
+ signy(1) = sn*DBLE(crdetq4)
+ if( signy(1) .eq. 0 ) signy(1) = signf
+ signy(2) = -signy(1)
+ endif
+
+ if( ny .eq. 0 .or. abs(DIMAG(cbeta)) .lt. precx ) return
+
+ if( key .eq. 1 ) then
+ chketa(1) = 1
+ chketa(2) = 1
+ else
+* check if the poles are inside the triangle [0, -cbeta, 1 - cbeta]
+* using the barycentric technique
+
+ abc2 = 1/DIMAG(cbeta)**2
+
+ do i = 1, ny
+ cay = cy(i) + cbeta
+ cac = cbeta
+ cab = 1
+
+ dotyc = DBLE(cay)*DBLE(cac) + DIMAG(cay)*DIMAG(cac)
+ dotyb = DBLE(cay)*DBLE(cab) + DIMAG(cay)*DIMAG(cab)
+ dotbc = DBLE(cab)*DBLE(cac) + DIMAG(cab)*DIMAG(cac)
+ dotcc = DBLE(cac)*DBLE(cac) + DIMAG(cac)*DIMAG(cac)
+ dotbb = 1
+
+ ru = (dotyc*dotbb - dotbc*dotyb)*abc2
+ rv = (dotcc*dotyb - dotyc*dotbc)*abc2
+ if( ru .ge. 0 .and. rv .ge. 0 .and. ru + rv .le. 1 )
+ & chketa(i) = 1
+ rminuv = min(rminuv, abs(ru), abs(rv))
+ enddo
+ endif
+ end
+
+************************************************************************
+* calculate T(ra, rc, rg, rh; cd, ce, cf, cj) defined as:
+* T = \int_0^1 dx \int_0^x dy
+* 1/( (rg x + rh y + cj)
+* (ra x^2 + rc x y + cd x + ce y + cf + I signf) )
+* with signf = -eps,
+* {ra, rc, rg, rh} are real, {cd, ce, cf, cj} are complex.
+* important: variables "signX" is the sign of img(X) in case X becomes real.
+* No extra term is needed.
+
+* Written by Le Duc Ninh, MPI, Munich (2008).
+* Spence, log and eta functions are taken from FF.
+* Nov 10 2008
+
+ double complex function ffT_lin(ra, rc, rg, rh,
+ & cd, ce, cf, cj, signf, reps, ier)
+ implicit none
+ double precision ra, rc, rg, rh, signf, reps
+ double complex cd, ce, cf, cj
+ integer ier
+
+#include "ff.h"
+
+ double complex ck, cl, cn, cy(2), crdetq4
+ double complex cbj(4), ccj(4)
+ double complex ffS3nAll1, ffS3nAll2
+ double precision sn, scj, sy(2), raj(4)
+
+ double complex ffS2, ffS3n
+ external ffS2, ffS3n
+
+* the coefficients of the 4 log arguments
+ raj(1) = rc + ra
+ raj(2) = 0
+ raj(3) = 0
+ raj(4) = ra
+
+ cbj(1) = ce + cd
+ cbj(2) = rh + rg
+ cbj(3) = rg
+ cbj(4) = cd
+
+ ccj(1) = cf
+ ccj(2) = cj
+ ccj(3) = cj
+ ccj(4) = cf
+
+* the ieps is the same for all
+ scj = -reps
+
+* the prefactor 1/(S V - T U)
+* eq. (S V - T U) = K y^2 + L y + N = 0
+* Leading Landau Sing. can occur if y1 == y2 and eps -> 0
+* the ieps is needed for the roots
+
+ ck = rh*ra - rc*rg
+ cl = rh*cd - rc*cj - ce*rg
+ cn = rh*cf - ce*cj
+
+* the ieps for cn
+ sn = -reps*rh
+ if( sn .eq. 0 ) sn = -reps
+
+ if( abs(ck) .lt. precx ) then
+ if( abs(cl) .lt. precx ) then
+ if( abs(cn) .lt. precx ) then
+ call fferr(105, ier)
+ ffT_lin = 0
+ return
+ endif
+* the case ny = 0, (S V - T U) = N = constant
+ ffT_lin = 1/cn*(
+ & ffS2(raj(1), cbj(1), ccj(1), scj, ier) -
+ & ffS2(raj(2), cbj(2), ccj(2), scj, ier) +
+ & ffS2(raj(3), cbj(3), ccj(3), scj, ier) -
+ & ffS2(raj(4), cbj(4), ccj(4), scj, ier) )
+ return
+ endif
+
+* the case ny = 1, (S V - T U) = L y + N
+ cy(1) = -cn/cl
+* ieps for this pole
+ sy(1) = -sn*DBLE(cl)
+ if( sy(1) .eq. 0 ) sy(1) = signf
+
+ ffS3nAll1 =
+ & ffS3n(cy(1), sy(1), raj(1), cbj(1), ccj(1), scj, ier) -
+ & ffS3n(cy(1), sy(1), raj(2), cbj(2), ccj(2), scj, ier) +
+ & ffS3n(cy(1), sy(1), raj(3), cbj(3), ccj(3), scj, ier) -
+ & ffS3n(cy(1), sy(1), raj(4), cbj(4), ccj(4), scj, ier)
+ ffT_lin = -ffS3nAll1/cl
+ return
+ endif
+
+* the case ny = 2, (S V - T U) = K y^2 + L y + N
+ crdetq4 = sqrt(cl**2 - 4*ck*cn)
+ cy(1) = -.5D0/ck*(cl + crdetq4)
+ cy(2) = -.5D0/ck*(cl - crdetq4)
+ if( abs(cy(1)) .gt. abs(cy(2)) ) then
+ cy(2) = cn/(ck*cy(1))
+ else
+ cy(1) = cn/(ck*cy(2))
+ endif
+
+* calculate the sign of im(cy1) and im(cy2) which are related to ieps
+ sy(1) = sn*DBLE(crdetq4)
+ if( sy(1) .eq. 0 ) sy(1) = signf
+ sy(2) = -sy(1)
+
+ ffS3nAll1 =
+ & ffS3n(cy(1), sy(1), raj(1), cbj(1), ccj(1), scj, ier) -
+ & ffS3n(cy(1), sy(1), raj(2), cbj(2), ccj(2), scj, ier) +
+ & ffS3n(cy(1), sy(1), raj(3), cbj(3), ccj(3), scj, ier) -
+ & ffS3n(cy(1), sy(1), raj(4), cbj(4), ccj(4), scj, ier)
+ ffS3nAll2 =
+ & ffS3n(cy(2), sy(2), raj(1), cbj(1), ccj(1), scj, ier) -
+ & ffS3n(cy(2), sy(2), raj(2), cbj(2), ccj(2), scj, ier) +
+ & ffS3n(cy(2), sy(2), raj(3), cbj(3), ccj(3), scj, ier) -
+ & ffS3n(cy(2), sy(2), raj(4), cbj(4), ccj(4), scj, ier)
+ ffT_lin = (ffS3nAll2 - ffS3nAll1)/crdetq4
+ end
+
diff --git a/Looptools/D/ffd0c.F b/Looptools/D/ffd0c.F
new file mode 100644
--- /dev/null
+++ b/Looptools/D/ffd0c.F
@@ -0,0 +1,190 @@
+* ffd0c.F
+* the scalar four-point function with complex masses
+* this file is part of LoopTools
+* last modified 8 Dec 10 th
+
+* Written by Le Duc Ninh, MPI, Munich (2008).
+* Spence, log and eta functions are taken from FF.
+* Please cite arXiV:0902.0325 [hep-ph] if you use this function.
+
+#include "externals.h"
+
+
+ subroutine ffd0c(cd0c, cpi, key, ier)
+ implicit none
+ double complex cd0c, cpi(10)
+ integer key, ier
+
+#include "ff.h"
+
+ integer o
+ double precision ra, rb, rg, rc, rh, rj
+ double precision d, a
+ double complex cd, ce, ck, cfx
+
+ double precision signf
+ parameter (signf = -1)
+
+ double complex ffT13, ffTn
+ external ffT13, ffTn
+
+#define PP(i) DBLE(cpi(i+4))
+#define LightLike(i) abs(PP(i)) .lt. precx
+
+* 2 lightlike momenta
+
+ if( LightLike(1) .and.
+ & LightLike(3) ) then
+ o = O'1234561234'
+ else if( LightLike(2) .and.
+ & LightLike(4) ) then
+ o = O'4123654123'
+ else if( LightLike(5) .and.
+ & LightLike(6) ) then
+ o = O'5361421342'
+ else if( LightLike(1) .and.
+ & LightLike(2) ) then
+ o = O'1234561234'
+ else if( LightLike(2) .and.
+ & LightLike(3) ) then
+ o = O'2341652341'
+ else if( LightLike(3) .and.
+ & LightLike(4) ) then
+ o = O'3412563412'
+ else if( LightLike(4) .and.
+ & LightLike(1) ) then
+ o = O'4123654123'
+
+* 1 lightlike momentum
+
+ else if( LightLike(1) ) then
+ o = O'1234561234'
+ else if( LightLike(2) ) then
+ o = O'2341652341'
+ else if( LightLike(3) ) then
+ o = O'3412563412'
+ else if( LightLike(4) ) then
+ o = O'4123654123'
+ else if( LightLike(5) ) then
+c WRONG? 8 Jan 10 th
+c o = O'5361422413'
+ o = O'5361421342'
+ else if( LightLike(6) ) then
+c WRONG? 8 Jan 10 th
+c o = O'6452132431'
+ o = O'6452132413'
+
+* kallen(pi, pj, pk) >= 0
+
+#define SIDE(i,j) PP(i)*(PP(i) - 2*PP(j))
+
+ else if( SIDE(5,1) +
+ & SIDE(1,2) +
+ & SIDE(2,5) .ge. 0 ) then
+ o = O'1234561234'
+ else if( SIDE(6,2) +
+ & SIDE(2,3) +
+ & SIDE(3,6) .ge. 0 ) then
+ o = O'2341652341'
+ else if( SIDE(5,3) +
+ & SIDE(3,4) +
+ & SIDE(4,5) .ge. 0 ) then
+ o = O'3412563412'
+ else if( SIDE(6,4) +
+ & SIDE(4,1) +
+ & SIDE(1,6) .ge. 0 ) then
+ o = O'4123654123'
+
+ else
+ call fferr(103, ier)
+ return
+ endif
+
+#define RP(i) PP(ibits(o,3*(10-i),3))
+#define CM(i) cpi(ibits(o,3*(4-i),3))
+
+ rg = RP(1)
+ rb = RP(2)
+ rj = RP(5) - rb
+ ra = RP(3)
+ rc = RP(6) - ra
+ rh = RP(4) - RP(6)
+ cfx = CM(4)
+ cd = CM(3) - cfx - ra
+ ce = CM(2) - CM(3) - rc
+ ck = CM(1) - CM(2) - rh
+ rc = rc - rb
+ rh = rh - rj
+ rj = rj - rg
+
+* D0C = \int_0^1 dx \int_0^x dy \int_0^y dz
+* 1/(ra x^2 + rb y^2 + rg z^2 + rc xy + rh xz + rj yz +
+* cd x + ce y + ck z + cfx + I signf)
+* with signf = -eps.
+* important: variables "signX" is the sign of img(X) in case X becomes real.
+
+* 2 opposite lightlike momenta
+
+ if( ra .eq. 0 .and. rg .eq. 0 ) then
+ cd0c = ffT13(rb + rj, rc + rh, rb, rc,
+ & cd, ce + ck, cfx, signf, ce, ier)
+ return
+ endif
+
+* 2 adjacent lightlike momenta
+
+ if( rb .eq. 0 .and. rg .eq. 0 ) then
+ cd0c = ffTn(ra, rb, rc, rh, rj,
+ & cd, ce, cfx, signf, ck, signf, key, ier) -
+ & ffTn(ra, rj, rc + rh, rh, rj,
+ & cd, ce + ck, cfx, signf, ck, signf, key, ier)
+ return
+ endif
+
+* 1 lightlike momentum
+
+ if( rg .eq. 0 ) then
+ cd0c = ffTn(ra, rb, rc, rh, rj,
+ & cd, ce, cfx, signf, ck, signf, key, ier) -
+ & ffTn(ra, rj + rb, rc + rh, rh, rj,
+ & cd, ce + ck, cfx, signf, ck, signf, key, ier)
+ return
+ endif
+
+* alpha is one root of: rg*alpha^2 + rj*alpha + rb == 0
+* we do not need the ieps for alpha
+ d = rj**2 - 4*rg*rb
+
+ d = sqrt(d)
+ a = -.5D0/rg*(rj + d)
+ d = -.5D0/rg*(rj - d)
+* choose the bigger root or unity
+ if( abs(a) .gt. abs(d) ) then
+ d = rb/(rg*a)
+ else
+ a = rb/(rg*d)
+ endif
+* which one for alpha?
+ if( abs(d) .lt. abs(a) ) a = d
+
+ cd0c = ffTn(ra + rb + rc, rg, rj + rh,
+ & -rc - 2*rb - (rj + rh)*a, -rj - 2*a*rg,
+ & cd + ce, ck, cfx, signf, -ce - ck*a, -signf, key, ier)
+
+ if( a .ne. 1 ) then
+ d = 1/(1 - a)
+ cd0c = cd0c + ffTn(ra, rg + rj + rb, rc + rh,
+ & d*(rc + rh*a), rj + 2*a*rg,
+ & cd, ce + ck, cfx, signf, d*(ce + ck*a), d*signf, key, ier)
+ endif
+
+ if( abs(a) .lt. precx ) then
+ call ffwarn(253, ier, 1D0, 0D0)
+ else
+ d = 1/a
+ cd0c = cd0c + ffTn(ra, rb, rc,
+ & d*rc + rh, -rj - 2*a*rg,
+ & cd, ce, cfx, signf, d*ce + ck, d*signf, key, ier)
+ endif
+ end
+
diff --git a/Looptools/D/ffdcc0.F b/Looptools/D/ffdcc0.F
new file mode 100644
--- /dev/null
+++ b/Looptools/D/ffdcc0.F
@@ -0,0 +1,319 @@
+#include "externals.h"
+
+
+*###[ ffdcc0:
+ subroutine ffdcc0(cs3,ipi12,isoort,clogi,ilogi,xpi,piDpj,
+ + xqi,qiDqj,sdel2,del2s,etalam,etami,delpsi,alph,
+ + ddel2s,ldel2s,npoin,ier)
+***#[*comment:***********************************************************
+* *
+* Calculates the difference of two threepoint functions *
+* C(3,...a) - C(4,...b) *
+* *
+* Input: xpi(6,3:4) (complex) transformed mi,pi squared in Ci *
+* piDpj(6,6,3:4)(complex) pi(i).pi(j) *
+* xqi(10,10) (complex) transformed mi,pi squared in D *
+* qiDqj(10,10) (complex) qi(i).qi(j) *
+* sdel2 (complex) sqrt(delta_{p_1 p_2}^{p_1 p_2}) *
+* del2s(3,3:4) (complex) delta_{p_i s_i}^{p_i s_i} *
+* etalam(3:4) (complex) delta_{s_1 s_2 s_3}^{s_1 s_2 s_3}
+* /delta_{p_1 p_2}^{p_1 p_2} *
+* etami(6,3:4) (complex) m_i^2 - etalam *
+* ddel2s(2:3) (complex) del2s(i,3) - del2s(i,4) *
+* alph(3) (complex) alph(1)=alpha, alph(3)=1-alpha *
+* *
+* Output: cs3 (complex)(160) C0(3)-C0(4), not yet summed. *
+* ipi12 (integer)(6) factors pi^2/12, not yet summed *
+* slam (complex) lambda(p1,p2,p3). *
+* isoort (integer)(16) indication of he method used *
+* clogi (complex)(6) log(-dyz(2,1,i)/dyz(2,2,i)) *
+* ilogi (integer)(6) factors i*pi in this *
+* ier (integer) 0=ok, 1=inaccurate, 2=error *
+* *
+* Calls: ... *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+*
+* arguments:
+*
+ integer ipi12(16),isoort(16),ilogi(6),npoin,ier
+ logical ldel2s
+ DOUBLE COMPLEX cs3(160),clogi(6)
+ DOUBLE COMPLEX xqi(10),qiDqj(10,10),
+ + xpi(6,3:4),piDpj(6,6,3:4),
+ + sdel2,del2s(3,3:4),etalam(3:4),etami(6,3:4),alph(3),
+ + ddel2s(2:3),delpsi(3,3:4)
+*
+* local variables:
+*
+ integer i,j,k,ip,ii,ifirst,ieri(8)
+ DOUBLE COMPLEX c,cc
+ DOUBLE COMPLEX sdel2i(3,3:4),s(5),som,zfflo1,
+ + y(4,3:4,3),z(4,3:4,3),dyz(2,2,3:4,3),d2yzz(3:4,3),
+ + dyzzy(4,3),dsdel2,dyyzz(2,3)
+ DOUBLE PRECISION smax,absc,xmax
+ DOUBLE COMPLEX zfflog
+ external zfflo1,zfflog
+*
+* common blocks:
+*
+#include "ff.h"
+*
+* statement function
+*
+ absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
+* #] declarations:
+* #[ get y,z-roots:
+ do 20 k=3,4
+ do 10 i=1,3
+*
+* get roots (y,z)
+*
+ ip = i+3
+ sdel2i(i,k) = sqrt(-del2s(i,k))
+* then handle the special case Si = 0
+ if ( xpi(ip,k) .eq. 0 ) then
+ if ( i .eq. 1 .and. alph(3) .eq. 0 .or.
+ + i .eq. 3 .and. alph(1) .eq. 0 ) then
+ isoort(2*i-1+8*(k-3)) = 0
+ isoort(2*i+8*(k-3)) = 0
+ goto 10
+ endif
+ endif
+ call ffccyz(y(1,k,i),z(1,k,i),dyz(1,1,k,i),d2yzz(k,i),i,
+ + sdel2,sdel2i(i,k),etalam(k),etami(1,k),delpsi(i,k),
+ + xpi(1,k),piDpj(1,1,k),isoort(2*i-1+8*(k-3)),ier)
+ 10 continue
+ 20 continue
+* #] get y,z-roots:
+* #[ get differences:
+*
+* the only important differences are y4z3-z3y4 and (1-y4)(1-z3)-
+* (1-y3)(1-z4). Note that the errors work in parallel.
+*
+ do 199 i=1,8
+ ieri(i) = 0
+ 199 continue
+ if ( isoort(1) .eq. isoort(9) ) then
+* #[ vertices (1):
+ som = qiDqj(7,2)/sdel2
+*
+* flag if we have a cancellation
+*
+ if ( absc(som) .lt. xloss ) then
+ isoort(1) = isoort(1) - 10
+ isoort(9) = isoort(9) - 10
+ endif
+ do 201 k=1,4
+ dyzzy(k,1) = som*z(k,3,1)
+ if ( k .gt. 2 ) dyzzy(k,1) = -dyzzy(k,1)
+ 201 continue
+ dyyzz(1,1) = som
+ dyyzz(2,1) = som
+* #] vertices (1):
+ endif
+ if ( isoort(3) .eq. isoort(11) ) then
+* #[ vertices (2):
+ ifirst = 0
+ do 22 j=1,2
+ do 21 k=1,2
+ ii = 2*(j-1) + k
+ dyzzy(ii,2) = y(2*j,4,2)*z(ii,3,2)-y(2*j,3,2)*z(ii,4,2)
+ xmax = absc(y(2*j,4,2)*z(ii,3,2))
+ if ( absc(dyzzy(ii,2)) .ge. xmax ) goto 21
+ isoort(3) = isoort(3) - 10
+ isoort(11) = isoort(11) - 10
+ if ( ifirst .eq. 0 ) then
+ if ( ddel2s(2) .eq. 0 ) then
+ dsdel2 = 0
+ else
+ dsdel2 = ddel2s(2)/(sdel2i(2,3)+sdel2i(2,4))
+ endif
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 ) then
+ s(1) = xqi(6)*qiDqj(7,4)*qiDqj(5,4)/sdel2
+ s(2) = -qiDqj(7,4)*sdel2i(2,3)
+ s(3) = +qiDqj(6,4)*dsdel2
+ else
+ s(1) = xqi(6)*qiDqj(7,2)*qiDqj(5,2)/sdel2
+ s(2) = -qiDqj(7,2)*sdel2i(2,3)
+ s(3) = +qiDqj(6,2)*dsdel2
+ endif
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ s(4) = -qiDqj(5,10)*qiDqj(7,4)*sdel2i(2,3)/sdel2
+ s(5) = delpsi(2,3)*dsdel2/sdel2
+ endif
+ if ( k .eq. 1 ) then
+ som = s(1) + s(2) + s(3) + s(4) + s(5)
+ else
+ som = s(1) - s(2) - s(3) - s(4) - s(5)
+ endif
+ smax = max(absc(s(1)),absc(s(2)),absc(s(3)),absc(s(4)),
+ + absc(s(5)))/DBLE(xqi(6))**2
+ if ( smax .lt. xmax ) then
+ dyzzy(ii,2) = som*(1/DBLE(xqi(6))**2)
+ xmax = smax
+ endif
+ 21 continue
+*
+* get dyyzz
+*
+ if ( ldel2s ) then
+ dyyzz(j,2) = dyz(2,j,4,2) - dyz(2,j,3,2)
+ xmax = absc(dyz(2,j,4,2))
+ if ( absc(dyyzz(j,2)) .ge. xloss*xmax ) goto 22
+ print *,'ffdcc0: under construction!'
+*
+* (could be copied from real case)
+*
+ endif
+*
+* bookkeeping
+*
+ ifirst = ifirst - 1
+ 22 continue
+* #] vertices (2):
+ endif
+ if ( isoort(5) .eq. isoort(13) ) then
+* #[ vertices (3):
+ ifirst = 0
+ do 26 j=1,2
+ do 25 k=1,2
+ ii = 2*(j-1) + k
+ dyzzy(ii,3) = y(2*j,4,3)*z(ii,3,3)-y(2*j,3,3)*z(ii,4,3)
+ xmax = absc(y(2*j,4,3)*z(ii,3,3))
+ if ( absc(dyzzy(ii,3)) .ge. xmax ) goto 25
+ isoort(5) = isoort(5) - 10
+ isoort(13) = isoort(13) - 10
+ if ( ifirst .eq. 0 ) then
+ if ( ddel2s(2) .eq. 0 ) then
+ dsdel2 = 0
+ else
+ dsdel2 = ddel2s(3)/(sdel2i(3,3)+sdel2i(3,4))
+ endif
+ endif
+ if ( ifirst .le. 1 ) then
+ if ( j .eq. 1 ) then
+ s(1) = xqi(8)*qiDqj(7,1)*qiDqj(5,1)/sdel2
+ s(2) = +qiDqj(7,1)*sdel2i(3,3)
+ s(3) = +qiDqj(9,1)*dsdel2
+ else
+ s(1) = xqi(8)*qiDqj(7,4)*qiDqj(5,4)/sdel2
+ s(2) = +qiDqj(7,4)*sdel2i(3,3)
+ s(3) = +qiDqj(9,4)*dsdel2
+ endif
+ endif
+ if ( ifirst .le. 0 ) then
+ ifirst = 2
+ s(4) = -qiDqj(5,9)*qiDqj(7,1)*sdel2i(3,3)/sdel2
+ s(5) = delpsi(3,3)*dsdel2/sdel2
+ endif
+ if ( k .eq. 1 ) then
+ som = s(1) + s(2) + s(3) + s(4) + s(5)
+ else
+ som = s(1) - s(2) - s(3) - s(4) - s(5)
+ endif
+ smax = max(absc(s(1)),absc(s(2)),absc(s(3)),absc(s(4)),
+ + absc(s(5)))/DBLE(xqi(8))**2
+ if ( smax .lt. xmax ) then
+ dyzzy(ii,3) = som*(1/DBLE(xqi(8))**2)
+ xmax = smax
+ endif
+ 25 continue
+*
+* get dyyzz
+*
+ if ( ldel2s ) then
+ dyyzz(j,3) = dyz(2,j,4,3) - dyz(2,j,3,3)
+ xmax = absc(dyz(2,j,4,3))
+ if ( absc(dyyzz(j,3)) .ge. xloss*xmax ) goto 24
+ print *,'ffdcc0: under construction!'
+*
+* (could be copied from real case)
+*
+ endif
+*
+* bookkeeping
+*
+ 24 continue
+ ifirst = ifirst - 1
+ 26 continue
+* #] vertices (3):
+ endif
+ ier = ier + max(ieri(1),ieri(2),ieri(3),ieri(4),ieri(5),ieri(6),
+ + ieri(7),ieri(8))
+* #] get differences:
+* #[ logarithms for 4point function:
+ if ( npoin .eq. 4 ) then
+ do 96 k = 3,4
+ do 95 i = 1,3
+ ii = i+3*(k-3)
+ if ( ilogi(ii) .ne. -999 ) goto 95
+ if ( isoort(2*i+8*(k-3)) .ne. 0 ) then
+* maybe add sophisticated factors i*pi later
+ c = -dyz(2,1,i,k)/dyz(2,2,i,k)
+ cc = c-1
+ if ( absc(cc) .lt. xloss ) then
+ s(1) = d2yzz(i,k)/dyz(2,2,i,k)
+ clogi(ii) = zfflo1(s(1),ier)
+ ilogi(ii) = 0
+ elseif ( DBLE(c) .gt. 0 ) then
+ clogi(ii) = zfflog(c,0,czero,ier)
+ ilogi(ii) = 0
+ else
+ cc = c+1
+ if ( absc(cc) .lt. xloss ) then
+ s(1) = -2*sdel2i(i,k)/dyz(2,2,i,k)/
+ + DBLE(xpi(i+3,k))
+ clogi(ii) = zfflo1(s(1),ier)
+ else
+ s(1) = 0
+ clogi(ii) = zfflog(-c,0,czero,ier)
+ endif
+ if ( DIMAG(c) .lt. -precc*absc(c) .or. DIMAG(s(1))
+ + .lt. -precc*absc(s(1)) ) then
+ ilogi(ii) = -1
+ elseif ( DIMAG(c) .gt. precc*absc(c) .or.
+ + DIMAG(s(1)) .gt. precc*absc(s(1)) ) then
+ ilogi(ii) = +1
+ elseif ( DBLE(dyz(2,2,i,k)) .eq. 0 ) then
+ ilogi(ii) = -nint(sign(1D0,DBLE(xpi(i+3,k))))
+ ier = ier + 50
+ print *,'doubtful imaginary part ',ilogi(ii)
+ else
+ call fferr(78,ier)
+ print *,'c = ',c
+ endif
+ endif
+ endif
+ 95 continue
+ 96 continue
+ endif
+* #] logarithms for 4point function:
+* #[ integrals:
+ do 100 i=1,3
+ j = 2*i-1
+ if ( isoort(j) .eq. 0 ) then
+ if ( isoort(j+8) .ne. 0 ) then
+ call ffcs3(cs3(20*i+61),ipi12(j+8),y(1,4,i),
+ + z(1,4,i),dyz(1,1,4,i),d2yzz(4,i),
+ + xpi(1,4),piDpj(1,1,4),i,6,isoort(j+8),ier)
+ endif
+ elseif ( isoort(j+8) .eq. 0 ) then
+ call ffcs3(cs3(20*i-19),ipi12(j),y(1,3,i),
+ + z(1,3,i),dyz(1,1,3,i),d2yzz(3,i),
+ + xpi(1,3),piDpj(1,1,3),i,6,isoort(j),ier)
+ else
+ call ffdcs(cs3(20*i-19),ipi12(j),y(1,3,i),z(1,3,i),
+ + dyz(1,1,3,i),d2yzz(3,i),dyzzy(1,i),dyyzz(1,i),
+ + xpi,piDpj,i,6,isoort(j),ier)
+ endif
+ 100 continue
+* #] integrals:
+*###] ffdcc0:
+ end
diff --git a/Looptools/D/ffdel4.F b/Looptools/D/ffdel4.F
--- a/Looptools/D/ffdel4.F
+++ b/Looptools/D/ffdel4.F
@@ -1,288 +1,291 @@
+#include "externals.h"
+
+
*###[ ffdel4:
subroutine ffdel4(del4,piDpj)
***#[*comment:***********************************************************
* *
* Calculate del4(piDpj) = det(si.sj) with *
* the momenta as follows: *
* p(1-4) = s(i) *
* p(4-10) = p(i) *
* *
* Input: piDpj(ns,ns) (real) *
* *
* Output: del4 (real) det(si.sj) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
DOUBLE PRECISION del4,piDpj(10,10)
*
* local variables:
*
integer mem,nperm
parameter(mem=10,nperm=125)
integer i,jj(8),iperm(4,nperm),imem,jmem,memarr(mem,4),memind,
+ inow,jnow,icount
DOUBLE PRECISION s(24),xmax,del4p,xmaxp
save iperm,memind,memarr,inow,jnow
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ data:
data memind /0/
data memarr /mem*0,mem*0,mem*1,mem*1/
data inow /1/
data jnow /1/
*
* these are all permutations that give a non-zero result with the
* correct sign. This list was generated with getperm4.
* (note: this used to be well-ordened, but then it had more than
* 19 continuation lines)
*
data iperm/
+ 1,2,3,4,1,2,3,7,1,2,8,3,1,2,3,10,1,2,6,4,1,2,4,7,1,2,4,9,1,2,6,7
+ ,1,2,8,6,1,2,6,10,1,2,7,8,1,2,7,9,1,2,10,7,1,2,9,8,1,2,10,9,1,3,
+ 4,5,1,3,6,4,1,3,10,4,1,3,7,5,1,3,5,8,1,3,10,5,1,3,6,7,1,3,8,6,1,
+ 3,6,10,1,3,10,7,1,3,8,10,1,4,5,6,1,4,7,5,1,4,9,5,1,4,6,7,1,4,6,9
+ ,1,4,6,10,1,4,10,7,1,4,10,9,1,5,6,7,1,5,8,6,1,5,6,10,1,5,7,8,1,5
+ ,7,9,1,5,10,7,1,5,9,8,1,5,10,9,1,6,8,7,1,6,9,7,1,6,8,9,1,6,8,10,
+ 1,6,9,10,1,7,10,8,1,7,10,9,1,8,9,10,2,3,4,5,2,3,8,4,2,3,9,4,2,3,
+ 7,5,2,3,5,8,2,3,10,5,2,3,8,7,2,3,9,7,2,3,8,9,2,3,8,10,2,3,9,10,2
+ ,4,5,6,2,4,7,5,2,4,9,5,2,4,6,8,2,4,6,9,2,4,8,7,2,4,9,7,2,4,8,9,2
+ ,5,6,7,2,5,8,6,2,5,6,10,2,5,7,8,2,5,7,9,2,5,10,7,2,5,9,8,2,5,10,
+ 9,2,6,8,7,2,6,9,7,2,6,8,9,2,6,8,10,2,6,9,10,2,7,10,8,2,7,10,9,2,
+ 8,9,10,3,4,5,6,3,4,8,5,3,4,9,5,3,4,5,10,3,4,6,8,3,4,6,9,3,4,10,8
+ ,3,4,10,9,3,5,6,7,3,5,8,6,3,5,6,10,3,5,7,8,3,5,7,9,3,5,10,7,3,5,
+ 9,8,3,5,10,9,3,6,8,7,3,6,9,7,3,6,8,9,3,6,8,10,3,6,9,10,3,7,10,8,
+ 3,7,10,9,3,8,9,10,4,5,6,7,4,5,8,6,4,5,6,10,4,5,7,8,4,5,7,9,4,5,1
+ 0,7,4,5,9,8,4,5,10,9,4,6,8,7,4,6,9,7,4,6,8,9,4,6,8,10,4,6,9,10,4
+ ,7,10,8,4,7,10,9,4,8,9,10/
* #] data:
* #[ get starting point from memory:
*
* see if we know were to start, if not: go on as last time
*
do 5 i=1,mem
if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
inow = memarr(i,3)
jnow = memarr(i,4)
goto 6
endif
5 continue
6 continue
* #] get starting point from memory:
* #[ calculations:
imem = inow
jmem = jnow
del4 = 0
xmax = 0
icount = 0
10 continue
jj(1) = iperm(1,inow)
jj(3) = iperm(2,inow)
jj(5) = iperm(3,inow)
jj(7) = iperm(4,inow)
jj(2) = iperm(1,jnow)
jj(4) = iperm(2,jnow)
jj(6) = iperm(3,jnow)
jj(8) = iperm(4,jnow)
s( 1) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*
+ piDpj(jj(5),jj(6))*piDpj(jj(7),jj(8))
s( 2) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*
+ piDpj(jj(5),jj(2))*piDpj(jj(7),jj(8))
s( 3) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*
+ piDpj(jj(5),jj(4))*piDpj(jj(7),jj(8))
s( 4) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*
+ piDpj(jj(5),jj(4))*piDpj(jj(7),jj(8))
s( 5) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*
+ piDpj(jj(5),jj(2))*piDpj(jj(7),jj(8))
s( 6) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*
+ piDpj(jj(5),jj(6))*piDpj(jj(7),jj(8))
s( 7) = -piDpj(jj(1),jj(2))*piDpj(jj(3),jj(4))*
+ piDpj(jj(7),jj(6))*piDpj(jj(5),jj(8))
s( 8) = -piDpj(jj(1),jj(4))*piDpj(jj(3),jj(6))*
+ piDpj(jj(7),jj(2))*piDpj(jj(5),jj(8))
s( 9) = -piDpj(jj(1),jj(6))*piDpj(jj(3),jj(2))*
+ piDpj(jj(7),jj(4))*piDpj(jj(5),jj(8))
s(10) = +piDpj(jj(1),jj(2))*piDpj(jj(3),jj(6))*
+ piDpj(jj(7),jj(4))*piDpj(jj(5),jj(8))
s(11) = +piDpj(jj(1),jj(6))*piDpj(jj(3),jj(4))*
+ piDpj(jj(7),jj(2))*piDpj(jj(5),jj(8))
s(12) = +piDpj(jj(1),jj(4))*piDpj(jj(3),jj(2))*
+ piDpj(jj(7),jj(6))*piDpj(jj(5),jj(8))
s(13) = -piDpj(jj(1),jj(2))*piDpj(jj(7),jj(4))*
+ piDpj(jj(5),jj(6))*piDpj(jj(3),jj(8))
s(14) = -piDpj(jj(1),jj(4))*piDpj(jj(7),jj(6))*
+ piDpj(jj(5),jj(2))*piDpj(jj(3),jj(8))
s(15) = -piDpj(jj(1),jj(6))*piDpj(jj(7),jj(2))*
+ piDpj(jj(5),jj(4))*piDpj(jj(3),jj(8))
s(16) = +piDpj(jj(1),jj(2))*piDpj(jj(7),jj(6))*
+ piDpj(jj(5),jj(4))*piDpj(jj(3),jj(8))
s(17) = +piDpj(jj(1),jj(6))*piDpj(jj(7),jj(4))*
+ piDpj(jj(5),jj(2))*piDpj(jj(3),jj(8))
s(18) = +piDpj(jj(1),jj(4))*piDpj(jj(7),jj(2))*
+ piDpj(jj(5),jj(6))*piDpj(jj(3),jj(8))
s(19) = -piDpj(jj(7),jj(2))*piDpj(jj(3),jj(4))*
+ piDpj(jj(5),jj(6))*piDpj(jj(1),jj(8))
s(20) = -piDpj(jj(7),jj(4))*piDpj(jj(3),jj(6))*
+ piDpj(jj(5),jj(2))*piDpj(jj(1),jj(8))
s(21) = -piDpj(jj(7),jj(6))*piDpj(jj(3),jj(2))*
+ piDpj(jj(5),jj(4))*piDpj(jj(1),jj(8))
s(22) = +piDpj(jj(7),jj(2))*piDpj(jj(3),jj(6))*
+ piDpj(jj(5),jj(4))*piDpj(jj(1),jj(8))
s(23) = +piDpj(jj(7),jj(6))*piDpj(jj(3),jj(4))*
+ piDpj(jj(5),jj(2))*piDpj(jj(1),jj(8))
s(24) = +piDpj(jj(7),jj(4))*piDpj(jj(3),jj(2))*
+ piDpj(jj(5),jj(6))*piDpj(jj(1),jj(8))
del4p = 0
xmaxp = 0
do 20 i=1,24
del4p = del4p + s(i)
xmaxp = max(xmaxp,abs(s(i)))
20 continue
if ( abs(del4p) .lt. xloss*xmaxp ) then
if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
del4 = del4p
xmax = xmaxp
endif
* as the list is ordered we may have more luck stepping
* through with large steps
inow = inow + 43
jnow = jnow + 49
if ( inow .gt. nperm ) inow = inow - nperm
if ( jnow .gt. nperm ) jnow = jnow - nperm
icount = icount + 1
if ( icount.gt.15 .or. inow.eq.imem .or. jnow.eq.jmem
+ ) goto 800
goto 10
endif
del4 = del4p
xmax = xmaxp
* #] calculations:
* #[ into memory:
memind = memind + 1
if ( memind .gt. mem ) memind = 1
memarr(memind,1) = id
memarr(memind,2) = idsub
memarr(memind,3) = inow
memarr(memind,4) = jnow
800 continue
* #] into memory:
*###] ffdel4:
end
*###[ ffdl3p:
subroutine ffdl3p(dl3p,piDpj,ns,ii,jj)
***#[*comment:***********************************************************
* calculate in a numerically stable way *
* *
* p1 p2 p3 *
* delta *
* p1' p2' p3' *
* *
* with pn = xpi(ii(n)), p4 = -p1-p2-p3, p5 = -p1-p2, p6 = p2+p3 *
* with pn'= xpi(jj(n)), p4'= etc. (when ns=15 p5=p1+p2) *
* *
* Input: piDpj real(ns,ns) dotpruducts *
* ns integer either 10 or 15 *
* ii,jj integer(6) location of pi in piDpj *
* Output: dl3p real see above *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ns,ii(6),jj(6)
DOUBLE PRECISION dl3p,piDpj(ns,ns)
*
* local variables
*
integer i,j,k,l,iperm(3,16),ii1,ii2,ii3,jj1,jj2,jj3,i0
logical lsymm
DOUBLE PRECISION s(6),som,xmax,smax,trylos
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data iperm /1,2,3, 2,4,3, 3,4,1, 4,2,1,
+ 1,2,6, 6,4,3, 3,1,6, 2,4,6,
+ 2,5,3, 5,4,1, 1,3,5, 2,4,5,
+ 1,6,5, 2,5,6, 3,6,5, 4,5,6/
* #] declarations:
* #[ calculations:
if ( ii(1).eq.jj(1) .and. ii(2).eq.jj(2) .and. ii(3).eq.jj(3) )
+ then
*
* symmetric - fewer possibilities
*
lsymm = .TRUE.
else
lsymm = .FALSE.
endif
*
* try all (8.5,16)*16 permutations
*
xmax = 0
trylos = 1
do 101 l=1,16
if ( lsymm ) then
i0 = l
else
i0 = 1
endif
do 100 i=i0,16
ii1 = ii(iperm(1,i))
ii2 = ii(iperm(2,i))
ii3 = ii(iperm(3,i))
j = i+l-1
if ( j .gt. 16 ) j=j-16
jj1 = jj(iperm(1,j))
jj2 = jj(iperm(2,j))
jj3 = jj(iperm(3,j))
s(1) = +piDpj(ii1,jj1)*piDpj(ii2,jj2)*piDpj(ii3,jj3)
s(2) = +piDpj(ii2,jj1)*piDpj(ii3,jj2)*piDpj(ii1,jj3)
s(3) = +piDpj(ii3,jj1)*piDpj(ii1,jj2)*piDpj(ii2,jj3)
s(4) = -piDpj(ii1,jj1)*piDpj(ii3,jj2)*piDpj(ii2,jj3)
s(5) = -piDpj(ii3,jj1)*piDpj(ii2,jj2)*piDpj(ii1,jj3)
s(6) = -piDpj(ii2,jj1)*piDpj(ii1,jj2)*piDpj(ii3,jj3)
som = 0
smax = 0
do 80 k=1,6
som = som + s(k)
smax = max(smax,abs(som))
80 continue
if ( ns .eq. 15 .and. (i.gt.8 .neqv. j.gt.8) )
+ som = -som
if ( i .eq. 1 .or. smax .lt. xmax ) then
dl3p = som
xmax = smax
endif
if ( abs(dl3p) .ge. xloss*smax ) goto 110
* give up a bit more easily if I have tried many times
if ( trylos*abs(dl3p) .ge. xloss*smax ) goto 109
trylos = trylos*1.3D0
100 continue
101 continue
109 continue
110 continue
* #] calculations:
*###] ffdl3p:
end
diff --git a/Looptools/D/ffxd0.F b/Looptools/D/ffxd0.F
--- a/Looptools/D/ffxd0.F
+++ b/Looptools/D/ffxd0.F
@@ -1,778 +1,787 @@
+#include "externals.h"
+
+
*--#[ log:
* $Id: ffxd0.f,v 1.4 1996/01/22 13:32:52 gj Exp $
* $Log: ffxd0.f,v $
c Revision 1.4 1996/01/22 13:32:52 gj
c Added sanity check on ier; if it is larger than 16 some routines will not
c compute anything.
c
c Revision 1.3 1995/11/28 13:37:47 gj
c Found wrong sign in ffcdna, fixed typo in ffcrp.
c Killed first cancellation in ffcdna - more to follow
c Added warnings to ffwarn.dat; slightly changed debug output in ffxd0.f
c
c Revision 1.2 1995/10/17 06:55:12 gj
c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
c (ffxd0h.f)
c
*--#] log:
*###[ ffxd0:
subroutine ffxd0(cd0,xpi,ier)
***#[*comment:***********************************************************
* *
* 1 / *
* calculate cd0 = ----- \dq [(q^2 + 2*s_1.q)*(q^2 + 2*s2.q) *
* ipi^2 / *(q^2 + 2*s3.q)*(q^2 + 2*s4.q)]^-1 *
* *
* |p9 *
* \p8 V p7/ *
* \ / *
* \________/ *
* | m4 | *
* = | | /____ *
* m1| |m3 \ p10 *
* | | all momenta are incoming *
* |________| *
* / m2 \ *
* / \ *
* /p5 p6\ *
* *
* *
* following the two-three-point-function method in 't hooft & *
* veltman. this is only valid if there is a lambda(pij,mi,mj)>0 *
* *
* Input: xpi = mi^2 (real) i=1,4 *
* xpi = pi.pi (real) i=5,8 (note: B&D metric) *
* xpi(9)=s (real) (=p13) *
* xpi(10)=t (real) (=p24) *
* xpi(11)=u (real) u=p5.p5+..-p9.p9-p10.10 or 0 *
* xpi(12)=v (real) v=-p5.p5+p6.p6-p7.p7+.. or 0 *
* xpi(13)=w (real) w=p5.p5-p6.p6+p7.p7-p8.p8+.. *
* output: cd0 (complex) *
* ier (integer) <50:lost # digits 100=error *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE PRECISION xpi(13)
DOUBLE COMPLEX cd0
integer ier
*
* local variables
*
logical luvw(3)
DOUBLE PRECISION dpipj(10,13)
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ catch totally massless case:
*
if (abs(xpi(1) + xpi(2) + xpi(3) + xpi(4)) .lt. 1D-10) then
call ffxd0m0(cd0,xpi,ier)
return
endif
*
* #] catch totally massless case:
* #[ call ffdif4, ffxd0a:
*
call ffdif4(dpipj,luvw,xpi)
call ffxd0a(cd0,xpi,dpipj,ier)
*
* restore the zeros for u,v,w as we have calculated them
* ourselves and the user is unlikely to do this...
*
if ( luvw(1) ) xpi(11) = 0
if ( luvw(2) ) xpi(12) = 0
if ( luvw(3) ) xpi(13) = 0
*
* #] call ffdif4, ffxd0a:
*###] ffxd0:
end
*###[ ffxd0a:
subroutine ffxd0a(cd0,xpi,dpipj,ier)
*
* glue routine which calls ffxd0b with ndiv=0
*
implicit none
*
* arguments
*
integer ier
DOUBLE PRECISION xpi(13),dpipj(10,13)
DOUBLE COMPLEX cd0
*
* locals
*
DOUBLE COMPLEX cs,cfac
*
* and go!
*
call ffxd0b(cs,cfac,xpi,dpipj,0,ier)
cd0 = cs*cfac
*
*###] ffxd0a:
end
*###[ ffxd0b:
subroutine ffxd0b(cs,cfac,xpi,dpipj,ndiv,ier)
***#[*comment:***********************************************************
* *
* 1 / *
* calculate cd0 = ----- \dq [(q^2 + 2*s_1.q)*(q^2 + 2*s2.q) *
* ipi^2 / *(q^2 + 2*s3.q)*(q^2 + 2*s4.q)]^-1 *
* *
* |p9 *
* \p8 V p7/ *
* \ / *
* \________/ *
* | m4 | *
* = | | /____ *
* m1| |m3 \ p10 *
* | | all momenta are incoming *
* |________| *
* / m2 \ *
* / \ *
* /p5 p6\ *
* *
* *
* following the two-three-point-function method in 't hooft & *
* veltman. this is only valid if there is a lambda(pij,mi,mj)>0 *
* *
* Input: xpi = mi^2 (real) i=1,4 *
* xpi = pi.pi (real) i=5,8 (note: B&D metric) *
* xpi(9)=s (real) (=p13) *
* xpi(10)=t (real) (=p24) *
* xpi(11)=u (real) u=p5.p5+..-p9.p9-p10.10 *
* xpi(12)=v (real) v=-p5.p5+p6.p6-p7.p7+.. *
* xpi(13)=w (real) w=p5.p5-p6.p6+p7.p7-p8.p8+.. *
* dpipj(10,13) (real) = pi(i) - pi(j) *
* output: cs,cfac (complex) cd0 = cs*cfac *
* ier (integr) 0=ok 1=inaccurate 2=error *
* calls: ffcxs3,ffcxr,ffcrr,... *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ndiv,ier
DOUBLE PRECISION xpi(13),dpipj(10,13)
DOUBLE COMPLEX cs,cfac
*
* local variables
*
integer i,j,itype,ini2ir,ier2,idone,ier0
logical ldel2s
DOUBLE COMPLEX c,cs1,cs2
DOUBLE PRECISION absc,xmax,xpip(13),dpipjp(10,13),piDpjp(10,10),
+ qiDqj(10,10),del2s,lambda0
save ini2ir,lambda0
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* memory
*
integer iermem(memory),ialmem(memory),memind,ierini,nscsav,
+ isgnsa
logical onssav
DOUBLE PRECISION xpimem(10,memory),dl4mem(memory)
DOUBLE COMPLEX csmem(memory),cfcmem(memory)
save memind,iermem,ialmem,xpimem,dl4mem,nscsav,onssav,csmem,
+ cfcmem
*
* statement function:
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* data
*
data memind /0/
data ini2ir /0/
data lambda0 /1D0/
*
* #] declarations:
* #[ initialisations:
cs = 0
cfac = 1
idsub = 0
idone = 0
* #] initialisations:
* #[ check for IR 4point function:
*
call ffxdir(cs,cfac,idone,xpi,dpipj,4,ndiv,ier)
if ( idone .le. 0 .and. ndiv .gt. 0 ) then
cs = 0
cfac = 1
ier = 0
return
endif
if ( idone .gt. 0 ) then
return
endif
*
* #] check for IR 4point function:
* #[ rotate to calculable position:
call ffrot4(irota4,del2s,xpip,dpipjp,piDpjp,xpi,dpipj,qiDqj,4,
+ itype,ier)
if ( itype .lt. 0 ) then
print *,'ffxd0b: error: Cannot handle this ',
+ ' masscombination yet:'
print *,(xpi(i),i=1,13)
return
endif
if ( itype .eq. 1 ) then
ldel2s = .TRUE.
isgnal = +1
else
ldel2s = .FALSE.
endif
* #] rotate to calculable position:
* #[ treat doubly IR divergent case:
if ( itype .eq. 2 ) then
*
* double IR divergent diagram, i.e. xpi(3)=xpi(4)=xpi(7)=0
*
if ( ini2ir .eq. 0 ) then
ini2ir = 1
print *,'ffxd0b: using the log(lam) prescription to'
print *,' regulate the 2 infrared poles to match'
print *,' with soft gluon massive, lam^2 =',lambda
endif
ier2 = 0
call ffx2ir(cs1,cs2,xpip,dpipjp,ier2)
del2s = -lambda**2/4
*
* correct for the wrongly treated IR pole
*
cs = cs + (cs1 + cs2)/cfac
ier = max(ier,ier2)
xmax = max(absc(cs1),absc(cs2))/absc(cfac)
if ( absc(cs) .lt. xloss*xmax )
+ call ffwarn(172,ier,absc(cs),xmax)
if ( .not.ldot ) return
endif
+ if( itype .eq. 3 ) then
+ call ffd0tra(cs,
+ & xpi(iold(9,irota4)), xpi(iold(10,irota4)),
+ & xpi(iold(1,irota4)), xpi(iold(8,irota4)), ier)
+ return
+ endif
*
* #] treat doubly IR divergent case:
* #[ look in memory:
ierini = ier
isgnsa = isgnal
*
* initialise memory
*
if ( lmem .and. idone .eq. 0 .and. (memind .eq. 0 .or. nschem
+ .ne. nscsav .or. (onshel .neqv. onssav) ) ) then
memind = 0
nscsav = nschem
onssav = onshel
do 2 i=1,memory
do 1 j=1,10
xpimem(j,i) = 0
1 continue
ialmem(i) = 0
2 continue
endif
*
if ( lmem .and. idone .eq. 0 .and. lambda .eq. lambda0 ) then
do 150 i=1,memory
do 130 j=1,10
if ( xpip(j) .ne. xpimem(j,i) ) goto 150
130 continue
* we use ialmem(i)==0 to signal that both are covered as
* the sign was flipped during the computation
if ( ialmem(i).ne.isgnal .and. ialmem(i).ne.0 ) goto 150
* we found an already calculated masscombination ..
* (maybe check differences as well)
cs = csmem(i)
cfac = cfcmem(i)
ier = ier+iermem(i)
if ( ldot ) then
fdel4s = dl4mem(i)
* we forgot to calculate the dotproducts
idone = 1
goto 51
endif
return
150 continue
elseif ( lmem ) then
lambda0 = lambda
endif
51 continue
* #] look in memory:
* #[ get dotproducts:
*
* Calculate the dotproducts (in case it comes out of memory the
* error is already included in ier)
*
ier0 = ier
call ffgdt4(piDpjp,xpip,dpipjp,xpi,ier0)
if ( idone .gt. 0 ) return
ier = ier0
if ( ier.ge.100 ) then
cs = 0
cfac = 1
return
endif
*
* #] get dotproducts:
* #[ calculations:
*
call ffxd0e(cs,cfac,xmax, .FALSE.,ndiv,xpip,dpipjp,piDpjp,del2s,
+ ldel2s,ier)
*
* #] calculations:
* #[ add to memory:
*
* memory management :-)
*
if ( lmem ) then
memind = memind + 1
if ( memind .gt. memory ) memind = 1
do 200 j=1,10
xpimem(j,memind) = xpip(j)
200 continue
csmem(memind) = cs
cfcmem(memind) = cfac
iermem(memind) = ier-ierini
ialmem(memind) = isgnal
dl4mem(memind) = fdel4s
if ( isgnal.ne.isgnsa ) then
ialmem(memind) = 0
endif
endif
* #] add to memory:
*###] ffxd0b:
end
*###[ ffxd0e:
subroutine ffxd0e(cs,cfac,xmax,lir,ndiv,xpip,dpipjp,piDpjp,
+ del2s,ldel2s,ier)
***#[*comment:***********************************************************
* *
* Break in the calculation of D0 to allow the E0 to tie in in a *
* logical position. This part gets untransformed momenta but *
* rotated momenta in and gives the D0 (in two pieces) and the *
* maximum term back. *
* *
* Input xpip real(13) *
* dpipjp real(10,13) *
* piDpjp real(10,10) *
* del2s real *
* ldel2s logical *
* lir logical if TRUE it can still be IR-div *
* ndiv integer number of required divergences *
* *
* Output: cs complex the fourpoint function without *
* overall factor (sum of dilogs) *
* cfac complex this overall factor *
* xmax real largest term in summation *
* ier integer usual error flag *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ndiv,ier
logical lir,ldel2s
DOUBLE PRECISION xpip(13),dpipjp(10,13),piDpjp(10,10),xmax,del2s
DOUBLE COMPLEX cs,cfac
*
* local variables
*
DOUBLE COMPLEX c,cs4(175),cs3(2)
logical laai
- integer i,ier0,itime,maxlos,init,isoort(16),ipi12(26),
+ integer i,ier0,itime,maxlos,init,isoort(16),ipi12(28),
+ ipi123(2),ipi12t,idone
DOUBLE PRECISION absc,sdel2s,ai(4),daiaj(4,4),aai(4),
+ dt3t4,xqi(10),dqiqj(10,10),qiDqj(10,10),xfac
save maxlos
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function:
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* data
*
data init /0/
* #] declarations:
* #[ check for IR 4point function:
if ( lir ) then
*
ier0 = ier
call ffxdir(cs,cfac,idone,xpip,dpipjp,4,0,ier)
if ( idone .le. 0 .and. ndiv .gt. 0 ) then
cs = 0
cfac = 1
xmax = 0
ier = 0
return
endif
if ( idone .gt. 0 ) then
xmax = abs(cs)*10d0**(-mod((ier0-ier),50))
return
endif
endif
*
* #] check for IR 4point function:
* #[ init:
*
* initialize cs4:
*
do 80 i=1,175
cs4(i) = 0
80 continue
- do 90 i=1,26
+ do 90 i=1,28
ipi12(i) = 0
90 continue
cs = 0
*
* #] init:
* #[ transform the masses and momenta:
itime = 1
25 continue
*
* Transform with the A's of gerard 't hooft's transformation:
*
* NOTE: for some odd reason I cannot vary isgnal,isgn34
* independently!
*
isgn34 = isgnal
sdel2s = isgn34*sqrt(-del2s)
ier0 = ier
call ffai(ai,daiaj,aai,laai,del2s,sdel2s,xpip,dpipjp,piDpjp,
+ ier0)
if ( ier0 .ge. 100 ) goto 70
call fftran(ai,daiaj,aai,laai,xqi,dqiqj,qiDqj,del2s,sdel2s,
+ xpip,dpipjp,piDpjp,ier0)
if ( ier0 .ge. 100 ) goto 70
if ( .not.ldel2s ) then
dt3t4 = -2*ai(3)*ai(4)*sdel2s
if ( dt3t4 .eq. 0 ) then
* don't know what to do...
call fferr(85,ier)
return
endif
else
* this value is modulo the delta of xpip(4)=xpip(3)(1+2delta)
dt3t4 = -2*ai(4)**2*xpip(3)
endif
70 continue
*
* If we lost too much accuracy try the other root...
* (to do: build in a mechanism for remembering this later)
*
if ( init .eq. 0 ) then
init = 1
* go ahead if we have half the digits left
maxlos = -int(log10(precx))/2
endif
if ( ier0-ier .gt. maxlos ) then
if ( itime .eq. 1 ) then
itime = 2
if ( ier0-ier .ge. 100 ) itime = 100
isgnal = -isgnal
goto 25
else
if ( ier0-ier .lt. 100 ) then
* it does not make any sense to go on, but do it anyway
elseif ( itime.eq.100 ) then
call fferr(72,ier)
cfac = 1
return
elseif ( itime.le.2 ) then
* the first try was better
isgnal = -isgnal
itime = 3
goto 25
endif
endif
endif
ier = ier0
* #] transform the masses and momenta:
* #[ calculations:
call ffxd0p(cs4,ipi12,isoort,cfac,xpip,dpipjp,piDpjp,
+ xqi,dqiqj,qiDqj,ai,daiaj,ldel2s,ier)
xfac = -ai(1)*ai(2)*ai(3)*ai(4)/dt3t4
*
* see the note at the end of this section about the sign
*
if ( DIMAG(cfac) .eq. 0 ) then
cfac = xfac/DBLE(cfac)
else
cfac = DBLE(xfac)/cfac
endif
*
* sum'em up:
*
cs3(1) = 0
cs3(2) = 0
xmax = 0
do 110 i=1,80
cs3(1) = cs3(1) + cs4(i)
xmax = max(xmax,absc(cs3(1)))
110 continue
do 111 i=81,160
cs3(2) = cs3(2) + cs4(i)
xmax = max(xmax,absc(cs3(2)))
111 continue
cs = cs3(1) - cs3(2)
do 112 i=161,175
cs = cs + cs4(i)
xmax = max(xmax,absc(cs))
112 continue
ipi123(1) = 0
ipi123(2) = 0
do 113 i=1,8
ipi123(1) = ipi123(1) + ipi12(i)
113 continue
do 114 i=9,16
ipi123(2) = ipi123(2) + ipi12(i)
114 continue
ipi12t = ipi123(1) - ipi123(2)
- do 120 i=17,26
+ do 120 i=17,28
ipi12t = ipi12t + ipi12(i)
120 continue
cs = cs + ipi12t*DBLE(pi12)
*
* If the imaginary part is very small it most likely is zero
* (can be removed, just esthetically more pleasing)
*
if ( abs(DIMAG(cs)) .lt. precc*abs(DBLE(cs)) )
+ cs = DCMPLX(DBLE(cs))
*
* it is much nicer to have the sign of cfac fixed, say positive
*
if ( DBLE(cfac) .lt. 0 .or. (DBLE(cfac) .eq. 0 .and. DIMAG(cfac)
+ .lt. 0 ) ) then
cfac = -cfac
cs = -cs
endif
* #] calculations:
*###] ffxd0e:
end
*###[ ffxd0r:
subroutine ffxd0r(cd0,xpi,ier)
***#[*comment:***********************************************************
* *
* Tries all 12 permutations of the 4pointfunction *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE PRECISION xpi(13),xqi(13)
DOUBLE COMPLEX cd0,cd0p
integer inew(13,6),irota,ier0,ier1,i,j,ialsav
save inew
- include 'ff.h'
+#include "ff.h"
data inew /1,2,3,4,5,6,7,8,9,10,11,12,13,
+ 4,1,2,3,8,5,6,7,10,9,11,13,12,
+ 3,4,1,2,7,8,5,6,9,10,11,12,13,
+ 2,3,4,1,6,7,8,5,10,9,11,13,12,
+ 4,2,3,1,10,6,9,8,7,5,12,11,13,
+ 1,3,2,4,9,6,10,8,5,7,12,11,13/
* #] declarations:
* #[ calculations:
cd0 = 0
ier0 = ier
ier = 999
ialsav = isgnal
do 30 j = -1,1,2
do 20 irota=1,6
do 10 i=1,13
xqi(inew(i,irota)) = xpi(i)
10 continue
ier1 = ier0
ner = 0
id = id + 1
isgnal = ialsav
print '(a,i1,a,i2)','---#[ rotation ',irota,': isgnal ',
+ isgnal
call ffxd0(cd0p,xqi,ier1)
ier1 = ier1 + ner
print '(a,i1,a,i2,a)','---#] rotation ',irota,
+ ': isgnal ',isgnal,' '
print '(a,2g28.16,i3)','d0 = ',cd0p,ier1
if ( ier1 .lt. ier ) then
cd0 = cd0p
ier = ier1
endif
20 continue
ialsav = -ialsav
30 continue
* #] calculations:
*###] ffxd0r:
end
*###[ ffxd0d:
subroutine ffxd0d(cd0,xpi,piDpj,del3p,del4s,info,ier)
***#[*comment:***********************************************************
* *
* Entry point to the four point function with dotproducts given. *
* Necessary to avoid cancellations near the borders of phase *
* space. *
* *
* Input: xpi(13) real 1-4: mi^2, 5-10: pi^2,s,t *
* optional: 11:u, 12:v, 13:w *
* info integer 0: no extra info *
* 1: piDpj(i,j), i,j>4 is defined *
* 2: del3p is also defined *
* 3: all piDpj are given *
* 4: del4s is also given *
* piDpj(10,10) real pi.pj in B&D metric; *
* 1-4:si.sj=(m_i^2+m_j^2-p_ij^2)/2*
* cross: si.pjk=si.pj-si.pk *
* 5-10: pi.pj *
* del3p real det(pi.pj) *
* del4s real det(si.sj) (~square overall fac)*
* ier integer #digits accuracy lost in input *
* Output: cd0 complex D0 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer info,ier
DOUBLE PRECISION xpi(13),piDpj(10,10),del3p,del4s
DOUBLE COMPLEX cd0
*
* local vars
*
integer i,j
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ hide information in common blocks:
*
idot = info
if ( idot.ne.0 ) then
if ( idot.gt.0 .and. idot.le.2 ) then
do 20 i=5,10
do 10 j=5,10
fpij4(j,i) = piDpj(j,i)
10 continue
20 continue
elseif ( idot.ge.3 ) then
do 40 i=1,10
do 30 j=1,10
fpij4(j,i) = piDpj(j,i)
30 continue
40 continue
endif
if ( abs(idot).ge.2 ) then
fdel3 = del3p
endif
if ( abs(idot).ge.4 ) then
fdel4s = del4s
endif
endif
*
* #] hide information in common blocks:
* #[ call ffxd0:
*
call ffxd0(cd0,xpi,ier)
*
* invalidate all the common blocks for the next call
*
idot = 0
*
* #] call ffxd0:
*###] ffxd0d:
end
*###[ ffdif4:
subroutine ffdif4(dpipj,luvw,xpi)
***#[*comment:***********************************************************
* *
* Compute the elements 11-13 in xpi and the differences dpipj *
* Note that the digits lost in dpipj are not counted towards *
* the total. *
* *
* Input: xpi(1:10) real masses, momenta^2 *
* *
* Output: xpi(11:13) real u and similar vars v,w *
* luvw(3) logical TRUE if xpi(10+i) has *
* been computed here *
* dpipj(10,13) real xpi(i) - xpi(j) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
logical luvw(3)
DOUBLE PRECISION xpi(13),dpipj(10,13)
*
* local variables
*
integer i,j
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ get differences:
* simulate the differences in the masses etc..
if ( xpi(11) .eq. 0 ) then
xpi(11) = xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
luvw(1) = .TRUE.
else
luvw(1) = .FALSE.
endif
if ( xpi(12) .eq. 0 ) then
xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
luvw(2) = .TRUE.
else
luvw(2) = .FALSE.
endif
if ( xpi(13) .eq. 0 ) then
if ( max(abs(xpi(5)),abs(xpi(7))) .gt.
+ max(abs(xpi(9)),abs(xpi(10))) ) then
xpi(13) = -xpi(12) + 2*(xpi(9)+xpi(10))
else
xpi(13) = -xpi(11) + 2*(xpi(5)+xpi(7))
endif
* xpi(13) = xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
luvw(3) = .TRUE.
else
luvw(3) = .FALSE.
endif
do 20 i=1,13
do 19 j=1,10
dpipj(j,i) = xpi(j) - xpi(i)
19 continue
20 continue
* #] get differences:
*###] ffdif4:
end
diff --git a/Looptools/D/ffxd0h.F b/Looptools/D/ffxd0h.F
--- a/Looptools/D/ffxd0h.F
+++ b/Looptools/D/ffxd0h.F
@@ -1,649 +1,668 @@
+#include "externals.h"
+
+
*--#[ log:
* $Id: ffxd0h.f,v 1.6 1996/01/22 13:33:49 gj Exp $
* $Log: ffxd0h.f,v $
c Revision 1.6 1996/01/22 13:33:49 gj
c Added the word 'error' to print statements in ffxuvw that u,v,w were wrong
c
c Revision 1.5 1995/12/08 10:48:32 gj
c Changed xloss to xlosn to prevent spurious error messages.
c
c Revision 1.4 1995/11/10 18:55:46 gj
c JUst added some comments in ffrot4
c
c Revision 1.3 1995/10/29 15:37:43 gj
c Revision 1.2 1995/10/17 06:55:13 gj
c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
c (ffxd0h.f)
c
*--#] log:
*###[ ffrot4:
subroutine ffrot4(irota,del2,xqi,dqiqj,qiDqj,xpi,dpipj,piDpj,ii,
+ itype,ier)
***#[*comment:***********************************************************
* *
* rotates the arrays xpi, dpipj into xqi,dqiqj over irota places *
* such that del2(s3,s4)<=0. itype=0 unless del2(s3,s4)=0 (itype=1)*
* itype=2 if the 4pointfunction is doubly IR-divergent *
* ((0,0,0)vertex) *
* *
* Input: xpi(13) real momenta squared *
* dpipj(10,13) real xpi(i) - xpi(j) *
* piDpj(10,10) real if ( ii>4) pi.pj *
* ii integer 4: from Do, 5: from E0 *
* Output: irota integer # of positions rotated + 1 *
* del2 real delta(s3,s4,s3,s4) chosen * *
* xqi,dqiqj,qiDqj real rotated (q->p) *
* itype integer 0:normal, -1:failure, 1:del2=0 *
* 2:doubly IR *
* ier integer usual error flag *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer irota,ier,ii,itype
DOUBLE PRECISION del2,xpi(13),dpipj(10,13),piDpj(10,10),
+ xqi(13),dqiqj(10,13),qiDqj(10,10)
*
* local variables
*
integer i,j,izero,ier0,init
DOUBLE COMPLEX chulp(4,4)
save init
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data init /0/
*
* #] declarations:
* #[ find out which del2 is negative: (or zero)
izero = 0
do 40 irota = 1,12
*
* first check if we have a doubly IR divergent diagram
*
if ( xpi(iold(3,irota)) .eq. 0 .and.
+ xpi(iold(4,irota)) .eq. 0 .and.
+ xpi(iold(7,irota)) .eq. 0 .and.
+ dpipj(iold(1,irota),iold(8,irota)) .eq. 0 .and.
+ dpipj(iold(2,irota),iold(6,irota)) .eq. 0 ) then
del2 = 0
goto 41
endif
*
* We can at this moment only handle s3^2 = 0
* (Hope to include two masses 0 later)
* I hope nothing goes wrong if we leave out:
* >xpi(iold(1,irota)) .eq. 0 .or.
* + xpi(iold(2,irota)) .eq. 0 .or.
* + <
* 'cause I can't see why it was included in the first place..
*
if ( xpi(iold(4,irota)) .eq. 0 ) goto 40
*
* Well, the combination s2=0, p6=s3, p10=s4 gives 1/A2=0 twice
*
if ( xpi(iold(2,irota)) .eq. 0 .and.
+ dpipj(iold( 6,irota),iold(3,irota)) .eq. 0 .and.
+ dpipj(iold(10,irota),iold(4,irota)) .eq. 0)
+ goto 40
*
* phenomenologically this combo also gives an infinite result
*
if ( xpi(iold(1,irota)) .eq. 0 .and.
+ xpi(iold(2,irota)) .eq. 0 .and.
+ dpipj(iold( 8,irota),iold(4,irota)) .eq. 0 .and.
+ dpipj(iold( 9,irota),iold(3,irota)) .eq. 0)
+ goto 40
*
* I just found out that this gives two times 1/A1 = 0
*
if ( xpi(iold(7,irota)) .eq. 0 .and.
+ dpipj(iold(9,irota),iold(3,irota))+
+ dpipj(iold(4,irota),iold(8,irota)) .eq. 0 )
+ goto 40
if ( xpi(iold(1,irota)) .eq. 0 .and.
+ dpipj(iold(9,irota),iold(3,irota)) .eq. 0 .and.
+ dpipj(iold(4,irota),iold(8,irota)) .eq. 0 .and.
+ .not.lnasty )
+ goto 40
*
* the nasty case wants xpi(1)=0, xpi(2) real:
*
if ( lnasty ) then
if ( xpi(iold(1,irota)).ne.0 .or. DIMAG(
+ c2sisj(iold(1,irota),iold(2,irota))).ne.0 ) then
print *,'no good: nasty but s1!=0 or s2 not real'
goto 40
endif
endif
*
+* all masses equal, three momenta zero:
+* added by TH 24 Dec 09
+*
+#if 0
+ if( xpi(iold(5,irota)) .eq. 0 .and.
+ & xpi(iold(6,irota)) .eq. 0 .and.
+ & xpi(iold(7,irota)) .eq. 0 .and.
+ & abs(xpi(iold(1,irota)) - xpi(iold(2,irota))) +
+ & abs(xpi(iold(1,irota)) - xpi(iold(3,irota))) +
+ & abs(xpi(iold(1,irota)) - xpi(iold(4,irota)))
+ & .lt. precx ) then
+ itype = 3
+ return
+ endif
+#endif
+*
ier0 = 0
call ffxlam(del2,xpi,dpipj,10,
+ iold(3,irota),iold(4,irota),iold(7,irota))
*
* we can only handle del2=0 if p_i^2 = 0 (and thus m_i=m_{i+1})
*
if ( del2 .lt. 0 ) then
itype = 0
goto 50
endif
if ( del2 .eq. 0 .and. izero .eq. 0 .and. xpi(iold(7,irota))
+ .eq. 0 ) then
izero = irota
endif
40 continue
ier = ier + ier0
if ( izero .eq. 0 ) then
call fferr(54,ier)
itype = -1
irota = 1
else
irota = izero
del2 = 0
itype = 1
if ( init.lt.10 ) then
init = init + 1
print *,'ffrota: warning: the algorithms for del2=0 have not '
print *,' yet been tested thoroughly, and in fact are '
print *,' known to contain bugs.'
print *,' ==> DOUBLECHECK EVERYTHING WITH SMALL SPACELIKE p^2'
endif
endif
goto 50
41 continue
itype = 2
50 continue
* #] find out which del2 is negative:
* #[ rotate:
do 20 i=1,13
xqi(i) = xpi(iold(i,irota))
do 10 j=1,10
dqiqj(j,i) = dpipj(iold(j,irota),iold(i,irota))
10 continue
20 continue
if ( ii .eq. 5 ) then
do 120 i=1,10
do 110 j=1,10
qiDqj(j,i) = isgrot(iold(j,irota),irota)*
+ isgrot(iold(i,irota),irota)*
+ piDpj(iold(j,irota),iold(i,irota))
110 continue
120 continue
endif
if ( lsmug .or. lnasty ) then
do 220 j=1,4
do 210 i=1,4
chulp(i,j) = c2sisj(i,j)
210 continue
220 continue
do 240 j=1,4
do 230 i=1,4
c2sisj(i,j) = chulp(iold(i,irota),iold(j,irota))
230 continue
240 continue
endif
* #] rotate:
*###] ffrot4:
end
*###[ ffxlam:
subroutine ffxlam(xlam,xpi,dpipj,ns,i1,i2,i3)
*************************************************************************
* *
* calculate in a numerically stable way *
* xlam(xpi(i1),xpi(i2),xpi(i3)) = *
* = -((xpi(i1)+xpi(i2)-xpi(i3))/2)^2 + xpi(i1)*xpi(i2) *
* or a permutation *
* ier is the usual error flag. *
* *
*************************************************************************
implicit none
*
* arguments:
*
integer ns,i1,i2,i3
DOUBLE PRECISION xlam,xpi(ns),dpipj(ns,ns)
*
* local variables
*
DOUBLE PRECISION s1,s2
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* calculations
*
if ( abs(xpi(i1)) .gt. max(abs(xpi(i2)),abs(xpi(i3))) ) then
s1 = xpi(i2)*xpi(i3)
if ( abs(dpipj(i1,i2)) .lt. abs(dpipj(i1,i3)) ) then
s2 = ((dpipj(i1,i2) - xpi(i3))/2)**2
else
s2 = ((dpipj(i1,i3) - xpi(i2))/2)**2
endif
elseif ( abs(xpi(i2)) .gt. abs(xpi(i3)) ) then
s1 = xpi(i1)*xpi(i3)
if ( abs(dpipj(i1,i2)) .lt. abs(dpipj(i2,i3)) ) then
s2 = ((dpipj(i1,i2) + xpi(i3))/2)**2
else
s2 = ((dpipj(i2,i3) - xpi(i1))/2)**2
endif
else
s1 = xpi(i1)*xpi(i2)
if ( abs(dpipj(i1,i3)) .lt. abs(dpipj(i2,i3)) ) then
s2 = ((dpipj(i1,i3) + xpi(i2))/2)**2
else
s2 = ((dpipj(i2,i3) + xpi(i1))/2)**2
endif
endif
xlam = s1 - s2
*###] ffxlam:
end
*###[ ffdot4:
subroutine ffdot4(piDpj,xpi,dpipj,ns,ier)
***#[*comment:***********************************************************
* *
* calculate the dotproducts pi.pj with *
* *
* pi = si i1=1,4 *
* pi = p(i-3) i1=5,10 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ns,ier
DOUBLE PRECISION xpi(13),dpipj(10,13),piDpj(10,10)
integer is1,is2,is3,ip1,ip2,ip3,i,j,ier0,ier1
DOUBLE PRECISION xmax,som,xmxp
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ check input:
if ( ns .ne. 10 ) print *,'ffdot4: error: ns <> 10 '
* #] check input:
* #[ special case: already known:
if ( idot.ge.3 ) then
do 2 i=1,10
do 1 j=1,10
piDpj(j,i) = isgrot(iold(j,irota4),irota4)*
+ isgrot(iold(i,irota4),irota4)*
+ fpij4(iold(j,irota4),iold(i,irota4))
1 continue
2 continue
return
endif
* #] special case: already known:
* #[ indices:
ier1 = ier
do 10 is1=1,4
is2 = is1 + 1
if ( is2 .eq. 5 ) is2 = 1
is3 = is2 + 1
if ( is3 .eq. 5 ) is3 = 1
ip1 = is1 + 4
ip2 = is2 + 4
if ( mod(is1,2) .eq. 1 ) then
ip3 = 9
else
ip3 = 10
endif
* #] indices:
* #[ all in one vertex:
*
* pi.pj, si.sj
*
piDpj(is1,is1) = xpi(is1)
piDpj(ip1,ip1) = xpi(ip1)
*
* si.s(i+1)
*
if ( xpi(is2) .le. xpi(is1) ) then
piDpj(is1,is2) = (dpipj(is1,ip1) + xpi(is2))/2
else
piDpj(is1,is2) = (dpipj(is2,ip1) + xpi(is1))/2
endif
piDpj(is2,is1) = piDpj(is1,is2)
ier0 = ier
ier1 = max(ier1,ier0)
*
* si.s(i+2)
*
if ( is1 .le. 2 ) then
if ( xpi(is1) .le. xpi(is3) ) then
piDpj(is3,is1) = (dpipj(is3,ip3) + xpi(is1))/2
else
piDpj(is3,is1) = (dpipj(is1,ip3) + xpi(is3))/2
endif
piDpj(is1,is3) = piDpj(is3,is1)
ier0 = ier
ier1 = max(ier1,ier0)
endif
*
* pi.si
*
if ( abs(xpi(ip1)) .le. xpi(is1) ) then
piDpj(ip1,is1) = (dpipj(is2,is1) - xpi(ip1))/2
else
piDpj(ip1,is1) = (dpipj(is2,ip1) - xpi(is1))/2
endif
piDpj(is1,ip1) = piDpj(ip1,is1)
ier0 = ier
ier1 = max(ier1,ier0)
*
* pi.s(i+1)
*
if ( abs(xpi(ip1)) .le. xpi(is2) ) then
piDpj(ip1,is2) = (dpipj(is2,is1) + xpi(ip1))/2
else
piDpj(ip1,is2) = (dpipj(ip1,is1) + xpi(is2))/2
endif
piDpj(is2,ip1) = piDpj(ip1,is2)
ier0 = ier
ier1 = max(ier1,ier0)
*
* p(i+2).s(i)
*
if ( abs(xpi(ip3)) .le. xpi(is1) ) then
piDpj(ip3,is1) = (dpipj(is1,is3) + xpi(ip3))/2
else
piDpj(ip3,is1) = (dpipj(ip3,is3) + xpi(is1))/2
endif
if ( is1 .eq. 2 .or. is1 .eq. 3 )
+ piDpj(ip3,is1) = -piDpj(ip3,is1)
piDpj(is1,ip3) = piDpj(ip3,is1)
ier0 = ier
ier1 = max(ier1,ier0)
*
* #] all in one vertex:
* #[ all in one 3point:
*
* pi.s(i+2)
*
if ( min(abs(dpipj(is2,is1)),abs(dpipj(ip3,ip2))) .le.
+ min(abs(dpipj(ip3,is1)),abs(dpipj(is2,ip2))) ) then
piDpj(ip1,is3) = (dpipj(ip3,ip2) + dpipj(is2,is1))/2
else
piDpj(ip1,is3) = (dpipj(ip3,is1) + dpipj(is2,ip2))/2
endif
piDpj(is3,ip1) = piDpj(ip1,is3)
ier0 = ier
ier1 = max(ier1,ier0)
*
* p(i+1).s(i)
*
if ( min(abs(dpipj(is3,is2)),abs(dpipj(ip1,ip3))) .le.
+ min(abs(dpipj(ip1,is2)),abs(dpipj(is3,ip3))) ) then
piDpj(ip2,is1) = (dpipj(ip1,ip3) + dpipj(is3,is2))/2
else
piDpj(ip2,is1) = (dpipj(ip1,is2) + dpipj(is3,ip3))/2
endif
piDpj(is1,ip2) = piDpj(ip2,is1)
ier0 = ier
ier1 = max(ier1,ier0)
*
* p(i+2).s(i+1)
*
if ( min(abs(dpipj(is1,is3)),abs(dpipj(ip2,ip1))) .le.
+ min(abs(dpipj(ip2,is3)),abs(dpipj(is1,ip1))) ) then
piDpj(ip3,is2) = (dpipj(ip2,ip1) + dpipj(is1,is3))/2
else
piDpj(ip3,is2) = (dpipj(ip2,is3) + dpipj(is1,ip1))/2
endif
if ( is1 .eq. 2 .or. is1 .eq. 3 )
+ piDpj(ip3,is2) = -piDpj(ip3,is2)
piDpj(is2,ip3) = piDpj(ip3,is2)
ier0 = ier
ier1 = max(ier1,ier0)
*
* #] all in one 3point:
* #[ all external 3point:
if ( idot.le.0 ) then
*
* pi.p(i+1)
*
if ( abs(xpi(ip2)) .le. abs(xpi(ip1)) ) then
piDpj(ip1,ip2) = (dpipj(ip3,ip1) - xpi(ip2))/2
else
piDpj(ip1,ip2) = (dpipj(ip3,ip2) - xpi(ip1))/2
endif
piDpj(ip2,ip1) = piDpj(ip1,ip2)
ier0 = ier
ier1 = max(ier1,ier0)
*
* p(i+1).p(i+2)
*
if ( abs(xpi(ip3)) .le. abs(xpi(ip2)) ) then
piDpj(ip2,ip3) = (dpipj(ip1,ip2) - xpi(ip3))/2
else
piDpj(ip2,ip3) = (dpipj(ip1,ip3) - xpi(ip2))/2
endif
if ( is1 .eq. 2 .or. is1 .eq. 3 )
+ piDpj(ip2,ip3) = -piDpj(ip2,ip3)
piDpj(ip3,ip2) = piDpj(ip2,ip3)
ier0 = ier
ier1 = max(ier1,ier0)
*
* p(i+2).p(i)
*
if ( abs(xpi(ip1)) .le. abs(xpi(ip3)) ) then
piDpj(ip3,ip1) = (dpipj(ip2,ip3) - xpi(ip1))/2
else
piDpj(ip3,ip1) = (dpipj(ip2,ip1) - xpi(ip3))/2
endif
if ( is1 .eq. 2 .or. is1 .eq. 3 )
+ piDpj(ip3,ip1) = -piDpj(ip3,ip1)
piDpj(ip1,ip3) = piDpj(ip3,ip1)
ier0 = ier
ier1 = max(ier1,ier0)
*
else
*
* idot > 0: copy the dotproducts from fpij4
*
piDpj(ip1,ip2) = isgrot(iold(ip1,irota4),irota4)*
+ isgrot(iold(ip2,irota4),irota4)*
+ fpij4(iold(ip1,irota4),iold(ip2,irota4))
piDpj(ip2,ip1) = piDpj(ip1,ip2)
piDpj(ip1,ip3) = isgrot(iold(ip1,irota4),irota4)*
+ isgrot(iold(ip3,irota4),irota4)*
+ fpij4(iold(ip1,irota4),iold(ip3,irota4))
piDpj(ip3,ip1) = piDpj(ip1,ip3)
piDpj(ip2,ip3) = isgrot(iold(ip2,irota4),irota4)*
+ isgrot(iold(ip3,irota4),irota4)*
+ fpij4(iold(ip2,irota4),iold(ip3,irota4))
piDpj(ip3,ip2) = piDpj(ip2,ip3)
endif
10 continue
* #] all external 3point:
* #[ real 4point:
*
* the awkward 4point dotproducts:
*
piDpj(9,9) = xpi(9)
piDpj(10,10) = xpi(10)
if ( idot.le.0 ) then
*--#[ p5.p7:
if ( abs(xpi(7)) .lt. abs(xpi(5)) ) then
piDpj(5,7) = (-xpi(7) - dpipj(5,11))/2
else
piDpj(5,7) = (-xpi(5) - dpipj(7,11))/2
endif
xmax = min(abs(xpi(5)),abs(xpi(7)))
if ( abs(piDpj(5,7)) .lt. xloss*xmax ) then
*
* second try (old algorithm)
*
if ( min(abs(dpipj(6,9)),abs(dpipj(8,10))) .le.
+ min(abs(dpipj(8,9)),abs(dpipj(6,10))) ) then
som = (dpipj(6,9) + dpipj(8,10))/2
else
som = (dpipj(8,9) + dpipj(6,10))/2
endif
xmxp = min(abs(dpipj(6,9)),abs(dpipj(8,9)))
if ( xmxp.lt.xmax ) then
piDpj(5,7) = som
xmax = xmxp
endif
ier0 = ier
ier1 = max(ier1,ier0)
endif
piDpj(7,5) = piDpj(5,7)
*--#] p5.p7:
*--#[ p6.p8:
if ( abs(xpi(6)) .lt. abs(xpi(8)) ) then
piDpj(6,8) = (-xpi(6) - dpipj(8,11))/2
else
piDpj(6,8) = (-xpi(8) - dpipj(6,11))/2
endif
xmax = min(abs(xpi(6)),abs(xpi(8)))
if ( abs(piDpj(6,8)) .lt. xloss*xmax ) then
*
* second try (old algorithm)
*
if ( min(abs(dpipj(5,9)),abs(dpipj(7,10))) .le.
+ min(abs(dpipj(7,9)),abs(dpipj(5,10))) ) then
som = (dpipj(5,9) + dpipj(7,10))/2
else
som = (dpipj(7,9) + dpipj(5,10))/2
endif
xmxp = min(abs(dpipj(5,9)),abs(dpipj(7,9)))
if ( xmxp.lt.xmax ) then
piDpj(6,8) = som
xmax = xmxp
endif
ier0 = ier
ier1 = max(ier1,ier0)
endif
piDpj(8,6) = piDpj(6,8)
*--#] p6.p8:
*--#[ p9.p10:
if ( abs(xpi(9)) .lt. abs(xpi(10)) ) then
piDpj(9,10) = (-xpi(9) - dpipj(10,13))/2
else
piDpj(9,10) = (-xpi(10) - dpipj(9,13))/2
endif
xmax = min(abs(xpi(9)),abs(xpi(10)))
if ( abs(piDpj(9,10)) .lt. xloss*xmax ) then
*
* second try (old algorithm)
*
if ( min(abs(dpipj(5,6)),abs(dpipj(7,8))) .le.
+ min(abs(dpipj(7,6)),abs(dpipj(5,8))) ) then
som = (dpipj(5,6) + dpipj(7,8))/2
else
som = (dpipj(7,6) + dpipj(5,8))/2
endif
xmxp = min(abs(dpipj(5,6)),abs(dpipj(7,6)))
if ( xmxp.lt.xmax ) then
piDpj(9,10) = som
xmax = xmxp
endif
ier0 = ier
ier1 = max(ier1,ier0)
endif
piDpj(10,9) = piDpj(9,10)
*--#] p9.p10:
else
*--#[ copy:
*
* idot > 1: just copy from fpij4...
*
piDpj(5,7) = isgrot(iold(5,irota4),irota4)*
+ isgrot(iold(7,irota4),irota4)*
+ fpij4(iold(5,irota4),iold(7,irota4))
piDpj(7,5) = piDpj(5,7)
piDpj(6,8) = isgrot(iold(6,irota4),irota4)*
+ isgrot(iold(8,irota4),irota4)*
+ fpij4(iold(6,irota4),iold(8,irota4))
piDpj(8,6) = piDpj(6,8)
piDpj(9,10)= isgrot(iold(9,irota4),irota4)*
+ isgrot(iold(10,irota4),irota4)*
+ fpij4(iold(9,irota4),iold(10,irota4))
piDpj(10,9) = piDpj(9,10)
*--#] copy:
endif
ier = ier1
* #] real 4point:
*###] ffdot4:
end
*###[ ffgdt4:
subroutine ffgdt4(piDpj,xpip,dpipjp,xpi,ier)
***#[*comment:***********************************************************
* *
* calculate the dotproducts pi.pj with *
* and store results in common when asked for *
* *
* pi = si i1=1,4 *
* pi = p(i-3) i1=5,10 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE PRECISION piDpj(10,10),xpip(13),dpipjp(10,13),xpi(13)
integer ier
*
* local variables
*
integer i,j,ii(6)
DOUBLE PRECISION dl3p
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ get dotproducts:
*
* Calculate the dotproducts
*
call ffdot4(piDpj,xpip,dpipjp,10,ier)
if ( ldot .and. idot.lt.3 ) then
do 65 i=1,10
do 64 j=1,10
fpij4(iold(j,irota4),iold(i,irota4)) =
+ isgrot(iold(j,irota4),irota4)*
+ isgrot(iold(i,irota4),irota4)*piDpj(j,i)
64 continue
65 continue
endif
if ( ldot ) then
if ( abs(idot).lt.2 ) then
ii(1)= 5
ii(2)= 6
ii(3)= 7
ii(4)= 8
ii(5)= 9
ii(6)= 10
fidel3 = ier
call ffdl3p(dl3p,piDpj,10,ii,ii)
fdel3 = dl3p
else
dl3p = fdel3
endif
if ( dl3p .lt. 0 ) then
call fferr(44,ier)
print *,'overall vertex has del3 ',dl3p
print *,'xpi = ',xpi
endif
endif
* #] get dotproducts:
*###] ffgdt4:
end
diff --git a/Looptools/D/ffxd0i.F b/Looptools/D/ffxd0i.F
--- a/Looptools/D/ffxd0i.F
+++ b/Looptools/D/ffxd0i.F
@@ -1,159 +1,162 @@
+#include "externals.h"
+
+
*###[ ffx2ir:
subroutine ffx2ir(cs1,cs2,xpip,dpipjp,ier)
***#[*comment:***********************************************************
* *
* Get the terms to correct for the second IR pole which is *
* treated incorrectly if the first one is regulated with a small *
* mass lam and they are adjacent. It is assumed that xpi(3)= *
* xpi(4)=xpi(7)=0, xpi(1)=xpi(8), xpi(2)=xpi(6). The correction *
* terms are *
* *
* cs1 = -C0(m2^2,0,lam^2;m2^2,0,p10^2)/(s-m1^2) *
* cs2 = +C0(m2^2,lam^2,0;m2^2,0,p10^2)/(s-m1^2) *
* *
* when xpi(4) = lambda is taken in the D0, *
* *
* cs1 = -C0(lam^2,0,m1^2;0,m1^2,p9^2)/(t-m2^2) *
* cs2 = +C0(0,lam^2,m1^2;0,m1^2,p9^2)/(t-m2^2) *
* *
* when xpi(3) = lambda. Not yet tested. *
* *
* 10-oct-1991 Geert Jan van Oldenborgh *
* *
* Input: xpip(13) (real) usual 4point pi.pi *
* dpipjp(10,13) (real) xpip(i) - xpip(j) *
* output: xpip(13) (real) usual 4point pi.pi modified *
* dpipjp(10,13) (real) xpip(i) - xpip(j) modified *
* cs1,cs2 (complex) *
* ier (integer) *
* calls: ffxc0 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cs1,cs2
DOUBLE PRECISION xpip(13),dpipjp(10,13)
*
* local vars
*
integer itest,ier0,ier1,i,j,iinx(6,4)
DOUBLE COMPLEX cc0
DOUBLE PRECISION xpi3(6),dpipj3(6,6)
save itest,iinx
*
* common
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
* 3=put mass on xpi(3)
* 4=put mass on xpi(4)
data itest /4/
data iinx /2,3,4,6,7,10,
+ 1,3,4,9,7,8,
+ 1,2,4,5,10,8,
+ 1,2,3,5,6,9/
*
* #] declarations:
* #[ work 3:
if ( itest .eq. 3 ) then
*
* modify xpip,dpipjp
*
xpip(3) = lambda
do 10 i=1,10
dpipjp(i,3) = dpipjp(i,3) - lambda
10 continue
do 20 i=1,13
dpipjp(3,i) = dpipjp(3,i) + lambda
20 continue
*
* call first C0
*
do 120 i=1,6
xpi3(i) = xpip(iinx(i,2))
do 110 j=1,6
dpipj3(j,i) = dpipjp(iinx(j,2),iinx(i,2))
110 continue
120 continue
idsub = idsub + 1
ier1 = 0
call ffxc0a(cc0,xpi3,dpipj3,ier1)
cs1 = -cc0/DBLE(dpipjp(9,2))
*
* call second C0
*
xpi3(2) = 0
xpi3(3) = lambda
do 130 i=1,6
dpipj3(i,2) = dpipj3(i,2) + lambda
dpipj3(i,3) = dpipj3(i,3) - lambda
130 continue
do 140 i=1,6
dpipj3(2,i) = dpipj3(2,i) - lambda
dpipj3(3,i) = dpipj3(3,i) + lambda
140 continue
idsub = idsub + 1
ier0 = 0
call ffxc0a(cc0,xpi3,dpipj3,ier0)
cs2 = +cc0/DBLE(dpipjp(9,2))
ier1 = max(ier1,ier0)
ier = ier + ier1
* #] work 3:
* #[ work 4:
elseif ( itest .eq. 4 ) then
*
* modify xpip,dpipjp
*
xpip(4) = lambda
do 210 i=1,10
dpipjp(i,4) = dpipjp(i,4) - lambda
210 continue
do 220 i=1,13
dpipjp(4,i) = dpipjp(4,i) + lambda
220 continue
*
* call first C0
*
do 320 i=1,6
xpi3(i) = xpip(iinx(i,1))
do 310 j=1,6
dpipj3(j,i) = dpipjp(iinx(j,1),iinx(i,1))
310 continue
320 continue
idsub = idsub + 1
ier1 = 0
call ffxc0a(cc0,xpi3,dpipj3,ier1)
cs1 = -cc0/DBLE(dpipjp(10,1))
*
* call second C0
*
xpi3(3) = 0
xpi3(2) = lambda
do 330 i=1,6
dpipj3(i,3) = dpipj3(i,3) + lambda
dpipj3(i,2) = dpipj3(i,2) - lambda
330 continue
do 340 i=1,6
dpipj3(3,i) = dpipj3(3,i) - lambda
dpipj3(2,i) = dpipj3(2,i) + lambda
340 continue
idsub = idsub + 1
ier0 = 0
call ffxc0a(cc0,xpi3,dpipj3,ier0)
cs2 = +cc0/DBLE(dpipjp(10,1))
ier1 = max(ier1,ier0)
ier = ier + ier1
* #] work 4:
* #[ error:
else
print *,'ffx2ir: error: itest should be either 3 or 4!',itest
endif
* #] error:
*###] ffx2ir:
end
diff --git a/Looptools/D/ffxd0m0.F b/Looptools/D/ffxd0m0.F
--- a/Looptools/D/ffxd0m0.F
+++ b/Looptools/D/ffxd0m0.F
@@ -1,70 +1,73 @@
+#include "externals.h"
+
+
*###[ ffxd0m0:
subroutine ffxd0m0(cd0, xpi, ier)
***#[*comment:***********************************************************
* *
* D0 function for 4 masses = 0 *
* input parameters as for ffxd0 *
* *
* algorithm taken from *
* Denner, Nierste, Scharf, Nucl. Phys. B367 (1991) 637-656 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE PRECISION xpi(13)
DOUBLE COMPLEX cd0
integer ier
DOUBLE PRECISION a, b, c, d
DOUBLE COMPLEX x(2), z(2), k1, k2, t1, t2
DOUBLE COMPLEX dl1, dl2, zl, ww, tlg
DOUBLE COMPLEX k12, k23, k34, k14, k13, k24
integer j, ipi1(2), ipi2(2), nffeta
- include 'ff.h'
+#include "ff.h"
a = xpi(10)*xpi(7)
b = xpi(9)*xpi(10) + xpi(5)*xpi(7) - xpi(8)*xpi(6)
c = xpi(5)*xpi(9)
d = -xpi(6)
k1 = DCMPLX(c, precx*d)
k2 = sqrt(b*b - 4*a*k1)
x(1) = (-b - k2)/2D0/a
x(2) = (-b + k2)/2D0/a
if( abs(x(1)) .gt. abs(x(2)) ) then
x(2) = k1/(a*x(1))
else
x(1) = k1/(a*x(2))
endif
k12 = DCMPLX(-xpi(5), -precx)
k13 = DCMPLX(-xpi(9), -precx)
k23 = DCMPLX(-xpi(6), -precx)
k34 = DCMPLX(-xpi(7), -precx)
k14 = DCMPLX(-xpi(8), -precx)
k24 = DCMPLX(-xpi(10), -precx)
k1 = k34/k13
k2 = k24/k12
ww = log(k12) + log(k13) - log(k14) - log(k23)
do 100 j = 1, 2
t1 = 1 + k1*x(j)
t2 = 1 + k2*x(j)
call ffzzdl(dl1, ipi1(j), zl, t1, ier)
call ffzzdl(dl2, ipi2(j), zl, t2, ier)
tlg = log(-x(j))
z(j) = tlg*(ww - .5D0*tlg) - dl1 - dl2 -
+ c2ipi*( nffeta(-x(j), k1, ier)*log(t1) +
+ nffeta(-x(j), k2, ier)*log(t2) )
100 continue
ww = z(2) - z(1) +
+ (ipi1(1) + ipi2(1) - ipi1(2) - ipi2(2))*pi12
cd0 = ww/(a*(x(1) - x(2)))
end
diff --git a/Looptools/D/ffxd0p.F b/Looptools/D/ffxd0p.F
--- a/Looptools/D/ffxd0p.F
+++ b/Looptools/D/ffxd0p.F
@@ -1,674 +1,677 @@
+#include "externals.h"
+
+
*(##[ ffxd0p:
subroutine ffxd0p(cs4,ipi12,isoort,cfac,xpi,dpipj,piDpj,
+ xqi,dqiqj,qiDqj,ai,daiaj,ldel2s,ier)
***#[*comment:***********************************************************
* *
* calculate D0/pi^2/(A1*A2*A3*A4/dt3t4) *
* *
* = C0(t1,t2,t3) - C0(t1,t2,t4) *
* *
* The transformed momenta of the fourpoint functions are *
* input. *
* *
* Input: xpi(10) untransformed fourpoint momenta *
* dpipj(10,10) differences of xpi *
* piDpj(10,10) dotproducts of xpi *
* xqi(10) transformed fourpoint momenta *
* dqiqj(10,10) differences of xqi *
* qiDqj(10,10) dotproducts of xqi *
* ai(4) the transformation parameters *
* daiaj(4,4) their deifferences *
* ldel2s if .TRUE. we took out factors delta *
* *
* Output: cs4(170) not added (assumed 0 on input) *
* cfac the factor of cs4 from C0 (ie lam(pi)) *
* ier 0=ok 1=inaccurate 2=error *
* *
* Calls: ffxc0p,ffpi34,ffxhck,ffdl3m,ffdel2,... *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cs4(175),cfac
- integer ipi12(26),isoort(16),ier
+ integer ipi12(28),isoort(16),ier
logical ldel2s
DOUBLE PRECISION xpi(10),dpipj(10,10),piDpj(10,10),
+ xqi(10),dqiqj(10,10),qiDqj(10,10),ai(4),daiaj(4,4)
*
* local variables
*
integer i,j,k,ip,jp,m,ilogi(6),ii(6,2),jj(6,2),ier0,ier1
DOUBLE COMPLEX c,clogi(6),cipi
DOUBLE PRECISION xpi3(6,3:4),dpipj3(6,6,3:4),piDpj3(6,6,3:4),
+ del2,del2s(3,3:4),del3(3:4),del3mi(6,3:4),
+ del4,etalam(3:4),etami(6,3:4),ddel2s(2:3),delpsi(3,3:4),
+ alph(3),blph(3),sdel2,hulp,som,s(4),smax,xmax
DOUBLE COMPLEX cpi(6,3:4),cpiDpj(6,6,3:4),cdpipj(6,6,3:4),
+ cetalm(3:4),cetami(6,3:4),calph(3),csdel2,
+ cel2s(3,3:4),celpsi(3,3:4),zqi(10),zqiDqj(10,10),
+ cddl2s(2:3)
logical lcroot
save ii,jj
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data ii/1,2,3,5,6,9,1,2,3,5,6,9/
data jj/1,2,4,5,10,8,1,2,4,5,10,8/
*
* #] declarations:
* #[ preparation:
* Note that the piDpj3(,,3) contain now the threepoint function
* with s3, (,,4) with s4 (and NOT *without* as before)
call ffpi43(xpi3(1,3),dpipj3(1,1,3),piDpj3(1,1,3),
+ xqi,dqiqj,qiDqj,7-3)
call ffpi43(xpi3(1,4),dpipj3(1,1,4),piDpj3(1,1,4),
+ xqi,dqiqj,qiDqj,7-4)
*
* set the logarithms to be calculated to -999
*
do 40 i=1,6
clogi(i) = 0
ilogi(i) = 0
40 continue
if ( ai(1) .lt. 0 .neqv. ai(2) .lt. 0 ) then
ilogi(1) = -999
ilogi(4) = -999
endif
if ( ai(2) .lt. 0 .neqv. ai(3) .lt. 0 ) then
ilogi(2) = -999
endif
if ( ai(3) .lt. 0 .neqv. ai(1) .lt. 0 ) then
ilogi(3) = -999
endif
if ( ai(2) .lt. 0 .neqv. ai(4) .lt. 0 ) then
ilogi(5) = -999
endif
if ( ai(4) .lt. 0 .neqv. ai(1) .lt. 0 ) then
ilogi(6) = -999
endif
*
* #] preparation:
* #[ determinants:
*
* some determinants
*
* note that not all errors are additive, only when a previous
* result is used as input do we need to add ther ier's, otherwise
* we can take the maximum value to get a decent estimate of the
* number of digits lost.
*
ier1 = ier
if ( .not.ldel2s ) then
ier0 = ier
call ffdel2(del2,qiDqj,10, 5,6,9, 0,ier0)
ier1 = max(ier1,ier0)
else
s(1) = xqi(5)*xqi(3)
s(2) = qiDqj(5,3)**2
del2 = s(1) - s(2)
if ( abs(del2) .lt. xloss*s(2) ) ier1 = 100
endif
if ( ier1 .ne. ier ) then
ier0 = ier
call ffdel4(del4,piDpj)
if ( ldel2s ) then
hulp = -(ai(1)*ai(2)*ai(3)*ai(4)/xqi(3))**2 * del4
else
hulp = -(2*ai(1)*ai(2)*ai(3)*ai(4)/dqiqj(3,4))**2 * del4
endif
del2 = hulp
ier1 = ier0
fdel4s = del4
else
if ( ldel2s ) then
fdel4s = -del2*(xqi(3)/ai(1)*ai(2)*ai(3)*ai(4))**2
else
fdel4s=-del2*(dqiqj(3,4)/(2*ai(1)*ai(2)*ai(3)*ai(4)))**2
endif
endif
if ( del2 .gt. 0 ) then
* use complex routines
* call fferr(44,ier)
lcroot = .TRUE.
sdel2 = isgnal*sqrt(del2)
csdel2 = DCMPLX(0D0,sdel2)
elseif ( del2 .eq. 0 ) then
call fferr(45,ier)
else
lcroot = .FALSE.
sdel2 = isgnal*sqrt(-del2)
endif
ier0 = ier
call ffdl3s(del3(3),piDpj,ii,10)
ier1 = max(ier0,ier1)
ier0 = ier
call ffdl3s(del3(4),piDpj,jj,10)
ier1 = max(ier1,ier0)
del3(3) = ai(1)**2*ai(2)**2*ai(3)**2*del3(3)
del3(4) = ai(1)**2*ai(2)**2*ai(4)**2*del3(4)
do 108 m=3,4
ier0 = ier
if ( .not.ldel2s ) then
call ffdl3m(del3mi(1,m),.TRUE.,del3(m),del2,xpi3(1,m)
+ ,dpipj3(1,1,m),piDpj3(1,1,m), 6, 4,5,6,1,3)
else
*
* the special case del2s = 0. Note that del3mi(i) and
* del3mi(i+3) are used in S_{i-1}.
*
call ffdl3m(del3mi(1,m),.FALSE.,0D0,0D0,xpi3(1,m),
+ dpipj3(1,1,m),piDpj3(1,1,m), 6, 4,3,0, 1,2)
ier1= max(ier1,ier0)
ier0 = ier
call ffdl3m(del3mi(5,m),.FALSE.,0D0,0D0,xpi3(1,m),
+ dpipj3(1,1,m),piDpj3(1,1,m), 6, 4,3,0, 5,2)
del3mi(3,m) = 0
del3mi(4,m) = 0
endif
ier1 = max(ier1,ier0)
do 105 i=1,3
j = i+1
if ( j .eq. 4 ) j = 1
ip = i
jp = j
if ( m .eq. 4 ) then
if ( jp .eq. 3 ) jp = 4
if ( ip .eq. 3 ) ip = 4
endif
if ( i.eq.1 .and. m.eq.4 ) then
del2s(1,4) = del2s(1,3)
else
ier0 = ier
call ffdel2(del2s(i,m),piDpj,10,inx(ip,jp),ip,
+ jp,1,ier0)
del2s(i,m) = ai(ip)**2*ai(jp)**2*del2s(i,m)
ier1 = max(ier1,ier0)
endif
k = i-1
if ( k .eq. 0 ) k = 3
ier0 = ier
if ( .not.ldel2s ) then
call ffdl2p(delpsi(i,m),xpi3(1,m),dpipj3(1,1,m),
+ piDpj3(1,1,m),i+3,j+3,k+3,i,j,k,6)
else
call ffdl2t(delpsi(i,m),qiDqj, m,5, ip,jp,inx(ip,jp)
+ ,+1,+1, 10)
endif
ier1 = max(ier1,ier0)
etami(i,m) = del3mi(i,m)/del2
if ( ldel2s .and. i.gt.1 )
+ etami(i+3,m) = del3mi(i+3,m)/del2
105 continue
etalam(m) = del3(m)/del2
108 continue
*
* the error analysis
*
ier = ier1
*
* get alpha,1-alpha
*
if ( .not. lcroot ) then
if ( .not.ldel2s ) then
if ( xpi3(5,3).eq.0 .and. (piDpj3(5,6,3).gt.0 .eqv.
+ sdel2.gt.0) ) then
alph(1) = -xpi3(6,3)/(piDpj3(5,6,3)+sdel2)
alph(3) = -xpi3(4,3)/(piDpj3(5,4,3)-sdel2)
else
call ffroot(blph(1),alph(1),xpi3(5,3),
+ -piDpj3(5,6,3),xpi3(6,3),sdel2,ier)
call ffroot(alph(3),blph(3),xpi3(5,3),
+ -piDpj3(5,4,3),xpi3(4,3),sdel2,ier)
endif
* We cannot change the sign as it is fixed by the choice
* of sign in fftrans (sqrt(delta(s3,s4))) WRONG
* if ( l4also .and. ( alph(1) .gt. 1 .or. alph(1) .lt. 0
* + ) .and. abs(blph(1)-.5D0) .lt. abs(alph(1)-.5D0) ) then
* alph(1) = blph(1)
* alph(3) = blph(3)
* sdel2 = -sdel2
* isgnal = -isgnal
* endif
else
alph(1) = 1
alph(3) = 0
endif
cfac = 2*sdel2
else
do 4 k=3,4
do 3 i=1,6
cpi(i,k) = xpi3(i,k)
do 2 j=1,6
cdpipj(j,i,k) = dpipj3(j,i,k)
cpiDpj(j,i,k) = piDpj3(j,i,k)
2 continue
3 continue
4 continue
if ( .not.ldel2s ) then
call ffcoot(c,calph(1),cpi(5,3),-cpiDpj(5,6,3),
+ cpi(6,3),csdel2,ier)
call ffcoot(calph(3),c,cpi(5,3),-cpiDpj(5,4,3),
+ cpi(4,3),csdel2,ier)
else
calph(1) = 1
calph(3) = 0
endif
cfac = 2*csdel2
endif
* #] determinants:
* #[ convert to complex:
if ( lcroot ) then
do 110 k=3,4
cetalm(k) = etalam(k)
do 109 i=1,3
cel2s(i,k) = del2s(i,k)
celpsi(i,k) = delpsi(i,k)
cetami(i,k) = etami(i,k)
109 continue
110 continue
endif
* #] convert to complex:
* #[ simple case:
if ( ldel2s .or. abs(dqiqj(3,4)) .lt. xloss*abs(xqi(3)) ) then
if ( .not.lsmug .and. (ldel2s .or. ldc3c4) ) goto 500
endif
*
* and the calculations
*
ier0 = ier
ier1 = ier
if ( lcroot ) then
call ffcc0p(cs4( 1),ipi12(1),isoort(1),clogi(1),ilogi(1),
+ cpi(1,3),cdpipj(1,1,3),cpiDpj(1,1,3),csdel2,cel2s(1,3),
+ cetalm(3),cetami(1,3),celpsi(1,3),calph,4,ier0)
call ffcc0p(cs4(81),ipi12(9),isoort(9),clogi(4),ilogi(4),
+ cpi(1,4),cdpipj(1,1,4),cpiDpj(1,1,4),csdel2,cel2s(1,4),
+ cetalm(4),cetami(1,4),celpsi(1,4),calph,4,ier1)
else
if ( lsmug ) call ffsm43(xpi3(1,3),7-3)
call ffxc0p(cs4( 1),ipi12(1),isoort(1),clogi(1),ilogi(1),
+ xpi3(1,3),dpipj3(1,1,3),piDpj3(1,1,3),sdel2,del2s(1,3),
+ etalam(3),etami(1,3),delpsi(1,3),alph,4,ier0)
if ( lsmug ) call ffsm43(xpi3(1,4),7-4)
call ffxc0p(cs4(81),ipi12(9),isoort(9),clogi(4),ilogi(4),
+ xpi3(1,4),dpipj3(1,1,4),piDpj3(1,1,4),sdel2,del2s(1,4),
+ etalam(4),etami(1,4),delpsi(1,4),alph,4,ier1)
endif
ier = max(ier0,ier1)
goto 600
* #] simple case:
* #[ cancellations:
500 continue
*
* There are cancellations between the dilogarithms or the vertex
* is on threshold.
* we need the differences ddel2s(i) = del2s(i,3)-del2s(i,4)
*
do 510 i=2,3
if ( i .eq. 2 ) then
j = 2
else
j = 1
endif
ddel2s(i) = del2s(i,3) - del2s(i,4)
xmax = abs(del2s(i,3))
if ( abs(ddel2s(i)) .ge. xloss*xmax ) goto 510
*
* Very first try with transformation
*
s(1) = (ai(3)+ai(4))*daiaj(3,4)*del2s(i,3)/ai(3)**2
s(2) = ai(j)**2*ai(4)**2*xpi(j)*dpipj(3,4)
s(3) = ai(j)**2*ai(4)**2*piDpj(j,7)*piDpj(j,3)
s(4) = ai(j)**2*ai(4)**2*piDpj(j,7)*piDpj(j,4)
som = s(1) + s(2) + s(3) + s(4)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)))
if ( abs(som) .ge. xloss*smax ) goto 510
if ( smax .lt. xmax ) then
ddel2s(i) = som
xmax = smax
endif
510 continue
if ( .not. lcroot ) then
call ffdxc0(cs4,ipi12,isoort,clogi,ilogi,xpi3,dpipj3,piDpj3,
+ xqi,qiDqj,sdel2,del2s,etalam,etami,delpsi,alph,
+ ddel2s,ldel2s,4,ier)
else
cddl2s(2) = ddel2s(2)
cddl2s(3) = ddel2s(3)
do 530 i=1,10
zqi(i) = xqi(i)
do 520 j=1,10
zqiDqj(j,i) = qiDqj(j,i)
520 continue
530 continue
call ffdcc0(cs4,ipi12,isoort,clogi,ilogi,cpi,cpiDpj,
+ zqi,zqiDqj,csdel2,cel2s,cetalm,cetami,celpsi,
+ calph,cddl2s,ldel2s,4,ier)
endif
600 continue
* #] cancellations:
* #[ Ai<0 terms:
cipi = DCMPLX(0D0,pi)
if ( ai(3) .lt. 0 .neqv. ai(4) .lt. 0 ) then
* we need the S term
if ( ai(1) .lt. 0 .eqv. ai(2) .lt. 0 ) then
if ( lcroot ) then
call ffcxra(cs4(167),ipi12(23),xqi,qiDqj,sdel2,1,ier)
else
* call ffxtro(cs4(167),ipi12(23),xqi,qiDqj,sdel2,1,ier)
call ffxtra(cs4(167),ipi12(23),xqi,qiDqj,sdel2,1,ier)
endif
else
if ( lcroot ) then
call ffcxra(cs4(167),ipi12(23),xqi,qiDqj,sdel2,2,ier)
- call ffcxra(cs4(169),ipi12(25),xqi,qiDqj,sdel2,3,ier)
+ call ffcxra(cs4(169),ipi12(26),xqi,qiDqj,sdel2,3,ier)
else
call ffxtra(cs4(167),ipi12(23),xqi,qiDqj,sdel2,2,ier)
- call ffxtra(cs4(169),ipi12(25),xqi,qiDqj,sdel2,3,ier)
+ call ffxtra(cs4(169),ipi12(26),xqi,qiDqj,sdel2,3,ier)
* call ffxtro(cs4(167),ipi12(23),xqi,qiDqj,sdel2,2,ier)
-* call ffxtro(cs4(169),ipi12(25),xqi,qiDqj,sdel2,3,ier)
+* call ffxtro(cs4(169),ipi12(26),xqi,qiDqj,sdel2,3,ier)
endif
endif
endif
*
* The normal correction terms
*
if ( ai(1) .lt. 0 .neqv. ai(2) .lt. 0 ) then
cs4(161) = -cipi*clogi(1)
ipi12(17) = 12*ilogi(1)
if ( ilogi(1) .eq. -999 ) call fferr(46,ier)
cs4(164) = cipi*clogi(4)
ipi12(20) = -12*ilogi(4)
if ( ilogi(4) .eq. -999 ) call fferr(46,ier)
endif
if ( ai(2) .lt. 0 .neqv. ai(3) .lt. 0 ) then
cs4(162) = -cipi*clogi(2)
ipi12(18) = 12*ilogi(2)
if ( ilogi(2) .eq. -999 ) call fferr(46,ier)
endif
if ( ai(3) .lt. 0 .neqv. ai(1) .lt. 0 ) then
cs4(163) = -cipi*clogi(3)
ipi12(19) = 12*ilogi(3)
if ( ilogi(3) .eq. -999 ) call fferr(46,ier)
endif
if ( ai(2) .lt. 0 .neqv. ai(4) .lt. 0 ) then
cs4(165) = cipi*clogi(5)
ipi12(21) = -12*ilogi(5)
if ( ilogi(5) .eq. -999 ) call fferr(46,ier)
endif
if ( ai(4) .lt. 0 .neqv. ai(1) .lt. 0 ) then
cs4(166) = cipi*clogi(6)
ipi12(22) = -12*ilogi(6)
if ( ilogi(6) .eq. -999 ) call fferr(46,ier)
endif
* #] Ai<0 terms:
*###] ffxd0p:
end
*###[ ffpi43:
subroutine ffpi43(xpi3,dpipj3,piDpj3,xpi,dpipj,piDpj,imiss)
***#[*comment:***********************************************************
* *
* Fill the threepoint arrays xpi3 and dpipj3 with masses from the *
* the fourpoint array xpi with leg imiss cut out. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE PRECISION xpi3(6),dpipj3(6,6),piDpj3(6,6)
DOUBLE PRECISION xpi(10),dpipj(10,10),piDpj(10,10)
integer imiss
*
* local variables
*
integer i,j
integer iinx(6,4)
save iinx
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data iinx /2,3,4,6,7,10,
+ 1,3,4,9,7,8,
+ 1,2,4,5,10,8,
+ 1,2,3,5,6,9/
* #] declarations:
* #[ calculations:
do 20 i=1,6
xpi3(i) = xpi(iinx(i,imiss))
do 10 j=1,6
dpipj3(j,i) = dpipj(iinx(j,imiss),iinx(i,imiss))
piDpj3(j,i) = piDpj(iinx(j,imiss),iinx(i,imiss))
10 continue
20 continue
* #] calculations:
*###] ffpi43:
end
*###[ ffxtra:
subroutine ffxtra(cs4,ipi12,xqi,qiDqj,sdel2,ii,ier)
***#[*comment:***********************************************************
* *
* calculate the extra terms S_ii^{\infty\prime}, put them in *
* cs4 and ipi12. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ipi12(3),ii,ier
DOUBLE COMPLEX cs4(3)
DOUBLE PRECISION xqi(10),qiDqj(10,10),sdel2
*
* local variables
*
integer i,ip(5)
DOUBLE PRECISION x(2,3),dfflo1,s,s1
external dfflo1
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data ip/5,6,8,5,6/
* #] declarations:
* #[ calculations:
if ( ii .eq. 3 ) return
do 10 i=1,3
if ( ii .eq. 1 .and. i .eq. 2 ) goto 10
call ffroot(x(1,i),x(2,i),xqi(ip(i)),-qiDqj(ip(i),
+ ip(i+1)),xqi(ip(i+1)),sdel2,ier)
s = -x(2,i)/x(1,i)
if ( abs(s-1) .lt. xloss ) then
s1 = dfflo1(-2*qiDqj(ip(i),ip(i+1))/(xqi(ip(i))*x(1,i)),
+ ier)
elseif ( s .gt. 0 ) then
s1 = log(s)
else
if ( abs(s+1) .lt. xloss ) then
s1 = dfflo1(-2*sdel2/(xqi(ip(i))*x(1,i)),ier)
else
s1 = log(-s)
endif
* also here an minus sign (-i*pi*log(-(p.p-sqrt)/(p.p+sqrt)))
if ( qiDqj(ip(i),ip(i+1))*xqi(ip(i))*sdel2 .gt. 0 ) then
ipi12(i) = +12
else
ipi12(i) = -12
endif
* ier = ier + 50
* print *,'ffxtra: imaginary part may well be wrong -> ',
* + 'n*pi^2 fout'
* print *,' ipi12(i) = ',ipi12(i)
* print *,' qiDqj = ',qiDqj(ip(i),ip(i+1))
* print *,' qi^2 = ',xqi(ip(i))
endif
* there is an overall minus compared with Veltman
cs4(i) = DCMPLX(0D0,-pi*s1)
if ( sdel2 .lt. 0 ) then
cs4(i) = -cs4(i)
ipi12(i) = -ipi12(i)
endif
if ( ii .ne. 1 ) then
cs4(i) = -cs4(i)
ipi12(i) = -ipi12(i)
endif
if ( i .eq. 2 ) then
cs4(i) = 2*cs4(i)
ipi12(i) = 2*ipi12(i)
endif
10 continue
* #] calculations:
*###] ffxtra:
end
*###[ ffcxra:
subroutine ffcxra(cs4,ipi12,xqi,qiDqj,sdel2,ii,ier)
***#[*comment:***********************************************************
* *
* calculate the extra terms S_ii^{\infty\prime}, put them in *
* cs4 and ipi12 for qi real but sdel2 complex. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ipi12(3),ii,ier
DOUBLE COMPLEX cs4(3)
DOUBLE PRECISION xqi(10),qiDqj(10,10),sdel2
*
* local variables
*
integer i,ip(5)
DOUBLE COMPLEX x(2,3),zfflo1,s,s1,c
DOUBLE PRECISION absc
external zfflo1
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data ip/5,6,8,5,6/
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ calculations:
if ( ii .eq. 3 ) return
do 10 i=1,3
if ( ii .eq. 1 .and. i .eq. 2 ) goto 10
x(1,i) = DCMPLX(-qiDqj(ip(i),ip(i+1))/xqi(ip(i)),
+ -sdel2/xqi(ip(i)))
x(2,i) = DCMPLX(-qiDqj(ip(i),ip(i+1))/xqi(ip(i)),
+ +sdel2/xqi(ip(i)))
s = -x(2,i)/x(1,i)
c = s-1
if ( absc(c) .lt. xloss ) then
s1 = zfflo1(DBLE(-2*qiDqj(ip(i),ip(i+1))/xqi(ip(i)))/
+ x(1,i),ier)
elseif ( abs(s+1) .lt. xloss ) then
s1 = zfflo1(DCMPLX(0D0,-2*sdel2/xqi(ip(i)))/x(1,i),ier)
if ( DIMAG(c).gt.0 ) then
ipi12(i) = +12
else
ipi12(i) = -12
endif
else
s1 = log(s)
endif
* there is an overall minus compared with Veltman
cs4(i) = DCMPLX(pi*DIMAG(s1),-pi*DBLE(s1))
if ( ii .ne. 1 ) then
cs4(i) = -cs4(i)
ipi12(i) = -ipi12(i)
endif
if ( sdel2 .lt. 0 ) then
cs4(i) = -cs4(i)
ipi12(i) = -ipi12(i)
endif
if ( i .eq. 2 ) then
cs4(i) = 2*cs4(i)
ipi12(i) = 2*ipi12(i)
endif
10 continue
* #] calculations:
*###] ffcxra:
end
*###[ ffsm43:
subroutine ffsm43(xpi3,imiss)
***#[*comment:***********************************************************
* *
* Distribute the smuggled 4point momenta to the 3point smuggled *
* momenta. Note that because of the common block smuggling this *
* cannot be included in ffpi43. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer imiss
DOUBLE PRECISION xpi3(6)
*
* local variables
*
integer i,j,iinx(6,4)
save iinx
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data iinx /2,3,4,6,7,10,
+ 1,3,4,9,7,8,
+ 1,2,4,5,10,8,
+ 1,2,3,5,6,9/
*
* #] declarations:
* #[ parcel out:
if ( lsmug ) then
*
* parcel out the smuggled diffs
*
do 30 i=1,3
j = mod(i,3)+1
if ( xpi3(j) .eq. 0 ) then
cmipj(i,i) = c2sisj(iinx(i,imiss),iinx(j,imiss))
elseif ( xpi3(i) .eq. 0 ) then
cmipj(j,i) = c2sisj(iinx(i,imiss),iinx(j,imiss))
endif
30 continue
endif
* #] parcel out:
*)##] ffsm43:
end
diff --git a/Looptools/D/ffxd0tra.F b/Looptools/D/ffxd0tra.F
new file mode 100644
--- /dev/null
+++ b/Looptools/D/ffxd0tra.F
@@ -0,0 +1,146 @@
+* ffd0tra.F
+* a special case of the D0 function
+* original code by Francesco Tramontano
+* this file is part of LoopTools
+* last modified 8 Dec 10 th
+
+#include "externals.h"
+
+
+ subroutine ffd0tra(res, S, T, ML2, ME2, ier)
+ implicit none
+ DOUBLE COMPLEX res
+ DOUBLE PRECISION S, T, ML2, ME2
+ integer ier
+
+c===============================c
+c c
+c p1 S p2 c
+c \ / c
+c \ / c S = (p1+p2)^2
+c \========/ c T = (p2+p3)^2
+c || || c ML2= mass-square of the particle in the loop
+c || || T c ME2= mass-square of the external particle p4
+c || || c
+c E========\ c
+c E ML2 \ c
+c E \ c
+c p3 c
+c p4^2=ME2 c
+c c
+c===============================c
+
+ DOUBLE COMPLEX xp, xm, ypS, ymS, ypT, ymT, ypE, ymE
+ DOUBLE COMPLEX xr, yr
+ integer iepsS, iepsT, iepsE
+
+ DOUBLE COMPLEX ffint3
+ external ffint3
+
+c PRINT *, "ML2=", ML2
+c PRINT *, "ME2=", ME2
+c PRINT *, "S=", S
+c PRINT *, "T=", T
+
+ call fftraroot(xm, xp, xr, -ML2*(ME2 - S - T)/(S*T))
+ call fftraroot(ymS, ypS, yr, ML2/S)
+ call fftraroot(ymT, ypT, yr, ML2/T)
+ call fftraroot(ymE, ypE, yr, ML2/ME2)
+
+ iepsS = 0
+ if( S .gt. 0 ) iepsS = 1
+
+ iepsT = 0
+ if( T .gt. 0 ) iepsT = 1
+
+ iepsE = 0
+ if( ME2 .gt. 0 ) iepsE = 1
+
+ res = (
+ & ffint3(ypS, xm, iepsS, ier) - ffint3(ypS, xp, iepsS, ier) +
+ & ffint3(ymS, xm, -iepsS, ier) - ffint3(ymS, xp, -iepsS, ier) +
+ & ffint3(ypT, xm, iepsT, ier) - ffint3(ypT, xp, iepsT, ier) +
+ & ffint3(ymT, xm, -iepsT, ier) - ffint3(ymT, xp, -iepsT, ier) -
+ & ffint3(ypE, xm, iepsE, ier) + ffint3(ypE, xp, iepsE, ier) -
+ & ffint3(ymE, xm, -iepsE, ier) + ffint3(ymE, xp, -iepsE, ier)
+ & )/(xr*S*T)
+ end
+
+************************************************************************
+
+ subroutine fftraroot(xm, xp, r, c)
+***#[*comment:***********************************************************
+* *
+* roots of quadratic equation x^2 + x + c == 0 *
+* *
+***#]*comment:***********************************************************
+* #[ declarations:
+ implicit none
+ DOUBLE COMPLEX xm, xp, r
+ DOUBLE PRECISION c
+* #] declarations:
+
+ r = sqrt(DCMPLX(1 - 4*c))
+ xp = .5D0*(1 + r)
+ xm = .5D0*(1 - r)
+c PRINT *, "c=", c
+c PRINT *, "r=", r
+c PRINT *, "xp=", xp
+c PRINT *, "xm=", xm
+ if( abs(xp) .gt. abs(xm) ) then
+ xm = c/xp
+ else
+ xp = c/xm
+ endif
+c PRINT *, "xp'=", xp
+c PRINT *, "xm'=", xm
+ end
+
+************************************************************************
+
+ DOUBLE COMPLEX function ffint3(y, x, ieps, ier)
+ implicit none
+ DOUBLE COMPLEX y, x
+ integer ieps, ier
+
+* compute \int_0^1 dz log(z - y)/(z - x)
+
+#include "ff.h"
+
+ DOUBLE COMPLEX arg1, arg2, dd1, dd2, zlog
+ integer ipi121, ipi122
+
+c DOUBLE PRECISION rarg1, rarg2
+c equivalence (arg1, rarg1), (arg2, rarg2)
+
+c DOUBLE PRECISION ddilog
+c DOUBLE COMPLEX li2
+c external ddilog, li2
+
+ if( DIMAG(x) .ne. 0 ) call ffwarn(258, ier, 1D0, 0D0)
+
+ arg1 = x/(x - y)
+ if( abs(DIMAG(arg1)) .lt. 1D-15 ) then
+ call ffzxdl(dd1, ipi121, zlog, arg1, ieps, ier)
+c dd1 = ddilog(rarg1)
+c if( rarg1 .gt. 1 )
+c & dd1 = dd1 + eps*sign(pi, x)*log(rarg1)*cI
+ else
+ call ffzzdl(dd1, ipi121, zlog, arg1, ier)
+c dd1 = li2(arg1)
+ endif
+
+ arg2 = (x - 1)/(x - y)
+ if( abs(DIMAG(arg2)) .lt. 1D-15 ) then
+ call ffzxdl(dd2, ipi122, zlog, arg2, ieps, ier)
+c dd2 = ddilog(rarg2)
+c if( rarg2 .gt. 1 )
+c & dd2 = dd2 - eps*sign(pi, 1 - x)*log(rarg2)*cI
+ else
+ call ffzzdl(dd2, ipi122, zlog, arg2, ier)
+c dd2 = li2(arg2)
+ endif
+
+ ffint3 = dd1 - dd2 + (ipi121 - ipi122)*pi12
+ end
+
diff --git a/Looptools/D/ffxdbd.F b/Looptools/D/ffxdbd.F
--- a/Looptools/D/ffxdbd.F
+++ b/Looptools/D/ffxdbd.F
@@ -1,832 +1,835 @@
+#include "externals.h"
+
+
*###[ ffxdir:
subroutine ffxdir(cs,cfac,idone,xpi,dpipj,ipoin,ndiv,ier)
***#[*comment:***********************************************************
* *
* Check if this 4point function is IRdivergent and if so, get it *
* using ffxdbd and set idone to 1 (or 2 if 2 IR poles) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ipoin,idone,ndiv,ier
DOUBLE COMPLEX cs,cfac
DOUBLE PRECISION xpi(13),dpipj(10,13)
*
* local variables
*
integer i,j,k,l,ier0,ii(6),notijk(4,4,4)
save notijk
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data notijk/
+ 0,0,0,0,0,0,4,3,0,4,0,2,0,3,2,0,0,0,4,3,0,0,0,0,4,0,0,1,3,0,1,0,
+ 0,4,0,2,4,0,0,1,0,0,0,0,2,1,0,0,0,3,2,0,3,0,1,0,2,1,0,0,0,0,0,0/
*
* #] declarations:
* #[ work:
*
idone = 0
do 25 i=1,4
if ( xpi(i) .ne. 0 ) goto 25
do 24 j=1,3
if ( j .eq. i ) goto 24
if ( dpipj(j,inx(j,i)) .ne. 0 ) goto 24
do 23 k=j+1,4
if ( k .eq. i ) goto 23
if ( dpipj(k,inx(k,i)) .ne. 0 ) goto 23
*
* we found an IR divergent function;
* first check whether it is linearly divergent
*
l = notijk(k,j,i)
*
* do we have a linear divergence on our hands?
*
if ( dpipj(l,inx(l,i)) .eq. 0 ) then
if ( ndiv.eq.-1 ) ndiv = 1
elseif ( ndiv.gt.0 ) then
cs = 0
cfac = 1
idone = 1
return
endif
*
* the complex case
*
if ( lsmug ) then
*
* use Wim & Ansgard's formulae whenever possible
*
if ( c2sisj(i,j).eq.0 .and. c2sisj(i,k).eq.0 )
+ then
call ffxdbd(cs,cfac,xpi,dpipj,i,j,k,l,ier)
goto 98
endif
if ( c2sisj(i,j).eq.0 .and. dpipj(i,inx(i,l))
+ .eq.0 .and. c2sisj(i,l).eq.0 ) then
call ffxdbd(cs,cfac,xpi,dpipj,i,j,l,k,ier)
goto 98
endif
if ( c2sisj(i,k).eq.0 .and. dpipj(i,inx(i,l))
+ .eq.0 .and. c2sisj(i,l).eq.0 ) then
call ffxdbd(cs,cfac,xpi,dpipj,i,k,l,j,ier)
goto 98
endif
*
* is it nasty?
*
if ( dpipj(i,inx(i,l)).eq.0 ) then
if ( c2sisj(j,i).eq.0 ) then
goto 99
elseif ( c2sisj(k,i).eq.0 ) then
goto 99
elseif ( c2sisj(l,i).eq.0 ) then
goto 99
else
call fferr(71,ier)
return
endif
endif
*
* then it just is logarithmiocally divergent
* let the ffxc0i handle this
*
else
*
* the real case
*
if ( dpipj(i,inx(i,l)).eq.0 ) then
call fferr(73,ier)
idone = 1
return
endif
call ffxdbd(cs,cfac,xpi,dpipj,i,j,k,l,ier)
goto 98
endif
23 continue
24 continue
25 continue
idone = 0
lnasty = .FALSE.
if ( ndiv.eq.-1 ) ndiv = 0
return
*
* clean up
*
98 continue
if ( ldot .and. ipoin.eq.4 ) then
ier0 = 0
if ( idot.lt.1 ) then
call ffdot4(fpij4,xpi,dpipj,10,ier0)
endif
ii(1)= 5
ii(2)= 6
ii(3)= 7
ii(4)= 8
ii(5)= 9
ii(6)= 10
if ( abs(idot).lt.2 ) then
fidel3 = ier0
call ffdl3p(fdel3,fpij4,10,ii,ii)
endif
endif
*
* and finito
*
if ( ndiv.eq.-1 ) ndiv = 0
idone = 1
if ( xpi(j) .eq. 0 .or. xpi(k) .eq. 0 ) idone = 2
if ( xpi(j) .eq. 0 .and. xpi(k) .eq. 0 ) idone = 3
return
*
* nasty - set some flags
*
99 continue
lnasty = .TRUE.
return
*
* #] work:
*###] ffxdir:
end
*###[ ffxdbd:
subroutine ffxdbd(csom,cfac,xpi,dpipj,ilam,i1,i4,ic,ier)
***#[*comment:***********************************************************
* *
* The IR divergent fourpoint function with real masses *
* according to Beenakker & Denner, Nucl.Phys.B338(1990)349. *
* *
* Input: xpi(13) real momenta^2 *
* dpipj(10,13) real xpi(i)-xpi(j) *
* ilam integer position of m=0 *
* i1,i4 integer position of other 2 IR masses *
* ic integer position of complex mass *
* lambda real cutoff to use instead of lam^2 *
* *
* Output: csom,cfac complex D0 = csom*cfac *
* ier integer number of digits lost *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ilam,i1,i4,ic,ier
DOUBLE COMPLEX csom,cfac
DOUBLE PRECISION xpi(13),dpipj(10,13)
*
* local variables
*
integer ier0,ier1,ipi12,ip,init,is,i2,i3,i,iepst,iepss,ieps2,
+ ieps3
DOUBLE PRECISION absc,xmax
DOUBLE PRECISION xxs(3),xxt(1),xx2(3),xx3(3),xm0,xm1,xm4,xlam,
+ d,dfflo1,fac
DOUBLE COMPLEX c,cs(21),z,zlg,som,cxt
DOUBLE COMPLEX zxfflg,zfflog
external dfflo1,zxfflg,zfflog
save init
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* data
*
data init /0/
*
* #] declarations:
* #[ check input:
*
if ( init .eq. 0 ) then
init = 1
print *,'ffxdbd: using IR cutoff lambda^2 = ',lambda
endif
if ( xpi(i1).eq.0 .or. xpi(i4).eq.0 ) then
call fferr(98,ier)
return
endif
*
* #] check input:
* #[ preliminaries:
*
csom = 0
cfac = 1
xm0 = sqrt(xpi(ic))
xm1 = sqrt(xpi(i1))
xm4 = sqrt(xpi(i4))
xlam = sqrt(lambda)
*
* #] preliminaries:
* #[ special case m0=0, m1=m2, m3=m4:
if ( xpi(ic) .eq. 0 ) then
*
* even more special case: 2 points of IR divergence:
*
if ( dpipj(i1,inx(ic,i1)).eq.0 .and.
+ dpipj(i4,inx(ic,i4)).eq.0 ) then
ier0 = 0
call ffxkfn(xxs,iepss,xpi(inx(i1,i4)),xm1,xm4,ier0)
if ( ier0.ge.100 ) then
call fferr(44,ier)
return
endif
ier = ier + ier0
if ( abs(xxs(2)).gt.xloss ) then
zlg = zxfflg(xxs(1),iepss,0D0,ier)
else
zlg = DBLE(dfflo1(xxs(2),ier))
endif
csom = -2*zlg*
+ zxfflg(-lambda/xpi(inx(ilam,ic)),-2,0D0,ier)
fac = xxs(1)/(xm1*xm4*xpi(inx(ilam,ic))*xxs(2)*xxs(3))
cfac = fac
if ( ldot .and. abs(idot).lt.4 ) then
fdel4s = 1/(16*fac**2)
endif
return
endif
* #] special case m0=0, m1=m2, m3=m4:
* #[ special case m0=0, m1=m2, m3!=m4:
if ( dpipj(i1,inx(ic,i1)).eq.0 .or.
+ dpipj(i4,inx(ic,i4)).eq.0 ) then
if ( dpipj(i1,inx(ic,i1)).ne.0 ) then
i = i4
i4 = i1
i1 = i
endif
*
* From Wim Beenakker, Priv.Comm.
*
ier0 = 0
call ffxkfn(xxs,iepss,xpi(inx(i1,i4)),xm1,xm4,ier0)
if ( ier0.ge.100 ) then
call fferr(44,ier)
return
endif
ier = ier + ier0
ier0 = ier
ier1 = ier
if ( abs(xxs(2)).gt.xloss ) then
zlg = zxfflg(xxs(1),iepss,0D0,ier0)
else
zlg = DBLE(dfflo1(xxs(2),ier0))
endif
cs(1) = zlg**2
ier1 = max(ier0,ier1)
ier0 = ier
if ( xxs(1)**2.lt.xloss ) then
cs(2) = -2*DBLE(dfflo1(xxs(1)**2,ier0))*zlg
else
cs(2) = -2*zxfflg(xxs(2)*xxs(3),0,0D0,ier0)*zlg
endif
ier1 = max(ier0,ier1)
ier0 = ier
cs(3) = zxfflg(lambda/xpi(i4),0,0D0,ier0)*zlg
ier1 = max(ier0,ier1)
ier0 = ier
cs(4) = 2*zxfflg(dpipj(inx(ic,i4),i4)/xpi(inx(ilam,ic)),
+ -1,dpipj(inx(ic,i4),i4),ier0)*zlg
ier1 = max(ier0,ier1)
ier0 = ier
call ffzxdl(cs(5),ip,zlg,xxs(1)**2,iepss,ier0)
cs(5) = -cs(5)
ipi12 = -ip + 2
ier1 = max(ier0,ier1)
ier = ier1
som = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) +
+ ipi12*DBLE(pi12)
xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
+ absc(cs(4)),absc(cs(5)))
csom = som
fac = -xxs(1)/(xm1*xm4*xpi(inx(ilam,ic))*xxs(2)*xxs(3))
cfac = fac
if ( ldot .and. abs(idot).lt.4 ) then
fdel4s = 1/(16*fac**2)
endif
return
endif
* #] special case m0=0, m1=m2, m3!=m4:
* #[ special case m0=0, m1!=m2, m3!=m4:
*
* This also crashes...
*
xm0 = precx*max(xm1,xm4)
endif
* #] special case m0=0, m1!=m2, m3!=m4:
* #[ get dimensionless vars:
*
* we follow the notation of Wim & Ansgar closely
* remember that for -pi we have ieps=+2 and v.v.
*
if ( lsmug ) then
* all is not what it seems
if ( nschem .ge. 3 ) then
cxt = DBLE(xm0*xlam)/c2sisj(ic,ilam)
else
cxt = DBLE(xm0*xlam)/DBLE(c2sisj(ic,ilam))
endif
else
if ( dpipj(ic,inx(ilam,ic)) .eq. 0 ) then
call fferr(73,ier)
return
endif
xxt(1) = xm0*xlam/dpipj(ic,inx(ilam,ic))
endif
iepst = -2
ier1 = 0
ier0 = 0
call ffxkfn(xxs,iepss,xpi(inx(i1,i4)),xm1,xm4,ier0)
ier1 = max(ier0,ier1)
ier0 = 0
call ffxkfn(xx2,ieps2,xpi(inx(i1,ic)),xm1,xm0,ier0)
ier1 = max(ier0,ier1)
ier0 = 0
call ffxkfn(xx3,ieps3,xpi(inx(i4,ic)),xm4,xm0,ier0)
ier1 = max(ier0,ier1)
if ( ier1 .ge. 100 ) then
call ffzdbd(csom,cfac,xpi,dpipj,ilam,i1,i4,ic,ier)
return
endif
ier = ier + ier1
*
* #] get dimensionless vars:
* #[ fill array:
*
ier1 = 0
ier0 = 0
zlg = zxfflg(xxs(1),iepss,0D0,ier)
d = xxs(1)**2
if ( abs(d) .lt. xloss ) then
cs(1) = 2*zlg*DBLE(dfflo1(d,ier0))
else
cs(1) = 2*zlg*zxfflg(xxs(2)*xxs(3),-iepss,0D0,ier0)
endif
ier1 = max(ier0,ier1)
ier0 = 0
if ( lsmug ) then
cs(2) = -2*zlg*zfflog(cxt,iepst,czero,ier0)
else
cs(2) = -2*zlg*zxfflg(xxt(1),iepst,0D0,ier0)
endif
ier1 = max(ier0,ier1)
*
ipi12 = 6
*
ier0 = 0
call ffzxdl(cs(3),ip,zlg,xxs(1)**2,iepss,ier0)
ipi12 = ipi12 + ip
ier1 = max(ier0,ier1)
ier0 = 0
if ( abs(xx2(2)) .gt. xloss ) then
z = zxfflg(xx2(1),ieps2,0D0,ier0)
else
z = dfflo1(xx2(2),ier0)
endif
cs(4) = z**2
ier1 = max(ier0,ier1)
ier0 = 0
if ( abs(xx3(2)) .gt. xloss ) then
z = zxfflg(xx3(1),ieps3,0D0,ier0)
else
z = dfflo1(xx3(2),ier0)
endif
cs(5) = z**2
ier1 = max(ier0,ier1)
*
is = 6
do 110 i2=-1,+1,2
do 100 i3=-1,+1,2
*
ier0 = 0
call ffzxdl(cs(is),ip,zlg,xxs(1)*xx2(1)**i2*xx3(1)**i3,
+ 0,ier0)
cs(is) = -cs(is)
ipi12 = ipi12 - ip
is = is + 1
ier1 = max(ier0,ier1)
*
ier0 = 0
if ( abs(xxs(2)) .gt. xloss ) then
cs(is) = -zlg*zxfflg(xxs(1),iepss,0D0,ier0)
else
cs(is) = -zlg*DBLE(dfflo1(xxs(2),ier0))
endif
is = is + 1
ier1 = max(ier0,ier1)
*
ier0 = 0
if ( abs(xx2(2)) .gt. xloss ) then
cs(is) = -zlg*zxfflg(xx2(1)**i2,i2*ieps2,0D0,ier0)
elseif ( i2.eq.1 ) then
cs(is) = -zlg*DBLE(dfflo1(xx2(2),ier0))
else
cs(is) = -zlg*DBLE(dfflo1(-xx2(2)/xx2(1),ier0))
endif
is = is + 1
ier1 = max(ier0,ier1)
*
ier0 = 0
if ( abs(xx3(2)) .gt. xloss ) then
cs(is) = -zlg*zxfflg(xx3(1)**i3,i3*ieps3,0D0,ier0)
elseif ( i3.eq.1 ) then
cs(is) = -zlg*DBLE(dfflo1(xx3(2),ier0))
else
cs(is) = -zlg*DBLE(dfflo1(-xx3(2)/xx3(1),ier0))
endif
is = is + 1
ier1 = max(ier0,ier1)
*
100 continue
110 continue
ier = ier + ier1
*
* #] fill array:
* #[ sum:
*
som = 0
xmax = 0
is = is - 1
do 200 i=1,is
som = som + cs(i)
xmax = max(xmax,absc(cs(i)))
200 continue
som = som + ipi12*DBLE(pi12)
*
* #] sum:
* #[ overall factors:
*
csom = som
if ( lsmug ) then
if ( nschem .ge. 2 ) then
cfac = -DBLE(xxs(1)/((xm1*xm4*xxs(2)*xxs(3))))/
+ c2sisj(ilam,ic)
else
cfac = -DBLE(xxs(1))/(DBLE(xm1*xm4*xxs(2)*xxs(3))*
+ DBLE(c2sisj(ilam,ic)))
endif
if ( ldot .and. abs(idot).lt.4 ) then
fdel4s = 16*(xm1*xm4*dpipj(inx(ilam,ic),ic)*xxs(2)*
+ xxs(3)/xxs(1))**2
endif
else
fac = xxs(1)/(xm1*xm4*dpipj(inx(ilam,ic),ic)*xxs(2)*xxs(3))
cfac = fac
if ( ldot .and. abs(idot).lt.4 ) then
fdel4s = 1/(16*fac**2)
endif
endif
*
* #] overall factors:
*###] ffxdbd:
end
*###[ ffxkfn:
subroutine ffxkfn(x,ieps,xpi,xm,xmp,ier)
***#[*comment:***********************************************************
* *
* Calculate the K-function in this paper: *
* *
* 1-sqrt(1-4*m*mp/(z-(m-mp)^2)) *
* K(p^2,m,mp) = ----------------------------- *
* 1+sqrt(1-4*m*mp/(z-(m-mp)^2)) *
* *
* and fill x(1) = -K, x(2) = 1+K, x(3) = 1-K *
* ieps gives the sign of the imaginary part: -2 -> +ieps and v.v. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ieps,ier
DOUBLE PRECISION x(3),xpi,xm,xmp
*
* local variables
*
DOUBLE PRECISION wortel,xx1,xx2,xx3
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ work:
*
* special case
*
if ( xpi.eq.0 .and. xm.eq.xmp ) then
x(1) = 1
x(2) = 0
x(3) = 2
return
endif
*
* normal case
*
xx1 = xpi - (xm-xmp)**2
xx2 = 1 - 4*xm*xmp/xx1
if ( xx2 .lt. 0 ) then
ier = ier + 100
return
endif
wortel = sqrt(xx2)
xx3 = 1/(1+wortel)
x(1) = -4*xm*xmp*xx3**2/xx1
x(2) = 2*xx3
x(3) = 2*wortel*xx3
*
ieps = -2
*
* #] work:
*###] ffxkfn:
end
*###[ ffzdbd:
subroutine ffzdbd(csom,cfac,xpi,dpipj,ilam,i1,i4,ic,ier)
***#[*comment:***********************************************************
* *
* The IR divergent fourpoint function with real masses *
* according to Beenakker & Denner, Nucl.Phys.B338(1990)349. *
* but in the case at least one of the roots is complex *
* *
* Input: xpi(13) real momenta^2 *
* dpipj(10,13) real xpi(i)-xpi(j) *
* ilam integer position of m=0 *
* i1,i4 integer position of other 2 IR masses *
* ic integer position of complex mass *
* lambda real cutoff to use instead of lam^2 *
* *
* Output: csom,cfac complex D0 = csom*cfac *
* ier integer number of digits lost *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ilam,i1,i4,ic,ier
DOUBLE COMPLEX csom,cfac
DOUBLE PRECISION xpi(13),dpipj(10,13)
*
* local variables
*
integer ier0,ier1,ipi12,ip,init,is,i2,i3,i,iepst,iepss,ieps2,
+ ieps3
DOUBLE PRECISION absc,xmax
DOUBLE PRECISION xm0,xm1,xm4,xlam,xxt(1)
DOUBLE COMPLEX c,cs(21),z,zlg,som,cxt,cxs(3),cx2(3),cx3(3)
DOUBLE COMPLEX zxfflg,zfflog,zfflo1
external zxfflg,zfflog,zfflo1
save init
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* data
*
data init /0/
*
* #] declarations:
* #[ check input:
*
if ( init .eq. 0 ) then
init = 1
print *,'ffzdbd: using IR cutoff lambda^2 = ',lambda
endif
*
* #] check input:
* #[ preliminaries:
*
xm0 = sqrt(xpi(ic))
xm1 = sqrt(xpi(i1))
xm4 = sqrt(xpi(i4))
xlam = sqrt(lambda)
*
* #] preliminaries:
* #[ get dimensionless vars:
*
* we follow the notation of Wim & Ansgar closely
* remember that for -pi we have ieps=+2 and v.v.
*
if ( lsmug ) then
* all is not what it seems
if ( nschem .ge. 3 ) then
cxt = DBLE(xm0*xlam)/c2sisj(ic,ilam)
else
cxt = DBLE(xm0*xlam)/DBLE(c2sisj(ic,ilam))
endif
else
xxt(1) = xm0*xlam/dpipj(ic,inx(ilam,ic))
endif
iepst = -2
ier1 = 0
ier0 = 0
call ffzkfn(cxs,iepss,xpi(inx(i1,i4)),xm1,xm4)
ier1 = max(ier0,ier1)
ier0 = 0
call ffzkfn(cx2,ieps2,xpi(inx(i1,ic)),xm1,xm0)
ier1 = max(ier0,ier1)
ier0 = 0
call ffzkfn(cx3,ieps3,xpi(inx(i4,ic)),xm4,xm0)
ier1 = max(ier0,ier1)
ier = ier + ier1
*
* #] get dimensionless vars:
* #[ fill array:
*
ier1 = 0
ier0 = 0
zlg = zfflog(cxs(1),iepss,czero,ier)
c = cxs(1)**2
if ( absc(c) .lt. xloss ) then
cs(1) = 2*zlg*zfflo1(c,ier0)
else
cs(1) = 2*zlg*zfflog(cxs(2)*cxs(3),-iepss,czero,ier0)
endif
ier1 = max(ier0,ier1)
ier0 = 0
if ( lsmug ) then
cs(2) = -2*zlg*zfflog(cxt,iepst,czero,ier0)
else
cs(2) = -2*zlg*zxfflg(xxt(1),iepst,0D0,ier0)
endif
ier1 = max(ier0,ier1)
*
ipi12 = 6
*
ier0 = 0
call ffzzdl(cs(3),ip,zlg,cxs(1)**2,ier0)
ipi12 = ipi12 + ip
ier1 = max(ier0,ier1)
ier0 = 0
z = zfflog(cx2(1),ieps2,czero,ier0)
cs(4) = z**2
ier1 = max(ier0,ier1)
ier0 = 0
z = zfflog(cx3(1),ieps3,czero,ier0)
cs(5) = z**2
ier1 = max(ier0,ier1)
*
is = 6
do 110 i2=-1,+1,2
do 100 i3=-1,+1,2
*
ier0 = 0
call ffzzdl(cs(is),ip,zlg,cxs(1)*cx2(1)**i2*cx3(1)**i3,
+ ier0)
cs(is) = -cs(is)
ipi12 = ipi12 - ip
is = is + 1
ier1 = max(ier0,ier1)
*
ier0 = 0
cs(is) = -zlg*zfflog(cxs(1),iepss,czero,ier0)
is = is + 1
ier1 = max(ier0,ier1)
*
ier0 = 0
cs(is) = -zlg*zfflog(cx2(1)**i2,i2*ieps2,czero,ier0)
is = is + 1
ier1 = max(ier0,ier1)
*
ier0 = 0
cs(is) = -zlg*zfflog(cx3(1)**i3,i3*ieps3,czero,ier0)
is = is + 1
ier1 = max(ier0,ier1)
*
100 continue
110 continue
ier = ier + ier1
*
* #] fill array:
* #[ sum:
*
som = 0
xmax = 0
is = is - 1
do 200 i=1,is
som = som + cs(i)
xmax = max(xmax,absc(cs(i)))
200 continue
som = som + ipi12*DBLE(pi12)
*
* #] sum:
* #[ overall factors:
*
csom = som
if ( lsmug ) then
if ( nschem .ge. 2 ) then
cfac = -cxs(1)/(DBLE(xm1*xm4)*cxs(2)*cxs(3)*
+ c2sisj(ilam,ic))
else
cfac = -cxs(1)/(DBLE(xm1*xm4)*cxs(2)*cxs(3)*
+ DBLE(c2sisj(ilam,ic)))
endif
if ( ldot .and. abs(idot).lt.4 ) then
c = 16*(DBLE(xm1*xm4*dpipj(inx(ilam,ic),ic))*
+ cxs(2)*cxs(3)/cxs(1))**2
fdel4s = DBLE(c)
if ( xloss*DIMAG(c) .gt. precc*DBLE(c) ) then
print *,'ffzdbd: error: Del4s is not real ',c
endif
endif
else
cfac = cxs(1)/(DBLE(xm1*xm4*dpipj(inx(ilam,ic),ic))*
+ cxs(2)*cxs(3))
if ( ldot .and. abs(idot).lt.4 ) then
fdel4s = 1/(16*DBLE(cfac)**2)
if ( xloss*abs(DIMAG(cfac)) .gt. precc*abs(DBLE(cfac)) )
+ then
print *,'ffzdbd: error: fac is not real: ',cfac
endif
endif
endif
*
* #] overall factors:
*###] ffzdbd:
end
*###[ ffzkfn:
subroutine ffzkfn(cx,ieps,xpi,xm,xmp)
***#[*comment:***********************************************************
* *
* Calculate the K-function in this paper: *
* *
* 1-sqrt(1-4*m*mp/(z-(m-mp)^2)) *
* K(p^2,m,mp) = ----------------------------- *
* 1+sqrt(1-4*m*mp/(z-(m-mp)^2)) *
* *
* and fill x(1) = -K, x(2) = 1+K, x(3) = 1-K *
* the roots are allowed to be imaginary *
* ieps gives the sign of the imaginary part: -2 -> +ieps and v.v. *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ieps
DOUBLE PRECISION xpi,xm,xmp
DOUBLE COMPLEX cx(3)
*
* local variables
*
DOUBLE PRECISION xx1,xx2
DOUBLE COMPLEX wortel,cx3
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ work:
*
xx1 = xpi - (xm-xmp)**2
xx2 = 1 - 4*xm*xmp/xx1
if ( xx2 .ge. 0 ) then
wortel = sqrt(xx2)
else
wortel = DCMPLX(DBLE(0),DBLE(sqrt(-xx2)))
endif
cx3 = 1/(1+wortel)
if ( xx1.eq.0 ) then
print *, 'ffzkfn: error: xx1=0, contact author'
cx(1) = 1/xclogm
else
cx(1) = DBLE(-4*xm*xmp/xx1)*cx3**2
endif
cx(2) = 2*cx3
cx(3) = 2*wortel*cx3
*
ieps = -2
*
* #] work:
*###] ffzkfn:
end
diff --git a/Looptools/E/E0.F b/Looptools/E/E0.F
--- a/Looptools/E/E0.F
+++ b/Looptools/E/E0.F
@@ -1,167 +1,169 @@
* E0.F
* the scalar four-point function
* this file is part of LoopTools
* written by M. Rauch
-* last modified 24 Jan 06 th
+* last modified 8 Dec 10 th
#include "defs.h"
#ifdef COMPLEXPARA
+#undef E0b
#define E0b E0C
#else
double complex function E0(p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
implicit none
DVAR p1, p2, p3, p4, p5
DVAR p1p2, p2p3, p3p4, p4p5, p5p1
DVAR m1, m2, m3, m4, m5
#include "lt.h"
double complex E0b
external E0b
double complex res(0:1), d0(5)
double precision xpi(20)
integer key, ier
key = ibits(versionkey, KeyE0, 2)
if( key .ne. 0 ) then
ier = 0
xpi(1) = m1
xpi(2) = m2
xpi(3) = m3
xpi(4) = m4
xpi(5) = m5
xpi(6) = p1
xpi(7) = p2
xpi(8) = p3
xpi(9) = p4
xpi(10) = p5
xpi(11) = p1p2
xpi(12) = p2p3
xpi(13) = p3p4
xpi(14) = p4p5
xpi(15) = p5p1
call ffxe0(res(1), d0, xpi, ier)
if( ier .gt. warndigits ) key = ior(key, 2)
endif
if( key .ne. 1 ) then
res(0) = E0b(p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
if( key .gt. 1 .and.
& abs(res(0) - res(1)) .gt. maxdev*abs(res(0)) ) then
print *, "Discrepancy in E0:"
print *, " p1 =", p1
print *, " p2 =", p2
print *, " p3 =", p3
print *, " p4 =", p4
print *, " p5 =", p5
print *, " p1p2 =", p1p2
print *, " p2p3 =", p2p3
print *, " p3p4 =", p3p4
print *, " p4p5 =", p4p5
print *, " p5p1 =", p5p1
print *, " m1 =", m1
print *, " m2 =", m2
print *, " m3 =", m3
print *, " m4 =", m4
print *, " m5 =", m5
print *, "E0 a =", res(0)
print *, "E0 b =", res(1)
endif
endif
E0 = res(iand(key, 1))
end
#endif
************************************************************************
* adapter code for C++
subroutine XE0sub(res, p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
implicit none
double complex res
DVAR p1, p2, p3, p4, p5
DVAR p1p2, p2p3, p3p4, p4p5, p5p1
DVAR m1, m2, m3, m4, m5
double complex XE0
external XE0
res = XE0(p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
end
************************************************************************
double complex function E0b(p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
implicit none
DVAR p1, p2, p3, p4, p5
DVAR p1p2, p2p3, p3p4, p4p5, p5p1
DVAR m1, m2, m3, m4, m5
#include "lt.h"
- QVAR Y(5,5), Yi(5,5), detYi(5)
+ QVAR Y(5,5), Yi(5,5), eta(5), detY
integer i, j
QVAR Yflat(25), Yiflat(25)
equivalence (Y, Yflat)
equivalence (Yi, Yiflat)
- QVAR XDet
double complex XD0
- external XDet, XD0
+ external XD0
- Y(1,1) = 2*QEXT(m1)
- Y(1,2) = QEXT(m1) + QEXT(m2) - QEXT(p1)
+ Y(1,1) = 2*QPREC(m1)
+ Y(2,2) = 2*QPREC(m2)
+ Y(3,3) = 2*QPREC(m3)
+ Y(4,4) = 2*QPREC(m4)
+ Y(5,5) = 2*QPREC(m5)
+ Y(1,2) = QPREC(m1) + QPREC(m2) - QPREC(p1)
Y(2,1) = Y(1,2)
- Y(1,3) = QEXT(m1) + QEXT(m3) - QEXT(p1p2)
+ Y(1,3) = QPREC(m1) + QPREC(m3) - QPREC(p1p2)
Y(3,1) = Y(1,3)
- Y(1,4) = QEXT(m1) + QEXT(m4) - QEXT(p4p5)
+ Y(1,4) = QPREC(m1) + QPREC(m4) - QPREC(p4p5)
Y(4,1) = Y(1,4)
- Y(1,5) = QEXT(m1) + QEXT(m5) - QEXT(p5)
+ Y(1,5) = QPREC(m1) + QPREC(m5) - QPREC(p5)
Y(5,1) = Y(1,5)
- Y(2,2) = 2*QEXT(m2)
- Y(2,3) = QEXT(m2) + QEXT(m3) - QEXT(p2)
+ Y(2,3) = QPREC(m2) + QPREC(m3) - QPREC(p2)
Y(3,2) = Y(2,3)
- Y(2,4) = QEXT(m2) + QEXT(m4) - QEXT(p2p3)
+ Y(2,4) = QPREC(m2) + QPREC(m4) - QPREC(p2p3)
Y(4,2) = Y(2,4)
- Y(2,5) = QEXT(m2) + QEXT(m5) - QEXT(p5p1)
+ Y(2,5) = QPREC(m2) + QPREC(m5) - QPREC(p5p1)
Y(5,2) = Y(2,5)
- Y(3,3) = 2*QEXT(m3)
- Y(3,4) = QEXT(m3) + QEXT(m4) - QEXT(p3)
+ Y(3,4) = QPREC(m3) + QPREC(m4) - QPREC(p3)
Y(4,3) = Y(3,4)
- Y(3,5) = QEXT(m3) + QEXT(m5) - QEXT(p3p4)
+ Y(3,5) = QPREC(m3) + QPREC(m5) - QPREC(p3p4)
Y(5,3) = Y(3,5)
- Y(4,4) = 2*QEXT(m4)
- Y(4,5) = QEXT(m4) + QEXT(m5) - QEXT(p4)
+ Y(4,5) = QPREC(m4) + QPREC(m5) - QPREC(p4)
Y(5,4) = Y(4,5)
- Y(5,5) = 2*QEXT(m5)
-
+
do i = 1, 5
do j = 1, 25
Yiflat(j) = Yflat(j)
enddo
do j = 1, 5
Yi(j,i) = 1
enddo
- detYi(i) = XDet(Yi, 5)
+ call XDet(5, Yi,5, eta(i))
enddo
+ call XDet(5, Y,5, detY)
+
E0b = -(
- & detYi(1)*XD0(p2, p3, p4, p5p1, p2p3, p3p4, m2, m3, m4, m5) +
- & detYi(2)*XD0(p1p2, p3, p4, p5, p4p5, p3p4, m1, m3, m4, m5) +
- & detYi(3)*XD0(p1, p2p3, p4, p5, p4p5, p5p1, m1, m2, m4, m5) +
- & detYi(4)*XD0(p1, p2, p3p4, p5, p1p2, p5p1, m1, m2, m3, m5) +
- & detYi(5)*XD0(p1, p2, p3, p4p5, p1p2, p2p3, m1, m2, m3, m4)
- & )/XDet(Y,5)
+ & eta(1)*XD0(p2, p3, p4, p5p1, p2p3, p3p4, m2, m3, m4, m5) +
+ & eta(2)*XD0(p1p2, p3, p4, p5, p4p5, p3p4, m1, m3, m4, m5) +
+ & eta(3)*XD0(p1, p2p3, p4, p5, p4p5, p5p1, m1, m2, m4, m5) +
+ & eta(4)*XD0(p1, p2, p3p4, p5, p1p2, p5p1, m1, m2, m3, m5) +
+ & eta(5)*XD0(p1, p2, p3, p4p5, p1p2, p2p3, m1, m2, m3, m4)
+ & )/detY
end
diff --git a/Looptools/E/Ecoeffa.F b/Looptools/E/Ecoeffa.F
--- a/Looptools/E/Ecoeffa.F
+++ b/Looptools/E/Ecoeffa.F
@@ -1,1471 +1,1472 @@
* Ecoeffa.F
* the five-point tensor coefficients
* this file is part of LoopTools
* written by M. Rauch
-* last modified 7 Dec 05 th
+* last modified 29 Sep 10 th
#include "defs.h"
subroutine XEcoeffa(para, E, ldpara)
implicit none
integer ldpara
DVAR para(ldpara,Pee)
double complex E(Nee)
#include "lt.h"
integer XDget
double complex XE0
- QVAR XDet
- external XDget, XE0, XDet
+ external XDget, XE0
DVAR p1, p2, p3, p4, p5
DVAR p1p2, p2p3, p3p4, p4p5, p5p1
DVAR m1, m2, m3, m4, m5
QVAR Y(5,5), Yi(5,5), Z(4,4), Zij(3,3)
QVAR eta(5), zeta(4,4), detY, detZ
double precision del, del4
integer i, j, k, l
integer Di1, Di2, Di3, Di4, Di5
logical dump
QVAR Yflat(25), Yiflat(25)
equivalence (Y, Yflat)
equivalence (Yi, Yiflat)
double complex help1, help2, help3, help4
double complex dabbr41, dabbr48, dabbr65, dabbr60, dabbr55
double complex dabbr50, dabbr49, dabbr45, dabbr42, dabbr10
double complex dabbr84, dabbr91, dabbr81, dabbr52, dabbr88
double complex dabbr77, dabbr90, dabbr46, dabbr87, dabbr74
double complex dabbr80, dabbr71, dabbr83, dabbr76, dabbr79
double complex dabbr43, dabbr70, dabbr73, dabbr35, dabbr37
double complex dabbr39, dabbr27, dabbr31, dabbr24, dabbr20
double complex dabbr16, dabbr30, dabbr13, dabbr23, dabbr26
double complex dabbr5, dabbr7, dabbr9, dabbr33, dabbr92
double complex dabbr89, dabbr86, dabbr85, dabbr82, dabbr78
double complex dabbr75, dabbr72, dabbr69, dabbr68, dabbr38
double complex dabbr36, dabbr34, dabbr32, dabbr29, dabbr28
double complex dabbr25, dabbr22, dabbr21, dabbr3, dabbr8
double complex dabbr6, dabbr4, dabbr1, dabbr61, dabbr66
double complex dabbr57, dabbr47, dabbr51, dabbr64, dabbr44
double complex dabbr56, dabbr59, dabbr14, dabbr17, dabbr19
double complex dabbr67, dabbr63, dabbr62, dabbr58, dabbr54
double complex dabbr53, dabbr11, dabbr18, dabbr15, dabbr12
double complex dabbr2, dabbr40
+#ifdef COMPLEXPARA
+ if( abs(DIMAG(para(1,1))) +
+ & abs(DIMAG(para(1,2))) +
+ & abs(DIMAG(para(1,3))) +
+ & abs(DIMAG(para(1,4))) +
+ & abs(DIMAG(para(1,5))) +
+ & abs(DIMAG(para(1,6))) +
+ & abs(DIMAG(para(1,7))) +
+ & abs(DIMAG(para(1,8))) +
+ & abs(DIMAG(para(1,9))) +
+ & abs(DIMAG(para(1,10))) .gt. 0 )
+ & print *, "Warning: complex momenta not implemented"
+ if( abs(DIMAG(para(1,11))) +
+ & abs(DIMAG(para(1,12))) +
+ & abs(DIMAG(para(1,13))) +
+ & abs(DIMAG(para(1,14))) +
+ & abs(DIMAG(para(1,15))) .eq. 0 ) then
+ call Ecoeffa(para, E, 2)
+ return
+ endif
+#endif
+
p1 = para(1,1)
p2 = para(1,2)
p3 = para(1,3)
p4 = para(1,4)
p5 = para(1,5)
p1p2 = para(1,6)
p2p3 = para(1,7)
p3p4 = para(1,8)
p4p5 = para(1,9)
p5p1 = para(1,10)
m1 = para(1,11)
m2 = para(1,12)
m3 = para(1,13)
m4 = para(1,14)
m5 = para(1,15)
-#ifdef COMPLEXPARA
- if( DIMAG(p1) .eq. 0 .and.
- & DIMAG(p2) .eq. 0 .and.
- & DIMAG(p3) .eq. 0 .and.
- & DIMAG(p4) .eq. 0 .and.
- & DIMAG(p5) .eq. 0 .and.
- & DIMAG(p1p2) .eq. 0 .and.
- & DIMAG(p2p3) .eq. 0 .and.
- & DIMAG(p3p4) .eq. 0 .and.
- & DIMAG(p4p5) .eq. 0 .and.
- & DIMAG(p5p1) .eq. 0 .and.
- & DIMAG(m1) .eq. 0 .and.
- & DIMAG(m2) .eq. 0 .and.
- & DIMAG(m3) .eq. 0 .and.
- & DIMAG(m4) .eq. 0 .and.
- & DIMAG(m5) .eq. 0 ) then
- call Ecoeffa(para, E, 2)
- return
- endif
-#endif
-
Di1 = XDget(p2, p3, p4, p5p1, p2p3, p3p4, m2, m3, m4, m5)
Di1 = XDget(p2, p3, p4, p5p1, p2p3, p3p4, m2, m3, m4, m5)
Di2 = XDget(p1p2, p3, p4, p5, p4p5, p3p4, m1, m3, m4, m5)
Di3 = XDget(p1, p2p3, p4, p5, p4p5, p5p1, m1, m2, m4, m5)
Di4 = XDget(p1, p2, p3p4, p5, p1p2, p5p1, m1, m2, m3, m5)
Di5 = XDget(p1, p2, p3, p4p5, p1p2, p2p3, m1, m2, m3, m4)
serial = serial + 1
dump = ibits(debugkey, DebugE, 1) .ne. 0 .and.
& serial .ge. debugfrom .and. serial .le. debugto
if( dump ) call XDumpPara(5, para, ldpara, "Ecoeffa")
- Y(1,1) = 2*QEXT(m1)
- Y(2,2) = 2*QEXT(m2)
- Y(3,3) = 2*QEXT(m3)
- Y(4,4) = 2*QEXT(m4)
- Y(5,5) = 2*QEXT(m5)
- Y(1,2) = QEXT(m1) + QEXT(m2) - QEXT(p1)
+ Y(1,1) = 2*QPREC(m1)
+ Y(2,2) = 2*QPREC(m2)
+ Y(3,3) = 2*QPREC(m3)
+ Y(4,4) = 2*QPREC(m4)
+ Y(5,5) = 2*QPREC(m5)
+ Y(1,2) = QPREC(m1) + QPREC(m2) - QPREC(p1)
Y(2,1) = Y(1,2)
- Y(1,3) = QEXT(m1) + QEXT(m3) - QEXT(p1p2)
+ Y(1,3) = QPREC(m1) + QPREC(m3) - QPREC(p1p2)
Y(3,1) = Y(1,3)
- Y(1,4) = QEXT(m1) + QEXT(m4) - QEXT(p4p5)
+ Y(1,4) = QPREC(m1) + QPREC(m4) - QPREC(p4p5)
Y(4,1) = Y(1,4)
- Y(1,5) = QEXT(m1) + QEXT(m5) - QEXT(p5)
+ Y(1,5) = QPREC(m1) + QPREC(m5) - QPREC(p5)
Y(5,1) = Y(1,5)
- Y(2,3) = QEXT(m2) + QEXT(m3) - QEXT(p2)
+ Y(2,3) = QPREC(m2) + QPREC(m3) - QPREC(p2)
Y(3,2) = Y(2,3)
- Y(2,4) = QEXT(m2) + QEXT(m4) - QEXT(p2p3)
+ Y(2,4) = QPREC(m2) + QPREC(m4) - QPREC(p2p3)
Y(4,2) = Y(2,4)
- Y(2,5) = QEXT(m2) + QEXT(m5) - QEXT(p5p1)
+ Y(2,5) = QPREC(m2) + QPREC(m5) - QPREC(p5p1)
Y(5,2) = Y(2,5)
- Y(3,4) = QEXT(m3) + QEXT(m4) - QEXT(p3)
+ Y(3,4) = QPREC(m3) + QPREC(m4) - QPREC(p3)
Y(4,3) = Y(3,4)
- Y(3,5) = QEXT(m3) + QEXT(m5) - QEXT(p3p4)
+ Y(3,5) = QPREC(m3) + QPREC(m5) - QPREC(p3p4)
Y(5,3) = Y(3,5)
- Y(4,5) = QEXT(m4) + QEXT(m5) - QEXT(p4)
+ Y(4,5) = QPREC(m4) + QPREC(m5) - QPREC(p4)
Y(5,4) = Y(4,5)
* calculate the Y(i), their determinants, and eta(i)
do i = 1, 5
do j = 1, 25
Yiflat(j) = Yflat(j)
enddo
do j = 1, 5
Yi(j,i) = 1
enddo
- eta(i) = XDet(Yi, 5)
+ call XDet(5, Yi,5, eta(i))
enddo
* Y is no longer needed, now calculate its determinant and
* add the missing factor 1/detY to eta
- detY = XDet(Y, 5)
+ call XDet(5, Y,5, detY)
do i = 1, 5
eta(i) = eta(i)/detY
enddo
- Z(1,1) = 2*QEXT(p1)
- Z(2,2) = 2*QEXT(p1p2)
- Z(3,3) = 2*QEXT(p4p5)
- Z(4,4) = 2*QEXT(p5)
- Z(1,2) = QEXT(p1) + QEXT(p1p2) - QEXT(p2)
+ Z(1,1) = 2*QPREC(p1)
+ Z(2,2) = 2*QPREC(p1p2)
+ Z(3,3) = 2*QPREC(p4p5)
+ Z(4,4) = 2*QPREC(p5)
+ Z(1,2) = QPREC(p1) + QPREC(p1p2) - QPREC(p2)
Z(2,1) = Z(1,2)
- Z(1,3) = QEXT(p1) - QEXT(p2p3) + QEXT(p4p5)
+ Z(1,3) = QPREC(p1) - QPREC(p2p3) + QPREC(p4p5)
Z(3,1) = Z(1,3)
- Z(1,4) = QEXT(p1) - QEXT(p5p1) + QEXT(p5)
+ Z(1,4) = QPREC(p1) - QPREC(p5p1) + QPREC(p5)
Z(4,1) = Z(1,4)
- Z(2,3) = QEXT(p1p2) - QEXT(p3) + QEXT(p4p5)
+ Z(2,3) = QPREC(p1p2) - QPREC(p3) + QPREC(p4p5)
Z(3,2) = Z(2,3)
- Z(2,4) = QEXT(p1p2) - QEXT(p3p4) + QEXT(p5)
+ Z(2,4) = QPREC(p1p2) - QPREC(p3p4) + QPREC(p5)
Z(4,2) = Z(2,4)
- Z(3,4) = QEXT(p5) + QEXT(p4p5) - QEXT(p4)
+ Z(3,4) = QPREC(p5) + QPREC(p4p5) - QPREC(p4)
Z(4,3) = Z(3,4)
* calculate the zeta(i,j)
do i = 1, 4
do j = i, 4
* generate the submatrix Z_ij
- do k = 1, 3
- do l = 1, 3
+ do l = 1, 3
+ do k = 1, 3
Zij(k,l) = Z(k + ibits(not(k - i), 3, 1),
& l + ibits(not(l - j), 3, 1))
enddo
enddo
- zeta(i,j) = Sgn(i + j)*XDet(Zij, 3)/detY
+ call XDet(3, Zij,3, detZ)
+ zeta(i,j) = Sgn(i + j)*detZ/detY
zeta(j,i) = zeta(i,j)
enddo
enddo
- detZ = XDet(Z, 4)
+ call XDet(4, Z,4, detZ)
- del = (delta + log(mudim))/6D0
+ del = (delta + log(mudim))/24D0
del4 = .25D0*del
help1 = Dval(dd003,Di1) + 2*Dval(dd0033,Di1) +
& Dval(dd00333,Di1)
help2 = Dval(dd002,Di1) + 2*Dval(dd0023,Di1) +
& Dval(dd00233,Di1)
help3 = Dval(dd001,Di1) + 2*Dval(dd0013,Di1) +
& Dval(dd00133,Di1)
help4 = Dval(dd00,Di1) + 2*Dval(dd003,Di1) +
& Dval(dd0033,Di1)
dabbr41 = Dval(dd00223,Di1) + Dval(dd00233,Di1)
dabbr48 = Dval(dd00113,Di1) + Dval(dd00133,Di1)
dabbr65 = Dval(dd0023,Di1) + Dval(dd00123,Di1)
dabbr60 = Dval(dd0013,Di1) + Dval(dd00123,Di1)
dabbr55 = Dval(dd0012,Di1) + Dval(dd00123,Di1)
dabbr50 = Dval(dd00112,Di1) + Dval(dd00122,Di1)
dabbr49 = Dval(dd2233,Di1) + Dval(dd2333,Di1)
dabbr45 = Dval(dd2223,Di1) + Dval(dd2233,Di1)
dabbr42 = Dval(dd1223,Di1) + Dval(dd1233,Di1)
dabbr10 = Dval(dd223,Di1) + Dval(dd233,Di1)
dabbr84 = Dval(dd0033,Di1) + Dval(dd00233,Di1) +
& Dval(dd00333,Di1)
dabbr91 = Dval(dd0033,Di1) + Dval(dd00133,Di1) +
& Dval(dd00333,Di1)
dabbr81 = dabbr41 + Dval(dd0023,Di1)
dabbr52 = Dval(dd0033,Di1) + Dval(dd00133,Di1) +
& Dval(dd00233,Di1)
dabbr88 = dabbr65 + Dval(dd00233,Di1)
dabbr77 = Dval(dd0022,Di1) + Dval(dd00222,Di1) +
& Dval(dd00223,Di1)
dabbr90 = dabbr65 + Dval(dd00223,Di1)
dabbr46 = Dval(dd0022,Di1) + Dval(dd00122,Di1) +
& Dval(dd00223,Di1)
dabbr87 = Dval(dd0022,Di1) + Dval(dd00122,Di1) +
& Dval(dd00222,Di1)
dabbr74 = dabbr60 + Dval(dd00133,Di1)
dabbr80 = dabbr48 + Dval(dd0013,Di1)
dabbr71 = dabbr55 + Dval(dd00122,Di1)
dabbr83 = dabbr60 + Dval(dd00113,Di1)
dabbr76 = dabbr55 + Dval(dd00112,Di1)
dabbr79 = dabbr50 + Dval(dd0012,Di1)
dabbr43 = Dval(dd0011,Di1) + Dval(dd00112,Di1) +
& Dval(dd00113,Di1)
dabbr70 = Dval(dd0011,Di1) + Dval(dd00111,Di1) +
& Dval(dd00113,Di1)
dabbr73 = Dval(dd0011,Di1) + Dval(dd00111,Di1) +
& Dval(dd00112,Di1)
dabbr35 = (Dval(dd0000,Di1) - del) +
& (Dval(dd00002,Di1) + del4) +
& (Dval(dd00003,Di1) + del4)
dabbr37 = (Dval(dd0000,Di1) - del) +
& (Dval(dd00001,Di1) + del4) +
& (Dval(dd00003,Di1) + del4)
dabbr39 = (Dval(dd0000,Di1) - del) +
& (Dval(dd00001,Di1) + del4) +
& (Dval(dd00002,Di1) + del4)
dabbr27 = Dval(dd003,Di1) + Dval(dd0023,Di1) +
& Dval(dd0033,Di1)
dabbr31 = Dval(dd003,Di1) + Dval(dd0013,Di1) +
& Dval(dd0033,Di1)
dabbr24 = Dval(dd002,Di1) + Dval(dd0022,Di1) +
& Dval(dd0023,Di1)
dabbr20 = Dval(dd003,Di1) + Dval(dd0013,Di1) +
& Dval(dd0023,Di1)
dabbr16 = Dval(dd002,Di1) + Dval(dd0012,Di1) +
& Dval(dd0023,Di1)
dabbr30 = Dval(dd002,Di1) + Dval(dd0012,Di1) +
& Dval(dd0022,Di1)
dabbr13 = Dval(dd001,Di1) + Dval(dd0012,Di1) +
& Dval(dd0013,Di1)
dabbr23 = Dval(dd001,Di1) + Dval(dd0011,Di1) +
& Dval(dd0013,Di1)
dabbr26 = Dval(dd001,Di1) + Dval(dd0011,Di1) +
& Dval(dd0012,Di1)
dabbr5 = Dval(dd00,Di1) + Dval(dd002,Di1) +
& Dval(dd003,Di1)
dabbr7 = Dval(dd00,Di1) + Dval(dd001,Di1) +
& Dval(dd003,Di1)
dabbr9 = Dval(dd00,Di1) + Dval(dd001,Di1) +
& Dval(dd002,Di1)
dabbr33 = dabbr35 + (Dval(dd00001,Di1) + del4)
dabbr92 = Dval(dd333,Di1) + Dval(dd1333,Di1) +
& Dval(dd2333,Di1) + Dval(dd3333,Di1)
dabbr89 = dabbr49 + Dval(dd233,Di1) + Dval(dd1233,Di1)
dabbr86 = dabbr45 + Dval(dd223,Di1) + Dval(dd1223,Di1)
dabbr85 = Dval(dd222,Di1) + Dval(dd1222,Di1) +
& Dval(dd2222,Di1) + Dval(dd2223,Di1)
dabbr82 = Dval(dd133,Di1) + Dval(dd1133,Di1) +
& Dval(dd1233,Di1) + Dval(dd1333,Di1)
dabbr78 = dabbr42 + Dval(dd123,Di1) + Dval(dd1123,Di1)
dabbr75 = Dval(dd122,Di1) + Dval(dd1122,Di1) +
& Dval(dd1222,Di1) + Dval(dd1223,Di1)
dabbr72 = Dval(dd113,Di1) + Dval(dd1113,Di1) +
& Dval(dd1123,Di1) + Dval(dd1133,Di1)
dabbr69 = Dval(dd112,Di1) + Dval(dd1112,Di1) +
& Dval(dd1122,Di1) + Dval(dd1123,Di1)
dabbr68 = Dval(dd111,Di1) + Dval(dd1111,Di1) +
& Dval(dd1112,Di1) + Dval(dd1113,Di1)
dabbr38 = dabbr27 + Dval(dd0013,Di1)
dabbr36 = dabbr24 + Dval(dd0012,Di1)
dabbr34 = dabbr13 + Dval(dd0011,Di1)
dabbr32 = Dval(dd33,Di1) + Dval(dd133,Di1) +
& Dval(dd233,Di1) + Dval(dd333,Di1)
dabbr29 = dabbr10 + Dval(dd23,Di1) + Dval(dd123,Di1)
dabbr28 = Dval(dd22,Di1) + Dval(dd122,Di1) +
& Dval(dd222,Di1) + Dval(dd223,Di1)
dabbr25 = Dval(dd13,Di1) + Dval(dd113,Di1) +
& Dval(dd123,Di1) + Dval(dd133,Di1)
dabbr22 = Dval(dd12,Di1) + Dval(dd112,Di1) +
& Dval(dd122,Di1) + Dval(dd123,Di1)
dabbr21 = Dval(dd11,Di1) + Dval(dd111,Di1) +
& Dval(dd112,Di1) + Dval(dd113,Di1)
dabbr3 = dabbr5 + Dval(dd001,Di1)
dabbr8 = Dval(dd3,Di1) + Dval(dd13,Di1) +
& Dval(dd23,Di1) + Dval(dd33,Di1)
dabbr6 = Dval(dd2,Di1) + Dval(dd12,Di1) +
& Dval(dd22,Di1) + Dval(dd23,Di1)
dabbr4 = Dval(dd1,Di1) + Dval(dd11,Di1) +
& Dval(dd12,Di1) + Dval(dd13,Di1)
dabbr1 = Dval(dd0,Di1) + Dval(dd1,Di1) +
& Dval(dd2,Di1) + Dval(dd3,Di1)
dabbr61 = help1 + 2*Dval(dd0023,Di1) +
& Dval(dd00223,Di1) + 2*Dval(dd00233,Di1)
dabbr66 = help1 + 2*Dval(dd0013,Di1) +
& Dval(dd00113,Di1) + 2*Dval(dd00133,Di1)
dabbr57 = help2 + 2*Dval(dd0022,Di1) +
& Dval(dd00222,Di1) + 2*Dval(dd00223,Di1)
dabbr47 = help2 + 2*Dval(dd0012,Di1) +
& Dval(dd00112,Di1) + 2*Dval(dd00123,Di1)
dabbr51 = Dval(dd003,Di1) + 2*Dval(dd0013,Di1) +
& 2*Dval(dd0023,Di1) + Dval(dd00113,Di1) +
& 2*Dval(dd00123,Di1) + Dval(dd00223,Di1)
dabbr64 = Dval(dd002,Di1) + 2*Dval(dd0012,Di1) +
& 2*Dval(dd0022,Di1) + Dval(dd00112,Di1) +
& 2*Dval(dd00122,Di1) + Dval(dd00222,Di1)
dabbr44 = help3 + 2*Dval(dd0012,Di1) +
& Dval(dd00122,Di1) + 2*Dval(dd00123,Di1)
dabbr56 = help3 + 2*Dval(dd0011,Di1) +
& Dval(dd00111,Di1) + 2*Dval(dd00113,Di1)
dabbr59 = Dval(dd001,Di1) + 2*Dval(dd0011,Di1) +
& 2*Dval(dd0012,Di1) + Dval(dd00111,Di1) +
& 2*Dval(dd00112,Di1) + Dval(dd00122,Di1)
dabbr14 = help4 + 2*Dval(dd002,Di1) +
& Dval(dd0022,Di1) + 2*Dval(dd0023,Di1)
dabbr17 = help4 + 2*Dval(dd001,Di1) +
& Dval(dd0011,Di1) + 2*Dval(dd0013,Di1)
dabbr19 = Dval(dd00,Di1) + 2*Dval(dd001,Di1) +
& 2*Dval(dd002,Di1) + Dval(dd0011,Di1) +
& 2*Dval(dd0012,Di1) + Dval(dd0022,Di1)
dabbr67 = Dval(dd33,Di1) + 2*Dval(dd133,Di1) +
& 2*Dval(dd233,Di1) + 2*Dval(dd333,Di1) +
& Dval(dd1133,Di1) + 2*Dval(dd1233,Di1) +
& 2*Dval(dd1333,Di1) + Dval(dd2233,Di1) +
& 2*Dval(dd2333,Di1) + Dval(dd3333,Di1)
dabbr63 = Dval(dd23,Di1) + 2*Dval(dd123,Di1) +
& 2*Dval(dd223,Di1) + 2*Dval(dd233,Di1) +
& Dval(dd1123,Di1) + 2*Dval(dd1223,Di1) +
& 2*Dval(dd1233,Di1) + Dval(dd2223,Di1) +
& 2*Dval(dd2233,Di1) + Dval(dd2333,Di1)
dabbr62 = Dval(dd22,Di1) + 2*Dval(dd122,Di1) +
& 2*Dval(dd222,Di1) + 2*Dval(dd223,Di1) +
& Dval(dd1122,Di1) + 2*Dval(dd1222,Di1) +
& 2*Dval(dd1223,Di1) + Dval(dd2222,Di1) +
& 2*Dval(dd2223,Di1) + Dval(dd2233,Di1)
dabbr58 = Dval(dd13,Di1) + 2*Dval(dd113,Di1) +
& 2*Dval(dd123,Di1) + 2*Dval(dd133,Di1) +
& Dval(dd1113,Di1) + 2*Dval(dd1123,Di1) +
& 2*Dval(dd1133,Di1) + Dval(dd1223,Di1) +
& 2*Dval(dd1233,Di1) + Dval(dd1333,Di1)
dabbr54 = Dval(dd12,Di1) + 2*Dval(dd112,Di1) +
& 2*Dval(dd122,Di1) + 2*Dval(dd123,Di1) +
& Dval(dd1112,Di1) + 2*Dval(dd1122,Di1) +
& 2*Dval(dd1123,Di1) + Dval(dd1222,Di1) +
& 2*Dval(dd1223,Di1) + Dval(dd1233,Di1)
dabbr53 = Dval(dd11,Di1) + 2*Dval(dd111,Di1) +
& 2*Dval(dd112,Di1) + 2*Dval(dd113,Di1) +
& Dval(dd1111,Di1) + 2*Dval(dd1112,Di1) +
& 2*Dval(dd1113,Di1) + Dval(dd1122,Di1) +
& 2*Dval(dd1123,Di1) + Dval(dd1133,Di1)
dabbr11 = dabbr14 + 2*Dval(dd001,Di1) +
& Dval(dd0011,Di1) + 2*Dval(dd0012,Di1) +
& 2*Dval(dd0013,Di1)
dabbr18 = Dval(dd3,Di1) + 2*Dval(dd13,Di1) +
& 2*Dval(dd23,Di1) + 2*Dval(dd33,Di1) +
& Dval(dd113,Di1) + 2*Dval(dd123,Di1) +
& 2*Dval(dd133,Di1) + Dval(dd223,Di1) +
& 2*Dval(dd233,Di1) + Dval(dd333,Di1)
dabbr15 = Dval(dd2,Di1) + 2*Dval(dd12,Di1) +
& 2*Dval(dd22,Di1) + 2*Dval(dd23,Di1) +
& Dval(dd112,Di1) + 2*Dval(dd122,Di1) +
& 2*Dval(dd123,Di1) + Dval(dd222,Di1) +
& 2*Dval(dd223,Di1) + Dval(dd233,Di1)
dabbr12 = Dval(dd1,Di1) + 2*Dval(dd11,Di1) +
& 2*Dval(dd12,Di1) + 2*Dval(dd13,Di1) +
& Dval(dd111,Di1) + 2*Dval(dd112,Di1) +
& 2*Dval(dd113,Di1) + Dval(dd122,Di1) +
& 2*Dval(dd123,Di1) + Dval(dd133,Di1)
dabbr2 = Dval(dd0,Di1) + 2*Dval(dd1,Di1) +
& 2*Dval(dd2,Di1) + 2*Dval(dd3,Di1) +
& Dval(dd11,Di1) + 2*Dval(dd12,Di1) +
& 2*Dval(dd13,Di1) + Dval(dd22,Di1) +
& 2*Dval(dd23,Di1) + Dval(dd33,Di1)
dabbr40 = Dval(dd0,Di1) + 4*Dval(dd1,Di1) +
& 4*Dval(dd2,Di1) + 4*Dval(dd3,Di1) +
& 6*Dval(dd11,Di1) + 12*Dval(dd12,Di1) +
& 12*Dval(dd13,Di1) + 6*Dval(dd22,Di1) +
& 12*Dval(dd23,Di1) + 6*Dval(dd33,Di1) +
& 4*Dval(dd111,Di1) + 12*Dval(dd112,Di1) +
& 12*Dval(dd113,Di1) + 12*Dval(dd122,Di1) +
& 24*Dval(dd123,Di1) + 12*Dval(dd133,Di1) +
& 4*Dval(dd222,Di1) + 12*Dval(dd223,Di1) +
& 12*Dval(dd233,Di1) + 4*Dval(dd333,Di1) +
& Dval(dd1111,Di1) + 4*Dval(dd1112,Di1) +
& 4*Dval(dd1113,Di1) + 6*Dval(dd1122,Di1) +
& 12*Dval(dd1123,Di1) + 6*Dval(dd1133,Di1) +
& 4*Dval(dd1222,Di1) + 12*Dval(dd1223,Di1) +
& 12*Dval(dd1233,Di1) + 4*Dval(dd1333,Di1) +
& Dval(dd2222,Di1) + 4*Dval(dd2223,Di1) +
& 6*Dval(dd2233,Di1) + 4*Dval(dd2333,Di1) +
& Dval(dd3333,Di1)
E(ee0) = XE0(p1, p2, p3, p4, p5, p1p2, p2p3, p3p4,
& p4p5, p5p1, m1, m2, m3, m4, m5)
E(ee1) = dabbr1*eta(1) - eta(3)*Dval(dd1,Di3) -
& eta(4)*Dval(dd1,Di4) - eta(5)*Dval(dd1,Di5) +
& 2*(zeta(1,1)*Dval(dd00,Di2) +
& zeta(1,2)*Dval(dd00,Di3) +
& zeta(1,3)*Dval(dd00,Di4) +
& zeta(1,4)*Dval(dd00,Di5) -
& (zeta(1,1) + zeta(1,2) + zeta(1,3) + zeta(1,4))*
& Dval(dd00,Di1))
E(ee2) = -(eta(2)*Dval(dd1,Di2)) -
& eta(4)*Dval(dd2,Di4) - eta(5)*Dval(dd2,Di5) -
& eta(1)*Dval(dd1,Di1) +
& 2*zeta(1,2)*Dval(dd00,Di2) +
& 2*zeta(2,2)*Dval(dd00,Di3) +
& 2*zeta(2,3)*Dval(dd00,Di4) +
& 2*zeta(2,4)*Dval(dd00,Di5) -
& 2*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00,Di1)
E(ee3) = -(eta(2)*Dval(dd2,Di2)) -
& eta(3)*Dval(dd2,Di3) - eta(5)*Dval(dd3,Di5) -
& eta(1)*Dval(dd2,Di1) +
& 2*zeta(1,3)*Dval(dd00,Di2) +
& 2*zeta(2,3)*Dval(dd00,Di3) +
& 2*zeta(3,3)*Dval(dd00,Di4) +
& 2*zeta(3,4)*Dval(dd00,Di5) -
& 2*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00,Di1)
E(ee4) = -(eta(2)*Dval(dd3,Di2)) -
& eta(3)*Dval(dd3,Di3) - eta(4)*Dval(dd3,Di4) -
& eta(1)*Dval(dd3,Di1) +
& 2*zeta(1,4)*Dval(dd00,Di2) +
& 2*zeta(2,4)*Dval(dd00,Di3) +
& 2*zeta(3,4)*Dval(dd00,Di4) +
& 2*zeta(4,4)*Dval(dd00,Di5) -
& 2*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00,Di1)
E(ee00) = -(eta(2)*Dval(dd00,Di2)) -
& eta(3)*Dval(dd00,Di3) - eta(4)*Dval(dd00,Di4) -
& eta(5)*Dval(dd00,Di5) - eta(1)*Dval(dd00,Di1)
E(ee11) = -(dabbr2*eta(1)) - eta(3)*Dval(dd11,Di3) -
& eta(4)*Dval(dd11,Di4) - eta(5)*Dval(dd11,Di5) +
& 4*(dabbr3*(zeta(1,1) + zeta(1,2) + zeta(1,3) +
& zeta(1,4)) + zeta(1,2)*Dval(dd001,Di3) +
& zeta(1,3)*Dval(dd001,Di4) +
& zeta(1,4)*Dval(dd001,Di5))
E(ee12) = dabbr4*eta(1) - eta(4)*Dval(dd12,Di4) -
& eta(5)*Dval(dd12,Di5) +
& 2*(dabbr5*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) + zeta(1,1)*Dval(dd001,Di2) +
& zeta(2,2)*Dval(dd001,Di3) +
& zeta(2,3)*Dval(dd001,Di4) +
& zeta(2,4)*Dval(dd001,Di5) +
& zeta(1,3)*Dval(dd002,Di4) +
& zeta(1,4)*Dval(dd002,Di5) -
& (zeta(1,1) + zeta(1,3) + zeta(1,4) - zeta(2,2) -
& zeta(2,3) - zeta(2,4))*Dval(dd001,Di1))
E(ee13) = dabbr6*eta(1) - eta(3)*Dval(dd12,Di3) -
& eta(5)*Dval(dd13,Di5) +
& 2*(dabbr7*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) + zeta(2,3)*Dval(dd001,Di3) +
& zeta(3,3)*Dval(dd001,Di4) +
& zeta(3,4)*Dval(dd001,Di5) +
& zeta(1,1)*Dval(dd002,Di2) +
& zeta(1,2)*Dval(dd002,Di3) +
& zeta(1,4)*Dval(dd003,Di5) -
& (zeta(1,1) + zeta(1,2) + zeta(1,4) - zeta(2,3) -
& zeta(3,3) - zeta(3,4))*Dval(dd002,Di1))
E(ee14) = dabbr8*eta(1) - eta(3)*Dval(dd13,Di3) -
& eta(4)*Dval(dd13,Di4) +
& 2*(dabbr9*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + zeta(2,4)*Dval(dd001,Di3) +
& zeta(3,4)*Dval(dd001,Di4) +
& zeta(4,4)*Dval(dd001,Di5) +
& zeta(1,1)*Dval(dd003,Di2) +
& zeta(1,2)*Dval(dd003,Di3) +
& zeta(1,3)*Dval(dd003,Di4) -
& (zeta(1,1) + zeta(1,2) + zeta(1,3) - zeta(2,4) -
& zeta(3,4) - zeta(4,4))*Dval(dd003,Di1))
E(ee22) = -(eta(2)*Dval(dd11,Di2)) -
& eta(4)*Dval(dd22,Di4) - eta(5)*Dval(dd22,Di5) -
& eta(1)*Dval(dd11,Di1) +
& 4*zeta(1,2)*Dval(dd001,Di2) +
& 4*zeta(2,3)*Dval(dd002,Di4) +
& 4*zeta(2,4)*Dval(dd002,Di5) -
& 4*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd001,Di1)
E(ee23) = -(eta(2)*Dval(dd12,Di2)) -
& eta(5)*Dval(dd23,Di5) - eta(1)*Dval(dd12,Di1) +
& 2*(zeta(1,3)*Dval(dd001,Di2) +
& zeta(1,2)*Dval(dd002,Di2) +
& zeta(2,2)*Dval(dd002,Di3) +
& zeta(3,3)*Dval(dd002,Di4) +
& zeta(3,4)*Dval(dd002,Di5) +
& zeta(2,4)*Dval(dd003,Di5) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd001,Di1) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd002,Di1))
E(ee24) = -(eta(2)*Dval(dd13,Di2)) -
& eta(4)*Dval(dd23,Di4) - eta(1)*Dval(dd13,Di1) +
& 2*(zeta(1,4)*Dval(dd001,Di2) +
& zeta(3,4)*Dval(dd002,Di4) +
& zeta(4,4)*Dval(dd002,Di5) +
& zeta(1,2)*Dval(dd003,Di2) +
& zeta(2,2)*Dval(dd003,Di3) +
& zeta(2,3)*Dval(dd003,Di4) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd001,Di1) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd003,Di1))
E(ee33) = -(eta(2)*Dval(dd22,Di2)) -
& eta(3)*Dval(dd22,Di3) - eta(5)*Dval(dd33,Di5) -
& eta(1)*Dval(dd22,Di1) +
& 4*zeta(1,3)*Dval(dd002,Di2) +
& 4*zeta(2,3)*Dval(dd002,Di3) +
& 4*zeta(3,4)*Dval(dd003,Di5) -
& 4*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd002,Di1)
E(ee34) = -(eta(2)*Dval(dd23,Di2)) -
& eta(3)*Dval(dd23,Di3) - eta(1)*Dval(dd23,Di1) +
& 2*(zeta(1,4)*Dval(dd002,Di2) +
& zeta(2,4)*Dval(dd002,Di3) +
& zeta(1,3)*Dval(dd003,Di2) +
& zeta(2,3)*Dval(dd003,Di3) +
& zeta(3,3)*Dval(dd003,Di4) +
& zeta(4,4)*Dval(dd003,Di5) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd002,Di1) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd003,Di1))
E(ee44) = -(eta(2)*Dval(dd33,Di2)) -
& eta(3)*Dval(dd33,Di3) - eta(4)*Dval(dd33,Di4) -
& eta(1)*Dval(dd33,Di1) +
& 4*zeta(1,4)*Dval(dd003,Di2) +
& 4*zeta(2,4)*Dval(dd003,Di3) +
& 4*zeta(3,4)*Dval(dd003,Di4) -
& 4*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd003,Di1)
E(ee001) = dabbr3*eta(1) - eta(3)*Dval(dd001,Di3) -
& eta(4)*Dval(dd001,Di4) - eta(5)*Dval(dd001,Di5) +
& 2*(zeta(1,1)*(Dval(dd0000,Di2) - del) +
& zeta(1,2)*(Dval(dd0000,Di3) - del) +
& zeta(1,3)*(Dval(dd0000,Di4) - del) +
& zeta(1,4)*(Dval(dd0000,Di5) - del) -
& (zeta(1,1) + zeta(1,2) + zeta(1,3) + zeta(1,4))*
& (Dval(dd0000,Di1) - del))
E(ee002) = -(eta(2)*Dval(dd001,Di2)) -
& eta(4)*Dval(dd002,Di4) - eta(5)*Dval(dd002,Di5) -
& eta(1)*Dval(dd001,Di1) +
& 2*zeta(1,2)*(Dval(dd0000,Di2) - del) +
& 2*zeta(2,2)*(Dval(dd0000,Di3) - del) +
& 2*zeta(2,3)*(Dval(dd0000,Di4) - del) +
& 2*zeta(2,4)*(Dval(dd0000,Di5) - del) -
& 2*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& (Dval(dd0000,Di1) - del)
E(ee003) = -(eta(2)*Dval(dd002,Di2)) -
& eta(3)*Dval(dd002,Di3) - eta(5)*Dval(dd003,Di5) -
& eta(1)*Dval(dd002,Di1) +
& 2*zeta(1,3)*(Dval(dd0000,Di2) - del) +
& 2*zeta(2,3)*(Dval(dd0000,Di3) - del) +
& 2*zeta(3,3)*(Dval(dd0000,Di4) - del) +
& 2*zeta(3,4)*(Dval(dd0000,Di5) - del) -
& 2*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& (Dval(dd0000,Di1) - del)
E(ee004) = -(eta(2)*Dval(dd003,Di2)) -
& eta(3)*Dval(dd003,Di3) - eta(4)*Dval(dd003,Di4) -
& eta(1)*Dval(dd003,Di1) +
& 2*zeta(1,4)*(Dval(dd0000,Di2) - del) +
& 2*zeta(2,4)*(Dval(dd0000,Di3) - del) +
& 2*zeta(3,4)*(Dval(dd0000,Di4) - del) +
& 2*zeta(4,4)*(Dval(dd0000,Di5) - del) -
& 2*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& (Dval(dd0000,Di1) - del)
E(ee111) = -6*dabbr11*
& (zeta(1,1) + zeta(1,2) + zeta(1,3) + zeta(1,4)) -
& eta(3)*Dval(dd111,Di3) - eta(4)*Dval(dd111,Di4) -
& eta(5)*Dval(dd111,Di5) +
& eta(1)*(3*dabbr10 + Dval(dd0,Di1) +
& 3*Dval(dd1,Di1) + 3*Dval(dd2,Di1) +
& 3*Dval(dd3,Di1) + 3*Dval(dd11,Di1) +
& 6*Dval(dd12,Di1) + 6*Dval(dd13,Di1) +
& 3*Dval(dd22,Di1) + 6*Dval(dd23,Di1) +
& 3*Dval(dd33,Di1) + Dval(dd111,Di1) +
& 3*Dval(dd112,Di1) + 3*Dval(dd113,Di1) +
& 3*Dval(dd122,Di1) + 6*Dval(dd123,Di1) +
& 3*Dval(dd133,Di1) + Dval(dd222,Di1) +
& Dval(dd333,Di1)) +
& 6*zeta(1,2)*Dval(dd0011,Di3) +
& 6*zeta(1,3)*Dval(dd0011,Di4) +
& 6*zeta(1,4)*Dval(dd0011,Di5)
E(ee112) = -(dabbr12*eta(1)) -
& 2*dabbr14*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) - eta(4)*Dval(dd112,Di4) -
& eta(5)*Dval(dd112,Di5) +
& 2*(2*dabbr13*(zeta(1,1) + zeta(1,3) + zeta(1,4) -
& zeta(2,2) - zeta(2,3) - zeta(2,4)) +
& zeta(2,2)*Dval(dd0011,Di3) +
& zeta(2,3)*Dval(dd0011,Di4) +
& zeta(2,4)*Dval(dd0011,Di5) +
& 2*zeta(1,3)*Dval(dd0012,Di4) +
& 2*zeta(1,4)*Dval(dd0012,Di5) +
& (2*zeta(1,1) + zeta(1,2) + 2*zeta(1,3) + 2*zeta(1,4) -
& zeta(2,2) - zeta(2,3) - zeta(2,4))*
& Dval(dd0011,Di1))
E(ee113) = -(dabbr15*eta(1)) -
& 2*dabbr17*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) - eta(3)*Dval(dd112,Di3) -
& eta(5)*Dval(dd113,Di5) +
& 2*(2*dabbr16*(zeta(1,1) + zeta(1,2) + zeta(1,4) -
& zeta(2,3) - zeta(3,3) - zeta(3,4)) +
& zeta(2,3)*Dval(dd0011,Di3) +
& zeta(3,3)*Dval(dd0011,Di4) +
& zeta(3,4)*Dval(dd0011,Di5) +
& 2*zeta(1,2)*Dval(dd0012,Di3) +
& 2*zeta(1,4)*Dval(dd0013,Di5) +
& (2*zeta(1,1) + 2*zeta(1,2) + zeta(1,3) + 2*zeta(1,4) -
& zeta(2,3) - zeta(3,3) - zeta(3,4))*
& Dval(dd0022,Di1))
E(ee114) = -(dabbr18*eta(1)) -
& 2*dabbr19*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) - eta(3)*Dval(dd113,Di3) -
& eta(4)*Dval(dd113,Di4) +
& 2*(2*dabbr20*(zeta(1,1) + zeta(1,2) + zeta(1,3) -
& zeta(2,4) - zeta(3,4) - zeta(4,4)) +
& zeta(2,4)*Dval(dd0011,Di3) +
& zeta(3,4)*Dval(dd0011,Di4) +
& zeta(4,4)*Dval(dd0011,Di5) +
& 2*zeta(1,2)*Dval(dd0013,Di3) +
& 2*zeta(1,3)*Dval(dd0013,Di4) +
& (2*zeta(1,1) + 2*zeta(1,2) + 2*zeta(1,3) + zeta(1,4) -
& zeta(2,4) - zeta(3,4) - zeta(4,4))*
& Dval(dd0033,Di1))
E(ee122) = dabbr21*eta(1) - eta(4)*Dval(dd122,Di4) -
& eta(5)*Dval(dd122,Di5) +
& 2*(2*dabbr13*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) + zeta(1,1)*Dval(dd0011,Di2) +
& 2*zeta(2,3)*Dval(dd0012,Di4) +
& 2*zeta(2,4)*Dval(dd0012,Di5) +
& zeta(1,3)*Dval(dd0022,Di4) +
& zeta(1,4)*Dval(dd0022,Di5) -
& (zeta(1,1) - zeta(1,2) + zeta(1,3) + zeta(1,4) -
& 2*(zeta(2,2) + zeta(2,3) + zeta(2,4)))*
& Dval(dd0011,Di1))
E(ee123) = dabbr22*eta(1) - eta(5)*Dval(dd123,Di5) +
& 2*(dabbr24*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) +
& dabbr23*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) + zeta(1,1)*Dval(dd0012,Di2) +
& zeta(2,2)*Dval(dd0012,Di3) +
& zeta(3,3)*Dval(dd0012,Di4) +
& zeta(3,4)*Dval(dd0012,Di5) +
& zeta(2,4)*Dval(dd0013,Di5) +
& zeta(1,4)*Dval(dd0023,Di5) +
& (-zeta(1,1) - zeta(1,4) + zeta(2,2) + 2*zeta(2,3) +
& zeta(2,4) + zeta(3,3) + zeta(3,4))*
& Dval(dd0012,Di1))
E(ee124) = dabbr25*eta(1) - eta(4)*Dval(dd123,Di4) +
& 2*(dabbr27*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) +
& dabbr26*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + zeta(3,4)*Dval(dd0012,Di4) +
& zeta(4,4)*Dval(dd0012,Di5) +
& zeta(1,1)*Dval(dd0013,Di2) +
& zeta(2,2)*Dval(dd0013,Di3) +
& zeta(2,3)*Dval(dd0013,Di4) +
& zeta(1,3)*Dval(dd0023,Di4) +
& (-zeta(1,1) - zeta(1,3) + zeta(2,2) + zeta(2,3) +
& 2*zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd0013,Di1))
E(ee133) = dabbr28*eta(1) - eta(3)*Dval(dd122,Di3) -
& eta(5)*Dval(dd133,Di5) +
& 2*(2*dabbr16*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) + 2*zeta(2,3)*Dval(dd0012,Di3) +
& 2*zeta(3,4)*Dval(dd0013,Di5) +
& zeta(1,1)*Dval(dd0022,Di2) +
& zeta(1,2)*Dval(dd0022,Di3) +
& zeta(1,4)*Dval(dd0033,Di5) -
& (zeta(1,1) + zeta(1,2) - zeta(1,3) + zeta(1,4) -
& 2*(zeta(2,3) + zeta(3,3) + zeta(3,4)))*
& Dval(dd0022,Di1))
E(ee134) = dabbr29*eta(1) - eta(3)*Dval(dd123,Di3) +
& 2*(dabbr31*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) +
& dabbr30*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + zeta(2,4)*Dval(dd0012,Di3) +
& zeta(2,3)*Dval(dd0013,Di3) +
& zeta(3,3)*Dval(dd0013,Di4) +
& zeta(4,4)*Dval(dd0013,Di5) +
& zeta(1,1)*Dval(dd0023,Di2) +
& zeta(1,2)*Dval(dd0023,Di3) +
& (-zeta(1,1) - zeta(1,2) + zeta(2,3) + zeta(2,4) +
& zeta(3,3) + 2*zeta(3,4) + zeta(4,4))*
& Dval(dd0023,Di1))
E(ee144) = dabbr32*eta(1) - eta(3)*Dval(dd133,Di3) -
& eta(4)*Dval(dd133,Di4) +
& 2*(2*dabbr20*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + 2*zeta(2,4)*Dval(dd0013,Di3) +
& 2*zeta(3,4)*Dval(dd0013,Di4) +
& zeta(1,1)*Dval(dd0033,Di2) +
& zeta(1,2)*Dval(dd0033,Di3) +
& zeta(1,3)*Dval(dd0033,Di4) -
& (zeta(1,1) + zeta(1,2) + zeta(1,3) - zeta(1,4) -
& 2*(zeta(2,4) + zeta(3,4) + zeta(4,4)))*
& Dval(dd0033,Di1))
E(ee222) = -(eta(2)*Dval(dd111,Di2)) -
& eta(4)*Dval(dd222,Di4) - eta(5)*Dval(dd222,Di5) -
& eta(1)*Dval(dd111,Di1) +
& 6*zeta(1,2)*Dval(dd0011,Di2) +
& 6*zeta(2,3)*Dval(dd0022,Di4) +
& 6*zeta(2,4)*Dval(dd0022,Di5) -
& 6*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd0011,Di1)
E(ee223) = -(eta(2)*Dval(dd112,Di2)) -
& eta(5)*Dval(dd223,Di5) - eta(1)*Dval(dd112,Di1) +
& 2*zeta(1,3)*Dval(dd0011,Di2) +
& 4*zeta(1,2)*Dval(dd0012,Di2) +
& 2*zeta(3,3)*Dval(dd0022,Di4) +
& 2*zeta(3,4)*Dval(dd0022,Di5) +
& 4*zeta(2,4)*Dval(dd0023,Di5) -
& 2*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd0011,Di1) -
& 4*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd0012,Di1)
E(ee224) = -(eta(2)*Dval(dd113,Di2)) -
& eta(4)*Dval(dd223,Di4) - eta(1)*Dval(dd113,Di1) +
& 2*zeta(1,4)*Dval(dd0011,Di2) +
& 4*zeta(1,2)*Dval(dd0013,Di2) +
& 2*zeta(3,4)*Dval(dd0022,Di4) +
& 2*zeta(4,4)*Dval(dd0022,Di5) +
& 4*zeta(2,3)*Dval(dd0023,Di4) -
& 2*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd0011,Di1) -
& 4*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd0013,Di1)
E(ee233) = -(eta(2)*Dval(dd122,Di2)) -
& eta(5)*Dval(dd233,Di5) - eta(1)*Dval(dd122,Di1) +
& 4*zeta(1,3)*Dval(dd0012,Di2) +
& 2*zeta(1,2)*Dval(dd0022,Di2) +
& 2*zeta(2,2)*Dval(dd0022,Di3) +
& 4*zeta(3,4)*Dval(dd0023,Di5) +
& 2*zeta(2,4)*Dval(dd0033,Di5) -
& 4*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd0012,Di1) -
& 2*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd0022,Di1)
E(ee234) = -(eta(2)*Dval(dd123,Di2)) -
& eta(1)*Dval(dd123,Di1) +
& 2*(zeta(1,4)*Dval(dd0012,Di2) +
& zeta(1,3)*Dval(dd0013,Di2) +
& zeta(1,2)*Dval(dd0023,Di2) +
& zeta(2,2)*Dval(dd0023,Di3) +
& zeta(3,3)*Dval(dd0023,Di4) +
& zeta(4,4)*Dval(dd0023,Di5) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd0012,Di1) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd0013,Di1) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd0023,Di1))
E(ee244) = -(eta(2)*Dval(dd133,Di2)) -
& eta(4)*Dval(dd233,Di4) - eta(1)*Dval(dd133,Di1) +
& 4*zeta(1,4)*Dval(dd0013,Di2) +
& 4*zeta(3,4)*Dval(dd0023,Di4) +
& 2*zeta(1,2)*Dval(dd0033,Di2) +
& 2*zeta(2,2)*Dval(dd0033,Di3) +
& 2*zeta(2,3)*Dval(dd0033,Di4) -
& 4*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd0013,Di1) -
& 2*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd0033,Di1)
E(ee333) = -(eta(2)*Dval(dd222,Di2)) -
& eta(3)*Dval(dd222,Di3) - eta(5)*Dval(dd333,Di5) -
& eta(1)*Dval(dd222,Di1) +
& 6*zeta(1,3)*Dval(dd0022,Di2) +
& 6*zeta(2,3)*Dval(dd0022,Di3) +
& 6*zeta(3,4)*Dval(dd0033,Di5) -
& 6*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd0022,Di1)
E(ee334) = -(eta(2)*Dval(dd223,Di2)) -
& eta(3)*Dval(dd223,Di3) - eta(1)*Dval(dd223,Di1) +
& 2*zeta(1,4)*Dval(dd0022,Di2) +
& 2*zeta(2,4)*Dval(dd0022,Di3) +
& 4*zeta(1,3)*Dval(dd0023,Di2) +
& 4*zeta(2,3)*Dval(dd0023,Di3) +
& 2*zeta(4,4)*Dval(dd0033,Di5) -
& 2*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd0022,Di1) -
& 4*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd0023,Di1)
E(ee344) = -(eta(2)*Dval(dd233,Di2)) -
& eta(3)*Dval(dd233,Di3) - eta(1)*Dval(dd233,Di1) +
& 4*zeta(1,4)*Dval(dd0023,Di2) +
& 4*zeta(2,4)*Dval(dd0023,Di3) +
& 2*zeta(1,3)*Dval(dd0033,Di2) +
& 2*zeta(2,3)*Dval(dd0033,Di3) +
& 2*zeta(3,3)*Dval(dd0033,Di4) -
& 4*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd0023,Di1) -
& 2*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd0033,Di1)
E(ee444) = -(eta(2)*Dval(dd333,Di2)) -
& eta(3)*Dval(dd333,Di3) - eta(4)*Dval(dd333,Di4) -
& eta(1)*Dval(dd333,Di1) +
& 6*zeta(1,4)*Dval(dd0033,Di2) +
& 6*zeta(2,4)*Dval(dd0033,Di3) +
& 6*zeta(3,4)*Dval(dd0033,Di4) -
& 6*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd0033,Di1)
E(ee0000) = (-(detZ/detY) -
& 48*(eta(2)*(Dval(dd0000,Di2) - del) +
& eta(3)*(Dval(dd0000,Di3) - del) +
& eta(4)*(Dval(dd0000,Di4) - del) +
& eta(5)*(Dval(dd0000,Di5) - del) +
& eta(1)*(Dval(dd0000,Di1) - del)))/48D0
E(ee0011) = -(dabbr11*eta(1)) -
& eta(3)*Dval(dd0011,Di3) -
& eta(4)*Dval(dd0011,Di4) -
& eta(5)*Dval(dd0011,Di5) +
& 4*(dabbr33*(zeta(1,1) + zeta(1,2) + zeta(1,3) +
& zeta(1,4)) +
& zeta(1,2)*(Dval(dd00001,Di3) + del4) +
& zeta(1,3)*(Dval(dd00001,Di4) + del4) +
& zeta(1,4)*(Dval(dd00001,Di5) + del4))
E(ee0012) = dabbr34*eta(1) -
& eta(4)*Dval(dd0012,Di4) -
& eta(5)*Dval(dd0012,Di5) +
& 2*(dabbr35*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) +
& zeta(1,1)*(Dval(dd00001,Di2) + del4) +
& zeta(2,2)*(Dval(dd00001,Di3) + del4) +
& zeta(2,3)*(Dval(dd00001,Di4) + del4) +
& zeta(2,4)*(Dval(dd00001,Di5) + del4) +
& zeta(1,3)*(Dval(dd00002,Di4) + del4) +
& zeta(1,4)*(Dval(dd00002,Di5) + del4) -
& (zeta(1,1) + zeta(1,3) + zeta(1,4) - zeta(2,2) -
& zeta(2,3) - zeta(2,4))*
& (Dval(dd00001,Di1) + del4))
E(ee0013) = dabbr36*eta(1) -
& eta(3)*Dval(dd0012,Di3) -
& eta(5)*Dval(dd0013,Di5) +
& 2*(dabbr37*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) +
& zeta(2,3)*(Dval(dd00001,Di3) + del4) +
& zeta(3,3)*(Dval(dd00001,Di4) + del4) +
& zeta(3,4)*(Dval(dd00001,Di5) + del4) +
& zeta(1,1)*(Dval(dd00002,Di2) + del4) +
& zeta(1,2)*(Dval(dd00002,Di3) + del4) +
& zeta(1,4)*(Dval(dd00003,Di5) + del4) -
& (zeta(1,1) + zeta(1,2) + zeta(1,4) - zeta(2,3) -
& zeta(3,3) - zeta(3,4))*
& (Dval(dd00002,Di1) + del4))
E(ee0014) = dabbr38*eta(1) -
& eta(3)*Dval(dd0013,Di3) -
& eta(4)*Dval(dd0013,Di4) +
& 2*(dabbr39*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) +
& zeta(2,4)*(Dval(dd00001,Di3) + del4) +
& zeta(3,4)*(Dval(dd00001,Di4) + del4) +
& zeta(4,4)*(Dval(dd00001,Di5) + del4) +
& zeta(1,1)*(Dval(dd00003,Di2) + del4) +
& zeta(1,2)*(Dval(dd00003,Di3) + del4) +
& zeta(1,3)*(Dval(dd00003,Di4) + del4) -
& (zeta(1,1) + zeta(1,2) + zeta(1,3) - zeta(2,4) -
& zeta(3,4) - zeta(4,4))*
& (Dval(dd00003,Di1) + del4))
E(ee0022) = -(eta(2)*Dval(dd0011,Di2)) -
& eta(4)*Dval(dd0022,Di4) -
& eta(5)*Dval(dd0022,Di5) -
& eta(1)*Dval(dd0011,Di1) +
& 4*zeta(1,2)*(Dval(dd00001,Di2) + del4) +
& 4*zeta(2,3)*(Dval(dd00002,Di4) + del4) +
& 4*zeta(2,4)*(Dval(dd00002,Di5) + del4) -
& 4*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& (Dval(dd00001,Di1) + del4)
E(ee0023) = -(eta(2)*Dval(dd0012,Di2)) -
& eta(5)*Dval(dd0023,Di5) -
& eta(1)*Dval(dd0012,Di1) +
& 2*(zeta(1,3)*(Dval(dd00001,Di2) + del4) +
& zeta(1,2)*(Dval(dd00002,Di2) + del4) +
& zeta(2,2)*(Dval(dd00002,Di3) + del4) +
& zeta(3,3)*(Dval(dd00002,Di4) + del4) +
& zeta(3,4)*(Dval(dd00002,Di5) + del4) +
& zeta(2,4)*(Dval(dd00003,Di5) + del4) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& (Dval(dd00001,Di1) + del4) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& (Dval(dd00002,Di1) + del4))
E(ee0024) = -(eta(2)*Dval(dd0013,Di2)) -
& eta(4)*Dval(dd0023,Di4) -
& eta(1)*Dval(dd0013,Di1) +
& 2*(zeta(1,4)*(Dval(dd00001,Di2) + del4) +
& zeta(3,4)*(Dval(dd00002,Di4) + del4) +
& zeta(4,4)*(Dval(dd00002,Di5) + del4) +
& zeta(1,2)*(Dval(dd00003,Di2) + del4) +
& zeta(2,2)*(Dval(dd00003,Di3) + del4) +
& zeta(2,3)*(Dval(dd00003,Di4) + del4) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& (Dval(dd00001,Di1) + del4) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& (Dval(dd00003,Di1) + del4))
E(ee0033) = -(eta(2)*Dval(dd0022,Di2)) -
& eta(3)*Dval(dd0022,Di3) -
& eta(5)*Dval(dd0033,Di5) -
& eta(1)*Dval(dd0022,Di1) +
& 4*zeta(1,3)*(Dval(dd00002,Di2) + del4) +
& 4*zeta(2,3)*(Dval(dd00002,Di3) + del4) +
& 4*zeta(3,4)*(Dval(dd00003,Di5) + del4) -
& 4*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& (Dval(dd00002,Di1) + del4)
E(ee0034) = -(eta(2)*Dval(dd0023,Di2)) -
& eta(3)*Dval(dd0023,Di3) -
& eta(1)*Dval(dd0023,Di1) +
& 2*(zeta(1,4)*(Dval(dd00002,Di2) + del4) +
& zeta(2,4)*(Dval(dd00002,Di3) + del4) +
& zeta(1,3)*(Dval(dd00003,Di2) + del4) +
& zeta(2,3)*(Dval(dd00003,Di3) + del4) +
& zeta(3,3)*(Dval(dd00003,Di4) + del4) +
& zeta(4,4)*(Dval(dd00003,Di5) + del4) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& (Dval(dd00002,Di1) + del4) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& (Dval(dd00003,Di1) + del4))
E(ee0044) = -(eta(2)*Dval(dd0033,Di2)) -
& eta(3)*Dval(dd0033,Di3) -
& eta(4)*Dval(dd0033,Di4) -
& eta(1)*Dval(dd0033,Di1) +
& 4*zeta(1,4)*(Dval(dd00003,Di2) + del4) +
& 4*zeta(2,4)*(Dval(dd00003,Di3) + del4) +
& 4*zeta(3,4)*(Dval(dd00003,Di4) + del4) -
& 4*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& (Dval(dd00003,Di1) + del4)
E(ee1111) = -(dabbr40*eta(1)) -
& eta(3)*Dval(dd1111,Di3) -
& eta(4)*Dval(dd1111,Di4) -
& eta(5)*Dval(dd1111,Di5) +
& 8*zeta(1,2)*Dval(dd00111,Di3) +
& 8*zeta(1,3)*Dval(dd00111,Di4) +
& 8*zeta(1,4)*Dval(dd00111,Di5) +
& 8*(zeta(1,1) + zeta(1,2) + zeta(1,3) + zeta(1,4))*
& (3*dabbr41 + Dval(dd00,Di1) +
& 3*Dval(dd001,Di1) + 3*Dval(dd002,Di1) +
& 3*Dval(dd003,Di1) + 3*Dval(dd0011,Di1) +
& 6*Dval(dd0012,Di1) + 6*Dval(dd0013,Di1) +
& 3*Dval(dd0022,Di1) + 6*Dval(dd0023,Di1) +
& 3*Dval(dd0033,Di1) + Dval(dd00111,Di1) +
& 3*Dval(dd00112,Di1) + 3*Dval(dd00113,Di1) +
& 3*Dval(dd00122,Di1) + 6*Dval(dd00123,Di1) +
& 3*Dval(dd00133,Di1) + Dval(dd00222,Di1) +
& Dval(dd00333,Di1))
E(ee1112) = -6*dabbr44*
& (zeta(1,1) + zeta(1,3) + zeta(1,4) - zeta(2,2) -
& zeta(2,3) - zeta(2,4)) -
& 6*dabbr43*(2*zeta(1,1) + zeta(1,2) + 2*zeta(1,3) +
& 2*zeta(1,4) - zeta(2,2) - zeta(2,3) - zeta(2,4)) -
& eta(4)*Dval(dd1112,Di4) -
& eta(5)*Dval(dd1112,Di5) +
& eta(1)*(3*dabbr42 + Dval(dd1,Di1) +
& 3*Dval(dd11,Di1) + 3*Dval(dd12,Di1) +
& 3*Dval(dd13,Di1) + 3*Dval(dd111,Di1) +
& 6*Dval(dd112,Di1) + 6*Dval(dd113,Di1) +
& 3*Dval(dd122,Di1) + 6*Dval(dd123,Di1) +
& 3*Dval(dd133,Di1) + Dval(dd1111,Di1) +
& 3*Dval(dd1112,Di1) + 3*Dval(dd1113,Di1) +
& 3*Dval(dd1122,Di1) + 6*Dval(dd1123,Di1) +
& 3*Dval(dd1133,Di1) + Dval(dd1222,Di1) +
& Dval(dd1333,Di1)) +
& 2*(zeta(2,2)*Dval(dd00111,Di3) +
& zeta(2,3)*Dval(dd00111,Di4) +
& zeta(2,4)*Dval(dd00111,Di5) +
& 3*zeta(1,3)*Dval(dd00112,Di4) +
& 3*zeta(1,4)*Dval(dd00112,Di5) +
& (-3*zeta(1,1) - 2*zeta(1,2) - 3*zeta(1,3) -
& 3*zeta(1,4) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00111,Di1)) +
& 2*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& (3*dabbr41 + Dval(dd00,Di1) +
& 3*Dval(dd002,Di1) + 3*Dval(dd003,Di1) +
& 3*Dval(dd0022,Di1) + 6*Dval(dd0023,Di1) +
& 3*Dval(dd0033,Di1) + Dval(dd00222,Di1) +
& Dval(dd00333,Di1))
E(ee1113) = -6*dabbr47*
& (zeta(1,1) + zeta(1,2) + zeta(1,4) - zeta(2,3) -
& zeta(3,3) - zeta(3,4)) -
& 6*dabbr46*(2*zeta(1,1) + 2*zeta(1,2) + zeta(1,3) +
& 2*zeta(1,4) - zeta(2,3) - zeta(3,3) - zeta(3,4)) -
& eta(3)*Dval(dd1112,Di3) -
& eta(5)*Dval(dd1113,Di5) +
& eta(1)*(3*dabbr45 + Dval(dd2,Di1) +
& 3*Dval(dd12,Di1) + 3*Dval(dd22,Di1) +
& 3*Dval(dd23,Di1) + 3*Dval(dd112,Di1) +
& 6*Dval(dd122,Di1) + 6*Dval(dd123,Di1) +
& 3*Dval(dd222,Di1) + 6*Dval(dd223,Di1) +
& 3*Dval(dd233,Di1) + Dval(dd1112,Di1) +
& 3*Dval(dd1122,Di1) + 3*Dval(dd1123,Di1) +
& 3*Dval(dd1222,Di1) + 6*Dval(dd1223,Di1) +
& 3*Dval(dd1233,Di1) + Dval(dd2222,Di1) +
& Dval(dd2333,Di1)) +
& 2*(zeta(2,3)*Dval(dd00111,Di3) +
& zeta(3,3)*Dval(dd00111,Di4) +
& zeta(3,4)*Dval(dd00111,Di5) +
& 3*zeta(1,2)*Dval(dd00112,Di3) +
& 3*zeta(1,4)*Dval(dd00113,Di5) +
& (-3*zeta(1,1) - 3*zeta(1,2) - 2*zeta(1,3) -
& 3*zeta(1,4) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00222,Di1)) +
& 2*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& (3*dabbr48 + Dval(dd00,Di1) +
& 3*Dval(dd001,Di1) + 3*Dval(dd003,Di1) +
& 3*Dval(dd0011,Di1) + 6*Dval(dd0013,Di1) +
& 3*Dval(dd0033,Di1) + Dval(dd00111,Di1) +
& Dval(dd00333,Di1))
E(ee1114) = -6*dabbr51*
& (zeta(1,1) + zeta(1,2) + zeta(1,3) - zeta(2,4) -
& zeta(3,4) - zeta(4,4)) -
& 6*dabbr52*(2*zeta(1,1) + 2*zeta(1,2) + 2*zeta(1,3) +
& zeta(1,4) - zeta(2,4) - zeta(3,4) - zeta(4,4)) -
& eta(3)*Dval(dd1113,Di3) -
& eta(4)*Dval(dd1113,Di4) +
& eta(1)*(3*dabbr49 + Dval(dd3,Di1) +
& 3*Dval(dd13,Di1) + 3*Dval(dd23,Di1) +
& 3*Dval(dd33,Di1) + 3*Dval(dd113,Di1) +
& 6*Dval(dd123,Di1) + 6*Dval(dd133,Di1) +
& 3*Dval(dd223,Di1) + 6*Dval(dd233,Di1) +
& 3*Dval(dd333,Di1) + Dval(dd1113,Di1) +
& 3*Dval(dd1123,Di1) + 3*Dval(dd1133,Di1) +
& 3*Dval(dd1223,Di1) + 6*Dval(dd1233,Di1) +
& 3*Dval(dd1333,Di1) + Dval(dd2223,Di1) +
& Dval(dd3333,Di1)) +
& 2*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& (3*dabbr50 + Dval(dd00,Di1) +
& 3*Dval(dd001,Di1) + 3*Dval(dd002,Di1) +
& 3*Dval(dd0011,Di1) + 6*Dval(dd0012,Di1) +
& 3*Dval(dd0022,Di1) + Dval(dd00111,Di1) +
& Dval(dd00222,Di1)) +
& 2*(zeta(2,4)*Dval(dd00111,Di3) +
& zeta(3,4)*Dval(dd00111,Di4) +
& zeta(4,4)*Dval(dd00111,Di5) +
& 3*zeta(1,2)*Dval(dd00113,Di3) +
& 3*zeta(1,3)*Dval(dd00113,Di4) +
& (-3*zeta(1,1) - 3*zeta(1,2) - 3*zeta(1,3) -
& 2*zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00333,Di1))
E(ee1122) = -(dabbr53*eta(1)) -
& 4*dabbr44*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) - eta(4)*Dval(dd1122,Di4) -
& eta(5)*Dval(dd1122,Di5) +
& 4*(-2*dabbr43*(zeta(2,2) + zeta(2,3) + zeta(2,4)) +
& zeta(1,1)*Dval(dd0011,Di1) -
& zeta(1,2)*Dval(dd0011,Di1) +
& zeta(1,3)*Dval(dd0011,Di1) +
& zeta(1,4)*Dval(dd0011,Di1) +
& zeta(2,3)*Dval(dd00112,Di4) +
& zeta(2,4)*Dval(dd00112,Di5) +
& zeta(1,3)*Dval(dd00122,Di4) +
& zeta(1,4)*Dval(dd00122,Di5) +
& (zeta(1,1) + zeta(1,3) + zeta(1,4) - zeta(2,2) -
& zeta(2,3) - zeta(2,4))*Dval(dd00111,Di1) +
& zeta(1,1)*Dval(dd00112,Di1) -
& zeta(1,2)*Dval(dd00112,Di1) +
& zeta(1,3)*Dval(dd00112,Di1) +
& zeta(1,4)*Dval(dd00112,Di1) +
& (zeta(1,1) - zeta(1,2) + zeta(1,3) + zeta(1,4))*
& Dval(dd00113,Di1))
E(ee1123) = -(dabbr54*eta(1)) -
& 2*dabbr57*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) - 2*dabbr56*
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4)) -
& eta(5)*Dval(dd1123,Di5) +
& 2*(2*dabbr55*(zeta(1,1) + zeta(1,4) - zeta(2,2) -
& 2*zeta(2,3) - zeta(2,4) - zeta(3,3) - zeta(3,4)) +
& zeta(2,2)*Dval(dd00112,Di3) +
& zeta(3,3)*Dval(dd00112,Di4) +
& zeta(3,4)*Dval(dd00112,Di5) +
& zeta(2,4)*Dval(dd00113,Di5) +
& 2*zeta(1,4)*Dval(dd00123,Di5) +
& (2*zeta(1,1) + zeta(1,2) + 2*zeta(1,4) - zeta(2,2) -
& 3*zeta(2,3) - zeta(2,4) - 2*zeta(3,3) - 2*zeta(3,4))
& *Dval(dd00112,Di1) +
& (2*zeta(1,1) + zeta(1,3) + 2*zeta(1,4) - 2*zeta(2,2) -
& 3*zeta(2,3) - 2*zeta(2,4) - zeta(3,3) - zeta(3,4))*
& Dval(dd00122,Di1))
E(ee1124) = -(dabbr58*eta(1)) -
& 2*dabbr61*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) - 2*dabbr59*
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4)) -
& eta(4)*Dval(dd1123,Di4) +
& 2*(2*dabbr60*(zeta(1,1) + zeta(1,3) - zeta(2,2) -
& zeta(2,3) - 2*zeta(2,4) - zeta(3,4) - zeta(4,4)) +
& zeta(3,4)*Dval(dd00112,Di4) +
& zeta(4,4)*Dval(dd00112,Di5) +
& zeta(2,2)*Dval(dd00113,Di3) +
& zeta(2,3)*Dval(dd00113,Di4) +
& 2*zeta(1,3)*Dval(dd00123,Di4) +
& (2*zeta(1,1) + zeta(1,2) + 2*zeta(1,3) - zeta(2,2) -
& zeta(2,3) - 3*zeta(2,4) - 2*zeta(3,4) - 2*zeta(4,4))
& *Dval(dd00113,Di1) +
& (2*zeta(1,1) + 2*zeta(1,3) + zeta(1,4) - 2*zeta(2,2) -
& 2*zeta(2,3) - 3*zeta(2,4) - zeta(3,4) - zeta(4,4))*
& Dval(dd00133,Di1))
E(ee1133) = -(dabbr62*eta(1)) -
& 4*dabbr47*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) - eta(3)*Dval(dd1122,Di3) -
& eta(5)*Dval(dd1133,Di5) +
& 4*(-2*dabbr46*(zeta(2,3) + zeta(3,3) + zeta(3,4)) +
& zeta(1,1)*Dval(dd0022,Di1) +
& zeta(1,2)*Dval(dd0022,Di1) -
& zeta(1,3)*Dval(dd0022,Di1) +
& zeta(1,4)*Dval(dd0022,Di1) +
& zeta(2,3)*Dval(dd00112,Di3) +
& zeta(3,4)*Dval(dd00113,Di5) +
& zeta(1,2)*Dval(dd00122,Di3) +
& zeta(1,4)*Dval(dd00133,Di5) +
& zeta(1,1)*Dval(dd00122,Di1) +
& zeta(1,2)*Dval(dd00122,Di1) -
& zeta(1,3)*Dval(dd00122,Di1) +
& zeta(1,4)*Dval(dd00122,Di1) +
& (zeta(1,1) + zeta(1,2) + zeta(1,4) - zeta(2,3) -
& zeta(3,3) - zeta(3,4))*Dval(dd00222,Di1) +
& (zeta(1,1) + zeta(1,2) - zeta(1,3) + zeta(1,4))*
& Dval(dd00223,Di1))
E(ee1134) = -(dabbr63*eta(1)) -
& 2*dabbr66*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) - 2*dabbr64*
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4)) -
& eta(3)*Dval(dd1123,Di3) +
& 2*(2*dabbr65*(zeta(1,1) + zeta(1,2) - zeta(2,3) -
& zeta(2,4) - zeta(3,3) - 2*zeta(3,4) - zeta(4,4)) +
& zeta(2,4)*Dval(dd00112,Di3) +
& zeta(2,3)*Dval(dd00113,Di3) +
& zeta(3,3)*Dval(dd00113,Di4) +
& zeta(4,4)*Dval(dd00113,Di5) +
& 2*zeta(1,2)*Dval(dd00123,Di3) +
& (2*zeta(1,1) + 2*zeta(1,2) + zeta(1,3) - zeta(2,3) -
& 2*zeta(2,4) - zeta(3,3) - 3*zeta(3,4) - 2*zeta(4,4))
& *Dval(dd00223,Di1) +
& (2*zeta(1,1) + 2*zeta(1,2) + zeta(1,4) - 2*zeta(2,3) -
& zeta(2,4) - 2*zeta(3,3) - 3*zeta(3,4) - zeta(4,4))*
& Dval(dd00233,Di1))
E(ee1144) = -(dabbr67*eta(1)) -
& 4*dabbr51*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) - eta(3)*Dval(dd1133,Di3) -
& eta(4)*Dval(dd1133,Di4) +
& 4*(-2*dabbr52*(zeta(2,4) + zeta(3,4) + zeta(4,4)) +
& zeta(1,1)*Dval(dd0033,Di1) +
& zeta(1,2)*Dval(dd0033,Di1) +
& zeta(1,3)*Dval(dd0033,Di1) -
& zeta(1,4)*Dval(dd0033,Di1) +
& zeta(2,4)*Dval(dd00113,Di3) +
& zeta(3,4)*Dval(dd00113,Di4) +
& zeta(1,2)*Dval(dd00133,Di3) +
& zeta(1,3)*Dval(dd00133,Di4) +
& zeta(1,1)*Dval(dd00133,Di1) +
& zeta(1,2)*Dval(dd00133,Di1) +
& zeta(1,3)*Dval(dd00133,Di1) -
& zeta(1,4)*Dval(dd00133,Di1) +
& (zeta(1,1) + zeta(1,2) + zeta(1,3) - zeta(1,4))*
& Dval(dd00233,Di1) +
& (zeta(1,1) + zeta(1,2) + zeta(1,3) - zeta(2,4) -
& zeta(3,4) - zeta(4,4))*Dval(dd00333,Di1))
E(ee1222) = dabbr68*eta(1) -
& eta(4)*Dval(dd1222,Di4) -
& eta(5)*Dval(dd1222,Di5) +
& 2*(3*dabbr43*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) + zeta(1,1)*Dval(dd00111,Di2) +
& 3*zeta(2,3)*Dval(dd00122,Di4) +
& 3*zeta(2,4)*Dval(dd00122,Di5) +
& zeta(1,3)*Dval(dd00222,Di4) +
& zeta(1,4)*Dval(dd00222,Di5) -
& (zeta(1,1) - 2*zeta(1,2) + zeta(1,3) + zeta(1,4) -
& 3*(zeta(2,2) + zeta(2,3) + zeta(2,4)))*
& Dval(dd00111,Di1))
E(ee1223) = dabbr69*eta(1) -
& eta(5)*Dval(dd1223,Di5) +
& 2*(2*dabbr71*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) +
& dabbr70*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) + zeta(1,1)*Dval(dd00112,Di2) +
& zeta(3,3)*Dval(dd00122,Di4) +
& zeta(3,4)*Dval(dd00122,Di5) +
& 2*zeta(2,4)*Dval(dd00123,Di5) +
& zeta(1,4)*Dval(dd00223,Di5) +
& (-zeta(1,1) + zeta(1,2) - zeta(1,4) + 2*zeta(2,2) +
& 3*zeta(2,3) + 2*zeta(2,4) + zeta(3,3) + zeta(3,4))*
& Dval(dd00112,Di1))
E(ee1224) = dabbr72*eta(1) -
& eta(4)*Dval(dd1223,Di4) +
& 2*(2*dabbr74*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) +
& dabbr73*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + zeta(1,1)*Dval(dd00113,Di2) +
& zeta(3,4)*Dval(dd00122,Di4) +
& zeta(4,4)*Dval(dd00122,Di5) +
& 2*zeta(2,3)*Dval(dd00123,Di4) +
& zeta(1,3)*Dval(dd00223,Di4) +
& (-zeta(1,1) + zeta(1,2) - zeta(1,3) + 2*zeta(2,2) +
& 2*zeta(2,3) + 3*zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00113,Di1))
E(ee1233) = dabbr75*eta(1) -
& eta(5)*Dval(dd1233,Di5) +
& 2*(dabbr77*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) +
& 2*dabbr76*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) + zeta(1,1)*Dval(dd00122,Di2) +
& zeta(2,2)*Dval(dd00122,Di3) +
& 2*zeta(3,4)*Dval(dd00123,Di5) +
& zeta(2,4)*Dval(dd00133,Di5) +
& zeta(1,4)*Dval(dd00233,Di5) +
& (-zeta(1,1) + zeta(1,3) - zeta(1,4) + zeta(2,2) +
& 3*zeta(2,3) + zeta(2,4) + 2*(zeta(3,3) + zeta(3,4)))
& *Dval(dd00122,Di1))
E(ee1234) = dabbr78*eta(1) +
& 2*(dabbr81*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) +
& dabbr80*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) +
& dabbr79*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + zeta(1,1)*Dval(dd00123,Di2) +
& zeta(2,2)*Dval(dd00123,Di3) +
& zeta(3,3)*Dval(dd00123,Di4) +
& zeta(4,4)*Dval(dd00123,Di5) +
& (-zeta(1,1) + zeta(2,2) + 2*zeta(2,3) + 2*zeta(2,4) +
& zeta(3,3) + 2*zeta(3,4) + zeta(4,4))*
& Dval(dd00123,Di1))
E(ee1244) = dabbr82*eta(1) -
& eta(4)*Dval(dd1233,Di4) +
& 2*(dabbr84*(zeta(1,2) + zeta(2,2) + zeta(2,3) +
& zeta(2,4)) +
& 2*dabbr83*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + 2*zeta(3,4)*Dval(dd00123,Di4) +
& zeta(1,1)*Dval(dd00133,Di2) +
& zeta(2,2)*Dval(dd00133,Di3) +
& zeta(2,3)*Dval(dd00133,Di4) +
& zeta(1,3)*Dval(dd00233,Di4) +
& (-zeta(1,1) - zeta(1,3) + zeta(1,4) + zeta(2,2) +
& zeta(2,3) + 3*zeta(2,4) + 2*(zeta(3,4) + zeta(4,4)))
& *Dval(dd00133,Di1))
E(ee1333) = dabbr85*eta(1) -
& eta(3)*Dval(dd1222,Di3) -
& eta(5)*Dval(dd1333,Di5) +
& 2*(3*dabbr46*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) + 3*zeta(2,3)*Dval(dd00122,Di3) +
& 3*zeta(3,4)*Dval(dd00133,Di5) +
& zeta(1,1)*Dval(dd00222,Di2) +
& zeta(1,2)*Dval(dd00222,Di3) +
& zeta(1,4)*Dval(dd00333,Di5) -
& (zeta(1,1) + zeta(1,2) - 2*zeta(1,3) + zeta(1,4) -
& 3*(zeta(2,3) + zeta(3,3) + zeta(3,4)))*
& Dval(dd00222,Di1))
E(ee1334) = dabbr86*eta(1) -
& eta(3)*Dval(dd1223,Di3) +
& 2*(2*dabbr88*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) +
& dabbr87*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + zeta(2,4)*Dval(dd00122,Di3) +
& 2*zeta(2,3)*Dval(dd00123,Di3) +
& zeta(4,4)*Dval(dd00133,Di5) +
& zeta(1,1)*Dval(dd00223,Di2) +
& zeta(1,2)*Dval(dd00223,Di3) +
& (-zeta(1,1) - zeta(1,2) + zeta(1,3) + 2*zeta(2,3) +
& zeta(2,4) + 2*zeta(3,3) + 3*zeta(3,4) + zeta(4,4))*
& Dval(dd00223,Di1))
E(ee1344) = dabbr89*eta(1) -
& eta(3)*Dval(dd1233,Di3) +
& 2*(dabbr91*(zeta(1,3) + zeta(2,3) + zeta(3,3) +
& zeta(3,4)) +
& 2*dabbr90*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + 2*zeta(2,4)*Dval(dd00123,Di3) +
& zeta(2,3)*Dval(dd00133,Di3) +
& zeta(3,3)*Dval(dd00133,Di4) +
& zeta(1,1)*Dval(dd00233,Di2) +
& zeta(1,2)*Dval(dd00233,Di3) +
& (-zeta(1,1) - zeta(1,2) + zeta(1,4) + zeta(2,3) +
& 2*zeta(2,4) + zeta(3,3) + 3*zeta(3,4) + 2*zeta(4,4))
& *Dval(dd00233,Di1))
E(ee1444) = dabbr92*eta(1) -
& eta(3)*Dval(dd1333,Di3) -
& eta(4)*Dval(dd1333,Di4) +
& 2*(3*dabbr52*(zeta(1,4) + zeta(2,4) + zeta(3,4) +
& zeta(4,4)) + 3*zeta(2,4)*Dval(dd00133,Di3) +
& 3*zeta(3,4)*Dval(dd00133,Di4) +
& zeta(1,1)*Dval(dd00333,Di2) +
& zeta(1,2)*Dval(dd00333,Di3) +
& zeta(1,3)*Dval(dd00333,Di4) -
& (zeta(1,1) + zeta(1,2) + zeta(1,3) - 2*zeta(1,4) -
& 3*(zeta(2,4) + zeta(3,4) + zeta(4,4)))*
& Dval(dd00333,Di1))
E(ee2222) = -(eta(2)*Dval(dd1111,Di2)) -
& eta(4)*Dval(dd2222,Di4) -
& eta(5)*Dval(dd2222,Di5) -
& eta(1)*Dval(dd1111,Di1) +
& 8*zeta(1,2)*Dval(dd00111,Di2) +
& 8*zeta(2,3)*Dval(dd00222,Di4) +
& 8*zeta(2,4)*Dval(dd00222,Di5) -
& 8*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00111,Di1)
E(ee2223) = -(eta(2)*Dval(dd1112,Di2)) -
& eta(5)*Dval(dd2223,Di5) -
& eta(1)*Dval(dd1112,Di1) +
& 2*zeta(1,3)*Dval(dd00111,Di2) +
& 6*zeta(1,2)*Dval(dd00112,Di2) +
& 2*zeta(3,3)*Dval(dd00222,Di4) +
& 2*zeta(3,4)*Dval(dd00222,Di5) +
& 6*zeta(2,4)*Dval(dd00223,Di5) -
& 2*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00111,Di1) -
& 6*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00112,Di1)
E(ee2224) = -(eta(2)*Dval(dd1113,Di2)) -
& eta(4)*Dval(dd2223,Di4) -
& eta(1)*Dval(dd1113,Di1) +
& 2*zeta(1,4)*Dval(dd00111,Di2) +
& 6*zeta(1,2)*Dval(dd00113,Di2) +
& 2*zeta(3,4)*Dval(dd00222,Di4) +
& 2*zeta(4,4)*Dval(dd00222,Di5) +
& 6*zeta(2,3)*Dval(dd00223,Di4) -
& 2*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00111,Di1) -
& 6*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00113,Di1)
E(ee2233) = -(eta(2)*Dval(dd1122,Di2)) -
& eta(5)*Dval(dd2233,Di5) -
& eta(1)*Dval(dd1122,Di1) +
& 4*(zeta(1,3)*Dval(dd00112,Di2) +
& zeta(1,2)*Dval(dd00122,Di2) +
& zeta(3,4)*Dval(dd00223,Di5) +
& zeta(2,4)*Dval(dd00233,Di5) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00112,Di1) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00122,Di1))
E(ee2234) = -(eta(2)*Dval(dd1123,Di2)) -
& eta(1)*Dval(dd1123,Di1) +
& 2*(zeta(1,4)*Dval(dd00112,Di2) +
& zeta(1,3)*Dval(dd00113,Di2) +
& 2*zeta(1,2)*Dval(dd00123,Di2) +
& zeta(3,3)*Dval(dd00223,Di4) +
& zeta(4,4)*Dval(dd00223,Di5) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00112,Di1) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00113,Di1) -
& 2*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00123,Di1))
E(ee2244) = -(eta(2)*Dval(dd1133,Di2)) -
& eta(4)*Dval(dd2233,Di4) -
& eta(1)*Dval(dd1133,Di1) +
& 4*(zeta(1,4)*Dval(dd00113,Di2) +
& zeta(1,2)*Dval(dd00133,Di2) +
& zeta(3,4)*Dval(dd00223,Di4) +
& zeta(2,3)*Dval(dd00233,Di4) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00113,Di1) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00133,Di1))
E(ee2333) = -(eta(2)*Dval(dd1222,Di2)) -
& eta(5)*Dval(dd2333,Di5) -
& eta(1)*Dval(dd1222,Di1) +
& 6*zeta(1,3)*Dval(dd00122,Di2) +
& 2*zeta(1,2)*Dval(dd00222,Di2) +
& 2*zeta(2,2)*Dval(dd00222,Di3) +
& 6*zeta(3,4)*Dval(dd00233,Di5) +
& 2*zeta(2,4)*Dval(dd00333,Di5) -
& 6*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00122,Di1) -
& 2*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00222,Di1)
E(ee2334) = -(eta(2)*Dval(dd1223,Di2)) -
& eta(1)*Dval(dd1223,Di1) +
& 2*(zeta(1,4)*Dval(dd00122,Di2) +
& 2*zeta(1,3)*Dval(dd00123,Di2) +
& zeta(1,2)*Dval(dd00223,Di2) +
& zeta(2,2)*Dval(dd00223,Di3) +
& zeta(4,4)*Dval(dd00233,Di5) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00122,Di1) -
& 2*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00123,Di1) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00223,Di1))
E(ee2344) = -(eta(2)*Dval(dd1233,Di2)) -
& eta(1)*Dval(dd1233,Di1) +
& 2*(2*zeta(1,4)*Dval(dd00123,Di2) +
& zeta(1,3)*Dval(dd00133,Di2) +
& zeta(1,2)*Dval(dd00233,Di2) +
& zeta(2,2)*Dval(dd00233,Di3) +
& zeta(3,3)*Dval(dd00233,Di4) -
& 2*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00123,Di1) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00133,Di1) -
& (zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00233,Di1))
E(ee2444) = -(eta(2)*Dval(dd1333,Di2)) -
& eta(4)*Dval(dd2333,Di4) -
& eta(1)*Dval(dd1333,Di1) +
& 6*zeta(1,4)*Dval(dd00133,Di2) +
& 6*zeta(3,4)*Dval(dd00233,Di4) +
& 2*zeta(1,2)*Dval(dd00333,Di2) +
& 2*zeta(2,2)*Dval(dd00333,Di3) +
& 2*zeta(2,3)*Dval(dd00333,Di4) -
& 6*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00133,Di1) -
& 2*(zeta(1,2) + zeta(2,2) + zeta(2,3) + zeta(2,4))*
& Dval(dd00333,Di1)
E(ee3333) = -(eta(2)*Dval(dd2222,Di2)) -
& eta(3)*Dval(dd2222,Di3) -
& eta(5)*Dval(dd3333,Di5) -
& eta(1)*Dval(dd2222,Di1) +
& 8*zeta(1,3)*Dval(dd00222,Di2) +
& 8*zeta(2,3)*Dval(dd00222,Di3) +
& 8*zeta(3,4)*Dval(dd00333,Di5) -
& 8*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00222,Di1)
E(ee3334) = -(eta(2)*Dval(dd2223,Di2)) -
& eta(3)*Dval(dd2223,Di3) -
& eta(1)*Dval(dd2223,Di1) +
& 2*zeta(1,4)*Dval(dd00222,Di2) +
& 2*zeta(2,4)*Dval(dd00222,Di3) +
& 6*zeta(1,3)*Dval(dd00223,Di2) +
& 6*zeta(2,3)*Dval(dd00223,Di3) +
& 2*zeta(4,4)*Dval(dd00333,Di5) -
& 2*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00222,Di1) -
& 6*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00223,Di1)
E(ee3344) = -(eta(2)*Dval(dd2233,Di2)) -
& eta(3)*Dval(dd2233,Di3) -
& eta(1)*Dval(dd2233,Di1) +
& 4*(zeta(1,4)*Dval(dd00223,Di2) +
& zeta(2,4)*Dval(dd00223,Di3) +
& zeta(1,3)*Dval(dd00233,Di2) +
& zeta(2,3)*Dval(dd00233,Di3) -
& (zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00223,Di1) -
& (zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00233,Di1))
E(ee3444) = -(eta(2)*Dval(dd2333,Di2)) -
& eta(3)*Dval(dd2333,Di3) -
& eta(1)*Dval(dd2333,Di1) +
& 6*zeta(1,4)*Dval(dd00233,Di2) +
& 6*zeta(2,4)*Dval(dd00233,Di3) +
& 2*zeta(1,3)*Dval(dd00333,Di2) +
& 2*zeta(2,3)*Dval(dd00333,Di3) +
& 2*zeta(3,3)*Dval(dd00333,Di4) -
& 6*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00233,Di1) -
& 2*(zeta(1,3) + zeta(2,3) + zeta(3,3) + zeta(3,4))*
& Dval(dd00333,Di1)
E(ee4444) = -(eta(2)*Dval(dd3333,Di2)) -
& eta(3)*Dval(dd3333,Di3) -
& eta(4)*Dval(dd3333,Di4) -
& eta(1)*Dval(dd3333,Di1) +
& 8*zeta(1,4)*Dval(dd00333,Di2) +
& 8*zeta(2,4)*Dval(dd00333,Di3) +
& 8*zeta(3,4)*Dval(dd00333,Di4) -
& 8*(zeta(1,4) + zeta(2,4) + zeta(3,4) + zeta(4,4))*
& Dval(dd00333,Di1)
if( dump ) call XDumpCoeff(5, E)
end
diff --git a/Looptools/E/Ecoeffb.F b/Looptools/E/Ecoeffb.F
--- a/Looptools/E/Ecoeffb.F
+++ b/Looptools/E/Ecoeffb.F
@@ -1,505 +1,515 @@
* Ecoeffb.F
* the five-point tensor coefficients via Passarino-Veltman decomposition
* this file is part of LoopTools
* written by M. Rauch
-* last modified 7 Dec 05 th
+* last modified 29 Sep 10 th
#include "defs.h"
subroutine XEcoeffb(para, E, ldpara)
implicit none
integer ldpara
DVAR para(ldpara,Pee)
double complex E(Nee)
#include "lt.h"
integer XDget
double complex XE0
external XDget, XE0
DVAR p1, p2, p3, p4, p5
DVAR p1p2, p2p3, p3p4, p4p5, p5p1
DVAR m1, m2, m3, m4, m5
DVAR f1, f2, f3, f4
double complex di, d0sum
double complex d1i, d1sum, d2i, d2sum, dii
double complex d1ii, d2ii, diii
double complex d00sum, d22sum, d33sum
double complex in(4)
integer Di1, Di2, Di3, Di4, Di5
- integer perm(4)
logical dump
- QVAR G(4,4), Y(4,4)
- common /XltEgram/ Y
+ QVAR G(4,4), Ginv(4,4)
+ common /XInvGramE/ Ginv
+
+#ifdef SOLVE_EIGEN
+#define SOLVE_SETUP XInverse(4, G,4, Ginv,4)
+#define SOLVE(b) XSolve(4, G,4, Ginv,4, b)
+#else
+ integer perm(4)
+#define IN(i) in(perm(i))
+#define SOLVE_SETUP XInverse(4, G,4, Ginv,4, perm)
+#define SOLVE(b) XSolve(4, G,4, b)
+#endif
p1 = para(1,1)
p2 = para(1,2)
p3 = para(1,3)
p4 = para(1,4)
p5 = para(1,5)
p1p2 = para(1,6)
p2p3 = para(1,7)
p3p4 = para(1,8)
p4p5 = para(1,9)
p5p1 = para(1,10)
m1 = para(1,11)
m2 = para(1,12)
m3 = para(1,13)
m4 = para(1,14)
m5 = para(1,15)
#ifdef COMPLEXPARA
- if( DIMAG(p1) .eq. 0 .and.
- & DIMAG(p2) .eq. 0 .and.
- & DIMAG(p3) .eq. 0 .and.
- & DIMAG(p4) .eq. 0 .and.
- & DIMAG(p5) .eq. 0 .and.
- & DIMAG(p1p2) .eq. 0 .and.
- & DIMAG(p2p3) .eq. 0 .and.
- & DIMAG(p3p4) .eq. 0 .and.
- & DIMAG(p4p5) .eq. 0 .and.
- & DIMAG(p5p1) .eq. 0 .and.
- & DIMAG(m1) .eq. 0 .and.
- & DIMAG(m2) .eq. 0 .and.
- & DIMAG(m3) .eq. 0 .and.
- & DIMAG(m4) .eq. 0 .and.
- & DIMAG(m5) .eq. 0 ) then
+ if( abs(DIMAG(para(1,1))) +
+ & abs(DIMAG(para(1,2))) +
+ & abs(DIMAG(para(1,3))) +
+ & abs(DIMAG(para(1,4))) +
+ & abs(DIMAG(para(1,5))) +
+ & abs(DIMAG(para(1,6))) +
+ & abs(DIMAG(para(1,7))) +
+ & abs(DIMAG(para(1,8))) +
+ & abs(DIMAG(para(1,9))) +
+ & abs(DIMAG(para(1,10))) .gt. 0 )
+ & print *, "Warning: complex momenta not implemented"
+ if( abs(DIMAG(para(1,11))) +
+ & abs(DIMAG(para(1,12))) +
+ & abs(DIMAG(para(1,13))) +
+ & abs(DIMAG(para(1,14))) +
+ & abs(DIMAG(para(1,15))) .eq. 0 ) then
call Ecoeffb(para, E, 2)
return
endif
#endif
Di1 = XDget(p2, p3, p4, p5p1, p2p3, p3p4, m2, m3, m4, m5)
Di2 = XDget(p1p2, p3, p4, p5, p4p5, p3p4, m1, m3, m4, m5)
Di3 = XDget(p1, p2p3, p4, p5, p4p5, p5p1, m1, m2, m4, m5)
Di4 = XDget(p1, p2, p3p4, p5, p1p2, p5p1, m1, m2, m3, m5)
Di5 = XDget(p1, p2, p3, p4p5, p1p2, p2p3, m1, m2, m3, m4)
serial = serial + 1
dump = ibits(debugkey, DebugE, 1) .ne. 0 .and.
& serial .ge. debugfrom .and. serial .le. debugto
if( dump ) call XDumpPara(5, para, ldpara)
- f1 = QEXT(m2) - QEXT(m1) - QEXT(p1)
- f2 = QEXT(m3) - QEXT(m1) - QEXT(p1p2)
- f3 = QEXT(m4) - QEXT(m1) - QEXT(p4p5)
- f4 = QEXT(m5) - QEXT(m1) - QEXT(p5)
+ f1 = QPREC(m2) - QPREC(m1) - QPREC(p1)
+ f2 = QPREC(m3) - QPREC(m1) - QPREC(p1p2)
+ f3 = QPREC(m4) - QPREC(m1) - QPREC(p4p5)
+ f4 = QPREC(m5) - QPREC(m1) - QPREC(p5)
-* build up G and calculate its LU-decomposition and its inverse Y
- G(1,1) = 2*QEXT(p1)
- G(2,2) = 2*QEXT(p1p2)
- G(3,3) = 2*QEXT(p4p5)
- G(4,4) = 2*QEXT(p5)
- G(1,2) = QEXT(p1) + QEXT(p1p2) - QEXT(p2)
+* build up G and calculate matrix decomposition and inverse Y
+ G(1,1) = 2*QPREC(p1)
+ G(2,2) = 2*QPREC(p1p2)
+ G(3,3) = 2*QPREC(p4p5)
+ G(4,4) = 2*QPREC(p5)
+ G(1,2) = QPREC(p1) + QPREC(p1p2) - QPREC(p2)
G(2,1) = G(1,2)
- G(1,3) = QEXT(p1) - QEXT(p2p3) + QEXT(p4p5)
+ G(1,3) = QPREC(p1) - QPREC(p2p3) + QPREC(p4p5)
G(3,1) = G(1,3)
- G(1,4) = QEXT(p1) - QEXT(p5p1) + QEXT(p5)
+ G(1,4) = QPREC(p1) - QPREC(p5p1) + QPREC(p5)
G(4,1) = G(1,4)
- G(2,3) = QEXT(p1p2) - QEXT(p3) + QEXT(p4p5)
+ G(2,3) = QPREC(p1p2) - QPREC(p3) + QPREC(p4p5)
G(3,2) = G(2,3)
- G(2,4) = QEXT(p1p2) - QEXT(p3p4) + QEXT(p5)
+ G(2,4) = QPREC(p1p2) - QPREC(p3p4) + QPREC(p5)
G(4,2) = G(2,4)
- G(3,4) = QEXT(p5) + QEXT(p4p5) - QEXT(p4)
+ G(3,4) = QPREC(p5) + QPREC(p4p5) - QPREC(p4)
G(4,3) = G(3,4)
- call XInverse(G, Y, 4, perm)
+ call SOLVE_SETUP
di = Dval(dd1,Di1) + Dval(dd2,Di1) + Dval(dd3,Di1)
d0sum = Dval(dd0,Di1) + di
d1i = Dval(dd11,Di1) + Dval(dd12,Di1) + Dval(dd13,Di1)
d1sum = Dval(dd1,Di1) + d1i
d2i = Dval(dd12,Di1) + Dval(dd22,Di1) + Dval(dd23,Di1)
d2sum = Dval(dd2,Di1) + d2i
dii = d1i + d2i +
& Dval(dd13,Di1) + Dval(dd23,Di1) + Dval(dd33,Di1)
d1ii = Dval(dd111,Di1) + Dval(dd122,Di1) +
& Dval(dd133,Di1) + 2*(Dval(dd112,Di1) +
& Dval(dd113,Di1) + Dval(dd123,Di1))
d2ii = Dval(dd112,Di1) + Dval(dd222,Di1) +
& Dval(dd233,Di1) + 2*(Dval(dd122,Di1) +
& Dval(dd123,Di1) + Dval(dd223,Di1))
diii = d1ii + d2ii +
& Dval(dd113,Di1) + Dval(dd223,Di1) +
& Dval(dd333,Di1) + 2*(Dval(dd123,Di1) +
& Dval(dd133,Di1) + Dval(dd233,Di1))
d00sum = Dval(dd00,Di1) +
& Dval(dd001,Di1) + Dval(dd002,Di1) + Dval(dd003,Di1)
d22sum = Dval(dd22,Di1) +
& Dval(dd122,Di1) + Dval(dd222,Di1) + Dval(dd223,Di1)
d33sum = Dval(dd33,Di1) +
& Dval(dd133,Di1) + Dval(dd233,Di1) + Dval(dd333,Di1)
E(ee0) = XE0(p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
- in(1) = f1*E(ee0) - Dval(dd0,Di1) + Dval(dd0,Di2)
- in(2) = f2*E(ee0) - Dval(dd0,Di1) + Dval(dd0,Di3)
- in(3) = f3*E(ee0) - Dval(dd0,Di1) + Dval(dd0,Di4)
- in(4) = f4*E(ee0) - Dval(dd0,Di1) + Dval(dd0,Di5)
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee0) - Dval(dd0,Di1) + Dval(dd0,Di2)
+ IN(2) = f2*E(ee0) - Dval(dd0,Di1) + Dval(dd0,Di3)
+ IN(3) = f3*E(ee0) - Dval(dd0,Di1) + Dval(dd0,Di4)
+ IN(4) = f4*E(ee0) - Dval(dd0,Di1) + Dval(dd0,Di5)
+ call SOLVE(in)
E(ee1) = in(1)
E(ee2) = in(2)
E(ee3) = in(3)
E(ee4) = in(4)
E(ee00) = 0
- in(1) = f1*E(ee1) + d0sum
- in(2) = f2*E(ee1) + d0sum + Dval(dd1,Di3)
- in(3) = f3*E(ee1) + d0sum + Dval(dd1,Di4)
- in(4) = f4*E(ee1) + d0sum + Dval(dd1,Di5)
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee1) + d0sum
+ IN(2) = f2*E(ee1) + d0sum + Dval(dd1,Di3)
+ IN(3) = f3*E(ee1) + d0sum + Dval(dd1,Di4)
+ IN(4) = f4*E(ee1) + d0sum + Dval(dd1,Di5)
+ call SOLVE(in)
E(ee11) = in(1)
E(ee12) = in(2)
E(ee13) = in(3)
E(ee14) = in(4)
- in(1) = f1*E(ee2) - Dval(dd1,Di1) + Dval(dd1,Di2)
- in(2) = f2*E(ee2) - Dval(dd1,Di1)
- in(3) = f3*E(ee2) - Dval(dd1,Di1) + Dval(dd2,Di4)
- in(4) = f4*E(ee2) - Dval(dd1,Di1) + Dval(dd2,Di5)
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee2) - Dval(dd1,Di1) + Dval(dd1,Di2)
+ IN(2) = f2*E(ee2) - Dval(dd1,Di1)
+ IN(3) = f3*E(ee2) - Dval(dd1,Di1) + Dval(dd2,Di4)
+ IN(4) = f4*E(ee2) - Dval(dd1,Di1) + Dval(dd2,Di5)
+ call SOLVE(in)
E(ee12) = .5D0*(E(ee12) + in(1))
E(ee22) = in(2)
E(ee23) = in(3)
E(ee24) = in(4)
- in(1) = f1*E(ee3) - Dval(dd2,Di1) + Dval(dd2,Di2)
- in(2) = f2*E(ee3) - Dval(dd2,Di1) + Dval(dd2,Di3)
- in(3) = f3*E(ee3) - Dval(dd2,Di1)
- in(4) = f4*E(ee3) - Dval(dd2,Di1) + Dval(dd3,Di5)
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee3) - Dval(dd2,Di1) + Dval(dd2,Di2)
+ IN(2) = f2*E(ee3) - Dval(dd2,Di1) + Dval(dd2,Di3)
+ IN(3) = f3*E(ee3) - Dval(dd2,Di1)
+ IN(4) = f4*E(ee3) - Dval(dd2,Di1) + Dval(dd3,Di5)
+ call SOLVE(in)
E(ee13) = .5D0*(E(ee13) + in(1))
E(ee23) = .5D0*(E(ee23) + in(2))
E(ee33) = in(3)
E(ee34) = in(4)
- in(1) = f1*E(ee4) - Dval(dd3,Di1) + Dval(dd3,Di2)
- in(2) = f2*E(ee4) - Dval(dd3,Di1) + Dval(dd3,Di3)
- in(3) = f3*E(ee4) - Dval(dd3,Di1) + Dval(dd3,Di4)
- in(4) = f4*E(ee4) - Dval(dd3,Di1)
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee4) - Dval(dd3,Di1) + Dval(dd3,Di2)
+ IN(2) = f2*E(ee4) - Dval(dd3,Di1) + Dval(dd3,Di3)
+ IN(3) = f3*E(ee4) - Dval(dd3,Di1) + Dval(dd3,Di4)
+ IN(4) = f4*E(ee4) - Dval(dd3,Di1)
+ call SOLVE(in)
E(ee14) = .5D0*(E(ee14) + in(1))
E(ee24) = .5D0*(E(ee24) + in(2))
E(ee34) = .5D0*(E(ee34) + in(3))
E(ee44) = in(4)
E(ee001) = 0
E(ee002) = 0
E(ee003) = 0
E(ee004) = 0
d0sum = d0sum + di + dii
- in(1) = f1*E(ee11) - d0sum -
- & 2*Y(1,1)*(Dval(dd00,Di1) - Dval(dd00,Di2))
- in(2) = f2*E(ee11) - d0sum + Dval(dd11,Di3) -
- & 2*Y(1,1)*(Dval(dd00,Di1) - Dval(dd00,Di3))
- in(3) = f3*E(ee11) - d0sum + Dval(dd11,Di4) -
- & 2*Y(1,1)*(Dval(dd00,Di1) - Dval(dd00,Di4))
- in(4) = f4*E(ee11) - d0sum + Dval(dd11,Di5) -
- & 2*Y(1,1)*(Dval(dd00,Di1) - Dval(dd00,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee11) - d0sum -
+ & 2*Ginv(1,1)*(Dval(dd00,Di1) - Dval(dd00,Di2))
+ IN(2) = f2*E(ee11) - d0sum + Dval(dd11,Di3) -
+ & 2*Ginv(1,1)*(Dval(dd00,Di1) - Dval(dd00,Di3))
+ IN(3) = f3*E(ee11) - d0sum + Dval(dd11,Di4) -
+ & 2*Ginv(1,1)*(Dval(dd00,Di1) - Dval(dd00,Di4))
+ IN(4) = f4*E(ee11) - d0sum + Dval(dd11,Di5) -
+ & 2*Ginv(1,1)*(Dval(dd00,Di1) - Dval(dd00,Di5))
+ call SOLVE(in)
E(ee111) = in(1)
E(ee112) = in(2)
E(ee113) = in(3)
E(ee114) = in(4)
- in(1) = f1*E(ee22) - Dval(dd11,Di1) + Dval(dd11,Di2) -
- & 2*Y(2,2)*(Dval(dd00,Di1) - Dval(dd00,Di2))
- in(2) = f2*E(ee22) - Dval(dd11,Di1) -
- & 2*Y(2,2)*(Dval(dd00,Di1) - Dval(dd00,Di3))
- in(3) = f3*E(ee22) - Dval(dd11,Di1) + Dval(dd22,Di4) -
- & 2*Y(2,2)*(Dval(dd00,Di1) - Dval(dd00,Di4))
- in(4) = f4*E(ee22) - Dval(dd11,Di1) + Dval(dd22,Di5) -
- & 2*Y(2,2)*(Dval(dd00,Di1) - Dval(dd00,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee22) - Dval(dd11,Di1) + Dval(dd11,Di2) -
+ & 2*Ginv(2,2)*(Dval(dd00,Di1) - Dval(dd00,Di2))
+ IN(2) = f2*E(ee22) - Dval(dd11,Di1) -
+ & 2*Ginv(2,2)*(Dval(dd00,Di1) - Dval(dd00,Di3))
+ IN(3) = f3*E(ee22) - Dval(dd11,Di1) + Dval(dd22,Di4) -
+ & 2*Ginv(2,2)*(Dval(dd00,Di1) - Dval(dd00,Di4))
+ IN(4) = f4*E(ee22) - Dval(dd11,Di1) + Dval(dd22,Di5) -
+ & 2*Ginv(2,2)*(Dval(dd00,Di1) - Dval(dd00,Di5))
+ call SOLVE(in)
E(ee122) = in(1)
E(ee222) = in(2)
E(ee223) = in(3)
E(ee224) = in(4)
- in(1) = f1*E(ee33) - Dval(dd22,Di1) + Dval(dd22,Di2) -
- & 2*Y(3,3)*(Dval(dd00,Di1) - Dval(dd00,Di2))
- in(2) = f2*E(ee33) - Dval(dd22,Di1) + Dval(dd22,Di3) -
- & 2*Y(3,3)*(Dval(dd00,Di1) - Dval(dd00,Di3))
- in(3) = f3*E(ee33) - Dval(dd22,Di1) -
- & 2*Y(3,3)*(Dval(dd00,Di1) - Dval(dd00,Di4))
- in(4) = f4*E(ee33) - Dval(dd22,Di1) + Dval(dd33,Di5) -
- & 2*Y(3,3)*(Dval(dd00,Di1) - Dval(dd00,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee33) - Dval(dd22,Di1) + Dval(dd22,Di2) -
+ & 2*Ginv(3,3)*(Dval(dd00,Di1) - Dval(dd00,Di2))
+ IN(2) = f2*E(ee33) - Dval(dd22,Di1) + Dval(dd22,Di3) -
+ & 2*Ginv(3,3)*(Dval(dd00,Di1) - Dval(dd00,Di3))
+ IN(3) = f3*E(ee33) - Dval(dd22,Di1) -
+ & 2*Ginv(3,3)*(Dval(dd00,Di1) - Dval(dd00,Di4))
+ IN(4) = f4*E(ee33) - Dval(dd22,Di1) + Dval(dd33,Di5) -
+ & 2*Ginv(3,3)*(Dval(dd00,Di1) - Dval(dd00,Di5))
+ call SOLVE(in)
E(ee133) = in(1)
E(ee233) = in(2)
E(ee333) = in(3)
E(ee334) = in(4)
- in(1) = f1*E(ee44) - Dval(dd33,Di1) + Dval(dd33,Di2) -
- & 2*Y(4,4)*(Dval(dd00,Di1) - Dval(dd00,Di2))
- in(2) = f2*E(ee44) - Dval(dd33,Di1) + Dval(dd33,Di3) -
- & 2*Y(4,4)*(Dval(dd00,Di1) - Dval(dd00,Di3))
- in(3) = f3*E(ee44) - Dval(dd33,Di1) + Dval(dd33,Di4) -
- & 2*Y(4,4)*(Dval(dd00,Di1) - Dval(dd00,Di4))
- in(4) = f4*E(ee44) - Dval(dd33,Di1) -
- & 2*Y(4,4)*(Dval(dd00,Di1) - Dval(dd00,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee44) - Dval(dd33,Di1) + Dval(dd33,Di2) -
+ & 2*Ginv(4,4)*(Dval(dd00,Di1) - Dval(dd00,Di2))
+ IN(2) = f2*E(ee44) - Dval(dd33,Di1) + Dval(dd33,Di3) -
+ & 2*Ginv(4,4)*(Dval(dd00,Di1) - Dval(dd00,Di3))
+ IN(3) = f3*E(ee44) - Dval(dd33,Di1) + Dval(dd33,Di4) -
+ & 2*Ginv(4,4)*(Dval(dd00,Di1) - Dval(dd00,Di4))
+ IN(4) = f4*E(ee44) - Dval(dd33,Di1) -
+ & 2*Ginv(4,4)*(Dval(dd00,Di1) - Dval(dd00,Di5))
+ call SOLVE(in)
E(ee144) = in(1)
E(ee244) = in(2)
E(ee344) = in(3)
E(ee444) = in(4)
- in(1) = f1*E(ee12) + d1sum -
- & 2*Y(1,2)*(Dval(dd00,Di1) - Dval(dd00,Di2))
- in(2) = f2*E(ee12) + d1sum -
- & 2*Y(1,2)*(Dval(dd00,Di1) - Dval(dd00,Di3))
- in(3) = f3*E(ee12) + d1sum + Dval(dd12,Di4) -
- & 2*Y(1,2)*(Dval(dd00,Di1) - Dval(dd00,Di4))
- in(4) = f4*E(ee12) + d1sum + Dval(dd12,Di5) -
- & 2*Y(1,2)*(Dval(dd00,Di1) - Dval(dd00,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee12) + d1sum -
+ & 2*Ginv(1,2)*(Dval(dd00,Di1) - Dval(dd00,Di2))
+ IN(2) = f2*E(ee12) + d1sum -
+ & 2*Ginv(1,2)*(Dval(dd00,Di1) - Dval(dd00,Di3))
+ IN(3) = f3*E(ee12) + d1sum + Dval(dd12,Di4) -
+ & 2*Ginv(1,2)*(Dval(dd00,Di1) - Dval(dd00,Di4))
+ IN(4) = f4*E(ee12) + d1sum + Dval(dd12,Di5) -
+ & 2*Ginv(1,2)*(Dval(dd00,Di1) - Dval(dd00,Di5))
+ call SOLVE(in)
E(ee112) = .5D0*(E(ee112) + in(1))
E(ee122) = .5D0*(E(ee122) + in(2))
E(ee123) = in(3)
E(ee124) = in(4)
- in(1) = f1*E(ee34) - Dval(dd23,Di1) + Dval(dd23,Di2) -
- & 2*Y(3,4)*(Dval(dd00,Di1) - Dval(dd00,Di2))
- in(2) = f2*E(ee34) - Dval(dd23,Di1) + Dval(dd23,Di3) -
- & 2*Y(3,4)*(Dval(dd00,Di1) - Dval(dd00,Di3))
- in(3) = f3*E(ee34) - Dval(dd23,Di1) -
- & 2*Y(3,4)*(Dval(dd00,Di1) - Dval(dd00,Di4))
- in(4) = f4*E(ee34) - Dval(dd23,Di1) -
- & 2*Y(3,4)*(Dval(dd00,Di1) - Dval(dd00,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee34) - Dval(dd23,Di1) + Dval(dd23,Di2) -
+ & 2*Ginv(3,4)*(Dval(dd00,Di1) - Dval(dd00,Di2))
+ IN(2) = f2*E(ee34) - Dval(dd23,Di1) + Dval(dd23,Di3) -
+ & 2*Ginv(3,4)*(Dval(dd00,Di1) - Dval(dd00,Di3))
+ IN(3) = f3*E(ee34) - Dval(dd23,Di1) -
+ & 2*Ginv(3,4)*(Dval(dd00,Di1) - Dval(dd00,Di4))
+ IN(4) = f4*E(ee34) - Dval(dd23,Di1) -
+ & 2*Ginv(3,4)*(Dval(dd00,Di1) - Dval(dd00,Di5))
+ call SOLVE(in)
E(ee134) = in(1)
E(ee234) = in(2)
E(ee334) = .5D0*(E(ee334) + in(3))
E(ee344) = .5D0*(E(ee344) + in(4))
E(ee0000) = 0
E(ee0011) = 0
E(ee0012) = 0
E(ee0013) = 0
E(ee0014) = 0
E(ee0022) = 0
E(ee0023) = 0
E(ee0024) = 0
E(ee0033) = 0
E(ee0034) = 0
E(ee0044) = 0
d0sum = d0sum + di + 2*dii + diii
- in(1) = f1*E(ee111) + d0sum +
- & 6*Y(1,1)*d00sum
- in(2) = f2*E(ee111) + d0sum + Dval(dd111,Di3) +
- & 6*Y(1,1)*(d00sum + Dval(dd001,Di3))
- in(3) = f3*E(ee111) + d0sum + Dval(dd111,Di4) +
- & 6*Y(1,1)*(d00sum + Dval(dd001,Di4))
- in(4) = f4*E(ee111) + d0sum + Dval(dd111,Di5) +
- & 6*Y(1,1)*(d00sum + Dval(dd001,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee111) + d0sum +
+ & 6*Ginv(1,1)*d00sum
+ IN(2) = f2*E(ee111) + d0sum + Dval(dd111,Di3) +
+ & 6*Ginv(1,1)*(d00sum + Dval(dd001,Di3))
+ IN(3) = f3*E(ee111) + d0sum + Dval(dd111,Di4) +
+ & 6*Ginv(1,1)*(d00sum + Dval(dd001,Di4))
+ IN(4) = f4*E(ee111) + d0sum + Dval(dd111,Di5) +
+ & 6*Ginv(1,1)*(d00sum + Dval(dd001,Di5))
+ call SOLVE(in)
E(ee1111) = in(1)
E(ee1112) = in(2)
E(ee1113) = in(3)
E(ee1114) = in(4)
- in(1) = f1*E(ee222) - Dval(dd111,Di1) + Dval(dd111,Di2) -
- & 6*Y(2,2)*(Dval(dd001,Di1) - Dval(dd001,Di2))
- in(2) = f2*E(ee222) - Dval(dd111,Di1) -
- & 6*Y(2,2)*Dval(dd001,Di1)
- in(3) = f3*E(ee222) - Dval(dd111,Di1) + Dval(dd222,Di4) -
- & 6*Y(2,2)*(Dval(dd001,Di1) - Dval(dd002,Di4))
- in(4) = f4*E(ee222) - Dval(dd111,Di1) + Dval(dd222,Di5) -
- & 6*Y(2,2)*(Dval(dd001,Di1) - Dval(dd002,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee222) - Dval(dd111,Di1) + Dval(dd111,Di2) -
+ & 6*Ginv(2,2)*(Dval(dd001,Di1) - Dval(dd001,Di2))
+ IN(2) = f2*E(ee222) - Dval(dd111,Di1) -
+ & 6*Ginv(2,2)*Dval(dd001,Di1)
+ IN(3) = f3*E(ee222) - Dval(dd111,Di1) + Dval(dd222,Di4) -
+ & 6*Ginv(2,2)*(Dval(dd001,Di1) - Dval(dd002,Di4))
+ IN(4) = f4*E(ee222) - Dval(dd111,Di1) + Dval(dd222,Di5) -
+ & 6*Ginv(2,2)*(Dval(dd001,Di1) - Dval(dd002,Di5))
+ call SOLVE(in)
E(ee1222) = in(1)
E(ee2222) = in(2)
E(ee2223) = in(3)
E(ee2224) = in(4)
- in(1) = f1*E(ee333) - Dval(dd222,Di1) + Dval(dd222,Di2) -
- & 6*Y(3,3)*(Dval(dd002,Di1) - Dval(dd002,Di2))
- in(2) = f2*E(ee333) - Dval(dd222,Di1) + Dval(dd222,Di3) -
- & 6*Y(3,3)*(Dval(dd002,Di1) - Dval(dd002,Di3))
- in(3) = f3*E(ee333) - Dval(dd222,Di1) -
- & 6*Y(3,3)*Dval(dd002,Di1)
- in(4) = f4*E(ee333) - Dval(dd222,Di1) + Dval(dd333,Di5) -
- & 6*Y(3,3)*(Dval(dd002,Di1) - Dval(dd003,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee333) - Dval(dd222,Di1) + Dval(dd222,Di2) -
+ & 6*Ginv(3,3)*(Dval(dd002,Di1) - Dval(dd002,Di2))
+ IN(2) = f2*E(ee333) - Dval(dd222,Di1) + Dval(dd222,Di3) -
+ & 6*Ginv(3,3)*(Dval(dd002,Di1) - Dval(dd002,Di3))
+ IN(3) = f3*E(ee333) - Dval(dd222,Di1) -
+ & 6*Ginv(3,3)*Dval(dd002,Di1)
+ IN(4) = f4*E(ee333) - Dval(dd222,Di1) + Dval(dd333,Di5) -
+ & 6*Ginv(3,3)*(Dval(dd002,Di1) - Dval(dd003,Di5))
+ call SOLVE(in)
E(ee1333) = in(1)
E(ee2333) = in(2)
E(ee3333) = in(3)
E(ee3334) = in(4)
- in(1) = f1*E(ee444) - Dval(dd333,Di1) + Dval(dd333,Di2) -
- & 6*Y(4,4)*(Dval(dd003,Di1) - Dval(dd003,Di2))
- in(2) = f2*E(ee444) - Dval(dd333,Di1) + Dval(dd333,Di3) -
- & 6*Y(4,4)*(Dval(dd003,Di1) - Dval(dd003,Di3))
- in(3) = f3*E(ee444) - Dval(dd333,Di1) + Dval(dd333,Di4) -
- & 6*Y(4,4)*(Dval(dd003,Di1) - Dval(dd003,Di4))
- in(4) = f4*E(ee444) - Dval(dd333,Di1) -
- & 6*Y(4,4)*Dval(dd003,Di1)
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee444) - Dval(dd333,Di1) + Dval(dd333,Di2) -
+ & 6*Ginv(4,4)*(Dval(dd003,Di1) - Dval(dd003,Di2))
+ IN(2) = f2*E(ee444) - Dval(dd333,Di1) + Dval(dd333,Di3) -
+ & 6*Ginv(4,4)*(Dval(dd003,Di1) - Dval(dd003,Di3))
+ IN(3) = f3*E(ee444) - Dval(dd333,Di1) + Dval(dd333,Di4) -
+ & 6*Ginv(4,4)*(Dval(dd003,Di1) - Dval(dd003,Di4))
+ IN(4) = f4*E(ee444) - Dval(dd333,Di1) -
+ & 6*Ginv(4,4)*Dval(dd003,Di1)
+ call SOLVE(in)
E(ee1444) = in(1)
E(ee2444) = in(2)
E(ee3444) = in(3)
E(ee4444) = in(4)
d1sum = d1sum + d1i + d1ii
- in(1) = f1*E(ee112) - d1sum -
- & 2*Y(1,1)*(Dval(dd001,Di1) - Dval(dd001,Di2)) +
- & 4*Y(1,2)*d00sum
- in(2) = f2*E(ee112) - d1sum -
- & 2*Y(1,1)*Dval(dd001,Di1) +
- & 4*Y(1,2)*(d00sum + Dval(dd001,Di3))
- in(3) = f3*E(ee112) - d1sum + Dval(dd112,Di4) -
- & 2*Y(1,1)*(Dval(dd001,Di1) - Dval(dd002,Di4)) +
- & 4*Y(1,2)*(d00sum + Dval(dd001,Di4))
- in(4) = f4*E(ee112) - d1sum + Dval(dd112,Di5) -
- & 2*Y(1,1)*(Dval(dd001,Di1) - Dval(dd002,Di5)) +
- & 4*Y(1,2)*(d00sum + Dval(dd001,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee112) - d1sum -
+ & 2*Ginv(1,1)*(Dval(dd001,Di1) - Dval(dd001,Di2)) +
+ & 4*Ginv(1,2)*d00sum
+ IN(2) = f2*E(ee112) - d1sum -
+ & 2*Ginv(1,1)*Dval(dd001,Di1) +
+ & 4*Ginv(1,2)*(d00sum + Dval(dd001,Di3))
+ IN(3) = f3*E(ee112) - d1sum + Dval(dd112,Di4) -
+ & 2*Ginv(1,1)*(Dval(dd001,Di1) - Dval(dd002,Di4)) +
+ & 4*Ginv(1,2)*(d00sum + Dval(dd001,Di4))
+ IN(4) = f4*E(ee112) - d1sum + Dval(dd112,Di5) -
+ & 2*Ginv(1,1)*(Dval(dd001,Di1) - Dval(dd002,Di5)) +
+ & 4*Ginv(1,2)*(d00sum + Dval(dd001,Di5))
+ call SOLVE(in)
E(ee1112) = .5D0*(E(ee1112) + in(1))
E(ee1122) = in(2)
E(ee1123) = in(3)
E(ee1124) = in(4)
- in(1) = f1*E(ee223) - Dval(dd112,Di1) + Dval(dd112,Di2) -
- & 2*Y(2,2)*(Dval(dd002,Di1) - Dval(dd002,Di2)) -
- & 4*Y(2,3)*(Dval(dd001,Di1) - Dval(dd001,Di2))
- in(2) = f2*E(ee223) - Dval(dd112,Di1) -
- & 2*Y(2,2)*(Dval(dd002,Di1) - Dval(dd002,Di3)) -
- & 4*Y(2,3)*Dval(dd001,Di1)
- in(3) = f3*E(ee223) - Dval(dd112,Di1) -
- & 2*Y(2,2)*Dval(dd002,Di1) -
- & 4*Y(2,3)*(Dval(dd001,Di1) - Dval(dd002,Di4))
- in(4) = f4*E(ee223) - Dval(dd112,Di1) + Dval(dd223,Di5) -
- & 2*Y(2,2)*(Dval(dd002,Di1) - Dval(dd003,Di5)) -
- & 4*Y(2,3)*(Dval(dd001,Di1) - Dval(dd002,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee223) - Dval(dd112,Di1) + Dval(dd112,Di2) -
+ & 2*Ginv(2,2)*(Dval(dd002,Di1) - Dval(dd002,Di2)) -
+ & 4*Ginv(2,3)*(Dval(dd001,Di1) - Dval(dd001,Di2))
+ IN(2) = f2*E(ee223) - Dval(dd112,Di1) -
+ & 2*Ginv(2,2)*(Dval(dd002,Di1) - Dval(dd002,Di3)) -
+ & 4*Ginv(2,3)*Dval(dd001,Di1)
+ IN(3) = f3*E(ee223) - Dval(dd112,Di1) -
+ & 2*Ginv(2,2)*Dval(dd002,Di1) -
+ & 4*Ginv(2,3)*(Dval(dd001,Di1) - Dval(dd002,Di4))
+ IN(4) = f4*E(ee223) - Dval(dd112,Di1) + Dval(dd223,Di5) -
+ & 2*Ginv(2,2)*(Dval(dd002,Di1) - Dval(dd003,Di5)) -
+ & 4*Ginv(2,3)*(Dval(dd001,Di1) - Dval(dd002,Di5))
+ call SOLVE(in)
E(ee1223) = in(1)
E(ee2223) = .5D0*(E(ee2223) + in(2))
E(ee2233) = in(3)
E(ee2234) = in(4)
- in(1) = f1*E(ee334) - Dval(dd223,Di1) + Dval(dd223,Di2) -
- & 2*Y(3,3)*(Dval(dd003,Di1) - Dval(dd003,Di2)) -
- & 4*Y(3,4)*(Dval(dd002,Di1) - Dval(dd002,Di2))
- in(2) = f2*E(ee334) - Dval(dd223,Di1) + Dval(dd223,Di3) -
- & 2*Y(3,3)*(Dval(dd003,Di1) - Dval(dd003,Di3)) -
- & 4*Y(3,4)*(Dval(dd002,Di1) - Dval(dd002,Di3))
- in(3) = f3*E(ee334) - Dval(dd223,Di1) -
- & 2*Y(3,3)*(Dval(dd003,Di1) - Dval(dd003,Di4)) -
- & 4*Y(3,4)*Dval(dd002,Di1)
- in(4) = f4*E(ee334) - Dval(dd223,Di1) -
- & 2*Y(3,3)*Dval(dd003,Di1) -
- & 4*Y(3,4)*(Dval(dd002,Di1) - Dval(dd003,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee334) - Dval(dd223,Di1) + Dval(dd223,Di2) -
+ & 2*Ginv(3,3)*(Dval(dd003,Di1) - Dval(dd003,Di2)) -
+ & 4*Ginv(3,4)*(Dval(dd002,Di1) - Dval(dd002,Di2))
+ IN(2) = f2*E(ee334) - Dval(dd223,Di1) + Dval(dd223,Di3) -
+ & 2*Ginv(3,3)*(Dval(dd003,Di1) - Dval(dd003,Di3)) -
+ & 4*Ginv(3,4)*(Dval(dd002,Di1) - Dval(dd002,Di3))
+ IN(3) = f3*E(ee334) - Dval(dd223,Di1) -
+ & 2*Ginv(3,3)*(Dval(dd003,Di1) - Dval(dd003,Di4)) -
+ & 4*Ginv(3,4)*Dval(dd002,Di1)
+ IN(4) = f4*E(ee334) - Dval(dd223,Di1) -
+ & 2*Ginv(3,3)*Dval(dd003,Di1) -
+ & 4*Ginv(3,4)*(Dval(dd002,Di1) - Dval(dd003,Di5))
+ call SOLVE(in)
E(ee1334) = in(1)
E(ee2334) = in(2)
E(ee3334) = .5D0*(E(ee3334) + in(3))
E(ee3344) = in(4)
- in(1) = f1*E(ee144) + d33sum -
- & 4*Y(1,4)*(Dval(dd003,Di1) - Dval(dd003,Di2)) +
- & 2*Y(4,4)*d00sum
- in(2) = f2*E(ee144) + d33sum + Dval(dd133,Di3) -
- & 4*Y(1,4)*(Dval(dd003,Di1) - Dval(dd003,Di3)) +
- & 2*Y(4,4)*(d00sum + Dval(dd001,Di3))
- in(3) = f3*E(ee144) + d33sum + Dval(dd133,Di4) -
- & 4*Y(1,4)*(Dval(dd003,Di1) - Dval(dd003,Di4)) +
- & 2*Y(4,4)*(d00sum + Dval(dd001,Di4))
- in(4) = f4*E(ee144) + d33sum -
- & 4*Y(1,4)*Dval(dd003,Di1) +
- & 2*Y(4,4)*(d00sum + Dval(dd001,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee144) + d33sum -
+ & 4*Ginv(1,4)*(Dval(dd003,Di1) - Dval(dd003,Di2)) +
+ & 2*Ginv(4,4)*d00sum
+ IN(2) = f2*E(ee144) + d33sum + Dval(dd133,Di3) -
+ & 4*Ginv(1,4)*(Dval(dd003,Di1) - Dval(dd003,Di3)) +
+ & 2*Ginv(4,4)*(d00sum + Dval(dd001,Di3))
+ IN(3) = f3*E(ee144) + d33sum + Dval(dd133,Di4) -
+ & 4*Ginv(1,4)*(Dval(dd003,Di1) - Dval(dd003,Di4)) +
+ & 2*Ginv(4,4)*(d00sum + Dval(dd001,Di4))
+ IN(4) = f4*E(ee144) + d33sum -
+ & 4*Ginv(1,4)*Dval(dd003,Di1) +
+ & 2*Ginv(4,4)*(d00sum + Dval(dd001,Di5))
+ call SOLVE(in)
E(ee1144) = in(1)
E(ee1244) = in(2)
E(ee1344) = in(3)
E(ee1444) = .5D0*(E(ee1444) + in(4))
d2sum = d2sum + d2i + d2ii
- in(1) = f1*E(ee113) - d2sum -
- & 2*Y(1,1)*(Dval(dd002,Di1) - Dval(dd002,Di2)) +
- & 4*Y(1,3)*d00sum
- in(2) = f2*E(ee113) - d2sum + Dval(dd112,Di3) -
- & 2*Y(1,1)*(Dval(dd002,Di1) - Dval(dd002,Di3)) +
- & 4*Y(1,3)*(d00sum + Dval(dd001,Di3))
- in(3) = f3*E(ee113) - d2sum -
- & 2*Y(1,1)*Dval(dd002,Di1) +
- & 4*Y(1,3)*(d00sum + Dval(dd001,Di4))
- in(4) = f4*E(ee113) - d2sum + Dval(dd113,Di5) -
- & 2*Y(1,1)*(Dval(dd002,Di1) - Dval(dd003,Di5)) +
- & 4*Y(1,3)*(d00sum + Dval(dd001,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee113) - d2sum -
+ & 2*Ginv(1,1)*(Dval(dd002,Di1) - Dval(dd002,Di2)) +
+ & 4*Ginv(1,3)*d00sum
+ IN(2) = f2*E(ee113) - d2sum + Dval(dd112,Di3) -
+ & 2*Ginv(1,1)*(Dval(dd002,Di1) - Dval(dd002,Di3)) +
+ & 4*Ginv(1,3)*(d00sum + Dval(dd001,Di3))
+ IN(3) = f3*E(ee113) - d2sum -
+ & 2*Ginv(1,1)*Dval(dd002,Di1) +
+ & 4*Ginv(1,3)*(d00sum + Dval(dd001,Di4))
+ IN(4) = f4*E(ee113) - d2sum + Dval(dd113,Di5) -
+ & 2*Ginv(1,1)*(Dval(dd002,Di1) - Dval(dd003,Di5)) +
+ & 4*Ginv(1,3)*(d00sum + Dval(dd001,Di5))
+ call SOLVE(in)
E(ee1113) = .5D0*(E(ee1113) + in(1))
E(ee1123) = .5D0*(E(ee1123) + in(2))
E(ee1133) = in(3)
E(ee1134) = in(4)
- in(1) = f1*E(ee224) - Dval(dd113,Di1) + Dval(dd113,Di2) -
- & 2*Y(2,2)*(Dval(dd003,Di1) - Dval(dd003,Di2)) -
- & 4*Y(2,4)*(Dval(dd001,Di1) - Dval(dd001,Di2))
- in(2) = f2*E(ee224) - Dval(dd113,Di1) -
- & 2*Y(2,2)*(Dval(dd003,Di1) - Dval(dd003,Di3)) -
- & 4*Y(2,4)*Dval(dd001,Di1)
- in(3) = f3*E(ee224) - Dval(dd113,Di1) + Dval(dd223,Di4) -
- & 2*Y(2,2)*(Dval(dd003,Di1) - Dval(dd003,Di4)) -
- & 4*Y(2,4)*(Dval(dd001,Di1) - Dval(dd002,Di4))
- in(4) = f4*E(ee224) - Dval(dd113,Di1) -
- & 2*Y(2,2)*Dval(dd003,Di1) -
- & 4*Y(2,4)*(Dval(dd001,Di1) - Dval(dd002,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee224) - Dval(dd113,Di1) + Dval(dd113,Di2) -
+ & 2*Ginv(2,2)*(Dval(dd003,Di1) - Dval(dd003,Di2)) -
+ & 4*Ginv(2,4)*(Dval(dd001,Di1) - Dval(dd001,Di2))
+ IN(2) = f2*E(ee224) - Dval(dd113,Di1) -
+ & 2*Ginv(2,2)*(Dval(dd003,Di1) - Dval(dd003,Di3)) -
+ & 4*Ginv(2,4)*Dval(dd001,Di1)
+ IN(3) = f3*E(ee224) - Dval(dd113,Di1) + Dval(dd223,Di4) -
+ & 2*Ginv(2,2)*(Dval(dd003,Di1) - Dval(dd003,Di4)) -
+ & 4*Ginv(2,4)*(Dval(dd001,Di1) - Dval(dd002,Di4))
+ IN(4) = f4*E(ee224) - Dval(dd113,Di1) -
+ & 2*Ginv(2,2)*Dval(dd003,Di1) -
+ & 4*Ginv(2,4)*(Dval(dd001,Di1) - Dval(dd002,Di5))
+ call SOLVE(in)
E(ee1224) = in(1)
E(ee2224) = .5D0*(E(ee2224) + in(2))
E(ee2234) = E(ee2234) + in(3)
E(ee2244) = in(4)
- in(1) = f1*E(ee234) - Dval(dd123,Di1) + Dval(dd123,Di2) -
- & 2*Y(2,3)*(Dval(dd003,Di1) - Dval(dd003,Di2)) -
- & 2*Y(3,4)*(Dval(dd001,Di1) - Dval(dd001,Di2)) -
- & 2*Y(2,4)*(Dval(dd002,Di1) - Dval(dd002,Di2))
- in(2) = f2*E(ee234) - Dval(dd123,Di1) -
- & 2*Y(2,3)*(Dval(dd003,Di1) - Dval(dd003,Di3)) -
- & 2*Y(3,4)*Dval(dd001,Di1) -
- & 2*Y(2,4)*(Dval(dd002,Di1) - Dval(dd002,Di3))
- in(3) = f3*E(ee234) - Dval(dd123,Di1) -
- & 2*Y(2,3)*(Dval(dd003,Di1) - Dval(dd003,Di4)) -
- & 2*Y(3,4)*(Dval(dd001,Di1) - Dval(dd002,Di4)) -
- & 2*Y(2,4)*Dval(dd002,Di1)
- in(4) = f4*E(ee234) - Dval(dd123,Di1) -
- & 2*Y(2,3)*Dval(dd003,Di1) -
- & 2*Y(3,4)*(Dval(dd001,Di1) - Dval(dd002,Di5)) -
- & 2*Y(2,4)*(Dval(dd002,Di1) - Dval(dd003,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee234) - Dval(dd123,Di1) + Dval(dd123,Di2) -
+ & 2*Ginv(2,3)*(Dval(dd003,Di1) - Dval(dd003,Di2)) -
+ & 2*Ginv(3,4)*(Dval(dd001,Di1) - Dval(dd001,Di2)) -
+ & 2*Ginv(2,4)*(Dval(dd002,Di1) - Dval(dd002,Di2))
+ IN(2) = f2*E(ee234) - Dval(dd123,Di1) -
+ & 2*Ginv(2,3)*(Dval(dd003,Di1) - Dval(dd003,Di3)) -
+ & 2*Ginv(3,4)*Dval(dd001,Di1) -
+ & 2*Ginv(2,4)*(Dval(dd002,Di1) - Dval(dd002,Di3))
+ IN(3) = f3*E(ee234) - Dval(dd123,Di1) -
+ & 2*Ginv(2,3)*(Dval(dd003,Di1) - Dval(dd003,Di4)) -
+ & 2*Ginv(3,4)*(Dval(dd001,Di1) - Dval(dd002,Di4)) -
+ & 2*Ginv(2,4)*Dval(dd002,Di1)
+ IN(4) = f4*E(ee234) - Dval(dd123,Di1) -
+ & 2*Ginv(2,3)*Dval(dd003,Di1) -
+ & 2*Ginv(3,4)*(Dval(dd001,Di1) - Dval(dd002,Di5)) -
+ & 2*Ginv(2,4)*(Dval(dd002,Di1) - Dval(dd003,Di5))
+ call SOLVE(in)
E(ee1234) = in(1)
E(ee2234) = 1/3D0*(E(ee2234) + in(2))
E(ee2334) = .5D0*(E(ee2334) + in(3))
E(ee2344) = in(4)
- in(1) = f1*E(ee133) + d22sum -
- & 4*Y(1,3)*(Dval(dd002,Di1) - Dval(dd002,Di2)) +
- & 2*Y(3,3)*d00sum
- in(2) = f2*E(ee133) + d22sum + Dval(dd122,Di3) -
- & 4*Y(1,3)*(Dval(dd002,Di1) - Dval(dd002,Di3)) +
- & 2*Y(3,3)*(d00sum + Dval(dd001,Di3))
- in(3) = f3*E(ee133) + d22sum -
- & 4*Y(1,3)*Dval(dd002,Di1) +
- & 2*Y(3,3)*(d00sum + Dval(dd001,Di4))
- in(4) = f4*E(ee133) + d22sum + Dval(dd133,Di5) -
- & 4*Y(1,3)*(Dval(dd002,Di1) - Dval(dd003,Di5)) +
- & 2*Y(3,3)*(d00sum + Dval(dd001,Di5))
- call XLUBackSubst(G, 4, perm, in)
+ IN(1) = f1*E(ee133) + d22sum -
+ & 4*Ginv(1,3)*(Dval(dd002,Di1) - Dval(dd002,Di2)) +
+ & 2*Ginv(3,3)*d00sum
+ IN(2) = f2*E(ee133) + d22sum + Dval(dd122,Di3) -
+ & 4*Ginv(1,3)*(Dval(dd002,Di1) - Dval(dd002,Di3)) +
+ & 2*Ginv(3,3)*(d00sum + Dval(dd001,Di3))
+ IN(3) = f3*E(ee133) + d22sum -
+ & 4*Ginv(1,3)*Dval(dd002,Di1) +
+ & 2*Ginv(3,3)*(d00sum + Dval(dd001,Di4))
+ IN(4) = f4*E(ee133) + d22sum + Dval(dd133,Di5) -
+ & 4*Ginv(1,3)*(Dval(dd002,Di1) - Dval(dd003,Di5)) +
+ & 2*Ginv(3,3)*(d00sum + Dval(dd001,Di5))
+ call SOLVE(in)
E(ee1133) = .5D0*(E(ee1133) + in(1))
E(ee1233) = in(2)
E(ee1333) = .5D0*(E(ee1333) + in(3))
E(ee1334) = .5D0*(E(ee1334) + in(4))
if( dump ) call XDumpCoeff(5, E)
end
diff --git a/Looptools/E/Eget.F b/Looptools/E/Eget.F
--- a/Looptools/E/Eget.F
+++ b/Looptools/E/Eget.F
@@ -1,292 +1,309 @@
* Eget.F
* retrieve the five-point tensor coefficients
* this file is part of LoopTools
* written by M. Rauch
-* last modified 16 Nov 06 th
+* last modified 24 Aug 09 th
#include "defs.h"
integer function XEget(p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
implicit none
DVAR p1, p2, p3, p4, p5
DVAR p1p2, p2p3, p3p4, p4p5, p5p1
DVAR m1, m2, m3, m4, m5
#include "lt.h"
integer cachelookup
external cachelookup, XEcoeff
DVAR para(Pee)
para(1) = p1
para(2) = p2
para(3) = p3
para(4) = p4
para(5) = p5
para(6) = p1p2
para(7) = p2p3
para(8) = p3p4
para(9) = p4p5
para(10) = p5p1
para(11) = m1
+ if( abs(para(11)) .lt. minmass ) para(11) = 0
para(12) = m2
+ if( abs(para(12)) .lt. minmass ) para(12) = 0
para(13) = m3
+ if( abs(para(13)) .lt. minmass ) para(13) = 0
para(14) = m4
+ if( abs(para(14)) .lt. minmass ) para(14) = 0
para(15) = m5
+ if( abs(para(15)) .lt. minmass ) para(15) = 0
XEget = cachelookup(para, Eval(1,0), XEcoeff, RC*Pee, Nee)
end
************************************************************************
double complex function XE0i(i, p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
implicit none
integer i
DVAR p1, p2, p3, p4, p5
DVAR p1p2, p2p3, p3p4, p4p5, p5p1
DVAR m1, m2, m3, m4, m5
#include "lt.h"
integer XEget
external XEget
integer b
b = XEget(p1, p2, p3, p4, p5,
& p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)
XE0i = Eval(i,b)
end
************************************************************************
subroutine XEcoeff(para, E, ldpara)
implicit none
integer ldpara
DVAR para(ldpara,Pee)
double complex E(Nee)
#include "lt.h"
double complex Ecmp(Nee)
#ifdef COMPLEXPARA
goto (1, 2, 3) ibits(versionkey, KeyEgetC, 2)
#else
goto (1, 2, 3) ibits(versionkey, KeyEget, 2)
#endif
call XEcoeffa(para, E, ldpara)
return
1 call XEcoeffb(para, E, ldpara)
return
2 call XEcheck(para, E, Ecmp, ldpara)
return
3 call XEcheck(para, Ecmp, E, ldpara)
end
************************************************************************
subroutine XEcheck(para, Ea, Eb, ldpara)
implicit none
integer ldpara
DVAR para(ldpara,Pee)
double complex Ea(Nee), Eb(Nee)
#include "lt.h"
double complex dE(Nee)
integer i
logical ini
- QVAR Y(4,4)
- common /XltEgram/ Y
+ QVAR Ginv(4,4)
+ common /XInvGramE/ Ginv
character*8 coeffname(Nee,2:5)
common /ltcoeffnames/ coeffname
call XEcoeffa(para, Ea, ldpara)
call XEcoeffb(para, Eb, ldpara)
dE(ee0) = 0
dE(ee1) = 0
dE(ee2) = 0
dE(ee3) = 0
dE(ee4) = 0
- dE(ee11) = -2*Ea(ee00)*Y(1,1)
- dE(ee12) = -2*Ea(ee00)*Y(1,2)
- dE(ee13) = -2*Ea(ee00)*Y(1,3)
- dE(ee14) = -2*Ea(ee00)*Y(1,4)
- dE(ee22) = -2*Ea(ee00)*Y(2,2)
- dE(ee23) = -2*Ea(ee00)*Y(2,3)
- dE(ee24) = -2*Ea(ee00)*Y(2,4)
- dE(ee33) = -2*Ea(ee00)*Y(3,3)
- dE(ee34) = -2*Ea(ee00)*Y(3,4)
- dE(ee44) = -2*Ea(ee00)*Y(4,4)
+ dE(ee11) = -2*Ea(ee00)*Ginv(1,1)
+ dE(ee12) = -2*Ea(ee00)*Ginv(1,2)
+ dE(ee13) = -2*Ea(ee00)*Ginv(1,3)
+ dE(ee14) = -2*Ea(ee00)*Ginv(1,4)
+ dE(ee22) = -2*Ea(ee00)*Ginv(2,2)
+ dE(ee23) = -2*Ea(ee00)*Ginv(2,3)
+ dE(ee24) = -2*Ea(ee00)*Ginv(2,4)
+ dE(ee33) = -2*Ea(ee00)*Ginv(3,3)
+ dE(ee34) = -2*Ea(ee00)*Ginv(3,4)
+ dE(ee44) = -2*Ea(ee00)*Ginv(4,4)
dE(ee00) = Ea(ee00)
- dE(ee111) = -6*Ea(ee001)*Y(1,1)
- dE(ee112) = -2*(Ea(ee002)*Y(1,1) + Ea(ee001)*(Y(1,2) + Y(2,1)))
- dE(ee113) = -2*(Ea(ee003)*Y(1,1) + Ea(ee001)*(Y(1,3) + Y(3,1)))
- dE(ee114) = -2*(Ea(ee004)*Y(1,1) + Ea(ee001)*(Y(1,4) + Y(4,1)))
- dE(ee122) = -2*(Ea(ee002)*(Y(1,2) + Y(2,1)) + Ea(ee001)*Y(2,2))
- dE(ee123) = -2*(Ea(ee003)*Y(1,2) + Ea(ee001)*Y(2,3) +
- & Ea(ee002)*Y(3,1))
- dE(ee124) = -2*(Ea(ee004)*Y(1,2) + Ea(ee001)*Y(2,4) +
- & Ea(ee002)*Y(4,1))
- dE(ee133) = -2*(Ea(ee003)*(Y(1,3) + Y(3,1)) + Ea(ee001)*Y(3,3))
- dE(ee134) = -2*(Ea(ee004)*Y(1,3) + Ea(ee001)*Y(3,4) +
- & Ea(ee003)*Y(4,1))
- dE(ee144) = -2*(Ea(ee004)*(Y(1,4) + Y(4,1)) + Ea(ee001)*Y(4,4))
- dE(ee222) = -6*Ea(ee002)*Y(2,2)
- dE(ee223) = -2*(Ea(ee003)*Y(2,2) + Ea(ee002)*(Y(2,3) + Y(3,2)))
- dE(ee224) = -2*(Ea(ee004)*Y(2,2) + Ea(ee002)*(Y(2,4) + Y(4,2)))
- dE(ee233) = -2*(Ea(ee003)*(Y(2,3) + Y(3,2)) + Ea(ee002)*Y(3,3))
- dE(ee234) = -2*(Ea(ee004)*Y(2,3) + Ea(ee002)*Y(3,4) +
- & Ea(ee003)*Y(4,2))
- dE(ee244) = -2*(Ea(ee004)*(Y(2,4) + Y(4,2)) + Ea(ee002)*Y(4,4))
- dE(ee333) = -6*Ea(ee003)*Y(3,3)
- dE(ee334) = -2*(Ea(ee004)*Y(3,3) + Ea(ee003)*(Y(3,4) + Y(4,3)))
- dE(ee344) = -2*(Ea(ee004)*(Y(3,4) + Y(4,3)) + Ea(ee003)*Y(4,4))
- dE(ee444) = -6*Ea(ee004)*Y(4,4)
+ dE(ee111) = -6*Ea(ee001)*Ginv(1,1)
+ dE(ee112) = -2*(Ea(ee002)*Ginv(1,1) +
+ & Ea(ee001)*(Ginv(1,2) + Ginv(2,1)))
+ dE(ee113) = -2*(Ea(ee003)*Ginv(1,1) +
+ & Ea(ee001)*(Ginv(1,3) + Ginv(3,1)))
+ dE(ee114) = -2*(Ea(ee004)*Ginv(1,1) +
+ & Ea(ee001)*(Ginv(1,4) + Ginv(4,1)))
+ dE(ee122) = -2*(Ea(ee002)*(Ginv(1,2) + Ginv(2,1)) +
+ & Ea(ee001)*Ginv(2,2))
+ dE(ee123) = -2*(Ea(ee003)*Ginv(1,2) + Ea(ee001)*Ginv(2,3) +
+ & Ea(ee002)*Ginv(3,1))
+ dE(ee124) = -2*(Ea(ee004)*Ginv(1,2) + Ea(ee001)*Ginv(2,4) +
+ & Ea(ee002)*Ginv(4,1))
+ dE(ee133) = -2*(Ea(ee003)*(Ginv(1,3) + Ginv(3,1)) +
+ & Ea(ee001)*Ginv(3,3))
+ dE(ee134) = -2*(Ea(ee004)*Ginv(1,3) + Ea(ee001)*Ginv(3,4) +
+ & Ea(ee003)*Ginv(4,1))
+ dE(ee144) = -2*(Ea(ee004)*(Ginv(1,4) + Ginv(4,1)) +
+ & Ea(ee001)*Ginv(4,4))
+ dE(ee222) = -6*Ea(ee002)*Ginv(2,2)
+ dE(ee223) = -2*(Ea(ee003)*Ginv(2,2) +
+ & Ea(ee002)*(Ginv(2,3) + Ginv(3,2)))
+ dE(ee224) = -2*(Ea(ee004)*Ginv(2,2) +
+ & Ea(ee002)*(Ginv(2,4) + Ginv(4,2)))
+ dE(ee233) = -2*(Ea(ee003)*(Ginv(2,3) + Ginv(3,2)) +
+ & Ea(ee002)*Ginv(3,3))
+ dE(ee234) = -2*(Ea(ee004)*Ginv(2,3) + Ea(ee002)*Ginv(3,4) +
+ & Ea(ee003)*Ginv(4,2))
+ dE(ee244) = -2*(Ea(ee004)*(Ginv(2,4) + Ginv(4,2)) +
+ & Ea(ee002)*Ginv(4,4))
+ dE(ee333) = -6*Ea(ee003)*Ginv(3,3)
+ dE(ee334) = -2*(Ea(ee004)*Ginv(3,3) +
+ & Ea(ee003)*(Ginv(3,4) + Ginv(4,3)))
+ dE(ee344) = -2*(Ea(ee004)*(Ginv(3,4) + Ginv(4,3)) +
+ & Ea(ee003)*Ginv(4,4))
+ dE(ee444) = -6*Ea(ee004)*Ginv(4,4)
dE(ee001) = Ea(ee001)
dE(ee002) = Ea(ee002)
dE(ee003) = Ea(ee003)
dE(ee004) = Ea(ee004)
- dE(ee1111) = -12*Y(1,1)*(Ea(ee0011) + Ea(ee0000)*Y(1,1))
- dE(ee1112) = -6*(Ea(ee0012)*Y(1,1) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(1,2))
- dE(ee1113) = -6*(Ea(ee0013)*Y(1,1) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(1,3))
- dE(ee1114) = -6*(Ea(ee0014)*Y(1,1) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(1,4))
- dE(ee1122) = -2*(Ea(ee0022)*Y(1,1) +
- & 4*Y(1,2)*(Ea(ee0012) + Ea(ee0000)*Y(1,2)) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(2,2))
- dE(ee1123) = -2*(Ea(ee0023)*Y(1,1) +
- & 2*Ea(ee0013)*Y(1,2) +
- & 2*(Ea(ee0012) + 2*Ea(ee0000)*Y(1,2))*Y(1,3) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(2,3))
- dE(ee1124) = -2*(Ea(ee0024)*Y(1,1) +
- & 2*Ea(ee0014)*Y(1,2) +
- & 2*(Ea(ee0012) + 2*Ea(ee0000)*Y(1,2))*Y(1,4) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(2,4))
- dE(ee1133) = -2*(Ea(ee0033)*Y(1,1) +
- & 4*Y(1,3)*(Ea(ee0013) + Ea(ee0000)*Y(1,3)) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(3,3))
- dE(ee1134) = -2*(Ea(ee0034)*Y(1,1) +
- & 2*Ea(ee0014)*Y(1,3) +
- & 2*(Ea(ee0013) + 2*Ea(ee0000)*Y(1,3))*Y(1,4) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(3,4))
- dE(ee1144) = -2*(Ea(ee0044)*Y(1,1) +
- & 4*Y(1,4)*(Ea(ee0014) + Ea(ee0000)*Y(1,4)) +
- & (Ea(ee0011) + 2*Ea(ee0000)*Y(1,1))*Y(4,4))
- dE(ee1222) = -6*(Ea(ee0022)*Y(1,2) +
- & (Ea(ee0012) + 2*Ea(ee0000)*Y(1,2))*Y(2,2))
- dE(ee1223) = -2*(2*Ea(ee0023)*Y(1,2) +
- & Ea(ee0022)*Y(1,3) +
- & (Ea(ee0013) + 2*Ea(ee0000)*Y(1,3))*Y(2,2) +
- & 2*(Ea(ee0012) + 2*Ea(ee0000)*Y(1,2))*Y(2,3))
- dE(ee1224) = -2*(2*Ea(ee0024)*Y(1,2) +
- & Ea(ee0022)*Y(1,4) +
- & (Ea(ee0014) + 2*Ea(ee0000)*Y(1,4))*Y(2,2) +
- & 2*(Ea(ee0012) + 2*Ea(ee0000)*Y(1,2))*Y(2,4))
- dE(ee1233) = -2*(Ea(ee0033)*Y(1,2) +
- & 2*Ea(ee0023)*Y(1,3) +
- & 2*(Ea(ee0013) + 2*Ea(ee0000)*Y(1,3))*Y(2,3) +
- & (Ea(ee0012) + 2*Ea(ee0000)*Y(1,2))*Y(3,3))
- dE(ee1234) = -2*(Ea(ee0023)*Y(1,4) +
- & (Ea(ee0014) + 2*Ea(ee0000)*Y(1,4))*Y(2,3) +
- & Ea(ee0013)*Y(2,4) +
- & Y(1,3)*(Ea(ee0024) + 2*Ea(ee0000)*Y(2,4)) +
- & Ea(ee0012)*Y(3,4) +
- & Y(1,2)*(Ea(ee0034) + 2*Ea(ee0000)*Y(3,4)))
- dE(ee1244) = -2*(Ea(ee0044)*Y(1,2) +
- & 2*Ea(ee0024)*Y(1,4) +
- & 2*(Ea(ee0014) + 2*Ea(ee0000)*Y(1,4))*Y(2,4) +
- & (Ea(ee0012) + 2*Ea(ee0000)*Y(1,2))*Y(4,4))
- dE(ee1333) = -6*(Ea(ee0033)*Y(1,3) +
- & (Ea(ee0013) + 2*Ea(ee0000)*Y(1,3))*Y(3,3))
- dE(ee1334) = -2*(2*Ea(ee0034)*Y(1,3) +
- & Ea(ee0033)*Y(1,4) +
- & (Ea(ee0014) + 2*Ea(ee0000)*Y(1,4))*Y(3,3) +
- & 2*(Ea(ee0013) + 2*Ea(ee0000)*Y(1,3))*Y(3,4))
- dE(ee1344) = -2*(Ea(ee0044)*Y(1,3) +
- & 2*Ea(ee0034)*Y(1,4) +
- & 2*(Ea(ee0014) + 2*Ea(ee0000)*Y(1,4))*Y(3,4) +
- & (Ea(ee0013) + 2*Ea(ee0000)*Y(1,3))*Y(4,4))
- dE(ee1444) = -6*(Ea(ee0044)*Y(1,4) +
- & (Ea(ee0014) + 2*Ea(ee0000)*Y(1,4))*Y(4,4))
- dE(ee2222) = -12*Y(2,2)*(Ea(ee0022) + Ea(ee0000)*Y(2,2))
- dE(ee2223) = -6*(Ea(ee0023)*Y(2,2) +
- & (Ea(ee0022) + 2*Ea(ee0000)*Y(2,2))*Y(2,3))
- dE(ee2224) = -6*(Ea(ee0024)*Y(2,2) +
- & (Ea(ee0022) + 2*Ea(ee0000)*Y(2,2))*Y(2,4))
- dE(ee2233) = -2*(Ea(ee0033)*Y(2,2) +
- & 4*Y(2,3)*(Ea(ee0023) + Ea(ee0000)*Y(2,3)) +
- & (Ea(ee0022) + 2*Ea(ee0000)*Y(2,2))*Y(3,3))
- dE(ee2234) = -2*(Ea(ee0034)*Y(2,2) +
- & 2*Ea(ee0024)*Y(2,3) +
- & 2*(Ea(ee0023) + 2*Ea(ee0000)*Y(2,3))*Y(2,4) +
- & (Ea(ee0022) + 2*Ea(ee0000)*Y(2,2))*Y(3,4))
- dE(ee2244) = -2*(Ea(ee0044)*Y(2,2) +
- & 4*Y(2,4)*(Ea(ee0024) + Ea(ee0000)*Y(2,4)) +
- & (Ea(ee0022) + 2*Ea(ee0000)*Y(2,2))*Y(4,4))
- dE(ee2333) = -6*(Ea(ee0033)*Y(2,3) +
- & (Ea(ee0023) + 2*Ea(ee0000)*Y(2,3))*Y(3,3))
- dE(ee2334) = -2*(2*Ea(ee0034)*Y(2,3) +
- & Ea(ee0033)*Y(2,4) +
- & (Ea(ee0024) + 2*Ea(ee0000)*Y(2,4))*Y(3,3) +
- & 2*(Ea(ee0023) + 2*Ea(ee0000)*Y(2,3))*Y(3,4))
- dE(ee2344) = -2*(Ea(ee0044)*Y(2,3) +
- & 2*Ea(ee0034)*Y(2,4) +
- & 2*(Ea(ee0024) + 2*Ea(ee0000)*Y(2,4))*Y(3,4) +
- & (Ea(ee0023) + 2*Ea(ee0000)*Y(2,3))*Y(4,4))
- dE(ee2444) = -6*(Ea(ee0044)*Y(2,4) +
- & (Ea(ee0024) + 2*Ea(ee0000)*Y(2,4))*Y(4,4))
- dE(ee3333) = -12*Y(3,3)*(Ea(ee0033) + Ea(ee0000)*Y(3,3))
- dE(ee3334) = -6*(Ea(ee0034)*Y(3,3) +
- & (Ea(ee0033) + 2*Ea(ee0000)*Y(3,3))*Y(3,4))
- dE(ee3344) = -2*(Ea(ee0044)*Y(3,3) +
- & 4*Y(3,4)*(Ea(ee0034) + Ea(ee0000)*Y(3,4)) +
- & (Ea(ee0033) + 2*Ea(ee0000)*Y(3,3))*Y(4,4))
- dE(ee3444) = -6*(Ea(ee0044)*Y(3,4) +
- & (Ea(ee0034) + 2*Ea(ee0000)*Y(3,4))*Y(4,4))
- dE(ee4444) = -12*Y(4,4)*(Ea(ee0044) + Ea(ee0000)*Y(4,4))
+ dE(ee1111) = -12*Ginv(1,1)*(Ea(ee0011) + Ea(ee0000)*Ginv(1,1))
+ dE(ee1112) = -6*(Ea(ee0012)*Ginv(1,1) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(1,2))
+ dE(ee1113) = -6*(Ea(ee0013)*Ginv(1,1) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(1,3))
+ dE(ee1114) = -6*(Ea(ee0014)*Ginv(1,1) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(1,4))
+ dE(ee1122) = -2*(Ea(ee0022)*Ginv(1,1) +
+ & 4*Ginv(1,2)*(Ea(ee0012) + Ea(ee0000)*Ginv(1,2)) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(2,2))
+ dE(ee1123) = -2*(Ea(ee0023)*Ginv(1,1) +
+ & 2*Ea(ee0013)*Ginv(1,2) +
+ & 2*(Ea(ee0012) + 2*Ea(ee0000)*Ginv(1,2))*Ginv(1,3) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(2,3))
+ dE(ee1124) = -2*(Ea(ee0024)*Ginv(1,1) +
+ & 2*Ea(ee0014)*Ginv(1,2) +
+ & 2*(Ea(ee0012) + 2*Ea(ee0000)*Ginv(1,2))*Ginv(1,4) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(2,4))
+ dE(ee1133) = -2*(Ea(ee0033)*Ginv(1,1) +
+ & 4*Ginv(1,3)*(Ea(ee0013) + Ea(ee0000)*Ginv(1,3)) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(3,3))
+ dE(ee1134) = -2*(Ea(ee0034)*Ginv(1,1) +
+ & 2*Ea(ee0014)*Ginv(1,3) +
+ & 2*(Ea(ee0013) + 2*Ea(ee0000)*Ginv(1,3))*Ginv(1,4) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(3,4))
+ dE(ee1144) = -2*(Ea(ee0044)*Ginv(1,1) +
+ & 4*Ginv(1,4)*(Ea(ee0014) + Ea(ee0000)*Ginv(1,4)) +
+ & (Ea(ee0011) + 2*Ea(ee0000)*Ginv(1,1))*Ginv(4,4))
+ dE(ee1222) = -6*(Ea(ee0022)*Ginv(1,2) +
+ & (Ea(ee0012) + 2*Ea(ee0000)*Ginv(1,2))*Ginv(2,2))
+ dE(ee1223) = -2*(2*Ea(ee0023)*Ginv(1,2) +
+ & Ea(ee0022)*Ginv(1,3) +
+ & (Ea(ee0013) + 2*Ea(ee0000)*Ginv(1,3))*Ginv(2,2) +
+ & 2*(Ea(ee0012) + 2*Ea(ee0000)*Ginv(1,2))*Ginv(2,3))
+ dE(ee1224) = -2*(2*Ea(ee0024)*Ginv(1,2) +
+ & Ea(ee0022)*Ginv(1,4) +
+ & (Ea(ee0014) + 2*Ea(ee0000)*Ginv(1,4))*Ginv(2,2) +
+ & 2*(Ea(ee0012) + 2*Ea(ee0000)*Ginv(1,2))*Ginv(2,4))
+ dE(ee1233) = -2*(Ea(ee0033)*Ginv(1,2) +
+ & 2*Ea(ee0023)*Ginv(1,3) +
+ & 2*(Ea(ee0013) + 2*Ea(ee0000)*Ginv(1,3))*Ginv(2,3) +
+ & (Ea(ee0012) + 2*Ea(ee0000)*Ginv(1,2))*Ginv(3,3))
+ dE(ee1234) = -2*(Ea(ee0023)*Ginv(1,4) +
+ & (Ea(ee0014) + 2*Ea(ee0000)*Ginv(1,4))*Ginv(2,3) +
+ & Ea(ee0013)*Ginv(2,4) +
+ & Ginv(1,3)*(Ea(ee0024) + 2*Ea(ee0000)*Ginv(2,4)) +
+ & Ea(ee0012)*Ginv(3,4) +
+ & Ginv(1,2)*(Ea(ee0034) + 2*Ea(ee0000)*Ginv(3,4)))
+ dE(ee1244) = -2*(Ea(ee0044)*Ginv(1,2) +
+ & 2*Ea(ee0024)*Ginv(1,4) +
+ & 2*(Ea(ee0014) + 2*Ea(ee0000)*Ginv(1,4))*Ginv(2,4) +
+ & (Ea(ee0012) + 2*Ea(ee0000)*Ginv(1,2))*Ginv(4,4))
+ dE(ee1333) = -6*(Ea(ee0033)*Ginv(1,3) +
+ & (Ea(ee0013) + 2*Ea(ee0000)*Ginv(1,3))*Ginv(3,3))
+ dE(ee1334) = -2*(2*Ea(ee0034)*Ginv(1,3) +
+ & Ea(ee0033)*Ginv(1,4) +
+ & (Ea(ee0014) + 2*Ea(ee0000)*Ginv(1,4))*Ginv(3,3) +
+ & 2*(Ea(ee0013) + 2*Ea(ee0000)*Ginv(1,3))*Ginv(3,4))
+ dE(ee1344) = -2*(Ea(ee0044)*Ginv(1,3) +
+ & 2*Ea(ee0034)*Ginv(1,4) +
+ & 2*(Ea(ee0014) + 2*Ea(ee0000)*Ginv(1,4))*Ginv(3,4) +
+ & (Ea(ee0013) + 2*Ea(ee0000)*Ginv(1,3))*Ginv(4,4))
+ dE(ee1444) = -6*(Ea(ee0044)*Ginv(1,4) +
+ & (Ea(ee0014) + 2*Ea(ee0000)*Ginv(1,4))*Ginv(4,4))
+ dE(ee2222) = -12*Ginv(2,2)*(Ea(ee0022) + Ea(ee0000)*Ginv(2,2))
+ dE(ee2223) = -6*(Ea(ee0023)*Ginv(2,2) +
+ & (Ea(ee0022) + 2*Ea(ee0000)*Ginv(2,2))*Ginv(2,3))
+ dE(ee2224) = -6*(Ea(ee0024)*Ginv(2,2) +
+ & (Ea(ee0022) + 2*Ea(ee0000)*Ginv(2,2))*Ginv(2,4))
+ dE(ee2233) = -2*(Ea(ee0033)*Ginv(2,2) +
+ & 4*Ginv(2,3)*(Ea(ee0023) + Ea(ee0000)*Ginv(2,3)) +
+ & (Ea(ee0022) + 2*Ea(ee0000)*Ginv(2,2))*Ginv(3,3))
+ dE(ee2234) = -2*(Ea(ee0034)*Ginv(2,2) +
+ & 2*Ea(ee0024)*Ginv(2,3) +
+ & 2*(Ea(ee0023) + 2*Ea(ee0000)*Ginv(2,3))*Ginv(2,4) +
+ & (Ea(ee0022) + 2*Ea(ee0000)*Ginv(2,2))*Ginv(3,4))
+ dE(ee2244) = -2*(Ea(ee0044)*Ginv(2,2) +
+ & 4*Ginv(2,4)*(Ea(ee0024) + Ea(ee0000)*Ginv(2,4)) +
+ & (Ea(ee0022) + 2*Ea(ee0000)*Ginv(2,2))*Ginv(4,4))
+ dE(ee2333) = -6*(Ea(ee0033)*Ginv(2,3) +
+ & (Ea(ee0023) + 2*Ea(ee0000)*Ginv(2,3))*Ginv(3,3))
+ dE(ee2334) = -2*(2*Ea(ee0034)*Ginv(2,3) +
+ & Ea(ee0033)*Ginv(2,4) +
+ & (Ea(ee0024) + 2*Ea(ee0000)*Ginv(2,4))*Ginv(3,3) +
+ & 2*(Ea(ee0023) + 2*Ea(ee0000)*Ginv(2,3))*Ginv(3,4))
+ dE(ee2344) = -2*(Ea(ee0044)*Ginv(2,3) +
+ & 2*Ea(ee0034)*Ginv(2,4) +
+ & 2*(Ea(ee0024) + 2*Ea(ee0000)*Ginv(2,4))*Ginv(3,4) +
+ & (Ea(ee0023) + 2*Ea(ee0000)*Ginv(2,3))*Ginv(4,4))
+ dE(ee2444) = -6*(Ea(ee0044)*Ginv(2,4) +
+ & (Ea(ee0024) + 2*Ea(ee0000)*Ginv(2,4))*Ginv(4,4))
+ dE(ee3333) = -12*Ginv(3,3)*(Ea(ee0033) + Ea(ee0000)*Ginv(3,3))
+ dE(ee3334) = -6*(Ea(ee0034)*Ginv(3,3) +
+ & (Ea(ee0033) + 2*Ea(ee0000)*Ginv(3,3))*Ginv(3,4))
+ dE(ee3344) = -2*(Ea(ee0044)*Ginv(3,3) +
+ & 4*Ginv(3,4)*(Ea(ee0034) + Ea(ee0000)*Ginv(3,4)) +
+ & (Ea(ee0033) + 2*Ea(ee0000)*Ginv(3,3))*Ginv(4,4))
+ dE(ee3444) = -6*(Ea(ee0044)*Ginv(3,4) +
+ & (Ea(ee0034) + 2*Ea(ee0000)*Ginv(3,4))*Ginv(4,4))
+ dE(ee4444) = -12*Ginv(4,4)*(Ea(ee0044) + Ea(ee0000)*Ginv(4,4))
dE(ee0000) = Ea(ee0000)
dE(ee0011) = Ea(ee0011)
dE(ee0012) = Ea(ee0012)
dE(ee0013) = Ea(ee0013)
dE(ee0014) = Ea(ee0014)
dE(ee0022) = Ea(ee0022)
dE(ee0023) = Ea(ee0023)
dE(ee0024) = Ea(ee0024)
dE(ee0033) = Ea(ee0033)
dE(ee0034) = Ea(ee0034)
dE(ee0044) = Ea(ee0044)
ini = .TRUE.
do i = 1, Nee
if( abs(Ea(i) - Eb(i) - dE(i)) .gt.
& .5D0*maxdev*abs(Ea(i) + Eb(i)) ) then
if( ini ) then
#ifdef COMPLEXPARA
print *, "Discrepancy in CEget:"
#else
print *, "Discrepancy in Eget:"
#endif
call XDumpPara(5, para, ldpara, " ")
ini = .FALSE.
endif
print *, coeffname(i,5), " a =", Ea(i)
print *, coeffname(i,5), " b =", Eb(i) + dE(i)
endif
enddo
end
diff --git a/Looptools/E/ffdel5.F b/Looptools/E/ffdel5.F
--- a/Looptools/E/ffdel5.F
+++ b/Looptools/E/ffdel5.F
@@ -1,559 +1,550 @@
+#include "externals.h"
+
+
*###[ ffdel5:
- subroutine ffdel5(del5,xpi,pDp,ns,ier)
+ subroutine ffdel5(del5,xpi,pDp)
***#[*comment:***********************************************************
* *
* Calculate del5(pDp) = det(si.sj) with *
* the momenta as follows: *
* p(1-5) = s(i) *
* p(5-10) = p(i) *
* p(11-15) = p(i)+p(i+1) *
* *
-* Input: xpi(ns) (real) *
-* pDp(ns,ns) (real) *
-* ns (integer) *
-* ier (integer) *
+* Input: xpi(15) (real) *
+* pDp(15,15) (real) *
* *
* Output: del5 (real) det(si.sj) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
- integer ns,ier
DOUBLE PRECISION del5,xpi(15),pDp(15,15)
*
* local variables:
*
integer mem,nperm,nsi
parameter(mem=10,nperm=1296,nsi=73)
integer i,j1,j2,j3,j4,j5,iperm(5,nperm),
+ imem,memarr(mem,3),memind,inow
DOUBLE PRECISION s(nsi),xmax,del5p,xmaxp
save iperm,memind,memarr,inow
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ data:
data memind /0/
data memarr /mem*0,mem*0,mem*1/
data inow /1/
- include 'ffperm5.h'
+#include "ffperm5.h"
* #] data:
* #[ out of memory:
*
* see if we know were to start, if not: go on as last time
*
do 5 i=1,mem
if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
inow = memarr(i,3)
goto 6
endif
5 continue
6 continue
* #] out of memory:
* #[ calculations:
imem = inow
del5 = 0
xmax = 0
10 continue
*
* we only try the diagonal elements: top==bottom
*
j1 = iperm(1,inow)
j2 = iperm(2,inow)
j3 = iperm(3,inow)
j4 = iperm(4,inow)
j5 = iperm(5,inow)
*
* The following was generated with the Form program
* V p1,p2,p3,p4,p5;
* L f = (e_(p1,p2,p3,p4,p5))**2;
* Contract;
* print +s;
* .end
* plus the substituion //p#@1\./p#@2/=/pDp(j@1,j@2)/
*
* #[ terms:
s(1)=+ xpi(j1)*xpi(j2)*xpi(j3)*xpi(j4)*xpi(j5)
s(2)=- xpi(j1)*xpi(j2)*xpi(j3)*pDp(j4,j5)**2
s(3)=- xpi(j1)*xpi(j2)*pDp(j3,j4)**2*xpi(j5)
s(4)=+2*xpi(j1)*xpi(j2)*pDp(j3,j4)*pDp(j3,j5)*pDp(j4,j5)
s(5)=- xpi(j1)*xpi(j2)*pDp(j3,j5)**2*xpi(j4)
s(6)=- xpi(j1)*pDp(j2,j3)**2*xpi(j4)*xpi(j5)
s(7)=+ xpi(j1)*pDp(j2,j3)**2*pDp(j4,j5)**2
s(8)=+2*xpi(j1)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j4)*xpi(j5)
s(9)=-2*xpi(j1)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j5)*pDp(j4,j5)
s(10)=-2*xpi(j1)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j4)*pDp(j4,j5)
s(11)=+2*xpi(j1)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j5)*xpi(j4)
s(12)=- xpi(j1)*pDp(j2,j4)**2*xpi(j3)*xpi(j5)
s(13)=+ xpi(j1)*pDp(j2,j4)**2*pDp(j3,j5)**2
s(14)=+2*xpi(j1)*pDp(j2,j4)*pDp(j2,j5)*xpi(j3)*pDp(j4,j5)
s(15)=-2*xpi(j1)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j4)*pDp(j3,j5)
s(16)=- xpi(j1)*pDp(j2,j5)**2*xpi(j3)*xpi(j4)
s(17)=+ xpi(j1)*pDp(j2,j5)**2*pDp(j3,j4)**2
s(18)=- pDp(j1,j2)**2*xpi(j3)*xpi(j4)*xpi(j5)
s(19)=+ pDp(j1,j2)**2*xpi(j3)*pDp(j4,j5)**2
s(20)=+ pDp(j1,j2)**2*pDp(j3,j4)**2*xpi(j5)
s(21)=-2*pDp(j1,j2)**2*pDp(j3,j4)*pDp(j3,j5)*pDp(j4,j5)
s(22)=+ pDp(j1,j2)**2*pDp(j3,j5)**2*xpi(j4)
s(23)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j3)*xpi(j4)*xpi(j5)
s(24)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j3)*pDp(j4,j5)**2
s(25)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j4)*pDp(j3,j4)*xpi(j5)
s(26)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j4)*pDp(j3,j5)*pDp(j4,j5)
s(27)=+2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j5)*pDp(j3,j4)*pDp(j4,j5)
s(28)=-2*pDp(j1,j2)*pDp(j1,j3)*pDp(j2,j5)*pDp(j3,j5)*xpi(j4)
s(29)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j3)*pDp(j3,j4)*xpi(j5)
s(30)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j3)*pDp(j3,j5)*pDp(j4,j5)
s(31)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j4)*xpi(j3)*xpi(j5)
s(32)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j4)*pDp(j3,j5)**2
s(33)=-2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j5)*xpi(j3)*pDp(j4,j5)
s(34)=+2*pDp(j1,j2)*pDp(j1,j4)*pDp(j2,j5)*pDp(j3,j4)*pDp(j3,j5)
s(35)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j3)*pDp(j3,j4)*pDp(j4,j5)
s(36)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j3)*pDp(j3,j5)*xpi(j4)
s(37)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j4)*xpi(j3)*pDp(j4,j5)
s(38)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j4)*pDp(j3,j4)*pDp(j3,j5)
s(39)=+2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j5)*xpi(j3)*xpi(j4)
s(40)=-2*pDp(j1,j2)*pDp(j1,j5)*pDp(j2,j5)*pDp(j3,j4)**2
s(41)=- pDp(j1,j3)**2*xpi(j2)*xpi(j4)*xpi(j5)
s(42)=+ pDp(j1,j3)**2*xpi(j2)*pDp(j4,j5)**2
s(43)=+ pDp(j1,j3)**2*pDp(j2,j4)**2*xpi(j5)
s(44)=-2*pDp(j1,j3)**2*pDp(j2,j4)*pDp(j2,j5)*pDp(j4,j5)
s(45)=+ pDp(j1,j3)**2*pDp(j2,j5)**2*xpi(j4)
s(46)=+2*pDp(j1,j3)*pDp(j1,j4)*xpi(j2)*pDp(j3,j4)*xpi(j5)
s(47)=-2*pDp(j1,j3)*pDp(j1,j4)*xpi(j2)*pDp(j3,j5)*pDp(j4,j5)
s(48)=-2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j3)*pDp(j2,j4)*xpi(j5)
s(49)=+2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j3)*pDp(j2,j5)*pDp(j4,j5)
s(50)=+2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j5)
s(51)=-2*pDp(j1,j3)*pDp(j1,j4)*pDp(j2,j5)**2*pDp(j3,j4)
s(52)=-2*pDp(j1,j3)*pDp(j1,j5)*xpi(j2)*pDp(j3,j4)*pDp(j4,j5)
s(53)=+2*pDp(j1,j3)*pDp(j1,j5)*xpi(j2)*pDp(j3,j5)*xpi(j4)
s(54)=+2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j4)*pDp(j4,j5)
s(55)=-2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j5)*xpi(j4)
s(56)=-2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j4)**2*pDp(j3,j5)
s(57)=+2*pDp(j1,j3)*pDp(j1,j5)*pDp(j2,j4)*pDp(j2,j5)*pDp(j3,j4)
s(58)=- pDp(j1,j4)**2*xpi(j2)*xpi(j3)*xpi(j5)
s(59)=+ pDp(j1,j4)**2*xpi(j2)*pDp(j3,j5)**2
s(60)=+ pDp(j1,j4)**2*pDp(j2,j3)**2*xpi(j5)
s(61)=-2*pDp(j1,j4)**2*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j5)
s(62)=+ pDp(j1,j4)**2*pDp(j2,j5)**2*xpi(j3)
s(63)=+2*pDp(j1,j4)*pDp(j1,j5)*xpi(j2)*xpi(j3)*pDp(j4,j5)
s(64)=-2*pDp(j1,j4)*pDp(j1,j5)*xpi(j2)*pDp(j3,j4)*pDp(j3,j5)
s(65)=-2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)**2*pDp(j4,j5)
s(66)=+2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j5)
s(67)=+2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j3)*pDp(j2,j5)*pDp(j3,j4)
s(68)=-2*pDp(j1,j4)*pDp(j1,j5)*pDp(j2,j4)*pDp(j2,j5)*xpi(j3)
s(69)=- pDp(j1,j5)**2*xpi(j2)*xpi(j3)*xpi(j4)
s(70)=+ pDp(j1,j5)**2*xpi(j2)*pDp(j3,j4)**2
s(71)=+ pDp(j1,j5)**2*pDp(j2,j3)**2*xpi(j4)
s(72)=-2*pDp(j1,j5)**2*pDp(j2,j3)*pDp(j2,j4)*pDp(j3,j4)
s(73)=+ pDp(j1,j5)**2*pDp(j2,j4)**2*xpi(j3)
* #] terms:
*
del5p = 0
xmaxp = 0
do 20 i=1,nsi
del5p = del5p + s(i)
xmaxp = max(xmaxp,abs(s(i)))
20 continue
if ( abs(del5p) .lt. xloss**2*xmaxp ) then
if ( inow .eq. imem .or. xmaxp .lt. xmax ) then
del5 = del5p
xmax = xmaxp
endif
inow = inow + 1
if ( inow .gt. nperm ) inow = 1
if ( inow .eq. imem ) goto 800
goto 10
endif
del5 = del5p
xmax = xmaxp
* #] calculations:
* #[ into memory:
800 continue
memind = memind + 1
if ( memind .gt. mem ) memind = 1
memarr(memind,1) = id
memarr(memind,2) = idsub
memarr(memind,3) = inow
* #] into memory:
-* #[ error messages:
return
- 910 print *,'ffdel5: error: cannot open file ffperm5.dat with data'
- stop
- 920 print *,'ffdel5: error: error reading from ffperm5.dat'
- stop
-* #] error messages:
*###] ffdel5:
end
*###[ ffdl4p:
- subroutine ffdl4p(dl4p,xpi,piDpj,ns,ii,ier)
+ subroutine ffdl4p(dl4p,piDpj,ii)
***#[*comment:***********************************************************
* calculate in a numerically stable way *
* *
* p1 p2 p3 p4 *
* delta *
* p1 p2 p3 p4 *
* *
* with pn = xpi(ii(n)), n=1,4 *
* p5 = -p1-p2-p3-p4 *
* xpi(ii(n+5)) = pn+p(n+1), n=1,5 *
* *
-* ier is the usual error flag. *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
- integer ns,ii(10),ier
- DOUBLE PRECISION dl4p,xpi(ns),piDpj(ns,ns)
+ integer ii(10)
+ DOUBLE PRECISION dl4p,piDpj(15,15)
*
* local variables
*
integer i,j,k,jj(8),iperm(4,60)
DOUBLE PRECISION s(24),som,xmax,smax
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data (the permutations with 2 from each (1-5) and (6-10) are
* still lacking)
*
data ((iperm(j,i),j=1,4),i=1,35)
+ /1,2,3,4, 2,3,4,5, 3,4,5,1, 4,5,1,2, 5,1,2,3,
+ 6,2,3,4, 4,5,6,2, 5,6,2,3,
+ 1,6,3,4, 4,5,1,6, 5,1,6,3,
+ 1,7,3,4, 7,3,4,5, 5,1,7,3,
+ 1,2,7,4, 2,7,4,5, 5,1,2,7,
+ 1,2,8,4, 2,8,4,5, 8,4,5,1,
+ 1,2,3,8, 2,3,8,5, 3,8,5,1,
+ 2,3,9,5, 3,9,5,1, 9,5,1,2,
+ 2,3,4,9, 3,4,9,1, 4,9,1,2,
+ 3,4,10,1, 4,10,1,2, 10,1,2,3,
+ 3,4,5,10, 4,5,10,2, 5,10,2,3/
data ((iperm(j,i),j=1,4),i=36,60)
+ / 8,9,1,6, 1,6,7,8,
+ 8,9,10,1, 10,1,7,8,
+ 2,7,8,9, 9,10,2,7,
+ 6,2,8,9, 9,10,6,2,
+ 3,8,9,10, 10,6,3,8,
+ 7,3,9,10, 10,6,7,3,
+ 6,7,4,9, 4,9,10,6,
+ 6,7,8,4, 8,4,10,6,
+ 7,8,5,10, 5,10,6,7,
+ 7,8,9,5, 9,5,6,7,
+ 6,7,8,9, 7,8,9,10, 8,9,10,6, 9,10,6,7, 10,6,7,8/
* #] declarations:
* #[ calculations:
*
* for the time being we just try the (60) diagonal elemnts.
*
xmax = 0
do 100 i=1,60
jj(1) = ii(iperm(1,i))
jj(2) = ii(iperm(2,i))
jj(3) = ii(iperm(3,i))
jj(4) = ii(iperm(4,i))
s( 1) = +piDpj(jj(1),jj(1))*piDpj(jj(2),jj(2))*
+ piDpj(jj(3),jj(3))*piDpj(jj(4),jj(4))
s( 2) = +piDpj(jj(2),jj(1))*piDpj(jj(3),jj(2))*
+ piDpj(jj(1),jj(3))*piDpj(jj(4),jj(4))
s( 3) = s(2)
* s( 3) = +piDpj(jj(3),jj(1))*piDpj(jj(1),jj(2))*
* + piDpj(jj(2),jj(3))*piDpj(jj(4),jj(4))
s( 4) = -piDpj(jj(1),jj(1))*piDpj(jj(3),jj(2))*
+ piDpj(jj(2),jj(3))*piDpj(jj(4),jj(4))
s( 5) = -piDpj(jj(3),jj(1))*piDpj(jj(2),jj(2))*
+ piDpj(jj(1),jj(3))*piDpj(jj(4),jj(4))
s( 6) = -piDpj(jj(2),jj(1))*piDpj(jj(1),jj(2))*
+ piDpj(jj(3),jj(3))*piDpj(jj(4),jj(4))
s( 7) = -piDpj(jj(1),jj(1))*piDpj(jj(2),jj(2))*
+ piDpj(jj(4),jj(3))*piDpj(jj(3),jj(4))
s( 8) = -piDpj(jj(2),jj(1))*piDpj(jj(4),jj(2))*
+ piDpj(jj(1),jj(3))*piDpj(jj(3),jj(4))
s( 9) = -piDpj(jj(4),jj(1))*piDpj(jj(1),jj(2))*
+ piDpj(jj(2),jj(3))*piDpj(jj(3),jj(4))
s(10) = +piDpj(jj(1),jj(1))*piDpj(jj(4),jj(2))*
+ piDpj(jj(2),jj(3))*piDpj(jj(3),jj(4))
s(11) = +piDpj(jj(4),jj(1))*piDpj(jj(2),jj(2))*
+ piDpj(jj(1),jj(3))*piDpj(jj(3),jj(4))
s(12) = +piDpj(jj(2),jj(1))*piDpj(jj(1),jj(2))*
+ piDpj(jj(4),jj(3))*piDpj(jj(3),jj(4))
s(13) = -piDpj(jj(1),jj(1))*piDpj(jj(4),jj(2))*
+ piDpj(jj(3),jj(3))*piDpj(jj(2),jj(4))
s(14) = -piDpj(jj(4),jj(1))*piDpj(jj(3),jj(2))*
+ piDpj(jj(1),jj(3))*piDpj(jj(2),jj(4))
s(15) = s(8)
* s(15) = -piDpj(jj(3),jj(1))*piDpj(jj(1),jj(2))*
* + piDpj(jj(4),jj(3))*piDpj(jj(2),jj(4))
s(16) = s(10)
* s(16) = +piDpj(jj(1),jj(1))*piDpj(jj(3),jj(2))*
* + piDpj(jj(4),jj(3))*piDpj(jj(2),jj(4))
s(17) = +piDpj(jj(3),jj(1))*piDpj(jj(4),jj(2))*
+ piDpj(jj(1),jj(3))*piDpj(jj(2),jj(4))
s(18) = +piDpj(jj(4),jj(1))*piDpj(jj(1),jj(2))*
+ piDpj(jj(3),jj(3))*piDpj(jj(2),jj(4))
s(19) = -piDpj(jj(4),jj(1))*piDpj(jj(2),jj(2))*
+ piDpj(jj(3),jj(3))*piDpj(jj(1),jj(4))
s(20) = s(9)
* s(20) = -piDpj(jj(2),jj(1))*piDpj(jj(3),jj(2))*
* + piDpj(jj(4),jj(3))*piDpj(jj(1),jj(4))
s(21) = s(14)
* s(21) = -piDpj(jj(3),jj(1))*piDpj(jj(4),jj(2))*
* + piDpj(jj(2),jj(3))*piDpj(jj(1),jj(4))
s(22) = +piDpj(jj(4),jj(1))*piDpj(jj(3),jj(2))*
+ piDpj(jj(2),jj(3))*piDpj(jj(1),jj(4))
s(23) = s(11)
* s(23) = +piDpj(jj(3),jj(1))*piDpj(jj(2),jj(2))*
* + piDpj(jj(4),jj(3))*piDpj(jj(1),jj(4))
s(24) = s(18)
* s(24) = +piDpj(jj(2),jj(1))*piDpj(jj(4),jj(2))*
* + piDpj(jj(3),jj(3))*piDpj(jj(1),jj(4))
som = 0
smax = 0
do 80 k=1,24
som = som + s(k)
smax = max(smax,abs(som))
80 continue
if ( i .eq. 1 .or. smax .lt. xmax ) then
dl4p = som
xmax = smax
endif
if ( abs(dl4p) .ge. xloss**2*smax ) goto 110
100 continue
110 continue
* #] calculations:
*###] ffdl4p:
end
*###[ ffdl4r:
- subroutine ffdl4r(dl4r,xpi,piDpj,ns,miss,ier)
+ subroutine ffdl4r(dl4r,piDpj,miss)
***#[*comment:***********************************************************
* calculate in a numerically stable way *
* *
* s1 s2 s3 s4 *
* delta *
* p1 p2 p3 p4 *
* *
* with s(miss) NOT included *
* *
-* ier is the usual error flag. *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
- integer ns,miss,ier
- DOUBLE PRECISION dl4r,xpi(ns),piDpj(ns,ns)
+ integer miss
+ DOUBLE PRECISION dl4r,piDpj(15,15)
*
* local variables
*
integer i,j,k,ii(4),jj(4),ipermp(4,125),iperms(4,125),
+ iplace(11,5),minus(125),mem,msign
parameter(mem=45)
integer memarr(mem,4),inow,jnow,imem,jmem,memind
DOUBLE PRECISION s(24),som,xmax,smax
save ipermp,iperms,iplace,minus,memarr,inow,jnow,memind
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ data:
data memind /0/
data memarr /mem*0,mem*0,mem*1,mem*1/
data inow,jnow /1,1/
*
* data (see getpermp.for)
*
data ipermp/
+ 1,2,3,4,1,2,5,3,1,2,3,8,1,2,10,3,1,2,4,5,1,2,7,4,1,2,8,4,1,2,4,
+ 9,1,2,4,10,1,2,5,7,1,2,9,5,1,2,7,8,1,2,10,7,1,2,8,9,1,2,9,10,1,
+ 3,5,4,1,3,4,6,1,3,4,7,1,3,9,4,1,3,10,4,1,3,6,5,1,3,7,5,1,3,5,8,
+ 1,3,5,9,1,3,8,6,1,3,6,10,1,3,8,7,1,3,7,10,1,3,9,8,1,3,10,8,1,3,
+ 10,9,1,4,5,6,1,4,8,5,1,4,6,7,1,4,6,8,1,4,9,6,1,4,10,6,1,4,7,8,1,
+ 4,8,9,1,4,8,10,1,5,7,6,1,5,6,9,1,5,8,7,1,5,9,8,1,6,7,8,1,6,10,7,
+ 1,6,8,9,1,6,9,10,1,7,10,8,1,8,10,9,2,3,4,5,2,3,6,4,2,3,4,9,2,3,
+ 5,6,2,3,8,5,2,3,9,5,2,3,5,10,2,3,6,8,2,3,10,6,2,3,8,9,2,3,9,10,
+ 2,4,6,5,2,4,5,7,2,4,5,8,2,4,10,5,2,4,7,6,2,4,8,6,2,4,6,9,2,4,6,
+ 10,2,4,9,7,2,4,9,8,2,4,10,9,2,5,6,7,2,5,9,6,2,5,7,8,2,5,7,9,2,5,
+ 10,7,2,5,8,9,2,5,9,10,2,6,8,7,2,6,7,10,2,6,9,8,2,6,10,9,2,7,8,9,
+ 2,7,9,10,3,4,7,5,3,4,5,10,3,4,6,7,3,4,10,6,3,4,7,9,3,4,9,10,3,5,
+ 7,6,3,5,6,10,3,5,8,7,3,5,9,7,3,5,7,10,3,5,10,8,3,5,10,9,3,6,7,8,
+ 3,6,10,7,3,6,8,10,3,7,9,8,3,7,10,9,3,8,9,10,4,5,6,7,4,5,10,6,4,
+ 5,7,8,4,5,8,10,4,6,8,7,4,6,7,9,4,6,10,8,4,6,9,10,4,7,8,9,4,8,10,
+ 9,5,6,9,7,5,6,7,10,5,6,10,9,5,7,9,8,5,7,8,10,5,8,9,10,6,7,8,9,6,
+ 7,10,8,6,7,9,10,6,8,10,9,7,8,9,10/
data iperms/
+ 1,2,3,4,1,2,3,7,1,2,8,3,1,2,3,10,1,2,6,4,1,2,4,7,1,2,4,9,1,2,6,7
+ ,1,2,8,6,1,2,6,10,1,2,7,8,1,2,7,9,1,2,10,7,1,2,9,8,1,2,10,9,1,3,
+ 4,5,1,3,6,4,1,3,10,4,1,3,7,5,1,3,5,8,1,3,10,5,1,3,6,7,1,3,8,6,1,
+ 3,6,10,1,3,10,7,1,3,8,10,1,4,5,6,1,4,7,5,1,4,9,5,1,4,6,7,1,4,6,9
+ ,1,4,6,10,1,4,10,7,1,4,10,9,1,5,6,7,1,5,8,6,1,5,6,10,1,5,7,8,1,5
+ ,7,9,1,5,10,7,1,5,9,8,1,5,10,9,1,6,8,7,1,6,9,7,1,6,8,9,1,6,8,10,
+ 1,6,9,10,1,7,10,8,1,7,10,9,1,8,9,10,2,3,4,5,2,3,8,4,2,3,9,4,2,3,
+ 7,5,2,3,5,8,2,3,10,5,2,3,8,7,2,3,9,7,2,3,8,9,2,3,8,10,2,3,9,10,2
+ ,4,5,6,2,4,7,5,2,4,9,5,2,4,6,8,2,4,6,9,2,4,8,7,2,4,9,7,2,4,8,9,2
+ ,5,6,7,2,5,8,6,2,5,6,10,2,5,7,8,2,5,7,9,2,5,10,7,2,5,9,8,2,5,10,
+ 9,2,6,8,7,2,6,9,7,2,6,8,9,2,6,8,10,2,6,9,10,2,7,10,8,2,7,10,9,2,
+ 8,9,10,3,4,5,6,3,4,8,5,3,4,9,5,3,4,5,10,3,4,6,8,3,4,6,9,3,4,10,8
+ ,3,4,10,9,3,5,6,7,3,5,8,6,3,5,6,10,3,5,7,8,3,5,7,9,3,5,10,7,3,5,
+ 9,8,3,5,10,9,3,6,8,7,3,6,9,7,3,6,8,9,3,6,8,10,3,6,9,10,3,7,10,8,
+ 3,7,10,9,3,8,9,10,4,5,6,7,4,5,8,6,4,5,6,10,4,5,7,8,4,5,7,9,4,5,1
+ 0,7,4,5,9,8,4,5,10,9,4,6,8,7,4,6,9,7,4,6,8,9,4,6,8,10,4,6,9,10,4
+ ,7,10,8,4,7,10,9,4,8,9,10/
data iplace /
+ 2,3,4,5, 07,08,09,15, +12,+13, 17,
+ 1,3,4,5, 11,08,09,10, -14,+13, 18,
+ 1,2,4,5, 06,12,09,10, -14,-15, 19,
+ 1,2,3,5, 06,07,13,10, +11,-15, 20,
+ 1,2,3,4, 06,07,08,14, +11,+12, 16/
data minus /
+ +1,+1,+1,+1,+1,+1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,
+ +1,+1,+1,+1,+1,+1,+1,+1,+1,+1,+1,+1,-1,+1,-1,+1,
+ +1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,
+ -1,-1,+1,+1,-1,+1,+1,+1,+1,-1,-1,+1,-1,+1,+1,-1,
+ +1,-1,+1,-1,-1,+1,+1,+1,+1,-1,+1,-1,-1,+1,-1,-1,
+ +1,-1,+1,-1,-1,+1,+1,-1,+1,+1,-1,+1,-1,+1,+1,+1,
+ +1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,-1,-1,+1,+1,+1,
+ +1,-1,+1,-1,-1,+1,-1,-1,+1,-1,+1,-1,-1/
* #] data:
* #[ out of memory:
*
* see if we know were to start, if not: go on as last time
*
do 5 i=1,mem
if ( id .eq. memarr(i,1) .and. idsub .eq. memarr(i,2) ) then
inow = memarr(i,3)
jnow = memarr(i,4)
goto 6
endif
5 continue
6 continue
* #] out of memory:
* #[ calculations:
*
* loop over all permutations of the si and the pi -
* we have 125*125 = a lot of possibilities before we give up ....
* 15-feb-1993: well, let's only consider 25 at a time, otherwise
* the time spent here becomes ludicrous
*
imem = inow
jmem = jnow
dl4r = 0
xmax = 0
*
do 110 i=1,5
ii(1) = abs(iplace((iperms(1,inow)),miss))
ii(2) = abs(iplace((iperms(2,inow)),miss))
ii(3) = abs(iplace((iperms(3,inow)),miss))
ii(4) = abs(iplace((iperms(4,inow)),miss))
msign = sign(1,iplace((iperms(1,inow)),miss))*
+ sign(1,iplace((iperms(2,inow)),miss))*
+ sign(1,iplace((iperms(3,inow)),miss))*
+ sign(1,iplace((iperms(4,inow)),miss))
do 100 j=1,5
jj(1) = ipermp(1,jnow) + 5
jj(2) = ipermp(2,jnow) + 5
jj(3) = ipermp(3,jnow) + 5
jj(4) = ipermp(4,jnow) + 5
*
s( 1) = +piDpj(ii(1),jj(1))*piDpj(ii(2),jj(2))*
+ piDpj(ii(3),jj(3))*piDpj(ii(4),jj(4))
s( 2) = +piDpj(ii(2),jj(1))*piDpj(ii(3),jj(2))*
+ piDpj(ii(1),jj(3))*piDpj(ii(4),jj(4))
s( 3) = +piDpj(ii(3),jj(1))*piDpj(ii(1),jj(2))*
+ piDpj(ii(2),jj(3))*piDpj(ii(4),jj(4))
s( 4) = -piDpj(ii(1),jj(1))*piDpj(ii(3),jj(2))*
+ piDpj(ii(2),jj(3))*piDpj(ii(4),jj(4))
s( 5) = -piDpj(ii(3),jj(1))*piDpj(ii(2),jj(2))*
+ piDpj(ii(1),jj(3))*piDpj(ii(4),jj(4))
s( 6) = -piDpj(ii(2),jj(1))*piDpj(ii(1),jj(2))*
+ piDpj(ii(3),jj(3))*piDpj(ii(4),jj(4))
*
s( 7) = -piDpj(ii(1),jj(1))*piDpj(ii(2),jj(2))*
+ piDpj(ii(4),jj(3))*piDpj(ii(3),jj(4))
s( 8) = -piDpj(ii(2),jj(1))*piDpj(ii(4),jj(2))*
+ piDpj(ii(1),jj(3))*piDpj(ii(3),jj(4))
s( 9) = -piDpj(ii(4),jj(1))*piDpj(ii(1),jj(2))*
+ piDpj(ii(2),jj(3))*piDpj(ii(3),jj(4))
s(10) = +piDpj(ii(1),jj(1))*piDpj(ii(4),jj(2))*
+ piDpj(ii(2),jj(3))*piDpj(ii(3),jj(4))
s(11) = +piDpj(ii(4),jj(1))*piDpj(ii(2),jj(2))*
+ piDpj(ii(1),jj(3))*piDpj(ii(3),jj(4))
s(12) = +piDpj(ii(2),jj(1))*piDpj(ii(1),jj(2))*
+ piDpj(ii(4),jj(3))*piDpj(ii(3),jj(4))
*
s(13) = -piDpj(ii(1),jj(1))*piDpj(ii(4),jj(2))*
+ piDpj(ii(3),jj(3))*piDpj(ii(2),jj(4))
s(14) = -piDpj(ii(4),jj(1))*piDpj(ii(3),jj(2))*
+ piDpj(ii(1),jj(3))*piDpj(ii(2),jj(4))
s(15) = -piDpj(ii(3),jj(1))*piDpj(ii(1),jj(2))*
+ piDpj(ii(4),jj(3))*piDpj(ii(2),jj(4))
s(16) = +piDpj(ii(1),jj(1))*piDpj(ii(3),jj(2))*
+ piDpj(ii(4),jj(3))*piDpj(ii(2),jj(4))
s(17) = +piDpj(ii(3),jj(1))*piDpj(ii(4),jj(2))*
+ piDpj(ii(1),jj(3))*piDpj(ii(2),jj(4))
s(18) = +piDpj(ii(4),jj(1))*piDpj(ii(1),jj(2))*
+ piDpj(ii(3),jj(3))*piDpj(ii(2),jj(4))
*
s(19) = -piDpj(ii(4),jj(1))*piDpj(ii(2),jj(2))*
+ piDpj(ii(3),jj(3))*piDpj(ii(1),jj(4))
s(20) = -piDpj(ii(2),jj(1))*piDpj(ii(3),jj(2))*
+ piDpj(ii(4),jj(3))*piDpj(ii(1),jj(4))
s(21) = -piDpj(ii(3),jj(1))*piDpj(ii(4),jj(2))*
+ piDpj(ii(2),jj(3))*piDpj(ii(1),jj(4))
s(22) = +piDpj(ii(4),jj(1))*piDpj(ii(3),jj(2))*
+ piDpj(ii(2),jj(3))*piDpj(ii(1),jj(4))
s(23) = +piDpj(ii(3),jj(1))*piDpj(ii(2),jj(2))*
+ piDpj(ii(4),jj(3))*piDpj(ii(1),jj(4))
s(24) = +piDpj(ii(2),jj(1))*piDpj(ii(4),jj(2))*
+ piDpj(ii(3),jj(3))*piDpj(ii(1),jj(4))
*
som = 0
smax = 0
do 80 k=1,24
som = som + s(k)
smax = max(smax,abs(som))
80 continue
if ( ( inow .eq. imem .and. jnow .eq. jmem ) .or.
+ smax .lt. xmax ) then
dl4r = msign*minus(inow)*som
xmax = smax
endif
if ( abs(dl4r) .ge. xloss**2*smax ) goto 120
* increase with something that is relative prime to 125 so that
* eventually we cover all possibilities, but with a good
* scatter.
jnow = jnow + 49
if ( jnow .gt. 125 ) jnow = jnow - 125
100 continue
* again, a number relative prime to 125 and a few times smaller
inow = inow + 49
if ( inow .gt. 125 ) inow = inow - 125
110 continue
120 continue
* #] calculations:
* #[ into memory:
- 800 continue
memind = memind + 1
if ( memind .gt. mem ) memind = 1
memarr(memind,1) = id
memarr(memind,2) = idsub
memarr(memind,3) = inow
memarr(memind,4) = jnow
* #] into memory:
*###] ffdl4r:
end
diff --git a/Looptools/E/ffxe0.F b/Looptools/E/ffxe0.F
--- a/Looptools/E/ffxe0.F
+++ b/Looptools/E/ffxe0.F
@@ -1,838 +1,835 @@
+#include "externals.h"
+
+
* $Id: ffxe0.f,v 1.4 1996/01/10 15:36:51 gj Exp $
*###[ ffxe0:
subroutine ffxe0(ce0,cd0i,xpi,ier)
***#[*comment:***********************************************************
* *
* calculate *
* *
* 1 / / \-1*
* e0= -----\dq |(q^2-m_1^2)((q+p_1)^2-m_2^2)...((q-p_5)^2-m_5^2| *
* ipi^2/ \ / *
* *
* following the five four-point-function method in .... *
* As an extra the five fourpoint function Di are also returned *
* if ( ldot ) the dotproducts are left behind in fpij5(15,15) in *
* /ffdot/ and the external determinants fdel4 and fdl3i(5) in *
* /ffdel/. *
* *
* Input: xpi = m_i^2 (real) i=1,5 *
* xpi = p_i.p_i (real) i=6,10 (note: B&D metric) *
* xpi = (p_i+p_{i+1})^2 (r) i=11,15 *
* xpi = (p_i+p_{i+2})^2 (r) i=16,20 OR 0 *
* *
* Output: ce0 (complex) *
* cd0i(5) (complex) D0 with s_i missing *
* ier (integr) 0=ok 1=inaccurate 2=error *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE PRECISION xpi(20)
DOUBLE COMPLEX ce0,cd0i(5)
integer ier
*
* local variables
*
integer i,j,NMIN,NMAX,ier0,i6,i7,i8,i9
parameter(NMIN=15,NMAX=20)
DOUBLE PRECISION dpipj(NMIN,NMAX),xmax
logical lp5(NMAX-NMIN)
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ get differences:
*
* simulate the differences in the masses etc..
*
* first p16-p20
*
do 5 i=1,5
if ( xpi(i+15) .eq. 0 ) then
i6 = i+5
i7 = i6+1
if ( i7 .ge. 11 ) i7 = 6
i8 = i7+1
if ( i8 .ge. 11 ) i8 = 6
i9 = i8+1
if ( i9 .ge. 11 ) i9 = 6
xpi(i+15) = xpi(i6)+xpi(i7)+xpi(i8)-xpi(i6+5)-xpi(i7+5)+
+ xpi(i9+5)
xmax = max(abs(xpi(i6)),abs(xpi(i7)),abs(xpi(i8)),abs(
+ xpi(i6+5)),abs(xpi(i7+5)),abs(xpi(i9+5)))
if ( abs(xpi(i+15)) .lt. xloss*xmax )
+ call ffwarn(168,ier,xpi(i+15),xmax)
lp5(i) = .TRUE.
else
lp5(i) = .FALSE.
endif
5 continue
*
* next the differences
*
ier0 = 0
do 40 i=1,NMAX
do 30 j=1,NMIN
dpipj(j,i) = xpi(j) - xpi(i)
30 continue
40 continue
* #] get differences:
* #[ call ffxe0a:
call ffxe0a(ce0,cd0i,xpi,dpipj,ier)
* #] call ffxe0a:
* #[ clean up:
do 90 i=1,5
if ( lp5(i) ) then
xpi(i+NMIN) = 0
endif
90 continue
* #] clean up:
*###] ffxe0:
end
*###[ ffxe0a:
subroutine ffxe0a(ce0,cd0i,xpi,dpipj,ier)
***#[*comment:***********************************************************
* *
* calculate *
* *
* 1 / / \-1*
* e0= -----\dq |(q^2-m_1^2)((q+p_1)^2-m_2^2)...((q-p_5)^2-m_5^2| *
* ipi^2/ \ / *
* *
* following the five four-point-function method in .... *
* As an extra the five fourpoint function Di are also returned *
* if ( ldot ) the dotproducts are left behind in fpij5(15,15) in *
* /ffdot/ and the external determinants fdel4 and fdl3i(5) in *
* /ffdel/. *
* *
* Input: xpi = m_i^2 (real) i=1,5 *
* xpi = p_i.p_i (real) i=6,10 (note: B&D metric) *
* xpi = (p_i+p_{i+1})^2 (r) i=11,15 *
* xpi = (p_i+p_{i+2})^2 (r) i=16,20 *
* dpipj(15,20) (real) = pi(i) - pi(j) *
* *
* Output: ce0 (complex) *
* cd0i(5) (complex) D0 with s_i missing *
* ier (integer) <50:lost # digits 100=error *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX ce0,cd0i(5)
DOUBLE PRECISION xpi(20),dpipj(15,20)
*
* local variables
*
integer i,j,ii(10),ii4(6),ieri(5),ier0,imin,itype,ndiv,idone,
+ ier1
logical ldel2s
DOUBLE COMPLEX c,cfac,cs,csum
DOUBLE PRECISION dl5s,dl4p,xpi4(13),dpipj4(10,13),piDpj4(10,10),
+ absc,xmax,piDpj(15,15),xqi4(13),dqiqj4(10,13),
+ qiDqj4(10,10),del2s,xmx5(5),dl4ri(5)
save ii4
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* data
*
data ii4 /5,6,7,8,9,10/
*
* #] declarations:
* #[ initialisations:
ndiv = 0
idsub = 0
ce0 = 0
do 1 i=1,5
cd0i(i) = 0
1 continue
* #] initialisations:
* #[ calculations:
*
idsub = idsub + 1
call ffdot5(piDpj,xpi,dpipj,ier)
if ( ldot ) then
do 6 i=1,15
do 5 j=1,15
fpij5(j,i) = piDpj(j,i)
5 continue
6 continue
do 10 i=1,10
ii(i) = i+5
10 continue
idsub = idsub + 1
ier0 = 0
- call ffdl4p(dl4p,xpi,piDpj,15,ii,ier0)
+ call ffdl4p(dl4p,piDpj,ii)
* if ( dl4p .lt. 0 ) then
* call fferr(57,ier)
* endif
fdel4 = dl4p
endif
idsub = idsub + 1
- call ffdel5(dl5s,xpi,piDpj,15,ier)
+ call ffdel5(dl5s,xpi,piDpj)
*
do 40 i=1,5
ieri(i) = ier
40 continue
*
do 100 i=1,5
*
* get the coefficient determinant
*
idsub = idsub + 1
- call ffdl4r(dl4ri(i),xpi,piDpj,15,i,ieri(i))
+ call ffdl4r(dl4ri(i),piDpj,i)
*
* get four-point momenta
*
- call ffpi54(xpi4,dpipj4,piDpj4,xpi,dpipj,piDpj,i,ieri(i))
+ call ffpi54(xpi4,dpipj4,piDpj4,xpi,dpipj,piDpj,i)
*
* first try IR divergent function to avoid error messages from ffrot4
*
ier1 = ieri(i)
call ffxdir(cs,cfac,idone,xpi4,dpipj4,6,ndiv,ier1)
if ( idone .gt. 0 ) then
* done
xmax = abs(cs)*10d0**(-mod((ier1-ieri(i)),50))
else
*
* rotate to calculable posistion
*
call ffrot4(irota4,del2s,xqi4,dqiqj4,qiDqj4,xpi4,dpipj4,
+ piDpj4,5,itype,ieri(i))
if ( itype .lt. 0 ) then
print *,'ffxe0: error: Cannot handle this ',
+ ' 4point masscombination yet:'
print *,(xpi(j),j=1,20)
return
endif
if ( itype .eq. 1 ) then
ldel2s = .TRUE.
isgnal = +1
print *,'ffxe0a: Cannot handle del2s = 0 yet'
stop
else
ldel2s = .FALSE.
endif
if ( itype .eq. 2 ) then
print *,'ffxe0a: no doubly IR divergent yet'
stop
endif
*
* get fourpoint function
*
ier0 = ieri(i)
call ffxd0e(cs,cfac,xmax, .FALSE.,ndiv,xqi4,dqiqj4,
+ qiDqj4,del2s,ldel2s,ieri(i))
if ( ieri(i).gt.10 ) then
isgnal = -isgnal
ieri(i) = ier0
call ffxd0e(cs,cfac,xmax, .TRUE.,ndiv,xqi4,dqiqj4,
+ qiDqj4,del2s,ldel2s,ieri(i))
isgnal = -isgnal
endif
endif
*
* Finally ...
*
cd0i(i) = cs*cfac
xmx5(i) = xmax*absc(cfac)
if ( ldot ) then
call ffdl3p(fdl3i(i),piDpj4,10,ii4,ii4)
* let's hope tha tthese have been set by ffxd0e...
fdl4si(i) = fdel4s
endif
100 continue
*
* #] calculations:
* #[ add all up:
*
csum = 0
xmax = 0
imin = 1
do 200 i=1,5
imin = -imin
csum = csum + imin*DBLE(dl4ri(i))*cd0i(i)
if ( ieri(i) .gt. 50 ) then
ieri(i) = mod(ieri(i),50)
endif
xmax = max(xmax,dl4ri(i)*xmx5(i)*DBLE(10)**mod(ieri(i),50))
200 continue
*
* If the imaginary part is very small it most likely is zero
* (can be removed, just esthetically more pleasing)
*
if ( abs(DIMAG(csum)) .lt. precc*abs(DBLE(csum)) )
+ csum = DCMPLX(DBLE(csum))
*
* Finally ...
*
ce0 = csum*(1/DBLE(2*dl5s))
*
* #] add all up:
*###] ffxe0a:
end
*###[ ffxe00:
- subroutine ffxe00(ce0,cd0i,dl4ri,xpi,piDpj,ier)
+ subroutine ffxe00(ce0,cd0i,dl4ri,xpi,piDpj)
***#[*comment:***********************************************************
* *
* calculate *
* *
* 1 / / \-1*
* e0= -----\dq |(q^2-m_1^2)((q+p_1)^2-m_2^2)...((q-p_5)^2-m_5^2| *
* ipi^2/ \ / *
* *
* following the five four-point-function method in .... *
* The four five fourpoint function Di are input in this version. *
* *
* Input: cd0i(5) (complex) D0 with s_i missing *
* dl4ri(5) (real) coeff of D0 *
* xpi = m_i^2 (real) i=1,5 *
* xpi = p_i.p_i (real) i=6,10 (note: B&D metric) *
* xpi = (p_i+p_{i+1})^2 (r) i=11,15 *
* xpi = (p_i+p_{i+2})^2 (r) i=16,20 *
* piDpj(15,15) (real) pi.pj *
* *
* Output: ce0 (complex) *
-* ier (integer) <50:lost # digits 100=error *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
- integer ier
DOUBLE COMPLEX ce0,cd0i(5)
DOUBLE PRECISION dl4ri(5),xpi(20),piDpj(15,15)
*
* local variables
*
- integer i,ii(10),imin,ier0
+ integer i,ii(10),imin
DOUBLE COMPLEX c,csum
DOUBLE PRECISION dl5s,dl4p,absc,xmax
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ initialisations:
*
idsub = idsub + 1
ce0 = 0
*
* #] initialisations:
* #[ calculations:
*
if ( ldot ) then
do 10 i=1,10
ii(i) = i+5
10 continue
idsub = idsub + 1
- ier0 = 0
- call ffdl4p(dl4p,xpi,piDpj,15,ii,ier0)
+ call ffdl4p(dl4p,piDpj,ii)
fdel4 = dl4p
endif
idsub = idsub + 1
- call ffdel5(dl5s,xpi,piDpj,15,ier)
+ call ffdel5(dl5s,xpi,piDpj)
*
* #] calculations:
* #[ add all up:
*
csum = 0
xmax = 0
imin = 1
do 200 i=1,5
imin = -imin
csum = csum + imin*DBLE(dl4ri(i))*cd0i(i)
xmax = max(xmax,abs(dl4ri(i))*absc(cd0i(i)))
200 continue
*
* If the imaginary part is very small it most likely is zero
* (can be removed, just esthetically more pleasing)
*
if ( abs(DIMAG(csum)) .lt. precc*abs(DBLE(csum)) )
+ csum = DCMPLX(DBLE(csum))
*
* Finally ...
*
ce0 = csum*(1/DBLE(2*dl5s))
*
* #] add all up:
*###] ffxe00:
end
*###[ ffdot5:
subroutine ffdot5(piDpj,xpi,dpipj,ier)
***#[*comment:***********************************************************
* *
* calculate the dotproducts pi.pj with *
* *
* xpi(i) = s_i i=1,5 *
* xpi(i) = p_i i=6,10 *
* xpi(i) = p_i+p_{i+1} i=11,15 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE PRECISION xpi(20),dpipj(15,20),piDpj(15,15)
*
* local variables
*
integer is1,is2,is3,is4,ip6,ip7,ip8,ip11,ip12,ip14,
+ itel,i1,i2,i3,i4,i5,i6,ierin
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
* #] declarations:
* #[ indices:
ierin = ier
do 10 is1=1,5
is2 = is1 + 1
if ( is2 .eq. 6 ) is2 = 1
is3 = is2 + 1
if ( is3 .eq. 6 ) is3 = 1
ip6 = is1 + 5
ip7 = is2 + 5
ip11 = ip6 + 5
*
* we have now defined a 3point function
*
* | -p11
* |
* / \
* s1/ \s3
* ___/_____\___
* p6 s2 p7
*
* #] indices:
* #[ all in one vertex:
*
* pi.pi, si.si
*
piDpj(is1,is1) = xpi(is1)
piDpj(ip6,ip6) = xpi(ip6)
piDpj(ip11,ip11) = xpi(ip11)
*
* si.s(i+1)
*
if ( xpi(is2) .le. xpi(is1) ) then
piDpj(is1,is2) = (dpipj(is1,ip6) + xpi(is2))/2
else
piDpj(is1,is2) = (dpipj(is2,ip6) + xpi(is1))/2
endif
piDpj(is2,is1) = piDpj(is1,is2)
*
* si.s(i+2)
*
if ( xpi(is1) .le. xpi(is3) ) then
piDpj(is3,is1) = (dpipj(is3,ip11) + xpi(is1))/2
else
piDpj(is3,is1) = (dpipj(is1,ip11) + xpi(is3))/2
endif
piDpj(is1,is3) = piDpj(is3,is1)
*
* pi.si
*
if ( abs(xpi(ip6)) .le. xpi(is1) ) then
piDpj(ip6,is1) = (dpipj(is2,is1) - xpi(ip6))/2
else
piDpj(ip6,is1) = (dpipj(is2,ip6) - xpi(is1))/2
endif
piDpj(is1,ip6) = piDpj(ip6,is1)
*
* pi.s(i+1)
*
if ( abs(xpi(ip6)) .le. xpi(is2) ) then
piDpj(ip6,is2) = (dpipj(is2,is1) + xpi(ip6))/2
else
piDpj(ip6,is2) = (dpipj(ip6,is1) + xpi(is2))/2
endif
piDpj(is2,ip6) = piDpj(ip6,is2)
*
* p(i+2).s(i)
*
if ( abs(xpi(ip11)) .le. xpi(is1) ) then
piDpj(ip11,is1) = -(dpipj(is1,is3) + xpi(ip11))/2
else
piDpj(ip11,is1) = -(dpipj(ip11,is3) + xpi(is1))/2
endif
piDpj(is1,ip11) = piDpj(ip11,is1)
*
* p(i+2).s(i+2)
*
if ( abs(xpi(ip11)) .le. xpi(is3) ) then
piDpj(ip11,is3) = -(dpipj(is1,is3) - xpi(ip11))/2
else
piDpj(ip11,is3) = -(dpipj(is1,ip11) - xpi(is3))/2
endif
piDpj(is3,ip11) = piDpj(ip11,is3)
* #] all in one vertex:
* #[ all in one 3point:
*
* pi.s(i+2)
*
if ( min(abs(dpipj(is2,is1)),abs(dpipj(ip11,ip7))) .le.
+ min(abs(dpipj(ip11,is1)),abs(dpipj(is2,ip7))) ) then
piDpj(ip6,is3) = (dpipj(ip11,ip7) + dpipj(is2,is1))/2
else
piDpj(ip6,is3) = (dpipj(ip11,is1) + dpipj(is2,ip7))/2
endif
piDpj(is3,ip6) = piDpj(ip6,is3)
*
* p(i+1).s(i)
*
if ( min(abs(dpipj(is3,is2)),abs(dpipj(ip6,ip11))) .le.
+ min(abs(dpipj(ip6,is2)),abs(dpipj(is3,ip11))) ) then
piDpj(ip7,is1) = (dpipj(ip6,ip11) + dpipj(is3,is2))/2
else
piDpj(ip7,is1) = (dpipj(ip6,is2) + dpipj(is3,ip11))/2
endif
piDpj(is1,ip7) = piDpj(ip7,is1)
*
* p(i+2).s(i+1)
*
if ( min(abs(dpipj(is1,is3)),abs(dpipj(ip7,ip6))) .le.
+ min(abs(dpipj(ip7,is3)),abs(dpipj(is1,ip6))) ) then
piDpj(ip11,is2) = -(dpipj(ip7,ip6) + dpipj(is1,is3))/2
else
piDpj(ip11,is2) = -(dpipj(ip7,is3) + dpipj(is1,ip6))/2
endif
piDpj(is2,ip11) = piDpj(ip11,is2)
* #] all in one 3point:
* #[ all external 3point:
*
* pi.p(i+1)
*
if ( abs(xpi(ip7)) .le. abs(xpi(ip6)) ) then
piDpj(ip6,ip7) = (dpipj(ip11,ip6) - xpi(ip7))/2
else
piDpj(ip6,ip7) = (dpipj(ip11,ip7) - xpi(ip6))/2
endif
piDpj(ip7,ip6) = piDpj(ip6,ip7)
*
* p(i+1).p(i+2)
*
if ( abs(xpi(ip11)) .le. abs(xpi(ip7)) ) then
piDpj(ip7,ip11) = -(dpipj(ip6,ip7) - xpi(ip11))/2
else
piDpj(ip7,ip11) = -(dpipj(ip6,ip11) - xpi(ip7))/2
endif
piDpj(ip11,ip7) = piDpj(ip7,ip11)
*
* p(i+2).p(i)
*
if ( abs(xpi(ip6)) .le. abs(xpi(ip11)) ) then
piDpj(ip11,ip6) = -(dpipj(ip7,ip11) - xpi(ip6))/2
else
piDpj(ip11,ip6) = -(dpipj(ip7,ip6) - xpi(ip11))/2
endif
piDpj(ip6,ip11) = piDpj(ip11,ip6)
* #] all external 3point:
* #[ the other 3point:
is4 = is3 + 1
if ( is4 .eq. 6 ) is4 = 1
ip8 = is3 + 5
ip14 = is4 + 10
*
* we now work with the threepoint configuration
*
* | p14
* |
* / \
* s1/ \s4
* ___/_____\___
* p11 s3 p8
*
* s1.p8
*
do 11 itel = 1,3
if ( itel .eq. 1 ) then
i1 = is1
i2 = is3
i3 = is4
i4 = ip11
i5 = ip8
i6 = ip14
elseif ( itel .eq. 2 ) then
i1 = is3
i2 = is4
i3 = is1
i4 = ip8
i5 = ip14
i6 = ip11
else
i1 = is4
i2 = is1
i3 = is3
i4 = ip14
i5 = ip11
i6 = ip8
endif
*
* in one go: the opposite sides
*
if ( min(abs(dpipj(i3,i2)),abs(dpipj(i4,i6))) .le.
+ min(abs(dpipj(i4,i2)),abs(dpipj(i3,i6))) ) then
piDpj(i5,i1) = (dpipj(i3,i2) + dpipj(i4,i6))/2
else
piDpj(i5,i1) = (dpipj(i4,i2) + dpipj(i3,i6))/2
endif
piDpj(i1,i5) = piDpj(i5,i1)
*
* and the remaining external ones
*
if ( abs(xpi(i5)) .le. abs(xpi(i4)) ) then
piDpj(i4,i5) = (dpipj(i6,i4) - xpi(i5))/2
else
piDpj(i4,i5) = (dpipj(i6,i5) - xpi(i4))/2
endif
piDpj(i5,i4) = piDpj(i4,i5)
11 continue
* #] the other 3point:
* #[ 4point indices:
ip12 = ip7+5
*
* we now have the fourpoint configuration
*
* \p14 /p8
* \____/
* | s4 |
* s1| |s3
* |____|
* p6/ s2 \p7
* / \
*
*
*
do 12 itel = 1,2
if ( itel .eq. 1 ) then
i1 = ip6
i2 = ip8
i3 = ip7
i4 = ip14
else
i1 = ip7
i2 = ip14
i3 = ip6
i4 = ip8
endif
if ( min(abs(dpipj(i3,ip11)),abs(dpipj(i4,ip12))) .le.
+ min(abs(dpipj(i4,ip11)),abs(dpipj(i3,ip12))) ) then
piDpj(i1,i2) = (dpipj(i3,ip11) + dpipj(i4,ip12))/2
else
piDpj(i1,i2) = (dpipj(i4,ip11) + dpipj(i3,ip12))/2
endif
piDpj(i2,i1) = piDpj(i1,i2)
12 continue
*
* we are only left with p11.p12 etc.
*
if ( min(abs(dpipj(ip14,ip8)),abs(dpipj(ip7,ip6))) .le.
+ min(abs(dpipj(ip7,ip8)),abs(dpipj(ip14,ip6))) ) then
piDpj(ip11,ip12) = (dpipj(ip7,ip6) + dpipj(ip14,ip8))/2
else
piDpj(ip11,ip12) = (dpipj(ip7,ip8) + dpipj(ip14,ip6))/2
endif
piDpj(ip12,ip11) = piDpj(ip11,ip12)
10 continue
* #] 4point indices:
*###] ffdot5:
end
*###[ ffpi54:
- subroutine ffpi54(xpi4,dpipj4,piDpj4,xpi,dpipj,piDpj,inum,ier)
+ subroutine ffpi54(xpi4,dpipj4,piDpj4,xpi,dpipj,piDpj,inum)
***#[*comment:***********************************************************
* *
* Gets the dotproducts pertaining to the fourpoint function with *
* s_i missing out of the five point function dotproduct array. *
* *
* Input: xpi real(20) si.si,pi.pi *
* dpipj real(15,20) xpi(i) - xpi(j) *
* piDpj real(15,15) pi(i).pi(j) *
* inum integer 1--5 *
* *
* Output: xpi4 real(13) *
* dpipj4 real(10,13) *
* piDpj4 real(10,10) *
-* ier integer *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
- integer inum,ier
+ integer inum
DOUBLE PRECISION xpi(20),dpipj(15,20),piDpj(15,15),xpi4(13),
+ dpipj4(10,13),piDpj4(10,10)
*
* local variables
*
integer i,j,iplace(11,5),isigns(11,5)
save iplace,isigns
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data iplace /
+ 2,3,4,5, 07,08,09,15, 12,13, 17,
+ 1,3,4,5, 11,08,09,10, 14,13, 18,
+ 1,2,4,5, 06,12,09,10, 14,15, 19,
+ 1,2,3,5, 06,07,13,10, 11,15, 20,
+ 1,2,3,4, 06,07,08,14, 11,12, 16/
*
data isigns /
+ +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +1,
+ +1,+1,+1,+1, +1,+1,+1,+1, +1,+1, +1,
+ +1,+1,+1,+1, +1,+1,+1,+1, +1,-1, +1,
+ +1,+1,+1,+1, +1,+1,+1,+1, -1,-1, +1,
+ +1,+1,+1,+1, +1,+1,+1,+1, -1,+1, +1/
* #] declarations:
* #[ distribute:
*
* copy p5-p11
*
do 20 i=1,11
xpi4(i) = xpi(iplace(i,inum))
do 10 j=1,10
dpipj4(j,i) = dpipj(iplace(j,inum),iplace(i,inum))
10 continue
20 continue
*
* these cannot be simply copied I think
*
xpi4(12) = -xpi4(5)+xpi4(6)-xpi4(7)+xpi4(8)+xpi4(9)+xpi4(10)
xpi4(13) = xpi4(5)-xpi4(6)+xpi4(7)-xpi4(8)+xpi4(9)+xpi4(10)
*
* and the differences
*
do 40 i=12,13
do 30 j=1,10
dpipj4(j,i) = xpi4(j) - xpi4(i)
30 continue
40 continue
*
* copy the dotproducts (watch the signs of p9,p10!)
*
do 60 i=1,10
do 50 j=1,10
piDpj4(j,i) = isigns(j,inum)*isigns(i,inum)*
+ piDpj(iplace(j,inum),iplace(i,inum))
50 continue
60 continue
* #] distribute:
*###] ffpi54:
end
*###[ ffxe0r:
subroutine ffxe0r(ce0,cd0i,xpi,ier)
***#[*comment:***********************************************************
* *
* Tries all 12 permutations of the 5pointfunction *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ier,nrot
parameter(nrot=12)
DOUBLE PRECISION xpi(20),xqi(20)
DOUBLE COMPLEX ce0,cd0i(5),ce0p,cd0ip(5),cd0ipp(5)
integer inew(20,nrot),irota,ier1,i,j,k,icon,ialsav,init
logical lcon
parameter (icon=3)
save inew,init,lcon
- include 'ff.h'
+#include "ff.h"
data inew
+ /1,2,3,4,5, 6,7,8,9,10,11,12,13,14,15, 16,17,18,19,20,
+ 2,1,3,4,5, 6,11,8,9,15,7,14,13,12,10, 16,18,17,19,-20,
+ 1,3,2,4,5, 11,7,12,9,10,6,8,15,14,13, -16,17,19,18,20,
+ 1,2,4,3,5, 6,12,8,13,10,14,7,9,11,15, 16,-17,18,20,19,
+ 1,2,3,5,4, 6,7,13,9,14,11,15,8,10,12, 20,17,-18,19,16,
+ 5,2,3,4,1, 15,7,8,14,10,13,12,11,9,6, 17,16,18,-19,20,
+ 2,1,4,3,5, 6,14,8,13,15,12,11,9,7,10, 16,-18,17,20,-19,
+ 1,3,2,5,4, 11,7,15,9,14,6,13,12,10,8, -20,17,-19,18,16,
+ 5,2,4,3,1, 15,12,8,11,10,9,7,14,13,6, 17,-16,18,-20,19,
+ 2,1,3,5,4, 6,11,13,9,12,7,10,8,15,14, 20,18,-17,19,-16,
+ 5,3,2,4,1, 13,7,12,14,10,15,8,6,9,11, -17,16,19,-18,20,
+ 1,3,5,2,4, 11,13,15,12,14,10,7,9,6,8,-20,-17,-19,-16,-18/
data init /0/
* #] declarations:
* #[ open console for some activity on screen:
if ( init .eq. 0 ) then
init = 1
- 11 continue
lcon = .FALSE.
- 13 continue
endif
* #] open console for some activity on screen:
* #[ calculations:
ce0 = 0
ier = 999
ialsav = isgnal
do 30 j = -1,1,2
do 20 irota=1,nrot
do 10 i=1,20
if ( inew(i,irota) .lt. 0 ) then
xqi(-inew(i,irota)) = 0
else
xqi(inew(i,irota)) = xpi(i)
endif
10 continue
- print '(a,i2,a,i2)','---#[ rotation ',irota,': isgnal ',
- + isgnal
- if (lcon) write(icon,'(a,i2,a,i2)')'rotation ',irota,',
- + isgnal ',isgnal
+ print '(a,i2,a,i2)','---#[ rotation ',irota,
+ + ': isgnal ',isgnal
+ if (lcon) write(icon,'(a,i2,a,i2)') 'rotation ',irota,
+ + ', isgnal ',isgnal
ier1 = 0
ner = 0
id = id + 1
isgnal = ialsav
call ffxe0(ce0p,cd0ip,xqi,ier1)
ier1 = ier1 + ner
print '(a,i1,a,i2)','---#] rotation ',irota,': isgnal ',
+ isgnal
print '(a,2g28.16,i3)','e0 = ',ce0p,ier1
do 15 k=1,5
cd0ipp(k) = cd0ip(inew(k,irota))
print '(a,2g28.16,i3)','d0 = ',cd0ipp(k),k
15 continue
if (lcon) write(icon,'(a,2g28.16,i3)')'e0 = ',ce0p,ier1
if ( ier1 .lt. ier ) then
ce0 = ce0p
do 19 k=1,5
cd0i(k) = cd0ipp(k)
19 continue
ier = ier1
endif
20 continue
ialsav = -ialsav
30 continue
* #] calculations:
*###] ffxe0r:
end
diff --git a/Looptools/Makefile.am b/Looptools/Makefile.am
--- a/Looptools/Makefile.am
+++ b/Looptools/Makefile.am
@@ -1,52 +1,59 @@
-noinst_LTLIBRARIES = libHwLooptoolsXFC.la
-## libHwLooptoolsCFC.la
-
-EXTRA_LTLIBRARIES = libHwLooptoolsCFC.la
-## EXTRA_LTLIBRARIES += libHwLooptoolsCheck2.la
+noinst_LTLIBRARIES = libHwLooptoolsXFC.la libHwLooptoolsCFC.la
+noinst_LTLIBRARIES += libHwLooptools.la
EXTRA_DIST = include/lt.h include/ftypes.h include/ff.h include/ffwarn.h \
include/fferr.h include/defs.h include/looptools.h include/ffperm5.h \
include/clooptools.h
-theXFCSOURCES = A/ffca0.F A/ffxa0.F A/A0.F A/A00.F \
-B/ffxdb0.F B/Bcoeffa.F B/ffcb0.F B/Bcoeff.F B/ffxdb1.F \
-B/ffdel2.F B/ffcel2.F B/ffcb1.F B/ffcdb0.F \
-B/Bcoeffb.F B/ffxb1.F B/Bget.F B/ffxb0.F B/ffcb2p.F B/ffxb2p.F \
-C/ffxc0p.F C/ffcc0p.F C/ffdel3.F C/Cget.F C/ffcel3.F C/ffdcc0.F \
-C/ffxc0.F C/ffdxc0.F C/ffxc0p0.F C/C0.F C/ffcc0.F C/ffxc0i.F \
-D/ffxdbd.F D/ffxd0i.F D/ffcdbd.F D/ffcd0.F D/D0.F D/ffxd0p.F D/ffcel4.F \
-D/ffxd0.F D/Dget.F D/ffdel4.F D/ffxd0m0.F D/ffxd0h.F \
-E/Ecoeffb.F E/E0.F E/ffxe0.F E/ffdel5.F E/Ecoeffa.F E/Eget.F \
-util/ini.F util/ffcxs3.F util/GaussPivot.F util/Dump.F util/ffbndc.F \
-util/ffcxr.F util/ffinit.F util/ffabcd.F util/Li2.F util/ff2dl2.F \
-util/cache.c util/ffcxyz.F util/ffxxyz.F util/ffxli2.F util/ffdcxs.F \
-util/ffcxs4.F util/fftran.F util/CGaussPivot.F util/auxCD.F util/ffcli2.F \
-util/ffcrr.F clooptools.cc
-##util/qcomplex.f90
+theXFCSOURCES = \
+A/A0.F A/A00.F A/ffxa0.F A/ffca0.F B/Bget.F \
+B/Bcoeff.F B/BcoeffC.F B/Bcoeffa.F B/Bcoeffb.F B/ffxb0.F \
+B/ffcb0.F B/ffxb1.F B/ffcb1.F B/ffxb2p.F B/ffcb2p.F \
+B/ffxdb0.F B/ffcdb0.F B/ffxdb1.F B/ffdel2.F B/ffcel2.F \
+C/C0.F C/C0C.F C/Cget.F C/ffxc0.F C/ffcc0.F \
+C/ffxc0i.F C/ffxc0p.F C/ffxc0p0.F C/ffcc0p.F C/ffdxc0.F \
+C/ffdel3.F C/ffcel3.F D/D0.F D/D0C.F D/Dget.F \
+D/ffxd0.F D/ffxd0h.F D/ffxd0i.F D/ffxd0p.F D/ffxd0m0.F \
+D/ffxd0tra.F D/ffxdbd.F D/ffdcc0.F D/ffdel4.F D/ffd0c.F \
+D/ffTn.F D/ffT13.F D/ffS2.F D/ffS3n.F D/ffRn.F \
+E/E0.F E/Eget.F E/Ecoeffa.F E/Ecoeffb.F E/ffxe0.F \
+E/ffdel5.F util/ini.F util/auxCD.F util/solve.F util/Dump.F \
+util/Li2.F util/ffinit.F util/ffxli2.F util/ffcli2.F util/ffxxyz.F \
+util/ffcxyz.F util/ffcrr.F util/ffcxr.F util/fftran.F util/ffabcd.F \
+util/ff2dl2.F util/ffcxs3.F util/ffcxs4.F util/ffdcxs.F util/ffbndc.F
## the following need -DCOMPLEXPARA
-theCFCSOURCES = A/A0.F A/A00.F B/Bget.F B/Bcoeffa.F C/Cget.F D/Dget.F \
-E/E0.F E/Eget.F E/Ecoeffa.F E/Ecoeffb.F \
-util/GaussPivot.F util/Dump.F util/Li2.F
+theCFCSOURCES = \
+A/A0.F A/A00.F B/Bget.F B/Bcoeffa.F C/Cget.F D/Dget.F E/E0.F \
+E/Eget.F E/Ecoeffa.F E/Ecoeffb.F util/solve.F util/Dump.F util/Li2.F
commonCPPFLAGS = $(AM_CPPFLAGS) -I$(srcdir)/include
+
libHwLooptoolsXFC_la_SOURCES = $(theXFCSOURCES)
-libHwLooptoolsXFC_la_CPPFLAGS = $(commonCPPFLAGS)
-libHwLooptoolsXFC_la_CFLAGS = $(AM_CFLAGS) -std=c99
-libHwLooptoolsXFC_la_FCFLAGS = $(AM_FCFLAGS)
+libHwLooptoolsXFC_la_CPPFLAGS = $(commonCPPFLAGS)
+libHwLooptoolsXFC_la_FCFLAGS = $(AM_FCFLAGS) -ffixed-line-length-none
+libHwLooptoolsXFC_la_FFLAGS = $(AM_FFLAGS) -ffixed-line-length-none
libHwLooptoolsCFC_la_SOURCES = $(theCFCSOURCES)
libHwLooptoolsCFC_la_CPPFLAGS = $(commonCPPFLAGS) -DCOMPLEXPARA
+libHwLooptoolsCFC_la_FCFLAGS = $(AM_FCFLAGS) -ffixed-line-length-none
+libHwLooptoolsCFC_la_FFLAGS = $(AM_FFLAGS) -ffixed-line-length-none
## installed already from "include/Makefile.am"
## noinst_HEADERS = include/clooptools.h
##if NEED_APPLE_FIXES
##libHwLooptoolsXFC_la_LDFLAGS = -Wl,-single_module
##libHwLooptoolsCFC_la_LDFLAGS = -Wl,-single_module
##endif
+libHwLooptools_la_SOURCES = util/cache.c clooptools.cc
+libHwLooptools_la_CPPFLAGS = $(commonCPPFLAGS)
+libHwLooptools_la_CFLAGS = $(AM_CFLAGS) -std=c99
+libHwLooptools_la_LIBADD = libHwLooptoolsXFC.la libHwLooptoolsCFC.la
+
+
## libHwLooptoolsHelper2_la_SOURCES = clooptools.cc
EXTRA_PROGRAMS = tester
tester_SOURCES = tester.cc
-tester_LDADD = libHwLooptoolsXFC.la $(FCLIBS)
+tester_LDADD = libHwLooptools.la $(FCLIBS) $(THEPEGLDFLAGS) $(THEPEGLIB)
diff --git a/Looptools/README b/Looptools/README
--- a/Looptools/README
+++ b/Looptools/README
@@ -1,17 +1,20 @@
-This subdirectory is based on version 2.2 of the Looptools package available at
+This subdirectory is based on version 2.6 of the Looptools package available at
http://www.feynarts.de/looptools/
From their website, it seems that Looptools is licensed under the LGPL,
although the tarball itself does not contain a reference to it.
For reference, we have added the LGPL in the file COPYING.Looptools.
Note that this licence only applies to the Looptools subdirectory.
-Our changes to LoopTools-2.2.tar.gz are listed here:
+Our changes to LoopTools-2.6.tar.gz are listed here:
-* include/clooptools.h modified
-* added Makefile.am; creates libHwLooptools.a
+* removed unused 'tools' and 'frontend' directories
+* include/clooptools.h modified: definitions and 'extern' declarations moved to
+ Herwig's clooptools.cc
+* fixed 64bit int -> long problem in cache.c
+* added Makefile.am; creates libHwLooptools.la to be linked into Herwig.so
* added tester.cc: a quick test whether c++ linking works
--
-2008-01-28 David Grellscheid <david.grellscheid@durham.ac.uk>
+2011-01-17 David Grellscheid <david.grellscheid@durham.ac.uk>
diff --git a/Looptools/clooptools.cc b/Looptools/clooptools.cc
--- a/Looptools/clooptools.cc
+++ b/Looptools/clooptools.cc
@@ -1,89 +1,495 @@
/* -*- C++ -*-
- clooptools.cc
- the C++ file with the definitions for fortran IO redirection
- Output redirected to log file. 2007-07-18 dgrell
+ clooptools.cc
+ the C++ file with the definitions for fortran IO redirection
+ Output redirected to log file. 2007-07-18 dgrell
+
+ Definitions moved here from clooptools.h 2011-01-21 dgrell
*/
+
+#include "Herwig++/Looptools/clooptools.h"
+
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <cstdio>
#include <cassert>
#include <string>
#ifdef HAVE_UNISTD_H
# include "ThePEG/Repository/CurrentGenerator.h"
#endif
extern "C" {
#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif
- void ffini_();
- void ffexi_();
+ extern void a0sub_(DOUBLE_COMPLEX *result, AARGS(_Fr_));
+ extern void a0subc_(DOUBLE_COMPLEX *result, AARGS(_Fc_));
+ extern void a00sub_(DOUBLE_COMPLEX *result, AARGS(_Fr_));
+ extern void a00subc_(DOUBLE_COMPLEX *result, AARGS(_Fc_));
+
+ extern long bget_(BARGS(_Fr_));
+ extern long bgetc_(BARGS(_Fc_));
+
+ extern void c0sub_(DOUBLE_COMPLEX *result, CARGS(_Fr_));
+ extern void c0subc_(DOUBLE_COMPLEX *result, CARGS(_Fc_));
+ extern long cget_(CARGS(_Fr_));
+ extern long cgetc_(CARGS(_Fc_));
+
+ extern void d0sub_(DOUBLE_COMPLEX *result, DARGS(_Fr_));
+ extern void d0subc_(DOUBLE_COMPLEX *result, DARGS(_Fc_));
+ extern long dget_(DARGS(_Fr_));
+ extern long dgetc_(DARGS(_Fc_));
+
+ extern void e0sub_(DOUBLE_COMPLEX *result, EARGS(_Fr_));
+ extern void e0subc_(DOUBLE_COMPLEX *result, EARGS(_Fc_));
+ extern long eget_(EARGS(_Fr_));
+ extern long egetc_(EARGS(_Fc_));
+
+ extern void li2sub_(DOUBLE_COMPLEX *result, const double *x);
+ extern void li2csub_(DOUBLE_COMPLEX *result, CDOUBLE_COMPLEX *x);
+
+ extern void ltini_(void);
+ extern void ltexi_(void);
+
+ extern void clearcache_(void);
+ extern void markcache_(void);
+ extern void restorecache_(void);
+
+ extern struct { /* MUST match common block ltvars in lt.h! */
+ DOUBLE_COMPLEX cache[8][2];
+ DOUBLE_COMPLEX savedptr[8];
+ double maxdev;
+ long warndigits, errdigits;
+ long serial, versionkey;
+ long debugkey, debugfrom, debugto;
+ } ltvars_;
+
+ extern struct { /* MUST match common block ltcache in lt.h! */
+ long cmpbits;
+ } ltcache_;
+
+ extern struct { /* MUST match common block ltregul in ff.h! */
+ double mudim, delta, lambda, minmass;
+ } ltregul_;
+
}
+/****************************************************************/
namespace {
#ifdef HAVE_UNISTD_H
int start_redirection(std::string logfilename) {
if ( ! ThePEG::CurrentGenerator::isVoid()
&& ThePEG::CurrentGenerator::current().useStdOut() ) return -1;
// redirect C stdout --- unix specific solution,
// see C FAQ: http://c-faq.com/stdio/undofreopen.html
int fd;
fflush(stdout);
fd = dup(fileno(stdout));
freopen(logfilename.c_str(), "a", stdout);
return fd;
}
void stop_redirection(int fd) {
if ( ! ThePEG::CurrentGenerator::isVoid()
&& ThePEG::CurrentGenerator::current().useStdOut() ) return;
fflush(stdout);
close(fileno(stdout));
dup2(fd, fileno(stdout));
close(fd);
clearerr(stdout);
}
#else
int start_redirection(std::string) {
return -1;
}
void stop_redirection(int) {}
#endif
} // namespace
namespace Herwig {
namespace Looptools {
static int initcount = 0;
- void ffini(std::string logfilename) {
+ void ltini(std::string logfilename) {
assert( initcount >= 0 );
if ( initcount == 0 ) {
int rd = start_redirection(logfilename);
- ffini_();
+ ltini_();
stop_redirection(rd);
}
++initcount;
}
- void ffexi(std::string logfilename) {
+ void ltexi(std::string logfilename) {
assert( initcount > 0 );
--initcount;
if ( initcount == 0 ) {
int rd = start_redirection(logfilename);
- ffexi_();
+ ltexi_();
stop_redirection(rd);
}
}
+
+ double_complex ToComplex(DOUBLE_COMPLEX c) {
+ return double_complex(c.re, c.im);
+ }
+
+ double_complex A0(AARGS(_Cr_))
+ {
+ DOUBLE_COMPLEX result;
+ a0sub_(&result, AARGS(_Frp_));
+ return ToComplex(result);
+ }
+
+ double_complex A0C(AARGS(_Cc_))
+ {
+ DOUBLE_COMPLEX result;
+ a0subc_(&result, AARGS(_Fcp_));
+ return ToComplex(result);
+ }
+
+ double_complex A00(AARGS(_Cr_))
+ {
+ DOUBLE_COMPLEX result;
+ a00sub_(&result, AARGS(_Frp_));
+ return ToComplex(result);
+ }
+
+ double_complex A00C(AARGS(_Cc_))
+ {
+ DOUBLE_COMPLEX result;
+ a00subc_(&result, AARGS(_Fcp_));
+ return ToComplex(result);
+ }
+
+ /****************************************************************/
+
+ long Bget(BARGS(_Cr_))
+ {
+ return bget_(BARGS(_Frp_));
+ }
+
+ long BgetC(BARGS(_Cc_))
+ {
+ return bgetc_(BARGS(_Fcp_));
+ }
+
+ DOUBLE_COMPLEX *Bcache(const long integral)
+ { return &ltvars_.cache[0][integral]; }
+
+ DOUBLE_COMPLEX *BcacheC(const long integral)
+ { return &ltvars_.cache[1][integral]; }
+
+ double_complex Bval(const int i, const long integral)
+ { return ToComplex(Bcache(integral)[i]); }
+
+ double_complex BvalC(const int i, const long integral)
+ { return ToComplex(BcacheC(integral)[i]); }
+
+ double_complex B0i(const int i, BARGS(_Cr_))
+ { return Bval(i, Bget(BARGS(_Id_))); }
+
+ double_complex B0iC(const int i, BARGS(_Cc_))
+ { return BvalC(i, BgetC(BARGS(_Id_))); }
+
+ double_complex B0(BARGS(_Cr_))
+ { return B0i(bb0, BARGS(_Id_)); }
+ double_complex B1(BARGS(_Cr_))
+ { return B0i(bb1, BARGS(_Id_)); }
+ double_complex B00(BARGS(_Cr_))
+ { return B0i(bb00, BARGS(_Id_)); }
+ double_complex B11(BARGS(_Cr_))
+ { return B0i(bb11, BARGS(_Id_)); }
+ double_complex B001(BARGS(_Cr_))
+ { return B0i(bb001, BARGS(_Id_)); }
+ double_complex B111(BARGS(_Cr_))
+ { return B0i(bb111, BARGS(_Id_)); }
+ double_complex DB0(BARGS(_Cr_))
+ { return B0i(dbb0, BARGS(_Id_)); }
+ double_complex DB1(BARGS(_Cr_))
+ { return B0i(dbb1, BARGS(_Id_)); }
+ double_complex DB00(BARGS(_Cr_))
+ { return B0i(dbb00, BARGS(_Id_)); }
+ double_complex DB11(BARGS(_Cr_))
+ { return B0i(dbb11, BARGS(_Id_)); }
+
+ double_complex B0C(BARGS(_Cc_))
+ { return B0iC(bb0, BARGS(_Id_)); }
+ double_complex B1C(BARGS(_Cc_))
+ { return B0iC(bb1, BARGS(_Id_)); }
+ double_complex B00C(BARGS(_Cc_))
+ { return B0iC(bb00, BARGS(_Id_)); }
+ double_complex B11C(BARGS(_Cc_))
+ { return B0iC(bb11, BARGS(_Id_)); }
+ double_complex B001C(BARGS(_Cc_))
+ { return B0iC(bb001, BARGS(_Id_)); }
+ double_complex B111C(BARGS(_Cc_))
+ { return B0iC(bb111, BARGS(_Id_)); }
+ double_complex DB0C(BARGS(_Cc_))
+ { return B0iC(dbb0, BARGS(_Id_)); }
+ double_complex DB1C(BARGS(_Cc_))
+ { return B0iC(dbb1, BARGS(_Id_)); }
+ double_complex DB00C(BARGS(_Cc_))
+ { return B0iC(dbb00, BARGS(_Id_)); }
+ double_complex DB11C(BARGS(_Cc_))
+ { return B0iC(dbb11, BARGS(_Id_)); }
+
+ /****************************************************************/
+
+ double_complex C0(CARGS(_Cr_))
+ {
+ DOUBLE_COMPLEX result;
+ c0sub_(&result, CARGS(_Frp_));
+ return ToComplex(result);
+ }
+
+ double_complex C0C(CARGS(_Cc_))
+ {
+ DOUBLE_COMPLEX result;
+ c0subc_(&result, CARGS(_Fcp_));
+ return ToComplex(result);
+ }
+
+ long Cget(CARGS(_Cr_))
+ {
+ return cget_(CARGS(_Frp_));
+ }
+
+ long CgetC(CARGS(_Cc_))
+ {
+ return cgetc_(CARGS(_Fcp_));
+ }
+
+ DOUBLE_COMPLEX *Ccache(const long integral)
+ { return &ltvars_.cache[2][integral]; }
+
+ DOUBLE_COMPLEX *CcacheC(const long integral)
+ { return &ltvars_.cache[3][integral]; }
+
+ double_complex Cval(const int i, const long integral)
+ { return ToComplex(Ccache(integral)[i]); }
+
+ double_complex CvalC(const int i, const long integral)
+ { return ToComplex(CcacheC(integral)[i]); }
+
+ double_complex C0i(const int i, CARGS(_Cr_))
+ { return Cval(i, Cget(CARGS(_Id_))); }
+
+ double_complex C0iC(const int i, CARGS(_Cc_))
+ { return CvalC(i, CgetC(CARGS(_Id_))); }
+
+ /****************************************************************/
+
+ double_complex D0(DARGS(_Cr_))
+ {
+ DOUBLE_COMPLEX result;
+ d0sub_(&result, DARGS(_Frp_));
+ return ToComplex(result);
+ }
+
+ double_complex D0C(DARGS(_Cc_))
+ {
+ DOUBLE_COMPLEX result;
+ d0subc_(&result, DARGS(_Fcp_));
+ return ToComplex(result);
+ }
+
+ long Dget(DARGS(_Cr_))
+ {
+ return dget_(DARGS(_Frp_));
+ }
+
+ long DgetC(DARGS(_Cc_))
+ {
+ return dgetc_(DARGS(_Fcp_));
+ }
+
+ DOUBLE_COMPLEX *Dcache(const long integral)
+ { return &ltvars_.cache[4][integral]; }
+
+ DOUBLE_COMPLEX *DcacheC(const long integral)
+ { return &ltvars_.cache[5][integral]; }
+
+ double_complex Dval(const int i, const long integral)
+ { return ToComplex(Dcache(integral)[i]); }
+
+ double_complex DvalC(const int i, const long integral)
+ { return ToComplex(DcacheC(integral)[i]); }
+
+ double_complex D0i(const int i, DARGS(_Cr_))
+ { return Dval(i, Dget(DARGS(_Id_))); }
+
+ double_complex D0iC(const int i, DARGS(_Cc_))
+ { return DvalC(i, DgetC(DARGS(_Id_))); }
+
+ /****************************************************************/
+
+ double_complex E0(EARGS(_Cr_))
+ {
+ DOUBLE_COMPLEX result;
+ e0sub_(&result, EARGS(_Frp_));
+ return ToComplex(result);
+ }
+
+ double_complex E0C(EARGS(_Cc_))
+ {
+ DOUBLE_COMPLEX result;
+ e0subc_(&result, EARGS(_Fcp_));
+ return ToComplex(result);
+ }
+
+ long Eget(EARGS(_Cr_))
+ {
+ return eget_(EARGS(_Frp_));
+ }
+
+ long EgetC(EARGS(_Cc_))
+ {
+ return egetc_(EARGS(_Fcp_));
+ }
+
+ DOUBLE_COMPLEX *Ecache(const long integral)
+ { return &ltvars_.cache[6][integral]; }
+
+ DOUBLE_COMPLEX *EcacheC(const long integral)
+ { return &ltvars_.cache[7][integral]; }
+
+ double_complex Eval(const int i, const long integral)
+ { return ToComplex(Ecache(integral)[i]); }
+
+ double_complex EvalC(const int i, const long integral)
+ { return ToComplex(EcacheC(integral)[i]); }
+
+ double_complex E0i(const int i, EARGS(_Cr_))
+ { return Eval(i, Eget(EARGS(_Id_))); }
+
+ double_complex E0iC(const int i, EARGS(_Cc_))
+ { return EvalC(i, EgetC(EARGS(_Id_))); }
+
+ /****************************************************************/
+
+ double_complex Li2(const double x)
+ {
+ DOUBLE_COMPLEX result;
+ li2sub_(&result, _Frp_(x));
+ return ToComplex(result);
+ }
+
+ double_complex Li2C(const double_complex x)
+ {
+ DOUBLE_COMPLEX result;
+ li2csub_(&result, _Fcp_(x));
+ return ToComplex(result);
+ }
+
+ /****************************************************************/
+
+
+ void setmudim(const double mudim)
+ {
+ ltregul_.mudim = mudim;
+ clearcache();
+ }
+
+ double getmudim() { return ltregul_.mudim; }
+
+
+ void setdelta(const double delta)
+ {
+ ltregul_.delta = delta;
+ clearcache();
+ }
+
+ double getdelta() { return ltregul_.delta; }
+
+
+ void setlambda(const double lambda)
+ {
+ ltregul_.lambda = lambda;
+ clearcache();
+ }
+
+ double getlambda() { return ltregul_.lambda; }
+
+
+ void setminmass(const double minmass)
+ {
+ ltregul_.minmass = minmass;
+ clearcache();
+ }
+
+ double getminmass() { return ltregul_.minmass; }
+
+
+ void setmaxdev(const double maxdev)
+ {
+ ltvars_.maxdev = maxdev;
+ }
+
+ double getmaxdev() { return ltvars_.maxdev; }
+
+
+ void setwarndigits(const long warndigits)
+ {
+ ltvars_.warndigits = warndigits;
+ }
+
+ long getwarndigits() { return ltvars_.warndigits; }
+
+
+ void seterrdigits(const long errdigits)
+ {
+ ltvars_.errdigits = errdigits;
+ }
+
+ long geterrdigits() { return ltvars_.errdigits; }
+
+
+ void setversionkey(const long versionkey)
+ {
+ ltvars_.versionkey = versionkey;
+ clearcache();
+ }
+
+ long getversionkey() { return ltvars_.versionkey; }
+
+
+ void setdebugkey(const long debugkey)
+ {
+ ltvars_.debugkey = debugkey;
+ }
+
+ long getdebugkey() { return ltvars_.debugkey; }
+
+
+ void setdebugrange(const long debugfrom, const long debugto)
+ {
+ ltvars_.debugfrom = debugfrom;
+ ltvars_.debugto = debugto;
+ }
+
+
+ void setcmpbits(const long cmpbits)
+ {
+ ltcache_.cmpbits = cmpbits;
+ }
+
+ long getcmpbits() { return ltcache_.cmpbits; }
+
+
+ void clearcache() { clearcache_(); }
+ void markcache() { markcache_(); }
+ void restorecache() { restorecache_(); }
+
} // namespace Looptools
} // namespace Herwig
diff --git a/Looptools/include/cexternals.h b/Looptools/include/cexternals.h
new file mode 100644
--- /dev/null
+++ b/Looptools/include/cexternals.h
@@ -0,0 +1,6 @@
+#if 0
+This file was generated by mkexternalsh on Thu Dec 9 09:13:07 CET 2010.
+Do not edit.
+#endif
+
+#define cachelookup_ ljcachelookup_
diff --git a/Looptools/include/clooptools.h b/Looptools/include/clooptools.h
--- a/Looptools/include/clooptools.h
+++ b/Looptools/include/clooptools.h
@@ -1,459 +1,302 @@
/* -*- C++ -*-
- clooptools.h
- the C/C++ header file with all definitions for LoopTools
- this file is part of LoopTools
- last modified 21 Dec 06 th
- dgrell 2008-01 for Herwig++
+ clooptools.h
+ the C/C++ header file with all definitions for LoopTools
+ this file is part of LoopTools
+ last modified 9 Dec 10 th
+ dgrell 2011-01-21 for Herwig++: moved definitions and extern declarations to our clooptools.cc
*/
#ifndef HERWIG_clooptools_h_
#define HERWIG_clooptools_h_
+//#define cachelookup_ ljcachelookup_
+
/** complex defn for Looptools
*/
struct DOUBLE_COMPLEX {
/**
* Real part
*/
double re;
/**
* Imaginary part
*/
double im;
};
typedef const DOUBLE_COMPLEX CDOUBLE_COMPLEX;
#include <complex>
typedef std::complex<double> double_complex;
/****************************************************************/
-extern "C" {
+#define AARGS(t) t(m)
-extern void a0sub_(DOUBLE_COMPLEX *result, const double *m);
-extern void a00sub_(DOUBLE_COMPLEX *result, const double *m);
+#define BARGS(t) t(p), t(m1), t(m2)
-extern long bget_(const double *p, const double *m1, const double *m2);
+#define CARGS(t) t(p1), t(p2), t(p1p2), t(m1), t(m2), t(m3)
-extern void c0sub_(DOUBLE_COMPLEX *result,
- const double *p1, const double *p2,
- const double *p1p2,
- const double *m1, const double *m2, const double *m3);
-extern long cget_(const double *p1, const double *p2,
- const double *p1p2,
- const double *m1, const double *m2, const double *m3);
+#define DARGS(t) t(p1), t(p2), t(p3), t(p4), t(p1p2), t(p2p3), \
+ t(m1), t(m2), t(m3), t(m4)
-extern void d0sub_(DOUBLE_COMPLEX *result,
- const double *p1, const double *p2,
- const double *p3, const double *p4,
- const double *p1p2, const double *p2p3,
- const double *m1, const double *m2,
- const double *m3, const double *m4);
-extern long dget_(const double *p1, const double *p2,
- const double *p3, const double *p4,
- const double *p1p2, const double *p2p3,
- const double *m1, const double *m2,
- const double *m3, const double *m4);
+#define EARGS(t) t(p1), t(p2), t(p3), t(p4), t(p5), \
+ t(p1p2), t(p2p3), t(p3p4), t(p4p5), t(p5p1), \
+ t(m1), t(m2), t(m3), t(m4), t(m5)
-extern void e0sub_(DOUBLE_COMPLEX *result,
- const double *p1, const double *p2,
- const double *p3, const double *p4, const double *p5,
- const double *p1p2, const double *p2p3,
- const double *p3p4, const double *p4p5,
- const double *p5p1,
- const double *m1, const double *m2,
- const double *m3, const double *m4, const double *m5);
-extern long eget_(const double *p1, const double *p2,
- const double *p3, const double *p4, const double *p5,
- const double *p1p2, const double *p2p3,
- const double *p3p4, const double *p4p5,
- const double *p5p1,
- const double *m1, const double *m2,
- const double *m3, const double *m4, const double *m5);
-
-
-extern void li2sub_(DOUBLE_COMPLEX *result, const double *x);
-extern void li2csub_(DOUBLE_COMPLEX *result, CDOUBLE_COMPLEX *x);
-
-extern void ffini_(void);
-extern void ffexi_(void);
-
-extern void clearcache_(void);
-extern void markcache_(void);
-extern void restorecache_(void);
-
-extern struct { /* MUST match common block ltvars in lt.h! */
- DOUBLE_COMPLEX cache[8][2];
- DOUBLE_COMPLEX savedptr[8];
- double maxdev;
- long serial, warndigits, errdigits, versionkey;
- long debugkey, debugfrom, debugto;
-} ltvars_;
-
-extern struct { /* MUST match common block ffregul in ff.h! */
- double mudim, delta, lambda;
-} ffregul_;
-
-}
+#define _Cr_(v) const double v
+#define _Cc_(v) const double_complex v
+#define _Fr_(v) const double *v
+#define _Fc_(v) CDOUBLE_COMPLEX *v
+#define _Frp_(v) &v
+#define _Fcp_(v) (CDOUBLE_COMPLEX *)&v
+#define _Id_(v) v
/****************************************************************/
namespace Herwig {
namespace Looptools {
- inline double_complex ToComplex(DOUBLE_COMPLEX c) {
- return double_complex(c.re, c.im);
- }
+ enum {
+ bb0, bb1, bb00, bb11, bb001, bb111, dbb0, dbb1, dbb00, dbb11,
+ Nbb
+ };
+
+ enum {
+ cc0, cc1, cc2, cc00, cc11, cc12, cc22, cc001, cc002, cc111, cc112,
+ cc122, cc222, cc0000, cc0011, cc0012, cc0022, cc1111, cc1112, cc1122,
+ cc1222, cc2222,
+ Ncc
+ };
+
+ enum {
+ dd0, dd1, dd2, dd3, dd00, dd11, dd12, dd13, dd22, dd23, dd33,
+ dd001, dd002, dd003, dd111, dd112, dd113, dd122, dd123, dd133, dd222,
+ dd223, dd233, dd333, dd0000, dd0011, dd0012, dd0013, dd0022, dd0023,
+ dd0033, dd1111, dd1112, dd1113, dd1122, dd1123, dd1133, dd1222,
+ dd1223, dd1233, dd1333, dd2222, dd2223, dd2233, dd2333, dd3333,
+ dd00001, dd00002, dd00003, dd00111, dd00112, dd00113, dd00122,
+ dd00123, dd00133, dd00222, dd00223, dd00233, dd00333, dd11111,
+ dd11112, dd11113, dd11122, dd11123, dd11133, dd11222, dd11223,
+ dd11233, dd11333, dd12222, dd12223, dd12233, dd12333, dd13333,
+ dd22222, dd22223, dd22233, dd22333, dd23333, dd33333,
+ Ndd
+ };
+
+ enum {
+ ee0, ee1, ee2, ee3, ee4, ee00, ee11, ee12, ee13, ee14, ee22, ee23,
+ ee24, ee33, ee34, ee44, ee001, ee002, ee003, ee004, ee111, ee112,
+ ee113, ee114, ee122, ee123, ee124, ee133, ee134, ee144, ee222,
+ ee223, ee224, ee233, ee234, ee244, ee333, ee334, ee344, ee444,
+ ee0000, ee0011, ee0012, ee0013, ee0014, ee0022, ee0023, ee0024,
+ ee0033, ee0034, ee0044, ee1111, ee1112, ee1113, ee1114, ee1122,
+ ee1123, ee1124, ee1133, ee1134, ee1144, ee1222, ee1223, ee1224,
+ ee1233, ee1234, ee1244, ee1333, ee1334, ee1344, ee1444, ee2222,
+ ee2223, ee2224, ee2233, ee2234, ee2244, ee2333, ee2334, ee2344,
+ ee2444, ee3333, ee3334, ee3344, ee3444, ee4444,
+ Nee
+ };
+
+ enum {
+ KeyA0 = 1,
+ KeyBget = 1<<2,
+ KeyC0 = 1<<4,
+ KeyD0 = 1<<6,
+ KeyE0 = 1<<8,
+ KeyEget = 1<<10,
+ KeyEgetC = 1<<12,
+ KeyAll = KeyA0 + KeyBget + KeyC0 + KeyD0 + KeyE0 + KeyEget + KeyEgetC
+ };
+
+ enum {
+ DebugB = 1,
+ DebugC = 1<<1,
+ DebugD = 1<<2,
+ DebugE = 1<<3,
+ DebugAll = DebugB + DebugC + DebugD + DebugE
+ };
+
+ double_complex ToComplex(DOUBLE_COMPLEX c);
/**
* Looptools initialisation
*/
- void ffini(std::string logfilename = std::string("Looptools.log"));
+ void ltini(std::string logfilename = std::string("Looptools.log"));
/**
* Looptools termination
*/
- void ffexi(std::string logfilename = std::string("Looptools.log"));
+ void ltexi(std::string logfilename = std::string("Looptools.log"));
-enum {
- bb0, bb1, bb00, bb11, bb001, bb111, dbb0, dbb1, dbb00, dbb11,
- Nbb
-};
-enum {
- cc0, cc1, cc2, cc00, cc11, cc12, cc22, cc001, cc002, cc111, cc112,
- cc122, cc222, cc0000, cc0011, cc0012, cc0022, cc1111, cc1112, cc1122,
- cc1222, cc2222,
- Ncc
-};
+ double_complex A0(AARGS(_Cr_));
+ double_complex A0C(AARGS(_Cc_));
+ double_complex A00(AARGS(_Cr_));
-enum {
- dd0, dd1, dd2, dd3, dd00, dd11, dd12, dd13, dd22, dd23, dd33,
- dd001, dd002, dd003, dd111, dd112, dd113, dd122, dd123, dd133, dd222,
- dd223, dd233, dd333, dd0000, dd0011, dd0012, dd0013, dd0022, dd0023,
- dd0033, dd1111, dd1112, dd1113, dd1122, dd1123, dd1133, dd1222,
- dd1223, dd1233, dd1333, dd2222, dd2223, dd2233, dd2333, dd3333,
- dd00001, dd00002, dd00003, dd00111, dd00112, dd00113, dd00122,
- dd00123, dd00133, dd00222, dd00223, dd00233, dd00333, dd11111,
- dd11112, dd11113, dd11122, dd11123, dd11133, dd11222, dd11223,
- dd11233, dd11333, dd12222, dd12223, dd12233, dd12333, dd13333,
- dd22222, dd22223, dd22233, dd22333, dd23333, dd33333,
- Ndd
-};
+ double_complex A00C(AARGS(_Cc_));
-enum {
- ee0, ee1, ee2, ee3, ee4, ee00, ee11, ee12, ee13, ee14, ee22, ee23,
- ee24, ee33, ee34, ee44, ee001, ee002, ee003, ee004, ee111, ee112,
- ee113, ee114, ee122, ee123, ee124, ee133, ee134, ee144, ee222,
- ee223, ee224, ee233, ee234, ee244, ee333, ee334, ee344, ee444,
- ee0000, ee0011, ee0012, ee0013, ee0014, ee0022, ee0023, ee0024,
- ee0033, ee0034, ee0044, ee1111, ee1112, ee1113, ee1114, ee1122,
- ee1123, ee1124, ee1133, ee1134, ee1144, ee1222, ee1223, ee1224,
- ee1233, ee1234, ee1244, ee1333, ee1334, ee1344, ee1444, ee2222,
- ee2223, ee2224, ee2233, ee2234, ee2244, ee2333, ee2334, ee2344,
- ee2444, ee3333, ee3334, ee3344, ee3444, ee4444,
- Nee
-};
+ /****************************************************************/
-enum {
- KeyA0 = 1,
- KeyBget = 1<<2,
- KeyC0 = 1<<4,
- KeyD0 = 1<<6,
- KeyE0 = 1<<8,
- KeyEget = 1<<10,
- KeyEgetC = 1<<12,
- KeyALL = KeyA0 + KeyBget + KeyC0 + KeyD0 + KeyE0 + KeyEget + KeyEgetC
-};
+ long Bget(BARGS(_Cr_));
+ long BgetC(BARGS(_Cc_));
+ DOUBLE_COMPLEX *Bcache(const long integral);
+ DOUBLE_COMPLEX *BcacheC(const long integral);
-enum {
- DebugB = 1,
- DebugC = 1<<1,
- DebugD = 1<<2,
- DebugE = 1<<3,
- DebugAll = DebugB + DebugC + DebugD + DebugE
-};
+ double_complex Bval(const int i, const long integral);
+ double_complex BvalC(const int i, const long integral);
-inline double_complex A0(const double m)
-{
- DOUBLE_COMPLEX result;
- a0sub_(&result, &m);
- return ToComplex(result);
-}
+ double_complex B0i(const int i, BARGS(_Cr_));
-inline double_complex A00(const double m)
-{
- DOUBLE_COMPLEX result;
- a00sub_(&result, &m);
- return ToComplex(result);
-}
+ double_complex B0iC(const int i, BARGS(_Cc_));
-/****************************************************************/
+ double_complex B0(BARGS(_Cr_));
+ double_complex B1(BARGS(_Cr_));
+ double_complex B00(BARGS(_Cr_));
+ double_complex B11(BARGS(_Cr_));
+ double_complex B001(BARGS(_Cr_));
+ double_complex B111(BARGS(_Cr_));
+ double_complex DB0(BARGS(_Cr_));
+ double_complex DB1(BARGS(_Cr_));
+ double_complex DB00(BARGS(_Cr_));
+ double_complex DB11(BARGS(_Cr_));
-inline long Bget(const double p, const double m1, const double m2)
-{
- return bget_(&p, &m1, &m2);
-}
+ double_complex B0C(BARGS(_Cc_));
+ double_complex B1C(BARGS(_Cc_));
+ double_complex B00C(BARGS(_Cc_));
+ double_complex B11C(BARGS(_Cc_));
+ double_complex B001C(BARGS(_Cc_));
+ double_complex B111C(BARGS(_Cc_));
+ double_complex DB0C(BARGS(_Cc_));
+ double_complex DB1C(BARGS(_Cc_));
+ double_complex DB00C(BARGS(_Cc_));
+ double_complex DB11C(BARGS(_Cc_));
-inline DOUBLE_COMPLEX *Bcache(const long integral)
- { return &ltvars_.cache[0][integral]; }
+ /****************************************************************/
-inline DOUBLE_COMPLEX *BcacheC(const long integral)
- { return &ltvars_.cache[1][integral]; }
+ double_complex C0(CARGS(_Cr_));
-inline double_complex Bval(const long i, const long integral)
- { return ToComplex(Bcache(integral)[i]); }
+ double_complex C0C(CARGS(_Cc_));
-inline double_complex BvalC(const long i, const long integral)
- { return ToComplex(BcacheC(integral)[i]); }
+ long Cget(CARGS(_Cr_));
-inline double_complex B0i(const long i, const double p,
- const double m1, const double m2)
- { return Bval(i, Bget(p, m1, m2)); }
+ long CgetC(CARGS(_Cc_));
-inline double_complex B0(const double p, const double m1, const double m2)
- { return B0i(bb0, p, m1, m2); }
-inline double_complex B1(const double p, const double m1, const double m2)
- { return B0i(bb1, p, m1, m2); }
-inline double_complex B00(const double p, const double m1, const double m2)
- { return B0i(bb00, p, m1, m2); }
-inline double_complex B11(const double p, const double m1, const double m2)
- { return B0i(bb11, p, m1, m2); }
-inline double_complex B001(const double p, const double m1, const double m2)
- { return B0i(bb001, p, m1, m2); }
-inline double_complex B111(const double p, const double m1, const double m2)
- { return B0i(bb111, p, m1, m2); }
-inline double_complex DB0(const double p, const double m1, const double m2)
- { return B0i(dbb0, p, m1, m2); }
-inline double_complex DB1(const double p, const double m1, const double m2)
- { return B0i(dbb1, p, m1, m2); }
-inline double_complex DB00(const double p, const double m1, const double m2)
- { return B0i(dbb00, p, m1, m2); }
-inline double_complex DB11(const double p, const double m1, const double m2)
- { return B0i(dbb11, p, m1, m2); }
+ DOUBLE_COMPLEX *Ccache(const long integral);
-/****************************************************************/
+ DOUBLE_COMPLEX *CcacheC(const long integral);
-inline double_complex C0(const double p1, const double p2,
- const double p1p2,
- const double m1, const double m2, const double m3)
-{
- DOUBLE_COMPLEX result;
- c0sub_(&result, &p1, &p2, &p1p2, &m1, &m2, &m3);
- return ToComplex(result);
-}
+ double_complex Cval(const int i, const long integral);
-inline long Cget(const double p1, const double p2,
- const double p1p2, const double m1,
- const double m2, const double m3)
-{
- return cget_(&p1, &p2, &p1p2, &m1, &m2, &m3);
-}
+ double_complex CvalC(const int i, const long integral);
-inline DOUBLE_COMPLEX *Ccache(const long integral)
- { return &ltvars_.cache[2][integral]; }
+ double_complex C0i(const int i, CARGS(_Cr_));
-inline DOUBLE_COMPLEX *CcacheC(const long integral)
- { return &ltvars_.cache[3][integral]; }
+ double_complex C0iC(const int i, CARGS(_Cc_));
-inline double_complex Cval(const long i, const long integral)
- { return ToComplex(Ccache(integral)[i]); }
+ /****************************************************************/
-inline double_complex CvalC(const long i, const long integral)
- { return ToComplex(CcacheC(integral)[i]); }
+ double_complex D0(DARGS(_Cr_));
-inline double_complex C0i(const long i,
- const double p1, const double p2,
- const double p1p2, const double m1,
- const double m2, const double m3)
- { return Cval(i, Cget(p1, p2, p1p2, m1, m2, m3)); }
+ double_complex D0C(DARGS(_Cc_));
-/****************************************************************/
+ long Dget(DARGS(_Cr_));
-inline double_complex D0(const double p1, const double p2,
- const double p3, const double p4,
- const double p1p2, const double p2p3,
- const double m1, const double m2,
- const double m3, const double m4)
-{
- DOUBLE_COMPLEX result;
- d0sub_(&result, &p1, &p2, &p3, &p4, &p1p2, &p2p3, &m1, &m2, &m3, &m4);
- return ToComplex(result);
-}
+ long DgetC(DARGS(_Cc_));
-inline long Dget(const double p1, const double p2,
- const double p3, const double p4,
- const double p1p2, const double p2p3,
- const double m1, const double m2,
- const double m3, const double m4)
-{
- return dget_(&p1, &p2, &p3, &p4, &p1p2, &p2p3, &m1, &m2, &m3, &m4);
-}
+ DOUBLE_COMPLEX *Dcache(const long integral);
-inline DOUBLE_COMPLEX *Dcache(const long integral)
- { return &ltvars_.cache[4][integral]; }
+ DOUBLE_COMPLEX *DcacheC(const long integral);
-inline DOUBLE_COMPLEX *DcacheC(const long integral)
- { return &ltvars_.cache[5][integral]; }
+ double_complex Dval(const int i, const long integral);
-inline double_complex Dval(const long i, const long integral)
- { return ToComplex(Dcache(integral)[i]); }
+ double_complex DvalC(const int i, const long integral);
-inline double_complex DvalC(const long i, const long integral)
- { return ToComplex(DcacheC(integral)[i]); }
+ double_complex D0i(const int i, DARGS(_Cr_));
-inline double_complex D0i(const long i,
- const double p1, const double p2,
- const double p3, const double p4,
- const double p1p2, const double p2p3,
- const double m1, const double m2,
- const double m3, const double m4)
- { return Dval(i, Dget(p1, p2, p3, p4, p1p2, p2p3, m1, m2, m3, m4)); }
+ double_complex D0iC(const int i, DARGS(_Cc_));
-/****************************************************************/
+ /****************************************************************/
-inline double_complex E0(const double p1, const double p2,
- const double p3, const double p4, const double p5,
- const double p1p2, const double p2p3,
- const double p3p4, const double p4p5,
- const double p5p1,
- const double m1, const double m2,
- const double m3, const double m4, const double m5)
-{
- DOUBLE_COMPLEX result;
- e0sub_(&result, &p1, &p2, &p3, &p4, &p5, &p1p2, &p2p3, &p3p4, &p4p5, &p5p1, &m1, &m2, &m3, &m4, &m5);
- return ToComplex(result);
-}
+ double_complex E0(EARGS(_Cr_));
-inline long Eget(const double p1, const double p2,
- const double p3, const double p4,
- const double p5,
- const double p1p2, const double p2p3,
- const double p3p4, const double p4p5,
- const double p5p1,
- const double m1, const double m2,
- const double m3, const double m4, const double m5)
-{
- return eget_(&p1, &p2, &p3, &p4, &p5, &p1p2, &p2p3, &p3p4, &p4p5, &p5p1, &m1, &m2, &m3, &m4, &m5);
-}
+ double_complex E0C(EARGS(_Cc_));
-inline DOUBLE_COMPLEX *Ecache(const long integral)
- { return &ltvars_.cache[6][integral]; }
+ long Eget(EARGS(_Cr_));
-inline DOUBLE_COMPLEX *EcacheC(const long integral)
- { return &ltvars_.cache[7][integral]; }
+ long EgetC(EARGS(_Cc_));
-inline double_complex Eval(const long i, const long integral)
- { return ToComplex(Ecache(integral)[i]); }
+ DOUBLE_COMPLEX *Ecache(const long integral);
-inline double_complex EvalC(const long i, const long integral)
- { return ToComplex(EcacheC(integral)[i]); }
+ DOUBLE_COMPLEX *EcacheC(const long integral);
-inline double_complex E0i(const long i,
- const double p1, const double p2,
- const double p3, const double p4,
- const double p5,
- const double p1p2, const double p2p3,
- const double p3p4, const double p4p5,
- const double p5p1,
- const double m1, const double m2,
- const double m3, const double m4, const double m5)
-{ return Eval(i, Eget(p1, p2, p3, p4, p5, p1p2, p2p3, p3p4, p4p5, p5p1, m1, m2, m3, m4, m5)); }
+ double_complex Eval(const int i, const long integral);
-/****************************************************************/
+ double_complex EvalC(const int i, const long integral);
-inline double_complex Li2(const double x)
-{
- DOUBLE_COMPLEX result;
- li2sub_(&result, &x);
- return ToComplex(result);
-}
+ double_complex E0i(const int i, EARGS(_Cr_));
-/****************************************************************/
+ double_complex E0iC(const int i, EARGS(_Cc_));
-#define clearcache clearcache_
-#define markcache markcache_
-#define restorecache restorecache_
+ /****************************************************************/
-inline void setmudim(const double mudim)
-{
- ffregul_.mudim = mudim;
- clearcache();
-}
+ double_complex Li2(const double x);
-inline double getmudim() { return ffregul_.mudim; }
+ double_complex Li2C(const double_complex x);
+ /****************************************************************/
-inline void setdelta(const double delta)
-{
- ffregul_.delta = delta;
- clearcache();
-}
-inline double getdelta() { return ffregul_.delta; }
+ void setmudim(const double mudim);
+ double getmudim();
-inline void setlambda(const double lambda)
-{
- ffregul_.lambda = lambda;
- clearcache();
-}
-inline double getlambda() { return ffregul_.lambda; }
+ void setdelta(const double delta);
+ double getdelta();
-inline void setmaxdev(const double maxdev)
-{
- ltvars_.maxdev = maxdev;
-}
-inline double getmaxdev() { return ltvars_.maxdev; }
+ void setlambda(const double lambda);
+ double getlambda();
-inline void setwarndigits(const long warndigits)
-{
- ltvars_.warndigits = warndigits;
-}
+ void setminmass(const double minmass);
+ double getminmass();
-inline long getwarndigits() { return ltvars_.warndigits; }
+ void setmaxdev(const double maxdev);
+ double getmaxdev();
-inline void seterrdigits(const long errdigits)
-{
- ltvars_.errdigits = errdigits;
-}
-inline long geterrdigits() { return ltvars_.errdigits; }
+ void setwarndigits(const long warndigits);
+ long getwarndigits();
-inline void setversionkey(const long versionkey)
-{
- ltvars_.versionkey = versionkey;
- clearcache();
-}
+ void seterrdigits(const long errdigits);
+ long geterrdigits();
-inline long getversionkey() { return ltvars_.versionkey; }
+ void setversionkey(const long versionkey);
+ long getversionkey();
-inline void setdebugkey(const long debugkey)
-{
- ltvars_.debugkey = debugkey;
-}
+ void setdebugkey(const long debugkey);
+ long getdebugkey();
-inline long getdebugkey() { return ltvars_.debugkey; }
+ void setdebugrange(const long debugfrom, const long debugto);
-inline void setdebugrange(const long debugfrom, const long debugto)
-{
- ltvars_.debugfrom = debugfrom;
- ltvars_.debugto = debugto;
-}
+ void setcmpbits(const long cmpbits);
- }
-}
+ long getcmpbits();
+
+ void clearcache();
+ void markcache();
+ void restorecache();
+
+ } // namespace Looptools
+} // namespace Herwig
#endif
diff --git a/Looptools/include/defs.h b/Looptools/include/defs.h
--- a/Looptools/include/defs.h
+++ b/Looptools/include/defs.h
@@ -1,367 +1,379 @@
* defs.h
* internal definitions for the LoopTools routines
* this file is part of LoopTools
-* last modified 13 Apr 06 th
+* last modified 7 Dec 10 th
+
+#include "externals.h"
#ifdef COMPLEXPARA
#define XA0 A0C
#define XA0b A0bC
-#define XA0sub A0subC
+#define XA0sub a0subc
#define XA00 A00C
-#define XA00sub A00subC
+#define XA00sub a00subc
#define XB0 B0C
#define XB1 B1C
#define XB00 B00C
#define XB11 B11C
#define XB001 B001C
#define XB111 B111C
#define XDB0 DB0C
#define XDB1 DB1C
#define XDB00 DB00C
#define XDB11 DB11C
#define XB0i B0iC
#define XBget BgetC
#define XBcoeff BcoeffC
#define XBcoeffa BcoeffaC
#define XC0 C0C
#define XC0i C0iC
#define XCget CgetC
#define XCcoeff CcoeffC
#define XD0 D0C
#define XD0i D0iC
#define XDget DgetC
#define XDcoeff DcoeffC
#define XE0 E0C
-#define XE0sub E0subC
+#define XE0sub e0subc
#define XE0i E0iC
#define XEget EgetC
#define XEcoeff EcoeffC
#define XEcoeffa EcoeffaC
#define XEcoeffb EcoeffbC
#define XEcheck EcheckC
-#define XltEgram ltEgramC
-#define XLUDecomp LUDecompC
-#define XLUBackSubst LUBackSubstC
-#define XDet ltDetC
-#define XInverse ltInverseC
+#define XInvGramE InvGramEC
+#define XSolve SolveC
+#define XEigen EigenC
+#define XDecomp DecompC
+#define XDet DetmC
+#define XInverse InverseC
#define XDumpPara DumpParaC
#define XDumpCoeff DumpCoeffC
#define XLi2 Li2C
-#define XLi2sub Li2Csub
+#define XLi2sub li2csub
#define Xfpij2 cfpij2
#define Xffa0 ffca0
#define Xffb0 ffcb0
#define Xffb1 ffcb1
#define Xffb2p ffcb2p
#define Xffdb0 ffcdb0
#define RC 2
#define DVAR double complex
#define QVAR double complex
#define QREAL double precision
-#define QEXT(x) x
+#define QPREC(x) x
+#define QCC(x) DCONJG(x)
+#define QRE(x) DBLE(x)
#else
#define XA0 A0
#define XA0b A0b
-#define XA0sub A0sub
+#define XA0sub a0sub
#define XA00 A00
-#define XA00sub A00sub
+#define XA00sub a00sub
#define XB0 B0
#define XB1 B1
#define XB00 B00
#define XB11 B11
#define XB001 B001
#define XB111 B111
#define XDB0 DB0
#define XDB1 DB1
#define XDB00 DB00
#define XDB11 DB11
#define XB0i B0i
#define XBget Bget
#define XBcoeff Bcoeff
#define XBcoeffa Bcoeffa
#define XC0 C0
#define XC0i C0i
#define XCget Cget
#define XCcoeff Ccoeff
#define XD0 D0
#define XD0i D0i
#define XDget Dget
#define XDcoeff Dcoeff
#define XE0 E0
-#define XE0sub E0sub
+#define XE0sub e0sub
#define XE0i E0i
#define XEget Eget
#define XEcoeff Ecoeff
#define XEcoeffa Ecoeffa
#define XEcoeffb Ecoeffb
#define XEcheck Echeck
-#define XltEgram ltEgram
-#define XLUDecomp LUDecomp
-#define XLUBackSubst LUBackSubst
-#define XDet ltDet
-#define XInverse ltInverse
+#define XInvGramE InvGramE
+#define XSolve Solve
+#define XEigen Eigen
+#define XDecomp Decomp
+#define XDet Detm
+#define XInverse Inverse
#define XDumpPara DumpPara
#define XDumpCoeff DumpCoeff
#define XLi2 Li2
-#define XLi2sub Li2sub
+#define XLi2sub li2sub
#define Xfpij2 fpij2
#define Xffa0 ffxa0
#define Xffb0 ffxb0
#define Xffb1 ffxb1
#define Xffb2p ffxb2p
#define Xffdb0 ffxdb0
#define RC 1
#define DVAR double precision
-#ifdef QUAD
+#if QUAD
#define QVAR real*16
+#define QPREC(x) QEXT(x)
#else
#define QVAR double precision
-#define QEXT(x) x
+#define QPREC(x) x
#endif
#define QREAL QVAR
+#define QCC(x) x
+#define QRE(x) x
#endif
#define bb0 1
#define bb1 2
#define bb00 3
#define bb11 4
#define bb001 5
#define bb111 6
#define dbb0 7
#define dbb1 8
#define dbb00 9
#define dbb11 10
#define Pbb 3
#define Nbb 10
#define cc0 1
#define cc1 2
#define cc2 3
#define cc00 4
#define cc11 5
#define cc12 6
#define cc22 7
#define cc001 8
#define cc002 9
#define cc111 10
#define cc112 11
#define cc122 12
#define cc222 13
#define cc0000 14
#define cc0011 15
#define cc0012 16
#define cc0022 17
#define cc1111 18
#define cc1112 19
#define cc1122 20
#define cc1222 21
#define cc2222 22
#define Pcc 6
#define Ncc 22
#define dd0 1
#define dd1 2
#define dd2 3
#define dd3 4
#define dd00 5
#define dd11 6
#define dd12 7
#define dd13 8
#define dd22 9
#define dd23 10
#define dd33 11
#define dd001 12
#define dd002 13
#define dd003 14
#define dd111 15
#define dd112 16
#define dd113 17
#define dd122 18
#define dd123 19
#define dd133 20
#define dd222 21
#define dd223 22
#define dd233 23
#define dd333 24
#define dd0000 25
#define dd0011 26
#define dd0012 27
#define dd0013 28
#define dd0022 29
#define dd0023 30
#define dd0033 31
#define dd1111 32
#define dd1112 33
#define dd1113 34
#define dd1122 35
#define dd1123 36
#define dd1133 37
#define dd1222 38
#define dd1223 39
#define dd1233 40
#define dd1333 41
#define dd2222 42
#define dd2223 43
#define dd2233 44
#define dd2333 45
#define dd3333 46
#define dd00001 47
#define dd00002 48
#define dd00003 49
#define dd00111 50
#define dd00112 51
#define dd00113 52
#define dd00122 53
#define dd00123 54
#define dd00133 55
#define dd00222 56
#define dd00223 57
#define dd00233 58
#define dd00333 59
#define dd11111 60
#define dd11112 61
#define dd11113 62
#define dd11122 63
#define dd11123 64
#define dd11133 65
#define dd11222 66
#define dd11223 67
#define dd11233 68
#define dd11333 69
#define dd12222 70
#define dd12223 71
#define dd12233 72
#define dd12333 73
#define dd13333 74
#define dd22222 75
#define dd22223 76
#define dd22233 77
#define dd22333 78
#define dd23333 79
#define dd33333 80
#define Pdd 10
#define Ndd 80
#define ee0 1
#define ee1 2
#define ee2 3
#define ee3 4
#define ee4 5
#define ee00 6
#define ee11 7
#define ee12 8
#define ee13 9
#define ee14 10
#define ee22 11
#define ee23 12
#define ee24 13
#define ee33 14
#define ee34 15
#define ee44 16
#define ee001 17
#define ee002 18
#define ee003 19
#define ee004 20
#define ee111 21
#define ee112 22
#define ee113 23
#define ee114 24
#define ee122 25
#define ee123 26
#define ee124 27
#define ee133 28
#define ee134 29
#define ee144 30
#define ee222 31
#define ee223 32
#define ee224 33
#define ee233 34
#define ee234 35
#define ee244 36
#define ee333 37
#define ee334 38
#define ee344 39
#define ee444 40
#define ee0000 41
#define ee0011 42
#define ee0012 43
#define ee0013 44
#define ee0014 45
#define ee0022 46
#define ee0023 47
#define ee0024 48
#define ee0033 49
#define ee0034 50
#define ee0044 51
#define ee1111 52
#define ee1112 53
#define ee1113 54
#define ee1114 55
#define ee1122 56
#define ee1123 57
#define ee1124 58
#define ee1133 59
#define ee1134 60
#define ee1144 61
#define ee1222 62
#define ee1223 63
#define ee1224 64
#define ee1233 65
#define ee1234 66
#define ee1244 67
#define ee1333 68
#define ee1334 69
#define ee1344 70
#define ee1444 71
#define ee2222 72
#define ee2223 73
#define ee2224 74
#define ee2233 75
#define ee2234 76
#define ee2244 77
#define ee2333 78
#define ee2334 79
#define ee2344 80
#define ee2444 81
#define ee3333 82
#define ee3334 83
#define ee3344 84
#define ee3444 85
#define ee4444 86
#define Pee 15
#define Nee 86
#define KeyA0 0
#define KeyBget 2
#define KeyC0 4
#define KeyD0 6
-#define KeyE0 8
-#define KeyEget 10
-#define KeyEgetC 12
+#define KeyD0C 8
+#define KeyE0 10
+#define KeyEget 12
+#define KeyEgetC 14
#define DebugB 0
#define DebugC 1
#define DebugD 2
#define DebugE 3
#define Bval(id,p) cache(p+id,RC)
#define Cval(id,p) cache(p+id,RC+2)
#define Dval(id,p) cache(p+id,RC+4)
#define Eval(id,p) cache(p+id,RC+6)
#define Nval(n,id,p) cache(p+id,RC+2*n-4)
#define Sgn(i) (1 - 2*iand(i,1))
+#define MAXDIM 8
+
#ifndef KIND
#define KIND 1
#endif
*#define WARNINGS
diff --git a/Looptools/include/externals.h b/Looptools/include/externals.h
new file mode 100644
--- /dev/null
+++ b/Looptools/include/externals.h
@@ -0,0 +1,269 @@
+#if 0
+This file was generated by mkexternalsh on Thu Dec 9 09:13:07 CET 2010.
+Do not edit.
+#endif
+
+#define A0b ljA0b
+#define A0bC ljA0bC
+#define Bcheck ljBcheck
+#define Bcoeff ljBcoeff
+#define BcoeffC ljBcoeffC
+#define Bcoeffa ljBcoeffa
+#define BcoeffaC ljBcoeffaC
+#define Bcoeffb ljBcoeffb
+#define C0coll ljC0coll
+#define C0collDR ljC0collDR
+#define C0p0 ljC0p0
+#define C0p1 ljC0p1
+#define C0p2 ljC0p2
+#define C0p3 ljC0p3
+#define C0soft ljC0soft
+#define C0softDR ljC0softDR
+#define CDispatch ljCDispatch
+#define Ccoeff ljCcoeff
+#define CcoeffC ljCcoeffC
+#define D0coll ljD0coll
+#define D0collDR ljD0collDR
+#define D0m0 ljD0m0
+#define D0m0p0 ljD0m0p0
+#define D0m0p1 ljD0m0p1
+#define D0m0p2 ljD0m0p2
+#define D0m0p3 ljD0m0p3
+#define D0m1 ljD0m1
+#define D0m1p2 ljD0m1p2
+#define D0m1p3 ljD0m1p3
+#define D0m2 ljD0m2
+#define D0m2p3 ljD0m2p3
+#define D0m3 ljD0m3
+#define D0m4 ljD0m4
+#define D0soft ljD0soft
+#define D0softDR ljD0softDR
+#define DDispatch ljDDispatch
+#define Dcoeff ljDcoeff
+#define DcoeffC ljDcoeffC
+#define Decomp ljDecomp
+#define DecompC ljDecompC
+#define Detm ljDetm
+#define DetmC ljDetmC
+#define DumpCoeff ljDumpCoeff
+#define DumpCoeffC ljDumpCoeffC
+#define DumpPara ljDumpPara
+#define DumpParaC ljDumpParaC
+#define E0b ljE0b
+#define Echeck ljEcheck
+#define EcheckC ljEcheckC
+#define Ecoeff ljEcoeff
+#define EcoeffC ljEcoeffC
+#define Ecoeffa ljEcoeffa
+#define EcoeffaC ljEcoeffaC
+#define Ecoeffb ljEcoeffb
+#define EcoeffbC ljEcoeffbC
+#define InvGramE ljInvGramE
+#define InvGramEC ljInvGramEC
+#define Inverse ljInverse
+#define InverseC ljInverseC
+#define Li2omrat ljLi2omrat
+#define Li2omrat2 ljLi2omrat2
+#define Li2omx2 ljLi2omx2
+#define Li2omx3 ljLi2omx3
+#define Li2rat ljLi2rat
+#define Li2series ljLi2series
+#define RSolve ljRSolve
+#define Solve ljSolve
+#define SolveC ljSolveC
+#define bdK ljbdK
+#define cachelookup ljcachelookup
+#define cln ljcln
+#define cspence ljcspence
+#define dfflo1 ljdfflo1
+#define dfflo2 ljdfflo2
+#define dfflo3 ljdfflo3
+#define eta ljeta
+#define etatilde ljetatilde
+#define ff2d22 ljff2d22
+#define ff2dl2 ljff2dl2
+#define ff3dl2 ljff3dl2
+#define ffRn ljffRn
+#define ffS2 ljffS2
+#define ffS2_linr ljffS2_linr
+#define ffS3n ljffS3n
+#define ffT13 ljffT13
+#define ffT_lin ljffT_lin
+#define ffTn ljffTn
+#define ffabcd ljffabcd
+#define ffai ljffai
+#define ffbglg ljffbglg
+#define ffbnd ljffbnd
+#define ffbndc ljffbndc
+#define ffc1lg ljffc1lg
+#define ffca0 ljffca0
+#define ffcayl ljffcayl
+#define ffcb0 ljffcb0
+#define ffcb0p ljffcb0p
+#define ffcb1 ljffcb1
+#define ffcb1a ljffcb1a
+#define ffcb2p ljffcb2p
+#define ffcb2q ljffcb2q
+#define ffcc0 ljffcc0
+#define ffcc0a ljffcc0a
+#define ffcc0b ljffcc0b
+#define ffcc0p ljffcc0p
+#define ffcc0r ljffcc0r
+#define ffccyz ljffccyz
+#define ffcdb0 ljffcdb0
+#define ffcdbp ljffcdbp
+#define ffcdel ljffcdel
+#define ffcdot ljffcdot
+#define ffcdwz ljffcdwz
+#define ffcel2 ljffcel2
+#define ffcel3 ljffcel3
+#define ffchck ljffchck
+#define ffcl2p ljffcl2p
+#define ffcl2t ljffcl2t
+#define ffcl3m ljffcl3m
+#define ffcl3s ljffcl3s
+#define ffclg2 ljffclg2
+#define ffclgy ljffclgy
+#define ffclmb ljffclmb
+#define ffcnst ljffcnst
+#define ffcod3 ljffcod3
+#define ffcoot ljffcoot
+#define ffcot2 ljffcot2
+#define ffcot3 ljffcot3
+#define ffcrr ljffcrr
+#define ffcrt3 ljffcrt3
+#define ffcs3 ljffcs3
+#define ffcs4 ljffcs4
+#define ffcxr ljffcxr
+#define ffcxra ljffcxra
+#define ffcxs3 ljffcxs3
+#define ffcxs4 ljffcxs4
+#define ffcxyz ljffcxyz
+#define ffd0c ljffd0c
+#define ffd0tra ljffd0tra
+#define ffdcc0 ljffdcc0
+#define ffdcrr ljffdcrr
+#define ffdcs ljffdcs
+#define ffdcxr ljffdcxr
+#define ffdcxs ljffdcxs
+#define ffdel ljffdel
+#define ffdel2 ljffdel2
+#define ffdel3 ljffdel3
+#define ffdel4 ljffdel4
+#define ffdel5 ljffdel5
+#define ffdif4 ljffdif4
+#define ffdl2p ljffdl2p
+#define ffdl2s ljffdl2s
+#define ffdl2t ljffdl2t
+#define ffdl3m ljffdl3m
+#define ffdl3p ljffdl3p
+#define ffdl3s ljffdl3s
+#define ffdl4p ljffdl4p
+#define ffdl4r ljffdl4r
+#define ffdot ljffdot
+#define ffdot2 ljffdot2
+#define ffdot3 ljffdot3
+#define ffdot4 ljffdot4
+#define ffdot5 ljffdot5
+#define ffdwz ljffdwz
+#define ffdxc0 ljffdxc0
+#define fferr ljfferr
+#define ffflag ljffflag
+#define ffgdt4 ljffgdt4
+#define ffgeta ljffgeta
+#define ffidel ljffidel
+#define ffieps ljffieps
+#define ffint3 ljffint3
+#define ffpi43 ljffpi43
+#define ffpi54 ljffpi54
+#define ffprec ljffprec
+#define ffpvf ljffpvf
+#define ffroot ljffroot
+#define ffroots ljffroots
+#define ffrot3 ljffrot3
+#define ffrot4 ljffrot4
+#define ffrota ljffrota
+#define ffrt3p ljffrt3p
+#define ffset ljffset
+#define ffsign ljffsign
+#define ffsm43 ljffsm43
+#define ffsmug ljffsmug
+#define fftayl ljfftayl
+#define ffthf ljffthf
+#define ffthre ljffthre
+#define fftran ljfftran
+#define fftraroot ljfftraroot
+#define ffwarn ljffwarn
+#define ffwbeta ljffwbeta
+#define ffx2ir ljffx2ir
+#define ffxa0 ljffxa0
+#define ffxb0 ljffxb0
+#define ffxb0p ljffxb0p
+#define ffxb1 ljffxb1
+#define ffxb111 ljffxb111
+#define ffxb1a ljffxb1a
+#define ffxb2p ljffxb2p
+#define ffxb2q ljffxb2q
+#define ffxc0 ljffxc0
+#define ffxc0a ljffxc0a
+#define ffxc0b ljffxc0b
+#define ffxc0i ljffxc0i
+#define ffxc0j ljffxc0j
+#define ffxc0p ljffxc0p
+#define ffxc0p0 ljffxc0p0
+#define ffxc0r ljffxc0r
+#define ffxclg ljffxclg
+#define ffxd0 ljffxd0
+#define ffxd0a ljffxd0a
+#define ffxd0b ljffxd0b
+#define ffxd0d ljffxd0d
+#define ffxd0e ljffxd0e
+#define ffxd0m0 ljffxd0m0
+#define ffxd0p ljffxd0p
+#define ffxd0r ljffxd0r
+#define ffxdb0 ljffxdb0
+#define ffxdb1 ljffxdb1
+#define ffxdb11 ljffxdb11
+#define ffxdbd ljffxdbd
+#define ffxdbp ljffxdbp
+#define ffxdir ljffxdir
+#define ffxe0 ljffxe0
+#define ffxe00 ljffxe00
+#define ffxe0a ljffxe0a
+#define ffxe0r ljffxe0r
+#define ffxhck ljffxhck
+#define ffxkfn ljffxkfn
+#define ffxl22 ljffxl22
+#define ffxlam ljffxlam
+#define ffxli2 ljffxli2
+#define ffxlmb ljffxlmb
+#define ffxlogx ljffxlogx
+#define ffxtra ljffxtra
+#define ffxxyz ljffxxyz
+#define ffypvf ljffypvf
+#define ffzdbd ljffzdbd
+#define ffzkfn ljffzkfn
+#define ffzli2 ljffzli2
+#define ffzxdl ljffzxdl
+#define ffzzdl ljffzzdl
+#define fpv ljfpv
+#define fth ljfth
+#define ln ljln
+#define lndiv0 ljlndiv0
+#define lndiv1 ljlndiv1
+#define lnrat ljlnrat
+#define ltcoeffnames ljltcoeffnames
+#define ltparanames ljltparanames
+#define nffet1 ljnffet1
+#define nffeta ljnffeta
+#define spence ljspence
+#define xeta ljxeta
+#define xetatilde ljxetatilde
+#define xlogx ljxlogx
+#define xspence ljxspence
+#define yfpv ljyfpv
+#define zfflo1 ljzfflo1
+#define zfflo2 ljzfflo2
+#define zfflo3 ljzfflo3
+#define zfflog ljzfflog
+#define zxfflg ljzxfflg
diff --git a/Looptools/include/ff.h b/Looptools/include/ff.h
--- a/Looptools/include/ff.h
+++ b/Looptools/include/ff.h
@@ -1,179 +1,179 @@
* $Id: ff.h,v 1.1 1995/12/12 10:03:48 gj Exp $
* -------------------------------------------------------------
* INCLUDE FILE FOR THE FF ROUTINES.
* Geert Jan van Oldenborgh.
* -------------------------------------------------------------
* please do not change, and recompile _everything_ when you do.
* -------------------------------------------------------------
*
* this parameter determines how far the scalar npoint functions
* will look back to find the same parameters (when lmem is true)
*
integer memory
parameter (memory = 12)
*
* if .TRUE. then default (ffinit)
* l4also: in C0 (and higher), also consider the algorithm with 16
* dilogs .TRUE.
* ldc3c4: in D0 (and higher), also consider possible cancellations
* between the C0s .TRUE.
* lmem: before computing the C0 and higher, first check whether
* it has already been done recently .FALSE.
* ldot: leave the dotproducts and some determinants in common
* .FALSE.
* onshel: (in ffz?0 only): use onshell momenta .TRUE.
* lsmug: internal use
* lnasty: internal use
*
logical l4also,ldc3c4,lmem,ldot,onshel,lsmug,lnasty
*
* nwidth: number of widths within which the complex mass is used
* nschem: scheme to handle the complex mass (see ffinit.f)
* idot: internal flags to signal that some of the dotproducts
* are input: 0: none; 1: external pi.pj, 2: external +
* kinematical determinant, 3: all dotproducts + kindet.
*
integer nwidth,nschem,idot
*
* xloss: factor that the final result of a subtraction can be
* smaller than the terms without warning (default 1/8)
* precx: precision of real numbers, determined at runtime by
* ffinit (IEEE: 4.e-16)
* precc: same for complex numbers
* xalogm: smallest real number of which a log can be taken,
* determined at runtime by ffinit (IEEE: 2.e-308)
* xclogm: same for complex.
* xalog2: xalogm**2
* xclog2: xclogm**2
* reqprc: not used
* pi: pi
* pi6: pi**2/6
* pi12: pi**2/12
* xlg2: log(2)
* bf: factors in the expansion of dilog (~Bernouilli numbers)
* xninv: 1/n
* xn2inv: 1/n**2
* xinfac: 1/n!
* fpij2: vi.vj for 2point function 1-2: si, 3-3: pi
* fpij3: vi.vj for 3point function 1-3: si, 4-6: pi
* fpij4: vi.vj for 4point function 1-4: si, 5-10: pi
* fpij5: vi.vj for 5point function 1-5: si, 6-15: pi
* fpij6: vi.vj for 6point function 1-6: si, 7-21: pi
* fdel2: del2 = delta_(p1,p2)^(p1,p2) = p1^2.p2^2 - p1.p2^2 in C0
* fdel3: del3 = delta_(p1,p2,p3)^(p1,p2,p3) in D0
* fdel4s: del4s = delta_(s1,s2,s3,s4)^(s1,s2,s3,s4) in D0
* fdel4: del4 = delta_(p1,p2,p3,p4)^(p1,p2,p3,p4) in E0
* fdl3i: del3i = delta_(pj,pk,pl)^(pj,pk,pl) in E0, D0 without si
* fdl4si: dl4si = del4s in E0, D0 without si
* fdl3ij: same in F0 without si and sj.
* fd4sij: dl4si = del4s in E0, D0 without si
* fdl4i: delta4 in F0 without si.
* fodel2: same offshell (in case of complex or z-functions)
* fodel3: -''-
* cfdl4s: -''-
* fodel4: -''-
* fodl3i: -''-
* fod3ij: -''-
* fodl4i: -''-
* fidel3: ier of del3 (is not included in D0)
* fidel4: ier of del4 (is not included in E0)
* fidl3i: ier of dl3i (is not included in E0)
* fid3ij: ier of dl3ij (is not included in F0)
* fidl4i: ier of dl4i (is not included in F0)
*
DOUBLE PRECISION xloss,precx,precc,xalogm,xclogm,xalog2,xclog2,
& reqprc,pi,pi6,pi12,xlg2,bf(20),
& xninv(30),xn2inv(30),xinfac(30),
& fpij2(3,3),fpij3(6,6),fpij4(10,10),fpij5(15,15),
& fpij6(21,21),fdel2,fdel3,fdel4s,fdel4,fdl3i(5),
& fdl4si(5),fdl3ij(6,6),fd4sij(6,6),fdl4i(6),fodel2,
& fodel3,fodel4,fodl3i(5),fod3ij(6,6),fodl4i(6)
integer fidel3,fidel4,fidl3i(5),fid3ij(6,6),fidl4i(6)
*
* cI: imaginary unit
* c[zero1]:0,1 complex
* c2ipi: 2*i*pi
* cipi2: i*pi**2
* cfp..: complex version of fp..., only defined in ff[cz]*
* cmipj: (internal only) mi^2 - pj^2 in C0
* c2sisj: (internal only) 2*si.sj in D0
* cfdl4s: del4s in complex case (D0)
* ca1: (internal only) complex A1
* csdl2p: (internal only) complex transformed sqrt(del2)
*
DOUBLE COMPLEX cI,czero,chalf,cone,c2ipi,cipi2,
& cfpij2(3,3),cfpij3(6,6),cfpij4(10,10),cfpij5(15,15),
& cfpij6(21,21),cmipj(3,3),c2sisj(4,4),cfdl4s,ca1
*
* nevent: number in integration loop (to be updated by user)
* ner: can be used to signal numerical problems (see ffrcvr)
* id: identifier of scalar function (to be set by user)
* idsub: internal identifier to pinpoint errors
* inx: in D0: p(inx(i,j)) = isgn(i,j)*(s(i)-s(j))
* inx5: in E0: p(inx5(i,j)) = isgn5(i,j)*(s(i)-s(j))
* inx6: in F0: p(inx6(i,j)) = isgn6(i,j)*(s(i)-s(j))
* isgn: see inx
* isgn5: see inx5
* isgn6: see inx6
* iold: rotation matrix for 4point function
* isgrot: signs to iold
* isgn34: +1 or -1: which root to choose in the transformation (D0)
* isgnal: +1 or -1: which root to choose in the alpha-trick (C0)
* irota3: save the number of positions the C0 configuration has been
* rotated over
* irota4: same for the D0
* irota5: same for the E0
* irota6: same for the F0
*
integer nevent,ner,id,idsub,inx(4,4),isgn(4,4),inx5(5,5),
& isgn5(5,5),inx6(6,6),isgn6(6,6),isgn34,isgnal,iold(13,
& 12),isgrot(10,12),irota3,irota4,irota5,irota6
integer idum93(2)
*
DOUBLE PRECISION acc, eps
*
* parameters
*
parameter(
& cI = (0D0, 1D0),
& czero = (0D0,0D0),
& chalf = (.5D0,0D0),
& cone = (1D0,0D0),
& c2ipi = (0D0,6.28318530717958647692528676655896D0),
& cipi2 = (0D0,9.869604401089358618834490999876D0),
& pi = 3.14159265358979323846264338327948D0,
& pi6 = 1.644934066848226436472415166646D0,
& pi12 = .822467033424113218236207583323D0,
& xlg2 = .6931471805599453094172321214581D0,
& acc = 1D-12,
& eps = 1D-25 )
*
* common
*
common /ffsign/isgn34,isgnal
common /ffprec/ xloss,precx,precc,xalogm,xclogm,xalog2,xclog2,
& reqprc
common /ffflag/ l4also,ldc3c4,lmem,ldot,
& nevent,ner,id,idsub,nwidth,nschem,onshel,idot
common /ffcnst/ bf,xninv,xn2inv,xinfac,inx,isgn,iold,isgrot,
& inx5,isgn5,inx6,isgn6
common /ffrota/ irota3,irota4,irota5,irota6
common /ffdot/ fpij2,fpij3,fpij4,fpij5,fpij6
common /ffdel/ fdel2,fdel3,fdel4s,fdel4,fdl3i,fdl4si,fdl3ij,
& fd4sij,fdl4i
common /ffidel/ fidel3,fidel4,fidl3i,fid3ij,fidl4i
common /ffcdot/ cfpij2,cfpij3,cfpij4,cfpij5,cfpij6
common /ffcdel/ fodel2,fodel3,cfdl4s,fodel4,fodl3i,fod3ij,fodl4i
common /ffsmug/ lsmug,lnasty,idum93,cmipj,c2sisj,ca1
*
* regularization parameters
*
- DOUBLE PRECISION mudim,delta,lambda
- common /ffregul/ mudim,delta,lambda
+ DOUBLE PRECISION mudim,delta,lambda,minmass
+ common /ltregul/ mudim,delta,lambda,minmass
*
* nan is used for undefined values and is supposed to
* "poison" a result, much as the IEEE NaN, which is just
* too unportable in Fortran
*
DOUBLE COMPLEX nan
parameter (nan = (1D123, 1D123))
diff --git a/Looptools/include/fferr.h b/Looptools/include/fferr.h
--- a/Looptools/include/fferr.h
+++ b/Looptools/include/fferr.h
@@ -1,286 +1,303 @@
character*80 e1
parameter (e1="ffca0: minimum value complex logarit"//
+ "hm gives problem, change mu.")
character*80 e2
parameter (e2="ffxa0: minimum value real logarithm "//
+ "gives problem, change mu.")
character*80 e3
parameter (e3="ffcb0: minimum value complex logarit"//
+ "hm gives problem, change mu.")
character*80 e4
parameter (e4="ffxb0: minimum value real logarithm "//
+ "gives problem, change mu.")
character*80 e5
parameter (e5="ffcb0p: cannot handle complex k^2 yet")
character*80 e6
parameter (e6="ffcb0p: minimum value complex log giv"//
+ "es problem in unequal masses.")
character*80 e7
parameter (e7="ffxb0p: divergence for k->0, m1=m2=0.")
character*80 e8
parameter (e8="ffxb0p: minimum value real log gives "//
+ "problem in equal masses.")
character*80 e9
parameter (e9="ffxb0p: minimum value real log gives "//
+ "problem in unequal masses.")
character*80 e10
parameter (e10="ffcc0p: cannot handle two spacelike m"//
+ "omenta and one zero.")
character*80 e11
parameter (e11="ffxc0p: cannot handle two spacelike m"//
+ "omenta and one zero.")
character*80 e12
parameter (e12="ffcs3: illegal code for isoort(1) (s"//
+ "hould not occur)")
character*80 e13
parameter (e13="ffcs3: illegal code for isoort(2) (s"//
+ "hould not occur)")
character*80 e14
parameter (e14="ffcs3: imaginary part wrong, will be"//
+ " improved later")
character*80 e15
parameter (e15="ffcs3: isoort = -1,0 not yet ready")
character*80 e16
parameter (e16="ffcs3: illegal combination in isoort"//
+ " (should not occur)")
character*80 e17
parameter (e17="ffcxs3: illegal code for isoort(1) (s"//
+ "hould not occur)")
character*80 e18
parameter (e18="ffcxs3: illegal code for isoort(2) (s"//
+ "hould not occur)")
character*80 e19
parameter (e19="ffcs4: imaginary part is wrong (shou"//
+ "ld be updated)")
character*80 e20
parameter (e20="ffdcrr: Taylor expansion in 1/x not y"//
+ "et ready")
character*80 e21
parameter (e21="ffdcxr: imaginary part is wrong")
character*80 e22
parameter (e22="ffdcxr: Taylor expansion in 1/x not y"//
+ "et ready")
character*80 e23
parameter (e23="ffcrr: minimum value complex log cau"//
+ "ses correction term to be wrong.")
character*80 e24
parameter (e24="ffcxr: minimum value real log causes"//
+ " correction term to be wrong.")
character*80 e25
parameter (e25="ffcrr: illegal code for iclas1 (shou"//
+ "ld not occur)")
character*80 e26
parameter (e26="ffcxr: illegal code for iclas1 (shou"//
+ "ld not occur)")
character*80 e27
parameter (e27="ffcrr: illegal code for iclas2 (shou"//
+ "ld not occur)")
character*80 e28
parameter (e28="ffcxr: illegal code for iclas2 (shou"//
+ "ld not occur)")
character*80 e29
parameter (e29="ffxli2: argument too large (should no"//
+ "t occur)")
character*80 e30
parameter (e30="ffzli2: argument too large (should no"//
+ "t occur)")
character*80 e31
parameter (e31="ffzzdl: imaginary part dilog is undef"//
+ "ined for real x > 1.")
character*80 e32
parameter (e32="nffeta: eta is not defined for real n"//
+ "egative numbers a,b, ab.")
character*80 e33
parameter (e33="nffet1: eta is not defined for real n"//
+ "egative numbers a,b, ab.")
character*80 e34
parameter (e34="ffcota: illegal flag (should not occu"//
+ "r)")
character*80 e35
parameter (e35="ffrota: illegal flag (should not occu"//
+ "r)")
character*80 e36
parameter (e36="ffccyz: I took the wrong value for ca"//
+ "lpha... (should not occur)")
character*80 e37
parameter (e37="ffxxyz: I took the wrong value for al"//
+ "pha... (should not occur)")
character*80 e38
parameter (e38="ffcoot: a=0, trying to find two roots"//
+ " of a linear equation ...")
character*80 e39
parameter (e39="ffroot: a=0, trying to find two roots"//
+ " of a linear equation ...")
character*80 e40
parameter (e40="ffrot3: all three external masses zer"//
+ "o !")
character*80 e41
parameter (e41="ffxc0: lambda(p1,p2,p3) < 0, unphysi"//
+ "cal configuration")
character*80 e42
parameter (e42="ffxc0: cannot handle this case (p1,p"//
+ "2,p3 dependent, on threshold)")
character*80 e43
parameter (e43="ffcxs3: illegal code for isoort(1) (s"//
+ "hould not occur)")
character*80 e44
parameter (e44="ffxd0: lambda(p1,p2,p3,p4) < 0, unph"//
+ "ysical configuration")
character*80 e45
parameter (e45="ffxd0: cannot handle this case (p1,p"//
+ "2,p3 dependent, on threshold)")
character*80 e46
parameter (e46="ffxd0p: correction terms for Ai <0 in"//
+ "finite (mass zero?)")
character*80 e47
parameter (e47="ffcxyz: p_i^2 = 0 (should not occur)")
character*80 e48
parameter (e48="ffeta: answer not consistent with no"//
+ "rmal result (old)")
character*80 e49
parameter (e49="ffcc0: cannot handle complex externa"//
+ "l momenta or im > 0")
character*80 e50
parameter (e50="ffcd0: cannot handle complex externa"//
+ "l momenta.")
character*80 e51
parameter (e51="zfflog: imaginary part undefined for "//
+ "real z < 0.")
character*80 e52
parameter (e52="zxfflg: imaginary part undefined for "//
+ "x < 0.")
character*80 e53
parameter (e53="ffcs3: eta changes within (0,1), add"//
+ " sophisticated terms...")
character*80 e54
parameter (e54="ffrot4: cannot find any physical vert"//
+ "ex to apply transformation.")
character*80 e55
parameter (e55="fftra0: too many vectors parallel, p_"//
+ "1.p_7 or p_2.p_7 is zero.")
character*80 e56
parameter (e56="zfflog: tiny imaginary part in confli"//
+ "ct with ieps prescription.")
character*80 e57
parameter (e57="ffxe0: lambda(p1,p2,p3,p4,p5) < 0, u"//
+ "nphysical")
character*80 e58
parameter (e58="ffxc0j: IR divergent C0 with lambda(p"//
+ "1,p2,p3)=0.")
character*80 e59
parameter (e59="ffxc0i: IR divergent C0 with lambda2=0.")
character*80 e60
parameter (e60="ffxc0j: IR divergent C0 obtained from"//
+ " D0 is singular. Contact author.")
character*80 e61
parameter (e61="ffxd0p: IR divergent D0 with lambda2=0.")
character*80 e62
parameter (e62="ffxc0p: I never expected complex root"//
+ "s in an IR divergent diagram.")
character*80 e63
parameter (e63="ffxd0p: can only handle one IR diverg"//
+ "ence per 3point function")
character*80 e64
parameter (e64="ffxd0p: cannot handle a threshold in"//
+ " (3,4), rotated wrongly.")
character*80 e65
parameter (e65="ffcxr: IR divergence but iclass!=3. "//
+ " should not occur.")
character*80 e66
parameter (e66="ffcxs3: different imaginary signs sho"//
+ "uld not occur for ipole=3.")
character*80 e67
parameter (e67="ffxdbd: I cannot use this algorithm f"//
+ "or a linear IR divergence")
character*80 e68
parameter (e68="ffxd0: cannot find a proj. transform"//
+ "ation; try another permutation.")
character*80 e69
parameter (e69="ff5ind: could not find independent mo"//
+ "menta (should not occur).")
character*80 e70
parameter (e70="ffxdna: lambda(pi,pj,pk) < 0, unphysi"//
+ "cal configuration")
character*80 e71
parameter (e71="ffxdna: cannot handle lambda(pi,pj,pk"//
+ ") = 0, dependent momenta.")
character*80 e72
parameter (e72="ffxd0e: could not find a stable root;"//
+ " please try another permutation")
character*80 e73
parameter (e73="ffxdir: cannot handle a linearly dive"//
+ "rgent four point function (yet)")
character*80 e74
parameter (e74="ffxdbd: IR divergent B0' without cuto"//
+ "ff in /ffregul/")
character*80 e75
parameter (e75="ffdcxr: dyz=0, should not occur")
character*80 e76
parameter (e76="ffdcrr: cdwz=0, but iepsz!=iepsz and "//
+ "significant")
character*80 e77
parameter (e77="ffdcrr: cdyz=0, should not occur")
character*80 e78
parameter (e78="ffdcc0: imaginary part wrong")
character*80 e79
parameter (e79="ffdcs: cannot handle isoort=0")
character*80 e80
parameter (e80="ffdcs: mixed up iep's, 2*pi^2 wrong "//
+ "somewhere")
character*80 e81
parameter (e81="ffdcs: wrong value for isoort")
character*80 e82
parameter (e82="ffdxc0: imaginary part Ai < 0 terms unc"//
+ "ertain")
character*80 e83
parameter (e83="ffxc0j: sorry, complex roots not yet "//
+ "supported here")
character*80 e84
parameter (e84="ffxc0p: imaginary part Ai < 0 terms unc"//
+ "ertain")
character*80 e85
parameter (e85="ffxd0a: t3 = t4, don''t know what to do")
character*80 e86
parameter (e86="ffxdbp: cannot compute derivative, la"//
+ "m=0")
character*80 e87
parameter (e87="ffxdi: dependent momenta not yet sup"//
+ "ported (boundary of phase space)")
character*80 e88
parameter (e88="ffxxyz: xk = 0 not yet implemented")
character*80 e92
parameter (e92="ffxc1: cannot invert matrix with zer"//
+ "o determinant.")
character*80 e93
parameter (e93="ffze0: Im(m^2) > 0")
character*80 e94
parameter (e94="ffze0: Im(p^2) != 0")
character*80 e95
parameter (e95="ffzf0: Im(m^2) > 0")
character*80 e96
parameter (e96="ffzf0: Im(p^2) != 0")
character*80 e97
- parameter (e97="ffxc0j: ill-defined IR-divergent C0 f"//
- + "or massless charged particles.")
+ parameter (e97="ffxc0j: ill-defined IR-divergent C0 "//
+ + "for massless charged particles.")
character*80 e98
- parameter (e98="ffxdbd: ill-defined IR-divergent D0 f"//
- + "or massless charged particles.")
+ parameter (e98="ffxdbd: ill-defined IR-divergent D0 "//
+ + "for massless charged particles.")
character*80 e100
parameter (e100="ffrcvr: probably underflow, I do"//
+ " not know where or how severe.")
character*80 e101
parameter (e101="ffxdb1: case not defined")
character*80 e102
parameter (e102="ffxdb11: case not defined")
- character*80 error(102)
+ character*80 e103
+ parameter (e103="ffd0c: cannot handle this case")
+ character*80 e104
+ parameter (e104="ffwbeta: prefactor 1/(SV-TU) = 1/0 "//
+ + "for all y")
+ character*80 e105
+ parameter (e105="ffT_lin: prefactor 1/(SV-TU) = 1/0 "//
+ + "for all y")
+ character*80 e99
+ parameter (e99="ffT13: prefactor 1/(SV-TU) = 1/0 "//
+ + "for all y")
+ character*80 e89
+ parameter (e89="ffS2: log(0) singularity")
+ character*80 e90
+ parameter (e90="ffS3n: end-point singularity")
+ character*80 e91
+ parameter (e91="ffS3n: log(0) singularity")
+ character*80 error(105)
data error / e1,e2,e3,e4,e5,e6,e7,e8,e9,
+ e10,e11,e12,e13,e14,e15,e16,e17,e18,e19,
+ e20,e21,e22,e23,e24,e25,e26,e27,e28,e29,
+ e30,e31,e32,e33,e34,e35,e36,e37,e38,e39,
+ e40,e41,e42,e43,e44,e45,e46,e47,e48,e49,
+ e50,e51,e52,e53,e54,e55,e56,e57,e58,e59,
+ e60,e61,e62,e63,e64,e65,e66,e67,e68,e69,
+ e70,e71,e72,e73,e74,e75,e76,e77,e78,e79,
- + e80,e81,e82,e83,e84,e85,e86,e87,e88," ",
- + " "," ",e92,e93,e94,e95,e96,e97,e98," ",
- + e100,e101,e102 /
+ + e80,e81,e82,e83,e84,e85,e86,e87,e88,e89,
+ + e90,e91,e92,e93,e94,e95,e96,e97,e98,e99,
+ + e100,e101,e102,e103,e104,e105 /
diff --git a/Looptools/include/ffwarn.h b/Looptools/include/ffwarn.h
--- a/Looptools/include/ffwarn.h
+++ b/Looptools/include/ffwarn.h
@@ -1,754 +1,770 @@
character*80 w1
parameter (w1="ffcb0p: warning: instability in case one mas"//
+ "s zero, may be solved later.")
character*80 w2
parameter (w2="ffcb0p: warning: not enough terms in Taylor "//
+ "expansion ma=mb. May be serious!")
character*80 w3
parameter (w3="ffcb0p: warning: minimum value complex logar"//
+ "ithm gives problem in equal masses.")
character*80 w4
parameter (w4="ffcb0p: warning: cancellations in equal mass"//
+ "es (should not occur).")
character*80 w5
parameter (w5="ffcb0p: warning: not enough terms in expansi"//
+ "on1 k2 zero. May be serious!")
character*80 w6
parameter (w6="ffcb0p: warning: not enough terms in expansi"//
+ "on2 k2 zero, May be serious!")
character*80 w7
parameter (w7="ffcb0p: warning: cancellations in final addi"//
+ "ng up, contact author if serious.")
character*80 w8
parameter (w8="ffc1lg: warning: the combination 1-z*log(1-1"//
+ "/z) id unstable.")
character*80 w9
parameter (w9="ffcayl: warning: not enough terms in Taylor "//
+ "expansion, may be serious.")
character*80 w10
parameter (w10="ffcb0p: warning: cancellation in dotproduct "//
+ "s1.s2")
character*80 w11
parameter (w11="ffcot2: warning: cancellation in dotproduct "//
+ "p.si ")
character*80 w12
parameter (w12="ffcdbp: warning: not enough terms in Taylor "//
+ "expansion, may be serious")
character*80 w13
parameter (w13="ffcdbp: warning: cancellations in case one m"//
+ "ass equal to zero")
character*80 w14
parameter (w14="ffxb0p: warning: instability in case one mas"//
+ "s zero, may be solved later.")
character*80 w15
parameter (w15="ffxb0p: warning: not enough terms in Taylor "//
+ "expansion ma=mb. May be serious!")
character*80 w16
parameter (w16="ffxb0p: warning: minimum value real logarith"//
+ "m gives problem in equal masses.")
character*80 w17
parameter (w17="ffxb0p: warning: cancellations in equal mass"//
+ "es (should not occur).")
character*80 w18
parameter (w18="ffxb0p: warning: cancellations in equal mass"//
+ "es, complex roots, can be avoided.")
character*80 w19
parameter (w19="ffxb0p: warning: not enough terms in expansi"//
+ "on1 k2 zero, may be serious!")
character*80 w20
parameter (w20="ffxb0p: warning: not enough terms in expansi"//
+ "on2 k2 zero, may be serious!")
character*80 w21
parameter (w21="ffxb0p: warning: cancellations between s2 an"//
+ "d alpha, should not be serious")
character*80 w22
parameter (w22="ffd1lg: warning: the combination 1-z*log(1-1"//
+ "/z) id unstable.")
character*80 w23
parameter (w23="ffxb0p: warning: cancellations in lambda equ"//
+ "al masses.")
character*80 w24
parameter (w24="ffxb0p: warning: cancellation in dotproduct "//
+ "s1.s2")
character*80 w25
parameter (w25="ffdot2: warning: cancellation in dotproduct "//
+ "p.si")
character*80 w26
parameter (w26="ffcc0: warning: cancellation between the tw"//
+ "o twopoint functions.")
character*80 w27
parameter (w27="ffcc0: warning: cancellation in final summi"//
+ "ng up.")
character*80 w28
parameter (w28="ffxc0: warning: cancellation between the tw"//
+ "o twopoint functions.")
character*80 w29
parameter (w29="ffxc0: warning: cancellation in final summi"//
+ "ng up.")
character*80 w30
parameter (w30="ffcc0p: warning: numerical problems in cw(j+"//
+ "2,1), not used")
character*80 w31
parameter (w31="ffcc0p: warning: cancellations in cdwz(j,i,1"//
+ "), not used")
character*80 w32
parameter (w32="ffcc0p: warning: numerical problems in cw(j+"//
+ "2,3), not used")
character*80 w33
parameter (w33="ffcc0p: warning: cancellations in cdwz(j,i,3"//
+ "), not used")
character*80 w34
parameter (w34="ffxc0p: warning: numerical problems in w(j+2"//
+ ",1), not used")
character*80 w35
parameter (w35="ffxc0p: warning: cancellations in dwz(j,i,1)"//
+ ", not used")
character*80 w36
parameter (w36="ffxc0p: warning: numerical problems in cw(j+"//
+ "2,1), not used")
character*80 w37
parameter (w37="ffxc0p: warning: cancellations in cdwz(j,i,1"//
+ "), not used")
character*80 w38
parameter (w38="ffxc0p: warning: numerical problems in w(j+2"//
+ ",3), not used")
character*80 w39
parameter (w39="ffxc0p: warning: cancellations in dwz(j,i,3)"//
+ ", not used")
character*80 w40
parameter (w40="ffxc0p: warning: numerical problems in cw(j+"//
+ "2,3), not used")
character*80 w41
parameter (w41="ffxc0p: warning: cancellations in cdwz(j,i,3"//
+ "), not used")
character*80 w42
parameter (w42="ffcs3: warning: problems with range complex"//
+ " numbers")
character*80 w43
parameter (w43="ffcs3: warning: cancellations in czz1 in sp"//
+ "ecial case")
character*80 w44
parameter (w44="ffcxs3: warning: cancellations in zz1 in spe"//
+ "cial case")
character*80 w45
parameter (w45="ffdcrr: warning: not enough terms in Taylor "//
+ "series (may be serious)")
character*80 w46
parameter (w46="ffdcxr: warning: not enough terms in Taylor "//
+ "series (may be serious)")
character*80 w47
parameter (w47="ffcrr: warning: problems with dynamical ran"//
+ "ge complex numbers")
character*80 w48
parameter (w48="ffcrr: warning: y0 = y1, so R has been take"//
+ "n zero")
character*80 w49
parameter (w49="ffcrr: warning: very large correction terms.")
character*80 w50
parameter (w50="ffcrr: warning: minimum value complex log c"//
+ "auses loss of precision.")
character*80 w51
parameter (w51="ffcxr: warning: y0 = y1, so R has been take"//
+ "n zero")
character*80 w52
parameter (w52="ffcxr: warning: very large correction terms.")
character*80 w53
parameter (w53="ffcxr: warning: minimum value real log caus"//
+ "es loss of precision.")
character*80 w54
parameter (w54="ffcrr: warning: not enough terms in Taylor "//
+ "series (may be serious)")
character*80 w55
parameter (w55="ffcxr: warning: not enough terms in Taylor "//
+ "series (may be serious)")
character*80 w56
parameter (w56="ffcrr: warning: cancellations in cd2yzz + c"//
+ "zz")
character*80 w57
parameter (w57="ffcrr: warning: cancellations in cd2yzz - c"//
+ "zz1")
character*80 w58
parameter (w58="ffcxr: warning: cancellations in d2yzz + zz")
character*80 w59
parameter (w59="ffcxr: warning: cancellations in d2yzz - zz1")
character*80 w60
parameter (w60="ffxli2: warning: not enough terms in expansi"//
+ "on (may be serious)")
character*80 w61
parameter (w61="ffzli2: warning: not enough terms in expansi"//
+ "on (may be serious)")
character*80 w62
parameter (w62="dfflo1: warning: not enough terms in expansi"//
+ "on. calling log.")
character*80 w63
parameter (w63="zfflo1: warning: not enough terms in expansi"//
+ "on. calling log.")
character*80 w64
parameter (w64="ffzxdl: warning: minimum value real log give"//
+ "s problems.")
character*80 w65
parameter (w65="ffzzdl: warning: minimum value complex log g"//
+ "ives problems.")
character*80 w66
parameter (w66="ffzxdl: warning: not enough terms in expansi"//
+ "on (may be serious)")
character*80 w67
parameter (w67="ffzzdl: warning: not enough terms in expansi"//
+ "on (may be serious)")
character*80 w68
parameter (w68="ffclmb: warning: cancellation in calculation"//
+ " lambda.")
character*80 w69
parameter (w69="ffxlmb: warning: cancellation in calculation"//
+ " lambda.")
character*80 w70
parameter (w70="ffcel2: warning: cancellation in calculation"//
+ " delta_{pi pj}^{pi pj}")
character*80 w71
parameter (w71="ffdel2: warning: cancellation in calculation"//
+ " delta_{pi pj}^{pi pj}")
character*80 w72
parameter (w72="ffcel3: warning: cancellation in calculation"//
+ " delta_{s1 s2 s3}^{s1 s2 s3}")
character*80 w73
parameter (w73="ffdel3: warning: cancellation in calculation"//
+ " delta_{s1 s2 s3}^{s1 s2 s3}")
character*80 w74
parameter (w74="ffcl3m: warning: cancellation in (delta_{sj"//
+ " sk}^{si mu})^2")
character*80 w75
parameter (w75="ffdl3m: warning: cancellation in (delta_{sj"//
+ " sk}^{si mu})^2")
character*80 w76
parameter (w76="ffeta: warning: still cancellations. (not u"//
+ "sed)")
character*80 w77
parameter (w77="ffceta: warning: still cancellations. (not u"//
+ "sed)")
character*80 w78
parameter (w78="ffcdwz: warning: still cancelations in cw3pm"//
+ " - cz3mp (not used)")
character*80 w79
parameter (w79="ffdwz: warning: still cancelations in w3pm "//
+ "- z3mp (not used)")
character*80 w80
parameter (w80="ffdcxr: warning: minimum value real log caus"//
+ "es problems.")
character*80 w81
parameter (w81="ffdcxr: warning: ieps <> iepsz, imaginary pa"//
+ "rt will be wrong")
character*80 w82
parameter (w82="ffdcrr: warning: minimum value complex log c"//
+ "auses problems.")
character*80 w83
parameter (w83="ffdl2s: warning: cancellations in delta_{s1'"//
+ "s2'}^{s1 s2}")
character*80 w84
parameter (w84="ffxd0: warning: cancellation in final summi"//
+ "ng up.")
character*80 w85
parameter (w85="ffdl3s: warning: cancellation in calculation"//
+ " delta^(si sj sk)_(sl sm sn)")
character*80 w86
parameter (w86="ffcc0: warning: cancellations among input p"//
+ "arameters")
character*80 w87
parameter (w87="ffxc0: warning: cancellations among input p"//
+ "arameters (import difference)")
character*80 w88
parameter (w88="ffabcd: warning: cancellations in (2*s3.s4^2"//
+ " - s3^2*s4^2), try with del2")
character*80 w89
parameter (w89="ffabcd: warning: cancellations in somb")
character*80 w90
parameter (w90="ffabcd: warning: cancellations in d")
character*80 w91
parameter (w91="ffabcd: warning: xc not yet accurate (can be"//
+ " improved)")
character*80 w92
parameter (w92="ffdl2p: warning: cancellations in delta_{p1"//
+ " s2}^{p1 p2}")
character*80 w93
parameter (w93="ffdl2t: warning: cancellations in delta_{p1"//
+ " s4}^{s3 s4}")
character*80 w94
parameter (w94="ffcb0: warning: cancellations between cma a"//
+ "nd cmb (add input parameters)")
character*80 w95
parameter (w95="ffcb0: warning: cancellations between ck an"//
+ "d cma (add input parameters)")
character*80 w96
parameter (w96="ffcb0: warning: cancellations between ck an"//
+ "d cmb (add input parameters)")
character*80 w97
parameter (w97="ffxb0: warning: cancellations between xma a"//
+ "nd xmb (add input parameters)")
character*80 w98
parameter (w98="ffxb0: warning: cancellations between xk an"//
+ "d xma (add input parameters)")
character*80 w99
parameter (w99="ffxb0: warning: cancellations between xk an"//
+ "d xmb (add input parameters)")
character*80 w100
parameter (w100="ffdot3: warning: cancellations in dotproduct"//
+ " s_i.s_{i+1}")
character*80 w101
parameter (w101="ffdot3: warning: cancellations in dotproduct"//
+ " p_i.s_i")
character*80 w102
parameter (w102="ffdot3: warning: cancellations in dotproduct"//
+ " p_i.s_{i+1}")
character*80 w103
parameter (w103="ffdot3: warning: cancellations in dotproduct"//
+ " p_i.s_{i+2}")
character*80 w104
parameter (w104="ffdot3: warning: cancellations in dotproduct"//
+ " p_i.p_{i+1}")
character*80 w105
parameter (w105="ffdot4: warning: cancellations in dotproduct"//
+ " s_i.s_{i+1}")
character*80 w106
parameter (w106="ffdot4: warning: cancellations in dotproduct"//
+ " s_i.s_{i-1}")
character*80 w107
parameter (w107="ffdot4: warning: cancellations in dotproduct"//
+ " p_i.s_i")
character*80 w108
parameter (w108="ffdot4: warning: cancellations in dotproduct"//
+ " p_i.s_{i+1}")
character*80 w109
parameter (w109="ffdot4: warning: cancellations in dotproduct"//
+ " p_{i-1}.s_i")
character*80 w110
parameter (w110="ffdot4: warning: cancellations in dotproduct"//
+ " p_i.s_{i+2}")
character*80 w111
parameter (w111="ffdot4: warning: cancellations in dotproduct"//
+ " p_{i+1}.s_i")
character*80 w112
parameter (w112="ffdot4: warning: cancellations in dotproduct"//
+ " p_{i+2}.s_{i+1}")
character*80 w113
parameter (w113="ffdot4: warning: cancellations in dotproduct"//
+ " p_i.p_{i+1}")
character*80 w114
parameter (w114="ffdot4: warning: cancellations in dotproduct"//
+ " p_{i+1}.p_{i+2}")
character*80 w115
parameter (w115="ffdot4: warning: cancellations in dotproduct"//
+ " p_{i+2}.p_i")
character*80 w116
parameter (w116="ffdot4: warning: cancellations in dotproduct"//
+ " p_5.p_7")
character*80 w117
parameter (w117="ffdot4: warning: cancellations in dotproduct"//
+ " p_6.p_8")
character*80 w118
parameter (w118="ffdot4: warning: cancellations in dotproduct"//
+ " p_9.p_10")
character*80 w119
parameter (w119="ffxd0: warning: sum is close to the minimum"//
+ " of the range.")
character*80 w120
parameter (w120="ffxc0: warning: sum is close to the minimum"//
+ " of the range.")
character*80 w121
parameter (w121="ffxd0: warning: cancellations among input p"//
+ "arameters (import difference)")
character*80 w122
parameter (w122="ff2d22: warning: cancellations (delta_{sjsk"//
+ "}_{si mu} delta_{smsn}^{mu nu})^2")
character*80 w123
parameter (w123="ff2dl2: warning: cancellations delta^{si mu"//
+ "}_{sj sk} delta^{mu sl}_{sm sn}")
character*80 w124
parameter (w124="ff3dl2: warning: cancellations d^{i mu}_{jl"//
+ "} d^{mu nu}_{lm} d^{nu n}_{op}")
character*80 w125
parameter (w125="fftran: warning: cancellations in s'_i^2 - s"//
+ "'_j^2")
character*80 w126
parameter (w126="fftran: warning: cancellations in p'_i^2 - s"//
+ "'_j^2")
character*80 w127
parameter (w127="fftran: warning: cancellations in p'_i^2 - p"//
+ "'_j^2")
character*80 w128
parameter (w128="zfflog: warning: taking log of number close "//
+ "to 1, must be cured.")
character*80 w129
parameter (w129="zxfflg: warning: taking log of number close "//
+ "to 1, must be cured.")
character*80 w130
parameter (w130="ffcrr: warning: cancellations in calculatin"//
+ "g 2y-1-z...")
character*80 w131
parameter (w131="ffxtra: warning: cancellations in extra term"//
+ "s, working on it")
character*80 w132
parameter (w132="dfflo1: warning: cancellations because of wr"//
+ "ong call, should not occur")
character*80 w133
parameter (w133="zfflo1: warning: cancellations because of wr"//
+ "ong call, should not occur")
character*80 w134
parameter (w134="ffcs4: warning: cancellations in cd2yzz + c"//
+ "zz")
character*80 w135
parameter (w135="ffcd0: warning: cancellations among input p"//
+ "arameters (import difference)")
character*80 w136
parameter (w136="ffcd0: warning: cancellation in final summi"//
+ "ng up.")
character*80 w137
parameter (w137="ffcd0: warning: sum is close to the minimum"//
+ " of the range.")
character*80 w138
parameter (w138="ffdl3p: warning: cancellations in delta_{p1"//
+ " p2 p3}^{p1 p2 p3}")
character*80 w139
parameter (w139="ffxd0p: warning: problems calculating sqrt(d"//
+ "elta(si,s3)) - sqrt(delta(si,s4))")
character*80 w140
parameter (w140="ffdxc0: warning: problems calculating yzzy ="//
+ " y(4)z(3) - y(3)z(4)")
character*80 w141
parameter (w141="ffcd0p: warning: problems calculating sqrt(d"//
+ "elta(si,s3)) - sqrt(delta(si,s4))")
character*80 w142
parameter (w142="ffdcc0: warning: problems calculating yzzy ="//
+ " y(4)z(3) - y(3)z(4)")
character*80 w143
parameter (w143="ffdel4: warning: cancellation in calculation"//
+ " delta_{s1 s2 s3 s4}^{s1 s2 s3 s4}")
character*80 w144
parameter (w144="fftran: warning: cancellation in calculation"//
+ " s_i'.p_{jk}'")
character*80 w145
parameter (w145="fftran: warning: cancellation in calculation"//
+ " p_{ji}'.p_{lk}'")
character*80 w146
parameter (w146="fftran: warning: cancellation in calculation"//
+ " Ai - Aj")
character*80 w147
parameter (w147="ffdxc0: warning: problems calculating yyzz ="//
+ " y(4) - y(3) - z(3) + z(4)")
character*80 w148
parameter (w148="ffdxc0: warning: problems calculating cancel"//
+ "lations extra terms")
character*80 w149
parameter (w149="ffcb0: warning: cancellations between Delta"//
+ ", B0' and log(m1*m2/mu^2)/2")
character*80 w150
parameter (w150="ffxb0: warning: cancellations between Delta"//
+ ", B0' and log(m1*m2/mu^2)/2")
character*80 w151
parameter (w151="ffzli2: warning: real part complex dilog ver"//
+ "y small and not stable")
character*80 w152
parameter (w152="ffxxyz: warning: cancellations in y - 2*z (w"//
+ "ill be solved)")
character*80 w153
parameter (w153="ffxd0: warning: cancellation in u=+p5^2+p6^"//
+ "2+p7^2+p8^2-p9^2-p10^2, import it!")
character*80 w154
parameter (w154="ffxd0: warning: cancellation in v=-p5^2+p6^"//
+ "2-p7^2+p8^2+p9^2+p10^2, import it!")
character*80 w155
parameter (w155="ffxd0: warning: cancellation in w=+p5^2-p6^"//
+ "2+p7^2-p8^2+p9^2+p10^2, import it!")
character*80 w156
parameter (w156="ffxc0i: warning: cancellations in dotproduct"//
+ " p_i.s_j")
character*80 w157
parameter (w157="ffxc0i: warning: cancellations in final summ"//
+ "ing up")
character*80 w158
parameter (w158="ffxe0: warning: cancellations among input p"//
+ "arameters (import difference)")
character*80 w159
parameter (w159="ffdl4p: warning: cancellations in delta_{p1"//
+ " p2 p3 p4}^{p1 p2 p3 p4}")
character*80 w160
parameter (w160="ffdel5: warning: cancellation in calculation"//
+ " delta_{s1s2s3s4s5}^{s1s2s3s4s5}")
character*80 w161
parameter (w161="ffxe0a: warning: cancellation in final summi"//
+ "ng up.")
character*80 w162
parameter (w162="ffxe0a: warning: sum is close to the minimum"//
+ " of the range.")
character*80 w163
parameter (w163="ffxc1: warning: cancellations in cc1.")
character*80 w164
parameter (w164="ffxd1: warning: cancellations in cd1.")
character*80 w165
parameter (w165="ffdl2i: warning: cancellations in delta_{p1"//
+ " p2}^{p3 p4}")
character*80 w166
parameter (w166="ffdl3q: warning: cancellations in delta_{p5"//
+ " p6 p7}^{p(i1) p(i2) p(i3)}")
character*80 w167
parameter (w167="ffxb1: warning: cancellations in cb1.")
character*80 w168
parameter (w168="ffxe0: warning: cancellations in (p_i+p_{i+"//
+ "2})^2 (may not be serious)")
character*80 w169
parameter (w169="ffdl4r: warning: cancellations in delta_{p1"//
+ " p2 p3 p4}^{s1 s2 s3 s4}")
character*80 w170
parameter (w170="ffdl4s: warning: cancellations in delta_{p1"//
+ "p2p3p4}^{si pj pk pl}, to be improved")
character*80 w171
parameter (w171="ffxe1: warning: cancellations in ce1")
character*80 w172
parameter (w172="ffceta: warning: cancellations in extra term"//
+ "s for 4point function")
character*80 w173
parameter (w173="ffceta: warning: cancellations between alpha"//
+ " and w-")
character*80 w174
parameter (w174="ffceta: warning: cancellations between alpha"//
+ " and w+")
character*80 w175
parameter (w175="ffceta: warning: cancellations between a and"//
+ " z")
character*80 w176
parameter (w176="ffceta: warning: cancellations between a and"//
+ " y")
character*80 w177
parameter (w177="ffcdbd: warning: cancellations in summing up")
character*80 w178
parameter (w178="ffkfun: warning: cancellations between z and"//
+ " (m-mp)^2")
character*80 w179
parameter (w179="ffkfun: warning: 4*m*mp/(z-(m-mp)^2) ~ 1, ca"//
+ "n be solved")
character*80 w180
parameter (w180="ffxc0p: warning: delta^{s1,s2,s3}_{s1,s2,s3"//
+ "} not stable, can be solved.")
character*80 w181
parameter (w181="ffxc0p: warning: cancellations in complex di"//
+ "scriminant, can be solved")
character*80 w182
parameter (w182="ffcd0e: warning: still cancellations in del4"//
+ " with only complex in poles")
character*80 w183
parameter (w183="ffcc0a: warning: cannot deal properly with t"//
+ "hreshold of this type")
character*80 w184
parameter (w184="ffcran: warning: cancellations in s'(i).p'(k"//
+ "j)")
character*80 w185
parameter (w185="ffcran: warning: cancellations in p'(ji).p'("//
+ "lk)")
character*80 w186
parameter (w186="ffcd0p: warning: cancellations in cel2")
character*80 w187
parameter (w187="ffdel6: warning: cancellations in coefficien"//
+ "t F0, can be improved")
character*80 w188
parameter (w188="ffdl5r: warning: cancellations in coefficien"//
+ "t E0, can be improved")
character*80 w189
parameter (w189="ffxdi: warning: cancellations in cd2del")
character*80 w190
parameter (w190="ffxdi: warning: cancellations in cd2pp")
character*80 w191
parameter (w191="ffxf0a: warning: cancellations in F0 as sum "//
+ "of 6 E0's - near threshold?")
character*80 w192
parameter (w192="ffxf0a: warning: sum is close to minimum of "//
+ "range")
character*80 w193
parameter (w193="ffxf0: warning: cancellations among input p"//
+ "arameters (import difference)")
character*80 w194
parameter (w194="ffxdbd: warning: cancellations in summing up")
character*80 w195
parameter (w195="ffdot6: warning: cancellations in dotproduct"//
+ " s_i.s_{i+1}")
character*80 w196
parameter (w196="ffdot6: warning: cancellations in dotproduct"//
+ " s_i.s_{i-1}")
character*80 w197
parameter (w197="ffdot6: warning: cancellations in dotproduct"//
+ " p_i.s_i")
character*80 w198
parameter (w198="ffdot6: warning: cancellations in dotproduct"//
+ " p_i.s_{i+1}")
character*80 w199
parameter (w199="ffdot6: warning: cancellations in dotproduct"//
+ " p_{i-1}.s_i")
character*80 w200
parameter (w200="ffdot6: warning: cancellations in dotproduct"//
+ " p_i.s_{i+2}")
character*80 w201
parameter (w201="ffdot6: warning: cancellations in dotproduct"//
+ " p_{i+1}.s_i")
character*80 w202
parameter (w202="ffdot6: warning: cancellations in dotproduct"//
+ " p_{i+2}.s_{i+1}")
character*80 w203
parameter (w203="ffdot6: warning: cancellations in dotproduct"//
+ " p_i.p_{i+1}")
character*80 w204
parameter (w204="ffdot6: warning: cancellations in dotproduct"//
+ " p_{i+1}.p_{i+2}")
character*80 w205
parameter (w205="ffdot6: warning: cancellations in dotproduct"//
+ " p_{i+2}.p_i")
character*80 w206
parameter (w206="ffdot6: warning: cancellations in dotproduct"//
+ " p_{i+2}.s_{i+2}")
character*80 w207
parameter (w207="ffdot6: warning: cancellations in dotproduct"//
+ " s_i.s{i+3}")
character*80 w208
parameter (w208="ffdot6: warning: cancellations in dotproduct"//
+ " pi.pj")
character*80 w209
parameter (w209="ffxdna: warning: cancellations in 1+/-a, une"//
+ "xpected...")
character*80 w210
parameter (w210="ffxdna: warning: cancellations in b-a, unexp"//
+ "ected...")
character*80 w211
parameter (w211="ffcd0c: warning: cancellations in subtractio"//
+ "n of IR pole (to be expected)")
character*80 w212
parameter (w212="ffcd0c: warning: cancellations in computatio"//
+ "n prop1 for threshold")
character*80 w213
parameter (w213="ffcd0c: warning: cancellations in computatio"//
+ "n prop2 for threshold")
character*80 w214
parameter (w214="ffxb2a: warning: cancellations in B2d")
character*80 w215
parameter (w215="ffxd0p: warning: cancellations in complex de"//
+ "l3mi")
character*80 w216
parameter (w216="ffzcnp: warning: cancellations in y (can be "//
+ "fixed, contact author)")
character*80 w217
parameter (w217="ffzdnp: warning: cancellations in delta^(pi "//
+ "si+1)_(pi pi+1)")
character*80 w218
parameter (w218="ffzdnp: warning: cancellations in (delta^(m"//
+ "u si+1)_(pi pi+1))^2")
character*80 w219
parameter (w219="ffzcnp: warning: cancellations in z (can be "//
+ "fixed, contact author)")
character*80 w220
parameter (w220="ffxb1: warning: not enough terms in Taylor "//
+ "expansion, may be serious")
character*80 w221
parameter (w221="ffxdb0: warning: cancellations in computatio"//
+ "n 'diff'")
character*80 w222
parameter (w222="ffxdb0: warning: still cancellations is spli"//
+ "t-up 1")
character*80 w223
parameter (w223="ffxdb0: warning: still cancellations is s1")
character*80 w224
parameter (w224="ffxdb0: warning: cancellations in B0', compl"//
+ "ex args (can be improved)")
character*80 w225
parameter (w225="ffxb2p: warning: cancellations in B21 (after"//
+ " a lot of effort)")
character*80 w226
parameter (w226="ffxb2p: warning: cancellations in B22")
character*80 w227
parameter (w227="ffxb2a: warning: cancellations in B21")
character*80 w228
parameter (w228="ffxbdp: warning: cancellations in case p^2=0")
character*80 w229
parameter (w229="ffxdpv: warning: cancellations in going from"//
+ " delta- to PV-scheme")
character*80 w230
parameter (w230="ffxl22: warning: not enough terms in Taylor "//
+ "expansion Li2(2-x)")
character*80 w231
parameter (w231="dfflo2: warning: not enough terms in taylor "//
+ "expansion, using log(1-x)+x")
character*80 w232
parameter (w232="dfflo3: warning: not enough terms in taylor "//
+ "expansion, using log(1-x)+x+x^2/2")
character*80 w233
parameter (w233="ffcdbp: warning: cancellations in equal mass"//
+ "es case")
character*80 w234
parameter (w234="ffcbdp: warning: cancellations in case p^2=0")
character*80 w235
parameter (w235="ffcbdp: warning: cancellations in small diff.")
character*80 w236
parameter (w236="ffcbdp: warning: cancellations in 1-alpha")
character*80 w237
parameter (w237="ffcbdp: warning: cancellations in s2-alpha, "//
+ "may not be serious")
character*80 w238
parameter (w238="ffcbdp: warning: not enough terms in Taylor "//
+ "expansion, may be serious")
character*80 w239
parameter (w239="ffcbdp: warning: cancellations in s1-(1-alph"//
+ "a), may not be serious")
character*80 w240
parameter (w240="ffcbdp: warning: cancellations in final resu"//
+ "lt")
character*80 w241
parameter (w241="ffxe2: warning: cancellations in E2 (can ma"//
+ "ybe be done better)")
character*80 w242
parameter (w242="ffxe3: warning: cancellations in E3 (can ma"//
+ "ybe be done better)")
character*80 w243
parameter (w243="ffxe3: warning: cancellations in adding det"//
+ "erminants (may not be serious)")
character*80 w244
parameter (w244="ffcdna: warning: cancellations in del45")
character*80 w245
parameter (w245="ffcdna: warning: cancellations in del543m")
character*80 w246
parameter (w246="ffcdna: warning: cancellations in B")
character*80 w247
parameter (w247="ffcdna: warning: cancellations in C")
character*80 w248
parameter (w248="ffcdna: warning: cancellations between z1 an"//
+ "d alpha")
character*80 w249
parameter (w249="ffcdna: warning: cancellations between z2 an"//
+ "d alpha")
character*80 w250
parameter (w250="ffcdna: warning: cancellations in 1 + r*x1 ")
character*80 w251
parameter (w251="ffcdna: warning: cancellations in 1 + r*x2")
character*80 w252
parameter (w252="ffcdna: warning: cancellations between r*x1 "//
+ "and r*x2")
- character*80 warn(252)
+ character*80 w253
+ parameter (w253="ffd0c: warning: something wrong with the "//
+ + "rotation")
+ character*80 w254
+ parameter (w254="ffTn: warning: numerical cancellation "//
+ + "in in-triangle check")
+ character*80 w255
+ parameter (w255="ffRn: warning: 3-point Landau singularity")
+ character*80 w256
+ parameter (w256="ffRn: warning: Im(a.b) in the 1st theta "//
+ + "function is zero")
+ character*80 w257
+ parameter (w257="ffRn: warning: Im(a.b) in the 2nd theta "//
+ + "function is zero")
+ character*80 w258
+ parameter (w258="ffint3: cannot handle complex x yet")
+ character*80 warn(258)
data warn / w1,w2,w3,w4,w5,w6,w7,w8,w9,
+ w10,w11,w12,w13,w14,w15,w16,w17,w18,w19,
+ w20,w21,w22,w23,w24,w25,w26,w27,w28,w29,
+ w30,w31,w32,w33,w34,w35,w36,w37,w38,w39,
+ w40,w41,w42,w43,w44,w45,w46,w47,w48,w49,
+ w50,w51,w52,w53,w54,w55,w56,w57,w58,w59,
+ w60,w61,w62,w63,w64,w65,w66,w67,w68,w69,
+ w70,w71,w72,w73,w74,w75,w76,w77,w78,w79,
+ w80,w81,w82,w83,w84,w85,w86,w87,w88,w89,
+ w90,w91,w92,w93,w94,w95,w96,w97,w98,w99,
+ w100,w101,w102,w103,w104,w105,w106,w107,w108,w109,
+ w110,w111,w112,w113,w114,w115,w116,w117,w118,w119,
+ w120,w121,w122,w123,w124,w125,w126,w127,w128,w129,
+ w130,w131,w132,w133,w134,w135,w136,w137,w138,w139,
+ w140,w141,w142,w143,w144,w145,w146,w147,w148,w149,
+ w150,w151,w152,w153,w154,w155,w156,w157,w158,w159,
+ w160,w161,w162,w163,w164,w165,w166,w167,w168,w169,
+ w170,w171,w172,w173,w174,w175,w176,w177,w178,w179,
+ w180,w181,w182,w183,w184,w185,w186,w187,w188,w189,
+ w190,w191,w192,w193,w194,w195,w196,w197,w198,w199,
+ w200,w201,w202,w203,w204,w205,w206,w207,w208,w209,
+ w210,w211,w212,w213,w214,w215,w216,w217,w218,w219,
+ w220,w221,w222,w223,w224,w225,w226,w227,w228,w229,
+ w230,w231,w232,w233,w234,w235,w236,w237,w238,w239,
+ w240,w241,w242,w243,w244,w245,w246,w247,w248,w249,
- + w250,w251,w252 /
+ + w250,w251,w252,w253,w254,w255,w256,w257,w258 /
diff --git a/Looptools/include/ftypes.h b/Looptools/include/ftypes.h
--- a/Looptools/include/ftypes.h
+++ b/Looptools/include/ftypes.h
@@ -1,37 +1,35 @@
-#ifndef ftypes_h__
-#define ftypes_h__
+#ifndef FTYPES_H
+#define FTYPES_H
-#if UNDERSCORE
#define FORTRAN(s) s##_
-#else
-#define FORTRAN(s) s
-#endif
typedef int INTEGER;
typedef const INTEGER CINTEGER;
typedef double DOUBLE_PRECISION;
typedef const DOUBLE_PRECISION CDOUBLE_PRECISION;
typedef struct { DOUBLE_PRECISION re, im; } DOUBLE_COMPLEX;
typedef const DOUBLE_COMPLEX CDOUBLE_COMPLEX;
+typedef char CHARACTER;
+typedef const CHARACTER CCHARACTER;
#ifdef __cplusplus
#include <complex>
typedef std::complex<double> double_complex;
#define ToComplex(c) double_complex(c.re, c.im)
#define ToComplex2(r,i) double_complex(r, i)
-#define Re(x) x.real()
-#define Im(x) x.imag()
+#define Re(x) std::real(x)
+#define Im(x) std::imag(x)
#else
typedef DOUBLE_COMPLEX double_complex;
#define ToComplex(c) c
#define ToComplex2(r,i) (double_complex){r, i}
-#define Re(x) x.re
-#define Im(x) x.im
+#define Re(x) (x).re
+#define Im(x) (x).im
#endif
#endif
diff --git a/Looptools/include/looptools.h b/Looptools/include/looptools.h
--- a/Looptools/include/looptools.h
+++ b/Looptools/include/looptools.h
@@ -1,273 +1,277 @@
* looptools.h
* the header file for Fortran with all definitions for LoopTools
* this file is part of LoopTools
-* last modified 13 Apr 06 th
+* last modified 6 Jul 10 th
-#ifndef LOOPTOOLS_H__
-#define LOOPTOOLS_H__
+#ifndef LOOPTOOLS_H
+#define LOOPTOOLS_H
#define bb0 1
#define bb1 2
#define bb00 3
#define bb11 4
#define bb001 5
#define bb111 6
#define dbb0 7
#define dbb1 8
#define dbb00 9
#define dbb11 10
#define cc0 1
#define cc1 2
#define cc2 3
#define cc00 4
#define cc11 5
#define cc12 6
#define cc22 7
#define cc001 8
#define cc002 9
#define cc111 10
#define cc112 11
#define cc122 12
#define cc222 13
#define cc0000 14
#define cc0011 15
#define cc0012 16
#define cc0022 17
#define cc1111 18
#define cc1112 19
#define cc1122 20
#define cc1222 21
#define cc2222 22
#define dd0 1
#define dd1 2
#define dd2 3
#define dd3 4
#define dd00 5
#define dd11 6
#define dd12 7
#define dd13 8
#define dd22 9
#define dd23 10
#define dd33 11
#define dd001 12
#define dd002 13
#define dd003 14
#define dd111 15
#define dd112 16
#define dd113 17
#define dd122 18
#define dd123 19
#define dd133 20
#define dd222 21
#define dd223 22
#define dd233 23
#define dd333 24
#define dd0000 25
#define dd0011 26
#define dd0012 27
#define dd0013 28
#define dd0022 29
#define dd0023 30
#define dd0033 31
#define dd1111 32
#define dd1112 33
#define dd1113 34
#define dd1122 35
#define dd1123 36
#define dd1133 37
#define dd1222 38
#define dd1223 39
#define dd1233 40
#define dd1333 41
#define dd2222 42
#define dd2223 43
#define dd2233 44
#define dd2333 45
#define dd3333 46
#define dd00001 47
#define dd00002 48
#define dd00003 49
#define dd00111 50
#define dd00112 51
#define dd00113 52
#define dd00122 53
#define dd00123 54
#define dd00133 55
#define dd00222 56
#define dd00223 57
#define dd00233 58
#define dd00333 59
#define dd11111 60
#define dd11112 61
#define dd11113 62
#define dd11122 63
#define dd11123 64
#define dd11133 65
#define dd11222 66
#define dd11223 67
#define dd11233 68
#define dd11333 69
#define dd12222 70
#define dd12223 71
#define dd12233 72
#define dd12333 73
#define dd13333 74
#define dd22222 75
#define dd22223 76
#define dd22233 77
#define dd22333 78
#define dd23333 79
#define dd33333 80
#define ee0 1
#define ee1 2
#define ee2 3
#define ee3 4
#define ee4 5
#define ee00 6
#define ee11 7
#define ee12 8
#define ee13 9
#define ee14 10
#define ee22 11
#define ee23 12
#define ee24 13
#define ee33 14
#define ee34 15
#define ee44 16
#define ee001 17
#define ee002 18
#define ee003 19
#define ee004 20
#define ee111 21
#define ee112 22
#define ee113 23
#define ee114 24
#define ee122 25
#define ee123 26
#define ee124 27
#define ee133 28
#define ee134 29
#define ee144 30
#define ee222 31
#define ee223 32
#define ee224 33
#define ee233 34
#define ee234 35
#define ee244 36
#define ee333 37
#define ee334 38
#define ee344 39
#define ee444 40
#define ee0000 41
#define ee0011 42
#define ee0012 43
#define ee0013 44
#define ee0014 45
#define ee0022 46
#define ee0023 47
#define ee0024 48
#define ee0033 49
#define ee0034 50
#define ee0044 51
#define ee1111 52
#define ee1112 53
#define ee1113 54
#define ee1114 55
#define ee1122 56
#define ee1123 57
#define ee1124 58
#define ee1133 59
#define ee1134 60
#define ee1144 61
#define ee1222 62
#define ee1223 63
#define ee1224 64
#define ee1233 65
#define ee1234 66
#define ee1244 67
#define ee1333 68
#define ee1334 69
#define ee1344 70
#define ee1444 71
#define ee2222 72
#define ee2223 73
#define ee2224 74
#define ee2233 75
#define ee2234 76
#define ee2244 77
#define ee2333 78
#define ee2334 79
#define ee2344 80
#define ee2444 81
#define ee3333 82
#define ee3334 83
#define ee3344 84
#define ee3444 85
#define ee4444 86
#define KeyA0 2**0
#define KeyBget 2**2
#define KeyC0 2**4
#define KeyD0 2**6
-#define KeyE0 2**8
-#define KeyEget 2**10
-#define KeyCEget 2**12
-#define KeyAll 5461
+#define KeyD0C 2**8
+#define KeyE0 2**10
+#define KeyEget 2**12
+#define KeyEgetC 2**14
+#define KeyAll 21845
#define DebugB 2**0
#define DebugC 2**1
#define DebugD 2**2
#define DebugE 2**3
#define DebugAll 15
#define Bval(id,p) cache(p+id,1)
#define BvalC(id,p) cache(p+id,2)
#define Cval(id,p) cache(p+id,3)
#define CvalC(id,p) cache(p+id,4)
#define Dval(id,p) cache(p+id,5)
#define DvalC(id,p) cache(p+id,6)
#define Eval(id,p) cache(p+id,7)
#define EvalC(id,p) cache(p+id,8)
#define Ccache 0
#define Dcache 0
#endif
- double complex cache(2,8)
+ integer ncaches
+ parameter (ncaches = 8)
+
+ double complex cache(2,ncaches)
common /ltvars/ cache
double complex A0, A0C, B0i, B0iC
double complex B0, B1, B00, B11, B001, B111
double complex B0C, B1C, B00C, B11C, B001C, B111C
double complex DB0, DB1, DB00, DB11
double complex DB0C, DB1C, DB00C, DB11C
double complex C0, C0C, C0i, C0iC
double complex D0, D0C, D0i, D0iC
double complex E0, E0C, E0i, E0iC
double complex Li2, Li2C
integer Bget, BgetC, Cget, CgetC, Dget, DgetC, Eget, EgetC
double precision getmudim, getdelta, getlambda, getmaxdev
integer getwarndigits, geterrdigits
integer getversionkey, getdebugkey
integer getcachelast
external A0, A0C, B0i, B0iC
external B0, B1, B00, B11, B001, B111
external B0C, B1C, B00C, B11C, B001C, B111C
external DB0, DB1, DB00, DB11
external DB0C, DB1C, DB00C, DB11C
external C0, C0C, C0i, C0iC
external D0, D0C, D0i, D0iC
external E0, E0C, E0i, E0iC
external Li2, Li2C
external Bget, BgetC, Cget, CgetC, Dget, DgetC, Eget, EgetC
external getmudim, getdelta, getlambda, getmaxdev
external getwarndigits, geterrdigits
external getversionkey, getdebugkey
external setcachelast, getcachelast
diff --git a/Looptools/include/lt.h b/Looptools/include/lt.h
--- a/Looptools/include/lt.h
+++ b/Looptools/include/lt.h
@@ -1,31 +1,43 @@
* lt.h
* internal common blocks for the LoopTools routines
* this file is part of LoopTools
-* last modified 23 Nov 05 th
+* last modified 21 Dec 10 th
#include "ff.h"
* the cache-pointer structure is (see cache.c):
* 1. int valid
* 2. Node *last
* 3. Node *first
* 4. (not used)
integer ncaches
parameter (ncaches = 8)
- integer*8 cacheptr(KIND,4,ncaches)
+ integer*8 cacheptr(4,KIND,ncaches)
integer*8 savedptr(2,ncaches)
double precision maxdev
- integer serial, warndigits, errdigits, versionkey
+ integer warndigits, errdigits
+ integer serial, versionkey
integer debugkey, debugfrom, debugto
common /ltvars/
& cacheptr, savedptr,
& maxdev,
- & serial, warndigits, errdigits, versionkey,
+ & warndigits, errdigits,
+ & serial, versionkey,
& debugkey, debugfrom, debugto
+ integer cmpbits
+
+ common /ltcache/ cmpbits
+
double complex cache(2,ncaches)
equivalence (cacheptr, cache)
+
+#ifndef sig
+#define sig(c) int(sign(1D0,DBLE(r))
+#define DEBUGLEVEL ibits(debugkey,8,2)
+#endif
+
diff --git a/Looptools/tester.cc b/Looptools/tester.cc
--- a/Looptools/tester.cc
+++ b/Looptools/tester.cc
@@ -1,29 +1,258 @@
// test program to check looptool linking against c++ code.
#include <iostream>
#include <complex>
+
#include "Herwig++/Looptools/clooptools.h"
-using namespace Herwig::Looptools;
+namespace LT = Herwig::Looptools;
using namespace std;
int main() {
+
+ {
+ double ps2 = 1.2268e+10;
+ double pv1s = -4.76837e-07;
+ double pv2s = -4.76837e-07;
+ double mls = 2.65501e+11;
+
+ LT::ltini();
+ LT::clearcache();
+
+ int theC = LT::Cget(ps2,pv2s,pv1s,
+ mls,mls,mls);
+ cerr << "theC: " << theC << '\n';
+ complex<double> C1 = LT::Cval(LT::cc1,theC);
+ LT::ltexi();
+ cout << "after: " << C1 << endl;
+
+ cerr << "int : " << sizeof(int)
+ << " long : " << sizeof(long) << '\n';
+ }
+
+ // ##################################################
+
+ LT::ltini();
+
+ typedef complex<double> Complex;
+
+ //Kinematic invariants
double ps2 = 1.2268e+10;
- double pv1s = 0;
- double pv2s = 0;
- double mls = 2.65501e+11;
+ double pv1s = -4.76837e-07;
+ double pv2s = -4.76837e-07;
+ //cerr << ps2 << ' ' << pv1s << ' ' << pv2s << ' ' << 6 << '\n';
+ Complex a(0.),b(0.),c(0.),d(0.),e(0.),f(0.);
+ for(unsigned int i = 0; i< 1; ++i) {
+ double lmass = 515268;
+ //cerr << lmass << '\n';
+ double mls = lmass * lmass;
+ Complex lc = 803.477;
+ //cerr << lc << '\n';
+ LT::clearcache();
+ {
+ Complex C0 = LT::C0i(LT::cc0,pv1s,pv2s,ps2,mls,mls,mls);
+ int theC = LT::Cget(ps2,pv2s,pv1s, mls,mls,mls);
+ Complex C1 = LT::Cval(LT::cc1,theC);
+ Complex C2 = LT::Cval(LT::cc2,theC);
+ Complex C00 = LT::Cval(LT::cc00,theC);
+ Complex C11 = LT::Cval(LT::cc11,theC);
+ Complex C12 = LT::Cval(LT::cc12,theC);
+ Complex C22 = LT::Cval(LT::cc22,theC);
+ Complex lpr = lc + 803.477;
+ //cerr << lpr << '\n';
- cout << "before ini" << endl;
- ffini();
- cout << "after ini" << endl;
- long theC = Cget(ps2,pv2s,pv1s,
+ a += 4.*lpr*lmass*(-2.*LT::B0(ps2,mls,mls)
+ + C0*(pv1s + pv2s - ps2)
+ + 8.*C00)/ps2;
+ b += 8.*lpr*lmass*(C0 + 3.*C1 +3.*C2 + 2.*(C11 + 2.*C12 + C22));
+ c += 4.*lpr*lmass*(C0 +2.*(2.*C1+C2 + 2.*(C11 +C12)));
+ d += 4.*lpr*lmass*(C0 + 4.*(C1+C11+C12));
+ e += 8.*lpr*lmass*(C1 + 2.*C11);
+ f += 4.*(lc - 803.477)*lmass*C0;
+
+
+ cerr << a << ' '
+ << b << ' '
+ << c << ' '
+ << d << ' '
+ << e << ' '
+ << f << '\n';
+
+ } LT::clearcache();
+ {
+ int theC = LT::Cget(ps2,pv2s,pv1s,mls,mls,mls);
+ Complex C1 = LT::Cval(LT::cc1,theC);
+ Complex C2 = LT::Cval(LT::cc2,theC);
+ Complex C00 = LT::Cval(LT::cc00,theC);
+ Complex C11 = LT::Cval(LT::cc11,theC);
+ Complex C12 = LT::Cval(LT::cc12,theC);
+ Complex C22 = LT::Cval(LT::cc22,theC);
+
+ /**
+ * vector type can contain different types of particle
+ * and hence the coupling is different
+ * Here left is used for the coupling of the ith
+ * type rather than creating another
+ * vector to hold them.
+ */
+ double pv12 = pv1s*pv2s;
+ Complex
+ C0A(LT::C0(pv1s,pv2s,ps2,mls,mls,mls)),A0A(LT::A0(mls)),
+ B0A(LT::B0(ps2 ,mls,mls)),
+ B1A(LT::B1(ps2 ,mls,mls)),B11A(LT::B11(ps2 ,mls,mls)),
+ B0B(LT::B0(pv1s,mls,mls)),B00B(LT::B00(pv1s,mls,mls)),
+ B1B(LT::B1(pv1s,mls,mls)),B11B(LT::B11(pv1s,mls,mls)),
+ B0C(LT::B0(pv2s,mls,mls)),B00C(LT::B00(pv2s,mls,mls)),
+ B1C(LT::B1(pv2s,mls,mls)),B11C(LT::B11(pv2s,mls,mls));
+ double mls2(mls*mls),mls3(mls2*mls);
+ // coefficient
+ a +=
+ 0.5*lc*(B0A*(2.*mls2*(-6.*mls + pv1s + pv2s)
+ + mls*(-2.*mls + pv1s + pv2s)*ps2)
+ + 2.*(8.*mls3*C0A*pv1s - 2.*mls2*C0A*(pv1s*pv1s)
+ + 2.*mls*B00B*pv2s + 8.*mls3*C0A*pv2s
+ + mls*B0B*pv12 + mls*B0C*pv12 - B00B*pv12
+ - 2.*mls2*C0A*(pv2s*pv2s)
+ + B00C*pv1s*(2.*mls - pv2s)
+ - mls*A0A*(pv1s + pv2s) - 8.*mls3*C0A*ps2
+ + 2.*mls2*C0A*pv1s*ps2 + 2.*mls2*C0A*pv2s*ps2
+ - mls*C0A*pv12*ps2
+ + (24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C00 ) )/mls3*2./ps2;
+
+ b += -0.25*lc*
+ ( 8.*mls*B0C*pv2s - 4.*B11B*(2.*mls - pv1s)*pv2s
+ + 2.*B1B*(2.*mls - pv1s)*(4.*mls - 3.*pv2s) + 4.*B00C*(2.*mls - pv2s)
+ - 2.*A0A*(2.*mls + pv2s) + 2.*B0B*(4.*mls2 - 2.*mls*pv1s + pv12)
+ - 2.*mls*B0A*(pv2s - ps2) - 4.*mls*B11A*(2.*mls + ps2)
+ + B1A*(2.*mls - pv2s)*(2.*mls + ps2)
+ - B1A*(6.*mls - pv2s)*(2.*mls + ps2)
+ - B0A*(8.*mls2 + (2.*mls - pv2s)*ps2)
+ - 2.*C0A*(2.*mls*(12.*mls2 + pv2s*(pv1s + pv2s) - 2.*mls*(pv1s + 3.*pv2s))
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)
+ + 4.*mls*(2.*mls*B0A + (B1A + B11A)*(2.*mls + ps2))
+ - 2.*(2.*mls*(36.*mls2 + 2.*pv12 + (pv2s*pv2s) - 6.*mls*(pv1s + pv2s))
+ + (12.*mls2 + 3.*pv12 - 2.*mls*(3.*pv1s + 4.*pv2s))*ps2)*C1
+ - 2.*(2.*mls*(36.*mls2 + 2.*pv12 + (pv2s*pv2s) - 6.*mls*(pv1s + pv2s))
+ + (12.*mls2 + 3.*pv12 - 2.*mls*(3.*pv1s + 4.*pv2s))*ps2)*C2
+ - 4.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C11
+ - 8.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C12
+ - 4.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C22 )/mls3;
+
+ c+= -lc*
+ (-12.*mls2 + 8.*mls*pv1s - (pv1s*pv1s) + 48.*B00B*(2.*mls - pv1s)
+ + 24.*B00C*(2.*mls - pv2s) - 6.*A0A*(6.*mls + pv1s - 2.*ps2)
+ - 6.*B1B*(2.*mls - pv1s)*(2.*mls - pv1s + 3.*pv2s - ps2)
+ - 24.*mls*B11A*(2.*mls + ps2)
+ - 3.*B1A*(4.*mls - pv1s + pv2s - ps2)*(2.*mls + ps2)
+ - 3.*B1A*(2.*mls + ps2)*(4.*mls + pv1s - pv2s + ps2)
+ + 6.*B1C*(2.*mls - pv2s)*(-3.*pv1s + pv2s + ps2)
+ + 12.*B11C*(2.*mls - pv2s)*(-pv1s + pv2s + ps2)
+ + 6.*B11B*(2.*mls - pv1s)*(3.*pv1s - 2.*pv2s + 2.*ps2)
+ + 6.*B0C*(2.*mls*pv1s + (4.*mls + pv1s)*pv2s - 4.*mls*ps2)
+ - 6.*B0B*(2.*mls2 - 5.*mls*pv1s - (2.*mls + pv1s)*pv2s
+ + 4.*mls*ps2)
+ - 3.*B0A*(2.*mls*(4.*mls + pv1s + 2.*pv2s) - (4.*mls + pv1s)*ps2)
+ - 3.*B0A*(2.*mls*(4.*mls + 2.*pv1s + pv2s) - (2.*mls + pv2s)*ps2
+ + (ps2*ps2))
+ - 6.*C0A*(2.*mls*(12.*mls2 - (pv1s*pv1s) + pv12 + (pv2s*pv2s)
+ - 6.*mls*(pv1s + pv2s))
+ + (12.*mls2 + pv12 + 2.*mls*(pv1s - pv2s))*ps2 - 2.*mls*(ps2*ps2))
+ + 24.*mls*(2.*mls*B0A + (B1A + B11A)*(2.*mls + ps2))
+ - 24.*(mls*(24.*mls2 - (pv1s*pv1s) + 2.*pv12 + (pv2s*pv2s)
+ - 4.*mls*(pv1s + pv2s))
+ + (4.*mls2 + pv12 - mls*(pv1s + 3.*pv2s))*ps2)*C1
+ - 12.*(24.*mls3 - 2.*mls*(pv1s*pv1s) - 4.*mls2*(pv1s + pv2s)
+ + (4.*mls2 - 2.*mls*pv2s + pv12)*ps2)*C2
+ - 24.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ +(2.*mls - pv1s)*(2.*mls - pv2s)*ps2)* C11
+ - 24.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C12
+ + 72.*(2.*mls - pv1s)*(-0.125*mls - 0.125*A0A + (0.25*mls*B1B)
+ + (0.125*pv1s*B11B))
+ - 12.*(-2.*mls + pv1s)*(0.25*mls - 0.25*A0A - (0.5*mls*B1B)
+ - (0.75*pv1s*B11B)) )/24./mls3;
+
+ d+= -lc*
+ (-2.*mls2*B0A - 2.*mls*C0A*(8.*mls2 + pv12 - 2.*mls*(pv1s + pv2s))
+ - mls*B1A*(2.*mls + ps2) - mls*B11A*(2.*mls + ps2)
+ + mls*(2.*mls*B0A + (B1A + B11A)*(2.*mls + ps2))
+ - (24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)* C1 - 2.*mls*pv12*C2
+ - (24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C11
+ - (24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ +(2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C12 )/mls3;
+
+ e+= -0.25*lc*
+ (8.*mls*B0B*pv1s + 4.*B00B*(2*mls - pv1s) - 2.*A0A*(2.*mls + pv1s)
+ - 4.*B11C*pv1s*(2.*mls - pv2s) + 2.*B1C*(4.*mls - 3.*pv1s)*(2.*mls - pv2s)
+ + 2.*B0C*(4.*mls2 - 2.*mls*pv2s + pv12) - 2.*mls*B0A*(pv1s - ps2)
+ + 4.*mls*C0A*pv1s*(4.*mls - pv2s - ps2) - 4.*mls*B11A*(2.*mls + ps2)
+ + B1A*(2.*mls - pv1s)*(2.*mls + ps2) - B1A*(6.*mls - pv1s)*(2.*mls + ps2)
+ - B0A*(8.*mls2 + (2.*mls - pv1s)*ps2)
+ + 4.*mls*(2.*mls*B0A + (B1A + B11A)*(2.*mls + ps2))
+ - 2*(2.*mls*(12.*mls2 - pv1s + 2.*pv12 - 2.*mls*(pv1s + pv2s))
+ + (4.*mls2 - 2.*mls*pv2s + pv12)*ps2)*C1
+ - 4.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ + (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C11 )/mls3;
+
+
+ cerr << a << ' '
+ << b << ' '
+ << c << ' '
+ << d << ' '
+ << e << ' '
+ << f << '\n';
+ } LT::clearcache();
+ {
+ int theC = LT::Cget(ps2,pv2s,pv1s,
mls,mls,mls);
- cerr << "theC: " << theC << '\n';
- complex<double> C1 = Cval(cc1,theC);
- ffexi();
- cout << "after: " << C1 << endl;
-
- cerr << sizeof(long) << '\n';
+ Complex C1 = LT::Cval(LT::cc1,theC);
+ Complex C2 = LT::Cval(LT::cc2,theC);
+ Complex C00 = LT::Cval(LT::cc00,theC);
+ Complex C11 = LT::Cval(LT::cc11,theC);
+ Complex C12 = LT::Cval(LT::cc12,theC);
+ Complex C22 = LT::Cval(LT::cc22,theC);
+ Complex Cz = LT::C0(pv1s,pv2s,ps2,mls,mls,mls);
+ /**
+ * vector type can contain different types of particle
+ * and hence the coupling is different
+ * Here left[i] is used for the coupling of the ith
+ * type rather than creating another
+ * vector to hold them.
+ */
+ a += 4.*lc*(LT::B0(ps2,mls,mls) - 4.*C00)/ps2;
+ b += -4.*lc*(Cz + 3.*C1 + 3.*C2 +2.*(C11 + 2.*C12 + C22 ));
+ c += -2.*lc*(Cz + 2.*(2.*C1+ C2 + 2.*(C11 +C12)));
+ d += -8.*lc*(C1 +C11 + C12);
+ e += -4.*lc*(C1 + 2.*C11);
+
+ cerr << a << ' '
+ << b << ' '
+ << c << ' '
+ << d << ' '
+ << e << ' '
+ << f << '\n';
+ }
+
+ }
+
+ LT::clearcache();
+
+ LT::ltexi();
+
+
+
+
+
+
+
+
+
return 0;
}
diff --git a/Looptools/util/CGaussPivot.F b/Looptools/util/CGaussPivot.F
deleted file mode 100644
--- a/Looptools/util/CGaussPivot.F
+++ /dev/null
@@ -1,4 +0,0 @@
-#define COMPLEXPARA
-
-#include "GaussPivot.F"
-
diff --git a/Looptools/util/GaussPivot.F b/Looptools/util/GaussPivot.F
deleted file mode 100644
--- a/Looptools/util/GaussPivot.F
+++ /dev/null
@@ -1,222 +0,0 @@
-* GaussPivot.F
-* Solution of the linear equation A.x = B by Gaussian elimination
-* with partial pivoting
-* this file is part of LoopTools
-* last modified 24 Jan 06 th
-
-* Author: Michael Rauch, 7 Dec 2004
-* Reference: Folkmar Bornemann, course notes to
-* Numerische Mathematik 1, Technische Universitaet, Munich, Germany
-
-#include "defs.h"
-
-#define MAXDIM 8
-
-************************************************************************
-* LUDecomp computes the LU decomposition of the n-by-n matrix A
-* by Gaussian Elimination with partial pivoting;
-* compact (in situ) storage scheme
-* Input:
-* A: n-by-n matrix to LU-decompose
-* n: dimension of A
-* Output:
-* A: mangled LU decomposition of A in the form
-* ( y11 y12 ... y1n )
-* ( x21 y22 ... y2n )
-* ( x31 x32 ... y3n )
-* ( ............... )
-* ( xn1 xn2 ... ynn )
-* where
-* ( 1 0 ... 0 ) ( y11 y12 ... y1n )
-* ( x21 1 ... 0 ) ( 0 y22 ... y2n )
-* ( x31 x32 ... 0 ) ( 0 0 ... y3n ) = Permutation(A)
-* ( ............... ) ( ............... )
-* ( xn1 xn2 ... 1 ) ( 0 0 ... ynn )
-* perm: permutation vector
-
- subroutine XLUDecomp(A, n, perm)
- implicit none
- integer n, perm(*)
- QVAR A(n,*)
-
- integer i, j, k, imax
- QVAR tmp
- QREAL Amax
-
- do j = 1, n
-* do U part (minus diagonal one)
- do i = 1, j - 1
- do k = 1, i - 1
- A(i,j) = A(i,j) - A(i,k)*A(k,j)
- enddo
- enddo
-
-* do L part (plus diagonal from U case)
- Amax = 0
- do i = j, n
- tmp = 0
- do k = 1, j - 1
- tmp = tmp + A(i,k)*A(k,j)
- enddo
- A(i,j) = A(i,j) - tmp
-
-* do partial pivoting ...
-* find the pivot
- if( abs(A(i,j)) .gt. Amax ) then
- Amax = abs(A(i,j))
- imax = i
- endif
- enddo
-
-* exchange rows
- perm(j) = imax
- do k = 1, n
- tmp = A(j,k)
- A(j,k) = A(imax,k)
- A(imax,k) = tmp
- enddo
-
-* division by the pivot element
- if( A(j,j) .eq. 0 ) then
- tmp = 1D123
- else
- tmp = 1/A(j,j)
- endif
- do i = j + 1, n
- A(i,j) = A(i,j)*tmp
- enddo
- enddo
- end
-
-************************************************************************
-* LUBackSubst computes the x in A.x = b from the LU-decomposed A.
-* Input:
-* A: LU-decomposed n-by-n matrix A
-* b: input vector b in A.x = b
-* n: dimension of A
-* p: permutation vector from LU decomposition
-* Output:
-* b: solution vector x in A.x = b
-
- subroutine XLUBackSubst(A, n, p, b)
- implicit none
- integer n, p(*)
- QVAR A(n,*)
- double complex b(*)
-
- integer i, j
- double complex tmp
-
-* permute b
- do i = 1, n
- tmp = b(i)
- b(i) = b(p(i))
- b(p(i)) = tmp
- enddo
-
-* forward substitution L.Y = B
- do i = 1, n
- do j = 1, i - 1
- b(i) = b(i) - A(i,j)*b(j)
- enddo
- enddo
-
-* backward substitution U.X = Y
- do i = n, 1, -1
- do j = i + 1, n
- b(i) = b(i) - A(i,j)*b(j)
- enddo
- b(i) = b(i)/A(i,i)
- enddo
- end
-
-************************************************************************
-* same as LUBackSubst, but for real b
-
-#ifdef COMPLEXPARA
-#define LUBackSubstD LUBackSubstC
-#else
- subroutine LUBackSubstD(A, n, p, b)
- implicit none
- integer n, p(*)
- QVAR A(n,*)
- QVAR b(*)
-
- integer i, j
- QVAR tmp
-
-* permute b
- do i = 1, n
- tmp = b(i)
- b(i) = b(p(i))
- b(p(i)) = tmp
- enddo
-
-* forward substitution L.Y = B
- do i = 1, n
- do j = 1, i - 1
- b(i) = b(i) - A(i,j)*b(j)
- enddo
- enddo
-
-* backward substitution U.X = Y
- do i = n, 1, -1
- do j = i + 1, n
- b(i) = b(i) - A(i,j)*b(j)
- enddo
- b(i) = b(i)/A(i,i)
- enddo
- end
-#endif
-
-************************************************************************
-* Det computes the determinant of a matrix.
-* Input:
-* A: n-by-n matrix A
-* n: dimension of A
-* Output:
-* determinant of A
-* Warning: A is overwritten
-
- QVAR function XDet(A, n)
- implicit none
- integer n
- QVAR A(n,*)
-
- integer i, perm(MAXDIM)
-
- call XLUDecomp(A, n, perm)
- XDet = 1
- do i = 1, n
- XDet = XDet*A(i,i)
- if( perm(i) .ne. i ) XDet = -XDet
- enddo
- end
-
-************************************************************************
-* Inverse computes the inverse of a matrix.
-* Input:
-* A: n-by-n matrix A
-* n: dimension of A
-* Output:
-* A: mangled LU decomposition of A
-* Ainv: inverse of A
-* perm: permutation vector
-
- subroutine XInverse(A, Ainv, n, perm)
- implicit none
- integer n, perm(*)
- QVAR A(n,*), Ainv(n,*)
-
- integer i, j
-
- call XLUDecomp(A, n, perm)
- do i = 1, n
- do j = 1, n
- Ainv(j,i) = 0
- enddo
- Ainv(i,i) = 1
- call LUBackSubstD(A, n, perm, Ainv(1,i))
- enddo
- end
-
diff --git a/Looptools/util/auxCD.F b/Looptools/util/auxCD.F
--- a/Looptools/util/auxCD.F
+++ b/Looptools/util/auxCD.F
@@ -1,178 +1,399 @@
* auxCD.F
* auxillary functions used by the three- and four-point integrals
* these functions are adapted from Ansgar Denner's bcanew.f
* to the conventions of LoopTools;
* they are used for double-checking the results of FF
-* last modified 25 Oct 05 th
+* last modified 1 Feb 10 th
#include "defs.h"
- double complex function ln(x, isig)
+ double complex function ln(x, s)
implicit none
- double precision x, isig
+ double precision x, s
-#include "lt.h"
+#include "ff.h"
- if( x .gt. 0 ) then
+ if( x .le. 0 ) then
+#ifdef WARNINGS
+ if( s .eq. 0 ) print *, "ln: argument on cut"
+#endif
+ ln = log(-x) + cI*sign(pi, s)
+ else
ln = log(x)
- else
- ln = log(-x) + DCMPLX(0D0, sign(pi, isig))
endif
end
************************************************************************
- double complex function cln(z, isig)
+ double complex function cln(z, s)
implicit none
double complex z
- double precision isig
+ double precision s
-#include "lt.h"
+#include "ff.h"
if( DIMAG(z) .eq. 0 .and. DBLE(z) .le. 0 ) then
#ifdef WARNINGS
- if( isig .eq. 0 ) print *, "cln: argument on cut"
+ if( s .eq. 0 ) print *, "cln: argument on cut"
#endif
- cln = log(-z) + DCMPLX(0D0, sign(pi, isig))
+ cln = log(-z) + cI*sign(pi, s)
else
cln = log(z)
endif
end
************************************************************************
+* lnrat(x, y) = log(x - i eps) - log(y - i eps)
+* original version by R.K. Ellis
+* this function is hardwired for the sign of epsilon
+* we must adjust the sign of x and y to get the right sign for epsilon
- double complex function spence(z, isig)
+ double complex function lnrat(x, y)
+ implicit none
+ double precision x, y
+
+#include "ff.h"
+
+ lnrat = log(abs(x/y)) +
+ & cI*(sign(.5D0*pi, x) - sign(.5D0*pi, y))
+ end
+
+************************************************************************
+
+ double complex function lndiv0(x, y)
+ implicit none
+ double precision x, y
+
+ double precision den
+
+ double complex lnrat
+ external lnrat
+
+ den = 1 - x/y
+ if( abs(den) .lt. 1D-7 ) then
+ lndiv0 = -1 - den*(.5D0 + den/3D0)
+ else
+ lndiv0 = lnrat(x, y)/den
+ endif
+ end
+
+************************************************************************
+
+ double complex function lndiv1(x, y)
+ implicit none
+ double precision x, y
+
+ double precision den
+
+ double complex lnrat
+ external lnrat
+
+ den = 1 - x/y
+ if( abs(den) .lt. 1D-7 ) then
+ lndiv1 = -.5D0 - den/3D0*(1 + .75D0*den)
+ else
+ lndiv1 = (lnrat(x, y)/den + 1)/den
+ endif
+ end
+
+************************************************************************
+* Li2omrat(x, y) = Li2(1 - (x - i eps)/(y - i eps)) for real x and y
+* hence arguments are typically negative invariants
+* original version by R.K. Ellis
+
+ double complex function Li2omrat(x, y)
+ implicit none
+ double precision x, y
+
+#include "ff.h"
+
+ double precision omarg
+
+ double complex spence, lnrat
+ external spence, lnrat
+
+ omarg = x/y
+ if( omarg .lt. 0 ) then
+ Li2omrat = pi6 - spence(DCMPLX(omarg), 0D0) -
+ & log(1 - omarg)*lnrat(x, y)
+ else
+ Li2omrat = spence(DCMPLX(1 - omarg), 0D0)
+ endif
+ end
+
+************************************************************************
+* Li2omx2 = Li2(1 - (z1 + i eps1) (z2 + i eps2)) for complex z1, z2
+* for z1 z2 < 1: +Li2(1 - z1 z2)
+* for z1 z2 > 1: -Li2(1 - 1/(z1 z2)) - 1/2 (ln(z1) + ln(z2))^2
+* original version by R.K. Ellis
+
+ double complex function Li2omx2(z1, s1, z2, s2)
+ implicit none
+ double complex z1, z2
+ double precision s1, s2
+
+#include "ff.h"
+
+ double complex z12, l12
+ double precision s12
+
+ double complex cln, spence
+ external cln, spence
+
+ z12 = z1*z2
+ if( abs(z12) .lt. eps ) then
+ Li2omx2 = 0
+ else if( abs(z12 - 1) .eq. acc ) then
+ Li2omx2 = pi6
+ else
+ l12 = cln(z1, s1) + cln(z2, s2)
+ s12 = sign(1D0, DBLE(z2))*s1 + sign(1D0, DBLE(z1))*s2
+ if( abs(z12) .le. 1 ) then
+ Li2omx2 = pi6 - spence(z12, s12) -
+ & l12*cln(1 - z12, -s12)
+ else
+ z12 = 1/z12
+ Li2omx2 = -pi6 + spence(z12, s12) -
+ & l12*(cln(1 - z12, -s12) + .5D0*l12)
+ endif
+ endif
+ end
+
+************************************************************************
+* Li2omx3 = Li2(1 - (z1 + i eps1) (z2 + i eps2)) for complex z1, z2
+* for z1 z2 < 1: +Li2(1 - z1 z2)
+* for z1 z2 > 1: -Li2(1 - 1/(z1 z2)) - 1/2 (ln(z1) + ln(z2))^2
+* original version by R.K. Ellis
+
+ double complex function Li2omx3(z1, s1, z2, s2, z3, s3)
+ implicit none
+ double complex z1, z2, z3
+ double precision s1, s2, s3
+
+#include "ff.h"
+
+ double complex z123, l123
+ double precision s123
+
+ double complex cln, spence
+ external cln, spence
+
+ z123 = z1*z2*z3
+ if( abs(DIMAG(z123)) .lt. eps )
+ & s123 = sign(1D0,
+ & DBLE(z2*z3)*s1 + DBLE(z1*z3)*s2 + DBLE(z1*z2)*s3)
+
+ if( abs(z123) .le. 1 ) then
+ Li2omx3 = pi6 - spence(z123, s123)
+ if( abs(z123) .gt. eps .and. abs(z123 - 1) .gt. acc )
+ & Li2omx3 = Li2omx3 - cln(1 - z123, 0D0)*
+ & (cln(z1, s1) + cln(z2, s2) + cln(z3, s3))
+ else
+ z123 = 1/z123
+ l123 = cln(z1, s1) + cln(z2, s2) + cln(z3, s3)
+ Li2omx3 = -pi6 + spence(z123, s123) -
+ & l123*(.5D0*l123 - cln(1 - z123, 0D0))
+ endif
+ end
+
+************************************************************************
+* Li2omrat2 = Li2(1 - (n1 - i eps) (n2 - i eps)/(d1 - i eps)/(d2 - i eps))
+* for real n1, n2, d1, d2
+* original version by R.K. Ellis
+
+ double complex function Li2omrat2(n1, d1, n2, d2)
+ implicit none
+ double precision n1, d1, n2, d2
+
+#include "ff.h"
+
+ double precision r12
+ double complex l12
+
+ double complex lnrat, spence
+ external lnrat, spence
+
+ r12 = n1*n2/(d1*d2)
+ if( r12 .lt. 1 ) then
+ Li2omrat2 = pi6 - spence(DCMPLX(r12), 0D0)
+ if( abs(r12*(1 - r12)) .gt. acc )
+ & Li2omrat2 = Li2omrat2 -
+ & (lnrat(n1, d1) + lnrat(n2, d2))*log(1 - r12)
+ else
+ r12 = 1/r12
+ l12 = lnrat(n1, d1) + lnrat(n2, d2)
+ Li2omrat2 = -pi6 + spence(DCMPLX(r12), 0D0) -
+ & l12*(.5D0*l12 + log(1 - r12))
+ endif
+ end
+
+************************************************************************
+* original version by R.K. Ellis
+
+ double complex function Li2rat(r1, s1, r2, s2)
+ implicit none
+ double complex r1, r2
+ double precision s1, s2
+
+#include "ff.h"
+
+ double complex r12, l12
+
+ double complex Li2omx2, cln, spence
+ external Li2omx2, cln, spence
+
+ if( abs(DIMAG(r1)) + abs(DIMAG(r2)) .lt. eps ) then
+ Li2rat = Li2omx2(r1, s1, r2, s2)
+ return
+ endif
+
+ r12 = r1*r2
+ if( abs(r12) .lt. 1 ) then
+ Li2rat = pi6 - spence(r12, 0D0)
+ if( abs(r12*(1 - r12)) .gt. acc )
+ & Li2rat = Li2rat - (cln(r1, s1) + cln(r2, s2))*log(1 - r12)
+ else
+ r12 = 1/r12
+ l12 = cln(r1, s1) + cln(r2, s2)
+ Li2rat = -pi6 + spence(r12, 0D0) -
+ & l12*(.5D0*l12 - log(1 - r12))
+ endif
+ end
+
+************************************************************************
+
+ double complex function spence(z, s)
implicit none
double complex z
- double precision isig
+ double precision s
-#include "lt.h"
+#include "ff.h"
double complex z1
double precision az1
- double complex li2series, cln
- external li2series, cln
+ double complex Li2series, cln
+ external Li2series, cln
z1 = 1 - z
az1 = abs(z1)
#ifdef WARNINGS
- if( isig .eq. 0 .and.
+ if( s .eq. 0 .and.
& DIMAG(z) .eq. 0 .and. abs(DBLE(z1)) .lt. acc )
& print *, "spence: argument on cut"
#endif
- if( az1 .lt. 1D-15 ) then
+ if( az1 .lt. acc ) then
spence = pi6
else if( DBLE(z) .lt. .5D0 ) then
if( abs(z) .lt. 1 ) then
- spence = li2series(z, isig)
+ spence = Li2series(z, s)
else
spence = -pi6 -
- & .5D0*cln(-z, -isig)**2 - li2series(1/z, -isig)
+ & .5D0*cln(-z, -s)**2 - Li2series(1/z, -s)
endif
else
if( az1 .lt. 1 ) then
spence = pi6 -
- & cln(z, isig)*cln(z1, -isig) - li2series(z1, -isig)
+ & cln(z, s)*cln(z1, -s) - Li2series(z1, -s)
else
spence = 2*pi6 +
- & .5D0*cln(-z1, -isig)**2 - cln(z, isig)*cln(z1, -isig) +
- & li2series(1/z1, isig)
+ & .5D0*cln(-z1, -s)**2 - cln(z, s)*cln(z1, -s) +
+ & Li2series(1/z1, s)
endif
endif
end
************************************************************************
- double complex function li2series(z, isig)
+ double complex function Li2series(z, s)
implicit none
double complex z
- double precision isig
+ double precision s
double complex xm, x2, new
integer j
double complex cln
external cln
* these are the even-n Bernoulli numbers, already divided by (n + 1)!
* as in Table[BernoulliB[n]/(n + 1)!, {n, 2, 50, 2}]
double precision b(25)
data b /
& 0.02777777777777777777777777777777777777777778774D0,
& -0.000277777777777777777777777777777777777777777778D0,
& 4.72411186696900982615268329554043839758125472D-6,
& -9.18577307466196355085243974132863021751910641D-8,
& 1.89788699889709990720091730192740293750394761D-9,
& -4.06476164514422552680590938629196667454705711D-11,
& 8.92169102045645255521798731675274885151428361D-13,
& -1.993929586072107568723644347793789705630694749D-14,
& 4.51898002961991819165047655285559322839681901D-16,
& -1.035651761218124701448341154221865666596091238D-17,
& 2.39521862102618674574028374300098038167894899D-19,
& -5.58178587432500933628307450562541990556705462D-21,
& 1.309150755418321285812307399186592301749849833D-22,
& -3.087419802426740293242279764866462431595565203D-24,
& 7.31597565270220342035790560925214859103339899D-26,
& -1.740845657234000740989055147759702545340841422D-27,
& 4.15763564461389971961789962077522667348825413D-29,
& -9.96214848828462210319400670245583884985485196D-31,
& 2.394034424896165300521167987893749562934279156D-32,
& -5.76834735536739008429179316187765424407233225D-34,
& 1.393179479647007977827886603911548331732410612D-35,
& -3.372121965485089470468473635254930958979742891D-37,
& 8.17820877756210262176477721487283426787618937D-39,
& -1.987010831152385925564820669234786567541858996D-40,
& 4.83577851804055089628705937311537820769430091D-42 /
- xm = -cln(1 - z, -isig)
+ xm = -cln(1 - z, -s)
x2 = xm**2
- li2series = xm - x2/4D0
+ Li2series = xm - x2/4D0
do j = 1, 25
xm = xm*x2
- new = li2series + xm*b(j)
- if( new .eq. li2series ) return
- li2series = new
+ new = Li2series + xm*b(j)
+ if( new .eq. Li2series ) return
+ Li2series = new
enddo
#ifdef WARNINGS
- print *, "li2series: bad convergence"
+ print *, "Li2series: bad convergence"
#endif
end
************************************************************************
- integer function eta(c1, c2, im1x, im2x, im12x)
+ integer function eta(z1, s1, z2, s2, s12)
implicit none
- double complex c1, c2
- double precision im1x, im2x, im12x
+ double complex z1, z2
+ double precision s1, s2, s12
double precision im1, im2, im12
- im1 = DIMAG(c1)
- if( im1 .eq. 0 ) im1 = im1x
- im2 = DIMAG(c2)
- if( im2 .eq. 0 ) im2 = im2x
- im12 = DIMAG(c1*c2)
- if( im12 .eq. 0 ) im12 = im12x
+ im1 = DIMAG(z1)
+ if( im1 .eq. 0 ) im1 = s1
+ im2 = DIMAG(z2)
+ if( im2 .eq. 0 ) im2 = s2
+ im12 = DIMAG(z1*z2)
+ if( im12 .eq. 0 ) im12 = s12
if( im1 .lt. 0 .and. im2 .lt. 0 .and. im12 .gt. 0 ) then
eta = 1
else
& if( im1 .gt. 0 .and. im2 .gt. 0 .and. im12 .lt. 0 ) then
eta = -1
else
eta = 0
#ifdef WARNINGS
- if( .not. (im2 .eq. 0 .and. DBLE(c2) .gt. 0 .or.
- & im1 .eq. 0 .and. DBLE(c1) .gt. 0) .and.
- & (im1 .eq. 0 .and. DBLE(c1) .lt. 0 .or.
- & im2 .eq. 0 .and. DBLE(c2) .lt. 0 .or.
- & im12 .eq. 0 .and. DBLE(c1*c2) .lt. 0) )
+ if( .not. (im2 .eq. 0 .and. DBLE(z2) .gt. 0 .or.
+ & im1 .eq. 0 .and. DBLE(z1) .gt. 0) .and.
+ & (im1 .eq. 0 .and. DBLE(z1) .lt. 0 .or.
+ & im2 .eq. 0 .and. DBLE(z2) .lt. 0 .or.
+ & im12 .eq. 0 .and. DBLE(z1*z2) .lt. 0) )
& print *, "eta not defined"
#endif
endif
end
diff --git a/Looptools/util/cache.c b/Looptools/util/cache.c
--- a/Looptools/util/cache.c
+++ b/Looptools/util/cache.c
@@ -1,87 +1,180 @@
/*
cache.c
caching of tensor coefficients in
dynamically allocated memory
this file is part of LoopTools
- last modified 14 Dec 06 th
+ last modified 9 Dec 10 th
*/
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
+#define cachelookup_ ljcachelookup_
-typedef struct { double re, im; } Complex;
+#define cachelookup cachelookup_
+#define ltcache ltcache_
-static int SignBit(const int i)
+#ifndef BIGENDIAN
+#define BIGENDIAN 0
+#endif
+
+#ifndef KIND
+#define KIND 1
+#endif
+
+#if KIND == 2
+#define MSB (1-BIGENDIAN)
+#else
+#define MSB 0
+#endif
+
+
+typedef long long dblint;
+
+typedef unsigned long long udblint;
+
+typedef struct { dblint part[KIND]; } Real;
+
+typedef struct { Real re, im; } Complex;
+
+typedef long Integer;
+
+
+extern struct {
+ long cmpbits;
+} ltcache;
+
+
+/* (a < 0) ? -1 : 0 */
+#define NegQ(a) ((a) >> (sizeof(a)*8 - 1))
+
+/* (a < 0) ? 0 : a */
+#define IDim(a) ((a) & NegQ(-(a)))
+
+
+static int SignBit(const dblint i)
{
- return (unsigned)i >> (8*sizeof(i) - 1);
+ return (udblint)i >> (8*sizeof(i) - 1);
}
-static long PtrDiff(const void *a, const void *b)
+
+static Integer PtrDiff(const void *a, const void *b)
{
return (char *)a - (char *)b;
}
-long cachelookup_(const double *para, double *base,
- void (*calc)(const double *, Complex *, const long *),
- const long *npara, const long *nval)
+static dblint CmpPara(const Real *para1, const Real *para2, int n,
+ const dblint mask)
{
+ while( n-- ) {
+ const dblint c = (mask & para1->part[MSB]) -
+ (mask & para2->part[MSB]);
+ if( c ) return c;
+ ++para1;
+ ++para2;
+ }
+ return 0;
+}
+
+
+#if KIND == 2
+
+static dblint CmpParaLo(const Real *para1, const Real *para2, int n,
+ const dblint mask)
+{
+ while( n-- ) {
+ dblint c = para1->part[MSB] - para2->part[MSB];
+ if( c ) return c;
+ c = (mask & para1->part[1-MSB]) - (mask & para2->part[1-MSB]);
+ if( c ) return c;
+ ++para1;
+ ++para2;
+ }
+ return 0;
+}
+
+#endif
+
+
+Integer cachelookup(const Real *para, double *base,
+ void (*calc)(const Real *, Real *, const long *),
+ const int *pnpara, const int *pnval)
+{
+
+ const long one = 1;
+ const Integer C_size = sizeof(Complex);
+ const int npara = *pnpara, nval = *pnval;
+
typedef struct node {
struct node *next[2], *succ;
- long serial;
- double para[*npara];
- Complex val[*nval];
+ int serial;
+ Real para[2];
} Node;
-#define base_valid (long *)&base[0]
+#define base_valid (int *)&base[0]
#define base_last (Node ***)&base[1]
#define base_first (Node **)&base[2]
- const long valid = *base_valid;
+ const int valid = *base_valid;
Node **last = *base_last;
Node **next = base_first;
- Node *node = NULL;
+ Node *node;
if( last == NULL ) last = next;
- while( (node = *next) && node->serial < valid ) {
- const int i = memcmp(para, node->para, sizeof(node->para));
- if( i == 0 ) goto found;
- next = &node->next[SignBit(i)];
+ if( ltcache.cmpbits > 0 ) {
+ dblint mask = -(1ULL << IDim(64 - ltcache.cmpbits));
+#if KIND == 2
+ dblint (*cmp)(const Real *, const Real *, int, const dblint) = CmpPara;
+ if( ltcache.cmpbits >= 64 ) {
+ mask = -(1ULL << IDim(128 - ltcache.cmpbits));
+ cmp = CmpParaLo;
+ }
+#else
+#define cmp CmpPara
+#endif
+
+ while( (node = *next) && node->serial < valid ) {
+ const dblint i = cmp(para, node->para, npara, mask);
+ if( i == 0 ) {
+ goto found;
+ }
+ next = &node->next[SignBit(i)];
+ }
}
node = *last;
if( node == NULL ) {
- /* MUST have extra Complex for alignment so that node
- can be reached with an integer index into base */
- node = malloc(sizeof(Node) + sizeof(Complex));
+ /* The "Real para[2]" bit in Node is effectively an extra
+ Complex for alignment so that node can be reached with
+ an integer index into base */
+ node = malloc(sizeof(Node) + npara*sizeof(Real) + nval*sizeof(Complex));
if( node == NULL ) {
fputs("Out of memory for LoopTools cache.\n", stderr);
exit(1);
}
node = (Node *)((char *)node +
- (PtrDiff(base, node->val) & (sizeof(Complex) - 1)));
+ (PtrDiff(base, &node->para[npara]) & (sizeof(Complex) - 1)));
node->succ = NULL;
node->serial = valid;
*last = node;
}
*next = node;
*base_last = &node->succ;
*base_valid = valid + 1;
node->next[0] = NULL;
node->next[1] = NULL;
- memcpy(node->para, para, sizeof(node->para));
- static const long one = 1;
- calc(node->para, node->val, &one);
+ memcpy(node->para, para, npara*sizeof(Real));
+ calc(node->para, &node->para[npara], &one);
found:
- return PtrDiff(node->val, base)/sizeof(Complex);
+ return PtrDiff(&node->para[npara], base)/C_size;
}
diff --git a/Looptools/util/ff2dl2.F b/Looptools/util/ff2dl2.F
--- a/Looptools/util/ff2dl2.F
+++ b/Looptools/util/ff2dl2.F
@@ -1,514 +1,517 @@
+#include "externals.h"
+
+
*###[ ff2dl2:
subroutine ff2dl2(del2d2,del2n,xpi,dpipj,piDpj, i,
+ j,k,kj,iskj,l, m,n,nm,isnm, ns, ier)
***#[*comment:***********************************************************
* *
* Calculate *
* *
* si mu mu sl *
* d d = si.sj*sk.sm*sl.sn - si.sk*sj.sm*sl.sn *
* sj sk sm sn - si.sj*sk.sn*sl.sm + si.sk*sj.sn*sl.sm *
* *
* with p(kj) = iskj*(sk-sj) *
* with p(nm) = isnm*(sn-sm) *
* *
* Input: xpi(ns) as usual *
* dpipj(ns,ns) -"- *
* piDpj(ns,ns) -"- *
* i,j,k,kj,iskj see above *
* l,m,n,nm,isnm -"- *
* *
* Output: del2d2 see above *
* del2n it is needed in fftran anyway *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer i,j,k,kj,iskj,l,m,n,nm,isnm,ns,ier
DOUBLE PRECISION del2d2,del2n,xpi(10),dpipj(10,10),piDpj(10,10)
*
* local variables:
*
integer isii,ii,ik,ij,im,in,ier0,ier1
DOUBLE PRECISION s(5),del2m,del2nm,som,xmax,smax
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ get del2n:
* we need this in any case !
ier1 = ier
if ( i .eq. n ) then
del2n = 0
elseif ( i .le. 4 ) then
ii = inx(n,i)
isii = isgn(n,i)
call ffdl2s(del2n,piDpj,i,n,ii,isii,j,k,kj,iskj,10)
else
call ffdl2t(del2n,piDpj,i,n,j,k,kj,iskj,+1,10)
endif
* #] get del2n:
* #[ special cases:
ier0 = ier
if ( i .eq. l .and. j .eq. m .and. k .eq. n ) then
call ffdl3m(s,.FALSE.,0D0,0D0,xpi,dpipj,piDpj,ns,j,k,kj,
+ i,1)
del2d2 = -s(1)
ier = max(ier0,ier1)
return
endif
if ( k .eq. l .and. j .le. 4 ) then
call ffdl2s(del2m,piDpj, j,l,inx(l,j),isgn(l,j),
+ m,n,nm,isnm, 10)
del2d2 = -piDpj(i,k)*del2m
ier = max(ier0,ier1)
return
endif
* #] special cases:
* #[ calculations:
ier0 = ier
if ( i .eq. m ) then
del2m = 0
elseif ( i .le. 4 ) then
ii = inx(m,i)
isii = isgn(m,i)
call ffdl2s(del2m,piDpj,i,m,ii,isii,j,k,kj,iskj,10)
else
call ffdl2t(del2m,piDpj,i,m,j,k,kj,iskj,+1,10)
endif
s(1) = del2m*piDpj(n,l)
s(2) = del2n*piDpj(m,l)
smax = abs(s(1))*DBLE(10)**(ier0-ier)
del2d2 = s(1) - s(2)
if ( abs(del2d2) .ge. xloss*smax ) goto 60
som = del2d2
xmax = smax
ier0 = ier
call ffdl2t(del2nm,piDpj,i,nm,j,k,kj,iskj,+1,10)
s(1) = del2n*piDpj(nm,l)
s(2) = del2nm*piDpj(n,l)
del2d2 = isnm*(s(1) - s(2))
smax = abs(s(2))*DBLE(10)**(ier0-ier)
if ( abs(del2d2) .ge. xloss*abs(s(1)) ) goto 60
if ( smax .lt. xmax ) then
som = del2d2
xmax = smax
endif
s(1) = del2m*piDpj(nm,l)
s(2) = del2nm*piDpj(m,l)
del2d2 = isnm*(s(1) - s(2))
smax = abs(s(2))*DBLE(10)**(ier0-ier)
if ( abs(del2d2) .ge. xloss*abs(s(1)) ) goto 60
if ( smax .lt. xmax ) then
som = del2d2
xmax = smax
endif
* One more special case:
if ( k .eq. m ) then
isii = -1
ik = j
ij = k
im = m
in = n
elseif ( j .eq. m ) then
isii = +1
ik = k
ij = j
im = m
in = n
elseif ( j .eq. n ) then
isii = -1
ik = k
ij = j
im = n
in = m
elseif ( k .eq. n ) then
isii = +1
ik = j
ij = k
im = n
in = m
else
goto 50
endif
if ( ij .eq. im .and. i .le. 4 .and. ij .le. 4 .and. in .le. 4 )
+ then
if ( inx(ij,i) .gt. 0 .and. inx(im,l) .gt. 0 ) then
if ( abs(dpipj(i,inx(ij,i))) .lt. xloss*abs(xpi(ij))
+ .and. abs(dpipj(l,inx(im,l))) .lt. xloss*abs(xpi(im)) )
+ then
s(1) = piDpj(l,in)*piDpj(ik,ij)*dpipj(i,inx(ij,i))/2
s(2) = isgn(ij,i)*piDpj(l,in)*xpi(ij)*piDpj(ik,
+ inx(ij,i))/2
s(3) = -piDpj(i,ij)*piDpj(ik,in)*piDpj(l,im)
s(4) = piDpj(i,ik)*piDpj(im,in)*dpipj(l,inx(im,l))/2
s(5) = isgn(im,l)*piDpj(i,ik)*xpi(im)*piDpj(in,
+ inx(im,l))/2
del2d2 = s(1) + s(2) + s(3) + s(4) + s(5)
if ( isii .lt. 0 ) del2d2 = -del2d2
smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)),
+ abs(s(5)))
if ( abs(del2d2) .ge. xloss**2*abs(smax) ) goto 60
if ( smax .lt. xmax ) then
som = del2d2
xmax = smax
endif
endif
endif
endif
50 continue
*
* give up
*
del2d2 = som
60 continue
* #] calculations:
*###] ff2dl2:
end
*###[ ff2d22:
subroutine ff2d22(dl2d22,xpi,dpipj,piDpj, i, j,k,kj,iskj,
+ m,n,nm,isnm)
***#[*comment:***********************************************************
* *
* Calculate *
* *
* / si mu mu nu \2 *
* |d d | *
* \ sj sk sm sn / *
* *
* = si.sj^2*sk.sm^2*sn.sn *
* - 2*si.sj^2*sk.sm*sk.sn*sm.sn *
* + si.sj^2*sk.sn^2*sm.sm *
* - 2*si.sj*si.sk*sj.sm*sk.sm*sn.sn *
* + 2*si.sj*si.sk*sj.sm*sk.sn*sm.sn *
* + 2*si.sj*si.sk*sj.sn*sk.sm*sm.sn *
* - 2*si.sj*si.sk*sj.sn*sk.sn*sm.sm *
* + si.sk^2*sj.sm^2*sn.sn *
* - 2*si.sk^2*sj.sm*sj.sn*sm.sn *
* + si.sk^2*sj.sn^2*sm.sm *
* *
* Input: xpi(ns) as usual *
* dpipj(ns,ns) -"- *
* piDpj(ns,ns) -"- *
* i,j,k,kj,iskj see above *
* m,n,nm,isnm -"- *
* *
* Output: dl2d22 see above *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer i,j,k,kj,iskj,m,n,nm,isnm
DOUBLE PRECISION dl2d22,xpi(10),dpipj(10,10),piDpj(10,10)
*
* local variables:
*
integer ii,isii
DOUBLE PRECISION s(10),del2s,del23,del24,del27,som,smax,xmax
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ special cases:
if ( i .eq. n .or. i .eq. m ) then
call ffdl2s(del2s,piDpj, j,k,kj,iskj, m,n,nm,isnm, 10)
dl2d22 = xpi(i)*del2s**2
return
endif
* #] special cases:
* #[ calculations:
* We use the product form
if ( i .eq. 3 ) then
del23 = 0
elseif ( i .le. 4 ) then
ii = inx(3,i)
isii = isgn(3,i)
call ffdl2s(del23,piDpj,i,3,ii,isii,j,k,kj,iskj,10)
else
call ffdl2t(del23,piDpj,i,3,j,k,kj,iskj,+1,10)
endif
if ( i .eq. 4 ) then
del24 = 0
elseif ( i .le. 4 ) then
ii = inx(n,i)
isii = isgn(n,i)
call ffdl2s(del24,piDpj,i,4,ii,isii,j,k,kj,iskj,10)
else
call ffdl2t(del24,piDpj,i,4,j,k,kj,iskj,+1,10)
endif
s(1) = xpi(4)*del23**2
s(2) = -2*piDpj(3,4)*del23*del24
s(3) = xpi(3)*del24**2
dl2d22 = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( abs(dl2d22) .ge. xloss*smax ) goto 110
som = dl2d22
xmax = smax
* try the special case k=4 (for use in ee->mumu among others)
if ( i .lt. 4 .and. k .eq. 4 .and. abs(s(3)) .lt. xloss*smax
+ .and. ( abs(dpipj(i,inx(4,i))) .lt. xloss*xpi(i) .or.
+ abs(piDpj(j,inx(4,i))) .lt. xloss*abs(piDpj(j,4)) ) )
+ then
s(1) = -del23*piDpj(i,4)*piDpj(j,3)*xpi(4)
s(2) = del23*dpipj(i,inx(4,i))*piDpj(j,4)*piDpj(3,4)
s(4) = del23*piDpj(3,4)*xpi(4)*piDpj(j,inx(4,i))*isgn(4,i)
dl2d22 = s(1) + s(2) + s(3) + s(4)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)),abs(s(4)))
if ( abs(dl2d22) .ge. xloss*smax ) goto 110
if ( smax .lt. xmax ) then
som = dl2d22
xmax = smax
endif
endif
call ffdl2t(del27,piDpj,i,7,j,k,kj,iskj,+1,10)
s(1) = xpi(7)*del24**2
s(2) = -2*piDpj(4,7)*del24*del27
s(3) = xpi(4)*del27**2
dl2d22 = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( abs(dl2d22) .ge. xloss*smax ) goto 110
if ( smax .lt. xmax ) then
som = dl2d22
xmax = smax
endif
s(1) = xpi(7)*del23**2
s(2) = -2*piDpj(3,7)*del23*del27
s(3) = xpi(3)*del27**2
dl2d22 = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( abs(dl2d22) .ge. xloss*smax ) goto 110
*
* We'll have to think of something more intelligent ...
*
if ( smax .lt. xmax ) then
som = dl2d22
xmax = smax
endif
dl2d22 = som
110 continue
* #] calculations:
*###] ff2d22:
end
*###[ ff3dl2:
subroutine ff3dl2(del3d2,xpi,dpipj,piDpj, i,
+ j,k,kj,iskj, l,m,ml,isml, n, o,p,po,ispo, ier)
***#[*comment:***********************************************************
* *
* Calculate *
* *
* si mu mu nu mu sn *
* d d d = ... *
* sj sk sl sm so sp *
* *
* with p(kj) = iskj*(sk-sj) *
* p(ml) = isml*(sm-sl) *
* p(po) = ispo*(sp-so) *
* *
* Input: xpi(ns) as usual *
* dpipj(ns,ns) -"- *
* piDpj(ns,ns) -"- *
* i,j,k,kj,iskj see above *
* l,m,ml,isml -"- *
* n,o,p,po,ispo -"- *
* *
* Output: del3d2 see above *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer i,j,k,kj,iskj,l,m,ml,isml,n,o,p,po,ispo,ier
DOUBLE PRECISION del3d2,xpi(10),dpipj(10,10),piDpj(10,10)
*
* local variables:
*
integer isii,ii
DOUBLE PRECISION s(2),dl2il,dl2im,dl2ln,dl2mn,dl2iml,dl2mln
DOUBLE PRECISION d2d2j,d2d2k,d2d2kj,dum,d2d2o,d2d2p,d2d2po
DOUBLE PRECISION som,xmax
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ split up l,m:
if ( i .eq. l ) then
dl2il = 0
elseif ( i .le. 4 ) then
ii = inx(l,i)
isii = isgn(l,i)
call ffdl2s(dl2il,piDpj,i,l,ii,isii,j,k,kj,iskj,10)
else
call ffdl2t(dl2il,piDpj,i,l,j,k,kj,iskj,+1,10)
endif
if ( m .eq. n ) then
dl2mn = 0
elseif ( i .le. 4 ) then
ii = inx(n,m)
isii = isgn(n,m)
call ffdl2s(dl2mn,piDpj,m,n,ii,isii,o,p,po,ispo,10)
else
call ffdl2t(dl2mn,piDpj,m,n,o,p,po,ispo,+1,10)
endif
s(1) = dl2il*dl2mn
if ( i .eq. m ) then
dl2im = 0
elseif ( i .le. 4 ) then
ii = inx(m,i)
isii = isgn(m,i)
call ffdl2s(dl2im,piDpj,i,m,ii,isii,j,k,kj,iskj,10)
else
call ffdl2t(dl2im,piDpj,i,m,j,k,kj,iskj,+1,10)
endif
if ( l .eq. n ) then
dl2ln = 0
elseif ( i .le. 4 ) then
ii = inx(n,l)
isii = isgn(n,l)
call ffdl2s(dl2ln,piDpj,l,n,ii,isii,o,p,po,ispo,10)
else
call ffdl2t(dl2ln,piDpj,l,n,o,p,po,ispo,+1,10)
endif
s(2) = dl2im*dl2ln
del3d2 = s(1) - s(2)
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
som = del3d2
xmax = abs(s(1))
*
* rotate l,m
*
call ffdl2t(dl2mln,piDpj,ml,n,o,p,po,ispo,+1,10)
call ffdl2t(dl2iml,piDpj,i,ml,j,k,kj,iskj,+1,10)
s(1) = dl2im*dl2mln
s(2) = dl2iml*dl2mn
del3d2 = isml*(s(1) - s(2))
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
if ( abs(s(1)) .lt. xmax ) then
som = del3d2
xmax = abs(s(1))
endif
s(1) = dl2il*dl2mln
s(2) = dl2iml*dl2ln
del3d2 = isml*(s(1) - s(2))
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
if ( abs(s(1)) .lt. xmax ) then
som = del3d2
xmax = abs(s(1))
endif
* #] split up l,m:
* #[ split up j,k:
call ff2dl2(d2d2k,dum,xpi,dpipj,piDpj, k, l,m,ml,isml, n,
+ o,p,po,ispo, 10, ier)
call ff2dl2(d2d2j,dum,xpi,dpipj,piDpj, j, l,m,ml,isml, n,
+ o,p,po,ispo, 10, ier)
s(1) = piDpj(i,j)*d2d2k
s(2) = piDpj(i,k)*d2d2j
del3d2 = s(1) - s(2)
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
if ( abs(s(1)) .lt. xmax ) then
som = del3d2
xmax = abs(s(1))
endif
call ff2dl2(d2d2kj,dum,xpi,dpipj,piDpj, kj, l,m,ml,isml, n,
+ o,p,po,ispo, 10, ier)
s(1) = piDpj(i,k)*d2d2kj
s(2) = piDpj(i,kj)*d2d2k
del3d2 = iskj*(s(1) - s(2))
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
if ( abs(s(1)) .lt. xmax ) then
som = del3d2
xmax = abs(s(1))
endif
s(1) = piDpj(i,j)*d2d2kj
s(2) = piDpj(i,kj)*d2d2j
del3d2 = iskj*(s(1) - s(2))
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
if ( abs(s(1)) .lt. xmax ) then
som = del3d2
xmax = abs(s(1))
endif
* #] split up j,k:
* #[ split up o,p:
call ff2dl2(d2d2o,dum,xpi,dpipj,piDpj, i, j,k,kj,iskj, o,
+ l,m,ml,isml, 10, ier)
call ff2dl2(d2d2p,dum,xpi,dpipj,piDpj, i, j,k,kj,iskj, p,
+ l,m,ml,isml, 10, ier)
s(1) = piDpj(p,n)*d2d2o
s(2) = piDpj(o,n)*d2d2p
del3d2 = s(1) - s(2)
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
if ( abs(s(1)) .lt. xmax ) then
som = del3d2
xmax = abs(s(1))
endif
call ff2dl2(d2d2po,dum,xpi,dpipj,piDpj, i, j,k,kj,iskj, po,
+ l,m,ml,isml, 10, ier)
s(1) = piDpj(po,n)*d2d2p
s(2) = piDpj(p,n)*d2d2po
del3d2 = ispo*(s(1) - s(2))
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
if ( abs(s(1)) .lt. xmax ) then
som = del3d2
xmax = abs(s(1))
endif
s(1) = piDpj(po,n)*d2d2o
s(2) = piDpj(o,n)*d2d2po
del3d2 = ispo*(s(1) - s(2))
if ( abs(del3d2) .ge. xloss*abs(s(1)) ) return
if ( abs(s(1)) .lt. xmax ) then
som = del3d2
xmax = abs(s(1))
endif
* #] split up o,p:
* #[ give up:
del3d2 = som
* #] give up:
*###] ff3dl2:
end
diff --git a/Looptools/util/ffabcd.F b/Looptools/util/ffabcd.F
--- a/Looptools/util/ffabcd.F
+++ b/Looptools/util/ffabcd.F
@@ -1,233 +1,247 @@
+#include "externals.h"
+
+
*###[ ffabcd:
subroutine ffabcd(aijkl,xpi,dpipj,piDpj,del2s,sdel2s,
+ in,jn,jin,isji, kn,ln,lkn,islk, ifirst, ier)
***#[*comment:***********************************************************
* *
* Calculate the a,b,c,d of the equation for qij.qkl *
* *
* a = s4.s4^2 *
* *
* si sj sk sl / sm sn sm sn sm sn mu ro\ *
* -b/2 = d d |d d - d s4 s4 | *
* mu nu nu ro \ mu s4 ro s4 sm sn / *
* *
* _ si sj sk sl / mu s4 ro mu s4 ro\ *
* vD/2 = d d |d s4 + d s4 | *
* mu nu nu ro \ s3 s4 s3 s4 / *
* *
* with sm = s3, sn = s4 *
* p(jin) = isji*(sj-si) *
* p(lkn) = islk*(sl-sk) *
* *
* Input: xpi(ns) as usual *
* dpipj(ns,ns) -"- *
* piDpj(ns,ns) -"- *
* in,jn,jin,isjn see above *
* kn,ln,lkn,islk see above *
* *
* Output: del4d2 see above *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer in,jn,jin,isji,kn,ln,lkn,islk,ifirst,
+ ier
DOUBLE PRECISION aijkl,xpi(10),dpipj(10,10),piDpj(10,10),del2s
DOUBLE PRECISION sdel2s
*
* local variables:
*
integer i,j,ji,k,l,lk,isii
integer ii
integer iii(6,2)
save iii
logical ldet(4)
DOUBLE PRECISION xa,xb,xc,xd,s(24),del3(4),som,somb,somd,
+ smax,save,xmax,del2d2,dum,del2i,del2j,
+ del2ji,d2d2i,d2d2j,d2d2ji
save del3,ldet
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data iii / 0,3,4,0,7,0,
+ 0,3,4,0,7,0/
* #] declarations:
* #[ initialisaties:
if ( ifirst .eq. 0 ) then
ifirst = ifirst + 1
ldet(2) = .FALSE.
ldet(3) = .FALSE.
ldet(4) = .FALSE.
endif
xa = xpi(4)**2
* #] initialisaties:
* #[ prepare input:
i = in
j = jn
ji = jin
k = kn
l = ln
lk = lkn
* #] prepare input:
* #[ special cases:
if ( k .eq. 3 ) then
xb = 0
xc = 0
xd = 0
goto 990
elseif ( j .ge. 3 .and. l .ge. 3 ) then
* the whole thing collapses to factor*det3
* we have a good memory of things already calculated ...
if ( .not.ldet(i+k) ) then
ldet(i+k) = .TRUE.
iii(1,1) = i
iii(4,1) = isgn(3,i)*inx(3,i)
iii(6,1) = isgn(i,4)*inx(i,4)
iii(1,2) = k
iii(4,2) = isgn(3,k)*inx(3,k)
iii(6,2) = isgn(k,4)*inx(k,4)
call ffdl3s(del3(i+k),piDpj,iii,10)
endif
if ( l .eq. 4 .and. j .eq. 4 ) then
xb = xpi(4)**2*del3(i+k)/del2s
xd = 0
xc = xb**2/xa
elseif ( l .eq. 4 .or. j .eq. 4 ) then
xb = piDpj(3,4)*xpi(4)*del3(i+k)/del2s
xd = -xpi(4)*del3(i+k)/sdel2s
xc = xpi(4)*xpi(3)*del3(i+k)**2/del2s**2
else
* l .eq. 3 .and. j .eq. 3
xd = -2*piDpj(3,4)*del3(i+k)/sdel2s
s(1) = xpi(3)*xpi(4)
s(2) = 2*piDpj(3,4)**2
som = s(2) - s(1)
xb = som*del3(i+k)/del2s
xc = xpi(3)**2*del3(i+k)**2/del2s**2
endif
goto 900
endif
if ( j .eq. 2 .and. l .eq. 4 ) then
call ff3dl2(s(1),xpi,dpipj,piDpj, 4, 1,2,5,+1,
+ k,3,inx(3,k),isgn(3,k), 4, 3,4,7,+1, ier)
xb = -xpi(4)*s(1)/del2s
iii(1,1) = 1
iii(2,1) = 2
iii(4,1) = 5
iii(5,1) = 10
iii(6,1) = 8
iii(1,2) = k
iii(4,2) = isgn(3,k)*inx(3,k)
iii(6,2) = isgn(k,4)*inx(k,4)
call ffdl3s(s(1),piDpj,iii,10)
* restore values for other users
iii(2,1) = 3
iii(5,1) = 7
xd = -xpi(4)*s(1)/sdel2s
goto 800
endif
* #] special cases:
* #[ normal case b:
*
* First term:
*
call ff2dl2(del2d2,dum,xpi,dpipj,piDpj, 4,
+ i,j,ji,isji, 4, k,l,lk,islk, 10, ier)
s(1) = -del2d2*del2s
*
* Second and third term, split i,j
*
if ( i .eq. 4 ) then
del2i = 0
else
ii = inx(4,i)
isii = isgn(4,i)
call ffdl2s(del2i,piDpj,i,4,ii,isii,3,4,7,+1,10)
endif
if ( j .eq. 4 ) then
del2j = 0
else
ii = inx(4,j)
isii = isgn(4,j)
call ffdl2s(del2j,piDpj,j,4,ii,isii,3,4,7,+1,10)
endif
call ff2dl2(d2d2i,dum,xpi,dpipj,piDpj, i, k,l,lk,islk, 4,
+ 3,4,7,+1, 10, ier)
call ff2dl2(d2d2j,dum,xpi,dpipj,piDpj, j, k,l,lk,islk, 4,
+ 3,4,7,+1, 10, ier)
s(2) = +del2i*d2d2j
s(3) = -del2j*d2d2i
somb = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( abs(somb) .ge. xloss*smax ) goto 90
xmax = smax
save = somb
* if the first term is wrong ... forget about it
if ( abs(somb) .lt. xloss*abs(s(1)) ) goto 80
call ffdl2t(del2ji,piDpj, ji,4, 3,4,7,+1,+1, 10)
call ff2dl2(d2d2ji,dum,xpi,dpipj,piDpj, ji, k,l,lk,islk, 4,
+ 3,4,7,+1, 10, ier)
s(2) = +del2j*d2d2ji
s(3) = -del2ji*d2d2j
somb = s(1) + isji*(s(2) + s(3))
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( abs(somb) .ge. xloss*smax ) goto 90
if ( smax .lt. xmax ) then
save = somb
xmax = smax
endif
s(2) = +del2i*d2d2ji
s(3) = -del2ji*d2d2i
somb = s(1) + isji*(s(2) + s(3))
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( abs(somb) .ge. xloss*max(abs(s(1)),abs(s(2)),abs(s(3))) )
+ goto 90
if ( smax .lt. xmax ) then
save = somb
xmax = smax
endif
80 continue
*
* give up:
*
somb = save
90 continue
xb = somb/del2s
* #] normal case b:
* #[ normal case d:
call ff3dl2(s(1),xpi,dpipj,piDpj, 4, i,j,ji,isji, k,l,lk,islk,
+ 4, 3,4,7,+1, ier)
if ( i .eq. k .and. j .eq. l ) then
somd = -2*s(1)
else
call ff3dl2(s(2),xpi,dpipj,piDpj, 4, k,l,lk,islk,
+ i,j,ji,isji, 4, 3,4,7,+1, ier)
somd = - s(1) - s(2)
endif
xd = -somd/sdel2s
* #] normal case d:
* #[ normal case c:
800 continue
s(1) = xb - xd
s(2) = xb + xd
+*** vvv Added 11 Feb 08:
+ smax = abs(abs(xb) - abs(xd))
+ xmax = xloss*max(abs(xb), abs(xd))
+ if( smax .lt. xmax .and. xmax .gt. 0 ) then
+ if( smax .ne. 0 ) then
+ ier = ier + int(log10(xmax/smax))
+ else
+ ier = ier + int(log10(xmax/xclogm))
+ endif
+ endif
+*** ^^^
som = s(1)*s(2)
xc = som/xa
* #] normal case c:
900 continue
* #[ and the final answer:
990 continue
call ffroot(dum,aijkl,xa,xb,xc,xd,ier)
-* #] and tne final answer:
+* #] and the final answer:
*###] ffabcd:
end
diff --git a/Looptools/util/ffbndc.F b/Looptools/util/ffbndc.F
--- a/Looptools/util/ffbndc.F
+++ b/Looptools/util/ffbndc.F
@@ -1,24 +1,27 @@
+#include "externals.h"
+
+
*###[ ffbndc:
DOUBLE PRECISION function ffbndc(n1,n2,carray)
*************************************************************************
* *
* calculate bound = (precc*|a(n1)/a(n1+n2)|^(1/n2) which is the *
* maximum value of x in a series expansion sum_(i=n1)^(n1+n2) *
* a(i)*x(i) to give a result of accuracy precc (actually of |next *
* term| < prec *
* *
*************************************************************************
implicit none
integer n1,n2
DOUBLE COMPLEX carray(n1+n2)
- include 'ff.h'
+#include "ff.h"
if ( carray(n1+n2) .eq. 0 ) then
print *,'ffbnd: fatal: array not intialized; did you call ',
+ 'ffini?'
stop
endif
ffbndc = (precc*abs(carray(n1)/carray(n1+n2)))**(1/DBLE(n2))
*###] ffbndc:
end
diff --git a/Looptools/util/ffcli2.F b/Looptools/util/ffcli2.F
--- a/Looptools/util/ffcli2.F
+++ b/Looptools/util/ffcli2.F
@@ -1,561 +1,564 @@
+#include "externals.h"
+
+
*###[ ffzli2:
subroutine ffzli2(zdilog,zlog,cx,ier)
***#[*comment:***********************************************************
* *
* Computes the dilogarithm (Li2, Sp) for any (complex) cx *
* to a precision precc. It assumes that cx is already in the *
* area |cx|<=1, Re(cx)<=1/2. As it is available it also returns *
* log(1-cx) = zlog. *
* *
* Input: cx (complex) *
* *
* Output: zdilog (complex) Li2(cx) *
* zlog (complex) log(1-cx) = -Li1(cx) *
* ier (integer) 0=OK,1=num,2=err *
* *
* Calls: log,zfflo1,(d/a)imag,real/dble *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE COMPLEX cx,zlog,zdilog
*
* local variables
*
DOUBLE PRECISION xprec,bdn02,bdn05,bdn10,bdn15,
+ xi,xr,xdilog,xlog,absc,xa,a,ffbnd
DOUBLE COMPLEX cc,cz,cz2,zfflo1
external ffbnd,zfflo1
save xprec,bdn02,bdn05,bdn10,bdn15
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
* #] declarations:
* #[ initialisations:
data xprec /-1D0/
if ( xprec .ne. precc ) then
xprec = precc
bdn02 = ffbnd(1,2,bf)
bdn05 = ffbnd(1,5,bf)
bdn10 = ffbnd(1,10,bf)
bdn15 = ffbnd(1,15,bf)
* we don't have bf(21) ...
endif
* #] initialisations:
* #[ exceptional cases:
xi = DIMAG(cx)
xr = DBLE(cx)
if ( xi .eq. 0) then
call ffxli2(xdilog,xlog,xr,ier)
zdilog = xdilog
zlog = xlog
return
endif
xa = abs(xi) + abs(xr)
if ( xa .lt. precc ) then
zdilog = cx
zlog = -cx
return
endif
* #] exceptional cases:
* #[ get log,dilog:
if ( xa .lt. xloss**2 ) then
zlog = zfflo1(cx,ier)
else
zlog = log(1-cx)
endif
cz = -zlog
if ( absc(cz) .lt. xclog2 ) then
zdilog = cz
else
cz2 = cz*cz
a = xa**2
if ( a .gt. bdn15 ) then
zdilog = cz2*(DBLE(bf(16)) + cz2*(DBLE(bf(17))
+ + cz2*(DBLE(bf(18)) + cz2*(DBLE(bf(19))
+ + cz2*(DBLE(bf(20)))))))
else
zdilog = 0
endif
if ( a .gt. bdn10 ) then
zdilog = cz2*(DBLE(bf(11)) + cz2*(DBLE(bf(12))
+ + cz2*(DBLE(bf(13)) + cz2*(DBLE(bf(14))
+ + cz2*(DBLE(bf(15)) + zdilog)))))
endif
if ( a .gt. bdn05 ) then
zdilog = cz2*(DBLE(bf(6)) + cz2*(DBLE(bf(7))
+ + cz2*(DBLE(bf(8)) + cz2*(DBLE(bf(9))
+ + cz2*(DBLE(bf(10)) + zdilog)))))
endif
if ( a .gt. bdn02 ) then
zdilog = cz2*(DBLE(bf(3)) + cz2*(DBLE(bf(4))
+ + cz2*(DBLE(bf(5)) + zdilog)))
endif
* watch the powers of z.
zdilog = cz + cz2*(DBLE(bf(1)) + cz*(DBLE(bf(2)) + zdilog))
endif
* #] get log,dilog:
*###] ffzli2:
end
*###[ ffzzdl:
subroutine ffzzdl(zdilog,ipi12,zlog,cx,ier)
***#[*comment:***************************************************
* *
* Computes the dilogarithm (Li2, Sp) for any (complex) cx *
* to about 15 significant figures. This can be improved *
* by adding more of the bf's. For real cx > 1 an error is *
* generated as the imaginary part is undefined then. *
* For use in ffcdbd zlog = log(1-cx) is also calculated *
* *
* Input: cx (complex) *
* *
* Output: zdilog (complex) Li2(cx) mod factors pi^2/12 *
* ipi12 (integer) these factors *
* zlog (complex) log(1-cx) *
* *
* Calls: log,zfflo1,(d/a)imag,real/dble *
* *
***#]*comment:***************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ipi12,ier
DOUBLE COMPLEX zdilog,zlog,cx
*
* local variables
*
integer jsgn
DOUBLE PRECISION xprec,bdn02,bdn05,bdn10,bdn15,
+ xi,xr,s1,s2,xa,a,absc,ffbnd
DOUBLE COMPLEX cfact,cx1,cy,cz,cz2,zfflo1,c
external ffbnd,zfflo1
save xprec,bdn02,bdn05,bdn10,bdn15
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ initialisations:
data xprec /-1D0/
if ( xprec .ne. precc ) then
xprec = precc
bdn02 = ffbnd(1,2,bf)
bdn05 = ffbnd(1,5,bf)
bdn10 = ffbnd(1,10,bf)
bdn15 = ffbnd(1,15,bf)
endif
* #] initialisations:
* #[ exceptional cases:
xi = DIMAG(cx)
xr = DBLE(cx)
if ( xi .eq. 0 ) then
if ( xr .gt. 1 ) call fferr(31,ier)
call ffzxdl(zdilog,ipi12,zlog,xr,1,ier)
return
endif
if ( abs(xi) .lt. xalog2 ) then
s1 = 0
else
s1 = xi**2
endif
if ( abs(xr) .lt. xalog2 ) then
s2 = 0
else
s2 = xr**2
endif
xa = sqrt(s1 + s2)
if ( xa .lt. precc ) then
zdilog = cx
zlog = -cx
ipi12 = 0
return
endif
* #] exceptional cases:
* #[ transform to |x|<1, Re(x) < 0.5:
if ( xr .le. .5D0) then
if (xa .gt. 1) then
if ( 1/xa .lt. xalogm ) then
cfact = 0
elseif ( 1/xa .lt. xclogm ) then
cx1 = cx*DBLE(1/xa)
cfact = log(-cx1) + log(DBLE(xa))
else
cfact = log(-cx)
endif
cy = - cfact**2/2
ipi12 = -2
if ( xa*xloss**2 .gt. 1) then
if ( 1/xa .lt. xclogm ) then
cx1 = cx*DBLE(1/xa)
cx1 = 1/cx1
cx1 = cx1*DBLE(1/xa)
else
cx1 = 1/cx
endif
cz = -zfflo1(cx1,ier)
else
cz = -log(1-1/cx)
endif
zlog = log(1-cx)
jsgn = -1
else
cy = 0
ipi12 = 0
if ( xa .lt. xloss**2 ) then
zlog = zfflo1(cx,ier)
else
zlog = log(1-cx)
endif
cz = -zlog
jsgn = 1
endif
else
if (xa .le. sqrt(2*xr)) then
cz = -log(cx)
if ( abs(xr-1) + abs(xi) .lt. xclogm ) then
cy = 0
else
zlog = log(1-cx)
cy = cz*zlog
endif
ipi12 = 2
jsgn = -1
else
if ( 1/xa .lt. xalogm ) then
cfact = 0
elseif ( 1/xa .lt. xclogm ) then
cx1 = cx*DBLE(1/xa)
cfact = log(-cx1) + log(DBLE(xa))
else
cfact = log(-cx)
endif
cy = - cfact**2/2
ipi12 = -2
if ( xa*xloss .gt. 1) then
if ( 1/xa .lt. xclogm ) then
cx1 = cx*DBLE(1/xa)
cx1 = 1/cx1
cx1 = cx1*DBLE(1/xa)
else
cx1 = 1/cx
endif
cz = -zfflo1(cx1,ier)
else
cz = -log(1-1/cx)
endif
zlog = log(1-cx)
jsgn = -1
endif
endif
* #] transform to |x|<1, Re(x) < 0.5:
* #[ get dilog:
if ( absc(cz) .lt. xclogm ) then
zdilog = cz
else
cz2 = cz*cz
a = DBLE(cz)**2 + DIMAG(cz)**2
if ( a .gt. bdn15 ) then
zdilog = cz2*(DBLE(bf(16)) + cz2*(DBLE(bf(17))
+ + cz2*(DBLE(bf(18)) + cz2*(DBLE(bf(19))
+ + cz2*(DBLE(bf(20)))))))
else
zdilog = 0
endif
if ( a .gt. bdn10 ) then
zdilog = cz2*(DBLE(bf(11)) + cz2*(DBLE(bf(12))
+ + cz2*(DBLE(bf(13)) + cz2*(DBLE(bf(14))
+ + cz2*(DBLE(bf(15)) + zdilog)))))
endif
if ( a .gt. bdn05 ) then
zdilog = cz2*(DBLE(bf(6)) + cz2*(DBLE(bf(7))
+ + cz2*(DBLE(bf(8)) + cz2*(DBLE(bf(9))
+ + cz2*(DBLE(bf(10)) + zdilog)))))
endif
if ( a .gt. bdn02 ) then
zdilog = cz2*(DBLE(bf(3)) + cz2*(DBLE(bf(4))
+ + cz2*(DBLE(bf(5)) + zdilog)))
endif
* watch the powers of z.
zdilog = cz + cz2*(DBLE(bf(1)) + cz*(DBLE(bf(2)) + zdilog))
endif
if(jsgn.eq.1)then
zdilog = zdilog + cy
else
zdilog = -zdilog + cy
endif
* #] get dilog:
*###] ffzzdl:
end
*###[ zfflog:
DOUBLE COMPLEX function zfflog(cx,ieps,cy,ier)
***#[*comment:***********************************************************
* *
* Calculate the complex logarithm of cx. The following cases *
* are treted separately: *
* |cx| too small: give warning and return 0 *
* (for Absoft, Apollo DN300) *
* Im(cx) = 0, Re(cx) < 0: take sign according to ieps *
* *
***#]*comment:***********************************************************
* #[ declarations:
*
* arguments
*
implicit none
integer ieps,ier
DOUBLE COMPLEX cx,cy
*
* local variables
*
DOUBLE COMPLEX c,ctroep
DOUBLE PRECISION absc,xa,xlog1p
*
* common blocks, statement function
*
- include 'ff.h'
+#include "ff.h"
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ calculations:
xa = absc(cx)
if ( xa .lt. xalogm ) then
if ( cx .ne. 0 ) call fferr(23,ier)
zfflog = 0
elseif ( DBLE(cx) .lt. 0 .and. DIMAG(cx) .eq. 0 ) then
* + abs(DIMAG(cx)) .lt. precc*abs(DBLE(cx)) ) then
xlog1p = log(-DBLE(cx))
* checked imaginary parts 19-May-1988
if ( abs(ieps) .eq. 1 ) then
if ( ieps*DBLE(cy) .lt. 0 ) then
zfflog = DCMPLX(xlog1p,-pi)
elseif ( ieps*DBLE(cy) .gt. 0 ) then
zfflog = DCMPLX(xlog1p,pi)
else
call fferr(51,ier)
zfflog = DCMPLX(xlog1p,pi)
endif
elseif ( ieps .ge. 2 .and. ieps .le. 3 ) then
zfflog = DCMPLX(xlog1p,-pi)
elseif ( ieps .le. -2 .and. ieps .ge. -3 ) then
zfflog = DCMPLX(xlog1p,pi)
else
call fferr(51,ier)
zfflog = DCMPLX(xlog1p,pi)
endif
elseif ( xa .lt. xclogm .or. 1/xa .lt. xclogm ) then
ctroep = cx*DBLE(1/xa)
zfflog = log(ctroep) + DBLE(log(xa))
else
* print *,'zfflog: neem log van ',cx
zfflog = log(cx)
endif
* #] calculations:
*###] zfflog:
end
*###[ zfflo1:
DOUBLE COMPLEX function zfflo1(cx,ier)
***#[*comment:***************************************************
* calculates log(1-x) for |x|<.14 in a faster way to ~15 *
* significant figures. *
***#]*comment:***************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE COMPLEX cx,c,zfflog
DOUBLE PRECISION xprec,bdn01,bdn05,bdn10,bdn15,bdn19,
+ absc,xa,ffbnd
external zfflog,ffbnd
save xprec,bdn01,bdn05,bdn10,bdn15,bdn19
- include 'ff.h'
+#include "ff.h"
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ initialisations:
data xprec /-1D0/
if ( precc .ne. xprec ) then
xprec = precc
* determine the boundaries for 1,5,10,15 terms
bdn01 = ffbnd(1,1,xninv)
bdn05 = ffbnd(1,5,xninv)
bdn10 = ffbnd(1,10,xninv)
bdn15 = ffbnd(1,15,xninv)
bdn19 = ffbnd(1,19,xninv)
endif
* #] initialisations:
* #[ calculations:
xa = absc(cx)
if ( xa .gt. bdn19 ) then
c = cx-1
xa = absc(c)
zfflo1 = zfflog(1-cx,0,czero,ier)
return
endif
if ( xa .gt. bdn15 ) then
zfflo1 = cx*( DBLE(xninv(16)) + cx*( DBLE(xninv(17))
+ + cx*( DBLE(xninv(18)) + cx*( DBLE(xninv(19))
+ + cx*( DBLE(xninv(20)) )))))
else
zfflo1 = 0
endif
if ( xa .gt. bdn10 ) then
zfflo1 = cx*( DBLE(xninv(11)) + cx*( DBLE(xninv(12))
+ + cx*( DBLE(xninv(13)) + cx*( DBLE(xninv(14))
+ + cx*( DBLE(xninv(15)) + zfflo1 )))))
endif
if ( xa .gt. bdn05 ) then
zfflo1 = cx*( DBLE(xninv(6)) + cx*( DBLE(xninv(7))
+ + cx*( DBLE(xninv(8)) + cx*( DBLE(xninv(9))
+ + cx*( DBLE(xninv(10)) + zfflo1 )))))
endif
if ( xa .gt. bdn01 ) then
zfflo1 = cx*( DBLE(xninv(2)) + cx*( DBLE(xninv(3))
+ + cx*( DBLE(xninv(4)) + cx*( DBLE(xninv(5))
+ + zfflo1 ))))
endif
zfflo1 = - cx*( DBLE(xninv(1)) + zfflo1 )
* #] calculations:
*###] zfflo1:
end
*###[ zfflo2:
DOUBLE COMPLEX function zfflo2(x,ier)
***#[*comment:***************************************************
* calculates log(1-x)+x for |x|<.14 in a faster way to *
* ~15 significant figures. *
***#]*comment:***************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE COMPLEX x,zfflo1,cc
DOUBLE PRECISION bdn01,bdn05,bdn10,bdn15,bdn18,xprec,xa,
+ ffbnd,absc
external ffbnd,zfflo1
save xprec,bdn01,bdn05,bdn10,bdn15,bdn18
- include 'ff.h'
+#include "ff.h"
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
* #] declarations:
* #[ initialisation:
data xprec /-1D0/
if ( xprec .ne. precc ) then
xprec = precx
precx = precc
* determine the boundaries for 1,5,10,15 terms
bdn01 = ffbnd(1,1,xninv(2))
bdn05 = ffbnd(1,5,xninv(2))
bdn10 = ffbnd(1,10,xninv(2))
bdn15 = ffbnd(1,15,xninv(2))
bdn18 = ffbnd(1,18,xninv(2))
precx = xprec
xprec = precc
endif
* #] initialisation:
* #[ calculations:
xa = absc(x)
if ( xa .gt. bdn18 ) then
zfflo2 = zfflo1(x,ier) + x
return
endif
if ( xa .gt. bdn15 ) then
zfflo2 = x*( DBLE(xninv(17)) + x*( DBLE(xninv(18)) +
+ x*( DBLE(xninv(19)) + x*( DBLE(xninv(20)) ))))
else
zfflo2 = 0
endif
if ( xa .gt. bdn10 ) then
zfflo2 = x*( DBLE(xninv(12)) + x*( DBLE(xninv(13)) +
+ x*( DBLE(xninv(14)) + x*( DBLE(xninv(15)) +
+ x*( DBLE(xninv(16)) + zfflo2 )))))
endif
if ( xa .gt. bdn05 ) then
zfflo2 = x*( DBLE(xninv(7)) + x*( DBLE(xninv(8)) +
+ x*( DBLE(xninv(9)) +x*( DBLE(xninv(10)) +
+ x*( DBLE(xninv(11)) + zfflo2 )))))
endif
if ( xa .gt. bdn01 ) then
zfflo2 = x*( DBLE(xninv(3)) + x*( DBLE(xninv(4)) +
+ x*( DBLE(xninv(5)) + x*( DBLE(xninv(6)) + zfflo2 ))))
endif
zfflo2 = - x**2*( DBLE(xninv(2)) + zfflo2 )
* #] calculations:
*###] zfflo2:
end
*###[ zfflo3:
DOUBLE COMPLEX function zfflo3(x,ier)
***#[*comment:***************************************************
* calculates log(1-x)+x+x^2/2 for |x|<.14 in a faster *
* way to ~15 significant figures. *
***#]*comment:***************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE COMPLEX x,zfflo2,cc
DOUBLE PRECISION bdn01,bdn05,bdn10,bdn15,xprec,xa,ffbnd,
+ absc
external zfflo2,ffbnd
save xprec,bdn01,bdn05,bdn10,bdn15
- include 'ff.h'
+#include "ff.h"
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
* #] declarations:
* #[ initialisation:
data xprec /-1D0/
if ( xprec .ne. precx ) then
xprec = precx
precx = precc
* determine the boundaries for 1,5,10,15 terms
bdn01 = ffbnd(1,1,xninv(3))
bdn05 = ffbnd(1,5,xninv(3))
bdn10 = ffbnd(1,10,xninv(3))
bdn15 = ffbnd(1,15,xninv(3))
precx = xprec
xprec = precc
endif
* #] initialisation:
* #[ calculations:
xa = absc(x)
if ( xa .gt. bdn15 ) then
zfflo3 = zfflo2(x,ier) + x**2/2
return
endif
if ( xa .gt. bdn10 ) then
zfflo3 = x*( DBLE(xninv(13)) + x*( DBLE(xninv(14)) +
+ x*( DBLE(xninv(15)) + x*( DBLE(xninv(16)) +
+ x*( DBLE(xninv(17)) )))))
else
zfflo3 = 0
endif
if ( xa .gt. bdn05 ) then
zfflo3 = x*( DBLE(xninv(8)) + x*( DBLE(xninv(9)) +
+ x*( DBLE(xninv(10)) + x*( DBLE(xninv(11)) +
+ x*( DBLE(xninv(12)) + zfflo3 )))))
endif
if ( xa .gt. bdn01 ) then
zfflo3 = x*( DBLE(xninv(4)) + x*( DBLE(xninv(5)) +
+ x*( DBLE(xninv(6)) + x*( DBLE(xninv(7)) + zfflo3 ))))
endif
zfflo3 = - x**3*( DBLE(xninv(3)) + zfflo3 )
* #] calculations:
*###] zfflo3:
end
diff --git a/Looptools/util/ffcrr.F b/Looptools/util/ffcrr.F
--- a/Looptools/util/ffcrr.F
+++ b/Looptools/util/ffcrr.F
@@ -1,652 +1,655 @@
+#include "externals.h"
+
+
*--#[ log:
* $Id: ffcrr.f,v 1.5 1995/11/10 19:04:23 gj Exp $
* $Log: ffcrr.f,v $
c Revision 1.5 1995/11/10 19:04:23 gj
c Added nicer logging header...
c
c Revision 1.4 1995/10/17 06:55:07 gj
c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
c (ffxd0h.f)
c
c Revision 1.3 1995/10/06 09:17:20 gj
c Found stupid typo in ffxc0p which caused the result to be off by pi^2/3 in
c some equal-mass cases. Added checks to ffcxs4.f ffcrr.f.
c
*--#] log:
*###[ ffcrr:
subroutine ffcrr(crr,ipi12,cy,cy1,cz,cz1,cdyz,ld2yzz,cd2yzz,czz,
+ czz1,isoort,ieps,ier)
***#[*comment:***********************************************************
* *
* calculates R as defined in appendix b: *
* *
* /1 log(y-y1+ieps) - log(y0-y1+ieps) *
* r(y0,y1,iesp) = \ dy -------------------------------- *
* /0 y-y0 *
* *
* = li2(c1) - li2(c2) *
* + eta(-y1,1/(y0-y1))*log(c1) *
* - eta(1-y1,1/(y0-y1))*log(c2) *
* with *
* c1 = y0 / (y0-y1), c2 = (y0-1) / (y0-y1) *
* *
* the factors pi^2/12 are passed separately in the integer ipi12 *
* ier is a status flag: 0=ok, 1=numerical problems, 2=error *
* *
* Input: cy (complex) *
* cy1 (complex) 1-y *
* cz (complex) *
* cz1 (complex) 1-z *
* cdyz (complex) y-z *
* ieps (integer) denotes sign imaginary part of *
* argument logs (0: don't care; *
* +/-1: add -ieps to z; +/-2: *
* direct in dilogs, no eta's) *
* *
* Output crr (complex) R modulo factors pi^2/12 *
* ipi12 (integer) these factors *
* ier (integer) lost ier digits, >100: error *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ipi12,isoort,ieps,ier
logical ld2yzz,lreal
DOUBLE COMPLEX crr(7),cy,cy1,cz,cz1,cdyz,cd2yzz,czz,czz1
*
* local variables
*
DOUBLE COMPLEX cfact,cc1,cc2,cc1p,cc2p,carg1,carg2,carg3,
+ cli1,cli2,cli3,clo1,clo2,clo3,clog1p,clog2p,chill,
+ cd2,cd21,cd2n,cd21n1,cc1n,cterm,ctot,zfflo1,clog1,clog2,
+ cc,cli4,clo4
DOUBLE COMPLEX ctroep,zfflog
DOUBLE PRECISION xa,xr,absc,xprec,bndtay,ffbnd
DOUBLE PRECISION y,y1,z,z1,dyz,d2yzz,zz,zz1
integer i,nffeta,nffet1,iclas1,iclas2,n1,n2,n3,ntot,
+ i2pi,n3p
external zfflog,zfflo1,ffbnd,nffeta,nffet1
save xprec,bndtay
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
* #] declarations:
* #[ initialisations:
data xprec /-1D0/
if ( xprec .ne. precx ) then
xprec = precx
bndtay = ffbnd(2,18,xn2inv)
* print *,'bndtay = ',bndtay
endif
* #] initialisations:
* #[ real case:
if ( DIMAG(cy).eq.0 .and. DIMAG(cy1).eq.0 .and. DIMAG(cz).eq.0
+ .and. DIMAG(cz1).eq.0 ) then
y = DBLE(cy)
y1 = DBLE(cy1)
z = DBLE(cz)
z1 = DBLE(cz1)
dyz = DBLE(cdyz)
d2yzz = DBLE(cd2yzz)
zz = DBLE(czz)
zz1 = DBLE(czz1)
call ffcxr(crr,ipi12,y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1,
+ .FALSE.,0D0,ieps,ier)
return
endif
* #] real case:
* #[ arguments:
*
* get the arguments
*
xa = absc(cdyz)
if ( xa .eq. 0 ) then
return
* This line is for 68000 compilers that have a limited range for
* complex division (Absoft, Apollo, Gould NP1):
elseif ( DBLE(cdyz) .lt. xclogm .or. DIMAG(cdyz) .lt. xclogm
+ .or. 1/xa .lt. xclogm ) then
ctroep = cdyz*DBLE(1/xa)
cfact = 1/ctroep
cfact = DBLE(1/xa)*cfact
else
cfact = 1/cdyz
endif
cc1 = cy * cfact
cc2 = - cy1 * cfact
*
* see if we just need the real part
*
lreal = mod(isoort,5) .eq. 0
* #] arguments:
* #[ which area?:
*
* determine the area: 1={|x|<=1,Re(x)<=1/2},
* 2={|1-x|<=1,Re(x)>1/2}
* 3={|x|>1,|1-x|>1}
*
xr = DBLE(cc1)
xa = absc(cc1)
if ( xa .gt. 1 .and. xa .lt. 1+sqrt(2.) ) then
* we need a more accurate estimate
xa = xr**2 + DIMAG(cc1)**2
endif
if ( ld2yzz .and. absc(cc1+1) .lt. xloss/2 ) then
iclas1 = 4
cc1p = cc1
elseif ( xa .le. 1 .and. xr .le. 0.5 ) then
iclas1 = 1
cc1p = cc1
elseif ( xa .lt. 1+sqrt(2.) .and. xa .lt. 2*xr ) then
iclas1 = 2
cc1p = -cz * cfact
if ( abs(DIMAG(cc1p)) .lt. precc*abs(DBLE(cc1p)) )
+ cc1p = DBLE(cc1p)
else
iclas1 = 3
if ( 1/xa .lt. xclogm ) then
ctroep = cc1*DBLE(1/xa)
ctroep = 1/ctroep
cc1p = ctroep*DBLE(1/xa)
else
cc1p = 1/cc1
endif
endif
xr = DBLE(cc2)
xa = absc(cc2)
if ( xa .gt. 1 .and. xa .lt. 1+sqrt(2.) ) then
xa = xr**2 + DIMAG(cc2)**2
endif
if ( ld2yzz .and. absc(cc2+1) .lt. xloss ) then
iclas2 = 4
cc2p = cc2
elseif ( xa .le. 1 .and. xr .le. 0.5 ) then
iclas2 = 1
cc2p = cc2
elseif ( xa .lt. 1+sqrt(2.) .and. xa .lt. 2*xr ) then
iclas2 = 2
cc2p = cz1 * cfact
if ( abs(DIMAG(cc2p)) .lt. precc*abs(DBLE(cc2p)) )
+ cc2p = DBLE(cc2p)
else
iclas2 = 3
if ( 1/xa .lt. xclogm ) then
ctroep = cc2*DBLE(1/xa)
ctroep = 1/ctroep
cc2p = ctroep*DBLE(1/xa)
else
cc2p = 1/cc2
endif
endif
*
* throw together if they are close
*
if ( iclas1 .ne. iclas2 .and. absc(cc1-cc2) .lt. 2*xloss )
+ then
* we don't want trouble with iclasn = 4
if ( iclas1 .eq. 4 ) iclas1 = 1
if ( iclas2 .eq. 4 ) iclas2 = 1
if ( iclas1 .eq. iclas2 ) goto 5
* go on
if ( iclas1 .le. iclas2 ) then
iclas2 = iclas1
if ( iclas1 .eq. 1 ) then
cc2p = cc2
else
cc2p = cz1*cfact
endif
else
iclas1 = iclas2
if ( iclas1 .eq. 1 ) then
cc1p = cc1
else
cc1p = -cz*cfact
endif
endif
endif
5 continue
* #] which area?:
* #[ eta's:
*
* get eta1 and eta2
*
if ( abs(ieps) .ge. 2 .or. isoort .eq. -2 ) then
n1 = 0
n2 = 0
else
if ( DIMAG(cz) .eq. 0 .or. DIMAG(cz1) .eq. 0 ) then
if ( DIMAG(cz1) .eq. 0 ) then
if ( DIMAG(cz) .eq. 0 ) then
* cz is really real, the hard case:
if ( cz .eq. 0 ) then
* multiplied with log(1), so don't care:
n1 = 0
* look at ieps for guidance
* n2 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,cfact,ier) = 0
n2 = 0
elseif ( cz1 .eq. 0 ) then
n1 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
+ -cfact,ier)
n2 = 0
else
n1 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
+ -cz*cfact,ier)
n2 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
+ cz1*cfact,ier)
endif
else
n1 = nffet1(-cz,cfact,-cz*cfact,ier)
n2 = nffet1(-cz,cfact,cz1*cfact,ier)
endif
else
n1 = nffet1(cz1,cfact,-cz*cfact,ier)
n2 = nffet1(cz1,cfact,cz1*cfact,ier)
endif
else
* the imaginary part of cc1, cc1p is often very unstable.
* make sure it agrees with the actual sign used.
if ( iclas1 .eq. 2 ) then
if ( DIMAG(cc1p) .eq. 0 ) then
* if y (or y1 further on) is purely imaginary
* give a random shift, this will also be used in
* the transformation terms. Checked 7-mar-94 that it
* is independent of the sign used.
if ( DBLE(cy).eq.0 ) cy = cy +
+ isgnal*DBLE(precc)*DIMAG(cy)
n1 = nffet1(-cz,cfact,DCMPLX(DBLE(0),ieps*DBLE(cy)),
+ ier)
else
n1 = nffet1(-cz,cfact,cc1p,ier)
endif
else
if ( DIMAG(cc1) .eq. 0 ) then
if ( DBLE(cy1).eq.0 ) cy1 = cy1 +
+ isgnal*DBLE(precc)*DIMAG(cy)
n1 = nffet1(-cz,cfact,DCMPLX(DBLE(0),
+ -ieps*DBLE(cy1)),ier)
else
n1 = nffet1(-cz,cfact,-cc1,ier)
endif
endif
if ( iclas2 .eq. 2 ) then
if ( DIMAG(cc2p) .eq. 0 ) then
if ( DBLE(cy).eq.0 ) cy = cy +
+ isgnal*DBLE(precc)*DIMAG(cy)
n2 = nffet1(cz1,cfact,DCMPLX(DBLE(0),ieps*DBLE(cy)),
+ ier)
else
n2 = nffet1(cz1,cfact,cc2p,ier)
endif
else
if ( DIMAG(cc2) .eq. 0 ) then
if ( DBLE(cy1).eq.0 ) cy1 = cy1 +
+ isgnal*DBLE(precc)*DIMAG(cy)
n2 = nffet1(cz1,cfact,DCMPLX(DBLE(0),
+ -ieps*DBLE(cy1)),ier)
else
n2 = nffet1(cz1,cfact,-cc2,ier)
endif
endif
endif
endif
* #] eta's:
* #[ calculations:
* 3-oct-1995 changed code to only use second criterium if the
* Taylor expansion is used - otherwise the Hill identity will
* only make things worse
if ( iclas1 .eq. iclas2 .and. isoort .ne. -2 .and.
+ ( absc(cc1p-cc2p) .lt. 2*xloss*absc(cc1p)
+ .or. lreal .and. abs(DBLE(cc1p-cc2p)) .lt. 2*xloss*
+ abs(DBLE(cc1p)) .and. (abs(DBLE(cc2p)) +
+ DIMAG(cc2p)**2/4) .lt. xloss .and.
+ abs(DIMAG(cc2p)) .lt. bndtay ) ) then
* Close together:
* -#[ handle dilog's:
if ( .not. lreal .and. absc(cc2p) .gt. xloss
+ .or. lreal .and. ( (abs(DBLE(cc2p)) + DIMAG(cc2p)**2/4)
+ .gt. xloss .or. abs(DIMAG(cc2p)) .gt. bndtay ) )
+ then
*--#[ Hill identity:
*
* Use the Hill identity to get rid of the cancellations.
*
*
* first get the arguments:
*
if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
carg1 = 1/cy
carg2 = 1/cz1
carg3 = carg2/cc1p
elseif ( iclas1 .eq. 2 ) then
carg1 = 1/cz
carg2 = 1/cy1
carg3 = carg2/cc1p
elseif ( iclas1 .eq. 3 ) then
carg1 = 1/cy1
carg3 = 1/cz1
carg2 = carg3*cc1p
endif
call ffzli2(cli1,clo1,carg1,ier)
call ffzli2(cli2,clo2,carg2,ier)
call ffzli2(cli3,clo3,carg3,ier)
if ( absc(cc2p) .lt. xloss ) then
clog2p = zfflo1(cc2p,ier)
else
clog2p = zfflog(1-cc2p,0,czero,ier)
endif
chill = clo1*clog2p
*--#] Hill identity:
else
*--#[ Taylor expansion:
*
* if the points are close to zero do a Taylor
* expansion of the first and last dilogarithm
*
* Li2(cc1p) - Li2(cc2p)
* = sum cc1p^i ( 1-(1-cd2)^i ) /i^2
*
* with cd2 = 1-cc2p/cc1p = ...
*
if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
cd2 = 1/cy
elseif ( iclas1 .eq. 2 ) then
cd2 = 1/cz
elseif ( iclas1 .eq. 3 ) then
cd2 = 1/cy1
endif
cd21 = 1-cd2
cd21n1 = 1
cc1n = cc1p
cd2n = cd2
ctot = cc1p*cd2
do 50 i=2,20
cc1n = cc1n*cc1p
cd21n1 = cd21n1*cd21
cd2n = cd2n + cd2*cd21n1
cterm = cc1n*cd2n*DBLE(xn2inv(i))
ctot = ctot + cterm
if ( absc(cterm) .le. precc*absc(ctot) .or.
+ lreal .and. abs(DBLE(cterm)) .le. precc*
+ abs(DBLE(ctot)) ) goto 51
50 continue
51 continue
cli1 = ctot
cli2 = 0
cli3 = 0
chill = 0
* for the eta+transformation section we also need
if ( iclas1.ne.1 .or. n1.ne.0 .or. n2.ne.0 )
+ clo1 = zfflo1(cd2,ier)
if ( iclas1.eq.2 ) clo2 = zfflo1(1/cy1,ier)
*--#] Taylor expansion:
endif
*
* -#] handle dilog's:
* -#[ handle eta + transformation terms:
if ( iclas1.eq.1 .or. iclas1.eq.4 ) then
*--#[ no transformation:
*
* no transformation was made.
*
* crr(5) = 0
if ( n1 .ne. n2 ) then
if ( absc(cc1) .lt. xclogm ) then
call fferr(23,ier)
else
* imaginary part not checked
ier = ier + 50
crr(5) = (n1-n2)*c2ipi*zfflog(cc1,ieps,-cy,ier)
endif
endif
* crr(6) = 0
* crr(7) = 0
if ( n2.ne.0 ) then
crr(6) = - n2*c2ipi*clo1
n3 = nffeta(cc2,1/cc1,ier)
if ( n3 .ne. 0 ) then
crr(7) = n2*n3*c2ipi**2
* else
* crr(7) = 0
endif
endif
*--#] no transformation:
elseif ( iclas1 .eq. 2 ) then
*--#[ transform 1-x:
*
* we tranformed to 1-x for both dilogs
*
if ( absc(cc1p) .lt. xloss ) then
clog1 = zfflo1(cc1p,ier)
else
clog1 = zfflog(cc1,ieps,-cy,ier)
endif
if ( DIMAG(cc2p).eq.0 ) then
if ( DIMAG(cc1p).eq.0 ) then
* use the ieps instead
n3 = 0
else
n3 = nffet1(DCMPLX(DBLE(0),ieps*DBLE(cy)),
+ 1/cc1p,cc2p/cc1p,ier)
endif
else
if ( DIMAG(cc1p).eq.0 ) then
n3 =nffet1(cc2p,DCMPLX(DBLE(0),-ieps*DBLE(cy1)),
+ cc2p/cc1p,ier)
else
n3 = nffet1(cc2p,1/cc1p,cz,ier)
endif
endif
ntot = n1-n2-n3
crr(5) = (ntot*c2ipi + clo1)*clog1
clog2p = zfflog(cc2p,ieps,cy,ier)
crr(6) = clo2*(n2*c2ipi - clog2p)
*--#] transform 1-x:
elseif ( iclas1 .eq. 3 ) then
*--#[ transform 1/x:
*
* we transformed to 1/x for both dilogs
*
clog2p = zfflog(-cc2p,ieps,cy1,ier)
if ( DIMAG(cc2p).eq.0 .or. DIMAG(cc1).eq.0 ) then
* we chose the eta's already equal, no worry.
n3 = 0
n3p = 0
else
n3 = nffet1(-cc2p,-cc1,-cy/cy1,ier)
n3p = nffet1(cc2p,cc1,-cy/cy1,ier)
endif
if ( n3.ne.0 .or. n3p.ne.0 .or. n1.ne.n2 ) then
* for the time being the normal terms, I'll have to think of
* something smarter one day
clog1p = zfflog(-cc1p,ieps,-cy,ier)
crr(5) = -clog1p**2/2
crr(6) = +clog2p**2/2
crr(7) = (n1*zfflog(cc1,ieps,cy,ier) -
+ n2*zfflog(cc2,ieps,-cy1,ier))*c2ipi
else
crr(5) = clo1*(n2*c2ipi + clog2p - clo1/2)
endif
*--#] transform 1/x:
endif
* -#] handle eta + transformation terms:
* -#[ add up:
if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
crr(1) = cli1
crr(2) = cli2
crr(3) = - cli3
crr(4) = chill
else
crr(1) = - cli1
crr(2) = - cli2
crr(3) = cli3
crr(4) = - chill
endif
* -#] add up:
else
* Normal case:
* -#[ handle dilogs:
*
* the dilogs will not come close together so just go on
* only the special case cc1p ~ (-1,0) needs special attention
*
if ( iclas1 .ne. 4 .or. .not. ld2yzz ) then
call ffzli2(cli1,clo1,cc1p,ier)
else
cd2 = cd2yzz + czz
if ( absc(cd2) .lt. xloss*absc(cd2yzz) ) then
cd2 = cy + cdyz
endif
cd2 = cd2/cdyz
cfact = 1/(2-cd2)
call ffzli2(cli1,clo1,cd2*cfact,ier)
call ffzli2(cli3,clo3,-cd2*cfact,ier)
call ffzli2(cli4,clo4,cd2,ier)
endif
if ( iclas2 .ne. 4 .or. .not. ld2yzz ) then
call ffzli2(cli2,clo2,cc2p,ier)
else
if ( iclas1 .eq. 4 ) call fferr(26,ier)
cd2 = cd2yzz - czz1
if ( absc(cd2) .lt. xloss*absc(cd2yzz) ) then
cd2 = cdyz - cy1
endif
cd2 = cd2/cdyz
cfact = 1/(2-cd2)
call ffzli2(cli2,clo2,cd2*cfact,ier)
call ffzli2(cli3,clo3,-cd2*cfact,ier)
call ffzli2(cli4,clo4,cd2,ier)
endif
* -#] handle dilogs:
* -#[ handle eta terms:
*
* the eta's
*
if ( n1 .ne. 0 ) then
if ( iclas1 .ne. 2 .or. absc(cc1p) .gt. xloss ) then
if ( DBLE(cc1) .gt. -abs(DIMAG(cc1)) ) then
clog1 = zfflog(cc1,ieps,cy,ier)
else
* take apart the factor i*pi^2
if ( iclas1 .eq. 4 ) then
clog1 = zfflo1(cd2,ier)
else
clog1 = zfflog(-cc1,0,cy,ier)
endif
if ( DIMAG(cc1) .lt. 0 ) then
i2pi = -1
elseif ( DIMAG(cc1) .gt. 0 ) then
i2pi = +1
elseif ( DBLE(cy)*ieps .lt. 0 ) then
i2pi = -1
elseif ( DBLE(cy)*ieps .gt. 0 ) then
i2pi = +1
else
call fferr(51,ier)
i2pi = 0
endif
ipi12 = ipi12 - n1*24*i2pi
endif
else
clog1 = zfflo1(cc1p,ier)
endif
crr(5) = n1*c2ipi*clog1
* else
* crr(5) = 0
endif
if ( n2 .ne. 0 ) then
if ( iclas2 .ne. 2 .or. absc(cc2p) .gt. xloss ) then
if ( DBLE(cc2) .gt. -abs(DIMAG(cc2)) ) then
clog2 = zfflog(cc2,ieps,cy,ier)
else
* take apart the factor i*pi^2
if ( iclas2 .eq. 4 ) then
clog2 = zfflo1(cd2,ier)
else
clog2 = zfflog(-cc2,0,czero,ier)
endif
if ( DIMAG(cc2) .lt. 0 ) then
i2pi = -1
elseif ( DIMAG(cc2) .gt. 0 ) then
i2pi = +1
elseif ( DBLE(cy)*ieps .lt. 0 ) then
i2pi = -1
elseif ( DBLE(cy)*ieps .gt. 0 ) then
i2pi = +1
else
call fferr(51,ier)
i2pi = 0
endif
ipi12 = ipi12 + n2*24*i2pi
endif
else
clog2 = zfflo1(cc2p,ier)
endif
crr(6) = n2*c2ipi*clog2
* else
* crr(6) = 0
endif
* -#] handle eta terms:
* -#[ handle transformation terms:
*
* transformation of cc1
*
if ( iclas1 .eq. 1 ) then
* crr(3) = 0
elseif( iclas1 .eq. 2 ) then
cli1 = -cli1
ipi12 = ipi12 + 2
crr(3) = - clo1*zfflog(cc1p,ieps,cy,ier)
elseif ( iclas1 .eq. 3 ) then
cli1 = -cli1
ipi12 = ipi12 - 2
clog1p = zfflog(-cc1p,ieps,cy1,ier)
crr(3) = - clog1p**2/2
elseif ( iclas1 .eq. 4 ) then
* Note that this sum does not cause problems as d2<<1
crr(3) = -cli3 - cli4 + clo4*zfflog(cfact,0,czero,ier)
ipi12 = ipi12 - 1
else
call fferr(25,ier)
endif
*
* transformation of cc2
*
if ( iclas2 .eq. 1 ) then
elseif( iclas2 .eq. 2 ) then
cli2 = -cli2
ipi12 = ipi12 - 2
crr(4) = clo2*zfflog(cc2p,ieps,cy,ier)
elseif ( iclas2 .eq. 3 ) then
cli2 = -cli2
ipi12 = ipi12 + 2
clog2p = zfflog(-cc2p,ieps,cy1,ier)
crr(4) = clog2p**2/2
elseif ( iclas2 .eq. 4 ) then
* Note that this sum does not cause problems as d2<<1
crr(4) = cli3 + cli4 - clo4*zfflog(cfact,0,czero,ier)
ipi12 = ipi12 + 1
else
call fferr(27,ier)
endif
* -#] handle transformation terms:
* -#[ sum:
crr(1) = cli1
crr(2) = - cli2
crr(6) = - crr(6)
* crr(7) = 0
* -#] sum:
endif
* #] calculations:
*###] ffcrr:
end
diff --git a/Looptools/util/ffcxr.F b/Looptools/util/ffcxr.F
--- a/Looptools/util/ffcxr.F
+++ b/Looptools/util/ffcxr.F
@@ -1,425 +1,428 @@
+#include "externals.h"
+
+
*--#[ log:
* $Id: ffcxr.f,v 1.2 1995/11/10 19:04:24 gj Exp $
* $Log: ffcxr.f,v $
c Revision 1.2 1995/11/10 19:04:24 gj
c Added nicer logging header...
c
*--#] log:
*###[ ffcxr:
subroutine ffcxr(crr,ipi12,y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1,
+ ldy2z,dy2z,ieps,ier)
***#[*comment:***********************************************************
* *
* calculates R as defined in appendix b: *
* *
* /1 log(x-z+i*eps) - log(y-z+i*eps) *
* r(y,z) = \ dx ----------------------------------- *
* /0 x-y *
* *
* = li2(y/(y-z)+i*eps') - li2((y-1)/(y-z)+i*eps') *
* *
* y,z are real, ieps integer denoting the sign of i*eps. *
* factors pi^2/12 are passed in the integer ipi12. *
* *
* Input: y (real) *
* y1 (real) 1-y *
* z (real) *
* z1 (real) 1-z *
* dyz (real) y-z *
* *
* ld2yzz (logical) if .TRUE. also defined are: *
* d2yzz (real) 2*y - z^+ - z^- *
* zz (real) the other z-root *
* zz1 (real) 1 - zz *
* *
* ieps (integer) if +/-1 denotes sign imaginary *
* part of argument logs *
* ieps (integer) if +/-2 denotes sign imaginary *
* part of argument dilogs *
* *
* Output crr (complex) R modulo factors pi^2/12 *
* ipi12 (integer) these factors *
* ier (intger) 0=ok, 1=num prob, 2=error *
* *
* Calls: ffxli2,(test: ffzxdl),dfflo1,zxfflg *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ipi12,ieps,ier
logical ld2yzz,ldy2z
DOUBLE PRECISION y,y1,z,z1,dyz,d2yzz,zz,zz1,dy2z(3)
DOUBLE COMPLEX crr(7)
*
* local variables
*
integer i,iclas1,iclas2
DOUBLE PRECISION fact,xx1,xx2,xx1p,xx2p,arg2,arg3,
+ xli1,xli2,xli3,xlo1,xlo2,xlo3,xhill,xlog1,
+ xlog2p,xx1n,d2,d21,d2n,d21n1,term,tot,xtroep,xli4,
+ xlo4,som,xmax
DOUBLE COMPLEX clog1p,clog2p
DOUBLE PRECISION dfflo1
DOUBLE COMPLEX zxfflg
external dfflo1,zxfflg
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ groundwork:
*
* get the arguments
*
if ( dyz .eq. 0 ) return
fact = 1/dyz
xx1 = y * fact
xx2 = - y1 * fact
*
* #] groundwork:
* #[ which area?:
*
* determine the area: 1 = [-1+xloss,1/2]
* 2 = (1/2,2-xloss]
* 3 = [2+xloss,->) U (<-,-1-xloss]
* 4 = [-1-xloss,-1+xloss]
* 5 = [2-xloss,2+xloss]
*
if ( xx1 .lt. -1-xloss/2 ) then
iclas1 = 3
xx1p = 1/xx1
elseif( xx1 .lt. -1+xloss/2 ) then
if ( ld2yzz ) then
iclas1 = 4
else
iclas1 = 1
endif
xx1p = xx1
elseif( xx1 .le. .5D0 ) then
iclas1 = 1
xx1p = xx1
elseif ( xx1 .lt. 2-xloss ) then
iclas1 = 2
xx1p = -z*fact
elseif ( ldy2z .and. xx1 .lt. 2+xloss ) then
iclas1 = 5
xx1p = dy2z(1)*fact
else
iclas1 = 3
xx1p = 1/xx1
endif
if ( xx2 .lt. -1-xloss/2 ) then
iclas2 = 3
xx2p = 1/xx2
elseif( xx2 .lt. -1+xloss/2 ) then
if ( ld2yzz ) then
iclas2 = 4
else
iclas2 = 1
endif
xx2p = xx2
elseif ( xx2 .le. .5D0 ) then
iclas2 = 1
xx2p = xx2
elseif ( xx2 .lt. 2-xloss ) then
iclas2 = 2
xx2p = z1*fact
elseif ( ldy2z .and. xx2 .lt. 2+xloss ) then
iclas2 = 5
xx2p = -dy2z(3)*fact
else
iclas2 = 3
xx2p = 1/xx2
endif
*
* throw together if they are close
*
if ( iclas1 .ne. iclas2 .and. abs(xx1-xx2) .lt. 2*xloss )
+ then
* we don't want trouble with iclasn = 4,5
if ( iclas1 .eq. 4 ) then
iclas1 = 1
elseif ( iclas1 .eq. 5 ) then
iclas1 = 3
xx1p = 1/xx1
endif
if ( iclas2 .eq. 4 ) then
iclas2 = 1
elseif ( iclas2 .eq. 5 ) then
iclas2 = 3
xx2p = 1/xx2
endif
if ( iclas1 .eq. iclas2 ) goto 5
* go on
if ( iclas1 .le. iclas2 ) then
iclas2 = iclas1
if ( iclas1 .eq. 1 ) then
xx2p = xx2
else
xx2p = z1*fact
endif
else
iclas1 = iclas2
if ( iclas1 .eq. 1 ) then
xx1p = xx1
else
xx1p = -z*fact
endif
endif
endif
* #] which area?:
* #[ calculations:
5 if ( iclas1 .eq. iclas2 .and.
+ abs(xx1p-xx2p) .lt. 2*xloss*max(abs(xx1p),abs(xx2p))
+ .and. iclas1 .ne. 5 ) then
* |----->temporary!
* Close together:
* -#[ handle dilog's:
if ( abs(xx2p) .gt. xloss ) then
*--#[ Hill identity:
*
* Use the Hill identity to get rid of the cancellations.
*
*
* first get the arguments:
*
if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
d2 = 1/y
arg2 = 1/z1
arg3 = arg2/xx1p
elseif ( iclas1 .eq. 2 ) then
d2 = 1/z
arg2 = 1/y1
arg3 = arg2/xx1p
elseif ( iclas1 .eq. 3 ) then
d2 = 1/y1
arg3 = 1/z1
arg2 = arg3*xx1p
endif
call ffxli2(xli1,xlo1,d2,ier)
call ffxli2(xli2,xlo2,arg2,ier)
call ffxli2(xli3,xlo3,arg3,ier)
if ( abs(xx2p) .lt. xloss ) then
xlog2p = dfflo1(xx2p,ier)
else
xlog2p = DBLE(zxfflg(1-xx2p,0,1D0,ier))
endif
xhill = xlo1*xlog2p
*--#] Hill identity:
else
*--#[ Taylor expansion:
*
* if the points are close to zero do a Taylor
* expansion of the first and last dilogarithm
*
* Li2(xx1p) - Li2(xx2p)
* = sum xx1p^i ( 1-(1-d2)^i ) /i^2
*
* with d2 = 1-xx2p/xx1p = ...
*
if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
d2 = 1/y
elseif ( iclas1 .eq. 2 ) then
d2 = 1/z
elseif ( iclas1 .eq. 3 ) then
d2 = 1/y1
endif
* flag to the print section that we did a Taylor expansion
d21 = 1-d2
d21n1 = 1
xx1n = xx1p
d2n = d2
tot = xx1p*d2
* check for possible underflow on the next line
if ( abs(xx1p) .lt. xalog2 ) goto 51
do 50 i=2,20
xx1n = xx1n*xx1p
d21n1 = d21n1*d21
d2n = d2n + d2*d21n1
term = xx1n*d2n*xn2inv(i)
tot = tot + term
if ( abs(term) .le. precx*abs(tot) ) goto 51
50 continue
51 continue
xli1 = tot
xli2 = 0
xli3 = 0
xhill = 0
* for the eta+transformation section we also need
if ( iclas1 .ne. 1 ) then
if ( abs(d2) .lt. xloss ) then
xlo1 = dfflo1(d2,ier)
else
xlo1 = DBLE(zxfflg(d21,0,1D0,ier))
endif
endif
if ( iclas1 .eq. 2 ) xlo2 = dfflo1(1/y1,ier)
*--#] Taylor expansion:
endif
*
* -#] handle dilog's:
* -#[ handle transformation terms:
if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
*
* no transformation was made.
*
* crr(5) = 0
* crr(6) = 0
elseif ( iclas1 .eq. 2 ) then
*
* we tranformed to 1-x for both dilogs
*
if ( abs(xx1p) .lt. xloss ) then
xlog1 = dfflo1(xx1p,ier)
else
xlog1 = DBLE(zxfflg(xx1,0,1D0,ier))
endif
crr(5) = xlo1*xlog1
clog2p = zxfflg(xx2p,ieps,-y1,ier)
crr(6) = -DBLE(xlo2)*clog2p
elseif ( iclas1 .eq. 3 ) then
*
* we transformed to 1/x for both dilogs
*
clog2p = zxfflg(-xx2p,-ieps,-y1,ier)
crr(5) = DBLE(xlo1)*(clog2p - DBLE(xlo1)/2)
endif
* -#] handle transformation terms:
* -#[ add up and print out:
if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
crr(1) = xli1
crr(2) = xli2
crr(3) = - xli3
crr(4) = xhill
else
crr(1) = - xli1
crr(2) = - xli2
crr(3) = xli3
crr(4) = - xhill
endif
* -#] add up and print out:
else
* Normal case:
* -#[ handle dilogs:
*
* the dilogs will not come close together so just go on
* only the special case xx1p ~ -1 needs special attention
* - and the special case xx1 ~ 2 also needs special attention
*
if ( iclas1 .eq. 4 ) then
d2 = d2yzz + zz
xmax = abs(d2yzz)
if ( abs(d2) .lt. xloss*xmax ) then
som = y + dyz
if ( abs(y).lt.xmax ) then
d2 = som
xmax = abs(y)
endif
endif
d2 = d2/dyz
fact = 1/(2-d2)
call ffxli2(xli1,xlo1,d2*fact,ier)
call ffxli2(xli3,xlo3,-d2*fact,ier)
call ffxli2(xli4,xlo4,d2,ier)
elseif ( iclas1 .eq. 5 ) then
call ffxl22(xli1,xx1p,ier)
ipi12 = ipi12 + 3
else
call ffxli2(xli1,xlo1,xx1p,ier)
endif
if ( iclas2 .eq. 4 ) then
if ( iclas1 .eq. 4 ) call fferr(26,ier)
d2 = d2yzz - zz1
xmax = abs(d2yzz)
if ( abs(d2) .lt. xloss*xmax ) then
som = dyz - y1
if ( abs(y1).lt.xmax ) then
d2 = som
xmax = abs(y1)
endif
endif
d2 = d2/dyz
fact = 1/(2-d2)
call ffxli2(xli2,xlo2,d2*fact,ier)
call ffxli2(xli3,xlo3,-d2*fact,ier)
call ffxli2(xli4,xlo4,d2,ier)
elseif ( iclas2 .eq. 5 ) then
call ffxl22(xli2,xx2p,ier)
ipi12 = ipi12 - 3
else
call ffxli2(xli2,xlo2,xx2p,ier)
endif
* -#] handle dilogs:
* -#[ handle transformation terms xx1:
*
* transformation of c1
*
if ( iclas1 .eq. 1 ) then
crr(1) = xli1
elseif( iclas1 .eq. 2 ) then
crr(1) = -xli1
ipi12 = ipi12 + 2
clog1p = zxfflg(xx1p,ieps,y,ier)
crr(3) = - DBLE(xlo1)*clog1p
elseif ( iclas1 .eq. 3 ) then
crr(1) = -xli1
ipi12 = ipi12 - 2
clog1p = zxfflg(-xx1p,-ieps,y,ier)
crr(3) = - clog1p**2/2
elseif ( iclas1 .eq. 4 ) then
crr(1) = xli1
* Note that this sum does not cause problems as d2<<1
crr(3) = DBLE(-xli3-xli4) + DBLE(xlo4)*
+ zxfflg(fact,0,0D0,ier)
ipi12 = ipi12 - 1
elseif ( iclas1 .eq. 5 ) then
crr(1) = xli1
* supply an imaginary part
clog1p = zxfflg(-1/xx1,-ieps,y,ier)
xtroep = -DIMAG(clog1p)*DBLE(clog1p)
crr(3) = DCMPLX(0D0,xtroep)
else
call fferr(26,ier)
endif
* -#] handle transformation terms xx1:
* -#[ handle transformation terms xx2:
*
* transformation of c2
*
if ( iclas2 .eq. 1 ) then
crr(2) = -xli2
elseif( iclas2 .eq. 2 ) then
crr(2) = +xli2
ipi12 = ipi12 - 2
clog2p = zxfflg(xx2p,ieps,-y1,ier)
crr(4) = + DBLE(xlo2)*clog2p
elseif ( iclas2 .eq. 3 ) then
crr(2) = +xli2
ipi12 = ipi12 + 2
clog2p = zxfflg(-xx2p,-ieps,-y1,ier)
crr(4) = clog2p**2/2
elseif ( iclas2 .eq. 4 ) then
crr(2) = -xli2
* Note that this sum does not cause problems as d2<<1
crr(4) = DBLE(xli3+xli4) - DBLE(xlo4)*
+ zxfflg(fact,0,0D0,ier)
ipi12 = ipi12 + 1
elseif ( iclas2 .eq. 5 ) then
crr(2) = -xli2
* supply an imaginary part
clog2p = zxfflg(-1/xx2,-ieps,-y1,ier)
xtroep = DIMAG(clog2p)*DBLE(clog2p)
crr(4) = DCMPLX(0D0,xtroep)
else
call fferr(28,ier)
endif
* -#] handle transformation terms xx2:
endif
* #] calculations:
*###] ffcxr:
end
diff --git a/Looptools/util/ffcxs3.F b/Looptools/util/ffcxs3.F
--- a/Looptools/util/ffcxs3.F
+++ b/Looptools/util/ffcxs3.F
@@ -1,650 +1,653 @@
+#include "externals.h"
+
+
*###[ ffcxs3:
subroutine ffcxs3(cs3,ipi12,y,z,dyz,d2yzz,dy2z,xpi,piDpj,ii,ns,
+ isoort,ier)
***#[*comment:***********************************************************
* *
* calculates the s3 as defined in appendix b. *
* (ip = ii+3, is1 = ii, is2 = ii+1) *
* *
* log( xk*y^2 + (-xk+xm1-xm2)*y + xm2 - i*eps ) *
* /1 - log( ... ) |y=yi *
* s3 = \ dy -------------------------------------------------- *
* /0 y - yi *
* *
* = r(yi,y-,+) + r(yi,y+,-) *
* *
* with y+- the roots of the argument of the logarithm. *
* the sign of the argument to the logarithms in r is passed *
* in ieps *
* *
* input: y(4),z(4) (real) roots in form (z-,z+,1-z-,1-z+) *
* dyz(2,2),d2yzz, (real) y() - z(), y+ - z- - z+ *
* dy2z(4) (real) y() - 2z() *
* xpi (real(ns)) p(i).p(i) (B&D metric) i=1,3 *
* m(i)^2 = si.si i=4,6 *
* ii (integer) xk = xpi(ii+3) etc *
* ns (integer) size of arrays *
* isoort (integer) returns kind of action taken *
* cs3 (complex)(20) assumed zero. *
* ccy (complex)(3) if i0 != 0: complex y *
* *
* output: cs3 (complex) mod factors pi^2/12, in array *
* ipi12 (integer) these factors *
* ier (integer) 0=ok 1=inaccurate 2=error *
* *
* calls: ffcrr,ffcxr,real/dble,DCMPLX,log,ffadd1,ffadd2,ffadd3 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(2),ii,ns,isoort(2),ier
DOUBLE COMPLEX cs3(20)
DOUBLE PRECISION y(4),z(4),dyz(2,2),d2yzz,dy2z(4),
+ xpi(ns),piDpj(ns,ns)
*
* local variables:
*
integer i,ip,ieps(2)
DOUBLE PRECISION yy,yy1,zz,zz1,dyyzz,xdilog,xlog,x00(3)
logical ld2yzz
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ get counters:
ip = ii+3
if ( isoort(2) .ne. 0 ) then
if ( (z(2).gt.z(1) .or. z(1).eq.z(2) .and. z(4).lt.z(3) )
+ .eqv. xpi(ip) .gt. 0 ) then
ieps(1) = +1
ieps(2) = -1
else
ieps(1) = -1
ieps(2) = +1
endif
else
if ( piDpj(ip,ii) .gt. 0 ) then
ieps(1) = +1
else
ieps(1) = -1
endif
endif
* #] get counters:
* #[ special case |z| >> |y|:
if ( xpi(ip).lt.0 .and. max(abs(y(2)),abs(y(4))) .lt.
+ xloss*min(abs(z(1)), abs(z(2)))/2 ) then
*
* we will obtain cancellations of the type Li_2(x) + Li_2(-x)
* with x small.
*
yy = dyz(2,1)/d2yzz
yy1 = dyz(2,2)/d2yzz
if ( y(2) .eq. 0 ) goto 10
zz = z(2)*yy/y(2)
zz1 = 1-zz
dyyzz = dyz(2,2)*yy/y(2)
call ffcxr(cs3(1),ipi12(1),yy,yy1,zz,zz1,dyyzz,.FALSE.,
+ 0D0,0D0,0D0,.FALSE.,x00,0,ier)
10 continue
if ( y(4) .eq. 0 ) goto 30
zz = yy*z(4)/y(4)
zz1 = 1-zz
dyyzz = -yy*dyz(2,2)/y(4)
call ffcxr(cs3(8),ipi12(2),yy,yy1,zz,zz1,dyyzz,.FALSE.,
+ 0D0,0D0,0D0,.FALSE.,x00,0,ier)
do 20 i=8,14
20 cs3(i) = -cs3(i)
30 continue
* And now the remaining Li_2(x^2) terms
call ffxli2(xdilog,xlog,(y(2)/dyz(2,1))**2,ier)
cs3(15) = +xdilog/2
call ffxli2(xdilog,xlog,(y(4)/dyz(2,1))**2,ier)
cs3(16) = -xdilog/2
goto 900
endif
* #] special case |z| >> |y|:
* #[ normal:
if ( xpi(ip) .eq. 0 ) then
ld2yzz = .FALSE.
else
ld2yzz = .TRUE.
endif
if ( isoort(1) .ne. 0 ) call ffcxr(cs3(1),ipi12(1),y(2),y(4),
+ z(1),z(3),dyz(2,1),ld2yzz,d2yzz,z(2),z(4),.TRUE.,dy2z(1),
+ ieps(1),ier)
if ( isoort(2) .ne. 0 ) then
if ( mod(isoort(2),10) .eq. 2 ) then
* both roots are equal: multiply by 2
do 60 i=1,7
cs3(i) = 2*DBLE(cs3(i))
60 continue
ipi12(1) = 2*ipi12(1)
else
call ffcxr(cs3(8),ipi12(2),y(2),y(4),z(2),z(4),dyz(2,2),
+ ld2yzz,d2yzz,z(1),z(3),.TRUE.,dy2z(2),ieps(2),ier)
endif
endif
*
* #] normal:
900 continue
*###] ffcxs3:
end
*###[ ffcs3:
subroutine ffcs3(cs3,ipi12,cy,cz,cdyz,cd2yzz,cpi,cpiDpj,ii,ns,
+ isoort,ier)
***#[*comment:***********************************************************
* *
* calculates the s3 as defined in appendix b. *
* *
* log( cpi(ii+3)*y^2 + (cpi(ii+3)+cpi(ii)-cpi(ii+1))*y *
* /1 + cpi(ii+1)) - log( ... ) |y=cyi *
* s3 = \ dy ---------------------------------------------------- *
* /0 y - cyi *
* *
* = r(cyi,cy+) + r(cyi,cy-) + ( eta(-cy-,-cy+) - *
* eta(1-cy-,1-cy+) - eta(...) )*log(1-1/cyi) *
* *
* with y+- the roots of the argument of the logarithm. *
* *
* input: cy(4) (complex) cy(1)=y^-,cy(2)=y^+,cy(i+2)=1-cy(1) *
* cz(4) (complex) cz(1)=z^-,cz(2)=z^+,cz(i+2)=1-cz(1) *
* cpi(6) (complex) masses & momenta (B&D) *
* ii (integer) position of cp,cma,cmb in cpi *
* ns (integer) size of arrays *
* isoort(2)(integer) returns the kind of action taken *
* cs3 (complex)(14) assumed zero. *
* *
* output: cs3 (complex) mod factors ipi12 *
* ipi12(2) (integer) these factors *
* ier (integer) 0=ok, 1=numerical problems, 2=error *
* *
* calls: ffcrr,DIMAG,DBLE,zfflog *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(2),ii,ns,isoort(2),ier
DOUBLE COMPLEX cs3(20),cpi(ns),cpiDpj(ns,ns)
DOUBLE COMPLEX cy(4),cz(4),cdyz(2,2),cd2yzz
*
* local variables:
*
integer i,ip,ieps(2),ieps0,ni(4),ntot
logical ld2yzz
DOUBLE COMPLEX c,zdilog,zlog,cyy,cyy1,czz,czz1,cdyyzz
DOUBLE PRECISION absc,y,y1,z,z1,dyz,d2yzz,zz,zz1,
+ x00(3),sprec
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ get ieps:
ip = ii+3
call ffieps(ieps,cz(1),cpi(ip),cpiDpj(ip,ii),isoort)
* #] get ieps:
* #[ special case |cz| >> |cy|:
if ( isoort(2) .ne. 0 .and. max(absc(cy(2)),absc(cy(4))) .lt.
+ xloss*min(absc(cz(1)),absc(cz(2)))/2 ) then
*
* we will obtain cancellations of the type Li_2(x) + Li_2(-x)
* with x small.
*
cyy = cdyz(2,1)/cd2yzz
cyy1 = cdyz(2,2)/cd2yzz
if ( absc(cy(2)) .lt. xclogm ) then
if ( DIMAG(cy(2)) .eq. 0 .and. abs(DBLE(cy(2))) .gt.
+ xalogm ) then
czz = cz(2)*cyy*DCMPLX(1/DBLE(cy(2)))
cdyyzz = cyy*cdyz(2,2)*DCMPLX(1/DBLE(cy(2)))
elseif ( cy(2) .eq. 0 .and. cz(2) .ne. 0 .and. cyy
+ .ne. 0 ) then
* the answer IS zero
goto 30
endif
else
czz = cz(2)*cyy/cy(2)
cdyyzz = cyy*cdyz(2,2)/cy(2)
endif
czz1 = 1-czz
if ( isoort(1) .eq. -10 ) then
* no eta terms.
ieps0 = 99
else
* do not know the im part
ieps0 = 0
endif
call ffcrr(cs3(1),ipi12(1),cyy,cyy1,czz,czz1,cdyyzz,.FALSE.,
+ czero,czero,czero,-1,ieps0,ier)
30 continue
if ( absc(cy(4)) .lt. xclogm ) then
if ( DIMAG(cy(4)) .eq. 0 .and. abs(DBLE(cy(4))) .gt.
+ xalogm ) then
czz = cz(4)*cyy*DCMPLX(1/DBLE(cy(4)))
cdyyzz = -cyy*cdyz(2,2)*DCMPLX(1/DBLE(cy(4)))
elseif ( cy(4) .eq. 0 .and. cz(4) .ne. 0 .and. cyy
+ .ne. 0 ) then
* the answer IS zero
goto 50
endif
else
czz = cz(4)*cyy/cy(4)
cdyyzz = -cyy*cdyz(2,2)/cy(4)
endif
czz1 = 1-czz
call ffcrr(cs3(8),ipi12(2),cyy,cyy1,czz,czz1,cdyyzz,.FALSE.,
+ czero,czero,czero,-1,ieps0,ier)
do 40 i=8,14
cs3(i) = -cs3(i)
40 continue
50 continue
*
* And now the remaining Li_2(x^2) terms
* stupid Gould NP1
*
c = cy(2)*cy(2)/(cdyz(2,1)*cdyz(2,1))
call ffzli2(zdilog,zlog,c,ier)
cs3(15) = +zdilog/2
* stupid Gould NP1
c = cy(4)*cy(4)/(cdyz(2,1)*cdyz(2,1))
call ffzli2(zdilog,zlog,c,ier)
cs3(16) = -zdilog/2
goto 900
endif
* #] special case |cz| >> |cy|:
* #[ normal:
if ( isoort(2) .eq. 0 ) then
ld2yzz = .FALSE.
else
ld2yzz = .TRUE.
endif
if ( isoort(1) .eq. 0 ) then
* do nothing
elseif ( mod(isoort(1),10).eq.0 .or. mod(isoort(1),10).eq.-1
+ .or. mod(isoort(1),10).eq.-3 ) then
call ffcrr(cs3(1),ipi12(1),cy(2),cy(4),cz(1),cz(3),
+ cdyz(2,1),ld2yzz,cd2yzz,cz(2),cz(4),isoort(1),
+ ieps(1),ier)
elseif ( mod(isoort(1),10) .eq. -5 .or. mod(isoort(1),10) .eq.
+ -6 ) then
y = DBLE(cy(2))
y1 = DBLE(cy(4))
z = DBLE(cz(1))
z1 = DBLE(cz(3))
dyz = DBLE(cdyz(2,1))
d2yzz = DBLE(cd2yzz)
zz = DBLE(cz(2))
zz1 = DBLE(cz(4))
sprec = precx
precx = precc
call ffcxr(cs3(1),ipi12(1),y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1
+ ,.FALSE.,x00,ieps(1),ier)
precx = sprec
else
call fferr(12,ier)
endif
if ( isoort(2) .eq. 0 ) then
* do nothing
elseif ( mod(isoort(2),5) .eq. 0 ) then
do 100 i=1,7
100 cs3(i) = 2*DBLE(cs3(i))
ipi12(1) = 2*ipi12(1)
elseif ( mod(isoort(2),10).eq.-1 .or. mod(isoort(1),10).eq.-3 )
+ then
call ffcrr(cs3(8),ipi12(2),cy(2),cy(4),cz(2),cz(4),
+ cdyz(2,2),ld2yzz,cd2yzz,cz(1),cz(3),isoort(2),
+ ieps(2),ier)
elseif ( mod(isoort(2),10) .eq. -6 ) then
y = DBLE(cy(2))
y1 = DBLE(cy(4))
z = DBLE(cz(2))
z1 = DBLE(cz(4))
dyz = DBLE(cdyz(2,2))
d2yzz = DBLE(cd2yzz)
zz = DBLE(cz(1))
zz1 = DBLE(cz(3))
sprec = precx
precx = precc
call ffcxr(cs3(8),ipi12(2),y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1
+ ,.FALSE.,x00,ieps(2),ier)
precx = sprec
else
call fferr(13,ier)
endif
* #] normal:
* #[ eta's:
if ( mod(isoort(1),10).eq.-5 .or. mod(isoort(1),10).eq.-6 )
+ then
if ( mod(isoort(2),10).ne.-5 .and. mod(isoort(1),10).ne.-6
+ ) then
print *,'ffcxs3: error: I assumed both would be real!'
ier = ier + 50
endif
* we called ffcxr - no eta's
elseif ( DIMAG(cpi(ip)).eq.0 ) then
call ffgeta(ni,cz(1),cdyz(1,1),
+ cpi(ip),cpiDpj(ii,ip),ieps,isoort,ier)
ntot = ni(1) + ni(2) + ni(3) + ni(4)
if ( ntot .ne. 0 ) call ffclgy(cs3(15),ipi12(2),ntot,
+ cy(1),cz(1),cd2yzz,ier)
else
*
* cpi(ip) is really complex (occurs in transformed
* 4pointfunction)
*
print *,'THIS PART IS NOT READY ',
+ 'and should not be reached'
stop
endif
* #] eta's:
900 continue
*###] ffcs3:
end
*###[ ffclgy:
subroutine ffclgy(cs3,ipi12,ntot,cy,cz,cd2yzz,ier)
***#[*comment:***********************************************************
* *
* calculates the the difference of two S's with cy(3,4),cz(3,4), *
* cy(4)cz(3)-cy(3)cz(4) given. Note the difference with ffdcs4, *
* in which the cy's are the same and only the cz's different. *
* Here both can be different. Also we skip an intermediat *
* level. *
* *
* input: cy(4) (complex) cy,1-cy in S with s3,s4 *
* cz(4) (complex) cz,1-cz in S with s3,s4 *
* cdyz(2,2) (complex) cy - cz *
* cd2yzz (complex) 2*cy - cz+ - cz- *
* cdyzzy(4) (complex) cy(i,4)*cz(i,4)-cy(i,3)*cz(i,4) *
* cpiDpj(6,6) (complex) usual *
* cs3 (complex) assumed zero. *
* *
* output: cs3 (complex) mod factors pi^2/12, in array *
* ipi12 (integer) these factors *
* isoort (integer) returns kind of action taken *
* ier (integer) number of digits lost *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cs3
DOUBLE COMPLEX cy(4),cz(4),cd2yzz
integer ipi12,ntot,ier
*
* local variables
*
integer ipi
DOUBLE COMPLEX c,cc,clogy,c2y1,zfflog,zfflo1,csum
DOUBLE PRECISION absc
external zfflog,zfflo1
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ calculations:
ipi = 0
if ( 1 .lt. xloss*absc(cy(2)) ) then
clogy = zfflo1(1/cy(2),ier)
else
if ( absc(cy(2)) .lt. xclogm .or. absc(cy(4)) .lt. xclogm )
+ then
if ( ntot .ne. 0 ) call fferr(15,ier)
clogy = 0
else
c = -cy(4)/cy(2)
if ( DBLE(c) .gt. -abs(DIMAG(c)) ) then
clogy = zfflog(c,0,czero,ier)
else
* take out the factor 2*pi^2
cc = c+1
if ( absc(cc) .lt. xloss ) then
c2y1 = -cd2yzz - cz(1) + cz(4)
if ( absc(c2y1) .lt. xloss*max(absc(cz(1)),
+ absc(cz(4))) ) then
c2y1 = -cd2yzz - cz(2) + cz(3)
endif
csum = -c2y1/cy(2)
clogy = zfflo1(csum,ier)
else
csum = 0
clogy = zfflog(-c,0,czero,ier)
endif
if ( DIMAG(c) .lt. -precc*absc(c) .or.
+ DIMAG(csum) .lt. -precc*absc(csum) ) then
ipi = -1
elseif ( DIMAG(c) .gt. precc*absc(c) .or.
+ DIMAG(csum) .gt. precc*absc(csum) ) then
ipi = +1
else
call fferr(51,ier)
ipi = 0
endif
endif
endif
endif
cs3 = cs3 + ntot*c2ipi*clogy
if ( ipi .ne. 0 ) then
ipi12 = ipi12 - 24*ntot*ipi
endif
* #] calculations:
*###] ffclgy:
end
*###[ ffieps:
subroutine ffieps(ieps,cz,cp,cpDs,isoort)
***#[*comment:***********************************************************
* *
* Get the ieps prescription in such a way that it is compatible *
* with the imaginary part of cz if non-zero, compatible with the *
* real case if zero. *
* *
* Input: cz complex(4) the roots z-,z+,1-z-,1-z+ *
* cp complex p^2 *
* cpDs complex p.s *
* isoort integer(2) which type of Ri *
* *
* Output: ieps integer(2) z -> z-ieps*i*epsilon *
* will give correct im part *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ieps(2),isoort(2)
DOUBLE COMPLEX cp,cpDs,cz(4)
*
* #] declarations:
* #[ work:
if ( DIMAG(cp) .ne. 0 ) then
* do not calculate ANY eta terms, we'll do them ourselves.
ieps(1) = 99
ieps(2) = 99
elseif ( isoort(2) .ne. 0 ) then
if ( DIMAG(cz(1)) .lt. 0 ) then
ieps(1) = +1
if ( DIMAG(cz(2)) .lt. 0 ) then
ieps(2) = +1
else
ieps(2) = -1
endif
elseif ( DIMAG(cz(1)) .gt. 0 ) then
ieps(1) = -1
if ( DIMAG(cz(2)) .le. 0 ) then
ieps(2) = +1
else
ieps(2) = -1
endif
else
if ( DIMAG(cz(2)) .lt. 0 ) then
ieps(1) = -1
ieps(2) = +1
elseif ( DIMAG(cz(2)) .gt. 0 ) then
ieps(1) = +1
ieps(2) = -1
else
if ( (DBLE(cz(2)).gt.DBLE(cz(1))
+ .or. (DBLE(cz(1)).eq.DBLE(cz(2))
+ .and. DBLE(cz(4)).lt.DBLE(cz(3)))
+ ) .eqv. DBLE(cp).gt.0 ) then
ieps(1) = +1
ieps(2) = -1
else
ieps(1) = -1
ieps(2) = +1
endif
endif
endif
else
if ( DIMAG(cz(1)) .lt. 0 ) then
ieps(1) = +1
elseif ( DIMAG(cz(1)) .gt. 0 ) then
ieps(1) = -1
elseif ( DBLE(cpDs) .gt. 0 ) then
ieps(1) = +1
else
ieps(1) = -1
endif
ieps(2) = -9999
endif
* #] work:
*###] ffieps:
end
*###[ ffgeta:
subroutine ffgeta(ni,cz,cdyz,cp,cpDs,ieps,isoort,ier)
***#[*comment:***********************************************************
* *
* Get the eta terms which arise from splitting up *
* log(p2(x-z-)(x-z+)) - log(p2(y-z-)(y-z+)) *
* *
* Input: cz complex(4) the roots z-,z+,1-z-,1-z+ *
* cdyz complex(2,2) y-z *
* cd2yzz complex(2) 2y-(z-)-(z+) *
* cp complex p^2 *
* cpDs complex p.s *
* ieps integer(2) the assumed im part if Im(z)=0 *
* isoort integer(2) which type of Ri *
* *
* Output: ni integer(4) eta()/(2*pi*i) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ni(4),ieps(2),isoort(2),ier
DOUBLE COMPLEX cp,cpDs,cz(4),cdyz(2,2)
*
* local variables
*
integer i,nffeta,nffet1
DOUBLE COMPLEX cmip
external nffeta,nffet1
*
* common
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ complex masses or imaginary roots:
*
* only complex because of complex roots in y or z
* [checked and in agreement with ieps definition 23-sep-1991]
*
* isoort = +1: y is real, z is real
* isoort = -1-n*10: y is complex, possibly z as well
* isoort = -3-n*10: y,z complex, (y-z-)*(y-z+) real
* isoort = 0: y is complex, one z root only
* isoort = -10-n*10: y is real, z is complex
* isoort = -5,6-n*10: y,z real
*
if ( isoort(1) .gt. 0 ) then
*
* really a real case
*
ni(1) = 0
ni(2) = 0
ni(3) = 0
ni(4) = 0
elseif ( mod(isoort(1),10) .ne. 0 .and. isoort(2) .ne. 0 ) then
cmip = DCMPLX(0D0,-DBLE(cp))
*
* ni(1) = eta(p2,(x-z-)(x-z+)) = 0 by definition (see ni(3))
* ni(2) = eta(x-z-,x-z+)
*
ni(1) = 0
if ( ieps(1) .gt. 0 .neqv. ieps(2) .gt. 0 ) then
ni(2) = 0
else
ni(2) = nffet1(-cz(1),-cz(2),cmip,ier)
if ( cz(3).ne.0 .and. cz(4).ne.0 ) then
i = nffet1(cz(3),cz(4),cmip,ier)
if ( i .ne. ni(2) ) call fferr(53,ier)
endif
endif
*
* ni(3) compensates for whatever convention we chose in ni(1)
* ni(4) = -eta(y-z-,y-z+)
*
if ( mod(isoort(1),10).eq.-3 ) then
* follow the i*epsilon prescription as (y-z-)(y-z+) real
ni(3) = 0
ni(4) = -nffet1(cdyz(2,1),cdyz(2,2),cmip,ier)
else
if ( DBLE(cp) .lt. 0 .and. DIMAG(cdyz(2,1)*
+ cdyz(2,2)) .lt. 0 ) then
ni(3) = -1
else
ni(3) = 0
endif
ni(4) = -nffeta(cdyz(2,1),cdyz(2,2),ier)
endif
elseif ( (mod(isoort(1),10).eq.-1 .or. mod(isoort(1),10).eq.-3)
+ .and. isoort(2) .eq. 0 ) then
ni(1) = 0
if ( DIMAG(cz(1)) .ne. 0 ) then
ni(2) = nffet1(-cpDs,-cz(1),DCMPLX(DBLE(0),
+ DBLE(-1)),ier)
else
ni(2) = nffet1(-cpDs,DCMPLX(DBLE(0),DBLE(1)),
+ DCMPLX(DBLE(0),DBLE(-1)),ier)
endif
ni(3) = 0
ni(4) = -nffeta(-cpDs,cdyz(2,1),ier)
else
ni(1) = 0
ni(2) = 0
ni(3) = 0
ni(4) = 0
endif
* #] complex masses or imaginary roots:
*###] ffgeta:
end
diff --git a/Looptools/util/ffcxs4.F b/Looptools/util/ffcxs4.F
--- a/Looptools/util/ffcxs4.F
+++ b/Looptools/util/ffcxs4.F
@@ -1,774 +1,777 @@
+#include "externals.h"
+
+
* $Id: ffcxs4.f,v 1.3 1995/10/17 06:55:09 gj Exp $
* $Log: ffcxs4.f,v $
c Revision 1.3 1995/10/17 06:55:09 gj
c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
c (ffxd0h.f)
c
c Revision 1.2 1995/10/06 09:17:22 gj
c Found stupid typo in ffxc0p which caused the result to be off by pi^2/3 in
c some equal-mass cases. Added checks to ffcxs4.f ffcrr.f.
c
*###[ ffcxs4:
subroutine ffcxs4(cs3,ipi12,w,y,z,dwy,dwz,dyz,d2yww,d2yzz,
+ xpi,piDpj,ii,ns,isoort,ier)
***#[*comment:***********************************************************
* *
* Calculate the 8 Spence functions = 4 R's = 2 dR's *
* *
* *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(4),ii,ns,isoort(4),ier
DOUBLE COMPLEX cs3(40)
DOUBLE PRECISION w(4),y(4),z(4),dwy(2,2),dwz(2,2),dyz(2,2),
+ d2yww,d2yzz,xpi(ns),piDpj(ns,ns),x00(3)
*
* local variables:
*
integer iepz(2),iepw(2)
logical ld2yzz,ld2yww
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ groundwork:
if ( isoort(2) .eq. 0 ) then
ld2yzz = .FALSE.
else
ld2yzz = .TRUE.
endif
if ( isoort(4) .eq. 0 ) then
ld2yww = .FALSE.
else
ld2yww = .TRUE.
endif
if ( isoort(2) .ne. 0 ) then
if ( z(2) .gt. z(1) .eqv. xpi(ii+3) .gt. 0 ) then
iepz(1) = +1
iepz(2) = -1
else
iepz(1) = -1
iepz(2) = +1
endif
else
print *,'ffcxs4: error: untested algorithm'
if ( piDpj(ii,ii+3) .gt. 0 ) then
iepz(1) = +1
else
iepz(1) = -1
endif
endif
if ( isoort(4) .ne. 0 ) then
if ( w(2) .gt. w(1) .eqv. xpi(5) .gt. 0 ) then
iepw(1) = 1
iepw(2) = -1
else
iepw(1) = -1
iepw(2) = 1
endif
else
print *,'ffcxs4: error: untested algorithm'
if ( piDpj(2,5) .gt. 0 ) then
iepw(1) = +1
else
iepw(1) = -1
endif
endif
* #] groundwork:
* #[ zm and wp:
if ( isoort(4) .eq. 0 ) then
call ffcxr(cs3(1),ipi12(1),y(2),y(4),z(1),z(3),dyz(2,1),
+ ld2yzz,d2yzz,z(2),z(4),.FALSE.,x00,iepz(1),ier)
else
if ( .not. ( dwz(2,1).eq.0 .and. iepz(1).eq.iepw(2) ) )
+ call ffdcxr(cs3( 1),ipi12(1),y(2),y(4),z(1),z(3),
+ z(2),z(4),d2yzz,w(2),w(4),w(1),w(3),d2yww,
+ dyz(2,1),dwy(2,2),dwz(2,1),iepz(1),iepw(2),ier)
endif
* #] zm and wp:
* #[ zp and wm:
if ( isoort(2) .eq. 0 ) then
call ffcxr(cs3(1),ipi12(1),y(2),y(4),w(1),w(3),-dwy(1,2),
+ ld2yww,d2yww,w(2),w(4),.FALSE.,x00,iepw(1),ier)
else
if ( .not. ( dwz(1,2).eq.0 .and. iepz(2).eq.iepw(1) ) )
+ call ffdcxr(cs3(21),ipi12(3),y(2),y(4),z(2),z(4),
+ z(1),z(3),d2yzz,w(1),w(3),w(2),w(4),d2yww,
+ dyz(2,2),dwy(1,2),dwz(1,2),iepz(2),iepw(1),ier)
endif
* #] zp and wm:
*###] ffcxs4:
end
*###[ ffcs4:
subroutine ffcs4(cs3,ipi12,cw,cy,cz,cdwy,cdwz,cdyz,cd2yww,cd2yzz
+ ,cpi,cpiDpj,cp2p,ii,ns,isoort,ier)
***#[*comment:***********************************************************
* *
* Calculate the 8 Spence functions = 4 R's = 2 dR's *
* *
* *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(4),ii,ns,isoort(4),ier
DOUBLE COMPLEX cs3(40)
DOUBLE COMPLEX cw(4),cy(4),cz(4),cdwy(2,2),cdwz(2,2),cdyz(2,2)
DOUBLE COMPLEX cd2yww,cd2yzz,cpi(ns),cp2p,cpiDpj(ns,ns)
*
* local variables:
*
logical ld2yzz,ld2yww
integer i,j,ip,iepz(2),iepw(2),nz(4),nw(4),ntot,i2pi
DOUBLE COMPLEX c,cc,clogy,c2y1,cdyw(2,2)
DOUBLE COMPLEX zfflo1,zfflog
DOUBLE PRECISION absc
external zfflo1,zfflog
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ get counters:
ip = ii+3
if ( isoort(2) .eq. 0 ) then
ld2yzz = .FALSE.
else
ld2yzz = .TRUE.
endif
if ( isoort(4) .eq. 0 ) then
ld2yww = .FALSE.
else
ld2yww = .TRUE.
endif
call ffieps(iepz,cz,cpi(ip),cpiDpj(ip,ii),isoort)
call ffieps(iepw,cw,cp2p,cpiDpj(ip,ii),isoort(3))
if ( isoort(4) .eq. 0 ) then
print *,'ffcs4: error: case not implemented'
ier = ier + 50
endif
* #] get counters:
* #[ R's:
if ( isoort(4) .eq. 0 ) then
call ffcrr(cs3(1),ipi12(1),cy(2),cy(4),cz(1),cz(3),cdyz(2,1)
+ ,ld2yzz,cd2yzz,cz(2),cz(4),isoort(4),iepz(1),ier)
else
if ( .not. ( cdwz(2,1).eq.0 .and. iepz(1).eq.iepw(2) ) )
+ call ffdcrr(cs3( 1),ipi12(1),cy(2),cy(4),cz(1),cz(3),cz(2),
+ cz(4),cd2yzz,cw(2),cw(4),cw(1),cw(3),cd2yww,cdyz(2,1),
+ cdwy(2,2),cdwz(2,1),isoort(4),iepz(1),iepw(2),ier)
endif
if ( isoort(2) .eq. 0 ) then
call ffcrr(cs3(1),ipi12(1),cy(2),cy(4),cw(1),cw(3),-cdwy(1,2
+ ),ld2yww,cd2yww,cw(2),cw(4),isoort(2),iepw(1),ier)
else
if ( .not. ( cdwz(1,2).eq.0 .and. iepz(2).eq.iepw(1) ) )
+ call ffdcrr(cs3(21),ipi12(3),cy(2),cy(4),cz(2),cz(4),cz(1),
+ cz(3),cd2yzz,cw(1),cw(3),cw(2),cw(4),cd2yww,cdyz(2,2),
+ cdwy(1,2),cdwz(1,2),iepz(2),isoort(2),iepw(1),ier)
endif
* #] R's:
* #[ eta's:
if ( DIMAG(cpi(ip)) .eq. 0 ) then
call ffgeta(nz,cz,cdyz,
+ cpi(ip),cpiDpj(ii,ip),iepz,isoort,ier)
do 120 i=1,2
do 110 j=1,2
cdyw(i,j) = cdwy(j,i)
110 continue
120 continue
call ffgeta(nw,cw,cdyw,
+ cp2p,cpiDpj(ii,ip),iepw,isoort(3),ier)
else
print *,'ffcs4: error: not ready for complex D0 yet'
endif
ntot = nz(1)+nz(2)+nz(3)+nz(4)-nw(1)-nw(2)-nw(3)-nw(4)
if ( ntot .ne. 0 ) then
i2pi = 0
if ( 1/absc(cy(2)) .lt. xloss ) then
clogy = zfflo1(1/cy(2),ier)
else
c = -cy(4)/cy(2)
if ( DBLE(c) .gt. -abs(DIMAG(c)) ) then
clogy = zfflog(c,0,czero,ier)
else
* take out the factor 2*pi^2
cc = c+1
if ( absc(cc) .lt. xloss ) then
c2y1 = -cd2yzz - cz(1) + cz(4)
if ( absc(c2y1) .lt. xloss*max(absc(cz(1)),
+ absc(cz(4))) ) then
c2y1 = -cd2yzz - cz(2) + cz(3)
endif
clogy = zfflo1(-c2y1/cy(2),ier)
else
clogy = zfflog(-c,0,czero,ier)
endif
if ( DIMAG(c) .lt. 0 ) then
i2pi = -1
elseif ( DIMAG(c) .gt. 0 ) then
i2pi = +1
else
call fferr(51,ier)
i2pi = 0
endif
ipi12(2) = ipi12(2) - ntot*24*i2pi
endif
endif
if ( cs3(40) .ne. 0 ) print *,'ffcs4: error: cs3(40) != 0'
cs3(40) = ntot*c2ipi*clogy
endif
* #] eta's:
*###] ffcs4:
end
*###[ ffdcxr:
subroutine ffdcxr(cs3,ipi12,y,y1,z,z1,zp,zp1,d2yzz,
+ w,w1,wp,wp1,d2yww,dyz,dwy,dwz,iepsz,iepsw,ier)
***#[*comment:***********************************************************
* *
* Calculate *
* *
* R(y,z,iepsz) - R(y,w,iepsw) *
* *
* Input: *
* a = [yzw] (real) see definition *
* a1 = 1 - a (real) *
* dab = a - b (real) *
* ieps[zw] (integer) sign of imaginary part *
* of argument logarithm *
* cs3(20) (complex) assumed zero *
* *
* Output: *
* cs3(20) (complex) the results, not added *
* ipi12(2) (integer) factors pi^2/12 *
* *
* Calls: ffcxr *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(2),iepsz,iepsw,ier
DOUBLE COMPLEX cs3(20)
DOUBLE PRECISION y,z,w,y1,z1,w1,dyz,dwy,dwz,zp,zp1,d2yzz,wp,wp1,
+ d2yww
*
* local variables:
*
integer i,ieps
logical again
DOUBLE PRECISION yy,yy1,zz,zz1,dyyzz,xx1,xx1n,term,tot,d2,d3,
+ d21,d31,d2n,d3n,d21n1,d31n1,dw,x00(3)
DOUBLE COMPLEX chulp
DOUBLE PRECISION dfflo1
external dfflo1
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ groundwork:
if ( dwz .eq. 0 .and. iepsz .eq. iepsw ) return
if ( dyz .eq. 0 ) then
call fferr(75,ier)
return
endif
xx1 = y/dyz
dw = dwz/dyz
if ( xx1 .le. .5D0 .or. xx1 .gt. 2 ) then
d2 = 1/y
dw = dw*y/w
else
d2 = 1/z1
endif
again = .FALSE.
123 continue
* #] groundwork:
* #[ trivial case:
if ( dw .eq. 0 ) then
* #] trivial case:
* #[ normal case:
elseif ( abs(dw) .gt. xloss .or. again ) then
* nothing's the matter
call ffcxr(cs3( 1),ipi12(1),y,y1,z,z1,dyz,
+ .TRUE.,d2yzz,zp,zp1,.FALSE.,x00,iepsz,ier)
call ffcxr(cs3(11),ipi12(2),y,y1,w,w1,-dwy,
+ .TRUE.,d2yww,wp,wp1,.FALSE.,x00,iepsw,ier)
do 10 i=11,20
10 cs3(i) = -cs3(i)
ipi12(2) = -ipi12(2)
* #] normal case:
* #[ only cancellations in w, not in y:
elseif ( abs(d2) .gt. xloss ) then
* there are no cancellations the other way:
if ( iepsz .ne. iepsw .and. ( y/dyz .gt. 1 .or.-y/dwy .gt.
+ 1 ) ) then
again = .TRUE.
goto 123
endif
yy = dwy/dwz
zz = yy*z/y
yy1 = dyz/dwz
zz1 = yy1*w/y
dyyzz = yy*dyz/y
if ( y .lt. 0 ) then
ieps = iepsz
else
ieps = -iepsz
endif
call ffcxr(cs3( 1),ipi12(1),yy,yy1,zz,zz1,dyyzz,.FALSE.,
+ 0D0,0D0,0D0,.FALSE.,x00,2*ieps,ier)
zz = yy*z1/y1
zz1 = yy1*w1/y1
dyyzz = -yy*dyz/y1
if ( y1 .gt. 0 ) then
ieps = iepsz
else
ieps = -iepsz
endif
call ffcxr(cs3(11),ipi12(2),yy,yy1,zz,zz1,dyyzz,.FALSE.,
+ 0D0,0D0,0D0,.FALSE.,x00,2*ieps,ier)
do 20 i=11,20
cs3(i) = -cs3(i)
20 continue
ipi12(2) = -ipi12(2)
* #] only cancellations in w, not in y:
* #[ Hill identity:
elseif ( ( 1 .gt. xloss*abs(y) .or. abs(xx1) .gt. xloss )
+ .and. ( 1 .gt. xloss*abs(z) .or. abs(z/dyz) .gt. xloss )
+ .and. ( 1 .gt. xloss*abs(y) .or. abs(dyz/y) .gt. xloss )
+ ) then
* do a Hill identity on the y,y-1 direction
yy = -y*w1/dwy
yy1 = w*y1/dwy
zz = -z*w1/dwz
zz1 = w*z1/dwz
dyyzz = -w*w1*(dyz/(dwy*dwz))
if ( y*dwz .gt. 0 .eqv. (y+dwz) .gt. 0 ) then
ieps = 2*iepsw
else
ieps = -2*iepsw
endif
call ffcxr(cs3( 1),ipi12(1),yy,yy1,zz,zz1,dyyzz,.FALSE.,
+ 0D0,0D0,0D0,.FALSE.,x00,ieps,ier)
yy = w1
yy1 = w
zz = -w1*z/dwz
zz1 = w*z1/dwz
dyyzz = w*w1/dwz
call ffcxr(cs3( 9),ipi12(2),yy,yy1,zz,zz1,dyyzz,.FALSE.,
+ 0D0,0D0,0D0,.FALSE.,x00,ieps,ier)
do 30 i=9,16
30 cs3(i) = -cs3(i)
ipi12(2) = -ipi12(2)
* the extra logarithms ...
if ( 1 .lt. xloss*abs(w) ) then
chulp = dfflo1(1/w,ier)
elseif ( w1 .lt. 0 .or. w .lt. 0 ) then
chulp = log(-w1/w)
else
chulp = DCMPLX(DBLE(log(w1/w)),DBLE(-iepsw*pi))
endif
cs3(20) = -DBLE(dfflo1(dwz/dwy,ier))*chulp
* #] Hill identity:
* #[ Taylor expansion:
elseif ( (w.lt.0..or.w1.lt.0) .and. (z.lt.0..or.z1.lt.0) ) then
* do a Taylor expansion
if ( abs(xx1) .lt. xloss ) then
d3 = dwz/dwy
xx1n = xx1
d2n = d2
d3n = d3
d21 = 1-d2
d21n1 = 1
d31 = 1-d3
d31n1 = 1
tot = xx1*d2*d3
do 50 i=2,20
xx1n = xx1n*xx1
d21n1 = d21n1*d21
d31n1 = d31n1*d31
d2n = d2n + d2*d21n1
d3n = d3n + d3*d31n1
term = xx1n*d2n*d3n*xn2inv(i)
tot = tot + term
if ( abs(term) .le. precx*abs(tot) ) goto 51
50 continue
51 continue
cs3(1) = tot
elseif ( abs(z/dyz) .lt. xloss ) then
call ffcxr(cs3( 1),ipi12(1),y,y1,z,z1,dyz,
+ .TRUE.,d2yzz,zp,zp1,.FALSE.,x00,iepsz,ier)
call ffcxr(cs3(11),ipi12(2),y,y1,w,w1,-dwy,
+ .TRUE.,d2yww,wp,wp1,.FALSE.,x00,iepsw,ier)
do 110 i=11,20
110 cs3(i) = -cs3(i)
else
call fferr(22,ier)
return
endif
else
call ffcxr(cs3( 1),ipi12(1),y,y1,z,z1,dyz,.FALSE.,
+ 0D0,0D0,0D0,.FALSE.,x00,iepsz,ier)
call ffcxr(cs3(11),ipi12(2),y,y1,w,w1,-dwy,.FALSE.,
+ 0D0,0D0,0D0,.FALSE.,x00,iepsw,ier)
do 40 i=11,20
40 cs3(i) = -cs3(i)
ipi12(2) = -ipi12(2)
endif
* #] Taylor expansion:
*###] ffdcxr:
end
*###[ ffdcrr:
subroutine ffdcrr(cs3,ipi12,cy,cy1,cz,cz1,czp,czp1,cd2yzz,cw,cw1
+ ,cwp,cwp1,cd2yww,cdyz,cdwy,cdwz,isoort,iepsz,iepsw,ier)
***#[*comment:***********************************************************
* *
* Calculate *
* *
* R(cy,cz,iepsz) - R(cy,cw,iepsw) *
* *
* Input: *
* a = [yzw] (real) see definition *
* a1 = 1 - a (real) *
* dab = a - b (real) *
* ieps[zw] (integer) sign of imaginary part *
* of argument logarithm *
* cs3(20) (complex) assumed zero *
* *
* Output: *
* cs3(20) (complex) the results, not added *
* ipi12(2) (integer) factors pi^2/12 *
* *
* Calls: ffcrr *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ipi12(2),isoort,iepsz,iepsw,ier
DOUBLE COMPLEX cs3(20)
DOUBLE COMPLEX cy,cz,czp,cw,cwp,cy1,cz1,czp1,cw1,cwp1,
+ cdyz,cdwy,cdwz,cd2yzz,cd2yww
*
* local variables:
*
integer i,ieps,ieps1,ieps2,
+ nffeta,nffet1,n1,n2,n3,n4,n5,n6
logical ld2yyz
DOUBLE COMPLEX cyy,cyy1,czz,czz1,cdyyzz,chulp,zfflo1,zfflog,
+ cc1,cdw,cc1n,cterm,ctot,cd2,cd3,
+ cd21,cd31,cd2n,cd3n,cd21n1,cd31n1,
+ cc2,cfactz,cfactw,czzp,czzp1,cd2yyz
DOUBLE COMPLEX c
DOUBLE PRECISION absc
external nffeta,nffet1,zfflo1,zfflog
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ groundwork:
if ( cdwz .eq. 0 ) then
if ( abs(DIMAG(cz)) .gt. precc*abs(DBLE(cz)) .or.
+ iepsz .eq. iepsw ) return
if ( DBLE(cz) .ge. 0 .and. DBLE(cz1) .ge. 0 ) return
call fferr(76,ier)
return
endif
if ( cdyz .eq. 0 ) then
call fferr(77,ier)
return
endif
cc1 = cy/cdyz
cdw = cdwz/cdyz
if ( DBLE(cc1) .le. .5D0 .or. abs(cc1-1) .gt. 1 ) then
cd2 = 1/cy
cdw = cdw*cy/cw
else
cd2 = 1/cz1
endif
* #] groundwork:
* #[ trivial case:
if ( absc(cdw) .eq. 0 ) then
* #] trivial case:
* #[ normal case:
*
* if no cancellations are expected OR the imaginary signs differ
* and are significant
*
elseif ( absc(cdw) .gt. xloss .or. (iepsz.ne.iepsw .and.
+ (DBLE(cy/cdyz).gt.1 .or. DBLE(-cy1/cdyz).gt.1) ) ) then
* nothing's the matter
* special case to avoid bug found 15-oct=1995
if ( iepsz.eq.iepsw ) then
if ( DIMAG(cz).eq.0 .and. DIMAG(cz1).eq.0 ) then
print *,'ffdcrr: flipping sign iepsz'
iepsz = -iepsz
elseif ( DIMAG(cw).eq.0 .and. DIMAG(cw1).eq.0 ) then
print *,'ffdcrr: flipping sign iepsw'
iepsw = -iepsw
else
print *,'ffdcrr: error: missing eta terms!'
ier = ier + 100
endif
endif
call ffcrr(cs3(1),ipi12(1),cy,cy1,cz,cz1,cdyz,.TRUE.,
+ cd2yzz,czp,czp1,isoort,iepsz,ier)
call ffcrr(cs3(8),ipi12(2),cy,cy1,cw,cw1,-cdwy,.TRUE.,
+ cd2yww,cwp,cwp1,isoort,iepsw,ier)
do 10 i=8,14
cs3(i) = -cs3(i)
10 continue
ipi12(2) = -ipi12(2)
* #] normal case:
* #[ only cancellations in cw, not in cy:
elseif ( absc(cd2) .gt. xloss ) then
* there are no cancellations the other way:
cyy = cdwy/cdwz
czz = cz*cyy/cy
cyy1 = cdyz/cdwz
czz1 = cyy1*cw/cy
cdyyzz = cdyz*cyy/cy
if ( DBLE(cy) .gt. 0 ) then
ieps1 = -3*iepsz
else
ieps1 = +3*iepsz
endif
* Often 2y-z-z is relevant, but 2*yy-zz-zz is not, solve by
* introducing zzp.
czzp = czp*cyy/cy
cd2yyz = cd2yzz*cyy/cy
czzp1 = 1 - czzp
if ( absc(czzp1) .lt. xloss ) then
* later try more possibilities
ld2yyz = .FALSE.
else
ld2yyz = .TRUE.
endif
call ffcrr(cs3(1),ipi12(1),cyy,cyy1,czz,czz1,cdyyzz,
+ ld2yyz,cd2yyz,czzp,czzp1,isoort,ieps1,ier)
czz = cyy*cz1/cy1
czz1 = cyy1*cw1/cy1
if ( DBLE(-cy1) .gt. 0 ) then
ieps2 = -3*iepsz
else
ieps2 = +3*iepsz
endif
cdyyzz = -cyy*cdyz/cy1
czzp = czp1*cyy/cy1
cd2yyz = -cd2yzz*cyy/cy1
czzp1 = 1 - czzp
if ( absc(czzp1) .lt. xloss ) then
* later try more possibilities
ld2yyz = .FALSE.
else
ld2yyz = .TRUE.
endif
call ffcrr(cs3(8),ipi12(2),cyy,cyy1,czz,czz1,cdyyzz,
+ .TRUE.,cd2yyz,czzp,czzp1,isoort,ieps2,ier)
do 20 i=8,14
cs3(i) = -cs3(i)
20 continue
ipi12(2) = -ipi12(2)
* eta terms (are not calculated in ffcrr as ieps = 3)
cfactz = 1/cdyz
if ( DIMAG(cz) .eq. 0 ) then
if ( DIMAG(cy) .eq. 0 ) then
n1 = 0
n2 = 0
else
n1 = nffet1(DCMPLX(DBLE(0),DBLE(iepsz)),cfactz,
+ -cz*cfactz,ier)
n2 = nffet1(DCMPLX(DBLE(0),DBLE(iepsz)),cfactz,
+ cz1*cfactz,ier)
endif
else
n1 = nffeta(-cz,cfactz,ier)
n2 = nffeta(cz1,cfactz,ier)
endif
cfactw = -1/cdwy
if ( DIMAG(cw) .eq. 0 ) then
if ( DIMAG(cy) .eq. 0 ) then
n4 = 0
n5 = 0
else
n4 = nffet1(DCMPLX(DBLE(0),DBLE(iepsw)),cfactw,
+ -cw*cfactw,ier)
n5 = nffet1(DCMPLX(DBLE(0),DBLE(iepsw)),cfactw,
+ cw1*cfactw,ier)
endif
else
n4 = nffeta(-cw,cfactw,ier)
n5 = nffeta(cw1,cfactw,ier)
endif
*
* we assume that cs3(15-17) are not used, this is always true
*
n3 = 0
n6 = 0
if ( n1.eq.n4 ) then
if ( n1.eq.0 ) then
* nothing to do
else
cc1 = cdwz/cdyz
if ( absc(cc1) .lt. xloss ) then
cs3(15) = n1*c2ipi*zfflo1(cc1,ier)
else
cc1 = -cdwy/cdyz
cs3(15) = n1*c2ipi*zfflog(cc1,0,czero,ier)
endif
cc1 = cy*cfactz
cc2 = cy*cfactw
if ( DIMAG(cc1).eq.0 .or. DIMAG(cc2).eq.0 ) then
n3 = 0
else
n3 = nffeta(cc1,1/cc2,ier)
endif
if ( n3.ne.0 ) then
print *,'ffdcrr: error: untested algorithm'
ier = ier + 50
ipi12(1) = ipi12(1) + 4*12*n1*n3
endif
endif
else
cc1 = cy*cfactz
cc2 = cy*cfactw
cs3(15) = (n1*zfflog(cc1,ieps1,czero,ier) +
+ n4*zfflog(cc2,ieps1,czero,ier))*c2ipi
endif
if ( n2.eq.n5 ) then
if ( n2.eq.0 ) then
* nothing to do
else
cc1 = cdwz/cdyz
if ( absc(cc1) .lt. xloss ) then
cs3(16) = n2*c2ipi*zfflo1(cc1,ier)
else
cc1 = -cdwy/cdyz
cs3(16) = n2*c2ipi*zfflog(cc1,0,czero,ier)
endif
cc1 = -cy1*cfactz
cc2 = -cy1*cfactw
if ( DIMAG(cc1).eq.0 .or. DIMAG(cc2).eq.0 ) then
n6 = 0
else
n6 = nffeta(cc1,1/cc2,ier)
endif
if ( n6.ne.0 ) then
print *,'ffdcrr: error: untested algorithm'
ier = ier + 50
ipi12(2) = ipi12(2) + 4*12*n2*n6
endif
endif
else
cc1 = -cy1*cfactz
cc2 = -cy1*cfactw
cs3(15) = (n2*zfflog(cc1,ieps2,czero,ier) +
+ n5*zfflog(cc2,ieps2,czero,ier))*c2ipi
endif
* #] only cancellations in cw, not in cy:
* #[ Hill identity:
elseif ( ( 1.gt.xloss*absc(cy) .or. absc(cc1).gt.xloss )
+ .and. ( 1.gt.xloss*absc(cz) .or. absc(cz/cdyz).gt.xloss )
+ .and. ( 1.gt.xloss*absc(cy) .or. absc(cdyz/cy).gt.xloss )
+ ) then
* do a Hill identity on the cy,cy-1 direction
cyy = -cy*cw1/cdwy
cyy1 = cw*cy1/cdwy
czz = -cz*cw1/cdwz
czz1 = cw*cz1/cdwz
cdyyzz = -cw*cw1*(cdyz/(cdwy*cdwz))
ieps = -2*iepsz
call ffcrr(cs3(1),ipi12(1),cyy,cyy1,czz,czz1,cdyyzz,
+ .FALSE.,czero,czero,czero,isoort,ieps,ier)
cyy = cw1
cyy1 = cw
czz = -cw1*cz/cdwz
czz1 = cw*cz1/cdwz
cdyyzz = cw*cw1/cdwz
call ffcrr(cs3(8),ipi12(2),cyy,cyy1,czz,czz1,cdyyzz,
+ .FALSE.,czero,czero,czero,isoort,0,ier)
do 30 i=8,14
30 cs3(i) = -cs3(i)
ipi12(2) = -ipi12(2)
* the extra logarithms ...
if ( 1 .lt. xloss*absc(cw) ) then
chulp = zfflo1(1/cw,ier)
else
chulp = zfflog(-cw1/cw,0,czero,ier)
endif
cs3(15) = -zfflo1(cdwz/cdwy,ier)*chulp
* #] Hill identity:
* #[ Taylor expansion:
else
* Do a Taylor expansion
if ( absc(cc1) .lt. xloss ) then
cd3 = cdwz/cdwy
* isign = 1
cc1n = cc1
cd2n = cd2
cd3n = cd3
cd21 = 1-cd2
cd21n1 = 1
cd31 = 1-cd3
cd31n1 = 1
ctot = cc1*cd2*cd3
do 50 i=2,20
cc1n = cc1n*cc1
cd21n1 = cd21n1*cd21
cd31n1 = cd31n1*cd31
cd2n = cd2n + cd2*cd21n1
cd3n = cd3n + cd3*cd31n1
cterm = cc1n*cd2n*cd3n*DBLE(xn2inv(i))
ctot = ctot + cterm
if ( absc(cterm) .lt. precc*absc(ctot) ) goto 51
50 continue
51 continue
cs3(1) = ctot
elseif ( absc(cz/cdyz) .lt. xloss ) then
call ffcrr(cs3(1),ipi12(1),cy,cy1,cz,cz1,cdyz,.TRUE.,
+ cd2yzz,czp,czp1,isoort,iepsz,ier)
call ffcrr(cs3(8),ipi12(2),cy,cy1,cw,cw1,-cdwy,.TRUE.,
+ cd2yww,cwp,cwp1,isoort,iepsw,ier)
do 110 i=8,14
110 cs3(i) = -cs3(i)
ipi12(2) = -ipi12(2)
else
call fferr(20,ier)
return
endif
endif
* #] Taylor expansion:
*###] ffdcrr:
end
diff --git a/Looptools/util/ffcxyz.F b/Looptools/util/ffcxyz.F
--- a/Looptools/util/ffcxyz.F
+++ b/Looptools/util/ffcxyz.F
@@ -1,305 +1,308 @@
+#include "externals.h"
+
+
*###[ ffcxyz:
subroutine ffcxyz(cy,cz,cdyz,cd2yzz,ivert,sdelpp,sdelps,
+ etami,delps,xpi,piDpj,isoort,ldel2s,ns,ier)
***#[*comment:***********************************************************
* *
* calculate in a numerically stable way *
* *
* cz(1,2) = (-p(ip1).p(is2) +/- sdelpp)/xpi(ip1) *
* cy(1,2) = (-p(ip1).p(is2) +/- sdisc)/xpi(ip1) *
* disc = slam1 + 4*eta*xpi(ip)/slam *
* *
* cy(3,4) = 1-cy(1,2) *
* cz(3.4) = 1-cz(1,2) *
* cdyz(i,j) = cy(i) - cz(j) *
* *
* Input: ivert (integer) 1,2 of 3 *
* sdelpp (real) sqrt(lam(p1,p2,p3))/2 *
* sdelps (real) sqrt(-lam(p,ma,mb))/2 *
* etalam (real) det(si.sj)/det(pi.pj) *
* etami(6) (real) si.si - etalam *
* xpi(ns) (real) standard *
* piDpj(ns,ns) (real) standard *
* ns (integer) dim of xpi,piDpj *
* *
* Output: cy(4),cz(4),cdyz(4,4) (complex) see above *
* *
* Calls: ?? *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ivert,isoort(2),ns,ier
logical ldel2s
DOUBLE COMPLEX cy(4),cz(4),cdyz(2,2),cd2yzz
DOUBLE PRECISION sdelpp,sdelps,etami(6),delps,xpi(ns),
+ piDpj(ns,ns)
*
* local variables:
*
integer ip1,is1,is2,is3
DOUBLE COMPLEX c
DOUBLE PRECISION absc,y(4)
DOUBLE PRECISION disc,hulp
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ set up pointers:
if ( ldel2s .and. ivert .ne. 1 ) goto 100
is1 = ivert
is2 = ivert+1
if ( is2 .eq. 4 ) is2 = 1
is3 = ivert-1
if ( is3 .eq. 0 ) is3 = 3
ip1 = is1 + 3
* ip2 = is2 + 3
* ip3 = is3 + 3
isoort(1) = -10
isoort(2) = -10
* #] set up pointers:
* #[ get cypm,czpm:
hulp = sdelps/xpi(ip1)
cz(1) = DCMPLX(piDpj(ip1,is2)/xpi(ip1),-hulp)
cz(2) = DCMPLX(piDpj(ip1,is2)/xpi(ip1),+hulp)
disc = delps/sdelpp
call ffroot(y(1),y(2),xpi(ip1),piDpj(ip1,is2),etami(is2),disc,
+ ier)
cy(1) = y(1)
cy(2) = y(2)
* #] get cypm,czpm:
* #[ get cypm1,czpm1:
if ( xpi(is1) .eq. xpi(is2) ) then
cy(4) = cy(1)
cy(3) = cy(2)
cz(4) = cz(1)
cz(3) = cz(2)
else
cz(3) = 1 - cz(1)
cz(4) = 1 - cz(2)
if ( absc(cz(3)).lt.xloss .or. absc(cz(4)).lt.xloss ) then
cz(3) =DCMPLX(-piDpj(ip1,is1)/xpi(ip1),+hulp)
cz(4) =DCMPLX(-piDpj(ip1,is1)/xpi(ip1),-hulp)
endif
y(3) = 1 - y(1)
y(4) = 1 - y(2)
if ( abs(y(3)) .lt. xloss .or. abs(y(4)) .lt. xloss ) then
call ffroot(y(4),y(3),xpi(ip1),-piDpj(ip1,is1),
+ etami(is1),disc,ier)
endif
cy(3) = y(3)
cy(4) = y(4)
endif
* #] get cypm1,czpm1:
* #[ get cdypzp, cdypzm:
cdyz(2,1) = DCMPLX(disc/xpi(ip1),+hulp)
cdyz(2,2) = DCMPLX(disc/xpi(ip1),-hulp)
cdyz(1,1) = -cdyz(2,2)
cdyz(1,2) = -cdyz(2,1)
cd2yzz = 2*disc/xpi(ip1)
goto 200
* #] get cdypzp, cdypzm:
* #[ special case, get indices:
100 continue
if ( ivert.eq.2 ) then
is1 = 2
ip1 = 5
else
is1 = 1
ip1 = 6
endif
isoort(1) = -100
isoort(2) = -100
* #] special case, get indices:
* #[ get cypm,czpm:
*
* special case del2s = 0, hence the roots are not the real roots
* but z_2'' = (z_2'-1)/delta, z''_3 = -z'_3/delta
*
hulp = sdelps/xpi(3)
disc = delps/sdelpp
if ( ivert .eq. 3 ) then
hulp = -hulp
disc = -disc
endif
cz(1) = DCMPLX(piDpj(is1,3)/xpi(3),-hulp)
cz(2) = DCMPLX(piDpj(is1,3)/xpi(3),+hulp)
call ffroot(y(1),y(2),xpi(3),piDpj(is1,3),etami(is1),disc,ier)
cy(1) = y(1)
cy(2) = y(2)
* #] get cypm,czpm:
* #[ get cypm1,czpm1:
cz(3) = 1 - cz(1)
cz(4) = 1 - cz(2)
if ( absc(cz(3)).lt.xloss .or. absc(cz(4)).lt.xloss ) then
if ( ivert.eq.2 ) then
cz(3) =DCMPLX(piDpj(ip1,3)/xpi(3),+hulp)
cz(4) =DCMPLX(piDpj(ip1,3)/xpi(3),-hulp)
else
cz(3) =DCMPLX(-piDpj(ip1,3)/xpi(3),+hulp)
cz(4) =DCMPLX(-piDpj(ip1,3)/xpi(3),-hulp)
endif
endif
y(3) = 1 - y(1)
y(4) = 1 - y(2)
if ( abs(y(3)) .lt. xloss .or. abs(y(4)) .lt. xloss ) then
if ( ivert .eq. 2 ) then
call ffroot(y(4),y(3),xpi(3),piDpj(ip1,3),etami(ip1),
+ disc,ier)
else
call ffroot(y(4),y(3),xpi(3),-piDpj(ip1,3),etami(ip1),
+ disc,ier)
endif
endif
cy(3) = y(3)
cy(4) = y(4)
* #] get cypm1,czpm1:
* #[ get cdypzp, cdypzm:
cdyz(2,1) = DCMPLX(disc/xpi(3),+hulp)
cdyz(2,2) = DCMPLX(disc/xpi(3),-hulp)
cdyz(1,1) = -cdyz(2,2)
cdyz(1,2) = -cdyz(2,1)
cd2yzz = 2*disc/xpi(3)
* #] get cdypzp, cdypzm:
200 continue
*###] ffcxyz:
end
*###[ ffcdwz:
subroutine ffcdwz(cdwz,cz,i1,j1,l,calpha,calph1,cpi,cdpipj,
+ cpiDpj,csdeli,csdel2,ns,ier)
***#[*comment:***********************************************************
* *
* Recalculate cdwz(i1,j1) = cw(i1) - cz(j1) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer i1,j1,l,ns,ier
DOUBLE COMPLEX cdwz(2,2),cz(4),calpha,calph1,cpi(ns)
DOUBLE COMPLEX cdpipj(ns,ns),cpiDpj(ns,ns),csdeli(3),csdel2
*
* local variables:
*
integer i,n
DOUBLE COMPLEX cs(8),csum,cfac,c,cddel
DOUBLE PRECISION xmax,absc,afac
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ calculations:
if ( l .eq. 1 ) then
if ( j1 .eq. 1 ) then
if ( absc(csdeli(1)+csdel2) .lt. xloss*absc(csdel2) )
+ then
* for example in e-> e g* with eeg loop
* first get the difference of csdeli(1) and csdel2:
cs(1) = cpi(4)*cdpipj(2,5)
cs(2) = -cpiDpj(4,3)*cpiDpj(4,2)
cs(3) = cpiDpj(4,3)*cpiDpj(4,5)
csum = cs(1)+cs(2)+cs(3)
xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)))
if ( absc(csum) .lt. xloss*xmax ) then
ier = 1
goto 5
endif
cddel = csum/(csdel2-csdeli(1))
if ( i1 .eq. 1 ) then
cs(1) = cpi(4)*csdeli(2)
else
cs(1) = -cpi(4)*csdeli(2)
endif
cs(2) = cddel*cpiDpj(4,2)
cs(3) = -cpiDpj(4,3)*csdeli(1)
cs(4) = cpiDpj(4,3)*cpiDpj(4,5)
cs(5) = -cpi(4)*cpiDpj(5,3)
cs(6) = -cddel*csdel2
n = 6
else
ier = ier + 100
goto 5
endif
csum = 0
xmax = 0
do 1 i=1,n
csum = csum + cs(i)
xmax = max(xmax,absc(cs(i)))
1 continue
if ( absc(csum) .lt. xloss*xmax ) then
ier = ier + 1
endif
cdwz(i1,j1) = csum/calph1/cpi(4)/cpi(5)
if ( cdwz(i1,j1) .eq. 0 .and. csum .ne. 0 ) then
print *,'?#$&!! cdwz = 0 but csum != 0, try again'
afac = 1/absc(csum)
csum = csum*DBLE(afac)
cdwz(i1,j1) = csum/calph1/cpi(4)/cpi(5)
afac = 1/afac
cdwz(i1,j1) = cdwz(i1,j1)*DBLE(afac)
endif
else
ier = ier + 100
endif
5 continue
elseif ( l .eq. 3 ) then
if ( (i1.eq.2 .and. j1.eq.1) .or. (i1.eq.1 .and. j1.eq.2 ) )
+ then
cfac = 1/(csdeli(2) + csdeli(3))
cs(1) = cdpipj(6,5)*cz(j1)
cs(2) = -calph1*cpi(5)*cz(j1+2)
if ( max(absc(cdpipj(2,1)),absc(cdpipj(5,6))) .lt.
+ max(absc(cdpipj(2,6)),absc(cdpipj(5,1))) ) then
cs(3) = cdpipj(2,1)/2
cs(4) = cdpipj(5,6)/2
else
cs(3) = cdpipj(2,6)/2
cs(4) = cdpipj(5,1)/2
endif
cs(5) = cpiDpj(4,3)*cpiDpj(5,3)*cfac
cs(6) = -cpiDpj(4,3)*cpiDpj(6,3)*cfac
cs(7) = cpi(3)*cdpipj(5,6)*cfac
if ( i1 .eq. 1 ) then
csum = cs(1)+cs(2)+cs(3)+cs(4) - (cs(5)+cs(6)+cs(7))
else
csum = cs(1)+cs(2)+cs(3)+cs(4) + cs(5)+cs(6)+cs(7)
endif
xmax = absc(cs(1))
do 10 i=2,7
xmax = max(xmax,absc(cs(i)))
10 continue
if ( absc(csum) .lt. xloss*xmax ) then
* this result is not used if it is not accurate (see
* ffxc0p)
ier = ier + 1
xmax = xmax/absc(calpha*cpi(5))
if ( xmax .lt. min(absc(cz(j1)),absc(cz(j1+2))) )
+ then
cdwz(i1,j1) = csum/(calpha*cpi(5))
endif
else
cdwz(i1,j1) = csum/(calpha*cpi(5))
endif
else
ier = ier + 100
endif
else
ier = ier + 100
endif
* #] calculations:
*###] ffcdwz:
end
diff --git a/Looptools/util/ffdcxs.F b/Looptools/util/ffdcxs.F
--- a/Looptools/util/ffdcxs.F
+++ b/Looptools/util/ffdcxs.F
@@ -1,621 +1,624 @@
+#include "externals.h"
+
+
*--#[ log:
* $Id: ffdcxs.f,v 1.7 1996/03/22 08:13:30 gj Exp $
* $Log: ffdcxs.f,v $
c Revision 1.7 1996/03/22 08:13:30 gj
c Fixed bug in bugfix of ffdcxs.f
c
c Revision 1.6 1996/03/14 15:53:13 gj
c Fixed bug in ffcb0: cp in C, cma=cmb=0 was computed incorrectly.
c
c Revision 1.5 1996/03/13 15:43:36 gj
c Fixed bug, when ieps unknown already some things were computed and not zero'd.
c Now I first check ieps, and then compute.
c
c Revision 1.4 1995/12/08 10:38:16 gj
c Fixed too long line
c
*--#] log:
*###[ ffdcxs:
subroutine ffdcxs(cs3,ipi12,y,z,dyz,d2yzz,dy2z,dyzzy,xpi,piDpj,
+ ii,ns,isoort,ier)
***#[*comment:***********************************************************
* *
* calculates the the difference of two S's with y(3,4),z(3,4) and *
* y(4)z(3)-y(3)z(4) given. Note the difference with ffdcxs4, in *
* which the y's are the same and only the z's different. Here *
* both can be different. Also we skip an intermediate level. *
* Note also that this routine is much less conservative than *
* ffcxs3 in its expectations of the order of the roots: it knows *
* that it is (z-,z+,1-z-,1-z+)! *
* *
* input: y(4,3:4) (real) y,1-y in S with s3,s4 *
* z(4,3:4) (real) z,1-z in S with s3,s4 *
* dyz(2,2,3:4) (real) y - z *
* d2yzz(3:4) (real) 2*y - z+ - z- *
* dy2z(4,3:4) (real) y - 2*z *
* dyzzy(4) (real) y(i,4)*z(i,4)-y(i,3)*z(i,4) *
* xpi(6,3:4) (real) usual *
* piDpj(6,3:4) (real) usual *
* cs3(40) (complex) assumed zero. *
* *
* output: cs3(40) (complex) mod factors pi^2/12, in array *
* ipi12(6)(integer) these factors *
* isoort(6)(integer) returns kind of action taken *
* ier (integer) 0=ok 1=inaccurate 2=error *
* *
* calls: ffcrr,ffcxr,real/dble,DCMPLX,log,ffadd1,ffadd2,ffadd3 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cs3(100)
DOUBLE PRECISION y(4,3:4),z(4,3:4),dyz(2,2,3:4),d2yzz(3:4),
+ dy2z(4,3:4),dyzzy(4),xpi(6,3:4),piDpj(6,6,3:4)
integer ipi12(10),ii,ns,isoort(10),ier
*
* local variables
*
integer i,j,k,l,m,iepsi(4),iepsj(2,2)
logical normal
DOUBLE PRECISION yy,zz,yy1,zz1,dyyzz,hulp3,hulp4,x00(3)
save iepsi
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* data
*
data iepsi /-2,+2,+2,-2/
*
* check constants
* #] declarations:
* #[ normal case:
normal = .FALSE.
10 continue
if ( normal .or. isoort(1) .ne. isoort(9) .or. isoort(1) .lt.
+ 10 ) then
call ffcxs3(cs3( 1),ipi12(1),y(1,3),z(1,3),dyz(1,1,3),
+ d2yzz(3),dy2z(1,3),xpi(1,3),piDpj(1,1,3),ii,6,
+ isoort(1),ier)
call ffcxs3(cs3(81),ipi12(9),y(1,4),z(1,4),dyz(1,1,4),
+ d2yzz(4),dy2z(1,4),xpi(1,4),piDpj(1,1,4),ii,6,
+ isoort(9),ier)
return
endif
* #] normal case:
* #[ rotate R's:
if ( abs(y(2,3)) .lt. 1/xloss ) then
do 102 i=1,2
do 101 j=1,2
* iepsi() = /-2,+2,+2,-2/
* BUT I AM NOT YET SURE OF THE SIGNS (29/6/89)
k = 2*(i-1)+j
if ( y(2*i,3) .gt. 0 ) then
iepsj(j,i) = iepsi(k)
else
iepsj(j,i) = -iepsi(k)
endif
if ( y(2*i,3) .gt. 0 .neqv. y(2*i,4) .gt. 0 ) then
* I have no clue to the ieps, take normal route
* iepsj(j,i) = 0
normal = .TRUE.
goto 10
endif
101 continue
102 continue
* loop over y,z , 1-y,1-z
do 120 i=1,2
* loop over z+ , z-
do 110 j=1,2
if ( j .eq. 2 ) then
* do not calculate if not there (isoort=0, one root)
* (this is probably not needed as this case should
* have been dealt with in ffdxc0)
if ( isoort(9) .eq. 0 ) goto 110
* or if not needed (isoort=2, two equal roots)
if ( mod(isoort(9),10) .eq. 2 ) then
* we use that l still contains the correct value
do 105 m=1,7
cs3(10*(l-1)+m) = 2*DBLE(cs3(10*(l-1)+m))
105 continue
ipi12(l) = 2*ipi12(l)
goto 110
endif
endif
k = 2*(i-1)+j
l = 8*(i-1)+j
if ( dyzzy(k) .ne. 0 ) then
* minus sign wrong in thesis (2.78)
hulp3 = -dyz(2,j,3)/dyzzy(k)
hulp4 = +dyz(2,j,4)/dyzzy(k)
yy = y(2*i,3)*hulp4
yy1 = y(2*i,4)*hulp3
zz = z(k,3)*hulp4
zz1 = z(k,4)*hulp3
dyyzz = dyz(2,j,3)*hulp4
if ( i .eq. 2 ) then
yy = -yy
yy1 = -yy1
zz = -zz
zz1 = -zz1
endif
call ffcxr(cs3(10*l-9),ipi12(l),yy,yy1,zz,zz1,dyyzz,
+ .FALSE.,0D0,0D0,0D0,.FALSE.,x00,iepsj(j,i),ier)
endif
110 continue
120 continue
goto 800
endif
* #] rotate R's:
* #[ other cases (not ready):
call ffcxs3(cs3( 1),ipi12(1),y(1,3),z(1,3),dyz(1,1,3),
+ d2yzz(3),dy2z(1,3),xpi(1,3),piDpj(1,1,3),ii,ns,
+ isoort(1),ier)
call ffcxs3(cs3(81),ipi12(9),y(1,4),z(1,4),dyz(1,1,4),
+ d2yzz(4),dy2z(1,4),xpi(1,4),piDpj(1,1,4),ii,ns,
+ isoort(9),ier)
return
* #] other cases (not ready):
800 continue
*###] ffdcxs:
end
*###[ ffdcs:
subroutine ffdcs(cs3,ipi12,cy,cz,cdyz,cd2yzz,cdyzzy,cdyyzz,
+ cpi,cpiDpj,ii,ns,isoort,ier)
***#[*comment:***********************************************************
* *
* calculates the the difference of two S's with cy(3,4),cz(3,4), *
* cy(4)cz(3)-cy(3)cz(4) given. Note the difference with ffdcs4, *
* in which the cy's are the same and only the cz's different. *
* Here both can be different. Also we skip an intermediat *
* level. *
* *
* input: cy(4,3:4) (complex) cy,1-cy in S with s3,s4 *
* cz(4,3:4) (complex) cz,1-cz in S with s3,s4 *
* cdyz(2,2,3:4)(complex) cy - cz *
* cd2yzz(3:4) (complex) 2*cy - cz+ - cz- *
* cdyzzy(4) (complex) cy(i,4)*cz(i,4)-cy(i,3)*cz(i,4) *
* cdyyzz(2) (complex) cy(i,4)-cz(i,4)-cy(i,3)+cz(i,4) *
* cpi(6,3:4) (complex) usual *
* cpiDpj(6,3:4)(complex) usual *
* cs3(40) (complex) assumed zero. *
* *
* output: cs3(40) (complex) mod factors pi^2/12, in array *
* ipi12(6) (integer) these factors *
* isoort(6) (integer) returns kind of action taken *
* ier (integer) number of digits lost *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cs3(100)
DOUBLE COMPLEX cy(4,3:4),cz(4,3:4),cdyz(2,2,3:4),cd2yzz(3:4),
+ cdyzzy(4),cdyyzz(2),cpi(6,3:4),cpiDpj(6,6,3:4)
integer ipi12(10),ii,ns,isoort(10),ier
*
* local variables
*
integer i,j,k,l,m,n,ieps,ni(4,3:4),ntot(3:4),
+ n1a,nffeta,nffet1,ip
DOUBLE COMPLEX c,cc,clogy,zfflog,
+ zfflo1,cmip,yy,zz,yy1,zz1,dyyzz,hulp3,hulp4
DOUBLE PRECISION absc
external nffeta,nffet1,zfflo1,zfflog
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) +abs(DIMAG(c))
*
* check constants
* #] declarations:
* #[ normal case:
if ( mod(isoort(1),5).ne.mod(isoort(9),5) .or. isoort(1).gt.-5
+ ) then
call ffcs3(cs3( 1),ipi12(1),cy(1,3),cz(1,3),cdyz(1,1,3),
+ cd2yzz(3),cpi(1,3),cpiDpj(1,1,3),ii,6,isoort(1),ier)
call ffcs3(cs3(81),ipi12(9),cy(1,4),cz(1,4),cdyz(1,1,4),
+ cd2yzz(4),cpi(1,4),cpiDpj(1,1,4),ii,6,isoort(9),ier)
return
endif
* #] normal case:
* #[ rotate R's:
if ( absc(cy(2,3)) .lt. 1/xloss .or. isoort(1) .le. -100 ) then
*
* loop over cy,cz , 1-cy,1-cz
do 190 i=1,2
if ( isoort(1).le.-100 .and. i.eq.2 ) then
*
* special case del2s=0, a limit has been taken
*
if ( ii .eq. 2 ) then
*
* we took the wrong sign for the dilogs...
*
do 110 j=1,20
cs3(j) = -cs3(j)
110 continue
ipi12(1) = -ipi12(1)
ipi12(2) = -ipi12(2)
endif
*
* now the remaining logs. take care to get the ieps
* correct!
*
if ( i.eq.1 .eqv. DBLE(cy(2*i,3)).gt.0 ) then
ieps = -3
else
ieps = +3
endif
call ffclg2(cs3(81),cdyz(2,1,3),cdyz(2,1,4),
+ cdyyzz(1),ieps,ier)
if ( ii .eq. 2 ) then
* we have the wrong sign
do 120 j=81,83
cs3(j) = -cs3(j)
120 continue
ipi12(9) = -ipi12(9)
endif
if ( mod(isoort(1),5).eq.0 .and. mod(isoort(9),5).eq.0
+ ) then
do 130 j=81,83
cs3(j) = 2*DBLE(cs3(j))
130 continue
ipi12(9) = 2*ipi12(9)
else
print *,'ffdcs: error: not yet tested'
call ffclg2(cs3(91),cdyz(2,2,3),cdyz(2,2,4),
+ cdyyzz(2),-ieps,ier)
if ( ii .eq. 2 ) then
* we have the wrong sign
do 140 j=91,93
cs3(j) = -cs3(j)
140 continue
ipi12(10) = -ipi12(10)
endif
endif
goto 190
endif
*
* loop over cz- , cz+
do 180 j=1,2
if ( j .eq. 2 ) then
if ( isoort(9) .eq. 0 .or. isoort(1) .eq. 0 ) then
*
* (this is not correct as this case should
* have been dealt with in ffdxc0,ffdcc0)
*
call fferr(79,ier)
goto 180
elseif ( mod(isoort(9),5) .eq. 0 .and.
+ mod(isoort(1),5) .eq. 0 ) then
*
* or if not needed (isoort=-10, two conjugate roots)
*
* we use that l still contains the correct value
do 150 m=1,9
cs3(10*(l-1)+m) = 2*DBLE(cs3(10*(l-1)+m))
150 continue
ipi12(l) = 2*ipi12(l)
goto 180
elseif ( mod(isoort(9),10) .eq. 2 ) then
* we use that l still contains the correct value
do 160 m=1,9
cs3(10*(l-1)+m) = 2*cs3(10*(l-1)+m)
160 continue
ipi12(l) = 2*ipi12(l)
goto 180
endif
endif
k = 2*(i-1)+j
l = 8*(i-1)+j
if ( cdyzzy(k) .ne. 0 ) then
hulp3 = -cdyz(2,j,3)/cdyzzy(k)
hulp4 = cdyz(2,j,4)/cdyzzy(k)
yy = cy(2*i,3)*hulp4
yy1 = cy(2*i,4)*hulp3
zz = cz(k,3)*hulp4
zz1 = cz(k,4)*hulp3
dyyzz = cdyz(2,j,3)*hulp4
if ( i .eq. 2 ) then
yy = -yy
yy1 = -yy1
zz = -zz
zz1 = -zz1
endif
*
* ieps = 3 means: dear ffcrr, do not use eta terms,
* they are calculated here. The sign gives the sign
* of the imag. part of the argument of the dilog, not
* y-z.
*
if ( i.eq.1 .eqv. j.eq.1 .eqv. DBLE(cy(2*i,3)).gt.0
+ ) then
ieps = -3
else
ieps = +3
endif
call ffcrr(cs3(10*l-9),ipi12(l),yy,yy1,zz,zz1,dyyzz,
+ .FALSE.,czero,czero,czero,isoort(j),ieps,ier)
*
* eta terms of the R's (eta(.)*log(c1)-eta(.)*log(c2))
*
do 170 m=3,4
* no eta terms in the real case
if ( DIMAG(cz(k,m)) .eq. 0 .and.
+ DIMAG(cdyz(2,j,m)) .eq. 0 ) then
ni(k,m) = 0
elseif ( i .eq. 1 ) then
ni(k,m) = nffeta(-cz(k,m),1/cdyz(2,j,m),ier)
else
ni(k,m) = nffeta(cz(k,m),1/cdyz(2,j,m),ier)
endif
170 continue
if ( ni(k,3) .ne. 0 .or. ni(k,4) .ne. 0 ) then
if ( ni(k,3) .ne. ni(k,4) ) then
do 175 m=3,4
c = cy(2*i,m)/cdyz(2,j,m)
if ( i .eq. 2 ) c = -c
cc = c-1
if ( absc(cc) .lt. xloss ) then
c = cz(k,m)/cdyz(2,j,m)
clogy = zfflo1(c,ier)
else
clogy = zfflog(c,0,czero,ier)
endif
n = 10*l + (m-3) - 2
if ( m .eq. 3 ) then
cs3(n) = + ni(k,m)*c2ipi*clogy
else
cs3(n) = - ni(k,m)*c2ipi*clogy
endif
175 continue
else
if ( i .eq. 1 ) then
n1a = nffeta(cy(k,3)/cdyz(2,j,3),
+ cdyz(2,j,4)/cy(k,4),ier)
else
n1a = nffeta(-cy(k,3)/cdyz(2,j,3),
+ -cdyz(2,j,4)/cy(k,4),ier)
endif
if ( n1a .ne. 0 ) then
call fferr(80,ier)
endif
c =cy(k,3)*cdyz(2,j,4)/(cdyz(2,j,3)*cy(k,4))
cc = c-1
if ( absc(cc) .lt. xloss ) then
c = -cdyzzy(k)/(cdyz(2,j,3)*cy(k,4))
clogy = zfflo1(c,ier)
else
clogy = zfflog(c,0,czero,ier)
endif
n = 10*l - 2
if ( i .eq. 1 ) then
cs3(n) = +ni(k,3)*c2ipi*clogy
else
cs3(n) = -ni(k,3)*c2ipi*clogy
endif
endif
endif
endif
180 continue
190 continue
goto 700
endif
* #] rotate R's:
* #[ other cases (not ready):
call ffcs3(cs3( 1),ipi12(1),cy(1,3),cz(1,3),cdyz(1,1,3),
+ cd2yzz(3),cpi(1,3),cpiDpj(1,1,3),ii,ns,isoort(1),ier)
call ffcs3(cs3(81),ipi12(9),cy(1,4),cz(1,4),cdyz(1,1,4),
+ cd2yzz(4),cpi(1,4),cpiDpj(1,1,4),ii,ns,isoort(9),ier)
return
* #] other cases (not ready):
* #[ get eta's:
700 continue
ip = ii+3
do 740 k=3,4
l = 8*(k-3) + 1
if ( DIMAG(cpi(ip,k)) .eq. 0 ) then
*
* complex because of a complex root in y or z
*
if ( (mod(isoort(l),10).eq.-1 .or. mod(isoort(l),10).eq.-3)
+ .and. isoort(l+1) .ne. 0 ) then
*
* isoort = -1: y is complex, possibly z as well
* isoort = -3: y,z complex, but (y-z-)(y-z+) real
* isoort = 0: y is complex, one z root only
* isoort = -10: y is real, z is complex
* isoort = -5,-6: y,z both real
*
cmip = DCMPLX(0D0,-DBLE(cpi(ip,k)))
if ( DIMAG(cz(1,k)) .eq. 0 ) then
ni(1,k) = 0
else
ni(1,k) = nffet1(-cz(1,k),-cz(2,k),cmip,ier)
i = nffet1(cz(3,k),cz(4,k),cmip,ier)
if ( i .ne. ni(1,k) ) call fferr(53,ier)
endif
ni(2,k) = 0
if ( DBLE(cd2yzz(k)).eq.0 .and. ( DIMAG(cz(1,k)).eq.0 .and.
+ DIMAG(cz(2,k)).eq.0 .or. DBLE(cdyz(2,1,k)).eq.0 .and.
+ DBLE(cdyz(2,2,k)) .eq. 0 ) ) then
* follow the i*epsilon prescription as (y-z-)(y-z+) real
if ( DBLE(cpi(ip,k)) .lt. 0 ) then
ni(3,k) = -1
else
ni(3,k) = 0
endif
ni(4,k) = -nffet1(cdyz(2,1,k),cdyz(2,2,k),cmip,ier)
else
if ( DBLE(cpi(ip,k)) .lt. 0 .and. DIMAG(cdyz(2,1,k)*
+ cdyz(2,2,k)) .lt. 0 ) then
ni(3,k) = -1
else
ni(3,k) = 0
endif
ni(4,k) = -nffeta(cdyz(2,1,k),cdyz(2,2,k),ier)
endif
elseif ( (mod(isoort(l),10).eq.-1 .or. mod(isoort(l),10).eq.-3)
+ .and. isoort(l+1).eq.0 ) then
ni(1,k) = 0
if ( DIMAG(cz(1,k)) .ne. 0 ) then
ni(2,k) = nffet1(-cpiDpj(ii,ip,k),-cz(1,k),DCMPLX(DBLE(0
+ ),DBLE(-1)),ier)
else
ni(2,k) = nffet1(-cpiDpj(ii,ip,k),DCMPLX(DBLE(0),
+ DBLE(1)),DCMPLX(DBLE(0),DBLE(-1)),ier)
endif
ni(3,k) = 0
ni(4,k) = -nffeta(-cpiDpj(ii,ip,k),cdyz(2,1,k),ier)
else
if ( mod(isoort(l),5).ne.0 .and. mod(isoort(l),5).ne.-1
+ .and. mod(isoort(l),5).ne.-3 ) then
call fferr(81,ier)
print *,'isoort(',l,') = ',isoort(l)
endif
ni(1,k) = 0
ni(2,k) = 0
ni(3,k) = 0
ni(4,k) = 0
endif
else
print *,'ffdcs: error: cpi complex should not occur'
stop
endif
740 continue
* #] get eta's:
* #[ add eta's:
do 750 k=3,4
ntot(k) = ni(1,k)+ni(2,k)+ni(3,k)+ni(4,k)
750 continue
do 760 k=3,4
if ( ntot(k) .ne. 0 ) call ffclgy(cs3(20+80*(k-3)),
+ ipi12(2+8*(k-3)),ni(1,k),cy(1,k),cz(1,k),cd2yzz(k),ier)
760 continue
* #] add eta's:
*###] ffdcs:
end
*###[ ffclg2:
subroutine ffclg2(cs3,cdyz3,cdyz4,cdyyzz,ieps,ier)
***#[*comment:***********************************************************
* *
* Calculate the finite part of the divergent dilogs in case *
* del2s=0. These are given by *
* *
* log^2(-cdyz3)/2 - log^2(-cdyz4)/2 *
* *
* Note that often we only need the imaginary part, which may be *
* very unstable even if the total is not. *
* *
* *
* Input: cy3,cz3,cdyz3 (complex) y,z,diff in C with s3 *
* cy4,cz4,cdyz4 (complex) y,z,diff in C with s4 *
* cdyyzz (complex) y4 - z4 - y3 + z3 *
* isort3,4 (integer) *
* *
* Output cs3(4) (complex) output *
* ipi12 (integer) terms pi^2/12 *
* ier (integer) error flag *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
DOUBLE COMPLEX cs3(3),cdyz3,cdyz4,cdyyzz
integer ieps,ier
*
* local variables
*
integer n1,nffeta,nffet1,ipi3,ipi4
DOUBLE COMPLEX c,cc,clog3,clog4,clog1,zfflo1,cipi
DOUBLE PRECISION absc
external nffeta,nffet1,zfflo1
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ calculations:
cipi = DCMPLX(0D0,pi)
if ( DBLE(cdyz3) .lt. 0 ) then
clog3 = log(-cdyz3)
ipi3 = 0
else
clog3 = log(cdyz3)
if ( DIMAG(cdyz3) .gt. 0 ) then
ipi3 = -1
elseif ( DIMAG(cdyz3) .lt. 0 ) then
ipi3 = +1
else
ipi3 = sign(1,-ieps)
endif
endif
if ( DBLE(cdyz4) .lt. 0 ) then
clog4 = log(-cdyz4)
ipi4 = 0
else
clog4 = log(cdyz4)
if ( DIMAG(cdyz4) .gt. 0 ) then
ipi4 = -1
elseif ( DIMAG(cdyz4) .lt. 0 ) then
ipi4 = +1
else
ipi4 = sign(1,-ieps)
endif
endif
cc = clog3-clog4
if ( absc(cc) .ge. xloss*absc(clog3) ) then
cs3(1) = -(clog3+ipi3*cipi)**2/2
cs3(2) = +(clog4+ipi4*cipi)**2/2
else
c = cdyyzz/cdyz4
clog1 = zfflo1(c,ier)
*
* notice that zfflog return log(a-ieps) (for compatibility
* with the dilog) ^
*
if ( DIMAG(cdyz3) .eq. 0 ) then
n1 = nffet1(DCMPLX(DBLE(0),DBLE(-ieps)),-1/cdyz4,-c,
+ ier)
elseif ( DIMAG(cdyz3) .eq. 0 ) then
n1 = nffet1(-cdyz3,DCMPLX(DBLE(0),DBLE(ieps)),-c,ier)
else
n1 = nffeta(-cdyz3,-1/cdyz4,ier)
endif
if ( n1 .ne. 0 ) then
clog1 = clog1 - n1*c2ipi
endif
cs3(1) = -clog3*clog1/2
cs3(2) = -clog4*clog1/2
cs3(3) = -(ipi3+ipi4)*cipi*clog1/2
* we could split off a factor 2*pi^2 if needed
endif
* ATTENTION: now (23-jul-1989) ffdcs assumes that only *3* cs are
* set. Change ffdcs as well if this is no longer true!
* #] calculations:
*###] ffclg2:
end
diff --git a/Looptools/util/ffinit.F b/Looptools/util/ffinit.F
--- a/Looptools/util/ffinit.F
+++ b/Looptools/util/ffinit.F
@@ -1,1097 +1,1134 @@
#include "defs.h"
* $Id: ffinit.f,v 1.9 1996/04/26 10:39:03 gj Exp $
*###[ ffini:
- subroutine ffini
+ subroutine ltini
***#[*comment:***********************************************************
* calculate a lot of commonly-used constants in the common block *
* /ffcnst/. also set the precision, maximum loss of digits and *
* the minimum value the logarithm accepts in /prec/. *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer i,j,init,ioldp(13,12),isgrop(10,12),ji
save init
DOUBLE PRECISION s,sold
DOUBLE COMPLEX cs
#include "lt.h"
character*32 env
data init /0/
data ioldp/1,2,3,4, 5,6,7,8,9,10, 11,12,13,
+ 4,1,2,3, 8,5,6,7,10,9, 11,13,12,
+ 3,4,1,2, 7,8,5,6,9,10, 11,12,13,
+ 2,3,4,1, 6,7,8,5,10,9, 11,13,12,
+ 4,2,3,1, 10,6,9,8,7,5, 12,11,13,
+ 1,3,2,4, 9,6,10,8,5,7, 12,11,13,
+ 1,2,4,3, 5,10,7,9,8,6, 13,12,11,
+ 1,4,3,2, 8,7,6,5,9,10, 11,13,12,
+ 3,4,2,1, 7,10,5,9,6,8, 13,12,11,
+ 2,3,1,4, 6,9,8,10,5,7, 12,13,11,
+ 4,2,1,3, 10,5,9,7,8,6, 13,11,12,
+ 1,3,4,2, 9,7,10,5,8,6, 13,11,12/
data isgrop/
+ +1,+1,+1,+1, +1,+1,+1,+1, +1,+1,
+ +1,+1,+1,+1, +1,+1,+1,+1, -1,+1,
+ +1,+1,+1,+1, +1,+1,+1,+1, -1,-1,
+ +1,+1,+1,+1, +1,+1,+1,+1, +1,-1,
+ +1,+1,+1,+1, -1,+1,+1,-1, +1,-1,
+ +1,+1,+1,+1, -1,-1,+1,+1, -1,+1,
+ +1,+1,+1,+1, +1,+1,-1,+1, +1,+1,
+ +1,+1,+1,+1, -1,-1,-1,-1, +1,-1,
+ +1,+1,+1,+1, -1,+1,+1,+1, -1,-1,
+ +1,+1,+1,+1, +1,+1,+1,-1, +1,-1,
+ +1,+1,+1,+1, -1,+1,+1,-1, -1,-1,
+ +1,+1,+1,+1, -1,-1,+1,+1, -1,-1/
* #] declarations:
* #[ check:
* check whether there is anything to do
if ( init .ne. 0 ) return
init = 1
print *,'===================================================='
print *,' FF 2.0, a package to evaluate one-loop integrals'
print *,'written by G. J. van Oldenborgh, NIKHEF-H, Amsterdam'
print *,'===================================================='
print *,'for the algorithms used see preprint NIKHEF-H 89/17,'
print *,'''New Algorithms for One-loop Integrals'', by G.J. van'
print *,'Oldenborgh and J.A.M. Vermaseren, published in '
print *,'Zeitschrift fuer Physik C46(1990)425.'
print *,'===================================================='
* #] check:
* #[ LoopTools stuff
*
* we do this here because loading block data is unreliable
*
call clearcache
- errdigits = 100
- warndigits = 9
serial = 0
+ call getenv("LTMINMASS", env)
+ minmass = 0
+ read(env, *, end=90, err=90) minmass
+ print *, "using minmass =", minmass
+90 continue
+
call getenv("LTMAXDEV", env)
maxdev = 1D-10
read(env, *, end=91, err=91) maxdev
print *, "using maxdev =", maxdev
91 continue
+ call getenv("LTCMPBITS", env)
+ cmpbits = 62 + (KIND-1)*4
+ read(env, *, end=92, err=92) cmpbits
+ print *, "using cmpbits =", cmpbits
+92 continue
+
call getenv("LTVERSION", env)
versionkey = 0
- read(env, *, end=92, err=92) versionkey
+ read(env, *, end=93, err=93) versionkey
print *, "using versionkey =", versionkey
-92 continue
+93 continue
call getenv("LTDEBUG", env)
debugkey = 0
- read(env, *, end=93, err=93) debugkey
+ read(env, *, end=94, err=94) debugkey
print *, "using debugkey =", debugkey
-93 continue
+94 continue
call getenv("LTRANGE", env)
debugfrom = 0
debugto = 2**30
i = index(env, '-')
if( i .eq. 0 ) then
- read(env, *, end=96, err=96) debugfrom
+ read(env, *, end=95, err=95) debugfrom
debugto = debugfrom
else
- read(env(1:i-1), *, end=94, err=94) debugfrom
-94 read(env(i+1:), *, end=95, err=95) debugto
-95 continue
+ read(env(1:i-1), *, end=951, err=951) debugfrom
+951 read(env(i+1:), *, end=952, err=952) debugto
+952 continue
endif
print *, "using debugrange =", debugfrom, debugto
+95 continue
+
+ call getenv("LTWARN", env)
+ warndigits = 9
+ read(env, *, end=96, err=96) warndigits
+ print *, "using warndigits =", warndigits
96 continue
+
+ call getenv("LTERR", env)
+ errdigits = 100
+ read(env, *, end=97, err=97) errdigits
+ print *, "using errdigits =", errdigits
+97 continue
+
+*
+* regularization parameters
+*
+ call getenv("LTDELTA", env)
+ delta = 0
+ read(env, *, end=100, err=100) delta
+ print *, "using delta =", delta
+100 continue
+
+ call getenv("LTMUDIM", env)
+ mudim = 1
+ read(env, *, end=101, err=101) mudim
+ print *, "using mudim =", mudim
+101 continue
+
+ call getenv("LTLAMBDA", env)
+ lambda = 1
+ read(env, *, end=102, err=102) lambda
+ print *, "using lambda =", lambda
+102 continue
*
* #] LoopTools stuff
* #[ precision etc:
nevent = -1
*
* the loss of accuracy in any single subtraction at which
* (timeconsuming) corrective action is to be taken is
*
xloss = 0.125D0
*
* the precision to which real calculations are done is
*
precx = 1
sold = 0
do 1 i=1,1000
precx = precx/2
call ffset(s, 1 + precx)
s = exp(log(s))
if ( s .eq. sold ) goto 2
sold = s
1 continue
2 continue
precx = precx*8
* (take three bits for safety)
*
* the precision to which complex calculations are done is
*
precc = 1
sold = 0
do 3 i=1,1000
precc = precc/2
call ffset(s, 1 + precc)
cs = exp(log(DCMPLX(s)))
if ( DBLE(cs) .eq. sold ) goto 4
sold = DBLE(cs)
3 continue
4 continue
precc = precc*8
* (take three bits for safety)
*
* for efficiency take them equal if they are not too different
*
if ( precx/precc .lt. 4 .and. precx/precc .gt. .25 ) then
precx = max(precc,precx)
precc = max(precc,precx)
endif
*
* and the minimum value the logarithm accepts without complaining
* about arguments zero is (DOUBLE PRECISION cq DOUBLE COMPLEX)
*
s = 1
xalogm = 1
do 5 i=1,10000
call ffset(s, s/2)
if ( 2*s .ne. xalogm ) goto 6
xalogm = s
5 continue
6 continue
if ( xalogm.eq.0 ) xalogm = 1d-307
s = 1
xclogm = abs(DCMPLX(s))
do 7 i=1,10000
call ffset(s, s/2)
if ( 2*abs(DCMPLX(s)) .ne. xclogm ) goto 8
xclogm = abs(DCMPLX(s))
7 continue
8 continue
if ( xclogm.eq.0 ) xclogm = 1d-307
*
* These values are for Absoft, Apollo fortran (68000):
* xalogm = 1.D-308
* xclogm = 1.D-18
* These values are for VAX g_float
* xalogm = 1.D-308
* xclogm = 1.D-308
* These values are for Gould fort (because of div_zz)
* xalogm = 1.D-75
* xclogm = 1.D-36
xalog2 = sqrt(xalogm)
xclog2 = sqrt(xclogm)
* #] precision etc:
* #[ constants:
*
* calculate the coefficients of the series expansion
* li2(x) = sum bn*z^n/(n+1)!, z = -log(1-x), bn are the
* bernouilli numbers (zero for odd n>1).
*
bf(1) = - 1.D+0/4.D+0
bf(2) = + 1.D+0/36.D+0
bf(3) = - 1.D+0/36.D+2
bf(4) = + 1.D+0/21168.D+1
bf(5) = - 1.D+0/108864.D+2
bf(6) = + 1.D+0/52690176.D+1
bf(7) = - 691.D+0/16999766784.D+3
bf(8) = + 1.D+0/1120863744.D+3
bf(9) = - 3617.D+0/18140058832896.D+4
bf(10) = + 43867.D+0/97072790126247936.D+3
bf(11) = - 174611.D+0/168600109166641152.D+5
bf(12) = + 77683.D+0/32432530090601152512.D+4
bf(13) = - 236364091.D+0/4234560341829359173632.D+7
bf(14) = + 657931.D+0/5025632054039239458816.D+6
bf(15) = - 3392780147.D+0/109890470493622010006470656.D+7
bf(16)=+172.3168255201D+0/2355349904102724211909.3102313472D+6
bf(17)=-770.9321041217D+0/4428491985594062112714.2791446528D+8
bf(18)=( 0.4157635644614046176D-28)
bf(19)=(-0.9962148488284986022D-30)
bf(20)=( 0.2394034424896265390D-31)
*
* inverses of integers:
*
do 10 i=1,30
xninv(i) = 1D0/i
xn2inv(i) = 1D0/(i*i)
10 continue
*
* inverses of faculties of integers:
*
xinfac(1) = 1D0
do 20 i=2,30
xinfac(i) = xinfac(i-1)/i
20 continue
*
* inx: p(inx(i,j)) = isgn(i,j)*(s(i)-s(j))
*
inx(1,1) = -9999
inx(2,1) = 5
inx(3,1) = 9
inx(4,1) = 8
inx(1,2) = 5
inx(2,2) = -9999
inx(3,2) = 6
inx(4,2) = 10
inx(1,3) = 9
inx(2,3) = 6
inx(3,3) = -9999
inx(4,3) = 7
inx(1,4) = 8
inx(2,4) = 10
inx(3,4) = 7
inx(4,4) = -9999
isgn(1,1) = -9999
isgn(2,1) = +1
isgn(3,1) = -1
isgn(4,1) = -1
isgn(1,2) = -1
isgn(2,2) = -9999
isgn(3,2) = +1
isgn(4,2) = +1
isgn(1,3) = +1
isgn(2,3) = -1
isgn(3,3) = -9999
isgn(4,3) = +1
isgn(1,4) = +1
isgn(2,4) = -1
isgn(3,4) = -1
isgn(4,4) = -9999
do 40 i=1,12
do 30 j=1,13
iold(j,i) = ioldp(j,i)
30 continue
do 35 j=1,10
isgrot(j,i) = isgrop(j,i)
35 continue
40 continue
inx5(1,1) = -9999
inx5(1,2) = 6
inx5(1,3) = 11
inx5(1,4) = 14
inx5(1,5) = 10
inx5(2,1) = 6
inx5(2,2) = -9999
inx5(2,3) = 7
inx5(2,4) = 12
inx5(2,5) = 15
inx5(3,1) = 11
inx5(3,2) = 7
inx5(3,3) = -9999
inx5(3,4) = 8
inx5(3,5) = 13
inx5(4,1) = 14
inx5(4,2) = 12
inx5(4,3) = 8
inx5(4,4) = -9999
inx5(4,5) = 9
inx5(5,1) = 10
inx5(5,2) = 15
inx5(5,3) = 13
inx5(5,4) = 9
inx5(5,5) = -9999
* isgn5 is not yet used.
do i=1,5
do j=1,5
isgn5(i,j) = -9999
enddo
enddo
*
inx6(1,1) = -9999
inx6(1,2) = 7
inx6(1,3) = 13
inx6(1,4) = 19
inx6(1,5) = 17
inx6(1,6) = 12
inx6(2,1) = 7
inx6(2,2) = -9999
inx6(2,3) = 8
inx6(2,4) = 14
inx6(2,5) = 20
inx6(2,6) = 18
inx6(3,1) = 13
inx6(3,2) = 8
inx6(3,3) = -9999
inx6(3,4) = 9
inx6(3,5) = 15
inx6(3,6) = 21
inx6(4,1) = 19
inx6(4,2) = 14
inx6(4,3) = 9
inx6(4,4) = -9999
inx6(4,5) = 10
inx6(4,6) = 16
inx6(5,1) = 17
inx6(5,2) = 20
inx6(5,3) = 15
inx6(5,4) = 10
inx6(5,5) = -9999
inx6(5,6) = 11
inx6(6,1) = 12
inx6(6,2) = 18
inx6(6,3) = 21
inx6(6,4) = 16
inx6(6,5) = 11
inx6(6,6) = -9999
* isgn6 is used.
do i=1,6
do j=1,6
ji = j-i
if ( ji.gt.+3 ) ji = ji - 6
if ( ji.lt.-3 ) ji = ji + 6
if ( ji.eq.0 ) then
isgn6(j,i) = -9999
elseif ( abs(ji).eq.3 ) then
if ( i.lt.0 ) then
isgn6(j,i) = -1
else
isgn6(j,i) = +1
endif
elseif ( ji.gt.0 ) then
isgn6(j,i) = +1
elseif ( ji.lt.0 ) then
isgn6(j,i) = -1
else
print *,'ffini: internal error in isgn6'
stop
endif
enddo
enddo
*
* #] constants:
* #[ defaults for flags:
nevent = 0
*
* the debugging flags.
*
ldc3c4 = .FALSE.
l4also = .FALSE.
lmem = .FALSE.
ldot = .FALSE.
idot = 0
*
* Specify which root to take in cases were two are possible
* it may be advantageous to change this to -1 (debugging hook)
*
isgn34 = 1
isgnal = 1
*
-* regularization parameters
-*
- mudim = 1
- delta = 0
- lambda = 1
-*
* the scheme used for the complex scalar functions:
*
* nschem = 1: do not use the complex mass at all
* 2: only use the complex mass in linearly divergent terms
* 3: also use the complex mass in divergent logs UNDEFINED
* 4: use the complex mass in the C0 if there are
* divergent logs
* 5: include the almost-divergent threshold terms from
* (m,m,0) vertices
* 6: include the (s-m^2)*log(s-m^2) threshold terms from
* (m1+m2),m1,m2) vertices
* 7: full complex computation
* (only in the ffz... functions):
* onshel = .FALSE.: use the offshell p^2 everywhere
* .TRUE.: use the onshell p^2 except in complex parts
*
nschem = 7
onshel = .TRUE.
*
* the precision wanted in the complex D0 (and hence E0) when
* nschem=7, these are calculated via Taylor expansion in the real
* one and hence expensive.
*
reqprc = 1.D-8
*
* in some schemes, for onshel=.FALSE.,
* when |p^2-Re(m^2)| < nwidth*|Im(m^2)| special action is taken
*
nwidth = 5
*
* a flag to indicate the validity of differences smuggled to the
* IR routines in the C0 (ff internal only)
*
lsmug = .FALSE.
*
* #] defaults for flags:
*###] ffini:
end
*###[ ffexi:
- subroutine ffexi
+ subroutine ltexi
***#[*comment:***********************************************************
* check a lot of commonly-used constants in the common block *
* /ffcnst/. *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer i,ier
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ checks:
*
* calculate the coefficients of the series expansion
* li2(x) = sum bn*z^n/(n+1)!, z = -log(1-x), bn are the
* bernouilli numbers (zero for odd n>1).
*
if ( bf(1) .ne. - 1.D+0/4.D+0 )
+ print *,'ffexi: error: bf(1) is corrupted'
if ( bf(2) .ne. + 1.D+0/36.D+0 )
+ print *,'ffexi: error: bf(2) is corrupted'
if ( bf(3) .ne. - 1.D+0/36.D+2 )
+ print *,'ffexi: error: bf(3) is corrupted'
if ( bf(4) .ne. + 1.D+0/21168.D+1 )
+ print *,'ffexi: error: bf(4) is corrupted'
if ( bf(5) .ne. - 1.D+0/108864.D+2 )
+ print *,'ffexi: error: bf(5) is corrupted'
if ( bf(6) .ne. + 1.D+0/52690176.D+1 )
+ print *,'ffexi: error: bf(6) is corrupted'
if ( bf(7) .ne. - 691.D+0/16999766784.D+3 )
+ print *,'ffexi: error: bf(7) is corrupted'
if ( bf(8) .ne. + 1.D+0/1120863744.D+3 )
+ print *,'ffexi: error: bf(8) is corrupted'
if ( bf(9) .ne. - 3617.D+0/18140058832896.D+4 )
+ print *,'ffexi: error: bf(9) is corrupted'
if ( bf(10) .ne. + 43867.D+0/97072790126247936.D+3 )
+ print *,'ffexi: error: bf(10) is corrupted'
if ( bf(11) .ne. - 174611.D+0/168600109166641152.D+5 )
+ print *,'ffexi: error: bf(11) is corrupted'
if ( bf(12) .ne. + 77683.D+0/32432530090601152512.D+4 )
+ print *,'ffexi: error: bf(12) is corrupted'
if ( bf(13) .ne. - 236364091.D+0/4234560341829359173632.D+7 )
+ print *,'ffexi: error: bf(13) is corrupted'
if ( bf(14) .ne. + 657931.D+0/5025632054039239458816.D+6 )
+ print *,'ffexi: error: bf(14) is corrupted'
if ( bf(15) .ne. -3392780147.D+0/109890470493622010006470656.D+7
+ ) print *,'ffexi: error: bf(15) is corrupted'
if ( bf(16).ne.+172.3168255201D+0/2355349904102724211909.3102313
+ 472D+6 )
+ print *,'ffexi: error: bf(16) is corrupted'
if ( bf(17).ne.-770.9321041217D+0/4428491985594062112714.2791446
+ 528D+8 )
+ print *,'ffexi: error: bf(17) is corrupted'
if ( bf(18).ne.( 0.4157635644614046176D-28) )
+ print *,'ffexi: error: bf(18) is corrupted'
if ( bf(19).ne.(-0.9962148488284986022D-30) )
+ print *,'ffexi: error: bf(19) is corrupted'
if ( bf(20).ne.( 0.2394034424896265390D-31) )
+ print *,'ffexi: error: bf(20) is corrupted'
*
* inverses of integers:
*
do 10 i=1,20
if ( abs(xninv(i)-1D0/i) .gt. precx*xninv(i) ) print *,
+ 'ffexi: error: xninv(',i,') is not 1/',i,': ',
+ xninv(i),xninv(i)-1D0/i
10 continue
*
* #] checks:
* #[ print summary of errors and warning:
ier = 0
call fferr(999,ier)
* #] print summary of errors and warning:
*###] ffexi:
end
*###[ fferr:
subroutine fferr(nerr,ierr)
***#[*comment:***********************************************************
* *
* generates an error message #nerr with severity 2 *
* nerr=999 gives a frequency listing of all errors *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer nmax
parameter (nmax=105)
integer nerr,ierr
integer noccur(nmax),i,inone,nnerr
save error,noccur
- include 'ff.h'
- include 'fferr.h'
+#include "ff.h"
+#include "fferr.h"
* #] declarations:
* #[ data:
data noccur /nmax*0/
* #] data:
* #[ nerr=999:
if ( nerr .eq. 999 ) then
* print out total numbers...
print '(a)',' '
print '(a)','total number of errors and warnings'
print '(a)','==================================='
inone = 1
do 10 i = 1, nmax
if ( noccur(i) .gt. 0 ) then
print '(a,i5,a,a)','fferr: ',noccur(i),
+ ' times ',error(i)
noccur(i) = 0
inone = 0
endif
10 continue
if ( inone.eq.1 ) print '(a)','fferr: no errors'
print '(a)',' '
return
endif
* #] nerr=999:
* #[ print error:
if ( nerr .lt. 1 .or. nerr .gt. nmax ) then
nnerr = nmax
else
nnerr = nerr
endif
noccur(nnerr) = noccur(nnerr) + 1
ierr = ierr + 100
print '(a,a)', 'error in ', error(nnerr)
* #] print error:
*###] fferr:
end
*###[ ffwarn:
subroutine ffwarn(nerr,ierr,som,xmax)
***#[*comment:***********************************************************
* *
* The warning routine. A warning is aloss of precision greater *
* than xloss (which is default set in ffini), whenever in a *
* subtraction the result is smaller than xloss*max(operands) this *
* routine is called. Now the strategy is to remember these *
* warnings until a 998 message is obtained; then all warnings of *
* the previous event are printed. The rationale is that one *
* makes this call if too much preciasion is lost only. *
* nerr=999 gives a frequency listing of all warnings *
* *
* Input: nerr integer the id of the warning message, see the *
* file ffwarn.h or 998 or 999 *
* ierr integer the usual error flag: number of digits *
* lost so far *
* som real the result of the addition *
* xmax real the largest operand *
* *
* Output: ierr integer is raised by the number of digits lost *
* the tolerated loss of xloss *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer nmax
parameter (nmax=300)
*
* arguments
*
integer nerr,ierr
DOUBLE PRECISION som,xmax
*
* local variables
*
integer memmax
parameter (memmax = 1000)
integer noccur(nmax),i,inone,nnerr,ilost,
+ nermem(memmax),losmem(memmax),idmem(memmax),
+ idsmem(memmax),laseve,imem
DOUBLE PRECISION xlosti(nmax),xlost
save warn,noccur,xlosti,nermem,losmem,idmem,idsmem,
+ laseve,imem
*
* common blocks
*
- include 'ff.h'
- include 'ffwarn.h'
+#include "ff.h"
+#include "ffwarn.h"
* #] declarations:
* #[ data:
data noccur /nmax*0/
* #] data:
* #[ nerr=999:
if ( nerr.eq.999 ) then
* print out total numbers...
inone = 1
do 10 i=1,nmax
if ( noccur(i) .gt. 0 ) then
print '(a,i8,a,i3,a,a)','ffwarn: ',noccur(i),
+ ' times ',i,': ',warn(i)
print '(a,g12.3,a)',
+ ' (lost at most a factor ',xlosti(i),')'
noccur(i) = 0
xlosti(i) = 0
inone = 0
endif
10 continue
if ( inone.eq.1 ) print '(a)','ffwarn: no warnings'
return
endif
* #] nerr=999:
* #[ print warning:
if ( nerr .eq. 998 ) then
if ( nevent .ne. laseve ) return
do 20 i=1,imem-1
if ( nermem(i).ne.0 ) then
print '(a,a)','warning in ',warn(nermem(i))
print '(a,i3,a)',' (lost ',losmem(i),' digits)'
endif
20 continue
imem = 1
return
endif
* #] print warning:
* #[ collect warnings:
*
* bring in range
*
if ( nerr .lt. 1 .or. nerr .gt. nmax ) then
nnerr = nmax
else
nnerr = nerr
endif
*
* bookkeeping
*
noccur(nnerr) = noccur(nnerr) + 1
if ( som .ne. 0 ) then
xlost = abs(xmax/som)
elseif ( xmax .ne. 0 ) then
xlost = 1/precx
else
xlost = 1
endif
xlosti(nnerr) = max(xlosti(nnerr),xlost)
if ( xlost*xloss .gt. xalogm ) then
ilost = 1 + int(abs(log10(xlost*xloss)))
else
ilost = 0
endif
ierr = ierr + ilost
*
* nice place to stop when debugging
*
if ( ilost.ge.10 ) then
ilost = ilost + 1
endif
*
* add to memory
*
if ( laseve .ne. nevent ) then
imem = 1
laseve = nevent
endif
if ( imem .le. memmax ) then
idmem(imem) = id
idsmem(imem) = idsub
nermem(imem) = nerr
losmem(imem) = ilost
imem = imem + 1
endif
* #] collect warnings:
*###] ffwarn:
end
*###[ ffbnd:
DOUBLE PRECISION function ffbnd(n1,n2,array)
*************************************************************************
* *
* calculate bound = (precx*|a(n1)/a(n1+n2)|^(1/n2) which is the *
* maximum value of x in a series expansion sum_(i=n1)^(n1+n2) *
* a(i)*x(i) to give a result of accuracy precx (actually of |next *
* term| < prec *
* *
*************************************************************************
implicit none
integer n1,n2
DOUBLE PRECISION array(n1+n2)
- include 'ff.h'
+#include "ff.h"
if ( array(n1+n2) .eq. 0 ) then
print *,'ffbnd: fatal: array not initialized; did you call ',
+ 'ffini?'
stop
endif
ffbnd = (precx*abs(array(n1)/array(n1+n2)))**(1/DBLE(n2))
*###] ffbnd:
end
*###[ ffroot:
subroutine ffroot(xm,xp,a,b,c,d,ier)
***#[*comment:***********************************************************
* *
* Calculate the roots of the equation *
* a*x^2 - 2*b*x + c = 0 *
* given by *
* x = (b +/- d )/a xp*xm = c/a *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ier
DOUBLE PRECISION xm,xp,a,b,c,d
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ check input:
if ( a .eq. 0 ) then
call fferr(39,ier)
if ( b.gt.0 .eqv. d.gt.0 ) then
xp = 1/xalogm
xm = c/(b+d)
else
xp = c/(b-d)
xm = 1/xalogm
endif
return
endif
* #] check input:
* #[ calculations:
if ( d .eq. 0 ) then
xm = b / a
xp = xm
elseif ( b .gt. 0 .eqv. d .gt. 0 ) then
xp = ( b + d ) / a
xm = c / (a*xp)
else
xm = ( b - d ) / a
xp = c / (a*xm)
endif
* #] calculations:
*###] ffroot:
end
*###[ ffcoot:
subroutine ffcoot(xm,xp,a,b,c,d,ier)
***#[*comment:***********************************************************
* *
* Calculate the roots of the equation *
* a*x^2 - 2*b*x + c = 0 *
* given by *
* x = (b +/- d )/a xp*xm = c/a *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ier
DOUBLE COMPLEX xm,xp,a,b,c,d
*
* local variables:
*
DOUBLE COMPLEX cc
DOUBLE PRECISION absc
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
* #] declarations:
* #[ check input:
if ( a .eq. 0 ) then
call fferr(38,ier)
if ( DBLE(b).gt.0 .eqv. DBLE(d).gt.0 ) then
xp = 1/xclogm
xm = c/(b+d)
else
xp = c/(b-d)
xm = 1/xclogm
endif
return
endif
* #] check input:
* #[ calculations:
cc = b+d
if ( d .eq. 0 ) then
xm = b / a
xp = xm
elseif ( absc(cc) .gt. xloss*absc(d) ) then
xp = ( b + d ) / a
xm = c / (a*xp)
else
xm = ( b - d ) / a
xp = c / (a*xm)
endif
* #] calculations:
*###] ffcoot:
end
*###[ ffxhck:
subroutine ffxhck(xpi,dpipj,ns,ier)
***#[*comment:***********************************************************
* *
* check whether the differences dpipj are compatible with xpi *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ns,ier
DOUBLE PRECISION xpi(ns),dpipj(ns,ns)
integer i,j
DOUBLE PRECISION xheck,rloss
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ calculations:
if ( ier.lt.0 ) then
print *,'ffxhck: error: ier < 0 ',ier
ier=0
endif
rloss = xloss**2*DBLE(10)**(-mod(ier,50))
do 20 i=1,ns
do 10 j=1,ns
xheck = dpipj(j,i) - xpi(j) + xpi(i)
if ( rloss*abs(xheck) .gt. precx*max(abs(dpipj(j,i)),
+ abs(xpi(j)),abs(xpi(i))) ) then
print *,'ffxhck: error: dpipj(',j,i,') <> xpi(',j,
+ ') - xpi(',i,'):',dpipj(j,i),xpi(j),xpi(i),
+ xheck,ier
endif
10 continue
20 continue
* #] calculations:
*###] ffxhck:
end
*###[ ffchck:
subroutine ffchck(cpi,cdpipj,ns,ier)
***#[*comment:***********************************************************
* *
* check whether the differences cdpipj are compatible with cpi *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ns,ier
DOUBLE COMPLEX cpi(ns),cdpipj(ns,ns),c
integer i,j
DOUBLE COMPLEX check
DOUBLE PRECISION absc,rloss
- include 'ff.h'
+#include "ff.h"
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
* #] declarations:
* #[ calculations:
if ( ier.lt.0 ) then
print *,'ffchck: error: ier < 0 ',ier
ier=0
endif
rloss = xloss**2*DBLE(10)**(-mod(ier,50))
do 20 i=1,ns
do 10 j=1,ns
check = cdpipj(j,i) - cpi(j) + cpi(i)
if ( rloss*absc(check) .gt. precc*max(absc(
+ cdpipj(j,i)),absc(cpi(j)),absc(cpi(i))) ) then
print *,'ffchck: error: cdpipj(',j,i,') <> cpi(',j,
+ ') - cpi(',i,'):',cdpipj(j,i),cpi(j),cpi(i),
+ check,ier
endif
10 continue
20 continue
* #] calculations:
*###] ffchck:
end
*###[ nffeta:
integer function nffeta(ca,cb,ier)
***#[*comment:***********************************************************
* calculates *
* *
* eta(a,b)/(2*i*pi) = ( thIm(-a)*thIm(-b)*thIm(a*b) *
* - thIm(a)*thIm(b)*thIm(-a*b) ) *
* *
* with thIm(a) = theta(Im(a)) *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE COMPLEX ca,cb
DOUBLE PRECISION a,b,ab,rab
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ calculations:
a = DIMAG(ca)
b = DIMAG(cb)
if ( a*b .lt. 0 ) then
nffeta = 0
return
endif
rab = DBLE(ca)*DBLE(cb) - a*b
ab = DBLE(ca)*b + a*DBLE(cb)
if ( abs(ab) .lt. precc*abs(DBLE(ca)*b) ) then
call fferr(32,ier)
endif
if ( a .lt. 0 .and. b .lt. 0 .and. ab .gt. 0 ) then
nffeta = 1
elseif ( a .gt. 0 .and. b .gt. 0 .and. ab .lt. 0 ) then
nffeta = -1
elseif ( a .eq. 0 .and. DBLE(ca) .le. 0 .or.
+ b .eq. 0 .and. DBLE(cb) .le. 0 .or.
+ ab .eq. 0 .and. rab .le. 0 ) then
call fferr(32,ier)
nffeta = 0
else
nffeta = 0
endif
* #] calculations:
*###] nffeta:
end
*###[ nffet1:
integer function nffet1(ca,cb,cc,ier)
***#[*comment:***********************************************************
* calculates the same eta with three input variables *
* *
* et1(a,b)/(2*i*pi) = ( thIm(-a)*thIm(-b)*thIm(c) *
* - thIm(a)*thIm(b)*thIm(-c) ) *
* *
* with thIm(a) = theta(Im(a)) *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE COMPLEX ca,cb,cc
DOUBLE PRECISION a,b,ab
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ calculations:
a = DIMAG(ca)
b = DIMAG(cb)
if ( a .gt. 0 .neqv. b .gt. 0 ) then
nffet1 = 0
return
endif
ab = DIMAG(cc)
if ( a .lt. 0 .and. b .lt. 0 .and. ab .gt. 0 ) then
nffet1 = 1
elseif ( a .gt. 0 .and. b .gt. 0 .and. ab .lt. 0 ) then
nffet1 = -1
elseif ( a .eq. 0 .and. DBLE(ca) .le. 0 .or.
+ b .eq. 0 .and. DBLE(cb) .le. 0 .or.
+ ab .eq. 0 .and. DBLE(cc) .le. 0 ) then
call fferr(33,ier)
nffet1 = 1
else
nffet1 = 0
endif
* #] calculations:
*###] nffet1:
end
*###[ ffcayl:
subroutine ffcayl(cs,z,coeff,n,ier)
***#[*comment:***********************************************************
* *
* Do a Taylor expansion in z with real coefficients coeff(i) *
* *
* Input: z complex *
* coeff(n) real *
* n integer *
* *
* Output cs complex \sum_{i=1} z^i coeff(i) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer n,ier
DOUBLE PRECISION coeff(n)
DOUBLE COMPLEX z,cs
*
* local variables
*
integer i
DOUBLE PRECISION absc
DOUBLE COMPLEX c,zi,csi
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* statement function
*
absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*
* #] declarations:
* #[ work:
cs = z*DBLE(coeff(1))
if ( absc(z) .lt. precc ) return
zi = z
do 10 i=2,n
zi = zi*z
csi = zi*DBLE(coeff(i))
cs = cs + csi
if ( absc(csi) .lt. precc*absc(cs) ) goto 20
10 continue
call ffwarn(9,ier,precc,absc(csi))
20 continue
* #] work:
*###] ffcayl:
end
*###[ fftayl:
subroutine fftayl(s,z,coeff,n,ier)
***#[*comment:***********************************************************
* *
* Do a Taylor expansion in z with real coefficients coeff(i) *
* *
* Input: z real *
* coeff(n) real *
* n integer *
* *
* Output cs real \sum_{i=1} z^i coeff(i) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer n,ier
DOUBLE PRECISION coeff(n),z,s
*
* local variables
*
integer i
DOUBLE PRECISION zi,si
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ work:
s = coeff(1)*z
if ( abs(z) .lt. precx ) return
zi = z
do 10 i=2,n
zi = zi*z
si = coeff(i)*zi
s = s + si
if ( abs(si) .lt. precx*abs(s) ) goto 20
10 continue
call ffwarn(9,ier,precx,si)
20 continue
* #] work:
*###] fftayl:
end
diff --git a/Looptools/util/fftran.F b/Looptools/util/fftran.F
--- a/Looptools/util/fftran.F
+++ b/Looptools/util/fftran.F
@@ -1,814 +1,817 @@
+#include "externals.h"
+
+
*###[ ffai:
subroutine ffai(ai,daiaj,aai,laai,del2s,sdel2s,xpi,dpipj,piDpj,
+ ier)
***#[*comment:***********************************************************
* *
* calculates the coefficients of the projective transformation *
* *
* xi = ai*ui / (som aj*uj ) *
* *
* such that the coefficients of z^2, z*x and z*y vanish: *
* *
* a2/a1 = ( lij +/- lam1/2(xp1,xm1,xm2) ) / (2*xm2) *
* a3 = ( xm2*a2 - xm1*a1 ) / ( xl23*a2 - xl13*a1 ) *
* a4 = ( xm2*a2 - xm1*a1 ) / ( xl24*a2 - xl14*a1 ) *
* *
* the differences ai-aj = daiaj(i,j) are also evaluated. *
* *
* Input: del2s real delta(s3,s4,s3,s4) *
* sdel2s real sqrt(-del2s) *
* xpi(10) real masses, momenta^2 *
* dpipj(10,10 real xpi(i) - xpi(j) *
* piDpj(10,10) real dotproducts *
* *
* Output: ai(4) real Ai of the transformation *
* daiaj(4,4) real Ai-Aj *
* aai(4) real the other roots *
* laai logical if .TRUE. aai are defined *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
logical laai
DOUBLE PRECISION ai(4),daiaj(4,4),aai(4),del2s,sdel2s,xpi(10),
+ dpipj(10,10),piDpj(10,10)
*
* local variables
*
integer i,j,ier0,ier1,ier2
DOUBLE PRECISION del2sa,del2sb,del3mi(2),aim(4),aaim(4),delps,
+ del3m(1),dum,da2a1m,da1a3m,da1a4m,da2a3m,da2a4m,da3a4m
* for debugging purposes
DOUBLE COMPLEX ca1m
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
* #] declarations:
* #[ get ai:
*
* A4: some arbitrary normalisation ...
*
ai(4) = 1
aai(4) = 1
ier2 = ier
if ( del2s .ne. 0 ) then
*
* A3: simple solution of quadratic equation
*
ier0 = ier
call ffroot(aaim(3),aim(3),xpi(4),piDpj(4,3),xpi(3),
+ sdel2s,ier0)
ier2 = max(ier2,ier0)
if ( aim(3) .eq. 0 ) then
* choose the other root
ier = ier + 100
return
endif
ai(3) = ai(4)/aim(3)
if ( aaim(3) .ne. 0 ) then
laai = .TRUE.
aai(3) = aai(4)/aaim(3)
else
laai = .FALSE.
endif
*
* A2: a bit more complicated quadratic equation
*
ier1 = ier
ier0 = ier
call ffdl2s(del2sa,piDpj, 2,4,10,1, 3,4,7,1, 10)
ier1 = max(ier1,ier0)
ier0 = ier
call ffdl3m(del3mi(2),.FALSE.,0D0,0D0,xpi,dpipj,piDpj,10,
+ 3,4,7, 2,1)
ier1 = max(ier1,ier0)
call ffroot(aim(2),aaim(2),xpi(4),piDpj(4,2),del3mi(2)/del2s
+ ,del2sa/sdel2s,ier1)
ier2 = max(ier2,ier1)
if ( aim(2) .eq. 0 ) then
ier = ier + 100
return
endif
ai(2) = ai(4)/aim(2)
if ( laai ) then
if ( aaim(2) .eq. 0 ) then
laai = .FALSE.
else
aai(2) = aai(4)/aaim(2)
endif
endif
*
* A1: same as A2, except for the special nasty case.
*
if ( .not.lnasty ) then
ier0 = ier
ier1 = ier
call ffdl2s(del2sb,piDpj, 1,4,8,-1, 3,4,7,1, 10)
ier1 = max(ier1,ier0)
ier0 = ier
call ffdl3m(del3mi(1),.FALSE.,0D0,0D0,xpi,dpipj,piDpj,10,
+ 3,4,7, 1,1)
ier1 = max(ier1,ier0)
call ffroot(aim(1),aaim(1),xpi(4),piDpj(4,1),del3mi(1)/del2s
+ ,del2sb/sdel2s,ier1)
ier2 = max(ier2,ier1)
if ( aim(1) .eq. 0 ) then
ier = ier + 100
return
endif
ai(1) = ai(4)/aim(1)
if ( laai ) then
if ( aaim(1) .eq. 0 ) then
laai = .FALSE.
else
aai(1) = aai(4)/aaim(1)
endif
endif
else
laai = .FALSE.
ca1m = (c2sisj(1,4) - (c2sisj(1,3)*DBLE(xpi(4)) -
+ c2sisj(1,4)*DBLE(piDpj(3,4)))/DBLE(sdel2s))/
+ DBLE(2*xpi(4))
ca1 = DBLE(ai(4))/ca1m
ai(1) = ai(4)/DBLE(ca1m)
endif
else
*
* the special case del2s=0 with xpi(3)=xpi(4),xpi(7)=0
*
laai = .FALSE.
ai(3) = ai(4)
if ( piDpj(7,2) .eq. 0 .or. piDpj(7,1) .eq. 0 ) then
call fferr(55,ier)
return
endif
ai(2) = ai(4)*xpi(3)/piDpj(7,2)
ai(1) = ai(4)*xpi(3)/piDpj(7,1)
endif
ier = ier2
* #] get ai:
* #[ get daiaj:
ier2 = ier
do 120 i=1,4
daiaj(i,i) = 0
do 110 j=i+1,4
daiaj(j,i) = ai(j) - ai(i)
if ( abs(daiaj(j,i)) .ge. xloss*abs(ai(i)) ) goto 105
if ( del2s .eq. 0 ) then
* #[ del2s=0:
if ( i .eq. 1 .and. j .eq. 2 ) then
daiaj(2,1) = -ai(1)*ai(2)*piDpj(5,7)/xpi(3)
goto 104
elseif ( i .eq. 3 .and. j .eq. 4 ) then
daiaj(4,3) = 0
goto 104
endif
ier1 = ier
call ffwarn(146,ier1,daiaj(j,i),ai(i))
goto 105
* #] del2s=0:
elseif ( lnasty .and. i.eq.1 ) then
ier1 = ier
call ffwarn(146,ier1,daiaj(j,i),ai(i))
goto 105
endif
ier0 = ier
if ( i .eq. 1 .and. j .eq. 2 ) then
* #[ daiaj(2,1):
*
* some determinants (as usual)
*
* as the vertex p1,s4,? does not exist we use ffdl2t
*
call ffdl2t(delps,piDpj, 5,4, 3,4,7,1,+1, 10)
ier1 = max(ier1,ier0)
ier0 = ier
call ffdl3m(del3m,.FALSE.,0D0,0D0,xpi,dpipj,piDpj,
+ 10, 3,4,7, 5,1)
ier1 = max(ier1,ier0)
call ffroot(dum,da2a1m,xpi(4),piDpj(4,5),
+ del3m(1)/del2s,-delps/sdel2s,ier1)
daiaj(2,1) = -ai(1)*ai(2)*da2a1m
goto 104
* #] daiaj(2,1):
elseif ( i .eq. 1 .and. j .eq. 3 ) then
* #[ daiaj(3,1):
*
* Again, the solution of a simple quadratic equation
*
call ffdl2t(delps,piDpj, 9,4, 3,4,7,1,+1, 10)
ier1 = ier0
ier0 = ier
call ffdl3m(del3m,.FALSE.,0D0,0D0,xpi,dpipj,piDpj,
+ 10, 3,4,7, 9,1)
ier1 = max(ier1,ier0)
call ffroot(dum,da1a3m,xpi(4),-piDpj(4,9),
+ del3m(1)/del2s,delps/sdel2s,ier1)
daiaj(3,1) = -ai(1)*ai(3)*da1a3m
goto 104
* #] daiaj(3,1):
elseif ( i .eq. 1 .and. j .eq. 4 ) then
* #[ daiaj(4,1):
*
* Again, the solution of a simple quadratic equation
*
call ffdl2s(delps,piDpj,4,1,8,1,3,4,7,1,10)
ier1 = ier0
ier0 = ier
call ffdl3m(del3m,.FALSE.,0D0,0D0,xpi,dpipj,piDpj,
+ 10, 3,4,7, 8,1)
ier1 = max(ier0,ier1)
call ffroot(dum,da1a4m,xpi(4),piDpj(4,8),del3m(1)/
+ del2s,delps/sdel2s,ier1)
daiaj(4,1) = ai(1)*ai(4)*da1a4m
goto 104
* #] daiaj(4,1):
elseif ( i .eq. 2 .and. j .eq. 3 ) then
* #[ daiaj(3,2):
*
* Again, the solution of a simple quadratic equation
*
call ffdl2t(delps,piDpj, 6,4, 3,4,7,1,+1, 10)
ier1 = ier0
ier0 = ier
call ffdl3m(del3m,.FALSE.,0D0,0D0,xpi,dpipj,piDpj,
+ 10, 3,4,7, 6,1)
ier1 = max(ier1,ier0)
call ffroot(dum,da2a3m,xpi(4),-piDpj(4,6),
+ del3m(1)/del2s,delps/sdel2s,ier1)
daiaj(3,2) = ai(2)*ai(3)*da2a3m
goto 104
* #] daiaj(3,2):
elseif ( i .eq. 2 .and. j .eq. 4 ) then
* #[ daiaj(4,2):
*
* Again, the solution of a simple quadratic equation
*
call ffdl2s(delps,piDpj,2,4,10,1,3,4,7,1,10)
ier1 = ier0
ier0 = ier
call ffdl3m(del3m,.FALSE.,0D0,0D0,xpi,dpipj,piDpj,
+ 10, 3,4,7, 10,1)
ier1 = max(ier0,ier1)
call ffroot(dum,da2a4m,xpi(4),piDpj(4,10),del3m(1)/
+ del2s,delps/sdel2s,ier1)
daiaj(4,2) = -ai(2)*ai(4)*da2a4m
goto 104
* #] daiaj(4,2):
elseif ( i .eq. 3 .and. j .eq. 4 ) then
* #[ daiaj(4,3):
*
* Again, the solution of a very simple quadratic equation
*
ier1 = ier
call ffroot(dum,da3a4m,xpi(4),-piDpj(4,7),
+ xpi(7),sdel2s,ier1)
daiaj(4,3) = ai(3)*ai(4)*da3a4m
goto 104
* #] daiaj(4,3):
endif
104 continue
105 continue
daiaj(i,j) = -daiaj(j,i)
ier2 = max(ier2,ier1)
110 continue
120 continue
ier = ier2
* #] get daiaj:
*###] ffai:
end
*###[ fftran:
subroutine fftran(ai,daiaj,aai,laai,xqi,dqiqj,qiDqj,
+ del2s,sdel2s,xpi,dpipj,piDpj,ier)
***#[*comment:***********************************************************
* *
* Transform the impulses according to *
* *
* ti = Ai*si *
* qij = (Ai*si - Aj*sj) *
* *
* In case del2s=0 it calculates the same coefficients but for *
* for A1,A2 leave out the delta with 2*delta = 1-xpi(4)/xpi(3) *
* infinitesimal. *
* *
* Input: ai(4) ai *
* daiaj(4,4) ai-aj *
* del2s \delta^{s(3) s4}_{s(3) s4} *
* sdel2s sqrt(del2s) *
* xpi(10) masses = s1-s2-s(3)-s4 *
* dpipj(10,10) differences *
* piDpj(10,10) dotproducts *
* *
* Output: xqi(10) transformed momenta *
* dqiqj(10,10) differences *
* qiDqj(10,10) dotproducts *
* ier (integer) 0=ok,1=inaccurate,2=error *
* *
* Calls: ffxlmb,... *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
logical laai
DOUBLE PRECISION ai(4),daiaj(4,4),aai(4),xqi(10),dqiqj(10,10),
+ qiDqj(10,10),del2s,sdel2s,xpi(10),dpipj(10,10),
+ piDpj(10,10)
*
* local variables
*
integer i,j,ji,k,kj,l,lk,is,isgnji,isgnlk,
+ ifirst,i1,j1,k1,j2,kk,kkj,ier0,ier1,ier2
logical lgo
DOUBLE PRECISION xmax,dum,delps,del2d2,dl2d22,aijk,aijkl,
+ smax,s(3),som
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
*
ifirst = 0
* #] declarations:
* #[ si.sj -> ti.tj:
*
* calculate the dotproducts of ti(i) = ai*si(i): no problems.
*
do 20 i=1,4
xqi(i) = ai(i)**2 * xpi(i)
qiDqj(i,i) = xqi(i)
do 10 j=i+1,4
qiDqj(j,i) = ai(j)*ai(i)*piDpj(j,i)
qiDqj(i,j) = qiDqj(j,i)
10 continue
20 continue
*
* and the smuggled ones for the onshell complex D0
*
if ( lsmug ) then
do 40 j=1,3
do 30 i=i+1,4
c2sisj(i,j) = DBLE(ai(j)*ai(i))*c2sisj(i,j)
c2sisj(j,i) = c2sisj(i,j)
30 continue
40 continue
endif
if ( lnasty ) then
do 60 j=3,4
*
* we also hide in this array the corresponding real value
* in (j,2) and (2,j), and the untransformed in (j,j).
* Not beuatiful, but we need these to get the correct
* Riemann sheets.
*
c2sisj(j,j) = c2sisj(j,1)
c2sisj(j,2) = ai(j)*ai(1)*DBLE(c2sisj(j,1))
c2sisj(2,j) = c2sisj(j,2)
c2sisj(j,1) = DBLE(ai(j))*ca1*c2sisj(j,1)
c2sisj(1,j) = c2sisj(j,1)
*
60 continue
endif
*
* #] si.sj -> ti.tj:
* #[ si.pj -> ti.qj:
*
* The dotproducts ti.qjk are still not too bad
* Notice that t3.p = t4.p, so qiDqj(3,5-10) = qiDqj(4,5-10)
*
ier2 = ier
do 90 i=1,4
do 80 j=1,3
do 70 k=j+1,4
ier1 = ier
kj = inx(k,j)
is = isgn(k,j)
if ( i.eq.4 .and.
+ (del2s.ne.0 .or. kj.eq.5 .or. kj.eq.7 )) then
qiDqj(kj,4) = qiDqj(kj,3)
goto 65
endif
s(1) = qiDqj(k,i)
s(2) = qiDqj(j,i)
qiDqj(kj,i) = is*(s(1) - s(2))
if ( abs(qiDqj(kj,i)).ge.xloss*abs(s(1)) ) goto 65
ier0 = ier
if ( del2s .eq. 0 ) then
*
* the special cases for del2s-0
*
if ( kj .eq. 5 ) then
call ffdl2t(delps,piDpj, 7,i, 1,2,5, 1,1,10)
qiDqj(5,i) = ai(1)*ai(2)*ai(i)*delps/xpi(3)
elseif ( kj .eq. 7 ) then
qiDqj(kj,i) = ai(i)*ai(4)**2*piDpj(kj,i)
else
*
* the pi has a mixed delta/no delta behaviour
*
call ffwarn(144,ier1,qiDqj(kj,i),s(1))
goto 65
endif
goto 65
endif
*
* Normal case, from the quadratic equation ...
*
ier1 = ier0
ier0 = ier
call ff2dl2(del2d2,delps,xpi,dpipj,piDpj, i,
+ j,k,kj,is, 4, 3,4,7,+1, 10, ier0)
ier1 = max(ier1,ier0)
ier0 = ier
call ff2d22(dl2d22,xpi,dpipj,piDpj, i, j,k,kj,is,
+ 3,4,7,+1)
ier1 = max(ier1,ier0)
call ffroot(dum,aijk,xpi(4),delps,dl2d22/del2s,
+ -del2d2/sdel2s,ier1)
* the minus sign is because we have aijk, not aikj.
qiDqj(kj,i) = -is*aijk*ai(i)*ai(j)*ai(k)
65 continue
qiDqj(i,kj) = qiDqj(kj,i)
ier2 = max(ier2,ier1)
70 continue
80 continue
90 continue
* #] si.pj -> ti.qj:
* #[ pi.pj -> qi.qj:
do 180 i=1,3
do 170 j=i+1,4
ji = inx(j,i)
isgnji = isgn(j,i)
do 160 k=i,3
do 150 l=k+1,4
if ( k .eq. i .and. l .lt. j ) goto 150
ier1 = ier
lk = inx(l,k)
isgnlk = isgn(l,k)
*
* Some are zero by definition, or equal to others
*
if ( del2s .ne. 0 .and. (ji.eq.7 .or. lk.eq.7)
+ .or.
+ del2s .eq. 0 .and. (ji.eq.7 .and. (lk.eq.7
+ .or. lk.eq.5) .or. ji.eq.5 .and. lk.eq.7
+ ) ) then
qiDqj(lk,ji) = 0
goto 145
endif
if ( j.eq.4 .and. (del2s.ne.0 .or. lk.eq.5) )
+ then
qiDqj(lk,ji) = isgnji*isgn(3,i)*
+ qiDqj(lk,inx(3,i))
goto 145
endif
if ( l.eq.4 .and. (del2s.ne.0 .or. ji.eq.5) )
+ then
qiDqj(lk,ji) = isgnlk*isgn(3,k)*
+ qiDqj(inx(3,k),ji)
goto 145
endif
*
* First normal try
*
if ( abs(qiDqj(k,ji)).le.abs(qiDqj(i,lk)) ) then
s(1) = qiDqj(k,ji)
s(2) = qiDqj(l,ji)
is = isgnlk
else
s(1) = qiDqj(i,lk)
s(2) = qiDqj(j,lk)
is = isgnji
endif
qiDqj(lk,ji) = is*(s(2) - s(1))
if ( abs(qiDqj(lk,ji)) .ge. xloss**2*abs(s(1)) )
+ goto 145
*
* First the special case del2s=0
*
if ( del2s .eq. 0 ) then
if ( ji .eq. 5 .and. lk .eq. 5 ) then
call ffdl3m(s(1),.FALSE.,0D0,0D0,xpi,
+ dpipj,piDpj, 10, 1,2,5, 7, 1)
qiDqj(5,5) =ai(1)**2*ai(2)**2*s(1)/xpi(3
+ )**2
else
call ffwarn(145,ier1,qiDqj(lk,ji),s(1))
endif
goto 145
endif
*
* Otherwise use determinants
*
call ffabcd(aijkl,xpi,dpipj,piDpj,del2s,
+ sdel2s, i,j,ji,isgnji, k,l,lk,isgnlk,
+ ifirst, ier1)
qiDqj(lk,ji) = (isgnji*isgnlk)*
+ aijkl*ai(i)*ai(j)*ai(k)*ai(l)
goto 145
* print *,'fftran: warning: numerical problems ',
* + 'in qiDqj(',lk,ji,')'
145 continue
if ( lk .ne. ji ) then
qiDqj(ji,lk) = qiDqj(lk,ji)
else
xqi(ji) = qiDqj(lk,ji)
endif
ier2 = max(ier2,ier1)
150 continue
160 continue
170 continue
180 continue
ier = ier2
* #] pi.pj -> qi.qj:
* #[ si^2 - sj^2:
*
* the differences may be awkward
*
ier2 = ier
do 140 i=1,4
dqiqj(i,i) = 0
do 130 j=i+1,4
ier0 = ier
dqiqj(j,i) = xqi(j) - xqi(i)
smax = abs(xqi(i))
if ( abs(dqiqj(j,i)) .ge. xloss*smax ) goto 125
if ( abs(daiaj(j,i)) .le. xloss*abs(ai(i)) )
+ then
s(1) = daiaj(j,i)*(ai(i)+ai(j))*xpi(j)
s(2) = ai(i)**2*dpipj(j,i)
som = s(1) + s(2)
xmax = abs(s(1))
if ( xmax.lt.smax ) then
dqiqj(j,i) = som
smax = xmax
endif
if ( abs(dqiqj(j,i)) .ge. xloss*smax ) goto 125
endif
*
* give up
*
125 continue
dqiqj(i,j) = -dqiqj(j,i)
ier2 = max(ier2,ier0)
130 continue
140 continue
* #] si^2 - sj^2:
* #[ si^2 - pj^2:
do 210 i=1,4
do 200 j=1,4
do 190 kk=j+1,4
ier0 = ier
k = kk
kj = inx(k,j)
kkj = kj
*
* Use that q_(i4)^2 = q_(i3)^2
*
if ( del2s.ne.0 .and. k.eq.4 ) then
if ( j .eq. 3 ) then
dqiqj(7,i) = -xqi(i)
else
dqiqj(kj,i) = dqiqj(inx(j,3),i)
endif
goto 185
elseif ( kj .eq. 7 ) then
dqiqj(7,i) = -xqi(i)
goto 185
endif
xmax = 0
181 continue
som = xqi(kj) - xqi(i)
if ( k.eq.kk .or. abs(xqi(i)).lt.xmax ) then
dqiqj(kj,i) = som
xmax = abs(xqi(i))
if ( abs(dqiqj(kj,i)) .ge. xloss*xmax ) goto 185
endif
*
* second try
* we assume that qi.qj, i,j<=3 are known
*
if ( abs(dqiqj(k,i)) .lt. abs(dqiqj(j,i)) ) then
j1 = k
j2 = j
else
j2 = k
j1 = j
endif
s(1) = dqiqj(j1,i)
s(2) = xqi(j2)
s(3) = -2*qiDqj(j1,j2)
som = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( smax.lt.xmax ) then
dqiqj(kj,i) = som
xmax = smax
if ( abs(dqiqj(kj,i)) .ge. xloss*xmax ) goto 185
endif
*
* third try: rearrange s(2),s(3)
* this works if ai(j1)~ai(j2)
*
if ( abs(daiaj(j2,j1)) .lt. xloss*abs(ai(j1)) ) then
s(2) = ai(j2)*daiaj(j2,j1)*xpi(j2)
s(3) = ai(j2)*ai(j1)*dpipj(kj,j1)
som = s(1) + s(2) + s(3)
smax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( smax.lt.xmax ) then
dqiqj(kj,i) = som
xmax = smax
if ( abs(dqiqj(kj,i)) .ge. xloss*xmax )
+ goto 185
endif
endif
*
* There is a trick involving the other root for j2=4
* Of course it also works for j2=3.
*
if ( laai .and. j2 .ge. 3 ) then
s(2) = -ai(4)**2*(ai(j1)/aai(j1))*xpi(4)
som = s(1) + s(2)
smax = abs(s(1))
if ( smax.lt.xmax ) then
dqiqj(kj,i) = som
xmax = smax
if ( abs(dqiqj(kj,i)) .ge. xloss*xmax )
+ goto 185
endif
endif
*
* If k = 3 we can also try with k = 4 -- should give
* the same
*
if ( del2s.ne.0 .and. kk.eq.3 .and. k.eq.3 ) then
k = 4
kj = inx(k,j)
dqiqj(kj,i) = dqiqj(kkj,i)
goto 181
endif
if ( del2s.ne.0 .and. kk.eq.4 .and. k.eq.4 ) then
k = 3
kj = inx(k,j)
dqiqj(kj,i) = dqiqj(kkj,i)
goto 181
endif
*
* give up
*
185 continue
if ( k .ne. kk ) then
dqiqj(kkj,i) = dqiqj(kj,i)
dqiqj(i,kkj) = -dqiqj(kj,i)
else
dqiqj(i,kj) = -dqiqj(kj,i)
endif
ier2 = max(ier2,ier0)
190 continue
200 continue
210 continue
* #] si^2 - pj^2:
* #[ pi^2 - pj^2:
do 280 i=1,4
do 270 j=i+1,4
ji = inx(j,i)
dqiqj(ji,ji) = 0
do 260 k=i,4
do 250 l=k+1,4
ier0 = ier
if ( k .eq. i .and. l .le. j ) goto 250
lk = inx(l,k)
if ( del2s .eq. 0 ) then
*
* special case:
*
if ( j.eq.4 .and. i.eq.3 ) then
dqiqj(lk,7) = xqi(lk)
goto 245
endif
if ( l.eq.4 .and. k.eq.3 ) then
dqiqj(7,ji) = -xqi(ji)
goto 245
endif
else
*
* Use that t_3.p_i = t_4.p_i
*
if ( k.eq.i .and. j.eq.3 .and. l.eq.4 ) then
dqiqj(lk,ji) = 0
goto 245
endif
if ( j.eq.4 ) then
if ( i .eq. 3 ) then
dqiqj(lk,7) = xqi(lk)
else
dqiqj(lk,ji) = dqiqj(lk,inx(i,3))
endif
goto 245
endif
if ( l.eq.4 ) then
if ( k .eq. 3 ) then
dqiqj(7,ji) = -xqi(ji)
else
dqiqj(lk,ji) = dqiqj(inx(k,3),ji)
endif
goto 245
endif
endif
*
* We really have to calculate something
*
dqiqj(lk,ji) = xqi(lk) - xqi(ji)
smax = abs(xqi(lk))
if ( abs(dqiqj(lk,ji)).ge.xloss*smax ) goto 245
*
* First the special case j=k,l
*
i1 = i
j1 = j
k1 = k
lgo = .FALSE.
if ( j .eq. k ) then
k1 = l
lgo = .TRUE.
elseif ( j .eq. l ) then
lgo = .TRUE.
elseif ( i .eq. k ) then
i1 = j
j1 = i
k1 = l
lgo = .TRUE.
endif
if ( lgo ) then
s(1) = dqiqj(k1,i1)
s(2) = 2*isgn(i1,k1)*qiDqj(j1,inx(i1,k1))
xmax = abs(s(1))
if ( xmax .lt. smax ) then
smax = xmax
dqiqj(lk,ji) = s(1) + s(2)
if ( abs(dqiqj(lk,ji)).ge.xloss*smax )
+ goto 245
endif
endif
*
* Just some recombinations
*
if ( abs(dqiqj(l,ji)).lt.abs(dqiqj(k,ji)) ) then
j1 = l
j2 = k
else
j2 = l
j1 = k
endif
s(1) = dqiqj(j1,ji)
s(2) = xqi(j2)
s(3) = -2*qiDqj(j1,j2)
* only if this is an improvement
xmax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( xmax .lt. smax ) then
smax = xmax
dqiqj(lk,ji) = s(1) + s(2) + s(3)
if ( abs(dqiqj(lk,ji)) .ge. xloss*smax )
+ goto 245
endif
if ( abs(dqiqj(j,lk)).lt.abs(dqiqj(i,lk)) ) then
j1 = j
j2 = i
else
j2 = j
j1 = i
endif
s(1) = -dqiqj(j1,lk)
s(2) = -xqi(j2)
s(3) = 2*qiDqj(j1,j2)
* only if this is an improvement
xmax = max(abs(s(1)),abs(s(2)),abs(s(3)))
if ( xmax .lt. smax ) then
dqiqj(lk,ji) = s(1) + s(2) + s(3)
smax = xmax
if ( abs(dqiqj(lk,ji)) .ge. xloss*smax )
+ goto 245
endif
*
* give up
*
245 continue
dqiqj(ji,lk) = -dqiqj(lk,ji)
ier2 = max(ier2,ier0)
250 continue
260 continue
270 continue
280 continue
ier = ier2
* #] pi^2 - pj^2:
*###] fftran:
end
diff --git a/Looptools/util/ffxli2.F b/Looptools/util/ffxli2.F
--- a/Looptools/util/ffxli2.F
+++ b/Looptools/util/ffxli2.F
@@ -1,590 +1,593 @@
+#include "externals.h"
+
+
*###[ ffxli2:
subroutine ffxli2(xdilog,xlog,x,ier)
***#[*comment:***********************************************************
* *
* Computes the dilogarithm (Li2, Sp) for (real) x to precision *
* precx. It is assumed that -1<=x<=1/2. As it is available anyway*
* log(1-x) = -Li1(x) is also passed. *
* *
* Input: x (real) *
* *
* Output: xdilog (real) Li2(x) *
* xlog (real) log(1-x) = -Li1(x) *
* ier (integer) 0=OK, 1=num prob, 2=error *
* *
* Calls: log,dfflo1 *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ier
DOUBLE PRECISION xdilog,xlog,x
*
* local variables
*
integer ipi12
DOUBLE PRECISION dfflo1,u,u2,a,ffbnd,
+ xprec,bdn02,bdn05,bdn10,bdn15
DOUBLE COMPLEX zxdilo,zlog
external ffbnd,dfflo1
save xprec,bdn02,bdn05,bdn10,bdn15
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ initialisations:
data xprec /-1D0/
if ( xprec .ne. precx ) then
xprec = precx
bdn02 = ffbnd(1,2,bf)
bdn05 = ffbnd(1,5,bf)
bdn10 = ffbnd(1,10,bf)
bdn15 = ffbnd(1,15,bf)
endif
* #] initialisations:
* #[ if the argument is too large...
if ( x .lt. -1.5 .or. x .gt. .75 ) then
call ffzxdl(zxdilo,ipi12,zlog,x,0,ier)
if ( DIMAG(zxdilo) .ne. 0 ) then
call fferr(52,ier)
endif
xdilog = DBLE(zxdilo) + ipi12*pi12
xlog = DBLE(zlog)
return
endif
* #] if the argument is too large...
* #[ exceptional cases:
if ( x .eq. -1 ) then
xdilog = -pi12
xlog = log(2D0)
return
elseif ( x .eq. .5D0 ) then
xdilog = - xlg2**2/2 + pi12
xlog = - xlg2
return
elseif ( abs(x) .lt. precx ) then
xdilog = x
xlog = -x
return
endif
* #] exceptional cases:
* #[ calculate dilog:
if ( abs(x) .lt. xloss ) then
xlog = dfflo1(x,ier)
else
xlog = log(1-x)
endif
u = -xlog
u2 = u*u
a = abs(u2)
if ( a .gt. bdn15 ) then
xdilog = u2*(bf(16) + u2*(bf(17) + u2*(bf(18) +
+ u2*(bf(19) + u2*bf(20) ))))
else
xdilog = 0
endif
if ( a .gt. bdn10 ) then
xdilog = u2*(bf(11) + u2*(bf(12) + u2*(bf(13) +
+ u2*(bf(14) + u2*(bf(15) + xdilog)))))
endif
if ( a .gt. bdn05 ) then
xdilog = u2*(bf(6) + u2*(bf(7) + u2*(bf(8) +
+ u2*(bf(9) + u2*(bf(10) + xdilog)))))
endif
if ( a .gt. bdn02 ) then
xdilog = u2*(bf(3) + u2*(bf(4) + u2*(bf(5) + xdilog)))
endif
* watch the powers of u.
xdilog = u + u2*(bf(1) + u*(bf(2) + xdilog))
* #] calculate dilog:
*###] ffxli2:
end
*###[ ffzxdl:
subroutine ffzxdl(zxdilo,ipi12,zlog,x,ieps,ier)
***#[*comment:***************************************************
* Computes the dilogarithm (Li2, Sp) for any (real) x *
* to precision precx. If an error message is given add *
* more bf's. For x > 1 the imaginary part is *
* -/+i*pi*log(x), corresponding to x+ieps. *
* The number of factors pi^2/12 is passed separately in *
* ipi12 for accuracy. We also calculate log(1-x) *
* which is likely to be needed. *
* *
* Input: x (real) *
* ieps (integer,+/-1) *
* *
* Output: zxdilo (complex) the dilog mod factors pi2/12 *
* ipi12 (integer) these factors *
* zlog (complex) log(1-x) *
* *
* Calls: log,dfflo1 *
* *
***#]*comment:***************************************************
* #[ declarations:
implicit none
*
* arguments
*
integer ipi12,ieps,ier
DOUBLE PRECISION x
DOUBLE COMPLEX zxdilo,zlog
*
* local variables
*
integer jsgn
DOUBLE PRECISION fact,u,u2,dfflo1,ffbnd,a,xdilo,
+ xprec,bdn02,bdn05,bdn10,bdn15
DOUBLE COMPLEX cy,cfact
external ffbnd,dfflo1
save xprec,bdn02,bdn05,bdn10,bdn15
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ initialisations:
data xprec /-1D0/
if ( xprec .ne. precx ) then
xprec = precx
bdn02 = ffbnd(1,2,bf)
bdn05 = ffbnd(1,5,bf)
bdn10 = ffbnd(1,10,bf)
bdn15 = ffbnd(1,15,bf)
endif
* #] initialisations:
* #[ exceptional cases:
if ( x .eq. 1) then
zxdilo = 0
zlog = -99999
ipi12 = 2
return
elseif (x .eq. -1) then
zxdilo = 0
zlog = xlg2
ipi12 = -1
return
elseif (x .eq. .5D0) then
zxdilo = - xlg2**2/2
zlog = -xlg2
ipi12 = 1
return
elseif ( abs(x) .lt. precx ) then
zxdilo = x
zlog = -x
ipi12 = 0
return
endif
* #] exceptional cases:
* #[ transform to (-1,.5):
if (x .lt. -1) then
fact = log(-x)
cy = - fact**2/2
ipi12 = -2
if ( -x*xloss .gt. 1 ) then
u = -dfflo1(1/x,ier)
else
u = -log(1-1/x)
endif
zlog = log(1-x)
jsgn = -1
elseif ( x .lt. .5D0) then
cy = 0
ipi12 = 0
if ( abs(x) .lt. xloss ) then
zlog = dfflo1(x,ier)
else
zlog = log(1-x)
endif
u = -DBLE(zlog)
jsgn = 1
elseif ( x .le. 2 ) then
u = -log(x)
if ( abs(1-x) .lt. xalogm ) then
cy = 0
elseif ( x .lt. 1 ) then
zlog = log(1-x)
cy = DBLE(u)*zlog
elseif ( ieps .gt. 0 ) then
zlog = DCMPLX(log(x-1),-pi)
cy = DBLE(u)*zlog
else
zlog = DCMPLX(log(x-1),+pi)
cy = DBLE(u)*zlog
endif
ipi12 = 2
jsgn = -1
else
if ( ieps .gt. 0 ) then
cfact = DCMPLX(log(x),-pi)
zlog = DCMPLX(log(x-1),-pi)
else
cfact = DCMPLX(log(x),+pi)
zlog = DCMPLX(log(x-1),+pi)
endif
cy = - cfact**2/2
ipi12 = -2
if ( x*xloss .gt. 1 ) then
u = -dfflo1(1/x,ier)
else
u = -log(1-1/x)
endif
jsgn = -1
endif
* #] transform to (-1,.5):
* #[ calculate dilog:
if ( abs(u) .lt. xalog2 ) then
xdilo = u
else
u2 = u**2
a = abs(u2)
if ( a .gt. bdn15 ) then
xdilo = u2*(bf(16) + u2*(bf(17) + u2*(bf(18) +
+ u2*(bf(19) + u2*bf(20) ))))
else
xdilo = 0
endif
if ( a .gt. bdn10 ) then
xdilo = u2*(bf(11) + u2*(bf(12) + u2*(bf(13) +
+ u2*(bf(14) + u2*(bf(15) + xdilo)))))
endif
if ( a .gt. bdn05 ) then
xdilo = u2*(bf(6) + u2*(bf(7) + u2*(bf(8) +
+ u2*(bf(9) + u2*(bf(10) + xdilo)))))
endif
if ( a .gt. bdn02 ) then
xdilo = u2*(bf(3) + u2*(bf(4) + u2*(bf(5) + xdilo)))
endif
* watch the powers of u.
xdilo = u + u2*(bf(1) + u*(bf(2) + xdilo))
endif
if(jsgn.eq.1)then
zxdilo = DBLE(xdilo) + cy
else
zxdilo = -DBLE(xdilo) + cy
endif
* #] calculate dilog:
*###] ffzxdl:
end
*###[ zxfflg:
DOUBLE COMPLEX function zxfflg(x,ieps,y,ier)
***#[*comment:***********************************************************
* *
* Calculate the complex logarithm of x. The following cases *
* are treted separately: *
* |x| too small: give warning and return 0 *
* (for Absoft, Apollo DN300) *
* |x| < 0: take sign according to ieps *
* *
***#]*comment:***********************************************************
* #[ declarations:
*
* arguments
*
implicit none
integer ieps,ier
DOUBLE PRECISION x,y
*
* local variables
*
DOUBLE PRECISION xlog
*
* common blocks
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ calculations:
if ( abs(x) .lt. xalogm ) then
zxfflg = 0
elseif ( x .gt. 0 ) then
zxfflg = log(x)
else
xlog = log(-x)
* checked imaginary parts 19-May-1988
if ( abs(ieps) .eq. 1 ) then
if ( y*ieps .lt. 0 ) then
zxfflg = DCMPLX(xlog,-pi)
else
zxfflg = DCMPLX(xlog,pi)
endif
elseif ( ieps .eq. 2 ) then
zxfflg = DCMPLX(xlog,-pi)
elseif ( ieps .eq. -2 ) then
zxfflg = DCMPLX(xlog,+pi)
else
call fferr(52,ier)
zxfflg = DCMPLX(xlog,pi)
endif
endif
* #] calculations:
*###] zxfflg:
end
*###[ dfflo1:
DOUBLE PRECISION function dfflo1(x,ier)
***#[*comment:***************************************************
* calculates log(1-x) for |x|<.14 in a faster way to ~15 *
* significant figures. *
***#]*comment:***************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,bdn19,xprec,
+ xa,ffbnd
DOUBLE COMPLEX zxfflg
external ffbnd,zxfflg
save xprec,bdn01,bdn05,bdn10,bdn15,bdn19
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ initialisation:
data xprec /-1D0/
if ( xprec .ne. precx ) then
xprec = precx
* determine the boundaries for 1,5,10,15 terms
bdn01 = ffbnd(1,1,xninv)
bdn05 = ffbnd(1,5,xninv)
bdn10 = ffbnd(1,10,xninv)
bdn15 = ffbnd(1,15,xninv)
bdn19 = ffbnd(1,19,xninv)
endif
* #] initialisation:
* #[ calculations:
xa = abs(x)
if ( xa .gt. bdn19 ) then
dfflo1 = DBLE(zxfflg(1-x,0,0D0,ier))
return
endif
if ( xa .gt. bdn15 ) then
dfflo1 = x*( xninv(16) + x*( xninv(17) + x*( xninv(18) +
+ x*( xninv(19) + x*xninv(20) ))))
else
dfflo1 = 0
endif
if ( xa .gt. bdn10 ) then
dfflo1 = x*( xninv(11) + x*( xninv(12) + x*( xninv(13) +
+ x*( xninv(14) + x*( xninv(15) + dfflo1 )))))
endif
if ( xa .gt. bdn05 ) then
dfflo1 = x*( xninv(6) + x*( xninv(7) + x*( xninv(8) +
+ x*( xninv(9) + x*( xninv(10) + dfflo1 )))))
endif
if ( xa .gt. bdn01 ) then
dfflo1 = x*( xninv(2) + x*( xninv(3) + x*( xninv(4) +
+ x*( xninv(5) + dfflo1 ))))
endif
dfflo1 = - x*( xninv(1) + dfflo1 )
* #] calculations:
*###] dfflo1:
end
*###[ dfflo2:
DOUBLE PRECISION function dfflo2(x,ier)
***#[*comment:***************************************************
* calculates log(1-x)+x for |x|<.14 in a faster way to *
* ~15 significant figures. *
***#]*comment:***************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,bdn18,xprec,
+ xa,ffbnd,dfflo1
external ffbnd,dfflo1
save xprec,bdn01,bdn05,bdn10,bdn15,bdn18
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ initialisation:
data xprec /-1D0/
if ( xprec .ne. precx ) then
xprec = precx
* determine the boundaries for 1,5,10,15 terms
bdn01 = ffbnd(1,1,xninv(2))
bdn05 = ffbnd(1,5,xninv(2))
bdn10 = ffbnd(1,10,xninv(2))
bdn15 = ffbnd(1,15,xninv(2))
bdn18 = ffbnd(1,18,xninv(2))
endif
* #] initialisation:
* #[ calculations:
xa = abs(x)
if ( xa .gt. bdn18 ) then
dfflo2 = dfflo1(x,ier) + x
return
endif
if ( xa .gt. bdn15 ) then
dfflo2 = x*( xninv(17) + x*( xninv(18) + x*( xninv(19) +
+ x*xninv(20) )))
else
dfflo2 = 0
endif
if ( xa .gt. bdn10 ) then
dfflo2 = x*( xninv(12) + x*( xninv(13) + x*( xninv(14) +
+ x*( xninv(15) + x*( xninv(16) + dfflo2 )))))
endif
if ( xa .gt. bdn05 ) then
dfflo2 = x*( xninv(7) + x*( xninv(8) + x*( xninv(9) +
+ x*( xninv(10) + x*( xninv(11) + dfflo2 )))))
endif
if ( xa .gt. bdn01 ) then
dfflo2 = x*( xninv(3) + x*( xninv(4) + x*( xninv(5) +
+ x*( xninv(6) + dfflo2 ))))
endif
dfflo2 = - x**2*( xninv(2) + dfflo2 )
* #] calculations:
*###] dfflo2:
end
*###[ dfflo3:
DOUBLE PRECISION function dfflo3(x,ier)
***#[*comment:***************************************************
* calculates log(1-x)+x+x^2/2 for |x|<.14 in a faster *
* way to ~15 significant figures. *
***#]*comment:***************************************************
* #[ declarations:
implicit none
integer ier
DOUBLE PRECISION x,bdn01,bdn05,bdn10,bdn15,xprec,
+ xa,ffbnd,dfflo2
external ffbnd,dfflo2
save xprec,bdn01,bdn05,bdn10,bdn15
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ initialisation:
data xprec /-1D0/
if ( xprec .ne. precx ) then
xprec = precx
* determine the boundaries for 1,5,10,15 terms
bdn01 = ffbnd(1,1,xninv(3))
bdn05 = ffbnd(1,5,xninv(3))
bdn10 = ffbnd(1,10,xninv(3))
bdn15 = ffbnd(1,15,xninv(3))
endif
* #] initialisation:
* #[ calculations:
xa = abs(x)
if ( xa .gt. bdn15 ) then
dfflo3 = dfflo2(x,ier) + x**2/2
return
endif
if ( xa .gt. bdn10 ) then
dfflo3 = x*( xninv(13) + x*( xninv(14) + x*( xninv(15) +
+ x*( xninv(16) + x*xninv(17) ))))
else
dfflo3 = 0
endif
if ( xa .gt. bdn05 ) then
dfflo3 = x*( xninv(8) + x*( xninv(9) + x*( xninv(10) +
+ x*( xninv(11) + x*( xninv(12) + dfflo3 )))))
endif
if ( xa .gt. bdn01 ) then
dfflo3 = x*( xninv(4) + x*( xninv(5) + x*( xninv(6) +
+ x*( xninv(7) + dfflo3 ))))
endif
dfflo3 = - x**3*( xninv(3) + dfflo3 )
* #] calculations:
*###] dfflo3:
end
*###[ ffxl22:
subroutine ffxl22(xl22,x,ier)
***#[*comment:***************************************************
* calculates Li2(2-x) for |x|<.14 in a faster way to ~15 *
* significant figures. *
***#]*comment:***************************************************
* #[ declarations:
implicit none
integer ier,init
DOUBLE PRECISION xl22,x,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,
+ xprec,xa,ffbnd,dilog2(29)
external ffbnd
save xprec,bdn01,bdn05,bdn10,bdn15,bdn20,bdn25,init,dilog2
- include 'ff.h'
+#include "ff.h"
data xprec /-1D0/
data init /0/
if ( init .eq. 0 ) then
init = 1
* taylor(dilog(x-1),x,30);
dilog2( 1) = 0.d0
dilog2( 2) = 1/4.d0
dilog2( 3) = 1/6.d0
dilog2( 4) = 5/48.d0
dilog2( 5) = 1/15.d0
dilog2( 6) = 2/45.d0
dilog2( 7) = 13/420.d0
dilog2( 8) = 151/6720.d0
dilog2( 9) = 16/945.d0
dilog2(10) = 83/6300.d0
dilog2(11) = 73/6930.d0
dilog2(12) = 1433/166320.d0
dilog2(13) = 647/90090.d0
dilog2(14) = 15341/2522520.d0
dilog2(15) = 28211/5405400.d0
dilog2(16) = 10447/2306304.d0
dilog2(17) = 608/153153.d0
dilog2(18) = 19345/5513508.d0
dilog2(19) = 18181/5819814.d0
dilog2(20) = 130349/46558512.d0
dilog2(21) = 771079/305540235.d0
dilog2(22) = 731957/320089770.d0
dilog2(23) = 2786599/1338557220.d0
dilog2(24) = 122289917/64250746560.d0
dilog2(25) = 14614772/8365982625.d0
dilog2(26) = 140001721/87006219300.d0
dilog2(27) = 134354573/90352612350.d0
dilog2(28) = 774885169/562194032400.d0
dilog2(29) = 745984697/582272390700.d0
endif
* #] declarations:
* #[ initialisation:
if ( xprec .ne. precx ) then
xprec = precx
* determine the boundaries for 1,5,10,15,20 terms
bdn01 = ffbnd(2,1,dilog2)
bdn05 = ffbnd(2,5,dilog2)
bdn10 = ffbnd(2,10,dilog2)
bdn15 = ffbnd(2,15,dilog2)
bdn20 = ffbnd(2,20,dilog2)
bdn25 = ffbnd(2,25,dilog2)
endif
* #] initialisation:
* #[ calculations:
xa = abs(x)
if ( xa .gt. bdn25 ) then
call ffwarn(230,ier,precx,dilog2(27)*xa**25)
endif
if ( xa .gt. bdn20 ) then
xl22 = x*( dilog2(22) + x*( dilog2(23) + x*( dilog2(24) +
+ x*( dilog2(25) + x*dilog2(26) ))))
else
xl22 = 0
endif
if ( xa .gt. bdn15 ) then
xl22 = x*( dilog2(17) + x*( dilog2(18) + x*( dilog2(19) +
+ x*( dilog2(20) + x*dilog2(21) ))))
endif
if ( xa .gt. bdn10 ) then
xl22 = x*( dilog2(12) + x*( dilog2(13) + x*( dilog2(14) +
+ x*( dilog2(15) + x*dilog2(16) ))))
endif
if ( xa .gt. bdn05 ) then
xl22 = x*( dilog2(7) + x*( dilog2(8) + x*( dilog2(9) +
+ x*( dilog2(10) + x*( dilog2(11) + xl22 )))))
endif
if ( xa .gt. bdn01 ) then
xl22 = x*( dilog2(3) + x*( dilog2(4) + x*( dilog2(5) +
+ x*( dilog2(6) + xl22 ))))
endif
xl22 = - x**2*( dilog2(2) + xl22 )
* #] calculations:
*###] ffxl22:
end
diff --git a/Looptools/util/ffxxyz.F b/Looptools/util/ffxxyz.F
--- a/Looptools/util/ffxxyz.F
+++ b/Looptools/util/ffxxyz.F
@@ -1,720 +1,723 @@
+#include "externals.h"
+
+
*###[ ffxxyz:
subroutine ffxxyz(y,z,dyz,d2yzz,dy2z,ivert,sdel2p,sdel2s,etalam,
+ etami,delps,xpi,dpipj,piDpj,isoort,ldel2s,ns,ier)
***#[*comment:***********************************************************
* *
* calculate in a numerically stable way *
* *
* z(1,2) = (-p(ip1).p(is2) +/- sdel2s)/xpi(ip1) *
* y(1,2) = (-p(ip1).p(is2) +/- sdisc)/xpi(ip1) *
* disc = del2s + etaslam*xpi(ip1) *
* *
* y(3,4) = 1-y(1,2) *
* z(3,4) = 1-z(1,2) *
* dyz(i,j) = y(i) - z(j) *
* d2yzz = y(2) - z(1) - z(2) *
* dy2z(j) = y(2) - 2*z(j) *
* *
* Input: ivert (integer) defines the vertex *
* sdel2p (real) sqrt(lam(p1,p2,p3))/2 *
* sdel2s (real) sqrt(lam(p,ma,mb))/2 *
* etalam (real) det(si.sj)/det(pi.pj) *
* etami(6) (real) si.si - etalam *
* xpi(ns) (real) standard *
* piDpj(ns,ns) (real) standard *
* ns (integer) dim of xpi,piDpj *
* *
* Output: y(4),z(4),dyz(4,4) (real) see above *
* *
* Calls: fferr,ffroot *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer ivert,ns,ier,isoort(2)
logical ldel2s
DOUBLE PRECISION y(4),z(4),dyz(2,2),d2yzz,dy2z(4),
+ sdel2p,sdel2s,etalam,etami(6),delps,xpi(ns),
+ dpipj(ns,ns),piDpj(ns,ns)
*
* local variables:
*
integer i,j,n,ip1,ip2,ip3,is1,is2,is3,iwarn,ier1
DOUBLE PRECISION disc,hulp,s,smax,som(51),xmax
DOUBLE PRECISION t1,t2,t4,t5,t8,t3,t7,t9,t12,t14,t21,t23,t24,
+ t28,t6,t35,t44,t42,t36,t55,t41,t19,t59,t25,t69,t82,t75,t84,t92,
+ t31,t98,t74,t101,t89,t106,t112,t113,t13,t117,t126,t127,t129,
+ t130,t133,t128,t132,t134,t137,t139,t146,t148,t149,t153,t131,
+ t160,t171,t169,t161,t182,t168,t144,t186,t150,t208,t201,t210,
+ t219,t156,t225,t200,t228,t215,t233,t239,t240,t138,t244
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ set up pointers:
if ( ldel2s .and. ivert .ne. 1 ) goto 100
is1 = ivert
is2 = ivert+1
if ( is2 .eq. 4 ) is2 = 1
is3 = ivert-1
if ( is3 .eq. 0 ) is3 = 3
ip1 = is1 + 3
ip2 = is2 + 3
ip3 = is3 + 3
* #] set up pointers:
* #[ xk = 0:
if ( xpi(ip1) .eq. 0 ) then
isoort(2) = 0
if ( piDpj(is1,ip1) .eq. 0 ) then
isoort(1) = 0
return
endif
isoort(1) = 1
y(1) = etami(is2) / piDpj(is1,ip1) /2
y(2) = y(1)
y(3) = - etami(is1) / piDpj(is1,ip1) /2
y(4) = y(3)
z(1) = xpi(is2) / piDpj(is1,ip1) /2
z(2) = z(1)
z(3) = - xpi(is1) / piDpj(is1,ip1) /2
z(4) = z(3)
dyz(1,1) = - etalam / piDpj(is1,ip1) /2
dyz(1,2) = dyz(1,1)
dyz(2,1) = dyz(1,1)
dyz(2,2) = dyz(1,1)
ier1 = ier
do 10 i=1,3,2
dy2z(i) = y(i) - 2*z(i)
smax = abs(y(i))
dy2z(i+1) = dy2z(i)
10 continue
ier = ier1
return
endif
* #] xk = 0:
* #[ get y(1,2),z(1,2):
if ( sdel2s .eq. 0 ) then
isoort(1) = 2
isoort(2) = 2
z(1) = piDpj(ip1,is2)/xpi(ip1)
z(2) = z(1)
else
isoort(1) = 1
isoort(2) = 1
call ffroot(z(1),z(2),xpi(ip1),piDpj(ip1,is2),xpi(is2),
+ sdel2s,ier)
endif
disc = delps/sdel2p
call ffroot(y(1),y(2),xpi(ip1),piDpj(ip1,is2),etami(is2),disc,
+ ier)
* #] get y(1,2),z(1,2):
* #[ get y(3,4),z(3,4):
if ( isoort(1) .eq. 2 ) then
z(3) = -piDpj(ip1,is1)/xpi(ip1)
z(4) = z(3)
else
z(3) = 1-z(1)
z(4) = 1-z(2)
if ( abs(z(3)) .lt. xloss .or. abs(z(4)) .lt. xloss )
+ call ffroot(z(4),z(3),xpi(ip1),-piDpj(ip1,is1),
+ xpi(is1),sdel2s,ier)
endif
y(3) = 1-y(1)
y(4) = 1-y(2)
if ( abs(y(3)) .lt. xloss .or. abs(y(4)) .lt. xloss ) then
call ffroot(y(4),y(3),xpi(ip1),-piDpj(ip1,is1),
+ etami(is1),disc,ier)
endif
* #] get y(3,4),z(3,4):
* #[ get dyz:
* Note that dyz(i,j) only exists for i,j=1,2!
if ( isoort(1) .eq. 2 ) then
dyz(2,1) = disc/xpi(ip1)
dyz(2,2) = dyz(2,1)
elseif ( disc .gt. 0 .eqv. sdel2s .gt. 0 ) then
dyz(2,1) = ( disc + sdel2s )/xpi(ip1)
dyz(2,2) = etalam/(xpi(ip1)*dyz(2,1))
else
dyz(2,2) = ( disc - sdel2s )/xpi(ip1)
dyz(2,1) = etalam/(xpi(ip1)*dyz(2,2))
endif
dyz(1,1) = -dyz(2,2)
dyz(1,2) = -dyz(2,1)
d2yzz = 2*disc/xpi(ip1)
*
* these are very rarely needed, but ...
*
iwarn = 0
ier1 = ier
do 20 i=1,4
j = 2*((i+1)/2)
dy2z(i) = y(j) - 2*z(i)
smax = abs(y(j))
if ( abs(dy2z(i)) .lt. xloss*smax ) then
if ( i/2 .eq. 1 ) then
s = -y(j-1) - 2*sdel2s/xpi(ip1)
else
s = -y(j-1) + 2*sdel2s/xpi(ip1)
endif
if ( abs(y(j-1)) .lt. smax ) then
dy2z(i) = s
smax = abs(y(j-1))
endif
if ( abs(dy2z(i)) .lt. xloss*smax ) then
if ( iwarn .ne. 0 ) then
else
iwarn = i
xmax = smax
endif
endif
endif
20 continue
if ( iwarn .ne. 0 ) then
*
* we should import the differences, but later...
*
if ( abs(dpipj(is3,ip1)) .lt. xloss*xpi(is3)
+ .and. abs(dpipj(is1,is2)) .lt. xloss*abs(xpi(ip1))) then
*
* give it another try - multiply roots (see dy2z.frm)
*
if ( iwarn.lt.3 ) then
*prod1=
* som(1)=+160*xpi(ip1)*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2*
* + dpipj(is2,is1)**2
* som(2)=-40*xpi(ip1)*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is2)*dpipj(is2,is1)**3
* som(3)=-32*xpi(ip1)*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
* + is1)**3
* som(4)=+9*xpi(ip1)*xpi(ip2)**2*dpipj(is2,is1)**4
* som(5)=-128*xpi(ip1)*xpi(is2)*piDpj(ip1,ip2)**3*piDpj(ip2,
* + is2)*dpipj(is2,is1)
* som(6)=-128*xpi(ip1)*xpi(is2)*piDpj(ip1,ip2)**4*dpipj(is2,
* + is1)
* som(7)=+256*xpi(ip1)*xpi(is2)**2*piDpj(ip1,ip2)**4
* som(8)=-16*xpi(ip1)*piDpj(ip1,ip2)**2*piDpj(ip2,is2)**2*
* + dpipj(is2,is1)**2
* som(9)=+96*xpi(ip1)*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*dpipj(is2,
* + is1)**2
* som(10)=+128*xpi(ip1)**2*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)*piDpj(
* + ip2,is2)*dpipj(is2,is1)
* som(11)=+320*xpi(ip1)**2*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2*
* + dpipj(is2,is1)
* som(12)=-512*xpi(ip1)**2*xpi(ip2)*xpi(is2)**2*piDpj(ip1,ip2)**2
* som(13)=-120*xpi(ip1)**2*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is2)*dpipj(is2,is1)**2
* som(14)=-48*xpi(ip1)**2*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
* + is1)**2
* som(15)=+40*xpi(ip1)**2*xpi(ip2)*piDpj(ip2,is2)**2*dpipj(is2,
* + is1)**2
* som(16)=-96*xpi(ip1)**2*xpi(ip2)**2*xpi(is2)*dpipj(is2,is1)**2
* som(17)=+36*xpi(ip1)**2*xpi(ip2)**2*dpipj(is2,is1)**3
* som(18)=+128*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**2*piDpj(ip2,
* + is2)**2
* som(19)=-128*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**3*piDpj(ip2,
* + is2)
* som(20)=-64*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**4
* som(21)=-32*xpi(ip1)**2*piDpj(ip1,ip2)*piDpj(ip2,is2)**3*
* + dpipj(is2,is1)
* som(22)=-32*xpi(ip1)**2*piDpj(ip1,ip2)**2*piDpj(ip2,is2)**2*
* + dpipj(is2,is1)
* som(23)=+96*xpi(ip1)**2*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*
* + dpipj(is2,is1)
* som(24)=+128*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)*piDpj(
* + ip2,is2)
* som(25)=+160*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2
* som(26)=-128*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip2,is2)**2
* som(27)=+32*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is1)*piDpj(ip2,is2)
* som(28)=-120*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is2)*dpipj(is2,is1)
* som(29)=-32*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
* + is1)
* som(30)=-16*xpi(ip1)**3*xpi(ip2)*piDpj(ip2,is1)*piDpj(ip2,
* + is2)**2
* som(31)=+80*xpi(ip1)**3*xpi(ip2)*piDpj(ip2,is2)**2*dpipj(is2,
* + is1)
* som(32)=-192*xpi(ip1)**3*xpi(ip2)**2*xpi(is2)*dpipj(is2,is1)
* som(33)=+256*xpi(ip1)**3*xpi(ip2)**2*xpi(is2)**2
* som(34)=+54*xpi(ip1)**3*xpi(ip2)**2*dpipj(is2,is1)**2
* som(35)=-16*xpi(ip1)**3*xpi(ip3)*piDpj(ip1,ip2)*piDpj(ip2,
* + is1)*piDpj(ip2,is2)
* som(36)=+8*xpi(ip1)**3*xpi(ip3)*piDpj(ip2,is1)*piDpj(ip2,is2)**2
* som(37)=+16*xpi(ip1)**3*xpi(is2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is1)*piDpj(ip2,is2)
* som(38)=-8*xpi(ip1)**3*xpi(is2)*piDpj(ip2,is1)*piDpj(ip2,is2)**2
* som(39)=-16*xpi(ip1)**3*piDpj(ip1,ip2)*piDpj(ip2,is1)*piDpj(ip2,
* + is2)*dpipj(is3,ip1)
* som(40)=+8*xpi(ip1)**3*piDpj(ip2,is1)*piDpj(ip2,is2)**2*
* + dpipj(is3,ip1)
* som(41)=-40*xpi(ip1)**4*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,is2)
* som(42)=-8*xpi(ip1)**4*xpi(ip2)*piDpj(ip1,ip2)**2
* som(43)=+40*xpi(ip1)**4*xpi(ip2)*piDpj(ip2,is2)**2
* som(44)=-96*xpi(ip1)**4*xpi(ip2)**2*xpi(is2)
* som(45)=+36*xpi(ip1)**4*xpi(ip2)**2*dpipj(is2,is1)
* som(46)=+9*xpi(ip1)**5*xpi(ip2)**2
* som(47)=-8*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,is1)**4
* som(48)=-64*xpi(is2)*piDpj(ip1,ip2)**4*dpipj(is2,is1)**2
* som(49)=+32*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*dpipj(is2,is1)**3
* print '(7g20.12)',(som(i),i=1,49)
*
* optimized by Maple (see ffxxyz.map)
*
t1 = xpi(ip1)
t2 = xpi(ip2)
t3 = t1*t2
t4 = xpi(is2)
t5 = piDpj(ip1,ip2)
t6 = t5**2
t7 = t4*t6
t8 = dpipj(is2,is1)
t9 = t8**2
som(1) = 160*t3*t7*t9
t12 = piDpj(ip2,is2)
t13 = t5*t12
t14 = t9*t8
som(2) = -40*t3*t13*t14
som(3) = -32*t3*t6*t14
t19 = t2**2
t21 = t9**2
som(4) = 9*t1*t19*t21
t23 = t1*t4
t24 = t6*t5
t25 = t24*t12
som(5) = -128*t23*t25*t8
t28 = t6**2
som(6) = -128*t23*t28*t8
t31 = t4**2
som(7) = 256*t1*t31*t28
t35 = t12**2
t36 = t35*t9
som(8) = -16*t1*t6*t36
som(9) = 96*t1*t24*t12*t9
t41 = t1**2
t42 = t41*t2
t44 = t13*t8
som(10) = 128*t42*t4*t44
som(11) = 320*t42*t7*t8
som(12) = -512*t42*t31*t6
som(13) = -120*t42*t13*t9
som(14) = -48*t42*t6*t9
som(15) = 40*t42*t36
t55 = t41*t19
som(16) = -96*t55*t4*t9
som(17) = 36*t55*t14
t59 = t41*t4
som(18) = 128*t59*t6*t35
som(19) = -128*t59*t25
som(20) = -64*t59*t28
som(21) = -32*t41*t5*t35*t12*t8
t69 = t35*t8
som(22) = -32*t41*t6*t69
som(23) = 96*t41*t24*t12*t8
t74 = t41*t1
t75 = t74*t2
som(24) = 128*t75*t4*t5*t12
som(25) = 160*t75*t7
som(26) = -128*t75*t4*t35
t82 = piDpj(ip2,is1)
t84 = t5*t82*t12
som(27) = 32*t75*t84
som(28) = -120*t75*t44
som(29) = -32*t75*t6*t8
t89 = t82*t35
som(30) = -16*t75*t89
som(31) = 80*t75*t69
t92 = t74*t19
som(32) = -192*t92*t4*t8
som(33) = 256*t92*t31
som(34) = 54*t92*t9
t98 = t74*xpi(ip3)
som(35) = -16*t98*t84
som(36) = 8*t98*t89
t101 = t74*t4
som(37) = 16*t101*t84
som(38) = -8*t101*t89
t106 = dpipj(is3,ip1)
som(39) = -16*t74*t5*t82*t12*t106
som(40) = 8*t74*t82*t35*t106
t112 = t41**2
t113 = t112*t2
som(41) = -40*t113*t13
som(42) = -8*t113*t6
som(43) = 40*t113*t35
t117 = t112*t19
som(44) = -96*t117*t4
som(45) = 36*t117*t8
som(46) = 9*t112*t1*t19
som(47) = -8*t2*t6*t21
som(48) = -64*t4*t28*t9
som(49) = 32*t25*t14
* print '(7g20.12)',(som(i),i=1,49)
n=49
else
*prod3=
* som(1)=+160*xpi(ip1)*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2*
* + dpipj(is2,is1)**2
* som(2)=-40*xpi(ip1)*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is2)*dpipj(is2,is1)**3
* som(3)=-88*xpi(ip1)*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
* + is1)**3
* som(4)=+9*xpi(ip1)*xpi(ip2)**2*dpipj(is2,is1)**4
* som(5)=-128*xpi(ip1)*xpi(is2)*piDpj(ip1,ip2)**3*piDpj(ip2,
* + is2)*dpipj(is2,is1)
* som(6)=-256*xpi(ip1)*xpi(is2)*piDpj(ip1,ip2)**4*dpipj(is2,is1)
* som(7)=+256*xpi(ip1)*xpi(is2)**2*piDpj(ip1,ip2)**4
* som(8)=-16*xpi(ip1)*piDpj(ip1,ip2)**2*piDpj(ip2,is2)**2*dpipj(
* + is2,is1)**2
* som(9)=+64*xpi(ip1)*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*dpipj(is2,
* + is1)**2
* som(10)=+80*xpi(ip1)*piDpj(ip1,ip2)**4*dpipj(is2,is1)**2
* som(11)=+128*xpi(ip1)**2*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)*piDpj(
* + ip2,is2)*dpipj(is2,is1)
* som(12)=+576*xpi(ip1)**2*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2*
* + dpipj(is2,is1)
* som(13)=-512*xpi(ip1)**2*xpi(ip2)*xpi(is2)**2*piDpj(ip1,ip2)**2
* som(14)=-88*xpi(ip1)**2*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is2)*dpipj(is2,is1)**2
* som(15)=-192*xpi(ip1)**2*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
* + is1)**2
* som(16)=+40*xpi(ip1)**2*xpi(ip2)*piDpj(ip2,is2)**2*dpipj(is2,
* + is1)**2
* som(17)=-96*xpi(ip1)**2*xpi(ip2)**2*xpi(is2)*dpipj(is2,is1)**2
* som(18)=+60*xpi(ip1)**2*xpi(ip2)**2*dpipj(is2,is1)**3
* som(19)=+128*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**2*piDpj(ip2,
* + is2)**2
* som(20)=-128*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**3*piDpj(ip2,
* + is2)
* som(21)=-64*xpi(ip1)**2*xpi(is2)*piDpj(ip1,ip2)**4
* som(22)=-32*xpi(ip1)**2*piDpj(ip1,ip2)*piDpj(ip2,is2)**3*
* + dpipj(is2,is1)
* som(23)=+64*xpi(ip1)**2*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*
* + dpipj(is2,is1)
* som(24)=+32*xpi(ip1)**2*piDpj(ip1,ip2)**4*dpipj(is2,is1)
* som(25)=+128*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)*piDpj(
* + ip2,is2)
* som(26)=+160*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip1,ip2)**2
* som(27)=-128*xpi(ip1)**3*xpi(ip2)*xpi(is2)*piDpj(ip2,is2)**2
* som(28)=+32*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is1)*piDpj(ip2,is2)
* som(29)=-88*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is2)*dpipj(is2,is1)
* som(30)=-88*xpi(ip1)**3*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,
* + is1)
* som(31)=-16*xpi(ip1)**3*xpi(ip2)*piDpj(ip2,is1)*piDpj(ip2,
* + is2)**2
* som(32)=+48*xpi(ip1)**3*xpi(ip2)*piDpj(ip2,is2)**2*dpipj(is2,
* + is1)
* som(33)=-320*xpi(ip1)**3*xpi(ip2)**2*xpi(is2)*dpipj(is2,is1)
* som(34)=+256*xpi(ip1)**3*xpi(ip2)**2*xpi(is2)**2
* som(35)=+118*xpi(ip1)**3*xpi(ip2)**2*dpipj(is2,is1)**2
* som(36)=-16*xpi(ip1)**3*xpi(ip3)*piDpj(ip1,ip2)*piDpj(ip2,
* + is1)*piDpj(ip2,is2)
* som(37)=+8*xpi(ip1)**3*xpi(ip3)*piDpj(ip2,is1)*piDpj(ip2,is2)**2
* som(38)=+16*xpi(ip1)**3*xpi(is2)*piDpj(ip1,ip2)*piDpj(ip2,
* + is1)*piDpj(ip2,is2)
* som(39)=-8*xpi(ip1)**3*xpi(is2)*piDpj(ip2,is1)*piDpj(ip2,is2)**2
* som(40)=-16*xpi(ip1)**3*piDpj(ip1,ip2)*piDpj(ip2,is1)*piDpj(ip2,
* + is2)*dpipj(is3,ip1)
* som(41)=+8*xpi(ip1)**3*piDpj(ip2,is1)*piDpj(ip2,is2)**2*
* + dpipj(is3,ip1)
* som(42)=-40*xpi(ip1)**4*xpi(ip2)*piDpj(ip1,ip2)*piDpj(ip2,is2)
* som(43)=-8*xpi(ip1)**4*xpi(ip2)*piDpj(ip1,ip2)**2
* som(44)=+40*xpi(ip1)**4*xpi(ip2)*piDpj(ip2,is2)**2
* som(45)=-96*xpi(ip1)**4*xpi(ip2)**2*xpi(is2)
* som(46)=+60*xpi(ip1)**4*xpi(ip2)**2*dpipj(is2,is1)
* som(47)=+9*xpi(ip1)**5*xpi(ip2)**2
* som(48)=-8*xpi(ip2)*piDpj(ip1,ip2)**2*dpipj(is2,is1)**4
* som(49)=-64*xpi(is2)*piDpj(ip1,ip2)**4*dpipj(is2,is1)**2
* som(50)=+32*piDpj(ip1,ip2)**3*piDpj(ip2,is2)*dpipj(is2,is1)**3
* som(51)=+32*piDpj(ip1,ip2)**4*dpipj(is2,is1)**3
* print '(7g20.12)',(som(i),i=1,51)
*
* optimized by Maple (see ffxxyz.map)
*
t126 = xpi(ip1)
t127 = xpi(ip2)
t128 = t126*t127
t129 = xpi(is2)
t130 = piDpj(ip1,ip2)
t131 = t130**2
t132 = t129*t131
t133 = dpipj(is2,is1)
t134 = t133**2
som(1) = 160*t128*t132*t134
t137 = piDpj(ip2,is2)
t138 = t130*t137
t139 = t134*t133
som(2) = -40*t128*t138*t139
som(3) = -88*t128*t131*t139
t144 = t127**2
t146 = t134**2
som(4) = 9*t126*t144*t146
t148 = t126*t129
t149 = t131*t130
t150 = t149*t137
som(5) = -128*t148*t150*t133
t153 = t131**2
som(6) = -256*t148*t153*t133
t156 = t129**2
som(7) = 256*t126*t156*t153
t160 = t137**2
t161 = t160*t134
som(8) = -16*t126*t131*t161
som(9) = 64*t126*t149*t137*t134
som(10) = 80*t126*t153*t134
t168 = t126**2
t169 = t168*t127
t171 = t138*t133
som(11) = 128*t169*t129*t171
som(12) = 576*t169*t132*t133
som(13) = -512*t169*t156*t131
som(14) = -88*t169*t138*t134
som(15) = -192*t169*t131*t134
som(16) = 40*t169*t161
t182 = t168*t144
som(17) = -96*t182*t129*t134
som(18) = 60*t182*t139
t186 = t168*t129
som(19) = 128*t186*t131*t160
som(20) = -128*t186*t150
som(21) = -64*t186*t153
som(22) = -32*t168*t130*t160*t137*t133
som(23) = 64*t168*t149*t137*t133
som(24) = 32*t168*t153*t133
t200 = t168*t126
t201 = t200*t127
som(25) = 128*t201*t129*t130*t137
som(26) = 160*t201*t132
som(27) = -128*t201*t129*t160
t208 = piDpj(ip2,is1)
t210 = t130*t208*t137
som(28) = 32*t201*t210
som(29) = -88*t201*t171
som(30) = -88*t201*t131*t133
t215 = t208*t160
som(31) = -16*t201*t215
som(32) = 48*t201*t160*t133
t219 = t200*t144
som(33) = -320*t219*t129*t133
som(34) = 256*t219*t156
som(35) = 118*t219*t134
t225 = t200*xpi(ip3)
som(36) = -16*t225*t210
som(37) = 8*t225*t215
t228 = t200*t129
som(38) = 16*t228*t210
som(39) = -8*t228*t215
t233 = dpipj(is3,ip1)
som(40) = -16*t200*t130*t208*t137*t233
som(41) = 8*t200*t208*t160*t233
t239 = t168**2
t240 = t239*t127
som(42) = -40*t240*t138
som(43) = -8*t240*t131
som(44) = 40*t240*t160
t244 = t239*t144
som(45) = -96*t244*t129
som(46) = 60*t244*t133
som(47) = 9*t239*t126*t144
som(48) = -8*t127*t131*t146
som(49) = -64*t129*t153*t134
som(50) = 32*t150*t139
som(51) = 32*t153*t139
* print '(7g20.12)',(som(i),i=1,51)
n=51
endif
*
s = 0
smax = 0
do 30 j=1,n
s = s + som(j)
smax = max(smax,som(j))
30 continue
if ( iwarn .lt. 3 ) then
hulp = 1/(16*xpi(ip1)**3*sdel2p**4*dy2z(3-iwarn)*
+ (y(1)-2*z(1))*(y(1)-2*z(2)))
else
hulp = 1/(16*xpi(ip1)**3*sdel2p**4*dy2z(7-iwarn)*
+ (y(3)-2*z(3))*(y(3)-2*z(4)))
endif
s = s*hulp
smax = smax*hulp
if ( smax .lt. xmax ) then
dy2z(iwarn) = s
xmax = smax
endif
else
n=0
endif
endif
ier = ier1
*
goto 200
* #] get dyz:
* #[ special case, get indices:
100 continue
if ( ivert.eq.2 ) then
is1 = 2
ip1 = 5
else
is1 = 1
ip1 = 6
endif
* #] special case, get indices:
* #[ xk = 0:
if ( xpi(ip1) .eq. 0 ) then
call fferr(88,ier)
endif
* #] xk = 0:
* #[ get ypm,zpm:
*
* special case del2s = 0, hence the roots are not the real roots
* but z_2'' = (z_2'-1)/delta, z''_3 = -z'_3/delta
*
hulp = sdel2s
disc = delps/sdel2p
if ( ivert .eq. 3 ) then
hulp = -hulp
disc = -disc
endif
if ( sdel2s .eq. 0 ) then
isoort(1) = 102
isoort(2) = 102
z(1) = piDpj(is1,3)/xpi(3)
z(2) = z(1)
else
isoort(1) = 101
isoort(2) = 101
call ffroot(z(1),z(2),xpi(3),piDpj(is1,3),xpi(is1),hulp,ier)
endif
call ffroot(y(1),y(2),xpi(3),piDpj(is1,3),etami(is1),disc,ier)
* #] get ypm,zpm:
* #[ get ypm1,zpm1:
z(3) = 1 - z(1)
z(4) = 1 - z(2)
if ( abs(z(3)).lt.xloss .or. abs(z(4)).lt.xloss ) then
if ( ivert.eq.2 ) then
call ffroot(z(4),z(3),xpi(3),piDpj(ip1,3),xpi(ip1),hulp,
+ ier)
else
call ffroot(z(4),z(3),xpi(3),-piDpj(ip1,3),xpi(ip1),hulp
+ ,ier)
endif
endif
y(3) = 1 - y(1)
y(4) = 1 - y(2)
if ( abs(y(3)) .lt. xloss .or. abs(y(4)) .lt. xloss ) then
if ( ivert .eq. 2 ) then
call ffroot(y(4),y(3),xpi(3),piDpj(ip1,3),etami(ip1),
+ disc,ier)
else
call ffroot(y(4),y(3),xpi(3),-piDpj(ip1,3),etami(ip1),
+ disc,ier)
endif
endif
* #] get ypm1,zpm1:
* #[ get dypzp, dypzm:
if ( isoort(1) .eq. 2 ) then
dyz(2,1) = disc/xpi(3)
dyz(2,2) = dyz(2,1)
elseif ( disc .gt. 0 .eqv. sdel2s .gt. 0 ) then
dyz(2,1) = ( disc + hulp )/xpi(3)
dyz(2,2) = etalam/(xpi(3)*dyz(2,1))
else
dyz(2,2) = ( disc - hulp )/xpi(3)
dyz(2,1) = etalam/(xpi(3)*dyz(2,2))
endif
dyz(1,1) = -dyz(2,2)
dyz(1,2) = -dyz(2,1)
d2yzz = 2*disc/xpi(3)
*
* these are very rarely needed, but ...
*
do 220 i=1,4
j = 2*((i+1)/2)
dy2z(i) = y(j) - 2*z(i)
smax = abs(y(j))
220 continue
* #] get dypzp, dypzm:
200 continue
*###] ffxxyz:
end
*###[ ffdwz:
subroutine ffdwz(dwz,z,i1,j1,l,alpha,alph1,xpi,dpipj,piDpj,
+ sdel2i,ns,ier)
***#[*comment:***********************************************************
* *
* Recalculate dwz(i1,j1) = w(i1) - z(j1) *
* *
***#]*comment:***********************************************************
* #[ declarations:
implicit none
*
* arguments:
*
integer i1,j1,l,ns,ier
DOUBLE PRECISION dwz(2,2),z(4)
DOUBLE PRECISION alpha,alph1,xpi(ns),dpipj(ns,ns),piDpj(ns,ns),
+ sdel2i(3)
*
* local variables:
*
DOUBLE PRECISION s(8),sum,fac,xmax
integer i
*
* common blocks:
*
- include 'ff.h'
+#include "ff.h"
* #] declarations:
* #[ calculations:
if ( l .eq. 1 ) then
ier = ier + 100
elseif ( l .eq. 3 ) then
if ( (i1.eq.2 .and. j1.eq.1) .or. (i1.eq.1 .and. j1.eq.2) )
+ then
fac = 1D0/(sdel2i(2) + sdel2i(3))
s(1) = dpipj(6,5)*z(j1)
s(2) = -alph1*xpi(5)*z(j1+2)
if ( max(abs(dpipj(2,1)),abs(dpipj(5,6))) .lt.
+ max(abs(dpipj(2,6)),abs(dpipj(5,1))) ) then
s(3) = .5D0*dpipj(2,1)
s(4) = .5D0*dpipj(5,6)
else
s(3) = .5D0*dpipj(2,6)
s(4) = .5D0*dpipj(5,1)
endif
s(5) = piDpj(4,3)*piDpj(5,3)*fac
s(6) = -piDpj(4,3)*piDpj(6,3)*fac
s(7) = xpi(3)*dpipj(5,6)*fac
if ( i1 .eq. 1 ) then
sum = s(1)+s(2)+s(3)+s(4) - (s(5)+s(6)+s(7))
else
sum = s(1)+s(2)+s(3)+s(4) + s(5)+s(6)+s(7)
endif
xmax = abs(s(1))
do 10 i=2,7
xmax = max(xmax,abs(s(i)))
10 continue
if ( abs(sum) .lt. xloss*xmax ) then
* this result is not used if it is not accurate (see
* ffxc0p)
ier = ier + 1
xmax = xmax/abs(alpha*xpi(5))
dwz(i1,j1) = sum/(alpha*xpi(5))
else
dwz(i1,j1) = sum/(alpha*xpi(5))
endif
else
ier = ier + 100
endif
endif
* #] calculations:
*###] ffdwz:
end
diff --git a/Looptools/util/ini.F b/Looptools/util/ini.F
--- a/Looptools/util/ini.F
+++ b/Looptools/util/ini.F
@@ -1,348 +1,409 @@
* ini.F
* routines for initializing and setting some parameters
* this file is part of LoopTools
-* last modified 7 Dec 05 th
+* last modified 9 Dec 10 th
#include "defs.h"
subroutine clearcache
implicit none
#include "lt.h"
integer i
do i = 1, ncaches
cacheptr(1,1,i) = 0
- cacheptr(1,2,i) = 0
+ cacheptr(2,1,i) = 0
enddo
end
************************************************************************
subroutine markcache
implicit none
#include "lt.h"
integer i
do i = 1, ncaches
savedptr(1,i) = cacheptr(1,1,i)
- savedptr(2,i) = cacheptr(1,2,i)
+ savedptr(2,i) = cacheptr(2,1,i)
enddo
end
************************************************************************
subroutine restorecache
implicit none
#include "lt.h"
integer i
do i = 1, ncaches
cacheptr(1,1,i) = savedptr(1,i)
- cacheptr(1,2,i) = savedptr(2,i)
+ cacheptr(2,1,i) = savedptr(2,i)
enddo
end
************************************************************************
* Legacy function, provided for compatibility only.
* Works only approximately as before!
subroutine setcachelast(base, offset)
implicit none
double complex base(*)
integer offset
+ logical ini
+ data ini /.TRUE./
+
+ if( ini ) then
+ print *, "setcachelast is deprecated"
+ print *, "use clearcache or restorecache instead"
+ ini = .FALSE.
+ endif
+
if( offset .eq. 0 ) then
call clearcache
else
call restorecache
endif
end
************************************************************************
* Legacy function, provided for compatibility only.
* Works only approximately as before!
integer function getcachelast(base)
implicit none
double complex base(*)
+ logical ini
+ data ini /.TRUE./
+
+ if( ini ) then
+ print *, "getcachelast is deprecated"
+ print *, "use markcache instead"
+ ini = .FALSE.
+ endif
+
getcachelast = 1
call markcache
end
************************************************************************
subroutine setmudim(mudim_)
implicit none
double precision mudim_
#include "lt.h"
mudim = mudim_
call clearcache
end
************************************************************************
double precision function getmudim()
implicit none
#include "lt.h"
getmudim = mudim
end
************************************************************************
subroutine setdelta(delta_)
implicit none
double precision delta_
#include "lt.h"
delta = delta_
call clearcache
end
************************************************************************
double precision function getdelta()
implicit none
#include "lt.h"
getdelta = delta
end
************************************************************************
subroutine setlambda(lambda_)
implicit none
double precision lambda_
#include "lt.h"
lambda = lambda_
call clearcache
end
************************************************************************
double precision function getlambda()
implicit none
#include "lt.h"
getlambda = lambda
end
************************************************************************
+ subroutine setminmass(minmass_)
+ implicit none
+ double precision minmass_
+
+#include "lt.h"
+
+ minmass = minmass_
+ call clearcache
+ end
+
+************************************************************************
+
+ double precision function getminmass()
+ implicit none
+
+#include "lt.h"
+
+ getminmass = minmass
+ end
+
+************************************************************************
+
subroutine setmaxdev(maxdev_)
implicit none
double precision maxdev_
#include "lt.h"
maxdev = maxdev_
end
************************************************************************
double precision function getmaxdev()
implicit none
#include "lt.h"
getmaxdev = maxdev
end
************************************************************************
subroutine setwarndigits(warndigits_)
implicit none
integer warndigits_
#include "lt.h"
warndigits = warndigits_
end
************************************************************************
integer function getwarndigits()
implicit none
#include "lt.h"
getwarndigits = warndigits
end
************************************************************************
subroutine seterrdigits(errdigits_)
implicit none
integer errdigits_
#include "lt.h"
errdigits = errdigits_
end
************************************************************************
integer function geterrdigits()
implicit none
#include "lt.h"
geterrdigits = errdigits
end
************************************************************************
subroutine setversionkey(versionkey_)
implicit none
integer versionkey_
#include "lt.h"
versionkey = versionkey_
call clearcache
end
************************************************************************
integer function getversionkey()
implicit none
#include "lt.h"
getversionkey = versionkey
end
************************************************************************
subroutine setdebugkey(debugkey_)
implicit none
integer debugkey_
#include "lt.h"
debugkey = debugkey_
end
************************************************************************
integer function getdebugkey()
implicit none
#include "lt.h"
getdebugkey = debugkey
end
************************************************************************
subroutine setdebugrange(debugfrom_, debugto_)
implicit none
integer debugfrom_, debugto_
#include "lt.h"
debugfrom = debugfrom_
debugto = debugto_
end
************************************************************************
+ subroutine setcmpbits(cmpbits_)
+ implicit none
+ integer cmpbits_
+
+#include "lt.h"
+
+ cmpbits = cmpbits_
+ end
+
+************************************************************************
+
+ integer function getcmpbits()
+ implicit none
+
+#include "lt.h"
+
+ getcmpbits = cmpbits
+ end
+
+************************************************************************
+
* This silly subroutine is called from ffini while determining
* the working precision of the machine we're running on.
* It works around the optimizer to guarantee that we're not in
* fact determining the precision of the FPU registers.
subroutine ffset(res, x)
implicit none
DOUBLE PRECISION res, x
res = x
end
************************************************************************
block data LTNameData
implicit none
integer i
character*6 paraname(Pee,2:5)
common /ltparanames/ paraname
character*8 coeffname(Nee,2:5)
common /ltcoeffnames/ coeffname
data (paraname(i,2), i = 1, Pbb) /
& "p", "m1", "m2" /
data (paraname(i,3), i = 1, Pcc) /
& "p1", "p2", "p1p2", "m1", "m2", "m3" /
data (paraname(i,4), i = 1, Pdd) /
& "p1", "p2", "p3", "p4", "p1p2", "p2p3",
& "m1", "m2", "m3", "m4" /
data (paraname(i,5), i = 1, Pee) /
& "p1", "p2", "p3", "p4", "p5",
& "p1p2", "p2p3", "p3p4", "p4p5", "p5p1",
& "m1", "m2", "m3", "m4", "m5" /
data (coeffname(i,2), i = 1, Nbb) /
& "bb0", "bb1", "bb00", "bb11", "bb001", "bb111",
& "dbb0", "dbb1", "dbb00", "dbb11" /
data (coeffname(i,3), i = 1, Ncc) /
& "cc0", "cc1", "cc2", "cc00", "cc11", "cc12", "cc22",
& "cc001", "cc002", "cc111", "cc112", "cc122", "cc222",
& "cc0000", "cc0011", "cc0012", "cc0022", "cc1111",
& "cc1112", "cc1122", "cc1222", "cc2222" /
data (coeffname(i,4), i = 1, Ndd) /
& "dd0", "dd1", "dd2", "dd3", "dd00", "dd11", "dd12",
& "dd13", "dd22", "dd23", "dd33", "dd001", "dd002", "dd003",
& "dd111", "dd112", "dd113", "dd122", "dd123", "dd133",
& "dd222", "dd223", "dd233", "dd333", "dd0000", "dd0011",
& "dd0012", "dd0013", "dd0022", "dd0023", "dd0033", "dd1111",
& "dd1112", "dd1113", "dd1122", "dd1123", "dd1133", "dd1222",
& "dd1223", "dd1233", "dd1333", "dd2222", "dd2223", "dd2233",
& "dd2333", "dd3333", "dd00001", "dd00002", "dd00003",
& "dd00111", "dd00112", "dd00113", "dd00122", "dd00123",
& "dd00133", "dd00222", "dd00223", "dd00233", "dd00333",
& "dd11111", "dd11112", "dd11113", "dd11122", "dd11123",
& "dd11133", "dd11222", "dd11223", "dd11233", "dd11333",
& "dd12222", "dd12223", "dd12233", "dd12333", "dd13333",
& "dd22222", "dd22223", "dd22233", "dd22333", "dd23333",
& "dd33333" /
data (coeffname(i,5), i = 1, Nee) /
& "ee0", "ee1", "ee2", "ee3", "ee4", "ee00", "ee11",
& "ee12", "ee13", "ee14", "ee22", "ee23", "ee24", "ee33",
& "ee34", "ee44", "ee001", "ee002", "ee003", "ee004",
& "ee111", "ee112", "ee113", "ee114", "ee122", "ee123",
& "ee124", "ee133", "ee134", "ee144", "ee222", "ee223",
& "ee224", "ee233", "ee234", "ee244", "ee333", "ee334",
& "ee344", "ee444", "ee0000", "ee0011", "ee0012", "ee0013",
& "ee0014", "ee0022", "ee0023", "ee0024", "ee0033", "ee0034",
& "ee0044", "ee1111", "ee1112", "ee1113", "ee1114", "ee1122",
& "ee1123", "ee1124", "ee1133", "ee1134", "ee1144", "ee1222",
& "ee1223", "ee1224", "ee1233", "ee1234", "ee1244", "ee1333",
& "ee1334", "ee1344", "ee1444", "ee2222", "ee2223", "ee2224",
& "ee2233", "ee2234", "ee2244", "ee2333", "ee2334", "ee2344",
& "ee2444", "ee3333", "ee3334", "ee3344", "ee3444", "ee4444" /
end
diff --git a/Looptools/util/solve-Eigen.F b/Looptools/util/solve-Eigen.F
new file mode 100644
--- /dev/null
+++ b/Looptools/util/solve-Eigen.F
@@ -0,0 +1,287 @@
+* solve-Eigen.F
+* computation of the inverse and solution of a linear system
+* by diagonalizing the matrix with the Jacobi algorithm
+* code adapted from the "Handbook" routines for complex A
+* (Wilkinson, Reinsch: Handbook for Automatic Computation, p. 202)
+* this file is part of LoopTools
+* last modified 9 Dec 10 th
+
+#include "defs.h"
+
+
+* A matrix is considered diagonal if the sum of the squares
+* of the off-diagonal elements is less than EPS.
+
+#define EPS 2D0**(-102)
+
+
+************************************************************************
+** XEigen diagonalizes a complex symmetric n-by-n matrix.
+** Input: n, A = n-by-n matrix
+** (only the upper triangle of A needs to be filled).
+** Output: d = vector of eigenvalues, U = transformation matrix
+** these fulfill diag(d) = U A U^T = U A U^-1 with U U^T = 1.
+
+ subroutine XEigen(n, A,ldA, d, U,ldU)
+ implicit none
+ integer n, ldA, ldU
+ QVAR A(ldA,*), U(ldU,*), d(*)
+
+ integer p, q, j, sweep
+ QREAL red, off, thresh
+ QVAR delta, t, invc, s, x, y
+ QVAR ev(2,MAXDIM)
+
+ QREAL sq
+ QVAR c
+ sq(c) = QRE(c*QCC(c))
+
+ do p = 1, n
+ ev(1,p) = 0
+ ev(2,p) = A(p,p)
+ d(p) = ev(2,p)
+ enddo
+
+ do p = 1, n
+ do q = 1, n
+ U(q,p) = 0
+ enddo
+ U(p,p) = 1
+ enddo
+
+ red = .04D0/n**4
+
+ do sweep = 1, 50
+ off = 0
+ do q = 2, n
+ do p = 1, q - 1
+ off = off + sq(A(p,q))
+ enddo
+ enddo
+ if( .not. off .gt. EPS ) return
+
+ thresh = 0
+ if( sweep .lt. 4 ) thresh = off*red
+
+ do q = 2, n
+ do p = 1, q - 1
+ delta = A(p,q)
+ off = sq(delta)
+ if( sweep .gt. 4 .and. off .lt.
+ & EPS*max(sq(ev(2,p)), sq(ev(2,q))) ) then
+ A(p,q) = 0
+ else if( off .gt. thresh ) then
+ x = .5D0*(ev(2,p) - ev(2,q))
+ y = sqrt(x**2 + delta**2)
+ t = x - y
+ s = x + y
+ if( sq(t) .lt. sq(s) ) t = s
+
+ t = delta/t
+ delta = delta*t
+ ev(1,p) = ev(1,p) + delta
+ ev(2,p) = d(p) + ev(1,p)
+ ev(1,q) = ev(1,q) - delta
+ ev(2,q) = d(q) + ev(1,q)
+
+ invc = sqrt(t**2 + 1)
+ s = t/invc
+ t = t/(invc + 1)
+
+ do j = 1, p - 1
+ x = A(j,p)
+ y = A(j,q)
+ A(j,p) = x + s*(y - t*x)
+ A(j,q) = y - s*(x + t*y)
+ enddo
+
+ do j = p + 1, q - 1
+ x = A(p,j)
+ y = A(j,q)
+ A(p,j) = x + s*(y - t*x)
+ A(j,q) = y - s*(x + t*y)
+ enddo
+
+ do j = q + 1, n
+ x = A(p,j)
+ y = A(q,j)
+ A(p,j) = x + s*(y - t*x)
+ A(q,j) = y - s*(x + t*y)
+ enddo
+
+ A(p,q) = 0
+
+ do j = 1, n
+ x = U(p,j)
+ y = U(q,j)
+ U(p,j) = x + s*(y - t*x)
+ U(q,j) = y - s*(x + t*y)
+ enddo
+ endif
+ enddo
+ enddo
+
+ do p = 1, n
+ ev(1,p) = 0
+ d(p) = ev(2,p)
+ enddo
+ enddo
+
+ print *, "Bad convergence in XEigen"
+ end
+
+************************************************************************
+
+ subroutine XDet(n, A,ldA, det)
+ implicit none
+ integer n, ldA
+ QVAR A(ldA,*), det
+
+ QVAR d(MAXDIM), U(MAXDIM,MAXDIM)
+ integer p
+
+ call XEigen(n, A,ldA, d, U,MAXDIM)
+
+ det = 1
+ do p = 1, n
+ det = det*d(p)
+ enddo
+ end
+
+************************************************************************
+** XInverse forms the (pseudo)inverse of a symmetric n-by-n matrix.
+** Input: n, A = n-by-n matrix, symmetric
+** (only the upper triangle of A needs to be filled).
+** Output: Ainv = (pseudo)inverse of A
+
+ subroutine XInverse(n, A,ldA, Ainv,ldAinv)
+ implicit none
+ integer n, ldA, ldAinv
+ QVAR A(ldA,*), Ainv(ldAinv,*)
+
+ integer p, q, j
+ QVAR U(MAXDIM,MAXDIM), d(MAXDIM), t
+
+#if 0
+ PRINT *, "SEigen"
+ PRINT *, "A11=", A(1,1)
+ PRINT *, "A12=", A(1,2)
+ PRINT *, "A21=", A(2,1)
+ PRINT *, "A22=", A(2,2)
+ if( ldA .gt. 2 ) then
+ PRINT *, "A13=", A(1,3), A(3,1)
+ PRINT *, "A23=", A(2,3), A(3,2)
+ PRINT *, "A33=", A(3,3)
+ endif
+ PRINT *, "-----------"
+#endif
+
+ call XEigen(n, A,ldA, d, U,MAXDIM)
+
+* form (pseudo)inverse U^T d^-1 U
+
+ do p = 1, n
+ do q = 1, n
+ t = 0
+ do j = 1, n
+ if( abs(d(j)) .gt. EPS )
+ & t = t + U(j,q)*U(j,p)/d(j)
+ enddo
+ Ainv(q,p) = t
+ enddo
+ enddo
+
+#if 0
+ PRINT *, "d1=", d(1)
+ PRINT *, "d2=", d(2)
+ if( ldA .gt. 2 ) PRINT *, "d3=", d(3)
+ PRINT *, "-----------"
+
+ PRINT *, "U11=", U(1,1)
+ PRINT *, "U12=", U(1,2)
+ PRINT *, "U21=", U(2,1)
+ PRINT *, "U22=", U(2,2)
+ if( ldA .gt. 2 ) then
+ PRINT *, "U13=", U(1,3)
+ PRINT *, "U23=", U(2,3)
+ PRINT *, "U31=", U(3,1)
+ PRINT *, "U32=", U(3,2)
+ PRINT *, "U33=", U(3,3)
+ endif
+ PRINT *, "-----------"
+
+ PRINT *, "Ai11=", Ainv(1,1)
+ PRINT *, "Ai12=", Ainv(1,2)
+ PRINT *, "Ai21=", Ainv(2,1)
+ PRINT *, "Ai22=", Ainv(2,2)
+ if( ldA .gt. 2 ) then
+ PRINT *, "Ai13=", Ainv(1,3)
+ PRINT *, "Ai23=", Ainv(2,3)
+ PRINT *, "Ai31=", Ainv(3,1)
+ PRINT *, "Ai32=", Ainv(3,2)
+ PRINT *, "Ai33=", Ainv(3,3)
+ endif
+ PRINT *, "-----------"
+#endif
+ end
+
+************************************************************************
+
+ subroutine XSolve(n, A,ldA, Ainv,ldAinv, b)
+ implicit none
+ integer n, ldA, ldAinv
+ QVAR A(ldA,*), Ainv(ldAinv,*)
+ double complex b(*)
+
+ integer i, j
+ double complex x(MAXDIM)
+
+#if defined(QUAD) && !defined(COMPLEXPARA)
+
+ QVAR tr, ti
+
+ do i = 1, n
+ tr = 0
+ ti = 0
+ do j = 1, n
+ tr = tr + Ainv(i,j)*DBLE(b(j))
+ ti = ti + Ainv(i,j)*DIMAG(b(j))
+ enddo
+ x(i) = DCMPLX(tr, ti)
+ enddo
+
+#else
+
+ double complex delta(MAXDIM), t
+
+ do i = 1, n
+ t = 0
+ do j = 1, n
+ t = t + Ainv(i,j)*b(j)
+ enddo
+ x(i) = t
+ enddo
+
+* improve on x
+ do i = 1, n
+ t = 0
+ do j = 1, n
+ t = t + A(i,j)*x(j)
+ enddo
+ delta(i) = b(i) - t
+ enddo
+ do i = 1, n
+ t = 0
+ do j = 1, n
+ t = t + Ainv(i,j)*delta(j)
+ enddo
+ x(i) = x(i) + t
+ enddo
+
+#endif
+
+ do i = 1, n
+ b(i) = x(i)
+ enddo
+ end
+
diff --git a/Looptools/util/solve-LU.F b/Looptools/util/solve-LU.F
new file mode 100644
--- /dev/null
+++ b/Looptools/util/solve-LU.F
@@ -0,0 +1,238 @@
+* solve-LU.F
+* Solution of the linear system A.x = B by LU decomposition
+* with partial pivoting
+* this file is part of LoopTools
+* last modified 14 Dec 10 th
+
+* Author: Michael Rauch, 7 Dec 2004
+* Reference: Folkmar Bornemann, lecture notes to
+* Numerische Mathematik 1, Technical University, Munich, Germany
+
+#include "defs.h"
+
+#define EPS 2D0**(-51)
+
+
+************************************************************************
+* XDecomp computes the LU decomposition of the n-by-n matrix A
+* by Gaussian Elimination with partial pivoting;
+* compact (in situ) storage scheme
+* Input:
+* A: n-by-n matrix to LU-decompose
+* n: dimension of A
+* Output:
+* A: mangled LU decomposition of A in the form
+* ( y11 y12 ... y1n )
+* ( x21 y22 ... y2n )
+* ( x31 x32 ... y3n )
+* ( ............... )
+* ( xn1 xn2 ... ynn )
+* where
+* ( 1 0 ... 0 ) ( y11 y12 ... y1n )
+* ( x21 1 ... 0 ) ( 0 y22 ... y2n )
+* ( x31 x32 ... 0 ) ( 0 0 ... y3n ) = Permutation(A)
+* ( ............... ) ( ............... )
+* ( xn1 xn2 ... 1 ) ( 0 0 ... ynn )
+* perm: permutation vector
+
+ subroutine XDecomp(n, A,ldA, perm)
+ implicit none
+ integer n, ldA, perm(*)
+ QVAR A(ldA,*)
+
+ integer i, j, k, pj, invperm(MAXDIM)
+ QVAR tmp
+ QREAL absA, pabsA
+
+ do j = 1, n
+ invperm(j) = j
+ enddo
+
+ do j = 1, n
+* do U part (minus diagonal one)
+ do i = 2, j - 1
+ tmp = 0
+ do k = 1, i - 1
+ tmp = tmp + A(i,k)*A(k,j)
+ enddo
+ A(i,j) = A(i,j) - tmp
+ enddo
+
+* do L part (plus diagonal from U case)
+ pabsA = -1
+ do i = j, n
+ tmp = 0
+ do k = 1, j - 1
+ tmp = tmp + A(i,k)*A(k,j)
+ enddo
+ A(i,j) = A(i,j) - tmp
+
+* do partial pivoting ...
+* find the pivot
+ absA = abs(A(i,j))
+ if( absA .gt. pabsA ) then
+ pabsA = absA
+ pj = i
+ endif
+ enddo
+
+ perm(invperm(pj)) = j
+
+* exchange rows
+ if( pj .ne. j ) then
+ invperm(pj) = invperm(j)
+ do k = 1, n
+ tmp = A(j,k)
+ A(j,k) = A(pj,k)
+ A(pj,k) = tmp
+ enddo
+ endif
+
+* division by the pivot element
+ if( abs(A(j,j)) .gt. EPS ) then
+ tmp = 1/A(j,j)
+ do i = j + 1, n
+ A(i,j) = A(i,j)*tmp
+ enddo
+ endif
+ enddo
+ end
+
+************************************************************************
+* XSolve computes the x in A.x = b from the LU-decomposed A.
+* Input:
+* A: LU-decomposed n-by-n matrix A
+* b: input vector b in A.x = b
+* n: dimension of A
+* p: permutation vector from LU decomposition
+* Output:
+* b: solution vector x in A.x = b
+
+ subroutine XSolve(n, A,ldA, b)
+ implicit none
+ integer n, ldA
+ QVAR A(ldA,*)
+ double complex b(*)
+
+ integer i, j
+ double complex tmp
+
+* forward substitution L.y = b
+ do i = 1, n
+ tmp = 0
+ do j = 1, i - 1
+ tmp = tmp + A(i,j)*b(j)
+ enddo
+ b(i) = b(i) - tmp
+ enddo
+
+* backward substitution U.x = y
+ do i = n, 1, -1
+ tmp = 0
+ do j = i + 1, n
+ tmp = tmp + A(i,j)*b(j)
+ enddo
+ b(i) = (b(i) - tmp)/A(i,i)
+ enddo
+ end
+
+************************************************************************
+
+#ifdef COMPLEXPARA
+
+#undef RSolve
+#define RSolve XSolve
+
+#else
+
+* same as XSolve but for real vector b
+
+ subroutine RSolve(n, A,ldA, b)
+ implicit none
+ integer n, ldA
+ QVAR A(ldA,*), b(*)
+
+ integer i, j
+ QVAR tmp
+
+* forward substitution L.y = b
+ do i = 1, n
+ tmp = 0
+ do j = 1, i - 1
+ tmp = tmp + A(i,j)*b(j)
+ enddo
+ b(i) = b(i) - tmp
+ enddo
+
+* backward substitution U.x = y
+ do i = n, 1, -1
+ tmp = 0
+ do j = i + 1, n
+ tmp = tmp + A(i,j)*b(j)
+ enddo
+ b(i) = (b(i) - tmp)/A(i,i)
+ enddo
+ end
+
+#endif
+
+************************************************************************
+* Det computes the determinant of a matrix.
+* Input:
+* A: n-by-n matrix A
+* n: dimension of A
+* Output:
+* determinant of A
+* Warning: A is overwritten
+
+ subroutine XDet(n, A,ldA, det)
+ implicit none
+ integer n, ldA
+ QVAR A(ldA,*), det
+
+ integer i, j, s, perm(MAXDIM)
+
+ call XDecomp(n, A,ldA, perm)
+ det = 1
+ s = 0
+ do i = 1, n
+ det = det*A(i,i)
+ j = i
+ do while( perm(j) .ne. i )
+ j = j + 1
+ enddo
+ if( j .ne. i ) then
+ perm(j) = perm(i)
+ s = s + 1
+ endif
+ enddo
+ if( iand(s, 1) .ne. 0 ) det = -det
+ end
+
+************************************************************************
+* Inverse computes the inverse of a matrix.
+* Input:
+* A: n-by-n matrix A
+* n: dimension of A
+* Output:
+* A: mangled LU decomposition of A
+* Ainv: inverse of A
+* perm: permutation vector
+
+ subroutine XInverse(n, A,ldA, Ainv,ldAinv, perm)
+ implicit none
+ integer n, ldA, ldAinv, perm(*)
+ QVAR A(ldA,*), Ainv(ldAinv,*)
+
+ integer i, j
+
+ call XDecomp(n, A,ldA, perm)
+ do i = 1, n
+ do j = 1, n
+ Ainv(j,i) = 0
+ enddo
+ Ainv(perm(i),i) = 1
+ call RSolve(n, A,ldA, Ainv(1,i))
+ enddo
+ end
+
diff --git a/Looptools/util/solve-LU.h b/Looptools/util/solve-LU.h
new file mode 100644
--- /dev/null
+++ b/Looptools/util/solve-LU.h
@@ -0,0 +1,20 @@
+ QVAR G(DIM,DIM), Gnorm(DIM)
+ integer perm(DIM)
+
+#define XSetup(G) XLUDecompose(n, G,DIM, Gnorm, perm)
+#define IN(i) in(perm(i))
+
+
+
+
+
+ QVAR G(DIM,DIM), Ginv(DIM,DIM)
+
+#define XSetup(G) XLUDecompose(n, G,DIM, Ginv,DIM)
+#define IN(i) in(i)
+
+
+
+
+sign of permutation?
+
diff --git a/Looptools/util/solve.F b/Looptools/util/solve.F
new file mode 100644
--- /dev/null
+++ b/Looptools/util/solve.F
@@ -0,0 +1,6 @@
+#ifdef SOLVE_EIGEN
+#include "solve-Eigen.F"
+#else
+#include "solve-LU.F"
+#endif
+
diff --git a/Models/General/VVSLoopVertex.cc b/Models/General/VVSLoopVertex.cc
--- a/Models/General/VVSLoopVertex.cc
+++ b/Models/General/VVSLoopVertex.cc
@@ -1,246 +1,246 @@
// -*- C++ -*-
//
// This is the implementation of the non-inlined, non-templated member
// functions of the VVSLoopVertex class.
//
#include "VVSLoopVertex.h"
#include "ThePEG/Interface/ClassDocumentation.h"
#include "ThePEG/Persistency/PersistentOStream.h"
#include "ThePEG/Persistency/PersistentIStream.h"
#include "Herwig++/Looptools/clooptools.h"
using namespace Herwig;
using namespace ThePEG;
-using namespace Looptools;
+namespace LT = Looptools;
IBPtr VVSLoopVertex::clone() const {
return new_ptr(*this);
}
IBPtr VVSLoopVertex::fullclone() const {
return new_ptr(*this);
}
void VVSLoopVertex::persistentOutput(PersistentOStream & os) const {
os << ounit(masses,GeV) << type << couplings << theNpart;
}
void VVSLoopVertex::persistentInput(PersistentIStream & is, int) {
is >> iunit(masses,GeV) >> type >> couplings >> theNpart;
}
void VVSLoopVertex::doinit() {
// ffini needed here for BSM initialization code!
- Looptools::ffini();
+ Looptools::ltini();
GeneralVVSVertex::doinit();
}
void VVSLoopVertex::dofinish() {
- Looptools::ffexi();
+ Looptools::ltexi();
GeneralVVSVertex::dofinish();
}
void VVSLoopVertex::doinitrun() {
- Looptools::ffini();
+ Looptools::ltini();
GeneralVVSVertex::doinitrun();
}
ClassDescription<VVSLoopVertex> VVSLoopVertex::initVVSLoopVertex;
// Definition of the static class description member.
void VVSLoopVertex::Init() {
static ClassDocumentation<VVSLoopVertex> documentation
("The VVSLoopVertex class calculates the tensor integral"
" coefficients using Looptools.");
}
void VVSLoopVertex::setCoupling(Energy2, tcPDPtr, tcPDPtr,tcPDPtr) {
//Kinematic invariants
double ps2 = invariant(0,0) / MeV2;
double pv1s = invariant(1,1) / MeV2;
double pv2s = invariant(2,2) / MeV2;
Complex a(0.),b(0.),c(0.),d(0.),e(0.),f(0.);
for(unsigned int i = 0; i< theNpart;++i) {
double lmass = masses[i] / MeV;
double mls = sqr(lmass);
Complex lc = couplings[i].first;
if(type[i] == PDT::Spin1Half) {
- Complex C0 = C0i(cc0,pv1s,pv2s,ps2,mls,mls,mls);
- long theC = Cget(ps2,pv2s,pv1s, mls,mls,mls);
- Complex C1 = Cval(cc1,theC);
- Complex C2 = Cval(cc2,theC);
- Complex C00 = Cval(cc00,theC);
- Complex C11 = Cval(cc11,theC);
- Complex C12 = Cval(cc12,theC);
- Complex C22 = Cval(cc22,theC);
+ Complex C0 = LT::C0i(LT::cc0,pv1s,pv2s,ps2,mls,mls,mls);
+ long theC = LT::Cget(ps2,pv2s,pv1s, mls,mls,mls);
+ Complex C1 = LT::Cval(LT::cc1,theC);
+ Complex C2 = LT::Cval(LT::cc2,theC);
+ Complex C00 = LT::Cval(LT::cc00,theC);
+ Complex C11 = LT::Cval(LT::cc11,theC);
+ Complex C12 = LT::Cval(LT::cc12,theC);
+ Complex C22 = LT::Cval(LT::cc22,theC);
Complex lpr = lc + couplings[i].second;
- a += 4.*lpr*lmass*(-2.*B0(ps2,mls,mls)+ C0*(pv1s + pv2s - ps2) + 8.*C00)/ps2;
+ a += 4.*lpr*lmass*(-2.*LT::B0(ps2,mls,mls)+ C0*(pv1s + pv2s - ps2) + 8.*C00)/ps2;
b += 8.*lpr*lmass*(C0 + 3.*C1 +3.*C2 + 2.*(C11 + 2.*C12 + C22));
c += 4.*lpr*lmass*(C0 +2.*(2.*C1+C2 + 2.*(C11 +C12)));
d += 4.*lpr*lmass*(C0 + 4.*(C1+C11+C12));
e += 8.*lpr*lmass*(C1 + 2.*C11);
f += 4.*(lc - couplings[i].second)*lmass*C0;
}
else if(type[i] == PDT::Spin1) {
- long theC = Cget(ps2,pv2s,pv1s,mls,mls,mls);
- Complex C1 = Cval(cc1,theC);Complex C2 = Cval(cc2,theC);
- Complex C00 = Cval(cc00,theC);Complex C11 = Cval(cc11,theC);
- Complex C12 = Cval(cc12,theC);
- Complex C22 = Cval(cc22,theC);
+ long theC = LT::Cget(ps2,pv2s,pv1s,mls,mls,mls);
+ Complex C1 = LT::Cval(LT::cc1,theC);Complex C2 = LT::Cval(LT::cc2,theC);
+ Complex C00 = LT::Cval(LT::cc00,theC);Complex C11 = LT::Cval(LT::cc11,theC);
+ Complex C12 = LT::Cval(LT::cc12,theC);
+ Complex C22 = LT::Cval(LT::cc22,theC);
/**
* vector type can contain different types of particle
* and hence the coupling is different
* Here left is used for the coupling of the ith
* type rather than creating another
* vector to hold them.
*/
double pv12 = pv1s*pv2s;
Complex
- C0A(C0(pv1s,pv2s,ps2,mls,mls,mls)),A0A(A0(mls)),
- B0A(B0(ps2 ,mls,mls)),
- B1A(B1(ps2 ,mls,mls)),B11A(B11(ps2 ,mls,mls)),
- B0B(B0(pv1s,mls,mls)),B00B(B00(pv1s,mls,mls)),
- B1B(B1(pv1s,mls,mls)),B11B(B11(pv1s,mls,mls)),
- B0C(B0(pv2s,mls,mls)),B00C(B00(pv2s,mls,mls)),
- B1C(B1(pv2s,mls,mls)),B11C(B11(pv2s,mls,mls));
+ C0A(LT::C0(pv1s,pv2s,ps2,mls,mls,mls)),A0A(LT::A0(mls)),
+ B0A(LT::B0(ps2 ,mls,mls)),
+ B1A(LT::B1(ps2 ,mls,mls)),B11A(LT::B11(ps2 ,mls,mls)),
+ B0B(LT::B0(pv1s,mls,mls)),B00B(LT::B00(pv1s,mls,mls)),
+ B1B(LT::B1(pv1s,mls,mls)),B11B(LT::B11(pv1s,mls,mls)),
+ B0C(LT::B0(pv2s,mls,mls)),B00C(LT::B00(pv2s,mls,mls)),
+ B1C(LT::B1(pv2s,mls,mls)),B11C(LT::B11(pv2s,mls,mls));
double mls2(mls*mls),mls3(mls2*mls);
// coefficient
a +=
0.5*lc*(B0A*(2.*mls2*(-6.*mls + pv1s + pv2s)
+ mls*(-2.*mls + pv1s + pv2s)*ps2)
+ 2.*(8.*mls3*C0A*pv1s - 2.*mls2*C0A*(pv1s*pv1s)
+ 2.*mls*B00B*pv2s + 8.*mls3*C0A*pv2s
+ mls*B0B*pv12 + mls*B0C*pv12 - B00B*pv12
- 2.*mls2*C0A*(pv2s*pv2s)
+ B00C*pv1s*(2.*mls - pv2s)
- mls*A0A*(pv1s + pv2s) - 8.*mls3*C0A*ps2
+ 2.*mls2*C0A*pv1s*ps2 + 2.*mls2*C0A*pv2s*ps2
- mls*C0A*pv12*ps2
+ (24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C00 ) )/mls3*2./ps2;
b += -0.25*lc*
( 8.*mls*B0C*pv2s - 4.*B11B*(2.*mls - pv1s)*pv2s
+ 2.*B1B*(2.*mls - pv1s)*(4.*mls - 3.*pv2s) + 4.*B00C*(2.*mls - pv2s)
- 2.*A0A*(2.*mls + pv2s) + 2.*B0B*(4.*mls2 - 2.*mls*pv1s + pv12)
- 2.*mls*B0A*(pv2s - ps2) - 4.*mls*B11A*(2.*mls + ps2)
+ B1A*(2.*mls - pv2s)*(2.*mls + ps2)
- B1A*(6.*mls - pv2s)*(2.*mls + ps2)
- B0A*(8.*mls2 + (2.*mls - pv2s)*ps2)
- 2.*C0A*(2.*mls*(12.*mls2 + pv2s*(pv1s + pv2s) - 2.*mls*(pv1s + 3.*pv2s))
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)
+ 4.*mls*(2.*mls*B0A + (B1A + B11A)*(2.*mls + ps2))
- 2.*(2.*mls*(36.*mls2 + 2.*pv12 + (pv2s*pv2s) - 6.*mls*(pv1s + pv2s))
+ (12.*mls2 + 3.*pv12 - 2.*mls*(3.*pv1s + 4.*pv2s))*ps2)*C1
- 2.*(2.*mls*(36.*mls2 + 2.*pv12 + (pv2s*pv2s) - 6.*mls*(pv1s + pv2s))
+ (12.*mls2 + 3.*pv12 - 2.*mls*(3.*pv1s + 4.*pv2s))*ps2)*C2
- 4.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C11
- 8.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C12
- 4.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C22 )/mls3;
c+= -lc*
(-12.*mls2 + 8.*mls*pv1s - (pv1s*pv1s) + 48.*B00B*(2.*mls - pv1s)
+ 24.*B00C*(2.*mls - pv2s) - 6.*A0A*(6.*mls + pv1s - 2.*ps2)
- 6.*B1B*(2.*mls - pv1s)*(2.*mls - pv1s + 3.*pv2s - ps2)
- 24.*mls*B11A*(2.*mls + ps2)
- 3.*B1A*(4.*mls - pv1s + pv2s - ps2)*(2.*mls + ps2)
- 3.*B1A*(2.*mls + ps2)*(4.*mls + pv1s - pv2s + ps2)
+ 6.*B1C*(2.*mls - pv2s)*(-3.*pv1s + pv2s + ps2)
+ 12.*B11C*(2.*mls - pv2s)*(-pv1s + pv2s + ps2)
+ 6.*B11B*(2.*mls - pv1s)*(3.*pv1s - 2.*pv2s + 2.*ps2)
+ 6.*B0C*(2.*mls*pv1s + (4.*mls + pv1s)*pv2s - 4.*mls*ps2)
- 6.*B0B*(2.*mls2 - 5.*mls*pv1s - (2.*mls + pv1s)*pv2s
+ 4.*mls*ps2)
- 3.*B0A*(2.*mls*(4.*mls + pv1s + 2.*pv2s) - (4.*mls + pv1s)*ps2)
- 3.*B0A*(2.*mls*(4.*mls + 2.*pv1s + pv2s) - (2.*mls + pv2s)*ps2
+ (ps2*ps2))
- 6.*C0A*(2.*mls*(12.*mls2 - (pv1s*pv1s) + pv12 + (pv2s*pv2s)
- 6.*mls*(pv1s + pv2s))
+ (12.*mls2 + pv12 + 2.*mls*(pv1s - pv2s))*ps2 - 2.*mls*(ps2*ps2))
+ 24.*mls*(2.*mls*B0A + (B1A + B11A)*(2.*mls + ps2))
- 24.*(mls*(24.*mls2 - (pv1s*pv1s) + 2.*pv12 + (pv2s*pv2s)
- 4.*mls*(pv1s + pv2s))
+ (4.*mls2 + pv12 - mls*(pv1s + 3.*pv2s))*ps2)*C1
- 12.*(24.*mls3 - 2.*mls*(pv1s*pv1s) - 4.*mls2*(pv1s + pv2s)
+ (4.*mls2 - 2.*mls*pv2s + pv12)*ps2)*C2
- 24.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+(2.*mls - pv1s)*(2.*mls - pv2s)*ps2)* C11
- 24.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C12
+ 72.*(2.*mls - pv1s)*(-0.125*mls - 0.125*A0A + (0.25*mls*B1B)
+ (0.125*pv1s*B11B))
- 12.*(-2.*mls + pv1s)*(0.25*mls - 0.25*A0A - (0.5*mls*B1B)
- (0.75*pv1s*B11B)) )/24./mls3;
d+= -lc*
(-2.*mls2*B0A - 2.*mls*C0A*(8.*mls2 + pv12 - 2.*mls*(pv1s + pv2s))
- mls*B1A*(2.*mls + ps2) - mls*B11A*(2.*mls + ps2)
+ mls*(2.*mls*B0A + (B1A + B11A)*(2.*mls + ps2))
- (24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)* C1 - 2.*mls*pv12*C2
- (24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C11
- (24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+(2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C12 )/mls3;
e+= -0.25*lc*
(8.*mls*B0B*pv1s + 4.*B00B*(2*mls - pv1s) - 2.*A0A*(2.*mls + pv1s)
- 4.*B11C*pv1s*(2.*mls - pv2s) + 2.*B1C*(4.*mls - 3.*pv1s)*(2.*mls - pv2s)
+ 2.*B0C*(4.*mls2 - 2.*mls*pv2s + pv12) - 2.*mls*B0A*(pv1s - ps2)
+ 4.*mls*C0A*pv1s*(4.*mls - pv2s - ps2) - 4.*mls*B11A*(2.*mls + ps2)
+ B1A*(2.*mls - pv1s)*(2.*mls + ps2) - B1A*(6.*mls - pv1s)*(2.*mls + ps2)
- B0A*(8.*mls2 + (2.*mls - pv1s)*ps2)
+ 4.*mls*(2.*mls*B0A + (B1A + B11A)*(2.*mls + ps2))
- 2*(2.*mls*(12.*mls2 - pv1s + 2.*pv12 - 2.*mls*(pv1s + pv2s))
+ (4.*mls2 - 2.*mls*pv2s + pv12)*ps2)*C1
- 4.*(24.*mls3 + 2.*mls*pv12 - 4.*mls2*(pv1s + pv2s)
+ (2.*mls - pv1s)*(2.*mls - pv2s)*ps2)*C11 )/mls3;
}
else if(type[i] == PDT::Spin0) {
- long theC = Cget(ps2,pv2s,pv1s,
+ long theC = LT::Cget(ps2,pv2s,pv1s,
mls,mls,mls);
- Complex C1 = Cval(cc1,theC);
- Complex C2 = Cval(cc2,theC);
- Complex C00 = Cval(cc00,theC);
- Complex C11 = Cval(cc11,theC);
- Complex C12 = Cval(cc12,theC);
- Complex C22 = Cval(cc22,theC);
- Complex Cz = C0(pv1s,pv2s,ps2,mls,mls,mls);
+ Complex C1 = LT::Cval(LT::cc1,theC);
+ Complex C2 = LT::Cval(LT::cc2,theC);
+ Complex C00 = LT::Cval(LT::cc00,theC);
+ Complex C11 = LT::Cval(LT::cc11,theC);
+ Complex C12 = LT::Cval(LT::cc12,theC);
+ Complex C22 = LT::Cval(LT::cc22,theC);
+ Complex Cz = LT::C0(pv1s,pv2s,ps2,mls,mls,mls);
/**
* vector type can contain different types of particle
* and hence the coupling is different
* Here left[i] is used for the coupling of the ith
* type rather than creating another
* vector to hold them.
*/
- a += 4.*lc*(B0(ps2,mls,mls) - 4.*C00)/ps2;
+ a += 4.*lc*(LT::B0(ps2,mls,mls) - 4.*C00)/ps2;
b += -4.*lc*(Cz + 3.*C1 + 3.*C2 +2.*(C11 + 2.*C12 + C22 ));
c += -2.*lc*(Cz + 2.*(2.*C1+ C2 + 2.*(C11 +C12)));
d += -8.*lc*(C1 +C11 + C12);
e += -4.*lc*(C1 + 2.*C11);
}
else {
throw Helicity::HelicityConsistencyError()
<< "SVVLoopVertex::setCoupling - Incorrect particle in SVV loop. "
<< "Spin: " << type[i]
<< Exception::warning;
}
}
//Looptools defines integrals differently
double fact = 1./16./sqr(Constants::pi);
a00(fact*a);
a11(fact*b);
a12(fact*c);
a21(fact*d);
a22(fact*e);
aEp(fact*f);
}
diff --git a/Models/StandardModel/SMHGGVertex.cc b/Models/StandardModel/SMHGGVertex.cc
--- a/Models/StandardModel/SMHGGVertex.cc
+++ b/Models/StandardModel/SMHGGVertex.cc
@@ -1,219 +1,220 @@
// -*- C++ -*-
//
// SMHGGVertex.cc is a part of Herwig++ - A multi-purpose Monte Carlo event generator
// Copyright (C) 2002-2007 The Herwig Collaboration
//
// Herwig++ is licenced under version 2 of the GPL, see COPYING for details.
// Please respect the MCnet academic guidelines, see GUIDELINES for details.
//
//
// This is the implementation of the non-inlined, non-templated member
// functions of the SMHGGVertex class.
//
#include "SMHGGVertex.h"
#include "ThePEG/Interface/ClassDocumentation.h"
#include "ThePEG/Interface/Parameter.h"
#include "ThePEG/Interface/Switch.h"
#include "ThePEG/Persistency/PersistentOStream.h"
#include "ThePEG/Persistency/PersistentIStream.h"
#include "Herwig++/Looptools/clooptools.h"
using namespace Herwig;
using namespace ThePEG;
SMHGGVertex::SMHGGVertex()
:_couplast(0.),_q2last(ZERO),_mw(),massopt(1),_minloop(6),
_maxloop(6),_CoefRepresentation(1) {
//PDG codes for particles at vertices
addToList(21,21,25);
}
void SMHGGVertex::doinit() {
_theSM = dynamic_ptr_cast<tcHwSMPtr>(generator()->standardModel());
if(!_theSM)
throw InitException();
_mw = getParticleData(ThePEG::ParticleID::Wplus)->mass();
orderInGs(2);
orderInGem(1);
VVSLoopVertex::doinit();
// code to test the partial width
// Energy mh = getParticleData(25)->mass();
// Complex I(0.);
// for(long ix=int(_minloop);ix<=int(_maxloop);++ix) {
// tcPDPtr qrk = getParticleData(ix);
// Energy mt = (2 == massopt) ? _theSM->mass(sqr(mh),qrk) : qrk->mass();
// double lambda = sqr(mt/mh);
// Complex fl;
// if(lambda>=0.25) {
// fl = -2.*sqr(asin(0.5/sqrt(lambda)));
// }
// else {
// double etap = 0.5+sqrt(0.25-lambda);
// double etam = 0.5-sqrt(0.25-lambda);
// fl = 0.5*sqr(log(etap/etam))-0.5*sqr(Constants::pi)
// -Complex(0.,1.)*Constants::pi*log(etap/etam);
// }
// I += 3.*(2.*lambda+lambda*(4.*lambda-1)*fl);
// }
// Energy width = sqr(weakCoupling(sqr(mh))*sqr(strongCoupling(sqr(mh))))/36./8.*sqr(mh/_mw)*mh
// /sqr(4.*sqr(Constants::pi))*std::norm(I)/Constants::pi;
// cerr << "testing anal " << width/GeV << "\n";
+ Looptools::ltexi();
}
void SMHGGVertex::persistentOutput(PersistentOStream & os) const {
os << _theSM << ounit(_mw,GeV) << massopt
<< _minloop << _maxloop << _CoefRepresentation;
}
void SMHGGVertex::persistentInput(PersistentIStream & is, int) {
is >> _theSM >> iunit(_mw,GeV) >> massopt
>> _minloop >> _maxloop >> _CoefRepresentation;
}
ClassDescription<SMHGGVertex> SMHGGVertex::initSMHGGVertex;
// Definition of the static class description member.
void SMHGGVertex::Init() {
static ClassDocumentation<SMHGGVertex> documentation
("This class implements the h->g,g vertex");
static Parameter<SMHGGVertex,int> interfaceMinQuarkInLoop
("MinQuarkInLoop",
"The minimum flavour of the quarks to include in the loops",
&SMHGGVertex::_minloop, 6, 1, 6,
false, false, Interface::limited);
static Parameter<SMHGGVertex,int> interfaceMaxQuarkInLoop
("MaxQuarkInLoop",
"The maximum flavour of the quarks to include in the loops",
&SMHGGVertex::_maxloop, 6, 1, 6,
false, false, Interface::limited);
static Switch<SMHGGVertex,unsigned int> interfaceMassOption
("LoopMassScheme",
"Switch for the treatment of the masses in the loops ",
&SMHGGVertex::massopt, 1, false, false);
static SwitchOption interfaceHeavyMass
(interfaceMassOption,
"PoleMasses",
"The loop is calculcated with the pole quark masses",
1);
static SwitchOption interfaceNormalMass
(interfaceMassOption,
"RunningMasses",
"running quark masses are taken in the loop",
2);
static SwitchOption interfaceInfiniteTopMass
(interfaceMassOption,
"InfiniteTopMass",
"the loop consists of an infinitely massive top quark",
3);
static Switch<SMHGGVertex,unsigned int> interfaceScheme
("CoefficientScheme",
"Which scheme for the tensor coefficients is applied",
&SMHGGVertex::_CoefRepresentation, 1, false, false);
static SwitchOption interfaceSchemeSimplified
(interfaceScheme,
"Simplified",
"Represection suitable for the simplified the H-g-g and H-gamma-gamma vertices",
1);
static SwitchOption interfaceSchemeGeneral
(interfaceScheme,
"General",
"Represection suitable for the Passarino-Veltman tensor reduction scheme",
2);
}
void SMHGGVertex::setCoupling(Energy2 q2, tcPDPtr part2, tcPDPtr part3, tcPDPtr part1) {
assert(part1 && part2 && part3);
assert(part1->id() == ParticleID::h0 &&
part2->id() == ParticleID::g && part3->id() == ParticleID::g );
int Qminloop = _minloop;
int Qmaxloop = _maxloop;
if (_maxloop < _minloop) {
Qmaxloop=_minloop;
Qminloop=_maxloop;
}
if(massopt==3) {
if(q2 != _q2last) {
double g = weakCoupling(q2);
double gs2 = sqr(strongCoupling(q2));
_couplast = UnitRemoval::E * gs2 * g / 16. / _mw/ sqr(Constants::pi);
_q2last = q2;
}
norm(_couplast);
Complex loop(2./3.);
a00( loop); a11(0.0); a12(0.0);
a21(-loop); a22(0.0); aEp(0.0);
return;
}
switch (_CoefRepresentation) {
case 1: {
if(q2 != _q2last||_couplast==0.) {
double g = weakCoupling(q2);
double gs2 = sqr(strongCoupling(q2));
_couplast = UnitRemoval::E * gs2 * g / 16. / _mw/ sqr(Constants::pi);
_q2last = q2;
}
norm(_couplast);
Complex loop(0.);
for ( int i = Qminloop; i <= Qmaxloop; ++i ) {
tcPDPtr qrk = getParticleData(i);
Energy mass = (2 == massopt) ? _theSM->mass(q2,qrk) : qrk->mass();
loop += Af(sqr(mass)/q2);
}
a00(loop);
a11(0.0);
a12(0.0);
a21(-loop);
a22(0.0);
aEp(0.0);
break;
}
case 2: {
if (q2 != _q2last) {
- clearcache();
+ Looptools::clearcache();
_couplast = 0.25*sqr(strongCoupling(q2))*weakCoupling(q2);
_q2last = q2;
}
norm(_couplast);
int delta = Qmaxloop - Qminloop + 1;
type.resize(delta,PDT::SpinUnknown);
masses.resize(delta,ZERO);
for (int i = 0; i < delta; ++i) {
tcPDPtr q = getParticleData(_minloop+i);
type[i] = PDT::Spin1Half;
masses[i] = (2 == massopt) ? _theSM->mass(q2,q) : q->mass();
couplings.push_back(make_pair(masses[i]/_mw, masses[i]/_mw));
}
setNParticles(delta);
VVSLoopVertex::setCoupling(q2, part1, part2, part3);
break;
}
}
}
Complex SMHGGVertex::Af(double tau) const {
return tau*(4.- W2(tau)*(1.-4.*tau));
}
Complex SMHGGVertex::W2(double lambda) const {
double pi = Constants::pi;
if (0.0 == lambda) return 0.0;
else if (lambda < 0.0) return 4.*sqr(asinh(0.5*sqrt(-1./lambda)));
double root(0.5*sqrt(1./lambda));
Complex ac(0.);
// formulae from NPB297,221
if(root < 1.) {
ac = -sqr(asin(root));
}
else {
double ex = acosh(root);
ac = sqr(ex) - 0.25*sqr(pi) - pi*ex*Complex(0.,1.);
}
return 4.*ac;
}
diff --git a/Models/StandardModel/SMHPPVertex.cc b/Models/StandardModel/SMHPPVertex.cc
--- a/Models/StandardModel/SMHPPVertex.cc
+++ b/Models/StandardModel/SMHPPVertex.cc
@@ -1,280 +1,281 @@
// -*- C++ -*-
//
// SMHPPVertex.cc is a part of Herwig++ - A multi-purpose Monte Carlo event generator
// Copyright (C) 2002-2007 The Herwig Collaboration
//
// Herwig++ is licenced under version 2 of the GPL, see COPYING for details.
// Please respect the MCnet academic guidelines, see GUIDELINES for details.
//
//
// This is the implementation of the non-inlined, non-templated member
// functions of the SMHPPVertex class.
//
#include "SMHPPVertex.h"
#include "ThePEG/Interface/ClassDocumentation.h"
#include "ThePEG/Interface/Parameter.h"
#include "ThePEG/Interface/Switch.h"
#include "ThePEG/Persistency/PersistentOStream.h"
#include "ThePEG/Persistency/PersistentIStream.h"
#include "ThePEG/PDT/EnumParticles.h"
#include "Herwig++/Looptools/clooptools.h"
using namespace Herwig;
using namespace ThePEG;
void SMHPPVertex::persistentOutput(PersistentOStream & os) const {
os << _theSM << ounit(_mw,GeV) << massopt << _minloop << _maxloop
<< _CoefRepresentation;
}
void SMHPPVertex::persistentInput(PersistentIStream & is, int) {
is >> _theSM >> iunit(_mw, GeV) >> massopt >> _minloop >> _maxloop
>> _CoefRepresentation;
}
ClassDescription<SMHPPVertex> SMHPPVertex::initSMHPPVertex;
// Definition of the static class description member.
void SMHPPVertex::Init() {
static ClassDocumentation<SMHPPVertex> documentation
("This class implements the h0->gamma,gamma vertex.");
static Parameter<SMHPPVertex,int> interfaceMinQuarkInLoop
("MinQuarkInLoop",
"The minimum flavour of the quarks to include in the loops",
&SMHPPVertex::_minloop, 6, 1, 6,
false, false, Interface::limited);
static Parameter<SMHPPVertex,int> interfaceMaxQuarkInLoop
("MaxQuarkInLoop",
"The maximum flavour of the quarks to include in the loops",
&SMHPPVertex::_maxloop, 6, 1, 6,
false, false, Interface::limited);
static Switch<SMHPPVertex,unsigned int> interfaceMassOption
("LoopMassScheme",
"Switch for the treatment of the masses in the loops ",
&SMHPPVertex::massopt, 2, false, false);
static SwitchOption interfaceHeavyMass
(interfaceMassOption,
"PoleMasses",
"The loop is calculcated with the pole quark masses",
1);
static SwitchOption interfaceNormalMass
(interfaceMassOption,
"RunningMasses",
"running quark masses are taken in the loop",
2);
static Switch<SMHPPVertex,unsigned int> interfaceScheme
("CoefficientScheme",
"Which scheme for the tensor coefficients is applied",
&SMHPPVertex::_CoefRepresentation, 1, false, false);
static SwitchOption interfaceSchemeSimplified
(interfaceScheme,
"Simplified",
"Represection suitable for the simplified the H-g-g and H-gamma-gamma vertices",
1);
static SwitchOption interfaceSchemeGeneral
(interfaceScheme,
"General",
"Represection suitable for the Passarino-Veltman tensor reduction scheme",
2);
}
void SMHPPVertex::setCoupling(Energy2 q2, tcPDPtr part2,
tcPDPtr part3, tcPDPtr part1) {
assert( part1->id() == ParticleID::h0 &&
part2->id() == ParticleID::gamma && part3->id() == ParticleID::gamma );
int Qminloop = _minloop;
int Qmaxloop = _maxloop;
if (_maxloop < _minloop) {
Qmaxloop=_minloop;
Qminloop=_maxloop;
}
switch (_CoefRepresentation) {
case 1: {
if(q2 != _q2last||_couplast==0.) {
double g = weakCoupling(q2);
double e2 = sqr(electroMagneticCoupling(q2));
_couplast = UnitRemoval::E * e2 * g / 8. / _mw/ sqr(Constants::pi);
_q2last = q2;
}
norm(_couplast);
Complex loop(0.);
// quark loops
for ( int i = Qminloop; i <= Qmaxloop; ++i ) {
tcPDPtr qrk = getParticleData(i);
Energy mass = (2 == massopt) ? _theSM->mass(q2,qrk) : qrk->mass();
Charge charge = qrk->charge();
loop += 3.*sqr(charge/ThePEG::Units::eplus) * Af(sqr(mass)/q2);
}
// lepton loops
int Lminloop = 3; // still fixed value
int Lmaxloop = 3; // still fixed value
for (int i = Lminloop; i <= Lmaxloop; ++i) {
tcPDPtr lpt = getParticleData(9 + 2*i);
Energy mass = (2 == massopt) ? _theSM->mass(q2,lpt) : lpt->mass();
Charge charge = lpt->charge();
loop += sqr(charge/ThePEG::Units::eplus) * Af(sqr(mass)/q2);
}
// W loop
loop += Aw(sqr(_mw)/q2);
a00(loop);
a11(0.0);
a12(0.0);
a21(-loop);
a22(0.0);
aEp(0.0);
break;
}
case 2: {
if(q2 != _q2last||_couplast==0.) {
- clearcache();
+ Looptools::clearcache();
double e = electroMagneticCoupling(q2);
_couplast = pow(e,3)/sqrt(sin2ThetaW());
_q2last = q2;
}
norm(_couplast);
// quarks
int delta = Qmaxloop - Qminloop + 1;
type.resize(delta,PDT::SpinUnknown);
masses.resize(delta,ZERO);
for (int i = 0; i < delta; ++i) {
tcPDPtr q = getParticleData(_minloop+i);
type[i] = PDT::Spin1Half;
masses[i] = (2 == massopt) ? _theSM->mass(q2,q) : q->mass();
double copl = -masses[i]*3.*sqr(q->iCharge()/3.)/_mw/2.;
couplings.push_back(make_pair(copl, copl));
}
// tau
type.push_back(PDT::Spin1Half);
tcPDPtr tau = getParticleData(ParticleID::tauminus);
masses.push_back(_theSM->mass(q2,tau));
double copl = -masses.back()*sqr(tau->iCharge()/3.)/_mw/2.;
couplings.push_back(make_pair(copl, copl));
// W
type.push_back(PDT::Spin1);
masses.push_back(_mw);
couplings.push_back(make_pair(UnitRemoval::InvE*_mw, UnitRemoval::InvE*_mw));
setNParticles(delta+2);
VVSLoopVertex::setCoupling(q2, part1, part2, part3);
break;
}
}
}
Complex SMHPPVertex::Af(const double tau) const {
return tau*(4. - W2(tau)*(1. - 4.*tau));
}
Complex SMHPPVertex::Aw(const double tau) const {
return 0.5*(-3.*W2(tau)*tau*(4.*tau - 2.) - 12.*tau - 2.);
}
Complex SMHPPVertex::W2(double lambda) const {
double pi = Constants::pi;
if (0.0 == lambda)
return 0.0;
if (lambda < 0.0)
return 4.*sqr(asinh(0.5*sqrt(-1./lambda)));
double root(0.5*sqrt(1./lambda));
Complex ac(0.);
// formulae from NPB297,221
if(root < 1.) {
ac = -sqr(asin(root));
}
else {
double ex = acosh(root);
ac = sqr(ex) - 0.25*sqr(pi) - pi*ex*Complex(0.,1.);
}
return 4.*ac;
}
SMHPPVertex::SMHPPVertex()
:_couplast(0.),_q2last(),_mw(),massopt(1),
_minloop(6),_maxloop(6),_CoefRepresentation(1) {
//PDG codes for particles at vertices
addToList(22,22,25);
}
// functions for loops for testing
// namespace {
// Complex F0(double tau) {
// Complex ft;
// if(tau>=1.)
// ft = sqr(asin(1./sqrt(tau)));
// else {
// double etap = 1.+sqrt(1.-tau);
// double etam = 1.-sqrt(1.-tau);
// ft = -0.25*sqr(log(etap/etam)-Constants::pi*Complex(0.,1.));
// }
// return tau*(1.-tau*ft);
// }
// Complex FHalf(double tau,double eta) {
// Complex ft;
// if(tau>=1.)
// ft = sqr(asin(1./sqrt(tau)));
// else {
// double etap = 1.+sqrt(1.-tau);
// double etam = 1.-sqrt(1.-tau);
// ft = -0.25*sqr(log(etap/etam)-Constants::pi*Complex(0.,1.));
// }
// return -2.*tau*(eta+(1.-tau*eta)*ft);
// }
// Complex F1(double tau) {
// Complex ft;
// if(tau>=1.)
// ft = sqr(asin(1./sqrt(tau)));
// else {
// double etap = 1.+sqrt(1.-tau);
// double etam = 1.-sqrt(1.-tau);
// ft = -0.25*sqr(log(etap/etam)-Constants::pi*Complex(0.,1.));
// }
// return 2.+3.*tau+3.*tau*(2.-tau)*ft;
// }
// }
void SMHPPVertex::doinit() {
_theSM = dynamic_ptr_cast<tcHwSMPtr>(generator()->standardModel());
if( !_theSM )
throw InitException()
<< "SMHGGVertex::doinit() - The pointer to the SM object is null."
<< Exception::abortnow;
_mw = getParticleData(ThePEG::ParticleID::Wplus)->mass();
orderInGs(0);
orderInGem(3);
VVSLoopVertex::doinit();
// // code to test the partial width
// Energy mh = getParticleData(25)->mass();
// Complex I(0.);
// for(long ix=int(_minloop);ix<=int(_maxloop);++ix) {
// tcPDPtr qrk = getParticleData(ix);
// Energy mt = (2 == massopt) ? _theSM->mass(sqr(mh),qrk) : qrk->mass();
// double tau = sqr(2.*mt/mh);
// I += 3.*sqr(double(qrk->iCharge())/3.)*FHalf(tau,1.);
// cerr << "testing half " << FHalf(tau,1) << " " << Af(0.25*tau) << "\n";
// }
// for(long ix=15;ix<=15;++ix) {
// tcPDPtr qrk = getParticleData(ix);
// Energy mt = (2 == massopt) ? _theSM->mass(sqr(mh),qrk) : qrk->mass();
// double tau = sqr(2.*mt/mh);
// I += sqr(double(qrk->iCharge())/3.)*FHalf(tau,1.);
// }
// I += F1(sqr(2.*_mw/mh));
// Energy width = sqr(weakCoupling(sqr(mh))*sqr(electroMagneticCoupling(sqr(mh))))
// /1024./pow(Constants::pi,5)/16.*sqr(mh/_mw)*mh*std::norm(I);
// cerr << "testing anal " << width/GeV << "\n";
+ Looptools::ltexi();
}
diff --git a/Models/Susy/NMSSM/NMSSMGGHVertex.cc b/Models/Susy/NMSSM/NMSSMGGHVertex.cc
--- a/Models/Susy/NMSSM/NMSSMGGHVertex.cc
+++ b/Models/Susy/NMSSM/NMSSMGGHVertex.cc
@@ -1,205 +1,206 @@
// -*- C++ -*-
//
// This is the implementation of the non-inlined, non-templated member
// functions of the NMSSMGGHVertex class.
//
#include "NMSSMGGHVertex.h"
#include "ThePEG/Interface/ClassDocumentation.h"
#include "ThePEG/Persistency/PersistentOStream.h"
#include "ThePEG/Persistency/PersistentIStream.h"
#include "Herwig++/Models/Susy/NMSSM/NMSSM.h"
#include "Herwig++/Looptools/clooptools.h"
using namespace Herwig;
NMSSMGGHVertex::NMSSMGGHVertex() : _sw(0.), _cw(0.), _mw(0.*MeV),
_mz(0.*MeV),_lambdaVEV(0.*MeV), _lambda(0.), _v1(0.*MeV),
_v2(0.*MeV), _triTp(0.*MeV), _triBt(0.*MeV),
_sb(0.), _cb(0.), _masslast(make_pair(0.*MeV,0.*MeV)),
_q2last(0.*MeV2), _couplast(0.), _coup(0.),
_hlast(0), _recalc(true) {
addToList(21,21,25);
addToList(21,21,35);
addToList(21,21,36);
addToList(21,21,45);
addToList(21,21,46);
}
void NMSSMGGHVertex::doinit() {
_theSM = dynamic_ptr_cast<tcHwSMPtr>(generator()->standardModel());
if( !_theSM ) {
throw InitException() << "NMSSMGGHVertex::doinit - The SM pointer is null!"
<< Exception::abortnow;
}
// SM parameters
_sw = sqrt(sin2ThetaW());
_cw = sqrt(1. - sin2ThetaW());
_mw = getParticleData(24)->mass();
_mz = getParticleData(23)->mass();
_top = getParticleData(6);
_bt = getParticleData(5);
//NMSSM parameters
tcNMSSMPtr nmssm = dynamic_ptr_cast<tcNMSSMPtr>(_theSM);
_mixS = nmssm->CPevenHiggsMix();
_mixP = nmssm->CPoddHiggsMix();
_mixQt = nmssm->stopMix();
_mixQb = nmssm->sbottomMix();
double beta = atan(nmssm->tanBeta());
_sb = sin(beta);
_cb = cos(beta);
_v1 = sqrt(2.)*_mw*_cb;
_v2 = sqrt(2.)*_mw*_sb;
_lambda = nmssm->lambda();
_lambdaVEV = nmssm->lambdaVEV();
_triTp = nmssm->topTrilinear();
_triBt = nmssm->bottomTrilinear();
// resize vectors here and use setNParticles method
// to the set the actual number in the loop.
// Also only the top mass hass to be calculated at runtime
masses.resize(6, Energy());
masses[0] = getParticleData(6)->mass();
masses[1] = getParticleData(5)->mass();
masses[2] = getParticleData(1000005)->mass();
masses[3] = getParticleData(2000005)->mass();
masses[4] = getParticleData(1000006)->mass();
masses[5] = getParticleData(2000006)->mass();
type.resize(6, PDT::Spin0);
type[0] = PDT::Spin1Half;
type[1] = PDT::Spin1Half;
couplings.resize(6);
orderInGem(1);
orderInGs(2);
VVSLoopVertex::doinit();
+ Looptools::ltexi();
}
void NMSSMGGHVertex::persistentOutput(PersistentOStream & os) const {
os << _theSM << _sw << _cw << ounit(_mw, GeV) << ounit(_mz, GeV)
<< ounit(_lambdaVEV,GeV) << _lambda << ounit(_v1,GeV) << ounit(_v2,GeV)
<< ounit(_triTp,GeV) << ounit(_triBt,GeV)
<< _top << _bt << _mixS << _mixP << _mixQt << _mixQb << _sb << _cb;
}
void NMSSMGGHVertex::persistentInput(PersistentIStream & is, int) {
is >> _theSM >> _sw >> _cw >> iunit(_mw, GeV) >> iunit(_mz, GeV)
>> iunit(_lambdaVEV,GeV) >> _lambda >> iunit(_v1,GeV) >> iunit(_v2,GeV)
>> iunit(_triTp,GeV) >> iunit(_triBt,GeV)
>> _top >> _bt >> _mixS >> _mixP >> _mixQt >> _mixQb >> _sb >> _cb;
}
ClassDescription<NMSSMGGHVertex> NMSSMGGHVertex::initNMSSMGGHVertex;
// Definition of the static class description member.
void NMSSMGGHVertex::Init() {
static ClassDocumentation<NMSSMGGHVertex> documentation
("The effective coupling of a higgs to a pair of gluons in the "
"NMSSM.");
}
void NMSSMGGHVertex::setCoupling(Energy2 q2, tcPDPtr p1, tcPDPtr p2,
tcPDPtr p3) {
long hid(p3->id());
if( q2 != _q2last ) {
- clearcache();
+ Looptools::clearcache();
_couplast = sqr(strongCoupling(q2));
_coup = weakCoupling(q2);
_q2last = q2;
_recalc = true;
}
norm(_couplast*_coup);
// scalar higgs bosons
if( hid != _hlast ) {
_hlast = hid;
_recalc = true;
if( hid % 5 == 0 ) {
// location of the higgs
int iloc = (hid - 25)/10;
// 6 particles in the loop
setNParticles(6);
// top and bottom quark masses
Energy mt = _theSM->mass(q2, _top);
Energy mb = _theSM->mass(q2, _bt);
Complex c(0.);
// couplings for the top quark loop
c = -0.25*mt*(*_mixS)(iloc, 1)/_sb/_mw;
couplings[0] = make_pair(c,c);
masses[0] = mt;
// couplings for the bottom quark loop
c = -0.25*mb*(*_mixS)(iloc, 0)/_cb/_mw;
couplings[1] = make_pair(c,c);
masses[1] = mb;
// sbottoms
double f1 = mb/_mw/_cb;
complex<Energy> f2 = 0.5*_mz/_cw*
( - _cb*(*_mixS)(iloc,0) + _sb*(*_mixS)(iloc,1));
complex<Energy> cpl;
for(unsigned int ix=0;ix<2;++ix) {
cpl = -f2*( (1. - 2.*sqr(_sw)/3.)*(*_mixQb)(ix, 0)*(*_mixQb)(ix, 0)
+ 2.*sqr(_sw)*(*_mixQb)(ix, 1)*(*_mixQb)(ix, 1)/3.)
- f1*mb*(*_mixS)(iloc,0)
*((*_mixQb)(ix, 0)*(*_mixQb)(ix, 0) + (*_mixQb)(ix, 1)*(*_mixQb)(ix, 1))
- 0.5*f1*(-_lambdaVEV*(*_mixS)(iloc,1) - _lambda*_v2*(*_mixS)(iloc,2)/_coup
+ _triBt*(*_mixS)(iloc,0))*((*_mixQb)(ix, 1)*(*_mixQb)(ix, 0)
+ (*_mixQb)(ix, 0)*(*_mixQb)(ix, 1));
couplings[2+ix] = make_pair(0.5*cpl*UnitRemoval::InvE,0.5*cpl*UnitRemoval::InvE);
}
// stop
f1 = mt/_mw/_sb;
for(unsigned int ix=0;ix<2;++ix) {
cpl =+f2*( (1. - 4.*sqr(_sw)/3.)*(*_mixQt)(ix, 0)*(*_mixQt)(ix, 0)
+ 4.*sqr(_sw)*(*_mixQt)(ix, 1)*(*_mixQt)(ix, 1)/3.)
- f1*mt*(*_mixS)(iloc,1)
*((*_mixQt)(ix, 0)*(*_mixQt)(ix, 0)
+ (*_mixQt)(ix, 1)*(*_mixQt)(ix, 1))
- 0.5*f1*(-_lambdaVEV*(*_mixS)(iloc,0) - _lambda*_v1*(*_mixS)(iloc,2)/_coup
+ _triTp*(*_mixS)(iloc,1))*((*_mixQt)(ix, 1)*(*_mixQt)(ix, 0)
+ (*_mixQt)(ix, 0)*(*_mixQt)(ix, 1));
couplings[4+ix] = make_pair(0.5*cpl*UnitRemoval::InvE,0.5*cpl*UnitRemoval::InvE);
}
}
// pseudoscalar higgs bosons
else {
// location of the higgs
int iloc = (hid - 36)/10;
// 2 particles in the loop
setNParticles(2);
// top and bottom quark masses
Energy mt = _theSM->mass(q2, _top);
Energy mb = _theSM->mass(q2, _bt);
Complex c(0.);
// top quark couplings
c = Complex(0.,-1.)*0.25*mt*(*_mixP)(iloc, 1)/_sb/_mw;
couplings[0] = make_pair(-c,c);
masses[0] = mt;
// bottom quark couplings
c = Complex(0., -1.)*0.25*mb*(*_mixP)(iloc, 0)/_cb/_mw;
couplings[1] = make_pair(-c,c);
masses[1] = mb;
}
}
if( _recalc ) {
VVSLoopVertex::setCoupling(q2, p1, p2, p3);
_recalc = false;
}
}
diff --git a/Models/Susy/NMSSM/NMSSMPPHVertex.cc b/Models/Susy/NMSSM/NMSSMPPHVertex.cc
--- a/Models/Susy/NMSSM/NMSSMPPHVertex.cc
+++ b/Models/Susy/NMSSM/NMSSMPPHVertex.cc
@@ -1,279 +1,280 @@
// -*- C++ -*-
//
// This is the implementation of the non-inlined, non-templated member
// functions of the NMSSMPPHVertex class.
//
#include "NMSSMPPHVertex.h"
#include "ThePEG/Interface/ClassDocumentation.h"
#include "ThePEG/Persistency/PersistentOStream.h"
#include "ThePEG/Persistency/PersistentIStream.h"
#include "ThePEG/PDT/EnumParticles.h"
#include "Herwig++/Models/Susy/NMSSM/NMSSM.h"
#include "Herwig++/Looptools/clooptools.h"
using namespace Herwig;
NMSSMPPHVertex::NMSSMPPHVertex()
: _sw(0.), _cw(0.), _mw(0.*MeV),
_mz(0.*MeV),_lambdaVEV(0.*MeV), _lambda(0.),
_triTp(0.*MeV), _triBt(0.*MeV),
_sb(0.), _cb(0.),
_kappa(0.),_vu(ZERO),_vd(ZERO),_s(ZERO),_theAl(ZERO),
_masslast(make_pair(0.*MeV,0.*MeV)),_q2last(0.*MeV2),
_couplast(0.), _coup(0.), _hlast(0), _recalc(true) {
addToList(22,22,25);
addToList(22,22,35);
addToList(22,22,36);
addToList(22,22,45);
addToList(22,22,46);
}
void NMSSMPPHVertex::doinit() {
_theSM = dynamic_ptr_cast<tcHwSMPtr>(generator()->standardModel());
if( !_theSM ) {
throw InitException() << "NMSSMPPHVertex::doinit - The SM pointer is null!"
<< Exception::abortnow;
}
// SM parameters
_sw = sqrt(sin2ThetaW());
_cw = sqrt(1. - sin2ThetaW());
_mw = getParticleData(24)->mass();
_mz = getParticleData(23)->mass();
_top = getParticleData(6);
_bt = getParticleData(5);
_tau = getParticleData(15);
//NMSSM parameters
tcNMSSMPtr nmssm = dynamic_ptr_cast<tcNMSSMPtr>(_theSM);
_mixS = nmssm->CPevenHiggsMix();
_mixP = nmssm->CPoddHiggsMix();
_mixQt = nmssm->stopMix();
_mixQb = nmssm->sbottomMix();
_mixLt = nmssm->stauMix();
double beta = atan(nmssm->tanBeta());
_sb = sin(beta);
_cb = cos(beta);
_lambda = nmssm->lambda();
_lambdaVEV = nmssm->lambdaVEV();
_triTp = nmssm->topTrilinear();
_triBt = nmssm->bottomTrilinear();
_triTa = nmssm->tauTrilinear();
_vd = sqrt(2)*_mw*_cb;
_vu = sqrt(2)*_mw*_sb;
_s = _lambdaVEV/_lambda;
_theAl = nmssm->trilinearLambda();
_kappa = nmssm->kappa();
_mixU = nmssm->charginoUMix();
_mixV = nmssm->charginoVMix();
// resize vectors here and use setNParticles method
// to the set the actual number in the loop.
// Also only the top mass hass to be calculated at runtime
masses.resize(13, Energy());
masses[ 0] = getParticleData( 6)->mass();
masses[ 1] = getParticleData( 5)->mass();
masses[ 2] = getParticleData(15)->mass();
masses[ 3] = getParticleData(ParticleID::SUSY_chi_1plus)->mass();
masses[ 4] = getParticleData(ParticleID::SUSY_chi_2plus)->mass();
masses[ 5] = _mw;
masses[ 6] = getParticleData(ParticleID::Hplus)->mass();
masses[ 7] = getParticleData(1000005)->mass();
masses[ 8] = getParticleData(2000005)->mass();
masses[ 9] = getParticleData(1000006)->mass();
masses[10] = getParticleData(2000006)->mass();
masses[11] = getParticleData(1000015)->mass();
masses[12] = getParticleData(2000015)->mass();
type.resize(13, PDT::Spin0);
type[0] = PDT::Spin1Half;
type[1] = PDT::Spin1Half;
type[2] = PDT::Spin1Half;
type[3] = PDT::Spin1Half;
type[4] = PDT::Spin1Half;
type[5] = PDT::Spin1;
couplings.resize(13);
orderInGem(3);
orderInGs(0);
VVSLoopVertex::doinit();
+ Looptools::ltexi();
}
void NMSSMPPHVertex::persistentOutput(PersistentOStream & os) const {
os << _theSM << _sw << _cw << ounit(_mw, GeV) << ounit(_mz, GeV)
<< ounit(_lambdaVEV,GeV) << _lambda
<< ounit(_triTp,GeV) << ounit(_triBt,GeV) << ounit(_triTa,GeV)
<< _top << _bt << _tau << _mixS << _mixP << _mixU << _mixV
<< _mixQt << _mixQb << _mixLt << _sb << _cb << _kappa
<< ounit(_vu,GeV) << ounit(_vd,GeV) << ounit(_s,GeV) << ounit(_theAl,GeV);
}
void NMSSMPPHVertex::persistentInput(PersistentIStream & is, int) {
is >> _theSM >> _sw >> _cw >> iunit(_mw, GeV) >> iunit(_mz, GeV)
>> iunit(_lambdaVEV,GeV) >> _lambda
>> iunit(_triTp,GeV) >> iunit(_triBt,GeV) >> iunit(_triTa,GeV)
>> _top >> _bt >> _tau >> _mixS >> _mixP >> _mixU >> _mixV
>> _mixQt >> _mixQb >> _mixLt >> _sb >> _cb >> _kappa
>> iunit(_vu,GeV) >> iunit(_vd,GeV) >> iunit(_s,GeV) >> iunit(_theAl,GeV);
}
ClassDescription<NMSSMPPHVertex> NMSSMPPHVertex::initNMSSMPPHVertex;
// Definition of the static class description member.
void NMSSMPPHVertex::Init() {
static ClassDocumentation<NMSSMPPHVertex> documentation
("The effective coupling of a higgs to a pair of gluons in the "
"NMSSM.");
}
void NMSSMPPHVertex::setCoupling(Energy2 q2, tcPDPtr p1, tcPDPtr p2,
tcPDPtr p3) {
long hid(p3->id());
double rt = sqrt(0.5);
if( q2 != _q2last ) {
- clearcache();
+ Looptools::clearcache();
_couplast = sqr(electroMagneticCoupling(q2));
_coup = weakCoupling(q2);
_q2last = q2;
_recalc = true;
}
norm(_couplast*_coup);
// scalar higgs bosons
if( hid != _hlast ) {
_hlast = hid;
_recalc = true;
// top and bottom quark masses
Energy mt = _theSM->mass(q2, _top);
Energy mb = _theSM->mass(q2, _bt);
Energy mtau = _theSM->mass(q2, _tau);
// scalar
if( hid % 5 == 0 ) {
// location of the higgs
int iloc = (hid - 25)/10;
// 6 particles in the loop
setNParticles(13);
Complex c(0.);
// couplings for the top quark loop
c = -1.5*sqr(_theSM->eu())* mt*(*_mixS)(iloc, 1)/_sb/_mw;
couplings[0] = make_pair(c,c);
masses[0] = mt;
// couplings for the bottom quark loop
c = -1.5*sqr(_theSM->ed())* mb*(*_mixS)(iloc, 0)/_cb/_mw;
couplings[1] = make_pair(c,c);
masses[1] = mb;
// couplings for the tau lepton loop
c = -0.5*sqr(_theSM->ee())*mtau*(*_mixS)(iloc, 0)/_cb/_mw;
couplings[2] = make_pair(c,c);
masses[2] = mtau;
// charginos
for(unsigned int ic=0;ic<2;++ic) {
c = -_lambda/_coup*rt*(*_mixS)(iloc,2)*(*_mixU)(ic,1)*(*_mixV)(ic,1)
-rt*((*_mixS)(iloc,0)*(*_mixU)(ic,1)*(*_mixV)(ic,0) +
(*_mixS)(iloc,1)*(*_mixU)(ic,0)*(*_mixV)(ic,1));
couplings[3+ic] = make_pair(c,c);
}
// W boson
c = UnitRemoval::InvE*_mw*
(_cb*(*_mixS)(iloc,0)+_sb*(*_mixS)(iloc,1));
couplings[5] = make_pair(c,c);
// charged Higgs
complex<Energy> cpl;
cpl = sqr(_lambda)*rt*2.*(_s*((*_mixS)(iloc,2)*sqr(_cb) + (*_mixS)(iloc,2)*sqr(_sb))
- (_vu*(*_mixS)(iloc,0)/_coup +
_vd*(*_mixS)(iloc,1)/_coup)*_sb*_cb)
+_lambda*_sb*_cb*2*(*_mixS)(iloc,2)*(_kappa*_s/rt + rt*_theAl)
+ sqr(_coup)*0.5*rt*sqr(_sw)/sqr(_cw)*((_vu*(*_mixS)(iloc,1)/_coup -
_vd*(*_mixS)(iloc,0)/_coup)*sqr(_cb) +
(_vd*(*_mixS)(iloc,0)/_coup -
_vu*(*_mixS)(iloc,1)/_coup)*sqr(_sb))
+ sqr(_coup)*0.5*rt*(_vu*((*_mixS)(iloc,1)*sqr(_cb) +
(*_mixS)(iloc,1)*sqr(_sb) +
2.*(*_mixS)(iloc,0)*_cb*_sb)/_coup
+ _vd*((*_mixS)(iloc,0)*sqr(_cb) +
(*_mixS)(iloc,0)*sqr(_sb)
+ 2.*(*_mixS)(iloc,1)*_sb*_cb)/_coup);
cpl /= -_coup;
couplings[6] = make_pair(cpl*UnitRemoval::InvE,cpl*UnitRemoval::InvE);
// sbottoms
double f1 = mb/_mw/_cb;
complex<Energy> f2 = 0.5*_mz/_cw*
( - _cb*(*_mixS)(iloc,0) + _sb*(*_mixS)(iloc,1));
for(unsigned int ix=0;ix<2;++ix) {
cpl = -f2*( (1. - 2.*sqr(_sw)/3.)*(*_mixQb)(ix, 0)*(*_mixQb)(ix, 0)
+ 2.*sqr(_sw)*(*_mixQb)(ix, 1)*(*_mixQb)(ix, 1)/3.)
- f1*mb*(*_mixS)(iloc,0)
*((*_mixQb)(ix, 0)*(*_mixQb)(ix, 0) + (*_mixQb)(ix, 1)*(*_mixQb)(ix, 1))
- 0.5*f1*(-_lambdaVEV*(*_mixS)(iloc,1) - _lambda*_vu*(*_mixS)(iloc,2)/_coup
+ _triBt*(*_mixS)(iloc,0))*((*_mixQb)(ix, 1)*(*_mixQb)(ix, 0)
+ (*_mixQb)(ix, 0)*(*_mixQb)(ix, 1));
cpl *= 3.*sqr(_theSM->ed());
couplings[7+ix] = make_pair(cpl*UnitRemoval::InvE,cpl*UnitRemoval::InvE);
}
// stop
f1 = mt/_mw/_sb;
for(unsigned int ix=0;ix<2;++ix) {
cpl =+f2*( (1. - 4.*sqr(_sw)/3.)*(*_mixQt)(ix, 0)*(*_mixQt)(ix, 0)
+ 4.*sqr(_sw)*(*_mixQt)(ix, 1)*(*_mixQt)(ix, 1)/3.)
- f1*mt*(*_mixS)(iloc,1)
*((*_mixQt)(ix, 0)*(*_mixQt)(ix, 0)
+ (*_mixQt)(ix, 1)*(*_mixQt)(ix, 1))
- 0.5*f1*(-_lambdaVEV*(*_mixS)(iloc,0) - _lambda*_vd*(*_mixS)(iloc,2)/_coup
+ _triTp*(*_mixS)(iloc,1))*((*_mixQt)(ix, 1)*(*_mixQt)(ix, 0)
+ (*_mixQt)(ix, 0)*(*_mixQt)(ix, 1));
cpl *= 3.*sqr(_theSM->eu());
couplings[9+ix] = make_pair(cpl*UnitRemoval::InvE,cpl*UnitRemoval::InvE);
} // sbottoms
f1 = mtau/_mw/_cb;
for(unsigned int ix=0;ix<2;++ix) {
cpl = -f2*( (1. - 2.*sqr(_sw))*(*_mixLt)(ix, 0)*(*_mixLt)(ix, 0)
+ 2.*sqr(_sw)*(*_mixLt)(ix, 1)*(*_mixLt)(ix, 1))
- f1*mtau*(*_mixS)(iloc,0)
*((*_mixLt)(ix, 0)*(*_mixLt)(ix, 0) + (*_mixLt)(ix, 1)*(*_mixLt)(ix, 1))
- 0.5*f1*(-_lambdaVEV*(*_mixS)(iloc,1) - _lambda*_vu*(*_mixS)(iloc,2)/_coup
+ _triTa*(*_mixS)(iloc,0))*((*_mixLt)(ix, 1)*(*_mixLt)(ix, 0)
+ (*_mixLt)(ix, 0)*(*_mixLt)(ix, 1));
cpl *= sqr(_theSM->ee());
couplings[11+ix] = make_pair(cpl*UnitRemoval::InvE,cpl*UnitRemoval::InvE);
}
}
// pseudoscalar higgs bosons
else {
// location of the higgs
int iloc = (hid - 36)/10;
// 2 particles in the loop
setNParticles(5);
Complex c(0.);
// top quark couplings
c = Complex(0., 1.)*1.5*sqr(_theSM->eu())* mt*(*_mixP)(iloc, 1)/_sb/_mw;
couplings[0] = make_pair(c,-c);
masses[0] = mt;
// bottom quark couplings
c = Complex(0., 1.)*1.5*sqr(_theSM->ed())* mb*(*_mixP)(iloc, 0)/_cb/_mw;
couplings[1] = make_pair(c,-c);
masses[1] = mb;
// tau lepton couplings
c = Complex(0., 1.)*0.5*sqr(_theSM->ee())*mtau*(*_mixP)(iloc, 0)/_cb/_mw;
couplings[2] = make_pair(c,-c);
masses[2] = mtau;
// charginos
for(unsigned int ic=0;ic<2;++ic) {
c = Complex(0,-1.0)*
(_lambda/_coup*rt*(*_mixP)(iloc,2)*(*_mixU)(ic,1)*(*_mixV)(ic,1)
-rt*((*_mixP)(iloc,0)*(*_mixU)(ic,1)*(*_mixV)(ic,0)
+ (*_mixP)(iloc,1)*(*_mixU)(ic,0)*(*_mixV)(ic,1)));
couplings[3+ic] = make_pair(-c,c);
}
}
}
if( _recalc ) {
VVSLoopVertex::setCoupling(q2, p1, p2, p3);
_recalc = false;
}
}
diff --git a/Models/Susy/SSHGGVertex.cc b/Models/Susy/SSHGGVertex.cc
--- a/Models/Susy/SSHGGVertex.cc
+++ b/Models/Susy/SSHGGVertex.cc
@@ -1,248 +1,249 @@
// -*- C++ -*-
//
// SSHGGVertex.cc is a part of Herwig++ - A multi-purpose Monte Carlo event generator
// Copyright (C) 2002-2007 The Herwig Collaboration
//
// Herwig++ is licenced under version 2 of the GPL, see COPYING for details.
// Please respect the MCnet academic guidelines, see GUIDELINES for details.
//
//
// This is the implementation of the non-inlined, non-templated member
// functions of the SSHGGVertex class.
//
#include "SSHGGVertex.h"
#include "ThePEG/Interface/ClassDocumentation.h"
#include "ThePEG/Persistency/PersistentOStream.h"
#include "ThePEG/Persistency/PersistentIStream.h"
#include "ThePEG/PDT/EnumParticles.h"
#include "Herwig++/Looptools/clooptools.h"
#include <cassert>
using namespace ThePEG::Helicity;
using namespace Herwig;
SSHGGVertex::SSHGGVertex() : theSw(0.), theMw(), theZfact(),
theQt1L(0.), theQt1R(0.), theQt1LR(0.),
theQt2L(0.), theQt2R(0.), theQt2LR(0.),
theQb1L(0.), theQb1R(0.), theQb1LR(0.),
theQb2L(0.), theQb2R(0.), theQb2LR(0.),
theSqmass(4,ZERO),
theTanB(0.),theSinA(0.),
theCosA(0.), theSinB(0.), theCosB(0.),
theSinApB(0.), theCosApB(0.), theCouplast(0.),
theq2last(), theHaveCoeff(false), theLastID(0) {
//PDG codes for particles at vertices
addToList(21,21,25);
addToList(21,21,35);
addToList(21,21,36);
}
void SSHGGVertex::doinit() {
theMSSM = dynamic_ptr_cast<tMSSMPtr>(generator()->standardModel());
if( !theMSSM )
throw InitException()
<< "SSHGGVertex::doinit() - The pointer to the MSSM object is null!"
<< Exception::abortnow;
theMw = getParticleData(ParticleID::Wplus)->mass();
thetop = getParticleData(ParticleID::t);
thebot = getParticleData(ParticleID::b);
theSw = sqrt(sin2ThetaW());
theZfact = getParticleData(ParticleID::Z0)->mass()/sqrt(1. - sqr(theSw));
theSinA = sin(theMSSM->higgsMixingAngle());
theCosA = sqrt(1. - sqr(theSinA));
theTanB = theMSSM->tanBeta();
theSinB = theTanB/sqrt(1. + sqr(theTanB));
theCosB = sqrt( 1. - sqr(theSinB) );
theSinApB = theSinA*theCosB + theCosA*theSinB;
theCosApB = theCosA*theCosB - theSinA*theSinB;
MixingMatrixPtr stop = theMSSM->stopMix();
MixingMatrixPtr sbot = theMSSM->sbottomMix();
theQt1L = (*stop)(0,0)*(*stop)(0,0);
theQt1R = (*stop)(0,1)*(*stop)(0,1);
theQt1LR = (*stop)(0,1)*(*stop)(0,0) + (*stop)(0,1)*(*stop)(0,0);
theQt2L = (*stop)(1,0)*(*stop)(1,0);
theQt2R = (*stop)(1,1)*(*stop)(1,1);
theQt2LR = (*stop)(1,1)*(*stop)(1,0) + (*stop)(1,0)*(*stop)(1,1);
theQb1L = (*sbot)(0,0)*(*sbot)(0,0);
theQb1R = (*sbot)(0,1)*(*sbot)(0,1);
theQb1LR = (*sbot)(0,1)*(*sbot)(0,0) + (*sbot)(0,1)*(*sbot)(0,0);
theQb2L = (*sbot)(1,0)*(*sbot)(1,0);
theQb2R = (*sbot)(1,1)*(*sbot)(1,1);
theQb2LR = (*sbot)(1,1)*(*sbot)(1,0) + (*sbot)(1,0)*(*sbot)(1,1);
assert( theSqmass.size() == 4 );
theSqmass[0] = getParticleData(ParticleID::SUSY_b_1)->mass();
theSqmass[1] = getParticleData(ParticleID::SUSY_t_1)->mass();
theSqmass[2] = getParticleData(ParticleID::SUSY_b_2)->mass();
theSqmass[3] = getParticleData(ParticleID::SUSY_t_2)->mass();
orderInGs(2);
orderInGem(1);
VVSLoopVertex::doinit();
+ Looptools::ltexi();
}
void SSHGGVertex::persistentOutput(PersistentOStream & os) const {
os << theMSSM << theSw << ounit(theMw,GeV) << ounit(theZfact,GeV)
<< theQt1L << theQt1R << theQt1LR << theQt2L << theQt2R << theQt2LR
<< theQb1L << theQb1R << theQb1LR << theQb2L << theQb2R << theQb2LR
<< thetop << thebot << theTanB
<< theSinA << theCosA << theSinB << theCosB << theSinApB << theCosApB
<< ounit(theSqmass, GeV);
}
void SSHGGVertex::persistentInput(PersistentIStream & is, int) {
is >> theMSSM >> theSw >> iunit(theMw,GeV) >> iunit(theZfact,GeV)
>> theQt1L >> theQt1R >> theQt1LR >> theQt2L >> theQt2R >> theQt2LR
>> theQb1L >> theQb1R >> theQb1LR >> theQb2L >> theQb2R >> theQb2LR
>> thetop >> thebot >> theTanB
>> theSinA >> theCosA >> theSinB >> theCosB >> theSinApB >> theCosApB
>> iunit(theSqmass, GeV);
}
ClassDescription<SSHGGVertex> SSHGGVertex::initSSHGGVertex;
// Definition of the static class description member.
void SSHGGVertex::Init() {
static ClassDocumentation<SSHGGVertex> documentation
("This class implements the higgs-gluon-gluon effective "
"vertex in the MSSM including stop, sbottom and top quarks "
"loops.");
}
void SSHGGVertex::setCoupling(Energy2 q2, tcPDPtr particle2,
tcPDPtr particle3, tcPDPtr particle1) {
long higgs(abs(particle1->id()));
assert( higgs == ParticleID::h0 || higgs == ParticleID::H0 ||
higgs == ParticleID::A0 );
assert(particle2->id() == ParticleID::g && particle3->id() == ParticleID::g );
if( q2 != theq2last || theCouplast == 0. || higgs != theLastID ) {
- clearcache();
+ Looptools::clearcache();
theCouplast = weakCoupling(q2)*sqr(strongCoupling(q2));
Energy mt = theMSSM->mass(q2, thetop);
Energy mb = theMSSM->mass(q2, thebot);
masses.resize(0);
type.resize(0);
if( higgs == ParticleID::h0 || higgs == ParticleID::H0 ) {
setNParticles(6);
masses.insert(masses.begin(), theSqmass.begin(), theSqmass.end());
masses.push_back(mt);
masses.push_back(mb);
type.resize(6, PDT::Spin0);
type[4] = PDT::Spin1Half;
type[5] = PDT::Spin1Half;
couplings.resize(6, make_pair(0., 0.));
complex<Energy> brac1 = theZfact*(0.5 + theMSSM->ed()*sqr(theSw));
complex<Energy> brac2 = theZfact*(0.5 - theMSSM->eu()*sqr(theSw));
complex<Energy> brac3 = theZfact*theMSSM->ed()*sqr(theSw);
complex<Energy> brac4 = theZfact*theMSSM->eu()*sqr(theSw);
Energy Trib=theMSSM->bottomTrilinear().real();
Energy Trit=theMSSM->topTrilinear().real();
Energy theMu = theMSSM->muParameter();
if( higgs == ParticleID::h0 ) {
// lightest sbottom
Complex coup = 0.5*UnitRemoval::InvE*
(theQb1L *( sqr(mb)*theSinA/theMw/theCosB - theSinApB*brac1) +
theQb1R *( sqr(mb)*theSinA/theMw/theCosB + theSinApB*brac3) +
theQb1LR*0.5*mb/theMw*(Trib*theSinA + theMu*theCosA)/theCosB);
couplings[0] = make_pair(coup, coup);
// lightest stop
coup = 0.5*UnitRemoval::InvE*
(theQt1L *( - sqr(mt)*theCosA/theMw/theSinB + theSinApB*brac2) +
theQt1R *( - sqr(mt)*theCosA/theMw/theSinB + theSinApB*brac4) -
theQt1LR*0.5*mt/theMw*(Trit*theCosA + theMu*theSinA)/theSinB);
couplings[1] = make_pair(coup, coup);
// heavier sbottom
coup = 0.5*UnitRemoval::InvE*
(theQb2L *( sqr(mb)*theSinA/theMw/theCosB - theSinApB*brac1) +
theQb2R *( sqr(mb)*theSinA/theMw/theCosB + theSinApB*brac3)+
theQb2LR*0.5*mb/theMw*(Trib*theSinA + theMu*theCosA)/theCosB);
couplings[2] = make_pair(coup, coup);
// heavier stop
coup = 0.5*UnitRemoval::InvE*
(theQt2L *( - sqr(mt)*theCosA/theMw/theSinB + theSinApB*brac2) +
theQt2R *( - sqr(mt)*theCosA/theMw/theSinB + theSinApB*brac4) -
theQt2LR*0.5*mt/theMw*(Trit*theCosA + theMu*theSinA)/theSinB);
couplings[3] = make_pair(coup, coup);
// top
coup = -0.25*(mt*theCosA/theMw/theSinB);
couplings[4] = make_pair(coup, coup);
// bottom
coup = +0.25*(mb*theSinA/theMw/theCosB);
couplings[5] = make_pair(coup, coup);
}
else {
// lightest sbottom
Complex coup = 0.5*UnitRemoval::InvE*
(theQb1L *( - sqr(mb)*theCosA/theMw/theCosB + theCosApB*brac1) +
theQb1R *( - sqr(mb)*theCosA/theMw/theCosB - theCosApB*brac3) +
theQb1LR*0.5*mb/theMw*(theMu*theSinA - Trib*theCosA)/theCosB);
couplings[0] = make_pair(coup, coup);
// lightest stop
coup = 0.5*UnitRemoval::InvE*
(theQt1L *( - sqr(mt)*theSinA/theMw/theSinB - theCosApB*brac2) +
theQt1R *( - sqr(mt)*theSinA/theMw/theSinB - theCosApB*brac4) -
theQt1LR*0.5*mt/theMw*(-theMu*theCosA + Trit*theSinA)/theSinB);
couplings[1] = make_pair(coup, coup);
// heavier sbottom
coup = 0.5*UnitRemoval::InvE*
(theQb2L *( - sqr(mb)*theCosA/theMw/theCosB + theCosApB*brac1) +
theQb2R *( - sqr(mb)*theCosA/theMw/theCosB - theCosApB*brac3) +
theQb2LR*0.5*mb/theMw*(theMu*theSinA - Trib*theCosA)/theCosB);
couplings[2] = make_pair(coup, coup);
// heavier stop
coup = 0.5*UnitRemoval::InvE*
(theQt2L *( - sqr(mt)*theSinA/theMw/theSinB - theCosApB*brac2) +
theQt2R *( - sqr(mt)*theSinA/theMw/theSinB - theCosApB*brac4) -
theQt2LR*0.5*mt/theMw*(-theMu*theCosA + Trit*theSinA)/theSinB);
couplings[3] = make_pair(coup, coup);
// top
coup = -0.25*mt*theSinA/theMw/theSinB;
couplings[4] = make_pair(coup, coup);
// bottom
coup = -0.25*mb*theCosA/theMw/theCosB;
couplings[5] = make_pair(coup, coup);
}
}
else {
setNParticles(2);
masses.resize(2);
couplings.resize(2);
masses[0] = mt;
masses[1] = mb;
type.resize(2,PDT::Spin1Half);
Complex coup = 0.25*Complex(0., 1.)*mt/theMw/theTanB;
couplings[0] = make_pair(coup, -coup);
coup = 0.25*Complex(0., 1.)*mb/theMw*theTanB;
couplings[1] = make_pair(coup, -coup);
}
theq2last = q2;
theLastID = higgs;
theHaveCoeff = false;
}
norm(theCouplast);
//calculate tensor coefficients
if( !theHaveCoeff ) {
VVSLoopVertex::setCoupling(q2, particle2, particle3, particle1);
theHaveCoeff = true;
}
}
diff --git a/Models/Susy/SSHPPVertex.cc b/Models/Susy/SSHPPVertex.cc
--- a/Models/Susy/SSHPPVertex.cc
+++ b/Models/Susy/SSHPPVertex.cc
@@ -1,578 +1,579 @@
// -*- C++ -*-
//
// SSHPPVertex.cc is a part of Herwig++ - A multi-purpose Monte Carlo event generator
// Copyright (C) 2002-2007 The Herwig Collaboration
//
// Herwig++ is licenced under version 2 of the GPL, see COPYING for details.
// Please respect the MCnet academic guidelines, see GUIDELINES for details.
//
//
// This is the implementation of the non-inlined, non-templated member
// functions of the SSHPPVertex class.
//
#include "SSHPPVertex.h"
#include "ThePEG/Interface/ClassDocumentation.h"
#include "ThePEG/Persistency/PersistentOStream.h"
#include "ThePEG/Persistency/PersistentIStream.h"
#include "ThePEG/PDT/EnumParticles.h"
#include <cassert>
#include "Herwig++/Looptools/clooptools.h"
using namespace ThePEG::Helicity;
using namespace Herwig;
SSHPPVertex::SSHPPVertex() : theSw(0.), theMw(), theZfact(),
theQt1L(0.), theQt1R(0.), theQt1LR(0.),
theQt2L(0.), theQt2R(0.), theQt2LR(0.),
theQb1L(0.), theQb1R(0.), theQb1LR(0.),
theQb2L(0.), theQb2R(0.), theQb2LR(0.),
theLt1L(0.), theLt1R(0.), theLt1LR(0.),
theLt2L(0.), theLt2R(0.), theLt2LR(0.),
theSfmass(6,ZERO),
theTanB(0.),theSinA(0.),
theCosA(0.), theSinB(0.), theCosB(0.),
theSinApB(0.), theCosApB(0.),
theSinBmA(0.), theCosBmA(0.),
theCouplast(0.),
theq2last(), theHaveCoeff(false), theLastID(0) {
//PDG codes for particles at vertices
addToList(22,22,25);
addToList(22,22,35);
addToList(22,22,36);
}
void SSHPPVertex::persistentOutput(PersistentOStream & os) const {
os << theMSSM << theSw << ounit(theMw,GeV) << ounit(theZfact,GeV)
<< theQt1L << theQt1R << theQt1LR << theQt2L << theQt2R << theQt2LR
<< theQb1L << theQb1R << theQb1LR << theQb2L << theQb2R << theQb2LR
<< theLt1L << theLt1R << theLt1LR << theLt2L << theLt2R << theLt2LR
<< thetop << thebot << thetau << theTanB
<< theSinA << theCosA << theSinB << theCosB << theSinApB << theCosApB
<< theSinBmA << theCosBmA
<< ounit(theSfmass, GeV) << theU << theV;
}
void SSHPPVertex::persistentInput(PersistentIStream & is, int) {
is >> theMSSM >> theSw >> iunit(theMw,GeV) >> iunit(theZfact,GeV)
>> theQt1L >> theQt1R >> theQt1LR >> theQt2L >> theQt2R >> theQt2LR
>> theQb1L >> theQb1R >> theQb1LR >> theQb2L >> theQb2R >> theQb2LR
>> theLt1L >> theLt1R >> theLt1LR >> theLt2L >> theLt2R >> theLt2LR
>> thetop >> thebot >> thetau >> theTanB
>> theSinA >> theCosA >> theSinB >> theCosB >> theSinApB >> theCosApB
>> theSinBmA >> theCosBmA
>> iunit(theSfmass, GeV) >> theU >> theV;
}
ClassDescription<SSHPPVertex> SSHPPVertex::initSSHPPVertex;
// Definition of the static class description member.
void SSHPPVertex::Init() {
static ClassDocumentation<SSHPPVertex> documentation
("This class implements the higgs-gluon-gluon effective "
"vertex in the MSSM including stop, sbottom and top quarks "
"loops.");
}
void SSHPPVertex::setCoupling(Energy2 q2, tcPDPtr particle2,
tcPDPtr particle3, tcPDPtr particle1) {
long higgs(abs(particle1->id()));
// check allowed
assert ( higgs == ParticleID::h0 || higgs == ParticleID::H0 ||
higgs == ParticleID::A0 );
assert(particle2->id() == ParticleID::gamma &&
particle3->id() == ParticleID::gamma );
// couplings
if( q2 != theq2last || theCouplast == 0. || higgs != theLastID ) {
- clearcache();
+ Looptools::clearcache();
theCouplast = sqr(electroMagneticCoupling(q2))*weakCoupling(q2);
Energy mt = theMSSM->mass(q2, thetop);
Energy mb = theMSSM->mass(q2, thebot);
Energy mtau = theMSSM->mass(q2, thetau);
masses.resize(0);
type.resize(0);
if( higgs == ParticleID::h0 || higgs == ParticleID::H0 ) {
setNParticles(13);
masses.insert(masses.begin(), theSfmass.begin(), theSfmass.end());
masses.push_back(mt);
masses.push_back(mb);
masses.push_back(mtau);
masses.push_back(getParticleData(ParticleID::Hplus)->mass());
masses.push_back(theMw);
masses.push_back(getParticleData(ParticleID::SUSY_chi_1plus)->mass());
masses.push_back(getParticleData(ParticleID::SUSY_chi_2plus)->mass());
type.resize(13, PDT::Spin0);
type[6] = PDT::Spin1Half;
type[7] = PDT::Spin1Half;
type[8] = PDT::Spin1Half;
type[9] = PDT::Spin0;
type[10] = PDT::Spin1;
type[11] = PDT::Spin1Half;
type[12] = PDT::Spin1Half;
couplings.resize(13, make_pair(0., 0.));
complex<Energy> brac1 = theZfact*(0.5 + theMSSM->ed()*sqr(theSw));
complex<Energy> brac2 = theZfact*(0.5 - theMSSM->eu()*sqr(theSw));
complex<Energy> brac3 = theZfact*theMSSM->ed()*sqr(theSw);
complex<Energy> brac4 = theZfact*theMSSM->eu()*sqr(theSw);
complex<Energy> brac5 = theZfact*(0.5 + theMSSM->ee()*sqr(theSw));
complex<Energy> brac6 = theZfact*theMSSM->ee()*sqr(theSw);
Energy Trib=theMSSM->bottomTrilinear().real();
Energy Trit=theMSSM->topTrilinear().real();
Energy Trita=theMSSM->tauTrilinear().real();
Energy theMu = theMSSM->muParameter();
if( higgs == ParticleID::h0 ) {
// lightest sbottom
Complex coup = 3.*UnitRemoval::InvE*sqr(theMSSM->ed())*
(theQb1L *( sqr(mb)*theSinA/theMw/theCosB - theSinApB*brac1) +
theQb1R *( sqr(mb)*theSinA/theMw/theCosB + theSinApB*brac3) +
theQb1LR*0.5*mb/theMw*(Trib*theSinA + theMu*theCosA)/theCosB);
couplings[0] = make_pair(coup, coup);
// lightest stop
coup = 3.*UnitRemoval::InvE*sqr(theMSSM->eu())*
(theQt1L *( - sqr(mt)*theCosA/theMw/theSinB + theSinApB*brac2) +
theQt1R *( - sqr(mt)*theCosA/theMw/theSinB + theSinApB*brac4) -
theQt1LR*0.5*mt/theMw*(Trit*theCosA + theMu*theSinA)/theSinB);
couplings[1] = make_pair(coup, coup);
// lightest stau
coup = UnitRemoval::InvE*sqr(theMSSM->ee())*
(theLt1L *( sqr(mtau)*theSinA/theMw/theCosB - theSinApB*brac5) +
theLt1R *( sqr(mtau)*theSinA/theMw/theCosB + theSinApB*brac6) +
theLt1LR*0.5*mtau/theMw*(Trita*theSinA + theMu*theCosA)/theCosB);
couplings[2] = make_pair(coup, coup);
// heavier sbottom
coup = 3.*UnitRemoval::InvE*sqr(theMSSM->ed())*
(theQb2L *( sqr(mb)*theSinA/theMw/theCosB - theSinApB*brac1) +
theQb2R *( sqr(mb)*theSinA/theMw/theCosB + theSinApB*brac3) +
theQb2LR*0.5*mb/theMw*(Trib*theSinA + theMu*theCosA)/theCosB);
couplings[3] = make_pair(coup, coup);
// heavier stop
coup = 3.*UnitRemoval::InvE*sqr(theMSSM->eu())*
(theQt2L*( - sqr(mt)*theCosA/theMw/theSinB + theSinApB*brac2) +
theQt2R*( - sqr(mt)*theCosA/theMw/theSinB + theSinApB*brac4) -
theQt2LR*0.5*mt/theMw*(Trit*theCosA + theMu*theSinA)/theSinB);
couplings[4] = make_pair(coup, coup);
// heavier stau
coup = UnitRemoval::InvE*sqr(theMSSM->ee())*
(theLt2L *( sqr(mtau)*theSinA/theMw/theCosB - theSinApB*brac5) +
theLt2R *( sqr(mtau)*theSinA/theMw/theCosB + theSinApB*brac6)+
theLt2LR*0.5*mtau/theMw*(Trita*theSinA + theMu*theCosA)/theCosB);
couplings[5] = make_pair(coup, coup);
// top
coup = - 3.*mt*sqr(theMSSM->eu())*theCosA/2./theMw/theSinB;
couplings[6] = make_pair(coup, coup);
// bottom
coup = 3.*mb*sqr(theMSSM->ed())*theSinA/2./theMw/theCosB;
couplings[7] = make_pair(coup, coup);
// tau
coup = mtau*sqr(theMSSM->ee())*theSinA/2./theMw/theCosB;
couplings[8] = make_pair(coup, coup);
// charged higgs
coup = - UnitRemoval::InvE*theMw*(theSinBmA + 0.5/(1.-sqr(theSw))*
(sqr(theCosB)-sqr(theSinB))*theSinApB);
couplings[9] = make_pair(coup, coup);
// W boson
coup = UnitRemoval::InvE*theMw*theSinBmA;
couplings[10] = make_pair(coup, coup);
// charginos
for(unsigned int ix=0;ix<2;++ix) {
Complex Q = sqrt(0.5)*(*theV)(ix,0)*(*theU)(ix,1);
Complex S = sqrt(0.5)*(*theV)(ix,1)*(*theU)(ix,0);
coup = Q*theSinA-S*theCosA;
couplings[11+ix] = make_pair(conj(coup), coup);
}
}
else {
// lightest sbottom
Complex coup = 3.*UnitRemoval::InvE*sqr(theMSSM->ed())*
(theQb1L *( - sqr(mb)*theCosA/theMw/theCosB + theCosApB*brac1) +
theQb1R *( - sqr(mb)*theCosA/theMw/theCosB - theCosApB*brac3)+
theQb1LR*0.5*mb/theMw*(theMu*theSinA - Trib*theCosA)/theCosB);
couplings[0] = make_pair(coup, coup);
// lightest stop
coup = 3.*UnitRemoval::InvE*sqr(theMSSM->eu())*
(theQt1L *( - sqr(mt)*theSinA/theMw/theSinB - theCosApB*brac2) +
theQt1R *( - sqr(mt)*theSinA/theMw/theSinB - theCosApB*brac4)-
theQt1LR*0.5*mt/theMw*(-theMu*theCosA + Trit*theSinA)/theSinB);
couplings[1] = make_pair(coup, coup);
// lightest stau
coup = UnitRemoval::InvE*sqr(theMSSM->ee())*
(theLt1L *( - sqr(mtau)*theCosA/theMw/theCosB + theCosApB*brac5) +
theLt1R *( - sqr(mtau)*theCosA/theMw/theCosB - theCosApB*brac6)+
theLt1LR*0.5*mtau/theMw*(theMu*theSinA - Trita*theCosA)/theCosB);
couplings[2] = make_pair(coup, coup);
// heavier sbottom
coup = 3.*UnitRemoval::InvE*sqr(theMSSM->ed())*
(theQb2L *( - sqr(mb)*theCosA/theMw/theCosB + theCosApB*brac1) +
theQb2R *( - sqr(mb)*theCosA/theMw/theCosB - theCosApB*brac3)+
theQb2LR*0.5*mb/theMw*(theMu*theSinA - Trib*theCosA)/theCosB);
couplings[3] = make_pair(coup, coup);
// heavier stop
coup = 3.*UnitRemoval::InvE*sqr(theMSSM->eu())*
(theQt2L *( - sqr(mt)*theSinA/theMw/theSinB - theCosApB*brac2) +
theQt2R *( - sqr(mt)*theSinA/theMw/theSinB - theCosApB*brac4)-
theQt2LR*0.5*mt/theMw*(-theMu*theCosA + Trit*theSinA)/theSinB);
couplings[4] = make_pair(coup, coup);
// heavier stau
coup = UnitRemoval::InvE*sqr(theMSSM->ee())*
(theLt2L *( - sqr(mtau)*theCosA/theMw/theCosB + theCosApB*brac5) +
theLt2R *( - sqr(mtau)*theCosA/theMw/theCosB - theCosApB*brac6)+
theLt2LR*0.5*mtau/theMw*(theMu*theSinA - Trita*theCosA)/theCosB);
couplings[5] = make_pair(coup, coup);
// top
coup = -3.*mt*sqr(theMSSM->eu())*theSinA/2./theMw/theSinB;
couplings[6] = make_pair(coup, coup);
// bottom
coup = -3.*mb*sqr(theMSSM->ed())*theCosA/2./theMw/theCosB;
couplings[7] = make_pair(coup, coup);
// bottom
coup = -mtau*sqr(theMSSM->ee())*theCosA/2./theMw/theCosB;
couplings[8] = make_pair(coup, coup);
// charged higgs
coup = - UnitRemoval::InvE*theMw*(theCosBmA - 0.5/(1.-sqr(theSw))*
(sqr(theCosB)-sqr(theSinB))*theCosApB);
couplings[9] = make_pair(coup, coup);
// W boson
coup = UnitRemoval::InvE*theMw*theCosBmA;
couplings[10] = make_pair(coup, coup);
// charginos
for(unsigned int ix=0;ix<2;++ix) {
Complex Q = sqrt(0.5)*(*theV)(ix,0)*(*theU)(ix,1);
Complex S = sqrt(0.5)*(*theV)(ix,1)*(*theU)(ix,0);
coup = -Q*theCosA-S*theSinA;
couplings[11+ix] = make_pair(conj(coup), coup);
}
}
}
else {
setNParticles(5);
masses.resize(5);
couplings.resize(5);
masses[0] = mt;
masses[1] = mb;
masses[2] = mtau;
masses[3] = getParticleData(ParticleID::SUSY_chi_1plus)->mass();
masses[4] = getParticleData(ParticleID::SUSY_chi_2plus)->mass();
type.resize(5,PDT::Spin1Half);
// top
Complex coup = 3.*Complex(0., 1.)*sqr(theMSSM->eu())*mt/2./theMw/theTanB;
couplings[0] = make_pair(coup, -coup);
// bottom
coup = 3.*Complex(0., 1.)*sqr(theMSSM->ed())*mb/2./theMw*theTanB;
couplings[1] = make_pair(coup, -coup);
// tau
coup = Complex(0., 1.)*sqr(theMSSM->ee())*mtau/2./theMw*theTanB;
couplings[2] = make_pair(coup, -coup);
// charginos
for(unsigned int ix=0;ix<2;++ix) {
Complex Q = sqrt(0.5)*(*theV)(ix,0)*(*theU)(ix,1);
Complex S = sqrt(0.5)*(*theV)(ix,1)*(*theU)(ix,0);
coup = - Complex(0., 1.)*(Q*theSinB+S*theCosB);
couplings[3+ix] = make_pair(coup, - coup);
}
}
theq2last = q2;
theLastID = higgs;
theHaveCoeff = false;
}
norm(theCouplast);
//calculate tensor coefficients
if( !theHaveCoeff ) {
VVSLoopVertex::setCoupling(q2, particle2, particle3, particle1);
theHaveCoeff = true;
}
}
// functions for loops for testing
// namespace {
// Complex F0(double tau) {
// Complex ft;
// if(tau>=1.)
// ft = sqr(asin(1./sqrt(tau)));
// else {
// double etap = 1.+sqrt(1.-tau);
// double etam = 1.-sqrt(1.-tau);
// ft = -0.25*sqr(log(etap/etam)-Constants::pi*Complex(0.,1.));
// }
// return tau*(1.-tau*ft);
// }
// Complex FHalf(double tau,double eta) {
// Complex ft;
// if(tau>=1.)
// ft = sqr(asin(1./sqrt(tau)));
// else {
// double etap = 1.+sqrt(1.-tau);
// double etam = 1.-sqrt(1.-tau);
// ft = -0.25*sqr(log(etap/etam)-Constants::pi*Complex(0.,1.));
// }
// return -2.*tau*(eta+(1.-tau*eta)*ft);
// }
// Complex F1(double tau) {
// Complex ft;
// if(tau>=1.)
// ft = sqr(asin(1./sqrt(tau)));
// else {
// double etap = 1.+sqrt(1.-tau);
// double etam = 1.-sqrt(1.-tau);
// ft = -0.25*sqr(log(etap/etam)-Constants::pi*Complex(0.,1.));
// }
// return 2.+3.*tau+3.*tau*(2.-tau)*ft;
// }
// }
void SSHPPVertex::doinit() {
theMSSM = dynamic_ptr_cast<tMSSMPtr>(generator()->standardModel());
if( !theMSSM )
throw InitException()
<< "SSHPPVertex::doinit() - The pointer to the MSSM object is null!"
<< Exception::abortnow;
theMw = getParticleData(ParticleID::Wplus)->mass();
thetop = getParticleData(ParticleID::t);
thebot = getParticleData(ParticleID::b);
thetau = getParticleData(ParticleID::tauminus);
theSw = sqrt(sin2ThetaW());
theZfact = getParticleData(ParticleID::Z0)->mass()/sqrt(1. - sqr(theSw));
theSinA = sin(theMSSM->higgsMixingAngle());
theCosA = sqrt(1. - sqr(theSinA));
theTanB = theMSSM->tanBeta();
theSinB = theTanB/sqrt(1. + sqr(theTanB));
theCosB = sqrt( 1. - sqr(theSinB) );
theSinApB = theSinA*theCosB + theCosA*theSinB;
theCosApB = theCosA*theCosB - theSinA*theSinB;
theSinBmA =-theSinA*theCosB + theCosA*theSinB;
theCosBmA = theCosA*theCosB + theSinA*theSinB;
MixingMatrix stop = *theMSSM->stopMix();
MixingMatrix sbot = *theMSSM->sbottomMix();
MixingMatrix stau = *theMSSM->stauMix();
theQt1L = stop(0,0)*stop(0,0);
theQt1R = stop(0,1)*stop(0,1);
theQt1LR = stop(0,1)*stop(0,0) + stop(0,1)*stop(0,0);
theQt2L = stop(1,0)*stop(1,0);
theQt2R = stop(1,1)*stop(1,1);
theQt2LR = stop(1,1)*stop(1,0) + stop(1,0)*stop(1,1);
theQb1L = sbot(0,0)*sbot(0,0);
theQb1R = sbot(0,1)*sbot(0,1);
theQb1LR = sbot(0,1)*sbot(0,0) + sbot(0,1)*sbot(0,0);
theQb2L = sbot(1,0)*sbot(1,0);
theQb2R = sbot(1,1)*sbot(1,1);
theQb2LR = sbot(1,1)*sbot(1,0) + sbot(1,0)*sbot(1,1);
theLt1L = stau(0,0)*stau(0,0);
theLt1R = stau(0,1)*stau(0,1);
theLt1LR = stau(0,1)*stau(0,0) + stau(0,1)*stau(0,0);
theLt2L = stau(1,0)*stau(1,0);
theLt2R = stau(1,1)*stau(1,1);
theLt2LR = stau(1,1)*stau(1,0) + stau(1,0)*stau(1,1);
theU = theMSSM->charginoUMix();
theV = theMSSM->charginoVMix();
assert( theSfmass.size() == 6 );
theSfmass[0] = getParticleData(ParticleID::SUSY_b_1)->mass();
theSfmass[1] = getParticleData(ParticleID::SUSY_t_1)->mass();
theSfmass[2] = getParticleData(ParticleID::SUSY_tau_1minus)->mass();
theSfmass[3] = getParticleData(ParticleID::SUSY_b_2)->mass();
theSfmass[4] = getParticleData(ParticleID::SUSY_t_2)->mass();
theSfmass[5] = getParticleData(ParticleID::SUSY_tau_2minus)->mass();
orderInGs(0);
orderInGem(3);
VVSLoopVertex::doinit();
// test calc of the width
// for(unsigned int ix=0;ix<2;++ix) {
// Energy mh = getParticleData(25+long(ix)*10)->mass();
// Energy mt = theMSSM->mass(sqr(mh ), thetop);
// Energy mb = theMSSM->mass(sqr(mh ), thebot);
// Energy mtau = theMSSM->mass(sqr(mh ), thetau);
// Energy mhp = getParticleData(ParticleID::Hplus)->mass();
// Energy mc[2] = {getParticleData(ParticleID::SUSY_chi_1plus)->mass(),
// getParticleData(ParticleID::SUSY_chi_2plus)->mass()};
// // sbottom
// Complex rsb1,rsb2;
// if(ix==0) {
// rsb1 =
// +theQb1L*(-sqr(mb/theMw)*(1.-sqr(theSw))*theSinA/theCosB
// -(-0.5+sqr(theSw)/3.)*theSinApB)
// +theQb1R*(-sqr(mb/theMw)*(1.-sqr(theSw))*theSinA/theCosB
// +sqr(theSw)/3.*theSinApB);
// rsb2 =
// +theQb2L*(-sqr(mb/theMw)*(1.-sqr(theSw))*theSinA/theCosB
// -(-0.5+sqr(theSw)/3.)*theSinApB)
// +theQb2R*(-sqr(mb/theMw)*(1.-sqr(theSw))*theSinA/theCosB
// +sqr(theSw)/3.*theSinApB);
// }
// else {
// rsb1 =
// +theQb1L*(+sqr(mb/theMw)*(1.-sqr(theSw))*theCosA/theCosB
// +(-0.5+sqr(theSw)/3.)*theCosApB)
// +theQb1R*(+sqr(mb/theMw)*(1.-sqr(theSw))*theCosA/theCosB
// -sqr(theSw)/3.*theCosApB);
// rsb2 =
// +theQb2L*(+sqr(mb/theMw)*(1.-sqr(theSw))*theCosA/theCosB
// +(-0.5+sqr(theSw)/3.)*theCosApB)
// +theQb2R*(+sqr(mb/theMw)*(1.-sqr(theSw))*theCosA/theCosB
// -sqr(theSw)/3.*theCosApB);
// }
// Complex Isb1 = 3.*sqr(1./3.)*rsb1*sqr(theMw/theSfmass[0])/(1.-sqr(theSw))
// *F0(sqr(2.*theSfmass[0]/mh));
// Complex Isb2 = 3.*sqr(1./3.)*rsb2*sqr(theMw/theSfmass[3])/(1.-sqr(theSw))
// *F0(sqr(2.*theSfmass[3]/mh));
// // stop
// Complex rst1,rst2;
// if(ix==0) {
// rst1 =
// +theQt1L*(+sqr(mt/theMw)*(1.-sqr(theSw))*theCosA/theSinB
// -(+0.5-2.*sqr(theSw)/3.)*theSinApB)
// +theQt1R*(+sqr(mt/theMw)*(1.-sqr(theSw))*theCosA/theSinB
// -2.*sqr(theSw)/3.*theSinApB);
// rst2 =
// +theQt2L*(+sqr(mt/theMw)*(1.-sqr(theSw))*theCosA/theSinB
// -(+0.5-2.*sqr(theSw)/3.)*theSinApB)
// +theQt2R*(+sqr(mt/theMw)*(1.-sqr(theSw))*theCosA/theSinB
// -2.*sqr(theSw)/3.*theSinApB);
// }
// else {
// rst1 =
// +theQt1L*(+sqr(mt/theMw)*(1.-sqr(theSw))*theSinA/theSinB
// +(+0.5-2.*sqr(theSw)/3.)*theCosApB)
// +theQt1R*(+sqr(mt/theMw)*(1.-sqr(theSw))*theSinA/theSinB
// +2.*sqr(theSw)/3.*theCosApB);
// rst2 =
// +theQt2L*(+sqr(mt/theMw)*(1.-sqr(theSw))*theSinA/theSinB
// +(+0.5-2.*sqr(theSw)/3.)*theCosApB)
// +theQt2R*(+sqr(mt/theMw)*(1.-sqr(theSw))*theSinA/theSinB
// +2.*sqr(theSw)/3.*theCosApB);
// }
// Complex Ist1 = 3.*sqr(2./3.)*rst1*sqr(theMw/theSfmass[1])/(1.-sqr(theSw))
// *F0(sqr(2.*theSfmass[1]/mh));
// Complex Ist2 = 3.*sqr(2./3.)*rst2*sqr(theMw/theSfmass[4])/(1.-sqr(theSw))
// *F0(sqr(2.*theSfmass[4]/mh));
// // stau
// Complex rstau1,rstau2;
// if(ix==0) {
// rstau1 =
// +theLt1L*(-sqr(mtau/theMw)*(1.-sqr(theSw))*theSinA/theCosB
// -(-0.5+sqr(theSw))*theSinApB)
// +theLt1R*(-sqr(mtau/theMw)*(1.-sqr(theSw))*theSinA/theCosB
// +sqr(theSw)*theSinApB);
// rstau2 =
// +theLt2L*(-sqr(mtau/theMw)*(1.-sqr(theSw))*theSinA/theCosB
// -(-0.5+sqr(theSw))*theSinApB)
// +theLt2R*(-sqr(mtau/theMw)*(1.-sqr(theSw))*theSinA/theCosB
// +sqr(theSw)*theSinApB);
// }
// else {
// rstau1 =
// +theLt1L*(+sqr(mtau/theMw)*(1.-sqr(theSw))*theCosA/theCosB
// +(-0.5+sqr(theSw))*theCosApB)
// +theLt1R*(+sqr(mtau/theMw)*(1.-sqr(theSw))*theCosA/theCosB
// -sqr(theSw)*theCosApB);
// rstau2 =
// +theLt2L*(+sqr(mtau/theMw)*(1.-sqr(theSw))*theCosA/theCosB
// +(-0.5+sqr(theSw))*theCosApB)
// +theLt2R*(+sqr(mtau/theMw)*(1.-sqr(theSw))*theCosA/theCosB
// -sqr(theSw)*theCosApB);
// }
// Complex Istau1 = rstau1*sqr(theMw/theSfmass[2])/(1.-sqr(theSw))
// *F0(sqr(2.*theSfmass[2]/mh));
// Complex Istau2 = rstau2*sqr(theMw/theSfmass[5])/(1.-sqr(theSw))
// *F0(sqr(2.*theSfmass[5]/mh));
// // charged higgs
// Complex rh;
// if(ix==0) {
// rh = theSinBmA+0.5*(sqr(theCosB)-sqr(theSinB))*theSinApB/(1.-sqr(theSw));
// }
// else {
// rh = theCosBmA-0.5*(sqr(theCosB)-sqr(theSinB))*theCosApB/(1.-sqr(theSw));
// }
// Complex Ih = rh*sqr(theMw/mhp)*F0(sqr(2.*mhp/mh));
// // W
// Complex rw;
// if(ix==0) {
// rw = theSinBmA;
// }
// else {
// rw = theCosBmA;
// }
// Complex IW = rw*F1(sqr(2.*theMw/mh));
// // top
// Complex rt;
// if(ix==0) {
// rt = theCosA/theSinB;
// }
// else {
// rt = theSinA/theSinB;
// }
// Complex Itop = 3.*sqr(2./3.)*rt*FHalf(sqr(2.*mt/mh),1.);
// // bottom
// Complex rb;
// if(ix==0) {
// rb =-theSinA/theCosB;
// }
// else {
// rb = theCosA/theCosB;
// }
// Complex Ibot = 3.*sqr(1./3.)*rb*FHalf(sqr(2.*mb/mh),1.);
// // tau
// Complex rtau;
// if(ix==0) {
// rtau =-theSinA/theCosB;
// }
// else {
// rtau = theCosA/theCosB;
// }
// Complex Itau = rtau*FHalf(sqr(2.*mtau/mh),1.);
// // charginos
// Complex rc[2],IC[2];
// for(unsigned int ic=0;ic<2;++ic) {
// Complex Q = sqrt(0.5)*(*theV)(ic,0)*(*theU)(ic,1);
// Complex S = sqrt(0.5)*(*theV)(ic,1)*(*theU)(ic,0);
// if(ix==0) {
// rc[ic] = 2.*(S*theCosA-Q*theSinA);
// }
// else {
// rc[ic] = 2.*(S*theSinA+Q*theCosA);
// }
// IC[ic] = rc[ic]*FHalf(sqr(2.*mc[ic]/mh),1.)*theMw/mc[ic];
// }
// Energy pre = sqr(mh/theMw)*mh/1024./pow(Constants::pi,3)
// *sqr(weakCoupling(sqr(mh))*sqr(electroMagneticCoupling(sqr(mh)))/4./Constants::pi);
// cerr << "testing lighter sbottom" << ix << " "
// << pre*std::norm(Isb1)/GeV << "\n";
// cerr << "testing heavier sbottom" << ix << " "
// << pre*std::norm(Istau2)/GeV << "\n";
// cerr << "testing lighter stop" << ix << " "
// << pre*std::norm(Ist1)/GeV << "\n";
// cerr << "testing heavier stop" << ix << " "
// << pre*std::norm(Ist2)/GeV << "\n";
// cerr << "testing lighter stau" << ix << " "
// << pre*std::norm(Istau1)/GeV << "\n";
// cerr << "testing heavier stau" << ix << " "
// << pre*std::norm(Isb2)/GeV << "\n";
// cerr << "testing top " << ix << " "
// << pre*std::norm(Itop)/GeV << "\n";
// cerr << "testing bottom " << ix << " "
// << pre*std::norm(Ibot)/GeV << "\n";
// cerr << "testing tau " << ix << " "
// << pre*std::norm(Itau)/GeV << "\n";
// cerr << "testing higgs " << ix << " "
// << pre*std::norm(Ih)/GeV << "\n";
// cerr << "testing W " << ix << " "
// << pre*std::norm(IW)/GeV << "\n";
// cerr << "testing chi1 " << ix << " "
// << pre*std::norm(IC[0])/GeV << "\n";
// cerr << "testing chi2 " << ix << " "
// << pre*std::norm(IC[1])/GeV << "\n";
// cerr << "testing chi " << ix << " "
// << pre*std::norm(IC[0]+IC[1])/GeV << "\n";
// cerr << "testing higgs width " << ix << " "
// << pre*std::norm(Isb1+Isb2+Ist1+Ist2+Istau1+Istau2+
// Itop+Ibot+Itau+Ih+IW+IC[0]+IC[1])/GeV << "\n";
// }
+ Looptools::ltexi();
}
diff --git a/lib/Makefile.am b/lib/Makefile.am
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -1,32 +1,32 @@
pkglib_LTLIBRARIES = Herwig.la
Herwig_la_SOURCES =
Herwig_la_LIBTOOLFLAGS = --tag=CXX
Herwig_la_LDFLAGS = -module -version-info 7:0:0
Herwig_la_LDFLAGS += $(THEPEGLDFLAGS) $(FCLIBS)
Herwig_la_LIBADD = \
$(top_builddir)/Hadronization/libHwHadronization.la \
$(top_builddir)/Models/StandardModel/libHwStandardModel.la \
$(top_builddir)/Decay/libHwDecay.la \
$(top_builddir)/Decay/FormFactors/libHwFormFactor.la \
$(top_builddir)/Decay/Radiation/libHwDecRad.la \
$(top_builddir)/Utilities/libHwUtils.la \
$(top_builddir)/Models/General/libHwModelGenerator.la \
$(top_builddir)/Decay/General/libHwGeneralDecay.la \
$(top_builddir)/MatrixElement/General/libHwGeneralME.la \
$(top_builddir)/MatrixElement/libHwME.la \
$(top_builddir)/Decay/WeakCurrents/libHwWeakCurrent.la \
-$(top_builddir)/Looptools/libHwLooptoolsXFC.la \
+$(top_builddir)/Looptools/libHwLooptools.la \
$(top_builddir)/Shower/libHwShower.la \
$(THEPEGLIB) -ldl
all-local: done-all-links
done-all-links: Herwig.la
if test ! -L Herwig++ ; then $(LN_S) -f . Herwig++ ; fi
find $(top_builddir) \( -name '*.so.*' -or -name '*.so' \) \
-not -name 'lib*' -not -path '$(top_builddir)/lib/*' -exec $(LN_S) -f \{\} \;
$(LN_S) -f .libs/Herwig*so* .
echo "stamp" > done-all-links
clean-local:
rm -f *.so *.so.* done-all-links

File Metadata

Mime Type
text/x-diff
Expires
Thu, Apr 24, 6:35 AM (1 d, 19 h)
Storage Engine
local-disk
Storage Format
Raw Data
Storage Handle
04/fe/b978160286d4bad089d2fcc6f0d9
Default Alt Text
(1 MB)

Event Timeline