SEXP dsyMatrix_trf(SEXP x)
{
SEXP val = get_factors(x, "BunchKaufman"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
int *dims = INTEGER(dimP), *perm, info;
int lwork = -1, n = dims[0];
const char *uplo = CHAR(STRING_ELT(uploP, 0));
double tmp, *vx, *work;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("BunchKaufman")));
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);
F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
perm = INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, n));
F77_CALL(dsytrf)(uplo, &n, vx, &n, perm, &tmp, &lwork, &info);
lwork = (int) tmp;
work = Alloca(lwork, double);
R_CheckStack();
F77_CALL(dsytrf)(uplo, &n, vx, &n, perm, work, &lwork, &info);
if (info) error(_("Lapack routine dsytrf returned error code %d"), info);
UNPROTECT(1);
return set_factors(x, val, "BunchKaufman");
}
SEXP dgeMatrix_LU_(SEXP x, Rboolean warn_sing)
{
SEXP val = get_factors(x, "LU");
int *dims, npiv, info;
if (val != R_NilValue) /* 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);
slot_dup(val, x, Matrix_DimNamesSym);
F77_CALL(dgetrf)(dims, dims + 1, REAL(GET_SLOT(val, Matrix_xSym)),
dims,
INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, npiv)),
&info);
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");
}
SEXP dppMatrix_chol(SEXP x)
{
SEXP val = get_factors(x, "pCholesky"),
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;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("pCholesky")));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
slot_dup(val, x, Matrix_xSym);
F77_CALL(dpptrf)(uplo, dims, REAL(GET_SLOT(val, Matrix_xSym)), &info);
if (info) {
if(info > 0) /* e.g. x singular */
error(_("the leading minor of order %d is not positive definite"),
info);
else /* should never happen! */
error(_("Lapack routine %s returned error code %d"), "dpptrf", info);
}
UNPROTECT(1);
return set_factors(x, val, "pCholesky");
}
/**
* Return a CHOLMOD copy of the cached Cholesky decomposition with the
* required perm, LDL and super attributes. If Imult is nonzero,
* update the numeric values before returning.
*
* If no cached copy is available then evaluate one, cache it (for
* zero Imult), and return a copy.
*
* @param Ap dsCMatrix object
* @param perm integer indicating if permutation is required (>0),
* forbidden (0) or optional (<0)
* @param LDL integer indicating if the LDL' form is required (>0),
* forbidden (0) or optional (<0)
* @param super integer indicating if the supernodal form is required (>0),
* forbidden (0) or optional (<0)
* @param Imult numeric multiplier of I in |A + Imult * I|
*/
static CHM_FR
internal_chm_factor(SEXP Ap, int perm, int LDL, int super, double Imult)
{
SEXP facs = GET_SLOT(Ap, Matrix_factorSym);
SEXP nms = getAttrib(facs, R_NamesSymbol);
int sup, ll;
CHM_FR L;
CHM_SP A = AS_CHM_SP__(Ap);
R_CheckStack();
if (LENGTH(facs)) {
for (int i = 0; i < LENGTH(nms); i++) { /* look for a match in cache */
if (chk_nm(CHAR(STRING_ELT(nms, i)), perm, LDL, super)) {
L = AS_CHM_FR(VECTOR_ELT(facs, i));
R_CheckStack();
/* copy the factor so later it can safely be cholmod_l_free'd */
L = cholmod_l_copy_factor(L, &c);
if (Imult) cholmod_l_factorize_p(A, &Imult, (int*)NULL, 0, L, &c);
return L;
}
}
}
/* No cached factor - create one */
sup = c.supernodal; /* save current settings */
ll = c.final_ll;
c.final_ll = (LDL == 0) ? 1 : 0;
c.supernodal = (super > 0) ? CHOLMOD_SUPERNODAL : CHOLMOD_SIMPLICIAL;
if (perm) { /* obtain fill-reducing permutation */
L = cholmod_l_analyze(A, &c);
} else { /* require identity permutation */
/* save current settings */
int nmethods = c.nmethods, ord0 = c.method[0].ordering,
postorder = c.postorder;
c.nmethods = 1; c.method[0].ordering = CHOLMOD_NATURAL; c.postorder = FALSE;
L = cholmod_l_analyze(A, &c);
/* and now restore */
c.nmethods = nmethods; c.method[0].ordering = ord0; c.postorder = postorder;
}
if (!cholmod_l_factorize_p(A, &Imult, (int*)NULL, 0 /*fsize*/, L, &c))
error(_("Cholesky factorization failed"));
c.supernodal = sup; /* restore previous settings */
c.final_ll = ll;
if (!Imult) { /* cache the factor */
char fnm[12] = "sPDCholesky";
if (super > 0) fnm[0] = 'S';
if (perm == 0) fnm[1] = 'p';
if (LDL == 0) fnm[2] = 'd';
set_factors(Ap, chm_factor_to_SEXP(L, 0), fnm);
}
return L;
}
SEXP dsCMatrix_Cholesky(SEXP Ap, SEXP permP, SEXP LDLp, SEXP superP)
{
char *fname = strdup("spdCholesky"); /* template for factorization name */
int perm = asLogical(permP),
LDL = asLogical(LDLp),
super = asLogical(superP);
SEXP Chol;
cholmod_sparse *A;
cholmod_factor *L;
int sup, ll;
if (super) fname[0] = 'S';
if (perm) fname[1] = 'P';
if (LDL) fname[2] = 'D';
Chol = get_factors(Ap, "fname");
if (Chol != R_NilValue) return Chol;
A = as_cholmod_sparse(Ap);
sup = c.supernodal;
ll = c.final_ll;
if (!A->stype) error("Non-symmetric matrix passed to dsCMatrix_chol");
c.final_ll = !LDL; /* leave as LL' or form LDL' */
c.supernodal = super ? CHOLMOD_SUPERNODAL : CHOLMOD_SIMPLICIAL;
if (perm) {
L = cholmod_analyze(A, &c); /* get fill-reducing permutation */
} else { /* require identity permutation */
int nmethods = c.nmethods, ord0 = c.method[0].ordering,
postorder = c.postorder;
c.nmethods = 1;
c.method[0].ordering = CHOLMOD_NATURAL;
c.postorder = FALSE;
L = cholmod_analyze(A, &c);
c.nmethods = nmethods; c.method[0].ordering = ord0;
c.postorder = postorder;
}
c.supernodal = sup; /* restore previous setting */
c.final_ll = ll;
if (!cholmod_factorize(A, L, &c))
error(_("Cholesky factorization failed"));
Free(A);
Chol = set_factors(Ap, chm_factor_to_SEXP(L, 1), fname);
free(fname); /* note, this must be free, not Free */
return Chol;
}
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;
}
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;
}
/* Modified version of Tim Davis's cs_lu_mex.c file for MATLAB */
void install_lu(SEXP Ap, int order, double tol, Rboolean err_sing, Rboolean keep_dimnms)
{
// (order, tol) == (1, 1) by default, when called from R.
SEXP ans;
css *S;
csn *N;
int n, *p, *dims;
CSP A = AS_CSP__(Ap), D;
R_CheckStack();
n = A->n;
if (A->m != n)
error(_("LU decomposition applies only to square matrices"));
if (order) { /* not using natural order */
order = (tol == 1) ? 2 /* amd(S'*S) w/dense rows or I */
: 1; /* amd (A+A'), or natural */
}
S = cs_sqr(order, A, /*qr = */ 0); /* symbolic ordering */
N = cs_lu(A, S, tol); /* numeric factorization */
if (!N) {
if(err_sing)
error(_("cs_lu(A) failed: near-singular A (or out of memory)"));
else {
/* No warning: The useR should be careful :
* Put NA into "LU" factor */
set_factors(Ap, ScalarLogical(NA_LOGICAL), "LU");
return;
}
}
cs_dropzeros(N->L); /* drop zeros from L and sort it */
D = cs_transpose(N->L, 1);
cs_spfree(N->L);
N->L = cs_transpose(D, 1);
cs_spfree(D);
cs_dropzeros(N->U); /* drop zeros from U and sort it */
D = cs_transpose(N->U, 1);
cs_spfree(N->U);
N->U = cs_transpose(D, 1);
cs_spfree(D);
p = cs_pinv(N->pinv, n); /* p=pinv' */
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("sparseLU")));
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = n; dims[1] = n;
SEXP dn; Rboolean do_dn = FALSE;
if(keep_dimnms) {
dn = GET_SLOT(Ap, Matrix_DimNamesSym);
do_dn = !isNull(VECTOR_ELT(dn, 0));
if(do_dn) {
dn = PROTECT(duplicate(dn));
// permute rownames by p : rn <- rn[ p ] :
SEXP rn = PROTECT(duplicate(VECTOR_ELT(dn, 0)));
for(int i=0; i < n; i++)
SET_STRING_ELT(VECTOR_ELT(dn, 0), i, STRING_ELT(rn, p[i]));
UNPROTECT(1); // rn
SET_VECTOR_ELT(dn, 1, R_NilValue); // colnames(.) := NULL
}
}
SET_SLOT(ans, install("L"),
Matrix_cs_to_SEXP(N->L, "dtCMatrix", 0, do_dn ? dn : R_NilValue));
if(keep_dimnms) {
if(do_dn) {
UNPROTECT(1); // dn
dn = GET_SLOT(Ap, Matrix_DimNamesSym);
}
do_dn = !isNull(VECTOR_ELT(dn, 1));
if(do_dn) {
dn = PROTECT(duplicate(dn));
if(order) { // permute colnames by S->q : cn <- cn[ S->q ] :
SEXP cn = PROTECT(duplicate(VECTOR_ELT(dn, 1)));
for(int j=0; j < n; j++)
SET_STRING_ELT(VECTOR_ELT(dn, 1), j, STRING_ELT(cn, S->q[j]));
UNPROTECT(1); // cn
}
SET_VECTOR_ELT(dn, 0, R_NilValue); // rownames(.) := NULL
}
}
SET_SLOT(ans, install("U"),
Matrix_cs_to_SEXP(N->U, "dtCMatrix", 0, do_dn ? dn : R_NilValue));
if(do_dn) UNPROTECT(1); // dn
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, /* "p" */
INTSXP, n)), p, n);
if (order)
Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"),
INTSXP, n)), S->q, n);
cs_nfree(N);
cs_sfree(S);
cs_free(p);
UNPROTECT(1);
set_factors(Ap, ans, "LU");
}
