void CUDADeviceMixin<CUDAArrayT>::assign(Array *A, const Array *B) // A[n] <- B[n] { CUDAArrayT *a; const CUDAArrayT *b; const int N = cast(A, B, &a, &b); cublas_wrap::copy(N, b->ptr(), 1, a->ptr(), 1); if (cublasGetError() != CUBLAS_STATUS_SUCCESS) throw std::runtime_error("CUDADeviceMixin::assign: cublas copy returned error code"); }
void CUDADeviceMixin<CUDAArrayT>::add(Array *A, const Array *B, double scale) // A[n] <- B[n] * scale { CUDAArrayT *a; const CUDAArrayT *b; const int N = cast(A, B, &a, &b); cublas_wrap::axpy(N, scale, b->ptr(), 1, a->ptr(), 1); if (cublasGetError() != CUBLAS_STATUS_SUCCESS) throw std::runtime_error("CUDADeviceMixin::add: cublas saxpy returned error code"); }
static void GEMM (const Teuchos::ETransp transA, const Teuchos::ETransp transB, const float alpha, const View<const float**,LayoutLeft,Cuda>& A, const View<const float**,LayoutLeft,Cuda>& B, const float beta, const View<float**,LayoutLeft,Cuda>& C) { const int m = static_cast<int>(C.dimension_0()), n = static_cast<int>(C.dimension_1()), k = (transA == Teuchos::NO_TRANS ? A.dimension_1() : A.dimension_0()), lda = static_cast<int>(Impl::getStride2DView(A)), ldb = static_cast<int>(Impl::getStride2DView(B)), ldc = static_cast<int>(Impl::getStride2DView(C)); const char char_transA = (transA == Teuchos::NO_TRANS ? 'N' : 'T'), char_transB = (transB == Teuchos::NO_TRANS ? 'N' : 'T'); cublasSgemm (char_transA, char_transB, m, n, k, alpha, A.ptr_on_device(), lda, B.ptr_on_device(), ldb, beta, C.ptr_on_device(), ldc); #ifdef HAVE_KOKKOS_DEBUG const cublasStatus info = cublasGetError (); TEUCHOS_TEST_FOR_EXCEPTION (info != CUBLAS_STATUS_SUCCESS, std::runtime_error, "cublasSgemm failed with status " << info << "." ); #endif // HAVE_KOKKOS_DEBUG }
void CUDADeviceMixin<CUDAArrayT>::scale(Array *A, double factor) { CUDAArrayT *a; const int N = cast(A, &a); cublas_wrap::scal(N, factor, a->ptr(), 1); if (cublasGetError() != CUBLAS_STATUS_SUCCESS) throw std::runtime_error("CUDADeviceMixin::scale: cublas saxpy returned error code"); }
static int hasCublasError(const char * msg) { cublasStatus err = cublasGetError(); if(err != CUBLAS_STATUS_SUCCESS) error("cublas error : %s : %s\n", msg, cublasGetErrorString(err)); return 0; }
double CUDADeviceMixin<CUDAArrayT>::dot(const Array *A, const Array *B) { const CUDAArrayT *a, *b; const int N = cast(A, B, &a, &b); const double dot = cublas_wrap::dot(N, b->ptr(), 1, a->ptr(), 1); if (cublasGetError() != CUBLAS_STATUS_SUCCESS) throw std::runtime_error("CUDADeviceMixin::dot: cublas dot returned error code"); return dot; }
CAMLprim value spoc_cublasIsamin(value n, value x, value incx, value dev){ CAMLparam4(n,x,incx, dev); CAMLlocal3(dev_vec_array, dev_vec, gi); int res; int id; CUdeviceptr d_A; GET_VEC(x, d_A); CUBLAS_GET_CONTEXT; res = cublasIsamin(Int_val(n), (float*)d_A, Int_val(incx)); CUBLAS_CHECK_CALL(cublasGetError()); CUDA_RESTORE_CONTEXT; CAMLreturn(Val_int(res)); }
CAMLprim value spoc_cublasSscal (value n, value alpha, value x, value incx, value dev){ CAMLparam5(n, alpha, x,incx, dev); CAMLlocal3(dev_vec_array, dev_vec, gi); CUdeviceptr d_A; int id; GET_VEC(x, d_A); CUBLAS_GET_CONTEXT; cublasSscal(Int_val(n), (float)(Double_val(alpha)), (float*)d_A, Int_val(incx)); CUBLAS_CHECK_CALL(cublasGetError()); CUDA_RESTORE_CONTEXT; CAMLreturn(Val_unit); }
CAMLprim value spoc_cublasSnrm2 (value n, value x, value incx, value dev){ CAMLparam4(n,x,incx, dev); CAMLlocal4(dev_vec_array, dev_vec, res, gi); CUdeviceptr d_A; int id; float result; GET_VEC(x, d_A); CUBLAS_GET_CONTEXT; result = cublasSnrm2(Int_val(n), (float*)d_A, Int_val(incx)); CUBLAS_CHECK_CALL(cublasGetError()); res = caml_copy_double((double)result); CUDA_RESTORE_CONTEXT; CAMLreturn((res)); }
CAMLprim value spoc_cublasScopy (value n, value x, value incx, value y, value incy, value dev){ CAMLparam5(n,x,incx, y, incy); CAMLxparam1(dev); CAMLlocal3(dev_vec_array, dev_vec, gi); int id; CUdeviceptr d_A; CUdeviceptr d_B; GET_VEC(x, d_A); GET_VEC(y, d_B); CUBLAS_GET_CONTEXT; cublasScopy(Int_val(n), (float*)d_A, Int_val(incx), (float*)d_B, Int_val(incy)); CUBLAS_CHECK_CALL(cublasGetError()); CUDA_RESTORE_CONTEXT; CAMLreturn(Val_unit); }
CAMLprim value spoc_cublasCaxpy (value n, value alpha, value x, value incx, value y, value incy, value dev){ CAMLparam5(n,alpha, x,incx, y); CAMLxparam2(incy, dev); CAMLlocal3(dev_vec_array, dev_vec, gi); CUdeviceptr d_A; CUdeviceptr d_B; int id; GET_VEC(x, d_A); GET_VEC(y, d_B); CUBLAS_GET_CONTEXT; cublasCaxpy(Int_val(n), Complex_val(alpha), (cuComplex*)d_A, Int_val(incx), (cuComplex*)d_B, Int_val(incy)); CUBLAS_CHECK_CALL(cublasGetError()); CUDA_RESTORE_CONTEXT; CAMLreturn(Val_unit); }
CAMLprim value spoc_cublasSrot (value n, value x, value incx, value y, value incy, value sc, value ss, value dev){ CAMLparam5(n,x,incx, y, incy); CAMLxparam3(sc, ss, dev); CAMLlocal4(dev_vec_array, dev_vec, res, gi); int id; CUdeviceptr d_A; CUdeviceptr d_B; float result; GET_VEC(x, d_A); GET_VEC(y, d_B); CUBLAS_GET_CONTEXT; cublasSrot(Int_val(n), (float*)d_A, Int_val(incx), (float*)d_B, Int_val(incy), (float)(Double_val(sc)), (float)(Double_val(ss))); CUBLAS_CHECK_CALL(cublasGetError()); CUDA_RESTORE_CONTEXT; CAMLreturn(Val_unit); }
CAMLprim value spoc_cublasSrotm (value n, value x, value incx, value y, value incy, value sparam, value dev){ CAMLparam5(n,x,incx, y, incy); CAMLxparam2(sparam, dev); CAMLlocal4(dev_vec_array, dev_vec, res, gi); CUdeviceptr d_A; CUdeviceptr d_B; CUdeviceptr d_C; float result; int id; GET_VEC(x, d_A); GET_VEC(y, d_B); GET_VEC(sparam, d_C); CUBLAS_GET_CONTEXT; cublasSrotm(Int_val(n), (float*)d_A, Int_val(incx), (float*)d_B, Int_val(incy), (float*)sparam); CUBLAS_CHECK_CALL(cublasGetError()); CUBLAS_RESTORE_CONTEXT; CAMLreturn(Val_unit); }
CAMLprim value spoc_cublasSrotg (value host_sa, value host_sb, value host_sc, value host_ss){ CAMLparam4(host_sa, host_sb, host_sc, host_ss); CAMLlocal2(bigArray, gi); int id; enum cudaError_enum cuda_error = 0; cublasStatus cublas_error = CUBLAS_STATUS_SUCCESS; float* h_A; float* h_B; float* h_C; float* h_D; float result; GET_HOST_VEC(host_sa, h_A); GET_HOST_VEC(host_sb, h_B); GET_HOST_VEC(host_sc, h_C); GET_HOST_VEC(host_ss, h_D); cublasSrotg(h_A, h_B, h_C, h_D); CUBLAS_CHECK_CALL(cublasGetError()); CAMLreturn(Val_unit); }
static inline void dw_common_cpu_codelet_update_u22(void *descr[], int s, STARPU_ATTRIBUTE_UNUSED void *_args) { float *left = (float *)STARPU_MATRIX_GET_PTR(descr[0]); float *right = (float *)STARPU_MATRIX_GET_PTR(descr[1]); float *center = (float *)STARPU_MATRIX_GET_PTR(descr[2]); unsigned dx = STARPU_MATRIX_GET_NX(descr[2]); unsigned dy = STARPU_MATRIX_GET_NY(descr[2]); unsigned dz = STARPU_MATRIX_GET_NY(descr[0]); unsigned ld12 = STARPU_MATRIX_GET_LD(descr[0]); unsigned ld21 = STARPU_MATRIX_GET_LD(descr[1]); unsigned ld22 = STARPU_MATRIX_GET_LD(descr[2]); #ifdef STARPU_USE_CUDA cublasStatus status; #endif switch (s) { case 0: STARPU_SGEMM("N", "N", dy, dx, dz, -1.0f, left, ld21, right, ld12, 1.0f, center, ld22); break; #ifdef STARPU_USE_CUDA case 1: cublasSgemm('n', 'n', dx, dy, dz, -1.0f, left, ld21, right, ld12, 1.0f, center, ld22); status = cublasGetError(); if (status != CUBLAS_STATUS_SUCCESS) STARPU_CUBLAS_REPORT_ERROR(status); break; #endif default: STARPU_ABORT(); break; } }
static inline void dw_common_codelet_update_u12(void *descr[], int s, STARPU_ATTRIBUTE_UNUSED void *_args) { float *sub11; float *sub12; sub11 = (float *)STARPU_MATRIX_GET_PTR(descr[0]); sub12 = (float *)STARPU_MATRIX_GET_PTR(descr[1]); unsigned ld11 = STARPU_MATRIX_GET_LD(descr[0]); unsigned ld12 = STARPU_MATRIX_GET_LD(descr[1]); unsigned nx12 = STARPU_MATRIX_GET_NX(descr[1]); unsigned ny12 = STARPU_MATRIX_GET_NY(descr[1]); #ifdef STARPU_USE_CUDA cublasStatus status; #endif /* solve L11 U12 = A12 (find U12) */ switch (s) { case 0: STARPU_STRSM("L", "L", "N", "N", nx12, ny12, 1.0f, sub11, ld11, sub12, ld12); break; #ifdef STARPU_USE_CUDA case 1: cublasStrsm('L', 'L', 'N', 'N', ny12, nx12, 1.0f, sub11, ld11, sub12, ld12); status = cublasGetError(); if (status != CUBLAS_STATUS_SUCCESS) STARPU_CUBLAS_REPORT_ERROR(status); break; #endif default: STARPU_ABORT(); break; } }
CAMLprim value spoc_cublasSrotmg (value host_psd1, value host_psd2, value host_psx1, value host_psy1, value host_sparam){ CAMLparam5(host_psd1, host_psd2, host_psx1, host_psy1, host_sparam); CAMLlocal2(bigArray, gi); int id; enum cudaError_enum cuda_error = 0; cublasStatus cublas_error = CUBLAS_STATUS_SUCCESS; float* h_A; float* h_B; float* h_C; float* h_D; float* h_E; GET_HOST_VEC(host_psd1, h_A); GET_HOST_VEC(host_psd2, h_B); GET_HOST_VEC(host_psx1, h_C); GET_HOST_VEC(host_psy1, h_D); GET_HOST_VEC(host_sparam, h_E); CUBLAS_GET_CONTEXT; cublasSrotmg(h_A, h_B, h_C, h_D, h_E); CUBLAS_CHECK_CALL(cublasGetError()); CUBLAS_RESTORE_CONTEXT; CAMLreturn(Val_unit); }
static inline void dw_common_codelet_update_u21(void *descr[], int s, STARPU_ATTRIBUTE_UNUSED void *_args) { float *sub11; float *sub21; sub11 = (float *)STARPU_MATRIX_GET_PTR(descr[0]); sub21 = (float *)STARPU_MATRIX_GET_PTR(descr[1]); unsigned ld11 = STARPU_MATRIX_GET_LD(descr[0]); unsigned ld21 = STARPU_MATRIX_GET_LD(descr[1]); unsigned nx21 = STARPU_MATRIX_GET_NX(descr[1]); unsigned ny21 = STARPU_MATRIX_GET_NY(descr[1]); #ifdef STARPU_USE_CUDA cublasStatus status; #endif switch (s) { case 0: STARPU_STRSM("R", "U", "N", "U", nx21, ny21, 1.0f, sub11, ld11, sub21, ld21); break; #ifdef STARPU_USE_CUDA case 1: cublasStrsm('R', 'U', 'N', 'U', ny21, nx21, 1.0f, sub11, ld11, sub21, ld21); status = cublasGetError(); if (status != CUBLAS_STATUS_SUCCESS) STARPU_CUBLAS_REPORT_ERROR(status); break; #endif default: STARPU_ABORT(); break; } }
SEXP magma_dpoMatrix_matrix_solve(SEXP a, SEXP b) { #ifdef HIPLAR_WITH_MAGMA SEXP Chol = magma_dpoMatrix_chol(a), val = PROTECT(duplicate(b)); int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)), *bdims = INTEGER(getAttrib(b, R_DimSymbol)), info; if (!(isReal(b) && isMatrix(b))) error(_("Argument b must be a numeric matrix")); if (*adims != *bdims || bdims[1] < 1 || *adims < 1) error(_("Dimensions of system to be solved are inconsistent")); double *A = REAL(GET_SLOT(Chol, Matrix_xSym)); double *B = REAL(val); //const char *uplo = uplo_P(Chol); //int N = bdims[1]; //There is only a GPU interface for this call //so it will be the default setting if the GPU is on if(GPUFlag == 1) { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Solving system of Ax = b, A = dpo, b = dge, using dpotrs_gpu;"); #endif double *d_A, *d_B; const char *uplo = uplo_P(Chol); magma_int_t NRHS = bdims[1]; magma_int_t lda = adims[1]; magma_int_t ldb = bdims[0]; magma_int_t N = adims[0]; cublasStatus retStatus; cublasAlloc(N * lda, sizeof(double), (void**)&d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(N * NRHS, sizeof(double), (void**)&d_B); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector( N * lda , sizeof(double), A, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ cublasSetVector( ldb * NRHS, sizeof(double), B, 1, d_B, 1 ); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ magma_dpotrs_gpu(uplo[0], N, NRHS , d_A, lda, d_B, ldb, &info); cublasGetVector( ldb * NRHS, sizeof(double), d_B, 1, B, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer from Device")); /********************************************/ cublasFree(d_A); cublasFree(d_B); } else { F77_CALL(dpotrs)(uplo_P(Chol), adims, bdims + 1, REAL(GET_SLOT(Chol, Matrix_xSym)), adims, REAL(val), bdims, &info); } // Error checking of MAGMA/LAPACK calls if (info) { if(info > 0) error(_("the leading minor of order %d is not positive definite"), info); else /* should never happen! */ error(_("Lapack routine %s returned error code %d"), "dpotrf", info); } UNPROTECT(1); return val; #endif return R_NilValue; }
SEXP magma_dgeMatrix_matrix_mm(SEXP a, SEXP bP, SEXP right) { #ifdef HIPLAR_WITH_MAGMA SEXP b = PROTECT(mMatrix_as_dgeMatrix(bP)), val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))); int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)), *bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)), *cdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2)); double one = 1.0, zero = 0.0; if (asLogical(right)) { int m = bdims[0], n = adims[1], k = bdims[1]; if (adims[0] != k) error(_("Matrices are not conformable for multiplication")); cdims[0] = m; cdims[1] = n; if (m < 1 || n < 1 || k < 1) { // This was commented out error(_("Matrices with zero extents cannot be multiplied")); ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n); } else { double *B = REAL(GET_SLOT(b, Matrix_xSym)); double *A = REAL(GET_SLOT(a, Matrix_xSym)); double *C = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n)); //TODO add magma here too if(GPUFlag == 1) { double *d_A, *d_B, *d_C; cublasStatus retStatus; #ifdef HIPLAR_DBG R_ShowMessage("DBG: Performing matrix multiplication with Right = true using magmablas_dgemm"); #endif cublasAlloc(n * k, sizeof(double), (void**)&d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(m * k, sizeof(double), (void**)&d_B); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(m * n, sizeof(double), (void**)&d_C); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector( n * k , sizeof(double), A, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ cublasSetVector( m * k, sizeof(double), B, 1, d_B, 1 ); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ // ******** magmablas_dgemm call Here ** //magmablas_dgemm('N', 'N', m, n, k, one, d_B, m, d_A, k, zero, d_C, m); //CHANGED 30/07 cublasDgemm('N', 'N', m, n, k, one, d_B, m, d_A, k, zero, d_C, m); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) { error(_("CUBLAS: Error in cublasDgemm routine")); } /********************************************/ cublasGetVector( m * n , sizeof(double), d_C, 1, C, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer from Device")); /********************************************/ cublasFree(d_A); cublasFree(d_B); cublasFree(d_C); } else { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Performing matrix multiplication using dgemm with right = TRUE"); #endif F77_CALL(dgemm) ("N", "N", &m, &n, &k, &one, B, &m, A , &k, &zero, C , &m); } } } else { int m = adims[0], n = bdims[1], k = adims[1]; double *A = REAL(GET_SLOT(a, Matrix_xSym)); double *B = REAL(GET_SLOT(b, Matrix_xSym)); if (bdims[0] != k) error(_("Matrices are not conformable for multiplication")); cdims[0] = m; cdims[1] = n; double *C = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n)); if (m < 1 || n < 1 || k < 1) { // This was commented out error(_("Matrices with zero extents cannot be multiplied")); ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n); } else { if(GPUFlag == 1) { double *d_A, *d_B, *d_C; cublasStatus retStatus; #ifdef HIPLAR_DBG R_ShowMessage("DBG: Performing matrix multiplication using magmablas_dgemm"); #endif cublasAlloc(m * k, sizeof(double), (void**)&d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(n * k, sizeof(double), (void**)&d_B); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(m * n, sizeof(double), (void**)&d_C); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector( m * k , sizeof(double), A, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ cublasSetVector( n * k, sizeof(double), B, 1, d_B, 1 ); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ // ******** magmablas_dgemm call Here ** //magmablas_dgemm('N', 'N', m, n, k, one, d_A, m, d_B, k, zero, d_C, m); //CHANGE cublasDgemm('N', 'N', m, n, k, one, d_A, m, d_B, k, zero, d_C, m); retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) { error(_("CUBLAS: Error in Data Transfer from Device")); /********************************************/ } cublasGetVector( m * n , sizeof(double), d_C, 1, C, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer from Device")); /********************************************/ cublasFree(d_A); cublasFree(d_B); cublasFree(d_C); } else { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Performing matrix multiplication using dgemm"); #endif F77_CALL(dgemm) ("N", "N", &m, &n, &k, &one, A, &m, B, &k, &zero, C, &m); } } } ALLOC_SLOT(val, Matrix_DimNamesSym, VECSXP, 2); UNPROTECT(2); return val; #endif return R_NilValue; }
SEXP magma_dgeMatrix_crossprod(SEXP x, SEXP trans) { #ifdef HIPLAR_WITH_MAGMA int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x) */ SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dpoMatrix"))), nms = VECTOR_ELT(GET_SLOT(x, Matrix_DimNamesSym), tr ? 0 : 1), vDnms = ALLOC_SLOT(val, Matrix_DimNamesSym, VECSXP, 2); int *Dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), *vDims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2)); int k = tr ? Dims[1] : Dims[0], n = tr ? Dims[0] : Dims[1]; double *vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n)), one = 1.0, zero = 0.0; double *A = REAL(GET_SLOT(x, Matrix_xSym)); AZERO(vx, n * n); SET_SLOT(val, Matrix_uploSym, mkString("U")); ALLOC_SLOT(val, Matrix_factorSym, VECSXP, 0); vDims[0] = vDims[1] = n; SET_VECTOR_ELT(vDnms, 0, duplicate(nms)); SET_VECTOR_ELT(vDnms, 1, duplicate(nms)); if(n && GPUFlag == 1) { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Performing crossproduct using cublasDsyrk"); #endif cublasStatus retStatus; double *d_A, *d_C; /*retStatus = cublasCreate(&handle); if ( retStatus != CUBLAS_STATUS_SUCCESS ) error(_("CUBLAS initialisation failed")); */ cublasAlloc(n * k, sizeof(double), (void**)&d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(n * n, sizeof(double), (void**)&d_C); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector( n * k , sizeof(double), A, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ //cublasSetVector( n * n , sizeof(double), vx, 1, d_C, 1); /* Error Checking */ //retStatus = cublasGetError (); //if (retStatus != CUBLAS_STATUS_SUCCESS) // error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ cublasDsyrk('U' , tr ? 'N' : 'T', n, k, one, d_A, Dims[0], zero, d_C, n); cublasGetVector( n * n , sizeof(double), d_C, 1, vx, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer from Device")); /********************************************/ cublasFree(d_A); cublasFree(d_C); } else if(n){ #ifdef HIPLAR_DBG R_ShowMessage("DBG: Performing cross prod with dsyrk"); #endif F77_CALL(dsyrk)("U", tr ? "N" : "T", &n, &k, &one, A, Dims, &zero, vx, &n); } SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0)); UNPROTECT(1); return val; #endif return R_NilValue; }
SEXP magma_dgeMatrix_matrix_crossprod(SEXP x, SEXP y, SEXP trans) { #ifdef HIPLAR_WITH_MAGMA int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x,y) */ SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))); int *xDims = INTEGER(GET_SLOT(x, Matrix_DimSym)), *yDims = INTEGER(getAttrib(y, R_DimSymbol)), *vDims, nprot = 1; int m = xDims[!tr], n = yDims[!tr];/* -> result dim */ int xd = xDims[ tr], yd = yDims[ tr];/* the conformable dims */ double one = 1.0, zero = 0.0; if (isInteger(y)) { y = PROTECT(coerceVector(y, REALSXP)); nprot++; } if (!(isMatrix(y) && isReal(y))) error(_("Argument y must be a numeric matrix")); SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0)); SET_SLOT(val, Matrix_DimSym, allocVector(INTSXP, 2)); vDims = INTEGER(GET_SLOT(val, Matrix_DimSym)); if (xd > 0 && yd > 0 && n > 0 && m > 0) { if (xd != yd) error(_("Dimensions of x and y are not compatible for %s"), tr ? "tcrossprod" : "crossprod"); vDims[0] = m; vDims[1] = n; SET_SLOT(val, Matrix_xSym, allocVector(REALSXP, m * n)); double *A = REAL(GET_SLOT(x, Matrix_xSym)); double *B = REAL(y); double *C = REAL(GET_SLOT(val, Matrix_xSym)); if(GPUFlag == 1) { double *d_A, *d_B, *d_C; cublasStatus retStatus; #ifdef HIPLAR_DBG R_ShowMessage("DBG: Performing dge/matrix crossprod using magmablas_dgemm"); #endif cublasAlloc(m * xd, sizeof(double), (void**)&d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(n * xd, sizeof(double), (void**)&d_B); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(m * n, sizeof(double), (void**)&d_C); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector( m * xd , sizeof(double), A, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ cublasSetVector( xd * n, sizeof(double), B, 1, d_B, 1 ); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ cublasSetVector( m * n, sizeof(double), C, 1, d_C, 1 ); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ // ******** magmablas_dgemm call Here ** //magmablas_dgemm( tr ? 'N' : 'T', tr ? 'T' : 'N', m, n, xd, one, d_A, xDims[0], d_B, yDims[0], zero, d_C, m); //CHANGE cublasDgemm( tr ? 'N' : 'T', tr ? 'T' : 'N', m, n, xd, one, d_A, xDims[0], d_B, yDims[0], zero, d_C, m); cublasGetVector( m * n , sizeof(double), d_C, 1, C, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer from Device")); /********************************************/ cublasFree(d_A); cublasFree(d_B); cublasFree(d_C); } else { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Performing dge/matrix cross prod with dgemm"); #endif F77_CALL(dgemm)(tr ? "N" : "T", tr ? "T" : "N", &m, &n, &xd, &one, A , xDims, B , yDims, &zero, C, &m); } } UNPROTECT(nprot); return val; #endif return R_NilValue; }
SEXP magma_dgeMatrix_LU_(SEXP x, Rboolean warn_sing) { #ifdef HIPLAR_WITH_MAGMA SEXP val = get_factors(x, "LU"); int *dims, npiv, info; if (val != R_NilValue) { // R_ShowMessage("already in slot"); /* nothing to do if it's there in 'factors' slot */ return val; } dims = INTEGER(GET_SLOT(x, Matrix_DimSym)); if (dims[0] < 1 || dims[1] < 1) error(_("Cannot factor a matrix with zero extents")); npiv = (dims[0] < dims[1]) ? dims[0] : dims[1]; val = PROTECT(NEW_OBJECT(MAKE_CLASS("denseLU"))); slot_dup(val, x, Matrix_xSym); slot_dup(val, x, Matrix_DimSym); double *h_R = REAL(GET_SLOT(val, Matrix_xSym)); int *ipiv = INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, npiv)); if(GPUFlag == 0){ #ifdef HIPLAR_DBG R_ShowMessage("DBG: LU decomposition using dgetrf;"); #endif F77_CALL(dgetrf)(dims, dims + 1, h_R, dims, ipiv, &info); } else if(GPUFlag == 1 && Interface == 0){ #ifdef HIPLAR_DBG R_ShowMessage("DBG: LU decomposition using magma_dgetrf;"); #endif magma_dgetrf(dims[0], dims[1], h_R, dims[0], ipiv, &info); } else if(GPUFlag == 1 && Interface == 1) { #ifdef HIPLAR_DBG R_ShowMessage("DBG: LU decomposition using magma_dgetrf_gpu;"); #endif double *d_A; int N2 = dims[0] * dims[1]; cublasStatus retStatus; cublasAlloc( N2 , sizeof(double), (void**)&d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector(N2, sizeof(double), h_R, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Date Transfer to Device")); /********************************************/ magma_dgetrf_gpu(dims[0],dims[1], d_A, dims[0], ipiv, &info); cublasGetVector( N2, sizeof(double), d_A, 1, h_R, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Date Transfer from Device")); /********************************************/ cublasFree(d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error freeing data")); /********************************************/ } else error(_("MAGMA/LAPACK/Interface Flag not defined correctly")); if (info < 0) error(_("Lapack routine %s returned error code %d"), "dgetrf", info); else if (info > 0 && warn_sing) warning(_("Exact singularity detected during LU decomposition: %s, i=%d."), "U[i,i]=0", info); UNPROTECT(1); return set_factors(x, val, "LU"); #endif return R_NilValue; }
/* Main */ int test_cublas(void) { cublasStatus status; cudaError_t e; float* h_A; float* h_B; float* h_C; float* h_C_ref; float* d_A = 0; void *vp; float* d_B = 0; float* d_C = 0; float alpha = 1.0f; float beta = 0.0f; int n2 = N * N; int i; float error_norm; float ref_norm; float diff; /* Initialize CUBLAS */ printf("simpleCUBLAS test running..\n"); status = cublasInit(); if (status != CUBLAS_STATUS_SUCCESS) { fprintf (stderr, "!!!! CUBLAS initialization error\n"); return EXIT_FAILURE; } /* Allocate host memory for the matrices */ h_A = (float*)malloc(n2 * sizeof(h_A[0])); if (h_A == 0) { fprintf (stderr, "!!!! host memory allocation error (A)\n"); return EXIT_FAILURE; } h_B = (float*)malloc(n2 * sizeof(h_B[0])); if (h_B == 0) { fprintf (stderr, "!!!! host memory allocation error (B)\n"); return EXIT_FAILURE; } h_C = (float*)malloc(n2 * sizeof(h_C[0])); if (h_C == 0) { fprintf (stderr, "!!!! host memory allocation error (C)\n"); return EXIT_FAILURE; } /* Fill the matrices with test data */ for (i = 0; i < n2; i++) { h_A[i] = rand() / (float)RAND_MAX; h_B[i] = rand() / (float)RAND_MAX; h_C[i] = rand() / (float)RAND_MAX; } /* Allocate device memory for the matrices */ if (cudaMalloc(&vp, n2 * sizeof(d_A[0])) != cudaSuccess) { fprintf (stderr, "!!!! device memory allocation error (A)\n"); return EXIT_FAILURE; } d_A = (float *) vp; if (cudaMalloc(&vp, n2 * sizeof(d_B[0])) != cudaSuccess) { fprintf (stderr, "!!!! device memory allocation error (B)\n"); return EXIT_FAILURE; } d_B = (float *) vp; if (cudaMalloc(&vp, n2 * sizeof(d_C[0])) != cudaSuccess) { fprintf (stderr, "!!!! device memory allocation error (C)\n"); return EXIT_FAILURE; } d_C = (float *) vp; /* Initialize the device matrices with the host matrices */ status = cublasSetVector(n2, sizeof(h_A[0]), h_A, 1, d_A, 1); if (status != CUBLAS_STATUS_SUCCESS) { fprintf (stderr, "!!!! device access error (write A)\n"); return EXIT_FAILURE; } status = cublasSetVector(n2, sizeof(h_B[0]), h_B, 1, d_B, 1); if (status != CUBLAS_STATUS_SUCCESS) { fprintf (stderr, "!!!! device access error (write B)\n"); return EXIT_FAILURE; } status = cublasSetVector(n2, sizeof(h_C[0]), h_C, 1, d_C, 1); if (status != CUBLAS_STATUS_SUCCESS) { fprintf (stderr, "!!!! device access error (write C)\n"); return EXIT_FAILURE; } /* Performs operation using plain C code */ simple_sgemm(N, alpha, h_A, h_B, beta, h_C); h_C_ref = h_C; /* Clear last error */ cublasGetError(); /* Performs operation using cublas */ cublasSgemm('n', 'n', N, N, N, alpha, d_A, N, d_B, N, beta, d_C, N); status = cublasGetError(); if (status != CUBLAS_STATUS_SUCCESS) { fprintf (stderr, "!!!! kernel execution error.\n"); return EXIT_FAILURE; } /* Allocate host memory for reading back the result from device memory */ h_C = (float*)malloc(n2 * sizeof(h_C[0])); if (h_C == 0) { fprintf (stderr, "!!!! host memory allocation error (C)\n"); return EXIT_FAILURE; } /* Read the result back */ status = cublasGetVector(n2, sizeof(h_C[0]), d_C, 1, h_C, 1); if (status != CUBLAS_STATUS_SUCCESS) { fprintf (stderr, "!!!! device access error (read C)\n"); return EXIT_FAILURE; } /* Check result against reference */ error_norm = 0; ref_norm = 0; for (i = 0; i < n2; ++i) { diff = h_C_ref[i] - h_C[i]; error_norm += diff * diff; ref_norm += h_C_ref[i] * h_C_ref[i]; } error_norm = (float)sqrt((double)error_norm); ref_norm = (float)sqrt((double)ref_norm); if (fabs(ref_norm) < 1e-7) { fprintf (stderr, "!!!! reference norm is 0\n"); return EXIT_FAILURE; } printf( "Test %s\n", (error_norm / ref_norm < 1e-6f) ? "PASSED" : "FAILED"); /* Memory clean up */ free(h_A); free(h_B); free(h_C); free(h_C_ref); e = cudaFree(d_A); if (e != cudaSuccess) { fprintf (stderr, "!!!! memory free error (A)\n"); return EXIT_FAILURE; } e = cudaFree(d_B); if (e != cudaSuccess) { fprintf (stderr, "!!!! memory free error (B)\n"); return EXIT_FAILURE; } e = cudaFree(d_C); if (e != cudaSuccess) { fprintf (stderr, "!!!! memory free error (C)\n"); return EXIT_FAILURE; } /* Shutdown */ status = cublasShutdown(); if (status != CUBLAS_STATUS_SUCCESS) { fprintf (stderr, "!!!! shutdown error (A)\n"); return EXIT_FAILURE; } return EXIT_SUCCESS; }
SEXP magma_dgeMatrix_matrix_solve(SEXP a, SEXP b) { #ifdef HIPLAR_WITH_MAGMA SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b)), lu = PROTECT(magma_dgeMatrix_LU_(a, TRUE)); int *adims = INTEGER(GET_SLOT(lu, Matrix_DimSym)), *bdims = INTEGER(GET_SLOT(val, Matrix_DimSym)); int info, n = bdims[0], nrhs = bdims[1]; if (*adims != *bdims || bdims[1] < 1 || *adims < 1 || *adims != adims[1]) error(_("Dimensions of system to be solved are inconsistent")); double *A = REAL(GET_SLOT(lu, Matrix_xSym)); double *B = REAL(GET_SLOT(val, Matrix_xSym)); int *ipiv = INTEGER(GET_SLOT(lu, Matrix_permSym)); if(GPUFlag == 0) { F77_CALL(dgetrs)("N", &n, &nrhs, A, &n, ipiv, B, &n, &info); #ifdef HIPLAR_DBG R_ShowMessage("DBG: Solve using LU using dgetrs;"); #endif }else if(GPUFlag == 1) { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Solve using LU using magma_dgetrs;"); #endif double *d_A, *d_B; cublasStatus retStatus; cublasAlloc(adims[0] * adims[1], sizeof(double), (void**)&d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation of A on Device")); /********************************************/ cublasAlloc(n * nrhs, sizeof(double), (void**)&d_B); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation of b on Device")); /********************************************/ cublasSetVector(adims[0] * adims[1], sizeof(double), A, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Transferring data to advice")); /********************************************/ cublasSetVector(n * nrhs, sizeof(double), B, 1, d_B, 1); magma_dgetrs_gpu( 'N', n, nrhs, d_A, n, ipiv, d_B, n, &info ); cublasGetVector(n * nrhs, sizeof(double), d_B, 1, B, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Transferring from to advice")); /********************************************/ cublasFree(d_A); cublasFree(d_B); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in freeing data")); /********************************************/ } if (info) error(_("Lapack routine dgetrs: system is exactly singular")); UNPROTECT(2); return val; #endif return R_NilValue; }
SEXP magma_dpoMatrix_chol(SEXP x) { #ifdef HIPLAR_WITH_MAGMA SEXP val = get_factors(x, "Cholesky"), dimP = GET_SLOT(x, Matrix_DimSym), uploP = GET_SLOT(x, Matrix_uploSym); const char *uplo = CHAR(STRING_ELT(uploP, 0)); int *dims = INTEGER(dimP), info; int n = dims[0]; double *vx; cublasStatus retStatus; if (val != R_NilValue) return val; dims = INTEGER(dimP); val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky"))); SET_SLOT(val, Matrix_uploSym, duplicate(uploP)); SET_SLOT(val, Matrix_diagSym, mkString("N")); SET_SLOT(val, Matrix_DimSym, duplicate(dimP)); vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n)); AZERO(vx, n * n); //we could put in magmablas_dlacpy but it only //copies all of the matrix F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n); if (n > 0) { if(GPUFlag == 0){ #ifdef HIPLAR_DBG R_ShowMessage("DBG: Cholesky decomposition using dpotrf;"); #endif F77_CALL(dpotrf)(uplo, &n, vx, &n, &info); } else if(GPUFlag == 1 && Interface == 0){ #ifdef HIPLAR_DBG R_ShowMessage("DBG: Cholesky decomposition using magma_dpotrf;"); #endif int nrows, ncols; nrows = ncols = n; magma_int_t lda; lda = nrows; magma_dpotrf(uplo[0], ncols, vx, lda, &info); /* Error Checking */ retStatus = cudaGetLastError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in magma_dpotrf")); /********************************************/ } else if(GPUFlag == 1 && Interface == 1) { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Cholesky decomposition using magma_dpotrf_gpu;"); #endif double *d_c; int nrows, ncols; nrows = ncols = n; int N2 = nrows * ncols; magma_int_t lda; lda = nrows; cublasAlloc(lda * ncols, sizeof(double), (void**)&d_c); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector(N2, sizeof(double), vx, 1, d_c, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Date Transfer to Device")); /********************************************/ magma_dpotrf_gpu(uplo[0], ncols, d_c, lda, &info); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in magma_dpotrf_gpu")); /********************************************/ cublasGetVector(nrows * ncols, sizeof(double), d_c, 1, vx, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Date Transfer from Device")); /********************************************/ cublasFree(d_c); } else error(_("MAGMA/LAPACK/Interface Flag not defined correctly")); } if (info) { if(info > 0) error(_("the leading minor of order %d is not positive definite"), info); else /* should never happen! */ error(_("Lapack routine %s returned error code %d"), "dpotrf", info); } UNPROTECT(1); return set_factors(x, val, "Cholesky"); #endif return R_NilValue; }
SEXP magma_dpoMatrix_dgeMatrix_solve(SEXP a, SEXP b) { #ifdef HIPLAR_WITH_MAGMA SEXP Chol = magma_dpoMatrix_chol(a), val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))); int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)), *bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)), info; /* Checking Matrix Dimensions */ if (adims[1] != bdims[0]) error(_("Dimensions of system to be solved are inconsistent")); if (adims[0] < 1 || bdims[1] < 1) error(_("Cannot solve() for matrices with zero extents")); /* ****************************************** */ SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0)); slot_dup(val, b, Matrix_DimSym); slot_dup(val, b, Matrix_xSym); double *A = REAL(GET_SLOT(Chol, Matrix_xSym)); double *B = REAL(GET_SLOT(val, Matrix_xSym)); if(GPUFlag == 1) { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Solving system of Ax = b, A = dpo, b = dge, using dpotrs_gpu;"); #endif double *d_A, *d_B; const char *uplo = uplo_P(Chol); magma_int_t NRHS = bdims[1]; magma_int_t lda = adims[1]; magma_int_t ldb = bdims[0]; magma_int_t N = adims[0]; cublasStatus retStatus; /*if(uplo == "U") uplo = MagmaUpperStr; else if(uplo == "L") uplo = MagmaLowerStr; else uplo = MagmaUpperStr; */ cublasAlloc(N * lda, sizeof(double), (void**)&d_A); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasAlloc(N * NRHS, sizeof(double), (void**)&d_B); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector( N * lda , sizeof(double), A, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ cublasSetVector( ldb * NRHS, sizeof(double), B, 1, d_B, 1 ); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ magma_dpotrs_gpu(uplo[0], N, NRHS , d_A, lda, d_B, ldb, &info); cublasGetVector( ldb * NRHS, sizeof(double), d_B, 1, B, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer from Device")); /********************************************/ cublasFree(d_A); cublasFree(d_B); } else { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Solving system of Ax = b, A = dpo, b = dge, using dpotrs;"); #endif F77_CALL(dpotrs)(uplo_P(Chol), adims, bdims + 1, A , adims, B , bdims, &info); } if (info) { if(info > 0) error(_("the leading minor of order %d is not positive definite"), info); else /* should never happen! */ error(_("Lapack routine %s returned error code %d"), "dpotrf", info); } UNPROTECT(1); return val; #endif return R_NilValue; }
SEXP magma_dpoMatrix_solve(SEXP x) { #ifdef HIPLAR_WITH_MAGMA SEXP Chol = magma_dpoMatrix_chol(x); SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dpoMatrix"))); int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), info; SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0)); slot_dup(val, Chol, Matrix_uploSym); slot_dup(val, Chol, Matrix_xSym); slot_dup(val, Chol, Matrix_DimSym); SET_SLOT(val, Matrix_DimNamesSym, duplicate(GET_SLOT(x, Matrix_DimNamesSym))); double *A = REAL(GET_SLOT(val, Matrix_xSym)); int N = *dims; int lda = N; const char *uplo = uplo_P(val); if(GPUFlag == 0) { F77_CALL(dpotri)(uplo_P(val), dims, A, dims, &info); } else if(GPUFlag == 1 && Interface == 0) { #ifdef HIPLAR_DBG R_ShowMessage("DBG: Solving using magma_dpotri"); #endif magma_dpotri(uplo[0], N, A, lda, &info); } else if(GPUFlag == 1 && Interface == 1){ double *d_A; cublasStatus retStatus; cublasAlloc( N * lda , sizeof(double), (void**)&d_A); #ifdef HIPLAR_DBG R_ShowMessage("DBG: Solving using magma_dpotri_gpu"); #endif /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation")); /********************************************/ cublasSetVector( N * lda, sizeof(double), A, 1, d_A, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ magma_dpotri_gpu(uplo[0], N, d_A, lda, &info); cublasGetVector(N * lda, sizeof(double), d_A, 1, val, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer from Device")); /********************************************/ cublasFree(d_A); } else error(_("MAGMA/LAPACK/Interface Flag not defined correctly")); if (info) { if(info > 0) error(_("the leading minor of order %d is not positive definite"), info); else /* should never happen! */ error(_("Lapack routine %s returned error code %d"), "dpotrf", info); } UNPROTECT(1); return val; #endif return R_NilValue; }
CAMLprim value spoc_cublasGetError(){ cublasStatus cublas_error = CUBLAS_STATUS_SUCCESS; CUBLAS_CHECK_CALL(cublasGetError()); return Val_unit; }
SEXP magma_dgeMatrix_solve(SEXP a) { #ifdef HIPLAR_WITH_MAGMA /* compute the 1-norm of the matrix, which is needed later for the computation of the reciprocal condition number. */ double aNorm = magma_get_norm(a, "1"); /* the LU decomposition : */ /* Given that we may be performing this operation * on the GPU we may put in an optimisation here * where if we call the LU solver we, we do not require * the decomposition to be transferred back to CPU. This is TODO */ SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))), lu = magma_dgeMatrix_LU_(a, TRUE); int *dims = INTEGER(GET_SLOT(lu, Matrix_DimSym)), *pivot = INTEGER(GET_SLOT(lu, Matrix_permSym)); /* prepare variables for the dgetri calls */ double *x, tmp; int info, lwork = -1; if (dims[0] != dims[1]) error(_("Solve requires a square matrix")); slot_dup(val, lu, Matrix_xSym); x = REAL(GET_SLOT(val, Matrix_xSym)); slot_dup(val, lu, Matrix_DimSym); int N2 = dims[0] * dims[0]; if(dims[0]) /* the dimension is not zero */ { /* is the matrix is *computationally* singular ? */ double rcond; F77_CALL(dgecon)("1", dims, x, dims, &aNorm, &rcond, (double *) R_alloc(4*dims[0], sizeof(double)), (int *) R_alloc(dims[0], sizeof(int)), &info); if (info) error(_("error [%d] from Lapack 'dgecon()'"), info); if(rcond < DOUBLE_EPS) error(_("Lapack dgecon(): system computationally singular, reciprocal condition number = %g"), rcond); /* only now try the inversion and check if the matrix is *exactly* singular: */ // This is also a work space query. This is not an option in magma F77_CALL(dgetri)(dims, x, dims, pivot, &tmp, &lwork, &info); lwork = (int) tmp; if( GPUFlag == 0){ F77_CALL(dgetri)(dims, x, dims, pivot, (double *) R_alloc((size_t) lwork, sizeof(double)), &lwork, &info); #ifdef HIPLAR_DBG R_ShowMessage("DBG: Solve using LU using dgetri;"); #endif } else if(GPUFlag == 1) { double *d_x, *dwork; cublasStatus retStatus; #ifdef HIPLAR_DBG R_ShowMessage("Solve using LU using magma_dgetri;"); #endif cublasAlloc(N2, sizeof(double), (void**)&d_x); //cublasAlloc(N2 , sizeof(double), (void**)&dtmp); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation on Device")); /********************************************/ cublasSetVector( N2, sizeof(double), x, 1, d_x, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data Transfer to Device")); /********************************************/ lwork = dims[0] * magma_get_dgetri_nb( dims[0] ); cublasAlloc(lwork, sizeof(double), (void**)&dwork); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Memory Allocation on Device")); /********************************************/ magma_dgetri_gpu(dims[0], d_x, dims[0], pivot, dwork , lwork, &info); cublasGetVector(N2, sizeof(double), d_x, 1, x, 1); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error in Data From to Device")); /********************************************/ cublasFree(dwork); cublasFree(d_x); /* Error Checking */ retStatus = cublasGetError (); if (retStatus != CUBLAS_STATUS_SUCCESS) error(_("CUBLAS: Error freeing memory")); /********************************************/ } else error(_("GPUFlag not set correctly")); if (info) error(_("Lapack routine dgetri: system is exactly singular")); } UNPROTECT(1); return val; #endif return R_NilValue; }