Commit 24959b26 authored by ulrich_y's avatar ulrich_y
Browse files

Merge branch 'ieps'

parents 3ec2beb9 3215f5fb
MODE=DEBUG
HAVE_GINAC=1
FC=gfortran
AR=ar rcs
CC=gcc
MCC=mcc
ifeq ($(HAVE_GINAC),1)
LD=g++
LFLAGS=-lgfortran
else
LD=gfortran
endif
FFLAGS=-fdefault-real-8 -cpp -pedantic-errors -std=f2008
FFLAGS+= -Werror -Wall -Wno-maybe-uninitialized -Wno-uninitialized
......@@ -17,6 +23,11 @@ else
FFLAGS += -ffpe-trap=invalid,overflow -fdump-core -fbacktrace
endif
ifeq ($(HAVE_GINAC),1)
FFLAGS += -DHAVE_GINAC
endif
files=globals.o ieps.o utils.o shuffle.o maths_functions.o mpl_module.o gpl_module.o
objects = $(addprefix build/,$(files))
......@@ -31,6 +42,9 @@ build/%.o: src/%.f90
@echo "F90 $@"
@$(FC) $(FFLAGS) -c $< -J build -o $@
build/%.o: src/%.cpp
@echo "C++ $@"
@$(CC) -c $< -o $@
# Mathlink related
......@@ -61,11 +75,18 @@ gpl: build/gpl.o libgpl.a build/mcc.internals
eval: libgpl.a build/eval.o
@echo "LD $@"
@$(LD) -o $@ build/eval.o -L. -lgpl
@$(LD) -o $@ build/eval.o -L. -lgpl $(LFLAGS)
ifeq ($(HAVE_GINAC),1)
test: $(objects) build/ginac.o build/test.o
@echo "LD $@"
@$(LD) -o $@ $^ -lcln -lginac $(LFLAGS)
else
test: $(objects) build/test.o
@echo "LD $@"
@$(LD) -o $@ $^ $(LFLAGS)
$(LD) -o $@ $^ $(LFLAGS)
endif
check: test
./$<
......
#include <ginac/ginac.h>
using namespace GiNaC;
#include <cln/cln.h>
#include <stdio.h>
#include <iostream>
typedef struct {double r,i;} complex_t;
extern "C"{
complex_t geval_(complex_t * z, int* n);
};
complex_t geval_(complex_t * z, int* n) {
cln::cl_inhibit_floating_point_underflow = true;
lst w;
for(long i=0;i<(*n)-1;i++)
{
w.append((z->r)+(z->i)*I);
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()
};
}
......@@ -4,8 +4,6 @@ MODULE globals
integer, parameter :: prec = selected_real_kind(15,32)
real, parameter :: epsilon = 1e-20 ! used for the small imaginary part
real, parameter :: zero = 1e-15 ! values smaller than this count as zero
real, parameter :: pi = 3.14159265358979323846
......
:Evaluate:
gpl`args2r[a_]:=Re[N[a/.SubPlus|SubMinus->Identity]];
gpl`args2i[a_]:=Im[N[a/.SubPlus|SubMinus->Identity]];
gpl`args2e[a_]:=Switch[Head[#], SubPlus, 1, SubMinus, -1, _, 1]& /@ a;
:Begin:
:Function: gpl
:Pattern: G[a__]/;And @@ (NumberQ /@ ({a} /. SubPlus | SubMinus -> Identity))
:Arguments: {Re@N[{a}], Im@N[{a}]}
:ArgumentTypes: {RealList,RealList}
:Pattern: gG[a__]/;And @@ (NumberQ /@ ({a} /. SubPlus | SubMinus -> Identity))
:Arguments: { gpl`args2r[{a}], gpl`args2i[{a}], gpl`args2e[{a}] }
:ArgumentTypes: {RealList,RealList,IntegerList}
:ReturnType: Manual
:End:
......@@ -13,17 +17,21 @@
#include <assert.h>
typedef struct {double r,i;} complex;
typedef struct {complex c; signed char i0;} inum;
extern complex __gpl_module_MOD_g_superflatn(complex*,long*);
extern complex __gpl_module_MOD_g_superflatn(inum*,long*);
void gpl(double * re, long nr, double * im, long ni)
void gpl(double * re, long nr, double * im, long ni, int*ieps, long ne)
{
assert(nr==ni);
complex input[nr], ans;
assert(nr==ne);
inum input[nr];
complex ans;
for(long i=0;i<nr;i++)
{
input[i].r = *(re+i);
input[i].i = *(im+i);
input[i].c.r = *(re+i);
input[i].c.i = *(im+i);
input[i].i0 = *(ieps+i);
}
ans = __gpl_module_MOD_g_superflatn(&input[0],&nr);
......
......@@ -5,25 +5,34 @@ MODULE gpl_module
use maths_functions
use shuffle
use mpl_module
use ieps
implicit none
INTERFACE GPL
module procedure G_flat, G_condensed, G_superflat, G_real, G_int
END INTERFACE GPL
CONTAINS
FUNCTION GPL_zero_zi(l,y)
! used to compute the value of GPL when all zi are zero
integer :: l
complex(kind=prec) :: y, GPL_zero_zi
GPL_zero_zi = 1.0_prec/factorial(l) * log(y) ** l
type(inum) :: y
complex(kind=prec) :: GPL_zero_zi
if (abs(aimag(y)).lt.zero) then
if (real(y).gt.0) then
GPL_zero_zi = 1.0_prec/factorial(l) * log(real(y)) ** l
else
GPL_zero_zi = 1.0_prec/factorial(l) * (log(-real(y))-cmplx(0,y%i0*pi)) ** l
endif
else
GPL_zero_zi = 1.0_prec/factorial(l) * log(y%c) ** l
endif
END FUNCTION GPL_zero_zi
FUNCTION is_convergent(z,y)
! returns true if G(z,y) convergent, otherwise false
! can be used in either notation (flat or condensed)
complex(kind=prec) :: z(:), y
type(inum) :: z(:), y
logical :: is_convergent
integer :: i
......@@ -35,8 +44,8 @@ CONTAINS
END FUNCTION is_convergent
SUBROUTINE print_G(z_flat, y)
complex(kind=prec) :: z_flat(:)
complex(kind=prec), optional :: y
type(inum) :: z_flat(:)
type(inum) , optional :: y
if(present(y)) print*, 'G(', real(z_flat), real(y), ')'
if(.not. present(y)) print*, 'G(', abs(z_flat), ')'
END SUBROUTINE print_G
......@@ -44,12 +53,13 @@ CONTAINS
RECURSIVE FUNCTION remove_sr_from_last_place_in_PI(a,y2,m,p) result(res)
! here what is passed is not the full a vector, only a1, ..., ak without the trailing zeroes
integer :: m, i, j, n
complex(kind=prec) :: a(:), y2, s(m), p(:), res
complex(kind=prec) :: alpha(product((/(i,i=1,size(a)+size(s))/))/ &
type(inum) :: a(:), y2, s(m), p(:)
complex(kind=prec) :: res
type(inum) :: alpha(product((/(i,i=1,size(a)+size(s))/))/ &
(product((/(i,i=1,size(a))/))*product((/(i,i=1,size(s))/))), &
size(a) + size(s))
s = [zeroes(m-1),cmplx(42e50)]
s = [zeroes(m-1),marker]
alpha = shuffle_product(a,s)
if(verb >= 50) then
print*, 'mapping to '
......@@ -60,20 +70,22 @@ CONTAINS
if(verb >= 50) print*, 'also mapping to'
do j = 2,size(alpha, 1)
! find location of s_r
n = find_first_true(abs(alpha(j,:) - 42e50) < zero)
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])
n = find_marker(alpha(j,:))
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])
res = res - pending_integral(p, n, [alpha(j,1:n-1),alpha(j,n+1:size(alpha,2)),y2])
end do
END FUNCTION remove_sr_from_last_place_in_PI
RECURSIVE FUNCTION pending_integral(p,i,g) result(res)
! evaluates a pending integral by reducing it to simpler ones and g functions
complex(kind=prec) :: p(:), g(:), res
complex(kind=prec) :: y1, y2, b(size(p)-1), a(size(g)-1)
complex(kind=prec) :: res
type(inum) :: p(:), g(:)
type(inum) :: y1, y2, b(size(p)-1), a(size(g)-1)
integer :: i, m
res = 0
if(verb >= 30) print*, 'evaluating PI with p=',real(p),'i=',real(i),'g =',real(g)
if(verb >= 30) print*, 'evaluating PI with p=',real(p),'i=',real(i),'g =',real(g)
y1 = p(1)
b = p(2:size(p))
......@@ -96,8 +108,11 @@ CONTAINS
! if depth one and m = 1 use my (59)
if(size(g) == 1) then
if(verb >= 30) print*, 'case depth one and m = 1'
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)))
!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)))
!TODO
res = pending_integral(p,2,[g(1)]) - pending_integral(p,2,[izero]) &
+ G_flat(p(2:size(p)), p(1)) * conjg(log(-g(1)%c))
return
end if
......@@ -111,14 +126,14 @@ CONTAINS
if(verb >= 50) then
print*, 'map to'
print*, 'zeta(',m,')'
print*, 'PI with p=',real(p),'i=',0,'g =',zeroes(0)
print*, 'PI with p=',real([y2,cmplx(0.0)]),'i=',m-1,'g =',[zeroes(m-2),y2]
print*, 'PI with p=',real(p),'i=',0,'g =',zeroes(0)
print*, 'PI with p=',[p,cmplx(0.0)],'i=',m-1,'g =',zeroes(0)
print*, 'PI with p=',real(p),'i=',0,'g =',tocmplx(zeroes(0))
print*, 'PI with p=',real([y2,izero]),'i=',m-1,'g =',tocmplx([zeroes(m-2),y2])
print*, 'PI with p=',real(p),'i=',0,'g =',tocmplx(zeroes(0))
print*, 'PI with p=',tocmplx([p,izero]),'i=',m-1,'g =',tocmplx(zeroes(0))
end if
res = -zeta(m)*pending_integral(p,0,zeroes(0)) &
+ pending_integral([y2,cmplx(0.0)],m-1,[zeroes(m-2),y2])*pending_integral(p,0,zeroes(0)) &
- pending_integral([p,cmplx(0.0)],m-1,[zeroes(m-2),y2])
+ 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])
return
end if
......@@ -128,16 +143,16 @@ CONTAINS
if(verb >= 50) then
print*, 'map to (using 68)'
print*, 'PI with p=',real(p),'i=',0,'g =',zeroes(0)
call print_G([cmplx(0.0),a],y2)
print*, 'PI with p=',real([p,y2]),'i=',0,'g =',zeroes(0)
print*, 'PI with p=',real(p),'i=',0,'g =',tocmplx(zeroes(0) )
call print_G([izero,a],y2)
print*, 'PI with p=',real([p,y2]),'i=',0,'g =',tocmplx(zeroes(0) )
call print_G(a,y2)
print*, 'PI with p=',real([p,a(1)]),'i=',1,'g =',real([a(2:size(a)),y2])
print*, 'PI with p=',real([p,a(1)]),'i=',0,'g =',zeroes(0)
print*, 'PI with p=',real([p,a(1)]),'i=',0,'g =',tocmplx(zeroes(0))
call print_G(a,y2)
end if
res = pending_integral(p,0,zeroes(0)) * G_flat([cmplx(0.0),a],y2) &
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)
......@@ -155,7 +170,7 @@ CONTAINS
! case higher depth, s_r in middle, use my (67)
if(verb >= 30) print*, 's_r in the middle under PI'
res = +pending_integral(p,1,zeroes(0)) * G_flat([a(1:i-1),cmplx(0.0),a(i:size(a))],y2) & !64
res = +pending_integral(p,1,zeroes(0)) * G_flat([a(1:i-1),izero,a(i:size(a))],y2) & !64
- pending_integral([p,a(i-1)],i-1,[a(1:i-2),a(i:size(a)),y2]) & ! 67a
+ pending_integral([p,a(i-1)],1,zeroes(0)) * G_flat(a,y2) & ! 67c
+ pending_integral([p,a(i)], i, [a(1:i-1), a(i+1:size(a)),y2]) & !67b
......@@ -163,9 +178,10 @@ CONTAINS
END FUNCTION pending_integral
RECURSIVE FUNCTION remove_sr_from_last_place_in_G(a,y2,m,sr) result(res)
complex(kind=prec) :: a(:), sr, res,y2
type(inum) :: a(:), sr, y2
complex(kind=prec) :: res
integer :: m,i,j
complex(kind=prec) :: alpha(product((/(i,i=1,size(a)+m)/))/ &
type(inum) :: alpha(product((/(i,i=1,size(a)+m)/))/ &
(product((/(i,i=1,size(a))/))*product((/(i,i=1,m)/))), &
size(a) + m)
alpha = shuffle_product(a,[zeroes(m-1),sr])
......@@ -178,7 +194,8 @@ CONTAINS
RECURSIVE FUNCTION make_convergent(a,y2) result(res)
! goes from G-functions to pending integrals and simpler expressions according to (62),(64),(67) and (68)
complex(kind=prec) :: a(:), y2, res, sr
type(inum) :: a(:), y2, sr
complex(kind=prec) :: res
integer :: i, mminus1
res = 0
......@@ -199,7 +216,7 @@ CONTAINS
if(verb >= 30) then
print*, '--------------------------------------------------'
print*, 'sr at beginning, map to: '
call print_G([cmplx(0), a(i+1:size(a))], y2)
call print_G([izero, a(i+1:size(a))], y2)
call print_G([y2], sr)
call print_G(a(i+1:size(a)), y2)
print*, 'PI with p=',real([sr, a(i+1)]),'i=',i,'g =', real([a(i+2:size(a)), y2])
......@@ -208,10 +225,10 @@ CONTAINS
print*, '--------------------------------------------------'
end if
res = G_flat([cmplx(0), a(i+1:size(a))], y2) &
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]) &
- G_flat([a(i+1)], sr) * G_flat(a(i+1:size(a)), y2)
- G_flat([a(i+1)],sr) * G_flat(a(i+1:size(a)), y2)
return
end if
......@@ -219,7 +236,7 @@ CONTAINS
if(verb >= 30) then
print*, '--------------------------------------------------'
print*, 'sr in the middle, map to: '
call print_G([a(1:i-1),cmplx(0),a(i+1:size(a))],y2)
call print_G([a(1:i-1),izero,a(i+1:size(a))],y2)
print*, 'PI with p=',real([sr,a(i-1)]),'i=', i-1,'g =', real([a(1:i-2),a(i+1:size(a)),y2])
call print_G([a(i-1)],sr)
call print_G([a(1:i-1),a(i+1:size(a))],y2)
......@@ -229,7 +246,7 @@ CONTAINS
print*, '--------------------------------------------------'
end if
res = G_flat([a(1:i-1),cmplx(0),a(i+1:size(a))],y2) &
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]) &
+ 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]) &
......@@ -238,24 +255,36 @@ CONTAINS
RECURSIVE FUNCTION improve_convergence(z) result(res)
! improves the convergence by applying the Hoelder convolution to G(z1,...zk,1)
complex(kind=prec) :: z(:),oneminusz(size(z)), res
type(inum) :: z(:),oneminusz(size(z))
complex(kind=prec) :: res
complex(kind=prec), parameter :: p = 2.0
integer :: k, j
if(verb >= 30) print*, 'requires Hoelder convolution'
oneminusz = 1-z
! In the Hoelder expression, all the (1-z) are -i0.. GiNaC does something
! different (and confusing, l. 1035). As we do, they usually would set
! i0 -> -z%i0. However, if Im[z] == 0 and Re[z] >= 1, they just set it to
! i0 -> +i0, be damned what it was before.
do j=1,size(z)
if ( (abs(aimag(z(j))) .lt. zero).and.( real(z(j)) .ge. 1) ) then
oneminusz(j) = inum(1.-z(j)%c, +1)
else
oneminusz(j) = inum(1.-z(j)%c,-z(j)%i0)
endif
enddo
k = size(z)
res = G_flat(z,1.0/p) ! first term of the sum
res = res + (-1)**k * G_flat(oneminusz(k:1:-1), 1.0-1.0/p)
res = G_flat(z,inum(1./p,di0)) ! first term of the sum
res = res + (-1)**k * G_flat(oneminusz(k:1:-1), inum(1.-1/p,di0))
do j = 1,k-1
res = res + (-1)**j * G_flat(oneminusz(j:1:-1),1.0-1.0/p) * G_flat(z(j+1:k),1.0/p)
res = res + (-1)**j * G_flat(oneminusz(j:1:-1),inum(1.-1/p,di0)) * G_flat(z(j+1:k),inum(1./p,di0))
end do
END FUNCTION improve_convergence
RECURSIVE FUNCTION G_flat(z_flat,y) result(res)
! Calls G function with flat arguments, that is, zeroes not passed through the m's.
complex(kind=prec) :: z_flat(:), y, res
complex(kind=prec), allocatable :: z(:), s(:,:)
type(inum) :: z_flat(:), y, znorm(size(z_flat))
complex(kind=prec) :: res
type(inum), allocatable :: s(:,:), z(:)
integer :: m_prime(size(z_flat)), condensed_size, kminusj, j, k, i, m_1
integer, allocatable :: m(:)
logical :: is_depth_one
......@@ -264,7 +293,7 @@ CONTAINS
if(size(z_flat) == 1) then
if( abs(z_flat(1) - y) <= zero ) then
if( abs(z_flat(1)%c - y%c) <= zero ) then
res = 0
return
end if
......@@ -279,16 +308,17 @@ CONTAINS
! is just a logarithm?
if(all(abs(z_flat) < zero)) then
if(verb >= 70) print*, 'all z are zero'
res = log(y)**size(z_flat) / factorial(size(z_flat))
res = gpl_zero_zi(size(z_flat),y)
return
end if
if(size(z_flat) == 1) then
if(verb >= 70) print*, 'is just a logarithm'
if(abs(z_flat(1)) <= zero) then
res = log(y)
! This shouldn't happen!
res = gpl_zero_zi(1,y)
return
end if
res = log((z_flat(1) - y)/z_flat(1))
res = plog1(y,z_flat(1)) ! log((z_flat(1) - y)/z_flat(1))
return
end if
......@@ -299,7 +329,7 @@ CONTAINS
if(is_depth_one) then
! case m >= 2, other already handled above
if(verb >= 70) print*, 'is just a polylog'
res = -polylog(m_1,y/z_flat(m_1))
res = -polylog(m_1, y, z_flat(m_1))!-polylog(m_1,y/z_flat(m_1))
return
end if
......@@ -314,7 +344,7 @@ CONTAINS
if(verb >= 30) print*, 'need to remove trailing zeroes'
allocate(s(j,j))
s = shuffle_with_zero(z_flat(1:j-1))
res = log(y)*G_flat(z_flat(1:size(z_flat)-1),y)
res = GPL_zero_zi(1,y)*G_flat(z_flat(1:size(z_flat)-1),y)
do i = 1,size(s,1)
res = res - G_flat([s(i,:),z_flat(j),zeroes(kminusj-1)], y)
end do
......@@ -331,8 +361,14 @@ CONTAINS
end if
! requires Hoelder convolution?
if( any(1.0 <= abs(z_flat/y) .and. abs(z_flat/y) <= HoelderCircle) ) then
res = improve_convergence(z_flat/y)
if( any(1.0 <= abs(z_flat%c/y%c) .and. abs(z_flat%c/y%c) <= HoelderCircle) ) then
! Here we just *assume* that y is positive and doesn't mess up the
! ieps, which is what GiNaC does (l. 1013)
! TODO
do j=1,size(z_flat)
znorm(j) = inum(z_flat(j)%c/y%c, z_flat(j)%i0)
enddo
res = improve_convergence(znorm)
return
end if
......@@ -356,21 +392,21 @@ CONTAINS
FUNCTION G_superflat(g) result(res)
! simpler notation for flat evaluation
complex(kind=prec) :: g(:), res
res = G_flat(g(1:size(g)-1), g(size(g)))
res = G_flat(toinum(g(1:size(g)-1)), inum(g(size(g)),di0))
END FUNCTION G_superflat
FUNCTION G_real(g) result(res)
! simpler notation for flat evaluation
real(kind=prec) :: g(:)
complex(kind=prec) :: res
res = G_flat(cmplx(g(1:size(g)-1)), cmplx(g(size(g))))
res = G_flat(toinum(cmplx(g(1:size(g)-1))), inum(cmplx(g(size(g))),di0))
END FUNCTION G_real
FUNCTION G_int(g) result(res)
! simpler notation for flat evaluation
integer:: g(:)
complex(kind=prec) :: res
res = G_flat(cmplx(g(1:size(g)-1)), cmplx(g(size(g))))
res = G_flat(toinum(cmplx(g(1:size(g)-1))), inum(cmplx(g(size(g))),di0))
END FUNCTION G_int
RECURSIVE FUNCTION G_condensed(m,z,y,k) result(res)
......@@ -378,7 +414,8 @@ CONTAINS
! assumes zero arguments expressed through the m's
integer :: m(:), k, i
complex(kind=prec) :: z(:), x(k), y, res, z_flat(sum(m))
type(inum) :: z(:), y, z_flat(sum(m))
complex(kind=prec) :: res, x(k)
! print*, 'called G_condensed with args'
! print*, 'm = ', m
......@@ -405,10 +442,10 @@ CONTAINS
res = G_flat(z_flat,y)
return
end if
x(1) = y/z(1)
!TODO is that okay?
x(1) = y%c/z(1)%c
do i = 2,k
x(i) = z(i-1)/z(i)
x(i) = z(i-1)%c/z(i)%c
end do
! print*, 'computed using Li with '
! print*, 'm = ', m
......@@ -420,9 +457,9 @@ CONTAINS
FUNCTION G_SUPERFLATN(c0,n)
integer, intent(in) :: n
complex(kind=prec), intent(in) :: c0(n)
type(inum), intent(in) :: c0(n)
complex(kind=prec) g_superflatn
G_superflatn=G_superflat(c0)
G_superflatn = G_flat(c0(1:n-1), c0(n))
END FUNCTION
END MODULE gpl_module
......
......@@ -11,59 +11,27 @@ MODULE ieps
type(inum), parameter :: izero=inum( 0.,di0)
type(inum), parameter :: imone=inum(-1.,di0)
type(inum), parameter :: ione=inum(+1.,di0)
type(inum), parameter :: marker=inum(0.,5)
interface operator (*)
module procedure multinum
end interface operator (*)
interface operator (+)
module procedure addinum
end interface operator (+)
interface operator (-)
module procedure subinum
end interface operator (-)
interface operator (**)
module procedure powinum
end interface operator (**)
interface operator (/)
module procedure divint, divinum
end interface operator (/)
interface abs
module procedure absinum, absinumv
end interface abs
interface log
module procedure loginum
end interface log
interface toinum
module procedure toinum_cmplx, toinum_real, toinum_int
end interface toinum
interface tocmplx
module procedure tocmplxv, tocmplxs
end interface tocmplx
interface real
module procedure realis, realiv
end interface real
interface aimag
module procedure imags, imagv
end interface aimag
CONTAINS
FUNCTION MULTINUM(n1, n2)
implicit none
type(inum), intent(in) :: n1, n2
type(inum) :: multinum
multinum = inum( n1%c*n2%c, int(sign(1._prec,real(n1%c)*n2%i0 + real(n2%c)*n1%i0)) )
END FUNCTION MULTINUM