SEXP sparseQR_resid_fitted(SEXP qr, SEXP y, SEXP resid)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(y));
CSP V = AS_CSP(GET_SLOT(qr, install("V")));
int *ydims = INTEGER(GET_SLOT(ans, Matrix_DimSym)),
*p = INTEGER(GET_SLOT(qr, Matrix_pSym)),
i, j, m = V->m, n = V->n, res = asLogical(resid);
double *ax = REAL(GET_SLOT(ans, Matrix_xSym)),
*beta = REAL(GET_SLOT(qr, install("beta")));
R_CheckStack();
/* apply row permutation and multiply by Q' */
sparseQR_Qmult(V, beta, p, 1, ax, ydims);
for (j = 0; j < ydims[1]; j++) {
if (res) /* zero first n rows */
for (i = 0; i < n; i++) ax[i + j * m] = 0;
else /* zero last m - n rows */
for (i = n; i < m; i++) ax[i + j * m] = 0;
}
/* multiply by Q and apply inverse row permutation */
sparseQR_Qmult(V, beta, p, 0, ax, ydims);
UNPROTECT(1);
return ans;
}
SEXP ddense_band(SEXP x, SEXP k1P, SEXP k2P)
/* Always returns a full matrix with entries outside the band zeroed
* Class of the value can be dtrMatrix or dgeMatrix
*/
{
SEXP aa, ans = PROTECT(dup_mMatrix_as_dgeMatrix(x));
int *adims = INTEGER(GET_SLOT(ans, Matrix_DimSym)),
i, j, k1 = asInteger(k1P), k2 = asInteger(k2P);
int m = adims[0], n = adims[1], sqr = (adims[0] == adims[1]),
tru = (k1 >= 0), trl = (k2 <= 0);
double *ax = REAL(GET_SLOT(ans, Matrix_xSym));
if (k1 > k2)
error(_("Lower band %d > upper band %d"), k1, k2);
for (j = 0; j < n; j++) {
int i1 = j - k2, i2 = j + 1 - k1;
for (i = 0; i < i1; i++) ax[i + j * m] = 0.;
for (i = i2; i < m; i++) ax[i + j * m] = 0.;
}
if (!sqr || (!tru && !trl)) { /* return the dgeMatrix */
UNPROTECT(1);
return ans;
}
/* Copy ans to a dtrMatrix object (must be square) */
/* Because slots of ans are freshly allocated and ans will not be
* used, we use the slots themselves and don't duplicate */
aa = PROTECT(NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
SET_SLOT(aa, Matrix_xSym, GET_SLOT(ans, Matrix_xSym));
SET_SLOT(aa, Matrix_DimSym, GET_SLOT(ans, Matrix_DimSym));
SET_SLOT(aa, Matrix_DimNamesSym, GET_SLOT(ans, Matrix_DimNamesSym));
SET_SLOT(aa, Matrix_diagSym, mkString("N"));
SET_SLOT(aa, Matrix_uploSym, mkString(tru ? "U" : "L"));
UNPROTECT(2);
return aa;
}
SEXP sparseQR_coef(SEXP qr, SEXP y)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(y)),
qslot = GET_SLOT(qr, install("q"));
CSP V = AS_CSP(GET_SLOT(qr, install("V"))),
R = AS_CSP(GET_SLOT(qr, install("R")));
int *ydims = INTEGER(GET_SLOT(ans, Matrix_DimSym)),
*q = INTEGER(qslot),
j, lq = LENGTH(qslot), m = R->m, n = R->n;
double *ax = REAL(GET_SLOT(ans, Matrix_xSym)),
*x = Alloca(m, double);
R_CheckStack();
R_CheckStack();
/* apply row permutation and multiply by Q' */
sparseQR_Qmult(V, REAL(GET_SLOT(qr, install("beta"))),
INTEGER(GET_SLOT(qr, Matrix_pSym)), 1,
REAL(GET_SLOT(ans, Matrix_xSym)), ydims);
for (j = 0; j < ydims[1]; j++) {
double *aj = ax + j * m;
cs_usolve(R, aj);
if (lq) {
cs_ipvec(q, aj, x, n);
Memcpy(aj, x, n);
}
}
UNPROTECT(1);
return ans;
}
/* 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 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;
}
SEXP dgCMatrix_matrix_solve(SEXP Ap, SEXP b, SEXP give_sparse)
// FIXME: add 'keep_dimnames' as argument
{
Rboolean sparse = asLogical(give_sparse);
if(sparse) {
// FIXME: implement this
error(_("dgCMatrix_matrix_solve(.., sparse=TRUE) not yet implemented"));
/* Idea: in the for(j = 0; j < nrhs ..) loop below, build the *sparse* result matrix
* ----- *column* wise -- which is perfect for dgCMatrix
* --> build (i,p,x) slots "increasingly" [well, allocate in batches ..]
*
* --> maybe first a protoype in R
*/
}
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(b)),
lu, qslot;
CSP L, U;
int *bdims = INTEGER(GET_SLOT(ans, Matrix_DimSym)), *p, *q;
int j, n = bdims[0], nrhs = bdims[1];
double *x, *ax = REAL(GET_SLOT(ans, Matrix_xSym));
C_or_Alloca_TO(x, n, double);
if (isNull(lu = get_factors(Ap, "LU"))) {
install_lu(Ap, /* order = */ 1, /* tol = */ 1.0, /* err_sing = */ TRUE,
/* keep_dimnames = */ TRUE);
lu = get_factors(Ap, "LU");
}
qslot = GET_SLOT(lu, install("q"));
L = AS_CSP__(GET_SLOT(lu, install("L")));
U = AS_CSP__(GET_SLOT(lu, install("U")));
R_CheckStack();
if (U->n != n)
error(_("Dimensions of system to be solved are inconsistent"));
if(nrhs >= 1 && n >= 1) {
p = INTEGER(GET_SLOT(lu, Matrix_pSym));
q = LENGTH(qslot) ? INTEGER(qslot) : (int *) NULL;
for (j = 0; j < nrhs; j++) {
cs_pvec(p, ax + j * n, x, n); /* x = b(p) */
cs_lsolve(L, x); /* x = L\x */
cs_usolve(U, x); /* x = U\x */
if (q) /* r(q) = x , hence
r = Q' U{^-1} L{^-1} P b = A^{-1} b */
cs_ipvec(q, x, ax + j * n, n);
else
Memcpy(ax + j * n, x, n);
}
}
if(n >= SMALL_4_Alloca) Free(x);
UNPROTECT(1);
return ans;
}
SEXP sparseQR_qty(SEXP qr, SEXP y, SEXP trans)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(y));
CSP V = AS_CSP(GET_SLOT(qr, install("V")));
R_CheckStack();
sparseQR_Qmult(V, REAL(GET_SLOT(qr, install("beta"))),
INTEGER(GET_SLOT(qr, Matrix_pSym)),
asLogical(trans),
REAL(GET_SLOT(ans, Matrix_xSym)),
INTEGER(GET_SLOT(ans, Matrix_DimSym)));
UNPROTECT(1);
return ans;
}
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 CHMfactor_solve(SEXP a, SEXP b, SEXP system)
{
CHM_FR L = AS_CHM_FR(a);
SEXP bb = PROTECT(dup_mMatrix_as_dgeMatrix(b));
CHM_DN B = AS_CHM_DN(bb), X;
int sys = asInteger(system);
R_CheckStack();
if (!(sys--)) /* align with CHOLMOD defs: R's {1:9} --> {0:8},
see ./CHOLMOD/Cholesky/cholmod_solve.c */
error(_("system argument is not valid"));
X = cholmod_solve(sys, L, B, &c);
UNPROTECT(1);
return chm_dense_to_SEXP(X, 1/*do_free*/, 0/*Rkind*/,
GET_SLOT(bb, Matrix_DimNamesSym), FALSE);
}
SEXP dgeMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b)),
lu = PROTECT(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"));
F77_CALL(dgetrs)("N", &n, &nrhs, REAL(GET_SLOT(lu, Matrix_xSym)), &n,
INTEGER(GET_SLOT(lu, Matrix_permSym)),
REAL(GET_SLOT(val, Matrix_xSym)), &n, &info);
if (info)
error(_("Lapack routine dgetrs: system is exactly singular"));
UNPROTECT(2);
return val;
}
SEXP dsyMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP trf = dsyMatrix_trf(a),
val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym)),
info;
if (*adims != *bdims || bdims[1] < 1 || *adims < 1)
error(_("Dimensions of system to be solved are inconsistent"));
F77_CALL(dsytrs)(uplo_P(trf), adims, bdims + 1,
REAL(GET_SLOT(trf, Matrix_xSym)), adims,
INTEGER(GET_SLOT(trf, Matrix_permSym)),
REAL(GET_SLOT(val, Matrix_xSym)),
bdims, &info);
UNPROTECT(1);
return val;
}
/* Because a must be square, the size of the answer is the same as the
* size of b */
SEXP dtrMatrix_matrix_mm(SEXP a, SEXP b, SEXP right)
{
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int rt = asLogical(right);
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 in %*% must be square"));
if ((rt && (adims[0] != m)) || (!rt && (bdims[0] != m)))
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1)
error(_("Matrices with zero extents cannot be multiplied"));
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_P(a), "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 plasma_dsyMatrix_matrix_mm(SEXP a, SEXP b, SEXP rtP)
{
#ifdef HIPLAR_WITH_PLASMA
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
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.;
double *vx = REAL(GET_SLOT(val, Matrix_xSym));
double *bcp = (double*)malloc(m * n * sizeof(double));
memcpy(bcp, vx, m * n * sizeof(double));
int info;
R_CheckStack();
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Entering plasma_dsyMatrix_matrix_mm");
#endif
if ((rt && n != adims[0]) || (!rt && m != adims[0]))
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
} else {
info = P_dsymm(rt ? "R" :"L", uplo_P(a), m, n, one,
REAL(GET_SLOT(a, Matrix_xSym)), adims[0], bcp,
m, zero, vx, m);
if (info) {
error(_("PLASMA routine %s returned error code %d"), "PLASMA_dsymm", info);
}
}
UNPROTECT(1);
free(bcp);
return val;
#endif
return R_NilValue;
}
/** Matrix products dense triangular Matrices o <matrix>
*
* @param a triangular matrix of class "dtrMatrix"
* @param b a <matrix> or <any-denseMatrix>
* @param right logical, if true, compute b %*% a, else a %*% b
* @param trans logical, if true, "transpose a", i.e., use t(a), otherwise a
*
* @return the matrix product, one of a %*% b, t(a) %*% b, b %*% a, or b %*% t(a)
* depending on (right, trans) = (F, F) (F, T) (T, F) (T, T)
*/
SEXP dtrMatrix_matrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
/* called from "%*%", crossprod() and tcrossprod() in ../R/products.R
*
* 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) {
// Level 3 BLAS - DTRMM() --> see call further below
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);
}
SEXP
dn_a = GET_SLOT( a, Matrix_DimNamesSym),
dn = GET_SLOT(val, Matrix_DimNamesSym);
/* matrix product a %*% b, t(a) %*% b, b %*% a, or b %*% t(a)
* (right, trans) = (F, F) (F, T) (T, F) (T, T)
* set:from_a = 0:0 0:1 1:1 1:0
*/
SET_VECTOR_ELT(dn, rt ? 1 : 0, VECTOR_ELT(dn_a, (rt+tr) % 2));
UNPROTECT(1);
return val;
}
SEXP dsyMatrix_matrix_mm(SEXP a, SEXP b, SEXP rtP)
{
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
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.;
double *vx = REAL(GET_SLOT(val, Matrix_xSym));
double *bcp = Memcpy(Alloca(m * n, double), vx, m * n);
R_CheckStack();
if ((rt && n != adims[0]) || (!rt && m != adims[0]))
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
} else
F77_CALL(dsymm)(rt ? "R" :"L", uplo_P(a), &m, &n, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims, bcp,
&m, &zero, vx, &m);
UNPROTECT(1);
return val;
}
SEXP dtrMatrix_dtrMatrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
/* to be called from "%*%" and crossprod(), tcrossprod(),
* from ../R/products.R
*
* TWO cases : (1) result is triangular <=> uplo are equal
* === (2) result is "general"
*/
SEXP val,/* = in case (2): PROTECT(dup_mMatrix_as_dgeMatrix(b)); */
d_a = GET_SLOT(a, Matrix_DimSym),
uplo_a = GET_SLOT(a, Matrix_uploSym),
diag_a = GET_SLOT(a, Matrix_diagSym);
/* if(rt), compute b %*% a, else a %*% b */
int rt = asLogical(right);
int tr = asLogical(trans);/* if true, use t(a) */
int *adims = INTEGER(d_a), n = adims[0];
double *valx = (double *) NULL /*Wall*/;
const char
*uplo_a_ch = CHAR(STRING_ELT(uplo_a, 0)), /* = uplo_P(a) */
*diag_a_ch = CHAR(STRING_ELT(diag_a, 0)); /* = diag_P(a) */
Rboolean same_uplo = (*uplo_a_ch == *uplo_P(b)),
uDiag_b = /* -Wall: */ FALSE;
if (INTEGER(GET_SLOT(b, Matrix_DimSym))[0] != n)
/* validity checking already "assures" square matrices ... */
error(_("dtrMatrices in %*% must have matching (square) dim."));
if(same_uplo) {
/* ==> result is triangular -- "dtrMatrix" !
* val := dup_mMatrix_as_dtrMatrix(b) : */
int sz = n * n;
val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
SET_SLOT(val, Matrix_uploSym, duplicate(uplo_a));
SET_SLOT(val, Matrix_DimSym, duplicate(d_a));
SET_DimNames(val, b);
valx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, sz));
Memcpy(valx, REAL(GET_SLOT(b, Matrix_xSym)), sz);
if((uDiag_b = *diag_P(b) == 'U')) {
/* unit-diagonal b - may contain garbage in diagonal */
for (int i = 0; i < n; i++)
valx[i * (n+1)] = 1.;
}
} else { /* different "uplo" ==> result is "dgeMatrix" ! */
val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
}
if (n >= 1) {
double alpha = 1.;
/* Level 3 BLAS - DTRMM(): Compute one of the matrix multiplication operations
* B := alpha*op( A )*B ["L"], or B := alpha*B*op( A ) ["R"],
* where trans_A determines op(A):= A "N"one or
* op(A):= t(A) "T"ransposed */
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_a_ch,
/*trans_A = */ tr ? "T" : "N", diag_a_ch, &n, &n, &alpha,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), &n);
}
if(same_uplo) {
make_d_matrix_triangular(valx, a); /* set "other triangle" to 0 */
if(*diag_a_ch == 'U' && uDiag_b) /* result remains uni-diagonal */
SET_SLOT(val, Matrix_diagSym, duplicate(diag_a));
}
UNPROTECT(1);
return val;
}
/** Matrix products of dense triangular Matrices
*
* @param a triangular matrix of class "dtrMatrix"
* @param b ( ditto )
* @param right logical, if true, compute b %*% a, else a %*% b
* @param trans logical, if true, "transpose a", i.e., use t(a), otherwise a
*
* @return the matrix product, one of a %*% b, t(a) %*% b, b %*% a, or b %*% t(a)
* depending on (right, trans) = (F, F) (F, T) (T, F) (T, T)
*/
SEXP dtrMatrix_dtrMatrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
/* called from "%*%" : (x,y, FALSE,FALSE),
crossprod() : (x,y, FALSE, TRUE) , and
tcrossprod(): (y,x, TRUE , TRUE)
* -
* TWO cases : (1) result is triangular <=> uplo's "match" (i.e., non-equal iff trans)
* === (2) result is "general"
*/
SEXP val,/* = in case (2): PROTECT(dup_mMatrix_as_dgeMatrix(b)); */
d_a = GET_SLOT(a, Matrix_DimSym),
uplo_a = GET_SLOT(a, Matrix_uploSym), diag_a = GET_SLOT(a, Matrix_diagSym),
uplo_b = GET_SLOT(b, Matrix_uploSym), diag_b = GET_SLOT(b, Matrix_diagSym);
int rt = asLogical(right);
int tr = asLogical(trans);
int *adims = INTEGER(d_a), n = adims[0];
double *valx = (double *) NULL /*Wall*/;
const char
*uplo_a_ch = CHAR(STRING_ELT(uplo_a, 0)), /* = uplo_P(a) */
*diag_a_ch = CHAR(STRING_ELT(diag_a, 0)), /* = diag_P(a) */
*uplo_b_ch = CHAR(STRING_ELT(uplo_b, 0)), /* = uplo_P(b) */
*diag_b_ch = CHAR(STRING_ELT(diag_b, 0)); /* = diag_P(b) */
Rboolean same_uplo = (*uplo_a_ch == *uplo_b_ch),
matching_uplo = tr ? (!same_uplo) : same_uplo,
uDiag_b = /* -Wall: */ FALSE;
if (INTEGER(GET_SLOT(b, Matrix_DimSym))[0] != n)
/* validity checking already "assures" square matrices ... */
error(_("\"dtrMatrix\" objects in '%*%' must have matching (square) dimension"));
if(matching_uplo) {
/* ==> result is triangular -- "dtrMatrix" !
* val := dup_mMatrix_as_dtrMatrix(b) : */
int sz = n * n;
val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtrMatrix")));
SET_SLOT(val, Matrix_uploSym, duplicate(uplo_b));
SET_SLOT(val, Matrix_DimSym, duplicate(d_a));
SET_DimNames(val, b);
valx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, sz));
Memcpy(valx, REAL(GET_SLOT(b, Matrix_xSym)), sz);
if((uDiag_b = (*diag_b_ch == 'U'))) {
/* unit-diagonal b - may contain garbage in diagonal */
for (int i = 0; i < n; i++)
valx[i * (n+1)] = 1.;
}
} else { /* different "uplo" ==> result is "dgeMatrix" ! */
val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
SEXP
dn_a = GET_SLOT( a , Matrix_DimNamesSym),
dn = GET_SLOT(val, Matrix_DimNamesSym);
/* matrix product a %*% b, t(a) %*% b, b %*% a, or b %*% t(a)
* (right, trans) = (F, F) (F, T) (T, F) (T, T)
* set:from_a = 0:0 0:1 1:1 1:0
*/
SET_VECTOR_ELT(dn, rt ? 1 : 0, VECTOR_ELT(dn_a, (rt+tr) % 2));
}
if (n >= 1) {
double alpha = 1.;
/* Level 3 BLAS - DTRMM(): Compute one of the matrix multiplication operations
* B := alpha*op( A )*B ["L"], or B := alpha*B*op( A ) ["R"],
* where trans_A determines op(A):= A "N"one or
* op(A):= t(A) "T"ransposed */
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_a_ch,
/*trans_A = */ tr ? "T" : "N", diag_a_ch, &n, &n, &alpha,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), &n);
}
if(matching_uplo) {
make_d_matrix_triangular(valx, tr ? b : a); /* set "other triangle" to 0 */
if(*diag_a_ch == 'U' && uDiag_b) /* result remains uni-diagonal */
SET_SLOT(val, Matrix_diagSym, duplicate(diag_a));
}
UNPROTECT(1);
return val;
}
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;
}
