SEXP Csparse_dense_prod(SEXP a, SEXP b)
{
CHM_SP cha = AS_CHM_SP(a);
SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b));
CHM_DN chb = AS_CHM_DN(b_M);
CHM_DN chc = cholmod_l_allocate_dense(cha->nrow, chb->ncol, cha->nrow,
chb->xtype, &c);
SEXP dn = PROTECT(allocVector(VECSXP, 2));
double one[] = {1,0}, zero[] = {0,0};
int nprot = 2;
R_CheckStack();
/* Tim Davis, please FIXME: currently (2010-11) *fails* when a is a pattern matrix:*/
if(cha->xtype == CHOLMOD_PATTERN) {
/* warning(_("Csparse_dense_prod(): cholmod_sdmult() not yet implemented for pattern./ ngCMatrix" */
/* " --> slightly inefficient coercion")); */
// This *fails* to produce a CHOLMOD_REAL ..
// CHM_SP chd = cholmod_l_copy(cha, cha->stype, CHOLMOD_REAL, &c);
// --> use our Matrix-classes
SEXP da = PROTECT(nz2Csparse(a, x_double)); nprot++;
cha = AS_CHM_SP(da);
}
cholmod_l_sdmult(cha, 0, one, zero, chb, chc, &c);
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 0)));
SET_VECTOR_ELT(dn, 1,
duplicate(VECTOR_ELT(GET_SLOT(b_M, Matrix_DimNamesSym), 1)));
UNPROTECT(nprot);
return chm_dense_to_SEXP(chc, 1, 0, dn);
}
SEXP dsCMatrix_matrix_solve(SEXP a, SEXP b)
{
CHM_FR L = internal_chm_factor(a, -1, -1, -1, 0.);
CHM_DN cx, cb = AS_CHM_DN(PROTECT(mMatrix_as_dgeMatrix(b)));
R_CheckStack();
cx = cholmod_l_solve(CHOLMOD_A, L, cb, &c);
cholmod_l_free_factor(&L, &c);
UNPROTECT(1);
return chm_dense_to_SEXP(cx, 1, 0, /*dimnames = */ R_NilValue);
}
// right = TRUE: %*% is called as *(y, x, right=TRUE)
SEXP dgeMatrix_matrix_mm(SEXP a, SEXP bP, SEXP right)
{
#define DGE_MAT_MM_1(N_PROT) \
SEXP val= PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))), \
dn = PROTECT(allocVector(VECSXP, 2)); \
int nprot = N_PROT + 2, \
*adims = INTEGER(GET_SLOT(a, Matrix_DimSym)), \
*bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)), \
*cdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2)), \
Rt = asLogical(right), m, k, n; \
double one = 1., zero = 0.; \
\
if (Rt) { /* b %*% a : (m x k) (k x n) -> (m x n) */ \
m = bdims[0]; k = bdims[1]; n = adims[1]; \
if (adims[0] != k) \
error(_("Matrices are not conformable for multiplication")); \
} else { /* a %*% b : (m x k) (k x n) -> (m x n) */ \
m = adims[0]; k = adims[1]; n = bdims[1]; \
if (bdims[0] != k) \
error(_("Matrices are not conformable for multiplication")); \
} \
\
cdims[0] = m; cdims[1] = n; \
/* establish dimnames */ \
SET_VECTOR_ELT(dn, 0, duplicate( \
VECTOR_ELT(GET_SLOT(Rt ? b : a, \
Matrix_DimNamesSym), 0))); \
SET_VECTOR_ELT(dn, 1, \
duplicate( \
VECTOR_ELT(GET_SLOT(Rt ? a : b, \
Matrix_DimNamesSym), 1))); \
SET_SLOT(val, Matrix_DimNamesSym, dn); \
double *v = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n))
#define DGE_MAT_MM_DO(_A_X_, _B_X_) \
if (m < 1 || n < 1 || k < 1) {/* zero extent matrices should work */ \
Memzero(v, m * n); \
} else { \
if (Rt) { /* b %*% a */ \
F77_CALL(dgemm) ("N", "N", &m, &n, &k, &one, \
_B_X_, &m, _A_X_, &k, &zero, v, &m); \
} else { /* a %*% b */ \
F77_CALL(dgemm) ("N", "N", &m, &n, &k, &one, \
_A_X_, &m, _B_X_, &k, &zero, v, &m); \
} \
} \
UNPROTECT(nprot); \
return val
SEXP b = PROTECT(mMatrix_as_dgeMatrix(bP));
DGE_MAT_MM_1(1);
DGE_MAT_MM_DO(REAL(GET_SLOT(a, Matrix_xSym)),
REAL(GET_SLOT(b, Matrix_xSym)));
}
SEXP dsCMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP Chol = get_factor_pattern(a, "spdCholesky", 3);
cholmod_factor *L;
cholmod_dense *cx,
*cb = as_cholmod_dense(PROTECT(mMatrix_as_dgeMatrix(b)));
if (Chol == R_NilValue)
Chol = dsCMatrix_Cholesky(a,
ScalarLogical(1), /* permuted */
ScalarLogical(1), /* LDL' */
ScalarLogical(0)); /* simplicial */
L = as_cholmod_factor(Chol);
cx = cholmod_solve(CHOLMOD_A, L, cb, &c);
Free(cb); Free(L);
UNPROTECT(1);
return chm_dense_to_SEXP(cx, 1);
}
SEXP dgeMatrix_matrix_mm(SEXP a, SEXP bP, SEXP right)
{
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., zero = 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) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n);
} else
F77_CALL(dgemm) ("N", "N", &m, &n, &k, &one,
REAL(GET_SLOT(b, Matrix_xSym)), &m,
REAL(GET_SLOT(a, Matrix_xSym)), &k, &zero,
REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n)),
&m);
} else {
int m = adims[0], n = bdims[1], k = adims[1];
if (bdims[0] != k)
error(_("Matrices are not conformable for multiplication"));
cdims[0] = m; cdims[1] = n;
if (m < 1 || n < 1 || k < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n);
} else
F77_CALL(dgemm)
("N", "N", &m, &n, &k, &one, REAL(GET_SLOT(a, Matrix_xSym)),
&m, REAL(GET_SLOT(b, Matrix_xSym)), &k, &zero,
REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n)), &m);
}
ALLOC_SLOT(val, Matrix_DimNamesSym, VECSXP, 2);
UNPROTECT(2);
return val;
}
SEXP Csparse_dense_crossprod(SEXP a, SEXP b)
{
CHM_SP cha = AS_CHM_SP(a);
SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b));
CHM_DN chb = AS_CHM_DN(b_M);
CHM_DN chc = cholmod_l_allocate_dense(cha->ncol, chb->ncol, cha->ncol,
chb->xtype, &c);
SEXP dn = PROTECT(allocVector(VECSXP, 2)); int nprot = 2;
double one[] = {1,0}, zero[] = {0,0};
R_CheckStack();
// -- see Csparse_dense_prod() above :
if(cha->xtype == CHOLMOD_PATTERN) {
SEXP da = PROTECT(nz2Csparse(a, x_double)); nprot++;
cha = AS_CHM_SP(da);
}
cholmod_l_sdmult(cha, 1, one, zero, chb, chc, &c);
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 1)));
SET_VECTOR_ELT(dn, 1,
duplicate(VECTOR_ELT(GET_SLOT(b_M, Matrix_DimNamesSym), 1)));
UNPROTECT(nprot);
return chm_dense_to_SEXP(chc, 1, 0, dn);
}
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;
}
