10
0
mirror of https://github.com/LCPQ/quantum_package synced 2024-08-25 05:51:46 +02:00

Tests for integration

This commit is contained in:
Anthony Scemama 2014-04-07 20:01:30 +02:00
parent 48c8616c29
commit c70e4591a9
12 changed files with 2091 additions and 1000 deletions

View File

@ -25,6 +25,8 @@ def run_test(test_name,inp):
template = """ template = """
class $test(unittest.TestCase): class $test(unittest.TestCase):
default_precision = 1.e-10
execfile('$test.ref') execfile('$test.ref')
def setUp(self): def setUp(self):
@ -38,9 +40,13 @@ class $test(unittest.TestCase):
continue continue
l,r = buffer l,r = buffer
l,r = l.strip(), eval(r) l,r = l.strip(), eval(r)
if 'precision' in self.__dict__:
precision = self.precision[l]
else:
precision = self.default_precision
if type(r) == float: if type(r) == float:
self.assertAlmostEqual(self.data[inp][l], r, self.assertAlmostEqual(self.data[inp][l], r,
places=abs(int(log10(self.precision[l]*max(abs(self.data[inp][l]),1.e-12)))), msg=None) places=abs(int(log10(precision*max(abs(self.data[inp][l]),1.e-12)))), msg=None)
else: else:
self.assertEqual(self.data[inp][l], r, msg=None) self.assertEqual(self.data[inp][l], r, msg=None)

View File

@ -35,6 +35,7 @@ then
exit 1 exit 1
fi fi
VERSION=$( cut -d '=' -f 2 < ${QPACKAGE_ROOT}/EZFIO/version)
for i in ${!key[@]} for i in ${!key[@]}
do do
MD5=${key[$i]} MD5=${key[$i]}
@ -42,6 +43,7 @@ do
if [[ ! -d $file ]] if [[ ! -d $file ]]
then then
mkdir -p $(dirname $file) mkdir -p $(dirname $file)
echo ${VERSION} > $(dirname $file)/.version
fi fi
if [[ ! -f ${QPACKAGE_ROOT}/data/cache/${MD5} ]] if [[ ! -f ${QPACKAGE_ROOT}/data/cache/${MD5} ]]
then then
@ -49,3 +51,4 @@ do
fi fi
cp ${QPACKAGE_ROOT}/data/cache/${MD5} ${file} cp ${QPACKAGE_ROOT}/data/cache/${MD5} ${file}
done done
echo ${VERSION} > ${EZFIO_FILE}.ezfio/.version

View File

@ -21,7 +21,7 @@ BEGIN_PROVIDER [ character*(128), ezfio_filename ]
! Check that file exists ! Check that file exists
logical :: exists logical :: exists
inquire(file=trim(ezfio_filename)//'/ezfio/.version',exist=exists) inquire(file=trim(ezfio_filename)//'/ezfio/creation',exist=exists)
if (.not.exists) then if (.not.exists) then
print *, 'Error: file '//trim(ezfio_filename)//' does not exist' print *, 'Error: file '//trim(ezfio_filename)//' does not exist'
stop 1 stop 1

View File

@ -1,7 +1,8 @@
subroutine ortho_lowdin(overlap,lda,n,C,ldc,m) subroutine ortho_lowdin(overlap,lda,n,C,ldc,m)
implicit none implicit none
BEGIN_DOC
! Compute U.S^-1/2 canonical orthogonalization ! Compute U.S^-1/2 canonical orthogonalization
END_DOC
integer, intent(in) :: lda, ldc, n, m integer, intent(in) :: lda, ldc, n, m
double precision, intent(in) :: overlap(lda,n) double precision, intent(in) :: overlap(lda,n)
@ -70,8 +71,10 @@ end
subroutine get_pseudo_inverse(A,m,n,C,LDA) subroutine get_pseudo_inverse(A,m,n,C,LDA)
! Find C = A^-1
implicit none implicit none
BEGIN_DOC
! Find C = A^-1
END_DOC
integer, intent(in) :: m,n, LDA integer, intent(in) :: m,n, LDA
double precision, intent(in) :: A(LDA,n) double precision, intent(in) :: A(LDA,n)
double precision, intent(out) :: C(n,m) double precision, intent(out) :: C(n,m)
@ -97,7 +100,7 @@ subroutine get_pseudo_inverse(A,m,n,C,LDA)
call dgesvd('S','A', m, n, A_tmp, m,D,U,m,Vt,n,work,lwork,info) call dgesvd('S','A', m, n, A_tmp, m,D,U,m,Vt,n,work,lwork,info)
if (info /= 0) then if (info /= 0) then
print *, info, ': SVD failed' print *, info, ': SVD failed'
stop stop 1
endif endif
do i=1,n do i=1,n
@ -122,8 +125,10 @@ subroutine get_pseudo_inverse(A,m,n,C,LDA)
end end
subroutine find_rotation(A,LDA,B,m,C,n) subroutine find_rotation(A,LDA,B,m,C,n)
! Find A.C = B
implicit none implicit none
BEGIN_DOC
! Find A.C = B
END_DOC
integer, intent(in) :: m,n, LDA integer, intent(in) :: m,n, LDA
double precision, intent(in) :: A(LDA,n), B(LDA,n) double precision, intent(in) :: A(LDA,n), B(LDA,n)
double precision, intent(out) :: C(n,n) double precision, intent(out) :: C(n,n)
@ -138,10 +143,11 @@ subroutine find_rotation(A,LDA,B,m,C,n)
end end
subroutine apply_rotation(A,LDA,R,LDR,B,LDB,m,n) subroutine apply_rotation(A,LDA,R,LDR,B,LDB,m,n)
implicit none implicit none
BEGIN_DOC
! Apply the rotation found by find_rotation
END_DOC
double precision, intent(in) :: R(LDR,n) double precision, intent(in) :: R(LDR,n)
double precision, intent(in) :: A(LDA,n) double precision, intent(in) :: A(LDA,n)
double precision, intent(out) :: B(LDB,n) double precision, intent(out) :: B(LDB,n)
@ -149,8 +155,11 @@ subroutine apply_rotation(A,LDA,R,LDR,B,LDB,m,n)
call dgemm('N','N',m,n,n,1.d0,A,LDA,R,LDR,0.d0,B,LDB) call dgemm('N','N',m,n,n,1.d0,A,LDA,R,LDR,0.d0,B,LDB)
end end
subroutine jacobi_lapack(eigvalues,eigvectors,H,nmax,n) subroutine lapack_diag(eigvalues,eigvectors,H,nmax,n)
implicit none implicit none
BEGIN_DOC
! Diagonalize matrix H
END_DOC
integer, intent(in) :: n,nmax integer, intent(in) :: n,nmax
double precision, intent(out) :: eigvectors(nmax,n) double precision, intent(out) :: eigvectors(nmax,n)
double precision, intent(out) :: eigvalues(n) double precision, intent(out) :: eigvalues(n)
@ -159,31 +168,19 @@ subroutine jacobi_lapack(eigvalues,eigvectors,H,nmax,n)
double precision,allocatable :: work(:) double precision,allocatable :: work(:)
double precision,allocatable :: A(:,:) double precision,allocatable :: A(:,:)
!eigvectors(i,j) = <d_i|psi_j> where d_i is the basis function and psi_j is the j th eigenvector !eigvectors(i,j) = <d_i|psi_j> where d_i is the basis function and psi_j is the j th eigenvector
print*,nmax,n
allocate(A(nmax,n),eigenvalues(nmax),work(4*nmax)) allocate(A(nmax,n),eigenvalues(nmax),work(4*nmax))
integer :: LWORK, info, i,j,l,k integer :: LWORK, info, i,j,l,k
double precision :: cpu_2, cpu_1
A=H A=H
call cpu_time (cpu_1)
LWORK = 4*nmax LWORK = 4*nmax
call dsyev( 'V', & call dsyev( 'V', 'U', n, A, nmax, eigenvalues, work, LWORK, info )
'U', &
n, &
A, &
nmax, &
eigenvalues, &
work, &
LWORK, &
info )
if (info < 0) then if (info < 0) then
print *, irp_here, ': the ',-info,'-th argument had an illegal value' print *, irp_here, ': the ',-info,'-th argument had an illegal value'
stop stop 1
else if (info > 0) then else if (info > 0) then
print *, irp_here, ': the algorithm failed to converge; ',info,' off-diagonal' print *, irp_here, ': the algorithm failed to converge; ',info,' off-diagonal'
print *, 'elements of an intermediate tridiagonal form did not converge to zero.' print *, 'elements of an intermediate tridiagonal form did not converge to zero.'
stop stop 1
endif endif
call cpu_time (cpu_2)
eigvectors = 0.d0 eigvectors = 0.d0
eigvalues = 0.d0 eigvalues = 0.d0
do j = 1, n do j = 1, n

View File

@ -2,18 +2,386 @@
Utils Module Utils Module
============ ============
Contains general purpose utilities.
Assumptions
-----------
.. include:: ./ASSUMPTIONS.rst
Needed Modules
--------------
.. include:: ./NEEDED_MODULES

File diff suppressed because it is too large Load Diff

View File

@ -1,135 +1,145 @@
double precision function overlap_gaussian_x(A_center,B_center,alpha,beta,power_A,power_B,dim) double precision function overlap_gaussian_x(A_center,B_center,alpha,beta,power_A,power_B,dim)
implicit none implicit none
! calculates the following overlap : BEGIN_DOC
! sum (x) between [-infty;+infty] of (x-A_x)^ax (x-B_x)^bx exp(-alpha(x-A_x)^2) exp(-beta(x-B_X)^2) !.. math::
include 'include/constants.F' !
integer,intent(in) :: dim ! dimension maximum for the arrays representing the polynoms ! \sum_{-infty}^{+infty} (x-A_x)^ax (x-B_x)^bx exp(-alpha(x-A_x)^2) exp(-beta(x-B_X)^2) dx
double precision,intent(in) :: A_center,B_center ! center of the x1 functions !
integer,intent(in) :: power_A, power_B ! power of the x1 functions END_DOC
double precision :: P_new(0:max_dim),P_center,fact_p,p,alpha,beta include 'include/constants.F'
integer :: iorder_p integer,intent(in) :: dim ! dimension maximum for the arrays representing the polynomials
call give_explicit_poly_and_gaussian_x(P_new,P_center,p,fact_p,iorder_p,alpha,beta,power_A,power_B,A_center,B_center,dim) double precision,intent(in) :: A_center,B_center ! center of the x1 functions
integer,intent(in) :: power_A, power_B ! power of the x1 functions
double precision :: P_new(0:max_dim),P_center,fact_p,p,alpha,beta
integer :: iorder_p
call give_explicit_poly_and_gaussian_x(P_new,P_center,p,fact_p,iorder_p,alpha,&
beta,power_A,power_B,A_center,B_center,dim)
if(fact_p.lt.0.000001d0)then if(fact_p.lt.0.000001d0)then
overlap_gaussian_x = 0.d0 overlap_gaussian_x = 0.d0
return return
endif endif
overlap_gaussian_x = 0.d0 overlap_gaussian_x = 0.d0
integer :: i integer :: i
double precision :: F_integral double precision :: F_integral
do i = 0,iorder_p do i = 0,iorder_p
overlap_gaussian_x += P_new(i) * F_integral(i,p) overlap_gaussian_x += P_new(i) * F_integral(i,p)
enddo enddo
overlap_gaussian_x*= fact_p overlap_gaussian_x*= fact_p
end end
subroutine overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,overlap_y,overlap_z,overlap,dim) subroutine overlap_gaussian_xyz(A_center,B_center,alpha,beta,power_A,&
implicit none power_B,overlap_x,overlap_y,overlap_z,overlap,dim)
! .. math:: implicit none
! BEGIN_DOC
! S_x = \int (x-A_x)^{a_x} exp(-\alpha(x-A_x)^2) (x-B_x)^{b_x} exp(-beta(x-B_x)^2) dx \\ !.. math::
! S = S_x S_y S_z !
! ! S_x = \int (x-A_x)^{a_x} exp(-\alpha(x-A_x)^2) (x-B_x)^{b_x} exp(-beta(x-B_x)^2) dx \\
! ! S = S_x S_y S_z
include 'include/constants.F' !
integer,intent(in) :: dim ! dimension maximum for the arrays representing the polynoms END_DOC
double precision,intent(in) :: A_center(3),B_center(3) ! center of the x1 functions include 'include/constants.F'
double precision, intent(in) :: alpha,beta integer,intent(in) :: dim ! dimension maximum for the arrays representing the polynomials
integer,intent(in) :: power_A(3), power_B(3) ! power of the x1 functions double precision,intent(in) :: A_center(3),B_center(3) ! center of the x1 functions
double precision, intent(out) :: overlap_x,overlap_y,overlap_z,overlap double precision, intent(in) :: alpha,beta
double precision :: P_new(0:max_dim,3),P_center(3),fact_p,p integer,intent(in) :: power_A(3), power_B(3) ! power of the x1 functions
double precision :: F_integral_tab(0:max_dim) double precision, intent(out) :: overlap_x,overlap_y,overlap_z,overlap
integer :: iorder_p(3) double precision :: P_new(0:max_dim,3),P_center(3),fact_p,p
double precision :: F_integral_tab(0:max_dim)
integer :: iorder_p(3)
call give_explicit_poly_and_gaussian(P_new,P_center,p,fact_p,iorder_p,alpha,beta,power_A,power_B,A_center,B_center,dim) call give_explicit_poly_and_gaussian(P_new,P_center,p,fact_p,iorder_p,alpha,beta,power_A,power_B,A_center,B_center,dim)
if(fact_p.lt.0.000001d0)then if(fact_p.lt.0.000001d0)then
overlap_x = 0.d0 overlap_x = 0.d0
overlap_y = 0.d0 overlap_y = 0.d0
overlap_z = 0.d0 overlap_z = 0.d0
overlap = 0.d0 overlap = 0.d0
return return
endif endif
integer :: nmax integer :: nmax
double precision :: F_integral double precision :: F_integral
nmax = maxval(iorder_p) nmax = maxval(iorder_p)
do i = 0,nmax do i = 0,nmax
F_integral_tab(i) = F_integral(i,p) F_integral_tab(i) = F_integral(i,p)
enddo enddo
overlap_x = P_new(0,1) * F_integral_tab(0) overlap_x = P_new(0,1) * F_integral_tab(0)
overlap_y = P_new(0,2) * F_integral_tab(0) overlap_y = P_new(0,2) * F_integral_tab(0)
overlap_z = P_new(0,3) * F_integral_tab(0) overlap_z = P_new(0,3) * F_integral_tab(0)
integer :: i integer :: i
do i = 1,iorder_p(1) do i = 1,iorder_p(1)
overlap_x += P_new(i,1) * F_integral_tab(i) overlap_x += P_new(i,1) * F_integral_tab(i)
enddo enddo
call gaussian_product_x(alpha,A_center(1),beta,B_center(1),fact_p,p,P_center(1)) call gaussian_product_x(alpha,A_center(1),beta,B_center(1),fact_p,p,P_center(1))
overlap_x *= fact_p overlap_x *= fact_p
do i = 1,iorder_p(2) do i = 1,iorder_p(2)
overlap_y += P_new(i,2) * F_integral_tab(i) overlap_y += P_new(i,2) * F_integral_tab(i)
enddo enddo
call gaussian_product_x(alpha,A_center(2),beta,B_center(2),fact_p,p,P_center(2)) call gaussian_product_x(alpha,A_center(2),beta,B_center(2),fact_p,p,P_center(2))
overlap_y *= fact_p overlap_y *= fact_p
do i = 1,iorder_p(3) do i = 1,iorder_p(3)
overlap_z += P_new(i,3) * F_integral_tab(i) overlap_z += P_new(i,3) * F_integral_tab(i)
enddo enddo
call gaussian_product_x(alpha,A_center(3),beta,B_center(3),fact_p,p,P_center(3)) call gaussian_product_x(alpha,A_center(3),beta,B_center(3),fact_p,p,P_center(3))
overlap_z *= fact_p overlap_z *= fact_p
overlap = overlap_x * overlap_y * overlap_z overlap = overlap_x * overlap_y * overlap_z
end end
subroutine overlap_x_abs(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,lower_exp_val,dx,nx) subroutine overlap_x_abs(A_center,B_center,alpha,beta,power_A,power_B,overlap_x,lower_exp_val,dx,nx)
implicit none implicit none
! compute the following integral : BEGIN_DOC
! int [-infty ; +infty] of [(x-A_center)^(power_A) * (x-B_center)^power_B * exp(-alpha(x-A_center)^2) * exp(-beta(x-B_center)^2) ] ! .. math ::
integer :: i,j,k,l !
integer,intent(in) :: power_A,power_B ! \int_{-infty}^{+infty} (x-A_center)^(power_A) * (x-B_center)^power_B * exp(-alpha(x-A_center)^2) * exp(-beta(x-B_center)^2) dx
double precision, intent(in) :: lower_exp_val !
double precision,intent(in) :: A_center, B_center,alpha,beta END_DOC
double precision, intent(out) :: overlap_x,dx integer :: i,j,k,l
integer, intent(in) :: nx integer,intent(in) :: power_A,power_B
double precision :: x_min,x_max,domain,x,factor,dist,p,p_inv,rho double precision, intent(in) :: lower_exp_val
double precision :: P_center double precision,intent(in) :: A_center, B_center,alpha,beta
if(power_A.lt.0.or.power_B.lt.0)then double precision, intent(out) :: overlap_x,dx
overlap_x = 0.d0 integer, intent(in) :: nx
dx = 0.d0 double precision :: x_min,x_max,domain,x,factor,dist,p,p_inv,rho
return double precision :: P_center
endif if(power_A.lt.0.or.power_B.lt.0)then
p = alpha + beta overlap_x = 0.d0
p_inv= 1.d0/p dx = 0.d0
rho = alpha * beta * p_inv return
dist = (A_center - B_center)*(A_center - B_center) endif
P_center = (alpha * A_center + beta * B_center) * p_inv p = alpha + beta
factor = dexp(-rho * dist) p_inv= 1.d0/p
rho = alpha * beta * p_inv
dist = (A_center - B_center)*(A_center - B_center)
P_center = (alpha * A_center + beta * B_center) * p_inv
factor = dexp(-rho * dist)
double precision :: tmp double precision :: tmp
tmp = dsqrt(lower_exp_val/p) tmp = dsqrt(lower_exp_val/p)
x_min = P_center - tmp x_min = P_center - tmp
x_max = P_center + tmp x_max = P_center + tmp
domain = x_max-x_min domain = x_max-x_min
dx = domain/dble(nx) dx = domain/dble(nx)
overlap_x = 0.d0 overlap_x = 0.d0
x = x_min x = x_min
do i = 1, nx do i = 1, nx
x += dx x += dx
overlap_x += abs((x-A_center)**power_A * (x-B_center)**power_B) * dexp(-p * (x-P_center)*(x-P_center)) overlap_x += abs((x-A_center)**power_A * (x-B_center)**power_B) * dexp(-p * (x-P_center)*(x-P_center))
enddo enddo
overlap_x *= factor * dx overlap_x = factor * dx * overlap_x
end end

View File

@ -1,42 +1,51 @@
BEGIN_TEMPLATE BEGIN_TEMPLATE
subroutine insertion_$Xsort (x,iorder,isize) subroutine insertion_$Xsort (x,iorder,isize)
implicit none implicit none
$type,intent(inout) :: x(isize) BEGIN_DOC
integer,intent(inout) :: iorder(isize) ! Sort array x(isize) using the insertion sort algorithm.
integer,intent(in) :: isize ! iorder in input should be (1,2,3,...,isize), and in output
$type :: xtmp ! contains the new order of the elements.
integer :: i, i0, j, jmax END_DOC
$type,intent(inout) :: x(isize)
integer,intent(inout) :: iorder(isize)
integer,intent(in) :: isize
$type :: xtmp
integer :: i, i0, j, jmax
do i=1,isize do i=1,isize
xtmp = x(i) xtmp = x(i)
i0 = iorder(i) i0 = iorder(i)
j = i-1 j = i-1
do j=i-1,1,-1 do j=i-1,1,-1
if ( x(j) > xtmp ) then if ( x(j) > xtmp ) then
x(j+1) = x(j) x(j+1) = x(j)
iorder(j+1) = iorder(j) iorder(j+1) = iorder(j)
else else
exit exit
endif endif
enddo enddo
x(j+1) = xtmp x(j+1) = xtmp
iorder(j+1) = i0 iorder(j+1) = i0
enddo enddo
end subroutine insertion_$Xsort end subroutine insertion_$Xsort
subroutine heap_$Xsort(x,iorder,isize) subroutine heap_$Xsort(x,iorder,isize)
implicit none implicit none
$type,intent(inout) :: x(isize) BEGIN_DOC
integer,intent(inout) :: iorder(isize) ! Sort array x(isize) using the heap sort algorithm.
integer,intent(in) :: isize ! iorder in input should be (1,2,3,...,isize), and in output
! contains the new order of the elements.
END_DOC
$type,intent(inout) :: x(isize)
integer,intent(inout) :: iorder(isize)
integer,intent(in) :: isize
integer :: i, k, j, l, i0 integer :: i, k, j, l, i0
$type :: xtemp $type :: xtemp
l = isize/2+1 l = isize/2+1
k = isize k = isize
do while (.True.) do while (.True.)
if (l>1) then if (l>1) then
l=l-1 l=l-1
xtemp = x(l) xtemp = x(l)
@ -56,45 +65,52 @@ BEGIN_TEMPLATE
i=l i=l
j = ishft(l,1) j = ishft(l,1)
do while (j<k) do while (j<k)
if ( x(j) < x(j+1) ) then if ( x(j) < x(j+1) ) then
j=j+1 j=j+1
endif endif
if (xtemp < x(j)) then if (xtemp < x(j)) then
x(i) = x(j) x(i) = x(j)
iorder(i) = iorder(j) iorder(i) = iorder(j)
i = j i = j
j = ishft(j,1) j = ishft(j,1)
else else
j = k+1 j = k+1
endif endif
enddo enddo
if (j==k) then if (j==k) then
if (xtemp < x(j)) then if (xtemp < x(j)) then
x(i) = x(j) x(i) = x(j)
iorder(i) = iorder(j) iorder(i) = iorder(j)
i = j i = j
j = ishft(j,1) j = ishft(j,1)
else else
j = k+1 j = k+1
endif endif
endif endif
x(i) = xtemp x(i) = xtemp
iorder(i) = i0 iorder(i) = i0
enddo enddo
end subroutine heap_$Xsort end subroutine heap_$Xsort
subroutine heap_$Xsort_big(x,iorder,isize) subroutine heap_$Xsort_big(x,iorder,isize)
implicit none implicit none
$type,intent(inout) :: x(isize) BEGIN_DOC
integer*8,intent(inout) :: iorder(isize) ! Sort array x(isize) using the heap sort algorithm.
integer*8,intent(in) :: isize ! iorder in input should be (1,2,3,...,isize), and in output
! contains the new order of the elements.
! This is a version for very large arrays where the indices need
! to be in integer*8 format
END_DOC
$type,intent(inout) :: x(isize)
integer*8,intent(inout) :: iorder(isize)
integer*8,intent(in) :: isize
integer*8 :: i, k, j, l, i0 integer*8 :: i, k, j, l, i0
$type :: xtemp $type :: xtemp
l = isize/2+1 l = isize/2+1
k = isize k = isize
do while (.True.) do while (.True.)
if (l>1) then if (l>1) then
l=l-1 l=l-1
xtemp = x(l) xtemp = x(l)
@ -114,39 +130,44 @@ BEGIN_TEMPLATE
i=l i=l
j = ishft(l,1) j = ishft(l,1)
do while (j<k) do while (j<k)
if ( x(j) < x(j+1) ) then if ( x(j) < x(j+1) ) then
j=j+1 j=j+1
endif endif
if (xtemp < x(j)) then if (xtemp < x(j)) then
x(i) = x(j) x(i) = x(j)
iorder(i) = iorder(j) iorder(i) = iorder(j)
i = j i = j
j = ishft(j,1) j = ishft(j,1)
else else
j = k+1 j = k+1
endif endif
enddo enddo
if (j==k) then if (j==k) then
if (xtemp < x(j)) then if (xtemp < x(j)) then
x(i) = x(j) x(i) = x(j)
iorder(i) = iorder(j) iorder(i) = iorder(j)
i = j i = j
j = ishft(j,1) j = ishft(j,1)
else else
j = k+1 j = k+1
endif endif
endif endif
x(i) = xtemp x(i) = xtemp
iorder(i) = i0 iorder(i) = i0
enddo enddo
end subroutine heap_$Xsort$big end subroutine heap_$Xsort$big
subroutine $Xsort(x,iorder,isize) subroutine $Xsort(x,iorder,isize)
implicit none implicit none
$type,intent(inout) :: x(isize) BEGIN_DOC
integer,intent(inout) :: iorder(isize) ! Sort array x(isize).
integer,intent(in) :: isize ! iorder in input should be (1,2,3,...,isize), and in output
! contains the new order of the elements.
END_DOC
$type,intent(inout) :: x(isize)
integer,intent(inout) :: iorder(isize)
integer,intent(in) :: isize
if (isize < 32) then if (isize < 32) then
call insertion_$Xsort(x,iorder,isize) call insertion_$Xsort(x,iorder,isize)
else else
@ -165,19 +186,23 @@ END_TEMPLATE
BEGIN_TEMPLATE BEGIN_TEMPLATE
subroutine $Xset_order(x,iorder,isize) subroutine $Xset_order(x,iorder,isize)
implicit none implicit none
integer :: isize BEGIN_DOC
$type :: x(*) ! array A has already been sorted, and iorder has contains the new order of
$type,allocatable :: xtmp(:) ! elements of A. This subroutine changes the order of x to match the new order of A.
integer :: iorder(*) END_DOC
integer :: i integer :: isize
$type :: x(*)
$type,allocatable :: xtmp(:)
integer :: iorder(*)
integer :: i
allocate(xtmp(isize)) allocate(xtmp(isize))
do i=1,isize do i=1,isize
xtmp(i) = x(iorder(i)) xtmp(i) = x(iorder(i))
enddo enddo
do i=1,isize do i=1,isize
x(i) = xtmp(i) x(i) = xtmp(i)
enddo enddo
deallocate(xtmp) deallocate(xtmp)
end end
@ -194,44 +219,57 @@ END_TEMPLATE
BEGIN_TEMPLATE BEGIN_TEMPLATE
subroutine insertion_$Xsort_big (x,iorder,isize) subroutine insertion_$Xsort_big (x,iorder,isize)
implicit none implicit none
$type,intent(inout) :: x(isize) BEGIN_DOC
integer*8,intent(inout) :: iorder(isize) ! Sort array x(isize) using the insertion sort algorithm.
integer*8,intent(in) :: isize ! iorder in input should be (1,2,3,...,isize), and in output
$type :: xtmp ! contains the new order of the elements.
integer*8 :: i, i0, j, jmax ! This is a version for very large arrays where the indices need
! to be in integer*8 format
END_DOC
$type,intent(inout) :: x(isize)
integer*8,intent(inout) :: iorder(isize)
integer*8,intent(in) :: isize
$type :: xtmp
integer*8 :: i, i0, j, jmax
do i=1_8,isize do i=1_8,isize
xtmp = x(i) xtmp = x(i)
i0 = iorder(i) i0 = iorder(i)
j = i-1_8 j = i-1_8
do j=i-1_8,1_8,-1_8 do j=i-1_8,1_8,-1_8
if ( x(j) > xtmp ) then if ( x(j) > xtmp ) then
x(j+1_8) = x(j) x(j+1_8) = x(j)
iorder(j+1_8) = iorder(j) iorder(j+1_8) = iorder(j)
else else
exit exit
endif endif
enddo enddo
x(j+1_8) = xtmp x(j+1_8) = xtmp
iorder(j+1_8) = i0 iorder(j+1_8) = i0
enddo enddo
end subroutine insertion_$Xsort end subroutine insertion_$Xsort
subroutine $Xset_order_big(x,iorder,isize) subroutine $Xset_order_big(x,iorder,isize)
implicit none implicit none
integer*8 :: isize BEGIN_DOC
$type :: x(*) ! array A has already been sorted, and iorder has contains the new order of
$type, allocatable :: xtmp(:) ! elements of A. This subroutine changes the order of x to match the new order of A.
integer*8 :: iorder(*) ! This is a version for very large arrays where the indices need
integer*8 :: i ! to be in integer*8 format
END_DOC
integer*8 :: isize
$type :: x(*)
$type, allocatable :: xtmp(:)
integer*8 :: iorder(*)
integer*8 :: i
allocate(xtmp(isize)) allocate(xtmp(isize))
do i=1_8,isize do i=1_8,isize
xtmp(i) = x(iorder(i)) xtmp(i) = x(iorder(i))
enddo enddo
do i=1_8,isize do i=1_8,isize
x(i) = xtmp(i) x(i) = xtmp(i)
enddo enddo
deallocate(xtmp) deallocate(xtmp)
end end
@ -246,23 +284,29 @@ END_TEMPLATE
BEGIN_TEMPLATE BEGIN_TEMPLATE
recursive subroutine $Xradix_sort$big(x,iorder,isize,iradix) recursive subroutine $Xradix_sort$big(x,iorder,isize,iradix)
implicit none implicit none
$int_type, intent(in) :: isize BEGIN_DOC
$int_type, intent(inout) :: iorder(isize) ! Sort integer array x(isize) using the radix sort algorithm.
$type, intent(inout) :: x(isize) ! iorder in input should be (1,2,3,...,isize), and in output
integer, intent(in) :: iradix ! contains the new order of the elements.
integer :: iradix_new ! iradix should be -1 in input.
$type, allocatable :: x2(:), x1(:) END_DOC
$int_type, allocatable :: iorder1(:),iorder2(:) $int_type, intent(in) :: isize
$int_type :: i0, i1, i2, i3, i $int_type, intent(inout) :: iorder(isize)
integer, parameter :: integer_size=$octets $type, intent(inout) :: x(isize)
$type, parameter :: zero=$zero integer, intent(in) :: iradix
$type :: mask integer :: iradix_new
integer :: nthreads, omp_get_num_threads $type, allocatable :: x2(:), x1(:)
!DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1 $int_type, allocatable :: iorder1(:),iorder2(:)
$int_type :: i0, i1, i2, i3, i
integer, parameter :: integer_size=$octets
$type, parameter :: zero=$zero
$type :: mask
integer :: nthreads, omp_get_num_threads
!DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1
if (iradix == -1) then if (iradix == -1) then
! Find most significant bit ! Find most significant bit
@ -276,13 +320,13 @@ BEGIN_TEMPLATE
iradix_new = integer_size-1-leadz(i3) iradix_new = integer_size-1-leadz(i3)
mask = ibset(zero,iradix_new) mask = ibset(zero,iradix_new)
nthreads = 1 nthreads = 1
! nthreads = 1+ishft(omp_get_num_threads(),-1) ! nthreads = 1+ishft(omp_get_num_threads(),-1)
integer :: err integer :: err
allocate(x1(isize/nthreads+1),iorder1(isize/nthreads+1),x2(isize/nthreads+1),iorder2(isize/nthreads+1),stat=err) allocate(x1(isize/nthreads+1),iorder1(isize/nthreads+1),x2(isize/nthreads+1),iorder2(isize/nthreads+1),stat=err)
if (err /= 0) then if (err /= 0) then
print *, irp_here, ': Unable to allocate arrays' print *, irp_here, ': Unable to allocate arrays'
stop stop
endif endif
i1=1_8 i1=1_8
@ -310,8 +354,8 @@ BEGIN_TEMPLATE
i3 = i0 i3 = i0
deallocate(x1,iorder1,stat=err) deallocate(x1,iorder1,stat=err)
if (err /= 0) then if (err /= 0) then
print *, irp_here, ': Unable to deallocate arrays x1, iorder1' print *, irp_here, ': Unable to deallocate arrays x1, iorder1'
stop stop
endif endif
@ -322,8 +366,8 @@ BEGIN_TEMPLATE
i0 = i0+i2 i0 = i0+i2
deallocate(x2,iorder2,stat=err) deallocate(x2,iorder2,stat=err)
if (err /= 0) then if (err /= 0) then
print *, irp_here, ': Unable to deallocate arrays x2, iorder2' print *, irp_here, ': Unable to deallocate arrays x2, iorder2'
stop stop
endif endif
@ -336,66 +380,65 @@ BEGIN_TEMPLATE
endif endif
return return
endif endif
ASSERT (iradix > 0) ASSERT (iradix > 0)
if (isize < 48) then if (isize < 48) then
call insertion_$Xsort$big(x,iorder,isize) call insertion_$Xsort$big(x,iorder,isize)
return return
endif endif
allocate(x2(isize),iorder2(isize),stat=err) allocate(x2(isize),iorder2(isize),stat=err)
if (err /= 0) then if (err /= 0) then
print *, irp_here, ': Unable to allocate arrays x1, iorder1' print *, irp_here, ': Unable to allocate arrays x1, iorder1'
stop stop
endif endif
mask = ibset(zero,iradix) mask = ibset(zero,iradix)
i0=1 i0=1
i1=1 i1=1
do i=1,isize do i=1,isize
if (iand(mask,x(i)) == zero) then if (iand(mask,x(i)) == zero) then
iorder(i0) = iorder(i) iorder(i0) = iorder(i)
x(i0) = x(i) x(i0) = x(i)
i0 = i0+1 i0 = i0+1
else else
iorder2(i1) = iorder(i) iorder2(i1) = iorder(i)
x2(i1) = x(i) x2(i1) = x(i)
i1 = i1+1 i1 = i1+1
endif endif
enddo enddo
i0=i0-1 i0=i0-1
i1=i1-1 i1=i1-1
do i=1,i1 do i=1,i1
iorder(i0+i) = iorder2(i) iorder(i0+i) = iorder2(i)
x(i0+i) = x2(i) x(i0+i) = x2(i)
enddo enddo
deallocate(x2,iorder2,stat=err) deallocate(x2,iorder2,stat=err)
if (err /= 0) then if (err /= 0) then
print *, irp_here, ': Unable to allocate arrays x2, iorder2' print *, irp_here, ': Unable to allocate arrays x2, iorder2'
stop stop
endif endif
if (iradix == 0) then if (iradix == 0) then
return return
endif endif
if (i1>1) then if (i1>1) then
call $Xradix_sort$big(x(i0+1),iorder(i0+1),i1,iradix-1) call $Xradix_sort$big(x(i0+1),iorder(i0+1),i1,iradix-1)
endif endif
if (i0>1) then if (i0>1) then
call $Xradix_sort$big(x,iorder,i0,iradix-1) call $Xradix_sort$big(x,iorder,i0,iradix-1)
endif endif
end
end
SUBST [ X, type, octets, is_big, big, int_type, zero ] SUBST [ X, type, octets, is_big, big, int_type, zero ]
i ; integer ; 32 ; .False. ; ; integer ; 0;; i ; integer ; 32 ; .False. ; ; integer ; 0;;

33
src/Utils/tests/Makefile Normal file
View File

@ -0,0 +1,33 @@
OPENMP =1
PROFILE =0
DEBUG = 0
IRPF90+= -I tests
REF_FILES=$(subst %.irp.f, %.ref, $(wildcard *.irp.f))
.PHONY: clean executables serial_tests parallel_tests
all: clean executables serial_tests parallel_tests
parallel_tests: $(REF_FILES)
@echo ; echo " ---- Running parallel tests ----" ; echo
@OMP_NUM_THREADS=10 ${QPACKAGE_ROOT}/scripts/run_tests.py
serial_tests: $(REF_FILES)
@echo ; echo " ---- Running serial tests ----" ; echo
@OMP_NUM_THREADS=1 ${QPACKAGE_ROOT}/scripts/run_tests.py
executables: $(wildcard *.irp.f) veryclean
$(MAKE) -C ..
%.ref: $(wildcard $(QPACKAGE_ROOT)/data/inputs/*.md5) executables
$(QPACKAGE_ROOT)/scripts/create_test_ref.sh $*
clean:
$(MAKE) -C .. clean
veryclean:
$(MAKE) -C .. veryclean

View File

@ -0,0 +1,130 @@
program test_integration
implicit none
character*(128) :: arg
integer :: iargc
integer :: i
if (iargc() < 1) then
print *, iargc()
print *, 'usage : test_integration <test_name>'
stop 1
endif
call getarg(1,arg)
i = len(arg)
do while (arg(i:i) == ' ')
i -= 1
if (i == 0) then
stop 1
endif
enddo
i -= 1
do while (arg(i:i) /= '/')
i -= 1
if (i == 0) then
stop 1
endif
enddo
i += 1
arg = arg(i:)
BEGIN_SHELL [ /bin/bash ]
for i in $(grep subroutine tests/test_integration.irp.f | cut -d ' ' -f 2 | sed 's/test_//' )
do
echo "if (trim(arg) == '"$i"') then"
echo ' call test_'$i
echo 'endif'
done
END_SHELL
end
subroutine test_rint1
implicit none
integer :: i,j
double precision :: rho(10)
double precision :: rint1
do i=1,size(rho)
rho(i) = 2.d0**(1-i)
enddo
do j=1,size(rho)
do i=0,8
print '(I2,A,F12.8,A3,E15.8)', i, ',', rho(j), ' : ', rint1(i,rho(j))
enddo
enddo
end
subroutine test_rint_large_n
implicit none
integer :: i,j
double precision :: rho(10)
double precision :: rint_large_n
do i=1,size(rho)
rho(i) = 2.d0**(2-i)
enddo
do j=1,size(rho)
do i=4,20
print '(I2,A,F12.8,A3,E15.8)', i, ',', rho(j), ' : ', rint_large_n(i,rho(j))
enddo
enddo
end
subroutine test_hermite
implicit none
integer :: i,j
double precision :: x(10)
double precision :: hermite
do i=1,size(x)
x(i) = (-1.d0)**i * 2.d0**(5-i)
enddo
do j=1,size(x)
do i=0,10
print '(I2,A,F12.8,A3,E15.8)', i, ',', x(j), ' : ', hermite(i,x(j))
enddo
enddo
end
subroutine test_rint_sum
implicit none
integer :: i,j
double precision :: d1(0:50), rho(10)
double precision :: rint_sum
do i=0,size(d1)-1
d1(i) = (-1.d0)**i * 2.d0**(5-i)
enddo
do i=1,size(rho)
rho(i) = abs(1.d0/d1(i))
enddo
do j=1,size(rho)
do i=0,5
print '(I2,A,F12.8,A3,E15.8)', 4*i+1, ',', rho(j), ' : ', rint_sum(4*i+1,rho(j),d1)
enddo
enddo
end
subroutine test_rint
implicit none
integer :: i,j
double precision :: rho(10)
double precision :: rint
do i=1,size(rho)
rho(i) = 2.d0**(2-i)
enddo
do j=1,size(rho)
do i=0,20,3
print '(I2,A,F12.8,A3,E15.8)', i, ',', rho(j), ' : ', rint(i,rho(j))
enddo
enddo
end
subroutine test_F_integral
implicit none
integer :: i,j
double precision :: rho(10)
double precision :: F_integral
do i=1,size(rho)
rho(i) = 2.d0**(2-i)
enddo
do j=1,size(rho)
do i=0,20,3
print '(I2,A,F12.8,A3,E15.8)', i, ',', rho(j), ' : ', F_integral(i,rho(j))
enddo
enddo
end

View File

@ -0,0 +1,514 @@
data = {
'rint1' : {
'0, 1.00000000' : 0.74682413E+00,
'1, 1.00000000' : 0.18947235E+00,
'2, 1.00000000' : 0.10026880E+00,
'3, 1.00000000' : 0.66732275E-01,
'4, 1.00000000' : 0.49623241E-01,
'5, 1.00000000' : 0.39364865E-01,
'6, 1.00000000' : 0.32567034E-01,
'7, 1.00000000' : 0.27746002E-01,
'8, 1.00000000' : 0.24155294E-01,
'0, 0.50000000' : 0.85562439E+00,
'1, 0.50000000' : 0.24909373E+00,
'2, 0.50000000' : 0.14075054E+00,
'3, 0.50000000' : 0.97222024E-01,
'4, 0.50000000' : 0.74023511E-01,
'5, 0.50000000' : 0.59680941E-01,
'6, 0.50000000' : 0.49959693E-01,
'7, 0.50000000' : 0.42945347E-01,
'8, 0.50000000' : 0.37649547E-01,
'0, 0.25000000' : 0.92256201E+00,
'1, 0.25000000' : 0.28752246E+00,
'2, 0.25000000' : 0.16753319E+00,
'3, 0.25000000' : 0.11773034E+00,
'4, 0.25000000' : 0.90623235E-01,
'5, 0.25000000' : 0.73616662E-01,
'6, 0.25000000' : 0.61964994E-01,
'7, 0.25000000' : 0.53488276E-01,
'8, 0.25000000' : 0.47046726E-01,
'0, 0.12500000' : 0.95985044E+00,
'1, 0.12500000' : 0.30941414E+00,
'2, 0.12500000' : 0.18298209E+00,
'3, 0.12500000' : 0.12965410E+00,
'4, 0.12500000' : 0.10032732E+00,
'5, 0.12500000' : 0.81795915E-01,
'6, 0.12500000' : 0.69032643E-01,
'7, 0.12500000' : 0.59709841E-01,
'8, 0.12500000' : 0.52602850E-01,
'0, 0.06250000' : 0.97955155E+00,
'1, 0.06250000' : 0.32110789E+00,
'2, 0.06250000' : 0.19128479E+00,
'3, 0.06250000' : 0.13608717E+00,
'4, 0.06250000' : 0.10557686E+00,
'5, 0.06250000' : 0.86229246E-01,
'6, 0.06250000' : 0.72869188E-01,
'7, 0.06250000' : 0.63091082E-01,
'8, 0.06250000' : 0.55625318E-01,
'0, 0.03125000' : 0.98968027E+00,
'1, 0.03125000' : 0.32715253E+00,
'2, 0.03125000' : 0.19558951E+00,
'3, 0.03125000' : 0.13942892E+00,
'4, 0.03125000' : 0.10830743E+00,
'5, 0.03125000' : 0.88537500E-01,
'6, 0.03125000' : 0.74868200E-01,
'7, 0.03125000' : 0.64853890E-01,
'8, 0.03125000' : 0.57201824E-01,
'0, 0.01562500' : 0.99481599E+00,
'1, 0.01562500' : 0.33022570E+00,
'2, 0.01562500' : 0.19778136E+00,
'3, 0.01562500' : 0.14113208E+00,
'4, 0.01562500' : 0.10970000E+00,
'5, 0.01562500' : 0.89715269E-01,
'6, 0.01562500' : 0.75888558E-01,
'7, 0.01562500' : 0.65753944E-01,
'8, 0.01562500' : 0.58006946E-01,
'0, 0.00781250' : 0.99740193E+00,
'1, 0.00781250' : 0.33177518E+00,
'2, 0.00781250' : 0.19888731E+00,
'3, 0.00781250' : 0.14199186E+00,
'4, 0.00781250' : 0.11040323E+00,
'5, 0.00781250' : 0.90310159E-01,
'6, 0.00781250' : 0.76404035E-01,
'7, 0.00781250' : 0.66208710E-01,
'8, 0.00781250' : 0.58413795E-01,
'0, 0.00390625' : 0.99869944E+00,
'1, 0.00390625' : 0.33255317E+00,
'2, 0.00390625' : 0.19944281E+00,
'3, 0.00390625' : 0.14242381E+00,
'4, 0.00390625' : 0.11075658E+00,
'5, 0.00390625' : 0.90609118E-01,
'6, 0.00390625' : 0.76663109E-01,
'7, 0.00390625' : 0.66437288E-01,
'8, 0.00390625' : 0.58618300E-01,
'0, 0.00195312' : 0.99934934E+00,
'1, 0.00195312' : 0.33294298E+00,
'2, 0.00195312' : 0.19972119E+00,
'3, 0.00195312' : 0.14264030E+00,
'4, 0.00195312' : 0.11093370E+00,
'5, 0.00195312' : 0.90758978E-01,
'6, 0.00195312' : 0.76792981E-01,
'7, 0.00195312' : 0.66551877E-01,
'8, 0.00195312' : 0.58720824E-01,
},
'rint_large_n' : {
'4, 2.00000000' : 0.22769400E-01,
'5, 2.00000000' : 0.17397330E-01,
'6, 2.00000000' : 0.14008836E-01,
'7, 2.00000000' : 0.11694896E-01,
'8, 2.00000000' : 0.10022038E-01,
'9, 2.00000000' : 0.87598405E-02,
'10, 2.00000000' : 0.77754214E-02,
'11, 2.00000000' : 0.69871414E-02,
'12, 2.00000000' : 0.63422421E-02,
'13, 2.00000000' : 0.58051924E-02,
'14, 2.00000000' : 0.53512279E-02,
'15, 2.00000000' : 0.49625818E-02,
'16, 2.00000000' : 0.46261880E-02,
'17, 2.00000000' : 0.43322304E-02,
'18, 2.00000000' : 0.40731954E-02,
'19, 2.00000000' : 0.38432370E-02,
'20, 2.00000000' : 0.36377399E-02,
'4, 1.00000000' : 0.49623241E-01,
'5, 1.00000000' : 0.39364865E-01,
'6, 1.00000000' : 0.32567034E-01,
'7, 1.00000000' : 0.27746002E-01,
'8, 1.00000000' : 0.24155294E-01,
'9, 1.00000000' : 0.21380280E-01,
'10, 1.00000000' : 0.19172936E-01,
'11, 1.00000000' : 0.17376108E-01,
'12, 1.00000000' : 0.15885526E-01,
'13, 1.00000000' : 0.14629351E-01,
'14, 1.00000000' : 0.13556514E-01,
'15, 1.00000000' : 0.12629735E-01,
'16, 1.00000000' : 0.11821172E-01,
'17, 1.00000000' : 0.11109621E-01,
'18, 1.00000000' : 0.10478652E-01,
'19, 1.00000000' : 0.99153382E-02,
'20, 1.00000000' : 0.94093737E-02,
'4, 0.50000000' : 0.74131525E-01,
'5, 0.50000000' : 0.59734080E-01,
'6, 0.50000000' : 0.49988791E-01,
'7, 0.50000000' : 0.42962588E-01,
'8, 0.50000000' : 0.37660400E-01,
'9, 0.50000000' : 0.33518800E-01,
'10, 0.50000000' : 0.30195249E-01,
'11, 0.50000000' : 0.27469686E-01,
'12, 0.50000000' : 0.25194350E-01,
'13, 0.50000000' : 0.23266388E-01,
'14, 0.50000000' : 0.21612012E-01,
'15, 0.50000000' : 0.20176927E-01,
'16, 0.50000000' : 0.18920297E-01,
'17, 0.50000000' : 0.17810821E-01,
'18, 0.50000000' : 0.16824108E-01,
'19, 0.50000000' : 0.15940870E-01,
'20, 0.50000000' : 0.15145655E-01,
'4, 0.25000000' : 0.90623235E-01,
'5, 0.25000000' : 0.73616662E-01,
'6, 0.25000000' : 0.61964994E-01,
'7, 0.25000000' : 0.53488276E-01,
'8, 0.25000000' : 0.47046726E-01,
'9, 0.25000000' : 0.41987104E-01,
'10, 0.25000000' : 0.37908392E-01,
'11, 0.25000000' : 0.34550883E-01,
'12, 0.25000000' : 0.31739030E-01,
'13, 0.25000000' : 0.29349937E-01,
'14, 0.25000000' : 0.27295006E-01,
'15, 0.25000000' : 0.25508764E-01,
'16, 0.25000000' : 0.23941782E-01,
'17, 0.25000000' : 0.22556049E-01,
'18, 0.25000000' : 0.21321854E-01,
'19, 0.25000000' : 0.20215642E-01,
'20, 0.25000000' : 0.19218495E-01,
'4, 0.12500000' : 0.10032732E+00,
'5, 0.12500000' : 0.81795915E-01,
'6, 0.12500000' : 0.69032643E-01,
'7, 0.12500000' : 0.59709841E-01,
'8, 0.12500000' : 0.52602850E-01,
'9, 0.12500000' : 0.47006219E-01,
'10, 0.12500000' : 0.42485051E-01,
'11, 0.12500000' : 0.38756708E-01,
'12, 0.12500000' : 0.35629567E-01,
'13, 0.12500000' : 0.32969128E-01,
'14, 0.12500000' : 0.30678211E-01,
'15, 0.12500000' : 0.28684857E-01,
'16, 0.12500000' : 0.26934646E-01,
'17, 0.12500000' : 0.25385662E-01,
'18, 0.12500000' : 0.24005098E-01,
'19, 0.12500000' : 0.22766909E-01,
'20, 0.12500000' : 0.21650155E-01,
'4, 0.06250000' : 0.10557686E+00,
'5, 0.06250000' : 0.86229246E-01,
'6, 0.06250000' : 0.72869188E-01,
'7, 0.06250000' : 0.63091082E-01,
'8, 0.06250000' : 0.55625318E-01,
'9, 0.06250000' : 0.49738703E-01,
'10, 0.06250000' : 0.44978296E-01,
'11, 0.06250000' : 0.41049216E-01,
'12, 0.06250000' : 0.37751241E-01,
'13, 0.06250000' : 0.34943654E-01,
'14, 0.06250000' : 0.32524670E-01,
'15, 0.06250000' : 0.30418845E-01,
'16, 0.06250000' : 0.28569075E-01,
'17, 0.06250000' : 0.26931342E-01,
'18, 0.06250000' : 0.25471168E-01,
'19, 0.06250000' : 0.24161166E-01,
'20, 0.06250000' : 0.22979305E-01,
'4, 0.03125000' : 0.10830743E+00,
'5, 0.03125000' : 0.88537500E-01,
'6, 0.03125000' : 0.74868200E-01,
'7, 0.03125000' : 0.64853890E-01,
'8, 0.03125000' : 0.57201824E-01,
'9, 0.03125000' : 0.51164511E-01,
'10, 0.03125000' : 0.46279696E-01,
'11, 0.03125000' : 0.42246171E-01,
'12, 0.03125000' : 0.38859267E-01,
'13, 0.03125000' : 0.35975049E-01,
'14, 0.03125000' : 0.33489346E-01,
'15, 0.03125000' : 0.31324909E-01,
'16, 0.03125000' : 0.29423240E-01,
'17, 0.03125000' : 0.27739231E-01,
'18, 0.03125000' : 0.26237537E-01,
'19, 0.03125000' : 0.24890074E-01,
'20, 0.03125000' : 0.23674243E-01,
'4, 0.01562500' : 0.10970000E+00,
'5, 0.01562500' : 0.89715269E-01,
'6, 0.01562500' : 0.75888558E-01,
'7, 0.01562500' : 0.65753944E-01,
'8, 0.01562500' : 0.58006946E-01,
'9, 0.01562500' : 0.51892813E-01,
'10, 0.01562500' : 0.46944559E-01,
'11, 0.01562500' : 0.42857760E-01,
'12, 0.01562500' : 0.39425485E-01,
'13, 0.01562500' : 0.36502162E-01,
'14, 0.01562500' : 0.33982407E-01,
'15, 0.01562500' : 0.31788050E-01,
'16, 0.01562500' : 0.29859885E-01,
'17, 0.01562500' : 0.28152246E-01,
'18, 0.01562500' : 0.26629349E-01,
'19, 0.01562500' : 0.25262753E-01,
'20, 0.01562500' : 0.24029571E-01,
'4, 0.00781250' : 0.11040323E+00,
'5, 0.00781250' : 0.90310159E-01,
'6, 0.00781250' : 0.76404035E-01,
'7, 0.00781250' : 0.66208710E-01,
'8, 0.00781250' : 0.58413795E-01,
'9, 0.00781250' : 0.52260879E-01,
'10, 0.00781250' : 0.47280591E-01,
'11, 0.00781250' : 0.43166888E-01,
'12, 0.00781250' : 0.39711698E-01,
'13, 0.00781250' : 0.36768623E-01,
'14, 0.00781250' : 0.34231665E-01,
'15, 0.00781250' : 0.32022192E-01,
'16, 0.00781250' : 0.30080639E-01,
'17, 0.00781250' : 0.28361060E-01,
'18, 0.00781250' : 0.26827449E-01,
'19, 0.00781250' : 0.25451185E-01,
'20, 0.00781250' : 0.24209234E-01,
'4, 0.00390625' : 0.11075658E+00,
'5, 0.00390625' : 0.90609118E-01,
'6, 0.00390625' : 0.76663109E-01,
'7, 0.00390625' : 0.66437288E-01,
'8, 0.00390625' : 0.58618300E-01,
'9, 0.00390625' : 0.52445898E-01,
'10, 0.00390625' : 0.47449515E-01,
'11, 0.00390625' : 0.43322293E-01,
'12, 0.00390625' : 0.39855587E-01,
'13, 0.00390625' : 0.36902585E-01,
'14, 0.00390625' : 0.34356981E-01,
'15, 0.00390625' : 0.32139911E-01,
'16, 0.00390625' : 0.30191629E-01,
'17, 0.00390625' : 0.28466050E-01,
'18, 0.00390625' : 0.26927053E-01,
'19, 0.00390625' : 0.25545928E-01,
'20, 0.00390625' : 0.24299570E-01,
},
'hermite': {
'0,-16.00000000' : 0.10000000E+01,
'1,-16.00000000' : -0.32000000E+02,
'2,-16.00000000' : 0.10220000E+04,
'3,-16.00000000' : -0.32576000E+05,
'4,-16.00000000' : 0.10363000E+07,
'5,-16.00000000' : -0.32900992E+08,
'6,-16.00000000' : 0.10424687E+10,
'7,-16.00000000' : -0.32964188E+11,
'8,-16.00000000' : 0.10402595E+13,
'9,-16.00000000' : -0.32760875E+14,
'10,-16.00000000' : 0.10296233E+16,
'0, 8.00000000' : 0.10000000E+01,
'1, 8.00000000' : 0.16000000E+02,
'2, 8.00000000' : 0.25400000E+03,
'3, 8.00000000' : 0.40000000E+04,
'4, 8.00000000' : 0.62476000E+05,
'5, 8.00000000' : 0.96761600E+06,
'6, 8.00000000' : 0.14857096E+08,
'7, 8.00000000' : 0.22610214E+09,
'8, 8.00000000' : 0.34096350E+10,
'9, 8.00000000' : 0.50936525E+11,
'10, 8.00000000' : 0.75361097E+12,
'0, -4.00000000' : 0.10000000E+01,
'1, -4.00000000' : -0.80000000E+01,
'2, -4.00000000' : 0.62000000E+02,
'3, -4.00000000' : -0.46400000E+03,
'4, -4.00000000' : 0.33400000E+04,
'5, -4.00000000' : -0.23008000E+05,
'6, -4.00000000' : 0.15066400E+06,
'7, -4.00000000' : -0.92921600E+06,
'8, -4.00000000' : 0.53244320E+07,
'9, -4.00000000' : -0.27728000E+08,
'10, -4.00000000' : 0.12598422E+09,
'0, 2.00000000' : 0.10000000E+01,
'1, 2.00000000' : 0.40000000E+01,
'2, 2.00000000' : 0.14000000E+02,
'3, 2.00000000' : 0.40000000E+02,
'4, 2.00000000' : 0.76000000E+02,
'5, 2.00000000' : -0.16000000E+02,
'6, 2.00000000' : -0.82400000E+03,
'7, 2.00000000' : -0.31040000E+04,
'8, 2.00000000' : -0.88000000E+03,
'9, 2.00000000' : 0.46144000E+05,
'10, 2.00000000' : 0.20041600E+06,
'0, -1.00000000' : 0.10000000E+01,
'1, -1.00000000' : -0.20000000E+01,
'2, -1.00000000' : 0.20000000E+01,
'3, -1.00000000' : 0.40000000E+01,
'4, -1.00000000' : -0.20000000E+02,
'5, -1.00000000' : 0.80000000E+01,
'6, -1.00000000' : 0.18400000E+03,
'7, -1.00000000' : -0.46400000E+03,
'8, -1.00000000' : -0.16480000E+04,
'9, -1.00000000' : 0.10720000E+05,
'10, -1.00000000' : 0.82240000E+04,
'0, 0.50000000' : 0.10000000E+01,
'1, 0.50000000' : 0.10000000E+01,
'2, 0.50000000' : -0.10000000E+01,
'3, 0.50000000' : -0.50000000E+01,
'4, 0.50000000' : 0.10000000E+01,
'5, 0.50000000' : 0.41000000E+02,
'6, 0.50000000' : 0.31000000E+02,
'7, 0.50000000' : -0.46100000E+03,
'8, 0.50000000' : -0.89500000E+03,
'9, 0.50000000' : 0.64810000E+04,
'10, 0.50000000' : 0.22591000E+05,
'0, -0.25000000' : 0.10000000E+01,
'1, -0.25000000' : -0.50000000E+00,
'2, -0.25000000' : -0.17500000E+01,
'3, -0.25000000' : 0.28750000E+01,
'4, -0.25000000' : 0.90625000E+01,
'5, -0.25000000' : -0.27531250E+02,
'6, -0.25000000' : -0.76859375E+02,
'7, -0.25000000' : 0.36880469E+03,
'8, -0.25000000' : 0.89162891E+03,
'9, -0.25000000' : -0.63466895E+04,
'10, -0.25000000' : -0.12875976E+05,
'0, 0.12500000' : 0.10000000E+01,
'1, 0.12500000' : 0.25000000E+00,
'2, 0.12500000' : -0.19375000E+01,
'3, 0.12500000' : -0.14843750E+01,
'4, 0.12500000' : 0.11253906E+02,
'5, 0.12500000' : 0.14688477E+02,
'6, 0.12500000' : -0.10886694E+03,
'7, 0.12500000' : -0.20347845E+03,
'8, 0.12500000' : 0.14732676E+04,
'9, 0.12500000' : 0.36239722E+04,
'10, 0.12500000' : -0.25612824E+05,
'0, -0.06250000' : 0.10000000E+01,
'1, -0.06250000' : -0.12500000E+00,
'2, -0.06250000' : -0.19843750E+01,
'3, -0.06250000' : 0.74804688E+00,
'4, -0.06250000' : 0.11812744E+02,
'5, -0.06250000' : -0.74609680E+01,
'6, -0.06250000' : -0.11719482E+03,
'7, -0.06250000' : 0.10418097E+03,
'8, -0.06250000' : 0.16277049E+04,
'9, -0.06250000' : -0.18703586E+04,
'10, -0.06250000' : -0.29064893E+05,
'0, 0.03125000' : 0.10000000E+01,
'1, 0.03125000' : 0.62500000E-01,
'2, 0.03125000' : -0.19960938E+01,
'3, 0.03125000' : -0.37475586E+00,
'4, 0.03125000' : 0.11953140E+02,
'5, 0.03125000' : 0.37451181E+01,
'6, 0.03125000' : -0.11929733E+03,
'7, 0.03125000' : -0.52397501E+02,
'8, 0.03125000' : 0.16668878E+04,
'9, 0.03125000' : 0.94254050E+03,
'10, 0.03125000' : -0.29945072E+05,
},
'rint_sum' : {
'1, 0.06250000' : 0.31345650E+02,
'5, 0.06250000' : 0.34297082E+02,
'9, 0.06250000' : 0.34378323E+02,
'13, 0.06250000' : 0.34381587E+02,
'17, 0.06250000' : 0.34381737E+02,
'21, 0.06250000' : 0.34381745E+02,
'1, 0.12500000' : 0.30715214E+02,
'5, 0.12500000' : 0.33556491E+02,
'9, 0.12500000' : 0.33633859E+02,
'13, 0.12500000' : 0.33636955E+02,
'17, 0.12500000' : 0.33637097E+02,
'21, 0.12500000' : 0.33637104E+02,
'1, 0.25000000' : 0.29521984E+02,
'5, 0.25000000' : 0.32157230E+02,
'9, 0.25000000' : 0.32227424E+02,
'13, 0.25000000' : 0.32230208E+02,
'17, 0.25000000' : 0.32230336E+02,
'21, 0.25000000' : 0.32230342E+02,
'1, 0.50000000' : 0.27379981E+02,
'5, 0.50000000' : 0.29654231E+02,
'9, 0.50000000' : 0.29712095E+02,
'13, 0.50000000' : 0.29714351E+02,
'17, 0.50000000' : 0.29714453E+02,
'21, 0.50000000' : 0.29714458E+02,
'1, 1.00000000' : 0.23898372E+02,
'5, 1.00000000' : 0.25614689E+02,
'9, 1.00000000' : 0.25654258E+02,
'13, 1.00000000' : 0.25655742E+02,
'17, 1.00000000' : 0.25655808E+02,
'21, 1.00000000' : 0.25655811E+02,
'1, 2.00000000' : 0.19140608E+02,
'5, 2.00000000' : 0.20172111E+02,
'9, 2.00000000' : 0.20191130E+02,
'13, 2.00000000' : 0.20191783E+02,
'17, 2.00000000' : 0.20191811E+02,
'21, 2.00000000' : 0.20191812E+02,
'1, 4.00000000' : 0.14113302E+02,
'5, 4.00000000' : 0.14571079E+02,
'9, 4.00000000' : 0.14576072E+02,
'13, 4.00000000' : 0.14576208E+02,
'17, 4.00000000' : 0.14576213E+02,
'21, 4.00000000' : 0.14576214E+02,
'1, 8.00000000' : 0.10025878E+02,
'5, 8.00000000' : 0.10189658E+02,
'9, 8.00000000' : 0.10190276E+02,
'13, 8.00000000' : 0.10190285E+02,
'17, 8.00000000' : 0.10190285E+02,
'21, 8.00000000' : 0.10190285E+02,
'1, 16.00000000' : 0.70898153E+01,
'5, 16.00000000' : 0.71465026E+01,
'9, 16.00000000' : 0.71465561E+01,
'13, 16.00000000' : 0.71465563E+01,
'17, 16.00000000' : 0.71465563E+01,
'21, 16.00000000' : 0.71465563E+01,
'1, 32.00000000' : 0.50132565E+01,
'5, 32.00000000' : 0.50330691E+01,
'9, 32.00000000' : 0.50330737E+01,
'13, 32.00000000' : 0.50330737E+01,
'17, 32.00000000' : 0.50330737E+01,
'21, 32.00000000' : 0.50330737E+01,
},
'rint' : {
'0, 2.00000000' : 0.59814401E+00,
'3, 2.00000000' : 0.32344698E-01,
'6, 2.00000000' : 0.14008836E-01,
'9, 2.00000000' : 0.87598405E-02,
'12, 2.00000000' : 0.63422421E-02,
'15, 2.00000000' : 0.49625795E-02,
'18, 2.00000000' : 0.40719014E-02,
'0, 1.00000000' : 0.74682413E+00,
'3, 1.00000000' : 0.66732275E-01,
'6, 1.00000000' : 0.32567034E-01,
'9, 1.00000000' : 0.21380280E-01,
'12, 1.00000000' : 0.15885521E-01,
'15, 1.00000000' : 0.12617897E-01,
'18, 1.00000000' : -0.42503468E-01,
'0, 0.50000000' : 0.85562439E+00,
'3, 0.50000000' : 0.97222024E-01,
'6, 0.50000000' : 0.49959693E-01,
'9, 0.50000000' : 0.33511631E-01,
'12, 0.50000000' : 0.25191806E-01,
'15, 0.50000000' : 0.20175809E-01,
'18, 0.50000000' : 0.16823542E-01,
'0, 0.25000000' : 0.92256201E+00,
'3, 0.25000000' : 0.11773034E+00,
'6, 0.25000000' : 0.61964994E-01,
'9, 0.25000000' : 0.41987104E-01,
'12, 0.25000000' : 0.31739030E-01,
'15, 0.25000000' : 0.25508764E-01,
'18, 0.25000000' : 0.21321854E-01,
'0, 0.12500000' : 0.95985044E+00,
'3, 0.12500000' : 0.12965410E+00,
'6, 0.12500000' : 0.69032643E-01,
'9, 0.12500000' : 0.47006219E-01,
'12, 0.12500000' : 0.35629567E-01,
'15, 0.12500000' : 0.28684857E-01,
'18, 0.12500000' : 0.24005098E-01,
'0, 0.06250000' : 0.97955155E+00,
'3, 0.06250000' : 0.13608717E+00,
'6, 0.06250000' : 0.72869188E-01,
'9, 0.06250000' : 0.49738703E-01,
'12, 0.06250000' : 0.37751241E-01,
'15, 0.06250000' : 0.30418845E-01,
'18, 0.06250000' : 0.25471168E-01,
'0, 0.03125000' : 0.98968027E+00,
'3, 0.03125000' : 0.13942892E+00,
'6, 0.03125000' : 0.74868200E-01,
'9, 0.03125000' : 0.51164511E-01,
'12, 0.03125000' : 0.38859267E-01,
'15, 0.03125000' : 0.31324909E-01,
'18, 0.03125000' : 0.26237537E-01,
'0, 0.01562500' : 0.99481599E+00,
'3, 0.01562500' : 0.14113208E+00,
'6, 0.01562500' : 0.75888558E-01,
'9, 0.01562500' : 0.51892813E-01,
'12, 0.01562500' : 0.39425485E-01,
'15, 0.01562500' : 0.31788050E-01,
'18, 0.01562500' : 0.26629349E-01,
'0, 0.00781250' : 0.99740193E+00,
'3, 0.00781250' : 0.14199186E+00,
'6, 0.00781250' : 0.76404035E-01,
'9, 0.00781250' : 0.52260879E-01,
'12, 0.00781250' : 0.39711698E-01,
'15, 0.00781250' : 0.32022192E-01,
'18, 0.00781250' : 0.26827449E-01,
'0, 0.00390625' : 0.99869944E+00,
'3, 0.00390625' : 0.14242381E+00,
'6, 0.00390625' : 0.76663109E-01,
'9, 0.00390625' : 0.52445898E-01,
'12, 0.00390625' : 0.39855587E-01,
'15, 0.00390625' : 0.32139911E-01,
'18, 0.00390625' : 0.26927053E-01,
},
'F_integral' : {
}
}

View File

@ -1,65 +1,75 @@
double precision function binom_func(i,j) double precision function binom_func(i,j)
implicit none implicit none
integer,intent(in) :: i,j BEGIN_DOC
double precision :: fact, f !.. math ::
integer, save :: ifirst !
double precision, save :: memo(0:15,0:15) ! \frac{i!}{j!(i-j)!}
!DEC$ ATTRIBUTES ALIGN : $IRP_ALIGN :: memo !
integer :: k,l END_DOC
if (ifirst == 0) then integer,intent(in) :: i,j
ifirst = 1 double precision :: fact, f
do k=0,15 integer, save :: ifirst
f = fact(k) double precision, save :: memo(0:15,0:15)
do l=0,15 !DEC$ ATTRIBUTES ALIGN : $IRP_ALIGN :: memo
memo(k,l) = f/(fact(l)*fact(k-l)) integer :: k,l
if (ifirst == 0) then
ifirst = 1
do k=0,15
f = fact(k)
do l=0,15
memo(k,l) = f/(fact(l)*fact(k-l))
enddo
enddo enddo
enddo endif
endif if ( (i<=15).and.(j<=15) ) then
if ( (i<=15).and.(j<=15) ) then binom_func = memo(i,j)
binom_func = memo(i,j) else
else binom_func = fact(i)/(fact(j)*fact(i-j))
binom_func = fact(i)/(fact(j)*fact(i-j)) endif
endif
end end
BEGIN_PROVIDER [ double precision, binom, (0:20,0:20) ] BEGIN_PROVIDER [ double precision, binom, (0:20,0:20) ]
&BEGIN_PROVIDER [ double precision, binom_transp, (0:20,0:20) ] &BEGIN_PROVIDER [ double precision, binom_transp, (0:20,0:20) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Binomial coefficients ! Binomial coefficients
END_DOC END_DOC
integer :: k,l integer :: k,l
double precision :: fact, f double precision :: fact, f
do k=0,20 do k=0,20
f = fact(k) f = fact(k)
do l=0,20 do l=0,20
binom(k,l) = f/(fact(l)*fact(k-l)) binom(k,l) = f/(fact(l)*fact(k-l))
binom_transp(l,k) = binom(k,l) binom_transp(l,k) = binom(k,l)
enddo
enddo enddo
enddo
END_PROVIDER END_PROVIDER
integer function align_double(n) integer function align_double(n)
implicit none implicit none
integer :: n BEGIN_DOC
include 'include/constants.F' ! Compute 1st dimension such that it is aligned for vectorization.
if (mod(n,SIMD_vector/4) /= 0) then END_DOC
align_double= n + SIMD_vector/4 - mod(n,SIMD_vector/4) integer :: n
else include 'include/constants.F'
align_double= n if (mod(n,SIMD_vector/4) /= 0) then
endif align_double= n + SIMD_vector/4 - mod(n,SIMD_vector/4)
else
align_double= n
endif
end end
double precision function fact(n) double precision function fact(n)
implicit none implicit none
integer :: n BEGIN_DOC
double precision, save :: memo(1:100) ! n!
integer, save :: memomax = 1 END_DOC
integer :: n
double precision, save :: memo(1:100)
integer, save :: memomax = 1
if (n<=memomax) then if (n<=memomax) then
if (n<2) then if (n<2) then
@ -70,7 +80,7 @@ double precision function fact(n)
return return
endif endif
integer :: i integer :: i
memo(1) = 1.d0 memo(1) = 1.d0
do i=memomax+1,min(n,100) do i=memomax+1,min(n,100)
memo(i) = memo(i-1)*float(i) memo(i) = memo(i-1)*float(i)
@ -85,12 +95,12 @@ end function
BEGIN_PROVIDER [ double precision, fact_inv, (128) ] BEGIN_PROVIDER [ double precision, fact_inv, (128) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! 1.d0/fact(k) ! 1/n!
END_DOC END_DOC
integer :: i integer :: i
double precision :: fact double precision :: fact
do i=1,size(fact_inv) do i=1,size(fact_inv)
fact_inv(i) = 1.d0/fact(i) fact_inv(i) = 1.d0/fact(i)
enddo enddo
@ -98,9 +108,12 @@ END_PROVIDER
double precision function dble_fact(n) result(fact2) double precision function dble_fact(n) result(fact2)
implicit none implicit none
integer :: n BEGIN_DOC
double precision, save :: memo(1:100) ! n!!
integer, save :: memomax = 1 END_DOC
integer :: n
double precision, save :: memo(1:100)
integer, save :: memomax = 1
ASSERT (iand(n,1) /= 0) ASSERT (iand(n,1) /= 0)
if (n<=memomax) then if (n<=memomax) then
@ -112,7 +125,7 @@ double precision function dble_fact(n) result(fact2)
return return
endif endif
integer :: i integer :: i
memo(1) = 1.d0 memo(1) = 1.d0
do i=memomax+2,min(n,99),2 do i=memomax+2,min(n,99),2
memo(i) = memo(i-2)* float(i) memo(i) = memo(i-2)* float(i)
@ -127,33 +140,39 @@ double precision function dble_fact(n) result(fact2)
end function end function
subroutine write_git_log(iunit) subroutine write_git_log(iunit)
implicit none implicit none
integer, intent(in) :: iunit BEGIN_DOC
write(iunit,*) '----------------' ! Write the last git commit in file iunit.
write(iunit,*) 'Last git commit:' END_DOC
BEGIN_SHELL [ /bin/bash ] integer, intent(in) :: iunit
git log -1 | sed "s/'//g"| sed "s/^/ write(iunit,*) '/g" | sed "s/$/'/g" write(iunit,*) '----------------'
END_SHELL write(iunit,*) 'Last git commit:'
write(iunit,*) '----------------' BEGIN_SHELL [ /bin/bash ]
git log -1 2>/dev/null | sed "s/'//g"| sed "s/^/ write(iunit,*) '/g" | sed "s/$/'/g" || echo "Unknown"
END_SHELL
write(iunit,*) '----------------'
end end
BEGIN_PROVIDER [ double precision, inv_int, (128) ] BEGIN_PROVIDER [ double precision, inv_int, (128) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! 1/i ! 1/i
END_DOC END_DOC
integer :: i integer :: i
do i=1,size(inv_int) do i=1,size(inv_int)
inv_int(i) = 1.d0/dble(i) inv_int(i) = 1.d0/dble(i)
enddo enddo
END_PROVIDER END_PROVIDER
subroutine wall_time(t) subroutine wall_time(t)
implicit none implicit none
double precision, intent(out) :: t BEGIN_DOC
integer :: c ! The equivalent of cpu_time, but for the wall time.
integer, save :: rate = 0 END_DOC
double precision, intent(out) :: t
integer :: c
integer, save :: rate = 0
if (rate == 0) then if (rate == 0) then
CALL SYSTEM_CLOCK(count_rate=rate) CALL SYSTEM_CLOCK(count_rate=rate)
endif endif
@ -162,17 +181,17 @@ subroutine wall_time(t)
end end
BEGIN_PROVIDER [ integer, nproc ] BEGIN_PROVIDER [ integer, nproc ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Number of current openmp threads ! Number of current OpenMP threads
END_DOC END_DOC
integer :: omp_get_num_threads integer :: omp_get_num_threads
nproc = 1 nproc = 1
!$OMP PARALLEL !$OMP PARALLEL
!$OMP MASTER !$OMP MASTER
!$ nproc = omp_get_num_threads() !$ nproc = omp_get_num_threads()
!$OMP END MASTER !$OMP END MASTER
!$OMP END PARALLEL !$OMP END PARALLEL
END_PROVIDER END_PROVIDER