The R Project SVN R-packages

Rev

Rev 1190 | Rev 1877 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 1190 Rev 1278
Line 16... Line 16...
16 
SEXP dpoMatrix_chol(SEXP x)
 16 
SEXP dpoMatrix_chol(SEXP x)
17 
{
 17 
{
18 
    SEXP val = get_factors(x, "Cholesky"),
 18 
    SEXP val = get_factors(x, "Cholesky"),
19 
	dimP = GET_SLOT(x, Matrix_DimSym),
 19 
	dimP = GET_SLOT(x, Matrix_DimSym),
20 
	uploP = GET_SLOT(x, Matrix_uploSym);
 20 
	uploP = GET_SLOT(x, Matrix_uploSym);
- 
 
 21 
    char *uplo = CHAR(STRING_ELT(uploP, 0));
- 
 
 22 
    int *dims = INTEGER(dimP), info;
21 
    int *dims, info;
 23 
    int n = dims[0];
- 
 
 24 
    double *vx;
22 
 
 25 
 
23 
    if (val != R_NilValue) return val;
 26 
    if (val != R_NilValue) return val;
24 
    dims = INTEGER(dimP);
 27 
    dims = INTEGER(dimP);
25 
    val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky")));
 28 
    val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky")));
26 
    SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
 29 
    SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
27 
    SET_SLOT(val, Matrix_diagSym, mkString("N"));
 30 
    SET_SLOT(val, Matrix_diagSym, mkString("N"));
28 
    SET_SLOT(val, Matrix_rcondSym, allocVector(REALSXP, 0));
 - 
 
29 
    SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
 - 
 
30 
    SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(x, Matrix_xSym)));
 - 
 
31 
    SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
 31 
    SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
32 
    F77_CALL(dpotrf)(CHAR(asChar(uploP)), dims,
 32 
    vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n));
- 
 
 33 
    AZERO(vx, n * n);
33 
		     REAL(GET_SLOT(val, Matrix_xSym)), dims, &info);
 34 
    F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
- 
 
 35 
    F77_CALL(dpotrf)(uplo, &n, vx, &n, &info);
34 
    if (info) error(_("Lapack routine dpotrf returned error code %d"), info);
 36 
    if (info) error(_("Lapack routine %s returned error code %d"), "dpotrf", info);
35 
    UNPROTECT(1);
 37 
    UNPROTECT(1);
36 
    return set_factors(x, val, "Cholesky");
 38 
    return set_factors(x, val, "Cholesky");
37 
}
 39 
}
38 
 
 40 
 
39 
static
 41 
static
Line 59... Line 61...
59 
    return rcond;
 61 
    return rcond;
60 
}
 62 
}
61 
 
 63 
 
62 
SEXP dpoMatrix_rcond(SEXP obj, SEXP type)
 64 
SEXP dpoMatrix_rcond(SEXP obj, SEXP type)
63 
{
 65 
{
64 
  return ScalarReal(set_rcond(obj, CHAR(asChar(type))));
 66 
    return ScalarReal(set_rcond(obj, CHAR(asChar(type))));
65 
}
 67 
}
66 
 
 68 
 
67 
SEXP dpoMatrix_solve(SEXP x)
 69 
SEXP dpoMatrix_solve(SEXP x)
68 
{
 70 
{
69 
    SEXP Chol = dpoMatrix_chol(x);
 71 
    SEXP Chol = dpoMatrix_chol(x);