The R Project SVN R-packages

Rev

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

Rev 1261 Rev 1273
Line 41... Line 41...
41 
    double rcond;
 41 
    double rcond;
42 
 
 42 
 
43 
    typnm[0] = rcond_type(typstr);
 43 
    typnm[0] = rcond_type(typstr);
44 
    rcond = get_double_by_name(rcv, typnm);
 44 
    rcond = get_double_by_name(rcv, typnm);
45 
 
 45 
 
46 
/* FIXME: Need a factorization here. */
 - 
 
47 
    if (R_IsNA(rcond)) {
 46 
    if (R_IsNA(rcond)) {
- 
 
 47 
	SEXP trf = dsyMatrix_trf(obj);
48 
	int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;
 48 
	int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;
49 
	double anorm = get_norm_sy(obj, "O");
 49 
	double anorm = get_norm_sy(obj, "O");
50 
 
 50 
 
51 
	error(_("Code for set_rcond_sy not yet written"));
 - 
 
52 
	F77_CALL(dsycon)(CHAR(asChar(GET_SLOT(obj, Matrix_uploSym))),
 51 
	F77_CALL(dsycon)(CHAR(asChar(GET_SLOT(trf, Matrix_uploSym))),
53 
			 dims, REAL(GET_SLOT(obj, Matrix_xSym)),
 52 
			 dims, REAL(GET_SLOT(trf, Matrix_xSym)),
54 
			 dims, INTEGER(GET_SLOT(obj, install("pivot"))),
 53 
			 dims, INTEGER(GET_SLOT(trf, Matrix_permSym)),
55 
			 &anorm, &rcond,
 54 
			 &anorm, &rcond,
56 
			 (double *) R_alloc(2*dims[0], sizeof(double)),
 55 
			 (double *) R_alloc(2*dims[0], sizeof(double)),
57 
			 (int *) R_alloc(dims[0], sizeof(int)), &info);
 56 
			 (int *) R_alloc(dims[0], sizeof(int)), &info);
58 
	SET_SLOT(obj, Matrix_rcondSym,
 57 
	SET_SLOT(obj, Matrix_rcondSym,
59 
		 set_double_by_name(rcv, rcond, typnm));
 58 
		 set_double_by_name(rcv, rcond, typnm));
Line 61... Line 60...
61 
    return rcond;
 60 
    return rcond;
62 
}
 61 
}
63 
 
 62 
 
64 
SEXP dsyMatrix_rcond(SEXP obj, SEXP type)
 63 
SEXP dsyMatrix_rcond(SEXP obj, SEXP type)
65 
{
 64 
{
66 
/* FIXME: This is a stub */
 - 
 
67 
/*     return ScalarReal(set_rcond_sy(obj, CHAR(asChar(type)))); */
 65 
    return ScalarReal(set_rcond_sy(obj, CHAR(asChar(type))));
68 
    return ScalarReal(NA_REAL);
 - 
 
69 
}
 66 
}
70 
 
 67 
 
71 
static
 68 
static
72 
void make_symmetric(double *to, SEXP from, int n)
 69 
void make_symmetric(double *to, SEXP from, int n)
73 
{
 70 
{
Line 87... Line 84...
87 
    }
 84 
    }
88 
}
 85 
}
89 
 
 86 
 
90 
SEXP dsyMatrix_solve(SEXP a)
 87 
SEXP dsyMatrix_solve(SEXP a)
91 
{
 88 
{
92 
/* FIXME: Write the code */
 89 
    SEXP trf = dsyMatrix_trf(a);
- 
 
 90 
    SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dsyMatrix")));
- 
 
 91 
    int *dims = INTEGER(GET_SLOT(trf, Matrix_DimSym)), info;
- 
 
 92 
 
- 
 
 93 
    SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(trf, Matrix_uploSym)));
- 
 
 94 
    SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(trf, Matrix_xSym)));
- 
 
 95 
    SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(trf, Matrix_DimSym)));
- 
 
 96 
    SET_SLOT(val, Matrix_rcondSym, duplicate(GET_SLOT(a, Matrix_rcondSym)));
- 
 
 97 
    F77_CALL(dsytri)(CHAR(asChar(GET_SLOT(val, Matrix_uploSym))),
- 
 
 98 
		     dims, REAL(GET_SLOT(val, Matrix_xSym)), dims,
- 
 
 99 
		     INTEGER(GET_SLOT(trf, Matrix_permSym)),
- 
 
 100 
		     (double *) R_alloc((long) dims[0], sizeof(double)),
- 
 
 101 
		     &info);
- 
 
 102 
    UNPROTECT(1);
- 
 
 103 
    return val;
- 
 
 104 
}
- 
 
 105 
 
- 
 
 106 
SEXP dsyMatrix_dgeMatrix_solve(SEXP a, SEXP b)
- 
 
 107 
{
- 
 
 108 
    SEXP trf = dsyMatrix_trf(a),
- 
 
 109 
	val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
- 
 
 110 
    int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
- 
 
 111 
	*bdims = INTEGER(GET_SLOT(b, Matrix_DimSym)),
- 
 
 112 
	info;
- 
 
 113 
 
- 
 
 114 
    if (*adims != *bdims || bdims[1] < 1 || *adims < 1)
93 
    error(_("code for dsyMatrix_solve not yet written"));
 115 
	error(_("Dimensions of system to be solved are inconsistent"));
- 
 
 116 
    SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(b, Matrix_DimSym)));
- 
 
 117 
    SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(b, Matrix_xSym)));
- 
 
 118 
    F77_CALL(dsytrs)(CHAR(asChar(GET_SLOT(trf, Matrix_uploSym))),
- 
 
 119 
		     adims, bdims + 1,
- 
 
 120 
		     REAL(GET_SLOT(trf, Matrix_xSym)), adims,
- 
 
 121 
		     INTEGER(GET_SLOT(trf, Matrix_permSym)),
- 
 
 122 
		     REAL(GET_SLOT(val, Matrix_xSym)),
- 
 
 123 
		     bdims, &info);
- 
 
 124 
    UNPROTECT(1);
94 
    return R_NilValue;
 125 
    return val;
95 
}
 126 
}
96 
 
 127 
 
97 
SEXP dsyMatrix_matrix_solve(SEXP a, SEXP b)
 128 
SEXP dsyMatrix_matrix_solve(SEXP a, SEXP b)
98 
{
 129 
{
99 
/* FIXME: Write the code */
 130 
    SEXP trf = dsyMatrix_trf(a),
- 
 
 131 
	val = PROTECT(duplicate(b));
- 
 
 132 
    int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
- 
 
 133 
	*bdims = INTEGER(getAttrib(b, R_DimSymbol)),
- 
 
 134 
	info;
- 
 
 135 
 
- 
 
 136 
    if (!(isReal(b) && isMatrix(b)))
- 
 
 137 
	error(_("Argument b must be a numeric matrix"));
- 
 
 138 
    if (*adims != *bdims || bdims[1] < 1 || *adims < 1)
100 
    error(_("code for dsyMatrix_matrix_solve not yet written"));
 139 
	error(_("Dimensions of system to be solved are inconsistent"));
- 
 
 140 
    F77_CALL(dsytrs)(CHAR(asChar(GET_SLOT(trf, Matrix_uploSym))),
- 
 
 141 
		     adims, bdims + 1,
- 
 
 142 
		     REAL(GET_SLOT(trf, Matrix_xSym)), adims,
- 
 
 143 
		     INTEGER(GET_SLOT(trf, Matrix_permSym)),
- 
 
 144 
		     REAL(val), bdims, &info);
- 
 
 145 
    UNPROTECT(1);
101 
    return R_NilValue;
 146 
    return val;
102 
}
 147 
}
103 
 
 148 
 
104 
SEXP dsyMatrix_as_dgeMatrix(SEXP from)
 149 
SEXP dsyMatrix_as_dgeMatrix(SEXP from)
105 
{
 150 
{
106 
    SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))),
 151 
    SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix"))),
Line 215... Line 260...
215 
    UNPROTECT(1);
 260 
    UNPROTECT(1);
216 
    Free(work);
 261 
    Free(work);
217 
    return set_factors(x, val, "BunchKaufman");
 262 
    return set_factors(x, val, "BunchKaufman");
218 
}
 263 
}
219 
 
 264 
 
- 
 
 265 
SEXP dsyMatrix_as_dspMatrix(SEXP from)
- 
 
 266 
{
- 
 
 267 
    SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dspMatrix"))),
- 
 
 268 
	uplo = GET_SLOT(from, Matrix_uploSym),
- 
 
 269 
	dimP = GET_SLOT(from, Matrix_DimSym);
- 
 
 270 
    int n = *INTEGER(dimP);
- 
 
 271 
 
- 
 
 272 
    SET_SLOT(val, Matrix_rcondSym,
- 
 
 273 
	     duplicate(GET_SLOT(from, Matrix_rcondSym)));
- 
 
 274 
    SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
- 
 
 275 
    SET_SLOT(val, Matrix_uploSym, duplicate(uplo));
- 
 
 276 
    full_to_packed(REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, (n*(n+1))/2)),
- 
 
 277 
		   REAL(GET_SLOT(from, Matrix_xSym)), n,
- 
 
 278 
		   *CHAR(STRING_ELT(uplo, 0)) == 'U' ? UPP : LOW, NUN);
- 
 
 279 
    UNPROTECT(1);
- 
 
 280 
    return val;
- 
 
 281 
}