Commit 646afc83 authored by ulrich_y's avatar ulrich_y

Merge branch 'bugfix-polylog-conjg'

parents 87817de8 09592838
......@@ -32,6 +32,9 @@ PROGRAM TEST
call do_timing_tests(5)
call do_high_weight_tests
#endif
#ifdef LONG_TEST
call do_long_test
#endif
#endif
#endif
......@@ -41,6 +44,7 @@ PROGRAM TEST
print*, 'Some tests failed. '
stop 1
end if
stop
CONTAINS
......@@ -330,50 +334,83 @@ CONTAINS
! Thanks to Roman Zwicky and Ben Pullin for these tests
ref = (0.392707112217551702879328061598355445_prec, - 1.274969448494380061814943180491890080_prec)
print*, ' ', 'testing GPL ', 'F.1', ' ...'
res = G( (/ (0._prec,0.), (1._prec,0.), (0._prec, 1.5_prec) /) )
call check(res,ref)
call test_one_flat((/ (0._prec,0.), (1._prec,0.), (0._prec, 1.5_prec) /),ref,'F.1')
ref = (2.09624324167194065961839363660174566_prec, 0.62644605179087454819421905065313983_prec)
print*, ' ', 'testing GPL ', 'F.2', ' ...'
res = G( (/ (1._prec,0.), (-1._prec,0.), (2.5_prec, -2.4_prec) /) )
call check(res,ref)
call test_one_flat( (/ (1._prec,0.), (-1._prec,0.), (2.5_prec, -2.4_prec) /) , ref, 'F.2')
ref = conjg(ref)
print*, ' ', 'testing GPL ', 'F.3', ' ...'
res = G( (/ (1._prec,0.), (-1._prec,0.), (2.5_prec, +2.4_prec) /) )
call check(res,ref)
call test_one_flat( (/ (1._prec,0.), (-1._prec,0.), (2.5_prec, +2.4_prec) /) , ref, 'F.3')
ref = (0.6874619495289224183167486785286777066_prec, -1.8261934916106546308783576818077830287_prec)
print*, ' ', 'testing GPL ', 'F.4', ' ...'
res = G( (/ (-1._prec,0.), (1._prec,0.), (2.5_prec, +2.4_prec) /) )
call check(res,ref)
call test_one_flat( (/ (-1._prec,0.), (1._prec,0.), (2.5_prec, +2.4_prec) /) , ref, 'F.4')
ref = (0.320016770069038023050391296154549_prec , 0.064263450879286017225353602844105_prec)
print*, ' ', 'testing GPL ', 'F.5', ' ...'
res = G( (/ (0._prec,0.), (1._prec,0.), (-1._prec,0.), (0.3_prec, -1.2_prec) /) )
call check(res,ref)
call test_one_flat( (/ (0._prec,0.), (1._prec,0.), (-1._prec,0.), (0.3_prec, -1.2_prec) /) , ref, 'F.5')
ref = conjg(ref)
print*, ' ', 'testing GPL ', 'F.6', ' ...'
res = G( (/ (0._prec,0.), (1._prec,0.), (-1._prec,0.), (0.3_prec, +1.2_prec) /) )
call check(res,ref)
call test_one_flat( (/ (0._prec,0.), (1._prec,0.), (-1._prec,0.), (0.3_prec, +1.2_prec) /) , ref, 'F.6')
ref = (0.8382358254435272068734922352_prec, - 0.3702062785327198487992149341_prec)
print*, ' ', 'testing GPL ', 'F.7', ' ...'
res = G( (/ (0._prec,0.), (1._prec,0.), (-1._prec,0.), (1.1_prec,2._prec) /) )
call check(res,ref)
call test_one_flat( (/ (0._prec,0.), (1._prec,0.), (-1._prec,0.), (1.1_prec,2._prec) /) , ref, 'F.7')
ref = (0.185156872427485220072774923047908301422_prec,-0.249989197161429773744237773045427322847_prec)
print*, ' ', 'testing GPL ', 'F.8', ' ...'
res = G( (/ (1._prec,0.), (-1._prec,0.), (2.3_prec,-1._prec), (1.1_prec,-0.1_prec) /) )
call check(res,ref)
call test_one_flat( (/ (1._prec,0.), (-1._prec,0.), (2.3_prec,-1._prec), (1.1_prec,-0.1_prec) /) , ref, 'F.8')
ref = (-1.11161035333074623447215317094270858897_prec,-0.875225967273157437459269290416981432294_prec)
print*, ' ', 'testing GPL ', 'F.9', ' ...'
res = G( (/ (1._prec,0.), (1.1_prec,-0.1_prec), (1._prec,0.), (2.3_prec,-1.2_prec), (3.4_prec,9.7_prec) /) )
call test_one_flat( (/ (1._prec,0.), (1.1_prec,-0.1_prec), (1._prec,0.), (2.3_prec,-1.2_prec), (3.4_prec,9.7_prec) /) , ref, 'F.9')
ref = (-0.1109203962012759970680116512959180346924_prec,0.114779444698808046532782358409267479097_prec)
call test_one_flat( (/ (0._prec, 0.) , (-0.1_prec, - 0.3_prec), (1._prec,0.), (0.5_prec, 0._prec) /) , ref, 'F.10')
ref = (-0.108930339927322068475622176344923224046_prec,0.1122893584726586134006078500824852031925_prec)
call test_one_flat( (/ (-0.005_prec, 0.) , (-0.1_prec, - 0.3_prec), (1._prec,0.), (0.5_prec, 0._prec)/) , ref, 'F.11')
ref = (-1.00642162671475190543135817048062920163_prec,0.75972801214517468120067717498723544972_prec)
call test_one_flat( (/ (-0.005_prec, 0.) , (-0.1_prec, - 0.3_prec), (1._prec,0.), (1.5_prec, 0._prec)/) , ref, 'F.12')
ref = (-0.764543307991553066235740993950606803628_prec, 0.54861507469010653128533842086292369104_prec)
call test_one_flat( (/ (-0.1_prec, - 0.3_prec), (1._prec,0.), (-0.005_prec, 0.) , (0.5_prec, 0._prec)/) , ref, 'F.13')
ref = (4.52004218277686921073832347986485146573_prec,-1.812384329980915889835338149845575221705_prec)
call test_one_flat( (/ (1.005_prec,0.), (0._prec,0.), (1.1_prec,0.3_prec), (1._prec,0.) /) , ref, 'F.14')
ref = (1.6706939608077788063504210821631008732_prec,-0.631820518538505729899318406678510198266_prec)
call test_one_flat( (/ (1.1_prec,0.), (0._prec,0.), (1.1_prec,0.3_prec), (1._prec,0.) /) , ref, 'F.10')
ref = (0.198693810038777868937967610639933071867_prec,+0.72807783717224553483870820314753060868_prec)
call test_one_flat( (/ (0._prec,0.), (1.0_prec,0._prec), (1.1_prec,0.), (1.1_prec,+0.3_prec) /) , ref, 'F.11')
ref = (1.6706939608077788063504210821631008732_prec,-0.631820518538505729899318406678510198266_prec)
call test_one_flat( (/ (1.1_prec,0.), (0._prec,0._prec), (1.1_prec,+0.3_prec), (1._prec,0.) /) , ref, 'F.12')
ref = (0.1810339553848393655117844582129810543006_prec,+0.82543851493400141056822586864697825094_prec)
call test_one_flat( (/ (0._prec,0.), (1.0_prec,0._prec), (1._prec,0.), (1.1_prec,+0.3_prec) /) , ref, 'F.13')
ref = (-3.028608056170828558746818459366566689807_prec,-0.52999686156911157999452896083600882192_prec)
call test_one_flat( (/ (1._prec,0._prec), (0.0_prec,0._prec), (0._prec,1._prec), (1.1_prec,0.0_prec) /) , ref, 'F.14')
! Here the branch cut matters, in Mathematica this is entered as G(1_-, 0, -I, -1.1)
ref = (0.0538179677556747874824671812943783830465_prec,0.340519960719077282936661573786600733497_prec)
print*, ' ', 'testing GPL ', 'F.15', ' ...'
res = G((/ inum(1._prec,-1), izero, inum((0._prec,-1._prec), -1) /), inum(-1.1_prec, +1))
call check(res,ref)
ref = (0.0075181720252360930529649927100295277234_prec,0.009279206321129807482628652573319115651_prec)
call test_one_flat( (/ (0._prec,0.), (0._prec,0.), (1.0_prec,0._prec), (0.1_prec,-0.1_prec), (0.11_prec,0._prec) /) , ref, 'F.16')
ref = (0.0135493735561310633082925053080300174678_prec,+0.01851696361979639851211857931403696163_prec)
call test_one_flat( (/ (0._prec,0.), (0._prec,0.), (1.0_prec,0._prec), (0.1_prec,-0.1_prec), (0.15_prec,0._prec) /) , ref, 'F.17')
ref = (-2.41176903997917647290181947143140323970805e-4_prec,0.00129690184788114442363777169655122)
call test_one_flat( (/ (0._prec,0.), (1._prec,0.), (0.5_prec,-0.1_prec), (-1.3_prec,10.2_prec), (0.4_prec,0._prec) /) , ref, 'F.18')
ref = (-0.003113755848404291707649322614093090379815_prec,-4.6914973893242872720303973859400498154E-4_prec)
call test_one_flat( (/ (0._prec,0.), (1._prec,0.), (0.1_prec,-0.1_prec), (-1.3_prec,10.2_prec), (0.4_prec,0._prec) /) , ref, 'F.19')
end subroutine do_GPL_tests
......@@ -384,8 +421,12 @@ CONTAINS
#ifdef HAVE_MM
function evalt(arr, what)
#if KINDREAL==16
use ieps, only: inum2inum
#endif
implicit none
complex(kind=prec) :: arr(:), evalt, geval
complex(kind=prec) :: arr(:), evalt
complex(kind=8) :: geval
integer what, i, l
evalt =0.
......@@ -404,7 +445,11 @@ CONTAINS
if (what .eq. 0) then
evalt = G(arr(1:l))
elseif (what.eq.1) then
evalt = geval(arr(1:l),l)
#if KINDREAL==16
evalt = cmplx(geval(inum2inum(toinum(arr(1:l))),l),kind=prec)
#else
evalt = geval(toinum(arr(1:l)),l)
#endif
endif
end function
......@@ -636,7 +681,91 @@ CONTAINS
end subroutine
#endif
#ifdef LONG_TEST
SUBROUTINE DO_LONG_TEST
#if KINDREAL==16
use ieps,only:inum2inum
#endif
implicit none
integer,parameter :: nzero = 10
integer,parameter :: nieps = 30
integer,parameter :: ncmpl = 30
integer,parameter :: perweight(4) = (/ 100, 500, 30000, 50000 /)
real(kind=prec), parameter :: rrange = 1.5
type(inum), dimension(nzero+nieps+ncmpl) :: basis
type(inum), dimension(size(perweight)) :: args
type(inum), parameter :: ione = inum((1._prec,0._prec), di0)
integer i, j, w, seed, oldseed
integer(kind=1) i0
real(kind=prec) :: v, maxd
complex(kind=prec) :: ans(2)
complex(kind=8) :: geval
character,parameter :: cr = achar(13)
maxd=0._prec
seed = 112312
tol = 0.01
open(unit=9, action='write', form='unformatted', file="long-test.txt")
basis(1:nzero) = izero
do i=nzero+1,nzero+nieps
if (ran2(seed).gt.0.5) then
i0 = +1_1
else
i0 = -1_1
endif
v = 2*rrange*(ran2(seed) - 0.5)
basis(i) = inum(cmplx(v,kind=prec), i0)
enddo
do i=nzero+nieps+1,nzero+nieps+ncmpl
v = 2*rrange*(ran2(seed) - 0.5)
basis(i) = toinum(v*exp(i_*2*pi*ran2(seed)))
enddo
do w=1,size(perweight)
do i=1,perweight(w)
oldseed = seed
write( * , 900, advance='no' ) cr, i, perweight(w), w
args(1:w) = basis((/ (1+int(size(basis)*ran2(seed)),j=1,w) /))
#if KINDREAL==16
ans(1) = cmplx(geval(inum2inum([args(1:w),ione]), w+1),kind=prec)
#else
ans(1) = cmplx(geval([args(1:w),ione], w+1),kind=prec)
#endif
ans(2) = G(args(1:w),ione)
if ((abs(ans(1)) .gt. 1.e10).or.(abs(ans(2)) .gt. 1.e10)) then
print*," can't deal with",args," (seed was",oldseed,')'
print*,"GiNaC : ",ans(1)
print*,"handyG: ",ans(2)
cycle
endif
write(9) w,i,oldseed, abs(ans(1)-ans(2))
flush(9)
if(abs(ans(1)-ans(2)) > maxd) maxd = abs(ans(1)-ans(2))
if(abs(ans(1)-ans(2)) > tol) goto 123
enddo
print*,' done. largest=',maxd
maxd=0.
enddo
print*,maxd
close(9)
return
123 continue
print*,"Failed with delta",abs(ans(1)-ans(2))
print*,"Offending G was",args(1:w)
print*,ans
close(9)
900 FORMAT(a , 'Testing ',i5,'/',i5,' GPLs with w=',i1)
END SUBROUTINE
#endif
FUNCTION RAN2(randy)
! This is the usual "random"
......
......@@ -534,10 +534,6 @@ CONF_LD=${LD:-$CONF_FC}
if $CONF_QUAD ; then
if $HAVE_GINAC ; then
echo "GiNaC testing is not supported for quad-precision!" 1>&3
exit 1
fi
echo -n "does $CONF_FC support quad-precision... " 1>&3
rm -fr $test*
tee $test.f90 << _EOF_ 1>&2
......@@ -568,7 +564,7 @@ if $HAVE_GINAC ; then
eval addflag CXXFLAGS "-std=c++11"
if [[ ! -z "$CONF_PKGCONFIG" ]]; then
echo -n "Does pkg-config know about GiNaC... " 1>&3
if $CONF_PKGCONFIG --exists ginac ; then
if $CONF_PKGCONFIG --atleast-version=1.7.4 ginac ; then
echo "yes" 1>&3
eval addflag CXXFLAGS `$CONF_PKGCONFIG --cflags ginac`
eval addflag LFLAGS `$CONF_PKGCONFIG --libs ginac`
......@@ -579,24 +575,63 @@ if $HAVE_GINAC ; then
FOUND_GINAC=false
fi
fi
if ! $FOUNDGINAC ; then
FOUNDGINAC=`findlib ginac GINAC && findlib cln CLN`
if ! $FOUND_GINAC ; then
findlib ginac GINAC && findlib cln CLN && FOUND_GINAC=true
eval addflag LFLAGS "-L`dirname $CONF_GINAC`"
eval addflag LFLAGS "-L`dirname $CONF_CLN`"
eval addflag LFLAGS "-lginac -lcln"
fi
if $FOUNDGINAC; then
if $FOUND_GINAC; then
CONF_LD=${LD:-$CONF_CXX}
echo -n "Checking if GiNaC works... " 1>&3
tee $test.ginac.cpp << _EOF_ 1>&2
#include <ginac/ginac.h>
#include <iostream>
int main() {
#include <cln/cln.h>
typedef struct {double r,i;} complex_t;
typedef struct {complex_t c; signed char i0;} inum_t;
complex_t geval_(inum_t * z, int* n) {
cln::cl_inhibit_floating_point_underflow = true;
GiNaC::lst w,s;
for(long i=0;i<(*n)-1;i++)
{
GiNaC::ex zz;
if (abs(z->c.i) < 1e-15)
w.append((z->c.r));
else
w.append((z->c.r)+(z->c.i)*GiNaC::I);
s.append(z->i0);
z++;
}
GiNaC::ex ans = GiNaC::G(w,s,z->c.r).evalf();
return {
.r = GiNaC::ex_to<GiNaC::numeric>(GiNaC::evalf(GiNaC::real_part(ans))).to_double(),
.i = GiNaC::ex_to<GiNaC::numeric>(GiNaC::evalf(GiNaC::imag_part(ans))).to_double()
};
}
int main() {
// Test 1
GiNaC::ex ans = GiNaC::G(0.3,0.5,0.7);
ans -= 0.2876820724517808812+3.1415926535897932385*GiNaC::I;
ans = GiNaC::abs(ans);
if (ans<1e-15)
// Test 2
inum_t x[] = {
{ .c = {.r = 0.73, .i=0}, .i0 = -1 },
{ .c = {.r = 0.00, .i=0}, .i0 = +1 },
{ .c = {.r = 1.00, .i=0}, .i0 = +1 }
};
int n=3;
complex_t cans = geval_(&x[0],&n);
float del = (2.2982889094420660-cans.r)*(2.2982889094420660-cans.r) + (0.98869296399417417-cans.i)*(0.98869296399417417-cans.i);
if ( (ans<1e-15) && (del<1e-15) )
return 0;
else
return 1;
......
......@@ -5,21 +5,33 @@ using namespace GiNaC;
#include <iostream>
typedef struct {double r,i;} complex_t;
typedef struct {complex_t c; signed char i0;} inum_t;
extern "C"{
complex_t geval_(complex_t * z, int* n);
complex_t geval_(inum_t * z, int* n);
};
complex_t geval_(complex_t * z, int* n) {
complex_t geval_(inum_t * z, int* n) {
cln::cl_inhibit_floating_point_underflow = true;
lst w;
lst w,s;
for(long i=0;i<(*n)-1;i++)
{
w.append((z->r)+(z->i)*I);
ex zz;
if (abs(z->c.i) < 1e-15)
w.append((z->c.r));
else
w.append((z->c.r)+(z->c.i)*I);
s.append(z->i0);
z++;
}
ex ans = G(w,z->r).evalf();
return {
.r = ex_to<numeric>(evalf(real_part(ans))).to_double(),
.i = ex_to<numeric>(evalf(imag_part(ans))).to_double()
};
try {
ex ans = G(w,s,z->c.r).evalf();
return {
.r = ex_to<numeric>(evalf(real_part(ans))).to_double(),
.i = ex_to<numeric>(evalf(imag_part(ans))).to_double()
};
} catch (...) {
std::cout << "Caught!!\n";
return {.r = 1.e11, .i = 1.e11};
}
}
......@@ -15,7 +15,7 @@ MODULE globals
real(kind=prec), parameter :: pi = 3.1415926535897932384626433832795028841971693993751_prec
! The following parameters control the accuracy of the evaluation
real(kind=prec), protected :: MPLdel = zero ! if the MPL sum changes less then del it is truncated.
real(kind=prec), protected :: MPLdelta = zero ! if the MPL sum changes less then del it is truncated.
integer, protected :: PolylogInfinity = 1000 ! expansion order for Polylogs
real(kind=prec), protected :: HoelderCircle = 1.1_prec ! when to apply Hoelder convolution?
integer, parameter :: PolyLogCacheSize(2) = (/ 5, 100 /)
......@@ -49,7 +49,7 @@ CONTAINS
SUBROUTINE SET_OPTIONS(mpldel, liinf, hcircle)
real(kind=prec), optional :: hcircle, mpldel
integer, optional :: liinf
if (present(mpldel)) MPLdel = mpldel
if (present(MPLdel)) MPLdelta = mpldel
if (present(liinf)) PolyLogInfinity = liinf
if (present(hcircle)) HoelderCircle = hcircle
END SUBROUTINE
......
......@@ -52,9 +52,10 @@ CONTAINS
if(.not. present(y)) print*, 'G(', abs(z_flat), ')'
END SUBROUTINE print_G
RECURSIVE FUNCTION remove_sr_from_last_place_in_PI(a,y2,m,p) result(res)
RECURSIVE FUNCTION remove_sr_from_last_place_in_PI(a,y2,m,p, srs) result(res)
! here what is passed is not the full a vector, only a1, ..., ak without the trailing zeroes
integer :: m, i, j, n
integer(1) :: srs
type(inum) :: a(:), y2, s(m), p(:)
complex(kind=prec) :: res
type(inum) :: alpha(product((/(i,i=1,size(a)+size(s))/))/ &
......@@ -70,7 +71,7 @@ CONTAINS
print*, 'PI with p=',real(p),'i=',m,'g =',real([zeroes(m-1),y2])
end if
#endif
res = G_flat(a,y2)*pending_integral(p,m,[zeroes(m-1),y2])
res = G_flat(a,y2)*pending_integral(p,m,[zeroes(m-1),y2], srs)
#ifdef DEBUG
if(verb >= 50) print*, 'also mapping to'
#endif
......@@ -81,16 +82,17 @@ CONTAINS
if(verb >= 50) print*, 'PI with p=',real(p),'i=',n,'g =',&
real([alpha(j,1:n-1),alpha(j,n+1:size(alpha,2)),y2])
#endif
res = res - pending_integral(p, n, [alpha(j,1:n-1),alpha(j,n+1:size(alpha,2)),y2])
res = res - pending_integral(p, n, [alpha(j,1:n-1),alpha(j,n+1:size(alpha,2)),y2], srs)
end do
END FUNCTION remove_sr_from_last_place_in_PI
RECURSIVE FUNCTION pending_integral(p,i,g) result(res)
RECURSIVE FUNCTION pending_integral(p,i,g,srs) result(res)
! evaluates a pending integral by reducing it to simpler ones and g functions
complex(kind=prec) :: res
type(inum) :: p(:), g(:)
type(inum) :: y1, y2, b(size(p)-1), a(size(g)-1)
integer :: i, m
integer(1):: srs
res = 0
#ifdef DEBUG
......@@ -126,11 +128,8 @@ CONTAINS
#endif
!res = pending_integral(p,2,[sub_ieps(g(1))]) - pending_integral(p,2,[cmplx(0.0)]) &
! + G_flat(p(2:size(p)), p(1)) * log(-sub_ieps(g(1)))
if(abs(aimag(p(1))).gt.zero) then
p(1)%i0 = int(sign(1._prec, aimag(p(1))),1)
endif
res = pending_integral(p,2,[inum( g(1)%c,-g(1)%i0 ) ]) - pending_integral(p,2,[izero]) &
+ G_flat(p(2:size(p)), p(1)) * (log(g(1)%c) + p(1)%i0 * pi * i_)
res = pending_integral(p,2,[inum( g(1)%c,-srs ) ], srs) - pending_integral(p,2,[izero], srs) &
+ G_flat(p(2:size(p)), p(1)) * (log(g(1)%c) + srs * pi * i_)
return
end if
......@@ -151,9 +150,9 @@ CONTAINS
print*, 'PI with p=',tocmplx([p,izero]),'i=',m-1,'g =',tocmplx(zeroes(0))
end if
#endif
res = -zeta(m)*pending_integral(p,0,zeroes(0)) &
+ pending_integral([y2,izero],m-1,[zeroes(m-2),y2])*pending_integral(p,0,zeroes(0)) &
- pending_integral([p,izero] ,m-1,[zeroes(m-2),y2])
res = -zeta(m)*pending_integral(p,0,zeroes(0),srs) &
+ pending_integral([y2,izero],m-1,[zeroes(m-2),y2],srs)*pending_integral(p,0,zeroes(0),srs) &
- pending_integral([p,izero] ,m-1,[zeroes(m-2),y2],srs)
return
end if
......@@ -174,10 +173,10 @@ CONTAINS
end if
#endif
res = pending_integral(p,0,zeroes(0)) * G_flat([izero,a],y2) &
+ pending_integral([p,y2],0,zeroes(0)) * G_flat(a,y2) &
+ pending_integral([p,a(1)],1,[a(2:size(a)),y2]) &
- pending_integral([p,a(1)],0,zeroes(0)) * G_flat(a,y2)
res = pending_integral(p,0,zeroes(0),srs) * G_flat([izero,a],y2) &
+ pending_integral([p,y2],0,zeroes(0),srs) * G_flat(a,y2) &
+ pending_integral([p,a(1)],1,[a(2:size(a)),y2],srs) &
- pending_integral([p,a(1)],0,zeroes(0),srs) * G_flat(a,y2)
return
end if
......@@ -187,7 +186,7 @@ CONTAINS
if(verb >= 30) print*, 's_r at the end under PI, need to shuffle'
#endif
m = find_amount_trailing_zeros(a) + 1
res = remove_sr_from_last_place_in_PI(a(1:size(a)-(m-1)), y2, m, p)
res = remove_sr_from_last_place_in_PI(a(1:size(a)-(m-1)), y2, m, p, srs)
return
end if
......@@ -196,11 +195,11 @@ CONTAINS
if(verb >= 30) print*, 's_r in the middle under PI'
#endif
res = +pending_integral(p,1,zeroes(0)) * G_flat([a(1:i-1),izero,a(i:size(a))],y2) &
- pending_integral([p,a(i-1)],i-1,[a(1:i-2),a(i:size(a)),y2]) &
+ pending_integral([p,a(i-1)],1,zeroes(0)) * G_flat(a,y2) &
+ pending_integral([p,a(i)], i, [a(1:i-1), a(i+1:size(a)),y2]) &
- pending_integral([p,a(i)],1,zeroes(0)) * G_flat(a,y2)
res = +pending_integral(p,1,zeroes(0),srs) * G_flat([a(1:i-1),izero,a(i:size(a))],y2) &
- pending_integral([p,a(i-1)],i-1,[a(1:i-2),a(i:size(a)),y2],srs) &
+ pending_integral([p,a(i-1)],1,zeroes(0),srs) * G_flat(a,y2) &
+ pending_integral([p,a(i)], i, [a(1:i-1), a(i+1:size(a)),y2],srs) &
- pending_integral([p,a(i)],1,zeroes(0),srs) * G_flat(a,y2)
END FUNCTION pending_integral
RECURSIVE FUNCTION remove_sr_from_last_place_in_G(a,y2,m,sr) result(res)
......@@ -254,10 +253,9 @@ CONTAINS
print*, '--------------------------------------------------'
end if
#endif
res = G_flat([izero, a(i+1:size(a))], y2) &
+ G_flat([y2], sr) * G_flat(a(i+1:size(a)), y2) &
+ pending_integral([sr, a(i+1)], i, [a(i+2:size(a)), y2]) &
+ pending_integral([sr, a(i+1)], i, [a(i+2:size(a)), y2],sr%i0) &
- G_flat([a(i+1)],sr) * G_flat(a(i+1:size(a)), y2)
return
end if
......@@ -279,9 +277,9 @@ CONTAINS
#endif
res = G_flat([a(1:i-1),izero,a(i+1:size(a))],y2) &
- pending_integral([sr,a(i-1)], i-1, [a(1:i-2),a(i+1:size(a)),y2]) &
- pending_integral([sr,a(i-1)], i-1, [a(1:i-2),a(i+1:size(a)),y2],sr%i0) &
+ G_flat([a(i-1)],sr) * G_flat([a(1:i-1),a(i+1:size(a))],y2) &
+ pending_integral([sr,a(i+1)], i, [a(1:i-1),a(i+2:size(a)),y2]) &
+ pending_integral([sr,a(i+1)], i, [a(1:i-1),a(i+2:size(a)),y2],sr%i0) &
- G_flat([a(i+1)],sr) * G_flat([a(1:i-1),a(i+1:size(a))],y2)
END FUNCTION make_convergent
......@@ -398,6 +396,9 @@ CONTAINS
! ieps, which is what GiNaC does (l. 1013)
do j=1,size(z_flat)
znorm(j) = inum(z_flat(j)%c/y%c, z_flat(j)%i0)
if (abs(aimag(znorm(j)))>zero) then
znorm(j)%i0 = int(sign(1._prec, aimag(znorm(j))),1)
endif
enddo
res = G_flat(znorm,inum((1.,0.), y%i0))
return
......@@ -418,6 +419,9 @@ CONTAINS
! ieps, which is what GiNaC does (l. 1013)
do j=1,size(z_flat)
znorm(j) = inum(z_flat(j)%c/y%c, z_flat(j)%i0)
if (abs(aimag(znorm(j)))>zero) then
znorm(j)%i0 = int(sign(1._prec, aimag(znorm(j))),1)
endif
enddo
res = improve_convergence(znorm)
return
......@@ -443,7 +447,7 @@ CONTAINS
FUNCTION G_superflat(g) result(res)
! simpler notation for flat evaluation
complex(kind=prec) :: g(:), res
res = G_flat(toinum(g(1:size(g)-1)), inum(g(size(g)),di0))
res = G_flat(toinum(g(1:size(g)-1)), toinum(g(size(g))))
END FUNCTION G_superflat
FUNCTION G_real(g) result(res)
......@@ -522,7 +526,7 @@ CONTAINS
FUNCTION G_FLATc(Z_FLAT,Y)
complex(kind=prec), intent(in) :: z_flat(:), y
complex(kind=prec) :: g_flatc
g_flatc = G_flat(toinum(z_flat), inum(y,di0))
g_flatc = G_flat(toinum(z_flat), toinum(y))
END FUNCTION
......
......@@ -18,7 +18,7 @@ MODULE ieps
end interface abs
interface toinum
module procedure toinum_cmplx, toinum_real, toinum_reals, toinum_int
module procedure toinum_cmplxs, toinum_cmplx, toinum_real, toinum_reals, toinum_int
end interface toinum
interface tocmplx
module procedure tocmplxv, tocmplxs
......@@ -29,6 +29,20 @@ MODULE ieps
interface aimag
module procedure imags, imagv
end interface aimag
#if KINDREAL==16
#ifdef HAVE_GINAC
type inumD
complex(kind=8) :: c
integer(1) :: i0
end type inumD
interface inum2inum
module procedure inum2inumS, inum2inumV
end interface inum2inum
#endif
#endif
CONTAINS
FUNCTION ABSINUM(n1)
implicit none
......@@ -44,6 +58,21 @@ CONTAINS
absinumv = abs(n1%c)
END FUNCTION ABSINUMV
FUNCTION TOINUM_cmplxs(z, s)
complex(kind=prec) :: z
type(inum) :: toinum_cmplxs
integer(1),optional :: s
integer(1) :: ss
if (present(s)) then
ss = s
else
ss = di0
endif
toinum_cmplxs = inum(z, ss)
if (abs(aimag(z))>zero) then
toinum_cmplxs%i0 = int(sign(1._prec, aimag(z)),1)
endif
END FUNCTION TOINUM_cmplxs
FUNCTION TOINUM_cmplx(z, s)
complex(kind=prec) :: z(:)
type(inum) :: toinum_cmplx(size(z))
......@@ -57,6 +86,9 @@ CONTAINS
endif
do i=1,size(z)
toinum_cmplx(i) = inum(z(i), ss)
if (abs(aimag(z(i)))>zero) then
toinum_cmplx(i)%i0 = int(sign(1._prec, aimag(z(i))),1)
endif
enddo
END FUNCTION TOINUM_cmplx
......@@ -141,4 +173,23 @@ CONTAINS
imags = aimag(z%c)
END FUNCTION
#if KINDREAL==16
#ifdef HAVE_GINAC
FUNCTION INUM2INUMS(i)
type(inum ) :: i
type(inumD) :: inum2inums
inum2inums = inumD( cmplx(i%c, kind=8), i%i0)
END FUNCTION INUM2INUMS
FUNCTION INUM2INUMV(i)
type(inum ) :: i(:)