SEXP R_zgeev(SEXP JOBVL, SEXP JOBVR, SEXP N,
SEXP A, SEXP LDA,
SEXP W, SEXP VL, SEXP LDVL, SEXP VR, SEXP LDVR,
SEXP WORK, SEXP LWORK, SEXP RWORK,
SEXP INFO){
int n = INTEGER(N)[0], total_length;
SEXP T;
char CS_JOBVL = CHARPT(JOBVL, 0)[0], CS_JOBVR = CHARPT(JOBVR, 0)[0];
/* Protect R objects. */
PROTECT(T = allocMatrix(CPLXSXP, n, n));
/* COpy A and B since zgges writes in place. */
total_length = n * n;
Memcpy(COMPLEX(T), COMPLEX(A), total_length);
/* Call Fortran. */
if(CS_JOBVL == 'V' && CS_JOBVR == 'V'){
F77_CALL(zgeev)("V", "V",
INTEGER(N), COMPLEX(T), INTEGER(LDA),
COMPLEX(W), COMPLEX(VL), INTEGER(LDVL),
COMPLEX(VR), INTEGER(LDVR), COMPLEX(WORK),
INTEGER(LWORK),
REAL(RWORK), INTEGER(INFO));
} else if(CS_JOBVL == 'N' && CS_JOBVR == 'V'){
F77_CALL(zgeev)("N", "V",
INTEGER(N), COMPLEX(T), INTEGER(LDA),
COMPLEX(W), COMPLEX(VL), INTEGER(LDVL),
COMPLEX(VR), INTEGER(LDVR), COMPLEX(WORK),
INTEGER(LWORK),
REAL(RWORK), INTEGER(INFO));
} else if(CS_JOBVL == 'V' && CS_JOBVR == 'N'){
F77_CALL(zgeev)("V", "N",
INTEGER(N), COMPLEX(T), INTEGER(LDA),
COMPLEX(W), COMPLEX(VL), INTEGER(LDVL),
COMPLEX(VR), INTEGER(LDVR), COMPLEX(WORK),
INTEGER(LWORK),
REAL(RWORK), INTEGER(INFO));
} else if(CS_JOBVL == 'N' && CS_JOBVR == 'N'){
F77_CALL(zgeev)("N", "N",
INTEGER(N), COMPLEX(T), INTEGER(LDA),
COMPLEX(W), COMPLEX(VL), INTEGER(LDVL),
COMPLEX(VR), INTEGER(LDVR), COMPLEX(WORK),
INTEGER(LWORK),
REAL(RWORK), INTEGER(INFO));
} else{
REprintf("Input (CHARACTER) types are not implemented.\n");
}
/* Return. */
UNPROTECT(1);
return(R_NilValue);
} /* End of R_zgeev(). */
// wc -l basically
SEXP pbddemo_linecount(SEXP file)
{
SEXP ret;
int i;
int nlines = 0;
size_t readsize;
char *buf = malloc(BUFLEN);
FILE *fp = fopen(CHARPT(file, 0), "r");
while (1)
{
readsize = fread(buf, 1, BUFLEN, fp);
for (i=0; i<readsize; i++)
{
if (buf[i] == '\n')
nlines++;
}
if (readsize < BUFLEN)
break;
}
fclose(fp);
free(buf);
PROTECT(ret = allocVector(INTSXP, 1));
INTEGER(ret)[0] = nlines;
UNPROTECT(1);
return ret;
}
SEXP R_PDCHTRI(SEXP UPLO, SEXP A, SEXP ALDIM, SEXP DESCA, SEXP CLDIM, SEXP DESCC)
{
int IJ = 1;
const int m = INTEGER(ALDIM)[0], n = INTEGER(ALDIM)[1];
double *A_cp;
int info = 0;
SEXP C;
PROTECT(C = allocMatrix(REALSXP, INTEGER(CLDIM)[0], INTEGER(CLDIM)[1]));
A_cp = (double *) R_alloc(m*n, sizeof(double));
memcpy(A_cp, REAL(A), m*n*sizeof(double));
pdchtri_(CHARPT(UPLO, 0), A_cp, &IJ, &IJ, INTEGER(DESCA),
REAL(C), &IJ, &IJ,
INTEGER(DESCC), &info);
if (info != 0)
{
//FIXME replace with appropriate COMM_WARN
Rprintf("INFO = %d\n", info);
}
UNPROTECT(1);
return(C);
}
SEXP ng_process(SEXP R_str, SEXP R_str_len, SEXP n_)
{
char *str;
const int n = INTEGER(n_)[0];
wordlist_t *wl;
ngramlist_t *ngl;
const size_t len = INTEGER(R_str_len)[0] +1 ;
SEXP RET, RET_NAMES, NGSIZE;
SEXP str_ptr, wl_ptr, ngl_ptr;
str = malloc(len * sizeof(str));
strncpy(str, CHARPT(R_str, 0), len);
wl = lex(str, len-1);
ngl = process(wl, n);
if (NULL == ngl)
{
PROTECT(RET = allocVector(INTSXP, 1));
INTEGER(RET)[0] = -1;
UNPROTECT(1);
free(str);
return RET;
}
newRptr(str, str_ptr, str_finalize);
newRptr(wl, wl_ptr, wl_finalize);
newRptr(ngl, ngl_ptr, ngl_finalize);
// Wrangle the list
PROTECT(NGSIZE = allocVector(INTSXP, 1));
INTEGER(NGSIZE)[0] = ngl->ngsize;
PROTECT(RET = allocVector(VECSXP, 4));
PROTECT(RET_NAMES = allocVector(STRSXP, 4));
SET_VECTOR_ELT(RET, 0, str_ptr);
SET_VECTOR_ELT(RET, 1, wl_ptr);
SET_VECTOR_ELT(RET, 2, ngl_ptr);
SET_VECTOR_ELT(RET, 3, NGSIZE);
SET_STRING_ELT(RET_NAMES, 0, mkChar("str_ptr"));
SET_STRING_ELT(RET_NAMES, 1, mkChar("wl_ptr"));
SET_STRING_ELT(RET_NAMES, 2, mkChar("ngl_ptr"));
SET_STRING_ELT(RET_NAMES, 3, mkChar("ngsize"));
setAttrib(RET, R_NamesSymbol, RET_NAMES);
UNPROTECT(6);
return RET;
}
SEXP R_PDLAPRNT(SEXP M, SEXP N, SEXP A, SEXP DESCA, SEXP CMATNM, SEXP NOUT)
{
double work[INTEGER(DESCA)[8]];
int IJ = 1;
int SRC = 0;
bprnt_(INTEGER(M), INTEGER(N), REAL(A), &IJ, &IJ,
INTEGER(DESCA), &SRC, &SRC, CHARPT(CMATNM, 0),
INTEGER(NOUT), work);
return RNULL;
}
// 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_dgsum2d1(SEXP ICTXT, SEXP SCOPE, SEXP M, SEXP N, SEXP A, SEXP LDA, SEXP RDEST, SEXP CDEST)
{
const int m = INT(M, 0), n = INT(N, 0);
char top = ' ';
SEXP OUT;
PROTECT(OUT = allocMatrix(REALSXP, m, n));
memcpy(REAL(OUT), REAL(A), m*n*sizeof(double));
Cdgsum2d(INTEGER(ICTXT)[0], CHARPT(SCOPE, 0), &top, m, n, REAL(OUT),
INTEGER(LDA)[0], INTEGER(RDEST)[0], INTEGER(CDEST)[0]);
UNPROTECT(1);
return(OUT);
}
SEXP R_zmq_disconnect(SEXP R_socket, SEXP R_endpoint){
int C_ret = -1, C_errno;
void *C_socket = R_ExternalPtrAddr(R_socket);
const char *C_endpoint = CHARPT(R_endpoint, 0);
if(C_socket != NULL){
C_ret = zmq_disconnect(C_socket, C_endpoint);
if(C_ret == -1){
C_errno = zmq_errno();
warning("R_zmq_disconnect errno: %d strerror: %s\n",
C_errno, zmq_strerror(C_errno));
}
} else{
warning("R_zmq_disconnect: C_socket is not available.\n");
}
return(AsInt(C_ret));
} /* End of R_zmq_disconnect(). */
SEXP R_igamn2d1(SEXP ICTXT, SEXP SCOPE, SEXP M, SEXP N, SEXP A, SEXP LDA, SEXP RDEST, SEXP CDEST)
{
const int m = INTEGER(M)[0], n = INTEGER(N)[0];
char top = ' ';
int rcflag = -1;
SEXP OUT;
PROTECT(OUT = allocMatrix(INTSXP, m, n));
memcpy(INTEGER(OUT), INTEGER(A), m*n*sizeof(int));
Cigamn2d(INTEGER(ICTXT)[0], CHARPT(SCOPE, 0), &top, m, n, INTEGER(OUT),
INTEGER(LDA)[0], &rcflag, &rcflag, rcflag, INTEGER(RDEST)[0], INTEGER(CDEST)[0]);
UNPROTECT(1);
return(OUT);
}
/**
* Define attributes in the bp file
*/
SEXP R_define_attr(SEXP R_group,
SEXP R_attrname,
SEXP R_nelems,
SEXP R_values)
{
int64_t m_adios_group = (int64_t)(REAL(R_group)[0]);
const char *attrname = CHARPT(R_attrname, 0);
int nelems = asInteger(R_nelems);
char **values;
values = malloc(nelems);
int i;
for(i = 0; i < nelems; i++)
values[i] = (char*)CHAR(STRING_ELT(R_values,i));
adios_define_attribute_byvalue(m_adios_group,
attrname, "",
adios_string_array,
nelems,
values);
return R_NilValue;
}
/**
* ADIOS init and create group etc.
* Return: pointer to the ADIOS group structure
*/
SEXP R_create(SEXP R_groupname,
SEXP R_buffersize,
SEXP R_comm)
{
const char *groupname = CHARPT(R_groupname, 0);
int buffer = asInteger(R_buffersize);
MPI_Comm comm = MPI_Comm_f2c(INTEGER(R_comm)[0]);
int64_t m_adios_group;
adios_init_noxml (comm);
adios_set_max_buffer_size (buffer); // Default buffer size for write is 20. User can change this value
adios_declare_group (&m_adios_group, groupname, "", adios_flag_yes);
adios_select_method (m_adios_group, "MPI", "", ""); // Default method is MPI. Let users choose different methods later.
// Pass group pointer to R
SEXP R_group = PROTECT(allocVector(REALSXP, 1));
REAL(R_group)[0] = (double)m_adios_group;
UNPROTECT(1);
return R_group;
}
SEXP R_zmq_setsockopt(SEXP R_socket, SEXP R_option_name, SEXP R_option_value,
SEXP R_option_type){
int C_ret = -1, C_errno;
int C_option_name = INTEGER(R_option_name)[0];
int C_option_type = INTEGER(R_option_type)[0];
void *C_socket = R_ExternalPtrAddr(R_socket);
void *C_option_value;
size_t C_option_len;
if(C_socket != NULL){
switch(C_option_type){
case 0:
C_option_value = (void *) CHARPT(R_option_value, 0);
C_option_len = strlen(C_option_value);
break;
case 1:
C_option_value = (void *) INTEGER(R_option_value);
C_option_len = sizeof(int);
break;
default:
warning("C_option_type: %d is not implemented.\n",
C_option_type);
} // End of switch().
C_ret = zmq_setsockopt(C_socket, C_option_name,
C_option_value, C_option_len);
if(C_ret == -1){
C_errno = zmq_errno();
warning("R_zmq_setsockopt errno: %d strerror: %s\n",
C_errno, zmq_strerror(C_errno));
}
} else{
warning("R_zmq_setsockopt: C_socket is not available.\n");
}
return(AsInt(C_ret));
} /* End of R_zmq_setsockopt(). */
// 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;
}
/**
* Define variables and write data
*/
SEXP R_write(SEXP R_filename,
SEXP R_group,
SEXP R_groupname,
SEXP R_nvars, // number of vars
SEXP R_varname_list, // var names
SEXP R_var_list, // var values
SEXP R_varlength_list, // length of var values
SEXP R_ndim, // number of dims
SEXP R_type,
SEXP R_comm,
SEXP R_p,
SEXP R_adios_rank)
{
const char *filename = CHARPT(R_filename, 0);
int64_t m_adios_group = (int64_t)(REAL(R_group)[0]);
const char *groupname = CHARPT(R_groupname, 0);
int nvars = asInteger(R_nvars);
MPI_Comm comm = MPI_Comm_f2c(INTEGER(R_comm)[0]);
int size = asInteger(R_p);
int rank = asInteger(R_adios_rank);
int i, j;
int Global_bounds, Offsets;
uint64_t adios_groupsize, adios_totalsize;
int64_t m_adios_file;
// variable to store the value converted from integer
char str[256];
// Define variables
for(i = 0; i < nvars; i++) {
const char *varname = CHAR(asChar(VECTOR_ELT(R_varname_list,i)));
int *length = INTEGER(VECTOR_ELT(R_varlength_list, i));
int *vndim = INTEGER(VECTOR_ELT(R_ndim, i));
int *typetag = INTEGER(VECTOR_ELT(R_type, i));
if((length[0] == 1) && (vndim[0] == 1)){
// scalar
if(typetag[0] == 0) {
adios_define_var (m_adios_group, varname, "", adios_integer, 0, 0, 0);
}else {
adios_define_var (m_adios_group, varname, "", adios_double, 0, 0, 0);
}
}else {
// define dimensions, global_dimensions, local_offsets and the variable
int temp_var_length = strlen(varname) + 8;
char* local_var = (char*)malloc(vndim[0]*temp_var_length);
char* global_var = (char*)malloc(vndim[0]*temp_var_length);
char* offset_var = (char*)malloc(vndim[0]*temp_var_length);
// initialize char variables
strcpy(local_var, "");
strcpy(global_var, "");
strcpy(offset_var, "");
// j = 0
j = 0;
sprintf(str, "%d", j);
char* local = (char*)malloc(temp_var_length);
strcpy(local, varname);
strcat(local, "_nx_");
strcat(local, str);
strcat(local_var, local);
char* global = (char*)malloc(temp_var_length);
strcpy(global, varname);
strcat(global, "_gx_");
strcat(global, str);
strcat(global_var, global);
char* offset = (char*)malloc(temp_var_length);
strcpy(offset, varname);
strcat(offset, "_off_");
strcat(offset, str);
strcat(offset_var, offset);
// define local dim, global dim and offset for each dimension
adios_define_var (m_adios_group, local,
"", adios_integer, 0, 0, 0);
adios_define_var (m_adios_group, global,
"", adios_integer, 0, 0, 0);
adios_define_var (m_adios_group, offset,
"", adios_integer, 0, 0, 0);
Free(local);
Free(global);
Free(offset);
for(j = 1; j < vndim[0]; j++) {
sprintf(str, "%d", j);
strcat(local_var, ",");
char* local = (char*)malloc(temp_var_length);
strcpy(local, varname);
strcat(local, "_nx_");
strcat(local, str);
strcat(local_var, local);
strcat(global_var, ",");
char* global = (char*)malloc(temp_var_length);
strcpy(global, varname);
strcat(global, "_gx_");
strcat(global, str);
strcat(global_var, global);
strcat(offset_var, ",");
char* offset = (char*)malloc(temp_var_length);
strcpy(offset, varname);
strcat(offset, "_off_");
strcat(offset, str);
strcat(offset_var, offset);
// define local dim, global dim and offset for each dimension
adios_define_var (m_adios_group, local,
"", adios_integer, 0, 0, 0);
adios_define_var (m_adios_group, global,
"", adios_integer, 0, 0, 0);
adios_define_var (m_adios_group, offset,
"", adios_integer, 0, 0, 0);
Free(local);
Free(global);
Free(offset);
}
// define variable
if(typetag[0] == 0) {
adios_define_var (m_adios_group, varname, "", adios_integer,
local_var, global_var, offset_var);
}else {
adios_define_var (m_adios_group, varname, "", adios_double,
local_var, global_var, offset_var);
}
Free(local_var);
Free(global_var);
Free(offset_var);
}
}
// Open ADIOS
adios_open (&m_adios_file, groupname, filename, "w", comm);
adios_groupsize = 0;
for(i = 0; i < nvars; i++) {
int *length = INTEGER(VECTOR_ELT(R_varlength_list, i));
int *vndim = INTEGER(VECTOR_ELT(R_ndim, i));
int *typetag = INTEGER(VECTOR_ELT(R_type, i));
// calculate the length of the variable
int temp = 1;
for(j = 0; j < vndim[0]; j++)
temp *= length[j];
if((length[0] == 1) && (vndim[0] == 1)){
// scalar
if(typetag[0] == 0) {
adios_groupsize += 4;
}else {
adios_groupsize += 8;
}
}else {
if(typetag[0] == 0) {
adios_groupsize += (12 * vndim[0] + temp * 4);
}else {
adios_groupsize += (12 * vndim[0] + temp * 8);
}
}
}
adios_group_size (m_adios_file, adios_groupsize, &adios_totalsize);
// Write data into variables
for(i = 0; i < nvars; i++) {
const char *varname = CHAR(asChar(VECTOR_ELT(R_varname_list,i)));
int *length = INTEGER(VECTOR_ELT(R_varlength_list, i));
int *vndim = INTEGER(VECTOR_ELT(R_ndim, i));
int *typetag = INTEGER(VECTOR_ELT(R_type, i));
if((length[0] == 1) && (vndim[0] == 1)){
// scalar
}else {
// var
int temp_var_length = strlen(varname) + 8;
j = 0;
sprintf(str, "%d", j);
char* local = (char*)malloc(temp_var_length);
strcpy(local, varname);
strcat(local, "_nx_");
strcat(local, str);
char* global = (char*)malloc(temp_var_length);
strcpy(global, varname);
strcat(global, "_gx_");
strcat(global, str);
char* offset = (char*)malloc(temp_var_length);
strcpy(offset, varname);
strcat(offset, "_off_");
strcat(offset, str);
adios_write(m_adios_file, local, (void *) &(length[j]));
Global_bounds = length[j] * size;
adios_write(m_adios_file, global, (void *) &Global_bounds);
Offsets = rank * length[j];
adios_write(m_adios_file, offset, (void *) &Offsets);
Free(local);
Free(global);
Free(offset);
for(j = 1; j < vndim[0]; j++) {
sprintf(str, "%d", j);
char* local = (char*)malloc(temp_var_length);
strcpy(local, varname);
strcat(local, "_nx_");
strcat(local, str);
char* global = (char*)malloc(temp_var_length);
strcpy(global, varname);
strcat(global, "_gx_");
strcat(global, str);
char* offset = (char*)malloc(temp_var_length);
strcpy(offset, varname);
strcat(offset, "_off_");
strcat(offset, str);
adios_write(m_adios_file, local, (void *) &(length[j]));
Global_bounds = length[j];
adios_write(m_adios_file, global, (void *) &Global_bounds);
Offsets = 0;
adios_write(m_adios_file, offset, (void *) &Offsets);
Free(local);
Free(global);
Free(offset);
}
}
// write var data
if(typetag[0] == 0) {
adios_write(m_adios_file, varname, (void *) INTEGER(VECTOR_ELT(R_var_list, i)));
}else {
adios_write(m_adios_file, varname, (void *) REAL(VECTOR_ELT(R_var_list, i)));
}
}
adios_close (m_adios_file);
MPI_Barrier (comm);
return R_NilValue;
}
SEXP papi_event_avail(SEXP which)
{
SEXP val,name,desc;
int i;
int unpt;
int num;
const int which_num = NUM_EVENTS;
SEXP ret;
int papiret;
int id;
PAPI_event_info_t ev;
char *namep;
if(which_num>0 && TYPEOF(which)==STRSXP)
{
num=which_num;
PROTECT(ret=allocVector(VECSXP,3));
PROTECT(name=allocVector(STRSXP,num));
PROTECT(val=allocVector(LGLSXP,num));
PROTECT(desc=allocVector(STRSXP,num));
for (i=0; i<num; i++)
{
namep=CHARPT(which,i);
papiret=PAPI_event_name_to_code(namep,&id);
if(papiret!=PAPI_OK)
{
unpt=i+3;
UNPROTECT(unpt);
return R_papi_error(PAPI_ENOEVNT); // Should we make a custom error?
}
/* TODO: find out what this returns */
PAPI_get_event_info(id,&ev);
LOGICAL(val)[i]=ev.count>0;
SET_STRING_ELT(name, i, mkChar(namep));
SET_STRING_ELT(desc, i, mkChar(ev.long_descr));
}
unpt=4;
}
else /* Get all events */
{
i=num=0;
id=0|PAPI_PRESET_MASK;
PAPI_enum_event(&id,PAPI_ENUM_FIRST);
do
{
num++;
}
while(PAPI_enum_event(&id,PAPI_ENUM_EVENTS)==PAPI_OK); // PAPI_PRESET_ENUM_AVAIL might also be useful
PROTECT(ret=allocVector(VECSXP,3));
PROTECT(name=allocVector(STRSXP,num));
PROTECT(val=allocVector(LGLSXP,num));
PROTECT(desc=allocVector(STRSXP,num));
id=0|PAPI_PRESET_MASK;
PAPI_enum_event(&id,PAPI_ENUM_FIRST);
do
{
PAPI_get_event_info(id,&ev);
LOGICAL(val)[i]=ev.count>0;
SET_STRING_ELT(name, i, mkChar(ev.symbol));
SET_STRING_ELT(desc, i, mkChar(ev.long_descr));
i++;
}
while(PAPI_enum_event(&id,PAPI_ENUM_EVENTS)==PAPI_OK); // PAPI_PRESET_ENUM_AVAIL might also be useful
unpt=4;
}
SET_VECTOR_ELT(ret,0,name);
SET_VECTOR_ELT(ret,1,val);
SET_VECTOR_ELT(ret,2,desc);
UNPROTECT(unpt);
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;
}
SEXP R_ng_asweka(SEXP R_str, SEXP min_n_, SEXP max_n_, SEXP R_sep)
{
int i, j;
char *str = CHARPT(R_str, 0);
char *sep = CHARPT(R_sep, 0);
const int min_n = INTEGER(min_n_)[0];
const int max_n = INTEGER(max_n_)[0];
int str_len;
sentencelist_t *sl;
wordlist_t *wptr;
int numwords;
int cur_n;
size_t len;
const char **starts = NULL;
int *lens = NULL;
int word_i;
char *errstr;
SEXP RET;
str_len = strlen(str);
if(*sep == '\0')
sep=NULL;
sl = lex_simple(str, str_len, sep);
if (sl == NULL)
error("out of memory");
numwords = 0;
for(i=0;i<sl->filled;i++)
for(wptr=sl->words[i];wptr && wptr->word->s;wptr=wptr->next)
numwords++;
if (numwords == 0){
errstr="no words";
goto memerr;
}
len = numwords;
starts = malloc(sizeof(*starts)*numwords);
if (starts == NULL){
errstr="out of memory";
goto memerr;
}
lens = malloc(sizeof(*lens)*numwords);
if (lens == NULL){
errstr="out of memory";
goto memerr;
}
for(i=sl->filled-1;i>=0;i--){
for(wptr=sl->words[i];wptr && wptr->word->s;wptr=wptr->next){
--len;
starts[len]=wptr->word->s;
lens[len]=wptr->word->len;
}
}
i = numwords-(min_n-1);
j = numwords-(max_n-1);
len = i*(i+1)/2 - j*(j-1)/2;
PROTECT(RET = allocVector(STRSXP, len));
word_i = 0;
for(cur_n=max_n;cur_n>=min_n;cur_n--){
for(i=0;i<numwords-(cur_n-1);i++){
len = starts[i+cur_n-1] - starts[i] + lens[i+cur_n-1];
SET_STRING_ELT(RET, word_i, mkCharLen(starts[i], len));
word_i++;
}
}
free(starts);
free(lens);
free_sentencelist(sl,free_wordlist);
UNPROTECT(1);
return RET;
memerr:
freeif(starts);
freeif(lens);
free_sentencelist(sl,free_wordlist);
error(errstr);
}
SEXP getPass_readline_masked(SEXP msg, SEXP showstars_, SEXP noblank_)
{
SEXP ret;
const int showstars = INTEGER(showstars_)[0];
const int noblank = INTEGER(noblank_)[0];
int i = 0;
int j;
char c;
ctrlc = CTRLC_NO; // must be global!
REprintf(CHARPT(msg, 0));
#if !(OS_WINDOWS)
struct termios tp, old;
tcgetattr(STDIN_FILENO, &tp);
old = tp;
tp.c_lflag &= ~(ECHO | ICANON | ISIG);
tcsetattr(0, TCSAFLUSH, &tp);
#if OS_LINUX
signal(SIGINT, ctrlc_handler);
#else
struct sigaction sa;
sa.sa_handler = ctrlc_handler;
sigemptyset(&sa.sa_mask);
sa.sa_flags = 0;
sigaction(SIGINT, &sa, NULL);
#endif
#endif
for (i=0; i<PWLEN; i++)
{
#if OS_WINDOWS
c = _getch();
#else
c = fgetc(stdin);
#endif
// newline
if (c == '\n' || c == '\r')
{
if (noblank && i == 0)
{
i--;
continue;
}
else
break;
}
// backspace
else if (c == '\b' || c == '\177')
{
if (i == 0)
{
i--;
continue;
}
else
{
if (showstars)
REprintf("\b \b");
pw[--i] = '\0';
i--;
}
}
// C-c
else if (ctrlc == CTRLC_YES || c == 3 || c == '\xff')
{
#if !(OS_WINDOWS)
tcsetattr(0, TCSANOW, &old);
#endif
REprintf("\n");
return R_NilValue;
}
// store value
else
{
if (showstars)
REprintf("*");
pw[i] = c;
}
}
#if !(OS_WINDOWS)
tcsetattr(0, TCSANOW, &old);
#endif
if (i == PWLEN)
{
REprintf("\n");
error("character limit exceeded");
}
if (showstars || strncmp(CHARPT(msg, 0), "", 1) != 0)
REprintf("\n");
PROTECT(ret = allocVector(STRSXP, 1));
SET_STRING_ELT(ret, 0, mkCharLen(pw, i));
for (j=0; j<i; j++)
pw[j] = '\0';
UNPROTECT(1);
return ret;
}
