SCM

SCM Repository

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

Diff of /pkg/src/dtrMatrix.c

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

revision 70, Mon Apr 12 12:10:01 2004 UTC revision 296, Mon Oct 4 17:13:29 2004 UTC
# Line 35  Line 35 
35          work = (double *) R_alloc(dims[0], sizeof(double));          work = (double *) R_alloc(dims[0], sizeof(double));
36      }      }
37      return F77_CALL(dlantr)(typnm,      return F77_CALL(dlantr)(typnm,
38                              CHAR(asChar(GET_SLOT(obj, install("uplo")))),                              CHAR(asChar(GET_SLOT(obj, Matrix_uploSym))),
39                              CHAR(asChar(GET_SLOT(obj, install("diag")))),                              CHAR(asChar(GET_SLOT(obj, Matrix_diagSym))),
40                              dims, dims+1,                              dims, dims+1,
41                              REAL(GET_SLOT(obj, install("x"))),                              REAL(GET_SLOT(obj, Matrix_xSym)),
42                              dims, work);                              dims, work);
43  }  }
44    
# Line 59  Line 59 
59      if (R_IsNA(rcond)) {      if (R_IsNA(rcond)) {
60          int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;          int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;
61          F77_CALL(dtrcon)(typnm,          F77_CALL(dtrcon)(typnm,
62                           CHAR(asChar(GET_SLOT(obj, install("uplo")))),                           CHAR(asChar(GET_SLOT(obj, Matrix_uploSym))),
63                           CHAR(asChar(GET_SLOT(obj, install("diag")))),                           CHAR(asChar(GET_SLOT(obj, Matrix_diagSym))),
64                           dims, REAL(GET_SLOT(obj, install("x"))),                           dims, REAL(GET_SLOT(obj, Matrix_xSym)),
65                           dims, &rcond,                           dims, &rcond,
66                           (double *) R_alloc(3*dims[0], sizeof(double)),                           (double *) R_alloc(3*dims[0], sizeof(double)),
67                           (int *) R_alloc(dims[0], sizeof(int)), &info);                           (int *) R_alloc(dims[0], sizeof(int)), &info);
# Line 80  Line 80 
80  {  {
81      SEXP val = PROTECT(duplicate(a));      SEXP val = PROTECT(duplicate(a));
82      int info, *Dim = INTEGER(GET_SLOT(val, Matrix_DimSym));      int info, *Dim = INTEGER(GET_SLOT(val, Matrix_DimSym));
83      F77_CALL(dtrtri)(CHAR(asChar(GET_SLOT(val, install("uplo")))),      F77_CALL(dtrtri)(CHAR(asChar(GET_SLOT(val, Matrix_uploSym))),
84                       CHAR(asChar(GET_SLOT(val, install("diag")))),                       CHAR(asChar(GET_SLOT(val, Matrix_diagSym))),
85                       Dim, REAL(GET_SLOT(val, install("x"))), Dim, &info);                       Dim, REAL(GET_SLOT(val, Matrix_xSym)), Dim, &info);
86        UNPROTECT(1);
87        return val;
88    }
89    
90    SEXP trMatrix_matrix_solve(SEXP a, SEXP b)
91    {
92        SEXP val = PROTECT(duplicate(b));
93        int *Dim = INTEGER(GET_SLOT(a, Matrix_DimSym)),
94            *bDim = INTEGER(getAttrib(val, R_DimSymbol));
95        double one = 1.0;
96    
97        if (bDim[0] != Dim[1])
98            error("Dimensions of a (%d,%d) and b (%d,%d) do not conform",
99                  Dim[0], Dim[1], bDim[0], bDim[1]);
100        F77_CALL(dtrsm)("L", CHAR(asChar(GET_SLOT(val, Matrix_uploSym))),
101                        "N", CHAR(asChar(GET_SLOT(val, Matrix_diagSym))),
102                        bDim, bDim+1, &one,
103                        REAL(GET_SLOT(a, Matrix_xSym)), Dim,
104                        REAL(val), bDim);
105      UNPROTECT(1);      UNPROTECT(1);
106      return val;      return val;
107  }  }
# Line 92  Line 111 
111      int i, j, *dims = INTEGER(GET_SLOT(from, Matrix_DimSym));      int i, j, *dims = INTEGER(GET_SLOT(from, Matrix_DimSym));
112      int n = dims[0], m = dims[1];      int n = dims[0], m = dims[1];
113    
114      if (toupper(*CHAR(asChar(GET_SLOT(from, install("uplo"))))) == 'U') {      if (toupper(*CHAR(asChar(GET_SLOT(from, Matrix_uploSym)))) == 'U') {
115          for (j = 0; j < n; j++) {          for (j = 0; j < n; j++) {
116              for (i = j+1; i < m; i++) {              for (i = j+1; i < m; i++) {
117                  to[i + j*m] = 0.;                  to[i + j*m] = 0.;
# Line 105  Line 124 
124              }              }
125          }          }
126      }      }
127      if (toupper(*CHAR(asChar(GET_SLOT(from, install("diag"))))) == 'U') {      if (toupper(*CHAR(asChar(GET_SLOT(from, Matrix_diagSym)))) == 'U') {
128          j = (n < m) ? n : m;          j = (n < m) ? n : m;
129          for (i = 0; i < j; i++) {          for (i = 0; i < j; i++) {
130              to[i * (m + 1)] = 1.;              to[i * (m + 1)] = 1.;
# Line 119  Line 138 
138    
139      SET_SLOT(val, install("rcond"),      SET_SLOT(val, install("rcond"),
140               duplicate(GET_SLOT(from, install("rcond"))));               duplicate(GET_SLOT(from, install("rcond"))));
141      SET_SLOT(val, install("x"), duplicate(GET_SLOT(from, install("x"))));      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(from, Matrix_xSym)));
142      SET_SLOT(val, Matrix_DimSym,      SET_SLOT(val, Matrix_DimSym,
143               duplicate(GET_SLOT(from, Matrix_DimSym)));               duplicate(GET_SLOT(from, Matrix_DimSym)));
144      make_array_triangular(REAL(GET_SLOT(val, install("x"))), from);      make_array_triangular(REAL(GET_SLOT(val, Matrix_xSym)), from);
145      UNPROTECT(1);      UNPROTECT(1);
146      return val;      return val;
147  }  }
# Line 134  Line 153 
153      SEXP val = PROTECT(allocMatrix(REALSXP, m, n));      SEXP val = PROTECT(allocMatrix(REALSXP, m, n));
154    
155      make_array_triangular(Memcpy(REAL(val),      make_array_triangular(Memcpy(REAL(val),
156                                   REAL(GET_SLOT(from, install("x"))), m * n),                                   REAL(GET_SLOT(from, Matrix_xSym)), m * n),
157                            from);                            from);
158      UNPROTECT(1);      UNPROTECT(1);
159      return val;      return val;
# Line 144  Line 163 
163  {  {
164      int i, n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0];      int i, n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0];
165      SEXP ret = PROTECT(allocVector(REALSXP, n)),      SEXP ret = PROTECT(allocVector(REALSXP, n)),
166          xv = GET_SLOT(x, install("x"));          xv = GET_SLOT(x, Matrix_xSym);
167    
168      if ('U' == toupper(CHAR(STRING_ELT(GET_SLOT(x, install("diag")), 0))[0])) {      if ('U' == toupper(CHAR(STRING_ELT(GET_SLOT(x, Matrix_diagSym), 0))[0])) {
169          for (i = 0; i < n; i++) REAL(ret)[i] = 1.;          for (i = 0; i < n; i++) REAL(ret)[i] = 1.;
170      } else {      } else {
171          for (i = 0; i < n; i++) {          for (i = 0; i < n; i++) {

Legend:
Removed from v.70  
changed lines
  Added in v.296

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