SCM

SCM Repository

[matrix] Diff of /pkg/src/dpoMatrix.c
ViewVC logotype

Diff of /pkg/src/dpoMatrix.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 341, Fri Nov 12 21:20:14 2004 UTC revision 342, Mon Nov 15 13:55:52 2004 UTC
# Line 2  Line 2 
2    
3  SEXP poMatrix_chol(SEXP x)  SEXP poMatrix_chol(SEXP x)
4  {  {
5      SEXP val = get_factorization(x, "Cholesky");      SEXP val = get_factorization(x, "Cholesky"),
6            dimP = GET_SLOT(x, Matrix_DimSym),
7            uploP = GET_SLOT(x, Matrix_uploSym);
8      int *dims, info;      int *dims, info;
9    
10      if (val != R_NilValue) return val;      if (val != R_NilValue) return val;
11      dims = INTEGER(GET_SLOT(x, Matrix_DimSym));      dims = INTEGER(dimP);
12      val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky")));      val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky")));
13      SET_SLOT(val, install("uplo"), duplicate(GET_SLOT(x, install("uplo"))));      SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
14        SET_SLOT(val, Matrix_diagSym, ScalarString(mkChar("N")));
15        SET_SLOT(val, Matrix_rcondSym, allocVector(REALSXP, 0));
16        SET_SLOT(val, Matrix_factorization, allocVector(VECSXP, 0));
17      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(x, Matrix_xSym)));      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(x, Matrix_xSym)));
18      SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(x, Matrix_DimSym)));      SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
19      F77_CALL(dpotrf)(CHAR(asChar(GET_SLOT(val, Matrix_uploSym))), dims,      F77_CALL(dpotrf)(CHAR(asChar(uploP)), dims,
20                       REAL(GET_SLOT(val, Matrix_xSym)), dims, &info);                       REAL(GET_SLOT(val, Matrix_xSym)), dims, &info);
21      if (info) error("Lapack routine dpotrf returned error code %d", info);      if (info) error("Lapack routine dpotrf returned error code %d", info);
22      UNPROTECT(1);      UNPROTECT(1);
# Line 22  Line 27 
27  double set_rcond(SEXP obj, char *typstr)  double set_rcond(SEXP obj, char *typstr)
28  {  {
29      char typnm[] = {'O', '\0'}; /* always use the one norm */      char typnm[] = {'O', '\0'}; /* always use the one norm */
30      SEXP rcv = GET_SLOT(obj, install("rcond"));      SEXP rcv = GET_SLOT(obj, Matrix_rcondSym);
31      double rcond = get_double_by_name(rcv, typnm);      double rcond = get_double_by_name(rcv, typnm);
32    
33      if (R_IsNA(rcond)) {      if (R_IsNA(rcond)) {
# Line 35  Line 40 
40                           dims, &anorm, &rcond,                           dims, &anorm, &rcond,
41                           (double *) R_alloc(3*dims[0], sizeof(double)),                           (double *) R_alloc(3*dims[0], sizeof(double)),
42                           (int *) R_alloc(dims[0], sizeof(int)), &info);                           (int *) R_alloc(dims[0], sizeof(int)), &info);
43          SET_SLOT(obj, install("rcond"),          SET_SLOT(obj, Matrix_rcondSym,
44                   set_double_by_name(rcv, rcond, typnm));                   set_double_by_name(rcv, rcond, typnm));
45      }      }
46      return rcond;      return rcond;
# Line 52  Line 57 
57      SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("poMatrix")));      SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("poMatrix")));
58      int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), info;      int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), info;
59    
60      SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(x, Matrix_uploSym)));      SET_SLOT(val, Matrix_factorization, allocVector(VECSXP, 0));
61        SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(Chol, Matrix_uploSym)));
62      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(Chol, Matrix_xSym)));      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(Chol, Matrix_xSym)));
63      SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(x, Matrix_DimSym)));      SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(Chol, Matrix_DimSym)));
64      F77_CALL(dpotri)(CHAR(asChar(GET_SLOT(val, Matrix_uploSym))),      F77_CALL(dpotri)(CHAR(asChar(GET_SLOT(val, Matrix_uploSym))),
65                       dims, REAL(GET_SLOT(val, Matrix_xSym)), dims, &info);                       dims, REAL(GET_SLOT(val, Matrix_xSym)), dims, &info);
66        SET_SLOT(val, Matrix_rcondSym, duplicate(GET_SLOT(x, Matrix_rcondSym)));
67      UNPROTECT(1);      UNPROTECT(1);
68      return val;      return val;
69  }  }
# Line 71  Line 78 
78    
79      if (*adims != *bdims || bdims[1] < 1 || *adims < 1)      if (*adims != *bdims || bdims[1] < 1 || *adims < 1)
80          error("Dimensions of system to be solved are inconsistent");          error("Dimensions of system to be solved are inconsistent");
81        SET_SLOT(val, Matrix_rcondSym, allocVector(REALSXP, 0));
82        SET_SLOT(val, Matrix_factorization, allocVector(VECSXP, 0));
83      SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(b, Matrix_DimSym)));      SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(b, Matrix_DimSym)));
84      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(b, Matrix_xSym)));      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(b, Matrix_xSym)));
85      F77_CALL(dpotrs)(CHAR(asChar(GET_SLOT(Chol, Matrix_uploSym))),      F77_CALL(dpotrs)(CHAR(asChar(GET_SLOT(Chol, Matrix_uploSym))),

Legend:
Removed from v.341  
changed lines
  Added in v.342

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge