SEXP R_blacs_init(SEXP NPROW_in, SEXP NPCOL_in, SEXP ICTXT_in) { R_INIT; SEXP NPROW, NPCOL, ICTXT, MYROW, MYCOL, RET, RET_NAMES; newRvec(NPROW, 1, "int"); newRvec(NPCOL, 1, "int"); newRvec(ICTXT, 1, "int"); newRvec(MYROW, 1, "int"); newRvec(MYCOL, 1, "int"); INT(NPROW) = INT(NPROW_in); INT(NPCOL) = INT(NPCOL_in); INT(ICTXT) = INT(ICTXT_in); char order = 'R'; /* sl_init_(INTP(ICTXT), INTP(NPROW), INTP(NPCOL));*/ Cblacs_get(INT(ICTXT_in), 0, INTP(ICTXT)); Cblacs_gridinit(INTP(ICTXT), &order, INT(NPROW), INT(NPCOL)); Cblacs_gridinfo(INT(ICTXT), INTP(NPROW), INTP(NPCOL), INTP(MYROW), INTP(MYCOL)); RET_NAMES = make_list_names(5, "NPROW", "NPCOL", "ICTXT", "MYROW", "MYCOL"); RET = make_list(RET_NAMES, 5, NPROW, NPCOL, ICTXT, MYROW, MYCOL); R_END; return(RET); }
SEXP R_blacs_gridinit(SEXP NPROW_in, SEXP NPCOL_in, SEXP SHANDLE) { R_INIT; SEXP NPROW, NPCOL, MYROW, MYCOL, RET, RET_NAMES, ICTXT; newRvec(NPROW, 1, "int"); newRvec(NPCOL, 1, "int"); newRvec(MYROW, 1, "int"); newRvec(MYCOL, 1, "int"); newRvec(ICTXT, 1, "int"); INT(NPROW) = INT(NPROW_in); INT(NPCOL) = INT(NPCOL_in); INT(ICTXT) = INT(SHANDLE); char order = 'R'; Cblacs_gridinit(INTP(ICTXT), &order, INT(NPROW), INT(NPCOL)); Cblacs_gridinfo(INT(ICTXT), INTP(NPROW), INTP(NPCOL), INTP(MYROW), INTP(MYCOL)); make_list_names(RET_NAMES, 5, "NPROW", "NPCOL", "ICTXT", "MYROW", "MYCOL"); make_list(RET, RET_NAMES, 5, NPROW, NPCOL, ICTXT, MYROW, MYCOL); R_END; return(RET); }
SEXP R_convert_dense_to_csr(SEXP x) { R_INIT; SEXP data, row_ptr, col_ind; SEXP R_list, R_list_names; const int m = nrows(x), n = ncols(x); int i, j; int row_ptr_len; int sparsity, density; int ct = 0, rct = 0, first; sparsity = sparse_count_zeros_withrows(m, n, &row_ptr_len, REAL(x)); density = m*n - sparsity; newRvec(data, density, "dbl"); newRvec(col_ind, density, "int"); newRvec(row_ptr, m+1, "int"); for (i=0; i<m; i++) { first = true; for (j=0; j<n; j++) { if (MatDBL(x, i, j) > 0.0) { DBL(data, ct) = MatDBL(x, i, j); INT(col_ind, ct) = j+1; ct++; if (first == true) { INT(row_ptr, rct) = ct; first = false; rct++; } } } if (first == true) { INT(row_ptr, rct) = ct+1; rct++; } } INT(row_ptr, m) = ct+1; R_list_names = make_list_names(3, "Data", "row_ptr", "col_ind"); R_list = make_list(R_list_names, 3, data, row_ptr, col_ind); R_END; return R_list; }
/* SVD */ SEXP R_PDGESVD(SEXP M, SEXP N, SEXP ASIZE, SEXP A, SEXP DESCA, SEXP ULDIM, SEXP DESCU, SEXP VTLDIM, SEXP DESCVT, SEXP JOBU, SEXP JOBVT, SEXP INPLACE) { R_INIT; double *A_OUT; int IJ = 1, temp_lwork = -1; double temp_A = 0, temp_work = 0, *WORK; SEXP RET, RET_NAMES, INFO, D, U, VT; newRvec(INFO, 1, "int"); newRvec(D, INT(ASIZE, 0), "dbl"); newRmat(U, INT(ULDIM, 0), INT(ULDIM, 1), "dbl"); newRmat(VT, INT(VTLDIM, 0), INT(VTLDIM, 1), "dbl"); // Query size of workspace INT(INFO, 0) = 0; pdgesvd_(STR(JOBU, 0), STR(JOBVT, 0), INTP(M), INTP(N), &temp_A, &IJ, &IJ, INTP(DESCA), &temp_A, &temp_A, &IJ, &IJ, INTP(DESCU), &temp_A, &IJ, &IJ, INTP(DESCVT), &temp_work, &temp_lwork, INTP(INFO)); // Allocate work vector and calculate svd temp_lwork = (int) temp_work; temp_lwork = nonzero(temp_lwork); WORK = (double *) R_alloc(temp_lwork, sizeof(double)); A_OUT = (double *) R_alloc(nrows(A)*ncols(A), sizeof(double)); memcpy(A_OUT, REAL(A), nrows(A)*ncols(A)*sizeof(double)); pdgesvd_(STR(JOBU, 0), STR(JOBVT, 0), INTP(M), INTP(N), A_OUT, &IJ, &IJ, INTP(DESCA), REAL(D), REAL(U), &IJ, &IJ, INTP(DESCU), REAL(VT), &IJ, &IJ, INTP(DESCVT), WORK, &temp_lwork, INTP(INFO)); // Manage return RET_NAMES = make_list_names(4, "info", "d", "u", "vt"); RET = make_list(RET_NAMES, 4, INFO, D, U, VT); R_END; return RET; }
// Condition # estimator for triangular matrix SEXP R_PDTRCON(SEXP TYPE, SEXP UPLO, SEXP DIAG, SEXP N, SEXP A, SEXP DESCA) { R_INIT; double* work; double tmp; int* iwork; int lwork, liwork, info = 0; int IJ = 1, in1 = -1; SEXP RET; newRvec(RET, 2, "dbl"); // workspace query and allocate work vectors pdtrcon_(CHARPT(TYPE, 0), CHARPT(UPLO, 0), CHARPT(DIAG, 0), INTP(N), DBLP(A), &IJ, &IJ, INTP(DESCA), DBLP(RET), &tmp, &in1, &liwork, &in1, &info); lwork = (int) tmp; work = malloc(lwork * sizeof(*work)); iwork = malloc(liwork * sizeof(*iwork)); // compute inverse of condition number info = 0; pdtrcon_(CHARPT(TYPE, 0), CHARPT(UPLO, 0), CHARPT(DIAG, 0), INTP(N), DBLP(A), &IJ, &IJ, INTP(DESCA), DBLP(RET), work, &lwork, iwork, &liwork, &info); DBL(RET, 1) = (double) info; free(work); free(iwork); R_END; return RET; }
SEXP R_optimal_grid(SEXP NPROCS) { R_INIT; SEXP NPROW, NPCOL, RET, RET_NAMES; newRvec(NPROW, 1, "int", TRUE); newRvec(NPCOL, 1, "int", TRUE); optimalgrid_(INTP(NPROCS), INTP(NPROW), INTP(NPCOL)); RET_NAMES = make_list_names(2, "nprow", "npcol"); RET = make_list(RET_NAMES, 2, NPROW, NPCOL); R_END; return RET; }
/* LU factorization */ SEXP R_PDGETRF(SEXP M, SEXP N, SEXP A, SEXP CLDIM, SEXP DESCA, SEXP LIPIV) { R_INIT; int *ipiv; int IJ = 1; SEXP RET, RET_NAMES, INFO, C; newRvec(INFO, 1, "int"); newRmat(C, INT(CLDIM, 0), INT(CLDIM, 1), "dbl"); // A = LU memcpy(DBLP(C), DBLP(A), nrows(A)*ncols(A)*sizeof(double)); INT(INFO, 0) = 0; INT(LIPIV) = nonzero(INT(LIPIV)); ipiv = (int*) R_alloc(INT(LIPIV), sizeof(int)); pdgetrf_(INTP(M), INTP(N), DBLP(C), &IJ, &IJ, INTP(DESCA), ipiv, INTP(INFO)); // Manage return RET_NAMES = make_list_names(2, "info", "A"); RET = make_list(RET_NAMES, 2, INFO, C); R_END; return RET; }
SEXP R_blacs_init(SEXP NPROW_in, SEXP NPCOL_in, SEXP ICTXT_in) { R_INIT; SEXP SHANDLE; newRvec(SHANDLE, 1, "int"); Cblacs_get(INT(ICTXT_in), 0, INTP(SHANDLE)); R_END; return(R_blacs_gridinit(NPROW_in, NPCOL_in, SHANDLE)); }
SEXP R_NUMROC(SEXP N, SEXP NB, SEXP IPROC, SEXP NPROCS) { R_INIT; SEXP NUM; newRvec(NUM, 1, "int"); numrocwrap_(INTP(N), INTP(NB), INTP(IPROC), INTP(NPROCS), INTP(NUM)); R_END; return NUM; }
SEXP R_PDCLVAR(SEXP X, SEXP DESCX, SEXP LSD) { R_INIT; SEXP VAR; newRvec(VAR, INT(LSD, 0), "dbl"); pdclvar_(REAL(X), INTEGER(DESCX), REAL(VAR)); R_END; return VAR; }
// Matrix norms SEXP R_PDLANGE(SEXP TYPE, SEXP M, SEXP N, SEXP A, SEXP DESCA) { R_INIT; int IJ = 1; SEXP VAL; newRvec(VAL, 1, "dbl"); matnorm_(DBLP(VAL), STR(TYPE, 0), INTP(M), INTP(N), DBLP(A), &IJ, &IJ, INTP(DESCA)); R_END; return VAL; }
SEXP R_descinit(SEXP DIM, SEXP BLDIM, SEXP ICTXT, SEXP LLD) { R_INIT; int row_col_src = 0; int info = 0; SEXP desc; newRvec(desc, 9, "int"); descinit_(INTP(desc), INTP(DIM), INTP(DIM)+1, INTP(BLDIM), INTP(BLDIM)+1, &row_col_src, &row_col_src, INTP(ICTXT), INTP(LLD), &info); R_END; return desc; }
/* Matrix inverse */ SEXP R_PDGETRI(SEXP A, SEXP DESCA) { R_INIT; int IJ = 1; SEXP RET, RET_NAMES, INFO, INV; newRvec(INFO, 1, "int"); newRmat(INV, nrows(A), ncols(A), "dbl"); // Compute inverse pdinv_(DBLP(A), &IJ, &IJ, INTP(DESCA), DBLP(INV), INTP(INFO)); // Manage return RET_NAMES = make_list_names(2, "info", "A"); RET = make_list(RET_NAMES, 2, INFO, INV); R_END; return RET; }
/* Solving systems of linear equations */ SEXP R_PDGESV(SEXP N, SEXP NRHS, SEXP MXLDIMS, SEXP A, SEXP DESCA, SEXP B, SEXP DESCB) { R_INIT; int IJ = 1; int * ipiv; double *A_cp; SEXP RET, RET_NAMES, INFO, B_OUT; newRvec(INFO, 1, "int"); newRmat(B_OUT, nrows(B), ncols(B), "dbl"); // Copy A and B since pdgesv writes in place A_cp = (double *) R_alloc(nrows(A)*ncols(A), sizeof(double)); //FIXME check returns... memcpy(A_cp, DBLP(A), nrows(A)*ncols(A)*sizeof(double)); memcpy(DBLP(B_OUT), DBLP(B), nrows(B)*ncols(B)*sizeof(double)); // Call pdgesv ipiv = (int *) R_alloc(INT(MXLDIMS, 0) + INT(DESCA, 5), sizeof(int)); /* ipiv = (int *) R_alloc(nrows(B) + INT(DESCA, 5), sizeof(int));*/ INT(INFO, 0) = 0; pdgesv_(INTP(N), INTP(NRHS), A_cp, &IJ, &IJ, INTP(DESCA), ipiv, DBLP(B_OUT), &IJ, &IJ, INTP(DESCB), INTP(INFO)); // Manage return RET_NAMES = make_list_names(2, "info", "B"); RET = make_list(RET_NAMES, 2, INFO, B_OUT); R_END; return RET; }
/* Cholesky */ SEXP R_PDPOTRF(SEXP N, SEXP A, SEXP DESCA, SEXP UPLO) { R_INIT; int IJ = 1; SEXP RET, RET_NAMES, INFO, C; newRvec(INFO, 1, "int"); newRmat(C, nrows(A), ncols(A), "dbl"); // Compute chol memcpy(DBLP(C), DBLP(A), nrows(A)*ncols(A)*sizeof(double)); INT(INFO, 0) = 0; pdpotrf_(STR(UPLO, 0), INTP(N), DBLP(C), &IJ, &IJ, INTP(DESCA), INTP(INFO)); // Manage return RET_NAMES = make_list_names(2, "info", "A"); RET = make_list(RET_NAMES, 2, INFO, C); R_END; return(RET); }
// next best divisor function SEXP R_nbd(SEXP N, SEXP D) { R_INIT; int i, test; const int n = INT(N); const int d = INT(D); SEXP RET; newRvec(RET, 1, "int"); INT(RET) = d; for (i=INT(RET, 0); i<=n; i++) { test = n % i; if (test == 0){ INT(RET) = i; break; } } R_END; return RET; }
// Condition # estimator for general matrix SEXP R_PDGECON(SEXP TYPE, SEXP M, SEXP N, SEXP A, SEXP DESCA) { R_INIT; int IJ = 1; double* cpA; int info = 0; const int m = nrows(A); const int n = ncols(A); SEXP RET; newRvec(RET, 2, "dbl"); // RET = {cond_num, info} cpA = malloc(m*n * sizeof(*cpA)); memcpy(cpA, DBLP(A), m*n*sizeof(*cpA)); // compute inverse of condition number condnum_(CHARPT(TYPE, 0), INTP(M), INTP(N), cpA, &IJ, &IJ, INTP(DESCA), DBLP(RET), &info); DBL(RET, 1) = (double) info; free(cpA); R_END; return RET; }
/* Symmetric Eigen */ SEXP R_PDSYEVR(SEXP JOBZ, SEXP UPLO, SEXP N, SEXP A, SEXP DESCA, SEXP DESCZ) { R_INIT; SEXP RET, RET_NAMES, INFO, W, Z; char range = 'A'; int IJ = 1; int lwork = -1; int *iwork; int liwork = -1; double temp_work = 0; double *work; double *A_cp; double tmp = 0; int itmp = 0; int m, nz; newRvec(INFO, 1, "int"); INT(INFO, 0) = 0; newRvec(W, INT(N, 0), "dbl"); newRmat(Z, nrows(A), ncols(A), "dbl"); /* Query size of workspace */ // pdsyev_(CHARPT(JOBZ, 0), CHARPT(UPLO, 0), INTP(N), // &tmp, &IJ, &IJ, INTP(DESCA), // &tmp, &tmp, &IJ, &IJ, INTP(DESCZ), // &temp_work, &lwork, INTP(INFO)); pdsyevr_(CHARPT(JOBZ, 0), &range, CHARPT(UPLO, 0), INTP(N), &tmp, &IJ, &IJ, INTP(DESCA), &tmp, &tmp, &itmp, &itmp, &m, &nz, DBLP(W), DBLP(Z), &IJ, &IJ, INTP(DESCZ), &temp_work, &lwork, &liwork, &liwork, INTP(INFO)); /* Allocate workspace and calculate */ const size_t size = nrows(A)*ncols(A); A_cp = (double *) R_alloc(size, sizeof(*A_cp)); memcpy(A_cp, DBLP(A), size*sizeof(*A_cp)); lwork = (int) temp_work; lwork = nonzero(lwork); work = (double *) R_alloc(lwork, sizeof(*work)); liwork = nonzero(liwork); iwork = (int *) R_alloc(liwork, sizeof(*iwork)); pdsyevr_(CHARPT(JOBZ, 0), &range, CHARPT(UPLO, 0), INTP(N), A_cp, &IJ, &IJ, INTP(DESCA), &tmp, &tmp, &itmp, &itmp, &m, &nz, DBLP(W), DBLP(Z), &IJ, &IJ, INTP(DESCZ), work, &lwork, iwork, &liwork, INTP(INFO)); // pdsyev_(CHARPT(JOBZ, 0), CHARPT(UPLO, 0), INTP(N), // A_cp, &IJ, &IJ, INTP(DESCA), // DBLP(W), DBLP(Z), &IJ, &IJ, INTP(DESCZ), // work, &lwork, INTP(INFO)); // Manage return RET_NAMES = make_list_names(3, "values", "vectors", "info"); RET = make_list(RET_NAMES, 3, W, Z, INFO); R_END; return RET; }
// The beast SEXP R_PDSYEVX(SEXP JOBZ, SEXP RANGE, SEXP N, SEXP A, SEXP DESCA, SEXP VL, SEXP VU, SEXP IL, SEXP IU, SEXP ABSTOL, SEXP ORFAC) { R_INIT; char uplo = 'U'; int IJ = 1; int i; int m, nz; int lwork, liwork, info; int descz[9], ldm[2], blacs[5]; int tmp_liwork; int *iwork, *ifail, *iclustr; double tmp_lwork; double *work; double *w, *z, *gap; double *a; SEXP RET, RET_NAMES, W, Z, M; // grid and local information pdims_(INTEGER(DESCA), ldm, blacs); ldm[0] = nrows(A);//nonzero(ldm[0]); ldm[1] = ncols(A);//nonzero(ldm[1]); // Setup for the setup for (i=0; i<9; i++) descz[i] = INT(DESCA, i); w = (double*) R_alloc(INT(N), sizeof(double)); z = (double*) R_alloc(ldm[0]*ldm[1], sizeof(double)); gap = (double*) R_alloc(blacs[1]*blacs[2], sizeof(double)); a = (double*) R_alloc(ldm[0]*ldm[1], sizeof(double)); memcpy(a, DBLP(A), nrows(A)*ncols(A)*sizeof(double)); ifail = (int*) R_alloc(INT(N, 0), sizeof(int)); iclustr = (int*) R_alloc(2*blacs[1]*blacs[2], sizeof(int)); // Allocate local workspace lwork = -1; liwork = -1; info = 0; pdsyevx_(CHARPT(JOBZ, 0), CHARPT(RANGE, 0), &uplo, INTP(N), a, &IJ, &IJ, INTP(DESCA), DBLP(VL), DBLP(VU), INTP(IL), INTP(IU), DBLP(ABSTOL), &m, &nz, w, DBLP(ORFAC), z, &IJ, &IJ, descz, &tmp_lwork, &lwork, &tmp_liwork, &liwork, ifail, iclustr, gap, &info); lwork = nonzero( ((int) tmp_lwork) ); work = (double*) R_alloc(lwork, sizeof(double)); liwork = nonzero(tmp_liwork); iwork = (int*) R_alloc(liwork, sizeof(int)); // Compute eigenvalues m = 0; info = 0; pdsyevx_(CHARPT(JOBZ, 0), CHARPT(RANGE, 0), &uplo, INTP(N), a, &IJ, &IJ, INTP(DESCA), DBLP(VL), DBLP(VU), INTP(IL), INTP(IU), DBLP(ABSTOL), &m, &nz, w, DBLP(ORFAC), z, &IJ, &IJ, descz, work, &lwork, iwork, &liwork, ifail, iclustr, gap, &info); newRvec(W, m, "dbl"); for (i=0; i<m; i++) DBL(W, i) = w[i]; /* SEXP IFAIL;*/ /* PROTECT(IFAIL = allocVector(INTSXP, m));*/ /* for (i=0; i<m; i++)*/ /* INTEGER(IFAIL)[0] = ifail[i];*/ // Manage the return if (CHARPT(JOBZ, 0)[0] == 'N') // Only eigenvalues are computed { RET_NAMES = make_list_names(1, "values"); RET = make_list(RET_NAMES, 1, W); } else // eigenvalues + eigenvectors { newRmat(Z, ldm[0], ldm[1], "dbl"); for (i=0; i<ldm[0]*ldm[1]; i++) DBL(Z, i) = z[i]; newRvec(M, 1, "int"); INT(M, 0) = m; RET_NAMES = make_list_names(3, "values", "vectors", "m"); RET = make_list(RET_NAMES, 3, W, Z, M); } R_END; return RET; }