Skip to content

GitLab

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

Some GPU functions with type(c_ptr) interface

parent 685e9338
Hide whitespace changes
Inline Side-by-side
src/GPU/CUDA/cudaFunctions.cu
View file @ 5466e576
......@@ -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) {
cudaError_t cuerr = cudaMemcpy2D( dest, dpitch, src, spitch, width, height, (cudaMemcpyKind)dir);
if (cuerr != cudaSuccess) {
errormessage("Error in cudaMemcpy2d: %s\n",cudaGetErrorString(cuerr));
......@@ -435,6 +435,32 @@ extern "C" {
// 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
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,
int m, int n, double alpha, const double *A,
int lda, double *B, int ldb){
......
src/GPU/CUDA/mod_cuda.F90
View file @ 5466e576
......@@ -182,7 +182,7 @@ module cuda_functions
end 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")
use, intrinsic :: iso_c_binding
......@@ -194,11 +194,43 @@ module cuda_functions
integer(kind=C_INT), intent(in), value :: dir
integer(kind=C_INT) :: istat
end function cuda_memcpy_c
end function cuda_memcpy_intptr_c
end 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")
use, intrinsic :: iso_c_binding
......@@ -214,7 +246,27 @@ module cuda_functions
integer(kind=C_INT), intent(in), value :: dir
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
interface
......@@ -260,6 +312,12 @@ module cuda_functions
end function cuda_free_c
end interface
interface cuda_memcpy
module procedure cuda_memcpy_intptr
module procedure cuda_memcpy_cptr
module procedure cuda_memcpy_mixed
end interface
interface
function cuda_malloc_c(a, width_height) result(istat) &
bind(C, name="cudaMallocFromC")
......@@ -352,8 +410,84 @@ module cuda_functions
end subroutine cublas_sgemm_c
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
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')
use, intrinsic :: iso_c_binding
......@@ -366,11 +500,34 @@ module cuda_functions
integer(kind=C_intptr_T), value :: a, b
integer(kind=C_intptr_T), value :: handle
end subroutine cublas_dtrmm_c
end subroutine cublas_dtrmm_intptr_c
end 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')
use, intrinsic :: iso_c_binding
......@@ -383,9 +540,27 @@ module cuda_functions
integer(kind=C_intptr_T), value :: a, b
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
interface
subroutine cublas_zgemm_c(handle, cta, ctb, m, n, k, alpha, a, lda, b, ldb, beta, c,ldc) &
bind(C,name='cublasZgemm_elpa_wrapper')
......@@ -420,8 +595,85 @@ module cuda_functions
end subroutine cublas_cgemm_c
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
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')
use, intrinsic :: iso_c_binding
......@@ -434,11 +686,33 @@ module cuda_functions
integer(kind=C_intptr_T), value :: a, b
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
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')
use, intrinsic :: iso_c_binding
......@@ -447,13 +721,31 @@ module cuda_functions
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
complex(kind=C_FLOAT_COMPLEX), value :: alpha
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
interface
subroutine cublas_dgemv_c(handle, cta, m, n, alpha, a, lda, x, incx, beta, y, incy) &
bind(C,name='cublasDgemv_elpa_wrapper')
......@@ -780,25 +1072,61 @@ module cuda_functions
#endif
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
implicit none
integer(kind=C_intptr_t) :: dst
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
logical :: success
#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
success = .true.
#endif
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
end function
function cuda_memcpy2d_intptr(dst, dpitch, src, spitch, width, height , dir) result(success)
use, intrinsic :: iso_c_binding
......@@ -813,11 +1141,32 @@ module cuda_functions
integer(kind=C_INT), intent(in) :: dir
logical :: success
#ifdef WITH_NVIDIA_GPU_VERSION
success = cuda_memcpy2d_c(dst, dpitch, src, spitch, width, height , dir) /= 0
success = cuda_memcpy2d_intptr_c(dst, dpitch, src, spitch, width, height , dir) /= 0
#else
success = .true.
#endif
end function cuda_memcpy2d_intptr
function cuda_memcpy2d_cptr(dst, dpitch, src, spitch, width, height , dir) result(success)
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr) :: dst
integer(kind=c_intptr_t), intent(in) :: dpitch
type(c_ptr) :: src
integer(kind=c_intptr_t), intent(in) :: spitch
integer(kind=c_intptr_t), intent(in) :: width
integer(kind=c_intptr_t), intent(in) :: height
integer(kind=C_INT), intent(in) :: dir
logical :: success
#ifdef WITH_NVIDIA_GPU_VERSION
success = cuda_memcpy2d_cptr_c(dst, dpitch, src, spitch, width, height , dir) /= 0
#else
success = .true.
#endif
end function cuda_memcpy2d
end function cuda_memcpy2d_cptr
function cuda_host_register(a, size, flag) result(success)
......@@ -880,7 +1229,59 @@ module cuda_functions
#endif
end subroutine cublas_sgemm
subroutine cublas_dtrmm(side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb)
subroutine cublas_dcopy_intptr(n, x, incx, y, incy)
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT) :: n
integer(kind=C_INT), intent(in) :: incx, incy
integer(kind=C_intptr_T) :: x, y
#ifdef WITH_NVIDIA_GPU_VERSION
call cublas_dcopy_intptr_c(cublasHandle, n, x, incx, y, incy)
#endif
end subroutine cublas_dcopy_intptr
subroutine cublas_dcopy_cptr(n, x, incx, y, incy)
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT) :: n
integer(kind=C_INT), intent(in) :: incx, incy
type(c_ptr) :: x, y
#ifdef WITH_NVIDIA_GPU_VERSION
call cublas_dcopy_cptr_c(cublasHandle, n, x, incx, y, incy)
#endif
end subroutine cublas_dcopy_cptr
subroutine cublas_scopy_intptr(n, x, incx, y, incy)
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT) :: n
integer(kind=C_INT), intent(in) :: incx, incy
integer(kind=C_intptr_T) :: x, y