Commit 5466e576 authored by Andreas Marek's avatar Andreas Marek
Browse files

Some GPU functions with type(c_ptr) interface

parent 685e9338
...@@ -218,7 +218,7 @@ extern "C" { ...@@ -218,7 +218,7 @@ extern "C" {
} }
int cudaMemcpy2dFromC(intptr_t *dest, size_t dpitch, intptr_t *src, size_t spitch, size_t width, size_t height, int dir) { int cudaMemcpy2dFromC(intptr_t *dest, size_t dpitch, intptr_t *src, size_t spitch, size_t width, size_t height, int dir) {
cudaError_t cuerr = cudaMemcpy2D( dest, dpitch, src, spitch, width, height, (cudaMemcpyKind)dir); cudaError_t cuerr = cudaMemcpy2D( dest, dpitch, src, spitch, width, height, (cudaMemcpyKind)dir);
if (cuerr != cudaSuccess) { if (cuerr != cudaSuccess) {
errormessage("Error in cudaMemcpy2d: %s\n",cudaGetErrorString(cuerr)); errormessage("Error in cudaMemcpy2d: %s\n",cudaGetErrorString(cuerr));
...@@ -435,6 +435,32 @@ extern "C" { ...@@ -435,6 +435,32 @@ extern "C" {
// todo: it provides out-of-place (and apparently more efficient) implementation // todo: it provides out-of-place (and apparently more efficient) implementation
// todo: by passing B twice (in place of C as well), we should fall back to in-place algorithm // todo: by passing B twice (in place of C as well), we should fall back to in-place algorithm
void cublasDcopy_elpa_wrapper (intptr_t handle, int n, double *x, int incx, double *y, int incy){
cublasDcopy(*((cublasHandle_t*)handle), n, x, incx, y, incy);
}
void cublasScopy_elpa_wrapper (intptr_t handle, int n, float *x, int incx, float *y, int incy){
cublasScopy(*((cublasHandle_t*)handle), n, x, incx, y, incy);
}
void cublasZcopy_elpa_wrapper (intptr_t handle, int n, double _Complex *x, int incx, double _Complex *y, int incy){
const cuDoubleComplex* X_casted = (const cuDoubleComplex*) x;
cuDoubleComplex* Y_casted = ( cuDoubleComplex*) y;
cublasZcopy(*((cublasHandle_t*)handle), n, X_casted, incx, Y_casted, incy);
}
void cublasCcopy_elpa_wrapper (intptr_t handle, int n, float _Complex *x, int incx, float _Complex *y, int incy){
const cuFloatComplex* X_casted = (const cuFloatComplex*) x;
cuFloatComplex* Y_casted = ( cuFloatComplex*) y;
cublasCcopy(*((cublasHandle_t*)handle), n, X_casted, incx, Y_casted, incy);
}
void cublasDtrmm_elpa_wrapper (intptr_t handle, char side, char uplo, char transa, char diag, void cublasDtrmm_elpa_wrapper (intptr_t handle, char side, char uplo, char transa, char diag,
int m, int n, double alpha, const double *A, int m, int n, double alpha, const double *A,
int lda, double *B, int ldb){ int lda, double *B, int ldb){
......
...@@ -182,7 +182,7 @@ module cuda_functions ...@@ -182,7 +182,7 @@ module cuda_functions
end interface end interface
interface interface
function cuda_memcpy_c(dst, src, size, dir) result(istat) & function cuda_memcpy_intptr_c(dst, src, size, dir) result(istat) &
bind(C, name="cudaMemcpyFromC") bind(C, name="cudaMemcpyFromC")
use, intrinsic :: iso_c_binding use, intrinsic :: iso_c_binding
...@@ -194,11 +194,43 @@ module cuda_functions ...@@ -194,11 +194,43 @@ module cuda_functions
integer(kind=C_INT), intent(in), value :: dir integer(kind=C_INT), intent(in), value :: dir
integer(kind=C_INT) :: istat integer(kind=C_INT) :: istat
end function cuda_memcpy_c end function cuda_memcpy_intptr_c
end interface end interface
interface interface
function cuda_memcpy2d_c(dst, dpitch, src, spitch, width, height , dir) result(istat) & function cuda_memcpy_cptr_c(dst, src, size, dir) result(istat) &
bind(C, name="cudaMemcpyFromC")
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr), value :: dst
type(c_ptr), value :: src
integer(kind=c_intptr_t), intent(in), value :: size
integer(kind=C_INT), intent(in), value :: dir
integer(kind=C_INT) :: istat
end function cuda_memcpy_cptr_c
end interface
interface
function cuda_memcpy_mixed_c(dst, src, size, dir) result(istat) &
bind(C, name="cudaMemcpyFromC")
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr), value :: dst
integer(kind=C_intptr_t), value :: src
integer(kind=c_intptr_t), intent(in), value :: size
integer(kind=C_INT), intent(in), value :: dir
integer(kind=C_INT) :: istat
end function cuda_memcpy_mixed_c
end interface
interface
function cuda_memcpy2d_intptr_c(dst, dpitch, src, spitch, width, height , dir) result(istat) &
bind(C, name="cudaMemcpy2dFromC") bind(C, name="cudaMemcpy2dFromC")
use, intrinsic :: iso_c_binding use, intrinsic :: iso_c_binding
...@@ -214,7 +246,27 @@ module cuda_functions ...@@ -214,7 +246,27 @@ module cuda_functions
integer(kind=C_INT), intent(in), value :: dir integer(kind=C_INT), intent(in), value :: dir
integer(kind=C_INT) :: istat integer(kind=C_INT) :: istat
end function cuda_memcpy2d_c end function cuda_memcpy2d_intptr_c
end interface
interface
function cuda_memcpy2d_cptr_c(dst, dpitch, src, spitch, width, height , dir) result(istat) &
bind(C, name="cudaMemcpy2dFromC")
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr), value :: dst
integer(kind=c_intptr_t), intent(in), value :: dpitch
type(c_ptr), value :: src
integer(kind=c_intptr_t), intent(in), value :: spitch
integer(kind=c_intptr_t), intent(in), value :: width
integer(kind=c_intptr_t), intent(in), value :: height
integer(kind=C_INT), intent(in), value :: dir
integer(kind=C_INT) :: istat
end function cuda_memcpy2d_cptr_c
end interface end interface
interface interface
...@@ -260,6 +312,12 @@ module cuda_functions ...@@ -260,6 +312,12 @@ module cuda_functions
end function cuda_free_c end function cuda_free_c
end interface end interface
interface cuda_memcpy
module procedure cuda_memcpy_intptr
module procedure cuda_memcpy_cptr
module procedure cuda_memcpy_mixed
end interface
interface interface
function cuda_malloc_c(a, width_height) result(istat) & function cuda_malloc_c(a, width_height) result(istat) &
bind(C, name="cudaMallocFromC") bind(C, name="cudaMallocFromC")
...@@ -352,8 +410,84 @@ module cuda_functions ...@@ -352,8 +410,84 @@ module cuda_functions
end subroutine cublas_sgemm_c end subroutine cublas_sgemm_c
end interface end interface
interface cublas_dcopy
module procedure cublas_dcopy_intptr
module procedure cublas_dcopy_cptr
end interface
interface
subroutine cublas_dcopy_intptr_c(handle, n, x, incx, y, incy) &
bind(C,name='cublasDcopy_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT),value :: n
integer(kind=C_INT), intent(in), value :: incx,incy
integer(kind=C_intptr_T), value :: x, y
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_dcopy_intptr_c
end interface
interface
subroutine cublas_dcopy_cptr_c(handle, n, x, incx, y, incy) &
bind(C,name='cublasDcopy_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT),value :: n
integer(kind=C_INT), intent(in), value :: incx,incy
type(c_ptr), value :: x, y
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_dcopy_cptr_c
end interface
interface cublas_scopy
module procedure cublas_scopy_intptr
module procedure cublas_scopy_cptr
end interface
interface interface
subroutine cublas_dtrmm_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) & subroutine cublas_scopy_intptr_c(handle, n, x, incx, y, incy) &
bind(C,name='cublasScopy_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT),value :: n
integer(kind=C_INT), intent(in), value :: incx,incy
integer(kind=C_intptr_T), value :: x, y
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_scopy_intptr_c
end interface
interface
subroutine cublas_scopy_cptr_c(handle, n, x, incx, y, incy) &
bind(C,name='cublasScopy_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT),value :: n
integer(kind=C_INT), intent(in), value :: incx,incy
type(c_ptr), value :: x, y
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_scopy_cptr_c
end interface
interface cublas_dtrmm
module procedure cublas_dtrmm_intptr
module procedure cublas_dtrmm_cptr
end interface
interface
subroutine cublas_dtrmm_intptr_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) &
bind(C,name='cublasDtrmm_elpa_wrapper') bind(C,name='cublasDtrmm_elpa_wrapper')
use, intrinsic :: iso_c_binding use, intrinsic :: iso_c_binding
...@@ -366,11 +500,34 @@ module cuda_functions ...@@ -366,11 +500,34 @@ module cuda_functions
integer(kind=C_intptr_T), value :: a, b integer(kind=C_intptr_T), value :: a, b
integer(kind=C_intptr_T), value :: handle integer(kind=C_intptr_T), value :: handle
end subroutine cublas_dtrmm_c end subroutine cublas_dtrmm_intptr_c
end interface end interface
interface interface
subroutine cublas_strmm_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) & subroutine cublas_dtrmm_cptr_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) &
bind(C,name='cublasDtrmm_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
character(1,C_CHAR),value :: side, uplo, trans, diag
integer(kind=C_INT),value :: m,n
integer(kind=C_INT), intent(in), value :: lda,ldb
real(kind=C_DOUBLE), value :: alpha
type(c_ptr), value :: a, b
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_dtrmm_cptr_c
end interface
interface cublas_strmm
module procedure cublas_strmm_intptr
module procedure cublas_strmm_cptr
end interface
interface
subroutine cublas_strmm_intptr_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) &
bind(C,name='cublasStrmm_elpa_wrapper') bind(C,name='cublasStrmm_elpa_wrapper')
use, intrinsic :: iso_c_binding use, intrinsic :: iso_c_binding
...@@ -383,9 +540,27 @@ module cuda_functions ...@@ -383,9 +540,27 @@ module cuda_functions
integer(kind=C_intptr_T), value :: a, b integer(kind=C_intptr_T), value :: a, b
integer(kind=C_intptr_T), value :: handle integer(kind=C_intptr_T), value :: handle
end subroutine cublas_strmm_c end subroutine cublas_strmm_intptr_c
end interface
interface
subroutine cublas_strmm_cptr_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) &
bind(C,name='cublasStrmm_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
character(1,C_CHAR),value :: side, uplo, trans, diag
integer(kind=C_INT),value :: m,n
integer(kind=C_INT), intent(in), value :: lda,ldb
real(kind=C_FLOAT), value :: alpha
type(c_ptr), value :: a, b
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_strmm_cptr_c
end interface end interface
interface interface
subroutine cublas_zgemm_c(handle, cta, ctb, m, n, k, alpha, a, lda, b, ldb, beta, c,ldc) & subroutine cublas_zgemm_c(handle, cta, ctb, m, n, k, alpha, a, lda, b, ldb, beta, c,ldc) &
bind(C,name='cublasZgemm_elpa_wrapper') bind(C,name='cublasZgemm_elpa_wrapper')
...@@ -420,8 +595,85 @@ module cuda_functions ...@@ -420,8 +595,85 @@ module cuda_functions
end subroutine cublas_cgemm_c end subroutine cublas_cgemm_c
end interface end interface
interface cublas_zcopy
module procedure cublas_zcopy_intptr
module procedure cublas_zcopy_cptr
end interface
interface
subroutine cublas_zcopy_intptr_c(handle, n, x, incx, y, incy) &
bind(C,name='cublasZcopy_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT),value :: n
integer(kind=C_INT), intent(in), value :: incx,incy
integer(kind=C_intptr_T), value :: x, y
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_zcopy_intptr_c
end interface
interface
subroutine cublas_zcopy_cptr_c(handle, n, x, incx, y, incy) &
bind(C,name='cublasZcopy_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT),value :: n
integer(kind=C_INT), intent(in), value :: incx,incy
type(c_ptr), value :: x, y
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_zcopy_cptr_c
end interface
interface cublas_ccopy
module procedure cublas_ccopy_intptr
module procedure cublas_ccopy_cptr
end interface
interface
subroutine cublas_ccopy_intptr_c(handle, n, x, incx, y, incy) &
bind(C,name='cublasCcopy_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT),value :: n
integer(kind=C_INT), intent(in), value :: incx,incy
integer(kind=C_intptr_T), value :: x, y
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_ccopy_intptr_c
end interface
interface interface
subroutine cublas_ztrmm_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) & subroutine cublas_ccopy_cptr_c(handle, n, x, incx, y, incy) &
bind(C,name='cublasCcopy_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT),value :: n
integer(kind=C_INT), intent(in), value :: incx,incy
type(c_ptr), value :: x, y
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_ccopy_cptr_c
end interface
interface cublas_ztrmm
module procedure cublas_ztrmm_intptr
module procedure cublas_ztrmm_cptr
end interface
interface
subroutine cublas_ztrmm_intptr_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) &
bind(C,name='cublasZtrmm_elpa_wrapper') bind(C,name='cublasZtrmm_elpa_wrapper')
use, intrinsic :: iso_c_binding use, intrinsic :: iso_c_binding
...@@ -434,11 +686,33 @@ module cuda_functions ...@@ -434,11 +686,33 @@ module cuda_functions
integer(kind=C_intptr_T), value :: a, b integer(kind=C_intptr_T), value :: a, b
integer(kind=C_intptr_T), value :: handle integer(kind=C_intptr_T), value :: handle
end subroutine cublas_ztrmm_c end subroutine cublas_ztrmm_intptr_c
end interface
interface
subroutine cublas_ztrmm_cptr_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) &
bind(C,name='cublasZtrmm_elpa_wrapper')
use, intrinsic :: iso_c_binding
implicit none
character(1,C_CHAR),value :: side, uplo, trans, diag
integer(kind=C_INT),value :: m,n
integer(kind=C_INT), intent(in), value :: lda,ldb
complex(kind=C_DOUBLE_COMPLEX), value :: alpha
type(c_ptr), value :: a, b
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_ztrmm_cptr_c
end interface
interface cublas_ctrmm
module procedure cublas_ctrmm_intptr
module procedure cublas_ctrmm_cptr
end interface end interface
interface interface
subroutine cublas_ctrmm_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) & subroutine cublas_ctrmm_intptr_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) &
bind(C,name='cublasCtrmm_elpa_wrapper') bind(C,name='cublasCtrmm_elpa_wrapper')
use, intrinsic :: iso_c_binding use, intrinsic :: iso_c_binding
...@@ -447,13 +721,31 @@ module cuda_functions ...@@ -447,13 +721,31 @@ module cuda_functions
character(1,C_CHAR),value :: side, uplo, trans, diag character(1,C_CHAR),value :: side, uplo, trans, diag
integer(kind=C_INT),value :: m,n integer(kind=C_INT),value :: m,n
integer(kind=C_INT), intent(in), value :: lda,ldb integer(kind=C_INT), intent(in), value :: lda,ldb
complex(kind=C_FLOAT_COMPLEX), value :: alpha complex(kind=C_FLOAT_COMPLEX), value :: alpha
integer(kind=C_intptr_T), value :: a, b integer(kind=C_intptr_T), value :: a, b
integer(kind=C_intptr_T), value :: handle integer(kind=C_intptr_T), value :: handle
end subroutine cublas_ctrmm_intptr_c
end interface
interface
subroutine cublas_ctrmm_cptr_c(handle, side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb) &
bind(C,name='cublasCtrmm_elpa_wrapper')
use, intrinsic :: iso_c_binding
end subroutine cublas_ctrmm_c implicit none
character(1,C_CHAR),value :: side, uplo, trans, diag
integer(kind=C_INT),value :: m,n
integer(kind=C_INT), intent(in), value :: lda,ldb
complex(kind=C_FLOAT_COMPLEX), value :: alpha
type(c_ptr), value :: a, b
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_ctrmm_cptr_c
end interface end interface
interface interface
subroutine cublas_dgemv_c(handle, cta, m, n, alpha, a, lda, x, incx, beta, y, incy) & subroutine cublas_dgemv_c(handle, cta, m, n, alpha, a, lda, x, incx, beta, y, incy) &
bind(C,name='cublasDgemv_elpa_wrapper') bind(C,name='cublasDgemv_elpa_wrapper')
...@@ -780,25 +1072,61 @@ module cuda_functions ...@@ -780,25 +1072,61 @@ module cuda_functions
#endif #endif
end function end function
function cuda_memcpy(dst, src, size, dir) result(success) function cuda_memcpy_intptr(dst, src, size, dir) result(success)
use, intrinsic :: iso_c_binding use, intrinsic :: iso_c_binding
implicit none implicit none
integer(kind=C_intptr_t) :: dst integer(kind=C_intptr_t) :: dst
integer(kind=C_intptr_t) :: src integer(kind=C_intptr_t) :: src
integer(kind=c_intptr_t), intent(in) :: size integer(kind=c_intptr_t), intent(in) :: size
integer(kind=C_INT), intent(in) :: dir integer(kind=C_INT), intent(in) :: dir
logical :: success logical :: success
#ifdef WITH_NVIDIA_GPU_VERSION #ifdef WITH_NVIDIA_GPU_VERSION
success = cuda_memcpy_c(dst, src, size, dir) /= 0 success = cuda_memcpy_intptr_c(dst, src, size, dir) /= 0
#else #else
success = .true. success = .true.
#endif #endif
end function end function
function cuda_memcpy2d(dst, dpitch, src, spitch, width, height , dir) result(success) function cuda_memcpy_cptr(dst, src, size, dir) result(success)
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr) :: dst
type(c_ptr) :: src
integer(kind=c_intptr_t), intent(in) :: size
integer(kind=C_INT), intent(in) :: dir
logical :: success
#ifdef WITH_NVIDIA_GPU_VERSION
success = cuda_memcpy_cptr_c(dst, src, size, dir) /= 0
#else
success = .true.
#endif
end function
function cuda_memcpy_mixed(dst, src, size, dir) result(success)
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr) :: dst
integer(kind=C_intptr_t) :: src
integer(kind=c_intptr_t), intent(in) :: size
integer(kind=C_INT), intent(in) :: dir
logical :: success
#ifdef WITH_NVIDIA_GPU_VERSION
success = cuda_memcpy_mixed_c(dst, src, size, dir) /= 0
#else
success = .true.
#endif