TREX/qmckl
1
0
Fork 0
mirror of https://github.com/TREX-CoE/qmckl.git synced 2024-07-18 08:53:47 +02:00
Code Issues Projects Releases Wiki Activity

Fixed some bugs, now compiles.

Browse Source
This commit is contained in:
v1j4y 2021-09-15 11:55:45 +02:00
parent 61751c307f
commit cf3550b6b7
1 changed files with 23 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
org/qmckl_blas.org
View File

@ -41,7 +41,7 @@ int main() {
| double | beta | in | Array containing the $n \times m$ matrix $B$ |
| double | C[][ldc] | out | Array containing the $n \times m$ matrix $B$ |
| int64_t | ldc | in | Leading dimension of array ~B~ |
*** Requirements
- ~context~ is not ~QMCKL_NULL_CONTEXT~
@ -86,14 +86,15 @@ integer function qmckl_dgemm_f(context, TransA, TransB, m, n, k, alpha, A, LDA,
use qmckl
implicit none
integer(qmckl_context) , intent(in) :: context
logical*8 , intent(in) :: TransA, TransN
logical*8 , intent(in) :: TransA, TransB
integer*8 , intent(in) :: m, n, k
real*8 , intent(in) :: alpha, beta
integer*8 , intent(in) :: lda
real*8 , intent(in) :: A(lda,*)
real*8 , intent(in) :: A(m,n)
integer*8 , intent(in) :: ldb
real*8 , intent(in) :: B(ldb,*)
real*8 , intent(in) :: B(n,k)
integer*8 , intent(in) :: ldc
real*8 , intent(out) :: C(ldc,*)
real*8 , intent(out) :: C(m,n)
integer*8 :: i,j
@ -158,13 +159,13 @@ end function qmckl_dgemm_f
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,*)
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(in) :: B(ldb,*)
real (c_double ) , intent(in) , value :: beta
real (c_double ) , intent(out) :: C(ldc,*)
integer (c_int64_t) , intent(in) , value :: ldc
real (c_double ) , intent(out) :: C(ldc,*)
integer(c_int32_t), external :: qmckl_dgemm_f
info = qmckl_dgemm_f &
@ -180,26 +181,26 @@ end function qmckl_dgemm_f
#+begin_src f90 :tangle (eval fh_func) :comments org :exports none
interface
integer(c_int32_t) function qmckl_dgemm &
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beat, C, ldc) &
(context, TransA, TransB, m, n, k, alpha, A, lda, B, ldb, beta, C, ldc) &
bind(C)
use, intrinsic :: iso_c_binding
import
implicit none
integer (c_int64_t) , intent(in) , value :: context
logical*8 (c_bool) , intent(in) , value :: TransA
logical*8 (c_bool) , intent(in) , value :: TransB
logical*8 , intent(in) , value :: TransA
logical*8 , 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) :: alpha
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: lda
real (c_double ) , intent(in) :: A(lda,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(in) :: B(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
real (c_double ) , intent(in) :: beta
real (c_double ) , intent(out) :: C(ldb,*)
integer (c_int64_t) , intent(in) , value :: ldb
integer (c_int64_t) , intent(in) , value :: ldc
real (c_double ) , intent(out) :: C(ldc,*)
end function qmckl_dgemm
end interface
@ -214,15 +215,15 @@ integer(qmckl_exit_code) function test_qmckl_dgemm(context) bind(C)
double precision, allocatable :: A(:,:), B(:,:), C(:,:), D(:,:)
integer*8 :: m, n, k, LDA, LDB, LDC
integer*8 :: i,j
integer*8 :: i,j,l
logical*8 :: TransA, TransB
double precision :: x
double precision :: x, alpha, beta
TransA = .False.
TransB = .False.
m = 5
k = 4
n = 6
m = 5_8
k = 4_8
n = 6_8
LDA = m
LDB = k
LDC = m
@ -255,11 +256,12 @@ integer(qmckl_exit_code) function test_qmckl_dgemm(context) bind(C)
do j=1,m
do i=l,n
do l=1,k
D(i,j) += D(i,j) + (A(i,k)*B(k,j))
D(i,j) = D(i,j) + A(i,k)*B(k,j)
end do
x = x + (D(i,j) - C(i,j))**2
end do
end do
print *,"DABS(X)= ",dabs(x)
if (dabs(x) <= 1.d-15) then
test_qmckl_dgemm = QMCKL_SUCCESS