1
0
mirror of https://github.com/TREX-CoE/qmckl.git synced 2024-06-30 00:44:52 +02:00
qmckl/org/qmckl_distance.org

1474 lines
43 KiB
Org Mode
Raw Normal View History

#+TITLE: Inter-particle distances
2021-04-30 01:26:19 +02:00
#+SETUPFILE: ../tools/theme.setup
#+INCLUDE: ../tools/lib.org
2020-10-22 01:24:14 +02:00
2021-03-09 01:16:23 +01:00
Functions for the computation of distances between particles.
2020-10-22 00:50:07 +02:00
2021-03-09 01:16:23 +01:00
* Headers :noexport:
2021-04-30 01:26:19 +02:00
#+begin_src elisp :noexport :results none
2021-04-17 12:35:52 +02:00
(org-babel-lob-ingest "../tools/lib.org")
#+end_src
2020-10-22 00:50:07 +02:00
2021-03-09 01:16:23 +01:00
#+begin_src c :comments link :tangle (eval c_test) :noweb yes
2020-10-22 00:50:07 +02:00
#include "qmckl.h"
2021-05-11 16:41:03 +02:00
#include "assert.h"
2021-05-10 10:05:50 +02:00
#ifdef HAVE_CONFIG_H
2021-05-10 10:41:59 +02:00
#include "config.h"
2021-05-09 02:12:38 +02:00
#endif
2021-05-11 16:41:03 +02:00
int main() {
2020-10-22 00:50:07 +02:00
qmckl_context context;
context = qmckl_context_create();
2021-03-09 01:16:23 +01:00
#+end_src
2020-10-22 00:50:07 +02:00
2021-03-09 01:16:23 +01:00
* Squared distance
2020-10-22 00:50:07 +02:00
** ~qmckl_distance_sq~
:PROPERTIES:
:Name: qmckl_distance_sq
:CRetType: qmckl_exit_code
2021-03-30 14:51:23 +02:00
:FRetType: qmckl_exit_code
:END:
~qmckl_distance_sq~ computes the matrix of the squared distances
2021-03-19 00:10:35 +01:00
between all pairs of points in two sets, one point within each set:
2020-10-22 01:24:14 +02:00
2021-03-09 01:16:23 +01:00
\[
C_{ij} = \sum_{k=1}^3 (A_{k,i}-B_{k,j})^2
\]
2020-10-22 01:24:14 +02:00
#+NAME: qmckl_distance_sq_args
| qmckl_context | context | in | Global state |
| char | transa | in | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed |
| char | transb | in | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed |
| int64_t | m | in | Number of points in the first set |
| int64_t | n | in | Number of points in the second set |
2021-04-17 12:35:52 +02:00
| double | A[][lda] | in | Array containing the $m \times 3$ matrix $A$ |
| int64_t | lda | in | Leading dimension of array ~A~ |
2021-04-17 12:35:52 +02:00
| double | B[][ldb] | in | Array containing the $n \times 3$ matrix $B$ |
| int64_t | ldb | in | Leading dimension of array ~B~ |
| double | C[n][ldc] | out | Array containing the $m \times n$ matrix $C$ |
| int64_t | ldc | in | Leading dimension of array ~C~ |
2020-10-22 00:50:07 +02:00
2021-03-09 01:16:23 +01:00
*** Requirements
2020-10-22 00:50:07 +02:00
- ~context~ is not ~QMCKL_NULL_CONTEXT~
- ~m > 0~
- ~n > 0~
- ~lda >= 3~ if ~transa == 'N'~
- ~lda >= m~ if ~transa == 'T'~
- ~ldb >= 3~ if ~transb == 'N'~
- ~ldb >= n~ if ~transb == 'T'~
2021-04-30 01:26:19 +02:00
- ~ldc >= m~
2021-03-09 01:16:23 +01:00
- ~A~ is allocated with at least $3 \times m \times 8$ bytes
- ~B~ is allocated with at least $3 \times n \times 8$ bytes
- ~C~ is allocated with at least $m \times n \times 8$ bytes
2021-04-30 01:26:19 +02:00
*** C header
#+CALL: generate_c_header(table=qmckl_distance_sq_args,rettyp=get_value("CRetType"),fname=get_value("Name"))
#+RESULTS:
2021-03-30 14:51:23 +02:00
#+begin_src c :tangle (eval h_func) :comments org
qmckl_exit_code qmckl_distance_sq (
const qmckl_context context,
const char transa,
const char transb,
const int64_t m,
const int64_t n,
const double* A,
const int64_t lda,
const double* B,
const int64_t ldb,
2021-04-17 12:35:52 +02:00
double* const C,
2021-04-30 01:26:19 +02:00
const int64_t ldc );
2021-03-09 01:16:23 +01:00
#+end_src
2020-10-22 00:50:07 +02:00
2021-03-09 01:16:23 +01:00
*** Source
#+begin_src f90 :tangle (eval f)
2021-04-26 01:45:25 +02:00
integer function qmckl_distance_sq_f(context, transa, transb, m, n, &
A, LDA, B, LDB, C, LDC) &
result(info)
2021-03-19 00:10:35 +01:00
use qmckl
2020-10-22 00:50:07 +02:00
implicit none
2021-04-01 01:19:33 +02:00
integer(qmckl_context) , intent(in) :: context
2020-10-28 20:15:36 +01:00
character , intent(in) :: transa, transb
2020-10-25 15:02:37 +01:00
integer*8 , intent(in) :: m, n
integer*8 , intent(in) :: lda
2020-10-28 20:15:36 +01:00
real*8 , intent(in) :: A(lda,*)
2020-10-25 15:02:37 +01:00
integer*8 , intent(in) :: ldb
2020-10-28 20:15:36 +01:00
real*8 , intent(in) :: B(ldb,*)
2020-10-25 15:02:37 +01:00
integer*8 , intent(in) :: ldc
2020-10-28 20:15:36 +01:00
real*8 , intent(out) :: C(ldc,*)
2020-10-25 15:02:37 +01:00
integer*8 :: i,j
real*8 :: x, y, z
2020-10-28 20:15:36 +01:00
integer :: transab
2020-10-22 01:24:14 +02:00
2021-04-26 01:45:25 +02:00
info = QMCKL_SUCCESS
2020-10-22 01:24:14 +02:00
2021-03-19 00:10:35 +01:00
if (context == QMCKL_NULL_CONTEXT) then
info = QMCKL_INVALID_CONTEXT
2020-10-22 00:50:07 +02:00
return
endif
2020-10-22 01:24:14 +02:00
2020-10-22 00:50:07 +02:00
if (m <= 0_8) then
2021-03-19 00:10:35 +01:00
info = QMCKL_INVALID_ARG_4
2020-10-22 00:50:07 +02:00
return
endif
2020-10-22 01:24:14 +02:00
2020-10-22 00:50:07 +02:00
if (n <= 0_8) then
2021-03-19 00:10:35 +01:00
info = QMCKL_INVALID_ARG_5
2020-10-22 00:50:07 +02:00
return
endif
2020-10-22 01:24:14 +02:00
2020-10-28 20:15:36 +01:00
if (transa == 'N' .or. transa == 'n') then
transab = 0
else if (transa == 'T' .or. transa == 't') then
transab = 1
else
transab = -100
endif
if (transb == 'N' .or. transb == 'n') then
continue
else if (transa == 'T' .or. transa == 't') then
transab = transab + 2
else
transab = -100
endif
if (transab < 0) then
2021-03-19 00:10:35 +01:00
info = QMCKL_INVALID_ARG_1
2021-04-30 01:26:19 +02:00
return
2020-10-22 00:50:07 +02:00
endif
2020-10-22 01:24:14 +02:00
2020-10-28 20:15:36 +01:00
if (iand(transab,1) == 0 .and. LDA < 3) then
2021-03-19 00:10:35 +01:00
info = QMCKL_INVALID_ARG_7
2020-10-22 00:50:07 +02:00
return
endif
2020-10-22 01:24:14 +02:00
2020-10-28 20:15:36 +01:00
if (iand(transab,1) == 1 .and. LDA < m) then
2021-03-19 00:10:35 +01:00
info = QMCKL_INVALID_ARG_7
2020-10-22 00:50:07 +02:00
return
endif
2020-10-22 01:24:14 +02:00
2020-10-28 20:15:36 +01:00
if (iand(transab,2) == 0 .and. LDA < 3) then
2021-03-19 00:10:35 +01:00
info = QMCKL_INVALID_ARG_7
2020-10-28 20:15:36 +01:00
return
endif
if (iand(transab,2) == 2 .and. LDA < m) then
2021-03-19 00:10:35 +01:00
info = QMCKL_INVALID_ARG_7
2020-10-28 20:15:36 +01:00
return
endif
select case (transab)
2020-10-28 20:15:36 +01:00
case(0)
do j=1,n
do i=1,m
x = A(1,i) - B(1,j)
y = A(2,i) - B(2,j)
z = A(3,i) - B(3,j)
C(i,j) = x*x + y*y + z*z
end do
end do
case(1)
do j=1,n
do i=1,m
x = A(i,1) - B(1,j)
y = A(i,2) - B(2,j)
z = A(i,3) - B(3,j)
C(i,j) = x*x + y*y + z*z
end do
end do
case(2)
do j=1,n
do i=1,m
x = A(1,i) - B(j,1)
y = A(2,i) - B(j,2)
z = A(3,i) - B(j,3)
C(i,j) = x*x + y*y + z*z
end do
2020-10-22 00:50:07 +02:00
end do
2020-10-22 01:24:14 +02:00
2020-10-28 20:15:36 +01:00
case(3)
do j=1,n
do i=1,m
x = A(i,1) - B(j,1)
y = A(i,2) - B(j,2)
z = A(i,3) - B(j,3)
C(i,j) = x*x + y*y + z*z
end do
end do
end select
2020-10-25 15:02:37 +01:00
end function qmckl_distance_sq_f
2021-03-09 01:16:23 +01:00
#+end_src
2021-04-30 01:26:19 +02:00
*** Performance
2021-05-19 00:28:56 +02:00
This function is more efficient when ~A~ and ~B~ are
transposed.
2021-04-16 00:57:08 +02:00
** C interface :noexport:
2020-10-22 00:50:07 +02:00
2021-04-17 12:35:52 +02:00
#+CALL: generate_c_interface(table=qmckl_distance_sq_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
2021-04-30 01:26:19 +02:00
2021-04-17 12:35:52 +02:00
#+RESULTS:
#+begin_src f90 :tangle (eval f) :comments org :exports none
integer(c_int32_t) function qmckl_distance_sq &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc) &
bind(C) result(info)
2021-04-17 12:35:52 +02:00
use, intrinsic :: iso_c_binding
implicit none
2021-04-17 12:35:52 +02:00
integer (c_int64_t) , intent(in) , value :: context
character , intent(in) , value :: transa
character , intent(in) , value :: transb
integer (c_int64_t) , intent(in) , value :: m
integer (c_int64_t) , intent(in) , value :: n
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(out) :: C(ldc,n)
2021-04-17 12:35:52 +02:00
integer (c_int64_t) , intent(in) , value :: ldc
2021-04-17 12:35:52 +02:00
integer(c_int32_t), external :: qmckl_distance_sq_f
info = qmckl_distance_sq_f &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc)
end function qmckl_distance_sq
2021-04-17 12:35:52 +02:00
#+end_src
2021-04-17 12:35:52 +02:00
#+CALL: generate_f_interface(table=qmckl_distance_sq_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
2021-04-17 12:35:52 +02:00
#+RESULTS:
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
interface
2021-04-17 12:35:52 +02:00
integer(c_int32_t) function qmckl_distance_sq &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc) &
bind(C)
2020-10-26 19:30:50 +01:00
use, intrinsic :: iso_c_binding
2021-03-30 14:51:23 +02:00
import
2020-10-26 19:30:50 +01:00
implicit none
2021-04-17 12:35:52 +02:00
integer (c_int64_t) , intent(in) , value :: context
character , intent(in) , value :: transa
character , intent(in) , value :: transb
integer (c_int64_t) , intent(in) , value :: m
integer (c_int64_t) , intent(in) , value :: n
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(out) :: C(ldc,n)
2021-04-17 12:35:52 +02:00
integer (c_int64_t) , intent(in) , value :: ldc
2020-10-26 19:30:50 +01:00
end function qmckl_distance_sq
end interface
2021-04-17 12:35:52 +02:00
#+end_src
2020-10-26 19:30:50 +01:00
2021-03-09 01:16:23 +01:00
*** Test :noexport:
#+begin_src f90 :tangle (eval f_test)
2021-03-30 14:51:23 +02:00
integer(qmckl_exit_code) function test_qmckl_distance_sq(context) bind(C)
2020-11-05 15:27:25 +01:00
use qmckl
2020-10-26 19:30:50 +01:00
implicit none
2021-03-30 14:51:23 +02:00
integer(qmckl_context), intent(in), value :: context
2020-10-22 00:50:07 +02:00
2020-10-26 19:30:50 +01:00
double precision, allocatable :: A(:,:), B(:,:), C(:,:)
integer*8 :: m, n, LDA, LDB, LDC
double precision :: x
2021-04-30 01:26:19 +02:00
integer*8 :: i,j
2020-10-26 19:30:50 +01:00
m = 5
n = 6
2020-10-28 20:15:36 +01:00
LDA = m
LDB = n
2020-10-26 19:30:50 +01:00
LDC = 5
2020-10-28 20:15:36 +01:00
allocate( A(LDA,m), B(LDB,n), C(LDC,n) )
2020-10-26 19:30:50 +01:00
2020-10-28 20:15:36 +01:00
do j=1,m
2020-10-26 19:30:50 +01:00
do i=1,m
2020-10-30 16:22:29 +01:00
A(i,j) = -10.d0 + dble(i+j)
2020-10-26 19:30:50 +01:00
end do
2020-10-28 20:15:36 +01:00
end do
do j=1,n
2020-10-26 19:30:50 +01:00
do i=1,n
2020-10-30 16:22:29 +01:00
B(i,j) = -1.d0 + dble(i*j)
2020-10-26 19:30:50 +01:00
end do
end do
2021-03-19 00:10:35 +01:00
test_qmckl_distance_sq = &
qmckl_distance_sq(context, 'X', 't', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_distance_sq == 0) return
2020-10-28 20:15:36 +01:00
2021-03-19 00:10:35 +01:00
test_qmckl_distance_sq = &
qmckl_distance_sq(context, 't', 'X', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_distance_sq == 0) return
2020-10-28 20:15:36 +01:00
2021-03-19 00:10:35 +01:00
test_qmckl_distance_sq = &
qmckl_distance_sq(context, 'T', 't', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_distance_sq /= 0) return
2020-10-26 19:30:50 +01:00
2021-05-19 00:28:56 +02:00
test_qmckl_distance_sq = QMCKL_FAILURE
2020-10-26 19:30:50 +01:00
do j=1,n
do i=1,m
2020-10-30 16:22:29 +01:00
x = (A(i,1)-B(j,1))**2 + &
(A(i,2)-B(j,2))**2 + &
(A(i,3)-B(j,3))**2
if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return
2020-10-26 19:30:50 +01:00
end do
end do
2021-03-19 00:10:35 +01:00
test_qmckl_distance_sq = &
qmckl_distance_sq(context, 'n', 'T', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_distance_sq /= 0) return
2020-10-28 20:15:36 +01:00
2021-05-19 00:28:56 +02:00
test_qmckl_distance_sq = QMCKL_FAILURE
2020-10-28 20:15:36 +01:00
do j=1,n
do i=1,m
2020-10-30 16:22:29 +01:00
x = (A(1,i)-B(j,1))**2 + &
(A(2,i)-B(j,2))**2 + &
(A(3,i)-B(j,3))**2
if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return
2020-10-28 20:15:36 +01:00
end do
end do
2021-03-19 00:10:35 +01:00
test_qmckl_distance_sq = &
qmckl_distance_sq(context, 'T', 'n', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_distance_sq /= 0) return
2020-10-28 20:15:36 +01:00
2021-05-19 00:28:56 +02:00
test_qmckl_distance_sq = QMCKL_FAILURE
2020-10-28 20:15:36 +01:00
do j=1,n
do i=1,m
2020-10-30 16:22:29 +01:00
x = (A(i,1)-B(1,j))**2 + &
(A(i,2)-B(2,j))**2 + &
(A(i,3)-B(3,j))**2
if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return
2020-10-28 20:15:36 +01:00
end do
end do
2021-03-19 00:10:35 +01:00
test_qmckl_distance_sq = &
qmckl_distance_sq(context, 'n', 'N', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_distance_sq /= 0) return
2020-10-28 20:15:36 +01:00
2021-05-19 00:28:56 +02:00
test_qmckl_distance_sq = QMCKL_FAILURE
2020-10-28 20:15:36 +01:00
do j=1,n
do i=1,m
2020-10-30 16:22:29 +01:00
x = (A(1,i)-B(1,j))**2 + &
(A(2,i)-B(2,j))**2 + &
(A(3,i)-B(3,j))**2
if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return
2020-10-28 20:15:36 +01:00
end do
end do
2021-05-19 00:28:56 +02:00
test_qmckl_distance_sq = QMCKL_SUCCESS
2020-10-26 19:30:50 +01:00
deallocate(A,B,C)
end function test_qmckl_distance_sq
2021-03-09 01:16:23 +01:00
#+end_src
2021-04-30 01:26:19 +02:00
2021-03-09 01:16:23 +01:00
#+begin_src c :comments link :tangle (eval c_test)
2021-05-19 00:28:56 +02:00
qmckl_exit_code test_qmckl_distance_sq(qmckl_context context);
assert(test_qmckl_distance_sq(context) == QMCKL_SUCCESS);
2021-03-09 01:16:23 +01:00
#+end_src
2021-04-26 01:45:25 +02:00
* Distance
** ~qmckl_distance~
:PROPERTIES:
:Name: qmckl_distance
:CRetType: qmckl_exit_code
:FRetType: qmckl_exit_code
:END:
~qmckl_distance~ computes the matrix of the distances between all
pairs of points in two sets, one point within each set:
\[
C_{ij} = \sqrt{\sum_{k=1}^3 (A_{k,i}-B_{k,j})^2}
\]
2021-05-19 00:28:56 +02:00
If the input array is normal (~'N'~), the xyz coordinates are in
the leading dimension: ~[n][3]~ in C and ~(3,n)~ in Fortran.
2021-04-26 01:45:25 +02:00
#+NAME: qmckl_distance_args
| qmckl_context | context | in | Global state |
| char | transa | in | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed |
| char | transb | in | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed |
| int64_t | m | in | Number of points in the first set |
| int64_t | n | in | Number of points in the second set |
| double | A[][lda] | in | Array containing the $m \times 3$ matrix $A$ |
| int64_t | lda | in | Leading dimension of array ~A~ |
| double | B[][ldb] | in | Array containing the $n \times 3$ matrix $B$ |
| int64_t | ldb | in | Leading dimension of array ~B~ |
| double | C[n][ldc] | out | Array containing the $m \times n$ matrix $C$ |
| int64_t | ldc | in | Leading dimension of array ~C~ |
*** Requirements
- ~context~ is not ~QMCKL_NULL_CONTEXT~
- ~m > 0~
- ~n > 0~
- ~lda >= 3~ if ~transa == 'N'~
- ~lda >= m~ if ~transa == 'T'~
- ~ldb >= 3~ if ~transb == 'N'~
- ~ldb >= n~ if ~transb == 'T'~
2021-04-30 01:26:19 +02:00
- ~ldc >= m~
2021-04-26 01:45:25 +02:00
- ~A~ is allocated with at least $3 \times m \times 8$ bytes
- ~B~ is allocated with at least $3 \times n \times 8$ bytes
- ~C~ is allocated with at least $m \times n \times 8$ bytes
2021-04-30 01:26:19 +02:00
2021-04-26 01:45:25 +02:00
*** C header
#+CALL: generate_c_header(table=qmckl_distance_args,rettyp=get_value("CRetType"),fname=get_value("Name"))
#+RESULTS:
#+begin_src c :tangle (eval h_func) :comments org
qmckl_exit_code qmckl_distance (
const qmckl_context context,
const char transa,
const char transb,
const int64_t m,
const int64_t n,
const double* A,
const int64_t lda,
const double* B,
const int64_t ldb,
double* const C,
2021-04-30 01:26:19 +02:00
const int64_t ldc );
2021-04-26 01:45:25 +02:00
#+end_src
*** Source
#+begin_src f90 :tangle (eval f)
integer function qmckl_distance_f(context, transa, transb, m, n, &
A, LDA, B, LDB, C, LDC) &
result(info)
use qmckl
implicit none
integer(qmckl_context) , intent(in) :: context
character , intent(in) :: transa, transb
integer*8 , intent(in) :: m, n
integer*8 , intent(in) :: lda
real*8 , intent(in) :: A(lda,*)
integer*8 , intent(in) :: ldb
real*8 , intent(in) :: B(ldb,*)
integer*8 , intent(in) :: ldc
real*8 , intent(out) :: C(ldc,*)
integer*8 :: i,j
real*8 :: x, y, z
integer :: transab
info = QMCKL_SUCCESS
if (context == QMCKL_NULL_CONTEXT) then
info = QMCKL_INVALID_CONTEXT
return
endif
if (m <= 0_8) then
info = QMCKL_INVALID_ARG_4
return
endif
if (n <= 0_8) then
info = QMCKL_INVALID_ARG_5
return
endif
if (transa == 'N' .or. transa == 'n') then
transab = 0
else if (transa == 'T' .or. transa == 't') then
transab = 1
else
transab = -100
endif
if (transb == 'N' .or. transb == 'n') then
continue
else if (transa == 'T' .or. transa == 't') then
transab = transab + 2
else
transab = -100
endif
if (transab < 0) then
info = QMCKL_INVALID_ARG_1
2021-04-30 01:26:19 +02:00
return
2021-04-26 01:45:25 +02:00
endif
! check for LDA
2021-04-26 01:45:25 +02:00
if (iand(transab,1) == 0 .and. LDA < 3) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,1) == 1 .and. LDA < m) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,2) == 0 .and. LDA < 3) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,2) == 2 .and. LDA < m) then
info = QMCKL_INVALID_ARG_7
return
endif
! check for LDB
if (iand(transab,1) == 0 .and. LDB < 3) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,1) == 1 .and. LDB < n) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,2) == 0 .and. LDB < 3) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,2) == 2 .and. LDB < n) then
info = QMCKL_INVALID_ARG_9
return
endif
! check for LDC
if (LDC < m) then
info = QMCKL_INVALID_ARG_11
return
endif
2021-04-26 01:45:25 +02:00
select case (transab)
case(0)
do j=1,n
do i=1,m
x = A(1,i) - B(1,j)
y = A(2,i) - B(2,j)
z = A(3,i) - B(3,j)
C(i,j) = x*x + y*y + z*z
end do
C(:,j) = dsqrt(C(:,j))
end do
case(1)
do j=1,n
do i=1,m
x = A(i,1) - B(1,j)
y = A(i,2) - B(2,j)
z = A(i,3) - B(3,j)
C(i,j) = x*x + y*y + z*z
end do
C(:,j) = dsqrt(C(:,j))
end do
case(2)
do j=1,n
do i=1,m
x = A(1,i) - B(j,1)
y = A(2,i) - B(j,2)
z = A(3,i) - B(j,3)
C(i,j) = x*x + y*y + z*z
end do
C(:,j) = dsqrt(C(:,j))
end do
case(3)
do j=1,n
do i=1,m
x = A(i,1) - B(j,1)
y = A(i,2) - B(j,2)
z = A(i,3) - B(j,3)
C(i,j) = x*x + y*y + z*z
end do
C(:,j) = dsqrt(C(:,j))
end do
end select
end function qmckl_distance_f
#+end_src
2021-04-30 01:26:19 +02:00
*** Performance
2021-04-26 01:45:25 +02:00
2021-05-19 00:28:56 +02:00
This function is more efficient when ~A~ and ~B~ are transposed.
2021-04-26 01:45:25 +02:00
** C interface :noexport:
#+CALL: generate_c_interface(table=qmckl_distance_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
2021-04-30 01:26:19 +02:00
2021-04-26 01:45:25 +02:00
#+RESULTS:
#+begin_src f90 :tangle (eval f) :comments org :exports none
integer(c_int32_t) function qmckl_distance &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc) &
bind(C) result(info)
use, intrinsic :: iso_c_binding
implicit none
integer (c_int64_t) , intent(in) , value :: context
character , intent(in) , value :: transa
character , intent(in) , value :: transb
integer (c_int64_t) , intent(in) , value :: m
integer (c_int64_t) , intent(in) , value :: n
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(out) :: C(ldc,n)
integer (c_int64_t) , intent(in) , value :: ldc
integer(c_int32_t), external :: qmckl_distance_f
info = qmckl_distance_f &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc)
end function qmckl_distance
#+end_src
#+CALL: generate_f_interface(table=qmckl_distance_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
#+RESULTS:
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
interface
integer(c_int32_t) function qmckl_distance &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc) &
bind(C)
use, intrinsic :: iso_c_binding
import
implicit none
integer (c_int64_t) , intent(in) , value :: context
character , intent(in) , value :: transa
character , intent(in) , value :: transb
integer (c_int64_t) , intent(in) , value :: m
integer (c_int64_t) , intent(in) , value :: n
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(out) :: C(ldc,n)
integer (c_int64_t) , intent(in) , value :: ldc
end function qmckl_distance
end interface
#+end_src
*** Test :noexport:
#+begin_src f90 :tangle (eval f_test)
integer(qmckl_exit_code) function test_qmckl_dist(context) bind(C)
use qmckl
implicit none
integer(qmckl_context), intent(in), value :: context
double precision, allocatable :: A(:,:), B(:,:), C(:,:)
integer*8 :: m, n, LDA, LDB, LDC
double precision :: x
2021-04-30 01:26:19 +02:00
integer*8 :: i,j
2021-04-26 01:45:25 +02:00
m = 5
n = 6
LDA = m
LDB = n
LDC = 5
allocate( A(LDA,m), B(LDB,n), C(LDC,n) )
do j=1,m
do i=1,m
A(i,j) = -10.d0 + dble(i+j)
end do
end do
do j=1,n
do i=1,n
B(i,j) = -1.d0 + dble(i*j)
end do
end do
test_qmckl_dist = &
qmckl_distance(context, 'X', 't', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_dist == 0) return
2021-04-26 01:45:25 +02:00
test_qmckl_dist = &
qmckl_distance(context, 't', 'X', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_dist == 0) return
2021-04-26 01:45:25 +02:00
test_qmckl_dist = &
qmckl_distance(context, 'T', 't', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_dist /= 0) return
2021-04-26 01:45:25 +02:00
2021-05-19 00:28:56 +02:00
test_qmckl_dist = QMCKL_FAILURE
2021-04-26 01:45:25 +02:00
do j=1,n
do i=1,m
x = dsqrt((A(i,1)-B(j,1))**2 + &
(A(i,2)-B(j,2))**2 + &
(A(i,3)-B(j,3))**2)
if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return
end do
end do
test_qmckl_dist = &
qmckl_distance(context, 'n', 'T', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_dist /= 0) return
2021-04-26 01:45:25 +02:00
2021-05-19 00:28:56 +02:00
test_qmckl_dist = QMCKL_FAILURE
2021-04-26 01:45:25 +02:00
do j=1,n
do i=1,m
x = dsqrt((A(1,i)-B(j,1))**2 + &
(A(2,i)-B(j,2))**2 + &
(A(3,i)-B(j,3))**2)
if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return
end do
end do
test_qmckl_dist = &
qmckl_distance(context, 'T', 'n', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_dist /= 0) return
2021-04-26 01:45:25 +02:00
2021-05-19 00:28:56 +02:00
test_qmckl_dist = QMCKL_FAILURE
2021-04-26 01:45:25 +02:00
do j=1,n
do i=1,m
x = dsqrt((A(i,1)-B(1,j))**2 + &
(A(i,2)-B(2,j))**2 + &
(A(i,3)-B(3,j))**2)
if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return
end do
end do
test_qmckl_dist = &
qmckl_distance(context, 'n', 'N', m, n, A, LDA, B, LDB, C, LDC)
2021-04-30 01:26:19 +02:00
if (test_qmckl_dist /= 0) return
2021-04-26 01:45:25 +02:00
2021-05-19 00:28:56 +02:00
test_qmckl_dist = QMCKL_FAILURE
2021-04-26 01:45:25 +02:00
do j=1,n
do i=1,m
x = dsqrt((A(1,i)-B(1,j))**2 + &
(A(2,i)-B(2,j))**2 + &
(A(3,i)-B(3,j))**2)
if ( dabs(1.d0 - C(i,j)/x) > 1.d-14 ) return
end do
end do
2021-05-19 00:28:56 +02:00
test_qmckl_dist = QMCKL_SUCCESS
2021-04-26 01:45:25 +02:00
deallocate(A,B,C)
end function test_qmckl_dist
#+end_src
2021-04-30 01:26:19 +02:00
2021-04-26 01:45:25 +02:00
#+begin_src c :comments link :tangle (eval c_test)
2021-05-19 00:28:56 +02:00
qmckl_exit_code test_qmckl_dist(qmckl_context context);
assert(test_qmckl_dist(context) == QMCKL_SUCCESS);
2021-04-26 01:45:25 +02:00
#+end_src
2021-05-25 14:18:25 +02:00
* Rescaled Distance
** ~qmckl_distance_rescaled~
:PROPERTIES:
:Name: qmckl_distance_rescaled
:CRetType: qmckl_exit_code
:FRetType: qmckl_exit_code
:END:
~qmckl_distance_rescaled~ computes the matrix of the rescaled distances between all
pairs of points in two sets, one point within each set:
\[
C_{ij} = \left( 1 - \exp{-\kappa C_{ij}}\right)/\kappa
2021-05-25 14:18:25 +02:00
\]
If the input array is normal (~'N'~), the xyz coordinates are in
the leading dimension: ~[n][3]~ in C and ~(3,n)~ in Fortran.
#+NAME: qmckl_distance_rescaled_args
| qmckl_context | context | in | Global state |
| char | transa | in | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed |
| char | transb | in | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed |
| int64_t | m | in | Number of points in the first set |
| int64_t | n | in | Number of points in the second set |
| double | A[][lda] | in | Array containing the $m \times 3$ matrix $A$ |
| int64_t | lda | in | Leading dimension of array ~A~ |
| double | B[][ldb] | in | Array containing the $n \times 3$ matrix $B$ |
| int64_t | ldb | in | Leading dimension of array ~B~ |
| double | C[n][ldc] | out | Array containing the $m \times n$ matrix $C$ |
| int64_t | ldc | in | Leading dimension of array ~C~ |
| double | rescale_factor_kappa | in | Factor for calculating rescaled distances |
2021-05-25 14:18:25 +02:00
*** Requirements
- ~context~ is not ~QMCKL_NULL_CONTEXT~
- ~m > 0~
- ~n > 0~
- ~lda >= 3~ if ~transa == 'N'~
- ~lda >= m~ if ~transa == 'T'~
- ~ldb >= 3~ if ~transb == 'N'~
- ~ldb >= n~ if ~transb == 'T'~
- ~ldc >= m~
- ~A~ is allocated with at least $3 \times m \times 8$ bytes
- ~B~ is allocated with at least $3 \times n \times 8$ bytes
- ~C~ is allocated with at least $m \times n \times 8$ bytes
*** C header
#+CALL: generate_c_header(table=qmckl_distance_rescaled_args,rettyp=get_value("CRetType"),fname=get_value("Name"))
#+RESULTS:
#+begin_src c :tangle (eval h_func) :comments org
qmckl_exit_code qmckl_distance_rescaled (
const qmckl_context context,
const char transa,
const char transb,
const int64_t m,
const int64_t n,
const double* A,
const int64_t lda,
const double* B,
const int64_t ldb,
double* const C,
const int64_t ldc,
const double rescale_factor_kappa);
2021-05-25 14:18:25 +02:00
#+end_src
*** Source
#+begin_src f90 :tangle (eval f)
integer function qmckl_distance_rescaled_f(context, transa, transb, m, n, &
A, LDA, B, LDB, C, LDC, rescale_factor_kappa) &
2021-05-25 14:18:25 +02:00
result(info)
use qmckl
implicit none
integer(qmckl_context) , intent(in) :: context
character , intent(in) :: transa, transb
integer*8 , intent(in) :: m, n
integer*8 , intent(in) :: lda
real*8 , intent(in) :: A(lda,*)
integer*8 , intent(in) :: ldb
real*8 , intent(in) :: B(ldb,*)
integer*8 , intent(in) :: ldc
real*8 , intent(out) :: C(ldc,*)
real*8 , intent(in) :: rescale_factor_kappa
2021-05-25 14:18:25 +02:00
integer*8 :: i,j
real*8 :: x, y, z, dist, rescale_factor_kappa_inv
2021-05-25 14:18:25 +02:00
integer :: transab
rescale_factor_kappa_inv = 1.0d0/rescale_factor_kappa;
2021-05-26 09:49:31 +02:00
2021-05-25 14:18:25 +02:00
info = QMCKL_SUCCESS
if (context == QMCKL_NULL_CONTEXT) then
info = QMCKL_INVALID_CONTEXT
return
endif
if (m <= 0_8) then
info = QMCKL_INVALID_ARG_4
return
endif
if (n <= 0_8) then
info = QMCKL_INVALID_ARG_5
return
endif
if (transa == 'N' .or. transa == 'n') then
transab = 0
else if (transa == 'T' .or. transa == 't') then
transab = 1
else
transab = -100
endif
if (transb == 'N' .or. transb == 'n') then
continue
else if (transa == 'T' .or. transa == 't') then
transab = transab + 2
else
transab = -100
endif
! check for LDA
2021-05-25 14:18:25 +02:00
if (transab < 0) then
info = QMCKL_INVALID_ARG_1
return
endif
if (iand(transab,1) == 0 .and. LDA < 3) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,1) == 1 .and. LDA < m) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,2) == 0 .and. LDA < 3) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,2) == 2 .and. LDA < m) then
info = QMCKL_INVALID_ARG_7
return
endif
! check for LDB
if (iand(transab,1) == 0 .and. LDB < 3) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,1) == 1 .and. LDB < n) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,2) == 0 .and. LDB < 3) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,2) == 2 .and. LDB < n) then
info = QMCKL_INVALID_ARG_9
return
endif
! check for LDC
if (LDC < m) then
info = QMCKL_INVALID_ARG_11
return
endif
2021-05-25 14:18:25 +02:00
select case (transab)
case(0)
do j=1,n
do i=1,m
x = A(1,i) - B(1,j)
y = A(2,i) - B(2,j)
z = A(3,i) - B(3,j)
2021-05-26 09:49:31 +02:00
dist = dsqrt(x*x + y*y + z*z)
C(i,j) = (1.0d0 - dexp(-rescale_factor_kappa * dist)) * rescale_factor_kappa_inv
2021-05-25 14:18:25 +02:00
end do
end do
case(1)
do j=1,n
do i=1,m
x = A(i,1) - B(1,j)
y = A(i,2) - B(2,j)
z = A(i,3) - B(3,j)
2021-05-26 09:49:31 +02:00
dist = dsqrt(x*x + y*y + z*z)
C(i,j) = (1.0d0 - dexp(-rescale_factor_kappa * dist)) * rescale_factor_kappa_inv
2021-05-25 14:18:25 +02:00
end do
end do
case(2)
do j=1,n
do i=1,m
x = A(1,i) - B(j,1)
y = A(2,i) - B(j,2)
z = A(3,i) - B(j,3)
2021-05-26 09:49:31 +02:00
dist = dsqrt(x*x + y*y + z*z)
C(i,j) = (1.0d0 - dexp(-rescale_factor_kappa * dist)) * rescale_factor_kappa_inv
2021-05-25 14:18:25 +02:00
end do
end do
case(3)
do j=1,n
do i=1,m
x = A(i,1) - B(j,1)
y = A(i,2) - B(j,2)
z = A(i,3) - B(j,3)
2021-05-26 09:49:31 +02:00
dist = dsqrt(x*x + y*y + z*z)
C(i,j) = (1.0d0 - dexp(-rescale_factor_kappa * dist)) * rescale_factor_kappa_inv
2021-05-25 14:18:25 +02:00
end do
end do
end select
end function qmckl_distance_rescaled_f
#+end_src
*** Performance
This function is more efficient when ~A~ and ~B~ are transposed.
** C interface :noexport:
#+CALL: generate_c_interface(table=qmckl_distance_rescaled_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
#+RESULTS:
#+begin_src f90 :tangle (eval f) :comments org :exports none
integer(c_int32_t) function qmckl_distance_rescaled &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa) &
2021-05-25 14:18:25 +02:00
bind(C) result(info)
use, intrinsic :: iso_c_binding
implicit none
integer (c_int64_t) , intent(in) , value :: context
character , intent(in) , value :: transa
character , intent(in) , value :: transb
integer (c_int64_t) , intent(in) , value :: m
integer (c_int64_t) , intent(in) , value :: n
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(out) :: C(ldc,n)
integer (c_int64_t) , intent(in) , value :: ldc
real (c_double ) , intent(in) , value :: rescale_factor_kappa
2021-05-25 14:18:25 +02:00
integer(c_int32_t), external :: qmckl_distance_rescaled_f
info = qmckl_distance_rescaled_f &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa)
2021-05-25 14:18:25 +02:00
end function qmckl_distance_rescaled
#+end_src
#+CALL: generate_f_interface(table=qmckl_distance_rescaled_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
#+RESULTS:
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
interface
integer(c_int32_t) function qmckl_distance_rescaled &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa) &
2021-05-25 14:18:25 +02:00
bind(C)
use, intrinsic :: iso_c_binding
import
implicit none
integer (c_int64_t) , intent(in) , value :: context
character , intent(in) , value :: transa
character , intent(in) , value :: transb
integer (c_int64_t) , intent(in) , value :: m
integer (c_int64_t) , intent(in) , value :: n
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(out) :: C(ldc,n)
integer (c_int64_t) , intent(in) , value :: ldc
real (c_double ) , intent(in) , value :: rescale_factor_kappa
2021-05-25 14:18:25 +02:00
end function qmckl_distance_rescaled
end interface
#+end_src
*** Test :noexport:
* Rescaled Distance Derivatives
** ~qmckl_distance_rescaled_deriv_e~
:PROPERTIES:
:Name: qmckl_distance_rescaled_deriv_e
:CRetType: qmckl_exit_code
:FRetType: qmckl_exit_code
:END:
~qmckl_distance_rescaled_deriv_e~ computes the matrix of the gradient and laplacian of the
rescaled distance with respect to the electron coordinates. The derivative is a rank 3 tensor.
The first dimension has a dimension of 4 of which the first three coordinates
contains the gradient vector and the last index is the laplacian.
\[
C_{ij} = \left( 1 - \exp{-\kappa C_{ij}}\right)/\kappa
\]
Here the gradient is defined as follows:
\[
\nabla (C_{ij}(\mathbf{r}_{ee})) = \left(\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta x},\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta y},\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta z} \right)
\]
and the laplacian is defined as follows:
\[
\triangle (C_{ij}(r_{ee})) = \frac{\delta^2}{\delta x^2} + \frac{\delta^2}{\delta y^2} + \frac{\delta^2}{\delta z^2}
\]
Using the above three formulae, the expression for the gradient and laplacian is
as follows:
\[
\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta x} = \frac{|(x_i - x_j)|}{r_{ij}} (1 - \kappa R_{ij})
\]
\[
\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta y} = \frac{|(y_i - y_j)|}{r_{ij}} (1 - \kappa R_{ij})
\]
\[
\frac{\delta C_{ij}(\mathbf{r}_{ee})}{\delta z} = \frac{|(z_i - z_j)|}{r_{ij}} (1 - \kappa R_{ij})
\]
\[
\Delta(C_{ij}(r_{ee}) = \left[ \frac{2}{r_{ij}} - \kappa \right] (1-\kappa R_{ij})
\]
If the input array is normal (~'N'~), the xyz coordinates are in
the leading dimension: ~[n][3]~ in C and ~(3,n)~ in Fortran.
#+NAME: qmckl_distance_rescaled_deriv_e_args
| qmckl_context | context | in | Global state |
| char | transa | in | Array ~A~ is ~'N'~: Normal, ~'T'~: Transposed |
| char | transb | in | Array ~B~ is ~'N'~: Normal, ~'T'~: Transposed |
| int64_t | m | in | Number of points in the first set |
| int64_t | n | in | Number of points in the second set |
| double | A[][lda] | in | Array containing the $m \times 3$ matrix $A$ |
| int64_t | lda | in | Leading dimension of array ~A~ |
| double | B[][ldb] | in | Array containing the $n \times 3$ matrix $B$ |
| int64_t | ldb | in | Leading dimension of array ~B~ |
| double | C[4][n][ldc] | out | Array containing the $4 \times m \times n$ matrix $C$ |
| int64_t | ldc | in | Leading dimension of array ~C~ |
| double | rescale_factor_kappa | in | Factor for calculating rescaled distances derivatives |
*** Requirements
- ~context~ is not ~QMCKL_NULL_CONTEXT~
- ~m > 0~
- ~n > 0~
- ~lda >= 3~ if ~transa == 'N'~
- ~lda >= m~ if ~transa == 'T'~
- ~ldb >= 3~ if ~transb == 'N'~
- ~ldb >= n~ if ~transb == 'T'~
- ~ldc >= m~
- ~A~ is allocated with at least $3 \times m \times 8$ bytes
- ~B~ is allocated with at least $3 \times n \times 8$ bytes
- ~C~ is allocated with at least $4 \times m \times n \times 8$ bytes
*** C header
#+CALL: generate_c_header(table=qmckl_distance_rescaled_deriv_e_args,rettyp=get_value("CRetType"),fname=get_value("Name"))
#+RESULTS:
#+begin_src c :tangle (eval h_func) :comments org
qmckl_exit_code qmckl_distance_rescaled_deriv_e (
const qmckl_context context,
const char transa,
const char transb,
const int64_t m,
const int64_t n,
const double* A,
const int64_t lda,
const double* B,
const int64_t ldb,
double* const C,
const int64_t ldc,
const double rescale_factor_kappa);
#+end_src
*** Source
#+begin_src f90 :tangle (eval f)
integer function qmckl_distance_rescaled_deriv_e_f(context, transa, transb, m, n, &
A, LDA, B, LDB, C, LDC, rescale_factor_kappa) &
result(info)
use qmckl
implicit none
integer(qmckl_context) , intent(in) :: context
character , intent(in) :: transa, transb
integer*8 , intent(in) :: m, n
integer*8 , intent(in) :: lda
real*8 , intent(in) :: A(lda,*)
integer*8 , intent(in) :: ldb
real*8 , intent(in) :: B(ldb,*)
integer*8 , intent(in) :: ldc
real*8 , intent(out) :: C(4,ldc,*)
real*8 , intent(in) :: rescale_factor_kappa
integer*8 :: i,j
real*8 :: x, y, z, dist, dist_inv
real*8 :: rescale_factor_kappa_inv, rij
integer :: transab
rescale_factor_kappa_inv = 1.0d0/rescale_factor_kappa;
info = QMCKL_SUCCESS
if (context == QMCKL_NULL_CONTEXT) then
info = QMCKL_INVALID_CONTEXT
return
endif
if (m <= 0_8) then
info = QMCKL_INVALID_ARG_4
return
endif
if (n <= 0_8) then
info = QMCKL_INVALID_ARG_5
return
endif
if (transa == 'N' .or. transa == 'n') then
transab = 0
else if (transa == 'T' .or. transa == 't') then
transab = 1
else
transab = -100
endif
if (transb == 'N' .or. transb == 'n') then
continue
else if (transa == 'T' .or. transa == 't') then
transab = transab + 2
else
transab = -100
endif
! check for LDA
if (transab < 0) then
info = QMCKL_INVALID_ARG_1
return
endif
if (iand(transab,1) == 0 .and. LDA < 3) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,1) == 1 .and. LDA < m) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,2) == 0 .and. LDA < 3) then
info = QMCKL_INVALID_ARG_7
return
endif
if (iand(transab,2) == 2 .and. LDA < m) then
info = QMCKL_INVALID_ARG_7
return
endif
! check for LDB
if (iand(transab,1) == 0 .and. LDB < 3) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,1) == 1 .and. LDB < n) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,2) == 0 .and. LDB < 3) then
info = QMCKL_INVALID_ARG_9
return
endif
if (iand(transab,2) == 2 .and. LDB < n) then
info = QMCKL_INVALID_ARG_9
return
endif
! check for LDC
if (LDC < m) then
info = QMCKL_INVALID_ARG_11
return
endif
select case (transab)
case(0)
do j=1,n
do i=1,m
x = A(1,i) - B(1,j)
y = A(2,i) - B(2,j)
z = A(3,i) - B(3,j)
dist = dsqrt(x*x + y*y + z*z)
dist_inv = 1.0d0/dist
rij = (1.0d0 - dexp(-rescale_factor_kappa * dist)) * rescale_factor_kappa_inv
C(1,i,j) = x * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(2,i,j) = y * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(3,i,j) = z * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(4,i,j) = (2.0d0 * dist_inv - rescale_factor_kappa_inv) * ( 1.0d0 - rescale_factor_kappa_inv * rij)
end do
end do
case(1)
do j=1,n
do i=1,m
x = A(i,1) - B(1,j)
y = A(i,2) - B(2,j)
z = A(i,3) - B(3,j)
dist = dsqrt(x*x + y*y + z*z)
dist_inv = 1.0d0/dist
rij = (1.0d0 - dexp(-rescale_factor_kappa * dist)) * rescale_factor_kappa_inv
C(1,i,j) = x * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(2,i,j) = y * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(3,i,j) = z * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(4,i,j) = (2.0d0 * dist_inv - rescale_factor_kappa_inv) * ( 1.0d0 - rescale_factor_kappa_inv * rij)
end do
end do
case(2)
do j=1,n
do i=1,m
x = A(1,i) - B(j,1)
y = A(2,i) - B(j,2)
z = A(3,i) - B(j,3)
dist = dsqrt(x*x + y*y + z*z)
dist_inv = 1.0d0/dist
rij = (1.0d0 - dexp(-rescale_factor_kappa * dist)) * rescale_factor_kappa_inv
C(1,i,j) = x * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(2,i,j) = y * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(3,i,j) = z * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(4,i,j) = (2.0d0 * dist_inv - rescale_factor_kappa_inv) * ( 1.0d0 - rescale_factor_kappa_inv * rij)
end do
end do
case(3)
do j=1,n
do i=1,m
x = A(i,1) - B(j,1)
y = A(i,2) - B(j,2)
z = A(i,3) - B(j,3)
dist = dsqrt(x*x + y*y + z*z)
dist_inv = 1.0d0/dist
rij = (1.0d0 - dexp(-rescale_factor_kappa * dist)) * rescale_factor_kappa_inv
C(1,i,j) = x * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(2,i,j) = y * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(3,i,j) = z * dist_inv * ( 1.0d0 - rescale_factor_kappa_inv * rij)
C(4,i,j) = (2.0d0 * dist_inv - rescale_factor_kappa_inv) * ( 1.0d0 - rescale_factor_kappa_inv * rij)
end do
end do
end select
end function qmckl_distance_rescaled_deriv_e_f
#+end_src
*** Performance
This function is more efficient when ~A~ and ~B~ are transposed.
** C interface :noexport:
#+CALL: generate_c_interface(table=qmckl_distance_rescaled_deriv_e_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
#+RESULTS:
#+begin_src f90 :tangle (eval f) :comments org :exports none
integer(c_int32_t) function qmckl_distance_rescaled_deriv_e &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa) &
bind(C) result(info)
use, intrinsic :: iso_c_binding
implicit none
integer (c_int64_t) , intent(in) , value :: context
character , intent(in) , value :: transa
character , intent(in) , value :: transb
integer (c_int64_t) , intent(in) , value :: m
integer (c_int64_t) , intent(in) , value :: n
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(out) :: C(4,ldc,n)
integer (c_int64_t) , intent(in) , value :: ldc
real (c_double ) , intent(in) , value :: rescale_factor_kappa
integer(c_int32_t), external :: qmckl_distance_rescaled_deriv_e_f
info = qmckl_distance_rescaled_deriv_e_f &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa)
end function qmckl_distance_rescaled_deriv_e
#+end_src
#+CALL: generate_f_interface(table=qmckl_distance_rescaled_deriv_e_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
#+RESULTS:
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
interface
integer(c_int32_t) function qmckl_distance_rescaled_deriv_e &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa) &
bind(C)
use, intrinsic :: iso_c_binding
import
implicit none
integer (c_int64_t) , intent(in) , value :: context
character , intent(in) , value :: transa
character , intent(in) , value :: transb
integer (c_int64_t) , intent(in) , value :: m
integer (c_int64_t) , intent(in) , value :: n
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(out) :: C(4,ldc,n)
integer (c_int64_t) , intent(in) , value :: ldc
real (c_double ) , intent(in) , value :: rescale_factor_kappa
end function qmckl_distance_rescaled_deriv_e
end interface
#+end_src
2021-03-09 01:16:23 +01:00
* End of files :noexport:
2020-10-22 00:50:07 +02:00
2021-03-09 01:16:23 +01:00
#+begin_src c :comments link :tangle (eval c_test)
2021-05-11 16:41:03 +02:00
assert (qmckl_context_destroy(context) == QMCKL_SUCCESS);
return 0;
2020-10-22 01:24:14 +02:00
}
2020-10-22 00:50:07 +02:00
2021-03-09 01:16:23 +01:00
#+end_src
2021-04-30 01:26:19 +02:00
2020-11-05 15:27:25 +01:00
2021-03-09 01:16:23 +01:00
# -*- mode: org -*-
# vim: syntax=c