The R Project SVN R-packages

Rev

Rev 4529 | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 4529 Rev 4560
Line 1... Line 1...
1 
#include "HBMM.h"
 1 
#include "HBMM.h"
2 
 
 2 
 
3 
#if 0
 - 
 
4 
#include "iohb.h"
 - 
 
5 
#endif
 - 
 
6 
 
 - 
 
7 
#include "mmio.h"
 3 
#include "mmio.h"
8 
 
 4 
 
9 
#if 0
 - 
 
10 
SEXP Matrix_writeHarwellBoeing(SEXP obj, SEXP file, SEXP typep)
 - 
 
11 
{
 - 
 
12 
    char *type = CHAR(asChar(typep)), *Type = strdup("RUA");
 - 
 
13 
    int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)),
 - 
 
14 
	*ii = (int *) NULL, *pp = (int *) NULL;
 - 
 
15 
    int M = dims[0], N = dims[1], nz = -1;
 - 
 
16 
    double *xx = (double *) NULL;
 - 
 
17 
 
 - 
 
18 
    if (type[2] == 'C') {
 - 
 
19 
	SEXP islot = GET_SLOT(obj, Matrix_iSym);
 - 
 
20 
	nz = LENGTH(islot);
 - 
 
21 
	ii = INTEGER(islot);
 - 
 
22 
	pp = INTEGER(GET_SLOT(obj, Matrix_pSym));
 - 
 
23 
    } else error("Only type 'C' allowed");
 - 
 
24 
 
 - 
 
25 
    if (type[0] == 'D') {
 - 
 
26 
	xx = REAL(GET_SLOT(obj, Matrix_xSym));
 - 
 
27 
    } else error("Only real matrices allowed");
 - 
 
28 
 
 - 
 
29 
    if (!isString(file))
 - 
 
30 
	error("non-string values for file not presently accepted");
 - 
 
31 
 
 - 
 
32 
    if (type[1] == 'S') {
 - 
 
33 
	if (*uplo_P(obj) != 'L')
 - 
 
34 
	    error("Symmetric matrices must be stored in lower triangle");
 - 
 
35 
	Type[1] = 'S';
 - 
 
36 
    }
 - 
 
37 
 
 - 
 
38 
    writeHB_mat_double(CHAR(asChar(file)), M, N, nz, pp, ii, xx, 0,
 - 
 
39 
		       (double *)NULL, (double *)NULL, (double *)NULL,
 - 
 
40 
		       "", "", Type, (char*)NULL, (char*)NULL,
 - 
 
41 
		       (char*)NULL, (char*)NULL, "RUA");
 - 
 
42 
 
 - 
 
43 
    Free(Type);
 - 
 
44 
    return R_NilValue;
 - 
 
45 
}
 - 
 
46 
#endif
 - 
 
47 
 
 - 
 
48 
SEXP Matrix_writeMatrixMarket(SEXP obj, SEXP file, SEXP typep)
 5 
SEXP Matrix_writeMatrixMarket(SEXP obj, SEXP file, SEXP typep)
49 
{
 6 
{
50 
    const char *type = CHAR(asChar(typep));
 7 
    const char *type = CHAR(asChar(typep));
51 
    char *ff = strdup(CHAR(asChar(file)));
 8 
    char *ff = strdup(CHAR(asChar(file)));
52 
    int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)),
 9 
    int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)),
Line 58... Line 15...
58 
    mm_set_matrix(&matcode);
 15 
    mm_set_matrix(&matcode);
59 
    if (type[2] == 'C' || type[2] == 'T') {
 16 
    if (type[2] == 'C' || type[2] == 'T') {
60 
	SEXP islot = GET_SLOT(obj, Matrix_iSym);
 17 
	SEXP islot = GET_SLOT(obj, Matrix_iSym);
61 
	nz = LENGTH(islot);
 18 
	nz = LENGTH(islot);
62 
	src = INTEGER(islot);
 19 
	src = INTEGER(islot);
63 
	ii = Calloc(nz, int);
 20 
	ii = Alloca(nz, int);
- 
 
 21 
	R_CheckStack();
64 
	for (i = 0; i < nz; i++) ii[i] = src[i] + 1;
 22 
	for (i = 0; i < nz; i++) ii[i] = src[i] + 1;
65 
	mm_set_coordinate(&matcode);
 23 
	mm_set_coordinate(&matcode);
66 
    } else error("Only types 'C' and 'T' allowed");
 24 
    } else error("Only types 'C' and 'T' allowed");
67 
 
 25 
 
68 
    if (type[0] == 'D') {
 26 
    if (type[0] == 'D') {
Line 76... Line 34...
76 
	mm_set_symmetric(&matcode);
 34 
	mm_set_symmetric(&matcode);
77 
    }
 35 
    }
78 
    if (type[1] == 'G') mm_set_general(&matcode);
 36 
    if (type[1] == 'G') mm_set_general(&matcode);
79 
 
 37 
 
80 
    if (type[2] == 'C') {
 38 
    if (type[2] == 'C') {
- 
 
 39 
	jj = Alloca(nz, int);
- 
 
 40 
	R_CheckStack();
81 
	jj = expand_cmprPt(N, INTEGER(GET_SLOT(obj, Matrix_pSym)),
 41 
	expand_cmprPt(N, INTEGER(GET_SLOT(obj, Matrix_pSym)), jj);
82 
			   Calloc(nz, int));
 - 
 
83 
	for (i = 0; i < nz; i++) jj[i] += 1; /* 1-based indices */
 42 
	for (i = 0; i < nz; i++) jj[i] += 1; /* 1-based indices */
84 
    }
 43 
    }
85 
    if (type[2] == 'T') {
 44 
    if (type[2] == 'T') {
86 
	src = INTEGER(GET_SLOT(obj, Matrix_jSym));
 45 
	src = INTEGER(GET_SLOT(obj, Matrix_jSym));
87 
	jj = Calloc(nz, int);
 46 
	jj = Alloca(nz, int);
- 
 
 47 
	R_CheckStack();
88 
	for (i = 0; i < nz; i++) jj[i] = src[i] + 1;
 48 
	for (i = 0; i < nz; i++) jj[i] = src[i] + 1;
89 
    }
 49 
    }
90 
    if (!jj) error("storage mode must be T or C");
 50 
    if (!jj) error("storage mode must be T or C");
91 
 
 51 
 
92 
    mm_write_mtx_crd(ff, M, N, nz, ii, jj, xx, matcode);
 52 
    mm_write_mtx_crd(ff, M, N, nz, ii, jj, xx, matcode);
93 
 
 53 
 
94 
    Free(ii); Free(jj); free(ff);
 54 
    free(ff);
95 
    return R_NilValue;
 55 
    return R_NilValue;
96 
 
 56 
 
97 
}
 57 
}