SEXP R_p_matexp_pade(SEXP A, SEXP desca, SEXP p)
{
R_INIT;
int m, n;
SEXP N, D;
SEXP RET, RET_NAMES;
m = nrows(A);
n = ncols(A);
// Allocate N and D
newRmat(N, m, n, "dbl");
newRmat(D, m, n, "dbl");
// Compute N and D
p_matexp_pade(DBLP(A), INTP(desca), INT(p, 0), DBLP(N), DBLP(D));
// Wrangle the return
RET_NAMES = make_list_names(2, "N", "D");
RET = make_list(RET_NAMES, 2, N, D);
R_END;
return RET;
}
/* 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;
}
/* 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_PDGEMR2D(SEXP M, SEXP N, SEXP X, SEXP DESCX, SEXP CLDIM, SEXP DESCB, SEXP CTXT)
{
R_INIT;
int IJ = 1;
SEXP C;
newRmat(C, INT(CLDIM, 0), INT(CLDIM, 1), "dbl");
Cpdgemr2d(INT(M), INT(N),
REAL(X), IJ, IJ, INTEGER(DESCX),
REAL(C), IJ, IJ, INTEGER(DESCB), INT(CTXT));
R_END;
return C;
}
SEXP R_convert_csr_to_dense(SEXP dim, SEXP data, SEXP row_ptr, SEXP col_ind)
{
R_INIT;
int i, j;
int c = 0, r = 0, diff;
const int m = INT(dim, 0), n = INT(dim, 1);
SEXP dense_mat;
// Initialize
newRmat(dense_mat, m, n, "dbl");
for (j=0; j<n; j++)
{
for (i=0; i<m; i++)
MatDBL(dense_mat, i, j) = 0.0;
}
// This is disgusting
i = 0;
while (r < m && INT(row_ptr, r) < INT(row_ptr, m))
{
diff = INT(row_ptr, r+1) - INT(row_ptr, r);
if (diff == 0)
goto increment;
else
{
while (diff)
{
j = INT(col_ind, c)-1;
MatDBL(dense_mat, i, j) = DBL(data, c);
c++; // hehehe
diff--;
}
}
increment:
r++;
i++;
}
R_END;
return dense_mat;
}
SEXP R_PDCROSSPROD(SEXP UPLO, SEXP TRANS, SEXP A, SEXP DESCA, SEXP CLDIM, SEXP DESCC)
{
R_INIT;
double alpha = 1.0;
int IJ = 1;
SEXP C;
newRmat(C, INT(CLDIM, 0), INT(CLDIM, 1), "dbl");
pdcrossprod_(STR(UPLO, 0), STR(TRANS, 0), &alpha,
DBLP(A), &IJ, &IJ, INTP(DESCA),
DBLP(C), &IJ, &IJ, INTP(DESCC));
R_END;
return C;
}
/* Reductions */
SEXP R_igsum2d1(SEXP ICTXT, SEXP SCOPE, SEXP M, SEXP N, SEXP A, SEXP LDA, SEXP RDEST, SEXP CDEST)
{
R_INIT;
const int m = INT(M, 0), n = INT(N, 0);
char top = ' ';
SEXP OUT;
newRmat(OUT, m, n, "int");
memcpy(INTP(OUT), INTP(A), m*n*sizeof(int));
Cigsum2d(INT(ICTXT, 0), STR(SCOPE, 0), &top, m, n, INTP(OUT),
INTP(LDA)[0], INTP(RDEST)[0], INTP(CDEST)[0]);
R_END;
return(OUT);
}
SEXP R_matexp(SEXP A, SEXP p)
{
R_INIT;
const int n = nrows(A);
int i;
double *A_cp;
SEXP R;
newRmat(R, n, n, "dbl");
A_cp = (double *) R_alloc(n*n, sizeof(A_cp));
for (i=0; i<n*n; i++)
A_cp[i] = REAL(A)[i];
matexp(n, INT(p), A_cp, REAL(R));
R_END;
return R;
}
SEXP R_p_matpow_by_squaring(SEXP A, SEXP desca, SEXP b)
{
R_INIT;
const int m = nrows(A), n = ncols(A);
double *cpA;
SEXP P;
newRmat(P, nrows(A), ncols(A), "dbl");
// Why did I make a copy ... ? // Oh now I remember
//FIXME check returns...
cpA = malloc(m*n * sizeof(double));
memcpy(cpA, REAL(A), m*n*sizeof(double));
p_matpow_by_squaring(cpA, INTEGER(desca), INT(b, 0), REAL(P));
free(cpA);
R_END;
return(P);
}
/* 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);
}
// 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;
}
/* 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;
}
