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;
}
