Ejemplo n.º 1
0
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);
}
Ejemplo n.º 2
0
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);
}
Ejemplo n.º 3
0
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;
}
Ejemplo n.º 4
0
/* 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;
} 
Ejemplo n.º 5
0
// 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;
}
Ejemplo n.º 6
0
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;
}
Ejemplo n.º 7
0
/* 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;
}
Ejemplo n.º 8
0
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));
}
Ejemplo n.º 9
0
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;
}
Ejemplo n.º 10
0
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;
} 
Ejemplo n.º 11
0
// 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;
}
Ejemplo n.º 12
0
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;
}
Ejemplo n.º 13
0
/* 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;
}
Ejemplo n.º 14
0
/* 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;
}
Ejemplo n.º 15
0
/* 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);
}
Ejemplo n.º 16
0
// 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;
}
Ejemplo n.º 17
0
// 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;
}
Ejemplo n.º 18
0
/* 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;
} 
Ejemplo n.º 19
0
// 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;
}