mirror of
https://github.com/TREX-CoE/qmckl.git
synced 2024-08-25 06:31:45 +02:00
Simplifying Fortran
This commit is contained in:
parent
0d9af3c497
commit
de98045fe4
@ -976,27 +976,37 @@ double* qmckl_alloc_double_of_tensor(const qmckl_context context,
|
|||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
#+begin_src f90 :tangle (eval f) :exports none
|
#+begin_src f90 :tangle (eval f) :exports none
|
||||||
integer function qmckl_dgemm_f(context, TransA, TransB, &
|
function qmckl_dgemm(context, TransA, TransB, &
|
||||||
m, n, k, alpha, A, LDA, B, LDB, beta, C, LDC) &
|
m, n, k, alpha, A, LDA, B, LDB, beta, C, LDC) &
|
||||||
result(info)
|
bind(C) result(info)
|
||||||
use qmckl
|
use, intrinsic :: iso_c_binding
|
||||||
|
use qmckl_constants
|
||||||
#ifdef HAVE_LIBQMCKLDGEMM
|
#ifdef HAVE_LIBQMCKLDGEMM
|
||||||
use qmckl_dgemm_tiled_module
|
use qmckl_dgemm_tiled_module
|
||||||
#endif
|
#endif
|
||||||
implicit none
|
implicit none
|
||||||
integer(qmckl_context), intent(in) :: context
|
integer (qmckl_context), intent(in) , value :: context
|
||||||
character , intent(in) :: TransA, TransB
|
character(c_char ) , intent(in) , value :: TransA
|
||||||
integer*8 , intent(in) :: m, n, k
|
character(c_char ) , intent(in) , value :: TransB
|
||||||
double precision , intent(in) :: alpha, beta
|
integer (c_int64_t) , intent(in) , value :: m
|
||||||
integer*8 , intent(in) :: lda
|
integer (c_int64_t) , intent(in) , value :: n
|
||||||
double precision , intent(in) :: A(lda,*)
|
integer (c_int64_t) , intent(in) , value :: k
|
||||||
integer*8 , intent(in) :: ldb
|
real (c_double ) , intent(in) , value :: alpha
|
||||||
double precision , intent(in) :: B(ldb,*)
|
real (c_double ) , intent(in) :: A(lda,*)
|
||||||
integer*8 , intent(in) :: ldc
|
integer (c_int64_t) , intent(in) , value :: lda
|
||||||
double precision , intent(out) :: C(ldc,*)
|
real (c_double ) , intent(in) :: B(ldb,*)
|
||||||
|
integer (c_int64_t) , intent(in) , value :: ldb
|
||||||
|
real (c_double ) , intent(in) , value :: beta
|
||||||
|
real (c_double ) , intent(out) :: C(ldc,*)
|
||||||
|
integer (c_int64_t) , intent(in) , value :: ldc
|
||||||
|
integer(qmckl_exit_code) :: info
|
||||||
|
|
||||||
|
#ifdef HAVE_LIBQMCKLDGEMM
|
||||||
double precision,allocatable,dimension(:,:) :: A1
|
double precision,allocatable,dimension(:,:) :: A1
|
||||||
double precision,allocatable,dimension(:,:) :: B1
|
double precision,allocatable,dimension(:,:) :: B1
|
||||||
double precision,allocatable,dimension(:,:) :: C1
|
double precision,allocatable,dimension(:,:) :: C1
|
||||||
|
#endif
|
||||||
|
|
||||||
integer*8 :: i, j, LDA1, LDB1, LDC1
|
integer*8 :: i, j, LDA1, LDB1, LDC1
|
||||||
|
|
||||||
info = QMCKL_SUCCESS
|
info = QMCKL_SUCCESS
|
||||||
@ -1070,7 +1080,7 @@ integer function qmckl_dgemm_f(context, TransA, TransB, &
|
|||||||
|
|
||||||
do j=1,n
|
do j=1,n
|
||||||
do i=1,m
|
do i=1,m
|
||||||
transpose C(i,j) = alpha*C1(j,i) + beta*C(i,j)
|
transpose C(i,j) = alpha*C1(j,i) + beta*C(i,j)
|
||||||
end do
|
end do
|
||||||
end do
|
end do
|
||||||
|
|
||||||
@ -1081,60 +1091,26 @@ transpose C(i,j) = alpha*C1(j,i) + beta*C(i,j)
|
|||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
|
||||||
end function qmckl_dgemm_f
|
end function qmckl_dgemm
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
*** C interface :noexport:
|
*** C interface :noexport:
|
||||||
|
|
||||||
#+CALL: generate_c_interface(table=qmckl_dgemm_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm")
|
|
||||||
|
|
||||||
#+RESULTS:
|
|
||||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
|
||||||
integer(c_int32_t) function qmckl_dgemm &
|
|
||||||
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beta, 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
|
|
||||||
integer (c_int64_t) , intent(in) , value :: k
|
|
||||||
real (c_double ) , intent(in) , value :: alpha
|
|
||||||
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(in) , value :: beta
|
|
||||||
real (c_double ) , intent(out) :: C(ldc,*)
|
|
||||||
integer (c_int64_t) , intent(in) , value :: ldc
|
|
||||||
|
|
||||||
integer(c_int32_t), external :: qmckl_dgemm_f
|
|
||||||
info = qmckl_dgemm_f &
|
|
||||||
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beta, C, ldc)
|
|
||||||
|
|
||||||
end function qmckl_dgemm
|
|
||||||
#+end_src
|
|
||||||
|
|
||||||
|
|
||||||
#+CALL: generate_f_interface(table=qmckl_dgemm_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm")
|
#+CALL: generate_f_interface(table=qmckl_dgemm_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm")
|
||||||
|
|
||||||
#+RESULTS:
|
#+RESULTS:
|
||||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||||
interface
|
interface
|
||||||
integer(c_int32_t) function qmckl_dgemm &
|
integer(qmckl_exit_code) function qmckl_dgemm &
|
||||||
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beta, C, ldc) &
|
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beta, C, ldc) &
|
||||||
bind(C)
|
bind(C)
|
||||||
use, intrinsic :: iso_c_binding
|
use, intrinsic :: iso_c_binding
|
||||||
import
|
import
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
integer (c_int64_t) , intent(in) , value :: context
|
integer (qmckl_context), intent(in) , value :: context
|
||||||
character(c_char) , intent(in) , value :: TransA
|
character(c_char ) , intent(in) , value :: TransA
|
||||||
character(c_char) , intent(in) , value :: TransB
|
character(c_char ) , intent(in) , value :: TransB
|
||||||
integer (c_int64_t) , intent(in) , value :: m
|
integer (c_int64_t) , intent(in) , value :: m
|
||||||
integer (c_int64_t) , intent(in) , value :: n
|
integer (c_int64_t) , intent(in) , value :: n
|
||||||
integer (c_int64_t) , intent(in) , value :: k
|
integer (c_int64_t) , intent(in) , value :: k
|
||||||
@ -1295,25 +1271,31 @@ printf("qmckl_dgemm ok\n");
|
|||||||
#+END_src
|
#+END_src
|
||||||
|
|
||||||
#+begin_src f90 :tangle (eval f) :exports none
|
#+begin_src f90 :tangle (eval f) :exports none
|
||||||
integer function qmckl_dgemm_safe_f(context, TransA, TransB, &
|
function qmckl_dgemm_safe(context, TransA, TransB, &
|
||||||
m, n, k, alpha, A, size_A, LDA, B, size_B, LDB, beta, C, size_C, LDC) &
|
m, n, k, alpha, A, size_A, LDA, B, size_B, LDB, beta, C, size_C, LDC) &
|
||||||
result(info)
|
result(info) bind(C)
|
||||||
use qmckl
|
use, intrinsic :: iso_c_binding
|
||||||
|
use qmckl_constants
|
||||||
implicit none
|
implicit none
|
||||||
integer(qmckl_context), intent(in) :: context
|
integer (qmckl_context), intent(in) , value :: context
|
||||||
character , intent(in) :: TransA, TransB
|
character(c_char ) , intent(in) , value :: TransA
|
||||||
integer*8 , intent(in) :: m, n, k
|
character(c_char ) , intent(in) , value :: TransB
|
||||||
double precision , intent(in) :: alpha, beta
|
integer (c_int64_t) , intent(in) , value :: m
|
||||||
integer*8 , intent(in) :: lda
|
integer (c_int64_t) , intent(in) , value :: n
|
||||||
integer*8 , intent(in) :: size_A
|
integer (c_int64_t) , intent(in) , value :: k
|
||||||
double precision , intent(in) :: A(lda,*)
|
real (c_double ) , intent(in) , value :: alpha
|
||||||
integer*8 , intent(in) :: ldb
|
real (c_double ) , intent(in) :: A(lda,*)
|
||||||
integer*8 , intent(in) :: size_B
|
integer (c_int64_t) , intent(in) , value :: size_A
|
||||||
double precision , intent(in) :: B(ldb,*)
|
integer (c_int64_t) , intent(in) , value :: lda
|
||||||
integer*8 , intent(in) :: ldc
|
real (c_double ) , intent(in) :: B(ldb,*)
|
||||||
integer*8 , intent(in) :: size_C
|
integer (c_int64_t) , intent(in) , value :: size_B
|
||||||
double precision , intent(out) :: C(ldc,*)
|
integer (c_int64_t) , intent(in) , value :: ldb
|
||||||
|
real (c_double ) , intent(in) , value :: beta
|
||||||
|
real (c_double ) , intent(out) :: C(ldc,*)
|
||||||
|
integer (c_int64_t) , intent(in) , value :: size_C
|
||||||
|
integer (c_int64_t) , intent(in) , value :: ldc
|
||||||
|
|
||||||
|
integer(qmckl_exit_code) :: info
|
||||||
info = QMCKL_SUCCESS
|
info = QMCKL_SUCCESS
|
||||||
|
|
||||||
if (context == QMCKL_NULL_CONTEXT) then
|
if (context == QMCKL_NULL_CONTEXT) then
|
||||||
@ -1369,76 +1351,39 @@ integer function qmckl_dgemm_safe_f(context, TransA, TransB, &
|
|||||||
call dgemm(transA, transB, int(m,4), int(n,4), int(k,4), &
|
call dgemm(transA, transB, int(m,4), int(n,4), int(k,4), &
|
||||||
alpha, A, int(LDA,4), B, int(LDB,4), beta, C, int(LDC,4))
|
alpha, A, int(LDA,4), B, int(LDB,4), beta, C, int(LDC,4))
|
||||||
|
|
||||||
end function qmckl_dgemm_safe_f
|
end function qmckl_dgemm_safe
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
*** C interface :noexport:
|
*** C interface :noexport:
|
||||||
|
|
||||||
#+CALL: generate_c_interface(table=qmckl_dgemm_safe_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm_safe")
|
|
||||||
|
|
||||||
#+RESULTS:
|
|
||||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
|
||||||
integer(c_int32_t) function qmckl_dgemm_safe &
|
|
||||||
(context, TransA, TransB, m, n, k, alpha, A, size_A, lda, B, size_B, ldb, beta, C, size_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
|
|
||||||
integer (c_int64_t) , intent(in) , value :: k
|
|
||||||
real (c_double ) , intent(in) , value :: alpha
|
|
||||||
real (c_double ) , intent(in) :: A(lda,*)
|
|
||||||
integer (c_int64_t) , intent(in) , value :: size_A
|
|
||||||
integer (c_int64_t) , intent(in) , value :: lda
|
|
||||||
real (c_double ) , intent(in) :: B(ldb,*)
|
|
||||||
integer (c_int64_t) , intent(in) , value :: size_B
|
|
||||||
integer (c_int64_t) , intent(in) , value :: ldb
|
|
||||||
real (c_double ) , intent(in) , value :: beta
|
|
||||||
real (c_double ) , intent(out) :: C(ldc,*)
|
|
||||||
integer (c_int64_t) , intent(in) , value :: size_C
|
|
||||||
integer (c_int64_t) , intent(in) , value :: ldc
|
|
||||||
|
|
||||||
integer(c_int32_t), external :: qmckl_dgemm_safe_f
|
|
||||||
info = qmckl_dgemm_safe_f &
|
|
||||||
(context, TransA, TransB, m, n, k, alpha, A, size_A, lda, B, size_B, ldb, beta, C, size_C, ldc)
|
|
||||||
|
|
||||||
end function qmckl_dgemm_safe
|
|
||||||
#+end_src
|
|
||||||
|
|
||||||
|
|
||||||
#+CALL: generate_f_interface(table=qmckl_dgemm_safe_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm_safe")
|
#+CALL: generate_f_interface(table=qmckl_dgemm_safe_args,rettyp="qmckl_exit_code",fname="qmckl_dgemm_safe")
|
||||||
|
|
||||||
#+RESULTS:
|
#+RESULTS:
|
||||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||||
interface
|
interface
|
||||||
integer(c_int32_t) function qmckl_dgemm_safe &
|
integer(qmckl_exit_code) function qmckl_dgemm_safe &
|
||||||
(context, TransA, TransB, m, n, k, alpha, A, size_A, lda, B, size_B, ldb, beta, C, size_C, ldc) &
|
(context, TransA, TransB, m, n, k, alpha, A, size_max_A, lda, B, size_max_B, ldb, beta, C, size_max_C, ldc) &
|
||||||
bind(C)
|
bind(C)
|
||||||
use, intrinsic :: iso_c_binding
|
use, intrinsic :: iso_c_binding
|
||||||
import
|
import
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
integer (c_int64_t) , intent(in) , value :: context
|
integer (qmckl_context), intent(in) , value :: context
|
||||||
character(c_char) , intent(in) , value :: TransA
|
character(c_char ) , intent(in) , value :: TransA
|
||||||
character(c_char) , intent(in) , value :: TransB
|
character(c_char ) , intent(in) , value :: TransB
|
||||||
integer (c_int64_t) , intent(in) , value :: m
|
integer (c_int64_t) , intent(in) , value :: m
|
||||||
integer (c_int64_t) , intent(in) , value :: n
|
integer (c_int64_t) , intent(in) , value :: n
|
||||||
integer (c_int64_t) , intent(in) , value :: k
|
integer (c_int64_t) , intent(in) , value :: k
|
||||||
real (c_double ) , intent(in) , value :: alpha
|
real (c_double ) , intent(in) , value :: alpha
|
||||||
real (c_double ) , intent(in) :: A(lda,*)
|
real (c_double ) , intent(in) :: A(lda,*)
|
||||||
integer (c_int64_t) , intent(in) , value :: size_A
|
integer (c_int64_t) , intent(in) , value :: size_max_A
|
||||||
integer (c_int64_t) , intent(in) , value :: lda
|
integer (c_int64_t) , intent(in) , value :: lda
|
||||||
real (c_double ) , intent(in) :: B(ldb,*)
|
real (c_double ) , intent(in) :: B(ldb,*)
|
||||||
integer (c_int64_t) , intent(in) , value :: size_B
|
integer (c_int64_t) , intent(in) , value :: size_max_B
|
||||||
integer (c_int64_t) , intent(in) , value :: ldb
|
integer (c_int64_t) , intent(in) , value :: ldb
|
||||||
real (c_double ) , intent(in) , value :: beta
|
real (c_double ) , intent(in) , value :: beta
|
||||||
real (c_double ) , intent(out) :: C(ldc,*)
|
real (c_double ) , intent(out) :: C(ldc,*)
|
||||||
integer (c_int64_t) , intent(in) , value :: size_C
|
integer (c_int64_t) , intent(in) , value :: size_max_C
|
||||||
integer (c_int64_t) , intent(in) , value :: ldc
|
integer (c_int64_t) , intent(in) , value :: ldc
|
||||||
|
|
||||||
end function qmckl_dgemm_safe
|
end function qmckl_dgemm_safe
|
||||||
@ -1756,17 +1701,20 @@ print(C.T)
|
|||||||
LAPACK library.
|
LAPACK library.
|
||||||
|
|
||||||
#+begin_src f90 :tangle (eval f) :exports none
|
#+begin_src f90 :tangle (eval f) :exports none
|
||||||
integer function qmckl_adjugate_f(context, na, A, LDA, B, ldb, det_l) &
|
function qmckl_adjugate(context, n, A, LDA, B, ldb, det_l) &
|
||||||
result(info)
|
result(info) bind(C)
|
||||||
use qmckl
|
use qmckl_constants
|
||||||
|
use, intrinsic :: iso_c_binding
|
||||||
implicit none
|
implicit none
|
||||||
integer(qmckl_context) , intent(in) :: context
|
|
||||||
double precision, intent(in) :: A (LDA,*)
|
integer (qmckl_context), intent(in) , value :: context
|
||||||
integer*8, intent(in) :: LDA
|
integer (c_int64_t) , intent(in) , value :: n
|
||||||
double precision, intent(out) :: B (LDB,*)
|
real (c_double ) , intent(in) :: A(lda,*)
|
||||||
integer*8, intent(in) :: LDB
|
integer (c_int64_t) , intent(in) , value :: lda
|
||||||
integer*8, intent(in) :: na
|
real (c_double ) , intent(out) :: B(ldb,*)
|
||||||
double precision, intent(inout) :: det_l
|
integer (c_int64_t) , intent(in) , value :: ldb
|
||||||
|
real (c_double ) , intent(inout) :: det_l
|
||||||
|
integer(qmckl_exit_code) :: info
|
||||||
|
|
||||||
info = QMCKL_SUCCESS
|
info = QMCKL_SUCCESS
|
||||||
|
|
||||||
@ -1775,7 +1723,7 @@ integer function qmckl_adjugate_f(context, na, A, LDA, B, ldb, det_l) &
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if (na <= 0_8) then
|
if (n <= 0_8) then
|
||||||
info = QMCKL_INVALID_ARG_2
|
info = QMCKL_INVALID_ARG_2
|
||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
@ -1785,28 +1733,28 @@ integer function qmckl_adjugate_f(context, na, A, LDA, B, ldb, det_l) &
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
if (LDA < na) then
|
if (LDA < n) then
|
||||||
info = QMCKL_INVALID_ARG_4
|
info = QMCKL_INVALID_ARG_4
|
||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
select case (na)
|
select case (n)
|
||||||
case (5)
|
case (5)
|
||||||
call adjugate5(A,LDA,B,LDB,na,det_l)
|
call adjugate5(A,LDA,B,LDB,n,det_l)
|
||||||
case (4)
|
case (4)
|
||||||
call adjugate4(A,LDA,B,LDB,na,det_l)
|
call adjugate4(A,LDA,B,LDB,n,det_l)
|
||||||
case (3)
|
case (3)
|
||||||
call adjugate3(A,LDA,B,LDB,na,det_l)
|
call adjugate3(A,LDA,B,LDB,n,det_l)
|
||||||
case (2)
|
case (2)
|
||||||
call adjugate2(A,LDA,B,LDB,na,det_l)
|
call adjugate2(A,LDA,B,LDB,n,det_l)
|
||||||
case (1)
|
case (1)
|
||||||
det_l = a(1,1)
|
det_l = a(1,1)
|
||||||
b(1,1) = 1.d0
|
b(1,1) = 1.d0
|
||||||
case default
|
case default
|
||||||
call adjugate_general(context, na, A, LDA, B, LDB, det_l)
|
call adjugate_general(context, n, A, LDA, B, LDB, det_l)
|
||||||
end select
|
end select
|
||||||
|
|
||||||
end function qmckl_adjugate_f
|
end function qmckl_adjugate
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
#+begin_src f90 :tangle (eval f) :exports none
|
#+begin_src f90 :tangle (eval f) :exports none
|
||||||
@ -2188,45 +2136,19 @@ subroutine cofactor5(A,LDA,B,LDB,na,det_l)
|
|||||||
end
|
end
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
#+CALL: generate_c_interface(table=qmckl_adjugate_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate")
|
|
||||||
|
|
||||||
#+RESULTS:
|
|
||||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
|
||||||
integer(c_int32_t) function qmckl_adjugate &
|
|
||||||
(context, n, A, lda, B, ldb, det_l) &
|
|
||||||
bind(C) result(info)
|
|
||||||
|
|
||||||
use, intrinsic :: iso_c_binding
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer (c_int64_t) , intent(in) , value :: context
|
|
||||||
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(out) :: B(ldb,*)
|
|
||||||
integer (c_int64_t) , intent(in) , value :: ldb
|
|
||||||
real (c_double ) , intent(inout) :: det_l
|
|
||||||
|
|
||||||
integer(c_int32_t), external :: qmckl_adjugate_f
|
|
||||||
info = qmckl_adjugate_f &
|
|
||||||
(context, n, A, lda, B, ldb, det_l)
|
|
||||||
|
|
||||||
end function qmckl_adjugate
|
|
||||||
#+end_src
|
|
||||||
|
|
||||||
#+CALL: generate_f_interface(table=qmckl_adjugate_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate")
|
#+CALL: generate_f_interface(table=qmckl_adjugate_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate")
|
||||||
|
|
||||||
#+RESULTS:
|
#+RESULTS:
|
||||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||||
interface
|
interface
|
||||||
integer(c_int32_t) function qmckl_adjugate &
|
integer(qmckl_exit_code) function qmckl_adjugate &
|
||||||
(context, n, A, lda, B, ldb, det_l) &
|
(context, n, A, lda, B, ldb, det_l) &
|
||||||
bind(C)
|
bind(C)
|
||||||
use, intrinsic :: iso_c_binding
|
use, intrinsic :: iso_c_binding
|
||||||
import
|
import
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
integer (c_int64_t) , intent(in) , value :: context
|
integer (qmckl_context), intent(in) , value :: context
|
||||||
integer (c_int64_t) , intent(in) , value :: n
|
integer (c_int64_t) , intent(in) , value :: n
|
||||||
real (c_double ) , intent(in) :: A(lda,*)
|
real (c_double ) , intent(in) :: A(lda,*)
|
||||||
integer (c_int64_t) , intent(in) , value :: lda
|
integer (c_int64_t) , intent(in) , value :: lda
|
||||||
@ -2315,7 +2237,7 @@ end subroutine adjugate_general
|
|||||||
|
|
||||||
#+begin_src f90 :tangle (eval f_test)
|
#+begin_src f90 :tangle (eval f_test)
|
||||||
integer(qmckl_exit_code) function test_qmckl_adjugate(context) bind(C)
|
integer(qmckl_exit_code) function test_qmckl_adjugate(context) bind(C)
|
||||||
use qmckl
|
use qmckl_constants
|
||||||
implicit none
|
implicit none
|
||||||
integer(qmckl_context), intent(in), value :: context
|
integer(qmckl_context), intent(in), value :: context
|
||||||
|
|
||||||
@ -2642,22 +2564,26 @@ printf("qmckl_adjugate ok\n");
|
|||||||
LAPACK library.
|
LAPACK library.
|
||||||
|
|
||||||
#+begin_src f90 :tangle (eval f) :exports none
|
#+begin_src f90 :tangle (eval f) :exports none
|
||||||
integer function qmckl_adjugate_safe_f(context, &
|
function qmckl_adjugate_safe(context, &
|
||||||
na, A, size_A, LDA, B, size_B, LDB, det_l) &
|
na, A, size_A, LDA, B, size_B, LDB, det_l) &
|
||||||
result(info)
|
result(info) bind(C)
|
||||||
use qmckl
|
use, intrinsic :: iso_c_binding
|
||||||
implicit none
|
use qmckl_constants
|
||||||
integer(qmckl_context) , intent(in) :: context
|
use qmckl, only: qmckl_adjugate
|
||||||
double precision, intent(in) :: A (LDA,*)
|
|
||||||
integer*8, intent(in) :: size_A
|
|
||||||
integer*8, intent(in) :: LDA
|
|
||||||
double precision, intent(out) :: B (LDB,*)
|
|
||||||
integer*8, intent(in) :: size_B
|
|
||||||
integer*8, intent(in) :: LDB
|
|
||||||
integer*8, intent(in) :: na
|
|
||||||
double precision, intent(inout) :: det_l
|
|
||||||
|
|
||||||
integer, external :: qmckl_adjugate_f
|
implicit none
|
||||||
|
|
||||||
|
integer (qmckl_context), intent(in) , value :: context
|
||||||
|
integer (c_int64_t) , intent(in) , value :: na
|
||||||
|
real (c_double ) , intent(in) :: A(lda,*)
|
||||||
|
integer (c_int64_t) , intent(in) , value :: size_A
|
||||||
|
integer (c_int64_t) , intent(in) , value :: lda
|
||||||
|
real (c_double ) , intent(out) :: B(ldb,*)
|
||||||
|
integer (c_int64_t) , intent(in) , value :: size_B
|
||||||
|
integer (c_int64_t) , intent(in) , value :: ldb
|
||||||
|
real (c_double ) , intent(inout) :: det_l
|
||||||
|
|
||||||
|
integer(qmckl_exit_code) :: info
|
||||||
|
|
||||||
info = QMCKL_SUCCESS
|
info = QMCKL_SUCCESS
|
||||||
|
|
||||||
@ -2671,7 +2597,7 @@ integer function qmckl_adjugate_safe_f(context, &
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
info = qmckl_adjugate_f(context, na, A, LDA, B, LDB, det_l)
|
info = qmckl_adjugate(context, na, A, LDA, B, LDB, det_l)
|
||||||
|
|
||||||
if (info == QMCKL_INVALID_ARG_4) then
|
if (info == QMCKL_INVALID_ARG_4) then
|
||||||
info = QMCKL_INVALID_ARG_5
|
info = QMCKL_INVALID_ARG_5
|
||||||
@ -2683,59 +2609,31 @@ integer function qmckl_adjugate_safe_f(context, &
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
end function qmckl_adjugate_safe_f
|
end function qmckl_adjugate_safe
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
*** C interface
|
*** C interface
|
||||||
|
|
||||||
#+CALL: generate_c_interface(table=qmckl_adjugate_safe_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate_safe")
|
|
||||||
|
|
||||||
#+RESULTS:
|
|
||||||
#+begin_src f90 :tangle (eval f) :comments org :exports none
|
|
||||||
integer(c_int32_t) function qmckl_adjugate_safe &
|
|
||||||
(context, n, A, size_A, lda, B, size_B, ldb, det_l) &
|
|
||||||
bind(C) result(info)
|
|
||||||
|
|
||||||
use, intrinsic :: iso_c_binding
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer (c_int64_t) , intent(in) , value :: context
|
|
||||||
integer (c_int64_t) , intent(in) , value :: n
|
|
||||||
real (c_double ) , intent(in) :: A(lda,*)
|
|
||||||
integer (c_int64_t) , intent(in) , value :: lda
|
|
||||||
integer (c_int64_t) , intent(in) , value :: size_A
|
|
||||||
real (c_double ) , intent(out) :: B(ldb,*)
|
|
||||||
integer (c_int64_t) , intent(in) , value :: ldb
|
|
||||||
integer (c_int64_t) , intent(in) , value :: size_B
|
|
||||||
real (c_double ) , intent(inout) :: det_l
|
|
||||||
|
|
||||||
integer(c_int32_t), external :: qmckl_adjugate_safe_f
|
|
||||||
info = qmckl_adjugate_safe_f &
|
|
||||||
(context, n, A, size_A, lda, B, size_B, ldb, det_l)
|
|
||||||
|
|
||||||
end function qmckl_adjugate_safe
|
|
||||||
#+end_src
|
|
||||||
|
|
||||||
#+CALL: generate_f_interface(table=qmckl_adjugate_safe_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate_safe")
|
#+CALL: generate_f_interface(table=qmckl_adjugate_safe_args,rettyp="qmckl_exit_code",fname="qmckl_adjugate_safe")
|
||||||
|
|
||||||
#+RESULTS:
|
#+RESULTS:
|
||||||
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
|
||||||
interface
|
interface
|
||||||
integer(c_int32_t) function qmckl_adjugate_safe &
|
integer(qmckl_exit_code) function qmckl_adjugate_safe &
|
||||||
(context, n, A, size_A, lda, B, size_B, ldb, det_l) &
|
(context, n, A, size_max_A, lda, B, size_max_B, ldb, det_l) &
|
||||||
bind(C)
|
bind(C)
|
||||||
use, intrinsic :: iso_c_binding
|
use, intrinsic :: iso_c_binding
|
||||||
import
|
import
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
integer (c_int64_t) , intent(in) , value :: context
|
integer (qmckl_context), intent(in) , value :: context
|
||||||
integer (c_int64_t) , intent(in) , value :: n
|
integer (c_int64_t) , intent(in) , value :: n
|
||||||
real (c_double ) , intent(in) :: A(lda,*)
|
real (c_double ) , intent(in) :: A(lda,*)
|
||||||
|
integer (c_int64_t) , intent(in) , value :: size_max_A
|
||||||
integer (c_int64_t) , intent(in) , value :: lda
|
integer (c_int64_t) , intent(in) , value :: lda
|
||||||
integer (c_int64_t) , intent(in) , value :: size_A
|
|
||||||
real (c_double ) , intent(out) :: B(ldb,*)
|
real (c_double ) , intent(out) :: B(ldb,*)
|
||||||
|
integer (c_int64_t) , intent(in) , value :: size_max_B
|
||||||
integer (c_int64_t) , intent(in) , value :: ldb
|
integer (c_int64_t) , intent(in) , value :: ldb
|
||||||
integer (c_int64_t) , intent(in) , value :: size_B
|
|
||||||
real (c_double ) , intent(inout) :: det_l
|
real (c_double ) , intent(inout) :: det_l
|
||||||
|
|
||||||
end function qmckl_adjugate_safe
|
end function qmckl_adjugate_safe
|
||||||
|
Loading…
Reference in New Issue
Block a user