double *cholesky(double *ml, int m) {
magma_int_t info;
magma_dpotrf('L',m,ml,m,&info);
magma_dpotri('L',m,ml,m,&info);
return ml;
}
void magmaf_dpotri(
magma_uplo_t *uplo, magma_int_t *n,
double *A, magma_int_t *lda,
magma_int_t *info )
{
magma_dpotri(
*uplo, *n,
A, *lda,
info );
}
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;
}
