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;
}
