TREX/qmckl
1
0
Fork 0
mirror of https://github.com/TREX-CoE/qmckl.git synced 2025-04-28 19:34:46 +02:00
Code Issues Projects Releases Wiki Activity

Cleaning Fortran

Browse Source
This commit is contained in:
Anthony Scemama 2023-09-22 16:41:43 +02:00
parent 50fa3aa754
commit 0d9af3c497
3 changed files with 281 additions and 677 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

690
org/qmckl_ao.org
View File

File diff suppressed because it is too large Load Diff

252
org/qmckl_distance.org
View File

@ -86,7 +86,7 @@ int main() {
const double* B,
const int64_t ldb,
double* const C,
const int64_t ldc );
const int64_t ldc );
#+end_src
#+begin_src f90 :tangle (eval f)
@ -231,21 +231,21 @@ end function qmckl_distance_sq
This function is more efficient when ~A~ and ~B~ are
transposed.
#+CALL: generate_f_interface(table=qmckl_distance_sq_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
#+CALL: generate_f_interface(table=qmckl_distance_sq_args,fname=get_value("Name"))
#+RESULTS:
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
interface
integer(c_int32_t) function qmckl_distance_sq &
integer(qmckl_exit_code) function qmckl_distance_sq &
(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(c_char) , intent(in) , value :: transa
character(c_char) , intent(in) , value :: transb
integer (qmckl_context), intent(in) , value :: context
character(c_char ) , intent(in) , value :: transa
character(c_char ) , 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,*)
@ -462,25 +462,29 @@ end function test_qmckl_distance_sq
const double* B,
const int64_t ldb,
double* const C,
const int64_t ldc );
const int64_t ldc );
#+end_src
*** Source
#+begin_src f90 :tangle (eval f)
integer function qmckl_distance_f(context, transa, transb, m, n, &
function qmckl_distance(context, transa, transb, m, n, &
A, LDA, B, LDB, C, LDC) &
result(info)
use qmckl
bind(C) result(info)
use, intrinsic :: iso_c_binding
use qmckl_constants
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(qmckl_context), intent(in), value :: context
character(c_char) , intent(in) , value :: transa
character(c_char) , 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 (qmckl_exit_code) :: info
integer*8 :: i,j
real*8 :: x, y, z
@ -605,60 +609,24 @@ integer function qmckl_distance_f(context, transa, transb, m, n, &
end select
end function qmckl_distance_f
end function qmckl_distance
#+end_src
*** Performance
This function is more efficient when ~A~ and ~B~ are transposed.
** C interface :noexport:
#+CALL: generate_c_interface(table=qmckl_distance_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 &
(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(c_char) , intent(in) , value :: transa
character(c_char) , 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"))
#+CALL: generate_f_interface(table=qmckl_distance_args,fname="qmckl_distance")
#+RESULTS:
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
interface
integer(c_int32_t) function qmckl_distance &
integer(qmckl_exit_code) 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(c_char) , intent(in) , value :: transa
character(c_char) , intent(in) , value :: transb
integer (qmckl_context), intent(in) , value :: context
character(c_char ) , intent(in) , value :: transa
character(c_char ) , 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,*)
@ -672,6 +640,10 @@ end function qmckl_distance_f
end interface
#+end_src
*** Performance
This function is more efficient when ~A~ and ~B~ are transposed.
*** Test :noexport:
#+begin_src f90 :tangle (eval f_test)
@ -886,26 +858,30 @@ end function test_qmckl_dist
const int64_t ldb,
double* const C,
const int64_t ldc,
const double rescale_factor_kappa );
const double rescale_factor_kappa );
#+end_src
*** Source
#+begin_src f90 :tangle (eval f)
integer function qmckl_distance_rescaled_f(context, transa, transb, m, n, &
function qmckl_distance_rescaled(context, transa, transb, m, n, &
A, LDA, B, LDB, C, LDC, rescale_factor_kappa) &
result(info)
use qmckl
bind(C) result(info)
use, intrinsic :: iso_c_binding
use qmckl_constants
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
integer (qmckl_context), intent(in) , value :: context
character(c_char ) , intent(in) , value :: transa
character(c_char ) , 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
integer(qmckl_exit_code) :: info
integer*8 :: i,j
real*8 :: x, y, z, dist, rescale_factor_kappa_inv
@ -1032,7 +1008,7 @@ integer function qmckl_distance_rescaled_f(context, transa, transb, m, n, &
end select
end function qmckl_distance_rescaled_f
end function qmckl_distance_rescaled
#+end_src
*** Performance
@ -1041,52 +1017,21 @@ end function qmckl_distance_rescaled_f
** 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) &
bind(C) result(info)
use, intrinsic :: iso_c_binding
implicit none
integer (c_int64_t) , intent(in) , value :: context
character(c_char) , intent(in) , value :: transa
character(c_char) , 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
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)
end function qmckl_distance_rescaled
#+end_src
#+CALL: generate_f_interface(table=qmckl_distance_rescaled_args,rettyp=get_value("FRetType"),fname=get_value("Name"))
#+CALL: generate_f_interface(table=qmckl_distance_rescaled_args,fname="qmckl_distance_rescaled")
#+RESULTS:
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
interface
integer(c_int32_t) function qmckl_distance_rescaled &
integer(qmckl_exit_code) function qmckl_distance_rescaled &
(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(c_char) , intent(in) , value :: transa
character(c_char) , intent(in) , value :: transb
integer (qmckl_context), intent(in) , value :: context
character(c_char ) , intent(in) , value :: transa
character(c_char ) , 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,*)
@ -1345,7 +1290,7 @@ end function test_qmckl_dist_rescaled
| ~lda~ | ~int64_t~ | in | Leading dimension of array ~A~ |
| ~B~ | ~double[][ldb]~ | in | Array containing the $n \times 3$ matrix $B$ |
| ~ldb~ | ~int64_t~ | in | Leading dimension of array ~B~ |
| ~C~ | ~double[4][n][ldc]~ | out | Array containing the $4 \times m \times n$ matrix $C$ |
| ~C~ | ~double[n][ldc][4]~ | out | Array containing the $4 \times m \times n$ matrix $C$ |
| ~ldc~ | ~int64_t~ | in | Leading dimension of array ~C~ |
| ~rescale_factor_kappa~ | ~double~ | in | Factor for calculating rescaled distances derivatives |
@ -1383,21 +1328,26 @@ end function test_qmckl_dist_rescaled
#+end_src
#+begin_src f90 :tangle (eval f)
integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
function qmckl_distance_rescaled_gl(context, transa, transb, m, n, &
A, LDA, B, LDB, C, LDC, rescale_factor_kappa) &
result(info)
use qmckl
bind(C) result(info)
use qmckl_constants
use, intrinsic :: iso_c_binding
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(qmckl_exit_code) :: info
integer (qmckl_context), intent(in) , value :: context
character(c_char ) , intent(in) , value :: transa
character(c_char ) , 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*8 :: i,j
real*8 :: x, y, z, dist, dist_inv
@ -1483,7 +1433,7 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
dist = dsqrt(x*x + y*y + z*z)
! Avoid floating-point exception
if (dist == 0.d0) then
dist = 69.d0/rescale_factor_kappa
dist = 69.d0/rescale_factor_kappa
endif
dist_inv = 1.0d0/dist
rij = dexp(-rescale_factor_kappa * dist)
@ -1504,7 +1454,7 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
dist = dsqrt(x*x + y*y + z*z)
! Avoid floating-point exception
if (dist == 0.d0) then
dist = 69.d0/rescale_factor_kappa
dist = 69.d0/rescale_factor_kappa
endif
dist_inv = 1.0d0/dist
rij = dexp(-rescale_factor_kappa * dist)
@ -1525,7 +1475,7 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
dist = dsqrt(x*x + y*y + z*z)
! Avoid floating-point exception
if (dist == 0.d0) then
dist = 69.d0/rescale_factor_kappa
dist = 69.d0/rescale_factor_kappa
endif
dist_inv = 1.0d0/dist
rij = dexp(-rescale_factor_kappa * dist)
@ -1546,7 +1496,7 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
dist = dsqrt(x*x + y*y + z*z)
! Avoid floating-point exception
if (dist == 0.d0) then
dist = 69.d0/rescale_factor_kappa
dist = 69.d0/rescale_factor_kappa
endif
dist_inv = 1.0d0/dist
rij = dexp(-rescale_factor_kappa * dist)
@ -1559,64 +1509,34 @@ integer function qmckl_distance_rescaled_gl_f(context, transa, transb, m, n, &
end select
end function qmckl_distance_rescaled_gl_f
end function qmckl_distance_rescaled_gl
#+end_src
This function is more efficient when ~A~ and ~B~ are transposed.
#+CALL: generate_c_interface(table=qmckl_distance_rescaled_gl_args,fname=get_value("Name"))
#+RESULTS:
#+begin_src f90 :tangle (eval f) :comments org :exports none
integer(c_int32_t) function qmckl_distance_rescaled_gl &
(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(c_char) , intent(in) , value :: transa
character(c_char) , 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,4)
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_gl_f
info = qmckl_distance_rescaled_gl_f &
(context, transa, transb, m, n, A, lda, B, ldb, C, ldc, rescale_factor_kappa)
end function qmckl_distance_rescaled_gl
#+end_src
#+CALL: generate_f_interface(table=qmckl_distance_rescaled_gl_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_gl &
integer(qmckl_exit_code) function qmckl_distance_rescaled_gl &
(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(c_char) , intent(in) , value :: transa
character(c_char) , intent(in) , value :: transb
integer (qmckl_context), intent(in) , value :: context
character(c_char ) , intent(in) , value :: transa
character(c_char ) , 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,4)
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

16
tools/lib.org
View File

@ -35,10 +35,10 @@
*** Fortran-C type conversions
#+NAME:f_of_c
#+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
#+BEGIN_SRC python :var table=test :var rettyp="qmckl_exit_code" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
f_of_c_d = { '' : ''
, 'qmckl_context' : 'integer (c_int64_t)'
, 'qmckl_exit_code' : 'integer (c_int32_t)'
, 'qmckl_context' : 'integer (qmckl_context)'
, 'qmckl_exit_code' : 'integer (qmckl_exit_code)'
, 'bool' : 'logical*8'
, 'int32_t' : 'integer (c_int32_t)'
, 'int64_t' : 'integer (c_int64_t)'
@ -53,8 +53,8 @@ f_of_c_d = { '' : ''
#+NAME:c_of_f
#+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
ctypeid_d = { '' : ''
, 'qmckl_context' : 'integer(c_int64_t)'
, 'qmckl_exit_code' : 'integer(c_int32_t)'
, 'qmckl_context' : 'integer(qmckl_context)'
, 'qmckl_exit_code' : 'integer(qmckl_exit_code)'
, 'integer' : 'integer(c_int32_t)'
, 'integer*8' : 'integer(c_int64_t)'
, 'real' : 'real(c_float)'
@ -164,7 +164,7 @@ return template
*** Generates a C interface to the Fortran function
#+NAME: generate_c_interface
#+BEGIN_SRC python :var table=[] :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
#+BEGIN_SRC python :var table=[] :var rettyp="qmckl_exit_code" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval f) :comments org :exports none"
<<c_of_f>>
<<f_of_c>>
<<parse_table>>
@ -220,7 +220,7 @@ return results
*** Generates a Fortran interface to the C function
#+NAME: generate_f_interface
#+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_func) :comments org :exports none"
#+BEGIN_SRC python :var table=test :var rettyp="qmckl_exit_code" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_func) :comments org :exports none"
<<c_of_f>>
<<f_of_c>>
<<parse_table>>
@ -269,7 +269,7 @@ return results
#+END_SRC
#+NAME: generate_private_f_interface
#+BEGIN_SRC python :var table=test :var rettyp="integer" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_private_func) :comments org :exports none"
#+BEGIN_SRC python :var table=test :var rettyp="qmckl_exit_code" :var fname=[] :results value :noweb yes :wrap "src f90 :tangle (eval fh_private_func) :comments org :exports none"
<<c_of_f>>
<<f_of_c>>
<<parse_table>>