SEXP dsyMatrix_matrix_mm(SEXP a, SEXP b, SEXP rtP)
{
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));// incl. its dimnames
int rt = asLogical(rtP); /* if(rt), compute b %*% a, else a %*% b */
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym)),
m = bdims[0], n = bdims[1];
double one = 1., zero = 0., mn = ((double) m) * ((double) n);
if (mn > INT_MAX)
error(_("Matrix dimension %d x %d (= %g) is too large"), m, n, mn);
// else: m * n will not overflow below
double *bcp, *vx = REAL(GET_SLOT(val, Matrix_xSym));
C_or_Alloca_TO(bcp, m * n, double);
Memcpy(bcp, vx, m * n);
if ((rt && n != adims[0]) || (!rt && m != adims[0]))
error(_("Matrices are not conformable for multiplication"));
if (m >=1 && n >= 1)
F77_CALL(dsymm)(rt ? "R" :"L", uplo_P(a), &m, &n, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims, bcp,
&m, &zero, vx, &m);
// add dimnames:
int nd = rt ?
1 : // v <- b %*% a : rownames(v) == rownames(b) are already there
0; // v <- a %*% b : colnames(v) == colnames(b) are already there
SEXP nms = PROTECT(duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), nd)));
SET_VECTOR_ELT(GET_SLOT(val, Matrix_DimNamesSym), nd, nms);
if(mn >= SMALL_4_Alloca) Free(bcp);
UNPROTECT(2);
return val;
}
/* to bu used for all three: '%*%', crossprod() and tcrossprod() */
SEXP dtrMatrix_matrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
/* Because a must be square, the size of the answer, val,
* is the same as the size of b */
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int rt = asLogical(right); /* if(rt), compute b %*% op(a), else op(a) %*% b */
int tr = asLogical(trans);/* if true, use t(a) */
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
int m = bdims[0], n = bdims[1];
double one = 1.;
if (adims[0] != adims[1])
error(_("dtrMatrix must be square"));
if ((rt && adims[0] != n) || (!rt && adims[1] != m))
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
} else /* BLAS */
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_P(a),
/*trans_A = */ tr ? "T" : "N",
diag_P(a), &m, &n, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), &m);
UNPROTECT(1);
return val;
}
SEXP Csparse_diagN2U(SEXP x)
{
const char *cl = class_P(x);
/* dtCMatrix, etc; [1] = the second character =?= 't' for triangular */
if (cl[1] != 't' || *diag_P(x) != 'N') {
/* "trivially fast" when not triangular (<==> no 'diag' slot),
or already *unit* triangular */
return (x);
}
else { /* triangular with diag='N'): now drop the diagonal */
/* duplicate, since chx will be modified: */
SEXP xx = PROTECT(duplicate(x));
CHM_SP chx = AS_CHM_SP__(xx);
int uploT = (*uplo_P(x) == 'U') ? 1 : -1,
Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
chm_diagN2U(chx, uploT, /* do_realloc */ FALSE);
UNPROTECT(1);
return chm_sparse_to_SEXP(chx, /*dofree*/ 0/* or 1 ?? */,
uploT, Rkind, "U",
GET_SLOT(x, Matrix_DimNamesSym));
}
}
double get_norm_sy(SEXP obj, const char *typstr)
{
#ifdef HIPLAR_WITH_PLASMA
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym));
double *work = (double *) NULL;
typnm[0] = La_norm_type(typstr);
if ((*typnm == 'F') && (CHECK_VVERSION_BEQ(2,4,5))) {
error("not implemented");
}
if (*typnm == 'F') {
work = (double *) R_alloc(2*R_PLASMA_NUM_THREADS, sizeof(double));
} else {
work = (double *) R_alloc(R_PLASMA_NUM_THREADS, sizeof(double));
}
return P_dlansy(typnm, uplo_P(obj),
dims[0], REAL(GET_SLOT(obj, Matrix_xSym)), dims[0], work);
#endif
return 0.0;
}
static
double set_rcond_sy(SEXP obj, char *typstr)
{
char typnm[] = {'\0', '\0'};
SEXP rcv = GET_SLOT(obj, Matrix_rcondSym);
double rcond;
typnm[0] = rcond_type(typstr);
rcond = get_double_by_name(rcv, typnm);
if (R_IsNA(rcond)) {
SEXP trf = dsyMatrix_trf(obj);
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;
double anorm = get_norm_sy(obj, "O");
F77_CALL(dsycon)(uplo_P(trf), dims,
REAL (GET_SLOT(trf, Matrix_xSym)), dims,
INTEGER(GET_SLOT(trf, Matrix_permSym)),
&anorm, &rcond,
(double *) R_alloc(2*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
SET_SLOT(obj, Matrix_rcondSym,
set_double_by_name(rcv, rcond, typnm));
}
return rcond;
}
/* This should be use for *BOTH* triangular and symmetric Tsparse: */
SEXP tTMatrix_validate(SEXP x)
{
SEXP val = xTMatrix_validate(x);/* checks x slot */
if(isString(val))
return(val);
else {
SEXP
islot = GET_SLOT(x, Matrix_iSym),
jslot = GET_SLOT(x, Matrix_jSym);
int uploT = (*uplo_P(x) == 'U'),
k, nnz = length(islot),
*xj = INTEGER(jslot),
*xi = INTEGER(islot);
/* Maybe FIXME: ">" should be ">=" for diag = 'U' (uplo = 'U') */
if(uploT) {
for (k = 0; k < nnz; k++)
if(xi[k] > xj[k])
return mkString(_("uplo='U' must not have sparse entries in lower diagonal"));
}
else {
for (k = 0; k < nnz; k++)
if(xi[k] < xj[k])
return mkString(_("uplo='L' must not have sparse entries in upper diagonal"));
}
return ScalarLogical(1);
}
}
SEXP dsyMatrix_dgeMatrix_mm_R(SEXP a, SEXP b)
{
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)),
*cdims,
m = adims[0], n = bdims[1], k = adims[1];
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
double one = 1., zero = 0.;
if (bdims[0] != k)
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
SET_SLOT(val, Matrix_rcondSym, allocVector(REALSXP, 0));
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
SET_SLOT(val, Matrix_xSym, allocVector(REALSXP, m * n));
SET_SLOT(val, Matrix_DimSym, allocVector(INTSXP, 2));
cdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
cdims[0] = m; cdims[1] = n;
F77_CALL(dsymm)("R", uplo_P(a), adims, bdims+1, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(b, Matrix_xSym)), bdims,
&zero, REAL(GET_SLOT(val, Matrix_xSym)), adims);
UNPROTECT(1);
return val;
}
/* This is used for *BOTH* triangular and symmetric Csparse: */
SEXP tCMatrix_validate(SEXP x)
{
SEXP val = xCMatrix_validate(x);/* checks x slot */
if(isString(val))
return(val);
else {
SEXP
islot = GET_SLOT(x, Matrix_iSym),
pslot = GET_SLOT(x, Matrix_pSym);
int uploT = (*uplo_P(x) == 'U'),
k, nnz = length(islot),
*xi = INTEGER(islot),
*xj = INTEGER(PROTECT(allocVector(INTSXP, nnz)));
expand_cmprPt(length(pslot) - 1, INTEGER(pslot), xj);
/* Maybe FIXME: ">" should be ">=" for diag = 'U' (uplo = 'U') */
if(uploT) {
for (k = 0; k < nnz; k++)
if(xi[k] > xj[k]) {
RETURN(mkString(_("uplo='U' must not have sparse entries below the diagonal")));
}
}
else {
for (k = 0; k < nnz; k++)
if(xi[k] < xj[k]) {
RETURN(mkString(_("uplo='L' must not have sparse entries above the diagonal")));
}
}
RETURN(ScalarLogical(1));
}
}
SEXP dtrMatrix_solve(SEXP a)
{
SEXP val = PROTECT(duplicate(a));
int info, *Dim = INTEGER(GET_SLOT(val, Matrix_DimSym));
F77_CALL(dtrtri)(uplo_P(val), diag_P(val), Dim,
REAL(GET_SLOT(val, Matrix_xSym)), Dim, &info);
UNPROTECT(1);
return val;
}
SEXP Csparse_Csparse_prod(SEXP a, SEXP b)
{
CHM_SP
cha = AS_CHM_SP(a),
chb = AS_CHM_SP(b),
chc = cholmod_l_ssmult(cha, chb, /*out_stype:*/ 0,
/* values:= is_numeric (T/F) */ cha->xtype > 0,
/*out sorted:*/ 1, &c);
const char *cl_a = class_P(a), *cl_b = class_P(b);
char diag[] = {'\0', '\0'};
int uploT = 0;
SEXP dn = PROTECT(allocVector(VECSXP, 2));
R_CheckStack();
#ifdef DEBUG_Matrix_verbose
Rprintf("DBG Csparse_C*_prod(%s, %s)\n", cl_a, cl_b);
#endif
/* Preserve triangularity and even unit-triangularity if appropriate.
* Note that in that case, the multiplication itself should happen
* faster. But there's no support for that in CHOLMOD */
/* UGLY hack -- rather should have (fast!) C-level version of
* is(a, "triangularMatrix") etc */
if (cl_a[1] == 't' && cl_b[1] == 't')
/* FIXME: fails for "Cholesky","BunchKaufmann"..*/
if(*uplo_P(a) == *uplo_P(b)) { /* both upper, or both lower tri. */
uploT = (*uplo_P(a) == 'U') ? 1 : -1;
if(*diag_P(a) == 'U' && *diag_P(b) == 'U') { /* return UNIT-triag. */
/* "remove the diagonal entries": */
chm_diagN2U(chc, uploT, /* do_realloc */ FALSE);
diag[0]= 'U';
}
else diag[0]= 'N';
}
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, Matrix_DimNamesSym), 1)));
UNPROTECT(1);
return chm_sparse_to_SEXP(chc, 1, uploT, /*Rkind*/0, diag, dn);
}
// FIXME: do not go via CHM (should not be too hard, to just *drop* the x-slot, right?
SEXP Csparse_to_nz_pattern(SEXP x, SEXP tri)
{
CHM_SP chxs = AS_CHM_SP__(x);
CHM_SP chxcp = cholmod_l_copy(chxs, chxs->stype, CHOLMOD_PATTERN, &c);
int tr = asLogical(tri);
R_CheckStack();
return chm_sparse_to_SEXP(chxcp, 1/*do_free*/,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
0, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
double magma_get_norm_sy(SEXP obj, const char *typstr)
{
#ifdef HIPLAR_WITH_MAGMA
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym));
double *work = (double *) NULL;
int N = dims[0];
int lda = N;
double *A = REAL(GET_SLOT(obj, Matrix_xSym));
typnm[0] = La_norm_type(typstr);
const char *c = uplo_P(obj);
//Magmablas dlansy only does I & M norms
if(GPUFlag == 1 && (*typnm == 'I' || *typnm == 'M')) {
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Performing norm using magmablas_dlansy");
#endif
double *dwork, *d_A, maxnorm;
cublasAlloc(N, sizeof(double), (void**)&dwork);
cublasAlloc(lda * N, sizeof(double), (void**)&d_A);
cublasSetVector(N * lda, sizeof(double), A, 1, d_A, 1);
maxnorm = magmablas_dlansy(typnm[0], *c ,N, d_A, lda, dwork);
cublasFree(d_A);
cublasFree(dwork);
return maxnorm;
}
else {
if (*typnm == 'I' || *typnm == 'O') {
work = (double *) R_alloc(dims[0], sizeof(double));
}
return F77_CALL(dlansy)(typnm, uplo_P(obj),
dims, A,
dims, work);
}
#endif
return 0.0;
}
SEXP Csparse_to_Tsparse(SEXP x, SEXP tri)
{
CHM_SP chxs = AS_CHM_SP__(x);
CHM_TR chxt = cholmod_l_sparse_to_triplet(chxs, &c);
int tr = asLogical(tri);
int Rkind = (chxs->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
return chm_triplet_to_SEXP(chxt, 1,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
Rkind, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP dppMatrix_rcond(SEXP obj, SEXP type)
{
SEXP Chol = dppMatrix_chol(obj);
char typnm[] = {'O', '\0'}; /* always use the one norm */
int *dims = INTEGER(GET_SLOT(Chol, Matrix_DimSym)), info;
double anorm = get_norm_sp(obj, typnm), rcond;
F77_CALL(dppcon)(uplo_P(Chol), dims,
REAL(GET_SLOT(Chol, Matrix_xSym)), &anorm, &rcond,
(double *) R_alloc(3*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
return ScalarReal(rcond);
}
SEXP Tsparse_to_Csparse(SEXP x, SEXP tri)
{
CHM_TR chxt = AS_CHM_TR__(x); /* << should *preserve* diag = "U" ! */
CHM_SP chxs = cholmod_l_triplet_to_sparse(chxt, chxt->nnz, &c);
int tr = asLogical(tri);
int Rkind = (chxt->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
return chm_sparse_to_SEXP(chxs, 1,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
Rkind, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP dtrMatrix_rcond(SEXP obj, SEXP type)
{
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;
double rcond;
typnm[0] = rcond_type(CHAR(asChar(type)));
F77_CALL(dtrcon)(typnm, uplo_P(obj), diag_P(obj), dims,
REAL(GET_SLOT(obj, Matrix_xSym)), dims, &rcond,
(double *) R_alloc(3*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
return ScalarReal(rcond);
}
static
double get_norm(SEXP obj, const char *typstr)
{
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym));
double *work = (double *) NULL;
typnm[0] = norm_type(typstr);
if (*typnm == 'I') {
work = (double *) R_alloc(dims[0], sizeof(double));
}
return F77_CALL(dlantr)(typnm, uplo_P(obj), diag_P(obj), dims, dims+1,
REAL(GET_SLOT(obj, Matrix_xSym)), dims, work);
}
SEXP dppMatrix_solve(SEXP x)
{
SEXP Chol = dppMatrix_chol(x);
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dppMatrix")));
int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), info;
slot_dup(val, Chol, Matrix_uploSym);
slot_dup(val, Chol, Matrix_xSym);
slot_dup(val, Chol, Matrix_DimSym);
F77_CALL(dpptri)(uplo_P(val), dims,
REAL(GET_SLOT(val, Matrix_xSym)), &info);
UNPROTECT(1);
return val;
}
SEXP dsyMatrix_rcond(SEXP obj, SEXP type)
{
SEXP trf = dsyMatrix_trf(obj);
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;
double anorm = get_norm_sy(obj, "O");
double rcond;
F77_CALL(dsycon)(uplo_P(trf), dims,
REAL (GET_SLOT(trf, Matrix_xSym)), dims,
INTEGER(GET_SLOT(trf, Matrix_permSym)),
&anorm, &rcond,
(double *) R_alloc(2*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
return ScalarReal(rcond);
}
SEXP Csparse_Csparse_crossprod(SEXP a, SEXP b, SEXP trans)
{
int tr = asLogical(trans);
CHM_SP
cha = AS_CHM_SP(a),
chb = AS_CHM_SP(b),
chTr, chc;
const char *cl_a = class_P(a), *cl_b = class_P(b);
char diag[] = {'\0', '\0'};
int uploT = 0;
SEXP dn = PROTECT(allocVector(VECSXP, 2));
R_CheckStack();
chTr = cholmod_l_transpose((tr) ? chb : cha, chb->xtype, &c);
chc = cholmod_l_ssmult((tr) ? cha : chTr, (tr) ? chTr : chb,
/*out_stype:*/ 0, cha->xtype, /*out sorted:*/ 1, &c);
cholmod_l_free_sparse(&chTr, &c);
/* Preserve triangularity and unit-triangularity if appropriate;
* see Csparse_Csparse_prod() for comments */
if (cl_a[1] == 't' && cl_b[1] == 't')
if(*uplo_P(a) != *uplo_P(b)) { /* one 'U', the other 'L' */
uploT = (*uplo_P(b) == 'U') ? 1 : -1;
if(*diag_P(a) == 'U' && *diag_P(b) == 'U') { /* return UNIT-triag. */
chm_diagN2U(chc, uploT, /* do_realloc */ FALSE);
diag[0]= 'U';
}
else diag[0]= 'N';
}
SET_VECTOR_ELT(dn, 0, /* establish dimnames */
duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), (tr) ? 0 : 1)));
SET_VECTOR_ELT(dn, 1,
duplicate(VECTOR_ELT(GET_SLOT(b, Matrix_DimNamesSym), (tr) ? 0 : 1)));
UNPROTECT(1);
return chm_sparse_to_SEXP(chc, 1, uploT, /*Rkind*/0, diag, dn);
}
SEXP dppMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
SEXP Chol = dppMatrix_chol(a);
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
int n = bdims[0], nrhs = bdims[1], info;
if (*adims != *bdims || bdims[1] < 1 || *adims < 1)
error(_("Dimensions of system to be solved are inconsistent"));
F77_CALL(dpptrs)(uplo_P(Chol), &n, &nrhs,
REAL(GET_SLOT(Chol, Matrix_xSym)),
REAL(GET_SLOT(val, Matrix_xSym)), &n, &info);
UNPROTECT(1);
return val;
}
SEXP dtrMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(ans, Matrix_DimSym));
int n = bdims[0], nrhs = bdims[1];
double one = 1.0;
if (*adims != *bdims || bdims[1] < 1 || *adims < 1 || *adims != adims[1])
error(_("Dimensions of system to be solved are inconsistent"));
F77_CALL(dtrsm)("L", uplo_P(a), "N", diag_P(a),
&n, &nrhs, &one, REAL(GET_SLOT(a, Matrix_xSym)), &n,
REAL(GET_SLOT(ans, Matrix_xSym)), &n);
UNPROTECT(1);
return ans;
}
SEXP dtrMatrix_chol2inv(SEXP a)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dpoMatrix")));
int info, n;
slot_dup(val, a, Matrix_DimSym);
slot_dup(val, a, Matrix_uploSym);
slot_dup(val, a, Matrix_diagSym);
slot_dup(val, a, Matrix_DimNamesSym);
slot_dup(val, a, Matrix_xSym);
n = *INTEGER(GET_SLOT(val, Matrix_DimSym));
F77_CALL(dpotri)(uplo_P(val), &n,
REAL(GET_SLOT(val, Matrix_xSym)), &n, &info);
UNPROTECT(1);
return val;
}
SEXP dtCMatrix_sparse_solve(SEXP a, SEXP b)
{
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("dgCMatrix")));
CSP A = AS_CSP(a), B = AS_CSP(b);
int *xp = INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP, (B->n) + 1)),
xnz = 10 * B->p[B->n]; /* initial estimate of nnz in x */
int *ti = Calloc(xnz, int), k, lo = uplo_P(a)[0] == 'L', pos = 0;
double *tx = Calloc(xnz, double);
double *wrk = Alloca(A->n, double);
int *xi = Alloca(2*A->n, int); /* for cs_reach */
R_CheckStack();
if (A->m != A->n || B->n < 1 || A->n < 1 || A->n != B->m)
error(_("Dimensions of system to be solved are inconsistent"));
slot_dup(ans, b, Matrix_DimSym);
SET_DimNames(ans, b);
xp[0] = 0;
for (k = 0; k < B->n; k++) {
int top = cs_spsolve (A, B, k, xi, wrk, (int *)NULL, lo);
int nz = A->n - top, p;
xp[k + 1] = nz + xp[k];
if (xp[k + 1] > xnz) {
while (xp[k + 1] > xnz) xnz *= 2;
ti = Realloc(ti, xnz, int);
tx = Realloc(tx, xnz, double);
}
if (lo) /* increasing row order */
for(p = top; p < A->n; p++, pos++) {
ti[pos] = xi[p];
tx[pos] = wrk[xi[p]];
}
else /* decreasing order, reverse copy */
for(p = A->n - 1; p >= top; p--, pos++) {
ti[pos] = xi[p];
tx[pos] = wrk[xi[p]];
}
}
xnz = xp[B->n];
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP, xnz)), ti, xnz);
Memcpy( REAL(ALLOC_SLOT(ans, Matrix_xSym, REALSXP, xnz)), tx, xnz);
Free(ti); Free(tx);
UNPROTECT(1);
return ans;
}
// need to implement magma here, but as noted below
// we are limited to the type of norm we can use (see get_norm_sy)
SEXP magma_dpoMatrix_rcond(SEXP obj, SEXP type)
{
#ifdef HIPLAR_WITH_MAGMA
SEXP Chol = magma_dpoMatrix_chol(obj);
const char typnm[] = {'O', '\0'}; // always use the one norm
int *dims = INTEGER(GET_SLOT(Chol, Matrix_DimSym)), info;
double anorm = magma_get_norm_sy(obj, typnm), rcond;
F77_CALL(dpocon)(uplo_P(Chol),
dims, REAL(GET_SLOT(Chol, Matrix_xSym)),
dims, &anorm, &rcond,
(double *) R_alloc(3*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
return ScalarReal(rcond);
#endif
return R_NilValue;
}
SEXP dpoMatrix_solve(SEXP x)
{
SEXP Chol = 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));
SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(Chol, Matrix_uploSym)));
SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(Chol, Matrix_xSym)));
SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(Chol, Matrix_DimSym)));
SET_SLOT(val, Matrix_DimNamesSym,
duplicate(GET_SLOT(x, Matrix_DimNamesSym)));
F77_CALL(dpotri)(uplo_P(val), dims,
REAL(GET_SLOT(val, Matrix_xSym)), dims, &info);
UNPROTECT(1);
return val;
}
SEXP dsyMatrix_solve(SEXP a)
{
SEXP trf = dsyMatrix_trf(a);
SEXP val = PROTECT(NEW_OBJECT_OF_CLASS("dsyMatrix"));
int *dims = INTEGER(GET_SLOT(trf, Matrix_DimSym)), info;
slot_dup(val, trf, Matrix_uploSym);
slot_dup(val, trf, Matrix_xSym);
slot_dup(val, trf, Matrix_DimSym);
F77_CALL(dsytri)(uplo_P(val), dims,
REAL(GET_SLOT(val, Matrix_xSym)), dims,
INTEGER(GET_SLOT(trf, Matrix_permSym)),
(double *) R_alloc((long) dims[0], sizeof(double)),
&info);
UNPROTECT(1);
return val;
}
SEXP dpoMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP Chol = 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"));
F77_CALL(dpotrs)(uplo_P(Chol), adims, bdims + 1,
REAL(GET_SLOT(Chol, Matrix_xSym)), adims,
REAL(val), bdims, &info);
UNPROTECT(1);
return val;
}
/* Csparse_drop(x, tol): drop entries with absolute value < tol, i.e,
* at least all "explicit" zeros */
SEXP Csparse_drop(SEXP x, SEXP tol)
{
const char *cl = class_P(x);
/* dtCMatrix, etc; [1] = the second character =?= 't' for triangular */
int tr = (cl[1] == 't');
CHM_SP chx = AS_CHM_SP__(x);
CHM_SP ans = cholmod_l_copy(chx, chx->stype, chx->xtype, &c);
double dtol = asReal(tol);
int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
R_CheckStack();
if(!cholmod_l_drop(dtol, ans, &c))
error(_("cholmod_l_drop() failed"));
return chm_sparse_to_SEXP(ans, 1,
tr ? ((*uplo_P(x) == 'U') ? 1 : -1) : 0,
Rkind, tr ? diag_P(x) : "",
GET_SLOT(x, Matrix_DimNamesSym));
}
SEXP dtrMatrix_dgeMatrix_mm_R(SEXP a, SEXP b)
{
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)),
m = adims[0], n = bdims[1], k = adims[1];
SEXP val = PROTECT(duplicate(b));
double one = 1.;
if (bdims[0] != k)
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
F77_CALL(dtrmm)("R", uplo_P(a), "N", diag_P(a), adims, bdims+1, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), bdims);
UNPROTECT(1);
return val;
}
