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 581, Mon Feb 28 15:13:13 2005 UTC revision 582, Mon Feb 28 18:15:21 2005 UTC
# Line 13  Line 13 
13      char *val;      char *val;
14    
15      if (length(uplo) != 1)      if (length(uplo) != 1)
16          return mkString("'uplo' slot must have length 1");          return mkString(_("'uplo' slot must have length 1"));
17      if (length(diag) != 1)      if (length(diag) != 1)
18          return mkString("'diag' slot must have length 1");          return mkString(_("'diag' slot must have length 1"));
19      val = CHAR(STRING_ELT(uplo, 0));      val = CHAR(STRING_ELT(uplo, 0));
20      if (strlen(val) != 1)      if (strlen(val) != 1)
21          return mkString("'uplo' must have string length 1");          return mkString(_("'uplo' must have string length 1"));
22      if (*val != 'U' && *val != 'L')      if (*val != 'U' && *val != 'L')
23          return mkString("'uplo' must be \"U\" or \"L\"");          return mkString(_("'uplo' must be \"U\" or \"L\""));
24      val = CHAR(STRING_ELT(diag, 0));      val = CHAR(STRING_ELT(diag, 0));
25      if (strlen(val) != 1)      if (strlen(val) != 1)
26          return mkString("'diag' must have string length 1");          return mkString(_("'diag' must have string length 1"));
27      if (*val != 'U' && *val != 'N')      if (*val != 'U' && *val != 'N')
28          return mkString("'diag' must be \"U\" or \"N\"");          return mkString(_("'diag' must be \"U\" or \"N\""));
29      return ScalarLogical(1);      return ScalarLogical(1);
30  }  }
31    
# Line 101  Line 101 
101      double one = 1.0;      double one = 1.0;
102    
103      if (bDim[0] != Dim[1])      if (bDim[0] != Dim[1])
104          error("Dimensions of a (%d,%d) and b (%d,%d) do not conform",          error(_("Dimensions of a (%d,%d) and b (%d,%d) do not conform"),
105                Dim[0], Dim[1], bDim[0], bDim[1]);                Dim[0], Dim[1], bDim[0], bDim[1]);
106      F77_CALL(dtrsm)("L", CHAR(asChar(GET_SLOT(val, Matrix_uploSym))),      F77_CALL(dtrsm)("L", CHAR(asChar(GET_SLOT(val, Matrix_uploSym))),
107                      "N", CHAR(asChar(GET_SLOT(val, Matrix_diagSym))),                      "N", CHAR(asChar(GET_SLOT(val, Matrix_diagSym))),
# Line 112  Line 112 
112      return val;      return val;
113  }  }
114    
 void make_array_triangular(double *to, SEXP from)  
 {  
     int i, j, *dims = INTEGER(GET_SLOT(from, Matrix_DimSym));  
     int n = dims[0], m = dims[1];  
   
     if (*CHAR(asChar(GET_SLOT(from, Matrix_uploSym))) == 'U') {  
         for (j = 0; j < n; j++) {  
             for (i = j+1; i < m; i++) {  
                 to[i + j*m] = 0.;  
             }  
         }  
     } else {  
         for (j = 1; j < n; j++) {  
             for (i = 0; i < j && i < m; i++) {  
                 to[i + j*m] = 0.;  
             }  
         }  
     }  
     if (*CHAR(asChar(GET_SLOT(from, Matrix_diagSym))) == 'U') {  
         j = (n < m) ? n : m;  
         for (i = 0; i < j; i++) {  
             to[i * (m + 1)] = 1.;  
         }  
     }  
 }  
   
115  SEXP dtrMatrix_as_dgeMatrix(SEXP from)  SEXP dtrMatrix_as_dgeMatrix(SEXP from)
116  {  {
117      SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));      SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
# Line 147  Line 121 
121      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(from, Matrix_xSym)));      SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(from, Matrix_xSym)));
122      /* Dim < 2 can give a seg.fault problem in make_array_triangular(): */      /* Dim < 2 can give a seg.fault problem in make_array_triangular(): */
123      if (LENGTH(GET_SLOT(from, Matrix_DimSym)) < 2)      if (LENGTH(GET_SLOT(from, Matrix_DimSym)) < 2)
124          error("'Dim' slot has length less than two");          error(_(_("'Dim' slot has length less than two")));
125      SET_SLOT(val, Matrix_DimSym,      SET_SLOT(val, Matrix_DimSym,
126               duplicate(GET_SLOT(from, Matrix_DimSym)));               duplicate(GET_SLOT(from, Matrix_DimSym)));
127      SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));      SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
# Line 195  Line 169 
169      double one = 1.;      double one = 1.;
170    
171      if (bdims[0] != k)      if (bdims[0] != k)
172          error("Matrices are not conformable for multiplication");          error(_("Matrices are not conformable for multiplication"));
173      if (m < 1 || n < 1 || k < 1)      if (m < 1 || n < 1 || k < 1)
174          error("Matrices with zero extents cannot be multiplied");          error(_("Matrices with zero extents cannot be multiplied"));
175      F77_CALL(dtrmm)("L", CHAR(asChar(GET_SLOT(a, Matrix_uploSym))), "N",      F77_CALL(dtrmm)("L", CHAR(asChar(GET_SLOT(a, Matrix_uploSym))), "N",
176                      CHAR(asChar(GET_SLOT(a, Matrix_diagSym))),                      CHAR(asChar(GET_SLOT(a, Matrix_diagSym))),
177                      adims, bdims+1, &one,                      adims, bdims+1, &one,
# Line 216  Line 190 
190      double one = 1.;      double one = 1.;
191    
192      if (bdims[0] != k)      if (bdims[0] != k)
193          error("Matrices are not conformable for multiplication");          error(_("Matrices are not conformable for multiplication"));
194      if (m < 1 || n < 1 || k < 1)      if (m < 1 || n < 1 || k < 1)
195          error("Matrices with zero extents cannot be multiplied");          error(_("Matrices with zero extents cannot be multiplied"));
196      F77_CALL(dtrmm)("R", CHAR(asChar(GET_SLOT(a, Matrix_uploSym))), "N",      F77_CALL(dtrmm)("R", CHAR(asChar(GET_SLOT(a, Matrix_uploSym))), "N",
197                      CHAR(asChar(GET_SLOT(a, Matrix_diagSym))),                      CHAR(asChar(GET_SLOT(a, Matrix_diagSym))),
198                      adims, bdims+1, &one,                      adims, bdims+1, &one,

Legend:
Removed from v.581  
changed lines
  Added in v.582

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