SEXP dgeMatrix_determinant(SEXP x, SEXP logarithm)
{
int lg = asLogical(logarithm);
int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
n = dims[0], sign = 1;
double modulus = lg ? 0. : 1; /* initialize; = result for n == 0 */
if (n != dims[1])
error(_("Determinant requires a square matrix"));
if (n > 0) {
SEXP lu = dgeMatrix_LU_(x, /* do not warn about singular LU: */ FALSE);
int i, *jpvt = INTEGER(GET_SLOT(lu, Matrix_permSym));
double *luvals = REAL(GET_SLOT(lu, Matrix_xSym));
for (i = 0; i < n; i++) if (jpvt[i] != (i + 1)) sign = -sign;
if (lg) {
for (i = 0; i < n; i++) {
double dii = luvals[i*(n + 1)]; /* ith diagonal element */
modulus += log(dii < 0 ? -dii : dii);
if (dii < 0) sign = -sign;
}
} else {
for (i = 0; i < n; i++)
modulus *= luvals[i*(n + 1)];
if (modulus < 0) {
modulus = -modulus;
sign = -sign;
}
}
}
return as_det_obj(modulus, lg, sign);
}
SEXP dgeMatrix_solve(SEXP a)
{
/* compute the 1-norm of the matrix, which is needed
later for the computation of the reciprocal condition number. */
double aNorm = get_norm(a, "1");
/* the LU decomposition : */
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))),
lu = dgeMatrix_LU_(a, TRUE);
int *dims = INTEGER(GET_SLOT(lu, Matrix_DimSym)),
*pivot = INTEGER(GET_SLOT(lu, Matrix_permSym));
/* prepare variables for the dgetri calls */
double *x, tmp;
int info, lwork = -1;
if (dims[0] != dims[1]) error(_("Solve requires a square matrix"));
slot_dup(val, lu, Matrix_xSym);
x = REAL(GET_SLOT(val, Matrix_xSym));
slot_dup(val, lu, Matrix_DimSym);
if(dims[0]) /* the dimension is not zero */
{
/* is the matrix is *computationally* singular ? */
double rcond;
F77_CALL(dgecon)("1", dims, x, dims, &aNorm, &rcond,
(double *) R_alloc(4*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
if (info)
error(_("error [%d] from Lapack 'dgecon()'"), info);
if(rcond < DOUBLE_EPS)
error(_("Lapack dgecon(): system computationally singular, reciprocal condition number = %g"),
rcond);
/* only now try the inversion and check if the matrix is *exactly* singular: */
F77_CALL(dgetri)(dims, x, dims, pivot, &tmp, &lwork, &info);
lwork = (int) tmp;
F77_CALL(dgetri)(dims, x, dims, pivot,
(double *) R_alloc((size_t) lwork, sizeof(double)),
&lwork, &info);
if (info)
error(_("Lapack routine dgetri: system is exactly singular"));
}
UNPROTECT(1);
return val;
}
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 dgeMatrix_rcond(SEXP obj, SEXP type)
{
SEXP LU = PROTECT(dgeMatrix_LU_(obj, FALSE));/* <- not warning about singularity */
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(LU, Matrix_DimSym)), info;
double anorm, rcond;
if (dims[0] != dims[1] || dims[0] < 1) {
UNPROTECT(1);
error(_("rcond requires a square, non-empty matrix"));
}
typnm[0] = La_rcond_type(CHAR(asChar(type)));
anorm = get_norm(obj, typnm);
F77_CALL(dgecon)(typnm,
dims, REAL(GET_SLOT(LU, Matrix_xSym)),
dims, &anorm, &rcond,
(double *) R_alloc(4*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
UNPROTECT(1);
return ScalarReal(rcond);
}
SEXP dgeMatrix_solve(SEXP a)
{
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))),
lu = dgeMatrix_LU_(a, TRUE);
int *dims = INTEGER(GET_SLOT(lu, Matrix_DimSym)),
*pivot = INTEGER(GET_SLOT(lu, Matrix_permSym));
double *x, tmp;
int info, lwork = -1;
if (dims[0] != dims[1]) error(_("Solve requires a square matrix"));
slot_dup(val, lu, Matrix_xSym);
x = REAL(GET_SLOT(val, Matrix_xSym));
slot_dup(val, lu, Matrix_DimSym);
F77_CALL(dgetri)(dims, x, dims, pivot, &tmp, &lwork, &info);
lwork = (int) tmp;
F77_CALL(dgetri)(dims, x, dims, pivot,
(double *) R_alloc((size_t) lwork, sizeof(double)),
&lwork, &info);
if (info)
error(_("Lapack routine dgetri: system is exactly singular"));
UNPROTECT(1);
return val;
}
SEXP dgeMatrix_LU(SEXP x, SEXP warn_singularity)
{
dgeMatrix_LU_(x, asLogical(warn_singularity));
}