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;
}
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 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 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;
}
SEXP dsyMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP trf = dsyMatrix_trf(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(dsytrs)(uplo_P(trf), adims, bdims + 1,
REAL(GET_SLOT(trf, Matrix_xSym)), adims,
INTEGER(GET_SLOT(trf, Matrix_permSym)),
REAL(val), bdims, &info);
UNPROTECT(1);
return val;
}
